/* Define version number and date */ #define __CVERSION__ 7.5700 #define __YEAR__ 2017 #define __MONTH__ 06 #define __DAY__ 02 #define __ICDATE__ 20170602 /* -YYYYMMDD- */ #define __CDATE__ 'JUNE 2, 2017' /* ----+----+----+--- */ *TITLE : CORSIKA __CVERSION__ __DAY__/__MONTH__/__YEAR__ *SVN: $HeadURL: https://devel-ik.fzk.de/svn/mc/corsika/trunk/src/corsika.F $ *REV: $Id: corsika.F 6153 2017-06-02 21:37:50Z pierog $ * *D. HECK AND T.PIEROG, IKP KIT KARLSRUHE *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= C C OOO OOO OOOO OOOO OO O O O C O O O O O O O O OO O O O O C O O O O O O OO O O O O C O O O O O OOOO OO OO O O C O O O OOOO O OO O O OOOOOOO C O O O O O O O O OO O O O O C OOO OOO O O OOOO OO O O O O C C - - - - - - CO(SMIC) R(AY) SI(MULATION FOR) KA(SCADE) - - - - - - - C C C A PROGRAM TO SIMULATE EXTENSIVE AIR SHOWERS IN ATMOSPHERE C C BASED ON A PROGRAM OF P.K.F. GRIEDER, UNIVERSITY BERN, SWITZERLAND C C SELECTABLE INTERACTION MODELS: C C HADRONIC HIGH ENERGY C DPMJET-III MODEL FROM S. ROESLER (CERN), A. FEDYNITCH (DESY), C R. ENGEL (IKP, KIT KARLSRUHE), J. RANFT (UNI. SIEGEN), C EPOS LHC FROM T. PIEROG, KIT, KARLSRUHE, GERMANY, AND K. WERNER, C UNIVERSITY OF NANTES, NANTES, FRANCE C HDPM 'DUAL PARTON MODEL' FROM J.N. CAPDEVIELLE, COLLEGE DE FRANCE, C PARIS, FRANCE C NEXUS FROM K. WERNER ET AL., UNIVERSITY OF NANTES, NANTES, FRANCE C QUARK GLUON STRING MODEL FROM N.N. KALMYKOV AND S.S. OSTAPCHENKO, C MOSCOW STATE UNIVERSITY, MOSCOW, RUSSIA C SIBYLL FROM R. ENGEL, R.S. FLETCHER, T.K. GAISSER, P. LIPARI, T. C STANEV, BARTOL RESEARCH INSTITUTE, UNIVERSITY OF DELAWARE, C NEWARK, USA C VENUS FROM K. WERNER, UNIVERSITY OF NANTES, NANTES, FRANCE C C HADRONIC LOW ENERGY C FLUKA MODEL FROM A. FASSO (CERN), A. FERRARI, J. RANFT (SIEGEN), C P. SALA, INFN MILAN, MILAN, ITALY C GHEISHA (CERN VERSION) FROM H. FESEFELDT, UNIVERSITY OF AACHEN, C AACHEN, GERMANY C URQMD MODEL FROM URQMD COLLABORATION, UNIVERSITY FRANKFURT, C FRANKFURT (MAIN), GERMANY C C ELECTROMAGNETIC ALL ENERGIES C EGS4 FROM W.R. NELSON, H. HIRAYAMA, W.O. ROGERS, C SLAC, STANFORD, USA C NKG FORMULAS FOR SIMULATION OF ELECTROMAGNETIC PARTICLES C C KARLSRUHER INSTITUT FUER TECHNOLIGIE (KIT) C INSTITUT FUER KERNPHYSIK C POSTFACH 3640 C D-76021 KARLSRUHE C GERMANY C C----------------------------------------------------------------------- C COPYRIGHT AND ANY OTHER APPROPRIATE LEGAL PROTECTION OF THESE C COMPUTER PROGRAMS AND ASSOCIATED DOCUMENTATION RESERVED IN ALL C COUNTRIES OF THE WORLD. C C THESE PROGRAMS OR DOCUMENTATION MAY NOT BE REPRODUCED BY ANY METHOD C WITHOUT PRIOR WRITTEN CONSENT OF FORSCHUNGSZENTRUM KARLSRUHE OR ITS C DELEGATE. C C KARLSRUHE INSTITUTE OF TECHNOLOGY WELCOMES COMMENTS CONCERNING THE C CORSIKA CODE BUT UNDERTAKES NO OBLIGATION FOR MAINTENANCE OF THE C PROGRAMS, NOR RESPONSIBILITY FOR THEIR CORRECTNESS, AND ACCEPTS NO C LIABILITY WHATSOEVER RESULTING FROM THE USE OF ITS PROGRAMS. C C----------------------------------------------------------------------- C IN CASE OF PROBLEMS CONTACT: C C T. PIEROG C E-MAIL: TANGUY.PIEROG@KIT.EDU C FAX: (49) 721-608-24075 C TEL: (49) 721-608-28134 C C OR C D. HECK C E-MAIL: DIETER.HECK@PARTNER.KIT.EDU C FAX: (49) 721-608-24075 C TEL: (49) 721-608-23777 C C PLEASE ASK FOR UPDATED VERSIONS OF THE PROGRAM C OR LOOK AT https://www.ikp.kit.edu/corsika/ C----------------------------------------------------------------------- *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= C C OPTIONS C ======= C C HERE ARE ALL THE AVAILABLE CPP OPTIONS: C----------------------------------------------------------------------- C COMPUTER OPTIONS C MAC VERSION FOR APPLE MACINTOSH UNDER SYSTEM 7 C UNIX VERSION FOR VARIOUS WORKSTATIONS AND PC''S LIKE C DEC STATIONS UNDER ULTRIX, C ALPHA STATIONS UNDER DEC UNIX (TRU64), C PC''S UNDER LINUX, ETC. C BYTERECL VERSION WITH RECL PARAMETER IN BYTES C (DEFAULT IS (4-BYTE) WORDS WHICH IS C APPRPRIATE FOR DEC FORTRAN COMPILERS; C USE BYTERECL FOR ABOUT ANYTHING ELSE). C OLDDATE VERSION USING OLD DATE AND TIME ROUTINES WHICH ARE C NOT Y2K COMPLIANT. C (DEFAULT IS NEW 'DATE_AND_TIME' ROUTINE) C OLDDATE2 VERSION USING OLD DATE AND TIME ROUTINES FOR LINUX C BETA WHICH ARE NOT Y2K COMPLIANT. C (DEFAULT IS NEW 'DATE_AND_TIME' ROUTINE) C TIMERC VERSION USING C-ROUTINE 'TIMERC' FOR DATE AND TIME C----------------------------------------------------------------------- C HADRONIC INTERACTION MODEL OPTIONS C DPMJET VERSION USING DPMJET MODEL FOR HIGH ENERGY HAD. INTER. C EPOS VERSION USING EPOS FOR HIGH ENERGY HAD. INTERACTIONS C NEXUS VERSION USING NEXUS FOR HIGH ENERGY HAD. INTERACTIONS C QGSJET VERSION USING QGSJET MODEL FOR HIGH ENERGY HAD. INTER. C (QGSJETOLD) DEFAULT USING QGSJET WITH PARAMETERS OF OLD QGSJET C !QGSJETOLD VERSION USING QGSJET WITH MODIFIED N&O CROSS-SECTIONS C (KALMYKOV EFFECT) C QGSII VERSION USING QGSJET II C SIBYLL VERSION USING SIBYLL FOR HIGH ENERGY HAD. INTERACTIONS C VENUS VERSION USING VENUS FOR HIGH ENERGY HAD. INTERACTIONS C C FLUKA VERSION USING FLUKA FOR LOW ENERGY HAD. INTERACTIONS C GHEISHA VERSION USING GHEISHA FOR LOW ENERGY HAD. INTERACTIONS C URQMD VERSION USING URQMD FOR LOW ENERGY HAD. INTERACTIONS C----------------------------------------------------------------------- C OTHER OPTIONS C ANAHIST VERSION PRODUCING HISTOGRAMS OF SHOWER ANALYSIS C ATMEXT VERSION USING TABULATED MODTRAN ATMOSPHERE C (IN CONNECTION WITH CHERENKOV OPTION) C AUGCERLONG VERSION PRODUCING LONGITUDINAL CHERENKOV DISTRIBUTION C (NOT TO BE COMBINED WITH CERENKOV) C AUGERHIST VERSION PRODUCING HISTO''S AT UP TO 20 OBSERVATION LEVELS C AUGERHIT VERSION SELECTING PARTICLES HITTING AUGER ARRAY C AUGERINFO WRITES AUGER INFO FILE INSTEAD OF DBASE FILE C CEFFIC VERSION TO APPLY ALREADY DURING EAS SIMULATION C ATM. ABSORPTION, MIRROR REFLECTIVITY AND QUANTUM EFF. C (SAVES LOTS OF TIME AND DISK SPACE) C (ONLY IN CONNECTION WITH CHERENKOV OPTION) C CERENKOV VERSION FOR CHERENKOV LIGHT GENERATION C CERWLEN VERSION FOR CHERENKOV WITH WAVELENGTH DEPENDENT PHOTONS C CHARM VERSION TO TREAT EXPLICITELY CHARMED PARTICLES BY PYTHIA C COAST VERSION FOR ROOT PARTICLE OUTPUT FILE C COASTUSERLIB VERSION FOR ROOT PARTICLE TRACKING (E.G. FOR COREAS) C COMPACT VERSION FOR COMPACT PARTICLE OUTPUT FILE C CONEX VERSION USING CONEX TO SPEED UP HIGH ENERGY CALCULATION C CURVED VERSION FOR CURVED (SLIDING PLANE) ATMOSPHERE C EFIELD VERSION WITH ELECTRICAL FIELD IN ATMOSPHERE C EHISTORY VERSION TO GIVE ADDITIONAL INFO (PREHISTORY) OF MUONS C IACT VERSION FOR IMAGING ATMOSPHERIC CHERENKOV TELESCOPES C (ONLY IN CONNECTION WITH CHERENKOV OPTION) C IACTEXT EXTENDED INTERFACING FOR CHERENKOV TELESCOPES C ICECUBE1 VERSION FOR ICECUBE TO TREAT SECPAR PARTICLES FIFO C ICECUBE2 VERSION FOR ICECUBE WITH GZIP OR PIPE OUTPUT C INTCLONG INTEGRATED CHERENKOV PHOTON NUMBERS FOR LONGITUDINAL C DEVELOPMENT (IN CONNECTION WITH CHERENKOV OR C AUGCERLONG OPTION) C INTTEST VERSION FOR INTERACTION TEST (NO SHOWER DEVELOPMENT) C LPM VERSION SELECTING LPM-EFFECT WITHOUT THINNING C MULTITHIN VERSION FOR MULTI-THINNING OF UNTHINNED SHOWER C MUONHIST VERSION PRODUCING HISTOGRAMS FOR MUON TRANSPOT C MUPROD VERSION FOR INFO ON DECAYING MUONS C NEUTRINO VERSION FOR EXPLICIT NEUTRINO TREATMENT C NOCLONG SUPPRESS LONGITUDINAL DEVELOPMENT FOR CHERENKOV C (ONLY IN CONNECTION WITH CHERENKOV OPTION) C NUPRIM VERSION FOR NEUTRINO PRIMARY TREATED BY HERWIG MODEL C PARALLEL VERSION FOR PARALLEL TREATMENT OF SUBSHOWERS C PARALLELIB VERSION FOR PARALLEL TREATMENT OF SUBSHOWERS WITH MPI C PLOTSH VERSION FOR PRODUCTION OF SHOWER PLOTS C PLOTSH2 VERSION FOR PRODUCTION OF SHOWER PLOTS SECOND VERSION C PRESHOWER GAMMA PRESHOWERING IN EARTH MAGNETIC FIELD C RIGIDITY VERSION TO SUPPRESS LOW ENERGY PRIMARIES (RIGIDITY CUTOFF) C SLANT VERSION FOR LONGITUDINAL DEVELOPMENT IN SLANT DEPTH C STACKIN STACK INPUT OF PARTICLES FROM EXTERNAL INTERACTION C TAULEP VERSION TO TREAT EXPLICITELY TAU LEPTONS BY PYTHIA C THIN VERSION FOR THINNING C TRAJECT VERSION TO FOLLOW TRAJECTORY OF SOURCE AT THE SKY C UPWARD VERSION INCLUDING UPWARD GOING PARTICLES C VIEWCONE VERSION FOR FIXED ANGLE AND VIEWING CONE C VOLUMECORR VERSION FOR VERTICAL STRING DETECTORS C VOLUMEDET VERSION FOR NON-FLAT (VOLUME) DETECTORS C----------------------------------------------------------------------- #if HAVE_CONFIG_H #include "config.h" #ifdef VERSION #undef VERSION #endif #ifdef PACKAGE #undef PACKAGE #endif *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= C C DATACARDS C ========= C C THE PROGRAM CAN BE RUN BY SEVERAL STEERING CARDS. THEY CONSIST OF C A KEYWORD (A6...A7) AND ONE OR MORE PARAMETERS. THE CARDS MAY BE GIVEN C IN ANY ORDER. IF NO CARD IS SUPPLIED FOR A SPECIAL PARAMETER, A C DEFAULT VALUE IS TAKEN. THE DEFAULTS ARE GIVEN BELOW. C INPUT IS FORMAT FREE, UPPER AND LOWER CASE CHARACTERS ARE ACCEPTED. C C EXPLANATION : C ============= C KEYWORD VARIABLES DESCRIPTION C----------------------------------------------------------------------- C RUNNR I RUN NUMBER OF THIS SIMULATION C EVTNR I EVENT NUMBER FOR FIRST SHOWER, SECOND SHOWER C WILL GET NUMBER EVTNR+1 AND SO ON C NSHOW I NUMBER OF SHOWERS TO BE GENERATED C OBSLEV F OBSERVATION LEVEL ABOVE SEA IN CM C UP TO 10 LEVELS ARE POSSIBLE C (FOR AUGERHIST UP TO 20 LEVELS ARE POSSIBLE) C PRMPAR I PARTICLE TYPE OF PRIMARY PARTICLE C THETAP 2F ZENITH ANGLE RANGE OF PRIM. PARTICLE IN DEGREES C PHIP 2F AZIMUTH ANGLE RANGE OF PRIM. PARTICLE IN DEGREES C ERANGE 2F LIMITS OF ENERGY RANGE C ESLOPE F EXPONENT OF DIFF. ENERGY SPECTRUM TO BE THROWN C FIXCHI F STARTING ALTITUDE OF PRIMARY IN G/CM**2 C TSTART L DEFINE ZERO POINT OF ARRIVAL TIME AT ENTRANCE INTO C ATMOSPHERE (ELSE: AT FIRST INTERACTION) C FIXHEI F,I FIX HEIGHT OF FIRST INTERACTION IN CM (RANDOM C AT 0.), TYPE OF TARGET FOR 1ST INTERACTION: C 0=RANDOM, 1=NITROGEN, 2=OXYGEN, 3=ARGON C HADFLG 6I STEERING OF HADRONIC INTERACTIONS C NFLAIN, NFLDIF, NFLPI0, NFLPIF, NFLCHE, NFRAGM C (MEANING SEE BELOW) C ELMFLG 2L SELECTING NKG AND/OR EGS FOR TREATING ELECTRONS C AND GAMMAS C STEPFC F MULTIPLE SCATTERING MAX. STEP LENGTH FACTOR C RADNKG F RANGE OF LATERAL NKG DISTRIBUTION IN CM C ECUTS 4F KINETIC ENERGY CUTS FOR HADRONS, MUONS, C ELECTRONS AND GAMMAS IN GEV C CORECUT F CUT RADIUS FOR DISCARDING PARTICLES CLOSE TO CORE C ECTMAP F GAMMA FACTOR CUT FOR PARTICLE PRINTOUT IN GEV C SEED 3I STARTING SEED, NUMBER OF CALLS AND NUMBER OF C BILLIONS OF CALLS (SEE RMMAR IN CERN LIBRARY) C UP TO 8 SEQUENCES ARE USED IN THE MOMENT C MAXPRT I THE MAXIMUM NUMBER OF EVENTS TO BE PRINTED C MAGNET 2F THE COMPONENTS OF THE EARTH MAGNETIC FIELD C ARRANG F ANGLE (DEG) ARRAY X_DIRECTION WRT. MAGNETIC NORD C LONGI L,F,2L SELECT SAMPLING OF LONGITUDINAL SHOWER DEVELOPMENT, C DEFINE THE SAMPLING STEPS IN G/CM**2, SET THE C FLAG FOR CHARGED LONGITUDINAL DISTRIBUTION FIT C FLAG FOR LONGITUD. OUTPUT C MUMULT L FLAG FOR MULTIPLE SCATTERING OF MUONS (T=MOLIERE) C MUADDI L ADDITIONAL INFORMATION ON MUON AT MUONS BIRTHPLACE C DEBUG L,I,L,I DEBUG PRINTOUT FLAG AND LOG.UNIT C FOR PRINTOUT AND DELAYED ACTIVATION OF DEBUG C EGSDEB I COUNTER FOR DELAYED DEBUG ACTICVATION IN EGS C PAROUT 2L FLAGS FOR MPATAP SUPPRESS AND TABLE OUT ACTIVATION C DIRECT A239 DATASET NAME FOR PARTICLE OUTPUT FILE C OUTPUT I REDIRECT PRINTER OUTPUT TO UNIT C ATMOD I SELECT ATMOSPHERIC MODEL NUMBER C ATMA 4F(5F) ATMOSPHERIC A PARAMETERS C ATMB 4F ATMOSPHERIC B PARAMETERS C ATMC 4F(5F) ATMOSPHERIC C PARAMETERS C ATMLAY 4F ATMOSPHERIC LAYER BOUNDARY ALTITUDE C DATDIR A132 DIRECTORY WHERE TO FIND ALL INPUT DATA SETS C DATBAS L PARAMETERS ARE WRITTEN TO DATABASE FILE C HOST A60 HOST NAME OF COMPUTER IN USE FOR DBASE FILE C USER A60 USER NAME FOR DBASE FILE C EXIT ENDS DATA CARD READING #if __DPMJET__ C DPMJET L,I SELECT DPMJET MODEL FOR HIGH ENERGY HADR. INTERACT. C DPJSIG L SELECT DPMJET CROSS-SECTIONS #elif __EPOS__ C EPOS L,I SELECT EPOS FOR HIGH ENERGY HADR.INTERACT.&DEBUG C EPOPAR A6,A73 EPOS PARAMETER WITH CODE WORD AND VALUE C EPOSIG L SELECT EPOS CROSS-SECTIONS #elif __NEXUS__ C NEXUS L,I SELECT NEXUS FOR HIGH ENERGY HADR.INTERACT.&DEBUG C NEXPAR A6,A73 NEXUS PARAMETER WITH CODE WORD AND VALUE C NEXSIG L SELECT NEXUS CROSS-SECTIONS #elif __QGSJET__ C QGSJET L,I SELECT QGSJET MODEL FOR HIGH ENERGY HADR. INTERACT. C QGSSIG L SELECT QGSJET CROSS-SECTIONS #elif __SIBYLL__ C SIBYLL L,I SELECT SIBYLL FOR HIGH ENERGY HADRONIC INTERACT. C AMOUNT OF SIBYLL DEBUG OUTPUT C SIBSIG L SELECT SIBYLL CROSS-SECTIONS #elif __VENUS__ C VENUS L,I SELECT VENUS FOR HIGH ENERGY HADRONIC INTERACT. C AMOUNT OF VENUS DEBUG OUTPUT C VENPAR A6,F VENUS PARAMETER WITH CODE WORD AND VALUE C VENSIG L SELECT VENUS CROSS-SECTIONS #endif C HILOW F SETS BORDER BETWEEN HIGH AND LOW ENERGY MODEL #if __FLUKA__ C FLUDBG L DIRECTS FLUKA DEBUG AND ERROR MESSAGES #elif __GHEISHAD__ C GHEIDB L SELECT DEBUG FOR GHEISHA INTERACTION MODEL #elif __URQMD__ C URQMD L,I SELECT URQMD FOR LOW EN.HADR.INT.MODEL & DEBUG #endif #if __DPMJET__ || __CHARM__ || __TAULEP__ C PYTHIA 2I MAX. WARNING AND ERRORS FOR PYTHIA PACKAGE #endif #if __ATMEXT__ C ATMOSPHERE I,L EXTERNAL TABUL. ATMOSPHERE # AND REFRACTION USAGE #endif #if __AUGERHIT__ C AUGSCT I,2F,2L MULTIPLE USE OF AUGER EVENTS, EFFECT. RADIUS OF C AUGER DETECTOR (M), DETECTOR OVERLOAD RADIUS (M) C FLAG REGISTER ONLY PARTICLES HITTING TANKSHADOW, C FLAG CHECK PARTICLE SURVIVES ANY THIN MODE C AUGHIT 2F AUGER DETECTOR SCATTERING POSITION #endif #if __CERENKOV__ C CERSIZ F MAXIMAL SIZE FOR GROUP OF CHERENKOV PHOTONS C CERARY 2I,4F DEFINITION OF THE ARRAY OF CHERENKOV DETECTORS C CERFIL I INDEX TO DIRECT CHERENKOV OUTPUT TO FILE C CDEBUG L CHERENKOV DEBUG FLAG C CWAVLG 2F LOWER AND UPPER WAVELENGTH LIMIT FOR CHERENKOV C CSCAT I,2F MULTIPLE USE OF CHERENKOV EVENTS, AND RANGE OF C CORE SCATTER #if __IACT__ C TELFIL A TELESCOPE DATA OUTPUT DSNAME C TELESCOPE 4F X,Y,Z COORDIANTES OF TELESCOPE WITH RADIUS R #else C TELESCOPE 4F,I X,Y,Z COORDIANTES OF TELESCOPE WITH RADIUS R, AND ID #endif #if __CEFFIC__ C CERQEF 3L SWITCH FOR APPLYING QUANTUM EFFICIENCY, C ATMOSPHERIC ABSORPTION, MIRROR REFLECTIVITY #endif #endif #if __COASTUSERLIB__ C INCLIN 5F COORDINATES (X,Y,Z) OF THE ORIGIN OF THE INCLINED C OBSERVATION PLANE AND ANGLES (THETA,PHI) OF C THE NORMAL OF THAT PLANE. #endif #if __COMPACT__ C COMOUT L FLAG ENABLING COMPACT PARTICLE OUTPUT #endif #if __CONEX__ C CASCADE 3L CONEX PARAMETERS C CONEX 3F CONEX PARAMETERS C CXWMX 3F,2L CONEX WEIGHT PARAMETERS C CX2COR 4F CONEX TO CORSIKA #endif #if __CURVED__ && __UPWARD__ C IMPACT 2F IMPACT PARAMETER RANGE FOR SKIMMING SHOWERS #endif #if __CURVED__ C TIMLIM F MAX. DISTANCE FOR PARTICLE CUT BY TIME LIMIT #endif #if __CURVED__ && !__ANAHIST__ C CURVOUT L CURVED (FLAT) OBSERVATION LEVEL C FLATOUT L FLAT (CURVED) OBSERVATIN LEVEL #endif #if __EHISTORY__ C EMADDI L MOTHER&GRANDMA OF EM-PARTCLS AT ORIGIN OF EM SUBSHOWER C NUADDI L ADDITIONAL INFORMATION ON NEUTRINOS AT NU BIRTHPLACE #endif #if __ICECUBE1__ C EINTER F THRESHOLD ENERGY ABOVE WHICH PARTICLES ARE INTERESTING #endif #if __ICECUBE2__ C COMPRESS L FLAG INDICATING THAT OUTPUT SHOULD BE GZIPPED C PIPE L FLAG INDICATING OUTPUT TO BE WRITTEN TO PIPE BUFFER #endif #if __INTTEST__ C INTTST 2I TARGET TYPE AND CHOICE OF COORDINATE SYSTEM C HISTDS A120 DATASET NAME FOR HBOOK HISTOGRAMS C DIFOFF I SWITCHES DIFFRACTION ON OR OFF C INTDEC 4L STEERS DECAY OF PI0, ETA, HYPERONS, AND K0S C INTSPC L PLOTS AS WELL THE SPECTATOR NUCLEONS C TRIGGER I TRIGGER CONDITION 1=UA5, 2=CDF, 3=P238 #endif #if __MULTITHIN__ C MTHINH 4F THIN PARAMETERS FOR MULTI-THIN C MTHINR F CUT RADIUS FOR DISCARDING PARTICLES C MSEED 3I STARTING SEED, NUMBER OF CALLS AND NUMBER OF C BILLIONS OF CALLS (SEE RMMAR IN CERN LIBRARY) C SEQUENCES 8 TO 14 ARE USED IN MULTITHIN OPTION #endif #if __PARALLEL__ C PARALLEL 2F,I,L PARAMETERS FOR PARALLEL VERSION C CUTFILE A255,2I DATA SET NAME AND CUT PARAMETERS FOR PARALLEL VERSION #endif #if __PLOTSH__ || __PLOTSH2__ C PLOTSH L FLAG TO ENABLE/DISABLE OUTPUT FOR PLOTS #endif #if __PLOTSH2__ C PLAXES 6F DEFINES AXIS RANGE FOR PLOT C PLCUTS 5F,L ENERGY CUTS, TIME CUT AND TRACK SEGMENT CUTS #endif #if __PRESHOWER__ || __CONEX__ C GCOORD 3F,2I GEOGRAPHICAL LONGITUDE, LATITUDE, YEAR, IPREPR, C IPRSTP (CALCL. MAGN. DIPOL FIELD AT EXPERIMENT C LOC., STOP SHOWER SIMULATON IF NO PRESHOWERING) #endif #if __STACKIN__ C INFILE A132 DATASET NAME FOR STACKINPUT FILE #elif !__CONEX__ C OUTFILE A132 DATASET NAME OF STACK OF FIRST INTERACTION OUTOUT FILE #endif #if __THIN__ C THIN 3F ENERGY FRACTION BELOW WHICH THINNING IS APPLIED, C MAX. WEIGHT FOR THINNING, MAX. RADIUS FOR RAD.THINNING C THINEM 2F DIFFERING THINNING FOR EM-PARTICLES WITH C RATIO EPSILON_EM/EPSILON_HAD; RATIO WMAX_EM/WMAX_HAD C THINH 2F DIFFERING THINNING FOR HADRONS WITH RATIO C EPSILON_EM/EPSILON_HAD; RATIO WMAX_EM/WMAX_HAD #endif #if __TRAJECT__ C TRAFLG L FLAG TO ENABLE TRAJECTORY C SRCPOS 2F SOURCE POSITION FOR TRAJECTORY C TRATM 7I START TIME AN DURATION OF TRAJECTORY OBSERVATION C TLAT 3F,A1 LATERAL POSITION OF OBSERVING TELESCOPE C TLONG 3F,A1 LONGITUDINAL POSITION OF OBSERVING TELESCOPE C GEODEC F GEOGRAPHIC DECLINATION OF OBSERVING TELESCOPE C TRARAD F RADIUS AROUND SOURCE FOR EVENT PRODUCTION #endif #if __VIEWCONE__ C VIEWCONE 2F OPENING ANGLE FOR INNER AND OUTER CONE (DEGREES) #endif #if __VOLUMECORR__ C DETCFG F DETECTORCONFIGURATION HEIGHT/DIAMETER #endif C C----------------------------------------------------------------------- C C LIST OF PROGRAM STEERING CARDS WITH DEFAULT VALUES : C ==================================================== C C RUNNR 1 C EVTNR 1 C NSHOW 10 C OBSLEV 110.E2 C PRMPAR 14 C THETAP 0. 0. C PHIP 0. 0. C ERANGE 1.E4 1.E4 C ESLOPE 0. C FIXCHI 0. C TSTART F C FIXHEI 0. 0 C HADFLG 0 0 0 0 0 2 C ELMFLG T F C STEPFC 1. C RADNKG 200.E2 #if __DPMJET__ C DPMJET T 0 C DPJSIG T #elif __EPOS__ C EPOS T 0 C EPOPAR ' ' C EPOSIG T #elif __NEXUS__ C NEXUS T 0 C NEXPAR ' ' C NEXSIG T #elif __QGSJET__ C QGSJET T 0 C QGSSIG T #elif __SIBYLL__ C SIBYLL T 0 C SIBSIG T #elif __VENUS__ C VENUS T 0 C VENPAR ' ' 0. C VENSIG T #endif C HILOW 80. #if __FLUKA__ C FLUDBG F #elif __GHEISHAD__ C GHEIDB F #elif __URQMD__ C URQMD T 0 #endif #if __DPMJET__ || __CHARM__ || __TAULEP__ C PYTHIA 0 0 #endif C ECUTS .3 .3 .003 .003 C ECTMAP 1.E4 C CORECUT 0. C SEED 1 0 0 C SEED 2 0 0 C SEED 3 0 0 C MAXPRT 1 C MAGNET 20. 42.8 C ARRANG 0. C LONGI F 20. F F C MUMULT T C MUADDI F C DEBUG F 6 F 100000 C EGSDEB 2147483647 C PAROUT T F C OUTPUT 6 C ATMOD 1 C ATMA 0. 0. 0. 0. (0.) C ATMB 0. 0. 0. 0. C ATMC 0. 0. 0. 0. (0.) C ATMLAY 4.E5 10.E5 40.E5 100.E5 C DATDIR './' C DATBAS F C HOST ' ' C USER ' ' C EXIT #if __ATMEXT__ C ATMOSPHERE 0 F #endif #if __AUGERHIT__ C AUGSCT 20 35. 1500. T T C AUGHIT 0. 0. #endif C DIRECT 'anynameupto239characters/' #if __CERENKOV__ C SEED 3 0 0 C CERSIZ 0. C CERARY 27 27 1500. 1500. 100. 100. C CERFIL 0 C CWAVLG 300. 450. C CSCAT 1 0. 0. C TELESCOPE 0. 0. 0. 1. 0 #if __IACT__ C TELFIL ' ' #endif #if __CEFFIC__ C CERQEF F F F #endif #endif #if __COASTUSERLIB__ C INCLIN 0. 0. OBSLEV(1) 0. 0. #endif #if __COMPACT__ C COMOUT T #endif #if __CONEX__ C CASCADE T F F C CONEX 1.E-3 1. 1.E-3 C CXWMX -1. -1. -1. F F C CX2COR 1.E3 1.E20 1.E1 4.E2 #endif #if __CURVED__ && __UPWARD__ C IMPACT 0. 112.82920E5 #endif #if __CURVED__ C TIMLIM 1.D8 #endif #if __CURVED__ && !__ANAHIST__ C CURVOUT T C FLATOUT F #endif #if __EHISTORY__ C EMADDI F C NUADDI F #endif #if __ICECUBE1__ C EINTER 1.E3 #endif #if __ICECUBE2__ C COMPRESS T C PIPE F #endif #if __INTTEST__ C INTTST 0 0 C HISTDS 'histo.corsika.inttst' C DIFOFF 0 C HILOW 49. (OR 101.) C INTDEC T T T T C INTSPC T C TRIGGER 0 #endif #if __MULTITHIN__ C MTHINH 1.E-4 1.E30 1. 1. C MTHINR 0. C MSEED 9 0 0 #endif #if __PARALLEL__ C FECTOUT F C ECTCUT 1.E1 C ECTMAX 1.E6 C CFILINPU ' ' C CFILSTEE ' ' C I1CUTPAR 0 C I2CUTPAR 0 #endif #if __PLOTSH__ || __PLOTSH2__ C PLOTSH F #endif #if __PLOTSH2__ C PLAXES -5.E5 5.E5 -5.E5 5.E5 0. 3.E6 C PLCUTS 0.3 0.3 0.003 0.003 1.E5 F #endif #if __PRESHOWER__ || __CONEX__ C GCOORD -69.585 -35.463 2003. 1 0 ! DEFAULT VALUES FOR NIHUIL #endif #if __STACKIN__ C INFILE ' ' #elif !__CONEX__ C OUTFILE ' ' #endif #if __THIN__ C THIN 1.E-4 1.E30 0. C THINEM 1. 1. C THINH 1. 1. #endif #if __TRAJECT__ C TRAFLG T C SRCPOS 5.57 22. C TRATM 2000 1 1 21 0 0 3600 C TLAT 28. 45. 42.462 'N' C TLONG 17. 53. 26.525 'W' C GEODEC -6.35 C TRARAD 0. #endif #if __VIEWCONE__ C VIEWCONE 0. 0. #endif #if __VOLUMECORR__ C DETCFG 0. #endif C C----------------------------------------------------------------------- *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= C C OUTPUT FORMAT FOR PARTICLE OR CHERENKOV OUTPUT FILE (MPATAP/MCETAP) C ============= C #if __THIN__ C ( BLOCKLENGTH = 26208 FIXED, ALL WORDS ARE 4 BYTES LONG ) C EACH BLOCK CONSISTS OF 21 SUBBLOCKS OF 312 WORDS #else C ( BLOCKLENGTH = 22932 FIXED, ALL WORDS ARE 4 BYTES LONG ) C EACH BLOCK CONSISTS OF 21 SUBBLOCKS OF 273 WORDS #endif C THESE SUBBLOCKS CAN BE : C RUN HEADER C EVENT HEADER C DATABLOCK C (LONG I:N) C EVENT END C RUN END C THE CONTENTS OF THESE BLOCKS IS DESCRIBED BELOW. C A DATA FILE HAS THEN THE FOLLOWING STRUCTURE : C RUN HEADER 1 C EVENT HEADER 1 C DATABLOCK C DATABLOCK C ... C ... C (LONG 1:1) C ... C (LONG 1:N) C EVENT END 1 C EVENT HEADER 2 C DATABLOCK C DATABLOCK C ... C ... C (LONG 2:1) C ... C (LONG 2:N) C EVENT END 2 C ... C ... C EVENT HEADER #NEVT C DATABLOCK C DATABLOCK C ... C ... C (LONG #NEVT:1) C ... C (LONG #NEVT:N) C EVENT END #NEVT C RUN END 1 C RUN HEADER 2 C ... C RUN END 2 C ... C RUN HEADER #NRUN C ... C RUN END #NRUN C C======================================================================= C C RUN HEADER : ( ONCE PER RUN ) C ============ C C 1 'RUNH' C 2 RUN NUMBER C 3 DATE OF BEGIN RUN ( YYMMDD ) C 4 VERSION OF CORSIKA PROGRAM C C OBSERVATION LEVELS ( MAXIMAL 10 ) C 5 NUMBER OF OBSERVATION LEVELS C 5+I HEIGHT OF LEVEL I IN CM C C ENERGY SPECTRUM C 16 SLOPE OF ENERGY SPECTRUM C 17 LOWER ENERGY LIMIT C 18 UPPER ENERGY LIMIT C C ELECTROMAGNETIC PARTICLES C 19 FLAG FOR EGS4 C 20 FLAG FOR NKG C C CUTOFFS IN SIMULATION C 21 KIN. ENERGY CUTOFF FOR HADRONS IN GEV C 22 KIN. ENERGY CUTOFF FOR MUONS IN GEV C 23 KIN. ENERGY CUTOFF FOR ELECTRONS IN GEV C 24 KIN. ENERGY CUTOFF FOR GAMMAS IN GEV C C RUN PARAMETERS AND PHYSICAL CONSTANTS C 24+I C(I), I=1,50 #if __COASTUSERLIB__ C 75 X COORDINATE OF INCLINED OBSERVATION PLANE RELATIVE TO SHOWER CORE C 76 Y COORDINATE OF INCLINED OBSERVATION PLANE RELATIVE TO SHOWER CORE C 77 Z COORDINATE OF INCLINED OBSERVATION PLANE RELATIVE TO SHOWER CORE C 78 THETA ANGLE OF THE NORMAL TO THE INCLINED OBSERVATION PLANE C 79 PHI ANGLE OF THE NORMAL TO THE INCLINED OBSERVATION PLANE C C 79+I 0, I=1,14 NO LONGER USED #else C 74+I 0, I=1,19 NO LONGER USED #endif C 94 NSHOW C 94+I CKA(I), I=1,40 C 134+I CETA(I), I=1,5 C 139+I CSTRBA(I)I=1,11 C 150+I 0, I=1,97 NO LONGER USED C 248 XSCATT SCATTER RANGE IN X DIRECTION FOR CERENKOV C 249 YSCATT SCATTER RANGE IN Y DIRECTION FOR CERENKOV C 249+I HLAY(I), I=1,5 C 254+I AATM(I), I=1,5 C 259+I BATM(I), I=1,5 C 264+I CATM(I), I=1,5 C 270 NFLAIN (AS REAL) C 271 NFLDIF (AS REAL) C 272 NFLPI0 + 100.* NFLPIF (AS REAL) C 273 NFLCHE + 100.* NFRAGM (AS REAL) #if __THIN__ C 274..312 NOT USED #endif C C======================================================================= C C EVENTHEADER : ( ONCE PER EVENT ) C ============= C C 1 'EVTH' C 2 EVENT NUMBER C C PRIMARY PARTICLE C 3 PARTICLE ID ( PARTICLE CODE OR A * 100 + Z FOR NUCLEI ) C 4 TOTAL ENERGY IN GEV C 5 STARTING ALTITUDE IN G/CM**2 C 6 NUMBER OF FIRST INTERACTION TARGET IF FIXED C 7 Z- COORDINATE IN CM OF FIRST INTERACTION C (NEGATIV IF TIME STARTS AT MARGIN OF ATMOSPHERE) C 8 PX MOMENTUM IN X DIRECTION C 9 PY MOMENTUM IN Y DIRECTION C 10 PZ MOMENTUM IN -Z DIRECTION C 11 THETA (ZENITH ANGLE) IN RAD C 12 PHI (AZIMUTH ANGLE) IN RAD C C RANDOM NUMBER INITIALIZATION ( SUBROUT. RMMARD ) C ( UP TO 10 DIFFERENT SEQUENCES ) C 13 NUMBER OF DIFFERENT SEQUENCES C C 11+3*I INTEGER SEED OF SEQUENCE I C 12+3*I NUMBER OF OFFSET RANDOM CALLS ( MOD 10**6 ) OF SEQUENCE I C 13+3*I NUMBER OF OFFSET RANDOM CALLS ( MILLIONS ) OF SEQUENCE I C C GENERAL INFORMATION C 44 RUN NUMBER C 45 DATE OF BEGIN RUN ( YYMMDD ) C 46 VERSION OF CORSIKA PROGRAM C C OBSERVATION LEVELS ( MAXIMAL 10 ) C 47 NUMBER OF OBSERVATION LEVELS C 47+I HEIGHT OF LEVEL I IN CM C C ENERGY SPECTRUM C 58 SLOPE OF ENERGY SPECTRUM C 59 LOWER LIMIT OF ENERGY RANGE IN GEV C 60 UPPER LIMIT OF ENERGY RANGE IN GEV C C CUTOFFS IN SIMULATION C 61 CUTOFF FOR HADRONS KINETIC ENERGY IN GEV C 62 CUTOFF FOR MUONS KINETIC ENERGY IN GEV C 63 CUTOFF FOR ELECTRONS KINETIC ENERGY IN GEV C 64 CUTOFF FOR GAMMAS KINETIC ENERGY IN GEV C C HDPM MODEL PARAMETERS C 65 NFLAIN ( AS REAL ) C 66 NFLDIF ( AS REAL ) C 67 NFLPI0 ( AS REAL ) C 68 NFLPIF ( AS REAL ) C 69 NFLCHE ( AS REAL ) C 70 NFRAGM ( AS REAL ) C C EARTH''S MAGNETIC FIELD COMPONENT C 71 BX IN MICROTESLA C 72 BZ IN MICROTESLA C C ELECTROMAGNETIC PARTICLES C 73 FLAG FOR EGS4 C 74 FLAG FOR NKG C C OTHER FLAGS C 75 GHEISHA/URQMD/FLUKA FLAG (1.=GHEISHA, 2.=URQMD, 3.=FLUKA) C 76 VENUS FLAG (0.=HDPM, 1.=VENUS, 2.=SIBYLL, C 3.=QGSJET, 4.=DPMJET, 5.=NEXUS, 6.=EPOS) C 77 CHERENKOV FLAG C 78 NEUTRINO FLAG C 79 CURVED FLAG (0.=STANDARD, 2.=CURVED) C 80 COMPUTER FLAG (3.=UNIX OR LINUX SYSTEM, 4.=MACINTOSH) C C ANGULAR DISTRIBUTION OF PRIMARY PARTICLE C 81 LOWER EDGE OF PRIMARY THETA SELECTION (IN DEGREES) C 82 UPPER EDGE OF PRIMARY THETA SELECTION (IN DEGREES) C 83 LOWER EDGE OF PRIMARY PHI SELECTION (IN DEGREES) C 84 UPPER EDGE OF PRIMARY PHI SELECTION (IN DEGREES) C C CHERENKOV SETTINGS IN CASE OF CHERENKOV CALCULATIONS C 85 CERSIZ CHERENKOV PHOTON BUNCH SIZE C 86 NCERX NUMBER OF CHERENKOV DETECTORS IN X DIRECTION C 87 NCERY NUMBER OF CHERENKOV DETECTORS IN Y DIRECTION C 88 DCERX GRID SPACING IN X DIRECTION IN CM C 89 DCERY GRID SPACING IN Y DIRECTION IN CM C 90 ACERX CHERENKOV DETECTOR SIZE IN X DIRECTION IN CM C 91 ACERY CHERENKOV DETECTOR SIZE IN Y DIRECTION IN CM C 92 MCERFI MODE FOR CHERENKOV PHOTON OUTPUT C C 93 ARRANR ANGLE (RAD) ARRAY X-DIRECTION AND MAGNETIC NORD C 94 MUADDI FLAG FOR ADDITIONAL MUON INFO ON PARTICLE DATA FILE C 95 STEPFC ELECTRON MULTIPLE SCATTERING STEP SIZE FACTOR (EGS) C 96 WAVLGL CHERENKOV WAVELENGTH BANDWIDTH LOWER LIMIT (NM) C 97 WAVLGU CHERENKOV WAVELENGTH BANDWIDTH UPPER LIMIT (NM) C C CHERENKOV RSP. AUGER STUFF FOR SCATTERED EVENTS C 98 ICERML NUMBER I OF TIMES A SINGLE EVENT IS USED (UP TO 20) C 98 MAUGPOS NUMBER I OF TIMES A SINGLE EVENT IS USED (AUGER) C 98+I CERXOS(I) X OFFSET IN CM FOR THE ITH EVENT (CERENKOV) C 98+I XSHCORE(I) X OFFSET IN CM FOR THE ITH EVENT (AUGER) C 118+I CERYOS(I) Y OFFSET IN CM FOR THE ITH EVENT (CERENKOV) C 118+I YSHCORE(I) Y OFFSET IN CM FOR THE ITH EVENT (AUGER) C C 139 SIBYLL INTERACTION FLAG (1.=VERS.1.6; 2.=VERS.2.1; 3.=VERS.2.3) C 140 SIBYLL CROSS-SECTION FLAG (1.=VERS.1.6; 2.=VERS.2.1; 3.=VERS.2.3) C 141 QGSJET INTERACTION FLAG (1.=OLD QGSJET; 2.=QGSJET01; C 3.=QGSJET-II) C 142 QGSJET CROSS-SECTION FLAG (1.=OLD QGSJET; 2.=QGSJET01; C 3.=QGSJET-II) C 143 DPMJET INTERACTION FLAG C 144 DPMJET CROSS-SECTION FLAG C 145 VENUS/NEXUS/EPOS CROSS-SECTION FLAG (1.=VENUSSIG, C 2./3.=NEXUSSIG, 4.=EPOSSIG) C 146 MUON MULTIPLE SCATTERING FLAG (1.=MOLIERE,0.=GAUSS) C 147 NKG RADIAL DISTRIBUTION RANGE IN CM C 148 ENERGY FRACTION OF THINNING LEVEL HADRONIC C 149 ENERGY FRACTION OF THINNING LEVEL EM-PARTICLES C 150 ACTUAL WEIGHT LIMIT FOR THINNING HADRONIC C 151 ACTUAL WEIGHT LIMIT FOR THINNING EM-PARTICLES C 152 MAX RADIUS FOR RADIAL THINNING IN CM C 152 MAX RADIUS FOR CORE CUTTING (CORECUT) C 153 VIEWCONE(1) ANGLE OF INNER VIEWING CONE (DEG) C 154 VIEWCONE(2) ANGLE OF OUTER VIEWING CONE (DEG) C 155 TRANSITION ENERGY HIGH-ENERGY/LOW-ENERGY MODEL (IN GEV) C 156 SKIMMING INCIDENCE FLAG (0.=STANDARD, 1.=SKIMMING) C 157 ALTITUDE (CM) OF HORIZONTAL SHOWER AXIS (SKIMMING INCIDENCE) C 158 STARTING HEIGHT (CM) C 159 CHARM PRODUCTION (0.=NOT ACTIVE, 1.=ACTIVE) C 160 EMADDI: FLAG FOR HADRON ORIGIN OF EM SUBSHOWER ON DATA FILE C 161 SLANT DEPTH CONEX THRESHOLD FOR LOW ENERGY MONTE-CARLO C 162 CONEX THRESHOLD FOR HADRONIC CASCADE EQUATION C 163 CONEX THRESHOLD FOR MUONS C 164 CONEX THRESHOLD FOR ELECTROMAGNETIC CASCADE EQUATION C 165 CONEX THRESHOLD FOR LOW ENERGY HADRONIC MONTE-CARLO C 166 CONEX THRESHOLD FOR LOW ENERGY MUONS MONTE-CARLO C 167 CONEX THRESHOLD FOR LOW ENERGY ELECTROMAGNETIC MONTE-CARLO C 168 FLAG FOR CURVOUT (OBSERVATION LEVEL FLAT = 0., CURVED = 1.) C 169 ACTUAL WEIGHT LIMIT FOR THINNING HADRONIC IN CONEX C 170 ACTUAL WEIGHT LIMIT FOR THINNING EM-PARTICLES IN CONEX C 171 ACTUAL WEIGHT LIMIT FOR SAMPLING HADRONIC IN CONEX C 172 ACTUAL WEIGHT LIMIT FOR SAMPLING MUONS IN CONEX C 173 ACTUAL WEIGHT LIMIT FOR SAMPLING EM-PARTICLES IN CONEX C 174 MIN. RADIUS OF SENSITIVE AREA AROUND AUGER DETECTOR (AUGERHIT) C 175 DETECTOR DISTANCE BETWEN NEIGHBOURING DETECTORS (AUGERHIT) C 176 (RESERVED FOR AUGERHIT WITH PARALLEL) #if __THIN__ C 177..312 NOT YET USED #else C 177 # OF MULTITHIN MODES C 177+J ENERGY FRACTION OF HADRONIC THINNING FOR MULTITHIN MODE J C 183+J ACTUAL WEIGHT LIMIT HADRONIC FOR MULTITHIN MODE J C 189+J ENERGY FRACTION OF EM THINNING FOR MULTITHIN MODE J C 195+J ACTUAL WEIGHT LIMIT EM FOR MULTITHIN MODE J C 199+3*J INTEGER SEED OF RANDOM SEQUENCE FOR MULTITHIN MODE J C 200+3*J # of OFFSET RANDOM CALLS (MOD 10**6) FOR MULTITHIN MODE J C 201+3*J # OF OFFSET RANDOM CALLS (/10**6) FOR MULTITHIN MODE J C 220 THRESHOLD ENERGY ABOVE WHICH PARTILCES ARE INTERESTING (ICECUBE) C 221 FLAG INDICATING THAT OUTPUT IS GZIPPED C 222 FLAG INDICATING THAT OUTPUT IS WRITTEN TO PIPE BUFFER C 223..273 NOT YET USED #endif C C======================================================================= C C PARTICLE DATA BLOCKS : C ====================== C #if __THIN__ C (CONTAINING UP TO 39 PARTICLES, 8 WORDS EACH) C C 8*(N-1)+1 PARTICLE IDENTIFICATION C ( PART.ID*1000 + HADR.GENERATION*10 + NO. OF OBS.LEVEL ) C <5627 <100 <10 C (IF PART.ID=75/76: PART.ID*1000 + HADR.GENERATION) C <5627 <1000 C (IF PART.ID = 9900 THEN CHERENKOV PHOTON WITH C NINT(NUMBER OF PHOTONS IN BUNCH)*10 + 1) C 8*(N-1)+2 PX MOMENTUM IN X DIRECTION IN GEV C 8*(N-1)+3 PY MOMENTUM IN Y DIRECTION IN GEV C 8*(N-1)+4 PZ MOMENTUM IN -Z DIRECTION IN GEV C 8*(N-1)+5 X- COORDINATE IN CM C 8*(N-1)+6 Y- COORDINATE IN CM C 8*(N-1)+7 T TIME SINCE FIRST INTERACTION (OR ENTRANCE INTO C ATMOSPHERE) IN NSEC C ( Z-COORDINATE IN CM FOR ADDITIONAL MUON INFORMATION) C 8*(N-1)+8 WEIGHT OF PARTICLE C #else C (CONTAINING UP TO 39 PARTICLES, 7 WORDS EACH) C C 7*(N-1)+1 PARTICLE IDENTIFICATION C ( PART.ID*1000 + HADR.GENERATION*10 + NO. OF OBS.LEVEL ) C <5627 <100 <10 C (IF PART.ID = 9900 THEN CHERENKOV PHOTON WITH C NINT(NUMBER OF PHOTONS IN BUNCH)*10 + 1) C 7*(N-1)+2 PX MOMENTUM IN X DIRECTION C 7*(N-1)+3 PY MOMENTUM IN Y DIRECTION C 7*(N-1)+4 PZ MOMENTUM IN -Z DIRECTION C 7*(N-1)+5 X- COORDINATE IN CM C 7*(N-1)+6 Y- COORDINATE IN CM C 7*(N-1)+7 T TIME SINCE FIRST INTERACTION (OR ENTRANCE INTO C ATMOSPHERE) IN NSEC C ( Z-COORDINATE IN CM FOR ADDITIONAL MUON INFORMATION) C #endif #if __MULTITHIN__ C (CONTAINING PARTICLE MULTITHIN EXTENSIONS AFTER EACH PARTICLE, C 7 WORDS EACH) C C 7*(N-1)+1 MULTITHIN IDENTIFICATION 8888jjj. C 7*(N-1)+2 WEIGHT OF PARTICLE IN MULTITHIN MODE 1 C 7*(N-1)+3 WEIGHT OF PARTICLE IN MULTITHIN MODE 2 C 7*(N-1)+4 WEIGHT OF PARTICLE IN MULTITHIN MODE 3 C 7*(N-1)+5 WEIGHT OF PARTICLE IN MULTITHIN MODE 4 C 7*(N-1)+6 WEIGHT OF PARTICLE IN MULTITHIN MODE 5 C 7*(N-1)+7 WEIGHT OF PARTICLE IN MULTITHIN MODE 6 C #endif C C FOR N = 1.... 39 C C IF LAST BLOCK IS NOT COMPLETELY FILLED, TRAILING ZEROS ARE ADDED C C======================================================================= C C CHERENKOV BUNCH DATA BLOCKS : C ============================ C #if __THIN__ C (CONTAINING UP TO 39 BUNCHES, 8 WORDS EACH) C C 8*(N-1)+1 NUMBER OF PHOTONS IN BUNCH C (FOR STANDARD PARTICLE OUTPUT FILE: C 99.E5 + NINT(NUMBER OF PHOTONS IN BUNCH)*10 + 1 C 8*(N-1)+2 X- COORDINATE IN CM C 8*(N-1)+3 Y- COORDINATE IN CM C 8*(N-1)+4 DIRECTION COSINUS TO X AXIS C 8*(N-1)+5 DIRECTION COSINUS TO Y AXIS C 8*(N-1)+6 T TIME SINCE FIRST INTERACTION (OR ENTRANCE INTO C ATMOSPHERE) IN NSEC C 8*(N-1)+7 PRODUCTION HEIGHT OF BUNCH IN CM C 8*(N-1)+8 WEIGHT OF BUNCH #else C (CONTAINING UP TO 39 BUNCHES, 7 WORDS EACH) C C 7*(N-1)+1 NUMBER OF PHOTONS IN BUNCH C (FOR STANDARD PARTICLE OUTPUT FILE: C 99.E5 + NINT(NUMBER OF PHOTONS IN BUNCH)*10 + 1 C 7*(N-1)+2 X- COORDINATE IN CM C 7*(N-1)+3 Y- COORDINATE IN CM C 7*(N-1)+4 DIRECTION COSINUS TO X AXIS C 7*(N-1)+5 DIRECTION COSINUS TO Y AXIS C 7*(N-1)+6 T TIME SINCE FIRST INTERACTION (OR ENTRANCE INTO C ATMOSPHERE) IN NSEC C 7*(N-1)+7 PRODUCTION HEIGHT OF BUNCH IN CM #endif C C FOR N = 1.... 39 C C IF LAST BLOCK IS NOT COMPLETELY FILLED, TRAILING ZEROS ARE ADDED C C======================================================================= C C LONGITUDINAL BLOCKS: C ==================== C OPTIONAL, IF (LONGI = .TRUE. .AND. FLONGOUT = .FALSE.) C C 1 'LONG' C 2 EVENT NUMBER C 3 PARTICLE ID ( PARTICLE CODE OR A * 100 + Z FOR NUCLEI ) C 4 TOTAL ENERGY IN GEV C 5 (TOTAL NUMBER OF LONGITUDINAL STEPS) * 100 + C NUMBER OF LONGITUDINAL BLOCKS/SHOWER C 6 CURRENT NUMBER 'M' OF LONGITUDINAL BLOCK C 7 ALTITUDE OF FIRST INTERACTION IN G/CM**2 C 8 THETA (ZENITH ANGLE) IN RAD C 9 PHI (AZIMUTH ANGLE) IN RAD C 10 CUTOFF FOR HADRONS KINETIC ENERGY IN GEV C 11 CUTOFF FOR MUONS KINETIC ENERGY IN GEV C 12 CUTOFF FOR ELECTRONS KINETIC ENERGY IN GEV C 13 CUTOFF FOR GAMMAS ENERGY IN GEV C C FOR N = 1, 26 AND FOR J LONGITUDINAL STEPS: C 10*N+ 4 VERTICAL DEPTH OF STEP J IN G/CM**2 C 10*N+ 5 NUMBER OF GAMMAS AT STEP J C 10*N+ 6 NUMBER OF E+ PARTICLES AT STEP J C 10*N+ 7 NUMBER OF E- PARTICLES AT STEP J C 10*N+ 8 NUMBER OF MU+ PARTICLES AT STEP J C 10*N+ 9 NUMBER OF MU- PARTICLES AT STEP J C 10*N+10 NUMBER OF HADRONIC PARTICLES AT STEP J C 10*N+11 NUMBER OF ALL CHARGED PARTICLES AT STEP J C 10*N+12 NUMBER OF NUCLEI AT STEP J C 10*N+13 NUMBER OF CHERENKOV PHOTONS AT STEP J C C FOR FIRST 'LONG' BLOCK: 1 ... J ... 26 C FOR SECOND 'LONG' BLOCK: 27 ... J ... 52 C ... C FOR 'M'TH 'LONG' BLOCK: (M-1)*26+1 ... J ... M*26 C C IF LAST BLOCK IS NOT COMPLETELY FILLED, TRAILING ZEROS ARE ADDED C #if __THIN__ C 274..312 NOT USED #endif C C======================================================================= C C END EVT: ( ONCE PER EVENT ) C ======== C C 1 'EVTE' C 2 EVENT NUMBER C C STATISTICS FOR SHOWER C 3 WEIGHTED NUMBER OF GAMMAS WRITTEN TO MPATAP C 4 WEIGHTED NUMBER OF ELECTRONS WRITTEN TO MPATAP C 5 WEIGHTED NUMBER OF HADRONS WRITTEN TO MPATAP C 6 WEIGHTED NUMBER OF MUONS WRITTEN TO MPATAP C 7 NUMBER OF WEIGHTED PARTICLES WRITTEN TO MPATAP C C NKG OUTPUT (208 WORDS) IF SELECTED C 7+I I=1,21 LATERAL DIST. IN X DIRECTION FOR 1. LEVEL (/CM**2) C 28+I I=1,21 LATERAL DIST. IN Y DIRECTION FOR 1. LEVEL (/CM**2) C 49+I I=1,21 LATERAL DIST. IN XY DIRECTION FOR 1. LEVEL (/CM**2) C 70+I I=1,21 LATERAL DIST. IN YX DIRECTION FOR 1. LEVEL (/CM**2) C C 91+I I=1,21 LATERAL DIST. IN X DIRECTION FOR 2. LEVEL (/CM**2) C 112+I I=1,21 LATERAL DIST. IN Y DIRECTION FOR 2. LEVEL (/CM**2) C 133+I I=1,21 LATERAL DIST. IN XY DIRECTION FOR 2. LEVEL (/CM**2) C 154+I I=1,21 LATERAL DIST. IN YX DIRECTION FOR 2. LEVEL (/CM**2) C C 175+I I=1,10 ELECTRON NUMBER AT LEVELS FOR LONGITUDINAL DIST. C 185+I I=1,10 AGE AT LEVELS FOR LONGITUDINAL DIST. C 195+I I=1,10 DISTANCES FOR NKG LATERAL DISTRIBUTION (CM) C 205+I I=1,10 LOCAL PSEUDO-AGE 1. LEVEL C C 215+I I=1,10 LEVEL HEIGHT IN G/CM**2 FOR LONGITUDINAL DIST. C 225+I I=1,10 LEVEL HEIGHT IN CM FOR LONGITUDINAL DIST. C 235+I I=1,10 DISTANCE BINS FOR LOCAL AGE (CM) C 245+I I=1,10 LOCAL PSEUDO-AGE 2. LEVEL C C LONGITUDINAL DEVELOPMENT (IF SELECTED) C 255+I I=1,6 PARAMETERS OF LONGITUDINAL DISTRIBUTION OF CHARGED C PARTICLES C 262 CHI**2 PER DEGREE OF FREEDOM OF FIT TO LONGITUDINAL C DISTRIBUTION C 263 WEIGHTED NUMBER OF GAMMAS ARRIVING AT OBSERVATION LEVEL C 264 WEIGHTED NUMBER OF ELECTRONS ARRIVING AT OBSERVATION LEVEL C 265 WEIGHTED NUMBER OF HADRONS ARRIVING AT OBSERVATION LEVEL C 266 WEIGHTED NUMBER OF MUONS ARRIVING AT OBSERVATION LEVEL C 267 NUMBER OF EM_PARTICLES EMERGING FROM PRE-SHOWER C #if __THIN__ C 268..312 NOT YET USED #else C 268..273 NOT YET USED #endif C C======================================================================= C C END RUN C ======= C C 1 'RUNE' C 2 RUNNR #if __PARALLEL__ C 3 RUNNR C 4 NUMBER OF CORES USED IN THIS PARALLEL RUN #else C STATISTICS FOR RUN C 3 NUMBER OF EVENTS PROCESSED C 4 NOT USED #endif C #if __THIN__ C 5..312 NOT YET USED #else C 5..273 NOT YET USED #endif C C----------------------------------------------------------------------- *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= C C PARTICLE CODES C ============== C C NAMING CONVENTION FOR PARTICLES IN CORSIKA ACCORDING TO GEANT WITH C EXTENSIONS FOR RESONANCES (RHO, K*, AND DELTA), NEUTRINOS, AND NUCLEI C C 1 GAMMA C 2 POSITRON C 3 ELECTRON C ( 4 NEUTRINO SEE 66..69 ) C 5 MUON + C 6 MUON - C 7 PION 0 C 8 PION + C 9 PION - C 10 KAON 0 LONG C 11 KAON + C 12 KAON - C 13 NEUTRON C 14 PROTON C 15 ANTI PROTON C 16 KAON 0 SHORT C 17 ETA SEE ALSO 71..74 C 18 LAMBDA C 19 SIGMA + C 20 SIGMA 0 C 21 SIGMA - C 22 XI 0 C 23 XI - C 24 OMEGA (BARYON) C 25 ANTI NEUTRON C 26 ANTI LAMBDA C 27 ANTI SIGMA - C 28 ANTI SIGMA 0 C 29 ANTI SIGMA + C 30 ANTI XI 0 C 31 ANTI XI + C 32 ANTI OMEGA (BARYON) C C 50 OMEGA MESON C 51 RHO 0 C 52 RHO + C 53 RHO - C 54 DELTA ++ C 55 DELTA + C 56 DELTA 0 C 57 DELTA - C 58 ANTI DELTA -- C 59 ANTI DELTA - C 60 ANTI DELTA 0 C 61 ANTI DELTA + C 62 K* 0 C 63 K* + C 64 K* - C 65 ANTI K* 0 C 66 ELECTRON NEUTRINO C 67 ELECTRON ANTI NEUTRINO C 68 MUON NEUTRINO C 69 MUON ANTI NEUTRINO C C 71 ETA --> GAMMA + GAMMA C 72 ETA --> PI(0) + PI(0) + PI(0) C 73 ETA --> PI(+) + PI(-) + PI(0) C 74 ETA --> PI(+) + PI(-) + GAMMA C 75 MUON + ADDITIONAL INFORMATION OF ORIGIN C 76 MUON - ADDITIONAL INFORMATION OF ORIGIN C C 85 DECAYING MU+ AT START C 86 DECAYING MU- AT START C C 95 DECAYING MU+ AT END C 96 DECAYING MU- AT END C C 116 D 0 C 117 D + C 118 ANTI D - C 119 ANTI D 0 C 120 D_S + C 121 ANTI D_S - C 122 ETA-C C 123 D* 0 C 124 D* + C 125 ANTI D* - C 126 ANTI D* 0 C 127 D*_S + C 128 ANTI D*_S - C C 130 J/PSI C 131 TAU + C 132 TAU - C 133 TAU NEUTRINO C 134 TAU ANTI NEUTRINO C C 137 LAMBDA_C + C 138 XI_C + C 139 XI_C 0 C 140 SIGMA_C ++ C 141 SIGMA_C + C 142 SIGMA_C 0 C 143 XI_C PRIME + C 144 XI_C PRIME 0 C 145 OMEGA_C 0 C C 149 ANTI LAMBDA_C - C 150 ANTI XI_C - C 151 ANTI XI_C 0 C 152 ANTI SIGMA_C -- C 153 ANTI SIGMA_C - C 154 ANTI SIGMA_C 0 C 155 ANTI XI_C PRIME - C 156 ANTI XI_C PRIME 0 C 157 ANTI OMEGA_C 0 C C 161 SIGMA_C * ++ C 162 SIGMA_C * + C 163 SIGMA_C * 0 C C 171 ANTI SIGMA_C * -- C 172 ANTI SIGMA_C * - C 173 ANTI SIGMA_C * 0 C C 176 B 0 C 177 B + C 178 ANTI B - C 179 ANTI B 0 C 180 B_S 0 C 181 ANTI B_S 0 C 182 B_C + C 183 ANTI B_C - C 184 LAMBDA_B 0 C 185 SIGMA_B - C 186 SIGMA_B + C 187 XI_B 0 C 188 XI_B - C 189 OMEGA_B - C 190 ANTI LAMBDA_B 0 C 191 ANTI SIGMA_B + C 192 ANTI SIGMA_B - C 193 ANTI XI_B 0 C 194 ANTI XI_B + C 195 ANTI OMEGA_B + C C NAMING CONVENTION FOR NUCLEI: C AAZZ NUCLEUS OF ZZ PROTONS AND (AA-ZZ) NEUTRONS C RESTRICTIONS: AA < 59 AND ZZ < AA+1 C C 9900 CHERENKOV PHOTONS ON THE PARTICLE OUTPUT FILE C----------------------------------------------------------------------- #define __INCVARINDEX__ #include "corsika.h" *-- Author : The CORSIKA development group 21/04/1994 C====================================================================== #if __PARALLELIB__ SUBROUTINE CORSIKA(LPRIM,DECTCUT,DECTMAX & ,I1CUTPART,I2CUTPART,CFILINPU,CFILOUTP,CFILSTEE & ,IDMPI) C----------------------------------------------------------------------- C MAIN SUBROUTINE C C CORSIKA CALLED FROM EXTERNAL PROGRAM WITH INPUT PARAMETERS. C ARGUMENTS: C LPRIM (LOG) : PRIMARY INTERACTION (T) OR NOT (F) C DECTCUT (DBL) : THRESHOLD ENERGY FOR SUBSHOWERS (GEV). C ALL PARTICLES WITH ENERGY ABOVE ECTCUT WILL HAVE C A SEED FROM THE 6TH SEQUENCE OF RANDOM NUMBERS C ECTCUT IS IRRELEVANT FOR EM SHOWERS C DECTMAX (DBL) : MAXIMUM ENERGY (GEV) FOR A COMPLETE SUBSHOWER C I1CUTPART(INT) : FIRST INDICE OF PARTICULE TO READ FROM CFILINP C I2CUTPART(INT) : LAST INDICE OF PARTICULE TO READ FROM CFILINP C CFILINPU (CHA) : CUTFILE NAME TO READ TO FILL 2ND STACK C CFILOUTP (CHA) : SCREEN OUTFILE FILE NAME C CFILSTEE (CHA) : STEERING FILE NAME TO READ INPUT PARAMETERS C IDMPI (INT) : ID OF THE MPI TASK #else PROGRAM AAMAIN C----------------------------------------------------------------------- C MAIN PROGRAM #endif #if __CONEX__ C TO ALLOW TO RUN CORSIKA SHOWER DEVELOPMENT AND CONEX SHOWER DEVELOPMENT C IN PARALLEL, WE CALL A SUBROUTINE WITH NAME OF THE DIFFERENT SUB PARTS C AS ARGUMENT (TRICK FOR RECURSIVE CALL OF SUBROUTINE) C C----------------------------------------------------------------------- #if __PARALLEL__ LOGICAL LPRIM #if __PARALLELIB__ INTEGER I1CUTPART,I2CUTPART,IDMPI CHARACTER*255 CFILINPU,CFILOUTP,CFILSTEE #endif #endif EXTERNAL RUNSHOWER,FINISHSHOWER,FINISHRUN C----------------------------------------------------------------------- CALL CORSIKAMAIN(RUNSHOWER,FINISHSHOWER,FINISHRUN #if __PARALLELIB__ * ,LPRIM,I1CUTPART,I2CUTPART,CFILINPU,CFILOUTP * ,CFILSTEE,IDMPI #endif * ) END *-- Author : The CORSIKA development group 09/12/2009 C======================================================================= SUBROUTINE CORSIKAMAIN(DUMRUNSHOWER,DUMFINISHSHOWER,DUMFINISHRUN #if __PARALLELIB__ * ,LPRIM,I1CUTPART,I2CUTPART,CFILINPU,CFILOUTP * ,CFILSTEE,IDMPI #endif * ) C----------------------------------------------------------------------- C MAIN SUBROUTINE #if __PARALLELIB__ C C CORSIKA CALLED FROM EXTERNAL PROGRAM WITH INPUT PARAMETERS. C ARGUMENTS: C LPRIM (LOG) : PRIMARY INTERACTION (T) OR NOT (F) C I1CUTPART(INT) : FIRST INDICE OF PARTICULE TO READ FROM CFILINP C I2CUTPART(INT) : LAST INDICE OF PARTICULE TO READ FROM CFILINP C CFILINPU (CHA) : CUTFILE NAME TO READ TO FILL 2ND STACK C CFILOUTP (CHA) : SCREEN OUTFILE FILE NAME C CFILSTEE (CHA) : STEERING FILE NAME TO READ INPUT PARAMETERS C IDMPI (INT) : ID OF THE MPI TASK #endif #endif C C C SIMULATION OF EXTENSIVE AIR SHOWERS C PREPARES INITIALIZATIONS C GENERATES SHOWERS IN THE SHOWER LOOP C TREATES PARTICLES IN THE PARTICLE LOOP C PERFORMS PRINTING OF TABLES AT END OF SHOWER AND AT END OF RUN C----------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) #define __ATMOS2INC__ #define __BUFFSINC__ #define __CHISTAINC__ #define __CONSTAINC__ #define __CURVEINC__ #define __ELADPMINC__ #define __ELASTYINC__ #define __GENERINC__ #define __IRETINC__ #define __ISTAINC__ #define __LONGIINC__ #define __MAGNETINC__ #define __MPARTIINC__ #define __MULTINC__ #define __MUMULTINC__ #define __MUPARTINC__ #define __NKGIINC__ #define __NKGSINC__ #define __NPARTIINC__ #define __OBSPARINC__ #define __PAMINC__ #define __PARPARINC__ #define __PARPAEINC__ #define __PRIMSPINC__ #define __RANDPAINC__ #define __RECORDINC__ #define __REJECTINC__ #define __RESONINC__ #define __RUNPARINC__ #define __SIGMINC__ #define __STACKFINC__ #define __STATIINC__ #define __TABLESINC__ #define __THNVARINC__ #define __VERSINC__ #if __CERENKOV__ || __AUGCERLONG__ #define __CEREN1INC__ #define __CEREN2INC__ #endif #if __CERENKOV__ #define __CERTELINC__ #define __CEREN3INC__ #endif #if __CONEX__ #define __CONEXINC__ #endif #if __INTTEST__ #define __TSTINTINC__ #endif #if __MULTITHIN__ #define __MULTHININC__ #endif #if __NUPRIM__ #define __NUPROCINC__ #endif #if __PARALLEL__ #define __AUGDETINC__ #endif #if __PRESHOWER__ #define __GLOBALINC__ #endif #if __THIN__ #define __WGHTMAINC__ #endif #if __TRAJECT__ #define __TRAJECINC__ #endif #if __CURVED__ && !__PRESHOWER__ #define __TIMLIMINC__ #endif #include "corsika.h" DOUBLE PRECISION JNBIN(40),JPBIN(40),JKBIN(40),JHBIN(40) DOUBLE PRECISION CHI2,FPARAM(6) DOUBLE PRECISION MPART2(20,28),MPHOT2(20),MPOSI2(20),MELEC2(20), * MNU2(20),MMUP2(20),MMUM2(20),MPI02(20),MPIP2(20), * MPIM2(20),MK0L2(20),MKPL2(20),MKMI2(20), * MNETR2(20),MPROT2(20),MPRTB2(20),MK0S2(20), * MHYP2(20),MNETB2(20),MDEUT2(20),MTRIT2(20), * MHEL32(20),MALPH2(20),MCRMM2(20),MCRMB2(20), * MOTH2(20) EQUIVALENCE (MPART2(1, 1),MPHOT2(1)), (MPART2(1, 2),MPOSI2(1)), * (MPART2(1, 3),MELEC2(1)), (MPART2(1, 4),MNU2(1)) , * (MPART2(1, 5),MMUP2(1)) , (MPART2(1, 6),MMUM2(1)) , * (MPART2(1, 7),MPI02(1)) , (MPART2(1, 8),MPIP2(1)) , * (MPART2(1, 9),MPIM2(1)) , (MPART2(1,10),MK0L2(1)) , * (MPART2(1,11),MKPL2(1)) , (MPART2(1,12),MKMI2(1)) , * (MPART2(1,13),MNETR2(1)), (MPART2(1,14),MPROT2(1)), * (MPART2(1,15),MPRTB2(1)), (MPART2(1,16),MK0S2(1)) , * (MPART2(1,18),MHYP2(1)) , (MPART2(1,19),MDEUT2(1)), * (MPART2(1,20),MTRIT2(1)), (MPART2(1,21),MHEL32(1)), * (MPART2(1,22),MALPH2(1)), (MPART2(1,23),MCRMM2(1)), * (MPART2(1,24),MCRMB2(1)), (MPART2(1,25),MOTH2(1)), * (MPART2(1,27),MNETB2(1)) LOGICAL FEXIST #if __GFORTRAN__ REAL XLEFTA,XLEFTB #endif #if __PRESHOWER__ DOUBLE PRECISION AMARGIN,PRESTR,PREHEI #endif #if __PARALLEL__ DOUBLE PRECISION ELAB LOGICAL LPRIM #if __PARALLELIB__ DOUBLE PRECISION DECTCUT,DECTMAX INTEGER I1CUTPART,I2CUTPART,IDMPI CHARACTER*255 CFILINPU,CFILOUTP,CFILSTEE #endif #endif DOUBLE PRECISION THICK INTEGER LPCT0,LPCT1,NSTEP1 SAVE EXTERNAL BLOCK1,EGS4BD,HEIGH,THICK #if __QGSJET__ && !__QGSII__ EXTERNAL PSDATA #elif __SIBYLL__ EXTERNAL PARAM_INI #endif #if __NUPRIM__ CHARACTER*2 PROCTYPE #endif #if __CURVED__ #if !__PRESHOWER__ DOUBLE PRECISION DL,FIXHAPP,THCKHN #endif DOUBLE PRECISION THICKC,DIAG EXTERNAL THICKC #if !__STACKIN__ && !__CONEX__ LOGICAL FLAGC #endif #else #if !__STACKIN__ && !__CONEX__ && !__MULTITHIN__ LOGICAL IRETC #if __EHISTORY__ DOUBLE PRECISION PROPAR(0:38) INTEGER IK #else DOUBLE PRECISION PROPAR(0:8) #endif #endif #if __MULTITHIN__ LOGICAL IRETC DOUBLE PRECISION PROPAR(0:46) INTEGER IK #endif #if __CERENKOV__ integer icertel #endif #if !__UPWARD__ && __CERENKOV__ DOUBLE PRECISION ORGPAR(0:8) #endif #endif #if __VIEWCONE__ DOUBLE PRECISION XVC1,XVC2,YVC1,YVC2,ZVC1,ZVC2 #endif #if __SLANT__ INTEGER LBIN EXTERNAL LBIN #endif #if __TRAJECT__ DOUBLE PRECISION TPHIP1,TTHETAP1 INTEGER TRNGSTEP #endif #if __UNIX__ && !__TIMERC__ C VARIABLES BEING USED FOR RUNTIME REAL TDIFF INTEGER ILEFTA,ILEFTB,TIME EXTERNAL TIME #elif __TIMERC__ C VARIABLES BEING USED FOR RUNTIME REAL TDIFF INTEGER ILEFTA,ILEFTB EXTERNAL TIMER #elif __MAC__ C VARIABLES BEING USED FOR RUNTIME REAL TLEFTA,TLEFTB,TDIFF #endif #if __VOLUMECORR__ DOUBLE PRECISION FINDTH EXTERNAL FINDTH #endif #if __INTTEST__ DOUBLE PRECISION FRACTION LOGICAL FLAG #endif #if !__STACKIN__ && !__CONEX__ c DOUBLE PRECISION ENERGY,EN,PZ,PX,PY,HEI0 c INTEGER NNN,NN,N,NTYP,IRET #endif #if __COASTUSERLIB__ 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 #if __CONEX__ EXTERNAL DUMRUNSHOWER,DUMFINISHSHOWER,DUMFINISHRUN #endif c logical PRMINFO,ltest c integer iptr #if __RIGIDITY__ DOUBLE PRECISION TOLLER,GDEC,RIGID(22021),THE,PHI,RIG INTEGER IREASON,MYCNT,MYTHE,MYPHI,IDANGLE(61,361) #endif C----------------------------------------------------------------------- #if __CERENKOV__ || __AUGCERLONG__ CERELE = 0.D0 CERHAD = 0.D0 NRECER = 0 #endif #if __AUGERHIST__ C DEFINE THICKNESS OF SAMPLING LAYER, DEFAULT = 1 G/CM^2 SAMPTH = 1.D0 * SAMPTH = 20.D0 #endif C RESET FIRST INTERACTION DATA (TO BE SET EARLY FOR PRMINFO) FIRSTI = .TRUE. FNPRIM = .FALSE. #if __PARALLEL__ FPRIM = LPRIM C INITIALIZE 2ND PARTICLE STACK CALL JSTACK C INITIALIZE ECTFLG IN PARTICLE ARRAYS CURPAR(39) = -1.D0 SECPAR(39) = -1.D0 PRMPAR(39) = -1.D0 OUTPAR(39) = -1.D0 C INITIALIZE WRITE HEADERS FLAGS WRRUNH = .FALSE. WRRUNE = .FALSE. WREVTH = .FALSE. WREVTE = .FALSE. #if __PARALLELIB__ C STEERING FILE NOT READ FROM STANDART INPUT I1CUTPAR = I1CUTPART I2CUTPAR = I2CUTPART MONIIN = MPAINP DSNINP = CFILSTEE CFILINP = CFILINPU CFILOUT = CFILOUTP ECTCUT = DECTCUT ECTMAX = DECTMAX MPIID = IDMPI #endif #endif C INITIALIZE AND READ RUN STEERING CARDS CALL START #if __REMOTECONTROL__ CALL remotecontrol_start() #endif #if __DYNSTACK__ CALL dynstack_start() #endif #if __DYNSTACK__ || __REMOTE_CONTROL__ CALL baack_init() CALL baack_pama(pama, SIZEOF(pama) ) #endif #if __CERENKOV__ || __AUGCERLONG__ IF ( CERSIZ .LE. 0.D0 ) THEN ICRSIZ = 0 ELSE ICRSIZ = 1 ENDIF #endif C RESET COUNTER FOR WORDS WRITTEN TO FILE IRECOR = 0 C RESET COUNTER FOR AVERAGE HEIGHT OF 1ST INTERACTION CHISUM = 0.D0 CHISM2 = 0.D0 C SET ARRAYS FOR SCALES OF KINETIC ENERGY-INTERACTION TABLE SABIN(1) = 0.D0 SBBIN(1) = 0.1D0 DO J = 2, 40 SABIN(J) = 10.D0**((J-5.D0)/3.D0) SBBIN(J) = 10.D0**((J-4.D0)/3.D0) ENDDO #if __TRAJECT__ IF ( TLOGIC ) THEN C CHECK THE INPUT VALUES OF THE TRAJECTORY MODE FOR CONSISTENCY CALL TRAJCHECK C GET REAL ZENITH AND AZIMUTH RANGES SPANNED BY THE TRAJECTORY C TRNGSTEP: GET ONE EVALUATION PER MINUTE. THAT IS FINE ENOUGH HERE. TRNGSTEP = DBLE(TDURATION) / 60.D0 C INITIALIZE MIN AND MAX VALUES WITH VALUES WHICH GIVE C THE BIGGEST POSSIBLE RANGE TTHETMIN = 70.D0 TTHETMAX = 0.D0 TPHIMIN = 360.D0 TPHIMAX = 0.D0 C FOR EACH STEP CALL SOURCEPATH TO GET THETA AND PHI DO J = 1, TRNGSTEP CALL SOURCEPATH( TRNGSTEP,TTHETAP1,TPHIP1 ) C AND COMPARE TO MIN AND MAX VALUES FROM BEFORE IF ( TTHETAP1 .LT. TTHETMIN ) TTHETMIN = TTHETAP1 IF ( TTHETAP1 .GT. TTHETMAX ) TTHETMAX = TTHETAP1 IF ( TPHIP1 .LT. TPHIMIN ) TPHIMIN = TPHIP1 IF ( TPHIP1 .GT. TPHIMAX ) TPHIMAX = TPHIP1 ENDDO C NOW WE HAVE THE RANGE OF ZENITH AND AZIMUTH ANGLE C CONVERT FROM RAD TO DEGREE AND ASSIGN TO CORSIKA VARIABLES THETPR(1) = TTHETMIN * 180.D0 / PI THETPR(2) = TTHETMAX * 180.D0 / PI PHIPR(1) = PHIMIN * 180.D0 / PI PHIPR(2) = PHIMAX * 180.D0 / PI ENDIF #endif C CHECK AND SET PRIMARY PARAMETERS CALL INPRM #if __CONEX__ C SET PRIMARY PARAMETERS FOR CONEX CALL CONEXINI #endif C INITIALIZE NKG ROUTINES CALL ININKG C RESET COUNTERS FOR NUCLEON, PION AND KAON TABLE FOR ALL SHOWERS C RESET ENERGY-MULTIPLICITY & ENERGY-ELASTICITY MATRIX FOR ALL SHOWERS DO J = 1, 40 JNBIN(J) = 0.D0 JPBIN(J) = 0.D0 JKBIN(J) = 0.D0 JHBIN(J) = 0.D0 ELMEAA(J) = 0.D0 DO L = 1, 13 MULTOT(J,L) = 0 IELDPA(J,L) = 0 ENDDO ENDDO C RESET STACKINT DO J = 1, MAXICOUNT DO K = 0, MAXLEN STACKINT(K,J) = 0.D0 ENDDO ENDDO #if __THIN__ C RESET ENERGY-WEIGHT MATRIX FOR ALL SHOWERS DO J = 1, 46 DO L = 1, 15 MWGHTOT(J,L) = 0 ENDDO ENDDO #endif C RESET ARRAYS FOR INTERACTION LENGTH STATISTICS DO J = 1, 124 IHYCHI(J) = 0 IKACHI(J) = 0 IMUCHI(J) = 0 INUCHI(J) = 0 IPICHI(J) = 0 INNCHI(J) = 0 ENDDO C RESET ARRAY FOR MEAN VALUES AND STANDARD DEVIATION DO K = 1, 28 DO J = 1, 20 MPARTO(J,K) = 0.D0 MPART2(J,K) = 0.D0 ENDDO ENDDO C RESET ARRAYS FOR AVERAGE LONGITUDINAL DISTRIBUTION IF ( LLONGI ) THEN #if __SLANT__ C TAKE MAXIMUM LENGTH OF LONGI TABLE FOR LONGI HISTOGRAMS NSTEP1 = LNGMAX NSTEP = LNGMAX LPCT0 = 0 #else NSTEP1 = NSTEP LPCT0 = NSTEP #endif LPCT1 = 1 #if __ANAHIST__ C INITIALIZE THE LONGITUDINAL HISTOGRAMS CALL LNGHSTINI #endif DO J = 0, NSTEP1 DO K = 1, 10 AELONG(J,K) = 0.D0 APLONG(J,K) = 0.D0 SELONG(J,K) = 0.D0 SPLONG(J,K) = 0.D0 #if __ANAHIST__ APLONG(J,K+10) = 0.D0 SPLONG(J,K+10) = 0.D0 #endif ENDDO DO K = 1, 19 ADLONG(J,K) = 0.D0 SDLONG(J,K) = 0.D0 ENDDO ENDDO ENDIF C STEERING OF PRINTOUT OF RANDOM GENERATOR SEEDS IPROUT = MIN( 100, NSHOW/20 ) IPROUT = MAX( 1, IPROUT ) #if __UNIX__ && !__TIMERC__ C TIME AT BEGINNING #if __GFORTRAN__ CALL CPU_TIME( XLEFTA ) ILEFTA = NINT(XLEFTA) #else ILEFTA = 0. !TIME() !?????????????????? check #endif #elif __TIMERC__ C TIME AT BEGINNING CALL TIMER( ILEFTA ) #elif __MAC__ C TIME AT BEGINNING CALL TIME( TLEFTA ) #endif THICK00 = THICK0 #if __RIGIDITY__ C READING DATA FILE OPEN(UNIT=99, FILE="gr3.txt", STATUS="OLD") MYCNT = 0 DO WHILE(.TRUE.) READ(99,*,IOSTAT=IREASON) THE,PHI,RIG IF ( IREASON .EQ. 0 ) THEN MYCNT = MYCNT + 1 C WRITE(MDEBUG,*) MYCNT, THE, PHI, RIG RIGID(MYCNT) = RIG ELSE EXIT ENDIF ENDDO CLOSE(99) C VALIDATION FOR NO. OF POINTS IF ( MYCNT .NE. 22021 .OR. THE .NE. 60.D0 .OR. & PHI .NE. 360.D0 ) THEN WRITE(MONIOU,*) 'DIMENSIONS ARE NOT MATCHING' WRITE(MONIOU,*) 'CHECK THE RIGIDITY DATA FILE & ADJUST THE ', $ 'MODIFICATION' STOP ENDIF C ASSIGNING IDs MYCNT = 0 DO MYTHE = 1, 61 DO MYPHI = 1, 361 MYCNT = MYCNT + 1 C WRITE(MONIOU,*) 'VALUE = ', MYTHE, MYPHI, MYCNT IDANGLE(MYTHE,MYPHI) = MYCNT ENDDO ENDDO C USING THE % OF RIGIDITY VALUES AS THRESHOLD C 90 % TOLLER = 0.9D0 C DECLINATION VALUE FOR GRAPES-3 GDEC = 1.92D0 C APPLYING % TO ALL NUCLEI WITH CHARGE = SIGNUM(ITYPE) ITYPE = INT( PRMPAR(0) ) IF ( SIGNUM(ITYPE) .NE. 0.D0 ) THEN DO MYCNT = 1, 22021 RIGID(MYCNT) = TOLLER * SQRT( ( SIGNUM(ITYPE)* & RIGID(MYCNT) )**2 + RESTMS(ITYPE)**2 ) C WRITE(MONIOU,*) MYCNT, RIGID(MYCNT) ENDDO ELSE DO MYCNT = 1, 22021 RIGID(MYCNT) = 0 C WRITE(MONIOU,*) MYCNT, RIGID(MYCNT) ENDDO ENDIF #endif C----------------------------------------------------------------------- C LOOP OVER SHOWERS #if __CONEX__ DO 22 ISHW = 1, NSHOW #else DO 2 ISHW = 1, NSHOW #endif ISHOWNO = ISHOWNO + 1 I = ISHW IF ( ISHW .LE. MAXPRT ) THEN FPRINT = .TRUE. ELSE FPRINT = .FALSE. ENDIF #if __INTTEST__ C ENTRY POINT IF COLLISION WAS NOT ACCEPTED IN INTTEST 2222 CONTINUE #endif THICK0 = THICK00 C FIRST INTERACTION DATA FIRSTI = .TRUE. FNPRIM = .FALSE. #if __PARALLEL__ && !__PARALLELIB__ C WHEN THE 2ND STACK IS NOT EMPTY, THE FIRST INTERACTION IS ALREADY PASSED IF ( JCOUNT .GT. 1 ) THEN FPRIM = .FALSE. ELSE FPRIM = .TRUE. ENDIF #endif c ltest= PRMINFO(iptr) IFINET = 0 IFINNU = 0 IFINKA = 0 IFINPI = 0 IFINHY = 0 IFINCM = 0 IFINRHO = 0 ELAST = 0.D0 THICK1 = 0.D0 TARG1I = 0.D0 SIGAIR = 0.D0 SIG1I = 0.D0 ISEED1I(1) = 0 ISEED1I(2) = 0 ISEED1I(3) = 0 #if !__STACKIN__ && !__CONEX__ IFINAM = 0 REWIND( LSTCK2 ) #endif C RESET COUNTERS DO K = 1, 28 DO J = 1, 20 NPARTO(J,K) = 0.D0 NPART2(J,K) = 0.D0 ENDDO ENDDO NRECS = 0 NBLKS = 0 DO KKK = 1, 20 AVNREJ(KKK) = 0.D0 ENDDO IRESPAR = 0 #if __PLOTSH2__ CALL PLMAPINI #endif C RESET COUNTERS FOR NUCLEON, PION AND KAON TABLE FOR SHOWER C RESET ENERGY-MULTIPLICITY & ENERGY-ELASTICITY MATRIX FOR SHOWER DO J = 1, 40 INBIN(J) = 0 IPBIN(J) = 0 IKBIN(J) = 0 IHBIN(J) = 0 ELMEAN(J) = 0.D0 DO L = 1, 13 MULTMA(J,L) = 0 IELDPM(J,L) = 0 ENDDO ENDDO #if __THIN__ C RESET ENERGY-WEIGHT MATRIX FOR ALL SHOWERS DO J = 1, 46 DO L = 1, 15 MWGHMA(J,L) = 0 ENDDO ENDDO #endif C RESET PARTICLE TABLES IF ( FTABOUT ) THEN DO IIE = 1, IEBIN DO IIT = 1, ITBIN DO IID = 1, IDBIN G_ARRAY(IIE,IIT,IID) = 0. E_ARRAY(IIE,IIT,IID) = 0. M_ARRAY(IIE,IIT,IID) = 0. ENDDO ENDDO ENDDO ENDIF C INITIALIZE PARTICLE STACK CALL ISTACK IRET1 = 0 C INITIALIZE EVENT HEADER AND END FOR EACH EVENT DO L = 2, 43 EVTH(L) = 0. ENDDO #if __THIN__ DO L = 274, 312 EVTH(L) = 0. ENDDO #endif DO L = 2, MAXBUF EVTE(L) = 0. ENDDO C SHOWER BEGIN PRINTOUT IF ( FPRINT .OR. DEBUG ) WRITE(MONIOU,105) ISHOWNO 105 FORMAT(/,/,1X,10('='),' SHOWER NO ',I10,' ',47('='),/) C RANDOM GENERATOR STATUS AT BEGINNING OF SHOWER CALCULATION EVTH(13) = REAL( NSEQ ) DO L = 1, NSEQ CALL RMMAQD( ISEED(1,L),L,'R' ) C SEED EVTH(11+L*3) = REAL( ISEED(1,L) ) C NUMBER OF CALLS EVTH(12+L*3) = MOD( ISEED(2,L), 1000000 ) C NUMBER OF MILLIONS EVTH(13+L*3) = ISEED(3,L)*1000 + INT( ISEED(2,L)/1000000 ) ENDDO IF ( IPROUT .LE. 0 ) IPROUT = 1000 IF ( FPRINT .OR. DEBUG .OR. MOD(ISHW-1,IPROUT) .EQ. 0 ) THEN CALL PRTIME( TTIME ) WRITE(MONIOU,158) ISHOWNO,( L,(ISEED(J,L),J=1,3),L=1,NSEQ ) 158 FORMAT(' AND RANDOM NUMBER GENERATOR AT BEGIN OF EVENT :',I8, * /,(' SEQUENCE = ',I2,' SEED = ',I9 ,' CALLS = ',I9, * ' BILLIONS = ',I9)) ENDIF C RESET KNOR KNOR = .TRUE. C GET FULL RANDOM GENERATOR STATUS (103 WORDS PER SEQUENCE) CC DO 495 L = 1, NSEQ CC CALL RMMAQD( ISEED(1,L),L,'RV' ) CC495 CONTINUE #if !__STACKIN__ C GET PRIMARY ENERGY INTO PRMPAR(1) IF ( ISPEC .EQ. 0 ) THEN PRMPAR(1) = LLIMIT ELSE CALL RMMARD( RD,1,1 ) IF ( PSLOPE .NE. -1.D0 ) THEN PRMPAR(1) = ( RD(1)*UL + ( 1.D0-RD(1) )*LL )**SLEX ELSE PRMPAR(1) = LLIMIT * LL**RD(1) ENDIF IF ( FPRINT .OR. DEBUG .OR. MOD(ISHW-1,IPROUT) .EQ. 0 ) * WRITE(MONIOU,*) 'PRIMARY ENERGY = ',PRMPAR(1),' GEV' ENDIF C IF YOU WANT TO USE KINETIC ENERGY IN PRIMARY SPECTRUM C YOU HAVE TO ADD THE PRIMARY''S REST MASS: cc PRMPAR(1) = PRMPAR(1) + PAMA(NINT( PRMPAR(0) )) #endif C GET PRIMARY ANGLES OF INCIDENCE #if __TRAJECT__ C CALCULATE THETA AND PHI FOR EACH EVENT USING SOURCEPATH IF ( TLOGIC ) THEN CALL SOURCEPATH( NSHOW,THETAP,PHIP ) PRMPAR(2) = COS(THETAP) #if __CURVED__ PRMPAR(15) = COS(THETAP) #endif ELSE #endif IF ( FIXINC ) THEN C PRIMARY ANGLE FIXED THETAP = THETPR(1) PHIP = PHIPR(1) #if __VIEWCONE__ IF ( VUECON(2) .GT. 0.D0 ) THEN C THROW UNIFORMLY DISTRIBUTED DIRECTION IN VIEWING CONE OR CONE RING C FOR NOW #if __VOLUMEDET__ 46 CALL RMMARD( RD,2,1 ) #elif __VOLUMECORR__ 46 WRITE(MONIOU,*) 'COMBINATION OF VIEWCONE AND VOLUMECORR', * ' IS NOT IMPLEMENTED' STOP #else 46 CALL RMMARD( RD,3,1 ) #endif CT1 = COS( VUECON(1) ) CT2 = COS( VUECON(2) ) CTT = RD(2) * ( CT2 - CT1 ) + CT1 THETAP = ACOS( CTT ) PHIP = RD(1) * PI2 C TEMPORARY CARTESIAN COORDINATES XVC1 = COS( PHIP )*SIN( THETAP ) YVC1 = SIN( PHIP )*SIN( THETAP ) ZVC1 = COS( THETAP ) C ROTATE AROUND Y AXIS XVC2 = XVC1*COS( THETPR(1) ) + ZVC1*SIN( THETPR(1) ) YVC2 = YVC1 ZVC2 = ZVC1*COS( THETPR(1) ) - XVC1*SIN( THETPR(1) ) #if !__VOLUMEDET__ C FOR A HORIZONTAL TARGET, THE COS(THETA) WEIGHT IS OBTAINED BY C THROWING THE DICE ANOTHER TIME. IF ( RD(3) .GT. ZVC2 ) GOTO 46 #endif THETAP = ACOS( ZVC2 ) #if __CURVED__ #if __CERENKOV__ IF ( THETAP .GT. 88.D0*(PI/180.D0) ) GOTO 46 #else IF ( THETAP .GE. 90.D0*(PI/180.D0) ) GOTO 46 #endif #else IF ( THETAP .GT. 70.D0*(PI/180.D0) ) GOTO 46 #endif IF ( XVC2 .NE. 0.D0 .OR. YVC2 .NE. 0.D0 ) THEN PHIP = ATAN2(YVC2,XVC2) + PHIPR(1) ELSE PHIP = PHIPR(1) ENDIF IF ( PHIP .GT. PI2 ) PHIP = PHIP - PI2 IF ( PHIP .LT. 0.D0 ) PHIP = PHIP + PI2 ENDIF #endif #if __IACT__ CALL EXTPRM(PRMPAR(0), PRMPAR(1), THETAP, PHIP) CTT = COS( THETAP ) #endif #if __CURVED__ C COSINE OF APPARENT ZENIT ANGLE IS PUT IN PRMPAR(15) C (COSINE OF LOCAL ZENIT ANGLE IS IN PRMPAR(2)) PRMPAR(15) = COS( THETAP ) #else PRMPAR(2) = COS( THETAP ) #endif ELSE #if __CURVED__ && __UPWARD__ IF ( FIMPCT ) THEN C SKIMMING INCIDENCE, COSTAP AT DETECOR IS 0 THETAP = 0.5D0 * PI CTT = 0.D0 C CHOOSE IMPACT PARAMETER AT RANDOM CALL RMMARD( RD,1,1 ) HIMPCT = ( HIMPACT(2) - HIMPACT(1) ) * RD(1) + HIMPACT(1) IF ( FPRINT .OR. DEBUG * .OR. MOD(ISHW-1,IPROUT) .EQ. 0 ) THEN WRITE(MONIOU,*) 'MINIMUM ALTITUDE OF PRIMARY IS ', * HIMPCT*0.01D0,' M' ENDIF EVTH(156) = 1. EVTH(157) = HIMPCT ELSE #endif #if __VOLUMEDET__ C USE EQUAL FLUX FROM ALL DIRECTIONS. THIS ASSUMES A VOLUME DETECTOR C INSENSITIVE ON THE INCIDENCE ANGLE. CALL RMMARD( RD,2,1 ) CT1 = COS( THETPR(1) ) CT2 = COS( THETPR(2) ) CTT = RD(2) * ( CT2 - CT1 ) + CT1 THETAP = ACOS( CTT ) #elif __VOLUMECORR__ C CHOOSE ANGLE AT RANDOM FOR A LONG CYLINDRICAL VOLUME DETECTOR WITH C VERTICAL CYLINDER AXIS AS IS USED FOR UNDERWATER OR ICE NEUTRINO C DETECTORS. DETECTOR CONFIGURATION MUST BE DEFINED. CALL RMMARD( RD,2,1 ) THETAP = FINDTH( RD(2) ) CTT = COS( THETAP ) #else C CHOOSE ANGLES AT RANDOM WITH EQUAL FLUX FOR ALL DIRECTIONS C WITH HORIZONTAL DETECTOR ARRAY (SEE: O.C. ALLKOFER & P.K.F. GRIEDER, C COSMIC RAYS ON EARTH, IN: PHYSICS DATA 25/1, H.BEHRENS & G.EBEL ED., C (FACHINFORMATIONSZENTRUM KARLSRUHE, GERMANY, 1983) CHPT. 1.1.2) CALL RMMARD( RD,3,1 ) CT1 = SIN( THETPR(1) )**2 CT2 = SIN( THETPR(2) )**2 CTT = SQRT( 1.D0 - RD(2)*(CT2 - CT1) - CT1 ) #if __UPWARD__ IF ( THETPR(1) .GT. 0.5D0*PI .AND. * THETPR(2) .GT. 0.5D0*PI ) THEN CTT = -CTT ENDIF #endif THETAP = ACOS( CTT ) #endif #if __CURVED__ && __UPWARD__ ENDIF #endif PHIP = RD(1) * ( PHIPR(2) - PHIPR(1) ) + PHIPR(1) #if __IACT__ CALL EXTPRM( PRMPAR(0), PRMPAR(1), THETAP, PHIP ) CTT = COS( THETAP ) #endif #if __CURVED__ C CALCULATION IS THE SAME AS IN THE CASE OF A FLAT ATMOSPHERE BECAUSE C FOR THIS CALCULATION THE APPARENT ANGLES AT DETECTOR ARE NEEDED. C COSINE OF APPARENT ZENITH ANGLE OF PRIMARY POSITION IS PUT C IN PRMPAR(15) = COSTAP PRMPAR(15) = CTT ENDIF C SET PRMPAR(2) WITH PRELIMINARY VALUE PRMPAR(2) = PRMPAR(15) #else PRMPAR(2) = CTT ENDIF #endif #if __TRAJECT__ ENDIF #endif PRMPAR(3) = SIN( THETAP ) * COS( PHIP ) PRMPAR(4) = SIN( THETAP ) * SIN( PHIP ) IF ( FPRINT .OR. DEBUG .OR. MOD(ISHW-1,IPROUT) .EQ. 0 ) THEN #if __VIEWCONE__ IF ( VUECON(2) .GT. 0.D0 ) WRITE(MONIOU,669) THETAP,PHIP #else IF ( .NOT. FIXINC ) WRITE(MONIOU,669) THETAP,PHIP #endif 669 FORMAT(' PRIMARY ANGLES ARE: THETA = ',F7.4, * ' RAD,',' PHI = ',F7.4,' RAD') ENDIF #if __RIGIDITY__ C RAD TO DEGREE MYTHE = INT( (THETAP * 180.D0/PI) + 0.5D0 ) MYPHI = INT( ((PHIP * 180.D0/PI) + 0.5D0) + GDEC ) C ADJUSTING PHI TO 0-360 IF ( MYPHI .GE. 360.D0 ) THEN MYPHI = MYPHI - 360 ELSEIF ( MYPHI .LT. 0.D0 ) THEN MYPHI = MYPHI + 360 ENDIF C REJECT THE SHOWER IF ENERGY IS LESS THAN RIGIDITY FOR THAT DIRECTION IF ( RIGID( IDANGLE(1+MYTHE, 1+MYPHI) ) .GE. PRMPAR(1) ) THEN WRITE(MONIOU,*) 'REJECTED ',PRMPAR(1),' BECAUSE OF RIGIDITY' GOTO 2 ENDIF #endif C DEFINE HEIGHT FOR START AT THICK0 (IN G/CM**2) C WHICH IS 112.8 KM FOR THICK0 = 0 #if __UPWARD__ IF ( PRMPAR(2) .GE. 0.D0 ) THEN PRMPAR(5) = HEIGH( THICK0 ) ELSE C UPWARD GOING PRIMARY * PRMPAR(5) = 0.D0 * THICK0 = THICK( 0.D0 ) ctp Aug 19, 2010 C THICK0 NOT DEFINED PROPERLY IF FIXHEI IS USED IF ( FIX1I ) THICK0 = THICK( FIXHEI ) PRMPAR(5) = HEIGH( THICK0 ) ENDIF IF ( LLONGI ) LPCT0 = 0 #else PRMPAR(5) = HEIGH( THICK0 ) #if __SLANT__ IF ( LLONGI ) LPCT0 = 0 #else IF ( LLONGI ) LPCT0 = MIN( INT( THICK0*THSTPI ), LPCT0 ) #endif #endif C COUNTER FOR PARTICLE OUTPUT LH = 0 C RESET GENERATION COUNTER GEN = 0.D0 #if __PRESHOWER__ && !__CONEX__ LPCT0 = 0 IF ( PRMPAR(0) .NE. 1.D0 ) THEN WRITE(MONIOU,*) 'PRESHOWER OPTION NEEDS GAMMA PRIMARY: STOP' STOP ENDIF IF ( THETAP .GT. 0.5D0*PI ) THEN WRITE(MONIOU,*) * 'PRESHOWER OPTION NEEDS DOWNWARD GOING SHOWER: STOP' STOP ENDIF C CALCULATE THE HEIGHT OF ATMOSPHERIC BORDER AMARGIN = HEIGH( 1.D-8 ) EVTH(158) = AMARGIN #if __CURVED__ CURPAR(5) = AMARGIN CURPAR(15) = PRMPAR(15) CALL COOINC CURPAR(15) = PRMPAR(2) #else CALL COORIN( AMARGIN ) #endif #if __SLANT__ NSTEP1 = NSTEP + 1 #endif #if __AUGERHIST__ HEIGHTP = AMARGIN COSPHIP = COS( PHIP ) SINPHIP = SIN( PHIP ) TANTEP = TAN( THETAP ) #endif #if __THIN__ C SET WEIGHT WEIGHT = 1.D0 #endif #if __MULTITHIN__ C CLEAR AND INITIALIZE WEIGHTS FOR THE DIFFERENT THINNING MODES CURPAR(40) = 8888000.D0 DO IK = 1, 6 CURPAR(40+IK) = 0.D0 ENDDO DO IK = 1, NMTHIN CURPAR(40+IK) = 1.D0 ENDDO #endif INT_ICOUNT = 0 CALL PRESHO( PRESTR, PREHEI ) C SUBR. PRESHO GIVES C PRESTR: HEIGHT OF START (IN CM) C PREHEI: HEIGHT OF 1ST INTERACTION IN EARTH MAGNETIC FIELD (IN CM) C SECONDARIES (STORED IN CORSIKA STACK) CALL TSTEND C NOW PRINT TIME AND STATUS OF RANDOM GENERATOR DO L = 1, NSEQ CALL RMMAQD( ISEED(1,L),L,'R' ) C SEED EVTH(11+L*3) = REAL( ISEED(1,L) ) C NUMBER OF CALLS EVTH(12+L*3) = MOD ( ISEED(2,L), 1000000 ) C NUMBER OF MILLIONS EVTH(13+L*3) = ISEED(3,L)*1000 + INT( ISEED(2,L)/1000000 ) ENDDO IF ( FPRINT .OR. DEBUG .OR. (IPREPR .GE. 2) ) THEN CALL PRTIME( TTIME ) WRITE(MONIOU,157) ISHOWNO,( L,(ISEED(J,L),J=1,3),L=1,NSEQ ) 157 FORMAT(' AND RANDOM NUMBER GENERATOR AFTER PRESHOWER:',I8, * /,(' SEQUENCE = ',I2,' SEED = ',I9 ,' CALLS = ',I9, * ' BILLIONS = ',I9)) ENDIF #else /* __PRESHOWER__ */ #if __STACKIN__ INT_ICOUNT = 0 C READ IN THE FILE OF SECONDARIES IN STCKIN CALL STCKIN #if __PARALLEL__ IF ( FPRIM ) CALL TSTEND #else CALL TSTEND #endif #endif EVTH(158) = PRMPAR(5) #if __CURVED__ C CALCULATE COORDINATE CORRECTION FOR TOP OF ATMOSPHERE C ALL CALCULATIONS FOR CURPAR ARE MADE IN COOINC C (COSTHE, HAPP, COSTEA). (X, Y) FOR SHOWER CORE = (0,0) H = PRMPAR(5) CURPAR(15) = PRMPAR(15) CALL COOINC #else C CALCULATE NO MAGNETIC DEFLECTION BEFORE THE FIRST INTERACTION BNORMC = 0.D0 C IF PRIMARY IS A MUON: RESET SCATTERING ANGLE VSCAT = 0.D0 PHISCT = 0.D0 C CALCULATE CORRECTIONS OF SHOWER AXIS OFFSET FOR OBSERVATION LEVELS C IN CASE OF FIX1I THE CORRECT OFFSET IS SET IN A SECOND CALL OF C COORIN WITH THE ADJUSTED ALTITUDE OF THE FIRST INTERACTION. C IN CASE OF TMARGIN = .TRUE. THIS SECOND CALL OF COORIN IS SUPPRESSED. CALL COORIN( PRMPAR(5) ) C RESET T, X AND Y COORDINATES OF PRIMARY PARTICLE PRMPAR(6) = 0.D0 PRMPAR(7) = 0.D0 PRMPAR(8) = 0.D0 #if __AUGERHIST__ HEIGHTP = PRMPAR(5) COSPHIP = COS( PHIP ) SINPHIP = SIN( PHIP ) TANTEP = TAN( THETAP ) #endif #endif /* __CURVED__ */ #if __SLANT__ NSTEP1 = NSTEP + 1 #endif #endif /* __PRESHOWER__ */ C RESET ARRAY FOR LONGITUDINAL DISTRIBUTION PER SHOWER IF ( LLONGI ) THEN DO K = 1, 10 DO J = 0, NSTEP1 ELONG(J,K) = 0.D0 PLONG(J,K) = 0.D0 #if __ANAHIST__ PLONG(J,K+10) = 0.D0 #endif ENDDO ENDDO DO K = 1, 19 DO J = 0, NSTEP1 DLONG(J,K) = 0.D0 ENDDO ENDDO ENDIF #if __AUGERHIT__ CALL AUGERCORES #endif #if __CERENKOV__ || __AUGCERLONG__ C COUNTER FOR CHERENKOV OUTPUT IF ( MCERFI .NE. 0 ) THEN DO III = 1, NMAXCERTEL LHCER(III) = 0 ENDDO ENDIF #if __IACT__ C FOR IMAGING TELESCOPES THE CALCULATION OF AN ENERGY-DEPENDENT BUNCH C SIZE IS USELESS SINCE WE ALWAYS TRIGGER ON A FEW PHOTOELECTRONS. C FOR HIGHER ENERGIES WE TRIGGER AT LARGER DISTANCE. #if __CEFFIC__ IF ( CERSIZ .LE. 0.D0 ) CERSIZ = 1.D0 #else IF ( CERSIZ .LE. 0.D0 ) CERSIZ = 5.D0 #endif #else /* __IACT__ */ C CALCULATE BUNCH SIZE FOR CHERENKOV PHOTONS IF NOT SET IN DATAC IF ( ICRSIZ .EQ. 0 ) THEN CALL GETBUS( NINT(PRMPAR(0)),PRMPAR(1),PRMPAR(2),CERSIZ ) IF ( FPRINT .OR. DEBUG ) WRITE(MONIOU,*) * 'CHERENKOV BUNCH SIZE IS CALCULATED TO=',CERSIZ ENDIF #endif /* __IACT__ */ #if !__IACT__ && !__AUGCERLONG__ IF ( ICERML .GE. 1 .AND. ( XSCATT .GT. 0.D0 * .OR. YSCATT .GT. 0.D0 ) ) THEN DO III = 1, ICERML CALL SELCOR( CERXOS(III),CERYOS(III) ) WRITE(MONIOU,4437) ISHW,III,CERXOS(III),CERYOS(III) 4437 FORMAT(' CORE OF EVENT ',I5,' (SCATT# ',I2, * ') AT ',F12.2,9X,F12.2,' CM') ENDDO ENDIF DO III = 1, 20 EVTH( 98+III) = CERXOS(III) EVTH(118+III) = CERYOS(III) ENDDO #endif #endif /* __CERENKOV__ || __AUGCERLONG__ */ #if __PRESHOWER__ && !__CONEX__ CURPAR(3) = PRMPAR(3) CURPAR(4) = PRMPAR(4) #else C GET GAMMA FACTOR FROM ENERGY C FOR MASSLESS PRIMARIES PRMPAR(1) STAYS = ENERGY IF ( PAMA(NINT( PRMPAR(0) )) .NE. 0.D0 ) THEN PRMPAR(1) = PRMPAR(1) / PAMA(NINT( PRMPAR(0) )) IF ( PRMPAR(1) .LE. 1.D0 ) THEN WRITE(MONIOU,*) 'GAMMA FACTOR ',SNGL(PRMPAR(1)), * ' OF PRIMARY IS TOO LOW' WRITE(MONIOU,*) WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORD: ERANGE' STOP ENDIF ENDIF #if __THIN__ C SET WEIGHT WEIGHT = 1.D0 #endif #if __MULTITHIN__ C CLEAR AND INITIALIZE WEIGHTS FOR THE DIFFERENT THINNING MODES CURPAR(40) = 8888000.D0 DO IK = 1, 6 CURPAR(40+IK) = 0.D0 ENDDO DO IK = 1, NMTHIN CURPAR(40+IK) = 1.D0 ENDDO #endif C SET PRIMARY TO CURRENT PARTICLE DO J = 0, 8 CURPAR(J) = PRMPAR(J) ENDDO #if __DYNSTACK__ C Push the primary particle to stack and recieve it directly C This is currently used to notify the stack about the primary particle C In future releases this will likely change to a common interface in basic call dynstack_tstout(SECPAR, (1+MAXLEN)*SIZEOF(SECPAR(0)), * dynRet) call dynstack_fstack( SECPAR, (MAXLEN+1)*SIZEOF(SECPAR(0))) #endif #if __EHISTORY__ C RESET HISTORY INFORMATION DO J = 1, 22 CURPAR(16+J) = 0.D0 ENDDO #endif #if !__STACKIN__ && !__CONEX__ C CALCULATE FIRST INTERACTION POINT IF HADRONIC H = HEIGH( THICK0 ) CALL BOX2 #endif #if __INTTEST__ C RESET THE TRANSVERSE MOMENTUM CURPAR(17) = 0.D0 C IF INTERACTION TEST: HAVE INTERACTION ALWAYS AT THE SAME POINT CHI = 10.D0 IWOUNT = 0 IWOUNP = 0 #endif IF ( FIX1I ) THEN #if __CURVED__ C CALCULATE GEOMETRIC PATH LENGTH TO FIXED FIRST INTERACTION POINT IN C DETECTOR FRAME (DUE TO DIFFERENCES IN H AND FIXHEI (POSSIBLY VERY C DIFFERENT COORDINATE FRAMES) AND TAKE NRANGC FOR GETTING CHI IN A C CURVED ATMOSPHERE #if __UPWARD__ IF ( FIMPCT ) THEN C DISTANCE DIAG BETWEEN DETECTOR POSITION X=Y=0, Z = HIMPCT AND C FIRST INTERACTION POINT DIAG = SQRT( (C(1)+FIXHEI)**2 - (C(1)+HIMPCT)**2 ) DL = SQRT( (C(1)+H)**2 - (C(1)+HIMPCT)**2 ) - DIAG ELSE IF ( PRMPAR(15) .LT. 0.D0 ) THEN DIAG = -SQRT( (C(1)+FIXHEI)**2 - (C(1)+OBSLEV(1))**2 * * (1.D0-PRMPAR(15))*(1.D0+PRMPAR(15)) ) * - (C(1)+OBSLEV(1))*PRMPAR(15) ELSE #endif DIAG = SQRT( (C(1)+FIXHEI)**2 - (C(1)+OBSLEV(1))**2 * * (1.D0-PRMPAR(15))*(1.D0+PRMPAR(15)) ) * - (C(1)+OBSLEV(1))*PRMPAR(15) #if __UPWARD__ ENDIF #endif FIXHAPP = OBSLEV(1) + DIAG * PRMPAR(15) DL = (HAPP - FIXHAPP) / PRMPAR(15) #if __UPWARD__ ENDIF #endif CALL NRANGC( DL ) #else /* __CURVED__ */ #if __UPWARD__ IF ( PRMPAR(2) .GE. 0.D0 ) THEN C NORMAL DOWNWARD PRIMARY CHI = THICK( FIXHEI ) / PRMPAR(2) ELSE C UPWARD PRIMARY CHI = ( THICK( FIXHEI ) - THICK(0.D0) ) / PRMPAR(2) ENDIF #else C CHI IS GIVEN BY FIXED INTERACTION HEIGHT CHI = THICK( FIXHEI ) / PRMPAR(2) #endif #endif /* __CURVED__ */ CHI = MAX( 0.D0, CHI ) C SET FIRST INTERACION ONLY FOR NON-EM PRIMARIES IF ( PRMPAR(0) .GT. 3 ) THEN H = FIXHEI ENDIF C FIRST INTERACTION IS NOT DECAY ONLY FOR HADRONS C FOR ALL OTHER PARTICLES THE DECAY FLAG IS SET IN BOX2 IF ( PRMPAR(0) .GE. 7 ) THEN FDECAY = .FALSE. ENDIF #if __CURVED__ && __UPWARD__ ELSEIF ( FIMPCT ) THEN H = MAX( H, HLAY(1) + 100.D0 ) H = MIN( H, HLAY(6) - 1.D0 ) #endif ELSE C FIRST INTERACTION IS NOT FIXED C CHI IS GIVEN BY BOX2 #if __CURVED__ THICKH = THICK0 THCKHN = THICKC( CHI ) #else THCKHN = CHI*PRMPAR(2) + THICK0 #endif C STARTING ALTITUDE MUST BE INSIDE ATMOSPHERE H = HEIGH( THCKHN ) H = MAX( H, HLAY(1) + 100.D0 ) H = MIN( H, HLAY(6) - 1.D0 ) ENDIF HEIGHP = H #if !__CONEX__ THICK1 = THICK( H ) IF ( CURPAR(0) .GT. 3.D0 .OR. .NOT. FEGS ) THEN CHISUM = CHISUM + THICK1 CHISM2 = CHISM2 + THICK1**2 ENDIF #else C THICK1 CALCULATED IN CONEX #endif ALEVEL = H C STORE PRIMARY COORDINATES FOR ADDITIONAL MUON INFORMATION IF ( FMUADD ) THEN IF ( CURPAR(0) .EQ. 5.D0 .OR. CURPAR(0) .EQ. 6.D0 ) THEN DO J = 0, MAXLEN AMUPAR(J) = CURPAR(J) ENDDO AMUPAR(5) = PRMPAR(5) IF ( DEBUG ) WRITE(MDEBUG,*) 'AAMAIN: MUON STORED IN AMUPAR' FMUORG = .TRUE. ELSE FMUORG = .FALSE. ENDIF ENDIF C UPDATE PATH (CHI) OF PRIMARY PARTICLE (AT INTERACTION POINT) PRMPAR(9) = CHI #endif /* __PRESHOWER__ */ C SET TARGET FLAG IF SELECTED FOR FIRST INTERACTION IF ( N1STTR .GT. 0 .AND. PRMPAR(0) .GT. 3.D0 ) THEN FIXTAR = .TRUE. FDECAY = .FALSE. EVTH(6) = REAL( N1STTR ) ELSE FIXTAR = .FALSE. EVTH(6) = 0. ENDIF C INITIALIZE ARRAYS FOR NKG FOR EACH SHOWER IF ( FNKG ) CALL STANKG C STORE FIRST PARTICLE IN HEADER AND PRINT IT OUT EVTH( 2) = REAL( ISHOWNO ) EVTH( 3) = PRMPAR(0) IF ( PAMA(NINT( PRMPAR(0) )) .EQ. 0.D0 ) THEN C PRIMARY ENERGY FOR MASSLESS PARTICLES (GAMMAS, NEUTRINOS) E00 = PRMPAR(1) E00PN = PRMPAR(1) INUCL = 1 ELSE E00 = PRMPAR(1) * PAMA(NINT( PRMPAR(0) )) INUCL = INT( MAX( 1.D0, PRMPAR(0)/100.D0 ) ) E00PN = E00 / INUCL ENDIF #if __THIN__ C SET ENERGY THRESHOLD FOR THINNING IN GEV ETHINNG = E00 * EFRCTHN C SET ENERGY THRESHOLD (IN MEV) FOR EGS ETHINN = ETHINNG * 1000.D0 * THINRAT IF ( DEBUG ) THEN WRITE(MDEBUG,*) 'AAMAIN: ETHINN =',SNGL(ETHINNG),' GEV' ENDIF IF ( ETHINNG .GT. 1.0D7 ) THEN WRITE(MDEBUG,*) * ' ETHINN_HADR=',SNGL(ETHINNG),' GEV IS REDUCED TO 1.E7 GEV ' ETHINNG = 1.D7 ENDIF EVTH(148) = ETHINNG / E00 IF ( ETHINN .GT. 1.0D10 ) THEN WRITE(MDEBUG,*) ' ETHINN_EM=',SNGL(ETHINN*0.001D0), * ' GEV IS REDUCED TO 1.E7 GEV ' ETHINN = 1.D10 ENDIF EVTH(149) = ETHINN * 0.001D0 / E00 IF ( WLIM ) THEN C SET WEIGHT LIMIT SLIDING WITH ACTUAL ENERGY WMAXEM = MAX( 1.D0,WMAXE0 * E00 / LLIMIT ) WMAX = MAX( 1.D0,WMAX0 * E00 / LLIMIT ) EVTH(150) = WMAX EVTH(151) = WMAXEM #if __STACKIN__ IF ( ISHW .EQ. 1 .OR. FPRINT .OR. DEBUG ) THEN #else IF ( ISPEC.NE.0 .AND. (FPRINT .OR. DEBUG) ) THEN #endif WRITE(MONIOU,667)WMAXEM,ETHINN*0.001D0,WMAX,ETHINNG 667 FORMAT(' ACTUAL THIN PARAMETERS ARE ',1P, * 'EM : WMAX_EM= ',E12.5,' E_THIN_EM= ',E12.5,' GEV'/ * 28X,'HADRONIC: WMAX_H = ',E12.5,' E_THIN_H = ',E12.5,' GEV') ENDIF ENDIF #else EVTH(148) = 0. EVTH(149) = 0. EVTH(150) = 0. EVTH(151) = 0. EVTH(152) = 0. #endif #if __MULTITHIN__ IF ( NMTHIN .GT. 0 ) THEN IF ( FPRINT .OR. DEBUG ) THEN WRITE(MONIOU,'(/,'' MULTITHIN PARAMETERS:'')') WRITE(MONIOU,664) 664 FORMAT(5X,'MODE',6X,'EFRCTHN',4X,'WMAX_E',3X,'THINRAT', * 1X,'WEITRAT') ENDIF DO J = 1, NMTHIN C SET ENERGY THRESHOLD FOR THINNING IN GEV EMTHNNG(J) = E00 * EMFRACTH(J) C SET ENERGY THRESHOLD (IN MEV) FOR EGS EMTHNN(J) = EMTHNNG(J) * 1000.D0 * THNMRTH(J) IF ( FPRINT .OR. DEBUG ) WRITE(MONIOU,665) J,EMFRACTH(J), * WMMAX0(J),THNMRTH(J),WTRATMH(J),EMTHNN(J)*1.D-3 665 FORMAT(5X,'MTHIN_',I1,': ',1P,E9.1,E12.4,0P,2F7.0, * ' BELOW',1P,E12.4,' GEV') IF ( EMTHNNG(J) .GT. 1.0D7 ) THEN WRITE(MONIOU,*) J,' ETHINN_HADR=',SNGL(EMTHNNG(J)), * ' GEV IS REDUCED TO 1.E7 GEV' EMTHNNG(J) = 1.D7 ENDIF IF ( EMTHNN(J) .GT. 1.0D10 ) THEN WRITE(MONIOU,*) J,' ETHINN_EM=',SNGL(EMTHNN(J)*0.001D0), * ' GEV IS REDUCED TO 1.E7 GEV ' EMTHNN(J) = 1.D10 ENDIF C SET WEIGHT LIMIT SLIDING WITH ACTUAL ENERGY WMMAX(J) = MAX( 1.D0,WMMAX0(J) * E00 / LLIMIT ) WMMAXEM0(J) = WMMAX0(J) * WTRATMH(J) WMMAXEM(J) = MAX( 1.D0,WMMAXEM0(J) * E00 / LLIMIT ) #if __STACKIN__ IF ( ISHW .EQ. 1 .OR. FPRINT .OR. DEBUG ) THEN #else IF ( ISPEC.NE.0 .AND. (FPRINT .OR. DEBUG) ) THEN #endif WRITE(MONIOU,667) J,WMMAX(J),EMTHNNG(J), * WMMAXEM(J),EMTHNN(J)*0.001D0 667 FORMAT(' ACTUAL THIN PARAMETERS FOR MODE ',I1,' ARE ',1P, * 'HADRONIC: WMAX_H = ',E12.5,' E_THIN_H = ',E12.5,' GEV'/ * 39X,'EM : WMAX_EM= ',E12.5,' E_THIN_EM= ',E12.5,' GEV') ENDIF ENDDO C WRITE PARAMETERS TO EVTH EVTH(177) = REAL( NMTHIN ) WRITE(MONIOU,*) 'EVENT:',ISHOWNO,' WITH MULTITHIN' DO J = 1, NMTHIN EVTH(177+J) = EMTHNNG(J) / E00 EVTH(183+J) = WMMAX(J) EVTH(189+J) = EMTHNN(J) * 0.001D0 / E00 EVTH(195+J) = WMMAXEM(J) C RANDOM GENERATOR STATUS AT BEGINNING OF SHOWER CALCULATION CALL RMMAQD( ISEED(1,10+J),10+J,'R' ) C SEED EVTH(201+J) = REAL( ISEED(1,10+J) ) C NUMBER OF CALLS EVTH(202+J) = MOD( ISEED(2,10+J), 1000000 ) C NUMBER OF MILLIONS EVTH(203+J) = ISEED(3,10+J)*1000 +INT(ISEED(2,10+J)/1000000) IF ( FPRINT .OR. DEBUG .OR. MOD(ISHW-1,IPROUT) .EQ. 0 ) THEN WRITE(MONIOU,160) 10+J,(ISEED(L,10+J), L=1,3) 160 FORMAT(' SEQUENCE = ',I2,' SEED = ',I9, * ' CALLS = ',I9,' BILLIONS = ',I9) ENDIF ENDDO ENDIF #endif #if __ICECUBE1__ EVTH(220) = energy_interesting #endif #if __ICECUBE2__ EVTH(221) = 0. IF ( gzip_output ) EVTH(221) = 1. EVTH(222) = 0. IF ( pipe_output ) EVTH(222) = 1. #endif IF ( FEGS ) THEN C PARAMETER FOR ELECTRON AND GAMMA REJECT (CONVERT ENERGY TO MEV) C TO BE USED WITH SPITZER ALGORITHM CDH EONCUT = .5D-9 * SQRT( E00*1000.D0 ) C LIMITATION OF ENERGY DEPENDENCE TO VALUES BELOW 100 TEV EONCUT = .5D-9 * SQRT( MIN( E00*1000.D0, 1.D8 ) ) CUTLN = LOG( EONCUT ) ENDIF EVTH( 4) = E00 #if __PRESHOWER__ C STARTING ALTITUDE (PRESTR) & FIRST INTERACTION (PREHEI) OF PRESHOWER EVTH( 5) = PRESTR EVTH( 7) = PREHEI * EVTH( 7) = HLAY(6) PTOT0 = SQRT( (E00-PAMA(NINT( PRMPAR(0) ))) * *(E00+PAMA(NINT( PRMPAR(0) ))) ) #else EVTH( 5) = THICK0 EVTH( 7) = HEIGHP #if __STACKIN__ || __CONEX__ PTOT0 = SQRT( (E00-PAMA(NINT( PRMPAR(0) ))) * *(E00+PAMA(NINT( PRMPAR(0) ))) ) #else PTOT0 = SQRT( (E00-PAMA(NINT( CURPAR(0) ))) * *(E00+PAMA(NINT( CURPAR(0) ))) ) #endif #endif PTOT0N = PTOT0 / INUCL #if __INTTEST__ CC IF ( PTOT0N .GT. HILOELB ) THEN CC FLOR = .TRUE. CC ELSE FLOR = .FALSE. CC ENDIF #endif #if __CURVED__ C PUT APPARENT ANGLES (SEEN FROM DETECTOR) INTO EVENT HEADER ST = SQRT( (1.D0-COSTAP) * (1.D0+COSTAP) ) EVTH(10) = PTOT0 * COSTAP THETA = ACOS( COSTAP ) #else #if __PRESHOWER__ COSTHE = PRMPAR(2) #endif ST = SQRT( (1.D0-COSTHE) * (1.D0+COSTHE) ) EVTH(10) = PTOT0 * COSTHE THETA = ACOS( COSTHE ) EVTH( 8) = PTOT0 * PHIX EVTH( 9) = PTOT0 * PHIY #endif EVTH(11) = THETA IF ( PHIX .NE. 0.D0 .OR. PHIY .NE. 0.D0 ) THEN EVTH(12) = SNGL( ATAN2( PHIY,PHIX ) ) ELSE EVTH(12) = 0. ENDIF #if __CURVED__ EVTH( 8) = PTOT0 * ST * COS( EVTH(12) ) EVTH( 9) = PTOT0 * ST * SIN( EVTH(12) ) #endif #if __UNIX__ C WRITE ENERGY AND ANGLES OF PRIMARY TO DBASE FILE FOR THE FIRST SHOWER IF ( FDBASE .AND. ISHW .EQ. 1 ) THEN #if __THIN__ EFRACEM = EFRCTHN * THINRAT IF ( NSHOW .EQ. 1 ) THEN C IF ONLY ONE SHOWER HAS TO BE SIMULATED, PRINT ACTUAL VALUES FOR WMAX WRITE(MDBASE,670) EFRACEM,WMAX,WMAXEM,RMAX*0.01D0 ELSE C IF MANY SHOWERS HAVE TO BE SIMULATED, PRINT THE INPUT VALUE FOR WMAX WRITE(MDBASE,670) EFRACEM,WMAX0,WMAXE0,RMAX*0.01D0 ENDIF #if __AUGERINFO__ 670 FORMAT(1P,'thinnlev_em = ',E14.7,/,'maxweight_had = ',E14.7,/, $ 'maxweight_em = ',E14.7,/,'rad_max = ',E14.7) #else 670 FORMAT(1P,'#thinnlev_em#',E14.7,'#maxweight_had#',E14.7,/, $ '#maxweight_em#',E14.7,'#rad_max#',E14.7) #endif #endif WRITE(MDBASE,668) E00, THETA*180.D0/PI, EVTH(12)*180.D0/PI #if __AUGERINFO__ 668 FORMAT(1P,'energy_prim = ',E14.7,/,'theta_prim = ',E14.7,/, * 'phi_prim = ',E14.7) #else 668 FORMAT(1P,'#energy_prim#',E14.7,'#theta_prim#',E14.7, * '#phi_prim#',E14.7) #endif CLOSE(UNIT=MDBASE) ENDIF #endif #if __CERENKOV__ EVTH(85) = CERSIZ #endif IF ( DEBUG .OR. FPRINT ) THEN WRITE(MONIOU,*) IF ( TMARGIN ) THEN #if !__UPWARD__ WRITE(MONIOU,*) 'TRACKING STARTS AT MARGIN OF ATMOSPHERE' #endif ELSE WRITE(MONIOU,*) 'TRACKING STARTS AT FIRST INTERACTION' ENDIF ENDIF #if !__STACKIN__ && !__CONEX__ IF ( PRMPAR(0) .GT. 3.D0 ) THEN IF ( DEBUG ) THEN WRITE(MONIOU,102) (CURPAR(J),J = 0,8) 102 FORMAT(' PRIMARY PARAMETERS AT FIRST INTERACTION POINT',/, * 16X,1P,9E11.3) #if __MULTITHIN__ WRITE(MDEBUG,31) (CURPAR(I),I=41,46) 31 FORMAT(' WEIGHTS 41-46: ',1P,6E11.3) #endif ELSEIF ( FPRINT ) THEN WRITE(MONIOU,1021) (CURPAR(J),J = 0,8) 1021 FORMAT(' PRIMARY PARAMETERS AT FIRST INTERACTION POINT',/, * 1X,1P,9E11.3) ENDIF ELSE IF ( FPRINT .OR. DEBUG ) WRITE(MONIOU,132) 132 FORMAT(/,' PRIMARY PARTICLE IS ELECTROMAGNETIC') ENDIF #endif #if __INTTEST__ C RESET HISTOGRAMMING ARRAYS AT BEGINNING OF EACH SHOWER CALL HISRES C DO NOT ALLOW A DECAY AS A FIRST INTERACTION IN INTERACTION TEST FDECAY = .FALSE. C FORCE TO START CLOCK AT FIRST INTERACTION TMARGIN = .FALSE. C DON''T WRITE EVENT HEADER TO DAT.... FILES IN CASE OF INTERACT. TEST #else C WRITE EVENT HEADER INTO BUFFER #if !__STACKIN__ && !__PRESHOWER__ && !__CONEX__ C FOR EM PARTICLES EVTH IS WRITTEN TO BUFFER IN EGS (IF ACTIVE) IF ( PRMPAR(0) .GT. 3.D0 .OR. .NOT. FEGS ) THEN #elif __PRESHOWER__ C WRITE EVTH TO BUFFER ONLY IF FIRST INTERACTION HAPPENED IF ( FNPRIM ) THEN #endif C NEGATIVE FIRST INTERACTIN HEIGHT, IF TRACKING STARTS AT ATMOS. MARGIN IF ( TMARGIN ) EVTH(7) = -EVTH(7) #if __REMOTECONTROL__ || __DYNSTACK__ C The changes from IACT TELEVT are not in the stack CALL baack_modify_evth(EVTH, SIZEOF(EVTH) ) #endif #if __CERENKOV__ && __IACT__ CALL TELEVT( EVTH, PRMPAR ) #endif #if __REMOTECONTROL__ CALL remotecontrol_push_evth(EVTH) CALL remotecontrol_push_initalparticle(PRMPAR) #endif #if __COMPACT__ IF ( COMOUT ) THEN IF ( EVTH(2) .LT. 1.5 ) THEN CALL TOBUFS( EVTH,MAXBUF ) ELSE CEVTH = 'EVHW' CALL TOBUFS( EVTH,12 ) ENDIF ELSE CALL TOBUF( EVTH,0 ) ENDIF #else #if __PARALLEL__ C WREVTH SIGNALS THAT EVTH HAS BEEN WRITTEN OUT WREVTH = .TRUE. #endif #if !__CONEX__ CALL TOBUF( EVTH,0 ) #endif #endif #if __CERENKOV__ IF ( MCERFI .NE. 0 ) THEN DO ICERBUF = 1, NCERBUF CALL TOBUFC( EVTH,0,ICERBUF ) ENDDO ENDIF #endif #if !__STACKIN__ && !__PRESHOWER__ && !__CONEX__ ENDIF #elif __PRESHOWER__ ENDIF #endif #endif /* __INTTEST__ */ #if __ANAHIST__ && !__CONEX__ C DETERMINE PARAMETERS OF THE SHOWER FRONT FOR HISTOGRAMS C FOR EM PARTICLES IT IS DONE WITHIN THE EGS ROUTINES IF ( PRMPAR(0) .GT. 3.D0 ) CALL SHOWERFRONT #elif __CONEX__ CALL SHOWERFRONT #endif C PRINT HEADER FOR HIGH ENERGY PARTICLES IF ( FPRINT .OR. DEBUG ) WRITE(MONIOU,103) #if __THIN__ 103 FORMAT(/,' TYPE GAMMA COSTHETA ', * ' PHIX PHIY HEIGHT TIME X-CM ', * ' Y-CM GEN/CHI WEIGHT ALEVEL E ON STACK',/) #else 103 FORMAT(/,' TYPE GAMMA COSTHETA ', * ' PHIX PHIY HEIGHT TIME X-CM ', * ' Y-CM GEN/CHI ALEVEL E ON STACK',/) #endif NOPART = 0 #if __CERENKOV__ NOCERB = 0 #endif #if __PRESHOWER__ && !__CONEX__ C FINISH SHOWER IF NO PRESHOWERING AND 'STOP EVENT' IS DEMANDED IF ( FPRSTP ) THEN WRITE(MONIOU,*) 'NO PRESHOWERING, SKIP THAT EVENT' WRITE(MONIOU,*) ' ' GOTO 2077 ENDIF #endif #if __STACKIN__ && !__CONEX__ C SET THE MAGNETIC FIELD BNORMC = BNORM*1.D-3 CHISUM = 0.D0 CHISM2 = 0.D0 C NO FIRST INTERACTION, SET FLAGS ACCORDINGLY FIRSTI = .FALSE. FNPRIM = .TRUE. GOTO 4 #elif __CONEX__ C SET THE MAGNETIC FIELD BNORMC = BNORM*1.D-3 C PRODUCES SECONDARIES IN CONEX AND UPDATES FIRST INTERACTION #if __PARALLEL__ C IF AT LEAST A PARTICLE IS STORED IN 2ND STACK, DO NOT USE CONEX C AND RUN DIRECTLY FROM CORSIKA STACK IF ( JCOUNT-1 .EQ. 0 )THEN #endif CALL CONEXLNK(THICK1,CHISUM,CHISM2) #if __PARALLEL__ ENDIF #endif C CALL OF RUNSHOWER FOR REMAINING PARTICLES IN STACK CALL DUMRUNSHOWER C CALL OF FINISHSHOWER FOR EVENT STATISTICS AND PLOTS CALL DUMFINISHSHOWER 22 CONTINUE !SHOWER LOOP #if __DYNSTACK__ CALL dynstack_end() #endif C CALL OF FINISHRUN FOR RUN STATISTICS AND MEAN PLOTS CALL DUMFINISHRUN C END OF RUN, RETURN TO MAIN AND STOP RETURN C======================================================================= ENTRY RUNSHOWER C----------------------------------------------------------------------- C C SUBPART OF AAMAIN FOR SHOWER DEVELOPMENT C THIS SUBROUTINE IS CALLED FROM FROMCNX AND CORSIKAMAIN VIA EXTERNAL C NAME C C----------------------------------------------------------------------- IF ( .NOT. FCORS ) RETURN GOTO 4 #else IF ( PRMPAR(0) .LE. 3.D0 * .OR. PRMPAR(0) .EQ. 5.D0 .OR. PRMPAR(0) .EQ. 6.D0 * .OR. PRMPAR(0) .EQ. 131.D0 .OR. PRMPAR(0) .EQ. 132.D0 * ) THEN C GIVE PARTICLE TO EGS OR NKG IF ELECTROMAGNETIC C AND TAKE THEN NEXT PARTICLE FROM STACK C FLAG FOR NO PRIMARY INTERACTION IS SET FOR ALL BUT ELM. PRIMARIES IF ( PRMPAR(0) .LE. 3.D0 ) THEN C EM PARTICLES BNORMC = BNORM*1.D-3 #if __PRESHOWER__ CHISUM = 0.D0 CHISM2 = 0.D0 FIRSTI = .FALSE. C EM PARTICLES COMING FROM PRESHOWER AS SECONDARIES, IF PRESHOWERING cdh FNPRIM = .TRUE. ! FNPRIM IS SET IN SUBR. PRESHO GOTO 4 #else FNPRIM = .FALSE. #endif ELSE C MUONS/TAU LEPTONS FNPRIM = .TRUE. H = PRMPAR(5) IF ( TMARGIN ) BNORMC = BNORM*1.D-3 ENDIF #if __PARALLEL__ C IF AT LEAST A PARTICLE IS STORED IN 2ND STACK, DO NOT USE PRIMARY C AND FILL MAIN STACK WITH 2ND STACK (AND NEW SEED) C WHEN THE 2ND STACK IS NOT EMPTY, THE FIRST INTERACTION IS ALREADY PASSED C SO SIMPLY SKIP INTERACTION IN EM OR MUTRAC IN BOX3 #endif CALL BOX3 BNORMC = BNORM*1.D-3 IF ( FEGS ) THEN CHISUM = CHISUM + THICK( ABS(DBLE(EVTH(7))) ) CHISM2 = CHISM2 + THICK( ABS(DBLE(EVTH(7))) )**2 ENDIF C UPDATE POSITION (X,Y,Z,T) OF PRIMARY PARTICLE (AT INTERACTION POINT) DO J = 5, 8 PRMPAR(J) = CURPAR(J) ENDDO C IF TRACKING FROM FIRST INTERACTION POINT UPDATE STARTING ALTITUDE IF(EVTH(7).GT.0.D0) PRMPAR(5) = EVTH(7) #if __CURVED__ PRMPAR(14) = CURPAR(14) PRMPAR(16) = CURPAR(16) #endif FIRSTI = .FALSE. GOTO 4 #if __SIBYLL__ && __CHARM__ ELSEIF ( ( CURPAR(0) .GE. 75.D0 .AND. CURPAR(0) .LT. 116.D0 ) * .OR. ( CURPAR(0) .GT. 174.D0 .AND. CURPAR(0) .LT. 200.D0 ) #else ELSEIF ( ( CURPAR(0) .GE. 50.D0 .AND. CURPAR(0) .LT. 66.D0 ) * .OR. ( CURPAR(0) .GE. 75.D0 .AND. CURPAR(0) .LE. 130.D0 ) * .OR. ( CURPAR(0) .GE. 135.D0 .AND. CURPAR(0) .LT. 200.D0 ) #endif * ) THEN C RESONANCES OR CHARMED PARTICLES ARE ILLEGAL PRIMARY PARTICLES WRITE(MONIOU,*) WRITE(MONIOU,*) 'AAMAIN: UNEXPECTED PARTICLE TYPE=',ITYPE WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORD: PRMPAR' STOP ELSE C HADRONIC PARTICLES (OR NEUTRINOS) FNPRIM = .TRUE. C CHECK OBSERVATION LEVEL PASSAGE AND UPDATE PARTICLE COORDINATES HNEW = H C FOR SUBR. UPDATE WE NEED THE START ALTITUDE H H = HEIGH( THICK0 ) #if __CURVED__ C TRACK THE PARTICLE WHEN ENTERING THE ATMOSPHERE FLAGC = .FALSE. IPAS = 0 #if !__UPWARD__ && __CERENKOV__ C SET TRANSPORT LENGTH MAXIMUM TO 6 KM FOR PRIMARY NUCLEUS C TO GET CERENKOV FROM PRIMARY NUCLEUS MORE PRECISELY IF ( PRMPAR(0) .GT. 200.D0 ) C(3) = 6.0D5 CALL UPDATC( IPAS,FLAGC ) C RESET TRANSPORT LENGTH AT TOP OF ATMOSPHERE TO ORIGINAL VALUE C(3) = 20.0D5 #else CALL UPDATC( IPAS,FLAGC ) #endif C UPDATE POSITION (X,Y,Z,T) OF PRIMARY PARTICLE (AT INTERACTION POINT) DO J = 5, 8 PRMPAR(J) = CURPAR(J) ENDDO PRMPAR(14) = CURPAR(14) PRMPAR(16) = CURPAR(16) IF ( IRET2 .NE. 0 ) GOTO 4 IF ( IPAS .EQ. 0 ) THEN CDH 25.04.2003 * THICK1 = THICK( H ) C PARTICLE DID NOT REACH OBSERVATION LEVEL C START CLOCK AT FIRST INTERACTION (MAGNETIC FIELD IS SET IN INPRM) IF ( .NOT. TMARGIN ) CURPAR(6) = 0.D0 C CLOCK HAS BEEN STARTED AT TOP OF ATMOSPHERE C JUMP INTO NORMAL PARTICLE TREATMENT FOR HADRONS #if __PARALLEL__ C IF AT LEAST A PARTICLE IS STORED IN 2ND STACK, DO NOT USE PRIMARY C AND FILL MAIN STACK WITH 2ND STACK (AND NEW SEED) C WHEN THE 2ND STACK IS NOT EMPTY, THE FIRST INTERACTION IS ALREADY PASSED IF ( JCOUNT .GT. 1 ) THEN FIRSTI = .FALSE. GOTO 4 ENDIF #endif C JUMP INTO NORMAL PARTICLE TREATMENT FOR HADRONS GOTO 6 ENDIF #else /* __CURVED__ */ C TRACK THE PARTICLE WHEN ENTERING THE ATMOSPHERE, SET MAGNETIC FIELD C (CLOCK IS ALREADY STARTED AT MARGIN OF ATMOSPHERE IN SUBR. INPRM) IF ( TMARGIN ) BNORMC = BNORM*1.D-3 THICKH = THICK0 C MASS OVERLAY AT INTERACTION POINT IS THCKHN = THICK0 + PRMPAR(2) * CHI #if __UPWARD__ THCKHN = MAX( 0.D0, THCKHN ) #endif IF ( DEBUG ) WRITE(MDEBUG,*) 'AAMAIN: THICKH,THCKHN,HNEW=', * SNGL(THICKH),SNGL(THCKHN),SNGL(HNEW) C UPDATE PARTICLE TO INTERACTION POINT (IF IT REACHES SO FAR) C AND STORE COORDINATES IN PROPAR #if !__UPWARD__ && __CERENKOV__ IF ( TMARGIN .AND. ( HNEW .GT. OBSLEV(NOBSLV) ) ) THEN C SAVE ORIGINAL PARTICLE PARAMETERS HSTART = H ! ALTITUDE AT BEGINNING OF TRANSPORT HEND = HNEW ! ALTITUDE AT END OF TRANSPORT THCKOLD = THICKH DO II = 0, 8 ORGPAR(II) = CURPAR(II) ENDDO C CHOP TRANSPORT DISTANCE TO GET CHERENKOV FROM PRIMARY MORE PRECISELY KKKEND = 20 ! WE CHOP THE DISTANCE INTO 20 SEGMENTS DELTAHK = (H - HNEW) / DBLE(KKKEND) DO KKK = 1, KKKEND HNEWKKK = MAX( 0.D0, HSTART-DBLE(KKK)*DELTAHK ) THCKKK = MAX( 0.D0, THICK( HNEWKKK ) ) THICKH = THICK(H) CALL UPDATE( HNEWKKK, THCKKK, 0 ) IF ( DEBUG ) WRITE(MDEBUG,*) & 'AAMAIN: KKK=',KKK,' IRET1..2=',IRET1,IRET2 IF ( IRET2 .EQ. 0 ) THEN C STORE PRIMARY PARTICLE FOR FURTHER TREATMENT DO II = 0, 8 CURPAR(II) = OUTPAR(II) ENDDO IRET4 = 0 ELSE C PRIMARY PARTICLE CUTTED; IT MAY HOWEVER PASS SOME C OF THE OBSERVATION LEVELS IRET4 = 1 GOTO 122 ENDIF C PRIMARY IS NOW UPDATED TO END OF STEP IN LOOP ENDDO HNEW = HEND IRET2 = IRET4 122 CONTINUE C THE PARTICLE COORDINATES AT END OF CHOPPING ARE IN OUTPAR C RESTORE PARTICLE COORDINATES AT THE BEGINNING DO II = 0, 8 CURPAR(II) = ORGPAR(II) ENDDO THICKH = THCKOLD ELSE CALL UPDATE( HNEW, THCKHN, 0 ) ENDIF #else CALL UPDATE( HNEW, THCKHN, 0 ) #endif IF ( DEBUG ) WRITE(MDEBUG,*) 'AAMAIN: IRET1..2=',IRET1,IRET2 C STORE PARTICLE FOR FURTHER TREATMENT IF ( IRET2 .EQ. 0 ) THEN IF ( DEBUG ) WRITE(MDEBUG,454) (OUTPAR(II),II=0,8) 454 FORMAT(' AAMAIN: OUTPAR=',1P,9E11.3) DO II = 0, 8 PROPAR(II) = OUTPAR(II) ENDDO #if __EHISTORY__ DO II = 17, 38 PROPAR(II) = OUTPAR(II) ENDDO #endif #if __MULTITHIN__ DO II = 41, 46 PROPAR(II) = OUTPAR(II) ENDDO #endif IRET3 = 0 ELSE C PARTICLE CUTTED AT INTERACTION POINT; IT MAY HOWEVER PASS SOME OF THE C OBSERVATION LEVELS IRET3 = 1 IRETC = IRETE ENDIF DO 251 J = 1, NOBSLV C CHECK OBSERVATION LEVEL PASSAGE AND UPDATE PARTICLE COORDINATES #if __PARALLEL__ C FIRST TRACK AND SECOND STACK NOT EMPTY, PRIMARY SHOULD NOT BE TRACKED IF( .NOT. (JCOUNT .GT. 1 ))THEN #endif #if __UPWARD__ IF ( COSTHE .LT. 0.D0 ) THEN IF ( HNEW .GT. OBSLEV(J) ) GOTO 255 ELSE IF ( HNEW .LT. OBSLEV(J) ) GOTO 255 ENDIF #else IF ( HNEW .LT. OBSLEV(J) ) GOTO 255 #endif #if __PARALLEL__ ENDIF #endif IF ( IRET3 .EQ. 0 ) THEN DO II = 0, 8 CURPAR(II) = PROPAR(II) ENDDO #if __EHISTORY__ DO II = 17, 38 CURPAR(II) = PROPAR(II) ENDDO #endif #if __MULTITHIN__ DO II = 41, 46 CURPAR(II) = PROPAR(II) ENDDO #endif ALEVEL = H BETA = SQRT( (GAMMA-1.D0)*(GAMMA+1.D0) ) / GAMMA IF ( .NOT. TMARGIN ) THEN C INITIALIZE COORDINATE CORRECTIONS FOR HADRONIC PRIMARIES C FOR EM PRIMARIES IT IS DONE IN EGS CALL COORIN( H ) #if __SLANT__ NSTEP1 = NSTEP + 1 #endif #if __AUGERHIST__ HEIGHTP = H #endif C START CLOCK AT FIRST INTERACTION AND SET MAGNETIC FIELD CURPAR(6) = 0.D0 CURPAR(7) = 0.D0 CURPAR(8) = 0.D0 BNORMC = BNORM*1.D-3 #if __COASTUSERLIB__ C CORRECT COORDINATES FOR SHIFT OF ORIGIN PERFORMED BY COORIN C WE TRACK PARTICLE BEFORE THE FIRST INTERACTION pnt1t = -PROPAR(6) pnt1x = -PROPAR(7) pnt1y = -PROPAR(8) pnt2t = 0.d0 pnt2x = 0.d0 pnt2y = 0.d0 C SLANT DEPTH IS NOT DEFINED BEFORE THE FIRST INTERACTION C AND STARTS WITH THE FIRST INTERACTION pnt1d = 0.d0 pnt2d = 0.D0 #endif ENDIF C UPDATE POSITION (X,Y,Z,T) OF PRIMARY PARTICLE (AT INTERACTION POINT) DO II = 5, 8 PRMPAR(II) = CURPAR(II) ENDDO #if __PARALLEL__ C IF AT LEAST A PARTICLE IS STORED IN 2ND STACK, DO NOT USE PRIMARY C AND FILL MAIN STACK WITH 2ND STACK (AND NEW SEED) C WHEN THE 2ND STACK IS NOT EMPTY, THE FIRST INTERACTION IS ALREADY PASSED IF ( JCOUNT .GT. 1 ) THEN FIRSTI = .FALSE. GOTO 4 ENDIF #endif #if __COASTUSERLIB__ call track(pnt1x, pnt2x) #endif C JUMP INTO NORMAL PARTICLE TREATMENT FOR HADRONS GOTO 6 ELSE C ELIMINATE PARTICLE IF BELOW CUTS BY JUMP TO LABEL 4 IF ( LLONGI .AND. .NOT.IRETE ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT AT BEGIN OF PATH #if __SLANT__ #if __CURVED__ LHEIGH = LBIN( X,Y,HAPP,1 ) #else LHEIGH = LBIN( X,Y,H,1 ) #endif #else LHEIGH = INT( THICKH*THSTPI + 1.D0 ) #endif IF ( ITYPE .EQ. 8 .OR. ITYPE .EQ. 9 .OR. * ITYPE .EQ. 11 .OR. ITYPE .EQ. 12 ) THEN FAC1 = 0.25D0 FAC2 = 0.75D0 ELSEIF ( ITYPE .EQ. 10 .OR. ITYPE .EQ. 16 ) THEN FAC1 = 0.5D0 FAC2 = 0.5D0 ELSE FAC1 = 1.D0 FAC2 = 0.D0 ENDIF #if __THIN__ C ADD TO THE HADRON ENERGY DEPOSIT DLONG(LHEIGH,17) = DLONG(LHEIGH,17)+(GAMMA*PAMA(ITYPE) * - RESTMS(ITYPE) ) * WEIGHT * FAC1 C ADD TO THE NEUTRINO DEPOSIT DLONG(LHEIGH,18) = DLONG(LHEIGH,18)+(GAMMA*PAMA(ITYPE) * - RESTMS(ITYPE) ) * WEIGHT * FAC2 #else C ADD TO THE HADRON ENERGY DEPOSIT DLONG(LHEIGH,17) = DLONG(LHEIGH,17)+(GAMMA*PAMA(ITYPE) * - RESTMS(ITYPE))*FAC1 C ADD TO THE NEUTRINO DEPOSIT DLONG(LHEIGH,18) = DLONG(LHEIGH,18)+(GAMMA*PAMA(ITYPE) * - RESTMS(ITYPE))*FAC2 #endif ENDIF #if __AUGERHIST__ IF ( IRETC .AND. LEVL .EQ. NOBSLV ) THEN DO LLL = 1, NOBSLV IF ( THCKHN .GE. THCKOB(LLL) .AND. * THCKHN .LT. THCKOB(LLL)+SAMPTH ) THEN C THCKHN AFTER TRANSPORT IS WITHIN 1 G/CM^2 BELOW OBSLEV(LLL) C BRING THE ENERGY BELOW CUT TO THE HISTO OF LEVEL LLL CALL AUGCUT( LLL ) ELSEIF ( THCKHN .LT. THCKOB(LLL) ) THEN GOTO 111 ENDIF ENDDO 111 CONTINUE ENDIF #endif ENDIF GOTO 4 255 CONTINUE #if __UPWARD__ IF ( COSTHE .LT. 0.D0 ) THEN IF ( H .GT. OBSLEV(J) ) GOTO 251 ELSE IF ( H .LT. OBSLEV(J) ) GOTO 251 ENDIF #else IF ( H .LT. OBSLEV(J) ) GOTO 251 #endif C REMEMBER NUMBER OF LEVEL FOR OUTPUT LEVL = J #if !__UPWARD__ && __CERENKOV__ IF ( TMARGIN ) THEN C SAVE ORIGINAL PARTICLE PARAMETERS HSTART = H ! ALTITUDE AT BEGINNING OF TRANSPORT HEND = OBSLEV(J) ! ALTITUDE AT END OF TRANSPORT THCKOLD = THICKH DO II = 0, 8 ORGPAR(II) = CURPAR(II) ENDDO C CHOP TRANSPORT DISTANCE TO GET CHERENKOV FROM PRIMARY MORE PRECISELY KKKEND = 20 ! WE CHOP THE DISTANCE INTO 20 SEGMENTS DELTAHK = (H - OBSLEV(J)) / DBLE(KKKEND) DO KKK = 1, KKKEND HNEWKKK = MAX( 0.D0, HSTART-DBLE(KKK)*DELTAHK ) THCKKK = MAX( 0.D0, THICK( HNEWKKK ) ) THICKH = THICK(H) CALL UPDATE( HNEWKKK, THCKKK, J ) IF ( DEBUG ) WRITE(MDEBUG,*) & 'AAMAIN: KKK=',KKK,' IRET1..2=',IRET1,IRET2 IF ( IRET2 .EQ. 0 ) THEN C STORE PRIMARY PARTICLE FOR FURTHER TREATMENT DO II = 0, 8 CURPAR(II) = OUTPAR(II) ENDDO IRET4 = 0 ELSE C PRIMARY PARTICLE CUTTED; IT MAY HOWEVER PASS SOME C OF THE OBSERVATION LEVELS IRET4 = 1 GOTO 123 ENDIF C PRIMARY IS NOW UPDATED TO END OF STEP IN LOOP ENDDO HNEW = HEND IRET2 = IRET4 123 CONTINUE C THE PARTICLE COORDINATES AT END OF CHOPPING ARE IN OUTPAR C RESTORE PARTICLE COORDINATES AT THE BEGINNING DO II = 0, 8 CURPAR(II) = ORGPAR(II) ENDDO THICKH = THCKOLD ELSE CALL UPDATE( OBSLEV(J),THCKOB(J),J ) ENDIF #else CALL UPDATE( OBSLEV(J),THCKOB(J),J ) #endif IF ( DEBUG ) WRITE(MDEBUG,256) J,IRET1,IRET2 256 FORMAT(' AAMAIN: LEVEL ',I5,' IRET1,2=',2I5) C IF PARTICLE IS NOT CUTTED, BRING IT TO OUTPUT IF ( IRET2 .EQ. 0 ) THEN CALL OUTPT1 ELSE IF ( LLONGI .AND. LEVL .EQ. NOBSLV * .AND. .NOT.IRETE ) THEN #if __AUGERHIST__ IF ( DEBUG .AND. IRETC ) * WRITE(MDEBUG,445) (CURPAR(K),K=0,9) 445 FORMAT(' AMAIN1: E-DEP',3X,1P,9E11.3,0P,F10.0) #endif C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT AT BEGIN OF PATH #if __SLANT__ #if __CURVED__ LHEIGH = LBIN( X,Y,HAPP,1 ) #else LHEIGH = LBIN( X,Y,H,1 ) #endif #else LHEIGH = INT( THICKH*THSTPI + 1.D0 ) #endif IF ( ITYPE .EQ. 8 .OR. ITYPE .EQ. 9 .OR. * ITYPE .EQ. 11 .OR. ITYPE .EQ. 12 ) THEN FAC1 = 0.25D0 FAC2 = 0.75D0 ELSEIF ( ITYPE .EQ. 10 .OR. ITYPE .EQ. 16 ) THEN FAC1 = 0.5D0 FAC2 = 0.5D0 ELSE FAC1 = 1.D0 FAC2 = 0.D0 ENDIF #if __THIN__ C ADD TO THE HADRON ENERGY DEPOSIT DLONG(LHEIGH,17) = DLONG(LHEIGH,17)+(GAMMA*PAMA(ITYPE) * - RESTMS(ITYPE) ) * WEIGHT * FAC1 C ADD TO THE NEUTRINO DEPOSIT DLONG(LHEIGH,18) = DLONG(LHEIGH,18)+(GAMMA*PAMA(ITYPE) * - RESTMS(ITYPE) ) * WEIGHT * FAC2 #else C ADD TO THE HADRON ENERGY DEPOSIT DLONG(LHEIGH,17) = DLONG(LHEIGH,17)+(GAMMA*PAMA(ITYPE) * - RESTMS(ITYPE))*FAC1 C ADD TO THE NEUTRINO DEPOSIT DLONG(LHEIGH,18) = DLONG(LHEIGH,18)+(GAMMA*PAMA(ITYPE) * - RESTMS(ITYPE))*FAC2 #endif ENDIF #if __AUGERHIST__ IF ( IRETC .AND. LEVL .EQ. NOBSLV ) THEN DO LLL = 1, NOBSLV IF ( THCKHN .GE. THCKOB(LLL) .AND. * THCKHN .LT. THCKOB(LLL)+SAMPTH ) THEN C THCKHN AFTER TRANSPORT IS WITHIN 1 G/CM^2 BELOW OBSLEV(LLL) C BRING THE ENERGY BELOW CUT TO THE HISTO OF LEVEL LLL IF (DEBUG) WRITE(MDEBUG,*) 'AMAIN1: THCKHN=',THCKHN CALL AUGCUT( LLL ) ELSEIF ( THCKHN .LT. THCKOB(LLL) ) THEN GOTO 112 ENDIF ENDDO 112 CONTINUE ENDIF #endif ENDIF 251 CONTINUE #if __COASTUSERLIB__ C PRIMARY HADRON REACHED OBSERVATION LEVEL IF ( IRET2 .EQ. 0 ) call track(pnt1x, pnt2x) #endif #endif /* __CURVED__ */ IF ( DEBUG ) WRITE(MDEBUG,*) * 'AAMAIN: PRIMARY REACHED LOWEST OBSERVATION LEVEL' GOTO 4 ENDIF #endif /*__STACKIN__ || __CONEX__*/ C----------------------------------------------------------------------- C NORMAL CYCLE 7 CONTINUE C IF ENERGY IS TOO SMALL, TAKE NEXT PARTICLE BY JUMP TO LABEL 4 IF ( GAMMA .LE. 1.D0 ) THEN IF ( PAMA(NINT( CURPAR(0) )) .GT. 0.D0 ) THEN IF ( CURPAR(0) .EQ. 5.D0 .OR. CURPAR(0) .EQ. 6.D0 ) * FMUORG = .FALSE. IF ( LLONGI ) THEN #if __AUGERHIST__ #if __STACKIN__ || __CONEX__ IF ( DEBUG ) WRITE(MDEBUG,446) (CURPAR(K),K=0,9) #else IF (DEBUG.AND.IRETC) WRITE(MDEBUG,446) (CURPAR(K),K=0,9) #endif 446 FORMAT(' AMAIN2: E-DEP',3X,1P,9E11.3,0P,F10.0) #endif C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT #if __SLANT__ #if __CURVED__ LHEIGH = LBIN( X,Y,HAPP,1 ) #else LHEIGH = LBIN( X,Y,H,1 ) #endif #else LHEIGH = INT( THICK( H )*THSTPI + 1.D0 ) #endif IF ( ITYPE .EQ. 2 ) THEN #if __THIN__ DLONG(LHEIGH,3) = DLONG(LHEIGH,3) * + (GAMMA+1.D0)*PAMA(2)*WEIGHT ELSEIF ( ITYPE .EQ. 3 ) THEN DLONG(LHEIGH,3) = DLONG(LHEIGH,3) * + (GAMMA-1.D0)*PAMA(2)*WEIGHT ELSEIF ( ITYPE .EQ. 5 .OR. ITYPE .EQ. 6 ) THEN DLONG(LHEIGH,5) = DLONG(LHEIGH,5) + GAMMA*PAMA(5)*WEIGHT ELSE IF ( ITYPE .EQ. 8 .OR. ITYPE .EQ. 9 .OR. * ITYPE .EQ. 11 .OR. ITYPE .EQ. 12 ) THEN FAC1 = 0.25D0 FAC2 = 0.75D0 ELSEIF ( ITYPE .EQ. 10 .OR. ITYPE .EQ. 16 ) THEN FAC1 = 0.5D0 FAC2 = 0.5D0 ELSE FAC1 = 1.D0 FAC2 = 0.D0 ENDIF C ADD TO THE HADRON ENERGY DEPOSIT DLONG(LHEIGH,7) = DLONG(LHEIGH,7)+(GAMMA*PAMA(ITYPE) * - RESTMS(ITYPE) ) * WEIGHT * FAC1 C ADD TO THE NEUTRINO DEPOSIT DLONG(LHEIGH,8) = DLONG(LHEIGH,8)+(GAMMA*PAMA(ITYPE) * - RESTMS(ITYPE) ) * WEIGHT * FAC2 #else DLONG(LHEIGH,3) = DLONG(LHEIGH,3) + (GAMMA+1.D0)*PAMA(2) ELSEIF ( ITYPE .EQ. 3 ) THEN DLONG(LHEIGH,3) = DLONG(LHEIGH,3) + (GAMMA-1.D0)*PAMA(2) ELSEIF ( ITYPE .EQ. 5 .OR. ITYPE .EQ. 6 ) THEN DLONG(LHEIGH,5) = DLONG(LHEIGH,5) + GAMMA * PAMA(5) ELSE IF ( ITYPE .EQ. 8 .OR. ITYPE .EQ. 9 .OR. * ITYPE .EQ. 11 .OR. ITYPE .EQ. 12 ) THEN FAC1 = 0.25D0 FAC2 = 0.75D0 ELSEIF ( ITYPE .EQ. 10 .OR. ITYPE .EQ. 16 ) THEN FAC1 = 0.5D0 FAC2 = 0.5D0 ELSE FAC1 = 1.D0 FAC2 = 0.D0 ENDIF C ADD TO THE HADRON ENERGY DEPOSIT DLONG(LHEIGH,7) = DLONG(LHEIGH,7)+(GAMMA*PAMA(ITYPE) * - RESTMS(ITYPE) ) * FAC1 C ADD TO THE NEUTRINO DEPOSIT DLONG(LHEIGH,8) = DLONG(LHEIGH,8)+(GAMMA*PAMA(ITYPE) * - RESTMS(ITYPE) ) * FAC2 #endif ENDIF ENDIF #if __AUGERHIST__ THICKLOC = THICK( H ) DO LLL = 1, NOBSLV IF ( THICKLOC .GE. THCKOB(LLL) .AND. * THICKLOC .LT. THCKOB(LLL)+SAMPTH ) THEN C THICKH IS WITHIN 1 G/CM^2 BELOW OBSLEV(LLL) C BRING THE ENERGY BELOW CUT TO THE HISTO OF LEVEL LLL DO II = 0, 8 OUTPAR(II) = CURPAR(II) ENDDO OUTPAR( 9) = GEN OUTPAR(10) = ALEVEL OUTPAR(13) = WEIGHT EDEP = ( PAMA(ITYPE)*GAMMA - RESTMS(ITYPE) ) * WEIGHT CALL AUGERDEPFIL( EDEP,LLL,0 ) ELSEIF ( THICKLOC .LT. THCKOB(LLL) ) THEN GOTO 4 ENDIF ENDDO #endif GOTO 4 ENDIF C SPECIAL TREATMENT FOR GAMMAS #if __NEUTRINO__ IF ( CURPAR(0) .EQ. 1.D0 ) THEN ITYPE = 1 CHI = 0.D0 GOTO 5 ENDIF #else ITYPE = 1 CHI = 0.D0 GOTO 5 #endif ENDIF C DETERMINE PLACE OF NEXT INTERACTION CALL BOX2 C CHECK PASSAGE THROUGH OBSERVATION LEVELS AND TRACK PARTICLES TO THE C PLACE OF INTERACTION 5 CONTINUE IRET1 = 0 CALL BOX3 IF ( IRET1 .NE. 0 ) GOTO 4 #if !__STACKIN__ && !__CONEX__ 6 CONTINUE #endif IRET1 = 0 MSMM = 0 C INCREMENT PARTICLE GENERATION AND PROCESS NUCLEAR INTERACTION GEN = GEN + 1.D0 C INITIALIZE INTERMEDIATE STACK FOR ONE REACTION INT_ICOUNT = 0 CALL NUCINT C TRANSFER INTERMEDIATE STACK FOR ONE REACTION CALL TSTEND C ENERGY - MULTIPLICITY STATISTICS IF ( EKINL .LE. 0.1D0 ) THEN MEN = 1 ELSE MEN = 4.D0 + 3.D0 * LOG10(EKINL) MEN = MIN( MEN, 40 ) ENDIF IF ( MSMM .LE. 1 ) THEN MMU = 1 ELSE MMU = 1.D0 + 3.D0 * LOG10(DBLE(MSMM)) MMU = MIN( MMU, 13 ) ENDIF #if __THIN__ MULTMA(MEN,MMU) = MULTMA(MEN,MMU) + NINT( WEIGHT ) MULTOT(MEN,MMU) = MULTOT(MEN,MMU) + NINT( WEIGHT ) #else MULTMA(MEN,MMU) = MULTMA(MEN,MMU) + 1 MULTOT(MEN,MMU) = MULTOT(MEN,MMU) + 1 #endif IF ( DEBUG ) WRITE(MDEBUG,*) 'AAMAIN: EKINL,MSMM=', * SNGL(EKINL),MSMM cdh cdh if(.not.firsti)DEBUG=.false. !switch off debug after first interact cdh IF ( IRET1 .EQ. 0 ) THEN #if __THIN__ IF ( DEBUG ) WRITE(MDEBUG,666) (CURPAR(II),II=0,9),WEIGHT 666 FORMAT(' AAMAIN: CURPAR=',1P,11E11.3) #else IF ( DEBUG ) WRITE(MDEBUG,666) (CURPAR(II),II=0,9) 666 FORMAT(' AAMAIN: CURPAR=',1P,10E11.3) #endif GOTO 7 ENDIF C GET NEXT PARTICLE FROM STACK, IF IRET=1 ALL PARTICLES ARE DONE 4 CONTINUE c if(.not.ltest)ltest= PRMINFO(iptr) #if __ICECUBE1__ IF ( .NOT. still_interesting ) THEN IRET1 = 1 IRET = 1 ELSE IRET1 = 0 CALL FSTACK ENDIF #else IRET1 = 0 CALL FSTACK #endif IF ( FMUADD ) THEN IF ( ( CURPAR(0) .EQ. 5.D0 .OR. CURPAR(0) .EQ. 6.D0 ) * .AND. IRET1 .EQ. 0 .AND. .NOT. FMUORG ) THEN DO J = 0, MAXLEN AMUPAR(J) = CURPAR(J) ENDDO IF ( DEBUG ) WRITE(MDEBUG,*) 'AAMAIN: MUON STORED IN AMUPAR' FMUORG = .TRUE. #if __MUONHIST__ CALL MUONHISTFIL #endif ENDIF ENDIF #if !__INTTEST__ C STACK IS EMPTY, IF IRET1 IS 1 IF ( IRET1 .EQ. 0 ) GOTO 7 #if __CONEX__ RETURN C======================================================================= ENTRY FINISHSHOWER C----------------------------------------------------------------------- C C SUBPART OF AAMAIN AT THE END OF THE SHOWER (EVENT STATISTICS AND PLOTS) C THIS SUBROUTINE IS CALLED FROM CORSIKAMAIN VIA AN EXTERNAL NAME C C----------------------------------------------------------------------- #endif #else IF ( IRET1 .EQ. 0 ) THEN C LET UNSTABLE PARTICLES DECAY FIRST C USUALLY PI0, ETA, K0S, AND HYPERONS C IF THEIR DECAY IS SELECTED BY DATACARD C RESONANCES HAVE TO DECAY IF ( * (CURPAR(0) .EQ. 7.D0 .AND. LPI0) .OR. * (CURPAR(0) .EQ. 17.D0 .AND. LETA) .OR. * (CURPAR(0) .GE. 71.D0 .AND. CURPAR(0) .LE. 74.D0 * .AND. LETA) .OR. * (CURPAR(0) .GE. 18.D0 .AND. CURPAR(0) .LE. 24.D0 * .AND. LHYP) .OR. * (CURPAR(0) .GE. 26.D0 .AND. CURPAR(0) .LE. 32.D0 * .AND. LHYP) .OR. * (CURPAR(0) .EQ. 16.D0 .AND. LK0S) .OR. * (CURPAR(0) .GE. 50.D0 .AND. CURPAR(0) .LT. 66.D0) * ) THEN GOTO 7 ELSE C THE OTHER PARTICLES ARE TAKEN FROM STACK AND STORED FOR HISTOGRAMS CALL HISPRP GOTO 4 ENDIF ELSE C STACK IS EMPTY, AS IRET1 IS 1 C LORENTZ TRANSFORM QUANTITIES INTO THE DESIRED CM SYSTEM CALL HISTRA( FLAG ) IF ( FLAG ) THEN C ... AND FILL HISTORGRAMS CALL HISFIL ELSE C ... OR REPEAT COLLISION GOTO 2222 ENDIF ENDIF #endif C----------------------------------------------------------------------- C FINISH SHOWER AND PRINT INFORMATION CALL OUTEND #if __PLOTSH__ || __PLOTSH2__ IF ( PLOTSH ) THEN #if __PLOTSH__ WRITE(MONIOU,3881) NPLEM,NPLMU,NPLHAD 3881 FORMAT(' PARTICLES STORED FOR PLOT OF 1. SHOWER:',/, * ' ',I10,' ELECTRONS AND GAMMAS',/, * ' ',I10,' MUONS',/, * ' ',I10,' HADRONS') CLOSE(55) CLOSE(56) CLOSE(57) #endif #if __PLOTSH2__ CALL PLWRITE #endif PLOTSH = .FALSE. ENDIF #endif * IF ( DEBUG ) WRITE(MDEBUG,442) NPARTO *442 FORMAT(' AAMAIN: NPARTO=',/,(' ',10F10.0)) IF ( FPRINT .OR. DEBUG ) THEN #if __ANAHIST__ || __AUGERHIST__ IFI = NOBSLV IOBSLV = NOBSLV WRITE(MONIOU,54) (K,K=IFI,IOBSLV) 54 FORMAT(/,' PARTICLES AT DETECTOR LEVEL:',/, * ' FOR LEVEL ', 5I13) WRITE(MONIOU,55) (OBSLEV(K),K=IFI,IOBSLV) 55 FORMAT( ' HEIGHT IN CM ',1P, 5E13.3,/) WRITE(MONIOU,555) (THCKOB(K),K=IFI,IOBSLV) 555 FORMAT( ' HEIGHT IN G/CM**2 ',1P, 5E13.3,/) IFI = 1 IOBSLV = 1 #else IFI = 1 IOBSLV = MIN( 5, NOBSLV ) WRITE(MONIOU,54) (K,K=IFI,IOBSLV) 54 FORMAT(/,' PARTICLES AT DETECTOR LEVEL:',/ * ,' FOR LEVEL ', 5I13) WRITE(MONIOU,55) (OBSLEV(K),K=IFI,IOBSLV) 55 FORMAT( ' HEIGHT IN CM ',1P, 5E13.3,/) WRITE(MONIOU,555) (THCKOB(K),K=IFI,IOBSLV) 555 FORMAT( ' HEIGHT IN G/CM**2 ',1P, 5E13.3,/) #endif WRITE(MONIOU,776) 'PROTONS ',(NPROTO(K),K=IFI,IOBSLV) WRITE(MONIOU,776) 'ANTIPROTONS ',(NPROTB(K),K=IFI,IOBSLV) WRITE(MONIOU,776) 'NEUTRONS ',(NNEUTR(K),K=IFI,IOBSLV) WRITE(MONIOU,776) 'ANTINEUTRONS ',(NNEUTB(K),K=IFI,IOBSLV) WRITE(MONIOU,775) 'GAMMAS ',(NPHOTO(K),K=IFI,IOBSLV) WRITE(MONIOU,775) 'POSITRONS ',(NPOSIT(K),K=IFI,IOBSLV) WRITE(MONIOU,775) 'ELECTRONS ',(NELECT(K),K=IFI,IOBSLV) #if __NEUTRINO__ WRITE(MONIOU,776) 'NEUTRINOS ',(NNU (K),K=IFI,IOBSLV) #endif WRITE(MONIOU,776) 'MU + ',(NMUP (K),K=IFI,IOBSLV) WRITE(MONIOU,776) 'MU - ',(NMUM (K),K=IFI,IOBSLV) WRITE(MONIOU,776) 'PI 0 ',(NPI0 (K),K=IFI,IOBSLV) WRITE(MONIOU,776) 'PI + ',(NPIP (K),K=IFI,IOBSLV) WRITE(MONIOU,776) 'PI - ',(NPIM (K),K=IFI,IOBSLV) WRITE(MONIOU,776) 'K0L ',(NK0L (K),K=IFI,IOBSLV) WRITE(MONIOU,776) 'K0S ',(NK0S (K),K=IFI,IOBSLV) WRITE(MONIOU,776) 'K + ',(NKPL (K),K=IFI,IOBSLV) WRITE(MONIOU,776) 'K - ',(NKMI (K),K=IFI,IOBSLV) WRITE(MONIOU,776) 'STR. BARYONS ',(NHYP (K),K=IFI,IOBSLV) WRITE(MONIOU,776) 'DEUTERONS ',(NDEUT (K),K=IFI,IOBSLV) WRITE(MONIOU,776) 'TRITONS ',(NTRIT (K),K=IFI,IOBSLV) WRITE(MONIOU,776) '3HELIUM ',(NHELI3(K),K=IFI,IOBSLV) WRITE(MONIOU,776) 'ALPHAS ',(NALPHA(K),K=IFI,IOBSLV) #if __CHARM__ WRITE(MONIOU,776) 'CHRM. MESONS ',(NCHRMM(K),K=IFI,IOBSLV) WRITE(MONIOU,776) 'CHRM. BARYONS',(NCHRMB(K),K=IFI,IOBSLV) #endif WRITE(MONIOU,776) 'OTHER PARTIC.',(NOTHER(K),K=IFI,IOBSLV) WRITE(MONIOU,*) WRITE(MONIOU,776) 'DECAYED MUONS',NMUOND WRITE(MONIOU,776) 'ELIMIN. MUONS',NMUONE 775 FORMAT(' NO OF ',A13, '= ',1P,5E13.6,0P) 776 FORMAT(' NO OF ',A13, '= ',5F13.0) #if !__AUGERHIST__ IF ( NOBSLV .GT. 5 ) THEN IOBSLV = NOBSLV WRITE(MONIOU,54) (K,K=6,IOBSLV) WRITE(MONIOU,55) (OBSLEV(K),K=6,IOBSLV) WRITE(MONIOU,555) (THCKOB(K),K=6,IOBSLV) WRITE(MONIOU,776) 'PROTONS ',(NPROTO(K),K=6,IOBSLV) WRITE(MONIOU,776) 'ANTIPROTONS ',(NPROTB(K),K=6,IOBSLV) WRITE(MONIOU,776) 'NEUTRONS ',(NNEUTR(K),K=6,IOBSLV) WRITE(MONIOU,776) 'ANTINEUTRONS ',(NNEUTB(K),K=6,IOBSLV) WRITE(MONIOU,775) 'GAMMAS ',(NPHOTO(K),K=6,IOBSLV) WRITE(MONIOU,775) 'POSITRONS ',(NPOSIT(K),K=6,IOBSLV) WRITE(MONIOU,775) 'ELECTRONS ',(NELECT(K),K=6,IOBSLV) #if __NEUTRINO__ WRITE(MONIOU,776) 'NEUTRINOS ',(NNU (K),K=6,IOBSLV) #endif WRITE(MONIOU,776) 'MU + ',(NMUP (K),K=6,IOBSLV) WRITE(MONIOU,776) 'MU - ',(NMUM (K),K=6,IOBSLV) WRITE(MONIOU,776) 'PI 0 ',(NPI0 (K),K=6,IOBSLV) WRITE(MONIOU,776) 'PI + ',(NPIP (K),K=6,IOBSLV) WRITE(MONIOU,776) 'PI - ',(NPIM (K),K=6,IOBSLV) WRITE(MONIOU,776) 'K0L ',(NK0L (K),K=6,IOBSLV) WRITE(MONIOU,776) 'K0S ',(NK0S (K),K=6,IOBSLV) WRITE(MONIOU,776) 'K + ',(NKPL (K),K=6,IOBSLV) WRITE(MONIOU,776) 'K - ',(NKMI (K),K=6,IOBSLV) WRITE(MONIOU,776) 'STR. BARYONS ',(NHYP (K),K=6,IOBSLV) WRITE(MONIOU,776) 'DEUTERONS ',(NDEUT (K),K=6,IOBSLV) WRITE(MONIOU,776) 'TRITONS ',(NTRIT (K),K=6,IOBSLV) WRITE(MONIOU,776) '3HELIUM ',(NHELI3(K),K=6,IOBSLV) WRITE(MONIOU,776) 'ALPHAS ',(NALPHA(K),K=6,IOBSLV) #if __CHARM__ WRITE(MONIOU,776) 'CHRM. MESONS ',(NCHRMM(K),K=6,IOBSLV) WRITE(MONIOU,776) 'CHRM. BARYONS',(NCHRMB(K),K=6,IOBSLV) #endif WRITE(MONIOU,776) 'OTHER PARTIC.',(NOTHER(K),K=6,IOBSLV) WRITE(MONIOU,*) ENDIF #endif ENDIF C ADD UP FOR MEAN VALUES DO K = 1, 28 DO J = 1, 20 MPARTO(J,K) = MPARTO(J,K) + NPARTO(J,K) MPART2(J,K) = MPART2(J,K) + NPARTO(J,K)**2 ENDDO ENDDO #if __ANAHIST__ || __AUGERHIST__ IOBSLV = 1 #else IOBSLV = NOBSLV #endif DO K = 1, IOBSLV EVTE(3) = EVTE(3) + NPHOTO(K) EVTE(263) = EVTE(263) + NPART2(K,1) EVTE(4) = EVTE(4) + NELECT(K) + NPOSIT(K) EVTE(264) = EVTE(264) + NPART2(K,2) + NPART2(K,3) DO J = 7,23 EVTE(5) = EVTE(5) + NPARTO(K,J) EVTE(265) = EVTE(265) + NPART2(K,J) ENDDO EVTE(5) = EVTE(5) + NNEUTB(K) EVTE(265) = EVTE(265) + NPART2(K,25) EVTE(6) = EVTE(6) + NMUP(K) + NMUM(K) EVTE(266) = EVTE(266) + NPART2(K,5) + NPART2(K,6) ENDDO EVTE(7) = NOPART #if __NUPRIM__ IF ( ( PRMPAR(0) .GE. 66 .AND. PRMPAR(0) .LE. 69 ) #if __CHARM__ || __TAULEP__ * .OR. PRMPAR(0) .EQ. 133 .OR. PRMPAR(0) .EQ. 134 #endif * ) THEN C LOOK FOR TYPE OF FIRST INTERACTION IF ( JPROC .EQ. 9010 ) THEN PROCTYPE = 'CC' ELSEIF ( JPROC .EQ. 9000 ) THEN PROCTYPE = 'NC' ELSE #if __PARALLEL__ C SLAVE PROCESS DOES NOT KNOW TYPE JPROC OF FIRST INTERACTION PROCTYPE = '00' #else WRITE(MONIOU,*) 'AAMAIN: JPROC = ',JPROC WRITE(MONIOU,*) 'ERROR IN TYPE OF NEUTRINO INTERACTION' STOP #endif ENDIF IF ( FPRINT .OR. DEBUG ) WRITE(MONIOU,109) * IFINNU,IFINPI,IFINET,IFINKA,IFINHY,IFINRHO, #if __CHARM__ * IFINCM, #endif * IFINOT, * IFINNU+IFINPI+IFINET+IFINKA+IFINHY+IFINRHO+IFINCM+ * IFINOT, * ELAST,THICK1,HEIGH(THICK1),PROCTYPE,SIG1I,TARG1I 109 FORMAT(/, * ' NO OF NUCLEONS PRODUCED IN FIRST NEUT. INTERACTION =',I10,/, * ' NO OF PIONS PRODUCED IN FIRST NEUT. INTERACTION =',I10,/, * ' NO OF ETAS PRODUCED IN FIRST NEUT. INTERACTION =',I10,/, * ' NO OF KAONS PRODUCED IN FIRST NEUT. INTERACTION =',I10,/, * ' NO OF S.BARYONS PRODUCED IN FIRST NEUT. INTERACTION =',I10,/, * ' NO OF RHO MESNS PRODUCED IN FIRST NEUT. INTERACTION =',I10,/, #if __CHARM__ * ' NO OF CHRM.PART.PRODUCED IN FIRST NEUT. INTERACTION =',I10,/, #endif * ' NO OF OTH. HADR.PRODUCED IN FIRST NEUT. INTERACTION =',I10,/, * ' TOTAL MULTIPLICITY OF FIRST NEUT. INTERACTION =',I10,/, * ' FRACTION OF NEUTRINO ENERGY TO OUTGOING LEPTON =',F10.4,/, * ' VERTICAL DEPTH (G/CM**2) OF FIRST NEUT. INTERACTION =',F10.4,/, * ' VERTICAL ALTITUDE (CM) OF FIRST NEUT. INTERACTION =',F10.1,/, * ' CROSS-SECTION (PICOB) OF FIRST NEUT. ',A2,' INTERACTION =', * 1P,E10.3,0P,/, * ' TARGET MASS NUMBER OF FIRST NEUT. INTERACTION =',F10.4,/) ELSE #endif IF ( FPRINT .OR. DEBUG ) WRITE(MONIOU,110) * IFINNU,IFINPI,IFINET,IFINKA,IFINHY,IFINRHO, #if __CHARM__ * IFINCM, #endif * IFINOT, * IFINNU+IFINPI+IFINET+IFINKA+IFINHY+IFINRHO+ * IFINCM+IFINOT, * ELAST,THICK1,HEIGH(THICK1),SIG1I,TARG1I 110 FORMAT(/, * ' NO OF NUCLEONS PRODUCED IN FIRST HADR. INTERACTION =',I10,/, * ' NO OF PIONS PRODUCED IN FIRST HADR. INTERACTION =',I10,/, * ' NO OF ETAS PRODUCED IN FIRST HADR. INTERACTION =',I10,/, * ' NO OF KAONS PRODUCED IN FIRST HADR. INTERACTION =',I10,/, * ' NO OF S.BARYONS PRODUCED IN FIRST HADR. INTERACTION =',I10,/, * ' NO OF RHO MESNS PRODUCED IN FIRST HADR. INTERACTION =',I10,/, #if __CHARM__ * ' NO OF CHRM.PART.PRODUCED IN FIRST HADR. INTERACTION =',I10,/, #endif * ' NO OF OTH. HADR.PRODUCED IN FIRST HADR. INTERACTION =',I10,/, * ' TOTAL MULTIPLICITY OF FIRST HADR. INTERACTION =',I10,/, * ' ELASTICITY OF FIRST HADR. INTERACTION =',F10.4,/, * ' VERTICAL DEPTH (G/CM**2) OF FIRST HADR. INTERACTION =',F10.4,/, * ' VERTICAL ALTITUDE (CM) OF FIRST HADR. INTERACTION =',F10.1,/, * ' CROSS-SECTION MILLIBARN OF FIRST HADR. INTERACTION =',F10.4,/, * ' TARGET MASS NUMBER OF FIRST HADR. INTERACTION =',F10.4,/) #if __NUPRIM__ ENDIF #endif #if __INTTEST__ C FORGET THE EVENT END OUTPUT AND CONTINUE IN THE EVENTLOOP C DUMMY IF IF ( ITTAR .NE. 0 ) GOTO 2 #endif C PRINT OUT NKG RESULT FOR ONE SHOWER IF SELECTED IF ( FNKG ) CALL AVAGE IF ( LLONGI ) THEN C TREAT LONGITUDINAL DISTRIBUTIONS #if __INTCLONG__ PINTEG9 = 0.D0 #endif DO J = 0, NSTEP1 C ADD UP ENERGY DEPOSIT AND IONIZATION FOR SUM C FOR ENERGY CUT AS WELL AS FOR ANGLE CUT DLONG(J,9) = DLONG(J,1)+DLONG(J,2)+DLONG(J,3)+DLONG(J,4) * +DLONG(J,5)+DLONG(J,6)+DLONG(J,7)+DLONG(J,8) * +DLONG(J,11)+DLONG(J,13)+DLONG(J,15) * +DLONG(J,17)+DLONG(J,18) C ADD ELECTRONS, POSITRONS, MUONS AND NUCLEI TO THE CHARGED PARTICLES ELONG(J,7) = ELONG(J,7) + ELONG(J,2) + ELONG(J,3) * + ELONG(J,4) + ELONG(J,5) + ELONG(J,8) C ADD UP ALL ENERGIES FOR SUM ELONG(J,9) = ELONG(J,1) + ELONG(J,2) + ELONG(J,3) * + ELONG(J,4) + ELONG(J,5) + ELONG(J,6) + ELONG(J,8) C ADD ALL CHARGED PARTICLES TO CHARGED SUM PLONG(J,7) = PLONG(J,7) + PLONG(J,2) + PLONG(J,3) * + PLONG(J,4) + PLONG(J,5) + PLONG(J,8) #if __INTCLONG__ C INTEGRATE THE LONGITUDINAL CHERENKOV DISTRIBUTION PINTEG9 = PINTEG9 + PLONG(J,9) PLONG(J,9) = PINTEG9 #endif C ADD UP FOR MEAN VALUES OF LONGITUDINAL DISTRIBUTION DO K = 1, 10 AELONG(J,K) = AELONG(J,K) + ELONG(J,K) SELONG(J,K) = SELONG(J,K) + ELONG(J,K)**2 APLONG(J,K) = APLONG(J,K) + PLONG(J,K) SPLONG(J,K) = SPLONG(J,K) + PLONG(J,K)**2 #if __ANAHIST__ APLONG(J,K+10) = APLONG(J,K+10) + PLONG(J,K+10) SPLONG(J,K+10) = SPLONG(J,K+10) + PLONG(J,K+10)**2 #endif ENDDO DO K = 1, 19 ADLONG(J,K) = ADLONG(J,K) + DLONG(J,K) SDLONG(J,K) = SDLONG(J,K) + DLONG(J,K)**2 ENDDO ENDDO C PRINT LONGITUDINAL DISTRIBUTIONS PER SHOWER IF ( FPRINT .OR. DEBUG ) THEN #if __NEUTRINO__ || __NUPRIM__ C PARTICLE DISTRIBUTION WRITE(MONIOU,910) THSTEP, * 'GAMMAS','POSITRONS','ELECTRONS','MU+','MU-','HADRONS', * 'CHARGED','NUCLEI','NEUTRINOS','CHERENKOV', #if __SLANT__ * ( THCKRL(J),(PLONG(J,K),K=1,8),PLONG(J,10),PLONG(J,9), * J=LPCT1,NSTEP1 ) 910 FORMAT(/,' ---------- LONGITUDINAL PARTICLE DISTRIBUTION IN' * ,' SLANT STEPS OF ',F5.0,' G/CM**2 ',55(1H-),/, #else * ( J*THSTEP,(PLONG(J,K),K=1,8),PLONG(J,10),PLONG(J,9), * J=LPCT1,NSTEP1 ) 910 FORMAT(/,' ---------- LONGITUDINAL PARTICLE DISTRIBUTION IN' * ,' VERT. STEPS OF ',F5.0,' G/CM**2 ',55(1H-),/, #endif * ' DEPTH ',3A14,3A12,A12,2A11,A12,/, * (F7.1,F15.0,2F14.0,3F12.0,F14.0,2F11.0,1P,E12.5,0P) ) C ENERGY DISTRIBUTION WRITE(MONIOU,908) THSTEP, * 'GAMMAS','POSITRONS','ELECTRONS','MU+','MU-','HADRONS', * 'CHARGED','NUCLEI','NEUTRINO','SUM', #if __SLANT__ * ( THCKRL(J),(ELONG(J,K),K=1,8),ELONG(J,10),ELONG(J,9), * J=LPCT1,NSTEP1 ) 908 FORMAT(/,' ---------- LONGITUDINAL ENERGY DISTRIBUTION ', * '[GEV] IN SLANT STEPS OF ',F5.0,' G/CM**2 ',54(1H-),/, #else * ( J*THSTEP,(ELONG(J,K),K=1,8),ELONG(J,10),ELONG(J,9), * J=LPCT1,NSTEP1 ) 908 FORMAT(/,' ---------- LONGITUDINAL ENERGY DISTRIBUTION ', * '[GEV] IN VERT. STEPS OF ',F5.0,' G/CM**2 ',54(1H-),/, #endif * ' DEPTH',10(A12,1X),/,(F7.1,1P,10E13.5,0P) ) #else C PARTICLE DISTRIBUTION WRITE(MONIOU,910) THSTEP, * 'GAMMAS','POSITRONS','ELECTRONS','MU+','MU-','HADRONS', * 'CHARGED','NUCLEI','CHERENKOV', #if __SLANT__ * ( THCKRL(J),(PLONG(J,K),K=1,9),J=LPCT1,NSTEP1 ) 910 FORMAT(/,' ---------- LONGITUDINAL PARTICLE DISTRIBUTION IN' * ,' SLANT STEPS OF ',F5.0,' G/CM**2 ',44(1H-),/, #else * ( J*THSTEP,(PLONG(J,K),K=1,9),J=LPCT1,NSTEP1 ) 910 FORMAT(/,' ---------- LONGITUDINAL PARTICLE DISTRIBUTION IN' * ,' VERT. STEPS OF ',F5.0,' G/CM**2 ',44(1H-),/, #endif * ' DEPTH ',3A14,3A12,A12,A11,A12,/, * (F7.1,F15.0,2F14.0,3F12.0,F14.0,F11.0,1P,E12.5,0P) ) C ENERGY DISTRIBUTION WRITE(MONIOU,908) THSTEP, * 'GAMMAS','POSITRONS','ELECTRONS','MU+','MU-','HADRONS', * 'CHARGED','NUCLEI','SUM', #if __SLANT__ * ( THCKRL(J),(ELONG(J,K),K=1,9),J=LPCT1,NSTEP1 ) 908 FORMAT(/,' ---------- LONGITUDINAL ENERGY DISTRIBUTION ', * '[GEV] IN SLANT STEPS OF ',F5.0,' G/CM**2 ',40(1H-),/, #else * ( J*THSTEP,(ELONG(J,K),K=1,9),J=LPCT1,NSTEP1 ) 908 FORMAT(/,' ---------- LONGITUDINAL ENERGY DISTRIBUTION ', * '[GEV] IN VERT. STEPS OF ',F5.0,' G/CM**2 ',40(1H-),/, #endif * ' DEPTH',9(A12,1X),/,(F7.1,1P,9E13.5,0P) ) #endif C ENERGY DEPOSIT #if __AUGERHIST__ WRITE(MONIOU,909) THSTEP, * ' GAMMA E-CUT','EM IONIZ','EM E-CUT','MU IONIZ','MU E-CUT', * 'HADR IONIZ','HADR E-CUT',' NTRINO E-CU','T SUM', #if __SLANT__ * ( 0.5*(THCKRL(J-1)+THCKRL(J)),(DLONG(J,K),K=1,9), * J=MAX(1,LPCT1),NSTEP1-1 ) 909 FORMAT(/,' ---------- LONGITUDINAL ENERGY DEPOSIT [GEV] IN', * ' SLANT STEPS OF ',F5.0,' G/CM**2 ',45(1H-),/, * ' DEPTH ',3A14,6A12,/,(F7.1,1X,3F14.1,5F12.1,F13.1)) WRITE(MONIOU,9091) 0.5*(THCKRL(J-1)+THCKRL(J)), * (DLONG(NSTEP1,K),K=1,9) #else * ( (2*J-1)*.5*THSTEP,(DLONG(J,K),K=1,9), * J=MAX(1,LPCT1),NSTEP1-1 ) 909 FORMAT(/,' ---------- LONGITUDINAL ENERGY DEPOSIT [GEV] IN', * ' VERT. STEPS OF ',F5.0,' G/CM**2 ',45(1H-),/, * ' DEPTH ',3A14,6A12,/,(F7.1,1X,3F14.1,5F12.1,F13.1)) WRITE(MONIOU,9091) (2*NSTEP-1)*.5*THSTEP, * (DLONG(NSTEP1,K),K=1,9) #endif 9091 FORMAT(F7.1,1X,3E14.7,5F12.1,F13.1) WRITE(MONIOU,909) THSTEP, * ' GAMMA A-CUT','(DUMMY)',' EM A-CUT','(DUMMY)', * 'MU A-CUT', '(DUMMY)','HADR A-CUT',' NTRNO A-CUT', * ' ', #if __SLANT__ * (0.5*(THCKRL(J-1)+THCKRL(J)),(DLONG(J,K),K=11,19), * J=MAX(1,LPCT1),NSTEP1-1 ) WRITE(MONIOU,9091) 0.5*(THCKRL(J-1)+THCKRL(J)), * (DLONG(NSTEP1,K),K=11,19) #else * ((2*J-1)*.5*THSTEP,(DLONG(J,K),K=11,19), * J=MAX(1,LPCT1),NSTEP1-1) WRITE(MONIOU,9091) (2*NSTEP-1)*.5*THSTEP, * (DLONG(NSTEP1,K),K=11,19) #endif #else WRITE(MONIOU,909) THSTEP, * ' GAMMA ','EM IONIZ','EM CUT','MU IONIZ','MU CUT', * 'HADR IONIZ','HADR CUT','NEUTRINO ',' SUM', #if __SLANT__ * ( 0.5*(THCKRL(J-1)+THCKRL(J)),DLONG(J,1)+DLONG(J,11), * DLONG(J,2),DLONG(J,3)+DLONG(J,13), * DLONG(J,4),DLONG(J,5)+DLONG(J,15), * DLONG(J,6),DLONG(J,7)+DLONG(J,17), * DLONG(J,8)+DLONG(J,18),DLONG(J,9), * J=MAX(1,LPCT1),NSTEP1-1 ) 909 FORMAT(/,' ---------- LONGITUDINAL ENERGY DEPOSIT [GEV] IN', * ' SLANT STEPS OF ',F5.0,' G/CM**2 ',45(1H-),/, * ' DEPTH ',3A14,6A12,/,(F8.1,1X,3F14.1,5F12.1,F13.1)) WRITE(MONIOU,9091) 0.5*(THCKRL(J-1)+THCKRL(J)), * DLONG(NSTEP1,1)+DLONG(NSTEP1,11),DLONG(NSTEP1,2), * DLONG(NSTEP1,3)+DLONG(NSTEP1,13),DLONG(NSTEP1,4), * DLONG(NSTEP1,5)+DLONG(NSTEP1,15),DLONG(NSTEP1,6), * DLONG(NSTEP1,7)+DLONG(NSTEP1,17), * DLONG(NSTEP1,8)+DLONG(NSTEP1,18),DLONG(NSTEP1,9) #else * ( (2*J-1)*.5*THSTEP,DLONG(J,1)+DLONG(J,11),DLONG(J,2), * DLONG(J,3)+DLONG(J,13),DLONG(J,4), * DLONG(J,5)+DLONG(J,15),DLONG(J,6), * DLONG(J,7)+DLONG(J,17), * DLONG(J,8)+DLONG(J,18),DLONG(J,9), * J=MAX(1,LPCT1),NSTEP1-1 ) 909 FORMAT(/,' ---------- LONGITUDINAL ENERGY DEPOSIT [GEV] IN', * ' VERT. STEPS OF ',F5.0,' G/CM**2 ',46(1H-),/, * ' DEPTH ',3A14,6A12,/,(F8.1,1X,3F14.1,5F12.1,F13.1)) WRITE(MONIOU,9091) (2*NSTEP-1)*.5*THSTEP, * DLONG(NSTEP1,1)+DLONG(NSTEP1,11),DLONG(NSTEP1,2), * DLONG(NSTEP1,3)+DLONG(NSTEP1,13),DLONG(NSTEP1,4), * DLONG(NSTEP1,5)+DLONG(NSTEP1,15),DLONG(NSTEP1,6), * DLONG(NSTEP1,7)+DLONG(NSTEP1,17), * DLONG(NSTEP1,8)+DLONG(NSTEP1,18),DLONG(NSTEP1,9) #endif 9091 FORMAT(F8.1,1X,1P,3E14.7,5E12.5,E13.6) #endif DLONGSUM = 0.D0 DO K = 1, 19 DLONG(LNGMAX,K) = 0.D0 DO J = 0, NSTEP1 DLONG(LNGMAX,K) = DLONG(LNGMAX,K) + DLONG(J,K) ENDDO IF ( K .NE. 9 ) DLONGSUM = DLONGSUM + DLONG(LNGMAX,K) ENDDO WRITE(MONIOU,907) (DLONG(LNGMAX,K),K=1,8) 907 FORMAT(' ',20X,' LONGITUDINAL ENERGY SUM [GEV] ',/ * ,' ',8X,3E14.7,5E12.5) WRITE(MONIOU,9071) (DLONG(LNGMAX,K),K=11,18) 9071 FORMAT(' ',8X,3F14.1,5F12.1) WRITE(MONIOU,919) DLONGSUM DO K = 1, 19 DLONG(LNGMAX,K) = 0.D0 ENDDO ENDIF C WRITE OUT LONGITUDINAL DISTRIBUTION IF ( FLONGOUT ) THEN #if __PARALLELIB__ #if __SLANT__ CALL STORETEXT(TYPE2,NSTEP1,THSTEP,ISHOWNO) #else CALL STORETEXT(TYPE1,NSTEP1,THSTEP,ISHOWNO) #endif DO 222 J=1,NSTEP1 LONGMATRIX((J-1)*10)=J*THSTEP DO 223 K=1,9 LONGMATRIX((J-1)*10+K)=PLONG(J,K) 223 ENDDO 222 ENDDO CALL JOINMATRIX(LONGMATRIX,TYPE2) C DO J = 1,NSTEP1 C WRITE(MLONGOUT,212) LONGMATRIX(J-1,0),(LONGMATRIX(J-1,K),K=1,9) C#if __SLANT__ C212 FORMAT(' ',F7.1,1P,9(E12.5),0P) C#else C DO NOT CHANGE THIS FORMAT, AS THE CorsToRoot PROGRAM DEPENDS ON IT C C 212 FORMAT(' ',F5.0,1P,9(E12.5),0P) C#endif C ENDDO #if __SLANT__ CALL STORETEXT(TYPE4,NSTEP1,THSTEP,ISHOWNO) #else CALL STORETEXT(TYPE3,NSTEP1,THSTEP,ISHOWNO) #endif DO J = 1,NSTEP1 DEPSTEP = (2*J-1)*.5*THSTEP LONGMATRIX((J-1)*10+0)= DEPSTEP LONGMATRIX((J-1)*10+1)= DLONG(J,1)+DLONG(J,11) LONGMATRIX((J-1)*10+2)= DLONG(J,2) LONGMATRIX((J-1)*10+3)= DLONG(J,3)+DLONG(J,13) LONGMATRIX((J-1)*10+4)= DLONG(J,4) LONGMATRIX((J-1)*10+5)= DLONG(J,5)+DLONG(J,15) LONGMATRIX((J-1)*10+6)= DLONG(J,6) LONGMATRIX((J-1)*10+7)= DLONG(J,7)+DLONG(J,17) LONGMATRIX((J-1)*10+8)= DLONG(J,8)+DLONG(J,18) LONGMATRIX((J-1)*10+9)= DLONG(J,9) ENDDO CALL JOINMATRIX(LONGMATRIX,TYPE1) C DO J = 1,NSTEP1 C WRITE(MLONGOUT,242) LONGMATRIX(J-1,0),(LONGMATRIX(J-1,K),K=1,9) C#if __SLANT__ C 242 FORMAT(' ',F7.1,1P,9(E12.5),0P) C#else C C DO NOT CHANGE THIS FORMAT, AS THE CorsToRoot PROGRAM DEPENDS ON IT C C 242 FORMAT(' ',F5.0,1P,9(E12.5),0P) C C#endif C ENDDO #else WRITE(MLONGOUT,211) NSTEP1,THSTEP,ISHOWNO, * 'GAMMAS','POSITRONS','ELECTRONS','MU+','MU-','HADRONS', #if __NEUTRINO__ || __NUPRIM__ * 'CHARGED','NUCLEI','NEUTRINOS' #else * 'CHARGED','NUCLEI','CHERENKOV' #endif #if __SLANT__ 211 FORMAT(' LONGITUDINAL DISTRIBUTION IN ',I5, * ' SLANT STEPS OF ',F5.0,' G/CM**2 FOR SHOWER ', * I7,/,' DEPTH ',9(A11,1X) ) #else C C DO NOT CHANGE THIS FORMAT, AS THE CorsToRoot PROGRAM DEPENDS ON IT C 211 FORMAT(' LONGITUDINAL DISTRIBUTION IN ',I5, * ' VERTICAL STEPS OF ',F5.0,' G/CM**2 FOR SHOWER ', * I7,/,' DEPTH',9(A11,1X) ) #endif C DO J = 1, NSTEP1 #if __NEUTRINO__ || __NUPRIM__ WRITE(MLONGOUT,212)J*THSTEP,(PLONG(J,K),K=1,8),PLONG(J,10) #else WRITE(MLONGOUT,212) J*THSTEP,(PLONG(J,K),K=1,9) #endif #if __SLANT__ 212 FORMAT(' ',F7.1,1P,9(E12.5),0P) #else C C DO NOT CHANGE THIS FORMAT, AS THE CorsToRoot PROGRAM DEPENDS ON IT C 212 FORMAT(' ',F5.0,1P,9(E12.5),0P) C #endif ENDDO WRITE(MLONGOUT,213) NSTEP1,THSTEP,ISHOWNO, * 'GAMMA ','EM IONIZ','EM CUT','MU IONIZ','MU CUT', * 'HADR IONIZ','HADR CUT','NEUTRINO ',' SUM ' #if __SLANT__ 213 FORMAT(' LONGITUDINAL ENERGY DEPOSIT IN ',I5, * ' SLANT STEPS OF ',F5.0,' G/CM**2 FOR SHOWER ', * I7,/,' DEPTH ',3A11,6A12) #else C C DO NOT CHANGE THIS FORMAT, AS THE CorsToRoot PROGRAM DEPENDS ON IT C 213 FORMAT(' LONGITUDINAL ENERGY DEPOSIT IN ',I5, * ' VERTICAL STEPS OF ',F5.0,' G/CM**2 FOR SHOWER ', * I7,/,' DEPTH ',3A11,6A12) #endif C C CHECK LAST LONGITUDINAL DEPOSIT BIN TO CONTAIN NON-NEGATIVE CONTENT DLONG(NSTEP1,2) = MAX( 0.D0, DLONG(NSTEP1,2) ) DLONG(NSTEP1,4) = MAX( 0.D0, DLONG(NSTEP1,4) ) DLONG(NSTEP1,9) = MAX( 0.D0, DLONG(NSTEP1,9) ) DO J = 1, NSTEP1 DEPSTEP = (2*J-1)*.5*THSTEP DLONG(J,6) = MAX( 0.D0, DLONG(J,6) ) WRITE(MLONGOUT,214) DEPSTEP, * DLONG(J,1)+DLONG(J,11),DLONG(J,2),DLONG(J,3)+DLONG(J,13), * DLONG(J,4),DLONG(J,5)+DLONG(J,15),DLONG(J,6), * DLONG(J,7)+DLONG(J,17),DLONG(J,8)+DLONG(J,18),DLONG(J,9) #if __SLANT__ 214 FORMAT(' ',F7.1,1P,9(E12.5),0P) #else C C DO NOT CHANGE THIS FORMAT, AS THE CorsToRoot PROGRAM DEPENDS ON IT C 214 FORMAT(' ',F5.0,1P,9(E12.5),0P) C #endif ENDDO #endif ELSE C FILL THE PERMANENT VALUES OF LONGITUDINAL FIELDS: ARRAYLONG(2) = EVTH(2) !SHOWER NUMBER ARRAYLONG(3) = EVTH(3) !PRIMARY PARTICLE ARRAYLONG(4) = EVTH(4) !PRIMARY ENERGY #if __PRESHOWER__ ARRAYLONG(7) = 0.D0 !THICKNS FIRST INTERACT #else ARRAYLONG(7) = THICK( ABS( DBLE(EVTH(7)) ) ) * !THICKNS FIRST INTERACT #endif ARRAYLONG(8) = EVTH(11) !ZENITH ANGLE ARRAYLONG(9) = EVTH(12) !AZIMUTH ANGLE ARRAYLONG(10) = EVTH(61) !ENERGY CUT HADRONS ARRAYLONG(11) = EVTH(62) !ENERGY CUT MUONS ARRAYLONG(12) = EVTH(63) !ENERGY CUT ELECTRONS ARRAYLONG(13) = EVTH(64) !ENERGY CUT GAMMAS C CALCULATE HOW MANY BLOCKS MUST BE WRITTEN JJEND = INT( (NSTEP1-1)/26 ) + 1 ARRAYLONG(5) = JJEND + 100*NSTEP1 !TOTAL # OF LONGI BLOCKS C ! & NUMBER OF STEPS C WRITE THE BLOCKS DO JJ = 1, JJEND C SET ACTUAL BLOCK NUMBER ARRAYLONG(6) = JJ !CURRENT NUMBER OF BLOCK C FILL THE BLOCK WITH ACTUAL VALUES DO J = 1, 26 JPLUS = 10*(J-1) JJJ = J + 26 * (JJ-1) IF ( JJJ .LE. NSTEP1 ) THEN C FILL IN THE THICKNESS VALUES ARRAYLONG(14+JPLUS) = JJJ * THSTEP DO K = 1, 9 C FILL IN THE PARTICLE NUMBERS ARRAYLONG(14+JPLUS+K) = PLONG(JJJ,K) ENDDO ELSE C FILL THE END OF LAST BLOCK WITH ZEROS DO K = 1, 10 ARRAYLONG(13+JPLUS+K) = 0. ENDDO ENDIF ENDDO C NOW WRITE OUT THE BLOCK CALL TOBUF( ARRAYLONG,0 ) * WRITE(MONIOU,3333)JJ,ARRAYLONG *3333 FORMAT( 1X,I5,3(1X,E10.5),/,(10(1X,E10.5)) ) ENDDO ENDIF IF ( FLGFIT ) THEN IF ( FPRINT .OR. DEBUG ) WRITE(MONIOU,*) ' ' C PERFORM FIT TO THE LONGITUDINAL DISTRIBUTION OF ALL CHARGED PARTICLES C IF EGS IS SELECTED THIS IS THE DISTRIBUTION WHICH IS TO BE TAKEN IF ( FEGS ) THEN DO J = 0, NSTEP-LPCT1 DEP(J+1) = (J+LPCT1)*THSTEP CHAPAR(J+1) = MAX( 0.D0, PLONG(J+LPCT1,7) ) ENDDO #if __CONEX__ C WITH CONEX, DO NOT USE THE LAST BIN WHICH MIGHT BE EMPTY IF ONLY CE ARE USED NSTP = NSTEP - LPCT1 #else NSTP = NSTEP + 1 - LPCT1 #endif IF ( FPRINT .OR. DEBUG ) * WRITE(MONIOU,8229) 'ALL CHARGED PARTICLES' 8229 FORMAT(' FIT OF THE HILLAS CURVE ', * ' N(T) = P1*((T-P2)/(P3-P2))**((P3-P2)/(P4+P5*T+P6*T**2))', * ' * EXP((P3-T)/(P4+P5*T+P6*T**2))',/, * ' TO LONGITUDINAL DISTRIBUTION OF ',A35) IF ( FLONGOUT ) * WRITE(MLONGOUT,8229) 'ALL CHARGED PARTICLES' C IF NKG IS SELECTED ONLY THE ELECTRON DISTRIBUTION IS AVAILABLE ELSEIF ( FNKG ) THEN DEP(1) = 0.D0 CHAPAR(1) = 0.D0 DO J = 1, IALT(1) DEP(J+1) = TLEV(J) CHAPAR(J+1) = MAX( 0.D0, SL(J) ) ENDDO NSTP = IALT(1) + 1 IF ( FPRINT .OR. DEBUG ) WRITE(MONIOU,8229)'NKG ELECTRONS' IF ( FLONGOUT ) WRITE(MLONGOUT,8229)'NKG ELECTRONS' C IF NONE IS SELECTED IT DOES NOT REALLY MAKE SENSE TO FIT C BUT LET''S TAKE THEN ALL CHARGED WHICH ARE MUONS AND HADRONS ELSE DO J = 0, NSTEP-LPCT1 DEP(J+1) = (J+LPCT1)*THSTEP CHAPAR(J+1) = MAX( 0.D0, PLONG(J+LPCT1,7) ) ENDDO #if __CONEX__ C WITH CONEX, DO NOT USE THE LAST BIN WHICH MIGHT BE EMPTY IF ONLY CE ARE USED NSTP = NSTEP - LPCT1 #else NSTP = NSTEP + 1 - LPCT1 #endif IF ( FPRINT .OR. DEBUG ) * WRITE(MONIOU,8229) 'MUONS AND CHARGED HADRONS' IF ( FLONGOUT ) * WRITE(MLONGOUT,8229) 'MUONS AND CHARGED HADRONS' ENDIF IF ( NSTP .GT. 6 ) THEN C THERE ARE MORE THAN 6 STEP VALUES, A FIT SHOULD BE POSSIBLE. C DO THE FIT: NPAR AND FPARAM GIVE THE NUMBER OF PARAMETERS USED C AND THE FINAL VALUES FOR THE PARAMETERS. CHISQ GIVES THE CHI**2/DOF C FOR THE FIT. C BUT FIRST WE MAKE A TEST WHETHER THE STATISTICS IN THE LONGITUD> C DISTRIBUTION IS GOOD ENOUGH, I.E. AT MINIMUM 6 CONSECUTIVE BINS C MUST BE NON-ZERO NSTART = 1 8232 CONTINUE DO J = NSTART, NSTP IF ( CHAPAR(J) .EQ. 0.D0 .AND. J .LT. NSTART+6 ) THEN NSTART = J + 1 GOTO 8232 ENDIF ENDDO IF ( NSTP - NSTART .LT. 6 ) THEN WRITE(MONIOU,*) 'NO LONGI. FIT POSSIBLE, NSTP =', * NSTP,', TOO FEW NONZERO BINS.' DO K = 1, 6 EVTE(255+K) = 0. ENDDO EVTE(262) = 0. GOTO 8234 ENDIF CALL LONGFT( FPARAM,CHI2 ) IF ( FPRINT .OR. DEBUG ) THEN IF ( FPARAM(1) .GT. 0.D0 ) THEN WRITE(MONIOU,8230) * FPARAM,CHI2,CHI2/SQRT(FPARAM(1))*100.D0 8230 FORMAT(' PARAMETERS = ',1P,6E12.4,/, * ' CHI**2/DOF = ',E11.4,/, * ' AV. DEVIATION IN % = ',E11.4,0P,/) ELSE WRITE(MONIOU,8231) FPARAM,CHI2 8231 FORMAT(' PARAMETERS = ',1P,6E12.4,/, * ' CHI**2/DOF = ',E11.4,0P,/,/) ENDIF ENDIF IF ( FLONGOUT ) THEN IF ( FPARAM(1) .GT. 0.D0 ) THEN WRITE(MLONGOUT,8230) FPARAM,CHI2, * CHI2/SQRT(FPARAM(1))*100.D0 ELSE WRITE(MLONGOUT,8231) FPARAM,CHI2 ENDIF ENDIF C STORE RESULT IN END EVENT BLOCK (IF NOT CRAZY) IF ( ABS( FPARAM(3) ) .LT. 1.D5 ) THEN DO K = 1, 6 EVTE(255+K) = FPARAM(K) ENDDO EVTE(262) = CHI2 ELSE WRITE(MONIOU,*) 'NO LONGI. FIT POSSIBLE, ', * ' FIT DOES NOT CONVERGE...' DO K = 1, 6 EVTE(255+K) = 0. ENDDO EVTE(262) = 0. ENDIF #if __AUGERHIST__ C FILL IN THE LONGITUDINAL ENERGY DEPOSIT AND MAKE A FIT WITH IT IF ( FEGS .AND. NSTP .GT. 8 ) THEN DO J = 2, NSTEP-LPCT1-1 DEP(J-1) = THSTEP * (2*J-1)*.5D0 C ADD UP: GAMMA ENERGY CUT; E+E- IONIZATON, E+E- ENERGY CUT; C MUON IONIZATION; MUON ENERGY CUT; HADRON IONIZATION; CHAPAR(J-1) = DLONG(J,1) + DLONG(J,2) + DLONG(J,3) * +DLONG(J,4) + DLONG(J,5) + DLONG(J,6) CHAPAR(J-1) = MAX( CHAPAR(J-1), 0.D0 ) ENDDO NSTP = NSTEP - LPCT1 - 2 IF ( FPRINT .OR. DEBUG ) * WRITE(MONIOU,8229) 'IONIZATION ENERGY DEPOSIT' CALL LONGFT( FPARAM,CHI2 ) IF ( FPRINT .OR. DEBUG ) THEN IF ( FPARAM(1) .GE. 0.D0 ) THEN WRITE(MONIOU,8230) * FPARAM,CHI2,CHI2/SQRT(FPARAM(1))*100.D0 ELSE WRITE(MONIOU,8231) FPARAM,CHI2 ENDIF ENDIF C WRITE OUT FIT TO .LONG FILE IF ( FLONGOUT ) THEN IF ( FPARAM(1) .GT. 0.D0 ) THEN WRITE(MLONGOUT,8230) * FPARAM,CHI2,CHI2/SQRT(FPARAM(1))*100.D0 ELSE WRITE(MLONGOUT,8231) FPARAM,CHI2 ENDIF ENDIF ENDIF #endif ELSE WRITE(MONIOU,*) 'NO LONGI. FIT POSSIBLE, ', * ' NSTP = ',NSTP,' TOO SMALL.' DO K = 1, 6 EVTE(255+K) = 0. ENDDO EVTE(262) = 0. ENDIF 8234 CONTINUE ENDIF #if __ANAHIST__ C FILL THE LONGITUDINAL HISTOGRAMS CALL LONGIHIST #endif ENDIF #if __PRESHOWER__ C JUMP HERE IF NO PRESHOWER OCCURED AND STOP WAS DEMANDED 2077 CONTINUE #endif EVTE(2) = REAL( ISHOWNO ) #if __REMOTECONTROL__ || __DYNSTACK__ CALL baack_modify_evte(EVTE, SIZEOF(EVTE) ) #endif C WRITE SHOWER END TO OUTPUT BUFFER #if __COMPACT__ IF ( .NOT. COMOUT ) CALL TOBUF( EVTE,0 ) #else #if __PARALLEL__ C WREVTE SIGNALS THAT EVTE HAS BEEN WRITTEN WREVTE = .TRUE. #endif #if __ICECUBE1__ && !__COASTUSERLIB__ CALL TOBUF( EVTE,1 ) #else CALL TOBUF( EVTE,0 ) #endif #endif #if __CERENKOV__ #if __IACT__ C PASS THE DIFFERENT LONGITUDINAL DISTRIBUTIONS TO IACT CODE CALL TELLNG( 1,PLONG,LNGMAX+1,9,NSTEP+1,THSTEP ) CALL TELLNG( 2,ELONG,LNGMAX+1,9,NSTEP+1,THSTEP ) CALL TELLNG( 3,DLONG,LNGMAX+1,9,NSTEP+1,THSTEP ) C PASS THE EVENT END BLOCK TO THE IACT CODE CALL TELEND( EVTE ) #endif IF ( MCERFI .NE. 0 ) THEN CALL OUTND2 DO J = 1, NCERBUF CALL TOBUFC( EVTE,0,J ) ENDDO ENDIF #endif #if __CERENKOV__ || __AUGCERLONG__ IF ( FPRINT .OR. DEBUG ) WRITE(MONIOU,208)CERELE,CERHAD 208 FORMAT(' CHERENKOV PH. FROM ELECTRONS = ',1P,E15.7, * ' CHERENKOV PH. FROM HADRONS = ',E15.7) CERELE = 0.D0 CERHAD = 0.D0 NRECER = 0 #endif C STORE TABLES IF ( FTABOUT ) THEN WRITE(MTABOUT) G_ARRAY,E_ARRAY,M_ARRAY C STORE LONG DISTRIBUTION OF CHARGED PARTICLES IF ( LLONGI ) THEN WRITE(MTABOUT) THSTEP,NSTEP,(PLONG(II,7),II=1,NSTEP) ENDIF ENDIF IF ( FPRINT .OR. DEBUG ) WRITE(MONIOU,210) ISHOWNO 210 FORMAT(/,' END OF SHOWER NO ',I10) #if __ICECUBE1__ C RESET INTERESTINGNESS FLAG still_interesting = .TRUE. #endif DO J = 1, 40 JNBIN(J) = JNBIN(J) + INBIN(J) JPBIN(J) = JPBIN(J) + IPBIN(J) JKBIN(J) = JKBIN(J) + IKBIN(J) JHBIN(J) = JHBIN(J) + IHBIN(J) ENDDO #if __INTTEST__ C ISHW ACTUAL NUMBER OF EVENTS C NSHOW DESIRED NUMBER OF EVENTS C NOINT NUMBER OF COLLISIONS WITHOUT INELASTIC EVENTS C NELAST NUMBER OF TRUE ELASTIC EVENTS C FINISH SHOWER LOOP IF NUMBER OF ELASTIC EVENTS DOMINATES THE C NUMBER OF EVENTS I = ISHW IF ( NELAST .GE. 5*NSHOW ) GOTO 992 #endif #if __CONEX__ RETURN C======================================================================= ENTRY FINISHRUN C----------------------------------------------------------------------- C C SUBPART OF AAMAIN AT THE END OF THE RUN (STATISTICS AND MEAN PLOTS) C THIS SUBROUTINE IS CALLED FROM CORSIKAMAIN VIA AN EXTERNAL NAME C C----------------------------------------------------------------------- #else 2 CONTINUE C END OF SHOWER LOOP #endif C----------------------------------------------------------------------- #if __INTTEST__ 992 CONTINUE #endif WRITE(MONIOU,*) ' ' CALL PRTIME( TTIME ) DO L = 1, NSEQ CALL RMMAQD( ISEED(1,L),L,'R' ) ENDDO WRITE(MONIOU,159) ISHOWNO,( L,(ISEED(J,L),J=1,3),L=1,NSEQ ) 159 FORMAT(' AND RANDOM NUMBER GENERATOR AT END OF EVENT :',I8, * /,(' SEQUENCE = ',I2,' SEED = ',I9 ,' CALLS = ',I9, * ' BILLIONS = ',I9)) C RESET NUMBER OF SHOWERS TO CORRECT VALUE ISHW = I #if __ANAHIST__ CALL AUGERHISTNORM( ISHW ) #endif RUNE(3) = REAL( ISHW ) cdh TDIFF = ILEFTB - ILEFTA C WRITE RUN END TO OUTPUT BUFFER AND FINISH OUTPUT #if __COMPACT__ IF ( COMOUT ) THEN CALL TOBUFS( RUNE, MAXBUF ) ELSE CALL TOBUF( RUNE,1 ) ENDIF #else #if __PARALLEL__ C WRRUNE SIGNALS THAT RUNE HAS BEEEN WRITTEN. WRRUNE = .TRUE. #endif #if __ICECUBE1__ && !__COASTUSERLIB__ CALL TOBUF( RUNE,2 ) #else CALL TOBUF( RUNE,1 ) #endif #endif #if __REMOTECONTROL__ CALL remotecontrol_push_rune(RUNE) #endif #if __CERENKOV__ #if __IACT__ CALL TELRNE( RUNE ) #endif IF ( MCERFI .NE. 0 ) THEN DO J = 1, NCERBUF CALL TOBUFC( RUNE,1,J ) ENDDO ENDIF #endif #if __UNIX__ && !__TIMERC__ C TIME SINCE BEGINNING #if __GFORTRAN__ CALL CPU_TIME( XLEFTB ) ILEFTB = NINT(XLEFTB) #else ILEFTB = 0. !TIME() !?????????????????? check #endif TDIFF = ILEFTB - ILEFTA #elif __TIMERC__ C TIME SINCE BEGINNING NO VALID INFORMATION CALL TIMER( ILEFTB ) TDIFF = ILEFTB - ILEFTA #elif __MAC__ C TIME SINCE BEGINNING CALL TIME( TLEFTB ) TDIFF = TLEFTB-TLEFTA #endif C MEAN VALUE FOR FIRST INTERACTION ALTITUDE (G/CM**2) IF ( ISHW .GT. 1 ) THEN CHISM2 = SQRT( ABS(CHISM2-CHISUM**2/ISHW) / (ISHW-1) ) CHISUM = CHISUM / ISHW ELSE CHISM2 = 0.D0 ENDIF C OUTPUTS FOR ALL SHOWERS WRITE(MONIOU,201) ISHW,TDIFF,TDIFF/ISHW,IRECOR,IRECOR/ISHW, * CHISUM,CHISM2 201 FORMAT(/,/,1X,10('='),' RUN SUMMARY ',56('='),/,/, * ' NUMBER OF GENERATED EVENTS = ',I10,/, * ' TOTAL TIME USED = ',F12.0,' SEC',/, * ' TIME PER EVENT = ',F14.2,' SEC',/, * ' TOTAL SPACE ON MPATAP USED = ',I12,' WORDS',/, * ' SPACE PER EVENT ON MPATAP = ',I12,' WORDS',/, * ' AVERAGE HEIGHT OF 1ST INT. = ',F10.3,' +-',F10.3,' G/CM**2',/) C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - * IF ( ISHW .GT. 1 ) THEN #if !__INTTEST__ C DO PRINTING OF AVERAGES ONLY IF MORE THAN 1 SHOWER IS SIMULATED C ENERGY - MULTIPLICITY MATRIX FOR ALL SHOWERS WRITE(MONIOU,209) (K,K=1,13),(J,(MULTOT(J,K),K=1,13), * 10**((J-4.)/3.),10**((J-3.)/3.),J=1,39), * 1,(INT(10**((K-1.)/3.)+1),K = 2,13), * 2,(INT(10**((K )/3.) ),K = 2,13) 209 FORMAT(/,/,' ENERGY - MULTIPLICITY MATRIX FOR ALL SHOWERS',/, * ' ENERGY RUNS VERTICALLY, MULTIPLICITY HORIZONTALLY',/,/, * ' ',6X,5I10,3I8,5I6,' ENERGY RANGE [GEV]',/, * 39(/,' ',I4,1X,I11,4I10,3I8,5I6,1P,E10.2,E9.2,0P),/,/, * ' MULT. ',5I10,3I8,5I6,4X,'LOWER BIN LIMIT',/, * ' RANGE ',5I10,3I8,5I6,4X,'UPPER BIN LIMIT') #if __THIN__ C ENERGY - WEIGHT MATRIX FOR ALL SHOWERS WRITE(MONIOU,229) (K,K=1,15), * (J,(MWGHTOT(J,K),K=1,15), * 10**((J-10.)/3.),10**((J-9.)/3.),J=1,45), * 1,(INT(10**((K-1.)/3.)+1),K = 2,15), * 2,(INT(10**((K )/3.) ),K = 2,15) 229 FORMAT(/,/,' ENERGY - WEIGHT MATRIX FOR ALL SHOWERS',/, * ' KIN. ENERGY RUNS VERTICALLY, WEIGHT HORIZONTALLY',/,/, * ' ',5X,5I7,5I7,5I7,' ENERGY RANGE [GEV]',/, * 45(/,' ',I4,1X,I7,4I7,5I7,5I7,1X,1P,2E10.2,0P),/,/, * ' WGHT. ',I6,5I7,4I7,5I7,4X,'LOWER BIN LIMIT',/, * ' RANGE ',I6,5I7,4I7,5I7,4X,'UPPER BIN LIMIT') #endif C GET MEAN OF ELASTICITY FOR ENERGY BINS DO J = 1, 40 NELMEA = 0 DO K = 1, 10 NELMEA = NELMEA + IELDPA(J,K) ENDDO IF ( NELMEA .NE. 0 ) ELMEAA(J) = ELMEAA(J) / NELMEA ENDDO C PRINT ENERGY - ELASTICITY MATRIX FOR ALL SHOWERS WRITE(MONIOU,408) (K,K=1,10), (J,(IELDPA(J,K),K=1,10), * ELMEAA(J),10**((J-4.D0)/3.D0),10**((J-3.)/3.D0),J=1,39), * ((K-1)*0.1D0,K=1,10),(K*0.1D0,K=1,10) 408 FORMAT(/,/,' ENERGY - ELASTICITY MATRIX FOR ALL SHOWERS',/, * ' ENERGY RUNS VERTICALLY, ELASTICITY HORIZONTALLY',/,/, * ' ',4X,7I9,3I10,' MEAN EL. ENERGY RANGE [GEV]',/, * 39(/,' ',I3,1X,7I9,3I10,1X,1P,E10.3,2E10.2,0P),/,/, * ' ELA. ',F8.2,6F9.2,3F10.2,5X,'LOWER BIN LIMIT',/, * ' RANGE',F8.2,6F9.2,3F10.2,5X,'UPPER BIN LIMIT') WRITE(MONIOU,204) 204 FORMAT(/,/,' INTERACTIONS PER KINETIC ENERGY INTERVAL FOR ALL', * ' SHOWERS',/,/,' BIN LOWER LIMIT UPPER LIMIT ', * 'NUCLEON PIONS KAONS S.BARYONS ', * ' TOTAL',/,12X,'IN GEV',9X,'IN GEV',7X, * ' EVENTS EVENTS EVENTS EVENTS ',/,/) WRITE(MONIOU,207) (J,SABIN(J),SBBIN(J),JNBIN(J),JPBIN(J), * JKBIN(J),JHBIN(J),JNBIN(J)+JPBIN(J)+JKBIN(J)+JHBIN(J),J=1,40) 207 FORMAT(' ',I5,1P,2E15.4,0P,F14.0,3F14.0,F15.0) #endif C CALCULATE MEAN VALUES AND STANDARD DEVIATIONS OF PARTICLE NUMBERS IF ( ISHW .GT. 1 ) THEN DO K = 1, 28 IOBSLV = NOBSLV DO J = 1, IOBSLV MPART2(J,K) = SQRT( ABS(MPART2(J,K)-MPARTO(J,K)**2/ISHW) * /(ISHW-1) ) MPARTO(J,K) = MPARTO(J,K)/ISHW ENDDO ENDDO ELSE DO K = 1, 28 IOBSLV = NOBSLV DO J = 1, IOBSLV MPART2(J,K) = 0.D0 ENDDO ENDDO ENDIF C PRINT MEAN VALUES AND STANDARD DEVIATIONS OF PARTICLE NUMBERS #if __ANAHIST__ || __AUGERHIST__ IFI = 1 IOBSLV = 1 WRITE(MONIOU,854) (K,K=IFI,IOBSLV) 854 FORMAT(/,' AVERAGE NUMBER OF PARTICLES PER EVENT :',/, * ' FROM LEVEL NUMBER ', 3(10X,I10,10X) ) WRITE(MONIOU,855) (OBSLEV(K),K=IFI,IOBSLV) 855 FORMAT( ' HEIGHT IN CM',1P,3(20X,E10.3),/) WRITE(MONIOU,856) (THCKOB(K),K=IFI,IOBSLV) 856 FORMAT( ' HEIGHT IN G/CM**2 ',1P,3(15X,E10.3,5X),/) IFI = NOBSLV IOBSLV = NOBSLV #else IFI = 1 IOBSLV = MIN( 3, NOBSLV ) WRITE(MONIOU,854) (K,K=IFI,IOBSLV) 854 FORMAT(/,' AVERAGE NUMBER OF PARTICLES PER EVENT :',/, * ' FROM LEVEL NUMBER ', 3(10X,I10,10X) ) WRITE(MONIOU,855) (OBSLEV(K),K=IFI,IOBSLV) 855 FORMAT( ' HEIGHT IN CM',1P,3(20X,E10.3),/) WRITE(MONIOU,856) (THCKOB(K),K=IFI,IOBSLV) 856 FORMAT( ' HEIGHT IN G/CM**2',1P,3(15X,E10.3,5X),/) #endif WRITE(MONIOU,778)'PROTONS ',(MPROTO(K),MPROT2(K),K=IFI,IOBSLV) WRITE(MONIOU,778)'ANTIPROTONS ',(MPROTB(K),MPRTB2(K),K=IFI,IOBSLV) WRITE(MONIOU,778)'NEUTRONS ',(MNEUTR(K),MNETR2(K),K=IFI,IOBSLV) WRITE(MONIOU,778)'ANTINEUTRONS',(MNEUTB(K),MNETB2(K),K=IFI,IOBSLV) WRITE(MONIOU,777)'GAMMAS ',(MPHOTO(K),MPHOT2(K),K=IFI,IOBSLV) WRITE(MONIOU,777)'POSITRONS ',(MPOSIT(K),MPOSI2(K),K=IFI,IOBSLV) WRITE(MONIOU,777)'ELECTRONS ',(MELECT(K),MELEC2(K),K=IFI,IOBSLV) #if __NEUTRINO__ WRITE(MONIOU,778)'NEUTRINOS ',(MNU (K),MNU2 (K),K=IFI,IOBSLV) #endif WRITE(MONIOU,778)'MU + ',(MMUP (K),MMUP2 (K),K=IFI,IOBSLV) WRITE(MONIOU,778)'MU - ',(MMUM (K),MMUM2 (K),K=IFI,IOBSLV) WRITE(MONIOU,778)'PI 0 ',(MPI0 (K),MPI02 (K),K=IFI,IOBSLV) WRITE(MONIOU,778)'PI + ',(MPIP (K),MPIP2 (K),K=IFI,IOBSLV) WRITE(MONIOU,778)'PI - ',(MPIM (K),MPIM2 (K),K=IFI,IOBSLV) WRITE(MONIOU,778)'K0L ',(MK0L (K),MK0L2 (K),K=IFI,IOBSLV) WRITE(MONIOU,778)'K0S ',(MK0S (K),MK0S2 (K),K=IFI,IOBSLV) WRITE(MONIOU,778)'K + ',(MKPL (K),MKPL2 (K),K=IFI,IOBSLV) WRITE(MONIOU,778)'K - ',(MKMI (K),MKMI2 (K),K=IFI,IOBSLV) WRITE(MONIOU,778)'STR. BARYONS',(MHYP (K),MHYP2 (K),K=IFI,IOBSLV) WRITE(MONIOU,778)'DEUTERONS ',(MDEUT (K),MDEUT2(K),K=IFI,IOBSLV) WRITE(MONIOU,778)'TRITONS ',(MTRIT (K),MTRIT2(K),K=IFI,IOBSLV) WRITE(MONIOU,778)'3HELIUM ',(MHELI3(K),MHEL32(K),K=IFI,IOBSLV) WRITE(MONIOU,778)'ALPHAS ',(MALPHA(K),MALPH2(K),K=IFI,IOBSLV) #if __CHARM__ WRITE(MONIOU,778)'CHRM.MESONS ',(MCHRMM(K),MCRMM2(K),K=IFI,IOBSLV) WRITE(MONIOU,778)'CHRM.BARYONS',(MCHRMB(K),MCRMB2(K),K=IFI,IOBSLV) #endif WRITE(MONIOU,778)'OTHER PART. ',(MOTHER(K),MOTH2 (K),K=IFI,IOBSLV) WRITE(MONIOU,*) WRITE(MONIOU,778) 'DECAYED MUONS',MMUOND WRITE(MONIOU,778) 'ELIMIN. MUONS',MMUONE 777 FORMAT(' NO OF ',A12,' = ',1P,3(E13.6,' +-',E13.6,' '),0P) 778 FORMAT(' NO OF ',A12,' = ',3(F13.1,' +-',F13.1,' ')) #if !__AUGERHIST__ IF ( NOBSLV .GT. 3 ) THEN IOBSLV = MIN( 6, NOBSLV ) WRITE(MONIOU,854) (K,K=4,IOBSLV) WRITE(MONIOU,855) (OBSLEV(K),K=4,IOBSLV) WRITE(MONIOU,856) (THCKOB(K),K=4,IOBSLV) WRITE(MONIOU,778)'PROTONS ',(MPROTO(K),MPROT2(K),K=4,IOBSLV) WRITE(MONIOU,778)'ANTIPROTONS ',(MPROTB(K),MPRTB2(K),K=4,IOBSLV) WRITE(MONIOU,778)'NEUTRONS ',(MNEUTR(K),MNETR2(K),K=4,IOBSLV) WRITE(MONIOU,778)'ANTINEUTRONS',(MNEUTB(K),MNETB2(K),K=4,IOBSLV) WRITE(MONIOU,777)'GAMMAS ',(MPHOTO(K),MPHOT2(K),K=4,IOBSLV) WRITE(MONIOU,777)'POSITRONS ',(MPOSIT(K),MPOSI2(K),K=4,IOBSLV) WRITE(MONIOU,777)'ELECTRONS ',(MELECT(K),MELEC2(K),K=4,IOBSLV) #if __NEUTRINO__ WRITE(MONIOU,778)'NEUTRINOS ',(MNU (K),MNU2 (K),K=4,IOBSLV) #endif WRITE(MONIOU,778)'MU + ',(MMUP (K),MMUP2 (K),K=4,IOBSLV) WRITE(MONIOU,778)'MU - ',(MMUM (K),MMUM2 (K),K=4,IOBSLV) WRITE(MONIOU,778)'PI 0 ',(MPI0 (K),MPI02 (K),K=4,IOBSLV) WRITE(MONIOU,778)'PI + ',(MPIP (K),MPIP2 (K),K=4,IOBSLV) WRITE(MONIOU,778)'PI - ',(MPIM (K),MPIM2 (K),K=4,IOBSLV) WRITE(MONIOU,778)'K0L ',(MK0L (K),MK0L2 (K),K=4,IOBSLV) WRITE(MONIOU,778)'K0S ',(MK0S (K),MK0S2 (K),K=4,IOBSLV) WRITE(MONIOU,778)'K + ',(MKPL (K),MKPL2 (K),K=4,IOBSLV) WRITE(MONIOU,778)'K - ',(MKMI (K),MKMI2 (K),K=4,IOBSLV) WRITE(MONIOU,778)'STR. BARYONS',(MHYP (K),MHYP2 (K),K=4,IOBSLV) WRITE(MONIOU,778)'DEUTERONS ',(MDEUT (K),MDEUT2(K),K=4,IOBSLV) WRITE(MONIOU,778)'TRITONS ',(MTRIT (K),MTRIT2(K),K=4,IOBSLV) WRITE(MONIOU,778)'3HELIUM ',(MHELI3(K),MHEL32(K),K=4,IOBSLV) WRITE(MONIOU,778)'ALPHAS ',(MALPHA(K),MALPH2(K),K=4,IOBSLV) #if __CHARM__ WRITE(MONIOU,778)'CHRM.MESONS ',(MCHRMM(K),MCRMM2(K),K=4,IOBSLV) WRITE(MONIOU,778)'CHRM.BARYONS',(MCHRMB(K),MCRMB2(K),K=4,IOBSLV) #endif WRITE(MONIOU,778)'OTHER PART. ',(MOTHER(K),MOTH2 (K),K=4,IOBSLV) WRITE(MONIOU,*) IF ( NOBSLV .GT. 6 ) THEN IOBSLV = MIN( 9, NOBSLV ) WRITE(MONIOU,854) (K,K=7,IOBSLV) WRITE(MONIOU,855) (OBSLEV(K),K=7,IOBSLV) WRITE(MONIOU,856) (THCKOB(K),K=7,IOBSLV) WRITE(MONIOU,778)'PROTONS ',(MPROTO(K),MPROT2(K),K=7,IOBSLV) WRITE(MONIOU,778)'ANTIPROTONS ',(MPROTB(K),MPRTB2(K),K=7,IOBSLV) WRITE(MONIOU,778)'NEUTRONS ',(MNEUTR(K),MNETR2(K),K=7,IOBSLV) WRITE(MONIOU,778)'ANTINEUTRONS',(MNEUTB(K),MNETB2(K),K=7,IOBSLV) WRITE(MONIOU,777)'GAMMAS ',(MPHOTO(K),MPHOT2(K),K=7,IOBSLV) WRITE(MONIOU,777)'POSITRONS ',(MPOSIT(K),MPOSI2(K),K=7,IOBSLV) WRITE(MONIOU,777)'ELECTRONS ',(MELECT(K),MELEC2(K),K=7,IOBSLV) #if __NEUTRINO__ WRITE(MONIOU,778)'NEUTRINOS ',(MNU (K),MNU2 (K),K=7,IOBSLV) #endif WRITE(MONIOU,778)'MU + ',(MMUP (K),MMUP2 (K),K=7,IOBSLV) WRITE(MONIOU,778)'MU - ',(MMUM (K),MMUM2 (K),K=7,IOBSLV) WRITE(MONIOU,778)'PI 0 ',(MPI0 (K),MPI02 (K),K=7,IOBSLV) WRITE(MONIOU,778)'PI + ',(MPIP (K),MPIP2 (K),K=7,IOBSLV) WRITE(MONIOU,778)'PI - ',(MPIM (K),MPIM2 (K),K=7,IOBSLV) WRITE(MONIOU,778)'K0L ',(MK0L (K),MK0L2 (K),K=7,IOBSLV) WRITE(MONIOU,778)'K0S ',(MK0S (K),MK0S2 (K),K=7,IOBSLV) WRITE(MONIOU,778)'K + ',(MKPL (K),MKPL2 (K),K=7,IOBSLV) WRITE(MONIOU,778)'K - ',(MKMI (K),MKMI2 (K),K=7,IOBSLV) WRITE(MONIOU,778)'STR. BARYONS',(MHYP (K),MHYP2 (K),K=7,IOBSLV) WRITE(MONIOU,778)'DEUTERONS ',(MDEUT (K),MDEUT2(K),K=7,IOBSLV) WRITE(MONIOU,778)'TRITONS ',(MTRIT (K),MTRIT2(K),K=7,IOBSLV) WRITE(MONIOU,778)'3HELIUM ',(MHELI3(K),MHEL32(K),K=7,IOBSLV) WRITE(MONIOU,778)'ALPHAS ',(MALPHA(K),MALPH2(K),K=7,IOBSLV) #if __CHARM__ WRITE(MONIOU,778)'CHRM.MESONS ',(MCHRMM(K),MCRMM2(K),K=7,IOBSLV) WRITE(MONIOU,778)'CHRM.BARYONS',(MCHRMB(K),MCRMB2(K),K=7,IOBSLV) #endif WRITE(MONIOU,778)'OTHER PART. ',(MOTHER(K),MOTH2 (K),K=7,IOBSLV) WRITE(MONIOU,*) IF ( NOBSLV .GT. 9 ) THEN IOBSLV = MIN( 10, NOBSLV ) WRITE(MONIOU,854) (K,K=9,IOBSLV) WRITE(MONIOU,855) (OBSLEV(K),K=9,IOBSLV) WRITE(MONIOU,856) (THCKOB(K),K=9,IOBSLV) WRITE(MONIOU,778)'PROTONS ',(MPROTO(K),MPROT2(K),K=9,IOBSLV) WRITE(MONIOU,778)'ANTIPROTONS ',(MPROTB(K),MPRTB2(K),K=9,IOBSLV) WRITE(MONIOU,778)'NEUTRONS ',(MNEUTR(K),MNETR2(K),K=9,IOBSLV) WRITE(MONIOU,778)'ANTINEUTRONS',(MNEUTB(K),MNETB2(K),K=9,IOBSLV) WRITE(MONIOU,777)'GAMMAS ',(MPHOTO(K),MPHOT2(K),K=9,IOBSLV) WRITE(MONIOU,777)'POSITRONS ',(MPOSIT(K),MPOSI2(K),K=9,IOBSLV) WRITE(MONIOU,777)'ELECTRONS ',(MELECT(K),MELEC2(K),K=9,IOBSLV) #if __NEUTRINO__ WRITE(MONIOU,778)'NEUTRINOS ',(MNU (K),MNU2 (K),K=9,IOBSLV) #endif WRITE(MONIOU,778)'MU + ',(MMUP (K),MMUP2 (K),K=9,IOBSLV) WRITE(MONIOU,778)'MU - ',(MMUM (K),MMUM2 (K),K=9,IOBSLV) WRITE(MONIOU,778)'PI 0 ',(MPI0 (K),MPI02 (K),K=9,IOBSLV) WRITE(MONIOU,778)'PI + ',(MPIP (K),MPIP2 (K),K=9,IOBSLV) WRITE(MONIOU,778)'PI - ',(MPIM (K),MPIM2 (K),K=9,IOBSLV) WRITE(MONIOU,778)'K0L ',(MK0L (K),MK0L2 (K),K=9,IOBSLV) WRITE(MONIOU,778)'K0S ',(MK0S (K),MK0S2 (K),K=9,IOBSLV) WRITE(MONIOU,778)'K + ',(MKPL (K),MKPL2 (K),K=9,IOBSLV) WRITE(MONIOU,778)'K - ',(MKMI (K),MKMI2 (K),K=9,IOBSLV) WRITE(MONIOU,778)'STR. BARYONS',(MHYP (K),MHYP2 (K),K=9,IOBSLV) WRITE(MONIOU,778)'DEUTERONS ',(MDEUT (K),MDEUT2(K),K=9,IOBSLV) WRITE(MONIOU,778)'TRITONS ',(MTRIT (K),MTRIT2(K),K=9,IOBSLV) WRITE(MONIOU,778)'3HELIUM ',(MHELI3(K),MHEL32(K),K=9,IOBSLV) WRITE(MONIOU,778)'ALPHAS ',(MALPHA(K),MALPH2(K),K=9,IOBSLV) #if __CHARM__ WRITE(MONIOU,778)'CHRM.MESONS ',(MCHRMM(K),MCRMM2(K),K=7,IOBSLV) WRITE(MONIOU,778)'CHRM.BARYONS',(MCHRMB(K),MCRMB2(K),K=9,IOBSLV) #endif WRITE(MONIOU,778)'OTHER PART. ',(MOTHER(K),MOTH2 (K),K=9,IOBSLV) WRITE(MONIOU,*) ENDIF ENDIF ENDIF #endif C PRINT OUT NKG RESULT FOR ALL SHOWERS IF SELECTED IF ( FNKG ) CALL MITAGE C CALCULATE MEAN VALUES AND SIGMAS OF LONGITUDINAL DISTRIBUTION IF ( LLONGI ) THEN IF ( ISHW .GT. 1 ) THEN DO J = 0, NSTEP1 DO K = 1, 19 SDLONG(J,K) = SQRT( MAX( 0.D0, * (SDLONG(J,K)-ADLONG(J,K)**2/ISHW)/(ISHW-1) ) ) ADLONG(J,K) = ADLONG(J,K)/ISHW ENDDO DO K = 1, 10 SELONG(J,K) = SQRT( MAX( 0.D0, * (SELONG(J,K)-AELONG(J,K)**2/ISHW)/(ISHW-1) ) ) AELONG(J,K) = AELONG(J,K)/ISHW SPLONG(J,K) = SQRT( MAX( 0.D0, * (SPLONG(J,K)-APLONG(J,K)**2/ISHW)/(ISHW-1) ) ) APLONG(J,K) = APLONG(J,K)/ISHW #if __ANAHIST__ SPLONG(J,K+10) = SQRT( MAX( 0.D0, * (SPLONG(J,K+10)-APLONG(J,K+10)**2/ISHW)/(ISHW-1) ) ) APLONG(J,K+10) = APLONG(J,K+10)/ISHW #endif ENDDO ENDDO ELSE DO J = 0, NSTEP1 DO K = 1, 19 SDLONG(J,K) = 0.D0 ENDDO DO K = 1, 10 SELONG(J,K) = 0.D0 SPLONG(J,K) = 0.D0 #if __ANAHIST__ SPLONG(J,K+10) = 0.D0 #endif ENDDO ENDDO ENDIF C PRINT AVERAGE LONGITUDINAL PARTICLE DISTRIBUTIONS WRITE(MONIOU,911) THSTEP, * 'GAMMAS ','POSITRONS','ELECTRONS','MU+ ','MU- ', #if __SLANT__ * (THCKRL(J),(APLONG(J,K),SPLONG(J,K),K=1,5),J=LPCT0,NSTEP1) 911 FORMAT(/,' AVERAGE LONGITUDINAL PARTICLE DISTRIBUTION IN ', * 'SLANT STEPS OF ',F5.0,' G/CM**2 ',/,' ',133('='),/, * ' DEPTH',6X,A9,16X,2(A10,17X),A9,16X,A9,/,/, * (' ',F6.0,1P,E11.4,'+-',E11.4,0P,F13.0,'+-',F12.0, * 1X,F13.0,'+-',F12.0,1X,F10.0,'+-',F11.0, * 1X,F10.0,'+-',F11.0 )) #else * (J*THSTEP,(APLONG(J,K),SPLONG(J,K),K=1,5),J=LPCT0,NSTEP1) 911 FORMAT(/,' AVERAGE LONGITUDINAL PARTICLE DISTRIBUTION IN ', * 'VERT. STEPS OF ',F5.0,' G/CM**2 ',/,' ',132('='),/, * ' DEPTH',6X,A9,16X,2(A10,17X),A9,16X,A9,/,/, * (' ',F5.0,1P,E11.4,'+-',E11.4,0P,F13.0,'+-',F12.0, * 1X,F13.0,'+-',F12.0,1X,F10.0,'+-',F11.0, * 1X,F10.0,'+-',F11.0 )) #endif #if __NEUTRINO__ || __NUPRIM__ WRITE(MONIOU,912) THSTEP, * 'HADRONS','CHARGED','NUCLEI','NEUTRINOS','CHERENKOV', #if __SLANT__ * ( THCKRL(J),(APLONG(J,K),SPLONG(J,K),K=6,8),APLONG(J,10), * SPLONG(J,10),APLONG(J,9),SPLONG(J,9), J=LPCT0,NSTEP1 ) 912 FORMAT(/,' AVERAGE LONGITUDINAL PARTICLE DISTRIBUTION IN ', * 'SLANT STEPS OF ',F5.0,' G/CM**2 ',/,' ',142('='),/, * ' DEPTH',8X,A9,17X,A10,17X,A9,20X,A9,16X,A9,/,/, * (' ',F6.0,1X,F11.1,'+-',F11.1,1X,F13.0,'+-',F13.0, * 2X,F10.1,'+-',F10.1,1X,1X,F10.1,'+-',F10.1, * 1P,E16.6,'+-',E16.6,0P)) #else * ( J*THSTEP,(APLONG(J,K),SPLONG(J,K),K=6,8),APLONG(J,10), * SPLONG(J,10),APLONG(J,9),SPLONG(J,9), J=LPCT0,NSTEP1 ) 912 FORMAT(/,' AVERAGE LONGITUDINAL PARTICLE DISTRIBUTION IN ', * 'VERT. STEPS OF ',F5.0,' G/CM**2 ',/,' ',141('='),/, * ' DEPTH',8X,A9,17X,A10,17X,A9,20X,A9,16X,A9,/,/, * (' ',F5.0,1X,F11.1,'+-',F11.1,1X,F13.0,'+-',F13.0, * 2X,F10.1,'+-',F10.1,1X,1X,F10.1,'+-',F10.1, * 1P,E16.6,'+-',E16.6,0P)) #endif #else WRITE(MONIOU,912) THSTEP, * 'HADRONS','CHARGED','NUCLEI','CHERENKOV', #if __SLANT__ * (THCKRL(J),(APLONG(J,K),SPLONG(J,K),K=6,9),J=LPCT0,NSTEP1) 912 FORMAT(/,' AVERAGE LONGITUDINAL PARTICLE DISTRIBUTION IN ', * 'SLANT STEPS OF ',F5.0,' G/CM**2 ',/,' ',119('='),/, * ' DEPTH',8X,A9,17X,A10,17X,A9,21X,A9,/,/, * (' ',F6.0,1X,F11.1,'+-',F11.1,1X,F13.0,'+-',F13.0, * 2X,F10.1,'+-',F10.1,1X,1P,E16.6,'+-',E16.6,0P)) #else * (J*THSTEP,(APLONG(J,K),SPLONG(J,K),K=6,9),J=LPCT0,NSTEP1) 912 FORMAT(/,' AVERAGE LONGITUDINAL PARTICLE DISTRIBUTION IN ', * 'VERT. STEPS OF ',F5.0,' G/CM**2 ',/,' ',118('='),/, * ' DEPTH',8X,A9,17X,A10,17X,A9,21X,A9,/,/, * (' ',F5.0,1X,F11.1,'+-',F11.1,1X,F13.0,'+-',F13.0, * 2X,F10.1,'+-',F10.1,1X,1P,E16.6,'+-',E16.6,0P)) #endif #endif C PRINT AVERAGE LONGITUDINAL ENERGY DISTRIBUTIONS WRITE(MONIOU,915) THSTEP, * 'GAMMAS ','POSITRONS','ELECTRONS','MU+ ','MU- ', #if __SLANT__ * (THCKRL(J),(AELONG(J,K),SELONG(J,K),K=1,5),J=LPCT0,NSTEP1) 915 FORMAT(/,' AVERAGE LONGITUDINAL ENERGY DISTRIBUTION [GEV] ', * 'IN SLANT STEPS OF ',F5.0,' G/CM**2 ',/,' ',132('='),/, * ' DEPTH',6X,A9,4(16X,A9),/,/, * (' ',F6.0,1X,1P,5(1X,E11.4,'+-',E11.4),0P)) #else * (J*THSTEP,(AELONG(J,K),SELONG(J,K),K=1,5),J=LPCT0,NSTEP1) 915 FORMAT(/,' AVERAGE LONGITUDINAL ENERGY DISTRIBUTION [GEV] ', * 'IN VERT. STEPS OF ',F5.0,' G/CM**2 ',/,' ',132('='),/, * ' DEPTH',6X,A9,4(16X,A9),/,/, * (' ',F5.0,1X,1P,5(1X,E11.4,'+-',E11.4),0P)) #endif #if __NEUTRINO__ || __NUPRIM__ WRITE(MONIOU,916) THSTEP, * 'HADRONS','CHARGED','NUCLEI','NEUTRINOS','ENERGYSUM', #if __SLANT__ * ( THCKRL(J),(AELONG(J,K),SELONG(J,K),K=6,8),AELONG(J,10), * SELONG(J,10),AELONG(J,9),SELONG(J,9),J=LPCT0,NSTEP1 ) 916 FORMAT(/,' AVERAGE LONGITUDINAL ENERGY DISTRIBUTION [GEV] ', * 'IN SLANT STEPS OF ',F5.0,' G/CM**2 ',/,' ',136('='),/, * ' DEPTH',7X,4(A8,17X),2X,A10, /,/,(' ',F6.0,1X,1P, * 4(E12.5,'+-',E11.4),E14.7,'+-',E13.6,0P)) #else * ( J*THSTEP,(AELONG(J,K),SELONG(J,K),K=6,8),AELONG(J,10), * SELONG(J,10),AELONG(J,9),SELONG(J,9),J=LPCT0,NSTEP1 ) 916 FORMAT(/,' AVERAGE LONGITUDINAL ENERGY DISTRIBUTION [GEV] ', * 'IN VERT. STEPS OF ',F5.0,' G/CM**2 ',/,' ',135('='),/, * ' DEPTH',7X,4(A8,17X),2X,A10, /,/,(' ',F5.0,1X,1P, * 4(E12.5,'+-',E11.4),E14.7,'+-',E13.6,0P)) #endif #else WRITE(MONIOU,916) THSTEP, * 'HADRONS','CHARGED','NUCLEI','ENERGYSUM', #if __SLANT__ * (THCKRL(J),(AELONG(J,K),SELONG(J,K),K=6,9),J=LPCT0,NSTEP1) 916 FORMAT(/,' AVERAGE LONGITUDINAL ENERGY DISTRIBUTION [GEV] ', * 'IN SLANT STEPS OF ',F5.0,' G/CM**2 ',/,' ',114('='),/, * ' DEPTH',7X,3(A8,18X),2X,A10, /,/,(' ',F6.0,1X,1P, * 3(E12.5,'+-',E12.5),E14.7,'+-',E14.7,0P)) #else * (J*THSTEP,(AELONG(J,K),SELONG(J,K),K=6,9),J=LPCT0,NSTEP1) 916 FORMAT(/,' AVERAGE LONGITUDINAL ENERGY DISTRIBUTION [GEV] ', * 'IN VERT. STEPS OF ',F5.0,' G/CM**2 ',/,' ',114('='),/, * ' DEPTH',7X,3(A8,18X),2X,A10, /,/,(' ',F5.0,1X,1P, * 3(E12.5,'+-',E12.5),E14.7,'+-',E14.7,0P)) #endif #endif C PRINT AVERAGE LONGITUDINAL ENERGY DEPOSIT ADLONGSUM = 0.D0 DO K = 1, 19 DO J = 0, NSTEP1 ADLONG(LNGMAX,K) = ADLONG(LNGMAX,K) + ADLONG(J,K) ENDDO C DO NOT SUM UP CHERENKOV PHOTONS IF ( K .NE. 9 ) ADLONGSUM = ADLONGSUM + ADLONG(LNGMAX,K) ENDDO WRITE(MONIOU,913) THSTEP, * 'GAMMA E_CUT', 'EM IONIZ','EM E-CUT','MU IONIZ','MU E-CUT', #if __SLANT__ * ( 0.5*(THCKRL(J-1)+THCKRL(J)),(ADLONG(J,K),SDLONG(J,K), * K=1,5),J=LPCT0+1,NSTEP1-1 ) 913 FORMAT(/,' AVERAGE LONGITUDINAL ENERGY DEPOSIT [GEV] IN ', * 'SLANT STEPS OF ', F5.0,' G/CM**2 ',/,' ',133('='),/, * ' DEPTH',6X,A11,14X,2(A10,17X),A9,16X,A9,/,/, * (' ',F7.1, F10.0,'+-',F10.0,1X,F13.0,'+-',F12.0, * 1X,F13.0,'+-',F12.0,1X,F10.0,'+-',F11.0, * 1X,F10.0,'+-',F11.0 )) #else * ((2*J-1)*.5*THSTEP,(ADLONG(J,K),SDLONG(J,K), * K=1,5),J=LPCT0+1,NSTEP1-1 ) 913 FORMAT(/,' AVERAGE LONGITUDINAL ENERGY DEPOSIT [GEV] IN ', * 'VERT. STEPS OF ', F5.0,' G/CM**2 ',/,' ',132('='),/, * ' DEPTH',6X,A11,14X,2(A10,17X),A9,16X,A9,/,/, * (' ',F6.1, F10.0,'+-',F10.0,1X,F13.0,'+-',F12.0, * 1X,F13.0,'+-',F12.0,1X,F10.0,'+-',F11.0, * 1X,F10.0,'+-',F11.0 )) #endif WRITE(MONIOU,9131) (2*NSTEP1-1)*.5*THSTEP, * (ADLONG(NSTEP1,K),SDLONG(NSTEP1,K),K=1,5) #if __SLANT__ 9131 FORMAT(' ',F7.1, F10.0,'+-',F10.0,1X,F13.0,'+-',F12.0, * 1X,F13.0,'+-',F12.0,1X,F10.0,'+-',F11.0, * 1X,1P,E10.3,0P,'+-',F11.0 ) #else 9131 FORMAT(' ',F6.1, F10.0,'+-',F10.0,1X,F13.0,'+-',F12.0, * 1X,F13.0,'+-',F12.0,1X,F10.0,'+-',F11.0, * 1X,1P,E10.3,0P,'+-',F11.0 ) #endif WRITE(MONIOU,917) (ADLONG(LNGMAX,K),K=1,5) 917 FORMAT(' ',20X,'AVERAGE LONGITUDINAL ENERGY SUM [GEV] ',/, * ' ',4X,F14.1,12X,F14.1,13X,F15.1,11X,F14.1,10X,F14.1) WRITE(MONIOU,913) THSTEP, * 'GAMMA A-CUT',' (DUMMY)','EM A-CUT','(DUMMY) ','MU A-CUT', #if __SLANT__ * (0.5*(THCKRL(J-1)+THCKRL(J)),(ADLONG(J,K),SDLONG(J,K), #else * ((2*J-1)*.5*THSTEP,(ADLONG(J,K),SDLONG(J,K), #endif * K=11,15),J=LPCT0+1,NSTEP1) WRITE(MONIOU,917) (ADLONG(LNGMAX,K),K=11,15) WRITE(MONIOU,914) THSTEP, * 'HADR IONIZ','HADR E-CUT','NEUTRINO',' SUM', #if __SLANT__ * ( 0.5*(THCKRL(J-1)+THCKRL(J)),(ADLONG(J,K),SDLONG(J,K), * K=6,9),J=LPCT0+1,NSTEP1 ) 914 FORMAT(/,' AVERAGE LONGITUDINAL ENERGY DEPOSIT [GEV] IN ', * 'SLANT STEPS OF ',F5.0,' G/CM**2 ',/,' ',116('='),/, * ' DEPTH',7X,A10,16X,A10,17X,A12,17X,A9,/,/, * (' ',F7.1, F11.1,'+-',F11.1,1X,F13.0,'+-',F13.0, * 1X,F12.1,'+-',F12.1,1X,F13.1,'+-',F13.1)) #else * ((2*J-1)*.5*THSTEP,(ADLONG(J,K),SDLONG(J,K), * K=6,9),J=LPCT0+1,NSTEP1 ) 914 FORMAT(/,' AVERAGE LONGITUDINAL ENERGY DEPOSIT [GEV] IN ', * 'VERT. STEPS OF ',F5.0,' G/CM**2 ',/,' ',115('='),/, * ' DEPTH',7X,A10,16X,A10,17X,A12,17X,A9,/,/, * (' ',F6.1, F11.1,'+-',F11.1,1X,F13.0,'+-',F13.0, * 1X,F12.1,'+-',F12.1,1X,F13.1,'+-',F13.1)) #endif WRITE(MONIOU,918) (ADLONG(LNGMAX,K),K=6,8) 918 FORMAT(' ',20X,'AVERAGE LONGITUDINAL ENERGY SUM [GEV] ', * /,' ',4X,F14.1,13X,F15.1,14X,F14.1) WRITE(MONIOU,914) THSTEP, * '(DUMMY)','HADR A-CUT','NTRINO A-CUT','(DUMMY)', #if __SLANT__ * (0.5*(THCKRL(J-1)+THCKRL(J)),(ADLONG(J,K),SDLONG(J,K), #else * ((2*J-1)*.5*THSTEP,(ADLONG(J,K),SDLONG(J,K), #endif * K=16,19),J=LPCT0+1,NSTEP1) WRITE(MONIOU,918) (ADLONG(LNGMAX,K),K=16,18) WRITE(MONIOU,919) ADLONGSUM 919 FORMAT(' ',20X,' ENERGY SUM = ',1P,E15.7,0P,' GEV') IF ( FLGFIT ) THEN C PERFORM FIT TO THE LONGITUDINAL DISTRIBUTION OF ALL CHARGED PARTICLES C IF EGS IS SELECTED THIS IS THE DISTRIBUTION WHICH IS TO BE TAKEN IF ( FEGS ) THEN DO J = 0, NSTEP-LPCT0 DEP(J+1) = (J+LPCT0)*THSTEP CHAPAR(J+1) = MAX( 0.D0, APLONG(J+LPCT0,7) ) ENDDO #if __CONEX__ C WITH CONEX, DO NOT USE THE LAST BIN WHICH MIGHT BE EMPTY IF ONLY CE ARE USED NSTP = NSTEP - LPCT0 #else NSTP = NSTEP + 1 - LPCT0 #endif WRITE(MONIOU,8229) 'AVERAGE ALL CHARGED PARTICLES' C IF NKG IS SELECTED ONLY THE ELECTRON DISTRIBUTION IS AVAILABLE ELSEIF ( FNKG ) THEN DEP(1) = 0.D0 CHAPAR(1) = 0.D0 DO J = 1, IALT(1) DEP(J+1) = TLEV(J) CHAPAR(J+1) = MAX( 0.D0, SEL(J)/ISHW ) ENDDO NSTP = IALT(1) + 1 WRITE(MONIOU,8229) 'AVERAGE NKG ELECTRONS' C IF NONE IS SELECTED IT DOES NOT REALLY MAKE SENSE TO FIT C BUT LET''S TAKE THEN ALL CHARGED WHICH ARE MUONS AND HADRONS ELSE DO J = 0, NSTEP-LPCT0 DEP(J+1) = (J+LPCT0)*THSTEP CHAPAR(J+1) = MAX( 0.D0, APLONG(J+LPCT0,7) ) ENDDO #if __CONEX__ C WITH CONEX, DO NOT USE THE LAST BIN WHICH MIGHT BE EMPTY IF ONLY CE ARE USED NSTP = NSTEP - LPCT0 #else NSTP = NSTEP + 1 - LPCT0 #endif WRITE(MONIOU,8229) 'AVERAGE MUONS AND CHARGED HADRONS' ENDIF #if __SLANT__ C OMIT LAST (INCOMPLETE) BIN FOR FIT OF SLANT LONGI DISTRIBUTION NSTP = NSTP - 1 #endif IF ( NSTP .GT. 6 ) THEN C THERE ARE MORE THAN 6 STEP VALUES, A FIT SHOULD BE POSSIBLE. C DO THE FIT: NPAR AND FPARAM GIVE THE NUMBER OF PARAMETERS USED C AND THE FINAL VALUES FOR THE PARAMETERS. CHISQ GIVES THE CHI**2/DOF C FOR THE FIT. CALL LONGFT( FPARAM,CHI2 ) IF ( FPARAM(1) .GT. 0.D0 ) THEN WRITE(MONIOU,8230) FPARAM,CHI2, * CHI2/SQRT(FPARAM(1))*100.D0 ELSE WRITE(MONIOU,8231) FPARAM,CHI2 ENDIF #if __AUGERHIST__ #if __SLANT__ C CORRECT NUMBER OF BINS: LAST (INCOMPLETE) BIN NSTP = NSTP + 1 #endif C FILL IN THE LONGITUDINAL ENERGY DEPOSIT AND MAKE A FIT WITH IT IF ( FEGS .AND. NSTP .GT. 8 ) THEN DO J = 2, NSTEP-LPCT1-1 DEP(J-1) = THSTEP * (2*J-1)*.5D0 C ADD UP: GAMMA ENERGY CUT; E+E- IONIZATON, E+E- ENERGY CUT; C MUON IONIZATION; MUON ENERGY CUT; HADRON IONIZATION; CHAPAR(J-1) = ADLONG(J,1) + ADLONG(J,2) + ADLONG(J,3) * +ADLONG(J,4) + ADLONG(J,5) + ADLONG(J,6) * +ADLONG(J,11)+ ADLONG(J,13)+ ADLONG(J,15) CHAPAR(J-1) = MAX( CHAPAR(J-1), 0.D0 ) ENDDO NSTP = NSTEP - LPCT1 - 2 WRITE(MONIOU,8229) 'AVERAGE IONIZATION ENERGY DEPOSIT' CALL LONGFT( FPARAM,CHI2 ) IF ( FPARAM(1) .GE. 0.D0 ) THEN WRITE(MONIOU,8230) * FPARAM,CHI2,CHI2/SQRT(FPARAM(1))*100.D0 ELSE WRITE(MONIOU,8231) FPARAM,CHI2 ENDIF ENDIF #endif ELSE WRITE(MONIOU,*) 'NO LONGI. FIT POSSIBLE, ', * ' NSTP = ',NSTP,' TOO SMALL.' ENDIF ENDIF ENDIF * ENDIF C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if __ANAHIST__ || __AUGERHIST__ || __MUONHIST__ C WRITE HISTOGRAMS (AUGER OR ANALYSIS) OUT TO DISK CALL AHISTOUT #endif #if __INTTEST__ C FINISH HISTOGRAMMING AND PUT HISTOGRAMS OUT CALL HISOUT WRITE(MONIOU,*) ' NUMBER OF STARTED EVENTS =', NOINT+ISHW WRITE(MONIOU,*) ' NUMBER OF ELASTIC EVENTS OR WITHOUT', * ' INTERACTION =', NOINT WRITE(MONIOU,*) ' NUMBER OF REMOVED ELASTIC EVENTS =',NELAST FRACTION = DBLE(ISHW) / DBLE(NOINT+ISHW) WRITE(MONIOU,997) FRACTION 997 FORMAT(' FRACTION OF INELASTIC EVENTS = ',F10.7) FRACTION = DBLE(NELAST)/DBLE(NELAST+ISHW) WRITE(MONIOU,998) FRACTION 998 FORMAT(' FRACTION OF ELASTIC EVENTS = ',F10.7) #endif C CONTROL PRINT OUTPUT OF CONSTANTS IF ( DEBUG ) THEN CALL STAEND WRITE(MDEBUG,*) 'AAMAIN: STAEND CALLED' ENDIF C CLOSE ALL OPEN UNITS #if __STACKIN__ CLOSE( LSTCK ) #endif #if __CONEX__ CLOSE( INLUN ) #endif #if __PARALLEL__ C CLOSE SCRATCH FILES CALL FSTACKO(0) CALL FSTACKJO(0) #else CLOSE( MEXST ) #endif #if __COAST__ #if __COASTUSERLIB__ call cloda () #else IF ( FPAROUT ) call cloda () #endif #endif #if !__COAST__ || __COASTUSERLIB__ #if __COMPACT__ IF ( FPAROUT ) CLOSE( MPATAP ) #else #if !__PARALLELIB__ IF ( FPAROUT ) CALL fclosempatap() #endif #endif #endif IF ( FTABOUT ) CLOSE( MTABOUT ) IF ( FLONGOUT .AND. LLONGI ) CLOSE( MLONGOUT ) #if __CERENKOV__ IF ( MCERFI .NE. 0 ) THEN DO ICERBUF = 1, NCERBUF CALL FCLOSEMCETAP( ICERBUF ) ENDDO ENDIF #endif WRITE(MONIOU,*) ' ' CALL PRTIME( TTIME ) WRITE(MONIOU,101) 101 FORMAT (/' ',10('='),' END OF RUN ',48('=')) IF ( MONIIN .NE. 5 ) CLOSE( MONIIN ) IF ( MONIOU .NE. 6 ) THEN INQUIRE( MONIOU, EXIST=FEXIST) IF ( FEXIST ) CLOSE( MONIOU ) ENDIF IF ( MDEBUG .NE. 6 ) THEN INQUIRE( MDEBUG, EXIST=FEXIST) IF ( FEXIST ) CLOSE( MDEBUG ) ENDIF #if __AUGERINFO__ C OMIT THE FINAL STOP FOR AUGER PRODUCTION AT LYON USING C THE PORTLAND COMPILER PGF77 TO PREVENT MESSAGE 'FORTRAN STOP' #elif !__PARALLELIB__ STOP #endif END *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE ADDANG( COST0,PHI0, COST,PHI, COST1,PHI1 ) C----------------------------------------------------------------------- C ADD(ITION OF) ANG(LES) C C ADDITION OF ANGLES IS DONE BY SEQUENTIAL ROTATIONS : C 1. ROTATE VECTOR AROUND Z AXIS BY -PHI0 C 2. ROTATE VECTOR AROUND Y AXIS BY -THETA0 NOW VECTOR IS (0,0,1) C C 3. ROTATE VECTOR AROUND Y AXIS BY THETA ANGLES TO BE ADDED C 4. ROTATE VECTOR AROUND Z AXIS BY PHI C C 5. ROTATE VECTOR AROUND Y AXIS BY THETA0 C 6. ROTATE VECTOR AROUND Z AXIS BY -PHI0 C NOW VECTOR IS (X,Y,Z) WITH COST1 = Z C AND TAN(PHI1) = Y/X C THIS SUBROUTINE IS CALLED FROM MANY ROUTINES. C ARGUMENTS: C COST0 = COSINE THETA OF PARTICLE BEFORE C PHI0 = PHI OF PARTICLE BEFORE C COST = COSINE THETA OF ANGLE TO ADD C PHI = PHI OF ANGLE TO ADD C COST1 = COSINE THETA OF PARTICLE AFTER ADDITION OF ANGLES C PHI1 = PHI THETA OF PARTICLE AFTER ADDITION OF ANGLES C----------------------------------------------------------------------- IMPLICIT NONE #define __CONSTAINC__ #define __RUNPARINC__ #include "corsika.h" DOUBLE PRECISION A,COST,COST0,COST1,CPHI,CPHI0,PHI,PHI0,PHI1, * SINT,SINT0,SPHI,SPHI0,XXX,YYY,ZZZ SAVE C----------------------------------------------------------------------- CC IF ( DEBUG ) WRITE(MDEBUG,*) 'ADDANG:' SINT0 = SQRT( (1.D0-COST0) * (1.D0+COST0) ) SINT = SQRT( (1.D0-COST) * (1.D0+COST) ) SPHI0 = SIN( PHI0 ) CPHI0 = COS( PHI0 ) SPHI = SIN( PHI ) CPHI = COS( PHI ) A = COST0 * CPHI * SINT + COST * SINT0 XXX = A * CPHI0 - SPHI0 * SINT * SPHI YYY = A * SPHI0 + CPHI0 * SINT * SPHI ZZZ = COST * COST0 - SINT0 * SINT * CPHI C GET NEW COSINE(THETA) AND PHI COST1 = MIN( 1.D0, ZZZ ) IF ( YYY .NE. 0.D0 .OR. XXX .NE. 0.D0 ) THEN PHI1 = ATAN2( YYY, XXX ) ELSE PHI1 = 0.D0 ENDIF RETURN END *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE ADDANG3( COST0,CPHI0,SPHI0, COST,PHI, * COST1,CPHI1,SPHI1 ) C----------------------------------------------------------------------- C ADD(ITION OF) ANG(LES) C C THIS SUBROUTINE IS CALLED FROM MANY ROUTINES. C ARGUMENTS: C COST0 = COSINE THETA OF PARTICLE BEFORE C CPHI0 = DIRECTION COS IN X OF PARTICLE BEFORE C SPHI0 = -DIRECTION COS IN Y OF PARTICLE BEFORE C COST = COSINE THETA OF ANGLE TO ADD C PHI = ANGLE PHI OF ANGLE TO ADD C COST1 = COSINE THETA OF PARTICLE AFTER ADDITION OF ANGLES C CPHI1 = DIRECTION COS IN X OF PARTICLE AFTER ADDITION OF ANGLES C SPHI1 = -DIRECTION COS IN Y OF PARTICLE AFTER ADDITION OF ANGLES C----------------------------------------------------------------------- IMPLICIT NONE #define __CONSTAINC__ #define __RUNPARINC__ #include "corsika.h" DOUBLE PRECISION COSDEL,COST,COST0,COST1,CPHI0,CPHI1, * PHI,PHIX,PHIY,RADINV, * SINDEL,SINT,SINPSI,SINPS2,SPHI0,SPHI1 SAVE C----------------------------------------------------------------------- CC IF ( DEBUG ) WRITE(MDEBUG,*) 'ADDANG3:' SINT = SQRT( (1.D0-COST) * (1.D0+COST) ) SINPS2 = CPHI0**2 + SPHI0**2 C SMALL POLAR ANGLE CASE IF ( SINPS2 .LT. 1.D-40 ) THEN CPHI1 = SINT * COS( -PHI ) SPHI1 = SINT * SIN( -PHI ) COST1 = COST * COST0 ELSE PHIX = SINT * COS( -PHI ) PHIY = SINT * SIN( -PHI ) SINPSI = SQRT( SINPS2 ) COSDEL = CPHI0 * (1.D0/SINPSI) SINDEL = -SPHI0 * (1.D0/SINPSI) CPHI1 = COST0 * COSDEL * PHIX - SINDEL * PHIY + CPHI0 * COST SPHI1 = -COST0 * SINDEL * PHIX - COSDEL * PHIY + SPHI0 * COST COST1 = -SINPSI * PHIX + COST0 * COST ENDIF RADINV = 1.5D0 - 0.5D0 * ( CPHI1**2 + SPHI1**2 + COST1**2 ) CPHI1 = MIN( 1.D0, MAX( -1.D0, RADINV * CPHI1 ) ) SPHI1 = MIN( 1.D0, MAX( -1.D0, RADINV * SPHI1 ) ) COST1 = MIN( 1.D0, MAX( -1.D0, RADINV * COST1 ) ) RETURN END *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE ADDANG4( COST0,CPHI0,SPHI0, COST,CPHI,SPHI, * COST1,CPHI1,SPHI1 ) C----------------------------------------------------------------------- C ADD(ITION OF) ANG(LES) C C THIS SUBROUTINE IS CALLED FROM MANY ROUTINES. C ARGUMENTS: C COST0 = COSINE THETA OF PARTICLE BEFORE C CPHI0 = DIRECTION COS IN X OF PARTICLE BEFORE C SPHI0 = -DIRECTION COS IN Y OF PARTICLE BEFORE C COST = DIRECTION COSINE THETA OF ANGLE TO ADD C CPHI = DIRECTION COSINE PHI OF ANGLE TO ADD C SPHI = DIRECTION COSINE PHI OF ANGLE TO ADD C COST1 = COSINE THETA OF PARTICLE AFTER ADDITION OF ANGLES C CPHI1 = DIRECTION COS IN X OF PARTICLE AFTER ADDITION OF ANGLES C SPHI1 = -DIRECTION COS IN Y OF PARTICLE AFTER ADDITION OF ANGLES C----------------------------------------------------------------------- IMPLICIT NONE #define __CONSTAINC__ #define __RUNPARINC__ #include "corsika.h" DOUBLE PRECISION COSDEL,COST,COST0,COST1,CPHI,CPHI0,CPHI1, * RADINV,SINDEL,SINPSI,SINPS2,SPHI,SPHI0,SPHI1 SAVE C----------------------------------------------------------------------- CC IF ( DEBUG ) WRITE(MDEBUG,*) 'ADDANG4:' SINPS2 = CPHI0**2 + SPHI0**2 C SMALL POLAR ANGLE CASE IF ( SINPS2 .LT. 1.D-40 ) THEN CPHI1 = CPHI SPHI1 = -SPHI COST1 = COST * COST0 ELSE SINPSI = SQRT( SINPS2 ) COSDEL = CPHI0 * (1.D0/SINPSI) SINDEL = -SPHI0 * (1.D0/SINPSI) CPHI1 = COST0 * COSDEL * CPHI + SINDEL * SPHI + CPHI0 * COST SPHI1 = -COST0 * SINDEL * CPHI + COSDEL * SPHI + SPHI0 * COST COST1 = -SINPSI * CPHI + COST0 * COST ENDIF RADINV = 1.5D0 - 0.5D0 * ( CPHI1**2 + SPHI1**2 + COST1**2 ) CPHI1 = MIN( 1.D0, MAX( -1.D0, RADINV * CPHI1 ) ) SPHI1 = MIN( 1.D0, MAX( -1.D0, RADINV * SPHI1 ) ) COST1 = MIN( 1.D0, MAX( -1.D0, RADINV * COST1 ) ) RETURN END *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE ADDANI4( COST0,CPHI0,SPHI0, COST,CPHI,SPHI, * COST1,CPHI1,SPHI1 ) C----------------------------------------------------------------------- C SUB(STRACTION OF) ANG(LES) C C THIS SUBROUTINE IS CALLED FROM TSTACK. C ARGUMENTS: C COST0 = COSINE THETA OF PARTICLE BEFORE C CPHI0 = DIRECTION COS IN X OF PARTICLE BEFORE C SPHI0 = -DIRECTION COS IN Y OF PARTICLE BEFORE C COST = COSINE THETA OF PARTICLE AFTER SUBSTRACTION OF ANGLES C CPHI = DIRECTION COS IN X OF PARTICLE AFTER SUBSTRACTION OF ANGLES C SPHI = -DIRECTION COS IN Y OF PARTICLE AFTER SUBSTRACTION OF ANGLES C COST1 = DIRECTION COSINE THETA OF ANGLE TO SUBSTRACT C CPHI1 = DIRECTION COSINE PHI OF ANGLE TO SUBSTRACT C SPHI1 = DIRECTION COSINE PHI OF ANGLE TO SUBSTRACT C----------------------------------------------------------------------- IMPLICIT NONE #define __CONSTAINC__ #define __RUNPARINC__ #include "corsika.h" DOUBLE PRECISION COSDEL,COST,COST0,COST1,CPHI,CPHI0,CPHI1 * ,RADINV,SINDEL,SINPSI,SINPS2,SPHI,SPHI0,SPHI1 SAVE C----------------------------------------------------------------------- CC IF ( DEBUG ) WRITE(MDEBUG,*) 'ADDANI4:' SINPS2 = CPHI0**2 + SPHI0**2 C SMALL ZENITH ANGLE CASE IF ( COST0 .LT. 1.D-40 ) THEN CPHI = 0.D0 SPHI = 0.D0 COST = 1.D0 C SMALL POLAR ANGLE CASE ELSEIF ( SINPS2 .LT. 1.D-40 ) THEN CPHI = CPHI1 SPHI = -SPHI1 IF ( COST0 .GT. 1.D-10 ) THEN COST = COST1 / COST0 ELSE COST = 0.D0 ENDIF ELSE SINPSI = SQRT( SINPS2 ) COSDEL = CPHI0 * (1.D0/SINPSI) SINDEL = -SPHI0 * (1.D0/SINPSI) SPHI = SINDEL*CPHI1+COSDEL*SPHI1 CPHI = (CPHI1-SINDEL*SPHI-CPHI0*COST1/COST0) & /(COST0*COSDEL+CPHI0*SINPSI/COST0) COST = (COST1+SINPSI*CPHI)/COST0 ENDIF RADINV = 1.5D0 - 0.5D0 * ( CPHI**2 + SPHI**2 + COST**2 ) CPHI = MIN( 1.D0, MAX( -1.D0, RADINV * CPHI ) ) SPHI = MIN( 1.D0, MAX( -1.D0, RADINV * SPHI ) ) COST = MIN( 1.D0, MAX( -1.D0, RADINV * COST ) ) RETURN END *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE ADDANI( COST0,PHI0, COST1,PHI1, DCTH,DPHI ) C----------------------------------------------------------------------- C ADD(ITION OF) AN(GLES) I(NVERTED) C C GIVEN TWO DIRECTIONS (0 AND 1) IN A COMMON SYSTEM OF REFERENCE. C FIND DCTH AND DPHI SUCH, THAT THE SUBROUT. ADDANG TRANSFORMS C (COST0,PHI0) BY ADDING (DCTH,DPHI) INTO (COST1,PHI1). C CALCULATION IS DONE BY SEQUENTIAL ROTATIONS : C 1. ROTATE VECTOR AROUND Z AXIS BY -PHI1 C 2. ROTATE VECTOR AROUND Y AXIS BY -THETA1 C NOW VECTOR IS (X,Y,Z) WITH DCTH = Z C AND TAN(DPHI) = Y/X C THIS SUBROUTINE IS CALLED FROM MUDECY. C ARGUMENTS: C COST0 = COSINE THETA OF PARTICLE BEFORE C PHI0 = PHI OF PARTICLE BEFORE C COST1 = COSINE THETA OF PARTICLE C PHI1 = PHI OF PARTICLE C DCTH = COSINE THETA OF ANGLE C DPHI = PHI OF ANGLE C----------------------------------------------------------------------- IMPLICIT NONE #define __CONSTAINC__ #define __RUNPARINC__ #include "corsika.h" DOUBLE PRECISION COST0,COST1,CP,CP1,CT,CT1,DCTH,DPHI,PHI0,PHI1, * SP,SP1,ST,ST1,X,XX,Y,YY,Z,ZZ SAVE C----------------------------------------------------------------------- CC IF ( DEBUG ) WRITE(MDEBUG,*) 'ADDANI:' CT = COST0 ST = SQRT( (1.D0-CT) * (1.D0+CT) ) CP = COS( PHI0 ) SP = SIN( PHI0 ) CT1 = COST1 ST1 = SQRT( (1.D0-CT1) * (1.D0+CT1) ) CP1 = COS( PHI1 ) SP1 = SIN( PHI1 ) X = ST1 * CP1 Y = ST1 * SP1 Z = CT1 XX = CT*CP*X + CT*SP*Y - ST*Z YY = (-SP) *X + CP *Y ZZ = ST*CP*X + ST*SP*Y + CT*Z C GET NEW COSINE(THETA) AND PHI DCTH = ZZ IF ( YY .NE. 0.D0 .OR. XX .NE. 0.D0 ) THEN DPHI = ATAN2( YY, XX ) ELSE DPHI = 0.D0 ENDIF RETURN END *-- Author : The CORSIKA development group 16/05/1995 C======================================================================= SUBROUTINE AMOEBA( P,Y,MP,NP,NDIM,FTOL,FUNK,ITER,IFLAG ) C----------------------------------------------------------------------- C C FITTING ROUTINE 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 LONGFT. C ARGUMENTS: 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 FUNCTION (GIVING DERIVATIVES) C ITER = ITERATION COUNTER C IFLAG = ERROR FLAG C----------------------------------------------------------------------- IMPLICIT NONE #define __RUNPARINC__ #include "corsika.h" INTEGER ITMAX,NMAX C MAXIMUM NUMBER OF TRIAL PER CALL PARAMETER (ITMAX=5000) PARAMETER (NMAX=20) INTEGER MP,NP DOUBLE PRECISION FTOL,P(MP,NP),PSUM(NMAX), * RTOL,SUM,SWAP,Y(MP),YSAVE,YTRY INTEGER I,IFLAG,IHI,ILO,INHI,ITER,J,M,N,NDIM DOUBLE PRECISION AMOTRY,FUNK SAVE EXTERNAL AMOTRY,FUNK C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'AMOEBA:' IFLAG = 0 ITER = 0 1 CONTINUE DO N = 1, NDIM SUM = 0.D0 DO M = 1, NDIM+1 SUM = SUM + P(M,N) ENDDO PSUM(N) = SUM ENDDO 2 CONTINUE ILO = 1 IF ( Y(1) .GT. Y(2) ) THEN IHI = 1 INHI = 2 ELSE IHI = 2 INHI = 1 ENDIF DO 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 ENDDO if ( y(ihi) .eq. 0.d0 .and. y(ilo) .eq. 0.d0 ) then iflag = 2 return else RTOL = 2.D0*ABS(Y(IHI)-Y(ILO))/(ABS(Y(IHI))+ABS(Y(ILO))) endif IF ( RTOL .LT. FTOL ) THEN SWAP = Y(1) Y(1) = Y(ILO) Y(ILO) = SWAP DO N = 1, NDIM SWAP = P(1,N) P(1,N) = P(ILO,N) P(ILO,N) = SWAP ENDDO RETURN ENDIF IF ( ITER .GE.ITMAX ) THEN IF ( DEBUG ) WRITE(MDEBUG,*) 'AMOEBA: ITMAX EXCEEDED IN AMOEBA' IFLAG = 1 RETURN ENDIF ITER = ITER + 2 YTRY = AMOTRY( P,Y,PSUM,MP,NP,NDIM,FUNK,IHI,-1.D0 ) IF ( YTRY .LE. Y(ILO) ) THEN YTRY = AMOTRY( P,Y,PSUM,MP,NP,NDIM,FUNK,IHI,2.D0 ) ELSEIF ( YTRY .GE. Y(INHI) ) THEN YSAVE = Y(IHI) YTRY = AMOTRY( P,Y,PSUM,MP,NP,NDIM,FUNK,IHI,0.5D0 ) IF ( YTRY .GE. YSAVE ) THEN DO I = 1, NDIM+1 IF ( I .NE. ILO ) THEN DO J = 1, NDIM PSUM(J) = 0.5D0 * (P(I,J) + P(ILO,J)) P(I,J) = PSUM(J) ENDDO Y(I) = FUNK( PSUM ) ENDIF ENDDO ITER = ITER + NDIM GOTO 1 ENDIF ELSE ITER = ITER - 1 ENDIF GOTO 2 END C======================================================================= DOUBLE PRECISION FUNCTION AMOTRY(P,Y,PSUM,MP,NP,NDIM,FUNK,IHI,FAC) 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 EXTERNAL FUNCTION FUNK C THIS FUNCTION IS CALLED FROM AMOEBA C----------------------------------------------------------------------- IMPLICIT NONE #define __RUNPARINC__ #include "corsika.h" 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 SAVE EXTERNAL FUNK C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'AMOTRY:' FAC1 = (1.D0-FAC)/NDIM FAC2 = FAC1-FAC DO J = 1, NDIM PTRY(J) = PSUM(J) * FAC1 - P(IHI,J) * FAC2 ENDDO YTRY = FUNK( PTRY ) IF ( YTRY .LT. Y(IHI) ) THEN Y(IHI) = YTRY DO J = 1, NDIM PSUM(J) = PSUM(J) - P(IHI,J) + PTRY(J) P(IHI,J) = PTRY(J) ENDDO ENDIF AMOTRY = YTRY RETURN END #if __AUGERHIT__ C-- Author : J. OEHLSCHLAEGER, D. HECK IKP KIT KARLSRUHE 07/10/2013 C======================================================================= SUBROUTINE AUGERCORES C----------------------------------------------------------------------- C (DETERMINE) AUGER CORE (POSITION)S C CORE POSITIONS ARE IN X: HALF DETECTOR DISTANCE (= 750 M) C IN Y: HALF DETECTOR ROW DISTANCE C THIS SUBROUTINE IS CALLED FROM AAMAIN. C----------------------------------------------------------------------- IMPLICIT NONE #define __AUGDETINC__ #define __CONSTAINC__ #define __BUFFSINC__ #define __RANDPAINC__ #define __RUNPARINC__ #include "corsika.h" DOUBLE PRECISION RND(2),XDISMAX,YDISMAX INTEGER I LOGICAL FIRST SAVE DATA FIRST/.TRUE./ C----------------------------------------------------------------------- CC IF ( DEBUG ) WRITE(MDEBUG,*) 'AUGERCORES' XDISMAX = DETDIS * 0.5D0 ! IN METER ROWDIS = DETDIS*0.5D0*SQRT3 ! DISTANCE BETWEEN DETECTOR ROWS (M) YDISMAX = ROWDIS * 0.5D0 ! IN METER C INITIALIZE SOBOL RANDOM NUMBER GENERATOR SOBSEQ #if __PARALLEL__ C IN CASE OF PARALLEL VERSION INITIALIZE SOBSEQ FOR EACH SLAVE FIRST = .TRUE. #endif IF ( FIRST ) THEN FIRST = .FALSE. CALL SOBSEQ( -2,RND ) C CALL RANDOM GENERATOR MANY TIMES ACC. TO FOURTH SEQUENCE C WHICH IS USED FOR CERENKOV TELESCOPES RSP. AUGERHIT SCATTERING DO I = 1, ISEED(1,4) CALL SOBSEQ( 2,RND ) ENDDO ENDIF C LIMIT NUMBER OF AUGER POSITIONS TO 20 MAUGPOS = MIN(20,MAUGPOS) EVTH(98) = REAL( MAUGPOS ) EVTH(174) = DRADIUS * 100. ! IN CM EVTH(175) = DETDIS * 100. ! IN CM EVTH(176) = 0. ! RESERVED FOR AUGERHIT && PARALLEL C CALCULATE MAUGPOS CENTERS OF SHOWERS WRITE(MONIOU,*) IF ( MAUGPOS .GE. 1 ) THEN DO I = 1, MAUGPOS CALL SOBSEQ( 2,RND ) ! PAIR OF QUASI RANDOM NUMBERS XSHCORE(I) = XDISMAX * (2.D0*RND(1) - 1.D0) ! IN METER YSHCORE(I) = YDISMAX * (2.D0*RND(2) - 1.D0) ! IN METER EVTH( 98+I) = XSHCORE(I)*1.E2 ! NOW IN CM EVTH(118+I) = YSHCORE(I)*1.E2 ! NOW IN CM C PRINT CALCULATED SCATTERED CORE POSITIONS FOR AUGER ANALYSIS WRITE(MONIOU,11) I,XSHCORE(I),YSHCORE(I), * SQRT( XSHCORE(I)**2 + YSHCORE(I)**2 ) 11 FORMAT(' AUGER CORE POS.',I3,' X=',F9.3,' M Y=',F9.3,' M', * ' R=',F9.3,' M') ENDDO ELSE DO I = 1, MAUGPS2 EVTH( 98+I) = XSHCORE(I)*1.E2 ! NOW IN CM EVTH(118+I) = YSHCORE(I)*1.E2 ! NOW IN CM C PRINT CALCULATED SCATTERED CORE POSITIONS FOR AUGER ANALYSIS WRITE(MONIOU,11) I,XSHCORE(I),YSHCORE(I), * SQRT( XSHCORE(I)**2 + YSHCORE(I)**2 ) ENDDO EVTH(98) = REAL( MAUGPS2 ) MAUGPOS = MAUGPS2 ENDIF RETURN END C-- Author : J. OEHLSCHLAEGER, D. HECK IKP KIT KARLSRUHE 07/10/2013 C======================================================================= SUBROUTINE AUGERPARTIC( ICORPOS ) C----------------------------------------------------------------------- C (TEST) AUGER PARTIC(LES) C WHETHER THEY HIT DETECTOR POSITIONS WITHIN HEXAGONS OF DRADIUS C SIDE LENGTH, I.E. PARTICLE SHOULD BE WITHIN 35 METERS TO DETECTOR C THIS IS USED TO REDUCE DISK SPACE NEEDED FOR PARTICLE DATA FILE. C THIS SUBROUTINE IS CALLED FROM OUTPT1. C ARGUMENT: C ICORPOS .EQ. 0 IF PARTICLE MISSES DETECTOR C .EQ. I IF PARTICLE HITS DETECTOR IN I-TH CORE POSITION C----------------------------------------------------------------------- IMPLICIT NONE #define __AUGDETINC__ #define __CONSTAINC__ #define __MAGANGINC__ #define __PARPARINC__ #define __RUNPARINC__ #include "corsika.h" DOUBLE PRECISION XP,YP,XP1,YP1,UP,WP,UTEST,WTEST INTEGER I,ICORPOS,IUTST,IWTST,IYTST SAVE C----------------------------------------------------------------------- ICORPOS = 0 DRADIUS = ABS( DRADIUS ) DO I = 1, MAUGPOS C CONVERT PARTICLE POSITIONS FROM CM TO METER XP1 = 1.D-2 * OUTPAR(7) YP1 = 1.D-2 * OUTPAR(8) C TAKE THE ROTATION WRT. TO MAGNETIC NORTH INTO ACCOUNT C AND SHIFT PARTICLE COORDINATES BY CORE POSITION (IN METER) XP = XP1 * COSANG + YP1 * SINANG - XSHCORE(I) YP = YP1 * COSANG - XP1 * SINANG - YSHCORE(I) C TEST PARTICLE COORDINATES ON STRIPES GOING IN EAST-WEST DIRECTION C DISTANCE BETWEEN DETECTOR ROWS: ROWDIS = DETDIS * SQRT(3.) * 0.5 IYTST = NINT( YP/ROWDIS ) YTEST = YP - ROWDIS*IYTST C CHECK DISTANCE TO MIDDLE OF STRIPES IF ( YTEST .GT. -DRADIUS .AND. YTEST .LT. DRADIUS ) THEN C TEST PARTICLE COORDINATES ON 60 DEGREES STRIPES UP = 0.5D0 * ( YP - SQRT3 * XP ) IUTST = NINT( UP/ROWDIS ) UTEST = UP - ROWDIS*IUTST IF ( UTEST .GT. -DRADIUS .AND. UTEST .LT. DRADIUS ) THEN C TEST PARTICLE COORDINATES ON -60 DEGREES STRIPES WP = 0.5D0 * ( SQRT3 * XP + YP ) IWTST = NINT( WP/ROWDIS ) WTEST = WP - ROWDIS*IWTST IF ( WTEST .GT. -DRADIUS .AND. WTEST .LT. DRADIUS ) THEN C PARTICLE FALLS ON DETECTOR HEXAGON WITH SIDE LENGTH DRADIUS ICORPOS = I ! PARTICLE BELONGS TO I-TH CORE POSITION C CALCULATE DISTANCE X_COORDIANTE TO DETECTOR CENTER IF ( FTANKSHADW ) XTEST = (2.D0 * WTEST - YTEST) / SQRT3 RETURN ENDIF ENDIF ENDIF ENDDO RETURN END #endif *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= BLOCK DATA BLOCK1 C----------------------------------------------------------------------- C INITIALIZES DATA C THIS ROUTINE IS CALLED FROM AAMAIN C----------------------------------------------------------------------- IMPLICIT NONE #define __AIRINC__ #define __ATMOSINC__ #define __ATMOS2INC__ #define __BUFFSINC__ #define __CONSTAINC__ #define __EDECAYINC__ #define __GNUPRINC__ #define __KAONSINC__ #define __MUPARTINC__ #define __NKGIINC__ #define __PAMINC__ #define __PARPARINC__ #define __PARPAEINC__ #define __RESTINC__ #define __RUNPARINC__ #define __STACKFINC__ #define __STRBARINC__ #define __VERSINC__ #if __EPOS__ || __NEXUS__ #define __NEXPARINC__ #endif #if __CERENKOV__ #define __CERTELINC__ #define __CEREN3INC__ #endif #if __CONEX__ #define __CONEXINC__ #endif #include "corsika.h" INTEGER I,J C----------------------------------------------------------------------- C AIR DATA COMPOS / 0.78479D0, 0.21052D0, 0.00469D0 / DATA PROBTA / 0.78479D0, 0.99531D0, 1.D0 / DATA AVERAW / 14.543D0 / C VALUE OF AVOGADRO REVISED JAN. 2016 BY D.H. DATA AVOGDR / 6.02214129D-4 / C ATMOS (U.S.STANDARD IS DEFAULT) DATA AATM / -186.555306D0,-94.919D0, 0.61289D0,0.D0,.01128292D0 / DATA BATM / 1222.6562D0,1144.9069D0,1305.5948D0,540.1778D0,1.D0 / DATA CATM / 994186.38D0,878153.55D0,636143.04D0,772170.16D0,1.D9 / DATA ((AATM0(I,J),I=1,5),J=0,16) * /-186.5562D0, -94.919D0 ,.61289D0 , 0.D0 , .01128292D0 , * -186.5562D0, -94.919D0 ,.61289D0 , 0.D0 , .01128292D0 , * -118.1277D0,-154.258D0 ,.4191499D0, 5.4094056D-4, .01128292D0 , * -195.837264D0,-50.4128778D0,.345594007D0,5.46207D-4,.01128292D0 , * -253.95047D0,-128.97714D0,.353207D0 , 5.526876D-4 , .01128292D0 , * -208.12899D0,-120.26179D0,.31167036D0,5.591489D-4 , .01128292D0 , * -77.875723D0,-214.96818D0,.3721868D0, 5.5309816D-4, .01128292D0 , * -242.56651D0,-103.21398D0,.3349752D0, 5.527485D-4 , .01128292D0 , * -195.34842D0,-71.997323D0,.3378142D0, 5.48224D-4 , .01128292D0 , * 0.D0 , 0.D0 , 0.D0, 0.D-4 , .01128292D0 , * 0.D0 , 0.D0 , 0.D0, 0.D-4 , .01128292D0 , * -137.656D0, -37.9610D0, .222659D0, -6.16201D-4 ,.00207722D0 , * -163.331D0, -65.3713D0, .402903D0, -4.79198D-4 ,.00188667D0 , * -142.801D0, -70.1538D0, 1.14855D0, -9.10269D-4 ,.00152236D0 , * -128.601D0, -39.5548D0, 1.13088D0, -26.4960D-4 ,.00192534D0 , * -113.139D0, -79.0635D0, -54.3888D0, 0.D0 ,.4210330D-2 , * -59.0293D0, -21.5794D0, -7.14839D0, 0.D0 ,.1901750D-3 / DATA ((AATM0(I,J),I=1,5),J=17,25) */-149.801663D0,-57.932486D0,.63631894D0,4.35453690D-4,.01128292D0, !US * -136.72575606,-31.636643044,1.8890234035,3.92018679839D-4, * .01128292, !Jan * -137.25655862,-31.793978896,2.0616227547,4.12430622892D-4, * .01128292, !Feb * -132.36885162,-29.077046629,2.090501509 ,4.35343379252D-4, * .01128292, !March * -129.9930412 ,-21.847248438,1.5211136484,3.95590551213D-4, * .01128292, !Apr * -125.11468467,-14.591235621,.93641128677,3.24755909854D-4, * .01128292, !May * -126.17178851,-7.7289852811,.81676828638,3.19476768915D-4, * .01128292, !June * -126.17216789,-8.6182537514,.74177836911,2.93507020973D-4, * .01128292, !July * -123.27936204,-10.051493041,.84187346153,3.24225467594D-4, * .01128292/ !Aug DATA ((AATM0(I,J),I=1,5),J=26,29) */-126.94494665,-9.5556536981,.74939405052,2.98231169610D-4, * .01128292, !Sep * -133.13151125,-13.973209265,0.8378263431,3.11174217600D-4, * .01128292, !Oct * -134.72208165,-18.172382908,1.1159806845,3.52170255153D-4, * .01128292, !Nov * -135.40825209,-22.830409026,1.4223453493,3.75129217743D-4, * .01128292/ !Dec DATA ((BATM0(I,J),I=1,5),J=0,16) * / 1222.6562D0, 1144.9069D0, 1305.5948D0, 540.1778D0, 1.D0 , * 1222.6562D0, 1144.9069D0, 1305.5948D0, 540.1778D0, 1.D0 , * 1173.9861D0, 1205.7625D0, 1386.7807D0, 555.8935D0, 1.D0 , * 1240.48D0 , 1117.85D0 , 1210.9D0 , 608.2128D0, 1.D0 , * 1285.2782D0, 1173.1616D0, 1320.4561D0, 680.6803D0, 1.D0 , * 1251.474D0 , 1173.321D0 , 1307.826D0 , 763.1139D0, 1.D0 , * 1103.3362D0, 1226.5761D0, 1382.6933D0, 685.6073D0, 1.D0 , * 1262.7013D0, 1139.0249D0, 1270.2886D0, 681.4061D0, 1.D0 , * 1210.4D0 , 1103.8629D0, 1215.3545D0, 629.7611D0, 1.D0 , * 0.D0 , 0.D0 , 0.D0 , 0.D0 , 1.D0 , * 0.D0 , 0.D0 , 0.D0 , 0.D0 , 1.D0 , * 1130.74D0, 1052.05D0, 1137.21D0, 442.512D0, 1.D0 , * 1183.70D0, 1108.06D0, 1424.02D0, 207.595D0, 1.D0 , * 1177.19D0, 1125.11D0, 1304.77D0, 433.823D0, 1.D0 , * 1139.99D0, 1073.82D0, 1052.96D0, 492.503D0, 1.D0 , * 1133.10D0, 1101.20D0, 1085.00D0, 1098.00D0, 1.D0 , * 1079.00D0, 1071.90D0, 1182.00D0, 1647.10D0, 1.D0 / DATA ((BATM0(I,J),I=1,5),J=17,29) * /1183.6071D0 , 1143.0425D0 ,1322.9748D0, 655.67307D0, 1.D0 , !US * 1174.8298334, 1204.8233453,1637.7703583,735.96095023,1.D0 , !Jan * 1176.0907565, 1197.8951104,1646.4616955,755.18728657,1.D0 , !Feb * 1172.6227784, 1215.3964677,1617.0099282,769.51991638,1.D0 , !March * 1172.3291878, 1250.2922774,1542.6248413,713.1008285 ,1.D0 , !Apr * 1169.9511302, 1277.6768488,1493.5303781,617.9660747 ,1.D0 , !May * 1171.0916276, 1295.3516434,1455.3009344,595.11713507,1.D0 , !June * 1172.7340688, 1258.9180079,1450.0537141,583.07727715,1.D0 , !July * 1169.763036 , 1251.0219808,1436.6499372,627.42169844,1.D0 , !Aug * 1174.8676453, 1251.5588529,1440.8257549,606.31473165,1.D0 , !Sep * 1176.9833473, 1244.234531 ,1464.0120855,622.11207419,1.D0 , !Oct * 1175.7737972, 1238.9538504,1505.1614366,670.64752105,1.D0 , !Nov * 1174.644971 , 1227.2753683,1585.7130562,691.23389637,1.D0 / !Dec DATA ((CATM0(I,J),I=1,5),J=0,16) * / 994186.38D0, 878153.55D0, 636143.04D0, 772170.16D0, 1.D9 , * 994186.38D0, 878153.55D0, 636143.04D0, 772170.16D0, 1.D9 , * 919546.D0 , 963267.92D0, 614315.D0 , 739059.6D0 , 1.D9 , * 933697.D0 , 765229.D0 , 636790.D0 , 733793.8D0 , 1.D9 , * 1088310.D0 , 935485.D0 , 635137.D0 , 727312.6D0 , 1.D9 , * 1032310.D0 , 925528.D0 , 645330.D0 , 720851.4D0 , 1.D9 , * 932077.D0 ,1109960.D0 , 630217.D0 , 726901.3D0 , 1.D9 , * 1059360.D0 , 888814.D0 , 639902.D0 , 727251.8D0 , 1.D9 , * 970276.D0 , 820946.D0 , 639074.D0 , 731776.5D0 , 1.D9 , * 0.D0 , 0.D0 , 0.D0 , 0.D0 , 1.D9 , * 0.D0 , 0.D0 , 0.D0 , 0.D0 , 1.D9 , * 867358.D0 , 741208.D0 , 633846.D0 , 759850.D0, 5.4303203D9, * 875221.D0 , 753213.D0 , 545846.D0 , 793043.D0, 5.9787908D9, * 861745.D0 , 765925.D0 , 581351.D0 , 775155.D0, 7.4095699D9, * 861913.D0 , 744955.D0 , 675928.D0 , 829627.D0, 5.8587010D9, * 861730.D0 , 826340.D0 , 790950.D0 , 682800.D0, 2.6798156D9, * 764170.D0 , 699910.D0 , 635650.D0 , 551010.D0, 59.329575D9/ DATA ((CATM0(I,J),I=1,5),J=17,29) * / 954248.34D0 ,800005.34D0 ,629568.93D0 ,737521.77D0 ,1.D9 , !US * 982815.95248,754029.87759,594416.83822,733974.36972,1.D9 , !Jan * 981369.6125 ,756657.65383,592969.89671,731345.88332,1.D9 , !Feb * 972654.0563 ,742769.2171 ,595342.19851,728921.61954,1.D9 , !March * 962396.5521 ,711452.06673,603480.61835,735460.83741,1.D9 , !Apr * 947742.88769,685089.57509,609640.01932,747555.95526,1.D9 , !May * 940102.98842,661697.57543,612702.0632 ,749976.26832,1.D9 , !June * 934649.58886,672975.82513,614888.52458,752631.28536,1.D9 , !July * 931569.97625,678861.75136,617363.34491,746739.16141,1.D9 , !Aug * 936953.91919,678906.60516,618132.60561,750154.67709,1.D9 , !Sep * 954151.404 ,692708.89816,615439.43936,747969.08133,1.D9 , !Oct * 964877.07766,706199.57502,610242.24564,741412.74548,1.D9 , !Nov * 973884.44361,723759.74682,600308.13983,738390.20525,1.D9 / !Dec DATA (LAYNO(J), J=0,29) * / 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, 2, 3, 4, 5, 6, 7, * 8, 9, 10, 11, 12, 13, 14, 15, 16/ DATA (HLAY(I),I=1,5) * / -5779.5D2 , 4.D5 , 1.D6 , 4.D6, 1.D7 / DATA ((HLAY0(I,J),I=1,5),J=0,16) * / -5779.5D2 , 4.D5 , 1.D6 , 4.D6 , 1.D7 , * -5779.5D2 , 4.D5 , 1.D6 , 4.D6 , 1.D7 , * -5.D5 , 2.66667D5 , 5.33333D5 , 8.D5 , 1.D7 ,!SPolJan * -5.D5 , 6.66667D5 ,13.33333D5 , 20.D5 , 1.D7 ,!SPolAug * -5.D5 , 7.0D5 , 11.4D5 , 37.0D5, 1.D7 ,!US * -5779.5D2, 9.4D5 , 15.3D5 , 31.6D5, 1.D7 ,!Jan * -5779.5D2, 9.2D5 , 15.4D5 , 31.0D5, 1.D7 ,!Feb * -5779.5D2, 9.6D5 , 15.2D5 , 30.7D5, 1.D7 ,!March * -5779.5D2, 10.0D5 , 14.9D5 , 32.6D5, 1.D7 ,!Apr * -5779.5D2, 10.2D5 , 15.1D5 , 35.9D5, 1.D7 ,!May * -5779.5D2, 10.1D5 , 16.0D5 , 36.7D5, 1.D7 ,!June * -5779.5D2, 9.6D5 , 16.5D5 , 37.4D5, 1.D7 ,!July * -5779.5D2, 9.6D5 , 15.9D5 , 36.3D5, 1.D7 ,!Aug * -5779.5D2, 9.5D5 , 16.2D5 , 37.2D5, 1.D7 ,!Sep * -5779.5D2, 9.5D5 , 15.5D5 , 36.5D5, 1.D7 ,!Oct * -5779.5D2, 9.6D5 , 15.3D5 , 34.6D5, 1.D7 ,!Nov * -5779.5D2, 9.6D5 , 15.6D5 , 33.3D5, 1.D7 /!Dec #if __CERENKOV__ C CEREN3 DATA CERCNT / 0.D0 / #endif C CONSTA DATA PI / 3.141592653589793D0 / DATA PI2 / 6.283185307179586D0 / DATA OB3 / 0.333333333333333D0 / DATA TB3 / 0.666666666666666D0 / C ENEPER IS CALCULATED IN START: ENEPER = EXP(1.D0) C DATA FOR MUPART: CUTOFF FOR BREMSSTRAHLUNG AT 3 MEV DATA BCUT /0.003D0/ C DATA FOR REST: AVERAGE ATOMIC WEIGHT, NEUTRON CONTENTS OF N,O,AR DATA TAR / 14.6D0 /, CONTNE / 0.5D0, 0.5D0, 0.55D0 /, LIT / 1 / C KAON CONSTANTS C REVISED NOV. 2004 BY D. HECK DATA CKA / 0.D0 , 0.1D0, 0.D0 , 0.D0, 0.D0 , * 0.D0 , 0.25D0, 0.5D0, 0.75D0, 1.D0 , !10 * 0.5D0, 0.2D0, 0.D0 , 0.D0 , 149.6D0, * 149.6D0,0.236D0, 0.206D0, 0.135D0, 0.222D0, !20 * 0.5D0, 0.D0 , 0.6356D0,0.692762D0, 0.8742D0, * 0.6783D0,.4069D0, 0.D0 , 0.D0 , 0.D0 , !30 * 0.D0 , 0.D0 , 0.D0 , 0.D0 , 1.D0 , * 1.0D5, 0.D0 , 0.D0 , 0.D0 , 0.D0 , !40 * 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , * 0.D0 ,0.8423D0, 0.8982D0, 0.9489D0, 0.9824D0, !50 * -0.2154D0, 0.012D0,-0.0101D0, 1.27D0, 0.638D0, * 0.057D0, 0.D0 , 1.84D0, 0.D0 , 1.D0 , !60 * 0.678D0, 0.076D0, 0.0099D0, 2.22D0, 0.0298D0, * 0.D0 ,1.288D-2, 0.0296D0, 1.96D-2, 1.194D-2, !70 * 0.0282D0, 0.D0 , 1.310D-2, 0.0282D0, 0.0138D0, * 1.241D-2, 0.D0 , 0.D0 , 0.D0 , 0.D0 / C DATA FOR ETA DECAY C REVISED NOV. 2004 BY D. HECK DATA CETA / 0.3972D0, 0.7265D0, 0.9575D0, 0.09D-2, 2.07D0 / C DATA FOR STRANGE BARYON DECAY C REVISED NOV. 2004 BY D. HECK DATA CSTRBA / 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.6409D0, * 0.5163D0 , 0.D0 , 0.D0 , 0.D0 , 0.678D0 , * 0.914D0 / C PARPAR C REVISED NOV. 2004 BY D. HECK DATA C /6371315.D2, 6.0D5, 20.0D5, 0.D0 , 0.D0 , * 0.D0 , 0.D0 , 0.D0 , 2.5D0, 2.07D0, !10 * 8.2D0, 0.1D0, 0.D0 , 0.D0 , 0.D0 , * 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , !20 * 37.7D0, 1.532873D-4, 9.386417D0, 2.D-3, 29.9792458D9, * 1.D0 , 0.D0 , 1.57D0, 0.D0 , 0.021D0, !30 * 0.D0 , 0.D0 , 0.D0 , 2.0D1, 0.D0 , * 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , !40 * 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , * 0.D0 , 0.D0 , 0.D0 , 0.D0 , 137.0359991D0 /!50 C RUNPAR , STACKF DATA MONIIN / 5 /, MONIOU / 6 /, MPATAP / 90 /, MEXST / 96 /, * MDEBUG / 6 /, NUCNUC / 11 /, MDBASE / 45 /, MTABOUT / 46 /, * MLONGOUT / 48 / #if __PARALLEL__ * ,MEXSTJ / 95 / * ,MPACUT / 92 /, MPAINP / 93 /, MPAJOB / 94 / #endif #if __INTTEST__ * ,LUNPLT / 54 / #endif c#if __ANAHIST__ || __AUGERHIST__ c * ,LUNHST / 53 / c#endif * ,LSTCK / 23 / #if !__STACKIN__ && !__CONEX__ * ,LSTCK2 / 24 / #endif #if __CERENKOV__ c * ,MCETAP / 91 / #if __CEFFIC__ * ,MCERABS / 20 /, MCERQEF / 21 /, MCERMIR / 22 / #endif #endif #if __CONEX__ * ,INLUN / 38 / #endif #if __EPOS__ || __NEXUS__ DATA NEXPRM / 97 / #endif C UNRELEASABLE ENERGY (REST MASS) FOR ENERGY DEPOSIT C THE REST MASSES FOR NUCLEI ARE SET IN PAMAF DATA RESTMS/ 0., -.511D-3, .511D-3, 0., .105658 , * .105658 , 0., 0., 0., 0., ! 10 * 0., 0., .9395653 , .938272 , -.938272 , * 0., 0., .938 , .938 , .938 , ! 20 * .938 , .938 , .938 , .938 ,-.9395653 , * -.938 , -.938 , -.938 , -.938 , -.938 , ! 30 * -.938 , -.938 , 0., 0., 0., * 0., 0., 0., 0., 0., ! 40 * 1D9, 0., 0., 0., 0., * 0., 0., 0., 0., 0., ! 50 * 0., 0., 0., .938 , .938 , * .938 , .938 , -.938 , -.938 , -.938 , ! 60 * -.938 , 0., 0., 0., 0., * 0., 0., 0., 0., 0., ! 70 * 0., 0., 0., 0., 0., * 5925*0.D0/ C GNUPR C NITROGEN TARGET 14 DATA ((SE14(I,J),I=1,3),J=1,14) * / 0.472000D+00,-0.426710D-02, 0.726439D-04, * 0.230324D+00,-0.989733D-03,-0.807077D-05, * 0.138623D+00, 0.609624D-03,-0.401675D-04, * 0.827139D-01, 0.135103D-02,-0.360236D-04, * 0.445693D-01, 0.137582D-02,-0.137674D-04, * 0.206106D-01, 0.998620D-03, 0.422867D-05, * 0.792756D-02, 0.559858D-03, 0.957875D-05, * 0.247793D-02, 0.247480D-03, 0.701650D-05, * 0.615535D-03, 0.860096D-04, 0.324410D-05, * 0.118279D-03, 0.230732D-04, 0.104282D-05, * 0.169210D-04, 0.461424D-05, 0.235175D-06, * 0.169481D-05, 0.647634D-06, 0.358189D-07, * 0.105988D-06, 0.568994D-07, 0.332920D-08, * 0.311374D-08, 0.235385D-08, 0.143213D-09/ C OXYGEN TARGET 16 DATA ((SE16(I,J), I=1,3),J=1,16) * /0.475002D+00,-0.434401D-02, 0.734217D-04, * 0.230261D+00,-0.966152D-03,-0.982228D-05, * 0.137372D+00, 0.642454D-03,-0.408490D-04, * 0.813380D-01, 0.135241D-02,-0.354835D-04, * 0.437870D-01, 0.135776D-02,-0.134429D-04, * 0.204919D-01, 0.988538D-03, 0.398723D-05, * 0.812995D-02, 0.567070D-03, 0.942943D-05, * 0.269031D-02, 0.263160D-03, 0.728079D-05, * 0.732711D-03, 0.993722D-04, 0.366933D-05, * 0.161940D-03, 0.303662D-04, 0.134776D-05, * 0.285325D-04, 0.740356D-05, 0.371648D-06, * 0.390910D-05, 0.140655D-05, 0.768260D-07, * 0.401145D-06, 0.200620D-06, 0.116200D-07, * 0.290010D-07, 0.202033D-07, 0.121929D-08, * 0.131709D-08, 0.128046D-08, 0.795482D-10, * 0.282645D-10, 0.384068D-10, 0.243535D-11/ C ARGON TARGET 40 DATA ((SE40(I,J),I=1,3),J=1,18) * / 0.318084D+00,-0.352566D-02, 0.829469D-04, * 0.193581D+00,-0.238538D-02, 0.404919D-04, * 0.148699D+00,-0.118791D-02,-0.130378D-04, * 0.117201D+00, 0.966097D-04,-0.536044D-04, * 0.876737D-01, 0.106482D-02,-0.612882D-04, * 0.600279D-01, 0.150343D-02,-0.412273D-04, * 0.370180D-01, 0.147347D-02,-0.130096D-04, * 0.204422D-01, 0.117625D-02, 0.743960D-05, * 0.101003D-01, 0.807913D-03, 0.155153D-04, * 0.447163D-02, 0.489622D-03, 0.146804D-04, * 0.177806D-02, 0.265260D-03, 0.102802D-04, * 0.636671D-03, 0.129412D-03, 0.591434D-05, * 0.205809D-03, 0.571042D-04, 0.291674D-05, * 0.601981D-04, 0.228546D-04, 0.126074D-05, * 0.159631D-04, 0.831226D-05, 0.484001D-06, * 0.384379D-05, 0.275100D-05, 0.166440D-06, * 0.841490D-06, 0.829259D-06, 0.515615D-07, * 0.167633D-06, 0.227810D-06, 0.144446D-07/ DATA((SE40(I,J),I=1,3),J=19,36) * /0.304029D-07, 0.570494D-07, 0.366843D-08, * 0.502077D-08, 0.130224D-07, 0.845876D-09, * 0.754786D-09, 0.270844D-08, 0.177211D-09, * 0.103229D-09, 0.512862D-09, 0.337323D-10, * 0.128308D-10, 0.883149D-10, 0.583066D-11, * 0.144721D-11, 0.138082D-10, 0.914113D-12, * 0.147837D-12, 0.195621D-11, 0.129757D-12, * 0.136429D-13, 0.250465D-12, 0.166371D-13, * 0.113379D-14, 0.288894D-13, 0.192092D-14, * 0.845213D-16, 0.299003D-14, 0.198959D-15, * 0.562496D-17, 0.276346D-15, 0.183981D-16, * 0.332222D-18, 0.226723D-16, 0.151001D-17, * 0.172872D-19, 0.163915D-17, 0.109200D-18, * 0.785321D-21, 0.103480D-18, 0.689517D-20, * 0.307886D-22, 0.563885D-20, 0.375787D-21, * 0.102630D-23, 0.261299D-21, 0.174154D-22, * 0.285163D-25, 0.100944D-22, 0.672832D-24, * 0.642589D-27, 0.316302D-24, 0.210839D-25/ DATA((SE40(I,J),I=1,3),J=37,40) * /0.112817D-28, 0.772286D-26, 0.514807D-27, * 0.144773D-30, 0.137838D-27, 0.918858D-29, * 0.120779D-32, 0.159956D-29, 0.106632D-30, * 0.491605D-35, 0.905709D-32, 0.603784D-33/ C VERSION NUMBER AND DATE OF RELEASE DATA VERNUM / __CVERSION__ / DATA MVDATE / __ICDATE__ / C -YYYYMMDD- DATA VERDAT / __CDATE__ / C ----+----+----+--- END *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE BOX2 C----------------------------------------------------------------------- C DETERMINES POINT OF INTERACTION OR DECAY FOR ANY PARTICLE C HEAVY PRIMARIES AND STRANGE BARYONS INCLUDED C ANNIHILATION CROSS-SECTION INCLUDED C PRECISE MEAN FREE PATH FOR DECAYING PARTICLES C HAS INTERACTION LENGTH STATISTICS INCLUDED C THIS SUBROUTINE IS CALLED FROM AAMAIN. C----------------------------------------------------------------------- IMPLICIT NONE #define __AIRINC__ #define __ATMOS2INC__ #define __CHISTAINC__ #define __CONSTAINC__ #define __KAONSINC__ #define __MUPARTINC__ #define __NCSNCSINC__ #define __OBSPARINC__ #define __PAMINC__ #define __PARPARINC__ #define __PARPAEINC__ #define __RANDPAINC__ #define __RESTINC__ #define __RUNPARINC__ #define __SIGMINC__ #define __SIGMUINC__ #define __STRBARINC__ #if __DPMJET__ #define __DPMJETINC__ #endif #if __EPOS__ || __NEXUS__ #define __NEXUSINC__ #endif #if __QGSJET__ #define __QGSCINC__ #endif #if __SIBYLL__ #define __SIBYLCINC__ #endif #if __VENUS__ #define __VENUSINC__ #endif #if __INTTEST__ #define __TSTINTINC__ #endif #include "corsika.h" DOUBLE PRECISION CHIBRM,CHIPRP,CHIINT,CHINUC,CHI1,CHI2,CHI3,COR1, * DH,EKIN,ELAB,ELABT,PLAB,PLABLG,SIG45,S45SQ,S4530 DOUBLE PRECISION HEIGH,THICK,CBRSGM,CNUSGM,CPRSGM INTEGER I,IA,IHY,IP,KA,MU,NI,NU #if __CURVED__ DOUBLE PRECISION HNEW #if __NEUTRINO__ || __NUPRIM__ DOUBLE PRECISION COSTPA #endif #else DOUBLE PRECISION HDEC #endif SAVE #if __GHEISHAD__ DOUBLE PRECISION CGHSIG EXTERNAL CGHSIG #endif EXTERNAL HEIGH,THICK,CBRSGM,CNUSGM,CPRSGM C----------------------------------------------------------------------- #if __THIN__ IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=0,9),WEIGHT 444 FORMAT(' BOX2 : CURPAR=',1P,11E11.3) #else IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=0,9) 444 FORMAT(' BOX2 : CURPAR=',1P,10E11.3) #endif ITYPE = INT( CURPAR(0) ) #if __NEUTRINO__ || __NUPRIM__ C----------------------------------------------------------------------- C PRIMARY NEUTRINOS IF ( ( ITYPE .GE. 66 .AND. ITYPE .LE. 69 ) #if __CHARM__ || __TAULEP__ * .OR. ITYPE .EQ. 133 .OR. ITYPE .EQ. 134 #endif * ) THEN BETA = 1.D0 THICKH = THICK( H ) #if __NUPRIM__ IF ( FIRSTI ) THEN IF ( ITYPE .EQ. 66 .OR. ITYPE .EQ. 68 * .OR. ITYPE .EQ. 133 ) THEN C SIGMA IS ENERGY DEPENDENT NEUTRINO-NUCLEON CROSS-SECTION C IN MILLIBARN SIGMA = 7.84D-9 * GAMMA**.363D0 ELSEIF ( ITYPE .EQ. 67 .OR. ITYPE .EQ. 69 * .OR. ITYPE .EQ. 134 ) THEN C SIGMA IS ENERGY DEPENDENT ANTINEUTRINO-NUCLEON CROSS-SECTION C IN MILLIBARN SIGMA = 7.80D-9 * GAMMA**.363D0 ENDIF C INELASTIC CROSS-SECTIONS OF AIR c!!! for the moment it is equal to sigma SIGAIR = SIGMA CDH 25.04.2003 CDH ASSUME THE CROSS SECTION SCALES WITH THE AVERAGE NUCLEON NUMBER SIGAIR = SIGAIR * 14.56D0 CDH assume 10 mb cross section CDH sigma = 10.d0 !26.12.2014 dh CDH SIGAIR = SIGMA !26.12.2014 dh IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2 : SIGMA,SIGAIR', * SNGL(SIGMA),SNGL(SIGAIR) C MEAN FREE PATH FROM MOLECULAR WEIGHT, AVOGADRO''S CONSTANT AND SIGMA CALL RMMARD( RD,1,1 ) CHI = -LOG( RD(1) ) * AVERAW / (AVOGDR * SIGAIR) #if __UPWARD__ IF ( COSTHE .LT. 0.D0 ) THEN CHI = MIN( CHI, -THICKH/COSTHE ) ENDIF #endif FDECAY = .FALSE. CHI = MAX( 0.D0, CHI ) IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2 : ITYPE,RD(1),CHI=', * ITYPE,RD(1),SNGL(CHI) C INTERACTION LENGTH STATISTICS CHI = MIN( 2.D9, CHI ) NU = 1.D0 + CHI * 0.1D0 NU = MIN( NU , 123 ) INECHI( NU) = INECHI( NU) + 1 INECHI(124) = INECHI(124) + 1 ELSE #endif C SECONDARY NEUTRINOS PENETRATE THROUGH DOWN BELOW LOWEST OBSERVATION LEVEL #if __CURVED__ C WE LOOK FOR THE GEOMETRICAL DISTANCE COR1 TO DETECTOR HEIGHT C COSTPA IS COS OF ANGLE BETWEEN PARTICLE AND VERTICAL ON OBSERVATION LEVEL COSTPA = COSTEA*COSTHE - SQRT( (1.D0-COSTEA)*(1.D0+COSTEA) * * (1.D0-COSTHE)*(1.D0+COSTHE) ) #if __UPWARD__ C LIMITING ANGLE ABOVE WHICH THE NEUTRINO WILL HIT GROUND AND NOT BECOME C SKIMMING IF ( COSTPA .GT. (C(1)+OBSLEV(NOBSLV))/(C(1)+CURPAR(5)) ) THEN #else IF ( COSTPA .GE. C(29) ) THEN #endif C NEUTRINO IS MOVING DOWNWARD C PROPAGATE NEUTRINO 100000 M BELOW OBSERVATION LEVEL TO BE SURE THAT C IT PASSES THE OBSERVATION LEVEL COR1 = (HAPP - OBSLEV(1) + 1.D7) / COSTPA CALL NRANGC( COR1 ) CHI = MAX( CHI, 8.D4 ) ELSE C NEUTRINO IS MOVING UPWARD OR HORIZONTALLY C WE TAKE THE MAXIMUM FOR SKIMMING INCIDENCE WHICH IS 1204 KM C RSP. 36842 G/CM^2. WE USE DOUBLE OF THOSE VALUES FOR SKIMMING INCIDENCE C STARTING IN HEIGH ALTITUDE. COR1 = 3000.D5 CHI = 8.D4 ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) 'COSTPA=',COSTPA,' COR1=',COR1 * ,' CHI=',CHI FDECAY = .FALSE. #else C SELECT CHI LARGE ENOUGH TO PASS FOR SURE LOWEST OBSERVATION LEVEL #if __UPWARD__ IF ( COSTHE .LT. 0.D0 ) THEN CHI = ( THCKOB(NOBSLV) - 1.D2 - THICKH ) / COSTHE CHI = MAX( CHI, -THICKH/COSTHE ) ENDIF #else CHI = ( THCKOB(NOBSLV) + 1.D2 - THICKH ) / COSTHE #endif #endif CHI = MAX( 0.D0, CHI ) IF (DEBUG) WRITE(MDEBUG,*) 'BOX2 : ITYPE,CHI=',ITYPE,SNGL(CHI) C INTERACTION LENGTH STATISTICS C FILL IN THE LAST BIN AS INTERACTION LENGTH IS QUASI INFINITE INECHI(123) = INECHI(123) + 1 INECHI(124) = INECHI(124) + 1 #if __NUPRIM__ ENDIF #endif RETURN ENDIF #endif C----------------------------------------------------------------------- C GAMMAS AND ELECTRONS ARE TREATED SEPARATELY (SEE BOX3) IF ( ITYPE .LE. 3 ) THEN CHI = 0.D0 RETURN ENDIF C----------------------------------------------------------------------- C RESONANCES ARE TREATED SEPARATELY (SEE BOX3) IF ( ITYPE .GE. 50 .AND. ITYPE .LE. 65 ) THEN CHI = 0.D0 C BETA DEFINED IN RESDEC RETURN ENDIF BETA = SQRT( (GAMMA-1.D0)*(GAMMA+1.D0) ) / GAMMA THICKH = THICK( H ) ELAB = PAMA(ITYPE) * GAMMA #if __CONEX__ C----------------------------------------------------------------------- C EXOTICS ARE ALREADY AT GROUND IF ( ITYPE .GE. 41 .AND. ITYPE .LE. 43 ) THEN CHI = 100000.D0 RETURN ENDIF #endif C----------------------------------------------------------------------- C MU+, MU-, TAU+, TAU- DECAYS AFTER ITS LIFE TIME C MUON/TAU INTERACTS BY BREMSSTRAHLUNG, PAIR PRODUCTION OR NUCLEAR INT. IF ( ITYPE .EQ. 5 .OR. ITYPE .EQ. 6 .OR. * ITYPE .EQ. 131 .OR. ITYPE .EQ. 132 ) THEN CALL RMMARD( RD,4,1 ) IF ( ITYPE .LE. 6 ) THEN C IT IS A MUON COR1 = (-LOG( RD(1) )) * C(25) * DECTIM(5) MT = 1 ELSE #if __CHARM__ || __TAULEP__ C IT IS A TAU LEPTON COR1 = (-LOG( RD(1) )) * C(25) * DECTIM(131) MT = 2 #else WRITE(MONIOU,*)'BOX2 : NO TAU LEPTONS POSSIBLE' WRITE(MONIOU,*)' WITHOUT CHARM OR TAULEP OPTION' STOP #endif ENDIF C DETERMINE RANGE FOR MUON/TAU DECAY #if __CURVED__ CALL PRANGC( COR1,.TRUE.,HNEW ) DH = MAX( 0.D0, H - HNEW ) #else CALL PRANGE( COR1 ) CHI = MAX( 0.D0, CHI ) #if __UPWARD__ DH = MAX( 0.D0, H - HEIGH( MAX( THICKH+CHI*COSTHE, 0.D0 ) ) ) #else DH = MAX( 0.D0, H - HEIGH( THICKH + CHI*COSTHE ) ) #endif #endif cdh elongate the muon range cdh chi = chi * 100.d0 cdh IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2 : ITYPE,RD(1),CHIDEC=', * ITYPE,SNGL(RD(1)),SNGL(CHI) IF ( GAMMA .LE. 5.D0 ) THEN C AT LOW ENERGIES ONLY DECAY IS CONSIDERED FDECAY = .TRUE. ELSE C CALCULATE MUON/TAU BREMSSTRAHLUNG CROSS-SECTION FOR AIR (MILLIBARN) FRABTN = COMPOS(1) * CBRSGM( ELAB,1,MT ) FRBTNO = FRABTN + COMPOS(2) * CBRSGM( ELAB,2,MT ) SIGBRM = FRBTNO + COMPOS(3) * CBRSGM( ELAB,3,MT ) IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2 : SIGBRM=',SNGL(SIGBRM) C CALCULATE MEAN FREE PATH FOR BREMSSTRAHLUNG CHIBRM = (-LOG( RD(2) )) * AVERAW / (AVOGDR * SIGBRM) IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2 : ITYPE,RD(2),CHIBRM=', * ITYPE,SNGL(RD(2)),SNGL(CHIBRM) CHI1 = MIN( CHIBRM, CHI ) C CALCULATE MUON/TAU PAIR PRODUCTION CROSS-SECTION FOR AIR (MILLIBARN) FRAPTN = COMPOS(1) * CPRSGM( ELAB,1,MT ) FRPTNO = FRAPTN + COMPOS(2) * CPRSGM( ELAB,2,MT ) SIGPRM = FRPTNO + COMPOS(3) * CPRSGM( ELAB,3,MT ) IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2 : SIGPRM=',SNGL(SIGPRM) C CALCULATE MEAN FREE PATH FOR PAIR PRODUCTION CHIPRP = (-LOG( RD(3) )) * AVERAW / (AVOGDR * SIGPRM) IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2 : ITYPE,RD(3),CHIPRP=', * ITYPE,SNGL(RD(3)),SNGL(CHIPRP) CHI2 = MIN( CHIPRP, CHI1 ) C CALCULATE MUON NUCLEAR INTERACTION CROSS-SECTION FOR AIR (MILLIBARN) FRANTN = COMPOS(1) * CNUSGM( ELAB,1,MT ) FRNTNO = FRANTN + COMPOS(2) * CNUSGM( ELAB,2,MT ) SIGNUC = FRNTNO + COMPOS(3) * CNUSGM( ELAB,3,MT ) IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2 : SIGNUC=',SNGL(SIGNUC) C CALCULATE MEAN FREE PATH FOR NUCLEAR INTERACTION CHINUC = (-LOG( RD(4) )) * AVERAW / (AVOGDR * SIGNUC) IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2 : ITYPE,RD(4),CHINUC=', * ITYPE,SNGL(RD(4)),CHINUC CHI3 = MIN( CHINUC, CHI2 ) C SET FLAGS ACCORDING THE EXPECTED INTERACTION AND SELECT TARGET NUCLEUS IF ( CHI3 .EQ. CHI ) THEN FDECAY = .TRUE. FMUNUC = .FALSE. C NO TARGET SELECTION FOR MUON/TAU DECAY ELSEIF ( CHI3 .EQ. CHIPRP ) THEN FDECAY = .FALSE. FMUNUC = .FALSE. FMUBRM = .FALSE. C TARGET IS CHOSEN AT RANDOM FOR MUON/TAU PAIR PRODUCTION CALL RMMARD( RD,1,1 ) IF ( RD(1)*SIGPRM .LE. FRAPTN ) THEN C PAIR PRODUCTION WITH NITROGEN LIT = 1 TAR = 14.D0 ELSEIF ( RD(1)*SIGPRM .LE. FRPTNO ) THEN C PAIR PRODUCTION WITH OXYGEN LIT = 2 TAR = 16.D0 ELSE C PAIR PRODUCTION WITH ARGON LIT = 3 TAR = 40.D0 ENDIF ELSEIF ( CHI3 .EQ. CHIBRM ) THEN FDECAY = .FALSE. FMUNUC = .FALSE. FMUBRM = .TRUE. C TARGET IS CHOSEN AT RANDOM FOR MUON/TAU BREMSSTRAHLUNG CALL RMMARD( RD,1,1 ) IF ( RD(1)*SIGBRM .LE. FRABTN ) THEN C BREMSSTRAHLUNG WITH NITROGEN LIT = 1 TAR = 14.D0 ELSEIF ( RD(1)*SIGBRM .LE. FRBTNO ) THEN C BREMSSTRAHLUNG WITH OXYGEN LIT = 2 TAR = 16.D0 ELSE C BREMSSTRAHLUNG WITH ARGON LIT = 3 TAR = 40.D0 ENDIF ELSEIF ( CHI3 .EQ. CHINUC ) THEN FDECAY = .FALSE. FMUNUC = .TRUE. C TARGET IS CHOSEN AT RANDOM FOR MUON/TAU NUCLEAR INTERACTION CALL RMMARD( RD,1,1 ) IF ( RD(1)*SIGNUC .LE. FRANTN ) THEN C NUCLEAR INTERACTION WITH NITROGEN LIT = 1 TAR = 14.D0 ELSEIF ( RD(1)*SIGNUC .LE. FRNTNO ) THEN C NUCLEAR INTERACTION WITH OXYGEN LIT = 2 TAR = 16.D0 ELSE C NUCLEAR INTERACTION WITH ARGON LIT = 3 TAR = 40.D0 ENDIF ENDIF CHI = CHI3 ENDIF IF ( MT .EQ. 2 ) RETURN C DECAY LENGTH STATISTICS (ONLY FOR MUONS) IF ( COSTHE .NE. 0.D0 ) THEN MU = 1.D0 + ABS( DH * 1.D-4 / COSTHE ) ELSE MU = 123 ENDIF MU = MIN( MU, 123 ) IMUCHI( MU) = IMUCHI( MU) + 1 IMUCHI(124) = IMUCHI(124) + 1 C----------------------------------------------------------------------- C CHARGED PIONS ELSEIF ( ITYPE .EQ. 8 .OR. ITYPE .EQ. 9 ) THEN PLAB = ELAB * BETA C CALCULATION OF CROSS-SECTION IN THE LOW ENERGY MODEL IF ( ELAB .LE. HILOELB ) THEN EKIN = ELAB - PAMA(ITYPE) USELOW = .TRUE. #if __FLUKA__ CALL FLUSIG( EKIN,PLAB ) FFLUSIG = .TRUE. ELSE FFLUSIG = .FALSE. #elif __GHEISHAD__ SIGAIR = CGHSIG( PLAB,EKIN,ITYPE ) GHESIG = .TRUE. ELSE #elif __URQMD__ CALL URQSIG( ELAB,ITYPE ) FURQSG = .TRUE. GHESIG = .FALSE. ELSE FURQSG = .FALSE. #endif USELOW = .FALSE. GHESIG = .FALSE. #if __DPMJET__ IF ( FDPJSG .AND. (ELAB .GE. HILOELB) ) THEN CALL DPJSIG( PLAB,2 ) ELSE #elif __EPOS__ || __NEXUS__ IF ( FNEXSG .AND. (ELAB .GE. HILOELB) ) THEN CALL NEXSIG( ELAB,1 ) ELSE #elif __QGSJET__ IF ( FQGSSG .AND. (ELAB .GE. HILOELB) ) THEN CALL QGSSIG( ELAB,1 ) ELSE #elif __SIBYLL__ IF ( FSIBSG .AND. (ELAB .GE. HILOELB) ) THEN CALL SIBSIG( ELAB,2 ) ELSE #elif __VENUS__ IF ( FVENSG .AND. (ELAB .GE. HILOELB) ) THEN CALL VENSIG( ELAB,2 ) ELSE #endif C SIGMA IS ENERGY DEPENDENT INELASTIC PION-NUCLEON CROSS-SECTION IF ( PLAB .LE. 5.D0 ) THEN SIGMA = 20.64D0 ELSEIF ( PLAB .LT. 1.D3 ) THEN PLABLG = LOG( PLAB ) C INELASTIC CROSS-SECTIONS FROM PARTICLE DATA GROUP C (A.BALDINI ET AL., LANDOLT-BOERNSTEIN NEW SERIES I/12A (1987) 193) SIGMA = 24.3D0 - 12.3D0 * PLAB**(-1.91D0) * + 0.324D0 * PLABLG**2 - 2.44D0 * PLABLG ELSE C FACTOR 0.6667 GIVES RATIO BETWEEN PION AND NUCLEON CROSS-SECTION SIGMA = 19.87D0 * ELAB**.079D0 * 0.6667D0 ENDIF C AUXIL. QUANTITIES FOR INTERPOLATION SIG45 = SIGMA - 45.D0 S45SQ = SIG45**2 / 450.D0 S4530 = SIG45 / 30.D0 C INELASTIC CROSS-SECTIONS OF AIR FOR PROJECTILE WITH MASS NUMBER 1 SIGAIR = (1.D0 - 2.D0 * S45SQ) * SIG45A(1) * +(S45SQ - S4530) * SIG30A(1) * +(S45SQ + S4530) * SIG60A(1) #if __DPMJET__ || __EPOS__ || __NEXUS__ || __QGSJET__ || __SIBYLL__ || __VENUS__ ENDIF #endif ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2 : SIGMA,SIGAIR,GHESIG=', * SNGL(SIGMA),SNGL(SIGAIR),GHESIG CALL RMMARD( RD,2,1 ) C MEAN FREE PATH FOR INTERACTION (CHIINT) OR DECAY (CHI) CHIINT = (-LOG( RD(1) )) * AVERAW / (AVOGDR * SIGAIR) #if __UPWARD__ IF ( COSTHE .LT. 0.D0 ) THEN CHIINT = MIN( CHIINT, -THICKH/COSTHE ) ENDIF #endif CHIINT = MAX( 0.D0, CHIINT ) IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2 : ITYPE,RD(1),CHIINT=', * ITYPE,SNGL(RD(1)),SNGL(CHIINT) COR1 = (-LOG( RD(2) )) * C(25) * DECTIM(8) #if __CURVED__ CALL PRANGC( COR1,.FALSE.,HNEW ) #else CALL PRANGE( COR1 ) #endif #if __UPWARD__ IF ( COSTHE .LT. 0.D0 ) THEN CHI = MIN( CHI, -THICKH/COSTHE ) ENDIF #endif CHI = MAX( 0.D0, CHI ) IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2 : ITYPE,RD(2),CHIDEC=', * ITYPE,SNGL(RD(2)),SNGL(CHI) CHI = MIN( CHIINT, CHI ) IF ( CHI .LT. CHIINT ) THEN FDECAY = .TRUE. ELSE FDECAY = .FALSE. ENDIF C INTERACTION LENGTH STATISTICS CHI = MIN( 2.D9, CHI ) IP = 1.D0 + CHI * 0.1D0 IP = MIN( IP, 123 ) IPICHI( IP) = IPICHI( IP) + 1 IPICHI(124) = IPICHI(124) + 1 C----------------------------------------------------------------------- C NEUTRAL PIONS ELSEIF ( ITYPE .EQ. 7 ) THEN C LOW ENERGY PIONS ARE NOT TRACKED AND DECAY IMMEDIATELY IF ( ELAB .LT. 1.D5 ) THEN FDECAY = .TRUE. CHI = 0.D0 IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2 : ITYPE,CHI,FDECAY=', * ITYPE,SNGL(CHI),FDECAY ELSE C PION IS HIGH ENERGY AND MUST BE TRACKED PLAB = ELAB * BETA GHESIG = .FALSE. #if __DPMJET__ IF ( FDPJSG ) THEN CALL DPJSIG( PLAB,2 ) ELSE #elif __EPOS__ || __NEXUS__ IF ( FNEXSG ) THEN CALL NEXSIG( ELAB,1 ) ELSE #elif __QGSJET__ IF ( FQGSSG ) THEN CALL QGSSIG( ELAB,1 ) ELSE #elif __SIBYLL__ IF ( FSIBSG ) THEN CALL SIBSIG( ELAB,2 ) ELSE #elif __VENUS__ IF ( FVENSG ) THEN CALL VENSIG( ELAB,2 ) ELSE #endif C SIGMA IS ENERGY DEPENDENT INELASTIC PION-NUCLEON CROSS-SECTION C FACTOR 0.6667 GIVES RATIO BETWEEN PION AND NUCLEON CROSS-SECTION SIGMA = 19.87D0 * ELAB**.079D0 * 0.6667D0 C AUXIL. QUANTITIES FOR INTERPOLATION SIG45 = SIGMA - 45.D0 S45SQ = SIG45**2 / 450.D0 S4530 = SIG45 / 30.D0 C INELASTIC CROSS-SECTIONS OF AIR FOR PROJECTILE WITH MASS NUMBER 1 SIGAIR = (1.D0 - 2.D0 * S45SQ) * SIG45A(1) * +(S45SQ - S4530) * SIG30A(1) * +(S45SQ + S4530) * SIG60A(1) #if __DPMJET__ || __EPOS__ || __NEXUS__ || __QGSJET__ || __SIBYLL__ || __VENUS__ ENDIF #endif IF ( DEBUG ) WRITE(MDEBUG,*) * 'BOX2 : SIGMA,SIGAIR=',SNGL(SIGMA),SNGL(SIGAIR) CALL RMMARD( RD,2,1 ) C MEAN FREE PATH FOR INTERACTION (CHIINT) OR DECAY (CHI) CHIINT = (-LOG( RD(1) )) * AVERAW / (AVOGDR * SIGAIR) #if __UPWARD__ IF ( COSTHE .LT. 0.D0 ) THEN CHIINT = MIN( CHIINT, -THICKH/COSTHE ) ENDIF #endif CHIINT = MAX( 0.D0, CHIINT ) IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2 : ITYPE,RD(1),CHIINT=', * ITYPE,SNGL(RD(1)),SNGL(CHIINT) COR1 = (-LOG( RD(2) )) * C(25) * DECTIM(7) #if __CURVED__ CALL NRANGC( COR1*BETA*GAMMA ) #else DH = COR1 * BETA * GAMMA * COSTHE HDEC = MAX( H - DH, HLAY(1) - 1.D2 ) #if __UPWARD__ IF ( COSTHE .LT. 0.D0 ) THEN HDEC = MIN( HDEC, HLAY(6) ) ENDIF IF ( COSTHE .NE. 0.D0 ) THEN CHI = MAX( 0.D0, (THICK( HDEC )-THICKH)/COSTHE ) ENDIF #else CHI = (THICK( HDEC )-THICKH)/COSTHE #endif #endif CHI = MAX( 0.D0, CHI ) IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2 : ITYPE,RD(2),CHIDEC=', * ITYPE,SNGL(RD(2)),SNGL(CHI) CHI = MIN( CHIINT, CHI ) IF ( CHI .LT. CHIINT ) THEN FDECAY = .TRUE. ELSE FDECAY = .FALSE. ENDIF #if __INTTEST__ C LET PI(0) DECAY IN CASE OF INTERACTION TEST IF ( LPI0 ) FDECAY = .TRUE. CHI = 0.D0 #endif ENDIF C INTERACTION LENGTH STATISTICS CHI = MIN( 2.D9, CHI ) IP = 1.D0 + CHI * 0.1D0 IP = MIN( IP, 123 ) IPICHI( IP) = IPICHI( IP) + 1 IPICHI(124) = IPICHI(124) + 1 C----------------------------------------------------------------------- C NUCLEONS AND ANTINUCLEONS ELSEIF ( ITYPE .EQ. 13 .OR. ITYPE .EQ. 14 .OR. * ITYPE .EQ. 15 .OR. ITYPE .EQ. 25 ) THEN PLAB = ELAB * BETA C CALCULATION OF CROSS-SECTION IN THE LOW ENERGY MODEL IF ( ELAB .LE. HILOELB ) THEN EKIN = ELAB - PAMA(ITYPE) USELOW = .TRUE. #if __FLUKA__ CALL FLUSIG( EKIN,PLAB ) FFLUSIG = .TRUE. ELSE FFLUSIG = .FALSE. #elif __GHEISHAD__ SIGAIR = CGHSIG( PLAB,EKIN,ITYPE ) GHESIG = .TRUE. ELSE #elif __URQMD__ CALL URQSIG( ELAB,ITYPE ) FURQSG = .TRUE. GHESIG = .FALSE. ELSE FURQSG = .FALSE. #endif USELOW = .FALSE. GHESIG = .FALSE. #if __DPMJET__ IF ( FDPJSG .AND. (ELAB .GE. HILOELB) ) THEN CALL DPJSIG( PLAB,1 ) ELSE #elif __EPOS__ || __NEXUS__ IF ( FNEXSG .AND. (ELAB .GE. HILOELB) ) THEN CALL NEXSIG( ELAB,2 ) ELSE #elif __QGSJET__ IF ( FQGSSG .AND. (ELAB .GE. HILOELB) ) THEN CALL QGSSIG( ELAB,2 ) ELSE #elif __SIBYLL__ IF ( FSIBSG .AND. (ELAB .GE. HILOELB) ) THEN CALL SIBSIG( ELAB,1 ) ELSE #elif __VENUS__ IF ( FVENSG .AND. (ELAB .GE. HILOELB) ) THEN CALL VENSIG( ELAB,1 ) ELSE #endif C SIGMA IS ENERGY DEPENDENT INELASTIC NUCLEON-NUCLEON CROSS-SECTION IF ( PLAB .LT. 1.D1 ) THEN SIGMA = 29.9D0 ELSEIF ( PLAB .LT. 1.D3 ) THEN PLABLG = LOG( PLAB ) C INELASTIC CROSS-SECTIONS FROM PARTICLE DATA GROUP C (A.BALDINI ET AL., LANDOLT-BOERNSTEIN NEW SERIES I/12B (1987) 150) SIGMA = 30.9D0 - 28.9D0 * PLAB**(-2.46D0) * + 0.192D0 * PLABLG**2 - 0.835D0 * PLABLG ELSE SIGMA = 19.87D0 * ELAB**.079D0 ENDIF C ADD ANNIHILATION CROSS-SECTION FOR ANTI-NUCLEONS IF ( ITYPE .EQ. 15 .OR. ITYPE .EQ. 25 ) THEN C ANNIHILATION CROSS-SECTIONS FROM PARTICLE DATA GROUP C (A.BALDINI ET AL., LANDOLT-BOERNSTEIN NEW SERIES I/12B (1987) 286) SIGANN = 0.532D0 + 0.634D2 * PLAB**(-0.71D0) SIGMA = MIN( 120.D0, SIGMA + SIGANN ) ENDIF C AUXIL. QUANTITIES FOR INTERPOLATION SIG45 = SIGMA - 45.D0 S45SQ = SIG45**2 / 450.D0 S4530 = SIG45 / 30.D0 C INELASTIC CROSS-SECTIONS OF AIR FOR PROJECTILE WITH MASS NUMBER 1 SIGAIR = (1.D0 - 2.D0 * S45SQ) * SIG45A(1) * +(S45SQ - S4530) * SIG30A(1) * +(S45SQ + S4530) * SIG60A(1) #if __DPMJET__ || __EPOS__ || __NEXUS__ || __QGSJET__ || __SIBYLL__ || __VENUS__ ENDIF IF ( ITYPE .EQ. 15 .OR. ITYPE .EQ. 25 ) THEN C TAKE ANNIHILATION AS ADDITION TO HADR. INTERACT. CROSS-SECTION SIGANN = 2.25D2 * PLAB**(-0.625D0) SIGAIR = SIGAIR + SIGANN FRACTN = FRACTN + PROBTA(1) * SIGANN FRCTNO = FRCTNO + PROBTA(2) * SIGANN ENDIF #endif ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2 : SIGMA,SIGAIR,GHESIG=', * SNGL(SIGMA),SNGL(SIGAIR),GHESIG C MEAN FREE PATH FROM MOLECULAR WEIGHT, AVOGADRO''S CONSTANT AND SIGMA CALL RMMARD( RD,1,1 ) CHI = (-LOG( RD(1) )) * AVERAW / (AVOGDR * SIGAIR) #if __UPWARD__ IF ( COSTHE .LT. 0.D0 ) THEN CHI = MIN( CHI, ABS( THICKH/COSTHE ) ) ENDIF #endif FDECAY = .FALSE. CHI = MAX( 0.D0, CHI ) IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2 : ITYPE,RD(1),CHI=', * ITYPE,SNGL(RD(1)),SNGL(CHI) C INTERACTION LENGTH STATISTICS CHI = MIN( 2.D9, CHI ) NU = 1.D0 + CHI * 0.1D0 NU = MIN( NU, 123 ) INUCHI( NU) = INUCHI( NU) + 1 INUCHI(124) = INUCHI(124) + 1 C----------------------------------------------------------------------- C KAONS (PARTICLE TYPES 10,11,12,16) ELSEIF ( ITYPE .EQ. 10 .OR. ITYPE .EQ. 11 .OR. * ITYPE .EQ. 12 .OR. ITYPE .EQ. 16 ) THEN PLAB = ELAB * BETA C CALCULATION OF CROSS-SECTION IN THE LOW ENERGY MODEL IF ( ELAB .LE. HILOELB ) THEN EKIN = ELAB - PAMA(ITYPE) USELOW = .TRUE. #if __FLUKA__ CALL FLUSIG( EKIN,PLAB ) FFLUSIG = .TRUE. ELSE FFLUSIG = .FALSE. #elif __GHEISHAD__ SIGAIR = CGHSIG( PLAB,EKIN,ITYPE ) GHESIG = .TRUE. ELSE #elif __URQMD__ CALL URQSIG( ELAB,ITYPE ) FURQSG = .TRUE. GHESIG = .FALSE. ELSE FURQSG = .FALSE. #endif USELOW = .FALSE. GHESIG = .FALSE. #if __DPMJET__ IF ( FDPJSG .AND. (ELAB .GE. HILOELB) ) THEN CALL DPJSIG( PLAB,3 ) ELSE #elif __EPOS__ || __NEXUS__ IF ( FNEXSG .AND. (ELAB .GE. HILOELB) ) THEN CALL NEXSIG( ELAB,3 ) ELSE #elif __QGSJET__ IF ( FQGSSG .AND. (ELAB .GE. HILOELB) ) THEN CALL QGSSIG( ELAB,3 ) ELSE #elif __SIBYLL__ IF ( FSIBSG .AND. (ELAB .GE. HILOELB) ) THEN CALL SIBSIG( ELAB,3 ) ELSE #elif __VENUS__ IF ( FVENSG .AND. (ELAB .GE. HILOELB) ) THEN CALL VENSIG( ELAB,3 ) ELSE #endif C SIGMA IS ENERGY DEPENDENT INELASTIC KAON-NUCLEON CROSS-SECTION IF ( PLAB .LE. 1.D1 ) THEN SIGMA = 14.11D0 ELSEIF ( PLAB .LT. 1.D3 ) THEN PLABLG = LOG( PLAB ) C INELASTIC CROSS-SECTIONS FROM PARTICLE DATA GROUP C (A.BALDINI ET AL., LANDOLT-BOERNSTEIN NEW SERIES I/12B (1987) 56) SIGMA = 12.3D0 - 7.77D0 * PLAB**(-2.12D0) * + 0.0326D0 * PLABLG**2 + 0.738D0 * PLABLG ELSE C FACTOR 0.5541 GIVES RATIO BETWEEN KAON AND NUCLEON CROSS-SECTION SIGMA = 19.87D0 * ELAB**.079D0 * 0.5541D0 ENDIF C AUXIL. QUANTITIES FOR INTERPOLATION SIG45 = SIGMA - 45.D0 S45SQ = SIG45**2 / 450.D0 S4530 = SIG45 / 30.D0 C INELASTIC CROSS-SECTIONS OF AIR FOR PROJECTILE WITH MASS NUMBER 1 SIGAIR = (1.D0 - 2.D0 * S45SQ) * SIG45A(1) * +(S45SQ - S4530) * SIG30A(1) * +(S45SQ + S4530) * SIG60A(1) #if __DPMJET__ || __EPOS__ || __NEXUS__ || __QGSJET__ || __SIBYLL__ || __VENUS__ ENDIF #endif ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2 : SIGMA,SIGAIR,GHESIG=', * SNGL(SIGMA),SNGL(SIGAIR),GHESIG CALL RMMARD( RD,2,1 ) C MEAN FREE PATH FOR INTERACTION (CHIINT) OR DECAY (CHI) CHIINT = (-LOG( RD(1) )) * AVERAW / (AVOGDR * SIGAIR) #if __UPWARD__ IF ( COSTHE .LT. 0.D0 ) THEN CHIINT = MIN( CHIINT, -THICKH/COSTHE ) ENDIF #endif CHIINT = MAX( 0.D0, CHIINT ) IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2 : ITYPE,RD(1),CHIINT=', * ITYPE,SNGL(RD(1)),SNGL(CHIINT) COR1 = (-LOG( RD(2) )) * C(25) * DECTIM(ITYPE) IF ( SIGNUM(ITYPE) .EQ. 0.D0 ) THEN C NEUTRAL KAONS #if __CURVED__ CALL NRANGC( COR1*BETA*GAMMA ) #else DH = COR1 * BETA * GAMMA * COSTHE HDEC = MAX( H - DH, HLAY(1) - 1.D2 ) #if __UPWARD__ IF ( COSTHE .LT. 0.D0 ) THEN HDEC = MIN( HDEC, HLAY(6) ) ENDIF IF ( COSTHE .NE. 0.D0 ) THEN CHI = (THICK( HDEC )-THICKH)/COSTHE ENDIF #else CHI = (THICK( HDEC )-THICKH)/COSTHE #endif #endif ELSE C CHARGED KAONS #if __CURVED__ CALL PRANGC( COR1,.FALSE.,HNEW ) #else CALL PRANGE( COR1 ) #endif #if __UPWARD__ IF ( COSTHE .LT. 0.D0 ) THEN CHI = MIN( CHI, -THICKH/COSTHE ) ENDIF #endif ENDIF CHI = MAX( 0.D0, CHI ) IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2 : ITYPE,RD(2),CHIDEC=', * ITYPE,SNGL(RD(2)),SNGL(CHI) CHI = MIN( CHIINT, CHI ) IF ( CHI .LT. CHIINT ) THEN FDECAY = .TRUE. ELSE FDECAY = .FALSE. ENDIF #if __INTTEST__ C INHIBIT A SECONDARY INTERACTION OF K0S IN CASE OF INTERACTION TEST IF ( ITYPE .EQ. 16 .AND. LK0S ) THEN CHI = 0.D0 FDECAY = .TRUE. ENDIF #endif C INTERACTION LENGTH STATISTICS CHI = MIN( 2.D9, CHI ) KA = 1.D0 + CHI * 0.1D0 KA = MIN( KA, 123 ) IKACHI( KA) = IKACHI( KA) + 1 IKACHI(124) = IKACHI(124) + 1 C----------------------------------------------------------------------- C ETA MESONS ELSEIF ( ITYPE .EQ. 17 .OR. * (ITYPE .GE. 71 .AND. ITYPE .LE. 74 ) ) THEN C LOW ENERGY ETA MESONS ARE NOT TRACKED AND DECAY IF ( ELAB .LT. 1.D7 ) THEN FDECAY = .TRUE. CHI = 0.D0 IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2 : ITYPE,CHI,FDECAY=', * ITYPE,SNGL(CHI),FDECAY ELSE C ETA IS HIGH ENERGY AND MUST BE TRACKED. WE TAKE PION CROSS-SECTIONS C BETTER IS KAON CROSS SECTION, AS ETA AND KAON HAVE SIMILAR MASS PLAB = ELAB * BETA GHESIG = .FALSE. #if __DPMJET__ IF ( FDPJSG ) THEN CALL DPJSIG( PLAB,3 ) ELSE #elif __EPOS__ || __NEXUS__ IF ( FNEXSG ) THEN CALL NEXSIG( ELAB,3 ) ELSE #elif __QGSJET__ IF ( FQGSSG ) THEN CALL QGSSIG( ELAB,3 ) ELSE #elif __SIBYLL__ IF ( FSIBSG ) THEN CALL SIBSIG( ELAB,3 ) ELSE #elif __VENUS__ IF ( FVENSG ) THEN CALL VENSIG( ELAB,3 ) ELSE #endif C SIGMA IS ENERGY DEPENDENT INELASTIC PION-NUCLEON CROSS-SECTION C FACTOR 0.6667 GIVES RATIO BETWEEN PION AND NUCLEON CROSS-SECTION SIGMA = 19.87D0 * ELAB**.079D0 * 0.6667D0 C AUXIL. QUANTITIES FOR INTERPOLATION SIG45 = SIGMA - 45.D0 S45SQ = SIG45**2 / 450.D0 S4530 = SIG45 / 30.D0 C INELASTIC CROSS-SECTIONS OF AIR FOR PROJECTILE WITH MASS NUMBER 1 SIGAIR = (1.D0 - 2.D0 * S45SQ) * SIG45A(1) * +(S45SQ - S4530) * SIG30A(1) * +(S45SQ + S4530) * SIG60A(1) #if __DPMJET__ || __EPOS__ || __NEXUS__ || __QGSJET__ || __SIBYLL__ || __VENUS__ ENDIF #endif IF ( DEBUG ) WRITE(MDEBUG,*) * 'BOX2 : SIGMA,SIGAIR=',SNGL(SIGMA),SNGL(SIGAIR) CALL RMMARD( RD,2,1 ) C MEAN FREE PATH FOR INTERACTION (CHIINT) OR DECAY (CHI) CHIINT = (-LOG( RD(1) )) * AVERAW / (AVOGDR * SIGAIR) #if __UPWARD__ IF ( COSTHE .LT. 0.D0 ) THEN CHIINT = MIN( CHIINT, -THICKH/COSTHE ) ENDIF #endif CHIINT = MAX( 0.D0, CHIINT ) IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2 : ITYPE,RD(1),CHIINT=', * ITYPE,SNGL(RD(1)),SNGL(CHIINT) COR1 = (-LOG( RD(2) )) * C(25) * DECTIM(17) #if __CURVED__ CALL NRANGC( COR1*BETA*GAMMA ) #else DH = COR1 * BETA * GAMMA * COSTHE HDEC = MAX( H - DH, HLAY(1) - 1.D2 ) #if __UPWARD__ IF ( COSTHE .LT. 0.D0 ) THEN HDEC = MIN( HDEC, HLAY(6) ) ENDIF IF ( COSTHE .NE. 0.D0 ) THEN CHI = (THICK( HDEC )-THICKH)/COSTHE ENDIF #else CHI = (THICK( HDEC )-THICKH)/COSTHE #endif #endif CHI = MAX( 0.D0, CHI ) IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2 : ITYPE,RD(2),CHIDEC=', * ITYPE,SNGL(RD(2)),SNGL(CHI) CHI = MIN( CHIINT, CHI ) #if __QGSJET__ && __QGSII__ C QGSJET_II CANNOT TREAT ETA THEREFORE MAKE DECAY FDECAY = .TRUE. #else IF ( CHI .LT. CHIINT ) THEN FDECAY = .TRUE. ELSE FDECAY = .FALSE. ENDIF #endif ENDIF #if __INTTEST__ C LET ETA DECAY IN CASE OF INTERACTION TEST IF ( LETA ) FDECAY = .TRUE. CHI = 0.D0 #endif C INTERACTION LENGTH STATISTICS CHI = MIN( 2.D9, CHI ) IP = 1.D0 + CHI * 0.1D0 IP = MIN( IP, 123 ) IPICHI( IP) = IPICHI( IP) + 1 IPICHI(124) = IPICHI(124) + 1 C----------------------------------------------------------------------- C STRANGE BARYONS ( LAMBDA, SIGMA(+,0,-), XI(0,-), OMEGA- ) ELSEIF ( (ITYPE .GE. 18 .AND. ITYPE .LE. 24) .OR. * (ITYPE .GE. 26 .AND. ITYPE .LE. 32) ) THEN PLAB = ELAB * BETA C CALCULATION OF CROSS-SECTION IN THE LOW ENERGY MODEL IF ( ELAB .LE. HILOELB ) THEN EKIN = ELAB - PAMA(ITYPE) USELOW = .TRUE. #if __FLUKA__ CALL FLUSIG( EKIN,PLAB ) FFLUSIG = .TRUE. ELSE FFLUSIG = .FALSE. #elif __GHEISHAD__ SIGAIR = CGHSIG( PLAB,EKIN,ITYPE ) C SET CROSS-SECTION VALUE TO A SMALL NUMBER FOR SIGMA0 AND ANTI SIGMA0 IF ( ITYPE .EQ. 20 .OR. ITYPE .EQ. 28 ) THEN SIGAIR = 1.D-3 ENDIF GHESIG = .TRUE. ELSE #elif __URQMD__ CALL URQSIG( ELAB,ITYPE ) FURQSG = .TRUE. GHESIG = .FALSE. ELSE FURQSG = .FALSE. #endif USELOW = .FALSE. GHESIG = .FALSE. C CROSS-SECTION FOR BARYONS IS ASSUMED TO BE THE SAME AS FOR NUCLEONS #if __DPMJET__ IF ( FDPJSG .AND. (ELAB .GE. HILOELB) ) THEN CALL DPJSIG( PLAB,4 ) ELSE #elif __EPOS__ || __NEXUS__ IF ( FNEXSG .AND. (ELAB .GE. HILOELB) ) THEN CALL NEXSIG( ELAB,2 ) ELSE #elif __QGSJET__ IF ( FQGSSG .AND. (ELAB .GE. HILOELB) ) THEN CALL QGSSIG( ELAB,2 ) ELSE #elif __SIBYLL__ IF ( FSIBSG .AND. (ELAB .GE. HILOELB) ) THEN CALL SIBSIG( ELAB,1 ) ELSE #elif __VENUS__ IF ( FVENSG .AND. (ELAB .GE. HILOELB) ) THEN CALL VENSIG( ELAB,1 ) ELSE #endif C SIGMA IS ENERGY DEPENDENT INELASTIC NUCLEON-NUCLEON CROSS-SECTION IF ( PLAB .LT. 1.D1 ) THEN SIGMA = 29.9D0 ELSEIF ( PLAB .LT. 1.D3 ) THEN PLABLG = LOG( PLAB ) C INELASTIC CROSS-SECTIONS FROM PARTICLE DATA GROUP C (A.BALDINI ET AL., LANDOLT-BOERNSTEIN NEW SERIES I/12B (1987) 150) SIGMA = 30.9D0 - 28.9D0 * PLAB**(-2.46D0) * + 0.192D0 * PLABLG**2 - 0.835D0 * PLABLG ELSE SIGMA = 19.87D0 * ELAB**.079D0 ENDIF C AUXIL. QUANTITIES FOR INTERPOLATION SIG45 = SIGMA - 45.D0 S45SQ = SIG45**2 / 450.D0 S4530 = SIG45 / 30.D0 C INELASTIC CROSS-SECTIONS OF AIR FOR PROJECTILE WITH MASS NUMBER 1 SIGAIR = (1.D0 - 2.D0 * S45SQ) * SIG45A(1) * +(S45SQ - S4530) * SIG30A(1) * +(S45SQ + S4530) * SIG60A(1) #if __DPMJET__ || __EPOS__ || __NEXUS__ || __QGSJET__ || __SIBYLL__ || __VENUS__ ENDIF #endif ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2 : SIGMA,SIGAIR,GHESIG=', * SNGL(SIGMA),SNGL(SIGAIR),GHESIG CALL RMMARD( RD,2,1 ) C MEAN FREE PATH FOR INTERACTION (CHIINT) OR DECAY (CHI) COR1 = (-LOG( RD(2) )) * C(25) * DECTIM(ITYPE) IF ( SIGNUM(ITYPE) .EQ. 0.D0 ) THEN C NEUTRAL STRANGE BARYONS #if __CURVED__ CALL NRANGC( COR1*BETA*GAMMA ) #else DH = COR1 * BETA * GAMMA * COSTHE HDEC = MAX( H - DH, HLAY(1) - 1.D2 ) #if __UPWARD__ IF ( COSTHE .LT. 0.D0 ) THEN HDEC = MIN( HDEC, HLAY(6) ) ENDIF IF ( COSTHE .NE. 0.D0 ) THEN CHI = (THICK( HDEC )-THICKH)/COSTHE ENDIF #else CHI = (THICK( HDEC )-THICKH)/COSTHE #endif #endif ELSE C CHARGED STRANGE BARYONS #if __CURVED__ CALL PRANGC( COR1,.FALSE.,HNEW ) #else CALL PRANGE( COR1 ) #endif #if __UPWARD__ IF ( COSTHE .LT. 0.D0 ) THEN CHI = MIN( CHI, -THICKH/COSTHE ) ENDIF #endif ENDIF CHI = MAX( 0.D0, CHI ) IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2 : ITYPE,RD(2),CHIDEC=', * ITYPE,SNGL(RD(2)),SNGL(CHI) CHIINT = (-LOG( RD(1) )) * AVERAW / (AVOGDR * SIGAIR) #if __UPWARD__ IF ( COSTHE .LT. 0.D0 ) THEN CHIINT = MIN( CHIINT, -THICKH/COSTHE ) ENDIF #endif CHIINT = MAX( 0.D0, CHIINT ) IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2 : ITYPE,RD(1),CHIINT=', * ITYPE,SNGL(RD(1)),SNGL(CHIINT) CHI = MIN( CHIINT, CHI ) #if __DPMJET__ C DPMJET-3 CAN TREAT ALL STRANGE BARYONS IF ( CHI .LT. CHIINT ) THEN FDECAY = .TRUE. ELSE FDECAY = .FALSE. ENDIF #elif __QGSJET__ && __QGSII__ IF ( FQGS .AND. (.NOT. GHESIG) ) THEN C QGSJET_II CANNOT TREAT BARYONS WITH STRANGENESS FDECAY = .TRUE. ELSE IF ( CHI .LT. CHIINT ) THEN FDECAY = .TRUE. ELSE FDECAY = .FALSE. ENDIF ENDIF #endif C GHEISHA CANNOT TREAT SIGMA0 AND ANTI-SIGMA0, LET THEM DECAY IF ( GHESIG .AND. (ITYPE .EQ. 20 .OR. ITYPE .EQ. 28) ) * FDECAY = .TRUE. #if __INTTEST__ C INHIBIT A SECONDARY INTERACTION IN CASE OF INTERACTION TEST IF ( LHYP ) FDECAY = .TRUE. CHI = 0.D0 #endif C INTERACTION LENGTH STATISTICS CHI = MIN( 2.D9, CHI ) IHY = 1.D0 + CHI * 0.1D0 IHY = MIN( IHY, 123 ) IHYCHI(IHY) = IHYCHI(IHY) + 1 IHYCHI(124) = IHYCHI(124) + 1 #if __CHARM__ C----------------------------------------------------------------------- C CHARMED PARTICLES C TAU NEUTRINOS AND TAU LEPTONS ARE ALREADY TREATED ELSEIF ( ITYPE .GE. 116 .AND. ITYPE .LE. 173 ) THEN * if ( debug ) write(mdebug,*) 'box2 : charm' C HILOELB CHANGED TO 200 (PYTHIA ENERGY LOW LIMIT) IF ( ELAB .LE. MAX( 200.D0 ,HILOELB ) ) THEN C LOW ENERGY MODEL CANNOT TREAT CHARMED PARTICLES, LET THEM DECAY FDECAY = .TRUE. CHI = 0.D0 IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2 : ITYPE,CHI,FDECAY=', * ITYPE,SNGL(CHI),FDECAY ELSE C PARTICLE HAS HIGH ENERGY AND MUST BE TRACKED PLAB = ELAB * BETA GHESIG = .FALSE. #if __DPMJET__ IF ( FDPJSG ) THEN * IF ( ITYPE .GE. 116 .AND. ITYPE .LE. 130 ) THEN C CHARMED MESONS C IF SIGMAQ==0 USE PARAMETERIZATION C PARAMETERIZATION VALID ONLY IN RANGE [1.E6,1.E11] GEV * IF ( SIGMAQ(1) .EQ. 0.D0 ) THEN * SIGMA = EXP(1.891D0 + 0.2095D0*LOG10(ELAB)) * * -2.157D0 + 1.236D0*LOG10(ELAB) * ELSE * SIGMA = SIGMAQ(1) * ENDIF * ELSE C CHARMED BARYONS C IF SIGMAQ==0 USE PARAMETERIZATION C PARAMETERIZATION VALID ONLY IN RANGE [1.E6,1E.11] GEV * IF ( SIGMAQ(2) .EQ. 0.D0 ) THEN * SIGMA = EXP(2.269D0 + 0.207D0*LOG10(ELAB)) * * -0.9907D0 + 1.277D0*LOG10(ELAB) * ELSE * SIGMA = SIGMAQ(2) * ENDIF * ENDIF C AUXIL. QUANTITIES FOR INTERPOLATION * SIG45 = SIGMA - 45.D0 * S45SQ = SIG45**2 / 450.D0 * S4530 = SIG45 / 30.D0 C INELASTIC CROSS-SECTIONS OF AIR FOR PROJECTILE WITH MASS NUMBER 1 * SIGAIR = (1.D0 - 2.D0 * S45SQ) * SIG45A(1) * * +(S45SQ - S4530) * SIG30A(1) * * +(S45SQ + S4530) * SIG60A(1) C TAKE A VERY SMALL CROSS SECTION, SO CHARMED PARTICLES WILL DECAY SIGMA = 1.D-32 SIGAIR = 1.D-32 ELSE #elif __EPOS__ IF ( FNEXSG ) THEN * IF ( ITYPE .GE. 116 .AND. ITYPE .LE. 130 ) THEN * CALL NEXSIG( ELAB,1 ) * ELSE * CALL NEXSIG( ELAB,2 ) * ENDIF C TAKE A VERY SMALL CROSS SECTION, SO CHARMED PARTICLES WILL DECAY SIGMA = 1.D-32 SIGAIR = 1.D-32 ELSE #elif __QGSJET__ && !__QGSII__ IF ( FQGSSG ) THEN * IF ( ITYPE .GE. 116 .AND. ITYPE .LE. 130 ) THEN C CHARMED MESONS C IF SIGMAQ==0 USE PARAMETERIZATION C PARAMETERIZATION VALID ONLY IN RANGE [1.E6,1.E11] GEV * IF ( SIGMAQ(1) .EQ. 0.D0 ) THEN * SIGMA = EXP(1.891D0 + 0.2095D0*LOG10(ELAB)) * * -2.157D0 + 1.236D0*LOG10(ELAB) * ELSE * SIGMA = SIGMAQ(1) * ENDIF * ELSE C CHARMED BARYONS C IF SIGMAQ==0 USE PARAMETERIZATION C PARAMETERIZATION VALID ONLY IN RANGE [1.E6,1E.11] GEV * IF ( SIGMAQ(2) .EQ. 0.D0 ) THEN * SIGMA = EXP(2.269D0 + 0.207D0*LOG10(ELAB)) * * -0.9907D0 + 1.277D0*LOG10(ELAB) * ELSE * SIGMA = SIGMAQ(2) * ENDIF * ENDIF C AUXIL. QUANTITIES FOR INTERPOLATION * SIG45 = SIGMA - 45.D0 * S45SQ = SIG45**2 / 450.D0 * S4530 = SIG45 / 30.D0 C INELASTIC CROSS-SECTIONS OF AIR FOR PROJECTILE WITH MASS NUMBER 1 * SIGAIR = (1.D0 - 2.D0 * S45SQ) * SIG45A(1) * * +(S45SQ - S4530) * SIG30A(1) * * +(S45SQ + S4530) * SIG60A(1) C TAKE A VERY SMALL CROSS SECTION, SO CHARMED PARTICLES WILL DECAY SIGMA = 1.D-32 SIGAIR = 1.D-32 ELSE #elif __SIBYLL__ IF ( FSIBSG ) THEN C CHARMED MESONS, ASSUME KAON CROSS SECTION IF ( ITYPE .GE. 116 .AND. ITYPE .LE. 121 ) THEN CALL SIBSIG( ELAB,3 ) c SIGAIR = SIGAIR * factor !factor for rescaling c SIGMA = SIGMA * factor !factor for rescaling C CHARMED BARYONS, ASSUME PROTON/NEUTRON CROSS SECTION ELSEIF ( ( ITYPE .GE. 137 .AND. ITYPE .LE. 139 ) .OR. * ( ITYPE .GE. 145 .AND. ITYPE .LE. 151 ) .OR. * ITYPE .EQ. 157 ) THEN CALL SIBSIG( ELAB,1 ) ELSE C ADOPT AN INFINITE SMALL CROSS SECTION, LET CHARMED PARTICLE DECAY SIGAIR = 1.D-32 SIGMA = 1.D-32 FDECAY = .TRUE. ENDIF ELSE #endif C SIGMA IS ENERGY DEPENDENT INELASTIC NUCLEON-NUCLEON CROSS-SECTION C FOR ENERGIES ABOVE 1 TEV C CHARMED MESONS IF ( ITYPE .GE. 116 .AND. ITYPE .LE. 130 ) THEN C IF SIGMAQ==0 USE PARAMETERIZATION C PARAMETERIZATION VALID ONLY IN RANGE [1.E6,1.E11] GEV IF ( SIGMAQ(1) .EQ. 0.D0 ) THEN SIGMA = EXP(1.891D0 + 0.2095D0*LOG10(ELAB)) * -2.157D0 + 1.236D0*LOG10(ELAB) ELSE SIGMA = SIGMAQ(1) ENDIF ELSE C CHARMED BARYONS C IF SIGMAQ==0 USE PARAMETERIZATION C PARAMETERIZATION VALID ONLY IN RANGE [1.E6,1.E11] GEV IF ( SIGMAQ(2) .EQ. 0.D0 ) THEN SIGMA = EXP(2.269D0 + 0.207D0*LOG10(ELAB)) * -0.9907D0 + 1.277D0*LOG10(ELAB) ELSE SIGMA = SIGMAQ(2) ENDIF ENDIF C AUXIL. QUANTITIES FOR INTERPOLATION SIG45 = SIGMA - 45.D0 S45SQ = SIG45**2 / 450.D0 S4530 = SIG45 / 30.D0 C INELASTIC CROSS-SECTIONS OF AIR FOR PROJECTILE WITH MASS NUMBER 1 SIGAIR = (1.D0 - 2.D0 * S45SQ) * SIG45A(1) * +(S45SQ - S4530) * SIG30A(1) * +(S45SQ + S4530) * SIG60A(1) #if __DPMJET__ || __EPOS__ || (__QGSJET__ && !__QGSII__) || __SIBYLL__ ENDIF #endif IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2 : SIGMA,SIGAIR=', * SNGL(SIGMA),SNGL(SIGAIR) CALL RMMARD( RD,2,1 ) C MEAN FREE PATH FOR INTERACTION (CHIINT) OR DECAY (CHI) CHIINT = (-LOG( RD(2) )) * AVERAW / (AVOGDR * SIGAIR) #if __UPWARD__ IF ( COSTHE .LT. 0.D0 ) THEN CHIINT = MIN( CHIINT, -THICKH/COSTHE ) ENDIF #endif CHIINT = MAX( 0.D0, CHIINT ) IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2 : ITYPE,RD(2),CHIINT=', * ITYPE,SNGL(RD(2)),SNGL(CHIINT) IF ( DECTIM(ITYPE) .EQ. 0.D0 ) THEN WRITE(MONIOU,*) 'BOX2 : PARTICLE ',ITYPE,' NOT DEFINED' STOP ENDIF COR1 = (-LOG( RD(1) )) * C(25) * DECTIM(ITYPE) IF ( SIGNUM(ITYPE) .EQ. 0.D0 ) THEN #if __CURVED__ C NEUTRAL PARTICLES CALL NRANGC( COR1*BETA*GAMMA ) #else DH = COR1 * BETA * GAMMA * COSTHE HDEC = MAX( H - DH, HLAY(1) - 1.D2 ) #if __UPWARD__ IF ( COSTHE .LT. 0.D0 ) THEN HDEC = MIN( HDEC, HLAY(6) ) ENDIF IF ( COSTHE .NE. 0.D0 ) THEN CHI = (THICK( HDEC )-THICKH)/COSTHE ENDIF #else CHI = (THICK( HDEC )-THICKH)/COSTHE #endif #endif ELSE C CHARGED PARTICLES #if __CURVED__ CALL PRANGC( COR1,.FALSE.,HNEW ) #else CALL PRANGE( COR1 ) #endif #if __UPWARD__ IF ( COSTHE .LT. 0.D0 ) THEN CHI = MIN( CHI, -THICKH/COSTHE ) ENDIF #endif ENDIF CHI = MAX( 0.D0, CHI ) IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2 : ITYPE,RD(1),CHIDEC=', * ITYPE,SNGL(RD(1)),SNGL(CHI) CHI = MIN( CHIINT, CHI ) IF ( CHI .LT. CHIINT ) THEN FDECAY = .TRUE. ELSE FDECAY = .FALSE. ENDIF ENDIF #if __DPMJET__ C DPMJET 3 CANNOT TREAT CHARMED PROJECTILES C BUT CHARMED PARTICLES ARE TREATED BY PYTHIA, SO KEEP THEM FDECAY = .TRUE. #elif __EPOS__ C EPOS CANNOT TREAT SEVERAL CHARMED PARTICLES * IF ( ITYPE .EQ. ??? ) FDECAY = .TRUE. #elif __QGSJET__ && !__QGSII__ C FORCE ALL CHARMED PARTICLES NOT KNOWN BY QGSJET01 TO DECAY C BUT CHARMED PARTICLES ARE TREATED BY PYTHIA, SO KEEP THEM cdh IF ( ITYPE .GE. 120 .AND. ITYPE .NE. 137 c * .AND. ITYPE .NE. 149 ) THEN FDECAY = .TRUE. cdh ENDIF #elif __SIBYLL__ C SIBYLL 2.3 WITH CHARM CAN TREAT CHARMED PROJECTILES #endif #endif #if __CHARM__ && !__SIBYLL__ C----------------------------------------------------------------------- C BOTTOM PARTICLES ELSEIF ( ITYPE .GE. 176 .AND. ITYPE .LE. 195 ) THEN C HILOELB CHANGED TO 200 (PYTHIA LOW ENERGY LIMIT) IF ( ELAB .LE. 200.D0 ) THEN C LOW ENERGY MODEL CANNOT TREAT BOTTOM PARTICLES, LET THEM DECAY FDECAY = .TRUE. CHI = 0.D0 IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2 : ITYPE,CHI,FDECAY=', * ITYPE,SNGL(CHI),FDECAY ELSE C PARTICLE HAS HIGH ENERGY AND MUST BE TRACKED PLAB = ELAB * BETA GHESIG = .FALSE. #if __DPMJET__ IF ( FDPJSG ) THEN IF ( ITYPE .GE. 176 .AND. ITYPE .LE. 183 ) THEN C BOTTOM MESONS C IF SIGMAQ==0 USE PARAMETERIZATION C PARAMETERIZATION VALID ONLY IN RANGE [1.E6,1.E11] GEV IF ( SIGMAQ(3) .EQ. 0.D0 ) THEN SIGMA = EXP(1.851D0 + 0.2094D0*LOG10(ELAB)) * -1.042D0 + 0.7279D0*LOG10(ELAB) ELSE SIGMA = SIGMAQ(3) ENDIF ELSE C BOTTOM BARYONS C IF SIGMAQ==0 USE PARAMETERIZATION C PARAMETERIZATION VALID ONLY IN RANGE [1.E6,1.E11] GEV IF ( SIGMAQ(4) .EQ. 0.D0 ) THEN SIGMA = EXP(2.23D0 + 0.207D0*LOG10(ELAB)) * -0.9026D0 + 1.086D0*LOG10(ELAB) ELSE SIGMA = SIGMAQ(4) ENDIF ENDIF C AUXIL. QUANTITIES FOR INTERPOLATION SIG45 = SIGMA - 45.D0 S45SQ = SIG45**2 / 450.D0 S4530 = SIG45 / 30.D0 C INELASTIC CROSS-SECTIONS OF AIR FOR PROJECTILE WITH MASS NUMBER 1 SIGAIR = (1.D0 - 2.D0 * S45SQ) * SIG45A(1) * +(S45SQ - S4530) * SIG30A(1) * +(S45SQ + S4530) * SIG60A(1) ELSE #elif __EPOS__ IF ( FNEXSG ) THEN SIGAIR = 1.D-32 ELSE #elif __QGSJET__ && !__QGSII__ IF ( FQGSSG ) THEN IF ( ITYPE .GE. 176 .AND. ITYPE .LE. 183 ) THEN C BOTTOM MESONS C IF SIGMAQ==0 USE PARAMETERIZATION C PARAMETERIZATION VALID ONLY IN RANGE [1.E6,1.E11] GEV IF ( SIGMAQ(3) .EQ. 0.D0 ) THEN SIGMA = EXP(1.851D0 + 0.2094D0*LOG10(ELAB)) * -1.042D0 + 0.7279D0*LOG10(ELAB) ELSE SIGMA = SIGMAQ(3) ENDIF ELSE C BOTTOM BARYONS C IF SIGMAQ==0 USE PARAMETERIZATION C PARAMETERIZATION VALID ONLY IN RANGE [1.E6,1.E11] GEV IF ( SIGMAQ(4) .EQ. 0.D0 ) THEN SIGMA = EXP(2.23D0 + 0.207D0*LOG10(ELAB)) * -0.9026D0 + 1.086D0*LOG10(ELAB) ELSE SIGMA = SIGMAQ(4) ENDIF ENDIF C AUXIL. QUANTITIES FOR INTERPOLATION SIG45 = SIGMA - 45.D0 S45SQ = SIG45**2 / 450.D0 S4530 = SIG45 / 30.D0 C INELASTIC CROSS-SECTIONS OF AIR FOR PROJECTILE WITH MASS NUMBER 1 SIGAIR = (1.D0 - 2.D0 * S45SQ) * SIG45A(1) * +(S45SQ - S4530) * SIG30A(1) * +(S45SQ + S4530) * SIG60A(1) ELSE #endif C SIGMA IS ENERGY DEPENDENT INELASTIC NUCLEON-NUCLEON CROSS-SECTION C FOR ENERGIES ABOVE 1 TEV, IF ( ITYPE .GE. 176 .AND. ITYPE .LE. 183 ) THEN C BOTTOM MESONS C IF SIGMAQ==0 USE PARAMETERIZATION C PARAMETERIZATION VALID ONLY IN RANGE [1E6,1E11] GEV IF ( SIGMAQ(3) .EQ. 0.D0) THEN SIGMA = EXP(1.851D0 + 0.2094D0*LOG10(ELAB)) * -1.042D0 + 0.7279D0*LOG10(ELAB) ELSE SIGMA = SIGMAQ(3) ENDIF ELSE C BOTTOM BARYONS C IF SIGMAQ==0 USE PARAMETERIZATION C PARAMETERIZATION VALID ONLY IN RANGE [1E6,1E11] GEV IF ( SIGMAQ(4) .EQ. 0.D0 ) THEN SIGMA = EXP(2.23D0 + 0.207D0*LOG10(ELAB)) * -0.9026D0 + 1.086D0*LOG10(ELAB) ELSE SIGMA = SIGMAQ(4) ENDIF ENDIF C AUXIL. QUANTITIES FOR INTERPOLATION SIG45 = SIGMA - 45.D0 S45SQ = SIG45**2 / 450.D0 S4530 = SIG45 / 30.D0 C INELASTIC CROSS-SECTIONS OF AIR FOR PROJECTILE WITH MASS NUMBER 1 SIGAIR = (1.D0 - 2.D0 * S45SQ) * SIG45A(1) * +(S45SQ - S4530) * SIG30A(1) * +(S45SQ + S4530) * SIG60A(1) #if __DPMJET__ || __EPOS__ || (__QGSJET__ && !__QGSII__) ENDIF #endif IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2 : SIGMA,SIGAIR=', * SNGL(SIGMA),SNGL(SIGAIR) CALL RMMARD( RD,2,1 ) C MEAN FREE PATH FOR INTERACTION (CHIINT) OR DECAY (CHI) CHIINT = (-LOG(RD(2))) * AVERAW / (AVOGDR * SIGAIR) #if __UPWARD__ IF ( COSTHE .LT. 0.D0 ) THEN CHIINT = MIN( CHIINT, -THICKH/COSTHE ) ENDIF #endif CHIINT = MAX( 0.D0, CHIINT ) IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2 : ITYPE,RD(2),CHIINT=', * ITYPE,SNGL(RD(2)),SNGL(CHIINT) IF ( DECTIM(ITYPE) .EQ. 0.D0 ) THEN WRITE(MONIOU,*) 'BOX2 : PARTICLE ',ITYPE,' NOT DEFINED' STOP ENDIF COR1 = (-LOG(RD(1))) * C(25) * DECTIM(ITYPE) IF ( SIGNUM(ITYPE) .EQ. 0.D0 ) THEN #if __CURVED__ C NEUTRAL PARTICLES CALL NRANGC( COR1*BETA*GAMMA ) #else DH = COR1 * BETA * GAMMA * COSTHE HDEC = MAX( H - DH, HLAY(1) - 1.D2 ) #if __UPWARD__ IF ( COSTHE .LT. 0.D0 ) THEN HDEC = MIN( HDEC, HLAY(6) ) ENDIF IF ( COSTHE .NE. 0.D0 ) THEN CHI = (THICK( HDEC )-THICKH)/COSTHE ENDIF #else CHI = (THICK( HDEC )-THICKH)/COSTHE #endif #endif ELSE C CHARGED PARTICLES #if __CURVED__ CALL PRANGC( COR1,.FALSE.,HNEW ) #else CALL PRANGE( COR1 ) #endif #if __UPWARD__ IF ( COSTHE .LT. 0.D0 ) THEN CHI = MIN( CHI, -THICKH/COSTHE ) ENDIF #endif ENDIF CHI = MAX( 0.D0, CHI ) IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2 : ITYPE,RD(1),CHIDEC=', * ITYPE,SNGL(RD(1)),SNGL(CHI) CHI = MIN( CHIINT, CHI ) IF ( CHI .LT. CHIINT ) THEN FDECAY = .TRUE. ELSE FDECAY = .FALSE. ENDIF ENDIF #if __DPMJET__ C DPMJET 3 CANNOT TREAT BOTTOM PROJECTILES C FORCE ALL BOTTOM PARTICLES WITH FORCED DECAY TO DECAY (JUST IN CASE) C BUT NOT LAMBDA(BOTTOM) AND ANTI-LAMBDA(BOTTOM) * IF ( ITYPE .GE. 182 .AND. ITYPE .NE. 184 * * .AND. ITYPE .NE. 190 ) THEN FDECAY = .TRUE. * ENDIF #elif __EPOS__ C EPOS CANNOT TREAT SEVERAL BOTTOM PARTICLES * IF ( ITYPE .EQ. ??? ) FDECAY = .TRUE. #elif __QGSJET__ && !__QGSII__ C FORCE ALL BOTTOM PARTICLES WITH FORCED DECAY TO DECAY (JUST IN CASE) C BUT NOT LAMBDA(BOTTOM) AND ANTI-LAMBDA(BOTTOM) * IF ( ITYPE .GE. 182 .AND. ITYPE .NE. 184 * * .AND. ITYPE .NE. 190 ) THEN FDECAY = .TRUE. * ENDIF #endif IF ( DEBUG ) WRITE(MDEBUG,*) * 'BOX2 : BOTTOM PARTICLE',ITYPE,' FDECAY=',FDECAY #endif C----------------------------------------------------------------------- C HEAVY PRIMARIES ( ITYPE = 100 * A + Z , FE -> ITYPE = 5656 ) C ( APPEARING AT FIRST INTERACTION AND AS REMNANTS OF THE PRIMARY ) ELSEIF ( ITYPE .GE. 200 ) THEN IA = ITYPE / 100 IF ( IA .GT. 56 ) THEN WRITE(MONIOU,*) WRITE(MONIOU,*) 'BOX2 : UNEXPECTED PARTICLE TYPE=',ITYPE WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORD: PRMPAR' STOP ENDIF C MEAN FREE PATH OF THE HEAVY PROJECTILE IS DEDUCED FROM THAT OF A NUCLEON C ONLY INELASTIC SCATTERING AT INTERACTIONS WITH HEAVY PROJECTILE/FRAGMENT ELAB = (PAMA(13) + PAMA(14)) * 0.5D0 * GAMMA PLAB = ELAB * BETA C CALCULATION OF CROSS-SECTION IN THE LOW ENERGY MODEL ELABT = ELAB * IA IF ( ELAB .LE. HILOELB ) THEN #if __FLUKA__ C FLUKA CANNOT TREAT HEAVY PROJECTILES FFLUSIG = .FALSE. #elif __GHEISHAD__ USELOW = .TRUE. C GHEISHA CANNOT TREAT NUCLEI GHESIG = .FALSE. ELSE #elif __URQMD__ USELOW = .TRUE. CALL URQSIG( ELABT,ITYPE ) FURQSG = .TRUE. GHESIG = .FALSE. ELSE FURQSG = .FALSE. #endif USELOW = .FALSE. GHESIG = .FALSE. ENDIF #if __DPMJET__ IF ( FDPJSG .AND. (ELAB .GE. HILOELB) ) THEN CALL DPJSIG( PLAB,ITYPE ) ELSE #elif __EPOS__ || __NEXUS__ IF ( FNEXSG .AND. (ELAB .GE. HILOELB) ) THEN CALL NEXSIG( ELAB,ITYPE ) ELSE #elif __QGSJET__ IF ( FQGSSG .AND. (ELAB .GE. HILOELB) ) THEN CALL QGSSIG( ELAB,ITYPE ) GOTO 333 ELSE #elif __SIBYLL__ IF ( FSIBSG .AND. (ELAB .GE. HILOELB) ) THEN CALL SIBSIG( ELAB,ITYPE ) GOTO 333 ELSE #elif __VENUS__ IF ( FVENSG .AND. (ELAB .GE. HILOELB) ) THEN CALL VENSIG( ELAB,ITYPE ) ELSE #endif #if __FLUKA__ C NO CROSS-SECTION AVAILABLE FOR FLUKA, USE GRIEDER MODEL C #elif __GHEISHAD__ IF ( GHESIG ) GOTO 333 #elif __URQMD__ C URQMD KNOWS LOW-ENERGY HEAVY PROJECTILE CROSS-SECTIONS IF ( FURQSG ) GOTO 333 #endif C SIGMA IS ENERGY DEPENDENT INELASTIC NUCLEON-NUCLEON CROSS-SECTION IF ( PLAB .LT. 1.D1 ) THEN SIGMA = 29.9D0 ELSEIF ( PLAB .LT. 1.D3 ) THEN PLABLG = LOG( PLAB ) C INELASTIC CROSS-SECTIONS FROM PARTICLE DATA GROUP C (A.BALDINI ET AL., LANDOLT-BOERNSTEIN NEW SERIES I/12B (1987) 150) SIGMA = 30.9D0 - 28.9D0 * PLAB**(-2.46D0) * + 0.192D0 * PLABLG**2 - 0.835D0 * PLABLG ELSE SIGMA = 19.87D0 * ELAB**.079D0 ENDIF #if __DPMJET__ || __EPOS__ || __NEXUS__ || __QGSJET__ || __SIBYLL__ || __VENUS__ ENDIF #endif C AUXIL. QUANTITIES FOR INTERPOLATION SIG45 = SIGMA - 45.D0 S45SQ = SIG45**2 / 450.D0 S4530 = SIG45 / 30.D0 C INELASTIC CROSS-SECTIONS OF AIR FOR PROJECTILE WITH MASS NUMBER IA SIGAIR = (1.D0 - 2.D0 * S45SQ) * SIG45A(IA) * +(S45SQ - S4530) * SIG30A(IA) * +(S45SQ + S4530) * SIG60A(IA) 333 CONTINUE IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2 : SIGMA,SIGAIR,GHESIG=', * SNGL(SIGMA),SNGL(SIGAIR),GHESIG C CHECK SIGAIR FOR CORRECT CROSS-SECTION IF ( SIGAIR .LE. 0.D0 ) THEN #if __FLUKA__ CHI = 0.D0 GOTO 334 #else WRITE(MONIOU,*) WRITE(MONIOU,*) 'BOX2: SIGAIR=0.D0, PROGRAM STOPPED ', * ' (UNALLOWED COMBINATION OF PROJECTILE WITH CROSS-SECTION)' WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORD: PRMPAR' STOP #endif ENDIF CALL RMMARD( RD,1,1 ) C MEAN FREE PATH FROM MOLECULAR WEIGHT, AVOGADRO''S CONSTANT AND SIGMA CHI = (-LOG( RD(1) )) * AVERAW / (AVOGDR * SIGAIR) #if __UPWARD__ IF ( COSTHE .LT. 0.D0 ) THEN CHI = MIN( CHI, -THICKH/COSTHE ) ENDIF #endif #if __FLUKA__ 334 CONTINUE #endif FDECAY = .FALSE. CHI = MAX( 0.D0, CHI ) IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2 : ITYPE,RD(1),CHI=', * ITYPE,SNGL(RD(1)),SNGL(CHI) C INTERACTION LENGTH STATISTICS CHI = MIN( 2.D9, CHI ) NI = 1.D0 + CHI * 0.1D0 NI = MIN( NI, 123 ) INNCHI( NI) = INNCHI( NI) + 1 INNCHI(124) = INNCHI(124) + 1 C----------------------------------------------------------------------- C ERROR IN PARTICLE CODE ELSE WRITE(MONIOU,*) WRITE(MONIOU,*) 'BOX2 : UNEXPECTED PARTICLE TYPE=',ITYPE WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORD: PRMPAR' STOP ENDIF RETURN END *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE BOX3 C----------------------------------------------------------------------- C CHECKS PASSAGE THROUGH OBSERVATION LEVEL(S) C IRET1=1 KILLS PARTICLE C IRET2=1 PARTICLE HAS BEEN CUTTED IN UPDATE C THIS SUBROUTINE IS CALLED FROM AAMAIN. C----------------------------------------------------------------------- IMPLICIT NONE #define __GENERINC__ #define __IRETINC__ #define __LONGIINC__ #define __OBSPARINC__ #define __PAMINC__ #define __PARPARINC__ #define __PARPAEINC__ #define __RANDPAINC__ #define __RUNPARINC__ #define __THNVARINC__ #include "corsika.h" DOUBLE PRECISION THICK INTEGER I,IRET3 #if __AUGERHIST__ INTEGER LL #endif #if __CURVED__ LOGICAL FLAG #else #if __MULTITHIN__ DOUBLE PRECISION HEIGH,HNEW,PROPAR(0:46),THCKHN #else #if __EHISTORY__ DOUBLE PRECISION HEIGH,HNEW,PROPAR(0:38),THCKHN #else DOUBLE PRECISION HEIGH,HNEW,PROPAR(0:8),THCKHN #endif #endif DOUBLE PRECISION FAC1,FAC2 INTEGER J LOGICAL IRETC EXTERNAL HEIGH #endif #if __SLANT__ INTEGER LBIN EXTERNAL LBIN #endif #if __COASTUSERLIB__ 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 SAVE EXTERNAL THICK C----------------------------------------------------------------------- #if __THIN__ IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=0,9),WEIGHT 444 FORMAT(' BOX3 : CURPAR=',1P,11E11.3) #else IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=0,9) 444 FORMAT(' BOX3 : CURPAR=',1P,10E11.3) #endif IF ( ITYPE .EQ. 5 .OR. ITYPE .EQ. 6 #if __CHARM__ || __TAULEP__ * .OR. ITYPE .EQ. 131 .OR. ITYPE .EQ. 132 #endif * ) THEN C MUONS/TAUS ARE TRACKED WITHIN SUBR. MUTRAC INT_ICOUNT = 0 CALL MUTRAC C CALL TO TSTEND IS DONE IN MUON ROUTINES MUTRAC RESP. MUNUCL IRET1 = 1 RETURN ELSEIF ( ITYPE .LE. 3 ) THEN C ELECTRONS OR GAMMAS ARE TREATED IN SUBR. EM CALL EM IRET1 = 1 RETURN ELSEIF ( ITYPE .GE. 50 .AND. ITYPE .LE. 65 ) THEN C RESONANCES DECAY WITHIN SUBR. RESDEC #if __SLANT__ #if __CURVED__ IF ( LLONGI ) LHEIGH = MIN( LBIN( X,Y,HAPP,1 ), NSTEP+1 ) #else IF ( LLONGI ) LHEIGH = MIN( LBIN( X,Y,H,1 ), NSTEP+1 ) #endif #else IF ( LLONGI ) LHEIGH = INT( THICK( H )*THSTPI + 1.D0 ) #endif INT_ICOUNT = 0 CALL RESDEC CALL TSTEND IRET1 = 1 RETURN ENDIF C FOR ALL THE OTHER PARTICLES THE PLACE OF NEXT INTERACTION WAS C DETERMINED IN BOX2 #if __CURVED__ C UPDATE PARTICLE TO INTERACTION POINT OR OBSERVATION LEVEL, C WHICHEVER IS CLOSER FLAG = .FALSE. CALL UPDATC( IRET3,FLAG ) IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX3 : IRET1,2,3=', * IRET1,IRET2,IRET3 IF ( IRET2 .NE. 0 ) THEN C PARTICLE CUTTED BEFORE INTERACTION POINT C LONGITUDINAL DEPOSIT IS ALREADY DONE IN UPDATC IRET1 = 1 RETURN ELSE C KILL PARTICLE AS IT IS AT DETECTOR LEVEL IF ( IRET3 .NE. 0 ) THEN IRET1 = 1 RETURN ELSE C STORE PARTICLE FOR FURTHER TREATMENT DO I = 0, 8 CURPAR(I) = OUTPAR(I) ENDDO #if __EHISTORY__ DO I = 17, 38 CURPAR(I) = OUTPAR(I) ENDDO #endif #if __MULTIHIST__ DO I = 40, 46 CURPAR(I) = OUTPAR(I) ENDDO #endif ALEVEL = H BETA = SQRT( (GAMMA-1.D0)*(GAMMA+1.D0) ) / GAMMA ENDIF #else C CALCULATE HEIGHT DIFFERENCE IN CM FROM GIVEN CHI IN G/CM**2 THCKHN = THICKH + COSTHE * CHI #if __UPWARD__ THCKHN = MAX( 0.D0, THCKHN ) #endif HNEW = HEIGH( THCKHN ) IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX3 : THICKH,THCKHN,HNEW=', * SNGL(THICKH),SNGL(THCKHN),SNGL(HNEW) C UPDATE PARTICLE TO INTERACTION POINT (IF IT REACHES SO FAR) C AND STORE COORDINATES IN PROPAR CALL UPDATE( HNEW,THCKHN,0 ) IF ( DEBUG ) THEN WRITE(MDEBUG,455) IRET1,IRET2 455 FORMAT(' BOX3 : IRET1..2=',2I5) IF ( IRET2 .EQ. 0 ) WRITE(MDEBUG,454) (OUTPAR(I),I=0,8) 454 FORMAT(' BOX3 : OUTPAR=',1P,9E11.3) ENDIF C STORE PARTICLE FOR FURTHER TREATMENT IF ( IRET2 .EQ. 0 ) THEN DO I = 0, 8 PROPAR(I) = OUTPAR(I) ENDDO #if __EHISTORY__ DO I = 17, 38 PROPAR(I) = OUTPAR(I) ENDDO #endif #if __MULTITHIN__ DO I = 41, 46 PROPAR(I) = OUTPAR(I) ENDDO #endif IRET3 = 0 ELSE C PARTICLE CUTTED AT INTERACTION POINT; IT MAY HOWEVER PASS SOME OF THE C OBSERVATION LEVELS IRET3 = 1 IRETC = IRETE ENDIF #if __COASTUSERLIB__ C DO NOT PASS LOWEST OBERVATION LEVEL IF ( HNEW .GT. OBSLEV(NOBSLV) .AND. IRET2 .EQ. 0 ) * call track(pnt1x, pnt2x) #endif C CHECK OBSERVATION LEVEL PASSAGE AND UPDATE PARTICLE COORDINATES DO 1 J = 1, NOBSLV #if __UPWARD__ IF ( COSTHE .LT. 0.D0 ) THEN IF ( HNEW .LT. OBSLEV(J) ) GOTO 2 IF ( H .GT. OBSLEV(J) ) GOTO 1 ELSE IF ( HNEW .GT. OBSLEV(J) ) GOTO 2 IF ( H .LT. OBSLEV(J) ) GOTO 1 ENDIF #else IF ( HNEW .GT. OBSLEV(J) ) GOTO 2 IF ( H .LT. OBSLEV(J) ) GOTO 1 #endif C REMEMBER NUMBER OF LEVEL FOR OUTPUT LEVL = J CALL UPDATE( OBSLEV(J),THCKOB(J),J ) IF (DEBUG) WRITE(MDEBUG,456) J,IRET1,IRET2 456 FORMAT(' BOX3 : LEVEL ',I5,' IRET1,2=',2I5) C IF PARTICLE IS NOT CUTTED, BRING IT TO OUTPUT IF ( IRET2 .EQ. 0 ) THEN CALL OUTPT1 ELSE IF ( LLONGI .AND. LEVL .EQ. NOBSLV .AND. .NOT.IRETE ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT #if __SLANT__ LHEIGH = MIN( LBIN( X,Y,H,1 ), NSTEP+1 ) #else LHEIGH = INT( THICKH*THSTPI + 1.D0 ) #endif IF ( ITYPE .EQ. 8 .OR. ITYPE .EQ. 9 .OR. * ITYPE .EQ. 11 .OR. ITYPE .EQ. 12 ) THEN FAC1 = 0.25D0 FAC2 = 0.75D0 ELSEIF ( ITYPE .EQ. 10 .OR. ITYPE .EQ. 16 ) THEN FAC1 = 0.5D0 FAC2 = 0.5D0 ELSE FAC1 = 1.D0 FAC2 = 0.D0 ENDIF #if __THIN__ C ADD TO THE HADRON ENERGY DEPOSIT DLONG(LHEIGH,7) = DLONG(LHEIGH,7) + ( GAMMA*PAMA(ITYPE) * - RESTMS(ITYPE) ) * WEIGHT * FAC1 C ADD TO THE NEUTRINO DEPOSIT DLONG(LHEIGH,8) = DLONG(LHEIGH,8) + ( GAMMA*PAMA(ITYPE) * - RESTMS(ITYPE) ) * WEIGHT * FAC2 #else C ADD TO THE HADRON ENERGY DEPOSIT DLONG(LHEIGH,7) = DLONG(LHEIGH,7) + ( GAMMA * PAMA(ITYPE) * - RESTMS(ITYPE) ) * FAC1 C ADD TO THE NEUTRINO DEPOSIT DLONG(LHEIGH,8) = DLONG(LHEIGH,8) + ( GAMMA * PAMA(ITYPE) * - RESTMS(ITYPE) ) * FAC2 #endif #if __AUGERHIST__ IF ( DEBUG .AND. IRETC ) WRITE(MDEBUG,446) (CURPAR(I),I=0,9) 446 FORMAT(' BOX3A : E-DEP',2X,1P,9E11.3,0P,F10.0) IF ( IRETC .AND. LEVL .EQ. NOBSLV ) THEN DO LL = 1, NOBSLV IF ( THCKHN .GE. THCKOB(LL) .AND. * THCKHN .LT. THCKOB(LL)+SAMPTH ) THEN C THCKHN AFTER TRANSPORT IS WITHIN 1 G/CM^2 BELOW OBSLEV(LL) C BRING THE ENERGY BELOW CUT TO THE HISTO OF LEVEL LL IF (DEBUG) WRITE(MDEBUG,*) 'BOX3A : THCKHN=',THCKHN CALL AUGCUT( LL ) ELSEIF ( THCKHN .LT. THCKOB(LL) ) THEN GOTO 111 ENDIF ENDDO 111 CONTINUE ENDIF #endif ENDIF ENDIF 1 CONTINUE #if __COASTUSERLIB__ C TRACK PARTICLE TO LOWEST OBSERVATION LEVEL IF ( IRET2 .EQ. 0 ) call track(pnt1x, pnt2x) #endif C KILL PARTICLE AS IT DECAYS OR INTERACTS BELOW LOWEST OBSLEVEL IRET1 = 1 RETURN C PARTICLE INTERACTS OR DECAYS BEFORE PASSING OBSLEVEL 2 CONTINUE C PARTICLE IS NOW UPDATED TO POINT OF INTERACTION IF ( IRET3 .EQ. 0 ) THEN DO J = 0, 8 CURPAR(J) = PROPAR(J) ENDDO #if __EHISTORY__ DO J = 17, 38 CURPAR(J) = PROPAR(J) ENDDO #endif #if __MULTITHIN__ DO J = 41, 46 CURPAR(J) = PROPAR(J) ENDDO #endif ALEVEL = H BETA = SQRT( (GAMMA-1.D0)*(GAMMA+1.D0) ) / GAMMA ELSE C ELIMINATE PARTICLE IF BELOW CUTS IRET1 = 1 IF ( LLONGI .AND. .NOT.IRETE ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT #if __AUGERHIST__ IF ( DEBUG .AND. IRETC ) WRITE(MDEBUG,445) (CURPAR(I),I=0,9) 445 FORMAT(' BOX3B : E-DEP',2X,1P,9E11.3,0P,F10.0) #endif #if __SLANT__ LHEIGH = MIN( LBIN( X,Y,H,1 ), NSTEP+1 ) #else LHEIGH = INT( THICKH*THSTPI + 1.D0 ) #endif IF ( ITYPE .EQ. 8 .OR. ITYPE .EQ. 9 .OR. * ITYPE .EQ. 11 .OR. ITYPE .EQ. 12 ) THEN FAC1 = 0.25D0 FAC2 = 0.75D0 ELSEIF ( ITYPE .EQ. 10 .OR. ITYPE .EQ. 16 ) THEN FAC1 = 0.5D0 FAC2 = 0.5D0 ELSE FAC1 = 1.D0 FAC2 = 0.D0 ENDIF #if __THIN__ C ADD TO THE HADRON ENERGY DEPOSIT DLONG(LHEIGH,7) = DLONG(LHEIGH,7) + ( GAMMA*PAMA(ITYPE) * - RESTMS(ITYPE) ) * WEIGHT * FAC1 C ADD TO THE NEUTRINO DEPOSIT DLONG(LHEIGH,8) = DLONG(LHEIGH,8) + ( GAMMA*PAMA(ITYPE) * - RESTMS(ITYPE) ) * WEIGHT * FAC2 #else C ADD TO THE HADRON ENERGY DEPOSIT DLONG(LHEIGH,7) = DLONG(LHEIGH,7) + ( GAMMA * PAMA(ITYPE) * - RESTMS(ITYPE) ) * FAC1 C ADD TO THE NEUTRINO DEPOSIT DLONG(LHEIGH,8) = DLONG(LHEIGH,8) + ( GAMMA * PAMA(ITYPE) * - RESTMS(ITYPE) ) * FAC2 #endif ENDIF #if __AUGERHIST__ IF ( IRETC ) THEN C PARTICLE FALLS BELOW ENERGY CUT DO LL = 1, NOBSLV IF ( THCKHN .GE. THCKOB(LL) .AND. * THCKHN .LT. THCKOB(LL)+SAMPTH ) THEN C THCKHN AFTER TRANSPORT IS WITHIN 1 G/CM^2 BELOW OBSLEV(LL) IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX3B : THCKHN=',THCKHN C BRING THE (ENERGY BELOW CUT) TO THE HISTO OF LEVEL LL CALL AUGCUT( LL ) ELSEIF ( THCKHN .LT. THCKOB(LL) ) THEN GOTO 112 ENDIF ENDDO 112 CONTINUE ENDIF #endif #endif ENDIF RETURN END *-- Author : D. HECK IK FZK KARLSRUHE 12/05/2003 C======================================================================= DOUBLE PRECISION FUNCTION CBRSGM( ELAB,MAT,MUTAU ) C----------------------------------------------------------------------- C C(ALCULATE) BR(EMSSTRAHLUNG) S(I)G(MA FOR) M(UONS/TAU LEPTONS) C C CALCULATES THE CROSS-SECTION IN CURRENT MATERIAL FOR DISCRETE (HARD) C MUON/TAU BREMSSTRAHLUNG. (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/TAU (GEV) C MAT = MATERIAL INDEX: 1=14N, 2=16O, 3=40AR C MUTAU = LEPTON INDEX: 1=MU, 2=TAU C----------------------------------------------------------------------- IMPLICIT NONE #define __MUPARTINC__ #define __RUNPARINC__ #define __SIGMUINC__ #include "corsika.h" DOUBLE PRECISION DELTAE,ELAB,WK(3),YE INTEGER I,JE,MAT,MUTAU SAVE 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 CBRSGM = 0.D0 DO I = 1, 3 CBRSGM = CBRSGM + BREMSTAB(JE+I-1,MAT,MUTAU)*WK(I) ENDDO CBRSGM = EXP( CBRSGM ) C IF ( DEBUG ) WRITE(MDEBUG,444) ELAB,MAT,CBRSGM C 444 FORMAT(' CBRSGM: E=',1P,E10.4,' MAT=',I3,' MUTAU=',MUTAU, C * ' CBRSGM=',E12.5) RETURN END *-- Author : D. HECK IK FZK KARLSRUHE 25/06/2003 C======================================================================= DOUBLE PRECISION FUNCTION CDEDXM( ELAB ) C----------------------------------------------------------------------- C C(ALCULATE) DE/DX (FOR) M(UON) C C CALCULATES THE CONTINUOUS ENERGY LOSS OF MUONS/TAU LEPTONS C BY BREMSSTRAHLUNG, PAIR PRODUCTION AND NUCL. INTERACTIONS IN AIR C (IN GEV G**-1 CM**2). 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 THIS FUNCTION IS CALLED FROM PRANGC, PRANGE, UPDATE, AND AUGEDP. C ARGUMENT: C ELAB = TOTAL ENERGY OF MUON (GEV) C----------------------------------------------------------------------- IMPLICIT NONE #define __MUPARTINC__ #define __RUNPARINC__ #define __SIGMUINC__ #include "corsika.h" DOUBLE PRECISION DELTAE,ELAB,WK(3),YE INTEGER I,JE SAVE 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 CDEDXM = 0.D0 DO I = 1, 3 CDEDXM = CDEDXM + DEDXM(JE+I-1,MT)*WK(I) ENDDO C IF ( DEBUG ) WRITE(MDEBUG,444) ELAB,CDEDXM C 444 FORMAT(' CDEDXM: E=',1P,E10.4,' CDEDXM=',E12.5) RETURN END #if __CHARM__ || __TAULEP__ *-- Author : D. HECK IK FZK KARLSRUHE 13/03/2007 C======================================================================= SUBROUTINE CHRMDC C----------------------------------------------------------------------- C CH(A)RM(ED PARTICLE) D(E)C(AY) C C ROUTINE TREATES DECAY OF CHARMED PARTICLES AND TAU LEPTONS. C DECAY IS TREATED BY PYTHIA. C THIS SUBROUTINE IS CALLED FROM MUTRAC AND NUCINT. C----------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION(A-H, O-Z) #define __IRETINC__ #define __LONGIINC__ #define __PAMINC__ #define __PARPARINC__ #define __PARPAEINC__ #define __PYTLININC__ #define __RANDPAINC__ #define __RUNPARINC__ #define __STRBARINC__ #include "corsika.h" C...Pythia parameters. COMMON/PYDAT1/ MSTU(200),PARU(200),MSTJ(200),PARJ(200) C...Pythia decay information. COMMON/PYDAT3/ MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) DOUBLE PRECISION PE,THICK INTEGER IRAND(3) INTEGER I,IP,KC,KF #if __DPMJET__ || __QGSJET__ || __SIBYLL__ INTEGER PYCOMP EXTERNAL PYCOMP #endif #if __SLANT__ INTEGER LBIN EXTERNAL LBIN #endif SAVE EXTERNAL THICK C----------------------------------------------------------------------- #if __THIN__ IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=0,9),WEIGHT 444 FORMAT(' CHRMDC: CURPAR=',1P,11E11.3) #else IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=0,9) 444 FORMAT(' CHRMDC: CURPAR=',1P,10E11.3) #endif IF ( IFLGPYE .GT. 0 ) THEN C ENABLE PRINTING OF PYTHIA ERRORS MSTU(22) = IFLGPYE ELSE C SUPPRESS PYTHIA ERRORS MSTU(22) = 10 ! suppress pythia error messages after 10 messages ENDIF IF ( IFLGPYW .GT. 0 ) THEN C ENABLE PYTHIA WARNINGS MSTU(25) = 1 MSTU(26) = IFLGPYW ELSE C SUPPRESS PYTHIA WARNINGS MSTU(25) = 0 MSTU(26) = 0 ENDIF C COPY VERTEX COORDINATES TO SECPAR DO I = 5, 8 SECPAR(I) = CURPAR(I) ENDDO C GENERATION COUNTER IS NOT INCREMENTED IN CHARM PARTICLE DECAY SECPAR( 9) = GEN SECPAR(10) = ALEVEL #if __THIN__ SECPAR(13) = WEIGHT #endif #if __CURVED__ SECPAR(14) = CURPAR(14) SECPAR(15) = CURPAR(15) SECPAR(16) = CURPAR(16) #endif #if __INTTEST__ SECPAR(17) = CURPAR(17) #endif #if __EHISTORY__ DO I = 17, 38 SECPAR(I) = CURPAR(I) ENDDO #endif #if __PARALLEL__ C SET ECTFLG TO OFF SECPAR(39) = CURPAR(39) #endif #if __MULTITHIN__ DO I = 41, 46 SECPAR(I) = CURPAR(I) ENDDO #endif #if __SLANT__ #if __CURVED__ IF ( LLONGI ) LHEIGH = MIN( LBIN( X,Y,HAPP,1 ), NSTEP+1 ) #else IF ( LLONGI ) LHEIGH = MIN( LBIN( X,Y,H,1 ), NSTEP+1 ) #endif #else IF ( LLONGI ) LHEIGH = INT( THICK( H )*THSTPI + 1.D0 ) #endif C ENABLE THE DECAY OF THE INCOMING PARTICLE C ALL OTHER PARTICLES (CHARM, BOTTOM, TAU-LEPTON) ARE NOT DECAYING C AND HAVE BEEN SET STABLE IN SUBR. PYTDCSET ITYPE = NINT( CURPAR(0) ) KF = IPTABL(ITYPE) KC = PYCOMP(KF) MDCY(KC,1) = 1 IF ( DEBUG ) THEN C RANDOM GENERATOR STATUS (SEQUENCE LL=1) AT BEGINNING OF EVENT LL = 1 CALL RMMAQD( ISEED(1,LL),LL,'R' ) C SEED IRAND(1) = ISEED(1,LL) C NUMBER OF CALLS IRAND(2) = ISEED(2,LL) C NUMBER OF BILLIONS IRAND(3) = ISEED(3,LL) WRITE(MDEBUG,158) (IRAND(J),J=1,3) 158 FORMAT(' CHRMDC: RANDOM NUMBER GENERATOR AT BEGIN:', * ' SEQUENCE= 1 SEED= ',I9,' CALLS=',I9, * ' BILLIONS=',I9) ENDIF C FILL PYTHIA COMMONS WITH ONE PARTICLE TO TREAT IT''S DECAY PE = PAMA(ITYPE) * CURPAR(1) C WITH ARGUMENT IP = 0 AUTOMATICALLY PYEXEC IS CALLED IP = 0 CALL PY1ENT( IP, KF, PE, 0.D0, 0.D0 ) C C STORE SECONDARY PARTICLES TO STACK CALL PYTSTO C RESET DECAY ENABLING OF INCOMING PARTICLE TYPE KC = PYCOMP(KF) MDCY(KC,1) = 0 RETURN END #endif *-- Author : The CORSIKA development group 16/05/1995 C======================================================================= DOUBLE PRECISION FUNCTION CHISQ( F ) C----------------------------------------------------------------------- C 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 ARGUMENTS: 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----------------------------------------------------------------------- IMPLICIT NONE #define __CURVEINC__ #define __RUNPARINC__ #include "corsika.h" DOUBLE PRECISION AUXIL,BALL,BASE,EXPO,F(6),T,WIDTH INTEGER I SAVE C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'CHISQ : PARAMETERS,NSTP =', * (SNGL(F(I)),I=1,6),NSTP 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 CHISQ = 1.D16 RETURN ENDIF CHISQ = 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 CHISQ = CHISQ + 1.D16 GOTO 1 ENDIF EXPO = (F(3)-F(2)) / WIDTH AUXIL = (F(3)-T) / WIDTH IF ( ABS(AUXIL) .GT. 20.D0 ) THEN CHISQ = CHISQ + 1.D16 GOTO 1 ENDIF BALL = F(1) * BASE ** EXPO * EXP( AUXIL ) ELSE BALL = 0.D0 ENDIF CHISQ = CHISQ + ((BALL-CHAPAR(I))/ERR(I))**2 1 CONTINUE CHISQ = CHISQ / (NSTP-6) IF ( DEBUG ) WRITE(MDEBUG,*) 'CHISQ : CHI**2 =',SNGL(CHISQ) RETURN END *-- Author : The CORSIKA development group 16/05/1995 C======================================================================= DOUBLE PRECISION FUNCTION CHISQ1( F ) C----------------------------------------------------------------------- C CHI SQ(UARE FOR THE) 1(ST FIT FUNCTION) 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 ARGUMENTS: C F(1) = HEIGHT AT MAXIMUM C F(2) = SHOWER STARTING POINT C F(3) = T AT MAXIMUM C F(4) = WIDTH PARAMETER C----------------------------------------------------------------------- IMPLICIT NONE #define __CURVEINC__ #define __RUNPARINC__ #include "corsika.h" DOUBLE PRECISION AUXIL,BALL,BASE,EXPO,F(6),T INTEGER I SAVE C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*)'CHISQ1: PARAMETERS,NSTP =', * (SNGL(F(I)),I=1,4),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 CHISQ1 = 1.D16 RETURN ENDIF CHISQ1 = 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 CHISQ1 = CHISQ1 + 1.D16 GOTO 1 ENDIF EXPO = (F(3)-F(2)) / AUXIL AUXIL = (F(3)-T) / AUXIL IF ( ABS(AUXIL) .GT. 20.D0 ) THEN CHISQ1 = CHISQ1 + 1.D16 GOTO 1 ENDIF BALL = F(1) * BASE ** EXPO * EXP( AUXIL ) ELSE BALL = 0.D0 ENDIF CHISQ1 = CHISQ1 + ((BALL-CHAPAR(I))/ERR(I))**2 1 CONTINUE CHISQ1 = CHISQ1 / (NSTP-4) IF ( DEBUG ) WRITE(MDEBUG,*) 'CHISQ1 : CHI**2 =',SNGL(CHISQ1) RETURN END *-- Author : D. HECK IK FZK KARLSRUHE 15/05/2003 C======================================================================= DOUBLE PRECISION FUNCTION CNUSGM( ELAB,MAT,MUTAU ) C----------------------------------------------------------------------- C C(ALCULATE) NU(CLEAR INTERACTION) S(I)G(MA FOR) M(UONS/TAU LEPTONS) C C CALCULATES THE CROSS-SECTION IN CURRENT MATERIAL FOR DISCRETE (HARD) C MUON/TAU 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/TAU (GEV) C MAT = MATERIAL INDEX: 1=14N, 2=16O, 3=40AR C MUTAU = LEPTON INDEX: 1=MU, 2=TAU C----------------------------------------------------------------------- IMPLICIT NONE #define __MUPARTINC__ #define __RUNPARINC__ #define __SIGMUINC__ #include "corsika.h" DOUBLE PRECISION DELTAE,ELAB,WK(3),YE INTEGER I,JE,MAT,MUTAU SAVE 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 CNUSGM = 0.D0 DO I = 1, 3 CNUSGM = CNUSGM + NUCTAB(JE+I-1,MAT,MUTAU)*WK(I) ENDDO CNUSGM = EXP( CNUSGM ) C IF ( DEBUG ) WRITE(MDEBUG,444) ELAB,MAT,CNUSGM C 444 FORMAT(' CNUSGM: E=',1P,E10.4,' MAT=',I3,' MUTAU=',MUTAU, C * ' CNUSGM=',E12.5) RETURN END *-- Author : T. PIEROG IKP KIT KARLSRUHE 05/07/2016 C======================================================================= SUBROUTINE CDEFROT(EP,S0X,C0X,S0,C0) c----------------------------------------------------------------------- c Determination of the parameters for a spacial rotation to the lab. c system 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 c model - 17.09.2003 and updated to standart Euler rotation 17.11.2004. c----------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION EP(3) SAVE c----------------------------------------------------------------------- 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 c (C0 = cos theta, 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 RETURN END *-- Author : T. PIEROG IKP KIT KARLSRUHE 05/07/2016 C======================================================================= SUBROUTINE CROTAT(EP,S0X,C0X,S0,C0,IS) 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 costhet*sinphi sinthet*sinphi | c (x y z) = (X Y Z) . | -sinphi costhet*cosphi cosphi*sinthet | c | 0 -sinthet 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 if IS < 0, inverse matrix is used to transform (x y z) to (X Y Z) c | cosphi -sinphi 0 | c (X Y Z) = (x y z) . | costhet*sinphi costhet*cosphi -sinthet | c | sinthet*sinphi sinthet*cosphi costhet | c----------------------------------------------------------------------- IMPLICIT NONE DOUBLE PRECISION EP(3),EP1(3),S0X,C0X,S0,C0 INTEGER IS SAVE c----------------------------------------------------------------------- IF ( IS .GE. 0 ) THEN 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 ELSE EP1(3) = EP(3) EP1(2) = EP(1)*S0X+EP(2)*C0X EP1(1) = EP(1)*C0X-EP(2)*S0X EP(1) = EP1(1) EP(3) = EP1(2)*S0+EP1(3)*C0 EP(2) = EP1(2)*C0-EP1(3)*S0 ENDIF RETURN END #if __CURVED__ *-- Author : F. SCHROEDER UNI WUPPERTAL 18/11/1998 C======================================================================= SUBROUTINE COOINC C----------------------------------------------------------------------- C COO(RDINATE) IN(ITIALIZATION FOR A) C(URVED ATMOSPHERE) C C INITIALIZES ALL IMPORTANT COORDINATES FOR ONE OBSERVATION LEVEL C ROUTINE DETERMINES STARTING PARAMETERS AT HEIGHT GIVEN BY THICK0 FOR C A COORDINATE SYSTEM WHICH IS FIXED IN (X,Y) AT THE ASSUMED DETECTOR C POSITION AND IN Z AT DETECTOR LEVEL. C THIS SUBROUTINE IS CALLED FROM AAMAIN. C----------------------------------------------------------------------- IMPLICIT NONE #define __OBSPARINC__ #define __PARPAEINC__ #define __PARPARINC__ #define __RUNPARINC__ #define __TIMLIMINC__ #if __SLANT__ || __COAST__ #define __LONGIINC__ #endif #if __SLANT__ #define __ATMOSINC__ #define __ATMOS2INC__ #define __ATMOSLINC__ #endif #include "corsika.h" DOUBLE PRECISION AUXIL,DIST,TEA,THETA,DIAG #if __SLANT__ DOUBLE PRECISION AUXILH,DIAGFR,DIAGH,DISTI,DT,D1,D2,HH,HH1,HH2, * H1,H2,RIMPCT,STH,THCKMX,THCKTOT,XXX,YYY #if __UPWARD__ DOUBLE PRECISION DT1,DT2,HHHH2(500),THCKTOT1,THCKTOT2 #endif INTEGER I,I3,JINV DOUBLE PRECISION HEIGH,HEIGHTD,RHOF,THICK EXTERNAL HEIGH,HEIGHTD,RHOF,THICK #elif __COAST__ INTEGER I #endif SAVE C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'COOINC: H,COSTAP,PHI =', * SNGL(H),SNGL(COSTAP),SNGL(PHIP) C NOTE : ANGLES THETAP AND PHIP ARE APPARENT ANGLES OF PRIMARY AT C THE EDGE OF THE ATMOSPHERE SEEN FROM THE C DETECTOR POSITION X=Y=0, Z=OBSLEV(1) C FOR CALCULATIONS: COSTAP = COSINE OF APPARENT ZENITH ANGLE THETAP C OF PARTICLE POSITION C COSTAP IS SET IN AAMAIN BY EQUIVALENCE WITH CURPAR(15) #if __UPWARD__ IF ( FIMPCT ) THEN COSTAP = 0.D0 C DISTANCE DIAG BETWEEN DETECTOR POSITION X=Y=0, Z = HIMPCT AND C STARTING POINT AUXIL = (C(1)+H)**2 - (C(1)+HIMPCT)**2 DIAG = SQRT( AUXIL ) C APPARENT HEIGHT HAPP IS PARTICLE Z-COORDINATE IN DETECTOR SYSTEM HAPP = HIMPCT C CALCULATING COSINE OF THETA_EARTH COSTEA, COSINE OF ZENITH ANGLE BY C TAKING A COORDINATE FRAME CENTERED IN THE MIDDLE OF EARTH COSTEA = ( C(1) + HIMPCT ) / ( C(1) + H ) IF ( DEBUG ) WRITE(MDEBUG,89) HAPP,COSTEA,DIAG 89 FORMAT(' COOINC: HIMPCT=',F10.2,' COSTEA=',F16.13, * ' DIAG=',F15.2) COSTEA = MIN( 1.D0, COSTEA ) C TRANSFORM THE APPARENT ANGLE SEEN FROM DETECTOR POSITION TO LOCAL C ANGLES RELATIVE TO THE VERTICAL TO THE MIDDLE OF EARTH COSTHE = DIAG / ( C(1) + H ) ELSE C DISTANCE DIAG BETWEEN DETECTOR POSITION X=Y=0, Z = OBSLEV(1) AND C STARTING POINT AUXIL = (C(1)+H)**2 - (C(1)+OBSLEV(1))**2 * * (1.D0-COSTAP)*(1.D0+COSTAP) IF ( PRMPAR(15) .LT. 0.D0 ) THEN DIAG = -SQRT( AUXIL ) - (C(1)+OBSLEV(1)) * COSTAP ELSE DIAG = SQRT( AUXIL ) - (C(1)+OBSLEV(1)) * COSTAP ENDIF C APPARENT HEIGHT HAPP IS PARTICLE Z-COORDINATE IN DETECTOR SYSTEM HAPP = OBSLEV(1) + DIAG * COSTAP C CALCULATING COSINE OF THETA_EARTH COSTEA, COSINE OF ZENITH ANGLE BY C TAKING A COORDINATE FRAME CENTERED IN THE MIDDLE OF EARTH COSTEA = (C(1)+HAPP) / (C(1)+H) IF ( DEBUG ) WRITE(MDEBUG,90) HAPP,COSTEA,DIAG 90 FORMAT(' COOINC: HAPP=',F12.2,' COSTEA=',F16.13,' DIAG=',F15.2) COSTEA = MIN( 1.D0, COSTEA ) C TRANSFORM THE APPARENT ANGLE SEEN FROM DETECTOR POSITION TO LOCAL C ANGLES RELATIVE TO THE VERTICAL TO THE MIDDLE OF EARTH C NOTE : LOCAL ZENITH ANGLE = DIFFERENCE OF APPARENT ZENITH ANGLE AND C THETA_EARTH COSTHE = (DIAG + (C(1)+OBSLEV(1))*COSTAP)/(C(1)+H) COSTHE = SIGN( COSTHE, COSTAP ) ENDIF #else C DISTANCE DIAG BETWEEN DETECTOR POSITION X=Y=0, Z = OBSLEV(1) AND C STARTING POINT AUXIL = (C(1)+H)**2 - (C(1)+OBSLEV(1))**2 * * (1.D0-COSTAP)*(1.D0+COSTAP) DIAG = SQRT( AUXIL ) - (C(1)+OBSLEV(1)) * COSTAP C APPARENT HEIGHT HAPP IS PARTICLE Z-COORDINATE IN DETECTOR SYSTEM HAPP = OBSLEV(1) + DIAG * COSTAP C CALCULATING COSINE OF THETA_EARTH COSTEA, COSINE OF ZENITH ANGLE BY C TAKING A COORDINATE FRAME CENTERED IN THE MIDDLE OF EARTH COSTEA = (C(1)+HAPP) / (C(1)+H) IF ( DEBUG ) WRITE(MDEBUG,*) 'COOINC: HAPP,COSTEA,DIAG =', * SNGL(HAPP),COSTEA,SNGL(DIAG) COSTEA = MIN( 1.D0, COSTEA ) C TRANSFORM THE APPARENT ANGLE SEEN FROM DETECTOR POSITION TO LOCAL C ANGLES RELATIVE TO THE VERTICAL TO THE MIDDLE OF EARTH C NOTE : LOCAL ZENITH ANGLE = DIFFERENCE OF APPARENT ZENITH ANGLE AND C THETA_EARTH COSTHE = (DIAG + (C(1)+OBSLEV(1))*COSTAP)/(C(1)+H) #endif C SET TIME LIMIT TO AVOID UNNECESSARY COMPUTING TIME WITH PARTICLES C WELL ABOVE THE TIME LIMIT. THE TIME LIMIT IS GIVEN BY THE C PROPAGATION TIME ALONG DIAD WITH SPEED OF LIGHT AND SOME ADDITIONAL C DISTANCE DOWNSTREAM OF THE DETECTOR DLIMIT (CM). C FOR SAFETY ADD ADDITIONAL 20 MICROSEC. (ALL TIME UNITS IN SEC) IF ( DSTLIM .GT. 0.D0 ) THEN TIMLIM = ( DIAG + DSTLIM ) / C(25) + 2.D-5 ELSE C DEFAULT LIMIT IS 20 KM TIMLIM = ( DIAG + 20.D5 ) / C(25) + 2.D-5 ENDIF IF ( DEBUG .OR. LTMLMPR ) WRITE(MDEBUG,*) 'COOINC: DIAG=',DIAG, * 'DSTLIM=',DSTLIM,' TIMLIM=',TIMLIM C DISTANCE DIST BETWEEN THE DETECTOR POSITION X=0, Y=0 C AND THE ACTUAL INTERACTION POINT MEASURED ON THE EARTH''S SURFACE TEA = ACOS( COSTEA ) DIST = C(1) * TEA C CONCERNING TRANSFORMATION OF AZIMUTH ANGLE PHI C NOTE : THE COORDINATE SYTEMS ONLY DIFFER IN A SHIFT ALONG THE Z-AXIS C OR A ROTATION ALONG THE ZENITH ANGLE. BOTH TRANSFORMATIONS C JUST CHANGE THETA AND NOT PHI (THETA AND PHI ARE ORTHOGONAL C COORDINATES, THUS LINEAR INDEPENDENT). C RESET CLOCK AT ENTRANCE INTO ATMOSPHERE T = 0.D0 C X,Y-COORDINATES SEEN FROM THE DETECTOR POSITION (X=Y=0) X = -DIST * COS( PHIP ) Y = -DIST * SIN( PHIP ) IF ( DEBUG ) WRITE(MDEBUG,91) X,Y,COSTHE,DIST 91 FORMAT(' COOINC: X,Y,COSTHE,DIST=',4G15.8) C FILL PARAMETERS IN PRMPAR PRMPAR(2) = COSTHE PRMPAR(6) = T PRMPAR(7) = X PRMPAR(8) = Y THETA = ACOS( COSTHE ) PRMPAR(3) = SIN( THETA ) * COS( PHIP ) PRMPAR(4) = SIN( THETA ) * SIN( PHIP ) C WE HAVE EQUIVALENCES FOR HAPP AND COSTEA C CURPAR(14) = HAPP C CURPAR(16) = COSTEA #if __SLANT__ IF ( LLONGI ) THEN C SET DIRECTION COSINES OF SHOWER AXIS C TO CALCULATE DIST=X*STHCPH + Y*STHSPH + Z*CTH=SQRT(X*X+Y*Y+Z*Z) C IN OBSERVER FRAME CTH = PRMPAR(15) STH = SIN( THETAP ) STHCPH = STH * COS( PHIP ) STHSPH = STH * SIN( PHIP ) C SET ZERO POPINT OF SLANT LONGITUDINAL DISTANCE XXX = -DIAG * STHCPH YYY = -DIAG * STHSPH HH1 = HAPP C SET AUXILIARY ARRAYS CCATM, HLAYC DO I = 1, 5 CCATM(I) = LOG( BATM(I)/CATM(I) ) ENDDO DO I = 1, 5 HLAYC(I) = HLAY(I) ENDDO HLAYC(6) = 5.D7 !500 KM HGROUND = OBSLEV(1) RADGRD = C(1) + HGROUND #if __STACKIN__ HH = PRMPAR(5) #else HH = HEIGH( THICK0 ) #endif IF ( DEBUG ) WRITE(MDEBUG,102) HGROUND,RADGRD,HH 102 FORMAT(' COOINC: HGROUND,RADGRD,HH=',3G15.8) H1 = HH C OFFSET FOR SLANT DISTANCE RLOFF = HH1 * CTH - XXX * STHCPH - YYY * STHSPH IF ( FIX1I .AND. PRMPAR(0) .LE. 3.D0 ) THEN C CORRECT OFFSET FOR EM PRIMARIES AUXILH = (C(1)+FIXHEI)**2 - (C(1)+OBSLEV(1))**2 * * (1.D0-COSTAP)*(1.D0+COSTAP) DIAGH = SQRT( AUXILH ) - (C(1)+OBSLEV(1)) * COSTAP RLOFF = RLOFF + DIAGH + (HH-FIXHEI) * CTH ENDIF IF ( DEBUG ) WRITE(MDEBUG,103) STHCPH,STHSPH,CTH,RLOFF,DIAG C CLEAR ALL ARRAYS DO I = 1, MAXSLANT PATH1(I) = 0.D0 RHOSLT(I) = 0.D0 TSLANT(I) = 0.D0 ENDDO #if __UPWARD__ C CALCULATE IMPACT RADIUS RIMPCT AND MAX SLANT DEPTH DT IF ( FIMPCT ) THEN C SHOWER AXIS WITH SKIMMING INCIDENCE RIMPCT = HIMPCT + C(1) C FIRST FRACTION OF PATH BETWEEN STARTING POINT AND SKIMMING POINT DT1 = DIAG D1 = DIAG IF ( DEBUG ) WRITE(MDEBUG,104) DT1,H1,D1,RIMPCT 104 FORMAT(' COOINC: DT1,H1,D1,RIMPCT=',4G15.8) CALL DL2DT( DT1,THCKTOT1,H1,H2,D1,D2,RIMPCT ) IF ( DEBUG ) WRITE(MDEBUG,105) THCKTOT1,H2,D2 105 FORMAT(' COOINC: THCKTOT1,H2,D2=',3G15.8) C SECOND FRACTION OF PATH BETWEEN SKIMMING POINT AND TOP OF ATMOSPHERE AUXIL = (C(1) + HLAY(6))**2 - RIMPCT**2 DT2 = -SQRT( AUXIL ) D1 = 0.D0 IF ( DEBUG ) WRITE(MDEBUG,106) DT2,HIMPCT,D1,RIMPCT 106 FORMAT(' COOINC: DT2,HIMPCT,D1,RIMPCT=',4G15.8) CALL DL2DT( DT2,THCKTOT2,HIMPCT,H2,D1,D2,RIMPCT ) THCKTOT = THCKTOT1 + THCKTOT2 IF ( DEBUG ) WRITE(MDEBUG,107) THCKTOT2,H2,D2,THCKTOT 107 FORMAT(' COOINC: THCKTOT2,H2,D2,THCKTOT=',4G15.8) ELSE C NON-SKIMMING INCIDENCE (UPWARD OR DOWNWARD) RIMPCT = RADGRD * SQRT( (1.D0+COSTAP)*(1.D0-COSTAP) ) C SHOWER AXIS WITH UPWARD OR DOWNWARD PRIMARY PARTICLE IF ( PRMPAR(15) .LT. 0.D0 ) THEN C PRIMARY PARTICLE GOES UPWARD C MODIFY HGROUND TO STARTING VALUE OF PRIMARY PARTICLE HGROUND = HH RADGRD = C(1) + HGROUND IF ( DEBUG ) WRITE(MDEBUG,108) HGROUND,RADGRD,HH 108 FORMAT(' COOINC: HGROUND,RADGRD,HH=',3G15.8) DT = -DIAG D1 = 0.D0 IF ( DEBUG ) WRITE(MDEBUG,109) DT,H1,D1,RIMPCT CALL DL2DT( DT,THCKTOT,H1,H2,D1,D2,RIMPCT ) IF ( DEBUG ) WRITE(MDEBUG,110) THCKTOT,H2,D2 ELSE C PRIMARY PARTICLE GOES DOWNWARD DT = DIAG D1 = DIAG IF ( DEBUG ) WRITE(MDEBUG,109) DT,H1,D1,RIMPCT C CALCULATE THE SLANT THICKNESS BETWEEN HLAY(6) AND OBSLEV CALL DL2DT( DT,THCKTOT,H1,H2,D1,D2,RIMPCT ) IF ( DEBUG ) WRITE(MDEBUG,110) THCKTOT,H2,D2 ENDIF ENDIF #else C PRIMARY PARTICLE GOES DOWNWARD RIMPCT = RADGRD * SQRT( (1.D0+COSTAP)*(1.D0-COSTAP) ) DT = DIAG D1 = DIAG C CALCULATE THE SLANT THICKNESS BETWEEN HLAY(6) AND OBSLEV IF ( DEBUG ) WRITE(MDEBUG,109) DT,H1,D1,RIMPCT CALL DL2DT( DT,THCKTOT,H1,H2,D1,D2,RIMPCT ) IF ( DEBUG ) WRITE(MDEBUG,110) THCKTOT,H2,D2 #endif C CALCULATE BIN WIDTH AND MAXIMUM NUMBER OF BINS FOR LONGI TABLE C THICKNESS OF BIN (SHOULD BE INTEGER) THSTEP = NINT( THSTEP ) cdh THSTEP = MIN( THSTEP, DBLE(LNGMAX-1) ) THCKMX = THCKTOT / DBLE(LNGMAX-2) C CALCULATE A REASONABLE BIN WIDTH C THICKNESS OF BIN IS LIMITED BY NUMBER OF AVAILABLE BINS #if !__ANAHIST__ #if __CONEX__ && __SLANT__ C TO KEEP CONEX COMPATIBILITY, THSTEP SHOULD BE A MULTIPLE OF 10 THSTEP = MAX( THSTEP, DBLE( INT( (THCKMX+0.5D0)*0.1D0 ) *10 ) ) #else THSTEP = MAX( THSTEP, DBLE( INT( THCKMX+0.5D0 ) ) ) #endif #endif 2 CONTINUE THSTPI = 1.D0/THSTEP NSTEP = INT( THSTPI*THCKTOT ) + 1 C CHECK BIN WIDTH AND MAXIMUM NUMBER OF BINS, EVENTUALLY CORRECTION IF ( NSTEP .GE. LNGMAX-2 ) THEN #if __ANAHIST__ WRITE(MONIOU,*)'COOINC: THSTEP TOO SMALL FOR HISTOGRAMMING', * ' TOO MANY LONGI STEPS CAUSE STOP' WRITE(MONIOU,*)'COOINC: PLEASE SPECIFY LARGER LONGI STEP', * ' SEE KEYWORD LONGI' STOP #else #if __CONEX__ && __SLANT__ C TO KEEP CONEX COMPATIBILITY, THSTEP SHOULD BE A MULTIPLE OF 10 THSTEP = THSTEP + 10.D0 #else THSTEP = THSTEP + 1.D0 #endif IF ( DEBUG ) WRITE(MDEBUG,*) * 'COOINC: LONGI THSTEP=',THSTEP,' NSTEP =',NSTEP GOTO 2 #endif ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) * 'COOINC: LONGI THSTEP=',THSTEP,' NSTEP =',NSTEP THCKTOT = THSTEP * NSTEP C CALCULATE TABLE TO BE USED BY RHOSL IF ( DEBUG ) WRITE(MDEBUG,*) 'COOINC: BIN HEIGHT ', * 'SL. PATH DENSITY SL.DEPTH' IF ( DEBUG ) WRITE(MDEBUG,*) ' I3 H2 ', * ' PATH1 RHOSLT TSLANT' #if __UPWARD__ IF ( FIMPCT ) THEN C SKIMMING INCIDENCE DIAGFR = (DT1-DT2) / DBLE( MAXSLANT - 1.D0 ) DISTI = 0.D0 D1 = DIAG IF ( DEBUG ) WRITE(MDEBUG,*) 'COOINC: H1,D1,RIMPCT=', * SNGL(H1),SNGL(D1),SNGL(RIMPCT) DO I3 = MAXSLANT, 2, -1 DISTI = DISTI + DIAGFR HH2 = H2 CALL DL2DT( DISTI,TSLANT(I3),H1,H2,D1,D2,RIMPCT ) PATH1(I3) = DIAG - D2 RHOSLT(I3) = RHOF( H2 ) IF ( DEBUG ) WRITE(MDEBUG,127) * I3,H2,PATH1(I3),RHOSLT(I3),TSLANT(I3) ENDDO I3 = 1 PATH1(1) = 2.D0 * PATH1(2) TSLANT(1) = 2.D0 * TSLANT(2) - TSLANT(3) HH2 = 2.D0 * H2 - HH2 RHOSLT(1) = RHOF( HH2 ) ELSE C NON_SKIMMING INCIDENCE (UPWARD OR DOWNWARD) IF ( PRMPAR(15) .LT. 0.D0 ) THEN C UPWARD PRIMARY DIAGFR = -DIAG / DBLE( MAXSLANT - 1.D0 ) DISTI = -DIAGFR D1 = 0.D0 DO I3 = 499, 2, -1 DISTI = DISTI + DIAGFR HH2 = H2 CALL DL2DT( DISTI,TSLANT(MAXSLANT+1-I3),H1,H2,D1,D2, * RIMPCT ) PATH1(MAXSLANT+1-I3) = D2 RHOSLT(MAXSLANT+1-I3) = RHOF( H2 ) HHHH2(MAXSLANT+1-I3) = H2 ENDDO DO I3 = MAXSLANT, 2, -1 IF ( DEBUG ) WRITE(MDEBUG,127) * I3,HHHH2(I3),PATH1(I3),RHOSLT(I3),TSLANT(I3) ENDDO I3 = 1 PATH1(1) = 2.D0 * PATH1(2) TSLANT(1) = 2.D0 * TSLANT(2) HH2 = 2.D0 * HHHH2(2) - HHHH2(3) RHOSLT(1) = RHOF( HH2 ) ELSE C DOWNWARD PRIMARY DIAGFR = DIAG / DBLE( MAXSLANT - 1.D0 ) DISTI = 0.D0 D1 = DIAG DO I3 = MAXSLANT, 2, -1 DISTI = DISTI + DIAGFR HH2 = H2 CALL DL2DT( DISTI,TSLANT(I3),H1,H2,D1,D2,RIMPCT ) PATH1(I3) = DIAG - D2 RHOSLT(I3) = RHOF( H2 ) IF ( DEBUG ) WRITE(MDEBUG,127) * I3,H2,PATH1(I3),RHOSLT(I3),TSLANT(I3) ENDDO I3 = 1 PATH1(1) = 2.D0 * PATH1(2) TSLANT(1) = 2.D0 * TSLANT(2) - TSLANT(3) HH2 = 2.D0 * H2 - HH2 RHOSLT(1) = RHOF( HH2 ) ENDIF ENDIF #else DIAGFR = DIAG / DBLE( MAXSLANT - 1.D0 ) DISTI = 0.D0 D1 = DIAG DO I3 = MAXSLANT, 2, -1 DISTI = DISTI + DIAGFR HH2 = H2 CALL DL2DT( DISTI,TSLANT(I3),H1,H2,D1,D2,RIMPCT ) PATH1(I3) = DIAG - D2 RHOSLT(I3) = RHOF( H2 ) IF ( DEBUG ) WRITE(MDEBUG,127) * I3,H2,PATH1(I3),RHOSLT(I3),TSLANT(I3) ENDDO I3 = 1 PATH1(1) = 2.D0 * PATH1(2) TSLANT(1) = 2.D0 * TSLANT(2) - TSLANT(3) HH2 = 2.D0 * H2 - HH2 RHOSLT(1) = RHOF( HH2 ) #endif IF ( DEBUG ) WRITE(MDEBUG,127) * I3,HH2,PATH1(1),RHOSLT(1),TSLANT(1) IF ( DEBUG ) WRITE(MDEBUG,*) 'COOINC: BIN HEIGHT ', * 'SL. PATH DENSITY SL.DEPTH' IF ( DEBUG ) WRITE(MDEBUG,*) ' I3 H2 ', * ' PATH1 RHOSLT TSLANT' IENDT = 1 IF ( DEBUG ) WRITE(MDEBUG,*) 'COOINC: IENDT =',IENDT, * ' NSTEP=',NSTEP IF ( FPRINT .OR. DEBUG ) WRITE(MONIOU,121) NSTEP,THSTEP 121 FORMAT(/,' LONGITUDINAL SHOWER DEVELOPMENT:',/, * ' SHOWER IS SAMPLED IN NSTEP=',I5, * ' SLANT STEPS OF ',F6.1,' G/CM**2') IF ( FPRINT .OR. DEBUG ) WRITE(MONIOU,131) 131 FORMAT(4X,'STEP',5X,'HEIGHT [CM]',1X,'SLANT DEPTH [G/CM**2]', * 1X,'SLANT DISTANCE [CM]',/, * 5X,'(I)',8X,'HLONG(I)',13X,'THCKRL(I)',12X,'RLONG(I)') #if __UPWARD__ IF ( FIMPCT ) THEN C SKIMMING INCIDENCE DO I3 = 0, NSTEP THCKRL(I3) = THSTEP * DBLE(I3) DT = THCKRL(I3) H1 = HH CALL DT2DL( DT,DISTI,H1,H2,RIMPCT,JINV ) RLONG(I3) = DISTI HLONG(I3) = H2 IF ( FPRINT .OR. DEBUG ) WRITE(MONIOU,141) * I3,HLONG(I3),THCKRL(I3),RLONG(I3) ENDDO THCKRL(NSTEP+1) = 2.D0 * THSTEP * DBLE(NSTEP) DT = THCKRL(NSTEP+1) H1 = HH CALL DT2DL( DT,DISTI,H1,H2,RIMPCT,JINV ) RLONG(NSTEP+1) = DISTI HLONG(NSTEP+1) = H2 IF ( FPRINT .OR. DEBUG ) WRITE(MONIOU,141) * NSTEP+1,HLONG(NSTEP+1),THCKRL(NSTEP+1),RLONG(NSTEP+1) ELSE C NON-SKIMMING INCIDENCE (UPWARD OR DOWNWARD) IF ( PRMPAR(15) .LT. 0.D0 ) THEN C UPWARD PRIMARY DO I3 = 0, NSTEP THCKRL(I3) = THSTEP * DBLE(I3) DT = -THCKRL(I3) H1 = HH CALL DT2DL( DT,DISTI,H1,H2,RIMPCT,JINV ) RLONG(I3) = DISTI HLONG(I3) = H2 IF ( FPRINT .OR. DEBUG ) WRITE(MONIOU,141) * I3,HLONG(I3),THCKRL(I3),RLONG(I3) ENDDO THCKRL(NSTEP+1) = 2.D0 * THSTEP * DBLE(NSTEP) DT = -THCKRL(NSTEP+1) H1 = HH CALL DT2DL( DT,DISTI,H1,H2,RIMPCT,JINV ) RLONG(NSTEP+1) = DISTI HLONG(NSTEP+1) = H2 IF ( FPRINT .OR. DEBUG ) WRITE(MONIOU,141) * NSTEP+1,HLONG(NSTEP+1),THCKRL(NSTEP+1),RLONG(NSTEP+1) ELSE C DOWNWARD PRIMARY DO I3 = 0, NSTEP THCKRL(I3) = THSTEP * DBLE(I3) DT = THCKRL(I3) H1 = HH CALL DT2DL( DT,DISTI,H1,H2,RIMPCT,JINV ) RLONG(I3) = DISTI HLONG(I3) = H2 IF ( FPRINT .OR. DEBUG ) WRITE(MONIOU,141) * I3,HLONG(I3),THCKRL(I3),RLONG(I3) ENDDO THCKRL(NSTEP+1) = 2.D0 * THSTEP * DBLE(NSTEP) DT = THCKRL(NSTEP+1) H1 = HH CALL DT2DL( DT,DISTI,H1,H2,RIMPCT,JINV ) RLONG(NSTEP+1) = DISTI HLONG(NSTEP+1) = H2 IF ( FPRINT .OR. DEBUG ) WRITE(MONIOU,141) * NSTEP+1,HLONG(NSTEP+1),THCKRL(NSTEP+1),RLONG(NSTEP+1) ENDIF ENDIF #else DO I3 = 0, NSTEP THCKRL(I3) = THSTEP * DBLE(I3) DT = THCKRL(I3) H1 = HH CALL DT2DL( DT,DISTI,H1,H2,RIMPCT,JINV ) RLONG(I3) = DISTI HLONG(I3) = H2 IF ( FPRINT .OR. DEBUG ) WRITE(MONIOU,141) * I3,HLONG(I3),THCKRL(I3),RLONG(I3) ENDDO THCKRL(NSTEP+1) = 2.D0 * THSTEP * DBLE(NSTEP) DT = THCKRL(NSTEP+1) H1 = HH CALL DT2DL( DT,DISTI,H1,H2,RIMPCT,JINV ) RLONG(NSTEP+1) = DISTI HLONG(NSTEP+1) = H2 IF ( FPRINT .OR. DEBUG ) WRITE(MONIOU,141) * NSTEP+1,HLONG(NSTEP+1),THCKRL(NSTEP+1),RLONG(NSTEP+1) #endif 103 FORMAT(' COOINC: STHCPH=',1P,E12.5,' STHSPH=',E12.5,' CTH=', * E12.5,0P,' RLOFF=',F12.2,' DIAG=',F12.2) 109 FORMAT(' COOINC: DT,H1,D1,RIMPCT=',4G15.8) 110 FORMAT(' COOINC: THCKTOT,H2,D2=',3G15.8) 127 FORMAT(7X,I4,1X,F11.1,1X,F16.3,2X,1P,E12.5,0P,F12.3) 141 FORMAT(1X,I7,F16.6,F22.6,F20.6) ENDIF #elif __COAST__ c Define value for link to COAST if SLANT is not activated CTH = PRMPAR(2) STHCPH = PRMPAR(3) STHSPH = PRMPAR(4) RLOFF = 0.D0 DO I = 0, LNGMAX THCKRL(I) = -1.D0 RLONG(I) = -1.D0 ENDDO #endif RETURN END #endif #if !__CURVED__ *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE COORIN( HEIGHT ) C----------------------------------------------------------------------- C COOR(DINATE) IN(ITIALIZATION) C C INITIALIZES COORDINATE CORRECTION FOR EACH OBSERVATION LEVEL C ROUTINE SHOULD BE CALLED AFTER HEIGHT OF FIRST INTERACTION IS C DETERMINED. X,Y COORDINATES OF 1. INERACTION ARE ASSUMED TO BE 0,0. C THIS SUBROUTINE IS CALLED FROM AAMAIN, ELECTR, AND PHOTON. C ARGUMENT: C HEIGHT = HEIGHT OF 1. INTERACTION (CM) C----------------------------------------------------------------------- IMPLICIT NONE #define __CONSTAINC__ #define __OBSPARINC__ #define __RUNPARINC__ #if __SLANT__ || __COAST__ #define __LONGIINC__ #define __PARPARINC__ #endif #if __SLANT__ #define __ATMOS2INC__ #define __ATMOSLINC__ #define __PARPAEINC__ #endif #include "corsika.h" DOUBLE PRECISION DXY,HEIGHT,TANTE #if __SLANT__ DOUBLE PRECISION DHS,DHH,HENDT,HH,HHH,THCKMX DOUBLE PRECISION HEIGH,RHOF,THICK INTEGER I2,I3,K LOGICAL LOOPFL EXTERNAL HEIGH,RHOF,THICK #endif INTEGER I SAVE C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'COORIN: HEIGHT,THETA,PHI =', * SNGL(HEIGHT),SNGL(THETAP*180.D0/PI),SNGL(PHIP*180.D0/PI) TANTE = TAN( THETAP ) DO I = 1, NOBSLV DXY = TANTE * ( HEIGHT - OBSLEV(I) ) XOFF(I) = COS( PHIP ) * DXY YOFF(I) = SIN( PHIP ) * DXY ENDDO IF ( DEBUG ) WRITE(MDEBUG,100) * (OBSLEV(I),XOFF(I),YOFF(I),I=1,NOBSLV) 100 FORMAT(' COORIN: OBSLVL,XOFF,YOFF= ',1P,3E12.4) #if __SLANT__ IF ( LLONGI ) THEN C SET DIRECTION COSINES OF SHOWER AXIS CTH = PRMPAR(2) STHCPH = PRMPAR(3) STHSPH = PRMPAR(4) C SET ZERO POPINT OF SLANT LONGITUDINAL DISTANCE #if __STACKIN__ HH = PRMPAR(5) #else IF ( FIX1I .AND. PRMPAR(0) .LE. 3.D0 ) THEN THICK0 = THICK( FIXHEI ) ENDIF HH = HEIGH( THICK0 ) #endif RLOFF = HH * PRMPAR(2) IF ( DEBUG ) WRITE(MDEBUG,110) STHCPH,STHSPH,CTH,RLOFF 110 FORMAT(' COORIN: STHCPH=',1P,E12.5,' STHSPH=',E12.5, * ' CTH=',E12.5,' RLOFF=',E12.5) C CALCULATE BIN WIDTH AND MAXIMUM NUMBER OF BINS FOR LONGI TABLE C THICKNESS OF BIN (SHOULD BE INTEGER) THSTEP = NINT( THSTEP ) THSTEP = MIN( THSTEP, DBLE(LNGMAX-2) ) C THICKNESS OF BIN IS LIMITED BY NUMBER OF AVAILABLE BINS C AND BY INCLINATION OF SHOWER AXIS THCKMX = (THCKOB(NOBSLV)-THICK0) / (CTH*DBLE(LNGMAX-2)) #if __UPWARD__ THCKMX = MAX( THCKMX, ABS( THICK0/CTH ) / DBLE(LNGMAX-2) ) THCKMX = MAX( THCKMX, ABS( THICK( FIXHEI ) )/DBLE(LNGMAX-2) ) #endif #if !__ANAHIST__ #if __CONEX__ && __SLANT__ C TO KEEP CONEX COMPATIBILITY, THSTEP SHOULD BE A MULTIPLE OF 10 THSTEP = MAX( THSTEP, DBLE( INT( (THCKMX+0.5D0)*0.1D0 ) *10 ) ) #else THSTEP = MAX( THSTEP, DBLE( INT( THCKMX+0.5D0 ) ) ) #endif #endif 1 CONTINUE THSTPI = 1.D0/THSTEP #if __UPWARD__ IF ( CTH .LT. 0.D0 .AND. * THCKOB(NOBSLV)-THICK0 .GE. 0.D0 ) THEN WRITE(MONIOU,*) 'COORIN: OBSERVATION LEVEL BELOW ', * 'FIRST INTERACTION: STOP' STOP ELSEIF ( CTH .GT. 0.D0 .AND. * THCKOB(NOBSLV)-THICK0 .LE. 0.D0 ) THEN WRITE(MONIOU,*) 'COORIN: OBSERVATION LEVEL ABOVE ', * 'FIRST INTERACTION: STOP' STOP ENDIF #endif NSTEP = INT( THSTPI*(THCKOB(NOBSLV)-THICK0)/CTH ) + 1 C CHECK BIN WIDTH AND MAXIMUM NUMBER OF BINS, EVENTUALLY CORRECTION IF ( NSTEP .GE. LNGMAX-1 ) THEN #if __ANAHIST__ WRITE(MONIOU,*)'COORIN: THSTEP TOO SMALL FOR HISTOGRAMMING', * ' TOO MANY LONGI STEPS CAUSE STOP' WRITE(MONIOU,*)'COORIN: PLEASE SPECIFY LARGER LONGI STEPS' STOP #else #if __CONEX__ && __SLANT__ C TO KEEP CONEX COMPATIBILITY, THSTEP SHOULD BE A MULTIPLE OF 10 THSTEP = THSTEP + 10.D0 #else THSTEP = THSTEP + 1.D0 #endif IF ( DEBUG ) WRITE(MDEBUG,*) * 'COORIN: THSTEP=',THSTEP,' NSTEP =',NSTEP GOTO 1 #endif ENDIF IF ( FPRINT .OR. DEBUG ) WRITE(MONIOU,120) NSTEP,THSTEP 120 FORMAT(/,' LONGITUDINAL SHOWER DEVELOPMENT:',/, * ' SHOWER IS SAMPLED IN NSTEP=',I5, * ' SLANT STEPS OF THSTEP=',F6.1,' G/CM**2') IF ( FPRINT .OR. DEBUG ) WRITE(MONIOU,130) 130 FORMAT(4X,'STEP',5X,'HEIGHT [CM]',1X,'SLANT DEPTH [G/CM**2]', * 1X,'SLANT DISTANCE [CM]',/, * 7X,'I',5X,'HLONG(I)',17X,'THCKRL(I)',12X,'RLONG(I)') C CALCULATE TABLES FOR THICKNESS AND FOR LONGITUDINAL DISTANCE VALUES C HLONG ARE HEIGHT VALUES TO BE USED IN EGS DO I = 0, NSTEP THCKRL(I) = THSTEP * DBLE(I) #if __UPWARD__ IF ( CTH .LT. 0.D0 ) THEN HLONG(I) = HEIGH( THICK0 + THCKRL(I)*CTH ) HLONG(I) = MIN( HLONG(I), HLAY(6) ) ELSE HLONG(I) = HEIGH( THICK0 + THCKRL(I)*CTH ) ENDIF #else HLONG(I) = HEIGH( THICK0 + THCKRL(I)*CTH ) #endif RLONG(I) = (HH - HLONG(I)) / CTH IF ( FPRINT .OR. DEBUG ) WRITE(MONIOU,140) * I, HLONG(I),THCKRL(I),RLONG(I) 140 FORMAT(1X,I7,F16.6,F22.6,F20.6) ENDDO THCKRL(NSTEP+1) = 2.D0 * THSTEP * DBLE(NSTEP) #if __UPWARD__ IF ( CTH .LT. 0.D0 ) THEN HLONG(NSTEP+1) = HLAY(6) RLONG(NSTEP+1) = (HH - HLONG(NSTEP+1)) / CTH ELSE HLONG(NSTEP+1) = HEIGH( THICK0 + THCKRL(NSTEP+1)*CTH ) RLONG(NSTEP+1) = HH / CTH ENDIF #else HLONG(NSTEP+1) = HEIGH( THICK0 + THCKRL(NSTEP+1)*CTH ) RLONG(NSTEP+1) = HH / CTH #endif IF ( FPRINT .OR. DEBUG ) WRITE(MONIOU,140) NSTEP+1, * HLONG(NSTEP+1),THCKRL(NSTEP+1),RLONG(NSTEP+1) IF ( FPRINT .OR. DEBUG ) THEN IF ( FLGFIT ) THEN WRITE(MONIOU,*) * ' FIT TO CHARGED PARTICLE LONG. DISTRIBUTION ENABLED' ELSE WRITE(MONIOU,*) * ' FIT TO CHARGED PARTICLE LONG. DISTRIBUTION DISABLED' ENDIF WRITE(MONIOU,*) ENDIF C CALCULATE DENSITY AND MASS OVERLAY FOR ATMOSPHERIC LAYER BOUNDARIES DO I = 6, 1, -1 HLAYS(I) = (HH - HLAY(I)) / CTH RHOS(I) = RHOF( HLAY(I) ) IF ( I .EQ. 6 ) THEN THICKS(6) = 0.D0 ELSE THICKS(I) = (THICKL(I)-THICK0) / CTH ENDIF IF ( DEBUG ) WRITE(MDEBUG,150) I,HLAYS(I),RHOS(I),THICKS(I) 150 FORMAT(' COORIN: I=',I2,' HLAYS=',F16.3,' RHO=',1P,E12.5,0P, * ' THICKS=',F16.3) ENDDO C CALCULATE TABLE TO BE USED BY RHOSLT IF ( DEBUG ) WRITE(MDEBUG,*) 'COORIN: BIN HEIGHT ', * 'SL. PATH DENSITY SL.DEPTH' LOOPFL = .TRUE. DO I = 5, 1, -1 C CALCULATE INTERMEDIATE VALUES FOR VARIOUS ALTITUDES AND THICKNESSES I2 = I + 1 DHS = (HLAYS(I2) - HLAYS(I)) * 0.01D0 DHH = (HLAY(I2) - HLAY(I)) * 0.01D0 DO K = MAXSLANT2, 1, -1 C CALCULATE INTERMADIATE STEPS I3 = (I-1)*MAXSLANT2 + K HHH = HLAY(I) + DHH * DBLE(K-1) PATH1(I3) = HLAYS(I) + DHS * DBLE(K-1) C CALCULATE DENSITIES FOR INTERMEDIATE STEPS RHOSLT(I3) = RHOF( HHH ) C CALCULATE THICKNESS AS INTEGRAL OVER RHO FROM H UP TO THE END TSLANT(I3) = (THICK( HHH ) - THICK0 ) / CTH #if __UPWARD__ IF ( CTH .LT. 0.D0 ) THEN IF ( HHH .GE. HH ) THEN IENDT = I3 HENDT = HHH ELSE IF ( LOOPFL ) THEN IENDT = I3 HENDT = HHH LOOPFL = .FALSE. ELSE HENDT = HHH PATH1(I3) = HLAY(6) / CTH RHOSLT(I3) = RHOF( 0.D0 ) TSLANT(I3) = (THICKL(1) - THICK0) / CTH GOTO 931 ENDIF ENDIF ELSE #endif IF ( HHH .GE. OBSLEV(NOBSLV) ) THEN IENDT = I3 - 1 HENDT = HHH ELSE IF ( LOOPFL ) THEN IENDT = I3 - 1 HENDT = HHH LOOPFL = .FALSE. ELSE HENDT = HHH PATH1(I3) = HLAY(6) / CTH RHOSLT(I3) = RHOF( 0.D0 ) TSLANT(I3) = (THICKL(1) - THICK0) / CTH GOTO 931 ENDIF ENDIF #if __UPWARD__ ENDIF #endif IF ( DEBUG ) WRITE(MDEBUG,928) * I3,HHH,PATH1(I3),RHOSLT(I3),TSLANT(I3) 928 FORMAT(7X,I4,1X,F11.1,1X,F16.3,2X,1P,E12.5,0P,F12.3) ENDDO ENDDO 931 CONTINUE IF ( DEBUG ) THEN WRITE(MDEBUG,929) IENDT,HENDT,PATH1(IENDT),RHOSLT(IENDT), * TSLANT(IENDT) 929 FORMAT(7X,I3,2X,F11.1,1X,F16.3,2X,1P,E12.5,E12.5) WRITE(MDEBUG,*) 'COORIN: IENDT =',IENDT ENDIF ENDIF #elif __COAST__ c Define value for link to COAST if SLANT is not activated CTH = PRMPAR(2) STHCPH = PRMPAR(3) STHSPH = PRMPAR(4) RLOFF = 0.D0 DO I = 0, LNGMAX THCKRL(I) = -1.D0 RLONG(I) = -1.D0 ENDDO #endif RETURN END #endif *-- Author : D. HECK IK FZK KARLSRUHE 12/05/2003 C======================================================================= DOUBLE PRECISION FUNCTION CPRSGM( ELAB,MAT,MUTAU ) C----------------------------------------------------------------------- C C(ALCULATE) P(AI)R (PRODUCTION) S(I)G(MA FOR) M(UONS AND TAUS) C C CALCULATES THE CROSS-SECTION IN CURRENT MATERIAL FOR DISCRETE (HARD) C MUON/TAU 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/TAU (GEV) C MAT = MATERIAL INDEX: 1=14N, 2=16O, 3=40AR C MUTAU = LEPTON INDEX: 1=MU, 2=TAU C----------------------------------------------------------------------- IMPLICIT NONE #define __MUPARTINC__ #define __RUNPARINC__ #define __SIGMUINC__ #include "corsika.h" DOUBLE PRECISION DELTAE,ELAB,WK(3),YE INTEGER I,JE,MAT,MUTAU SAVE 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 CPRSGM = 0.D0 DO I = 1, 3 CPRSGM = CPRSGM + PAIRTAB(JE+I-1,MAT,MUTAU)*WK(I) ENDDO CPRSGM = EXP( CPRSGM ) C IF ( DEBUG ) WRITE(MDEBUG,444) ELAB,MAT,CPRSGM C 444 FORMAT(' CPRSGM: E=',1P,E10.4,' MAT=',I3,' MUTAU=', C * ' CPRSGM=',E12.5) RETURN END *-- Author : A.C.Genz, A.A.Malik, CERN, MATHLIB 15/11/1995 C======================================================================= SUBROUTINE DADMUL( F,N,A,B,MINPTS,MAXPTS,EPS,WK,IWK,RESULT, * RELERR,NFNEVL,IFAIL ) C----------------------------------------------------------------------- C D(OUBLE PRECISION) AD(APTIVE QUADRATURE FOR) MUL(TIPLE INTEGRALS) C C CERN ROUTINE FOR ADAPTIVE QUADRATURE FOR MULTIPLE INTEGRALS OVER C N-DIMENSIONAL RECTANGULAR REGIONS. C SEE: http://wwwasdoc.web.cern.ch/wwwasdoc/cernlib.html (d120) C THIS ROUTINE IS SLIGHTLY MODIFIED TO MEET REQUIREMENTS OF CORSIKA. C THIS SUBROUTINE IS CALLED FROM DBRELM, DBRSGM, DNUSGM, DPRELM, C 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/2.D0) 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) 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 IF ( ABS(DIFMAX - DIF) .LE. DIF*1.D-10 ) 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 = 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 *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE DATAC C----------------------------------------------------------------------- C DATA C(ARDS) C C READS DATA CARDS FROM UNIT 5 TO STEER RUN. C READING IS FREE FORMAT WITH BLANK AS SEPARATOR. C EACH KEYWORD STARTS ON A NEW LINE LEFTSHIFTED. C THIS SUBROUTINE IS CALLED FROM START. C----------------------------------------------------------------------- IMPLICIT NONE #define __ATMOSINC__ #define __ATMOS2INC__ #define __CONSTAINC__ #define __DPMFLGINC__ #define __EGSDEBINC__ #define __ELABCTINC__ #define __ETHMAPINC__ #define __LONGIINC__ #define __MAGANGINC__ #define __MAGNETINC__ #define __MUMULTINC__ #define __NKGIINC__ #define __OBSPARINC__ #define __PARPARINC__ #define __PRIMSPINC__ #define __RANDPAINC__ #define __RANMA3INC__ #define __REJECTINC__ #define __RUNPARINC__ #if __CONEX__ #define __CONEXINC__ #endif #if __CURVED__ #define __TIMLIMINC__ #endif #if __DPMJET__ #define __DPMJETINC__ #endif #if __EPOS__ || __NEXUS__ #define __NEXPARINC__ #define __NEXUSINC__ #endif #if __QGSJET__ #define __QGSCINC__ #endif #if __SIBYLL__ #define __SIBYLCINC__ #define __SIBDBGINC__ #endif #if __VENUS__ #define __VENPARINC__ #define __VENUSINC__ #endif #if __ATMEXT__ #define __ATMOSXINC__ #endif #if __AUGERHIT__ #define __AUGDETINC__ #endif #if __CERENKOV__ || __AUGERHIST__ || __AUGCERLONG__ #define __CEREN1INC__ #endif #if __CERENKOV__ || __AUGCERLONG__ #define __CEREN2INC__ #endif #if __CERENKOV__ && __CEFFIC__ #define __CERABSINC__ #endif #if __CERENKOV__ && !__IACT__ #define __CERTELINC__ #endif #if __CHARM__ || __TAULEP__ #define __PYTLININC__ #endif #if __COASTUSERLIB__ #define __INCLINEDINC__ #endif #if __INTTEST__ #define __TSTINTINC__ #endif #if __MULTITHIN__ #define __MULTHININC__ #endif #if __NUPRIM__ #define __NUPROCINC__ #endif #if __PRESHOWER__ #define __GLOBALINC__ #endif #if __PRESHOWER__ || __CONEX__ #define __GLOBALINC__ #endif #if __PARALLEL__ #define __BUFFSINC__ #define __PAMINC__ #define __STACKFINC__ #endif #if __PLOTSH2__ #define __PLOTSH2INC__ #endif #if __THIN__ || __MULTITHIN__ #define __THNVARINC__ #endif #if __TRAJECT__ #define __TRAJECINC__ #endif #if __VOLUMECORR__ #define __DETCFGINC__ #endif #include "corsika.h" DOUBLE PRECISION R1,R2 INTEGER I,IE,IOBSLV,IS,ISEQ,LENVAL,MMM,MONNEW,NUMERR, * IDCHAR #if !__STACKIN__ INTEGER NNTYP #endif #if __EPOS__ COMMON /COPEN/ NOPEN,NOPENR INTEGER NOPEN,NOPENR #elif __NEXUS__ COMMON /COPEN/ NOPEN INTEGER NOPEN #endif #if __EPOS__ || __NEXUS__ COMMON /KOPEN/ KCHOPEN,KHIOPEN,KDTOPEN,KCPOPEN,KLGOPEN,KNXOPEN INTEGER KCHOPEN,KHIOPEN,KDTOPEN,KCPOPEN,KLGOPEN,KNXOPEN INTEGER IPARAM #elif __VENUS__ INTEGER IPARAM #endif #if __CERENKOV__ DOUBLE PRECISION TELPAR(4) INTEGER TELID #if __IACT__ CHARACTER TELFNM*512 #endif #endif #if __CURVED__ LOGICAL FCURVOUT #endif #if __CURVED__ && __UPWARD__ DOUBLE PRECISION HEIGH EXTERNAL HEIGH #endif CHARACTER LINE*512,TAB*1 #if __INTTEST__ || __ANAHIST__ || __AUGERHIST__ CHARACTER LINEC*1 #endif #if __CONEX__ DOUBLE PRECISION CXMCT(3),CXWMT(3) LOGICAL FCXCAS,FCXLCE,FECUT,FCXWMT #endif #if __MULTITHIN__ INTEGER IMTHIN,MSEQ,IMSEQ #endif SAVE #if __PARALLEL__ INTEGER J,NCUTPAR,ISTK,II LOGICAL PASS,FEXIST DATA ISTK / MAXSTK / #endif C----------------------------------------------------------------------- C WRITE TITEL WRITE(MONIOU,999) 999 FORMAT(' ',10('='),' USERS RUN DIRECTIVES FOR THIS SIMULATION ', * 27('='),/) C SET TABULATOR TAB = CHAR(9) C DEFAULT VALUES FOR ALL RUN PARAMETERS ISEQ = 0 NSEQ = 1 ISEED(1,1) = 1 ISEED(2,1) = 0 ISEED(3,1) = 0 /* EGS4 */ ISEED(1,2) = 2 ISEED(2,2) = 0 ISEED(3,2) = 0 /* __CERENKOV__ */ ISEED(1,3) = 3 ISEED(2,3) = 0 ISEED(3,3) = 0 /* __IACT__ || __AUGERHIT__ */ ISEED(1,4) = 4 ISEED(2,4) = 0 ISEED(3,4) = 0 /* __NUPRIM__ */ ISEED(1,5) = 5 ISEED(2,5) = 0 ISEED(3,5) = 0 /* __PARALLEL__ */ ISEED(1,6) = 6 ISEED(2,6) = 0 ISEED(3,6) = 0 /* __CONEX__ */ ISEED(1,7) = 7 ISEED(2,7) = 0 ISEED(3,7) = 0 ISEED(1,8) = 8 ISEED(2,8) = 0 ISEED(3,8) = 0 ISEED(1,9) = 9 ISEED(2,9) = 0 ISEED(3,9) = 0 NRRUN = 1 ISHOWNO = 0 #if __STACKIN__ LLIMIT = 1.D20 #else LLIMIT = 1.D4 #endif ULIMIT = 1.D4 PSLOPE = 0.D0 #if __STACKIN__ C USE DUMMY PARTICLE NOT TO BE DEFLECTED IN EARTH MAGNETIC FIELD PRMPAR(0) = 13.D0 #else PRMPAR(0) = 14.D0 #endif THETPR(1) = 0.D0 THETPR(2) = 0.D0 PHIPR(1) = 0.D0 PHIPR(2) = 0.D0 #if __PARALLEL__ || __COASTUSERLIB__ NSHOW = 1 #else NSHOW = 10 #endif IOBSLV = 0 NOBSLV = 1 #if __PRESHOWER__ || __CONEX__ C DEFAULT VALUE FOR EL NIHUIL (MALARGUE) OBSLEV(1) = 1400.D2 ! #else C DEFAULT VALUE FOR KASCADE OBSLEV(1) = 110.D2 #endif #if __VOLUMECORR__ DETCFG = 0.D0 #endif MODATM = 1 LAYNEW = .FALSE. #if __INTTEST__ ELCUT(1) = 0.D0 ELCUT(2) = 0.D0 ELCUT(3) = 0.D0 ELCUT(4) = 0.D0 #else ELCUT(1) = 0.3D0 ELCUT(2) = 0.3D0 ELCUT(3) = 0.003D0 ELCUT(4) = 0.003D0 #endif ECTMAP = 1.D4 NFLAIN = 0 NFLDIF = 0 NFLPI0 = 0 NFLPIF = 0 NFLCHE = 0 NFRAGM = 2 FEGS = .TRUE. FNKG = .TRUE. FMOLI = .TRUE. FMUADD = .FALSE. #if __EHISTORY__ FEMADD = .FALSE. FNUADD = .FALSE. #endif #if __PRESHOWER__ || __CONEX__ C DEFAULT VALUES FOR EL NIHUIL (MALARGUE) GLONG = -69.585 GLATI = -35.463 GRFYEAR = 2013.D0 IPREPR = 1 IPRSTP = 0 #endif #if __COASTUSERLIB__ XPINCL = 0.D0 YPINCL = 0.D0 ZPINCL = OBSLEV(1)+1.D0 THINCL = 0.D0 PHINCL = 0.D0 #endif FPAROUT = .TRUE. FTABOUT = .FALSE. #if __CURVED__ #if __CERENKOV__ FFLATOUT= .TRUE. FCURVOUT= .FALSE. #else FFLATOUT= .FALSE. FCURVOUT= .TRUE. #endif #endif #if __THIN__ MODETHN = 0 EFRCTHN = 1.D-4 EEFRTHN = 1.D-4 RLIM = .FALSE. WLIM = .FALSE. WMAX = 1.D30 WMAX0 = 1.D30 WMAXE = 1.D30 WMAXE0 = 1.D30 WMAXEM = 1.D30 THINRAT = 1.D0 THINRATH= 1.D0 WEITRAT = 1.D0 WEITRATH= 1.D0 RMAX = 0.D0 RMAX2 = RMAX**2 #endif RCUT = 0.D0 ! [cm] RCUT2 = RCUT**2 #if __MULTITHIN__ IMTHIN = 0 NMTHIN = 0 DO I = 1, 6 EMFRACTH(I)= 1.D-4 WMMAX0(I) = 1.D30 THNMRTH(I) = 1.D0 WTRATMH(I) = 1.D0 ISEED(1,10+I) = 10+I ISEED(2,10+1) = 0 ISEED(3,10+I) = 0 ENDDO IMSEQ = 0 MSEQ = 8 #endif STEPFC = 1.D0 #if __PARALLELIB__ MAXPRT = 0 #else MAXPRT = 1 #endif #if __ICECUBE1__ C INITIALIZE INTERESTINGNESS FLAGS energy_interesting = 1.D3 ![GeV] n_interesting = 0 n_interesting_nu = 0 still_interesting = .TRUE. #endif #if __AUGERHIT__ MAUGPS2 = 0 MAUGPOS = 1 DRADIUS = 35.D0 ! EFFECTIVE TANK RADIUS IN METER C WITH TANK HEIGHT 1.2m DRADIUS CORRESPONDS WITH ZENITH ANGLE OF 88 DEG RCUT = 200.D2 ! RADIUS [cm] OF SATURATION REGION AROUND SHOWER CORE RCUT2 = RCUT**2 DETDIS = 1500.D0 ! DETECTOR DISTANCE IN METER FTANKSHADW = .TRUE. ! REGISTER ONLY PARTICLES HITTING TANK SHADOW FANYMODE = .TRUE. ! FOR CHECKING IF PARTICLE SURVIVES ANY THIN MODE DO I = 1, 20 XSHCORE(I) = 0.D0 ! CORE POSITION IN METER YSHCORE(I) = 0.D0 ! CORE POSITION IN METER ENDDO ARRANG =-92.08D0 ! ROTATION OF AUGER ARRAY WRT. MAGNETIC NORTH BX = 19.52D0 ! AUGER MAGNETIC FIELD COMPONENT X-DIRECTION BZ =-14.17D0 ! AUGER MAGNETIC FIELD COMPONENT Z-DIRECTION #else ARRANG = 0.D0 BX = 20.40D0 ! KASCADE MAGNETIC FIELD COMPONENT X-DIRECTION BZ = 43.23D0 ! KASCADE MAGNETIC FIELD COMPONENT Z-DIRECTION #endif #if __TRAJECT__ C LOGICAL FOR USE OF TRAJECTORY CALCULATION TLOGIC = .TRUE. C SOURCE POSITION (E.G. CRAB NEBULA) DECL = 22.D0 ! DECLINATION RA = 5.57D0 ! RIGHT ASCENSION C START TIME OF OBSERVATION, DEFAULT VALUES ARBITRARY TYEAR = 2000 TMONTH = 1 TDAY = 1 THOUR = 21 TMINUTE = 0 TSECOND = 0 C DURATION OF OBSERVATION IN SECONDS, DEFAULT VALUE ARBITRARY TDURATION = 3600 C LOCATION OF TELESCOPE: LONGITUDE IN DEG, MIN, SEC C LATITUDE IN DEG, MIN, SEC C DEFAULT VALUES E.G. SITE OF THE MAGIC TELESCOPES TLONGDGR = 17.D0 TLONGMIN = 53.D0 TLONGSEC = 26.525D0 TLONGDIR = 'W' TLATDGR = 28.D0 TLATMIN = 45.D0 TLATSEC = 42.462D0 TLATDIR = 'N' GEODECL = -6.35D0 C RADIUS WITHIN TO SPREAD EVENTS AROUND THE SOURCE POSITION C GIVEN IN ARCMINUTES TRAD = 0.D0 #endif #if __COASTUSERLIB__ LLONGI = .TRUE. #else LLONGI = .FALSE. #endif THSTEP = 20.D0 FLGFIT = .FALSE. FLONGOUT= .FALSE. RADNKG = 200.D2 #if __COMPACT__ COMOUT = .TRUE. #endif FDBASE = .FALSE. DEBUG = .FALSE. DEBDEL = .FALSE. NDEBDL = 100000000 THICK0 = 0.D0 FIX1I = .FALSE. FIXHEI = 0.D0 DSN = 'anynameupto239characters/' DATDIR = './' #if __ICECUBE2__ gzip_output = .TRUE. pipe_output = .FALSE. #endif #if __CERENKOV__ && !__IACT__ C PARAMETERS FOR CERENKOV TELESCOPES NCERTEL = 0 DO I = 1, NMAXCERTEL CERTELX(I) = 0.D0 CERTELY(I) = 0.D0 CERTELZ(I) = 0.D0 CERTELR(I) = 0.D0 CERTELID(I)= 0 ENDDO #endif #if __SLANT__ || __CURVED__ || __CONEX__ TMARGIN = .TRUE. #elif __CERENKOV__ && __IACT__ TMARGIN = .TRUE. #else TMARGIN = .FALSE. #endif #if __PARALLEL__ C WRITE OUT PARTICLES ABOVE ECTCUT TO SPECIAL FILE? PASS = .FALSE. FECTOUT = .FALSE. FECTEGS = .FALSE. #if !__PARALLELIB__ ECTCUT = 1.D1 ECTMAX = 1.D6 MPIID = 1 CFILINP = ' ' I1CUTPAR = 0 I2CUTPAR = 0 #endif NCUTPAR = 0 #endif #if __CURVED__ DSTLIM = 1204.4D5 !1204.4 km LTMLMPR = .FALSE. !NO PRINTING IF PARTICLE EXCEEDS TIME LIMIT #endif #if __CURVED__ && __UPWARD__ HIMPACT(1) = 0.D0 HIMPACT(2) = HEIGH( 0.D0 ) HIMPCT = 0.D0 FIMPCT = .FALSE. #endif HOST = ' ' USER = ' ' #if __STACKIN__ FILINP = ' ' #elif !__CONEX__ FILOUT = ' ' FOUTFILE= .FALSE. #endif #if __CERENKOV__ || __AUGERHIST__ || __AUGCERLONG__ WAVLGL = 300.D0 WAVLGU = 450.D0 CERSIZ = 0.D0 #endif #if __AUGERHIST__ || __AUGCERLONG__ CERSIZ = 1.D0 #endif #if __CERENKOV__ || __AUGCERLONG__ #if __CEFFIC__ CERQEF = .FALSE. CERATA = .FALSE. CERMIR = .FALSE. #endif NCERX = 27 NCERY = 27 DCERX = 1500.D0 DCERY = 1500.D0 ACERX = 100.D0 ACERY = 100.D0 #if __CERWLEN__ MCERFI = 2 ! new default cherenkov output format to CERxxxxxx #else MCERFI = 1 ! new default cherenkov output format to CERxxxxxx #endif ICERML = 0 ! # of scatters of core position XSCATT = 0.D0 YSCATT = 0.D0 DO I = 1, 20 CERXOS(I) = 0.D0 CERYOS(I) = 0.D0 ENDDO #if __ATMEXT__ IATMOX = 0 FREFRX = .FALSE. #endif #endif #if __CHARM__ || __TAULEP__ IFLGPYE = 0 IFLGPYW = 0 #endif #if __CHARM__ C DEFAULT VALUES SIGMAQ(1) = 0.D0 SIGMAQ(2) = 0.D0 SIGMAQ(3) = 0.D0 SIGMAQ(4) = 0.D0 C PROPAGATION PROPMOD = 1 #endif #if __CONEX__ CXTHR(1) = 1.D-3 CXTHR(2) = 1.D0 !MUONS IN CORSIKA CXTHR(3) = 1.D-3 CXMCC(1) = 1.D3 CXMCC(2) = 1.D20 !FULL RANGE TO GET MUONS DEVIATION IN MAGNETIC FIELD CXMCC(3) = 10.D0 CXMCS = 400.D0 FCORS = .TRUE. FCXCAS = .TRUE. FCXLCE = .FALSE. FCXGHE = .FALSE. FCXWMX = .FALSE. FCXCE = .FALSE. FECUT = .FALSE. CXWMX(1) = -1.D0 !BY DEFAULT USE WEIGHT DEFINED BY NORMAL THINNNING CXWMX(2) = -1.D0 CXWMX(3) = -1.D0 #endif #if __INTTEST__ C IN CASE OF INTERACTION TEST ALLOW MODIFICATIONS C HIGH ENERGY MODELS DOWN TO 50 GEV C LOW ENERGY MODELS UP TO 100 GEV #if __DPMJET__ || __EPOS__ || __NEXUS__ || __QGSJET__ || __VENUS__ C BORDER BETWEEN LOW AND HIGH ENERGY INTERACTION MODELS HILOELB = 49.D0 #elif __SIBYLL__ C BORDER BETWEEN LOW AND HIGH ENERGY INTERACTION MODELS HILOELB = 60.D0 #else C DEFAULT FOR LOW ENERGY INTERACTION MODELS HILOELB = 101.D0 #endif #else C BORDER BETWEEN LOW AND HIGH ENERGY INTERACTION MODELS C SET BY DEFAULT TO ELAB = 80 GEV HILOELB = 80.D0 #endif #if __FLUKA__ GHEISH = .FALSE. FFLUKA = .TRUE. FFLUDB = .FALSE. #elif __GHEISHAD__ GHEISH = .TRUE. GHEISDB = .FALSE. #elif __URQMD__ GHEISH = .FALSE. FURQMD = .TRUE. IUDEBUG = 0 IUDEBG0 = 0 #endif #if __NUPRIM__ C SELCT NEUTRINO INTERACTION AT RANDOM BY DEFAULT NUSLCT = 2 #endif #if __DPMJET__ FDPMJT = .TRUE. FDPJSG = .TRUE. LEVLDB = 0 #elif __EPOS__ || __NEXUS__ FNEXUS = .TRUE. ISH0N = 0 IPARAM = 0 NNPARM = 0 C SET OPEN FLAGS FOR FILES CHECK, HISTO, DATA TO AVOID OPEN IN AREAD KCHOPEN = 1 KHIOPEN = 1 KDTOPEN = 1 OPEN(UNIT=NEXPRM,STATUS='SCRATCH',FORM='FORMATTED') WRITE(NEXPRM,'(A19)') 'application hadron ' #if __CONEX__ c Stable particles defined in CONEX #else WRITE(NEXPRM,'(A20)') 'set ndecay 1111110 ' WRITE(NEXPRM,'(A41)') 'nodecay 220 ! prevent eta from decaying' WRITE(NEXPRM,'(A41)') 'nodecay 120 ! prevent pi+ from decaying' WRITE(NEXPRM,'(A41)') 'nodecay -120 ! prevent pi- from decaying' WRITE(NEXPRM,'(A41)') 'nodecay 130 ! prevent K+ from decaying' WRITE(NEXPRM,'(A41)') 'nodecay -130 ! prevent K- from decaying' WRITE(NEXPRM,'(A41)') 'nodecay -14 ! prevent mu- from decaying' WRITE(NEXPRM,'(A41)') 'nodecay 14 ! prevent mu+ from decaying' #if __EPOS__ WRITE(NEXPRM,'(A41)') 'nodecay -1220! prevent an from decaying' WRITE(NEXPRM,'(A41)') 'nodecay 1220! prevent n from decaying' WRITE(NEXPRM,'(A41)') 'nodecay 17 ! prevent De from decaying' WRITE(NEXPRM,'(A41)') 'nodecay 18 ! prevent Tr from decaying' WRITE(NEXPRM,'(A41)') 'nodecay 19 ! prevent Al from decaying' #endif #endif WRITE(NEXPRM,'(A28)') 'set pnll 200 ! dummy energy ' FNEXSG = .TRUE. #elif __QGSJET__ FQGS = .TRUE. FQGSSG = .TRUE. LEVLDQ = 0 #elif __SIBYLL__ FSIBYL = .TRUE. FSIBSG = .TRUE. ISDEBUG = 0 #elif __VENUS__ FVENUS = .TRUE. FVENSG = .TRUE. ISH00 = 91 IPARAM = 0 NPARAM = 0 DO I = 1, 100 PARVAL(I) = 0. ENDDO #endif #if __INTTEST__ ITTAR = 0 MCM = 0 C SET DECAY MODES AND RREGULATE WHETHER SPECTATORS ARE PLOTTED LPI0 = .TRUE. LETA = .TRUE. LHYP = .TRUE. LK0S = .TRUE. LSPEC = .FALSE. HISTDS = 'histo.corsika.inttest ' NDIF = 0 NTRIG = 0 #endif #if __PLOTSH__ || __PLOTSH2__ PLOTSH = .FALSE. #endif #if __PLOTSH2__ C ENERGY AND TIME CUTS FOR PLOTTING PLCUT(1) = 0.3D0 PLCUT(2) = 0.3D0 PLCUT(3) = 0.003D0 PLCUT(4) = 0.003D0 PLTCUT = 1.D5 C WHETHER TO TRUNCATE TRACKS TO BOX GIVEN BY AXIS RANGES FBOXCUT = .FALSE. C AXIS RANGES FOR PLOT MAPS (IN CM) PLX1 = -5.D5 PLX2 = 5.D5 PLY1 = -5.D5 PLY2 = 5.D5 PLZ1 = 0.D0 PLZ2 = 30.D5 #endif #if __VIEWCONE__ VUECON(1) = 0.D0 VUECON(2) = 0.D0 #endif C----------------------------------------------------------------------- C OPEN DATASET FOR COMMANDS #if __UNIX__ IF ( MONIIN .NE. 5 ) THEN #if __PARALLELIB__ OPEN(UNIT=MONIIN,FILE=DSNINP,STATUS='OLD',FORM='FORMATTED') #else OPEN(UNIT=MONIIN,FILE='INPUTS',STATUS='OLD',FORM='FORMATTED') #endif WRITE(MONIOU,*) 'DATA CARDS FOR RUN STEERING ARE ', * 'EXPECTED FROM UNIT',MONIIN ELSE WRITE(MONIOU,*) 'DATA CARDS FOR RUN STEERING ARE ', * 'EXPECTED FROM STANDARD INPUT' ENDIF WRITE(MONIOU,*) ' ' #elif __MAC__ OPEN(UNIT=MONIIN,FILE='INPUTS',ACTION='READ',FORM='FORMATTED') #endif NUMERR = 0 C----------------------------------------------------------------------- 1 CONTINUE C ERASE 'LINE' BY FILLING WITH BLANKS LINE = ' ' #if __REMOTECONTROL__ CALL remotecontrol_steering_nextline(LINE, LEN(LINE), IE) IF(IE .EQ. 0) THEN GOTO 1000 ENDIF #else C GET A NEW INPUT LINE AND PRINT IT READ(MONIIN,500,END=1000) LINE 500 FORMAT(A) #endif DO IE = LEN(LINE), 1, -1 IF ( LINE(IE:IE) .NE. ' ' ) GOTO 11 ENDDO 11 CONTINUE C CHECK FOR HORIZONTAL TABS AND ELIMINATE THEM DO I = 1, IE IF ( LINE(I:I) .EQ. TAB ) THEN LINE(I:I) = ' ' ENDIF ENDDO C ECHO WRITE THE INPUT LINE IF ( DEBUG ) THEN WRITE(MDEBUG,501) LINE(1:IE) 501 FORMAT(' DATAC : ',A) ELSE WRITE(MONIOU,502) LINE(1:IE) *502 FORMAT(' ',A) 502 FORMAT(A) ENDIF C CONVERT FIRST KEYWORD FROM LOWER CASE CHARACTERS TO UPPER CASE DO I = 1, LEN(LINE) IF ( LINE(I:I).EQ.'*' .OR. LINE(I:I).EQ.' ' ) GOTO 101 CALL LOWUP( LINE(I:I),IDCHAR ) ENDDO C EXCEPT FOR SPECIFIC KEYWORDS CONVERT ALSO THE REMAINING CHARACTERS 101 IF ( LINE(1:4) .NE. 'HOST' * .AND. LINE(1:4) .NE. 'USER' * .AND. LINE(1:6) .NE. 'DIRECT' * .AND. LINE(1:6) .NE. 'DATDIR' * .AND. LINE(1:6) .NE. 'HISTDS' #if __CERENKOV__ && __IACT__ * .AND. LINE(1:6) .NE. 'TELFIL' * .AND. LINE(1:5) .NE. 'IACT ' #endif #if __EPOS__ * .AND. LINE(1:6) .NE. 'EPOPAR' #elif __NEXUS__ * .AND. LINE(1:6) .NE. 'NEXPAR' #endif #if __STACKIN__ * .AND. LINE(1:6) .NE. 'INFILE' #else * .AND. LINE(1:7) .NE. 'OUTFILE' #endif #if __PARALLEL__ && !__PARALLELIB__ * .AND. LINE(1:7) .NE. 'CUTFILE' #endif #if __DYNSTACK__ * .AND. LINE(1:8) .NE. 'DYNSTACK' #endif #if __REMOTECONTROL__ * .AND. LINE(1:14) .NE. 'REMOTE_CONTROL' #endif * ) THEN DO I = 2, LEN(LINE) CALL LOWUP( LINE(I:I),IDCHAR ) ENDDO #if __INTTEST__ || __ANAHIST__ || __AUGERHIST__ C CHECK FOR CAPITALS IN DIRECTORY NAMES FOR HBOOK HISTO OUTPUT ELSEIF ( LINE(1:6) .EQ. 'DIRECT' .OR. * LINE(1:6) .EQ. 'HISTDS' ) THEN DO I = 8, LEN(LINE) LINEC = LINE(I:I) CALL LOWUP( LINEC,IDCHAR ) C NO CHANGE AFTER CONVERSION MEANS: WE HAVE A CAPITAL IN DIRECTORY NAME IF ( IDCHAR .NE. 0 .AND. LINEC .EQ. LINE(I:I) ) THEN WRITE(MONIOU,*) 'DATAC : DIRECTORY NAME CONTAINS CAPITALS' WRITE(MONIOU,502) LINE(1:I) WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORD: DIRECT OR HISTDS' STOP ENDIF ENDDO #endif ENDIF #if __CERENKOV__ && __IACT__ CALL TELLNI( LINE,LEN(LINE) ) #endif C----------------------------------------------------------------------- C INTERPRET KEYWORD AND READ PARAMETERS IS = 0 C DUMMY LINE (MAY BE USED FOR COMMENTS) NO ACTION IF ( LINE(1:6) .EQ. ' ' ) THEN ELSEIF ( LINE(1:1) .EQ. '*' ) THEN ELSEIF ( LINE(1:2) .EQ. 'C ' ) THEN #if __CERENKOV__ && __IACT__ C IACT-SPECIFIC LINES ALSO TREATED LIKE COMMENTS ELSEIF ( LINE(1:5) .EQ. 'IACT ' ) THEN #endif C GET ANGLE (DEGREES) BETWEEN ARRAY X-DIRCTION AND MAGNETIC NORD ELSEIF ( LINE(1:6) .EQ. 'ARRANG' ) THEN #if !__COASTUSERLIB__ CALL DTCDBL( LINE,IS,ARRANG,'ARRANG',1 ) #else WRITE(MONIOU,*) 'DATAC : ARRANG NOT COMPATIBLE WITH COAST' STOP #endif C READ ATMOSPHERIC PARAMETERS AATM(.,0) ELSEIF ( LINE(1:4) .EQ. 'ATMA' ) THEN CALL DTCDBL( LINE,IS,AATM0(1,0),'ATMA',1 ) CALL DTCDBL( LINE,IS,AATM0(2,0),'ATMA',2 ) CALL DTCDBL( LINE,IS,AATM0(3,0),'ATMA',3 ) CALL DTCDBL( LINE,IS,AATM0(4,0),'ATMA',4 ) AATM0(5,0) = .01128292D0 IF ( MODATM .EQ. 10 ) THEN AATM0(1,10) = AATM0(1,0) AATM0(2,10) = AATM0(2,0) AATM0(3,10) = AATM0(3,0) AATM0(4,10) = AATM0(4,0) CALL DTCDBL( LINE,IS,AATM0(5,10),'ATMA',5 ) ENDIF C READ ATMOSPHERIC PARAMETERS BATM(.,0) ELSEIF ( LINE(1:4) .EQ. 'ATMB' ) THEN CALL DTCDBL( LINE,IS,BATM0(1,0),'ATMB',1 ) CALL DTCDBL( LINE,IS,BATM0(2,0),'ATMB',2 ) CALL DTCDBL( LINE,IS,BATM0(3,0),'ATMB',3 ) CALL DTCDBL( LINE,IS,BATM0(4,0),'ATMB',4 ) BATM0(5,0) = 1.D0 IF ( MODATM .EQ. 10 ) THEN BATM0(1,10) = BATM0(1,0) BATM0(2,10) = BATM0(2,0) BATM0(3,10) = BATM0(3,0) BATM0(4,10) = BATM0(4,0) ENDIF C READ ATMOSPHERIC PARAMETERS CATM(.,0) ELSEIF ( LINE(1:4) .EQ. 'ATMC' ) THEN CALL DTCDBL( LINE,IS,CATM0(1,0),'ATMC',1 ) CALL DTCDBL( LINE,IS,CATM0(2,0),'ATMC',2 ) CALL DTCDBL( LINE,IS,CATM0(3,0),'ATMC',3 ) CALL DTCDBL( LINE,IS,CATM0(4,0),'ATMC',4 ) CATM0(5,0) = 1.D9 IF ( MODATM .EQ. 10 ) THEN CATM0(1,10) = CATM0(1,0) CATM0(2,10) = CATM0(2,0) CATM0(3,10) = CATM0(3,0) CATM0(4,10) = CATM0(4,0) CALL DTCDBL( LINE,IS,CATM0(5,10),'ATMC',5 ) ENDIF C READ ATMOSPHERIC LAYER BOUNDARIES HLAY0(.,0) ELSEIF ( LINE(1:6) .EQ. 'ATMLAY' ) THEN CALL DTCDBL( LINE,IS,HLAY0(2,0),'ATMLAY',1 ) CALL DTCDBL( LINE,IS,HLAY0(3,0),'ATMLAY',2 ) CALL DTCDBL( LINE,IS,HLAY0(4,0),'ATMLAY',3 ) CALL DTCDBL( LINE,IS,HLAY0(5,0),'ATMLAY',4 ) HLAY0(1,0) = 0.D0 LAYNEW = .TRUE. C GET INTERNAL ATMOSPHERIC MODEL NUMBER ELSEIF ( LINE(1:5) .EQ. 'ATMOD' ) THEN CALL DTCINT( LINE,IS,MODATM,'ATMOD',1 ) #if __ATMEXT__ C SET EXTERNAL ATMOSPHERIC MODEL (MOST USEFUL FOR CHERENKOV LIGHT) C AND DETERMINE IF ATMOSPHERIC REFRACTION SHOULD BE ACCOUNTED FOR. ELSEIF ( LINE(1:10) .EQ. 'ATMOSPHERE' ) THEN CALL DTCINT( LINE,IS,IATMOX,'ATMOSPHERE',1 ) CALL DTCLOG( LINE,IS,FREFRX,'ATMOSPHERE',2 ) #if !__CERENKOV__ FREFRX = .FALSE. #endif #endif #if __AUGERHIT__ C SET THE AUGER SCATTERING POSITIONS BY INPUT (ONLY IF MAUGPOS = 0) C POSITIONS ARE IN DETECTOR COORDINATE SYSTEM (IN METER) ELSEIF ( LINE(1:6) .EQ. 'AUGHIT' ) THEN IF ( MAUGPOS .EQ. 0 ) THEN MAUGPS2 = MAUGPS2 + 1 IF ( MAUGPS2 .LE. 20 ) THEN CALL DTCDBL( LINE,IS,XSHCORE(MAUGPS2),'AUGHIT',1 ) CALL DTCDBL( LINE,IS,YSHCORE(MAUGPS2),'AUGHIT',2 ) ELSE WRITE(MONIOU,*) 'DATAC : TOO MANY AUGERHIT POSITIONS,', * ' IGNORE IT' ENDIF ELSE WRITE(MONIOU,*) 'DATAC : AUGERHIT POSITIONS ARE DETERMINED ', * 'BY SOBOL RANDOM GENERATOR, IGNORE THIS INPUT LINE' ENDIF C SET NUMBER OF SCATTERS OF AUGER ARRAY, EFFECTIVE AUGER DET. RADIUS, C DETECTOR DISTANCE, FLAG TO CHECK HITTING OF TANK SHADOW (= .TRUE) C OR ONLY THE ENVIRONMENT WITHIN DRADIUS (= .FALSE.), C FLAG TO CHECK WHETHER PARTICLE SURVIVES ANY MODE IN MULTIPLE THINNING C MAUGPOS = 0: SCATTER POSITIONS ARE READ IN BY KEYWORD 'AUGHIT' C MAUGPOS > 0: SCATTER POSITIONS ARE SELECTED AT RANDOM ELSEIF ( LINE(1:6) .EQ. 'AUGSCT' ) THEN CALL DTCINT( LINE,IS,MAUGPOS,'AUGSCT',1 ) CALL DTCDBL( LINE,IS,DRADIUS,'AUGSCT',2 ) CALL DTCDBL( LINE,IS,DETDIS,'AUGSCT',3 ) CALL DTCLOG( LINE,IS,FTANKSHADW,'AUGSCT',4 ) CALL DTCLOG( LINE,IS,FANYMODE,'AUGSCT',5 ) #endif #if __CERENKOV__ ELSEIF ( LINE(1:6) .EQ. 'CDEBUG' ) THEN CALL DTCLOG( LINE,IS,LCERDB,'CDEBUG',1 ) #if !__IACT__ C GET CHERENKOV ARRAY SPECIFICATIONS ELSEIF ( LINE(1:6) .EQ. 'CERARY' ) THEN CALL DTCINT( LINE,IS,NCERX,'CERARY',1 ) CALL DTCINT( LINE,IS,NCERY,'CERARY',2 ) CALL DTCDBL( LINE,IS,DCERX,'CERARY',3 ) CALL DTCDBL( LINE,IS,DCERY,'CERARY',4 ) CALL DTCDBL( LINE,IS,ACERX,'CERARY',5 ) CALL DTCDBL( LINE,IS,ACERY,'CERARY',6 ) #endif C GET CHERENKOV OUTPUT FLAG ELSEIF ( LINE(1:6) .EQ. 'CERFIL' ) THEN CALL DTCINT( LINE,IS,MCERFI,'CERFIL',1 ) #if __CEFFIC__ C GET FLAG FOR QUANTUM EFFICIENCY, ATMOSPHERIC EXTINCTION, AND C MIRROR REFLECTIVITY FOR CHERENKOV LIGHT ELSEIF ( LINE(1:6) .EQ. 'CERQEF' ) THEN CALL DTCLOG( LINE,IS,CERQEF,'CERQEF',1 ) CALL DTCLOG( LINE,IS,CERATA,'CERQEF',2 ) CALL DTCLOG( LINE,IS,CERMIR,'CERQEF',3 ) #endif #endif #if __CERENKOV__ || __AUGERHIST__ || __AUGCERLONG__ C GET MAXIMUM BUNCH SIZE FOR CHERENKOV PHOTONS ELSEIF ( LINE(1:6) .EQ. 'CERSIZ' ) THEN CALL DTCDBL( LINE,IS,CERSIZ,'CERSIZ',1 ) #endif #if __COMPACT__ C GET FLAG FOR COMPACT OUTPUT ELSEIF ( LINE(1:6) .EQ. 'COMOUT' ) THEN CALL DTCLOG( LINE,IS,COMOUT,'COMOUT',1 ) #endif #if __ICECUBE2__ C GET FLAG FOR COMPRESSED OUTPUT ELSEIF ( LINE(1:8) .EQ. 'COMPRESS' ) THEN CALL DTCLOG( LINE,IS,gzip_output,'COMPRESS',1 ) #endif #if __CONEX__ C GET CONEX MC TO CE THRESHOLDS ELSEIF ( LINE(1:5) .EQ. 'CONEX' ) THEN CALL DTCDBL( LINE,IS,CXTHR(1),'CONEX',1 ) CALL DTCDBL( LINE,IS,CXTHR(2),'CONEX',2 ) CALL DTCDBL( LINE,IS,CXTHR(3),'CONEX',3 ) C GET CONEX 2 CORSIKA THRESHOLDS ELSEIF ( LINE(1:6) .EQ. 'CX2COR' ) THEN CALL DTCDBL( LINE,IS,CXMCT(1),'CX2COR',1 ) CALL DTCDBL( LINE,IS,CXMCT(2),'CX2COR',2 ) CALL DTCDBL( LINE,IS,CXMCT(3),'CX2COR',3 ) CALL DTCDBL( LINE,IS,CXMCS,'CX2COR',4 ) C OVERWRITE DEFAULT PARAMETERS ONLY IF CASCADE EQUATIONS AND LOW ENERGY MC C ARE USED IF ( .NOT.FCXLCE .AND. FCXCAS ) THEN CXMCC(1) = CXMCT(1) CXMCC(2) = CXMCT(2) CXMCC(3) = CXMCT(3) ENDIF C GET CONEX WEIGHT SAMPLING ELSEIF ( LINE(1:5) .EQ. 'CXWMX' ) THEN CALL DTCDBL( LINE,IS,CXWMT(1),'CXWMX',1 ) CALL DTCDBL( LINE,IS,CXWMT(2),'CXWMX',2 ) CALL DTCDBL( LINE,IS,CXWMT(3),'CXWMX',3 ) CALL DTCLOG( LINE,IS,FCXWMX, 'CXWMX',4 ) CALL DTCLOG( LINE,IS,FCXCE, 'CXWMX',5 ) C OVERWRITE DEFAULT PARAMETERS ONLY IF CASCADE EQUATIONS AND LOW ENERGY MC C ARE USED c IF ( .NOT.FCXLCE .AND. FCXCAS ) THEN CXWMX(1) = CXWMT(1) CXWMX(2) = CXWMT(2) CXWMX(3) = CXWMT(3) c ENDIF C FLAG TO GET SIMPLIFIED CONEX THRESHOLDS MANAGEMENT ELSEIF ( LINE(1:7) .EQ. 'CASCADE' ) THEN CALL DTCLOG( LINE,IS,FCXCAS,'CASCADE',1 ) CALL DTCLOG( LINE,IS,FCXLCE,'CASCADE',2 ) CALL DTCLOG( LINE,IS,FCXGHE,'CASCADE',3 ) IF ( FCXCAS ) THEN IF( .NOT. FECUT ) THEN WRITE(MONIOU,*) * 'DATAC : CASCADE KEYWORD HAS TO BE CALLED AFTER ECUTS !' NUMERR = NUMERR + 1 GOTO 1 ENDIF IF ( FCXLCE ) THEN C CONEX MC ABOVE CXTHR AND ONLY CASCADE EQUATIONS BELOW IF ( FCXGHE ) THEN C FORCE HADRONIC CASCADE EQUATIONS EVEN IF C HADRONIC ECUT TOO LOW FOR CONEX (FAST AND GOOD FOR XMAX BUT NOT NMU) CXMCC(1) = 0.D0 CXWMX(1) = 1.D-6 / SQRT( MAX( 1.D0, ELCUT(1) ) ) CXMCC(2) = 0.D0 !KEEP MUONS IN CE CXWMX(2) = 1.D-6 / SQRT( MAX( 1.D0, ELCUT(2) ) ) CXMCC(3) = 0.D0 ELSE C CONEX MC ABOVE CXTHR AND ONLY CASCADE EQUATIONS for EM BELOW CXMCC(1) = 1.D3 CXWMX(1) = 1.D-7 / SQRT( MAX( 1.D0, ELCUT(1) ) ) CXMCC(2) = 1.D20 !GIVES MUONS TO CORSIKA CXWMX(2) = 1.D-7 / SQRT( MAX( 1.D0, ELCUT(2) ) ) CXMCC(3) = 0.D0 ENDIF C IF ENERGY CUT TOO LOW, SAMPLING IS USED WITH C REASONABLE WEIGHT AND USE THE SAME IN CORSIKA THINNING C BUT NOT IN CONEX THINNING TO KEEP SHOWER REPRODUCTIBILITY FCXCE = .TRUE. CXWMX(3) = 1.D-4 / SQRT( MAX( 1.D0, ELCUT(3) * 1.D3 ) ) ELSEIF(FCXGHE)THEN WRITE(MONIOU,*) 'DATAC : CASCADE T F T IS NOT POSSIBLE,', * 'ONLY T T T, T T F, T F F, OR F F F' STOP ELSE C LOW ENERGY MONTE-CARLO IN CORSIKA AFTER CASCADE EQUATIONS C DEFAULT PARAMETERS ARE USED WITH RELATIVE WEIGHT DEFINITION FOR SAMPLING CXWMX(1) = 3.D-8 / SQRT( MAX( 1.D0, ELCUT(1) ) ) CXWMX(2) = 3.D-8 / SQRT( MAX( 1.D0, ELCUT(2) ) ) CXWMX(3) = 3.D-6 / SQRT( MAX( 1.D0, ELCUT(3) * 1.D3 ) ) FCXCE = .TRUE. ENDIF ELSEIF(FCXLCE.OR.FCXGHE)THEN WRITE(MONIOU,*) 'DATAC : CASCADE COMBINATION NOT VALID,', * 'ONLY T T T, T T F, T F F, OR F F F' STOP ELSE C PURE MONTE-CARLO USING CONEX MC ABOVE CXTHR CXMCC(1) = 1.D20 CXMCC(2) = 1.D20 CXMCC(3) = 1.D20 ENDIF C SWITCH CORSIKA ON/OFF (FOR DEBUGGING) ELSEIF ( LINE(1:7) .EQ. 'CORSIKA' ) THEN CALL DTCLOG( LINE,IS,FCORS, 'CORSIKA',1 ) #endif C RCUT [cm] IS LIMIT WITHIN WHICH PARTICLES ARE DISCARDED ELSEIF ( LINE(1:7) .EQ. 'CORECUT' ) THEN CALL DTCDBL( LINE,IS,RCUT,'CORECUT',1 ) RCUT2 = RCUT**2 #if __CERENKOV__ C GET CHERENKOV CORE POSITIONS ELSEIF ( LINE(1:7) .EQ. 'COREPOS' ) THEN ICERML = ICERML + 1 IF ( ICERML .LE. 20 ) THEN CALL DTCDBL( LINE,IS,CERXOS(ICERML),'COREPOS',1 ) CALL DTCDBL( LINE,IS,CERYOS(ICERML),'COREPOS',2 ) ELSE WRITE(MONIOU,*) 'TOO MANY CHERENKOV CORE POSITIONS DEFINED' WRITE(MONIOU,*) 'MAXIMUM NUMBER IS: 20' c STOP ENDIF C GET CHERENKOV EVENT SCATTERING INFORMATION ELSEIF ( LINE(1:5) .EQ. 'CSCAT' ) THEN IF ( ICERML .EQ. 0 ) THEN CALL DTCINT( LINE,IS,ICERML,'CSCAT',1 ) CALL DTCDBL( LINE,IS,XSCATT,'CSCAT',2 ) CALL DTCDBL( LINE,IS,YSCATT,'CSCAT',3 ) #if __IACT__ CALL TELASU( ICERML,XSCATT,YSCATT ) #endif ELSE WRITE(MONIOU,*) 'DATAC : KEYWORD CSCAT IGNORED, AS KEYWORD ', * 'COREPOS IS USED TO DETERMINE CORE POSITIONS' ENDIF #endif #if __CURVED__ && !__ANAHIST__ && !__AUGERHIST__ && !__CERENKOV__ C GET FLAGS FOR PARTICLE AND TABLE OUTPUT ELSEIF ( LINE(1:7) .EQ. 'CURVOUT' ) THEN CALL DTCLOG( LINE,IS,FCURVOUT,'CURVOUT',1 ) FFLATOUT = .NOT. FCURVOUT #endif #if __PARALLEL__ C GET FULL PARTICLE INFORMATION TO FILL 2ND STACK FROM BINARY FILE ELSEIF ( LINE(1:7) .EQ. 'CUTFILE' ) THEN IF ( PASS ) THEN #if !__PARALLELIB__ CALL DTCCHR( LINE,IS,CFILINP,'CUTFILE',1,LENVAL ) CALL DTCINT( LINE,IS,I1CUTPAR,'CUTFILE',2) CALL DTCINT( LINE,IS,I2CUTPAR,'CUTFILE',3) CALL CUTREAD #endif ELSE WRITE(MONIOU,*) 'DATAC ERROR: CUTPAR HAS TO BE DEFINED', * ' AFTER PARALLEL KEYWORD' STOP ENDIF C GET FULL PARTICLE INFORMATION TO FILL 2ND STACK FROM ASCII INPUT ELSEIF ( LINE(1:6) .EQ. 'CUTPAR' ) THEN IF ( PASS ) THEN NCUTPAR = NCUTPAR + 1 IF ( .NOT. (FECTOUT .AND. NCUTPAR .GT. 1 ) ) THEN CALL DTCHEX( LINE,IS,CUTPAR(0),'CUTPAR',1 ) CALL DTCHEX( LINE,IS,CUTPAR(1),'CUTPAR',2 ) CALL DTCHEX( LINE,IS,CUTPAR(2),'CUTPAR',3 ) CALL DTCHEX( LINE,IS,CUTPAR(3),'CUTPAR',4 ) CALL DTCHEX( LINE,IS,CUTPAR(4),'CUTPAR',5 ) CALL DTCHEX( LINE,IS,CUTPAR(5),'CUTPAR',6 ) CALL DTCHEX( LINE,IS,CUTPAR(6),'CUTPAR',7 ) CALL DTCHEX( LINE,IS,CUTPAR(7),'CUTPAR',8 ) CALL DTCHEX( LINE,IS,CUTPAR(8),'CUTPAR',9 ) CALL DTCHEX( LINE,IS,CUTPAR(9),'CUTPAR',10 ) CALL DTCHEX( LINE,IS,CUTPAR(10),'CUTPAR',11 ) CALL DTCHEX( LINE,IS,CUTPAR(11),'CUTPAR',12 ) CALL DTCHEX( LINE,IS,CUTPAR(12),'CUTPAR',13 ) CALL DTCHEX( LINE,IS,CUTPAR(13),'CUTPAR',14 ) CALL DTCHEX( LINE,IS,CUTPAR(14),'CUTPAR',15 ) CALL DTCHEX( LINE,IS,CUTPAR(15),'CUTPAR',16 ) CALL DTCHEX( LINE,IS,CUTPAR(16),'CUTPAR',17 ) CALL DTCHEX( LINE,IS,CUTPAR(17),'CUTPAR',18 ) CALL DTCHEX( LINE,IS,CUTPAR(18),'CUTPAR',19 ) ISEED(1,6) = INT( CUTPAR(18) ) C SAVE PARTICLE IN 2ND STACK IF ( MSTACKPJ .GE. ISTK ) THEN CALL FSTACKJO(1) WRITE(MEXSTJ,REC=NOURECJ+1) (STACKJ(I),I= 1,ISTK/2) WRITE(MEXSTJ,REC=NOURECJ+2) (STACKJ(I),I=ISTK/2+1,ISTK ) NOURECJ = NOURECJ + 2 NSHIFTJ = NSHIFTJ + 2 MSTACKPJ = 0 ENDIF JCOUNT = JCOUNT + 1 DO J = 0, 18 STACKJ(MSTACKPJ+J+1) = CUTPAR(J) ENDDO MSTACKPJ = MSTACKPJ + MAXLEN + 1 C COUNT ENERGY IN 2ND STACK BUT WITHOUT WEIGHT BECAUSE ONLY C PARTICLE ENERGY IS IMPORTANT HERE IF ( PAMA(NINT( CUTPAR(0) )) .LE. 0.D0 ) THEN ELEFTJ = ELEFTJ + CUTPAR(1) ELSE ELEFTJ = ELEFTJ + (CUTPAR(1)-1.D0)*PAMA(NINT(CUTPAR(0))) ENDIF ELSE WRITE(MONIOU,*) 'DATAC ERROR: ONLY ONE CUTPAR DEFINITION', * ' IF PARALLEL=T' STOP ENDIF ELSE WRITE(MONIOU,*) 'DATAC ERROR: CUTPAR HAS TO BE DEFINED', * ' AFTER PARALLEL KEYWORD' STOP ENDIF #endif /*__PARALLEL__*/ #if __CERENKOV__ || __AUGERHIST__ || __AUGCERLONG__ C GET CHERENKOV WAVELENGTH BAND ELSEIF ( LINE(1:6) .EQ. 'CWAVLG' ) THEN CALL DTCDBL( LINE,IS,R1,'CWAVLG',1 ) CALL DTCDBL( LINE,IS,R2,'CWAVLG',2 ) WAVLGL = MIN( R1, R2 ) WAVLGU = MAX( R1, R2 ) #endif C GET DATABASE FLAG ELSEIF ( LINE(1:6) .EQ. 'DATBAS' ) THEN CALL DTCLOG( LINE,IS,FDBASE,'DATBAS',1 ) C GET DIRECTORY WHERE ALL INPUT DATA TABLES ARE STORED ELSEIF ( LINE(1:6) .EQ. 'DATDIR' ) THEN CALL DTCCHR( LINE,IS,DATDIR,'DATDIR',1,LENVAL ) C ADD TRAILING '/' TO DIRECTORY, IF MISSING IF (DATDIR(INDEX(DATDIR,' ')-1:INDEX(DATDIR,' ')-1).NE.'/') THEN DATDIR(INDEX(DATDIR,' '):INDEX(DATDIR,' ')) = '/' ENDIF C GET DEBUG FLAG AND DELAYED DEBUG PARAMETERS ELSEIF ( LINE(1:5) .EQ. 'DEBUG' ) THEN CALL DTCLOG( LINE,IS,DEBUG,'DEBUG',1 ) CALL DTCINT( LINE,IS,MMM,'DEBUG',2 ) CALL DTCLOG( LINE,IS,DEBDEL,'DEBUG',3 ) CALL DTCINT( LINE,IS,NDEBDL,'DEBUG',4 ) IF ( MMM .LE. 0 .OR. MMM .GT. 99 ) THEN MDEBUG = 6 ELSE MDEBUG = MMM ENDIF #if __VOLUMECORR__ C GET DETECTOR RATIO: XI=4*HEIGHT/(PI*DIAMETER) C READ IN RATIO HEIGHT/DIAMETER ELSEIF ( LINE(1:6) .EQ. 'DETCFG' ) THEN CALL DTCDBL( LINE,IS,DETCFG,'DETCFG',1 ) DETCFG = DETCFG*4.D0 / PI #endif #if __INTTEST__ C GET DIFFRACTION SWITCH ELSEIF ( LINE(1:6) .EQ. 'DIFOFF' ) THEN CALL DTCINT( LINE,IS,NDIF,'DIFOFF',1 ) #endif C GET OUTPUT DIRECTORY FOR CALCULATIONS ON UNIX-STATION ELSEIF ( LINE(1:6) .EQ. 'DIRECT' ) THEN CALL DTCCHR( LINE,IS,DSN,'DIRECT',1,LENVAL ) #if __DPMJET__ C GET CROSS-SECTION FLAG FOR DPMJET HADRONIC INTERACTION MODEL ELSEIF ( LINE(1:6) .EQ. 'DPJSIG' ) THEN CALL DTCLOG( LINE,IS,FDPJSG,'DPJSIG',1 ) C GET FLAG FOR DPMJET HIGH ENERGY HADRONIC INTERACTION MODEL ELSEIF ( LINE(1:6) .EQ. 'DPMJET' ) THEN CALL DTCLOG( LINE,IS,FDPMJT,'DPMJET',1 ) CALL DTCINT( LINE,IS,LEVLDB,'DPMJET',2 ) #endif #ifdef __DYNSTACK__ ELSEIF ( LINE(1:8) .EQ. 'DYNSTACK' ) THEN CALL dynstack_init( LINE, LEN(LINE) ) #endif C GET ENERGY CUTS FOR PARTICLE PRINTOUT ELSEIF ( LINE(1:6) .EQ. 'ECTMAP' ) THEN CALL DTCDBL( LINE,IS,ECTMAP,'ECTMAP',1 ) C GET ENERGY CUTS FOR HADRONS, MUONS, ELECTRONS, AND GAMMAS ELSEIF ( LINE(1:5) .EQ. 'ECUTS' ) THEN CALL DTCDBL( LINE,IS,ELCUT(1),'ECUTS',1 ) CALL DTCDBL( LINE,IS,ELCUT(2),'ECUTS',2 ) CALL DTCDBL( LINE,IS,ELCUT(3),'ECUTS',3 ) CALL DTCDBL( LINE,IS,ELCUT(4),'ECUTS',4 ) #ifdef __DYNSTACK__ CALL baack_elcut(ELCUT, SIZEOF(ELCUT) ) #endif #if __CONEX__ FECUT = .TRUE. #endif C GET COUNTER FOR START OF EGS DEBUGGING ELSEIF ( LINE(1:6) .EQ. 'EGSDEB' ) THEN CALL DTCINT( LINE,IS,JCLOCK,'EGSDEB',1 ) C GET FLAGS FOR ELECTROMAGNETIC OPTIONS (NKG, EGS) ELSEIF ( LINE(1:6) .EQ. 'ELMFLG' ) THEN CALL DTCLOG( LINE,IS,FNKG,'ELMFLG',1 ) CALL DTCLOG( LINE,IS,FEGS,'ELMFLG',2 ) #if !__INTTEST__ && __EHISTORY__ C GET FLAG FOR ADDITIONAL EM INFORMATION ON MPATAP ELSEIF ( LINE(1:6) .EQ. 'EMADDI' ) THEN CALL DTCLOG( LINE,IS,FEMADD,'EMADDI',1 ) #endif #if !__STACKIN__ C GET ENERGY RANGE OF PRIMARY PARTICLE ELSEIF ( LINE(1:6) .EQ. 'ERANGE' ) THEN CALL DTCDBL( LINE,IS,LLIMIT,'ERANGE',1 ) CALL DTCDBL( LINE,IS,ULIMIT,'ERANGE',2 ) C GET SLOPE OF ENERGY SPECTRUM OF PRIMARY PARTICLE ELSEIF ( LINE(1:6) .EQ. 'ESLOPE' ) THEN CALL DTCDBL( LINE,IS,PSLOPE,'ESLOPE',1 ) #endif C GET FIRST EVENT NUMBER ELSEIF ( LINE(1:5) .EQ. 'EVTNR' ) THEN CALL DTCINT( LINE,IS,ISHOWNO,'EVTNR',1 ) ISHOWNO = MAX( 0, ISHOWNO-1 ) C END OF DATA CARD INPUT ELSEIF ( LINE(1:4) .EQ. 'EXIT' ) THEN IF ( DEBUG ) THEN WRITE(MONIOU,*) 'DATAC : END OF DATACARD INPUT' ELSE WRITE(MONIOU,*) WRITE(MONIOU,*) 'END OF DATACARD INPUT' ENDIF GOTO 1001 C GET FIXED HEIGHT (G/CM**2) OF PARTICLE START ELSEIF ( LINE(1:6) .EQ. 'FIXCHI' ) THEN CALL DTCDBL( LINE,IS,THICK0,'FIXCHI',1 ) C GET FIXED HEIGHT OF FIRST INTERACTION AND FIRST TARGET ELSEIF ( LINE(1:6) .EQ. 'FIXHEI' ) THEN CALL DTCDBL( LINE,IS,FIXHEI,'FIXHEI',1 ) CALL DTCINT( LINE,IS,N1STTR,'FIXHEI',2 ) IF ( FIXHEI .GT. 0.D0 ) FIX1I = .TRUE. #if __CURVED__ && !__ANAHIST__ && !__AUGERHIST__ && !__CERENKOV__ C OLD DEFINITION FOR COMPATIBILITY ELSEIF ( LINE(1:7) .EQ. 'FLATOUT' ) THEN CALL DTCLOG( LINE,IS,FFLATOUT,'FLATOUT',1 ) #endif #if __FLUKA__ C GET FLAG FOR FLUKA WRITE OUT ELSEIF ( LINE(1:6) .EQ. 'FLUDBG' ) THEN CALL DTCLOG( LINE,IS,FFLUDB,'FLUDBG',1 ) #endif #if __PRESHOWER__ || __CONEX__ C GET GLOBAL COORDINATES AND YEAR OF EXPERIMENT ELSEIF ( LINE(1:6) .EQ. 'GCOORD' ) THEN CALL DTCDBL( LINE,IS,GLONG,'GCOORD',1 ) CALL DTCDBL( LINE,IS,GLATI,'GCOORD',2 ) CALL DTCDBL( LINE,IS,GRFYEAR,'GCOORD',3 ) CALL DTCINT( LINE,IS,IPREPR,'GCOORD',4 ) CALL DTCINT( LINE,IS,IPRSTP,'GCOORD',5 ) #endif #if __TRAJECT__ C GET GEOGRAPHIC DECLINATION OF TELESCOPE LOCATION ELSEIF ( LINE(1:6) .EQ. 'GEODEC' ) THEN CALL DTCDBL( LINE,IS,GEODECL,'GEODEC',1 ) #endif #if __GHEISHAD__ C GET FLAG FOR GHEISHA DEBUG ELSEIF ( LINE(1:6) .EQ. 'GHEIDB' ) THEN CALL DTCLOG( LINE,IS,GHEISDB,'GHEIDB',1 ) #endif C GET FLAGS FOR HADRON INTERACTION OPTIONS ELSEIF ( LINE(1:6) .EQ. 'HADFLG' ) THEN CALL DTCINT( LINE,IS,NFLAIN,'HADFLG',1 ) CALL DTCINT( LINE,IS,NFLDIF,'HADFLG',2 ) CALL DTCINT( LINE,IS,NFLPI0,'HADFLG',3 ) CALL DTCINT( LINE,IS,NFLPIF,'HADFLG',4 ) CALL DTCINT( LINE,IS,NFLCHE,'HADFLG',5 ) CALL DTCINT( LINE,IS,NFRAGM,'HADFLG',6 ) C GET TRANSITION ENERGY BETWEEN INTERACTION MODELS ELSEIF ( LINE(1:5) .EQ. 'HILOW' ) THEN CALL DTCDBL( LINE,IS,HILOELB,'HILOW',1 ) #if __CONEX__ IF ( HILOELB .LT. 50.D0 ) THEN WRITE(MONIOU,*) 'WARNING: HIGH ENERGY HADRONIC INTERACTION' & ,' MODEL CAN NOT BE USED BELOW 50 GEV IN CONEX' WRITE(MONIOU,*) 'DO NOT USE HILOELB < 50 GEV !' STOP ENDIF #endif #if __INTTEST__ C GET DATASET NAME FOR HISTOGRAM STORAGE ELSEIF ( LINE(1:6) .EQ. 'HISTDS' ) THEN CALL DTCCHR( LINE,IS,HISTDS,'HISTDS',1,LENVAL ) #endif C GET NAME OF HOST COMPUTER ELSEIF ( LINE(1:4) .EQ. 'HOST' ) THEN CALL DTCCHR( LINE,IS,HOST,'HOST',1,LENVAL ) #if __CURVED__ && __UPWARD__ C GET IMPACT PARAMETER (MINIMAL VERTICAL ALTITUDE) ELSEIF ( LINE(1:6) .EQ. 'IMPACT' ) THEN CALL DTCDBL( LINE,IS,R1,'IMPACT',1) CALL DTCDBL( LINE,IS,R2,'IMPACT',2) HIMPACT(1) = MIN( R1, R2 ) HIMPACT(2) = MAX( R1, R2 ) FIMPCT = .TRUE. #endif #if __COASTUSERLIB__ C GET COORDINATES OF INCLINED OBSERVATION LEVEL ELSEIF ( LINE(1:6) .EQ. 'INCLIN' ) THEN CALL DTCDBL( LINE,IS,XPINCL,'INCLIN',1 ) CALL DTCDBL( LINE,IS,YPINCL,'INCLIN',2 ) CALL DTCDBL( LINE,IS,ZPINCL,'INCLIN',3 ) CALL DTCDBL( LINE,IS,THINCL,'INCLIN',4 ) CALL DTCDBL( LINE,IS,PHINCL,'INCLIN',5 ) #endif #if __STACKIN__ C GET FILE NAME FOR SECONDARY INPUT TO STACK ELSEIF ( LINE(1:6) .EQ. 'INFILE' ) THEN CALL DTCCHR( LINE,IS,FILINP,'INFILE',1,LENVAL ) #endif #if __INTTEST__ C GET DECAY SWITCHES ELSEIF ( LINE(1:6) .EQ. 'INTDEC' ) THEN CALL DTCLOG( LINE,IS,LPI0,'INTDEC',1 ) CALL DTCLOG( LINE,IS,LETA,'INTDEC',2 ) CALL DTCLOG( LINE,IS,LHYP,'INTDEC',3 ) CALL DTCLOG( LINE,IS,LK0S,'INTDEC',4 ) C GET SPECTATOR SWITCH ELSEIF ( LINE(1:6) .EQ. 'INTSPC' ) THEN CALL DTCLOG( LINE,IS,LSPEC,'INTSPC',1 ) C GET TARGET AND MODE OF CM CALCULATION FOR INTERACTION TEST ELSEIF ( LINE(1:6) .EQ. 'INTTST' ) THEN CALL DTCINT( LINE,IS,ITTAR,'INTTST',1 ) CALL DTCINT( LINE,IS,MCM,'INTTST',2 ) #endif #if __ICECUBE1__ C GET "INTERESTING" NEUTRINO ENERGY THRESHOLD ELSEIF ( LINE(1:6) .EQ. 'EINTER' ) THEN CALL DTCDBL( LINE,IS,energy_interesting,'EINTER',1 ) #endif C GET PARAMETER FOR LONGITUDINAL DEVELOPMENT ELSEIF ( LINE(1:5) .EQ. 'LONGI' ) THEN CALL DTCLOG( LINE,IS,LLONGI,'LONGI',1 ) CALL DTCDBL( LINE,IS,THSTEP,'LONGI',2 ) CALL DTCLOG( LINE,IS,FLGFIT,'LONGI',3 ) #if !__COMPACT__ CALL DTCLOG( LINE,IS,FLONGOUT,'LONGI',4 ) #else FLONGOUT = .TRUE. #endif C GET PARAMETERS OF MAGNETIC FIELD ELSEIF ( LINE(1:6) .EQ. 'MAGNET' ) THEN CALL DTCDBL( LINE,IS,BX,'MAGNET',1 ) CALL DTCDBL( LINE,IS,BZ,'MAGNET',2 ) C GET NUMBER OF EVENTS TO BE PRINTED ELSEIF ( LINE(1:6) .EQ. 'MAXPRT' ) THEN CALL DTCINT( LINE,IS,MAXPRT,'MAXPRT',1 ) #if !__PARALLELIB__ IF ( MAXPRT .LE. 0 ) MAXPRT = 1 #endif #if !__INTTEST__ C GET FLAG FOR ADDITIONAL MUON INFORMATION ON MPATAP ELSEIF ( LINE(1:6) .EQ. 'MUADDI' ) THEN CALL DTCLOG( LINE,IS,FMUADD,'MUADDI',1 ) #endif C GET FLAG FOR MUON MULTIPLE SCATTERING (T=MOLIERE, F=GAUSS) ELSEIF ( LINE(1:6) .EQ. 'MUMULT' ) THEN CALL DTCLOG( LINE,IS,FMOLI,'MUMULT',1 ) #if __MULTITHIN__ C GET PARAMETERS FOR MULTIPLE THINNING (SEE 'THINH') ELSEIF ( LINE(1:6) .EQ. 'MTHINH' ) THEN IMTHIN = IMTHIN + 1 IF ( IMTHIN .LE. 6 ) THEN CALL DTCDBL( LINE,IS,EMFRACTH(IMTHIN),'MTHINH',1 ) CALL DTCDBL( LINE,IS,WMMAX0(IMTHIN),'MTHINH',2 ) CALL DTCDBL( LINE,IS,THNMRTH(IMTHIN),'MTHINH',3 ) CALL DTCDBL( LINE,IS,WTRATMH(IMTHIN),'MTHINH',4 ) NMTHIN = IMTHIN ELSE WRITE(MONIOU,*) 'DATAC : TOO MANY THINNING MODES,', * ' IGNORE IT' ENDIF C RCUT [cm] IS LIMIT WITHIN WHICH PARTICLES ARE DISCARDED ELSEIF ( LINE(1:6) .EQ. 'MTHINR' ) THEN CALL DTCDBL( LINE,IS,RCUT,'MTHINR',1 ) RCUT2 = RCUT**2 #endif #if __EPOS__ || __NEXUS__ #if __EPOS__ C GET EPOS PARAMETER WITH CODE WORD AND VALUE ELSEIF ( LINE(1:6) .EQ. 'EPOPAR' ) THEN #elif __NEXUS__ C GET NEXUS PARAMETER WITH CODE WORD AND VALUE ELSEIF ( LINE(1:6) .EQ. 'NEXPAR' ) THEN #endif IPARAM = IPARAM + 1 C RESET OPEN FLAGS FOR FILES: CHECK, HISTOGRAM AND DATA KCHOPEN = 0 KHIOPEN = 0 KDTOPEN = 0 IF ( IPARAM .LE. 100 ) THEN WRITE(NEXPRM,'(73A1)') (LINE(I:I),I=8,80) NNPARM = IPARAM ELSE #if __EPOS__ WRITE(MONIOU,*) 'DATAC : TOO MANY EPOS PARAMETERS,', * ' IGNORE IT' #elif __NEXUS__ WRITE(MONIOU,*) 'DATAC : TOO MANY NEXUS PARAMETERS,', * ' IGNORE IT' #endif ENDIF #if __EPOS__ C GET CROSS-SECTION FLAG FOR EPOS HADRONIC INTERACTION MODEL ELSEIF ( LINE(1:6) .EQ. 'EPOSIG' ) THEN CALL DTCLOG( LINE,IS,FNEXSG,'EPOSIG',1 ) C GET FLAG FOR EPOS HIGH ENERGY HADRONIC INTERACTION MODEL C GET PARAMETER ISH0N FOR AMOUNT OF EPOS DEBUG ELSEIF ( LINE(1:4) .EQ. 'EPOS' ) THEN CALL DTCLOG( LINE,IS,FNEXUS,'EPOS',1 ) CALL DTCINT( LINE,IS,ISH0N,'EPOS',2 ) #elif __NEXUS__ C GET CROSS-SECTION FLAG FOR NEXUS HADRONIC INTERACTION MODEL ELSEIF ( LINE(1:6) .EQ. 'NEXSIG' ) THEN CALL DTCLOG( LINE,IS,FNEXSG,'NEXSIG',1 ) C GET FLAG FOR NEXUS HIGH ENERGY HADRONIC INTERACTION MODEL C GET PARAMETER ISH0N FOR AMOUNT OF NEXUS DEBUG ELSEIF ( LINE(1:5) .EQ. 'NEXUS' ) THEN CALL DTCLOG( LINE,IS,FNEXUS,'NEXUS',1 ) CALL DTCINT( LINE,IS,ISH0N,'NEXUS',2 ) #endif #endif C GET NUMBER OF SHOWERS TO BE PRODUCED ELSEIF ( LINE(1:5) .EQ. 'NSHOW' ) THEN CALL DTCINT( LINE,IS,NSHOW,'NSHOW',1 ) IF ( NSHOW .LE. 0 ) NSHOW = 1 #if __PARALLEL__ C NSHOW IS ALWAYS 1 IN CASE OF PARALLEL RUN (TO BE SURE NOT TO MIX UP SHOWERS) IF ( NSHOW .NE. 1 ) THEN WRITE(MONIOU,*) 'DATAC : ONLY ONE SHOWER PER RUN ', * 'POSSIBLE IN PARALLEL VERSION' STOP ENDIF #endif #if !__INTTEST__ && __EHISTORY__ C GET FLAG FOR ADDITIONAL NU INFORMATION ON MPATAP ELSEIF ( LINE(1:6) .EQ. 'NUADDI' ) THEN CALL DTCLOG( LINE,IS,FNUADD,'NUADDI',1 ) #endif #if __NUPRIM__ C NUSLCT SELECTS INTERACTION TYPE OF PRIMARY NEUTRINO ELSEIF ( LINE(1:6) .EQ. 'NUSLCT' ) THEN CALL DTCINT( LINE,IS,NUSLCT,'NUSLCT',1 ) #endif C GET HEIGHT OF OBSERVATION LEVELS ELSEIF ( LINE(1:6) .EQ. 'OBSLEV' ) THEN IOBSLV = IOBSLV + 1 #if __CURVED__ || __UPWARD__ IF ( IOBSLV .LE. 1 ) THEN CALL DTCDBL( LINE,IS,OBSLEV(IOBSLV),'OBSLEV',1 ) NOBSLV = IOBSLV ELSE #if __CURVED__ WRITE(MONIOU,*) 'DATAC : ONLY ONE OBSERVATION LEVEL ,', * 'POSSIBLE IN CURVED VERSION' #endif #if __UPWARD__ WRITE(MONIOU,*) 'DATAC : ONLY ONE OBSERVATION LEVEL ,', * 'POSSIBLE IN UPWARD VERSION' #endif STOP #else #if __AUGERHIST__ IF ( IOBSLV .LE. 20 ) THEN #else IF ( IOBSLV .LE. 10 ) THEN #endif CALL DTCDBL( LINE,IS,OBSLEV(IOBSLV),'OBSLEV',1 ) NOBSLV = IOBSLV ELSE WRITE(MONIOU,*) 'DATAC : TOO MANY OBSERVATION LEVELS,', * ' IGNORE IT' #endif ENDIF #if !__STACKIN__ && !__CONEX__ C GET FILE NAME FOR SECONDARY OUTPUT OF STACK OF FIRST INTERACTION ELSEIF ( LINE(1:7) .EQ. 'OUTFILE' ) THEN CALL DTCCHR( LINE,IS,FILOUT,'OUTFILE',1,LENVAL ) IF(LENVAL.GT.0) FOUTFILE = .TRUE. #endif C GET NEW MONITOR OUTPUT UNIT ELSEIF ( LINE(1:6) .EQ. 'OUTPUT' ) THEN CALL DTCINT( LINE,IS,MONNEW,'OUTPUT',1 ) WRITE(MONIOU,593) MONIOU,MONNEW 593 FORMAT(' ATTENTION',/,' =========',/, * ' LOGFILE OUTPUT REDIRECTED FROM UNIT ',I3, * ' TO UNIT ',I3) MONIOU = MONNEW #if __PARALLEL__ C GET FLAG FOR WRITING PARTICLES ABOVE ECTCUT TO SPECIAL FILE ELSEIF ( LINE(1:8) .EQ. 'PARALLEL' ) THEN #if !__PARALLELIB__ CALL DTCDBL( LINE,IS,ECTCUT ,'PARALLEL',1 ) CALL DTCDBL( LINE,IS,ECTMAX ,'PARALLEL',2 ) CALL DTCINT( LINE,IS,MPIID ,'PARALLEL',3 ) CALL DTCLOG( LINE,IS,FECTOUT,'PARALLEL',4 ) #endif PASS = .TRUE. !SHOULD ALWAYS BE TRUE #endif C GET FLAGS FOR PARTICLE AND TABLE OUTPUT ELSEIF ( LINE(1:6) .EQ. 'PAROUT' ) THEN CALL DTCLOG( LINE,IS,FPAROUT,'PAROUT',1 ) CALL DTCLOG( LINE,IS,FTABOUT,'PAROUT',2 ) C GET PHI OF PRIMARY PARTICLE ELSEIF ( LINE(1:4) .EQ. 'PHIP' ) THEN CALL DTCDBL( LINE,IS,R1,'PHIP',1 ) CALL DTCDBL( LINE,IS,R2,'PHIP',2 ) PHIPR(1) = MIN( R1, R2 ) PHIPR(2) = MAX( R1, R2 ) #if __ICECUBE2__ C GET FLAG FOR PIPED OUTPUT ELSEIF ( LINE(1:4) .EQ. 'PIPE' ) THEN CALL DTCLOG( LINE,IS,pipe_output,'PIPE',1 ) #endif #if __PLOTSH2__ C GET AXIS RANGES FOR PLOT MAPS ELSEIF ( LINE(1:6) .EQ. 'PLAXES' ) THEN CALL DTCDBL( LINE,IS,PLX1,'PLAXES',1 ) CALL DTCDBL( LINE,IS,PLX2,'PLAXES',2 ) CALL DTCDBL( LINE,IS,PLY1,'PLAXES',3 ) CALL DTCDBL( LINE,IS,PLY2,'PLAXES',4 ) CALL DTCDBL( LINE,IS,PLZ1,'PLAXES',5 ) CALL DTCDBL( LINE,IS,PLZ2,'PLAXES',6 ) C GET ENERGY CUTS FOR PLOTTING ELSEIF ( LINE(1:6) .EQ. 'PLCUTS' ) THEN CALL DTCDBL( LINE,IS,PLCUT(1),'PLCUTS',1 ) CALL DTCDBL( LINE,IS,PLCUT(2),'PLCUTS',2 ) CALL DTCDBL( LINE,IS,PLCUT(3),'PLCUTS',3 ) CALL DTCDBL( LINE,IS,PLCUT(4),'PLCUTS',4 ) CALL DTCDBL( LINE,IS,PLTCUT,'PLCUT',5 ) CALL DTCLOG( LINE,IS,FBOXCUT,'PLCUT',6 ) #endif #if __PLOTSH__ || __PLOTSH2__ C GET PLOTSH FLAG INDICATING SEPARATE FILE FOR PLOT OUT ELSEIF ( LINE(1:6) .EQ. 'PLOTSH' ) THEN CALL DTCLOG( LINE,IS,PLOTSH,'PLOTSH',1 ) #endif #if !__STACKIN__ C GET TYPE OF PRIMARY PARTICLE ELSEIF ( LINE(1:6) .EQ. 'PRMPAR' ) THEN CALL DTCINT( LINE,IS,NNTYP,'PRMPAR',1 ) PRMPAR(0) = NNTYP #endif #if __CHARM__ && ((__QGSJET__ || !__QGSII__) || __SIBYLL__) ELSEIF ( LINE(1:6) .EQ. 'PROPAQ' ) THEN C PROPAGATION 0:OFF (SDPM, QGSJET01) 1:ON (HEPARIN) CALL DTCINT( LINE,IS,PROPMOD,'PROPAQ',1 ) C CHECK INCOMPATIBILITES IN OPTIONS IF ( PROPMOD .NE. 0 .AND. PROPMOD .NE. 1 ) THEN WRITE(MONIOU,*) 'DATAC : PROPAQ WRONG ARGUMENT' WRITE(MONIOU,*) 'PROPMOD=',PROPMOD NUMERR = NUMERR+1 ENDIF #endif #if __CHARM__ || __TAULEP__ C GET COUNTER FOR START OF PYTHIA DEBUGGING ELSEIF ( LINE(1:6) .EQ. 'PYTHIA' ) THEN CALL DTCINT( LINE,IS,IFLGPYW,'PYTHIA',1 ) CALL DTCINT( LINE,IS,IFLGPYE,'PYTHIA',2 ) #endif #if __QGSJET__ C GET FLAG FOR QGSJET HIGH ENERGY HADRONIC INTERACTION MODEL ELSEIF ( LINE(1:6) .EQ. 'QGSJET' ) THEN CALL DTCLOG( LINE,IS,FQGS,'QGSJET',1 ) CALL DTCINT( LINE,IS,LEVLDQ,'QGSJET',2 ) LEVLDQ = MAX( 0, LEVLDQ ) C GET CROSS-SECTION FLAG FOR QGSJET HADRONIC INTERACTION MODEL ELSEIF ( LINE(1:6) .EQ. 'QGSSIG' ) THEN CALL DTCLOG( LINE,IS,FQGSSG,'QGSSIG',1 ) #endif C GET WIDTH OF NKG LATERAL DISTRIBUTION ELSEIF ( LINE(1:6) .EQ. 'RADNKG' ) THEN CALL DTCDBL( LINE,IS,RADNKG,'RADNKG',1 ) #if __REMOTECONTROL__ ELSEIF ( LINE(1:14) .EQ. 'REMOTE_CONTROL' ) THEN CALL remotecontrol_init( LINE, LEN(LINE) ) #endif C GET RUN NUMBER ELSEIF ( LINE(1:5) .EQ. 'RUNNR' ) THEN CALL DTCINT( LINE,IS,NRRUN,'RUNNR',1 ) NRRUN = ABS(NRRUN) C GET SEEDS OF RANDOM NUMBER SEQUENCES ELSEIF ( LINE(1:4) .EQ. 'SEED' ) THEN ISEQ = ISEQ + 1 #if __MULTITHIN__ IF ( ISEQ .LE. 8 ) THEN #else IF ( ISEQ .LE. KSEQ ) THEN #endif #if __PARALLEL__ C DO NOT UPDATE SEED6 IF CUTFILE IS USED IF ( I1CUTPAR .EQ. 0 .OR. ISEQ .NE. 6 ) THEN #endif CALL DTCINT( LINE,IS,ISEED(1,ISEQ),'SEED',1 ) CALL DTCINT( LINE,IS,ISEED(2,ISEQ),'SEED',2 ) CALL DTCINT( LINE,IS,ISEED(3,ISEQ),'SEED',3 ) #if __PARALLEL__ ENDIF #endif NSEQ = ISEQ ELSE WRITE(MONIOU,*) 'DATAC : TOO MANY RANDOM GENERATOR SEEDS,', * ' IGNORE IT' ENDIF #if __MULTITHIN__ C GET SEEDS OF RANDOM NUMBER SEQUENCES FOR MULTITHIN ELSEIF ( LINE(1:5) .EQ. 'MSEED' ) THEN IMSEQ = MSEQ + 1 IF ( IMSEQ .LE. KSEQ ) THEN CALL DTCINT( LINE,IS,ISEED(1,IMSEQ),'MSEED',1 ) CALL DTCINT( LINE,IS,ISEED(2,IMSEQ),'MSEED',2 ) CALL DTCINT( LINE,IS,ISEED(3,IMSEQ),'MSEED',3 ) MSEQ = IMSEQ ELSE WRITE(MONIOU,*) 'DATAC : TOO MANY RANDOM GENERATOR SEEDS', * ' FOR MULTITHIN, IGNORE IT' ENDIF #endif #if __SIBYLL__ C GET CROSS-SECTION FLAG FOR SIBYLL HADRONIC INTERACTION MODEL ELSEIF ( LINE(1:6) .EQ. 'SIBSIG' ) THEN CALL DTCLOG( LINE,IS,FSIBSG,'SIBSIG',1 ) C GET FLAG FOR SIBYLL HIGH ENERGY HADRONIC INTERACTION MODEL ELSEIF ( LINE(1:6) .EQ. 'SIBYLL' ) THEN CALL DTCLOG( LINE,IS,FSIBYL,'SIBYLL',1 ) C GET FLAG FOR SIBYLL DEBUG; 0:NO DEBUG, >0: DEBUG CALL DTCINT( LINE,IS,ISDEBUG,'SIBYLL',2 ) #endif #if __CHARM__ C SET CHARM AND BOTTOM INTERACTION FIXED INTERACTION CROSS SECTIONS ELSEIF ( LINE(1:6) .EQ. 'SIGMAQ' ) THEN C CHARM MESON CALL DTCDBL( LINE,IS,SIGMAQ(1),'SIGMAQ',1 ) C CHARM BARYON CALL DTCDBL( LINE,IS,SIGMAQ(2),'SIGMAQ',2 ) C BOTTOM MESON CALL DTCDBL( LINE,IS,SIGMAQ(3),'SIGMAQ',3 ) C BOTTOM BARYON CALL DTCDBL( LINE,IS,SIGMAQ(4),'SIGMAQ',4 ) #endif #if __TRAJECT__ C GET SOURCE POSITION ELSEIF ( LINE(1:6) .EQ. 'SRCPOS' ) THEN CALL DTCDBL( LINE,IS,RA,'SRCPOS',1 ) CALL DTCDBL( LINE,IS,DECl,'SRCPOS',2 ) #endif C GET FACTOR FOR ELECTRON''S MULTIPLE SCATTERING LENGTH ELSEIF ( LINE(1:6) .EQ. 'STEPFC' ) THEN CALL DTCDBL( LINE,IS,STEPFC,'STEPFC',1 ) #if __CERENKOV__ C SET TELESCOPE POSITION ELSEIF ( LINE(1:9) .EQ. 'TELESCOPE' ) THEN CALL DTCDBL( LINE,IS,TELPAR(1),'TELESCOPE',1 ) CALL DTCDBL( LINE,IS,TELPAR(2),'TELESCOPE',2 ) CALL DTCDBL( LINE,IS,TELPAR(3),'TELESCOPE',3 ) CALL DTCDBL( LINE,IS,TELPAR(4),'TELESCOPE',4 ) C NOTE: IF IACT IS NOT USED, TELSET IS A FORTRAN ROUTINE #if __IACT__ CALL TELSET( TELPAR(1),TELPAR(2),TELPAR(3),TELPAR(4) ) #else CALL DTCINT( LINE,IS,TELID,'TELESCOPE',5 ) if (telid.le.0) telid = 0 if (telid.ge.NMAXCERTEL) then WRITE(MONIOU,9000) telid 9009 FORMAT(1X,I3,' TELID out of range') STOP 'BAD DATA CARDS' endif CALL TELSET( TELPAR(1),TELPAR(2),TELPAR(3),TELPAR(4),TELID ) #endif #if __IACT__ C SET TELESCOPE OUTPUT FILE ELSEIF ( LINE(1:6) .EQ. 'TELFIL' ) THEN CALL DTCCHR( LINE,IS,TELFNM(1:LEN(TELFNM)-1),'TELFIL',1,LENVAL ) C MAKE A PROPERLY TERMINATED C STRING (DO NOT USE COMPILER-DEPENDENT C PASSING OF THE LENGTH OF THE FORTRAN STRING BUT STILL REQUIRES C ADDRESS TO BE PASSED). IF ( LENVAL .GT. 0 .AND. LENVAL .LT. LEN(TELFNM) ) THEN TELFNM(LENVAL+1:LENVAL+1) = CHAR(0) CALL TELFIL( TELFNM ) ENDIF #endif #endif C GET THETA OF PRIMARY PARTICLE ELSEIF ( LINE(1:6) .EQ. 'THETAP' ) THEN CALL DTCDBL( LINE,IS,R1,'THETAP',1 ) CALL DTCDBL( LINE,IS,R2,'THETAP',2 ) THETPR(1) = MIN( R1, R2 ) THETPR(2) = MAX( R1, R2 ) #if __THIN__ C KEEP THE SEQUENCEE: 1) THINEM, 2) THINH, 3) THIN C - - - - - - - - - - - - - - - - - - - - - - - - C GET DEVIATING THINNING FOR EM-PARTICLES C THINRAT IS RATIO (EFRCTHN_EM)/EFRCTHN) C WEITRAT IS RATIO (WMAX_EM)/WMAX) C KEYWORDS THINEM AND THINH ARE ALTERNATIVE ELSEIF ( LINE(1:6) .EQ. 'THINEM' ) THEN CALL DTCDBL( LINE,IS,THINRAT,'THINEM',1 ) CALL DTCDBL( LINE,IS,WEITRAT,'THINEM',2 ) MODETHN = MODETHN + 10 C GET DEVIATING THINNING FOR HADR. PARTICLES C THINRATH IS RATIO (EFRCTHN_HADR)/EFRCTHN) C WEITRATH IS RATIO (WMAX_HADR)/WMAX) C KEYWORDS THINH AND THINEM ARE ALTERNATIVE ELSEIF ( LINE(1:5) .EQ. 'THINH' ) THEN CALL DTCDBL( LINE,IS,THINRATH,'THINH',1 ) CALL DTCDBL( LINE,IS,WEITRATH,'THINH',2 ) MODETHN = MODETHN + 100 C GET ENERGY FRACTION AND WEIGHT LIMIT FOR THINNING C RMAX IS LIMIT FOR RADIAL THINNING FOR ALL PARTICLES ELSEIF ( LINE(1:4) .EQ. 'THIN' ) THEN CALL DTCDBL( LINE,IS,EFRCTHN,'THIN',1 ) CALL DTCDBL( LINE,IS,WMAX0,'THIN',2 ) CALL DTCDBL( LINE,IS,RMAX,'THIN',3 ) MODETHN = MODETHN + 1 #endif #if __CURVED__ C GET DISTANCE FOR TIME LIMIT FOR DISCARDING PARTICLES C DSTLIM IS MAXIMUM DISTANCE FROM DETECTOR DOWNSTREAM TO C LIMIT (IN CM) ELSEIF ( LINE(1:6) .EQ. 'TIMLIM' ) THEN CALL DTCDBL( LINE,IS,DSTLIM,'TIMLIM',1 ) CALL DTCLOG( LINE,IS,LTMLMPR,'TIMLIM',2 ) DSTLIM = ABS( DSTLIM ) #endif #if __TRAJECT__ C GET POSITION OF TELESCOPE LOCATION ELSEIF ( LINE(1:4) .EQ. 'TLAT' ) THEN CALL DTCDBL( LINE,IS,TLATDGR,'TLAT',1 ) CALL DTCDBL( LINE,IS,TLATMIN,'TLAT',2 ) CALL DTCDBL( LINE,IS,TLATSEC,'TLAT',3 ) CALL DTCCHR( LINE,IS,TLATDIR,'TLAT',4,LENVAL ) ELSEIF ( LINE(1:5) .EQ. 'TLONG' ) THEN CALL DTCDBL( LINE,IS,TLONGDGR,'TLONG',1 ) CALL DTCDBL( LINE,IS,TLONGMIN,'TLONG',2 ) CALL DTCDBL( LINE,IS,TLONGSEC,'TLONG',3 ) CALL DTCCHR( LINE,IS,TLONGDIR,'TLONG',4,LENVAL ) C GET LOGICAL FOR CALCUATION OF TRAJECTORY ELSEIF ( LINE(1:6) .EQ. 'TRAFLG' ) THEN CALL DTCLOG( LINE,IS,TLOGIC,'TRAFLG',1 ) C PRODUCE EVENTS WITHIN RADIUS TRADIUS AROUND SOURCEPOS ELSEIF ( LINE(1:6) .EQ. 'TRARAD' ) THEN CALL DTCDBL( LINE,IS,TRAD,'TRARAD',1 ) C GET START TIME AND DURATION OF OBSERVATION ELSEIF ( LINE(1:5) .EQ. 'TRATM' ) THEN CALL DTCINT( LINE,IS,TYEAR,'TRATM',1 ) CALL DTCINT( LINE,IS,TMONTH,'TRATM',2 ) CALL DTCINT( LINE,IS,TDAY,'TRATM',3 ) CALL DTCINT( LINE,IS,THOUR,'TRATM',4 ) CALL DTCINT( LINE,IS,TMINUTE,'TRATM',5 ) CALL DTCINT( LINE,IS,TSECOND,'TRATM',6 ) CALL DTCINT( LINE,IS,TDURATION,'TRATM',7 ) #endif #if __INTTEST__ C GET TRIGGER CONDITION FOR INTERACTION TEST C DEFAULT VALUE = 0: ALL EVENTS ARE ACCEPTED C AVAILABEL EXPERIMENTS ARE NTRIG = 1: UA5 C NTRIG = 2: CDF C NTRIG = 3: P238 (HARR ET AL.) ELSEIF ( LINE(1:7) .EQ. 'TRIGGER' ) THEN CALL DTCINT( LINE,IS,NTRIG,'TRIGGER',1 ) #endif #if !__CURVED__ && !__SLANT__ && !__STACKIN__ && !__CONEX__ C GET STARTING POINT OF CLOCK (TRUE = ENTRANCE INTO ATMOSPHERE) C (FALSE = FIRST INTERACTION) ELSEIF ( LINE(1:6) .EQ. 'TSTART' ) THEN CALL DTCLOG( LINE,IS,TMARGIN,'TSTART',1 ) #endif #if __URQMD__ C GET FLAG AND DEBUG FLAG FOR URQMD LOW ENERGY INTERACTION ELSEIF ( LINE(1:5) .EQ. 'URQMD' ) THEN CALL DTCLOG( LINE,IS,FURQMD,'URQMD',1 ) CALL DTCINT( LINE,IS,IUDEBG0,'URQMD',2 ) #endif C GET NAME OF USER ELSEIF ( LINE(1:4) .EQ. 'USER' ) THEN CALL DTCCHR( LINE,IS,USER,'USER',1,LENVAL ) #if __VENUS__ C GET VENUS PARAMETER WITH CODE WORD AND VALUE ELSEIF ( LINE(1:6) .EQ. 'VENPAR' ) THEN IPARAM = IPARAM + 1 IF ( IPARAM .LE. 100 ) THEN CALL DTCCHR( LINE,IS,PARCHA(IPARAM),'VENPAR',1,LENVAL ) CALL DTCRL( LINE,IS,PARVAL(IPARAM),'VENPAR',2 ) NPARAM = IPARAM ELSE WRITE(MONIOU,*) 'DATAC : TOO MANY VENUS PARAMETERS,', * ' IGNORE IT' ENDIF C GET CROSS-SECTION FLAG FOR VENUS HADRONIC INTERACTION MODEL ELSEIF ( LINE(1:6) .EQ. 'VENSIG' ) THEN CALL DTCLOG( LINE,IS,FVENSG,'VENSIG',1 ) C GET FLAG FOR VENUS HIGH ENERGY HADRONIC INTERACTION MODEL C GET PARAMETER ISH00 FOR AMOUNT OF VENUS DEBUG ELSEIF ( LINE(1:5) .EQ. 'VENUS' ) THEN CALL DTCLOG( LINE,IS,FVENUS,'VENUS',1 ) CALL DTCINT( LINE,IS,ISH00,'VENUS',2 ) #endif #if __VIEWCONE__ C GET CIRCULAR ANGLE RANGE FROM (FIXED) THETA AND PHI DIRECTION C WHERE SIMULATED SHOWER DIRECTION SHOULD BE. ELSEIF (LINE(1:8) .EQ. 'VIEWCONE' ) THEN CALL DTCDBL( LINE,IS,R1,'VIEWCONE',1 ) CALL DTCDBL( LINE,IS,R2,'VIEWCONE',2 ) VUECON(1) = MIN( R1, R2 ) VUECON(2) = MAX( R1, R2 ) #endif C ILLEGAL KEYWORD ELSE IE = INDEX(LINE,' ') IF ( IE .LE. 0 ) IE = LEN(LINE)+1 WRITE(MONIOU,*) 'DATAC : UNKNOWN KEYWORD: ',LINE(1:IE-1) NUMERR = NUMERR + 1 ENDIF IF ( LINE(1:1) .EQ. '!' ) NUMERR = NUMERR + 1 GOTO 1 C----------------------------------------------------------------------- 1000 CONTINUE IF ( DEBUG ) THEN WRITE(MDEBUG,*) 'DATAC : NO MORE DIRECTIVES FOUND' ELSE WRITE(MONIOU,*) '*** NO MORE DIRECTIVES FOUND ***' ENDIF 1001 IF ( NUMERR .GT. 0 ) THEN WRITE(MONIOU,9000) NUMERR 9000 FORMAT(1X,I3,' SYNTAX ERROR(S) IN INPUT DATA CARDS.') STOP 'BAD DATA CARDS' ENDIF #if __COASTUSERLIB__ && __SLANT__ IF ( .NOT. LLONGI ) THEN STOP 'COASTUSERLIB + SLANT without LLONGI is not possible!' ENDIF #endif #if __EPOS__ WRITE(NEXPRM,'(A10)') 'runprogram ' REWIND(NEXPRM) #elif __NEXUS__ WRITE(NEXPRM,'(A4)') 'run ' REWIND(NEXPRM) #endif RETURN END *-- Author : D. HECK IK FZK KARLSRUHE 25/06/2003 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----------------------------------------------------------------------- IMPLICIT NONE #define __AIRINC__ #define __MUPARTINC__ #define __PAMINC__ #define __RUNPARINC__ #include "corsika.h" INTEGER IWK,MAXPTS,MINCAL,MINPTS,N PARAMETER (IWK = 1000000) PARAMETER (MAXPTS = 100000) PARAMETER (MINCAL = 1) 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 SAVE DATA XLOW0 / 1.D-15 / C----------------------------------------------------------------------- DBRELM = 0.D0 C EE IS THE TOTAL ENERGY OF INCOMING MUON ECMIN = 0.D0 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(MONIOU,*) 'DBRELM: IFAIL=',IFAIL,' E=',EE,' JJMAT=',JJMAT STOP ENDIF C NORMALIZE TO GET ENERGY LOSS IN GEV * G**-1 * CM**2 DBRELM = AVOGDR * RESULT * 1.D27 * EE / AATOM RETURN END *-- Author : D. HECK IK FZK KARLSRUHE 12/05/2003 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----------------------------------------------------------------------- IMPLICIT NONE #define __MUPARTINC__ #define __PAMINC__ #define __RUNPARINC__ #include "corsika.h" INTEGER IWK,MAXPTS,MINCAL,MINPTS,N PARAMETER (IWK = 1000000) PARAMETER (MAXPTS = 100000) PARAMETER (MINCAL = 1) 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 SAVE DATA XLOW0 / 1.D-15 / C----------------------------------------------------------------------- DBRSGM = 0.D0 C EE IS THE TOTAL ENERGY OF INCOMING MUON IF ( MT .EQ. 1 ) THEN IF ( EE-PAMA(5) .LT. BCUT ) RETURN ELSE IF ( EE-PAMA(131) .LT. BCUT ) RETURN ENDIF 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(MONIOU,*) 'DBRSGM: IFAIL=',IFAIL,' E=',EE,' JJMAT=',JJMAT STOP ENDIF C CONVERT FROM CM**2 TO MILLIBARN DBRSGM = RESULT * 1.D27 RETURN END *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE DECAY1( M0,M3,M4 ) C----------------------------------------------------------------------- C DECAY (INTO TWO PARTICLES) C C TWO PARTICLE DECAY WITH FULL KINEMATIC; ENERGY AND MOMENTA CONSERVED C THIS SUBROUTINE IS CALLED FROM KDECAY, RESDEC, AND STRDEC. C ARGUMENTS: C M0 = TYPE OF DECAYING PARTICLE C M3 = TYPE OF FIRST PRODUCT PARTICLE (HADRON) C M4 = TYPE OF SECOND PRODUCT PARTICLE (HADRON OR GAMMA, NEUTRINO) C C TESTED FOR ENERGY MOMENTUM CONSERVATION OK (2016.07.05) C----------------------------------------------------------------------- IMPLICIT NONE #define __CONSTAINC__ #define __LONGIINC__ #define __PAMINC__ #define __PARPARINC__ #define __PARPAEINC__ #define __RANDPAINC__ #define __RUNPARINC__ #if __AUGERHIST__ #define __GENERINC__ #define __OBSPARINC__ #endif #include "corsika.h" DOUBLE PRECISION AUX1,AUX2,AUX2A,AUX3,AUX4,COSTCM,COSTH3,COSTH4, * FAC1,FAC2,GAMMA3,GAMMA4,PHI4,WORK1,WORK2 INTEGER I,M0,M3,M4 #if __AUGERHIST__ DOUBLE PRECISION EDEP,THICKLOC,THICK INTEGER II,LL EXTERNAL THICK #endif SAVE C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,444) BETA,M0,M3,M4 444 FORMAT(' DECAY1: BETA,M0,M3,M4=',1P,E10.3,3I5) C PARTICLE COORDINATES 5..10 ARE COPIED INTO SECPAR IN CALLING PROGRAM C CALCULATE AUXILIARY QUANTITIES AUX1 = ( ( PAMA(M0)**2 + PAMA(M3)**2 - PAMA(M4)**2 ) * / (2.D0*PAMA(M0)) )**2 - PAMA(M3)**2 AUX2 = 1.D0 + AUX1 / PAMA(M3)**2 AUX2A = SQRT( AUX2 ) AUX3 = SQRT( 1.D0 - 1.D0 / AUX2 ) WORK1 = GAMMA * AUX2A WORK2 = AUX3 * BETA * WORK1 C DETERMINE POLAR ANGLE IN CM SYSTEM CALL RMMARD( RD,2,1 ) COSTCM = 2.D0 * RD(1) - 1.D0 GAMMA3 = WORK1 + WORK2 * COSTCM C SECOND PRODUCT PARTICLE WITH NONVANISHING REST MASS IF ( PAMA(M4) .NE. 0.D0 ) THEN GAMMA4 = (PAMA(M0)*GAMMA - PAMA(M3)*GAMMA3) / PAMA(M4) AUX4 = (PAMA(M0)**2 + PAMA(M4)**2 - PAMA(M3)**2 ) * / (2.D0*PAMA(M0)*PAMA(M4)) COSTH4 = MIN( 1.D0, (GAMMA*GAMMA4 - AUX4) / * (BETA * GAMMA * SQRT( (GAMMA4-1.D0)*(GAMMA4+1.D0) )) ) ELSE C SECOND PRODUCT PARTICLE IS GAMMA; THEN GAMMA4 IS THE ENERGY GAMMA4 = PAMA(M0)*GAMMA - PAMA(M3)*GAMMA3 COSTH4 = MIN( 1.D0, (BETA - COSTCM)/(1.D0 - BETA*COSTCM) ) ENDIF PHI4 = RD(2) * PI2 CALL ADDANG3( COSTHE,PHIX,PHIY, COSTH4,PHI4, * SECPAR(2),SECPAR(3),SECPAR(4) ) #if __UPWARD__ IF ( SECPAR(2) .GE. -1.D0 ) THEN #else IF ( SECPAR(2) .GT. C(29) ) THEN #endif SECPAR(0) = M4 SECPAR(1) = GAMMA4 #if __INTTEST__ IF ( M4 .EQ. 1 ) THEN SECPAR(17) = SECPAR(1) * * SQRT( (1.D0-SECPAR(2))*(1.D0+SECPAR(2)) ) ELSE SECPAR(17) = SQRT( (SECPAR(1)-1.D0)*(SECPAR(1)+1.D0) * * (1.D0-SECPAR(2))*(1.D0+SECPAR(2)) )*PAMA(M4) ENDIF #endif #if __THIN__ IF ( DEBUG ) WRITE(MDEBUG,445) (SECPAR(I),I=0,9),SECPAR(13) 445 FORMAT(' DECAY1: SECPAR=',1P,9E11.3,0P,F10.0,1P,E10.3) #else IF ( DEBUG ) WRITE(MDEBUG,445) (SECPAR(I),I=0,9) 445 FORMAT(' DECAY1: SECPAR=',1P,9E11.3,0P,F10.0) #endif CALL TSTACK ELSE IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT IF ( M4 .EQ. 1 ) THEN #if __THIN__ DLONG(LHEIGH,11) = DLONG(LHEIGH,11) + GAMMA4 * WEIGHT #else DLONG(LHEIGH,11) = DLONG(LHEIGH,11) + GAMMA4 #endif ELSE IF ( M4 .EQ. 8 .OR. M4 .EQ. 9 .OR. * M4 .EQ. 11 .OR. M4 .EQ. 12 ) THEN FAC1 = 0.25D0 FAC2 = 0.75D0 ELSEIF ( M4 .EQ. 10 .OR. M4 .EQ. 16 ) THEN FAC1 = 0.5D0 FAC2 = 0.5D0 ELSE FAC1 = 1.D0 FAC2 = 0.D0 ENDIF #if __THIN__ C ADD TO THE HADRON ENERGY DEPOSIT DLONG(LHEIGH,17) = DLONG(LHEIGH,17) + ( GAMMA4*PAMA(M4) * - RESTMS(M4) ) * WEIGHT * FAC1 C ADD TO THE NEUTRINO DEPOSIT DLONG(LHEIGH,18) = DLONG(LHEIGH,18) + ( GAMMA4*PAMA(M4) * - RESTMS(M4) ) * WEIGHT * FAC2 #else C ADD TO THE HADRON ENERGY DEPOSIT DLONG(LHEIGH,17) = DLONG(LHEIGH,17) + ( GAMMA4 * PAMA(M4) * - RESTMS(M4) ) * FAC1 C ADD TO THE NEUTRINO DEPOSIT DLONG(LHEIGH,18) = DLONG(LHEIGH,18) + ( GAMMA4 * PAMA(M4) * - RESTMS(M4) ) * FAC2 #endif ENDIF ENDIF #if __AUGERHIST__ THICKLOC = THICK( H ) DO LL = 1, NOBSLV IF ( THICKLOC .GE. THCKOB(LL) .AND. * THICKLOC .LT. THCKOB(LL)+SAMPTH ) THEN C THICKH IS WITHIN 1 G/CM^2 BELOW OBSLEV(LL) C BRING THE ENERGY BELOW ANGULAR CUT TO THE HISTO OF LEVEL LL OUTPAR(0) = M4 OUTPAR(1) = GAMMA4 OUTPAR(2) = SECPAR(2) OUTPAR(3) = SECPAR(3) OUTPAR(4) = SECPAR(4) DO II = 5, 8 OUTPAR(II) = CURPAR(II) ENDDO OUTPAR( 9) = GEN OUTPAR(10) = ALEVEL OUTPAR(13) = WEIGHT IF ( M4 .EQ. 1 ) THEN EDEP = GAMMA4*WEIGHT ELSE EDEP = ( GAMMA4 * PAMA(M4) - RESTMS(M4) ) * WEIGHT ENDIF C WE HAVE ANGULAR CUT CALL AUGERDEPFIL( EDEP,LL,1 ) ELSEIF ( THICKLOC .LT. THCKOB(LL) ) THEN GOTO 111 ENDIF ENDDO 111 CONTINUE #endif ENDIF C FIRST PRODUCT PARTICLE WITH OPPOSITE AZIMUTHAL DIRECTION COSTH3 = MIN( 1.D0, (GAMMA * GAMMA3 - AUX2A) * / (BETA * GAMMA * SQRT( (GAMMA3-1.D0)*(GAMMA3+1.D0)) )) CALL ADDANG3( COSTHE,PHIX,PHIY, COSTH3,PHI4+PI, * SECPAR(2),SECPAR(3),SECPAR(4) ) #if __UPWARD__ IF ( SECPAR(2) .GE. -1.D0 ) THEN #else IF ( SECPAR(2) .GT. C(29) ) THEN #endif SECPAR(0) = M3 SECPAR(1) = GAMMA3 #if __INTTEST__ SECPAR(17) = SQRT( (SECPAR(1)-1.D0)*(SECPAR(1)+1.D0) * * (1.D0-SECPAR(2))*(1.D0+SECPAR(2)) )*PAMA(M3) #endif IF ( DEBUG ) WRITE(MDEBUG,445) (SECPAR(I),I=0,9) CALL TSTACK ELSE IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT IF ( M3 .EQ. 8 .OR. M3 .EQ. 9 .OR. * M3 .EQ. 11 .OR. M3 .EQ. 12 ) THEN FAC1 = 0.25D0 FAC2 = 0.75D0 ELSEIF ( M3 .EQ. 10 .OR. M3 .EQ. 16 ) THEN FAC1 = 0.5D0 FAC2 = 0.5D0 ELSE FAC1 = 1.D0 FAC2 = 0.D0 ENDIF #if __THIN__ C ADD TO THE HADRON ENERGY DEPOSIT DLONG(LHEIGH,17) = DLONG(LHEIGH,17) + ( GAMMA3*PAMA(M3) * - RESTMS(M3) ) * WEIGHT * FAC1 C ADD TO THE NEUTRINO DEPOSIT DLONG(LHEIGH,18) = DLONG(LHEIGH,18) + ( GAMMA3*PAMA(M3) * - RESTMS(M3) ) * WEIGHT * FAC2 #else C ADD TO THE HADRON ENERGY DEPOSIT DLONG(LHEIGH,17) = DLONG(LHEIGH,17) + ( GAMMA3 * PAMA(M3) * - RESTMS(M3) ) * FAC1 C ADD TO THE NEUTRINO DEPOSIT DLONG(LHEIGH,18) = DLONG(LHEIGH,18) + ( GAMMA3 * PAMA(M3) * - RESTMS(M3) ) * FAC2 #endif ENDIF #if __AUGERHIST__ THICKLOC = THICK( H ) DO LL = 1, NOBSLV IF ( THICKLOC .GE. THCKOB(LL) .AND. * THICKLOC .LT. THCKOB(LL)+SAMPTH ) THEN C THICKH IS WITHIN 1 G/CM^2 BELOW OBSLEV(LL) C BRING THE ENERGY BELOW ANGULAR CUT TO THE HISTO OF LEVEL LL OUTPAR(0) = M3 OUTPAR(1) = GAMMA3 OUTPAR(2) = SECPAR(2) OUTPAR(3) = SECPAR(3) OUTPAR(4) = SECPAR(4) DO II = 5, 8 OUTPAR(II) = CURPAR(II) ENDDO OUTPAR( 9) = GEN OUTPAR(10) = ALEVEL OUTPAR(13) = WEIGHT EDEP = ( GAMMA3 * PAMA(M3) - RESTMS(M3) ) * WEIGHT C WE HAVE ANGULAR CUT CALL AUGERDEPFIL( EDEP,LL,1 ) ELSEIF ( THICKLOC .LT. THCKOB(LL) ) THEN GOTO 112 ENDIF ENDDO 112 CONTINUE #endif ENDIF RETURN END *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE DECAY6(AM0,AM3,AM4,AM5,PARAMA,PARAMB,PARAMC,AMPMX,MODE) C----------------------------------------------------------------------- C DECAY (INTO 3 PARTICLES) C C TREATES DECAY INTO 3 PARTICLES; FULLY CONSERVING ENERGY AND MOMENTA C KINEMATIC RANGE PARAMETERISATION SEE PHYS. LETT. 204B (1988) 90-91 C FOR LEPTONIC KAON DACAY: THE POLARIZATION OF THE MUON AND C THE NEUTRINO PRODUCTION IS INCLUDED. C THIS SUBROUTINE IS CALLED FROM ETADEC, KDECAY, PI0DEC, AND RESDEC. C ARGUMENTS: C AM0 = MASS OF DECAYING PARTICLE (GEV) C AM3, AM4, AM5 = MASSES OF RESULTING PARTICLES (GEV) C PARAMA = DALITZ AMPLITUDE PARAMETER (SEE BELOW) C PARAMB = DALITZ AMPLITUDE PARAMETER (SEE BELOW) C PARAMC = DALITZ AMPLITUDE PARAMETER (SEE BELOW) C AMPMX = MAXIMUM AMPLITUDE OF DALITZ PLOT C MODE = 1 FOR DECAY KAON ----> 3 PIONS C = 2 FOR DECAY ETA ----> 3 PIONS OR 2 PIONS + GAMMA C FOR DECAY PI(0) ----> ELECTRON + POSITRON + GAMMA C = 3 FOR DECAY KAON ----> PION + MUON + NEUTRINO C = 4 FOR DECAY KAON ----> PION + ELECTRON + NEUTRINO C C AMPLITUDE PARAMETERS PARAMA, PARAMB, PARAMC ARE DEPENDENT ON MODE: C FOR MODE=1: PARAMA = G DALITZ AMPLITUDE PARAMETERISATION SEE C PARAMB = H PHYS. LETT. 204B (1988) 181 - 193 C PARAMC = K C C FOR MODE=2: PARAMA = A DALITZ AMPLITUDE PARAMETERISATION SEE C PARAMB = DUMMY PHYS. LETT. 204B (1988) 173 - 175; C PARAMC = DUMMY J.G. LAYTER ET.AL. PHYS.REV.D7(1973)2565 C C FOR MODE>2: PARAMA = LAMBDA-PLUS DALITZ AMPLITUDE PARAMETERISATION C PARAMB = LAMBDA-ZERO SEE PHYS. LETT. 204B (1988) C PARAMC = DUMMY 182 - 194 C----------------------------------------------------------------------- IMPLICIT NONE #define __CONSTAINC__ #define __DECAYCINC__ #define __PAMINC__ #define __PARPARINC__ #define __PARPAEINC__ #define __POLARINC__ #define __RANDPAINC__ #define __RUNPARINC__ #include "corsika.h" DOUBLE PRECISION ABYM,AMPLI,AMPMX,AM0,AM3,AM34I,AM34SQ,AM35SQ, * AM4,AM5,APARAL,APERPN,AUXA,AUXB,AUX1,AUX2,AUX2A, * AUX3,AUX4,AUX4A,AUX5,AUX6,AUX7,AUX8,AUX10,AUX12, * AUX14,BBYM,BOFQ,CM0SQ,CM3SQ,CM3SQI,CM4SQ,CM5SQ, * COSALF,COSBET,COSFI4,COSFI5,COSOME,COSPHI, * COSPSI,COS3CM,COS4CM,COS5CM, * DISCR,EPIPRM,E3CM,E3STAR,E4CM,E5CM,E5STAR,FACT, * GRLAMD,OMEGA,PA,PARAMA,PARAMB,PARAMC,PB,PC,PSI, * P3CM,P3SQ,P4CM,P4SQ,P5CM,P5SQ,ROOT1,ROOT2, * SINALF,SINBET,SINFI4,SINFI5,SINOMG,SINPHI,SINPSI, * SINT4,SINT4I,SINT5I,SIN3CM,S0,TBYMSS,XIT,XI0 INTEGER MODE SAVE C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,444) AM0,AM3,AM4,AM5 444 FORMAT(' DECAY6: AM0',1P,E10.3,' AM3',E10.3,' AM4',E10.3, * ' AM5',E10.3) C CALCULATE AUXILIARY QUANTITIES CM0SQ = AM0**2 CM3SQ = AM3**2 CM4SQ = AM4**2 CM5SQ = AM5**2 AUX1 = (AM3 + AM4)**2 AUX2A = (AM0 - AM5)**2 AUX2 = AUX2A - AUX1 AUX3 = (AM3 + AM5)**2 AUX4A = (AM0 - AM4)**2 AUX4 = AUX4A - AUX3 AUX5 = CM3SQ - CM4SQ AUX6 = CM0SQ - CM5SQ AUX7 = 0.5D0 / AM0 IF ( MODE .EQ. 1 ) THEN AUX8 = (AM0 - AM3)**2 S0 = OB3 * ( CM0SQ + CM3SQ + CM4SQ + CM5SQ ) AUX10 = 1.D0 / PAMA(8)**2 ELSEIF ( MODE .EQ. 2 ) THEN AUX14 = 1.D0 / (AM0 - AM3 - AM4 - AM5) ELSEIF ( MODE .EQ. 3 .OR. MODE .EQ. 4 ) THEN CM3SQI = 1.D0 / CM3SQ AUX12 = (CM0SQ + CM3SQ - CM4SQ) * AUX7 C XI0 IS XI(0); GRLAMD IS GREAT LAMBDA XI0 = ( CM0SQ - CM3SQ) * CM3SQI * (PARAMB - PARAMA) GRLAMD = (-XI0) * PARAMA ELSE WRITE(MONIOU,*) 'DECAY6: UNEXPECTED MODE =',MODE RETURN ENDIF 100 CALL RMMARD( RD,3,1 ) C ARE INVARIANT MASS SQUARES INSIDE BOUNDARY OF DALITZ PLOT? AM34SQ = AUX2 * RD(1) + AUX1 AM35SQ = AUX4 * RD(2) + AUX3 AM34I = 0.5D0 / SQRT( AM34SQ ) E3STAR = (AUX5 + AM34SQ) * AM34I E5STAR = (AUX6 - AM34SQ) * AM34I ROOT1 = SQRT( E3STAR**2 - CM3SQ ) ROOT2 = SQRT( E5STAR**2 - CM5SQ ) DISCR = AM35SQ - (E3STAR + E5STAR)**2 C REJECT RANDOM NUMBERS, IF OUTSIDE KINEMATIC BOUNDARY OF DALITZ PLOT IF ( DISCR .GT. -((ROOT1 - ROOT2)**2) ) GOTO 100 IF ( DISCR .LT. -((ROOT1 + ROOT2)**2) ) GOTO 100 C E3CM, E4CM, E5CM ARE ENERGIES IN THE C. M. SYSTEM E4CM = (CM0SQ + CM4SQ - AM35SQ) * AUX7 E5CM = (CM0SQ + CM5SQ - AM34SQ) * AUX7 E3CM = AM0 - E4CM - E5CM IF ( MODE .EQ. 1 ) THEN FACT = AUX10 * (AUX2A - 2.D0*AM0*(E5CM-AM5) - S0) C AMPLITUDE OF SQUARED MATRIX ELEMENT (SEE PHYS. LETT. B204 (1988) 181) AMPLI = 1.D0 + PARAMA*FACT + PARAMB*FACT**2 + PARAMC*( AUX10 * * ( AUX4A -AUX8 -2.D0*(E4CM-AM4-E3CM+AM3)*AM0 ) )**2 ELSEIF ( MODE .EQ. 2 ) THEN C AMPLITUDE OF SQUARED MATRIX ELEMENT (SEE PHYS. LETT. B204 (1988) 173) C REF: J. G. LAYTER ET AL., PHYS. REV. D7 (1973) 2565 AMPLI = 1.D0 + PARAMA * ( 3.D0 * (E5CM - AM5) * AUX14 - 1.D0 ) ELSE C EPIPRM IS (ENERGY OF PION)PRIMED EPIPRM = AUX12 - E3CM C PA, PB, AND PC ARE THE A, B, AND C PARAMETERS PA = AM0 * ( 2.D0 * E4CM * E5CM - AM0 * EPIPRM ) * + CM4SQ * ( 0.25D0 * EPIPRM - E5CM ) PB = CM4SQ * ( E5CM - 0.5D0 * EPIPRM ) PC = CM4SQ * EPIPRM * 0.25D0 C TBYMSS IS T DIVIDED BY MASS SQUARE OF PION TBYMSS = (CM0SQ + CM3SQ - 2.D0 * AM0 * E3CM) * CM3SQI C XIT IS XI(T) XIT = XI0 + GRLAMD*TBYMSS C AMPLITUDE OF SQUARED MATRIX ELEMENT (PHYS. LETT. B204 (1988) 183) AMPLI = (1.D0 + PARAMA*TBYMSS)**2 * ( PA + XIT*PB + XIT**2 *PC ) ENDIF C REJECT RANDOM NUMBERS, IF RD(3) IS LARGER THAN DALITZ PLOT AMPLITUDE IF ( RD(3)*AMPMX .GT. AMPLI ) GOTO 100 IF ( DEBUG ) WRITE(MDEBUG,*) 'DECAY6: E3CM,E4CM,E5CM=', * SNGL(E3CM),SNGL(E4CM),SNGL(E5CM) C P3CM, P4CM, P5CM ARE MOMENTA IN THE C.M. SYSTEM C P3SQ, P4SQ, P5SQ ARE SQUARED MOMENTA IN C.M. SYSTEM P5SQ = E5CM**2 - CM5SQ P5CM = SQRT( P5SQ ) P4SQ = E4CM**2 - CM4SQ P4CM = SQRT( P4SQ ) P3SQ = E3CM**2 - CM3SQ P3CM = SQRT( P3SQ ) C ANGLE ALFA AND BETA ARE BETWEEN PARTICLE 3 AND 4 RSP. 3 AND 5 COSALF = (P5SQ - P3SQ - P4SQ) / (2.D0 * P3CM * P4CM) SINALF = -SQRT( MAX( 0.D0, (1.D0 - COSALF)*(1.D0 + COSALF) ) ) COSBET = (P4SQ - P3SQ - P5SQ) / (2.D0 * P3CM * P5CM) SINBET = SQRT( MAX( 0.D0, (1.D0 - COSBET)*(1.D0 + COSBET)) ) C NOW SELECT RANDOM NUMBERS FOR THREE INDEPENDENT ANGLES IN CM-SYSTEM C COS3CM AND PHI ARE ANGLES OF PARTICLE 3 RELATIVE TO DECAYING PARTICLE CALL RMMARD( RD,3,1 ) COS3CM = 2.D0*RD(1) - 1.D0 SIN3CM = SQRT( MAX( 0.D0, (1.D0 - COS3CM)*(1.D0 + COS3CM) ) ) PHI345(1) = PI2 * RD(2) COSPHI = COS( PHI345(1) ) SINPHI = SIN( PHI345(1) ) C ANGLE PSI GIVES ROTATION OF PLANE (3,4,5) RELATIVE TO PLANE (1,3) PSI = PI2 * RD(3) COSPSI = COS( PSI ) SINPSI = SIN( PSI ) C CALCULATE ALL NEEDED POLAR AND AZIMUTHAL ANGLES IN THE CM-SYSTEM COS4CM = COS3CM * COSALF - SIN3CM * COSPSI * SINALF IF ( ABS(COS4CM) .LT. 1.D0 ) THEN SINT4 = SQRT( (1.D0 - COS4CM) * (1.D0 + COS4CM) ) SINT4I = 1.D0 / SINT4 AUXA = COS3CM * COSPSI * SINALF + SIN3CM * COSALF COSFI4 = (COSPHI*AUXA-SINPHI*SINPSI*SINALF) * SINT4I PHI345(2) = ACOS( MAX( -1.D0, MIN( 1.D0, COSFI4 ) ) ) SINFI4 = (SINPHI*AUXA+COSPHI*SINPSI*SINALF) * SINT4I IF ( SINFI4 .LE. 0.D0 ) PHI345(2) = PI2 - PHI345(2) ELSE PHI345(2) = 0.D0 ENDIF C CALCULATE GAMMA FACTORS AND POLAR ANGLES IN LABORATORY SYSTEM GAM345(1) = GAMMA * (E3CM + BETA * P3CM * COS3CM) / AM3 COS345(1) = MIN( 1.D0, (BETA * E3CM + P3CM * COS3CM) * GAMMA * / (AM3 * SQRT( (GAM345(1)-1.D0)*(GAM345(1)+1.D0) )) ) GAM345(2) = GAMMA * (E4CM + BETA * P4CM * COS4CM) / AM4 COS345(2) = MIN( 1.D0, (BETA * E4CM + P4CM * COS4CM) * GAMMA * / (AM4 * SQRT( (GAM345(2)-1.D0)*(GAM345(2)+1.D0) )) ) C CALCULATE PARAMETERS OF PARTICLE 5, IF NEEDED #if !__NEUTRINO__ IF ( MODE .LE. 2 ) THEN #endif COS5CM = COS3CM * COSBET - SIN3CM * COSPSI * SINBET IF ( ABS(COS5CM) .LT. 1.D0 ) THEN SINT5I = 1.D0 / SQRT( (1.D0 - COS5CM) * (1.D0 + COS5CM) ) AUXB = COS3CM * COSPSI * SINBET + SIN3CM * COSBET COSFI5 = (COSPHI*AUXB-SINPHI*SINPSI*SINBET) * SINT5I PHI345(3) = ACOS( MAX( -1.D0, MIN( 1.D0, COSFI5 ) ) ) SINFI5 = (SINPHI*AUXB+COSPHI*SINPSI*SINBET) * SINT5I IF ( SINFI5 .LE. 0.D0 ) PHI345(3) = PI2 - PHI345(3) ELSE PHI345(3) = 0.D0 ENDIF IF ( AM5 .NE. 0.D0 ) THEN GAM345(3) = GAMMA * (E5CM + BETA * P5CM * COS5CM) / AM5 COS345(3) = MIN( 1.D0, (BETA * E5CM + P5CM * COS5CM) * GAMMA * /(AM5 * SQRT((GAM345(3)-1.D0)*(GAM345(3)+1.D0))) ) ELSE C IF PARTICLE 5 IS GAMMA RAY OR NEUTRINO, THEN GAM345(3) IS THE ENERGY GAM345(3) = GAMMA * (E5CM + BETA * P5CM * COS5CM) COS345(3) = MIN( 1.D0, (BETA * E5CM + P5CM * COS5CM) * GAMMA * / GAM345(3) ) ENDIF #if !__NEUTRINO__ ENDIF #endif IF ( MODE .EQ. 3 ) THEN C CALCULATION OF MUON POLARIZATION. WE FOLLOW THE DESCRIPTION OF C L. JAUNEAU, IN: METHODS IN SUBNUCLEAR PHYSICS, VOL. 3, M. NIKOLIC ED. C (GORDON + BREACH, NEW YORK, 1969), P. 123 C SEE ALSO: L.M. CHOUNET ET AL., PHYS. REP. 4 (1972) 199, APPENDIX 1. C SEE ALSO: N. CABBIBO, A. MAKSYMOWICZ, PHYS. LETT. 9 (1964) 352 C (CORRECTIONS IN: PHYS. LETT. 11 (1964) 360; 14 (1965) 72) C WE DEFINE BOFQ (READ: B OF Q), WHICH IS -B(Q**2)*4 BOFQ = 1.D0 - XIT C ABYM AND BBYM (READ A BY M; B BY M) ARE THE QUANTITIES A/M AND B/M ABYM = AM0 * ( BOFQ * EPIPRM - 2.D0 * E5CM ) BBYM = CM0SQ + 0.25D0 * CM4SQ * BOFQ**2 - BOFQ * AM0 * E4CM C NOW CALCULATE THE COMPONENTS APARAL (PARALLEL TO MU DIRECTION) AND C APERPN (PERPENDICULAR TO MU DIRECTION) USING QUANTITIES DEFINED IN C KAON REST SYSTEM. NOTE OUR DEFINITION OF SINALF (ALWAYS WITH NEGATIVE C SIGN) OPPOSITE TO CABBIBO''S SIN(PSI) AND JAUNEAU''S SIN(THETA) APARAL = (-P3CM)*AM4*BBYM*COSALF - P4CM * ( AM0*ABYM - BBYM * * ( P3CM*SINALF*(E4CM-AM4)/P4CM + AM0 - E3CM ) ) APERPN = P3CM*AM4*BBYM*SINALF C NOW NORMALIZE THE PARALLEL COMPONENT OF POLARIZATION; POLART IS C COSINE OF THE ANGLE BETWEEN MUON MOMENTUM AND POLARISATION POLART = APARAL / SQRT( APARAL**2 + APERPN**2 ) C THE POLARIZATION VECTOR LIES IN THE PLANE OF MOMENTA (PION,MUON). C OMEGA IS THE ANGLE BY WHICH THE DECAY PLANE (PION,MUON) IS ROTATET C AROUND THE DIRECTION OF MUON RELATIVE TO THE PLANE (KAON,MUON) IF ( ABS(COS4CM) .LT. 1.D0 .AND. SINALF .NE. 0.D0 ) THEN COSOME = (COS4CM*COSALF - COS3CM)*SINT4I/SINALF OMEGA = ACOS( MAX( -1.D0, MIN( 1.D0, COSOME ) ) ) IF ( SINFI4 .NE. 0.D0 ) THEN SINOMG = ( COSFI4 * ( COSALF - COS3CM*COS4CM ) * SINT4I * - SIN3CM * COSPHI ) / (SINALF*SINFI4) IF ( SINOMG .LT. 0.D0 ) OMEGA = PI2 - OMEGA ENDIF ELSE OMEGA = 0.D0 ENDIF POLARF = OMEGA ENDIF RETURN END #if __CURVED__ && __SLANT__ *-- Author : V. Chernatkin Univ. Nantes 00/00/2003 C======================================================================= DOUBLE PRECISION FUNCTION CRSDEPTH0( RR1,RR2,A,J ) C----------------------------------------------------------------------- C OPTIMIZED FOR SPEED ... NOT THE BEST PRECISION ! C CRSDEPTH0 - SLANT DEPTH INTERVAL (G/CM^2) BETWEEN 2 POINTS DEFINED C BY THEIR RADIUS C THIS FUNCTION IS CALLED FROM DL2DT, DT2DL, CRSRADIUS0. C ARGUMENTS: C RR1 = RADIUS OF THE STARTING POINT (CM) C RR2 = RADIUS OF THE ENDING POINT (CM) C A = IMPACT RADIUS (CM) C J = ATMOSPHERIC LAYER C----------------------------------------------------------------------- IMPLICIT NONE #define __ATMOSINC__ #define __ATMOS2INC__ #define __ATMOSLINC__ #define __OBSPARINC__ #define __PARPARINC__ #define __RUNPARINC__ #include "corsika.h" DOUBLE PRECISION A,CORR,RM,RR1,RR2,RT,RXX1,RXX2,R1,R2 INTEGER J DOUBLE PRECISION GAMMQ EXTERNAL GAMMQ SAVE C----------------------------------------------------------------------- RT = C(1) RM = RT + HLAYC(6) R1 = MIN( RR1,RR2 ) R2 = MIN( MAX( RR1,RR2 ),RM ) IF ( A .GT. R1 ) THEN WRITE(MONIOU,*) 'CRSDEPTH0: RR2,PR1,A=',RR2,RR1,A STOP 'CRSDEPTH0: INCORRECT INPUT R0 GO TOWARDS THE MIDDLE POINT, <0 GO BACKWARDS) C DT = SLANT DEPTH INTERVAL (G/CM^2) (SIGN GIVEN BY DL) (OUTPUT), C H1 = HEIGHT ABOVE SEA LEVEL OF STARTING POINT (CM) (INPUT) C H2 = HEIGHT ABOVE SEA LEVEL OF ENDING POINT (CM) (OUTPUT) C D1 = SLANT DISTANCE OF STARTING POINT (CM) (INPUT) C (TAKEN FROM CROSS POINT WITH GROUND IF A < RGROUND, C TAKEN FROM CROSS POINT WITH IMPACT RADIUS IF A > RGROUND) C D2 = SLANT DISTANCE OF ENDING POINT (CM) (OUTPUT) C A = IMPACT RADIUS (CM) (INPUT). C----------------------------------------------------------------------- IMPLICIT NONE #define __ATMOS2INC__ #define __ATMOSLINC__ #define __OBSPARINC__ #define __PARPARINC__ #define __RUNPARINC__ #include "corsika.h" DOUBLE PRECISION A,ADL,DL,DLL,DLS,DS,DSS,DT,D1,D2, * H1,H2,HMIN,RT,R0,R02,R1,R2 INTEGER IS,J,JA,J1,J2 DOUBLE PRECISION CRSDEPTH0,DISTAND,HEIGHTD EXTERNAL CRSDEPTH0,DISTAND,HEIGHTD SAVE C----------------------------------------------------------------------- IF ( ABS( DL ) .LT. 1.D-15 ) THEN DT = 0.D0 H2 = H1 D2 = D1 RETURN ENDIF RT = C(1) R1 = H1 + RT DO JA = 1,5 !STARTING LAYER IF ( HLAYC(JA+1) - H1 .GT. -1.D-7 ) GOTO 1 ENDDO 1 CONTINUE J1 = JA D2 = D1 - DL !CAN BE NEGATIVE H2 = HEIGHTD( ABS(D2),A ) !NEW HEIGHT IF ( H2 .LE. HGROUND ) THEN !REACH GROUND H2 = HGROUND D2 = 0.D0 DL = SIGN( D1,DL ) J2 = 1 ELSEIF ( H2 .GE. HLAYC(6) ) THEN !LEAVE ATMOSPHERE H2 = HLAYC(6) D2 = DISTAND( H2,A ) DL = SIGN( D2-D1,DL ) J2 = 6 ELSE DO JA = 1,5 !ENDING LAYER IF ( H2 - HLAYC(JA+1) .LT. 1.D-10 ) GOTO 2 ENDDO 2 CONTINUE J2 = JA ENDIF R2 = H2 + RT IF ( J1 .EQ. J2 .AND. D2 .GE. 0.D0 ) THEN C SAME LAYER AND DO NOT CROSS MIDDLE POINT DS = CRSDEPTH0( 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,HLAYC(J) ) + RT ELSE J = J + 1 R02 = HLAYC(J) + RT ENDIF C ENTRANCE OF LOOPING BACK 3 CONTINUE 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. 6 ) GOTO 12 !INFINITY REACHED J2 = J IF ( IS .EQ. 1 ) J2 = J - 1 DSS = CRSDEPTH0( R0,R02,A,J2 ) DS = DS + DSS R0 = R02 IF ( HMIN .GE. HLAYC(J) ) THEN IS = -IS !MIDDLE POINT REACHED ELSE IF ( (A .LE. RADGRD) .AND. (J .EQ. 1) ) THEN !GROUND DT = DS RETURN ENDIF ENDIF J = J + IS R02 = MAX( HMIN,HLAYC(J) ) + RT GOTO 3 12 CONTINUE !BOUNDED AN INTERVAL J2 = J IF ( IS .EQ. 1 ) J2 = J - 1 DS = DS + CRSDEPTH0( R0,R2,A,J2 ) ENDIF DT = DS RETURN END #endif *-- Author : D. HECK IK FZK KARLSRUHE 04/02/2004 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----------------------------------------------------------------------- IMPLICIT NONE #define __AIRINC__ #define __ELABCTINC__ #define __MUPARTINC__ #define __PAMINC__ #define __RUNPARINC__ #include "corsika.h" INTEGER IWK,MAXPTS,MINCAL,MINPTS,N PARAMETER (IWK = 1000000) PARAMETER (MAXPTS = 100000) PARAMETER (MINCAL = 1) 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 SAVE DATA XLOW0 / 1.D-15 / C----------------------------------------------------------------------- DNIELM = 0.D0 C EE IS THE TOTAL ENERGY OF INCOMING MUON ECMIN = PAMA(8) + PAMA(8)**2 / (PAMA(14) * 2.D0) IF ( MT .EQ. 1 ) THEN C MUON ECMAX = EE - 0.5D0 * ( PAMA(14) + PAMA(5)**2/PAMA(14) ) ELSE C TAU LEPTON ECMAX = EE - 0.5D0 * ( PAMA(14) + PAMA(131)**2/PAMA(14) ) ENDIF XLOW = ECMIN / EE C TAKE HADRON CUTTING ENERGY FOR MAXIMUM CDH MARCH 17, 2005 XUPP = ( ELCUT(1) + PAMA(7) ) / EE IF ( ECMAX .LT. ELCUT(1)+PAMA(7) ) XUPP = ECMAX/EE IF ( ECMIN .GE. ELCUT(1)+PAMA(7) ) RETURN 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(MONIOU,*) 'DNIELM: IFAIL=',IFAIL,' E=',EE,' JJMAT=',JJMAT STOP ENDIF DNIELM = RESULT * 1.D27 * EE * AVOGDR / AATOM RETURN END *-- Author : D. HECK IK FZK KARLSRUHE 15/05/2003 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----------------------------------------------------------------------- IMPLICIT NONE #define __CONSTAINC__ #define __ELABCTINC__ #define __MUPARTINC__ #define __PAMINC__ #include "corsika.h" INTEGER IWK,MAXPTS,MINCAL,MINPTS,N PARAMETER (IWK = 1000000) PARAMETER (MAXPTS = 100000) PARAMETER (MINCAL = 1) 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 SAVE DATA XLOW0 / 1.D-15 / C----------------------------------------------------------------------- DNUSGM = 0.D0 ECMIN = PAMA(8) + 0.5D0 * PAMA(8)**2 / PAMA(14) IF ( MT .EQ. 1 ) THEN C EE IS THE TOTAL ENERGY OF INCOMING MUON ECMAX = EE - 0.5D0 * PAMA(14) * (1.D0 + (PAMA(5)/PAMA(14))**2) ELSE C EE IS THE TOTAL ENERGY OF INCOMING TAU LEPTON ECMAX = EE - 0.5D0 * PAMA(14) * (1.D0+(PAMA(131)/PAMA(14))**2) ENDIF C TAKE HADRON CUTTING ENERGY FOR MMINIMU CDH MARCH 17, 2005 XLOW = ( ELCUT(1) + PAMA(7) ) / EE XUPP = ECMAX / EE IF ( ECMAX .LT. ELCUT(1)+PAMA(7) ) RETURN IF ( ECMIN .GT. ELCUT(1)+PAMA(7) ) 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(6,*) 'DNUSGM: IFAIL=',IFAIL,' E=',EE,' JJMAT=',JJMAT STOP ENDIF C CONVERT FROM CM**2 TO MILLIBARN DNUSGM = RESULT * 1.D27 RETURN END *-- Author : D. HECK IK FZK KARLSRUHE 25/06/2003 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----------------------------------------------------------------------- IMPLICIT NONE #define __AIRINC__ #define __CONSTAINC__ #define __MUPARTINC__ #define __PAMINC__ #define __RUNPARINC__ #include "corsika.h" INTEGER IWK,MAXPTS,MINCAL,MINPTS,N PARAMETER (IWK = 1000000) PARAMETER (MAXPTS = 100000) PARAMETER (MINCAL = 1) PARAMETER (MINPTS = 10) PARAMETER (N = 2) DOUBLE PRECISION ALPHFA,EPSPP,RE PARAMETER (ALPHFA = 7.297353D-3) PARAMETER (EPSPP = 1.D-3) PARAMETER (RE = 3.8615932335D-11) !ELECTRON RADIUS (CM) 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 SAVE DATA XLOW0 / 1.D-15 / C----------------------------------------------------------------------- DPRELM = 0.D0 C EE IS THE TOTAL ENERGY OF INCOMING MUON ECMIN = 4.D0 * PAMA(2) 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 * PAMA(2) / 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(MONIOU,*) 'DPRELM: IFAIL=',IFAIL,' E=',EE,' JJMAT=',JJMAT STOP ENDIF C NORMALIZE TO GET ENERGY LOSS IN GEV * G**-1 * CM**2 DPRELM = AVOGDR * RESULT * 2.D27 * EE * ALPHFA**4 * (TB3/PI) * * ZATOM * (ZATOM+1.D0) * RE**2 / AATOM RETURN END *-- Author : D. HECK IK FZK KARLSRUHE 14/05/2003 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----------------------------------------------------------------------- IMPLICIT NONE #define __CONSTAINC__ #define __MUPARTINC__ #define __PAMINC__ #define __RUNPARINC__ #include "corsika.h" INTEGER IWK,MAXPTS,MINCAL,MINPTS,N PARAMETER (IWK = 1000000) PARAMETER (MAXPTS = 100000) PARAMETER (MINCAL = 1) PARAMETER (MINPTS = 10) PARAMETER (N = 2) DOUBLE PRECISION ALPHFA,EPSPP,RE PARAMETER (ALPHFA = 7.297353D-3) PARAMETER (EPSPP = 1.D-3) PARAMETER (RE = 3.8615932335D-11) !ELECTRON RADIUS (CM) 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 SAVE DATA XLOW0 / 1.D-15 / C----------------------------------------------------------------------- DPRSGM = 0.D0 IF ( MT .EQ. 1 ) THEN C EE IS THE TOTAL ENERGY OF INCOMING MUON IF ( EE-PAMA(5) .LT. BCUT ) RETURN ELSE C EE IS THE TOTAL ENERGY OF INCOMING TAU LEPTON IF ( EE-PAMA(131) .LT. BCUT ) RETURN ENDIF ECMIN = 4.D0 * PAMA(2) 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 * PAMA(2) / 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(MONIOU,*) '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 *-- Author : K. BERNLOEHR MPIK HEIDELBERG 15/06/1998 C======================================================================= SUBROUTINE DTCCHR( LINE,IS,CVAL,KEYWRD,IKEY,LENVAL ) C----------------------------------------------------------------------- C D(A)T(A) C(ARD) CH(A)R(ACTER) C C READ CHARACTER PARAMETER FROM DATA CARD CHARACTER STRING C ERRORS ARE INDICATED BY WRITING A '!' IN LINE(1:1) C THIS SUBROUTINE IS CALLED FROM DATAC. C ARGUMENTS: C LINE = CHARACTER STRING OF INPUT LINE C IS = POINTER FOR START OF INTERPRETATION OF 'LINE' C CVAL = CHARACTER STRING TO BE RETURNED C KEYWRD = KEYWORD AT BEGIN OF LINE C IKEY = NUMBER OF ARGUMENT AFTER KEYWORD C LENVAL = LENGTH OF CHARACTER STRING TO BE RETURNED C----------------------------------------------------------------------- IMPLICIT NONE #define __RUNPARINC__ #include "corsika.h" INTEGER I,IE,IKEY,IQUOTE,IS,L,LENVAL CHARACTER CVAL*(*),KEYWRD*(*),LINE*(*) SAVE C----------------------------------------------------------------------- IF ( IS .LE. 0 ) IS = LEN(KEYWRD) L = LEN(LINE) DO I = IS+1, L IF ( LINE(I:I) .NE. ' ' ) GOTO 11 ENDDO 11 IF ( I .GT. L .OR. LINE(I:I) .EQ. '!' * .OR. LINE(I:I) .EQ. ' ' ) THEN IF ( IKEY .LE. 1 ) THEN WRITE(MONIOU,6000) KEYWRD 6000 FORMAT(1X,'DATACARD ',A,' HAS NO PARAMETER(S)') ELSE WRITE(MONIOU,6001) KEYWRD,IKEY 6001 FORMAT(1X,'DATACARD ',A,' PARAMETER',I2,' IS MISSING') ENDIF CVAL = ' ' LINE(1:1) = '!' LENVAL = 0 RETURN ENDIF IF ( LINE(I:I) .EQ. '''' ) THEN IQUOTE = 1 IS = I+1 ELSEIF ( LINE(I:I) .EQ. '"' ) THEN IQUOTE = 2 IS = I+1 ELSE IQUOTE = 0 IS = I ENDIF DO I = IS, L IF ( IQUOTE .EQ. 1 ) THEN IF ( LINE(I:I) .EQ. '''' ) GOTO 21 ELSEIF ( IQUOTE .EQ. 2 ) THEN IF ( LINE(I:I) .EQ. '"' ) GOTO 21 ELSE IF ( LINE(I:I) .EQ. ' ' .OR. LINE(I:I) .EQ. '!' ) GOTO 21 ENDIF ENDDO 21 CONTINUE IE = I IF ( IQUOTE .EQ. 1 ) THEN IF ( LINE(I:I) .EQ. '''' ) THEN IE = I-1 LINE(I:I) = ' ' ENDIF ELSEIF ( IQUOTE .EQ. 2 ) THEN IF ( LINE(I:I) .EQ. '"' ) THEN IE = I-1 LINE(I:I) = ' ' ENDIF ELSEIF ( LINE(I:I) .EQ. ' ' .OR. LINE(I:I) .EQ. '!' ) THEN IE = I-1 ENDIF * WRITE(*,6666) KEYWRD,IKEY,IS,IE,LINE(IS:IE) *6666 FORMAT(1X,'DTCCHR: ',A,' #',I3,I4,I4,': ',A) CVAL = LINE(IS:IE) LENVAL = IE-IS+1 IF ( LEN(CVAL) .LT. IE-IS+1 ) THEN WRITE(MONIOU,6002) * KEYWRD,IKEY,IE-IS+1,LEN(CVAL),CVAL 6002 FORMAT(1X,'DATACARD ',A,' PARAMETER',I2,' IS TOO LONG AND HAS', * ' BEEN TRUNCATED FROM',I4,' TO',I4,':',/,5X,'''',A,'''') LINE(1:1) = '!' LENVAL = LEN(CVAL) ENDIF IS = IE IF ( DEBUG ) WRITE(MDEBUG,6667) CVAL 6667 FORMAT(1X,'DTCCHR: VALUE = ''',A,'''') RETURN END *-- Author : K. BERNLOEHR MPIK HEIDELBERG 15/06/1998 C======================================================================= SUBROUTINE DTCDBL( LINE,IS,DVAL,KEYWRD,IKEY ) C----------------------------------------------------------------------- C D(A)T(A) C(ARD) D(OU)BL(E PRECISION) C C READ DOUBLE PRECISION PARAMETER FROM DATA CARD CHARACTER STRING C ERRORS ARE INDICATED BY WRITING A '!' IN LINE(1:1) C THIS SUBROUTINE IS CALLED FROM DATAC. C ARGUMENTS: C LINE = CHARACTER STRING OF INPUT LINE C IS = POINTER FOR START OF INTERPRETATION OF 'LINE' C DVAL = DOUBLE PRECISION VARIABLE TO BE RETURNED C KEYWRD = KEYWORD AT BEGIN OF LINE C IKEY = NUMBER OF ARGUMENT AFTER KEYWORD C----------------------------------------------------------------------- IMPLICIT NONE #define __RUNPARINC__ #include "corsika.h" DOUBLE PRECISION DVAL INTEGER I,IE,IKEY,IS,L CHARACTER CFMTR*8,KEYWRD*(*),LINE*(*) SAVE C----------------------------------------------------------------------- IF ( IS .LE. 0 ) IS = LEN(KEYWRD) L = LEN(LINE) DO I = IS+1, L IF ( LINE(I:I) .NE. ' ' ) GOTO 11 ENDDO 11 IF ( I .GT. L .OR. LINE(I:I) .EQ. '!' * .OR. LINE(I:I) .EQ. ' ' ) THEN IF ( IKEY .LE. 1 ) THEN WRITE(MONIOU,6000) KEYWRD 6000 FORMAT(1X,'DATACARD ',A,' HAS NO PARAMETER(S)') ELSE WRITE(MONIOU,6001) KEYWRD,IKEY 6001 FORMAT(1X,'DATACARD ',A,' PARAMETER',I2,' IS MISSING') ENDIF DVAL = 0.D0 LINE(1:1) = '!' RETURN ENDIF IS = I DO I = IS+1, L IF ( LINE(I:I) .EQ. ' ' .OR. LINE(I:I) .EQ. '!' ) GOTO 21 ENDDO 21 IF ( LINE(I:I) .EQ. ' ' .OR. LINE(I:I) .EQ. '!' ) THEN IE = I-1 ELSE IE = I ENDIF * WRITE(*,*) 'DTCDBL: ',KEYWRD,' #',IKEY,IS,IE,': ',LINE(IS:IE) IF ( IE-IS+1 .LT. 10 ) THEN CFMTR = '(F .0)' WRITE(CFMTR(3:3),'(I1)') IE-IS+1 ELSE CFMTR = '(F .0)' WRITE(CFMTR(3:4),'(I2)') IE-IS+1 ENDIF READ(LINE(IS:IE),CFMTR,ERR=999) DVAL IS = IE IF ( DEBUG ) WRITE(MDEBUG,*) 'DTCDBL: VALUE = ',DVAL RETURN 999 WRITE(MONIOU,6002) KEYWRD,IKEY,LINE(IS:IE) 6002 FORMAT(1X,'DATACARD ',A,' PARAMETER',I2,' IS INVALID: ',A) LINE(1:1) = '!' DVAL = 0.D0 IS = IE IF ( DEBUG ) WRITE(MDEBUG,*) 'DTCDBL: VALUE = ',DVAL RETURN END *-- Author : K. BERNLOEHR MPIK HEIDELBERG 15/06/1998 C======================================================================= SUBROUTINE DTCHEX( LINE,IS,DVAL,KEYWRD,IKEY ) C----------------------------------------------------------------------- C D(A)T(A) C(ARD) D(OU)BL(E PRECISION) C C HEXADECIMAL PARAMETERS FROM DATA CARD CHARACTER STRING C ERRORS ARE INDICATED BY WRITING A '!' IN LINE(1:1) C THIS SUBROUTINE IS CALLED FROM DATAC. C ARGUMENTS: C LINE = CHARACTER STRING OF INPUT LINE C IS = POINTER FOR START OF INTERPRETATION OF 'LINE' C DVAL = HEXADECIMAL VARIABLE TO BE RETURNED C KEYWRD = KEYWORD AT BEGIN OF LINE C IKEY = NUMBER OF ARGUMENT AFTER KEYWORD C----------------------------------------------------------------------- IMPLICIT NONE #define __RUNPARINC__ #include "corsika.h" DOUBLE PRECISION DVAL INTEGER I,IE,IKEY,IS,L CHARACTER CFMTR*8,KEYWRD*(*),LINE*(*) SAVE C----------------------------------------------------------------------- IF ( IS .LE. 0 ) IS = LEN(KEYWRD) L = LEN(LINE) DO I = IS+1, L IF ( LINE(I:I) .NE. ' ' ) GOTO 11 ENDDO 11 IF ( I .GT. L .OR. LINE(I:I) .EQ. '!' * .OR. LINE(I:I) .EQ. ' ' ) THEN IF ( IKEY .LE. 1 ) THEN WRITE(MONIOU,6000) KEYWRD 6000 FORMAT(1X,'DATACARD ',A,' HAS NO PARAMETER(S)') ELSE WRITE(MONIOU,6001) KEYWRD,IKEY 6001 FORMAT(1X,'DATACARD ',A,' PARAMETER',I2,' IS MISSING') ENDIF DVAL = 0.D0 LINE(1:1) = '!' RETURN ENDIF IS = I DO I = IS+1, L IF ( LINE(I:I) .EQ. ' ' .OR. LINE(I:I) .EQ. '!' ) GOTO 21 ENDDO 21 IF ( LINE(I:I) .EQ. ' ' .OR. LINE(I:I) .EQ. '!' ) THEN IE = I-1 ELSE IE = I ENDIF * WRITE(*,*) 'DTCDBL: ',KEYWRD,' #',IKEY,IS,IE,': ',LINE(IS:IE) IF ( IE-IS+1 .LT. 10 ) THEN CFMTR = '(Z )' WRITE(CFMTR(3:3),'(I1)') IE-IS+1 ELSE CFMTR = '(Z )' WRITE(CFMTR(3:4),'(I2)') IE-IS+1 ENDIF READ(LINE(IS:IE),CFMTR,ERR=999) DVAL IS = IE IF ( DEBUG ) WRITE(MDEBUG,*) 'DTCHEX: VALUE = ',DVAL RETURN 999 WRITE(MONIOU,6002) KEYWRD,IKEY,LINE(IS:IE) 6002 FORMAT(1X,'DATACARD ',A,' PARAMETER',I2,' IS INVALID: ',A) LINE(1:1) = '!' DVAL = 0.D0 IS = IE IF ( DEBUG ) WRITE(MDEBUG,*) 'DTCHEX: VALUE = ',DVAL RETURN END *-- Author : K. BERNLOEHR MPIK HEIDELBERG 15/06/1998 C======================================================================= SUBROUTINE DTCINT( LINE,IS,IVAL,KEYWRD,IKEY ) C----------------------------------------------------------------------- C D(A)T(A) C(ARD) INT(EGER) C C READ INTEGER PARAMETER FROM DATA CARD CHARACTER STRING C ERRORS ARE INDICATED BY WRITING A '!' IN LINE(1:1) C THIS SUBROUTINE IS CALLED FROM DATAC. C ARGUMENTS: C LINE = CHARACTER STRING OF INPUT LINE C IS = POINTER FOR START OF INTERPRETATION OF 'LINE' C IVAL = INTEGER VARIABLE TO BE RETURNED C KEYWRD = KEYWORD AT BEGIN OF LINE C IKEY = NUMBER OF ARGUMENT AFTER KEYWORD C----------------------------------------------------------------------- IMPLICIT NONE #define __RUNPARINC__ #include "corsika.h" INTEGER I,IE,IKEY,IS,IVAL,L CHARACTER CFMTI*8,KEYWRD*(*),LINE*(*) SAVE C----------------------------------------------------------------------- IF ( IS .LE. 0 ) IS = LEN(KEYWRD) L = LEN(LINE) DO I = IS+1, L IF ( LINE(I:I) .NE. ' ' ) GOTO 11 ENDDO 11 IF ( I .GT. L .OR. LINE(I:I) .EQ. '!' * .OR. LINE(I:I) .EQ. ' ' ) THEN IF ( IKEY .LE. 1 ) THEN WRITE(MONIOU,6000) KEYWRD 6000 FORMAT(1X,'DATACARD ',A,' HAS NO PARAMETER(S)') ELSE WRITE(MONIOU,6001) KEYWRD,IKEY 6001 FORMAT(1X,'DATACARD ',A,' PARAMETER',I2,' IS MISSING') ENDIF IVAL = 0 LINE(1:1) = '!' RETURN ENDIF IS = I DO I = IS+1, L IF ( LINE(I:I) .EQ. ' ' .OR. LINE(I:I) .EQ. '!' ) GOTO 21 ENDDO 21 IF ( LINE(I:I) .EQ. ' ' .OR. LINE(I:I) .EQ. '!' ) THEN IE = I-1 ELSE IE = I ENDIF * WRITE(*,*) 'DTCINT: ',KEYWRD,' #',IKEY,IS,IE,': ',LINE(IS:IE) DO I = IS, IE IF ( (ICHAR(LINE(I:I)) .LT. ICHAR('0') .OR. * ICHAR(LINE(I:I)) .GT. ICHAR('9')) .AND. * (LINE(I:I) .NE. '-' .OR. I .NE. IS) ) THEN WRITE(MONIOU,6002) KEYWRD,IKEY,LINE(IS:IE) 6002 FORMAT(1X,'DATACARD ',A,' PARAMETER',I2, * ' IS NOT INTEGER: ',A) IS = IE IVAL = 0 LINE(1:1) = '!' RETURN ENDIF ENDDO IF ( IE-IS+1 .LT. 10 ) THEN CFMTI = '(I )' WRITE(CFMTI(3:3),'(I1)') IE-IS+1 ELSE CFMTI = '(I )' WRITE(CFMTI(3:4),'(I2)') IE-IS+1 ENDIF READ(LINE(IS:IE),CFMTI) IVAL IS = IE IF ( DEBUG ) WRITE(MDEBUG,*) 'DTCINT: VALUE = ',IVAL RETURN END *-- Author : K. BERNLOEHR MPIK HEIDELBERG 15/06/1998 C======================================================================= SUBROUTINE DTCLOG( LINE,IS,LVAL,KEYWRD,IKEY ) C----------------------------------------------------------------------- C D(A)T(A) C(ARD) LOG(ICAL) C C READ LOGICAL PARAMETER FROM DATA CARD CHARACTER STRING. C MAKE USE OF UPPERCASE CONVERSION OF DATA CARDS. C FOR 'T' YOU CAN ALSO USE 'TRUE', '.TRUE.', 'Y', 'YES', 'ON', '1'. C FOR 'F' YOU CAN ALSO USE 'FALSE', '.FALSE.', 'N', 'NO', 'OFF', '0'. C ERRORS ARE INDICATED BY WRITING A '!' IN LINE(1:1) C THIS SUBROUTINE IS CALLED FROM DATAC. C ARGUMENTS: C LINE = CHARACTER STRING OF INPUT LINE C IS = POINTER FOR START OF INTERPRETATION OF 'LINE' C LVAL = LOGICAL TO BE RETURNED C KEYWRD = KEYWORD AT BEGIN OF LINE C IKEY = NUMBER OF ARGUMENT AFTER KEYWORD C----------------------------------------------------------------------- IMPLICIT NONE #define __RUNPARINC__ #include "corsika.h" INTEGER I,IE,IKEY,IS,L LOGICAL LVAL CHARACTER KEYWRD*(*),LINE*(*) SAVE C----------------------------------------------------------------------- IF ( IS .LE. 0 ) IS = LEN(KEYWRD) L = LEN(LINE) DO I = IS+1, L IF ( LINE(I:I) .NE. ' ' ) GOTO 11 ENDDO 11 IF ( I .GT. L .OR. LINE(I:I) .EQ. '!' * .OR. LINE(I:I) .EQ. ' ' ) THEN IF ( IKEY .LE. 1 ) THEN WRITE(MONIOU,6000) KEYWRD 6000 FORMAT(1X,'DATACARD ',A,' HAS NO PARAMETER(S)') ELSE WRITE(MONIOU,6001) KEYWRD,IKEY 6001 FORMAT(1X,'DATACARD ',A,' PARAMETER',I2,' IS MISSING') ENDIF IS = IE LVAL = .FALSE. LINE(1:1) = '!' RETURN ENDIF IS = I DO I = IS+1, L IF ( LINE(I:I) .EQ. ' ' .OR. LINE(I:I) .EQ. '!' ) GOTO 21 ENDDO 21 IF ( LINE(I:I) .EQ. ' ' .OR. LINE(I:I) .EQ. '!' ) THEN IE = I-1 ELSE IE = I ENDIF * WRITE(*,*) 'DTCLOG: ',KEYWRD,' #',IKEY,IS,IE,': ',LINE(IS:IE) IF ( LINE(IS:IE) .EQ. 'T' .OR. LINE(IS:IE) .EQ. 'TRUE' * .OR. LINE(IS:IE) .EQ. '.TRUE.' * .OR. LINE(IS:IE) .EQ. 'Y' .OR. LINE(IS:IE) .EQ. 'YES' * .OR. LINE(IS:IE) .EQ. 'ON' .OR. LINE(IS:IE) .EQ. '1' ) THEN LVAL = .TRUE. ELSEIF ( LINE(IS:IE) .EQ. 'F' .OR. LINE(IS:IE) .EQ. 'FALSE' * .OR. LINE(IS:IE) .EQ. '.FALSE.' * .OR. LINE(IS:IE) .EQ. 'N' .OR. LINE(IS:IE) .EQ. 'NO' * .OR. LINE(IS:IE) .EQ. 'OFF' .OR. LINE(IS:IE) .EQ. '0' ) THEN LVAL = .FALSE. ELSE WRITE(MONIOU,6002) KEYWRD,IKEY,LINE(IS:IE) 6002 FORMAT(1X,'DATACARD ',A,' PARAMETER',I2,' IS INVALID: ',A) LVAL = .FALSE. LINE(1:1) = '!' ENDIF IS = IE IF ( DEBUG ) WRITE(MDEBUG,*) 'DTCLOG: VALUE = ',LVAL RETURN END *-- Author : K. BERNLOEHR MPIK HEIDELBERG 15/06/1998 C======================================================================= SUBROUTINE DTCRL( LINE,IS,RVAL,KEYWRD,IKEY ) C----------------------------------------------------------------------- C D(A)T(A) C(ARD) R(EA)L C C READ REAL PARAMETER FROM DATA CARD CHARACTER STRING C ERRORS ARE INDICATED BY WRITING A '!' IN LINE(1:1) C THIS SUBROUTINE IS CALLED FROM DATAC. C ARGUMENTS: C LINE = CHARACTER STRING OF INPUT LINE C IS = POINTER FOR START OF INTERPRETATION OF 'LINE' C RVAL = REAL VARIABLE TO BE RETURNED C KEYWRD = KEYWORD AT BEGIN OF LINE C IKEY = NUMBER OF ARGUMENT AFTER KEYWORD C----------------------------------------------------------------------- IMPLICIT NONE #define __RUNPARINC__ #include "corsika.h" REAL RVAL INTEGER I,IE,IKEY,IS,L CHARACTER CFMTR*8,LINE*(*),KEYWRD*(*) SAVE C----------------------------------------------------------------------- IF ( IS .LE. 0 ) IS = LEN(KEYWRD) L = LEN(LINE) DO I = IS+1, L IF ( LINE(I:I) .NE. ' ' ) GOTO 11 ENDDO 11 IF ( I .GT. L .OR. LINE(I:I) .EQ. '!' * .OR. LINE(I:I) .EQ. ' ' ) THEN IF ( IKEY .LE. 1 ) THEN WRITE(MONIOU,6000) KEYWRD 6000 FORMAT(1X,'DATACARD ',A,' HAS NO PARAMETER(S)') ELSE WRITE(MONIOU,6001) KEYWRD,IKEY 6001 FORMAT(1X,'DATACARD ',A,' PARAMETER',I2,' IS MISSING') ENDIF RVAL = 0. LINE(1:1) = '!' RETURN ENDIF IS = I DO I = IS+1, L IF ( LINE(I:I) .EQ. ' ' .OR. LINE(I:I) .EQ. '!' ) GOTO 21 ENDDO 21 IF ( LINE(I:I) .EQ. ' ' .OR. LINE(I:I) .EQ. '!' ) THEN IE = I-1 ELSE IE = I ENDIF * WRITE(*,*) 'DTCRL : ',KEYWRD,' #',IKEY,IS,IE,': ',LINE(IS:IE) IF ( IE-IS+1 .LT. 10 ) THEN CFMTR = '(F .0)' WRITE(CFMTR(3:3),'(I1)') IE-IS+1 ELSE CFMTR = '(F .0)' WRITE(CFMTR(3:4),'(I2)') IE-IS+1 ENDIF READ(LINE(IS:IE),CFMTR,ERR=999) RVAL IF ( DEBUG ) WRITE(MDEBUG,*) 'DTCRL : VALUE = ',RVAL IS = IE RETURN 999 WRITE(MONIOU,6002) KEYWRD,IKEY,LINE(IS:IE) 6002 FORMAT(1X,'DATACARD ',A,' PARAMETER',I2,' IS INVALID: ',A) RVAL = 0. LINE(1:1) = '!' IS = IE IF ( DEBUG ) WRITE(MDEBUG,*) 'DTCRL : VALUE = ',RVAL RETURN END #if __CURVED__ && __SLANT__ *-- Author : V. Chernatkin Univ. Nantes 00/00/2003 C======================================================================= SUBROUTINE DT2DL( DT,DL,H1,H2,A,JINV ) C----------------------------------------------------------------------- C CONVERT A SLANT DEPTH INTERVAL INTO A SLANT DISTANCE INTERVAL. C THIS SUBROUTINE IS CALLED FROM COOINC. C ARGUMENTS: C DT = SLANT DEPTH INTERVAL (G/CM^2) (INPUT) C (UPDATED IF BORDER REACHED) C (>0 GO TOWARDS THE MIDDLE POINT, <0 GO BACKWARDS) C DL = SLANT DISTANCE INTERVAL (CM) (ALWAYS POSITIVE) (OUPUT) C H1 = HEIGHT ABOVE SEA LEVEL OF STARTING POINT (CM) (INPUT) C H2 = HEIGHT ABOVE SEA LEVEL OF ENDING POINT (CM) (OUTPUT) C A = IMPACT RADIUS (CM) (INPUT). C JINV = IF NOT 0, MIDDLE POINT CROSSED (OUTPUT). C----------------------------------------------------------------------- IMPLICIT NONE #define __ATMOS2INC__ #define __ATMOSLINC__ #define __OBSPARINC__ #define __PARPARINC__ #define __RUNPARINC__ #include "corsika.h" DOUBLE PRECISION A,ADT,DDS,DL,DS,DT,FS,HMIN,H1,H2, * R,RT,R1,R2 DOUBLE PRECISION CRSDEPTH0,CRSRADIUS0 INTEGER IS,J,JA,JINV,J2 EXTERNAL CRSDEPTH0,CRSRADIUS0 SAVE C----------------------------------------------------------------------- JINV = 0 ADT = ABS( DT ) IF ( ADT .LT. 1.D-15 ) THEN DL = 0.D0 H2 = H1 RETURN ELSEIF ( ADT .GT. 1.D20 ) THEN DL = 1.D30 H2 = H1 RETURN ENDIF RT = C(1) R1 = H1 + RT HMIN = A - RT IS = -INT( SIGN( 1.D0,DT ) ) !DIRECTION OF PROPAGATION FS = 1.D0 DO JA = 1,5 !STARTING LAYER IF ( HLAYC(JA+1) - H1 .GT. -1.D-7 ) GOTO 1 ENDDO 1 CONTINUE J = JA C TEST DT, IF LAST POINT STILL IN LAYER, IT''S FINISH (FASTER) R2 = CRSRADIUS0( R1,ADT,IS,A,-J ) IF ( IS .EQ. -1 ) THEN !GOING TOWARDS MIDDLE POINT IF ( HLAYC(J) .GE. HMIN .AND. R2 .GE. HLAYC(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 RETURN ELSE R2 = MAX( HMIN,HLAYC(J) ) + RT ENDIF ELSE IF ( R2 .GT. 0.D0 ) THEN !GOING BACKWARDS MIDDLE POINT IF ( R2 .LE. HLAYC(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 RETURN ELSEIF ( J+1 .EQ. 6 ) THEN !LEAVE ATMO. R2 = HLAYC(6) + 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 = HLAYC(6) DT = -CRSDEPTH0( R1,R2,A,J ) RETURN ENDIF ENDIF J = J + 1 R2 = HLAYC(J) + RT ENDIF R = R1 !ACTUAL HEIGHT DS = 0.D0 !DEPTH CROSSED C ENTRANCE OF LOOPING BACK 3 CONTINUE !HOW MANY LAYERS WE CROSS? J2 = J IF ( IS .EQ. 1 ) J2 = J - 1 DDS = CRSDEPTH0( R,R2,A,J2 ) !CROSSED DEPTH IF ( DS+DDS .GE. ADT ) GOTO 12 !BOUNDED IF ( J .EQ. 6 ) GOTO 12 !INFINITY REACHED DS = DS + DDS R = R2 IF ( HMIN .GT. HLAYC(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) ) ) H2 = HGROUND DT = SIGN( DS,DT ) RETURN ENDIF ENDIF J = J + IS R2 = MAX( HMIN,HLAYC(J) ) + RT GOTO 3 12 CONTINUE !BOUNDED AN INTERVAL IF ( J .EQ. 6 .AND. DS+DDS .LT. ADT ) THEN !LEAVE ATMO. H2 = HLAYC(6) DT = SIGN( DS+DDS,DT ) ELSE J2 = J IF ( IS .EQ. 1 ) J2 = J - 1 IF ( ADT-DS .LT. DS+DDS-ADT ) THEN R2 = CRSRADIUS0( R,ADT-DS,IS,A,J2 ) ELSE R2 = CRSRADIUS0( R2,DS+DDS-ADT,-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) ) ) RETURN END #endif *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE EM C----------------------------------------------------------------------- C E(LECTRO) M(AGNETIC PARTICLES) C C ROUTINE FOR TREATING EM PARTICLES C THIS SUBROUTINE IS CALLED FROM BOX3. C----------------------------------------------------------------------- IMPLICIT NONE #define __GENERINC__ #define __LONGIINC__ #define __PAMINC__ #define __PARPARINC__ #define __PARPAEINC__ #define __RUNPARINC__ #if __AUGERHIST__ #define __OBSPARINC__ #endif #include "corsika.h" DOUBLE PRECISION ENER,THICK INTEGER I #if __AUGERHIST__ DOUBLE PRECISION EDEP,THICKLOC INTEGER II,LL #endif #if __SLANT__ INTEGER LBIN EXTERNAL LBIN #endif SAVE EXTERNAL THICK C----------------------------------------------------------------------- #if __THIN__ IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=0,9),WEIGHT 444 FORMAT(' EM : CURPAR=',1P,11E11.3) #else IF ( DEBUG ) THEN WRITE(MDEBUG,444) (CURPAR(I),I=0,9) 444 FORMAT(' EM : CURPAR=',1P,9E11.3,0P,F6.0) #if __MULTITHIN__ WRITE(MDEBUG,31) (CURPAR(I),I=41,46) 31 FORMAT(' EM : 41-46: ',1P,6E11.3) #endif ENDIF #endif C GET CORRECT PARTICLE ENERGY IF ( ITYPE .EQ. 1 ) THEN ENER = CURPAR(1) ELSEIF ( ITYPE .EQ. 2 .OR. ITYPE .EQ. 3 ) THEN ENER = CURPAR(1) * PAMA(2) ELSE WRITE(MONIOU,*) 'EM : WRONG PARTICLE CODE =',ITYPE RETURN ENDIF C COPY PARTICLE COORDINATES INTO SECPAR DO I = 0, 8 SECPAR(I) = CURPAR(I) ENDDO SECPAR( 9) = GEN SECPAR(10) = ALEVEL #if __THIN__ SECPAR(13) = WEIGHT #endif #if __CURVED__ SECPAR(14) = CURPAR(14) SECPAR(15) = CURPAR(15) SECPAR(16) = CURPAR(16) #endif #if __INTTEST__ SECPAR(17) = CURPAR(17) #endif #if __EHISTORY__ DO I = 17, 38 SECPAR(I) = CURPAR(I) ENDDO IF ( DEBUG ) WRITE(MDEBUG,445) (SECPAR(I),I=17,27) 445 FORMAT(' EM : 17-27:',1P,11E11.3) IF ( DEBUG ) WRITE(MDEBUG,446) (SECPAR(I),I=28,38) 446 FORMAT(' EM : 28-38:',1P,11E11.3) #endif #if __PARALLEL__ C SET ECTFLG TO CURRENT SECPAR(39) = CURPAR(39) #endif #if __MULTITHIN__ DO I = 41, 46 SECPAR(I) = CURPAR(I) ENDDO #endif C CALL NKG IF SELECTED IF ( FNKG ) CALL NKG( ENER ) C CALL EGS4 IF SELECTED (PARTICLE IS TAKEN IN EGS FROM CURPAR) IF ( FEGS ) THEN CALL EGS4( ENER ) ELSE IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT #if __SLANT__ #if __CURVED__ LHEIGH = MIN( LBIN( X,Y,HAPP,1 ), NSTEP+1 ) #else LHEIGH = MIN( LBIN( X,Y,H,1 ), NSTEP+1 ) #endif #else LHEIGH = INT( THICK( H )*THSTPI + 1.D0 ) #endif IF ( SECPAR(0) .EQ. 1.D0 ) THEN #if __THIN__ DLONG(LHEIGH,1) = DLONG(LHEIGH,1) + ENER*WEIGHT ELSEIF ( SECPAR(0) .EQ. 2.D0 ) THEN DLONG(LHEIGH,3) = DLONG(LHEIGH,3) + (ENER+PAMA(2))*WEIGHT ELSE DLONG(LHEIGH,3) = DLONG(LHEIGH,3) + (ENER-PAMA(2))*WEIGHT #else DLONG(LHEIGH,1) = DLONG(LHEIGH,1) + ENER ELSEIF ( SECPAR(0) .EQ. 2.D0 ) THEN DLONG(LHEIGH,3) = DLONG(LHEIGH,3) + (ENER+PAMA(2)) ELSE DLONG(LHEIGH,3) = DLONG(LHEIGH,3) + (ENER-PAMA(2)) #endif ENDIF ENDIF #if __AUGERHIST__ THICKLOC = THICK( H ) DO LL = 1, NOBSLV IF ( THICKLOC .GE. THCKOB(LL) .AND. * THICKLOC .LT. THCKOB(LL)+SAMPTH ) THEN C THICKH IS WITHIN 1 G/CM^2 BELOW OBSLEV(LL) C BRING THE ENERGY BELOW CUT TO THE HISTO OF LEVEL LL DO II = 0, 8 OUTPAR(II) = CURPAR(II) ENDDO OUTPAR( 9) = GEN OUTPAR(10) = ALEVEL OUTPAR(13) = WEIGHT IF ( ITYPE .EQ. 1 ) THEN EDEP = ENER * WEIGHT ELSEIF ( ITYPE .EQ. 2 ) THEN EDEP = ( ENER + PAMA(2) ) * WEIGHT ELSE EDEP = ( ENER - PAMA(2) ) * WEIGHT ENDIF CALL AUGERDEPFIL( EDEP,LL,0 ) ELSEIF ( THICKLOC .LT. THCKOB(LL) ) THEN GOTO 111 ENDIF ENDDO 111 CONTINUE #endif ENDIF RETURN END *-- Author : D. HECK IKP KIT KARLSRUHE 30/10/2014 C======================================================================= SUBROUTINE ETADEC C----------------------------------------------------------------------- C ETA DEC(AY) C C ROUTINE TREATES DECAY OF ETA C DECAY WITH FULL KINEMATIC, ENERGY AND MOMENTA CONSERVED C THIS SUBROUTINE IS CALLED FROM NUCINT. C UPDATED INCLUDING RARE DECAY ETA ---> MU(+) + MU(-) + GAMMA C----------------------------------------------------------------------- IMPLICIT NONE #define __CONSTAINC__ #define __DECAYCINC__ #define __EDECAYINC__ #define __GENERINC__ #define __LONGIINC__ #define __PAMINC__ #define __PARPARINC__ #define __PARPAEINC__ #define __POLARINC__ #define __RANDPAINC__ #define __RUNPARINC__ #if __AUGERHIST__ #define __OBSPARINC__ #endif #include "corsika.h" DOUBLE PRECISION AUX1,AUX2,COSTH1,COSTH2,EETA2,FAC1,FAC2,FI1 INTEGER I #if __AUGERHIST__ DOUBLE PRECISION EDEP,THICKLOC,THICK INTEGER II,LL EXTERNAL THICK #endif SAVE C----------------------------------------------------------------------- #if __THIN__ IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=0,9),WEIGHT 444 FORMAT(' ETADEC: CURPAR=',1P,11E11.3) #else IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=0,9) 444 FORMAT(' ETADEC: CURPAR=',1P,10E11.3) #endif C SELECT MODE OF DECAY, IF NOT ALREADY SELECTED BY THE PARTICLE TYPE C NEW VALUES (2014) DERIVED FROM PARTICLE DATA GROUP VALUES IF ( ITYPE .EQ. 17 ) THEN CALL RMMARD( RD,1,1 ) IF ( RD(1) .LE. 0.39703D0 ) THEN ITYPE = 71 ELSEIF ( RD(1) .LE. 0.72627D0 ) THEN ITYPE = 72 ELSEIF ( RD(1) .LE. 0.95717D0 ) THEN ITYPE = 73 ELSEIF ( RD(1) .LE. 0.99969D0 ) THEN ITYPE = 74 ELSE ! RARE DECAY ETA ----> MU(+) + MU(-) + GAMMA GOTO 201 ENDIF ENDIF C DECAY OF ETA WITH 4 MODES C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C DECAY ETA ----> GAMMA + GAMMA IF ( ITYPE .EQ. 71 ) THEN EETA2 = 0.5D0 * GAMMA * PAMA(17) CALL RMMARD( RD,2,1 ) AUX1 = 1.D0 + BETA * RD(1) AUX2 = 1.D0 - BETA * RD(1) COSTH1 = (BETA + RD(1)) / AUX1 COSTH2 = (BETA - RD(1)) / AUX2 SECPAR(0) = 1.D0 C FIRST GAMMA (WITH HIGHER ENERGY) SECPAR(1) = AUX1 * EETA2 FI1 = PI2 * RD(2) CALL ADDANG3( COSTHE,PHIX,PHIY, COSTH1,FI1, * SECPAR(2),SECPAR(3),SECPAR(4) ) #if __UPWARD__ IF ( SECPAR(2) .GE. -1.D0 ) THEN #else IF ( SECPAR(2) .GT. C(29) ) THEN #endif #if __INTTEST__ SECPAR(17) = SECPAR(1) * * SQRT( (1.D0-SECPAR(2))*(1.D0+SECPAR(2)) ) #endif CALL TSTACK ELSE IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT #if __THIN__ DLONG(LHEIGH,11) = DLONG(LHEIGH,11) + SECPAR(1) * WEIGHT #else DLONG(LHEIGH,11) = DLONG(LHEIGH,11) + SECPAR(1) #endif ENDIF #if __AUGERHIST__ THICKLOC = THICK( H ) DO LL = 1, NOBSLV IF ( THICKLOC .GE. THCKOB(LL) .AND. * THICKLOC .LT. THCKOB(LL)+SAMPTH ) THEN C THICKH IS WITHIN 1 G/CM^2 BELOW OBSLEV(LL) C BRING THE ENERGY BELOW ANGULAR CUT TO THE HISTO OF LEVEL LL OUTPAR(0) = 1.D0 OUTPAR(1) = SECPAR(1) OUTPAR(2) = SECPAR(2) OUTPAR(3) = SECPAR(3) OUTPAR(4) = SECPAR(4) DO II = 5, 8 OUTPAR(II) = CURPAR(II) ENDDO OUTPAR( 9) = GEN OUTPAR(10) = ALEVEL OUTPAR(13) = WEIGHT EDEP = OUTPAR(1) * WEIGHT C WE HAVE ANGULAR CUT CALL AUGERDEPFIL( EDEP,LL,1 ) ELSEIF ( THICKLOC .LT. THCKOB(LL) ) THEN GOTO 111 ENDIF ENDDO 111 CONTINUE #endif ENDIF C SECOND GAMMA (WITH LOWER ENERGY) SECPAR(1) = AUX2 * EETA2 CALL ADDANG3( COSTHE,PHIX,PHIY, COSTH2,FI1+PI, * SECPAR(2),SECPAR(3),SECPAR(4) ) #if __UPWARD__ IF ( SECPAR(2) .GE. -1.D0 ) THEN #else IF ( SECPAR(2) .GT. C(29) ) THEN #endif #if __INTTEST__ SECPAR(17) = SECPAR(1) * * SQRT( (1.D0-SECPAR(2))*(1.D0+SECPAR(2)) ) #endif CALL TSTACK ELSE IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT #if __THIN__ DLONG(LHEIGH,11) = DLONG(LHEIGH,11) + SECPAR(1) * WEIGHT #else DLONG(LHEIGH,11) = DLONG(LHEIGH,11) + SECPAR(1) #endif ENDIF #if __AUGERHIST__ THICKLOC = THICK( H ) DO LL = 1, NOBSLV IF ( THICKLOC .GE. THCKOB(LL) .AND. * THICKLOC .LT. THCKOB(LL)+SAMPTH ) THEN C THICKH IS WITHIN 1 G/CM^2 BELOW OBSLEV(LL) C BRING THE ENERGY BELOW ANGULAR CUT TO THE HISTO OF LEVEL LL OUTPAR(0) = 1.D0 OUTPAR(1) = SECPAR(1) OUTPAR(2) = SECPAR(2) OUTPAR(3) = SECPAR(3) OUTPAR(4) = SECPAR(4) DO II = 5, 8 OUTPAR(II) = CURPAR(II) ENDDO OUTPAR( 9) = GEN OUTPAR(10) = ALEVEL OUTPAR(13) = WEIGHT EDEP = OUTPAR(1) * WEIGHT C WE HAVE ANGULAR CUT CALL AUGERDEPFIL( EDEP,LL,1 ) ELSEIF ( THICKLOC .LT. THCKOB(LL) ) THEN GOTO 112 ENDIF ENDDO 112 CONTINUE #endif ENDIF C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C DECAY ETA ----> PI(0) + PI(0) + PI(0) ELSEIF ( ITYPE .EQ. 72 ) THEN CALL DECAY6( PAMA(17), PAMA(7),PAMA(7),PAMA(7), * 0.D0,0.D0,0.D0, 1.D0, 2 ) SECPAR(0) = 7.D0 DO I = 1, 3 CALL ADDANG3( COSTHE,PHIX,PHIY, COS345(I),PHI345(I), * SECPAR(2),SECPAR(3),SECPAR(4) ) #if __UPWARD__ IF ( SECPAR(2) .GE. -1.D0 ) THEN #else IF ( SECPAR(2) .GT. C(29) ) THEN #endif SECPAR(1) = GAM345(I) #if __INTTEST__ SECPAR(17) = SQRT( (SECPAR(1)-1.D0)*(SECPAR(1)+1.D0) * * (1.D0-SECPAR(2))*(1.D0+SECPAR(2)) )*PAMA(7) #endif CALL TSTACK ELSE IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT #if __THIN__ DLONG(LHEIGH,17) = DLONG(LHEIGH,17) * + GAM345(I)*PAMA(7) * WEIGHT #else DLONG(LHEIGH,17) = DLONG(LHEIGH,17) + GAM345(I) * PAMA(7) #endif ENDIF #if __AUGERHIST__ THICKLOC = THICK( H ) DO LL = 1, NOBSLV IF ( THICKLOC .GE. THCKOB(LL) .AND. * THICKLOC .LT. THCKOB(LL)+SAMPTH ) THEN C THICKH IS WITHIN 1 G/CM^2 BELOW OBSLEV(LL) C BRING THE ENERGY BELOW ANGULAR CUT TO THE HISTO OF LEVEL LL OUTPAR(0) = 7.D0 OUTPAR(1) = GAM345(I) OUTPAR(2) = SECPAR(2) OUTPAR(3) = SECPAR(3) OUTPAR(4) = SECPAR(4) DO II = 5, 8 OUTPAR(II) = CURPAR(II) ENDDO OUTPAR( 9) = GEN OUTPAR(10) = ALEVEL OUTPAR(13) = WEIGHT EDEP = OUTPAR(1) * PAMA(7) * WEIGHT C WE HAVE ANGULAR CUT CALL AUGERDEPFIL( EDEP,LL,1 ) ELSEIF ( THICKLOC .LT. THCKOB(LL) ) THEN GOTO 113 ENDIF ENDDO 113 CONTINUE #endif ENDIF ENDDO C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C DECAY ETA ----> PI(-) + PI(+) + PI(0) ELSEIF ( ITYPE .EQ. 73 ) THEN CALL DECAY6( PAMA(17), PAMA(8),PAMA(8),PAMA(7), * CETA(4),0.D0,0.D0, CETA(5), 2 ) DO I = 1, 3 CALL ADDANG3( COSTHE,PHIX,PHIY, COS345(I),PHI345(I), * SECPAR(2),SECPAR(3),SECPAR(4) ) #if __UPWARD__ IF ( SECPAR(2) .GE. -1.D0 ) THEN #else IF ( SECPAR(2) .GT. C(29) ) THEN #endif SECPAR(0) = 10 - I SECPAR(1) = GAM345(I) #if __INTTEST__ SECPAR(17) = SQRT( (SECPAR(1)-1.D0)*(SECPAR(1)+1.D0) * * (1.D0-SECPAR(2))*(1.D0+SECPAR(2)) )*PAMA(10-I) #endif CALL TSTACK ELSE IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT IF ( 10-I .EQ. 8 .OR. 10-I .EQ. 9 ) THEN FAC1 = 0.25D0 FAC2 = 0.75D0 ELSE FAC1 = 1.D0 FAC2 = 0.D0 ENDIF #if __THIN__ DLONG(LHEIGH,17) = DLONG(LHEIGH,17) * + GAM345(I)*PAMA(10-I) * WEIGHT* FAC1 DLONG(LHEIGH,18) = DLONG(LHEIGH,18) * + GAM345(I)*PAMA(10-I) * WEIGHT* FAC2 #else DLONG(LHEIGH,17) = DLONG(LHEIGH,17) * + GAM345(I)*PAMA(10-I) * FAC1 DLONG(LHEIGH,18) = DLONG(LHEIGH,18) * + GAM345(I)*PAMA(10-I) * FAC2 #endif ENDIF #if __AUGERHIST__ THICKLOC = THICK( H ) DO LL = 1, NOBSLV IF ( THICKLOC .GE. THCKOB(LL) .AND. * THICKLOC .LT. THCKOB(LL)+SAMPTH ) THEN C THICKH IS WITHIN 1 G/CM^2 BELOW OBSLEV(LL) C BRING THE ENERGY BELOW ANGULAR CUT TO THE HISTO OF LEVEL LL OUTPAR(0) = 10 - I OUTPAR(1) = GAM345(I) OUTPAR(2) = SECPAR(2) OUTPAR(3) = SECPAR(3) OUTPAR(4) = SECPAR(4) DO II = 5, 8 OUTPAR(II) = CURPAR(II) ENDDO OUTPAR( 9) = GEN OUTPAR(10) = ALEVEL OUTPAR(13) = WEIGHT EDEP = OUTPAR(1) * PAMA(10-I) * WEIGHT C WE HAVE ANGULAR CUT CALL AUGERDEPFIL( EDEP,LL,1 ) ELSEIF ( THICKLOC .LT. THCKOB(LL) ) THEN GOTO 114 ENDIF ENDDO 114 CONTINUE #endif ENDIF ENDDO C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C DECAY ETA ----> PI(+) + PI(-) + GAMMA ELSEIF ( ITYPE .EQ. 74 ) THEN CALL DECAY6( PAMA(17), PAMA(8),PAMA(8),0.D0, * 0.D0,0.D0,0.D0, 1.D0, 2 ) DO I = 1, 3 CALL ADDANG3( COSTHE,PHIX,PHIY, COS345(I),PHI345(I), * SECPAR(2),SECPAR(3),SECPAR(4) ) #if __UPWARD__ IF ( SECPAR(2) .GE. -1.D0 ) THEN #else IF ( SECPAR(2) .GT. C(29) ) THEN #endif IF ( I .EQ. 3 ) THEN SECPAR(0) = 1.D0 ELSE SECPAR(0) = 7 + I ENDIF SECPAR(1) = GAM345(I) #if __INTTEST__ IF ( I .LT. 3 ) THEN SECPAR(17) = SQRT( (SECPAR(1)-1.D0)*(SECPAR(1)+1.D0) * * (1.D0-SECPAR(2))*(1.D0+SECPAR(2)) )*PAMA(8) ELSE SECPAR(17) = SECPAR(1) * * SQRT( (1.D0-SECPAR(2))*(1.D0+SECPAR(2)) ) ENDIF #endif CALL TSTACK ELSE IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT IF ( I .EQ. 3 ) THEN #if __THIN__ DLONG(LHEIGH,11) = DLONG(LHEIGH,11) + GAM345(I)*WEIGHT #else DLONG(LHEIGH,11) = DLONG(LHEIGH,11) + GAM345(I) #endif ELSE FAC1 = 0.25D0 FAC2 = 0.75D0 #if __THIN__ DLONG(LHEIGH,17) = DLONG(LHEIGH,17) * + GAM345(I)*PAMA(8)*WEIGHT*FAC1 DLONG(LHEIGH,18) = DLONG(LHEIGH,18) * + GAM345(I)*PAMA(8)*WEIGHT*FAC2 #else DLONG(LHEIGH,17) = DLONG(LHEIGH,17) * + GAM345(I)*PAMA(8)*FAC1 DLONG(LHEIGH,18) = DLONG(LHEIGH,18) * + GAM345(I)*PAMA(8)*FAC2 #endif ENDIF ENDIF #if __AUGERHIST__ THICKLOC = THICK( H ) DO LL = 1, NOBSLV IF ( THICKLOC .GE. THCKOB(LL) .AND. * THICKLOC .LT. THCKOB(LL)+SAMPTH ) THEN C THICKH IS WITHIN 1 G/CM^2 BELOW OBSLEV(LL) C BRING THE ENERGY BELOW ANGULAR CUT TO THE HISTO OF LEVEL LL OUTPAR(1) = GAM345(I) IF ( I .EQ. 3 ) THEN OUTPAR(0) = 1.D0 EDEP = OUTPAR(1) * WEIGHT ELSE OUTPAR(0) = 7 + I EDEP = OUTPAR(1) * PAMA(8) * WEIGHT ENDIF OUTPAR(2) = SECPAR(2) OUTPAR(3) = SECPAR(3) OUTPAR(4) = SECPAR(4) DO II = 5, 8 OUTPAR(II) = CURPAR(II) ENDDO OUTPAR( 9) = GEN OUTPAR(10) = ALEVEL OUTPAR(13) = WEIGHT C WE HAVE ANGULAR CUT CALL AUGERDEPFIL( EDEP,LL,1 ) ELSEIF ( THICKLOC .LT. THCKOB(LL) ) THEN GOTO 115 ENDIF ENDDO 115 CONTINUE #endif ENDIF ENDDO ELSE WRITE(MONIOU,*) 'ETADEC: UNEXPECTED PARTICLE CODE ITYPE=',ITYPE ENDIF RETURN C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C RARE DECAY ETA ----> MU(+) + MU(-) + GAMMA C DECAY ADDED IN NOV. 2014, SEE A. FEDYNITCH ET AL., arXiv: 1206.6710 201 CALL DECAY6( PAMA(17), PAMA(5),PAMA(5),0.D0, * 0.D0,0.D0,0.D0, 1.D0, 2 ) C SET POLARIZATION CALL RMMARD( RD, 2, 1 ) POLART = 2.D0 * RD(1) - 1.D0 POLARF = PI2 * RD(2) DO I = 1, 3 CALL ADDANG3( COSTHE,PHIX,PHIY, COS345(I),PHI345(I), * SECPAR(2),SECPAR(3),SECPAR(4) ) #if __UPWARD__ IF ( SECPAR(2) .GE. -1.D0 ) THEN #else IF ( SECPAR(2) .GT. C(29) ) THEN #endif SECPAR(1) = GAM345(I) C SET POLARIZATION IF ( I .EQ. 1 ) THEN ! MU(+) SECPAR(0) = 5.D0 SECPAR(11) = POLART SECPAR(12) = POLARF ELSEIF (I .EQ. 2 ) THEN ! MU(-) SECPAR(0) = 6.D0 SECPAR(11) = -POLART SECPAR(12) = POLARF + PI ELSE ! GAMMA SECPAR(0) = 1.D0 SECPAR(11) = 0.D0 SECPAR(12) = 0.D0 ENDIF #if __INTTEST__ IF ( I .LT. 3 ) THEN SECPAR(17) = SQRT( (SECPAR(1)-1.D0)*(SECPAR(1)+1.D0) * * (1.D0-SECPAR(2))*(1.D0+SECPAR(2)) )*PAMA(5) ELSE SECPAR(17) = SECPAR(1) * * SQRT( (1.D0-SECPAR(2))*(1.D0+SECPAR(2)) ) ENDIF #endif CALL TSTACK ELSE IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT IF ( I .EQ. 3 ) THEN #if __THIN__ DLONG(LHEIGH,11) = DLONG(LHEIGH,11) + GAM345(I)*WEIGHT #else DLONG(LHEIGH,11) = DLONG(LHEIGH,11) + GAM345(I) #endif ELSE C ADD MUON ENERGY TO LONGITUDINAL ENERGY DEPOSIT #if __THIN__ DLONG(LHEIGH,15) = DLONG(LHEIGH,15) * + GAM345(I)*PAMA(5)*WEIGHT #else DLONG(LHEIGH,15) = DLONG(LHEIGH,15) + GAM345(I)*PAMA(5) #endif ENDIF ENDIF #if __AUGERHIST__ THICKLOC = THICK( H ) DO LL = 1, NOBSLV IF ( THICKLOC .GE. THCKOB(LL) .AND. * THICKLOC .LT. THCKOB(LL)+SAMPTH ) THEN C THICKH IS WITHIN 1 G/CM^2 BELOW OBSLEV(LL) C BRING THE ENERGY BELOW ANGULAR CUT TO THE HISTO OF LEVEL LL OUTPAR(1) = GAM345(I) IF ( I .EQ. 3 ) THEN OUTPAR(0) = 1.D0 EDEP = OUTPAR(1) * WEIGHT ELSE OUTPAR(0) = 4 + I EDEP = OUTPAR(1) * PAMA(5) * WEIGHT ENDIF OUTPAR(2) = SECPAR(2) OUTPAR(3) = SECPAR(3) OUTPAR(4) = SECPAR(4) DO II = 5, 8 OUTPAR(II) = CURPAR(II) ENDDO OUTPAR( 9) = GEN OUTPAR(10) = ALEVEL OUTPAR(13) = WEIGHT C WE HAVE ANGULAR CUT CALL AUGERDEPFIL( EDEP,LL,1 ) ELSEIF ( THICKLOC .LT. THCKOB(LL) ) THEN GOTO 116 ENDIF ENDDO 116 CONTINUE #endif ENDIF ENDDO cdh Sept 2015 here the rare decay may be added c eta ---> mu(+) + mu(-) (BR = 5.8E(-6)) C RESET POLARIZATION SECPAR(11) = 0.D0 SECPAR(12) = 0.D0 RETURN END *-- Author : D. HECK IK FZK KARLSRUHE 24/06/2003 C======================================================================= SUBROUTINE FILOPN C----------------------------------------------------------------------- C FIL(E) OP(E)N C C OPENS THE FILES NEEDED FOR OUTPUT. C THIS SUBROUTINE IS CALLED FROM START. C----------------------------------------------------------------------- #if __FLUKA__ IMPLICIT DOUBLE PRECISION (A-H,O-Z) #if __LINUX__ INCLUDE '(IOUNIT)' #else INCLUDE 'IOUNIT' #endif #else IMPLICIT NONE #endif #define __BUFFSINC__ #define __LONGIINC__ #define __RUNPARINC__ #define __STACKFINC__ #define __TABLESINC__ #if __CERENKOV__ || __AUGERHIST__ || __AUGCERLONG__ #define __CEREN1INC__ #define __CERTELINC__ #define __CEREN3INC__ #endif #if __CONEX__ #define __CONEXINC__ #endif #if __PARALLEL__ #define __RANDPAINC__ #endif #include "corsika.h" #if __CERENKOV__ integer cerdone(0:nmaxcertel) integer icertel #endif INTEGER IBL,L CHARACTER*8 RQSTAT CHARACTER*255 DSN0 #if __UNIX__ LOGICAL FEXIST,LDEVNL #endif #if __CONEX__ CHARACTER*80 FILENAME integer ifname #endif #if __COAST__ INTEGER COASTTHN,COASTCRV,COASTSNT,COASTSTK,COASTPRE #endif SAVE C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'FILOPN:' C CHECK CORRECTNESS OF RUN NUMBER IF ( NRRUN .GT. 999999 ) THEN WRITE(MONIOU,*) 'RUN NUMBER = ',NRRUN,' EXCEEDS 999999, STOP' STOP ENDIF #if __STACKIN__ C OPEN INPUT DATA SET FOR READING IN SECONDARY PARTICLES TO STACK OPEN(UNIT=LSTCK,FILE=FILINP,STATUS='OLD',FORM='FORMATTED') WRITE(MONIOU,5794) FILINP 5794 FORMAT(/,' PARTICLE INPUT FROM FILE: ',A) #elif !__CONEX__ #if __PARALLEL__ IF ( FPRIM ) THEN #endif C OPEN OUTPUT DATA SET FOR WRITING IN SECONDARY PARTICLES OF FIRST INTERACTION IF ( FOUTFILE ) THEN INQUIRE(FILE=FILOUT,EXIST=FEXIST) IF ( FEXIST ) THEN IBL = INDEX(FILOUT,' ') IF ( IBL .LE. 1 ) IBL = LEN(FILOUT)+1 WRITE(MONIOU,5790) FILOUT(1:IBL-1) 5790 FORMAT(/' FILE ',A,' ALREADY EXISTS. RENAME OR REMOVE IT', * ' OR CHANGE ''OUTFILE'' DATA CARD AND TRY AGAIN.') STOP 'FILOPN: FATAL PROBLEM OPENING FILE' ENDIF OPEN(UNIT=LSTCK,FILE=FILOUT,STATUS='UNKNOWN',FORM='FORMATTED') OPEN(UNIT=LSTCK2,STATUS='SCRATCH',FORM='FORMATTED') ENDIF #if __PARALLEL__ ENDIF #endif #endif C OUTPUT FILES SHOULD NORMALLY NOT EXIST BEFORE THE RUN STARTS #if __PARALLEL__ RQSTAT = 'UNKNOWN' #else RQSTAT = 'NEW' #endif C LOOK FOR THE FIRST BLANK IN DATASET NAME IBL = INDEX(DSN,' ') C CHECK MAXIMUM LENGTH OF DATA FILE NAMES (ALL TOGETHER < 255) #if __PARALLEL__ IF ( IBL .GE. 221 ) THEN #else IF ( IBL .GE. 234 ) THEN #endif WRITE(MONIOU,*) WRITE(MONIOU,*) 'DATASET NAME TOO LONG' WRITE(MONIOU,*) DSN(1:IBL) WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORD: DIRECT' STOP ENDIF C CHECK DATA SET NAME FOR CORRECTNESS IF ( DSN(1:) .EQ. '~' ) THEN WRITE(MONIOU,*) WRITE(MONIOU,*) 'FILOPN: INCORRECT DATA SET NAME' WRITE(MONIOU,*) DSN(1:IBL) WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORD: DIRECT' STOP ENDIF IF ( DSN(1:9) .EQ. '/dev/null' ) THEN WRITE(MONIOU,*) WRITE(MONIOU,*) 'FILOPN: INCORRECT DATA SET NAME' WRITE(MONIOU,*) DSN(1:IBL) WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORD: DIRECT' WRITE(MONIOU,*) 'IF YOU DO NOT WANT PARTICLE OUTPUT FILE' WRITE(MONIOU,*) 'PLEASE USE: PAROUT F F' STOP ENDIF DSN0 = DSN C OPEN OUTPUT DATA SET FOR RUN DSN(IBL:IBL+8) = 'DAT000000' WRITE(DSN(IBL+3:IBL+8),'(I6.6)') NRRUN #if __PARALLEL__ C UPDATE DAT FILE NAME TO BE UNIQUE DSN(IBL+9:249) = '-' WRITE(DSN(IBL+10:IBL+18),'(I9.9)') ISEED(1,6) DSN(IBL+19:255) = '-' WRITE(DSN(IBL+20:IBL+28),'(I9.9)') MPIID C OPEN FILE FOR ECUT PARTICLES (NAME ALWAYS DEFINED) AND JOB LIST DSNCUT = DSN DSNCUT(IBL+29:IBL+33) = '.cut ' DSNJOB = DSN DSNJOB(IBL+29:IBL+33) = '.job ' IF ( .NOT. FECTOUT ) THEN DSNCUT(1:5) = 'NONE ' ENDIF IF ( FLONGOUT .AND. LLONGI ) THEN DSNLONG = DSN DSNLONG(IBL+29:IBL+33) = '.long' ENDIF IF ( FTABOUT ) THEN DSNTAB = DSN DSNTAB(IBL+29:IBL+32) = '.tab' ENDIF #else IF ( FTABOUT ) THEN DSNTAB = DSN DSNTAB(IBL+9:IBL+12) = '.tab' ENDIF IF ( FLONGOUT .AND. LLONGI ) THEN DSNLONG = DSN DSNLONG(IBL+9:IBL+13) = '.long' ENDIF #endif #if __ANAHIST__ || __AUGERHIST__ || __MUONHIST__ DSNHST = DSN C USE LOWER CASE CHARACTERS FOR USAGE WITH HBOOK ROUTINES DSNHST(IBL:IBL+2) = 'dat' DSNHST(IBL+9:IBL+15) = '.lhbook' #endif #if __UNIX__ #if __PARALLEL__ IF ( FPRIM ) THEN #endif C ON LINUX WITH G77 AN EXISTING FILE CAUSES A CORE DUMP -> FIRST INQUIRE #if __PARALLELIB__ INQUIRE(FILE=DSN(1:IBL+8)//'-000001',EXIST=FEXIST) !FILE NAME INCLUDE NODE NUMBER #else INQUIRE(FILE=DSN,EXIST=FEXIST) #endif IF ( FEXIST ) THEN IBL = INDEX(DSN,' ') IF ( IBL .LE. 1 ) IBL = LEN(DSN)+1 #if __PARALLELIB__ WRITE(MONIOU,5791) DSN(1:IBL-21)//'-000001' #else WRITE(MONIOU,5791) DSN(1:IBL-1) #endif STOP 'FILOPN: FATAL PROBLEM OPENING FILE' ENDIF #if __PARALLEL__ ENDIF #endif #endif 5791 FORMAT(/,' FILE ',A,' ALREADY EXISTS. RENAME OR REMOVE IT', * ' OR CHANGE ''DIRECT'' DATA CARD AND TRY AGAIN.') #if __COAST__ || __COASTUSERLIB__ C INITIALIZE COAST #if __THIN__ coastthn = 1 #else coastthn = 0 #endif #if __CURVED__ coastcrv = 1 #else coastcrv = 0 #endif #if __SLANT__ coastsnt = 1 #else coastsnt = 0 #endif #if __STACKIN__ coaststk = 1 #else coaststk = 0 #endif #if __PRESHOWER__ coastpre = 1 #else coastpre = 0 #endif #if !__COASTUSERLIB__ IF ( FPAROUT ) THEN #endif call inida( DSN, coastthn, coastcrv, coastsnt, coaststk, coastpre) #if !__COASTUSERLIB__ endif #endif #endif /* __COAST__ || __COASTUSERLIB__ */ #if !__COAST__ || __COASTUSERLIB__ C OPEN DATASET FOR PARTICLE OUTPUT IF ( FPAROUT ) THEN #if __COMPACT__ OPEN(UNIT=MPATAP,FILE=DSN,STATUS=RQSTAT, * FORM='UNFORMATTED',ACCESS='SEQUENTIAL') #else #if __PARALLEL__ #if !__PARALLELIB__ CALL fopenmpatap( DSN , IBL+28 ) #endif #else #if __ICECUBE2__ CALL fopenmpatap( DSN , IBL+8, gzip_output, pipe_output ) #else CALL fopenmpatap( DSN , IBL+8 ) #endif #endif #endif WRITE(MONIOU,579) DSN 579 FORMAT(/,' PARTICLE OUTPUT TO FILE: ',A) #if __COMPACT__ IF ( COMOUT ) WRITE(MONIOU,*)' IN COMPACT FORMAT' #endif ENDIF #endif #if __PARALLEL__ C PRINT OUT NAME OF ECUT FILE C ECUT WILL BE OPEN LATER IN TSTEND WRITE(MONIOU,5792) ECTCUT,ECTMAX 5792 FORMAT(/,10X,'ECUTMIN',1P,E12.3,10X,'ECUTMAX',E12.3) #if !__PARALLELIB__ IF ( FECTOUT ) THEN WRITE(MONIOU,5793) DSNJOB 5793 FORMAT(/,' LIST OF JOBS FROM ECUT TO FILE :',A) ENDIF #endif #endif #if __FLUKA__ C HANDLE DATA SETS FOR FLUKA ERRORS AND FLUKA DEBUG DSNFLOUT = DSN DSNFLERR = DSN #if __PARALLEL__ DSNFLOUT(IBL+29:IBL+34) = '.flout' DSNFLERR(IBL+29:IBL+34) = '.flerr' #else DSNFLOUT(IBL+9:IBL+14) = '.flout' DSNFLERR(IBL+9:IBL+14) = '.flerr' #endif C PRINT UNIT 11 AND UNIT 15 FLUKA FILES ONLY IN CASE OF DEBUG MODE C /dev/null CAN NOT BE USED FOR PARALLELIB BECAUSE IT IS ALREADY USED FOR C THE LST FILE IF ( .NOT. FFLUDB ) THEN DSNFLERR(1:16) = '/dev/null ' OPEN(UNIT=LUNERR,FORM='FORMATTED',STATUS='SCRATCH') c#if __LINUX__ && !__PARALLELIB__ cC A SECOND OPEN TO A FILE WHICH IS ALREADY CONNECTED (IN THIS CASE cC /dev/null) IS NOT ALLOWED WITH LINUX, ENDING IN AN cC ERROR AT RUN TIME. SO USE /dev/null ONLY FOR THE LARGEST ERROR FILE cC FROM FLUKA (FLERR) c OPEN(UNIT=LUNOUT,FORM='FORMATTED',STATUS='UNKNOWN', c * FILE=DSNFLOUT) c ELSE c#else DSNFLOUT(1:16) = '/dev/null ' OPEN(UNIT=LUNOUT,FORM='FORMATTED',STATUS='SCRATCH') ELSE c#endif OPEN(UNIT=LUNOUT,FORM='FORMATTED',STATUS='UNKNOWN', * FILE=DSNFLOUT) OPEN(UNIT=LUNERR,FORM='FORMATTED',STATUS='UNKNOWN', * FILE=DSNFLERR) ENDIF #endif C OPEN DATASET FOR TABLE OUTPUT IF ( FTABOUT ) THEN #if __UNIX__ C ON LINUX WITH G77 AN EXISTING FILE CAUSES A CORE DUMP -> FIRST INQUIRE #if __PARALLEL__ IF ( FPRIM ) THEN #endif INQUIRE(FILE=DSNTAB,EXIST=FEXIST) IF ( FEXIST ) THEN IBL = INDEX(DSNTAB,' ') IF ( IBL .LE. 1 ) IBL = LEN(DSNTAB)+1 WRITE(MONIOU,5791) DSNTAB(1:IBL-1) STOP 'FILOPN: FATAL PROBLEM OPENING FILE' ENDIF #if __PARALLEL__ ENDIF #endif #endif OPEN(UNIT=MTABOUT,FILE=DSNTAB,STATUS=RQSTAT, * FORM='UNFORMATTED',ACCESS='SEQUENTIAL') WRITE(MONIOU,578) DSNTAB, * IEBIN,EBMIN,EBMAX, * ITBIN,TBMIN,TBMAX, * IDBIN,DBMIN,DBMAX 578 FORMAT(/,' TABLE OUTPUT TO FILE : ',A,/, * ' ENERGY : ',I2,' BINS, RANGE :',1P,2E10.2,' GEV',/, * ' TIME : ',I2,' BINS, RANGE :',1P,2E10.2,' NS',/, * ' RADIUS : ',I2,' BINS, RANGE :',1P,2E10.2,' CM') WRITE(MTABOUT) IEBIN,EBMIN,EBMAX WRITE(MTABOUT) ITBIN,TBMIN,TBMAX WRITE(MTABOUT) IDBIN,DBMIN,DBMAX EBOFF = LOG10(EBMIN) EBFAC = 1./(LOG10(EBMAX/EBMIN)/IEBIN) TBOFF = LOG10(TBMIN) TBFAC = 1./(LOG10(TBMAX/TBMIN)/ITBIN) DBOFF = LOG10(DBMIN) DBFAC = 1./(LOG10(DBMAX/DBMIN)/IDBIN) ENDIF C OPEN DATA SET FOR LONGITUDINAL DISTRIBUTION IF ( FLONGOUT .AND. LLONGI ) THEN #if __UNIX__ #if __PARALLEL__ IF ( FPRIM ) THEN #endif C ON LINUX WITH G77 AN EXISTING FILE CAUSES A CORE DUMP -> FIRST INQUIRE INQUIRE(FILE=DSNLONG,EXIST=FEXIST) IF ( FEXIST ) THEN IBL = INDEX(DSNLONG,' ') IF ( IBL .LE. 1 ) IBL = LEN(DSNLONG)+1 WRITE(MONIOU,5791) DSNLONG(1:IBL-1) STOP 'FILOPN: FATAL PROBLEM OPENING FILE' ENDIF #if __PARALLEL__ ENDIF #endif #endif #if !__PARALLELIB__ OPEN(UNIT=MLONGOUT,FILE=DSNLONG,STATUS=RQSTAT, * FORM='FORMATTED',ACCESS='SEQUENTIAL') #endif WRITE(MONIOU,5781) DSNLONG 5781 FORMAT(/,' LONGITUDINAL OUTPUT TO FILE: ',A) ENDIF #if __PLOTSH__ C OPEN DATA SETS FOR PLOTSH OUTPUT IF ( PLOTSH ) THEN CPLOT = DSN WRITE(MONIOU,3466)CPLOT(IBL:IBL+8),CPLOT(IBL:IBL+8) * ,CPLOT(IBL:IBL+8) 3466 FORMAT(/,' ATTENTION : PLOTSH OPTION HAS BEEN SELECTED',/, * ' TRACK SEGMENTS FOR EACH PARTICLE ARE STORED ON',/, * ' ',a9,'.track_em',/, * ' ',a9,'.track_mu AND',/, * ' ',a9,'.track_hd',/, * ' NEEDS LOTS OF DISK SPACE !!!',/, * ' CALCULATE NOT MORE THAN 1 EVENT AT A TIME !',/) CPLOT(IBL+9:IBL+18) = '.track_em' OPEN(UNIT=55,FILE=CPLOT,FORM='UNFORMATTED',STATUS='UNKNOWN') CPLOT(IBL+9:IBL+18) = '.track_mu' OPEN(UNIT=56,FILE=CPLOT,FORM='UNFORMATTED',STATUS='UNKNOWN') CPLOT(IBL+9:IBL+18) = '.track_hd' OPEN(UNIT=57,FILE=CPLOT,FORM='UNFORMATTED',STATUS='UNKNOWN') NPLEM = 0 NPLMU = 0 NPLHAD = 0 ENDIF #endif #if __PLOTSH2__ C OPEN DATA SETS FOR PLOTSH2 OUTPUT IF ( PLOTSH ) THEN CPLOT2 = DSN WRITE(MONIOU,*) 'FILOPN: CPLOT2=',CPLOT2(1:IBL+8) ENDIF #endif #if __CERENKOV__ C OPEN OUTPUT DATA SET FOR CHERENKOV PHOTONS, IF CER OUTPUT SELECTED IF ( MCERFI .NE. 0 ) THEN do icertel = 0, nmaxcertel cerbuf(icertel) = -1 ! reset cerdone(icertel) = -1 ! reset enddo ncerbuf = 0 c need "+1" in loop to make sure at least one CER file is produced do icertel = 1, ncertel+1 C SET CORRECT DATA SET NAME AND LENGTH DSN = DSN0 C LOOK FOR THE FIRST BLANK IN DATASET NAME IBL = INDEX(DSN,' ') if (MCERFI.ge.3) then DSN(IBL:IBL+13) = 'DAT000000.cher' WRITE(DSN(IBL+3:IBL+8),'(I6.6)') NRRUN IBL=IBL+14 else DSN(IBL:IBL+8) = 'CER000000' WRITE(DSN(IBL+3:IBL+8),'(I6.6)') NRRUN IBL=IBL+9 endif if ( icertel .lt. ncertel+1 ) then ! check for last iteration if ( certelid(icertel) .gt. 0 ) then DSN(IBL:IBL+6) = '-tel000' write(DSN(IBL+4:IBL+6),'(I3.3)') certelid(icertel) IBL=IBL+7 endif if ( cerdone(certelid(icertel)) .ge. 0 ) then c this telescope output buffer already exists. don''t need to create. goto 111 endif c we need to a new output buffer for this icertel ncerbuf = ncerbuf+1 cerbuf(certelid(icertel)) = ncerbuf cerdone(certelid(icertel)) = 1 else if ( ncerbuf .eq. 0 ) then c if we arrive here, we have not yet created any CER output file, but now c is the last chance ncerbuf = 1 cerbuf(0) = ncerbuf cerdone(0) = 1 certelid(icertel) = 0 else goto 111 ! nothing more to be done endif endif #if __PARALLEL__ C UPDATE DAT FILE NAME TO BE UNIQUE DSN(IBL:255) = '-' WRITE(DSN(IBL+1:IBL+9),'(I9.9)') ISEED(1,6) DSN(IBL+10:255) = '-' WRITE(DSN(IBL+11:IBL+19),'(I9.8)') MPIID #endif #if __UNIX__ #if __PARALLEL__ IF ( FPRIM ) THEN #endif C ON LINUX WITH G77 AN EXISTING FILE CAUSES A CORE DUMP -> FIRST INQUIRE #if __PARALLELIB__ C FILE NAME INCUDES NODE NUMBER INQUIRE(FILE=DSN(1:IBL+19)//'-000001',EXIST=FEXIST) #else INQUIRE(FILE=DSN,EXIST=FEXIST) #endif IF ( FEXIST ) THEN IBL = INDEX(DSN,' ') IF ( IBL .LE. 1 ) IBL = LEN(DSN)+1 #if __PARALLELIB__ WRITE(MONIOU,5791) DSN(1:IBL-21)//'-000001' #else WRITE(MONIOU,5791) DSN(1:IBL-1) #endif STOP 'FILOPN: FATAL PROBLEM OPENING FILE' ENDIF #if __PARALLEL__ ENDIF #endif #endif c OPEN(UNIT=MCETAP,FILE=DSN,STATUS=RQSTAT, c * FORM='UNFORMATTED',ACCESS='SEQUENTIAL') #if __PARALLEL__ #if !__PARALLELIB__ CALL FOPENMCETAP( DSN , IBL+19, ncerbuf ) #endif #else CALL FOPENMCETAP( DSN , IBL-1, ncerbuf ) #endif WRITE(MONIOU,580) DSN 580 FORMAT(/,' CHERENKOV OUTPUT TO FILE: ',A) 111 CONTINUE enddo ELSE WRITE(MONIOU,580) DSN ENDIF #endif C RESET DSN EXTENSIONS DSN(IBL:255) = ' ' C CHECK THE EXTERNAL STACK FORMAT C BLOCKS OF 32448 BYTES = 4056 REAL*8 = 312 PARTICLES FOR THINNING C BLOCKS OF 32640 BYTES = 4080 REAL*8 = 340 PARTICLES FOR STANDARD #if __BYTERECL__ C FOR MOST FORTRAN COMPILERS ON UNIX-LIKE SYSTEMS (GNU g77, HP, C IBM RS6000) IT IS NECESSARY TO USE THE NUMBER OF BYTES FOR THE RECL C PARAMETER. CALL RCLCHK( MEXST,1,L ) IF ( L .NE. 0 ) THEN WRITE(MONIOU,*) 'FILOPN: FATAL ERROR:',L, * ' RECL HANDLING NOT AS EXPECTED' STOP ENDIF #if !__PARALLEL__ OPEN(UNIT=MEXST,STATUS='SCRATCH', * FORM='UNFORMATTED',ACCESS='DIRECT',RECL=4*MAXSTK) #else C STACK FILE WILL BE OPENED ONLY IF NEEDED IN SUBROUTINE FSTACKO #endif #else C FOR DEC UNIX (COMPAQ Tru64) MACHINES WITH f77 COMPILER (UNLESS USING C THE '-assume bytrecl' COMPILER OPTION) AND SOME OTHER MACHINES THE C RECL PARAMETER IS THE NUMBER OF (4-BYTE) WORDS. CALL RCLCHK( MEXST,4,L ) IF ( L .GT. 0 ) THEN WRITE(MONIOU,*) 'FILOPN: FATAL ERROR:',L, * ' RECL HANDLING NOT AS EXPECTED' STOP ENDIF #if !__PARALLEL__ OPEN(UNIT=MEXST,STATUS='SCRATCH', * FORM='UNFORMATTED',ACCESS='DIRECT',RECL=MAXSTK) #else C STACK FILE WILL BE OPENED ONLY IF NEEDED IN SUBROUTINE FSTACKO #endif #endif C----------------------------------------------------------------------- #if __UNIX__ C WRITE DATA SET FOR INFORMATION BANK IF ( FDBASE ) THEN DSN = DSN0 C OPEN OUTPUT DATA SET FOR RUN IBL = INDEX(DSN,' ') C IF NORMAL OUTPUT DISABLED BUT 'DATBAS T', TRY CURRENT DIRECTORY. LDEVNL = .FALSE. #if __AUGERINFO__ DSN(IBL:IBL+13) = 'DAT000000.info' #else DSN(IBL:IBL+14) = 'DAT000000.dbase' #endif WRITE(DSN(IBL+3:IBL+8),'(I6.6)') NRRUN #if __PARALLEL__ IF ( FPRIM ) THEN #endif C ON LINUX WITH G77 AN EXISTING FILE CAUSES A CORE DUMP -> FIRST INQUIRE INQUIRE(FILE=DSN,EXIST=FEXIST) IF ( FEXIST ) THEN IBL = INDEX(DSN,' ') IF ( IBL .LE. 1 ) IBL = LEN(DSN)+1 WRITE(MONIOU,5791) DSN(1:IBL-1) STOP 'FILOPN: FATAL PROBLEM OPENING FILE' ENDIF #if __PARALLEL__ ENDIF #endif OPEN(UNIT=MDBASE,FILE=DSN,STATUS=RQSTAT) WRITE(MONIOU,581) DSN 581 FORMAT(/,' DBASE OUTPUT TO FILE: ',A) LSTDSN(1:3) = 'LST' LSTDSN(4:9) = DSN(IBL+3:IBL+8) IF ( IBL .EQ. 1 ) DSN = '$cwd' C RESET DSN DSN(IBL+9:IBL+14) = ' ' C THE MDBASE FILE IS CLOSED IN AAMAIN ENDIF #endif #if __INTTEST__ C LOOK FOR THE FIRST BLANK IN HISTOGRAM DATASET NAME IBL = INDEX(HISTDS,' ') C CHECK HISTOGRAM DATA SET NAME FOR CORRECTNESS IF ( HISTDS(1:IBL) .EQ. '~' ) THEN WRITE(MONIOU,*) WRITE(MONIOU,*) 'FILOPN: INCORRECT DATA SET NAME FOR DIRECT' WRITE(MONIOU,*) HISTDS(1:IBL) WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORD: HISTDS' STOP ENDIF #endif #if __CONEX__ C INITIALIZE CONEX #if __QGSJETOLD__ FILENAME = 'conex_qgsjet ' #elif __NEXUS__ FILENAME = 'conex_nexus ' #elif __EPOS__ FILENAME = 'conex_epos ' #elif __SIBYLL__ FILENAME = 'conex_sibyll ' #elif __QGSII__ FILENAME = 'conex_qgsjetII ' #else WRITE(MONIOU,*) 'CONEX OPTION NOT COMPATIBLE WITH CURRENT MODEL' STOP #endif ifname = INDEX(FILENAME,' ') - 1 #if __GHEISHAD__ FILENAME = FILENAME(1:ifname)//'_gheisha.param' #elif __FLUKA__ FILENAME = FILENAME(1:ifname)//'_fluka.param' #elif __URQMD__ FILENAME = FILENAME(1:ifname)//'_urqmd.param' #else WRITE(MONIOU,*) 'CONEX OPTION NOT COMPATIBLE WITH CURRENT MODEL' STOP #endif WRITE(MONIOU,*) 'CONEX IS USED WITH ',FILENAME OUTLUN = MONIOU OPEN(UNIT=INLUN,FILE=FILENAME,STATUS='OLD',ERR=999) #endif RETURN #if __CONEX__ 999 WRITE(MONIOU,*) 'INPUT FILE FOR CONEX NOT FOUND !' STOP #endif END #if __VOLUMECORR__ *-- Author : D. CHIRKIN BERKELEY 09/03/99 C======================================================================= DOUBLE PRECISION FUNCTION FINDTH( X ) C----------------------------------------------------------------------- C FIND TH(ETA) C C FUNCTION TO FIND THETA OF PRIMARY WITH CORRECTION TO GEOMETRY C FOR VERTICAL CYLINDER WITH LONG AXIS AS USED FOR UNDERWATER NEUTRINO C DETECTORS. C TO RANDOMIZE XY COORDINATES OF SHOWER CORES ONE NEEDS TO PROJECT THE C DETECTOR CYLINDER ALONG THE PRIMARY''S TRACK ONTO THE SURFACE. SUCH C PROJECTION HAS AREA (PI*R^2*COS(TH)+L*2R*SIN(TH))/COS(TH) AND C CONSISTS OF TWO HALF-CIRCLES AND A RECTANGLE. C THIS ROUNTINE IS CALLED FROM AAMAIN. C ARGUMENT: C X = RANDOM NUMBER C----------------------------------------------------------------------- IMPLICIT NONE #define __CONSTAINC__ #define __DETCFGINC__ #define __OBSPARINC__ #define __RUNPARINC__ #include "corsika.h" INTEGER MAXSTP PARAMETER (MAXSTP=100) DOUBLE PRECISION ACCURC,COS2X,DF,DELTA,FN,F1,F2,SIN2X, * THETA,TH1,TH2,X,Y INTEGER I SAVE DATA ACCURC / 1.D-10 / C----------------------------------------------------------------------- TH1 = THETPR(1) TH2 = THETPR(2) F1 = COS( TH1*2.D0 ) + DETCFG * (SIN( TH1*2.D0 ) - TH1*2.D0) F2 = COS( TH2*2.D0 ) + DETCFG * (SIN( TH2*2.D0 ) - TH2*2.D0) Y = F1 * (1.D0-X) + F2*X THETA = TH1 * (1.D0-X) + TH2*X C ROOT IS FOUND BY NEWTON''S METHOD, MODIFIED FOR A MONOTOMICALLY C FALLING FUNCTION SO THAT IT DOES NOT FAIL. USUALLY ROOT IS FOUND C WITHIN 5-6 STEPS, BUT SOMETIMES IT TAKES AS MUCH AS 15-16. THOSE C CASES ARE EXTREMELY RARE, HOWEVER, ABOUT ONE IN 1E+5. F1 = F1 - Y F2 = F2 - Y IF ( F1*F2 .GE. 0.D0 ) THEN WRITE(MONIOU,*) WRITE(MONIOU,*) '---***!!!***WARNING***!!!***---' WRITE(MONIOU,*) 'FUNCTION FINDTH FAILED TO FIND ROOT BECAUSE:' WRITE(MONIOU,*) ' ROOT IS NOT BRACKETED' WRITE(MONIOU,*) '---***!!!***WARNING***!!!***---' WRITE(MONIOU,*) GOTO 2 ENDIF DO I = 1, MAXSTP SIN2X = SIN( 2.D0*THETA ) COS2X = COS( 2.D0*THETA ) FN = COS2X + DETCFG * (SIN2X-2.D0*THETA) - Y IF ( FN .EQ. 0.D0 ) THEN GOTO 2 ELSEIF ( F1*FN .LT. 0.D0 ) THEN TH2 = THETA F2 = FN ELSE TH1 = THETA F1 = FN ENDIF DF = 2.D0 * (SIN2X + DETCFG*(1-COS2X)) IF ( DF .NE. 0.D0 ) THEN DELTA = FN/DF ENDIF IF ( ((THETA+DELTA) .LT. TH1) .OR. ((THETA+DELTA) .GT. TH2) * .OR. (DF .EQ. 0) ) THEN DELTA = 0.5D0 * (TH2 - TH1) ENDIF THETA = THETA + DELTA IF ( ABS( DELTA ) .LT. ACCURC ) GOTO 2 ENDDO WRITE(MONIOU,*) WRITE(MONIOU,*) '---***!!!***WARNING***!!!***---' WRITE(MONIOU,*) 'FUNCTION FINDTH FAILED TO FIND ROOT IN',I, * ' STEPS' WRITE(MONIOU,*) 'BRACKETED BY TH1=',TH1,' TH2=',TH2 WRITE(MONIOU,*) ' F1 =',F1, ' F2 =',F1 WRITE(MONIOU,*) 'THETPR(1)=',THETPR(1),' THETPR(2)=',THETPR(2) WRITE(MONIOU,*) 'DETCFG=',DETCFG,' RANDOM=', X,' Y=', Y WRITE(MONIOU,*) 'THETA=',THETA,' DELTA IS:',DELTA WRITE(MONIOU,*) 'FUNCTION AT THETA IS:', * COS(2.D0*THETA) + DETCFG*(SIN(2.D0*THETA)-2.D0*THETA) - Y WRITE(MONIOU,*) '---***!!!***WARNING***!!!***---' WRITE(MONIOU,*) 2 CONTINUE FINDTH = THETA RETURN END #endif *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE FSTACK C----------------------------------------------------------------------- C F(ROM) STACK C C GETS PARTICLE FROM STACK AND READS FROM DISK IF NECESSARY. C THIS SUBROUTINE IS CALLED FROM AAMAIN. C----------------------------------------------------------------------- IMPLICIT NONE #define __BUFFSINC__ #define __ETHMAPINC__ #define __GENERINC__ #define __IRETINC__ #define __PAMINC__ #define __PARPARINC__ #define __PARPAEINC__ #define __POLARINC__ #if __PARALLEL__ #define __RANDPAINC__ #endif #define __RUNPARINC__ #define __STACKFINC__ #include "corsika.h" #if __CONEX__ double precision etotlost,etotsource,etotsta common/cxegybal/etotlost,etotsource,etotsta #endif INTEGER I,ISTK,J,N * ,IYEAR,MONTH,IDAY,IHOUR,IMINU #if __PARALLEL__ * ,L #endif DOUBLE PRECISION EAVAI,EINI * ,SEC0,SEC1,STIME,TTIME #if __ICECUBE1__ || __DYNSTACK__ LOGICAL buffer_empty #endif SAVE DATA ISTK / MAXSTK /, N / 0 / C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,220) ICOUNT-1,ELEFT #if __PARALLEL__ * ,JCOUNT-1,ELEFTJ #endif 220 FORMAT(' FSTACK:',I7,E12.5 #if __PARALLEL__ * ,I7,E12.5 #endif * ) C STACK EMPTY, SOMETHING TO BE READ FROM DISK ? #if __ICECUBE1__ call ringbuffer_empty( buffer_empty ) IF ( buffer_empty ) THEN #elif __DYNSTACK__ call dynstack_empty( buffer_empty ) IF ( buffer_empty ) THEN #else IF ( MSTACKP .EQ. 0 ) THEN #endif IF ( NOUREC .EQ. 0 ) THEN #if __PARALLEL__ C 2ND STACK EMPTY IF ( MSTACKPJ .EQ. 0 .AND. NOURECJ .EQ. 0 ) THEN #endif #if __CONEX__ IF ( DEBUG ) WRITE(MONIOU,224) NTO,NFROM #else IF ( FPRINT .OR. DEBUG ) WRITE(MONIOU,224) NTO,NFROM #endif 224 FORMAT(/,' NO MORE SECONDARIES FOUND ON STACK',/, * ' ',I11,' PARTICLES WRITTEN TO STACK',/, * ' ',I11,' PARTICLES READ FROM STACK' ) #if __PARALLEL__ WRITE(MONIOU,225) NTOJ WRITE(MONIOU,226) NFROMJ 225 FORMAT( ' ',I11,' PARTICLES WRITTEN TO STACKJ') 226 FORMAT( ' ',I11,' PARTICLES READ FROM STACKJ' ) #endif CURPAR(0) = 0.D0 IRET1 = 1 RETURN #if __PARALLEL__ ELSE C 2ND STACK EMPTY, SOMETHING TO BE READ FROM DISK ? IF ( MSTACKPJ .EQ. 0 ) THEN #if __THIN__ C READ LAST BLOCK OF 312 PARTICLES FROM 2ND SCRATCH FILE #else C READ LAST BLOCK OF 256 PARTICLES FROM 2ND SCRATCH FILE #endif READ(MEXSTJ,REC=NOURECJ) (STACKJ(I),I=1,ISTK/2) NOURECJ = NOURECJ - 1 MSTACKPJ = ISTK/2 ENDIF C ADD ONE PARTICLE IN STACK FROM 2ND STACK AND CHANGE SEED ACCORDING C TO CUTPAR(18) NFROMJ = NFROMJ + 1 JCOUNT = JCOUNT - 1 C PUT PARTICLE FROM 2ND STACK INTO CUTPAR MSTACKPJ = MSTACKPJ - MAXLEN - 1 DO J = 0, 18 CUTPAR(J) = STACKJ(MSTACKPJ+J+1) ENDDO #if __MULTITHIN__ DO J = 41, 46 CUTPAR(J) = STACKJ(MSTACKPJ+J+1) ENDDO #endif C COUNT ENERGY IN 2ND STACK BUT WITHOUT WEIGHT BECAUSE ONLY C PARTICLE ENERGY IS IMPORTANT HERE IF ( PAMA(NINT( CUTPAR(0) )) .LE. 0.D0 ) THEN ELEFTJ = ELEFTJ - CUTPAR(1) ELSE ELEFTJ = ELEFTJ - (CUTPAR(1)-1.D0)*PAMA(NINT(CUTPAR(0))) ENDIF C INITIALIZE 6TH RANDOM NUMBER SEQUENCE FROM CUTPAR(39) ISEED(1,6) = INT( CUTPAR(18) ) ISEED(2,6) = 0 ISEED(3,6) = 0 CALL RMMAQD( ISEED(1,6),6,'S' ) C INITIALIZE 1ST TO 3RD RANDOM NUMBER SEQUENCE FROM 6TH SEQUENCE CALL RMMARD( RD,3,6 ) DO L=1,3 ISEED(1,L) = INT( RD(L)*9.D8 ) ISEED(2,L) = 0 ISEED(3,L) = 0 CALL RMMAQD( ISEED(1,L),L,'S' ) ENDDO IF ( DEBUG )WRITE(MONIOU,227) (L,(ISEED(J,L),J=1,3),L=1,NSEQ) 227 FORMAT (' RANDOM NUMBER GENERATOR AT BEGIN OF SUBSHOWER :'/ * (' SEQUENCE = ',I2,' SEED = ',I9,' CALLS = ',I9, * ' BILLIONS = ',I9)) C INITIALIZE GAUSSIAN RANDOM NUMBER AS AT START OF A SHOWER KNOR = .TRUE. C SAVE CUTPAR IN MAIN STACK TO CONTINUE THE SUBSHOWER WITH NEW SEEDS NTO = NTO + 1 ICOUNT = ICOUNT + 1 CUTPAR(18) = -1.D0 DO J = 0, 18 STACKI(MSTACKP+J+1) = CUTPAR(J) ENDDO #if __MULTITHIN__ DO J = 19, MAXLEN - 6 STACKI(MSTACKP+J+1) = 0.D0 ENDDO DO J = 41, 46 STACKI(MSTACKP+J+1) = CUTPAR(J) ENDDO #else DO J = 19, MAXLEN STACKI(MSTACKP+J+1) = 0.D0 ENDDO #endif #if __ICECUBE1__ MSTACKP = MSTACKP - MAXLEN - 1 #else MSTACKP = MSTACKP + MAXLEN + 1 #endif IF ( PAMA(NINT( CUTPAR(0) )) .LE. 0.D0 ) THEN #if __THIN__ ELEFT = ELEFT + CUTPAR(1) * CUTPAR(13) ELSE ELEFT = ELEFT + CUTPAR(1) * PAMA(NINT(CUTPAR(0))) * * CUTPAR(13) #else ELEFT = ELEFT + CUTPAR(1) ELSE ELEFT = ELEFT + CUTPAR(1) * PAMA(NINT( CUTPAR(0) )) #endif ENDIF ENDIF #endif ELSE #if __PARALLEL__ #if __THIN__ C READ LAST BLOCK OF 312 PARTICLES FROM SCRATCH FILE #else C READ LAST BLOCK OF 256 PARTICLES FROM SCRATCH FILE #endif #else #if __CURVED__ C READ LAST BLOCK OF 256 PARTICLES FROM SCRATCH FILE #else #if __THIN__ C READ LAST BLOCK OF 312 PARTICLES FROM SCRATCH FILE #else C READ LAST BLOCK OF 340 PARTICLES FROM SCRATCH FILE #endif #endif #endif READ(MEXST,REC=NOUREC) (STACKI(I),I=1,ISTK/2) NOUREC = NOUREC - 1 MSTACKP = ISTK/2 ENDIF ENDIF NFROM = NFROM + 1 ICOUNT = ICOUNT - 1 #if __ICECUBE1__ C PUT PARTICLE FROM RING BUFFER INTO CURPAR call ringbuffer_get( SECPAR, MAXLEN ) C IF THE PARTICLE COMING FROM THE STACK IS INTERESTING DECREASE THE C COUNTER BY 1 IF ( .NOT.(SECPAR(0) .EQ. 1 .OR. SECPAR(0) .EQ. 2 .OR. * SECPAR(0) .EQ. 3 .OR. SECPAR(0) .EQ. 5 .OR. * SECPAR(0) .EQ. 6 .OR. SECPAR(0) .EQ. 7 .OR. * SECPAR(0) .EQ. 16 .OR. SECPAR(0) .EQ. 17 .OR. * SECPAR(0) .EQ. 18 ) .AND. * SECPAR(1)*PAMA(NINT(SECPAR(0))) .GE. energy_interesting ) THEN n_interesting = n_interesting - 1 ENDIF DO J = 0, 8 CURPAR(J) = SECPAR(J) ENDDO GEN = SECPAR(9) ALEVEL = SECPAR(10) POLART = SECPAR(11) POLARF = SECPAR(12) #elif __DYNSTACK__ call dynstack_fstack( SECPAR, (MAXLEN+1)*SIZEOF(SECPAR(0))) DO J = 0, 8 CURPAR(J) = SECPAR(J) ENDDO GEN = SECPAR(9) ALEVEL = SECPAR(10) POLART = SECPAR(11) POLARF = SECPAR(12) #if __CURVED__ CURPAR(14) = SECPAR(14) CURPAR(15) = SECPAR(15) CURPAR(16) = SECPAR(16) #endif #if __INTTEST__ CURPAR(17) = SECPAR(17) #endif #if __EHISTORY__ DO J = 17, 38 CURPAR(J) = SECPAR(J) ENDDO #endif #if __PARALLEL__ C ECTFLG IS CURPAR(39) CURPAR(39) = SECPAR(39) #endif #if __MULTITHIN__ DO J = 41, 46 CURPAR(J) = SECPAR(J) ENDDO #endif #else C PUT PARTICLE FROM STACK INTO CURPAR MSTACKP = MSTACKP - MAXLEN - 1 DO J = 0, 8 CURPAR(J) = STACKI(MSTACKP+J+1) ENDDO GEN = STACKI(MSTACKP+10) ALEVEL = STACKI(MSTACKP+11) POLART = STACKI(MSTACKP+12) POLARF = STACKI(MSTACKP+13) #if __THIN__ WEIGHT = STACKI(MSTACKP+14) #endif #if __CURVED__ CURPAR(14) = STACKI(MSTACKP+15) CURPAR(15) = STACKI(MSTACKP+16) CURPAR(16) = STACKI(MSTACKP+17) #endif #if __INTTEST__ CURPAR(17) = STACKI(MSTACKP+18) #endif #if __EHISTORY__ DO J = 17, 38 CURPAR(J) = STACKI(MSTACKP+J+1) ENDDO #endif #if __PARALLEL__ C ECTFLG IS CURPAR(39) CURPAR(39) = STACKI(MSTACKP+40) #endif #if __MULTITHIN__ DO J = 41, 46 CURPAR(J) = STACKI(MSTACKP+J+1) ENDDO #endif #endif IF ( PAMA(NINT( CURPAR(0) )) .NE. 0.D0 ) THEN #if __THIN__ ELEFT = ELEFT - CURPAR(1)*PAMA(NINT( CURPAR(0) ))* WEIGHT ELSE ELEFT = ELEFT - CURPAR(1)* WEIGHT ENDIF IF ( DEBUG ) WRITE(MDEBUG,667) ICOUNT,(CURPAR(J),J=0,9),WEIGHT 667 FORMAT('+ ',I7,1X,1P,11E11.3) #else ELEFT = ELEFT - CURPAR(1)*PAMA(NINT( CURPAR(0) )) ELSE ELEFT = ELEFT - CURPAR(1) ENDIF IF ( DEBUG ) THEN WRITE(MDEBUG,667) ICOUNT,(CURPAR(J),J=0,8) 667 FORMAT('+ ',I7,1X,1P,9E11.3) #if __MULTITHIN__ WRITE(MDEBUG,31) (CURPAR(I),I=41,46) 31 FORMAT(' FSTACK: 41-46: ',1P,6E11.3) #endif ENDIF #endif IF( PRMPAR(1) .GT. 5.D7 )THEN EINI = PRMPAR(1)*PAMA(NINT( PRMPAR(0) )) EAVAI = ELEFT #if __PARALLEL__ EAVAI = EAVAI + ELEFTJ #endif #if __CONEX__ EAVAI = EAVAI + etotsta + etotsource #endif #if !__PARALLELIB__ C ESTIMATE SIMULATION PROGRESS ONLY FOR HADRONIC SHOWERS IF ( PRMPAR(0) .GT. 3.D0 .AND. * (1.D0-EAVAI/EINI)*100.D0-DBLE(N) .GE. 0.D0 ) THEN C print *,N,EINI,EAVAI,ELEFT,etotsta,etotsource,etotlost C * ,1.D0-EAVAI/EINI IF ( N .EQ. 0 ) THEN C INITIALIZE TIME CALL GTTIME( SEC0,TTIME ) SEC1 = 0.D0 ELSE CALL GTTIME( SEC1,TTIME ) IYEAR = INT( TTIME / 1.D8 ) MONTH = INT( MOD( TTIME,1.D8 ) / 1.D6 ) IDAY = INT( MOD( TTIME,1.D6 ) / 1.D4 ) IHOUR = INT( MOD( TTIME,1.D4 ) / 1.D2 ) IMINU = INT( MOD( TTIME,1.D2 ) ) C TIME DIFFERENCE IN SEC SINCE BEGINNING STIME = SEC1 - SEC0 C EXPECTED TIME IN SEC TO REACH THE END STIME = STIME * DBLE( 100 - N ) / DBLE( N ) STIME = MIN( STIME,1.D12 ) IF ( STIME .GT. 60 ) * WRITE(MONIOU,670) N,INT( STIME / 3600.D0 ) * ,INT( MOD( STIME,3600.D0 ) / 60.D0 ) * ,IDAY,MONTH,IYEAR,IHOUR,IMINU 670 FORMAT('PROGRESS:',I3,'% (ESTIMATED TIME ',I4,' H ',I2,' MIN)', * ' THE ',I2.2,'.',I2.2,'.',I4,' AT ',I2.2,':',I2.2) CALL FLUSH( MDEBUG ) ENDIF N = N + 1 IF ( N .GE. 100 ) N = 0 ENDIF #endif ENDIF RETURN END #if __PARALLEL__ *-- Author : The CORSIKA development group 21/11/2011 C======================================================================= SUBROUTINE FSTACKO(IOPT) C----------------------------------------------------------------------- C F(ILE) STACK O(PEN) C C SCRATCH DISK MANAGEMENT. C THIS SUBROUTINE IS CALLED FROM TSTOUT AND AAMAIN. C ARGUMENT: C IOPT : OPTION TO OPEN FILE (1) OR TO CLOSE IT (0) C----------------------------------------------------------------------- IMPLICIT NONE #define __RUNPARINC__ #define __STACKFINC__ #include "corsika.h" INTEGER IOF,IBL,IOPT SAVE IOF DATA IOF/0/ C----------------------------------------------------------------------- IF ( IOPT .EQ. 1 ) THEN IF ( IOF .EQ. 0 ) THEN IOF = 1 IBL = INDEX(DSNJOB,' ')-1 #if __BYTERECL__ C FOR MOST FORTRAN COMPILERS ON UNIX-LIKE SYSTEMS (GNU g77, HP, C IBM RS6000) IT IS NECESSARY TO USE THE NUMBER OF BYTES FOR THE RECL C PARAMETER. c OPEN(UNIT=MEXST,STATUS='SCRATCH', c * FORM='UNFORMATTED',ACCESS='DIRECT',RECL=4*MAXSTK) OPEN(UNIT=MEXST,FILE=DSNJOB(1:IBL-4)//'.scratch', * STATUS='UNKNOWN',FORM='UNFORMATTED',ACCESS='DIRECT', * RECL=4*MAXSTK) #else C FOR DEC UNIX (COMPAQ Tru64) MACHINES WITH f77 COMPILER (UNLESS USING C THE '-assume bytrecl' COMPILER OPTION) AND SOME OTHER MACHINES THE C RECL PARAMETER IS THE NUMBER OF (4-BYTE) WORDS. c OPEN(UNIT=MEXST,STATUS='SCRATCH', c * FORM='UNFORMATTED',ACCESS='DIRECT',RECL=MAXSTK) OPEN(UNIT=MEXST,FILE=DSNJOB(1:IBL-4)//'.scratch', * STATUS='UNKNOWN',FORM='UNFORMATTED',ACCESS='DIRECT', * RECL=MAXSTK) #endif ENDIF ELSEIF ( IOF .NE. 0 ) THEN IOF = 0 CLOSE( MEXST ) ENDIF RETURN END *-- Author : The CORSIKA development group 21/11/2011 C======================================================================= SUBROUTINE FSTACKJO(IOPT) C----------------------------------------------------------------------- C F(ILE) STACK O(PEN) C C 2D SCRATCH DISK MANAGEMENT. C THIS SUBROUTINE IS CALLED FROM TSTOUT, CUTREAD, DATAC AND AAMAIN. C ARGUMENT: C IOPT : OPTION TO OPEN FILE (1) OR TO CLOSE IT (0) C----------------------------------------------------------------------- IMPLICIT NONE #define __RUNPARINC__ #define __STACKFINC__ #include "corsika.h" INTEGER IOF, IBL, IOPT SAVE IOF DATA IOF/0/ C----------------------------------------------------------------------- IF ( IOPT .EQ. 1 ) THEN IF ( IOF .EQ. 0 ) THEN IOF = 1 IBL = INDEX(DSNJOB,' ')-1 #if __BYTERECL__ C FOR MOST FORTRAN COMPILERS ON UNIX-LIKE SYSTEMS (GNU g77, HP, C IBM RS6000) IT IS NECESSARY TO USE THE NUMBER OF BYTES FOR THE RECL C PARAMETER. c OPEN(UNIT=MEXSTJ,STATUS='SCRATCH', c * FORM='UNFORMATTED',ACCESS='DIRECT',RECL=4*MAXSTK) OPEN(UNIT=MEXSTJ,FILE=DSNJOB(1:IBL-4)//'.scratchj', * STATUS='UNKNOWN',FORM='UNFORMATTED',ACCESS='DIRECT', * RECL=4*MAXSTK) #else C FOR DEC UNIX (COMPAQ Tru64) MACHINES WITH f77 COMPILER (UNLESS USING C THE '-assume bytrecl' COMPILER OPTION) AND SOME OTHER MACHINES THE C RECL PARAMETER IS THE NUMBER OF (4-BYTE) WORDS. c OPEN(UNIT=MEXSTJ,STATUS='SCRATCH', c * FORM='UNFORMATTED',ACCESS='DIRECT',RECL=MAXSTK) OPEN(UNIT=MEXSTJ,FILE=DSNJOB(1:IBL-4)//'.scratchj', * STATUS='UNKNOWN',FORM='UNFORMATTED',ACCESS='DIRECT', * RECL=MAXSTK) #endif ENDIF ELSEIF ( IOF .NE. 0 ) THEN IOF = 0 CLOSE( MEXSTJ ) ENDIF RETURN END #endif #if __CURVED__ && __SLANT__ && !__CONEX__ C======================================================================= DOUBLE PRECISION FUNCTION GAMMQ(X) C----------------------------------------------------------------------- C GAMMA FUNCTION C C RETURNS THE INCOMPLETE GAMMA FUNCTION Q(A, X) A 1-P(A, X). C USES THE ROUTINES GCF,GSER C THIS FUNCTION IS CALLED FROM CRSDEPTH0. C ARGUMENT : C X = ARGUMENT OF GAMMA FUNCTION C----------------------------------------------------------------------- IMPLICIT NONE DOUBLE PRECISION GAMMCF,GAMSER,X SAVE C----------------------------------------------------------------------- IF ( X .LT. 0.D0 ) STOP 'BAD ARGUMENT IN GAMMQ' IF ( X .LT. 1.5D0 ) 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 GCF( GAMMCF,X ) C----------------------------------------------------------------------- C RETURNS THE INCOMPLETE GAMMA FUNCTION Q(A, X) WITH A=0.5 C EVALUATED BY ITS CONTINUED FRACTION REPRESENTATION AS GAMMCF. C ALSO RETURNS LN(A) AS GLN. C PARAMETERS: C ITMAX = MAXIMUM ALLOWED NUMBER OF ITERATIONS C EPS = RELATIVE ACCURACY C FPMIN = NUMBER NEAR THE SMALLEST REPRESENTABLE FLOATING-POINT C NUMBER C ARGUMENTS: C GAMMCF = RETURNED VALUE OF GAMMA FUNCION C X = ARGUMENT OF GAMMA FUNCTION C----------------------------------------------------------------------- IMPLICIT NONE #define __RUNPARINC__ #include "corsika.h" INTEGER ITMAX PARAMETER (ITMAX=200) DOUBLE PRECISION EPS,FPMIN,GLN PARAMETER (EPS=3.D-5) PARAMETER (FPMIN=1.D-30) PARAMETER (GLN=0.572364942D0) !GLN=LN(SQRT(PI)) DOUBLE PRECISION AN,B,C,D,DEL,GAMMCF,H,X INTEGER I SAVE C----------------------------------------------------------------------- C GLN=GAMMLN(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(MONIOU,*) 'GCF : WARNING: A TOO LARGE, ITMAX TOO SMALL' *1 GAMMCF = EXP( -X + 0.5D0*LOG( X ) - GLN ) * H C PUT FACTORS IN FRONT. 1 GAMMCF = SQRT( X )*EXP( -X-GLN ) * H RETURN END C======================================================================= SUBROUTINE GSER( GAMSER,X ) C----------------------------------------------------------------------- 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. C ARGUMENTS: C GAMSER = RETURNED VALUE OF GAMMA FUNCTION C X = ARGUMENT OF GAMMA FUNCTION C----------------------------------------------------------------------- IMPLICIT NONE #define __RUNPARINC__ #include "corsika.h" INTEGER ITMAX DOUBLE PRECISION EPS,GLN PARAMETER (ITMAX=100) PARAMETER (EPS=3.D-6) PARAMETER (GLN=0.572364942D0) !GLN=LN(SQRT(PI)) DOUBLE PRECISION AP,DEL,GAMSER,SUM,X INTEGER N SAVE C----------------------------------------------------------------------- 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(MONIOU,*) 'GSER : WARNING: A TOO LARGE, ITMAX TOO SMALL' 1 GAMSER = SUM * SQRT( X ) * EXP( -X-GLN ) RETURN END #endif C======================================================================= SUBROUTINE GTTIME( SECONDS, TTIME ) C----------------------------------------------------------------------- C G(E)T TIME C C GET PRESENT TIME IN SECONDS. C THIS SUBROUTINE IS CALLED FROM FSTACK. C ARGUMENT: C SECONDS = TIME IN SECONDS C TTIME = DATE AND TIME (YYMMDDHHMN) C C IF OUR DATE ROUTINE DOES NOT FIT TO YOUR COMPUTER, PLEASE REPLACE C IT BY A SUITABLE ROUTINE OF YOUR SYSTEM C----------------------------------------------------------------------- IMPLICIT NONE #define __RUNPARINC__ #include "corsika.h" DOUBLE PRECISION SECONDS,TTIME #if __UNIX__ && __OLDDATE__ REAL SECNDS EXTERNAL SECNDS INTEGER ISECO #elif __UNIX__ && __OLDDATE2__ INTEGER LTIME(3) #elif __UNIX__ && __IBMRISC__ CHARACTER CYYMMDD*8, CHHMMSS*8 #elif __UNIX__ && !__IBMRISC__ && !__TIMERC__ CHARACTER*8 YYYYMMDD CHARACTER*10 HHMMSS #elif __MAC__ INTEGER ISECO #endif INTEGER IYEAR,MONTH,IDAY,IHOUR,IMINU,ISEC SAVE C----------------------------------------------------------------------- #if __TIMERC__ C COMPILERS WITH OLD DATE FUNCTIONS ONLY HAVE TO CALL SEKDAT HERE CALL SEKDAT( IYEAR,MONTH,IDAY,IHOUR,IMINU,ISEC ) SECONDS = MONTH*2.592D6 + IDAY*86.4D3 + IHOUR*3.D3 * + IMINU*60.D0 + ISEC #elif __UNIX__ && __OLDDATE__ C IF YOUR COMPILER DOES NOT KNOW ROUTINES IDATE AND SECNDS C REPLACE THESE CALLS BY CALLS TO YOUR SYSTEM ROUTINES TO C FILL THE INTEGERS: IYEAR, MONTH, IDAY, IHOUR, IMINU, ISEC CALL IDATE( MONTH,IDAY,IYEAR ) SECONDS = MONTH*2.592D6 + IDAY*86.4D3 + SECNDS(0.0) IHOUR = INT( SECNDS(0.0) / 3600.D0 ) IMINU = INT( MOD( SECNDS(0.0) , 3600.D0 ) / 60.D0 ) #elif __UNIX__ && __OLDDATE2__ C IF YOUR COMPILER DOES NOT KNOW ROUTINES IDATE AND SECNDS C REPLACE THESE CALLS BY CALLS TO YOUR SYSTEM ROUTINES TO C FILL THE INTEGERS: IYEAR, MONTH, IDAY, IHOUR, IMINU, ISEC CALL IDATE( MONTH,IDAY,IYEAR ) C SECONDS, MINUTS, HOURS (ALTERNATIVE FOR betaLINUX at CC.in2p3.fr) CALL ITIME( LTIME ) ISEC = LTIME(3) IMINU = LTIME(2) IHOUR = LTIME(1) SECONDS = MONTH*2.592D6 + IDAY*86.4D3 + IHOUR*3.D3 * + IMINU*60.D0 + ISEC #elif __UNIX__ && !__OLDDATE__ && !__IBMRISC__ 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 CALL DATE_AND_TIME( YYYYMMDD, HHMMSS ) READ(YYYYMMDD,'(I4,2I2)') IYEAR,MONTH,IDAY READ(HHMMSS,'(3I2)') IHOUR,IMINU,ISEC SECONDS = MONTH*2.592D6 + IDAY*86.4D3 + IHOUR*3.D3 * + IMINU*60.D0 + ISEC #elif __UNIX__ && __IBMRISC__ C FOR COMPILERS ON IBM RISC MACHINES LIKE IBM RS 6000 CALL DATE( CYYMMDD ) CALL CLOCK_( CHHMMSS ) READ(CYYMMDD,'(I2,1X,I2,1X,I2)') MONTH,IDAY,IYEAR READ(CHHMMSS,'(I2,1X,I2,1X,I2)') IHOUR,IMINU,ISEC SECONDS = MONTH*2.592D6 + IDAY*86.4D3 + IHOUR*3.D3 * + IMINU*60.D0 + ISEC #elif __MAC__ C DATE AND TIME ROUTINES FOR MACINTOSH CALL DATE( MONTH,IDAY,IYEAR ) CALL TIME( ISECO ) SECONDS = MONTH*2.592D6 + IDAY*86.4D3 + ISECO IHOUR = ISECO / 3600 IMINU = MOD( ISECO , 3600 ) / 60 #endif TTIME = IYEAR*1D8 + MONTH*1D6 + IDAY*1D4 + IHOUR*1D2 + IMINU RETURN END *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= DOUBLE PRECISION FUNCTION HEIGH( ARG ) C----------------------------------------------------------------------- C HEIGH(T AS FUNCTION OF THICKNESS) C C CALCULATES HEIGHT DEPENDING ON THICKNESS OF ATMOSPHERE C THIS FUNCTION IS CALLED FROM AAMAIN, BOX2, BOX3, COOINC, INPRM, C MUTRAC, PRANGC, STAEND, THICKC, UPDATC, UPDATE, EGSIN1, AND ININKG C ARGUMENT: C ARG = MASS OVERLAY (G/CM**2) C----------------------------------------------------------------------- IMPLICIT NONE #define __ATMOSINC__ #define __ATMOS2INC__ #define __RUNPARINC__ #if __ATMEXT__ #define __ATMOSXINC__ #endif #include "corsika.h" DOUBLE PRECISION ARG SAVE #if __ATMEXT__ DOUBLE PRECISION HEIGHX EXTERNAL HEIGHX #endif C----------------------------------------------------------------------- CC IF ( DEBUG ) WRITE(MDEBUG,*) 'HEIGH : ARG=',SNGL(ARG) #if __ATMEXT__ IF ( IATMOX .GE. 1 ) THEN HEIGH = HEIGHX(ARG) RETURN ENDIF #endif IF ( ARG .GT. THICKL(2) ) THEN HEIGH = CATM(1) * LOG( BATM(1) / (ARG - AATM(1)) ) ELSEIF ( ARG .GT. THICKL(3) ) THEN HEIGH = CATM(2) * LOG( BATM(2) / (ARG - AATM(2)) ) ELSEIF ( ARG .GT. THICKL(4) ) THEN HEIGH = CATM(3) * LOG( BATM(3) / (ARG - AATM(3)) ) ELSEIF ( ARG .GT. THICKL(5) ) THEN HEIGH = CATM(4) * LOG( BATM(4) / (ARG - AATM(4)) ) ELSE HEIGH = (AATM(5) - ARG) * CATM(5) ENDIF RETURN END #if __CURVED__ && __SLANT__ *-- Author : S. Ostapchenko IK FZK Karlsruhe 19/09/2003 C======================================================================= DOUBLE PRECISION FUNCTION HEIGHTD(DIST,RADT) C----------------------------------------------------------------------- C HEIGHT (AT SLANT) D(ISTANCE FROM OBSERVATION LEVEL) C C CALCULATES THE HEIGHT ABOVE SEA LEVEL (IN CM) AT DISTANCE FROM C OBSERVATION LEVEL ALONG A PATH WITH IMPACT RADIUS RADT. C WORKS ONLY IN THE EXPONENTIAL LAYERS OF THE ATMOSPHERE. C THIS FUNCTION IS CALLED FROM DL2DT. C ARGUMENTS: C DIST = SLANT DISTANCE TO THE OBS LEVEL (TO THE IMPACT POINT) (CM) C RADT = IMPACT RADIUS (CM) C----------------------------------------------------------------------- IMPLICIT NONE #define __ATMOSLINC__ #define __OBSPARINC__ #define __PARPARINC__ #include "corsika.h" DOUBLE PRECISION DIST,RADT SAVE C----------------------------------------------------------------------- IF ( RADT .GE. RADGRD ) THEN C PARTICLE PASSES ABOVE OBSERVATION LEVEL HEIGHTD = (DIST**2+(RADT-C(1))*(RADT+C(1))) * /(SQRT( DIST**2+RADT**2 )+C(1)) ELSE C PARTICLE HITS GROUND HEIGHTD = (DIST**2+2.D0*DIST*SQRT( MAX(0.D0,RADGRD-RADT) ) * *SQRT( RADGRD+RADT )+HGROUND**2+2.D0*C(1)*HGROUND) * / (SQRT( (DIST+SQRT( MAX( 0.D0,RADGRD-RADT ) ) * *SQRT( RADGRD+RADT ) )**2+RADT**2)+C(1)) ENDIF RETURN END #endif #if __CHARM__ *-- Author : A.GASCON IN UNIVERSITY OF GRANADA 11/01/2012 C======================================================================= SUBROUTINE HEPARIN( CHAE ) C----------------------------------------------------------------------- C HE(AVY) PAR(TICLE) IN(TERACTION) C HEAVY PARTICLE INTERACTION BASED ON M.MASIP AND J.ILLANA MODEL C PERFORMS INTERACTION ON PROTON AND RETRIEVE SECONDARY PARTICLES. C THIS SUBROUTINE IS CALLED FROM NUCINT. C ARGUMENT: C CHAE = PARTICLE (TOTAL) LAB. ENERGY (IN GEV) C----------------------------------------------------------------------- IMPLICIT NONE #define __INTERINC__ #define __NCSNCSINC__ #define __PAMINC__ #define __PARPARINC__ #define __PARPAEINC__ #define __RANDPAINC__ #define __RUNPARINC__ #include "corsika.h" DOUBLE PRECISION CHAE INTEGER NY,NDIFF,NPARTONIC INTEGER IIC INTEGER NNY SAVE EXTERNAL NNY C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*)'HEPARIN: CHAE=',CHAE C SET ALL CHARMED AND BOTTOM PARTICLES TO BE STABLE CALL PYTDCSET NDIFF = 0 NPARTONIC = 0 NY = NNY(1.D0) IF ( ITYPE .GE. 116 .AND. ITYPE .LE. 128 ) THEN C CHARMED MESONS C NY = NNY(1.0,143.49,-7.694,3.95) DO IIC = 1,NY CALL RMMARD( RD,1,1 ) IF ( RD(1) .LT. 0.26D0 ) NDIFF = NDIFF+1 ENDDO ELSEIF ( ITYPE .GE. 137 .AND. ITYPE .LE. 173 ) THEN C CHARMED BARYONS C NY = NNY(1.0,74.96,-8.618,5.2605) DO IIC = 1,NY CALL RMMARD( RD,1,1 ) IF ( RD(1) .LT. 0.30D0 ) NDIFF = NDIFF+1 ENDDO #if !__SIBYLL__ ELSEIF ( ITYPE .GE. 176 .AND. ITYPE .LE. 183 ) THEN C BOTTOM MESONS C NY = NNY(1.0,106.338,-6.8364,3.768) DO IIC = 1,NY CALL RMMARD( RD,1,1 ) IF ( RD(1) .LT. 0.288D0 ) NDIFF = NDIFF+1 ENDDO ELSEIF ( ITYPE .GE. 184 .AND. ITYPE .LE. 195 ) THEN C BOTTOM BARYONS C NY = NNY(1.0,6351.69,-25.84,8.0) DO IIC = 1,NY CALL RMMARD( RD,1,1 ) IF ( RD(1) .LT. 0.315D0 ) NDIFF = NDIFF+1 ENDDO #endif ENDIF NPARTONIC = NY-NDIFF IF ( DEBUG ) WRITE(MDEBUG,*) 'HEPARIN: NY,NDIFF,NPARTONIC=', * NY,NDIFF,NPARTONIC C DIFFRACTIVE OR PARTONIC PROCESS ACCORDING TO CALCULATED PROBABILITIES IF ( ITYPE .GE. 116 .AND. ITYPE .LE. 128 ) THEN C CHARMED MESON IF ( NDIFF .EQ. NY ) THEN CALL CHAMEDIF( CHAE ) ELSE CALL CHAMEPAR( CHAE,NPARTONIC ) ENDIF ELSEIF ( ITYPE .GE. 137 .AND. ITYPE .LE. 173 ) THEN C CHARMED BARYON IF ( NDIFF .EQ. NY ) THEN CALL CHABADIF( CHAE ) ELSE CALL CHABAPAR( CHAE,NPARTONIC ) ENDIF #if !__SIBYLL__ ELSEIF ( ITYPE .GE. 176 .AND. ITYPE .LE. 183 ) THEN C BOTTOM MESON IF ( NDIFF .EQ. NY ) THEN CALL BOMEDIF( CHAE ) ELSE CALL BOMEPAR( CHAE,NPARTONIC ) ENDIF ELSEIF ( ITYPE .GE. 184 .AND. ITYPE .LE. 195 ) THEN C BOTTOM BARYON IF ( NDIFF .EQ. NY ) THEN CALL BOBADIF( CHAE ) ELSE CALL BOBAPAR( CHAE,NPARTONIC ) ENDIF #endif ENDIF C STORE SECONDARY PARTICLES TO STACK CALL PYTSTO C CALL PYTDCSET HERE AND NOT BEFORE MUCH MORE FREQUENT CALLS TO CHRMDC C SET ALL (LONG LIVED) CHARMED AND BOTTOM PARTICLES TO BE STABLE CALL PYTDCSET RETURN END #endif *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE INPRM C----------------------------------------------------------------------- C IN(PUT) PR(I)M(ARY) C C TAKES INPUT PRIMARY ENERGY FROM SPECIFIED SPECTRUM C CHECKS INPUT VARIABLES FOR CONSISTENCY AND LIMITATIONS C WRITES DATA BASE FILE C INITIALIZES CHERENKOV, IF CERENKOV OPTION SELECTED. C THIS SUBROUTINE IS CALLED FROM AAMAIN. C----------------------------------------------------------------------- IMPLICIT NONE #define __ATMOSINC__ #define __ATMOS2INC__ #define __BUFFSINC__ #define __CONSTAINC__ #define __DPMFLGINC__ #define __ELABCTINC__ #define __ETHMAPINC__ #define __LONGIINC__ #define __MAGANGINC__ #define __MAGNETINC__ #define __NKGIINC__ #define __OBSPARINC__ #define __PARPARINC__ #define __PARPAEINC__ #define __PRIMSPINC__ #define __RANDPAINC__ #define __REJECTINC__ #define __RUNPARINC__ #define __VERSINC__ #if __CONEX__ #define __CONEXINC__ #endif #if __DPMJET__ #define __DPMJETINC__ #endif #if __EPOS__ || __NEXUS__ #define __NEXUSINC__ #endif #if __QGSJET__ #define __QGSCINC__ #endif #if __SIBYLL__ #define __SIBYLCINC__ #endif #if __VENUS__ #define __VENUSINC__ #endif #if __ATMEXT__ #define __ATMOSXINC__ #endif #if __CERENKOV__ || __AUGERHIST__ || __AUGCERLONG__ #define __CEREN1INC__ #define __CERTELINC__ #define __CEREN3INC__ #endif #if __CERENKOV__ || __AUGCERLONG__ #define __CEREN2INC__ #endif #if __CEFFIC__ && __CERENKOV__ #define __CERABSINC__ #endif #if __PARALLEL__ #define __STACKFINC__ #endif #if __COASTUSERLIB__ #define __INCLINEDINC__ #endif #if __PLOTSH2__ #define __PLOTSH2INC__ #endif #if __THIN__ || __MULTITHIN__ #define __THNVARINC__ #endif #if __VOLUMECORR__ #define __DETCFGINC__ #endif #include "corsika.h" #if __UNIX__ DOUBLE PRECISION EFRAC,VERVEN INTEGER IDPM,ILONG,ILTHIN,ISO CHARACTER*1 MARK #endif DOUBLE PRECISION H0 DOUBLE PRECISION HEIGH,THICK #if __CURVED__ && __UPWARD__ DOUBLE PRECISION DELTA #endif INTEGER I,IA,IP #if __CERENKOV__ DOUBLE PRECISION TMPROTX,TMPROTY #if __IACT__ DOUBLE PRECISION RTEL,XTEL,YTEL,ZTEL INTEGER IEXIST #endif #endif #if __ATMEXT__ INTEGER IFREFRX #endif #if __THIN__ INTEGER IONES,ITENS,IHUNS #endif SAVE EXTERNAL HEIGH,THICK #if __CONEX__ DOUBLE PRECISION aNbrNucl #endif C----------------------------------------------------------------------- WRITE(MONIOU,504) 504 FORMAT(/,/,' ',10('='),' SHOWER PARAMETERS ', 50('=') ) C WRITE ENERGY SPECTRUM TO HEADER RUNH(16) = PSLOPE RUNH(17) = LLIMIT RUNH(18) = ULIMIT EVTH(58) = PSLOPE EVTH(59) = LLIMIT EVTH(60) = ULIMIT #if __COASTUSERLIB__ C INCLINED PLANE RUNH(75) = XPINCL RUNH(76) = YPINCL RUNH(77) = ZPINCL RUNH(78) = THINCL RUNH(79) = PHINCL #endif RUNH(80) = ARRANG RUNH(93) = REAL( NSHOW ) IF ( PRMPAR(0) .GT. 5656.D0 .OR. PRMPAR(0) .LE. 0.D0 ) THEN WRITE(MONIOU,*) WRITE(MONIOU,*) 'INCORRECT SELECTION OF PRIMARY PARTICLE ', * 'TYPE = ',INT( PRMPAR(0) ) WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORD: PRMPAR' STOP ENDIF C CHECK WHETHER NUCLEUS IS A SINGLE NUCLEON IF ( PRMPAR(0) .EQ. 100.D0 ) PRMPAR(0) = 13.D0 IF ( PRMPAR(0) .EQ. 101.D0 ) PRMPAR(0) = 14.D0 C CHECK WHETHE NUCLEUS HAS CORRECT NUCLEON NUMBERS IF ( PRMPAR(0) .GE. 200.D0 ) THEN ITYPE = INT( PRMPAR(0) ) IA = ITYPE / 100 IP = MOD( ITYPE, 100 ) IF ( IP .GT. IA ) THEN WRITE(MONIOU,*) WRITE(MONIOU,*) 'INCORRECT SELECTION OF PRIMARY PARTICLE ', * 'TYPE = ',ITYPE WRITE(MONIOU,*) 'MORE PROTONS =',IP,' THAN NUCLEONS =',IA WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORD: PRMPAR' STOP ENDIF ENDIF #if !__STACKIN__ WRITE(MONIOU,*) 'PRIMARY PARTICLE IDENTIFICATION IS ', * NINT( PRMPAR(0) ) #endif C CHECK RECOMMENDED ENERGY RANGE #if __DPMJET__ IF ( FDPMJT .AND. c * ULIMIT .GT. 1.D12 .AND. PRMPAR(0) .GE. 8.D0 ) THEN * ULIMIT .GT. 1.D12 ) THEN WRITE(MONIOU,502) ULIMIT 502 FORMAT(' INTERACTION MODEL UNCERTAIN FOR THE SELECTED PRIMARY ', * 'ENERGY OF ',E11.4,' GEV',/,/,' PLEASE READ THE USERS GUIDE') WRITE(MONIOU,*) 'SEE KEYWORD: ERANGE' c STOP ENDIF #elif __VENUS__ IF ( FVENUS .AND. * ULIMIT .GT. 2.D7 .AND. PRMPAR(0) .GE. 8.D0 ) THEN WRITE(MONIOU,502) ULIMIT 502 FORMAT(' INTERACTION MODEL DOUBTFUL FOR THE SELECTED PRIMARY ', * 'ENERGY OF ',E11.4,' GEV',/,/,' PLEASE READ THE USERS GUIDE') WRITE(MONIOU,*) 'SEE KEYWORD: ERANGE' STOP ENDIF #endif C CHECK ENERGY RANGE FOR CROSS-SECTIONS #if __DPMJET__ IF ( .NOT. FDPJSG .AND. ULIMIT .GT. 1.D8 ) THEN #elif __EPOS__ || __NEXUS__ IF ( .NOT. FNEXSG .AND. ULIMIT .GT. 1.D8 ) THEN #elif __QGSJET__ IF ( .NOT. FQGSSG .AND. ULIMIT .GT. 1.D8 ) THEN #elif __SIBYLL__ IF ( .NOT. FSIBSG .AND. ULIMIT .GT. 1.D8 ) THEN #elif __VENUS__ IF ( .NOT. FVENSG .AND. ULIMIT .GT. 1.D7 ) THEN #else IF ( ULIMIT .GT. 1.D8 ) THEN #endif WRITE(MONIOU,*) ' WARNING: P-AIR CROSS-SECTION DOUBTFULL ', * 'FOR ENERGIES ABOVE 10**17 EV' ENDIF IF ( PRMPAR(0) .GE. 200.D0 ) THEN #if __FLUKA__ IF ( FFLUKA ) THEN C FLUKA LINK CANNOT TREAT NUCLEI #elif __URQMD__ IF ( FURQMD ) THEN C URQMD1.3 LINK CANNOT TREAT NUCLEI #else IF ( GHEISH ) THEN C GHEISHA CANNOT TREAT NUCLEI #endif IF ( LLIMIT .LT. HILOELB * INT( PRMPAR(0)/100.D0 ) ) THEN WRITE(MONIOU,503) INT( PRMPAR(0)/100.D0 ),LLIMIT 503 FORMAT(' NUCLEUS WITH A =',I2,' AND PRIMARY ENERGY =',1P, * E11.4,' GEV IS TOO LOW FOR HIGH ENERGY INTERACTION MODEL', * /,' AND CANNOT BE TREATED BY LOW ENERGY INTERACTION MODEL' * ,/,' SIMPLE SUPERPOSITION MODEL IS USED',0P,/) WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORD: ERANGE' ** STOP ENDIF ENDIF ENDIF #if __STACKIN__ ISPEC = 0 #else C DEFINE ENERGY RANGE AND ENERGY SPECTRUM OF PRIMARY IF ( LLIMIT .GT. ULIMIT ) THEN WRITE(MONIOU,501) LLIMIT,ULIMIT 501 FORMAT(' ERROR IN PRIMARY ENERGY SPECIFICATION:',/, * ' LLIMIT=',1P,E11.4,' IS LARGER THAN ULIMIT=',E11.4,' STOP') STOP ELSEIF ( LLIMIT .EQ. ULIMIT ) THEN ISPEC = 0 WRITE(MONIOU,506) LLIMIT 506 FORMAT(' PRIMARY ENERGY IS FIXED AT ',1P,E11.4, * ' GEV' ) ELSE ISPEC = 1 WRITE(MONIOU,505) PSLOPE,LLIMIT,ULIMIT 505 FORMAT(' PRIMARY ENERGY IS TAKEN FROM SPECTRUM VIA MONTE CARLO', * /,5X,' SLOPE OF PRIMARY SPECTRUM = ',1P,E11.4,/, * 5X,' LOWER LIMIT CUT-OFF FOR PRIMARY SPECTRUM = ',E11.4,' GEV',/ * ,5X,' UPPER LIMIT CUT-OFF FOR PRIMARY SPECTRUM = ',E11.4,' GEV', * /) IF ( PSLOPE .NE. -1.D0 ) THEN LL = LLIMIT ** (PSLOPE + 1.D0) UL = ULIMIT ** (PSLOPE + 1.D0) SLEX = 1.D0 / (PSLOPE + 1.D0) ELSE LL = ULIMIT / LLIMIT ENDIF ENDIF #endif C FIRST INTERACTION TARGET FIXED ? * IF ( N1STTR .EQ. 1 ) THEN * WRITE(MONIOU,508) 'NITROGEN' *508 FORMAT(' TARGET OF FIRST INTERACTION IS FIXED TO ',A8) * ELSEIF ( N1STTR .EQ. 2 ) THEN * WRITE(MONIOU,508) 'OXYGEN ' * ELSEIF ( N1STTR .EQ. 3 ) THEN * WRITE(MONIOU,508) 'ARGON ' * ELSE * N1STTR = 0 #if !__INTTEST__ * WRITE(MONIOU,*) 'TARGET OF FIRST INTERACTION IS CHOSEN RANDOMLY' #endif * ENDIF #if __CURVED__ && __UPWARD__ C SET PRIMARY ZENITH ANGLE FOR HORIZONTALLY SKIMMING SHOWERS IF ( FIMPCT ) THEN THETPR(1) = 90.D0 THETPR(2) = 90.D0 ENDIF #endif C CHECK ANGULAR SETTINGS IF ( THETPR(1) .LT. 0.D0 ) THEN WRITE(MONIOU,*) WRITE(MONIOU,*) 'UNALLOWED CHOICE OF THETAP = ',SNGL(THETPR(1)), * ' DEGREES' WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORD: THETAP' STOP ENDIF #if __UPWARD__ && __CURVED__ #if !__VOLUMEDET__ && !__VOLUMECORR__ IF ( THETPR(1) .LT. 90.D0 .AND. THETPR(2) .GT. 90.D0 ) THEN WRITE(MONIOU,*) WRITE(MONIOU,*) 'UNALLOWED RANGE OF THETAP: ',SNGL(THETPR(1)), * ' < THETPR < ',SNGL(THETPR(2)) WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORD: THETAP' STOP ENDIF #endif #endif #if __CURVED__ #if __CERENKOV__ IF ( THETPR(2) .GT. 88.D0 ) THEN WRITE(MONIOU,*) WRITE(MONIOU,*) 'UNALLOWED CHOICE OF THETAP = ',SNGL(THETPR(2)), * ' DEGREES' WRITE(MONIOU,*) 'UPWARD GOING CERENKOV PHOTONS CANNOT BE ', * 'TREATED' WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORD: THETAP' STOP ENDIF IF ( .NOT. FFLATOUT ) THEN WRITE(MONIOU,*) WRITE(MONIOU,*) 'CURVOUT = .true. NOT POSSIBLE FOR CERENKOV ', * 'SHOWERS, MODIFIED TO CURVOUT = .false.' WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORD: CURVOUT' FFLATOUT = .TRUE. ENDIF #else IF ( FFLATOUT .AND. THETPR(2) .GE. 85.D0 ) THEN WRITE(MONIOU,*) WRITE(MONIOU,*) 'UNALLOWED RANGE OF THETAP:',SNGL(THETPR(1)), * '< THETAP <',SNGL(THETPR(2)), * 'WITH CURVOUT OPTION SET .false.' WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORD: CURVOUT' STOP ENDIF IF ( THETPR(2) .GT. 90.D0 ) THEN #if __UPWARD__ IF ( FFLATOUT ) THEN WRITE(MONIOU,*) WRITE(MONIOU,*) 'CURVOUT SET TO .true. FOR UPWARD GOING', * ' SHOWERS' WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORD: CURVOUT' FFLATOUT = .FALSE. ENDIF #else WRITE(MONIOU,*) WRITE(MONIOU,*) 'UNALLOWED CHOICE OF THETAP = ',SNGL(THETPR(2)), * ' DEGREES' WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORD: THETAP' STOP #endif ENDIF #endif #else /* !__CURVED__ */ #if __UPWARD__ IF ( THETPR(1) .LT. 90.D0 .AND. THETPR(2) .GT. 90.D0 ) THEN WRITE(MONIOU,*) WRITE(MONIOU,*) 'UNALLOWED RANGE OF THETAP: ',SNGL(THETPR(1)), * ' < THETAP < ',SNGL(THETPR(2)) WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORD: THETAP' STOP ENDIF IF ( THETPR(1) .GT. 70.D0 .AND. THETPR(1) .LT. 110.D0 ) THEN WRITE(MONIOU,*) WRITE(MONIOU,*) 'UNALLOWED CHOICE OF THETAP = ',SNGL(THETPR(1)), * ' DEGREES' WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORD: THETAP' STOP ENDIF IF ( THETPR(2) .GT. 70.D0 .AND. THETPR(2) .LT. 110.D0 ) THEN WRITE(MONIOU,*) WRITE(MONIOU,*) 'UNALLOWED CHOICE OF THETAP = ',SNGL(THETPR(2)), * ' DEGREES' #else IF ( THETPR(2) .GT. 70.D0 ) THEN WRITE(MONIOU,*) WRITE(MONIOU,*) 'UNALLOWED CHOICE OF THETAP = ',SNGL(THETPR(2)), * ' DEGREES' #endif WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORD: THETAP' STOP ENDIF #endif /* __CURVED__ */ C INCIDENCE ANGLE FIXED ? IF ( THETPR(1) .EQ. THETPR(2) .AND. PHIPR(1) .EQ. PHIPR(2) ) THEN FIXINC = .TRUE. #if !__VIEWCONE__ WRITE(MONIOU,517) THETPR(1),PHIPR(1) 517 FORMAT(' THETA OF INCIDENCE IS FIXED TO ',F10.2,' DEGREES',/, * ' PHI OF INCIDENCE IS FIXED TO ',F10.2,' DEGREES') #endif ELSE FIXINC = .FALSE. #if __VOLUMEDET__ WRITE(MONIOU,527) THETPR,PHIPR 527 FORMAT(' THETA OF INCIDENCE CHOSEN FROM ',F10.2,'...',F10.2, * ' DEGREES',/, * ' ANGULAR THETA DEPENDENCE ACCORDING TO VOLUME DETECTOR', * /,' PHI OF INCIDENCE CHOSEN FROM ',F10.2,'...',F10.2, * ' DEGREES') #elif __VOLUMECORR__ WRITE(MONIOU,527) THETPR,DETCFG,PHIPR 527 FORMAT(' THETA OF INCIDENCE CHOSEN FROM ',F10.2,'...',F10.2, * ' DEGREES',/,' ANGULAR THETA DEPENDENCE ACCORDING TO', * ' VERTICAL STRING DETECTOR WITH HEIGHT/DIAMETER = ', * F10.5,/,' PHI OF INCIDENCE CHOSEN FROM ',F10.2, * '...',F10.2,' DEGREES') #else WRITE(MONIOU,527) THETPR,PHIPR 527 FORMAT(' THETA OF INCIDENCE CHOSEN FROM ',F10.2,'...',F10.2, * ' DEGREES',/, * ' ANGULAR THETA DEPENDENCE ACCORDING TO FLAT DETECTOR',/, * ' PHI OF INCIDENCE CHOSEN FROM ',F10.2,'...',F10.2, * ' DEGREES') #endif ENDIF #if __VIEWCONE__ IF ( VUECON(2) .LT. 0.D0 ) THEN WRITE(MONIOU,*) WRITE(MONIOU,*) 'UNALLOWED CHOICE OF VUECON = ', * SNGL(VUECON(1)),SNGL(VUECON(2)),' DEGREES < 0.' WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORD: VIEWCONE' STOP ELSEIF ( VUECON(2) .GT. 0.D0 ) THEN IF ( .NOT. FIXINC ) THEN WRITE(MONIOU,*) WRITE(MONIOU,*) 'THE VIEWCONE OPTION REQUIRES FIXED THETA', * ' AND PHI VALUES.' WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORD: VIEWCONE' STOP ENDIF #if __CURVED__ #if __CERENKOV__ IF ( ABS(THETPR(2)-VUECON(2)) .GT. 88.D0-0.1D0 ) THEN #else IF ( ABS(THETPR(2)-VUECON(2)) .GE. 90.D0-0.1D0 ) THEN #endif #else IF ( ABS(THETPR(2)-VUECON(2)) .GT. 70.D0-0.1D0 ) THEN #endif WRITE(MONIOU,*) WRITE(MONIOU,*) 'UNALLOWED COMBINATION OF THETA AND ', * 'VIEWCONE' WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORD: VIEWCONE AND THETAP' STOP ENDIF WRITE(MONIOU,519) THETPR(1),PHIPR(1),ABS(VUECON(1)),VUECON(2) 519 FORMAT(' THETA OF VIEWING CONE IS FIXED TO ',F10.2,' DEGREES',/, * ' PHI OF VIEWING CONE IS FIXED TO ',F10.2,' DEGREES',/, * ' VIEWING CONE HAS INNER OPENING OF +-',F10.2,' DEGREES',/, * ' VIEWING CONE HAS OUTER OPENING OF +-',F10.2,' DEGREES',/) #if __CURVED__ #if __CERENKOV__ IF ( THETPR(2)+VUECON(2) .GT. 88.D0 ) THEN #else IF ( THETPR(2)+VUECON(2) .GE. 90.D0 ) THEN #endif #else IF ( THETPR(2)+VUECON(2) .GT. 70.D0 ) THEN #endif WRITE(MONIOU,528) 528 FORMAT(' A VIEWING CONE WAS CHOSEN WHICH DOES NOT FIT ', * 'ENTIRELY INTO THE ALLOWED RANGE',/, * 'OF ZENITH ANGLES. ONLY SHOWERS IN THE ALLOWED RANGE ARE ', * 'GENERATED BY CORSIKA.') ENDIF ENDIF #endif /* __VIEWCONE__ */ EVTH(81) = THETPR(1) EVTH(82) = THETPR(2) EVTH(83) = PHIPR(1) EVTH(84) = PHIPR(2) #if __VIEWCONE__ VUECON(1) = VUECON(1)*PI/180.D0 VUECON(2) = VUECON(2)*PI/180.D0 #endif C----------------------------------------------------------------------- C PRMPAR, OBSLEV, NOBSLV PRMPAR(1) = 0.D0 PRMPAR(6) = 0.D0 PRMPAR(7) = 0.D0 PRMPAR(8) = 0.D0 C CHECK WHETHER OBSERVATION LEVELS ARE IN ALLOWED RANGE DO I = 1, NOBSLV IF ( OBSLEV(I) .GT. HLAY(6)-1.D2 ) THEN WRITE(MONIOU,120) I,OBSLEV(I),HLAY(6)-1.D2 120 FORMAT(' UNALLOWED CHOICE OF OBSLEV ',/,' OBSERVATION LEVEL ', * I2,' IS AT ',F12.3,' CM, WHICH IS ABOVE', * F12.3,' CM',/,/,' PLEASE READ THE USERS GUIDE') WRITE(MONIOU,*) 'SEE KEYWORD: OBSLEV' STOP ENDIF IF ( OBSLEV(I) .LT. HLAY(1) ) THEN WRITE(MONIOU,121) I,OBSLEV(I) 121 FORMAT(' UNALLOWED CHOICE OF OBSLEV ',/,' OBSERVATION LEVEL ', * I2,' IS AT ',F12.3,' CM, WHICH IS BELOW LOWEST', * ' ATMOSPHERE BOUNDARY',/,/, * ' PLEASE READ THE USERS GUIDE') WRITE(MONIOU,*) 'SEE KEYWORD: OBSLEV' STOP ENDIF THCKOB(I) = THICK( OBSLEV(I) ) ENDDO #if __AUGERHIST__ IF ( THCKOB(NOBSLV)+SAMPTH .GT. THICK(0.D0) ) THEN WRITE(MONIOU,1211) NOBSLV,OBSLEV(NOBSLV) 1211 FORMAT(' UNALLOWED CHOICE OF OBSLEV ',/,' OBSERVATION LEVEL ', * I2,' IS AT ',F12.3,' CM, WHICH IS LESS THAN 1 G/CM^2', * ' ABOVE SEA LEVEL',/,/,' PLEASE READ THE USERS GUIDE') WRITE(MONIOU,*) 'SEE KEYWORD: OBSLEV' STOP ENDIF #endif C WRITE OBSERVATION LEVELS TO HEADER (IN CM) #if __ANAHIST__ || __AUGERHIST__ RUNH(5) = 1. EVTH(47) = 1. RUNH(5+1) = OBSLEV(NOBSLV) EVTH(47+1) = OBSLEV(NOBSLV) #else RUNH(5) = REAL( NOBSLV ) EVTH(47) = REAL( NOBSLV ) DO I = 1, NOBSLV RUNH(5+I) = OBSLEV(I) EVTH(47+I) = OBSLEV(I) ENDDO #endif #if __STACKIN__ C FIRST INTERACTION HEIGHT MUST BE SPECIFIED IF ( .NOT. FIX1I ) THEN WRITE(MONIOU,1122) 1122 FORMAT(' FIXHEI MUST BE SPECIFIED WITH THE STACKIN OPTION',/,/, * ' PLEASE READ THE USERS GUIDE') WRITE(MONIOU,*) 'SEE KEYWORD: FIXHEI' WRITE(MONIOU,*) 'SEE ALSO OPTION: STACKIN' STOP ENDIF #endif #if __NUPRIM__ C FIRST INTERACTION HEIGHT MUST BE SPECIFIED IF ( .NOT. FIX1I ) THEN WRITE(MONIOU,1222) 1222 FORMAT(' FIXHEI SHOULD BE SPECIFIED WITH THE NUPRIM OPTION',/,/, * ' PLEASE READ THE USERS GUIDE') WRITE(MONIOU,*) 'SEE KEYWORD: FIXHEI' WRITE(MONIOU,*) 'SEE ALSO OPTION: NUPRIM' STOP ENDIF #endif C FIRST INTERACTION HEIGHT FIXED ? IF ( FIX1I ) THEN IF ( FIXHEI .GE. HLAY(6) ) THEN WRITE(MONIOU,122) FIXHEI,HLAY(6) 122 FORMAT(' UNALLOWED CHOICE OF FIXHEI ',/,' FIRST INTERACTION ', * 'IS FIXED AT ',F12.3,' CM, WHICH IS ABOVE ', * F12.3,' CM',/,/,' PLEASE READ THE USERS GUIDE') WRITE(MONIOU,*) 'SEE KEYWORD: FIXHEI' STOP ENDIF #if !__UPWARD__ IF ( FIXHEI .LE. OBSLEV(NOBSLV) ) THEN WRITE(MONIOU,123) FIXHEI,OBSLEV(NOBSLV) 123 FORMAT(' UNALLOWED CHOICE OF FIXHEI ',/,' FIRST INTERACTION ', * 'IS FIXED AT ',F12.3,' CM, ',/,' WHICH IS BELOW ', * 'LOWEST OBSERVATION LEVEL AT ',F12.3,' CM' * ,/,/,' PLEASE READ THE USERS GUIDE') WRITE(MONIOU,*) 'SEE KEYWORD: FIXHEI' STOP ENDIF #endif #if __CURVED__ && !__STACKIN__ IF ( PRMPAR(0) .LE. 3.D0 ) THEN WRITE(MONIOU,124) 124 FORMAT(' UNALLOWED CHOICE OF FIXHEI IN CURVED VERSION ',/, * ' THE FIRST INTERACTION CANNOT BE FIXED FOR PRIMARY ', * 'PARTICLE TYPE ',I5,/,/,' PLEASE READ THE USERS GUIDE') WRITE(MONIOU,*) 'SEE KEYWORD: FIXHEI' STOP ENDIF #endif WRITE(MONIOU,507) FIXHEI 507 FORMAT(' HEIGHT OF FIRST INTERACTION IS FIXED TO ',1P,E15.7, * ' CM') IF ( N1STTR .GE. 1 .AND. N1STTR .LE. 3 ) THEN IF ( PRMPAR(0) .LE. 3.D0 ) THEN WRITE(MONIOU,516) INT( PRMPAR(0) ) 516 FORMAT(' TARGET OF FIRST INTERACTION CANNOT BE FIXED FOR ', * 'PRIMARY TYPE ',I5,/,/,' PLEASE READ THE USERS GUIDE') WRITE(MONIOU,*) 'SEE KEYWORD: FIXHEI' STOP ENDIF IF ( N1STTR .EQ. 1 ) THEN WRITE(MONIOU,*) 'TARGET OF FIRST INTERACTION IS NITROGEN' ELSEIF ( N1STTR .EQ. 2 ) THEN WRITE(MONIOU,*) 'TARGET OF FIRST INTERACTION IS OXYGEN' ELSEIF ( N1STTR .EQ. 3 ) THEN WRITE(MONIOU,*) 'TARGET OF FIRST INTERACTION IS ARGON' ENDIF ELSE WRITE(MONIOU,*) * 'TARGET OF FIRST INTERACTION IS CHOSEN AT RANDOM' N1STTR = 0 ENDIF ELSE FIXHEI = 0.D0 #if !__INTTEST__ WRITE(MONIOU,*) 'HEIGHT OF FIRST INTERACTION IS CHOSEN RANDOMLY' #endif IF ( N1STTR .EQ. 0 ) THEN WRITE(MONIOU,*) 'TARGET OF FIRST INTERACTION IS AT RANDOM' ELSEIF ( N1STTR .EQ. 1 ) THEN WRITE(MONIOU,*) 'TARGET OF FIRST INTERACTION IS NITROGEN' ELSEIF ( N1STTR .EQ. 2 ) THEN WRITE(MONIOU,*) 'TARGET OF FIRST INTERACTION IS OXYGEN' ELSEIF ( N1STTR .EQ. 3 ) THEN WRITE(MONIOU,*) 'TARGET OF FIRST INTERACTION IS ARGON' ENDIF ENDIF C STARTING ALTITUDE WITHIN ATMOSPHERE? IF ( THICK0 .LT. 0.D0 ) THEN WRITE(MONIOU,130) THICK0 130 FORMAT(' UNALLOWED STARTING ALTITUDE WITH NEGATIVE MASS OVERLAY' * ,E12.3,/,/,' PLEASE READ THE USERS GUIDE') WRITE(MONIOU,*) 'SEE KEYWORD: FIXCHI' STOP ENDIF #if __UPWARD__ IF ( THETPR(1) .GT. 90.D0 .OR. THETPR(2) .GT. 90.D0 ) THEN C UPWARD GOING PRIMARY PARTICLE IF ( THICK0 .LE. THCKOB(NOBSLV) ) THEN WRITE(MONIOU,132) THICK0 132 FORMAT(' UNALLOWED STARTING ALTITUDE AT ',F12.3,' G/CM**2', * ' WHICH IS ABOVE OBSERVATION LEVEL',/,/, * ' PLEASE READ THE USERS GUIDE') WRITE(MONIOU,*) 'SEE KEYWORD: FIXCHI' STOP ELSEIF ( THICK0 .GE. THICK( 0.D0 ) ) THEN WRITE(MONIOU,133) THICK0 133 FORMAT(' UNALLOWED STARTING ALTITUDE BELOW THE SEA LEVEL' * ,E12.3,/,/,' PLEASE READ THE USERS GUIDE') WRITE(MONIOU,*) 'SEE KEYWORD: FIXCHI' STOP ENDIF ELSE C DOWNWARD GOING PRIMARY PARTICLE IF ( THICK0 .GE. THCKOB(NOBSLV) ) THEN WRITE(MONIOU,131) THICK0 131 FORMAT(' UNALLOWED STARTING ALTITUDE AT ',F12.3,' G/CM**2', * ' WHICH IS BELOW LOWEST OBSERVATION LEVEL',/,/, * ' PLEASE READ THE USERS GUIDE') WRITE(MONIOU,*) 'SEE KEYWORD: FIXCHI' STOP ENDIF ENDIF #else IF ( THICK0 .GE. THCKOB(NOBSLV) ) THEN WRITE(MONIOU,131) THICK0 131 FORMAT(' UNALLOWED STARTING ALTITUDE AT ',F12.3,' G/CM**2', * ' WHICH IS BELOW LOWEST OBSERVATION LEVEL',/,/, * ' PLEASE READ THE USERS GUIDE') WRITE(MONIOU,*) 'SEE KEYWORD: FIXCHI' STOP ENDIF #endif H0 = HEIGH( THICK0 ) #if !__INTTEST__ #if !__STACKIN__ IF ( THICK0 .EQ. 0.D0 ) THEN WRITE(MONIOU,518) H0,THICK0 WRITE(MONIOU,*) ' WHICH IS AT TOP OF ATMOSPHERE' ELSE WRITE(MONIOU,518) H0, THICK0 ENDIF 518 FORMAT(' STARTING ALTITUDE AT ',F15.2,' CM (=', * F10.2,' G/CM**2)') #endif WRITE(MONIOU,202) 202 FORMAT(/,' OBSERVATION LEVEL # IN CM AND IN G/CM**2 ') DO I = 1, NOBSLV WRITE(MONIOU,203) I,OBSLEV(I),THCKOB(I) 203 FORMAT(9X,I2,1P,2E21.8) ENDDO #endif #if __CURVED__ && __UPWARD__ IF ( THETPR(1) .GT. 90.D0 ) THEN IF ( FIX1I .AND. FIXHEI .LT. OBSLEV(1) ) THEN C ANGLE WHERE DETECTOR MAY NOT BE HIT FROM UPWARD SHOWER AXIS DELTA = ACOS( (C(1)+FIXHEI) / (C(1)+OBSLEV(1)) ) ELSEIF ( H0 .LT. OBSLEV(1) ) THEN DELTA = ACOS( (C(1)+H0) / (C(1)+OBSLEV(1)) ) ELSE WRITE(MONIOU,*) WRITE(MONIOU,*) 'UNALLOWED COMBINATION OF STARTING ALTITUDE,', * ' OBSERVATION LEVEL AND ZENITH ANGLE FOR UPWARD SHOWER' WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORD: FIXHEI, FIXCHI, OBSLEV AND ', * 'THETAP' STOP ENDIF DELTA = DELTA * 180.D0 / PI IF ( THETPR(1) .LT. 90.D0+DELTA ) THEN WRITE(MONIOU,*) 'UNALLOWED CHOICE OF THETPR =', * SNGL(THETPR(1)),'DEGREES ' WRITE(MONIOU,*) 'FOR CHOSEN OBSERVATION LEVEL AND STARTING ', * 'ALTITUDE THETAP MUST BE' WRITE(MONIOU,*) ' AT MINIMUM',SNGL(90.D0+DELTA),'DEGREES' WRITE(MONIOU,*) WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORDS: FIXHEI, FIXCHI, OBSLEV AND ', * 'THETAP' STOP ENDIF ELSEIF ( FIMPCT ) THEN C SKIMMING IMPACT WITH HORIZONTAL SHOWER AXIS ABOVE DETECTOR C BORDER OF ATMOSPHERE IS AT HLAY(6) IF ( HIMPACT(1) .LT. OBSLEV(1) ) THEN WRITE(MONIOU,*) WRITE(MONIOU,*) 'UNALLOWED CHOICE OF SKIMMING ALTITUDE AND ', * 'OBSERVATION LEVEL' WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORD: IMPACT' STOP ENDIF IF ( (FIX1I .AND. FIXHEI .LT. HIMPACT(2)) .OR. * (HEIGH( THICK0 ) .LT. HIMPACT(2)) ) THEN WRITE(MONIOU,*) WRITE(MONIOU,*) 'UNALLOWED CHOICE OF STARTING ALTITUDE ', * 'OR FIRST INTERACTION HEIGHT AND SKIMMING ALTITUDE' WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORDS: FIXHEI, FIXCHI, AND IMPACT' STOP ENDIF FIXINC = .FALSE. ENDIF #endif #if __PARALLEL__ C XMAX FIT CAN NOT BE PERFORMED IF SOME PARTICLES ARE SENT IN ECUT IF ( FLGFIT .AND. ( FECTOUT .OR. JCOUNT .GT.1 ) ) THEN FLGFIT = .FALSE. WRITE(MONIOU,*) ' ECUT FILE : NO LONG. DISTRIBUTION TO FIT' ENDIF #endif #if !__SLANT__ C LONGITUDINAL SHOWER DEVELOPMENT IF ( LLONGI ) THEN THSTEP = NINT( THSTEP ) THSTEP = MAX( 1.D0, THSTEP ) THSTEP = MIN( THSTEP, DBLE(LNGMAX) ) THSTPI = 1.D0/THSTEP NSTEP = INT( THCKOB(NOBSLV)*THSTPI ) + 1 #if __UPWARD__ NSTEP = MAX( NSTEP, INT( THICK0*THSTPI )+1 ) IF ( FIX1I ) THEN NSTEP = MAX( NSTEP, INT( THICK( FIXHEI )*THSTPI ) + 1 ) ENDIF #endif IF ( NSTEP .GE. LNGMAX ) THEN NSTEP = LNGMAX THSTEP = THCKOB(NOBSLV)/(NSTEP+1) THSTPI = 1.D0/THSTEP WRITE(MONIOU,*) 'LONGITUDINAL SHOWER SAMPLING MODIFIED' ENDIF WRITE(MONIOU,925) NSTEP,THSTEP 925 FORMAT(/,' LONGITUDINAL SHOWER DEVELOPMENT:',/, * ' SHOWER IS SAMPLED IN ',I5, * ' STEPS OF ',F6.1,' G/CM**2') C GET HEIGHT VALUES IN CM FOR USE IN EGS IF ( DEBUG ) WRITE(MDEBUG,926) 926 FORMAT(8X,'STEP',8X,'CM', 20X,'G/CM**2') DO I = 0, NSTEP HLONG(I) = HEIGH( I*THSTEP ) IF ( DEBUG ) WRITE(MDEBUG,927) I,HLONG(I),I*THSTEP 927 FORMAT(8X,I4,3X,F16.7,8X,F16.7) ENDDO IF ( FLGFIT ) THEN WRITE(MONIOU,*) * ' FIT TO CHARGED PARTICLE LONG. DISTRIBUTION ENABLED' ELSE WRITE(MONIOU,*) * ' FIT TO CHARGED PARTICLE LONG. DISTRIBUTION DISABLED' ENDIF WRITE(MONIOU,*) ENDIF #endif C CONVERT ANGLE IN RAD THETPR(1) = THETPR(1)*PI/180.D0 THETPR(2) = THETPR(2)*PI/180.D0 PHIPR(1) = PHIPR(1) *PI/180.D0 PHIPR(2) = PHIPR(2) *PI/180.D0 C----------------------------------------------------------------------- #if !__INTTEST__ C CHECK INPUT OF ENERGY CUTS #if __URQMD__ IF ( ELCUT(1) .LT. 0.3D0 ) THEN #elif __FLUKA__ C FLUKA CAN TREAT HADRONS (EXCEPT ANTI-NEUTRONS) DOWN TO 20 MEV IF ( ELCUT(1) .LT. 0.02D0 ) THEN #else IF ( ELCUT(1) .LT. 0.05D0 ) THEN #endif WRITE(MONIOU,*) 'ELCUT(1) SELECTED INCORRECT TO',ELCUT(1),' GEV' WRITE(MONIOU,*) WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORD: ECUTS' STOP ENDIF IF ( ELCUT(2) .LT. 0.01D0 ) THEN WRITE(MONIOU,*) 'ELCUT(2) SELECTED INCORRECT TO',ELCUT(2),' GEV' WRITE(MONIOU,*) WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORD: ECUTS' STOP ENDIF IF ( ELCUT(3) .LT. 5.D-5 ) THEN WRITE(MONIOU,*) 'ELCUT(3) SELECTED INCORRECT TO',ELCUT(3),' GEV' WRITE(MONIOU,*) WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORD: ECUTS' STOP ENDIF IF ( ELCUT(4) .LT. 5.D-5 ) THEN WRITE(MONIOU,*) 'ELCUT(4) SELECTED INCORRECT TO',ELCUT(4),' GEV' WRITE(MONIOU,*) WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORD: ECUTS' STOP ENDIF IF ( ELCUT(1) .GT. LLIMIT .AND. PRMPAR(0) .GE. 7.D0 ) THEN WRITE(MONIOU,*) 'ELCUT(1) SELECTED INCORRECT < LLIMIT= ',LLIMIT WRITE(MONIOU,*) WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORD: ECUTS' STOP ENDIF IF ( ELCUT(2) .GT. LLIMIT .AND. * (PRMPAR(0) .EQ. 5.D0 .OR. PRMPAR(0) .EQ. 6.D0) ) THEN WRITE(MONIOU,*) 'ELCUT(2) SELECTED INCORRECT < LLIMIT= ',LLIMIT WRITE(MONIOU,*) WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORD: ECUTS' STOP ENDIF IF ( ELCUT(3) .GT. LLIMIT .AND. * (PRMPAR(0) .EQ. 2.D0 .OR. PRMPAR(0) .EQ. 3.D0) ) THEN WRITE(MONIOU,*) 'ELCUT(3) SELECTED INCORRECT < LLIMIT= ',LLIMIT WRITE(MONIOU,*) WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORD: ECUTS' STOP ENDIF IF ( ELCUT(4) .GT. LLIMIT .AND. PRMPAR(0) .EQ. 1.D0 ) THEN WRITE(MONIOU,*) 'ELCUT(4) SELECTED INCORRECT < LLIMIT= ',LLIMIT WRITE(MONIOU,*) WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORD: ECUTS' STOP ENDIF #endif #if __THIN__ IONES = MOD(MODETHN,10) ITENS = MOD(MODETHN,100) - IONES IHUNS = MODETHN - ITENS - IONES IF ( ITENS .NE. 0 .AND. IHUNS .NE. 0 ) THEN C DEVIATING THINING BOTH FOR EM AND HADRONIC SPECIFIED WRITE(MONIOU,*) 'ILLEGAL SPECIFICATION OF THINNING' WRITE(MONIOU,*) 'DO NOT SPECIFY THINEM AND THINH SIMULTANEOUSLY' WRITE(MONIOU,*) WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORDS: THIN, THINEM, THINH' STOP ELSEIF ( IONES .EQ. 0 .AND. * (ITENS .NE. 0 .OR. IHUNS .NE. 0) ) THEN C DEVIATING THINNING SPECIFIED WITHOUT THIN SPECIFICATION WRITE(MONIOU,*) 'ILLEGAL SPECIFICATION OF THINNING' WRITE(MONIOU,*) 'THINEM OR THINH SPECIFIED WITHOUT THIN' WRITE(MONIOU,*) WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORDS: THIN, THINEM, THINH' STOP ELSEIF ( IONES .NE. 0 ) THEN C NORMAL THINNING SPECIFIED, VARIABLES EFRCTHN AND WMAX0 HAVE C BEEN READ; THINRAT=1, WEITRAT=1 BY DEFAULT. IF ( IHUNS .NE. 0 ) THEN C DEVIATING HADRONIC THINNING SPECIFIED, C VARIABLES THINRATH AND WEITRATH HAVE BEEN READ; C CALCULATE NEEDED VARIABLES THINRAT = THINRATH EFRCTHN = EFRCTHN / THINRATH WEITRAT = WEITRATH WMAX0 = WMAX0 / WEITRATH ELSEIF ( ITENS .NE. 0 ) THEN C DEVIATING EM THINNING SPECIFIED, C VARIABLES THINRAT AND WEITRAT HAVE BEEN READ AS THEY ARE USED ENDIF C THINNING SELECTED WITHOUT THIN SPECIFICATION #if __CONEX__ ELSEIF( .NOT. FCXWMX )THEN WRITE(MONIOU,*) 'NO SPECIFICATION OF SAMPLING WEIGHT DETECTED' WRITE(MONIOU,*)'THIN OR CXWMX SHOULD BE SPECIFIED IN INPUT CARD' WRITE(MONIOU,*) 'TO AVOID RUN WITH BAD WEIGHT PARAMETERS' WRITE(MONIOU,*) WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORDS: THIN, THINEM, THINH, CXWMX' #else ELSE WRITE(MONIOU,*) 'NO SPECIFICATION OF THINNING DETECTED' WRITE(MONIOU,*) 'THIN SHOULD BE SPECIFIED IN INPUT CARD' WRITE(MONIOU,*) 'TO AVOID RUN WITH BAD THINNING PARAMETERS' WRITE(MONIOU,*) WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORDS: THIN, THINEM, THINH' #endif STOP ENDIF C IF ( WEITRAT .GT. 1.D6 .OR. WEITRAT .LT. 1.D-4 ) THEN WRITE(MONIOU,*) 'ILLEGAL CHOICE OF RATIO ', * 'WEIGHTLIMIT_EM/WEIGHTLIMIT_HADR , WHICH IS = ',WEITRAT WRITE(MONIOU,*) WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORD: THIN, THINEM, THINH' STOP ENDIF C IF ( EFRCTHN*ULIMIT .LT. ELCUT(1) .AND. * EFRCTHN*ULIMIT .LT. ELCUT(2) .AND. * EFRCTHN*ULIMIT*THINRAT .LT. ELCUT(3) .AND. * EFRCTHN*ULIMIT*THINRAT .LT. ELCUT(4) ) THEN WRITE(MONIOU,*) 'THRESHOLD FOR THINNING SMALLER THAN ELCUT' WRITE(MONIOU,*) ' ' #if !__CONEX__ ELSE #else ENDIF #endif #if !__STACKIN__ WRITE(MONIOU,702) EFRCTHN*THINRAT, EFRCTHN 702 FORMAT(' ENERGY FRACTION FOR EM THINNING = ',1P, E11.4,/, * ' AND FOR HADRONIC THINNING = ',E11.4) #endif #if __CONEX__ IF ( FCXWMX )THEN C FOR HADRON WMAX0 = LLIMIT * CXWMX(1) WMAX = MAX( 1.D0,WMAX0 ) C FOR EM WMAXE0 = LLIMIT * CXWMX(3) WMAXEM = MAX( 1.D0,WMAXE0 ) IF ( ( WMAX .GT. 1.D20 ) .AND. * ( WMAXEM .GT. 1.D20 ) ) THEN WLIM = .FALSE. EVTH(150) = 0. EVTH(151) = 0. ELSE WLIM = .TRUE. #if !__STACKIN__ WRITE(MONIOU,*) 'HAD.WEIGHTS ARE LIMITED TO MAX.',SNGL(WMAX) WRITE(MONIOU,*) 'EM WEIGHTS ARE LIMITED TO MAX.',SNGL(WMAXEM) EVTH(150) = WMAX EVTH(151) = WMAXEM #else EVTH(150) = 0. EVTH(151) = 0. #endif ENDIF ELSE #endif WMAXE0 = WMAX0 * WEITRAT IF ( (WMAX0 .GT. 1.D20 .OR. WMAX0 .LT. .1D0) .AND. * (WMAXE0 .GT. 1.D20 .OR. WMAXE0 .LT. .1D0) ) THEN WLIM = .FALSE. EVTH(150) = 0. EVTH(151) = 0. ELSE WLIM = .TRUE. #if !__STACKIN__ #if __CONEX__ IF ( FCXCE .AND. CXWMX(1) .GT. 0.D0 * .AND. CXWMX(3) .GT. 0.D0 ) THEN WRITE(MONIOU,*) 'HAD.WEIGHTS ARE LIMITED TO MAX.' * ,SNGL(MAX( 1.D0, CXWMX(1) * LLIMIT )) WRITE(MONIOU,*) 'EM WEIGHTS ARE LIMITED TO MAX.' * ,SNGL(MAX( 1.D0, CXWMX(3) * LLIMIT )) ELSE #endif WRITE(MONIOU,*) 'HAD.WEIGHTS ARE LIMITED TO MAX.' * ,SNGL(WMAX0) WRITE(MONIOU,*) 'EM WEIGHTS ARE LIMITED TO MAX.' * ,SNGL(WMAXE0) #if __CONEX__ ENDIF #endif EVTH(150) = WMAX0 EVTH(151) = WMAXE0 #else EVTH(150) = 0. EVTH(151) = 0. #endif WMAX = WMAX0 WMAXEM = WMAXE0 ENDIF ENDIF DO I = 274, 312 RUNH(I) = 0. ENDDO C LOOK FOR CORECUT RSP. RADIAL THINNING IF ( RMAX .LE. 0.D0 ) THEN RLIM = .FALSE. IF ( RCUT .GT. 0.D0 ) THEN WRITE(MONIOU,*) 'NO RADIAL THINNING, BUT PARTICLES ARE ', * 'DISCARDED FOR RADIUS < ',SNGL(RCUT),' CM' EVTH(152) = RCUT ELSE EVTH(152) = 0. ENDIF ELSE ! RMAX > 0. IF ( RCUT .GT. 0.D0 ) THEN RLIM = .FALSE. WRITE(MONIOU,*) 'NO RADIAL THINNING, BUT PARTICLES ARE ', * 'DISCARDED FOR RADIUS < ',SNGL(RCUT),' CM' EVTH(152) = RCUT ELSE RLIM = .TRUE. RMAX2 = RMAX**2 WRITE(MONIOU,*) 'RADIAL THINNING FOR RADIUS < ',SNGL(RMAX), * ' CM' EVTH(152) = RMAX ENDIF ENDIF #else /* __THIN__ */ IF ( RCUT .LE. 0.D0 ) THEN EVTH(152) = 0. ELSE WRITE(MONIOU,*) 'PARTICLES ARE DISCARDED FOR RADIUS < ', * SNGL(RCUT),' CM' EVTH(152) = RCUT ENDIF WRITE(MONIOU,*) ' ' #endif WRITE(MONIOU,703) ECTMAP,ELCUT 703 FORMAT(' PARTICLES WITH LORENTZ FACTOR LARGER THAN',1P,E15.4, * ' ARE PRINTED OUT',/,' SHOWER PARTICLES ENERGY CUT :',/, * ' FOR HADRONS : ',E15.4,' GEV',/, * ' FOR MUONS : ',E15.4,' GEV',/, * ' FOR ELECTRONS : ',E15.4,' GEV',/, * ' FOR GAMMAS : ',E15.4,' GEV',/,/) DO I = 1, 4 RUNH(20+I) = ELCUT(I) EVTH(60+I) = ELCUT(I) ENDDO C----------------------------------------------------------------------- C PARAMETERS OF EARTH MAGNETIC FIELD OF MIDDLE EUROPE C +X DIRECTION IS NORTH, +Y DIRECTION IS EAST, +Z DIRECTION IS DOWN BVAL = SQRT( BX**2 + BZ**2 ) IF ( BVAL .EQ. 0.D0 ) THEN WRITE(MONIOU,*) ' ' WRITE(MONIOU,*) '===============================' WRITE(MONIOU,*) 'MAGNETIC FIELD MUST NOT BE ZERO' WRITE(MONIOU,*) '===============================' WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORD: MAGNET' STOP ENDIF C BNORM HAS DIMENSIONS OF MEV/CM BNORM = BVAL * C(25) * 1.D-16 C BNORMC HAS DIMENSIONS OF GEV/CM BNORMC = BNORM * 1.D-3 SINB = BZ / BVAL COSB = BX / BVAL WRITE(MONIOU,*) 'EARTH MAGNETIC FIELD STRENGTH IS ',SNGL(BVAL), * ' MICROTESLA' WRITE(MONIOU,*) ' WITH INCLINATION ANGLE ', * SNGL( ASIN( SINB )*180.D0/PI ),' DEGREES' IF ( BVAL .GE. 10000.D0 ) THEN WRITE(MONIOU,*) 'YOU WANT TO MAGNETIZE THE GALAXY ?' WRITE(MONIOU,*) WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORD: MAGNET' STOP ENDIF C LIMITING FACTOR FOR STEP SIZE OF ELECTRON IN MAGNETIC FIELD #if __CERENKOV__ && __IACT__ C LIMIT IN DEFLECTION ANGLE IS 2.5 MILLIRADIAN = 0.143 DEG C WE USE A LIMIT OF ABOUT 0.05 DEG (APPROX. 1 MILLIRAD) BLIMIT = 0.001D0 / BNORM #else C WE USE A LIMIT OF ABOUT 11.4 DEG (0.2 RAD) BLIMIT = 0.2D0 / BNORM #endif EVTH(71) = BX EVTH(72) = BZ C ANGLE BETWEEN ARRAY X-DIRECTION AND MAGNETIC NORD C POSITIV, IF X-DIRECTION OF ARRAY POINTS TO WESTERN DIRECTION ARRANR = ARRANG * PI / 180.D0 COSANG = COS( ARRANR ) SINANG = SIN( ARRANR ) EVTH(93) = ARRANR IF ( ARRANG .NE. 0.D0 ) THEN WRITE(MONIOU,*) WRITE(MONIOU,704) ARRANG 704 FORMAT(' DETECTOR COORDINATE SYSTEM IS ROTATED WRT.', * ' NORTH BY',F9.3,' DEGREES') #if __AUGERHIT__ ELSE WRITE(MONIOU,*) WRITE(MONIOU,*) 'DETECTOR COORDINATE SYSTEM IS NOT ROTATET, ', * 'THIS IS NOT CONSISTENT WITH AUGER EXPERIMENT' WRITE(MONIOU,*) '------------------------------===----------', * '--------===---------------------------------' #endif ENDIF #if __CERENKOV__ C----------------------------------------------------------------------- C DEFINE CHERENKOV ARRAY C NYMBER OF DETECTOR STATIONS NCERX = MAX( 1, NCERX ) NCERY = MAX( 1, NCERY ) C DIMENSIONS OF EACH DETECTOR STATION ACERX = ABS(ACERX) ACERY = ABS(ACERY) C GRID SPACINGS OF DETECTOR IF ( NCERX .GT. 1 ) THEN DCERX = MAX( 1.D0, ABS(DCERX) ) ELSE DCERX = 0.001D0 ENDIF IF ( NCERY .GT. 1 ) THEN DCERY = MAX( 1.D0, ABS(DCERY) ) ELSE DCERY = 0.001D0 ENDIF C MAXIMUM EXTENSIONS OF ARRAY XCMAX = (ACERX + (NCERX-1) * DCERX) * 0.5D0 YCMAX = (ACERY + (NCERY-1) * DCERY) * 0.5D0 DCERXI = 1.D0/DCERX EPSX = ACERX * 0.5D0 * DCERXI DCERYI = 1.D0/DCERY EPSY = ACERY * 0.5D0 * DCERYI IF ( MOD(NCERX,2) .EQ. 0 ) THEN FCERX = -0.5D0 ELSE FCERX = 0.D0 ENDIF IF ( MOD(NCERY,2) .EQ. 0 ) THEN FCERY = -0.5D0 ELSE FCERY = 0.D0 ENDIF C MULTIPLE SCATTERING LENGTH FACTOR IF ( STEPFC .NE. 1.D0 ) THEN STEPFC = 1.D0 WRITE(MONIOU,*) 'INPRM : STEPFC CORRECTED TO 1.D0' EVTH(95) = STEPFC ENDIF #if __IACT__ CALL TELSHW #else if (NCERTEL.ge.1) then IF ( ICERML .GE. 1 ) THEN DO I = 1, ICERML WRITE(MONIOU,*) * 'MULTI-CORE #',I,': ',CERXOS(I),CERYOS(I) ENDDO ENDIF DO I = 1, NCERTEL WRITE(MONIOU,*) 'CHERENKOV TELESCOPE #', I, * ', POS=', CERTELX(I),CERTELY(I), * CERTELZ(I),', R=', CERTELR(I), * ', ID=', CERTELID(I) ENDDO else WRITE(MONIOU,472) ACERX,ACERY, DCERX,DCERY,NCERX,NCERY 472 FORMAT(/,' CHERENKOV ARRAY:',/,5X, * ' CHERENKOV STATIONS ARE ',F10.2,' * ',F10.2,' CM**2 LARGE',/, * 5X,' THE GRID SPACING IS ',F10.2,' AND ',F10.2,' CM',/, * 5X,' THERE ARE ',I3,' * ',I3,' STATIONS IN X/Y DIRECTIONS',/, * 5X,' THE CHERENKOV ARRAY IS CENTERED AROUND (0., 0.)',/) endif #endif IF ( NOBSLV .GT. 1 ) WRITE(MONIOU,473) OBSLEV(NOBSLV)*0.01 473 FORMAT(/,' CHERENKOV RADIATION IS REGISTERED ONLY FOR LOWEST', * ' OBSERVATION LEVEL AT ', F10.1,' METER',/) #endif #if __CERENKOV__ || __AUGERHIST__ || __AUGCERLONG__ C CALCULATE CHERENKOV YIELD FACTOR FROM WAVELENGTH BAND #if __IACT__ && !__CEFFIC__ IF ( WAVLGL .LT. 100.D0 .OR. WAVLGU .GT. 2000.D0 * .OR. WAVLGL .GE. WAVLGU ) THEN #else IF ( WAVLGL .LT. 100.D0 .OR. WAVLGU .GT. 700.D0 * .OR. WAVLGL .GE. WAVLGU ) THEN #endif WRITE(MONIOU,*) 'CHERENKOV WAVELENGTH BAND FROM ',SNGL(WAVLGL), * ' TO ',SNGL(WAVLGU),' NANOMETER' WRITE(MONIOU,*) ' IS OUT OF VALIDITY RANGE' WRITE(MONIOU,*) WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORD: CWAVLG' STOP ENDIF WRITE(MONIOU,*) 'CHERENKOV WAVELENGTH BAND FROM ',SNGL(WAVLGL), * ' TO ',SNGL(WAVLGU),' NANOMETER' C WAVELENGTH IS CONVERTED FROM NM TO CM CYIELD = (WAVLGU-WAVLGL)/(WAVLGL*WAVLGU) * 2.D7 * PI / C(50) C CALCULATE FACTOR FOR ETA DENSITY NORML. C (ETA AT SEA LEVEL = 0.283D-3 FOR U.S. STDANDARD ATMOSPHERE) ETADSN = 0.283D-3 * CATM0(1,1) / BATM0(1,1) #endif #if __AUGERHIST__ || __AUGCERLONG__ IF ( CERSIZ .GT. 0.D0 ) THEN WRITE(MONIOU,*) 'CHERENKOV BUNCH SIZE IS SET TO ',CERSIZ ELSE WRITE(MONIOU,*) 'CHERENKOV BUNCH SIZE IS SET TO ',CERSIZ, * ', BUT MUST BE NON-ZERO AND POSITIV' STOP ENDIF #endif #if __CERENKOV__ IF ( CERSIZ .GT. 0.D0 ) THEN WRITE(MONIOU,*) 'CHERENKOV BUNCH SIZE IS SET TO ',CERSIZ ELSE WRITE(MONIOU,*) 'CHERENKOV BUNCH SIZE IS CALCULATED FOR EACH ', * 'SHOWER' ENDIF IF ( MCERFI .EQ. 0 ) THEN #if __COMPACT__ IF ( COMOUT ) THEN WRITE(MONIOU,474) 474 FORMAT(' ==============================================', /,' ***** CHANGED BECAUSE OF COMPACT OUTPUT: *****', * /,' CHERENKOV PHOTONS ARE WRITTEN TO SEPARATE FILE' * /,' ==============================================') MCERFI = 1 ELSE WRITE(MONIOU,*) 'CHERENKOV PHOTONS ARE WRITTEN TO PARTICLE ', * 'OUTPUT FILE' ENDIF #else WRITE(MONIOU,*) 'CHERENKOV PHOTONS ARE WRITTEN TO PARTICLE ', * 'OUTPUT FILE' #endif ELSEIF ( MCERFI .EQ. 1 ) THEN WRITE(MONIOU,*) 'CHERENKOV PHOTONS ARE WRITTEN TO SEPARATE FILE' ELSEIF ( MCERFI .GE. 2 ) THEN WRITE(MONIOU,*) 'CHERENKOV PHOTONS ARE WRITTEN TO SEPARATE FILE' #if __THIN__ * ,' WITH WAVELENGTH INSTEAD OF WEIGHT' #endif IF ( MCERFI .GE. 3 ) THEN WRITE(MONIOU,*) 'CHERENKOV PHOTONS ARE WRITTEN WITH DISTANCE', * ' OF EMISSION POINT TO DETECTOR ARRAY CENTER', * ' (INSTEAD OF EMISSION HEIGHT)' ENDIF ENDIF #if !__IACT__ C SCATTERING OF CENTER OF CHERENKOV ARRAY RELATIVE TO SHOWER AXIS ICERML = MIN( 20, MAX( 1, ICERML ) ) IF ( ICERML .GE. 1 .AND. ( XSCATT .GT. 0.D0 * .OR. YSCATT .GT. 0.D0 ) ) THEN XSCATT = ABS(XSCATT) YSCATT = ABS(YSCATT) WRITE(MONIOU,5225) ICERML,XSCATT,YSCATT 5225 FORMAT(' DEFINE MULTIPLE CHERENKOV ARRAYS TO USE EACH', * ' SHOWER SEVERAL TIMES'/ ' USE EACH EVENT ',I2,' TIMES'/ * ' THE EVENTS ARE SCATTERED QUASI RANDOMLY IN THE RANGE '/ * 18X,' X = +- ',F10.2,' Y = +- ',F10.2,' CM' ) XCMAXS = XCMAX + XSCATT YCMAXS = YCMAX + YSCATT ENDIF #endif C STORE CHERENKOV PARAMETERS IN EVENTHEADER EVTH(86) = REAL( NCERX ) EVTH(87) = REAL( NCERY ) EVTH(88) = DCERX EVTH(89) = DCERY EVTH(90) = ACERX EVTH(91) = ACERY EVTH(92) = REAL( MCERFI ) EVTH(96) = WAVLGL EVTH(97) = WAVLGU EVTH(98) = REAL(ICERML) #if __CURVED__ C INITIALIZE REFRACTIVE INDEX TABLE CALL INRTAB #endif #if __CEFFIC__ || __CERWLEN__ CERNOR = WAVLGL * WAVLGU / (WAVLGU-WAVLGL) #endif #if __CEFFIC__ C INITIALIZE ATMOSPHERIC ABSORPTION AND EFFICIENCIES C THE CORRESPONDING TABLES ARE READ FROM EXTERNAL FILES C (SEE DESCRIPTION IN USER''S GUIDE) IF ( CERATA .OR. CERQEF .OR. CERMIR ) * CALL TPDINI( OBSLEV(NOBSLV) ) #endif #endif C----------------------------------------------------------------------- C ESTABLISH MUON CONSTANTS AND MUON CROSS-SECTION TABLES CALL MUPINI C FLAG FOR ADDITIONAL MUON INFORMATION IF ( FMUADD ) THEN WRITE(MONIOU,*) WRITE(MONIOU,*) 'ADDITIONAL INFORMATION ON MUON ORIGIN IS', * ' WRITTEN TO PARTICLE DATA FILE' EVTH(94) = 1. ELSE EVTH(94) = 0. ENDIF #if __EHISTORY__ C FLAG FOR ADDITIONAL EM INFORMATION IF ( PRMPAR(0) .LE. 3.D0 .AND. FEMADD ) THEN FEMADD = .FALSE. WRITE(MONIOU,*) 'SUPPRESS ADDITIONAL EM-PARTICLE INFO FOR ', * 'EM-INDUCED SHOWER' WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE ', * 'SEE KEYWORD: EMADDI' ENDIF IF ( FEMADD ) THEN WRITE(MONIOU,*) WRITE(MONIOU,*) 'HADRON ORIGIN OF ELECTROMAGNETIC SUBSHOWER IS', * ' WRITTEN TO PARTICLE DATA FILE' EVTH(160) = 1. ELSE EVTH(160) = 0. ENDIF #endif C FFLATOUT = .TRUE. MEANS FLAT GROUND AND CARTESIAN COORDINATES IN THE C OUTPUT FILE. WITHOUT CURVED IT IS ALWAYS THE CASE AND IN CASE OF C CURVED THE USER CAN CHOOSE TO FORCE IT (DEFAULT IS .FALSE.) EVTH(168) = 0. #if __CURVED__ IF ( .NOT. FFLATOUT ) THEN C FFLATOUT = .FALSE. MEANS CURVED GROUND AND PSEUDO-SPHERICAL C COORDINATES IN THE OUTPUT FILE. FROM X' AND Y' IN THE DAT FILE THETA C AND PHI CAN BE CALCULATED AS THETA=SQRT(X'**2+Y'**2)/(C(1)+OBSVEL(1)) C AND PHI=ATAN2(Y,X). FROM THETA AND PHI, THE CARTESIAN COORDINATES CAN C BE CALCULATED USING D=(C(1)+OBSVEL(1))*SIN(THETA) AS C X=D*COS(PHI) C Y=D*SIN(PHI) C Z=(C(1)+OBSVEL(1))*COS(THETA)-C(1) EVTH(168) = 1. ENDIF #endif C PRINTOUT OF INFORMATIONS FOR DEBUGGING IF ( DEBUG ) WRITE(MONIOU,484) MDEBUG 484 FORMAT(/,' ATTENTION ! DEBUGGING IS ACTIVE',/, * ' ====> DEBUG INFORMATION WRITTEN TO UNIT ',I3,/,/) #if __DYNSTACK__ || __REMOTECONTROL__ C write runheader to baack api call baack_modify_runh(RUNH, SIZEOF(RUNH)) #endif C----------------------------------------------------------------------- C WRITE RUNHEADER TO OUTPUT BUFFER #if __COMPACT__ IF ( COMOUT ) THEN CALL TOBUFS( RUNH, MAXBUF ) ELSE CALL TOBUF( RUNH,0 ) ENDIF #else #if __PARALLEL__ C WRRUNH SIGNALS THAT RUNH HAS BEEN WRITTEN OUT WRRUNH = .TRUE. #endif CALL TOBUF( RUNH,0 ) #endif #if __CERENKOV__ #if __IACT__ CALL TELRNH( RUNH ) #endif IF ( MCERFI .NE. 0 ) THEN DO I = 1, NCERBUF CALL TOBUFC( RUNH,0, I ) ENDDO ENDIF #endif #if __REMOTECONTROL__ CALL remotecontrol_push_runh(RUNH) #endif #if __PLOTSH2__ C CHECK PLOTSH SETTINGS IF ( PLX1 .GE. PLX2 .OR. PLY1 .GE. PLY2 * .OR. PLZ1 .GE. PLZ2 ) THEN WRITE(MONIOU,*) ' ILLEGAL PLOTTING AXIS DEFINITIONS.' WRITE(MONIOU,*) ' (I.E., LOWER BOUND > UPPER BOUND)' STOP ENDIF #endif C----------------------------------------------------------------------- #if __UNIX__ C WRITE DATA SET FOR INFORMATION BANK IF ( FDBASE ) THEN #if __DPMJET__ VERVEN = 3.0D0 #elif __EPOS__ || __NEXUS__ VERVEN = NEXVER #elif __QGSJET__ VERVEN = IQGSVER * 0.1D0 #elif __SIBYLL__ VERVEN = 2.3D0 #elif __VENUS__ VERVEN = DBLE(IVERVN) / 1000.D0 #else VERVEN = 0.D0 #endif C LONGITUDINAL FLAG (0=NO LONGI, 1=VERT. DEPTH, 2=SLANT DEPTH) IF ( LLONGI ) THEN #if __SLANT__ ILONG = 2 #else ILONG = 1 #endif ELSE ILONG = 0 ENDIF C SET ISO-FLAG (0=ISOBAR MODEL, 1=GHEISHA, 2=URQMD, 3=FLUKA) #if __FLUKA__ ISO = 3 #elif __GHEISHAD__ ISO = 1 #elif __URQMD__ ISO = 2 #else ISO = 0 #endif C SET DPMFLAG (0=HDPM, 1=VENUS, 2=SIBYLL, 3=QGSJET01/II, 4=DPMJET, C 5=EPOS/NEXUS) IF ( EVTH(76) .EQ. 1. ) THEN IDPM = 1 ELSEIF ( EVTH(76) .EQ. 2. ) THEN IDPM = 2 ELSEIF ( EVTH(76) .EQ. 3. ) THEN IDPM = 3 ELSEIF ( EVTH(76) .EQ. 4. ) THEN IDPM = 4 ELSEIF ( EVTH(76) .EQ. 5. ) THEN IDPM = 5 ELSE IDPM = 0 ENDIF C INCREMENT DPMFLAG FOR VARIOUS CROSS-SECTIONS C BY (0=HDPM-SIG, 10=VENUSSIG, 20=SIBYLLSIG, 30=QGSSIG, 40=DPMJETSIG, C 50=EPOSSIG/NEXUSSIG) IF ( EVTH(145) .EQ. 1. ) THEN IDPM = IDPM + 10 ELSEIF ( EVTH(145) .GE. 2. ) THEN IDPM = IDPM + 50 ELSEIF ( EVTH(140) .NE. 0. ) THEN IDPM = IDPM + 20 ELSEIF ( EVTH(142) .NE. 0. ) THEN IDPM = IDPM + 30 ELSEIF ( EVTH(144) .NE. 0. ) THEN IDPM = IDPM + 40 ENDIF #if __OFFIC__ MARK = '0' #else MARK = '1' #endif #if __THIN__ ILTHIN = 1 EFRAC = EFRCTHN #else ILTHIN = 0 EFRAC = 0.D0 #endif #if __ATMEXT__ IF ( FREFRX ) THEN IFREFRX = 1 ELSE IFREFRX = 0 ENDIF #endif WRITE(MDBASE,666) VERNUM,MARK,MVDATE,SNGL(VERVEN), $ INT(RUNH(3))+20000000, $ INT(EVTH(80)),INT(EVTH(79)),INT(EVTH(78)), $ MOD(INT(EVTH(77)),1024),INT(RUNH(2)), $ INT(PRMPAR(0)),LLIMIT,ULIMIT, $ PSLOPE,INT(RUNH(20)),INT(RUNH(19)),INT(EVTH(76)), $ INT(EVTH(75)),INT(EVTH(158)),IDPM, $ NFLAIN,NFLDIF,NFLPI0,NFLPIF,NFLCHE,NFRAGM, $ ILONG,THSTEP,BX, $ BZ,NOBSLV #if __AUGERINFO__ 666 FORMAT('version = ',F6.3,A1,/,'versiondate = ',I9,/, $ 'modelversion = ',F8.3,/,'rundate = ',I9,/, $ 'computer = ',I2,/,'curved = ',I2,/,'neutrino = ',I2,/, $ 'cerenkov = ',I3,/,'runnumber = ',I7,/, $ 'primary = ',I5,/,'e_range_l = ',1P,E14.7,/, $ 'e_range_u = ',E14.7,/, $ 'slope = ',E15.7,0P,/,'nkg = ',I2,/,'egs = ',I2,/, $ 'model = ',I2,/,'gheisha = ',I2,/,'charm = ',I2,/, $ 'model+crossect = ',I3,/, $ 'hadflag1 = ',I2,/,'hadflag2 = ',I2,/,'hadflag3 = ',I2,/, $ 'hadflag4 = ',I2,/,'hadflag5 = ',I2,/,'hadflag6 = ',I2,/, $ 'longi = ',I2,/,'longistep = ',1P,E14.7,/, $ 'magnetx = ',E15.7,/,'magnetz = ',E15.7,0P,/, $ 'nobslev = ',I3) #else 666 FORMAT('#version#',F6.3,A1,'#versiondate#',I9, $ '#modelversion#',F8.3,'#rundate#',I9,/, $ '#computer#',I2,'#curved#',I2,'#neutrino#',I2, $ '#cerenkov#',I3,'#runnumber#',I7,/, $ '#primary#',I5,'#e_range_l#',1P,E14.7,'#e_range_u#',E14.7,/, $ '#slope#',E15.7,0P,'#nkg#',I2,'#egs#',I2,/, $ '#model#',I2,'#gheisha#',I2,'#charm#',I2, $ '#model+crossect#',I3,/, $ '#hadflag1#',I2,'#hadflag2#',I2,'#hadflag3#',I2, $ '#hadflag4#',I2,'#hadflag5#',I2,'#hadflag6#',I2,/, $ '#longi#',I2,'#longistep#',1P,E14.7,'#magnetx#',E15.7,/, $ '#magnetz#',E15.7,0P,'#nobslev#',I3) #endif #if __ANAHIST__ || __AUGERHIST__ WRITE(MDBASE,669) OBSLEV(NOBSLV),0.D0, 0.D0, $ 0.D0, 0.D0, 0.D0, $ 0.D0, 0.D0, 0.D0, $ 0.D0, ELCUT(1),ELCUT(2), #else WRITE(MDBASE,669) OBSLEV(1),OBSLEV(2),OBSLEV(3), $ OBSLEV(4),OBSLEV(5),OBSLEV(6), $ OBSLEV(7),OBSLEV(8),OBSLEV(9), $ OBSLEV(10),ELCUT(1),ELCUT(2), #endif $ ELCUT(3), ELCUT(4),EVTH(81), $ EVTH(82),EVTH(83),EVTH(84), $ FIXHEI,N1STTR,THICK0, $ STEPFC,ARRANG,INT(EVTH(94)), #if __CURVED__ && __UPWARD__ $ HIMPACT(1),HIMPACT(2),NSEQ, #else $ 0.D0,0.D0,NSEQ, #endif $ ISEED(1,1),ISEED(2,1),ISEED(3,1), $ ISEED(1,2),ISEED(2,2),ISEED(3,2), $ ISEED(1,3),ISEED(2,3),ISEED(3,3),0,DSN,LSTDSN, #if __AUGERINFO__ $ ' ',' ', #else $ ' ARC000.01',' ARC000.01', #endif $ NSHOW,HOST,USER #if __ATMEXT__ $ ,IATMOX,IFREFRX #endif #if __VIEWCONE__ $ ,VUECON(1)*(180.D0/PI),VUECON(2)*(180.D0/PI) #endif #if __AUGERINFO__ 669 FORMAT(1P,'obslev1 = ',E15.7,/,'obslev2 = ',E15.7,/, $ 'obslev3 = ',E15.7,/,'obslev4 = ',E15.7,/, $ 'obslev5 = ',E15.7,/,'obslev6 = ',E15.7,/, $ 'obslev7 = ',E15.7,/,'obslev8 = ',E15.7,/, $ 'obslev9 = ',E15.7,/,'obslev10 = ',E15.7,/, $ 'hcut = ',E14.7,/,'mcut = ',E14.7,/,'ecut = ',E14.7,/, $ 'gcut = ',E14.7,/,'theta_l = ',E14.7,/,'theta_u = ',E14.7,/, $ 'phi_l = ',E15.7,/,'phi_u = ',E15.7,/,'fixhei = ',E14.7,0P, $ /,'n1sttr = ',I3,/,1P,'fixchi = ',E14.7,/,'stepfc = ',E14.7, $ /,'arrang = ',E15.7,/,0P,'muaddi = ',I2,/,1P, $ 'himpact1 = ',E14.7,/,'himpact2 = ',E14.7,/,0P,'nseq = ',I2, $ /,'seq1seed1 = ',I10,/,'seq1seed2 = ',I9,/,'seq1seed3 = ',I9, $ /,'seq2seed1 = ',I10,/,'seq2seed2 = ',I9,/,'seq2seed3 = ',I9, $ /,'seq3seed1 = ',I10,/,'seq3seed2 = ',I9,/,'seq3seed3 = ',I9, $ /,'size = ',I10,/,'dsn_events = ',A59,/, $ 'dsn_prtout = ',A9,/,'tape_name = ',A10,/,'backup = ',A10,/, $ 'howmanyshowers = ',I10,/,'host = ',A60,/,'user = ',A60 #if __ATMEXT__ $ ,/,'atmosphere = ',I3,/,'refract = ',I2 #endif #if __VIEWCONE__ $ ,/,1P,'viewcon_l = ',E14.7,/,'viewcon_u = ',E14.7,0P #endif $ ) #else 669 FORMAT(1P,'#obslev1#',E15.7,'#obslev2#',E15.7, $ '#obslev3#',E15.7,/, $ '#obslev4#',E15.7,'#obslev5#',E15.7,'#obslev6#',E15.7,/, $ '#obslev7#',E15.7,'#obslev8#',E15.7,'#obslev9#',E15.7,/, $ '#obslev10#',E15.7,'#hcut#',E14.7,'#mcut#',E14.7,/, $ '#ecut#',E14.7,'#gcut#',E14.7,'#theta_l#',E14.7,/, $ '#theta_u#',E14.7,'#phi_l#',E15.7,'#phi_u#',E15.7,/, $ '#fixhei#',E14.7,'#n1sttr#',0P,I3,1P,'#fixchi#',E14.7,/, $ '#stepfc#',E14.7,'#arrang#',E15.7,0P,'#muaddi#',I2,/, $ 1P,'#himpact1#',E14.7,'#himpact1#',E14.7,0P,'#nseq#',I2,/, $ '#seq1seed1#',I10,'#seq1seed2#',I9,'#seq1seed3#',I9,/, $ '#seq2seed1#',I10,'#seq2seed2#',I9,'#seq2seed3#',I9,/, $ '#seq3seed1#',I10,'#seq3seed2#',I9,'#seq3seed3#',I9,/, $ '#size#',I10,/,'#dsn_events#',A59,/, $ '#dsn_prtout# ',A9,'#tape_name#',A10,'#backup#',A10,/, $ '#howmanyshowers#',I10,'#host#',A60,'#user#',A60 #if __ATMEXT__ $ ,/,'#atmosphere#',I3,'#refract#',I2 #endif #if __VIEWCONE__ $ ,/,1P,'#viewcon_l#',E14.7,'#viewcon_u#',E14.7,0P #endif $ ) #endif #if __CERENKOV__ && __IACT__ WRITE(MDBASE,668) ICERML,XSCATT,YSCATT #if __AUGERINFO__ 668 FORMAT('cscat = ',I3,2(1X,F10.1)) #else 668 FORMAT('#cscat#',I3,2(1X,F10.1)) #endif DO I = 1, 999 CALL TELINF( I,XTEL,YTEL,ZTEL,RTEL,IEXIST ) IF ( IEXIST .NE. 1 ) GOTO 31 #if __AUGERINFO__ WRITE(MDBASE,667) I,XTEL,YTEL,ZTEL,RTEL 667 FORMAT('telescope = ',I3,4(1X,F10.1)) #else WRITE(MDBASE,667) I,XTEL,YTEL,ZTEL,RTEL 667 FORMAT('#telescope',I3,'#',4(1X,F10.1)) #endif ENDDO 31 CONTINUE #endif WRITE(MDBASE,670) ILTHIN,EFRAC #if __AUGERINFO__ 670 FORMAT('thinning = ',I2,/,'thinnlev_had = ',1P,E14.7,0P) #else 670 FORMAT('#thinning#',I2,'#thinnlev_had#',1P,E14.7,0P) #endif ENDIF #endif #if __CURVED__ && __ATMEXT__ C IN THE CURVED VERSION WE TREAT THE FITTED PROFILE THROUGH INTERNAL C FUNCTIONS ONLY. RESETTING IATMOX IS DONE AFTER THE C RUNHEADER AND THE 'DBASE' FILE ARE WRITTEN. IATMOX = 0 #endif WRITE(MONIOU,*) WRITE(MONIOU,*) 'NUMBER OF SHOWERS TO GENERATE =',NSHOW WRITE(MONIOU,*) RETURN END *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE ISTACK C----------------------------------------------------------------------- C I(NITIALIZE) STACK C C PREPARES STACK AND EXTERNAL DISK FILE. C THIS SUBROUTINE IS CALLED FROM AAMAIN. C----------------------------------------------------------------------- IMPLICIT NONE #define __ETHMAPINC__ #define __RUNPARINC__ #define __STACKFINC__ #if __ICECUBE1__ #define __BUFFSINC__ #endif #include "corsika.h" SAVE C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'ISTACK:' NTO = 0 NFROM = 0 NOUREC = 0 NOURECMAX = 0 NSHIFT = 0 ELEFT = 0.D0 ICOUNT = 1 #if __ICECUBE1__ MSTACKP = MAXSTK call ringbuffer_clear( MAXLEN ) #elif __DYNSTACK__ MSTACKP = MAXSTK call dynstack_reset() #else MSTACKP = 0 #endif RETURN END #if __PARALLEL__ *-- Author : The CORSIKA development group 07/05/2009 C======================================================================= SUBROUTINE JSTACK C----------------------------------------------------------------------- C (INITIALIZE) STACK J C C PREPARES STACK AND EXTERNAL DISK FILE. C THIS SUBROUTINE IS CALLED FROM AAMAIN. C----------------------------------------------------------------------- IMPLICIT NONE #define __ETHMAPINC__ #define __RUNPARINC__ #define __STACKFINC__ #include "corsika.h" SAVE C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'JSTACK:' NTOJ = 0 NFROMJ = 0 NOURECJ = 0 NSHIFTJ = 0 MSTACKPJ= 0 ELEFTJ = 0.D0 JCOUNT = 1 RETURN END #endif #if __TRAJECT__ C======================================================================= SUBROUTINE JULDAT( I,M,K,H,TJD ) C----------------------------------------------------------------------- C JUL(IAN) DAT(E) C THIS SUBROUTINE COMPUTES JULIAN DATE, GIVEN CALENDAR DATE AND C TIME. INPUT CALENDAR DATE MUST BE GREGORIAN. INPUT TIME VALUE C CAN BE IN ANY UT-LIKE TIME SCALE (UTC, UT1, TT, ETC.) - OUTPUT C JULIAN DATE WILL HAVE SAME BASIS. C ALGORITHM BY FLIEGEL AND VAN FLANDERN. C THIS SUBROUTINE IS TAKEN FROM: C http://aa.usno.navy.mil/software/novas/ novas\_info.ph C THIS SUBROUTINE IS CALLED FROM SOURCEPATH. C ARGUMENTS: C I = YEAR (IN) C M = MONTH NUMBER (IN) C K = DAY OF MONTH (IN) C H = UT HOURS (IN) C TJD = JULIAN DATE (OUT) C----------------------------------------------------------------------- IMPLICIT NONE DOUBLE PRECISION H,TJD INTEGER I,JD,K,M SAVE C----------------------------------------------------------------------- C JD=JULIAN DAY NO FOR DAY BEGINNING AT GREENWICH NOON ON GIVEN DATE JD = K-32075+1461*(I+4800+(M-14)/12)/4+367*(M-2-(M-14)/12*12)/12 * -3*((I+4900+(M-14)/12)/100)/4 TJD = JD - 0.5D0 + H/24.D0 RETURN END #endif *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE KDECAY( IGO ) C----------------------------------------------------------------------- C K(AON) DECAY C C KAON DECAYS WITH FULL KINEMATIC, ENERGY AND MOMENTA CONSERVED C ALL SECONDARY PARTICLES ARE WRITTEN TO STACK. C THIS SUBROUTINE IS CALLED FROM NUCINT. C ARGUMENT: (TO CHARACTERIZE THE DECAYING KAON) C IGO = 1 K+ C = 2 K- C = 3 K0S C = 4 K0L C----------------------------------------------------------------------- IMPLICIT NONE #define __CONSTAINC__ #define __DECAYCINC__ #define __IRETINC__ #define __KAONSINC__ #define __LONGIINC__ #define __PAMINC__ #define __PARPARINC__ #define __PARPAEINC__ #define __POLARINC__ #define __RANDPAINC__ #define __RUNPARINC__ #if __AUGERHIST__ #define __GENERINC__ #define __OBSPARINC__ #endif #include "corsika.h" DOUBLE PRECISION BETA3,COSTCM,COSTH3,FAC1,FAC2,GAMMA3,GAMMA4, * PHINN,PHI3,RA,WORK1,WORK2 INTEGER I,ICHARG,IGO,M3 #if __NEUTRINO__ DOUBLE PRECISION COSTH4 #endif SAVE #if __AUGERHIST__ DOUBLE PRECISION EDEP,THICKLOC,THICK INTEGER II,LL EXTERNAL THICK #endif C----------------------------------------------------------------------- #if __THIN__ IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=0,9),WEIGHT 444 FORMAT(' KDECAY: CURPAR=',1P,11E11.3) #else IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=0,9) 444 FORMAT(' KDECAY: CURPAR=',1P,10E11.3) #endif C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C DECAY OF K(+,-) (6 MODES) IF ( IGO .LE. 2 ) THEN CALL RMMARD( RD,1,1 ) RA = RD(1) C DECAY K(+,-) ----> MU(+,-) + NEUTRINO IF ( RA .LE. CKA(23) ) THEN #if !__NEUTRINO__ C NEUTRINO IS DROPPED #endif WORK1 = CKA(28) * GAMMA WORK2 = CKA(29) * BETA * WORK1 CALL RMMARD( RD,2,1 ) COSTCM = RD(1) * 2.D0 - 1.D0 C MU(+,-) GAMMA3 = WORK1 + COSTCM * WORK2 BETA3 = SQRT( (GAMMA3-1.D0)*(GAMMA3+1.D0) ) / GAMMA3 COSTH3 = MIN( 1.D0, (GAMMA * GAMMA3 - CKA(28)) * / (BETA * GAMMA * BETA3 * GAMMA3) ) PHI3 = RD(2) * PI2 CALL ADDANG3( COSTHE,PHIX,PHIY, COSTH3,PHI3, * SECPAR(2),SECPAR(3),SECPAR(4) ) #if __UPWARD__ IF ( SECPAR(2) .GE. -1.D0 ) THEN #else IF ( SECPAR(2) .GT. C(29) ) THEN #endif SECPAR(0) = 4 + IGO SECPAR(1) = GAMMA3 C DIRECTION OF PION IN THE MUON CM SYSTEM (= DIRECTION OF POLARIZATION) C SEE: G. BARR ET AL., PHYS. REV. D39 (1989) 3532, EQ. 5 C POLART IS COS OF ANGLE BETWEEN KAON AND LABORATORY IN THE MU CM C POLARF IS ANGLE PHI AROUND THE LAB DIRECTION IN THE MU CM C POLART, POLARF WITH RESPECT TO THE MU DIRECTION IN THE LAB SYSTEM POLART = ( 2.D0*PAMA(11)*GAMMA*C(6) / (PAMA(5)*GAMMA3) * - C(6) - 1.D0 ) / ( BETA3 * (1.D0-C(6)) ) POLARF = PHI3 - PI C PION DIRECTION IS DIRECTION OF POLARIZATION FOR K+, OPPOSITE FOR K- IF ( ITYPE .EQ. 12 ) THEN POLART = -POLART POLARF = POLARF + PI ENDIF C GET THE POLARIZATION DIRECTION IN THE MU CM RELATIVE TO THE CORSIKA C COORDINATE SYSTEM IF ( SECPAR(3) .NE. 0.D0 .OR. SECPAR(4) .NE. 0.D0 ) THEN PHINN = ATAN2( SECPAR(4), SECPAR(3) ) ELSE PHINN = 0.D0 ENDIF CALL ADDANG( SECPAR(2),PHINN, POLART,POLARF, * POLART,POLARF ) SECPAR(11) = POLART SECPAR(12) = POLARF CALL TSTACK SECPAR(11) = 0.D0 SECPAR(12) = 0.D0 ELSE IF ( LLONGI ) THEN C ADD MUON ENERGY TO LONGITUDINAL ENERGY DEPOSIT #if __THIN__ DLONG(LHEIGH,15) = DLONG(LHEIGH,15)+GAMMA3*PAMA(5)*WEIGHT #else DLONG(LHEIGH,15) = DLONG(LHEIGH,15) + GAMMA3 * PAMA(5) #endif ENDIF #if __AUGERHIST__ THICKLOC = THICK( H ) DO LL = 1, NOBSLV IF ( THICKLOC .GE. THCKOB(LL) .AND. * THICKLOC .LT. THCKOB(LL)+SAMPTH ) THEN C THICKH IS WITHIN 1 G/CM^2 BELOW OBSLEV(LL) C BRING THE ENERGY BELOW ANGULAR CUT TO THE HISTO OF LEVEL LL OUTPAR(0) = 4 + IGO OUTPAR(1) = GAMMA3 OUTPAR(2) = SECPAR(2) OUTPAR(3) = SECPAR(3) OUTPAR(4) = SECPAR(4) DO II = 5, 8 OUTPAR(II) = CURPAR(II) ENDDO OUTPAR( 9) = GEN OUTPAR(10) = ALEVEL OUTPAR(13) = WEIGHT EDEP = OUTPAR(1) * PAMA(5) * WEIGHT C WE HAVE ANGULAR CUT CALL AUGERDEPFIL( EDEP,LL,1 ) ELSEIF ( THICKLOC .LT. THCKOB(LL) ) THEN GOTO 211 ENDIF ENDDO 211 CONTINUE #endif ENDIF #if __NEUTRINO__ C (ANTI)-NEUTRINO(MU) GAMMA4 = PAMA(11) * GAMMA - PAMA(5) * GAMMA3 COSTH4 = MIN( 1.D0, (BETA - COSTCM)/(1.D0 - BETA*COSTCM) ) CALL ADDANG3( COSTHE,PHIX,PHIY, COSTH4,PHI3+PI, * SECPAR(2),SECPAR(3),SECPAR(4) ) #if __UPWARD__ IF ( SECPAR(2) .GE. -1.D0 ) THEN #else IF ( SECPAR(2) .GT. C(29) ) THEN #endif SECPAR(0) = 67 + IGO SECPAR(1) = GAMMA4 CALL TSTACK ELSE IF ( LLONGI ) THEN C ADD NEUTRINO ENERGY TO LONGITUDINAL ENERGY DEPOSIT #if __THIN__ DLONG(LHEIGH,18) = DLONG(LHEIGH,18) + GAMMA4 * WEIGHT #else DLONG(LHEIGH,18) = DLONG(LHEIGH,18) + GAMMA4 #endif ENDIF ENDIF #else IF ( LLONGI ) THEN C ADD NEUTRINO ENERGY TO LONGITUDINAL ENERGY DEPOSIT GAMMA4 = PAMA(11) * GAMMA - PAMA(5) * GAMMA3 #if __THIN__ DLONG(LHEIGH,8) = DLONG(LHEIGH,8) + GAMMA4 * WEIGHT #else DLONG(LHEIGH,8) = DLONG(LHEIGH,8) + GAMMA4 #endif ENDIF #endif C DECAY K(+,-) ----> PI(+,-) + PI(0) ELSEIF ( RA .LE. CKA(47) ) THEN M3 = ITYPE - 3 CALL DECAY1( ITYPE, M3, 7 ) C DECAY K(+,-) ----> PI(+,-) + PI(+,-) + PI(-,+) ELSEIF ( RA .LE. CKA(48) ) THEN CALL DECAY6( PAMA(11), PAMA(8),PAMA(8),PAMA(8), * CKA(51),CKA(52),CKA(53), CKA(54), 1 ) C PI(+,-) AND PI(+,-) AND THIRD (ODD) PI(-,+) DO I = 1, 3 CALL ADDANG3( COSTHE,PHIX,PHIY, COS345(I),PHI345(I), * SECPAR(2),SECPAR(3),SECPAR(4) ) #if __UPWARD__ IF ( SECPAR(2) .GE. -1.D0 ) THEN #else IF ( SECPAR(2) .GT. C(29) ) THEN #endif IF ( I .EQ. 3 ) THEN SECPAR(0) = 10 - IGO ELSE SECPAR(0) = 7 + IGO ENDIF SECPAR(1) = GAM345(I) CALL TSTACK ELSE IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT FAC1 = 0.25D0 FAC2 = 0.75D0 #if __THIN__ C ADD TO THE HADRON ENERGY DEPOSIT DLONG(LHEIGH,17) = DLONG(LHEIGH,17) * + GAM345(I)*PAMA(8)*WEIGHT*FAC1 C ADD TO THE NEUTRINO DEPOSIT DLONG(LHEIGH,18) = DLONG(LHEIGH,18) * + GAM345(I)*PAMA(8)*WEIGHT*FAC2 #else C ADD TO THE HADRON ENERGY DEPOSIT DLONG(LHEIGH,17) = DLONG(LHEIGH,17) * + GAM345(I) * PAMA(8) * FAC1 C ADD TO THE NEUTRINO DEPOSIT DLONG(LHEIGH,18) = DLONG(LHEIGH,18) * + GAM345(I) * PAMA(8) * FAC2 #endif ENDIF #if __AUGERHIST__ THICKLOC = THICK( H ) DO LL = 1, NOBSLV IF ( THICKLOC .GE. THCKOB(LL) .AND. * THICKLOC .LT. THCKOB(LL)+SAMPTH ) THEN C THICKH IS WITHIN 1 G/CM^2 BELOW OBSLEV(LL) C BRING THE ENERGY BELOW ANGULAR CUT TO THE HISTO OF LEVEL LL IF ( I .EQ. 3 ) THEN OUTPAR(0) = 10 - IGO ELSE OUTPAR(0) = 7 + IGO ENDIF OUTPAR(1) = GAM345(I) OUTPAR(2) = SECPAR(2) OUTPAR(3) = SECPAR(3) OUTPAR(4) = SECPAR(4) DO II = 5, 8 OUTPAR(II) = CURPAR(II) ENDDO OUTPAR( 9) = GEN OUTPAR(10) = ALEVEL OUTPAR(13) = WEIGHT EDEP = OUTPAR(1) * PAMA(8) * WEIGHT C WE HAVE ANGULAR CUT CALL AUGERDEPFIL( EDEP,LL,1 ) ELSEIF ( THICKLOC .LT. THCKOB(LL) ) THEN GOTO 231 ENDIF ENDDO 231 CONTINUE #endif ENDIF ENDDO C DECAY K(+,-) ----> PI(0) + E(+,-) + NEUTRINO ELSEIF ( RA .LE. CKA(49) ) THEN CALL DECAY6( PAMA(11), PAMA(7),PAMA(2),0.D0, * CKA(65),CKA(66),0.D0, CKA(67), 4 ) #if __NEUTRINO__ C PI(0), E(+,-) AND (ANTI)-NEUTRINO(E) DO 250 I = 1, 3 CALL ADDANG3( COSTHE,PHIX,PHIY, COS345(I),PHI345(I), * SECPAR(2),SECPAR(3),SECPAR(4) ) #if __UPWARD__ IF ( SECPAR(2) .GE. -1.D0 ) THEN #else IF ( SECPAR(2) .GT. C(29) ) THEN #endif IF ( I .EQ. 1 ) THEN SECPAR(0) = 7.D0 ELSEIF ( I .EQ. 3 ) THEN SECPAR(0) = 65 + IGO #else C PI(0) AND E(+,-) / NEUTRINO IS DROPPED DO 250 I = 1, 2 CALL ADDANG3( COSTHE,PHIX,PHIY, COS345(I),PHI345(I), * SECPAR(2),SECPAR(3),SECPAR(4) ) #if __UPWARD__ IF ( SECPAR(2) .GE. -1.D0 ) THEN #else IF ( SECPAR(2) .GT. C(29) ) THEN #endif IF ( I .EQ. 1 ) THEN SECPAR(0) = 7.D0 #endif ELSE SECPAR(0) = 1 + IGO ENDIF SECPAR(1) = GAM345(I) CALL TSTACK ELSE IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT IF ( I .EQ. 1 ) THEN #if __THIN__ DLONG(LHEIGH,17) = DLONG(LHEIGH,17) * + GAM345(1) * PAMA(7) * WEIGHT #if __NEUTRINO__ ELSEIF ( I .EQ. 3 ) THEN DLONG(LHEIGH,18) = DLONG(LHEIGH,18)+GAM345(3)*WEIGHT #endif ELSE IF ( IGO .EQ. 1 ) THEN DLONG(LHEIGH,13) = DLONG(LHEIGH,13) * + (GAM345(2)+1.D0)*PAMA(2)*WEIGHT ELSE DLONG(LHEIGH,13) = DLONG(LHEIGH,13) * + (GAM345(2)-1.D0)*PAMA(2)*WEIGHT ENDIF #else DLONG(LHEIGH,17) = DLONG(LHEIGH,17)+GAM345(1)*PAMA(7) #if __NEUTRINO__ ELSEIF ( I .EQ. 3 ) THEN DLONG(LHEIGH,18) = DLONG(LHEIGH,18) + GAM345(3) #endif ELSE IF ( IGO .EQ. 1 ) THEN DLONG(LHEIGH,13) = DLONG(LHEIGH,13) * + (GAM345(2)+1.D0) * PAMA(2) ELSE DLONG(LHEIGH,13) = DLONG(LHEIGH,13) * + (GAM345(2)-1.D0) * PAMA(2) ENDIF #endif ENDIF ENDIF #if __AUGERHIST__ THICKLOC = THICK( H ) DO LL = 1, NOBSLV IF ( THICKLOC .GE. THCKOB(LL) .AND. * THICKLOC .LT. THCKOB(LL)+SAMPTH ) THEN C THICKH IS WITHIN 1 G/CM^2 BELOW OBSLEV(LL) C BRING THE ENERGY BELOW ANGULAR CUT TO THE HISTO OF LEVEL LL IF ( I .EQ. 1 ) THEN OUTPAR(0) = 7.D0 OUTPAR(1) = GAM345(I) EDEP = OUTPAR(1) * PAMA(7) * WEIGHT ELSE OUTPAR(0) = 1 + IGO OUTPAR(1) = GAM345(I)*PAMA(2) EDEP = ( OUTPAR(1) - RESTMS(1+IGO) ) * WEIGHT ENDIF OUTPAR(2) = SECPAR(2) OUTPAR(3) = SECPAR(3) OUTPAR(4) = SECPAR(4) DO II = 5, 8 OUTPAR(II) = CURPAR(II) ENDDO OUTPAR( 9) = GEN OUTPAR(10) = ALEVEL OUTPAR(13) = WEIGHT C WE HAVE ANGULAR CUT CALL AUGERDEPFIL( EDEP,LL,1 ) ELSEIF ( THICKLOC .LT. THCKOB(LL) ) THEN GOTO 241 ENDIF ENDDO 241 CONTINUE #endif ENDIF 250 CONTINUE #if !__NEUTRINO__ IF ( LLONGI ) THEN C ADD NEUTRINO ENERGY TO LONGITUDINAL ENERGY DEPOSIT GAM345(3)=GAMMA*PAMA(11)-GAM345(1)*PAMA(7)-GAM345(2)*PAMA(2) #if __THIN__ DLONG(LHEIGH,8) = DLONG(LHEIGH,8) + GAM345(3) * WEIGHT #else DLONG(LHEIGH,8) = DLONG(LHEIGH,8) + GAM345(3) #endif ENDIF #endif C DECAY K(+,-) ----> PI(0) + MU(+,-) + NEUTRINO ELSEIF ( RA .LE. CKA(50) ) THEN CALL DECAY6( PAMA(11), PAMA(7),PAMA(5),0.D0, * CKA(68),CKA(69),0.D0, CKA(70), 3 ) #if __NEUTRINO__ C PI(0), MU(+,-) AND (ANTI)-NEUTRINO(MU) DO 260 I = 1, 3 CALL ADDANG3( COSTHE,PHIX,PHIY, COS345(I),PHI345(I), * SECPAR(2),SECPAR(3),SECPAR(4) ) #if __UPWARD__ IF ( SECPAR(2) .GE. -1.D0 ) THEN #else IF ( SECPAR(2) .GT. C(29) ) THEN #endif SECPAR(1) = GAM345(I) IF ( I .EQ. 1 ) THEN SECPAR(0) = 7.D0 ELSEIF ( I .EQ. 3 ) THEN SECPAR(0) = 67 + IGO #else C PI(0) AND MU(+,-) / NEUTRINO IS DROPPED DO 260 I = 1, 2 CALL ADDANG3( COSTHE,PHIX,PHIY, COS345(I),PHI345(I), * SECPAR(2),SECPAR(3),SECPAR(4) ) #if __UPWARD__ IF ( SECPAR(2) .GE. -1.D0 ) THEN #else IF ( SECPAR(2) .GT. C(29) ) THEN #endif SECPAR(1) = GAM345(I) IF ( I .EQ. 1 ) THEN SECPAR(0) = 7.D0 #endif ELSE SECPAR(0) = 4 + IGO IF ( SECPAR(0) .EQ. 6.D0 ) THEN C INVERT POLARIZATION DIRECTION FOR MU(-) POLART = -POLART POLARF = POLARF + PI ENDIF C GET THE POLARIZATION DIRECTION IN THE MU CM RELATIVE TO THE CORSIKA C COORDINATE SYSTEM IF ( SECPAR(3).NE.0.D0 .OR. SECPAR(4).NE.0.D0 ) THEN PHINN = ATAN2( SECPAR(4), SECPAR(3) ) ELSE PHINN = 0.D0 ENDIF CALL ADDANG( SECPAR(2),PHINN, POLART,POLARF, * POLART,POLARF ) SECPAR(11) = POLART SECPAR(12) = POLARF ENDIF CALL TSTACK SECPAR(11) = 0.D0 SECPAR(12) = 0.D0 ELSE IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT IF ( I .EQ. 1 ) THEN #if __THIN__ DLONG(LHEIGH,17) = DLONG(LHEIGH,17) * + GAM345(1) * PAMA(7) * WEIGHT #if __NEUTRINO__ ELSEIF ( I .EQ. 3 ) THEN DLONG(LHEIGH,18) = DLONG(LHEIGH,18)+GAM345(3)*WEIGHT #endif ELSE DLONG(LHEIGH,15) = DLONG(LHEIGH,15) * + GAM345(1) * PAMA(5) * WEIGHT #else DLONG(LHEIGH,17) = DLONG(LHEIGH,17)+GAM345(2)*PAMA(7) #if __NEUTRINO__ ELSEIF ( I .EQ. 3 ) THEN DLONG(LHEIGH,18) = DLONG(LHEIGH,18) + GAM345(3) #endif ELSE DLONG(LHEIGH,15) = DLONG(LHEIGH,15)+GAM345(2)*PAMA(5) #endif ENDIF ENDIF #if __AUGERHIST__ THICKLOC = THICK( H ) DO LL = 1, NOBSLV IF ( THICKLOC .GE. THCKOB(LL) .AND. * THICKLOC .LT. THCKOB(LL)+SAMPTH ) THEN C THICKH IS WITHIN 1 G/CM^2 BELOW OBSLEV(LL) C BRING THE ENERGY BELOW ANGULAR CUT TO THE HISTO OF LEVEL LL OUTPAR(1) = GAM345(I) IF ( I .EQ. 1 ) THEN OUTPAR(0) = 7.D0 EDEP = OUTPAR(1) * PAMA(7) * WEIGHT ELSE OUTPAR(0) = 4 + IGO EDEP = OUTPAR(1) * PAMA(5) * WEIGHT ENDIF OUTPAR(2) = SECPAR(2) OUTPAR(3) = SECPAR(3) OUTPAR(4) = SECPAR(4) DO II = 5, 8 OUTPAR(II) = CURPAR(II) ENDDO OUTPAR( 9) = GEN OUTPAR(10) = ALEVEL OUTPAR(13) = WEIGHT C WE HAVE ANGULAR CUT CALL AUGERDEPFIL( EDEP,LL,1 ) ELSEIF ( THICKLOC .LT. THCKOB(LL) ) THEN GOTO 251 ENDIF ENDDO 251 CONTINUE #endif ENDIF 260 CONTINUE #if !__NEUTRINO__ IF ( LLONGI ) THEN C ADD NEUTRINO ENERGY TO LONGITUDINAL ENERGY DEPOSIT GAM345(3)=GAMMA*PAMA(11)-GAM345(1)*PAMA(7)-GAM345(2)*PAMA(5) #if __THIN__ DLONG(LHEIGH,8) = DLONG(LHEIGH,8) + GAM345(3) * WEIGHT #else DLONG(LHEIGH,8) = DLONG(LHEIGH,8) + GAM345(3) #endif ENDIF #endif C DECAY K(+,-) ----> PI(0) + PI(0) + PI(+,-) ELSE CALL DECAY6( PAMA(11), PAMA(7),PAMA(7),PAMA(8), * CKA(55),CKA(56),CKA(57), CKA(58), 1 ) C PI(0)''S AND PI(+,-) DO I = 1, 3 IF ( I .EQ. 3 ) THEN SECPAR(0) = 7 + IGO ELSE SECPAR(0) = 7.D0 ENDIF CALL ADDANG3( COSTHE,PHIX,PHIY, COS345(I),PHI345(I), * SECPAR(2),SECPAR(3),SECPAR(4) ) #if __UPWARD__ IF ( SECPAR(2) .GE. -1.D0 ) THEN #else IF ( SECPAR(2) .GT. C(29) ) THEN #endif SECPAR(1) = GAM345(I) CALL TSTACK ELSE IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT GAMMA4 = GAM345(I) * PAMA(NINT( SECPAR(0) )) IF ( NINT( SECPAR(0) ) .EQ. 7 ) THEN FAC1 = 1.D0 FAC2 = 0.D0 ELSE FAC1 = 0.25D0 FAC2 = 0.75D0 ENDIF #if __THIN__ C ADD TO THE HADRON ENERGY DEPOSIT DLONG(LHEIGH,17) = DLONG(LHEIGH,17) * + GAMMA4*WEIGHT*FAC1 C ADD TO THE NEUTRINO DEPOSIT DLONG(LHEIGH,18) = DLONG(LHEIGH,18) * + GAMMA4*WEIGHT*FAC2 #else C ADD TO THE HADRON ENERGY DEPOSIT DLONG(LHEIGH,17) = DLONG(LHEIGH,17) + GAMMA4 * FAC1 C ADD TO THE NEUTRINO DEPOSIT DLONG(LHEIGH,18) = DLONG(LHEIGH,18) + GAMMA4 * FAC2 #endif ENDIF #if __AUGERHIST__ THICKLOC = THICK( H ) DO LL = 1, NOBSLV IF ( THICKLOC .GE. THCKOB(LL) .AND. * THICKLOC .LT. THCKOB(LL)+SAMPTH ) THEN C THICKH IS WITHIN 1 G/CM^2 BELOW OBSLEV(LL) C BRING THE ENERGY BELOW ANGULAR CUT TO THE HISTO OF LEVEL LL OUTPAR(1) = GAM345(I) IF ( I .EQ. 3 ) THEN OUTPAR(0) = 7 + IGO EDEP = OUTPAR(1) * PAMA(8) * WEIGHT ELSE OUTPAR(0) = 7.D0 EDEP = OUTPAR(1) * PAMA(7) * WEIGHT ENDIF OUTPAR(2) = SECPAR(2) OUTPAR(3) = SECPAR(3) OUTPAR(4) = SECPAR(4) DO II = 5, 8 OUTPAR(II) = CURPAR(II) ENDDO OUTPAR( 9) = GEN OUTPAR(10) = ALEVEL OUTPAR(13) = WEIGHT C WE HAVE ANGULAR CUT CALL AUGERDEPFIL( EDEP,LL,1 ) ELSEIF ( THICKLOC .LT. THCKOB(LL) ) THEN GOTO 261 ENDIF ENDDO 261 CONTINUE #endif ENDIF ENDDO ENDIF C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C DECAY OF K0S (2 MODES RSP. 4 MODES) ELSEIF ( IGO .EQ. 3 ) THEN CALL RMMARD( RD,1,1 ) #if __NEUTRINO__ C DECAY K0S ----> PI(+) + PI(-) IF ( RD(1) .LE. 0.69194949 ) THEN CALL DECAY1( ITYPE, 8, 9 ) C DECAY K0S ----> PI(0) + PI(0) ELSEIF ( RD(1) .LE. 0.9988271 ) THEN CALL DECAY1( ITYPE, 7, 7 ) C DECAY K0S ----> PI(+,-) + E(-,+) + (ANTI)-NEUTRINO(E) ELSEIF ( RD(1) .LE. 0.9995310 ) THEN C REGARD PRODUCTION OF ELECTRON NEUTRINOS, C SEE T. GAISSER & S. KlEIN, arXiv 1409.4924 (2014) CALL DECAY6( PAMA(10), PAMA(8),PAMA(3),0.D0, * 0.0339D0,0.D0,0.D0, 0.0130773D0, 4 ) CALL RMMARD( RD,1,1 ) C CHARGE ASYMMETRY PREFERS FORMATION OF PI(-) ICHARG = INT( 1.50075D0 + RD(1) ) C PI(+,-), E(-,+) AND (ANTI)-NEUTRINO(E) DO 320 I = 1, 3 IF ( I .EQ. 3 ) THEN SECPAR(0) = 68 - ICHARG ELSE SECPAR(0) = 10 - 3*I - (2*I-3)*ICHARG ENDIF CALL ADDANG3( COSTHE,PHIX,PHIY, COS345(I),PHI345(I), * SECPAR(2),SECPAR(3),SECPAR(4) ) #if __UPWARD__ IF ( SECPAR(2) .GE. -1.D0 ) THEN #else IF ( SECPAR(2) .GT. C(29) ) THEN #endif SECPAR(1) = GAM345(I) CALL TSTACK ELSE C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT IF ( LLONGI ) THEN IF ( I .EQ. 1 ) THEN FAC1 = 0.25D0 FAC2 = 0.75D0 #if __THIN__ DLONG(LHEIGH,17) = DLONG(LHEIGH,17) * + GAM345(1)*PAMA(8)*WEIGHT*FAC1 DLONG(LHEIGH,18) = DLONG(LHEIGH,18) * + GAM345(1)*PAMA(8)*WEIGHT*FAC2 ELSEIF ( I .EQ. 3 ) THEN DLONG(LHEIGH,18) = DLONG(LHEIGH,18)+GAM345(3)*WEIGHT ELSE IF ( SECPAR(0) .EQ. 2.D0 ) THEN DLONG(LHEIGH,13) = DLONG(LHEIGH,13) * + (GAM345(2)+1.D0)*PAMA(2)*WEIGHT ELSE DLONG(LHEIGH,13) = DLONG(LHEIGH,13) * + (GAM345(2)-1.D0)*PAMA(2)*WEIGHT ENDIF #else DLONG(LHEIGH,17) = DLONG(LHEIGH,17) * +GAM345(1)*PAMA(8)*FAC1 DLONG(LHEIGH,18) = DLONG(LHEIGH,18) * +GAM345(1)*PAMA(8)*FAC2 ELSEIF ( I .EQ. 3 ) THEN DLONG(LHEIGH,18) = DLONG(LHEIGH,18) + GAM345(3) ELSE IF ( SECPAR(0) .EQ. 2.D0 ) THEN DLONG(LHEIGH,13) = DLONG(LHEIGH,13) * + (GAM345(2)+1.D0) * PAMA(2) ELSE DLONG(LHEIGH,13) = DLONG(LHEIGH,13) * + (GAM345(2)-1.D0) * PAMA(2) ENDIF #endif ENDIF ENDIF #if __AUGERHIST__ THICKLOC = THICK( H ) DO LL = 1, NOBSLV IF ( THICKLOC .GE. THCKOB(LL) .AND. * THICKLOC .LT. THCKOB(LL)+SAMPTH ) THEN C THICKH IS WITHIN 1 G/CM^2 BELOW OBSLEV(LL) C BRING THE ENERGY BELOW ANGULAR CUT TO THE HISTO OF LEVEL LL OUTPAR(0) = SECPAR(0) IF ( OUTPAR(0) .LE. 3.D0 ) THEN OUTPAR(1) = GAM345(I) * PAMA(2) EDEP = (OUTPAR(1)-RESTMS(NINT(OUTPAR(0)))) * WEIGHT ELSE OUTPAR(1) = GAM345(I) EDEP = OUTPAR(1) * PAMA(8) * WEIGHT ENDIF DO II = 2, 8 OUTPAR(II) = SECPAR(II) ENDDO OUTPAR( 9) = GEN OUTPAR(10) = ALEVEL OUTPAR(13) = WEIGHT C WE HAVE ANGULAR CUT CALL AUGERDEPFIL( EDEP,LL,1 ) ELSEIF ( THICKLOC .LT. THCKOB(LL) ) THEN GOTO 311 ENDIF ENDDO 311 CONTINUE #endif ENDIF 320 CONTINUE C DECAY K0S ----> PI(+,-) + MU(-,+) + (ANTI)-NEUTRINO(MU) ELSE C REGARD PRODUCTION OF HIGH ENERGY MUONS AND MUONIC NEUTRINOS, C IN ANALOGY WITH T. GAISSER & S. KlEIN, arXiv 1409.4924 (2014) CALL DECAY6( PAMA(10), PAMA(8),PAMA(5),0.D0, * 0.0339D0,0.D0,0.D0, 0.0130773D0, 3 ) CALL RMMARD( RD,1,1 ) C CHARGE ASYMMETRY PREFERS FORMATION OF PI(-) ICHARG = INT( 1.50075D0 + RD(1) ) C PI(+,-), MU(-,+) AND (ANTI)-NEUTRINO(MU) DO 321 I = 1, 3 IF ( I .EQ. 3 ) THEN SECPAR(0) = 70 - ICHARG ELSE SECPAR(0) = 7 - (2*I-3)*ICHARG ENDIF CALL ADDANG3( COSTHE,PHIX,PHIY, COS345(I),PHI345(I), * SECPAR(2),SECPAR(3),SECPAR(4) ) #if __UPWARD__ IF ( SECPAR(2) .GE. -1.D0 ) THEN #else IF ( SECPAR(2) .GT. C(29) ) THEN #endif SECPAR(1) = GAM345(I) IF ( I .EQ. 2 ) THEN C THE POLARZATION DIRECTION OF THE MUON IS CALCULATED IN DECAY6 C GET THE POLARIZATION DIRECTION IN THE MU CM RELATIVE TO THE CORSIKA C COORDINATE SYSTEM IF ( SECPAR(3).NE.0.D0 .OR. SECPAR(4).NE.0.D0 ) THEN PHINN = ATAN2( SECPAR(4), SECPAR(3) ) ELSE PHINN = 0.D0 ENDIF CALL ADDANG( SECPAR(2),PHINN, POLART,POLARF, * POLART,POLARF ) IF ( SECPAR(0) .EQ. 5 ) THEN SECPAR(11) = POLART SECPAR(13) = POLARF ELSE C INVERT POLARIZATION DIRECTION FOR MU(-) SECPAR(11) = -POLART SECPAR(13) = POLARF + PI ENDIF ENDIF CALL TSTACK C RESET POLARIZATION SECPAR(11) = 0.D0 SECPAR(12) = 0.D0 ELSE C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT IF ( LLONGI ) THEN IF ( I .EQ. 1 ) THEN FAC1 = 0.25D0 FAC2 = 0.75D0 #if __THIN__ DLONG(LHEIGH,17) = DLONG(LHEIGH,17) * + GAM345(1)*PAMA(8)*WEIGHT*FAC1 DLONG(LHEIGH,18) = DLONG(LHEIGH,18) * + GAM345(1)*PAMA(8)*WEIGHT*FAC2 ELSEIF ( I .EQ. 3 ) THEN DLONG(LHEIGH,18) = DLONG(LHEIGH,18)+GAM345(3)*WEIGHT ELSE DLONG(LHEIGH,15) = DLONG(LHEIGH,15) * + GAM345(2)*PAMA(5)*WEIGHT #else DLONG(LHEIGH,17) = DLONG(LHEIGH,17) * +GAM345(1)*PAMA(8)*FAC1 DLONG(LHEIGH,18) = DLONG(LHEIGH,18) * +GAM345(1)*PAMA(8)*FAC2 ELSEIF ( I .EQ. 3 ) THEN DLONG(LHEIGH,18) = DLONG(LHEIGH,18) + GAM345(3) ELSE DLONG(LHEIGH,15) = DLONG(LHEIGH,15) * + GAM345(2) * PAMA(5) #endif ENDIF ENDIF #if __AUGERHIST__ THICKLOC = THICK( H ) DO LL = 1, NOBSLV IF ( THICKLOC .GE. THCKOB(LL) .AND. * THICKLOC .LT. THCKOB(LL)+SAMPTH ) THEN C THICKH IS WITHIN 1 G/CM^2 BELOW OBSLEV(LL) C BRING THE ENERGY BELOW ANGULAR CUT TO THE HISTO OF LEVEL LL OUTPAR(0) = SECPAR(0) IF ( OUTPAR(0) .EQ. 5.D0 .OR. * OUTPAR(0) .EQ. 6.D0 ) THEN OUTPAR(1) = GAM345(I) * PAMA(5) EDEP = OUTPAR(1) * PAMA(5) * WEIGHT ELSE OUTPAR(1) = GAM345(I) EDEP = OUTPAR(1) * PAMA(8) * WEIGHT ENDIF DO II = 2, 8 OUTPAR(II) = SECPAR(II) ENDDO OUTPAR( 9) = GEN OUTPAR(10) = ALEVEL OUTPAR(13) = WEIGHT C WE HAVE ANGULAR CUT CALL AUGERDEPFIL( EDEP,LL,1 ) ELSEIF ( THICKLOC .LT. THCKOB(LL) ) THEN GOTO 312 ENDIF ENDDO 312 CONTINUE #endif ENDIF 321 CONTINUE #else /* !__NEUTRINO__ */ C DISREGARD THE PRODUCTION OF ELECTRON/MUON NEUTRINOS C DECAY K0S ----> PI(+) + PI(-) IF ( RD(1) .LE. CKA(24) ) THEN CALL DECAY1( ITYPE, 8, 9 ) C DECAY K0S ----> PI(0) + PI(0) ELSE CALL DECAY1( ITYPE, 7, 7 ) #endif ENDIF C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C DECAY OF K0L (4 MODES) ELSEIF ( IGO .EQ. 4 ) THEN CALL RMMARD( RD,1,1 ) RA = RD(1) C DECAY K0L ----> PI(+,-) + E(-,+) + NEUTRINO IF ( RA .LE. CKA(27) ) THEN CALL DECAY6( PAMA(10), PAMA(8),PAMA(3),0.D0, * CKA(71),CKA(72),0.D0, CKA(73), 4 ) CALL RMMARD( RD,1,1 ) C CHARGE ASYMMETRY PREFERS FORMATION OF PI(-) ICHARG = INT( 1.5016D0 + RD(1) ) #if __NEUTRINO__ C PI(+,-), E(-,+) AND (ANTI)-NEUTRINO(E) DO 420 I = 1, 3 IF ( I .EQ. 3 ) THEN SECPAR(0) = 68 - ICHARG ELSE SECPAR(0) = 10 - 3*I - (2*I-3)*ICHARG ENDIF #else C PI(+,-) AND E(-,+) / NEUTRINO IS DROPPED DO 420 I = 1, 2 SECPAR(0) = 10 - 3*I - (2*I-3)*ICHARG #endif CALL ADDANG3( COSTHE,PHIX,PHIY, COS345(I),PHI345(I), * SECPAR(2),SECPAR(3),SECPAR(4) ) #if __UPWARD__ IF ( SECPAR(2) .GE. -1.D0 ) THEN #else IF ( SECPAR(2) .GT. C(29) ) THEN #endif SECPAR(1) = GAM345(I) CALL TSTACK ELSE C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT IF ( LLONGI ) THEN IF ( I .EQ. 1 ) THEN FAC1 = 0.25D0 FAC2 = 0.75D0 #if __THIN__ DLONG(LHEIGH,17) = DLONG(LHEIGH,17) * + GAM345(1)*PAMA(8)*WEIGHT*FAC1 DLONG(LHEIGH,18) = DLONG(LHEIGH,18) * + GAM345(1)*PAMA(8)*WEIGHT*FAC2 #if __NEUTRINO__ ELSEIF ( I .EQ. 3 ) THEN DLONG(LHEIGH,18) = DLONG(LHEIGH,18)+GAM345(3)*WEIGHT #endif ELSE IF ( SECPAR(0) .EQ. 2.D0 ) THEN DLONG(LHEIGH,13) = DLONG(LHEIGH,13) * + (GAM345(2)+1.D0)*PAMA(2)*WEIGHT ELSE DLONG(LHEIGH,13) = DLONG(LHEIGH,13) * + (GAM345(2)-1.D0)*PAMA(2)*WEIGHT ENDIF #else DLONG(LHEIGH,17) = DLONG(LHEIGH,17) * +GAM345(1)*PAMA(8)*FAC1 DLONG(LHEIGH,18) = DLONG(LHEIGH,18) * +GAM345(1)*PAMA(8)*FAC2 #if __NEUTRINO__ ELSEIF ( I .EQ. 3 ) THEN DLONG(LHEIGH,18) = DLONG(LHEIGH,18) + GAM345(3) #endif ELSE IF ( SECPAR(0) .EQ. 2.D0 ) THEN DLONG(LHEIGH,13) = DLONG(LHEIGH,13) * + (GAM345(2)+1.D0) * PAMA(2) ELSE DLONG(LHEIGH,13) = DLONG(LHEIGH,13) * + (GAM345(2)-1.D0) * PAMA(2) ENDIF #endif ENDIF ENDIF #if __AUGERHIST__ THICKLOC = THICK( H ) DO LL = 1, NOBSLV IF ( THICKLOC .GE. THCKOB(LL) .AND. * THICKLOC .LT. THCKOB(LL)+SAMPTH ) THEN C THICKH IS WITHIN 1 G/CM^2 BELOW OBSLEV(LL) C BRING THE ENERGY BELOW ANGULAR CUT TO THE HISTO OF LEVEL LL OUTPAR(0) = SECPAR(0) IF ( OUTPAR(0) .LE. 3.D0 ) THEN OUTPAR(1) = GAM345(I) * PAMA(2) EDEP = (OUTPAR(1)-RESTMS(NINT(OUTPAR(0)))) * WEIGHT ELSE OUTPAR(1) = GAM345(I) EDEP = OUTPAR(1) * PAMA(8) * WEIGHT ENDIF DO II = 2, 8 OUTPAR(II) = SECPAR(II) ENDDO OUTPAR( 9) = GEN OUTPAR(10) = ALEVEL OUTPAR(13) = WEIGHT C WE HAVE ANGULAR CUT CALL AUGERDEPFIL( EDEP,LL,1 ) ELSEIF ( THICKLOC .LT. THCKOB(LL) ) THEN GOTO 411 ENDIF ENDDO 411 CONTINUE #endif ENDIF 420 CONTINUE #if !__NEUTRINO__ IF ( LLONGI ) THEN C ADD NEUTRINO ENERGY TO LONGITUDINAL ENERGY DEPOSIT GAM345(3)=GAMMA*PAMA(10)-GAM345(1)*PAMA(8)-GAM345(2)*PAMA(2) #if __THIN__ DLONG(LHEIGH,8) = DLONG(LHEIGH,8) + GAM345(3) * WEIGHT #else DLONG(LHEIGH,8) = DLONG(LHEIGH,8) + GAM345(3) #endif ENDIF #endif C DECAY K0L ----> PI(+,-) + MU(-,+) + NEUTRINO ELSEIF ( RA .LE. CKA(26) ) THEN CALL DECAY6( PAMA(10), PAMA(8),PAMA(6),0.D0, * CKA(74),CKA(75),0.D0, CKA(76), 3 ) CALL RMMARD( RD,1,1 ) C CHARGE ASYMMETRY PREFERS FORMATION OF PI(-) ICHARG = INT( 1.5016D0 + RD(1) ) #if __NEUTRINO__ C PI(+,-), MU(-,+) AND (ANTI)-NEUTRINO(MU) DO 430 I = 1, 3 #else C PI(+,-) AND MU(-,+) / NEUTRINO IS DROPPED DO 430 I = 1, 2 #endif CALL ADDANG3( COSTHE,PHIX,PHIY, COS345(I),PHI345(I), * SECPAR(2),SECPAR(3),SECPAR(4) ) #if __UPWARD__ IF ( SECPAR(2) .GE. -1.D0 ) THEN #else IF ( SECPAR(2) .GT. C(29) ) THEN #endif SECPAR(1) = GAM345(I) IF ( I .EQ. 1 ) THEN SECPAR(0) = 7 + ICHARG ELSEIF ( I .EQ. 2 ) THEN SECPAR(0) = 7 - ICHARG IF ( SECPAR(0) .EQ. 6.D0 ) THEN C INVERT POLARIZATION DIRECTION FOR MU(-) POLART = -POLART POLARF = POLARF + PI ENDIF C GET THE POLARIZATION DIRECTION IN THE MU CM RELATIVE TO THE CORSIKA C COORDINATE SYSTEM IF ( SECPAR(3).NE.0.D0 .OR. SECPAR(4).NE.0.D0 ) THEN PHINN = ATAN2( SECPAR(4), SECPAR(3) ) ELSE PHINN = 0.D0 ENDIF CALL ADDANG( SECPAR(2),PHINN, POLART,POLARF, * POLART,POLARF ) SECPAR(11) = POLART SECPAR(12) = POLARF #if __NEUTRINO__ ELSEIF ( I .EQ. 3 ) THEN SECPAR(0) = 70 - ICHARG #endif ENDIF CALL TSTACK SECPAR(11) = 0.D0 SECPAR(12) = 0.D0 ELSE C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT IF ( LLONGI ) THEN IF ( I .EQ. 1 ) THEN FAC1 = 0.25D0 FAC2 = 0.75D0 #if __THIN__ DLONG(LHEIGH,17) = DLONG(LHEIGH,17) * + GAM345(1)*PAMA(8)*WEIGHT*FAC1 DLONG(LHEIGH,18) = DLONG(LHEIGH,18) * + GAM345(1)*PAMA(8)*WEIGHT*FAC2 #if __NEUTRINO__ ELSEIF ( I .EQ. 3 ) THEN DLONG(LHEIGH,18) = DLONG(LHEIGH,18)+GAM345(3)*WEIGHT #endif ELSE DLONG(LHEIGH,15) = DLONG(LHEIGH,15) * + GAM345(2) * PAMA(5) * WEIGHT #else DLONG(LHEIGH,17) = DLONG(LHEIGH,17) * +GAM345(1)*PAMA(8)*FAC1 DLONG(LHEIGH,18) = DLONG(LHEIGH,18) * +GAM345(1)*PAMA(8)*FAC2 #if __NEUTRINO__ ELSEIF ( I .EQ. 3 ) THEN DLONG(LHEIGH,18) = DLONG(LHEIGH,18) + GAM345(3) #endif ELSE DLONG(LHEIGH,15) = DLONG(LHEIGH,15)+GAM345(2)*PAMA(5) #endif ENDIF ENDIF #if __AUGERHIST__ THICKLOC = THICK( H ) DO LL = 1, NOBSLV IF ( THICKLOC .GE. THCKOB(LL) .AND. * THICKLOC .LT. THCKOB(LL)+SAMPTH ) THEN C THICKH IS WITHIN 1 G/CM^2 BELOW OBSLEV(LL) C BRING THE ENERGY BELOW ANGULAR CUT TO THE HISTO OF LEVEL LL OUTPAR(1) = GAM345(I) IF ( I .EQ. 1 ) THEN OUTPAR(0) = 7 + ICHARG EDEP = OUTPAR(1) * PAMA(8) * WEIGHT ELSE OUTPAR(0) = 7 - ICHARG EDEP = OUTPAR(1) * PAMA(5) * WEIGHT ENDIF OUTPAR(2) = SECPAR(2) OUTPAR(3) = SECPAR(3) OUTPAR(4) = SECPAR(4) DO II = 5, 8 OUTPAR(II) = CURPAR(II) ENDDO OUTPAR( 9) = GEN OUTPAR(10) = ALEVEL OUTPAR(13) = WEIGHT C WE HAVE ANGULAR CUT CALL AUGERDEPFIL( EDEP,LL,1 ) ELSEIF ( THICKLOC .LT. THCKOB(LL) ) THEN GOTO 421 ENDIF ENDDO 421 CONTINUE #endif ENDIF 430 CONTINUE #if !__NEUTRINO__ IF ( LLONGI ) THEN C ADD NEUTRINO ENERGY TO LONGITUDINAL ENERGY DEPOSIT GAM345(3)=GAMMA*PAMA(10)-GAM345(1)*PAMA(8)-GAM345(2)*PAMA(5) #if __THIN__ DLONG(LHEIGH,8) = DLONG(LHEIGH,8) + GAM345(3) * WEIGHT #else DLONG(LHEIGH,8) = DLONG(LHEIGH,8) + GAM345(3) #endif ENDIF #endif C DECAY K0L ----> PI(0) + PI(0) + PI(0) ELSEIF ( RA .LE. CKA(25) ) THEN C SEE: S.V. SOMALWAR ET AL., PHYS.REV.LET. 68(1992)2580 CALL DECAY6( PAMA(10), PAMA(7),PAMA(7),PAMA(7), * CKA(59),-.0033D0,CKA(59), CKA(60), 1 ) C PI(0)''S SECPAR(0) = 7.D0 DO I = 1, 3 CALL ADDANG3( COSTHE,PHIX,PHIY, COS345(I),PHI345(I), * SECPAR(2),SECPAR(3),SECPAR(4) ) #if __UPWARD__ IF ( SECPAR(2) .GE. -1.D0 ) THEN #else IF ( SECPAR(2) .GT. C(29) ) THEN #endif SECPAR(1) = GAM345(I) CALL TSTACK ELSE IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT #if __THIN__ DLONG(LHEIGH,17) = DLONG(LHEIGH,17) * + GAM345(I)*PAMA(7)*WEIGHT #else DLONG(LHEIGH,17) = DLONG(LHEIGH,17) * + GAM345(I) * PAMA(7) #endif ENDIF #if __AUGERHIST__ THICKLOC = THICK( H ) DO LL = 1, NOBSLV IF ( THICKLOC .GE. THCKOB(LL) .AND. * THICKLOC .LT. THCKOB(LL)+SAMPTH ) THEN C THICKH IS WITHIN 1 G/CM^2 BELOW OBSLEV(LL) C BRING THE ENERGY BELOW ANGULAR CUT TO THE HISTO OF LEVEL LL OUTPAR(0) = 7.D0 OUTPAR(1) = GAM345(I) OUTPAR(2) = SECPAR(2) OUTPAR(3) = SECPAR(3) OUTPAR(4) = SECPAR(4) DO II = 5, 8 OUTPAR(II) = CURPAR(II) ENDDO OUTPAR( 9) = GEN OUTPAR(10) = ALEVEL OUTPAR(13) = WEIGHT C WE HAVE ANGULAR CUT EDEP = OUTPAR(1) * PAMA(7) * WEIGHT CALL AUGERDEPFIL( EDEP,LL,1 ) ELSEIF ( THICKLOC .LT. THCKOB(LL) ) THEN GOTO 431 ENDIF ENDDO 431 CONTINUE #endif ENDIF ENDDO C DECAY K0L ----> PI(+) + PI(-) + PI(0) ELSE CALL DECAY6( PAMA(10), PAMA(8),PAMA(9),PAMA(7), * CKA(61),CKA(62),CKA(63), CKA(64), 1 ) C PI(+) AND PI(-) AND PI(0) DO I = 1, 3 CALL ADDANG3( COSTHE,PHIX,PHIY, COS345(I),PHI345(I), * SECPAR(2),SECPAR(3),SECPAR(4) ) #if __UPWARD__ IF ( SECPAR(2) .GE. -1.D0 ) THEN #else IF ( SECPAR(2) .GT. C(29) ) THEN #endif IF ( I .EQ. 3 ) THEN SECPAR(0) = 7.D0 ELSE SECPAR(0) = 7 + I ENDIF SECPAR(1) = GAM345(I) CALL TSTACK ELSE IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT IF ( I .EQ. 3 ) THEN #if __THIN__ DLONG(LHEIGH,17) = DLONG(LHEIGH,17) * + GAM345(I) * PAMA(7) * WEIGHT ELSE FAC1 = 0.25D0 FAC2 = 0.75D0 DLONG(LHEIGH,17) = DLONG(LHEIGH,17) * + GAM345(I)*PAMA(8)*WEIGHT*FAC1 DLONG(LHEIGH,18) = DLONG(LHEIGH,18) * + GAM345(I)*PAMA(8)*WEIGHT*FAC2 #else DLONG(LHEIGH,17) = DLONG(LHEIGH,17)+GAM345(I)*PAMA(7) ELSE FAC1 = 0.25D0 FAC2 = 0.75D0 DLONG(LHEIGH,17) = DLONG(LHEIGH,17) * +GAM345(I)*PAMA(8)*FAC1 DLONG(LHEIGH,18) = DLONG(LHEIGH,18) * +GAM345(I)*PAMA(8)*FAC2 #endif ENDIF ENDIF #if __AUGERHIST__ THICKLOC = THICK( H ) DO LL = 1, NOBSLV IF ( THICKLOC .GE. THCKOB(LL) .AND. * THICKLOC .LT. THCKOB(LL)+SAMPTH ) THEN C THICKH IS WITHIN 1 G/CM^2 BELOW OBSLEV(LL) C BRING THE ENERGY BELOW ANGULAR CUT TO THE HISTO OF LEVEL LL OUTPAR(1) = GAM345(I) IF ( I .EQ. 3 ) THEN OUTPAR(0) = 7.D0 EDEP = OUTPAR(1) * PAMA(7) * WEIGHT ELSE OUTPAR(0) = 7 + I EDEP = OUTPAR(1) * PAMA(8) * WEIGHT ENDIF OUTPAR(2) = SECPAR(2) OUTPAR(3) = SECPAR(3) OUTPAR(4) = SECPAR(4) DO II = 5, 8 OUTPAR(II) = CURPAR(II) ENDDO OUTPAR( 9) = GEN OUTPAR(10) = ALEVEL OUTPAR(13) = WEIGHT C WE HAVE ANGULAR CUT CALL AUGERDEPFIL( EDEP,LL,1 ) ELSEIF ( THICKLOC .LT. THCKOB(LL) ) THEN GOTO 441 ENDIF ENDDO 441 CONTINUE #endif ENDIF ENDDO ENDIF ENDIF C KILL CURRENT PARTICLE IRET1 = 1 RETURN END #if __SLANT__ *-- Author : D. HECK IK FZK KARLSRUHE 16/10/2003 C======================================================================= INTEGER FUNCTION LBIN( XX,YY,HH,ISTART ) C----------------------------------------------------------------------- C L(ONGITUDINAL) BIN C C DETERMINES THE LONGITUDINAL BIN OF SLANT DEPTH DISTRIBUTION FOR A #if __CURVED__ C PARTICLE WITH COORDINATES XX, YY AND APPARENT HEIGHT HH IN C CURVED COORDINATE SYSTEM #else C PARTICLE WITH CARTESIAN COORDINATES XX, YY, HH. #endif C THIS FUNCTION IS CALLED FROM AAMAIN, BOX3, EM, MUBREM, MUDECY, C MUNUCL, MUPRPR, MUTRAC, NUCINT, UPDATE, CERLDE. C ARGUMENTS: C XX = X COORDINATE OF PARTICLE (CM) C YY = Y COORDINATE OF PARTICLE (CM) #if __CURVED__ C HH = HAPP APPARENT HEIGHT OF PARTICLE IN DET. SYSTEM (CM) #else C HH = H ALTITUDE OF PARTICLE (CM) #endif C ISTART = STARTING BIN FOR FORWARD SEARCH C----------------------------------------------------------------------- IMPLICIT NONE #define __LONGIINC__ #define __OBSPARINC__ #define __PARPARINC__ #define __PARPAEINC__ #define __RUNPARINC__ #include "corsika.h" DOUBLE PRECISION AUXIL1,HHH,XXX,YYY,HH,XX,YY #if __CURVED__ DOUBLE PRECISION PHI1,RRR,SINTEA #endif INTEGER IEND,III,ISTART,ISTRT2 SAVE C----------------------------------------------------------------------- * IF ( DEBUG ) WRITE(MDEBUG,1) XX,YY,HH * 1 FORMAT(' LBIN : XX,YY,HH=',1P,3(1X,E16.9)) C TRANSFER COORDINATES TO LOCAL VARIABLES WHICH CAN BE CHANGED C (INPUT PARAMATERS SHOULD NOT BE CHANGED) HHH = HH XXX = XX YYY = YY #if __CURVED__ IF ( COSTEA .NE. 1.D0 ) THEN C WE ARE AWAY FROM DETECOR C CALCULATE AZIMUTH ANGLE OF PARTICLE SEEN FROM DETECTOR IF ( YYY .NE. 0.D0 .OR. XXX .NE. 0.D0 ) THEN PHI1 = ATAN2( YYY, XXX ) ELSE PHI1 = 0.D0 ENDIF C HORIZONTAL DISTANCE OF PARTICLE TO DETECTOR SINTEA = SQRT( (1.D0-COSTEA)*(1.D0+COSTEA) ) RRR = ( HHH + C(1) ) * SINTEA / COSTEA XXX = RRR * COS( PHI1 ) YYY = RRR * SIN( PHI1 ) ELSE C WE ARE IN THE DETECOR SYSTEM AND NEED NO COORDINATE CALCULATION XXX = XXX YYY = YYY ENDIF #endif AUXIL1 = XXX*STHCPH + YYY*STHSPH - HHH*CTH + RLOFF ISTRT2 = MAX( ISTART, 1 ) IEND = MIN( NSTEP+1, LNGMAX-2 ) GOTO 10 C REDUCE START BIN FOR A NEW SEARCH 40 CONTINUE * IF ( DEBUG ) WRITE(MDEBUG,*) 'LBIN : ISTRT2=',ISTRT2 ISTRT2 = ISTRT2 - 1 10 CONTINUE IF ( ISTRT2 .LE. 0 ) THEN LBIN = 0 * IF ( DEBUG ) WRITE(MDEBUG,*) * * 'LBIN : AUXIL1,LBIN=',SNGL(AUXIL1),LBIN RETURN ENDIF C MAKE SEARCH WITHIN WHICH BIN THE COORDINATES XXX,YYY,HHH ARE DO III = ISTRT2, IEND IF ( RLONG(III) .GT. AUXIL1 ) THEN IF ( RLONG(III-1) .LE. AUXIL1 ) THEN LBIN = III * IF ( DEBUG ) WRITE(MDEBUG,*) * * 'LBIN : AUXIL1,LBIN=',SNGL(AUXIL1),LBIN RETURN ELSE C START BIN IS TOO HIGH, REDUCE IT AND TRY NEW SEARCH GOTO 40 ENDIF ENDIF ENDDO LBIN = IEND * IF ( DEBUG ) WRITE(MDEBUG,*) * * 'LBIN : AUXIL1,LBIN=',SNGL(AUXIL1),LBIN RETURN END #endif #if __PLOTSH2__ *-- Author : Fabian Schmidt, Leeds University 02/05/2005 C======================================================================= SUBROUTINE LINPLXY( IM,X1,Y1,X2,Y2,W ) C----------------------------------------------------------------------- C LIN(E )PL(OT )XY C C PLOTS LINE INTO THE TRACK MAP SPECIFIED BY IM, FOR OPTION 'PLOTSH2'. C THIS SUBROUTINE IS CALLED FROM UPDATE, PHOTON, ELECTR. C C ARGUMENTS: C IM INDEX OF MAP (1: EM, 2: MU+/-, 3: HADRONS) C X1,Y1 COORDINATES OF STARTING POINT (CM) C X2,Y2 COORDINATES OF END POINT (CM) C W WEIGHT OF PARTICLE C C ADAPTED FROM A ROUTINE WRITTEN BY J. KNAPP, LEEDS C----------------------------------------------------------------------- IMPLICIT NONE #define __PLOTSH2INC__ #include "corsika.h" DOUBLE PRECISION W REAL X1,Y1,X2,Y2,XXCONST,YYCONST,XX1,YY1 INTEGER IM INTEGER IXX1,IXX2,IYY1,IYY2,IX1,IX2,IY1,IY2,IYY,IXX INTEGER I SAVE C----------------------------------------------------------------------- IF ( X1 .EQ. X2 .AND. Y1 .EQ. Y2 ) RETURN IXX1 = NINT( 1. + (X1-PLX1) * XCONST ) IXX2 = NINT( 1. + (X2-PLX1) * XCONST ) IYY1 = NINT( 1. + (Y1-PLY1) * YCONST ) IYY2 = NINT( 1. + (Y2-PLY1) * YCONST ) IX1 = MIN( IXX1, IXX2 ) IX2 = MAX( IXX1, IXX2 ) IY1 = MIN( IYY1, IYY2 ) IY2 = MAX( IYY1, IYY2 ) cc WRITE(*,*) 'LINPL : X1, Y1, X2, Y2', X1,Y1,X2,Y2 cc WRITE(*,*) 'LINPL : IX1,IY1,IX2,IY2', IX1,IY1,IX2,IY2 IF ( IX1 .EQ. IX2 ) THEN IF ( IY1 .EQ. IY2 ) THEN C ONLY A POINT IF ( IX1 .GE. 1 ) THEN IF ( IX1 .LE. IXRES ) THEN IF ( IY1 .GE. 1 ) THEN IF ( IY1 .LE. IYRES ) THEN PLMAPXY(IM,IY1,IX1) = PLMAPXY(IM,IY1,IX1) + W ENDIF ENDIF ENDIF ENDIF cc WRITE(*,*) 'LINPL POINT: ',IX1,IY1 ELSE C VERTICAL LINE DO I = IY1, IY2 IF ( IX1 .GE. 1 ) THEN IF ( IX1 .LE. IXRES ) THEN IF ( I .GE. 1 ) THEN IF ( I .LE. IYRES ) THEN PLMAPXY(IM,I,IX1) = PLMAPXY(IM,I,IX1) + W ENDIF ENDIF ENDIF ENDIF cc WRITE(*,*) 'LINPL VERT: ',IX1,I ENDDO ENDIF ELSEIF ( IY1 .EQ. IY2 ) THEN C HORIZONTAL LINE DO I = IX1, IX2 IF ( I .GE. 1 ) THEN IF ( I .LE. IXRES ) THEN IF ( IY1 .GE. 1 ) THEN IF ( IY1 .LE. IYRES ) THEN PLMAPXY(IM,IY1,I) = PLMAPXY(IM,IY1,I) + W ENDIF ENDIF ENDIF ENDIF cc WRITE(*,*) 'LINPL HORZ: ',I,IY1 ENDDO ELSE C SKEW LINES C ALONG THE X-AXIS IF ( ABS(IX2-IX1) .GT. ABS(IY2-IY1) ) THEN YYCONST = (Y2-Y1)/(X2-X1) DO I = IX1, IX2 XX1 = (I-1)/XCONST + PLX1 YY1 = Y1 + (XX1-X1) * YYCONST IYY = NINT( 1. + (YY1-PLY1) * YCONST ) cc WRITE(*,*) 'LINPL ALNG X: ',XX1,YY1,I,IYY IF ( I .GE. 1 ) THEN IF ( I .LE. IXRES ) THEN IF ( IYY .GE. 1 ) THEN IF ( IYY .LE. IYRES ) THEN PLMAPXY(IM,IYY,I) = PLMAPXY(IM,IYY,I) + W ENDIF ENDIF ENDIF ENDIF ENDDO ELSE C ALONG THE Y-AXIS XXCONST = (X2-X1)/(Y2-Y1) DO I = IY1, IY2 YY1 = (I-1)/YCONST + PLY1 XX1 = X1 + (YY1-Y1) * XXCONST IXX = NINT( 1. + (XX1-PLX1) * XCONST ) cc WRITE(*,*) 'LINPL ALNG Y: ',XX1,YY1,IXX,I IF ( IXX .GE. 1 ) THEN IF ( IXX .LE. IXRES ) THEN IF ( I .GE. 1 ) THEN IF ( I .LE. IYRES ) THEN PLMAPXY(IM,I,IXX) = PLMAPXY(IM,I,IXX) + W ENDIF ENDIF ENDIF ENDIF ENDDO ENDIF ENDIF RETURN END #endif #if __PLOTSH2__ *-- Author : Fabian Schmidt, Leeds University 02/05/2005 C======================================================================= SUBROUTINE LINPLXZ( IM,X1,Z1,X2,Z2,W ) C----------------------------------------------------------------------- C LIN(E )PL(OT )XZ C C PLOTS LINE INTO THE TRACK MAP SPECIFIED BY IM, FOR OPTION 'PLOTSH2'. C THIS SUBROUTINE IS CALLED FROM UPDATE, PHOTON, ELECTR. C C ARGUMENTS: C IM INDEX OF MAP (1: EM, 2: MU+/-, 3: HADRONS) C X1,Z1 COORDINATES OF STARTING POINT (CM) C X2,Z2 COORDINATES OF END POINT (CM) C W WEIGHT OF PARTICLE C C ADAPTED FROM A ROUTINE WRITTEN BY J. KNAPP, LEEDS C----------------------------------------------------------------------- IMPLICIT NONE #define __PLOTSH2INC__ #include "corsika.h" DOUBLE PRECISION W REAL X1,Z1,X2,Z2,XXCONST,ZZCONST,XX1,ZZ1 INTEGER IM INTEGER IXX1,IXX2,IZZ1,IZZ2,IX1,IX2,IZ1,IZ2,IZZ,IXX INTEGER I SAVE C----------------------------------------------------------------------- IF ( X1 .EQ. X2 .AND. Z1 .EQ. Z2 ) RETURN IXX1 = NINT( 1. + (X1-PLX1) * XCONST ) IXX2 = NINT( 1. + (X2-PLX1) * XCONST ) IZZ1 = NINT( 1. + (Z1-PLZ1) * ZCONST ) IZZ2 = NINT( 1. + (Z2-PLZ1) * ZCONST ) IX1 = MIN( IXX1, IXX2 ) IX2 = MAX( IXX1, IXX2 ) IZ1 = MIN( IZZ1, IZZ2 ) IZ2 = MAX( IZZ1, IZZ2 ) cc WRITE(*,*) 'LINPL : X1, Z1, X2, Z2', X1,Z1,X2,Z2 cc WRITE(*,*) 'LINPL : IX1,IZ1,IX2,IZ2', IX1,IZ1,IX2,IZ2 IF ( IX1 .EQ. IX2 ) THEN IF ( IZ1 .EQ. IZ2 ) THEN C ONLY A POINT IF ( IX1 .GE. 1 ) THEN IF ( IX1 .LE. IXRES ) THEN IF ( IZ1 .GE. 1 ) THEN IF ( IZ1 .LE. IZRES ) THEN PLMAPXZ(IM,IZ1,IX1) = PLMAPXZ(IM,IZ1,IX1) + W ENDIF ENDIF ENDIF ENDIF cc WRITE(*,*) 'LINPL POINT: ',IX1,IZ1 ELSE C VERTICAL LINE DO I=IZ1,IZ2 IF ( IX1 .GE. 1 ) THEN IF ( IX1 .LE. IXRES ) THEN IF ( I .GE. 1 ) THEN IF ( I .LE. IZRES ) THEN PLMAPXZ(IM,I,IX1) = PLMAPXZ(IM,I,IX1) + W ENDIF ENDIF ENDIF ENDIF cc WRITE(*,*) 'LINPL VERT: ',IX1,I ENDDO ENDIF ELSEIF ( IZ1 .EQ. IZ2 ) THEN C HORIZONTAL LINE DO I = IX1, IX2 IF ( I .GE. 1 ) THEN IF ( I .LE. IXRES ) THEN IF ( IZ1 .GE. 1 ) THEN IF ( IZ1 .LE. IZRES ) THEN PLMAPXZ(IM,IZ1,I) = PLMAPXZ(IM,IZ1,I) + W ENDIF ENDIF ENDIF ENDIF cc WRITE(*,*) 'LINPL HORZ: ',I,IZ1 ENDDO ELSE C SKEW LINES C ALONG THE x-AXIS IF ( ABS(IX2-IX1) .GT. ABS(IZ2-IZ1) ) THEN ZZCONST = (Z2-Z1)/(X2-X1) DO I = IX1, IX2 XX1 = (I-1)/XCONST + PLX1 ZZ1 = Z1 + (XX1-X1) * ZZCONST IZZ = NINT( 1. + (ZZ1-PLZ1) * ZCONST ) cc WRITE(*,*) 'LINPL ALNG X: ',XX1,ZZ1,I,IZZ IF ( I .GE. 1 ) THEN IF ( I .LE. IXRES ) THEN IF ( IZZ .GE. 1 ) THEN IF ( IZZ .LE. IZRES ) THEN PLMAPXZ(IM,IZZ,I) = PLMAPXZ(IM,IZZ,I) + W ENDIF ENDIF ENDIF ENDIF ENDDO ELSE C ALONG THE Z-AXIS XXCONST = (X2-X1)/(Z2-Z1) DO I = IZ1, IZ2 ZZ1 = (I-1)/ZCONST + PLZ1 XX1 = X1 + (ZZ1-Z1) * XXCONST IXX = NINT( 1. + (XX1-PLX1) * XCONST ) cc WRITE(*,*) 'LINPL ALNG Z: ',XX1,ZZ1,IXX,I IF ( IXX .GE. 1 ) THEN IF ( IXX .LE. IXRES ) THEN IF ( I .GE. 1 ) THEN IF ( I .LE. IZRES ) THEN PLMAPXZ(IM,I,IXX) = PLMAPXZ(IM,I,IXX) + W ENDIF ENDIF ENDIF ENDIF ENDDO ENDIF ENDIF RETURN END #endif #if __PLOTSH2__ *-- Author : Fabian Schmidt, Leeds University 02/05/2005 C======================================================================= SUBROUTINE LINPLYZ( IM,Y1,Z1,Y2,Z2,W ) C----------------------------------------------------------------------- C LIN(E )PL(OT )YZ C C PLOTS LINE INTO THE TRACK MAP SPECIFIED BY IM, FOR OPTION 'PLOTSH2'. C THIS SUBROUTINE IS CALLED FROM UPDATE, PHOTON, ELECTR. C C ARGUMENTS: C IM INDEX OF MAP (1: EM, 2: MU+/-, 3: HADRONS) C Y1,Z1 COORDINATES OF STARTING POINT (CM) C Y2,Z2 COORDINATES OF END POINT (CM) C W WEIGHT OF PARTICLE C C ADAPTED FROM A ROUTINE WRITTEN BY J. KNAPP, LEEDS C----------------------------------------------------------------------- IMPLICIT NONE #define __PLOTSH2INC__ #include "corsika.h" DOUBLE PRECISION W REAL Y1,Z1,Y2,Z2,YYCONST,ZZCONST,YY1,ZZ1 INTEGER IM INTEGER IYY1,IYY2,IZZ1,IZZ2,IY1,IY2,IZ1,IZ2,IZZ,IYY INTEGER I SAVE C----------------------------------------------------------------------- IF ( Y1 .EQ. Y2 .AND. Z1 .EQ. Z2 ) RETURN IYY1 = NINT( 1. + (Y1-PLY1) * YCONST ) IYY2 = NINT( 1. + (Y2-PLY1) * YCONST ) IZZ1 = NINT( 1. + (Z1-PLZ1) * ZCONST ) IZZ2 = NINT( 1. + (Z2-PLZ1) * ZCONST ) IY1 = MIN( IYY1, IYY2 ) IY2 = MAX( IYY1, IYY2 ) IZ1 = MIN( IZZ1, IZZ2 ) IZ2 = MAX( IZZ1, IZZ2 ) cc WRITE(*,*) 'LINPL : Y1, Z1, Y2, Z2', Y1,Z1,Y2,Z2 cc WRITE(*,*) 'LINPl : IY1,IZ1,IY2,IZ2', IY1,IZ1,IY2,IZ2 IF ( IY1 .EQ. IY2 ) THEN IF ( IZ1 .EQ. IZ2 ) THEN C ONLY A POINT IF ( IY1 .GE. 1 ) THEN IF ( IY1 .LE. IYRES ) THEN IF ( IZ1 .GE. 1 ) THEN IF ( IZ1 .LE. IZRES ) THEN PLMAPYZ(IM,IZ1,IY1) = PLMAPYZ(IM,IZ1,IY1) + W ENDIF ENDIF ENDIF ENDIF cc WRITE(*,*) 'LINPL POINT: ',IY1,IZ1 ELSE C VERTICAL LINE DO I = IZ1, IZ2 IF ( IY1 .GE. 1 ) THEN IF ( IY1 .LE. IYRES ) THEN IF ( I .GE. 1 ) THEN IF ( I .LE. IZRES ) THEN PLMAPYZ(IM,I,IY1) = PLMAPYZ(IM,I,IY1) + W ENDIF ENDIF ENDIF ENDIF cc WRITE(*,*) 'LINPL VERT: ',IY1,I ENDDO ENDIF ELSEIF ( IZ1 .EQ. IZ2 ) THEN C HORIZONTAL LINE DO I = IY1, IY2 IF ( I .GE. 1 ) THEN IF ( I .LE. IYRES ) THEN IF ( IZ1 .GE. 1 ) THEN IF ( IZ1 .LE. IZRES ) THEN PLMAPYZ(IM,IZ1,I) = PLMAPYZ(IM,IZ1,I) + W ENDIF ENDIF ENDIF ENDIF cc WRITE(*,*) 'LINPL HORZ: ',I,IZ1 ENDDO ELSE C SKEW LINES C ALONG THE Y-AXIS IF ( ABS(IY2-IY1) .GT. ABS(IZ2-IZ1) ) THEN ZZCONST = (Z2-Z1)/(Y2-Y1) DO I = IY1, IY2 YY1 = (I-1)/YCONST + PLY1 ZZ1 = Z1 + (YY1-Y1) * ZZCONST IZZ = NINT( 1. + (ZZ1-PLZ1) * ZCONST ) cc WRITE(*,*) 'LINPL ALNG Y: ',YY1,ZZ1,I,IZZ IF ( I .GE. 1 ) THEN IF ( I .LE. IYRES ) THEN IF ( IZZ .GE. 1 ) THEN IF ( IZZ .LE. IZRES ) THEN PLMAPYZ(IM,IZZ,I) = PLMAPYZ(IM,IZZ,I) + W ENDIF ENDIF ENDIF ENDIF ENDDO ELSE C ALONG THE Z-AXIS YYCONST = (Y2-Y1)/(Z2-Z1) DO I = IZ1, IZ2 ZZ1 = (I-1)/ZCONST + PLZ1 YY1 = Y1 + (ZZ1-Z1) * YYCONST IYY = NINT( 1. + (YY1-PLY1) * YCONST ) cc WRITE(*,*) 'LINPL ALNG Z: ',YY1,ZZ1,IYY,I IF ( IYY .GE. 1 ) THEN IF ( IYY .LE. IYRES ) THEN IF ( I .GE. 1 ) THEN IF ( I .LE. IZRES ) THEN PLMAPYZ(IM,I,IYY) = PLMAPYZ(IM,I,IYY) + W ENDIF ENDIF ENDIF ENDIF ENDDO ENDIF ENDIF RETURN END #endif *-- Author : The CORSIKA development group 31/05/2017 C======================================================================= #if __PARALLELIB__ SUBROUTINE PARLONGFT( FPARAM,CHI2,CHAPARMPI,DEPMPI,NSTPMPI ) C----------------------------------------------------------------------- C PAR(ALLEL CALL OF) LONG(ITUDINAL) F(I)T C C THIS ROUTINE IS CALLED FROM MPIRUNNER IN ORDER TO PASS ACCUMULATED C VALUES OF THE ARRAYS OF PARTICLE NUMBERS AND DEPTH VALUES FOR C LONGITUDAL DISTRIBUTION BEFORE CALLING STANDARD LONGFT SUBROUTINE C C ARGUMENTS: C FPARAM = ARRAY WITH THE FINAL FITTED PARAMETERS (6 PARAMETERS) C CHI2 = CHI SQUARED C CHAPARMPI = ARRAY OF PARTICLE NUMBERS FOR LONGITUDAL DISTRIBUTION C DEPMPI = ARRAY OF DEPTH VALUES FOR LONGITUDAL DISTRIBUTION C NSTPMPI = NUMBER OF STEPS FOR LONGITUDAL DISTRIBUTION FIT C C----------------------------------------------------------------------- IMPLICIT NONE #define __CURVEINC__ #define __PARPARINC__ #define __RUNPARINC__ #include "corsika.h" INTEGER NPAR PARAMETER (NPAR=6) DOUBLE PRECISION F(NPAR),FPARAM(NPAR),CHI2 INTEGER I SAVE INTEGER NSTPMPI DOUBLE PRECISION CHAPARMPI(15000),DEPMPI(15000) C----------------------------------------------------------------------- C COPY PARAMETERS PASSED BY MPI NSTP = NSTPMPI DO I = 1, NSTP CHAPAR(I) = CHAPARMPI(I) DEP(I) = DEPMPI(I) ENDDO C NOW CALL THE ORIGINAL LONGFT CALL LONGFT( FPARAM,CHI2 ) RETURN END #endif *-- Author : The CORSIKA development group 16/05/1995 C======================================================================= SUBROUTINE LONGFT( FPARAM,CHI2 ) C----------------------------------------------------------------------- C 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) = NMAX * ((T-T0)/(TMAX-T0))**((TMAX-T0)/P) * EXP((TMAX-T)/P) C WITH: C NMAX = 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) = NMAX * ((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 NMAX = 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 AAMAIN. C ARGUMENTS: C FPARAM = ARRAY WITH THE FINAL FITTED PARAMETERS (6 PARAMETERS) C CHI2 = CHI SQUARED C----------------------------------------------------------------------- IMPLICIT NONE #define __CURVEINC__ #define __PARPARINC__ #define __RUNPARINC__ #include "corsika.h" INTEGER NPAR PARAMETER (NPAR=6) DOUBLE PRECISION F(NPAR),FPARAM(NPAR),CHI2,CHISQ,CHISQ1 DOUBLE PRECISION P(NPAR+1,NPAR),Y(NPAR+1),EPS DOUBLE PRECISION P1(NPAR-1,NPAR-2),FPARAM1(NPAR-2),CHI21 DOUBLE PRECISION HALFW,T0,TMAX,NMAX,FAC INTEGER I,II,ILOWER,IMAX,IUPPER,J,JJ,K,ITER,IFLAG SAVE EXTERNAL CHISQ,CHISQ1 C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'LONGFT:' C FIND GOOD START VALUES FOR XMAX AND FMAX NMAX = 0.D0 TMAX = 400.D0 IMAX = 0 DO I = 1, NSTP ERR(I) = MAX( 1.D0, SQRT( CHAPAR(I) ) ) IF ( CHAPAR(I) .GT. NMAX ) THEN NMAX = CHAPAR(I) TMAX = DEP(I) IMAX = I ENDIF ENDDO C STARTVALUE FOR X0 IS ABOUT WHERE MORE THAN 1 PARTICLE SHOWS UP II = 1 DO I = 1, NSTP IF ( CHAPAR(I) .GT. 1.D0 ) GOTO 1 II = I ENDDO C OBVIOUSLY WE HAVE NO PARTICLES IN THE DISTRIBUTION WRITE(MONIOU,*) * 'LONGFT: NO PARTICLES IN LONGITUDINAL DISTRIBUTION' WRITE (MONIOU,*)' NO FIT POSSIBLE' DO I = 1, NPAR FPARAM(I) = 0.D0 ENDDO CHI2 = 0.D0 RETURN 1 CONTINUE IF ( II .GT. 1 ) THEN T0 = 0.5 * ( 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*NMAX ) THEN IUPPER = I GOTO 31 ENDIF ENDDO IUPPER = IMAX - 1 31 CONTINUE DO I = IMAX, NSTP IF ( CHAPAR(I) .LT. 0.5D0*NMAX ) 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----------------------------------------------------------------------- C FIT IS PERFORMED WITH THE SUBROUT. AMOEBA 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 P1(1,1) = NMAX P1(1,2) = T0 P1(1,3) = TMAX P1(1,4) = HALFW IF (DEBUG) WRITE(MDEBUG,*) 'LONGFT: START VALS=',(P1(1,I),I=1,4) C LOOP OVER FITTING ROUTINE (2 TIMES 3 FITS WITH VARYING PRECISION) DO J = 1, 2 DO JJ = 1, 3 C START WITH CRUDE PRECISION AND IMPROVE STEP BY STEP C AFTER THREE 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-2 STARTING VERTICES FROM THE STARTING POINT BY C VARIATION OF ONLY ONE OF THE COORDINATE VALUES DO I = 2, NPAR-1 DO K = 1, NPAR-2 P1(I,K) = P1(1,K) ENDDO IF ( P1(I,I-1) .EQ. 0.D0 ) THEN P1(I,I-1) = 1.D0 ELSE P1(I,I-1) = P1(I,I-1) * FAC ENDIF ENDDO IF ( DEBUG ) WRITE(MDEBUG,*) 'LONGFT: TRIAL1,FAC,EPS ', * J,FAC,EPS C CALCULATE FUNCTION VALUES AT THE START VERTICES DO I = 1, NPAR-1 DO K = 1, NPAR-2 F(K) = P1(I,K) ENDDO Y(I) = CHISQ1(F) ENDDO C PERFORM A FIT CALL AMOEBA( P1,Y,NPAR-1,NPAR-2,NPAR-2,EPS,CHISQ1,ITER,IFLAG ) IF ( DEBUG ) THEN WRITE(MDEBUG,*) 'LONGFT: ITER1/IFLAG=',ITER,IFLAG WRITE(MDEBUG,*) 'LONGFT: PARAMETERS1=',(SNGL(P1(1,K)),K=1,4) WRITE(MDEBUG,*) 'LONGFT: CHISQ2 =',Y(1) ENDIF C STORE CHI**2 AT FIRST TRIAL OR AT IMPROVED RESULT IF ( J .EQ. 1 .OR. Y(1) .LT. CHI21 ) THEN DO I = 1, NPAR-2 FPARAM1(I) = P1(1,I) ENDDO CHI21 = Y(1) ENDIF C END OF LOOPS OVER THE FITTING ROUTINE ENDDO ENDDO IF (DEBUG) WRITE(MDEBUG,*) 'LONGFIT: INTERMEDIATE PARAMETERS ARE', * (SNGL(FPARAM1(I)),I=1,4),CHI21 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C CREATE A SET OF NPAR+1 STARTING VERTICES C HERE IS THE FIRST ONE (THE FIRST FOUR PARAMETERS REMAIN UNCHANGED) C EXPERIENCE SHOWS, THAT THE FIFTH PARAMETER IS USUALLY NEGATIVE P(1,1) = FPARAM1(1) P(1,2) = FPARAM1(2) P(1,3) = FPARAM1(3) P(1,4) = FPARAM1(4) ** 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 J = 1, 2 DO 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 I = 2, NPAR+1 DO K = 1, NPAR P(I,K) = P(1,K) ENDDO 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 ENDDO IF ( DEBUG ) WRITE(MDEBUG,*) 'LONGFT: TRIAL,FAC,EPS ',J, * SNGL(FAC),SNGL(EPS) C CALCULATE FUNCTION VALUES AT THE START VERTICES DO I = 1, NPAR+1 DO K = 1, NPAR F(K) = P(I,K) ENDDO Y(I) = CHISQ(F) ENDDO C PERFORM A FIT CALL AMOEBA( P,Y,NPAR+1,NPAR,NPAR,EPS,CHISQ,ITER,IFLAG ) IF ( DEBUG ) THEN WRITE(MDEBUG,*) 'LONGFT: ITER/IFLAG=',ITER,IFLAG WRITE(MDEBUG,*) 'LONGFT: PARAMETERS=',(SNGL(P(1,K)),K=1,6) WRITE(MDEBUG,*) 'LONGFT: CHISQ =',SNGL(Y(1)) ENDIF C STORE VALUES AT FIRST TRIAL OR AT IMPROVED RESULT IF ( J .EQ. 1 .OR. Y(1) .LT. CHI2 ) THEN DO I = 1, NPAR FPARAM(I) = P(1,I) ENDDO CHI2 = Y(1) ENDIF C END OF LOOPS OVER THE FITTING ROUTINE ENDDO ENDDO RETURN END *-- Author : K. BERNLOEHR MPIK HEIDELBERG 15/06/1998 C======================================================================= SUBROUTINE LOWUP( CHAR,IDX ) C----------------------------------------------------------------------- C (CONVERTS) LOW(ER CASE CHARACTER TO) UP(PER CASE CHARACTER) C C THIS SUBROUTINE IS CALLED FROM DATAC. C ARGUMENT: C CHAR = CHARACTER TO BE CONVERTED C IDX = INDEX OF CONVERTED CHARACTER C----------------------------------------------------------------------- IMPLICIT NONE INTEGER IDX CHARACTER*1 CHAR CHARACTER LOWCHR*26, UPRCHR*26 SAVE DATA UPRCHR / 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' / DATA LOWCHR / 'abcdefghijklmnopqrstuvwxyz' / C----------------------------------------------------------------------- IDX = INDEX(LOWCHR,CHAR) IF ( IDX .NE. 0 ) CHAR = UPRCHR(IDX:IDX) RETURN END *-- Author : D. HECK IK FZK KARLSRUHE 15/10/1996 C======================================================================= SUBROUTINE MMOL4( 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----------------------------------------------------------------------- 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 *-- Author : D. HECK IK FZK KARLSRUHE 15/10/1996 C======================================================================= SUBROUTINE MMOLIE( 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 UPDATE. C ARGUMENTS: C OMEGA = NUMBER OF SCATTERINGS FOR THE STEP C DENS = LOCAL DENSITY (G/CM**3) C----------------------------------------------------------------------- IMPLICIT NONE #define __CONSTAINC__ #define __MUMULTINC__ #define __PAMINC__ #define __PARPARINC__ #define __PARPAEINC__ #define __RANDPAINC__ #define __RUNPARINC__ #include "corsika.h" DOUBLE PRECISION TINT(40),B,BINV,CHIC,CNST,DB,DENS,OMEGA,SINTH, * TEST,TMP,XINT 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----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'MMOLIE: OMEGA=',SNGL(OMEGA), * ' DENS=',SNGL(DENS) C COMPUTE VSCAT ANGLE FROM MOLIERE DISTRIBUTION VSCAT = 0.D0 IF ( OMEGA .LE. ENEPER ) 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 ) / ( PAMA(ITYPE) * GAMMA * BETA**2 ) 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,1 ) 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 MMOL4( THRI,XINT2,VAL,ARG,F,IER ) 80 CONTINUE VSCAT = CHIC * SQRT( ABS(B*THRI) ) IF ( VSCAT .GT. PI ) GOTO 40 SINTH = SIN( VSCAT ) TEST = VSCAT * (RD(1))**2 IF ( TEST .GT. SINTH ) GOTO 40 RETURN END *-- Author : D. HECK IK FZK KARLSRUHE 15/10/1996 C======================================================================= SUBROUTINE MPOISS( AMEAN,NPRAN ) 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 NPRAN = RANDOM NUMBER POISSON DISTRIBUTED C----------------------------------------------------------------------- IMPLICIT NONE #define __CONSTAINC__ #define __RANDPAINC__ #define __RUNPARINC__ #include "corsika.h" DOUBLE PRECISION AMEAN,AN,HMXINT,P,PLIM,RR,S,X INTEGER NPRAN SAVE DATA PLIM / 16.D0 /, HMXINT / 2.D9 / C----------------------------------------------------------------------- C PROTECTION AGAINST NEGATIVE MEAN VALUES AN = 0.D0 IF ( AMEAN .GT. 0.D0 ) THEN IF ( AMEAN .LE. PLIM ) THEN CALL RMMARD( RD,1,1 ) 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 CALL RMMARD( RD,2,1 ) RR = SQRT( (-2.D0)*LOG( RD(1) ) ) X = RR * COS( PI2 * RD(2) ) AN = MIN( MAX( 0.D0, AMEAN+X*SQRT( AMEAN ) ), HMXINT ) ENDIF ENDIF 20 NPRAN = AN RETURN END *-- Author : D. HECK IK FZK KARLSRUHE 25/09/1996 C======================================================================= SUBROUTINE MUBREM C----------------------------------------------------------------------- C MU(ON) BREM(SSTRAHLUNG) (ALSO USED FOR TAU LEPTONS) C C TREATES MUON/TAU 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 MUTRAC. C----------------------------------------------------------------------- IMPLICIT NONE #define __AIRINC__ #define __CONSTAINC__ #define __ELABCTINC__ #define __GENERINC__ #define __LONGIINC__ #define __MUPARTINC__ #define __PAMINC__ #define __PARPARINC__ #define __PARPAEINC__ #define __POLARINC__ #define __RANDPAINC__ #define __RESTINC__ #define __RUNPARINC__ #define __SIGMUINC__ #if __AUGERHIST__ #define __OBSPARINC__ #endif #include "corsika.h" DOUBLE PRECISION ALFA1,BETA1,COSTH3,CREJ,D,EKIN,F1, * PHI3,SCREJ,SIGNEW,SIGOLD,SINTH3,THETA3, * U,UMAX,V,VC,VM,V1,W1,Z INTEGER I,KCOUNT #if __AUGERHIST__ DOUBLE PRECISION EDEP,THICKLOC INTEGER II,LL #endif #if __SLANT__ INTEGER LBIN EXTERNAL LBIN #endif SAVE DOUBLE PRECISION CBRSGM,THICK EXTERNAL CBRSGM,THICK DATA ALFA1 / 0.625D0 / C----------------------------------------------------------------------- #if __THIN__ IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=0,9),WEIGHT 444 FORMAT(' MUBREM: CURPAR=',1P,11E11.3) #else IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=0,9) 444 FORMAT(' MUBREM: CURPAR=',1P,10E11.3) #endif C COPY VERTEX COORDINATES TO SECPAR DO I = 5, 8 SECPAR(I) = CURPAR(I) ENDDO C INCREASE GENERATION COUNTER BY 200 TO MARK EM PARTICLES FROM MU CHANNEL SECPAR(9) = GEN + 200.D0 #if __THIN__ SECPAR(13) = WEIGHT #endif #if __CURVED__ SECPAR(14) = CURPAR(14) SECPAR(15) = CURPAR(15) SECPAR(16) = CURPAR(16) #endif #if __INTTEST__ SECPAR(17) = CURPAR(17) #endif #if __EHISTORY__ DO I = 17, 38 SECPAR(I) = CURPAR(I) ENDDO #endif #if __PARALLEL__ C SET ECTFLG TO OFF SECPAR(39) = CURPAR(39) #endif #if __MULTITHIN__ DO I = 41, 46 SECPAR(I) = CURPAR(I) ENDDO #endif #if __SLANT__ #if __CURVED__ IF ( LLONGI ) LHEIGH = MIN( LBIN( X,Y,HAPP,1 ), NSTEP+1 ) #else IF ( LLONGI ) LHEIGH = MIN( LBIN( X,Y,H,1 ), NSTEP+1 ) #endif #else IF ( LLONGI ) LHEIGH = INT( THICK( H )*THSTPI + 1.D0 ) #endif C TOTAL AND KINETIC ENERGY OF MUON EE = PAMA(ITYPE) * GAMMA EKIN = EE - PAMA(ITYPE) IF ( EKIN .LE. BCUT ) THEN C MUON ENERGY IS TOO LOW TO PRODUCE BREMSSTRAHLUNG SECPAR(1) = CURPAR(1) GOTO 900 ENDIF C CHECK THE REDUCED CROSS-SECTIONS AND SKIP INTERACTION EVENTUALLY C RESTORE OLD CROSS SECTION IF ( LIT .EQ. 1 ) THEN SIGOLD = FRABTN / COMPOS(1) ELSEIF ( LIT .EQ. 2 ) THEN SIGOLD = (FRBTNO - FRABTN) / COMPOS(2) ELSEIF ( LIT .EQ. 3 ) THEN SIGOLD = (SIGBRM - FRBTNO) / COMPOS(3) ELSE WRITE(MONIOU,*) 'MUBREM: WRONG TARGET LIT =',LIT,' STOP' STOP ENDIF C GET NEW CROSS-SECTION SIGNEW = CBRSGM( EE,LIT,MT ) CALL RMMARD( RD,1,1 ) IF ( RD(1)*SIGOLD .GT. SIGNEW ) THEN C SKIP INTERACTION IF RANDOM NUMBER GREATER THAN CROSS-SECTION RATIO SECPAR(1) = CURPAR(1) GOTO 900 ENDIF VC = BCUT/EE IF ( MT .EQ. 1 ) THEN VM = 1.D0 - CMUON(6+LIT)/EE ELSE VM = 1.D0 - CTAU(6+LIT)/EE ENDIF IF ( VM .LE. 0.D0 ) THEN C MAXIMUM OF BREMSSTRAHLUNG SPECTRUM IS NEGATIVE, NO BREMSSTRAHLUNG SECPAR(1) = CURPAR(1) GOTO 900 ENDIF IF ( MT .EQ. 1 ) THEN CREJ = CMUON(3+LIT)/EE ELSE CREJ = CTAU(3+LIT)/EE ENDIF KCOUNT = 0 50 CONTINUE KCOUNT = KCOUNT + 1 IF ( KCOUNT .GT. 1000 ) THEN SECPAR(1) = CURPAR(1) GOTO 900 ENDIF CALL RMMARD( RD,2,1 ) V = VC*(VM/VC)**RD(1) V1 = 1.D0 - V C COMPUTE REJECTION FUNCTION IF ( MT .EQ. 1 ) THEN F1 = CMUON(LIT) - LOG( 1.D0 + CREJ*V/V1 ) SCREJ = (V1 + 0.75D0*V*V)*F1/CMUON(LIT) ELSE F1 = CTAU(LIT) - LOG( 1.D0 + CREJ*V/V1 ) SCREJ = (V1 + 0.75D0*V*V)*F1/CTAU(LIT) ENDIF IF ( RD(2) .GT. SCREJ ) GOTO 50 C GAMMA ENERGY SECPAR(1) = EE * V C RADIATED GAMMA BELOW CUT? IF ( SECPAR(1) .LE. ELCUT(4) ) THEN IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT #if __THIN__ DLONG(LHEIGH,1) = DLONG(LHEIGH,1) + SECPAR(1) * WEIGHT #else DLONG(LHEIGH,1) = DLONG(LHEIGH,1) + SECPAR(1) #endif ENDIF #if __AUGERHIST__ THICKLOC = THICK( H ) DO LL = 1, NOBSLV IF ( THICKLOC .GE. THCKOB(LL) .AND. * THICKLOC .LT. THCKOB(LL)+SAMPTH ) THEN C THICKH IS WITHIN 1 G/CM^2 BELOW OBSLEV(LL) C BRING THE ENERGY BELOW CUT TO THE HISTO OF LEVEL LL OUTPAR( 0) = 1.D0 OUTPAR( 1) = SECPAR(1) EDEP = SECPAR(1) * WEIGHT DO II = 2, 8 OUTPAR(II) = CURPAR(II) ENDDO OUTPAR( 9) = GEN OUTPAR(10) = ALEVEL OUTPAR(13) = WEIGHT CALL AUGERDEPFIL( EDEP,LL,0 ) ELSEIF ( THICKLOC .LT. THCKOB(LL) ) THEN GOTO 111 ENDIF ENDDO 111 CONTINUE #endif C REDUCE ENERGY OF MUON GOTO 800 ENDIF C SET MATERIAL CONSTANTS CMUON(.) ACCORDING TO C TARGET INDEX LIT (1=N, 2=O, 3=AR) WHICH HAS BEEN SET IN BOX2 IF ( LIT .EQ. 1 ) THEN Z = 7.D0 ELSEIF ( LIT .EQ. 2 ) THEN Z = 8.D0 ELSE Z = 18.D0 ENDIF 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 / PAMA(ITYPE) 10 CONTINUE CALL RMMARD( RD,3,1 ) 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 * PAMA(ITYPE) / EE COSTH3 = COS( THETA3 ) SINTH3 = SIN( THETA3 ) CALL RMMARD( RD,1,1 ) PHI3 = PI2 * RD(1) CALL ADDANG3( COSTHE,PHIX,PHIY, COSTH3,PHI3, * SECPAR(2),SECPAR(3),SECPAR(4) ) #if __UPWARD__ IF ( SECPAR(2) .GE. -1.D0 ) THEN #else IF ( SECPAR(2) .GT. C(29) ) THEN #endif C WRITE BREMSSTRAHLUNG GAMMA TO STACK SECPAR( 0) = 1.D0 SECPAR(10) = H CALL TSTACK ELSE IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT #if __THIN__ DLONG(LHEIGH,11) = DLONG(LHEIGH,11) + SECPAR(1) * WEIGHT #else DLONG(LHEIGH,11) = DLONG(LHEIGH,11) + SECPAR(1) #endif ENDIF #if __AUGERHIST__ THICKLOC = THICK( H ) DO LL = 1, NOBSLV IF ( THICKLOC .GE. THCKOB(LL) .AND. * THICKLOC .LT. THCKOB(LL)+SAMPTH ) THEN C THICKH IS WITHIN 1 G/CM^2 BELOW OBSLEV(LL) C BRING THE ENERGY TO THE HISTO OF LEVEL LL OUTPAR( 0) = 1.D0 DO II = 1, 8 OUTPAR(II) = SECPAR(II) ENDDO OUTPAR( 9) = GEN OUTPAR(10) = ALEVEL OUTPAR(13) = WEIGHT EDEP = SECPAR(1) * WEIGHT CALL AUGERDEPFIL( EDEP,LL,1 ) ELSEIF ( THICKLOC .LT. THCKOB(LL) ) THEN GOTO 112 ENDIF ENDDO 112 CONTINUE #endif ENDIF C REDUCE ENERGY OF MUON 800 CONTINUE EE = EE * V1 SECPAR(1) = EE/PAMA(ITYPE) 900 CONTINUE C WRITE MUON TO STACK SECPAR( 0) = CURPAR(0) SECPAR( 2) = CURPAR(2) SECPAR( 3) = CURPAR(3) SECPAR( 4) = CURPAR(4) SECPAR( 9) = GEN SECPAR(10) = ALEVEL CALL TSTACK RETURN END *-- Author : D. HECK IK FZK KARLSRUHE 15/10/1996 C======================================================================= SUBROUTINE MUCOUL( 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 UPDATE. C ARGUMENTS: C OMEGA = NUMBER OF SCATTERINGS FOR THE STEP C DENS = LOCAL DENSITY (G/CM**3) C----------------------------------------------------------------------- IMPLICIT NONE #define __CONSTAINC__ #define __MUMULTINC__ #define __PAMINC__ #define __PARPARINC__ #define __PARPAEINC__ #define __RANDPAINC__ #define __RUNPARINC__ #include "corsika.h" DOUBLE PRECISION DENS,OMCF,OMEGA,OMEGA0,PHIS,SUMX,SUMY, * THET,THMIN2 INTEGER I,NSCMX,NSCA SAVE DATA OMCF / 1.167D0 /, NSCMX / 50 / C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'MUCOUL: OMEGA=',SNGL(OMEGA), * ' DENS=',SNGL(DENS) C COMPUTE NUMBER OF SCATTERS (POISSON DISTR. WITH MEAN OMEGA0) OMEGA0 = OMCF*OMEGA CALL MPOISS( OMEGA0,NSCA ) IF ( NSCA .LE. 0 ) THEN VSCAT = 0.D0 RETURN ENDIF NSCA = MIN( NSCA, NSCMX ) CALL RMMARD( RD,2*NSCA,1 ) C THMIN2 IS THE SCREENING ANGLE THMIN2 = CHC**2/( OMCF*OMC * (PAMA(ITYPE)*BETA*GAMMA)**2 ) SUMX = 0.D0 SUMY = 0.D0 DO I = 1, NSCA THET = SQRT( THMIN2*((1.D0/RD(I)) - 1.D0) ) PHIS = PI2 * RD(NSCA+I) SUMX = SUMX + THET * COS( PHIS ) SUMY = SUMY + THET * SIN( PHIS ) ENDDO VSCAT = SQRT( SUMX**2 + SUMY**2 ) RETURN END *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE MUDECY C----------------------------------------------------------------------- C MU(ON) DEC(A)Y C C TREATS DECAY OF MUON INTO ELECTRON (INCLUDING POLARISATION EFFECTS) C INCLUDING NEUTRINOS, IF SELECTED. C THIS SUBROUTINE IS CALLED FROM MUTRAC. C----------------------------------------------------------------------- IMPLICIT NONE #define __CONSTAINC__ #define __GENERINC__ #define __LONGIINC__ #define __PAMINC__ #define __PARPARINC__ #define __PARPAEINC__ #define __POLARINC__ #define __RANDPAINC__ #define __RUNPARINC__ #if __AUGERHIST__ #define __OBSPARINC__ #endif #include "corsika.h" DOUBLE PRECISION AUX2,COSDE,COSTH3,COS3CM,COS3C1,COS3C2, * E3CM,GAMMA3,GAMMA4,PHINN,PHI3CM,PHI3C2,PHI31, * P3CM,THICK,XI INTEGER I #if __NEUTRINO__ DOUBLE PRECISION AUXI,AUX3,AUX4,AUX5,BBETA,COSALF,COSBET,COSFI3, * COSFI4,COSFI5,COSPSI,COSTH4,COSTH5,COS4CM, * COS4C1,COS4C2,COS5CM,COS5C1,COS5C2,GAMMA5, * PHI4CM,PHI4C2,PHI41,PHI5CM,PHI5C2,PHI51,PSI, * P3CMSQ,P4CM,P4CMSQ,P5CM,P5CMSQ,SINALF,SINBET, * SINFI3,SINFI4,SINFI5,SINPSI,SIN3C1,SIN4CI,SIN5CI, * XXXX,XXX1,XXX2,XXX4,XXX6,XXX7 INTEGER MCOUNT #endif #if __AUGERHIST__ DOUBLE PRECISION EDEP,THICKLOC INTEGER II,LL #endif #if __SLANT__ INTEGER LBIN EXTERNAL LBIN #endif SAVE EXTERNAL THICK C----------------------------------------------------------------------- #if __THIN__ IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=0,9),WEIGHT 444 FORMAT(' MUDECY: CURPAR=',1P,11E11.3) #else IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=0,9) 444 FORMAT(' MUDECY: CURPAR=',1P,10E11.3) #endif C COPY VERTEX COORDINATES TO SECPAR DO I = 5, 8 SECPAR(I) = CURPAR(I) ENDDO SECPAR( 9) = GEN SECPAR(10) = ALEVEL #if __THIN__ SECPAR(13) = WEIGHT #endif #if __CURVED__ SECPAR(14) = CURPAR(14) SECPAR(15) = CURPAR(15) SECPAR(16) = CURPAR(16) #endif #if __INTTEST__ SECPAR(17) = CURPAR(17) #endif #if __EHISTORY__ DO I = 17, 38 SECPAR(I) = CURPAR(I) ENDDO #endif #if __PARALLEL__ C SET ECTFLG TO OFF SECPAR(39) = CURPAR(39) #endif #if __MULTITHIN__ DO I = 41, 46 SECPAR(I) = CURPAR(I) ENDDO #endif #if __SLANT__ #if __CURVED__ IF ( LLONGI ) LHEIGH = MIN( LBIN( X,Y,HAPP,1 ), NSTEP+1 ) #else IF ( LLONGI ) LHEIGH = MIN( LBIN( X,Y,H,1 ), NSTEP+1 ) #endif #else IF ( LLONGI ) LHEIGH = MIN( INT( THICK(H)*THSTPI+1.D0 ), NSTEP+1 ) #endif C MUON DECAYS INTO ELECTRON AND NEUTRINOS XI = 2*ITYPE - 11 C ELECTRON ENERGY SPECTRUM N(E) * DE = CONST * E**2 * (3/2*E0-E) * DE C IS GAINED BY THE REJECTION/REFLECTION METHOD 6 CONTINUE CALL RMMARD( RD,4,1 ) IF ( RD(1)**2*(3.D0-RD(1)*2.D0) .LT. RD(2) ) RD(1) = 1.D0-RD(1) E3CM = PAMA(2) + RD(1) * ( C(8) - PAMA(2) ) IF ( E3CM .GT. 0.5D0*PAMA(5) ) GOTO 6 P3CM = SQRT( (E3CM-PAMA(2))*(E3CM+PAMA(2)) ) C NOW DETERMINE COS3C1 AND PHI31 BY RANDOM SELECTION C WITH RESPECT TO THE POLARIZATION DIRECTION OF THE MUON IN THE MU CM C GIVEN BY POLART, POLARF COSDE = 2.D0 * RD(4) - 1.D0 AUX2 = ( 1.D0 - 2.D0*RD(1) ) / ( 3.D0 - 2.D0*RD(1) ) IF ( ABS(AUX2) .GT. 1.D-2 ) THEN COS3C1 = XI*(SQRT( 1.D0-(2.D0*COSDE-AUX2)*AUX2 ) - 1.D0) / AUX2 ELSE COS3C1 = (-XI) * COSDE ENDIF PHI31 = RD(3) * PI2 #if __NEUTRINO__ C MU(+) ----> E(+) + NEUTRINO(E) + ANTI-NEUTRINO(MU) C MU(-) ----> E(-) + ANTI-NEUTRINO(E) + NEUTRINO(MU) SIN3C1 = (-XI) * SQRT( (1.D0-COS3C1)*(1.D0+COS3C1) ) COSFI3 = (-XI) * COS( PHI31 ) SINFI3 = (-XI) * SIN( PHI31 ) C PSI IS THE ROTATION OF THE EMISSION PLANE AROUND THE PLANE FORMED BY C THE MUON SPIN AND ELECTRON MOMENTUM (0 < PSI < 2*PI). BETA IS THE C ANGLE BETWEEN ELECTRON AND NU(MU) WITH (0 < BETA < PI). WE TAKE AT C RANDOM: BBETA ( BBETA = 0.5 - 0.5 * COS(BETA)) WITH (0 < BBETA < 1) C AND SIMULTANEOUSLY THE ANGLE PSI = PI2 * RD AND LOOK, WHETHER A 3RD C RANDOM NUMBER IS SMALLER THAN THE DISTRIBUTION, WHICH IS DERIVED C FROM C. JARLSKOG, NUCL. PHYS. 75 (1966) 659, EQ. (37) C XXX4 IS A NORMALIZATION, TO KEEP THE EXPRESSION BELOW 1. XXXX = 2.D0 * E3CM / PAMA(5) XXX1 = 1.D0 - XXXX XXX6 = (-XXX1) * 2.D0 * XI * SIN3C1 XXX2 = XXXX * (2.D0 - XXXX) XXX7 = XXX2 - (2.D0 - XXX2) * XI * COS3C1 AUX3 = 1.D0 - XI * COS3C1 C IN ABOUT 76 % OF THE CASES WE HAVE XXXX < 0.88 IF ( XXXX .LT. 0.88D0 ) THEN XXX4 = XXX1**2 * .45D0 7 CONTINUE CALL RMMARD( RD,3,1 ) PSI = PI2 * RD(2) COSPSI = COS( PSI ) IF ( RD(3)*(1.D0-RD(1)*XXXX)**4 .GT. XXX4*RD(1) * * ( AUX3 - RD(1)*XXX7 * - SQRT( RD(1)-RD(1)**2 )*COSPSI*XXX6 ) ) THEN GOTO 7 ELSE BBETA = RD(1) ENDIF C IN ABOUT 18 % OF THE CASES WE HAVE 0.88 < XXXX < 0.97 ELSEIF ( XXXX .LT. 0.97D0 ) THEN XXX4 = XXX1**3 * 4.D0 8 CONTINUE CALL RMMARD( RD,3,1 ) PSI = PI2 * RD(2) COSPSI = COS( PSI ) IF ( RD(3)*(1.D0-RD(1)*XXXX)**4 .GT. XXX4*RD(1) * * ( AUX3 - RD(1)*XXX7 * - SQRT( RD(1)-RD(1)**2 )*COSPSI*XXX6 ) ) THEN GOTO 8 ELSE BBETA = RD(1) ENDIF C IN ABOUT 6 % OF THE CASES WE HAVE .97 < XXXX ELSE MCOUNT = 0 XXX4 = XXX1**3 * 5.D0 9 CONTINUE CALL RMMARD( RD,3,1 ) MCOUNT = MCOUNT + 1 PSI = PI2 * RD(2) COSPSI = COS( PSI ) BBETA = 1.D0 - 5.D0 * XXX1 * RD(1) IF ( RD(3)*(1.D0-BBETA*XXXX)**4 .GT. XXX4*BBETA * * ( AUX3 - BBETA*XXX7 * - SQRT( BBETA-BBETA**2 )*COSPSI*XXX6 ) ) THEN IF ( MCOUNT .GE. 1000 ) THEN IF ( DEBUG ) WRITE(MDEBUG,*) ' XXXX,COS3C1=', * SNGL(XXXX),SNGL(COS3C1) GOTO 6 ENDIF GOTO 9 ENDIF ENDIF COSBET = 1.D0 - 2.D0 * BBETA C ANGLE BETA IS DEFINED 0 < BETA < PI, THUS POSITIVE SIGN OF SINBET SINBET = SQRT( MAX( 0.D0, (1.D0-COSBET)*(1.D0+COSBET) ) ) SINPSI = SIN( PSI ) C NOW CALCULATE ALL NEEDED PARAMETERS AUXI = PAMA(5) - E3CM P5CM = 0.5D0 *(AUXI**2 - P3CM**2) / (AUXI + COSBET * P3CM) P4CM = PAMA(5) - E3CM - P5CM P3CMSQ = P3CM**2 P4CMSQ = P4CM**2 P5CMSQ = P5CM**2 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C (ANTI)-NEUTRINO(E) COSALF = (P5CMSQ - P3CMSQ - P4CMSQ) / (2.D0 * P3CM * P4CM) COSALF = MAX( -1.D0, MIN( 1.D0, COSALF ) ) C ANGLE ALFA IS DEFINED PI < ALFA < 2*PI, THUS NEGATIVE SIGN OF SINALF SINALF = -SQRT( (1.D0-COSALF)*(1.D0+COSALF) ) COS4C1 = COS3C1 * COSALF - SIN3C1 * SINALF * COSPSI IF ( ABS(COS4C1) .LT. 1.D0 ) THEN SIN4CI = 1.D0 / SQRT( (1.D0-COS4C1)*(1.D0+COS4C1) ) AUX4 = COS3C1 * COSPSI * SINALF + SIN3C1 * COSALF COSFI4 = (COSFI3*AUX4-SINFI3*SINPSI*SINALF)*SIN4CI COSFI4 = MAX( -1.D0, MIN( 1.D0, COSFI4 ) ) PHI41 = ACOS( COSFI4 ) SINFI4 = (SINFI3*AUX4+COSFI3*SINPSI*SINALF)*SIN4CI IF ( SINFI4 .LE. 0.D0 ) PHI41 = PI2 - PHI41 ELSE PHI41 = 0.D0 ENDIF C NOW ADD NU(E) EMISSION ANGLE COS4C1 TO THE POLARISATION DIRECTION C TO GET THE DIRECTION (RELATIVE TO THE CORSIKA COORDINATE SYSTEM) CALL ADDANG( POLART,POLARF, COS4C1,PHI41, COS4C2,PHI4C2 ) C GET THE NU(E) DIRECTION RELATIVE TO THE MUON LAB DIRECTION IF ( CURPAR(3) .NE. 0.D0 .OR. CURPAR(4) .NE. 0.D0 ) THEN PHINN = ATAN2( CURPAR(4), CURPAR(3) ) ELSE PHINN = 0.D0 ENDIF CALL ADDANI( CURPAR(2),PHINN, COS4C2,PHI4C2, * COS4CM,PHI4CM ) C LORENTZ TRANSFORMATION TO THE LAB SYSTEM GAMMA4 = GAMMA * (P4CM + BETA * P4CM * COS4CM) COSTH4 = MIN( 1.D0, (BETA+COS4CM) * P4CM * GAMMA / GAMMA4 ) CALL ADDANG3( CURPAR(2),CURPAR(3),CURPAR(4), COSTH4,PHI4CM, * SECPAR(2),SECPAR(3),SECPAR(4) ) #if __UPWARD__ IF ( SECPAR(2) .GE. -1.D0 ) THEN #else IF ( SECPAR(2) .GT. C(29) ) THEN #endif SECPAR(0) = ITYPE + 61 SECPAR(1) = GAMMA4 CALL TSTACK ELSE IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT #if __THIN__ DLONG(LHEIGH,18) = DLONG(LHEIGH,18) + GAMMA4 * WEIGHT #else DLONG(LHEIGH,18) = DLONG(LHEIGH,18) + GAMMA4 #endif ENDIF ENDIF C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C (ANTI)-NEUTRINO(MU) COS5C1 = COS3C1 * COSBET - SIN3C1 * SINBET * COSPSI IF ( ABS(COS5C1) .LT. 1.D0 ) THEN SIN5CI = 1.D0 / SQRT( (1.D0-COS5C1)*(1.D0+COS5C1) ) AUX5 = COS3C1 * COSPSI * SINBET + SIN3C1 * COSBET COSFI5 = (COSFI3*AUX5-SINFI3*SINPSI*SINBET)*SIN5CI PHI51 = ACOS( MAX( -1.D0, MIN( 1.D0, COSFI5 ) ) ) SINFI5 = (SINFI3*AUX5+COSFI3*SINPSI*SINBET)*SIN5CI IF ( SINFI5 .LE. 0.D0 ) PHI51 = PI2 - PHI51 ELSE PHI51 = 0.D0 ENDIF C NOW ADD NU(MU) EMISSION ANGLE COS5C1 TO THE POLARISATION DIRECTION C TO GET THE DIRECTION (RELATIVE TO THE CORSIKA COORDINATE SYSTEM) CALL ADDANG( POLART,POLARF, COS5C1,PHI51, COS5C2,PHI5C2 ) C GET THE NU(MU) DIRECTION RELATIVE TO THE MUON LAB DIRECTION CALL ADDANI( CURPAR(2),PHINN, COS5C2,PHI5C2, COS5CM,PHI5CM ) C LORENTZ TRANSFORMATION TO THE LAB SYSTEM GAMMA5 = GAMMA * (P5CM + BETA * P5CM * COS5CM) COSTH5 = MIN( 1.D0, (BETA+COS5CM) * P5CM * GAMMA / GAMMA5 ) CALL ADDANG3( CURPAR(2),CURPAR(3),CURPAR(4), COSTH5,PHI5CM, * SECPAR(2),SECPAR(3),SECPAR(4) ) #if __UPWARD__ IF ( SECPAR(2) .GE. -1.D0 ) THEN #else IF ( SECPAR(2) .GT. C(29) ) THEN #endif SECPAR(0) = 74 - ITYPE SECPAR(1) = GAMMA5 CALL TSTACK ELSE IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT #if __THIN__ DLONG(LHEIGH,18) = DLONG(LHEIGH,18) + GAMMA5 * WEIGHT #else DLONG(LHEIGH,18) = DLONG(LHEIGH,18) + GAMMA5 #endif ENDIF ENDIF C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C ELECTRON #endif C NOW ADD ELECTRON EMISSION ANGLE COS3C1 TO THE POLARISATION DIRECTION C TO GET THE DIRECTION (RELATIVE TO THE CORSIKA COORDINATE SYSTEM) CALL ADDANG( POLART,POLARF, COS3C1,PHI31, COS3C2,PHI3C2 ) C GET THE ELECTRON DIRECTION RELATIVE TO THE MUON LAB DIRECTION #if !__NEUTRINO__ IF ( CURPAR(3) .NE. 0.D0 .OR. CURPAR(4) .NE. 0.D0 ) THEN PHINN = ATAN2( CURPAR(4), CURPAR(3) ) ELSE PHINN = 0.D0 ENDIF #endif CALL ADDANI( CURPAR(2),PHINN, COS3C2,PHI3C2, COS3CM,PHI3CM ) C LORENTZ TRANSFORMATION TO THE LAB SYSTEM GAMMA3 = GAMMA * ( E3CM + BETA * P3CM * COS3CM ) / PAMA(2) COSTH3 = MIN( 1.D0, GAMMA * (P3CM * COS3CM + BETA * E3CM) / * (PAMA(2) * SQRT( (GAMMA3-1.D0)*(GAMMA3+1.D0) )) ) CALL ADDANG3( CURPAR(2),CURPAR(3),CURPAR(4), COSTH3,PHI3CM, * SECPAR(2),SECPAR(3),SECPAR(4) ) #if __UPWARD__ IF ( SECPAR(2) .GE. -1.D0 ) THEN #else IF ( SECPAR(2) .GT. C(29) ) THEN #endif SECPAR(0) = ITYPE - 3 SECPAR(1) = GAMMA3 C INCREASE GENERATION COUNTER BY 100 TO MARK EM PARTICLES FROM MU CHANNEL SECPAR(9) = GEN + 100.D0 CALL TSTACK ELSE IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT IF ( ITYPE .EQ. 5 ) THEN #if __THIN__ DLONG(LHEIGH,13) = DLONG(LHEIGH,13) * + (GAMMA3+1.D0)*PAMA(2)*WEIGHT ELSE DLONG(LHEIGH,13) = DLONG(LHEIGH,13) * + (GAMMA3-1.D0)*PAMA(2)*WEIGHT #else DLONG(LHEIGH,13) = DLONG(LHEIGH,13) + (GAMMA3+1.D0)*PAMA(2) ELSE DLONG(LHEIGH,13) = DLONG(LHEIGH,13) + (GAMMA3-1.D0)*PAMA(2) #endif ENDIF ENDIF #if __AUGERHIST__ THICKLOC = THICK( H ) DO LL = 1, NOBSLV IF ( THICKLOC .GE. THCKOB(LL) .AND. * THICKLOC .LT. THCKOB(LL)+SAMPTH ) THEN C THICKH IS WITHIN 1 G/CM^2 BELOW OBSLEV(LL) C BRING THE ENERGY BELOW ANGULAR CUT TO THE HISTO OF LEVEL LL OUTPAR( 0) = ITYPE - 3 OUTPAR( 1) = GAMMA3 DO II = 2, 8 OUTPAR(II) = SECPAR(II) ENDDO OUTPAR( 9) = GEN OUTPAR(10) = ALEVEL OUTPAR(13) = WEIGHT EDEP = OUTPAR(1) * PAMA(5) * WEIGHT C WE HAVE ANGULAR CUT CALL AUGERDEPFIL( EDEP,LL,1 ) ELSEIF ( THICKLOC .LT. THCKOB(LL) ) THEN GOTO 111 ENDIF ENDDO 111 CONTINUE #endif ENDIF POLART = 0.D0 POLARF = 0.D0 #if !__NEUTRINO__ IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT GAMMA4 = GAMMA * PAMA(5) - GAMMA3 * PAMA(2) #if __THIN__ DLONG(LHEIGH,8) = DLONG(LHEIGH,8) + GAMMA4 * WEIGHT #else DLONG(LHEIGH,8) = DLONG(LHEIGH,8) + GAMMA4 #endif ENDIF #endif RETURN END *-- Author : D. HECK IK FZK KARLSRUHE 22/07/2014 C======================================================================= SUBROUTINE MUNUCL C----------------------------------------------------------------------- C MU(ON) NUCL(EAR INTERACTION) (ALSO USED FOR TAU LEPTONS) C C TREATES MUON/TAU 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, SOV.J.NUCL.PHYS. 33 (1981) 635 C THIS SUBROUTINE IS CALLED FROM MUTRAC. C----------------------------------------------------------------------- IMPLICIT NONE #define __AIRINC__ #define __BUFFSINC__ #define __CONSTAINC__ #define __EGSDEBINC__ #define __ELABCTINC__ #define __GENERINC__ #define __LONGIINC__ #define __MULTINC__ #if __MULTITHIN__ #define __MULTHININC__ #endif #define __MUPARTINC__ #define __NPARTIINC__ #define __OBSPARINC__ #define __PAMINC__ #define __PARPARINC__ #define __PIONINC__ #define __POLARINC__ #define __RANDPAINC__ #define __REJECTINC__ #define __RESTINC__ #define __RUNPARINC__ #define __SIGMUINC__ #define __STACKEINC__ #define __THNVARINC__ #if __INTTEST__ #define __TSTINTINC__ #endif #include "corsika.h" 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) PARAMETER (ELE1 = 0.0808D0) PARAMETER (ELE2 = -0.4525D0) DOUBLE PRECISION AMUPR2(0:46) DOUBLE PRECISION ARGO,AUXIL1,BPH,COEF,COEF1,COSTH3,CPH, * DPH,EKIN,EPH,E1,FACTO,FPH,GG,GMAX,GMIN,HHH,PHI3, * SS,SIGN,SIGNEW,SIGOLD,SNI,SNIMAX,SNIMIN, * SNIMIN1,SNIMIN2,TTT,VPH,VPH1,VPH2,ZZZ INTEGER I,KCOUNT #if __AUGERHIST__ DOUBLE PRECISION EDEP,THICKLOC INTEGER II,LL #endif #if __SLANT__ #if __CURVED__ DOUBLE PRECISION PHI1,RRR #endif DOUBLE PRECISION AUXIL,THCKSI,XXX,YYY,ZZ1 INTEGER LBIN EXTERNAL LBIN,THCKSI #endif SAVE DOUBLE PRECISION CNUSGM,THICK EXTERNAL CNUSGM,THICK C----------------------------------------------------------------------- #if __THIN__ IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=0,9),CURPAR(13) 444 FORMAT(' MUNUCL: CURPAR=',1P,11E11.3) #else IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=0,9) 444 FORMAT(' MUNUCL: CURPAR=',1P,10E11.3) #endif C COPY VERTEX COORDINATES TO SECPAR AND AMUPR2 DO I = 0, 4 AMUPR2(I) = CURPAR(I) ENDDO DO I = 5, 8 SECPAR(I) = CURPAR(I) AMUPR2(I) = CURPAR(I) ENDDO SECPAR( 9) = GEN AMUPR2( 9) = GEN #if __THIN__ SECPAR(13) = CURPAR(13) AMUPR2(13) = CURPAR(13) #endif #if __CURVED__ SECPAR(14) = CURPAR(14) AMUPR2(14) = CURPAR(14) SECPAR(15) = CURPAR(15) AMUPR2(15) = CURPAR(15) SECPAR(16) = CURPAR(16) AMUPR2(16) = CURPAR(16) #endif #if __INTTEST__ SECPAR(17) = CURPAR(17) AMUPR2(17) = CURPAR(17) #endif #if __EHISTORY__ DO I = 17, 38 SECPAR(I) = CURPAR(I) AMUPR2(I) = CURPAR(I) ENDDO #endif #if __PARALLEL__ C SET ECTFLG TO OFF SECPAR(39) = CURPAR(39) AMUPR2(39) = CURPAR(39) #endif #if __MULTITHIN__ DO I = 41, 46 SECPAR(I) = CURPAR(I) AMUPR2(I) = CURPAR(I) ENDDO #endif #if __SLANT__ #if __CURVED__ IF ( LLONGI ) LHEIGH = MIN( LBIN(CURPAR(7),CURPAR(8),CURPAR(14), * 1), NSTEP+1 ) #else IF ( LLONGI ) LHEIGH = MIN( LBIN(CURPAR(7),CURPAR(8),CURPAR(5),1), * NSTEP+1 ) #endif #else IF ( LLONGI ) LHEIGH = INT( THICK( CURPAR(5) )*THSTPI + 1.D0 ) #endif C SET MATERIAL CONSTANTS ACCORDING TO TARGET INDEX LIT (1=N, 2=O, 3=AR) C WHICH HAS BEEN SET IN BOX2, AND RESTORE OLD CROSS-SECTIONS IF ( LIT .EQ. 1 ) THEN AATOM = 14.D0 SIGOLD = FRANTN / COMPOS(1) ELSEIF ( LIT .EQ. 2 ) THEN AATOM = 16.D0 SIGOLD = (FRNTNO - FRANTN) / COMPOS(2) ELSEIF ( LIT .EQ. 3 ) THEN AATOM = 40.D0 SIGOLD = (SIGNUC - FRNTNO) / COMPOS(3) ELSE WRITE(MONIOU,*) 'MUNUCL: WRONG TARGET LIT=',LIT,' STOP' STOP ENDIF C TOTAL AND KINETIC ENERGY OF MUON/TAU EE = PAMA(ITYPE) * CURPAR(1) EKIN = EE - PAMA(ITYPE) IF ( EKIN .LE. BCUT ) RETURN C CHECK THE REDUCED CROSS-SECTIONS AND SKIP INTERACTION EVENTUALLY SIGNEW = CNUSGM( EE,LIT,MT ) CALL RMMARD( RD,1,1 ) C SKIP INTERACTION IF RANDOM NUMBER GREATER THAN CROSS-SECTION RATIO IF ( RD(1)*SIGOLD .GT. SIGNEW ) GOTO 999 C SAMPLE THE ENERGY FRACTION SNI OF VIRTUAL GAMMA C LIMITS FOR VIRTUAL GAMMA''S ENERGY ARE SNIMIN AND SNIMAX SNIMIN1 = ( PAMA(8) + 0.5D0*PAMA(8)**2/PAMA(14) )/EE SNIMIN2 = ( ELCUT(1) + PAMA(7) )/EE SNIMIN = MAX( SNIMIN1, SNIMIN2, 1.D-15 ) SNIMAX = 1.D0 - ( PAMA(14) + PAMA(ITYPE)**2/PAMA(14) )*0.5D0/EE IF ( SNIMIN .GE. SNIMAX ) GOTO 999 C USE FOR SAMPLING A FUNCTION WHICH IS SOMEWHAT LARGER, BUT C CAN BE INTEGRATED AND THE INTEGRAL CAN BE INVERTED. C AFTERWARDS CORRECT SAMPLING IS DONE BY REJECTION TECHNIQUE 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 KCOUNT = 0 1 CONTINUE KCOUNT = KCOUNT + 1 C SKIP INTERACTION IF TOO MANY ATTEMPTS IF ( KCOUNT .GT. 1000 ) GOTO 999 CALL RMMARD( RD,2,1 ) 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 = PAMA(ITYPE)**2 * SNI**2 / (1.D0 - SNI) C SS IS ENERGY**2 IN CM SYSTEM, EE IS TOTAL ENERGY OF INCOMING MUON SS = 2.D0 * PAMA(14) * 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 * PAMA(ITYPE)**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 * PAMA(ITYPE)**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 NOW TREAT THE VIRTUAL GAMMA AS REAL GAMMA ITYPE = 1 CURPAR(0) = 1.D0 CURPAR(1) = SNI * EE C COSTH3 IS SET TO 1 (FORWARD MOVEMENT WITHOUT TRANSVERSE MOMENTUM) CALL ADDANG3( CURPAR(2),CURPAR(3),CURPAR(4), COSTH3,PHI3+PI, * CURPAR(2),CURPAR(3),CURPAR(4) ) #if __THIN__ IF ( DEBUG ) WRITE(MDEBUG,445) (CURPAR(I),I=0,9),CURPAR(13) 445 FORMAT(' MUNUCL: PIGEN =',1P,11E11.3) #else IF ( DEBUG ) WRITE(MDEBUG,445) (CURPAR(I),I=0,9) 445 FORMAT(' MUNUCL: PIGEN =',1P,10E11.3) #endif C CHECK: ENERGY OF VIRTUAL GAMMA IS SUFFICIENT FOR PION PRODUCTION ? IF ( CURPAR(1) .LE. MAX( ELCUT(4), PITHR*1.D-3 ) ) THEN IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT #if __THIN__ DLONG(LHEIGH,1) = DLONG(LHEIGH,1) + CURPAR(1) * CURPAR(13) #else DLONG(LHEIGH,1) = DLONG(LHEIGH,1) + CURPAR(1) #endif ENDIF #if __AUGERHIST__ THICKLOC = THICK( CURPAR(5) ) DO LL = 1, NOBSLV IF ( THICKLOC .GE. THCKOB(LL) .AND. * THICKLOC .LT. THCKOB(LL)+SAMPTH ) THEN C THICKH IS WITHIN 1 G/CM^2 BELOW OBSLEV(LL) C BRING THE ENERGY BELOW CUT TO THE HISTO OF LEVEL LL OUTPAR( 0) = 1.D0 DO II = 1, 8 OUTPAR(II) = CURPAR(II) ENDDO OUTPAR( 9) = GEN OUTPAR(10) = CURPAR(5) OUTPAR(13) = CURPAR(13) EDEP = CURPAR(1) * CURPAR(13) CALL AUGERDEPFIL( EDEP,LL,0 ) ELSEIF ( THICKLOC .LT. THCKOB(LL) ) THEN GOTO 113 ENDIF ENDDO 113 CONTINUE #endif ELSE CURPAR(12) = SQRT( (PAMA(14) + CURPAR(1)*2.D0)*PAMA(14) ) CURPAR(11) = (CURPAR(1) + PAMA(14))/CURPAR(12) #if __INTTEST__ GACM = CURPAR(11) BECM = SQRT( (GACM-1.D0)*(GACM+1.D0) ) / GACM ECMI = CURPAR(12) IF ( DEBUG ) WRITE(MDEBUG,*) 'MUNUCL: GACM,BECM,ECM = ', * SNGL(GACM),BECM,SNGL(ECMI) #endif C STORE VIRTUAL GAMMA INTO EGS STACK AND CALL SUBR. PIGEN C FILL IN STARTING COORDINATES NP = 1 TIM(1) = CURPAR(6) X(1) = CURPAR(7) Y(1) =-CURPAR(8) C STARTS IN HEIGHT 'Z' DOWNWARDS Z(1) =-CURPAR(5) C START DIRECTION COSINES U(1) = CURPAR(3) V(1) =-CURPAR(4) W(1) = CURPAR(2) #if __THIN__ WT(1) = CURPAR(13) #endif #if __CURVED__ ZAP(1) =-CURPAR(14) WAP(1) = CURPAR(15) WA(1) = CURPAR(16) #endif #if __MULTITHIN__ DO I = 1, NMTHIN WTM(I,1) = CURPAR(40+I) ENDDO #endif IF ( LLONGI ) THEN #if __SLANT__ || __COASTUSERLIB__ #if __CURVED__ IF ( WA(1) .NE. 1.D0 ) THEN C WE ARE AWAY FROM DETECOR C CALCULATE AZIMUTH ANGLE OF PARTICLE SEEN FROM DETECTOR IF ( Y(1) .NE. 0.D0 .OR. X(1) .NE. 0.D0 ) THEN PHI1 = ATAN2( Y(1), X(1) ) ELSE PHI1 = 0.D0 ENDIF C HORIZONTAL DISTANCE OF PARTICLE TO DETECTOR RRR = SQRT( (1.D0-WA(1))*(1.D0+WA(1)) ) * * ( ZAP(1) + C(1) ) / WA(1) XXX = RRR * COS( PHI1 ) YYY = RRR * SIN( PHI1 ) ZZ1 = ZAP(1) ELSE C WE ARE IN THE DETECTOR SYSTEM AND NEED NO COORDINATE CALCULATION XXX = X(1) YYY = Y(1) ZZ1 = Z(1) ENDIF C STORE COORDINATES IN THE DETECTOR SYSTEM XXXX(1) = XXX YYYY(1) = YYY #elif __SLANT__ XXX = X(1) YYY = Y(1) ZZ1 = Z(1) #endif #endif #if __SLANT__ AUXIL = XXX*STHCPH -YYY*STHSPH +ZZ1*CTH + RLOFF TSLAN(1) = THCKSI( AUXIL ) LPCTE(1) = MIN( INT( TSLAN(1)*THSTPI + 1.D0 ), NSTEP+1 ) #else LPCTE(1) = MIN( NSTEP, * INT( THICK( CURPAR(5) )*THSTPI + 1.D0 ) ) #endif ENDIF IGEN(1) = GEN C CONVERSION GEV --> MEV E(1) = CURPAR(1) * 1000.D0 IQ(1) = NINT( CURPAR(0) ) C TREAT THE PHOTONUCLEAR INTERACTION WITH EGS BY PIGEN CALL PIGEN( .FALSE. ) C ALL SECONDARIES ARE WRITTEN TO STACK AND TSTEND WAS CALLED IN PIGEN C RESET STACK POINTER INT_ICOUNT = 0 ENDIF C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C COPY VERTEX COORDINATES FROM AMUPR2 TO SECPAR C AS IN PIGEN SECPAR AND CURPAR HAS BEEN USED DO I = 5, 8 SECPAR(I) = AMUPR2(I) ENDDO SECPAR( 9) = AMUPR2( 9) #if __THIN__ SECPAR(13) = AMUPR2(13) #endif #if __CURVED__ SECPAR(14) = AMUPR2(14) SECPAR(15) = AMUPR2(15) SECPAR(16) = AMUPR2(16) #endif #if __INTTEST__ SECPAR(17) = AMUPR2(17) #endif #if __EHISTORY__ DO I = 17, 38 SECPAR(I) = AMUPR2(I) ENDDO #endif #if __PARALLEL__ C SET ECTFLG TO OFF SECPAR(39) = AMUPR2(39) #endif #if __MULTITHIN__ DO I = 41, 46 SECPAR(I) = AMUPR2(I) ENDDO #endif C ENERGY OF RESIDUAL MUON C SNI FINALLY IS ENERGY FRACTION OF VIRTUAL GAMMA E1 = EE * (1.D0 - SNI) SECPAR(0) = AMUPR2(0) ITYPE = SECPAR(0) IF ( DEBUG ) WRITE(MDEBUG,*) 'MUNUCL: ENERGY OF MUON=',E1 SECPAR(1) = E1/PAMA(ITYPE) CALL RMMARD( RD,1,1 ) PHI3 = RD(1) * PI C COSTH3 IS SET TO 1 (FORWARD MOVEMENT WITHOUT TRANSVERSE MOMENTUM) COSTH3 = 1.D0 CALL ADDANG3( AMUPR2(2),AMUPR2(3),AMUPR2(4), COSTH3,PHI3, * SECPAR(2),SECPAR(3),SECPAR(4) ) SECPAR(10) = AMUPR2(5) IF ( E1 - PAMA(ITYPE) .LE. ELCUT(2) ) THEN C MUON DID NOT SURVIVE NUCLEAR INTERACTION (ENERGY CUT) #if __MUPROD__ C ADD. MUON INFORMATION (MUON INFORMATION AT PRODUCTION POINT) C FOR DECAYED MUONS CALL OUTPT3(2) #endif #if __THIN__ NMUONE = NMUONE + SECPAR(13) #else NMUONE = NMUONE + 1.D0 #endif IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT #if __THIN__ DLONG(LHEIGH,5) = DLONG(LHEIGH,5) + E1 * CURPAR(13) #else DLONG(LHEIGH,5) = DLONG(LHEIGH,5) + E1 #endif ENDIF #if __AUGERHIST__ THICKLOC = THICK( CURPAR(5) ) DO LL = 1, NOBSLV IF ( THICKH .GE. THCKOB(LL) .AND. * THICKH .LT. THCKOB(LL)+SAMPTH ) THEN C THICKH IS WITHIN 1 G/CM^2 BELOW OBSLEV(LL) C BRING THE ENERGY BELOW CUT TO THE HISTO OF LEVEL LL DO II = 0, 10 OUTPAR(II) = SECPAR(II) ENDDO OUTPAR(13) = SECPAR(13) EDEP = SECPAR(1) * PAMA(ITYPE) * SECPAR(13) IF ( DEBUG ) WRITE(MDEBUG,*) 'MUNUCL: THICKH=',THICKH CALL AUGERDEPFIL( EDEP,LL,0 ) ELSEIF ( THICKH .LT. THCKOB(LL) ) THEN GOTO 111 ENDIF ENDDO 111 CONTINUE #endif ELSE #if __UPWARD__ IF ( SECPAR(2) .GE. -1.D0 ) THEN #else IF ( SECPAR(2) .GT. C(29) ) THEN #endif C WRITE RESIDUAL MUON/TAU TO STACK CALL TSTACK CALL TSTEND ELSE C MUON DID NOT SURVIVE NUCLEAR INTERACTION (ANGULAR CUT) #if __MUPROD__ C ADD. MUON INFORMATION (MUON INFORMATION AT PRODUCTION POINT) C FOR DECAYED MUONS CALL OUTPT3(2) #endif #if __THIN__ NMUONE = NMUONE + SECPAR(13) #else NMUONE = NMUONE + 1.D0 #endif IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT #if __THIN__ DLONG(LHEIGH,15) = DLONG(LHEIGH,15) + E1 * SECPAR(13) #else DLONG(LHEIGH,15) = DLONG(LHEIGH,15) + E1 #endif ENDIF #if __AUGERHIST__ THICKLOC = THICK( SECPAR(5) ) DO LL = 1, NOBSLV IF ( THICKLOC .GE. THCKOB(LL) .AND. * THICKLOC .LT. THCKOB(LL)+SAMPTH ) THEN C THICKH IS WITHIN 1 G/CM^2 BELOW OBSLEV(LL) C BRING THE ENERGY TO THE HISTO OF LEVEL LL OUTPAR( 0) = 1.D0 DO II = 1, 10 OUTPAR(II) = SECPAR(II) ENDDO OUTPAR(13) = SECPAR(13) EDEP = SECPAR(1) * SECPAR(13) CALL AUGERDEPFIL( EDEP,LL,1 ) ELSEIF ( THICKLOC .LT. THCKOB(LL) ) THEN GOTO 112 ENDIF ENDDO 112 CONTINUE #endif ENDIF ENDIF RETURN C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C NO INTERACTION OF THE MUON 999 SECPAR(0) = CURPAR(0) SECPAR(1) = CURPAR(1) SECPAR(2) = CURPAR(2) SECPAR(3) = CURPAR(3) SECPAR(4) = CURPAR(4) C WRITE MUON UNCHANGED TO STACK CALL TSTACK CALL TSTEND RETURN END *-- Author : D. HECK IK FZK KARLSRUHE 12/05/2003 C======================================================================= SUBROUTINE MUPINI C----------------------------------------------------------------------- C MU(ON/TAU) P(ARAMETER) INI(TIALIZATION) C C INTIALIZES MUON/TAU PARAMETERS FOR MULTIPLE SCATTERING. C ESTABLISHES TABLES FOR CROSS-SECTIONS OF BEMSSTRAHLUNG, C PAIR PRODUCTION AND NUCLEAR INTERACTION. C ESTABLISHES TABLES FOR MUON/TAU ENERGY LOSS FOR BEMSSTRAHLUNG, C PAIR PRODUCTION, AND NUCLEAR INTERACTION. C THIS SUBROUTINE IS CALLED FROM INPRM. C----------------------------------------------------------------------- IMPLICIT NONE #define __AIRINC__ #define __CONSTAINC__ #define __ELABCTINC__ #define __MUMULTINC__ #define __MUPARTINC__ #define __PAMINC__ #define __PARPARINC__ #define __PIONINC__ #define __PRIMSPINC__ #define __RUNPARINC__ #define __SIGMUINC__ #include "corsika.h" DOUBLE PRECISION AAIR(3),YE,ZAIR(3) DOUBLE PRECISION ARGLOG,BREMS,CDNS,CDNS1,DEDXBR,DEDXNI,DEDXPR, * ELOSS,GAMSQ,GAM0,GMSQM1,NUCLE,PAIR INTEGER J,JE,JJMAT DOUBLE PRECISION DEDXMUB(141,3,2),DEDXMNI(141,3,2), * DEDXMUP(141,3,2),DEDXMB(141,2),DEDXMN(141,2), * DEDXMP(141,2) SAVE DOUBLE PRECISION CBRSGM,CNUSGM,CPRSGM,DBRELM,DBRSGM, * DNIELM,DNUSGM,DPRELM,DPRSGM,RHOF EXTERNAL CBRSGM,CNUSGM,CPRSGM, * DBRELM,DBRSGM,DNIELM,DNUSGM,DPRELM,DPRSGM,RHOF DATA AAIR / 14.D0, 16.D0, 40.D0 / DATA ZAIR / 7.D0, 8.D0, 18.D0 / C CONSTANT IN DENSITY EFFECT FOR IONIZATION LOSS IN AIR DATA CDNS1 / 0.020762D0 / C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'MUPINI: INITIALIZE MUON/TAU DATA' C SET BCUT BELOW THE PI THERSHOLD BCUT = MIN( ELCUT(3), PITHR*1.D-3 ) #if __INTTEST__ BCUT = .001D0 #endif IF ( DEBUG ) WRITE(MDEBUG,*) 'MUPINI: BCUT =',BCUT,' GEV' C SET CONSTANTS FOR MUON BREMSSTRAHLUNG CMUON(7) = 7.D0**OB3 CMUON(8) = 8.D0**OB3 CMUON(9) = 18.D0**OB3 CMUON(1) = LOG( 189.D0 * PAMA(5) / (CMUON(7)*PAMA(2)) ) * + LOG( TB3/CMUON(7) ) CMUON(2) = LOG( 189.D0 * PAMA(5) / (CMUON(8)*PAMA(2)) ) * + LOG( TB3/CMUON(8) ) CMUON(3) = LOG( 189.D0 * PAMA(5) / (CMUON(9)*PAMA(2)) ) * + LOG( TB3/CMUON(9) ) SE = SQRT( EXP( 1.D0 ) ) CMUON(4) = 189.D0 * SE*PAMA(5)**2/(2.D0*PAMA(2)*CMUON(7)) CMUON(5) = 189.D0 * SE*PAMA(5)**2/(2.D0*PAMA(2)*CMUON(8)) CMUON(6) = 189.D0 * SE*PAMA(5)**2/(2.D0*PAMA(2)*CMUON(9)) CMUON(10) = 0.75D0 * PAMA(5) * SE CMUON(7) = CMUON(7) * CMUON(10) CMUON(8) = CMUON(8) * CMUON(10) CMUON(9) = CMUON(9) * CMUON(10) CMUON(11) = LOG( BCUT/PAMA(5) ) C MASS RATIO ELETRON BY MUON EBYMU = PAMA(2)/PAMA(5) C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C CALCULATE CROSS SECTION TABLES FOR MUONS MT = 1 C MAXIMUM PRIMARY ENERGY DETERMINES MAXIMUM OF TABLE VALUES NEEDED JE = 10.D0 * LOG10(ULIMIT) + 23.D0 JE = MIN( JE, 141 ) C MATERIAL LOOP (JJMAT=1: 14N; JJMAT=2: 16O; JJMAT=3: 40AR) DO JJMAT = 1, 3 ZATOM = ZAIR(JJMAT) AATOM = AAIR(JJMAT) CONSTKINE = CMUON(JJMAT+6) IF ( DEBUG ) WRITE(MDEBUG,101) JJMAT 101 FORMAT(' MUPINI: MUON CROSS SECTIONS (MBARN) FOR MATERIAL ', * 'INDEX = ',I3,/,' BIN',1X, * 'ENERGY (GEV)',3X,'SIGBREMS',6X,'SIGPAIR',7X,'SIGNUCL') 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) BREMSTAB(J,JJMAT,1) = DBRSGM(JJMAT) NUCTAB(J,JJMAT,1) = DNUSGM(JJMAT) PAIRTAB(J,JJMAT,1) = DPRSGM(JJMAT) IF ( DEBUG ) WRITE(MDEBUG,102) J,EE,BREMSTAB(J,JJMAT,1), * PAIRTAB(J,JJMAT,1),NUCTAB(J,JJMAT,1) 102 FORMAT(' ',I3,1P,1X,E12.5,3(1X,E13.6)) BREMSTAB(J,JJMAT,1) = LOG(MAX( BREMSTAB(J,JJMAT,1), 1.D-30 ) ) NUCTAB(J,JJMAT,1) = LOG(MAX( NUCTAB(J,JJMAT,1), 1.D-30 ) ) PAIRTAB(J,JJMAT,1) = LOG(MAX( PAIRTAB(J,JJMAT,1), 1.D-30 ) ) ENDDO ENDDO IF ( DEBUG ) THEN WRITE(MDEBUG,103) 103 FORMAT(' MUPINI: 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 = COMPOS(1) * CBRSGM( EE,1,1 ) BREMS = BREMS + COMPOS(2) * CBRSGM( EE,2,1 ) BREMS = BREMS + COMPOS(3) * CBRSGM( EE,3,1 ) PAIR = COMPOS(1) * CPRSGM( EE,1,1 ) PAIR = PAIR + COMPOS(2) * CPRSGM( EE,2,1 ) PAIR = PAIR + COMPOS(3) * CPRSGM( EE,3,1 ) NUCLE = COMPOS(1) * CNUSGM( EE,1,1 ) NUCLE = NUCLE + COMPOS(2) * CNUSGM( EE,2,1 ) NUCLE = NUCLE + COMPOS(3) * CNUSGM( EE,3,1 ) WRITE(MDEBUG,104) J,EE,BREMS,PAIR,NUCLE 104 FORMAT(' ',I3,1P,1X,E12.5,5(1X,E13.6)) ENDDO ENDIF C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C CALCULATE ENERGY LOSS TABLES. AS WE REGARD CUT VALUES ONLY BELOW 21 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 = ZAIR(JJMAT) AATOM = AAIR(JJMAT) CONSTKINE = CMUON(JJMAT+6) C ENERGY LOOP (10 MEV AT J=1; 1 GEV AT J=21; 1000 EEV AT J=141) IF ( DEBUG ) WRITE(MDEBUG,105) JJMAT 105 FORMAT(' MUPINI: MUON ENERGY LOSS (GEV G**-1 CM**2) FOR ', * 'MATERIAL INDEX = ',I3,/,' BIN',1X, * 'ENERGY (GEV)',3X,'DEDXBREM',6X,'DEDXPAIR',6X, * 'NUCLEAR',8X,'SUM') 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 DEDXBR = DBRELM(JJMAT) DEDXPR = DPRELM(JJMAT) DEDXNI = DNIELM(JJMAT) DEDXMU(J,JJMAT,1) = DEDXBR + DEDXPR + DEDXNI DEDXMUB(J,JJMAT,1) = DEDXBR DEDXMUP(J,JJMAT,1) = DEDXPR DEDXMNI(J,JJMAT,1) = DEDXNI IF ( DEBUG ) WRITE(MDEBUG,106) * J,EE,DEDXBR,DEDXPR,DEDXNI,DEDXMU(J,JJMAT,1) 106 FORMAT(' ',I3,1P,1X,E12.5,4(1X,E13.6)) ENDDO ENDDO C CALCULATE ENERGY LOSS IN AIR IF ( DEBUG ) WRITE(MDEBUG,107) 107 FORMAT(' MUPINI: MUON ENERGY LOSS (GEV G**-1 CM**2) FOR AIR',/, * ' IONIZATION ENERGY LOSS WITH DENSITY EFFECT AT SEA LEVEL',/, * ' BIN',1X,'ENERGY (GEV)',5X,'ELOSS',8X,'DEDXMB',8X, * 'DEDXMP',8X,'DEDXMN',8X,' SUM') C DENSITY EFFECT PARAMETERIZATION (AT SEA LEVEL) CDNS = CDNS1 * RHOF(0.D0) 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,1) = COMPOS(1) * DEDXMU(J,1,1) * +COMPOS(2) * DEDXMU(J,2,1) * +COMPOS(3) * DEDXMU(J,3,1) DEDXMB(J,1) = COMPOS(1) * DEDXMUB(J,1,1) * +COMPOS(2) * DEDXMUB(J,2,1) * +COMPOS(3) * DEDXMUB(J,3,1) DEDXMP(J,1) = COMPOS(1) * DEDXMUP(J,1,1) * +COMPOS(2) * DEDXMUP(J,2,1) * +COMPOS(3) * DEDXMUP(J,3,1) DEDXMN(J,1) = COMPOS(1) * DEDXMNI(J,1,1) * +COMPOS(2) * DEDXMNI(J,2,1) * +COMPOS(3) * DEDXMNI(J,3,1) C ENERGY LOSS BY IONIZATION GAM0 = MAX( 1.0001D0, EE / PAMA(5) ) GAMSQ = GAM0**2 GMSQM1 = GAMSQ - 1.D0 ARGLOG = GMSQM1**2/( (GAM0*C(16)+1.D0)*(1.D0+GMSQM1*CDNS) ) ELOSS = C(22) * ( GAMSQ * (0.5D0*LOG( ARGLOG )+C(23)) * / GMSQM1 - 1.D0 ) IF ( DEBUG ) WRITE(MDEBUG,108) * J,EE,ELOSS,DEDXMB(J,1),DEDXMP(J,1),DEDXMN(J,1), * ELOSS+DEDXM(J,1) 108 FORMAT(' ',I3,1P,1X,E12.5,5(1X,E13.6)) ENDDO #if __CHARM__ || __TAULEP__ C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C NOW ALL CALCULATIONS FOR TAU LEPTONS MT = 2 C SET CONSTANTS FOR TAU BREMSSTRAHLUNG CTAU(7) = 7.D0**OB3 CTAU(8) = 8.D0**OB3 CTAU(9) = 18.D0**OB3 CTAU(1) = LOG( 189.D0 * PAMA(131) / (CTAU(7)*PAMA(2)) ) * + LOG( TB3/CTAU(7) ) CTAU(2) = LOG( 189.D0 * PAMA(131) / (CTAU(8)*PAMA(2)) ) * + LOG( TB3/CTAU(8) ) CTAU(3) = LOG( 189.D0 * PAMA(131) / (CTAU(9)*PAMA(2)) ) * + LOG( TB3/CTAU(9) ) CTAU(4) = 189.D0 * SE*PAMA(131)**2/(2.D0*PAMA(2)*CTAU(7)) CTAU(5) = 189.D0 * SE*PAMA(131)**2/(2.D0*PAMA(2)*CTAU(8)) CTAU(6) = 189.D0 * SE*PAMA(131)**2/(2.D0*PAMA(2)*CTAU(9)) CTAU(10) = 0.75D0 * PAMA(131) * SE CTAU(7) = CTAU(7) * CTAU(10) CTAU(8) = CTAU(8) * CTAU(10) CTAU(9) = CTAU(9) * CTAU(10) CTAU(11) = LOG( BCUT/PAMA(131) ) C MASS RATIO ELETRON BY MUON EBYTAU = PAMA(2)/PAMA(131) C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C CALCULATE CROSS SECTION TABLES FOR TAU LEPTONS C MATERIAL LOOP (JJMAT=1: 14N; JJMAT=2: 16O; JJMAT=3: 40AR) DO JJMAT = 1, 3 ZATOM = ZAIR(JJMAT) AATOM = AAIR(JJMAT) CONSTKINE = CTAU(JJMAT+6) IF ( DEBUG ) WRITE(MDEBUG,201) JJMAT 201 FORMAT(' MUPINI: TAU CROSS SECTIONS (MBARN) FOR MATERIAL ', * 'INDEX = ',I3,/,' BIN',1X, * 'ENERGY (GEV)',3X,'SIGBREMS',6X,'SIGPAIR',7X,'SIGNUCL') 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) BREMSTAB(J,JJMAT,2) = DBRSGM(JJMAT) NUCTAB(J,JJMAT,2) = DNUSGM(JJMAT) PAIRTAB(J,JJMAT,2) = DPRSGM(JJMAT) IF ( DEBUG ) WRITE(MDEBUG,202) J,EE,BREMSTAB(J,JJMAT,2), * PAIRTAB(J,JJMAT,2),NUCTAB(J,JJMAT,2) 202 FORMAT(' ',I3,1P,1X,E12.5,3(1X,E13.6)) BREMSTAB(J,JJMAT,2) = LOG(MAX( BREMSTAB(J,JJMAT,2), 1.D-30 ) ) NUCTAB(J,JJMAT,2) = LOG(MAX( NUCTAB(J,JJMAT,2), 1.D-30 ) ) PAIRTAB(J,JJMAT,2) = LOG(MAX( PAIRTAB(J,JJMAT,2), 1.D-30 ) ) ENDDO ENDDO IF ( DEBUG ) THEN WRITE(MDEBUG,203) 203 FORMAT(' MUPINI: TAU 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 = COMPOS(1) * CBRSGM( EE,1,2 ) BREMS = BREMS + COMPOS(2) * CBRSGM( EE,2,2 ) BREMS = BREMS + COMPOS(3) * CBRSGM( EE,3,2 ) PAIR = COMPOS(1) * CPRSGM( EE,1,2 ) PAIR = PAIR + COMPOS(2) * CPRSGM( EE,2,2 ) PAIR = PAIR + COMPOS(3) * CPRSGM( EE,3,2 ) NUCLE = COMPOS(1) * CNUSGM( EE,1,2 ) NUCLE = NUCLE + COMPOS(2) * CNUSGM( EE,2,2 ) NUCLE = NUCLE + COMPOS(3) * CNUSGM( EE,3,2 ) WRITE(MDEBUG,204) J,EE,BREMS,PAIR,NUCLE 204 FORMAT(' ',I3,1P,1X,E12.5,5(1X,E13.6)) ENDDO ENDIF C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C CALCULATE ENERGY LOSS TABLES. AS WE REGARD CUT VALUES ONLY BELOW 21 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 = ZAIR(JJMAT) AATOM = AAIR(JJMAT) CONSTKINE = CTAU(JJMAT+6) C ENERGY LOOP (10 MEV AT J=1; 1 GEV AT J=21; 1000 EEV AT J=141) IF ( DEBUG ) WRITE(MDEBUG,205) JJMAT 205 FORMAT(' MUPINI: TAU ENERGY LOSS (GEV G**-1 CM**2) FOR ', * 'MATERIAL INDEX = ',I3,/,' BIN',1X, * 'ENERGY (GEV)',3X,'DEDXBREM',6X,'DEDXPAIR',6X, * 'NUCLEAR',8X,'SUM') 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 DEDXBR = DBRELM(JJMAT) DEDXPR = DPRELM(JJMAT) DEDXNI = DNIELM(JJMAT) DEDXMU(J,JJMAT,2) = DEDXBR + DEDXPR + DEDXNI DEDXMUB(J,JJMAT,2) = DEDXBR DEDXMUP(J,JJMAT,2) = DEDXPR DEDXMNI(J,JJMAT,2) = DEDXNI IF ( DEBUG ) WRITE(MDEBUG,206) * J,EE,DEDXBR,DEDXPR,DEDXNI,DEDXMU(J,JJMAT,2) 206 FORMAT(' ',I3,1P,1X,E12.5,4(1X,E13.6)) ENDDO ENDDO C CALCULATE ENERGY LOSS IN AIR IF ( DEBUG ) WRITE(MDEBUG,207) 207 FORMAT(' MUPINI: TAU ENERGY LOSS (GEV G**-1 CM**2) FOR AIR',/, * ' IONIZATION ENERGY LOSS WITH DENSITY EFFECT AT SEA LEVEL',/, * ' BIN',1X,'ENERGY (GEV)',5X,'ELOSS',8X,'DEDXMB',8X, * 'DEDXMP',8X,'DEDXMN',8X,' SUM') C DENSITY EFFECT PARAMETERIZATION (AT SEA LEVEL) CDNS = CDNS1 * RHOF(0.D0) 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,2) = COMPOS(1) * DEDXMU(J,1,2) * +COMPOS(2) * DEDXMU(J,2,2) * +COMPOS(3) * DEDXMU(J,3,2) DEDXMB(J,2) = COMPOS(1) * DEDXMUB(J,1,2) * +COMPOS(2) * DEDXMUB(J,2,2) * +COMPOS(3) * DEDXMUB(J,3,2) DEDXMP(J,2) = COMPOS(1) * DEDXMUP(J,1,2) * +COMPOS(2) * DEDXMUP(J,2,2) * +COMPOS(3) * DEDXMUP(J,3,2) DEDXMN(J,2) = COMPOS(1) * DEDXMNI(J,1,2) * +COMPOS(2) * DEDXMNI(J,2,2) * +COMPOS(3) * DEDXMNI(J,3,2) C ENERGY LOSS BY IONIZATION GAM0 = MAX( 1.0001D0, EE / PAMA(131) ) GAMSQ = GAM0**2 GMSQM1 = GAMSQ - 1.D0 ARGLOG = GMSQM1**2/( (GAM0*C(18)+1.D0)*(1.D0+GMSQM1*CDNS) ) ELOSS = C(22) * ( GAMSQ * (0.5D0*LOG( ARGLOG )+C(23)) * / GMSQM1 - 1.D0 ) IF ( DEBUG ) WRITE(MDEBUG,208) * J,EE,ELOSS,DEDXMB(J,2),DEDXMP(J,2),DEDXMN(J,2), * ELOSS+DEDXM(J,2) 208 FORMAT(' ',I3,1P,1X,E12.5,5(1X,E13.6)) ENDDO #endif RETURN END *-- Author : D. HECK IK FZK KARLSRUHE 04/10/1996 C======================================================================= SUBROUTINE MUPRPR C----------------------------------------------------------------------- C MU(ON) P(AI)R PR(ODUCTION) (ALSO USED FOR TAU LEPTONS) C C TREATES MUON/TAU 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 MUTRAC. C----------------------------------------------------------------------- IMPLICIT NONE #define __AIRINC__ #define __CONSTAINC__ #define __ELABCTINC__ #define __GENERINC__ #define __LONGIINC__ #define __MUPARTINC__ #define __PAMINC__ #define __PARPARINC__ #define __PARPAEINC__ #define __POLARINC__ #define __RANDPAINC__ #define __RESTINC__ #define __RUNPARINC__ #define __SIGMUINC__ #if __AUGERHIST__ #define __OBSPARINC__ #endif #include "corsika.h" DOUBLE PRECISION COSTH3,EELOG,EKIN,ENEG,EPOS,EPP,GX, * PHI3,RAT12,RO,ROMAX,ROMIN,SIGNEW,SIGOLD, * SINT1,SINT2,SK,SK1,SK2,SMAX,SMX1,SMX2,SNINT, * TRUR,TRUV,VC INTEGER I,KCOUNT,NPNTS #if __AUGERHIST__ DOUBLE PRECISION EDEP,THICKLOC INTEGER II,LL #endif #if __SLANT__ INTEGER LBIN EXTERNAL LBIN #endif SAVE DOUBLE PRECISION CPRSGM,DKOKOI,PPCS,THICK EXTERNAL CPRSGM,DKOKOI,PPCS,THICK C----------------------------------------------------------------------- #if __THIN__ IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=0,9),WEIGHT 444 FORMAT(' MUPRPR: CURPAR=',1P,11E11.3) #else IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=0,9) 444 FORMAT(' MUPRPR: CURPAR=',1P,10E11.3) #endif C COPY VERTEX COORDINATES TO SECPAR DO I = 5, 8 SECPAR(I) = CURPAR(I) ENDDO C INCREASE GENERATION COUNTER BY 200 TO MARK EM PARTICLES FROM MU CHANNEL SECPAR(9) = GEN + 200.D0 #if __THIN__ SECPAR(13) = WEIGHT #endif #if __CURVED__ SECPAR(14) = CURPAR(14) SECPAR(15) = CURPAR(15) SECPAR(16) = CURPAR(16) #endif #if __INTTEST__ SECPAR(17) = CURPAR(17) #endif #if __EHISTORY__ DO I = 17, 38 SECPAR(I) = CURPAR(I) ENDDO #endif #if __PARALLEL__ C SET ECTFLG TO OFF SECPAR(39) = CURPAR(39) #endif #if __MULTITHIN__ DO I = 41, 46 SECPAR(I) = CURPAR(I) ENDDO #endif #if __SLANT__ #if __CURVED__ IF ( LLONGI ) LHEIGH = MIN( LBIN( X,Y,HAPP,1 ), NSTEP+1 ) #else IF ( LLONGI ) LHEIGH = MIN( LBIN( X,Y,H,1 ), NSTEP+1 ) #endif #else IF ( LLONGI ) LHEIGH = INT( THICK( H )*THSTPI + 1.D0 ) #endif C SET MATERIAL CONSTANTS CMUON(.) ACCORDING TO TARGET INDEX LIT C (1=N, 2=O, 3=AR) WHICH WAS SET IN BOX2; RESTORE OLD CROSS-SECTION IF ( LIT .EQ. 1 ) THEN ZATOM = 7.D0 SIGOLD = FRAPTN / COMPOS(1) ELSEIF ( LIT .EQ. 2 ) THEN ZATOM = 8.D0 SIGOLD = (FRPTNO - FRAPTN) / COMPOS(2) ELSEIF ( LIT .EQ. 3 ) THEN ZATOM = 18.D0 SIGOLD = (SIGPRM - FRPTNO) / COMPOS(3) ELSE WRITE(MONIOU,*) 'MUPRPR: WRONG TARGET LIT =',LIT,' STOP' STOP ENDIF C TOTAL AND KINETIC ENERGY OF MUON EE = PAMA(ITYPE) * GAMMA EKIN = EE - PAMA(ITYPE) IF ( EKIN .LE. BCUT ) GOTO 900 C CHECK THE REDUCED CROSS-SECTIONS AND SKIP INTERACTION EVENTUALLY C GET NEW CROSS-SECTION SIGNEW = CPRSGM( EE,LIT,MT ) CALL RMMARD( RD,1,1 ) IF ( RD(1)*SIGOLD .GT. SIGNEW ) THEN C SKIP INTERACTION IF RANDOM NUMBER GREATER THAN CROSS-SECTION RATIO GOTO 900 ENDIF C VMIN = 4.D0 * PAMA(2) / EE VC = BCUT / EE VMIN = MAX( VMIN, VC ) IF ( MT .EQ. 1 ) THEN VMAX = 1.D0 - CMUON(10) * ZATOM**OB3 / EE ELSE VMAX = 1.D0 - CTAU(10) * ZATOM**OB3 / EE ENDIF IF ( VMAX .LE. VMIN ) GOTO 900 ROMIN = 0.D0 NPNTS = 64 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 KCOUNT = 0 321 CONTINUE KCOUNT = KCOUNT + 1 IF ( KCOUNT .GT. 1000 ) THEN GOTO 900 ENDIF CALL RMMARD( RD,3,1 ) 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*PAMA(ITYPE)**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 CALL RMMARD( RD,2,1 ) 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( PAMA(ITYPE)/EE ) CALL RMMARD( RD,1,1 ) PHI3 = PI2 * RD(1) C TREAT THE POSITRON IF ( EPOS .GT. BCUT+PAMA(2) ) THEN CALL ADDANG3( COSTHE,PHIX,PHIY, COSTH3,PHI3, * SECPAR(2),SECPAR(3),SECPAR(4) ) #if __UPWARD__ IF ( SECPAR(2) .GE. -1.D0 ) THEN #else IF ( SECPAR(2) .GT. C(29) ) THEN #endif SECPAR( 0) = 2.D0 SECPAR( 1) = EPOS/PAMA(2) SECPAR(10) = H CALL TSTACK ELSE IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT #if __THIN__ DLONG(LHEIGH,13) = DLONG(LHEIGH,13) + (EPOS+PAMA(2))*WEIGHT #else DLONG(LHEIGH,13) = DLONG(LHEIGH,13) + EPOS + PAMA(2) #endif ENDIF #if __AUGERHIST__ C PARTICLE BELOW ANGLE CUT THICKLOC = THICK( H ) DO LL = 1, NOBSLV IF ( THICKLOC .GE. THCKOB(LL) .AND. * THICKLOC .LT. THCKOB(LL)+SAMPTH ) THEN C THICKH IS WITHIN 1 G/CM^2 BELOW OBSLEV(LL) C BRING THE ENERGY TO THE HISTO OF LEVEL LL OUTPAR( 0) = 2.D0 OUTPAR( 1) = EPOS DO II = 2, 8 OUTPAR(II) = SECPAR(II) ENDDO OUTPAR( 9) = GEN OUTPAR(10) = ALEVEL OUTPAR(13) = WEIGHT EDEP = ( EPOS - RESTMS(2) ) * WEIGHT C WE HAVE ANGULAR CUT CALL AUGERDEPFIL( EDEP,LL,1 ) ELSEIF ( THICKLOC .LT. THCKOB(LL) ) THEN GOTO 110 ENDIF ENDDO 110 CONTINUE #endif ENDIF ELSE IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT #if __THIN__ DLONG(LHEIGH,3) = DLONG(LHEIGH,3) + (EPOS+PAMA(2))*WEIGHT #else DLONG(LHEIGH,3) = DLONG(LHEIGH,3) + EPOS + PAMA(2) #endif ENDIF #if __AUGERHIST__ THICKLOC = THICK( H ) DO LL = 1, NOBSLV IF ( THICKLOC .GE. THCKOB(LL) .AND. * THICKLOC .LT. THCKOB(LL)+SAMPTH ) THEN C THICKH IS WITHIN 1 G/CM^2 BELOW OBSLEV(LL) C BRING THE ENERGY BELOW CUT TO THE HISTO OF LEVEL LL OUTPAR( 0) = 2.D0 OUTPAR( 1) = EPOS DO II = 2, 8 OUTPAR(II) = CURPAR(II) ENDDO OUTPAR( 9) = GEN OUTPAR(10) = ALEVEL OUTPAR(13) = WEIGHT EDEP = ( EPOS - RESTMS(2) ) * WEIGHT CALL AUGERDEPFIL( EDEP,LL,0 ) ELSEIF ( THICKLOC .LT. THCKOB(LL) ) THEN GOTO 111 ENDIF ENDDO 111 CONTINUE #endif ENDIF C TREAT THE ELECTRON IF ( ENEG .GT. BCUT+PAMA(2) ) THEN C THE PHI DIRECTION IS OPPOSITE TO POSITRON CALL ADDANG3( COSTHE,PHIX,PHIY, COSTH3,PHI3+PI, * SECPAR(2),SECPAR(3),SECPAR(4) ) #if __UPWARD__ IF ( SECPAR(2) .GE. -1.D0 ) THEN #else IF ( SECPAR(2) .GT. C(29) ) THEN #endif SECPAR( 0) = 3.D0 SECPAR( 1) = ENEG/PAMA(2) SECPAR(10) = H CALL TSTACK ELSE IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT #if __THIN__ DLONG(LHEIGH,13) = DLONG(LHEIGH,13) + (ENEG-PAMA(3))*WEIGHT #else DLONG(LHEIGH,13) = DLONG(LHEIGH,13) + ENEG - PAMA(3) #endif ENDIF #if __AUGERHIST__ C PARTICLE BELOW ANGLE CUT THICKLOC = THICK( H ) DO LL = 1, NOBSLV IF ( THICKLOC .GE. THCKOB(LL) .AND. * THICKLOC .LT. THCKOB(LL)+SAMPTH ) THEN C THICKH IS WITHIN 1 G/CM^2 BELOW OBSLEV(LL) C BRING THE ENERGY TO THE HISTO OF LEVEL LL OUTPAR( 0) = 3.D0 OUTPAR( 1) = ENEG DO II = 2, 8 OUTPAR(II) = SECPAR(II) ENDDO OUTPAR( 9) = GEN OUTPAR(10) = ALEVEL OUTPAR(13) = WEIGHT EDEP = ( ENEG - RESTMS(3) ) * WEIGHT C WE HAVE ANGULAR CUT CALL AUGERDEPFIL( EDEP,LL,1 ) ELSEIF ( THICKLOC .LT. THCKOB(LL) ) THEN GOTO 112 ENDIF ENDDO 112 CONTINUE #endif ENDIF ELSE IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT #if __THIN__ DLONG(LHEIGH,3) = DLONG(LHEIGH,3) + (ENEG-PAMA(3))*WEIGHT #else DLONG(LHEIGH,3) = DLONG(LHEIGH,3) + ENEG - PAMA(3) #endif ENDIF #if __AUGERHIST__ THICKLOC = THICK( H ) DO LL = 1, NOBSLV IF ( THICKLOC .GE. THCKOB(LL) .AND. * THICKLOC .LT. THCKOB(LL)+SAMPTH ) THEN C THICKH IS WITHIN 1 G/CM^2 BELOW OBSLEV(LL) C BRING THE ENERGY BELOW CUT TO THE HISTO OF LEVEL LL OUTPAR( 0) = 3.D0 OUTPAR( 1) = ENEG DO II = 2, 8 OUTPAR(II) = CURPAR(II) ENDDO OUTPAR( 9) = GEN OUTPAR(10) = ALEVEL OUTPAR(13) = WEIGHT EDEP = ( ENEG - RESTMS(3) ) * WEIGHT CALL AUGERDEPFIL( EDEP,LL,0 ) ELSEIF ( THICKLOC .LT. THCKOB(LL) ) THEN GOTO 113 ENDIF ENDDO 113 CONTINUE #endif ENDIF C REDUCE ENERGY OF MUON/TAU GAMMA = (EE - EPP)/ PAMA(ITYPE) C THE CHANGEMENT OF THE MUON/TAU ANGLE IS NEGLECTED 900 CONTINUE C WRITE MUON/TAU TO STACK SECPAR( 0) = CURPAR(0) SECPAR( 1) = GAMMA SECPAR( 2) = CURPAR(2) SECPAR( 3) = CURPAR(3) SECPAR( 4) = CURPAR(4) SECPAR( 9) = GEN SECPAR(10) = ALEVEL CALL TSTACK RETURN END *-- Author : D. HECK IK FZK KARLSRUHE 25/09/1996 C======================================================================= SUBROUTINE MUTRAC C----------------------------------------------------------------------- C MU(ON) TRAC(KING) (ALSO USED FOR TAU) C C TRACKS THE MUON/TAU REGARDING MAX. STEP LENGTH FOR MULTIPLE SCATTER C CHECKS PASSAGE THROUGH OBSERVATION LEVELS. C IRET1=1 KILLS PARTICLE C IRET2=1 PARTICLE HAS BEEN CUTTED IN UPDATE C THIS SUBROUTINE IS CALLED FROM BOX3. C----------------------------------------------------------------------- IMPLICIT NONE #define __GENERINC__ #define __IRETINC__ #define __LONGIINC__ #define __MAGNETINC__ #define __MUMULTINC__ #define __MUPARTINC__ #define __NPARTIINC__ #define __OBSPARINC__ #define __PAMINC__ #define __PARPARINC__ #define __PARPAEINC__ #define __RUNPARINC__ #define __STACKFINC__ #include "corsika.h" #if __CERENKOV__ && __IACT__ DOUBLE PRECISION RHOF EXTERNAL RHOF #endif #if __CURVED__ LOGICAL FLAG #else #if __MULTITHIN__ DOUBLE PRECISION HEIGH,HNEW,PROPAR(0:46),THICK,THCKHN #else #if __EHISTORY__ DOUBLE PRECISION HEIGH,HNEW,PROPAR(0:38),THICK,THCKHN #else DOUBLE PRECISION HEIGH,HNEW,PROPAR(0:8),THICK,THCKHN #endif #endif INTEGER J LOGICAL IRETC EXTERNAL HEIGH,THICK #endif #if __AUGERHIST__ INTEGER LL #endif #if __SLANT__ INTEGER LBIN EXTERNAL LBIN #endif #if __COASTUSERLIB__ 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 DOUBLE PRECISION AUX,CHITOT,STPTOT INTEGER I,IRET3 LOGICAL FSCAT SAVE C----------------------------------------------------------------------- #if __THIN__ IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=0,9),WEIGHT 444 FORMAT(' MUTRAC: CURPAR=',1P,11E11.3) #else IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=0,9) 444 FORMAT(' MUTRAC: CURPAR=',1P,10E11.3) #endif C THE PLACE OF NEXT INTERACTION WAS DETERMINED IN BOX2 C KEEP TOTAL STEP LENGTH UNTIL DECAY OR INTERACTION OCCURS CHITOT = CHI IF ( FDECAY ) THEN #if __CURVED__ STPTOT = STEPL #else THCKHN = THICKH + COSTHE * CHITOT #if __UPWARD__ STPTOT = ( H - HEIGH( THCKHN ) )/COSTHE #else STPTOT = MAX( H - HEIGH( THCKHN ), 1.D-10 )/COSTHE #endif #endif ENDIF 10 CONTINUE C CALCULATE MAX STEP SIZE (10 RAD. LENGTH) FOR MULTIPLE SCATTERING C THE MAXIMUM STEP SIZE DEPENDS ON THE ENERGY TO GET ARRIVAL TIMES C WITH UNCERTAINTIES SMALLER THAN 1 NSEC #if __CERENKOV__ && __IACT__ C SCATTERING ANGLES OF MUONS SHOULD BE SMALLER THAN THE PIXEL SIZE. * AUX = MIN( 1.D0, 0.015D0*GAMMA ) C THE SAME SHOULD HOLD FOR DEFLECTION IN THE GEOMAGNETIC FIELD. C HERE USING A MAXIMUM RMS SCATTERING / DEFLECTION ANGLE OF 0.05 DEG C AND APPROXIMATE ALL BETA*GAMMA TERMS BY GAMMA. Cxx Write(*,*) 'mu step old-style step=',MIN( 1.D0,0.015D0*GAMMA ) C FOR A MEAN SCATTERING ANGLE THETA WE HAVE A STEP LENGTH OF ABOUT C (THETA / (13.6 MEV/(BETA*C*P))**2 RADIATION LENGTHS (PDG), C NOT TAKING INTO ACCOUNT THE NON-GAUSSIAN PART OF THE DISTIBUTION. C FOR THE MOMENT DON''T CARE ABOUT THE DIFFERENCE BETWEEN THE C 'COULOMB SCATTERING LENGTH' 37.7 G/CM**2 (=C(21)) AND THE C RADIATION LENGTH OF 36.66 OR 36.62 G/CM**2 IN AIR. C NOTE: PI/180/(13.6 MEV/(BETA*C*P)) APPROX 0.136*GAMMA FOR MUONS. AUX = MIN( 1.D0, ((0.05*0.136)*GAMMA)**2 ) IF ( BNORMC .GT. 0.D0 ) THEN C NOTE: PI/180*PAMA(5)*BETA*GAMMA APPROX 0.00185*GAMMA AUX = MIN( AUX, (0.05*0.00185)*GAMMA*RHOF(H)/(BNORMC*C(21)) ) ENDIF Cxx Write(*,*) 'mu step new-style step=',AUX #else AUX = MIN( 10.D0, 0.015D0*GAMMA ) #endif CHI = MIN( AUX*C(21), CHITOT ) IF ( CHI .GE. CHITOT ) THEN FSCAT = .FALSE. IF ( DEBUG ) WRITE(MDEBUG,*) 'MUTRAC: CHI=',SNGL(CHI) ELSE FSCAT = .TRUE. IF ( DEBUG ) WRITE(MDEBUG,*) 'MUTRAC: C(XX)=',SNGL(AUX*C(21)) ENDIF #if __CURVED__ C UPDATE PARTICLE TO INTERACTION POINT OR OBSERVATION LEVEL, C WHICHEVER IS CLOSER FLAG = .TRUE. CALL UPDATC( IRET3,FLAG ) C IRET3 = 1 MEANS PARTCLE HAS PASSED OBSERVATION LEVEL IF ( DEBUG ) WRITE(MDEBUG,*) 'MUTRAC: IRET1,2,3=', * IRET1,IRET2,IRET3 IF ( IRET2 .NE. 0 ) THEN C IRET2 = 1 MEANS PARTICLE IS CUTTED IN UPDATC/UPDATE C MUON/TAU CUT BEFORE INTERACTION POINT C LONGITUDINAL DEPOSIT IS ALREADY DONE IN UPDATC IRET1 = 1 FMUORG = .FALSE. RETURN ELSE IF ( IRET3 .EQ. 0 ) THEN C STORE MUON/TAU FOR FURTHER TREATMENT DO I = 0, 8 CURPAR(I) = OUTPAR(I) ENDDO #if __EHISTORY__ DO I = 17, 38 CURPAR(I) = OUTPAR(I) ENDDO #endif #if __MULTITHIN__ DO I = 41, 46 CURPAR(I) = OUTPAR(I) ENDDO #endif BETA = SQRT( (GAMMA-1.D0)*(GAMMA+1.D0) ) / GAMMA #if __PARALLEL__ IF ( FIRSTI .AND. JCOUNT .GT. 1 ) THEN C IF AT LEAST A PARTICLE IS STORED IN 2ND STACK, DO NOT USE PRIMARY IRET1 = 1 FMUORG = .FALSE. RETURN ENDIF #endif ELSE C KILL PARTICLE AS IT IS AT DETECTOR LEVEL IRET1 = 1 FMUORG = .FALSE. RETURN ENDIF ENDIF #else C CALCULATE HEIGHT DIFFERENCE IN CM FROM GIVEN CHI IN G/CM**2 THCKHN = THICKH + COSTHE * CHI IF ( THCKHN .LT. 0.D0 ) THEN THCKHN = 0.D0 FSCAT = .FALSE. ENDIF HNEW = HEIGH( THCKHN ) IF ( DEBUG ) WRITE(MDEBUG,*) 'MUTRAC: THICKH,THCKHN,HNEW=', * SNGL(THICKH),SNGL(THCKHN),SNGL(HNEW) C UPDATE MUON/TAU TO INTERACTION POINT (IF IT REACHES SO FAR) C AND STORE COORDINATES IN PROPAR CALL UPDATE( HNEW,THCKHN,0 ) IF ( DEBUG ) THEN WRITE(MDEBUG,455) IRET1,IRET2 455 FORMAT(' MUTRAC: IRET1..2=',2I5) IF ( IRET2 .EQ. 0 ) THEN #if __THIN__ WRITE(MDEBUG,454) (OUTPAR(I),I=0,9),OUTPAR(13) 454 FORMAT(' MUTRAC: OUTPAR=',1P,9E11.3,0P,F10.0,1P,E11.3) #else WRITE(MDEBUG,454) (OUTPAR(I),I=0,9) 454 FORMAT(' MUTRAC: OUTPAR=',1P,9E11.3,0P,F10.0) #endif ENDIF ENDIF #if __PARALLEL__ IF ( FIRSTI .AND. JCOUNT .GT. 1 ) THEN C MUON/TAU IS NOW UPDATED TO POINT OF INTERACTION FOR PRMPAR DO I = 0, 8 CURPAR(I) = OUTPAR(I) ENDDO C IF AT LEAST A PARTICLE IS STORED IN 2ND STACK, DO NOT USE PRIMARY IRET1 = 1 FMUORG = .FALSE. RETURN ENDIF #endif C STORE MUON/TAU FOR FURTHER TREATMENT IF ( IRET2 .EQ. 0 ) THEN DO I = 0, 8 PROPAR(I) = OUTPAR(I) ENDDO #if __EHISTORY__ DO I = 17, 38 PROPAR(I) = OUTPAR(I) ENDDO #endif #if __MULTITHIN__ DO I = 41, 46 PROPAR(I) = OUTPAR(I) ENDDO #endif IRET3 = 0 ELSE C MUON/TAU CUTTED AT INTERACTION POINT; IT MAY HOWEVER PASS SOME OF C THE OBSERVATION LEVELS IRET3 = 1 IRETC = IRETE ENDIF #if __COASTUSERLIB__ C DO NOT PASS LOWEST OBERVATION LEVEL IF ( HNEW .GT. OBSLEV(NOBSLV) .AND. IRET2 .EQ. 0 ) * call track(pnt1x, pnt2x) #endif C CHECK OBSERVATION LEVEL PASSAGE AND UPDATE MUON/TAU COORDINATES DO 1 J = 1, NOBSLV #if __UPWARD__ IF ( COSTHE .LT. 0.D0 ) THEN IF ( HNEW .LT. OBSLEV(J) ) GOTO 2 IF ( H .GT. OBSLEV(J) ) GOTO 1 ELSE IF ( HNEW .GT. OBSLEV(J) ) GOTO 2 IF ( H .LT. OBSLEV(J) ) GOTO 1 ENDIF #else IF ( HNEW .GT. OBSLEV(J) ) GOTO 2 IF ( H .LT. OBSLEV(J) ) GOTO 1 #endif C REMEMBER NUMBER OF LEVEL FOR OUTPUT LEVL = J CALL UPDATE( OBSLEV(J),THCKOB(J),J ) IF ( DEBUG ) WRITE(MDEBUG,456) J,IRET1,IRET2 456 FORMAT(' MUTRAC: OBSLEV=',I5,' IRET1,2=',2I5) C IF MUON/TAU IS NOT CUTTED, BRING IT TO OUTPUT IF ( IRET2 .EQ. 0 ) THEN CALL OUTPT1 ELSE IF ( LLONGI .AND. LEVL .EQ. NOBSLV .AND. .NOT.IRETE ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT #if __AUGERHIST__ IF ( DEBUG .AND. IRETC ) WRITE(MDEBUG,445) (CURPAR(I),I=0,9) 445 FORMAT(' MUTRAC1:E-DEP',2X,1P,9E11.3,0P,F10.0) #endif #if __SLANT__ LHEIGH = MIN( LBIN( X,Y,H,1 ), NSTEP+1 ) #else LHEIGH = INT( THICK( H )*THSTPI + 1.D0 ) #endif #if __THIN__ DLONG(LHEIGH,15) = DLONG(LHEIGH,15) * + GAMMA*PAMA(ITYPE)*WEIGHT #else DLONG(LHEIGH,15) = DLONG(LHEIGH,15) + GAMMA * PAMA(ITYPE) #endif ENDIF #if __AUGERHIST__ IF ( IRETC .AND. LEVL .EQ. NOBSLV ) THEN DO LL = 1, NOBSLV IF ( THCKHN .GE. THCKOB(LL) .AND. * THCKHN .LT. THCKOB(LL)+SAMPTH ) THEN C THCKHN AFTER TRANSPORT IS WITHIN 1 G/CM^2 BELOW OBSLEV(LL) C BRING THE ENERGY BELOW CUT TO THE HISTO OF LEVEL LL IF ( DEBUG ) WRITE(MDEBUG,*) 'MUTRAC1: THCKHN=',THCKHN CALL AUGCUT( LL ) ELSEIF ( THCKHN .LT. THCKOB(LL) ) THEN GOTO 111 ENDIF ENDDO 111 CONTINUE ENDIF #endif ENDIF 1 CONTINUE #if __COASTUSERLIB__ C PASS LOWEST OBERVATION LEVEL OR CUTTED IF ( IRET2 .EQ. 0 ) call track(pnt1x, pnt2x) #endif C KILL MUON/TAU AS IT DECAYS OR INTERACTS BELOW LOWEST OBSLEVEL IRET1 = 1 FMUORG = .FALSE. RETURN C MUON/TAU SCATTERS, DECAYS OR INTERACTS BEFORE PASSING OBSLEVEL 2 CONTINUE IF ( IRET3 .NE. 0 ) THEN C ELIMINATE MUON/TAU IF BELOW CUTS IRET1 = 1 FMUORG = .FALSE. IF ( LLONGI .AND. .NOT.IRETE ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT #if __AUGERHIST__ IF ( DEBUG .AND. IRETC ) WRITE(MDEBUG,446) (CURPAR(I),I=0,9) 446 FORMAT(' MUTRAC2:E-DEP',2X,1P,9E11.3,0P,F10.0) #endif #if __SLANT__ LHEIGH = MIN( LBIN( X,Y,H,1 ), NSTEP+1 ) #else LHEIGH = INT( THICK( H )*THSTPI + 1.D0 ) #endif #if __THIN__ DLONG(LHEIGH,15) = DLONG(LHEIGH,15) * + GAMMA*PAMA(ITYPE)*WEIGHT #else DLONG(LHEIGH,15) = DLONG(LHEIGH,15) + GAMMA * PAMA(ITYPE) #endif ENDIF #if __AUGERHIST__ IF ( IRETC ) THEN DO LL = 1, NOBSLV IF ( THCKHN .GE. THCKOB(LL) .AND. * THCKHN .LT. THCKOB(LL)+SAMPTH ) THEN C THCKHN AFTER TRANSPORT IS WITHIN 1 G/CM^2 BELOW OBSLEV(LL) C BRING THE ENERGY BELOW CUT TO THE HISTO OF LEVEL LL IF ( DEBUG ) WRITE(MDEBUG,*) 'MUTRAC2: THCKHN=',THCKHN CALL AUGCUT( LL ) ELSEIF ( THCKHN .LT. THCKOB(LL) ) THEN RETURN ENDIF ENDDO ENDIF #endif C MUON DID NOT SURVIVE ENERGY OR ANGULAR CUTS IN UPDATE #if __MUPROD__ C ADD. MUON INFORMATION (MUON INFORMATION AT PRODUCTION POINT) C FOR DECAYED MUONS CALL OUTPT3(3) #endif #if __THIN__ NMUONE = NMUONE + WEIGHT #else NMUONE = NMUONE + 1.D0 #endif RETURN ENDIF C MUON/TAU IS NOW UPDATED TO POINT OF INTERACTION DO I = 0, 8 CURPAR(I) = PROPAR(I) ENDDO #if __EHISTORY__ DO I = 17, 38 CURPAR(I) = PROPAR(I) ENDDO #endif #if __MULTITHIN__ DO I = 41, 46 CURPAR(I) = PROPAR(I) ENDDO #endif BETA = SQRT( (GAMMA-1.D0)*(GAMMA+1.D0) ) / GAMMA #endif IF ( FDECAY ) THEN C MUON/TAU DECAYS AT END OF PATH (MUDECY WRITES EM-PARTICLE TO STACK) IF ( FSCAT ) THEN C CHITOT IS THE MATERIAL STILL TO BE TRACKED C STPTOT IS THE PATHLENGTH STILL TO BE TRACKED STPTOT = STPTOT - STEPL CHITOT = CHITOT - CHI IF ( CHITOT .GT. 0.D0 .AND. STPTOT .GT. 0.D0 ) GOTO 11 ENDIF ALEVEL = H IF ( MT .EQ. 1 ) THEN C PERFORM DECAY OF MUON #if __MUPROD__ C ADD. MUON INFORMATION (MUON INFORMATION AT PRODUCTION POINT) C FOR DECAYED MUONS CALL OUTPT3(1) #endif CALL MUDECY CALL TSTEND #if __THIN__ NMUOND = NMUOND + WEIGHT #else NMUOND = NMUOND + 1.D0 #endif ELSE #if __CHARM__ || __TAULEP__ C PERFORM DECAY OF TAU LEPTON CALL CHRMDC CALL TSTEND #else WRITE(MONIOU,*) 'MUTRAC: PROGRAM STOP FOR TAU' STOP #endif ENDIF FMUORG = .FALSE. ELSE C MUON UNDERGOES NUCL. INTERACT OR BREMSSTR/PAIRPR AT END OF PATH C MUNUCL WRITES SECONDARY PARTICLES AND MUON TO STACK C MUBREM/MUPRPR WRITE EM-PARTICLES AND MUON TO STACK IF ( FSCAT ) THEN C MUON HAS MADE MULTIPLE SCATTERING C CHITOT IS THE MATERIAL STILL TO BE TRACKED CHITOT = CHITOT - CHI IF ( CHITOT .GT. 0.D0 ) GOTO 11 ENDIF IF ( FMUNUC ) THEN CALL MUNUCL C TSTEND IS CALLED IN MUNUCL ELSE IF ( FMUBRM ) THEN CALL MUBREM ELSE CALL MUPRPR ENDIF CALL TSTEND ENDIF ENDIF IRET1 = 1 RETURN 11 CONTINUE #if !__CURVED__ THICKH = THCKHN #endif #if __THIN__ IF ( DEBUG ) WRITE(MDEBUG,457) (CURPAR(I),I=0,9),WEIGHT 457 FORMAT(' MUTRAC: SCATTER',1P,11E11.3) #else IF ( DEBUG ) WRITE(MDEBUG,457) (CURPAR(I),I=0,9) 457 FORMAT(' MUTRAC: SCATTER',1P,10E11.3) #endif GOTO 10 END #if __CHARM__ *-- Author : A.GASCON IN UNIVERSIDAD DE GRANADA 07/03/2012 C======================================================================= INTEGER FUNCTION NNY(A) C----------------------------------------------------------------------- C PARAMETERIZATION OBTAINED FROM NUCOGE FOR THE NUMBER OF INTERACTING C NUCLEONS C NUCOGE: DING LINKAI, E. STENLUND, COMP. PHYS. COMMUN. 59 (1990) 313 C----------------------------------------------------------------------- IMPLICIT NONE #define __AIRINC__ #define __NCSNCSINC__ #define __PARPARINC__ #define __PARPAEINC__ #define __RANDPAINC__ #define __RESTINC__ #define __RUNPARINC__ #define __SIGMINC__ #include "corsika.h" DOUBLE PRECISION A, SIGMAA,SIGMAN,SIGMAO,SIG45,S45SQ,S4530 DOUBLE PRECISION NUCOGE(12,20),YN,YR INTEGER I,J,N,NUCCHOO SAVE C CHARMED MESON WITH NITROGEN DATA ((NUCOGE(I,J),I=1,1),J=1,20) / * 0.51974D0, 0.24427D0, 0.13045D0, 0.06484D0, * 0.02813D0, 0.00903D0, 0.00282D0, 0.00051D0, 0.00017D0, * 3.D-5, 1.D-5, 0.D0, 0.D0, 0.D0, 0.D0, * 0.D0, 0.D0, 0.D0, 0.D0, 0.D0 / C CHARMED MESON WITH OXYGEN DATA ((NUCOGE(I,J),I=2,2),J=1,20) / * 0.49752D0, 0.24097D0, 0.13664D0, 0.07223D0, * 0.03336D0, 0.01334D0, 0.00433D0, 0.00124D0, 0.00032D0, * 4.D-5, 1.D-5, 0.D0, 0.D0, 0.D0, 0.D0, * 0.D0, 0.D0, 0.D0, 0.D0, 0.D0 / C CHARMED MESON WITH ARGON DATA ((NUCOGE(I,J),I=3,3),J=1,20) / * 0.36767D0, 0.20187D0, 0.13996D0, 0.10289D0, * 0.0747D0, 0.04984D0, 0.03145D0, 0.01747D0, 0.00795D0, * 0.00383D0, 0.00147D0, 0.00068D0, 0.0002D0, 1.D-5, 1.D-5, * 0.D0, 0.D0, 0.D0, 0.D0, 0.D0 / C CHARMED BARYON WITH NITROGEN DATA ((NUCOGE(I,J),I=4,4),J=1,20) / * 0.40217D0, 0.21148D0, 0.142D0, 0.09835D0, * 0.06721D0, 0.04207D0, 0.02225D0, 0.00962D0, 0.00346D0, * 0.001D0, 0.0003D0, 7.D-5, 2.D-5, 0.D0, 0.D0, * 0.D0, 0.D0, 0.D0, 0.D0, 0.D0 / C CHARMED BARYON WITH OXYGEN DATA ((NUCOGE(I,J),I=5,5),J=1,20) / * 0.38468D0, 0.20701D0, 0.13775D0, 0.10131D0, * 0.07247D0, 0.04804D0, 0.02669D0, 0.01347D0, 0.00569D0, * 0.00213D0, 0.0006D0, 0.00012D0, 4.D-5, 0.D0, 0.D0, * 0.D0, 0.D0, 0.D0, 0.D0, 0.D0 / C CHARMED BARYON WITH ARGON DATA ((NUCOGE(I,J),I=6,6),J=1,20) / * 0.29152D0, 0.1581D0, 0.11624D0, 0.09232D0, * 0.07763D0, 0.06576D0, 0.05512D0, 0.04542D0, 0.03508D0, * 0.02453D0, 0.01662D0, 0.01042D0, 0.00584D0, 0.00314D0, * 0.00138D0, 0.00056D0, 0.00021D0, 8.D-5, 2.D-5, 1.D-5 / C BOTTOM MESON WITH NITROGEN DATA ((NUCOGE(I,J),I=7,7),J=1,20) / * 0.52967D0, 0.24535D0, 0.1278D0, 0.06133D0, * 0.02513D0, 0.00782D0, 0.00237D0, 0.00039D0, 0.00012D0, * 1.D-5, 1.D-5, 0.D0, 0.D0, 0.D0, 0.D0, * 0.D0, 0.D0, 0.D0, 0.D0, 0.D0/ C BOTTOM MESON WITH OXYGEN DATA ((NUCOGE(I,J),I=8,8),J=1,20) / * 0.50731D0, 0.24302D0, 0.13478D0, 0.06821D0, * 0.03012D0, 0.01169D0, 0.00352D0, 0.00106D0, 0.00024D0, * 4.D-5, 1.D-5, 0.D0, 0.D0, 0.D0, 0.D0, * 0.D0, 0.D0, 0.D0, 0.D0, 0.D0 / C BOTTOM MESON WITH ARGON DATA ((NUCOGE(I,J),I=9,9),J=1,20) / * 0.37532D0, 0.20698D0, 0.14347D0, 0.10334D0, * 0.0721D0, 0.04648D0, 0.02719D0, 0.01413D0, 0.00639D0, * 0.00303D0, 0.00115D0, 0.00031D0, 0.0001D0, 1.D-5, * 0.D0, 0.D0, 0.D0, 0.D0, 0.D0, 0.D0 / C BOTTOM BARYON WITH NITROGEN DATA ((NUCOGE(I,J),I=10,10),J=1,20) / * 0.40984D0, 0.21658D0, 0.1421D0, 0.09858D0, * 0.06398D0, 0.03841D0, 0.01922D0, 0.00773D0, 0.00261D0, * 0.00063D0, 0.00026D0, 6.D-5, 0.D0, 0.D0, 0.D0, * 0.D0, 0.D0, 0.D0, 0.D0, 0.D0 / C BOTTOM BARYON WITH OXYGEN DATA ((NUCOGE(I,J),I=11,11),J=1,20) / * 0.3937D0, 0.21018D0, 0.13997D0, 0.10044D0, * 0.07055D0, 0.04405D0, 0.02362D0, 0.0111D0, 0.00442D0, * 0.00147D0, 0.00041D0, 9.D-5, 0.D0, 0.D0, 0.D0, * 0.D0, 0.D0, 0.D0, 0.D0, 0.D0 / C BOTTOM BARYON WITH ARGON DATA ((NUCOGE(I,J),I=12,12),J=1,20) / * 0.29607D0, 0.16347D0, 0.11912D0, 0.09466D0, * 0.07987D0, 0.06695D0, 0.0554D0, 0.04374D0, 0.03097D0, * 0.02102D0, 0.01357D0, 0.0075D0, 0.0042D0, 0.00206D0, * 0.00093D0, 0.00029D0, 0.00011D0, 6.D-5, 1.D-5, 0.D0 / C----------------------------------------------------------------------- cdh FRACTN = COMPOS(1) * 14.D0 * SIGMA/SIGAIR cdh FRCTNO = COMPOS(2) * 16.D0 * SIGMA/SIGAIR + FRACTN C AUXIL. QUANTITIES FOR INTERPOLATION SIG45 = SIGMA - 45.D0 S45SQ = SIG45**2 / 450.D0 S4530 = SIG45 / 30.D0 C INELASTIC CROSS-SECTIONS FOR PROJECTICLE WITH MASS NUMBER 1 SIGMAN = (1.D0 - 2.D0 * S45SQ) * SIGN45(1) * +(S45SQ - S4530) * SIGN30(1) * +(S45SQ + S4530) * SIGN60(1) FRACTN = COMPOS(1) * SIGMAN SIGMAO = (1.D0 - 2.D0 * S45SQ) * SIGO45(1) * +(S45SQ - S4530) * SIGO30(1) * +(S45SQ + S4530) * SIGO60(1) FRCTNO = FRACTN + COMPOS(2) * SIGMAO SIGMAA = (1.D0 - 2.D0 * S45SQ) * SIGA45(1) * +(S45SQ - S4530) * SIGA30(1) * +(S45SQ + S4530) * SIGA60(1) C INELASTIC CROSS-SECTIONS OF AIR FOR PROJECTILE WITH MASS NUMBER 1 SIGAIR = FRCTNO + COMPOS(3) * SIGMAA CALL RMMARD( RD,1,1 ) IF ( RD(1)*SIGAIR .LE. FRACTN ) THEN C INTERACTION WITH NITROGEN LIT = 1 TAR = 14.D0 ELSEIF ( RD(1)*SIGAIR .LE. FRCTNO ) THEN C INTERACTION WITH OXYGEN LIT = 2 TAR = 16.D0 ELSE C INTERACTION WITH ARGON LIT = 3 TAR = 40.D0 ENDIF NUCCHOO = 0 IF ( ITYPE .GE. 116 .AND. ITYPE .LE. 128 ) THEN C CHARMED MESON IF ( TAR .EQ. 14.D0 ) THEN NUCCHOO = 1 ELSEIF ( TAR .EQ. 16.D0 ) THEN NUCCHOO = 2 ELSEIF ( TAR .EQ. 40.D0 ) THEN NUCCHOO = 3 ENDIF ELSEIF ( ITYPE .GE. 137 .AND. ITYPE .LE. 173 ) THEN C CHARMED BARYON IF ( TAR .EQ. 14.D0 ) THEN NUCCHOO = 4 ELSEIF ( TAR .EQ. 16.D0 ) THEN NUCCHOO = 5 ELSEIF ( TAR .EQ. 40.D0 ) THEN NUCCHOO = 6 ENDIF ELSEIF ( ITYPE .GE. 176 .AND. ITYPE .LE. 183 ) THEN C BOTTOM MESON IF ( TAR .EQ. 14.D0 ) THEN NUCCHOO = 7 ELSEIF ( TAR .EQ. 16.D0 ) THEN NUCCHOO = 8 ELSEIF ( TAR .EQ. 40.D0 ) THEN NUCCHOO = 9 ENDIF ELSEIF ( ITYPE .GE. 184 .AND. ITYPE .LE. 195 ) THEN C BOTTOM BARYON IF ( TAR .EQ. 14.D0 ) THEN NUCCHOO = 10 ELSEIF ( TAR .EQ. 16.D0 ) THEN NUCCHOO = 11 ELSEIF ( TAR .EQ. 40.D0 ) THEN NUCCHOO = 12 ENDIF ENDIF 150 CONTINUE CALL RMMARD( RD,2,1 ) N = INT(19.D0*RD(1)+1.D0) YR = RD(2) YN = NUCOGE(NUCCHOO,N) IF ( YR .GT. YN ) GOTO 150 NNY = N RETURN END #endif #if __CURVED__ *-- Author : F. SCHROEDER UNI WUPPERTAL 17/09/1998 C======================================================================= SUBROUTINE NRANGC( ARG ) C----------------------------------------------------------------------- C N(EUTRAL PARTICLE) RANGE C(URVED ATMOSPHERE) C C DETERMINES PENETRATED MATTER CHI FOR NEUTRAL PARTICLES C TAKING INTO ACCOUNT A CURVED ATMOSPHERE. C THIS SUBROUTINE IS CALLED FROM AAMAIN AND BOX2. C ARGUMENT: C ARG = GEOMETRIC LENGTH OF PARTICLE TRACK (CM) C----------------------------------------------------------------------- IMPLICIT NONE #define __ATMOS2INC__ #define __OBSPARINC__ #define __PARPARINC__ #define __PARPAEINC__ #define __RUNPARINC__ #if __ATMEXT__ #define __ATMOSXINC__ #endif #include "corsika.h" DOUBLE PRECISION ARG,ARGNEW,COSDIF,COSPHI,COSTHENEW, * DH,HOLD,HNEW,SINPHI, * SINTHE,SINTHENEW,THICK,TRANS,TRANSNEW SAVE EXTERNAL THICK #if __UPWARD__ DOUBLE PRECISION RHOF EXTERNAL RHOF #endif C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,444) ARG,THICKH 444 FORMAT(' NRANGC: ARG=',1P,E10.3,' THICKH=',E10.3) C START VALUES CHI = 0.D0 HNEW = H SINTHE = SQRT( (1.D0-COSTHE)*(1.D0+COSTHE) ) IF ( SINTHE .NE. 0.D0 ) THEN COSPHI = PHIX / SINTHE SINPHI = PHIY / SINTHE ELSE COSPHI = 0.D0 SINPHI = 0.D0 ENDIF COSTHENEW = COSTHE C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C LOOP OVER PIECES OF ARG (EACH IN ITS LOCAL FLAT COORDINATE FRAME) 2 CONTINUE SINTHENEW = SQRT( (1.D0-COSTHENEW)*(1.D0+COSTHENEW) ) TRANS = ARG * SINTHENEW C MAXIMAL HORIZONTAL STEP (DEPENDS ON THICKNESS AT PARTICLE ALTITUDE) TRANSNEW = MIN( TRANS, MAX( (C(4) * THICK(HNEW) + C(3)), C(2) ) ) IF ( DEBUG ) WRITE(MDEBUG,*) 'NRANGC: TRANSNEW=',SNGL(TRANSNEW) IF ( SINTHENEW .LE. 0.D0 ) THEN C PARTICLE TRACK IS VERTICAL ARGNEW = ARG ELSE ARGNEW = TRANSNEW / SINTHENEW ENDIF DH = ARGNEW * COSTHENEW #if __ATMEXT__ IF ( IATMOX .GT. 0 ) THEN IF ( HNEW-DH .LE. HLAY(1) ) THEN #if __UPWARD__ IF ( ABS( COSTHENEW ) .GT. 0.003D0 ) THEN CHI = CHI + (THICKL(1) - THICK( HNEW )) / COSTHENEW ELSE C TREATMENT OF NEARLY HORIZONTAL PARTICLE (INCLINATION < 0.2 DEG) CHI = CHI + TRANSNEW * RHOF( HNEW ) ENDIF #else CHI = CHI + (THICKL(1) - THICK( HNEW )) / COSTHENEW #endif IF ( DEBUG ) WRITE(MDEBUG,*) * 'NRANGC: HNEW,CHI= ',SNGL(HLAY(1)),SNGL(CHI) RETURN ENDIF ENDIF #else IF ( HNEW-DH .LE. HLAY(1) ) THEN #if __UPWARD__ IF ( ABS( COSTHENEW ) .GT. 0.003D0 ) THEN CHI = CHI + (THICKL(1) - THICK( HNEW )) / COSTHENEW ELSE C TREATMENT OF NEARLY HORIZONTAL PARTICLE (INCLINATION < 0.2 DEG) CHI = CHI + TRANSNEW * RHOF( HNEW ) ENDIF #else CHI = CHI + (THICKL(1) - THICK( HNEW )) / COSTHENEW #endif IF ( DEBUG ) WRITE(MDEBUG,*) * 'NRANGC: HNEW,CHI= ',SNGL(HLAY(1)),SNGL(CHI) RETURN ENDIF #endif #if __UPWARD__ IF ( ABS( COSTHENEW ) .GT. 0.003D0 ) THEN CHI = CHI + (THICK( HNEW-DH ) - THICK( HNEW )) / COSTHENEW ELSE C TREATMENT OF NEARLY HORIZONTAL PARTICLE (INCLINATION < 0.2 DEG) CHI = CHI + TRANSNEW * RHOF( HNEW ) ENDIF #else CHI = CHI + (THICK( HNEW-DH ) - THICK( HNEW )) / COSTHENEW #endif C ACTUAL VALUES ARG = ARG - ARGNEW IF (DEBUG) WRITE(MDEBUG,*) 'NRANGC: ARG,CHI=',SNGL(ARG),SNGL(CHI) C LOOP UNTIL COMPLETE PARTICLE TRACK LENGTHS IS TRANSFORMED INTO CHI IF ( ARG .GT. 0.D0 ) THEN C NEW COORDINATE FRAME HOLD = HNEW C NEW HEIGHT IN OLD COORDINATE FRAME HNEW = HNEW - DH C NEW ACTUAL HEIGHT AT NEW THICKNESS GRADIENT C (CALCULATED WITH PARAMETERS OF OLD COORDINATE FRAME) HNEW = SQRT( TRANSNEW**2 + (C(1)+HNEW)**2 ) - C(1) #if __UPWARD__ C TERMINATE PROCESS IF PARTICLE BELOW SEA LEVEL OR ABOVE ATMOSPHERE IF ( ( HNEW .LT. HLAY(1) - 1.D5 ) .OR. * ( HNEW .GT. HLAY(6) ) ) THEN #else C TERMINATE PROCESS IF PARTICLE WELL BELOW OBSERVATION LEVEL IF ( HNEW .LT. OBSLEV(1) - 1.D5 ) THEN #endif IF ( DEBUG ) WRITE(MDEBUG,*) 'NRANGC: HNEW,CHI,ARG=', * SNGL(HNEW),SNGL(CHI),SNGL(ARG) RETURN ENDIF COSDIF = ( (C(1)+HNEW)**2 + (C(1)+HOLD)**2 - ARGNEW**2 ) / * ( 2.D0 * (C(1)+HNEW) * (C(1)+HOLD) ) IF (DEBUG) WRITE(MDEBUG,*) 'NRANGC: HNEW,COSDIF=', * SNGL(HNEW),SNGL(COSDIF) COSDIF = MIN( 1.D0, COSDIF ) C COSINE OF NEW LOCAL ZENITH ANGLE C (THETA_NEW=THETA+DELTA -> ALWAYS + FOR THIS DEFINITION OF THETA) COSTHENEW = MIN( 1.D0, ( COSTHENEW * COSDIF * - SQRT( (1.D0-COSDIF)*(1.D0+COSDIF) * *(1.D0-COSTHENEW)*(1.D0+COSTHENEW) ) ) ) IF ( DEBUG ) WRITE(MDEBUG,*) 'NRANGC: COSTHENEW=',COSTHENEW C TERMINATE PROCESS IF PARTICLE MOVES OUT OF ANGULAR RANGE (UPWARD?) IF ( COSTHENEW .LE. C(29) ) RETURN GOTO 2 ENDIF RETURN END #endif *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE NUCINT C----------------------------------------------------------------------- C NUC(LEAR) INT(ERACTION) C C SELECTS TYPE OF INTERACTION PROCESS ACCORDING TO ECM C HEAVY PRIMARIES AND STRANGE BARYONS INCLUDED. C THIS SUBROUTINE IS CALLED FROM AAMAIN. C----------------------------------------------------------------------- IMPLICIT NONE #define __AIRINC__ #define __CONSTAINC__ #define __GENERINC__ #define __IRETINC__ #define __KAONSINC__ #define __LONGIINC__ #define __MULTINC__ #define __PAMINC__ #define __PARPARINC__ #define __PARPAEINC__ #define __POLARINC__ #define __RANDPAINC__ #define __RUNPARINC__ #define __SIGMINC__ #define __STATIINC__ #define __VKININC__ #if __AUGERHIST__ #define __OBSPARINC__ #endif #if __INTTEST__ #define __TSTINTINC__ #endif #include "corsika.h" DOUBLE PRECISION BETA3,COSMU,COSTCM,COSTH3,ETOT,GAMMA3, * PHI,PHIMU,PHI3,SINMU,THICK,WORK1,WORK2 INTEGER I,IGO,KJ LOGICAL FIRSTINT #if !__STACKIN__ && !__CONEX__ DOUBLE PRECISION ENERGY,EN,PZ,PX,PY,HEI0 INTEGER NNN,NN,NTYP c INTEGER N,IRET,IBL #endif #if __URQMD__ INTEGER IA #endif #if __NEUTRINO__ DOUBLE PRECISION COSTH4 #endif #if __SLANT__ INTEGER LBIN EXTERNAL LBIN #endif #if __AUGERHIST__ DOUBLE PRECISION EDEP,THICKLOC INTEGER II,LL #endif SAVE EXTERNAL THICK C----------------------------------------------------------------------- #if __THIN__ IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=0,9),WEIGHT 444 FORMAT(' NUCINT: CURPAR=',1P,11E11.3) #else IF ( DEBUG ) THEN WRITE(MDEBUG,444) (CURPAR(I),I=0,9) 444 FORMAT(' NUCINT: CURPAR=',1P,10E11.3) #if __MULTITHIN__ WRITE(MDEBUG,31) (CURPAR(I),I=41,46) 31 FORMAT(' NUCINT: 41-46: ',1P,6E11.3) #endif ENDIF #endif FIRSTINT = FIRSTI C COPY VERTEX COORDINATES INTO SECPAR DO I = 5, 8 SECPAR(I) = CURPAR(I) ENDDO C SET GENERATION AND LEVEL OF LAST INTERACTION SECPAR( 9) = GEN SECPAR(10) = ALEVEL C RESET POLARIZATION, NOT USED FOR PARTICLES OTHER THAN MUONS YET SECPAR(11) = 0.D0 SECPAR(12) = 0.D0 #if __THIN__ C SET WEIGHT SECPAR(13) = WEIGHT #endif #if __CURVED__ SECPAR(14) = CURPAR(14) SECPAR(15) = CURPAR(15) SECPAR(16) = CURPAR(16) #endif #if __INTTEST__ SECPAR(17) = CURPAR(17) #endif #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER/GRANDMOTHER DO I = 17, 38 SECPAR(I) = CURPAR(I) ENDDO #endif #if __PARALLEL__ C SET ECTFLG TO OFF SECPAR(39) = CURPAR(39) #endif #if __MULTITHIN__ DO I = 41, 46 SECPAR(I) = CURPAR(I) ENDDO #endif THICKH = THICK( H ) #if __SLANT__ #if __CURVED__ IF ( LLONGI ) LHEIGH = MIN( LBIN( X,Y,HAPP,1 ), NSTEP+1 ) #else IF ( LLONGI ) LHEIGH = MIN( LBIN( X,Y,H,1 ), NSTEP+1 ) #endif #else IF ( LLONGI ) LHEIGH = INT( THICKH * THSTPI + 1.D0 ) #endif C CALCULATE KIN. ENERGY BIN EKINL = PAMA(ITYPE) * ( GAMMA - 1.D0 ) ETOT = PAMA(ITYPE) * GAMMA IF ( EKINL .GE. .1D0 ) THEN KJ = INT( MIN( 40.D0, 5.D0 + 3.D0*LOG10(EKINL) ) ) ELSE KJ = 1 ENDIF C----------------------------------------------------------------------- C CHARGED PION INCIDENT IF ( ITYPE .EQ. 8 .OR. ITYPE .EQ. 9 ) THEN IF ( DEBUG ) WRITE(MDEBUG,*) 'NUCINT: PION EKINL=',SNGL(EKINL), * ' ETOT=',ETOT #if __THIN__ IPBIN(KJ) = IPBIN(KJ) + NINT( WEIGHT ) #else IPBIN(KJ) = IPBIN(KJ) + 1 #endif C DECAY OR INTERACTION FOR CHARGED PIONS ? IF ( FDECAY ) THEN C DECAY PI(+,-) ----> MU(+,-) + (ANTI)-NEUTRINO(MU) C INCREMENT GENERATION COUNTER TO DIFFERENTIATE BETWEEN MUONS (AND C NEUTRINOS) FROM DECAYS: C K-DECAY (OR OTHER SOURCES): GEN=NORMAL, PI-DECAY: GEN INCREASED BY 50 SECPAR(9) = GEN + 50.D0 WORK1 = C(48) * GAMMA WORK2 = C(49) * BETA * WORK1 CALL RMMARD( RD,2,1 ) COSTCM = 2.D0 * RD(1) - 1.D0 GAMMA3 = WORK1 + COSTCM * WORK2 BETA3 = SQRT( (GAMMA3-1.D0)*(GAMMA3+1.D0) ) / GAMMA3 COSTH3 = MIN( 1.D0, ( GAMMA * GAMMA3 - C(48) ) * /( BETA * GAMMA * BETA3 * GAMMA3 ) ) PHI3 = PI2 * RD(2) #if __NEUTRINO__ C (ANTI)-NEUTRINO(MU) COSTH4 = MIN( 1.D0, (BETA - COSTCM) / (1.D0 - BETA * COSTCM) ) SECPAR(1) = PAMA(8) * GAMMA - PAMA(5) * GAMMA3 CALL ADDANG3( COSTHE,PHIX,PHIY, COSTH4,PHI3+PI, * SECPAR(2),SECPAR(3),SECPAR(4) ) #if __UPWARD__ IF ( SECPAR(2) .GE. -1.D0 ) THEN #else IF ( SECPAR(2) .GT. C(29) ) THEN #endif SECPAR(0) = CURPAR(0) + 60.D0 CALL TSTACK ELSE IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT #if __THIN__ DLONG(LHEIGH,18) = DLONG(LHEIGH,18) + SECPAR(1) * WEIGHT #else DLONG(LHEIGH,18) = DLONG(LHEIGH,18) + SECPAR(1) #endif ENDIF ENDIF #else C NEUTRINO IS DROPPED IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT SECPAR(1) = PAMA(8) * GAMMA - PAMA(5) * GAMMA3 #if __THIN__ DLONG(LHEIGH,8) = DLONG(LHEIGH,8) + SECPAR(1) * WEIGHT #else DLONG(LHEIGH,8) = DLONG(LHEIGH,8) + SECPAR(1) #endif ENDIF #endif C MUON IF ( PHIX .NE. 0.D0 .OR. PHIY .NE. 0.D0 ) THEN PHI = ATAN2( PHIY, PHIX ) ELSE PHI = 0.D0 ENDIF CALL ADDANG( COSTHE,PHI, COSTH3,PHI3, COSMU,PHIMU ) IF ( COSMU .GT. C(29) ) THEN C DIRECTION OF PION IN THE MUON CM SYSTEM (= DIRECTION OF POLARIZATION) C SEE: G. BARR ET AL., PHYS. REV. D39 (1989) 3532, EQ. 5 C POLART IS COS OF ANGLE BETWEEN PION AND LABORATORY IN THE MU CM C POLARF IS ANGLE PHI AROUND THE LAB DIRECTION IN THE MU CM C POLART, POLARF ARE WITH RESPECT TO THE MU DIRECTION IN THE LAB SYSTEM POLART = ( 2.D0*PAMA(8)*GAMMA*C(7)/(PAMA(5)*GAMMA3) * - C(7) - 1.D0 ) / ( BETA3 * (1.D0 - C(7)) ) POLARF = PHI3 - PI C PION DIRECTION IS DIRECTION OF POLARIZATION FOR PI+, OPPOSITE FOR PI- IF ( ITYPE .EQ. 9 ) THEN POLART = -POLART POLARF = POLARF + PI ENDIF C GET THE POLARIZATION DIRECTION IN THE MU CM RELATIVE TO THE CORSIKA C COORDINATE SYSTEM CALL ADDANG( COSMU,PHIMU, POLART,POLARF, POLART,POLARF ) C MUON IS WRITTEN TO STACK SECPAR( 0) = CURPAR(0) - 3.D0 SECPAR( 1) = GAMMA3 SECPAR( 2) = COSMU SINMU = SQRT( (1.D0 - COSMU)*(1.D0 + COSMU) ) SECPAR( 3) = SINMU * COS( PHIMU ) SECPAR( 4) = SINMU * SIN( PHIMU ) SECPAR(11) = POLART SECPAR(12) = POLARF CALL TSTACK SECPAR(11) = 0.D0 SECPAR(12) = 0.D0 ELSE IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT #if __THIN__ DLONG(LHEIGH,15) = DLONG(LHEIGH,15)+GAMMA3*PAMA(5)*WEIGHT #else DLONG(LHEIGH,15) = DLONG(LHEIGH,15) + GAMMA3 * PAMA(5) #endif ENDIF #if __AUGERHIST__ THICKLOC = THICK( H ) DO LL = 1, NOBSLV IF ( THICKLOC .GE. THCKOB(LL) .AND. * THICKLOC .LT. THCKOB(LL)+SAMPTH ) THEN C THICKH IS WITHIN 1 G/CM^2 BELOW OBSLEV(LL) C BRING THE ENERGY BELOW ANGULAR CUT TO THE HISTO OF LEVEL LL OUTPAR(0) = CURPAR(0) - 3.D0 OUTPAR(1) = GAMMA3 OUTPAR(2) = COSMU SINMU = SQRT( (1.D0-COSMU)*(1.D0+COSMU) ) OUTPAR(3) = SINMU * COS( PHIMU ) OUTPAR(4) = SINMU * SIN( PHIMU ) DO II = 5, 8 OUTPAR(II) = CURPAR(II) ENDDO OUTPAR( 9) = GEN OUTPAR(10) = ALEVEL OUTPAR(13) = WEIGHT EDEP = OUTPAR(1) * PAMA(5) * WEIGHT C WE HAVE ANGULAR CUT CALL AUGERDEPFIL( EDEP,LL,1 ) ELSEIF ( THICKLOC .LT. THCKOB(LL) ) THEN GOTO 111 ENDIF ENDDO 111 CONTINUE #endif ENDIF IRET1 = 1 RETURN ENDIF C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C CHARGED PION INTERACTS C CALCULATE GAMMA, BETA AND ENERGY IN CENTER OF MASS ECM = SQRT( C(45) * GAMMA + C(46) ) GCM = (PAMA(ITYPE) * GAMMA + PAMA(14)) / ECM BETACM = SQRT( (GCM-1.D0)*(GCM+1.D0) ) / GCM #if __INTTEST__ C STORE THE GAMMA FACTOR AND BETA FOR BACK TRANSFORMATION C INTO THE PROJECTILE-NUCLEON REST SYSTEM GACM = GCM BECM = BETACM ECMI = ECM IF ( DEBUG ) WRITE(MDEBUG,*) 'NUCINT: GACM,BECM,ECM = ', * SNGL(GACM),BECM,SNGL(ECMI) #endif C LOW ENERGY HADRONIC INTERACTIONS C CHECK IF WE USE LOW ENERGY HADRONIC INTERACTION MODEL IF ( USELOW ) THEN #if __FLUKA__ C USE FLUKA LOW ENERGY HADRONIC INTERACTION MODEL CALL FLULNK ELSE IF ( PAMA(ITYPE)*GAMMA .GT. HILOELB ) THEN C USE HIGH ENERGY HADRONIC INTERACTION MODEL CALL SDPM( 0 ) ELSE CALL FLULNK ENDIF #elif __GHEISHAD__ C USE GHEISHA IF THE CROSS-SECTION HAS BEEN CALCULATED FOR GHEISHA CALL CGHEI ELSE CALL SDPM( 0 ) #elif __URQMD__ C USE URQMD LOW ENERGY HADRONIC INTERACTION MODEL CALL URQLNK ELSE IF ( PAMA(ITYPE)*GAMMA .GT. HILOELB ) THEN C USE HIGH ENERGY HADRONIC INTERACTION MODEL CALL SDPM( 0 ) ELSE CALL URQLNK ENDIF #endif ENDIF C----------------------------------------------------------------------- C PI(0) INCIDENT ELSEIF ( ITYPE .EQ. 7 ) THEN IF ( DEBUG ) WRITE(MDEBUG,*) 'NUCINT: PI(0) EKINL=',SNGL(EKINL), * ' ETOT=',ETOT #if __THIN__ IPBIN(KJ) = IPBIN(KJ) + NINT( WEIGHT ) #else IPBIN(KJ) = IPBIN(KJ) + 1 #endif C DECAY OR INTERACTION FOR PIONS ? IF ( FDECAY ) THEN CALL PI0DEC ELSE C FOR INTERACTION THE ENERGY MUST BE VERY HIGH C CALCULATE GAMMA, BETA AND ENERGY IN CENTER OF MASS ECM = SQRT( 2.D0 * PAMA(14) * PAMA(7) * GAMMA * + PAMA(14)**2 +PAMA(7)**2 ) GCM = (PAMA(7) * GAMMA + PAMA(14)) / ECM BETACM = SQRT( (GCM-1.D0)*(GCM+1.D0) ) / GCM #if __INTTEST__ C STORE THE GAMMA FACTOR AND BETA FOR BACK TRANSFORMATION C INTO THE PROJECTILE-NUCLEON REST SYSTEM GACM = GCM BECM = BETACM ECMI = ECM IF ( DEBUG ) WRITE(MDEBUG,*) 'NUCINT: GACM,BECM,ECM = ', * SNGL(GACM),BECM,SNGL(ECMI) #endif C HIGH ENERGY INTERACTION MODEL CALL SDPM( 0 ) ENDIF C----------------------------------------------------------------------- C NUCLEON OR ANTINUCLEON INCIDENT ELSEIF ( ITYPE .EQ. 13 .OR. ITYPE .EQ. 14 .OR. * ITYPE .EQ. 15 .OR. ITYPE .EQ. 25 ) THEN IF ( DEBUG ) WRITE(MDEBUG,*) 'NUCINT: NUCL EKINL=',SNGL(EKINL), * ' ETOT=',ETOT C CALCULATE GAMMA, BETA AND ENERGY IN CENTER OF MASS GCM = SQRT( GAMMA * 0.5D0 + 0.5D0 ) ECM = PAMA(ITYPE) * GCM * 2.D0 BETACM = SQRT( (GCM-1.D0)*(GCM+1.D0) ) / GCM #if __INTTEST__ C STORE THE GAMMA FACTOR AND BETA FOR BACK TRANSFORMATION C INTO THE PROJECTILE-NUCLEON REST SYSTEM GACM = GCM BECM = BETACM ECMI = ECM IF ( DEBUG ) WRITE(MDEBUG,*) 'NUCINT: GACM,BECM,ECM = ', * SNGL(GACM),BECM,SNGL(ECMI) #endif #if __THIN__ INBIN(KJ) = INBIN(KJ) + NINT( WEIGHT ) #else INBIN(KJ) = INBIN(KJ) + 1 #endif C LOW ENERGY HADRONIC INTERACTIONS C CHECK IF WE USE LOW ENERGY HADRONIC INTERACTION MODEL IF ( USELOW ) THEN #if __FLUKA__ C USE FLUKA LOW ENERGY HADRONIC INTERACTION MODEL CALL FLULNK ELSE IF ( PAMA(ITYPE)*GAMMA .GT. HILOELB ) THEN C USE HIGH ENERGY HADRONIC INTERACTION MODEL CALL SDPM( 0 ) ELSE CALL FLULNK ENDIF #elif __GHEISHAD__ C USE GHEISHA IF THE CROSS-SECTION HAS BEEN CALCULATED FOR GHEISHA CALL CGHEI ELSE CALL SDPM( 0 ) #elif __URQMD__ C USE URQMD LOW ENERGY HADRONIC INTERACTION MODEL CALL URQLNK ELSE IF ( PAMA(ITYPE)*GAMMA .GT. HILOELB ) THEN C USE HIGH ENERGY HADRONIC INTERACTION MODEL CALL SDPM( 0 ) ELSE CALL URQLNK ENDIF #endif ENDIF C----------------------------------------------------------------------- C KAON INCIDENT ELSEIF ( ITYPE .EQ. 11 .OR. ITYPE .EQ. 12 .OR. * ITYPE .EQ. 10 .OR. ITYPE .EQ. 16 ) THEN IF ( DEBUG ) WRITE(MDEBUG,*) 'NUCINT: KAON EKINL=',SNGL(EKINL), * ' ETOT=',ETOT #if __THIN__ IKBIN(KJ) = IKBIN(KJ) + NINT( WEIGHT ) #else IKBIN(KJ) = IKBIN(KJ) + 1 #endif C DECAY OR INTERACTION FOR KAONS ? IF ( FDECAY ) THEN C KAON DECAYS. DETERMINE DECAY MODE FOR KAONS IF ( ITYPE .EQ. 10 ) THEN C K(0,L)-MESON IGO = 4 ELSEIF ( ITYPE .EQ. 11 ) THEN C K(+)-MESON IGO = 1 ELSEIF ( ITYPE .EQ. 12 ) THEN C K(-)-MESON IGO = 2 ELSE C K(0,S)-MESON IGO = 3 ENDIF CALL KDECAY( IGO ) RETURN ELSE C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C KAON INTERACTS C CALCULATE GAMMA, BETA AND ENERGY IN CENTER OF MASS ECM = SQRT( CKA(13) * GAMMA + CKA(14) ) GCM = ( PAMA(ITYPE) * GAMMA + PAMA(14) ) / ECM BETACM = SQRT( (GCM-1.D0)*(GCM+1.D0) ) / GCM #if __INTTEST__ C STORE THE GAMMA FACTOR AND BETA FOR BACK TRANSFORMATION C INTO THE PROJECTILE-NUCLEON REST SYSTEM GACM = GCM BECM = BETACM ECMI = ECM IF ( DEBUG ) WRITE(MDEBUG,*) 'NUCINT: GACM,BECM,ECM = ', * SNGL(GACM),BECM,SNGL(ECMI) #endif C LOW ENERGY HADRONIC INTERACTIONS C CHECK IF WE USE LOW ENERGY HADRONIC INTERACTION MODEL IF ( USELOW ) THEN #if __FLUKA__ C USE FLUKA LOW ENERGY HADRONIC INTERACTION MODEL CALL FLULNK ELSE IF ( PAMA(ITYPE)*GAMMA .GT. HILOELB ) THEN C USE HIGH ENERGY HADRONIC INTERACTION MODEL CALL SDPM( 0 ) ELSE CALL FLULNK ENDIF #elif __GHEISHAD__ C USE GHEISHA IF THE CROSS-SECTION HAS BEEN CALCULATED FOR GHEISHA CALL CGHEI ELSE CALL SDPM( 0 ) #elif __URQMD__ C USE URQMD LOW ENERGY HADRONIC INTERACTION MODEL CALL URQLNK ELSE IF ( PAMA(ITYPE)*GAMMA .GT. HILOELB ) THEN C USE HIGH ENERGY HADRONIC INTERACTION MODEL CALL SDPM( 0 ) ELSE CALL URQLNK ENDIF #endif ENDIF ENDIF C----------------------------------------------------------------------- C ETA INCIDENT ELSEIF ( ITYPE .EQ. 17 .OR. * (ITYPE .GE. 71 .AND. ITYPE .LE. 74) ) THEN IF ( DEBUG ) WRITE(MDEBUG,*) 'NUCINT: ETA EKINL=',SNGL(EKINL), * ' ETOT=',ETOT #if __THIN__ IPBIN(KJ) = IPBIN(KJ) + NINT( WEIGHT ) #else IPBIN(KJ) = IPBIN(KJ) + 1 #endif C DECAY OR INTERACTION FOR ETAS ? IF ( FDECAY ) THEN CALL ETADEC ELSE C FOR INTERACTION THE ENERGY MUST BE VERY HIGH C CALCULATE GAMMA, BETA AND ENERGY IN CENTER OF MASS CURPAR(0) = 17.D0 ITYPE = 17 ECM = SQRT( 2.D0 * PAMA(14) * PAMA(17) * GAMMA * + PAMA(14)**2 +PAMA(17)**2 ) GCM = (PAMA(17) * GAMMA + PAMA(14)) / ECM BETACM = SQRT( (GCM-1.D0)*(GCM+1.D0) ) / GCM #if __INTTEST__ C STORE THE GAMMA FACTOR AND BETA FOR BACK TRANSFORMATION C INTO THE PROJECTILE-NUCLEON REST SYSTEM GACM = GCM BECM = BETACM ECMI = ECM IF ( DEBUG ) WRITE(MDEBUG,*) 'NUCINT: GACM,BECM,ECM = ', * SNGL(GACM),BECM,SNGL(ECMI) #endif C HIGH ENERGY INTERACTION MODEL CALL SDPM( 0 ) ENDIF C----------------------------------------------------------------------- C STRANGE BARYON (LAMDA, SIGMA) INCIDENT ELSEIF ( (ITYPE .GE. 18 .AND. ITYPE .LE. 24) .OR. * (ITYPE .GE. 26 .AND. ITYPE .LE. 32) ) THEN IF ( DEBUG ) WRITE(MDEBUG,*) 'NUCINT: SBAR EKINL=',SNGL(EKINL), * ' ETOT=',ETOT #if __THIN__ IHBIN(KJ) = IHBIN(KJ) + NINT( WEIGHT ) #else IHBIN(KJ) = IHBIN(KJ) + 1 #endif C DECAY OR INTERACTION FOR STRANGE BARYONS? IF ( FDECAY ) THEN CALL STRDEC RETURN ENDIF C CALCULATE GAMMA, BETA AND ENERGY IN CENTER OF MASS ECM = SQRT( 2.D0 * PAMA(ITYPE) * PAMA(14) * GAMMA * + PAMA(ITYPE)**2 + PAMA(14)**2 ) GCM = ( PAMA(ITYPE) * GAMMA + PAMA(14)) / ECM BETACM = SQRT( (GCM-1.D0)*(GCM+1.D0) ) / GCM #if __INTTEST__ C STORE THE GAMMA FACTOR AND BETA FOR BACK TRANSFORMATION C INTO THE PROJECTILE-NUCLEON REST SYSTEM GACM = GCM BECM = BETACM ECMI = ECM IF ( DEBUG ) WRITE(MDEBUG,*) 'NUCINT: GACM,BECM,ECM = ', * SNGL(GACM),BECM,SNGL(ECMI) #endif C LOW ENERGY HADRONIC INTERACTIONS C CHECK IF WE USE LOW ENERGY HADRONIC INTERACTION MODEL IF ( USELOW ) THEN #if __FLUKA__ C USE FLUKA LOW ENERGY HADRONIC INTERACTION MODEL CALL FLULNK #elif __GHEISHAD__ C USE GHEISHA IF THE CROSS-SECTION HAS BEEN CALCULATED FOR GHEISHA CALL CGHEI #elif __URQMD__ C USE URQMD LOW ENERGY HADRONIC INTERACTION MODEL CALL URQLNK #endif ELSE #if __DPMJET__ C DPMJET 3 TREATS ALL STRANGE BARYONS CALL SDPM( 0 ) #elif __EPOS__ || __NEXUS__ C EPOS/NEXUS TREATS STRANGE BARYONS CALL SDPM( 0 ) #elif __QGSJET__ C QGSJET CANNOT TREAT STRANGE BARYONS, THEREFORE DECAY CALL STRDEC RETURN #elif __SIBYLL__ C SIBYLL2.3 TREATS STRANGE BARYONS (Oct. 2015) EXCEPT Omega IF ( ITYPE .EQ. 24 .OR. ITYPE .EQ. 32 ) THEN CALL STRDEC RETURN ELSE CALL SDPM( 0 ) ENDIF #elif __VENUS__ C VENUS TREATS STRANGE BARYONS CALL SDPM( 0 ) #else CALL SDPM( 0 ) #endif ENDIF C----------------------------------------------------------------------- C HEAVY PROJECTILE INCIDENT ELSEIF ( ITYPE .GE. 200 ) THEN IF ( DEBUG ) WRITE(MDEBUG,*) 'NUCINT: HEAVY PROJECTILE EKINL=', * SNGL(EKINL),' ETOT=',ETOT #if __INTTEST__ C CALCULATE GCM AND BETACM FOR NUCLEON-NUCLEON COLLISION C STORE THE GAMMA FACTOR AND BETA FOR BACK TRANSFORMATION C INTO THE PROJECTILE-NUCLEON REST SYSTEM GACM = SQRT( GAMMA * 0.5D0 + 0.5D0 ) BECM = SQRT( (GACM-1.D0)*(GACM+1.D0) ) / GACM ECM = PAMA(14) * GACM * 2.D0 ECMI = ECM IF ( DEBUG ) WRITE(MDEBUG,*) 'NUCINT: GACM,BECM,ECM = ', * SNGL(GACM),BECM,SNGL(ECMI) #endif C USE GHEISHA IF THE CROSS-SECTION HAS BEEN CALCULATED FOR GHEISHA C CHECK IF WE USE LOW ENERGY HADRONIC INTERACTION MODEL IF ( USELOW ) THEN #if __FLUKA__ C FLUKA WILL NOT TREAT NUCLEI, C THEREFORE USE SUPERPOSITION IN SDPM CALL SDPM( 0 ) ELSE C USE SDPM AS STEERING ROUTINE IN HIGH ENERGY CASE CALL SDPM( 0 ) #elif __GHEISHAD__ C USE GHEISHA IF THE CROSS-SECTION HAS BEEN CALCULATED FOR GHEISHA C (THIS MIGHT BE THE CASE FOR DEUTERONS, TRITONS AND ALPHAS) IF ( GHESIG ) THEN CALL CGHEI ELSE CALL SDPM( 0 ) ENDIF ELSE CALL SDPM( 0 ) #elif __URQMD__ cdh USE URQMD LOW ENERGY HADRONIC INTERACTION MODEL cdh CALL URQLNK C NEW URQMD LINK (MARCH 2004) WILL NOT TREAT NUCLEI, C THEREFORE USE SUPERPOSITION IN SDPM CALL SDPM( 0 ) ELSE IA = ITYPE/100 IF ( PAMA(ITYPE)*GAMMA .GT. HILOELB*IA ) THEN C USE HIGH ENERGY HADRONIC INTERACTION MODEL CALL SDPM( 0 ) ELSE C IF ENERGY HAS FALLEN BELOW HILOELB BY IONIZATION ENERGY LOSS, C USE URQMD TO TREAT NUCLEUS-NUCLEUS INTERACTION cdh CALL URQLNK C NEW URQMD LINK (MARCH 2004) WILL NOT TREAT NUCLEI, C THEREFORE USE SUPERPOSITION IN SDPM CALL SDPM( 0 ) ENDIF #endif ENDIF #if __NUPRIM__ C----------------------------------------------------------------------- C PRIMARY NEUTRINO INCIDENT ELSEIF ( FIRSTI .AND. ((ITYPE .GE. 66 .AND. ITYPE .LE. 69 ) #if __CHARM__ || __TAULEP__ * .OR. ITYPE .EQ. 133 .OR. ITYPE .EQ. 134 #endif * ) ) THEN C CALCULATE ENERGY BIN FOR ENERGY - MULTIPLICITY MATRIX EKINL = GAMMA ETOT = GAMMA IF ( DEBUG ) WRITE(MDEBUG,*) 'NUCINT: NEUTRINO EKINL=', * SNGL(EKINL),' ETOT=',ETOT IF ( EKINL .GE. .1D0 ) THEN KJ = INT( MIN( 40.D0, 5.D0 + 3.D0*LOG10(EKINL) ) ) ELSE KJ = 1 ENDIF C CALL SDPM TO SELECT TARGET (WHICH FINALLY IS PROTON OR NEUTRON) CALL SDPM( 0 ) #endif #if __CHARM__ C----------------------------------------------------------------------- C CHARMED PARTICLE INCIDENT C TAU LEPTONS ARE NOT COMING HERE, THEY ARE TREATED IN BOX3 ELSEIF ( ITYPE .GE. 116 .AND. ITYPE .LE. 173 ) THEN IF ( DEBUG ) WRITE(MDEBUG,*) 'NUCINT: CHARMED PART. EKINL=', * SNGL(EKINL),' ETOT=',ETOT C CALCULATE GAMMA, BETA AND ENERGY IN CENTER OF MASS GCM = SQRT( GAMMA * 0.5D0 + 0.5D0 ) ECM = PAMA(ITYPE) * GCM * 2.D0 BETACM = SQRT( (GCM-1.D0)*(GCM+1.D0) ) / GCM IF ( FDECAY ) THEN cdh call to PYTDCSET is done at the end of HEPARIN c CALL PYTDCSET ! set charm (and bottom) particles to be stable CALL CHRMDC #if __SIBYLL__ ELSE C LET SHORT LIVED CHARMED MESONS OR BARYONS DECAY INSTEAD OF INTERACTION IF ( ( ITYPE .GE. 122 .AND. ITYPE .LE. 136 ) .OR. * ( ITYPE .GE. 140 .AND. ITYPE .LE. 144 ) .OR. * ( ITYPE .GE. 152 .AND. ITYPE .LE. 156 ) .OR. * ( ITYPE .GT. 158 ) ) THEN c CALL PYTDCSET ! set charm (and bottom) particles to be stable CALL CHRMDC ELSE CALL SDPM( 0 ) ENDIF #endif #if !__SIBYLL__ ELSE IF ( PROPMOD .EQ. 0 ) THEN !only possible for qgsjet01c CALL SDPM( 0 ) ELSE CALL HEPARIN( ETOT ) ENDIF #endif ENDIF #endif #if __CHARM__ && !__SIBYLL__ C----------------------------------------------------------------------- C BOTTOM PARTICLE INCIDENT ELSEIF ( ITYPE .GE. 176 .AND. ITYPE .LE. 195 ) THEN IF ( DEBUG ) WRITE(MDEBUG,*) 'NUCINT: BOTTOM PART. EKINL=', * SNGL(EKINL),' ETOT=',ETOT C CALCULATE GAMMA, BETA AND ENERGY IN CENTER OF MASS GCM = SQRT( GAMMA * 0.5D0 + 0.5D0 ) ECM = PAMA(ITYPE) * GCM * 2.D0 BETACM = SQRT( (GCM-1.D0)*(GCM+1.D0) ) / GCM IF ( FDECAY ) THEN cdh call to PYTDCSET is done at the end of HEPARIN c CALL PYTDCSET ! set charm (and bottom) particles to be stable CALL CHRMDC ELSE IF ( PROPMOD .EQ. 0 ) THEN !only possible for qgsjet01c CALL SDPM( 0 ) ELSE CALL HEPARIN( ETOT ) ENDIF ENDIF #endif C----------------------------------------------------------------------- C ILLEGAL PARTICLE ELSE #if __THIN__ WRITE(MONIOU,444) (CURPAR(I),I=0,9),WEIGHT #else WRITE(MONIOU,444) (CURPAR(I),I=0,9) #endif WRITE(MONIOU,*) 'NUCINT: ILLEGAL PARTICLE = ',ITYPE STOP ENDIF #if !__STACKIN__ && !__CONEX__ C STORE INFORMATIONS ON FIRST INTERACTION IN A TEMPORARY FILE TO BE C WRITTEN IN OUTFILE IF ( FOUTFILE .AND. FIRSTINT ) THEN IF ( PAMA(NINT( PRMPAR(0) )) .NE. 0.D0 ) THEN ENERGY = PRMPAR(1) * PAMA(NINT( PRMPAR(0) )) ELSE ENERGY = PRMPAR(1) ENDIF HEI0 = H NNN = IFINAM REWIND( LSTCK2 ) C - - - - - - - - - - - - - - 510 FORMAT(2I5,1P,4(E16.6)) 511 FORMAT(A1,I6,1P,E18.9,I7,E18.9,A1,I5,A1,3(I11)) C - - - - - - - - - - - - - - IF ( DEBUG ) & WRITE(MONIOU,*)'WRITE ',NNN,' PART FROM FIRST INT IN',FILOUT C HEADER CONTAINES NUMBER OF PARTICLES IN LIST (INT), PRIMARY ENERGY (DBL), C PRIMARY PROJECTILE (INT), HEIGHT OF FIRST INTERACTION (DBL), C TARGET MASS (INT) AND SEED AFTER THE FIRST INTERACTION (3xINT) WRITE(LSTCK,511)' ',NNN,ENERGY,NINT(PRMPAR(0)),HEI0,' ' & ,NINT(TARG1I),' ',ISEED1I 512 READ(LSTCK2,*,END=513)NN,NTYP,EN,PZ,PX,PY WRITE(LSTCK,510)NN,NTYP,EN,PZ,PX,PY GOTO 512 513 CONTINUE cc change pi0 into charged pions c close(lstck) c rewind(lstck2) c IBL = INDEX(FILOUT,' ') c IF ( IBL .LE. 1 ) IBL = LEN(FILOUT)+1 c OPEN(UNIT=LSTCK,FILE=FILOUT(1:IBL-1)//".pion" c & ,STATUS='UNKNOWN',FORM='FORMATTED') c WRITE(LSTCK,511)' ',NNN,ENERGY,NINT(PRMPAR(0)),HEI0,' ' c & ,NINT(TARG1I),' ',ISEED1I c 514 READ(LSTCK2,*,END=515)NN,NTYP,EN,PZ,PX,PY c if(NTYP.EQ.7.or.ntyp.eq.17)then c CALL RMMARD( RD,1,1 ) c NTYP=7+INT(1.5d0+RD(1)) c EN=sqrt(pz*pz+px*px+py*py+PAMA(ntyp)*PAMA(ntyp)) c endif c WRITE(LSTCK,510)NN,NTYP,EN,PZ,PX,PY c GOTO 514 c 515 CONTINUE c close(lstck) cc change all mesons into nucleons c rewind(lstck2) c OPEN(UNIT=LSTCK,FILE=FILOUT(1:IBL-1)//".nucl" c & ,STATUS='UNKNOWN',FORM='FORMATTED') c WRITE(LSTCK,511)' ',NNN,ENERGY,NINT(PRMPAR(0)),HEI0,' ' c & ,NINT(TARG1I),' ',ISEED1I c 516 READ(LSTCK2,*,END=517)NN,NTYP,EN,PZ,PX,PY c if(NTYP.GE.7.and.NTYP.le.12.or.ntyp.eq.16.or.ntyp.eq.17 c & .or.(ntyp.ge.51.and.ntyp.le.53))then c if(ntyp.le.9)then c NTYP=ntyp+6 c elseif(ntyp.le.12)then c NTYP=ntyp+3 c elseif(ntyp.ge.51.and.ntyp.le.53)then c NTYP=ntyp-38 c else c NTYP=13 c endif c EN=sqrt(pz*pz+px*px+py*py+PAMA(ntyp)*PAMA(ntyp)) c endif c WRITE(LSTCK,510)NN,NTYP,EN,PZ,PX,PY c GOTO 516 c 517 CONTINUE CLOSE(LSTCK) C DO NOT WRITE MORE THAN ONE OUTPUT FILE FOR THE PARTICLES OF THE C FIRST INTERACTION COMING FROM THE SECOND OR FURTHER SHOWERS FOUTFILE = .FALSE. ENDIF #endif C----------------------------------------------------------------------- C KILL PARTICLE IRET1 = 1 RETURN END *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE OUTEND C----------------------------------------------------------------------- C OUT(PUT AT) END (OF SHOWER) C C WRITE REST OF PARTICLES TO OUTPUT BUFFER. C PRINTS INTERACTION LENGTHS STATISTICS. C THIS SUBROUTINE IS CALLED FROM AAMAIN. C----------------------------------------------------------------------- IMPLICIT NONE #define __BUFFSINC__ #define __CHISTAINC__ #define __ELADPMINC__ #define __MULTINC__ #define __NPARTIINC__ #define __PARPARINC__ #define __PARPAEINC__ #define __RECORDINC__ #define __RUNPARINC__ #define __STACKFINC__ #define __STATIINC__ #if __THIN__ #define __WGHTMAINC__ #endif #include "corsika.h" INTEGER I #if !__INTTEST__ INTEGER J,K,NELMEA #endif SAVE C----------------------------------------------------------------------- IF ( LH .GT. 0 ) THEN #if __COMPACT__ IF ( COMOUT ) THEN IF ( FPAROUT ) CALL TOBUFS( DATAB,LH ) ELSE CALL TOBUF( DATAB,0 ) ENDIF #else IF ( FPAROUT ) CALL TOBUF( DATAB,0 ) #endif #if __CERENKOV__ && __IACT__ && __IACTEXT__ IF ( FPAROUT ) CALL TELPRT( DATAB, MAXBUF ) #endif DO I = 1, MAXBUF DATAB(I) = 0. ENDDO ENDIF LH = 0 IF ( FPRINT .OR. DEBUG ) THEN WRITE(MONIOU,101) NOURECMAX,NSHIFT 101 FORMAT(' ',I11,' BLOCKS MAXIMUM STACK FILE SIZE',/, * ' ',I11,' SHIFTS TO EXTERNAL STACK') IF ( NOPART .GE. 0 ) THEN WRITE(MONIOU,'(I12,'' PARTICLES WRITTEN TO MPATAP'')') NOPART ELSE WRITE(MONIOU,'(F10.0,''E3 PARTICLES WRITTEN TO MPATAP'')') * 39.D-3 * (-4.D0 + NBLKS) ENDIF #if __CERENKOV__ WRITE(MONIOU,103) NOCERB 103 FORMAT(' ',I11,' CHERENKOV BUNCHES WRITTEN TO MCETAB') #endif #if __PARALLEL__ IF ( DSNCUT(1:4) .NE. 'NONE' ) THEN WRITE(MONIOU,102) NTOC 102 FORMAT(' ',I11,' WRITTEN TO MPACUT') ENDIF #endif ENDIF #if !__INTTEST__ IF ( FPRINT ) THEN C PRINT ENERGY - MULTIPLICITY MATRIX WRITE(MONIOU,209) ISHOWNO,(K,K=1,13), * (J,(MULTMA(J,K),K=1,13),10**((J-4.)/3.),10**((J-3.)/3.),J=1,39), * 1,(INT(10**((K-1.)/3.)+1 ),K = 2,13), * 2,(INT(10**((K )/3.) ),K = 2,13) 209 FORMAT(/,/,' ENERGY - MULTIPLICITY MATRIX OF SHOWER NO ',I10,/, * ' ENERGY RUNS VERTICALLY, MULTIPLICITY HORIZONTALLY',/, * /,' ',4X,5I10,3I8,5I6,' ENERGY RANGE (GEV)',/, * 39(/,' ',I3,1X,5I10,3I8,5I6,1X,1P,2E10.1,0P),/,/, * ' MULT.',I9,4I10,3I8,5I6,4X,'LOWER BIN LIMIT',/, * ' RANGE',I9,4I10,3I8,5I6,4X,'UPPER BIN LIMIT') ENDIF #if __THIN__ IF ( FPRINT ) THEN C PRINT ENERGY - WEIGHT MATRIX WRITE(MONIOU,229) ISHOWNO,(K,K=1,15), * (J,(MWGHMA(J,K),K=1,15), * 10**((J-10.)/3.),10**((J-9.)/3.),J=1,45), * 1,(INT(10**((K-1.)/3.)+1 ),K = 2,15), * 2,(INT(10**((K )/3.) ),K = 2,15) 229 FORMAT(/,/,' ENERGY - WEIGHT MATRIX OF SHOWER NO ',I10,/, * ' KIN. ENERGY RUNS VERTICALLY, WEIGHT HORIZONTALLY',/,/ * ,' ',4X,5I7,5I7,5I7,' ENERGY RANGE (GEV)',/, * 45(/,' ',I4, 5I7,5I7,5I7,2X,1P,2E10.1,0P),/,/, * ' WGHT.',I6,5I7,4I7,5I7,5X,'LOWER BIN LIMIT',/, * ' RANGE',I6,5I7,4I7,5I7,5X,'UPPER BIN LIMIT') ENDIF #endif C GET MEAN OF ELASTICITY FOR ENERGY BINS DO J = 1, 40 NELMEA = 0 DO K = 1, 10 NELMEA = NELMEA + IELDPM(J,K) ENDDO IF ( NELMEA .NE. 0 ) ELMEAN(J) = ELMEAN(J) / NELMEA ENDDO IF ( FPRINT ) THEN C PRINT ENERGY - ELASTICITY MATRIX WRITE(MONIOU,408) ISHOWNO,(K,K=1,10), * (J,(IELDPM(J,K),K=1,10), * ELMEAN(J),10**((J-4.)/3.),10**((J-3.)/3.),J=1,39), * ((K-1)*0.1,K=1,10),(K*0.1,K=1,10) 408 FORMAT(/,/,' ENERGY - ELASTICITY MATRIX OF SHOWER NO ',I10,/, * ' ENERGY RUNS VERTICALLY, ELASTICITY HORIZONTALLY',/,/, * ' ',5X,8I9,2I10,' MEAN EL. ENERGY RANGE (GEV)',/, * 39(/,' ',I4,1X,8I9,2I10,2X,1P,E10.3,2E10.1,0P),/,/, * ' ELA. ',8F9.2,2F10.2,5X,'LOWER BIN LIMIT',/, * ' RANGE',8F9.2,2F10.2,5X,'UPPER BIN LIMIT') WRITE(MONIOU,204) ISHOWNO 204 FORMAT(/,/,' INTERACTIONS PER KINETIC ENERGY INTERVAL OF SHOWER' * ,' NO ',I10,/,/) WRITE(MONIOU,205) 205 FORMAT(' BIN LOWER LIMIT UPPER LIMIT ', * ' NUCLEON PIONS KAONS S.BARYONS TOTAL',/ * ,' IN GEV IN GEV ', * ' EVENTS EVENTS EVENTS EVENTS ',/) WRITE(MONIOU,207) (I,SABIN(I),SBBIN(I),INBIN(I),IPBIN(I), * IKBIN(I),IHBIN(I),INBIN(I)+IPBIN(I)+IKBIN(I)+IHBIN(I),I=1,40) 207 FORMAT(' ',I5,1P,2E15.4,0P,1X,5I11) #if __NUPRIM__ WRITE(MONIOU,301) 301 FORMAT(/,/,' INTERACTION LENGTH STATISTICS: ', * ' 1 BIN CORRESPONDS TO 10 G/CM**2 OR 100M FOR MUONS',/,/ * ' BIN LAMBDA NU LAMBDA PI LAMBDA KA ', * 'LAMBDA HY LAMBDA MU LAMBDA NUCLEUS', * ' LAMBDA NEUTRINOS',/) WRITE(MONIOU,303) (I,INUCHI(I),IPICHI(I),IKACHI(I),IHYCHI(I), * IMUCHI(I),INNCHI(I),INECHI(I),I=1,124) 303 FORMAT(' ',I4,6I12,I15) #else WRITE(MONIOU,301) 301 FORMAT(/,/,' INTERACTION LENGTH STATISTICS: ', * ' 1 BIN CORRESPONDS TO 10 G/CM**2 OR 100M FOR MUONS',/,/, * ' BIN LAMBDA NU LAMBDA PI LAMBDA KA ', * 'LAMBDA HY LAMBDA MU LAMBDA NUCLEUS',/) WRITE(MONIOU,303) (I,INUCHI(I),IPICHI(I),IKACHI(I),IHYCHI(I), * IMUCHI(I),INNCHI(I),I=1,124) 303 FORMAT(' ',I4,6I12) #endif WRITE(MONIOU,105) IRECOR 105 FORMAT(/,' WORDS WRITTEN TO PARTICLE DATA FILE UP TO NOW =', * I12) ENDIF #endif RETURN END *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE OUTPT1 C----------------------------------------------------------------------- C (WRITE PARTICLE) OUTP(U)T 1 C C WRITES 39 PARTICLE RECORDS PER PHYSICAL RECORD C TABULATES PARAMETERS OF ALL HIGH ENERGY PARTICLES WITH C LORENTZ FACTOR LARGER THAN ECTMAP. C THIS SUBROUTINE IS CALLED FROM AAMAIN, BOX3, MUTRAC, UPDATC, C AND AUSGAB. C----------------------------------------------------------------------- IMPLICIT NONE #define __BUFFSINC__ #define __ETHMAPINC__ #define __LONGIINC__ #define __MAGANGINC__ #define __MULTINC__ #define __MUPARTINC__ #define __NPARTIINC__ #define __OBSPARINC__ #define __PAMINC__ #define __PARPARINC__ #define __PARPAEINC__ #define __RUNPARINC__ #define __TABLESINC__ #if __AUGERHIT__ #define __AUGDETINC__ #endif #if __THIN__ #define __RANDPAINC__ #define __WGHTMAINC__ #endif #if __MULTITHIN__ #define __MULTHININC__ #endif #if __THIN__ || __MULTITHIN__ #define __THNVARINC__ #endif #include "corsika.h" DOUBLE PRECISION AUGM,AUGM2,ETOT,FAC1,FAC2,PHIMU,PHIPAR,PTOT,RR2, * STT,XADDMU,YADDMU REAL EEE,TT,RR,TF INTEGER IIE,IIT,IID INTEGER I,IGG,III,NCOUNT LOGICAL ROUT #if __CURVED__ DOUBLE PRECISION COSTHPRPR #endif #if __EHISTORY__ INTEGER II2,IK #endif #if __THIN__ DOUBLE PRECISION EKIN,PROBTH INTEGER MEN,MMU #endif #if __AUGERHIT__ || __MULTITHIN__ INTEGER ICODE #endif #if __AUGERHIT__ DOUBLE PRECISION RRDET INTEGER ICORPOS LOGICAL TANKSHADOW EXTERNAL TANKSHADOW #endif SAVE DATA NCOUNT / 0 /, AUGM / 1.D0 /, AUGM2 / 1.D0 / C----------------------------------------------------------------------- #if __THIN__ IF ( DEBUG ) WRITE(MDEBUG,444) (OUTPAR(I),I=0,9),OUTPAR(13),LEVL 444 FORMAT(' OUTPT1: OUTPAR=',1P,9E11.3,0P,F13.0,1P,E10.3,I5) #else IF ( DEBUG ) WRITE(MDEBUG,444) (OUTPAR(I),I=0,9),LEVL 444 FORMAT(' OUTPT1: OUTPAR=',1P,9E11.3,0P,F13.0,I5) #endif #if __EHISTORY__ IF ( DEBUG ) WRITE(MDEBUG,1445) (OUTPAR(I),I=17,27) 1445 FORMAT(' OUTPT1: 17-27: ',1P,11E11.3) IF ( DEBUG ) WRITE(MDEBUG,1446) (OUTPAR(I),I=28,38) 1446 FORMAT(' OUTPT1: 28-38: ',1P,11E11.3) #endif #if __MULTITHIN__ OUTPAR(40) = 8888000.D0 IF ( DEBUG ) WRITE(MDEBUG,1447) (OUTPAR(I),I=40,46) 1447 FORMAT(' OUTPT1: 40-46: ',1P,7E11.3) #endif #if !__CURVED__ C CORRECT X,Y COORDINATES FOR EACH LEVEL OUTPAR(7) = OUTPAR(7) - XOFF(LEVL) OUTPAR(8) = OUTPAR(8) - YOFF(LEVL) #else IF ( .NOT. FFLATOUT ) THEN C PROPAGATE PARTICLE UNTIL SPHERICAL GROUND SO X AND Y ARE CORRECTED C TO BE DEFINED AT OBSERVATION LEVEL INSTEAD OF SEA LEVEL C (CORRXY = ( C(1) + OBSLEV(1) ) / C(1)) OUTPAR(7) = OUTPAR(7) * CORRXY OUTPAR(8) = OUTPAR(8) * CORRXY ENDIF #endif #if __AUGERHIST__ C FILL PARTICLE INTO AUGER HISTO''S CALL AUGERHISTFIL C ONLY CHARGED PARTICLES PRODUCE IONIZATION ENERGY LOSS IF ( SIGNUM(NINT( OUTPAR(0) )) .NE. 0.D0 ) THEN C TRACK CHARGED PARTICLES TO PRODUCE CHERENKOV PHOTONS CALL AUGCERTRACK ENDIF C WRITE PARTICLE TO PARTICLE OUTPUT ONLY FOR LOWEST OBSERV. LEVEL IF ( LEVL .NE. NOBSLV ) RETURN #endif #if __ANAHIST__ C FILL PARTICLE INTO ANAHISTO ONLY FOR ONE LEVEL, WHICH MUST BE LOWEST IF ( LEVL .EQ. NOBSLV ) CALL ANAHISTFIL #endif C PRINT OUT PARTICLE IF IT IS ABOVE THE CUT IF ( FPRINT .OR. DEBUG .OR. DEBDEL ) THEN IF ( OUTPAR(1) .GE. ECTMAP ) THEN #if __THIN__ WRITE(MONIOU,3) (OUTPAR(I),I=0,9),OUTPAR(13),OUTPAR(10),ELEFT #if __PARALLEL__ & ,ELEFTJ 3 FORMAT(' OUTPT1: ',1P,9E11.3,0P,F12.0,1P,4E10.3) #else 3 FORMAT(' OUTPT1: ',1P,9E11.3,0P,F12.0,1P,3E10.3) #endif #else WRITE(MONIOU,3) (OUTPAR(I),I=0,10),ELEFT #if __PARALLEL__ & ,ELEFTJ 3 FORMAT(' OUTPT1: ',1P,9E11.3,0P,F12.0,1P,3E10.3) #else 3 FORMAT(' OUTPT1: ',1P,9E11.3,0P,F12.0,1P,2E10.3) #endif #if __MULTITHIN__ IF ( NMTHIN .GT. 0 ) THEN OUTPAR(40) = 8888000.D0 WRITE(MONIOU,31) (OUTPAR(I),I=40,46) 31 FORMAT(' OUTPT1: 40-46: ',1P,7E11.3) ENDIF #endif #endif IF ( DEBDEL ) THEN NCOUNT = NCOUNT + 1 WRITE(MDEBUG,*) 'OUTPT1: NCOUNT = ',NCOUNT IF ( NCOUNT .GE. NDEBDL ) DEBUG = .TRUE. IF ( NCOUNT .GE. NDEBDL+2 ) DEBUG = .FALSE. ENDIF ENDIF ENDIF III = NINT( OUTPAR(0) ) IF ( III .GE. 71 .AND. III .LE. 74 ) III = 17 #if __THIN__ C SET INCREMENT FOR COUNTERS AUGM = OUTPAR(13) #endif C COUNT PARTICLES SPECIFIED BY THEIR PARTICLE CODE < 25 IF ( III .LT. 18 ) THEN NPARTO(LEVL,III) = NPARTO(LEVL,III) + AUGM ELSEIF ( III .EQ. 25 ) THEN NNEUTB(LEVL) = NNEUTB(LEVL) + AUGM ELSEIF ( (III .GE. 18 .AND. III .LE. 24) .OR. * (III .GE. 26 .AND. III .LE. 32) ) THEN NHYP(LEVL) = NHYP(LEVL) + AUGM #if __CHARM__ ELSEIF ( III .GE. 116 .AND. III .LE. 128 ) THEN NCHRMM(LEVL) = NCHRMM(LEVL) + AUGM ELSEIF ( III .GE. 137 .AND. III .LE. 173 ) THEN NCHRMB(LEVL) = NCHRMB(LEVL) + AUGM #endif ELSEIF ( III .EQ. 201 ) THEN NDEUT(LEVL) = NDEUT(LEVL) + AUGM ELSEIF ( III .EQ. 301 ) THEN NTRIT(LEVL) = NTRIT(LEVL) + AUGM ELSEIF ( III .EQ. 302 ) THEN NHELI3(LEVL) = NHELI3(LEVL) + AUGM ELSEIF ( III .EQ. 402 ) THEN NALPHA(LEVL) = NALPHA(LEVL) + AUGM #if __NEUTRINO__ || __NUPRIM__ ELSEIF ( ( III .GE. 66 .AND. III .LE. 69 ) #if __CHARM__ || __TAULEP__ * .OR. III .EQ. 133 .OR. III .EQ. 134 #endif * ) THEN NPARTO(LEVL,4) = NPARTO(LEVL,4) + AUGM #endif ELSE WRITE(MONIOU,*) 'OUTPT1: PARTICLE ON OBSLEV ',LEVL, * ' ID= ',III NOTHER(LEVL) = NOTHER(LEVL) + AUGM ENDIF IF ( LLONGI .AND. LEVL .EQ. NOBSLV ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT IN LAST BIN NSTEP #if __UPWARD__ IF ( PRMPAR(15) .GT. 0.D0 ) THEN LHEIGH = NSTEP ELSEIF ( PRMPAR(15) .LE. 0.D0 ) THEN #if __SLANT__ LHEIGH = NSTEP #else LHEIGH = MAX( 0, INT( THCKOB(1)*THSTPI ) ) #endif ENDIF #else LHEIGH = NSTEP #endif IF ( III .EQ. 1 ) THEN DLONG(LHEIGH,1) = DLONG(LHEIGH,1) + OUTPAR(1) * AUGM ELSEIF ( III .EQ. 2 ) THEN C REMEMBER: FOR EM-PARTICLES OUTPAR(2) CONTAINS ENERGY IN GEV DLONG(LHEIGH,3) = DLONG(LHEIGH,3) + (OUTPAR(1)+PAMA(2))*AUGM ELSEIF ( III .EQ. 3 ) THEN DLONG(LHEIGH,3) = DLONG(LHEIGH,3) + (OUTPAR(1)-PAMA(2))*AUGM ELSEIF ( III .EQ. 5 .OR. III .EQ. 6 ) THEN DLONG(LHEIGH,5) = DLONG(LHEIGH,5) * + OUTPAR(1)*PAMA(5)*AUGM ELSEIF ( III .EQ. 13 .OR. III .EQ. 14 ) THEN DLONG(LHEIGH,7) = DLONG(LHEIGH,7) * + (OUTPAR(1)-1.D0)*PAMA(III)*AUGM ELSEIF ( III .EQ. 15 .OR. III .EQ. 25 ) THEN DLONG(LHEIGH,7) = DLONG(LHEIGH,7) * + (OUTPAR(1)+1.D0)*PAMA(III)*AUGM #if __NEUTRINO__ || __NUPRIM__ ELSEIF ( ( III .GE. 66 .AND. III .LE. 69 ) #if __CHARM__ || __TAULEP__ * .OR. III .EQ. 133 .OR. III .EQ. 134 #endif * ) THEN DLONG(LHEIGH,8) = DLONG(LHEIGH,8) + OUTPAR(1) * AUGM #endif ELSE IF ( III .EQ. 8 .OR. III .EQ. 9 .OR. * III .EQ. 11 .OR. III .EQ. 12 ) THEN FAC1 = 0.25D0 FAC2 = 0.75D0 ELSEIF ( III .EQ. 10 .OR. III .EQ. 16 ) THEN FAC1 = 0.5D0 FAC2 = 0.5D0 ELSE FAC1 = 1.D0 FAC2 = 0.D0 ENDIF C ADD TO THE HADRON ENERGY DEPOSIT DLONG(LHEIGH,7) = DLONG(LHEIGH,7) + (OUTPAR(1)*PAMA(III) * - RESTMS(III)) * AUGM * FAC1 C ADD TO THE NEUTRINO DEPOSIT DLONG(LHEIGH,8) = DLONG(LHEIGH,8) + (OUTPAR(1)*PAMA(III) * - RESTMS(III)) * AUGM * FAC2 ENDIF ENDIF #if __AUGERHIT__ C SUPPRESS ALL PARTICLES CLOSE TO SHOWER CORE (RRDET < RCUT**2) C BECAUSE OF SATURATION. RCUT IS GIVEN IN CM !! RRDET = OUTPAR(7)**2 + OUTPAR(8)**2 IF ( RRDET .LT. RCUT**2 ) RETURN C CHECK WHETHER PARTICLE HITS AUGER DETECTOR HEXAGON CALL AUGERPARTIC( ICORPOS ) C SKIP PARTICLE WHICH FALLS OUTSIDE DETECTOR HEXAGON IF ( ICORPOS .EQ. 0 ) RETURN C CHECK, WHETHER PARTICLE HITS THE TANK SHADOW ICODE = 0 C ICODE > 100: PARTICLE HITS SHADOW C THE LOWEST TWO DIGITS OF ICODE GIVE BINARY CODING OF THINNG MODES C WHICH PARTICLE SURVIVES IF ( FTANKSHADW ) THEN C KEEP PARTICLE IF TANKSHADOW IS HIT IF ( TANKSHADOW(XTEST,YTEST, * OUTPAR(3),OUTPAR(4),OUTPAR(2)) ) THEN ICODE = ICODE + 100 ENDIF ENDIF #if __MULTITHIN__ C CHECK WHETHER PARTICLE SURVIVES IN ANY THINNING MODE IF ( FANYMODE ) THEN DO I = 1, 6 IF ( OUTPAR(40+I) .GT. 0.D0 ) THEN ICODE = ICODE + 2**(I-1) ENDIF ENDDO ENDIF #endif C PARTICLE DID NOT HIT TANK SHADOW (OR DID NOT SURVIVE THINNING), C SKIP IT IF ( ICODE .LE. 0 ) RETURN #endif ROUT = .TRUE. RR2 = OUTPAR(7)**2 + OUTPAR(8)**2 #if __MUPROD__ C DO NOT PERFORM RADIAL CUTTING FOR MUONS WITH ADDITIONAL INFO IF ( .NOT. (FMUADD .AND. (III .EQ. 5 .OR. III .EQ. 6)) ) THEN #endif C DISCARD PARTICLES BY CORECUT WITHIN RADIUS < RMAX IF ( RR2 .LT. RCUT2 ) ROUT = .FALSE. #if __MUPROD__ ENDIF #endif #if __THIN__ PROBTH = 1.D0 #if __MUPROD__ C DO NOT PERFORM RADIAL THINNING FOR MUONS WITH ADDITIONAL INFO IF ( .NOT. (FMUADD .AND. (III .EQ. 5 .OR. III .EQ. 6)) ) THEN #endif C DO RADIAL THIN-OUT OF OUTPUT PARTICLES (ACC. S. SCIUTTO) C (ONLY WRITING TO FILE IS AFFECTED, ALL TABLES ARE NOT.) IF ( RLIM ) THEN IF ( RR2 .LT. RMAX2 ) THEN CALL RMMARD( RD,1,1 ) * PROBTH = RR2/RMAX2 PROBTH = (RR2/RMAX2)**2 IF ( RD(1) .GT. PROBTH ) THEN ROUT = .FALSE. ENDIF ENDIF ENDIF #if __MUPROD__ ENDIF #endif #endif C TREAT ADDITIONAL INFORMATION OF MUONS C THE COORDINATES OF MUON ORIGIN ARE STORED IN AMUPAR(.) IF ( ROUT ) THEN IF ( FMUADD .AND. (III .EQ. 5 .OR. III .EQ. 6) ) THEN C LIMIT GENERATION COUNTER TO 99 * IGG = MIN( OUTPAR(9), 99.D0 ) * DATAB(LH+1) = (III + 70) * 1000 + IGG*10 + MOD(LEVL,10) C LIMIT GENERATION COUNTER TO 999 C NORMAL HADRONIC GENERATION COUNTER BELOW 1000 IGG = MOD( OUTPAR(9), 1000.D0 ) C IF PHOTONUCLEAR INTERACTION OR MUON PAIR PRODUCTION IN MUON HISTORY IF ( OUTPAR(9) .GT. 1D8 ) IGG = IGG + 500 IGG = MIN( IGG , 999) DATAB(LH+1) = (III + 70) * 1000 + IGG PTOT = PAMA(III) * SQRT( (AMUPAR(1)-1.D0)*(AMUPAR(1)+1.D0) ) #if __CURVED__ C DETERMINE ANGLE THETAPRPR IN DETECTOR SYSTEM FROM LOCAL ANGLE THETA C AND ANGLE THETA_E (AT CENTER OF EARTH) SEE FZKA 6954 FIG. 3 C THETPRPR = THETA + THETA_E C USE THE ADDITION RULES FOR COSINE(THETA + THETA_E) COSTHPRPR = AMUPAR(2) * AMUPAR(16) * - SQRT( (1.D0+AMUPAR(2))*(1.D0-AMUPAR(2)) * * (1.D0+AMUPAR(16))*(1.D0-AMUPAR(16)) ) DATAB(LH+4) = PTOT * COSTHPRPR XADDMU = AMUPAR(7) YADDMU = AMUPAR(8) STT = SQRT( (1.D0-COSTHPRPR) * (1.D0+COSTHPRPR) ) #else DATAB(LH+4) = PTOT * AMUPAR(2) XADDMU = AMUPAR(7) - XOFF(LEVL) YADDMU = AMUPAR(8) - YOFF(LEVL) STT = SQRT( (1.D0-AMUPAR(2))*(1.D0+AMUPAR(2)) ) #endif IF ( AMUPAR(4) .NE. 0.D0 .OR. AMUPAR(3) .NE. 0.D0 ) THEN PHIMU = ATAN2( AMUPAR(4), AMUPAR(3) ) ELSE PHIMU = 0.D0 ENDIF DATAB(LH+2) = PTOT * STT * COS( PHIMU - ARRANR ) DATAB(LH+3) = PTOT * STT * SIN( PHIMU - ARRANR ) DATAB(LH+5) = XADDMU * COSANG + YADDMU * SINANG DATAB(LH+6) = YADDMU * COSANG - XADDMU * SINANG DATAB(LH+7) = AMUPAR(5) #if __THIN__ DATAB(LH+8) = AMUPAR(13) / MAX(1.D-10,PROBTH) IF ( DEBUG ) WRITE(MDEBUG,445) (DATAB(LH+I),I=1,8) 445 FORMAT(' OUTPT1: MUADDI=',1P,8E11.3) LH = LH + 8 #else IF ( DEBUG ) WRITE(MDEBUG,445) (DATAB(LH+I),I=1,7) 445 FORMAT(' OUTPT1: MUADDI=',1P,7E11.3) LH = LH + 7 #endif C WRITE A BLOCK OF 39 PARTICLES TO OUTPUT BUFFER AND CLEAR FIELD IF ( LH .GE. MAXBUF ) THEN #if __COMPACT__ IF ( COMOUT ) THEN IF ( FPAROUT ) CALL TOBUFS( DATAB, MAXBUF ) ELSE IF ( FPAROUT ) CALL TOBUF( DATAB,0 ) ENDIF #else IF ( FPAROUT ) CALL TOBUF( DATAB,0 ) #endif #if __CERENKOV__ && __IACT__ && __IACTEXT__ IF ( FPAROUT ) CALL TELPRT( DATAB, MAXBUF ) #endif DO I = 1, MAXBUF DATAB(I) = 0. ENDDO LH = 0 ENDIF #if __EHISTORY__ C ADD MOTHER PARTICLE INFORMATION IK = 16 #if __PARALLEL__ C WITH PARALLEL SOME MOTHERS ARE LOST IF ( AMUPAR(IK+2) .EQ. -1.D0 ) THEN DO I = 1, 7 DATAB(LH+I) = 0. ENDDO ELSE #endif II2 = NINT(OUTPAR(IK+1)) IGG = MOD( AMUPAR(35), 1000D0 ) C IF PHOTONUCLEAR INTERACTION OR MUON PAIR PRODUCTION IN MOTHER HISTORY IF ( AMUPAR(35) .GT. 1D8 ) IGG = IGG + 500 IGG = MIN( IGG , 999) DATAB(LH+1) = -II2*1000 - IGG ! HAD. GENCOUNT OF MOTHER IF ( II2 .EQ. 0 ) THEN WRITE(MONIOU,*) 'FIRST PARTICLE? ',II2, * ' AT SHOWER NR. ',ISHOWNO ELSE IF ( PAMA(II2) .GT. 0.D0 ) THEN IF ( AMUPAR(IK+2) .GT. 1.D0 ) THEN PTOT = PAMA(II2) * SQRT( (AMUPAR(IK+2) - 1.D0) * *(AMUPAR(IK+2) + 1.D0) ) ELSE WRITE(MONIOU,*) 'ERROR: MOTHER GAMMA < 1', * AMUPAR(IK+2) GOTO 101 ENDIF ELSE C PARTICLE WITH ZERO MASS PTOT = AMUPAR(IK+2) ENDIF STT = SQRT( (1.D0-AMUPAR(IK+3))*(1.D0+AMUPAR(IK+3)) ) IF ( AMUPAR(21) .NE. 0.D0 .OR. AMUPAR(20) .NE. 0.D0 ) THEN PHIPAR = ATAN2( AMUPAR(IK+5), AMUPAR(IK+4) ) ELSE PHIPAR = 0.D0 ENDIF DATAB(LH+2) = PTOT * STT * COS( PHIPAR - ARRANR ) ! Px DATAB(LH+3) = PTOT * STT * SIN( PHIPAR - ARRANR ) ! Py DATAB(LH+4) = PTOT * AMUPAR(IK+3) ! Pz XADDMU = AMUPAR(IK+8) - XOFF(LEVL) YADDMU = AMUPAR(IK+9) - YOFF(LEVL) DATAB(LH+5) = XADDMU * COSANG + YADDMU * SINANG !x DATAB(LH+6) = YADDMU * COSANG - XADDMU * SINANG !y DATAB(LH+7) = AMUPAR(IK+6) !z ENDIF #if __PARALLEL__ ENDIF #endif #if __THIN__ DATAB(LH+8) = 0. IF ( DEBUG ) WRITE(MDEBUG,445) (DATAB(LH+I),I=1,8) LH = LH + 8 #else IF ( DEBUG ) WRITE(MDEBUG,445) (DATAB(LH+I),I=1,7) LH = LH + 7 #endif C WRITE A BLOCK OF 39 PARTICLES TO OUTPUT BUFFER AND CLEAR FIELD IF ( LH .GE. MAXBUF ) THEN #if __COMPACT__ IF ( COMOUT ) THEN IF ( FPAROUT ) CALL TOBUFS( DATAB, MAXBUF ) ELSE IF ( FPAROUT ) CALL TOBUF( DATAB,0 ) ENDIF #else IF ( FPAROUT ) CALL TOBUF( DATAB,0 ) #endif #if __CERENKOV__ && __IACT__ && __IACTEXT__ IF ( FPAROUT ) CALL TELPRT( DATAB, MAXBUF ) #endif DO I = 1, MAXBUF DATAB(I) = 0. ENDDO LH = 0 ENDIF 101 CONTINUE C ADD GRANDMOTHER PARTICLE INFORMATION IK = 27 #if __PARALLEL__ C WITH PARALLEL SOME GRANDMOTHERS ARE LOST IF ( AMUPAR(IK+2) .EQ. -1.D0 .OR. AMUPAR(18) .EQ. -1.D0) THEN DO I = 1, 7 DATAB(LH+I) = 0. ENDDO ELSE #endif II2 = NINT(OUTPAR(IK+1)) IGG = MOD( AMUPAR(35), 1D8 ) IGG = IGG / 1000 !EM GEN COUNTER ONLY IGG = MIN(NINT(LOG(MOD(DBLE( IGG ),1.D3)+1.D0)),9) * 100 * + IGG / 1000 !LOG OF THE NUMBER ELECTRON INTERACTIONS * 100 + NUMBER OF PHOTON INTERACTIONS OF MOTHER IGG = MIN( IGG , 999) DATAB(LH+1) = -II2*1000 - IGG ! EM GENCOUNT OF MOTHER IF ( II2 .EQ. 0 ) THEN WRITE(MONIOU,*) 'FIRST PARTICLE GRANDMA ',II2, * ' AT SHOWER NR. ',ISHOWNO ELSE IF ( PAMA(II2) .GT. 0.D0 ) THEN IF ( AMUPAR(IK+2) .GT. 1.D0 ) THEN PTOT = PAMA(II2) * SQRT( (AMUPAR(IK+2) - 1.D0) * *(AMUPAR(IK+2) + 1.D0) ) ELSE WRITE(MONIOU,*) 'ERROR: GRANDMA GAMMA < 1', * AMUPAR(IK+2) GOTO 102 ENDIF ELSE C PARTICLE WITH ZERO MASS PTOT = AMUPAR(IK+2) ENDIF STT = SQRT( (1.D0-AMUPAR(IK+3))*(1.D0+AMUPAR(IK+3)) ) IF ( AMUPAR(32) .NE. 0.D0 .OR. AMUPAR(31) .NE. 0.D0 ) THEN PHIPAR = ATAN2( AMUPAR(IK+5), AMUPAR(IK+4) ) ELSE PHIPAR = 0.D0 ENDIF DATAB(LH+2) = PTOT * STT * COS( PHIPAR - ARRANR ) ! Px DATAB(LH+3) = PTOT * STT * SIN( PHIPAR - ARRANR ) ! Py DATAB(LH+4) = PTOT * AMUPAR(IK+3) ! Pz C FINAL COMPLETE GENERATION COUNTER OF PARTICLE DATAB(LH+5) = NINT( OUTPAR(9) ) / 100 ! GenCount DATAB(LH+6) = AMUPAR(IK+9) ! chi DATAB(LH+7) = -AMUPAR(IK+6) ! negative h ENDIF #if __PARALLEL__ ENDIF #endif #if __THIN__ DATAB(LH+8) = AMUPAR(IK+10) IF ( DEBUG ) WRITE(MDEBUG,445) (DATAB(LH+I),I=1,8) LH = LH + 8 #else IF ( DEBUG ) WRITE(MDEBUG,445) (DATAB(LH+I),I=1,7) LH = LH + 7 #endif C WRITE A BLOCK OF 39 PARTICLES TO OUTPUT BUFFER AND CLEAR FIELD IF ( LH .GE. MAXBUF ) THEN #if __COMPACT__ IF ( COMOUT ) THEN IF ( FPAROUT ) CALL TOBUFS( DATAB, MAXBUF ) ELSE IF ( FPAROUT ) CALL TOBUF( DATAB,0 ) ENDIF #else IF ( FPAROUT ) CALL TOBUF( DATAB,0 ) #endif #if __CERENKOV__ && __IACT__ && __IACTEXT__ IF ( FPAROUT ) CALL TELPRT( DATAB, MAXBUF ) #endif DO I = 1, MAXBUF DATAB(I) = 0. ENDDO LH = 0 ENDIF 102 CONTINUE #endif ENDIF #if __EHISTORY__ IF ( ( FEMADD .AND. III .LE. 3 ) .OR. * ( FNUADD .AND. (III .GE. 66 .AND. III .LE. 69) ) ) THEN C ADD MOTHER PARTICLE INFORMATION FOR EM-PARTICLES OR FOR NEUTRINOS IK = 16 #if __PARALLEL__ C WITH PARALLEL SOME MOTHERS ARE LOST IF ( OUTPAR(IK+2) .EQ. -1.D0 ) THEN DO I = 1, 7 DATAB(LH+I) = 0. ENDDO ELSE #endif II2 = NINT(OUTPAR(IK+1)) IGG = MOD( OUTPAR(35), 1000D0 ) C IF PHOTONUCLEAR INTERACTION OR MUON PAIR PRODUCTION IN MOTHER HISTORY IF ( OUTPAR(35) .GT. 1D8 ) IGG = IGG + 500 IGG = MIN( IGG , 999) DATAB(LH+1) = -II2*1000 - IGG ! HAD. GENCOUNT OF MOTHER IF ( II2 .EQ. 0 ) THEN WRITE(MONIOU,*) 'FIRST PARTICLE?',II2 ELSE IF ( PAMA(II2) .GT. 0.D0 ) THEN IF ( OUTPAR(IK+2) .GT. 1.D0 ) THEN PTOT = PAMA(II2) * SQRT( (OUTPAR(IK+2) - 1.D0) * *(OUTPAR(IK+2) + 1.D0) ) ELSE WRITE(MONIOU,*) 'ERROR: MOTHER GAMMA < 1', * OUTPAR(IK+2) GOTO 103 ENDIF ELSE C PARTICLE WITH ZERO MASS PTOT = OUTPAR(IK+2) ENDIF STT = SQRT( (1.D0-OUTPAR(IK+3))*(1.D0+OUTPAR(IK+3)) ) IF ( OUTPAR(21) .NE. 0.D0 .OR. OUTPAR(20) .NE. 0.D0 ) THEN PHIPAR = ATAN2( OUTPAR(IK+5), OUTPAR(IK+4) ) ELSE PHIPAR = 0.D0 ENDIF DATAB(LH+2) = PTOT * STT * COS( PHIPAR - ARRANR ) ! Px DATAB(LH+3) = PTOT * STT * SIN( PHIPAR - ARRANR ) ! Py DATAB(LH+4) = PTOT * OUTPAR(IK+3) ! Pz XADDMU = OUTPAR(IK+8) - XOFF(LEVL) YADDMU = OUTPAR(IK+9) - YOFF(LEVL) DATAB(LH+5) = XADDMU * COSANG + YADDMU * SINANG !x DATAB(LH+6) = YADDMU * COSANG - XADDMU * SINANG !y DATAB(LH+7) = OUTPAR(IK+6) !z ENDIF #if __PARALLEL__ ENDIF #endif #if __THIN__ DATAB(LH+8) = OUTPAR(IK+10) IF ( DEBUG ) WRITE(MDEBUG,447) (DATAB(LH+I),I=1,8) 447 FORMAT(' OUTPT1: EM =',1P,8E11.3) LH = LH + 8 #else IF ( DEBUG ) WRITE(MDEBUG,447) (DATAB(LH+I),I=1,7) 447 FORMAT(' OUTPT1: EM =',1P,7E11.3) LH = LH + 7 #endif C WRITE A BLOCK OF 39 PARTICLES TO OUTPUT BUFFER AND CLEAR FIELD IF ( LH .GE. MAXBUF ) THEN #if __COMPACT__ IF ( COMOUT ) THEN IF ( FPAROUT ) CALL TOBUFS( DATAB, MAXBUF ) ELSE IF ( FPAROUT ) CALL TOBUF( DATAB,0 ) ENDIF #else IF ( FPAROUT ) CALL TOBUF( DATAB,0 ) #endif #if __CERENKOV__ && __IACT__ && __IACTEXT__ IF ( FPAROUT ) CALL TELPRT( DATAB, MAXBUF ) #endif DO I = 1, MAXBUF DATAB(I) = 0. ENDDO LH = 0 ENDIF 103 CONTINUE C ADD GRANDMOTHER PARTICLE INFORMATION FOR EM-PARTICLES OR NEUTRINOS IK = 27 #if __PARALLEL__ C WITH PARALLEL SOME GRANDMOTHERS ARE LOST IF ( OUTPAR(IK+2) .EQ. -1.D0 .OR. OUTPAR(18) .EQ. -1.D0) THEN DO I = 1, 7 DATAB(LH+I) = 0. ENDDO ELSE #endif II2 = NINT(OUTPAR(IK+1)) IGG = MOD( OUTPAR(35) , 1D8 ) IGG = IGG / 1000 !EM GEN COUNTER ONLY IGG = MIN(NINT(LOG(MOD(DBLE( IGG ),1.D3)+1.D0)),9) * 100 * + IGG / 1000 !LOG OF THE NUMBER ELECTRON INTERACTIONS * 100 + NUMBER OF PHOTON INTERACTIONS OF MOTHER IGG = MIN( IGG , 999) DATAB(LH+1) = -II2*1000 - IGG ! EM GENCOUNT OF MOTHER IF ( II2 .EQ. 0 ) THEN WRITE(MONIOU,*) 'FIRST PARTICLE GRANDMA',II2 ELSE IF ( PAMA(II2) .GT. 0.D0 ) THEN IF ( OUTPAR(IK+2) .GT. 1.D0 ) THEN PTOT = PAMA(II2) * SQRT( (OUTPAR(IK+2) - 1.D0) * *(OUTPAR(IK+2) + 1.D0) ) ELSE WRITE(MONIOU,*) 'ERROR: GRANDMA GAMMA < 1', * OUTPAR(IK+2) GOTO 104 ENDIF ELSE C PARTICLE WITH ZERO MASS PTOT = OUTPAR(IK+2) ENDIF STT = SQRT( (1.D0-OUTPAR(IK+3))*(1.D0+OUTPAR(IK+3)) ) IF ( OUTPAR(32) .NE. 0.D0 .OR. OUTPAR(31) .NE. 0.D0 ) THEN PHIPAR = ATAN2( OUTPAR(IK+5), OUTPAR(IK+4) ) ELSE PHIPAR = 0.D0 ENDIF DATAB(LH+2) = PTOT * STT * COS( PHIPAR - ARRANR ) ! Px DATAB(LH+3) = PTOT * STT * SIN( PHIPAR - ARRANR ) ! Py DATAB(LH+4) = PTOT * OUTPAR(IK+3) ! Pz C FINAL COMPLETE GENERATION COUNTER OF PARTICLE DATAB(LH+5) = NINT( OUTPAR(9) ) / 100 ! Extension of GenCount (too long in 32bits) DATAB(LH+6) = OUTPAR(IK+9) ! chi DATAB(LH+7) = -OUTPAR(IK+6) ! negative height ENDIF #if __PARALLEL__ ENDIF #endif #if __THIN__ DATAB(LH+8) = OUTPAR(IK+10) IF ( DEBUG ) WRITE(MDEBUG,447) (DATAB(LH+I),I=1,8) LH = LH + 8 #else IF ( DEBUG ) WRITE(MDEBUG,447) (DATAB(LH+I),I=1,7) LH = LH + 7 #endif C WRITE A BLOCK OF 39 PARTICLES TO OUTPUT BUFFER AND CLEAR FIELD IF ( LH .GE. MAXBUF ) THEN #if __COMPACT__ IF ( COMOUT ) THEN IF ( FPAROUT ) CALL TOBUFS( DATAB, MAXBUF ) ELSE IF ( FPAROUT ) CALL TOBUF( DATAB,0 ) ENDIF #else IF ( FPAROUT ) CALL TOBUF( DATAB,0 ) #endif #if __CERENKOV__ && __IACT__ && __IACTEXT__ IF ( FPAROUT ) CALL TELPRT( DATAB, MAXBUF ) #endif DO I = 1, MAXBUF DATAB(I) = 0. ENDDO LH = 0 ENDIF 104 CONTINUE ENDIF #endif #if __EHISTORY__ C STRIP OFF PRECOURSORS WITH GEN. COUNTER ABOVE 100 C TO GET FULL GENERATION COUNTER USING ADDITIONAL FIELD IN GRANDMOTHER IGG = MOD( OUTPAR(9), 100.D0 ) #else C STRIP OFF EM-PRECOURSORS WITH GEN. COUNTER ABOVE 1000 IGG = MOD( OUTPAR(9), 1000.D0 ) C LIMIT GENERATION COUNTER TO 99 C (EM PARTICLES WITH GEN=99 ARE COMING FROM MUON INTERACTION ONLY) C (MUON WITH GEN=99 ARE COMING FROM A CHAIN WITH 2 PION DECAYS (RARE)) IGG = MIN( IGG, 99 ) #endif C LIMIT GENERATION COUNTER TO 99 DATAB(LH+1) = III*1000 + IGG*10 + MOD(LEVL,10) IF ( OUTPAR(0) .LE. 3.D0 ) THEN ETOT = OUTPAR(1) #if __NEUTRINO__ || __NUPRIM__ ELSEIF ( ( OUTPAR(0).GE.66.D0 .AND. OUTPAR(0).LE.69.D0 ) #if __CHARM__ || __TAULEP__ * .OR. OUTPAR(0).EQ.133.D0 .OR. OUTPAR(0).EQ.134.D0 #endif * ) THEN ETOT = OUTPAR(1) #endif ELSE ETOT = PAMA(III) * OUTPAR(1) ENDIF PTOT = SQRT( (ETOT-PAMA(III))*(ETOT+PAMA(III)) ) STT = SQRT( (1.D0-OUTPAR(2))*(1.D0+OUTPAR(2)) ) IF ( OUTPAR(4) .NE. 0.D0 .OR. OUTPAR(3) .NE. 0.D0 ) THEN PHIPAR = ATAN2( OUTPAR(4), OUTPAR(3) ) ELSE PHIPAR = 0.D0 ENDIF DATAB(LH+2) = PTOT * STT * COS( PHIPAR - ARRANR ) DATAB(LH+3) = PTOT * STT * SIN( PHIPAR - ARRANR ) DATAB(LH+4) = PTOT * OUTPAR(2) DATAB(LH+5) = OUTPAR(7) * COSANG + OUTPAR(8) * SINANG DATAB(LH+6) = OUTPAR(8) * COSANG - OUTPAR(7) * SINANG DATAB(LH+7) = OUTPAR(6) * 1.E9 ENDIF IF ( FTABOUT ) THEN C CALCULATE TIME DELAY (IN NS) WITH RESPECT TO SPHERICAL SHOWER C FRONT AT POINT (X,Y) TF = SQRT( (HEIGHP - OBSLEV(LEVL))**2 + * (OUTPAR(7)+XOFF(LEVL))**2 + * (OUTPAR(8)+YOFF(LEVL))**2 ) / (C(25)*1.D-9) TT = OUTPAR(6)*1.D9 - TF IF ( OUTPAR(0) .LE. 3.D0 ) THEN ETOT = OUTPAR(1) ELSE ETOT = PAMA(III) * OUTPAR(1) ENDIF EEE = ETOT #if __THIN__ RR = SQRT( RR2 ) #else RR = SQRT( OUTPAR(7)**2 + OUTPAR(8)**2 ) #endif EEE = MAX( EBMIN, EEE ) TT = MAX( TBMIN, TT ) RR = MAX( DBMIN, RR ) C GET CORRECT BIN IIE = (LOG10(EEE) - EBOFF)*EBFAC + 1. IIT = (LOG10(TT) - TBOFF)*TBFAC + 1. IID = (LOG10(RR) - DBOFF)*DBFAC + 1. IIE = MIN( IIE, IEBIN ) IIE = MAX( 1, IIE ) IIT = MIN( IIT, ITBIN ) IIT = MAX( 1, IIT ) IID = MIN( IID, IDBIN ) IID = MAX( 1, IID ) IF ( III .EQ. 1 ) THEN G_ARRAY(IIE,IIT,IID) = G_ARRAY(IIE,IIT,IID) + AUGM ELSEIF ( III .LE. 3 ) THEN E_ARRAY(IIE,IIT,IID) = E_ARRAY(IIE,IIT,IID) + AUGM ELSEIF ( III .EQ. 5 .OR. III .EQ. 6 ) THEN M_ARRAY(IIE,IIT,IID) = M_ARRAY(IIE,IIT,IID) + AUGM ENDIF ENDIF #if __THIN__ C FILL ENERGY - WEIGHT STATISTICS C HERE STILL ALL PARTICLES ARE CONSIDERED (I.E. NO RADIAL THINNING) C THEREFORE WEIGHT IS NOT MODIFIED. IF ( OUTPAR(0) .LE. 3.D0 ) THEN ETOT = OUTPAR(1) #if __NEUTRINO__ || __NUPRIM__ ELSEIF ( ( OUTPAR(0).GE.66.D0 .AND. OUTPAR(0).LE.69.D0 ) #if __CHARM__ || __TAULEP__ * .OR. OUTPAR(0).EQ.133.D0 .OR. OUTPAR(0).EQ.134.D0 #endif * ) THEN ETOT = OUTPAR(1) #endif ELSE ETOT = PAMA(III) * OUTPAR(1) ENDIF EKIN = ETOT - PAMA(III) IF ( EKIN .LE. 0.001D0 ) THEN MEN = 1 ELSE MEN = 10.D0 + 3.D0 * LOG10(EKIN) MEN = MIN( MEN, 46 ) ENDIF IF ( OUTPAR(13) .LE. 1.D0 ) THEN MMU = 1 ELSE MMU = 1.D0 + 3.D0 * LOG10(OUTPAR(13)) MMU = MIN( MMU, 15 ) ENDIF MWGHMA (MEN,MMU) = MWGHMA (MEN,MMU) + 1 MWGHTOT(MEN,MMU) = MWGHTOT(MEN,MMU) + 1 IF (DEBUG) WRITE(MDEBUG,446) SNGL(EKIN),SNGL(OUTPAR(13)),MEN,MMU 446 FORMAT(1H ,'OUTPT1: ENERGY WEIGHT BIN',1P,E11.4,2X,E11.4,2I5) C MODIFY THE INCREMENT IN CASE OF RADIAL THINNING AUGM2 = AUGM / MAX(1.D-10,PROBTH) #endif IF ( ROUT ) THEN C COUNT PARTICLES SPECIFIED BY THEIR PARTICLE CODE < 25 IF ( III .LT. 18 ) THEN NPART2(LEVL,III) = NPART2(LEVL,III) + AUGM2 ELSEIF ( III .EQ. 25 ) THEN NPART2(LEVL,27) = NPART2(LEVL,27) + AUGM2 ELSEIF ( (III .GE. 18 .AND. III .LE. 24) .OR. * (III .GE. 26 .AND. III .LE. 32) ) THEN NPART2(LEVL,18) = NPART2(LEVL,18) + AUGM2 #if __CHARM__ ELSEIF ( III .GE. 116 .AND. III .LE. 128 ) THEN NPART2(LEVL,23) = NPART2(LEVL,23) + AUGM2 ELSEIF ( III .GE. 137 .AND. III .LE. 173 ) THEN NPART2(LEVL,24) = NPART2(LEVL,24) + AUGM2 #endif ELSEIF ( III .EQ. 201 ) THEN NPART2(LEVL,19) = NPART2(LEVL,19) + AUGM2 ELSEIF ( III .EQ. 301 ) THEN NPART2(LEVL,20) = NPART2(LEVL,20) + AUGM2 ELSEIF ( III .EQ. 302 ) THEN NPART2(LEVL,21) = NPART2(LEVL,21) + AUGM2 ELSEIF ( III .EQ. 402 ) THEN NPART2(LEVL,22) = NPART2(LEVL,22) + AUGM2 #if __NEUTRINO__ || __NUPRIM__ ELSEIF ( ( III .GE. 66 .AND. III .LE. 69 ) #if __CHARM__ || __TAULEP__ * .OR. III .EQ. 133 .OR. III .EQ. 134 #endif * ) THEN NPART2(LEVL, 4) = NPART2(LEVL,4) + AUGM2 #endif ELSE WRITE(MONIOU,*) 'OUTPT1: PARTICLE ON OBSLEV ',LEVL, * ' ID= ',III NPART2(LEVL,25) = NPART2(LEVL,25) + AUGM2 ENDIF C COUNT PARTICLES, THAT ARE WRITTEN TO FILE NOPART = NOPART + 1 #if __THIN__ C MODIFY THE WEIGHT IN CASE OF RADIAL THINNING (OTHERWISE PROBTH = 1) C HERE NO WEIGHT LIMITATION IS DONE. DATAB(LH+8) = OUTPAR(13)/MAX(1.D-10,PROBTH) LH = LH + 8 #else LH = LH + 7 #endif C WRITE A BLOCK OF 39 PARTICLES TO OUTPUT BUFFER AND CLEAR FIELD IF ( LH .GE. MAXBUF ) THEN #if __COMPACT__ IF ( COMOUT ) THEN IF ( FPAROUT ) CALL TOBUFS( DATAB, MAXBUF ) ELSE IF ( FPAROUT ) CALL TOBUF( DATAB,0 ) ENDIF #else IF ( FPAROUT ) CALL TOBUF( DATAB,0 ) #endif #if __CERENKOV__ && __IACT__ && __IACTEXT__ IF ( FPAROUT ) CALL TELPRT( DATAB, MAXBUF ) #endif DO I = 1, MAXBUF DATAB(I) = 0. ENDDO LH = 0 ENDIF ENDIF #if __MULTITHIN__ IF ( ROUT ) THEN IF ( NMTHIN .GT. 0 ) THEN C WRITE IDENTIFICATION FOR DATA SUBBLOCK WHICH CONTAINS WEIGHTS C ICODE > 100: PARTCLE HITS SHADOW C THE LOWEST TWO DIGITS OF ICODE GIVE BINARY CODING OF THINNG MODES DATAB(LH+1) = 8888000. + ICODE DO I = 1, 6 DATAB(LH+I+1) = OUTPAR(40+I) ENDDO LH = LH + 7 C WRITE A BLOCK OF 39 PARTICLES TO OUTPUT BUFFER AND CLEAR FIELD IF ( LH .GE. MAXBUF ) THEN #if __COMPACT__ IF ( COMOUT ) THEN IF ( FPAROUT ) CALL TOBUFS( DATAB, MAXBUF ) ELSE IF ( FPAROUT ) CALL TOBUF( DATAB,0 ) ENDIF #else IF ( FPAROUT ) CALL TOBUF( DATAB,0 ) #endif DO I = 1, MAXBUF DATAB(I) = 0. ENDDO LH = 0 ENDIF ENDIF ENDIF #endif RETURN END #if __MUPROD__ *-- Author : D. HECK IKP KIT KARLSRUHE 18/12/2012 C======================================================================= SUBROUTINE OUTPT3(INDX) C----------------------------------------------------------------------- C WRITES MUON INFORMATION AT THE POINT OF ORIGIN AND DECAY/INTERACTION C OF A DISAPPEARING MUON. C USED PARTICLE CODES: C 85 MUON AT BIRTH FOR DECAYING MUON C 86 MUON AT BIRTH FOR DECAYING MUON C 95 MUON AT DECAY POINT FOR DECAYING/INTERACTING MUON C 96 MUON AT DECAY POINT FOR DECAYING/INTERACTING MUON C C WRITES 39 PARTICLE RECORDS PER PHYSICAL RECORD C THIS SUBROUTINE IS CALLED FROM MUNUCL AND MUTRAC. C ARGUMENT: C INDX = 1 MUON TRACK ENDS BECAUSE OF DECAY C = 2 MUON TRACK ENDS BECAUSE OF NUCLEAR FATAL INTERACTION C = 3 MUON TRACK ENDS IN UPDATE BY ENERGY OR ANGULAR CUT C----------------------------------------------------------------------- IMPLICIT NONE #define __BUFFSINC__ #define __ETHMAPINC__ #define __LONGIINC__ #define __MAGANGINC__ #define __MULTINC__ #define __MUPARTINC__ #define __NPARTIINC__ #define __OBSPARINC__ #define __PAMINC__ #define __PARPARINC__ #define __PARPAEINC__ #define __RUNPARINC__ #if __THIN__ #define __RANDPAINC__ #define __THNVARINC__ #define __WGHTMAINC__ #endif #if __MULTITHIN__ #define __MULTHININC__ #endif #include "corsika.h" DOUBLE PRECISION ETOT,PHIMU,PHIPAR,PTOT,STT,XADDMU,YADDMU INTEGER I,IGG,III,INDX #if __CURVED__ DOUBLE PRECISION COSTHPRPR #endif #if __EHISTORY__ INTEGER II2,IK #endif LOGICAL ROUT #if __THIN__ DOUBLE PRECISION EKIN #endif SAVE C----------------------------------------------------------------------- #if __THIN__ IF ( DEBUG ) WRITE(MDEBUG,444) (OUTPAR(I),I=0,9),OUTPAR(13),INDX 444 FORMAT(' OUTPT3: OUTPAR=',1P,9E11.3,0P,F10.0,1P,E10.3,I5) #else IF ( DEBUG ) WRITE(MDEBUG,444) (OUTPAR(I),I=0,9),INDX 444 FORMAT(' OUTPT3: OUTPAR=',1P,9E11.3,0P,F10.0,I5) #endif #if __EHISTORY__ IF ( DEBUG ) WRITE(MDEBUG,1445) (OUTPAR(I),I=17,27) 1445 FORMAT(' OUTPT3: 17-27: ',1P,11E11.3) IF ( DEBUG ) WRITE(MDEBUG,1446) (OUTPAR(I),I=28,38) 1446 FORMAT(' OUTPT3: 28-38: ',1P,11E11.3) #endif #if __MULTITHIN__ OUTPAR(40) = 8888000.D0 IF ( DEBUG ) WRITE(MDEBUG,1447) (OUTPAR(I),I=40,46) 1447 FORMAT(' OUTPT3: 40-46: ',1P,7E11.3) #endif #if !__CURVED__ C CORRECT X,Y COORDINATES FOR LOWEST OBSERVATION LEVEL OUTPAR(7) = OUTPAR(7) - XOFF(NOBSLV) OUTPAR(8) = OUTPAR(8) - YOFF(NOBSLV) #else IF ( .NOT. FFLATOUT ) THEN C PROPAGATE PARTICLE UNTIL SPHERICAL GROUND SO X AND Y ARE CORRECTED C TO BE DEFINED AT OBSERVATION LEVEL INSTEAD OF SEA LEVEL C (CORRXY = ( C(1) + OBSLEV(1) ) / C(1)) OUTPAR(7) = OUTPAR(7) * CORRXY OUTPAR(8) = OUTPAR(8) * CORRXY ENDIF #endif C PRINT OUT PARTICLE IF IT IS ABOVE THE CUT IF ( FPRINT .OR. DEBUG .OR. DEBDEL ) THEN IF ( OUTPAR(1) .GE. ECTMAP ) THEN #if __THIN__ WRITE(MONIOU,3) (OUTPAR(I),I=0,9),OUTPAR(13),OUTPAR(10),ELEFT #if __PARALLEL__ & +ELEFTJ #endif 3 FORMAT(' OUTPT3: ',1P,9E11.3,0P,F12.0,1P,3E10.3) #else WRITE(MONIOU,3) (OUTPAR(I),I=0,10),ELEFT #if __PARALLEL__ & +ELEFTJ #endif 3 FORMAT(' OUTPT3: ',1P,9E11.3,0P,F12.0,1P,2E10.3) #if __MULTITHIN__ WRITE(MDEBUG,31) (OUTPAR(I),I=40,46) 31 FORMAT(' OUTPT3: 40-46: ',1P,7E11.3) #endif #endif ENDIF ENDIF III = NINT( OUTPAR(0) ) ROUT = .TRUE. C TREAT ADDITIONAL INFORMATION OF MUONS C THE COORDINATES OF MUON ORIGIN ARE STORED IN AMUPAR(.) IF ( ROUT ) THEN IF ( FMUADD .AND. (III .EQ. 5 .OR. III .EQ. 6) ) THEN C LIMIT GENERATION COUNTER TO 99 * IGG = MIN( OUTPAR(9), 99.D0 ) * DATAB(LH+1) = (III + 80) * 1000 + IGG*10 + INDX C LIMIT GENERATION COUNTER TO 999 C NORMAL GENERATION COUNTER BELOW 1000 IGG = MOD( OUTPAR(9), 1000.D0 ) C IF PHOTONUCLEAR INTERACTION OR MUON PAIR PRODUCTION IN MUON HISTORY IF ( OUTPAR(9) .GT. 1D8 ) IGG = IGG + 500 IGG = MIN( IGG , 999) C ADDITIONAL MUON INFO FOR DECAYING MUONS IS PARTICLE CODE 85/86 DATAB(LH+1) = (III + 80) * 1000 + IGG PTOT = PAMA(III) * SQRT( (AMUPAR(1)-1.D0)*(AMUPAR(1)+1.D0) ) #if __CURVED__ C DETERMINE ANGLE THETAPRPR IN DETECTOR SYSTEM FROM LOCAL ANGLE THETA C AND ANGLE THETA_E (AT CENTER OF EARTH) SEE FZKA 6954 FIG. 3 C THETPRPR = THETA + THETA_E C USE THE ADDITION RULES FOR COSINE(THETA + THETA_E) COSTHPRPR = AMUPAR(2) * AMUPAR(16) * - SQRT( (1.D0+AMUPAR(2))*(1.D0-AMUPAR(2)) * * (1.D0+AMUPAR(16))*(1.D0-AMUPAR(16)) ) DATAB(LH+4) = PTOT * COSTHPRPR XADDMU = AMUPAR(7) YADDMU = AMUPAR(8) STT = SQRT( (1.D0-COSTHPRPR) * (1.D0+COSTHPRPR) ) #else DATAB(LH+4) = PTOT * AMUPAR(2) XADDMU = AMUPAR(7) - XOFF(NOBSLV) !PROJECTION TO LOWEST OBSLEVEL YADDMU = AMUPAR(8) - YOFF(NOBSLV) !PROJECTION TO LOWEST OBSLEVEL STT = SQRT( (1.D0-AMUPAR(2))*(1.D0+AMUPAR(2)) ) #endif IF ( AMUPAR(4) .NE. 0.D0 .OR. AMUPAR(3) .NE. 0.D0 ) THEN PHIMU = ATAN2( AMUPAR(4), AMUPAR(3) ) ELSE PHIMU = 0.D0 ENDIF DATAB(LH+2) = PTOT * STT * COS( PHIMU - ARRANR ) DATAB(LH+3) = PTOT * STT * SIN( PHIMU - ARRANR ) DATAB(LH+5) = XADDMU * COSANG + YADDMU * SINANG DATAB(LH+6) = YADDMU * COSANG - XADDMU * SINANG DATAB(LH+7) = AMUPAR(5) #if __THIN__ DATAB(LH+8) = AMUPAR(13) IF ( DEBUG ) WRITE(MDEBUG,445) (DATAB(LH+I),I=1,8) 445 FORMAT(' OUTPT3: MUADDI=',1P,8E11.3) LH = LH + 8 #else IF ( DEBUG ) WRITE(MDEBUG,445) (DATAB(LH+I),I=1,7) 445 FORMAT(' OUTPT3: MUADDI=',1P,7E11.3) LH = LH + 7 #endif C WRITE A BLOCK OF 39 PARTICLES TO OUTPUT BUFFER AND CLEAR FIELD IF ( LH .GE. MAXBUF ) THEN IF ( FPAROUT ) CALL TOBUF( DATAB,0 ) DO I = 1, MAXBUF DATAB(I) = 0. ENDDO LH = 0 ENDIF #if __EHISTORY__ C ADD MOTHER PARTICLE INFORMATION IK = 16 II2 = NINT(OUTPAR(IK+1)) IGG = MOD( AMUPAR(35), 1000D0 ) C IF PHOTONUCLEAR INTERACTION OR MUON PAIR PRODUCTION IN MOTHER HISTORY IF ( AMUPAR(35) .GT. 1D8 )IGG = IGG + 500 IGG = MIN( IGG , 999) DATAB(LH+1) = -II2*1000 - IGG ! HAD. GENCOUNT OF MOTHER IF ( II2 .EQ. 0 ) THEN WRITE(MONIOU,*) 'FIRST PARTICLE?',II2 ELSE IF ( PAMA(II2) .GT. 0.D0 ) THEN IF ( AMUPAR(IK+2) .GT. 1.D0 ) THEN PTOT = PAMA(II2) * SQRT( (AMUPAR(IK+2) - 1.D0) * *(AMUPAR(IK+2) + 1.D0) ) ELSE WRITE(MONIOU,*) 'ERROR: MOTHER GAMMA < 1', * AMUPAR(IK+2) GOTO 101 ENDIF ELSE C PARTICLE WITH ZERO MASS PTOT = AMUPAR(IK+2) ENDIF STT = SQRT( (1.D0-AMUPAR(IK+3))*(1.D0+AMUPAR(IK+3)) ) IF ( AMUPAR(21) .NE. 0.D0 .OR. AMUPAR(20) .NE. 0.D0 ) THEN PHIPAR = ATAN2( AMUPAR(IK+5), AMUPAR(IK+4) ) ELSE PHIPAR = 0.D0 ENDIF DATAB(LH+2) = PTOT * STT * COS( PHIPAR - ARRANR ) ! Px DATAB(LH+3) = PTOT * STT * SIN( PHIPAR - ARRANR ) ! Py DATAB(LH+4) = PTOT * AMUPAR(IK+3) ! Pz XADDMU = AMUPAR(IK+8) - XOFF(NOBSLV) YADDMU = AMUPAR(IK+9) - YOFF(NOBSLV) DATAB(LH+5) = XADDMU * COSANG + YADDMU * SINANG !x DATAB(LH+6) = YADDMU * COSANG - XADDMU * SINANG !y DATAB(LH+7) = AMUPAR(IK+6) !z ENDIF #if __THIN__ DATAB(LH+8) = 0. IF ( DEBUG ) WRITE(MDEBUG,445) (DATAB(LH+I),I=1,8) LH = LH + 8 #else IF ( DEBUG ) WRITE(MDEBUG,445) (DATAB(LH+I),I=1,7) LH = LH + 7 #endif C WRITE A BLOCK OF 39 PARTICLES TO OUTPUT BUFFER AND CLEAR FIELD IF ( LH .GE. MAXBUF ) THEN IF ( FPAROUT ) CALL TOBUF( DATAB,0 ) DO I = 1, MAXBUF DATAB(I) = 0. ENDDO LH = 0 ENDIF 101 CONTINUE C ADD GRANDMOTHER PARTICLE INFORMATION IK = 27 II2 = NINT( OUTPAR(IK+1) ) IGG = MOD( AMUPAR(35), 1D8 ) IGG = IGG / 1000 !EM GENCOUNT ONLY IGG = MIN(NINT(LOG(MOD(DBLE( IGG ),1.D3)+1.D0)),9) * 100 * + IGG / 1000 !LOG OF THE NUMBER ELECTRON INTERACTIONS * 100 + NUMBER OF PHOTON INTERACTIONS OF MOTHER IGG = MIN( IGG , 999) DATAB(LH+1) = -II2*1000 - IGG ! EM GENCOUNT OF MOTHER IF ( II2 .EQ. 0 ) THEN WRITE(MONIOU,*) 'FIRST PARTICLE GRANDMA',II2 ELSE IF ( PAMA(II2) .GT. 0.D0 ) THEN IF ( AMUPAR(IK+2) .GT. 1.D0 ) THEN PTOT = PAMA(II2) * SQRT( (AMUPAR(IK+2) - 1.D0) * *(AMUPAR(IK+2) + 1.D0) ) ELSE WRITE(MONIOU,*) 'ERROR: GRANDMA GAMMA < 1', * AMUPAR(IK+2) GOTO 102 ENDIF ELSE C PARTICLE WITH ZERO MASS PTOT = AMUPAR(IK+2) ENDIF STT = SQRT( (1.D0-AMUPAR(IK+3))*(1.D0+AMUPAR(IK+3)) ) IF ( AMUPAR(32) .NE. 0.D0 .OR. AMUPAR(31) .NE. 0.D0 ) THEN PHIPAR = ATAN2( AMUPAR(IK+5), AMUPAR(IK+4) ) ELSE PHIPAR = 0.D0 ENDIF DATAB(LH+2) = PTOT * STT * COS( PHIPAR - ARRANR ) ! Px DATAB(LH+3) = PTOT * STT * SIN( PHIPAR - ARRANR ) ! Py DATAB(LH+4) = PTOT * AMUPAR(IK+3) ! Pz C FINAL COMPLETE GENERATION COUNTER OF PARTICLE DATAB(LH+5) = NINT( OUTPAR(9) ) / 100 ! GenCount DATAB(LH+6) = AMUPAR(IK+9) ! chi DATAB(LH+7) = -AMUPAR(IK+6) ! negative height ENDIF #if __THIN__ DATAB(LH+8) = AMUPAR(IK+10) IF ( DEBUG ) WRITE(MDEBUG,445) (DATAB(LH+I),I=1,8) LH = LH + 8 #else IF ( DEBUG ) WRITE(MDEBUG,445) (DATAB(LH+I),I=1,7) LH = LH + 7 #endif C WRITE A BLOCK OF 39 PARTICLES TO OUTPUT BUFFER AND CLEAR FIELD IF ( LH .GE. MAXBUF ) THEN IF ( FPAROUT ) CALL TOBUF( DATAB,0 ) DO I = 1, MAXBUF DATAB(I) = 0. ENDDO LH = 0 ENDIF 102 CONTINUE #endif ENDIF C COPY PARTICLE TO DATAB FIELD #if __EHISTORY__ C STRIP OFF PRECOURSORS WITH GEN. COUNTER ABOVE 100 C TO GET FULL GENERATION COUNTER USING ADDITIONAL FIELD IN GRANDMOTHER IGG = MOD( OUTPAR(9), 100.D0 ) #else C STRIP OFF EM-PRECOURSORS WITH GEN. COUNTER ABOVE 1000 IGG = MOD( OUTPAR(9), 1000.D0 ) C LIMIT GENERATION COUNTER TO 99 C (EM PARTICLES WITH GEN=99 ARE COMING FROM MUON INTERACTION ONLY) C (MUON WITH GEN=99 ARE COMING FROM A CHAIN WITH 2 PION DECAYS (RARE)) IGG = MIN( IGG, 99 ) #endif C DECAYING MUONS GET PARTICLE CODE 95/96 DATAB(LH+1) = (III+90)*1000 + IGG*10 + INDX ETOT = PAMA(III) * OUTPAR(1) PTOT = SQRT( (ETOT-PAMA(III))*(ETOT+PAMA(III)) ) STT = SQRT( (1.D0-OUTPAR(2))*(1.D0+OUTPAR(2)) ) IF ( OUTPAR(4) .NE. 0.D0 .OR. OUTPAR(3) .NE. 0.D0 ) THEN PHIPAR = ATAN2( OUTPAR(4), OUTPAR(3) ) ELSE PHIPAR = 0.D0 ENDIF DATAB(LH+2) = PTOT * STT * COS( PHIPAR - ARRANR ) DATAB(LH+3) = PTOT * STT * SIN( PHIPAR - ARRANR ) DATAB(LH+4) = PTOT * OUTPAR(2) DATAB(LH+5) = OUTPAR(7) * COSANG + OUTPAR(8) * SINANG DATAB(LH+6) = OUTPAR(8) * COSANG - OUTPAR(7) * SINANG C ALTITUDE OF THE DECAY GIVEN IN DATAB(LH+7) DATAB(LH+7) = OUTPAR(5) ! ALTITUDE C DATAB(LH+7) = OUTPAR(6) * 1.E9 ! TIME SINCE FIRST INTEACTION C COUNT PARTICLES, THAT ARE WRITTEN TO TAPE NOPART = NOPART + 1 #if __THIN__ DATAB(LH+8) = OUTPAR(13) IF ( DEBUG ) WRITE(MDEBUG,545) (DATAB(LH+I),I=1,8) 545 FORMAT(' OUTPT3: MUDECY=',1P,8E11.3) LH = LH + 8 #else IF ( DEBUG ) WRITE(MDEBUG,545) (DATAB(LH+I),I=1,7) 545 FORMAT(' OUTPT3: MUDECY=',1P,7E11.3) LH = LH + 7 #endif C WRITE A BLOCK OF 39 PARTICLES TO OUTPUT BUFFER AND CLEAR FIELD IF ( LH .GE. MAXBUF ) THEN IF ( FPAROUT ) CALL TOBUF( DATAB,0 ) DO I = 1, MAXBUF DATAB(I) = 0. ENDDO LH = 0 ENDIF ENDIF #if __MULTITHIN__ IF ( ROUT ) THEN IF ( NMTHIN .GT. 0 ) THEN C WRITE IDENTIFICATION FOR DATA SUBBLOCK WHICH CONTAINS WEIGHTS DATAB(LH+1) = 8888000. DO I = 1, 6 DATAB(LH+I+1) = OUTPAR(40+I) ENDDO LH = LH + 7 C WRITE A BLOCK OF 39 PARTICLES TO OUTPUT BUFFER AND CLEAR FIELD IF ( LH .GE. MAXBUF ) THEN #if __COMPACT__ IF ( COMOUT ) THEN IF ( FPAROUT ) CALL TOBUFS( DATAB, MAXBUF ) ELSE IF ( FPAROUT ) CALL TOBUF( DATAB,0 ) ENDIF #else IF ( FPAROUT ) CALL TOBUF( DATAB,0 ) #endif DO I = 1, MAXBUF DATAB(I) = 0. ENDDO LH = 0 ENDIF ENDIF ENDIF #endif RETURN END #endif *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE PAMAF C----------------------------------------------------------------------- C PA(RTICLE) MA(SS) F(ILLING) C C FILLS PARTICLE MASS FOR PARTICLE IP IN ARRAY PAMA, C RESONANCES AND STRANGE BARYONS INCLUDED. C PARTICLE MASSES ACCORDING TO PARTICLE DATA GROUP TABLES C OR CALCULATED WITH THE MASS FORMULA OF WEIZSAECKER. C LIFE TIMES ARE TAKEN FROM THE PARTICLE DATA GROUP TABLES. C THIS SUBROUTINE IS CALLED FROM START. C----------------------------------------------------------------------- IMPLICIT NONE #define __CONSTAINC__ #define __PAMINC__ #include "corsika.h" DOUBLE PRECISION CHARGE(75),MASSES(75) DOUBLE PRECISION CHARGE2(100),MASSES2(100) C* DOUBLE PRECISION AMUS(59,14),BIND,B1,B2,B3A,B4,B5,SS DOUBLE PRECISION DECTME(75),DECTME2(100) INTEGER IA,IC,IN,IP C* INTEGER I,L SAVE C----------------------------------------------------------------------- C MASSES + LIFETIMES REVISED NOV 2015 BY D. HECK C BOTTOM PARTICLES ADDED JULY 2012 BY A. GASCON C CHARMED PARTICLES ADDED 2008 BY D. HECK DATA MASSES / * 0.D0 ,.51099893D-3,.51099893D-3, 0.D0 ,.105658372D0, * .105658372D0, .1349766D0, .13957018D0,.13957018D0, 0.497611D0 ,!10 * 0.493677D0 , 0.493677D0 ,.93956538D0 ,.93827205D0,.93827205D0 , * 0.497611D0 , 0.547862D0 , 1.115683D0 , 1.18937D0 , 1.192642D0 ,!20 * 1.197449D0 , 1.31486D0 , 1.32171D0 , 1.67245D0 ,.93956538D0 , * 1.115683D0 , 1.18937D0 , 1.192642D0 , 1.197449D0, 1.31486D0 ,!30 * 1.32171D0 , 1.67245D0 , 0.D0 , 0.D0 , 0.D0 , * 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 ,!40 * 1.D9 , 580.D0 , 1.D5 , 0.D0 , 0.D0 , * 0.D0 , 0.D0 , 0.95778D0 , 1.019461D0, 0.78265D0 ,!50 * 0.7690D0 , 0.7665D0 , 0.7665D0 , 1.2305D0 , 1.2318D0 , * 1.2331D0 , 1.2344D0 , 1.2309D0 , 1.2323D0 , 1.2336D0 ,!60 * 1.2349D0 , 0.89581D0 , 0.89166D0 , 0.89166D0 , 0.89581D0 , * 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 ,!70 * 0.547862D0 , 0.547862D0 , 0.547862D0 , 0.547862D0, 0.D0 / DATA CHARGE / * 0.D0,+1.D0,-1.D0, 0.D0,+1.D0,-1.D0, 0.D0,+1.D0,-1.D0, 0.D0, * +1.D0,-1.D0, 0.D0,+1.D0,-1.D0, 0.D0, 0.D0, 0.D0,+1.D0, 0.D0, * -1.D0, 0.D0,-1.D0,-1.D0, 0.D0, 0.D0,-1.D0, 0.D0,+1.D0, 0.D0, * +1.D0,+1.D0, 0.D0, 0.D0, 0.D0, 0.D0, 0.D0, 0.D0, 0.D0, 0.D0, * 0.D0, 0.D0, 0.D0, 0.D0, 0.D0, 0.D0, 0.D0, 0.D0, 0.D0, 0.D0, * 0.D0,+1.D0,-1.D0,+2.D0,+1.D0, 0.D0,-1.D0,-2.D0,-1.D0, 0.D0, * +1.D0, 0.D0,+1.D0,-1.D0, 0.D0, 0.D0, 0.D0, 0.D0, 0.D0, 0.D0, * 0.D0, 0.D0, 0.D0, 0.D0, 0.D0 / C LIFE TIMES AT REST TAKEN FROM THE PARTICLE DATA GROUP TABLES DATA DECTME/ * 0.D0 , 0.D0 , 0.D0 , 0.D0 , 2.19698D-6, * 2.19698D-6, 8.52D-17 , 2.6033D-8 , 2.6033D-8 , 5.116D-8 , !10 * 1.2380D-8 , 1.2380D-8 , 880.3D0 , 0.D0 , 0.D0 , * 0.8954D-10, 5.02D-19 , 2.632D-10 , 0.8018D-10, 7.4D-20 , !20 * 1.479D-10 , 2.90D-10 , 1.639D-10 , 0.821D-10 , 880.3D0 , * 2.632D-10 , 0.8018D-10, 7.4D-20 , 1.479D-10 , 2.90D-10 , !30 * 1.639D-10 , 0.821D-10 , 0.D0 , 0.D0 , 0.D0 , * 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , !40 * 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , * 0.D0 , 0.D0 , 3.32D-21 , 1.54D-22 , 7.75D-23 , !50 * 4.14D-24 , 4.14D-24 , 4.14D-24 , 5.87D-24 , 5.02D-24 , * 5.606D-24 , 5.D-24 , 5.87D-24 , 5.02D-24 , 5.606D-24 , !60 * 5.D-24 , 1.398D-23 , 1.296D-23 , 1.296D-23 , 1.389D-23 , * 0.D0 , 0.D0 , 0.D0 , 0.D0 , 0.D0 , !70 * 5.02D-19 , 5.02D-19 , 5.02D-19 , 5.02D-19 , 0.D0 / C CHARGE2, MASSES2 AND DECTME2 RUN FROM PARTICLE CODE 101 TO 200 DATA MASSES2 / * 15*0.D0, * 1.86484D0 , 1.86961D0 , 1.86961D0 , 1.86484D0 , 1.9683D0 , !120 * 1.9683D0 , 2.9836D0 , 2.00697D0 , 2.01027D0 , 2.01027D0 , * 2.00697D0 , 2.1121D0 , 2.1121D0 , 0.0D0 , 3.096916D0 , !130 * 1.77686D0 , 1.77686D0 , 0.D0 , 0.D0 , 0.D0 , * 0.D0 , 2.28646D0 , 2.46793D0 , 2.47085D0 , 2.45397D0 , !140 * 2.4529D0 , 2.45375D0 , 2.5757D0 , 2.5779D0 , 2.6952D0 , * 0.D0 , 0.D0 , 0.D0 , 2.28646D0 , 2.46793D0 , !150 * 2.47085D0 , 2.45397D0 , 2.4529D0 , 2.45375D0 , 2.5757D0 , * 2.5779D0 , 2.6952D0 , 0.D0 , 0.D0 , 0.D0 , !160 * 2.51841D0 , 2.5175D0 , 2.51848D0 , 0.D0 , 0.D0 , * 5*0.D0 , !170 * 2.51841D0 , 2.5175D0 , 2.51848D0 , 0.D0 , 0.D0 , * 5.27961D0 , 5.27929D0 , 5.27929D0 , 5.27961D0 , 5.36679D0 , !180 * 5.36679D0 , 6.2751D0 , 6.2751D0 , 5.61951D0 , 5.8155D0 , * 5.8113D0 , 5.7918D0 , 5.7944D0 , 6.0480D0 , 5.61951D0 , !190 * 5.8155D0 , 5.8113D0 , 5.7918D0 , 5.7944D0 , 6.0480D0 , * 5*0.D0 / DATA CHARGE2 / * 10*0.D0, * 5*0.D0, 0.D0,+1.D0,-1.D0, 0.D0,+1.D0, !120 * -1.D0, 0.D0, 0.D0,+1.D0,-1.D0, 0.D0,+1.D0,-1.D0, 0.D0, 0.D0, * -1.D0,+1.D0, 0.D0, 0.D0, 0.D0, 0.D0,+1.D0,+1.D0, 0.D0,+2.D0, !140 * +1.D0, 0.D0,+1.D0, 0.D0, 0.D0, 0.D0, 0.D0, 0.D0,-1.D0,-1.D0, * 0.D0,-2.D0,-1.D0, 0.D0,-1.D0, 0.D0, 0.D0, 0.D0, 0.D0, 0.D0, !160 * +2.D0,+1.D0, 0.D0, 6*0.D0, +2.D0, * -2.D0,-1.D0, 0.D0, 0.D0, 0.D0, 0.D0,+1.D0,-1.D0, 0.D0, 0.D0, !180 * 0.D0,+1.D0,-1.D0, 0.D0,-1.D0,+1.D0, 0.D0,-1.D0,-1.D0, 0.D0, !190 * +1.D0,-1.D0, 0.D0,+1.D0,+1.D0, 5*0.D0 / !200 DATA DECTME2/ * 15* 0.D0 , * 0.4101D-12, 1.040D-12 , 1.040D-12 , 0.4101D-12, 0.500D-12 , !120 * 0.500D-12 , 2.070D-23 , 3.13D-22 , 7.89D-21 , 7.89D-21 , * 3.13D-22 , 3.46D-22 , 3.46D-22 , 0.D0 , 7.085D-21 , !130 * 0.2903D-12, 0.2903D-12, 0.D0 , 0.D0 , 0.D0 , * 0.D0 , 0.200D-12 , 0.442D-12 , 0.112D-12 , 3.48D-22 , !140 * 1.43D-22 , 3.66D-22 , 1.D-23 , 1.D-23 , 0.69D-13 , * 0.D0 , 0.D0 , 0.D0 , 0.200D-12 , 0.442D-12 , !150 * 0.112D-12 , 3.48D-22 , 1.43D-22 , 3.66D-22 , 1.D-23 , * 1.D-23 , 0.69D-13 , 0.D0 , 0.D0 , 0.D0 , !160 * 4.45D-23 , 3.87D-23 , 4.30D-23 , 0.D0 , 0.D0 , * 5*0.D0 , !170 * 4.45D-23 , 3.87D-23 , 4.30D-23 , 0.D0 , 0.D0 , * 1.520D-12 , 1.638D-12 , 1.638D-12 , 1.520D-12 , 1.510D-12 , !180 * 1.510D-12 , 0.507D-12 , 0.507D-12 , 1.466D-12 , 1.34D-22 , * 5.72D-23 , 1.464D-12 , 1.560D-12 , 1.57D-12 , 1.466D-12 , !190 * 1.34D-22 , 5.72D-23 , 1.464D-12 , 1.560D-12 , 1.57D-12 , * 5*0.D0 / !200 C ISOTOPE MASSES CALCULATED FROM: ATOMIC DATA AND NUCL.DATA TABLES 39 C (1988) 289, (WAPSTRA''S VALUES, CORRECTED FOR ELECTRON MASSES) C* DATA ((AMUS(I,L),I=1,59),L=1,7) / C* * 1.8756D0, 2.8089D0, 57*0.D0, C* * 2.8083D0, 3.7273D0, 4.6678D0, 5.6054D0, 6.5454D0, 54*0.D0, C* * 2*0.D0 , 5.6014D0, 6.5337D0, 7.4712D0, 8.4067D0, C* * 9.3471D0, 10.2856D0, 51*0.D0, C* * 2*0.D0 , 6.5341D0, 7.4547D0, 8.3926D0, 9.3253D0, C* * 10.2644D0, 11.2008D0, 51*0.D0, C* * 2*0.D0 , 7.4722D0, 8.3932D0, 9.3243D0, 10.2524D0, C* * 11.1886D0, 12.1232D0, 13.0618D0, 13.9986D0, 49*0.D0, C* * 2*0.D0 , 8.4091D0, 9.3274D0, 10.2538D0, 11.1747D0, 12.1093D0, C* * 13.0406D0, 13.9790D0, 14.9143D0, 15.8531D0, 48*0.D0, C* * 4*0.D0 , 11.1915D0, 12.1110D0, 13.0400D0, 13.9687D0, 14.9057D0, C* * 15.8394D0, 16.7761D0, 17.7104D0, 47*0.D0/ C* DATA ((AMUS(I,L),I=1,59),L=8,14) / C* * 4*0.D0, 12.1282D0, 13.0446D0, 13.9709D0, 14.8948D0, 15.8302D0, C* * 16.7617D0, 17.6973D0, 18.6293D0, 19.5650D0, 46*0.D0, C* * 7*0.D0, 15.8325D0, 16.7629D0, 17.6920D0, 18.6429D0, 19.5564D0, C* * 20.4907D0, 21.4227D0, 22.3587D0, 44*0.D0, C* * 6*0.D0, 15.8464D0, 16.7668D0, 17.6947D0, 18.6174D0, 19.5502D0, C* * 20.4794D0, 21.4137D0, 22.3444D0, 23.2839D0, 24.2138D0, 43*0.D0, C* * 8*0.D0, 18.6308D0, 19.5532D0, 20.4817D0, 21.4088D0, 22.3414D0, C* * 23.2720D0, 24.2059D0, 25.1387D0, 26.0746D0, 27.0099D0, C* * 27.9469D0, 28.8820D0, 29.8173D0, 30.7546D0, 31.6913D0, 36*0.D0, C* * 7*0.D0, 18.6410D0, 19.5658D0, 20.4860D0, 21.4124D0, 22.3354D0, C* * 23.2676D0, 24.1961D0, 25.1292D0, 26.0602D0, 26.9961D0, C* * 27.9291D0, 28.8660D0, 29.7994D0, 30.7376D0, 38*0.D0, C* * 9*0.D0, 21.4241D0, 22.3488D0, 23.2714D0, 24.1996D0, 25.1261D0, C* * 26.0579D0, 26.9880D0, 27.9218D0, 28.8541D0, 29.7894D0, C* * 30.7233D0, 31.6599D0, 32.5944D0, 33.5316D0, 36*0.D0, C* * 9*0.D0, 22.3591D0, 23.2836D0, 24.2041D0, 25.1304D0, 26.0527D0, C* * 26.9838D0, 27.9128D0, 28.8457D0, 29.7761D0, 30.7111D0, C* * 31.6431D0, 32.5803D0, 33.5128D0, 34.4505D0, 35.3837D0, 35*0.D0/ C----------------------------------------------------------------------- C GEANT PARTICLES INCLUDING RHO, K*, AND DELTA DO IP = 1, 75 PAMA (IP) = MASSES(IP) SIGNUM(IP) = CHARGE(IP) DECTIM(IP) = DECTME(IP) ENDDO C RESET REST OF THE ARRAY DO IP = 76, 6000 PAMA (IP) = 0.D0 SIGNUM(IP) = 0.D0 ENDDO C NOW FILL IN CHARMED PARTICLES AND OTHER EXOTICS DO IP = 1, 99 PAMA (IP+100) = MASSES2(IP) SIGNUM(IP+100) = CHARGE2(IP) DECTIM(IP+100) = DECTME2(IP) ENDDO C LIGHTEST NUCLEUS IS DEUTERON (IA=2, IC=1) DO IA = 2, 59 DO IC = 1, IA IN = IA - IC IP = IA * 100 + IC C* IF ( IC .LE. 14 ) THEN C MASSES FROM MASS TABLE FOR ISOTOPES C* IF ( IN .EQ. 0 ) THEN C* PAMA(IP) = IC * PAMA(14) C* ELSE C* PAMA(IP) = AMUS(IN,IC) C* ENDIF C SIMPLE SUM OF PROTON AND NEUTRON MASSES C* IF ( PAMA(IP) .EQ. 0.D0 ) C* * PAMA(IP) = IC * PAMA(14) + IN * PAMA(13) C* ELSE C WEIZSAECKERS MASS FORMULA GIVES BINDING ENERGY IN MEV C* B1 = 14.1D0 * IA C* B2 = (-13.D0) * IA**TB3 C* B3 = (-0.595D0) * IC**2 / IA**OB3 C* B4 = (-19.D0) * (IC-IN)**2 / IA C* B5 = 33.5D0 / IA**0.75D0 C* IF ( MOD(IC,2) .EQ. 0 .AND. MOD(IN,2) .EQ. 0 ) THEN C* SS = 1.D0 C* ELSEIF ( MOD(IC,2) .EQ. 1 .AND. MOD(IN,2) .EQ. 1 ) THEN C* SS = -1.D0 C* ELSE C* SS = 0.D0 C* ENDIF C* BIND = (B1 + B2 + B3 + B4 + SS*B5)* 1.D-3 C* BIND = MAX( 0.D0, BIND ) C* PAMA(IP) = IN * MASSES(13) + IC * MASSES(14) - BIND C* ENDIF C FILL IN MASSES AND REST MASSES OF NUCLEI C DO NOT USE BINDING ENERGY EFFECTS PAMA(IP) = IN * MASSES(13) + IC * MASSES(14) RESTMS(IP) = PAMA(IP) C NUCLEI ARE ASSUMED TO BE FULLY IONIZED SIGNUM(IP) = +IC ENDDO ENDDO C MASSES OF MULTINEUTRON CLUSTERS (MINUMIM 2 NEUTRONS) DO IN = 2, 59 IP = 100 * IN PAMA (IP) = IN * PAMA(13) RESTMS(IP) = PAMA(IP) SIGNUM(IP) = 0.D0 ENDDO C REST MASS OF LIGHT NUCLEI (DEUTERIUM, TRITIUM, 3HE, ALPHA) RESTMS(201) = RESTMS(13) + RESTMS(14) RESTMS(301) = 2.D0 * RESTMS(13) + RESTMS(14) RESTMS(302) = RESTMS(13) + 2.D0 * RESTMS(14) RESTMS(402) = 2.D0 * RESTMS(13) + 2.D0 * RESTMS(14) RESTMS(45) = RESTMS(201) RESTMS(46) = RESTMS(301) RESTMS(47) = RESTMS(402) RETURN END *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE PI0DEC C----------------------------------------------------------------------- C PI 0 DEC(AY) C C DECAY OF PI0 INTO 2 GAMMAS OR INTO E(+) + E(-) + GAMMA C THIS SUBROUTINE IS CALLED FROM NUCINT. C----------------------------------------------------------------------- IMPLICIT NONE #define __CONSTAINC__ #define __DECAYCINC__ #define __GENERINC__ #define __LONGIINC__ #define __PAMINC__ #define __PARPARINC__ #define __PARPAEINC__ #define __RANDPAINC__ #define __RUNPARINC__ #if __AUGERHIST__ #define __OBSPARINC__ #endif #include "corsika.h" DOUBLE PRECISION AUX1,AUX2,COSTH1,COSTH2,EPITO2,FI1 INTEGER I #if __AUGERHIST__ DOUBLE PRECISION EDEP,THICKLOC,THICK INTEGER II,LL EXTERNAL THICK #endif SAVE C----------------------------------------------------------------------- #if __THIN__ IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=0,9),WEIGHT 444 FORMAT(' PI0DEC: CURPAR=',1P,11E11.3) #else IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=0,9) 444 FORMAT(' PI0DEC: CURPAR=',1P,10E11.3) #endif C LOOK FOR DECAY MODE CALL RMMARD( RD,3,1 ) C DECAY PI(0) ----> GAMMA + GAMMA IF ( RD(3) .LT. 0.98798D0 ) THEN C HALF OF TOTAL ENERGY OF THE PION = EPITO2 EPITO2 = 0.5D0 * GAMMA * PAMA(7) AUX1 = 1.D0 + BETA * RD(1) AUX2 = 1.D0 - BETA * RD(1) COSTH1 = (BETA + RD(1)) / AUX1 COSTH2 = (BETA - RD(1)) / AUX2 C FIRST GAMMA (WITH HIGHER ENERGY) FI1 = PI2 * RD(2) C ENERGY OF GAMMA SECPAR(1) = AUX1 * EPITO2 CALL ADDANG3( COSTHE,PHIX,PHIY, COSTH1,FI1, * SECPAR(2),SECPAR(3),SECPAR(4) ) #if __UPWARD__ IF ( SECPAR(2) .GE. -1.D0 ) THEN #else IF ( SECPAR(2) .GT. C(29) ) THEN #endif SECPAR(0) = 1.D0 #if __INTTEST__ SECPAR(17) = SECPAR(1) * * SQRT( (1.D0-SECPAR(2))*(1.D0+SECPAR(2)) ) #endif CALL TSTACK ELSE IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT #if __THIN__ DLONG(LHEIGH,11) = DLONG(LHEIGH,11) + SECPAR(1) * WEIGHT #else DLONG(LHEIGH,11) = DLONG(LHEIGH,11) + SECPAR(1) #endif ENDIF #if __AUGERHIST__ THICKLOC = THICK( H ) DO LL = 1, NOBSLV IF ( THICKLOC .GE. THCKOB(LL) .AND. * THICKLOC .LT. THCKOB(LL)+SAMPTH ) THEN C THICKH IS WITHIN 1 G/CM^2 BELOW OBSLEV(LL) C BRING THE ENERGY BELOW ANGULAR CUT TO THE HISTO OF LEVEL LL OUTPAR( 0) = 1.D0 DO II = 1, 8 OUTPAR(II) = SECPAR(II) ENDDO OUTPAR( 9) = GEN OUTPAR(10) = ALEVEL OUTPAR(13) = WEIGHT EDEP = OUTPAR(1) * WEIGHT C WE HAVE ANGULAR CUT CALL AUGERDEPFIL( EDEP,LL,1 ) ELSEIF ( THICKLOC .LT. THCKOB(LL) ) THEN GOTO 111 ENDIF ENDDO 111 CONTINUE #endif ENDIF C SECOND GAMMA (WITH LOWER ENERGY) C ENERGY OF GAMMA SECPAR(1) = AUX2 * EPITO2 CALL ADDANG3( COSTHE,PHIX,PHIY, COSTH2,FI1+PI, * SECPAR(2),SECPAR(3),SECPAR(4) ) #if __UPWARD__ IF ( SECPAR(2) .GE. -1.D0 ) THEN #else IF ( SECPAR(2) .GT. C(29) ) THEN #endif SECPAR(0) = 1.D0 #if __INTTEST__ SECPAR(17) = SECPAR(1) * * SQRT( (1.D0-SECPAR(2))*(1.D0+SECPAR(2)) ) #endif CALL TSTACK ELSE IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT #if __THIN__ DLONG(LHEIGH,11) = DLONG(LHEIGH,11) + SECPAR(1) * WEIGHT #else DLONG(LHEIGH,11) = DLONG(LHEIGH,11) + SECPAR(1) #endif ENDIF #if __AUGERHIST__ THICKLOC = THICK( H ) DO LL = 1, NOBSLV IF ( THICKLOC .GE. THCKOB(LL) .AND. * THICKLOC .LT. THCKOB(LL)+SAMPTH ) THEN C THICKH IS WITHIN 1 G/CM^2 BELOW OBSLEV(LL) C BRING THE ENERGY BELOW ANGULAR CUT TO THE HISTO OF LEVEL LL OUTPAR( 0) = 1.D0 DO II = 1, 8 OUTPAR(II) = SECPAR(II) ENDDO OUTPAR( 9) = GEN OUTPAR(10) = ALEVEL OUTPAR(13) = WEIGHT EDEP = OUTPAR(1) * WEIGHT C WE HAVE ANGULAR CUT CALL AUGERDEPFIL( EDEP,LL,1 ) ELSEIF ( THICKLOC .LT. THCKOB(LL) ) THEN GOTO 112 ENDIF ENDDO 112 CONTINUE #endif ENDIF C DECAY PI(0) ----> E(-) + E(+) + GAMMA (DALITZ DECAY) C (UNIFORM PHASE SPACE DISTRIBUTION IS ASSUMED FOR THIS DECAY) ELSE CALL DECAY6( PAMA(7), PAMA(2), PAMA(2), 0.D0, * 0.D0,0.D0,0.D0, 1.D0, 2 ) DO I = 1, 3 CALL ADDANG3( COSTHE,PHIX,PHIY, COS345(I),PHI345(I), * SECPAR(2),SECPAR(3),SECPAR(4) ) #if __UPWARD__ IF ( SECPAR(2) .GE. -1.D0 ) THEN #else IF ( SECPAR(2) .GT. C(29) ) THEN #endif SECPAR(0) = DBLE(4 - I) SECPAR(1) = GAM345(I) #if __INTTEST__ IF ( I .LT. 3 ) THEN SECPAR(17) = SQRT( (SECPAR(1)-1.D0)*(SECPAR(1)+1.D0) * * (1.D0-SECPAR(2))*(1.D0+SECPAR(2)) )*PAMA(2) ELSE SECPAR(17) = SECPAR(1) * * SQRT( (1.D0-SECPAR(2))*(1.D0+SECPAR(2)) ) ENDIF #endif CALL TSTACK ELSE IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT IF ( I .EQ. 1 ) THEN #if __THIN__ DLONG(LHEIGH,13) = DLONG(LHEIGH,13) * +(GAM345(I)-1.D0) * PAMA(2) * WEIGHT ELSEIF ( I .EQ. 2 ) THEN DLONG(LHEIGH,13) = DLONG(LHEIGH,13) * +(GAM345(I)+1.D0) * PAMA(2) * WEIGHT ELSE DLONG(LHEIGH,11) = DLONG(LHEIGH,11) + GAM345(I) * WEIGHT #else DLONG(LHEIGH,13) = DLONG(LHEIGH,13) * +(GAM345(I)-1.D0)*PAMA(2) ELSEIF ( I .EQ. 2 ) THEN DLONG(LHEIGH,13) = DLONG(LHEIGH,13) * +(GAM345(I)+1.D0)*PAMA(2) ELSE DLONG(LHEIGH,11) = DLONG(LHEIGH,11) + GAM345(I) #endif ENDIF ENDIF #if __AUGERHIST__ THICKLOC = THICK( H ) DO LL = 1, NOBSLV IF ( THICKLOC .GE. THCKOB(LL) .AND. * THICKLOC .LT. THCKOB(LL)+SAMPTH ) THEN C THICKH IS WITHIN 1 G/CM^2 BELOW OBSLEV(LL) C BRING THE ENERGY BELOW ANGULAR CUT TO THE HISTO OF LEVEL LL OUTPAR( 0) = 4 - I OUTPAR( 1) = GAM345(I) DO II = 2, 8 OUTPAR(II) = SECPAR(II) ENDDO OUTPAR( 9) = GEN OUTPAR(10) = ALEVEL OUTPAR(13) = WEIGHT IF ( OUTPAR(0) .NE. 1.D0 ) THEN OUTPAR(1) = OUTPAR(1) * PAMA(2) ENDIF EDEP = ( OUTPAR(1) - RESTMS(4-I) ) * WEIGHT C WE HAVE ANGULAR CUT CALL AUGERDEPFIL( EDEP,LL,1 ) ELSEIF ( THICKLOC .LT. THCKOB(LL) ) THEN GOTO 113 ENDIF ENDDO 113 CONTINUE #endif ENDIF ENDDO ENDIF RETURN END #if __PLOTSH2__ *-- Author : Fabian Schmidt, Leeds University 02/05/2005 C======================================================================= SUBROUTINE PLMAPINI C----------------------------------------------------------------------- C PL(OTTING )MAP( )INI(TIALIZATION) C C RESETS THE MAPS FOR DIFFERENT PROJECTIONS WHERE PARTICLE TRACKS WILL C BE PLOTTED IN. CALCULATES CONSTANTS FOR LINE DRAWING ROUTINES C----------------------------------------------------------------------- IMPLICIT NONE #define __RUNPARINC__ #define __PLOTSH2INC__ #include "corsika.h" INTEGER I,J,K SAVE C----------------------------------------------------------------------- C RESET MAPS DO I = 1, 3 DO J = 1, IYRES DO K = 1, IXRES PLMAPXY(I,J,K) = 0.D0 ENDDO ENDDO ENDDO DO I = 1, 3 DO J = 1, IZRES DO K = 1, IXRES PLMAPXZ(I,J,K) = 0.D0 ENDDO ENDDO ENDDO DO I = 1, 3 DO J = 1, IZRES DO K = 1, IYRES PLMAPYZ(I,J,K) = 0.D0 ENDDO ENDDO ENDDO C SET UP CONSTANTS XCONST = DBLE(IXRES-1) / (PLX2 - PLX1) YCONST = DBLE(IYRES-1) / (PLY2 - PLY1) ZCONST = DBLE(IZRES-1) / (PLZ2 - PLZ1) C PRINT OUT PLOTTING SCALES (MIGHT BE INTERESTING) WRITE(MONIOU,*) 'SCALES OF SHOWER MAP AXES:' WRITE(MONIOU,100) 'X',1.D0/XCONST WRITE(MONIOU,100) 'Y',1.D0/YCONST WRITE(MONIOU,100) 'Z',1.D0/ZCONST IF (FBOXCUT) WRITE(MONIOU,*) 'APPLYING 3D BOX CUT TO TRACKS.' WRITE(MONIOU,*) ' ' 100 FORMAT(' ',A1,' AXIS: ',E15.7,' CM / PIXEL') RETURN END #endif #if __PLOTSH2__ *-- Author : Fabian Schmidt, Univ. of Leeds 21/07/2005 C======================================================================= SUBROUTINE PLTRUNC C----------------------------------------------------------------------- C PL(OTSH2: )TRUNC(ATE PARTICLE TRACKS) C C TRUNCATES THE COORDINATES OF THE PARTICLE TRACK TO 3D BOX GIVEN C BY PLOTSH2 AXIS RANGES. C----------------------------------------------------------------------- IMPLICIT NONE #define __PLOTSH2INC__ #include "corsika.h" SAVE C----------------------------------------------------------------------- C TRACKS WITH BOTH ENDPOINTS LYING OUTSIDE THE AXIS RANGES ARE C NOT PLOTTED (THAT IS, POINTS ARE SET EQUAL) IF ( ( TRX1 .LT. REAL(PLX1) .OR. TRX1 .GT. REAL(PLX2) .OR. * TRY1 .LT. REAL(PLY1) .OR. TRY1 .GT. REAL(PLY2) .OR. * TRZ1 .LT. REAL(PLZ1) .OR. TRZ1 .GT. REAL(PLZ2) ) .AND. * ( TRX2 .LT. REAL(PLX1) .OR. TRX2 .GT. REAL(PLX2) .OR. * TRY2 .LT. REAL(PLY1) .OR. TRY2 .GT. REAL(PLY2) .OR. * TRZ2 .LT. REAL(PLZ1) .OR. TRZ2 .GT. REAL(PLZ2) ) ) THEN TRX2 = TRX1 TRY2 = TRY1 TRZ2 = TRZ1 ENDIF RETURN END #endif #if __PLOTSH2__ *-- Author : Fabian Schmidt, Leeds University 02/05/2005 C======================================================================= SUBROUTINE PLWRITE C----------------------------------------------------------------------- C PL(OTTING MAP )WRITE C C WRITES MAPS TO DISK AS RAW (UNFORMATTED) DATA FILES C X-Y-, X-Z-, AND Y-Z-PROJECTIONS FOR ElECTROMAGNETIC PARTICLES, MUONS, C AND HADRONS EACH -> 9 FILES. C----------------------------------------------------------------------- IMPLICIT NONE #define __PLOTSH2INC__ #define __RUNPARINC__ #include "corsika.h" REAL D1,D2 INTEGER I,K,IBL SAVE C----------------------------------------------------------------------- IBL = INDEX(CPLOT2,' ') WRITE(MONIOU,3466)CPLOT2(1:IBL-1),CPLOT2(1:IBL-1),CPLOT2(1:IBL-1) 3466 FORMAT(/,' PLOTSH2 OPTION HAS BEEN SELECTED',/, * ' TRACK SEGMENTS FOR EACH PARTICLE ARE STORED ON',/, * ' ',a,'.em_[xy/xz/yz].map,',/, * ' ',a,'.mu_[xy/xz/yz].map, AND',/, * ' ',a,'.hd_[xy/xz/yz].map') C EM MAP CPLOT2(IBL:IBL+9) = '.em_xy.map' OPEN(UNIT=55,FILE=CPLOT2,FORM='UNFORMATTED',STATUS='UNKNOWN') D1 = FLOAT(IXRES) D2 = FLOAT(IYRES) WRITE(55) D1,D2 DO I = 1, IYRES WRITE(55) (PLMAPXY(1,I,K), K=1,IXRES) ENDDO CLOSE( UNIT=55 ) CPLOT2(IBL:IBL+9) = '.em_xz.map' OPEN(UNIT=55,FILE=CPLOT2,FORM='UNFORMATTED',STATUS='UNKNOWN') D1 = FLOAT(IXRES) D2 = FLOAT(IZRES) WRITE(55) D1,D2 DO I = 1, IZRES WRITE(55) (PLMAPXZ(1,I,K), K=1,IXRES) ENDDO CLOSE( UNIT=55 ) CPLOT2(IBL:IBL+9) = '.em_yz.map' OPEN(UNIT=55,FILE=CPLOT2,FORM='UNFORMATTED',STATUS='UNKNOWN') D1 = FLOAT(IYRES) D2 = FLOAT(IZRES) WRITE(55) D1,D2 DO I = 1, IZRES WRITE(55) (PLMAPYZ(1,I,K), K=1,IYRES) ENDDO CLOSE( UNIT=55 ) C MU+/- MAP CPLOT2(IBL:IBL+9) = '.mu_xy.map' OPEN(UNIT=55,FILE=CPLOT2,FORM='UNFORMATTED',STATUS='UNKNOWN') D1 = FLOAT(IXRES) D2 = FLOAT(IYRES) WRITE(55) D1,D2 DO I = 1, IYRES WRITE(55) (PLMAPXY(2,I,K), K=1,IXRES) ENDDO CLOSE( UNIT=55 ) CPLOT2(IBL:IBL+9) = '.mu_xz.map' OPEN(UNIT=55,FILE=CPLOT2,FORM='UNFORMATTED',STATUS='UNKNOWN') D1 = FLOAT(IXRES) D2 = FLOAT(IZRES) WRITE(55) D1,D2 DO I = 1, IZRES WRITE(55) (PLMAPXZ(2,I,K), K=1,IXRES) ENDDO CLOSE( UNIT=55 ) CPLOT2(IBL:IBL+9) = '.mu_yz.map' OPEN(UNIT=55,FILE=CPLOT2,FORM='UNFORMATTED',STATUS='UNKNOWN') D1 = FLOAT(IYRES) D2 = FLOAT(IZRES) WRITE(55) D1,D2 DO I = 1, IZRES WRITE(55) (PLMAPYZ(2,I,K), K=1,IYRES) ENDDO CLOSE( UNIT=55 ) C HADRONS'' MAP CPLOT2(IBL:IBL+9) = '.hd_xy.map' OPEN(UNIT=55,FILE=CPLOT2,FORM='UNFORMATTED',STATUS='UNKNOWN') D1 = FLOAT(IXRES) D2 = FLOAT(IYRES) WRITE(55) D1,D2 DO I = 1, IYRES WRITE(55) (PLMAPXY(3,I,K), K=1,IXRES) ENDDO CLOSE( UNIT=55 ) CPLOT2(IBL:IBL+9) = '.hd_xz.map' OPEN(UNIT=55,FILE=CPLOT2,FORM='UNFORMATTED',STATUS='UNKNOWN') D1 = FLOAT(IXRES) D2 = FLOAT(IZRES) WRITE(55) D1,D2 DO I = 1, IZRES WRITE(55) (PLMAPXZ(3,I,K), K=1,IXRES) ENDDO CLOSE( UNIT=55 ) CPLOT2(IBL:IBL+9) = '.hd_yz.map' OPEN(UNIT=55,FILE=CPLOT2,FORM='UNFORMATTED',STATUS='UNKNOWN') D1 = FLOAT(IYRES) D2 = FLOAT(IZRES) WRITE(55) D1,D2 DO I = 1, IZRES WRITE(55) (PLMAPYZ(3,I,K), K=1,IYRES) ENDDO CLOSE( UNIT=55 ) RETURN END #endif *-- Author : D. HECK IK FZK KARLSRUHE 26/06/2003 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/TAU C PAIR PRODUCTION ENERGY LOSS. C PARAMETERS TO BE GIVEN BY COMMON: C EE = ENERGY OF INCOMING MUON/TAU C VFRAC = (E+ + E-)/EE FRACTION OF MUON/TAU ENERGY TRANSMT. 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----------------------------------------------------------------------- IMPLICIT NONE #define __CONSTAINC__ #define __MUPARTINC__ #define __PAMINC__ #include "corsika.h" DOUBLE PRECISION R PARAMETER (R = 189.D0) 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) IF ( MT .EQ. 1 ) THEN C MUON CSI = (1.D0-RO2) * (0.5D0*VFRAC / EBYMU)**2 / (1.D0-VFRAC) ELSE C TAUL LEPTON CSI = (1.D0-RO2) * (0.5D0*VFRAC / EBYTAU)**2 / (1.D0-VFRAC) ENDIF 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 * PAMA(2) * SE * (1.D0+CSI) * (1.D0+YE) * * AUXIL2 ) * AUXIL IF ( MT .EQ. 1 ) THEN C MUON 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 ELSE C TAU LEPTON ALE2 = 1.D0 + ( (1.5D0*EBYTAU * ZATOM**OB3)**2 ) * (1.D0+CSI) * * (1.D0+YE) ALE = LOG( UPPLE/DOWNLE ) - 0.5D0 * LOG( ALE2 ) UPPLM = (TB3 / EBYTAU) * R / ZATOM**TB3 ENDIF DOWNLM = 1.D0 + ( 2.D0 * PAMA(2) * 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 IF ( MT .EQ. 1 ) THEN C MUON PPCE = ( FIE + FIM * EBYMU**2 ) * (1.D0-VFRAC) ELSE C TAU LEPTON PPCE = ( FIE + FIM * EBYTAU**2 ) * (1.D0-VFRAC) ENDIF RETURN END *-- Author : D. HECK IK FZK KARLSRUHE 22/05/2003 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/TAU C PAIR PRODUCTION CROSS-SECTIONS. C PARAMETERS TO BE GIVEN BY COMMON: C EE = ENERGY OF INCOMING MUON/TAU C VFRAC = (E+ + E-)/EE FRACTION OF MUON/TAU ENERGY TRANSMITTED C TO PAIR C ZATOM = ATOMIC NUMBER OF TARGET ATOM C THIS FUNCTION IS CALLED FROM DGQUAD (BY MUPRPR, DKOKOS, DKOKOS) C AND MUPRPR. C ARGUMENT: C R1 = ASYMMETRY ENERGY ELECTRON-POSITRON: (E+ - E-)/(E+ + E-) C----------------------------------------------------------------------- IMPLICIT NONE #define __CONSTAINC__ #define __MUPARTINC__ #define __PAMINC__ #include "corsika.h" DOUBLE PRECISION R PARAMETER (R = 189.D0) 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) IF ( MT .EQ. 1 ) THEN C MUON CSI = (1.D0-RO2) * (0.5D0*VFRAC / EBYMU)**2 / (1.D0-VFRAC) ELSE C TAU LEPTON CSI = (1.D0-RO2) * (0.5D0*VFRAC / EBYTAU)**2 / (1.D0-VFRAC) ENDIF 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 * PAMA(2) * SE * (1.D0+CSI) * (1.D0+YE) * * AUXIL2 ) * AUXIL IF ( MT .EQ. 1 ) THEN C MUON 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 ELSE C TAU LEPTON ALE2 = 1.D0 + ( (1.5D0 * EBYTAU * ZATOM**OB3)**2 ) * (1.D0+CSI) * * (1.D0+YE) ALE = LOG( UPPLE/DOWNLE ) - 0.5D0 * LOG( ALE2 ) UPPLM = (TB3 / EBYTAU) * R / ZATOM**TB3 ENDIF DOWNLM = 1.D0 + ( 2.D0 * PAMA(2) * 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 IF ( MT .EQ. 1 ) THEN C MUON PPCS = ( FIE + FIM * EBYMU**2 ) * (1.D0-VFRAC)/VFRAC ELSE C TAU lEPTON PPCS = ( FIE + FIM * EBYTAU**2 ) * (1.D0-VFRAC)/VFRAC ENDIF 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/TAU C PAIR PRODUCTION CROSS-SECTIONS. C PARAMETERS TO BE GIVEN BY COMMON: C EE = ENERGY OF INCOMING MUON/TAU LEPTON C VFRAC = (E+ + E-)/EE FRACTION OF MUON/TAU ENERGY TRANSMITTED C TO PAIR C ZATOM = ATOMIC NUMBER OF TARGET ATOM C THIS FUNCTION IS CALLED FROM DGQUAD (BY MUPRPR) 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 #define __CONSTAINC__ #define __MUPARTINC__ #define __PAMINC__ #include "corsika.h" DOUBLE PRECISION R PARAMETER (R = 189.D0) 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) IF ( MT .EQ. 1 ) THEN C MUON CSI = (1.D0-RO2) * (0.5D0*VFRAC / EBYMU)**2 / (1.D0-VFRAC) C TAU LEPTON ELSE CSI = (1.D0-RO2) * (0.5D0*VFRAC / EBYTAU)**2 / (1.D0-VFRAC) ENDIF 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 * PAMA(2) * SE * (1.D0+CSI) * (1.D0+YE) * * AUXIL2 ) * AUXIL IF ( MT .EQ. 1 ) THEN C MUON 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 ELSE C TAU LEPTON ALE2 = 1.D0 + ( (1.5D0 * EBYTAU * ZATOM**OB3)**2 )*(1.D0+CSI) * * (1.D0+YE) ALE = LOG( UPPLE/DOWNLE ) - 0.5D0 * LOG( ALE2 ) UPPLM = (TB3 / EBYTAU) * R / ZATOM**TB3 ENDIF DOWNLM = 1.D0 + ( 2.D0 * PAMA(2) * 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 IF ( MT .EQ. 1 ) THEN C MUON PPCSL = R1MN1 * ( FIE + FIM * EBYMU**2 ) * (1.D0-VFRAC)/VFRAC ELSE C TAU lEPTON PPCSL = R1MN1 * ( FIE + FIM * EBYTAU**2 ) * (1.D0-VFRAC)/VFRAC ENDIF RETURN END #if __CURVED__ *-- Author : F. SCHROEDER UNI WUPPERTAL 17/09/1998 C======================================================================= SUBROUTINE PRANGC( ARG,FLAGMU,HNEW ) C----------------------------------------------------------------------- C (DECAYING) P(ARTICLE''S) RANG(E IN A) C(URVED ATMOSPHERE) C C DETERMINES MEAN FREE PATH FOR DECAYING PARTICLES IN CURVED C ATMOSPHERE INCLUDING IONIZATION ENERGY LOSS PRECISELY. C CALCULATE TOTAL PATH LENGTH FOR MUONS/TAU. C THIS SUBROUTINE IS CALLED FROM BOX2. C ARGUMENTS: C ARG = -LOG(RANDOM NUMBER) * SPEED OF LIGHT * LIFETIME (CM) C FLAGMU = MUON FLAG (T FOR MUONS/TAU LEPTONS, F ELSE) C HNEW = HEIGHT AFTER TOTAL STEP LENGTH (CM) C----------------------------------------------------------------------- IMPLICIT NONE #define __AIRINC__ #define __ATMOSINC__ #define __ATMOS2INC__ #define __CONSTAINC__ #define __MUPARTINC__ #define __MUMULTINC__ #define __OBSPARINC__ #define __PAMINC__ #define __PARPARINC__ #define __PARPAEINC__ #define __RUNPARINC__ #if __ATMEXT__ #define __ATMOSXINC__ #endif #include "corsika.h" DOUBLE PRECISION ACOSTNEW,AK,ARG,ARG0,ARGNEW,AUXIL,AUX2,BETANEW, * BK,CHIT,CHIT2,COSDIF,COSPHI,COSTHENEW, * DK,DL,ELOSS,ELOS2,GAMK,GAMNEW, * GAMSQ,GAM0,GMSQM1,HNEW,HOLD,H0, * SINPHI,SINTHE,SINTHENEW, * TH0,THNEW,THOLD,TRANS,TRANSNEW INTEGER ILAY LOGICAL FLAGMU DOUBLE PRECISION CDNS,CDNS1,ARGLOG #if __UPWARD__ DOUBLE PRECISION DENS,STEPNEW #endif DOUBLE PRECISION CDEDXM,HEIGH,RHOF,THICK SAVE EXTERNAL CDEDXM,HEIGH,RHOF,THICK C CONSTANT IN DENSITY EFFECT FOR IONIZATION LOSS IN AIR DATA CDNS1 / 0.020762D0 / C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,444) ARG,THICKH 444 FORMAT(' PRANGC: -LOG(RD)*C*TAU = ',1P,E10.3,' THICKH=',E10.3) C START VALUES CHI = 0.D0 HNEW = H GAM0 = GAMMA TH0 = THICKH BETANEW = BETA COSTHENEW = COSTHE STEPL = 0.D0 SINTHE = SQRT( (1.D0-COSTHE)*(1.D0+COSTHE) ) IF ( SINTHE .NE. 0.D0 ) THEN COSPHI = PHIX / SINTHE SINPHI = PHIY / SINTHE ELSE COSPHI = 0.D0 SINPHI = 0.D0 ENDIF C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C LOOP OVER PIECES OF ARG (EACH IN ITS LOCAL FLAT COORDINATE FRAME) 1 CONTINUE C STORE OLD VALUE OF THICKNESS THOLD = TH0 SINTHENEW = SQRT( MAX( 0.D0, (1.D0-COSTHENEW)*(1.D0+COSTHENEW) ) ) C CALCULATE UPPER LIMIT FOR TRANSVERSAL LENGTH (IMPORTANT TO DO A CUT, C 'UPPER LIMIT' BECAUSE GAM0 BECOMES SMALLER DUE TO IONISATION LOSS) AUXIL = GAM0 * BETANEW * SINTHENEW TRANS = ARG * AUXIL C MAXIMAL HORIZONTAL STEP (DEPENDS ON THICKNESS AT PARTICLE ALTITUDE) CDH 17.06.2002 TRANSNEW = MIN( TRANS, MAX( (C(4) * THOLD + C(3)), C(2) ) ) C IF ( SINTHENEW .EQ. 0.D0 ) THEN C STEP IN VERTICAL DIRECTION ARGNEW = ARG ELSE ARGNEW = TRANSNEW / AUXIL ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) 'PRANGC: TH0,ARGNEW,TRANSNEW=', * SNGL(TH0),SNGL(ARGNEW),SNGL(TRANSNEW) C SET START VALUES FOR ITERATION OVER THE AIR LAYERS ARG0 = ARGNEW CHIT = 0.D0 H0 = HNEW ACOSTNEW = ABS( COSTHENEW ) #if __UPWARD__ IF ( ACOSTNEW .GT. 0.003D0 ) THEN C NORMAL TREATMENT FOR NON-HORIZONTAL PARTICLE (INCLINATION > 0.2 DEG) #endif C LOOK WITHIN WHICH LAYER THE PARTICLE STARTS IF ( HNEW .LE. HLAY(2) ) THEN ILAY = 1 ELSEIF ( HNEW .LE. HLAY(3) ) THEN ILAY = 2 ELSEIF ( HNEW .LE. HLAY(4) ) THEN ILAY = 3 ELSE ILAY = 4 TH0 = MAX( TH0, THICKL(5) ) ENDIF #if __UPWARD__ IF ( COSTHENEW .LT. 0.D0 ) THEN ILAY = ILAY + 1 ENDIF #endif C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 2 CONTINUE GAM0 = MAX( GAM0, 1.0001D0 ) GAMSQ = GAM0**2 GMSQM1 = GAMSQ - 1.D0 C ENERGY LOSS BY IONIZATION IF ( FLAGMU ) THEN C DENSITY EFFECT PARAMETERIZATION (R.P. KOKOULIN, 2006) CDNS = CDNS1 * RHOF(H0) IF ( MT .EQ. 1 ) THEN C MUON ARGLOG = GMSQM1**2/( (GAM0*C(16)+1.D0)*(1.D0+GMSQM1*CDNS) ) ELSE C TAU LEPTON ARGLOG = GMSQM1**2/( (GAM0*C(18)+1.D0)*(1.D0+GMSQM1*CDNS) ) ENDIF ELOSS = C(22) * ( GAMSQ * (0.5D0*LOG( ARGLOG )+C(23)) * / GMSQM1 - 1.D0 ) C ADD ENERGY LOSS OF SUBTHRESHOLD BEMSSTRAHLUNG AND PAIRPRODUCTION AUX2 = CDEDXM( PAMA(ITYPE)*GAM0 ) IF ( DEBUG ) WRITE(MDEBUG,*) * 'PRANGC: ELOSS,DEDXM=',ELOSS,AUX2 ELOSS = ELOSS + AUX2 ELSE ELOSS = SIGNUM(ITYPE)**2 * C(22) * ( GAMSQ * (LOG( GMSQM1 ) * - 0.5D0 * LOG( GAM0 * 2.D0 * PAMA(2)/PAMA(ITYPE) * + 1.D0 + (PAMA(2)/PAMA(ITYPE))**2 ) * + C(23)) / GMSQM1 - 1.D0 ) IF ( DEBUG ) WRITE(MDEBUG,*) 'PRANGC: ELOSS=',ELOSS ENDIF ELOS2 = ELOSS / ( PAMA(ITYPE) * ACOSTNEW ) #if __UPWARD__ IF ( ILAY .GT. 4 ) THEN BK = ELOS2 * (TH0 - AATM(4)) DK = GAM0 + BK AK = ARG0 * DK * ACOSTNEW * DATM(4) ELSE BK = ELOS2 * (TH0 - AATM(ILAY)) DK = GAM0 + BK AK = ARG0 * DK * ACOSTNEW * DATM(ILAY) ENDIF #else BK = ELOS2 * (TH0 - AATM(ILAY)) DK = GAM0 + BK AK = ARG0 * DK * ACOSTNEW * DATM(ILAY) #endif IF ( AK .GT. 0.D0 ) THEN C LIMIT FOR EXPONENT IF ( AK .LT. 174.D0 ) THEN C SEE FZKA 6019, EQ. 4.6 GAMNEW = MAX( GAM0*DK / (GAM0 + EXP( AK )*BK), 1.0001D0 ) ELSE GAMNEW = 1.0001D0 ENDIF #if __UPWARD__ IF ( COSTHENEW .GT. 0.D0 ) THEN GAMK = GAM0 - ELOS2 * (THICKL(ILAY) - TH0) ELSE IF ( ILAY .GT. 4 ) THEN GAMK = GAM0 - ELOS2 * TH0 ELSE GAMK = GAM0 - ELOS2 * (TH0 - THICKL(ILAY) ) ENDIF ENDIF #else GAMK = GAM0 - ELOS2 * (THICKL(ILAY) - TH0) #endif ELSE GAMK = 1.D0 GAMNEW = 1.0001D0 ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) 'PRANGC: GAMNEW,GAMK=', * SNGL(GAMNEW),SNGL(GAMK) C LOOK WHETHER PARTICLE PENETRATES LAYER BOUNDARY OR DECAYS BEFORE C HORIZONTAL PARTICLES SHOULD NOT PENETRATE ANY LAYER IF ( GAMNEW .LT. GAMK ) THEN #if __UPWARD__ IF ( ILAY .LE. 4 .AND. COSTHENEW .LT. 0.D0 ) THEN C CALCULATE PORTION OF RANGE AND NEW START VALUES AT LAYER BOUNDARY ARG0 = ARG0 -( H0 - HLAY(ILAY) + CATM(ILAY)*LOG(GAM0/GAMK) ) * / ( DK * ACOSTNEW ) CHIT = CHIT + (THICKL(ILAY) - TH0) / COSTHENEW IF ( FLAGMU ) STEPL = STEPL + (H0 - HLAY(ILAY)) / COSTHENEW GAM0 = GAMK H0 = HLAY(ILAY) TH0 = THICKL(ILAY) ILAY = ILAY + 1 GOTO 2 ELSEIF ( ILAY .GT. 1 .AND. COSTHENEW .GT. 0.D0 ) THEN #else IF ( ILAY .GT. 1 ) THEN #endif C CALCULATE PORTION OF RANGE AND NEW START VALUES AT LAYER BOUNDARY ARG0 = ARG0 -( H0 - HLAY(ILAY) + CATM(ILAY)*LOG(GAM0/GAMK) ) * / ( DK * COSTHENEW ) CHIT = CHIT + (THICKL(ILAY) - TH0) / COSTHENEW IF ( FLAGMU ) STEPL = STEPL + (H0 - HLAY(ILAY)) / COSTHENEW GAM0 = GAMK H0 = HLAY(ILAY) TH0 = THICKL(ILAY) ILAY = ILAY - 1 GOTO 2 ENDIF ENDIF C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C PENETRATED MATTER THICKNESS CHIT2 = (GAM0 - GAMNEW) / (ELOS2 * ACOSTNEW) CHIT = CHIT + CHIT2 #if __ATMEXT__ IF ( IATMOX .GT. 0 ) THEN IF ( TH0 + CHIT*COSTHENEW .GT. THICKL(1) ) THEN CHI = CHI + (THICKL(1) - TH0)/COSTHENEW HNEW = HLAY(1) IF ( FLAGMU ) STEPL = STEPL + (H0 - HLAY(1))/COSTHENEW IF ( DEBUG ) WRITE(MDEBUG,*) 'PRANGC: CHI = ',SNGL(CHI) GOTO 100 ENDIF ENDIF #endif IF ( FLAGMU ) THEN STEPL = STEPL + ( H0 - HEIGH( MAX(0.D0,TH0+COSTHENEW*CHIT2) ) ) * / COSTHENEW ENDIF #if __UPWARD__ ELSE C TREATMENT OF NEARLY HORIZONTAL PARTICLE (INCLINATION < 0.2 DEG) C SEE D. HECK, REPORT FZKA 6019 (1998), APP. B GAM0 = MAX( GAM0, 1.0001D0 ) GAMSQ = GAM0**2 GMSQM1 = GAMSQ - 1.D0 DENS = RHOF(HNEW) C ENERGY LOSS BY IONIZATION IF ( FLAGMU ) THEN C DENSITY EFFECT PARAMETERIZATION (R.P. KOKOULIN, 2006) CDNS = CDNS1 * DENS IF ( MT .EQ. 1 ) THEN C MUON ARGLOG = GMSQM1**2/( (GAM0*C(16)+1.D0)*(1.D0+GMSQM1*CDNS) ) ELSE C TAU LEPTON ARGLOG = GMSQM1**2/( (GAM0*C(18)+1.D0)*(1.D0+GMSQM1*CDNS) ) ENDIF ELOSS = C(22) * ( GAMSQ * (0.5D0*LOG( ARGLOG )+C(23)) * / GMSQM1 - 1.D0 ) C ADD ENERGY LOSS OF SUBTHRESHOLD BEMSSTRAHLUNG AND PAIRPRODUCTION AUX2 = CDEDXM( PAMA(ITYPE)*GAM0 ) IF ( DEBUG ) WRITE(MDEBUG,*) * 'PRANGC: ELOSS,DEDXM=',ELOSS,AUX2 ELOSS = ELOSS + AUX2 ELSE ELOSS = SIGNUM(ITYPE)**2 * C(22) * ( GAMSQ * (LOG( GMSQM1 ) * - 0.5D0 * LOG( GAM0 * 2.D0 * PAMA(2)/PAMA(ITYPE) * + 1.D0 + (PAMA(2)/PAMA(ITYPE))**2 ) * + C(23)) / GMSQM1 - 1.D0 ) IF ( DEBUG ) WRITE(MDEBUG,*) 'PRANGC: ELOSS=',ELOSS ENDIF C SEE FZKA 6019 (1998) EQ. (B.2) STEPNEW = ARGNEW * BETANEW * GAM0 / ( 1.D0 * + ARGNEW*DENS*ELOSS/(PAMA(ITYPE)*BETANEW**3) ) CHIT = STEPNEW * DENS GAMNEW = MAX( 1.0001D0, GAM0 - ELOSS * CHIT / PAMA(ITYPE) ) IF ( DEBUG ) WRITE(MDEBUG,*) 'PRANGC: GAMNEW=',SNGL(GAMNEW) IF ( FLAGMU ) STEPL = STEPL + STEPNEW ENDIF #endif C ACTUAL VALUES CHI = CHI + CHIT ARG = ARG - ARGNEW C ACTUAL VALUE OF GAM0 IS CALCULATED IN THE LOOP ABOVE GAM0 = GAMNEW IF ( DEBUG ) WRITE(MDEBUG,11) CHI,CHIT,ARG 11 FORMAT(' PRANGC: CHI,CHIT,ARG=',1P,3(E10.3, 1X),0P) C LOOP UNTIL THE COMPLETE PARTICLE TRACK LENGTHS IS TRANSFORMED IN CHI BETANEW = SQRT( (GAMNEW-1.D0)*(GAMNEW+1.D0) ) / GAMNEW C CALCULATE REAL TRANSNEW AND REAL GEOMETRIC LENGTH DL WHICH CROSSED C THE PARTICLE WITH GIVEN ARGNEW. (GAMMA (= GAM0) HAS CHANGED DUE TO C IONIZATION LOSS). BECAUSE OF CUT ON TRANS AND ON ARG, IT IS POSSIBLE C TO CALCULATE WITHIN A FLAT ATMOSPHERE THNEW = MAX ( 0.D0, THOLD + COSTHENEW * CHIT ) HOLD = HNEW #if __UPWARD__ IF ( ACOSTNEW .LT. 0.003D0 ) THEN C NEARLY HORIZONTAL PARTICLE C NEW HEIGHT IN OLD COORDINATE FRAME HNEW = HEIGH( THNEW ) C DL IS INCLINED (HORIZONTAL) STEP LENGTH DL = STEPNEW ELSE C NEW HEIGHT IN OLD COORDINATE FRAME HNEW = HEIGH( THNEW ) C DL IS INCLINED STEP LENGTH DL = ( HOLD - HNEW ) / COSTHENEW ENDIF #else C NEW HEIGHT IN OLD COORDINATE FRAME HNEW = HEIGH( THNEW ) DL = ( HOLD - HNEW ) / COSTHENEW #endif C HORIZONTAL STEP LENGTH TRANSNEW = DL * SINTHENEW C NEW COORDINATE FRAME FOR NEXT STEP IN TRANSNEW C NEW ACTUAL HEIGHT AT NEW THICKNESS GRADIENT C (CALCULATED WITH PARAMETERS OF OLD COORDINATE FRAME) HNEW = SQRT( TRANSNEW**2 + (C(1)+HNEW)**2 ) - C(1) #if __UPWARD__ C TERMINATE PROCESS IF WELL BELOW SEA LEVEL IF ( HNEW .LT. HLAY(1) - 1.D5 ) THEN #else C TERMINATE PROCESS IF WELL BELOW OBSERVATION LEVEL IF ( SINTHENEW .NE. 0.D0 ) THEN IF ( HNEW .LT. OBSLEV(1)-2.D0*C(2)*COSTHENEW/SINTHENEW ) THEN IF ( DEBUG ) WRITE(MDEBUG,*) 'PRANGC: HNEW,CHI,ARG,STEPL=', * SNGL(HNEW),SNGL(CHI),SNGL(ARG),SNGL(STEPL) GOTO 100 ENDIF ENDIF IF ( HNEW .LT. OBSLEV(1) - 1.D5 ) THEN #endif IF ( DEBUG ) WRITE(MDEBUG,*) 'PRANGC: HNEW,CHI,ARG,STEPL=', * SNGL(HNEW),SNGL(CHI),SNGL(ARG),SNGL(STEPL) GOTO 100 #if __UPWARD__ ELSEIF ( HNEW .GE. HLAY(6) ) THEN C PARTICLE IS LEAVING THE ATMOSPHERE, TERMINATE PROCESS IF ( DEBUG ) WRITE(MDEBUG,*) 'PRANGC: HNEW,CHI,ARG,STEPL=', * SNGL(HNEW),SNGL(CHI),SNGL(ARG),SNGL(STEPL) GOTO 100 #endif ENDIF C TERMINATE PROCESS IF PARTICLE IS STOPPED IF ( GAM0 .LE. 1.0001D0 ) THEN IF ( DEBUG ) WRITE(MDEBUG,*) 'PRANGC: HNEW,GAM0,CHI,ARG,STEPL=', * SNGL(HNEW),SNGL(GAM0),SNGL(CHI),SNGL(ARG),SNGL(STEPL) GOTO 100 ENDIF C DIF IS ANGLE AT CENTER OF EARTH, USE COSINE RULE FOR DETERMINATION COSDIF = ( (C(1)+HNEW)**2 + (C(1)+HOLD)**2 - DL**2 ) / * ( 2.D0 * (C(1)+HNEW) * (C(1)+HOLD) ) IF ( DEBUG ) WRITE(MDEBUG,*) 'PRANGC: HNEW,COSDIF=', * SNGL(HNEW),SNGL(COSDIF) COSDIF = MIN( 1.D0, COSDIF ) C COSINE OF ZENITH ANGLE IN THE NEW FRAME C (THETA_NEW=THETA+DELTA -> ALWAYS + FOR THIS DEFINITION OF THETA) COSTHENEW = MIN( 1.D0, ( COSTHENEW * COSDIF * - SQRT( (1.D0-COSTHENEW)*(1.D0+COSTHENEW) * * (1.D0-COSDIF)*(1.D0+COSDIF) ) ) ) IF ( DEBUG ) WRITE(MDEBUG,*) 'PRANGC: COSTHENEW =',COSTHENEW C TERMINATE PROCESS IF PARTICLE MOVES OUT OF ANGULAR RANGE (UPWARD?) IF ( COSTHENEW .LE. C(29) ) GOTO 100 TH0 = THICK( HNEW ) C NEXT STEP IF ARG NOT COMPLETELY TRANSFORMAED IN CHI IF ( ARG .GT. 0.D0 ) GOTO 1 100 CONTINUE IF ( DEBUG ) THEN IF ( FLAGMU ) THEN WRITE(MDEBUG,*) 'PRANGC: HNEW,STEPL=',SNGL(HNEW),SNGL(STEPL) ELSE WRITE(MDEBUG,*) 'PRANGC: HNEW=',SNGL(HNEW) ENDIF ENDIF RETURN END #endif #if !__CURVED__ *-- Author : The CORSIKA development group 14/07/1995 C======================================================================= SUBROUTINE PRANGE( ARG ) C----------------------------------------------------------------------- C (DECAYING) P(ARTICLE''S) RANGE C C DETERMINES MEAN FREE PATH FOR DECAYING PARTICLES C INCLUDING IONIZATION ENERGY LOSS, C FOR EACH LAYER OF THE ATMOSOHERE SEPARATELY C PRECISELY C THIS SUBROUTINE IS CALLED FROM BOX2. C ARGUMENT: C ARG = -LOG(RANDOM NUMBER) * SPEED OF LIGHT * LIFETIME (CM) C----------------------------------------------------------------------- IMPLICIT NONE #define __AIRINC__ #define __ATMOSINC__ #define __ATMOS2INC__ #define __CONSTAINC__ #define __OBSPARINC__ #define __PAMINC__ #define __PARPARINC__ #define __PARPAEINC__ #define __RUNPARINC__ #include "corsika.h" DOUBLE PRECISION ACOSTH,AK,ARG,ARGLOG,ARG0,AUX2,BK,CDNS,CDNS1, * CHIT,DK,ELOSS,ELOS2, * GAMK,GAMNEW,GAMSQ,GAM0,GMSQM1,H0,TH0 INTEGER ILAY DOUBLE PRECISION CDEDXM,RHOF SAVE EXTERNAL CDEDXM,RHOF C CONSTANT IN DENSITY EFFECT FOR IONIZATION LOSS IN AIR DATA CDNS1 / 0.020762D0 / C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,444) ARG,THICKH 444 FORMAT(' PRANGE: -LOG(RD)*C*TAU = ',1P,E10.3,' THICKH=',E10.3) C LOOK WITHIN WHICH LAYER THE PARTICLE STARTS IF ( H .LE. HLAY(2) ) THEN ILAY = 1 TH0 = THICKH ELSEIF ( H .LE. HLAY(3) ) THEN ILAY = 2 TH0 = THICKH ELSEIF ( H .LE. HLAY(4) ) THEN ILAY = 3 TH0 = THICKH ELSE ILAY = 4 TH0 = MAX( THICKH, THICKL(5) ) ENDIF C SET START VALUES FOR ITERATION ARG0 = ARG CHIT = 0.D0 GAM0 = GAMMA H0 = H #if __UPWARD__ IF ( COSTHE .LT. 0.D0 ) THEN ILAY = ILAY + 1 ACOSTH = -COSTHE ELSE ACOSTH = COSTHE ENDIF #else ACOSTH = COSTHE #endif C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 2 CONTINUE GAM0 = MAX( GAM0, 1.0001D0 ) GAMSQ = GAM0**2 GMSQM1 = GAMSQ - 1.D0 C ENERGY LOSS BY IONIZATION IF ( ITYPE .EQ. 5 .OR. ITYPE .EQ. 6 ) THEN C DENSITY EFFECT PARAMETERIZATION (R.P. KOKOULIN, 2006) CDNS = CDNS1 * RHOF(H0) ARGLOG = GMSQM1**2/( (GAM0*C(16)+1.D0)*(1.D0+GMSQM1*CDNS) ) ELOSS = C(22) * ( GAMSQ * (0.5D0*LOG( ARGLOG )+C(23)) * / GMSQM1 - 1.D0 ) C ADD ENERGY LOSS OF SUBTHRESHOLD BEMSSTRAHLUNG AND PAIRPRODUCTION AUX2 = CDEDXM( PAMA(5)*GAM0 ) IF ( DEBUG ) WRITE(MDEBUG,*) 'PRANGE: ELOSS,DEDXM=',ELOSS,AUX2 ELOSS = ELOSS + AUX2 #if __CHARM__ || __TAULEP__ ELSEIF ( ITYPE .EQ. 131 .OR. ITYPE .EQ. 132 ) THEN C DENSITY EFFECT PARAMETERIZATION (R.P. KOKOULIN, 2006) CDNS = CDNS1 * RHOF(H0) ARGLOG = GMSQM1**2/( (GAM0*C(18)+1.D0)*(1.D0+GMSQM1*CDNS) ) ELOSS = C(22) * ( GAMSQ * (0.5D0*LOG( ARGLOG )+C(23)) * / GMSQM1 - 1.D0 ) C ADD ENERGY LOSS OF SUBTHRESHOLD BEMSSTRAHLUNG AND PAIRPRODUCTION AUX2 = CDEDXM( PAMA(131)*GAM0 ) IF ( DEBUG ) WRITE(MDEBUG,*) 'PRANGE: ELOSS,DEDXM=',ELOSS,AUX2 ELOSS = ELOSS + AUX2 #endif ELSE ELOSS = SIGNUM(ITYPE)**2 * C(22) * ( GAMSQ * (LOG( GMSQM1 ) * - 0.5D0 * LOG( GAM0 * 2.D0 * PAMA(2)/PAMA(ITYPE) * + 1.D0 + (PAMA(2)/PAMA(ITYPE))**2 ) * + C(23)) / GMSQM1 - 1.D0 ) IF ( DEBUG ) WRITE(MDEBUG,*) 'PRANGE: ELOSS=',ELOSS ENDIF ELOS2 = ELOSS / ( PAMA(ITYPE) * ACOSTH ) #if __UPWARD__ IF ( ILAY .GT. 4 ) THEN BK = ELOS2 * (TH0 - AATM(4)) DK = GAM0 + BK AK = ARG0 * DK * ACOSTH * DATM(4) ELSE BK = ELOS2 * (TH0 - AATM(ILAY)) DK = GAM0 + BK AK = ARG0 * DK * ACOSTH * DATM(ILAY) ENDIF #else BK = ELOS2 * (TH0 - AATM(ILAY)) DK = GAM0 + BK AK = ARG0 * DK * COSTHE * DATM(ILAY) #endif IF ( AK .GT. 0.D0 ) THEN C LIMIT FOR EXPONENT AK IF ( AK .LT. 174.D0 ) THEN C SEE FZKA 6019, EQ. 4.6 GAMNEW = MAX( GAM0 * DK / ( GAM0 + BK * EXP(AK) ), 1.0001D0 ) ELSE GAMNEW = 1.0001D0 ENDIF #if __UPWARD__ IF ( COSTHE .GT. 0.D0 ) THEN GAMK = GAM0 - ELOS2 * (THICKL(ILAY) - TH0) ELSE IF ( ILAY .GT. 4 ) THEN GAMK = GAM0 - ELOS2 * TH0 ELSE GAMK = GAM0 + ELOS2 * (THICKL(ILAY) - TH0) ENDIF ENDIF #else GAMK = GAM0 - ELOS2 * ( THICKL(ILAY) - TH0 ) #endif ELSE GAMK = 1.D0 GAMNEW = 1.0001D0 ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) 'PRANGE: GAMNEW,GAMK=', * SNGL(GAMNEW),SNGL(GAMK) C LOOK WHETHER PARTICLE PENETRATES LAYER BOUNDARY OR DECAYS BEFORE IF ( GAMNEW .LT. GAMK ) THEN #if __UPWARD__ IF ( ILAY .LE. 4 .AND. COSTHE .LT. 0.D0 ) THEN C CALCULATE PORTION OF RANGE AND NEW START VALUES AT LAYER BOUNDARY ARG0 = ARG0 - ( H0 - HLAY(ILAY) + CATM(ILAY)*LOG(GAM0/GAMK) ) * / (DK * COSTHE) CHIT = CHIT + (THICKL(ILAY) - TH0) / COSTHE GAM0 = GAMK H0 = HLAY(ILAY) TH0 = THICKL(ILAY) ILAY = ILAY + 1 GOTO 2 ELSEIF ( ILAY .GT. 1 .AND. COSTHE .GT. 0.D0 ) THEN #else IF ( ILAY .GT. 1 ) THEN #endif C CALCULATE PORTION OF RANGE AND NEW START VALUES AT LAYER BOUNDARY ARG0 = ARG0 - ( H0 - HLAY(ILAY) + CATM(ILAY)*LOG(GAM0/GAMK) ) * / (DK * COSTHE) CHIT = CHIT + (THICKL(ILAY) - TH0) / COSTHE GAM0 = GAMK H0 = HLAY(ILAY) TH0 = THICKL(ILAY) ILAY = ILAY - 1 GOTO 2 ENDIF ENDIF C PENETRATED MATTER THICKNESS CHI = CHIT + (GAM0 - GAMNEW) / ( ELOS2 * ACOSTH ) IF ( DEBUG ) WRITE(MDEBUG,445) CHI 445 FORMAT(' PRANGE: CHI = ',1P,E10.3) RETURN END #endif #if __PRESHOWER__ *-- Author : D. HECK IK FZK KARLSRUHE 23/11/2001 C======================================================================= SUBROUTINE PRESHO( PRESTART,PREHEIGH ) C----------------------------------------------------------------------- C PRESHO(WER LINKING ROUTINE) C C THIS SUBROUTINE MAKES THE LINK WITH THE PRESHOWER C-ROUTINES C OF P. HOMOLA (KRAKOW) TO SIMULATE THE INTERACTIONS OF AN EeV GAMMA C IN THE EARTH''S MAGNETIC FIELD FAR ABOVE THE ATMOSPHERE. C THIS SUBROUTINE IS CALLED FROM AAMAIN. C ARGUMENTS: C PRESTART = STARTING ALTITUDE OF GAMMA PRESHOWER (CM) C PREHEIGH = FIRST INTERACTION IN EARTH MAGNETIC FIELD (CM) C----------------------------------------------------------------------- IMPLICIT NONE #define __BUFFSINC__ #define __GENERINC__ #define __GLOBALINC__ #define __PAMINC__ #define __PARPARINC__ #define __REJECTINC__ #define __RUNPARINC__ #if __CURVED__ #define __OBSPARINC__ #define __TIMLIMINC__ #endif #include "corsika.h" DOUBLE PRECISION AMARGN,HEIGH,PART_OUT(8,100000),PREHEIGH,PRESTART DOUBLE PRECISION GLONGD,GLATD,PHIP1,SINTT REAL AMARGIN,PRESTAR,PREHEI,THETAPP,PHIPP,GRFYER INTEGER I,ITYPI,J,LPARTI,IPRINT,MODCOR,NRUNS #if __CURVED__ DOUBLE PRECISION DIST,TEA,XXX,YYY,DIAG #endif SAVE EXTERNAL HEIGH DATA MODCOR / 1 /, NRUNS / 1 / C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'PRESHO: START' C CHECK THE VALIDITY OF THE YEAR (MUST BE BETWEEN 1965 AND 2015) GRFYEAR = MAX(GRFYEAR,1965.D0) GRFYEAR = MIN(GRFYEAR,2015.D0) GRFYER = GRFYEAR C TOP OF ATMOSPHERE IN KM. TAKE A VERY SMALL VALUE OF MASS OVERLAY C TO AVOID HANGUP IN EGS4 AMARGN = HEIGH( 1.D-9 ) AMARGIN = AMARGN * 1.D-5 ITYPI = PRMPAR(0) C ZENITH ANGLE IN RADIANS #if __CURVED__ THETAPP = ACOS( PRMPAR(15) ) #else THETAPP = ACOS( PRMPAR(2) ) #endif IF ( PRMPAR(3) .NE. 0.D0 .OR. PRMPAR(4) .NE. 0.D0 ) THEN PHIP1 = ATAN2( PRMPAR(4), PRMPAR(3) ) ELSE PHIP1 = 0.D0 ENDIF PHIPP = PHIP1 GLONGD = GLONG GLATD = GLATI C SET FLAG IPRINT FOR PRINTING OF PRESHW PROGRAM IF ( IPREPR .LE. 0 ) THEN C NO PRINTING IPRINT = 0 ELSEIF ( IPREPR .EQ. 1 ) THEN IF ( FPRINT .OR. DEBUG ) THEN IPRINT = 1 ELSE IPRINT = 0 ENDIF ELSEIF ( IPREPR .GE. 2 ) THEN C ALWAYS PRINTING IPRINT = 1 ENDIF IF (DEBUG) WRITE(MDEBUG,*) 'PRESHO: PRESHW CALL WITH ITYPI=',ITYPI C NOW CALL THE C-ROUTINE PACKAGE OF P. HOMOLA CALL PRESHWVETO( ITYPI,PRMPAR(1),THETAPP,PHIPP,AMARGIN,GLONGD * ,GLATD,GRFYER,IPRINT, MODCOR,NRUNS, * PART_OUT,PRESTAR,PREHEI,LPARTI ) IF ( LPARTI .GT. 1 ) THEN FNPRIM = .TRUE. ELSE FNPRIM = .FALSE. ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) * 'PRESHO: AFTER PRESHW CALL, LPARTI=',LPARTI,' FNPRIM=',FNPRIM C PRESTART IS STARTING ALTITUDE OF PRESHOWER IN CM (PRESTAR IN KM) PRESTART = PRESTAR * 1.D5 C PREHEIGH IS FIRST INTERACT. HEIGHT OF PRESHOWER IN CM (PREHEI IN KM) PREHEIGH = PREHEI * 1.D5 C STORE PARAMETERS COMMON TO ALL PARTICLES SECPAR( 5) = AMARGN ! HEIGHT OF ATMOSPHERIC BORDER IN CM SECPAR( 9) = GEN ! GENERATION COUNTER SECPAR(10) = AMARGN ! LEVEL OF LAST HADRONIC INTERACTION C POLARIZATION NOT USED FOR EM-PARTICLES SECPAR(11) = 0.D0 ! POLARIZATION SECPAR(12) = 0.D0 ! POLARIZATION C NO THINNING IN THE PRESHOWER PROGRAM SECPAR(13) = 1.D0 #if __PARALLEL__ C SET PARTICLE BELOW ECUT INITIALLY SECPAR(39) = -1.D0 #endif #if __CURVED__ C CALCULATE GLOBAL PARAMETERS VALID FOR ALL SECONDARIES OF PRESHOWER. C FOR FURTHER COMMENTS SEE SUBR. COOINC. C THIS APPROACH HOLDS, AS ALL PRESHOWER PARTICLES ARRIVE WITHIN THE C SAME SPOT, DIRECTION AND TIME AT TOP OF ATMOSPHERE. C DISTANCE DIAG BETWEEN DETECTOR POSITION X=Y=0, Z = OBSLEV(1) AND C STARTING POINT OF SHOWER AXIS AT BORDER OF ATMOSPHERE DIAG = SQRT( (C(1)+AMARGN)**2 - (C(1)+OBSLEV(1))**2 * * (1.D0-PRMPAR(15))*(1.D0+PRMPAR(15)) ) * - (C(1)+OBSLEV(1)) * PRMPAR(15) C SET TIME LIMIT TO AVOID UNNECESSARY COMPUTING TIME WITH PARTICLES C WELL ABOVE THE TIME LIMIT. THE TIME LIMIT IS GIVEN BY THE C PROPAGATION TIME ALONG DIAG WITH SPEED OF LIGHT AND SOME ADDITIONAL C DISTANCE DOWNSTREAM OF THE DETECTOR DLIMIT (CM). C FOR SAFETY ADD ADDITIONAL 20 MICROSEC. (ALL TIME UNITS IN SEC) IF ( DSTLIM .GT. 0.D0 ) THEN TIMLIM = ( DIAG + DSTLIM ) / C(25) + 2.D-5 ELSE C DEFAULT LIMIT IS 20 KM TIMLIM = ( DIAG + 20.D5 ) / C(25) + 2.D-5 ENDIF IF ( DEBUG .OR. LTMLMPR ) WRITE(MDEBUG,*) 'PRESHO: DIAG=',DIAG, * 'DSTLIM=',DSTLIM,' TIMLIM=',TIMLIM C CALCULATE APPARENT HEIGHT (HAPP) PRMPAR(14) = OBSLEV(1) + DIAG * PRMPAR(15) C CALCULATE COSTEA PRMPAR(16) = (C(1)+PRMPAR(14)) / (C(1)+AMARGN) IF ( DEBUG ) WRITE(MDEBUG,*) 'PRESHO: HAPP,COSTEA,DIAG =', * SNGL(PRMPAR(14)),PRMPAR(16),SNGL(DIAG) PRMPAR(16) = MIN( 1.D0, PRMPAR(16) ) TEA = ACOS( PRMPAR(16) ) DIST = C(1) * TEA XXX = -DIST * COS( PHIP1 ) YYY = -DIST * SIN( PHIP1 ) IF ( DEBUG ) WRITE(MDEBUG,*) 'PRESHO: X,Y,TEA,DIST =', * SNGL(XXX),SNGL(YYY),SNGL(TEA),SNGL(DIST) #endif C STORE PARTICLES COORDINATES OF PRESHOWER INTO CORSIKA STACK DO J = 1, LPARTI SECPAR(0) = PART_OUT(1,J) ! PARTICLE IDENTIFIER IF ( PAMA(NINT( SECPAR(0) )) .NE. 0.D0 ) THEN C LORENTZ GAMMA FACTOR SECPAR(1) = PART_OUT(2,J)/PAMA(NINT( SECPAR(0) )) ELSE C ENERGY(GEV) FOR MASSLESS PARTICLES (GAMMAS) SECPAR(1) = PART_OUT(2,J) ENDIF #if __CURVED__ C APPARENT HEIGHT ABOVE DETECTOR IN CARTESIAN DETECTOR SYSTEM SECPAR(14) = OBSLEV(1) + DIAG * PART_OUT(3,J) C COSINE OF ZENITH ANGLE AT DETECTOR SYSTEM SECPAR(15) = PART_OUT(3,J) C ANGLE AT CENTER OF EARTH OF PARTICLE RELATIVE TO DETECTOR CENTER SECPAR(16) = (C(1)+SECPAR(14)) / (C(1)+AMARGN) C COSINE OF LOCAL ZENITH ANGLE SECPAR(2) = (DIAG + (C(1)+OBSLEV(1))*SECPAR(15))/(C(1)+AMARGN) SECPAR(6) = ( SQRT( (C(1)+AMARGN)**2 * * (SECPAR(2)+1.D0)*(SECPAR(2)-1.D0) * + (C(1)+PREHEIGH)**2 ) * - (C(1)+AMARGN)*SECPAR(2) ) / C(25) SECPAR(7) = PART_OUT(6,J) + XXX ! X-POSITION SECPAR(8) = PART_OUT(7,J) + YYY ! Y-POSITION #else SECPAR(2) = PART_OUT(3,J) ! COSINE OF ZENITH ANGLE SECPAR(6) = ( PREHEIGH - AMARGN ) / ( PRMPAR(2)*C(25) ) !!! SECPAR(7) = PART_OUT(6,J) ! X-POSITION SECPAR(8) = PART_OUT(7,J) ! Y-POSITION #endif SINTT = SQRT( (1.D0-SECPAR(2))*(1.D0+SECPAR(2)) ) SECPAR(3) = SINTT * COS( PART_OUT(4,J) ) ! AZIMUTHAL ANGLE SECPAR(4) = SINTT * SIN( PART_OUT(4,J) ) ! AZIMUTHAL ANGLE #if __THIN__ IF ( DEBUG ) WRITE(MDEBUG,444) (SECPAR(I),I = 1,9),SECPAR(13) 444 FORMAT(' PRESHO: SECPAR=',1P,10E11.3) #else IF ( DEBUG ) WRITE(MDEBUG,444) (SECPAR(I),I = 1,9) 444 FORMAT(' PRESHO: SECPAR=',1P,9E11.3) #endif CALL TSTACK ENDDO IF ( DEBUG ) WRITE(MDEBUG,*) 'PRESHO: ',LPARTI, * ' PARTICLES TRANSMITTED FROM PRESHW' EVTE(267) = REAL( LPARTI ) C SET STOP FLAG IF 'STOP OF EVENT' IS DEMANDED FOR NO PRESHOWERING IF ( LPARTI .LE. 1 .AND. IPRSTP .NE. 0 ) THEN FPRSTP = .TRUE. ELSE FPRSTP = .FALSE. ENDIF RETURN END #endif *-- Author : D. HECK IK FZK KARLSRUHE 26/06/1995 C======================================================================= SUBROUTINE PRTIME( TTIME ) C----------------------------------------------------------------------- C PR(INT) TIME C C PRINTS PRESENT DATE AND TIME AND GIVES IT IN A FORMAT SUITED FOR THE C RUNHEADER AND EVENTHEADER. C THIS SUBROUTINE IS CALLED FROM AAMAIN AND START. C ARGUMENT: C TTIME = TIME (YYMMDD) C C IF OUR DATE ROUTINE DOES NOT FIT TO YOUR COMPUTER, PLEASE REPLACE C IT BY A SUITABLE ROUTINE OF YOUR SYSTEM C----------------------------------------------------------------------- IMPLICIT NONE #define __RUNPARINC__ #include "corsika.h" DOUBLE PRECISION TTIME #if __UNIX__ && __OLDDATE__ REAL SECNDS EXTERNAL SECNDS INTEGER ISECO #elif __UNIX__ && __OLDDATE2__ INTEGER LTIME(3) #elif __UNIX__ && __IBMRISC__ CHARACTER CYYMMDD*8, CHHMMSS*8 #elif __UNIX__ && !__IBMRISC__ && !__TIMERC__ CHARACTER*8 YYYYMMDD CHARACTER*10 HHMMSS #elif __MAC__ INTEGER ISECO #endif INTEGER IYEAR,MONTH,IDAY,IHOUR,IMINU,ISEC SAVE C----------------------------------------------------------------------- #if __TIMERC__ C COMPILERS WITH OLD DATE FUNCTIONS ONLY HAVE TO CALL SEKDAT HERE CALL SEKDAT( IYEAR,MONTH,IDAY,IHOUR,IMINU,ISEC ) WRITE(MONIOU,100) IDAY,MONTH,IYEAR,IHOUR,IMINU,ISEC TTIME = MOD(IYEAR,100)*10000 + MONTH*100 + IDAY #elif __UNIX__ && __OLDDATE__ C IF YOUR COMPILER DOES NOT KNOW ROUTINES IDATE AND SECNDS C REPLACE THESE CALLS BY CALLS TO YOUR SYSTEM ROUTINES TO C FILL THE INTEGERS: IYEAR, MONTH, IDAY, IHOUR, IMINU, ISEC CALL IDATE( MONTH,IDAY,IYEAR ) C SECONDS, MINUTS, HOURS ISECO = INT( SECNDS(0.0) ) ISEC = MOD(ISECO,60) ISECO = ISECO/60 IMINU = MOD(ISECO,60) ISECO = ISECO/60 IHOUR = MOD(ISECO,24) WRITE(MONIOU,100) IDAY,MONTH,IYEAR,IHOUR,IMINU,ISEC TTIME = MOD(IYEAR,100)*10000 + MONTH*100 + IDAY #elif __UNIX__ && __OLDDATE2__ C IF YOUR COMPILER DOES NOT KNOW ROUTINES IDATE AND SECNDS C REPLACE THESE CALLS BY CALLS TO YOUR SYSTEM ROUTINES TO C FILL THE INTEGERS: IYEAR, MONTH, IDAY, IHOUR, IMINU, ISEC CALL IDATE( MONTH,IDAY,IYEAR ) C SECONDS, MINUTS, HOURS (ALTERNATIVE FOR betaLINUX at CC.in2p3.fr) CALL ITIME( LTIME ) ISEC = LTIME(3) IMINU = LTIME(2) IHOUR = LTIME(1) WRITE(MONIOU,100) IDAY,MONTH,IYEAR,IHOUR,IMINU,ISEC TTIME = MOD(IYEAR,100)*10000 + MONTH*100 + IDAY #elif __UNIX__ && !__OLDDATE__ && !__IBMRISC__ 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 CALL DATE_AND_TIME( YYYYMMDD, HHMMSS ) READ(YYYYMMDD,'(I4,2I2)') IYEAR,MONTH,IDAY READ(HHMMSS,'(3I2)') IHOUR,IMINU,ISEC WRITE(MONIOU,100) IDAY,MONTH,IYEAR,IHOUR,IMINU,ISEC TTIME = MOD(IYEAR,100)*10000 + MONTH*100 + IDAY #elif __UNIX__ && __IBMRISC__ C FOR COMPILERS ON IBM RISC MACHINES LIKE IBM RS 6000 CALL DATE( CYYMMDD ) CALL CLOCK_( CHHMMSS ) READ(CYYMMDD,'(I2,1X,I2,1X,I2)') MONTH,IDAY,IYEAR READ(CHHMMSS,'(I2,1X,I2,1X,I2)') IHOUR,IMINU,ISEC IYEAR = 2000 + IYEAR TTIME = MOD(IYEAR,100)*10000 + MONTH*100 + IDAY #elif __MAC__ C DATE AND TIME ROUTINES FOR MACINTOSH CALL DATE( MONTH,IDAY,IYEAR ) CALL TIME( ISECO ) C SECONDS, MINUTS, HOURS, YEAR ISEC = MOD(ISECO,60) ISECO = ISECO/60 IMINU = MOD(ISECO,60) ISECO = ISECO/60 IHOUR = MOD(ISECO,24) WRITE(MONIOU,100) IDAY,MONTH,IYEAR,IHOUR,IMINU,ISEC TTIME = MOD(IYEAR,100)*10000 + MONTH*100 + IDAY #endif #if __TIMERC__ 100 FORMAT(' PRESENT TIME : ',I2.2,'.',I2.2,'.',I4,I4.2,':',I2.2, * ':',I2.2,' UTC') #else 100 FORMAT(' PRESENT TIME : ',I2.2,'.',I2.2,'.',I4,I4.2,':',I2.2, * ':',I2.2) #endif RETURN END *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= DOUBLE PRECISION FUNCTION PTRANS() C----------------------------------------------------------------------- C TRANS(VERSE MOMENTUM) C C RANDOM SELECTION OF TRANSVERSE MOMENTUM C DISTRIBUTION IS OF FORM X*EXP(-X) C THIS FUNCTION IS CALLED FROM PIGEN1, PIGEN2. C----------------------------------------------------------------------- IMPLICIT NONE #define __PARPARINC__ #define __RANDPAINC__ #define __RUNPARINC__ #include "corsika.h" DOUBLE PRECISION GX(0:50),HX(0:50),DX,SUMI,TT,X,XX,ZZ INTEGER I,IMAX LOGICAL FIRST SAVE C DX IS STEPSIZE FOR APPROXIMATING CURVE DATA FIRST / .TRUE. /, DX / 0.5D0 / C----------------------------------------------------------------------- C IF ( DEBUG ) WRITE(MDEBUG,*) 'PTRANS:' 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 = C(34) / 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 CALL RMMARD( RD,2,1 ) I = 0 1 CONTINUE I = I+1 IF ( GX(I) .LT. RD(1) ) GOTO 1 XX = ( (RD(1)-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 ( RD(2)*ZZ .GT. TT ) GOTO 11 C GET REQUIRED PEAK VALUE PTRANS = XX * C(12) IF ( DEBUG ) WRITE(MDEBUG,*) 'PTRANS: PT = ',SNGL(PTRANS) RETURN END #if __CURVED__ && __SLANT__ *-- Author : V. Chernatkin Univ. Nantes 00/00/2003 C======================================================================= DOUBLE PRECISION FUNCTION CRSRADIUS0( RR1,DT,IS,A,JA ) C----------------------------------------------------------------------- C CRSRADIUS0 CALCULATES RADIUS OF THE ENDING POINT (CM) CORRESPONDING C TO A GIVEN SLANT DEPTH C THIS FUNCTION IS CALLED FROM DT2DL. C ARGUMENTS: C RR1 = RADIUS OF THE STARTING POINT (CM) C DT = SLANT DEPTH INTERVAL (G/CM^2) C IS = SIGN FOR DIRECTION (<0 DT FROM RR1 > CRSRADIUS0, C >0 DT FROM CRSRADIUS0 > RR1) C A = IMPACT RADIUS (CM) C JA = ATMOSPHERIC LAYER C----------------------------------------------------------------------- IMPLICIT NONE #define __ATMOSINC__ #define __ATMOS2INC__ #define __ATMOSLINC__ #define __OBSPARINC__ #define __PARPARINC__ #define __RUNPARINC__ #include "corsika.h" DOUBLE PRECISION PRE PARAMETER (PRE=1D-5) DOUBLE PRECISION A,AI,DDT,DT,RR1,RT,R1,R2,S,X2 INTEGER I,IS,J,JA DOUBLE PRECISION CRSDEPTH0 SAVE EXTERNAL CRSDEPTH0 C----------------------------------------------------------------------- RT = C(1) R1 = RR1 DDT = DT IF ( DDT .EQ. 0.D0 ) THEN CRSRADIUS0 = R1 RETURN ENDIF S = DBLE( IS ) R2 = R1 J = ABS( JA ) IF ( A .GT. R1 ) THEN WRITE(MONIOU,*) 'CRSRADIUS0: DT, RR1,A=', DT, RR1, A STOP 'CRSRADIUS0: INCORRECT INPUT R < A!' ENDIF DO I = 0,100 !TYPICAL <5 R1 = R2 IF( J .EQ. 5 )THEN !LINEAR EVOLUTION X2 = S * DDT * SQRT( (R1-A)*(R1+A) ) / R1 * CATM(5)/BATM(5) R2 = R1 + X2 IF( JA .LT. 0 .AND. & ( R2 .LT. HLAYC(5) + RT .OR. R2 .GT. HLAYC(6) + 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 = SQRT( (R1-A)*(R1+A) ) & + S * DDT * EXP( DATM(J)*(R1-RT) ) * CATM(J) / BATM(J) IF ( JA .LT. 0 .AND. X2 .LT. 0.D0 ) THEN !IF NONSENSE 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 = -DATM(J) * SQRT( (R1-A)*(R1+A) ) * S * DDT / R1 & + EXP( -DATM(J)*(R1-RT) ) * BATM(J) * DATM(J) IF ( AI .LE. 0.D0 .AND. JA .LT. 0 ) THEN !IF NONSENSE 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 DDT = DDT - CRSDEPTH0( R1,R2,A,J ) IF ( DDT .LE. 0.D0 ) THEN S = -S DDT = -DDT ENDIF IF ( DDT/DT .LT. PRE ) GOTO 1 ENDDO 1 CRSRADIUS0 = R2 RETURN END #endif *-- 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 THIS FUNCTION IS CALLED FROM HDPM, LEADDF, PARRAP, QGSTOR, C UPDATE, AND VAPOR. C ARGUMENTS: C A = MEAN VALUE C B = STANDARD DEVIATION C----------------------------------------------------------------------- IMPLICIT NONE #define __CONSTAINC__ #define __RANDPAINC__ #define __RUNPARINC__ #if __CONEX__ #define __CONEXINC__ #endif #include "corsika.h" #if __CONEX__ integer iseedcx,lseq common /cxseed/iseedcx(3,2),lseq #endif DOUBLE PRECISION A,B,RR INTEGER LLSEQ SAVE C----------------------------------------------------------------------- LLSEQ = 1 #if __CONEX__ IF ( FINCNX ) LLSEQ = lseq #endif C IF ( DEBUG ) WRITE(MDEBUG,100) SNGL(A),SNGL(B) C100 FORMAT(' RANNOR: A,B=',1P,2E10.3) ctp write(mdebug,*)'knor,u1,u2,fac,llseq',knor,u1,u2,fac,llseq IF ( KNOR ) THEN 1 CONTINUE CALL RMMARD( RD,2,LLSEQ ) U1 = 2.D0*RD(1) - 1.D0 U2 = 2.D0*RD(2) - 1.D0 RR = U1**2 + U2**2 IF ( RR .GE. 1.D0 .OR. RR .EQ. 0.D0 ) GOTO 1 FAC = SQRT( (-2.D0) * LOG( RR ) / RR ) RANNOR = FAC * U1 * B + A KNOR = .FALSE. ELSE RANNOR = FAC * U2 * B + A KNOR = .TRUE. ENDIF C IF ( DEBUG ) WRITE(MDEBUG,101) RANNOR C101 FORMAT('+',34X,' RANNOR =',1P,E12.5) RETURN END *-- Author : Konrad Bernloehr, Uni Hamburg 30/08/1999 C======================================================================= SUBROUTINE RCLCHK( MUNIT,NLREC,IERR ) C----------------------------------------------------------------------- C R(E)C(ORD)L(ENGTH PARAMETER) CH(EC)K C C CHECK IF THE RECL PARAMETER FOR OPENING UNFORMATTED DIRECT-ACCESS C FILES IS INTERPRETED AS IT SHOULD. C THIS SUBROUTINE IS CALLED FROM FILOPN. C ARGUMENTS: C MUNIT = UNIT NUMBER FOR TEMPORARY FILE C NLREC = 1 FOR RECL IN BYTES, 4 FOR RECL IN 4-BYTE WORDS C IERR = ERROR INDICATOR C----------------------------------------------------------------------- IMPLICIT NONE #define __RUNPARINC__ #include "corsika.h" INTEGER IERR,MUNIT,NLREC INTEGER IDAT(5) SAVE C----------------------------------------------------------------------- IERR = 0 OPEN(UNIT=MUNIT,STATUS='SCRATCH', * FORM='UNFORMATTED',ACCESS='DIRECT',RECL=16/NLREC) C IF NLREC=4 BUT RECL COUNTED IN BYTES, THE '990' STATEMENT C WILL TYPICALLY BE JUMPED TO, AS A RESULT OF A WRITE ERROR. WRITE(MUNIT,REC=1,ERR=990) 1,2,3,4 WRITE(MUNIT,REC=3,ERR=990) 9,10,11,12 WRITE(MUNIT,REC=2,ERR=990) 5,6,7,8 C IF NLREC=4 BUT RECL IS COUNTED IN BYTES AND NO WRITE C ERROR WAS REPORTED, RECORDS SHOULD HAVE OVERLAPED AND C THE DATA IS CORRUPTED. READ(MUNIT,REC=1) IDAT(1),IDAT(2),IDAT(3),IDAT(4) IF ( IDAT(1) .NE. 1 .OR. IDAT(2) .NE. 2 .OR. * IDAT(3) .NE. 3 .OR. IDAT(4) .NE. 4 ) IERR = 1 READ(MUNIT,REC=2) IDAT(1),IDAT(2),IDAT(3),IDAT(4) IF ( IDAT(1) .NE. 5 .OR. IDAT(2) .NE. 6 .OR. * IDAT(3) .NE. 7 .OR. IDAT(4) .NE. 8 ) IERR = IERR + 2 READ(MUNIT,REC=3) IDAT(1),IDAT(2),IDAT(3),IDAT(4) IF ( IDAT(1) .NE. 9 .OR. IDAT(2) .NE. 10 .OR. * IDAT(3) .NE. 11 .OR. IDAT(4) .NE. 12 ) IERR = IERR + 4 C IF NLREC=1 BUT RECL COUNTED IN WORDS IS USUALLY NOT CAUGHT BY C THIS ROUTINE, BUT SHOULD BE RATHER HARMLESS. THE ONLY BAD C EFFECT EXPECTED IS THAT THE EXTERNAL STACK FILE WILL BE FOUR C TIMES AS LARGE AS NEEDED. #if __GFORTRAN__ C Cannot check with gfortran because read errors not caught. goto 900 #else C WELL, LET''S TRY TO CATCH THAT ONE AS WELL (READ ERROR IS O.K.) READ(MUNIT,REC=1,ERR=900) IDAT(1),IDAT(2),IDAT(3),IDAT(4),IDAT(5) WRITE(MONIOU,*) 'RCLCHK: ' WRITE(MONIOU,*) 'THE HANDLING OF UNFORMATTED DIRECT-ACCESS FILES', * ' ON YOUR MACHINE SEEMS TO' WRITE(MONIOU,*) 'BE NOT AS EXPECTED. THE TEMPORARY CORSIKA ', * 'EXTERNAL STACK FILE MAY BECOME' WRITE(MONIOU,*) 'LARGER THAN NEEDED BUT NO DATA CORRUPTION IS ', * 'EXPECTED THERE.' WRITE(MONIOU,*) 'PERHAPS YOU USED THE BYTERECL OPTION FOR ', * 'EXTRACTING CORSIKA BUT DO NOT NEED IT.' WRITE(MONIOU,*) ' ' IERR = -1 RETURN #endif 990 IERR = 99 900 CLOSE( MUNIT ) IF ( IERR .NE. 0 ) THEN WRITE(MONIOU,*) 'RCLCHK: ' WRITE(MONIOU,*) 'THE HANDLING OF UNFORMATTED DIRECT-ACCESS ', * 'FILES ON YOUR MACHINE IS NOT AS' WRITE(MONIOU,*) 'EXPECTED. THIS MAY WELL LEAD TO CORRUPTION ', * 'OF THE CORSIKA EXTERNAL STACK.' WRITE(MONIOU,*) 'PERHAPS THIS PROBLEM IS DUE TO A MISSING ', * 'BYTERECL OPTION FOR EXTRACTING' WRITE(MONIOU,*) 'CORSIKA FROM THE SOURCE FILE. IT MAY ALSO BE ', * 'DUE TO USING COMPILER FLAGS' WRITE(MONIOU,*) 'INAPPROPRIATE FOR THE CORSIKA VERSION ', * 'EXTRACTED.' WRITE(MONIOU,*) ' ' ENDIF RETURN END *-- Author : D. HECK IK FZK KARLSRUHE 16/07/1999 C======================================================================= SUBROUTINE RHO0DC(KFROM) C----------------------------------------------------------------------- C RHO(0) D(E)C(AY) C C TWO PARTICLE DECAY WITH FULL KINEMATIC; ENERGY AND MOMENTA CONSERVED C RHO(0) DECAYS INTO PI(+) + PI(-) WITH DIPOLE CHARACTERISTIC. C THIS ROUTINE CONTAINS NOW (SEPT. 2015) THE RARE DECAY C RHO(0)--> MU+ + MU- WITH BRANCHING RATIO 4.5E(-5) C FOR THIS RARE DECAY ISOTROPE CHARACTERISTIC IS ASSUMED. C THIS SUBROUTINE IS CALLED FROM RHOGEN AND FROM RESDEC. C ARGUMENT: C KFROM = 0 CALL FROM RESDEC C = 1 CALL FROM RHOGEN C----------------------------------------------------------------------- IMPLICIT NONE #define __CONSTAINC__ #define __GENERINC__ #define __LONGIINC__ #define __PAMINC__ #define __PARPARINC__ #define __POLARINC__ #define __RANDPAINC__ #define __RUNPARINC__ #define __STACKEINC__ #if __AUGERHIST__ #define __OBSPARINC__ #endif #include "corsika.h" DOUBLE PRECISION AUX2A,BETA,COSTCM,COSTH3,COSTH4, * FAC1,FAC2,GAMMA3,GAMMA4,PHI4,WORK1,WORK2 DOUBLE PRECISION PAMSEC INTEGER I,KFROM,LHERHO #if __AUGERHIST__ DOUBLE PRECISION EDEP,THICKLOC,THICK INTEGER II,LL EXTERNAL THICK #endif #if __EHISTORY__ INTEGER IK #endif SAVE C----------------------------------------------------------------------- #if __THIN__ IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=0,9),CURPAR(13) 444 FORMAT(' RHO0DC: CURPAR=',1P,11E11.3) #else IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=0,9) 444 FORMAT(' RHO0DC: CURPAR=',1P,9E11.3,0P,F10.0) #endif C COPY VERTEX COORDINATES INTO SECPAR DO I = 5, 8 SECPAR(I) = CURPAR(I) ENDDO C GENERATION COUNTER AND ALEVEL ALREADY SET IN RHOGEN RSP. RESDEC C SET GENERATION AND LEVEL OF LAST INTERACTION * SECPAR( 9) = GEN * SECPAR(10) = ALEVEL C RESET POLARIZATION, NOT USED FOR PARTICLES OTHER THAN MUONS YET #if __THIN__ C SET WEIGHT SECPAR(13) = CURPAR(13) #endif #if __CURVED__ SECPAR(14) = CURPAR(14) SECPAR(15) = CURPAR(15) SECPAR(16) = CURPAR(16) #endif #if __INTTEST__ SECPAR(17) = CURPAR(17) #endif IF ( LLONGI ) THEN IF ( KFROM .EQ. 1 ) THEN C RHO(0) IS PRODUCED IN PHOTONUCLEAR INTERACTION LHERHO = LPCTE(NP) ELSE C RHO(0) IS PRODUCED IN HADRONIC INTERACTION LHERHO = INT( THICKH * THSTPI + 1.D0 ) ENDIF ENDIF C ADD RARE DECAY RHO(0) ---> MU+ + MU- (Sept. 2015) CALL RMMARD( RD,1,1 ) IF ( RD(1) .LT. 0.999955D0 ) THEN C PRODUCE PI(+) + PI(-) (FIRST WITH NEGATIVE CHARGE) PAMSEC = PAMA(9) SECPAR(0) = 9.D0 C RESET POLARIZATION, NOT USED FOR PARTICLES OTHER THAN MUONS SECPAR(11) = 0.D0 SECPAR(12) = 0.D0 ELSE C PRODUCE MU(+) + MU(-) (FIRST WITH NEGATIVE CHARGE) PAMSEC = PAMA(6) SECPAR(0) = 6.D0 CALL RMMARD( RD, 2, 1 ) POLART = 2.D0 * RD(1) - 1.D0 POLARF = PI2 * RD(2) C POLARIZATION FOR MU- IS SET AFTER THE KINEMATICS IS COMPLETE ENDIF C CALCULATE AUXILIARY QUANTITIES BETA = SQRT( (CURPAR(1)-1.D0)*(CURPAR(1)+1.D0) ) / CURPAR(1) AUX2A = 0.5D0 * PAMA(51) / PAMSEC WORK1 = CURPAR(1) * AUX2A WORK2 = BETA * CURPAR(1) * SQRT( (AUX2A-1.D0)*(AUX2A+1.D0) ) C DETERMINE POLAR ANGLE IN CM SYSTEM WITH ISOTROPY 210 CONTINUE CALL RMMARD( RD,2,1 ) COSTCM = 2.D0 * RD(1) - 1.D0 IF ( KFROM .EQ. 1 ) THEN C RHO(0) COMES FROM PHOTONUCLEAR INTERACTION WITH ANGULAR DEPENDENCE C DETERMINE POLAR ANGLE IN CM SYSTEM WITH DIPOLE CHARACTERISTICS C PURE DIPOLE RADIATION: W(COSTH) = 1-3/5*COSTH**2 C PARAMETERIZATION FROM H1 COLLAB. [NUCL.PYS. B463(1996)3] C THIS PARAMETERIZATION SEEMS UNPHYSICALLY, AS IT RESULTS IN C NEGATIVE RATE IN FORWARD OR BACKWARD DIRECTION C IF ( RD(2) .GT. 1.D0 - 1.1982D0 * COSTCM**2 ) GOTO 210 C PARAMETERIZATION FROM ZEUSS COLLAB. [Z.PHYS. C69(1995)39] IF ( RD(2) .GT. 1.D0 - 0.8836D0 * COSTCM**2 ) GOTO 210 ENDIF GAMMA3 = WORK1 + WORK2 * COSTCM GAMMA4 = CURPAR(1) * (PAMA(51)/PAMSEC) - GAMMA3 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C FIRST PRODUCT PARTICLE HAS NEGATIVE CHARGE PI(-) RSP. MU(-) COSTH4 = MIN( 1.D0, (CURPAR(1)*GAMMA4 - AUX2A) * / (BETA*CURPAR(1)*SQRT( (GAMMA4-1.D0)*(GAMMA4+1.D0))) ) CALL RMMARD( RD,1,1 ) PHI4 = RD(1) * PI2 CALL ADDANG3( CURPAR(2),CURPAR(3),CURPAR(4), COSTH4,PHI4, * SECPAR(2),SECPAR(3),SECPAR(4) ) #if __UPWARD__ IF ( SECPAR(2) .GE. -1.D0 ) THEN #else IF ( SECPAR(2) .GT. C(29) ) THEN #endif SECPAR(1) = GAMMA4 #if __THIN__ IF ( DEBUG ) WRITE(MDEBUG,445) (SECPAR(I),I=0,9),SECPAR(13) 445 FORMAT(' RHO0DC: SECPAR=',1P,9E11.3,0P,F10.0,1P,E10.3) #else IF ( DEBUG ) WRITE(MDEBUG,445) (SECPAR(I),I=0,9) 445 FORMAT(' RHO0DC: SECPAR=',1P,9E11.3,0P,F10.0) #endif #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER PARTICLE DO IK = 0, 8 SECPAR(17+IK) = CURPAR(IK) ENDDO #if __THIN__ SECPAR(26) = CURPAR(13) #endif #endif C POLARIZATION FOR MU(-) IF ( SECPAR(0) .EQ. 6.D0 ) THEN SECPAR(11) = POLART SECPAR(12) = POLARF ENDIF CALL TSTACK C RESET POLARIZATION SECPAR(11) = 0.D0 SECPAR(12) = 0.D0 ELSE IF ( LLONGI ) THEN IF ( SECPAR(0) .GT. 7.D0 ) THEN C WE HAVE A CHARGED PION(-) C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT FAC1 = 0.25D0 FAC2 = 0.75D0 #if __THIN__ C ADD TO THE HADRON ENERGY DEPOSIT DLONG(LHERHO,17) = DLONG(LHERHO,17) * + GAMMA4*PAMA(9)*CURPAR(13)*FAC1 C ADD TO THE NEUTRINO DEPOSIT DLONG(LHERHO,18) = DLONG(LHERHO,18) * + GAMMA4*PAMA(9)*CURPAR(13)*FAC2 #else C ADD TO THE HADRON ENERGY DEPOSIT DLONG(LHERHO,17) = DLONG(LHERHO,17) * + GAMMA4*PAMA(9)*FAC1 C ADD TO THE NEUTRINO DEPOSIT DLONG(LHERHO,18) = DLONG(LHERHO,18) * + GAMMA4*PAMA(9)*FAC2 #endif ELSE C WE HAVE A MUON(-) TO ADD TO THE MUON ENERGY DEPOSIT #if __THIN__ DLONG(LHERHO,15) = DLONG(LHERHO,15) * + GAMMA4*PAMA(6)*CURPAR(13) #else DLONG(LHERHO,15) = DLONG(LHERHO,15) + GAMMA4*PAMA(6) #endif ENDIF ENDIF #if __AUGERHIST__ THICKLOC = THICK( CURPAR(5) ) DO LL = 1, NOBSLV IF ( THICKLOC .GE. THCKOB(LL) .AND. * THICKLOC .LT. THCKOB(LL)+SAMPTH ) THEN C THICKH IS WITHIN 1 G/CM^2 BELOW OBSLEV(LL) C BRING THE ENERGY BELOW ANGULAR CUT TO THE HISTO OF LEVEL LL OUTPAR( 0) = SECPAR(0) OUTPAR( 1) = GAMMA4 DO II = 2, 8 OUTPAR(II) = SECPAR(II) ENDDO OUTPAR( 9) = GEN OUTPAR(10) = ALEVEL OUTPAR(13) = CURPAR(13) EDEP = OUTPAR(1) * PAMA(NINT(SECPAR(0) )) * CURPAR(13) C WE HAVE ANGULAR CUT CALL AUGERDEPFIL( EDEP,LL,1 ) ELSEIF ( THICKLOC .LT. THCKOB(LL) ) THEN GOTO 111 ENDIF ENDDO 111 CONTINUE #endif ENDIF C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C SECOND PRODUCT PARTICLE HAS POSITIVE CHARGE PI(+) RSP. MU(+) COSTH3 = MIN( 1.D0, (CURPAR(1) * GAMMA3 - AUX2A) * / (BETA*CURPAR(1)*SQRT( (GAMMA3-1.D0)*(GAMMA3+1.D0) )) ) CALL ADDANG3( CURPAR(2),CURPAR(3),CURPAR(4), COSTH3,PHI4+PI, * SECPAR(2),SECPAR(3),SECPAR(4) ) C SET PARTICLE TYPE WITH POSITIVE CHARGE SECPAR(0) = SECPAR(0) - 1.D0 #if __UPWARD__ IF ( SECPAR(2) .GE. -1.D0 ) THEN #else IF ( SECPAR(2) .GT. C(29) ) THEN #endif SECPAR(1) = GAMMA3 #if __THIN__ IF ( DEBUG ) WRITE(MDEBUG,445) (SECPAR(I),I=0,9),SECPAR(13) #else IF ( DEBUG ) WRITE(MDEBUG,445) (SECPAR(I),I=0,9) #endif #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER PARTICLE DO IK = 0, 8 SECPAR(17+IK) = SECPAR(IK) ENDDO #if __THIN__ SECPAR(26) = SECPAR(13) #endif #endif C POLARIZATION FOR MU(+) IF ( SECPAR(0) .EQ. 5.D0 ) THEN SECPAR(11) = -POLART SECPAR(12) = POLARF + PI ENDIF CALL TSTACK C RESET POLARIZATION SECPAR(11) = 0.D0 SECPAR(12) = 0.D0 ELSE IF ( LLONGI ) THEN IF ( SECPAR(0) .GT. 7.D0 ) THEN C WE HAVE A CHARGED PION(+) C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT FAC1 = 0.25D0 FAC2 = 0.75D0 #if __THIN__ DLONG(LHERHO,17) = DLONG(LHERHO,17) * + GAMMA3*PAMA(8)*CURPAR(13)*FAC1 DLONG(LHERHO,18) = DLONG(LHERHO,18) * + GAMMA3*PAMA(8)*CURPAR(13)*FAC2 #else DLONG(LHERHO,17) = DLONG(LHERHO,17) * + GAMMA3*PAMA(8)*FAC1 DLONG(LHERHO,18) = DLONG(LHERHO,18) * + GAMMA3*PAMA(8)*FAC2 #endif ELSE C WE HAVE A MUON(+) TO ADD TO THE MUON ENERGY DEPOSIT #if __THIN__ DLONG(LHERHO,15) = DLONG(LHERHO,15) * + GAMMA3*PAMA(5)*CURPAR(13) #else DLONG(LHERHO,15) = DLONG(LHERHO,15) + GAMMA3*PAMA(5) #endif ENDIF ENDIF #if __AUGERHIST__ THICKLOC = THICK( CURPAR(5) ) DO LL = 1, NOBSLV IF ( THICKLOC .GE. THCKOB(LL) .AND. * THICKLOC .LT. THCKOB(LL)+SAMPTH ) THEN C THICKH IS WITHIN 1 G/CM^2 BELOW OBSLEV(LL) C BRING THE ENERGY BELOW ANGULAR CUT TO THE HISTO OF LEVEL LL OUTPAR( 0) = SECPAR(0) OUTPAR( 1) = GAMMA3 DO II = 2, 8 OUTPAR(II) = SECPAR(II) ENDDO OUTPAR( 9) = GEN OUTPAR(10) = ALEVEL OUTPAR(13) = CURPAR(13) EDEP = OUTPAR(1) * PAMA(NINT(SECPAR(0) )) * CURPAR(13) C WE HAVE ANGULAR CUT CALL AUGERDEPFIL( EDEP,LL,1 ) ELSEIF ( THICKLOC .LT. THCKOB(LL) ) THEN GOTO 112 ENDIF ENDDO 112 CONTINUE #endif ENDIF RETURN END *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= DOUBLE PRECISION FUNCTION RHOF( ARG ) C----------------------------------------------------------------------- C RHO (DENSITY) F(UNCTION) C C CALCULATES DENSITY (G/CM**3) OF ATMOSPHERE DEPENDING ON HEIGHT (CM) C THIS FUNCTION IS CALLED FROM BOX2, LPMEFFECT, ININKG, CERENK, C MUTRAC, AND INRTAB. C ARGUMENT: C ARG = HEIGHT (CM) C----------------------------------------------------------------------- IMPLICIT NONE #define __ATMOSINC__ #define __ATMOS2INC__ #define __RUNPARINC__ #if __ATMEXT__ #define __ATMOSXINC__ #endif #include "corsika.h" DOUBLE PRECISION ARG #if __ATMEXT__ DOUBLE PRECISION RHOFX EXTERNAL RHOFX #endif SAVE C----------------------------------------------------------------------- CC IF ( DEBUG ) WRITE(MDEBUG,*) 'RHOF : ARG=',SNGL(ARG) #if __ATMEXT__ IF ( IATMOX .GE. 1 ) THEN RHOF = RHOFX( ARG ) RETURN ENDIF #endif IF ( ARG .LT. HLAY(2) ) THEN RHOF = BATM(1) * DATM(1) * EXP( (-ARG) * DATM(1) ) ELSEIF ( ARG .LT. HLAY(3) ) THEN RHOF = BATM(2) * DATM(2) * EXP( (-ARG) * DATM(2) ) ELSEIF ( ARG .LT. HLAY(4) ) THEN RHOF = BATM(3) * DATM(3) * EXP( (-ARG) * DATM(3) ) ELSEIF ( ARG .LT. HLAY(5) ) THEN RHOF = BATM(4) * DATM(4) * EXP( (-ARG) * DATM(4) ) ELSE RHOF = DATM(5) ENDIF RETURN END *-- Author : D. HECK IK FZK KARLSRUHE 17/03/2003 C======================================================================= SUBROUTINE RMMAQD( ISEED,ISEQ,CHOPT ) 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://wwwasdoc.web.cern.ch/wwwasdoc/cernlib.html (v113) 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 ' ' SEQUENCE 1 IS INITIALIZED WITH DEFAULT SEED C 'R' GET STATUS OF GENERATOR BY 3 SEEDS C 'RV' COMPLETE STATUS OF GENERATOR IS DUMPED (103 WORDS) C 'S' SET RANDOM GENERATOR BY 3 SEEDS C 'SV' SET RANDOM GENERATOR BY ARRAY WITH 103 WORDS C 'V' VECTOR OPTION SET/GET STATUS USING 103 WORDS C----------------------------------------------------------------------- IMPLICIT NONE #define __RANMA3INC__ #define __RANMA4INC__ #include "corsika.h" 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 : D. HECK IK FZK KARLSRUHE 17/03/2003 C======================================================================= SUBROUTINE RMMARD( RVEC,LENV,ISEQ ) C----------------------------------------------------------------------- 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://wwwasdoc.web.cern.ch/wwwasdoc/cernlib.html (v113) C IT HAS BEEN CHECKED THAT RESULTS ARE BIT-IDENTICAL WITH CERN C DOUBLE PRECISION RANDOM NUMBER GENERATOR RMM48, DESCRIBED IN C http://wwwasdoc.web.cern.ch/wwwasdoc/cernlib.html (v116) 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 #define __RANMA3INC__ #define __RANMA4INC__ #include "corsika.h" 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 *-- Author : D. HECK IK FZK KARLSRUHE 27/04/1994 C======================================================================= SUBROUTINE SDPM( LTA ) C----------------------------------------------------------------------- C S(TARTING) D(UAL) P(ARTON) M(ODEL) C C THIS ROUTINE DETERMINES THE TARGET NUCLEUS. C IT CALLS ALSO THE VARIOUS INTERACTION MODELS. C FOR HDPM, THIS ROUTINE LOOKS, HOW MANY NUCLEONS INTERACT AND WHICH C RESIDUAL FRAGMENT OF THE PROJECTILE NUCLEUS REMAINS. C THIS SUBROUTINE IS CALLED FROM NUCINT AND PIGEN. C ARGUMENT: C LTA = TARGET: 1=14N, 2=16O, 3=40AR, 0=RANDOM C----------------------------------------------------------------------- IMPLICIT NONE #define __AIRINC__ #define __CONSTAINC__ #define __DPMFLGINC__ #define __GENERINC__ #define __INTERINC__ #define __ISTAINC__ #define __LONGIINC__ #define __MULTINC__ #define __NCSNCSINC__ #define __PAMINC__ #define __PARPARINC__ #define __PARPAEINC__ #define __RANDPAINC__ #define __RESTINC__ #define __RUNPARINC__ #define __SIGMINC__ #define __VKININC__ #if __AUGERHIST__ #define __OBSPARINC__ #endif #if __DPMJET__ #define __DPMJETINC__ #endif #if __EPOS__ || __NEXUS__ #define __NEXUSINC__ #endif #if __QGSJET__ #define __QGSCINC__ #endif #if __SIBYLL__ #define __SIBYLCINC__ #endif #if __VENUS__ #define __VENUSINC__ #endif #if __INTTEST__ #define __TSTINTINC__ #endif #include "corsika.h" DOUBLE PRECISION PFRX(60),PFRY(60) DOUBLE PRECISION COSTET,CPHIV,EA,P,PTM,PT2,PTOT,SPHIV, * SIGMAA,SIGMAN,SIGMAO,SIG45,S45SQ,S4530 DOUBLE PRECISION CGHSIG INTEGER ITYP(60),I,IA,IANEW,INACTA,INACTZ,INDEX,INEUTR, * IZ,IZNEW,J,JFIN,KNEW,L,LL,LTA,NPRPRO,NNEPRO #if __GHEISHAD__ DOUBLE PRECISION EKIN #endif #if __AUGERHIST__ DOUBLE PRECISION EDEP,THICKLOC,THICK INTEGER II EXTERNAL THICK #endif SAVE EXTERNAL CGHSIG C----------------------------------------------------------------------- #if __THIN__ IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=0,9),WEIGHT 444 FORMAT(' SDPM : CURPAR=',1P,11E11.3) #else IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=0,9) 444 FORMAT(' SDPM : CURPAR=',1P,10E11.3) #endif C IA IS MASS NUMBER OF PROJECTILE IA = ITYPE / 100 IF ( IA .GT. 56 ) THEN #if __THIN__ WRITE(MONIOU,444) (CURPAR(I),I=0,9),WEIGHT #else WRITE(MONIOU,444) (CURPAR(I),I=0,9) #endif WRITE(MONIOU,*) 'SDPM : NOT FORESEEN PARTICLE TYPE=',ITYPE STOP ENDIF C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C TREATMENT OF GAMMAS COMING FROM EGS4 (PIGEN) IF ( ITYPE .EQ. 1 ) THEN IF ( LTA .EQ. 0 ) THEN C TAKE TARGET FROM CROSS SECTION RATIOS AT RANDOM C RATIOS OF CROSS-SECTIONS GO LIKE A**0.91 C 14**0.91 = 11.04; 16**0.91 = 12.47; 40**0.91 = 28.70 FRACTN = COMPOS(1) * 11.04019D0 FRCTNO = FRACTN + COMPOS(2) * 12.46663D0 SIGAIR = FRCTNO + COMPOS(3) * 28.69952D0 C TARGET IS CHOSEN AT RANDOM CALL RMMARD( RD,1,1 ) IF ( RD(1)*SIGAIR .LE. FRACTN ) THEN C INTERACTION WITH NITROGEN LIT = 1 TAR = 14.D0 ELSEIF ( RD(1)*SIGAIR .LE. FRCTNO ) THEN C INTERACTION WITH OXYGEN LIT = 2 TAR = 16.D0 ELSE C INTERACTION WITH ARGON LIT = 3 TAR = 40.D0 ENDIF C TARGET IS PREDETERMINED ELSEIF ( LTA .EQ. 1 ) THEN LIT = 1 TAR = 14.D0 ELSEIF ( LTA .EQ. 2 ) THEN LIT = 2 TAR = 16.D0 ELSEIF ( LTA .EQ. 3 ) THEN LIT = 3 TAR = 40.D0 ENDIF #if __INTTEST__ C WHAT TARGET FOR TESTING ? C SET TAR IF PRESELECTED, LEAVE IT FOR AIR IF ( ITTAR .NE. 99 ) TAR = ITTAR IWOUNP = 1 #endif #if __DPMJET__ C GAMMAS ARE TREATED BY DPMJET, IF SUFFICIENT ENERGY IF ( FDPMJT .AND. CURPAR(1) .GT. HILOELB ) THEN CALL DPMJLK ELSE CALL HDPM ENDIF #elif __EPOS__ || __NEXUS__ C GAMMAS ARE TREATED BY EPOS/NEXUS, IF SUFFICIENT ENERGY IF ( FNEXUS .AND. CURPAR(1) .GT. HILOELB ) THEN CALL NEXLNK ELSE CALL HDPM ENDIF #elif __QGSJET__ C GAMMAS ARE TREATED BY QGSJET, IF SUFFICIENT ENERGY IF ( FQGS .AND. CURPAR(1) .GT. HILOELB ) THEN CALL QGSLNK ELSE CALL HDPM ENDIF #elif __SIBYLL__ C GAMMAS ARE TREATED BY SIBYLL, IF SUFFICIENT ENERGY IF ( FSIBYL .AND. CURPAR(1) .GT. HILOELB ) THEN CALL SIBLNK ELSE CALL HDPM ENDIF #elif __VENUS__ C GAMMAS ARE TREATED BY VENUS, IF SUFFICIENT ENERGY IF ( FVENUS .AND. CURPAR(1) .GT. HILOELB ) THEN CALL VENLNK ELSE CALL HDPM ENDIF #else CALL HDPM #endif C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C NORMAL HADRON PROJECTILE ELSEIF ( ITYPE .LT. 200 ) THEN C WITH WHAT KIND OF TARGET DOES PROJECTILE INTERACT? IF ( FIXTAR ) THEN C TARGET OF FIRST INTERACTION IS FIXED LIT = N1STTR IF ( N1STTR .EQ. 1 ) THEN TAR = 14.D0 ELSEIF ( N1STTR .EQ. 2 ) THEN TAR = 16.D0 ELSE TAR = 40.D0 ENDIF FIXTAR = .FALSE. #if __NUPRIM__ IF ( ( ( ITYPE .GE. 66 .AND. ITYPE .LE. 69 ) #if __CHARM__ || __TAULEP__ * .OR. ITYPE .EQ. 133 .OR. ITYPE .EQ. 134 #endif * ) .AND. FIRSTI ) THEN C SET TARGET TO PROTON OR NEUTRON ACCORDING TO NUCLEON CONTENT CALL RMMARD( RD,1,1 ) IF ( RD(1) .LE. CONTNE(LIT) ) THEN ITAR = 13 ELSE ITAR = 14 ENDIF C here ecm (equivalent to curpar(12)) for neutrino is calculated C it is not really needed, but computed for completeness CDH April 28/03 is this calculation of ecm correct??????? * ecm = gamma / sqrt( 1.d0 + 2.d0 * gamma /pama(itar) ) ECM = SQRT( PAMA(ITAR) * (PAMA(ITAR) + 2.D0*GAMMA) ) GCM = GAMMA / ECM BETACM = SQRT( (GCM-1.D0)*(GCM+1.D0) ) / GCM ENDIF #endif ELSE C SELECT THE TARGET ACCORDING OCCURENCE AND CROSS SECTION CONTRIBUTION #if __NUPRIM__ IF ( ( ITYPE .GE. 66 .AND. ITYPE .LE. 69 ) #if __CHARM__ || __TAULEP__ * .OR. ITYPE .EQ. 133 .OR. ITYPE .EQ. 134 #endif * ) THEN C SELECTION ACCORDING WITH NUCLEON CONTENTS OF COMPONENTS OF AIR FRACTN = COMPOS(1) * 14.D0 * SIGMA/SIGAIR FRCTNO = COMPOS(2) * 16.D0 * SIGMA/SIGAIR + FRACTN GOTO 333 ENDIF #endif C TARGET IS CHOSEN AT RANDOM ACCORDING TO CROSS-SECTION #if __DPMJET__ C SIGAIR, FRACTN, FRCTNO HAVE BEEN DETERMINED IN BOX2/DPJSIG IF ( FDPJSG ) GOTO 333 C SIGMA IS ENERGY DEPENDENT INELASTIC NUCLEON-NUCLEON CROSS-SECTION C AND IS SET IN BOX2 #elif __EPOS__ || __NEXUS__ C SIGAIR, FRACTN, FRCTNO HAVE BEEN DETERMINED IN BOX2/NEXSIG IF ( FNEXSG ) GOTO 333 C SIGMA IS ENERGY DEPENDENT INELASTIC NUCLEON-NUCLEON CROSS-SECTION C AND IS SET IN BOX2 #elif __QGSJET__ C SIGAIR, FRACTN, FRCTNO HAVE BEEN DETERMINED IN BOX2/QGSSIG IF ( FQGSSG ) GOTO 333 C SIGMA IS ENERGY DEPENDENT INELASTIC NUCLEON-NUCLEON CROSS-SECTION C AND IS SET IN BOX2 #elif __SIBYLL__ C SIGMA IS ENERGY DEPENDENT INELASTIC NUCLEON-NUCLEON CROSS-SECTION C AND IS SET IN BOX2/SIBSIG IF ( FSIBSG ) THEN C KEEP THE CROSS SECTION FOR PRINTOUT OF FIRST INTERACTION SIGAIRS = SIGAIR ENDIF #elif __VENUS__ C SIGAIR, FRACTN, FRCTNO HAVE BEEN DETERMINED IN BOX2/VENSIG IF ( FVENSG ) GOTO 333 C SIGMA IS ENERGY DEPENDENT INELASTIC NUCLEON-NUCLEON CROSS-SECTION C AND IS SET IN BOX2 #else C SIGMA IS ENERGY DEPENDENT INELASTIC NUCLEON-NUCLEON CROSS-SECTION C AND IS SET IN BOX2 #endif C AUXIL. QUANTITIES FOR INTERPOLATION SIG45 = SIGMA - 45.D0 S45SQ = SIG45**2 / 450.D0 S4530 = SIG45 / 30.D0 C INELASTIC CROSS-SECTIONS FOR PROJECTICLE WITH MASS NUMBER 1 SIGMAN = (1.D0 - 2.D0 * S45SQ) * SIGN45(1) * +(S45SQ - S4530) * SIGN30(1) * +(S45SQ + S4530) * SIGN60(1) FRACTN = COMPOS(1) * SIGMAN SIGMAO = (1.D0 - 2.D0 * S45SQ) * SIGO45(1) * +(S45SQ - S4530) * SIGO30(1) * +(S45SQ + S4530) * SIGO60(1) FRCTNO = FRACTN + COMPOS(2) * SIGMAO SIGMAA = (1.D0 - 2.D0 * S45SQ) * SIGA45(1) * +(S45SQ - S4530) * SIGA30(1) * +(S45SQ + S4530) * SIGA60(1) C INELASTIC CROSS-SECTIONS OF AIR FOR PROJECTILE WITH MASS NUMBER 1 SIGAIR = FRCTNO + COMPOS(3)*SIGMAA #if __DPMJET__ || __EPOS__ || __NEXUS__ || __QGSJET__ || __VENUS__ || __NUPRIM__ 333 CONTINUE #endif CALL RMMARD( RD,1,1 ) IF ( DEBUG ) WRITE(MDEBUG,*) 'SDPM : FRACTN=',SNGL(FRACTN), * ' FRCTNO=',SNGL(FRCTNO), * ' SIGAIR=',SNGL(SIGAIR), * ' RD=',SNGL(RD(1)) IF ( RD(1)*SIGAIR .LE. FRACTN ) THEN C INTERACTION WITH NITROGEN LIT = 1 TAR = 14.D0 ELSEIF ( RD(1)*SIGAIR .LE. FRCTNO ) THEN C INTERACTION WITH OXYGEN LIT = 2 TAR = 16.D0 ELSE C INTERACTION WITH ARGON LIT = 3 TAR = 40.D0 ENDIF ENDIF #if __NUPRIM__ IF ( FIRSTI .AND. * ( (ITYPE .GE. 66 .AND. ITYPE .LE. 69) #if __CHARM__ || __TAULEP__ * .OR. ITYPE .EQ. 133 .OR. ITYPE .EQ. 134 #endif * ) ) THEN C PRIMARY NEUTRINOS ARE TREATED BY HERWIG CALL HERLNK RETURN ENDIF #endif #if __INTTEST__ C WHAT TARGET FOR TESTING ? C SET TAR IF PRESELECTED, LEAVE IT FOR AIR IF ( ITTAR .NE. 99 ) TAR = ITTAR IWOUNP = 1 #endif #if __DPMJET__ IF ( FDPMJT ) THEN C MESONS, NUCLEONS AND STRANGE BARYONS ARE TREATED BY DPMJET C BUT NOT ANTI_SIGMA AND STRANGENESS 2 AND 3 IF ( ITYPE .GE. 7 .AND. ITYPE .LE. 32 ) THEN CALL DPMJLK ELSE CALL HDPM ENDIF ELSE CALL HDPM ENDIF #elif __EPOS__ || __NEXUS__ IF ( FNEXUS ) THEN C MESONS, NUCLEONS AND STRANGE BARYONS ARE TREATED BY EPOS/NEXUS IF ( ( ITYPE .GE. 7 .AND. ITYPE .LE. 32 ) #if __CHARM__ && __EPOS__ * * .OR. ( ITYPE .GE. 116 .AND. ITYPE .LE. 121 ) * * .OR. ( ITYPE .GE. 137 .AND. ITYPE .LE. 157 ) #endif * ) THEN CALL NEXLNK ELSE CALL HDPM ENDIF ELSE CALL HDPM ENDIF #elif __QGSJET__ IF ( FQGS ) THEN C MESONS AND NUCLEONS ARE TREATED BY QGSJET (JAN 96) IF ( (ITYPE .GE. 7 .AND. ITYPE .LE. 17) .OR. * (ITYPE .EQ. 25 ) .OR. * (ITYPE .GE. 71 .AND. ITYPE .LE. 74) #if __CHARM__ * .OR. (ITYPE .GE. 116 .AND. ITYPE .LE. 119) * .OR. ITYPE .EQ. 137 .OR. ITYPE .EQ. 149 #endif * ) THEN CALL QGSLNK ELSE CALL HDPM ENDIF ELSE CALL HDPM ENDIF #elif __SIBYLL__ IF ( FSIBYL ) THEN C MESONS AND NUCLEONS ARE TREATED BY SIBYLL C INCLUDING STRANGE BARYONS AND ANTI_BARYONS (Oct 2015) C INCLUDING CHARMED MESONS AND BARYONS (Feb. 2016) IF ( (ITYPE .GE. 7 .AND. ITYPE .LE. 23) .OR. * (ITYPE .GE. 25 .AND. ITYPE .LE. 31) .OR. * (ITYPE .GE. 71 .AND. ITYPE .LE. 74) .OR. * (ITYPE .GE. 116 .AND. ITYPE .LE. 121) .OR. * (ITYPE .GE. 137 .AND. ITYPE .LE. 139) .OR. * (ITYPE .GE. 145 .AND. ITYPE .LE. 151) .OR. * (ITYPE .EQ. 157 ) ) THEN IF ( ECM .GE. 10.D0 ) THEN CALL SIBLNK ELSE CALL HDPM ENDIF ELSE CALL HDPM ENDIF ELSE CALL HDPM ENDIF #elif __VENUS__ IF ( FVENUS ) THEN C MESONS, NUCLEONS AND STRANGE BARYONS ARE TREATED BY VENUS (JAN 95) IF ( ITYPE .GE. 7 .AND. ITYPE .LE. 32 ) THEN CALL VENLNK ELSE CALL HDPM ENDIF ELSE CALL HDPM ENDIF #else CALL HDPM #endif C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C HEAVY PROJECTILE INCIDENT WITH IA NUCLEONS ELSEIF ( IA .LE. 56 ) THEN IZ = MOD(ITYPE,100) C WITH WHAT KIND OF TARGET DOES PROJECTILE INTERACT? IF ( FIXTAR ) THEN C TARGET OF FIRST INTERACTION IS FIXED LIT = N1STTR IF ( N1STTR .EQ. 1 ) THEN TAR = 14.D0 ELSEIF ( N1STTR .EQ. 2 ) THEN TAR = 16.D0 ELSE TAR = 40.D0 ENDIF FIXTAR = .FALSE. CALL RMMARD( RD,2,1 ) C AUXIL. QUANTITIES FOR INTERPOLATION SIG45 = SIGMA - 45.D0 S45SQ = SIG45**2 / 450.D0 S4530 = SIG45 / 30.D0 ELSE C ONLY INELASTIC INTERACTIONS WITH HEAVY PROJECTILE/FRAGMENT C SIGMA IS ENERGY DEPENDENT INELASTIC NUCLEON-NUCLEON CROSS-SECTION #if __DPMJET__ C AND IS SET IN BOX2/DPMJETSIG #elif __EPOS__ || __NEXUS__ C AND IS SET IN BOX2/NEXSIG #elif __QGSJET__ C AND IS SET IN BOX2/QGSSIG IF ( FQGSSG ) GOTO 334 #elif __SIBYLL__ C AND IS SET IN BOX2/SIBSIG/SIGNUC_INI2 IF ( FSIBSG ) THEN C KEEP THE CROSS SECTION FOR PRINTOUT OF FIRST INTERACTION SIGAIRS = SIGAIR ENDIF #elif __VENUS__ C AND IS SET IN BOX2/VENSIG #else C AND IS SET IN BOX2 #endif #if __FLUKA__ C NO CORRECT CROSS SECTION AVAILABLE FOR NUCLEUS-NUCLEUS COLLISION C TAKE THE GRIEDER MODEL #elif __GHEISHAD__ C NO CORRECT CROSS SECTION AVAILABLE FOR NUCLEUS-NUCLEUS COLLISION C TAKE THE GRIEDER MODEL #elif __URQMD__ C CROSS SECTION HAS BEEN DETERMINED IN BOX2 WHICH MIGHT BE USED IF ( FURQSG ) GOTO 334 #endif C AUXIL. QUANTITIES FOR INTERPOLATION SIG45 = SIGMA - 45.D0 S45SQ = SIG45**2 / 450.D0 S4530 = SIG45 / 30.D0 C INELASTIC CROSS-SECTIONS FOR PROJECTICLE WITH MASS NUMBER IA SIGMAN = (1.D0 - 2.D0 * S45SQ) * SIGN45(IA) * +(S45SQ - S4530) * SIGN30(IA) * +(S45SQ + S4530) * SIGN60(IA) FRACTN = COMPOS(1) * SIGMAN SIGMAO = (1.D0 - 2.D0 * S45SQ) * SIGO45(IA) * +(S45SQ - S4530) * SIGO30(IA) * +(S45SQ + S4530) * SIGO60(IA) FRCTNO = FRACTN + COMPOS(2) * SIGMAO SIGMAA = (1.D0 - 2.D0 * S45SQ) * SIGA45(IA) * +(S45SQ - S4530) * SIGA30(IA) * +(S45SQ + S4530) * SIGA60(IA) C INELASTIC CROSS-SECTIONS OF AIR FOR PROJECTILE WITH MASS NUMBER IA SIGAIR = FRCTNO +COMPOS(3)*SIGMAA #if __QGSJET__ || __URQMD__ 334 CONTINUE #endif C TARGET IS CHOSEN AT RANDOM CALL RMMARD( RD,2,1 ) IF ( DEBUG ) WRITE(MDEBUG,*) 'SDPM : FRACTN=',SNGL(FRACTN), * ' FRCTNO=',SNGL(FRCTNO), * ' SIGAIR=',SNGL(SIGAIR), * ' RD=',SNGL(RD(1)) IF ( RD(1)*SIGAIR .LE. FRACTN ) THEN C INTERACTION WITH NITROGEN LIT = 1 TAR = 14.D0 ELSEIF ( RD(1)*SIGAIR .LE. FRCTNO ) THEN C INTERACTION WITH OXYGEN LIT = 2 TAR = 16.D0 ELSE C INTERACTION WITH ARGON LIT = 3 TAR = 40.D0 ENDIF ENDIF #if __INTTEST__ C WHAT TARGET FOR TESTING ? C SET TAR IF PRESELECTED, LEAVE IT FOR AIR IF ( ITTAR .NE. 99 ) TAR = ITTAR #endif #if __DPMJET__ C TREAT NUCLEUS BY DPMJET, IF SELECTED AND ENERGY/NUCLEON HIGH ENOUGH IF ( FDPMJT .AND. PAMA(ITYPE)*GAMMA .GT. HILOELB*IA ) THEN CALL DPMJLK RETURN ENDIF #elif __EPOS__ || __NEXUS__ C TREAT NUCLEUS BY EPOS/NEXUS, IF SELECTED AND ENERGY/NUCLEON HIGH ENOUGH IF ( FNEXUS .AND. PAMA(ITYPE)*GAMMA .GT. HILOELB*IA ) THEN CALL NEXLNK RETURN ENDIF #elif __QGSJET__ C TREAT NUCLEUS BY QGSJET, IF SELECTED AND ENERGY/NUCLEON HIGH ENOUGH IF ( FQGS .AND. PAMA(ITYPE)*GAMMA .GT. HILOELB*IA ) THEN CALL QGSLNK RETURN ENDIF #elif __SIBYLL__ C TREAT NUCLEUS BY SIBYLL, IF SELECTED AND ENERGY/NUCLEON HIGH ENOUGH IF ( FSIBYL .AND. PAMA(ITYPE)*GAMMA .GT. HILOELB*IA ) THEN CALL SIBLNK RETURN ENDIF #elif __VENUS__ C TREAT NUCLEUS BY VENUS, IF SELECTED AND ENERGY/NUCLEON HIGH ENOUGH IF ( FVENUS .AND. PAMA(ITYPE)*GAMMA .GT. HILOELB*IA ) THEN CALL VENLNK RETURN ENDIF #endif C TREATMENT OF NUCLEUS-NUCLEUS INTERACTION IN HDPM BY SUPERPOSITION C C INDEX CALCULATION 1 P( I*(I-3)*0.5+J+1 ) C IZ IS NUMBER OF PROTONS IN PROJECTILE C LIT IS INDEX FOR TARGET 1 = N, 2 = O, 3 = AR C INACTA IS NUMBER OF INTERACTING NUCLEONS C INACTZ IS NUMBER OF INTERACTING PROTONS C LOOK, HOW MANY NUCLEONS INTERACT DO J = 1, IA-1 INACTA = J INDEX = IA * (IA-3) * 0.5 + 1 + J P = ( 1.D0 - S45SQ *2.D0 ) * PNOA45(INDEX,LIT) * +( S45SQ - S4530 ) * PNOA30(INDEX,LIT) * +( S45SQ + S4530 ) * PNOA60(INDEX,LIT) IF ( RD(2) .LT. P ) GOTO 110 ENDDO C ALL NUCLEONS INTERACT (INACTA EQUAL IA) INACTA = INACTA + 1 110 CONTINUE IANEW = IA - INACTA C REMAINING PROJECTILE WITH IANEW NUCLEONS DO L = 1, 4 SECPAR(L) = CURPAR(L) ENDDO #if __INTTEST__ IWOUNP = INACTA #endif C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C PROJECTILE NUCLEUS FRAGMENTS COMPLETELY, WRITE SPECTATOR NUCLEONS C ONTO STACK IF ( NFRAGM .EQ. 0 ) THEN C LOOK, HOW MANY PROTONS AND NEUTRONS ARE FORMED IZNEW = IANEW / 2.15D0 + 0.7D0 INEUTR = IANEW - IZNEW INACTZ = MAX( 0, IZ-IZNEW ) IF ( IZNEW .GT. 0 ) THEN C PROTONS SECPAR(0) = 14.D0 DO L = 1, IZNEW CALL TSTACK ENDDO ENDIF IF ( INEUTR .GT. 0 ) THEN C NEUTRONS SECPAR(0) = 13.D0 DO L = 1, INEUTR CALL TSTACK ENDDO ENDIF C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C NO FRAGMENTATION, BUT SUCCESSIVE ABRASION OF PROJECTILE NUCLEUS ELSE IF ( DEBUG ) WRITE( MDEBUG,111 ) TAR,INACTA,IANEW 111 FORMAT(' SDPM : TARGET=',F4.0,' INACTA=',I4,' IANEW=',I4) C ALL NUCLEONS INTERACT, NO RESIDUAL NUCLEUS IF ( IANEW .EQ. 0 ) THEN INACTZ = IZ #if __THIN__ IF ( DEBUG ) WRITE(MDEBUG,554) (CURPAR(I),I=0,9),WEIGHT 554 FORMAT(' SDPM : CURPAR=',1P,11E11.3) #else IF ( DEBUG ) WRITE(MDEBUG,554) (CURPAR(I),I=0,9) 554 FORMAT(' SDPM : CURPAR=',1P,10E11.3) #endif KNEW = 0 C REMAINING NUCLEUS IS A NUCLEON ELSEIF ( IANEW .EQ. 1 ) THEN CALL RMMARD( RD,1,1 ) IZNEW = NINT( RD(1) ) INACTZ = IZ - IZNEW KNEW = 13 + IZNEW C REMAINING NUCLEUS GETS A CHARGE WHICH IS ABOUT HALF THE MASS NUMBER ELSEIF ( IANEW .GT. 1 ) THEN IZNEW = DBLE(IANEW) / 2.15D0 + 0.7D0 INACTZ = MAX( 0, IZ - IZNEW ) KNEW = IANEW*100 + IZNEW C REMAINING NUCLEUS DEEXCITES BY EVAPORATION OF NUCLEONS/ALPHA PARTCLS. IF ( NFRAGM .GE. 2 ) THEN JFIN = 0 CALL VAPOR( IA,KNEW,JFIN,ITYP,PFRX,PFRY ) IF ( JFIN .LE. 0 ) GOTO 190 KNEW = 0 DO 135 J = 1,JFIN EA = GAMMA * PAMA(ITYP(J)) IF ( DEBUG ) WRITE(MDEBUG,*) 'SDPM : J,ITYP,EA=', * J,ITYP(J),SNGL(EA) PTM = (EA-PAMA(ITYP(J))) * (EA+PAMA(ITYP(J))) PT2 = PFRX(J)**2 + PFRY(J)**2 IF ( PT2 .GE. PTM ) THEN IF ( DEBUG ) WRITE(MDEBUG,*) 'SDPM : PT REJECT ',J GOTO 135 ENDIF IF ( PTM .GT. 0.D0 ) THEN COSTET = SQRT( 1.D0 - PT2/PTM ) PTOT = SQRT( PTM ) CPHIV = PFRX(J) / PTOT SPHIV = PFRY(J) / PTOT ELSE COSTET = 0.D0 PTOT = 0.D0 CPHIV = 1.D0 SPHIV = 0.D0 ENDIF CALL ADDANG4( COSTHE,PHIX,PHIY, COSTET,CPHIV,SPHIV, * SECPAR(2),SECPAR(3),SECPAR(4) ) #if __UPWARD__ IF ( SECPAR(2) .GE. -1.D0 ) THEN #else IF ( SECPAR(2) .GT. C(29) ) THEN #endif IF ( J .LT. JFIN ) THEN SECPAR(0) = ITYP(J) #if __INTTEST__ SECPAR(17) = SQRT( PT2 ) #endif CALL TSTACK ELSE KNEW = ITYP(JFIN) IANEW = KNEW/100 ENDIF ELSE IF (DEBUG) WRITE(MDEBUG,*) 'SDPM : ANGLE REJECT ',J IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT #if __THIN__ DLONG(LHEIGH,17) = DLONG(LHEIGH,17) * + ( EA-RESTMS(ITYP(J)) )*WEIGHT #else DLONG(LHEIGH,17) = DLONG(LHEIGH,17) * + ( EA-RESTMS(ITYP(J)) ) #endif ENDIF #if __AUGERHIST__ THICKLOC = THICK( H ) DO LL = 1, NOBSLV IF ( THICKLOC .GE. THCKOB(LL) .AND. * THICKLOC .LT. THCKOB(LL)+SAMPTH ) THEN C THICKH IS WITHIN 1 G/CM^2 BELOW OBSLEV(LL) C BRING THE ENERGY BELOW ANGULAR CUT TO THE HISTO OF LEVEL LL OUTPAR(0) = ITYP(J) DO II = 1, 8 OUTPAR(II) = SECPAR(II) ENDDO OUTPAR( 9) = GEN OUTPAR(10) = ALEVEL OUTPAR(13) = WEIGHT EDEP = ( EA - RESTMS(ITYP(J)) ) * WEIGHT C WE HAVE ANGULAR CUT CALL AUGERDEPFIL( EDEP,LL,1 ) ELSEIF ( THICKLOC .LT. THCKOB(LL) ) THEN GOTO 112 ENDIF ENDDO 112 CONTINUE #endif ENDIF 135 CONTINUE ENDIF ENDIF C REMAINING NUCLEUS: MASS 5 CANNOT BE TREATED IN BOX2 IF ( KNEW/100 .EQ. 5 ) THEN IF ( MOD(KNEW,100) .GE. 3 ) THEN C MASS 5: SPLIT OFF ONE PROTON SECPAR(0) = 14.D0 CALL TSTACK KNEW = KNEW - 101 ELSE C MASS 5: SPLIT OFF ONE NEUTRON SECPAR(0) = 13.D0 CALL TSTACK KNEW = KNEW - 100 ENDIF C REMAINING NUCLEUS: MASS 8 CANNOT BE TREATED IN BOX2 ELSEIF ( KNEW/100 .EQ. 8 ) THEN IF ( MOD(KNEW,100) .GE. 5 ) THEN C MASS 8: SPLIT OFF ONE PROTON SECPAR(0) = 14.D0 CALL TSTACK KNEW = KNEW - 101 ELSEIF ( MOD(KNEW,100) .LE. 3 ) THEN C MASS 8: SPLIT OFF ONE NEUTRON SECPAR(0) = 13.D0 CALL TSTACK KNEW = KNEW - 100 ELSE C MASS 8: SPLIT OFF ONE ALPHA PARTICLE SECPAR(0) = 402.D0 CALL TSTACK KNEW = KNEW - 402 ENDIF ENDIF IF ( KNEW .GT. 0 ) THEN SECPAR(0) = KNEW CALL TSTACK #if __THIN__ IF ( DEBUG ) WRITE(MDEBUG,555) (SECPAR(I),I=0,9),SECPAR(13) 555 FORMAT(' SDPM : SECPAR=',1P,9E11.3,0P,F10.0,1P,E10.3) #else IF ( DEBUG ) WRITE(MDEBUG,555) (SECPAR(I),I=0,9) 555 FORMAT(' SDPM : SECPAR=',1P,9E11.3,0P,F10.0) #endif ENDIF ENDIF C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C HERE THE REACTING NUCLEONS ARE TREATED 190 CONTINUE NPRPRO = INACTZ NNEPRO = INACTA - INACTZ IF ( DEBUG ) WRITE(MDEBUG,*) 'SDPM : REACTING PROTONS=', * NPRPRO,' NEUTRONS=',NNEPRO C TREAT INTERACTING NEUTRONS FROM PROJECTILE IF ( NNEPRO .GE. 1 ) THEN CURPAR(0) = 13.D0 ITYPE = 13 C CALCULATE GAMMA, BETA AND ENERGY IN CENTER OF MASS GCM = SQRT( GAMMA * 0.5D0 + 0.5D0 ) ECM = PAMA(ITYPE) * GCM * 2.D0 BETACM = SQRT( (GCM-1.D0)*(GCM+1.D0) ) / GCM DO LL = 1, NNEPRO IF ( ECM .LE. HILOECM ) THEN #if __FLUKA__ C TARGET MATERIAL IS DECIDED IN FLULNK CALL FLULNK #elif __GHEISHAD__ C USE GHEISHA AND CALCULATE THE CROSS-SECTION FOR GHEISHA ELAB = PAMA(ITYPE) * GAMMA PLAB = ELAB * BETA EKIN = ELAB - PAMA(ITYPE) SIGAIR = CGHSIG( PLAB,EKIN,ITYPE ) IF ( DEBUG ) WRITE(MDEBUG,*) * 'SDPM : SIGAIR=',SNGL(SIGAIR) CALL CGHEI #elif __URQMD__ C NEW URQMD LINK (MARCH 2004) WILL NOT TREAT NUCLEI, C THEREFORE USE SUPERPOSITION CALL URQLNK #endif ELSE C DUAL PARTON MODEL CALL HDPM ENDIF ENDDO ENDIF C TREAT INTERACTING PROTONS FROM PROJECTILE IN SUBROUT. HDPM IF ( NPRPRO .GE. 1 ) THEN CURPAR(0) = 14.D0 ITYPE = 14 C CALCULATE GAMMA, BETA AND ENERGY IN CENTER OF MASS GCM = SQRT( GAMMA * 0.5D0 + 0.5D0 ) ECM = PAMA(ITYPE) * GCM * 2.D0 BETACM = SQRT( (GCM-1.D0)*(GCM+1.D0) ) / GCM DO LL = 1, NPRPRO IF ( ECM .LE. HILOECM ) THEN #if __FLUKA__ C TARGET MATERIAL IS DECIDED IN FLULNK CALL FLULNK #elif __GHEISHAD__ C USE GHEISHA AND CALCULATE THE CROSS-SECTION FOR GHEISHA ELAB = PAMA(ITYPE) * GAMMA PLAB = ELAB * BETA EKIN = ELAB - PAMA(ITYPE) SIGAIR = CGHSIG( PLAB,EKIN,ITYPE ) IF ( DEBUG ) WRITE(MDEBUG,*) * 'SDPM : SIGAIR=',SNGL(SIGAIR) CALL CGHEI #elif __URQMD__ C NEW URQMDLINK (MARCH 2004) WILL NOT TREAT NUCLEI, C THEREFORE USE SUPERPOSITION CALL URQLNK #endif ELSE C DUAL PARTON MODEL CALL HDPM ENDIF ENDDO ENDIF C ALL PARTICLES, INCLUDING THE LEADING ONE, ARE NOW WRITTEN TO STACK ELSE #if __THIN__ WRITE(MONIOU,444) (CURPAR(I),I=0,9),WEIGHT #else WRITE(MONIOU,444) (CURPAR(I),I=0,9) #endif WRITE(MONIOU,*) 'SDPM : NOT FORESEEN PARTICLE TYPE=',ITYPE STOP ENDIF RETURN END #if __TIMERC__ *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE SEKDAT( IYEAR,IMONT,IDAYS,IHOUR,IMINU,ISEKU ) C----------------------------------------------------------------------- C SEK(UNDEN) DAT(UM) C C GIVES TIME AND DATE ON UNIX IN UNIVERSAL TIME (UT) ON C UNIX(-LIKE) SYSTEMS. C LINKING WITH EXTRA TIMER FUNCTION MAY BE REQUIRED. C THIS SUBROUTINE IS CALLED FROM PRTIME. C ARGUMENTS: C IJAHR = YEAR (YYYY) C IMONT = MONTH C IDAYS = DAY C IHOUR = HOUR C IMINU = MINUTE C ISEKU = SECOND C----------------------------------------------------------------------- IMPLICIT NONE REAL RYEAR INTEGER I,IYEAR,ILANG,ILEAP,IMINU,IMONT,ISECO,ISEKU, * IHOUR,IDAYS INTEGER IMONS(13,4) SAVE DATA IMONS/ 0,31,59,90,120,151,181,212,243,273,304,334,365, + 0,31,60,91,121,152,182,213,244,274,305,335,366, + 0,31,28,31, 30, 31, 30, 31, 31, 30, 31, 30, 31, + 0,31,29,31, 30, 31, 30, 31, 31, 30, 31, 30, 31 / C----------------------------------------------------------------------- CALL TIMER( ISECO ) C SECONDS, MINUTS, HOURS, YEAR ISEKU = MOD(ISECO,60) ISECO = ISECO/60 IMINU = MOD(ISECO,60) ISECO = ISECO/60 IHOUR = MOD(ISECO,24) ISECO = ISECO/24 IDAYS = ISECO RYEAR = 2.73785E-3*IDAYS+1.4E-3 IYEAR = 1970 + INT( RYEAR ) C LEAP DAYS ILEAP = 0 ILANG = 1 DO I = 1970, IYEAR IF ( (MOD(I,4) .EQ. 0 .AND. MOD(I,100) .NE. 0 ) + .OR. MOD(I,400) .EQ. 0 ) THEN ILEAP = ILEAP + 1 IF ( I .EQ. IYEAR ) THEN ILANG = 2 ILEAP = ILEAP - 1 ENDIF ENDIF ENDDO IDAYS = IDAYS - INT( RYEAR )*365 - ILEAP + 1 IF ( I .EQ. IYEAR+4 .AND. IDAYS .LT. IMONS(3,2) ) IDAYS=IDAYS+1 C MONTH AND DAY DO I = 2, 13 IF ( IMONS(I,ILANG) .GT. IDAYS ) GOTO 3 ENDDO 3 CONTINUE IMONT = I - 1 IDAYS = IDAYS-IMONS(IMONT,ILANG) IF ( IDAYS .EQ. 0 ) THEN IDAYS = IMONS(IMONT,2+ILANG) IMONT = IMONT - 1 ENDIF RETURN END #endif #if __TRAJECT__ C======================================================================= SUBROUTINE SIDTIM( TJDH,TJDL,GST ) C----------------------------------------------------------------------- C SID(ERAL) TIM(E) C THIS SUBROUTINE COMPUTES THE GREENWICH SIDEREAL TIME C (EITHER MEAN OR APPARENT) AT JULIAN DATE TJDH + TJDL. C SEE AOKI, ET AL. A&A 105 (1982) 359-361. C THIS SUBROUTINE IS TAKEN FROM: C http://aa.usno.navy.mil/software/novas/ novas\_info.ph C THIS SUBROUTINE IS CALLED FROM SOURCEPATH. C ARGUMENTS: C TJDH = JULIAN DATE, HIGH-ORDER PART (IN) C TJDL = JULIAN DATE, LOW-ORDER PART (IN) C JULIAN DATE MAY BE SPLIT AT ANY POINT, BUT C FOR HIGHEST PRECISION, SET TJDH TO BE THE INTEGRAL C PART OF THE JULIAN DATE, AND SET TJDL TO BE THE C FRACTIONAL PART C GST = GREENWICH (MEAN OR APPARENT) SIDEREAL TIME C IN HOURS (OUT) C C NOTE: FOR MOST APPLICATIONS, BASIS FOR INPUT JULIAN DATE SHOULD C BE UT1, WHICH RESULTS IN ORDINARY SIDEREAL TIME OUTPUT IN GST. C USE OF INPUT JULIAN DATE BASED ON TDB RESULTS IN C 'DYNAMICAl SIDEREAL TIME'. C----------------------------------------------------------------------- IMPLICIT NONE DOUBLE PRECISION DMOD,EQEQ,GST,ST,T,T0,T2,T3, * TH,TJD,TJDH,TJDL,TL,X SAVE C T0 = TDB JULIAN DATE OF EPOCH J2000.0 DATA T0 / 2451545.00000000D0 / C----------------------------------------------------------------------- TJD = TJDH + TJDL TH = (TJDH - T0) / 36525.0D0 TL = TJDL / 36525.0D0 T = TH + TL T2 = T * T T3 = T2 * T C FOR APPARENT SIDEREAL TIME, OBTAIN EQUATION OF THE EQUINOXES EQEQ = 0.D0 C ST = EQEQ - 6.2D-6 * T3 + 0.093104D0 * T2 + 67310.54841D0 * + 8640184.812866D0 * TL + 3155760000.0D0 * TL * + 8640184.812866D0 * TH + 3155760000.0D0 * TH GST = DMOD( ST/3600.0D0, 24.0D0 ) IF ( GST .LT. 0.D0 ) GST = GST + 24.0D0 RETURN END *-- Author : M. DOERT TU DORTMUND 06/01/2012 C======================================================================= SUBROUTINE SOURCEPATH( TSTEPS,THETAP,PHIP ) C----------------------------------------------------------------------- C CALCULATES THE SOURCE PATH IN ANGLES THETAP AND PHIP C FOR CONSECUTIVE STEPS TSTEPS. C THIS SUBROUTINE IS CALLED FROM AAMAIN. C ARGUMENTS: C TSTEPS = MAXIMUM NUMBER OF STEP (EVENTS TO BE SIMULATED) (IN) C THETAP = ZENITH ANGLE (IN RAD)(OUT) C PHIP = AZIMUTH ANGLE (IN RAD)(OUT) C----------------------------------------------------------------------- IMPLICIT NONE #define __CONSTAINC__ #define __RANDPAINC__ #define __RUNPARINC__ #define __TRAJECINC__ #include "corsika.h" DOUBLE PRECISION THETAP,PHIP DOUBLE PRECISION ALPHA,ALT,AZIM,DEC,DECL1,GMSTSTART,HA,HOURPLUS, * JULIANDATE,JULIANDATEFRAC,LMST,LMSTSTART, * RADIUS,RA1,TGEOLAT,TGEOLONG,TTEMP INTEGER TN,TSTEPS LOGICAL TINIT SAVE DATA TN / 0 / DATA TINIT / .TRUE. / C---------------------------------------------------------------------- C IN THE FIRST EXECUTION OF SOURCEPATH THE COORDINATES OF C THE TELESCOPE SITE ARE SET AND THE LOCAL MEAN SIDERIAL TIME IS C CALCULATED FOR THE START TIME IF ( TINIT ) THEN C TGEOLONG: GEOGRAPH. LONGITUDE NEEDED IN HOURS C TGEOLAT: GEOGRAPH. LATITUDE NEEDED IN RADIANS IF ( TLONGDIR .EQ. 'E' ) THEN C DEGREES ---> HOURS TGEOLONG = (TLONGDGR + TLONGMIN/60.D0 + TLONGSEC/3600.D0) * / 15.D0 ELSEIF ( TLONGDIR .EQ. 'W' ) THEN TGEOLONG = -1.D0 * (TLONGDGR + TLONGMIN/60.D0 + * TLONGSEC/3600.D0) / 15.D0 ELSE WRITE(MONIOU,*) 'SOURCEPATH: WRONG LONGITUDE DIRECTION = ', * TLONGDIR STOP ENDIF IF ( TLATDIR .EQ. 'N' ) THEN C DEGREES ---> RAD TGEOLAT = ( TLATDGR + TLATMIN/60.D0 + TLATSEC/3600.D0 ) * * PI2 / 360.D0 ELSEIF ( TLATDIR .EQ. 'S' ) THEN TGEOLAT = -1.D0 * ( TLATDGR + TLATMIN/60.D0 * + TLATSEC/3600.D0 ) * PI2 / 360.D0 ELSE WRITE(MONIOU,*) 'SOURCEPATH: WRONG LATITUDE DIRECTION = ', * TLATDIR STOP ENDIF C HOURPLUS = DBLE( THOUR ) + DBLE( TMINUTE )/60.D0 * + DBLE( TSECOND )/3600.D0 JULIANDATEFRAC = 0.D0 CALL JULDAT( TYEAR,TMONTH,TDAY,HOURPLUS,JULIANDATE ) CALL SIDTIM( JULIANDATE,JULIANDATEFRAC,GMSTSTART ) LMSTSTART = GMSTSTART + TGEOLONG TN = 0 TINIT = .FALSE. ENDIF TN = TN + 1 C SIMULATE EXTENDED SOURCE USING SPREADING IN RA DEC IF ( TRAD .GT. 0.D0 ) THEN CALL RMMARD( RD,2,1 ) ALPHA = PI2 * RD(1) RADIUS = TRAD/60.D0 * SQRT( RD(2) ) DECL1 = DECL + RADIUS * COS(ALPHA) RA1 = RA + RADIUS * SIN(ALPHA) / 15.D0 ELSE DECL1 = DECL RA1 = RA ENDIF C UP TO HERE DEC IN DEGREES AND RA IN HOURS C CONVERT FROM DEGREES TO RADIANS FOR DEC DEC = DECL1 * PI2 / 360.D0 C CALCULATE LOCAL MEAN SIDERIAL TIME FOR THIS STEP LMST = LMSTSTART + DBLE( TN ) * (DBLE( TDURATION )/3600.D0) * / DBLE( TSTEPS ) C CALCULATE HOUR ANGLE IN RADIANS HA = (LMST - RA1) * PI2 / 24.D0 C COORDINATE CONVERSION ALT = ASIN( SIN(TGEOLAT) * SIN(DEC) * + COS(TGEOLAT) * COS(DEC) * COS(HA) ) IF ( COS(TGEOLAT) .LT. 0.00001D0 ) THEN AZIM = HA ELSE AZIM = PI - ACOS( (SIN(DEC) - SIN(ALT)*SIN(TGEOLAT)) * / (COS(ALT)*COS(TGEOLAT)) ) IF (SIN(HA) .GT. 0.D0 ) AZIM = -AZIM ENDIF THETAP = 0.5D0 * PI - ALT C CHECK THETAP FOR VALIDITY WITHIN RANGE (< 70 DEG FOR UNCURVED) IF ( THETAP .LT. 0.D0 .OR. THETAP .GT. 70.D0 ) THEN WRITE(MONIOU,*) 'SOURCEPATH: THETAP OUT OF ALLOWED RANGE ', * 'THETAP=',THETAP,' TN=',TN STOP ENDIF C ADD MAGNETIC DECLINATION BECAUSE CORSIKA NORTH IS MAGNETIC C NORTH, WHEREAS COORDINATE TRANSFORMATION IS CALCULATED W.R.T. C GEOGRAPHIC NORTH. C NOTE: GEODEC IS NEGATIVE FOR WESTWARD DECLINATION PHIP = AZIM + GEODECL * PI/180.D0 IF ( PHIP .GT. PI2 ) PHIP = PHIP - PI2 IF ( PHIP .LT. 0.D0 ) PHIP = PHIP + PI2 IF ( TN .EQ. TSTEPS ) THEN C AT THE END OF THE FIRST PASSAGE OF THE TRACE THE MAXIMUM AND C MINIMUM VALUES OF THE THETA AND PHI COORDINATES ARE SET. C NOW RESET PASSAGE COUNTER FOR THE SECOND PASSAGE OF THE TRACE C DURING THE SHOWER SIMULATION. TINIT = .TRUE. TN = 0 WRITE(MONIOU,*) 'SOURCEPATH: ALL EVENTS',TSTEPS,' CREATED' ENDIF RETURN END #endif *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE STAEND C----------------------------------------------------------------------- C STA(RT) END C C SUBROUTINE FOR GETTING THE CONTROL PRINTOUT OF THE CONSTANT ARRAYS C PRINT CONTROL OUTPUT. C THIS SUBROUTINE IS CALLED FROM AAMAIN AND START. C----------------------------------------------------------------------- IMPLICIT NONE #define __ATMOSINC__ #define __ATMOS2INC__ #define __EDECAYINC__ #define __KAONSINC__ #define __PARPARINC__ #define __PARPAEINC__ #define __RUNPARINC__ #define __STRBARINC__ #if __ATMEXT__ #define __ATMOSXINC__ #endif #include "corsika.h" INTEGER I SAVE C----------------------------------------------------------------------- C PRINT CONTROL OUTPUT WRITE(MONIOU,103) (C(I),I=1,50) 103 FORMAT(/,/,' ',10('='),' CONSTANTS AND PARAMETERS ',43('='), * /,/,' PHYSICAL CONSTANTS C(1) TO C(50)', * /,(1P,4(E15.8,1X),E15.8) ) WRITE(MONIOU,110) (CKA(I),I=1,80) 110 FORMAT(/,/,' CONSTANTS FOR KAONS CKA(1) TO CKA(80)', * /,(1P,4(E15.8,1X),E15.8) ) WRITE(MONIOU,114) (CETA(I),I=1,5) 114 FORMAT(/,/,' CONSTANTS FOR ETAS CETA(1) TO CETA(5)', * /,(1P,4(E15.8,1X),E15.8) ) WRITE(MONIOU,115) (CSTRBA(I),I=1,11) 115 FORMAT(/,/,' CONSTANTS FOR STRANGE BARYONS CSTRBA(1) TO ', * 'CSTRBA(11)',/,(1P,4(E15.8,1X),E15.8) ) WRITE(MONIOU,200) 200 FORMAT(/,/,' ',10('='),' ATMOSPHERE ', 57('='),/ ) #if __ATMEXT__ IF ( IATMOX .GE. 1 ) THEN WRITE(MONIOU,299) IATMOX 299 FORMAT(' ( EXTERNAL ATMOSPHERE FROM TABLE',I3,' AS FITTED )',/) ELSEIF ( MODATM .EQ. 0 ) THEN #else IF ( MODATM .EQ. 0 ) THEN #endif WRITE(MONIOU,300) 300 FORMAT(' ( ATMOSPHERE GIVEN BY INPUT (LAYER 5 UNCHANGED)') ELSEIF ( MODATM .EQ. 1 ) THEN WRITE(MONIOU,301) 301 FORMAT(' ( US STANDARD ATMOSPHERE PARAMETERIZED BY LINSLEY )') ELSEIF ( MODATM .EQ. 2 ) THEN WRITE(MONIOU,302) 302 FORMAT(' ( ATMOSPHERE AT115 PARAMETERIZED BY H. ULRICH )') ELSEIF ( MODATM .EQ. 3 ) THEN WRITE(MONIOU,303) 303 FORMAT(' ( ATMOSPHERE AT223 PARAMETERIZED BY H. ULRICH )') ELSEIF ( MODATM .EQ. 4 ) THEN WRITE(MONIOU,304) 304 FORMAT(' ( ATMOSPHERE AT511 PARAMETERIZED BY H. ULRICH )') ELSEIF ( MODATM .EQ. 5 ) THEN WRITE(MONIOU,305) 305 FORMAT(' ( ATMOSPHERE AT616 PARAMETERIZED BY H. ULRICH )') ELSEIF ( MODATM .EQ. 6 ) THEN WRITE(MONIOU,306) 306 FORMAT(' ( ATMOSPHERE AT822 PARAMETERIZED BY H. ULRICH )') ELSEIF ( MODATM .EQ. 7 ) THEN WRITE(MONIOU,307) 307 FORMAT(' ( ATMOSPHERE AT1014 PARAMETERIZED BY H. ULRICH )') ELSEIF ( MODATM .EQ. 8 ) THEN WRITE(MONIOU,308) 308 FORMAT(' ( ATMOSPHERE AT1224 PARAMETERIZED BY H. ULRICH )') ELSEIF ( MODATM .EQ. 9 ) THEN WRITE(MONIOU,309) 309 FORMAT(' ( ATMOSPHERE GIVEN BY INPUT (LAYER 5 UNCHANGED)') ELSEIF ( MODATM .EQ. 10 ) THEN WRITE(MONIOU,310) 310 FORMAT(' ( ATMOSPHERE GIVEN BY INPUT (LAYER 5 CHANGED) )') ELSEIF ( MODATM .EQ. 11 ) THEN WRITE(MONIOU,311) 311 FORMAT(' ( SOUTH POLE ATMOSPHERE FOR 97MAR31 (MSIS-90-E) )') ELSEIF ( MODATM .EQ. 12 ) THEN WRITE(MONIOU,312) 312 FORMAT(' ( SOUTH POLE ATMOSPHERE FOR 97JUL01 (MSIS-90-E) )') ELSEIF ( MODATM .EQ. 13 ) THEN WRITE(MONIOU,313) 313 FORMAT(' ( SOUTH POLE ATMOSPHERE FOR 97OCT01 (MSIS-90-E) )') ELSEIF ( MODATM .EQ. 14 ) THEN WRITE(MONIOU,314) 314 FORMAT(' ( SOUTH POLE ATMOSPHERE FOR 97DEC31 (MSIS-90-E) )') ELSEIF ( MODATM .EQ. 15 ) THEN WRITE(MONIOU,315) 315 FORMAT(' ( SOUTH POLE ATMOSPHERE FOR JANUARY, LIPARI(GS) )') ELSEIF ( MODATM .EQ. 16 ) THEN WRITE(MONIOU,316) 316 FORMAT(' ( SOUTH POLE ATMOSPHERE FOR AUGUST, LIPARI(GS) )') ELSEIF ( MODATM .EQ. 17 ) THEN WRITE(MONIOU,317) 317 FORMAT(' ( US STANDARD ATMOSPHERE PARAMETERIZED BY KEILHAUER)') ELSEIF ( MODATM .EQ. 18 ) THEN WRITE(MONIOU,318) 318 FORMAT(' ( MALARGUE ATMOSPHERE FOR JANUARY (GDAS) )') ELSEIF ( MODATM .EQ. 19 ) THEN WRITE(MONIOU,319) 319 FORMAT(' ( MALARGUE ATMOSPHERE FOR FEBRUARY (GDAS) )') ELSEIF ( MODATM .EQ. 20 ) THEN WRITE(MONIOU,320) 320 FORMAT(' ( MALARGUE ATMOSPHERE FOR MARCH (GDAS) )') ELSEIF ( MODATM .EQ. 21 ) THEN WRITE(MONIOU,321) 321 FORMAT(' ( MALARGUE ATMOSPHERE FOR APRIL (GDAS) )') ELSEIF ( MODATM .EQ. 22 ) THEN WRITE(MONIOU,322) 322 FORMAT(' ( MALARGUE ATMOSPHERE FOR MAY (GDAS) )') ELSEIF ( MODATM .EQ. 23 ) THEN WRITE(MONIOU,323) 323 FORMAT(' ( MALARGUE ATMOSPHERE FOR JUNE (GDAS) )') ELSEIF ( MODATM .EQ. 24 ) THEN WRITE(MONIOU,324) 324 FORMAT(' ( MALARGUE ATMOSPHERE FOR JULY (GDAS) )') ELSEIF ( MODATM .EQ. 25 ) THEN WRITE(MONIOU,325) 325 FORMAT(' ( MALARGUE ATMOSPHERE FOR AUGUST (GDAS) )') ELSEIF ( MODATM .EQ. 26 ) THEN WRITE(MONIOU,326) 326 FORMAT(' ( MALARGUE ATMOSPHERE FOR SEPTEMBER (GDAS) )') ELSEIF ( MODATM .EQ. 27 ) THEN WRITE(MONIOU,327) 327 FORMAT(' ( MALARGUE ATMOSPHERE FOR OCTOBER (GDAS) )') ELSEIF ( MODATM .EQ. 28 ) THEN WRITE(MONIOU,328) 328 FORMAT(' ( MALARGUE ATMOSPHERE FOR NOVEMBER (GDAS) )') ELSEIF ( MODATM .EQ. 29 ) THEN WRITE(MONIOU,329) 329 FORMAT(' ( MALARGUE ATMOSPHERE FOR DECEMBER (GDAS) )') ENDIF WRITE(MONIOU,400) (HLAY(I)*1.D-6,HLAY(I+1)*1.D-6, * AATM(I),BATM(I),CATM(I)*1.E-5,I=1,4), * HLAY(5)*1.D-6,HLAY(6)*1.D-6,AATM(5),CATM(5)*1.E-5 400 FORMAT(' HEIGHT H IN KM GIVES THICKNESS OF ATMOSPHERE T IN ', * 'G/CM**2',/,1P,' H = ',F5.1,'...',F5.1,' KM ---> T = ', * E12.5,' +',E11.4,' * EXP( -H /',E11.4,')',/, * ' H = ',F5.1,'...',F5.1,' KM ---> T = ', * E12.5,' +',E11.4,' * EXP( -H /',E11.4,')',/, * ' H = ',F5.1,'...',F5.1,' KM ---> T = ', * E12.5,' +',E11.4,' * EXP( -H /',E11.4,')',/, * ' H = ',F5.1,'...',F5.1,' KM ---> T = ', * E12.5,' +',E11.4,' * EXP( -H /',E11.4,')',/, * ' H = ',F5.1,'...',F5.1,' KM ---> T = ', * E12.5,' - H /',E11.4 ) RETURN END *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE START C----------------------------------------------------------------------- C START C C PRINTS HEADER AND ALL SELECTED OPTIONS C PERFORMS INITIALIZATIONS AND CHECKS AT THE BEGINNING OF RUN. C CALLS DATAC TO READ IN DATA CARDS. C INITIALIZES ATMOSPHERIC MODELS C CHECKS AND INITIALIZES SELECTED HADRONIC INTERACTION MODEL. C THIS SUBROUTINE IS CALLED FROM AAMAIN. C----------------------------------------------------------------------- IMPLICIT NONE #define __AIRINC__ #define __ATMOSINC__ #define __ATMOS2INC__ #define __BUFFSINC__ #define __CONSTAINC__ #define __DPMFLGINC__ #define __EDECAYINC__ #define __ELABCTINC__ #define __ETHMAPINC__ #define __KAONSINC__ #define __MAGNETINC__ #define __MUMULTINC__ #define __MUPARTINC__ #define __NCSNCSINC__ #define __NKGIINC__ #define __OBSPARINC__ #define __PAMINC__ #define __PARPARINC__ #define __PARPAEINC__ #define __PRIMSPINC__ #define __RANDPAINC__ #define __RUNPARINC__ #define __STACKFINC__ #define __STRBARINC__ #define __VERSINC__ #if __CONEX__ #define __ATMOS3INC__ #endif #if __DPMJET__ #define __DPMJETINC__ #endif #if __EPOS__ || __NEXUS__ #define __NEXUSINC__ #endif #if __QGSJET__ #define __QGSCINC__ #endif #if __SIBYLL__ #define __SIBYLCINC__ #endif #if __VENUS__ #define __VENUSINC__ #endif #if __ATMEXT__ #define __ATMOSXINC__ #endif #if __CERENKOV__ #define __CEREN2INC__ #define __CERTELINC__ #define __CEREN3INC__ #endif #if __CERENKOV__ && !__IACT__ #define __CERTELINC__ #endif #if __MULTITHIN__ #define __MULTHININC__ #endif #if __INTTEST__ #define __TSTINTINC__ #endif #include "corsika.h" DOUBLE PRECISION HEIGH,OOO,TEMP1,TEMP2,TEMP3,THICK, * TTIME,ZE,ZS,ZX INTEGER I,IA,J,L SAVE EXTERNAL HEIGH,THICK #if __PARALLELIB__ INTEGER INIHCALL,INILCALL,INIECALL,lfil DATA INIHCALL/0/,INILCALL/0/,INIECALL/0/ #endif C----------------------------------------------------------------------- #if __PARALLELIB__ C---------change----------opening input file MONIOU = 89 OPEN(UNIT=MONIOU,FILE=CFILOUT,ACCESS='APPEND') lfil = 2 + index(cfilinp,'cut') WRITE(MONIOU,'(1x,a)') CFILINP(1:lfil) if ( I1CUTPAR .gt. 0 ) then WRITE(MONIOU,'('' Using particles from'',i7,'' to'',i7 )') + I1CUTPAR,I2CUTPAR else WRITE(MONIOU,'('' Writing particles'')') endif #endif C SAY HELLO WRITE(MONIOU,112) 112 FORMAT(/,' ',80('A'),/,/, *' OOO OOO OOOO OOOO OO O O O ',/, *' O O O O O O O O OO O O O O ',/, *' O O O O O O OO O O O O',/, *' O O O O O OOOO OO OO O O', */, *' O O O OOOO O OO O O OOOOOOO', */, *' O O O O O O O O OO O O O O', */, *' OOO OOO O O OOOO OO O O O O', */,/,' COSMIC RAY SIMULATION FOR KASCADE',/,/, *' A PROGRAM TO SIMULATE EXTENSIVE AIR SHOWERS IN ATMOSPHERE',/,/, *' BASED ON A PROGRAM OF P.K.F. GRIEDER, UNIVERSITY BERN,', *' SWITZERLAND',/, #if __DPMJET__ *' DPMJET-III MODEL ACCORDING TO S. ROESLER (CERN), A. FEDYNITCH', *' (DESY), R. ENGEL (KIT), AND J. RANFT (SIEGEN)',/, #elif __EPOS__ *' EPOS MODEL ACCORDING TO K. WERNER ET AL., UNIVERSITY NANTES,', *' FRANCE',/, #elif __NEXUS__ *' neXus MODEL ACCORDING TO K. WERNER ET AL., UNIVERSITY NANTES,', *' FRANCE',/, #elif __QGSJET__ #if __QGSII__ *' QGSJET-II MODEL ACCORDING TO S.S. OSTAPCHENKO, IEKP, KARLSRUHE', *' AND MSU, MOSCOW, RUSSIA',/, #else *' QGSJET MODEL ACCORDING TO N.N. KALMYKOV AND S.S. OSTAPCHENKO,', *' MSU, MOSCOW, RUSSIA',/, #endif #elif __SIBYLL__ *' SIBYLL 2.3 MODEL ACCORDING TO F. RIEHN & R. ENGEL, IKP KIT', *' KARLSRUHE,',/, #elif __VENUS__ *' VENUS MODEL ACCORDING TO K. WERNER, UNIVERSITY NANTES, FRANCE', */, #endif *' HDPM MODEL ACCORDING TO J.N. CAPDEVIELLE, COLLEGE DE FRANCE,', *' PARIS, FRANCE',/, #if __FLUKA__ *' FLUKA MODEL FROM A. FASSO (CERN), A. FERRARI, J. RANFT', *' (SIEGEN), AND P. SALA,',/, *' INFN MILAN, MILAN, ITALY, AND CERN, GENEVA, SWITZERLAND', */, #elif __GHEISHAD__ *' GHEISHA ROUTINES ACCORDING TO H. FESEFELDT, RWTH AACHEN,', *' GERMANY',/, #elif __URQMD__ *' URQMD-MODEL FROM THE URQMD-COLLABORATION, FRANKFURT(MAIN),', *' GERMANY',/, #endif *' EGS4 ACCORDING TO W.R. NELSON, H. HIRAYAMA, D.W.O. ROGERS,', *' SLAC, STANFORD, USA',/, *' NKG FORMULAS FOR FAST SIMULATION OF EL.MAG. PARTICLES',/,/, *' REFERENCES: D. HECK, J.KNAPP, J.N. CAPDEVIELLE, G. SCHATZ,', * ' T. THOUW,',/,' REPORT FZKA 6019 (1998)',/, #if __THIN__ *' D. HECK, J. KNAPP, REPORT FZKA 6097 (1998)',/, #endif #if __SLANT__ || __CURVED__ || __UPWARD__ *' D. HECK, REPORT FZKA 7254 (2006)',/, #endif *' SEE ALSO WEB PAGE https://www.ikp.kit.edu/corsika/') WRITE(MONIOU,912) VERNUM,VERDAT 912 FORMAT( ' KARLSRUHE INSTITUTE OF TECHNOLOGY (KIT)',/, * ' INSTITUT FUER KERNPHYSIK',/, * ' POSTFACH 3640',/, * ' D-76021 KARLSRUHE',/, * ' GERMANY',/,/, * ' IN CASE OF PROBLEMS CONTACT: Dr. Tanguy Pierog',/, * ' e-mail: tanguy.pierog@kit.edu',/, * ' FAX: (49) 721-608-24075 ',/, * ' PHONE: (49) 721-608-28134 ',/, * ' OR : Dr. Dieter Heck ',/, * ' e-mail: dieter.heck@partner.kit.edu',/, * ' FAX: (49) 721-608-24075 ',/, * ' PHONE: (49) 721-608-23777 ',/, * ' AND SEND YOUR LIST-FILE BY E-MAIL',/,/, * ' NUMBER OF VERSION : ',F7.4,/, * ' DATE OF VERSION : ',A18 ,/) #if __UNIX__ WRITE(MONIOU,*) 'VERSION GENERATED FOR UNIX OR COMPATIBLE SYSTEMS' WRITE(MONIOU,*) '^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^' #if __BYTERECL__ WRITE(MONIOU,*) ' (RECL IS DEFINED IN BYTES)' #else WRITE(MONIOU,*) ' (RECL IS DEFINED IN (4-BYTE) WORDS)' #endif #if __OLDDATE__ WRITE(MONIOU,*) ' WITH OLD DATE ROUTINE' #elif __OLDDATE2__ WRITE(MONIOU,*) ' WITH OLD DATE ROUTINE FOR LINUX BETA' #elif __TIMERC__ WRITE(MONIOU,*) ' WITH TIMERC DATE ROUTINE' #elif __IBMRISC__ WRITE(MONIOU,*) ' WITH DATE AND TIME FOR IBM RS' #else WRITE(MONIOU,*) ' WITH NEW DATE_AND_TIME ROUTINE' #endif #elif __MAC__ WRITE(MONIOU,*) 'VERSION GENERATED FOR MAC' WRITE(MONIOU,*) '^^^^^^^^^^^^^^^^^^^^^^^^^' #endif #if __VOLUMEDET__ WRITE(MONIOU,*) 'ZENITH ANGLE DEPENDENCE FOR VOLUME DETECTOR' #elif __VOLUMECORR__ WRITE(MONIOU,*) * 'ZENITH ANGLE DEPENDENCE FOR VERTICAL STRING DETECTOR' #else WRITE(MONIOU,*) 'ZENITH ANGLE DEPENDENCE FOR FLAT DETECTOR ARRAY' #endif WRITE(MONIOU,*) ' ' #if __ANAHIST__ WRITE(MONIOU,1001) 1001 FORMAT(' ANAHIST VERSION WITH THINNING (NEEDS HBOOK ROUTINES)',/, * ' ====================================================',/) #endif #if __ATMEXT__ WRITE(MONIOU,1003) 1003 FORMAT(' INTERFACE FOR EXTERNAL ATMOSPHERIC PROFILES ENABLED',/, * ' ===================================================',/) #endif #if __AUGCERLONG__ WRITE(MONIOU,1014) 1014 FORMAT * (' CHERENKOV RADIATION IS GENERATED FOR LONGITUDINAL TABLE',/, * ' =======================================================',/) #endif #if __AUGERHIST__ WRITE(MONIOU,1021) 1021 FORMAT(' AUGERHIST VERSION WITH THINNING (NEEDS HBOOK ROUTINES)',/ * ,' ======================================================',/) #endif #if __AUGERHIT__ WRITE(MONIOU,1020) 1020 FORMAT(' AUGERHIT VERSION FOR REDUCTION OF PARTICLE OUTPUT',/ * ,' =================================================',/) #endif #if __CERENKOV__ WRITE(MONIOU,1044) 1044 FORMAT(' CHERENKOV RADIATION IS GENERATED',/, * ' ================================',/) #if __CERWLEN__ WRITE(MONIOU,*) 'WITH WAVELENGTH DEPENDENCE' #endif #if __CEFFIC__ WRITE(MONIOU,1045) 1045 FORMAT(' ATMOSPHERIC ABSORPTION, MIRROR REFLECTIVITY AND ', * 'QUANTUM EFFICIENCY MAY BE RESPECTED',/) #endif #if __IACT__ WRITE(MONIOU,1048) 1048 FORMAT(' INTERFACE FOR SYSTEMS OF TELESCOPES OR OTHER CHERENKOV ', * 'DETECTORS ENABLED',/) #if __IACTEXT__ WRITE(MONIOU,*) 'EXTENDED INTERFACING FOR IACT ROUTINES' #endif #endif #endif #if __TRAJECT__ WRITE(MONIOU,*) 'TRAJECTORY VERSION TO FOLLOW EMITTING SOURCE' WRITE(MONIOU,*) '============================================' WRITE(MONIOU,*) ' ' #endif #if __COAST__ WRITE(MONIOU,1556) #if __COASTUSERLIB__ 1556 FORMAT(' COASTUSERLIB IS USED',/, * ' ====================',/) #else 1556 FORMAT(' PARTICLE OUTPUT IS WRITTEN TO ROOT',/, * ' ==================================',/) #endif #endif #if __CHARM__ #if __DPMJET__ WRITE(MONIOU,*) 'CHARMED PARTICLES ARE TRANSPORTED AND DECAY ONLY' WRITE(MONIOU,*) '================================================' #else WRITE(MONIOU,*) 'CHARMED PARTICLES ARE EXPLICITELY TREATED' WRITE(MONIOU,*) '=========================================' #endif WRITE(MONIOU,*) ' ' #endif #if __COMPACT__ WRITE(MONIOU,1501) 1501 FORMAT(' PARTICLE OUTPUT IS WRITTEN IN COMPACT FORM',/, * ' ==========================================',/) #endif #if __CONEX__ WRITE(MONIOU,1550) 1550 FORMAT(' CONEX VERSION WITH CASCADE EQUATIONS',/ * ,' ====================================',/ * ,' WARNING: DESPITE A LOT OF SUCCESSFUL TESTS,',/ * ,' THE AUTHORS COULD NOT TEST ALL POSSIBLE COMBINATIONS' * ,' OF MODELS AND OBSERVABLE TYPES.',/,' FOR THE MOMENT THE' * ,' PRECISION EXPECTED BY THE USE OF CONEX OPTION SHOULD BE' * ,' BETTER THAN 10%',/,' COMPARED TO USUAL CORSIKA FOR A ' * ,' FACTOR OF 10 GAIN IN CPU TIME',/,' BUT IT MAY DEPEND ON' * ,' THE INITIAL CONDITIONS AND OBSERVABLES.',/ * ,' AS A CONSEQUENCE THEY DECLINE ANY RESPONSABILITY IF AN' * ,' ANALYSIS IS BIASED BY THE USE OF CONEX OPTION.',/ * ,' THE USER SHOULD VALIDATE HIS ANALYSIS BY THE USE OF ',/ * ,' CORSIKA WITHOUT CONEX FOR PARTICLE BASED ANALYSIS.',/ * ,' 1D SIMULATIONS BASED ON CONEX ARE ALREADY USED' * ,' INTENSIVELY SINCE MANY YEARS.',/ * ,' ====================================',/) #endif #if __CURVED__ WRITE(MONIOU,1502) 1502 FORMAT(' CURVED VERSION WITH SLIDING PLANAR ATMOSPHERE',/, * ' =============================================',/) #endif #if __DYNSTACK__ WRITE(MONIOU,1514) 1514 FORMAT(' VERSION WITH EXTENSIONS DYNSTACK',/, * ' ===============================================',/) #endif #if __EHISTORY__ WRITE(MONIOU,1511) 1511 FORMAT(' VERSION WITH EXTENDED PARTICLE HISTORY',/, * ' ======================================',/) #endif #if __ICECUBE1__ WRITE(MONIOU,1512) 1512 FORMAT(' VERSION WITH EXTENSIONS FOR ICECUBE (RINGBUFFER FIFO)',/, * ' =====================================================',/) #endif #if __ICECUBE2__ WRITE(MONIOU,1513) 1513 FORMAT(' VERSION WITH EXTENSIONS FOR ICECUBE (GZIP/PIPE)',/, * ' ===============================================',/) #endif #if __INTTEST__ WRITE(MONIOU,1531) 1531 FORMAT(' INTERACTION TEST VERSION (NEEDS HBOOK ROUTINES)',/, * ' ===============================================',/) #if __MAC__ WRITE(MONIOU,*) 'INTTEST AND MAC ARE CONFLICTING OPTIONS' WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE COMBINATION OF OPTIONS' STOP #endif #endif #if __MULTITHIN__ WRITE(MONIOU,1529) 1529 FORMAT(' MULTITHIN VERSION',/, * ' =================',/) #endif #if __MUONHIST__ WRITE(MONIOU,1022) 1022 FORMAT(' MUONHIST VERSION (NEEDS HBOOK ROUTINES)',/, * ' =======================================',/) #endif #if __MUPROD__ WRITE(MONIOU,1530) 1530 FORMAT(' VERSION WITH HISTORY OF DECAYING MUONS',/, * ' ======================================',/) #endif #if __NEUTRINO__ WRITE(MONIOU,1542) 1542 FORMAT(' NEUTRINOS ARE EXPLICITELY GENERATED',/, * ' ===================================',/) #endif #if __NUPRIM__ WRITE(MONIOU,1543) 1543 FORMAT(' PRIMARY NEUTRINOS ARE TREATED BY HERWIG',/, * ' =======================================') WRITE(MONIOU,1544) 1544 FORMAT(' FOR THE HERWIG MODEL SEE WEB PAGE:',/, * ' http://www.hep.phy.cam.ac.uk/theory/webber/Herwig/',/) #endif #if __PARALLEL__ WRITE(MONIOU,1545) 1545 FORMAT(' PARALLEL OPTION ENABLED',/, * ' =======================',/) #if __PARALLELIB__ WRITE(MONIOU,1546) 1546 FORMAT(' PARALLELIB OPTION ENABLED',/, * ' =========================',/) #endif #endif #if __PRESHOWER__ WRITE(MONIOU,1551) 1551 FORMAT(' GAMMA SHOWER WITH PRESHOWER IN EARTH MAGNETIC FIELD',/, * ' ===================================================',/) #endif #if __REMOTECONTROL__ WRITE(MONIOU,1515) 1515 FORMAT(' VERSION WITH EXTENSIONS REMOTECONTROL',/, * ' ===============================================',/) #endif #if __SLANT__ WRITE(MONIOU,1503) 1503 FORMAT(' SLANT DEPTH FOR LONGITUDINAL DISTRIBUTIONS',/, * ' ==========================================',/) #endif #if __STACKIN__ WRITE(MONIOU,*) 'STACKIN: SECONDARIES ARE READ IN' WRITE(MONIOU,*) '================================' WRITE(MONIOU,*) ' ' #endif #if __TAULEP__ || __CHARM__ WRITE(MONIOU,*) 'TAU LEPTONS ARE EXPLICITELY TREATED' WRITE(MONIOU,*) '===================================' WRITE(MONIOU,*) ' ' #endif #if __THIN__ WRITE(MONIOU,1563) 1563 FORMAT(' THINNING IS ACTIVE',/, * ' ==================',/) #else #if __LPM__ || __PARALLEL__ WRITE(MONIOU,*) 'LPM_EFFECT IS ACTIVE' WRITE(MONIOU,*) '====================' WRITE(MONIOU,*) ' ' #endif #endif #if __UPWARD__ WRITE(MONIOU,1620) 1620 FORMAT(' UPWARD VERSION FOR UPWARD GOING PARTICLES',/, * ' =========================================',/) #endif #if __VIEWCONE__ WRITE(MONIOU,1632) 1632 FORMAT(' PRIMARY DIRECTION IS SELECTED FROM VIEWING CONE',/, * ' ===============================================',/) #endif WRITE(MONIOU,*) ' ' C C INITIALIZE ARRAY WITH PARTICLE MASSES CALL PAMAF C READ RUN STEERING DATA CARDS CALL DATAC #if __PARALLELIB__ C FILL 2ND STACK FROM INPUT FILE IF NOT PRIMARY INTERACTION C SHOULD BE CALL AFTER DATAC NOT TO USE THE DEFAULT VALUE C OF FECTOUT AND SEED FECTOUT = .TRUE. IF ( .NOT. FPRIM ) THEN IF ( I1CUTPAR .NE. I2CUTPAR .AND. I2CUTPAR .NE. 0 ) * FECTOUT = .FALSE. CALL CUTREAD ENDIF C SWITCH OFF DATABASE FILE IF NOT FIRST CALL IF ( .NOT. FPRIM ) FDBASE = .FALSE. #elif __PARALLEL__ C DEFINE IF WE ARE IN THE PRIMARY RUN FPRIM = .TRUE. IF ( JCOUNT .GT. 1 ) FPRIM = .FALSE. #endif #if __ATMEXT__ IF ( FREFRX ) WRITE(MONIOU,144) 144 FORMAT(/,' ATMOSPHERIC REFRACTION IS TAKEN INTO ACCOUNT',/, * ' ============================================',/) #endif C ORDERING OF OBSERVATION LEVELS FROM TOP TO BOTTOM IF ( NOBSLV .GT. 1 ) THEN 215 CONTINUE DO I = 2, NOBSLV IF ( OBSLEV(I) .GT. OBSLEV(I-1) ) THEN OOO = OBSLEV(I) OBSLEV(I) = OBSLEV(I-1) OBSLEV(I-1) = OOO GOTO 215 ENDIF ENDDO ENDIF IF ( NOBSLV .LT. 20 ) THEN DO I = NOBSLV+1, 20 OBSLEV(I) = 0.D0 ENDDO ENDIF #if __CURVED__ C CALCULATION OF CORRECTION FACTOR IN CASE OF CURVOUT OPTION CORRXY = ( C(1) + OBSLEV(1) ) / C(1) IF ( .NOT. FFLATOUT ) WRITE(MONIOU,145) 145 FORMAT( ' PARTICLES REGISTERED ON CURVED OBSLEV',/, * ' (X,Y) ARE NOT CARTESIAN COORDINATES!',/, * ' PLEASE READ THE USERS GUIDE',/, * ' SEE KEYWORD: CURVOUT/FLATOUT',/, * ' =====================================',/) #endif WRITE(MONIOU,1441) 1441 FORMAT(/) C PREPARE ATMOSPHERIC MODEL IF ( MODATM .LT. 0 .OR. MODATM .GT. 29 ) THEN WRITE(MONIOU,*) 'START : MODATM < 0 OR > 29 NOT POSSIBLE! STOP' WRITE(MONIOU,*) WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORD: ATMOD' STOP ENDIF C SET LOWER BOUNDARIES OF THE AIR LAYERS IF ( LAYNEW ) THEN C TAKE THE BOUNDARIES READ IN I = 0 ELSE C TAKE THE DEFAULT BOUNDARIES I = LAYNO(MODATM) ENDIF C SET THE SELECTED ATMOSPHERE AND LAYERS DO L = 1, 5 HLAY(L) = HLAY0(L,I) AATM(L) = AATM0(L,MODATM) BATM(L) = BATM0(L,MODATM) CATM(L) = CATM0(L,MODATM) DATM(L) = 1.D0 / CATM(L) ENDDO #if __ATMEXT__ C SET THE ATMOSPHERIC MODEL NUMBER, READING AN EXTERNAL FILE IF NEEDED. C PARAMETERS FOR TAKING REFRACTION INTO ACCOUNT ARE CALCULATED EVEN C FOR CORSIKA BUILT-IN MODELS. IF ( IATMOX .GE. 1 .OR. FREFRX ) THEN CALL ATMSET( IATMOX,OBSLEV(NOBSLV) ) ENDIF C FOR AN EXTERNAL ATMOSPHERE, FIT PARAMETERS USED IN CORSIKA-EGS PART. IF ( IATMOX .GE. 1 ) THEN IF ( LAYNEW ) THEN CALL ATMFIT( -5,HLAY,AATM,BATM,CATM ) ELSE CALL ATMFIT( 5,HLAY,AATM,BATM,CATM ) ENDIF WRITE(MONIOU,*) 'FITTED ATMOSPHERIC PARAMETERS:' WRITE(MONIOU,*) 'HLAY =',(HLAY(L),L=1,5) WRITE(MONIOU,*) 'AATM =',(AATM(L),L=1,5) WRITE(MONIOU,*) 'BATM =',(BATM(L),L=1,5) WRITE(MONIOU,*) 'CATM =',(CATM(L),L=1,5) DO L = 1, 5 DATM(L) = 1.D0 / CATM(L) ENDDO ENDIF #endif #if __CURVED__ && __UPWARD__ C LIMIT ATMOSPHERE LOWER BOUNDARY TO SEA LEVEL HLAY(1) = MAX( HLAY(1), -1000.D2 ) #endif C CALCULATE THICKNESS AT LOWER BOUNDARIES OF AIR LAYERS DO L = 1, 5 THICKL(L) = THICK( HLAY(L) ) IF ( THICKL(L) .LT. 0.D0 ) THEN WRITE(MDEBUG,98) L,THICKL(L) 98 FORMAT(' START : BAD SELECTION OF ATMOSPHERIC PARAMETERS', * /,' MASS OVERLAY OF LAYER ',I5,' MUST NOT BE NEGATIVE:', * ' THICKL =',E15.8) STOP ENDIF ENDDO HLAY(6) = HEIGH( 0.D0 ) IF ( DEBUG ) WRITE(MDEBUG,99) $ (L,HLAY(L),THICKL(L),L=1,5),HLAY(6) 99 FORMAT(' START : ATMOSPHERIC LAYERS',/, $ ' NR. HLAY (CM) THICKL (G/CM**2)',/, $ 5(8X,I3,1X,E16.8,1X,E16.8,/), $ 8X,' 6',1X,E16.8,' 0.00000') #if __CONEX__ C SAVE ATMOSPHERIC PARAMETERS FOR CONEX DO L = 1, 5 AATMCRS(L) = AATM(L) BATMCRS(L) = BATM(L) CATMCRS(L) = CATM(L) DATMCRS(L) = DATM(L) EATMCRS(L) = HLAY(L) ENDDO EATMCRS(6) = HLAY(6) #endif C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C CLEARS BUFFERS FOR HEADER AND FILLS IN PERMANENT INFORMATION DO L = 1, MAXBUF EVTH(L) = 0. EVTE(L) = 0. RUNH(L) = 0. RUNE(L) = 0. DATAB(L) = 0. ARRAYLONG(L) = 0. #if __CERENKOV__ do i=1,nmaxcertel DATAB2(L, i) = 0. enddo #endif ENDDO C PERMANENT INFORMATION C CHARACTER STRINGS CRUNH = 'RUNH' CRUNE = 'RUNE' CEVTH = 'EVTH' CEVTE = 'EVTE' CLONG = 'LONG' RUNH(2) = REAL( NRRUN ) RUNE(2) = REAL( NRRUN ) EVTH(44) = REAL( NRRUN ) C DATE OF RUN WRITE(MONIOU,101) 101 FORMAT(/,' ',10('='),' START OF RUN ',55('='),/) CALL PRTIME( TTIME ) RUNH(3) = TTIME EVTH(45) = TTIME C VERSION OF PROGRAM RUNH(4) = VERNUM EVTH(46) = VERNUM C----------------------------------------------------------------------- C INITIALIZATION FOR RANDOM NUMBER GENERATOR C 2 SEQUENCES NEEDED BECAUSE MUON/TAU NUCLEAR INTERACTIONS USE C EGS ROUTINES IF ( NSEQ .LT. 2 ) THEN WRITE(MONIOU,*) WRITE(MONIOU,*) 'TOO FEW RANDOM SEEDS: NSEQ =',NSEQ WRITE(MONIOU,*) 'AT MINIMUM TWO RANDOM SEEDS ARE NECESSARY' WRITE(MONIOU,*) 'USE THE DEFAULT SEED(S)' WRITE(MONIOU,*) NSEQ = 2 ENDIF #if __PRESHOWER__ FEGS = .TRUE. #endif #if __CONEX__ C IN CASE OF CONEX THE 7TH RANDOM SEQUENCE IS NEEDED C EVENTUALLY THE DEFAULT SEED IS USED OR THE LAST LINE IS USED FOR CONEX IF ( NSEQ .LT. 7 )THEN IF ( NSEQ .GT. 2 #if __PARALLEL__ * .AND. NSEQ .NE. 6 #endif #if __NUPRIM__ * .AND. NSEQ .NE. 5 #endif #if __IACT__ || _AUGERHIT__ * .AND. NSEQ .NE. 4 #endif #if __CERENKOV__ || __AUGERHIST__ || __AUGCERLONG__ * .AND. NSEQ .NE. 3 #endif * ) THEN C IN CASE SEED ARE NOT DEFINED FOR SPECIAL OPTIONS, USES LAST LINE FOR CONEX C THE 7TH SEQUENCE IS USED TO C SELECT RANDOMLY THE RANDOM NUMBERS USED TO FIX SEED OF HIGH ENERGY C PARTICLES IN CONEX ISEED(1,7) = ISEED(1,NSEQ) ISEED(2,7) = ISEED(2,NSEQ) ISEED(3,7) = ISEED(3,NSEQ) IF ( ISEED(1,NSEQ+1) .NE. NSEQ+1 ) THEN ISEED(1,8) = ISEED(1,NSEQ+1) ISEED(2,8) = ISEED(2,NSEQ+1) ISEED(3,8) = ISEED(3,NSEQ+1) ENDIF C SET AGAIN DEFAULT VALUE FOR DUMMY SEQUENCE ISEED(1,NSEQ) = NSEQ ISEED(2,NSEQ) = 0 ISEED(3,NSEQ) = 0 IF ( NSEQ .LT. 6 ) THEN ISEED(1,NSEQ+1) = NSEQ+1 ISEED(2,NSEQ+1) = 0 ISEED(3,NSEQ+1) = 0 ENDIF ELSE WRITE(MONIOU,*) WRITE(MONIOU,*) 'TOO FEW RANDOM SEEDS: NSEQ =',NSEQ WRITE(MONIOU,*) 'AT MINIMUM 3 RANDOM SEEDS ARE NECESSARY' c WRITE(MONIOU,*) 'USE THE DEFAULT SEED(S)' WRITE(MONIOU,*) STOP ENDIF NSEQ = 9 ENDIF #endif #if __AUGERHIST__ || __AUGCERLONG__ C IN CASE OF AUGERHIST CALCULATIONS THE 3RD RANDOM SEQUENCE IS NEEDED C EVENTUALLY THE DEFAULT SEED IS USED IF ( NSEQ .LT. 3 ) NSEQ = 3 #endif #if __CERENKOV__ C CHERENKOV SELECTION DEMANDS ALWAYS EGS CALCULATION FEGS = .TRUE. C IN CASE OF CHERENKOV CALCULATIONS THE 3RD RANDOM SEQUENCE IS NEEDED C EVENTUALLY THE DEFAULT SEED IS USED IF ( NSEQ .LT. 3 ) NSEQ = 3 #if __IACT__ C IN CASE OF CHERENKOV TELESCOPES THE 4TH RANDOM SEQUENCE IS NEEDED C EVENTUALLY THE DEFAULT SEED IS USED IF ( NSEQ .LT. 4 ) NSEQ = 4 #endif C SET TMARGIN = .TRUE. TO START CLOCK AT BORDER OF ATMOSPHERE C THIS IS NEEDED FOR THE PHOTONS EMITTED FROM THE PRIMARY TMARGIN = .TRUE. #endif #if __AUGERHIT__ C IN CASE OF AUGERHIT THE 4TH RANDOM NUMBER SEQUENCE IS NEEDED C EVENTUALLY THE DEFAULT SEED IS USED IF ( NSEQ .LT. 4 ) THEN WRITE(MONIOU,*) 'TOO FEW RANDOM SEEDS: NSEQ =',NSEQ WRITE(MONIOU,*) 'AT MINIMUM 4 RANDOM SEEDS ARE NECESSARY ', * 'FOR THE AUGERHIT SCATTERING' NSEQ = 4 WRITE(MONIOU,*) 'NOW THE DEFAULT VALUE OF THE 4TH SEED IS ', * 'USED FOR AUGERHIT SCATTERING' ENDIF #endif #if __NUPRIM__ C IN CASE OF NEUTRINO PRIMARIES THE 5TH RANDOM SEQUENCE IS NEEDED C EVENTUALLY THE DEFAULT SEED IS USED IF ( NSEQ .LT. 5 ) THEN c NSEQ = 5 WRITE(MONIOU,*) WRITE(MONIOU,*) 'TOO FEW RANDOM SEEDS: NSEQ =',NSEQ WRITE(MONIOU,*) 'AT MINIMUM FIVE RANDOM SEEDS ARE NECESSARY' WRITE(MONIOU,*) 'FOR THE PRIMARY NEUTRINO INTERACTION' STOP ENDIF #endif #if __PARALLEL__ C IN CASE OF PARALLEL OPTION THE 6TH RANDOM SEQUENCE IS NEEDED C EVENTUALLY THE DEFAULT SEED IS USED IF ( NSEQ .LT. 6 ) NSEQ = 6 #endif DO I = 1, NSEQ IF ( ISEED(2,I) .GT. 1000 .OR. ISEED(3,I) .GT. 0 ) THEN IF ( .NOT. DEBUG .AND. .NOT. DEBDEL ) THEN WRITE(MONIOU,2811) I 2811 FORMAT(/,' #########################################',/, * ' ## IMPROPER INITIALIZATION OF RANDOM ##',/, * ' ## NUMBER GENERATOR SEQUENCE',I6,' ##',/, * ' ## IS EXTREMELY TIME CONSUMING ##',/, * ' ## PLEASE READ THE USERS GUIDE ##',/, * ' ## SEE KEYWORD: SEED ##',/, * ' #########################################',/) ELSE WRITE(MONIOU,2812) I 2812 FORMAT(' RANDOM NUMBER GENERATOR SEQUENCE ',I6, * ' IS NOW POSITIONED') ENDIF #if __CONEX__ C IF 8TH SEQUENCE IS NOT EXPLICITELY DEFINED USES 1ST SEQUENCE TO C SELECT RANDOMLY THE RANDOM NUMBERS USED FOR LOW ENERGY INTERACTIONS IN CONEX ELSEIF ( I .EQ. 8 .AND. ISEED(1,I) .EQ. 8 ) THEN CALL RMMARD( RD,1,1 ) ISEED(1,8) = INT( RD(1) * 1.D9 ) + 1 ISEED(2,8) = 0 ISEED(3,8) = 0 C USES 7TH SEQUENCE TO FIX THE SEED OF HIGH ENERGY INTERACTIONS IN CONEX C (INCLUDING THE FIRST INTERACTION) ELSEIF ( I .EQ. 9 ) THEN IF ( ISEED(1,I) .EQ. 9) THEN CALL RMMARD( RD,1,7 ) ISEED(1,9) = INT( RD(1) * 1.D9 ) + 1 ISEED(2,9) = 0 ISEED(3,9) = 0 ELSE C THE 9TH SEQUENCE SHOULD NOT BE FIXED EXPLICITLY BECAUSE IT WILL ARTIFICIALLY C FIX THE FIRST INTERACTION WRITE(MONIOU,*) 'START : PROGRAM STOPPED, DONT FIX 9TH', * ' SEED WITH CONEX' STOP ENDIF #endif ENDIF CALL RMMAQD( ISEED(1,I),I,'S' ) ENDDO KNOR = .TRUE. #if __MULTITHIN__ C SET RANDOM GENERATOR FOR THE THINNING MODES IN MULTITHIN DO J = 1, NMTHIN CALL RMMAQD( ISEED(1,10+J),10+J,'S' ) ENDDO #endif WRITE(MONIOU,158) (L,(ISEED(J,L),J=1,3),L=1,NSEQ) 158 FORMAT(' RANDOM NUMBER GENERATOR AT BEGIN OF RUN :',/, * (' SEQUENCE = ',I2,' SEED = ',I9,' CALLS = ',I9, * ' BILLIONS = ',I9)) IF ( DEBUG ) WRITE(MONIOU,*) C----------------------------------------------------------------------- C READ CROSS-SECTIONS AND PROBABILITIES FOR NUCLEUS-NUCLEUS COLLISIONS OPEN(UNIT=NUCNUC,FILE=DATDIR(1:INDEX(DATDIR,' ')-1)//"NUCNUCCS", * STATUS='OLD') READ(NUCNUC,500) SIGN30,SIGN45,SIGN60,SIGO30,SIGO45,SIGO60, * SIGA30,SIGA45,SIGA60 READ(NUCNUC,500) (PNOA30(I,1),I=1,1540),(PNOA45(I,1),I=1,1540), * (PNOA60(I,1),I=1,1540),(PNOA30(I,2),I=1,1540), * (PNOA45(I,2),I=1,1540),(PNOA60(I,2),I=1,1540), * (PNOA30(I,3),I=1,1540),(PNOA45(I,3),I=1,1540), * (PNOA60(I,3),I=1,1540) 500 FORMAT( 5E16.9 ) CLOSE( UNIT=NUCNUC ) C INELASTIC CROSS-SECTIONS FOR PROJECTICLE WITH MASS NUMBER IA DO IA = 1, 56 SIG30A(IA) = COMPOS(1)*SIGN30(IA) + COMPOS(2)*SIGO30(IA) * + COMPOS(3)*SIGA30(IA) SIG45A(IA) = COMPOS(1)*SIGN45(IA) + COMPOS(2)*SIGO45(IA) * + COMPOS(3)*SIGA45(IA) SIG60A(IA) = COMPOS(1)*SIGN60(IA) + COMPOS(2)*SIGO60(IA) * + COMPOS(3)*SIGA60(IA) IF (DEBUG) WRITE(MDEBUG,544) IA,SIG30A(IA),SIG45A(IA),SIG60A(IA) 544 FORMAT(' START : CROSS-SECTIONS A-AIR: A=',I2,1P,3E14.6) ENDDO C NOW OPEN THE VARIOUS FILES CALL FILOPN WRITE(MONIOU,503) 503 FORMAT(/,/,' ',10('='),' INTERACTION MODELS ',49('=')) #if __PARALLELIB__ IF ( INIHCALL .EQ. 0 ) THEN C INITIALIZATIONS DONE ONLY ONCE ON THE SAME COMPUTER INIHCALL = 1 #endif #if __DPMJET__ IF ( FDPMJT ) THEN WRITE(MONIOU,*) 'DPMJET TREATS HIGH ENERGY HADRONIC', * ' INTERACTIONS' CALL DPMJIN ELSE WRITE(MONIOU,1506) ENDIF IF ( FDPJSG ) THEN WRITE(MONIOU,*) WRITE(MONIOU,*) 'DPMJET CROSS-SECTIONS ARE TAKEN' ENDIF #elif __EPOS__ || __NEXUS__ C HIGH ENERGY HADRONIC INTERACTION MODEL IF ( FNEXUS ) THEN #if __EPOS__ WRITE(MONIOU,*) 'EPOS TREATS HIGH ENERGY HADRONIC INTERACTIONS' #elif __NEXUS__ WRITE(MONIOU,*) 'NEXUS TREATS HIGH ENERGY HADRONIC INTERACTIONS' #endif CALL NEXINI ELSE WRITE(MONIOU,1506) ENDIF IF ( FNEXSG ) THEN WRITE(MONIOU,*) #if __EPOS__ WRITE(MONIOU,*) 'EPOS CROSS-SECTIONS ARE TAKEN' #elif __NEXUS__ WRITE(MONIOU,*) 'NEXUS CROSS-SECTIONS ARE TAKEN' #endif CALL NEXSIGINI ENDIF #elif __QGSJET__ IF ( FQGS ) THEN WRITE(MONIOU,*) 'QGSJET TREATS HIGH ENERGY HADRONIC', * ' INTERACTIONS' IF ( .NOT. FQGSSG ) THEN CALL QGSINI( 1 ) ELSE WRITE(MONIOU,*) WRITE(MONIOU,*) 'QGSJET CROSS-SECTIONS ARE TAKEN' CALL QGSINI( 3 ) ENDIF ELSE WRITE(MONIOU,1506) IF ( FQGSSG ) THEN WRITE(MONIOU,*) WRITE(MONIOU,*) 'QGSJET CROSS-SECTIONS ARE TAKEN' CALL QGSINI( 2 ) ENDIF ENDIF #elif __SIBYLL__ IF ( FSIBYL ) THEN WRITE(MONIOU,*) 'SIBYLL TREATS HIGH ENERGY HADRONIC', * ' INTERACTIONS' IF ( .NOT. FSIBSG ) THEN CALL SIBINI( 1 ) ELSE WRITE(MONIOU,*) WRITE(MONIOU,*) 'SIBYLL CROSS-SECTIONS ARE TAKEN' CALL SIBINI( 3 ) ENDIF ELSE WRITE(MONIOU,1506) IF ( FSIBSG ) THEN WRITE(MONIOU,*) WRITE(MONIOU,*) 'SIBYLL CROSS-SECTIONS ARE TAKEN' CALL SIBINI( 2 ) ENDIF ENDIF #elif __VENUS__ C HIGH ENERGY HADRONIC INTERACTION MODEL IF ( FVENUS ) THEN WRITE(MONIOU,*) 'VENUS TREATS HIGH ENERGY HADRONIC INTERACTIONS' CALL VENINI ELSE WRITE(MONIOU,1506) ENDIF IF ( FVENSG ) THEN WRITE(MONIOU,*) WRITE(MONIOU,*) 'VENUS CROSS-SECTIONS ARE TAKEN' CALL VENSIGINI ENDIF #else WRITE(MONIOU,1506) #endif #if __PARALLELIB__ ELSE WRITE(MONIOU,1521) ENDIF 1521 FORMAT(' INITIALIZATION ALREADY DONE ON THIS COMPUTER') #endif 1506 FORMAT(' HDPM ROUTINES TREAT HIGH ENERGY HADRONIC INTERACTIONS') #if __DPMJET__ IF ( .NOT. FDPMJT ) THEN #elif __EPOS__ || __NEXUS__ IF ( .NOT. FNEXUS ) THEN #elif __QGSJET__ IF ( .NOT. FQGS ) THEN #elif __SIBYLL__ IF ( .NOT. FSIBYL ) THEN #elif __VENUS__ IF ( .NOT. FVENUS ) THEN #endif C INPUT FLAGS FOR HDPM OPTIONS WRITE(MONIOU,*) 'HDPM GENERATOR SPECIFICATIONS ARE:' IF ( NFLAIN .EQ. 0 ) THEN WRITE(MONIOU,*) ' RANDOM NUMBER OF INTERACTIONS IN AIR TARGET' IF ( NFLDIF .EQ. 0 ) THEN WRITE(MONIOU,*) ' NO DIFFRACTIVE SECOND INTERACTIONS' ELSE WRITE(MONIOU,*) ' DIFFRACTIVE SECOND INTERACTIONS' ENDIF ELSE WRITE(MONIOU,*) ' FIXED NUMBER OF INTERACTIONS IN AIR TARGET' ENDIF IF ( NFLPI0 .EQ. 0 ) THEN WRITE(MONIOU,*) ' RAPIDITY OF PI0 ACCORDING TO COLLIDER DATA' ELSE WRITE(MONIOU,*) ' RAPIDITY OF PI0 SAME AS THAT OF CHARGED' ENDIF IF ( NFLPIF .EQ. 0 ) THEN WRITE(MONIOU,*) ' NO FLUCTUATIONS OF NUMBER OF PI0' ELSE WRITE(MONIOU,*) ' FLUCTUATIONS OF NUMBER OF PI0 AS MEASURED', * ' AT THE COLLIDER' ENDIF IF ( NFLCHE .EQ. 0 ) THEN WRITE(MONIOU,*) ' CHARGE EXCHANGE INTERACTION POSSIBLE ' ELSE WRITE(MONIOU,*) ' NO CHARGE EXCHANGE INTERACTION POSSIBLE ' ENDIF #if __DPMJET__ || __EPOS__ || __NEXUS__ || __QGSJET__ || __SIBYLL__ || __VENUS__ ENDIF #endif IF ( NFRAGM .EQ. 0 ) THEN WRITE(MONIOU,*) ' TOTAL FRAGMENTION OF PRIMARY NUCLEUS IN ', * 'FIRST INTERACTION' ELSEIF ( NFRAGM .EQ. 1 ) THEN WRITE(MONIOU,*) ' NO FRAGMENTATION, NO EVAPORATION OF REMAINDER' #if __QGSJET__ ELSEIF ( NFRAGM .EQ. 2 ) THEN WRITE(MONIOU,*)'FRAGMENTATION WITH EVAPORATION (PT AFTER JACEE)' ELSEIF ( NFRAGM .EQ. 3 ) THEN WRITE(MONIOU,*) * 'FRAGMENTATION WITH EVAPORATION (PT AFTER GOLDHABER)' ELSE NFRAGM = 4 WRITE(MONIOU,*) 'FRAGMENTATION WITH EVAPORATION (PT=0)' ENDIF #elif __SIBYLL__ ELSE NFRAGM = 2 WRITE(MONIOU,*) 'FRAGMENTATION ACCORDING TO SIBYLL, PT=0' ENDIF #else ELSEIF ( NFRAGM .EQ. 2 ) THEN WRITE(MONIOU,1504) 1504 FORMAT(' NO FRAGMENTATION; EVAPORATION OF REMAINDER ', * ' (PT AFTER JACEE)') ELSEIF ( NFRAGM .EQ. 3 ) THEN WRITE(MONIOU,1505) 1505 FORMAT(' NO FRAGMENTATION; EVAPORATION OF REMAINDER ', * ' (PT AFTER GOLDHABER)') ELSEIF ( NFRAGM .EQ. 4 ) THEN WRITE(MONIOU,1507) 1507 FORMAT(' NO FRAGMENTATION; EVAPORATION OF REMAINDER ', * ' (WITH PT = 0.)') #if __DPMJET__ ELSEIF ( NFRAGM .EQ. 5 ) THEN WRITE(MONIOU,*) * 'FORMATION ZONE INTRANUCLEAR CASCADE NOT POSSIBLE' NFRAGM = 3 WRITE(MONIOU,1505) #endif ELSE NFRAGM = 4 WRITE(MONIOU,1507) ENDIF #endif WRITE(MONIOU,*) C LOW ENERGY HADRONIC INTERACTION MODEL #if __PARALLELIB__ IF ( INILCALL .EQ. 0 ) THEN C INITIALIZATIONS DONE ONLY ONCE ON THE SAME COMPUTER INILCALL = 1 #endif #if __FLUKA__ #if __INTTEST__ C DO NOT COMBINE FLUKA WITH INTERACTIONTEST WITHOUT AUTHORIZATION C SEE FLUKA LICENSE CONDITIONS WRITE(MONIOU,*) 'START : PROGRAM STOPPED, DONT USE', * ' INTERACTIONTEST WITH FLUKA' STOP #endif C FLUKA TREATS LOW ENERGY HADRONIC INTERACTIONS WRITE(MONIOU,*) 'FLUKA TREATS LOW ENERGY HADRONIC ', * 'INTERACTIONS' CALL FLUINI #elif __GHEISHAD__ WRITE(MONIOU,*) 'GHEISHA TREATS LOW ENERGY HADRONIC ', * 'INTERACTIONS' CALL CGHINI #elif __URQMD__ IF ( FURQMD ) THEN WRITE(MONIOU,*) 'URQMD TREATS LOW ENERGY HADRONIC ', * 'INTERACTIONS' CALL URQINI ELSE WRITE(MONIOU,*) 'NO LOW ENERGY HADRONIC INTERACTION', * ' MODEL AVAILABLE' STOP ENDIF #endif #if (__CHARM__ || __TAULEP__) && !__DPMJET__ C C INITIALIZE PYTHIA ROUTINES FOR CHARMED PARTICLE OR TAU LEPTON DECAYS CALL PYTINI #endif #if __PARALLELIB__ ENDIF #endif C WRITE HADRONIC STEERING FLAGS TO RUNHEADER RUNH(270) = REAL( NFLAIN ) RUNH(271) = REAL( NFLDIF ) RUNH(272) = REAL( NFLPI0 ) + 100. * NFLPIF RUNH(273) = REAL( NFLCHE ) + 100. * NFRAGM EVTH(65) = REAL( NFLAIN ) EVTH(66) = REAL( NFLDIF ) EVTH(67) = REAL( NFLPI0 ) EVTH(68) = REAL( NFLPIF ) EVTH(69) = REAL( NFLCHE ) EVTH(70) = REAL( NFRAGM ) HILOECM = SQRT( 2.D0*PAMA(14)*(PAMA(14) + HILOELB) ) IF ( DEBUG ) THEN WRITE(MDEBUG,1509) HILOELB,HILOECM 1509 FORMAT(' START: HIGH ENERGY INTERACTION MODEL USED ABOVE ', * F8.3,' GEV LAB ENERGY OR',/, * 50X,F8.3,' GEV CM ENERGY') ELSE WRITE(MONIOU,1510) HILOELB,HILOECM 1510 FORMAT(' HIGH ENERGY INTERACTION MODEL USED ABOVE ', * F8.3,' GEV LAB ENERGY OR',/, * 43X,F8.3,' GEV CM ENERGY') ENDIF #if __SIBYLL__ && __INTTEST__ IF ( FSIBYL .AND. HILOECM .LT. 10.D0 ) THEN WRITE(MONIOU,*) 'IMPROPER SELECTION OF HILOW FOR SIBYLL MODEL' WRITE(MONIOU,*) ' HILOW (CM) MUST BE GREATER THAN 10. GEV' WRITE(MONIOU,*) ' HILOW (LAB) MUST BE GREATER THAN 53. GEV' ENDIF #endif C----------------------------------------------------------------------- C INITIALIZE CONSTANTS FOR MUON/TAU MULTIPLE SCATTERING (MOLIERE) C SEE SUBROUT. GMOLI OF GEANT321 (CERN) IF ( FMOLI ) THEN TEMP1 = COMPOS(1) * 7.D0 * 8.D0 TEMP2 = COMPOS(2) * 8.D0 * 9.D0 TEMP3 = COMPOS(3) * 18.D0 * 19.D0 ZS = TEMP1 + TEMP2 + TEMP3 ZE = (-TB3)*(TEMP1*LOG(7.D0)+TEMP2*LOG(8.D0)+TEMP3*LOG(18.D0)) ZX = TEMP1 * LOG( 1.D0 + 3.34D0 * ( 7.D0/C(50))**2 ) * + TEMP2 * LOG( 1.D0 + 3.34D0 * ( 8.D0/C(50))**2 ) * + TEMP3 * LOG( 1.D0 + 3.34D0 * (18.D0/C(50))**2 ) C NOTE: CHC IS DEFINED DIFFERENT FROM GEANT WITHOUT DENSITY CHC = 0.39612D-3 * SQRT( ZS / AVERAW ) C NOTE: OMC IS DEFINED DIFFERENT FROM GEANT WITHOUT DENSITY OMC = 6702.33D0 * (ZS/AVERAW) * EXP( (ZE-ZX)/ZS ) EVTH(146) = 1. WRITE(MONIOU,*) 'MUON/TAU MULTIPLE SCATTERING AFTER MOLIERE' ELSE EVTH(146) = 0. WRITE(MONIOU,*) * 'MUON/TAU MULTIPLE SCATTERING IN GAUSS APPROXIMATION' ENDIF C----------------------------------------------------------------------- C INPUT STEERING FLAGS FOR ELECTROMAGNETIC PART WRITE(MONIOU,*) IF ( FNKG ) THEN #if __CURVED__ WRITE(MONIOU,2121) 2121 FORMAT(' ######################################################' * ,/, ' # SIMULATION WITH NKG NOT POSSIBLE IN CURVED VERSION #' * ,/, ' ######################################################' * ,/ ) FNKG = .FALSE. #else WRITE(MONIOU,*) 'ELECTROMAGNETIC COMPONENT SIMULATED WITH NKG' IF ( ULIMIT .GT. 1.D8 ) THEN WRITE(MONIOU,*)'#############################################' WRITE(MONIOU,*)'# W A R N I N G NKG IS WITHOUT LPM EFFECT #' WRITE(MONIOU,*)'#############################################' ENDIF WRITE(MONIOU,*) #endif #if __COMPACT__ IF ( COMOUT ) THEN WRITE(MONIOU,2122) 2122 FORMAT( * ' #######################################################' * ,/,' # SIMULATION WITH NKG NOT POSSIBLE IN COMPACT VERSION #' * ,/,' #######################################################' * ) STOP ENDIF #endif ENDIF C WRITE STEERING FLAGS FOR ELECTROMAGNETIC PART AS REAL TO HEADER IF ( FNKG ) THEN #if __PRESHOWER__ RUNH(20) = 2. EVTH(74) = 2. #else RUNH(20) = 1. EVTH(74) = 1. #endif ELSE RUNH(20) = 0. EVTH(74) = 0. ENDIF IF ( FEGS ) THEN #if __PRESHOWER__ RUNH(19) = 2. EVTH(73) = 2. #else RUNH(19) = 1. EVTH(73) = 1. #endif ELSE RUNH(19) = 0. EVTH(73) = 0. ENDIF EVTH(95) = STEPFC C PROGRAM CONFIGURATIONS FOR EVENT HEADER #if __FLUKA__ EVTH(75) = 3. #elif __GHEISHAD__ EVTH(75) = 1. #elif __URQMD__ EVTH(75) = 2. #else EVTH(75) = 0. #endif EVTH(76) = 0. EVTH(139) = 0. EVTH(140) = 0. EVTH(141) = 0. EVTH(142) = 0. EVTH(143) = 0. EVTH(144) = 0. EVTH(145) = 0. #if __DPMJET__ IF ( FDPMJT ) THEN EVTH(76) = 4. ELSE EVTH(76) = 0. ENDIF IF ( FDPMJT ) THEN c EVTH(143) = 1. ! for dpmjet-2.55 EVTH(143) = 2. ! for dpmjet-III ELSE EVTH(143) = 0. ENDIF IF ( FDPJSG ) THEN EVTH(144) = 1. ELSE EVTH(144) = 0. ENDIF #elif __EPOS__ IF ( FNEXUS ) THEN EVTH(76) = 6. ELSE EVTH(76) = 0. ENDIF IF ( FNEXSG ) THEN EVTH(145) = 4. ! FOR EPOS ELSE EVTH(145) = 0. ENDIF #elif __NEXUS__ IF ( FNEXUS ) THEN EVTH(76) = 5. ELSE EVTH(76) = 0. ENDIF IF ( FNEXSG ) THEN EVTH(145) = 3. ! FOR NEXUS 3 ELSE EVTH(145) = 0. ENDIF #elif __QGSJET__ IF ( FQGS ) THEN EVTH(76) = 3. ELSE EVTH(76) = 0. ENDIF IF ( FQGS ) THEN #if __QGSII__ EVTH(141) = 3. #else #if !__QGSJETOLD__ EVTH(141) = 2. #else EVTH(141) = 1. #endif #endif ELSE EVTH(141) = 0. ENDIF IF ( FQGSSG ) THEN #if __QGSII__ EVTH(142) = 3. #else #if !__QGSJETOLD__ EVTH(142) = 2. #else EVTH(142) = 1. #endif #endif ELSE EVTH(142) = 0. ENDIF #elif __SIBYLL__ IF ( FSIBYL ) THEN EVTH(76) = 2. EVTH(139) = 3. !sibyll 2.3 ELSE EVTH(76) = 0. EVTH(139) = 0. ENDIF IF ( FSIBSG ) THEN EVTH(140) = 2. ELSE EVTH(140) = 0. ENDIF #elif __VENUS__ IF ( FVENUS ) THEN EVTH(76) = 1. ELSE EVTH(76) = 0. ENDIF IF ( FVENSG ) THEN EVTH(145) = 1. ELSE EVTH(145) = 0. ENDIF #endif #if __VIEWCONE__ EVTH(153) = VUECON(1) EVTH(154) = VUECON(2) #else EVTH(153) = 0. EVTH(154) = 0. #endif EVTH(155) = HILOELB #if __CHARM__ EVTH(159) = 1. #else EVTH(159) = 0. #endif #if __CERENKOV__ C --------------------------------------------------------- C ELEMENT 77 OF EVENT HEADER HAS THE FOLLOWING CONTENTS IF C CONVERTED TO AN INTEGER WITH SUITABLE ROUNDING APPLIED: C BIT 1: CERENKOV OPTION COMPILED IN C 2: IACT OPTION COMPILED IN C 3: CEFFIC OPTION COMPILED IN C 4: ATMEXT OPTION COMPILED IN C 5: ATMEXT OPTION USED WITH REFRACTION ENABLED C 6: VOLUMEDET OPTION COMPILED IN C 7: CURVED OPTION COMPILED IN (SEE ALSO EVTH(79)) C 11-21: TABLE NUMBER FOR EXTERNAL ATMOSPHERE TABLE C (BUT LIMITED TO 1023 IF THE NUMBER IS LARGER) C -------------------------------------------------------- EVTH(77) = 1. #if __IACT__ EVTH(77) = EVTH(77) + 2. #endif #if __CEFFIC__ EVTH(77) = EVTH(77) + 4. #endif #if __ATMEXT__ EVTH(77) = EVTH(77) + 8. IF ( FREFRX ) EVTH(77) = EVTH(77) + 16. EVTH(77) = EVTH(77) + 1024. * MIN(IATMOX,1023) #endif #if __VOLUMEDET__ EVTH(77) = EVTH(77) + 32. #endif #if __CURVED__ EVTH(77) = EVTH(77) + 64. #endif C BIT 8 (VALUE 128) IS USED BY THE IACT INTERFACE. #if __SLANT__ EVTH(77) = EVTH(77) + 256. #endif #else EVTH(77) = 0. #endif #if __NEUTRINO__ EVTH(78) = 1. #else EVTH(78) = 0. #endif #if __CURVED__ EVTH(79) = 2. #else EVTH(79) = 0. #endif #if __UNIX__ EVTH(80) = 3. #elif __MAC__ EVTH(80) = 4. #endif C----------------------------------------------------------------------- C PHYSICAL CONSTANTS PI = 2.D0 * ACOS( 0.D0 ) PI2 = 4.D0 * ACOS( 0.D0 ) OB3 = 1.D0/3.D0 TB3 = 2.D0/3.D0 ENEPER = EXP( 1.D0 ) SQRT3 = SQRT( 3.D0 ) C(6) = ( PAMA(5) / PAMA(11) )**2 C(7) = ( PAMA(5) / PAMA(8) )**2 C(8) = ( PAMA(5)**2 + PAMA(2)**2 ) * 0.5D0 / PAMA(5) C RATIO ELECTRON MASS BY MUON MASS AND DERIVED QUANTITIES C(15) = 1.D0 + (PAMA(2) / PAMA(5))**2 C(16) = 2.D0 * PAMA(2) / PAMA(5) C RATIO ELECTRON MASS BY TAU LEPTON MASS AND DERIVED QUANTITIES C(17) = 1.D0 + (PAMA(2) / PAMA(131))**2 C(18) = 2.D0 * PAMA(2) / PAMA(131) #if __INTTEST__ C DISABLE ANGULAR CUTS FOR INTERACTION TESTS C(26) = PI C(28) = PI #endif C(27) = COS( C(26) ) #if __UPWARD__ C(28) = PI C(29) = MAX( COS( C(28) ), -1.D0 ) #else C(29) = COS( C(28) ) #endif #if __CURVED__ C CALCULATE CONSTANT FOR MAXIMAL HORIZONTAL RANGE WITHIN LOCAL SYSTEM C(4) = (C(2)-C(3)) / THICK( 0.D0 ) #if !__UPWARD__ C EXTEND ANGULAR CUT UP TO HORIZONTAL FOR CURVED VERSION C(29) = 1.D-15 #endif #endif C(45) = PAMA(8) * PAMA(14) * 2.D0 C(46) = PAMA(8)**2 + PAMA(14)**2 C(48) = (PAMA(8)**2 + PAMA(5)**2) / (2.D0*PAMA(8)*PAMA(5)) C(49) = SQRT( C(48)**2 - 1.D0 ) / C(48) CKA(13) = 2.D0 * PAMA(11) * PAMA(14) CKA(14) = PAMA(11)**2 + PAMA(14)**2 CKA(17) = SQRT( ( (PAMA(11)**2 + PAMA(5)**2) * / (2.D0*PAMA(11)) )**2 - PAMA(5)**2 ) CKA(28) = SQRT( 1.D0 + CKA(17)**2 / PAMA(5)**2 ) CKA(29) = SQRT( 1.D0 - 1.D0 / CKA(28)**2 ) C----------------------------------------------------------------------- C FILL CONSTANTS IN RUN HEADER DO L = 1, 50 RUNH(24+L) = C(L) RUNH(154+L) = 0. RUNH(204+L) = 0. ENDDO DO L = 1, 20 RUNH(74+L) = 0. ENDDO DO L = 1, 40 RUNH(94+L) = CKA(L) ENDDO DO L = 1, 5 RUNH(134+L) = CETA(L) ENDDO DO L = 1, 11 RUNH(139+L) = CSTRBA(L) ENDDO #if __CERENKOV__ RUNH(248) = XSCATT RUNH(249) = YSCATT #endif DO L = 1, 5 RUNH(249+L) = HLAY(L) RUNH(254+L) = AATM(L) RUNH(259+L) = BATM(L) RUNH(264+L) = CATM(L) ENDDO C----------------------------------------------------------------------- C INITIALIZE EGS4 PACKAGE AS IT IS USED FOR MUON/TAU NUCL. INTERACTION CALL EGSIN1 IF ( .NOT. (FNKG .OR. FEGS) ) WRITE(MONIOU,*) * 'ELECTROMAGNETIC COMPONENT IS NOT SIMULATED' IF ( FNKG .AND. .NOT.FEGS ) WRITE(MONIOU,*) * 'ELECTROMAGNETIC COMPONENT SIMULATED ONLY WITH NKG' IF ( FEGS ) THEN WRITE(MONIOU,*) 'ELECTROMAGNETIC COMPONENT SIMULATED WITH EGS4' WRITE(MONIOU,*) IF ( STEPFC .GT. 10.D0 .OR. STEPFC .LE. 0.D0 ) THEN WRITE(MONIOU,*) 'STEP LENGTH FACTOR FOR ELECTRON MULTIPLE ', * 'SCATTERING =',SNGL(STEPFC),' NOT CORRECT' WRITE(MONIOU,*) WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORD: STEPFC' STOP ENDIF IF ( STEPFC .NE. 1.D0 ) WRITE(MONIOU,*)'STEP LENGTH ', * 'FACTOR FOR ELECTRON MULTIPLE SCATTERING =',SNGL(STEPFC) #if __PARALLELIB__ IF ( INIECALL .EQ. 0 ) THEN C INITIALIZATIONS DONE ONLY ONCE ON THE SAME COMPUTER INIECALL = 1 #endif C READ EGSDAT FILE IN EGSIN2 CALL EGSIN2 #if __PARALLELIB__ ELSE WRITE(MONIOU,1521) ENDIF #endif ENDIF C----------------------------------------------------------------------- #if __INTTEST__ WRITE(MONIOU,*) C STOP IF INTTEST VERSION AND NO INTTST DATACARD WAS SUPPLIED IF ( ITTAR .EQ. 0 .OR. MCM .EQ. 0 ) THEN WRITE(MONIOU,*) 'NO VALID DATA CARD FOR INTERACT. TEST SUPPLIED' STOP ELSE C PROJECTILE IS PRIMARY PARTICLE ITPRO = PRMPAR(0) C ENERGY IS FIXED AS GIVEN BY ERANGE DATACARD C NO ENERGY SPECTRUM ALLOWED FOR TESTING ULIMIT = LLIMIT PSLOPE = 0.D0 WRITE(MONIOU,191) LLIMIT,ITPRO 191 FORMAT(' INTERACTION TESTING PARAMETERS ARE :',/, * ' ENERGY LAB : ',F14.1,' GEV',/, * ' PROJECTILE : ',I5) C RESET NO INTERACTION COUNTER NOINT = 0 NELAST = 0 C TARGET ACCORDING TO TEST SELECTION IF ( ITTAR .EQ. 1 ) THEN WRITE(MONIOU,192) ITTAR,'PROTON' 192 FORMAT(' TARGET : ',I5,' ',A9) ELSEIF ( ITTAR .EQ. 2 ) THEN WRITE(MONIOU,192) ITTAR,'NEUTRON' ELSEIF ( ITTAR .EQ. 9 ) THEN WRITE(MONIOU,192) ITTAR,'BERYLLIUM' ELSEIF ( ITTAR .EQ. 12 ) THEN WRITE(MONIOU,192) ITTAR,'CARBON' ELSEIF ( ITTAR .EQ. 14 ) THEN WRITE(MONIOU,192) ITTAR,'NITROGEN' ELSEIF ( ITTAR .EQ. 16 ) THEN WRITE(MONIOU,192) ITTAR,'OXYGEN' ELSEIF ( ITTAR .EQ. 40 ) THEN WRITE(MONIOU,192) ITTAR,'ARGON' ELSEIF ( ITTAR .EQ. 99 ) THEN WRITE(MONIOU,192) ITTAR,'AIR' ELSE WRITE(MONIOU,*) ' ILLEGAL TARGET SELECTION :',ITTAR WRITE(MONIOU,*) ' SET TARGET TO AIR (ITTAR = 99)' ITTAR = 99 WRITE(MONIOU,192) ITTAR,'AIR' ENDIF #if __FLUKA__ || __GHEISHAD__ C FOR GHEISHA PART NO PRIMARY NUCLEI ARE ALLOWED IF ( ULIMIT .LT. HILOELB ) THEN IF ( ITPRO .GE. 200 ) THEN WRITE(MONIOU,195) ITPRO 195 FORMAT(' ILLEGAL PROJECTILE SELECTION :',I5,/, * ' AT LOW ENERGIES ONLY NUCLEONS, PIONS AND KAONS ', * ' ARE AVAILABLE') STOP ENDIF ENDIF #endif C CENTER OF MASS CALCULATION IF ( MCM .EQ. 1 ) THEN WRITE(MONIOU,193) MCM,'NUCLEON-NUCLEON SYSTEM' 193 FORMAT(' MCM : ',I5,' CM = ',A22) ELSEIF ( MCM .EQ. 2 ) THEN WRITE(MONIOU,193) MCM,'LABORATORY SYSTEM' ELSEIF ( MCM .EQ. 3 ) THEN WRITE(MONIOU,193) MCM,'ALL SECONDARIES SYSTEM' ELSE WRITE(MONIOU,*) ' ILLEGAL MCM SELECTION :',MCM MCM = 1 WRITE(MONIOU,193) MCM,'NUCLEON-NUCLEON SYSTEM' ENDIF ENDIF C DIFFRACTION SWITCH IF ( NDIF .EQ. 1 ) THEN WRITE(MONIOU,*) 'NONDIFFRACTIVE INTERACTIONS ONLY' ELSEIF ( NDIF .EQ. 2 ) THEN WRITE(MONIOU,*) 'DIFFRACTIVE INTERACTIONS ONLY' ELSE WRITE(MONIOU,*) * 'DIFFRACTIVE AND NONDIFFRACTIVE INTERACTIONS MIXED' ENDIF C TTRIGGER SWITCH IF ( NTRIG .EQ. 0 ) THEN WRITE(MONIOU,*) 'NO TRIGGER CONDITION, ALL EVENTS ACCEPTED' ELSE IF ( ITTAR .GT. 2 ) THEN WRITE(MONIOU,*) 'ILLEGAL COMBINATION OF TRIGGER AND TARGET ' STOP ENDIF IF ( NDIF .NE. 0 ) THEN WRITE(MONIOU,*) * 'ILLEGAL COMBINATION OF TRIGGER AND DIFFRACTION' STOP ENDIF IF ( NTRIG .EQ. 1 ) THEN WRITE(MONIOU,*) * 'ONLY EVENTS WITH UA5 TRIGGER CONDITIONS ACCEPTED' ELSEIF ( NTRIG .EQ. 2 ) THEN WRITE(MONIOU,*) * 'ONLY EVENTS WITH CDF TRIGGER CONDITIONS ACCEPTED' ELSEIF ( NTRIG .EQ. 3 ) THEN WRITE(MONIOU,*) * 'ONLY EVENTS WITH P238 (HARR ET AL.) TRIGGER CONDITIONS', * ' ACCEPTED' ELSE WRITE(MONIOU,*)' ILLEGAL TRIGGER CONDITION NTRIG=',NTRIG STOP ENDIF ENDIF C FIXE ZENITH AND AZIMUTH ANGLE TO 0 THETPR(1) = 0.D0 PHIPR(1) = 0.D0 THETPR(2) = 0.D0 PHIPR(2) = 0.D0 WRITE(MONIOU,194) 194 FORMAT(' THETA AND PHI ANGLES FIXED TO 0.D0') C BOOK HISTOGRAMS CALL HISINI #endif #if __ANAHIST__ || __AUGERHIST__ || __MUONHIST__ C INITIALIZE AUGER/ANAHIST/MUONHIST HISTO''S CALL AUGERHISTINI #endif CALL STAEND RETURN END #if __STACKIN__ *-- Author : D. HECK IK FZK KARLSRUHE 07/01/2004 C======================================================================= SUBROUTINE STCKIN C----------------------------------------------------------------------- C ST(A)CK IN(PUT) C C THIS SUBROUTINE READS IN THE LIST OF SECONDARIES OF AN EXOTIC C INTERACTION AND STORES THE SECONDARY PARTICLES ONTO STACK TO C TREAT THEM AS ONE SINGLE SHOWER. C THIS SUBROUTINE IS CALLED FROM AAMAIN. C----------------------------------------------------------------------- IMPLICIT NONE #define __BUFFSINC__ #define __ELASTYINC__ #define __GENERINC__ #define __OBSPARINC__ #define __PAMINC__ #define __PARPARINC__ #define __PRIMSPINC__ #define __RUNPARINC__ #define __THNVARINC__ #if __CURVED__ #define __TIMLIMINC__ #endif #include "corsika.h" DOUBLE PRECISION AUXIL,COSTHJ,CPHIJ,EN,ENERGY,ESUM,HEIGH, * * RNPHI, * PX,PY,PZ,SPHIJ INTEGER I,IE,IS,NN,NNN,NTYP,NSEC #if __EHISTORY__ INTEGER IDPRIM,IK #endif #if __CURVED__ DOUBLE PRECISION DIST,TEA,XXX,YYY,DIAG #endif CHARACTER LINE*132,TAB*1 SAVE EXTERNAL HEIGH C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'STCKIN:' C STORE PARAMETERS COMMON TO ALL PARTICLES ALEVEL = FIXHEI PRMPAR(5) = FIXHEI SECPAR(5) = ALEVEL SECPAR(6) = 0.D0 GEN = 1.D0 SECPAR(9) = GEN SECPAR(10) = ALEVEL C POLARIZATION NOT USED SECPAR(11) = 0.D0 ! POLARIZATION SECPAR(12) = 0.D0 ! POLARIZATION C NO THINNING OF SECONDARY PARTICLES SECPAR(13) = 1.D0 #if __PARALLEL__ C SET ECUT FLAG TO BELOW ECUT (OFF) SECPAR(39) = -1.D0 #endif #if __CURVED__ C CALCULATE GLOBAL PARAMETERS VALID FOR ALL SECONDARIES. C FOR FURTHER COMMENTS SEE SUBR. COOINC. C ALL PRESHOWER PARTICLES START AT INTERACTION POINT. #if __UPWARD__ IF ( FIMPCT ) THEN C DISTANCE DIAG BETWEEN DETECTOR POSITION X=Y=0, Z = HIMPCT AND C STARTING POINT DIAG = SQRT( (C(1)+FIXHEI)**2 - (C(1)+HIMPCT)**2 ) ELSE IF ( PRMPAR(15) .LT. 0.D0 ) THEN DIAG = -SQRT( (C(1)+FIXHEI)**2 - (C(1)+OBSLEV(1))**2 * * (1.D0-PRMPAR(15))*(1.D0+PRMPAR(15)) ) * - (C(1)+OBSLEV(1)) * PRMPAR(15) ELSE DIAG = SQRT( (C(1)+FIXHEI)**2 - (C(1)+OBSLEV(1))**2 * * (1.D0-PRMPAR(15))*(1.D0+PRMPAR(15)) ) * - (C(1)+OBSLEV(1)) * PRMPAR(15) ENDIF ENDIF #else DIAG = SQRT( (C(1)+FIXHEI)**2 - (C(1)+OBSLEV(1))**2 * * (1.D0-PRMPAR(15))*(1.D0+PRMPAR(15)) ) * - (C(1)+OBSLEV(1)) * PRMPAR(15) #endif C SET TIME LIMIT TO AVOID UNNECESSARY COMPUTING TIME WITH PARTICLES C WELL ABOVE THE TIME LIMIT. THE TIME LIMIT IS GIVEN BY THE C PROPAGATION TIME ALONG DIAD WITH SPEED OF LIGHT AND SOME ADDITIONAL C DISTANCE DOWNSTREAM OF THE DETECTOR DLIMIT (CM). C FOR SAFETY ADD ADDITIONAL 20 MICROSEC. (ALL TIME UNITS IN SEC) IF ( DSTLIM .GT. 0.D0 ) THEN TIMLIM = ( DIAG + DSTLIM ) / C(25) + 2.D-5 ELSE C DEFAULT LIMIT IS 20 KM TIMLIM = ( DIAG + 20.D5 ) / C(25) + 2.D-5 ENDIF IF ( DEBUG .OR. LTMLMPR ) WRITE(MDEBUG,*) 'STCKIN: DIAG=',DIAG, * 'DSTLIM=',DSTLIM,' TIMLIM=',TIMLIM #if __UPWARD__ IF ( FIMPCT ) THEN C CALCULATE APPARENT HEIGHT (HAPP) PRMPAR(14) = HIMPCT ELSE #endif C CALCULATE APPARENT HEIGHT (HAPP) PRMPAR(14) = OBSLEV(1) + DIAG * PRMPAR(15) #if __UPWARD__ ENDIF #endif C CALCULATE COSTEA PRMPAR(16) = (C(1)+PRMPAR(14)) / (C(1)+FIXHEI) IF ( DEBUG ) WRITE(MDEBUG,*) 'STCKIN: HAPP,COSTEA,DIAG =', * SNGL(PRMPAR(14)),SNGL(PRMPAR(16)),SNGL(DIAG) PRMPAR(16) = MIN( 1.D0, PRMPAR(16) ) PRMPAR(2) = (DIAG + (C(1)+OBSLEV(1))*PRMPAR(15))/(C(1)+FIXHEI) TEA = ACOS( PRMPAR(16) ) DIST = C(1) * TEA XXX = -DIST * COS( PHIP ) YYY = -DIST * SIN( PHIP ) IF ( DEBUG ) WRITE(MDEBUG,*) 'STCKIN: X,Y,COSTHE,DIST =', * SNGL(XXX),SNGL(YYY),SNGL(PRMPAR(2)),SNGL(DIST) SECPAR(7) = XXX SECPAR(8) = YYY SECPAR(14) = PRMPAR(14) SECPAR(15) = PRMPAR(15) SECPAR(16) = PRMPAR(16) #else SECPAR(7) = 0.D0 SECPAR(8) = 0.D0 #endif C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C READ FILE WITH SECONDARY PARTICLES AND TREAT IT C SET TABULATOR TAB = CHAR(9) C ERASE 'LINE' BY FILLING WITH BLANKS LINE = ' ' C GET FIRST INPUT LINE (FORMAT FREE) AND PRINT IT READ(LSTCK,500,END=1000) LINE 500 FORMAT(A) DO IE = LEN(LINE), 1, -1 IF ( LINE(IE:IE) .NE. ' ' ) GOTO 11 ENDDO 11 CONTINUE C CHECK FOR HORIZONTAL TABS AND ELIMINATE THEM DO I = 1, IE IF ( LINE(I:I) .EQ. TAB ) THEN LINE(I:I) = ' ' ENDIF ENDDO C ECHO WRITE THE FIRST LINE IF ( DEBUG ) THEN WRITE(MDEBUG,*) 'STCKIN: LIST OF PARTICLES FOR STACK INPUT' WRITE(MDEBUG,501) LINE(1:IE) 501 FORMAT(' STCKIN: ',A) ELSE WRITE(MONIOU,*) ' LIST OF PARTICLES FOR STACK INPUT' WRITE(MONIOU,502) LINE(1:IE) *502 FORMAT(' ',A) 502 FORMAT(A) ENDIF C FIRST LINE CONTAINS NUMBER OF SECONDARIES NSEC AND ENERGY IS = 0 CALL DTCINT( LINE,IS,NSEC,' ',1 ) CALL DTCDBL( LINE,IS,ENERGY,' ',2 ) #if __EHISTORY__ CALL DTCINT( LINE,IS,IDPRIM,' ',3 ) WRITE(MONIOU,*) 'PRIMARY=', IDPRIM,' WITH ENERGY=',ENERGY CURPAR(17) = IDPRIM IF ( IDPRIM .LE. 0 ) IDPRIM = 1 IF ( PAMA(IDPRIM) .NE. 0.D0 ) THEN CURPAR(18) = ENERGY / PAMA(IDPRIM) ELSE C PARTICLES WITH ZERO MASS IF ( IDPRIM .EQ. 1 .OR. #if __CHARM__ || __TAULEP__ * IDPRIM .EQ. 133 .OR. IDPRIM .EQ. 134 .OR. #endif * IDPRIM .GE. 66 .AND. IDPRIM .LE. 69 ) THEN C FOR GAMMA AND NEUTRINOS STORE ENERGY INTO SECPAR(1) CURPAR(18) = ENERGY ELSE WRITE(MONIOU,*) 'PRIMARY',IDPRIM,' WITH ZERO MASS NOT DEFINED' CURPAR(18) = ENERGY ENDIF ENDIF C COPY PARTICLE INFORMATION, LATER TO BECOME GRANDMOTHER PARTICLE SECPAR(28) = CURPAR(17) ! PARICLE ID SECPAR(29) = CURPAR(18) ! GAMMA RSP. ENERGY SECPAR(30) = PRMPAR(2) ! COSTHE SECPAR(31) = PRMPAR(3) SECPAR(32) = PRMPAR(4) SECPAR(33) = ALEVEL ! HEIGHT FIRST INTERACTION SECPAR(34) = 0.D0 ! TIME SINCE FIRST INTEACTION C STORE GENERATION COUNTER OF MOTHER SECPAR(35) = GEN C STORE MASS PENETRATION BEFORE INTERACTION SECPAR(36) = THICK0 / PRMPAR(2) #if __THIN__ SECPAR(37) = SECPAR(13) ! WEIGHT #endif #endif C ENERGY OF PRIMARY BEFORE INTERACTION PRMPAR(1) = ENERGY ESUM = 0.D0 C SET DUMMY VALUES FOR PRINTING AND CORRECT PROGRAM RUNNING SIG1I = 0.D0 ELAST = 0.D0 TARG1I = 0.D0 ISEED1I(1) = 0 ISEED1I(2) = 0 ISEED1I(3) = 0 PSLOPE = 0.D0 LLIMIT = ENERGY ULIMIT = ENERGY EVTH(58) = PSLOPE EVTH(59) = LLIMIT EVTH(60) = ULIMIT C SET DUMMY PRIMARY PARTICLE WITHOUT MASS (IMPORTANT FOR CORRECT C SETTING OF THINNING PARAMETERS) PRMPAR(0) = 4.D0 NNN = 0 #if __PARALLEL__ C IN CASE OF PARALLEL, READ LIST OF PARTICLES ONLY FOR THE FIRST CALL IF ( FPRIM ) THEN #endif IF (DEBUG ) THEN WRITE(MDEBUG,508) 508 FORMAT(' STCKIN: NR ITYP ENERGY PZ ', * ' PX PY') c ELSE c WRITE(MONIOU,509) c 509 FORMAT(' NR ITYP ENERGY PZ ', c * ' PX PY') ENDIF C READ SECONDARY PARTICLE PARAMETERS AND STORE THEM ON STACK C ENTRY POINT FOR PARTICLE LOOP 22 CONTINUE ctp READ(LSTCK,510,END=1000) NN,NTYP,EN,PZ,PX,PY READ(LSTCK,*,END=1000) NN,NTYP,EN,PZ,PX,PY C FREE FORMAT TO READ STACKIN FILE (EVENTUALLY TO BE CHANGED) C - - - - - - - - - - - - - - c 510 FORMAT(2I5,4(1X,E15.7)) C - - - - - - - - - - - - - - IF (DEBUG ) THEN WRITE(MDEBUG,511) NN,NTYP,EN,PZ,PX,PY 511 FORMAT(' STCKIN:',2I5,1P,4(1X,E15.7)) c ELSE c WRITE(MONIOU,512) NN,NTYP,EN,PZ,PX,PY c 512 FORMAT(' ',2I5,1P,4(1X,E15.7)) ENDIF NNN = NNN + 1 #if __CONEX__ C PARTICLE LIST READ IN CONEX ESUM = ESUM + EN #else C CALCULATE THE GAMMA FACTORS IF ( PAMA(NTYP) .NE. 0.D0 ) THEN C FOR PARTICLES WITH MASS STORE GAMMA FACTOR INTO SECPAR(1) SECPAR(1) = EN / PAMA(NTYP) IF ( SECPAR(1) .LE. 1.D0 ) THEN WRITE(MONIOU,*) 'STCKIN: PARTICLE',NN,' PT REJECT' GOTO 333 ENDIF ELSE C PARTICLES WITH ZERO MASS IF ( NTYP .EQ. 1 .OR. #if __CHARM__ || __TAULEP__ * NTYP .EQ. 133 .OR. NTYP .EQ. 134 .OR. #endif * NTYP .GE. 66 .AND. NTYP .LE. 69 ) THEN C FOR GAMMA AND NEUTRINOS STORE ENERGY INTO SECPAR(1) SECPAR(1) = EN ELSE C PARTICLES WITH ZERO MASS ARE INVALID (EXCEPT GAMMA OR NEUTRINO) WRITE(MONIOU,*) 'STCKIN: ILLEGAL PARTICLE IN STCKIN' WRITE(MONIOU,*) 'STCKIN: NTYP =', NTYP WRITE(MONIOU,*) 'STCKIN: PROGRAM ABORTED' STOP ENDIF ENDIF ESUM = ESUM + EN AUXIL = PX**2 + PY**2 + PZ**2 C SKIP PARTICLES WITH WRONG MOMENTA IF ( AUXIL .LE. 0.D0 ) GOTO 333 C CALCULATE THE EMISSION ANGLES AUXIL = SQRT( AUXIL ) COSTHJ = PZ / AUXIL COSTHJ = MAX( -1.D0, MIN( 1.D0, COSTHJ ) ) CPHIJ = PX / AUXIL SPHIJ = PY / AUXIL #if __CURVED__ C COSINE OF ZENITH ANGLE IN LOCAL FRAME c CALL ADDANG4( PRMPAR(15),PRMPAR(3),PRMPAR(4), COSTHJ,CPHIJ,SPHIJ, c * SECPAR(15),SECPAR(3),SECPAR(4) ) CALL ADDANG4( PRMPAR(2),PRMPAR(3),PRMPAR(4), COSTHJ,CPHIJ,SPHIJ, * SECPAR(2),SECPAR(3),SECPAR(4) ) IF ( DEBUG ) WRITE(MDEBUG,*) 'STCKIN: SECPAR(15) =', * SNGL(SECPAR(15)) C COSINE OF ZENITH ANGLE IN OBSERVER FRAME c SECPAR(2) = (DIAG + (C(1)+OBSLEV(1))*SECPAR(15))/(C(1)+FIXHEI) #else CALL ADDANG4( PRMPAR(2),PRMPAR(3),PRMPAR(4), COSTHJ,CPHIJ,SPHIJ, * SECPAR(2),SECPAR(3),SECPAR(4) ) #endif IF ( DEBUG ) WRITE(MDEBUG,*) 'STCKIN: SECPAR(2) =', * SNGL(SECPAR(2)) C STORE ONLY PARTICLES ABOVE ANGULAR CUT TO THE CORSIKA STACK #if __UPWARD__ IF ( SECPAR(2) .GE. -1.D0 ) THEN #else IF ( SECPAR(2) .GT. C(29) ) THEN #endif SECPAR(0) = NTYP #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER PARTICLE DO IK = 0, 8 SECPAR(17+IK) = SECPAR(IK) ENDDO #if __THIN__ SECPAR(26) = SECPAR(13) #endif #endif CALL TSTACK ELSE WRITE(MONIOU,*) 'STCKIN: PARTICLE BELOW ANGLE CUT' ENDIF #endif 333 CONTINUE C LOOP BACK IF NOT YET ALL SECONDARIES IF ( NNN .LT. NSEC ) GOTO 22 WRITE(MONIOU,*) 'STCKIN: ENERGY SUM = ',SNGL(ESUM), * ' PRIMARY ENERGY = ',SNGL(ENERGY) #if __PARALLEL__ ENDIF #endif C TO SIMULATE MORE THAN ONE SHOWER WITH IDENTICAL INPUT REWIND C LSTCK TO READ THE INPUT FOR THE FOLLOWING SHOWERS REWIND( LSTCK ) RETURN 1000 CONTINUE WRITE(MONIOU,*)'STCKIN: END OF FILE FOR STACK INPUT' RETURN END #endif *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE STRDEC C----------------------------------------------------------------------- C STR(ANGE BARYON) DEC(AY) C C ROUTINE TREATES DECAY OF STRANGE BARYONS (LAMBDA, SIGMA, XI, OMEGA) C DECAY WITH FULL KINEMATIC, ENERGY AND MOMENTA CONSERVED. C THIS SUBROUTINE IS CALLED FROM NUCINT. C----------------------------------------------------------------------- IMPLICIT NONE #define __IRETINC__ #define __PARPARINC__ #define __PARPAEINC__ #define __RANDPAINC__ #define __RUNPARINC__ #define __STRBARINC__ #include "corsika.h" INTEGER I SAVE C----------------------------------------------------------------------- #if __THIN__ IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=0,9),WEIGHT 444 FORMAT(' STRDEC: CURPAR=',1P,11E11.3) #else IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=0,9) 444 FORMAT(' STRDEC: CURPAR=',1P,10E11.3) #endif IF ( ITYPE .EQ. 18 ) THEN CALL RMMARD( RD,1,1 ) IF ( RD(1) .LT. CSTRBA(5) ) THEN C DECAY LAMBDA ---> P + PI(-) CALL DECAY1( ITYPE,14,9 ) ELSE C DECAY LAMBDA ---> N + PI(0) CALL DECAY1( ITYPE,13,7 ) ENDIF ELSEIF ( ITYPE .EQ. 19 ) THEN CALL RMMARD( RD,1,1 ) IF ( RD(1) .LT. CSTRBA(6) ) THEN C DECAY SIGMA(+) ---> P + PI(0) CALL DECAY1( ITYPE,14,7 ) ELSE C DECAY SIGMA(+) ---> N + PI(+) CALL DECAY1( ITYPE,13,8 ) ENDIF ELSEIF ( ITYPE .EQ. 20 .OR. ITYPE .EQ. 28 ) THEN C DECAY SIGMA(0) ---> LAMBDA + GAMMA C DECAY ANTI-SIGMA(0) ---> ANTI-LAMBDA + GAMMA CALL DECAY1( ITYPE,ITYPE-2,1 ) ELSEIF ( ITYPE .EQ. 21 ) THEN C DECAY SIGMA(-) ---> N + PI(-) CALL DECAY1( ITYPE,13,9 ) ELSEIF ( ITYPE .EQ. 22 .OR. ITYPE .EQ. 30 ) THEN C DECAY XI(0) ---> LAMBDA + PI(0) C DECAY ANTI-XI(0) ---> ANTI-LAMBDA + PI(0) CALL DECAY1( ITYPE,ITYPE-4,7 ) ELSEIF ( ITYPE .EQ. 23 ) THEN C DECAY XI(-) ---> LAMBDA + PI(-) CALL DECAY1( ITYPE,18,9 ) ELSEIF ( ITYPE .EQ. 24 .OR. ITYPE .EQ. 32 ) THEN CALL RMMARD( RD,1,1 ) IF ( RD(1) .LT. CSTRBA(10) ) THEN C DECAY OMEGA(-) ---> LAMBDA + K(-) C DECAY ANTI-OMEGA(+) ---> ANTI-LAMBDA + K(+) CALL DECAY1( ITYPE,ITYPE-6,15-ITYPE/8 ) ELSEIF ( RD(1) .LT. CSTRBA(11) ) THEN C DECAY OMEGA(-) ---> XI(0) + PI(-) C DECAY ANTI-OMEGA(+) ---> ANTI-XI(0) + PI(+) CALL DECAY1( ITYPE,ITYPE-2,12-ITYPE/8 ) ELSE C DECAY OMEGA(-) ---> XI(-) + PI(0) C DECAY ANTI-OMEGA(+) ---> ANTI-XI(+) + PI(0) CALL DECAY1( ITYPE,ITYPE-1,7 ) ENDIF ELSEIF ( ITYPE .EQ. 26 ) THEN CALL RMMARD( RD,1,1 ) IF ( RD(1) .LT. CSTRBA(5) ) THEN C DECAY ANTI-LAMBDA ---> ANTI-P + PI(+) CALL DECAY1( ITYPE,15,8 ) ELSE C DECAY ANTI-LAMBDA ---> ANTI-N + PI(0) CALL DECAY1( ITYPE,25,7 ) ENDIF ELSEIF ( ITYPE .EQ. 27 ) THEN CALL RMMARD( RD,1,1 ) IF ( RD(1) .LT. CSTRBA(6) ) THEN C DECAY ANTI-SIGMA(-) ---> ANTI-P + PI(0) CALL DECAY1( ITYPE,15,7 ) ELSE C DECAY ANTI-SIGMA(-) ---> ANTI-N + PI(-) CALL DECAY1( ITYPE,25,9 ) ENDIF ELSEIF ( ITYPE .EQ. 29 ) THEN C DECAY ANTI-SIGMA(+) ---> ANTI-N + PI(+) CALL DECAY1( ITYPE,25,8 ) ELSEIF ( ITYPE .EQ. 31 ) THEN C DECAY ANTI-XI(+) ---> ANTI-LAMBDA + PI(+) CALL DECAY1( ITYPE,26,8 ) ELSE #if __THIN__ WRITE(MONIOU,444) (CURPAR(I),I=0,9),WEIGHT #else WRITE(MONIOU,444) (CURPAR(I),I=0,9) #endif WRITE(MONIOU,*) 'STRDEC: UNFORESEEN PARTICLE CODE =',ITYPE ENDIF IRET1 = 1 RETURN END #if __AUGERHIT__ *-- Author : Darko Veberic IKP KIT KARLSRUHE 24/03/2015 C======================================================================= LOGICAL FUNCTION TANKSHADOW( x,y,u,v,w ) C----------------------------------------------------------------------- c returns true when particle inside of a cylindrical tank shadow c ARGUMENTS: c x = particle position relative to the tank [m] c y = particle position relative to the tank [m] c u = particle directional cosine in x-direction c v = particle directional cosine in y-direction c w = particle directional cosine in z-direction w>0 c----------------------------------------------------------------------- implicit none double precision x, y ! particle position relative to the tank double precision u, v, w ! particle directional cosines, w > 0 double precision n2, px, py, how, dx, dy, dn, r2, xb, yb double precision r, h parameter (r = 1.8) ! tank radius [m] parameter (h = 1.2) ! tank height [m] c----------------------------------------------------------------------- TANKSHADOW = .false. c bounding square cut how = h / w dx = - how * u if ( dx .ge. 0 ) then if ( x .lt. -r .or. x .gt. r + dx ) return else if ( x .lt. -r + dx .or. x .gt. r ) return endif dy = - how * v if ( dy .ge. 0 ) then if ( y .lt. -r .or. y .gt. r + dy ) return else if ( y .lt. -r + dy .or. y .gt. r ) return endif c diagonal sides cut py = x*v - y*u r2 = r * r n2 = u**2 + v**2 if ( py**2 .gt. r2*n2 ) return c round corners cut px = - x*u - y*v if ( px .lt. 0 .and. x**2 + y**2 .gt. r2 ) return dn = how * n2 if ( px .gt. dn ) then xb = x - dx yb = y - dy if ( xb**2 + yb**2 .gt. r2 ) return endif TANKSHADOW = .true. return end #endif #if __SLANT__ *-- Author : D. HECK IK FZK KARLSRUHE 20/10/2003 C======================================================================= DOUBLE PRECISION FUNCTION THCKSI( ARGU ) C----------------------------------------------------------------------- C TH(I)CK(NESS OF) S(LANT ATMOSPHERE) I(NTERPOLATED) C C CALCULATES SLANT THICKNESS (G/CM**2) FOR SHOWER PATH NORMAL TO THE C SLANT DEPTH PLANES. THE SHOWER PATH STARTS AT TOP OF ATMOSPHERE. C THIS FUNCTION IS CALLED FROM MUNUCL, UPDATC, UPDATE, EGS4, ELECTR, C PHOTON, CERLDE. C ARGUMENT: C ARGU = SLANT PATH (CM) C----------------------------------------------------------------------- IMPLICIT NONE #define __ATMOSLINC__ #if __UPWARD__ #define __LONGIINC__ #endif #define __RUNPARINC__ #include "corsika.h" DOUBLE PRECISION ARG,ARGU,SL INTEGER I1,I2,II SAVE C----------------------------------------------------------------------- C SET FIRST AND LAST BIN FOR SEARCH I1 = IENDT I2 = MAXSLANT IF ( ARGU .LT. 0.D0 ) THEN C PARTICLE OUT OF RANGE THCKSI = 1.5D0 * TSLANT(I2) RETURN ELSE ARG = ARGU ENDIF #if __UPWARD__ C PROTECTION AGAINST BACKWARD GOING PARTICLES EXCEEDING THE AXIS RANGE IF ( CTH .LT. 0.D0 ) THEN IF ( ARG .LE. PATH1(IENDT) ) THEN THCKSI = TSLANT(IENDT) GOTO 2 ENDIF C FIND PATH BIN BY CONTINUOUSLY DIVIDING PATH INTERVAL 3 CONTINUE II = (I1+I2) / 2 IF ( PATH1(II) .GT. ARG ) THEN I2 = II ELSE I1 = II ENDIF IF ( I2-I1 .GT. 1 ) GOTO 3 ELSE #endif IF ( ARG .GE. PATH1(IENDT) ) THEN THCKSI = TSLANT(IENDT) GOTO 2 ENDIF C FIND PATH BIN BY CONTINUOUSLY DIVIDING PATH INTERVAL 1 CONTINUE II = (I1+I2) / 2 IF ( PATH1(II) .LT. ARG ) THEN I2 = II ELSE I1 = II ENDIF IF ( I2-I1 .GT. 1 ) GOTO 1 #if __UPWARD__ ENDIF #endif C BIN FOUND, INTERPOLATION OF THICKNESS SL = (TSLANT(I1)-TSLANT(I2)) / (PATH1(I1)-PATH1(I2)) THCKSI = TSLANT(I2) + SL * (ARG-PATH1(I2)) 2 CONTINUE CC IF ( DEBUG ) WRITE(MDEBUG,*) 'THCKSI: I1,I2,ARG,SL,THCKSI=', CC * I1,I2,SNGL(ARG),SNGL(SL),SNGL(THCKSI) RETURN END #endif *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= DOUBLE PRECISION FUNCTION THICK( ARG ) C----------------------------------------------------------------------- C THICK(NESS OF ATMOSPHERE) C C CALCULATES THICKNESS (G/CM**2) OF ATMOSPHERE DEPENDING ON HEIGHT (CM) C THIS FUNCTION IS CALLED FROM AAMAIN, BOX2, BOX3, EM, INPRM, MUBREM, C MUDECY, MUPRPR, MUTRAC, NRANGC, NUCINT, PRANGC, START, UPDATC, C UPDATE, EGS4, ELECTR, HOWFAR, PHOTON, ININKG, NKG, AND CERENK. C ARGUMENT: C ARG = HEIGHT (CM) C----------------------------------------------------------------------- IMPLICIT NONE #define __ATMOSINC__ #define __ATMOS2INC__ #define __RUNPARINC__ #if __ATMEXT__ #define __ATMOSXINC__ #endif #include "corsika.h" DOUBLE PRECISION ARG SAVE #if __ATMEXT__ DOUBLE PRECISION THICKX EXTERNAL THICKX #endif C----------------------------------------------------------------------- CC IF ( DEBUG ) WRITE(MDEBUG,*) 'THICK : ARG=',SNGL(ARG) #if __ATMEXT__ IF ( IATMOX .GE. 1 ) THEN THICK = THICKX(ARG) RETURN ENDIF #endif IF ( ARG .LT. HLAY(2) ) THEN THICK = AATM(1) + BATM(1) * EXP( (-ARG) * DATM(1) ) ELSEIF ( ARG .LT. HLAY(3) ) THEN THICK = AATM(2) + BATM(2) * EXP( (-ARG) * DATM(2) ) ELSEIF ( ARG .LT. HLAY(4) ) THEN THICK = AATM(3) + BATM(3) * EXP( (-ARG) * DATM(3) ) ELSEIF ( ARG .LT. HLAY(5) ) THEN THICK = AATM(4) + BATM(4) * EXP( (-ARG) * DATM(4) ) ELSE THICK = AATM(5) - ARG * DATM(5) ENDIF RETURN END #if __CURVED__ *-- Author : F. SCHROEDER UNI WUPPERTAL 17/09/98 C======================================================================= DOUBLE PRECISION FUNCTION THICKC( ARG ) C----------------------------------------------------------------------- C THICK(NESS IN CASE OF) C(URVED ATMOSPHERE) C C CALCULATES THE ATMOSPHERIC THICKNESS AT INTERACTION POINT IN CURVED C COORDINATE SYSTEM AFTER TRANSPORTING THE PARTICLE BY CHI G/CM**2. C THIS FUNCTION IS CALLED FROM AAMAIN. C ARGUMENT: C ARG = PENETRATED MATTER THICKNESS IN CURVED ATMOSPHERE (G/CM**2) C C REDESIGN: D. HECK IK FZK KARLSRUHE C----------------------------------------------------------------------- IMPLICIT NONE #define __ATMOSINC__ #define __ATMOS2INC__ #define __OBSPARINC__ #define __PARPARINC__ #define __PARPAEINC__ #define __RUNPARINC__ #include "corsika.h" DOUBLE PRECISION ARG,AUXIL,CHIC,CHIMAX,CHIN,CORR,COSDIF,COSPHI, * COSTHENEW,COSTHEOLD,DL, * HEIGH,HNEW,HOLD,SINDIF,SINI,SINPHI,SINTHE, * THCKHN,THCKHO,THICK,TRANS,TRANS2,WORK, * XNEW,XOLD,YNEW,YOLD INTEGER IL #if __UPWARD__ DOUBLE PRECISION RHOF EXTERNAL RHOF #endif SAVE EXTERNAL HEIGH,THICK C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'THICKC: ARG=',SNGL(ARG),'H=',SNGL(H) C START VALUES CHIC = ARG HNEW = H XNEW = X YNEW = Y THCKHN = THICKH SINTHE = SQRT( (1.D0-COSTHE)*(1.D0+COSTHE) ) IF ( SINTHE .NE. 0.D0 ) THEN COSPHI = PHIX / SINTHE SINPHI = PHIY / SINTHE ELSE COSPHI = 0.D0 SINPHI = 0.D0 ENDIF COSTHENEW = COSTHE C CHOPPING OF TOTAL PATH LENGTH CHITOT INTO SMALLER PIECES AND C TRANSPORT IN LOCAL PLANE SYSTEM. STEP LENGTH LIMITATION DEPENDS ON C THICKNESS OF STARTING POINT. THIS NEEDS A LOOP OVER ALL SMALL PIECES C OF STEP WHICH ENDS AT MAXIMAL HORIZONTAL STEP 2 CONTINUE C SAVE OLD LOCAL HEIGHT FOR TRANSFORMATION AFTER UPDATE HOLD = HNEW XOLD = XNEW YOLD = YNEW COSTHEOLD = COSTHENEW IF ( DEBUG ) WRITE(MDEBUG,*) 'THICKC: CHIC,HOLD,THCKHN=', * SNGL(CHIC),SNGL(HOLD),SNGL(THCKHN) C LOOK WITHIN WHICH LAYER THE PARTICLE STARTS IF ( HOLD .LE. HLAY(2) ) THEN IL = 1 ELSEIF ( HOLD .LE. HLAY(3) ) THEN IL = 2 ELSEIF ( HOLD .LE. HLAY(4) ) THEN IL = 3 ELSE IL = 4 ENDIF #if __UPWARD__ IF ( COSTHENEW .LT. 0.D0 ) IL = IL + 1 C LOOK FOR MAXIMAL STEP OF CHIN, ONLY IF NOT CLOSE TO VERTICAL IF ( ABS( COSTHEOLD ) .LT. 0.98D0 ) THEN #else C LOOK FOR MAXIMAL STEP OF CHIN, ONLY IF NOT CLOSE TO VERTICAL IF ( COSTHEOLD .LT. 0.98D0 ) THEN #endif SINI = DATM(IL) / SQRT( (1.D0-COSTHEOLD)*(1.D0+COSTHEOLD) ) WORK = MAX( C(2), C(3) + C(4)*THCKHN ) IF ( DEBUG ) WRITE(MDEBUG,*) 'THICKC: SINI,WORK=',SINI,WORK IF ( HOLD .LT. HLAY(5) ) THEN CHIMAX = ( THCKHN - AATM(IL) ) * SINI * * ( WORK + 0.5D0*COSTHEOLD*SINI * WORK**2 ) ELSE CHIMAX = WORK * SINI * DATM(5)/DATM(IL) ENDIF IF ( DEBUG ) WRITE(MDEBUG,301) CHIMAX 301 FORMAT(' THICKC: CHIMAX=',F10.5,' TO NEXT ATMOSPHERIC BOUNDARY') IF ( CHIC .GE. CHIMAX ) THEN CHIN = CHIMAX ELSE CHIN = CHIC ENDIF ELSE CHIN = CHIC ENDIF C ACTUAL VALUES THCKHO = THCKHN THCKHN = THCKHO + CHIN * COSTHEOLD THCKHN = MAX( 0.D0, THCKHN) C NEW COORDINATE FRAME, NEW ACTUAL HEIGHT AT NEW THICKNESS GRADIENT C (CALCULATED WITH PARAMETERS OF OLD COORDINATE FRAME) HNEW = HEIGH( THCKHN ) IF ( DEBUG ) WRITE(MDEBUG,*) 'THICKC: CHIN,HOLD,HNEW=', * SNGL(CHIN),SNGL(HOLD),SNGL(HNEW) C CALCULATE TRANSPORT LENGTH DL #if __UPWARD__ IF ( ABS( COSTHEOLD ) .LT. 0.003D0 ) THEN C TREATMENT OF NEARLY HORIZONTAL PARTICLE (INCLINATION < 0.2 DEG) DL = CHIN / RHOF( HNEW ) ELSE DL = (HOLD - HNEW) / COSTHEOLD ENDIF #else DL = (HOLD - HNEW) / COSTHEOLD #endif C CALCULATE THE REMAINING MATTER TO BE PANETRATED CHIC = CHIC - CHIN IF ( DEBUG ) WRITE(MDEBUG,*) 'THICKC: CHIC,THCKHN,DL=', * SNGL(CHIC),SNGL(THCKHN),SNGL(DL) C HORIZONTAL STEP IS TRANS, TRANS2 IS TRANS**2 TRANS2 = DL**2 * (1.D0 - COSTHEOLD)*(1.D0 + COSTHEOLD) TRANS = SQRT( TRANS2 ) IF ( DEBUG ) WRITE(MDEBUG,*) 'THICKC: HNEW,DL,TRANS=', * SNGL(HNEW),SNGL(DL),SNGL(TRANS) AUXIL = SQRT( TRANS2 + (C(1)+HNEW)**2 ) C CALCULATE ANGLE DIFFERENCE BETWEEN OLD AND NEW FRAME SINDIF = TRANS / AUXIL COSDIF = (C(1)+HNEW) / AUXIL IF ( DEBUG ) WRITE(MDEBUG,*) 'THICKC: HNEW,COSDIF,AUXIL=', * SNGL(HNEW),SNGL(COSDIF),SNGL(AUXIL) COSDIF = MIN( 1.D0, COSDIF ) C X AND Y HAVE TO BE TRANSFORMED INTO 'EARTH'-COORDINATES (SPHERE) C TRANSPORT DISTANCE IS CORRECTED TO GET DISTANCE AT EARTHS SURFACE HNEW = AUXIL - C(1) THCKHN = THICK( HNEW ) IF ( SINDIF .NE. 0.D0 ) THEN CORR = C(1) * ASIN( SINDIF ) / ( (C(1)+HNEW) * SINDIF ) C NOW CALCULATE COORDINATES IN NEW SYSTEM XNEW = XOLD + TRANS * COSPHI * CORR YNEW = YOLD + TRANS * SINPHI * CORR ELSE XNEW = XOLD YNEW = YOLD ENDIF IF ( DEBUG ) THEN WRITE(MDEBUG,*) 'THICKC: XNEW,YNEW,HNEW=', * SNGL(XNEW),SNGL(YNEW),SNGL(HNEW) ENDIF C IF WE ARRIVE OBSLEVEL HEIGHT, THEN MODIFY ARRIVAL HEIGHT IF ( XNEW*PRMPAR(3) + YNEW*PRMPAR(4) * + (OBSLEV(1) - HNEW)*PRMPAR(2) .GT. 0.D0 ) THEN IF ( DEBUG ) WRITE(MDEBUG,*) 'THICKC: HNEW=',HNEW HNEW = OBSLEV(1) GOTO 999 ENDIF C IN FIRST ORDER APPROXIMATION COSTHEOLD AND COSDIF ARE IN THE SAME C PLANE OF PARTICLE MOVEMENT, THEREFORE THE ANGLES MAY BE ADDED C DIRECTLY: COSINE OF THE ZENITH ANGLE IN THE NEW FRAME COSTHENEW = COSTHEOLD * COSDIF * - SQRT( (1.D0-COSTHEOLD) * (1.D0+COSTHEOLD) * * (1.D0-COSDIF) * (1.D0+COSDIF) ) COSTHENEW = MIN( 1.D0, COSTHENEW ) IF (DEBUG) WRITE(MDEBUG,*) 'THICKC: COSTHENEW=',SNGL(COSTHENEW) IF ( COSTHENEW .LE. C(29) ) GOTO 999 C LOOP BACK, IF NOT COMPLETE MATTER IS PENETRATED IF ( CHIC .GT. 0.D0 ) GOTO 2 999 CONTINUE THCKHN = THICK( HNEW ) THICKC = THCKHN IF (DEBUG) WRITE(MDEBUG,*) 'THICKC: THICKC=',SNGL(THICKC), * ' HNEW=',HNEW RETURN END #endif *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE TOBUF( A,IFL ) C----------------------------------------------------------------------- C (WRITE) TO BUF(FER) C C WRITES UP TO NSUBBL DATA BLOCKS TO OUTPUT BUFFER AND PUTS THE FULL C BUFFER TO FILE. C THIS SUBROUTINE IS CALLED FROM AAMAIN, ELECTR, INPRM, OUTEND, C OUTPT1, OUTPT2, AND PHOTON. C ARGUMENTS: C A = ARRAY TO BE WRITTEN TO FILE C IFL = STARTING OF FINAL OUTPUT C = 0 NORMAL BLOCK C = 1 NORMAL BLOCK WITH END OF OUTPUT C = 2 ONLY END OF OUTPUT C----------------------------------------------------------------------- IMPLICIT NONE #define __BUFFSINC__ #define __RECORDINC__ #define __RUNPARINC__ #if __ICECUBE1__ #define __PARPARINC__ #endif #include "corsika.h" #if __ICECUBE1__ INTEGER zeroes #else C NSUBBL IS NUMBER OF SUBBLOCKS IN ONE OUTPUT RECORD INTEGER NSUBBL PARAMETER (NSUBBL=21) #if __THIN__ C (OUTPUT RECORD LENGTH = NSUBBL * 39 * 8 * 4 BYTES <= 26208 ) #else C (OUTPUT RECORD LENGTH = NSUBBL * 39 * 7 * 4 BYTES <= 22932 ) #endif #if !__COAST__ || __COASTUSERLIB__ C OUTPUT BUFFER FOR PARTICLE OUTPUT REAL OUTBUF(MAXBUF,NSUBBL) #if !__COMPACT__ * ,OUTVECT(MAXBUF*NSUBBL) #endif C IBLK IS COUNTER FOR SUBBLOCKS INTEGER I,K #if !__COMPACT__ * ,J #endif #endif INTEGER IBLK DATA IBLK / 0 / #endif REAL A(*) CHARACTER*4 CNAME REAL A1 EQUIVALENCE (A1,CNAME) INTEGER IFL SAVE C----------------------------------------------------------------------- A1 = A(1) IF ( .NOT.( CNAME(1:1) .EQ. "E" .OR. CNAME(1:1) .EQ. "R" * .OR. CNAME(1:1) .EQ. "L" ) ) CNAME = "DATA" IF ( DEBUG ) WRITE(MDEBUG,*) 'TOBUF ('//CNAME//'): IFL =',IFL #if __ICECUBE1__ C IS THIS SHOWER STILL INTERESTING? #if __COASTUSERLIB__ zeroes = 0 #else IF ( still_interesting .AND. n_interesting_nu .GT. 0 ) THEN zeroes = 0 ELSE zeroes = 1 ENDIF #endif call tobuf_c( A, MAXBUF, IFL, zeroes ) C SHOWER FINISHED; RESET COUNTERS IF ( IFL .GE. 1 ) THEN n_interesting = 0 n_interesting_nu = 0 still_interesting = .TRUE. ENDIF #if __COAST__ #if __COASTUSERLIB__ call wrida(a) #else IF ( FPAROUT ) call wrida(a) #endif #endif #else C COPY TO BUFFER IF ( IFL .LE. 1 ) THEN IBLK = IBLK + 1 #if __COAST__ #if __COASTUSERLIB__ call wrida(a) #else IF ( FPAROUT ) call wrida(a) #endif #endif #if !__COAST__ || __COASTUSERLIB__ DO I = 1, MAXBUF OUTBUF(I,IBLK) = A(I) ENDDO #endif ENDIF #if !__COAST__ || __COASTUSERLIB__ C WRITE TO FILE IF BLOCK IS FULL OR IF IFL IS 1 IF ( IFL .GE. 1 .OR. IBLK .EQ. NSUBBL ) THEN NRECS = NRECS + 1 NBLKS = NBLKS + IBLK IF ( FPAROUT ) THEN #if __COMPACT__ WRITE(MPATAP) ((OUTBUF(I,K),I=1,MAXBUF),K=1,NSUBBL) #else J = 0 DO K = 1, NSUBBL DO I = 1, MAXBUF J = J + 1 OUTVECT(J) = OUTBUF(I,K) ENDDO ENDDO #if __PARALLELIB__ CALL joindat( MAXBUF, NSUBBL, OUTVECT ) #else CALL fwritempatap( MAXBUF, NSUBBL, OUTVECT ) #endif #endif ENDIF IRECOR = IRECOR + MAXBUF * NSUBBL IBLK = 0 DO K = 1, NSUBBL DO I = 1, MAXBUF OUTBUF(I,K) = 0.0 ENDDO ENDDO ENDIF #endif #endif RETURN END #if __COMPACT__ *-- Author : J. Wentz IK FZK KARLSRUHE 20/05/1999 C======================================================================= SUBROUTINE TOBUFS( A,N ) C----------------------------------------------------------------------- C (WRITE) TO BUF(FER) S(HORT) C C WRITES DATA A WITH LENGTH N TO BUFFER. C THIS SUBROUTINE IS CALLED FROM AAMAIN, ELECTR, INPRM, OUTEND, C OUTPT1, AND PHOTON. C ARGUMENTS: C A = ARRAY TO BE WRITTEN TO FILE C N = LENGTH OF DATA BLOCK C----------------------------------------------------------------------- IMPLICIT NONE #define __RUNPARINC__ #include "corsika.h" REAL A(*),A1 INTEGER I,N CHARACTER*4 CNAME EQUIVALENCE (A1,CNAME) SAVE C----------------------------------------------------------------------- A1=A(1) IF ( DEBUG ) WRITE(MDEBUG,*) 'TOBUFS ('//CNAME//'): N =',N CDH April 2004 IF ( FPAROUT ) WRITE(MPATAP) N, ( A(I), I=1, N ) RETURN END #endif #if __TRAJECT__ *-- Author : D. HECK IKP KIT KARLSRUHE 24/01/2012 C======================================================================= SUBROUTINE TRAJCHECK C----------------------------------------------------------------------- C TRAJ(ECTORY INPUT) CHECK C CHECKS THE INPUT PARAMETERS OF THE TRAJECTORY KEY WORDS. C THIS SUBROUTINE IS CALLED FROM AAMAIN. C----------------------------------------------------------------------- IMPLICIT NONE #define __RUNPARINC__ #define __TRAJECINC__ #include "corsika.h" SAVE C----------------------------------------------------------------------- C CHECK RIGHT ASCENSION IF ( RA .LT. 0.D0 .OR. RA .GT. 24.D0 ) THEN WRITE(MONIOU,*) 'TRAJCHECK: RIGHT ASCENSION PARAMETER OUT OF ', * ' ALLOWED RANGE, RA=',SNGL(RA) WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORD: SRCPOS' STOP ENDIF C CHECK DECLINATION IF ( DECL .LT. -90.D0 .OR. DECL .GT. 90.D0 ) THEN WRITE(MONIOU,*) 'TRAJCHECK: DECLINATION PARAMETER OUT OF ', * ' ALLOWED RANGE, DECL=',SNGL(DECL) WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORD: SRCPOS' STOP ENDIF C CHECK TREJECTORY TIME PARAMETERS IF ( TMONTH .LT. 1 .OR. TMONTH .GT. 12 ) THEN WRITE(MONIOU,*) 'TRAJCHECK: TIME PARAMETER MONTH OUT OF ', * 'ALLOWED RANGE, TMONTH=',TMONTH WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORD: TRATM' STOP ENDIF IF ( TDAY .LT. 1 ) THEN WRITE(MONIOU,*) 'TRAJCHECK: TIME PARAMETER DAY OUT OF ', * 'ALLOWED RANGE, TDAY=',TDAY WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORD: TRATM' STOP ENDIF IF ( TMONTH .EQ. 2 .AND. TDAY .GT. 29 ) THEN WRITE(MONIOU,*) 'TRAJCHECK: TIME PARAMETER DAY OUT OF ', * 'ALLOWED RANGE, TDAY=',TDAY WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORD: TRATM' STOP ENDIF IF ( ( TMONTH .EQ. 4 .OR. TMONTH .EQ. 6 .OR. * TMONTH .EQ. 9 .OR. TMONTH .EQ. 11 ) .AND. * TDAY .GT. 30 ) THEN WRITE(MONIOU,*) 'TRAJCHECK: TIME PARAMETER DAY OUT OF ', * 'ALLOWED RANGE, TDAY=',TDAY WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORD: TRATM' STOP ENDIF IF ( TDAY .GT. 31 ) THEN WRITE(MONIOU,*) 'TRAJCHECK: TIME PARAMETER DAY OUT OF ', * 'ALLOWED RANGE, TDAY=',TDAY WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORD: TRATM' STOP ENDIF IF ( THOUR .LT. 0 .OR. THOUR .GT. 24 ) THEN WRITE(MONIOU,*) 'TRAJCHECK: TIME PARAMETER HOUR OUT OF ', * 'ALLOWED RANGE, THOUR=',THOUR WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORD: TRATM' STOP ENDIF IF ( TMINUTE .LT. 0 .OR. TMINUTE .GT. 60 ) THEN WRITE(MONIOU,*) 'TRAJCHECK: TIME PARAMETER MINUTE OUT OF ', * 'ALLOWED RANGE, TMINUTE=',TMINUTE WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORD: TRATM' STOP ENDIF IF ( TSECOND .LT. 0 .OR. TSECOND .GT. 60 ) THEN WRITE(MONIOU,*) 'TRAJCHECK: TIME PARAMETER SECOND OUT OF ', * 'ALLOWED RANGE, TSECOND=',TSECOND WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORD: TRATM' STOP ENDIF IF ( TDURATION .LT. 0 ) THEN WRITE(MONIOU,*) 'TRAJCHECK: TIME PARAMETER DURATION OUT OF ', * 'ALLOWED RANGE, TDURATION=',TDURATION WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORD: TRATM' STOP ENDIF C CHECK OF TELESCOPE SITE PARAMETERS C LONGITUDINAL IF ( TLONGDGR .LT. 0.D0 .OR. TLONGDGR .GT. 180.D0 ) THEN WRITE(MONIOU,*) 'TRAJCHECK: TELESCOPE SITE PARAMETER OUT OF ', * 'ALLOWED RANGE, TLONGDGR=',TLONGDGR WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORD: TLONG' STOP ENDIF IF ( TLONGMIN .LT. 0.D0 .OR. TLONGMIN .GT. 60.D0 ) THEN WRITE(MONIOU,*) 'TRAJCHECK: TELESCOPE SITE PARAMETER OUT OF ', * 'ALLOWED RANGE, TLONGMIN=',TLONGMIN WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORD: TLONG' STOP ENDIF IF ( TLONGSEC .LT. 0.D0 .OR. TLONGSEC .GT. 60.D0 ) THEN WRITE(MONIOU,*) 'TRAJCHECK: TELESCOPE SITE PARAMETER OUT OF ', * 'ALLOWED RANGE, TLONGSEC=',TLONGSEC WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORD: TLONG' STOP ENDIF IF ( TLONGDIR .NE. 'W' .AND. TLONGDIR .NE. 'E' ) THEN WRITE(MONIOU,*) 'TRAJCHECK: TELESCOPE SITE PARAMETER OUT OF ', * 'ALLOWED RANGE, TLONGDIR=',TLONGDIR WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORD: TLONG' STOP ENDIF C LATERAL IF ( TLATDGR .LT. 0.D0 .OR. TLATDGR .GT. 90.D0 ) THEN WRITE(MONIOU,*) 'TRAJCHECK: TELESCOPE SITE PARAMETER OUT OF ', * 'ALLOWED RANGE, TLATDGR=',TLATDGR WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORD: TLAT' STOP ENDIF IF ( TLATMIN .LT. 0.D0 .OR. TLATMIN .GT. 60.D0 ) THEN WRITE(MONIOU,*) 'TRAJCHECK: TELESCOPE SITE PARAMETER OUT OF ', * 'ALLOWED RANGE, TLATMIN=',TLATMIN WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORD: TLAT' STOP ENDIF IF ( TLATSEC .LT. 0.D0 .OR. TLATSEC .GT. 60.D0 ) THEN WRITE(MONIOU,*) 'TRAJCHECK: TELESCOPE SITE PARAMETER OUT OF ', * 'ALLOWED RANGE, TLATSEC=',TLATSEC WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORD: TLAT' STOP ENDIF IF ( TLATDIR .NE. 'N' .AND. TLATDIR .NE. 'S' ) THEN WRITE(MONIOU,*) 'TRAJCHECK: TELESCOPE SITE PARAMETER OUT OF ', * 'ALLOWED RANGE, TLATDIR=',TLATDIR WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORD: TLAT' STOP ENDIF C CHECK DECLINATION IF ( GEODECL .LT. -45.D0 .OR. GEODECL .GT. 45.D0 ) THEN WRITE(MONIOU,*) 'TRAJCHECK: DECLINATION PARAMETER OUT OF ', * 'ALLOWED RANGE, GEODECL=',SNGL(GEODECL) WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORD: GEODEC' STOP ENDIF C CHECK BROADENING PARAMETER IF ( TRAD .LT. 0.D0 .OR. TRAD .GT. 3600.D0 ) THEN WRITE(MONIOU,*) 'TRAJCHECK: BROADENING PARAMETER OUT OF ', * 'ALLOWED RANGE, TRAD=',SNGL(TRAD) WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORD: TRARAD' STOP ENDIF RETURN END #endif *-- Author : Johannes Knapp, IEKP U Karlsruhe 26/01/1997 C======================================================================= SUBROUTINE TSTACK C----------------------------------------------------------------------- C T(O) STACK C C ADDS PARTICLE TO INTERMEDIATE STACK UNTIL REACTION IS FINISHED. C ONLY PARTICLES ABOVE ENERGY CUT ARE TAKEN TO STACK. C THIS SUBROUTINE IS CALLED FROM MANY ROUTINES ALL OVER THE PROGRAM. C----------------------------------------------------------------------- IMPLICIT NONE #define __BUFFSINC__ #define __ELABCTINC__ #define __LONGIINC__ #define __MUPARTINC__ #define __PAMINC__ #define __PARPARINC__ #define __PARPAEINC__ #define __RUNPARINC__ #define __THNVARINC__ #if __AUGERHIST__ #define __GENERINC__ #define __OBSPARINC__ #endif #include "corsika.h" DOUBLE PRECISION FAC1,FAC2 INTEGER I,J #if __AUGERHIST__ DOUBLE PRECISION EDEP INTEGER II,LL #endif #if __FLUKA__ DOUBLE PRECISION ANCUT #endif #if !__STACKIN__ && !__CONEX__ DOUBLE PRECISION EN,PZ,PX,PY,PTOT,CPHIV,SPHIV,COSTET INTEGER NTYP #endif SAVE C----------------------------------------------------------------------- #if __ICECUBE1__ C RETURN IMMEDIATELY IF THE SHOWER SHOULD STOP IF ( .NOT. still_interesting ) RETURN #endif INT_ICOUNT = INT_ICOUNT + 1 #if __THIN__ IF (DEBUG) WRITE(MDEBUG,1) INT_ICOUNT,(SECPAR(J),J=0,9),SECPAR(13) 1 FORMAT(' TSTACK:',I7,1X,1P,9E11.3,0P,F10.0,1P,E10.3) #else IF ( DEBUG ) WRITE(MDEBUG,1) INT_ICOUNT,(SECPAR(J),J=0,9) 1 FORMAT(' TSTACK:',I7,1X,1P,9E11.3,0P,F10.0) #endif IF ( INT_ICOUNT .GT. MAXICOUNT ) THEN WRITE(MONIOU,10) MAXICOUNT 10 FORMAT(' TSTACK: TOO MANY SECONDARIES FOR THIS REACTION', * ' EXCEEDED ',I7,' STOP') c * ' EXCEEDED ',I7,' A T T E N T I O N PARTICLE IS LOST') WRITE(MONIOU,*)'TSTACK: INCREASE PARAMETER MAXICOUNT TO ', * ' CIRCUMVENT THIS PROBLEM.' INT_ICOUNT = INT_ICOUNT - 1 STOP * RETURN ENDIF #if !__STACKIN__ && !__CONEX__ C IF FIRST INTERACTION, STORE PARTICLES IN A TEMPORARY FILE TO BE C WRITTEN IN OUTFILE IF ( FOUTFILE .AND. FIRSTI ) THEN NTYP = NINT(SECPAR(0)) IF ( PAMA( NTYP ) .NE. 0.D0 ) THEN EN = SECPAR(1) * PAMA( NTYP ) ELSE EN = SECPAR(1) ENDIF PTOT = (EN-PAMA(NTYP))*(EN+PAMA(NTYP)) IF ( PTOT .GE. 0.D0 ) THEN PTOT = SQRT( PTOT ) CALL ADDANI4(COSTHE,PHIX,PHIY, COSTET,CPHIV,SPHIV * , SECPAR(2),SECPAR(3),SECPAR(4)) PX = CPHIV * PTOT PY = SPHIV * PTOT PZ = COSTET * PTOT IFINAM = IFINAM + 1 WRITE(LSTCK2,510) IFINAM,NTYP,EN,PZ,PX,PY ENDIF 510 FORMAT(2I5,4(1X,E15.7)) ENDIF #endif #if __PARALLEL__ C SECPAR(39) IS LESS THAN ZERO (OFF) BY DEFAULT SECPAR(39) = -1.D0 #endif C CALCULATE APPROPRIATE KINETIC ENERGY CUT AND APPLY IT IF ( SECPAR(0) .EQ. 5.D0 .OR. SECPAR(0) .EQ. 6.D0 ) THEN C ---MUONS--- IF ( (SECPAR(1) - 1.D0)*PAMA(5) .LT. ELCUT(2) ) THEN FMUORG = .FALSE. IF ( DEBUG ) WRITE(MDEBUG,*) * 'TSTACK: PARTICLE BELOW ENERGY CUT' INT_ICOUNT = INT_ICOUNT - 1 IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT #if __THIN__ DLONG(LHEIGH,5) = DLONG(LHEIGH,5)+SECPAR(1)*PAMA(5)*WEIGHT #else DLONG(LHEIGH,5) = DLONG(LHEIGH,5) + SECPAR(1) * PAMA(5) #endif ENDIF #if __AUGERHIST__ IF ( DEBUG ) WRITE(MDEBUG,2) (SECPAR(II),II=0,9) 2 FORMAT(' TSTACK: E-DEP',2X,1P,9E11.3,0P,F10.0) DO LL = 1, NOBSLV IF ( THICKH .GE. THCKOB(LL) .AND. * THICKH .LT. THCKOB(LL)+SAMPTH ) THEN C THICKH IS WITHIN 1 G/CM^2 BELOW OBSLEV(LL) C BRING THE ENERGY BELOW CUT TO THE HISTO OF LEVEL LL DO II = 0, 8 OUTPAR(II) = SECPAR(II) ENDDO OUTPAR( 9) = GEN OUTPAR(10) = ALEVEL OUTPAR(13) = WEIGHT EDEP = SECPAR(1) * PAMA(5) * WEIGHT IF ( DEBUG ) WRITE(MDEBUG,*) 'TSTACK: THICKH=',THICKH CALL AUGERDEPFIL( EDEP,LL,0 ) ELSEIF ( THICKH .LT. THCKOB(LL) ) THEN RETURN ENDIF ENDDO #endif RETURN #if __PARALLEL__ #if __CONEX__ ELSE #else ELSEIF ( (SECPAR(1) - 1.D0)*PAMA(5) .GT. ECTCUT ) THEN #endif C FLAG ECUT PARTICLES FOR OUTPUT TO SPECIAL FILE SECPAR(39) = 1.D0 #endif ENDIF ELSEIF ( SECPAR(0) .EQ. 2.D0 .OR. SECPAR(0) .EQ. 3.D0 ) THEN C ---ELECTRONS--- IF ( (SECPAR(1) - 1.D0)*PAMA(2) .LT. ELCUT(3) ) THEN IF ( DEBUG ) WRITE(MDEBUG,*) * 'TSTACK: PARTICLE BELOW ENERGY CUT' INT_ICOUNT = INT_ICOUNT - 1 IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT IF ( SECPAR(0) .EQ. 2.D0 ) THEN DLONG(LHEIGH,3) = DLONG(LHEIGH,3) #if __THIN__ * + (SECPAR(1)+1.D0)*PAMA(2)*WEIGHT ELSE DLONG(LHEIGH,3) = DLONG(LHEIGH,3) * + (SECPAR(1)-1.D0)*PAMA(2)*WEIGHT #else * + (SECPAR(1)+1.D0) * PAMA(2) ELSE DLONG(LHEIGH,3) = DLONG(LHEIGH,3) * + (SECPAR(1)-1.D0) * PAMA(2) #endif ENDIF ENDIF #if __AUGERHIST__ IF ( DEBUG ) WRITE(MDEBUG,2) (SECPAR(II),II=0,9) DO LL = 1, NOBSLV IF ( THICKH .GE. THCKOB(LL) .AND. * THICKH .LT. THCKOB(LL)+SAMPTH ) THEN C THICKH IS WITHIN 1 G/CM^2 BELOW OBSLEV(LL) C BRING THE ENERGY BELOW CUT TO THE HISTO OF LEVEL LL OUTPAR( 0) = SECPAR(0) OUTPAR( 1) = SECPAR(1) * PAMA(2) DO II = 2, 8 OUTPAR(II) = SECPAR(II) ENDDO OUTPAR( 9) = GEN OUTPAR(10) = ALEVEL OUTPAR(13) = WEIGHT EDEP = ( OUTPAR(1) - RESTMS(NINT(SECPAR(0))) ) * WEIGHT IF ( DEBUG ) WRITE(MDEBUG,*) 'TSTACK: THICKH=',THICKH CALL AUGERDEPFIL( EDEP,LL,0 ) ELSEIF ( THICKH .LT. THCKOB(LL) ) THEN RETURN ENDIF ENDDO #endif RETURN #if __PARALLEL__ #if __CONEX__ ELSE #else ELSEIF ( (SECPAR(1) - 1.D0)*PAMA(2) .GT. ECTCUT ) THEN #endif C FLAG ECUT PARTICLES FOR OUTPUT TO SPECIAL FILE SECPAR(39) = 1.D0 #endif ENDIF ELSEIF ( SECPAR(0) .EQ. 1.D0 ) THEN C ---GAMMAS--- IF ( SECPAR(1) .LT. ELCUT(4) ) THEN IF ( DEBUG ) WRITE(MDEBUG,*) * 'TSTACK: PARTICLE BELOW ENERGY CUT' INT_ICOUNT = INT_ICOUNT - 1 IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT #if __THIN__ DLONG(LHEIGH,1) = DLONG(LHEIGH,1) + SECPAR(1) * WEIGHT #else DLONG(LHEIGH,1) = DLONG(LHEIGH,1) + SECPAR(1) #endif ENDIF #if __AUGERHIST__ IF ( DEBUG ) WRITE(MDEBUG,2) (SECPAR(II),II=0,9) DO LL = 1, NOBSLV IF ( THICKH .GE. THCKOB(LL) .AND. * THICKH .LT. THCKOB(LL)+SAMPTH ) THEN C THICKH IS WITHIN 1 G/CM^2 BELOW OBSLEV(LL) C BRING THE ENERGY BELOW CUT TO THE HISTO OF LEVEL LL DO II = 0, 8 OUTPAR(II) = SECPAR(II) ENDDO OUTPAR( 9) = GEN OUTPAR(10) = ALEVEL OUTPAR(13) = WEIGHT EDEP = SECPAR(1) * WEIGHT IF ( DEBUG ) WRITE(MDEBUG,*) 'TSTACK: THICKH=',THICKH CALL AUGERDEPFIL( EDEP,LL,0 ) ELSEIF ( THICKH .LT. THCKOB(LL) ) THEN RETURN ENDIF ENDDO #endif RETURN #if __PARALLEL__ #if __CONEX__ ELSE #else ELSEIF ( SECPAR(1) .GT. ECTCUT ) THEN #endif C FLAG ECUT PARTICLES FOR OUTPUT TO SPECIAL FILE SECPAR(39) = 1.D0 #endif ENDIF #if __NEUTRINO__ || __NUPRIM__ ELSEIF ( ( SECPAR(0).GE.66.D0 .AND. SECPAR(0).LE.69.D0 ) #if __CHARM__ || __TAULEP__ * .OR. SECPAR(0).EQ.133.D0 .OR. SECPAR(0).EQ.134.D0 #endif * ) THEN C ---NEUTRINOS--- IF ( SECPAR(1) .LT. ELCUT(1) ) THEN IF ( DEBUG ) WRITE(MDEBUG,*) * 'TSTACK: PARTICLE BELOW ENERGY CUT' INT_ICOUNT = INT_ICOUNT - 1 IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT #if __THIN__ DLONG(LHEIGH,8) = DLONG(LHEIGH,8) + SECPAR(1) * WEIGHT #else DLONG(LHEIGH,8) = DLONG(LHEIGH,8) + SECPAR(1) #endif ENDIF #if __AUGERHIST__ C NEUTRINOS DON''T DEPOSE ENERGY #endif RETURN ENDIF #endif ELSEIF ( SECPAR(0) .EQ. 7.D0 ) THEN C ---PI(0)--- TAKE THRESHOLD OF GAMMAS IF ( (SECPAR(1)-1.D0)*PAMA(7) .LT. ELCUT(4) ) THEN IF ( DEBUG ) WRITE(MDEBUG,*) * 'TSTACK: PARTICLE BELOW GAMMA ENERGY CUT' INT_ICOUNT = INT_ICOUNT - 1 IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT #if __THIN__ DLONG(LHEIGH,1) = DLONG(LHEIGH,1)+SECPAR(1)*PAMA(7)*WEIGHT #else DLONG(LHEIGH,1) = DLONG(LHEIGH,1) + SECPAR(1) * PAMA(7) #endif ENDIF #if __AUGERHIST__ IF ( DEBUG ) WRITE(MDEBUG,2) (SECPAR(II),II=0,9) DO LL = 1, NOBSLV IF ( THICKH .GE. THCKOB(LL) .AND. * THICKH .LT. THCKOB(LL)+SAMPTH ) THEN C THICKH IS WITHIN 1 G/CM^2 BELOW OBSLEV(LL) C BRING THE ENERGY BELOW CUT TO THE HISTO OF LEVEL LL DO II = 0, 8 OUTPAR(II) = SECPAR(II) ENDDO OUTPAR( 9) = GEN OUTPAR(10) = ALEVEL OUTPAR(13) = WEIGHT EDEP = SECPAR(1) * PAMA(7) * WEIGHT IF ( DEBUG ) WRITE(MDEBUG,*) 'TSTACK: THICKH=',THICKH CALL AUGERDEPFIL( EDEP,LL,0 ) ELSEIF ( THICKH .LT. THCKOB(LL) ) THEN RETURN ENDIF ENDDO #endif RETURN #if __PARALLEL__ #if __CONEX__ ELSE #else ELSEIF ( (SECPAR(1) - 1.D0)*PAMA(7) .GT. ECTCUT ) THEN #endif C FLAG ECUT PARTICLES FOR OUTPUT TO SPECIAL FILE SECPAR(39) = 1.D0 #endif ENDIF #if __CHARM__ || __TAULEP__ ELSEIF ( SECPAR(0) .EQ. 131.D0 .OR. SECPAR(0) .EQ. 132.D0 ) THEN C ---TAU--- IF ( (SECPAR(1)-1.D0)*PAMA(NINT(SECPAR(0))) .LT. ELCUT(2) ) THEN IF ( DEBUG ) WRITE(MDEBUG,*) * 'TSTACK: PARTICLE BELOW ENERGY CUT' INT_ICOUNT = INT_ICOUNT - 1 IF ( LLONGI ) THEN C ADD ENERGY TO THE LONGITUDINAL MUON ENERGY DEPOSIT DLONG(LHEIGH,5) = DLONG(LHEIGH,5) #if __THIN__ * + SECPAR(1) * PAMA(NINT(SECPAR(0))) * WEIGHT #else * + SECPAR(1) * PAMA(NINT(SECPAR(0))) #endif ENDIF #if __AUGERHIST__ IF ( DEBUG ) WRITE(MDEBUG,2) (SECPAR(II),II=0,9) DO LL = 1, NOBSLV IF ( THICKH .GE. THCKOB(LL) .AND. * THICKH .LT. THCKOB(LL)+SAMPTH ) THEN C THICKH IS WITHIN 1 G/CM^2 BELOW OBSLEV(LL) C BRING THE ENERGY BELOW CUT TO THE HISTO OF LEVEL LL DO II = 0, 8 OUTPAR(II) = SECPAR(II) ENDDO OUTPAR( 9) = GEN OUTPAR(10) = ALEVEL OUTPAR(13) = WEIGHT C TAKE INTO ACCOUNT THE CORRECT REST MAS OF HADRON OR NUCLEUS EDEP = ( SECPAR(1) * PAMA(NINT(SECPAR(0))) * - RESTMS(NINT(SECPAR(0))) ) * WEIGHT IF ( DEBUG ) WRITE(MDEBUG,*) 'TSTACK: THICKH=',THICKH CALL AUGERDEPFIL( EDEP,LL,0 ) ELSEIF ( THICKH .LT. THCKOB(LL) ) THEN RETURN ENDIF ENDDO #endif RETURN ENDIF #endif #if __CHARM__ ELSEIF ( SECPAR(0) .GE. 116.D0 .AND. SECPAR(0) .LE. 195.D0 ) THEN C ---CHARMED (OR BOTTOM) PARTICLE--- IF ( (SECPAR(1)-1.D0)*PAMA(NINT(SECPAR(0))) .LT. ELCUT(1) ) THEN IF ( DEBUG ) WRITE(MDEBUG,*) * 'TSTACK: PARTICLE BELOW ENERGY CUT' INT_ICOUNT = INT_ICOUNT - 1 IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT C ADD TO THE HADRON ENERGY DEPOSIT DLONG(LHEIGH,7) = DLONG(LHEIGH,7) * + ( SECPAR(1) * PAMA(NINT(SECPAR(0))) #if __THIN__ * - RESTMS(NINT(SECPAR(0))) )*WEIGHT #else * - RESTMS(NINT(SECPAR(0))) ) #endif ENDIF #if __AUGERHIST__ IF ( DEBUG ) WRITE(MDEBUG,2) (SECPAR(II),II=0,9) DO LL = 1, NOBSLV IF ( THICKH .GE. THCKOB(LL) .AND. * THICKH .LT. THCKOB(LL)+SAMPTH ) THEN C THICKH IS WITHIN 1 G/CM^2 BELOW OBSLEV(LL) C BRING THE ENERGY BELOW CUT TO THE HISTO OF LEVEL LL DO II = 0, 8 OUTPAR(II) = SECPAR(II) ENDDO OUTPAR( 9) = GEN OUTPAR(10) = ALEVEL OUTPAR(13) = WEIGHT C TAKE INTO ACCOUNT THE CORRECT REST MAS OF HADRON OR NUCLEUS EDEP = ( SECPAR(1) * PAMA(NINT(SECPAR(0))) * - RESTMS(NINT(SECPAR(0))) ) * WEIGHT IF ( DEBUG ) WRITE(MDEBUG,*) 'TSTACK: THICKH=',THICKH CALL AUGERDEPFIL( EDEP,LL,0 ) ELSEIF ( THICKH .LT. THCKOB(LL) ) THEN RETURN ENDIF ENDDO #endif RETURN #if __PARALLEL__ #if __CONEX__ ELSE #else ELSEIF ( (SECPAR(1) - 1.D0)*PAMA(NINT(SECPAR(0))) * .GT. ECTCUT ) THEN #endif C FLAG ECUT PARTICLES FOR OUTPUT TO SPECIAL FILE SECPAR(39) = 1.D0 #endif ENDIF #endif ELSEIF ( SECPAR(0) .GE. 200.D0 ) THEN C ---NUCLEI---, CUTTED IF ENERGY/NUCLEON BELOW CUT IF ( (SECPAR(1)-1.D0)*PAMA(NINT(SECPAR(0))) * .LT. ELCUT(1)*NINT(SECPAR(0)/100.D0) ) THEN IF ( DEBUG ) WRITE(MDEBUG,*) * 'TSTACK: PARTICLE BELOW ENERGY CUT' INT_ICOUNT = INT_ICOUNT - 1 IF ( LLONGI ) THEN C ADD KINETIC ENERGY TO LONGITUDINAL ENERGY DEPOSIT DLONG(LHEIGH,7) = DLONG(LHEIGH,7) * + ( SECPAR(1)*PAMA(NINT(SECPAR(0))) #if __THIN__ * - RESTMS(NINT(SECPAR(0))) )*WEIGHT #else * - RESTMS(NINT(SECPAR(0))) ) #endif ENDIF #if __AUGERHIST__ IF ( DEBUG ) WRITE(MDEBUG,2) (SECPAR(II),II=0,9) DO LL = 1, NOBSLV IF ( THICKH .GE. THCKOB(LL) .AND. * THICKH .LT. THCKOB(LL)+SAMPTH ) THEN C THICKH IS WITHIN 1 G/CM^2 BELOW OBSLEV(LL) C BRING THE ENERGY BELOW CUT TO THE HISTO OF LEVEL LL DO II = 0, 8 OUTPAR(II) = SECPAR(II) ENDDO OUTPAR( 9) = GEN OUTPAR(10) = ALEVEL OUTPAR(13) = WEIGHT C TAKE INTO ACCOUNT THE REST MASS EDEP = ( SECPAR(1) * PAMA(NINT(SECPAR(0))) * - RESTMS(NINT(SECPAR(0))) ) * WEIGHT IF ( DEBUG ) WRITE(MDEBUG,*) 'TSTACK: THICKH=',THICKH CALL AUGERDEPFIL( EDEP,LL,0 ) ELSEIF ( THICKH .LT. THCKOB(LL) ) THEN RETURN ENDIF ENDDO #endif RETURN #if __PARALLEL__ #if __CONEX__ ELSE #else ELSEIF ( (SECPAR(1) - 1.D0)*PAMA(NINT(SECPAR(0))) * .GT. ECTCUT ) THEN #endif C FLAG ECUT PARTICLES FOR OUTPUT TO SPECIAL FILE SECPAR(39) = 1.D0 #endif ENDIF #if __FLUKA__ ELSEIF ( SECPAR(0) .EQ. 25.D0 ) THEN C ---ANTI-NEUTRONS--- (WITH MIN CUT OF 50 MEV) ANCUT = MAX( ELCUT(1), 0.05D0 ) IF ( (SECPAR(1)-1.D0)*PAMA(25) .LT. ANCUT ) THEN IF ( DEBUG ) WRITE(MDEBUG,*) * 'TSTACK: PARTICLE BELOW ENERGY CUT' INT_ICOUNT = INT_ICOUNT - 1 IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT C IN CASE OF NUCLEONS TAKE ONLY KINETIC ENERGY C IN CASE OF ANTINUCLEONS TAKE RELEASABLE ENERGY DLONG(LHEIGH,7) = DLONG(LHEIGH,7) #if __THIN__ * + ( SECPAR(1)*PAMA(25) - RESTMS(25) ) * WEIGHT #else * + ( SECPAR(1) * PAMA(25) - RESTMS(25) ) #endif ENDIF #if __AUGERHIST__ IF ( DEBUG ) WRITE(MDEBUG,2) (SECPAR(II),II=0,9) DO LL = 1, NOBSLV IF ( THICKH .GE. THCKOB(LL) .AND. * THICKH .LT. THCKOB(LL)+SAMPTH ) THEN C THICKH IS WITHIN 1 G/CM^2 BELOW OBSLEV(LL) C BRING THE ENERGY BELOW CUT TO THE HISTO OF LEVEL LL DO II = 0, 8 OUTPAR(II) = SECPAR(II) ENDDO OUTPAR( 9) = GEN OUTPAR(10) = ALEVEL OUTPAR(13) = WEIGHT C TAKE INTO ACCOUNT THE CORRECT REST MAS OF ANTI-NEUTRON EDEP = ( SECPAR(1) * PAMA(25) - RESTMS(25) ) * WEIGHT IF ( DEBUG ) WRITE(MDEBUG,*) 'TSTACK: THICKH=',THICKH CALL AUGERDEPFIL( EDEP,LL,0 ) ELSEIF ( THICKH .LT. THCKOB(LL) ) THEN RETURN ENDIF ENDDO #endif RETURN #if __PARALLEL__ #if __CONEX__ ELSE #else ELSEIF ( (SECPAR(1) - 1.D0)*PAMA(25) .GT. ECTCUT ) THEN #endif C FLAG ECUT PARTICLES FOR OUTPUT TO SPECIAL FILE SECPAR(39) = 1.D0 #endif ENDIF #endif ELSE C ---HADRONS--- IF ( (SECPAR(1)-1.D0)*PAMA(NINT(SECPAR(0))) .LT. ELCUT(1) ) THEN IF ( DEBUG ) WRITE(MDEBUG,*) * 'TSTACK: PARTICLE BELOW ENERGY CUT' INT_ICOUNT = INT_ICOUNT - 1 IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT C IN CASE OF NUCLEONS TAKE ONLY KINETIC ENERGY C IN CASE OF ANTINUCLEONS TAKE RELEASABLE ENERGY IF ( NINT(SECPAR(0)) .EQ. 8 .OR. * NINT(SECPAR(0)) .EQ. 9 .OR. * NINT(SECPAR(0)) .EQ. 11 .OR. * NINT(SECPAR(0)) .EQ. 12 ) THEN FAC1 = 0.25D0 FAC2 = 0.75D0 ELSEIF ( NINT(SECPAR(0)) .EQ. 10 .OR. * NINT(SECPAR(0)) .EQ. 16 ) THEN FAC1 = 0.5D0 FAC2 = 0.5D0 ELSE FAC1 = 1.D0 FAC2 = 0.D0 ENDIF C ADD TO THE HADRON ENERGY DEPOSIT DLONG(LHEIGH,7) = DLONG(LHEIGH,7) * + ( SECPAR(1) * PAMA(NINT(SECPAR(0))) #if __THIN__ * - RESTMS(NINT(SECPAR(0))) )*WEIGHT*FAC1 #else * - RESTMS(NINT(SECPAR(0))) )*FAC1 #endif C ADD TO THE NEUTRINO DEPOSIT DLONG(LHEIGH,8) = DLONG(LHEIGH,8) * + ( SECPAR(1) * PAMA(NINT(SECPAR(0))) #if __THIN__ * - RESTMS(NINT(SECPAR(0))) )*WEIGHT*FAC2 #else * - RESTMS(NINT(SECPAR(0))) )*FAC2 #endif ENDIF #if __AUGERHIST__ IF ( DEBUG ) WRITE(MDEBUG,2) (SECPAR(II),II=0,9) DO LL = 1, NOBSLV IF ( THICKH .GE. THCKOB(LL) .AND. * THICKH .LT. THCKOB(LL)+SAMPTH ) THEN C THICKH IS WITHIN 1 G/CM^2 BELOW OBSLEV(LL) C BRING THE ENERGY BELOW CUT TO THE HISTO OF LEVEL LL DO II = 0, 8 OUTPAR(II) = SECPAR(II) ENDDO OUTPAR( 9) = GEN OUTPAR(10) = ALEVEL OUTPAR(13) = WEIGHT C TAKE INTO ACCOUNT THE CORRECT REST MAS OF HADRON OR NUCLEUS EDEP = ( SECPAR(1) * PAMA(NINT(SECPAR(0))) * - RESTMS(NINT(SECPAR(0))) ) * WEIGHT IF ( DEBUG ) WRITE(MDEBUG,*) 'TSTACK: THICKH=',THICKH CALL AUGERDEPFIL( EDEP,LL,0 ) ELSEIF ( THICKH .LT. THCKOB(LL) ) THEN RETURN ENDIF ENDDO #endif RETURN #if __PARALLEL__ #if __CONEX__ ELSE #else ELSEIF ( (SECPAR(1) - 1.D0)*PAMA(NINT(SECPAR(0))) * .GT. ECTCUT ) THEN #endif C FLAG ECUT PARTICLES FOR OUTPUT TO SPECIAL FILE SECPAR(39) = 1.D0 #endif ENDIF ENDIF #if __ICECUBE1__ C iNCREASE NINTERSTING IF THE CURRENT SECPAR IS INTERESTING IF ( .NOT.( SECPAR(0) .EQ. 1 .OR. SECPAR(0) .EQ. 2 .OR. * SECPAR(0) .EQ. 3 .OR. SECPAR(0) .EQ. 5 .OR. * SECPAR(0) .EQ. 6 .OR. SECPAR(0) .EQ. 7 .OR. * SECPAR(0) .EQ. 16 .OR. SECPAR(0) .EQ. 17 .OR. * SECPAR(0) .EQ. 18 ) .AND. * SECPAR(1)*PAMA(NINT(SECPAR(0))) .GE. energy_interesting ) THEN C NEUTRINO PROGENITOR n_interesting = n_interesting + 1 ELSEIF ( SECPAR(0) .GE. 66 .AND. SECPAR(0) .LE. 69 * .AND. SECPAR(1) .GE. energy_interesting ) THEN C NEUTRINO n_interesting = n_interesting + 1 n_interesting_nu = n_interesting_nu + 1 ENDIF #endif C WRITE PARTICLE ABOVE CUT TO INTERMEDIATE STACK DO I = 0, MAXLEN STACKINT(I,INT_ICOUNT) = SECPAR(I) ENDDO RETURN END *-- Author : Johannes Knapp, IEKP U Karlsruhe 26/01/1997 C======================================================================= SUBROUTINE TSTEND C----------------------------------------------------------------------- C T(O) ST(ACK) END (OF REACTION) C C MOVE INTERMEDIATE REACTION STACK TO THE REAL STACK C AND PERFORM THINNING, IF SELECTED. C THIS SUBROUTINE IS CALLED FROM AAMAIN, BOX3, AND PIGEN. C----------------------------------------------------------------------- IMPLICIT NONE #define __BUFFSINC__ #define __MUPARTINC__ #define __PAMINC__ #define __PARPARINC__ #define __PARPAEINC__ #define __RANDPAINC__ #define __REJECTINC__ #define __RUNPARINC__ #define __THNVARINC__ #define __STACKFINC__ #if __MULTITHIN__ #define __MULTHININC__ #endif #include "corsika.h" #if __THIN__ || __MULTITHIN__ DOUBLE PRECISION ETOTAL,ETOTAL2,THNMRK,WT_OLD,ETOTALN LOGICAL LABOVE #endif INTEGER I,K #if __MULTITHIN__ INTEGER J #endif SAVE C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,1) INT_ICOUNT 1 FORMAT(' TSTEND: TRANSFER INTERNAL REACTION STACK', * ' WITH ',I6,' PARTICLES ') IF ( INT_ICOUNT .LE. 0 ) RETURN #if __THIN__ ETOTAL = 0.D0 ETOTAL2 = 0.D0 ETOTALN = 0.D0 #if __CONEX__ C ONLY PARTICLES NOT FROM CE SAMPLING CAN BE COUNTED FOR THINNING C AT THIS POINT STILL ALL GENERATION SHOULD BE THE SAME, C SO TAKE THAT OF PARTICLE 1 AS REFERENCE IF ( STACKINT(9,1) .LT. 5000.D0 ) THEN #endif C AT THIS POINT STILL ALL WEIGHTS SHOULD BE THE SAME, C SO TAKE THAT OF PARTICLE 1 AS REFERENCE WT_OLD = STACKINT(13,1) IF ( INT_ICOUNT .GT. 1 ) THEN C WE HAVE MORE THAN ONE PARTICLE, PERFORM THINNING DO K = 1, INT_ICOUNT IF ( PAMA(NINT(STACKINT(0,K))) .LE. 0.D0 ) THEN C WE HAVE A PARTICLE WITH ZERO MASS (GAMMA OR NEUTRINO) EEPP(K) = STACKINT(1,K) ELSE EEPP(K) = STACKINT(1,K)*PAMA(NINT( STACKINT(0,K) )) * - RESTMS(NINT( STACKINT(0,K) )) ENDIF #if __PARALLEL__ C ONLY PARTICLES NOT CUT CAN BE COUNTED FOR THINNING IF ( STACKINT(39,K) .LE. 0.D0 ) THEN #endif C ADD UP ENERGY OF THOSE PARTICLES, WHICH MAY BE THINNED ETOTAL2 = ETOTAL2 + EEPP(K) IF ( EEPP(K) .LT. ETHINNG ) THEN ETOTAL = ETOTAL + EEPP(K) ENDIF #if __PARALLEL__ ELSE C CUT PARTICLES NOT USED FOR THINNING EEPP(K) = 2.D0 * ETHINNG ENDIF #endif ENDDO C FIND WHICH METHOD OF THINNING WILL BE DONE IF ( ETOTAL2 .GT. ETHINNG ) THEN LABOVE = .TRUE. ELSE LABOVE = .FALSE. ENDIF C GET RANDOM NUMBER CALL RMMARD( RD,1,1 ) IF ( LABOVE ) THEN C COMPUTE LOWER LIMIT FOR ENERGY IF WEIGHT SHOULD STAY BELOW WMAX ELIM = ETHINNG * WT_OLD/WMAX THNMRK = RD(1) * ETHINNG IF ( DEBUG ) WRITE(MDEBUG,*) 'TSTEND: THNMRK=',THNMRK C ETOTAL2 < ETHINNG MEANS THAT PRIMARY WAS ALREADY BELOW ETHINNG C ALL SECONDARIES MUST ALSO BE BELOW ETHINNG: ETOTAL = ETOTAL2 ELSE C LOWER LIMIT FOR ENERGY IF WEIGHT SHOULD STAY BELOW WMAX ELIM = ETOTAL * WT_OLD/WMAX C RECALCULATE ETOTAL FOR PARTICLES WITH NOT TOO LOW ENERGIES IF ( WLIM ) THEN ETOTALN = 0.D0 DO K = 1, INT_ICOUNT C OF THOSE PARTICLES, WHICH MAY BE THINNED IF ( EEPP(K).LT.ETHINNG .AND. EEPP(K).GT.ELIM ) THEN ETOTALN = ETOTALN + EEPP(K) ENDIF C THIS PART IS ONLY APPROXIMATELY CORRECT: WE CALCULATE ELIM FROM C ETOTAL BUT THEN DETERMINE, USING ELIM, A NEW ETOTALN. C THIS LEADS TO WEIGHTS THAT ARE SLIGHTLY LOWER THAN THEY COULD BE C WHICH WILL PROBABLY CORRECTED DURING THE NEXT INTERACTION. ENDDO ELSE ETOTALN = ETOTAL ENDIF THNMRK = RD(1) * ETOTALN IF ( DEBUG ) WRITE(MDEBUG,*) 'TSTEND: TOTAL ENERGY=',ETOTAL, * ETOTALN,' RANDOM NUMBER=',SNGL(RD(1)) ENDIF C NOW FIND PARTICLES TO FOLLOW FURTHER DOWN THE LINE DO K = 1, INT_ICOUNT IF ( EEPP(K) .GE. ETHINNG .OR. EEPP(K) .LE. ELIM ) THEN C ENERGY IS ABOVE THE THINNING LEVEL, KEEP PARTICLE C OR ENERGY IS BELOW THE LIMIT DEDUCED FROM MAXIMUM TOLERABLE WEIGHT DO I = 0, MAXLEN SECPAR(I) = STACKINT(I,K) STACKINT(I,K) = 0.D0 ENDDO CALL TSTOUT ELSE C ENERGY IS LOWER THAN THINNING LEVEL, SELECT PARTICLES AT RANDOM THNMRK = THNMRK - EEPP(K) IF ( DEBUG ) WRITE(MDEBUG,12) K,EEPP(K),THNMRK 12 FORMAT(' TSTEND: K,EEPP,THNMRK=',I7,1X,1P,2E17.7) C WE MUST HAVE A PROCESS WITH MORE THAN ONE SECONDARIES IF ( THNMRK .LE. 0.D0 ) THEN C KEEP THINNED PARTICLE AND RESET THINMARKER THNMRK C RESCALE WEIGHT IF ( LABOVE ) THEN THNMRK = THNMRK + ETHINNG STACKINT(13,K) = STACKINT(13,K) * ETHINNG / EEPP(K) ELSE THNMRK = THNMRK + ETOTALN STACKINT(13,K) = STACKINT(13,K) * ETOTALN / EEPP(K) ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) * 'TSTEND: NEW WEIGHT',STACKINT(13,K) DO I = 0, MAXLEN SECPAR(I) = STACKINT(I,K) STACKINT(I,K) = 0.D0 ENDDO CALL TSTOUT ELSE C DISCARD PARTICLE C TAKE CARE FOR DISCARDED MUONS WITH ADDITIONAL MUON INFO IF ( K .EQ. INT_ICOUNT .AND. * (STACKINT(0,K).EQ.5.D0 .OR. STACKINT(0,K).EQ.6.D0) ) * FMUORG = .FALSE. ENDIF ENDIF ENDDO ELSE C WE HAVE ONLY ONE SECONDARY PARTCLE, KEEP IT DO I = 0, MAXLEN SECPAR(I) = STACKINT(I,1) STACKINT(I,1) = 0.D0 ENDDO CALL TSTOUT ENDIF #if __CONEX__ ELSE C PUT SAMPLED PARTICLES FROM INTERMEDIATE STACK TO REAL STACK DO K = 1, INT_ICOUNT DO I = 0, MAXLEN SECPAR(I) = STACKINT(I,K) STACKINT(I,K) = 0.D0 ENDDO CALL TSTOUT ENDDO ENDIF #endif #endif #if __MULTITHIN__ IF ( NMTHIN .GT. 0 ) THEN DO J = 1, NMTHIN C AT THIS POINT STILL ALL WEIGHTS SHOULD BE THE SAME, C SO TAKE THAT OF PARTICLE 1 AS REFERENCE WT_OLD = STACKINT(40+J,1) C SKIP PARTCLES WITHOUT WEIGHT BY EARLIER THINNING IF ( WT_OLD .GT. 0.D0 ) THEN IF ( INT_ICOUNT .GT. 1 ) THEN C WE HAVE MORE THAN ONE SECONDARY PARTICLE, TREAT THINNING ETOTAL = 0.D0 ETOTAL2 = 0.D0 ETOTALN = 0.D0 DO K = 1, INT_ICOUNT IF ( PAMA(NINT( STACKINT(0,K) )) .LE. 0.D0 ) THEN C WE HAVE A PARTICLE WITH ZERO MASS (GAMMA OR NEUTRINO) EEPP(K) = STACKINT(1,K) ELSE EEPP(K) = STACKINT(1,K)*PAMA(NINT( STACKINT(0,K) )) * - RESTMS(NINT( STACKINT(0,K) )) ENDIF #if __PARALLEL__ C ONLY PARTICLES NOT CUT CAN BE COUNTED FOR THINNING IF ( STACKINT(39,K) .LE. 0.D0 ) THEN #endif ETOTAL2 = ETOTAL2 + EEPP(K) C ADD UP ENERGY OF THOSE PARTICLES, WHICH MAY BE THINNED IF ( EEPP(K) .LT. EMTHNNG(J) ) THEN ETOTAL = ETOTAL + EEPP(K) ENDIF #if __PARALLEL__ ELSE C CUT PARTICLES NOT USED FOR THINNING EEPP(K) = 2.D0 * EMTHNNG(J) ENDIF #endif ENDDO C FIND WHICH METHOD OF THINNING WILL BE DONE IF ( ETOTAL2 .GT. EMTHNNG(J) ) THEN LABOVE = .TRUE. ELSE LABOVE = .FALSE. ENDIF C WE TAKE FOR EACH MODE ITS OWN RANDOM SEQUENCE CALL RMMARD( RD,1,J+10 ) IF ( LABOVE ) THEN C COMPUTE LOWER LIMIT FOR ENERGY IF WEIGHT SHOULD STAY BELOW WMAX ELIM = EMTHNNG(J) * WT_OLD/WMMAX(J) THNMRK = RD(1) * EMTHNNG(J) IF ( DEBUG ) WRITE(MDEBUG,*) 'TSTEND: THNMRK=',THNMRK C ETOTAL2 < ETHINNG MEANS THAT PRIMARY WAS ALREADY BELOW ETHINNG C ALL SECONDARIES MUST ALSO BE BELOW ETHINNG: ETOTAL = ETOTAL2 ELSE C LOWER LIMIT FOR ENERGY IF WEIGHT SHOULD STAY BELOW WMAX ELIM = ETOTAL * WT_OLD/WMMAX(J) C WEIGHT LIMITATION IS ACTIVE ETOTALN = 0.D0 DO K = 1, INT_ICOUNT C RECALCULATE ETOTAL FOR PARTICLES WITH NOT TOO LOW ENERGIES C OF THOSE PARTICLES, WHICH MAY BE THINNED IF ( EEPP(K) .LT. EMTHNNG(J) .AND. * EEPP(K) .GT. ELIM ) THEN ETOTALN = ETOTALN + EEPP(K) ENDIF C THIS PART IS ONLY APPROXIMATELY CORRECT: WE CALCULATE ELIM FROM C ETOTAL BUT THEN DETERMINE, USING ELIM, A NEW ETOTALN. C THIS LEADS TO WEIGHTS THAT ARE SLIGHTLY LOWER THAN THEY COULD BE C WHICH WILL PROBABLY BE CORRECTED DURING THE NEXT INTERACTION. ENDDO THNMRK = RD(1) * ETOTALN IF ( DEBUG ) WRITE(MDEBUG,*) 'TSTEND: TOTAL ENERGY=', * ETOTAL,ETOTALN,' RANDOM NUMBER=',SNGL(RD(1)) ENDIF C NOW FIND PARTICLES TO FOLLOW FURTHER DOWN THE LINE DO K = 1, INT_ICOUNT IF ( EEPP(K).GE.EMTHNNG(J) .OR. EEPP(K).LE.ELIM ) THEN C ENERGY IS ABOVE THE THINNING LEVEL, KEEP PARTICLE C OR ENERGY IS BELOW THE LIMIT DEDUCED FROM MAXIMUM TOLERABLE WEIGHT C KEEP WEIGHT UNCHANGED c STACKINT(40+J,K) = STACKINT(40+J,1) STACKINT(40+J,K) = WT_OLD ELSE C ENERGY IS LOWER THAN THINNING LEVEL, SELECT PARTICLES AT RANDOM THNMRK = THNMRK - EEPP(K) IF ( DEBUG ) WRITE(MDEBUG,12) K,EEPP(K),THNMRK 12 FORMAT(' TSTEND: K,EEPP,THNMRK=',I7,1X,1P,2E17.7) C WE MUST HAVE A PROCESS WITH MORE THAN ONE SECONDARY IF ( THNMRK .LE. 0.D0 ) THEN C KEEP THINNED PARTICLE AND RESET THINMARKER THNMRK C RESCALE WEIGHT IF ( LABOVE ) THEN THNMRK = THNMRK + EMTHNNG(J) STACKINT(40+J,K) = STACKINT(40+J,K) * * EMTHNNG(J) / EEPP(K) ELSE THNMRK = THNMRK + ETOTALN STACKINT(40+J,K) = STACKINT(40+J,K) * * ETOTALN / EEPP(K) ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) * 'TSTEND: NEW WEIGHT',STACKINT(13,K) ELSE C DISCARD PARTICLE BY SETTING WEIGHT TO NEGATIVE WEIGHT STACKINT(40+J,K) = -STACKINT(40+J,K) ENDIF ENDIF ENDDO ENDIF ENDIF ENDDO ENDIF #endif #if !__THIN__ C PUT ALL PARTICLES FROM INTERMEDIATE STACK TO REAL STACK DO K = 1, INT_ICOUNT DO I = 0, MAXLEN SECPAR(I) = STACKINT(I,K) STACKINT(I,K) = 0.D0 ENDDO CALL TSTOUT ENDDO #if __ICECUBE1__ still_interesting = n_interesting.GT.0 #endif #endif #if __PARALLEL__ C IF NOT IN EM CASCADE OR MORE THAN ONE PARTICLE TO BE SAVED IF ( .NOT. ( FECTEGS .OR. JCOUNT.EQ.2 ) ) THEN C CLOSE FILE FOR ECUT PARTICLE OUTPUT AFTER FIRST INTERACTION NOT C TO WAIT UNTIL THE SHOWER IS FINISHED TO BE ABLE TO START A NEW JOB C (NO PARTICLE WITH E>ECTCUT CAN BE CREATED AFTER THE FIRST INTERACTION) IF ( FECTOUT .AND. JCOUNT.GT.1 ) THEN C GROUP PARTICLE IN ECUT BY ENERGY TO REACH ECTMAX C AND SEND INFORMATION TO OUTSIDE CALL SENDCUT IF ( DEBUG ) * WRITE(MDEBUG,*) 'TSTEND: ECUT PARTICLE OUTPUT SAVED' FECTOUT = .FALSE. ELSE FECTOUT = .FALSE. ENDIF ENDIF #endif RETURN END *-- Author : Johannes Knapp, IEKP U Karlsruhe 26/01/1997 C======================================================================= SUBROUTINE TSTOUT C----------------------------------------------------------------------- C T(O) ST(ACK) OUT C C MAKE OUTPUT AFTER ONE INTERACTION HAS FINISHED C ADDS PARTICLE TO STACK AND WRITES IT TO DISK IF NECESSARY. C THIS SUBROUTINE IS CALLED FROM TSTEND #if __PARALLEL__ C AND SHOWER. #endif C----------------------------------------------------------------------- IMPLICIT NONE #define __BUFFSINC__ #define __ETHMAPINC__ #define __PAMINC__ #define __PARPARINC__ #define __PARPAEINC__ #if __PARALLEL__ #define __RANDPAINC__ #endif #define __RUNPARINC__ #define __STACKFINC__ #include "corsika.h" INTEGER I,ISTK,J SAVE DATA ISTK / MAXSTK / #if __DYNSTACK__ INTEGER dyn_return #endif C----------------------------------------------------------------------- #if __THIN__ #if __PARALLEL__ IF ( SECPAR(39) .LE. 0.D0 ) THEN #endif IF ( DEBUG ) WRITE(MDEBUG,666) ICOUNT,(SECPAR(J),J=0,9),SECPAR(13) #if __PARALLEL__ * ,SECPAR(39) ELSE IF ( DEBUG ) WRITE(MDEBUG,667) JCOUNT,(SECPAR(J),J=0,9),SECPAR(13) * ,SECPAR(39) ENDIF 666 FORMAT(' TSTOUT I:',I7,1X,1P,9E11.3,0P,F10.0,1P,E10.3,0P,F5.0) 667 FORMAT(' TSTOUT J:',I7,1X,1P,9E11.3,0P,F10.0,1P,E10.3,0P,F5.0) #else 666 FORMAT(' TSTOUT:',I7,1X,1P,9E11.3,0P,F10.0,1P,E10.3) #endif #else #if __PARALLEL__ IF ( SECPAR(39) .LE. 0.D0 ) THEN IF ( DEBUG ) WRITE(MDEBUG,666) ICOUNT,(SECPAR(J),J=0,9) * ,SECPAR(39) ELSE IF ( DEBUG ) WRITE(MDEBUG,667) JCOUNT,(SECPAR(J),J=0,9) * ,SECPAR(39) ENDIF 666 FORMAT(' TSTOUT I:',I7,1X,1P,9E11.3,0P,F10.0,F5.0) 667 FORMAT(' TSTOUT J:',I7,1X,1P,9E11.3,0P,F10.0,F5.0) #else IF ( DEBUG ) THEN WRITE(MDEBUG,666) ICOUNT,(SECPAR(J),J=0,9) 666 FORMAT(' TSTOUT:',I7,1X,1P,9E11.3,0P,F10.0) #if __MULTITHIN__ WRITE(MDEBUG,31) (SECPAR(I),I=41,46) 31 FORMAT(' TSTOUT: 41-46: ',1P,6E11.3) #endif ENDIF #endif #endif #if __PARALLEL__ C CHECK TO SEE IF THIS PARTICLE IS DUE TO BE WRITTEN OUT TO THE C ECUT PARTICLE FILE. IF FECTOUT IS FALSE, PARTICLE IS WRITTEN C IN THE 2ND STACK. IF ( SECPAR(39) .GT. 0.D0 ) THEN DO I = 0, 18 CUTPAR(I) = SECPAR(I) ENDDO #if __MULTITHIN__ DO I = 41, 46 CUTPAR(I) = SECPAR(I) ENDDO #endif C GIVE NEW SEED FOR THE 6TH SEQUENCE OF RANDOM NUMBERS FOR THIS PARTICLE CALL RMMARD( RD,1,6 ) CUTPAR(18) = INT( RD(1)*9.D8 ) IF ( MSTACKPJ .GE. ISTK ) THEN CALL FSTACKJO(1) WRITE(MEXSTJ,REC=NOURECJ+1) (STACKJ(I),I= 1,ISTK/2) WRITE(MEXSTJ,REC=NOURECJ+2) (STACKJ(I),I=ISTK/2+1,ISTK ) NOURECJ = NOURECJ + 2 NSHIFTJ = NSHIFTJ + 2 MSTACKPJ = 0 ENDIF NTOJ = NTOJ + 1 JCOUNT = JCOUNT + 1 DO J = 0, 18 STACKJ(MSTACKPJ+J+1) = CUTPAR(J) ENDDO #if __MULTITHIN__ DO J = 19, MAXLEN-6 STACKJ(MSTACKPJ+J+1) = 0.D0 ENDDO DO J = 41, 46 STACKJ(MSTACKPJ+J+1) = CUTPAR(J) ENDDO #else DO J = 19, MAXLEN STACKJ(MSTACKPJ+J+1) = 0.D0 ENDDO #endif MSTACKPJ = MSTACKPJ + MAXLEN + 1 C COUNT ENERGY IN 2ND STACK BUT WITHOUT WEIGHT BECAUSE ONLY C PARTICLE ENERGY IS IMPORTANT HERE IF ( PAMA(NINT( CUTPAR(0) )) .LE. 0.D0 ) THEN ELEFTJ = ELEFTJ + CUTPAR(1) ELSE ELEFTJ = ELEFTJ + (CUTPAR(1)-1.D0)*PAMA(NINT(CUTPAR(0))) ENDIF ELSE C PARTICLE IS BELOW ECUT, CONTINUE #endif #if !__ICECUBE1__ && !__DYNSTACK__ IF ( MSTACKP .GE. ISTK ) THEN #if __PARALLEL__ CALL FSTACKO(1) #endif WRITE(MEXST,REC=NOUREC+1) (STACKI(I),I= 1,ISTK/2) WRITE(MEXST,REC=NOUREC+2) (STACKI(I),I=ISTK/2+1,ISTK ) NOUREC = NOUREC + 2 NOURECMAX = MAX( NOUREC,NOURECMAX ) NSHIFT = NSHIFT + 2 MSTACKP = 0 ENDIF #endif NTO = NTO + 1 ICOUNT = ICOUNT + 1 #if __ICECUBE1__ C PUT PARTICLE ON THE FRONT OF THE QUEUE IF C A) THE SHOWER ALREADY CONTAINS HIGH-ENERGY NEUTRINOS, OR C B) THE PARTICLE IS CAPABLE OF CREATING A HIGH-ENERGY NEUTRINO IF ( ( n_interesting_nu .GT. 0 ) .OR. ! THIS SHOWER ALREADY CONTAINS * ( .NOT.(SECPAR(0) .EQ. 1 .OR. ! THIS PARTICLE IS CAPABLE OF CREATE * SECPAR(0) .EQ. 2 .OR. SECPAR(0) .EQ. 3 .OR. * SECPAR(0) .EQ. 5 .OR. SECPAR(0) .EQ. 6 .OR. * SECPAR(0) .EQ. 7 .OR. SECPAR(0) .EQ. 16 .OR. * SECPAR(0) .EQ. 17 .OR. SECPAR(0) .EQ. 18 ) .AND. * SECPAR(1)*PAMA(NINT(SECPAR(0))) .GE. energy_interesting ) ) THEN call ringbuffer_put( SECPAR, MAXLEN, 0 ) ELSE C PUT ALL OTHERS AT THE BACK call ringbuffer_put( SECPAR, MAXLEN, 1 ) ENDIF #elif __DYNSTACK__ call dynstack_tstout(SECPAR, (1+MAXLEN)*SIZEOF(SECPAR(0)), * dyn_return) #else DO J = 0, MAXLEN STACKI(MSTACKP+J+1) = SECPAR(J) ENDDO MSTACKP = MSTACKP + MAXLEN + 1 #endif IF ( PAMA(NINT( SECPAR(0) )) .LE. 0.D0 ) THEN #if __THIN__ ELEFT = ELEFT + SECPAR(1) * SECPAR(13) ELSE ELEFT = ELEFT + SECPAR(1) * PAMA(NINT(SECPAR(0))) * SECPAR(13) #else ELEFT = ELEFT + SECPAR(1) ELSE ELEFT = ELEFT + SECPAR(1) * PAMA(NINT( SECPAR(0) )) #endif ENDIF #if __PARALLEL__ ENDIF #endif RETURN END #if __CURVED__ *-- Author : F. SCHROEDER UNI WUPPERTAL 17/11/1998 C======================================================================= SUBROUTINE UPDATC( IPASC,FLAGMU ) C----------------------------------------------------------------------- C UPDAT(ES PARTICLE PARAMETERS IN A) C(URVED ATMOSPHERE) C C IN THE CASE THE HORIZONTAL COMPONENT OF THE TRACK IS TO LONG (> 20KM) C THE PARTICLE TRACK IS CHOPPED IN SEVERAL SHORTER TRACKS. C FOR EACH OF THESE CHOPPED TRACKS SUBR. UPDATE IS CALLED. C THIS SUBROUTINE IS CALLED FROM AAMAIN, BOX3, AND MUTRAC. C ARGUMENTS: C IPASC = 0 TRANSPORT LEADS TO END OF RANGE OF PARTICLE C 1 TRANSPORT LEADS TO OBSERVATION LEVEL C FLAGMU = FLAG INDICATING THE TRACKING OF MUONS C----------------------------------------------------------------------- IMPLICIT NONE #define __ATMOSINC__ #define __ATMOS2INC__ #define __GENERINC__ #define __IRETINC__ #define __LONGIINC__ #define __MAGNETINC__ #define __MUMULTINC__ #define __OBSPARINC__ #define __PAMINC__ #define __PARPARINC__ #define __PARPAEINC__ #define __RUNPARINC__ #define __TIMLIMINC__ #if __CERENKOV__ || __AUGCERLONG__ #define __CORFRAMINC__ #endif #if __PLOTSH2__ #define __PLOTSH2INC__ #endif #if __PARALLEL__ #define __STACKFINC__ #endif #include "corsika.h" DOUBLE PRECISION ARG,AUXIL,AUXILSQ,AUX2SQ,CHIC,CHIMAX,CHIN,CORR, * COSDIF,COSPHI,COSTHENEW,DSTEFF,SPEED,SPEED0, * EDEPB,EDEPN,EDEP1,EFRST,FAC1,FAC2,GAMMAOLD, * GAMMAN,HEIGH,HNEW,HOLD,HOLDM,PHICOR,PHIXNEW, * PHIYNEW,RADINV,SINDIF,SINPHI,SINTEA, * SINTHE,STEPLC,STEPLO,STEPT,THCKHN,THCKHO,THICK, * THICKHOLD,TRANS2,WORK,XNEW,XOLD,YNEW,YOLD, * HAPPOLD,XXXOLD,YYYOLD,XXX,YYY,TOLD,TNEW,PHI1,RRR EXTERNAL HEIGH,THICK INTEGER I,IL,IPASC,LPCT1,LPCT2,NCOUNT LOGICAL FLAGMU LOGICAL IRETC #if __CERENKOV__ || __AUGCERLONG__ DOUBLE PRECISION HNEWO #endif #if __SLANT__ DOUBLE PRECISION T1,T2,THCKSI INTEGER LBIN LOGICAL FLGLB EXTERNAL LBIN,THCKSI #endif #if __UPWARD__ DOUBLE PRECISION RHOF,PATH EXTERNAL RHOF #endif #if __PLOTSH__ && !__PLOTSH2__ REAL TRID,TRE,TRX1,TRY1,TRZ1,TRT1,TRX2,TRY2,TRZ2,TRT2 #endif #if __COASTUSERLIB__ #if __SLANT__ double precision T11 #endif 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 #if __PLOTSH__ || __PLOTSH2__ || __COASTUSERLIB__ LOGICAL LPLOTCNT #endif #if __PLOTSH2__ DOUBLE PRECISION WGHT #endif SAVE #if __PLOTSH2__ && !__THIN__ DATA WGHT / 1.D0 / #endif DATA NCOUNT / 0 / C----------------------------------------------------------------------- #if __THIN__ IF ( DEBUG ) WRITE(MDEBUG,457) (CURPAR(I),I=0,9),WEIGHT,FLAGMU, * COSTAP 457 FORMAT(' UPDATC: CURPAR=',1P,11E11.3,0P,/, * ' FLAGMU=',L2,' COSTAP=',1P,E11.3,0P) #else IF ( DEBUG ) WRITE(MDEBUG,457) (CURPAR(I),I=0,9),FLAGMU,COSTAP 457 FORMAT(' UPDATC: CURPAR=',1P,10E11.3,0P,/, * ' FLAGMU=',L2,' COSTAP=',1P,E11.3,0P) #endif C NOTE: ARG = PENETRATED MATTER THICKNESS HAS TO BE A CONSTANT C FOR THE WHOLE PARTICLE UPDATING C => LOOP OVER PIECES OF ARG (ALSO CONSTANTS FOR UPDATE) C START VALUES FOR LOOP OVER PENETRATED MATTER THICKNESS IRET2 = 0 C STORE THE THICKNES CHI TO BE TRANSPORTED CHIC = CHI ARG = CHI C STORE THE PATH LENGTH STEPL DO BE TRANSPORTED IF ( FLAGMU ) THEN STEPLC = STEPL ELSE STEPLC = 0.D0 ENDIF STEPLO = 0.D0 HNEW = H THCKHN = THICKH XNEW = X YNEW = Y TNEW = T IF ( COSTEA .NE. 1.D0 ) THEN C WE ARE AWAY FROM DETECOR C CALCULATE AZIMUTH ANGLE OF PARTICLE SEEN FROM DETECTOR IF ( Y .NE. 0.D0 .OR. X .NE. 0.D0 ) THEN PHI1 = ATAN2( Y, X ) ELSE PHI1 = 0.D0 ENDIF SINTEA = SQRT( (1.D0-COSTEA)*(1.D0+COSTEA) ) C HORIZONTAL DISTANCE OF PARTICLE TO DETECTOR RRR = ( HAPP + C(1) ) * SINTEA / COSTEA XXX = RRR * COS( PHI1 ) YYY = RRR * SIN( PHI1 ) ELSE C WE ARE IN THE DETECTOR SYSTEM AND NEED NO COORDINATE CALCULATION XXX = X YYY = Y ENDIF IF ( LLONGI ) THEN GAMMAOLD = GAMMA THICKHOLD = THICKH #if __SLANT__ FLGLB = .FALSE. T1 = THCKSI( XXX*STHCPH + YYY*STHSPH - HAPP*CTH + RLOFF ) #if __COASTUSERLIB__ T11 = T1 #endif LPCT1 = INT( T1*THSTPI + 1.D0 ) LPCT1 = MIN( LPCT1, NSTEP+1 ) #else LPCT1 = INT( THICKHOLD*THSTPI + 1.D0 ) LPCT1 = MIN( LPCT1, NSTEP ) #endif ENDIF #if __PLOTSH__ || __PLOTSH2__ || __COASTUSERLIB__ LPLOTCNT = .FALSE. #endif C CHOPPING OF TOTAL PATH LENGTH CHIC INTO SMALLER PIECES AND C TRANSPORT IN LOCAL PLANE SYSTEMS. STEP LENGTH LIMITATION DEPENDS ON C THICKNESS OF STARTING POINT. LOOP OVER ALL SMALL PIECES OF STEP 2 CONTINUE C SAVE OLD LOCAL HEIGHT FOR TRANSFORMATION AFTER UPDATE HOLD = HNEW XOLD = XNEW YOLD = YNEW TOLD = TNEW HAPPOLD = HAPP XXXOLD = XXX YYYOLD = YYY IF ( DEBUG ) WRITE(MDEBUG,*) 'UPDATC: CHIC,HOLD,THCKHN=', * SNGL(CHIC),SNGL(HOLD),SNGL(THCKHN) #if __PLOTSH__ || __PLOTSH2__ || __COASTUSERLIB__ C RECORD END OF INTERMEDIATE STEP (IF MORE THAN 1) IF ( LPLOTCNT ) THEN #endif #if __PLOTSH__ C END OF THE TRACKING STEP IF ( PLOTSH ) THEN TRX2 = X TRY2 = Y TRZ2 = HAPP TRT2 = T IF ( ITYPE .EQ. 5 .OR. ITYPE .EQ. 6 ) THEN WRITE(56) TRID,TRE,TRX1,TRY1,TRZ1,TRT1,TRX2,TRY2,TRZ2,TRT2 #if __THIN__ * ,WEIGHT #endif NPLMU = NPLMU + 1 ELSE WRITE(57) TRID,TRE,TRX1,TRY1,TRZ1,TRT1,TRX2,TRY2,TRZ2,TRT2 #if __THIN__ * ,WEIGHT #endif NPLHAD = NPLHAD + 1 ENDIF IF ( DEBUG ) THEN #if __THIN__ WRITE(MDEBUG,2552) TRID,TRE,TRX1,TRY1,TRZ1,TRT1, * TRX2,TRY2,TRZ2,TRT2,WEIGHT #else WRITE(MDEBUG,2552) TRID,TRE,TRX1,TRY1,TRZ1,TRT1, * TRX2,TRY2,TRZ2,TRT2 #endif ENDIF ENDIF #endif #if __PLOTSH2__ C END OF THE TRACKING STEP APPLY TIME CUT IF ( PLOTSH .AND. OUTPAR(6) .LT. PLTCUT ) THEN TRX2 = X TRY2 = Y TRZ2 = HAPP TRT2 = T #if __THIN__ WGHT = WEIGHT #endif IF ( FBOXCUT ) CALL PLTRUNC IF ( ( TRID .LE. 1.D0 .AND. TRE .GT. PLCUT(4) ) .OR. * ( ( TRID .EQ. 2.D0 .OR. TRID .EQ. 3.D0 ) .AND. * TRE .GT. PLCUT(3) ) ) THEN C X-Y AND OTHER PROJECTIONS (E.M.-> MAP 1) CALL LINPLXY( 1,TRX1,TRY1,TRX2,TRY2,WGHT ) CALL LINPLXZ( 1,TRX1,TRZ1,TRX2,TRZ2,WGHT ) CALL LINPLYZ( 1,TRY1,TRZ1,TRY2,TRZ2,WGHT ) ELSEIF ( ( TRID .EQ. 5.D0 .OR. TRID .EQ. 6.D0 ) .AND. * TRE .GT. PLCUT(2) ) THEN C X-Y AND OTHER PROJECTIONS (MU -> MAP 2) CALL LINPLXY( 2,TRX1,TRY1,TRX2,TRY2,WGHT ) CALL LINPLXZ( 2,TRX1,TRZ1,TRX2,TRZ2,WGHT ) CALL LINPLYZ( 2,TRY1,TRZ1,TRY2,TRZ2,WGHT ) ELSEIF ( TRID .GE. 7.D0 .AND. TRE .GT. PLCUT(1) ) THEN C X-Y AND OTHER PROJECTIONS (HADRONS -> MAP 3) CALL LINPLXY( 3,TRX1,TRY1,TRX2,TRY2,WGHT ) CALL LINPLXZ( 3,TRX1,TRZ1,TRX2,TRZ2,WGHT ) CALL LINPLYZ( 3,TRY1,TRZ1,TRY2,TRZ2,WGHT ) ENDIF IF ( DEBUG ) THEN WRITE(MDEBUG,2553) TRID,TRE,TRX1,TRY1,TRZ1,TRT1, * TRX2,TRY2,TRZ2,TRT2 ENDIF ENDIF #endif #if __COASTUSERLIB__ C END OF TRACKING STEP pnt2id = ITYPE pnt2gen= GEN pnt2x = XXX pnt2y = YYY pnt2z = HAPP #if __SLANT__ pnt2d = T11 #else pnt2d = THICKH/COS( THETAP ) #endif pnt2t = T pnt2e = PAMA(ITYPE)*GAMMA #if __THIN__ pnt2w = WEIGHT #else pnt2w = 1.D0 #endif call track(pnt1x, pnt2x) #endif #if __PLOTSH__ || __PLOTSH2__ || __COASTUSERLIB__ C END OF INTERMEDIATE STEP #if __PARALLEL__ C IF FIRST TRACK AND SECOND STACK NOT EMPTY, PRIMARY SHOULD NOT BE TRACKED ELSEIF( .NOT. (FIRSTI .AND. JCOUNT .GT. 1 ))THEN #else ELSE #endif LPLOTCNT = .TRUE. ENDIF #endif #if __PLOTSH__ || __PLOTSH2__ IF ( PLOTSH ) THEN C BEGINNING OF TRACKING STEP TRID = ITYPE TRE = PAMA(ITYPE)*GAMMA TRX1 = X TRY1 = Y TRZ1 = HAPP TRT1 = T ENDIF #endif #if __COASTUSERLIB__ C BEGINNING OF TRACKING STEP pnt1id = ITYPE pnt1gen= GEN pnt1x = XXX pnt1y = YYY pnt1z = HAPP #if __SLANT__ pnt1d = T11 #else pnt1d = THICKH/COS( THETAP ) #endif pnt1t = T pnt1e = PAMA(ITYPE)*GAMMA #if __THIN__ pnt1w = WEIGHT #else pnt1w = 1.D0 #endif #endif C LOOK WITHIN WHICH LAYER THE PARTICLE STARTS IF ( HOLD .LE. HLAY(2) ) THEN IL = 1 ELSEIF ( HOLD .LE. HLAY(3) ) THEN IL = 2 ELSEIF ( HOLD .LE. HLAY(4) ) THEN IL = 3 ELSE IL = 4 ENDIF C LOOK FOR MAXIMAL STEP OF CHIN, ONLY IF NOT CLOSE TO VERTICAL C BEFORE ENTERING NEW ATMOSPHERIC LAYER #if __UPWARD__ IF ( ABS( COSTHE ) .LT. 0.003D0 ) THEN WORK = MAX( C(2), C(3) + C(4)*THCKHN ) C LIMIT STEPSIZE BY MOVEMENT IN MAGNETIC FIELD (ENERGY IN GEV) #if __NEUTRINO__ || __NUPRIM__ IF ( ( ITYPE .GE. 66 .AND. ITYPE .LE. 69 ) #if __CHARM__ || __TAULEP__ * .OR. ITYPE .EQ. 133 .OR. ITYPE .EQ. 134 #endif * ) THEN WORK = MIN( WORK, 1.D3*BLIMIT * GAMMA ) ELSE WORK = MIN( WORK, 1.D3*BLIMIT * GAMMA * PAMA(ITYPE) ) ENDIF #else WORK = MIN( WORK, 1.D3 * BLIMIT * GAMMA * PAMA(ITYPE) ) #endif CHIMAX = WORK * RHOF(HOLD) IF ( DEBUG ) WRITE(MDEBUG,*) 'UPDATC: WORK,CHIC,CHIMAX=', * SNGL(WORK),SNGL(CHIC),SNGL(CHIMAX) IF ( CHIC .GE. CHIMAX ) THEN CHIN = CHIMAX ELSE CHIN = CHIC ENDIF ELSEIF ( ABS( COSTHE ) .LT. 0.98D0 ) THEN #else IF ( COSTHE .LT. 0.98D0 ) THEN #endif SINTHE = SQRT( (1.D0-COSTHE)*(1.D0+COSTHE) ) WORK = MAX( C(2), C(3) + C(4)*THCKHN ) C LIMIT STEPSIZE BY MOVEMENT IN MAGNETIC FIELD (ENERGY IN GEV) #if __NEUTRINO__ || __NUPRIM__ IF ( ( ITYPE .GE. 66 .AND. ITYPE .LE. 69 ) #if __CHARM__ || __TAULEP__ * .OR. ITYPE .EQ. 133 .OR. ITYPE .EQ. 134 #endif * ) THEN WORK = MIN( WORK, 1.D3*BLIMIT * GAMMA * SINTHE ) ELSE WORK = MIN( WORK, 1.D3*BLIMIT * GAMMA * PAMA(ITYPE) * SINTHE ) ENDIF #else WORK = MIN( WORK, 1.D3*BLIMIT * GAMMA * PAMA(ITYPE) * SINTHE ) #endif * IF ( DEBUG ) WRITE(MDEBUG,*) 'UPDATC: WORK=',SNGL(WORK) IF ( HOLD .LT. HLAY(5) ) THEN CHIMAX = ( THICK(HOLD - WORK*COSTHE/SINTHE) - THCKHN )/COSTHE ELSE CHIMAX = WORK * DATM(5) / SINTHE ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) 'UPDATC: WORK,CHIC,CHIMAX=', * SNGL(WORK),SNGL(CHIC),SNGL(CHIMAX) IF ( CHIC .GE. CHIMAX ) THEN CHIN = CHIMAX ELSE CHIN = CHIC ENDIF ELSE C NEARLY VERTICAL MOVEMENT C LIMIT STEPSIZE BY MOVEMENT IN MAGNETIC FIELD (ENERGY IN GEV) #if __NEUTRINO__ || __NUPRIM__ IF ( ( ITYPE .GE. 66 .AND. ITYPE .LE. 69 ) #if __CHARM__ || __TAULEP__ * .OR. ITYPE .EQ. 133 .OR. ITYPE .EQ. 134 #endif * ) THEN WORK = 1.D3 * BLIMIT * GAMMA ELSE WORK = 1.D3 * BLIMIT * GAMMA * PAMA(ITYPE) ENDIF #else WORK = 1.D3 * BLIMIT * GAMMA * PAMA(ITYPE) #endif HOLDM = MIN( HLAY(6), MAX( HLAY(1), HOLD - COSTHE * WORK ) ) CHIMAX = ABS( THICK( HOLDM ) - THICK( HOLD ) ) IF ( DEBUG ) WRITE(MDEBUG,*) 'UPDATC: WORK,CHIC,CHIMAX=', * SNGL(WORK),SNGL(CHIC),SNGL(CHIMAX) IF ( CHIC .GE. CHIMAX ) THEN CHIN = CHIMAX ELSE CHIN = CHIC ENDIF ENDIF C CALCULATE VALUES FOR UPDATE THCKHO = THCKHN #if __UPWARD__ IF ( COSTHE .LT. 0.003D0 ) THEN THCKHN = THCKHO + CHIN * COSTHE C RESTRICT UPWARD MOVEMENT BY BORDER OF ATMOSPHERE THCKHN = MAX( 0.D0, THCKHN ) HNEW = HEIGH( THCKHN ) ELSEIF ( COSTHE .GT. 0.003D0 ) THEN THCKHN = THCKHO + CHIN * COSTHE HNEW = HEIGH( THCKHN ) ELSE PATH = CHIN / RHOF( HOLD ) HNEW = HOLD - PATH * COSTHE THCKHN = THICK( HNEW ) ENDIF #else THCKHN = THCKHO + CHIN * COSTHE HNEW = HEIGH( THCKHN ) #endif #if __UPWARD__ IF ( COSTHE .LT. 0.D0 .AND. HOLD .GT. HNEW ) THEN C MAKE A SMALL STEP OF 0.1 CM HIGHER UP IN THE ATMOSPHERE HNEW = HOLD + 0.1D0 THCKHN = THICK( HNEW ) ELSEIF ( COSTHE .GT. 0.D0 .AND. HOLD .LT. HNEW ) THEN #else IF ( HOLD .LT. HNEW ) THEN #endif C MAKE A SMALL STEP OF 0.1 CM DEEPER DOWN INTO THE ATMOSPHERE HNEW = HOLD - 0.1D0 THCKHN = THICK( HNEW ) ENDIF C CHECK WHETHER PARTICLE PASSES OBSERVATION LEVEL #if __UPWARD__ IF ( ( PRMPAR(15) .GE. 0.D0 .AND. HNEW .LE. OBSLEV(1) ) .OR. * ( PRMPAR(15) .LT. 0.D0 .AND. HNEW .GE. OBSLEV(1) ) * ) THEN #else IF ( HNEW .LE. OBSLEV(1) ) THEN #endif IF ( DEBUG ) WRITE(MDEBUG,558) COSTHE,H,X,Y 558 FORMAT(' UPDATC: UNCORR COSTHE,H,X,Y=',1P,4E17.10,0P) IF ( FFLATOUT ) THEN C CORRECT PARTICLE COORDINATES FOR DETECTOR SYSTEM C FIRST CALCULATE COSTAP AND HAPP IN OLD SYSTEM AUXILSQ = SQRT( X**2 + Y**2 ) COSTEA = COS( AUXILSQ / C(1) ) COSTEA = MIN( 1.D0, COSTEA ) HAPP = (C(1)+HOLD) * COSTEA - C(1) #if !__UPWARD__ C REJECT PARTICLE WHICH TRAVERSES BELOW OBSERVATION LEVEL MEASURED C IN THE DETECTOR FRAME * IF ( HAPP .LT. OBSLEV(1) ) THEN * IRETC = .TRUE. * GOTO 200 * ENDIF #endif C REGARD WHETHER PARTICLE IS MOVING TOWARDS DETECTOR C EFFECTIVE DISTANCE TO DETECTOR CENTER IS DISTANCE TO POINT C OF FLIGHT PATH PROJECTION WHICH COMES CLOSEST TO DETECTOR CENTER SINTHE = SQRT( (1.D0-COSTHE)*(1.D0+COSTHE) ) IF ( SINTHE .NE. 0.D0 ) THEN COSPHI = PHIX / SINTHE SINPHI = PHIY / SINTHE ELSE COSPHI = 0.D0 SINPHI = 0.D0 ENDIF DSTEFF = -( COSPHI*X + SINPHI*Y ) C CALCULATE CORRECTION ANGLE DIF FROM EFFECTIVE DISTANCE SINDIF = SIN( DSTEFF / C(1) ) COSDIF = SQRT( (1.D0-SINDIF)*(1.D0+SINDIF) ) COSTHENEW = COSTHE*COSDIF - SINDIF*SINTHE IF ( DEBUG ) WRITE(MDEBUG,*) 'UPDATC: COSDIF,COSTHENEW=', * COSDIF,COSTHENEW COSTHE = MIN( 1.D0, COSTHENEW ) #if __UPWARD__ COSTHE = MAX( -1.D0, COSTHENEW ) #endif C KILL HORIZONTAL OR UPWARD GOING PARTICLES IF ( COSTHE .LE. C(29) ) THEN IF ( DEBUG ) WRITE(MDEBUG,556) (CURPAR(I),I=0,9) 556 FORMAT(' UPDATC: KILL 1=',1P,11E11.3) IRETC = .FALSE. GOTO 200 ENDIF C ANGLE DIF MIGHT BE LARGE (DUE TO CUT ON HAPP) IF ( COSTEA .NE. 1.D0 ) THEN C WE ARE AWAY FROM DETECOR C CALCULATE AZIMUTH ANGLE OF PARTICLE SEEN FROM DETECTOR IF ( Y .NE. 0.D0 .OR. X .NE. 0.D0 ) THEN PHI1 = ATAN2( Y, X ) ELSE PHI1 = 0.D0 ENDIF SINTEA = SQRT( (1.D0-COSTEA)*(1.D0+COSTEA) ) C HORIZONTAL DISTANCE OF PARTICLE TO DETECTOR RRR = ( HAPP + C(1) ) * SINTEA / COSTEA C UPDATE COORDINATES OF STARTING POINT IN A FLAT ATMOSPHERE (FOR UPDATE) X = RRR * COS( PHI1 ) Y = RRR * SIN( PHI1 ) H = HAPP ELSE C WE ARE IN THE DETECTOR SYSTEM AND NEED NO COORDINATE CALCULATION ENDIF #if __CERENKOV__ || __AUGCERLONG__ DETSYS = .TRUE. ELSE C PROPAGATE PARTICLE UNTIL SPHERICAL GROUND SO X AND Y ARE NOT CORRECTED DETSYS = .FALSE. ENDIF #else ELSE C PROPAGATE PARTICLE UNTIL SPHERICAL GROUND SO X AND Y ARE NOT CORRECTED ENDIF #endif THICKH = THICK(H) IF ( DEBUG ) WRITE(MDEBUG,559) COSTHE,H,X,Y,THICKH 559 FORMAT(' UPDATC: CORREC COSTHE,H,X,Y,THICKH=', * 1P,5E14.7,0P) HNEW = OBSLEV(1) THCKHN = THCKOB(1) C TRANSPORT ENDS AT OBSERVATION LEVEL IPASC = 1 #if __CERENKOV__ || __AUGCERLONG__ ELSE IPASC = 0 DETSYS = .FALSE. ENDIF HNEWO = HNEW #else ELSE C TRANSPORT ENDS AT RANGE OF PARTICLE IPASC = 0 ENDIF #endif C CALL UPDATE WITH NEW INPUT PARAMETERS ( HNEW,THCKHN,CURPAR(..) ) CHI = CHIN CALL UPDATE( HNEW,THCKHN,IPASC ) CHIN = CHI C DECREMENT THE THICKNESS STILL TO BE TRAVERSED CHIC = CHIC - CHI C INCREMENT STEPLO BY THE LENGTH PERFORMED IN UPDATE IF ( FLAGMU ) STEPLO = STEPLO + STEPL IF ( DEBUG ) WRITE(MDEBUG,*) 'UPDATC: CHIC,CHIN,IPASC=' * ,CHIC,CHIN,IPASC IF ( IRET2 .NE. 0 ) THEN IF ( IRETE ) THEN C PARTICLE SUFFERED FROM ENERGY CUT IRETC = IRETE #if __SLANT__ || __COASTUSERLIB__ IF ( FFLATOUT .AND. IPASC .NE. 0 ) COSTEA = 1.D0 #endif GOTO 150 ELSE C PARTICLE SUFFERED FROM ANGULAR CUT GOTO 200 ENDIF ENDIF #if __CERENKOV__ C KILL PARTICLE AS IT HAS BEEN STOPPED (MODIFIED HNEW IN UPDATE) C (NORMALLY BECAUSE OF ENERGY CUT) C IF ( HNEW .NE. HNEWO ) THEN C IRET2 = 1 C IRETE = .TRUE. C IRETC = .TRUE. C GOTO 200 C ENDIF #endif C FOR CHARGED PARTICLES COSINE OF ZENITH ANGLE IS CALCULATED IN UPDATE. C KILL HORIZONTAL OR UPWARD GOING PARTICLES IF ( OUTPAR(2) .LE. C(29) ) THEN IRETC = .FALSE. GOTO 200 ENDIF C FILL CURPAR WITH ACTUAL VALUES OF PARTICLE AFTER TRANSPORT IN UPDATE C OUTPAR(13-16) IS NOT MODIFIED IN UPDATE C UPDATES VALUES OF X, Y, H, ... DO I = 0, 8 CURPAR(I) = OUTPAR(I) ENDDO THICKH = THCKHN C CHECK WHETHER PARTICLE EXCEEDS TIME LIMIT IF ( OUTPAR(6) .GT. TIMLIM ) THEN IRET2 = 1 IRETC = .FALSE. C PRINT PARTICLE EXCEEDING TIME LIMIT IF PRINT FLAG IS SET IF ( LTMLMPR .OR. DEBUG ) THEN #if __THIN__ WRITE(MONIOU,571) (OUTPAR(I),I=0,8),WEIGHT 571 FORMAT(' UPDATC: OUTPAR=',1P,10E11.3) #else WRITE(MONIOU,571) (OUTPAR(I),I=0,8) 571 FORMAT(' UPDATC: OUTPAR=',1P,9E11.3) #endif WRITE(MONIOU,570) 570 FORMAT(' UPDATC: PARTICLE ELIMINATED BECAUSE OF TIME LIMIT,', * ' PLEASE READ THE USERS GUIDE, SEE KEYWORD: TIMLIM') ENDIF #if __SLANT__ || __COASTUSERLIB__ IF ( FFLATOUT .AND. IPASC .NE. 0 ) COSTEA = 1.D0 #endif GOTO 150 ENDIF C SPEED OF PARTICLE IN LOCAL FRAME IF ( T-TOLD .GT. 1.D-10 ) THEN SPEED0 = SQRT(( X - XOLD )**2 & +( Y - YOLD )**2 & +( H - HOLD )**2) / ( T - TOLD ) ELSE SPEED0 = C(25) ENDIF IF ( IPASC .EQ. 0 .OR. .NOT.FFLATOUT ) THEN C TRACK ENDS NOT AT OBSERVATION LEVEL (SPHERICAL DEFINITION OF X AND Y) C HORIZONTAL COMPONENT OF TRACK LENGTH SQUARED TRANS2 = (X-XOLD)**2 + (Y-YOLD)**2 C TRANSPORT AT MINIMUM 1 MM TRANS2 = MAX( TRANS2, 0.01D0 ) C NEW COORDINATE FRAME, NEW ACTUAL HEIGHT AT NEW THICKNESS GRADIENT C (CALCULATED WITH PARAMETERS OF OLD COORDINATE FRAME) AUXIL = SQRT( TRANS2 + (C(1)+H)**2 ) HNEW = AUXIL - C(1) #if __UPWARD__ IF ( HNEW .GE. HLAY(6) .OR. * ( COSTHE .LT. 0.D0 .AND. THCKHN .LT. 1.D-7 ) ) THEN C KILL PARTICLE WHICH LEAVES ATMOSPHERE OR C UPWARD PARTICLE HIGHER THAN 1 M BELOW TOP OF ATMOSPHERE #else IF ( HNEW .GE. HLAY(6) ) THEN C KILL PARTICLE WHICH LEAVES ATMOSPHERE #endif IF ( DEBUG ) WRITE(MDEBUG,*) 'UPDATC: HNEW=',HNEW,' KILL' HNEW = HLAY(6) THCKHN = 0.D0 IRET2 = 1 IRETC = .FALSE. GOTO 150 #if __UPWARD__ ELSEIF ( HNEW .LT. HLAY(1) .AND. COSTHE .GT. 0.D0 ) THEN IF ( DEBUG ) WRITE(MDEBUG,*) 'UPDATC: HNEW=',HNEW,' KILL' HNEW = HLAY(1) THCKHN = THICKL(1) IRET2 = 1 IRETC = .FALSE. GOTO 150 #endif ENDIF THCKHN = THICK( HNEW ) C CALCULATE ANGLE DIFFERENCE BETWEEN OLD AND NEW FRAME SINDIF = SQRT( TRANS2 ) / AUXIL COSDIF = (C(1)+H) / AUXIL IF ( DEBUG ) WRITE(MDEBUG,560) COSDIF,SINDIF,H,HNEW 560 FORMAT(' UPDATC: COSDIF,SINDIF,H,HNEW=',2F18.15,1P,2E17.9) COSDIF = MIN( 1.D0, COSDIF ) C X AND Y HAVE TO BE TRANSFORMED INTO 'EARTH'-COORDINATES (SPHERE) C TRANSPORT DISTANCE IS CORRECTED TO GET DISTANCE AT EARTHS SURFACE CORR = C(1) * ASIN( SINDIF ) / ( (C(1)+HNEW) * SINDIF ) XNEW = XOLD + (X-XOLD)*CORR X = XNEW YNEW = YOLD + (Y-YOLD)*CORR Y = YNEW H = HNEW THICKH = THICK(H) TNEW = T C IN FIRST ORDER APPROXIMATION COSTHE AND COSDIF ARE IN THE SAME PLANE C OF PARTICLE MOVEMENT, THEREFORE THE ANGLES MAY BE ADDED DIRECTLY C USE ADDITION THEOREM FOR (THETA + DELTA) C COS(THETA+DELTA)= COS(THETA)*COS(DELTA) - SIN(THETA)*SIN(DELTA) SINTHE = SQRT( (1.D0-COSTHE)*(1.D0+COSTHE) ) COSTHENEW = COSTHE*COSDIF - SINDIF*SINTHE COSTHENEW = MIN( 1.D0, COSTHENEW ) C PROTECTION AGAINST SINTHE=0 IF ( SINTHE .NE. 0.D0 ) THEN PHICOR = COSDIF + COSTHE * SINDIF /SINTHE PHIXNEW = PHIX * PHICOR PHIYNEW = PHIY * PHICOR ELSE C VERTICAL MOVEMENT OF PARTICLE: PHIX AND PHIY MUST BE 0 FOR SINTHE=0 PHIXNEW = 0 PHIYNEW = 0 ENDIF COSTHE = COSTHENEW PHIX = PHIXNEW PHIY = PHIYNEW RADINV = 1.5D0 - 0.5D0 * ( PHIX**2 + PHIY**2 + COSTHE**2 ) COSTHE = RADINV * COSTHENEW PHIX = RADINV * PHIX PHIY = RADINV * PHIY C KILL HORIZONTAL OR UPWARD GOING PARTICLES IF ( COSTHE .LE. C(29) ) THEN IF ( DEBUG ) WRITE(MDEBUG,555) (CURPAR(I),I=0,9) 555 FORMAT(' UPDATC: KILL 0=',1P,11E11.3) IRETC = .FALSE. GOTO 200 ENDIF C CALCULATE ANGLES IN THE NEW FRAME AUXILSQ = SQRT( X**2 + Y**2 ) COSTEA = COS( AUXILSQ / C(1) ) COSTEA = MIN( 1.D0, COSTEA ) HAPP = (C(1)+HNEW) * COSTEA - C(1) AUX2SQ = SQRT( (C(1)+HNEW)**2 * (1.D0-COSTEA)*(1.D0+COSTEA) * + (HAPP-OBSLEV(1))**2 ) IF ( AUX2SQ .GT. 0.D0 ) THEN COSTAP = (HAPP-OBSLEV(1)) / AUX2SQ ELSE C PARTICLE REACHED THE GROUND AT CORE POSITION COSTAP = 0.D0 ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) 'UPDATC: COSTAP,HAPP=', * SNGL(COSTAP),SNGL(HAPP) COSTAP = MIN( 1.D0, COSTAP ) IF ( COSTEA .NE. 1.D0 ) THEN C WE ARE AWAY FROM DETECOR C CALCULATE AZIMUTH ANGLE OF PARTICLE SEEN FROM DETECTOR IF ( Y .NE. 0.D0 .OR. X .NE. 0.D0 ) THEN PHI1 = ATAN2( Y, X ) ELSE PHI1 = 0.D0 ENDIF SINTEA = SQRT( (1.D0-COSTEA)*(1.D0+COSTEA) ) C HORIZONTAL DISTANCE OF PARTICLE TO DETECTOR RRR = ( HAPP + C(1) ) * SINTEA / COSTEA XXX = RRR * COS( PHI1 ) YYY = RRR * SIN( PHI1 ) ELSE C WE ARE IN THE DETECTOR SYSTEM AND NEED NO COORDINATE CALCULATION XXX = X YYY = Y ENDIF C SPEED OF PARTICLE IN OBSERVER FRAME IF ( T-TOLD .GT. 1.D-10 ) THEN SPEED = SQRT(( XXX - XXXOLD )**2 & +( YYY - YYYOLD )**2 & +( HAPP - HAPPOLD )**2) / ( T - TOLD ) ELSE SPEED0 = C(25) SPEED = C(25) ENDIF C FIX TIME DIFFERENCE DUE TO FRAME SHIFT : SPEED IN LOCAL FRAME C (AFTER UPDATE) SHOULD BE THE SAME AS IN OBSERVER FRAME TNEW = TOLD + ( T-TOLD ) * SPEED/SPEED0 IF ( ABS(CHIC) .GT. 1.D-2 .AND. & ABS(SPEED/SPEED0-1.D0) .GT. 1.D-2 ) THEN IF ( DEBUG ) WRITE(MONIOU,'(A,F5.2)') & 'WARNING: SPEED CORRECTION HAD > 1% -> OK IF RARE',SPEED/SPEED0 IF ( DEBDEL ) THEN NCOUNT = NCOUNT + 1 WRITE(MDEBUG,*) 'UPDATC: NCOUNT = ',NCOUNT IF ( NCOUNT .GE. NDEBDL ) DEBUG = .TRUE. IF ( NCOUNT .GE. NDEBDL+10 ) DEBUG = .FALSE. ENDIF ENDIF IF ( DEBUG ) WRITE(MDEBUG,561) SPEED/SPEED0,T,TNEW 561 FORMAT(' UPDATC: S/S0,T,TNEW=',F18.15,1P,2E17.9) T = TNEW #if __COASTUSERLIB__ && __SLANT__ T11 = THCKSI( XXX*STHCPH + YYY*STHSPH - HAPP*CTH + RLOFF ) #endif IF ( DEBUG ) WRITE(MDEBUG,562) COSTEA,HAPP 562 FORMAT(' UPDATC: COSTEA,HAPP=',F18.15,1P,E17.9) #if __THIN__ IF ( DEBUG ) WRITE(MDEBUG,557) (CURPAR(I),I=0,9),WEIGHT 557 FORMAT(' UPDATC: STPEND=',1P,11E11.3,0P) #else IF ( DEBUG ) WRITE(MDEBUG,557) (CURPAR(I),I=0,9) 557 FORMAT(' UPDATC: STPEND=',1P,10E11.3,0P) #endif IF ( FFLATOUT ) THEN #if __UPWARD__ IF ( ( PRMPAR(15) .GE. 0.D0 .AND. HAPP .LT. OBSLEV(1) ) .OR. * ( PRMPAR(15) .LT. 0.D0 .AND. HAPP .GE. OBSLEV(1) ) ) THEN #else IF ( HAPP .LT. OBSLEV(1) ) THEN #endif C BRING PARTICLE TO OUTPUT WHICH MOVES BELOW OBSERVATION LEVEL C IN THE DETECTOR FRAME AT THE INTERSECTION POINT WITH OBSERVATION LEVEL C DEFINE COORDINATES IN DETECTOR FRAME (FLAT) AUXIL = ( OBSLEV(1) - HAPPOLD ) / ( HAPP - HAPPOLD ) X = XXXOLD + AUXIL * ( XXX - XXXOLD ) Y = YYYOLD + AUXIL * ( YYY - YYYOLD ) T = TOLD + AUXIL * ( TNEW - TOLD ) RRR = SQRT ( X*X + Y*Y ) HAPP = OBSLEV(1) AUXIL = HAPP + C(1) AUXILSQ= SQRT ( RRR*RRR + AUXIL*AUXIL ) COSTEA = AUXIL / AUXILSQ H = OBSLEV(1) THCKHN = THCKOB(1) IF ( DEBUG )WRITE(MDEBUG,*) 'UPDATC: HAPP,COSTEA=',HAPP,COSTEA IF ( DEBUG )WRITE(MDEBUG,*) 'UPDATC: CORRECTED HEIGHT=',H IPASC = 1 #if __SLANT__ || __COASTUSERLIB__ C COORDINATES NOW DEFINED IN UPDATE IN DETECTOR FRAME, NO NEED C FOR CORRECTION COSTEA = 1.D0 #endif ENDIF ENDIF OUTPAR(2) = COSTHE OUTPAR(3) = PHIX OUTPAR(4) = PHIY OUTPAR(5) = H OUTPAR(6) = T OUTPAR(7) = X OUTPAR(8) = Y ENDIF IF ( IPASC .EQ. 0 ) THEN C WE ARE NOT YET AT DETECTOR. IF ( FDECAY ) THEN C JUMP BACK IF NOT WHOLE CHIC OR STEPLC TRAVERSED IF ( CHIC .GT. 1.D-10 .AND. STEPLO .LT. STEPLC ) GOTO 2 ELSE C JUMP BACK IF NOT WHOLE CHIC TRAVERSED IF ( CHIC .GT. 1.D-10 ) GOTO 2 ENDIF C RESTORE CHI IN COMMON CUPPAR FOR CORRECT USE IN MUTRAC CHI = ARG - CHIC C RESTORE STEPL IN COMMON MUMULT FOR CORRECT USE IN MUTRAC IF ( FLAGMU ) STEPL = STEPLO IF ( DEBUG ) WRITE(MDEBUG,*) 'UPDATC: CHI,STEPL=', * SNGL(CHI),SNGL(STEPL) ELSE H = OBSLEV(1) THCKHN = THCKOB(1) IF ( .NOT. FFLATOUT ) THEN C UPDATE COORDINATES DEFINED IN UPDATC ON EARTH SURFACE OUTPAR(2) = COSTHE OUTPAR(3) = PHIX OUTPAR(4) = PHIY OUTPAR(5) = H OUTPAR(7) = X OUTPAR(8) = Y ELSE HAPP = OBSLEV(1) #if __SLANT__ || __COASTUSERLIB__ C COORDINATES DEFINED IN UPDATE IN DETECTOR FRAME, NO NEED C FOR CORRECTION COSTEA = 1.D0 #endif ENDIF ENDIF 150 CONTINUE #if __PARALLEL__ C IF FIRST TRACK AND SECOND STACK NOT EMPTY STOP HERE TO AVOID TRACKING OF C PRIMARY IF( FIRSTI .AND. JCOUNT .GT. 1 )RETURN #endif IF ( LLONGI ) THEN #if __SLANT__ || __COASTUSERLIB__ IF ( COSTEA .NE. 1.D0 ) THEN C WE ARE AWAY FROM DETECTOR C CALCULATE AZIMUTH ANGLE OF PARTICLE SEEN FROM DETECTOR IF ( OUTPAR(8) .NE. 0.D0 .OR. OUTPAR(7) .NE. 0.D0 ) THEN PHI1 = ATAN2( OUTPAR(8), OUTPAR(7) ) ELSE PHI1 = 0.D0 ENDIF SINTEA = SQRT( (1.D0-COSTEA)*(1.D0+COSTEA) ) C HORIZONTAL DISTANCE OF PARTICLE TO DETECTOR RRR = ( HAPP + C(1) ) * SINTEA / COSTEA XXX = RRR * COS( PHI1 ) YYY = RRR * SIN( PHI1 ) ELSE C WE ARE IN THE DETECTOR SYSTEM AND NEED NO COORDINATE CALCULATION XXX = OUTPAR(7) YYY = OUTPAR(8) ENDIF #endif C THE PARTICLE IS TRACKED FROM SLANT THICKNES T1 TO T2 #if __SLANT__ FLGLB = .FALSE. T2 = THCKSI( XXX*STHCPH + YYY*STHSPH - HAPP*CTH + RLOFF ) LPCT2 = INT( T2*THSTPI ) C SET FLAG_LAST_BIN IF PATH STARTS IN LAST BIN IF ( LPCT1 .GE. NSTEP .AND. LPCT2 .GE. LPCT1 ) FLGLB = .TRUE. #else C THE PARTICLE IS TRACKED FROM THICKHOLD DOWN TO THCKHN LPCT2 = INT( THCKHN*THSTPI ) LPCT2 = MAX( LPCT2, 0 ) LPCT2 = MIN( LPCT2, NSTEP + 1 ) #endif C TOTAL PATH LENGTH IN UNITS OF LONGI BINS #if __SLANT__ STEPT = (T2 - T1) * THSTPI #else STEPT = (THCKHN - THICKHOLD) * THSTPI #endif IF ( SIGNUM(ITYPE) .NE. 0.D0 ) THEN C CHARGED PARTICLES GAMMAN = OUTPAR(1) #if __UPWARD__ || __SLANT__ #if __SLANT__ IF ( T2 .GT. T1 ) THEN C FORWARD MOVING PARTICLE #else IF ( COSTHE .GT. 0.D0 ) THEN C DOWNWARD MOVING PARTICLE #endif #endif C CHARGED PARTICLES SUFFER IONIZATION LOSS. C WE ASSUME HOMOGENEOUS ENERGY DEPOSIT ALONG PATH IF ( STEPT .GT. 0.D0 ) THEN C IONIZATION ENERGY DEPOSITED IN EACH BIN #if __THIN__ EDEPB = PAMA(ITYPE) * (GAMMAOLD - GAMMAN) * WEIGHT / STEPT #else EDEPB = PAMA(ITYPE) * (GAMMAOLD - GAMMAN) / STEPT #endif ELSE EDEPB = 0.D0 ENDIF C ENERGY DEPOSIT IN FIRST BIN #if __SLANT__ EDEP1 = EDEPB * (DBLE(LPCT1) - T1*THSTPI) #else EDEP1 = EDEPB * (DBLE(LPCT1) - THICKHOLD*THSTPI) IF ( LPCT1 .EQ. NSTEP ) EDEP1 = ABS( EDEP1 ) #endif C ENERGY AT FIRST BIN BOUNDARY #if __THIN__ EFRST = PAMA(ITYPE) * GAMMAOLD * WEIGHT - EDEP1 #else EFRST = PAMA(ITYPE) * GAMMAOLD - EDEP1 #endif IF ( LPCT2 .LT. LPCT1 ) THEN C SMALL STEP #if __SLANT__ EDEPN = EDEPB * (T2*THSTPI - DBLE(LPCT1)) #else EDEPN = EDEPB * (THCKHN*THSTPI - DBLE(LPCT1)) #endif IF ( IPASC .NE. 0 ) THEN C PARTICLE MOVES NEARLY HORIZONTALLY TO DETECTOR, LAST STEP WAS SMALLER C THAN LONGITUDINAL BINNING, THEREFORE LPCT2 < LPCT1. LPCT2 = MIN( NSTEP, LPCT2 ) ENDIF ELSE C STEP LONGER THAN ONE LONGITUDINAL BIN GIVES LPCT2 >= LPCT1 IF ( IPASC .EQ. 0 ) THEN #if __SLANT__ EDEPN = MAX( 0.D0, EDEPB * (T2*THSTPI - DBLE(LPCT2)) ) ELSE C PARTICLE ARRIVES AT DETECTOR LPCT2 = MIN( LPCT2, NSTEP+1 ) #else EDEPN = MAX( 0.D0, EDEPB*(THCKHN*THSTPI - DBLE(LPCT2)) ) ELSE C PARTICLE ARRIVES AT DETECTOR LPCT2 = MIN( LPCT2, NSTEP ) #endif EDEPN = 0.D0 ENDIF ENDIF #if __SLANT__ IF ( FLGLB ) THEN C PATH STARTS AND ENDS IN LAST BIN, DEPOSIT IONISATION LOSS IN THIS BIN EDEP1 = MAX( 0.D0, STEPT * EDEPB ) EDEPN = 0.D0 LPCT2 = LPCT1 ENDIF #endif C NOW FILL FIRST AND LAST+1 BIN, THEN LOOP OVER THE BINS BETWEEN IF ( ITYPE .EQ. 5 ) THEN C MUON(+) LONGITUDINAL DEVELOPMENT FOR DEPOSIT, ENERGY, PARTICLES DLONG(LPCT1 ,4) = DLONG(LPCT1 ,4) + EDEP1 DLONG(LPCT2+1,4) = DLONG(LPCT2+1,4) + EDEPN IF ( LPCT2 .GE. LPCT1 ) THEN ELONG(LPCT2,4) = ELONG(LPCT2,4) * + ( EFRST - (LPCT2-LPCT1) * EDEPB ) #if __THIN__ PLONG(LPCT2,4) = PLONG(LPCT2,4) + WEIGHT #else PLONG(LPCT2,4) = PLONG(LPCT2,4) + 1.D0 #endif ENDIF ELSEIF ( ITYPE .EQ. 6 ) THEN C MUON(-) LONGITUDINAL DEVELOPMENT FOR DEPOSIT, ENERGY, PARTICLES DLONG(LPCT1 ,4) = DLONG(LPCT1 ,4) + EDEP1 DLONG(LPCT2+1,4) = DLONG(LPCT2+1,4) + EDEPN IF ( LPCT2 .GE. LPCT1 ) THEN ELONG(LPCT2,5) = ELONG(LPCT2,5) * + ( EFRST - (LPCT2-LPCT1) * EDEPB ) #if __THIN__ PLONG(LPCT2,5) = PLONG(LPCT2,5) + WEIGHT #else PLONG(LPCT2,5) = PLONG(LPCT2,5) + 1.D0 #endif ENDIF ELSEIF ( ITYPE .LT. 200 ) THEN C CHARGED HADRON LONGITUD. DEVELOPMENT FOR DEPOSIT, ENERGY, PARTICLES DLONG(LPCT1 ,6) = DLONG(LPCT1 ,6) + EDEP1 DLONG(LPCT2+1,6) = DLONG(LPCT2+1,6) + EDEPN IF ( LPCT2 .GE. LPCT1 ) THEN ELONG(LPCT2,6) = ELONG(LPCT2,6) * + ( EFRST - (LPCT2-LPCT1) * EDEPB ) ELONG(LPCT2,7) = ELONG(LPCT2,7) * + ( EFRST - (LPCT2-LPCT1) * EDEPB ) #if __ANAHIST__ IF ( ITYPE .EQ. 8 ) THEN #if __THIN__ PLONG(LPCT2,14) = PLONG(LPCT2,14) + WEIGHT ELSEIF ( ITYPE .EQ. 9 ) THEN PLONG(LPCT2,14) = PLONG(LPCT2,14) + WEIGHT ELSEIF ( ITYPE .EQ. 11 ) THEN PLONG(LPCT2,15) = PLONG(LPCT2,15) + WEIGHT ELSEIF ( ITYPE .EQ. 12 ) THEN PLONG(LPCT2,15) = PLONG(LPCT2,15) + WEIGHT ELSEIF ( ITYPE .EQ. 14 ) THEN PLONG(LPCT2,12) = PLONG(LPCT2,12) + WEIGHT PLONG(LPCT2,11) = PLONG(LPCT2,11) + WEIGHT ELSEIF ( ITYPE .EQ. 15 ) THEN PLONG(LPCT2,12) = PLONG(LPCT2,12) + WEIGHT PLONG(LPCT2,11) = PLONG(LPCT2,11) + WEIGHT #else PLONG(LPCT2,14) = PLONG(LPCT2,14) + 1.D0 ELSEIF ( ITYPE .EQ. 9 ) THEN PLONG(LPCT2,14) = PLONG(LPCT2,14) + 1.D0 ELSEIF ( ITYPE .EQ. 11 ) THEN PLONG(LPCT2,15) = PLONG(LPCT2,15) + 1.D0 ELSEIF ( ITYPE .EQ. 12 ) THEN PLONG(LPCT2,15) = PLONG(LPCT2,15) + 1.D0 ELSEIF ( ITYPE .EQ. 14 ) THEN PLONG(LPCT2,12) = PLONG(LPCT2,12) + 1.D0 PLONG(LPCT2,11) = PLONG(LPCT2,11) + 1.D0 ELSEIF ( ITYPE .EQ. 15 ) THEN PLONG(LPCT2,12) = PLONG(LPCT2,12) + 1.D0 PLONG(LPCT2,11) = PLONG(LPCT2,11) + 1.D0 #endif ENDIF #endif #if __THIN__ PLONG(LPCT2,6) = PLONG(LPCT2,6) + WEIGHT PLONG(LPCT2,7) = PLONG(LPCT2,7) + WEIGHT #else PLONG(LPCT2,6) = PLONG(LPCT2,6) + 1.D0 PLONG(LPCT2,7) = PLONG(LPCT2,7) + 1.D0 #endif ENDIF ELSE C NUCLEI LONGITUDINAL DEVELOPMENT FOR DEPOSIT, ENERGY, PARTICLES DLONG(LPCT1 ,6) = DLONG(LPCT1 ,6) + EDEP1 DLONG(LPCT2+1,6) = DLONG(LPCT2+1,6) + EDEPN IF ( LPCT2 .GE. LPCT1 ) THEN ELONG(LPCT2,8) = ELONG(LPCT2,8) * + ( EFRST - (LPCT2-LPCT1) * EDEPB ) #if __THIN__ PLONG(LPCT2,8) = PLONG(LPCT2,8) + WEIGHT #else PLONG(LPCT2,8) = PLONG(LPCT2,8) + 1.D0 #endif ENDIF ENDIF C LOOP OVER ALL LONGITUDINAL BINS IF ( LPCT2 .GT. LPCT1 ) THEN DO IL = LPCT1, LPCT2-1 IF ( ITYPE .EQ. 5 ) THEN C MUON(+) LONGITUDINAL DEVELOPMENT FOR DEPOSIT, ENERGY, PARTICLES DLONG(IL+1,4) = DLONG(IL+1,4) + EDEPB ELONG(IL,4) = ELONG(IL,4) + ( EFRST-(IL-LPCT1)*EDEPB ) #if __THIN__ PLONG(IL,4) = PLONG(IL,4) + WEIGHT #else PLONG(IL,4) = PLONG(IL,4) + 1.D0 #endif ELSEIF ( ITYPE .EQ. 6 ) THEN C MUON(-) LONGITUDINAL DEVELOPMENT FOR DEPOSIT, ENERGY, PARTICLES DLONG(IL+1,4) = DLONG(IL+1,4) + EDEPB ELONG(IL,5) = ELONG(IL,5) + ( EFRST-(IL-LPCT1)*EDEPB ) #if __THIN__ PLONG(IL,5) = PLONG(IL,5) + WEIGHT #else PLONG(IL,5) = PLONG(IL,5) + 1.D0 #endif ELSEIF ( ITYPE .LT. 200 ) THEN C CHARGED HADRON LONGITUDINAL DEVELOPMENT FOR DEPOSIT, ENERGY, PARTICLES DLONG(IL+1,6) = DLONG(IL+1,6) + EDEPB ELONG(IL,6) = ELONG(IL,6) + ( EFRST-(IL-LPCT1)*EDEPB ) ELONG(IL,7) = ELONG(IL,7) + ( EFRST-(IL-LPCT1)*EDEPB ) #if __ANAHIST__ IF ( ITYPE .EQ. 8 ) THEN #if __THIN__ PLONG(IL,14) = PLONG(IL,14) + WEIGHT ELSEIF ( ITYPE .EQ. 9 ) THEN PLONG(IL,14) = PLONG(IL,14) + WEIGHT ELSEIF ( ITYPE .EQ. 11 ) THEN PLONG(IL,15) = PLONG(IL,15) + WEIGHT ELSEIF ( ITYPE .EQ. 12 ) THEN PLONG(IL,15) = PLONG(IL,15) + WEIGHT ELSEIF ( ITYPE .EQ. 14 ) THEN PLONG(IL,12) = PLONG(IL,12) + WEIGHT PLONG(IL,11) = PLONG(IL,11) + WEIGHT ELSEIF ( ITYPE .EQ. 15 ) THEN PLONG(IL,12) = PLONG(IL,12) + WEIGHT PLONG(IL,11) = PLONG(IL,11) + WEIGHT #else PLONG(IL,14) = PLONG(IL,14) + 1.D0 ELSEIF ( ITYPE .EQ. 9 ) THEN PLONG(IL,14) = PLONG(IL,14) + 1.D0 ELSEIF ( ITYPE .EQ. 11 ) THEN PLONG(IL,15) = PLONG(IL,15) + 1.D0 ELSEIF ( ITYPE .EQ. 12 ) THEN PLONG(IL,15) = PLONG(IL,15) + 1.D0 ELSEIF ( ITYPE .EQ. 14 ) THEN PLONG(IL,12) = PLONG(IL,12) + 1.D0 PLONG(IL,11) = PLONG(IL,11) + 1.D0 ELSEIF ( ITYPE .EQ. 15 ) THEN PLONG(IL,12) = PLONG(IL,12) + 1.D0 PLONG(IL,11) = PLONG(IL,11) + 1.D0 #endif ENDIF #endif #if __THIN__ PLONG(IL,6) = PLONG(IL,6) + WEIGHT PLONG(IL,7) = PLONG(IL,7) + WEIGHT #else PLONG(IL,6) = PLONG(IL,6) + 1.D0 PLONG(IL,7) = PLONG(IL,7) + 1.D0 #endif ELSE C NUCLEI LONGITUDINAL DEVELOPMENT FOR DEPOSIT, ENERGY, PARTICLES DLONG(IL+1,6) = DLONG(IL+1,6) + EDEPB ELONG(IL,8) = ELONG(IL,8) + ( EFRST-(IL-LPCT1)*EDEPB ) #if __THIN__ PLONG(IL,8) = PLONG(IL,8) + WEIGHT #else PLONG(IL,8) = PLONG(IL,8) + 1.D0 #endif ENDIF ENDDO ENDIF #if __UPWARD__ || __SLANT__ #if __SLANT__ ELSEIF ( T2 .LT. T1 ) THEN C BACKWARD MOVING PARTICLE IF ( T2 .LT. 0.D0 ) THEN LPCT2 = 0 T2 = 0.D0 STEPT = (T2 - T1) * THSTPI ENDIF #else ELSEIF ( COSTHE .LT. 0.D0 ) THEN C UPWARD MOVING PARTICLE #endif LPCT1 = LPCT1 - 1 LPCT2 = LPCT2 + 1 STEPT = -STEPT C CHARGED PARTICLES SUFFER IONIZATION LOSS. C WE ASSUME HOMOGENEOUS ENERGY DEPOSIT ALONG PATH IF ( STEPT .GT. 0.D0 ) THEN C IONIZATION ENERGY DEPOSITED IN EACH BIN #if __THIN__ EDEPB = PAMA(ITYPE) * (GAMMAOLD - GAMMAN) * WEIGHT / STEPT #else EDEPB = PAMA(ITYPE) * (GAMMAOLD - GAMMAN) / STEPT #endif ELSE EDEPB = 0.D0 ENDIF C ENERGY DEPOSIT IN FIRST BIN #if __SLANT__ LPCT2 = MIN( LPCT2, NSTEP+1 ) EDEP1 = EDEPB * (T1*THSTPI - DBLE(LPCT1)) #else LPCT2 = MAX( LPCT2, 0 ) EDEP1 = EDEPB * (THICKHOLD*THSTPI - DBLE(LPCT1)) #endif C ENERGY AT FIRST BIN BOUNDARY #if __THIN__ EFRST = PAMA(ITYPE) * GAMMAOLD * WEIGHT - EDEP1 #else EFRST = PAMA(ITYPE) * GAMMAOLD - EDEP1 #endif IF ( LPCT2. GT. LPCT1 ) THEN C SMALL STEP #if __SLANT__ EDEPN = EDEPB * (DBLE(LPCT1) - T2*THSTPI) #else EDEPN = EDEPB * (DBLE(LPCT1) - THCKHN*THSTPI) #endif ELSE C STEP LONGER THAN ONE LONGITUDINAL BIN GIVES LPCT2 <= LPCT1 IF ( IPASC .EQ. 0 ) THEN #if __SLANT__ EDEPN = MAX( 0.D0, EDEPB * (DBLE(LPCT2) - T2*THSTPI) ) #else EDEPN = MAX( 0.D0, EDEPB * (DBLE(LPCT2)-THCKHN*THSTPI) ) #endif ELSE C PARTICLE ARRIVES AT DETECTOR LPCT2 = MAX( 0, LPCT2 ) EDEPN = 0.D0 ENDIF ENDIF #if __SLANT__ IF ( FLGLB ) THEN C PATH STARTS AND ENDS IN LAST BIN, DEPOSIT IONISATION LOSS IN THIS BIN EDEP1 = MAX( 0.D0, STEPT * EDEPB ) EDEPN = 0.D0 LPCT2 = LPCT1 ENDIF #endif C NOW FILL FIRST AND LAST+1 BIN, THEN LOOP OVER THE BINS BETWEEN IF ( ITYPE .EQ. 5 ) THEN C MUON(+) LONGITUDINAL DEVELOPMENT FOR DEPOSIT, ENERGY, PARTICLES DLONG(LPCT1+1,4) = DLONG(LPCT1+1,4) + EDEP1 DLONG(LPCT2 ,4) = DLONG(LPCT2 ,4) + EDEPN IF ( LPCT2 .LE. LPCT1 ) THEN ELONG(LPCT2,4) = ELONG(LPCT2,4) * + ( EFRST + (LPCT2-LPCT1) * EDEPB ) #if __THIN__ PLONG(LPCT2,4) = PLONG(LPCT2,4) + WEIGHT #else PLONG(LPCT2,4) = PLONG(LPCT2,4) + 1.D0 #endif ENDIF ELSEIF ( ITYPE .EQ. 6 ) THEN C MUON(-) LONGITUDINAL DEVELOPMENT FOR DEPOSIT, ENERGY, PARTICLES DLONG(LPCT1+1,4) = DLONG(LPCT1+1,4) + EDEP1 DLONG(LPCT2 ,4) = DLONG(LPCT2 ,4) + EDEPN IF ( LPCT2 .LE. LPCT1 ) THEN ELONG(LPCT2,5) = ELONG(LPCT2,5) * + ( EFRST + (LPCT2-LPCT1) * EDEPB ) #if __THIN__ PLONG(LPCT2,5) = PLONG(LPCT2,5) + WEIGHT #else PLONG(LPCT2,5) = PLONG(LPCT2,5) + 1.D0 #endif ENDIF ELSEIF ( ITYPE .LT. 200 ) THEN C CHARGED HADRON LONGITUD. DEVELOPMENT FOR DEPOSIT, ENERGY, PARTICLES DLONG(LPCT1+1,6) = DLONG(LPCT1+1,6) + EDEP1 DLONG(LPCT2 ,6) = DLONG(LPCT2 ,6) + EDEPN IF ( LPCT2 .LE. LPCT1 ) THEN ELONG(LPCT2,6) = ELONG(LPCT2,6) * + ( EFRST + (LPCT2-LPCT1) * EDEPB ) ELONG(LPCT2,7) = ELONG(LPCT2,7) * + ( EFRST + (LPCT2-LPCT1) * EDEPB ) #if __ANAHIST__ IF ( ITYPE .EQ. 8 ) THEN #if __THIN__ PLONG(LPCT2,14) = PLONG(LPCT2,14) + WEIGHT ELSEIF ( ITYPE .EQ. 9 ) THEN PLONG(LPCT2,14) = PLONG(LPCT2,14) + WEIGHT ELSEIF ( ITYPE .EQ. 11 ) THEN PLONG(LPCT2,15) = PLONG(LPCT2,15) + WEIGHT ELSEIF ( ITYPE .EQ. 12 ) THEN PLONG(LPCT2,15) = PLONG(LPCT2,15) + WEIGHT ELSEIF ( ITYPE .EQ. 14 ) THEN PLONG(LPCT2,12) = PLONG(LPCT2,12) + WEIGHT PLONG(LPCT2,11) = PLONG(LPCT2,11) + WEIGHT ELSEIF ( ITYPE .EQ. 15 ) THEN PLONG(LPCT2,12) = PLONG(LPCT2,12) + WEIGHT PLONG(LPCT2,11) = PLONG(LPCT2,11) + WEIGHT #else PLONG(LPCT2,14) = PLONG(LPCT2,14) + 1.D0 ELSEIF ( ITYPE .EQ. 9 ) THEN PLONG(LPCT2,14) = PLONG(LPCT2,14) + 1.D0 ELSEIF ( ITYPE .EQ. 11 ) THEN PLONG(LPCT2,15) = PLONG(LPCT2,15) + 1.D0 ELSEIF ( ITYPE .EQ. 12 ) THEN PLONG(LPCT2,15) = PLONG(LPCT2,15) + 1.D0 ELSEIF ( ITYPE .EQ. 14 ) THEN PLONG(LPCT2,12) = PLONG(LPCT2,12) + 1.D0 PLONG(LPCT2,11) = PLONG(LPCT2,11) + 1.D0 ELSEIF ( ITYPE .EQ. 15 ) THEN PLONG(LPCT2,12) = PLONG(LPCT2,12) + 1.D0 PLONG(LPCT2,11) = PLONG(LPCT2,11) + 1.D0 #endif ENDIF #endif #if __THIN__ PLONG(LPCT2,6) = PLONG(LPCT2,6) + WEIGHT PLONG(LPCT2,7) = PLONG(LPCT2,7) + WEIGHT #else PLONG(LPCT2,6) = PLONG(LPCT2,6) + 1.D0 PLONG(LPCT2,7) = PLONG(LPCT2,7) + 1.D0 #endif ENDIF ELSE C NUCLEI LONGITUDINAL DEVELOPMENT FOR DEPOSIT, ENERGY, PARTICLES DLONG(LPCT1+1,6) = DLONG(LPCT1+1,6) + EDEP1 DLONG(LPCT2 ,6) = DLONG(LPCT2 ,6) + EDEPN IF ( LPCT2 .LE. LPCT1 ) THEN ELONG(LPCT2,8) = ELONG(LPCT2,8) * + ( EFRST + (LPCT2-LPCT1) * EDEPB ) #if __THIN__ PLONG(LPCT2,8) = PLONG(LPCT2,8) + WEIGHT #else PLONG(LPCT2,8) = PLONG(LPCT2,8) + 1.D0 #endif ENDIF ENDIF C LOOP OVER ALL LONGITUDINAL BINS IF ( LPCT2 .LT. LPCT1 ) THEN DO IL = LPCT1, LPCT2+1, -1 IF ( ITYPE .EQ. 5 ) THEN C MUON(+) LONGITUDINAL DEVELOPMENT FOR DEPOSIT, ENERGY, PARTICLES DLONG(IL,4) = DLONG(IL,4) + EDEPB ELONG(IL,4) = ELONG(IL,4) + ( EFRST+(IL-LPCT1)*EDEPB ) #if __THIN__ PLONG(IL,4) = PLONG(IL,4) + WEIGHT #else PLONG(IL,4) = PLONG(IL,4) + 1.D0 #endif ELSEIF ( ITYPE .EQ. 6 ) THEN C MUON(-) LONGITUDINAL DEVELOPMENT FOR DEPOSIT, ENERGY, PARTICLES DLONG(IL,4) = DLONG(IL,4) + EDEPB ELONG(IL,5) = ELONG(IL,5) + ( EFRST+(IL-LPCT1)*EDEPB ) #if __THIN__ PLONG(IL,5) = PLONG(IL,5) + WEIGHT #else PLONG(IL,5) = PLONG(IL,5) + 1.D0 #endif ELSEIF ( ITYPE .LT. 200 ) THEN C CHARGED HADRON LONGITUDINAL DEVELOPMENT FOR DEPOSIT, ENERGY, PARTICLES DLONG(IL,6) = DLONG(IL,6) + EDEPB ELONG(IL,6) = ELONG(IL,6) + ( EFRST+(IL-LPCT1)*EDEPB ) ELONG(IL,7) = ELONG(IL,7) + ( EFRST+(IL-LPCT1)*EDEPB ) #if __ANAHIST__ IF ( ITYPE .EQ. 8 ) THEN #if __THIN__ PLONG(IL,14) = PLONG(IL,14) + WEIGHT ELSEIF ( ITYPE .EQ. 9 ) THEN PLONG(IL,14) = PLONG(IL,14) + WEIGHT ELSEIF ( ITYPE .EQ. 11 ) THEN PLONG(IL,15) = PLONG(IL,15) + WEIGHT ELSEIF ( ITYPE .EQ. 12 ) THEN PLONG(IL,15) = PLONG(IL,15) + WEIGHT ELSEIF ( ITYPE .EQ. 14 ) THEN PLONG(IL,12) = PLONG(IL,12) + WEIGHT PLONG(IL,11) = PLONG(IL,11) + WEIGHT ELSEIF ( ITYPE .EQ. 15 ) THEN PLONG(IL,12) = PLONG(IL,12) + WEIGHT PLONG(IL,11) = PLONG(IL,11) + WEIGHT #else PLONG(IL,14) = PLONG(IL,14) + 1.D0 ELSEIF ( ITYPE .EQ. 9 ) THEN PLONG(IL,14) = PLONG(IL,14) + 1.D0 ELSEIF ( ITYPE .EQ. 11 ) THEN PLONG(IL,15) = PLONG(IL,15) + 1.D0 ELSEIF ( ITYPE .EQ. 12 ) THEN PLONG(IL,15) = PLONG(IL,15) + 1.D0 ELSEIF ( ITYPE .EQ. 14 ) THEN PLONG(IL,12) = PLONG(IL,12) + 1.D0 PLONG(IL,11) = PLONG(IL,11) + 1.D0 ELSEIF ( ITYPE .EQ. 15 ) THEN PLONG(IL,12) = PLONG(IL,12) + 1.D0 PLONG(IL,11) = PLONG(IL,11) + 1.D0 #endif ENDIF #endif #if __THIN__ PLONG(IL,6) = PLONG(IL,6) + WEIGHT PLONG(IL,7) = PLONG(IL,7) + WEIGHT #else PLONG(IL,6) = PLONG(IL,6) + 1.D0 PLONG(IL,7) = PLONG(IL,7) + 1.D0 #endif ELSE C NUCLEI LONGITUDINAL DEVELOPMENT FOR DEPOSIT, ENERGY, PARTICLES DLONG(IL,6) = DLONG(IL,6) + EDEPB ELONG(IL,8) = ELONG(IL,8) + ( EFRST+(IL-LPCT1)*EDEPB ) #if __THIN__ PLONG(IL,8) = PLONG(IL,8) + WEIGHT #else PLONG(IL,8) = PLONG(IL,8) + 1.D0 #endif ENDIF ENDDO ENDIF ELSE C ENERGY DEPOSIT FOR HORIZONTALLY MOVING PARTICLES IN FIRST BIN #if __THIN__ EDEP1 = PAMA(ITYPE) * (GAMMAOLD - GAMMAN) * WEIGHT #else EDEP1 = PAMA(ITYPE) * (GAMMAOLD - GAMMAN) #endif C NOW FILL IN FIRST BIN ALL ENERGY DEPOSIT IF ( ITYPE .EQ. 5 ) THEN C MUON(+) LONGITUDINAL DEVELOPMENT FOR DEPOSIT, ENERGY DLONG(LPCT1,4) = DLONG(LPCT1,4) + EDEP1 ELONG(LPCT2,4) = ELONG(LPCT2,4) + EFRST - EDEP1 ELSEIF ( ITYPE .EQ. 6 ) THEN C MUON(-) LONGITUDINAL DEVELOPMENT FOR DEPOSIT, ENERGY DLONG(LPCT1,4) = DLONG(LPCT1,4) + EDEP1 ELONG(LPCT2,5) = ELONG(LPCT2,5) + EFRST - EDEP1 ELSEIF ( ITYPE .LT. 200 ) THEN C CHARGED HADRON LONGITUDINAL DEVELOPMENT FOR DEPOSIT, ENERGY DLONG(LPCT1,6) = DLONG(LPCT1,6) + EDEP1 ELONG(LPCT2,6) = ELONG(LPCT2,6) + EFRST - EDEP1 ELONG(LPCT2,7) = ELONG(LPCT2,7) + EFRST - EDEP1 ELSE C NUCLEI LONGITUDINAL DEVELOPMENT FOR DEPOSIT, ENERGY DLONG(LPCT1,6) = DLONG(LPCT1,6) + EDEP1 ELONG(LPCT2,8) = ELONG(LPCT2,8) + EFRST - EDEP1 ENDIF ENDIF #endif ELSE C NEUTRAL PARTICLES C NEUTRAL PARTICLES KEEP THEIR ENERGY GAMMAN = GAMMA C LONGITUDINAL DISTRIBUTIONS FOR NEUTRAL HADRONS WITHOUT NEUTRINOS C THE PARTICLE IS TRACKED FROM THICKH DOWN TO THCKHN C COUNT THE PARTICLES FOR THE LONGITUDINAL DEVELOPMENT IF ( (ITYPE .GE. 7 .AND. ITYPE .LE. 32) .OR. * (ITYPE .GE. 71 .AND. ITYPE .LE. 74) ) THEN IF ( IPASC .NE. 0 ) THEN C PARTICLE ARRIVES AT DETECTOR LPCT2 = NSTEP ENDIF DO IL = LPCT1, LPCT2 #if __THIN__ ELONG(IL,6) = ELONG(IL,6) + GAMMA * PAMA(ITYPE) * WEIGHT PLONG(IL,6) = PLONG(IL,6) + WEIGHT #else ELONG(IL,6) = ELONG(IL,6) + GAMMA * PAMA(ITYPE) PLONG(IL,6) = PLONG(IL,6) + 1.D0 #endif #if __ANAHIST__ IF ( ITYPE .EQ. 10 ) THEN #if __THIN__ PLONG(IL,16) = PLONG(IL,16) + WEIGHT PLONG(IL,18) = PLONG(IL,18) + WEIGHT ELSEIF ( ITYPE .EQ. 13 ) THEN PLONG(IL,13) = PLONG(IL,13) + WEIGHT PLONG(IL,11) = PLONG(IL,11) + WEIGHT ELSEIF ( ITYPE .EQ. 16 ) THEN PLONG(IL,17) = PLONG(IL,17) + WEIGHT PLONG(IL,18) = PLONG(IL,18) + WEIGHT ELSEIF ( ITYPE .EQ. 25 ) THEN PLONG(IL,13) = PLONG(IL,13) + WEIGHT PLONG(IL,11) = PLONG(IL,11) + WEIGHT #else PLONG(IL,16) = PLONG(IL,16) + 1.D0 PLONG(IL,18) = PLONG(IL,18) + 1.D0 ELSEIF ( ITYPE .EQ. 13 ) THEN PLONG(IL,13) = PLONG(IL,13) + 1.D0 PLONG(IL,11) = PLONG(IL,11) + 1.D0 ELSEIF ( ITYPE .EQ. 16 ) THEN PLONG(IL,17) = PLONG(IL,17) + 1.D0 PLONG(IL,18) = PLONG(IL,18) + 1.D0 ELSEIF ( ITYPE .EQ. 25 ) THEN PLONG(IL,13) = PLONG(IL,13) + 1.D0 PLONG(IL,11) = PLONG(IL,11) + 1.D0 #endif ENDIF #endif ENDDO ENDIF #if __NEUTRINO__ || __NUPRIM__ C LONGITUDINAL DISTRIBUTIONS FOR NEUTRINOS C THE PARTICLE IS TRACKED FROM THICKH DOWN TO THCKHN C COUNT THE PARTICLES FOR THE LONGITUDINAL DEVELOPMENT IF ( ( ITYPE .GE. 66 .AND. ITYPE .LE. 69 ) #if __CHARM__ || __TAULEP__ * .OR. ITYPE .EQ. 133 .OR. ITYPE .EQ. 134 #endif * ) THEN IF ( IPASC .NE. 0 ) THEN C PARTICLE ARRIVES AT DETECTOR LPCT2 = NSTEP ENDIF DO IL = LPCT1,LPCT2 #if __THIN__ ELONG(IL,10) = ELONG(IL,10) + GAMMA * WEIGHT PLONG(IL,10) = PLONG(IL,10) + WEIGHT #else ELONG(IL,10) = ELONG(IL,10) + GAMMA PLONG(IL,10) = PLONG(IL,10) + 1.D0 #endif ENDDO ENDIF #endif ENDIF IF ( IRET2 .NE. 0 .AND. IRETE ) THEN C FILL REMAINING CUTTED ENERGY INTO LONGI BIN AT ENERGY CUTTING POINT LHEIGH = LPCT2 IF ( ITYPE .EQ. 5 .OR. ITYPE .EQ. 6 ) THEN #if __THIN__ DLONG(LHEIGH,5) = DLONG(LHEIGH,5) + GAMMAN*PAMA(5) * WEIGHT #else DLONG(LHEIGH,5) = DLONG(LHEIGH,5) + GAMMAN*PAMA(5) #endif ELSE IF ( ITYPE .EQ. 8 .OR. ITYPE .EQ. 9 .OR. * ITYPE .EQ. 11 .OR. ITYPE .EQ. 12 ) THEN FAC1 = 0.25D0 FAC2 = 0.75D0 ELSEIF ( ITYPE .EQ. 10 .OR. ITYPE .EQ. 16 ) THEN FAC1 = 0.5D0 FAC2 = 0.5D0 ELSE FAC1 = 1.D0 FAC2 = 0.D0 ENDIF #if __THIN__ C ADD TO THE HADRON ENERGY DEPOSIT DLONG(LHEIGH,7) = DLONG(LHEIGH,7) + ( GAMMAN*PAMA(ITYPE) * - RESTMS(ITYPE) ) * WEIGHT * FAC1 C ADD TO THE NEUTRINO DEPOSIT DLONG(LHEIGH,8) = DLONG(LHEIGH,8) + ( GAMMAN*PAMA(ITYPE) * - RESTMS(ITYPE) ) * WEIGHT * FAC2 #else C ADD TO THE HADRON ENERGY DEPOSIT DLONG(LHEIGH,7) = DLONG(LHEIGH,7) + ( GAMMAN * PAMA(ITYPE) * - RESTMS(ITYPE) ) * FAC1 C ADD TO THE NEUTRINO DEPOSIT DLONG(LHEIGH,8) = DLONG(LHEIGH,8) + ( GAMMAN * PAMA(ITYPE) * - RESTMS(ITYPE) ) * FAC2 #endif ENDIF C ELIMINATE PARTICLE FALLING BELOW ENERGY CUT RETURN ENDIF ENDIF C ELIMINATE PARTICLE FALLING BELOW ENERGY CUT IF ( IRET2 .NE. 0 .AND. IRETE ) RETURN C ELIMINATE PARTICLE MOVING OUT OF ATMOSPHERE OR EXCEEDING TIME LIMIT IF ( IRET2 .NE. 0 .AND. .NOT.IRETC ) GOTO 200 C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if __COASTUSERLIB__ C END OF TRACKING STEP pnt2id = OUTPAR(0) pnt2gen= OUTPAR(9) pnt2x = XXX pnt2y = YYY pnt2z = HAPP #if __SLANT__ pnt2d = T2 #else pnt2d = THICKH/COS( THETAP ) #endif pnt2t = OUTPAR(6) pnt2e = PAMA(pnt2id)*OUTPAR(1) #if __THIN__ pnt2w = OUTPAR(13.) #else pnt2w = 1.D0 #endif call track(pnt1x, pnt2x) #endif C TRANSPORT TO END OF TRACK IF ( IPASC .EQ. 0 ) THEN ALEVEL = H BETA = SQRT( (GAMMA-1.D0)*(GAMMA+1.D0) ) / GAMMA THICKH = THCKHN ELSE C TRANSPORT TO OBSERVATION LEVEL AND BRING TO OUTPUT C COORDINATE SYSTEM AT END OF TRACK HAS TO BE DETECTOR FRAME LEVL = 1 CALL OUTPT1 ENDIF #if __PLOTSH__ C END OF THE TRACKING STEP IF ( PLOTSH ) THEN TRX2 = OUTPAR(7) TRY2 = OUTPAR(8) TRZ2 = HAPP TRT2 = OUTPAR(6) IF ( ITYPE .EQ. 5 .OR. ITYPE .EQ. 6 ) THEN WRITE(56) TRID,TRE,TRX1,TRY1,TRZ1,TRT1,TRX2,TRY2,TRZ2,TRT2 #if __THIN__ * ,WEIGHT #endif NPLMU = NPLMU + 1 ELSE WRITE(57) TRID,TRE,TRX1,TRY1,TRZ1,TRT1,TRX2,TRY2,TRZ2,TRT2 #if __THIN__ * ,WEIGHT #endif NPLHAD = NPLHAD + 1 ENDIF IF ( DEBUG ) THEN #if __THIN__ WRITE(MDEBUG,2552) TRID,TRE,TRX1,TRY1,TRZ1,TRT1, * TRX2,TRY2,TRZ2,TRT2,WEIGHT 2552 FORMAT(' TRACKINF ',1P,6E15.5,/,40X,5E15.5) #else WRITE(MDEBUG,2552) TRID,TRE,TRX1,TRY1,TRZ1,TRT1, * TRX2,TRY2,TRZ2,TRT2 2552 FORMAT(' TRACKINF ',1P,6E15.5,/,40X,4E15.5) #endif ENDIF ENDIF #endif #if __PLOTSH2__ C END OF THE TRACKING STEP APPLY TIME CUT IF ( PLOTSH .AND. OUTPAR(6) .LT. PLTCUT ) THEN TRX2 = OUTPAR(7) TRY2 = OUTPAR(8) TRZ2 = HAPP TRT2 = OUTPAR(6) #if __THIN__ WGHT = OUTPAR(13) #endif IF ( FBOXCUT ) CALL PLTRUNC IF ( ( TRID .LE. 1.D0 .AND. TRE .GT. PLCUT(4) ) .OR. * ( ( TRID .EQ. 2.D0 .OR. TRID .EQ. 3.D0 ) .AND. * TRE .GT. PLCUT(3) ) ) THEN C X-Y AND OTHER PROJECTIONS (E.M.-> MAP 1) CALL LINPLXY( 1,TRX1,TRY1,TRX2,TRY2,WGHT ) CALL LINPLXZ( 1,TRX1,TRZ1,TRX2,TRZ2,WGHT ) CALL LINPLYZ( 1,TRY1,TRZ1,TRY2,TRZ2,WGHT ) ELSEIF ( ( TRID .EQ. 5.D0 .OR. TRID .EQ. 6.D0 ) .AND. * TRE .GT. PLCUT(2) ) THEN C X-Y AND OTHER PROJECTIONS (MU -> MAP 2) CALL LINPLXY( 2,TRX1,TRY1,TRX2,TRY2,WGHT ) CALL LINPLXZ( 2,TRX1,TRZ1,TRX2,TRZ2,WGHT ) CALL LINPLYZ( 2,TRY1,TRZ1,TRY2,TRZ2,WGHT ) ELSEIF ( TRID .GE. 7.D0 .AND. TRE .GT. PLCUT(1) ) THEN C X-Y AND OTHER PROJECTIONS (HADRONS -> MAP 3) CALL LINPLXY( 3,TRX1,TRY1,TRX2,TRY2,WGHT ) CALL LINPLXZ( 3,TRX1,TRZ1,TRX2,TRZ2,WGHT ) CALL LINPLYZ( 3,TRY1,TRZ1,TRY2,TRZ2,WGHT ) ENDIF IF ( DEBUG ) THEN WRITE(MDEBUG,2553) TRID,TRE,TRX1,TRY1,TRZ1,TRT1, * TRX2,TRY2,TRZ2,TRT2 2553 FORMAT(' TRACKINF2 ',1P,6E15.5,/,41X,4E15.5) ENDIF ENDIF #endif RETURN 200 CONTINUE C TREATMENT OF KILLED PARTICLES C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT, IF PARTICLE IS CUTTED IF ( LLONGI ) THEN C PARTICLE SUFFERED FROM ANGULAR CUT OR MOVED OUT OF ATMOSPHERE IF ( ITYPE .EQ. 5 .OR. ITYPE .EQ. 6 ) THEN #if __UPWARD__ #if __THIN__ DLONG(LPCT1+1,15) = DLONG(LPCT1+1,15) * +GAMMAOLD*PAMA(5)*WEIGHT #if __NEUTRINO__ || __NUPRIM__ ELSEIF ( ( ITYPE .GE. 66 .AND. ITYPE .LE. 69 ) #if __CHARM__ || __TAULEP__ * .OR. ITYPE .EQ. 133 .OR. ITYPE .EQ. 134 #endif * ) THEN DLONG(LPCT1+1,18) = DLONG(LPCT1+1,18) + GAMMAOLD*WEIGHT #endif ELSE IF ( ITYPE .EQ. 8 .OR. ITYPE .EQ. 9 .OR. * ITYPE .EQ. 11 .OR. ITYPE .EQ. 12 ) THEN FAC1 = 0.25D0 FAC2 = 0.75D0 ELSEIF ( ITYPE .EQ. 10 .OR. ITYPE .EQ. 16 ) THEN FAC1 = 0.5D0 FAC2 = 0.5D0 ELSE FAC1 = 1.D0 FAC2 = 0.D0 ENDIF C ADD TO THE HADRON ENERGY DEPOSIT DLONG(LPCT1+1,17) = DLONG(LPCT1+1,17) + ( GAMMAOLD*PAMA(ITYPE) * - RESTMS(ITYPE) ) * WEIGHT * FAC1 C ADD TO THE NEUTRINO DEPOSIT DLONG(LPCT1+1,18) = DLONG(LPCT1+1,18) + ( GAMMAOLD*PAMA(ITYPE) * - RESTMS(ITYPE) ) * WEIGHT * FAC2 #else DLONG(LPCT1+1,15) = DLONG(LPCT1+1,15) + GAMMAOLD * PAMA(5) #if __NEUTRINO__ || __NUPRIM__ ELSEIF ( ( ITYPE .GE. 66 .AND. ITYPE .LE. 69 ) #if __CHARM__ || __TAULEP__ * .OR. ITYPE .EQ. 133 .OR. ITYPE .EQ. 134 #endif * ) THEN DLONG(LPCT1+1,18) = DLONG(LPCT1+1,18) + GAMMAOLD #endif ELSE IF ( ITYPE .EQ. 8 .OR. ITYPE .EQ. 9 .OR. * ITYPE .EQ. 11 .OR. ITYPE .EQ. 12 ) THEN FAC1 = 0.25D0 FAC2 = 0.75D0 ELSEIF ( ITYPE .EQ. 10 .OR. ITYPE .EQ. 16 ) THEN FAC1 = 0.5D0 FAC2 = 0.5D0 ELSE FAC1 = 1.D0 FAC2 = 0.D0 ENDIF C ADD TO THE HADRON ENERGY DEPOSIT DLONG(LPCT1+1,17) = DLONG(LPCT1+1,17) + ( GAMMAOLD*PAMA(ITYPE) * - RESTMS(ITYPE) ) * FAC1 C ADD TO THE NEUTRINO DEPOSIT DLONG(LPCT1+1,18) = DLONG(LPCT1+1,18) + ( GAMMAOLD*PAMA(ITYPE) * - RESTMS(ITYPE) ) * FAC2 #endif #else /* upward */ #if __THIN__ DLONG(LPCT1,15) = DLONG(LPCT1,15) * +GAMMAOLD*PAMA(5)*WEIGHT #if __NEUTRINO__ || __NUPRIM__ ELSEIF ( ( ITYPE .GE. 66 .AND. ITYPE .LE. 69 ) #if __CHARM__ || __TAULEP__ * .OR. ITYPE .EQ. 133 .OR. ITYPE .EQ. 134 #endif * ) THEN DLONG(LPCT1,18) = DLONG(LPCT1,18) + GAMMAOLD*WEIGHT #endif ELSE IF ( ITYPE .EQ. 8 .OR. ITYPE .EQ. 9 .OR. * ITYPE .EQ. 11 .OR. ITYPE .EQ. 12 ) THEN FAC1 = 0.25D0 FAC2 = 0.75D0 ELSEIF ( ITYPE .EQ. 10 .OR. ITYPE .EQ. 16 ) THEN FAC1 = 0.5D0 FAC2 = 0.5D0 ELSE FAC1 = 1.D0 FAC2 = 0.D0 ENDIF C ADD TO THE HADRON ENERGY DEPOSIT DLONG(LPCT1,17) = DLONG(LPCT1,17) + ( GAMMAOLD*PAMA(ITYPE) * - RESTMS(ITYPE) ) * WEIGHT * FAC1 C ADD TO THE NEUTRINO DEPOSIT DLONG(LPCT1,18) = DLONG(LPCT1,18) + ( GAMMAOLD*PAMA(ITYPE) * - RESTMS(ITYPE) ) * WEIGHT * FAC2 #else DLONG(LPCT1,15) = DLONG(LPCT1,15) + GAMMAOLD * PAMA(5) #if __NEUTRINO__ || __NUPRIM__ ELSEIF ( ( ITYPE .GE. 66 .AND. ITYPE .LE. 69 ) #if __CHARM__ || __TAULEP__ * .OR. ITYPE .EQ. 133 .OR. ITYPE .EQ. 134 #endif * ) THEN DLONG(LPCT1,18) = DLONG(LPCT1,18) + GAMMAOLD #endif ELSE IF ( ITYPE .EQ. 8 .OR. ITYPE .EQ. 9 .OR. * ITYPE .EQ. 11 .OR. ITYPE .EQ. 12 ) THEN FAC1 = 0.25D0 FAC2 = 0.75D0 ELSEIF ( ITYPE .EQ. 10 .OR. ITYPE .EQ. 16 ) THEN FAC1 = 0.5D0 FAC2 = 0.5D0 ELSE FAC1 = 1.D0 FAC2 = 0.D0 ENDIF C ADD TO THE HADRON ENERGY DEPOSIT DLONG(LPCT1,17) = DLONG(LPCT1,17) + ( GAMMAOLD*PAMA(ITYPE) * - RESTMS(ITYPE) ) * FAC1 C ADD TO THE NEUTRINO DEPOSIT DLONG(LPCT1,18) = DLONG(LPCT1,18) + ( GAMMAOLD*PAMA(ITYPE) * - RESTMS(ITYPE) ) * FAC2 #endif #endif /* upward */ ENDIF ENDIF IRET2 = 1 RETURN END #endif *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE UPDATE( HNEW,THCKHN,IPAS ) C----------------------------------------------------------------------- C UPDATE(S PARTICLE PARAMETERS) C C UPDATES PARTICLE PARAMETERS TO OBSERVATION LEVEL WITH NUMBER IPAS C OR TO POINT OF INTERACTION OR DECAY (IPAS=0) C FOR CHARGED PARTICLES THE ENERGY LOSS IS COMPUTED FOR THE WHOLE STEP, C SUBDIVIDED BY THE BOUNDARIES OF THE ATMOSPHERIC LAYERS. C THE PARTICLE IS FLYING THE 1ST HALF (CHI/2) WITH INITIAL ENERGY C AND ANGLE AND THE 2ND HALF WITH FINAL ENERGY AND ANGLE. C THE TIME CALCULATION FOLLOWS THIS SIMPLIFICATION. C CHARGED PARTICLES ARE DEFLECTED IN THE EARTH MAGNETIC FIELD. C THE ANGLE OF DEFLECTION BY MULTIPLE SCATTERING IS COMPUTED ONLY C FOR MUONS/TAUS AND ONLY ONCE FOR THE WHOLE STEP AT HALF THICKNESS. C IF PARTICLES COME TO REST BY STOPPING, THEIR PATH TO THE STOPPING C POINT IS CALCULATED. #if __CERENKOV__ C CHERENKOV RADIATION IS CALCULATED ONLY FOR LOWEST OBSERVATION LEVEL #endif C THIS SUBROUTINE IS CALLED FROM AAMAIN, BOX3, MUTRAC, AND UPDATC. C ARGUMENTS: C HNEW = ALTITUDE OF PARTICLE AFTER UPDATE (CM) C THCKHN = THICKNESS OF HNEW (G/CM**2) C IPAS = 0 TRANSPORT TO END OF RANGE OF PARTICLE C .NE. 0 TRANSPORT TO PASSAGE OF OBSERVATION LEVEL IPAS C----------------------------------------------------------------------- IMPLICIT NONE #define __ATMOS2INC__ #define __CONSTAINC__ #define __ELABCTINC__ #define __GENERINC__ #define __IRETINC__ #define __LONGIINC__ #define __MAGNETINC__ #define __MUPARTINC__ #define __MUMULTINC__ #define __OBSPARINC__ #define __PAMINC__ #define __PARPARINC__ #define __PARPAEINC__ #define __RANDPAINC__ #define __RUNPARINC__ #if ( __CERENKOV__ && __CURVED__ ) || ( __AUGCERLONG__ && __CURVED__ ) #define __CORFRAMINC__ #endif #if __PLOTSH2__ && !__CURVED__ #define __PLOTSH2INC__ #endif #if __PARALLEL__ #define __STACKFINC__ #endif #include "corsika.h" DOUBLE PRECISION ACOSTH,ALPHA1,ALPHA2,ARGLOG,AUX2,BETAN, * CHIT,CDNS,CDNS1,DCHI,DENS, * DH,DT,ELOSS,ELOS2,FNORM1,FNORM2, * F1COS1,F1COS2,F1SIN1,F1SIN2, * GAMK,GAMMAN,GAMSQ,GAM0,GLCUT,GMSQM1, * HFDNS,HMIDDL,HNEW,HNEWC,OMEGA,RADINV,RATIO, * SN,SN1,SN2,SN3,SN4, * SNMIDDL1,SNMIDDL2,THCKHC,THCKHN,THICKMDL,TH0, * USW,U10,U12,U20,U22,V,VVV,V10,V12,V20,V22, * W10,W12,W20,W22 INTEGER I,IL,ILAY,IPAS #if __EHISTORY__ || __MULTITHIN__ INTEGER IK #endif LOGICAL CFLAG,MUS,TCRNKV,TFLAG DOUBLE PRECISION CDEDXM,HEIGH,RANNOR,RHOF,THICK #if !__CURVED__ DOUBLE PRECISION EDEPB,EDEPN,EDEP1,EFRST,STEPT, * FAC1,FAC2 INTEGER LPCT1,LPCT2 #if __SLANT__ DOUBLE PRECISION T1,T2,T3,THCKSI INTEGER LBIN EXTERNAL LBIN,THCKSI #if __AUGERHIST__ DOUBLE PRECISION THCKC #endif #else DOUBLE PRECISION THCKC #endif #else #if __UPWARD__ DOUBLE PRECISION CHIT2,STEPNW #endif #endif #if __EFIELD__ DOUBLE PRECISION EX0,EX1,EY0,EY1,EZ0,EZ1,X0,X1,Y0,Y1,Z0,Z1 DOUBLE PRECISION DPX0,DPX1,DPY0,DPY1,DPZ0,DPZ1,DPOT,DP1,DP21 DOUBLE PRECISION ALPHAE,EDOT0,EDOT1,FNORME,FNORM4,GAMMAI #endif #if __PLOTSH__ && !__PLOTSH2__ && !__CURVED__ REAL TRID,TRE,TRX1,TRY1,TRZ1,TRT1,TRX2,TRY2,TRZ2,TRT2 #endif #if __AUGERHIST__ INTEGER LL #endif #if __COASTUSERLIB__ && !__CURVED__ 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 SAVE EXTERNAL CDEDXM,HEIGH,RANNOR,RHOF,THICK #if __PLOTSH2__ DOUBLE PRECISION WGHT #endif #if __CERENKOV__ || __AUGCERLONG__ #if __CURVED__ DOUBLE PRECISION AUXIL,CORR,DX,DY,SINDIF,TRANS2 #endif DOUBLE PRECISION XBEG,YBEG,ZBEG,TBEG,EBEG,XEND,YEND,ZEND,TEND, * EEND,TPART,XPART,YPART,ZPART,WTPART,CTEA, * UMEAN,VMEAN,WMEAN DATA CFLAG / .TRUE. / #else DATA CFLAG / .FALSE. / #endif C CONSTANT IN DENSITY EFFECT FOR IONIZATION LOSS IN AIR DATA CDNS1 / 0.020762D0 / #if __PLOTSH2__ && !__THIN__ DATA WGHT / 1.D0 / #endif C----------------------------------------------------------------------- #if __THIN__ IF ( DEBUG ) WRITE(MDEBUG,457) * (CURPAR(I),I=0,9),WEIGHT,HNEW,THICKH,CHI,IPAS 457 FORMAT(' UPDATE: CURPAR=',1P,11E11.3,/, * 9X,'TO HEIGHT ',0P,F11.1,' THICKH=',F11.5,' CHI=',F11.4 * ,' IPAS=',I1) #else IF ( DEBUG ) WRITE(MDEBUG,457) * (CURPAR(I),I=0,9),HNEW,THICKH,CHI,IPAS 457 FORMAT(' UPDATE: CURPAR=',1P,10E11.3,/, * 9X,'TO HEIGHT ',0P,F11.1,' THICKH=',F11.5,' CHI=',F11.4 * ,' IPAS=',I1) #endif IRET2 = 1 IRETE = .FALSE. C TOTAL HEIGHT DIFFERENCE #if __UPWARD__ DH = H - HNEW #else DH = MAX( H - HNEW, 1.D-10 ) #endif ACOSTH = ABS( COSTHE ) C ATMOSPHERE THICKNESS TRAVERSED #if __CURVED__ && __UPWARD__ IF ( ACOSTH .GT. 0.003D0 .AND. ABS(DH) .GT. 1.D-10 ) THEN C NORMAL TREATMENT FOR NON-HORIZONTAL PARTICLE (INCLINATION > 0.2 DEG) #endif DCHI = MAX( 0.D0, (THCKHN - THICKH) / COSTHE ) C TOTAL PATH FOR UNDEFLECTED PARTICLE SN = DH / COSTHE C GEOMETRICAL MIDDLE CDH HMIDDL = H - 0.5D0*DH C MIDDLE OF THICKNESS THICKMDL = THICKH + 0.5D0*DCHI*COSTHE HMIDDL = HEIGH( THICKMDL ) SNMIDDL1 = ((H-HMIDDL))/COSTHE #if __CURVED__ && __UPWARD__ ELSE C TREATMENT OF NEARLY HORIZONTAL PARTICLE (INCLINATION < 0.2 DEG) C TOTAL PATH FOR UNDEFLECTED PARTICLE SN = CHI / RHOF( H ) HNEW = H - SN * COSTHE THCKHN = THICK( HNEW ) C MIDDLE OF PATH SNMIDDL1 = SN * 0.5D0 HMIDDL = H - SNMIDDL1 * COSTHE THICKMDL = THICK( HMIDDL ) ENDIF #endif SNMIDDL2 = SN - SNMIDDL1 SN1 = 0.5D0 * SNMIDDL1 HNEWC = HNEW #if !__CURVED__ #if __PLOTSH__ || __PLOTSH2__ IF ( PLOTSH ) THEN C BEGINNING OF TRACKING STEP TRID = ITYPE TRE = PAMA(ITYPE)*GAMMA TRX1 = X TRY1 = Y TRZ1 = H TRT1 = T ENDIF #endif #if __COASTUSERLIB__ C BEGINNING OF TRACKING STEP pnt1id = ITYPE pnt1gen = GEN pnt1x = X - XOFF(NOBSLV) pnt1y = Y - YOFF(NOBSLV) pnt1z = H #if __SLANT__ pnt1d = THCKSI( X*STHCPH + Y*STHSPH - H*CTH + RLOFF ) #else pnt1d = THICKH/COS( THETAP ) #endif pnt1t = T pnt1e = PAMA(ITYPE)*GAMMA #if __THIN__ pnt1w = WEIGHT #else pnt1w = 1.D0 #endif #endif #endif C CALCULATE KINETIC ENERGY CUT IF ( ITYPE .EQ. 5 .OR. ITYPE .EQ. 6 .OR. * ITYPE .EQ. 131 .OR. ITYPE .EQ. 132 ) THEN MUS = .TRUE. GLCUT = ELCUT(2) / PAMA(ITYPE) + 1.D0 ELSE MUS = .FALSE. #if __NEUTRINO__ || __NUPRIM__ IF ( ( ITYPE .GE. 66 .AND. ITYPE .LE. 69 ) #if __CHARM__ || __TAULEP__ * .OR. ITYPE .EQ. 133 .OR. ITYPE .EQ. 134 #endif * ) THEN C NEUTRINOS GLCUT = ELCUT(1) ELSE C HADRONS GLCUT = ELCUT(1) / PAMA(ITYPE) + 1.D0 ENDIF #else GLCUT = ELCUT(1) / PAMA(ITYPE) + 1.D0 #endif ENDIF C CALCULATE THE ENERGY LOSS FOR CHARGED PARTICLES IF ( SIGNUM(ITYPE) .NE. 0.D0 ) THEN C LOOK WITHIN WHICH LAYER THE PARTICLE STARTS IF ( H .LE. HLAY(2) ) THEN ILAY = 1 TH0 = THICKH ELSEIF ( H .LE. HLAY(3) ) THEN ILAY = 2 TH0 = THICKH ELSEIF ( H .LE. HLAY(4) ) THEN ILAY = 3 TH0 = THICKH ELSE ILAY = 4 TH0 = MAX( THICKH, THICKL(5) ) ENDIF C SET START VALUES FOR ITERATION GAM0 = GAMMA #if __UPWARD__ IF ( COSTHE .LT. 0.D0 ) ILAY = ILAY + 1 #if __CURVED__ IF ( ACOSTH .GT. 0.003D0 ) THEN C NORMAL TREATMENT FOR NON-HORIZONTAL PARTICLE (INCLINATION > 0.2 DEG) #endif #endif HFDNS = H IL = ILAY C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 1 CONTINUE GAM0 = MAX( GAM0, 1.0001D0 ) GAMSQ = GAM0**2 GMSQM1 = GAMSQ - 1.D0 C ENERGY LOSS BY IONIZATION IF ( MUS ) THEN C DENSITY EFFECT PARAMETERIZATION (R.P. KOKOULIN, 2006) CDNS = CDNS1 * RHOF(HFDNS) IF ( MT .EQ. 1 ) THEN C MUON ARGLOG = GMSQM1**2/((GAM0*C(16)+1.D0)*(1.D0+GMSQM1*CDNS)) ELSE C TAU LEPTON ARGLOG = GMSQM1**2/((GAM0*C(18)+1.D0)*(1.D0+GMSQM1*CDNS)) ENDIF ELOSS = C(22) * ( GAMSQ * (0.5D0*LOG( ARGLOG )+C(23)) * / GMSQM1 - 1.D0 ) C ADD ENERGY LOSS OF SUBTHRESHOLD BEMSSTRAHLUNG AND PAIR PRODUCTION AUX2 = CDEDXM( PAMA(ITYPE)*GAM0 ) IF (DEBUG) WRITE(MDEBUG,*) 'UPDATE: ELOSS,DEDXM=',ELOSS,AUX2 ELOSS = ELOSS + AUX2 ELSE ELOSS = SIGNUM(ITYPE)**2 * C(22) * ( GAMSQ * (LOG( GMSQM1 ) * - 0.5D0 * LOG( GAM0 * 2.D0 * PAMA(2)/PAMA(ITYPE) * + 1.D0 + (PAMA(2)/PAMA(ITYPE))**2 ) * + C(23)) / GMSQM1 - 1.D0 ) IF (DEBUG) WRITE(MDEBUG,*) 'UPDATE: ELOSS=',ELOSS ENDIF ELOS2 = ELOSS / ( PAMA(ITYPE) * ACOSTH ) C LOOK WHETHER PARTICLE PENETRATES LAYER BOUNDARY #if __UPWARD__ IF ( COSTHE .LT. 0.D0 ) THEN IF ( THICKL(IL) .GT. THCKHN ) THEN IF ( IL .GT. 4 ) THEN GAM0 = GAM0 - ELOS2 * TH0 ELSE GAM0 = GAM0 - ELOS2 * ( TH0 - THICKL(IL) ) ENDIF IF ( GAM0 .LE. 1.D0 ) THEN GAMMAN = 1.0001D0 GOTO 3 ENDIF TH0 = THICKL(IL) HFDNS = HLAY(IL) IL = IL + 1 IF ( IL .LE. 5 ) GOTO 1 ENDIF C GAMMA VALUE FOR CHARGED PARTICLES AT END OF STEP GAMMAN = GAM0 - ELOS2 * (TH0 - THCKHN ) ELSEIF ( COSTHE .GT. 0.D0 ) THEN #endif IF ( IL .GT. 1 .AND. THICKL(IL) .LT. THCKHN ) THEN C CALCULATE NEW START VALUES AT LAYER BOUNDARY GAM0 = GAM0 - ELOS2 * (THICKL(IL) - TH0) IF ( GAM0 .LE. 1.D0 ) THEN GAMMAN = 1.0001D0 GOTO 3 ENDIF TH0 = THICKL(IL) HFDNS = HLAY(IL) IL = IL - 1 GOTO 1 ENDIF C GAMMA VALUE FOR CHARGED PARTICLES AT END OF STEP GAMMAN = GAM0 - ELOS2 * (THCKHN - TH0) #if __PARALLEL__ C KEEP GAMMAN ABOVE 1.0 IF ( GAMMAN .LT. 1.D0 ) GAMMAN = 1.0001D0 #endif #if __UPWARD__ ENDIF #endif 3 CONTINUE IF ( DEBUG ) WRITE(MDEBUG,453) * SNGL(GAM0),SNGL(ELOS2),SNGL(THCKHN),SNGL(TH0) 453 FORMAT(' UPDATE: GAM0,ELOS2,THCKHN,TH0=',4E15.8) #if __CURVED__ && __UPWARD__ ELSE C TREATMENT OF NEARLY HORIZONTAL PARTICLE (INCLINATION < 0.2 DEG) GAM0 = MAX( GAM0, 1.0001D0 ) GAMSQ = GAM0**2 GMSQM1 = GAMSQ - 1.D0 C ENERGY LOSS BY IONIZATION IF ( MUS ) THEN CDNS = CDNS1 * RHOF(H) IF ( MT .EQ. 1 ) THEN C MUON ARGLOG = GMSQM1**2/((GAM0*C(16)+1.D0)*(1.D0+GMSQM1*CDNS)) ELSE C TAU LEPTON ARGLOG = GMSQM1**2/((GAM0*C(18)+1.D0)*(1.D0+GMSQM1*CDNS)) ENDIF C ADD ENERGY LOSS OF SUBTHRESHOLD BEMSSTRAHLUNG AND PAIRPRODUCTION AUX2 = CDEDXM( PAMA(ITYPE)*GAM0 ) IF ( DEBUG ) WRITE(MDEBUG,*) * 'UPDATE: ELOSS,DEDXM=',ELOSS,AUX2 ELOSS = ELOSS + AUX2 ELSE ELOSS = SIGNUM(ITYPE)**2 * C(22) * ( GAMSQ * (LOG( GMSQM1 ) * - 0.5D0 * LOG( GAM0 * 2.D0 * PAMA(2)/PAMA(ITYPE) * + 1.D0 + (PAMA(2)/PAMA(ITYPE))**2 ) * + C(23)) / GMSQM1 - 1.D0 ) IF ( DEBUG ) WRITE(MDEBUG,*) 'UPDATE: ELOSS=',ELOSS ENDIF CHIT2 = SN * RHOF( H ) GAMMAN = MAX( 1.0001D0, GAM0 - ELOSS * CHIT2 / PAMA(ITYPE) ) ENDIF #endif ELSE C NO LOSS FOR NEUTRAL PARTICLES GAMMAN = GAMMA ENDIF #if __EFIELD__ C SET X0,Y0 RELATIVE TO MIDDLE OF LOWEST OBSERVATION LEVEL #if __CURVED__ X0 = X Y0 = Y #else X0 = X - XOFF(NOBSLV) Y0 = Y - YOFF(NOBSLV) #endif Z0 = H C BETA IS LORENTZ BETA VALUE GAMMAI = SQRT( (1.D0 + BETA) * (1.D0 - BETA) ) C SIGNUM(ITYPE) = -1 FOR NEGATIVE CHARGED, = +1 FOR POSITIVE CHARGED FNORME = SIGNUM(ITYPE) * GAMMAI / BETA**2 C ATTENTION! DEFINITION OF Y,Z ACCORDING TO HADRONIC PART CALL ELFIELD( X0,Y0,Z0, EX0,EY0,EZ0 ) C THEREFORE USE INVERTED FIELD FOR EY AND EZ C CONVERSION VOLT TO GV GIVES FACTOR 1.D-9 EX0 = EX0 * 1.D-9 / PAMA(ITYPE) !in GV/cm EY0 = -EY0 * 1.D-9 / PAMA(ITYPE) EZ0 = -EZ0 * 1.D-9 / PAMA(ITYPE) EDOT0= EX0*PHIX + EY0*PHIY + EZ0*COSTHE DPX0 = EX0 - EDOT0 * PHIX DPY0 = EY0 - EDOT0 * PHIY DPZ0 = EZ0 - EDOT0 * COSTHE C STEPSIZE LIMITATION BECAUSE OF DIRECTION CHANGE IN EL. FIELD C OR BACAUSE OF ENERGY CHANGE IM EL.FIELD IS NOT RELEVANT FOR HADRONIC C PARTICLES BECAUSE OF THEIR MUCH LARGER MASS COMPARED TO EM PARTICLES #endif #if !__AUGERHIST__ IF ( LLONGI .OR. CFLAG ) THEN #endif C PARTICLE HAS TO BE TRACKED TO THE CUTOFF ENERGY FOR CHERENKOV PHOTONS C OR FOR LONGITUDINAL DISTRIBUTIONS (AS NEUTRAL DO NOT LOOSE ENERGY IN C UPDATE, THIS CONDITION IS FULFILLED BY CHARGED PARTICLES ONLY) IF ( SIGNUM(ITYPE) .NE. 0.D0 .AND. GAMMAN .LT. GLCUT ) THEN GAMMAN = 0.9D0 + GLCUT * 0.1D0 C SET START VALUES FOR ITERATION IL = ILAY CHIT = 0.D0 GAM0 = GAMMA #if __UPWARD__ && __CURVED__ IF ( ACOSTH .GT. 0.003D0 .AND. ABS(DH) .GT. 1.D-10 ) THEN C NORMAL TREATMENT FOR NON-HORIZONTAL PARTICLE (INCLINATION > 0.2 DEG) #endif TH0 = MAX( THICKH, THICKL(5) ) HFDNS = H 2 CONTINUE GAM0 = MAX( GAM0, 1.0001D0 ) GAMSQ = GAM0**2 GMSQM1 = GAMSQ - 1.D0 C ENERGY LOSS BY IONIZATION IF ( MUS ) THEN C DENSITY EFFECT PARAMETERIZATION (R.P. KOKOULIN, 2006) CDNS = CDNS1 * RHOF(HFDNS) IF ( MT .EQ. 1 ) THEN C MUON ARGLOG = GMSQM1**2/((GAM0*C(16)+1.D0)*(1.D0+GMSQM1*CDNS)) ELSE C TAU LEPTON ARGLOG = GMSQM1**2/((GAM0*C(18)+1.D0)*(1.D0+GMSQM1*CDNS)) ENDIF ELOSS = C(22) * ( GAMSQ * (0.5D0*LOG( ARGLOG )+C(23)) * / GMSQM1 - 1.D0 ) C ADD ENERGY LOSS OF SUBTHRESHOLD BEMSSTRAHLUNG AND PAIR PRODUCTION AUX2 = CDEDXM( PAMA(ITYPE)*GAM0 ) IF ( DEBUG ) WRITE(MDEBUG,*) * 'UPDATE: ELOSS,AUX2=',ELOSS,AUX2 ELOSS = ELOSS + AUX2 ELSE ELOSS = SIGNUM(ITYPE)**2 * C(22) * ( GAMSQ * (LOG( GMSQM1 ) * - 0.5D0 * LOG( GAM0 * 2.D0 * PAMA(2)/PAMA(ITYPE) * + 1.D0 + (PAMA(2)/PAMA(ITYPE))**2 ) * + C(23)) / GMSQM1 - 1.D0 ) IF ( DEBUG ) WRITE(MDEBUG,*) 'UPDATE: ELOSS=',ELOSS ENDIF ELOS2 = ELOSS / ( PAMA(ITYPE) * ACOSTH ) GAMK = GAM0 - ELOS2 * (THICKL(IL) - TH0) IF ( DEBUG ) WRITE(MDEBUG,*) 'UPDATE: ELOS2,GAMK=', * SNGL(ELOS2),SNGL(GAMK) C LOOK WHETHER PARTICLE PENETRATES LAYER BOUNDARY IF ( GAMMAN .LT. GAMK ) THEN #if __UPWARD__ IF ( IL .LT. 4 .AND. COSTHE .LT. 0.D0 ) THEN C CALCULATE PORTION OF RANGE AND NEW START VALUES AT LAYER BOUNDARY CHIT = CHIT + (THICKL(IL) - TH0) / COSTHE GAM0 = GAMK TH0 = THICKL(IL) HFDNS = HLAY(IL) IL = IL + 1 IF ( IL .LE. 5 ) GOTO 2 ELSEIF ( IL .GT. 1 .AND. COSTHE .GT. 0.D0 ) THEN #else IF ( IL. GT. 1 ) THEN #endif C CALCULATE PORTION OF RANGE AND NEW START VALUES AT LAYER BOUNDARY CHIT = CHIT + (THICKL(IL) - TH0) / COSTHE GAM0 = GAMK TH0 = THICKL(IL) HFDNS = HLAY(IL) IL = IL - 1 GOTO 2 ENDIF ENDIF C PENETRATED MATTER THICKNESS CHI = CHIT + (GAM0 - GAMMAN) / ( ELOS2 * ACOSTH ) C CALCULATE CORRECTED PATH PARAMETERS THCKHC = THICKH + COSTHE * CHI IF ( DEBUG ) WRITE(MDEBUG,*) 'UPDATE: GAMMAN,CHI,TRHCKHC=', * SNGL(GAMMAN),SNGL(CHI),SNGL(THCKHC) #if __UPWARD__ IF ( COSTHE .LT. 0.D0 ) THEN THCKHC = MAX( THCKHC, THCKHN ) IF ( PRMPAR(15) .LT. 0.D0 ) THEN IF ( THCKHC .LT. THCKOB(1) ) THEN IF ( DEBUG ) WRITE(MDEBUG,*) * 'UPDATE: THCKHC CHANGED FROM', * SNGL(THCKHC),' TO',SNGL(THCKOB(1)) THCKHC = THCKOB(1) ENDIF ENDIF ELSE THCKHC = MIN( THCKHC, THCKHN ) IF ( PRMPAR(15) .GE. 0.D0 ) THEN IF ( THCKHC .GT. THCKOB(1) ) THEN IF ( DEBUG ) WRITE(MDEBUG,*) * 'UPDATE: THCKHC CHANGED FROM', * SNGL(THCKHC),' TO',SNGL(THCKOB(1)) THCKHC = THCKOB(1) ENDIF ENDIF ENDIF #else THCKHC = MIN( THCKHC, THCKHN ) #endif CHI = (THCKHC - THICKH) / COSTHE HNEWC = HEIGH( THCKHC ) DT = SN / (C(25) * BETA * GAMMA) RATIO = 0.5D0 * (H-HNEWC) / DH #if __UPWARD__ DH = H - HNEWC #else DH = MAX( H - HNEWC, 1.D-10 ) #endif SN = DH / COSTHE C GEOMETRICAL MIDDLE CDH HMIDDL = H - 0.5D0 * DH C MIDDLE OF THICKNESS THICKMDL = THICKH + 0.5D0 * CHI * COSTHE HMIDDL = HEIGH( THICKMDL ) SNMIDDL1 = ( H - HMIDDL ) / COSTHE IF ( DEBUG ) WRITE(MDEBUG,*) * 'UPDATE: CHI,THICKMDL,HMIDDL,SNMIDDL1=', * SNGL(CHI),SNGL(THICKMDL),SNGL(HMIDDL),SNGL(SNMIDDL1) #if __CURVED__ && __UPWARD__ ELSE C TREATMENT OF NEARLY HORIZONTAL PARTICLE (INCLINATION < 0.2 DEG) GAM0 = MAX( GAM0, 1.0001D0 ) GAMSQ = GAM0**2 GMSQM1 = GAMSQ - 1.D0 C ENERGY LOSS BY IONIZATION IF ( MUS ) THEN C DENSITY EFFECT PARAMETERIZATION (R.P. KOKOULIN, 2006) CDNS = CDNS1 * RHOF(H) IF ( MT .EQ. 1 ) THEN C MUON ARGLOG = GMSQM1**2 / ( (GAM0*C(16)+1.D0) * * (1.D0+GMSQM1*CDNS) ) ELSE C TAU LEPTON ARGLOG = GMSQM1**2 / ( (GAM0*C(18)+1.D0) * * (1.D0+GMSQM1*CDNS) ) ENDIF ELOSS = C(22) * ( GAMSQ * (0.5D0*LOG( ARGLOG )+C(23)) * / GMSQM1 - 1.D0 ) C ADD ENERGY LOSS OF SUBTHRESHOLD BEMSSTRAHLUNG AND PAIRPRODUCTION AUX2 = CDEDXM( PAMA(ITYPE)*GAM0 ) IF ( DEBUG ) WRITE(MDEBUG,*) * 'UPDATE: ELOSS,DEDXM=',ELOSS,AUX2 ELOSS = ELOSS + AUX2 ELSE ELOSS = SIGNUM(ITYPE)**2 * C(22) * ( GAMSQ * (LOG(GMSQM1) * - 0.5D0 * LOG( GAM0 * 2.D0 * PAMA(2)/PAMA(ITYPE) * + 1.D0 + (PAMA(2)/PAMA(ITYPE))**2 ) * + C(23)) / GMSQM1 - 1.D0 ) IF ( DEBUG ) WRITE(MDEBUG,*) 'UPDATE: ELOSS=',ELOSS ENDIF C PENETRATED MATTER THICKNESS CHIT = ( GAM0 - GAMMAN ) * PAMA(ITYPE) / ELOSS STEPNW = CHIT / RHOF( H ) HNEWC = H - STEPNW * COSTHE IF ( DEBUG ) WRITE(MDEBUG,*) 'UPDATE: HNEWC,GAMMAN,CHIT=', * SNGL(HNEWC),SNGL(GAMMAN),SNGL(CHIT) SNMIDDL1 = 0.5D0 * STEPNW HMIDDL = H - SNMIDDL1 * COSTHE THCKHC = THICK( HNEWC ) C CALCULATE CORRECTED PATH PARAMETERS SN = STEPNW DT = SN / (C(25) * BETA * GAMMA) RATIO = 0.5D0 * CHIT / CHI CHI = CHIT C MIDDLE OF THICKNESS THICKMDL = THICK( HMIDDL ) IF ( DEBUG ) WRITE(MDEBUG,*) 'UPDATE: CHIT,STEPNW=', * SNGL(CHIT),SNGL(STEPNW) ENDIF #endif SNMIDDL2 = SN - SNMIDDL1 SN1 = 0.5D0 * SNMIDDL1 TFLAG = .TRUE. ELSE TFLAG = .FALSE. ENDIF #if !__AUGERHIST__ ELSE IF ( GAMMAN .LT. GLCUT ) THEN C REJECT ALL PARTICLES IF BELOW KINETIC ENERGY CUT IF ( DEBUG ) WRITE(MDEBUG,*) * 'UPDATE: PARTICLE TYPE',ITYPE,' BELOW ENERGY CUT' IRETE = .TRUE. GOTO 1111 ENDIF ENDIF #endif C----------------------------------------------------------------------- #if !__CURVED__ IF ( IPAS .EQ. 0 ) THEN #endif C UPDATE TO THE END POINT OF THE TRACK IF ( MUS ) THEN C COULOMB SCATTERING ANGLE (FOR MUONS/TAUS ONLY) IF ( FMOLI) THEN C TREAT MUON/TAU MULTIPLE SCATTERING BY MOLIERE THEORY (SEE GEANT) C CALCULATE AVERAGE DENSITY AND NUMBER OF SCATTERING (OMEGA) #if __CURVED__ && __UPWARD__ IF ( ACOSTH .GT. 0.003D0 .AND. ABS(DH) .GT. 1.D-10 ) THEN C NORMAL TREATMENT FOR NON-HORIZONTAL PARTICLE (INCLINATION > 0.2 DEG) DENS = COSTHE * CHI / DH ELSE DENS = RHOF( HNEW ) ENDIF #else IF ( DH .NE. 0.D0 ) THEN DENS = COSTHE * CHI / DH ELSE DENS = RHOF( HNEW ) ENDIF #endif OMEGA = OMC * CHI / BETA**2 IF ( OMEGA .LE. 20.D0 ) THEN C FEW SCATTERING EVENTS, APPLY PLURAL COULOMB SCATTERING CALL MUCOUL( OMEGA,DENS ) ELSE C ENOUGH SCATTERING EVENTS, APPLY MOLIERE''S THEORY CALL MMOLIE( OMEGA,DENS ) ENDIF ELSE C TREAT MUON MULTIPLE SCATTERING BY GAUSS DISTRIBUTION VSCAT = RANNOR( 0.D0, C(30) * SQRT( CHI/C(21) ) * / (PAMA(ITYPE) * GAMMA * BETA**2) ) ENDIF IF ( FIRSTI .AND. .NOT. TMARGIN ) THEN C IF WE TRACK MUON AS PRIMARY BEFORE FIRST INTERACTION, NO SCATTERING VSCAT = 0.D0 PHISCT = 0.D0 ELSE CALL RMMARD( RD,1,1 ) PHISCT = RD(1) * PI2 ENDIF V = VSCAT IF ( DEBUG ) WRITE(MDEBUG,*) 'UPDATE: VSCAT=',SNGL(VSCAT), * ' PHISCT=',SNGL(PHISCT) ENDIF #if !__AUGERHIST__ IF ( LLONGI .OR. CFLAG ) THEN #endif IF ( TFLAG ) THEN HNEW = HNEWC THCKHN = THCKHC IF ( DEBUG ) WRITE(MDEBUG,*) * 'UPDATE: CHANGED HNEW=',SNGL(HNEW) ENDIF C CHERENKOV RADIATION: LOOK, WHETHER PATH ENDS ABOVE LOWEST OBSERV.LEVEL #if ( __CURVED__ && __CERENKOV__ ) || ( __CURVED__ && __AUGCERLONG__ ) TCRNKV = .TRUE. #else #if __UPWARD__ #if __CURVED__ IF ( ( PRMPAR(15).LT.0.D0 .AND. HNEW.LT.OBSLEV(NOBSLV) ) * .OR. ( PRMPAR(15).GE.0.D0 .AND. HNEW.GT.OBSLEV(NOBSLV) ) )THEN #else IF ( ( PRMPAR(2).LT.0.D0 .AND. HNEW.LT.OBSLEV(NOBSLV) ) * .OR. ( PRMPAR(2).GE.0.D0 .AND. HNEW.GT.OBSLEV(NOBSLV) ) ) THEN #endif #else IF ( HNEW .GT. OBSLEV(NOBSLV) ) THEN #endif TCRNKV = .TRUE. ELSE TCRNKV = .FALSE. ENDIF #endif #if !__AUGERHIST__ ENDIF #endif #if !__CURVED__ ELSE C UPDATE TO THE OBSERVATION LEVELS IF ( MUS ) THEN C COULOMB SCATTERING ANGLE (FOR MUONS ONLY) V = VSCAT * SQRT( DCHI / CHI ) ENDIF #if !__AUGERHIST__ IF ( LLONGI .OR. CFLAG ) THEN #endif C CHERENKOV RADIATION: LOOK, WHETHER LOWEST OBSERVATION LEVEL IF ( IPAS .EQ. NOBSLV ) THEN TCRNKV = .TRUE. ELSE TCRNKV = .FALSE. ENDIF #if !__AUGERHIST__ ENDIF #endif ENDIF #endif C REJECT ALL PARTICLES IF BELOW KINETIC ENERGY CUT #if !__AUGERHIST__ IF ( LLONGI .OR. CFLAG ) THEN #endif #if __CERENKOV__ IF ( GAMMAN .LT. GLCUT .AND. .NOT.TCRNKV ) THEN IF ( DEBUG ) WRITE(MDEBUG,*) 'UPDATE: PARTICLE ',ITYPE, * ' BELOW ENERGY CUT, CHERENKOV LIGHT NOT CALCULATED' #else IF ( GAMMAN .LT. GLCUT .AND. .NOT.TCRNKV ) THEN IF ( DEBUG ) WRITE(MDEBUG,*) 'UPDATE: PARTICLE ',ITYPE, * ' BELOW ENERGY CUT' #endif #if __CURVED__ OUTPAR(1) = GAMMAN #endif IRETE = .TRUE. GOTO 1111 ENDIF #if !__AUGERHIST__ ENDIF #endif C----------------------------------------------------------------------- C TRANSPORT CHARGED PARTICLES THE FIRST PORTION OF STEP IF ( SIGNUM(ITYPE) .NE. 0.D0 ) THEN C CHARGED PARTICLES SUFFER IONIZATION LOSS, DEFLECTION IN MAGNETIC C FIELD AND MUONS IN ADDITION DO MULTIPLE COULOMB SCATTERING. C DEFLECTION IN EARTH MAGNETIC FIELD ON FIRST HALF OF STEP ALPHA1 = SIGNUM(ITYPE) * * MIN( 1.D0, 2.D0*SN1*BNORMC /(PAMA(ITYPE)*BETA*GAMMA) ) U10 = PHIX V10 = -PHIY W10 = COSTHE FNORM1 = 1.D0 - 0.5D0*ALPHA1**2 * (1.D0 - 0.75D0*ALPHA1**2) F1COS1 = ( 1.D0 - FNORM1 ) * COSB F1SIN1 = ( 1.D0 - FNORM1 ) * SINB VVV = V10 * ALPHA1 * FNORM1 USW = U10 * SINB - W10 * COSB U12 = U10 - F1SIN1 * USW + VVV * SINB V12 = FNORM1 * ( V10 - ALPHA1 * USW ) W12 = W10 + F1COS1 * USW - VVV * COSB RADINV = 1.5D0 - 0.5D0 * ( U12**2 + V12**2 + W12**2 ) W12 = MIN( 1.D0, RADINV * W12 ) IF ( W12 .LE. C(29) ) THEN IF ( DEBUG ) WRITE(MDEBUG,*) * 'UPDATE: PARTICLE',ITYPE,' BELOW ANGLE CUT 1' IRETE = .FALSE. GOTO 1111 ENDIF #if __CURVED__ || __UPWARD__ IF ( ABS( W12 ) .GT. 0.003D0 ) THEN C NORMAL TREATMENT FOR NON-HORIZONTAL PARTICLE (INCLINATION > 0.2 DEG) SN2 = SN1 * ACOSTH / ABS( W12 ) ELSE SN2 = SN1 ENDIF #else SN2 = SN1 * COSTHE / W12 #endif U12 = RADINV * U12 V12 = RADINV * V12 #if __CERENKOV__ || __AUGCERLONG__ C CHERENKOV RADIATION: FILL PARTICLE COORDINATES IF ( TCRNKV #if __PARALLEL__ * .AND. .NOT. (FIRSTI .AND. JCOUNT .GT. 1 ) #endif * ) THEN C ..BEG ARE THE COORDINATES AT BEGIN OF THIS STEP C ..PART ARE THE COORDINATES AT END OF THIS STEP #if __CURVED__ IF ( .NOT. DETSYS ) THEN C TRANSFORM INTO DETECTOR FRAME C FIRST CALCULATE STEP TO X AND Y ALONG EARTH SURFACE DX = +SN1 * U10 + SN2 * U12 DY = -SN1 * V10 - SN2 * V12 TRANS2 = DX**2 + DY**2 AUXIL = SQRT( TRANS2 + (C(1)+HMIDDL)**2 ) SINDIF = SQRT( TRANS2 ) / AUXIL IF ( SINDIF .GT. 0.D0 ) THEN CORR = C(1) * ASIN( SINDIF ) / (AUXIL*SINDIF) ELSE CORR = 1.D0 ENDIF XPART = X + DX*CORR YPART = Y + DY*CORR C CALCULATE ANGLE BETWEEN THE ACTUAL LOCAL AND THE APPARENT COORDINATE C SYSTEM (IMPORTANT FOR DECIDING IN CERENK IF FIRST OR SECOND CALL C AND TO CALCULATE THE INTERMEDIATE DIF ANGLE) AUXIL = SQRT( X**2 + Y**2 ) CTEA = COS( AUXIL/C(1) ) C NOW TRANSFORM THEM IN DETECTOR FRAME. ATTENTION: ANGLE MIGHT BE C VERY LARGE, THEREFORE APPROXIMATION TAN(X) EQUAL X IS NOT ALLOWED! C SINCE X = X(HAPP), DON''T TRANSFORM X AND Y HERE BUT IN CERENK XBEG = X YBEG = Y ELSE #endif CTEA = 1.D0 XBEG = X YBEG = Y XPART = X + SN1 * U10 + SN2 * U12 YPART = Y - SN1 * V10 - SN2 * V12 #if __CURVED__ ENDIF #endif TPART = T + ( SN1 + SN2 ) / ( C(25) * BETA ) CDH ZPART = H - DH * 0.5D0 ZPART = HMIDDL UMEAN = 0.5D0 * (U10 + U12) VMEAN = 0.5D0 * (V10 + V12) WMEAN = 0.5D0 * (W10 + W12) C SET OTHER FUNCTION ARGUMENTS TBEG = T ZBEG = H EBEG = PAMA(ITYPE)*GAMMA TEND = TPART XEND = XPART YEND = YPART ZEND = ZPART EEND = PAMA(ITYPE)*GAMMAN #if __THIN__ WTPART = WEIGHT #else WTPART = 1.D0 #endif CALL CERENK( SN1+SN2,UMEAN,-VMEAN,WMEAN,EBEG, * EEND-0.5D0*(EEND-EBEG), * XBEG,YBEG,ZBEG,XEND,YEND,ZEND,TBEG,TEND, * PAMA(ITYPE),SIGNUM(ITYPE),WTPART,CTEA ) ENDIF #endif C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C CHANGE DIRECTION BY COULOMB SCATTERING (FOR MUONS ONLY) IF ( MUS ) THEN C BEFORE SCATTERING : DIRECTION COSINES ARE U12,V12,W12 CALL ADDANG3( W12,U12,V12, COS( V ),-PHISCT, W20,U20,V20 ) IF ( W20 .LE. C(29) ) THEN IF ( DEBUG ) WRITE(MDEBUG,*) 'UPDATE: MUON BELOW ANGLE CUT' IRETE = .FALSE. GOTO 1111 ENDIF C AFTER SCATTERING: DIRECTION COSINES ARE U20,V20,W20 #if __CURVED__ #if __UPWARD__ IF ( ( PRMPAR(15).LT.0.D0 .AND. HNEW.LT.OBSLEV(1) ) .OR. * ( PRMPAR(15).GE.0.D0 .AND. HNEW.GT.OBSLEV(1) ) ) THEN #else IF ( HNEW .GT. OBSLEV(1) ) THEN #endif #else IF ( IPAS .EQ. 0 ) THEN #endif C CORRECT ARRIVAL HEIGHT ACCORDING TO INTERACTION OR DECAY IF ( FDECAY ) THEN C IN CASE OF DECAY THE PATH LENGTH SNMIDDL2 IS KEPT CONSTANT HNEW = HMIDDL - SNMIDDL2 * W20 #if __UPWARD__ C LIMIT THE STEP FOR THE CASE THE SCATTERING ANGLE IS LARGE IF ( W20 .LT. 0.D0 ) THEN HNEW = MIN( HNEW, HLAY(6) ) ELSE HNEW = MAX( HNEW, HLAY(1) ) ENDIF THCKHN = THICK( HNEW ) IF ( DEBUG ) WRITE(MDEBUG,*) * 'UPDATE DECAY: HMIDDL,THCKHN,W20=', * SNGL(HMIDDL),SNGL(THCKHN),SNGL(W20) #if __CURVED__ IF ( ABS( W20 ) .GT. 0.003D0 ) THEN C NORMAL TREATMENT FOR NON-HORIZONTAL PARTICLE (INCLINATION > 0.2 DEG) CHI = 0.5D0 * CHI + (THCKHN - THICKMDL) / W20 ELSE CHI = 0.5D0 * CHI + SNMIDDL2 * RHOF( HNEW ) ENDIF #else CHI = 0.5D0 * CHI + (THCKHN - THICKMDL) / W20 #endif #else THCKHN = THICK( HNEW ) CHI = 0.5D0 * CHI + (THCKHN - THICKMDL) / W20 #endif IF ( DEBUG ) WRITE(MDEBUG,*) * 'UPDATE: DECAY HNEW=',SNGL(HNEW),' CHI=',SNGL(CHI) CHI = MAX( CHI, 1.D-20) ELSE C IN CASE OF INTERACTION THE PENETRATED MATTER CHI IS KEPT CONSTANT THCKHN = THICKMDL + 0.5D0 * CHI * W20 #if __UPWARD__ C LIMIT THE STEP FOR THE CASE THE SCATTERING ANGLE IS LARGE IF ( W20 .LT. 0.D0 ) THEN THCKHN = MAX( THCKHN, 0.D0 ) ELSE THCKHN = MIN( THCKHN, THICKL(1) ) ENDIF HNEW = HEIGH( THCKHN ) IF ( DEBUG ) WRITE(MDEBUG,*) * 'UPDATE INTAC: THICKMDL,THCKHN,W20=', * SNGL(THICKMDL),SNGL(THCKHN),SNGL(W20) #if __CURVED__ IF ( ABS( W20 ) .GT. 0.003D0 ) THEN C NORMAL TREATMENT FOR NON-HORIZONTAL PARTICLE (INCLINATION > 0.2 DEG) SNMIDDL2 = (HMIDDL - HNEW) / W20 ELSE SNMIDDL2 = CHI * 0.5D0 / RHOF( HNEW ) ENDIF #else SNMIDDL2 = (HMIDDL - HNEW) / W20 #endif #else HNEW = HEIGH( THCKHN ) SNMIDDL2 = (HMIDDL - HNEW) / W20 #endif IF ( DEBUG ) WRITE(MDEBUG,*) 'UPDATE: INTAC HNEW=', * SNGL(HNEW),' SNMIDDL2=',SNGL(SNMIDDL2) ENDIF #if __CURVED__ C CHECK HNEW COMPARED TO OBSERVATION LEVEL IF ( ( PRMPAR(15).GE.0.D0 .AND. HNEW.LE.OBSLEV(1) ) .OR. * ( PRMPAR(15).LT.0.D0 .AND. HNEW.GE.OBSLEV(1) ) ) THEN HNEW = OBSLEV(1) THCKHN = THICK( HNEW ) IF ( ABS( W20 ) .GT. 0.003D0 ) THEN C NORMAL TREATMENT FOR NON-HORIZONTAL PARTICLE (INCLINATION > 0.2 DEG) CHI = 0.5D0 * CHI + (THCKHN - THICKMDL) / W20 SNMIDDL2 = (HMIDDL - HNEW) / W20 CHI = MAX( CHI, 1.D-20) ELSE C NO UPDATE POSSIBLE FOR CHI AND SNMIDDL2 (RARE AND NOT IMPORTANT HERE) ENDIF IPAS = 1 IF ( DEBUG ) WRITE(MDEBUG,*) 'UPDATE: OBSLEV HNEW=', * SNGL(HNEW),' SNMIDDL2=',SNGL(SNMIDDL2),' CHI=',SNGL(CHI) ENDIF #endif STEPL = SNMIDDL1 + SNMIDDL2 SN3 = 0.5D0 * SNMIDDL2 ELSE C KEEP ARRIVAL HEIGHT AND SNMIDDL2, PARTICLE ARRIVES AT OBSERV. LEVEL #if __CURVED__ || __UPWARD__ IF ( ABS( W20 ) .GT. 0.003D0 ) THEN C NORMAL TREATMENT FOR NON-HORIZONTAL PARTICLE (INCLINATION > 0.2 DEG) SN3 = 0.5D0 * SNMIDDL2 * ACOSTH / ABS( W20 ) ELSE SN3 = 0.5D0 * SNMIDDL2 ENDIF #else SN3 = 0.5D0 * SNMIDDL2 * COSTHE / W20 #endif ENDIF ELSE ! NON-MUON CASE U20 = U12 V20 = V12 W20 = W12 #if __CURVED__ && __UPWARD__ IF ( ABS(W20) .GT. 0.003D0 ) THEN C NORMAL TREATMENT FOR NON-HORIZONTAL PARTICLE (INCLINATION > 0.2 DEG) SN3 = 0.5D0 * SNMIDDL2 * ACOSTH / ABS( W20 ) ELSE SN3 = 0.5D0 * SNMIDDL2 ENDIF #else SN3 = 0.5D0 * SNMIDDL2 * COSTHE / W20 #endif ENDIF #if __EFIELD__ C CHANGE DIRECTION BY ELECTRICAL FIELD X1 = X0 + (SN1+SN2+SN3+SN4) * U20 Y1 = Y0 + (SN1+SN2+SN3+SN4) * V20 Z1 = Z0 + (SN1+SN2+SN3+SN4) * W20 C ATTENTION! DEFINITION OF Y,Z ACCORDING TO HADRONIC PART CALL ELFIELD( X1,Y1,Z1, EX1,EY1,EZ1 ) C THEREFORE USE INVERTED FIELD FOR EY AND EZ C CONVERSION VOLT TO GV GIVES FACTOR 1.D-9 EX1 = EX1 * 1.D-9 / PAMA(ITYPE) EY1 = -EY1 * 1.D-9 / PAMA(ITYPE) EZ1 = -EZ1 * 1.D-9 / PAMA(ITYPE) EDOT1 = EX1*U20 + EY1*V20 + EZ1*W20 DPX1 = FNORME * 0.5D0 * (EX1 - U20*EDOT1 + DPX0) DPY1 = FNORME * 0.5D0 * (EY1 - V20*EDOT1 + DPY0) DPZ1 = FNORME * 0.5D0 * (EZ1 - W20*EDOT1 + DPZ0) DP21 = DPX1**2 + DPY1**2 + DPZ1**2 IF ( DP21 .NE. 0.D0 ) THEN ALPHAE = 0.5D0 * DP21 * (SN1+SN2+SN3+SN4)**2 FNORM4 = 1.D0 / (1.D0 + ALPHAE*(1.D0 - 0.5D0*ALPHAE)) U20 = (U20 + (SN1+SN2+SN3+SN4)*DPX1) * FNORM4 V20 = (V20 + (SN1+SN2+SN3+SN4)*DPY1) * FNORM4 W20 = (W20 + (SN2+SN2+SN3+SN4)*DPZ1) * FNORM4 ENDIF C ENERGY LOSS OR GAIN IN ELECTRICAL FIELD C POTENTIAL DIFFERENCE DPOT (IN GEV) (DIVIDED BY PARTICLE MASS) C FACTOR 0.5 BY AVERAGING OF FIELD AT START AND END DPOT = 0.5D0 * SIGNUM(ITYPE) * ( (EX0 + EX1)*(X0 - X1) * + (EY0 + EY1)*(Y0 - Y1) * + (EZ0 + EZ1)*(Z0 - Z1) ) C CHANGEMENT OF GAMMA FACTOR AT END OF TRANSPORT GAMMAN = GAMMAN - DPOT #endif C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C TRANSPORT CHARGED PARTICLES THE SECOND PORTION OF STEP C NEW PATH LENGTH, NEW BETA VALUE BECAUSE OF IONIZATION ENERGY LOSS BETAN = SQRT( (GAMMAN-1.D0)*(GAMMAN+1.D0) ) / GAMMAN C DEFLECTION IN EARTH MAGNETIC FIELD ON SECOND HALF OF STEP ALPHA2 = SIGNUM(ITYPE) * * MIN(1.D0,2.D0*SN3*BNORMC / (PAMA(ITYPE)*BETAN*GAMMAN)) FNORM2 = 1.D0 - 0.5D0*ALPHA2**2 * (1.D0 - 0.75D0*ALPHA2**2) F1SIN2 = ( 1.D0 - FNORM2 ) * SINB F1COS2 = ( 1.D0 - FNORM2 ) * COSB VVV = V20 * ALPHA2 * FNORM2 USW = U20 * SINB - W20 * COSB U22 = U20 - F1SIN2 * USW + VVV * SINB V22 = FNORM2 * ( V20 - ALPHA2 * USW ) W22 = W20 + F1COS2 * USW - VVV * COSB RADINV = 1.5D0 - 0.5D0 * ( U22**2 + V22**2 + W22**2 ) W22 = MIN( 1.D0, RADINV * W22 ) IF ( W22 .LE. C(29) ) THEN IF ( DEBUG ) WRITE(MDEBUG,*) * 'UPDATE: PARTICLE',ITYPE,' BELOW ANGLE CUT 2' IRETE = .FALSE. GOTO 1111 ENDIF #if __CURVED__ || __UPWARD__ IF ( ABS( W22 ) .GT. 0.003D0 ) THEN C NORMAL TREATMENT FOR NON-HORIZONTAL PARTICLE (INCLINATION > 0.2 DEG) SN4 = SN3 * ABS( W20 ) / ABS( W22 ) ELSE SN4 = SN3 ENDIF #else SN4 = SN3 * W20 / W22 #endif U22 = RADINV * U22 V22 = RADINV * V22 OUTPAR(2) = W22 OUTPAR(3) = U22 OUTPAR(4) = -V22 C UPDATE COORDINATES AND TIME TO THE END OF DISTANCE IF ( (LLONGI .OR. CFLAG) .AND. TFLAG ) THEN OUTPAR(6) = T + DT* ( RATIO*GAMMA + (1.D0-RATIO)*GAMMAN) ELSE OUTPAR(6) = T + (SN1 + SN2)/(BETA *C(25)) + * (SN3 + SN4)/(BETAN*C(25)) ENDIF OUTPAR(7) = X + SN1*U10 + SN2*U12 + SN3*U20 + SN4*U22 OUTPAR(8) = Y - SN1*V10 - SN2*V12 - SN3*V20 - SN4*V22 #if __CERENKOV__ || __AUGCERLONG__ C CHERENKOV RADIATION: FILL PARTICLE COORDINATES IF ( TCRNKV #if __PARALLEL__ * .AND. .NOT. (FIRSTI .AND. JCOUNT .GT. 1 ) #endif * ) THEN #if __CURVED__ IF ( .NOT. DETSYS ) THEN C RESAVE OLD COORDINATES DUE TO DIFFERENT DEFINITION IN CERENK C (COORDINATES WERE TRANSFORMED IN CERENK) XEND = XPART YEND = YPART ZEND = ZPART C TRANSFORM INTO DETECTOR FRAME C FIRST CALCULATE STEP TO X AND Y ALONG EARTH SURFACE DX = +SN1*U10 + SN2*U12 + SN3*U20 + SN4*U22 DY = -SN1*V10 - SN2*V12 - SN3*V20 - SN4*V22 TRANS2 = DX**2 + DY**2 AUXIL = SQRT( TRANS2 + (C(1)+HNEW)**2 ) SINDIF = SQRT( TRANS2 ) / AUXIL IF ( SINDIF .GT. 0.D0 ) THEN CORR = C(1) * ASIN( SINDIF ) / (AUXIL*SINDIF) ELSE CORR = 1.D0 ENDIF XPART = X + DX*CORR YPART = Y + DY*CORR TPART = OUTPAR(6) C CALCULATE EARTH ANGLE BETWEEN THE ACTUAL LOCAL AND THE C APPARENT COORDINATE SYSTEM (SEE ABOVE) AUXIL = SQRT( X**2 + Y**2 ) CTEA = COS( AUXIL/C(1) ) C NOW TRANSFORM THEM IN DETECTOR FRAME. ATTENTION: ANGLE MIGHT BE C VERY LARGE, THEREFORE APPROXIMATION TAN(X) EQUAL X IS NOT ALLOWED! C DON''T TRANSFORM X AND Y HERE BUT IN CERENK (SEE ABOVE) C XBEG=XEND(LAST PART) AND YBEG=YEND(LAST PART) ARE SET ABOVE ELSE #endif CTEA = 1.D0 XPART = OUTPAR(7) YPART = OUTPAR(8) TPART = OUTPAR(6) #if __CURVED__ ENDIF #endif ZPART = HNEW * TPART = OUTPAR(6) UMEAN = 0.5D0 * (U20 + U22) VMEAN = 0.5D0 * (V20 + V22) WMEAN = 0.5D0 * (W20 + W22) C SET OTHER FUNCTION ARGUMENTS (FORMER END IS NOW THE BEGIN) TBEG = TEND XBEG = XEND YBEG = YEND ZBEG = ZEND TEND = TPART XEND = XPART YEND = YPART ZEND = ZPART #if __THIN__ WTPART = WEIGHT #else WTPART = 1.D0 #endif CALL CERENK( SN3+SN4,UMEAN,-VMEAN,WMEAN, * EBEG+0.5*(EEND-EBEG),EEND, * XBEG,YBEG,ZBEG,XEND,YEND,ZEND,TBEG,TEND, * PAMA(ITYPE),SIGNUM(ITYPE),WTPART,CTEA ) ENDIF #endif C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if !__CURVED__ IF ( LLONGI .AND. TCRNKV #if __PARALLEL__ * .AND. .NOT. (FIRSTI .AND. JCOUNT .GT. 1 ) #endif * ) THEN C THE PARTICLE IS TRACKED FROM THICKH DOWN TO THCKHN #if __SLANT__ T1 = THCKSI( X*STHCPH + Y*STHSPH - H*CTH + RLOFF ) LPCT1 = LBIN( X,Y,H,1 ) T2 = THCKSI( OUTPAR(7)*STHCPH + OUTPAR(8)*STHSPH * - HNEW*CTH + RLOFF ) T3 = T2 STEPT = (T2 - T1)*THSTPI LPCT2 = LBIN( OUTPAR(7),OUTPAR(8),HNEW,LPCT1 ) - 1 #else LPCT1 = INT( THICKH*THSTPI + 1.D0 ) THCKC = THCKHN STEPT = (THCKC - THICKH)*THSTPI LPCT2 = INT( THCKC*THSTPI ) #endif #if __UPWARD__ || __SLANT__ #if __SLANT__ IF ( T2 .GT. T1 ) THEN C FORWARD MOVING PARTICLE #else IF ( COSTHE .GT. 0.D0 ) THEN C DOWNWARD MOVING PARTICLE #endif #endif C TOTAL PATH LENGTH IN UNITS OF LONGI BINS IF ( IPAS .GT. 0 ) LPCT2 = LPCT2 + 1 C WE ASSUME HOMOGENEOUS ENERGY DEPOSIT ALONG PATH C IONIZATION ENERGY DEPOSITED IN EACH BIN IS EDEPB IF ( STEPT .GT. 0.D0 ) THEN #if __THIN__ EDEPB = PAMA(ITYPE) * (GAMMA - GAMMAN) * WEIGHT / STEPT #else EDEPB = PAMA(ITYPE) * (GAMMA - GAMMAN) / STEPT #endif IF ( GAMMAN .LT. GLCUT ) THEN #if __SLANT__ T3 = (GAMMA-GLCUT)*STEPT*THSTEP/(GAMMA-GAMMAN) + T1 LPCT2 = INT( T3*THSTPI ) #else THCKC = (GAMMA-GLCUT)*STEPT*THSTEP/(GAMMA-GAMMAN) * + THICKH LPCT2 = INT( THCKC*THSTPI ) #endif ENDIF ELSE EDEPB = 0.D0 ENDIF #if __SLANT__ LPCT2 = MIN( LPCT2, NSTEP+1 ) C ENERGY DEPOSIT IN FIRST BIN EDEP1 = EDEPB * (DBLE(LPCT1) - T1*THSTPI) cdh April 4, 2017 cdh EDEP1 = MAX( 0.D0, EDEPB * (DBLE(LPCT1) - T1*THSTPI) ) #else LPCT2 = MIN( LPCT2, NSTEP ) C ENERGY DEPOSIT IN FIRST BIN EDEP1 = EDEPB * (DBLE(LPCT1) - THICKH*THSTPI) #endif C ENERGY AT FIRST BIN BOUNDARY #if __THIN__ EFRST = PAMA(ITYPE) * GAMMA * WEIGHT - EDEP1 #else EFRST = PAMA(ITYPE) * GAMMA - EDEP1 #endif IF ( LPCT2 .LT. LPCT1 ) THEN #if __SLANT__ EDEPN = EDEPB * (T3*THSTPI - DBLE(LPCT1)) #else EDEPN = EDEPB * (THCKC*THSTPI - DBLE(LPCT1)) #endif LPCT2 = MAX( LPCT2, 0 ) ELSE IF ( HNEW .GT. OBSLEV(NOBSLV) ) THEN #if __SLANT__ EDEPN = MAX( 0.D0, EDEPB * (T3*THSTPI - DBLE(LPCT2)) ) #else EDEPN = MAX( 0.D0, EDEPB * (THCKC*THSTPI - DBLE(LPCT2)) ) #endif ELSE C PARTICLE ARRIVES AT DETECTOR EDEPN = 0.D0 ENDIF ENDIF C NOW FILL FIRST AND LAST+1 BIN, THEN LOOP OVER THE BINS BETWEEN IF ( ITYPE .EQ. 5 ) THEN C MUON(+) LONGITUDINAL DEVELOPMENT FOR DEPOSIT, ENERGY, PARTICLES DLONG(LPCT1 ,4) = DLONG(LPCT1 ,4) + EDEP1 DLONG(LPCT2+1,4) = DLONG(LPCT2+1,4) + EDEPN IF ( LPCT2 .GE. LPCT1 ) THEN ELONG(LPCT2,4) = ELONG(LPCT2,4) * + (EFRST-(LPCT2-LPCT1)*EDEPB) #if __THIN__ PLONG(LPCT2,4) = PLONG(LPCT2,4) + WEIGHT #else PLONG(LPCT2,4) = PLONG(LPCT2,4) + 1.D0 #endif ENDIF ELSEIF ( ITYPE .EQ. 6 ) THEN C MUON(-) LONGITUDINAL DEVELOPMENT FOR DEPOSIT, ENERGY, PARTICLES DLONG(LPCT1 ,4) = DLONG(LPCT1 ,4) + EDEP1 DLONG(LPCT2+1,4) = DLONG(LPCT2+1,4) + EDEPN IF ( LPCT2 .GE. LPCT1 ) THEN ELONG(LPCT2,5) = ELONG(LPCT2,5) * + (EFRST-(LPCT2-LPCT1)*EDEPB) #if __THIN__ PLONG(LPCT2,5) = PLONG(LPCT2,5) + WEIGHT #else PLONG(LPCT2,5) = PLONG(LPCT2,5) + 1.D0 #endif ENDIF ELSEIF ( ITYPE .LT. 200 ) THEN C CHARGED HADRON LONGITUDINAL DEVELOPMENT FOR DEPOSIT, ENERGY, PARTICLES DLONG(LPCT1 ,6) = DLONG(LPCT1 ,6) + EDEP1 DLONG(LPCT2+1,6) = DLONG(LPCT2+1,6) + EDEPN IF ( LPCT2 .GE. LPCT1 ) THEN ELONG(LPCT2,6) = ELONG(LPCT2,6) * + (EFRST-(LPCT2-LPCT1)*EDEPB) ELONG(LPCT2,7) = ELONG(LPCT2,7) * + (EFRST-(LPCT2-LPCT1)*EDEPB) #if __ANAHIST__ IF ( ITYPE .EQ. 8 ) THEN #if __THIN__ PLONG(LPCT2,14) = PLONG(LPCT2,14) + WEIGHT ELSEIF ( ITYPE .EQ. 9 ) THEN PLONG(LPCT2,14) = PLONG(LPCT2,14) + WEIGHT ELSEIF ( ITYPE .EQ. 11 ) THEN PLONG(LPCT2,15) = PLONG(LPCT2,15) + WEIGHT ELSEIF ( ITYPE .EQ. 12 ) THEN PLONG(LPCT2,15) = PLONG(LPCT2,15) + WEIGHT ELSEIF ( ITYPE .EQ. 14 ) THEN PLONG(LPCT2,12) = PLONG(LPCT2,12) + WEIGHT PLONG(LPCT2,11) = PLONG(LPCT2,11) + WEIGHT ELSEIF ( ITYPE .EQ. 15 ) THEN PLONG(LPCT2,12) = PLONG(LPCT2,12) + WEIGHT PLONG(LPCT2,11) = PLONG(LPCT2,11) + WEIGHT #else PLONG(LPCT2,14) = PLONG(LPCT2,14) + 1.D0 ELSEIF ( ITYPE .EQ. 9 ) THEN PLONG(LPCT2,14) = PLONG(LPCT2,14) + 1.D0 ELSEIF ( ITYPE .EQ. 11 ) THEN PLONG(LPCT2,15) = PLONG(LPCT2,15) + 1.D0 ELSEIF ( ITYPE .EQ. 12 ) THEN PLONG(LPCT2,15) = PLONG(LPCT2,15) + 1.D0 ELSEIF ( ITYPE .EQ. 14 ) THEN PLONG(LPCT2,12) = PLONG(LPCT2,12) + 1.D0 PLONG(LPCT2,11) = PLONG(LPCT2,11) + 1.D0 ELSEIF ( ITYPE .EQ. 15 ) THEN PLONG(LPCT2,12) = PLONG(LPCT2,12) + 1.D0 PLONG(LPCT2,11) = PLONG(LPCT2,11) + 1.D0 #endif ENDIF #endif #if __THIN__ PLONG(LPCT2,6) = PLONG(LPCT2,6) + WEIGHT PLONG(LPCT2,7) = PLONG(LPCT2,7) + WEIGHT #else PLONG(LPCT2,6) = PLONG(LPCT2,6) + 1.D0 PLONG(LPCT2,7) = PLONG(LPCT2,7) + 1.D0 #endif ENDIF ELSE C NUCLEI LONGITUDINAL DEVELOPMENT FOR DEPOSIT, ENERGY, PARTICLES DLONG(LPCT1 ,6) = DLONG(LPCT1 ,6) + EDEP1 DLONG(LPCT2+1,6) = DLONG(LPCT2+1,6) + EDEPN IF ( LPCT2 .GE. LPCT1 ) THEN ELONG(LPCT2,8) = ELONG(LPCT2,8) * + (EFRST-(LPCT2-LPCT1)*EDEPB) #if __THIN__ PLONG(LPCT2,8) = PLONG(LPCT2,8) + WEIGHT #else PLONG(LPCT2,8) = PLONG(LPCT2,8) + 1.D0 #endif ENDIF ENDIF C LOOP OVER ALL LONGITUDINAL BINS IF ( LPCT2 .GT. LPCT1 ) THEN DO IL = LPCT1, LPCT2-1 IF ( ITYPE .EQ. 5 ) THEN C MUON(+) LONGITUDINAL DEVELOPMENT FOR DEPOSIT, ENERGY, PARTICLES DLONG(IL+1,4) = DLONG(IL+1,4) + EDEPB ELONG(IL,4) = ELONG(IL,4) + (EFRST-(IL-LPCT1)*EDEPB) #if __THIN__ PLONG(IL,4) = PLONG(IL,4) + WEIGHT #else PLONG(IL,4) = PLONG(IL,4) + 1.D0 #endif ELSEIF ( ITYPE .EQ. 6 ) THEN C MUON(-) LONGITUDINAL DEVELOPMENT FOR DEPOSIT, ENERGY, PARTICLES DLONG(IL+1,4) = DLONG(IL+1,4) + EDEPB ELONG(IL,5) = ELONG(IL,5) + (EFRST-(IL-LPCT1)*EDEPB) #if __THIN__ PLONG(IL,5) = PLONG(IL,5) + WEIGHT #else PLONG(IL,5) = PLONG(IL,5) + 1.D0 #endif ELSEIF ( ITYPE .LT. 200 ) THEN C CHARGED HADRON LONGITUDINAL DEVELOPMENT FOR DEPOSIT, ENERGY, PARTICLES DLONG(IL+1,6) = DLONG(IL+1,6) + EDEPB ELONG(IL,6) = ELONG(IL,6) + (EFRST-(IL-LPCT1)*EDEPB) ELONG(IL,7) = ELONG(IL,7) + (EFRST-(IL-LPCT1)*EDEPB) #if __ANAHIST__ IF ( ITYPE .EQ. 8 ) THEN #if __THIN__ PLONG(IL,14) = PLONG(IL,14) + WEIGHT ELSEIF ( ITYPE .EQ. 9 ) THEN PLONG(IL,14) = PLONG(IL,14) + WEIGHT ELSEIF ( ITYPE .EQ. 11 ) THEN PLONG(IL,15) = PLONG(IL,15) + WEIGHT ELSEIF ( ITYPE .EQ. 12 ) THEN PLONG(IL,15) = PLONG(IL,15) + WEIGHT ELSEIF ( ITYPE .EQ. 14 ) THEN PLONG(IL,12) = PLONG(IL,12) + WEIGHT PLONG(IL,11) = PLONG(IL,11) + WEIGHT ELSEIF ( ITYPE .EQ. 15 ) THEN PLONG(IL,12) = PLONG(IL,12) + WEIGHT PLONG(IL,11) = PLONG(IL,11) + WEIGHT #else PLONG(IL,14) = PLONG(IL,14) + 1.D0 ELSEIF ( ITYPE .EQ. 9 ) THEN PLONG(IL,14) = PLONG(IL,14) + 1.D0 ELSEIF ( ITYPE .EQ. 11 ) THEN PLONG(IL,15) = PLONG(IL,15) + 1.D0 ELSEIF ( ITYPE .EQ. 12 ) THEN PLONG(IL,15) = PLONG(IL,15) + 1.D0 ELSEIF ( ITYPE .EQ. 14 ) THEN PLONG(IL,12) = PLONG(IL,12) + 1.D0 PLONG(IL,11) = PLONG(IL,11) + 1.D0 ELSEIF ( ITYPE .EQ. 15 ) THEN PLONG(IL,12) = PLONG(IL,12) + 1.D0 PLONG(IL,11) = PLONG(IL,11) + 1.D0 #endif ENDIF #endif #if __THIN__ PLONG(IL,6) = PLONG(IL,6) + WEIGHT PLONG(IL,7) = PLONG(IL,7) + WEIGHT #else PLONG(IL,6) = PLONG(IL,6) + 1.D0 PLONG(IL,7) = PLONG(IL,7) + 1.D0 #endif ELSE C NUCLEI LONGITUDINAL DEVELOPMENT FOR DEPOSIT, ENERGY, PARTICLES DLONG(IL+1,6) = DLONG(IL+1,6) + EDEPB ELONG(IL,8) = ELONG(IL,8) + (EFRST-(IL-LPCT1)*EDEPB) #if __THIN__ PLONG(IL,8) = PLONG(IL,8) + WEIGHT #else PLONG(IL,8) = PLONG(IL,8) + 1.D0 #endif ENDIF ENDDO ENDIF #if __UPWARD__ || __SLANT__ #if __SLANT__ ELSEIF ( T2 .LT. T1 ) THEN C BACKWARD MOVING PARTICLES IF ( T2 .LT. 0.D0 ) THEN T2 = 0.D0 LPCT2 = 0 STEPT = (T2 - T1) * THSTPI ENDIF #else ELSEIF ( COSTHE .LT. 0.D0 ) THEN C UPWARD MOVING PARTICLES #endif LPCT1 = LPCT1 - 1 LPCT2 = LPCT2 + 1 STEPT = -STEPT C TOTAL PATH LENGTH IN UNITS OF LONGI BINS IF ( IPAS .GT. 0 ) LPCT2 = LPCT2 - 1 C WE ASSUME HOMOGENEOUS ENERGY DEPOSIT ALONG PATH C IONIZATION ENERGY DEPOSITED IN EACH BIN IS EDEPB IF ( STEPT .GT. 0.D0 ) THEN #if __THIN__ EDEPB = PAMA(ITYPE) * (GAMMA - GAMMAN) * WEIGHT / STEPT #else EDEPB = PAMA(ITYPE) * (GAMMA - GAMMAN) / STEPT #endif IF ( GAMMAN .LT. GLCUT ) THEN #if __SLANT__ T3 = T1 - (GAMMA-GLCUT)*STEPT*THSTEP/(GAMMA-GAMMAN) LPCT2 = INT( T3*THSTPI +1 ) #else THCKC = THICKH-(GAMMA-GLCUT)*STEPT*THSTEP/(GAMMA-GAMMAN) LPCT2 = INT( THCKC*THSTPI + 1 ) #endif ENDIF ELSE EDEPB = 0.D0 ENDIF #if __SLANT__ LPCT2 = MIN( LPCT2, NSTEP+1 ) C ENERGY DEPOSIT IN FIRST BIN EDEP1 = EDEPB * (T1*THSTPI - DBLE(LPCT1)) #else LPCT2 = MAX( LPCT2, 0 ) C ENERGY DEPOSIT IN FIRST BIN EDEP1 = EDEPB * (THICKH*THSTPI - DBLE(LPCT1)) #endif C ENERGY AT FIRST BIN BOUNDARY #if __THIN__ EFRST = PAMA(ITYPE) * GAMMA * WEIGHT - EDEP1 #else EFRST = PAMA(ITYPE) * GAMMA - EDEP1 #endif IF ( LPCT2 .GT. LPCT1 ) THEN #if __SLANT__ EDEPN = EDEPB * (DBLE(LPCT1) - T3*THSTPI) #else EDEPN = EDEPB * (DBLE(LPCT1) - THCKC*THSTPI) #endif LPCT2 = MIN( LPCT2, NSTEP ) ELSE IF ( HNEW .LT. OBSLEV(NOBSLV) ) THEN #if __SLANT__ EDEPN = MAX( 0.D0, EDEPB * (DBLE(LPCT2) - T3*THSTPI) ) #else EDEPN = MAX( 0.D0, EDEPB * (DBLE(LPCT2)-THCKC*THSTPI) ) #endif ELSE C PARTICLE ARRIVES AT DETECTOR LPCT2 = MAX( 0, LPCT2 ) EDEPN = 0.D0 ENDIF ENDIF C NOW FILL FIRST AND LAST+1 BIN, THEN LOOP OVER THE BINS BETWEEN IF ( ITYPE .EQ. 5 ) THEN C MUON(+) LONGITUDINAL DEVELOPMENT FOR DEPOSIT, ENERGY, PARTICLES DLONG(LPCT1+1,4) = DLONG(LPCT1+1,4) + EDEP1 DLONG(LPCT2 ,4) = DLONG(LPCT2 ,4) + EDEPN IF ( LPCT2 .LE. LPCT1 ) THEN ELONG(LPCT2,4) = ELONG(LPCT2,4) * + (EFRST+(LPCT2-LPCT1)*EDEPB) #if __THIN__ PLONG(LPCT2,4) = PLONG(LPCT2,4) + WEIGHT #else PLONG(LPCT2,4) = PLONG(LPCT2,4) + 1.D0 #endif ENDIF ELSEIF ( ITYPE .EQ. 6 ) THEN C MUON(-) LONGITUDINAL DEVELOPMENT FOR DEPOSIT, ENERGY, PARTICLES DLONG(LPCT1+1,4) = DLONG(LPCT1+1,4) + EDEP1 DLONG(LPCT2 ,4) = DLONG(LPCT2 ,4) + EDEPN IF ( LPCT2 .LE. LPCT1 ) THEN ELONG(LPCT2,5) = ELONG(LPCT2,5) * + (EFRST+(LPCT2-LPCT1)*EDEPB) #if __THIN__ PLONG(LPCT2,5) = PLONG(LPCT2,5) + WEIGHT #else PLONG(LPCT2,5) = PLONG(LPCT2,5) + 1.D0 #endif ENDIF ELSEIF ( ITYPE .LT. 200 ) THEN C CHARGED HADRON LONGITUDINAL DEVELOPMENT FOR DEPOSIT, ENERGY, PARTICLES DLONG(LPCT1+1,6) = DLONG(LPCT1+1,6) + EDEP1 DLONG(LPCT2 ,6) = DLONG(LPCT2 ,6) + EDEPN IF ( LPCT2 .LE. LPCT1 ) THEN ELONG(LPCT2,6) = ELONG(LPCT2,6) * + (EFRST+(LPCT2-LPCT1)*EDEPB) ELONG(LPCT2,7) = ELONG(LPCT2,7) * + (EFRST+(LPCT2-LPCT1)*EDEPB) #if __ANAHIST__ IF ( ITYPE .EQ. 8 ) THEN #if __THIN__ PLONG(LPCT2,14) = PLONG(LPCT2,14) + WEIGHT ELSEIF ( ITYPE .EQ. 9 ) THEN PLONG(LPCT2,14) = PLONG(LPCT2,14) + WEIGHT ELSEIF ( ITYPE .EQ. 11 ) THEN PLONG(LPCT2,15) = PLONG(LPCT2,15) + WEIGHT ELSEIF ( ITYPE .EQ. 12 ) THEN PLONG(LPCT2,15) = PLONG(LPCT2,15) + WEIGHT ELSEIF ( ITYPE .EQ. 14 ) THEN PLONG(LPCT2,12) = PLONG(LPCT2,12) + WEIGHT PLONG(LPCT2,11) = PLONG(LPCT2,11) + WEIGHT ELSEIF ( ITYPE .EQ. 15 ) THEN PLONG(LPCT2,12) = PLONG(LPCT2,12) + WEIGHT PLONG(LPCT2,11) = PLONG(LPCT2,11) + WEIGHT #else PLONG(LPCT2,14) = PLONG(LPCT2,14) + 1.D0 ELSEIF ( ITYPE .EQ. 9 ) THEN PLONG(LPCT2,14) = PLONG(LPCT2,14) + 1.D0 ELSEIF ( ITYPE .EQ. 11 ) THEN PLONG(LPCT2,15) = PLONG(LPCT2,15) + 1.D0 ELSEIF ( ITYPE .EQ. 12 ) THEN PLONG(LPCT2,15) = PLONG(LPCT2,15) + 1.D0 ELSEIF ( ITYPE .EQ. 14 ) THEN PLONG(LPCT2,12) = PLONG(LPCT2,12) + 1.D0 PLONG(LPCT2,11) = PLONG(LPCT2,11) + 1.D0 ELSEIF ( ITYPE .EQ. 15 ) THEN PLONG(LPCT2,12) = PLONG(LPCT2,12) + 1.D0 PLONG(LPCT2,11) = PLONG(LPCT2,11) + 1.D0 #endif ENDIF #endif #if __THIN__ PLONG(LPCT2,6) = PLONG(LPCT2,6) + WEIGHT PLONG(LPCT2,7) = PLONG(LPCT2,7) + WEIGHT #else PLONG(LPCT2,6) = PLONG(LPCT2,6) + 1.D0 PLONG(LPCT2,7) = PLONG(LPCT2,7) + 1.D0 #endif ENDIF ELSE C NUCLEI LONGITUDINAL DEVELOPMENT FOR DEPOSIT, ENERGY, PARTICLES DLONG(LPCT1+1,6) = DLONG(LPCT1+1,6) + EDEP1 DLONG(LPCT2 ,6) = DLONG(LPCT2 ,6) + EDEPN IF ( LPCT2 .LE. LPCT1 ) THEN ELONG(LPCT2,8) = ELONG(LPCT2,8) * + (EFRST+(LPCT2-LPCT1)*EDEPB) #if __THIN__ PLONG(LPCT2,8) = PLONG(LPCT2,8) + WEIGHT #else PLONG(LPCT2,8) = PLONG(LPCT2,8) + 1.D0 #endif ENDIF ENDIF C LOOP OVER ALL LONGITUDINAL BINS IF ( LPCT2 .LT. LPCT1 ) THEN DO IL = LPCT1, LPCT2+1 , -1 IF ( ITYPE .EQ. 5 ) THEN C MUON(+) LONGITUDINAL DEVELOPMENT FOR DEPOSIT, ENERGY, PARTICLES DLONG(IL,4) = DLONG(IL,4) + EDEPB ELONG(IL,4) = ELONG(IL,4) + (EFRST+(IL-LPCT1)*EDEPB) #if __THIN__ PLONG(IL,4) = PLONG(IL,4) + WEIGHT #else PLONG(IL,4) = PLONG(IL,4) + 1.D0 #endif ELSEIF ( ITYPE .EQ. 6 ) THEN C MUON(-) LONGITUDINAL DEVELOPMENT FOR DEPOSIT, ENERGY, PARTICLES DLONG(IL,4) = DLONG(IL,4) + EDEPB ELONG(IL,5) = ELONG(IL,5) + (EFRST+(IL-LPCT1)*EDEPB) #if __THIN__ PLONG(IL,5) = PLONG(IL,5) + WEIGHT #else PLONG(IL,5) = PLONG(IL,5) + 1.D0 #endif ELSEIF ( ITYPE .LT. 200 ) THEN C CHARGED HADRON LONGITUDINAL DEVELOPMENT FOR DEPOSIT, ENERGY, PARTICLES DLONG(IL,6) = DLONG(IL,6) + EDEPB ELONG(IL,6) = ELONG(IL,6) + (EFRST+(IL-LPCT1)*EDEPB) ELONG(IL,7) = ELONG(IL,7) + (EFRST+(IL-LPCT1)*EDEPB) #if __ANAHIST__ IF ( ITYPE .EQ. 8 ) THEN #if __THIN__ PLONG(IL,14) = PLONG(IL,14) + WEIGHT ELSEIF ( ITYPE .EQ. 9 ) THEN PLONG(IL,14) = PLONG(IL,14) + WEIGHT ELSEIF ( ITYPE .EQ. 11 ) THEN PLONG(IL,15) = PLONG(IL,15) + WEIGHT ELSEIF ( ITYPE .EQ. 12 ) THEN PLONG(IL,15) = PLONG(IL,15) + WEIGHT ELSEIF ( ITYPE .EQ. 14 ) THEN PLONG(IL,12) = PLONG(IL,12) + WEIGHT PLONG(IL,11) = PLONG(IL,11) + WEIGHT ELSEIF ( ITYPE .EQ. 15 ) THEN PLONG(IL,12) = PLONG(IL,12) + WEIGHT PLONG(IL,11) = PLONG(IL,11) + WEIGHT #else PLONG(IL,14) = PLONG(IL,14) + 1.D0 ELSEIF ( ITYPE .EQ. 9 ) THEN PLONG(IL,14) = PLONG(IL,14) + 1.D0 ELSEIF ( ITYPE .EQ. 11 ) THEN PLONG(IL,15) = PLONG(IL,15) + 1.D0 ELSEIF ( ITYPE .EQ. 12 ) THEN PLONG(IL,15) = PLONG(IL,15) + 1.D0 ELSEIF ( ITYPE .EQ. 14 ) THEN PLONG(IL,12) = PLONG(IL,12) + 1.D0 PLONG(IL,11) = PLONG(IL,11) + 1.D0 ELSEIF ( ITYPE .EQ. 15 ) THEN PLONG(IL,12) = PLONG(IL,12) + 1.D0 PLONG(IL,11) = PLONG(IL,11) + 1.D0 #endif ENDIF #endif #if __THIN__ PLONG(IL,6) = PLONG(IL,6) + WEIGHT PLONG(IL,7) = PLONG(IL,7) + WEIGHT #else PLONG(IL,6) = PLONG(IL,6) + 1.D0 PLONG(IL,7) = PLONG(IL,7) + 1.D0 #endif ELSE C NUCLEI LONGITUDINAL DEVELOPMENT FOR DEPOSIT, ENERGY, PARTICLES DLONG(IL,6) = DLONG(IL,6) + EDEPB ELONG(IL,8) = ELONG(IL,8) + (EFRST+(IL-LPCT1)*EDEPB) #if __THIN__ PLONG(IL,8) = PLONG(IL,8) + WEIGHT #else PLONG(IL,8) = PLONG(IL,8) + 1.D0 #endif ENDIF ENDDO ENDIF ELSE C ENERGY DEPOSIT FOR HORIZONTALLY MOVING PARTICLES IN FIRST BIN ENDIF #endif ENDIF #endif C REJECT PARTICLES AFTER PRODUCTION OF CHERENKOV LIGHT C AND LONGITUDINAL DEVELOPMENT #if __AUGERHIST__ IF ( TCRNKV #else IF ( (LLONGI .OR. CFLAG) .AND. TCRNKV #endif #if __PARALLEL__ * .AND. .NOT. (FIRSTI .AND. JCOUNT .GT. 1 ) #endif * ) THEN IF ( GAMMAN .LT. GLCUT ) THEN #if __CERENKOV__ IF ( DEBUG ) WRITE(MDEBUG,*) 'UPDATE: PARTICLE',ITYPE, * ' BELOW ENERGY CUT AFTER CREATION OF CHERENKOV LIGHT' #else IF ( DEBUG ) WRITE(MDEBUG,*) 'UPDATE: PARTICLE',ITYPE, * ' BELOW ENERGY CUT' #endif #if __CURVED__ OUTPAR(1) = GAMMAN #else IF ( LLONGI ) THEN C FILL REMAINING CUTTED ENERGY INTO LONGI BIN AT CUTTING POINT LHEIGH = MAX( LPCT2, 0 ) IF ( ITYPE .EQ. 5 .OR. ITYPE .EQ. 6 ) THEN #if __THIN__ DLONG(LHEIGH,5) = DLONG(LHEIGH,5)+GAMMAN*PAMA(5)*WEIGHT #else DLONG(LHEIGH,5) = DLONG(LHEIGH,5) + GAMMAN * PAMA(5) #endif ELSE IF ( ITYPE .EQ. 8 .OR. ITYPE .EQ. 9 .OR. * ITYPE .EQ. 11 .OR. ITYPE .EQ. 12 ) THEN FAC1 = 0.25D0 FAC2 = 0.75D0 ELSEIF ( ITYPE .EQ. 10 .OR. ITYPE .EQ. 16 ) THEN FAC1 = 0.5D0 FAC2 = 0.5D0 ELSE FAC1 = 1.D0 FAC2 = 0.D0 ENDIF #if __THIN__ C ADD TO THE HADRON ENERGY DEPOSIT DLONG(LHEIGH,7) = DLONG(LHEIGH,7) + ( GAMMAN*PAMA(ITYPE) * - RESTMS(ITYPE) ) * WEIGHT * FAC1 C ADD TO THE NEUTRINO DEPOSIT DLONG(LHEIGH,8) = DLONG(LHEIGH,8) + ( GAMMAN*PAMA(ITYPE) * - RESTMS(ITYPE) ) * WEIGHT * FAC2 #else C ADD TO THE HADRON ENERGY DEPOSIT DLONG(LHEIGH,7) = DLONG(LHEIGH,7) + ( GAMMAN*PAMA(ITYPE) * - RESTMS(ITYPE) ) * FAC1 C ADD TO THE NEUTRINO DEPOSIT DLONG(LHEIGH,8) = DLONG(LHEIGH,8) + ( GAMMAN*PAMA(ITYPE) * - RESTMS(ITYPE) ) * FAC2 #endif ENDIF ENDIF #if __AUGERHIST__ #if __SLANT__ THCKC = (GAMMA-GLCUT)*STEPT*THSTEP/(GAMMA-GAMMAN) + THICKH #endif DO LL = 1, NOBSLV IF ( THCKC .GE. THCKOB(LL) .AND. * THCKC .LT. THCKOB(LL)+SAMPTH ) THEN C THCKHN AFTER TRANSPORT IS WITHIN 1 G/CM^2 BELOW OBSLEV(LL) C BRING THE ENERGY BELOW CUT TO THE HISTO OF LEVEL LL IF ( DEBUG ) WRITE(MDEBUG,*) 'UPDATE: THCKC=',THCKC CALL AUGCUT( LL ) ELSEIF ( THCKC .LT. THCKOB(LL) ) THEN GOTO 111 ENDIF ENDDO 111 CONTINUE #endif #endif IRETE = .TRUE. GOTO 1111 ENDIF ENDIF C----------------------------------------------------------------------- ELSE C NEUTRAL PARTICLES C NO COULOMB SCATTERING, NO DEFLECTION IN MAGNETIC FIELD C UPDATE COORDINATES AND TIME OUTPAR(2) = COSTHE OUTPAR(3) = PHIX OUTPAR(4) = PHIY OUTPAR(6) = T + SN / ( C(25) * BETA ) C HORIZONTAL PATH LENGTH OUTPAR(7) = X + SN * PHIX OUTPAR(8) = Y + SN * PHIY #if !__CURVED__ IF ( LLONGI .AND. IPAS .EQ. 0 #if __PARALLEL__ * .AND. .NOT. (FIRSTI .AND. JCOUNT .GT. 1 ) #endif * ) THEN C LONGITUDINAL DISTRIBUTIONS FOR NEUTRAL HADRONS WITHOUT NEUTRINOS C THE PARTICLE IS TRACKED FROM THICKH DOWN TO THCKHN C COUNT THE PARTICLES FOR THE LONGITUDINAL DEVELOPMENT IF ( (ITYPE.GE. 7 .AND. ITYPE.LE.32) .OR. * (ITYPE.GE.71 .AND. ITYPE.LE.74) ) THEN #if __SLANT__ LPCT1 = MIN( LBIN( X,Y,H,1 ), NSTEP ) LPCT2 = MIN( LBIN(OUTPAR(7),OUTPAR(8),HNEW,LPCT1-1)-1, * NSTEP+1 ) #else LPCT1 = INT( THICKH*THSTPI + 1.D0 ) LPCT2 = MIN( INT(THCKHN*THSTPI), NSTEP ) #endif #if __UPWARD__ #if __SLANT__ IF ( LPCT2 .GT. LPCT1 ) THEN C FORWARD MOVING PARTICLE #else IF ( COSTHE .GT. 0.D0 ) THEN C DOWNWARD MOVING PARTICLE #endif #endif DO IL = LPCT1, LPCT2 #if __THIN__ ELONG(IL,6) = ELONG(IL,6) + GAMMA * PAMA(ITYPE) * WEIGHT PLONG(IL,6) = PLONG(IL,6) + WEIGHT #else ELONG(IL,6) = ELONG(IL,6) + GAMMA * PAMA(ITYPE) PLONG(IL,6) = PLONG(IL,6) + 1.D0 #endif #if __ANAHIST__ IF ( ITYPE .EQ. 10 ) THEN #if __THIN__ PLONG(IL,16) = PLONG(IL,16) + WEIGHT PLONG(IL,18) = PLONG(IL,18) + WEIGHT ELSEIF ( ITYPE .EQ. 13 ) THEN PLONG(IL,13) = PLONG(IL,13) + WEIGHT PLONG(IL,11) = PLONG(IL,11) + WEIGHT ELSEIF ( ITYPE .EQ. 16 ) THEN PLONG(IL,17) = PLONG(IL,17) + WEIGHT PLONG(IL,18) = PLONG(IL,18) + WEIGHT ELSEIF ( ITYPE .EQ. 25 ) THEN PLONG(IL,13) = PLONG(IL,13) + WEIGHT PLONG(IL,11) = PLONG(IL,11) + WEIGHT #else PLONG(IL,16) = PLONG(IL,16) + 1.D0 PLONG(IL,18) = PLONG(IL,18) + 1.D0 ELSEIF ( ITYPE .EQ. 13 ) THEN PLONG(IL,13) = PLONG(IL,13) + 1.D0 PLONG(IL,11) = PLONG(IL,11) + 1.D0 ELSEIF ( ITYPE .EQ. 16 ) THEN PLONG(IL,17) = PLONG(IL,17) + 1.D0 PLONG(IL,18) = PLONG(IL,18) + 1.D0 ELSEIF ( ITYPE .EQ. 25 ) THEN PLONG(IL,13) = PLONG(IL,13) + 1.D0 PLONG(IL,11) = PLONG(IL,11) + 1.D0 #endif ENDIF #endif ENDDO #if __UPWARD__ #if __SLANT__ ELSEIF ( LPCT2 .LT. LPCT1 ) THEN C BACKWARD MOVING PARTICLE #else ELSEIF ( COSTHE .LT. 0.D0 ) THEN C UPWARD MOVING PARTICLE #endif LPCT1 = LPCT1 - 1 LPCT2 = MAX( INT( THCKHN*THSTPI + 1.D0 ), 0 ) DO IL = LPCT1, LPCT2, -1 #if __THIN__ ELONG(IL,6) = ELONG(IL,6) + GAMMA * PAMA(ITYPE) * WEIGHT PLONG(IL,6) = PLONG(IL,6) + WEIGHT #else ELONG(IL,6) = ELONG(IL,6) + GAMMA * PAMA(ITYPE) PLONG(IL,6) = PLONG(IL,6) + 1.D0 #endif #if __ANAHIST__ IF ( ITYPE .EQ. 10 ) THEN #if __THIN__ PLONG(IL,16) = PLONG(IL,16) + WEIGHT PLONG(IL,18) = PLONG(IL,18) + WEIGHT ELSEIF ( ITYPE .EQ. 13 ) THEN PLONG(IL,13) = PLONG(IL,13) + WEIGHT PLONG(IL,11) = PLONG(IL,11) + WEIGHT ELSEIF ( ITYPE .EQ. 16 ) THEN PLONG(IL,17) = PLONG(IL,17) + WEIGHT PLONG(IL,18) = PLONG(IL,18) + WEIGHT ELSEIF ( ITYPE .EQ. 25 ) THEN PLONG(IL,13) = PLONG(IL,13) + WEIGHT PLONG(IL,11) = PLONG(IL,11) + WEIGHT #else PLONG(IL,16) = PLONG(IL,16) + 1.D0 PLONG(IL,18) = PLONG(IL,18) + 1.D0 ELSEIF ( ITYPE .EQ. 13 ) THEN PLONG(IL,13) = PLONG(IL,13) + 1.D0 PLONG(IL,11) = PLONG(IL,11) + 1.D0 ELSEIF ( ITYPE .EQ. 16 ) THEN PLONG(IL,17) = PLONG(IL,17) + 1.D0 PLONG(IL,18) = PLONG(IL,18) + 1.D0 ELSEIF ( ITYPE .EQ. 25 ) THEN PLONG(IL,13) = PLONG(IL,13) + 1.D0 PLONG(IL,11) = PLONG(IL,11) + 1.D0 #endif ENDIF #endif ENDDO ELSE C PARTICLE MOVES HORIZONTALLY ENDIF #endif ENDIF #if __NEUTRINO__ || __NUPRIM__ C LONGITUDINAL DISTRIBUTIONS FOR NEUTRINOS C THE PARTICLE IS TRACKED FROM THICKH DOWN TO THCKHN C COUNT THE PARTICLES FOR THE LONGITUDINAL DEVELOPMENT IF ( ( ITYPE .GE. 66 .AND. ITYPE .LE. 69 ) #if __CHARM__ || __TAULEP__ * .OR. ITYPE .EQ. 133 .OR. ITYPE .EQ. 134 #endif * ) THEN #if __SLANT__ LPCT1 = MIN( LBIN( X,Y,H,1 ), NSTEP ) LPCT2 = MIN( LBIN(OUTPAR(7),OUTPAR(8),HNEW,LPCT1-1)-1, * NSTEP+1 ) #else LPCT1 = INT( THICKH*THSTPI + 1.D0 ) LPCT2 = MIN( INT( THCKHN*THSTPI ), NSTEP ) #endif #if __UPWARD__ #if __SLANT__ IF ( LPCT2 .GT. LPCT1 ) THEN C FORWARD MOVING PARTICLE #else IF ( COSTHE .GT. 0.D0 ) THEN C DOWNWARD MOVING PARTICLE #endif #endif DO IL = LPCT1, LPCT2 #if __THIN__ ELONG(IL,10) = ELONG(IL,10) + GAMMA * WEIGHT PLONG(IL,10) = PLONG(IL,10) + WEIGHT #else ELONG(IL,10) = ELONG(IL,10) + GAMMA PLONG(IL,10) = PLONG(IL,10) + 1.D0 #endif ENDDO #if __UPWARD__ #if __SLANT__ ELSEIF ( LPCT2 .LT. LPCT1 ) THEN C BACKWARD MOVING PARTICLE #else ELSEIF ( COSTHE .LT. 0.D0 ) THEN C UPWARD MOVING PARTICLE #endif LPCT1 = LPCT1 - 1 LPCT2 = MAX( INT( THCKHN*THSTPI + 1.D0 ), 0 ) DO IL = LPCT1, LPCT2, -1 #if __THIN__ ELONG(IL,10) = ELONG(IL,10) + GAMMA * WEIGHT PLONG(IL,10) = PLONG(IL,10) + WEIGHT #else ELONG(IL,10) = ELONG(IL,10) + GAMMA PLONG(IL,10) = PLONG(IL,10) + 1.D0 #endif ENDDO ELSE C PARTICLE MOVES HORIZONTALLY ENDIF #endif ENDIF #endif ENDIF #endif ENDIF C----------------------------------------------------------------------- #if __UPWARD__ C KILL PARTICLE MOVING OUT OF ATMOSPHERE IF ( HNEW .GE. HLAY(6) .OR. * ( OUTPAR(2) .LE. 0.D0 .AND. THCKHN .LT. 1.D-7 ) ) THEN IRETE = .TRUE. GOTO 1111 ENDIF #endif OUTPAR( 0) = CURPAR(0) OUTPAR( 1) = GAMMAN OUTPAR( 5) = HNEW OUTPAR( 9) = GEN OUTPAR(10) = ALEVEL #if __PARALLEL__ C SET ECTFLG TO OFF OUTPAR(39) = CURPAR(39) #endif #if __THIN__ OUTPAR(13) = WEIGHT IF ( DEBUG ) WRITE(MDEBUG,458) (OUTPAR(I),I=0,9),OUTPAR(13) 458 FORMAT(' UPDATE: OUTPAR=',1P,9E11.3,0P,F10.0,1P,E10.3) #else IF ( DEBUG ) WRITE(MDEBUG,458) (OUTPAR(I),I=0,9) 458 FORMAT(' UPDATE: OUTPAR=',1P,9E11.3,0P,F10.0) #endif #if __EHISTORY__ DO IK = 1, 22 OUTPAR(16+IK) = CURPAR(16+IK) ENDDO #endif #if __MULTITHIN__ DO IK = 41, 46 OUTPAR(IK) = CURPAR(IK) ENDDO #endif #if !__CURVED__ #if __PARALLEL__ IF ( .NOT. (FIRSTI .AND. JCOUNT .GT. 1 )) THEN #endif #if __PLOTSH__ C END OF THE TRACKING STEP IF ( PLOTSH .AND. IPAS .EQ. 0 ) THEN TRX2 = OUTPAR(7) TRY2 = OUTPAR(8) #if __UPWARD__ IF ( PRMPAR(2) .LT. 0.D0 ) THEN TRZ2 = MIN( HNEW, OBSLEV(NOBSLV) ) ELSE #endif TRZ2 = MAX( HNEW, OBSLEV(NOBSLV) ) #if __UPWARD__ ENDIF #endif TRT2 = OUTPAR(6) IF ( ITYPE .EQ. 5 .OR. ITYPE .EQ. 6 ) THEN WRITE(56) TRID,TRE,TRX1,TRY1,TRZ1,TRT1,TRX2,TRY2,TRZ2,TRT2 #if __THIN__ * ,WEIGHT #endif NPLMU = NPLMU + 1 ELSE WRITE(57) TRID,TRE,TRX1,TRY1,TRZ1,TRT1,TRX2,TRY2,TRZ2,TRT2 #if __THIN__ * ,WEIGHT #endif NPLHAD = NPLHAD + 1 ENDIF IF ( DEBUG ) THEN #if __THIN__ WRITE(MDEBUG,2552) TRID,TRE,TRX1,TRY1,TRZ1,TRT1, * TRX2,TRY2,TRZ2,TRT2,WEIGHT 2552 FORMAT(' TRACKINF ',1P,6E15.5,/,40X,5E15.5) #else WRITE(MDEBUG,2552) TRID,TRE,TRX1,TRY1,TRZ1,TRT1, * TRX2,TRY2,TRZ2,TRT2 2552 FORMAT(' TRACKINF ',1P,6E15.5,/,40X,4E15.5) #endif ENDIF ENDIF #endif #if __PLOTSH2__ C END OF THE TRACKING STEP APPLY TIME CUT IF ( PLOTSH .AND. IPAS .EQ. 0 * .AND. OUTPAR(6) .LT. PLTCUT ) THEN TRX2 = OUTPAR(7) TRY2 = OUTPAR(8) #if __UPWARD__ IF ( PRMPAR(2) .LT. 0.D0 ) THEN TRZ2 = MIN( HNEW, OBSLEV(NOBSLV) ) ELSE #endif TRZ2 = MAX( HNEW, OBSLEV(NOBSLV) ) #if __UPWARD__ ENDIF #endif TRT2 = OUTPAR(6) #if __THIN__ WGHT = OUTPAR(13) #endif IF ( FBOXCUT ) CALL PLTRUNC IF ( ( TRID .LE. 1.D0 .AND. TRE .GT. PLCUT(4) ) .OR. * ( ( TRID .EQ. 2.D0 .OR. TRID .EQ. 3.D0 ) .AND. * TRE .GT. PLCUT(3) ) ) THEN C X-Y AND OTHER PROJECTIONS (E.M.-> MAP 1) CALL LINPLXY( 1,TRX1,TRY1,TRX2,TRY2,WGHT ) CALL LINPLXZ( 1,TRX1,TRZ1,TRX2,TRZ2,WGHT ) CALL LINPLYZ( 1,TRY1,TRZ1,TRY2,TRZ2,WGHT ) ELSEIF ( ( TRID .EQ. 5.D0 .OR. TRID .EQ. 6.D0 ) .AND. * TRE .GT. PLCUT(2) ) THEN C X-Y AND OTHER PROJECTIONS (MU -> MAP 2) CALL LINPLXY( 2,TRX1,TRY1,TRX2,TRY2,WGHT ) CALL LINPLXZ( 2,TRX1,TRZ1,TRX2,TRZ2,WGHT ) CALL LINPLYZ( 2,TRY1,TRZ1,TRY2,TRZ2,WGHT ) ELSEIF ( TRID .GE. 7.D0 .AND. TRE .GT. PLCUT(1) ) THEN C X-Y AND OTHER PROJECTIONS (HADRONS -> MAP 3) CALL LINPLXY( 3,TRX1,TRY1,TRX2,TRY2,WGHT ) CALL LINPLXZ( 3,TRX1,TRZ1,TRX2,TRZ2,WGHT ) CALL LINPLYZ( 3,TRY1,TRZ1,TRY2,TRZ2,WGHT ) ENDIF IF ( DEBUG ) THEN WRITE(MDEBUG,2553) TRID,TRE,TRX1,TRY1,TRZ1,TRT1, * TRX2,TRY2,TRZ2,TRT2 2553 FORMAT(' TRACKINF2 ',1P,6E15.5,/,41X,4E15.5) ENDIF ENDIF #endif #if __PARALLEL__ ENDIF C TRACK IS NOT CALLED IN AAMAIN IF PRIMARY TRACK IS DONE WITH 2ND STACK NOT EMPTY #endif #if __COASTUSERLIB__ C END OF TRACKING STEP pnt2id = OUTPAR(0) pnt2gen= OUTPAR(9) pnt2x = OUTPAR(7) - XOFF(NOBSLV) pnt2y = OUTPAR(8) - YOFF(NOBSLV) pnt2z = HNEW #if __SLANT__ pnt2d = THCKSI( OUTPAR(7)*STHCPH + OUTPAR(8)*STHSPH * - pnt2z*CTH + RLOFF ) #else pnt2d = THCKHN/COS( THETAP ) #endif pnt2t = OUTPAR(6) pnt2e = PAMA(pnt2id)*GAMMAN #if __THIN__ pnt2w = OUTPAR(13) #else pnt2w = 1.D0 #endif #endif #endif C REGULAR END OF UPDATE IRET2 = 0 RETURN 1111 CONTINUE IF ( CURPAR(0) .NE. 5.D0 .AND. CURPAR(0) .NE. 6.D0 ) RETURN C SPECIAL TREATMENT ONLY FOR MUONS BELOW ENERGY OR ANGULAR CUT #if __MUPROD__ C THESE VALUES ARE NOT CORRECT, ONLY FOR UNAFFECTED MUONS. C FOR A PRECISE CALCULATION FOR EACH RETURN CONDITION A DIFFERENT C SETTING OF THE POSITIONS AND ANGLES WOULD BE REQUIRED OUTPAR( 0) = CURPAR(0) OUTPAR( 1) = GAMMAN OUTPAR( 2) = COSTHE OUTPAR( 3) = PHIX OUTPAR( 4) = PHIY OUTPAR( 5) = HNEW OUTPAR( 6) = T + SN / ( C(25) * BETA ) OUTPAR( 7) = X + SN * PHIX OUTPAR( 8) = Y + SN * PHIY OUTPAR( 9) = GEN OUTPAR(10) = ALEVEL #endif #if __EHISTORY__ DO IK = 1, 22 OUTPAR(16+IK) = CURPAR(16+IK) ENDDO #endif #if __MULTITHIN__ DO IK = 41, 46 OUTPAR(IK) = CURPAR(IK) ENDDO #endif RETURN END *-- Author : D. HECK IK FZK KARLSRUHE 27/04/1994 C======================================================================= SUBROUTINE VAPOR( 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 (GEANT) C PFRX(1:JFIN) = TRANSVERSE MOMENTUM OF FRAGMENTS IN X-DIRECTION (GEV) C PFRY(1:JFIN) = TRANSVERSE MOMENTUM OF FRAGMENTS IN Y-DIRECTION (GEV) C----------------------------------------------------------------------- IMPLICIT NONE #define __CONSTAINC__ #define __DPMFLGINC__ #define __RANDPAINC__ #define __RUNPARINC__ #include "corsika.h" DOUBLE PRECISION PFR(60),PFRX(60),PFRY(60) DOUBLE PRECISION AFIN,AGLH,APRF,BGLH,EEX,PHIFR,RANNOR,SPFRX,SPFRY INTEGER ITYP(60),IARM,INEW,ITYPRM,INRM,IS,IZRM,JC,JFIN, * K,L,LS,MAPROJ,MF,NFIN,NINTA,NNUC,NPRF,NNSTEP SAVE EXTERNAL RANNOR C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'VAPOR : MAPROJ,INEW=',MAPROJ,INEW ITYPRM = INEW NPRF = INEW/100 NINTA = MAPROJ - NPRF IF ( NINTA .EQ. 0 ) THEN C NO NUCLEON HAS INTERACTED JFIN = 1 PFR(1) = 0.D0 ITYP(1) = INEW IF ( DEBUG ) WRITE(MDEBUG,*) 'VAPOR : JFIN,NINTA=',JFIN,NINTA 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,1 ) 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 IF (DEBUG) WRITE(MDEBUG,*)'VAPOR : EEX=',SNGL(EEX*0.04D0),' GEV' 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 ) IF ( NNSTEP .LE. 0 ) THEN C EXCITATION ENERGY TOO SMALL, NO EVAPORATION JFIN = 1 PFR(1) = 0.D0 ITYP(1) = INEW IF (DEBUG) WRITE(MDEBUG,*) 'VAPOR : JFIN,EEX=',JFIN,SNGL(EEX) 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 IF ( DEBUG ) WRITE(MDEBUG,*) 'VAPOR : NFIN,NNUC=',NFIN,NNUC JC = 0 IF ( NNUC .LE. 0 ) THEN C NO EVAPORATION JFIN = 1 PFR(1) = 0.D0 ITYP(1) = INEW 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,1 ) IF ( RD(1) .LT. 0.2D0 .AND. IZRM .GE. 2 * .AND. INRM .GE. 2 ) THEN ITYP(JC) = 402 NNUC = NNUC - 4 ITYPRM = ITYPRM - 402 ELSE IF ( RD(2)*(IZRM+INRM) .LT. IZRM ) THEN ITYP(JC) = 14 ITYPRM = ITYPRM - 101 ELSE ITYP(JC) = 13 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,1 ) 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) = 14 ITYPRM = ITYPRM - 101 ELSE ITYP(JC) = 13 ITYPRM = ITYPRM - 100 ENDIF ENDDO ENDIF 50 CONTINUE JC = JC + 1 IF ( ITYPRM .GE. 201 ) THEN ITYP(JC) = ITYPRM ELSEIF ( ITYPRM .EQ. 200 ) THEN ITYP(JC) = 13 JC = JC + 1 ITYP(JC) = 13 ELSEIF ( ITYPRM .EQ. 101 ) THEN ITYP(JC) = 14 ELSEIF ( ITYPRM .EQ. 100 ) THEN ITYP(JC) = 13 ELSE JC = JC - 1 IF ( ITYPRM .NE. 0 ) WRITE(MONIOU,*) * 'VAPOR : ILLEGAL PARTICLE ITYPRM =',ITYPRM ENDIF 100 CONTINUE JFIN = JC IF ( DEBUG ) WRITE(MDEBUG,*) 'VAPOR : NO ITYP PFR' IF ( NFRAGM .EQ. 2 ) THEN C EVAPORATION WITH PT AFTER PARAMETERIZED JACEE DATA DO MF = 1, JFIN PFR(MF) = RANNOR(0.088D0,0.044D0) IF ( DEBUG ) WRITE(MDEBUG,*) MF,ITYP(MF),SNGL(PFR(MF)) ENDDO ELSEIF ( NFRAGM .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) IF ( DEBUG ) WRITE(MDEBUG,*) MF,ITYP(MF),SNGL(PFR(MF)) ENDDO ELSE C EVAPORATION WITHOUT TRANSVERSE MOMENTUM DO MF = 1, JFIN PFR(MF) = 0.D0 IF ( DEBUG ) WRITE(MDEBUG,*) MF,ITYP(MF),SNGL(PFR(MF)) ENDDO ENDIF C CALCULATE RESIDUAL TRANSVERSE MOMENTUM SPFRX = 0.D0 SPFRY = 0.D0 CALL RMMARD( RD,JFIN,1 ) 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 IF ( DEBUG ) WRITE(MDEBUG,*) 'VAPOR : NINTA,JFIN=',NINTA,JFIN RETURN END *-- Author : D. HECK IK FZK KARLSRUHE 25/06/2003 C======================================================================= DOUBLE PRECISION FUNCTION VBSE( Y ) C----------------------------------------------------------------------- C FUNCTION TO BE USED FOR INTEGRATION OF MUON/TAU 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 Y = DUMMY ARRAY OF DIMENSION N C----------------------------------------------------------------------- IMPLICIT NONE #define __CONSTAINC__ #define __MUPARTINC__ #define __PAMINC__ #include "corsika.h" DOUBLE PRECISION ALPHFA,BBS,CBS,RE PARAMETER (ALPHFA = 7.297353D-3) PARAMETER (BBS = 184.15D0) PARAMETER (CBS = 1194.0D0) PARAMETER (RE = 2.81794092D-13) ! ELECTR. RADIUS IN CM 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 SAVE C----------------------------------------------------------------------- XX = Y(2) IF ( MT .EQ. 1 ) THEN C MUON ABS = ( 2.D0 * RE * ZATOM * EBYMU )**2 DBS = (1.D0 - XX) C EE IS THE TOTAL ENERGY OF INCOMING MUON QMIN = XX * PAMA(5)**2 / (2.D0 * EE * DBS) ELSE C TAU LEPTON ABS = ( 2.D0 * RE * ZATOM * EBYTAU )**2 DBS = (1.D0 - XX) C EE IS THE TOTAL ENERGY OF INCOMING MUON QMIN = XX * PAMA(131)**2 / (2.D0 * EE * DBS) ENDIF A1 = BBS / ( SE * PAMA(2) * ZATOM**OB3 ) A2 = CBS / ( SE * PAMA(2) * 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 IF ( MT .EQ. 1 ) THEN C MUON C1 = LOG( ( (PAMA(5)*A1)**2 ) / (1.D0+X1SQ) ) C2 = LOG( ( (PAMA(5)*A2)**2 ) / (1.D0+X2SQ) ) ELSE C TAU LEPTON C1 = LOG( ( (PAMA(131)*A1)**2 ) / (1.D0+X1SQ) ) C2 = LOG( ( (PAMA(131)*A2)**2 ) / (1.D0+X2SQ) ) ENDIF 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 *-- Author : D. HECK IK FZK KARLSRUHE 13/05/2003 C======================================================================= DOUBLE PRECISION FUNCTION VBSS( Y ) C----------------------------------------------------------------------- C FUNCTION TO BE USED FOR INTEGRATION OF MUON/TAU 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 Y = DUMMY ARRAY OF DIMENSION N C----------------------------------------------------------------------- IMPLICIT NONE #define __CONSTAINC__ #define __MUPARTINC__ #define __PAMINC__ #include "corsika.h" DOUBLE PRECISION ALPHFA,BBS,CBS,RE PARAMETER (ALPHFA = 7.297353D-3) PARAMETER (BBS = 184.15D0) PARAMETER (CBS = 1194.0D0) PARAMETER (RE = 2.81794092D-13) ! ELECTR. RADIUS IN CM 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 SAVE C----------------------------------------------------------------------- XX = Y(2) IF ( MT .EQ. 1 ) THEN C MUON ABS = ( 2.D0 * RE * ZATOM * EBYMU )**2 DBS = (1.D0 - XX) C EE IS THE TOTAL ENERGY OF INCOMING MUON QMIN = XX * PAMA(5)**2 / (2.D0 * EE * DBS) ELSE C TAU LEPTON ABS = ( 2.D0 * RE * ZATOM * EBYTAU )**2 DBS = (1.D0 - XX) C EE IS THE TOTAL ENERGY OF INCOMING MUON QMIN = XX * PAMA(131)**2 / (2.D0 * EE * DBS) ENDIF A1 = BBS / ( SE * PAMA(2) * ZATOM**OB3 ) A2 = CBS / ( SE * PAMA(2) * 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 IF ( MT .EQ. 1 ) THEN C MUON C1 = LOG( ( (PAMA(5)*A1)**2 ) / (1.D0+X1SQ) ) C2 = LOG( ( (PAMA(5)*A2)**2 ) / (1.D0+X2SQ) ) ELSE C TAU LEPTON C1 = LOG( ( (PAMA(131)*A1)**2 ) / (1.D0+X1SQ) ) C2 = LOG( ( (PAMA(131)*A2)**2 ) / (1.D0+X2SQ) ) ENDIF 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 *-- Author : D. HECK IK FZK KARLSRUHE 04/02/2004 C======================================================================= DOUBLE PRECISION FUNCTION VPHL( Y ) 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 Y = DUMMY ARRAY OF DIMENSION N C----------------------------------------------------------------------- IMPLICIT NONE #define __CONSTAINC__ #define __MUPARTINC__ #define __PAMINC__ #include "corsika.h" 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) PARAMETER (ELE1 = 0.0808D0) PARAMETER (ELE2 = -0.4525D0) DOUBLE PRECISION Y(2) DOUBLE PRECISION BPH,CPH,DPH,EPH,FPH,GG,HHH, * SS,SIGN,TTT,VPH1,VPH2,XX,ZZZ SAVE C----------------------------------------------------------------------- XX = Y(2) C CALCULATE BEZRUKOV''S T IF ( MT .EQ. 1 ) THEN C MUON TTT = PAMA(5)**2 * XX**2 / (1.D0 - XX) ELSE C TAU LEPTON TTT = PAMA(131)**2 * XX**2 / (1.D0 - XX) ENDIF C SS IS ENERGY**2 IN CM SYSTEM, EE IS TOTAL ENERGY OF INCOMING MUON SS = 2.D0 * PAMA(14) * 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 FPH = AM21 / (AM21 + TTT) IF ( MT .EQ. 1 ) THEN C MUON EPH = 2.D0 * PAMA(5)**2 / 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 * PAMA(5)**2/TTT) * * ( GG * FPH + (AM22/TTT) * LOG( 1.D0 + (TTT/AM22) ) ) ELSE C TAU LEPTON EPH = 2.D0 * PAMA(131)**2 / 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 * PAMA(131)**2/TTT) * * ( GG * FPH + (AM22/TTT) * LOG( 1.D0 + (TTT/AM22) ) ) ENDIF C FOR ENERGY LOSSES VPHL = BPH * (VPH1+VPH2) IF ( VPHL .LE. 0.D0 ) VPHL = 0.D0 RETURN END *-- Author : D. HECK IK FZK KARLSRUHE 15/05/2003 C======================================================================= DOUBLE PRECISION FUNCTION VPHM( Y ) C----------------------------------------------------------------------- C FUNCTION TO BE USED FOR INTEGRATION OF MUON/TAU 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 Y = DUMMY ARRAY OF DIMENSION N C----------------------------------------------------------------------- IMPLICIT NONE #define __CONSTAINC__ #define __MUPARTINC__ #define __PAMINC__ #include "corsika.h" 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) PARAMETER (ELE1 = 0.0808D0) PARAMETER (ELE2 = -0.4525D0) DOUBLE PRECISION Y(2) DOUBLE PRECISION BPH,CPH,DPH,EPH,FPH,GG,HHH, * SS,SIGN,TTT,VPH1,VPH2,XX,ZZZ SAVE C----------------------------------------------------------------------- XX = Y(2) C CALCULATE BEZRUKOV''S T C MUON IF ( MT .EQ. 1 ) THEN TTT = PAMA(5)**2 * XX**2 / (1.D0 - XX) ELSE C TAU LEPTON TTT = PAMA(131)**2 * XX**2 / (1.D0 - XX) ENDIF C SS IS ENERGY**2 IN CM SYSTEM, EE IS TOTAL ENERGY OF INCOMING MUO SS = 2.D0 * PAMA(14) * 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 FPH = AM21 / (AM21 + TTT) IF ( MT .EQ. 1 ) THEN C MUON EPH = 2.D0 * PAMA(5)**2 / 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 * PAMA(5)**2/TTT) * * ( GG * FPH + (AM22/TTT) * LOG( 1.D0 + (TTT/AM22) ) ) ELSE C TAU LEPTON EPH = 2.D0 * PAMA(131)**2 / 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 * PAMA(131)**2/TTT) * * ( GG * FPH + (AM22/TTT) * LOG( 1.D0 + (TTT/AM22) ) ) ENDIF C FINAL CROSS-SECTION VPHM = BPH * (VPH1+VPH2) / XX IF ( VPHM .LT. 0.D0 ) VPHM = 0.D0 RETURN END *-- Author : D. HECK IK FZK KARLSRUHE 21/04/1994 C======================================================================= C C EGS4 SUBROUTINE VERSION FOR CORSIKA C C----------------------------------------------------------------------- C AUTHORS OF EGS4-SOURCE WITHOUT CORSIKA-MODIFICATIONS: C 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 MODIFICATIONS FOR CORSIKA: C DIETER HECK C KARLSRUHER INSTITUT FUER TECHNOLOGIE (KIT) C INSTITUT FUER KERNPHYSIK C POSTFACH 3640 C D-76021 KARLSRUHE, FED. REP. GERMANY C TEL: 07247-82-3777 C FAX: 07247-82-4075 C E-MAIL: DIETER.HECK@PARTNER.KIT.EDU C----------------------------------------------------------------------- C EGS4 USER SUBROUTINES TO STUDY THE AIR SHOWER DEVELOPMENT IN THE C ATMOSPHERE WITH: C BAROMETRIC DENSITY DISTRIBUTION (4 LAYER WITH EXP. DENSITY) C LAYER PARAMETERS ARE TAKEN FROM CORSIKA C STERNHEIMER CORRECTION OF DENSITY DEPENDENT IONISATION LOSS C PROPAGATION TIME C FAST REJECTION OF SUBSHOWERS, WHICH LEAD ONLY WITH SMALL C CHANCE TO CHARGED PARTICLES AT DETECTOR LEVEL C EARTH MAGNETIC FIELD WITH CORRECTED PATH LENGTH C AGE (GENERATION) OF PARTICLES IN HADRONIC INTERACTIONS C MULTIPLE SCATTERING IS MODIFIED 'STEPFC*(TEFF0*200)' C PHOTONUCLEAR REACTION LEADING TO PIONS C MUONIC PAIR FORMATION C FZK-IK/CORSIKA STANDARDS FOR RANDOM GENERATOR, PARTICLE C IDENTIFICATION, DETECTION LEVELS C CHERENKOV RADIATION, IF OPTION 'CERENKOV' IS SELECTED C LONGITUDINAL DISTRIBUTION OF PARTICLES, ENERGIES, ENERGY DEPOSITS C 'THINNING' ENABLED BY OPTION 'THIN' C LANDAU-POMERANCHUK-MIGDAL EFFECT C SIN AND COSIN NOW AS FORTRAN FUNCTIONS C ALL QUANTITIES IN DOUBLE PRECISION, IF NOT FROM PEGS4-FILE C ALL ROUTINES WITH 'IMPLICIT NONE' AND 'SAVE' C EXTENSIONS FOR 'CURVED' VERSION OF CORSIKA C EXTENSIONS FOR UPWARD GOING PARTICLES C EXTENSIONS FOR 'SLANT' DEPTH LONGITUDINAL DISTRIBUTION C DEBUGGING STATEMENTS BY ACTIVATION OF COUNTERS JCLOCK, NCLOCK C----------------------------------------------------------------------- C THE FOLLOWING UNITS ARE USED: UNIT 12 IS PEGS CROSS-SECTION FILE C UNIT MDEBUG FOR DEBUG OUTPUT C----------------------------------------------------------------------- C PHYSICAL UNITS INTERNALLY USED IN THE CORSIKA-EGS4 ARE: C LENGTH IN CM C ENERGY IN MEV C TIME IN SEC C C DIRECTIONS OF COORDINATE SYSTEM WITHIN THE CORSIKA-EGS4 ARE: C +X ----> NORTH C +Y ----> EAST C +Z ----> DOWN C----------------------------------------------------------------------- *-- Author : STANFORD LINEAR ACCELERATOR CENTER C======================================================================= C STANFORD LINEAR ACCELERATOR CENTER SUBROUTINE ANNIH C VERSION 4.00 -- 26 JAN 1986/1900 C----------------------------------------------------------------------- C ANNIH(ILATION OF E+) C C GAMMA SPECTRUM FOR TWO GAMMA IN-FLIGHT POSITRON ANNIHILATION. C USING SCHEME BASED ON HEITLER''S P269-270 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 THIS SUBROUTINE IS CALLED FROM ELECTR. C----------------------------------------------------------------------- IMPLICIT NONE #define __EGSDEBINC__ #define __RANDPAINC__ #define __RUNPARINC__ #define __STACKEINC__ #define __UPHIOTINC__ #define __USEFULINC__ #include "corsika.h" DOUBLE PRECISION A,AI,EP,EP0I,G,P,PESG1,PESG2,PAVIP,POT,REJF,T SAVE C----------------------------------------------------------------------- IF ( FEGSDB ) THEN WRITE(MDEBUG,1) NP,IR(NP),IOBS(NP) 1 FORMAT(' ANNIH : NP=',I3,' IR=',I3,' IOBS=',I3) CALL AUSGB2 ENDIF PAVIP = E(NP)+PRM A = PAVIP*RMI AI = 1.D0/A G = A - 1.D0 T = G - 1.D0 P = SQRT( A * T ) POT = P/T EP0I = (A+P) 331 CONTINUE C SAMPLE 1/EP FROM EP=1./EP0I TO 1.0-1./EP0I CALL RMMARD( RD,2,2 ) EP = EXP( DBLE(RD(1))*LOG( EP0I-1.D0 ) )/EP0I C NOW DECIDE WHETHER TO ACCEPT REJF = 1.D0 - EP + AI*AI*(2.D0*G-1.D0/EP) IF ( RD(2) .GT. REJF ) GOTO 331 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). PESG1 = PAVIP*MAX(EP,1.D0-EP) E(NP) = PESG1 E(NP+1) = PAVIP-E(NP) PESG2 = E(NP+1) C SET UP ANGLES OF HIGHER ENERGY GAMMA IQ(NP) = 1 COSTHE = (PESG1-PRM)*POT/PESG1 SINTHE = SQRT( MAX( 0.D0, (1.D0-COSTHE)*(1.D0+COSTHE) ) ) CALL UPHI( 2,1 ) NP = NP+1 C SET UP ANGLES OF LOWER ENERGY GAMMA IQ(NP) = 1 COSTHE = (PESG2-PRM)*POT/PESG2 SINTHE = SQRT( MAX( 0.D0, (1.D0-COSTHE)*(1.D0+COSTHE) ) ) CALL UPHI( 3,2 ) RETURN END *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE AUSGAB C----------------------------------------------------------------------- C WE USE AUSGAB TO FILL OUTPAR WITH PARTICLE COORDINATES. C THIS SUBROUTINE IS CALLED FROM ELECTR AND PHOTON. C----------------------------------------------------------------------- IMPLICIT NONE #define __EGSDEBINC__ #define __GENERINC__ #define __MISCINC__ #define __PARPARINC__ #define __RUNPARINC__ #define __STACKEINC__ #define __UPHIOTINC__ #define __USEFULINC__ #if __MULTITHIN__ #define __MULTHININC__ #endif #include "corsika.h" DOUBLE PRECISION ANGLEX,ANGLEY,ANGLEZ,XX,YY,ZZ #if __EHISTORY__ || __MULTITHIN__ INTEGER II #endif SAVE C----------------------------------------------------------------------- IF ( FEGSDB ) .WRITE(MDEBUG,*) 'AUSGAB: NP=',NP,' IR=',IR(NP),' IOBS=',IOBS(NP) C ANGLE WITH RESPECT TO X AXIS C PARTICLE IS WRITTEN IN OUTPUT BUFFER ARRAY OUTPAR(0) = IQ(NP) OUTPAR(1) = E(NP)*0.001D0 OUTPAR(2) = MIN( 1.D0, W(NP) ) OUTPAR(3) = U(NP) OUTPAR(4) =-V(NP) OUTPAR(5) =-Z(NP) OUTPAR(6) = TIM(NP) OUTPAR(7) = X(NP) OUTPAR(8) =-Y(NP) OUTPAR(9) = IGEN(NP) OUTPAR(10) = ALEVEL #if __THIN__ OUTPAR(13) = WT(NP) #endif #if __EHISTORY__ C BRING MOTHER AND GRANDMOTHER PARTICLE TO OUTPUT DO II = 1, 22 OUTPAR(16+II) = SECPAR(16+II) ENDDO #endif #if __PARALLEL__ C SET ECTFLG TO OFF OUTPAR(39) = -1.D0 #endif #if __MULTITHIN__ DO II = 1, 6 OUTPAR(40+II) = 0.D0 ENDDO DO II = 1, NMTHIN OUTPAR(40+II) = WTM(II,NP) ENDDO #endif LEVL = MAX( IOBS(NP), 1 ) CALL OUTPT1 IF ( FEGSDB ) THEN XX = X(NP) YY =-Y(NP) ZZ =-Z(NP) ANGLEX = U(NP) ANGLEY =-V(NP) ANGLEZ = W(NP) WRITE(MDEBUG,170) IQ(NP),E(NP)*.001D0,ANGLEZ,ANGLEX,ANGLEY,ZZ, * TIM(NP)*1.D3,XX,YY,IGEN(NP) #if __THIN__ * ,WT(NP) #endif #if __PARALLEL__ * ,OUTPAR(39) #endif 170 FORMAT(' AUSGAB:',13X,I4,1P,E13.3,0P,1X,F9.5,1X,F10.6,1X,F10.6, * 1X,F11.0,1X,F10.6,1X,1P,E10.3,1X,E10.3,1X,I10,0P #if __THIN__ * ,1X,F10.2 #endif #if __PARALLEL__ * ,1X,F4.1 #endif * ) ENDIF RETURN END *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE AUSGB2 C----------------------------------------------------------------------- C IN CASE OF DEBUGGING WE PRINT THE PARTICLE COORDINATES. C THIS SUBROUTINE IS CALLED FROM MANY EGS-ROUTINES. C----------------------------------------------------------------------- IMPLICIT NONE #define __EGSDEBINC__ #define __MISCINC__ #define __PARPARINC__ #define __RUNPARINC__ #define __STACKEINC__ #define __UPHIOTINC__ #define __USEFULINC__ #if __MULTITHIN__ #define __MULTHININC__ #endif #include "corsika.h" DOUBLE PRECISION ANGLEX,ANGLEY,ANGLEZ,XX,YY,ZZ #if __MULTITHIN__ INTEGER J #endif SAVE C----------------------------------------------------------------------- C ANGLE WITH RESPECT TO X AXIS XX = X(NP) YY =-Y(NP) ZZ =-Z(NP) ANGLEZ = W(NP) ANGLEX = U(NP) ANGLEY =-V(NP) WRITE(MDEBUG,170) IQ(NP),E(NP)*.001D0,ANGLEZ,ANGLEX,ANGLEY,ZZ, * TIM(NP)*1.0D3,XX,YY,IGEN(NP),LPCTE(NP) #if __THIN__ * ,WT(NP) #endif #if __MULTITHIN__ * ,(WTM(J,NP),J=1,NMTHIN) #endif 170 FORMAT(' AUSGB2:',13X,I4,1P,E13.3,0P,1X,F9.5,1X,F10.6,1X,F10.6, * 1X,F11.0,1X,F10.6,1X,1P,E10.3,1X,E10.3,0P,1X,I10,1X,I5 #if __THIN__ * ,1X,1P,E10.3,0P #endif #if __MULTITHIN__ * ,1X,1P,6E10.3,0P #endif * ) RETURN END *-- Author : STANFORD LINEAR ACCELERATOR CENTER C======================================================================= C STANFORD LINEAR ACCELERATOR CENTER SUBROUTINE BHABHA C VERSION 4.00 -- 26 JAN 1986/1900 C----------------------------------------------------------------------- C BHABHA (SCATTERING) 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 THIS SUBROUTINE IS CALLED FROM ELECTR. C----------------------------------------------------------------------- IMPLICIT NONE #define __EGSDEBINC__ #define __RANDPAINC__ #define __RUNPARINC__ #define __STACKEINC__ #define __THRESHINC__ #define __UPHIOTINC__ #define __USEFULINC__ #include "corsika.h" DOUBLE PRECISION BETA2,BR,B1,B2,B3,B4,DCOSTH,EP0,EP0C,E0,E02,H1, * PEIP,PEKIN,PEKINI,PEKSE2,PESE1,PESE2,REJF2, * T0,YY,Y2,YP,YP2 SAVE C----------------------------------------------------------------------- IF ( FEGSDB ) THEN WRITE(MDEBUG,1) NP,IR(NP),IOBS(NP) 1 FORMAT(' BHABHA: NP=',I3,' IR=',I3,' IOBS=',I3) CALL AUSGB2 ENDIF C WE HAVE ELECTRON INTERACTION, INCREASE GEN. COUNTER BY 1.E3 IGEN(NP) = IGEN(NP) + 1000 PEIP = E(NP) C KINETIC ENERGY OF INCIDENT POSITRON PEKIN = PEIP-PRM PEKINI= 1.D0/PEKIN T0 = PEKIN*RMI E0 = T0+1.D0 YY = 1.D0/(T0+2.D0) E02 = E0**2 BETA2 = (E02-1.D0)/E02 EP0 = TE*PEKINI EP0C = 1.D0-EP0 Y2 = YY*YY YP = 1.D0-2.D0*YY YP2 = YP**2 B4 = YP2*YP B3 = B4+YP2 B2 = YP*(3.D0+Y2) B1 = 2.D0-Y2 341 CONTINUE C SAMPLE BR FROM MINIMUM(EP0) TO 1 CALL RMMARD( RD,2,2 ) BR = EP0/(1.D0-EP0C*RD(1)) REJF2 = (1.D0-BETA2*BR*(B1-BR*(B2-BR*(B3-BR*B4)))) IF ( RD(2) .GT. REJF2 ) GOTO 341 IF ( BR .LT. 0.5D0 ) THEN IQ(NP+1) = 3 ELSE C IF E- GOT MORE THAN E+, MOVE THE E+ POINTER AND REFLECT B IQ(NP) = 3 IQ(NP+1) = 2 BR = 1.D0-BR ENDIF BR = MAX( 0.D0, BR ) C DIVIDE UP THE ENERGY PEKSE2 = BR*PEKIN PESE1 = PEIP-PEKSE2 PESE2 = PEKSE2+PRM E(NP) = PESE1 E(NP+1) = PESE2 C DETERMINE ANGLES FROM KINEMATICS H1 = (PEIP+PRM)*PEKINI C DIRECTION COSINE CHANGE FOR 'OLD' ELECTRON DCOSTH = MIN( 1.D0, H1*(PESE1-PRM)/(PESE1+PRM) ) SINTHE = SQRT( 1.D0 - DCOSTH ) COSTHE = SQRT( DCOSTH ) CALL UPHI( 2,1 ) NP = NP+1 DCOSTH = MIN( 1.D0, H1*(PESE2-PRM)/(PESE2+PRM) ) SINTHE =-SQRT( 1.D0 - DCOSTH ) COSTHE = SQRT( DCOSTH ) CALL UPHI( 3,2 ) RETURN END *-- Author : STANFORD LINEAR ACCELERATOR CENTER C======================================================================= C STANFORD LINEAR ACCELERATOR CENTER #if __LPM__ || __THIN__ || __PARALLEL__ || __MULTITHIN__ SUBROUTINE BREMSLPM( FPASS ) #else SUBROUTINE BREMS #endif C VERSION 4.00 -- 26 JAN 1986/1900 C----------------------------------------------------------------------- C BREMS(STRAHLUNG GENERATION) C C FOR ELECTRON ENERGY GREATER THAN 5.0 MEV, THE BETHE-HEITLER C CROSS-SECTION IS EMPLOYED. C THIS SUBROUTINE IS CALLED FROM ELECTR. #if __LPM__ || __THIN__ || __PARALLEL__ || __MULTITHIN__ C ARGUMENT: C FPASS = (LOGICAL) FLAG INDICATING THAT INTERRACTION IS SUPPRESSED #endif C----------------------------------------------------------------------- IMPLICIT NONE #define __BREMPRINC__ #define __EGSDEBINC__ #define __RANDPAINC__ #define __RUNPARINC__ #define __STACKEINC__ #define __THRESHINC__ #define __UPHIOTINC__ #define __USEFULINC__ #include "corsika.h" DOUBLE PRECISION ABREMS,AI2LN2,BR,DEL,DELTA,H,P,PEIE,PESG,PESE, * REJF,T INTEGER IDISTR,LVL,LVL0,LVX #if __LPM__ || __THIN__ || __PARALLEL__ || __MULTITHIN__ LOGICAL FPASS #endif SAVE DATA AI2LN2 / 0.721347521D0 / C----------------------------------------------------------------------- IF ( FEGSDB ) THEN WRITE(MDEBUG,1) NP,IR(NP),IOBS(NP) 1 FORMAT(' BREMS : NP=',I3,' IR=',I3,' IOBS=',I3) CALL AUSGB2 ENDIF PEIE = E(NP) NP = NP+1 C DECIDE WHICH DISTRIBUTION TO USE IF ( PEIE .LT. 50.D0 ) THEN C (B-H IS USED 1.5 TO 50 MEV) LVX = 1 LVL0 = 0 ELSE C (B-H COULOMB CORRECTED IS USED ABOVE 50 MEV) LVX = 2 LVL0 = 3 ENDIF C TWO TIMES AI2LN2 = 1.442695041 ABREMS = DBLE(INT( 1.442695041D0*LOG( PEIE*API ) )) C THE METHOD OF BUTCHER AND MESSEL FOR SAMPLING A CLASS OF FACTORIZABLE C FREQUENCY DISTRIBUTIONS IS USED. OUR 'BR' VARIABLE IS THE SAME AS C THEIR 'EPSILON' VARIABLE. (SEE BUTCHER AND MESSEL,NUCL.PHYS.,VOL.20, C PP23,24. COMPUTE NUMBER OF SUBDISTRIBUTIONS NEEDED TO PRODUCE GAMMAS C OF MINIMUM DISCRETE TRANSPORT ENRGY AP, IN CASE THE (1-BR)/BR C PART OF THE DISTRIBUTION IS USED. 351 CONTINUE CALL RMMARD( RD,3,2 ) C DECIDE WHETHER TO SAMPLE FROM (1-BR)/BR OR 2*BR PART OF DISTRIBUTION IF ( (ABREMS*ALPHI(LVX)+0.5D0)*RD(1) .GE. 0.5D0 ) THEN C USE THE (1-BR)/BR PART. WHICH SUBDISTRIBUTION? IDISTR = ABREMS*RD(2) C THIS CHOOSES IDISTR AT RANDOM FROM SET (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. IF ( RD(3) .GE. AI2LN2 ) THEN 361 CONTINUE CALL RMMARD( RD,3,2 ) H = MAX( RD(2), RD(3) ) BR = 1.D0-0.5D0*H IF ( BR*RD(1) .GT. 0.5D0 ) GOTO 361 ELSE CALL RMMARD( RD,1,2 ) BR = RD(1)*0.5D0 ENDIF BR = BR*P ELSE BR = MAX( RD(2), RD(3) ) C USE B(DELTA) FOR SCREENING FUNCTION LVL = LVL0+2 ENDIF C NOW ATTRIBUTE ENERGIES TO THE PARTICLES PESG = PEIE*BR C AP IS SELECTED IN PROGRAM PEGS (ESTABLISHING CROSS-SECTION FILE) C MINIMUM HARDNESS REQUIREMENT, CORRESPONDING TO LOWER BOUND C CHOICE FOR TOTAL CROSS-SECTION INTEGRAL IF ( PESG .LT. AP ) GOTO 351 PESE = PEIE-PESG C THE ELECTRON MUST HAVE A MINIMUM ENERGY EQUAL TO 0.511 MEV IF ( PESE .LT. PRM ) GOTO 351 C DEFINITION OF DELTA IS 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=(GAMMA 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). DEL = BR/PESE C A(DELTA) AND B(DELTA) MUST ALWAYS BE POSITIVE IF ( DEL .GE. DELPOS(LVX) ) GOTO 351 DELTA = DELCM*DEL IF ( DELTA .LT. 1.D0 ) THEN REJF = DL1(LVL)+DELTA*(DL2(LVL)+DELTA*DL3(LVL)) ELSE REJF = DL4(LVL)+DL5(LVL)*LOG( DELTA+DL6(LVL) ) ENDIF CALL RMMARD( RD,1,2 ) C SCREENING REJECTION IF ( RD(1) .GT. REJF ) GOTO 351 #if __LPM__ || __THIN__ || __PARALLEL__ || __MULTITHIN__ C CHECK LPM EFFECT AT ENERGIES ABOVE 10**16 EV IF ( PEIE .GT. 1.D10 ) THEN CALL LPMEFFECT( PESG,PEIE,PESE,-Z(NP-1),.FALSE.,FPASS ) IF ( FPASS ) THEN NP = NP - 1 RETURN ENDIF ELSE FPASS = .FALSE. ENDIF #endif C WE HAVE ELECTROMAGNETIC INTERACTION, INCREASE GEN. COUNTER BY 1.E3 IGEN(NP-1) = IGEN(NP-1) + 1000 THETA = PRM/PEIE CALL UPHI( 1,3 ) C ATTRIBUTE PARTICLE ENERGIES AND PROPERTIES IF ( PESG .LE. PESE ) THEN IQ(NP ) = 1 E(NP) = PESG E(NP-1) = PESE ELSE IQ(NP) = IQ(NP-1) IQ(NP-1) = 1 E(NP) = PESE E(NP-1) = PESG C INTERCHANGE STACK POSITION OF ELECTRON AND GAMMA 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 ENDIF RETURN END *-- Author : STANFORD LINEAR ACCELERATOR CENTER C======================================================================= C STANFORD LINEAR ACCELERATOR CENTER SUBROUTINE COMPT C VERSION 4.00 -- 26 JAN 1986/1900 C----------------------------------------------------------------------- C COMPT(ON SCATTERING) 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 GAMMA ENERGY /INITIAL GAMMA ENERGY. C BR0 = MINIMUM BR = 1./(1.+2.*(E(NP)/PRM)) 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 THIS SUBROUTINE IS CALLED FROM PHOTO. C----------------------------------------------------------------------- IMPLICIT NONE #define __EGSDEBINC__ #define __RANDPAINC__ #define __RUNPARINC__ #define __STACKEINC__ #define __THRESHINC__ #define __UPHIOTINC__ #define __USEFULINC__ #include "corsika.h" DOUBLE PRECISION ALPH1,ALPH2,A1MIBR,BR,BRP,BR0,BR0I,EGP, * PEIG,PESG,PESE,PSQ,SUMALP,T,TEMP SAVE C----------------------------------------------------------------------- IF ( FEGSDB ) THEN WRITE(MDEBUG,1) NP,IR(NP),IOBS(NP) 1 FORMAT(' COMPT : NP=',I3,' IR=',I3,' IOBS=',I3) CALL AUSGB2 ENDIF C WE HAVE PHOTON INTERACTION, INCREASE GEN. COUNTER BY 1E6 IGEN(NP) = IGEN(NP) + 1000000 PEIG = E(NP) EGP = PEIG*RMI BR0I = 1.D0+2.D0*EGP BR0 = 1.D0/BR0I ALPH1 = LOG( BR0I ) ALPH2 = EGP*(BR0I+1.D0)*BR0**2 SUMALP = ALPH1+ALPH2 371 CONTINUE CALL RMMARD( RD,3,2 ) C WHICH PART OF 1./BR + BR TO SAMPLE FROM ? IF ( ALPH1 .GE. SUMALP*RD(1) ) THEN C USE 1/BR PART OF DISTRIBUTION BR = EXP( ALPH1*RD(2) ) * BR0 ELSE C USE LINEAR ( BR ) PART OF DISTRIBUTION BRP = RD(2) IF ( EGP .GE. (EGP+1.D0)*RD(3) ) THEN CALL RMMARD( RD(4),1,2 ) BRP = MAX( RD(2), RD(4) ) ENDIF BR = ((BR0I-1.D0)*BRP+1.D0)*BR0 ENDIF C BR=FINAL GAMMA ENERGY FRACTION PESG = BR*PEIG C THE COMPTON ANGLES FOR GAMMA AND RECOIL ELECTRON ARE UNIQUELY C DETERMINED BY THE CONSERVATION LAWS A1MIBR = 1.D0-BR TEMP = PRM*A1MIBR/PESG SINTHE = MAX( 0.D0, TEMP*(2.D0-TEMP) ) CALL RMMARD( RD,1,2 ) IF ( (1.D0-RD(1))*(1.D0+BR**2) .LT. BR*SINTHE ) GOTO 371 SINTHE = SQRT( SINTHE ) COSTHE = 1.D0-TEMP C NOW FILL IN THE PARTICLE PROPERTIES PESE = PEIG-PESG+PRM CALL UPHI( 2,1 ) NP = NP+1 C MOMENTUM SQUARED OF ELECTRON PSQ = PESE*PESE-RMSQ IF ( PSQ .LE. 0.D0 ) THEN COSTHE = 0.D0 SINTHE = -1.D0 ELSE COSTHE = (PESE+PESG)*A1MIBR/SQRT( PSQ ) SINTHE = -SQRT( MAX( 0.D0, (1.D0-COSTHE)*(1.D0+COSTHE) ) ) ENDIF CALL UPHI( 3,2 ) IF ( PESE .LE. PESG ) THEN IQ(NP) = 3 E(NP) = PESE E(NP-1) = PESG ELSE C SORT PARTICLES ON STACK WITH DESCENDING ENERGY IQ(NP) = 1 IQ(NP-1) = 3 E(NP) = PESG E(NP-1) = PESE 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 ENDIF RETURN END #if __CURVED__ *-- Author : D. HECK IK FZK KARLSRUHE 18/06/1999 C======================================================================= SUBROUTINE CORNEC C----------------------------------------------------------------------- C CO(O)R(DINATE) (I)N(ITIALIZATION FOR) E(M IN A) C(URVED ATMOSPHERE) C C INITIALIZES ALL IMPORTANT COORDINATES FOR ONE OBSERVATION LEVEL C ROUTINE DETERMINES STARTING PARAMETERS AT HEIGHT GIVEN BY THICK0 FOR C A COORDINATE SYSTEM WHICH IS FIXED IN (X,Y) AT THE ASSUMED DETECTOR C POSITION AND IN Z AT SEA LEVEL. C THIS SUBROUTINE IS CALLED FROM ELECTR AND PHOTON. C C DESIGN : D. HECK IK FZK KARLSRUHE C----------------------------------------------------------------------- IMPLICIT NONE #define __OBSPARINC__ #define __PARPARINC__ #define __RUNPARINC__ #define __STACKEINC__ #define __TIMLIMINC__ #include "corsika.h" DOUBLE PRECISION DIST,SIGNE,TANPHI,TEA,DIAG SAVE C----------------------------------------------------------------------- IF (DEBUG) WRITE(MDEBUG,*) 'CORNEC: -Z(NP),WAP(NP),U(NP),V(NP)=', * SNGL(-Z(NP)),SNGL(WAP(NP)),SNGL(U(NP)),SNGL(V(NP)) C NOTE : ANGLES WAP, U, AND V ARE APPARENT ANGLES OF PRIMARY AT C THE EDGE OF THE ATMOSPHERE SEEN FROM THE C DETECTOR POSITION X=Y=0, Z=-OBSLEV(1) C FOR CALCULATIONS: WAP = COSINE OF APPARENT ZENITH ANGLE THETAP C WAP IS SET IN SUBR. EGS4 C DISTANCE DIAG BETWEEN DETECTOR POSITION X=Y=0, Z =-OBSLEV(1) AND C STARTING POINT SIGNE = +1.D0 #if __UPWARD__ IF ( FIMPCT ) THEN C APPARENT HEIGHT ZAP IS PARTICLE Z-COORDINATE IN DETECTOR SYSTEM ZAP(NP) = -HIMPCT IF ( ZAP(NP) .GE. Z(NP) ) THEN DIAG = SQRT( (2.D0*C(1)-ZAP(NP)-Z(NP))*(ZAP(NP)-Z(NP)) ) C CALCULATING COSINE OF THETA_EARTH COSTEA, COSINE OF ZENITH ANGLE BY C TAKING A COORDINATE FRAME CENTERED IN THE MIDDLE OF EARTH WA(NP) = (C(1)-ZAP(NP)) / (C(1)-Z(NP)) WA(NP) = MIN( 1.D0, WA(NP) ) ELSE C CALCULATE THE ACTUAL HIGHT WITH THE COSINE OF THETA_EARTH COSTEA Z(NP) = -( ( C(1) - ZAP(NP) ) / WA(NP) - C(1) ) IF ( DEBUG ) WRITE(MDEBUG,*) 'CORNEC: NEW Z (X,Y)=', * SNGL(-Z(NP)),'(',SNGL(X(NP)),-SNGL(Y(NP)),')' DIAG = SQRT( MAX( 0.D0, * (2.D0*C(1)-ZAP(NP)-Z(NP))*(ZAP(NP)-Z(NP)) ) ) ENDIF C IF THE PARTICLE MOVED DOWNSTREAM OF THE LOWEST POINT, THE C NEGATIVE SIGN OF THE SQUARE ROOT HAS TO BE APPLIED TO DIAG IF ( W(NP) .LT. 0.D0 ) SIGNE = -1.D0 IF ( DEBUG ) WRITE(MDEBUG,*) 'CORNEC:-ZAP(NP),WA(NP),DIAG =', * SNGL(-ZAP(NP)),WA(NP),SNGL(DIAG) C TRANSFORM THE APPARENT ANGLE SEEN FROM DETECTOR POSITION TO LOCAL C ANGLES RELATIVE TO THE VERTICAL TO THE MIDDLE OF EARTH C NOTE : LOCAL ZENITH ANGLE = DIFFERENCE OF APPARENT ZENITH ANGLE AND C THETA_EARTH W(NP) = SIGNE * DIAG / (C(1)-Z(NP)) ELSE IF ( PRMPAR(15) .LT. 0.D0 ) THEN DIAG = -SQRT( (C(1)-Z(NP))**2 - (C(1)+OBSLEV(1))**2 * * (1.D0-WAP(NP))*(1.D0+WAP(NP)) ) * - (C(1)+OBSLEV(1)) * WAP(NP) ELSE DIAG = SQRT( (C(1)-Z(NP))**2 - (C(1)+OBSLEV(1))**2 * * (1.D0-WAP(NP))*(1.D0+WAP(NP)) ) * - (C(1)+OBSLEV(1)) * WAP(NP) ENDIF C APPARENT HEIGHT ZAP IS PARTICLE Z-COORDINATE IN DETECTOR SYSTEM ZAP(NP) = -OBSLEV(1) - DIAG * WAP(NP) C CALCULATING COSINE OF THETA_EARTH COSTEA, COSINE OF ZENITH ANGLE BY C TAKING A COORDINATE FRAME CENTERED IN THE MIDDLE OF EARTH WA(NP) = (C(1)-ZAP(NP)) / (C(1)-Z(NP)) IF ( DEBUG ) WRITE(MDEBUG,*) 'CORNEC:-ZAP(NP),WA(NP),DIAG =', * SNGL(-ZAP(NP)),WA(NP),SNGL(DIAG) WA(NP) = MIN( 1.D0, WA(NP) ) C TRANSFORM THE APPARENT ANGLE SEEN FROM DETECTOR POSITION TO LOCAL C ANGLES RELATIVE TO THE VERTICAL TO THE MIDDLE OF EARTH C NOTE : LOCAL ZENITH ANGLE = DIFFERENCE OF APPARENT ZENITH ANGLE AND C THETA_EARTH W(NP) = (DIAG + (C(1)+OBSLEV(1))*WAP(NP))/(C(1)-Z(NP)) W(NP) = SIGN( W(NP), WAP(NP) ) ENDIF #else DIAG = SQRT( (C(1)-Z(NP))**2 - (C(1)+OBSLEV(1))**2 * * (1.D0-WAP(NP))*(1.D0+WAP(NP)) ) * - (C(1)+OBSLEV(1)) * WAP(NP) C APPARENT HEIGHT ZAP IS PARTICLE Z-COORDINATE IN DETECTOR SYSTEM ZAP(NP) = -OBSLEV(1) - DIAG * WAP(NP) C CALCULATING COSINE OF THETA_EARTH COSTEA, COSINE OF ZENITH ANGLE BY C TAKING A COORDINATE FRAME CENTERED IN THE MIDDLE OF EARTH WA(NP) = (C(1)-ZAP(NP)) / (C(1)-Z(NP)) IF ( DEBUG ) WRITE(MDEBUG,*) 'CORNEC:-ZAP(NP),WA(NP),DIAG =', * SNGL(-ZAP(NP)),WA(NP),SNGL(DIAG) WA(NP) = MIN( 1.D0, WA(NP) ) C TRANSFORM THE APPARENT ANGLE SEEN FROM DETECTOR POSITION TO LOCAL C ANGLES RELATIVE TO THE VERTICAL TO THE MIDDLE OF EARTH C NOTE : LOCAL ZENITH ANGLE = DIFFERENCE OF APPARENT ZENITH ANGLE AND C THETA_EARTH W(NP) = (DIAG + (C(1)+OBSLEV(1))*WAP(NP)) / (C(1)-Z(NP)) #endif W(NP) = MIN( 1.D0, W(NP) ) W(NP) = MAX( -1.D0, W(NP) ) IF ( U(NP) .NE. 0.D0 ) THEN TANPHI= V(NP) / U(NP) IF ( ABS(W(NP)) .LT. 1.D0 ) THEN U(NP) = SIGN( 1.D0,U(NP) ) * * SQRT( (1.D0-W(NP))*(1.D0+W(NP))/(1.D0+TANPHI**2) ) ELSE U(NP) = 0.D0 ENDIF V(NP) = TANPHI * U(NP) ELSE IF ( V(NP) .NE. 0.D0 .AND. ABS(W(NP)) .LT. 1.D0 ) THEN V(NP) = SIGN(1.D0,V(NP)) * SQRT( (1.D0-W(NP))*(1.D0+W(NP)) ) ELSE V(NP) = 0.D0 ENDIF ENDIF C SET TIME LIMIT TO AVOID UNNECESSARY COMPUTING TIME WITH PARTICLES C WELL ABOVE THE TIME LIMIT. THE TIME LIMIT IS GIVEN BY THE C PROPAGATION TIME ALONG DIAD WITH SPEED OF LIGHT AND SOME ADDITIONAL C DISTANCE DOWNSTREAM OF THE DETECTOR DLIMIT (CM). C FOR SAFETY ADD ADDITIONAL 20 MICROSEC. (ALL TIME UNITS IN SEC) IF ( DSTLIM .GT. 0.D0 ) THEN TIMLIM = ( DIAG + DSTLIM ) / C(25) + 2.D-5 ELSE C DEFAULT LIMIT IS 20 KM TIMLIM = ( DIAG + 20.D5 ) / C(25) + 2.D-5 ENDIF IF ( DEBUG .OR. LTMLMPR ) WRITE(MDEBUG,*) 'CORNEC: DIAG=',DIAG, * 'DSTLIM=',DSTLIM,' TIMLIM=',TIMLIM C DISTANCE DIST BETWEEN THE DETECTOR POSITION X=0, Y=0 C AND THE ACTUAL INTERACTION POINT MEASURED ON THE EARTH''S SURFACE TEA = ACOS( WA(NP) ) DIST = C(1) * TEA C CONCERNING TRANSFORMATION OF AZIMUTH ANGLE PHI C NOTE : THE COORDINATE SYTEMS ONLY DIFFER IN A SHIFT ALONG THE Z-AXIS C OR A ROTATION ALONG THE ZENITH ANGLE. BOTH TRANSFORMATIONS C JUST CHANGE THETA AND NOT PHI (THETA AND PHI ARE ORTHOGONAL C COORDINATES, THUS LINEAR INDEPENDENT). C X,Y-COORDINATES SEEN FROM THE DETECTOR POSITION (X=Y=0) C PHIP IS DEFINED HERE IN __OBSPARINC__ BUT IS NOT SENSIBEL TO USE IN C THIS ROUTINE; WE HAVE TO TAKE NOT PHI OF PRIMARY, BUT FROM CURRENT C PARTICLE. TAKE NEW LOCAL DIRECTION COSINES (SEE ABOVE) TO PROJECT C U AND V ON THE OBSERVER FRAME TO GET X AND Y. #if __UPWARD__ IF ( W(NP) .LT. 1.D0 .AND. W(NP) .GT. -1.D0 ) THEN #else IF ( W(NP) .LT. 1.D0 ) THEN #endif X(NP) = -SIGNE*DIST*U(NP) / SQRT( (1.D0-W(NP))*(1.D0+W(NP)) ) Y(NP) = -SIGNE*DIST*V(NP) / SQRT( (1.D0-W(NP))*(1.D0+W(NP)) ) ELSE X(NP) = -SIGNE*DIST*U(NP) Y(NP) = -SIGNE*DIST*V(NP) ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) 'CORNEC: X(NP),Y(NP),W(NP),DIST =', * SNGL(X(NP)),-SNGL(Y(NP)),SNGL(W(NP)),SNGL(DIST) C NOW ALL PARAMETERS ARE FILLED INTO STACKE RETURN END #endif *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE EGS4( EEIN ) C----------------------------------------------------------------------- C E(LECTRON) G(AMMA) S(HOWER) C C TREATS ELECTROMAGNETIC SUBSHOWER. C THIS SUBROUTINE IS CALLED FROM EM. C ARGUMENT: C EEIN = (DBL) INCOMING PARTICLE ENERGY (GEV) C----------------------------------------------------------------------- IMPLICIT NONE #define __EGSDEBINC__ #define __GENERINC__ #define __GEOMEGSINC__ #define __LONGIINC__ #define __MISCINC__ #define __OBSPARINC__ #define __PARPARINC__ #define __PIONINC__ #define __REJECTINC__ #define __RUNPARINC__ #define __STACKEINC__ #define __THRESHINC__ #define __USEFULINC__ #if __MULTITHIN__ #define __MULTHININC__ #endif #include "corsika.h" DOUBLE PRECISION EEIN,THICK INTEGER IDET,K SAVE EXTERNAL THICK #if __CURVED__ DOUBLE PRECISION PHI1,RRR,XXX,YYY #endif #if __SLANT__ DOUBLE PRECISION AUXIL,THCKSI EXTERNAL THCKSI #endif C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'EGS4 :' C FILL IN STARTING COORDINATES NP = 1 TIM(1) = SECPAR(6) X(1) = SECPAR(7) Y(1) =-SECPAR(8) C STARTS IN HEIGHT 'Z' DOWNWARDS Z(1) =-SECPAR(5) C START DIRECTION COSINES U(NP) = SECPAR(3) V(NP) = -SECPAR(4) W(NP) = SECPAR(2) #if __THIN__ WT(1) = SECPAR(13) #endif #if __CURVED__ ZAP(NP) =-SECPAR(14) WAP(NP) = SECPAR(15) WA(NP) = SECPAR(16) #endif IGEN(1) = GEN #if __MULTITHIN__ DO K = 1, NMTHIN WTM(K,1) = SECPAR(40+K) ENDDO #endif #if __CURVED__ IF ( WA(1) .NE. 1.D0 ) THEN C WE ARE AWAY FROM DETECOR C CALCULATE AZIMUTH ANGLE OF PARTICLE SEEN FROM DETECTOR IF ( Y(1) .NE. 0.D0 .OR. X(1) .NE. 0.D0 ) THEN PHI1 = ATAN2( Y(1), X(1) ) ELSE PHI1 = 0.D0 ENDIF C HORIZONTAL DISTANCE OF PARTICLE TO DETECTOR RRR = SQRT( (1.D0-WA(1))*(1.D0+WA(1)) ) * * ( C(1) - ZAP(1) ) / WA(1) XXX = RRR * COS( PHI1 ) YYY = RRR * SIN( PHI1 ) ELSE C WE ARE IN THE DETECTOR SYSTEM AND NEED NO COORDINATE CALCULATION XXX = X(1) YYY = Y(1) ENDIF C STORE COORDINATES IN THE DETECTOR SYSTEM XXXX(1) = XXX YYYY(1) = YYY #endif IF ( LLONGI ) THEN #if __SLANT__ #if __CURVED__ AUXIL = XXX*STHCPH - YYY*STHSPH + ZAP(1)*CTH + RLOFF #else AUXIL = X(1)*STHCPH -Y(1)*STHSPH +Z(1)*CTH + RLOFF #endif TSLAN(1) = THCKSI( AUXIL ) LPCTE(1) = MIN( INT( TSLAN(1)*THSTPI + 1.D0 ), NSTEP+1 ) #else LPCTE(1) = MIN( INT( THICK( SECPAR(5) )*THSTPI + 1.D0 ), NSTEP ) #endif ENDIF C CONVERSION GEV --> MEV E(1) = EEIN*1000.D0 C CHECK ENERGY RANGE IQ(1) = NINT( SECPAR(0) ) IF ( IQ(1) .EQ. 1 ) THEN IF ( E(1) .GT. UP ) THEN CALL AUSGB2 WRITE(KMPO,91) EEIN 91 FORMAT(' EGS4 : ENERGY OF GAMMA =',1P,E10.3,' GEV TOO HIGH') STOP ENDIF ELSE IF ( E(1) .GT. UE ) THEN CALL AUSGB2 WRITE(KMPO,92) EEIN 92 FORMAT(' EGS4 : ENERGY OF ELECTRON/POSITRON =',1P,E10.3, * ' GEV TOO HIGH') STOP ENDIF ENDIF DNEAR(1) = 0.D0 DO K = 1, 5 C DETERMINE START REGION IF ( -BOUND(K) .LE. Z(1) .AND. -BOUND(K+1) .GT. Z(1) ) THEN IR(1) = K+1 GOTO 110 ENDIF ENDDO #if __CURVED__ RETURN #else CALL AUSGB2 WRITE(KMPO,120) (-0.01)*Z(1) 120 FORMAT(' EGS4 : START VALUE OF Z=',1P,E11.4,' M NOT IN ', * 'ATMOSPHERE') STOP #endif 110 CONTINUE DO IDET = 1, NOBSLV C DETERMINE NEXT OBSERVATION LEVEL IF ( -Z(1) .GE. OBSLVL(IDET) ) THEN IOBS(1) = IDET GOTO 130 ENDIF ENDDO IOBS(1) = NOBSLV #if __UPWARD__ #if !__CURVED__ IF ( PRMPAR(2) .LT. 0.D0 ) IOBS(1) = NOBSLV + 1 #endif IF ( W(NP) .LT. 0.D0 ) THEN NEWOBS = IOBS(1) GOTO 131 ELSE #if __CURVED__ IF ( PRMPAR(15) .LT. 0.D0 ) GOTO 130 #else IF ( PRMPAR(2) .LT. 0.D0 ) GOTO 130 #endif CALL AUSGB2 WRITE(KMPO,140) (-0.01D0)*Z(1),OBSLVL(NOBSLV)*0.01D0 140 FORMAT(' EGS4 : START VALUE OF Z= ',E11.4, ' M BELOW LOWEST ', * 'DETECTOR AT',E11.4,' M') STOP ENDIF #else #if __CURVED__ RETURN #else CALL AUSGB2 WRITE(KMPO,140) (-0.01D0)*Z(1),OBSLVL(NOBSLV)*0.01D0 140 FORMAT(' EGS4 : START VALUE OF Z= ',E11.4, ' M BELOW LOWEST ', * 'DETECTOR AT',E11.4,' M') STOP #endif #endif 130 CONTINUE C NEWOBS IS THE NEXT OBSERVATION LEVEL DOWNWARDS NEWOBS = IOBS(1) #if __UPWARD__ 131 CONTINUE #endif IF ( DEBUG ) WRITE(MDEBUG,*) * 'EGS4 :IQ=',IQ(1),' IR=',IR(1),' IOBS=',IOBS(1) CALL SHOWER #if !__CERENKOV__ && !__THIN__ && !__PLOTSH__ && !__AUGCERLONG__ IF ( DEBUG ) THEN DO K = 1, NOBSLV IF ( FPRINT ) THEN WRITE(KMPO,160) AVNREJ(K),K 160 FORMAT(' EGS4 : ',F13.9,' CHARGED PARTICLES REJECTED AT ', * 'DETECTOR',I3) ENDIF ENDDO ENDIF #endif IF ( DEBUG ) WRITE(MDEBUG,*) 'EGS4 : EGS-STACK EMPTY, EXIT' RETURN END *-- Author : STANFORD LINEAR ACCELERATOR CENTER C======================================================================= C STANFORD LINEAR ACCELERATOR CENTER BLOCK DATA EGS4BD C VERSION 4.00 -- 26 JAN 1986/1900 C----------------------------------------------------------------------- C INITIALIZES GENERAL DATA OF EGS4 C----------------------------------------------------------------------- IMPLICIT NONE #define __BOUNDSINC__ #define __ELECININC__ #define __EGSDEBINC__ #define __EPCONTINC__ #define __MEDIAINC__ #define __MEDIACINC__ #define __MISCINC__ #define __MULTSINC__ #define __PATHCMINC__ #define __THRESHINC__ #define __UPHIOTINC__ #define __USEFULINC__ #include "corsika.h" CHARACTER MEDIA1*24 EQUIVALENCE (MEDIA1,MEDIA) DATA NCLOCK/0/,JCLOCK/2147483647/ DATA ECUT/6*0.D0/,PCUT/6*0.D0/,VACDST/1.D9/ DATA RHOFAC/1.D0/ DATA NMED/1/,MEDIA1/'NAI '/ DATA IRAYLM/1*0/ DATA KMPI/12/,KMPO/8/,DUNIT/1.D0/,NOSCAT/0/ DATA MED/6*1/,RHOR/6*0.D0/,IRAYLR/6*0/ DATA B0G21/ 2.D0 /,B1G21/ 5.D0 / DATA G210(1),G211(1),G212(1)/-9.9140D-04, 2.7672D+00,-1.1544D+00/ DATA G210(2),G211(2),G212(2)/-9.9140D-04, 2.7672D+00,-1.1544D+00/ DATA G210(3),G211(3),G212(3)/-7.1017D-02, 3.4941D+00,-3.0773D+00/ DATA G210(4),G211(4),G212(4)/-7.3556D-02, 3.5487D+00,-3.1989D+00/ DATA G210(5),G211(5),G212(5)/ 3.6658D-01, 2.1162D+00,-2.0311D+00/ DATA G210(6),G211(6),G212(6)/ 1.4498D+00,-5.9717D-01,-3.2951D-01/ DATA G210(7),G211(7),G212(7)/ 1.4498D+00,-5.9717D-01,-3.2951D-01/ DATA B0G22/ 2.D0 /,B1G22/ 6.D0 / DATA G220(1),G221(1),G222(1)/-5.2593D-04, 1.4285D+00,-1.2670D+00/ DATA G220(2),G221(2),G222(2)/-5.2593D-04, 1.4285D+00,-1.2670D+00/ DATA G220(3),G221(3),G222(3)/-6.4819D-02, 2.2033D+00,-3.6399D+00/ DATA G220(4),G221(4),G222(4)/ 3.7427D-02, 1.6630D+00,-2.9362D+00/ DATA G220(5),G221(5),G222(5)/ 6.1955D-01,-6.2713D-01,-6.7859D-01/ DATA G220(6),G221(6),G222(6)/ 1.7584D+00,-4.0390D+00, 1.8810D+00/ DATA G220(7),G221(7),G222(7)/ 2.5694D+00,-6.0484D+00, 3.1256D+00/ DATA G220(8),G221(8),G222(8)/ 2.5694D+00,-6.0484D+00, 3.1256D+00/ DATA B0G31/ 2.D0 /,B1G31/ 9.D0 / DATA G310(1),G311(1),G312(1)/ 4.9437D-01, 1.9124D-02, 1.8375D+00/ DATA G310(2),G311(2),G312(2)/ 4.9437D-01, 1.9124D-02, 1.8375D+00/ DATA G310(3),G311(3),G312(3)/ 5.3251D-01,-6.1555D-01, 4.5595D+00/ DATA G310(4),G311(4),G312(4)/ 6.6810D-01,-2.2056D+00, 8.9293D+00/ DATA G310(5),G311(5),G312(5)/-3.8262D+00, 2.5528D+01,-3.3862D+01/ DATA G310(6),G311(6),G312(6)/ 4.2335D+00,-1.0604D+01, 6.6702D+00/ DATA G310(7),G311(7),G312(7)/ 5.0694D+00,-1.4208D+01, 1.0456D+01/ DATA G310(8),G311(8),G312(8)/ 1.4563D+00,-3.3275D+00, 2.2601D+00/ DATA G310(9),G311(9),G312(9)/-3.2852D-01, 1.2938D+00,-7.3254D-01/ DATA G310(10),G311(10),G312(10)/-2.2489D-1, 1.0713D+0,-6.1358D-1/ DATA G310(11),G311(11),G312(11)/-2.2489D-1, 1.0713D+0,-6.1358D-1/ DATA B0G32/ 2.D0 /,B1G32/ 2.3000D1/ DATA G320(1),G321(1),G322(1)/ 2.9907D-05, 4.7318D-01, 6.5921D-01/ DATA G320(2),G321(2),G322(2)/ 2.9907D-05, 4.7318D-01, 6.5921D-01/ DATA G320(3),G321(3),G322(3)/ 2.5820D-03, 3.5853D-01, 1.9776D+00/ DATA G320(4),G321(4),G322(4)/-5.3270D-03, 4.9418D-01, 1.4528D+00/ DATA G320(5),G321(5),G322(5)/-6.6341D-02, 1.4422D+00,-2.2407D+00/ DATA G320(6),G321(6),G322(6)/-3.6027D-01, 4.7190D+00,-1.1380D+01/ DATA G320(7),G321(7),G322(7)/-2.7953D+00, 2.6694D+01,-6.0986D+01/ DATA G320(8),G321(8),G322(8)/-3.6091D+00, 3.4125D+01,-7.7512D+01/ DATA G320(9),G321(9),G322(9)/ 1.2491D+01,-7.1103D+01, 9.4496D+01/ DATA G320(10),G321(10),G322(10)/ 1.9637D+1,-1.1371D+2, 1.5794D+2/ DATA G320(11),G321(11),G322(11)/ 2.1692D+0,-2.5019D+1, 4.5340D+1/ DATA G320(12),G321(12),G322(12)/-1.6682D+1, 6.2067D+1,-5.5257D+1/ DATA G320(13),G321(13),G322(13)/-2.1539D+1, 8.2651D+1,-7.7065D+1/ DATA G320(14),G321(14),G322(14)/-1.4344D+1, 5.5193D+1,-5.0867D+1/ DATA G320(15),G321(15),G322(15)/-5.4990D+0, 2.3874D+1,-2.3140D+1/ DATA G320(16),G321(16),G322(16)/ 3.1029D+0,-4.4708D+0, 2.1318D-1/ DATA G320(17),G321(17),G322(17)/ 6.0961D+0,-1.3670D+1, 7.2823D+0/ DATA G320(18),G321(18),G322(18)/ 8.6179D+0,-2.0950D+1, 1.2536D+1/ DATA G320(19),G321(19),G322(19)/ 7.5064D+0,-1.7956D+1, 1.0520D+1/ DATA G320(20),G321(20),G322(20)/ 5.9838D+0,-1.4065D+1, 8.0342D+0/ DATA G320(21),G321(21),G322(21)/ 4.4959D+0,-1.0456D+1, 5.8462D+0/ DATA G320(22),G321(22),G322(22)/ 3.2847D+0,-7.6709D+0, 4.2445D+0/ DATA G320(23),G321(23),G322(23)/ 1.9514D+0,-4.7505D+0, 2.6452D+0/ DATA G320(24),G321(24),G322(24)/ 4.8808D-1,-1.6910D+0, 1.0459D+0/ DATA G320(25),G321(25),G322(25)/ 4.8808D-1,-1.6910D+0, 1.0459D+0/ DATA NBGB/ 8/,B0BGB/ 1.5714D0/,B1BGB/ 2.1429D-1/ DATA BGB0(1),BGB1(1),BGB2(1)/-1.0724D+00, 2.8203D+00,-3.5669D-01/ DATA BGB0(2),BGB1(2),BGB2(2)/ 3.7136D-01, 1.4560D+00,-2.8072D-02/ DATA BGB0(3),BGB1(3),BGB2(3)/ 1.1396D+00, 1.1910D+00,-5.2070D-03/ DATA BGB0(4),BGB1(4),BGB2(4)/ 1.4908D+00, 1.1267D+00,-2.2565D-03/ DATA BGB0(5),BGB1(5),BGB2(5)/ 1.7342D+00, 1.0958D+00,-1.2705D-03/ DATA BGB0(6),BGB1(6),BGB2(6)/ 1.9233D+00, 1.0773D+00,-8.1806D-04/ DATA BGB0(7),BGB1(7),BGB2(7)/ 2.0791D+00, 1.0649D+00,-5.7197D-04/ DATA BGB0(8),BGB1(8),BGB2(8)/ 2.0791D+00, 1.0649D+00,-5.7197D-04/ DATA NPTH/ 6/,B0PTH/ 2.D0 /,B1PTH/ 1.8182D1/ DATA PTH0(1),PTH1(1),PTH2(1)/ 1.0000D+00, 9.8875D-01, 2.5026D+00/ DATA PTH0(2),PTH1(2),PTH2(2)/ 1.0000D+00, 9.8875D-01, 2.5026D+00/ DATA PTH0(3),PTH1(3),PTH2(3)/ 1.0060D+00, 7.8657D-01, 4.2387D+00/ DATA PTH0(4),PTH1(4),PTH2(4)/ 1.0657D+00,-2.5051D-01, 8.7681D+00/ DATA PTH0(5),PTH1(5),PTH2(5)/ 1.6971D+00,-7.5600D+00, 2.9946D+01/ DATA PTH0(6),PTH1(6),PTH2(6)/ 1.6971D+00,-7.5600D+00, 2.9946D+01/ END *-- Author : D. HECK IK FZK KARLSRUHE 03/02/1997 C======================================================================= SUBROUTINE EGSIN1 C----------------------------------------------------------------------- C E(LECTRON) G(AMMA) S(HOWER) IN(ITIALIZATION) 1 C C INITIALIZES EGS4 PACKAGE. C THIS SUBROUTINE IS CALLED FROM START. C----------------------------------------------------------------------- IMPLICIT NONE #define __ATMOSINC__ #define __ATMOS2INC__ #define __BOUNDSINC__ #define __ELABCTINC__ #define __EPCONTINC__ #define __GEOMEGSINC__ #define __LAYERINC__ #define __MEDIACINC__ #define __MISCINC__ #define __MUONINC__ #define __OBSPARINC__ #define __PAMINC__ #define __PARPARINC__ #define __PIONINC__ #define __REJECTINC__ #define __RUNPARINC__ #define __THRESHINC__ #define __UPHIOTINC__ #define __USEFULINC__ #include "corsika.h" INTEGER I,IDET,IRL,JREG,KREG CHARACTER MEDARR*24 #if __AUGERHIST__ DOUBLE PRECISION THICK,HEIGH EXTERNAL THICK,HEIGH #endif SAVE DATA MEDARR / 'AIR-NTP ' / C----------------------------------------------------------------------- C INITIALIZATION BEFORE THE FIRST CALL OF EGS4 IF ( DEBUG ) THEN WRITE(MDEBUG,*) 'EGSIN1:' KMPO = MDEBUG ELSE KMPO = MONIOU ENDIF WRITE(KMPO,10) 10 FORMAT(/,' START EGS4 AIR SHOWER SUBROUTINE VERSION',/) C SET PARTICLE MASSES AND PHYSICAL CONSTANTS PRM = PAMA(2)*1.D3 RMSQ = PRM**2 RMI = 1.D0/PRM PRMT2 = 2.D0*PRM PRRMMU = PAMA(5)*1.D3 RMMUT4 = 4.D0*PRRMMU PICMAS = PAMA(8)*1.D3 PI0MAS = PAMA(7)*1.D3 PI0MSQ = PI0MAS**2 AMASKC = PAMA(11)*1.D3 AMASK0 = PAMA(10)*1.D3 AMASPR = PAMA(14)*1.D3 AMASNT = PAMA(13)*1.D3 C INVERSE OF VELOCITY OF LIGHT VCI = 1.D0/C(25) PI = 2.D0 * ACOS( 0.D0 ) TWOPI = 2.D0 * PI C SET ANGULAR CUT #if __UPWARD__ C TAKE TOTAL ANGLE INCLUDING UPWARD GOING PARTICLES WCUT = -1.D0 #else WCUT = C(29) #endif C PION-PRODUCTION THRESHOLD (MEV) PITHR = 152.D0 C NMED AND DUNIT DEFAULT TO 1,I.E. ONE MEDIUM AND WE WORK IN CM MEDIUM = 1 DO I = 1, 24 MEDIA(I:I) = MEDARR(I:I) ENDDO C BOUNDARY 1: TOP OF ATMOSPHERE (SEE SUBR. HOWFAR) BOUND(1) = HLAY(6) C BOUNDARY 6: 1CM BELOW LOWEST AIR LAYER BOUND(6) = HLAY(1) - 1.D0 MED(1) = 0 MED(6) = 0 C VACUUM IN REGIONS 1 AND 6, AIR IN REGION 2 TO 5 DO IRL = 2, 5 MED(IRL) = 1 C PARAMETERS OF ATMOSPHERE ARE TAKEN FROM CORSIKAPROGRAM BOUND(IRL) = HLAY(6-IRL) HBARO(IRL) = CATM(6-IRL) HBAROI(IRL) = 1.D0/HBARO(IRL) RHOR(IRL) = BATM(6-IRL)*HBAROI(IRL) C NEEDED FOR REGION 2 TO 5 SINCE NO TRANSPORT ELSEWHERE C ECUT IS TOTAL ENERGY C TERMINATE ELECTRON HISTORIES AT ECUT (GEV TO MEV CONVERTED) ECUT(IRL) = 1000.D0*ELCUT(3)+PRM C TERMINATE GAMMA HISTORIES AT PCUT (GEV TO MEV CONVERTED) PCUT(IRL) = 1000.D0*ELCUT(4) ENDDO C CALCULATE THE LAYER THICKNESS BELOW EACH DETECTOR DO IDET = 1, NOBSLV C NECESSARY BECAUSE OF DOUBLE PRECIS. OBSLVL(IDET) = OBSLEV(IDET) #if __AUGERHIST__ OBSLV2(IDET) = HEIGH( THICK( OBSLEV(IDET) )+SAMPTH ) #endif DO JREG = 2, 5 IF ( OBSLVL(IDET) .GE. BOUND(JREG) ) THEN KREG = JREG GOTO 80 ENDIF ENDDO WRITE(KMPO,90) IDET,OBSLVL(IDET)*0.01D0 90 FORMAT(' EGSIN1:', ' DETECTOR ',I2,' AT ',E10.3,' M IS OUT ', * 'OF ATMOSPHERE') STOP 80 CONTINUE #if !__CERENKOV__ && !__THIN__ && !__PLOTSH__ && !__AUGERHIST__ && !__AUGCERLONG__ THICKD(IDET) = EXP( (-OBSLVL(IDET))*HBAROI(KREG) ) THICKA(IDET) = RHOR(KREG)*HBARO(KREG)*(1.D0-THICKD(IDET)) C MIN ALTITUDE FOR REJECT IS OBSERVATION LEVEL+3*36.6 G/CM**2 ALTMIN(IDET) = (-HBARO(KREG))*LOG(MAX(1.D-37, * (1.D0-(THICKA(IDET)+109.8D0)*HBAROI(KREG)/RHOR(KREG)))) ALTMIN(IDET) = MIN( ALTMIN(IDET), BOUND(1) ) #endif ENDDO RETURN END *-- Author : D. HECK IK FZK KARLSRUHE 26/06/2003 C======================================================================= SUBROUTINE EGSIN2 C----------------------------------------------------------------------- C E(LECTRON) G(AMMA) S(HOWER) IN(ITIALIZATION) 2 C C READS EGSDAT DATA SET. C EGSDAT6... DATA SETS INCLUDE PHOTONUCLEAR CROSS SECTION AFTER C CUDELL AND ELECTRONUCLEAR CROSS SECTIONS. C THIS SUBROUTINE IS CALLED FROM START. C----------------------------------------------------------------------- IMPLICIT NONE #define __BOUNDSINC__ #define __ELABCTINC__ #define __ELECININC__ #define __MISCINC__ #define __RUNPARINC__ #define __THRESHINC__ #define __USEFULINC__ #include "corsika.h" DOUBLE PRECISION ECUTMIN LOGICAL LAVAIL SAVE C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'EGSIN2:' C LOOK FOR MINIMUM ENERGY CUT TO SELECT OPTIMUM EGSDATA SET ECUTMIN = MIN( 1000.D0*ELCUT(3), 1000.D0*ELCUT(4) ) 33 CONTINUE IF ( ECUTMIN .GE. 3.D0 ) THEN INQUIRE(FILE=DATDIR(1:INDEX(DATDIR,' ')-1)//'EGSDAT6_3.', * EXIST=LAVAIL) IF ( LAVAIL ) THEN OPEN(UNIT=KMPI,FILE=DATDIR(1:INDEX(DATDIR,' ')-1)// * 'EGSDAT6_3.', STATUS='OLD') WRITE(KMPO,*) 'DATASET EGSDAT6_3. AVAILABLE' STERNCOR = 0. ELSE ECUTMIN = 1.1D0 WRITE(KMPO,*) * 'DATASET EGSDAT6_3. BEST SUITED BUT NOT AVAILABLE' GOTO 33 ENDIF ELSEIF ( ECUTMIN .GE. 1.D0 ) THEN INQUIRE(FILE=DATDIR(1:INDEX(DATDIR,' ')-1)//'EGSDAT6_1.', * EXIST=LAVAIL) IF ( LAVAIL ) THEN OPEN(UNIT=KMPI,FILE=DATDIR(1:INDEX(DATDIR,' ')-1)// * 'EGSDAT6_1.', STATUS='OLD') WRITE(KMPO,*) 'DATASET EGSDAT6_1. AVAILABLE' STERNCOR = 6. ELSE ECUTMIN = 0.5D0 WRITE(KMPO,*) * 'DATASET EGSDAT6_1. BEST SUITED BUT NOT AVAILABLE' GOTO 33 ENDIF ELSEIF ( ECUTMIN .GE. 0.4D0 ) THEN INQUIRE(FILE=DATDIR(1:INDEX(DATDIR,' ')-1)//'EGSDAT6_.4', * EXIST=LAVAIL) IF ( LAVAIL ) THEN OPEN(UNIT=KMPI,FILE=DATDIR(1:INDEX(DATDIR,' ')-1)// * 'EGSDAT6_.4', STATUS='OLD') WRITE(KMPO,*) 'DATASET EGSDAT6_.4 AVAILABLE' STERNCOR = 10. ELSE ECUTMIN = 0.16D0 WRITE(KMPO,*) * 'DATASET EGSDAT6_.4 BEST SUITED BUT NOT AVAILABLE' GOTO 33 ENDIF ELSEIF ( ECUTMIN .GE. 0.25D0 ) THEN INQUIRE(FILE=DATDIR(1:INDEX(DATDIR,' ')-1)//'EGSDAT6_.25', * EXIST=LAVAIL) IF ( LAVAIL ) THEN OPEN(UNIT=KMPI,FILE=DATDIR(1:INDEX(DATDIR,' ')-1)// * 'EGSDAT6_.25', STATUS='OLD') WRITE(KMPO,*) 'DATASET EGSDAT6_.25 AVAILABLE' STERNCOR = 11.0 ELSE ECUTMIN = 0.16D0 WRITE(KMPO,*) * 'DATASET EGSDAT6_.25 BEST SUITED BUT NOT AVAILABLE' GOTO 33 ENDIF ELSEIF ( ECUTMIN .GE. 0.15D0 ) THEN INQUIRE(FILE=DATDIR(1:INDEX(DATDIR,' ')-1)//'EGSDAT6_.15', * EXIST=LAVAIL) IF ( LAVAIL ) THEN OPEN(UNIT=KMPI,FILE=DATDIR(1:INDEX(DATDIR,' ')-1)// * 'EGSDAT6_.15', STATUS='OLD') WRITE(KMPO,*) 'DATASET EGSDAT6_.15 AVAILABLE' STERNCOR = 12.5 ELSE ECUTMIN = 0.06D0 WRITE(KMPO,*) * 'DATASET EGSDAT6_.15 BEST SUITED BUT NOT AVAILABLE' GOTO 33 ENDIF ELSEIF ( ECUTMIN .GE. 0.05D0 ) THEN INQUIRE(FILE=DATDIR(1:INDEX(DATDIR,' ')-1)//'EGSDAT6_.05', * EXIST=LAVAIL) IF ( LAVAIL ) THEN OPEN(UNIT=KMPI,FILE=DATDIR(1:INDEX(DATDIR,' ')-1)// * 'EGSDAT6_.05', STATUS='OLD') WRITE(KMPO,*) 'DATASET EGSDAT6_.05 AVAILABLE' STERNCOR = 15. ELSE ECUTMIN = 0.04D0 WRITE(KMPO,*) * 'DATASET EGSDAT6_.05 BEST SUITED BUT NOT AVAILABLE' GOTO 33 ENDIF ELSE INQUIRE(FILE=DATDIR(1:INDEX(DATDIR,' ')-1)//'EGSDAT6_.05', * EXIST=LAVAIL) IF ( LAVAIL ) THEN OPEN(UNIT=KMPI,FILE=DATDIR(1:INDEX(DATDIR,' ')-1)// * 'EGSDAT6_.05', STATUS='OLD') WRITE(KMPO,*) 'ONLY DATASET EGSDAT6_.05 AVAILABLE' STERNCOR = 15. ELSE WRITE(KMPO,*) 'NO DATASET EGSDAT6_???? AVAILABLE' STOP ENDIF ENDIF C PICK UP CROSS-SECTION DATA FOR AIR-NTP FROM UNIT KMPI=12 CALL HATCH CLOSE( UNIT=KMPI ) C INVERTED GAMMA THRESHOLD API = 1.D0/AP IF(ECUT(2).LE.1D6.AND.PCUT(2).LE.1D6)THEN WRITE(KMPO,40) (AE-PRM)*.001,AP*.001,ECUT(2)*.001,PCUT(2)*.001 ELSE WRITE(KMPO,41) (AE-PRM)*.001,AP*.001,ECUT(2)*.001,PCUT(2)*.001 ENDIF 40 FORMAT(' ELECTRONS CAN BE CREATED AND ANY ELECTRON FOLLOWED DO', * 'WN TO',/,T38,F15.5,' GEV KINETIC ENERGY',/, * ' GAMMAS CAN BE CREATED AND ANY GAMMA FOLLOWED DOWN TO',/,T38, * F15.5,' GEV ENERGY',/,' ELECTRON HISTORIES ARE TERMINATED AT', * F15.5,' GEV',/,' GAMMA HISTORIES ARE TERMINATED AT ',F15.5, * ' GEV',/) 41 FORMAT(' ELECTRONS CAN BE CREATED AND ANY ELECTRON FOLLOWED DO', * 'WN TO',/,T38,F15.5,' GEV KINETIC ENERGY',/, * ' GAMMAS CAN BE CREATED AND ANY GAMMA FOLLOWED DOWN TO',/,T38, * F15.5,' GEV ENERGY',/,' ELECTRON HISTORIES ARE TERMINATED AT', * 1P,E12.4,' GEV',/,' GAMMA HISTORIES ARE TERMINATED AT ', * 1P,E12.4,' GEV',/) ** IF ( DEBUG ) WRITE(KMPO,50) #if __THIN__ **50 FORMAT(10X,' PART|TOT.ENERGY|ANGLE Z|ANGLE X|ALTITUDE|', ** * ' TIME | POS. X | POS. Y |GENER|WEIGHT|',/,11X,'ICLE|', ** * ' (GEV) |COSTHET| (RAD) | (CM) | (MSEC) | (CM) |', ** * ' (CM) |ATION| |') #else **50 FORMAT(10X,' PART|TOT.ENERGY|ANGLE Z|ANGLE X|ALTITUDE|', ** * ' TIME | POS. X | POS. Y |GENER|',/,11X,'ICLE|', ** * ' (GEV) |COSTHET| (RAD) | (CM) | (MSEC) | (CM) |', ** * ' (CM) |ATION|') #endif RETURN END *-- Author : STANFORD LINEAR ACCELERATOR CENTER C======================================================================= C STANFORD LINEAR ACCELERATOR CENTER SUBROUTINE ELECTR( IRCODE ) C VERSION 4.00 -- 26 JAN 1986/1900 C----------------------------------------------------------------------- C ELECTR(ONS AND POSITRONS ARE TREATED) C C TREATS THE ELECTRON/POSITRON TRANSPORT. C FOR PATH LENGTH CORRECTION BECAUSE OF BAROMETRIC ATMOSPHERE SEE C INTERNAL REPORT OF D.HECK,(1989). C THIS SUBROUTINE IS CALLED FROM SHOWER. C ARGUMENT: C IRCODE = RETURN CODE : 1 NORMAL RETURN C 2 IF POSSIBLY STACK IS EMPTY C----------------------------------------------------------------------- IMPLICIT NONE #define __BOUNDSINC__ #define __BUFFSINC__ #define __ELABCTINC__ #define __ELECININC__ #define __EGSDEBINC__ #define __EPCONTINC__ #define __GEOMEGSINC__ #define __LAYERINC__ #define __LONGIINC__ #define __MAGNETINC__ #define __MEDIAINC__ #define __MEDIACINC__ #define __MISCINC__ #define __MUONINC__ #define __OBSPARINC__ #define __PARPARINC__ #define __PATHCMINC__ #define __PIONINC__ #define __RANDPAINC__ #define __REJECTINC__ #define __RUNPARINC__ #define __STACKEINC__ #if __PARALLEL__ #define __STACKFINC__ #endif #define __THRESHINC__ #if __CURVED__ #define __TIMLIMINC__ #endif #define __UPHIOTINC__ #define __USEFULINC__ #if __CERENKOV__ || __AUGCERLONG__ #define __CEREN1INC__ #define __CERTELINC__ #define __CEREN3INC__ #endif #if ( __CERENKOV__ && __CURVED__ ) || ( __AUGCERLONG__ && __CURVED__ ) #define __CORFRAMINC__ #endif #if __PLOTSH2__ #define __PLOTSH2INC__ #endif #include "corsika.h" DOUBLE PRECISION A,ALPHA,ALTEXP,B,BETA3,CC, * COSDEL,DE,DEDX,DEDX0,DEMFP,DISC,EBR1,EBR2,EDEPB, * EDEPN,EDEP1,EFRST,EKEF,EKEOLD,ERELS,FLIP,FNORM, * F1SIN,F1COS,PBR1,PBR2,PBR3, * PEIE,PHI,PTH,RADINV,RANGE, * RHOFI,SIG,SIGF,SIG0,SINDEL,SINPSI,SINPS2, * STEPT,THICK,TMXS,TUSTPC, * TVSTPC,UMEAN,US,USTEPU,USTEP0,USW,U0, * VMEAN,VS,VSTP,VSTEPU,V0,V1,WMEAN,W0,ZOLD INTEGER IDR,IRCODE,IRL,I,IPTH,I1, * LELEC,LELKE,LPCT1,LPCT2,NSTPCN LOGICAL IRETC #if __EFIELD__ C ADDITIONS FOR ELECTRICAL FIELD DOUBLE PRECISION EX0,EX1,EY0,EY1,EZ0,EZ1,X0,X1,Y0,Y1,Z0,Z1 DOUBLE PRECISION DPOT,DPX0,DPX1,DPY0,DPY1,DPZ0,DPZ1,DP20,DP21 DOUBLE PRECISION ALPHA2,BETA0,EDOT0,EDOT1,FNORME,FNORM2,GAMMAI #endif #if !__CERENKOV__ && !__THIN__ && !__PLOTSH__ && !__AUGCERLONG__ && !__UPWARD__ DOUBLE PRECISION ALTEXI,ANU1,ANU2 INTEGER JDET,KDET #endif #if __AUGERHIST__ INTEGER LL CHARACTER*10 VONWO #endif #if __CERENKOV__ || __AUGCERLONG__ DOUBLE PRECISION CTEA,EBEG,EEND,TBEG,TEND, * XBEG,XEND,YBEG,YEND,ZBEG,ZEND LOGICAL FDELAY INTEGER IDELAY DOUBLE PRECISION RCTEA,REBEG,REEND,RTBEG,RTEND, * RXBEG,RXEND,RYBEG,RYEND,RZBEG,RZEND, * RUMEAN,RVMEAN,RWMEAN,RSTEP,RUVW #endif #if __CURVED__ DOUBLE PRECISION AUXIL,AUXILSQ,AUX2SQ,CORR,COSDIF,COSTHENEW, * DISTO2,DSTEFF,PHIC,SINDIF,SINTEA, * TANPHI,TRANS2,XOLD,YOLD,ZNEW DOUBLE PRECISION PHI1,RRR,XXX,YYY INTEGER IPASC #endif #if __UPWARD__ DOUBLE PRECISION ZNEWUP #endif #if __PLOTSH__ && !__PLOTSH2__ REAL TRID,TRE,TRX1,TRY1,TRZ1,TRT1,TRX2,TRY2,TRZ2,TRT2 #endif #if __COASTUSERLIB__ 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 #if __PLOTSH2__ DOUBLE PRECISION WGHT #endif #if __CURVED__ DOUBLE PRECISION ZAPOLD,XXXOLD,YYYOLD,SPEED0,SPEED,TDIFF INTEGER LCOUNT #endif #if __SLANT__ DOUBLE PRECISION AUXIL1,AUXOLD,AUXNEW,THCKSI,T1,T2 EXTERNAL THCKSI #if !__CURVED__ DOUBLE PRECISION XOLD,YOLD #endif #else DOUBLE PRECISION THCKHN,THCKHO #endif #if __THIN__ || __LPM__ || __PARALLEL__ || __MULTITHIN__ LOGICAL FPASS #endif #if __THIN__ || __MULTITHIN__ DOUBLE PRECISION EKENP,EKENP1 #endif SAVE EXTERNAL THICK DATA NSTPCN / 0 / #if __CURVED__ * ,LCOUNT / 0 / #endif #if __PLOTSH2__ && !__THIN__ DATA WGHT / 1.D0 / #endif C----------------------------------------------------------------------- IF ( DEBUG ) THEN NCLOCK = NCLOCK+1 IF ( FEGSDB ) THEN WRITE(MDEBUG,1) NP,IR(NP),IOBS(NP),NCLOCK 1 FORMAT(/,' ELECTR: NP=',I3,' IR=',I3,' IOBS=',I3,' NCLOCK=', * I12) CALL AUSGB2 ELSE IF ( NCLOCK .GE. JCLOCK ) THEN FEGSDB = .TRUE. WRITE(MDEBUG,1) NP,IR(NP),IOBS(NP),NCLOCK CALL AUSGB2 ENDIF IF ( MOD(NCLOCK,1000) .EQ. 0 ) THEN WRITE(MDEBUG,2) NP,IR(NP),IOBS(NP),NCLOCK 2 FORMAT(' ELECTR: NP=',I3,' IR=',I3,' IOBS=',I3,' NCLOCK=', * I12) ENDIF ENDIF ENDIF NEWOBS = IOBS(NP) IRCODE = 1 IROLD = IR(NP) IRL = IR(NP) MEDIUM = MED(IRL) #if __CERENKOV__ || __AUGCERLONG__ FDELAY = .FALSE. IDELAY = 0 #endif C START WITH A NEW ELECTRON: LELEC = -1 FOR E-, LELEC =+1 FOR E+ 380 CONTINUE LELEC = 5-2*IQ(NP) PEIE = E(NP) IF ( PEIE .LE. ECUT(IRL) ) THEN IF ( FNPRIM ) GOTO 390 GOTO 498 ENDIF MEDIUM = MED(IRL) 401 CONTINUE IF ( MEDIUM .NE. 0 ) THEN C WE USE EKE = KIN. ENERGY OF ELECTRON, ELKE = LOGARITHM OF EKE EKE = PEIE-PRM ELKE = LOG( EKE ) #if !__CERENKOV__ && !__THIN__ && !__PLOTSH__ && !__COASTUSERLIB__ && !__AUGERHIST__ && !__AUGCERLONG__ && !__UPWARD__ C REJECT PARTICLES, WHICH HAVE LITTLE CHANCE TO LEAD TO A PARTICLE TO C BE DETECTED ON OBSERVATION LEVEL. THE PARAMETERISATION IS TAKEN FROM C J. SPITZER (DESY AND HD) 1988. C ENERGY THRESHOLD IS THE PI-THRESHOLD IF ( .NOT. LLONGI .AND. EKE .LT. PITHR ) THEN IF ( -Z(NP) .GT. ALTMIN(1) ) THEN ALTEXI = EXP( Z(NP) * HBAROI(IRL) ) THICKA(1) = HBARO(IRL)*(THICKD(1)-ALTEXI) ANU1 = -11.97936D0+ELKE*(2.796576D0-.1056D0*ELKE) ANU2 = 2.79D-5 -ELKE*(0.2801D-5 -0.01415D-5*ELKE) C ANEXP IS AVERAGE NUMBER OF EXPECTED PARTICLES AT DETECTOR LEVEL ANEXP(1) = ANU1-ANU2*THICKA(1) IF ( ANEXP(1) .LT. CUTLN+ELKE ) THEN C AVNREJ IS AVERAGE NUMBER OF REJECTED PARTICLES AT DETECTOR AVNREJ(1) = AVNREJ(1) + EXP( ANEXP(1) ) IF ( NOBSLV .GT. 1 ) THEN DO KDET = 2, NOBSLV THICKA(KDET) = HBARO(IRL)*(THICKD(KDET)-ALTEXI) ANEXP(KDET) = ANU1-ANU2*THICKA(KDET) AVNREJ(KDET) = AVNREJ(KDET) + EXP( ANEXP(KDET) ) ENDDO ENDIF IRETC = .TRUE. GOTO 420 ENDIF ELSEIF ( NOBSLV .GT. 1 ) THEN DO JDET = 2, NOBSLV IF ( -Z(NP) .LT. OBSLVL(JDET-1) .AND. * -Z(NP) .GT. ALTMIN(JDET) ) THEN ALTEXI = EXP( Z(NP) * HBAROI(IRL) ) THICKA(JDET) = HBARO(IRL)*(THICKD(JDET)-ALTEXI) ANU1 = -11.97936D0+ELKE*(2.796576D0-.1056D0*ELKE) ANU2 = 2.79D-5 -ELKE*(0.2801D-5 -0.01415D-5*ELKE) C ANEXP IS AVERAGE NUMBER OF EXPECTED PARTICLES AT DETECTOR LEVEL ANEXP(JDET) = ANU1-ANU2*THICKA(JDET) IF ( ANEXP(JDET) .LT. CUTLN+ELKE ) THEN C AVNREJ IS AVERAGE NUMBER OF REJECTED PARTICLES AT DETECTOR AVNREJ(JDET) = AVNREJ(JDET) + EXP( ANEXP(JDET) ) IF ( NOBSLV .GT. JDET ) THEN DO KDET = JDET+1, NOBSLV THICKA(KDET) = HBARO(IRL)*(THICKD(KDET) -ALTEXI) ANEXP(KDET) = ANU1-ANU2*THICKA(KDET) AVNREJ(KDET) = AVNREJ(KDET) + EXP( ANEXP(KDET) ) ENDDO ENDIF IRETC = .TRUE. GOTO 420 ENDIF ENDIF ENDDO ENDIF ENDIF #endif CALL RMMARD( RD,1,2 ) DEMFP = MAX( -LOG( RD(1) ), 1.D-14 ) C LOOK FOR CROSS-SECTION TO DETERMINE RANGE LELKE = EKE1*ELKE+EKE0 IF ( LELEC .LT. 0 ) THEN SIG0 = ESIG1(LELKE)*ELKE+ESIG0(LELKE) ELSE SIG0 = PSIG1(LELKE)*ELKE+PSIG0(LELKE) ENDIF ENDIF 451 CONTINUE #if __PLOTSH__ || __PLOTSH2__ IF ( PLOTSH ) THEN C BEGINNING OF TRACKING STEP TRID = IQ(NP) TRE = E(NP) * 0.001D0 TRX1 = X(NP) TRY1 = -Y(NP) #if __CURVED__ TRZ1 = -ZAP(NP) #else TRZ1 = -Z(NP) #endif TRT1 = TIM(NP) ENDIF #endif #if __COASTUSERLIB__ C BEGINNING OF TRACKING STEP pnt1id = IQ(NP) pnt1gen= igen(NP) #if __CURVED__ pnt1x = XXXX(NP) pnt1y = -YYYY(NP) pnt1z = -ZAP(NP) #else pnt1x = X(NP) - XOFF(NOBSLV) pnt1y = -Y(NP) - YOFF(NOBSLV) pnt1z = -Z(NP) #endif #if __SLANT__ pnt1d = TSLAN(NP) #else pnt1d = THICK( -Z(NP) )/COS(THETAP) #endif pnt1t = TIM(NP) pnt1e = E(NP) * 0.001D0 #if __THIN__ pnt1w = WT(NP) #else pnt1w = 1.D0 #endif #endif IF ( MEDIUM .EQ. 0 ) THEN C WE ARE IN VACUUM TSTEP = VACDST USTEP = TSTEP TUSTEP = USTEP ALTEXP = 1.D0 ELSE C WE ARE IN AIR C COMPUTE SIZE OF MAXIMUM ACCEPTABLE STEP, WHICH IS LIMITED BY C MULTIPLE SCATTERING OR OTHER APPROXIMATIONS. RHOFAC = RHOR(IRL)/RHO RHOFI = 1.D0/RHOFAC SIG = SIG0*RHOFAC IF ( SIG .LE. 0.D0 ) THEN C THIS CAN HAPPEN IF THE THRESHOLD FOR BREMS, (AP+RM), IS GREATER C THAN AE. MOLLER THRESHOLD IS 2*AE-RM. IF SIG IS ZERO, WE ARE BELOW C THE THRESHOLDS FOR BOTH BREMSSTRAHLUNG AND MOLLER. IN THIS CASE WE C WILL JUST LOSE ENERGY BY IONIZATION LOSS UNTIL WE GO BELOW CUT-OFF. C DO NOT ASSUME RANGE IS AVAILABLE, SO JUST ASK FOR STEP SAME AS C VACUUM. ELECTRON TRANSPORT WILL REDUCE INTO LITTLE STEPS TSTEP = VACDST ELSE TSTEP = DEMFP/SIG ENDIF TMXS = TMXS1(LELKE)*ELKE+TMXS0(LELKE) TMXS = MIN( TMXS, STEPFC*200.D0*DBLE(TEFF0) ) TMXS = TMXS*RHOFI TUSTEP = MIN( TSTEP, TMXS ) C EVALUATE IONIZATION ENERGY LOSS IF ( LELEC .LT. 0 ) THEN DEDX0 = EDEDX1(LELKE)*ELKE+EDEDX0(LELKE) ELSE DEDX0 = PDEDX1(LELKE)*ELKE+PDEDX0(LELKE) ENDIF 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 PARAMETERISATION IS ONLY VALID FOR U.S. STANDARD ATMOS. IF ( PEIE .GE. 3.D0 ) THEN DEDX = RHOFAC * MIN( DEDX0, * (86.65D0-STERNCOR-Z(NP)*8.D-6)*RLDUI ) ELSE C NO DENSITY DEPENDENT STERNHEIMER CORRECTION AT LOW ENERGIES DEDX = RHOFAC * DEDX0 ENDIF RANGE = (PEIE-ECUT(IRL)+0.001D0)/DEDX BETA2 = MAX( 1.D-8, 1.D0-RMSQ/(PEIE*PEIE) ) C THE FACTOR 0.094315=2./E_S WITH E_S = 21.2MEV BETA3 = PEIE*BETA2*0.094315D0 TSCAT = RLDU*BETA3**2 TSCAT = TSCAT*RHOFI TUSTEP = MIN( TUSTEP, 0.3D0*TSCAT, RANGE ) C RATIO GIVES THE NUMBER OF SCATTERS ALONG STEP RATIO = TUSTEP/TSCAT USTEP = TUSTEP*(1.D0-RATIO) C USTEPU IS STEP LENGTH WITHOUT CORRECTION FOR DENSITY GRADIENT USTEPU = USTEP ALTEXP = EXP( (-Z(NP)) * HBAROI(IRL) ) USTEP = USTEP*ALTEXP DISC = W(NP)*USTEP*HBAROI(IRL) IF ( ABS(DISC) .LT. .0000007D0 ) THEN USTEP = USTEP*(1.D0-.5D0*DISC*(1.D0-.666666666666667D0*DISC* * (1.D0-.75D0*DISC*(1.D0-.8D0*DISC)))) ELSEIF ( DISC .GT. -1.D0 ) THEN USTEP = USTEP*LOG( DISC+1.D0 )/DISC ELSE USTEP = VACDST ENDIF C USTEP IS STEP LENGTH WITH CORRECTION FOR DENSITY GRADIENT TUSTPC = USTEP/(1.D0-RATIO) ENDIF IRNEW = IR(NP) IDISC = 0 USTEP0 = USTEP C REDUCE STEPSIZE, IF PARTICLE COILS WITH ANGLES >0.2 RAD (=11.4 DEG.) C IN MAGNETIC FIELD (OR SMALLER THAN PIXEL SIZE FOR CERENKOV&IACT). USTEP = MIN( USTEP, BLIMIT*PEIE ) #if __EFIELD__ C SET X0,Y0 RELATIVE TO MIDDLE OF LOWEST OBSERVATION LEVEL #if __CURVED__ X0 = X(NP) Y0 = Y(NP) #else X0 = X(NP) - XOFF(NOBSLV) Y0 = Y(NP) + YOFF(NOBSLV) #endif Z0 = Z(NP) C BETA2 IS LORENTZ BETA VALUE SQUARED BETA0 = SQRT( BETA2 ) GAMMAI = SQRT( (1.D0 + BETA0) * (1.D0 - BETA0) ) C LELEC = -1 FOR E-, LELEC = +1 FOR E+ FNORME = LELEC * GAMMAI / BETA2 C ATTENTION! MIRROR DEFINITION OF Y,Z TO HADRONIC PART CALL ELFIELD( X0,-Y0,-Z0, EX0,EY0,EZ0 ) C BUT DIRECTION COSIN IN Z DIRECTION IS UNCHANGED C THEREFORE USE INVERTED FIELD FOR EY AND EZ C CONVERSION VOLT TO MV GIVES FACTOR 1.D-6 EX0 = 1.D-6 * EX0 / PRM EY0 = -1.D-6 * EY0 / PRM EZ0 = -1.D-6 * EZ0 / PRM EDOT0 = EX0*U(NP) + EY0*V(NP) + EZ0*W(NP) DPX0 = EX0 - U(NP)*EDOT0 DPY0 = EY0 - V(NP)*EDOT0 DPZ0 = EZ0 - W(NP)*EDOT0 C LIMIT STEPSIZE BECAUSE OF DIRECTION CHANGE IN EL. FIELD DP20 = FNORME**2 * (DPX0**2 + DPY0**2 + DPZ0**2) IF ( DP20 .GT. 0.D0 ) THEN USTEP = MIN( USTEP, 2.D-2 / SQRT(DP20) ) ENDIF C LIMIT STEPSIZE BACAUSE OF ENERGY CHANGE IM EL.FIELD IF ( EDOT0*FNORME .NE. 0.D0 ) THEN USTEP = MIN( USTEP, ABS( 2.D-2*(1.D0+GAMMAI)/(EDOT0*FNORME) ) ) ENDIF #endif C LOOK HOW FAR WE CAN GO #if __CURVED__ DNEAR(NP) = 0.D0 #endif IF ( USTEP .GT. DNEAR(NP) ) CALL HOWFAR( IRETC ) IF ( IDISC .GT. 0 ) THEN C THIS HAPPENS IF WE ARE OUT OF ATMOSPHERE GOTO 420 ENDIF IF ( USTEP .LE. 0.D0 ) THEN IF ( USTEP .LT. -1.D-4 ) THEN C NEGATIVE USTEP---PROBABLE TRUNCATION PROBLEM AT A BOUNDARY, WHICH C MEANS WE ARE NOT IN THE REGION WE THINK WE ARE IN. THE DEFAULT MACRO C ASSUMES THAT USER HAS SET IRNEW TO THE REGION WE ARE REALLY MOST C LIKELY TO BE IN. A MESSAGE IS WRITTEN OUT WHENEVER USTEP IS LESS C THAN -1.E-4 WRITE(KMPO,460) USTEP 460 FORMAT(' ELECTR: NEGATIVE USTEP=',G20.10,' CM') WRITE(KMPO,470) Z(NP),DNEAR(NP),IR(NP),IRNEW,W(NP) 470 FORMAT(' Z=',G15.7, ' DNEAR=',G15.7,' IR=',I5, ' IRNEW=',I5, * ' W=',G15.7) NSTPCN = NSTPCN+1 IF ( NSTPCN .GE. 20 ) THEN CALL AUSGB2 WRITE(KMPO,480) NSTPCN 480 FORMAT(' ELECTR: PROGRAM STOPPED BECAUSE OF FREQUENT', * 'NEGATIVE USTEP, COUNTER = ',I5) STOP ENDIF ENDIF USTEP = 0.D0 ENDIF ZOLD = Z(NP) #if __CURVED__ XOLD = X(NP) YOLD = Y(NP) XXXOLD = XXXX(NP) YYYOLD = YYYY(NP) ZAPOLD = ZAP(NP) DISTO2 = X(NP)**2 + Y(NP)**2 IF ( IDISC .EQ. -1 ) THEN C PARTICLE WILL CROSS THE DETECTOR LEVEL IF ( FEGSDB ) THEN WRITE(MDEBUG,*) 'ELECTR: WE APPROACH DETECTOR' CALL AUSGB2 ENDIF AUXILSQ = SQRT( DISTO2 ) WA(NP) = COS( AUXILSQ / C(1) ) WA(NP) = MIN( 1.D0, WA(NP) ) C REGARD WHETHER PARTICLE IS MOVING TOWARDS DETECTOR C EFFECTIVE DISTANCE TO DETECTOR CENTER IS DISTANCE TO POINT C OF FLIGHT PATH PROJECTION WHICH COMES CLOSEST TO DETECTOR CENTER IF ( U(NP) .NE. 0.D0 .OR. V(NP) .NE. 0.D0 ) THEN PHIC = ATAN2(V(NP),U(NP)) ELSE PHIC = 0.D0 ENDIF DSTEFF = -( COS( PHIC )*X(NP) + SIN( PHIC )*Y(NP) ) C ANGLE DIF MIGHT BE LARGE (DUE TO CUT ON APPARTENT HEIGHT) C BUT SHOULD NOT BE TOO LARGE IF ( DSTEFF .LT. C(3) ) THEN C CALCULATE CORRECTION ANGLE DIF FROM EFFECTIVE DISTANCE DSTEFF SINDIF = SIN( DSTEFF / C(1) ) COSDIF = SQRT( (1.D0-SINDIF)*(1.D0+SINDIF) ) COSTHENEW = W(NP)*COSDIF IF ( ABS(W(NP)) .LT. 1.D0 ) COSTHENEW = * COSTHENEW - SQRT( (1.D0-W(NP))*(1.D0+W(NP)) )*SINDIF IF ( FEGSDB ) WRITE(MDEBUG,*) 'ELECTR: COSDIF,COSTHENEW=', * SNGL(COSDIF),SNGL(COSTHENEW) W(NP) = MIN( 1.D0, COSTHENEW ) #if __UPWARD__ W(NP) = MAX( -1.D0, W(NP) ) #endif ENDIF C KILL HORIZONTAL OR UPWARD GOING PARTICLES IF ( W(NP) .LE. WCUT ) THEN IRETC = .FALSE. GOTO 420 ENDIF ZAP(NP) = C(1) - (C(1)-Z(NP)) * WA(NP) IF ( FFLATOUT ) THEN C ANGLE DIF (= DSTEFF/C(1)) MIGHT BE LARGE DUE TO CUT ON HAPP c X(NP) = (C(1)-ZAP(NP)) * TAN( X(NP)/C(1) ) c Y(NP) = (C(1)-ZAP(NP)) * TAN( Y(NP)/C(1) ) c Z(NP) = ZAP(NP) IF ( WA(NP) .NE. 1.D0 ) THEN C CALCULATE AZIMUTH ANGLE OF PARTICLE SEEN FROM DETECTOR IF ( Y(NP) .NE. 0.D0 .OR. X(NP) .NE. 0.D0 ) THEN PHI1 = ATAN2( Y(NP), X(NP) ) ELSE PHI1 = 0.D0 ENDIF C WE ARE AWAY FROM DETECOR SINTEA = SQRT( (1.D0-WA(NP))*(1.D0+WA(NP)) ) C HORIZONTAL DISTANCE OF PARTICLE TO DETECTOR RRR = ( -ZAP(NP) + C(1) ) * SINTEA / WA(NP) C UPDATE COORDINATES OF STARTING POINT IN A FLAT ATMOSPHERE (FOR UPDATE) X(NP) = RRR * COS( PHI1 ) Y(NP) = RRR * SIN( PHI1 ) Z(NP) = ZAP(NP) ELSE C WE ARE IN THE DETECTOR SYSTEM AND NEED NO COORDINATE CALCULATION ENDIF WAP(NP) = 0.D0 #if __CERENKOV__ || __AUGCERLONG__ DETSYS = .TRUE. #endif ELSE #if __CERENKOV__ || __AUGCERLONG__ DETSYS = .FALSE. #endif ENDIF IF ( U(NP) .NE. 0.D0 ) THEN TANPHI = V(NP)/U(NP) IF ( ABS(W(NP)) .LT. 1.D0 ) THEN U(NP) = SIGN( 1.D0,U(NP) ) * * SQRT( (1.D0-W(NP))*(1.D0+W(NP) )/(1.D0+TANPHI**2)) ELSE U(NP) = 0.D0 ENDIF V(NP) = TANPHI * U(NP) ELSE IF ( V(NP) .NE. 0.D0 .AND. ABS(W(NP)) .LT. 1.D0 ) THEN V(NP) = SIGN(1.D0,V(NP))*SQRT( (1.D0-W(NP))*(1.D0+W(NP)) ) ELSE V(NP) = 0.D0 ENDIF ENDIF #if __UPWARD__ IF ( W(NP) .GT. 0.D0 ) THEN IF ( PRMPAR(15) .GE. 0.D0 ) THEN USTEP = -(Z(NP)+OBSLEV(1))/W(NP) ELSE IF ( FEGSDB ) WRITE(MDEBUG,*)'ELECTR: DOWNWARD GOING PARTI' * ,'CLE IN UPWARD GOING SHOWER SHOULD NOT REACH DETECTOR !' IDISC = 1 IRETC = .FALSE. GOTO 420 ENDIF ELSEIF ( W(NP) .LT. 0.D0 ) THEN IF ( PRMPAR(15) .LT. 0.D0 ) THEN USTEP = -(Z(NP)+OBSLEV(1))/W(NP) ELSE IF ( FEGSDB ) WRITE(MDEBUG,*)'ELECTR: UPWARD GOING PARTICL' * ,'E IN DOWNWARD GOING SHOWER SHOULD NOT REACH DETECTOR !' IDISC = 1 IRETC = .FALSE. GOTO 420 ENDIF ELSE C HORIZONTAL MOVEMENT C USTEP = MAX( C(4) * THICK( -Z(NP) ) + C(3), C(2) ) IDISC = 1 IRETC = .FALSE. GOTO 420 ENDIF #else USTEP = -(Z(NP)+OBSLEV(1))/W(NP) #endif IF ( FEGSDB ) THEN WRITE(MDEBUG,*) 'ELECTR: CORR. FOR DET. ARRIVAL:USTEP=',USTEP CALL AUSGB2 ENDIF USTEP = MAX( USTEP, 0.0001D0 ) IPASC = 1 ELSE #if __CERENKOV__ || __AUGCERLONG__ DETSYS = .FALSE. #endif C PARTICLE MOVES TO END OF ITS RANGE, WE DO NOT YET APPROACH DETECTOR IPASC = 0 ENDIF #else #if __SLANT__ XOLD = X(NP) YOLD = Y(NP) #endif #endif #if __CERENKOV__ || __AUGCERLONG__ C FILL IN CHERENKOV COORDINATES AT BEGIN OF STEP EBEG = PEIE*1.D-3 EEND = PEIE*1.D-3 XBEG = X(NP) YBEG = -Y(NP) ZBEG = -Z(NP) TBEG = TIM(NP) #endif C WE ARE IN VACUUM OR MAKE A ZERO STEP IF ( USTEP .EQ. 0.D0 .OR. MEDIUM .EQ. 0 ) THEN IF ( USTEP .NE. 0.D0 ) THEN VSTEP = USTEP TVSTEP = VSTEP C WE ARE IN VACUUM, NO ENERGY LOSS EDEP = 0.D0 TVSTPC = TVSTEP C CHARGED PARTICLE TRANSPORT IN EARTH MAGNETIC FIELD C SEE ALSO SLAC-265, P. 127 FF ALPHA = VSTEP*LELEC*BNORM/PEIE TVSTPC = TVSTPC*(1.D0+0.04166667D0*ALPHA**2) U0 = U(NP) V0 = V(NP) W0 = W(NP) FNORM = 1.D0-0.5D0*ALPHA**2*(1.D0-0.75D0*ALPHA**2) F1SIN = (1.D0-FNORM)*SINB F1COS = (1.D0-FNORM)*COSB V1 = V0*ALPHA*FNORM USW = U0*SINB-W0*COSB U(NP) = U0-F1SIN*USW+V1*SINB V(NP) = FNORM*(V0-ALPHA*USW) W(NP) = W0+F1COS*USW-V1*COSB RADINV = 1.5D0-0.5D0*(U(NP)**2+V(NP)**2+W(NP)**2) U(NP) = U(NP)*RADINV V(NP) = V(NP)*RADINV W(NP) = W(NP)*RADINV UMEAN = 0.5D0*(U0+U(NP)) VMEAN = 0.5D0*(V0+V(NP)) WMEAN = 0.5D0*(W0+W(NP)) #if __UPWARD__ C LIMIT UPWARD GOING PARTICLES TO THE BORDER OF ATMOSPHERE ZNEWUP = Z(NP) + VSTEP*WMEAN IF ( -ZNEWUP .GE. BOUND(1)-1.D0 ) THEN IRETC = .FALSE. GOTO 420 ELSEIF ( -ZNEWUP .LE. BOUND(6) ) THEN IRETC = .FALSE. GOTO 420 ENDIF #endif X(NP) = X(NP) + VSTEP*UMEAN Y(NP) = Y(NP) + VSTEP*VMEAN Z(NP) = Z(NP) + VSTEP*WMEAN #if __CURVED__ IF ( IPASC .EQ. 0 .OR. .NOT.FFLATOUT ) THEN C NORMAL STEP TO END OF PARTICLE RANGE, WE DO NOT YET APPROACH DETECTOR C BUT WE ARE IN VACUUM W(NP) = MIN( 1.D0, W(NP) ) #if __UPWARD__ W(NP) = MAX( -1.D0, W(NP) ) #endif C HORIZONTAL COMPONENT OF TRACK LENGTH SQUARED TRANS2 = (X(NP)-XOLD)**2 + (Y(NP)-YOLD)**2 C TRANSPORT AT MINIMUM .001 MM TRANS2 = MAX( TRANS2, 0.00001D0 ) C NEW COORDINATE FRAME, NEW ACTUAL HEIGHT AT NEW THICKNESS GRADIENT C (CALCULATED WITH PARAMETERS OF OLD COORDINATE FRAME) AUXIL = SQRT( TRANS2 + (C(1)-Z(NP))**2 ) ZNEW = C(1) - AUXIL C CALCULATE ANGLE DIFFERENCE BETWEEN OLD AND NEW FRAME SINDIF = SQRT( TRANS2 ) / AUXIL COSDIF = (C(1)-Z(NP)) / AUXIL IF ( FEGSDB ) WRITE(MDEBUG,560) COSDIF,SINDIF,-Z(NP),-ZNEW 560 FORMAT(' ELECTR: COSDIF,SINDIF,Z,ZNEW=',2F18.15,1P,2E17.9) COSDIF = MIN( 1.D0, COSDIF ) C TRANSPORT DISTANCE IS CORRECTED TO GET DISTANCE AT EARTH'' SURFACE CORR = C(1) * ASIN( SINDIF ) / ( (C(1)-ZNEW)*SINDIF ) X(NP) = XOLD + (X(NP)-XOLD)*CORR Y(NP) = YOLD + (Y(NP)-YOLD)*CORR Z(NP) = ZNEW C IN FIRST ORDER APPROXIMATION W(NP) AND COSDIF ARE IN THE SAME PLANE C OF PARTICLE MOVEMENT, THEREFORE THE ANGLES MAY BE ADDED DIRECTLY COSTHENEW = W(NP)*COSDIF IF ( ABS(W(NP)) .LT. 1.D0 ) COSTHENEW = * COSTHENEW - SINDIF*SQRT( (1.D0-W(NP))*(1.D0+W(NP)) ) W(NP) = MIN( 1.D0, COSTHENEW ) #if __UPWARD__ W(NP) = MAX( -1.D0, W(NP) ) #endif C KILL HORIZONTAL OR UPWARD GOING PARTICLES IF ( W(NP) .LE. WCUT ) THEN IRETC = .FALSE. GOTO 420 ENDIF IF ( FEGSDB ) THEN WRITE(MDEBUG,562) WA(NP),-ZAP(NP) 562 FORMAT(' ELECTR: WA,-ZAP=',F18.15,1P,E17.9) WRITE(MDEBUG,557) U(NP),-V(NP),W(NP),X(NP),-Y(NP),-Z(NP) 557 FORMAT(' ELECTR: STEPEND=',1P,6(E11.3,1X),0P) ENDIF C CALCULATE ANGLES IN THE NEW FRAME AUXILSQ = SQRT( X(NP)**2 + Y(NP)**2 ) WA(NP) = COS( AUXILSQ / C(1) ) WA(NP) = MIN( 1.D0, WA(NP) ) ZAP(NP) = C(1) - (C(1)-ZNEW) * WA(NP) AUX2SQ = SQRT( (C(1)-ZNEW)**2*(1.D0-WA(NP))*(1.D0+WA(NP)) * + (-ZAP(NP)-OBSLEV(1))**2 ) IF ( AUX2SQ .GT. 0.D0 ) THEN WAP(NP) = -(OBSLEV(1)+ZAP(NP)) / AUX2SQ ELSE C PARTICLE REACHED THE GROUND AT CORE POSITION WAP(NP) = 0.D0 ENDIF IF ( FEGSDB ) WRITE(MDEBUG,*) 'ELECTR: WAP=',WAP(NP) C KILL PARTICLES, WHICH ARE BELOW DETECTOR SURFACE C CUT ON APPARENT HEIGHT #if __UPWARD__ IF ( PRMPAR(15) .LE. 0.D0 ) THEN WAP(NP) = MAX( -1.D0, WAP(NP) ) ELSEIF ( FFLATOUT ) THEN IF ( -ZAP(NP) .LE. OBSLEV(1) ) THEN IRETC = .TRUE. IDISC = -1 IF ( FNPRIM ) GOTO 420 GOTO 498 ENDIF ENDIF #else IF ( FFLATOUT .AND. -ZAP(NP) .LE. OBSLEV(1) ) THEN IRETC = .TRUE. IDISC = -1 IF ( FNPRIM ) GOTO 420 GOTO 498 ENDIF #endif WAP(NP) = MIN( 1.D0, WAP(NP) ) IF ( U(NP) .NE. 0.D0 ) THEN TANPHI= V(NP) / U(NP) IF ( ABS(W(NP)) .LT. 1.D0 ) THEN U(NP) = SIGN(1.D0,U(NP)) * * SQRT( (1.D0-W(NP))*(1.D0+W(NP))/(1.D0+TANPHI**2) ) ELSE U(NP) = 0.D0 ENDIF V(NP) = TANPHI * U(NP) ELSE IF ( V(NP) .NE. 0.D0 .AND. ABS(W(NP)) .LT. 1.D0 ) THEN V(NP) = SIGN(1.D0,V(NP))*SQRT((1.D0-W(NP))*(1.D0+W(NP))) ELSE V(NP) = 0.D0 ENDIF ENDIF IF ( WA(NP) .NE. 1.D0 ) THEN C WE ARE AWAY FROM DETECOR C CALCULATE AZIMUTH ANGLE OF PARTICLE SEEN FROM DETECTOR IF ( Y(NP) .NE. 0.D0 .OR. X(NP) .NE. 0.D0 ) THEN PHI1 = ATAN2( Y(NP), X(NP) ) ELSE PHI1 = 0.D0 ENDIF C HORIZONTAL DISTANCE OF PARTICLE TO DETECTOR RRR = SQRT( (1.D0-WA(NP))*(1.D0+WA(NP)) ) * * ( C(1) - ZAP(NP) ) / WA(NP) XXX = RRR * COS( PHI1 ) YYY = RRR * SIN( PHI1 ) ELSE C WE ARE IN THE DETECTOR SYSTEM AND NEED NO COORDINATE CALCULATION XXX = X(NP) YYY = Y(NP) ENDIF C STORE COORDINATES IN THE DETECTOR SYSTEM XXXX(NP) = XXX YYYY(NP) = YYY ELSE ZAP(NP) = Z(NP) XXXX(NP) = X(NP) YYYY(NP) = Y(NP) ENDIF TDIFF = TVSTPC*VCI/SQRT( * (1.D0-(PRM/E(NP)))*(1.D0+(PRM/E(NP))) ) IF( VSTEP .GT. 1D-10 )THEN C SPEED OF PARTICLE IN LOCAL FRAME SPEED0 = VSTEP C SPEED OF PARTICLE IN OBSERVER FRAME SPEED = SQRT(( XXXX(NP) - XXXOLD )**2 * +( YYYY(NP) - YYYOLD )**2 * +( ZAP(NP) - ZAPOLD )**2 ) IF ( FEGSDB ) WRITE(MDEBUG,*)'ELECTR: VSTEP/TDIFF,S/S0=' * ,VSTEP/TDIFF/C(25),SPEED/SPEED0 ELSE SPEED0 = 1.D0 SPEED = 1.D0 ENDIF C FIX TIME DIFFERENCE DUE TO FRAME SHIFT : SPEED IN LOCAL FRAME C (AFTER UPDATE) SHOULD BE THE SAME AS IN OBSERVER FRAME TIM(NP) = TIM(NP) + TDIFF * SPEED/SPEED0 IF(ABS(VSTEP).GT.1D1.AND.ABS(SPEED/SPEED0-1.D0).GT.1.D-1)THEN IF ( DEBUG ) WRITE(MONIOU,'(A,F5.2)') & 'WARNING: SPEED CORRECTION ELE > 10% -> OK IF RARE',SPEED/SPEED0 IF ( DEBDEL ) THEN LCOUNT = LCOUNT + 1 WRITE(MDEBUG,*) 'ELECTR: LCOUNT = ',LCOUNT IF ( LCOUNT .GE. JCLOCK ) FEGSDB = .TRUE. IF ( LCOUNT .GE. JCLOCK+10 ) FEGSDB = .FALSE. IF ( LCOUNT .GE. NDEBDL ) DEBUG = .TRUE. IF ( LCOUNT .GE. NDEBDL+10 ) DEBUG = .FALSE. ENDIF ENDIF #else TIM(NP) = TIM(NP) + TVSTPC*VCI/SQRT( * (1.D0-(PRM/E(NP)))*(1.D0+(PRM/E(NP))) ) C KILL HORIZONTAL OR UPWARD GOING PARTICLES IF ( W(NP) .LE. WCUT ) THEN IRETC = .FALSE. GOTO 420 ENDIF #endif #if __CERENKOV__ C NO CHERENKOV PHOTONS, WE ARE IN VACUUM #endif #if __PARALLEL__ C PLOTS IF NOTHING STORED IN 2ND STACK TRACKING AGAIN PRIMARY PARTICLE IF ( FNPRIM .OR. JCOUNT .LE. 1 ) THEN #endif #if __PLOTSH__ IF ( PLOTSH ) THEN C DON''T PLOT EM-PRIMARY BEFORE THE FIRST INTERACT EXCEPT FOR TMARGIN IF ( FNPRIM .OR. TMARGIN ) THEN C END OF TRACKING STEP TRX2 = X(NP) TRY2 = -Y(NP) #if __CURVED__ TRZ2 = -ZAP(NP) #else TRZ2 = -Z(NP) #endif TRT2 = TIM(NP) WRITE(55) TRID,TRE,TRX1,TRY1,TRZ1,TRT1, * TRX2,TRY2,TRZ2,TRT2 NPLEM = NPLEM + 1 IF ( DEBUG ) THEN WRITE(MDEBUG,2552) TRID,TRE,TRX1,TRY1,TRZ1,TRT1, * TRX2,TRY2,TRZ2,TRT2 2552 FORMAT(' TRACKINFEM ',1P,6E15.5,/,42X,4E15.5) ENDIF ENDIF ENDIF #endif #if __PLOTSH2__ IF ( PLOTSH .AND. TIM(NP) .LT. PLTCUT ) THEN C DON''T PLOT EM-PRIMARY BEFORE THE FIRST INTERACT EXCEPT FOR TMARGIN IF ( FNPRIM .OR. TMARGIN ) THEN C END OF TRACKING STEP, APPLY TIME CUT TRX2 = X(NP) TRY2 = -Y(NP) #if __CURVED__ TRZ2 = -ZAP(NP) #else TRZ2 = -Z(NP) #endif TRT2 = TIM(NP) #if __THIN__ WGHT = WT(NP) #endif IF ( FBOXCUT ) CALL PLTRUNC IF ( ( TRID .LE. 1.D0 .AND. TRE .GT. PLCUT(4) ) .OR. * ( ( TRID .EQ. 2.D0 .OR. TRID .EQ. 3.D0 ) .AND. * TRE .GT. PLCUT(3) ) ) THEN C X-Y AND OTHER PROJECTIONS (E.M.-> MAP 1) CALL LINPLXY( 1,TRX1,TRY1,TRX2,TRY2,WGHT ) CALL LINPLXZ( 1,TRX1,TRZ1,TRX2,TRZ2,WGHT ) CALL LINPLYZ( 1,TRY1,TRZ1,TRY2,TRZ2,WGHT ) IF ( DEBUG ) THEN WRITE(MDEBUG,2553) TRID,TRE,TRX1,TRY1,TRZ1,TRT1, * TRX2,TRY2,TRZ2,TRT2 2553 FORMAT(' TRACKINFEM2 ',1P,6E15.5,/,43X,4E15.5) ENDIF ENDIF ENDIF ENDIF #endif C ADD ELECTRONS TO THE LONGITUDINAL DEVELOPMENT C FIND FIRST THE EQUIVALENT LEVELS IF ( LLONGI ) THEN #if __SLANT__ #if __CURVED__ AUXOLD = XXXOLD*STHCPH - YYYOLD*STHSPH + ZAPOLD*CTH + RLOFF AUXNEW = XXXX(NP)*STHCPH-YYYY(NP)*STHSPH+ZAP(NP)*CTH + RLOFF #else AUXOLD = XOLD *STHCPH - YOLD *STHSPH + ZOLD *CTH + RLOFF AUXNEW = X(NP)*STHCPH - Y(NP)*STHSPH + Z(NP)*CTH + RLOFF #endif #endif #if __COASTUSERLIB__ C END OF TRACKING STEP pnt2id = IQ(NP) pnt2gen= igen(np) #if __CURVED__ pnt2x = XXXX(NP) pnt2y = -YYYY(NP) pnt2z = -ZAP(NP) #else pnt2x = X(NP) - XOFF(NOBSLV) pnt2y = -Y(NP) - YOFF(NOBSLV) pnt2z = -Z(NP) #endif #if __SLANT__ pnt2d = THCKSI( AUXNEW ) #else pnt2d = THICK( -Z(NP) )/COS( THETAP ) #endif pnt2t = TIM(NP) pnt2e = E(NP) * 0.001D0 #if __THIN__ pnt2w = WT(NP) #else pnt2w = 1.D0 #endif call track(pnt1x, pnt2x) #endif #if __SLANT__ C IF STARTING POINT BEYOND FURTHEST LEVEL THEN DON''T CHECK IF ( RLONG(NSTEP) .GT. AUXOLD ) THEN T1 = TSLAN(NP) #else C IF STARTING POINT BELOW LOWEST LEVEL THEN DON''T CHECK IF ( HLONG(NSTEP) .LE. -ZOLD ) THEN #endif LPCT1 = LPCTE(NP) #if __UPWARD__ || __SLANT__ #if __SLANT__ IF ( AUXNEW .GT. AUXOLD ) THEN C FORWARD MOVING PARTICLE #else IF ( W(NP) .GT. 0.D0 ) THEN C DOWNWARD MOVING PARTICLE #endif #endif C Z_NEW IS PROBABLY ONLY LITTLE BELOW Z_OLD, DO INCREMENTAL SEARCH #if __SLANT__ DO I1 = LPCT1, NSTEP+1 IF ( RLONG(I1) .GT. AUXNEW ) GOTO 6003 #else DO I1 = LPCT1, NSTEP IF ( HLONG(I1) .LT. -Z(NP) ) GOTO 6003 #endif ENDDO I1 = NSTEP + 1 6003 CONTINUE LPCT2 = I1 - 1 C STORE END POINT AS POSSIBLE STARTPOINT OF NEXT TRACK LPCTE(NP) = LPCT2 + 1 #if __SLANT__ AUXNEW = MIN( AUXNEW, RLONG(NSTEP+1) ) TSLAN(NP) = THCKSI( AUXNEW ) #endif DO I = LPCT1, LPCT2 #if __THIN__ PLONG(I,IQ(NP)) = PLONG(I,IQ(NP)) + WT(NP) #else PLONG(I,IQ(NP)) = PLONG(I,IQ(NP)) + 1.D0 #endif ENDDO C WE ARE IN VACUUM NO ENERGY LOSS. RELEASABLE ENERGY ERELS [GEV] IF ( IDISC .LT. 0 ) C WE ARE AT OBSERVATION LEVEL OR ATMOSPHERIC BOUNDARY #if __THIN__ * PLONG(LPCT2+1,IQ(NP)) = PLONG(LPCT2+1,IQ(NP)) + WT(NP) ERELS = (E(NP) - DBLE(2*IQ(NP)-5) * PRM) * 1.D-3 * WT(NP) #else * PLONG(LPCT2+1,IQ(NP)) = PLONG(LPCT2+1,IQ(NP)) + 1.D0 ERELS = (E(NP) - DBLE(2*IQ(NP)-5) * PRM) * 1.D-3 #endif C NOW FILL FIRST AND LAST BINS, THEN LOOP OVER THE BINS BETWEEN IF ( LPCT2 .LT. NSTEP ) THEN IF ( IDISC .LT. 0 ) THEN C WE ARE AT OBSERVATION LEVEL OR ATMOSPHERIC BOUNDARY ELONG(LPCT2+1,IQ(NP)) = ELONG(LPCT2+1,IQ(NP)) + ERELS ENDIF ENDIF IF ( LPCT2 .GE. LPCT1 ) THEN ELONG(LPCT2,IQ(NP)) = ELONG(LPCT2,IQ(NP)) + ERELS ENDIF C LOOP OVER ALL LONGITUDINAL BINS IF ( LPCT2 .GT. LPCT1 ) THEN DO I = LPCT1, LPCT2-1 ELONG(I,IQ(NP)) = ELONG(I,IQ(NP)) + ERELS ENDDO ENDIF #if __UPWARD__ || __SLANT__ #if __SLANT__ ELSEIF ( AUXNEW .LT. AUXOLD ) THEN C BACKWARD MOVING PARTICLE #else ELSEIF ( W(NP) .LT. 0.D0 ) THEN C UPWARD MOVING PARTICLE #endif C Z_NEW IS PROBABLY ONLY LITTLE ABOVE Z_OLD, DO INCREMENTAL SEARCH DO I1 = LPCT1-1, 0, -1 #if __SLANT__ IF ( RLONG(I1) .LE. AUXNEW ) GOTO 6004 #else IF ( HLONG(I1) .GT. -Z(NP) ) GOTO 6004 #endif ENDDO I1 = 0 6004 CONTINUE LPCT2 = MAX( I1, 0 ) LPCTE(NP) = LPCT2 + 1 #if __SLANT__ AUXNEW = MIN( AUXNEW, RLONG(NSTEP+1) ) TSLAN(NP) = THCKSI( AUXNEW ) #endif DO I = LPCT2+1, LPCT1-1 #if __THIN__ PLONG(I,IQ(NP)) = PLONG(I,IQ(NP)) + WT(NP) #else PLONG(I,IQ(NP)) = PLONG(I,IQ(NP)) + 1.D0 #endif ENDDO C WE ARE IN VACUUM NO ENERGY LOSS. RELEASABLE ENERGY ERELS [GEV] C ARE WE AT OBSERVATION LEVEL OR ATMOSPHERIC BOUNDARY? IF ( IDISC .LT. 0 ) PLONG(LPCT2,IQ(NP)) = #if __THIN__ * PLONG(LPCT2,IQ(NP)) + WT(NP) ERELS = (E(NP) - DBLE(2*IQ(NP)-5) * PRM) * 1.D-3*WT(NP) #else * PLONG(LPCT2,IQ(NP)) + 1.D0 ERELS = (E(NP) - DBLE(2*IQ(NP)-5) * PRM) * 1.D-3 #endif C NOW FILL UPMOST BIN AND LAST BIN, THEN LOOP OVER THE BINS BETWEEN. IF ( LPCT2 .GE. 0 ) THEN IF ( IDISC .LT. 0 ) THEN C WE ARE AT OBSERVATION LEVEL OR ATMOSPHERIC BOUNDARY ELONG(LPCT2,IQ(NP)) = ELONG(LPCT2,IQ(NP))+ERELS ENDIF ENDIF C LAST BIN IF ( LPCT2+1 .LE. LPCT1-1 ) THEN ELONG(LPCT2+1,IQ(NP)) = ELONG(LPCT2+1,IQ(NP)) + ERELS ENDIF C LOOP OVER ALL LONGITUDINAL BINS IF ( LPCT2+1 .LT. LPCT1-1 ) THEN DO I = LPCT2+2, LPCT1-1 ELONG(I,IQ(NP)) = ELONG(I,IQ(NP)) + ERELS ENDDO ENDIF ELSE C MOVING HORIZONTALLY: NO LONGITUDINAL BORDERS ARE CROSSED, NO ACTION C NO ENERGY DEPOSIT, WE ARE IN VACUUM ENDIF #endif ENDIF C END LONGITUDINAL DISTRIBUTION FILLING ENDIF #if __PARALLEL__ ENDIF #endif DNEAR(NP) = DNEAR(NP)-VSTEP IROLD = IR(NP) C END OF STEP IN VACUUM ENDIF IF ( IDISC .GE. 0 ) THEN IF ( -Z(NP) .LT. BOUND(IRNEW) ) THEN IRNEW = IRNEW + 1 IF ( IRNEW .GE. 6 ) THEN C PARTICLE WILL REACH GROUND, TRANSPORT AND ELIMINATE AFTERWARDS IDISC = -2 ENDIF ELSEIF ( ( -Z(NP) .GT. BOUND(IRNEW-1) ) .OR. * ( ( -Z(NP) .EQ. BOUND(IRNEW-1) ) .AND. * ( W(NP) .LE. 0.003D0 ) ) ) THEN IRNEW = IRNEW - 1 IF ( IRNEW .LE. 1 ) THEN C PARTICLE WILL LEAVE ATMOSPHERE, TRANSPORT AND ELIMINATE AFTERWARDS IDISC = -2 ENDIF ENDIF ENDIF IR(NP) = IRNEW IRL = IRNEW MEDIUM = MED(IRL) IF ( PEIE .LE. ECUT(IRL) ) THEN IF ( FNPRIM ) GOTO 390 GOTO 498 ENDIF C KILL UPWARD GOING PARTICLES IF ( W(NP) .LE. WCUT ) THEN IRETC = .FALSE. GOTO 420 ENDIF IF ( USTEP .NE. 0.D0 ) THEN C LOOK FOR OBSERVATION LEVEL AND GIVE TO OUTPUT IF ( NEWOBS .GT. IOBS(NP) ) THEN #if __PARALLEL__ C IF NOTHING STORED IN 2ND STACK TRACKING AGAIN PRIMARY PARTICLE IF ( FNPRIM .OR. JCOUNT .LE. 1 ) THEN #endif CALL AUSGAB #if __PARALLEL__ ENDIF #endif IOBS(NP) = NEWOBS #if __UPWARD__ ELSEIF ( NEWOBS .LT. IOBS(NP) ) THEN IOBS(NP) = NEWOBS #if __PARALLEL__ C IF NOTHING STORED IN 2ND STACK TRACKING AGAIN PRIMARY PARTICLE IF ( FNPRIM .OR. JCOUNT .LE. 1 ) THEN #endif CALL AUSGAB #if __PARALLEL__ ENDIF #endif #endif ENDIF #if __CURVED__ IF ( TIM(NP) .GT. TIMLIM ) THEN C CHECK WHETHER PARTICLE EXCEEDS TIME LIMIT IF ( DEBUG .OR. LTMLMPR ) WRITE(MDEBUG,570) 570 FORMAT(' ELECTR: PARTICLE ELIMINATED BECAUSE OF TIME LIMIT,' * ,' PLEASE READ THE USERS GUIDE,' * ,' SEE KEYWORD: TIMLIM') IRETC = .FALSE. GOTO 420 ENDIF #endif ENDIF GOTO 401 ENDIF C WE ARE IN NORMAL MEDIUM WITH NORMAL STEP VSTEP = USTEP IF ( USTEP .EQ. USTEP0 ) THEN TVSTEP = TUSTEP TVSTPC = TUSTPC ELSE C KILL UPWARD GOING PARTICLES IF ( W(NP) .LE. WCUT ) THEN IRETC = .FALSE. GOTO 420 ENDIF C PATH LENGTH CORRECTION FOR BAROMETRIC AIR VSTEPU = VSTEP DISC = W(NP)*VSTEPU*HBAROI(IRL) IF ( DISC .NE. 0.D0 ) THEN VSTEPU = VSTEPU*(EXP( DISC )-1.D0)/(DISC*ALTEXP) ELSE VSTEPU = VSTEPU/ALTEXP ENDIF VSTEPU = MAX( VSTEPU, .0001D0 ) C PATH LENGTH CORRECTION FOR MULTIPLE SCATTERING VSTP = VSTEPU/TSCAT IPTH = B0PTH+B1PTH*VSTP IPTH = MAX( IPTH, 1 ) IF ( IPTH .GT. NPTH ) THEN IF ( DEBUG ) THEN CALL AUSGB2 WRITE(KMPO,490) VSTP,IPTH,NPTH 490 FORMAT(' ELECTR: OUT OF BOUNDS IPTH: VSTP,IPTH,NPTH=',1P, * G15.6,2I10) ENDIF IPTH = NPTH ENDIF PTH = PTH0(IPTH)+VSTP*(PTH1(IPTH)+VSTP*PTH2(IPTH)) TVSTEP = PTH*VSTEPU TVSTPC = PTH*VSTEP ENDIF C DEFLECTION IN MAGNETIC FIELD ALPHA = VSTEP*LELEC*BNORM/PEIE TVSTPC = TVSTPC*(1.D0+0.04166667D0*ALPHA**2) C NOW TAKE IONIZATION LOSSES INTO ACCOUNT DE = DEDX*TVSTEP EDEP = DE EKEF = EKE-DE EOLD = PEIE ENEW = EOLD-DE C NOW CHANGE ANGLE BECAUSE OF MULTIPLE SCATTERING CALL MSCAT C WE NOW KNOW DISTANCE AND AMOUNT OF ENERGY LOSS FOR THIS STEP, C AND THE ANGLE BY WHICH THE ELECTRON WILL BE SCATTERED. U0 = U(NP) V0 = V(NP) W0 = W(NP) C NOW TRANSPORT, DEDUCT ENERGY LOSS, DO MULTIPLE SCATTER AND C DEFLECT IN MAGNETIC FIELD FNORM = 1.D0-0.5D0*ALPHA**2*(1.D0-0.75D0*ALPHA**2) F1SIN = (1.D0-FNORM)*SINB F1COS = (1.D0-FNORM)*COSB V1 = V0*ALPHA*FNORM USW = U0*SINB-W0*COSB U(NP) = U0-F1SIN*USW+V1*SINB V(NP) = FNORM*(V0-ALPHA*USW) W(NP) = W0+F1COS*USW-V1*COSB #if __EFIELD__ C CHANGE DIRECTION BY ELECTRICAL FIELD X1 = X0 + VSTEP*U(NP) Y1 = Y0 + VSTEP*V(NP) Z1 = Z0 + VSTEP*W(NP) C ATTENTION! MIRROR DEFINITION OF Y,Z TO HADRONIC PART CALL ELFIELD( X1,-Y1,-Z1, EX1,EY1,EZ1 ) C BUT DIRECTION COSIN IN Z DIRECTION IS UNCHANGED C THEREFORE USE INVERTED FIELD FOR EY AND EZ C CONVERSION VOLT TO MV GIVES FACTOR 1.D-6 EX1 = 1.D-6 * EX1 / PRM EY1 = -1.D-6 * EY1 / PRM EZ1 = -1.D-6 * EZ1 / PRM EDOT1 = EX1*U(NP) + EY1*V(NP) + EZ1*W(NP) DPX1 = FNORME * 0.5D0 * (EX1 - U(NP)*EDOT1 + DPX0) DPY1 = FNORME * 0.5D0 * (EY1 - V(NP)*EDOT1 + DPY0) DPZ1 = FNORME * 0.5D0 * (EZ1 - W(NP)*EDOT1 + DPZ0) DP21 = DPX1**2 + DPY1**2 + DPZ1**2 IF ( DP21 .NE. 0.D0 ) THEN ALPHA2 = 0.5D0 * DP21 * VSTEP**2 FNORM2 = 1.D0 / (1.D0 + ALPHA2*(1.D0 - 0.5D0*ALPHA2)) U(NP) = (U(NP) + VSTEP*DPX1) * FNORM2 V(NP) = (V(NP) + VSTEP*DPY1) * FNORM2 W(NP) = (W(NP) + VSTEP*DPZ1) * FNORM2 ENDIF #endif C MAGNETIC DEFLECTION IS APPROXIMATION, THEREFORE RENORMALIZE U, V, W RADINV = 1.5D0-0.5D0*(U(NP)**2+V(NP)**2+W(NP)**2) U(NP) = U(NP)*RADINV V(NP) = V(NP)*RADINV W(NP) = W(NP)*RADINV UMEAN = 0.5D0*(U0+U(NP)) VMEAN = 0.5D0*(V0+V(NP)) WMEAN = 0.5D0*(W0+W(NP)) #if __EFIELD__ C ENERGY LOSS OR GAIN IN ELECTRICAL FIELD C POTENTIAL DIFFERENCE DPOT (IN MEV) C FACTOR 0.5 BY AVERAGING OF FIELD AT START AND END DPOT = 0.5D0 * PRM * LELEC * ( (EX0 + EX1)*(X0 - X1) * + (EY0 + EY1)*(Y0 - Y1) * + (EZ0 + EZ1)*(Z0 - Z1) ) DE = DE + DPOT EDEP = DE EKEF = EKE - DE ENEW = EOLD - DE #endif #if __UPWARD__ C LIMIT UPWARD GOING PARTICLES TO THE BORDER OF ATMOSPHERE ZNEWUP = Z(NP) + VSTEP*WMEAN IF ( -ZNEWUP .GE. BOUND(1)-1.D0 ) THEN IRETC = .FALSE. GOTO 420 ELSEIF ( -ZNEWUP .LE. BOUND(6) ) THEN IRETC = .FALSE. GOTO 420 ENDIF #endif X(NP) = X(NP) + VSTEP*UMEAN Y(NP) = Y(NP) + VSTEP*VMEAN Z(NP) = Z(NP) + VSTEP*WMEAN #if __CURVED__ IF ( IPASC .EQ. 0 .OR. .NOT.FFLATOUT ) THEN C WE TRANSPORT THE PARTICLE TO END OF IT''S RANGE, NORMAL STEP C NOW WE ARE IN NORMAL MATTER W(NP) = MIN( 1.D0, W(NP) ) #if __UPWARD__ W(NP) = MAX( -1.D0, W(NP) ) #endif C HORIZONTAL COMPONENT OF TRACK LENGTH SQUARED TRANS2 = (X(NP)-XOLD)**2 + (Y(NP)-YOLD)**2 C TRANSPORT AT MINIMUM .001 MM TRANS2 = MAX( TRANS2, 0.0001D0 ) C NEW COORDINATE FRAME, NEW ACTUAL HEIGHT AT NEW THICKNESS GRADIENT C (CALCULATED WITH PARAMETERS OF OLD COORDINATE FRAME) AUXIL = SQRT( TRANS2 + (C(1)-Z(NP))**2 ) ZNEW = C(1) - AUXIL C CALCULATE ANGLE DIFFERENCE BETWEEN OLD AND NEW FRAME SINDIF = SQRT( TRANS2 ) / AUXIL COSDIF = (C(1)-Z(NP)) / AUXIL IF ( FEGSDB ) WRITE(MDEBUG,560) COSDIF,SINDIF,-Z(NP),-ZNEW COSDIF = MIN( 1.D0, COSDIF ) C TRANSPORT DISTANCE IS CORRECTED TO GET DISTANCE AT EARTH'' SURFACE CORR = C(1) * ASIN( SINDIF ) / ( (C(1)-ZNEW)*SINDIF ) X(NP) = XOLD + (X(NP)-XOLD)*CORR Y(NP) = YOLD + (Y(NP)-YOLD)*CORR Z(NP) = ZNEW C IN FIRST ORDER APPROXIMATION W(NP) AND COSDIF ARE IN THE SAME PLANE C OF PARTICLE MOVEMENT, THEREFORE THE ANGLES MAY BE ADDED DIRECTLY C IF W(NP) IS PROPERLY DEFINED, THEN SIGNE > 0 COSTHENEW = W(NP)*COSDIF IF ( ABS(W(NP)) .LT. 1.D0 ) COSTHENEW = * COSTHENEW - SINDIF*SQRT( (1.D0-W(NP))*(1.D0+W(NP)) ) W(NP) = MIN( 1.D0, COSTHENEW ) #if __UPWARD__ W(NP) = MAX( -1.D0, W(NP) ) #endif C KILL HORIZONTAL OR UPWARD GOING PARTICLES IF ( W(NP) .LE. WCUT ) THEN IRETC = .FALSE. GOTO 420 ENDIF IF ( FEGSDB ) THEN WRITE(MDEBUG,562) WA(NP),-ZAP(NP) WRITE(MDEBUG,557) U(NP),-V(NP),W(NP),X(NP),-Y(NP),-Z(NP) ENDIF C CALCULATE ANGLES IN THE NEW FRAME AUXILSQ = SQRT( X(NP)**2 + Y(NP)**2 ) WA(NP) = COS( AUXILSQ / C(1) ) WA(NP) = MIN( 1.D0, WA(NP) ) ZAP(NP) = C(1) - (C(1)-ZNEW) * WA(NP) AUX2SQ = SQRT( (C(1)-ZNEW)**2*(1.D0-WA(NP))*(1.D0+WA(NP)) * + (-ZAP(NP)-OBSLEV(1))**2 ) IF ( AUX2SQ .GT. 0.D0 ) THEN WAP(NP) = -(OBSLEV(1)+ZAP(NP)) / AUX2SQ ELSE C PARTICLE REACHED THE GROUND AT CORE POSITION WAP(NP) = 0.D0 ENDIF IF ( FEGSDB ) WRITE(MDEBUG,*) 'ELECTR: WAP=',WAP(NP) C LOOK WHETHER PARTICLE IS ALREADY ON DETECTOR SURFACE C CUT ON APPARENT HEIGHT #if __UPWARD__ IF ( PRMPAR(15) .LE. 0.D0 ) THEN WAP(NP) = MAX( -1.D0, WAP(NP) ) ELSEIF ( FFLATOUT ) THEN IF ( -ZAP(NP) .LE. OBSLEV(1) ) THEN IRETC = .TRUE. IDISC = -1 IF ( FNPRIM ) GOTO 420 GOTO 498 ENDIF ENDIF #else IF ( FFLATOUT .AND. -ZAP(NP) .LE. OBSLEV(1) ) THEN IRETC = .TRUE. IDISC = -1 IF ( FNPRIM ) GOTO 420 GOTO 498 ENDIF #endif WAP(NP) = MIN( 1.D0, WAP(NP) ) IF ( U(NP) .NE. 0.D0 ) THEN TANPHI = V(NP) / U(NP) IF ( ABS(W(NP)) .LT. 1.D0 ) THEN U(NP) = SIGN(1.D0,U(NP)) * * SQRT((1.D0-W(NP))*(1.D0+W(NP))/(1.D0+TANPHI**2)) ELSE U(NP) = 0.D0 ENDIF V(NP) = TANPHI * U(NP) ELSE IF ( V(NP) .NE. 0.D0 .AND. ABS(W(NP)) .LT. 1.D0 ) THEN V(NP) = SIGN(1.D0,V(NP))*SQRT( (1.D0-W(NP))*(1.D0+W(NP)) ) ELSE V(NP) = 0.D0 ENDIF ENDIF IF ( WA(NP) .NE. 1.D0 ) THEN C WE ARE AWAY FROM DETECOR C CALCULATE AZIMUTH ANGLE OF PARTICLE SEEN FROM DETECTOR IF ( Y(NP) .NE. 0.D0 .OR. X(NP) .NE. 0.D0 ) THEN PHI1 = ATAN2( Y(NP), X(NP) ) ELSE PHI1 = 0.D0 ENDIF C HORIZONTAL DISTANCE OF PARTICLE TO DETECTOR RRR = SQRT( (1.D0-WA(NP))*(1.D0+WA(NP)) ) * * ( C(1) - ZAP(NP) ) / WA(NP) XXX = RRR * COS( PHI1 ) YYY = RRR * SIN( PHI1 ) ELSE C WE ARE IN THE DETECTOR SYSTEM AND NEED NO COORDINATE CALCULATION XXX = X(NP) YYY = Y(NP) ENDIF C STORE COORDINATES IN THE DETECTOR SYSTEM XXXX(NP) = XXX YYYY(NP) = YYY ELSE ZAP(NP) = Z(NP) XXXX(NP) = X(NP) YYYY(NP) = Y(NP) ENDIF TDIFF = TVSTPC*VCI/SQRT((1.D0-(PRM/E(NP)))*(1.D0+(PRM/E(NP))) ) IF ( VSTEP .GT. 1.D-10 ) THEN C SPEED OF PARTICLE IN LOCAL FRAME SPEED0 = VSTEP C SPEED OF PARTICLE IN OBSERVER FRAME SPEED = SQRT(( XXXX(NP) - XXXOLD )**2 * +( YYYY(NP) - YYYOLD )**2 * +( ZAP(NP) - ZAPOLD )**2 ) IF ( FEGSDB ) WRITE(MDEBUG,*) 'ELECTR: VSTEP/TDIFF,S/S0=' * ,VSTEP/TDIFF/C(25),SPEED/SPEED0 ELSE SPEED0 = 1.D0 SPEED = 1.D0 ENDIF C FIX TIME DIFFERENCE DUE TO FRAME SHIFT : SPEED IN LOCAL FRAME C (AFTER UPDATE) SHOULD BE THE SAME AS IN OBSERVER FRAME TIM(NP) = TIM(NP) + TDIFF * SPEED/SPEED0 IF ( ABS(VSTEP) .GT. 1.D1 .AND. & ABS(SPEED/SPEED0-1.D0) .GT. 1.D-1 ) THEN IF ( DEBUG ) WRITE(MONIOU,'(A,F5.2)') & 'WARNING: SPEED CORRECTION ELE > 10% -> OK IF RARE',SPEED/SPEED0 IF ( DEBDEL ) THEN LCOUNT = LCOUNT + 1 WRITE(MDEBUG,*) 'ELECTR: LCOUNT = ',LCOUNT IF ( LCOUNT .GE. JCLOCK ) FEGSDB = .TRUE. IF ( LCOUNT .GE. JCLOCK+10 ) FEGSDB = .FALSE. IF ( LCOUNT .GE. NDEBDL ) DEBUG = .TRUE. IF ( LCOUNT .GE. NDEBDL+10 ) DEBUG = .FALSE. ENDIF ENDIF #else TIM(NP) = TIM(NP) + TVSTPC*VCI/SQRT( * (1.D0-(PRM/E(NP)))*(1.D0+(PRM/E(NP))) ) C KILL UPWARD GOING PARTICLES IF ( W(NP) .LE. WCUT ) THEN IRETC = .FALSE. GOTO 420 ENDIF #endif #if __PARALLEL__ C IF NOTHING STORED IN 2ND STACK TRACK PRIMARY PARTICLE IF ( FNPRIM .OR. JCOUNT .LE. 1 ) THEN #endif #if __CERENKOV__ || __AUGCERLONG__ C FILL IN CHERENKOV COORDINATES AT END OF STEP #if __CURVED__ IF ( .NOT. DETSYS ) THEN C WE ARE NOT IN LOCAL SYSTEM OF DETECTOR TRANS2 = VSTEP**2 * (UMEAN**2 + VMEAN**2) C TAKE HEIGHT AT END POINT OF TRACK AUXIL = SQRT( TRANS2 + (C(1)+(-Z(NP)))**2 ) SINDIF = SQRT( TRANS2 )/AUXIL IF ( SINDIF .GT. 0.D0 ) THEN CORR = C(1) * ASIN( SINDIF ) / (AUXIL*SINDIF) ELSE CORR = 1.D0 ENDIF XEND = XBEG + UMEAN * VSTEP * CORR YEND = YBEG - VMEAN * VSTEP * CORR C CALCULATE EARTH ANGLE BETWEEN THE ACTUAL LOCAL AND THE C APPARENT COORDINATE SYSTEM AUXIL = SQRT( XBEG**2 + YBEG**2 ) CTEA = COS( AUXIL/C(1) ) ELSE C HERE WE ARE IN LOCAL DETECTOR SYSTEM XEND = X(NP) YEND = -Y(NP) ENDIF #else CTEA = 1.D0 XEND = X(NP) YEND = -Y(NP) #endif #if __CERENKOV__ || __AUGCERLONG__ TEND = TIM(NP) ZEND = -Z(NP) EEND = (PEIE - EDEP)*1.D-3 C GENERATE CHERENKOV PHOTONS IF ( FNPRIM ) THEN CALL CERENK( TVSTPC,UMEAN,-VMEAN,WMEAN,EBEG,EEND, * XBEG,YBEG,ZBEG,XEND,YEND,ZEND,TBEG,TEND,PRM*1.D-3,1.D0*LELEC, #if __THIN__ * WT(NP),CTEA ) #else * 1.D0,CTEA ) #endif ELSE C Since we cannot use the Cherenkov emission before the event header C is complete and written, we delay the first part of the primary's C path. FDELAY = .TRUE. IF ( IDELAY .EQ. 0 ) THEN RXBEG = XBEG RYBEG = YBEG RZBEG = ZBEG RTBEG = TBEG REBEG = EBEG RSTEP = 0.D0 RUMEAN = 0.D0 RVMEAN = 0.D0 RWMEAN = 0.D0 RCTEA = 0.D0 ENDIF IDELAY = IDELAY + 1 RXEND = XEND RYEND = YEND RZEND = ZEND RTEND = TEND REEND = EEND RSTEP = RSTEP + TVSTPC RUMEAN = RUMEAN + UMEAN*TVSTPC RVMEAN = RVMEAN - VMEAN*TVSTPC RWMEAN = RWMEAN + WMEAN*TVSTPC RCTEA = RCTEA + CTEA ENDIF #endif #endif #if __PLOTSH__ IF ( PLOTSH ) THEN C DON''T PLOT EM-PRIMARY BEFORE THE FIRST INTERACT EXCEPT FOR TMARGIN IF ( FNPRIM .OR. TMARGIN ) THEN C END OF TRACKING STEP TRX2 = X(NP) TRY2 = -Y(NP) #if __CURVED__ TRZ2 = -ZAP(NP) #else TRZ2 = -Z(NP) #endif TRT2 = TIM(NP) TRE = ENEW * 0.001D0 WRITE(55) TRID,TRE,TRX1,TRY1,TRZ1,TRT1, * TRX2,TRY2,TRZ2,TRT2 #if __THIN__ * ,WT(NP) #endif NPLEM = NPLEM + 1 IF ( DEBUG ) THEN WRITE(MDEBUG,2552) TRID,TRE,TRX1,TRY1,TRZ1,TRT1, * TRX2,TRY2,TRZ2,TRT2 ENDIF ENDIF ENDIF #endif #if __PLOTSH2__ IF ( PLOTSH .AND. TIM(NP) .LT. PLTCUT ) THEN C DON''T PLOT EM-PRIMARY BEFORE THE FIRST INTERACT EXCEPT FOR TMARGIN IF ( FNPRIM .OR. TMARGIN ) THEN C END OF TRACKING STEP, APPLY TIME CUT TRX2 = X(NP) TRY2 = -Y(NP) #if __CURVED__ TRZ2 = -ZAP(NP) #else TRZ2 = -Z(NP) #endif TRT2 = TIM(NP) TRE = ENEW * 0.001D0 #if __THIN__ WGHT = WT(NP) #endif IF ( FBOXCUT ) CALL PLTRUNC IF ( ( TRID .LE. 1.D0 .AND. TRE .GT. PLCUT(4) ) .OR. * ( ( TRID .EQ. 2.D0 .OR. TRID .EQ. 3.D0 ) .AND. * TRE .GT. PLCUT(3) ) ) THEN C X-Y AND OTHER PROJECTIONS (E.M.-> MAP 1) CALL LINPLXY( 1,TRX1,TRY1,TRX2,TRY2,WGHT ) CALL LINPLXZ( 1,TRX1,TRZ1,TRX2,TRZ2,WGHT ) CALL LINPLYZ( 1,TRY1,TRZ1,TRY2,TRZ2,WGHT ) IF ( DEBUG ) THEN WRITE(MDEBUG,2553) TRID,TRE,TRX1,TRY1,TRZ1,TRT1, * TRX2,TRY2,TRZ2,TRT2 ENDIF ENDIF ENDIF ENDIF #endif C ADD ELECTRONS TO THE LONGITUDINAL DEVELOPMENT C FIND FIRST THE EQUIVALENT LEVELS IF ( LLONGI ) THEN #if __SLANT__ #if __CURVED__ AUXOLD = XXXOLD*STHCPH - YYYOLD*STHSPH + ZAPOLD*CTH + RLOFF AUXNEW = XXXX(NP)*STHCPH-YYYY(NP)*STHSPH+ZAP(NP)*CTH + RLOFF #else AUXOLD = XOLD *STHCPH - YOLD *STHSPH + ZOLD *CTH + RLOFF AUXNEW = X(NP)*STHCPH - Y(NP)*STHSPH + Z(NP)*CTH + RLOFF #endif #endif #if __COASTUSERLIB__ C END OF TRACKING STEP pnt2id = IQ(NP) pnt2gen= IGEN(NP) #if __CURVED__ pnt2x = XXXX(NP) pnt2y = -YYYY(NP) pnt2z = -ZAP(NP) #else pnt2x = X(NP) - XOFF(NOBSLV) pnt2y = -Y(NP) - YOFF(NOBSLV) pnt2z = -Z(NP) #endif #if __SLANT__ pnt2d = THCKSI( AUXNEW ) #else pnt2d = THICK( -Z(NP) )/COS( THETAP ) #endif pnt2t = TIM(NP) pnt2e = ENEW * 0.001D0 #if __THIN__ pnt2w = WT(NP) #else pnt2w = 1.D0 #endif call track(pnt1x, pnt2x) #endif #if __SLANT__ C IF STARTING POINT BEYOND FURTHEST LEVEL THEN DON''T CHECK IF ( RLONG(NSTEP) .GT. AUXOLD ) THEN T1 = TSLAN(NP) #else C IF STARTING POINT BELOW LOWEST LEVEL THEN DON''T CHECK IF ( HLONG(NSTEP) .LE. -ZOLD ) THEN #endif LPCT1 = LPCTE(NP) #if __UPWARD__ || __SLANT__ #if __SLANT__ IF ( AUXNEW .GT. AUXOLD ) THEN C FORWARD MOVING PARTICLE #else IF ( W(NP) .GT. 0.D0 ) THEN C DOWNWARD MOVING PARTICLE #endif #endif C Z_NEW IS PROBABLY ONLY LITTLE BELOW Z_OLD, DO INCREMENTAL SEARCH #if __SLANT__ DO I1 = LPCT1, NSTEP+1 IF ( RLONG(I1) .GT. AUXNEW ) GOTO 6103 #else DO I1 = LPCT1, NSTEP IF ( HLONG(I1) .LT. -Z(NP) ) GOTO 6103 #endif ENDDO I1 = NSTEP + 1 6103 CONTINUE LPCT2 = I1 - 1 C STORE END POINT AS POSSIBLE STARTPOINT OF NEXT TRACK LPCTE(NP) = LPCT2 + 1 DO I = LPCT1, LPCT2 #if __THIN__ PLONG(I,IQ(NP)) = PLONG(I,IQ(NP)) + WT(NP) #else PLONG(I,IQ(NP)) = PLONG(I,IQ(NP)) + 1.D0 #endif ENDDO C ARE WE AT OBSERVATION LEVEL OR ATMOSPHERIC BOUNDARY IF ( IDISC .LT. 0 ) #if __THIN__ * PLONG(LPCT2+1,IQ(NP)) = PLONG(LPCT2+1,IQ(NP)) + WT(NP) #else * PLONG(LPCT2+1,IQ(NP)) = PLONG(LPCT2+1,IQ(NP)) + 1.D0 #endif C TOTAL PATH LENGTH STEPT IN UNITS OF LONGI BINS #if __SLANT__ AUXNEW = MIN( AUXNEW, RLONG(NSTEP+1) ) TSLAN(NP) = THCKSI( AUXNEW ) T2 = TSLAN(NP) STEPT = (T2 - T1) * THSTPI #else THCKHO = THICK( -ZOLD ) THCKHN = THICK( -Z(NP) ) STEPT = (THCKHN - THCKHO) * THSTPI #endif C RELEASABLE ENERGY [IN GEV] #if __THIN__ ERELS = 1.D-3*( E(NP) - DBLE(2*IQ(NP)-5) * PRM ) * WT(NP) C WE ASSUME HOMOGENEOUS ENERGY DEPOSIT ALONG PATH C IONIZATION E(NERGY) DEP(OSED IN EACH) B(IN) [IN GEV] IF ( STEPT .GT. 0.D0 ) THEN EDEPB = EDEP * 1.D-3 * WT(NP) / STEPT ELSE EDEPB = EDEP * 1.D-3 * WT(NP) #else ERELS = 1.D-3*( E(NP) - DBLE(2*IQ(NP)-5) * PRM ) C WE ASSUME HOMOGENEOUS ENERGY DEPOSIT ALONG PATH C IONIZATION E(NERGY) DEP(OSED IN EACH) B(IN) [IN GEV] IF ( STEPT .GT. 0.D0 ) THEN EDEPB = EDEP * 1.D-3 / STEPT ELSE EDEPB = EDEP * 1.D-3 #endif ENDIF C ENERGY DEPOSIT IN FIRST BIN [IN GEV] #if __SLANT__ EDEP1 = EDEPB * (DBLE(LPCT1) - T1*THSTPI) cdh april 4, 2017 cdh EDEP1 = MAX( 0.D0, EDEPB * (DBLE(LPCT1) - T1*THSTPI) ) #else EDEP1 = EDEPB * (DBLE(LPCT1) - THCKHO*THSTPI) #endif C ENERGY AT FIRST BIN BOUNDARY EFRST = ERELS - EDEP1 C ENERGY DEPOSIT IN LAST BIN [IN GEV] IF ( LPCT2 .LE. LPCT1 ) THEN #if __SLANT__ EDEPN = EDEPB * (T2*THSTPI - DBLE(LPCT1)) ELSE EDEPN = MAX( 0.D0, EDEPB*(T2*THSTPI - DBLE(LPCT2)) ) #else EDEPN = EDEPB * (THCKHN*THSTPI - DBLE(LPCT1)) ELSE EDEPN = MAX( 0.D0, EDEPB*(THCKHN*THSTPI - DBLE(LPCT2)) ) #endif ENDIF C NOW FILL FIRST AND LAST+1 BIN, THEN LOOP OVER THE BINS BETWEEN DLONG(LPCT1,2) = DLONG(LPCT1,2) + EDEP1 IF ( LPCT2 .LT. NSTEP ) THEN DLONG(LPCT2+1,2) = DLONG(LPCT2+1,2) + EDEPN IF ( IDISC .LT. 0 ) THEN C WE ARE AT OBSERVATION LEVEL OR ATMOSPHERIC BOUNDARY ELONG(LPCT2+1,IQ(NP)) = ELONG(LPCT2+1,IQ(NP)) * + MAX( 0.D0, (EFRST-(LPCT2+1-LPCT1)*EDEPB) ) ENDIF ELSEIF ( LPCT2 .GE. NSTEP ) THEN DLONG(LPCT2,2) = DLONG(LPCT2,2) + EDEPN IF ( IDISC .LT. 0 ) THEN C WE ARE AT OBSERVATION LEVEL OR ATMOSPHERIC BOUNDARY ELONG(LPCT2,IQ(NP)) = ELONG(LPCT2,IQ(NP)) * + MAX( 0.D0, (EFRST-(LPCT2-LPCT1)*EDEPB) ) ENDIF ENDIF IF ( LPCT2 .GE. LPCT1 ) THEN ELONG(LPCT2,IQ(NP)) = ELONG(LPCT2,IQ(NP)) * + MAX( 0.D0, (EFRST-(LPCT2-LPCT1)*EDEPB) ) ENDIF C LOOP OVER ALL LONGITUDINAL BINS IF ( LPCT2 .GT. LPCT1 ) THEN DO I = LPCT1, LPCT2-1 DLONG(I+1,2) = DLONG(I+1,2) + EDEPB ELONG(I,IQ(NP)) = ELONG(I,IQ(NP)) * + MAX( 0.D0, (EFRST-(I-LPCT1)*EDEPB) ) ENDDO ENDIF #if __UPWARD__ || __SLANT__ #if __SLANT__ ELSEIF ( AUXNEW .LT. AUXOLD ) THEN C BACKWARD MOVING PARTICLE #else ELSEIF ( W(NP) .LT. 0.D0 ) THEN C UPWARD MOVING PARTICLE #endif C Z_NEW IS PROBABLY ONLY LITTLE ABOVE Z_OLD, DO INCREMENTAL SEARCH DO I1 = LPCT1-1, 0, -1 #if __SLANT__ IF ( RLONG(I1) .LE. AUXNEW ) GOTO 6104 #else IF ( HLONG(I1) .GT. -Z(NP) ) GOTO 6104 #endif ENDDO I1 = 0 6104 CONTINUE LPCT2 = MAX( I1, 0 ) LPCTE(NP) = LPCT2 + 1 DO I = LPCT2+1, LPCT1-1 #if __THIN__ PLONG(I,IQ(NP)) = PLONG(I,IQ(NP)) + WT(NP) #else PLONG(I,IQ(NP)) = PLONG(I,IQ(NP)) + 1.D0 #endif ENDDO C ARE WE AT OBSERVATION LEVEL OR ATMOSPHERIC BOUNDARY? IF ( IDISC .LT. 0 ) PLONG(LPCT2,IQ(NP)) = #if __THIN__ * PLONG(LPCT2,IQ(NP)) + WT(NP) #else * PLONG(LPCT2,IQ(NP)) + 1.D0 #endif C TOTAL PATH LENGTH STEPT IN UNITS OF LONGI BINS #if __SLANT__ AUXNEW = MIN( AUXNEW, RLONG(NSTEP+1) ) TSLAN(NP) = THCKSI( AUXNEW ) T2 = TSLAN(NP) STEPT = (T1 - T2)*THSTPI #else THCKHO = THICK( -ZOLD ) THCKHN = THICK( -Z(NP) ) STEPT = (THCKHO - THCKHN)*THSTPI #endif C RELEASABLE ENERGY [IN GEV] #if __THIN__ ERELS = 1.D-3*( E(NP) - DBLE(2*IQ(NP)-5) * PRM ) * WT(NP) C WE ASSUME HOMOGENEOUS ENERGY DEPOSIT ALONG PATH C IONIZATION E(NERGY) DEP(OSED IN EACH) B(IN) [IN GEV] IF ( STEPT .GT. 0.D0 ) THEN EDEPB = EDEP * 1.D-3 * WT(NP) / STEPT ELSE C FOR HORIZONTAL MOVEMENT ALL ENERGY FALLS WITHIN THE ACTUAL BIN EDEPB = EDEP * 1.D-3 * WT(NP) #else ERELS = 1.D-3*( E(NP) - DBLE(2*IQ(NP)-5) * PRM ) C WE ASSUME HOMOGENEOUS ENERGY DEPOSIT ALONG PATH C IONIZATION E(NERGY) DEP(OSED IN EACH) B(IN) [IN GEV] IF ( STEPT .GT. 0.D0 ) THEN EDEPB = EDEP * 1.D-3 / STEPT ELSE EDEPB = EDEP * 1.D-3 #endif ENDIF C ENERGY DEPOSIT FOR UPWARD GOING PARTICLES IN FIRST BIN [IN GEV] #if __SLANT__ EDEP1 = EDEPB * (T1 * THSTPI - DBLE(LPCT1-1)) #else EDEP1 = EDEPB * (THCKHO*THSTPI - DBLE(LPCT1-1)) #endif C ENERGY AT FIRST BIN BOUNDARY [IN GEV] EFRST = ERELS - EDEP1 C ENERGY DEPOSIT IN LAST BIN [IN GEV] IF ( LPCT2+1 .GT. LPCT1-1 ) THEN #if __SLANT__ EDEPN = EDEPB * (DBLE(LPCT1-1) - T2*THSTPI) ELSE EDEPN = MAX( 0.D0, EDEPB*(DBLE(LPCT2+1) - T2*THSTPI) ) #else EDEPN = EDEPB * (DBLE(LPCT1-1) - THCKHN*THSTPI) ELSE EDEPN = MAX( 0.D0, EDEPB*(DBLE(LPCT2+1) - THCKHN*THSTPI) ) #endif ENDIF C NOW FILL FIRST AND LAST BIN, THEN LOOP OVER THE BINS BETWEEN C FIRST BIN DLONG(LPCT1,2) = DLONG(LPCT1,2) + EDEP1 C LAST BIN IF ( LPCT2 .GE. 0 ) THEN DLONG(LPCT2+1,2) = DLONG(LPCT2+1,2) + EDEPN IF ( IDISC .LT. 0 ) THEN C WE ARE AT OBSERVATION LEVEL OR ATMOSPHERIC BOUNDARY ELONG(LPCT2,IQ(NP)) = ELONG(LPCT2,IQ(NP)) * + MAX( 0.D0, (EFRST-(LPCT1-1-LPCT2)*EDEPB) ) ENDIF ENDIF C LAST BIN IF ( LPCT1-1 .GE. LPCT2+1 ) THEN ELONG(LPCT2+1,IQ(NP)) = ELONG(LPCT2+1,IQ(NP)) * + MAX( 0.D0, (EFRST-(LPCT1-LPCT2-2)*EDEPB) ) ENDIF C LOOP OVER ALL LONGITUDINAL BINS IF ( LPCT1-1 .GT. LPCT2+1 ) THEN DO I = LPCT2+2, LPCT1-1 DLONG(I,2) = DLONG(I,2) + EDEPB ELONG(I,IQ(NP)) = ELONG(I,IQ(NP)) * + MAX( 0.D0, (EFRST-(LPCT1-1-I)*EDEPB) ) ENDDO ENDIF ELSE C ENERGY DEPOSIT FOR HORIZONTALLY MOVING PARTICLES IN FIRST BIN #if __THIN__ DLONG(LPCT1,2) = DLONG(LPCT1,2) + EDEP * 1.D-3 * WT(NP) ELONG(LPCT1,IQ(NP)) = ELONG(LPCT1,IQ(NP)) * + EFRST - EDEP * 1.D-3 * WT(NP) #else DLONG(LPCT1,2) = DLONG(LPCT1,2) + EDEP * 1.D-3 ELONG(LPCT1,IQ(NP)) = ELONG(LPCT1,IQ(NP)) * + EFRST - EDEP * 1.D-3 #endif ENDIF #endif #if __SLANT__ ELSE C WE ARE AT END OF LONGITUDINAL DISTRIBUTION C FILL ALL IONIZATION ENERGY INTO LAST BIN #if __THIN__ DLONG(NSTEP+1,2) = DLONG(NSTEP+1,2) + EDEP * 1.D-3 * WT(NP) #else DLONG(NSTEP+1,2) = DLONG(NSTEP+1,2) + EDEP * 1.D-3 #endif #endif C END LONGITUDINAL DISTRIBUTION FILLING ENDIF ENDIF #if __PARALLEL__ ENDIF #endif C SKIP TO FIRST INTERACTION TREATMENT IF ( .NOT. FNPRIM ) THEN IF ( FIX1I .AND. FIXHEI .GT. -Z(1) ) THEN Z(1) = -FIXHEI IDISC = 0 GOTO 498 ENDIF ENDIF DNEAR(NP) = DNEAR(NP)-VSTEP IROLD = IR(NP) C NOW ADD ANGLE OF MULTIPLE SCATTERING (SEE ALSO SUBR. UPHI) CALL RMMARD( RD,1,2 ) PHI = RD(1) * TWOPI SINPHI = SIN( PHI ) COSPHI = COS( PHI ) A = U(NP) B = V(NP) CC = W(NP) SINPS2 = A**2+B**2 IF ( SINPS2 .LT. 1.D-20 ) THEN U(NP) = SINTHE*COSPHI V(NP) = SINTHE*SINPHI W(NP) = CC*COSTHE ELSE SINPSI = SQRT( SINPS2 ) US = SINTHE*COSPHI VS = SINTHE*SINPHI SINDEL = B*(1.D0/SINPSI) COSDEL = A*(1.D0/SINPSI) U(NP) = CC*COSDEL*US-SINDEL*VS+A*COSTHE V(NP) = CC*SINDEL*US+COSDEL*VS+B*COSTHE W(NP) = (-SINPSI)*US+CC*COSTHE ENDIF C UPDATE ENERGY PEIE = PEIE-EDEP E(NP) = PEIE IF ( PEIE .LE. ECUT(IRL) ) THEN IF ( FNPRIM ) GOTO 390 GOTO 498 ENDIF MEDOLD = MEDIUM IF ( MEDIUM .NE. 0 ) THEN C UPDATE KINETIC ENERGY EKEOLD = EKE EKE = PEIE-PRM ELKE = LOG( EKE ) LELKE = EKE1*ELKE+EKE0 ENDIF IF ( IDISC .GE. 0 ) THEN IF ( -Z(NP) .LT. BOUND(IRNEW) ) THEN IRNEW = IRNEW + 1 IF ( IRNEW .GE. 6 ) THEN C PARTICLE WILL REACH GROUND, TRANSPORT AND ELIMINATE AFTERWARDS IDISC = -2 ENDIF ELSEIF ( ( -Z(NP) .GT. BOUND(IRNEW-1) ) .OR. * ( ( -Z(NP) .EQ. BOUND(IRNEW-1) ) .AND. * ( W(NP) .LE. 0.003D0 ) ) ) THEN IRNEW = IRNEW - 1 IF ( IRNEW .LE. 1 ) THEN C PARTICLE WILL LEAVE ATMOSPHERE, TRANSPORT AND ELIMINATE AFTERWARDS IDISC = -2 ENDIF ENDIF ENDIF IF ( IRNEW .NE. IROLD ) THEN C LAYER HAS CHANGED IR(NP) = IRNEW IRL = IRNEW MEDIUM = MED(IRL) ENDIF C KILL UPWARD GOING PARTICLES IF ( W(NP) .LE. WCUT ) THEN IRETC = .FALSE. GOTO 420 ENDIF C LOOK FOR OBSERVATION LEVEL AND GIVE TO OUTPUT IF ( NEWOBS .GT. IOBS(NP) ) THEN #if __PARALLEL__ C IF NOTHING STORED IN 2ND STACK TRACKING AGAIN PRIMARY PARTICLE IF ( FNPRIM .OR. JCOUNT .LE. 1 ) THEN #endif CALL AUSGAB #if __PARALLEL__ ENDIF #endif IOBS(NP) = NEWOBS #if __UPWARD__ ELSEIF ( NEWOBS .LT. IOBS(NP) ) THEN IOBS(NP) = NEWOBS #if __PARALLEL__ C IF NOTHING STORED IN 2ND STACK TRACKING AGAIN PRIMARY PARTICLE IF ( FNPRIM .OR. JCOUNT .LE. 1 ) THEN #endif CALL AUSGAB #if __PARALLEL__ ENDIF #endif #endif ENDIF #if __CURVED__ IF ( TIM(NP) .GT. TIMLIM ) THEN C CHECK WHETHER PARTICLE EXCEEDS TIME LIMIT IF ( DEBUG .OR. LTMLMPR ) WRITE(MDEBUG,570) IRETC = .FALSE. GOTO 420 ENDIF #endif IF ( IDISC .LT. 0 ) THEN IRETC = .TRUE. IF ( FNPRIM ) THEN #if __UPWARD__ C ADD ENERGY OF PARTICLE LEAVING THE ATMOSPHERE TO DLONG C AND JUMP TO END OF ROUTINE IF ( IDISC .EQ. -2 ) GOTO 420 #endif C AS WE HAVE ADDED PARTICLE ENERGY TO DLONG IN OUTPT1, DON''T C ADD IT HERE AND JUMP TO END OF ROUTINE GOTO 421 ENDIF GOTO 498 ENDIF IF ( MEDIUM .NE. MEDOLD ) GOTO 401 DEMFP = MAX( 0.D0, DEMFP-TVSTEP*SIG ) C SKIP BACK IF STEP LENGTH NOT YET TOTALLY EXHAUSTED IF ( DEMFP .GE. 1.D-10 ) GOTO 451 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. IF ( LELEC .LT. 0 ) THEN SIGF = ESIG1(LELKE)*ELKE+ESIG0(LELKE) ELSE SIGF = PSIG1(LELKE)*ELKE+PSIG0(LELKE) ENDIF CALL RMMARD( RD,1,2 ) IF ( RD(1) .GT. SIGF/SIG0 ) GOTO 401 498 CONTINUE IF ( .NOT. FNPRIM ) THEN C DETERMINE THE ALTITUDE OF THE FIRST INTERACTION IF ( .NOT. TMARGIN ) THEN X(1) = 0.D0 Y(1) = 0.D0 #if !__CURVED__ U(1) = SECPAR(3) V(1) = -SECPAR(4) W(1) = SECPAR(2) #endif ENDIF IF ( FIX1I ) THEN C IF HEIGHT OF FIRST INTERACTION IS FIXED, TAKE STARTING ANGLES OF C PRIMARY PARTICLE Z(1) = -FIXHEI NP = 1 #if !__CURVED__ && __SLANT__ AUXIL1 = X(1)*STHCPH - Y(1)*STHSPH + Z(1)*CTH + RLOFF TSLAN(1) = THCKSI( AUXIL1 ) LPCTE(1) = MIN( NSTEP+1, INT( TSLAN(1)*THSTPI ) + 1 ) #else LPCTE(1) = MIN( NSTEP, INT( THICK( FIXHEI )*THSTPI ) + 1 ) #endif DNEAR(NP) = 0.D0 U(1) = SECPAR(3) V(1) = -SECPAR(4) W(1) = SECPAR(2) ENDIF #if __CURVED__ C CHECK CONSISTENCY OF COORDINATES IF ( .NOT. TMARGIN ) THEN CALL CORNEC ENDIF IF ( FIX1I ) THEN IF ( WA(1) .NE. 1.D0 ) THEN C WE ARE AWAY FROM DETECOR C CALCULATE AZIMUTH ANGLE OF PARTICLE SEEN FROM DETECTOR IF ( Y(1) .NE. 0.D0 .OR. X(1) .NE. 0.D0 ) THEN PHI1 = ATAN2( Y(1), X(1) ) ELSE PHI1 = 0.D0 ENDIF C HORIZONTAL DISTANCE OF PARTICLE TO DETECTOR RRR = SQRT( (1.D0-WA(NP))*(1.D0+WA(NP)) ) * * ( C(1) - ZAP(NP) ) / WA(NP) XXX = RRR * COS( PHI1 ) YYY = RRR * SIN( PHI1 ) ELSE C WE ARE IN THE DETECTOR SYSTEM AND NEED NO COORDINATE CALCULATION XXX = X(1) YYY = Y(1) ENDIF #if __SLANT__ AUXIL1 = XXX*STHCPH - YYY*STHSPH + ZAP(NP)*CTH + RLOFF TSLAN(1) = THCKSI( AUXIL1 ) LPCTE(1) = MIN( NSTEP+1, INT( TSLAN(1)*THSTPI ) + 1 ) #endif ENDIF C STORE COORDINATES IN THE DETECTOR SYSTEM XXXX(1) = XXX YYYY(1) = YYY #endif EVTH(6) = 0. IF ( TMARGIN ) THEN C NEGATIVE FIRST INTERACTION HEIGHT,IF TRACKING STARTS AT ATMOS. MARGIN EVTH(7) = Z(1) ELSE EVTH(7) = -Z(1) ENDIF C UPDATE PRMPAR PRMPAR(5) = -Z(1) PRMPAR(6) = TIM(1) #if __CURVED__ PRMPAR(14) = -ZAP(1) PRMPAR(16) = WA(1) PRMPAR(7) = XXXX(1) PRMPAR(8) = -YYYY(1) #else PRMPAR(7) = X(1) - XOFF(NOBSLV) PRMPAR(8) = -Y(1) - YOFF(NOBSLV) #endif #if __CERENKOV__ && __IACT__ CALL TELEVT( EVTH,PRMPAR ) #endif #if __COMPACT__ IF ( COMOUT ) THEN IF ( EVTH(2) .LT. 1.5 ) THEN CALL TOBUFS( EVTH,MAXBUF ) ELSE CEVTH = 'EVHW' CALL TOBUFS( EVTH,12 ) ENDIF ELSE CALL TOBUF( EVTH,0 ) ENDIF #else #if __PARALLEL__ C WREVTH SIGNALS THAT EVTH HAS BEEN WRITTEN OUT WREVTH = .TRUE. #endif CALL TOBUF( EVTH,0 ) #endif #if __CERENKOV__ C OUTPUT OF EVENTHEADER TO THE CHERENKOV FILE IF ( MCERFI .NE. 0 ) THEN DO I = 1, NCERBUF CALL TOBUFC( EVTH,0,I ) ENDDO ENDIF #endif #if __CERENKOV__ || __AUGCERLONG__ IF ( FDELAY .AND. IDELAY .GT. 0 ) THEN RUVW = SQRT(RUMEAN*RUMEAN+RVMEAN*RVMEAN+RWMEAN*RWMEAN) RUMEAN = RUMEAN / RUVW RVMEAN = RVMEAN / RUVW RWMEAN = RWMEAN / RUVW RCTEA = RCTEA / (1.D0*IDELAY) C ... Delayed Cherenkov emission, assuming particle mass, charge, and thinning C ... weight have not changed since the point of delay. CALL CERENK( RSTEP,RUMEAN,RVMEAN,RWMEAN,REBEG,REEND, * RXBEG,RYBEG,RZBEG,RXEND,RYEND,RZEND,RTBEG,RTEND, * PRM*1.D-3,1.D0*LELEC, #if __THIN__ * WT(NP),RCTEA ) #else * 1.D0,RCTEA ) #endif FDELAY = .FALSE. IDELAY = 0 ENDIF #endif #if __CURVED__ IF ( .NOT. TMARGIN ) THEN TIM(1) = 0.D0 ENDIF #else IF ( .NOT. TMARGIN ) THEN CALL COORIN( -Z(1) ) #if __AUGERHIST__ HEIGHTP = -Z(1) #endif TIM(1) = 0.D0 ENDIF #endif #if __THIN__ WT(1) = 1.D0 #endif FNPRIM = .TRUE. IF ( FPRINT ) THEN WRITE(KMPO,*)' FIRST INTERACTION AT ',ABS(EVTH(7)*0.01D0), * ' M ALTITUDE' ENDIF #if __ANAHIST__ C DETERMINE PARAMETERS OF THE SHOWER FRONT FOR HISTOGRAMS CALL SHOWERFRONT #endif C FILL CURPAR TO UPDATE PRMPAR AFTER BOX3 CALL FOR PRIMARY PARTICLE DO I = 5, 8 CURPAR(I) = PRMPAR(I) ENDDO #if __CURVED__ CURPAR(14) = PRMPAR(14) CURPAR(16) = PRMPAR(16) #endif #if __PARALLEL__ C RETURN BEFORE INTERACTION IF ( JCOUNT .GT. 1 ) THEN NP = 0 !RESET PARTICLE INDEX IRCODE = 3 FEGSDB = .false. RETURN ENDIF #endif IF ( PEIE .LE. ECUT(IRL) ) GOTO 390 IF ( IDISC .LT. 0 ) THEN C OBVIOUSLY THE PRIMARY HAS PASSED THROUGH TOTAL ATMOSPHERE. #if __UPWARD__ C ADD ENERGY OF PARTICLE LEAVING THE ATMOSPHERE TO DLONG C AND JUMP TO END OF ROUTINE IF ( IDISC .EQ. -2 ) GOTO 420 #endif C AS WE HAVE ADDED PARTICLE ENERGY TO DLONG IN OUTPT1, DON''T C ADD IT HERE AND JUMP TO END OF ROUTINE GOTO 421 ENDIF ENDIF C NOW SAMPLE ELECTRON INTERACTION, LOOK FOR BRANCHING RATIOS IF ( LELEC .LT. 0 ) THEN C THIS RANDOM NUMBER DETERMINES WHICH INTERACTION OF ELECTRON CALL RMMARD( RD,1,2 ) EBR2 = EBR21(LELKE)*ELKE+EBR20(LELKE) IF ( RD(1) .GE. EBR2 ) THEN C MAKE BREMSSTRAHLUNG GOTO 500 ENDIF EBR1 = EBR11(LELKE)*ELKE+EBR10(LELKE) IF ( RD(1) .GE. EBR1 ) THEN IF ( E(NP) .LE. THMOLL ) THEN IF ( EBR1 .LE. 0.D0 ) GOTO 380 GOTO 500 ENDIF C MOLLER SCATTERING CALL MOLLER #if __THIN__ EKENP = E(NP) - PRM IF ( EKENP .LT. ETHINN ) THEN EKENP1 = E(NP-1) - PRM EKE = PEIE - PRM CALL THIN( EKE,EKENP1,EKENP ) ENDIF #endif #if __MULTITHIN__ EKENP = E(NP) - PRM EKENP1 = E(NP-1) - PRM EKE = PEIE - PRM CALL THIN2( EKE,EKENP1,EKENP ) #endif C ELECTRON IS LOWEST ENERGY - FOLLOW IT GOTO 380 ELSE C ELECTRONUCLEAR INTERACTION IF ( E(NP) .LT. MAX(ELCUT(4)*1.D3,PITHR) ) GOTO 500 CALL ELNUCL GOTO 380 ENDIF ENDIF C THIS RANDOM NUMBER DETERMINES WHICH INTERACTION OF POSITRON CALL RMMARD( RD,1,2 ) PBR3 = PBR31(LELKE)*ELKE+PBR30(LELKE) IF ( RD(1) .GE. PBR3 ) THEN C BREMSSTRAHLUNG GOTO 500 ENDIF PBR2 = PBR21(LELKE)*ELKE+PBR20(LELKE) IF ( RD(1) .GE. PBR2 ) THEN C BHABHA SCATTERING CALL BHABHA #if __THIN__ IF ( IQ(NP) .EQ. 2 ) THEN EKENP = E(NP) + PRM EKENP1 = E(NP-1) - PRM ELSE EKENP = E(NP) - PRM EKENP1 = E(NP-1) + PRM ENDIF IF ( EKENP .LT. ETHINN ) THEN EKE = PEIE + PRM CALL THIN( EKE,EKENP1,EKENP ) ENDIF #endif #if __MULTITHIN__ IF ( IQ(NP) .EQ. 2 ) THEN EKENP = E(NP) + PRM EKENP1 = E(NP-1) - PRM ELSE EKENP = E(NP) - PRM EKENP1 = E(NP-1) + PRM ENDIF EKE = PEIE + PRM CALL THIN2( EKE,EKENP1,EKENP ) #endif GOTO 380 ENDIF PBR1 = PBR11(LELKE)*ELKE+PBR10(LELKE) IF ( RD(1) .GE. PBR1 ) THEN C ANNIHILATION CALL ANNIH #if __THIN__ EKENP = E(NP) IF ( EKENP .LT. ETHINN ) THEN EKENP1 = E(NP-1) EKE = PEIE + PRM CALL THIN( EKE,EKENP1,EKENP ) ENDIF #endif #if __MULTITHIN__ EKENP = E(NP) EKENP1 = E(NP-1) EKE = PEIE + PRM CALL THIN2( EKE,EKENP1,EKENP ) #endif RETURN ELSE C ELECTRONUCLEAR INTERACTION IF ( E(NP) .LT. MAX(ELCUT(4)*1.D3,PITHR) ) GOTO 500 CALL ELNUCL GOTO 380 ENDIF 500 CONTINUE C BREMSSTRAHLUNG #if __THIN__ CALL BREMSLPM( FPASS ) IF ( FPASS ) GOTO 380 IF ( IQ(NP-1) .EQ. 3 ) THEN EKENP1 = E(NP-1) - PRM EKENP = E(NP) EKE = PEIE - PRM ELSEIF ( IQ(NP-1) .EQ. 2 ) THEN EKENP1 = E(NP-1) + PRM EKENP = E(NP) EKE = PEIE + PRM ELSE IF ( IQ(NP) .EQ. 3 ) THEN EKENP = E(NP) - PRM EKENP1 = E(NP-1) EKE = PEIE - PRM ELSE EKENP = E(NP) + PRM EKENP1 = E(NP-1) EKE = PEIE + PRM ENDIF ENDIF IF ( EKENP .LT. ETHINN ) THEN CALL THIN( EKE,EKENP1,EKENP ) ENDIF #else #if __LPM__ || __PARALLEL__ || __MULTITHIN__ CALL BREMSLPM( FPASS ) IF ( FPASS ) GOTO 380 #else CALL BREMS #endif #endif #if __MULTITHIN__ IF ( IQ(NP-1) .EQ. 3 ) THEN EKENP1 = E(NP-1) - PRM EKENP = E(NP) EKE = PEIE - PRM ELSEIF ( IQ(NP-1) .EQ. 2 ) THEN EKENP1 = E(NP-1) + PRM EKENP = E(NP) EKE = PEIE + PRM ELSE IF ( IQ(NP) .EQ. 3 ) THEN EKENP = E(NP) - PRM EKENP1 = E(NP-1) EKE = PEIE - PRM ELSE EKENP = E(NP) + PRM EKENP1 = E(NP-1) EKE = PEIE + PRM ENDIF ENDIF CALL THIN2( EKE,EKENP1,EKENP ) #endif IF ( IQ(NP) .EQ. 1 ) THEN C GAMMA ON TOP OF STACK RETURN ELSE C ELECTRON ON TOP OF STACK GOTO 380 ENDIF C ENERGY DEPOSIT FOR ELECTRON BELOW ENERGY CUT 390 IF ( PEIE .GT. AE ) THEN IDR = 1 IF ( LELEC .LT. 0 ) THEN EDEP = PEIE-PRM ELSE EDEP = PEIE-PRM ENDIF ELSE IDR = 2 EDEP = PEIE-PRM ENDIF IF ( LLONGI ) THEN C CUTTED ENERGY TO LONGITUDINAL ENERGY SUMS [IN GEV] #if __THIN__ DLONG(LPCTE(NP),3) = DLONG(LPCTE(NP),3) + EDEP*1.D-3*WT(NP) #else DLONG(LPCTE(NP),3) = DLONG(LPCTE(NP),3) + EDEP*1.D-3 #endif ENDIF #if __AUGERHIST__ E(NP) = 0.D0 DO LL = 1, NOBSLV C LOOK WHETHER DEPOSIT IS WITHIN 1 G/CM^2 BELOW OBSERVATION LEVEL IF ( -Z(NP) .LE. OBSLVL(LL) .AND. * -Z(NP) .GT. OBSLV2(LL) ) THEN VONWO = 'ELECTR1' CALL AUGECT( EDEP,LL,VONWO ) ELSEIF ( -Z(NP) .GT. OBSLVL(LL) ) THEN GOTO 111 ENDIF ENDDO 111 CONTINUE #endif IF ( LELEC .GT. 0 ) THEN C IT''S A POSITRON. PRODUCE ANNIHILATION GAMMAS IF EDEP < PEI IF ( EDEP .LT. PEIE ) THEN CALL RMMARD( RD,2,2 ) COSTHE = RD(1) FLIP = RD(2) IF ( FLIP .LE. 0.5D0 ) COSTHE = -COSTHE SINTHE = SQRT( MAX( 0.D0, (1.0-COSTHE)*(1.0+COSTHE) ) ) E(NP) = PRM IQ(NP) = 1 U(NP) = 0.D0 V(NP) = 0.D0 W(NP) = 1.D0 C UPHI WILL PICK RANDOM AZIMUTHAL ANGLE CALL UPHI( 2,1 ) NP = NP+1 E(NP) = PRM IQ(NP) = 1 X(NP) = X(NP-1) Y(NP) = Y(NP-1) Z(NP) = Z(NP-1) LPCTE(NP) = LPCTE(NP-1) IR(NP) = IR(NP-1) DNEAR(NP) = DNEAR(NP-1) TIM(NP) = TIM(NP-1) IGEN(NP) = IGEN(NP-1) IOBS(NP) = IOBS(NP-1) C SECOND GAMMA IN OPPOSITE DIRECTION U(NP) = -U(NP-1) V(NP) = -V(NP-1) W(NP) = -W(NP-1) #if __THIN__ WT(NP) = WT(NP-1) #endif #if __CURVED__ ZAP(NP) = ZAP(NP-1) WAP(NP) = WAP(NP-1) WA(NP) = WA(NP-1) XXXX(NP) = XXXX(NP-1) YYYY(NP) = YYYY(NP-1) #endif #if __SLANT__ TSLAN(NP) = TSLAN(NP-1) #endif RETURN ENDIF ENDIF NP = NP-1 IRCODE = 2 RETURN C ELECTRON IS ELEMINATED BECAUSE OF CUT 420 IF ( LELEC .LT. 0 ) THEN EDEP = PEIE-PRM ELSE EDEP = PEIE+PRM ENDIF IF ( LLONGI ) THEN C CUTTED ENERGY TO LONGITUDINAL ENERGY SUMS [IN GEV] IF ( IRETC ) THEN C ENERGY CUT #if __THIN__ DLONG(LPCTE(NP),3) = DLONG(LPCTE(NP),3) + EDEP*1.D-3*WT(NP) ELSE C ANGULAR CUT DLONG(LPCTE(NP),13) = DLONG(LPCTE(NP),13) + EDEP*1.D-3*WT(NP) #else DLONG(LPCTE(NP),3) = DLONG(LPCTE(NP),3) + EDEP*1.D-3 ELSE C ANGULAR CUT DLONG(LPCTE(NP),13) = DLONG(LPCTE(NP),13) + EDEP*1.D-3 #endif ENDIF ENDIF #if __AUGERHIST__ E(NP) = 0.D0 IF ( IRETC ) THEN C ELECTRON BELOW ENERGY CUT DO LL = 1, NOBSLV-1 C LOOK WHETHER DEPOSIT IS WITHIN 1 G/CM^2 BELOW OBSERVATION LEVEL IF ( -Z(NP) .LE. OBSLVL(LL) .AND. * -Z(NP) .GT. OBSLV2(LL) ) THEN VONWO = 'ELECTR2' CALL AUGECT( EDEP,LL,VONWO ) ELSEIF ( -Z(NP) .GT. OBSLVL(LL) ) THEN GOTO 112 ENDIF ENDDO 112 CONTINUE ELSE C ELECTRON BELOW ANGULAR CUT DO LL = 1, NOBSLV C LOOK WHETHER DEPOSIT IS WITHIN 1 G/CM^2 BELOW OBSERVATION LEVEL IF ( -Z(NP) .LE. OBSLVL(LL) .AND. * -Z(NP) .GT. OBSLV2(LL) ) THEN VONWO = 'ELECTR3' CALL AUGACT( EDEP,LL,VONWO ) ELSEIF ( -Z(NP) .GT. OBSLVL(LL) ) THEN GOTO 113 ENDIF ENDDO 113 CONTINUE ENDIF #endif 421 CONTINUE IRCODE = 2 NP = NP-1 RETURN END *-- Author : D. HECK IK FZK KARLSRUHE 01/09/2004 C======================================================================= SUBROUTINE ELNUCL C----------------------------------------------------------------------- C EL(ECTRONS AND POSITRONS) NUCL(EAR INTERACTION) C C TREATS THE ELECTRON/POSITRON NUCLEAR INTERACTION C IN ANALOGY WITH SUBR. MUNUCL. C ENERGY UNITS IN THIS ROUTINE ARE GEV. C THIS SUBROUTINE IS CALLED FROM ELECTR. C----------------------------------------------------------------------- IMPLICIT NONE #define __AIRINC__ #define __EGSDEBINC__ #define __ELABCTINC__ #define __PAMINC__ #define __PIONINC__ #define __RANDPAINC__ #define __RUNPARINC__ #define __STACKEINC__ #define __UPHIOTINC__ #include "corsika.h" 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) PARAMETER (ELE1 = 0.0808D0) PARAMETER (ELE2 = -0.4525D0) DOUBLE PRECISION ARGO,AUXIL1,BPH,COEF,COEF1,CPH,DPH, * EE,EKIN,EPH,E1,FACTO,FPH,GG,GMAX,GMIN,HHH, * OB3,SS,SIGN,SNI,SNIMAX,SNIMIN, * TTT,VPH,VPH1,VPH2,ZZZ INTEGER KCOUNT SAVE DATA OB3 / 0.333333333333333D0 / C----------------------------------------------------------------------- IF (FEGSDB) THEN WRITE(MDEBUG,2) NP,IR(NP),IOBS(NP) 2 FORMAT(' ELNUCL: NP=',I3,' IR=',I3,' IOBS=',I3) CALL AUSGB2 ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) 'ELNUCL: E=',E(NP)*.001D0 C TOTAL AND KINETIC ENERGY OF ELECTRON C CONVERT MEV TO GEV EE = E(NP) * 0.001D0 EKIN = EE - PAMA(2) IF ( EKIN .LE. ELCUT(3) ) THEN C ELECTRON IS KEPT UNCHANGED IN THE EGS STACK RETURN ENDIF C SAMPLE THE ENERGY FRACTION SNI OF VIRTUAL GAMMA C LIMITS FOR VIRTUAL GAMMA''S ENERGY ARE SNIMIN AND SNIMAX SNIMIN = ( PAMA(8) + 0.5D0*PAMA(8)**2/PAMA(14) )/EE SNIMAX = 1.D0 - ( PAMA(14) + PAMA(2)**2/PAMA(14) ) * 0.5D0/EE C USE FOR SAMPLING A FUNCTION WHICH IS SOMEWHAT LARGER, BUT C CAN BE INTEGRATED AND THE INTEGRAL CAN BE INVERTED. C AFTERWARDS CORRECT SAMPLING IS DONE BY REJECTION TECHNIQUE 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))) * * AVERAW/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))) * * AVERAW/22.D0 ENDIF COEF1 = COEF + 1.D0 GMIN = FACTO/COEF1 * SNIMIN**COEF1 GMAX = FACTO/COEF1 * SNIMAX**COEF1 KCOUNT = 0 1 CONTINUE KCOUNT = KCOUNT + 1 IF ( KCOUNT .GT. 1000 ) THEN C KEEP ELECTRON UNCHANGED IN EGS STACK RETURN ENDIF CALL RMMARD( RD,2,1 ) 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 = PAMA(2)**2 * SNI**2 / (1.D0 - SNI) C SS IS ENERGY**2 IN CM SYSTEM, EE IS TOTAL ENERGY OF INCOMING ELECTRON SS = 2.D0 * PAMA(14) * 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 C AND: CUDELL ET AL., PHYS. REV. D61 (2000) 034019 SIGN = 59.3D0 * SS**0.093D0 + 120.2D0 * SS**(-0.358D0) C SCALE THE CROSS-SECTION WITH ATOMIC NUMBER ZZZ = SIGN * APH * AVERAW**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 = AVERAW * SNI * SIGN * (ALPHFA/(8.D0*PI)) C AUXILIARY QUANTITIES CPH = 1.D0 + AM21/TTT DPH = 1.D0 + AM22/TTT EPH = 2.D0 * PAMA(2)**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 * PAMA(2)**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 IF ( SNI * EE .LT. PITHR*1.D-3 ) GOTO 1 C ENERGY OF RESIDUAL ELECTRON E1 = EE * (1.D0 - SNI) C CONVERSION GEV TO MEV E(NP) = E1 * 1.D3 C COSTHE IS SET TO 1 (FORWARD MOVEMENT WITHOUT TRANSVERSE MOMENTUM) COSTHE = 1.D0 SINTHE = 0.D0 CALL UPHI( 2,1 ) C ELECTRON IS KEPT IN EGS4 STACK, EVEN IF IT IS BELOW THRESHOLD C IT WILL BE TREATED CORRECTLY IN SUBR. ELECTR. C NOW FILL VIRTUAL GAMMA AS REAL GAMMA INTO EGS STACK NP = NP + 1 IQ(NP) = 1 C CONVERSION GEV TO MEV E(NP) = EE * SNI * 1.D3 COSTHE = 1.D0 SINTHE = 0.D0 CALL UPHI( 3,2 ) C TREAT THE PHOTONUCLEAR INTERACTION BY PIGEN C INCREASE OF HADRONIC GENERATION IS DONE IN PIGEN C SUBTRACTION OF ENERGY OF VIRTUAL GAMMA FROM THE NKG IS DONE IN PIGEN CALL PIGEN( .TRUE. ) C ALL SECONDARIES ARE WRITTEN TO STACK AND TSTEND WAS CALLED IN PIGEN RETURN END *-- Author : STANFORD LINEAR ACCELERATOR CENTER C======================================================================= C STANFORD LINEAR ACCELERATOR CENTER SUBROUTINE HATCH C VERSION 4.00 -- 26 JAN 1986/1900 C----------------------------------------------------------------------- C HATCH (THE CROSS-SECTION FILE) 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 GAMMA 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 THIS SUBROUTINE IS CALLED FROM EGSIN2. C----------------------------------------------------------------------- IMPLICIT NONE #define __BOUNDSINC__ #define __BREMPRINC__ #define __ELECININC__ #define __MEDIAINC__ #define __MEDIACINC__ #define __MISCINC__ #define __PHOTININC__ #define __RANDPAINC__ #define __RUNPARINC__ #define __STACKEINC__ #define __THRESHINC__ #define __UPHIOTINC__ #define __USEFULINC__ #include "corsika.h" DOUBLE PRECISION DFACT,DFACTI,DUNITR,DUNITO,P INTEGER I,IB,IE,IL,IM,IRAYL,I1ST,JR,LMDL,LMDN,LOK,MD, * NCMFP,NE,NEKE,NGE,NGRIM,NLEKE,NM,NRANGE, * NSEKE,NSGE CHARACTER MBUF*72,MDLABL*8 SAVE DATA MDLABL / ' MEDIUM=' /, LMDL / 8 /, LMDN / 24 / DATA DUNITO / 1.D0 /, I1ST / 1 / C----------------------------------------------------------------------- 510 FORMAT(1X,14I5) 520 FORMAT(1X,1P,5E14.5) 530 FORMAT(A72) IF ( I1ST .NE. 0 ) THEN I1ST = 0 C NOW FILL IN POWER OF TWO TABLE. PWR2I(I)=1/2**(I-1) P = 1.D0 DO I = 1, 60 PWR2I(I) = P P = P*.5D0 ENDDO ENDIF C FILL IRAYLM ARRAY BASED ON IRAYLR INPUTS DO IM = 1, NMED DO I = 1, 6 IF ( IRAYLR(I) .EQ. 1 .AND. MED(I) .EQ. IM ) THEN C REGION I = MEDIUM IM AND WE WANT RAYLEIGH SCATTERING, SO C SET FLAG TO PICK UP DATA FOR MEDIUM IM AND TRY NEXT MEDIUM. IRAYLM = 1 GOTO 672 ENDIF ENDDO 672 CONTINUE ENDDO C NOW SEARCH FILE FOR DATA FOR REQUESTED MATERIALS REWIND KMPI NM = 0 DO IM = 1, NMED LOK = 0 IF ( IRAYLM .EQ. 1 ) THEN WRITE(KMPO,690) IM 690 FORMAT(' RAYLEIGH OPTION REQUESTED FOR MEDIUM NUMBER',I3,/) ENDIF ENDDO 701 CONTINUE C MEDIUM HEADER SEARCH LOOP, FIRST LOOK FOR MEDIUM HEADER READ(KMPI,530,END=720) MBUF DO IB = 1, LMDL IF ( MBUF(IB:IB) .NE. MDLABL(IB:IB) ) GOTO 701 ENDDO C HEADER MATCHES. NOW SEE IF IT IS ONE OF REQUESTED MEDIA DO 741 IM = 1, NMED DO IB = 1, LMDN IL = LMDL+IB IF ( MBUF(IL:IL) .NE. MEDIA(IB:IB) ) GOTO 741 IF ( IB .EQ. LMDN ) GOTO 712 ENDDO 741 CONTINUE GOTO 701 712 CONTINUE C 'IM' IS THE INDEX OF THE MEDIUM READY TO BE READ IF ( LOK .NE. 0 ) GOTO 701 LOK = 1 NM = NM+1 C NOW READY TO READ IN DATA FOR THIS MEDIUM WRITE(KMPO,760) IM,MBUF 760 FORMAT(' DATA FOR MEDIUM #',I3,', WHICH IS:',A72) READ(KMPI,770) (MBUF(I:I),I=1,5),RHO,NE 770 FORMAT(5A1,5X,F11.0,4X,I2) WRITE(KMPO,780) (MBUF(I:I),I=1,5),RHO,NE 780 FORMAT(5A1,',RHO=',1P,G11.4, ',NE=',I2,',COMPOSITION IS :') DO IE = 1, NE READ(KMPI,530) MBUF WRITE(KMPO,530) MBUF ENDDO C MEDIA AND THRESH READ(KMPI,520)RLC,AE,AP,UE,UP TE = AE-PRM THMOLL = TE*2.D0 + PRM C ACTUAL ARRAY SIZES FROM PEGS READ(KMPI,510)MSGE,MGE,MSEKE,MEKE,MLEKE,MCMFP,MRANGE,IRAYL NSGE = MSGE NGE = MGE NSEKE = MSEKE NEKE = MEKE NLEKE = MLEKE NCMFP = MCMFP NRANGE = MRANGE C BREMPR READ(KMPI,520) (DL1(I),DL2(I),DL3(I),DL4(I),DL5(I),DL6(I),I=1,6) READ(KMPI,520) DELCM,(ALPHI(I),BPAR(I),DELPOS(I),I=1,2) C ELECIN READ(KMPI,520) XR0,TEFF0,BLCC,XCC READ(KMPI,520) EKE0,EKE1 READ(KMPI,520) (ESIG0(I),ESIG1(I),PSIG0(I),PSIG1(I),EDEDX0(I), * EDEDX1(I),PDEDX0(I),PDEDX1(I), * EBR10(I),EBR11(I),EBR20(I),EBR21(I), * PBR10(I),PBR11(I),PBR20(I),PBR21(I),PBR30(I),PBR31(I), * TMXS0(I),TMXS1(I),I=1,NEKE) C PHOTIN READ(KMPI,520) EBINDA,GE0,GE1 READ(KMPI,520) (GMFP0(I),GMFP1(I),GBR10(I),GBR11(I),GBR20(I), * GBR21(I),GBR30(I),GBR31(I),GBR40(I),GBR41(I),I=1,NGE) IF ( IRAYLM .EQ. 1 .AND. IRAYL .NE. 1 ) THEN WRITE(KMPO,800) IM 800 FORMAT(' STOPPED IN HATCH: REQUESTED RAYLEIGH OPTION FOR MEDIUM' * ,I3,/,' BUT RAYLEIGH DATA NOT INCLUDED IN DATA CREATED BY PEGS.' * ) STOP ENDIF IF ( IRAYL .EQ. 1 ) THEN READ(KMPI,510) NGR NGRIM = NGR READ(KMPI,520) RCO0,RCO1 READ(KMPI,520) (RSCT0(I),RSCT1(I),I=1,NGRIM) READ(KMPI,520) (COHE0(I),COHE1(I),I=1,NGE) IF ( IRAYLM .NE. 1 ) THEN WRITE(KMPO,810) IM 810 FORMAT(' RAYLEIGH DATA AVAILABLE FOR MEDIUM',I3,' BUT OPTION', * ' NOT REQUESTED.',/) ENDIF ENDIF C THAT''S ALL FOR THIS MEDIUM IF ( NM .LT. NMED ) GOTO 701 C WE NOW HAVE DATA FOR ALL MEDIA REQUESTED. NOW DO DISTANCE UNIT C CHANGE. DATA FROM PEGS IS IN UNITS OF RADIATION LENGTHS. EGS IS C RUN IN UNITS OF 'DUNIT' CENTIMETERS, IF DUNIT.GT.0 OR IN UNITS OF C RLC(-DUNIT) CENTIMETERS IF DUNIT.LT.0. THAT IS, A NEGATIVE DUNIT C MEANS UNIT IS TO BE THE RADIATION LENGTH OF THE MEDIUM WHOSE INDEX C IS -DUNIT DUNITR = DUNIT IF ( DUNIT .LT. 0.D0 ) THEN MD = MAX( 1,MIN( 1,INT( -DUNIT ) ) ) DUNIT = RLC ENDIF IF ( DUNIT .NE. 1.D0 ) THEN WRITE(KMPO,820) DUNITR,DUNIT 820 FORMAT(' DUNIT REQUESTED&USED ARE:',1P,2E14.5,'(CM.)') ENDIF DO IM = 1, NMED C CONVERTS RADIATION LENGTH TO DUNITS DFACT = RLC/DUNIT C CONVERTS (RADIATION LENGTH)**-1 TO DUNITS**-1 DFACTI = 1.D0/DFACT I = 1 GOTO 843 841 CONTINUE I = I+1 843 CONTINUE IF ( I-(MEKE) .GT. 0 ) GOTO 842 ESIG0(I) = ESIG0(I)*DFACTI ESIG1(I) = ESIG1(I)*DFACTI PSIG0(I) = PSIG0(I)*DFACTI PSIG1(I) = PSIG1(I)*DFACTI EDEDX0(I) = EDEDX0(I)*DFACTI EDEDX1(I) = EDEDX1(I)*DFACTI PDEDX0(I) = PDEDX0(I)*DFACTI PDEDX1(I) = PDEDX1(I)*DFACTI TMXS0(I) = TMXS0(I)*DFACT TMXS1(I) = TMXS1(I)*DFACT GOTO 841 842 CONTINUE I = 1 GOTO 853 851 CONTINUE I = I+1 853 CONTINUE IF ( I-(MLEKE) .GT. 0 ) GOTO 852 ERANG0(I) = ERANG0(I)*DFACT ERANG1(I) = ERANG1(I)*DFACT PRANG0(I) = PRANG0(I)*DFACT PRANG1(I) = PRANG1(I)*DFACT GOTO 851 852 CONTINUE TEFF0 = TEFF0*DFACT BLCC = BLCC*DFACTI XCC = XCC*SQRT( DFACTI ) RLDU = RLC/DUNIT RLDUI = 1.D0/RLDU I = 1 GOTO 863 861 CONTINUE I = I+1 863 CONTINUE IF ( I-(MGE) .GT. 0 ) GOTO 862 GMFP0(I) = GMFP0(I)*DFACT GMFP1(I) = GMFP1(I)*DFACT GOTO 861 862 CONTINUE ENDDO C SCALE VACDST. UNDO PREVIOUS SCALE, THEN DO NEW. VACDST = VACDST*DUNITO/DUNIT C SAVE OLD DUNIT DUNITO = DUNIT C NOW MAKE SURE ECUT AND PCUT ARE NOT LOWER THAN ANY AE OR AP C ALSO SET DEFAULT DENSITIES DO JR = 1, 6 MD = MED(JR) IF ( (MD .GE. 1) .AND. (MD .LE. NMED) ) THEN ECUT(JR) = MAX(ECUT(JR),DBLE(AE),DBLE(AP+1.D0*PRM)) PCUT(JR) = MAX(PCUT(JR),DBLE(AP)) C USE STANDARD DENSITY FOR REGIONS NOT SPECIALLY SET UP IF ( RHOR(JR) .EQ. 0.D0 ) RHOR(JR) = RHO ENDIF ENDDO C SETUP IS NOW COMPLETE IF ( NMED .EQ. 1 ) THEN WRITE(KMPO,880) 880 FORMAT(' EGS SUCCESSFULLY ''HATCHED'' FOR ONE MEDIUM.') ELSE WRITE(KMPO,890) NMED 890 FORMAT(' EGS SUCCESSFULLY ''HATCHED'' FOR ',I5,' MEDIA.') ENDIF RETURN 720 WRITE(KMPO,900) KMPI 900 FORMAT(' END OF FILE ON UNIT ',I2,/,/,' PROGRAM STOPPED IN HATCH', * ' BECAUSE THE',/,' FOLLOWING NAMES WERE NOT RECOGNIZED:',/) DO IM = 1, NMED IF ( LOK .NE. 1 ) THEN WRITE(KMPO,920) (MEDIA(I:I),I=1,LMDN) 920 FORMAT(40X,'''',24A1,'''') ENDIF ENDDO STOP END *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE HOWFAR( IRETE ) C----------------------------------------------------------------------- C HOW FAR (COMES THE PARTICLE) C THE FOLLOWING IS A GENERAL SPECIFICATION OF HOWFAR: 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 OR OBSERVATION LEVEL? C IF YES, IT CALCULATES DNEAR AND RETURNS. C IF NO, IT SETS USTEP=DISTANCE TO BOUNDARY OR DETECTOR IN C IN THE CURRENT DIRECTION. C IT SETS IRNEW TO THE REGION NUMBER ON THE FAR SIDE C OF THE BOUNDARY (THIS CAN BE MESSY IN GENERAL!); C IT SETS NEWOBS TO THE DETECTOR NUMBER NEXT AFTER THE C DETECTOR JUST PASSING. C IDISC = +1 TERMINATES A HISTORY IMMEDIATELY C IDISC = -1 TRANSPORTS PARTICLE AND TERMINATES IT AFTER TRANSPORT C (OBSERVATION LEVEL) C IDISC = -2 TRANSPORTS PARTICLE AND TERMINATES IT AFTER TRANSPORT C (ATMOSPHERIC BOUND) C HERE WE TRANSPORT AND TERMINATE ALL PARTICLES WHICH ENTER C REGION 6 OR HAVE PASSED THE LAST OBSERVATION LEVEL. C********************************************************************* C ELECTRON OR GAMMA POSITIVE Z-DIRECTION (W>0) IS DOWNWARDS C | C | REGION 1 (VACUUM) C | IR = 1 C V C--------------------------- STARTING PLANE AT BOUND(1) = HEIGH(0) C C REGION 2 (AIR WITH EXPONENTIALLY C IR = 2 INCREASING DENSITY) C C--------------------------- BOUNDARY AT BOUND(2) = HLAY(4) C C REGION 3 (AIR WITH EXPONENTIALLY C IR = 3 INCREASING DENSITY) C C--------------------------- BOUNDARY AT BOUND(3) = HLAY(3) C C REGION 4 (AIR WITH EXPONENTIALLY C IR = 4 INCREASING DENSITY) C C--------------------------- BOUNDARY AT BOUND(4) = HLAY(2) C C REGION 5 (AIR WITH EXPONENTIALLY C IR = 5 INCREASING DENSITY) C C--SEA LEVEL---------------- BOUNDARY AT BOUND(5) = HLAY(1) C////////////|///////// C////////////|///////// REGION 6 (VACUUM) C////////////V///////// IR = 6 C ELECTRON OR GAMMA C--------------------------- BOUNDARY AT BOUND(6) = HLAY(1) -1. C C********************************************************************* C THIS SUBROUTINE IS CALLED FROM ELECTR AND PHOTON. C ARGUMENT: C IRETE = .TRUE. IF PARTICLE IS REJECTED BY ENERGY CUT C = .FALSE. IF PARTICLE IS REJECTED BY ANGLE CUT C----------------------------------------------------------------------- IMPLICIT NONE #define __EGSDEBINC__ #define __EPCONTINC__ #define __GEOMEGSINC__ #define __OBSPARINC__ #define __PARPARINC__ #define __RUNPARINC__ #define __STACKEINC__ #include "corsika.h" DOUBLE PRECISION TVAL INTEGER IRL,NOBS LOGICAL IRETE #if __CURVED__ DOUBLE PRECISION AUXIL,AUX3,BOUNDC,CEARTH,OBSGLOB, * XNEW,YNEW,ZB2,ZAPB2, * RADHOR,STEPMX,S2B,THICK,TOAXIS INTEGER IBFLAG EXTERNAL THICK #endif #if __UPWARD__ || __CURVED__ DOUBLE PRECISION AUX1,AUX2 #endif SAVE C----------------------------------------------------------------------- IF ( FEGSDB ) THEN WRITE(MDEBUG,1) NP,IR(NP),IOBS(NP),USTEP 1 FORMAT(' HOWFAR: NP=',I3,' IR=',I3,' IOBS=',I3,' USTEP=',G15.7) CALL AUSGB2 ENDIF IF ( IR(NP) .GT. 1 .AND. IR(NP) .LT. 6 ) THEN C WE ARE IN THE ATMOSPHERE - CHECK THE GEOMETRY IRL = IR(NP) C GOING FORWARD - CONSIDER FIRST SINCE MOST FREQUENT NOBS = IOBS(NP) #if __CURVED__ C STEPMX IS MAX HORIZONTAL STEP, BEFORE TRANSITION TO NEXT LOCAL C COORDINATE FRAME MUST BE PERFORMED RADHOR = MAX( U(NP)**2 + V(NP)**2, 0.001D0 ) AUXIL = C(4) * THICK( -Z(NP) ) + C(3) AUXIL = MAX( C(2), AUXIL ) STEPMX = AUXIL / SQRT( RADHOR ) C JUST SHORTEN USTEP IF ( FEGSDB ) WRITE(MDEBUG,*) 'HOWFAR: STEPMX,USTEP=', * SNGL(STEPMX),SNGL(USTEP) IF ( USTEP .GE. STEPMX ) USTEP = STEPMX C CHECK THE DIRECTION OF THE PARTICLE (TO THE AXIS OR NOT) AUXIL = X(NP)**2 + Y(NP)**2 XNEW = X(NP)+U(NP)*USTEP YNEW = Y(NP)+V(NP)*USTEP IF ( ( ABS(XNEW) .LT. ABS(X(NP)) .OR. XNEW * X(NP) .LE. 0.D0 ) * .AND. ( ABS(YNEW) .LT. ABS(Y(NP)) .OR. YNEW * Y(NP) .LE. 0.D0 ) * .OR. XNEW * XNEW + YNEW * YNEW .LT. AUXIL ) THEN TOAXIS = 1.D0 ELSE TOAXIS = -1.D0 C PRINT *,"NEW",X(NP),'->',XNEW,'|',Y(NP),'->',YNEW ENDIF C TVAL IS DISTANCE TO NEXT BOUNDARY OR OBSERVATION LEVEL IN THIS C DIRECTION. INTRODUCE 'GLOBAL OBSERVATION LEVEL' C (IN CURVED VERSION JUST ONE OBSERVATION LEVEL) C ANGLE OF LOCAL FRAME CEARTH = WA(NP) C HEIGHT OF OBSERVATION LEVEL IN OBSERVER FRAME AT STARTING POINT IF ( FFLATOUT ) THEN OBSGLOB = ( C(1) + OBSLVL(1) ) / CEARTH - C(1) ELSE OBSGLOB = OBSLVL(1) ENDIF C COS(ANGLE) OF TRAJECTORY DIRECTION IN OBSERVER FRAME AUX3 = W(NP)*CEARTH !AUX3=COS(ACOS(W(NP)+/-ACOS(CEARTH)) IF ( ABS(W(NP)) .LT. 1.D0 ) AUX3 = AUX3 - TOAXIS * * SQRT( (1.D0-W(NP))*(1.D0+W(NP))*(1.D0-CEARTH)*(1.D0+CEARTH) ) C FOR AUX3 < 0 PARTICLE GOING AWAY FROM THE AXIS WILL NEVER ARRIVE C AT OBSERVATION LEVEL PLANE LOWER THAN PARTICLE AND C FOR W < 0 PARTICLE GOING TO THE AXIS WILL NEVER ARRIVE C AT OBSERVATION LEVEL PLANE LOWER THAN PARTICLE C PARTICLE GOING TO OBSERVATION LEVEL LOWER THAN CURRENT HEIGHT IF ( FEGSDB ) WRITE(MDEBUG,*) 'HOWFAR: OBSGLOB,TOAXIS,AUX3=', * SNGL(OBSGLOB),SNGL(TOAXIS),SNGL(AUX3) IF ( ( ( FFLATOUT .AND. AUX3 .GT. 0.D0 .AND. IR(NP) .EQ. 5 ) * .OR. W(NP) .GT. 0.D0 ) #if !__UPWARD__ * .AND. W(NP) .GT. WCUT #endif * ) THEN C CALCULATE REAL STEP LENGTH TO NEXT SPHERICAL BOUNDARY S2B C (DUE TO TRANSFORMING INTO NEW LOCAL FRAME AT THIS POINT) #if __UPWARD__ IF ( PRMPAR(15) .LT. 0.D0 ) THEN ZB2 = BOUND(IRL) + C(1)-0.1D0 ELSE #endif ZB2 = MAX( OBSLVL(1), BOUND(IRL)-0.1D0 ) + C(1) #if __UPWARD__ ENDIF #endif IF ( ABS(W(NP)) .LT. 1.D0 ) THEN ZAPB2 = (C(1)-Z(NP)) * SQRT( (1.D0-W(NP))*(1.D0+W(NP)) ) ELSE ZAPB2 = 0.D0 ENDIF IF ( ZB2 .GE. ZAPB2 .AND. W(NP) .GT. 0.D0 ) THEN S2B = (C(1)-Z(NP))*W(NP) - SQRT( (ZB2+ZAPB2)*(ZB2-ZAPB2) ) IBFLAG = 0 ELSE C PARTICLE WITH THIS ZENITH ANGLE AND HEIGHT WILL NEVER REACH THE C BOUNDARY (SPHERE AROUND EARTH), BUT IT MAY REACH THE BOUNDARY C ABOVE LATER. SO LET IT FLY UNTIL COSTHE WILL CHANGE ITS SIGNE S2B = (C(1)-Z(NP))* ABS( W(NP) ) IBFLAG = 1 ENDIF #if __UPWARD__ IF ( PRMPAR(15) .LT. 0.D0 ) THEN TVAL = S2B ELSE #endif C GOES EXACTLY TO OBSERVATION LEVEL IF ( FFLATOUT .AND. AUX3 .GT. 0.D0 ) THEN C IF THE OBSERVATION LEVEL IS FLAT, RECALCULATE STEP LENGHT TVAL = ((C(1)-Z(NP))*CEARTH-C(1)-OBSLVL(1))/AUX3 IF ( TVAL .LE. S2B ) THEN IBFLAG = 0 ELSE TVAL = S2B ENDIF ELSE TVAL = S2B ENDIF #if __UPWARD__ ENDIF #endif IF ( FEGSDB ) WRITE(MDEBUG,*) 'HOWFAR: TVAL,IBFLAG=', * TVAL,IBFLAG IF ( TVAL .GT. USTEP ) THEN C CAN TAKE CURRENTLY REQUESTED STEP. DNEAR HAS TO BE DISTANCE TO NEXT C BOUNDARY OR OBSLVL. KEEP DNEAR SMALL => CHECK CROSSING OF LAYER C BOUNDARY MORE OFTEN #if __UPWARD__ AUX1 = BOUND(IRL-1) IF ( PRMPAR(15) .LT. 0.D0 ) THEN AUX2 = BOUND(IRL) ELSE AUX2 = MAX( BOUND(IRL), OBSGLOB ) ENDIF DNEAR(NP) = MIN( Z(NP)+AUX1, -Z(NP)-AUX2 ) #else DNEAR(NP) = MIN( -Z(NP)-BOUND(IRL), -Z(NP)-OBSGLOB ) #endif IF ( IBFLAG .EQ. 0 ) THEN DNEAR(NP) = MIN( DNEAR(NP), TVAL * ABS( W(NP) ) ) ELSE DNEAR(NP) = MIN( DNEAR(NP), USTEP * ABS( W(NP) ) ) ENDIF IF ( FEGSDB ) WRITE(MDEBUG,*) 'HOWFAR: DNEAR(NP),USTEP=', * DNEAR(NP),USTEP ELSE C GO TO DETECTOR OR BOUNDARY, WHICH IS CLOSER USTEP = MAX( TVAL, 0.0001D0 ) IF ( IBFLAG .EQ. 0 ) THEN #if __UPWARD__ IF ( PRMPAR(15) .LT. 0.D0 ) THEN BOUNDC = BOUND(IRL) ELSE #endif BOUNDC = MAX( OBSGLOB, BOUND(IRL) ) #if __UPWARD__ ENDIF #endif ELSE C IF S2B IS NOT DEFINED , BOUNDC IS NOT REACHED. WE ARE AT THE C CLOSEST POINT TO THE EARTH ON THIS TRAJECTORY BOUNDC = SQRT( ZAPB2 ) - C(1) ENDIF IF ( FEGSDB ) WRITE(MDEBUG,*) 'HOWFAR: BOUNDC=',BOUNDC #if __UPWARD__ IF ( PRMPAR(15) .LT. 0.D0 ) THEN C THE OBSERVATION LEVEL MUST BE AT TOP OF ATMOSPHERE, THERERFORE C BOUNDARY IS CROSSED IF NOT STOPPED IN THE MIDDLE OF THE PATH IF ( IBFLAG .EQ. 0 ) THEN IRNEW = IRL + 1 IF ( FEGSDB ) WRITE(MDEBUG,*) 'HOWFAR: IRL,IRNEW=', * IRL,IRNEW C PARTICLE LEAVES AIR (IN GROUND) IF ( IRNEW .GE. 6 ) THEN C TRANSPORT AND ELIMINATE AFTERWARDS IDISC = -2 IRETE = .TRUE. ENDIF ELSE IF ( FEGSDB ) WRITE(MDEBUG,*) 'HOWFAR: SAME IRL', * IRL ENDIF RETURN ENDIF #endif IF ( IBFLAG .EQ. 1 ) THEN C PARTICLE GOES TO THE MIDDLE OF ITS PATH WITHOUT REACHING A BOUNDARY IF ( FEGSDB ) WRITE(MDEBUG,*) 'HOWFAR: SAME IRL', * IRL C IFLAG=0 HERE = REACH OBSERVATION LEVEL OR BOUNDARY ELSEIF ( BOUNDC .GT. OBSGLOB ) THEN !BOUNDARY #else /* not curved */ C STANDARD CASE #if __UPWARD__ IF ( W(NP) .GT. 0.0003D0 ) THEN #else IF ( W(NP) .GT. WCUT ) THEN #endif C WE ARE GOING DOWNWARD C TVAL IS DISTANCE TO NEXT BOUNDARY OR OBSERVATION LEVEL C IN THIS DIRECTION TVAL = ( -Z(NP) -MAX( BOUND(IRL), OBSLVL(NOBS) ) ) / W(NP) IF ( FEGSDB ) WRITE(MDEBUG,*) 'HOWFAR: TVAL,USTEP=', * TVAL,USTEP IF ( TVAL .GT. USTEP ) THEN C CAN TAKE CURRENTLY REQUESTED STEP #if __UPWARD__ IF ( PRMPAR(2) .LT. 0.D0 ) THEN C NO DETECTOR LEVEL EXCEPT AT TOP OF ATMOSPHERE AUX1 = BOUND(IRL) ELSE AUX1 = MAX( BOUND(IRL), OBSLVL(NOBS) ) ENDIF IF ( NOBS .GT. 1 ) THEN AUX2 = MIN( BOUND(IRL-1), OBSLVL(NOBS-1) ) ELSE AUX2 = BOUND(IRL-1) ENDIF DNEAR(NP) = MIN( -Z(NP)-AUX1, AUX2+Z(NP) ) #else DNEAR(NP) = TVAL * W(NP) #endif IF ( FEGSDB ) WRITE(MDEBUG,*) 'HOWFAR: DNEAR(NP),USTEP=', * DNEAR(NP),USTEP ELSE C GO TO DETECTOR OR BOUNDARY, WHICH IS CLOSER USTEP = MAX( TVAL, 0.0001D0 ) #if __UPWARD__ IF ( PRMPAR(2) .LT. 0.D0 ) THEN C NO DETECTOR LEVEL EXCEPT AT TOP OF ATMOSPHERE; IT MUST BE A BOUNDARY IRNEW = IRL + 1 IF ( FEGSDB ) WRITE(MDEBUG,*) 'HOWFAR: IRL,IRNEW=', * IRL,IRNEW C PARTICLE LEAVES AIR IF ( IRNEW .GE. 6 ) THEN C TRANSPORT AND ELIMINATE AFTERWARDS IDISC = -1 IRETE = .TRUE. RETURN ENDIF ENDIF #endif IF ( BOUND(IRL) .GT. OBSLVL(NOBS) ) THEN !BOUNDARY #endif /* curved */ C PARTICLE CROSSES BOUNDARY IRNEW = IRL + 1 IF ( FEGSDB ) WRITE(MDEBUG,*) 'HOWFAR: IRL,IRNEW=', * IRL,IRNEW C PARTICLE LEAVES AIR IF ( IRNEW .GE. 6 ) THEN C TRANSPORT AND ELIMINATE AFTERWARDS IDISC = -1 IRETE = .TRUE. RETURN ENDIF ELSE ! BOUND(IRL) .LE. OBSLVL(NOBS) !DETECTOR C PARTICLE CROSSES DETECTOR LEVEL NEWOBS = NOBS + 1 IF ( FEGSDB ) WRITE(MDEBUG,*) 'HOWFAR: NOBS,NEWOBS=', * NOBS,NEWOBS C TRANSPORT PARTICLE TO FINAL DETECTOR LEVEL AND DISCARD IT #if __UPWARD__ && !__CURVED__ IF ( NEWOBS .GT. NOBSLV .AND. PRMPAR(2) .GE. 0.D0 ) THEN #else IF ( NEWOBS .GT. NOBSLV ) THEN #endif C TRANSPORT AND ELIMINATE AFTERWARDS IDISC = -1 IRETE = .TRUE. RETURN ENDIF ENDIF ENDIF C END OF 'PARTICLE GOING DOWNWARD' #if __CURVED__ || __UPWARD__ #if __CURVED__ ELSE C PARTICLE IS GOING UPWARD OR NEARLY HORIZONTALLY #elif __UPWARD__ ELSEIF ( W(NP) .LT. -0.003D0 ) THEN C PARTICLE IS GOING UPWARD #endif #if __CURVED__ IF ( ABS( W(NP) ) .LE. 0.003D0 ) THEN C HORIZONTALLY GOING PARTICLE CAN NOT REACH OBSLVL C (CHECK DISTANCE OF BOUNDARY WITH PYTHAGORE) IF ( BOUND(IRL-1) .GT. -Z(NP) ) THEN TVAL = SQRT( ( 2.D0*C(1) + BOUND(IRL-1)+0.1D0 - Z(NP) ) * * ( BOUND(IRL-1)+0.1D0 + Z(NP) ) ) ELSE WRITE(MDEBUG,*) 'HOWFAR: WARNING FOR TVAL' IRNEW = IRL DO WHILE ( BOUND(IRNEW-1) .LE. -Z(NP) ) IRNEW = IRNEW - 1 IF ( IRNEW .LE. 1 ) THEN C PARTICLE IS OUT OF THE ATMOSPHERE, DISCARD IT IDISC = 1 IRETE = .FALSE. RETURN ENDIF ENDDO WRITE(MDEBUG,*) 'IRL NOT WELL DEFINED : IRL,IRNEW', * IRL,IRNEW TVAL = SQRT( ( 2.D0*C(1) + BOUND(IRNEW-1)+0.1D0 - Z(NP) ) * * ( BOUND(IRNEW-1)+0.1D0 + Z(NP) ) ) ENDIF ELSE IF ( PRMPAR(15) .LT. 0.D0 ) THEN C UPWARD SHOWER WITH UPWARD PARTICLE TVAL = ABS( (-MIN( BOUND(IRL-1)+0.1D0, OBSLVL(1) )-Z(NP) ) * / W(NP) ) ELSE C DOWNWARD SHOWER WITH UPWARD PARTICLE CAN NOT REACH OBSLVL TVAL = ABS( (-(BOUND(IRL-1)+0.1D0) -Z(NP) ) / W(NP) ) ENDIF ENDIF #else C DISTANCE TO NEXT BOUNDARY OR OBSERVATION LEVEL IF ( NOBS .LE. 1 ) THEN IF ( PRMPAR(2) .LT. 0.D0 ) THEN C UPWARD SHOWER WITH UPWARD PARTICLE TVAL = (-MIN( BOUND(IRL-1), OBSLVL(1) ) - Z(NP) )/W(NP) ELSE TVAL = ( -BOUND(IRL-1) - Z(NP) )/W(NP) ENDIF ELSE TVAL = (-MIN( BOUND(IRL-1), OBSLVL(NOBS-1) ) - Z(NP) )/W(NP) ENDIF #endif IF ( FEGSDB ) WRITE(MDEBUG,*) 'HOWFAR: TVAL,USTEP=', * TVAL,USTEP IF ( TVAL .GT. USTEP ) THEN C CAN TAKE CURRENTLY REQUESTED STEP, DNEAR IS CLOSEST DISTANCE C TO DETECTOR OR BOUNDARY ABOVE OR BELOW PARTICLE #if __CURVED__ AUX1 = BOUND(IRL-1) IF ( PRMPAR(15) .LT. 0.D0 ) THEN AUX2 = BOUND(IRL) ELSE C UPWARD GOING PARTICLE CAN LATER PRODUCE DOWNWARD GOING PARTICLES... AUX2 = MAX( BOUND(IRL), OBSGLOB ) ENDIF #else IF ( NOBS .LE. 1 ) THEN AUX1 = BOUND(IRL-1) ELSE AUX1 = MIN( BOUND(IRL-1), OBSLVL(NOBS-1) ) ENDIF IF ( PRMPAR(2) .LT. 0.D0 ) THEN AUX2 = BOUND(IRL) ELSE AUX2 = MAX( BOUND(IRL), OBSLVL(NOBS) ) ENDIF #endif DNEAR(NP) = MIN( Z(NP)+AUX1, -Z(NP)-AUX2 ) IF ( FEGSDB ) WRITE(MDEBUG,*) 'HOWFAR: DNEAR(NP),USTEP=', * DNEAR(NP),USTEP ELSE C TAKE ONLY STEP UP TO BOUNDARY OR DETECTOR USTEP = MAX( TVAL, 0.0001D0 ) C UPWARD SHOWER WITH UPWARD PARTICLE #if __CURVED__ IF ( PRMPAR(15) .LT. 0.D0 ) THEN IF ( BOUND(IRL-1) .GE. OBSLVL(1) .AND. * ABS( W(NP) ) .GT. 0.003D0) THEN #else IF ( NOBS .LE. 1 ) THEN IF ( PRMPAR(2) .LT. 0.D0 ) THEN IF ( BOUND(IRL-1) .GE. OBSLVL(1) ) THEN #endif C PARTICLE CROSSES DETECTOR ABOVE, TRANSPORT AND DISCARD AFTER STEP NEWOBS = NOBS - 1 IF ( FEGSDB ) WRITE(MDEBUG,*) 'HOWFAR: NOBS,NEWOBS=', * NOBS,NEWOBS IDISC = -1 IRETE = .TRUE. RETURN ELSE C PARTICLE CROSSES BOUNDARY ABOVE IRNEW = IRL - 1 IF ( FEGSDB ) WRITE(MDEBUG,*) 'HOWFAR: IRL,IRNEW=', * IRL,IRNEW IF ( IRNEW .LE. 1 ) THEN C PARTICLE WILL LEAVE ATMOSPHERE C TRANSPORT PARTICLE TO BORDER OF ATMOSPHERE AND DISCARD IT IDISC = -2 IRETE = .FALSE. RETURN ENDIF ENDIF ELSE C DOWNWARD SHOWER WITH UPWARD PARTICLE C PARTICLE CROSSES BOUNDARY ABOVE IRNEW = IRL - 1 IF ( FEGSDB ) WRITE(MDEBUG,*) 'HOWFAR: IRL,IRNEW=', * IRL,IRNEW IF ( IRNEW .LE. 1 ) THEN C PARTICLE WILL LEAVE ATMOSPHERE C TRANSPORT PARTICLE TO BORDER OF ATMOSPHERE AND DISCARD IT IDISC = -2 IRETE = .FALSE. RETURN ENDIF ENDIF #if !__CURVED__ ELSE IF ( BOUND(IRL-1) .GE. OBSLVL(NOBS-1) ) THEN NEWOBS = NOBS - 1 IF ( FEGSDB ) WRITE(MDEBUG,*) 'HOWFAR: NOBS,NEWOBS=', * NOBS,NEWOBS IF ( NEWOBS .LT. 1 .OR. PRMPAR(2) .LT. 0.D0 ) THEN C PARTICLE CROSSES THE UPMOST DETECTOR ABOVE FROM BENEATH, C TRANSPORT AND ELIMINATE AFTER STEP IDISC = -1 IRETE = .FALSE. RETURN ENDIF ENDIF IF ( BOUND(IRL-1) .LE. OBSLVL(NOBS-1) ) THEN C PARTICLE CROSSES BOUNDARY ABOVE IRNEW = IRL - 1 IF ( FEGSDB ) WRITE(MDEBUG,*) 'HOWFAR: IRL,IRNEW=', * IRL,IRNEW IF ( IRNEW .LE. 1 ) THEN C PARTICLE WILL LEAVE ATMOSPHERE C TRANSPORT PARTICLE TO BORDER OF ATMOSPHERE AND DISCARD IT IDISC = -2 IRETE = .FALSE. RETURN ENDIF ENDIF ENDIF #endif ENDIF C END OF 'PARTICLE GOING UPWARD' #if __UPWARD__ && !__CURVED__ ELSEIF ( ABS( W(NP) ) .LE. 0.003D0 ) THEN C PARTICLE MOVES HORIZONTALLY AND CANNOT HIT BOUNDARY OR DETECTOR C THEREFORE NO ACTION #endif C END OF 'PARTICLE MOVES HORIZONTALLY' #endif ENDIF C END OF ATMOSPHERE REGION CASE ELSEIF ( IR(NP) .EQ. 6 ) THEN C TERMINATE THIS HISTORY, IT IS PAST THE ATMOSPHERE C DISCARD PARTICLE IMMEDIATELY IDISC = 1 IRETE = .TRUE. ELSEIF ( IR(NP) .EQ. 1 ) THEN C WE ARE IN THE REGION WITH SOURCE ABOVE AIR IF ( W(NP) .GT. 0.D0 ) THEN C IT MUST BE A SOURCE PARTICLE ON BOUNDARY 1 USTEP = 0.0001D0 IRNEW = 2 ELSE C IT IS A REFLECTED PARTICLE, DISCARD IT C DISCARD PARTICLE IMMEDIATELY IDISC = 1 IRETE = .FALSE. ENDIF ENDIF IF ( USTEP .LT. -0.1D0 ) THEN CALL AUSGB2 WRITE(MONIOU,*) 'HOWFAR: NEGATIVE USTEP=',USTEP,' STOP' STOP ENDIF RETURN END #if __LPM__ || __THIN__ || __PARALLEL__ || __MULTITHIN__ *-- Author : D. HECK IK3 FZK KARLSRUHE 24/11/97 C======================================================================= SUBROUTINE LPMEFFECT( E0,E1,E2,ALT,FPAIR,FPASS ) C----------------------------------------------------------------------- C 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 BREMSLPM AND PAIR__LPM__ C ARGUMENTS: (ALL ENERGIES IN MEV) C PAIR BREMS C E0 = ENERGY OF GAMMA ENERGY OF GAMMA 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 (CM) C FPAIR = FLAG INDICATING PAIR OR BREMS EVENT C FPASS = FLAG INDICATING THAT PAIR/BREMS EVENT SHOULD BE SKIPPED C----------------------------------------------------------------------- IMPLICIT NONE #define __CONSTAINC__ #define __EGSDEBINC__ #define __RANDPAINC__ #define __RUNPARINC__ #include "corsika.h" DOUBLE PRECISION AB,ALT,E0,E1,E2,EGSQ, * CONLPM,F,FOVERZLOG,GLPM, * PHII,RHOF,S,S1SQLPM,SSQ,XI LOGICAL FPAIR,FPASS SAVE EXTERNAL RHOF C CONLPM IS (1.3710*10**3)**2 * RAD.LENGTH(AIR)*(ELECTR.REST MASS) C UNITS ARE (/CM) (G/CM**2) (MEV) 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.5156D7 / C WE USE SSQ = S**2 SEE KONISHI EQ. (7) & (8): C S1**2 SEE KONISHI EQ. (5) & (6): C WE USE S1SQLPM = S1**2 = ( Z**(1/3) / 190 )**4 = 1.0796917D-8 DATA S1SQLPM / 1.0796917D-8 / C WE DERIVE: FOVERZLOG = -1/( LN(S1SQLPM) ) = 5.4513722D-2 DATA FOVERZLOG / 5.4513722D-2 / C----------------------------------------------------------------------- FPASS = .FALSE. C SEE MIGDAL, EQ. (47) SSQ = CONLPM * E0 / (E1 * E2 * RHOF( ALT )) IF ( SSQ .LT. 1.D0 ) THEN C LPM EFFECT IS SIGNIFICANT IF ( FEGSDB ) * WRITE(MDEBUG,1) E0*.001D0,E1*.001D0,E2*.001D0,ALT,FPAIR 1 FORMAT(' LPMEFF: E0,E1,E2,ALT,FPAIR= ',1P,4E10.3,L2) 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) CALL RMMARD( RD,1,2 ) IF ( RD(1) .GT. F ) FPASS = .TRUE. IF ( FEGSDB ) WRITE(MDEBUG,*) 'LPMEFF: FPASS= ',FPASS ENDIF RETURN END #endif *-- Author : STANFORD LINEAR ACCELERATOR CENTER C======================================================================= C STANFORD LINEAR ACCELERATOR CENTER SUBROUTINE MOLLER C VERSION 4.00 -- 26 JAN 1986/1900 C----------------------------------------------------------------------- C MOLLER (SCATTERING) 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-PRM. 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+PRM. THE REST OF THE COLLISION CONTRIBUTION IS C SUBTRACTED CONTINUOUSLY FROM THE ELECTRON AS IONIZATION C LOSS DURING TRANSPORT. C THIS SUBROUTINE IS CALLED FROM ELECTR. C----------------------------------------------------------------------- IMPLICIT NONE #define __EGSDEBINC__ #define __RANDPAINC__ #define __RUNPARINC__ #define __STACKEINC__ #define __THRESHINC__ #define __UPHIOTINC__ #define __USEFULINC__ #include "corsika.h" DOUBLE PRECISION AUXIL,BR,EP0,E0,E02,EXTRAE,DCOSTH,GMAX,G2, * G3,H1,PEIE,PEKIN,PEKINI,PEKSE2,PESE1,PESE2, * R,REJF4,T0 SAVE C----------------------------------------------------------------------- IF ( FEGSDB ) THEN WRITE(MDEBUG,1) NP,IR(NP),IOBS(NP) 1 FORMAT(' MOLLER: NP=',I3,' IR=',I3,' IOBS=',I3) CALL AUSGB2 ENDIF C WE HAVE ELECTRON INTERACTION, INCREASE GEN. COUNTER BY 1.E3 IGEN(NP) = IGEN(NP) + 1000 PEIE = E(NP) PEKIN = PEIE-PRM PEKINI = 1.D0/PEKIN T0 = PEKIN*RMI E0 = T0+1.D0 EXTRAE = PEIE - THMOLL E02 = E0**2 EP0 = TE*PEKINI G2 = T0**2*(1.D0/E02) G3 = (2.D0*T0+1.D0)*(1.D0/E02) GMAX = (1.D0+1.25D0*G2) C H.H.NAGEL HAS CONSTRUCTED A FACTORIZATION OF THE FREQUENCY DISTRI- C BUTION FUNCTION FOR THE MOLLER DIFFERENTIAL CROSS-SECTION USED AS C SUGGESTED BY BUTCHER AND MESSEL. (H.H.NAGEL, OP.CIT., P. 53-55) C HOWEVER, A MUCH SIMPLER SAMPLING METHOD WHICH DOES NOT BECOME VERY C INEFFICIENT NEAR THMOLL IS THE FOLLOWING: LET BR=EKS/EKIN, WHERE C EKS IS KINETIC ENERGY TRANSFERED TO THE SECONDARY ELECTRON AND EKIN C IS THE INCIDENT KINETIC ENERGY. C MODIFIED (7 FEB 1974) TO USE THE TRUE MOLLER CROSS-SECTION. THAT IS, C INSTEAD OF THE E+ E- AVERAGE GIVEN IN ROSSI FORMULA USED BY NAGEL. C THE SAMPLING SCHEME IS THAT USED BY MESSEL AND CRAWFORD C (EPSDF 1970 P.13) FIRST SAMPLE (1/BR**2) OVER (TE/EKIN,1/2) . 931 CONTINUE CALL RMMARD( RD,2,2 ) AUXIL = (PEKIN-EXTRAE*RD(1)) IF ( AUXIL .EQ. 0.D0 ) GOTO 931 BR = TE/AUXIL C USE MESSEL AND CRAWFORDS REJECTION FUNCTION. R = BR/(1.D0-BR) REJF4 = (1.D0+G2*BR**2+R*(R-G3)) IF ( RD(2)*GMAX .GT. REJF4 ) GOTO 931 PEKSE2 = BR*PEKIN PESE1 = PEIE-PEKSE2 PESE2 = PEKSE2+PRM E(NP) = PESE1 C SINCE BR.LE.0.5, E(NP+1) MUST BE .LE. E(NP) E(NP+1) = PESE2 H1 = (PEIE+PRM)*PEKINI C MOLLER ANGLES ARE UNIQUELY DETERMINED BY KINEMATICS DCOSTH = MIN( 1.D0, H1*(PESE1-PRM)/(PESE1+PRM) ) C DIRECTION COSINE CHANGE FOR 'OLD' ELECTRON SINTHE = SQRT( 1.D0 - DCOSTH ) COSTHE = SQRT( DCOSTH ) CALL UPHI( 2,1 ) C RELATED CHANGE AND (X,Y,Z) SETUP FOR 'NEW' ELECTRON NP = NP+1 IQ(NP) = 3 DCOSTH = MIN( 1.D0, H1*(PESE2-PRM)/(PESE2+PRM) ) SINTHE =-SQRT( 1.D0 - DCOSTH ) COSTHE = SQRT( DCOSTH ) CALL UPHI( 3,2 ) RETURN END *-- Author : STANFORD LINEAR ACCELERATOR CENTER C======================================================================= C STANFORD LINEAR ACCELERATOR CENTER SUBROUTINE MSCAT C VERSION 4.00 -- 26 JAN 1986/1900 C----------------------------------------------------------------------- C M(ULTIPLE) SCAT(TERING) C C DETERMINES ANGLE OF MULTPLIE SCATTERING. C THIS SUBROUTINE IS CALLED FROM ELECTR. C----------------------------------------------------------------------- IMPLICIT NONE #define __EGSDEBINC__ #define __ELECININC__ #define __EPCONTINC__ #define __MISCINC__ #define __MULTSINC__ #define __RANDPAINC__ #define __RUNPARINC__ #define __STACKEINC__ #define __THRESHINC__ #define __UPHIOTINC__ #define __USEFULINC__ #include "corsika.h" DOUBLE PRECISION B,BI,BLC,BMD,BM1,BM2,ETA,G21,G22,G2,G31,G32,G3, * OMEGA0,VSTEFF,THR,XR INTEGER IB,I21,I22,I31,I32 SAVE C----------------------------------------------------------------------- IF ( FEGSDB ) THEN WRITE(MDEBUG,1) NP,IR(NP),IOBS(NP) 1 FORMAT(' MSCAT : NP=',I3,' IR=',I3,' IOBS=',I3) CALL AUSGB2 ENDIF C ACCOUNT FOR ALTERED DENSITY VSTEFF = TVSTEP*RHOFAC C GET MOLIERE''S LOWER CASE B PARAMETER, BLC OMEGA0 = BLCC*VSTEFF/BETA2 IF ( OMEGA0 .LE. 1.D0 ) THEN SINTHE = 0.D0 COSTHE = 1.D0 THETA = 0.D0 NOSCAT = NOSCAT+1 RETURN ENDIF BLC = LOG( OMEGA0 ) C NOW CONVERT TO MOLIERE''S BIG B; 1.30685=2-LN 2, 1.530394=2/(2-LN 2) IF ( BLC .LE. 1.306852820D0 ) THEN C BELOW TRANSCENDENTAL LIMIT B = 1.530394218D0*BLC ELSE IB = B0BGB+BLC*B1BGB IF ( IB .GT. NBGB ) THEN WRITE(KMPO,940) IB 940 FORMAT('MSCAT: NBGB*SQRT(B); C BUT <*CHI-SUB-C*>=XCC(MEDIUM)*SQRT(VSTEFF)/(E*BETA2) XR = XCC*SQRT( MAX( 0.D0, VSTEFF*B ) )/(EOLD*BETA2) 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 BMD = 1.D0/(1.D00+1.75D0*BI) BM1 = (1.D00-2.D00*BI)*BMD BM2 = (1.0+0.025*BI)*BMD ELSE BI = 0.5D0 BM1 = (1.D0-2.D0/B)*0.533333333333D0 BM2 = 0.54D0 ENDIF C THIS LOOP IS FOR BETHE CORRECTION FACTOR REJECTION OR OTHER REJECTION 951 CONTINUE CALL RMMARD( RD,1,2 ) IF ( RD(1) .LE. BM1 ) THEN C GAUSSIAN, F0 CALL RMMARD( RD(2),1,2 ) THR = SQRT( MAX( 0.D0, -LOG( RD(2) ) ) ) ELSEIF ( RD(1) .LE. BM2 ) THEN C TAIL, F3 CALL RMMARD( RD(2),3,2 ) ETA = MAX( RD(2), RD(3) ) 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 IF ( RD(4) .GT. G3 ) GOTO 951 THR = 1.D0/ETA ELSE C CENTRAL CORRECTION, F2 CALL RMMARD( RD(2),2,2 ) THR = RD(2) 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 IF ( RD(3) .GT. G2 ) GOTO 951 ENDIF C THR IS NOW THE REDUCED ANGLE. NOW GET THE REAL ANGLE THETA = THR*XR IF ( THETA .GE. PI ) GOTO 951 SINTHE = SIN( THETA ) CALL RMMARD( RD,1,2 ) C BETHE CORRECTION FACTOR IF ( RD(1)**2*THETA .GT. SINTHE ) GOTO 951 COSTHE = COS( THETA ) RETURN END *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE MUPAIR C----------------------------------------------------------------------- C MU(ON) PAIR (FORMATION) 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 THIS SUBROUTINE IS CALLED FROM PHOTON. C REDESIGN: D. HECK IK FZK KARLSRUHE AUGUST 11, 2009 C----------------------------------------------------------------------- IMPLICIT NONE #define __AIRINC__ #define __EGSDEBINC__ #define __MUONINC__ #define __MUPARTINC__ #define __NKGSUBINC__ #define __PARPARINC__ #define __POLARINC__ #define __RANDPAINC__ #define __RUNPARINC__ #define __STACKEINC__ #define __THNVARINC__ #define __UPHIOTINC__ #define __USEFULINC__ #include "corsika.h" DOUBLE PRECISION AAIR(3),ZAIR(3) DOUBLE PRECISION AEXP,AUXIL,AUX5,BETA4,C1,C1NUM,C2, * DELMAX,DELTA,DN,ENERN,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 / C----------------------------------------------------------------------- IF ( FEGSDB ) THEN WRITE(MDEBUG,1) NP,IR(NP),IOBS(NP) 1 FORMAT(' MUPAIR: NP=',I3,' IR=',I3,' IOBS=',I3) CALL AUSGB2 ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) 'MUPAIR: E=',E(NP)*.001D0 C INCREMENT GENERATION COUNTER IGEN(NP) = IGEN(NP) + 1 C WE HAVE MUONIC PAIR PRODUCTION, INCREASE GEN. COUNTER BY 1E9 IGEN(NP) = MIN( IGEN(NP) + 1000000000 , 2000000001) C PRECISE ENERGY OF INCIDENT GAMMA PEIG = E(NP) C SUBTRACT EM SUBSHOWER FROM NKG CALCULATION IF ( FNKG ) THEN SECPAR(0) = 1.D0 SECPAR(2) = MIN( 1.D0, W(NP) ) SECPAR(3) = U(NP) SECPAR(4) = -V(NP) SECPAR(5) = -ZZOLD SECPAR(7) = XXOLD SECPAR(8) = -YYOLD #if __THIN__ SECPAR(13) = WT(NP) #endif ENERN = (-1.D-3)*PEIG CALL NKG( ENERN ) ENDIF 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 = COMPOS(1) * ZAIR(1)**1.735D0 SUM2 = SUM1 + COMPOS(2) * ZAIR(2)**1.735D0 SUM3 = SUM2 + COMPOS(3) * ZAIR(3)**1.735D0 CALL RMMARD( RD,1,2 ) IF ( RD(1)*SUM3 .LE. SUM1 ) THEN JE = 1 !NITROGEN TARGET ELSEIF ( RD(1)*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 CALL RMMARD( RD,2,2 ) XMINS = XMIN + .5D0 * RD(1) * (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 ( RD(2) .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 CALL RMMARD( RD,2,2 ) C CALCULATE F1 BY EQ.(23) F1 = ( 1.D0 - 2.D0*XPXM + 4.D0*XPXM*RD(1)*(1.D0-RD(1)) ) / * ( 1.D0 + C1/(RD(1)*RD(1)) ) IF ( F1 .LT. 0.D0 .OR. F1 .GT. F1MAX ) F1 = 0.D0 IF ( RD(2)*F1MAX .GT. F1 ) GOTO 3 TT = RD(1) 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 CALL RMMARD( RD,2,2 ) PSI = RD(1) * 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 ( RD(2)*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 ) CALL RMMARD( RD,1,2 ) C CALCULATE RHO BY EQ.(30) RHO = ( C2 * ( EXP( RD(1)*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 ) CALL RMMARD( RD,1,2 ) PHI = RD(1) * TWOPI COSPHI = COS( PHI + PHI1 ) SINPHI = SIN( PHI + PHI1 ) CALL UPHI( 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 UPHI( 3,2 ) C NOW RANDOMLY DECIDE WHICH IS POSITIVE MUON, AND SET C CHARGES ACCORDINGLY CALL RMMARD( RD,3,2 ) IF ( RD(1) .LE. .5D0 ) THEN C POSITIVE MUON ON TOP OF STACK IQ(NP) = 5 IQ(NP-1) = 6 ELSE C NEGATIVE MUON ON TOP OF STACK IQ(NP) = 6 IQ(NP-1) = 5 ENDIF C POLARISATION OF MUON (FOR ANGULAR CORRELATION IN IT''S DECAY) POLART = 2.D0*RD(2) - 1.D0 POLARF = TWOPI*RD(3) C TRANSPORT MUON 2 TO CORSIKA STACK INT_ICOUNT = 0 CALL MUPROP C INVERT POLARIZATION FOR SECOND MUON POLART = -POLART POLARF = POLARF + PI C TRANSPORT MUON 1 TO CORSIKA STACK CALL MUPROP CALL TSTEND RETURN END *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE MUPROP C----------------------------------------------------------------------- C MU(ON) PROP(AGATION) C C MOVES MUONS FROM EGS-STACK TO CORSIKA-STACK. C THIS SUBROUTINE IS CALLED FROM MUPAIR. C----------------------------------------------------------------------- IMPLICIT NONE #define __EGSDEBINC__ #define __ELABCTINC__ #define __LONGIINC__ #define __MUONINC__ #define __PARPARINC__ #define __PIONINC__ #define __POLARINC__ #define __RUNPARINC__ #define __STACKEINC__ #define __UPHIOTINC__ #if __AUGERHIST__ #define __GEOMEGSINC__ #define __OBSPARINC__ #endif #if __MULTITHIN__ #define __MULTHININC__ #endif #include "corsika.h" #if __AUGERHIST__ DOUBLE PRECISION EDEP INTEGER LL CHARACTER*10 VONWO #endif #if __MULTITHIN__ INTEGER J #endif SAVE C----------------------------------------------------------------------- IF ( FEGSDB ) THEN WRITE(MDEBUG,1) NP,IR(NP),IOBS(NP) 1 FORMAT(' MUPROP: NP=',I3,' IR=',I3,' IOBS=',I3) CALL AUSGB2 ENDIF C USE MUON ONLY IF ABOVE CUT AND INSIDE ACCEPTANCE CONE IF ( E(NP)-PRRMMU .GT. ELCUT(2)*1000.D0 ) THEN IF ( W(NP) .GT. C(29) ) THEN C FILL MUON COORDINATES INTO CORSIKA-STACK SECPAR(0) = IQ(NP) SECPAR(1) = E(NP)/PRRMMU SECPAR(2) = MIN( 1.D0, W(NP) ) SECPAR(3) = U(NP) SECPAR(4) = -V(NP) SECPAR(5) = -Z(NP) SECPAR(6) = TIM(NP) SECPAR(7) = X(NP) SECPAR(8) = -Y(NP) SECPAR(9) = IGEN(NP) SECPAR(10) = -Z(NP) SECPAR(11) = POLART SECPAR(12) = POLARF #if __THIN__ SECPAR(13) = WT(NP) #endif #if __CURVED__ SECPAR(14) = -ZAP(NP) SECPAR(15) = WAP(NP) SECPAR(16) = WA(NP) #endif #if __INTTEST__ SECPAR(17) = SQRT( (SECPAR(1)-1.D0)*(SECPAR(1)+1.D0) * *(1.D0-SECPAR(2))*(1.D0+SECPAR(2)) ) * * E(NP)*0.001D0 / SECPAR(1) #endif #if __EHISTORY__ C SECPAR(39) REMAINS UNCHANGED #endif #if __MULTITHIN__ DO J = 1, NMTHIN SECPAR(40+J) = WTM(J,NP) ENDDO #endif C MOVE MUON TO CORSIKA STACK CALL TSTACK ELSE IF ( LLONGI ) THEN C CUTTED ENERGY TO LONGITUDINAL ENERGY SUMS OF MUONS [IN GEV] C ANGULAR CUT #if __THIN__ DLONG(LPCTE(NP),15) = DLONG(LPCTE(NP),15)+E(NP)*1.D-3*WT(NP) #else DLONG(LPCTE(NP),15) = DLONG(LPCTE(NP),15)+E(NP)*1.D-3 #endif ENDIF #if __AUGERHIST__ DO LL = 1, NOBSLV C LOOK WHETHER DEPOSIT IS WITHIN 1 G/CM^2 BELOW OBSERVATION LEVEL IF ( -Z(NP) .LE. OBSLVL(LL) .AND. * -Z(NP) .GT. OBSLV2(LL) ) THEN EDEP = E(NP) E(NP) = E(NP)/PRRMMU VONWO = 'MUPROP1' C MUON/PION BELOW ANGULAR CUT CALL AUGACT( EDEP,LL,VONWO ) ELSEIF ( -Z(NP) .GT. OBSLVL(LL) ) THEN GOTO 111 ENDIF ENDDO 111 CONTINUE #endif ENDIF ELSE IF ( LLONGI ) THEN C CUTTED ENERGY TO LONGITUDINAL ENERGY SUMS OF MUONS [IN GEV] C ENERGY CUT #if __THIN__ DLONG(LPCTE(NP),5) = DLONG(LPCTE(NP),5)+E(NP)*1.D-3*WT(NP) #else DLONG(LPCTE(NP),5) = DLONG(LPCTE(NP),5)+E(NP)*1.D-3 #endif ENDIF #if __AUGERHIST__ DO LL = 1, NOBSLV C LOOK WHETHER DEPOSIT IS WITHIN 1 G/CM^2 BELOW OBSERVATION LEVEL IF ( -Z(NP) .LE. OBSLVL(LL) .AND. * -Z(NP) .GT. OBSLV2(LL) ) THEN EDEP = E(NP) E(NP) = E(NP)/PRRMMU VONWO = 'MUPROP2' C MUON/PION BELOW ENERGY CUT CALL AUGECT( EDEP,LL,VONWO ) ELSEIF ( -Z(NP) .GT. OBSLVL(LL) ) THEN GOTO 112 ENDIF ENDDO 112 CONTINUE #endif ENDIF C ELIMINATE MUON FROM EGS-STACK NP = NP-1 RETURN END *-- Author : STANFORD LINEAR ACCELERATOR CENTER C======================================================================= C STANFORD LINEAR ACCELERATOR CENTER #if __LPM__ || __THIN__ || __PARALLEL__ || __MULTITHIN__ SUBROUTINE PAIRLPM( FPASS ) #else SUBROUTINE PAIR #endif C VERSION 4.00 -- 26 JAN 1986/1900 C----------------------------------------------------------------------- C PAIR (FORMATION) C C FOR A GAMMA 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 GAMMA 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 THIS SUBROUTINE IS CALLED FROM PHOTON. #if __LPM__ || __THIN__ || __PARALLEL__ || __MULTITHIN__ C ARGUMENT: C FPASS = (LOGICAL) FLAG INDICATING THAT INTERRACTION IS SUPPRESSED #endif C----------------------------------------------------------------------- IMPLICIT NONE #define __BREMPRINC__ #define __EGSDEBINC__ #define __RANDPAINC__ #define __RUNPARINC__ #define __STACKEINC__ #define __THRESHINC__ #define __UPHIOTINC__ #define __USEFULINC__ #include "corsika.h" DOUBLE PRECISION BR,DEL,DELTA,PEIG,PESE1,PESE2,REJF INTEGER LVL,LVL0,LVX #if __LPM__ || __THIN__ || __PARALLEL__ || __MULTITHIN__ LOGICAL FPASS #endif SAVE C----------------------------------------------------------------------- IF ( FEGSDB ) THEN WRITE(MDEBUG,1) NP,IR(NP),IOBS(NP) 1 FORMAT(' PAIR : NP=',I3,' IR=',I3,' IOBS=',I3) CALL AUSGB2 ENDIF PEIG = E(NP) IF ( PEIG .LE. 2.1D0 ) THEN C BELOW 2.1 MEV,USE APPROXIMATION PESE2 = PRM ELSE C ABOVE 2.1 MEV, MUST SAMPLE. DECIDE WHETHER TO USE C BETHE-HEITLER (LVX=1,LVL=1,3) OR COULOMB CORRECTED (LVX=2,LVL=4,6) C CROSS-SECTIONS. SEE RELATED COMMENTS IN BREMS. IF ( PEIG .LT. 50.D0 ) THEN LVX = 1 LVL0 = 0 ELSE LVX = 2 LVL0 = 3 ENDIF 961 CONTINUE C RETRY IF REJECTED BECAUSE DEL OUT OF RANGE, OR BY SCREENING C WE''LL NEED AT LEAST ONE RANDOM NUMBER C NOW DECIDE WHICH OF THE TWO SUBDISTRIBUTIONS TO USE CALL RMMARD( RD,2,2 ) IF ( RD(2) .GE. BPAR(LVX) ) THEN C USE THE SUBDISTRIBUTION THAT IS PROPORTIONAL TO 12*(BR-0.5)**2. C IT USES A(DELTA) FOR SCREENING FUNCTION. LVL = LVL0+1 CALL RMMARD( RD(3),2,2 ) C FROM SYMMETRY, ONLY NEED TO SAMPLE BR IN INTERVAL (0,.5) 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( RD(3), RD(4), RD(1) ) ELSE C USE THE SUBDISTRIBUTION THAT IS PROPORTIONAL TO 1, I.E. UNIFORM. C IT USES C(DELTA) FOR A SCREENING REJECTION FUNCTION. LVL = LVL0+3 BR = RD(1)*0.5D0 ENDIF 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 GAMMA ENERGY AND BR=ENERGY FRACTION. C AVOID DIVISION BY ZERO: IF ( BR*PEIG .LT. PRM ) GOTO 961 DEL = 1.D0/(PEIG*BR*(1.D0-BR)) IF ( DEL .GE. DELPOS(LVX) ) GOTO 961 C THE PRECEDING CONDITION ENSURES THAT A(DELTA) AND C(DELTA) WILL BE C POSITIVE. IF IT IS NOT SATISFIED, LOOP BACK AND TRY ANOTHER SAMPLE. DELTA = DELCM*DEL IF ( DELTA .LT. 1.D0 ) THEN REJF = DL1(LVL)+DELTA*(DL2(LVL)+DELTA*DL3(LVL)) ELSE REJF = DL4(LVL)+DL5(LVL)*LOG( DELTA+DL6(LVL) ) ENDIF CALL RMMARD( RD,1,2 ) IF ( RD(1) .GT. REJF ) GOTO 961 C BR=PRODUCT ENERGY FRACTION PESE2 = BR*PEIG ENDIF PESE1 = PEIG-PESE2 #if __LPM__ || __THIN__ || __PARALLEL__ || __MULTITHIN__ C CHECK LPM EFFECT AT ENERGIES ABOVE 10**18 EV IF ( PEIG .GT. 1.D12 ) THEN CALL LPMEFFECT( PEIG,PESE1,PESE2,-Z(NP),.TRUE.,FPASS ) IF ( FPASS ) RETURN ELSE FPASS = .FALSE. ENDIF #endif C WE HAVE PHOTON INTERACTION, INCREASE GEN. COUNTER BY 1E6 IGEN(NP) = IGEN(NP) + 1000000 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.. THE INITIAL AND C FINAL MOMENTA ARE COPLANAR. SET UP A NEW 'ELECTRON' THETA = PRM/PEIG CALL UPHI( 1,1 ) NP = NP+1 SINTHE = -SINTHE CALL UPHI( 3,2 ) C NOW RANDOMLY DECIDED WHICH IS POSITRON, AND SET CHARGES ACCORDINGLY CALL RMMARD( RD,1,2 ) IF ( RD(1) .LE. 0.5D0 ) THEN IQ(NP) = 2 IQ(NP-1) = 3 ELSE IQ(NP) = 3 IQ(NP-1) = 2 ENDIF RETURN END *-- Author : STANFORD LINEAR ACCELERATOR CENTER C======================================================================= C STANFORD LINEAR ACCELERATOR CENTER SUBROUTINE PHOTO C VERSION 4.00 -- 26 JAN 1986/1900 C----------------------------------------------------------------------- C PHOTO (EFFECT) C C TREATS PHOTO EFFECT. C THIS SUBROUTINE IS CALLED FROM PHOTON. C----------------------------------------------------------------------- IMPLICIT NONE #define __EGSDEBINC__ #define __EPCONTINC__ #define __LONGIINC__ #define __PHOTININC__ #define __RUNPARINC__ #define __STACKEINC__ #define __USEFULINC__ #if __AUGERHIST__ #define __GEOMEGSINC__ #define __OBSPARINC__ #endif #include "corsika.h" DOUBLE PRECISION PEIG #if __AUGERHIST__ INTEGER LL CHARACTER*10 VONWO #endif SAVE C----------------------------------------------------------------------- IF ( FEGSDB ) THEN WRITE(MDEBUG,1) NP,IR(NP),IOBS(NP) 1 FORMAT(' PHOTO : NP=',I3,' IR=',I3,' IOBS=',I3) CALL AUSGB2 ENDIF PEIG = E(NP) IF ( E(NP) .LE. EBINDA ) THEN C GAMMA IS COMPLETELY ABSORBED EDEP = PEIG IBLOBE = 1 ELSE C ASSUME ELECTRON WENT IN DIRECTION OF THE GAMMA WITH ITS ENERGY, LESS C THE BINDING ENERGY. EDEP = EBINDA C BINDING ENERGY WILL BE DEPOSITED LOCALLY E(NP) = EDEP IBLOBE = 0 C FLAG INDICATING WHETHER ENERGY BELOW BINDING ENERGY ENDIF IF ( LLONGI ) THEN C CUTTED ENERGY TO LONGITUDINAL ENERGY SUMS [IN GEV] C THIS ENERGY GOES COMPLETELY INTO IONIZATON #if __THIN__ DLONG(LPCTE(NP),2) = DLONG(LPCTE(NP),2) + EDEP*1.D-3*WT(NP) #else DLONG(LPCTE(NP),2) = DLONG(LPCTE(NP),2) + EDEP*1.D-3 #endif ENDIF #if __AUGERHIST__ DO LL = 1, NOBSLV C LOOK WHETHER DEPOSIT IS WITHIN 1 G/CM^2 BELOW OBSERVATION LEVEL IF ( -Z(NP) .LE. OBSLVL(LL) .AND. * -Z(NP) .GT. OBSLV2(LL) ) THEN VONWO = 'PHOTO' CALL AUGECT( EDEP,LL,VONWO ) ELSEIF ( -Z(NP) .GT. OBSLVL(LL) ) THEN GOTO 111 ENDIF ENDDO 111 CONTINUE #endif IF ( IBLOBE .EQ. 1 ) THEN E(NP) = 0.D0 RETURN ENDIF IQ(NP) = 3 C SET ELECTRON ENERGY E(NP) = PEIG-EDEP+PRM C WE HAVE ELECTROMAGNETIC INTERACTION, INCREASE GEN. COUNTER BY 1E6 IGEN(NP) = IGEN(NP) + 1000000 RETURN END *-- Author : STANFORD LINEAR ACCELERATOR CENTER C======================================================================= C STANFORD LINEAR ACCELERATOR CENTER SUBROUTINE PHOTON( IRCODE ) C VERSION 4.00 -- 26 JAN 1986/1900 C----------------------------------------------------------------------- C PHOTON (IS TREATED) C C TREATS THE GAMMA TRANSPORT. C FOR PATH LENGTH CORRECTION BECAUSE OF BAROMETRIC ATMOSPHERE SEE C INTERNAL REPORT OF D.HECK,(1989). C THIS SUBROUTINE IS CALLED FROM SHOWER. C ARGUMENT: C IRCODE = RETURN CODE : 1 NORMAL RETURN C 2 IF POSSIBLY STACK IS EMPTY C----------------------------------------------------------------------- IMPLICIT NONE #define __BOUNDSINC__ #define __BUFFSINC__ #define __EGSDEBINC__ #define __ELABCTINC__ #define __EPCONTINC__ #define __GEOMEGSINC__ #define __LAYERINC__ #define __LONGIINC__ #define __MEDIAINC__ #define __MEDIACINC__ #define __MISCINC__ #define __MUONINC__ #define __NKGSUBINC__ #define __OBSPARINC__ #define __PARPARINC__ #define __PHOTININC__ #define __PIONINC__ #define __RANDPAINC__ #define __REJECTINC__ #define __RUNPARINC__ #define __STACKEINC__ #if __PARALLEL__ #define __STACKFINC__ #endif #define __THRESHINC__ #if __CURVED__ #define __TIMLIMINC__ #endif #define __UPHIOTINC__ #define __USEFULINC__ #if __CERENKOV__ || __AUGCERLONG__ #define __CEREN1INC__ #define __CERTELINC__ #define __CEREN3INC__ #endif #if __PLOTSH2__ #define __PLOTSH2INC__ #endif #include "corsika.h" DOUBLE PRECISION ALTEXP,COHFAC,CSQTHE,DISC,DPMFP, * GBR1,GBR2,GBR3,GBR4,GMFP,GMFPR0,PEIG,Q2, * REJF,RHOFI,THICK,USTEPU,X2,ZOLD INTEGER IRCODE,IRL,I,IDR,I1, * LGLE,LPCT1,LPCT2,LXXX LOGICAL IRETC #if !__CERENKOV__ && !__THIN__ && !__PLOTSH__ && !__AUGERHIST__ && !__AUGCERLONG__ && !__UPWARD__ DOUBLE PRECISION ALTEXI,ANU1,ANU2 INTEGER JDET,KDET #endif #if __AUGERHIST__ INTEGER LL CHARACTER*10 VONWO #endif #if __CURVED__ DOUBLE PRECISION AUXIL,AUXILSQ,AUX2SQ,CORR,COSDIF,COSTHENEW, * DISTO2,DSTEFF,PHI,SINDIF, * TANPHI,TRANS2,XOLD,YOLD,ZNEW DOUBLE PRECISION PHI1,RRR,SINTEA,XXX,YYY INTEGER IPASC #endif #if __UPWARD__ DOUBLE PRECISION ZNEWUP #endif #if __PLOTSH__ && !__PLOTSH2__ REAL TRID,TRE,TRX1,TRY1,TRZ1,TRT1,TRX2,TRY2,TRZ2,TRT2 #endif #if __PLOTSH2__ DOUBLE PRECISION WGHT #endif #if __COASTUSERLIB__ 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 #if __CURVED__ DOUBLE PRECISION ZAPOLD,XXXOLD,YYYOLD,SPEED,SPEED0,TDIFF INTEGER MCOUNT #endif #if __SLANT__ DOUBLE PRECISION AUXIL1,AUXOLD,AUXNEW,THCKSI,T1 EXTERNAL THCKSI #if !__CURVED__ DOUBLE PRECISION XOLD,YOLD #endif #endif #if __THIN__ || __MULTITHIN__ DOUBLE PRECISION EKENP,EKENP1,EKG #endif #if __THIN__ || __LPM__ || __PARALLEL__ || __MULTITHIN__ LOGICAL FPASS #endif SAVE EXTERNAL THICK #if __CURVED__ DATA MCOUNT / 0 / #endif #if __PLOTSH2__ && !__THIN__ DATA WGHT / 1.D0 / #endif C----------------------------------------------------------------------- IF ( DEBUG ) THEN NCLOCK = NCLOCK+1 IF ( FEGSDB ) THEN WRITE(MDEBUG,1) NP,IR(NP),IOBS(NP),NCLOCK 1 FORMAT(/,' PHOTON: NP=',I3,' IR=',I3,' IOBS=',I3,' NCLOCK=', * I12) CALL AUSGB2 ELSE IF ( NCLOCK .GE. JCLOCK ) THEN FEGSDB = .TRUE. WRITE(MDEBUG,1) NP,IR(NP),IOBS(NP),NCLOCK CALL AUSGB2 ENDIF IF ( MOD(NCLOCK,1000) .EQ. 0 ) THEN WRITE(MDEBUG,2) NP,IR(NP),IOBS(NP),NCLOCK 2 FORMAT(' PHOTON: NP=',I3,' IR=',I3,' IOBS=',I3,' NCLOCK=', * I12) ENDIF ENDIF ENDIF #if __INTTEST__ IF ( DEBUG ) WRITE(MDEBUG,*) 'PHOTON: NP=',NP,' IR=',IR(NP), * ' IOBS=',IOBS(NP) #endif NEWOBS = IOBS(NP) IRCODE = 1 PEIG = E(NP) IRL = IR(NP) MEDIUM = MED(IRL) IF ( PEIG .LE. PCUT(IRL) ) GOTO 970 980 CONTINUE XXOLD = X(NP) YYOLD = Y(NP) ZZOLD = Z(NP) 981 CONTINUE C KILL HORIZONTAL OR UPWARD GOING PARTICLES IF ( W(NP) .LE. WCUT ) THEN IDISC = 1 IRETC = .FALSE. GOTO 1000 ENDIF GLE = LOG( PEIG ) #if !__CERENKOV__ && !__THIN__ && !__PLOTSH__ && !__COASTUSERLIB__ && !__AUGERHIST__ && !__AUGCERLONG__ && !__UPWARD__ C REJECT PARTICLES, WHICH HAVE LITTLE CHANCE TO LEAD TO A PARTICLE TO C BE DETECTED ON OBSERVATION LEVEL. THE PARAMETERISATION IS TAKEN FROM C J. SPITZER (DESY AND HD) 1988. C ENERGY THRESHOLD IS PION THRESHOLD IF ( .NOT. LLONGI .AND. PEIG .LT. PITHR ) THEN IDISC = 0 IF ( -Z(NP) .GT. ALTMIN(1) ) THEN ALTEXI = EXP( Z(NP) * HBAROI(IRL) ) THICKA(1) = HBARO(IRL)*(THICKD(1)-ALTEXI) ANU1 = -6.65D0+1.368D0*GLE+0.1954D0*ABS(GLE-6.908D0) ANU2 = 2.7D-5 -GLE*(0.2714D-5 -0.01415D-5*GLE) C ANEXP IS AVERAGE NUMBER OF EXPECTED PARTICLES AT DETECTOR LEVEL ANEXP(1) = ANU1-ANU2*THICKA(1) IF ( ANEXP(1) .LT. CUTLN+GLE ) THEN C AVNREJ IS AVERAGE NUMBER OF REJECTED PARTICLES AT DETECTOR AVNREJ(1) = AVNREJ(1) + EXP( ANEXP(1) ) IF ( NOBSLV .GT. 1 ) THEN DO KDET = 2, NOBSLV THICKA(KDET) = HBARO(IRL)*(THICKD(KDET)-ALTEXI) ANEXP(KDET) = ANU1-ANU2*THICKA(KDET) AVNREJ(KDET) = AVNREJ(KDET) + EXP( ANEXP(KDET) ) ENDDO ENDIF IRETC = .TRUE. GOTO 1000 ENDIF ELSEIF ( NOBSLV .GT. 1 ) THEN DO JDET = 2, NOBSLV IF (-Z(NP) .LT. OBSLVL(JDET-1) .AND. * -Z(NP) .GT. ALTMIN(JDET) ) THEN ALTEXI = EXP( Z(NP) * HBAROI(IRL) ) THICKA(JDET) = HBARO(IRL)*(THICKD(JDET)-ALTEXI) ANU1 = -6.65D0+1.368D0*GLE+0.1954D0*ABS(GLE-6.908D0) ANU2 = 2.7D-5 -GLE*(0.2714D-5 -0.01415D-5*GLE) C ANEXP IS AVERAGE NUMBER OF EXPECTED PARTICLES AT DETECTOR LEVEL ANEXP(JDET) = ANU1-ANU2*THICKA(JDET) IF ( ANEXP(JDET) .LT. CUTLN+GLE ) THEN C AVNREJ IS AVERAGE NUMBER OF REJECTED PARTICLES AT DETECTOR AVNREJ(JDET) = AVNREJ(JDET) + EXP( ANEXP(JDET) ) IF ( NOBSLV .GT. JDET ) THEN DO KDET = JDET+1, NOBSLV THICKA(KDET) = HBARO(IRL)*(THICKD(KDET) -ALTEXI) ANEXP(KDET) = ANU1-ANU2*THICKA(KDET) AVNREJ(KDET) = AVNREJ(KDET) + EXP( ANEXP(KDET) ) ENDDO ENDIF IRETC = .TRUE. GOTO 1000 ENDIF ENDIF ENDDO ENDIF ENDIF #endif C HERE SAMPLE MEAN FREE PATH TO TRANSPORT BEFORE INTERACTING CALL RMMARD( RD,1,2 ) DPMFP = MAX( -LOG( RD(1) ), 1.D-14 ) IROLD = IR(NP) 1031 CONTINUE IF ( MEDIUM .NE. 0 ) THEN LGLE = GE1*GLE+GE0 GMFPR0 = GMFP1(LGLE)*GLE+GMFP0(LGLE) ENDIF 1041 CONTINUE #if __PLOTSH__ || __PLOTSH2__ IF ( PLOTSH ) THEN C BEGINNING OF TRACKING STEP TRID = 1. TRE = E(NP) * 0.001 TRX1 = X(NP) TRY1 = -Y(NP) #if __CURVED__ TRZ1 = -ZAP(NP) #else TRZ1 = -Z(NP) #endif TRT1 = TIM(NP) ENDIF #endif #if __COASTUSERLIB__ C BEGINNING OF TRACKING STEP pnt1id = 1 pnt1gen = igen(np) #if __CURVED__ pnt1x = XXXX(NP) pnt1y = -YYYY(NP) pnt1z = -ZAP(NP) #else pnt1x = X(NP) - XOFF(NOBSLV) pnt1y = -Y(NP) - YOFF(NOBSLV) pnt1z = -Z(NP) #endif #if __SLANT__ pnt1d = TSLAN(NP) #else pnt1d = THICK( -Z(NP) )/COS( THETAP ) #endif pnt1t = TIM(NP) pnt1e = PEIG * 0.001D0 #if __THIN__ pnt1w = WT(NP) #else pnt1w = 1.D0 #endif #endif IF ( MEDIUM .EQ. 0 ) THEN C WE ARE IN VACUUM TSTEP = VACDST ALTEXP = 1.D0 ELSE C WE ARE IN AIR LAYER RHOFAC = RHOR(IRL)/RHO RHOFI = 1.D0/RHOFAC GMFP = GMFPR0*RHOFI C DENSITY CORRECTION OF MEAN FREE PATH IF ( IRAYLR(IRL) .EQ. 1 ) THEN COHFAC = COHE1(LGLE)*GLE+COHE0(LGLE) GMFP = GMFP*COHFAC ENDIF TSTEP = MAX( GMFP*DPMFP, 1.D-3 ) ALTEXP = EXP( (-Z(NP))*HBAROI(IRL) ) TSTEP = TSTEP*ALTEXP DISC = W(NP)*TSTEP*HBAROI(IRL) IF ( ABS(DISC) .LT. .0000007D0 ) THEN TSTEP = TSTEP*(1.D0-.5D0*DISC*(1.D0-.666666666666667D0*DISC* * (1.D0-.75D0*DISC*(1.D0-.8D0*DISC)))) ELSEIF ( DISC .GT. -1.D0 ) THEN TSTEP = TSTEP*LOG( DISC+1.D0 )/DISC ELSE TSTEP = VACDST ENDIF ENDIF IRNEW = IR(NP) IDISC = 0 USTEP = TSTEP TUSTEP = USTEP C LOOK HOW FAR WE CAN GO IF ( USTEP .GT. DNEAR(NP) ) CALL HOWFAR( IRETC ) IF ( IDISC .GT. 0 ) GOTO 1000 ZOLD = Z(NP) #if __CURVED__ XOLD = X(NP) YOLD = Y(NP) XXXOLD = XXXX(NP) YYYOLD = YYYY(NP) ZAPOLD = ZAP(NP) DISTO2 = X(NP)**2 + Y(NP)**2 IF ( IDISC .EQ. -1 ) THEN C PARTICLE WILL CROSS THE DETECTOR LEVEL IF ( FEGSDB ) THEN WRITE(MDEBUG,*) 'PHOTON: WE APPROACH DETECTOR' CALL AUSGB2 ENDIF AUXILSQ = SQRT( DISTO2 ) WA(NP) = COS( AUXILSQ / C(1) ) WA(NP) = MIN( 1.D0, WA(NP) ) C REGARD WHETHER PARTICLE IS MOVING TOWARDS DETECTOR C EFFECTIVE DISTANCE TO DETECTOR CENTER IS DISTANCE TO POINT C OF FLIGHT PATH PROJECTION WHICH COMES CLOSEST TO DETECTOR CENTER IF ( U(NP) .NE. 0.D0 .OR. V(NP) .NE. 0.D0 ) THEN PHI = ATAN2(V(NP),U(NP)) ELSE PHI = 0.D0 ENDIF DSTEFF = -( COS( PHI )*X(NP) + SIN( PHI )*Y(NP) ) C ANGLE DIF MIGHT BE LARGE (DUE TO CUT ON APPARTENT HEIGHT) C BUT SHOULD NOT BE TOO LARGE IF ( DSTEFF .LT. C(3) ) THEN C CALCULATE CORRECTION ANGLE DIF FROM EFFECTIVE DISTANCE SINDIF = SIN( DSTEFF/C(1) ) COSDIF = SQRT( (1.D0-SINDIF)*(1.D0+SINDIF) ) COSTHENEW = W(NP)*COSDIF IF ( ABS(W(NP)) .LT. 1.D0 ) COSTHENEW = * COSTHENEW - SINDIF * SQRT( (1.D0-W(NP))*(1.D0+W(NP)) ) IF ( FEGSDB ) WRITE(MDEBUG,*) 'PHOTON: COSDIF,COSTHENEW=', * SNGL(COSDIF),SNGL(COSTHENEW) W(NP) = MIN( 1.D0, COSTHENEW ) #if __UPWARD__ W(NP) = MAX( -1.D0, W(NP) ) #endif ENDIF C KILL HORIZONTAL OR UPWARD GOING PARTICLES IF ( W(NP) .LE. WCUT ) THEN IDISC = 1 IRETC = .FALSE. GOTO 1000 ENDIF ZAP(NP) = - (C(1)-Z(NP)) * WA(NP) + C(1) IF ( FFLATOUT ) THEN C ANGLE DIF MIGHT BE LARGE (DUE TO CUT ON APPARENT HEIGHT) c X(NP) = (C(1)-ZAP(NP)) * TAN( X(NP)/C(1) ) c Y(NP) = (C(1)-ZAP(NP)) * TAN( Y(NP)/C(1) ) c Z(NP) = ZAP(NP) IF ( WA(NP) .NE. 1.D0 ) THEN C WE ARE AWAY FROM DETECOR C CALCULATE AZIMUTH ANGLE OF PARTICLE SEEN FROM DETECTOR IF ( Y(NP) .NE. 0.D0 .OR. X(NP) .NE. 0.D0 ) THEN PHI1 = ATAN2( Y(NP), X(NP) ) ELSE PHI1 = 0.D0 ENDIF SINTEA = SQRT( (1.D0-WA(NP))*(1.D0+WA(NP)) ) C HORIZONTAL DISTANCE OF PARTICLE TO DETECTOR RRR = ( -ZAP(NP) + C(1) ) * SINTEA / WA(NP) C UPDATE COORDINATES OF STARTING POINT IN A FLAT ATMOSPHERE (FOR UPDATE) X(NP) = RRR * COS( PHI1 ) Y(NP) = RRR * SIN( PHI1 ) Z(NP) = ZAP(NP) ELSE C WE ARE IN THE DETECTOR SYSTEM AND NEED NO COORDINATE CALCULATION ENDIF WAP(NP) = 0.D0 ENDIF IF ( U(NP) .NE. 0.D0 ) THEN TANPHI = V(NP)/U(NP) IF ( ABS(W(NP)) .LT. 1.D0 ) THEN U(NP) = SIGN(1.D0,U(NP)) * * SQRT( (1.D0-W(NP))*(1.D0+W(NP))/(1.D0+TANPHI**2) ) ELSE U(NP) = 0.D0 ENDIF V(NP) = TANPHI * U(NP) ELSE IF ( V(NP) .NE. 0.D0 .AND. ABS(W(NP)) .LT. 1.D0 ) THEN V(NP) = SIGN(1.D0,V(NP))*SQRT( (1.D0-W(NP))*(1.D0+W(NP)) ) ELSE V(NP) = 0.D0 ENDIF ENDIF #if __UPWARD__ IF ( W(NP) .GT. 0.D0 ) THEN IF ( PRMPAR(15) .GE. 0.D0 ) THEN USTEP = -(Z(NP)+OBSLVL(1))/W(NP) ELSE IF ( FEGSDB ) WRITE(MDEBUG,*)'PHOTON: DOWNWARD GOING PARTI' * ,'CLE IN UPWARD GOING SHOWER SHOULD NOT REACH DETECTOR !' IDISC = 1 IRETC = .FALSE. GOTO 1000 ENDIF ELSEIF ( W(NP) .LT. 0.D0 ) THEN IF ( PRMPAR(15) .LT. 0.D0 ) THEN USTEP = -(Z(NP)+OBSLVL(1))/W(NP) ELSE IF ( FEGSDB ) WRITE(MDEBUG,*)'PHOTON: UPWARD GOING PARTICL' * ,'E IN DOWNWARD GOING SHOWER SHOULD NOT REACH DETECTOR !' IDISC = 1 IRETC = .FALSE. GOTO 1000 ENDIF ELSE C HORIZONTAL MOVEMENT IDISC = 1 IRETC = .FALSE. GOTO 1000 ENDIF #else USTEP = -(Z(NP)+OBSLVL(1))/W(NP) #endif IF ( FEGSDB ) THEN WRITE(MDEBUG,*) 'PHOTON: CORR. FOR DET. ARRIVAL:USTEP=',USTEP CALL AUSGB2 ENDIF USTEP = MAX( USTEP, 0.0001D0 ) IPASC = 1 ELSE C NORMAL TRANSPORT STEP FAR AWAY FROM DETECTOR IPASC = 0 ENDIF #else #if __SLANT__ XOLD = X(NP) YOLD = Y(NP) #endif #endif VSTEP = USTEP TVSTEP = VSTEP C NO ENERGY DEPOSITION ON GAMMA TRANSPORT EDEP = 0.D0 USTEPU = USTEP DISC = W(NP)*USTEPU*HBAROI(IRL) IF ( DISC .NE. 0.D0 ) THEN USTEPU = USTEPU * (EXP( DISC )-1.D0) / (DISC*ALTEXP) ELSE USTEPU = USTEPU/ALTEXP ENDIF USTEPU = MAX( USTEPU, .0001D0 ) #if __UPWARD__ C LIMIT UPWARD GOING PARTICLES TO THE BORDER OF ATMOSPHERE ZNEWUP = Z(NP) + USTEP*W(NP) IF ( -ZNEWUP .GE. BOUND(1)-1.D0 ) THEN IRETC = .FALSE. GOTO 1000 ELSEIF ( -ZNEWUP .LE. BOUND(6) ) THEN IRETC = .FALSE. GOTO 1000 ENDIF #endif X(NP) = X(NP)+U(NP)*USTEP Y(NP) = Y(NP)+V(NP)*USTEP Z(NP) = Z(NP)+W(NP)*USTEP #if __CURVED__ IF ( IPASC .EQ. 0 .OR. .NOT.FFLATOUT ) THEN C NORMAL TRANSPORT STEP FAR AWAY FROM DETECTOR C HORIZONTAL COMPONENT OF TRACK LENGTH SQUARED TRANS2 = (X(NP)-XOLD)**2 + (Y(NP)-YOLD)**2 C TRANSPORT AT MINIMUM .001 MM TRANS2 = MAX( TRANS2, 0.00001D0 ) C NEW COORDINATE FRAME, NEW ACTUAL HEIGHT AT NEW THICKNESS GRADIENT C (CALCULATED WITH PARAMETERS OF OLD COORDINATE FRAME) AUXIL = SQRT( TRANS2 + (C(1)-Z(NP))**2 ) ZNEW = C(1) - AUXIL C CALCULATE ANGLE DIFFERENCE BETWEEN OLD AND NEW FRAME SINDIF = SQRT( TRANS2 ) / AUXIL COSDIF = (C(1)-Z(NP)) / AUXIL IF ( FEGSDB ) WRITE(MDEBUG,560) COSDIF,SINDIF,-Z(NP),-ZNEW 560 FORMAT(/,' PHOTON: COSDIF,SINDIF,-Z,-ZNEW=',2F18.15,1P,2E17.9) COSDIF = MIN( 1.D0, COSDIF ) C TRANSPORT DISTANCE IS CORRECTED TO GET DISTANCE AT EARTH'' SURFACE CORR = C(1) * ASIN( SINDIF ) / ( (C(1)-ZNEW)*SINDIF ) X(NP) = XOLD + (X(NP)-XOLD) * CORR Y(NP) = YOLD + (Y(NP)-YOLD) * CORR Z(NP) = ZNEW C IN FIRST ORDER APPROXIMATION W(NP) AND COSDIF ARE IN THE SAME PLANE C OF PARTICLE MOVEMENT, THEREFORE THE ANGLES MAY BE ADDED DIRECTLY COSTHENEW = W(NP)*COSDIF IF ( ABS(W(NP)) .LT. 1.D0 ) COSTHENEW = * COSTHENEW - SINDIF*SQRT( (1.D0-W(NP))*(1.D0+W(NP)) ) W(NP) = MIN( 1.D0, COSTHENEW ) #if __UPWARD__ W(NP) = MAX( -1.D0, W(NP) ) #endif C KILL HORIZONTAL OR UPWARD GOING PARTICLES IF ( W(NP) .LE. WCUT ) THEN IDISC = 1 IRETC = .FALSE. GOTO 1000 ENDIF IF ( FEGSDB ) THEN WRITE(MDEBUG,562) WA(NP),-ZAP(NP) 562 FORMAT(' PHOTON: WA,-ZAP=',F18.15,1P,E17.9) WRITE(MDEBUG,557) U(NP),-V(NP),W(NP),X(NP),-Y(NP),-Z(NP) 557 FORMAT(' PHOTON: STEPEND=',1P,6E16.8,0P) ENDIF C CALCULATE ANGLES IN THE NEW FRAME AUXILSQ = SQRT( X(NP)**2 + Y(NP)**2 ) WA(NP) = COS( AUXILSQ/C(1) ) WA(NP) = MIN( 1.D0, WA(NP) ) ZAP(NP) = C(1) - (C(1)-ZNEW) * WA(NP) AUX2SQ = SQRT( (C(1)-ZNEW)**2*(1.D0-WA(NP))*(1.D0+WA(NP)) * + (-ZAP(NP)-OBSLVL(1))**2 ) IF ( AUX2SQ .GT. 0.D0 ) THEN WAP(NP) = -(OBSLVL(1)+ZAP(NP)) / AUX2SQ ELSE C PARTICLE REACHED THE GROUND AT CORE POSITION WAP(NP) = 0.D0 ENDIF IF ( FEGSDB ) WRITE(MDEBUG,*) 'PHOTON: WAP,ZAP=',WAP(NP),ZAP(NP) WAP(NP) = MIN( 1.D0, WAP(NP) ) IF ( U(NP) .NE. 0.D0 ) THEN TANPHI = V(NP)/U(NP) IF ( ABS(W(NP)) .LT. 1.D0 ) THEN U(NP) = SIGN(1.D0,U(NP)) * * SQRT( (1.D0-W(NP))*(1.D0+W(NP))/(1.D0+TANPHI**2) ) ELSE U(NP) = 0.D0 ENDIF V(NP) = TANPHI * U(NP) ELSE IF ( V(NP) .NE. 0.D0 .AND. ABS(W(NP)) .LT. 1.D0 ) THEN V(NP) = SIGN(1.D0,V(NP))*SQRT( (1.D0-W(NP))*(1.D0+W(NP)) ) ELSE V(NP) = 0.D0 ENDIF ENDIF IF ( WA(NP) .NE. 1.D0 ) THEN C WE ARE AWAY FROM DETECOR C CALCULATE AZIMUTH ANGLE OF PARTICLE SEEN FROM DETECTOR IF ( Y(NP) .NE. 0.D0 .OR. X(NP) .NE. 0.D0 ) THEN PHI1 = ATAN2( Y(NP), X(NP) ) ELSE PHI1 = 0.D0 ENDIF C HORIZONTAL DISTANCE OF PARTICLE TO DETECTOR RRR = SQRT( (1.D0-WA(NP))*(1.D0+WA(NP)) ) * * ( C(1) - ZAP(NP) ) / WA(NP) XXX = RRR * COS( PHI1 ) YYY = RRR * SIN( PHI1 ) ELSE C WE ARE IN THE DETECTOR SYSTEM AND NEED NO COORDINATE CALCULATION XXX = X(NP) YYY = Y(NP) ENDIF C STORE COORDINATES IN THE DETECTOR SYSTEM XXXX(NP) = XXX YYYY(NP) = YYY ELSE ZAP(NP) = Z(NP) XXXX(NP) = X(NP) YYYY(NP) = Y(NP) ENDIF TDIFF = TVSTEP*VCI IF ( VSTEP .GT. 1.D-10 ) THEN C SPEED OF PARTICLE IN LOCAL FRAME SPEED0 = USTEP C SPEED OF PARTICLE IN OBSERVER FRAME SPEED = SQRT(( XXXX(NP) - XXXOLD )**2 * +( YYYY(NP) - YYYOLD )**2 * +( ZAP(NP) - ZAPOLD )**2 ) IF ( FEGSDB ) WRITE(MDEBUG,*)'PHOTON: USTEP/TDIFF,S/S0=' * ,USTEP/TDIFF/C(25),SPEED/SPEED0 ELSE SPEED0 = 1.D0 SPEED = 1.D0 ENDIF C FIX TIME DIFFERENCE DUE TO FRAME SHIFT : SPEED IN LOCAL FRAME C (AFTER UPDATE) SHOULD BE THE SAME AS IN OBSERVER FRAME TIM(NP) = TIM(NP) + TDIFF * SPEED/SPEED0 IF ( ABS(USTEP) .GT. 1.D1 .AND. & ABS(SPEED/SPEED0-1.D0) .GT. 1.D-1 ) THEN IF ( DEBUG ) WRITE(MONIOU,'(A,F5.2)') & 'WARNING: SPEED CORRECTION PHO > 10% -> OK IF RARE',SPEED/SPEED0 IF ( DEBDEL ) THEN MCOUNT = MCOUNT + 1 WRITE(MDEBUG,*) 'PHOTON: MCOUNT = ',MCOUNT IF ( MCOUNT .GE. JCLOCK ) FEGSDB = .TRUE. IF ( MCOUNT .GE. JCLOCK+10 ) FEGSDB = .FALSE. IF ( MCOUNT .GE. NDEBDL ) DEBUG = .TRUE. IF ( MCOUNT .GE. NDEBDL+10 ) DEBUG = .FALSE. ENDIF ENDIF #else TIM(NP) = TIM(NP) + TVSTEP*VCI #endif #if __PARALLEL__ C PLOTS IF NOTHING STORED IN 2ND STACK TRACKING AGAIN PRIMARY PARTICLE IF ( FNPRIM .OR. JCOUNT .LE. 1 ) THEN #endif #if __PLOTSH__ IF ( PLOTSH ) THEN C DON''T PLOT EM-PRIMARY BEFORE THE FIRST INTERACT EXCEPT FOR TMARGIN IF ( FNPRIM .OR. TMARGIN ) THEN C END OF TRACKING STEP TRX2 = X(NP) TRY2 = -Y(NP) #if __CURVED__ TRZ2 = -ZAP(NP) #else TRZ2 = -Z(NP) #endif TRT2 = TIM(NP) WRITE(55) TRID,TRE,TRX1,TRY1,TRZ1,TRT1, * TRX2,TRY2,TRZ2,TRT2 #if __THIN__ * ,WT(NP) #endif NPLEM = NPLEM + 1 IF ( DEBUG ) THEN WRITE(MDEBUG,2552) TRID,TRE,TRX1,TRY1,TRZ1,TRT1, * TRX2,TRY2,TRZ2,TRT2 2552 FORMAT(' TRACKINFEM ',1P,6E15.5,/,42X,4E15.5) ENDIF ENDIF ENDIF #endif #if __PLOTSH2__ IF ( PLOTSH .AND. TIM(NP) .LT. PLTCUT ) THEN C DON''T PLOT EM-PRIMARY BEFORE THE FIRST INTERACT EXCEPT FOR TMARGIN IF ( FNPRIM .OR. TMARGIN ) THEN C END OF TRACKING STEP, APPLY TIME CUT TRX2 = X(NP) TRY2 = -Y(NP) #if __CURVED__ TRZ2 = -ZAP(NP) #else TRZ2 = -Z(NP) #endif TRT2 = TIM(NP) #if __THIN__ WGHT = WT(NP) #endif IF ( FBOXCUT ) CALL PLTRUNC IF ( ( TRID .LE. 1.D0 .AND. TRE .GT. PLCUT(4) ) .OR. * ( ( TRID .EQ. 2.D0 .OR. TRID .EQ. 3.D0 ) .AND. * TRE .GT. PLCUT(3) ) ) THEN C X-Y AND OTHER PROJECTIONS (E.M.-> MAP 1) CALL LINPLXY( 1,TRX1,TRY1,TRX2,TRY2,WGHT ) CALL LINPLXZ( 1,TRX1,TRZ1,TRX2,TRZ2,WGHT ) CALL LINPLYZ( 1,TRY1,TRZ1,TRY2,TRZ2,WGHT ) IF ( DEBUG ) THEN WRITE(MDEBUG,2553) TRID,TRE,TRX1,TRY1,TRZ1,TRT1, * TRX2,TRY2,TRZ2,TRT2 2553 FORMAT(' TRACKINFEM2 ',1P,6E15.5,/,43X,4E15.5) ENDIF ENDIF ENDIF ENDIF #endif C ADD GAMMAS TO THE LONGITUDINAL DEVELOPMENT IF ( LLONGI ) THEN #if __SLANT__ #if __CURVED__ AUXNEW = XXXX(NP)*STHCPH - YYYY(NP)*STHSPH + ZAP(NP)*CTH + RLOFF AUXOLD = XXXOLD *STHCPH - YYYOLD *STHSPH + ZAPOLD *CTH + RLOFF #else AUXOLD = XOLD *STHCPH - YOLD *STHSPH + ZOLD *CTH + RLOFF AUXNEW = X(NP)*STHCPH - Y(NP)*STHSPH + Z(NP)*CTH + RLOFF #endif #endif #if __COASTUSERLIB__ C END OF TRACKING STEP pnt2id = 1 pnt2gen= igen(np) #if __CURVED__ pnt2x = XXXX(NP) pnt2y = -YYYY(NP) pnt2z = -ZAP(NP) #else pnt2x = X(NP) - XOFF(NOBSLV) pnt2y = -Y(NP) - YOFF(NOBSLV) pnt2z = -Z(NP) #endif #if __SLANT__ pnt2d = THCKSI( AUXNEW ) #else pnt2d = THICK( -Z(NP) )/COS( THETAP ) #endif pnt2t = TIM(NP) pnt2e = PEIG * 0.001D0 #if __THIN__ pnt2w = WT(NP) #else pnt2w = 1.D0 #endif call track(pnt1x, pnt2x) #endif C FIND FIRST THE EQUIVALENT LEVELS #if __SLANT__ C IF STARTING POINT BEYOND FURTHEST LEVEL THEN DON''T CHECK IF ( RLONG(NSTEP) .GT. AUXOLD ) THEN T1 = TSLAN(NP) #else C IF STARTING POINT BELOW LOWEST LEVEL THEN DON''T CHECK IF ( HLONG(NSTEP) .LE. -ZOLD ) THEN #endif LPCT1 = LPCTE(NP) #if __UPWARD__ || __SLANT__ #if __SLANT__ IF ( AUXNEW .GT. AUXOLD ) THEN C FORWARD MOVING PARTICLE #else IF ( W(NP) .GT. 0.D0 ) THEN C DOWNWARD MOVING PARTICLE #endif #endif C Z NEW IS PROBABLY ONLY LITTLE BELOW Z OLD, DO INCREMENTAL SEARCH #if __SLANT__ DO I1 = LPCT1, NSTEP+1 IF ( RLONG(I1) .GT. AUXNEW ) GOTO 6003 #else DO I1 = LPCT1, NSTEP IF ( HLONG(I1) .LT. -Z(NP) ) GOTO 6003 #endif ENDDO I1 = NSTEP + 1 6003 CONTINUE LPCT2 = I1 - 1 C STORE END POINT AS POSSIBLE STARTPOINT OF NEXT TRACK LPCTE(NP) = LPCT2 + 1 #if __SLANT__ AUXNEW = MIN( AUXNEW, RLONG(NSTEP+1) ) TSLAN(NP) = THCKSI( AUXNEW ) #endif C ARE WE AT OBSERVATION LEVEL OR ATMOSPHERIC BOUNDARY? IF ( IDISC .LT. 0 ) LPCT2 = LPCT2+1 DO I = LPCT1, LPCT2 #if __THIN__ PLONG(I,1) = PLONG(I,1) + WT(NP) ELONG(I,1) = ELONG(I,1) + E(NP) * 1.D-3 * WT(NP) #else PLONG(I,1) = PLONG(I,1) + 1.D0 ELONG(I,1) = ELONG(I,1) + E(NP) * 1.D-3 #endif ENDDO #if __UPWARD__ || __SLANT__ #if __SLANT__ ELSEIF ( AUXNEW .LT. AUXOLD ) THEN C BACKWARD MOVING PARTICLE #else ELSEIF ( W(NP) .LT. 0.D0 ) THEN C UPWARD MOVING PARTICLE #endif C Z_NEW IS PROBABLY ONLY LITTLE ABOVE Z_OLD: INCREMENTAL SEARCH DO I1 = LPCT1-1, 0, -1 #if __SLANT__ IF ( RLONG(I1) .LE. AUXNEW ) GOTO 6004 #else IF ( HLONG(I1) .GT. -Z(NP) ) GOTO 6004 #endif ENDDO I1 = 0 6004 CONTINUE LPCT2 = MAX( I1, 0 ) LPCTE(NP) = LPCT2 + 1 #if __SLANT__ AUXNEW = MIN( AUXNEW, RLONG(NSTEP+1) ) TSLAN(NP) = THCKSI( AUXNEW ) #endif DO I = LPCT2+1, LPCT1-1 #if __THIN__ PLONG(I,1) = PLONG(I,1) + WT(NP) ELONG(I,1) = ELONG(I,1) + E(NP) * 1.D-3 * WT(NP) #else PLONG(I,1) = PLONG(I,1) + 1.D0 ELONG(I,1) = ELONG(I,1) + E(NP) * 1.D-3 #endif ENDDO ELSE C HORIZONTALLY MOVING GAMMAS: THEY CROSS NO BOUNDARY, NO ACTION C AS PARTICLE WAS ATTIBUTED TO BIN LPCT1 ALREADY IN PREVIOUS STEP ENDIF #endif ENDIF ENDIF #if __PARALLEL__ ENDIF #endif C SKIP TO FIRST INTERACTION TREATMENT IF ( .NOT. FNPRIM ) THEN IF ( FIX1I .AND. FIXHEI .GT. -Z(1) ) THEN Z(1) = -FIXHEI IDISC = 0 GOTO 1033 ENDIF ENDIF C DEDUCT FROM DISTANCE TO NEAREST BOUNDARY DNEAR(NP) = DNEAR(NP)-USTEP IF ( MEDIUM .NE. 0 ) THEN DPMFP = MAX( 0.D0, DPMFP-USTEPU/GMFP ) ENDIF IROLD = IR(NP) MEDOLD = MEDIUM #if __CURVED__ IF ( IDISC .GE. 0 ) THEN IF ( -Z(NP) .LT. BOUND(IRNEW) ) THEN IRNEW = IRNEW + 1 IF ( IRNEW .GE. 6 ) THEN C PARTICLE WILL REACH GROUND, TRANSPORT AND ELIMINATE AFTERWARDS IDISC = -2 ENDIF ELSEIF ( ( -Z(NP) .GT. BOUND(IRNEW-1) ) .OR. * ( ( -Z(NP) .EQ. BOUND(IRNEW-1) ) .AND. * ( W(NP) .LE. 0.003D0 ) ) ) THEN IRNEW = IRNEW - 1 IF ( IRNEW .LE. 1 ) THEN C PARTICLE WILL LEAVE ATMOSPHERE, TRANSPORT AND ELIMINATE AFTERWARDS IDISC = -2 ENDIF ENDIF ENDIF #endif IF ( IRNEW .NE. IROLD ) THEN C CHANGE OF LAYER IR(NP) = IRNEW IRL = IRNEW MEDIUM = MED(IRL) ENDIF C LOOK FOR OBSERVATION LEVEL AND GIVE TO OUTPUT IF ( NEWOBS .GT. IOBS(NP) ) THEN #if __PARALLEL__ C IF NOTHING STORED IN 2ND STACK TRACKING AGAIN PRIMARY PARTICLE IF ( FNPRIM .OR. JCOUNT .LE. 1 ) THEN #endif CALL AUSGAB #if __PARALLEL__ ENDIF #endif IOBS(NP) = NEWOBS #if __UPWARD__ ELSEIF ( NEWOBS .LT. IOBS(NP) ) THEN IOBS(NP) = NEWOBS #if __PARALLEL__ C IF NOTHING STORED IN 2ND STACK TRACKING AGAIN PRIMARY PARTICLE IF ( FNPRIM .OR. JCOUNT .LE. 1 ) THEN #endif CALL AUSGAB #if __PARALLEL__ ENDIF #endif #endif ENDIF #if __CURVED__ IF ( TIM(NP) .GT. TIMLIM ) THEN C CHECK WHETHER PARTICLE EXCEEDS TIME LIMIT IF ( DEBUG .OR. LTMLMPR ) WRITE(MDEBUG,570) 570 FORMAT(' PHOTON: PARTICLE ELIMINATED BECAUSE OF TIME LIMIT,', * ' PLEASE READ THE USERS GUIDE,', * ' SEE KEYWORD: TIMLIM') IRETC = .FALSE. GOTO 1000 ENDIF #endif IF ( IDISC .LT. 0 ) THEN IRETC = .TRUE. IF ( FNPRIM ) THEN #if __UPWARD__ C ADD ENERGY OF PARTICLE LEAVING THE ATMOSPHERE TO DLONG C AND JUMP TO END OF ROUTINE IF ( IDISC .EQ. -2 ) GOTO 1000 #endif C AS WE HAVE ADDED GAMMA ENERGY TO DLONG IN OUTPT1, DON''T C ADD IT HERE AND JUMP TO END OF ROUTINE GOTO 1001 ENDIF GOTO 1033 ENDIF IF ( MEDIUM .NE. MEDOLD ) GOTO 1031 C SKIP BACK IF STEP LENGTH NOT YET TOTALLY EXHAUSTED IF ( MEDIUM .NE. 0 .AND. DPMFP .LE. 1.D-10 ) GOTO 1032 GOTO 1041 1032 CONTINUE C RAYLEIGH SCATTERING IF ( IRAYLR(IRL) .EQ. 1 ) THEN CALL RMMARD( RD,1,2 ) IF ( RD(1) .LE. 1.D0-COHFAC ) THEN 1050 CONTINUE CALL RMMARD( RD,1,2 ) LXXX = RCO1*RD(1)+RCO0 X2 = RSCT1(LXXX)*RD(1)+RSCT0(LXXX) Q2 = X2*RMSQ*.23547885D-02 COSTHE = 1.D0-Q2/(2.D0*E(NP)**2) IF ( ABS(COSTHE) .GT. 1.D0 ) GOTO 1050 CSQTHE = COSTHE**2 REJF = (1.D0+CSQTHE)*.5D0 CALL RMMARD( RD,1,2 ) IF ( RD(1) .GT. REJF ) GOTO 1050 SINTHE = SQRT( MAX( 0.D0, 1.D0-CSQTHE ) ) CALL UPHI( 2,1 ) GOTO 981 ENDIF ENDIF 1033 CONTINUE IF ( .NOT. FNPRIM ) THEN C DETERMINE THE ALTITUDE OF THE FIRST INTERACTION IF ( .NOT. TMARGIN ) THEN X(1) = 0.D0 Y(1) = 0.D0 #if !__CURVED__ U(1) = SECPAR(3) V(1) = -SECPAR(4) W(1) = SECPAR(2) #endif ENDIF IF ( FIX1I ) THEN C IF HEIGHT OF FIRST INTERACTION IS FIXED, TAKE STARTING ANGLES OF C PRIMARY PARTICLE Z(1) = -FIXHEI NP = 1 #if !__CURVED__ && __SLANT__ AUXIL1 = X(1)*STHCPH - Y(1)*STHSPH + Z(1)*CTH + RLOFF TSLAN(1) = THCKSI( AUXIL1 ) LPCTE(1) = MIN( NSTEP+1, INT( TSLAN(1)*THSTPI ) + 1 ) #else LPCTE(1) = MIN( NSTEP, INT( THICK( FIXHEI )*THSTPI ) + 1 ) #endif DNEAR(NP) = 0.D0 U(1) = SECPAR(3) V(1) = -SECPAR(4) W(1) = SECPAR(2) ENDIF #if __CURVED__ C CHECK CONSISTENCY OF COORDINATES IF ( .NOT. TMARGIN ) THEN CALL CORNEC ENDIF IF ( FIX1I ) THEN IF ( WA(1) .NE. 1.D0 ) THEN C WE ARE AWAY FROM DETECOR C CALCULATE AZIMUTH ANGLE OF PARTICLE SEEN FROM DETECTOR IF ( Y(1) .NE. 0.D0 .OR. X(1) .NE. 0.D0 ) THEN PHI1 = ATAN2( Y(1), X(1) ) ELSE PHI1 = 0.D0 ENDIF C HORIZONTAL DISTANCE OF PARTICLE TO DETECTOR RRR = SQRT( (1.D0-WA(NP))*(1.D0+WA(NP)) ) * * ( C(1) - ZAP(NP) ) / WA(NP) XXX = RRR * COS( PHI1 ) YYY = RRR * SIN( PHI1 ) ELSE C WE ARE IN THE DETECTOR SYSTEM AND NEED NO COORDINATE CALCULATION XXX = X(1) YYY = Y(1) ENDIF #if __SLANT__ AUXIL1 = XXX*STHCPH - YYY*STHSPH + ZAP(NP)*CTH + RLOFF TSLAN(1) = THCKSI( AUXIL1 ) LPCTE(1) = MIN( NSTEP+1, INT( TSLAN(1)*THSTPI ) + 1 ) #endif ENDIF C STORE COORDINATES IN THE DETECTOR SYSTEM XXXX(1) = XXX YYYY(1) = YYY #endif EVTH(6) = 0. IF ( TMARGIN ) THEN C NEGATIVE FIRST INTERACTION HEIGHT,IF TRACKING STARTS AT ATMOS. MARGIN EVTH(7) = Z(1) ELSE EVTH(7) = -Z(1) ENDIF C UPDATE PRMPAR PRMPAR(5) = -Z(1) PRMPAR(6) = TIM(1) #if __CURVED__ PRMPAR(14) = -ZAP(1) PRMPAR(16) = WA(1) PRMPAR(7) = XXXX(1) PRMPAR(8) = -YYYY(1) #else PRMPAR(7) = X(1) - XOFF(NOBSLV) PRMPAR(8) = -Y(1) - YOFF(NOBSLV) #endif #if __CERENKOV__ && __IACT__ CALL TELEVT( EVTH,PRMPAR ) #endif #if __COMPACT__ IF ( COMOUT ) THEN IF ( EVTH(2) .LT. 1.5 ) THEN CALL TOBUFS( EVTH,MAXBUF ) ELSE CEVTH = 'EVHW' CALL TOBUFS( EVTH,12 ) ENDIF ELSE CALL TOBUF( EVTH,0 ) ENDIF #else #if __PARALLEL__ C WREVTH SIGNALS THAT EVTH HAS BEEN WRITTEN OUT WREVTH = .TRUE. #endif CALL TOBUF( EVTH,0 ) #endif #if __CERENKOV__ C OUTPUT OF EVENTHEADER TO THE CHERENKOV FILE IF ( MCERFI .NE. 0 ) THEN DO I = 1, NCERBUF CALL TOBUFC( EVTH,0,I ) ENDDO ENDIF #endif #if __CURVED__ IF ( .NOT. TMARGIN ) THEN TIM(1) = 0.D0 ENDIF #else IF ( .NOT. TMARGIN ) THEN CALL COORIN( -Z(1) ) #if __AUGERHIST__ HEIGHTP = -Z(1) #endif TIM(1) = 0.D0 ENDIF #endif #if __THIN__ WT(1) = 1.D0 #endif FNPRIM = .TRUE. IF ( FPRINT ) THEN WRITE(KMPO,*)' FIRST INTERACTION AT ',ABS(EVTH(7)*0.01D0), * ' M ALTITUDE' ENDIF #if __ANAHIST__ && !__CONEX__ C DETERMINE PARAMETERS OF THE SHOWER FRONT FOR HISTOGRAMS CALL SHOWERFRONT #endif C FILL CURPAR TO UPDATE PRMPAR AFTER BOX3 CALL FOR PRIMARY PARTICLE DO I = 5, 8 CURPAR(I) = PRMPAR(I) ENDDO #if __CURVED__ CURPAR(14) = PRMPAR(14) CURPAR(16) = PRMPAR(16) #endif #if __PARALLEL__ C INFORMATION ABOUT FIRST INTERACTION STORED BUT THEN RETURN BEFORE INTERACTION IF ( JCOUNT .GT. 1 ) THEN NP = 0 !RESET PARTICLE INDEX IRCODE = 3 FEGSDB = .false. RETURN ENDIF #endif IF ( IDISC .LT. 0 ) THEN C OBVIOUSLY THE PRIMARY HAS PASSED THROUGH TOTAL ATMOSPHERE. #if __UPWARD__ C ADD ENERGY OF PARTICLE LEAVING THE ATMOSPHERE TO DLONG C AND JUMP TO END OF ROUTINE IF ( IDISC .EQ. -2 ) GOTO 1000 #endif C AS WE HAVE ADDED GAMMA ENERGY TO DLONG IN OUTPT1, DON''T C ADD IT HERE AND JUMP TO END OF ROUTINE GOTO 1001 ENDIF ENDIF C THIS RANDOM NUMBER DETERMINES WHICH INTERACTION CALL RMMARD( RD,1,2 ) GBR4 = GBR41(LGLE)*GLE+GBR40(LGLE) #if __INTTEST__ GBR4 = 1.D0 #endif IF ( RD(1) .GE. GBR4 .AND. E(NP) .GT. PRMT2 ) THEN C E+E- PAIR FORMATION #if __THIN__ CALL PAIRLPM( FPASS ) IF ( FPASS ) GOTO 981 IF ( IQ(NP) .EQ. 3 ) THEN EKENP = E(NP) - PRM EKENP1 = E(NP-1) + PRM ELSE EKENP = E(NP) + PRM EKENP1 = E(NP-1) - PRM ENDIF IF ( EKENP .LT. ETHINN ) THEN EKG = PEIG CALL THIN( EKG,EKENP1,EKENP ) ENDIF #else #if __LPM__ || __PARALLEL__ || __MULTITHIN__ CALL PAIRLPM( FPASS ) IF ( FPASS ) GOTO 981 #else CALL PAIR #endif #endif #if __MULTITHIN__ IF ( IQ(NP) .EQ. 3 ) THEN EKENP = E(NP) - PRM EKENP1 = E(NP-1) + PRM ELSE EKENP = E(NP) + PRM EKENP1 = E(NP-1) - PRM ENDIF EKG = PEIG CALL THIN2( EKG,EKENP1,EKENP ) #endif RETURN ENDIF GBR3 = GBR31(LGLE)*GLE+GBR30(LGLE) #if __INTTEST__ GBR3 = 1.D0 #endif IF ( RD(1) .GE. GBR3 ) THEN C COMPTON SCATTERING CALL COMPT #if __THIN__ IF ( IQ(NP) .NE. 1 ) THEN EKENP = E(NP) - PRM EKENP1 = E(NP-1) ELSE EKENP = E(NP) EKENP1 = E(NP-1) - PRM ENDIF IF ( EKENP .LT. ETHINN ) THEN EKG = PEIG CALL THIN( EKG,EKENP1,EKENP ) ENDIF #endif #if __MULTITHIN__ IF ( IQ(NP) .NE. 1 ) THEN EKENP = E(NP) - PRM EKENP1 = E(NP-1) ELSE EKENP = E(NP) EKENP1 = E(NP-1) - PRM ENDIF EKG = PEIG CALL THIN2( EKG,EKENP1,EKENP ) #endif IF ( IQ(NP) .NE. 1 ) RETURN GOTO 1060 ENDIF GBR1 = GBR11(LGLE)*GLE+GBR10(LGLE) #if __INTTEST__ GBR1 = 0.D0 #endif C INCREASE MU-PAIR PRODUCTION THRESHOLD BY MUON CUT ENERGY C TO PREVENT HANGUP IN SUBR. MUPAIR IF ( RD(1) .LE. GBR1 .AND. E(NP) .GT. RMMUT4 * + ELCUT(2) * 1.D3 ) THEN C MU+MU- PAIR FORMATION CALL MUPAIR IF ( NP .EQ. 0 ) IRCODE = 2 RETURN ENDIF GBR2 = GBR21(LGLE)*GLE+GBR20(LGLE) #if __INTTEST__ GBR2 = 1.D0 #endif IF ( RD(1) .LE. GBR2 .AND. E(NP) .GT. PITHR ) THEN C PHOTONUCLEAR REACTION CALL PIGEN( .TRUE. ) IF ( NP .EQ. 0 ) THEN IRCODE = 2 RETURN ENDIF RETURN ELSE C PHOTO EFFECT CALL PHOTO IF ( NP .EQ. 0 ) THEN IRCODE = 2 RETURN ENDIF IF ( IQ(NP) .EQ. 3 ) RETURN ENDIF 1060 CONTINUE PEIG = E(NP) C KILL HORIZONTAL OR UPWARD GOING PARTICLES IF ( W(NP) .LE. WCUT ) THEN IDISC = 1 IRETC = .FALSE. GOTO 1000 ENDIF IF ( PEIG .GE. PCUT(IRL) ) GOTO 980 970 CONTINUE IF ( PEIG .GT. AP ) THEN C GAMMA FALLS BELOW ENERGY CUT IDR = 1 ELSE IDR = 2 ENDIF EDEP = PEIG IF ( LLONGI ) THEN C CUTTED ENERGY TO LONGITUDINAL ENERGY SUMS [IN GEV] #if __THIN__ DLONG(LPCTE(NP),1) = DLONG(LPCTE(NP),1) + EDEP * 1.D-3 * WT(NP) #else DLONG(LPCTE(NP),1) = DLONG(LPCTE(NP),1) + EDEP * 1.D-3 #endif ENDIF #if __AUGERHIST__ E(NP) = 0.D0 DO LL = 1, NOBSLV C LOOK WHETHER DEPOSIT IS WITHIN 1 G/CM^2 BELOW OBSERVATION LEVEL IF ( -Z(NP) .LE. OBSLVL(LL) .AND. * -Z(NP) .GT. OBSLV2(LL) ) THEN VONWO = 'PHOTON1' CALL AUGECT( EDEP,LL,VONWO ) ELSEIF ( -Z(NP) .GT. OBSLVL(LL) ) THEN GOTO 111 ENDIF ENDDO 111 CONTINUE #endif IRCODE = 2 NP = NP-1 RETURN 1000 CONTINUE EDEP = PEIG C GAMMA FALLS BELOW CUT IF ( LLONGI ) THEN C CUTTED ENERGY TO LONGITUDINAL ENERGY SUMS [IN GEV] C ENERGY CUT IF ( IRETC ) THEN #if __THIN__ DLONG(LPCTE(NP),1) = DLONG(LPCTE(NP),1) + EDEP*1.D-3*WT(NP) ELSE C ANGULAR CUT DLONG(LPCTE(NP),11) = DLONG(LPCTE(NP),11) + EDEP*1.D-3*WT(NP) #else DLONG(LPCTE(NP),1) = DLONG(LPCTE(NP),1) + EDEP * 1.D-3 ELSE C ANGULAR CUT DLONG(LPCTE(NP),11) = DLONG(LPCTE(NP),11) + EDEP * 1.D-3 #endif ENDIF ENDIF #if __AUGERHIST__ E(NP) = 0.D0 IF ( IRETC ) THEN DO LL = 1, NOBSLV-1 C LOOK WHETHER DEPOSIT IS WITHIN 1 G/CM^2 BELOW OBSERVATION LEVEL IF ( -Z(NP) .LE. OBSLVL(LL) .AND. * -Z(NP) .GT. OBSLV2(LL) ) THEN VONWO = 'PHOTON2' CALL AUGECT( EDEP,LL,VONWO ) ELSEIF ( -Z(NP) .GT. OBSLVL(LL) ) THEN GOTO 112 ENDIF ENDDO 112 CONTINUE ELSE DO LL = 1, NOBSLV C LOOK WHETHER DEPOSIT IS WITHIN 1 G/CM^2 BELOW OBSERVATION LEVEL IF ( -Z(NP) .LE. OBSLVL(LL) .AND. * -Z(NP) .GT. OBSLV2(LL) ) THEN VONWO = 'PHOTON3' CALL AUGACT( EDEP,LL,VONWO ) ELSEIF ( -Z(NP) .GT. OBSLVL(LL) ) THEN GOTO 113 ENDIF ENDDO 113 CONTINUE ENDIF #endif 1001 CONTINUE IRCODE = 2 NP = NP-1 RETURN END *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE PIGEN( FNKGS ) C----------------------------------------------------------------------- C 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 SDPM 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 MUNUCL AND PHOTON. C ARGUMENT: C FNKGS = FLAG INDICATING THAT NKG MIGHT BE SUBTRACTED C----------------------------------------------------------------------- IMPLICIT NONE #define __BUFFSINC__ #define __EGSDEBINC__ #define __GENERINC__ #define __LONGIINC__ #define __MULTINC__ #define __NKGSUBINC__ #define __PAMINC__ #define __PARPARINC__ #define __RANDPAINC__ #define __RUNPARINC__ #define __STACKEINC__ #define __THNVARINC__ #if __MULTITHIN__ #define __MULTHININC__ #endif #if __INTTEST__ #define __TSTINTINC__ #endif #include "corsika.h" DOUBLE PRECISION ENERN,PEIG,REGPAR(0:MAXLEN),REGGEN,REGLVL DOUBLE PRECISION AUXIL,ECMVM,VMFRAC #if __EHISTORY__ DOUBLE PRECISION REGPAR2(0:MAXLEN) #endif INTEGER K LOGICAL FNKGS SAVE C----------------------------------------------------------------------- IF ( FEGSDB ) THEN WRITE(MDEBUG,1) NP,IR(NP),IOBS(NP) 1 FORMAT(' PIGEN : NP=',I3,' IR=',I3,' IOBS=',I3) CALL AUSGB2 ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) 'PIGEN : E=',E(NP)*.001D0 C INCREASE GENERATION COUNTER, WE HAVE HADRONIC INTERACTION IGEN(NP) = IGEN(NP) + 1 C WE HAVE PHOTONUCLEAR INTERACTION, INCREASE GEN. COUNTER BY 1.E8 IGEN(NP) = IGEN(NP) + 100000000 SECPAR(9) = IGEN(NP) SECPAR(10) = -Z(NP) #if __THIN__ SECPAR(13) = WT(NP) #endif #if __CURVED__ SECPAR(14) = -ZAP(NP) SECPAR(15) = WAP(NP) SECPAR(16) = WA(NP) #endif #if __PARALLEL__ C SET ECTFLG TO OFF SECPAR(39) = -1.D0 #endif #if __MULTITHIN__ DO K = 1, NMTHIN SECPAR(40+K) = WTM(K,NP) ENDDO #endif PEIG = E(NP) C SUBTRACT EM SUBSHOWER FROM NKG CALCULATION C WITH CORRECTION FOR ORIGIN OF GAMMA (MARCH 10, 1998) IF ( FNKG .AND. FNKGS ) THEN SECPAR(0) = 1.D0 SECPAR(2) = MIN( 1.D0, W(NP) ) SECPAR(3) = U(NP) SECPAR(4) = -V(NP) SECPAR(5) = -ZZOLD SECPAR(7) = XXOLD SECPAR(8) = -YYOLD ENERN = (-1.D-3)*PEIG CALL NKG( ENERN ) IF ( DEBUG ) WRITE(MDEBUG,*) 'PIGEN : NKG SUBTRACTED' ENDIF C SAVE CURPAR PARTICLE INTO REGISTER REGPAR DO K = 0, MAXLEN REGPAR(K) = CURPAR(K) #if __EHISTORY__ REGPAR2(K) = SECPAR(K) #endif ENDDO REGGEN = GEN REGLVL = ALEVEL CALL RMMARD( RD,1,2 ) IF ( RD(1) .GT. (PEIG-400.D0)*0.001D0 ) THEN C FOR ENERGIES BETWEEN 400 MEV AND 1400 MEV (=1000+400) DECIDE C BY CHANCE WHETHER ONE OR TWO PIONS ARE GENERATED C PIGEN1 TREATS THE PRODUCTION OF 1 PION INT_ICOUNT = 0 CALL PIGEN1 CALL TSTEND ELSEIF ( RD(1) .GT. (PEIG-2000.D0)*0.001D0 ) THEN 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 INT_ICOUNT = 0 CALL PIGEN2 CALL TSTEND ELSE 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 = 7.3D0 * (PAMA(13)+PAMA(14)) C THE FRACTION OF VECTOR MESON PRODUCTION IS FORMED IN THE CM-SYSTEM C OF THE PHOTON WITH A NUCLEON. THERFORE NUCLEON MASS (AUXIL) IS AUXIL = 0.5D0 * (PAMA(13)+PAMA(14)) C ENERGY IN CM SYSTEM (GEV); PEIG IS IN MEV 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) CALL RMMARD( RD,1,2 ) #if __INTTEST__ IF ( NDIF .EQ. 1 ) THEN C IN CASE OF NON-DIFFRACTIVE INTERACTIONS SUPPRESS VECT MES PRODUCTION RD(1) = 0.99D0 ELSEIF ( NDIF .EQ. 2 ) THEN C IN CASE OF DIFFRACTIVE INTERACTIONS TAKE ONLY VECTORMESON PRODUCTION RD(1) = 0.01D0 ELSEIF ( NDIF .EQ. 0 ) THEN C IN CASE OF 'MIXED' INTERACTIONS TAKE VECTOR MESON GENERATION AT RANDOM ENDIF #endif IF ( FEGSDB .OR. DEBUG ) WRITE(MDEBUG,*) 'PIGEN : VMFRAC,RD=', * SNGL(VMFRAC),SNGL(RD(1)) IF ( RD(1) .LT. VMFRAC ) THEN INT_ICOUNT = 0 CALL RHOGEN CALL TSTEND ELSE C AT HIGHER ENERGIES MORE THAN 2 PIONS ARE GENERATED BY HIGH ENERGY C HADRONIC INTERACTION MODEL C FILL CURRENT EGS4-PARTICLE INTO CURPAR ITYPE = 1 CURPAR(0) = 1.D0 CURPAR(1) = PEIG*1.D-3 CURPAR(2) = MIN( 1.D0, W(NP) ) CURPAR(3) = U(NP) CURPAR(4) = -V(NP) CURPAR(5) = -Z(NP) CURPAR(6) = TIM(NP) CURPAR(7) = X(NP) CURPAR(8) = -Y(NP) CURPAR(9) = 0.D0 CURPAR(10) = 1.D0 CURPAR(12) = SQRT( PAMA(14)*(PAMA(14) + PEIG*2.D-3) ) CURPAR(11) = ( PEIG*1.D-3 + PAMA(14) ) / CURPAR(12) #if __INTTEST__ GACM = CURPAR(11) BECM = SQRT( (GACM-1.D0) * (GACM+1.D0) ) / GACM ECMI = CURPAR(12) IF ( DEBUG ) WRITE(MDEBUG,*) 'PIGEN : GACM,BECM,ECM = ', * SNGL(GACM),BECM,SNGL(ECMI) #endif GEN = IGEN(NP) ALEVEL = -Z(NP) EKINL = CURPAR(1) #if __THIN__ CURPAR(13) = WT(NP) #endif #if __CURVED__ CURPAR(14) = -ZAP(NP) SECPAR(14) = -ZAP(NP) CURPAR(15) = WAP(NP) SECPAR(15) = WAP(NP) CURPAR(16) = WA(NP) SECPAR(16) = WA(NP) #endif #if __PARALLEL__ C SET ECTFLG TO OFF CURPAR(39) = -1.D0 #endif #if __MULTITHIN__ DO K = 1, NMTHIN CURPAR(40+K) = WTM(K,NP) ENDDO #endif IF ( LLONGI ) LHEIGH = LPCTE(NP) C ELIMINATE GAMMA FROM EGS-STACK NP = NP-1 C DPMJET, EPOS, HDPM, NEXUS, QGSJET, SIBYLL, VENUS GIVE ALL PARTICLES TO C SECPAR. COPY VERTEX COORDINATES INTO SECPAR FOR SECONDARIES DO K = 5, 8 SECPAR(K) = CURPAR(K) ENDDO INT_ICOUNT = 0 CALL SDPM( 0 ) CALL TSTEND C END OF MANY PION GENERATION ENDIF ENDIF C RESTORE CURPAR PARTICLE FROM REGPAR DO K = 0, MAXLEN CURPAR(K) = REGPAR(K) #if __EHISTORY__ SECPAR(K) = REGPAR2(K) #endif ENDDO GEN = REGGEN ALEVEL = REGLVL RETURN END *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE PIGEN1 C----------------------------------------------------------------------- C 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----------------------------------------------------------------------- IMPLICIT NONE #define __EGSDEBINC__ #define __ELABCTINC__ #define __LONGIINC__ #define __PAMINC__ #define __PARPARINC__ #define __PIONINC__ #define __RANDPAINC__ #define __RUNPARINC__ #define __REJECTINC__ #define __STACKEINC__ #define __UPHIOTINC__ #if __AUGERHIST__ #define __GEOMEGSINC__ #define __OBSPARINC__ #endif #if __INTTEST__ #define __TSTINTINC__ #endif #include "corsika.h" DOUBLE PRECISION AMASS2,AMAS2I,AMASS3,AMASS4,AMOM3,AMOM4, * BETA,BRATIO,B3CM,B3CM2,COSTE3,ED,ENUCL, * ESQ,ETH,E3CM,GAMMA,G3, * PEIG,PEOP,PT,PTRANS,P3CM,W0,W0I,W0S,W0SI #if __AUGERHIST__ DOUBLE PRECISION EDEP INTEGER LL CHARACTER*10 VONWO #endif #if __EHISTORY__ INTEGER IK #endif SAVE EXTERNAL PTRANS C----------------------------------------------------------------------- IF ( FEGSDB ) THEN WRITE(MDEBUG,1) NP,IR(NP),IOBS(NP) 1 FORMAT(' PIGEN1: NP=',I3,' IR=',I3,' IOBS=',I3) CALL AUSGB2 ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) 'PIGEN1: E=',E(NP)*.001D0 #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME GRANDMOTHER PARTICLE SECPAR(28) = IQ(NP) SECPAR(29) = E(NP)*0.001D0 SECPAR(30) = MIN( 1.D0, W(NP) ) SECPAR(31) = U(NP) SECPAR(32) = -V(NP) SECPAR(33) = -Z(NP) SECPAR(34) = TIM(NP) C STORE GENERATION COUNTER OF MOTHER SECPAR(35) = IGEN(NP) C STORE MASS PENETRATION BEFORE INTERACTION SECPAR(36) = 0.D0 #if __THIN__ SECPAR(37) = WT(NP) #endif #endif 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 CALL RMMARD( RD,2,2 ) C 0.49923 IS THE FRACTION OF PROTONS IN AIR IF ( RD(1) .LE. 0.49923D0 ) THEN C HIT NUCLEON IS PROTON AMASS2 = AMASPR C 33% CHANCE FOR CHARGE EXCHANGE IF ( RD(2) .LE. 0.3333333D0 ) THEN C PI(+) + NEUTRON PRODUCED IQ(NP) = 8 IQ(NP+1) = 13 ELSE C PI(0) + PROTON PRODUCED IQ(NP) = 7 IQ(NP+1) = 14 ENDIF ELSE C HIT NUCLEON IS NEUTRON AMASS2 = AMASNT C 33% CHANCE FOR CHARGE EXCHANGE IF ( RD(2) .LE. 0.3333333D0 ) THEN C PI(-) + PROTON PRODUCED IQ(NP) = 9 IQ(NP+1) = 14 ELSE C PI(0) + NEUTRON PRODUCED IQ(NP) = 7 IQ(NP+1) = 13 ENDIF ENDIF AMAS2I = 1.D0/AMASS2 C NOTE: THE ENERGIES IN EGS ARE IN MEV, IN CORSIKA IN GEV AMASS3 = PAMA(IQ(NP))*1.D3 AMASS4 = PAMA(IQ(NP+1))*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-AMASS2**2)*AMAS2I C BETA,GAMMA, ESQ, BRATIO, G3 ARE AUXILIARY QUANTITIES BETA = PEIG*W0I GAMMA = W0*W0SI #if __INTTEST__ BECM = BETA GACM = GAMMA ECMI = W0S*0.001D0 IF ( DEBUG ) WRITE(MDEBUG,*) 'PIGEN1: GACM,BECM,ECM = ', * SNGL(GACM),BECM,SNGL(ECMI) #endif 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 CALL RMMARD( RD,2,2 ) IF ( IQ(NP) .EQ. 7 ) THEN C NEUTRAL PION EMITTED, TAKE PURE C DIPOLE RADIATION: W(COSTH) = 1-3/5*COSTH**2 COSTE3 = 2.D0*RD(1)-1.D0 IF ( RD(2) .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/(RD(1)*2.D0*B3CM2/(1.D0-B3CM2) * + B3CM/(1.D0+B3CM)) IF ( RD(2)*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 CALL RMMARD( RD,2,2 ) IF ( IQ(NP) .EQ. 7 ) THEN C NEUTRAL PION EMITTED, TAKE PURE QUADRUPOLE C RADIATION: W(COSTH) = 1+6*COSTH**2-5*COSTH**4 COSTE3 = 2.D0*RD(1)-1.D0 IF ( 2.8D0*RD(2) .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/(RD(1)*2.D0*B3CM2/(1.D0-B3CM2) * + B3CM/(1.D0+B3CM)) IF ( 13.2D0*RD(2) .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*PTRANS() 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 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 AMOM3 = SQRT( MAX( 0.D0, (PEOP-AMASS3)*(PEOP+AMASS3) ) ) IF ( AMOM3 .GT. 0.D0 ) THEN COSTHE = (AMASS4**2 - AMASS2**2 - AMASS3**2 + 2.D0*PEOP*W0 * - 2.D0*PEIG*AMASS2)/(2.D0*PEIG*AMOM3) ELSE COSTHE = 1.D0 ENDIF SINTHE = SQRT( MAX( 0.D0, (1.D0-COSTHE)*(1.D0+COSTHE) ) ) CALL UPHI( 2,1 ) C TOTAL ENERGY OF RECOILING NUCLEON = ENUCL ENUCL = W0-PEOP IF ( ENUCL-AMASS4 .GT. ELCUT(1)*1000.D0 ) THEN C RECOIL ENERGY IS TOO LARGE, MUST TREAT THE NUCLEON NP = NP+1 E(NP) = ENUCL 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) ) ) CALL UPHI( 3,2 ) IF ( E(NP)-AMASS4 .GT. ELCUT(1)*1000.D0 ) THEN IF ( W(NP) .GT. C(29) ) THEN C ADD RECOIL NUCLEON TO CORSIKA STACK SECPAR(0) = IQ(NP) SECPAR(1) = E(NP)/AMASS4 SECPAR(2) = MIN( 1.D0, W(NP) ) SECPAR(3) = U(NP) SECPAR(4) = -V(NP) SECPAR(5) = -Z(NP) SECPAR(6) = TIM(NP) SECPAR(7) = X(NP) SECPAR(8) = -Y(NP) SECPAR(11) = 1.D0 SECPAR(12) = 0.D0 #if __THIN__ SECPAR(13) = WT(NP) #endif #if __INTTEST__ SECPAR(17) = SQRT( (SECPAR(1)-1.D0)*(SECPAR(1)+1.D0) * * (1.D0-SECPAR(2))*(1.D0+SECPAR(2)) ) * * E(NP)*0.001D0/SECPAR(1) #endif #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER PARTICLE DO IK = 0, 8 SECPAR(17+IK) = SECPAR(IK) ENDDO #if __THIN__ SECPAR(26) = SECPAR(13) #endif #endif CALL TSTACK ELSE IF ( LLONGI ) THEN C CUTTED ENERGY TO LONGITUDINAL ENERGY SUMS OF NUCLEON [IN GEV] DLONG(LPCTE(NP),17) = DLONG(LPCTE(NP),17) #if __THIN__ * + (E(NP)-AMASS4) * 1.D-3 * WT(NP) #else * + (E(NP)-AMASS4) * 1.D-3 #endif ENDIF #if __AUGERHIST__ DO LL = 1, NOBSLV C LOOK WHETHER DEPOSIT IS WITHIN 1 G/CM^2 BELOW OBSERVATION LEVEL IF ( -Z(NP) .LE. OBSLVL(LL) .AND. * -Z(NP) .GT. OBSLV2(LL) ) THEN EDEP = E(NP) - AMASS4 E(NP) = E(NP)/AMASS4 VONWO = 'PIGEN1_1' C PARTICLE BELOW ANGULAR CUT CALL AUGACT( EDEP,LL,VONWO ) ELSEIF ( -Z(NP) .GT. OBSLVL(LL) ) THEN GOTO 111 ENDIF ENDDO 111 CONTINUE #endif ENDIF ELSE IF ( LLONGI ) THEN C CUTTED ENERGY TO LONGITUDINAL ENERGY SUMS OF NUCLEON [IN GEV] DLONG(LPCTE(NP),7) = DLONG(LPCTE(NP),7) #if __THIN__ * + (E(NP)-AMASS4) * 1.D-3 * WT(NP) #else * + (E(NP)-AMASS4) * 1.D-3 #endif ENDIF #if __AUGERHIST__ DO LL = 1, NOBSLV C LOOK WHETHER DEPOSIT IS WITHIN 1 G/CM^2 BELOW OBSERVATION LEVEL IF ( -Z(NP) .LE. OBSLVL(LL) .AND. * -Z(NP) .GT. OBSLV2(LL) ) THEN EDEP = E(NP) - AMASS4 E(NP) = E(NP)/AMASS4 VONWO = 'PIGEN1_2' C PARTICLE BELOW ENERGY CUT CALL AUGECT( EDEP,LL,VONWO ) ELSEIF ( -Z(NP) .GT. OBSLVL(LL) ) THEN GOTO 112 ENDIF ENDDO 112 CONTINUE #endif ENDIF C ELIMINATE NUCLEON FROM EGS-STACK NP = NP-1 IF ( NP .EQ. 0 ) RETURN ENDIF C END OF RECOIL NUCLEON TREATMENT CASE C STORE PION TO CORSIKA STACK CALL PIPROP RETURN END *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE PIGEN2 C----------------------------------------------------------------------- C 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----------------------------------------------------------------------- IMPLICIT NONE #define __EGSDEBINC__ #define __ELABCTINC__ #define __LONGIINC__ #define __PAMINC__ #define __PARPARINC__ #define __PIONINC__ #define __RANDPAINC__ #define __RUNPARINC__ #define __REJECTINC__ #define __STACKEINC__ #define __UPHIOTINC__ #if __AUGERHIST__ #define __GEOMEGSINC__ #define __OBSPARINC__ #endif #if __INTTEST__ #define __TSTINTINC__ #endif #include "corsika.h" DOUBLE PRECISION AMASS2,AMASS3,AMASS4,AMASS5,AM34SQ,AM35SQ,AM34I, * AUXA,AUXB,AUX1,AUX2,AUX2A,AUX3,AUX4, * AUX4A,AUX5,AUX6,AUX7,AUX8,BETA,COSA,COSB, * COSFI3,COSPSI,COS3CM,COS4CM,COS5CM,DISCR, * ECM,ENUCL,E3CM,E4CM,E5CM,E3STAR,E5STAR, * GAMMA,HELP,PEIG,P3CM,P4CM,P5CM, * P3SQ,P4SQ,P5SQ,ROOT1,ROOT2,SINA,SINB, * SINFI3,SINPSI,SINT4,SINT4I,SINT5,SINT5I,SIN3CM, * PSI,PTRANS,PT3 INTEGER IHELP #if __AUGERHIST__ DOUBLE PRECISION EDEP INTEGER LL CHARACTER*10 VONWO #endif #if __EHISTORY__ INTEGER IK #endif SAVE EXTERNAL PTRANS C----------------------------------------------------------------------- IF ( FEGSDB ) THEN WRITE(MDEBUG,1) NP,IR(NP),IOBS(NP) 1 FORMAT(' PIGEN2: NP=',I3,' IR=',I3,' IOBS=',I3) CALL AUSGB2 ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) 'PIGEN2: E=',E(NP)*.001D0 #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME GRANDMOTHER PARTICLE SECPAR(28) = IQ(NP) SECPAR(29) = E(NP)*0.001D0 SECPAR(30) = MIN( 1.D0, W(NP) ) SECPAR(31) = U(NP) SECPAR(32) = -V(NP) SECPAR(33) = -Z(NP) SECPAR(34) = TIM(NP) C STORE GENERATION COUNTER OF MOTHER SECPAR(35) = IGEN(NP) C STORE MASS PENETRATION BEFORE INTERACTION SECPAR(36) = 0.D0 #if __THIN__ SECPAR(37) = WT(NP) #endif #endif 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 CALL RMMARD( RD,2,2 ) C LOOK WHICH TYPE OF REACTION C 0.49923 IS THE FRACTION OF PROTONS IN AIR IF ( RD(1) .LE. 0.49923D0 ) THEN C HIT NUCLEON IS PROTON AMASS2 = AMASPR C BRANCHING FOR COLLISION WITH PROTON IF ( RD(2) .LE. 0.3D0 ) THEN C PI(0) + PI(0) + PROTON IQ(NP) = 7 IQ(NP+1) = 7 IQ(NP+2) = 14 ELSEIF ( RD(2) .LE. 0.6D0 ) THEN C PI(+) + PI(-) + PROTON IQ(NP) = 8 IQ(NP+1) = 9 IQ(NP+2) = 14 ELSE C PI(+) + PI(0) + NEUTRON IQ(NP) = 8 IQ(NP+1) = 7 IQ(NP+2) = 13 ENDIF ELSE C HIT NUCLEON IS NEUTRON C BRANCHING FOR COLLISION WITH NEUTRON AMASS2 = AMASNT IF ( RD(2) .LE. 0.3D0 ) THEN C PI(0) + PI(0) + NEUTRON IQ(NP) = 7 IQ(NP+1) = 7 IQ(NP+2) = 13 ELSEIF ( RD(2) .LE. 0.6D0 ) THEN C PI(+) + PI(-) + NEUTRON IQ(NP) = 8 IQ(NP+1) = 9 IQ(NP+2) = 13 ELSE C PI(-) + PI(0) + PROTON IQ(NP) = 9 IQ(NP+1) = 7 IQ(NP+2) = 14 ENDIF 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 AMASS3 = PAMA(IQ(NP))*1.D3 AMASS4 = PAMA(IQ(NP+1))*1.D3 AMASS5 = PAMA(IQ(NP+2))*1.D3 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 AUX8 = (ECM - AMASS3)**2 BETA = PEIG/(AMASS2+PEIG) GAMMA = 2.D0*(PEIG+AMASS2)*AUX7 #if __INTTEST__ ECMI = ECM*0.001D0 BECM = BETA GACM = GAMMA IF ( DEBUG ) WRITE(MDEBUG,*) 'PIGEN2: GACM,BECM,ECM = ', * SNGL(GACM),BECM,SNGL(ECMI) #endif 230 CONTINUE CALL RMMARD( RD,2,2 ) C ARE INVARIANT MASS SQUARES INSIDE BOUNDARY OF DALITZ PLOT? AM34SQ = AUX2*RD(1)+AUX1 AM35SQ = AUX4*RD(2)+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*PTRANS() SIN3CM = MIN( 1.D0, PT3/P3CM ) COS3CM = SQRT( (1.D0-SIN3CM) * (1.D0+SIN3CM) ) CALL RMMARD( RD,1,2 ) PSI = TWOPI*RD(1) 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) 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) ) ) C SINPHI AND COSPHI ARE NOW SET IN SUBR. UPHI CALL UPHI( 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) 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) ) ) CALL UPHI( 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) = 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) 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) ) ) CALL UPHI( 3,2 ) IF ( E(NP)-AMASS5 .GT. ELCUT(1)*1000.D0 ) THEN IF ( W(NP) .GT. C(29) ) THEN C ADD NUCLEON TO CORSIKA STACK SECPAR(0) = IQ(NP) SECPAR(1) = E(NP)/AMASS5 SECPAR(2) = MIN( 1.D0, W(NP) ) SECPAR(3) = U(NP) SECPAR(4) = -V(NP) SECPAR(5) = -Z(NP) SECPAR(6) = TIM(NP) SECPAR(7) = X(NP) SECPAR(8) = -Y(NP) SECPAR(11) = 1.D0 SECPAR(12) = 0.D0 #if __THIN__ SECPAR(13) = WT(NP) #endif #if __INTTEST__ SECPAR(17) = SQRT( (SECPAR(1)-1.D0)*(SECPAR(1)+1.D0) * * (1.D0-SECPAR(2))*(1.D0+SECPAR(2)) ) * * E(NP)*0.001D0/SECPAR(1) #endif #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER PARTICLE DO IK = 0, 8 SECPAR(17+IK) = SECPAR(IK) ENDDO #if __THIN__ SECPAR(26) = SECPAR(13) #endif #endif CALL TSTACK ELSE IF ( LLONGI ) THEN C CUTTED ENERGY TO LONGITUDINAL ENERGY [IN GEV] C ANGLE CUT DLONG(LPCTE(NP),17) = DLONG(LPCTE(NP),17) #if __THIN__ * + (E(NP)-AMASS5) * 1.D-3 * WT(NP) #else * + (E(NP)-AMASS5) * 1.D-3 #endif ENDIF #if __AUGERHIST__ DO LL = 1, NOBSLV C LOOK WHETHER DEPOSIT IS WITHIN 1 G/CM^2 BELOW OBSERVATION LEVEL IF ( -Z(NP) .LE. OBSLVL(LL) .AND. * -Z(NP) .GT. OBSLV2(LL) ) THEN EDEP = E(NP) - AMASS5 E(NP) = E(NP)/AMASS5 VONWO = 'PIGEN2_1' C PARTICLE BELOW ANGULAR CUT CALL AUGACT( EDEP,LL,VONWO ) ELSEIF ( -Z(NP) .GT. OBSLVL(LL) ) THEN GOTO 111 ENDIF ENDDO 111 CONTINUE #endif ENDIF ELSE IF ( LLONGI ) THEN C CUTTED ENERGY TO LONGITUDINAL ENERGY [IN GEV] C ENERGY CUT DLONG(LPCTE(NP),7) = DLONG(LPCTE(NP),7) #if __THIN__ * + (E(NP)-AMASS5) * 1.D-3 * WT(NP) #else * + (E(NP)-AMASS5) * 1.D-3 #endif ENDIF #if __AUGERHIST__ DO LL = 1, NOBSLV C LOOK WHETHER DEPOSIT IS WITHIN 1 G/CM^2 BELOW OBSERVATION LEVEL IF ( -Z(NP) .LE. OBSLVL(LL) .AND. * -Z(NP) .GT. OBSLV2(LL) ) THEN EDEP = E(NP) - AMASS5 E(NP) = E(NP)/AMASS5 VONWO = 'PIGEN2_2' C PARTICLE BELOW ENERGY CUT CALL AUGECT( EDEP,LL,VONWO ) ELSEIF ( -Z(NP) .GT. OBSLVL(LL) ) THEN GOTO 112 ENDIF ENDDO 112 CONTINUE #endif ENDIF C ELIMINATE NUCLEON FROM EGS-STACK NP = NP-1 IF ( NP .EQ. 0 ) RETURN C END OF RECOIL NUCLEON TREATMENT CASE C STORE SECOND PION TO CORSIKA STACK CALL PIPROP IF ( NP .EQ. 0 ) RETURN C STORE FIRST PION TO CORSIKA STACK CALL PIPROP RETURN END *-- Author : D. HECK IK FZK KARLSRUHE 01/09/2001 C======================================================================= SUBROUTINE PIPROP C----------------------------------------------------------------------- C PI(ON) PROP(AGATION) C C MOVES PIONS FROM EGS-STACK TO CORSIKA-STACK. C THIS SUBROUTINE IS CALLED FROM PIGEN1 AND PIGEN2. C----------------------------------------------------------------------- IMPLICIT NONE #define __EGSDEBINC__ #define __ELABCTINC__ #define __LONGIINC__ #define __MUONINC__ #define __PARPARINC__ #define __PIONINC__ #define __POLARINC__ #define __RUNPARINC__ #define __STACKEINC__ #define __UPHIOTINC__ #if __AUGERHIST__ #define __GEOMEGSINC__ #define __OBSPARINC__ #endif #include "corsika.h" DOUBLE PRECISION AMASS,CUT,FAC1,FAC2 #if __AUGERHIST__ DOUBLE PRECISION EDEP INTEGER LL CHARACTER*10 VONWO #endif #if __EHISTORY__ INTEGER IK #endif SAVE C----------------------------------------------------------------------- IF ( FEGSDB ) THEN WRITE(MDEBUG,1) NP,IR(NP),IOBS(NP) 1 FORMAT(' PIPROP: NP=',I3,' IR=',I3,' IOBS=',I3) CALL AUSGB2 ENDIF C SET MASS AND CUT PARAMETER OF PARTICLE UNDER CONSIDERATION IF ( IQ(NP) .EQ. 7 ) THEN AMASS = PI0MAS CUT = ELCUT(1)*1000.D0 POLART = 1.D0 POLARF = 0.D0 ELSEIF ( IQ(NP) .EQ. 8 .OR. IQ(NP) .EQ. 9 ) THEN AMASS = PICMAS CUT = ELCUT(1)*1000.D0 POLART = 1.D0 POLARF = 0.D0 ELSE RETURN ENDIF C USE PARTICLE ONLY IF INSIDE ACCEPTANCE CONE IF ( W(NP) .GT. C(29) ) THEN C FILL PION COORDINATES INTO CORSIKA-STACK SECPAR(0) = IQ(NP) SECPAR(1) = E(NP)/AMASS SECPAR(2) = MIN( 1.D0, W(NP) ) SECPAR(3) = U(NP) SECPAR(4) = -V(NP) SECPAR(5) = -Z(NP) SECPAR(6) = TIM(NP) SECPAR(7) = X(NP) SECPAR(8) = -Y(NP) SECPAR(9) = IGEN(NP) SECPAR(10) = -Z(NP) SECPAR(11) = POLART SECPAR(12) = POLARF #if __THIN__ SECPAR(13) = WT(NP) #endif #if __CURVED__ SECPAR(14) = -ZAP(NP) SECPAR(15) = WAP(NP) SECPAR(16) = WA(NP) #endif #if __INTTEST__ SECPAR(17) = SQRT( (SECPAR(1)-1.D0)*(SECPAR(1)+1.D0) * * (1.D0-SECPAR(2))*(1.D0+SECPAR(2)) ) * * E(NP)*0.001D0/SECPAR(1) #endif #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER PARTICLE DO IK = 0, 8 SECPAR(17+IK) = SECPAR(IK) ENDDO #if __THIN__ SECPAR(26) = SECPAR(13) #endif #endif C ADD PION TO CORSIKA-STACK CALL TSTACK ELSE IF ( LLONGI ) THEN C CUTTED ENERGY TO LONGITUDINAL ENERGY SUMS OF HADRONS [IN GEV] IF ( IQ(NP) .EQ. 7 ) THEN FAC1 = 1.D0 FAC2 = 0.D0 ELSE FAC1 = 0.25D0 FAC2 = 0.75D0 ENDIF #if __THIN__ C ADD TO THE HADRON ENERGY DEPOSIT DLONG(LPCTE(NP),7) = DLONG(LPCTE(NP),7) * + E(NP)*1.D-3*WT(NP)*FAC1 C ADD TO THE NEUTRINO DEPOSIT DLONG(LPCTE(NP),8) = DLONG(LPCTE(NP),8) * + E(NP)*1.D-3*WT(NP)*FAC2 #else C ADD TO THE HADRON ENERGY DEPOSIT DLONG(LPCTE(NP),7) = DLONG(LPCTE(NP),7) + E(NP)*1.D-3*FAC1 C ADD TO THE NEUTRINO DEPOSIT DLONG(LPCTE(NP),8) = DLONG(LPCTE(NP),8) + E(NP)*1.D-3*FAC2 #endif ENDIF #if __AUGERHIST__ DO LL = 1, NOBSLV C LOOK WHETHER DEPOSIT IS WITHIN 1 G/CM^2 BELOW OBSERVATION LEVEL IF ( -Z(NP) .LE. OBSLVL(LL) .AND. * -Z(NP) .GT. OBSLV2(LL) ) THEN EDEP = E(NP) E(NP) = E(NP)/AMASS VONWO = 'PIPROP1' C PION BELOW ANGULAR CUT CALL AUGACT( EDEP,LL,VONWO ) ELSEIF ( -Z(NP) .GT. OBSLVL(LL) ) THEN GOTO 111 ENDIF ENDDO 111 CONTINUE #endif ENDIF C ELIMINATE PION FROM EGS-STACK NP = NP-1 RETURN END *-- Author : D. HECK IK FZK KARLSRUHE 28/06/1999 C======================================================================= SUBROUTINE RHOGEN C----------------------------------------------------------------------- C RHO 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. 124 (2000) 290 C THIS SUBROUTINE IS CALLED FROM PIGEN. C----------------------------------------------------------------------- IMPLICIT NONE #define __EGSDEBINC__ #define __ELABCTINC__ #define __GENERINC__ #define __LONGIINC__ #define __PAMINC__ #define __PARPARINC__ #define __PIONINC__ #define __POLARINC__ #define __RANDPAINC__ #define __REJECTINC__ #define __RUNPARINC__ #define __STACKEINC__ #define __UPHIOTINC__ #if __AUGERHIST__ #define __GEOMEGSINC__ #define __OBSPARINC__ #endif #if __INTTEST__ #define __TSTINTINC__ #endif #include "corsika.h" DOUBLE PRECISION AMASS2,AMAS2I,AMAS2S,AMASS3,AMASS4,AMOM3,AMOM4, * AUX3,BDIFF,BETA,BRATIO, * ED,ENUCL,ESQ,ETH,E3CM,E2,E4, * GAMMA,G3,PCM2,PCM4,PEIG,PEOM,PLNG3,P3CM, * T,TMAX,TMIN,W0,W0I,W0S,W0SI #if __AUGERHIST__ DOUBLE PRECISION EDEP INTEGER LL CHARACTER*10 VONWO #endif #if __EHISTORY__ INTEGER IK #endif SAVE C----------------------------------------------------------------------- IF ( FEGSDB ) THEN WRITE(MDEBUG,1) NP,IR(NP),IOBS(NP) 1 FORMAT(' RHOGEN: NP=',I3,' IR=',I3,' IOBS=',I3) CALL AUSGB2 ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) 'RHOGEN: E=',E(NP)*.001D0 #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME GRANDMOTHER PARTICLE SECPAR(28) = IQ(NP) SECPAR(29) = E(NP)*0.001D0 SECPAR(30) = MIN( 1.D0, W(NP) ) SECPAR(31) = U(NP) SECPAR(32) = -V(NP) SECPAR(33) = -Z(NP) SECPAR(34) = TIM(NP) C STORE GENERATION COUNTER OF MOTHER SECPAR(35) = IGEN(NP) C STORE MASS PENETRATION BEFORE INTERACTION SECPAR(36) = 0.D0 #if __THIN__ SECPAR(37) = WT(NP) #endif #endif 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 CALL RMMARD( RD,3,2 ) C 0.49923 IS THE FRACTION OF PROTONS IN AIR IF ( RD(1) .LE. 0.49923D0 ) THEN C HIT NUCLEON IS PROTON IQ(NP+1) = 14 AMASS2 = AMASPR ELSE C HIT NUCLEON IS NEUTRON IQ(NP+1) = 13 AMASS2 = AMASNT ENDIF AMAS2I = 1.D0/AMASS2 AMAS2S = AMASS2**2 IF ( RD(2) .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) = 50 ELSE C GENERATED MESON IS RHO(0) IQ(NP) = 51 ENDIF C NOTE: THE ENERGIES IN EGS ARE IN MEV, IN CORSIKA IN GEV AMASS3 = PAMA(IQ(NP))*1.D3 AMASS4 = PAMA(IQ(NP+1))*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, BRATIO, G3 ARE AUXILIARY QUANTITIES BETA = PEIG*W0I GAMMA = W0*W0SI #if __INTTEST__ ECMI = W0S*0.001D0 BECM = BETA GACM = GAMMA IF ( DEBUG ) WRITE(MDEBUG,*) 'RHOGEN: GACM,BECM,ECM = ', * SNGL(GACM),BECM,SNGL(ECMI) #endif ED = 0.5D0*((AMASS3-AMASS4)**2-AMAS2S)*AMAS2I ESQ = SQRT( (PEIG-ETH) * (PEIG-ED) ) BRATIO = PEIG/ESQ G3 = W0I*(PEIG-ETH+AMASS3*AMAS2I*(AMASS3+AMASS4)) C C.M. ENERGY OF MESON E3CM = G3*AMASS2*GAMMA C C.M. MESON MOMENTUM P3CM = AMASS2*W0SI*ESQ C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C THE FOLLOWING SELECTION OF TRANSFERRED MOMENTUM IS IN ANALOGY WITH C PROGRAM SOPHIA (SUBROUT. GAMMA_H OF R. ENGEL). C SEE A. MUECKE ET AL., COMP. PHYS. COMM. 124 (2000) 290 C ANGULAR DISTRIBUTION IS ACCORDING C 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 #if __INTTEST__ IF ( DEBUG ) WRITE(MDEBUG,*) 'RHOGEN: E2,E4,PCM2,PCM4,TMIN,TMAX=', #else IF (FEGSDB) WRITE(MDEBUG,*) 'RHOGEN: E2,E4,PCM2,PCM4,TMIN,TMAX=', #endif * SNGL(E2*0.001D0),SNGL(E4*0.001D0),SNGL(PCM2*0.001D0), * SNGL(PCM4*0.001D0),SNGL(TMIN*0.001D0),SNGL(TMAX*0.001D0) C SELECT THE MOMENTUM TRANSFER T BY CHANCE T = RD(3)*(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) #if __INTTEST__ IF ( DEBUG ) WRITE(MDEBUG,*) 'RHOGEN: RD,T,PLNG3,PEOM=', #else IF ( FEGSDB ) WRITE(MDEBUG,*) 'RHOGEN: RD,T,PLNG3,PEOM=', #endif * SNGL(RD(3)),SNGL(T*0.001D0),SNGL(PLNG3*0.001D0), * SNGL(PEOM*0.001D0) 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 ( AMOM3 .GT. 0.D0 ) THEN COSTHE = (AMASS4**2 - AMAS2S - AMASS3**2 + 2.D0*PEOM*W0 * - 2.D0*PEIG*AMASS2)/(2.D0*PEIG*AMOM3) ELSE COSTHE = 1.D0 ENDIF SINTHE = SQRT( MAX( 0.D0, (1.D0-COSTHE)*(1.D0+COSTHE) ) ) CALL UPHI( 2,1 ) C TOTAL ENERGY OF RECOILING NUCLEON ( = ENUCL) ENUCL = W0 - PEOM NP = NP + 1 E(NP) = ENUCL IF ( ENUCL-AMASS4 .GT. ELCUT(1)*1000.D0 ) 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) ) ) CALL UPHI( 3,2 ) IF ( W(NP) .GT. C(29) ) THEN C ADD NUCLEON TO CORSIKA STACK SECPAR(0) = IQ(NP) SECPAR(1) = E(NP)/AMASS4 SECPAR(2) = MIN( 1.D0, W(NP) ) SECPAR(3) = U(NP) SECPAR(4) = -V(NP) SECPAR(5) = -Z(NP) SECPAR(6) = TIM(NP) SECPAR(7) = X(NP) SECPAR(8) = -Y(NP) * SECPAR(9) = IGEN(NP) * SECPAR(10) = -Z(NP) SECPAR(11) = 1.D0 SECPAR(12) = 0.D0 #if __THIN__ SECPAR(13) = WT(NP) #endif #if __INTTEST__ SECPAR(17) = SQRT( (SECPAR(1)-1.D0)*(SECPAR(1)+1.D0) * * (1.D0-SECPAR(2))*(1.D0+SECPAR(2)) ) * * E(NP)*0.001D0/SECPAR(1) #endif #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER PARTICLE DO IK = 0, 8 SECPAR(17+IK) = SECPAR(IK) ENDDO #if __THIN__ SECPAR(26) = SECPAR(13) #endif #endif CALL TSTACK ELSE IF ( LLONGI ) THEN C CUTTED ENERGY TO LONGITUDINAL ENERGY SUMS TO NUCLEON [IN GEV] C ANGULAR CUT DLONG(LPCTE(NP),17) = DLONG(LPCTE(NP),17) #if __THIN__ * + (E(NP)-AMASS4) * 1.D-3 * WT(NP) #else * + (E(NP)-AMASS4) * 1.D-3 #endif ENDIF #if __AUGERHIST__ DO LL = 1, NOBSLV C LOOK WHETHER DEPOSIT IS WITHIN 1 G/CM^2 BELOW OBSERVATION LEVEL IF ( -Z(NP) .LE. OBSLVL(LL) .AND. * -Z(NP) .GT. OBSLV2(LL) ) THEN EDEP = ENUCL - AMASS4 E(NP) = E(NP)/AMASS4 VONWO = 'RHOGEN2' CALL AUGACT( EDEP,LL,VONWO ) ELSEIF ( -Z(NP) .GT. OBSLVL(LL) ) THEN GOTO 112 ENDIF ENDDO 112 CONTINUE #endif ENDIF C ELIMINATE NUCLEON FROM EGS-STACK NP = NP-1 IF ( NP .LE. 0 ) RETURN ELSE IF ( LLONGI ) THEN C CUTTED ENERGY TO LONGITUDINAL ENERGY SUMS TO NUCLEON [IN GEV] C ENERGY CUT DLONG(LPCTE(NP),7) = DLONG(LPCTE(NP),7) #if __THIN__ * + (E(NP)-AMASS4) * 1.D-3 * WT(NP) #else * + (E(NP)-AMASS4) * 1.D-3 #endif ENDIF #if __AUGERHIST__ DO LL = 1, NOBSLV C LOOK WHETHER DEPOSIT IS WITHIN 1 G/CM^2 BELOW OBSERVATION LEVEL IF ( -Z(NP) .LE. OBSLVL(LL) .AND. * -Z(NP) .GT. OBSLV2(LL) ) THEN EDEP = ENUCL - AMASS4 E(NP) = E(NP)/AMASS4 VONWO = 'RHOGEN3' CALL AUGECT( EDEP,LL,VONWO ) ELSEIF ( -Z(NP) .GT. OBSLVL(LL) ) THEN GOTO 113 ENDIF ENDDO 113 CONTINUE #endif C ELIMINATE NUCLEON FROM EGS-STACK NP = NP-1 C END OF RECOIL NUCLEON TREATMENT CASE ENDIF C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - IF ( IQ(NP) .GE. 50 ) THEN C NOW TREAT THE VECTOR MESON IF ( W(NP) .GT. C(29) ) THEN IF ( IQ(NP) .EQ. 50 ) THEN C ADD OMEGA MESON TO CORSIKA-STACK (TO BE TREATED IN RESDEC) SECPAR(0) = IQ(NP) SECPAR(1) = E(NP)/AMASS3 SECPAR(2) = MIN( 1.D0, W(NP) ) SECPAR(3) = U(NP) SECPAR(4) = -V(NP) SECPAR(5) = -Z(NP) SECPAR(6) = TIM(NP) SECPAR(7) = X(NP) SECPAR(8) = -Y(NP) SECPAR(9) = IGEN(NP) SECPAR(10) = -Z(NP) SECPAR(11) = POLART SECPAR(12) = POLARF #if __THIN__ SECPAR(13) = WT(NP) #endif #if __CURVED__ SECPAR(14) = -ZAP(NP) SECPAR(15) = WAP(NP) SECPAR(16) = WA(NP) #endif #if __INTTEST__ SECPAR(17) = SQRT( (SECPAR(1)-1.D0)*(SECPAR(1)+1.D0) * * (1.D0-SECPAR(2))*(1.D0+SECPAR(2)) ) * * E(NP)*0.001D0/SECPAR(1) IF ( DEBUG ) WRITE(MDEBUG,*) 'RHOGEN: OMEG PT=',SECPAR(17) #endif #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER PARTICLE DO IK = 0, 8 SECPAR(17+IK) = SECPAR(IK) ENDDO #if __THIN__ SECPAR(26) = SECPAR(13) #endif #endif CALL TSTACK C FINALLY OMEGA WILL BE TREATED IN OMEGDC (OMEGA DECAY ROUTINE) C WITH CORRECT ANGULAR DISTRIBUTION C (AT THE MOMENT WE USE RESDEC ROUTINE) * CALL OMEGDC ELSEIF ( IQ(NP) .EQ. 51 ) THEN C FILL RHO(0) MESON COORDINATES INTO CORSIKA-STACK C (CURPAR HAS BEEN SAVED IN PIGEN) ITYPE = IQ(NP) CURPAR(0) = IQ(NP) CURPAR(1) = E(NP)/AMASS3 CURPAR(2) = MIN( 1.D0, W(NP) ) CURPAR(3) = U(NP) CURPAR(4) = -V(NP) CURPAR(5) = -Z(NP) CURPAR(6) = TIM(NP) CURPAR(7) = X(NP) CURPAR(8) = -Y(NP) CURPAR(9) = 0.D0 C BETA IS CALCULATED IN RHO0DC * CURPAR(10) = -Z(NP) GEN = IGEN(NP) ALEVEL = -Z(NP) #if __THIN__ CURPAR(13) = WT(NP) #endif #if __CURVED__ CURPAR(14) = -ZAP(NP) CURPAR(15) = WAP(NP) CURPAR(16) = WA(NP) #endif #if __INTTEST__ CURPAR(17) = SQRT( (CURPAR(1)-1.D0)*(CURPAR(1)+1.D0) * *(1.D0-CURPAR(2))*(1.D0+CURPAR(2)) ) * * E(NP)*0.001D0 / CURPAR(1) IF ( DEBUG ) WRITE(MDEBUG,*) 'RHOGEN: RHO PT=',CURPAR(17) #endif C RHO(0) DECAYS WITH DIPOLE CHARACTERISTIC IN RHO0DC #if __EHISTORY__ C MOTHER PARTICLE COORDINATES ARE SET IN RHO0DC #endif CALL RHO0DC(1) ELSE WRITE(MONIOU,*) 'RHOGEN: WRONG PARTICLE CODE=',IQ(NP) STOP ENDIF ELSE IF ( LLONGI ) THEN C CUTTED ENERGY TO LONGITUDINAL ENERGY SUMS OF HADRONS [IN GEV] C ANGLE CUT #if __THIN__ DLONG(LPCTE(NP),17) = DLONG(LPCTE(NP),17)+E(NP)*1.D-3*WT(NP) #else DLONG(LPCTE(NP),17) = DLONG(LPCTE(NP),17)+E(NP)*1.D-3 #endif ENDIF #if __AUGERHIST__ DO LL = 1, NOBSLV C LOOK WHETHER DEPOSIT IS WITHIN 1 G/CM^2 BELOW OBSERVATION LEVEL IF ( -Z(NP) .LE. OBSLVL(LL) .AND. * -Z(NP) .GT. OBSLV2(LL) ) THEN EDEP = ENUCL - AMASS4 E(NP) = E(NP)/AMASS4 VONWO = 'RHOGEN4' CALL AUGACT( EDEP,LL,VONWO ) ELSEIF ( -Z(NP) .GT. OBSLVL(LL) ) THEN GOTO 114 ENDIF ENDDO 114 CONTINUE #endif ENDIF C ELIMINATE VECTOR MESON FROM EGS-STACK NP = NP-1 ENDIF RETURN END *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE SHOWER C----------------------------------------------------------------------- C SHOWER (STEERING) C C THIS ROUTINE LOOKS, WHAT IS ON TOP OF EGS-STACK, AND CALLS THE C APPROPRIATE ROUTINE TO TREAT THIS PARTICLE. C THIS SUBROUTINE IS CALLED FROM EGS4. C----------------------------------------------------------------------- IMPLICIT NONE #define __EGSDEBINC__ #define __MISCINC__ #define __RUNPARINC__ #define __STACKEINC__ #if __MULTITHIN__ #define __MULTHININC__ #endif #if __PARALLEL__ #define __PAMINC__ #define __PARPARINC__ #define __STACKFINC__ #endif #include "corsika.h" #if __PARALLEL__ DOUBLE PRECISION EK #endif INTEGER IRCODE #if __MULTITHIN__ INTEGER IK #endif SAVE C----------------------------------------------------------------------- #if __INTTEST__ IF ( DEBUG ) WRITE(MDEBUG,*) 'SHOWER: IQ(NP),NP=',IQ(NP),NP #endif C TAKE FIRST PARTICLE IN STACK NP = 1 C DECIDE WHAT IS ON TOP OF STACK #if !__INTTEST__ 261 CONTINUE #endif IF ( FEGSDB ) THEN WRITE(MDEBUG,1) NP,IR(NP),IOBS(NP),IQ(NP) 1 FORMAT(' SHOWER: NP=',I3,' IR=',I3,' IOBS=',I3,' IQ=',I3) CALL AUSGB2 ENDIF #if __PARALLEL__ IF ( FECTOUT ) THEN C SWITCH INTO EM CASCADE MODE FOR CUTFILE PRODUCTION C (STOP WHEN FIRST EM CASCADE IS DONE (ALL PARTICLES WITH EECTCUT CAN BE CREATED AFTER THE FIRST INTERACTION) IF ( FECTOUT .AND. JCOUNT .GT. 1 ) THEN C GROUP PARTICLE IN ECUT BY ENERGY TO REACH ECTMAX C AND SEND INFORMATION TO OUTSIDE CALL SENDCUT WRITE(MONIOU,*) ' SHOWER: ECUT PARTICLE OUTPUT SAVED' FECTEGS = .FALSE. FECTOUT = .FALSE. ELSE FECTEGS = .FALSE. FECTOUT = .FALSE. ENDIF #endif RETURN END #if __THIN__ *-- Author : D. HECK IK FZK KARLSRUHE 24/11/1997 C======================================================================= SUBROUTINE THIN( EK,EKHIGH,EKLOW ) C----------------------------------------------------------------------- C THIN(NNING IS PERFORMED) C C PERFORMS THINNING ACCORDING TO MOCCA/AIRES (HILLAS) C THIS ROUTINE IS ALWAYS DEALING WITH ONLY 2 SECONDARIES. C THIS SUBROUTINE IS CALLED FROM ELECTR AND PHOTON. C ARGUMENTS: (ALL ENERGIES IN MEV) C EK = RELEASABLE ENERGY OF INCOMING PARTICLE C EKHIGH = RELEASABLE ENERGY OF HIGH ENERGY SECONDARY C EKLOW = RELEASABLE ENERGY OF LOW ENERGY SECONDARY C----------------------------------------------------------------------- IMPLICIT NONE #define __EGSDEBINC__ #define __RANDPAINC__ #define __REJECTINC__ #define __RUNPARINC__ #define __STACKEINC__ #define __THNVARINC__ #include "corsika.h" DOUBLE PRECISION EK,EKHIGH,EKK,EKLOW,THNMRK LOGICAL LABOVE SAVE C----------------------------------------------------------------------- #if __CONEX__ C THINNING ONLY IF NOT AFTER CE SAMPLING c IF ( MOD(IGEN(NP),10000) .GE. 500.D0 ) RETURN #endif IF ( FEGSDB ) THEN WRITE(MDEBUG,1) NP,IR(NP),IOBS(NP) 1 FORMAT(' THIN : NP=',I3,' IR=',I3,' IOBS=',I3) CALL AUSGB2 ENDIF IF ( FEGSDB ) WRITE(MDEBUG,2) EK*.001D0,EKHIGH*.001D0,IQ(NP-1), * EKLOW*.001D0,IQ(NP) 2 FORMAT(' THIN : EK,E1,IQ1,E2,IQ2=',1P,2E10.3,1X,I2,E10.3,1X,I2) CALL RMMARD( RD,1,2 ) IF ( EK .GE. ETHINN ) THEN LABOVE = .TRUE. ELSE LABOVE = .FALSE. ENDIF C WEIGHT FOR BOTH PARTICLES ARE SAME C GET MINIMUM ENERGY IF ( LABOVE ) THEN ELIM = WT(NP)/WMAXEM*ETHINN THNMRK = RD(1) * ETHINN IF ( FEGSDB ) WRITE(MDEBUG,*)'THIN H: THNMRK=',THNMRK, * ' ETHINN=',SNGL(ETHINN*0.001D0),' GEV' ELSE C CHECK HOW MANY PARTICLES ARE THINNED AT ALL AND MODIFY EK TO GET THE C APPROPRIATE NEW WEIGHT ELIM = WT(NP)/WMAXEM*EK IF ( WLIM ) THEN EKK = 0.D0 IF ( EKHIGH .LT. ETHINN .AND. EKHIGH .GT. ELIM ) * EKK = EKK + EKHIGH IF ( EKLOW .LT. ETHINN .AND. EKLOW .GT. ELIM ) * EKK = EKK + EKLOW ELSE EKK = EK ENDIF C IF BOTH PARTICLES ARE KEPT, THEN EKK=0. THNMRK = RD(1) * EKK IF ( FEGSDB ) WRITE(MDEBUG,*)'THIN H: THNMRK=',THNMRK, * ' EKK=',SNGL(EKK*0.001D0) ENDIF IF ( EKHIGH .LT. ETHINN .AND. EKHIGH .GT. ELIM ) THEN C TREAT FIRST PARTICLE WITH HIGHER ENERGY THNMRK = THNMRK - EKHIGH IF ( THNMRK .LE. 0.D0 ) THEN C KEEP PARTICLE WITH HIGHER ENERGY WITH MODIFIED WEIGHT IF ( LABOVE ) THEN WT(NP-1) = WT(NP-1) * ETHINN / EKHIGH THNMRK = THNMRK + ETHINN ELSE WT(NP-1) = WT(NP-1) * EKK / EKHIGH THNMRK = THNMRK + EKK ENDIF IF ( FEGSDB ) WRITE(MDEBUG,*) 'THIN : EH=', * SNGL(E(NP-1)*.001D0),' WEIGHT=',SNGL(WT(NP-1)),' NP=',NP ELSE C DISCARD PARTICLE WITH HIGHER ENERGY E(NP-1) = E(NP) IQ(NP-1) = IQ(NP) U(NP-1) = U(NP) V(NP-1) = V(NP) W(NP-1) = W(NP) NP = NP-1 ENDIF ENDIF C TREAT PARTICLE WITH LOWER ENERGY IF ( EKLOW .LT. ETHINN .AND. EKLOW .GT. ELIM ) THEN IF ( FEGSDB ) WRITE(MDEBUG,*) 'THIN L: THNMRK=',THNMRK THNMRK = THNMRK - EKLOW IF ( THNMRK .LE. 0.D0 ) THEN C KEEP PARTICLE WITH LOWER ENERGY WITH MODIFIED WEIGHT IF ( LABOVE ) THEN WT(NP) = WT(NP) * ETHINN / EKLOW ELSE WT(NP) = WT(NP) * EKK / EKLOW ENDIF IF ( FEGSDB ) WRITE(MDEBUG,*) 'THIN : EL=', * SNGL(E(NP)*.001D0),' WEIGHT=',SNGL(WT(NP)),' NP=',NP ELSE C DISCARD PARTICLE WITH LOWER ENERGY NP = NP-1 ENDIF ENDIF RETURN END #endif #if __MULTITHIN__ *-- Author : D. HECK IK FZK KARLSRUHE 2/12/2013 C======================================================================= SUBROUTINE THIN2( EK,EKHIGH,EKLOW ) C----------------------------------------------------------------------- C (MULTIPLE) THIN(NNING IS PERFORMED) C C PERFORMS THINNING ACCORDING TO MOCCA/AIRES (HILLAS) C THIS ROUTINE IS ALWAYS DEALING WITH ONLY 2 SECONDARIES. C THIS SUBROUTINE IS CALLED FROM ELECTR AND PHOTON. C ARGUMENTS: (ALL ENERGIES IN MEV) C EK = RELEASABLE ENERGY OF INCOMING PARTICLE C EKHIGH = RELEASABLE ENERGY OF HIGH ENERGY SECONDARY C EKLOW = RELEASABLE ENERGY OF LOW ENERGY SECONDARY C----------------------------------------------------------------------- IMPLICIT NONE #define __EGSDEBINC__ #define __RANDPAINC__ #define __RUNPARINC__ #define __STACKEINC__ #define __THNVARINC__ #define __MULTHININC__ #include "corsika.h" DOUBLE PRECISION EK,EKHIGH,EKK,EKLOW,THNMRK INTEGER J LOGICAL LABOVE SAVE C----------------------------------------------------------------------- IF ( FEGSDB ) THEN WRITE(MDEBUG,1) NP,IR(NP),IOBS(NP) 1 FORMAT(' THIN2 : NP=',I3,' IR=',I3,' IOBS=',I3) CALL AUSGB2 ENDIF IF ( FEGSDB ) WRITE(MDEBUG,2) EK*.001D0,EKHIGH*.001D0,IQ(NP-1), * EKLOW*.001D0,IQ(NP) 2 FORMAT(' THIN2 : EK,E1,IQ1,E2,IQ2=',1P,2E10.3,1X,I2,E10.3,1X,I2) IF ( NMTHIN .GT. 0 ) THEN C LOOP OVER ALL MULTITHIN MODES DO J = 1, NMTHIN IF ( WTM(J,NP) .GT. 0.D0 ) THEN IF ( EKLOW .LT. EMTHNN(J) ) THEN C WE TAKE FOR EACH MODE ITS OWN RANDOM SEQUENCE CALL RMMARD( RD,1,J+10 ) IF ( EK .GE. EMTHNN(J) ) THEN LABOVE = .TRUE. ELSE LABOVE = .FALSE. ENDIF C WEIGHT FOR BOTH PARTICLES ARE SAME C GET MINIMUM ENERGY IF ( LABOVE ) THEN ELIM = WTM(J,NP)/WMMAXEM(J)*EMTHNN(J) THNMRK = RD(1) * EMTHNN(J) IF ( FEGSDB ) WRITE(MDEBUG,*)'THIN2H: THNMRK=',THNMRK, * ' EMTHNN(J)=',SNGL(EMTHNN(J)*1.D-3),' GEV' ELSE C CHECK HOW MANY PARTICLES ARE THINNED AT ALL AND MODIFY EK TO GET THE C APPROPRIATE NEW WEIGHT ELIM = WTM(J,NP)/WMMAXEM(J)*EK EKK = 0.D0 IF ( EKHIGH .LT. EMTHNN(J) .AND. EKHIGH .GT. ELIM ) * EKK = EKK + EKHIGH IF ( EKLOW .LT. EMTHNN(J) .AND. EKLOW .GT. ELIM ) * EKK = EKK + EKLOW C IF BOTH PARTICLES ARE KEPT, THEN EKK=0. THNMRK = RD(1) * EKK IF ( FEGSDB ) WRITE(MDEBUG,*)'THIN2H: THNMRK=',THNMRK, * ' EKK=',SNGL(EKK*1.D-3),' GEV' ENDIF IF ( EKHIGH .LT. EMTHNN(J) .AND. EKHIGH .GT. ELIM ) THEN C TREAT FIRST PARTICLE WITH HIGHER ENERGY THNMRK = THNMRK - EKHIGH IF ( THNMRK .LE. 0.D0 ) THEN C KEEP PARTICLE WITH HIGHER ENERGY WITH MODIFIED WEIGHT IF ( LABOVE ) THEN WTM(J,NP-1) = WTM(J,NP-1) * EMTHNN(J) / EKHIGH THNMRK = THNMRK + EMTHNN(J) ELSE WTM(J,NP-1) = WTM(J,NP-1) * EKK / EKHIGH THNMRK = THNMRK + EKK ENDIF IF ( FEGSDB ) WRITE(MDEBUG,*) 'THIN2 : EH=', * SNGL(E(NP-1)*1.D-3),' WEIGHT=', * SNGL(WTM(J,NP-1)),' NP=',NP ELSE C DISCARD PARTICLE WITH HIGHER ENERGY BY SETTING TO NEGATIVE WEIGHT WTM(J,NP-1) = -WTM(J,NP-1) ENDIF ENDIF C TREAT PARTICLE WITH LOWER ENERGY IF ( EKLOW .LT. EMTHNN(J) .AND. EKLOW .GT. ELIM ) THEN IF ( FEGSDB ) WRITE(MDEBUG,*) 'THIN2L: THNMRK=',THNMRK THNMRK = THNMRK - EKLOW IF ( THNMRK .LE. 0.D0 ) THEN C KEEP PARTICLE WITH LOWER ENERGY WITH MODIFIED WEIGHT IF ( LABOVE ) THEN WTM(J,NP) = WTM(J,NP) * EMTHNN(J) / EKLOW ELSE WTM(J,NP) = WTM(J,NP) * EKK / EKLOW ENDIF IF ( FEGSDB ) WRITE(MDEBUG,*) 'THIN2 : EL=', * SNGL(E(NP)*1.D-3),' WEIGHT=',SNGL(WTM(J,NP)),' NP=',NP ELSE C DISCARD PARTICLE WITH LOWER ENERGY BY SETTING TO NEGATIVE WEIGHT WTM(J,NP) = -WTM(J,NP) ENDIF ENDIF ENDIF ENDIF ENDDO ENDIF RETURN END #endif *-- Author : STANFORD LINEAR ACCELERATOR CENTER C======================================================================= C STANFORD LINEAR ACCELERATOR CENTER SUBROUTINE UPHI( IENTRY,LVL ) C VERSION 4.00 -- 26 JAN 1986/1900 C----------------------------------------------------------------------- C U(NIFORM) PHI (DISTRIBUTION) C 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 THIS SUBROUTINE IS CALLED FROM ANNIH, BHABHA, BREMS, COMPT, ELECTR, C MOLLER, MUPAIR, PAIR, PHOTON, PIGEN1, PIGEN2, RHOGEN. C ARGUMENTS: C IENTRY = 1 THETA IS KNOWN, DETERMINE SINTHE,COSTHE AND PHI C 2 SINTHE AND COSTHE ARE KNOWN, SELECT PHI AT RANDOM C 3 SINTHE, COSTHE AND PHI ARE KNOWN C LVL = 1 OLD PARTICLE, SAVE ITS DIRECTION AND ADJUST IT C 2 NEW PARTICLE. ADJUST DIRECTION USING SAVED A,B,C C 3 BREMSSTRAHLUNG GAMMA. SAVE ELECTRON DIRECTION AND ADJUST C GAMMA DIRECTION C----------------------------------------------------------------------- IMPLICIT NONE #define __EPCONTINC__ #define __RANDPAINC__ #define __RUNPARINC__ #define __STACKEINC__ #define __UPHIOTINC__ #if __MULTITHIN__ #define __MULTHININC__ #endif #include "corsika.h" DOUBLE PRECISION A,B,C,COSDEL,PHI,SINDEL,SINPSI,SINPS2,US,VS INTEGER IENTRY,LVL #if __MULTITHIN__ INTEGER IK #endif SAVE C----------------------------------------------------------------------- IF ( IENTRY .EQ. 2 ) GOTO 1070 IF ( IENTRY .EQ. 3 ) GOTO 1080 SINTHE = SIN( THETA ) COSTHE = COS( THETA ) C USE THE FOLLOWING ENTRY IF SINTHE AND COSTHE ARE ALREADY KNOWN. C SELECT PHI UNIFORMLY OVER THE INTERVAL (0,TWO PI). 1070 CONTINUE CALL RMMARD( RD,1,2 ) PHI = RD(1)*TWOPI SINPHI = SIN( PHI ) COSPHI = COS( PHI ) 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. 1080 CONTINUE IF ( LVL .EQ. 2 ) GOTO 1100 IF ( LVL .EQ. 3 ) GOTO 1110 A = U(NP) B = V(NP) C = W(NP) GOTO 1130 1110 CONTINUE A = U(NP-1) B = V(NP-1) C = W(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) 1100 CONTINUE X(NP) = X(NP-1) Y(NP) = Y(NP-1) Z(NP) = Z(NP-1) LPCTE(NP) = LPCTE(NP-1) IR(NP) = IR(NP-1) DNEAR(NP) = DNEAR(NP-1) TIM(NP) = TIM(NP-1) IGEN(NP) = IGEN(NP-1) IOBS(NP) = IOBS(NP-1) #if __THIN__ WT(NP) = WT(NP-1) #endif #if __CURVED__ ZAP(NP) = ZAP(NP-1) WAP(NP) = WAP(NP-1) WA(NP) = WA(NP-1) XXXX(NP) = XXXX(NP-1) YYYY(NP) = YYYY(NP-1) #endif #if __SLANT__ TSLAN(NP) = TSLAN(NP-1) #endif #if __MULTITHIN__ DO IK = 1, NMTHIN WTM(IK,NP) = WTM(IK,NP-1) ENDDO #endif 1130 CONTINUE SINPS2 = A*A+B*B C SMALL POLAR ANGLE CASE, NO ROTATION IS NEEDED IF ( SINPS2 .LT. 1.D-20 ) THEN U(NP) = SINTHE*COSPHI V(NP) = SINTHE*SINPHI W(NP) = C*COSTHE ELSE C LARGE POLAR ANGLE CASE SINPSI = SQRT( SINPS2 ) US = SINTHE*COSPHI VS = SINTHE*SINPHI SINDEL = B*(1.D0/SINPSI) COSDEL = A*(1.D0/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 ENDIF RETURN END *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE AGE( R,S ) C----------------------------------------------------------------------- C AGE C C CALCULATES LONGITUDINAL AGE PARAMETER C ORIGINALLY DEVELOPED BY: J. KEMPA, UNIVERSITY OF LODZ, POLAND C THIS SUBROUTINE IS CALLED FROM AVAGE. C ARGUMENTS: C R = AVERAGED AGE PARAMETER C S = LONGITUDINAL AGE PARAMETER OF TOTAL SHOWER C----------------------------------------------------------------------- IMPLICIT NONE #define __RUNPARINC__ #include "corsika.h" DOUBLE PRECISION A,B,C,R,R1,R2,R3,R4,R5,S SAVE DATA R1 / 1.9096D-02 /, R2 / 1.7964D-01 /, R3 / 5.3644D-01 /, * R4 / 1.0332D0 /, R5 / 1.4856D0 / C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'AGE : R=',SNGL(R) R = MAX( R, R1 ) R = MIN( R, R5 ) IF ( R .LT. R2 ) THEN A = 3.109121D-1 B = 2.146465D-1 C = -5.451040D-3 ELSEIF ( R .LT. R3 ) THEN A = 3.666449D-1 B = 1.639189D-1 C = 5.970362D-3 ELSEIF ( R .LT. R4 ) THEN A = 1.459842D-1 B = 6.317027D-1 C = -2.420241D-1 ELSEIF ( R .LE. R5 ) THEN A = -3.375703D-1 B = 2.090333D0 C = -1.343802D0 ENDIF S = ( SQRT( B**2 - 4.D0 * A * (C-R) ) - B ) / ( 2.D0 * A ) IF ( DEBUG ) WRITE(MDEBUG,*) 'AGE : S=',SNGL(S) RETURN END *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE AVAGE C----------------------------------------------------------------------- C AVE(ERAGE) AGE C C CALCULATES AVERAGE AGE AS A FUNCTION OF RADIUS. C THIS SUBROUTINE IS CALLED FROM AAMAIN. C----------------------------------------------------------------------- IMPLICIT NONE #define __BUFFSINC__ #define __ELABCTINC__ #define __NKGIINC__ #define __NKGSINC__ #define __RUNPARINC__ #include "corsika.h" DOUBLE PRECISION AJ,BJ,CJ,DF(10),SJ(10),SLLG,TH,ZF INTEGER I,ID,IL,IOL,J,K,L SAVE C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'AVAGE :' IF ( FPRINT ) WRITE(MONIOU,1110) ISHOWNO,ELCUT(3),ELCUT(4) 1110 FORMAT(/,' ---------- NKG - OUTPUT OF SHOWER NO ',I10, * ' --------------------------------',/, * ' ELECTRON/GAMMA THRESHOLD AT ',F10.5,' /',F10.5,' GEV') C LOOP OVER ALL DISTANCES WHERE ELECTRON NUMBER IS CALCULATED DO K = 1, 2 IF ( OBSATI(K) .GE. 0.D0 ) THEN DO ID = -10, 10 DLAX (ID,K) = DLAX (ID,K) + CZX (ID,K) DLAY (ID,K) = DLAY (ID,K) + CZY (ID,K) DLAXY(ID,K) = DLAXY(ID,K) + CZXY(ID,K) DLAYX(ID,K) = DLAYX(ID,K) + CZYX(ID,K) ENDDO ENDIF ENDDO C CALCULATE LONGITUDINAL SHOWER DEVELOPMENT DO IL = 1, IALT(1) IF ( SL(IL) .GT. 0.D0 ) THEN SEL(IL) = SEL(IL) + SL(IL) SLLG = LOG10(SL(IL)) SELLG(IL) = SELLG(IL) + SLLG ZEL(IL) = ZEL(IL) + SL(IL)**2 ZELLG(IL) = ZELLG(IL) + SLLG**2 ZF = ZNE(IL)/SL(IL) CALL AGE( ZF,TH ) C AGE PARAMETERS AVERAGED ON ALL SUBCASCADES AT THIS LEVEL SAH(IL) = TH STH(IL) = STH(IL) + TH ZSL(IL) = ZSL(IL) + TH**2 ELSE SL(IL) = 0.D0 SAH(IL) = 0.D0 ENDIF EVTE(175+IL) = SL(IL) EVTE(185+IL) = SAH(IL) EVTE(215+IL) = TLEV(IL) EVTE(225+IL) = TLEVCM(IL) ENDDO C PRINT LONGITUDINAL SHOWER DEVELOPMENT IF ( FPRINT ) WRITE(MONIOU,229) * (I,TLEV(I),TLEVCM(I),SL(I),SAH(I),I=1,IALT(1)) 229 FORMAT( * /,' LEVEL',2X,'THICKNESS',8X,'HEIGHT',5X,'ELECT. NUMBER',3X, * 'PSEUDO-' * /,' NO. ',2X,' G/CM**2',8X,' CM',25X,'AGE',/, * (' ',I4,F12.0,2X,F12.0,1X,F17.3,F10.3) ) DO 312 IOL = 1, 2 IF ( OBSATI(IOL) .LT. 0.D0 ) GOTO 312 C DETERMINE LOCAL AGE PARAMETER DO J = 1, 9 IF ( CZX(J+1,IOL).GT.0.D0 .AND. CZX(-J-1,IOL).GT.0.D0 .AND. * CZXY(J+1,IOL).GT.0.D0 .AND. CZXY(-J-1,IOL).GT.0.D0 .AND. * CZYX(J+1,IOL).GT.0.D0 .AND. CZYX(-J-1,IOL).GT.0.D0 .AND. * CZY(J+1,IOL).GT.0.D0 .AND. CZY(-J-1,IOL).GT.0.D0 ) THEN AJ = 0.125D0 * ( * CZX(J,IOL) /CZX(J+1,IOL) + CZX(-J,IOL) /CZX(-J-1,IOL) * + CZXY(J,IOL)/CZXY(J+1,IOL)+ CZXY(-J,IOL)/CZXY(-J-1,IOL) * + CZYX(J,IOL)/CZYX(J+1,IOL)+ CZYX(-J,IOL)/CZYX(-J-1,IOL) * + CZY(J,IOL) /CZY(J+1,IOL) + CZY(-J,IOL) /CZY(-J-1,IOL) ) ELSE AJ = 0.D0 ENDIF IF ( AJ .GT. 0.D0 ) THEN BJ = DIST(J) / DIST(J+1) CJ = (DIST(J)+RMOL(IOL)) / (DIST(J+1)+RMOL(IOL)) SJ(J) = LOG( AJ * BJ**2 * CJ**4.5D0 ) / LOG( BJ * CJ ) DF(J) = 0.5D0 * (DIST(J) + DIST(J+1)) ELSE SJ(J) = 0.D0 DF(J) = 0.D0 ENDIF ENDDO DO L = 1, 10 EVTE(165+IOL*40+L) = SJ(L) ENDDO IF ( FPRINT ) THEN C WRITE LOCAL AGE PARAMETER WRITE(MONIOU,60) IOL,OBSATI(IOL), (I,DF(I),SJ(I),I=1,9) 60 FORMAT(/,' RADIAL BIN DISTANCE(CM) LOCAL AGE AT LEVEL NO.', * I4,' AT HEIGHT:',F10.0,' CM',/, * (' ',I10,' ',F10.0,' ',F10.3 ) ) C PRINT LATERAL ELECTRON DISTRIBUTION WRITE(MONIOU,507) IOL,OBSATI(IOL) 507 FORMAT(/,' LATERAL ELECTRON DENSITY (/CM**2) AT LEVEL NO.', * I4,' AT HEIGHT:',F10.0,' CM',/, * ' --------------------------------------------------', * '---------------------------',/, * ' DIST (CM) CZX CZXY ', * ' CZY CZYX ') WRITE(MONIOU,508) (DISX(I),CZX(I,IOL),CZXY(I,IOL), * CZY(I,IOL),CZYX(I,IOL),I=-10,10) 508 FORMAT(' ',0P,F10.0,1P,4E15.5) WRITE(MONIOU,*)' ' ENDIF 312 CONTINUE DO L = 1, 10 EVTE(195+L) = DIST(L) EVTE(235+L) = DF(L) ENDDO C WRITE NKG - SHOWER INFORMATION TO EVENT END BLOCK DO L = 1, 21 EVTE( 7+L) = CZX (-11+L,1) EVTE( 28+L) = CZY (-11+L,1) EVTE( 49+L) = CZXY(-11+L,1) EVTE( 70+L) = CZYX(-11+L,1) EVTE( 91+L) = CZX (-11+L,2) EVTE(112+L) = CZY (-11+L,2) EVTE(133+L) = CZXY(-11+L,2) EVTE(154+L) = CZYX(-11+L,2) ENDDO RETURN END *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= DOUBLE PRECISION FUNCTION GAM( Z ) C----------------------------------------------------------------------- C GAM(MA FUNCTION) C C EULER''S GAMMA FUNCTION C THE INTERNAL PRECISION OF THIS FUNCTION IS ONLY SINGLE PRECISION. C THIS FUNCION IS CALLED FROM NKG C ARGUMENT: C Z = ARGUMENT OF GAMMA FUNCTION (0 < Z < 57) C----------------------------------------------------------------------- IMPLICIT NONE DOUBLE PRECISION U,Y,YY,Z INTEGER IZ,IU SAVE C----------------------------------------------------------------------- C CALCULATE CORRESPONDING FUNCTION VALUE IN INTERVAL 1 ... 2 Y = MOD(Z,1.D0) YY = Y + 1.D0 C PARAMETERIZATION FOR VALUES IN INTERVAL 1 ... 2 GAM = 1.D0 + Y*(-0.5771017D0 + Y*(0.9858540D0+ * Y*(-0.8764218D0 + Y*(0.8328212D0+ * Y*(-0.5684729D0 + Y*(0.2548205D0+ * Y*(-0.0514993D0 ))))))) C GET FUNCTION VALUE IN DESIRED INTERVAL BY ITERATION IF ( Z .LT. 1.D0 ) THEN C GAMMA(Z-1) IS GAMMA(Z) / (Z-1) GAM = GAM / Z ELSE C GAMMA(Z+1) IS GAMMA(Z) * Z IZ = INT(Z)-1 U = YY DO IU = 1, IZ, 1 GAM = GAM * U U = U + 1.D0 ENDDO ENDIF RETURN END *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE ININKG C----------------------------------------------------------------------- C INI(TIALIZE) NKG C C INITIALIZES ARRAYS FOR NKG CALCULATING VARIABLES. C THIS SUBROUTINE IS CALLED FROM AAMAIN. C----------------------------------------------------------------------- IMPLICIT NONE #define __BUFFSINC__ #define __NKGIINC__ #define __OBSPARINC__ #define __RUNPARINC__ #include "corsika.h" DOUBLE PRECISION DEPTH,HEIGH,RHOF,RMGCM,THICK INTEGER I,IL,K,KL SAVE EXTERNAL HEIGH,RHOF,THICK DATA RMGCM / 9.6D0 / C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'ININKG:' C SET LATERAL DISTRIBUTION DISTANCES IF ( RADNKG .LE. 100.D0 ) THEN WRITE(MONIOU,*) 'ININKG: RADNKG=',RADNKG,' CM TOO SMALL ' RADNKG = 200.D2 WRITE(MONIOU,*) ' RADNKG CORRECTED TO ',RADNKG,' CM' ENDIF EVTH(147) = RADNKG DO I = 1, 10 DIST(I) = 100.D0 * 10.D0**(LOG10(RADNKG/100.D0)*0.1D0*I) DISX(I) = DIST(I) DISX(-I) = -DIST(I) ENDDO DISX(0) = 0.D0 C MOLIERE RADIUS FOR COULOMB SCATTERING ; EQUIVALENT TO 9.6 G/CM**2 C OBSERVATION LEVELS AND CORRESPONDING MOLIERE RADII (IN CM) FOR NKG OBSATI(1) = OBSLEV(NOBSLV) RMOL (1) = RMGCM / RHOF( OBSATI(1) ) #if __ANAHIST__ || __AUGERHIST__ OBSATI(2) = -1.D0 RMOL (2) = 0.D0 IALT (2) = 0 #else IF ( NOBSLV .GT. 1 ) THEN OBSATI(2) = OBSLEV(NOBSLV-1) RMOL (2) = RMGCM / RHOF( OBSATI(2) ) ELSE OBSATI(2) = -1.D0 RMOL (2) = 0.D0 IALT (2) = 0 ENDIF #endif C CALCULATE COORDINATES OF POINTS ON THE X AND Y AXIS AND THE TWO C DIAGONAL LINES Y IS X AND Y IS -X DO KL = -10, 10 DISY (KL) = DISX (KL) DISXY(KL,1) = DISX (KL) / SQRT( 2.D0 ) DISXY(KL,2) = DISXY(KL,1) DISYX(KL,1) = DISXY(KL,1) DISYX(KL,2) = -DISXY(KL,2) ENDDO C CLEAR ARRAY FOR LATERAL ELECTRON DISTR. (AVERAGE OVER ALL SHOWERS) DO K = 1, 2 DO I = -10, 10 DLAX (I,K) = 0.D0 DLAY (I,K) = 0.D0 DLAXY(I,K) = 0.D0 DLAYX(I,K) = 0.D0 ENDDO ENDDO C CLEAR ARRAY FOR AGE PARAMETER CALCULATION (AVERAGE OVER ALL SHOWERS) DO I = 1, 10 SEL(I) = 0.D0 SELLG(I) = 0.D0 STH(I) = 0.D0 ZELLG(I) = 0.D0 ZEL(I) = 0.D0 ZSL(I) = 0.D0 ENDDO C LAST OBSERVATION LEVEL DEPTH IS GIVEN IN G/CM**2 DEPTH = THICK( OBSATI(1) ) IALT(1) = MIN( 10, INT( DEPTH/102.D0 )+1 ) C CALCULATE 10 LEVELS AT EACH 100 G/CM**2 DO IL = 1, IALT(1)-1 TLEV (IL) = 100.D0 * IL TLEVCM(IL) = HEIGH( TLEV(IL) ) ENDDO C FOR LAST LEVEL NOT IL*100 BUT OBSERVATION LEVEL TLEV (IALT(1)) = DEPTH TLEVCM(IALT(1)) = OBSATI(1) C SECOND OBSERVATION LEVEL ? IF ( OBSATI(2) .GE. 0.D0 ) THEN DEPTH = THICK( OBSATI(2) ) IALT(2) = INT( DEPTH/102.D0 ) + 1 IF ( IALT(2) .GE. IALT(1) ) IALT(2) = MAX( 1, IALT(1)-1 ) TLEV (IALT(2)) = DEPTH TLEVCM(IALT(2)) = OBSATI(2) ENDIF RETURN END *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE MITAGE C----------------------------------------------------------------------- C MIT(TELWERT) AGE (AVERAGE AGE) C C CALCULATES AVERAGE DISTRIBUTION FOR NKG FUNCTION OVER ALL SHOWERS. C THIS SUBROUTINE IS CALLED FROM AAMAIN. C----------------------------------------------------------------------- IMPLICIT NONE #define __ELABCTINC__ #define __NKGIINC__ #define __RUNPARINC__ #include "corsika.h" DOUBLE PRECISION AJ,ATH,BJ,CJ,DF(10),RISH,SELEC,SELCLG,SJ(10), * ZEC,ZECLG,ZSE INTEGER I,ID,J,K,LI SAVE C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'MITAGE:' WRITE(MONIOU,349) ELCUT(3),ELCUT(4) 349 FORMAT(/,' ========== NKG - AVERAGE VALUES OF ALL SHOWERS ', * '===============================',/, * ' ELECTRON/GAMMA THRESHOLDS AT ',F10.5,' /',F10.5,' GEV',/,/, * ' LEVEL THICKNESS HEIGHT DEV', * ' DEV DEV',/, * ' NO. (G/CM**2) (M) ' ) C NORMALIZE AVERAGE ELECTRON DENSITIES RISH = 1.D0 / ISHW DO K = 1, 2 IF ( OBSATI(K) .GE. 0.D0 ) THEN DO ID = -10, 10 DLAX (ID,K) = DLAX (ID,K) * RISH DLAY (ID,K) = DLAY (ID,K) * RISH DLAXY(ID,K) = DLAXY(ID,K) * RISH DLAYX(ID,K) = DLAYX(ID,K) * RISH ENDDO ENDIF ENDDO DO LI = 1, IALT(1) C ELECTRON NUMBER SELEC = SEL(LI) * RISH C LOG10 ELECTRON NUMBER SELCLG = SELLG(LI) * RISH C AVERAGE LONGITUDINAL AGE ATH = STH(LI) * RISH IF ( ISHW .GT. 1 ) THEN C ELECTRON NUMBER ZEC = SQRT( MAX( 0.D0, (ZEL(LI) - SEL(LI)**2*RISH)/ * (ISHW-1.D0) ) ) C LOG10 ELECTRON NUMBER ZECLG = SQRT( MAX( 0.D0, (ZELLG(LI) - SELLG(LI)**2*RISH)/ * (ISHW-1.D0) ) ) C AVERAGE LONGITUDINAL AGE ZSE = SQRT( MAX( 0.D0, (ZSL(LI) - STH(LI)**2*RISH)/ * (ISHW-1.D0) ) ) ELSE ZEC = 0.D0 ZECLG = 0.D0 ZSE = 0.D0 ENDIF C WRITE ELECTRON INFORMATION FOR ALL NKG LEVELS (LONG. DEVELOPMENT) WRITE(MONIOU,219) LI,TLEV(LI),TLEVCM(LI)*0.01D0, * SELEC,ZEC,SELCLG,ZECLG,ATH,ZSE 219 FORMAT(' ',I4,F10.0,F11.2,1X,2F15.0,3X,2F12.5,F12.3,1X,F9.3) ENDDO DO 520 K = 1, 2 IF ( OBSATI(K) .LT. 0.D0 ) GOTO 520 C DETERMINE LOCAL AGE PARAMETER DO J = 1, 9 IF ( DLAX(J+1,K).GT.0.D0 .AND. DLAX(-J-1,K).GT.0.D0 .AND. * DLAXY(J+1,K).GT.0.D0 .AND. DLAXY(-J-1,K).GT.0.D0 .AND. * DLAYX(J+1,K).GT.0.D0 .AND. DLAYX(-J-1,K).GT.0.D0 .AND. * DLAY(J+1,K).GT.0.D0 .AND. DLAY(-J-1,K).GT.0.D0 ) THEN AJ = 0.125D0 * ( * DLAX(J,K) /DLAX(J+1,K) + DLAX(-J,K) /DLAX(-J-1,K) * + DLAXY(J,K)/DLAXY(J+1,K) + DLAXY(-J,K)/DLAXY(-J-1,K) * + DLAYX(J,K)/DLAYX(J+1,K) + DLAYX(-J,K)/DLAYX(-J-1,K) * + DLAY(J,K) /DLAY(J+1,K) + DLAY(-J,K) /DLAY(-J-1,K)) ELSE AJ = 0.D0 ENDIF IF ( AJ .GT. 0.D0 ) THEN BJ = DIST(J) / DIST(J+1) CJ = (DIST(J)+RMOL(K)) / (DIST(J+1)+RMOL(K)) SJ(J) = LOG( AJ * BJ**2 * CJ**4.5D0 ) / LOG( BJ * CJ ) DF(J) = 0.5D0* (DIST(J) + DIST(J+1)) ELSE SJ(J) = 0.D0 DF(J) = 0.D0 ENDIF ENDDO C WRITE LOCAL AGE PARAMETER WRITE(MONIOU,60) K,OBSATI(K), (I,DF(I),SJ(I),I=1,9) 60 FORMAT(/,' RADIAL BIN DISTANCE(CM) LOCAL AGE AT LEVEL NO.', * I4,' AT HEIGHT:',F10.0,' CM',/, * (' ',I9,' ',F10.0,' ',F10.3 ) ) C WRITE LATERAL ELECTRON DISTRIBUTION WRITE(MONIOU,507) K,OBSATI(K) 507 FORMAT(/,' AVERAGE ELECTRON DENSITY (/CM**2) FOR LEVEL NO.', * I4,' AT HEIGHT:',F10.0,' CM',/, * ' ==================================================', * '==========================',/, * ' DIST (CM) DLAX DLAXY ', * ' DLAY DLAYX') WRITE(MONIOU,508) (DISX(I),DLAX(I,K),DLAXY(I,K), * DLAY(I,K),DLAYX(I,K),I=-10,10) 508 FORMAT(' ',0P,F10.0,1P,4E15.5) WRITE(MONIOU,*)' ' 520 CONTINUE RETURN END *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE NKG( ENERN ) C----------------------------------------------------------------------- C N(ISHIMURA) K(AMATA) G(REISEN) C C CALCULATES ELECTROMAGNETIC COMPONENT OF SHOWERS USING THE ANALYTIC C NKG FORMULAS, INCLUDING ELECTRON ENERGY THRESHOLD ELCUT(3). C SEE J.N. CAPDEVIELLE, 22ND ICRC, DUBLIN 1991, CONTRIB. HE 3.5.10 C THIS SUBROUTINE IS CALLED FROM EM. C ARGUMENT: C ENERN = ENERGY OF ELECTRON/GAMMA GENERATING A SUBSHOWER (GEV) C NEGATIVE FOR SUBSHOWERS TO BE SUBTRACTED AFTER C PHOTONUCLEAR REACTION C----------------------------------------------------------------------- IMPLICIT NONE #define __CONSTAINC__ #define __ELABCTINC__ #define __NKGIINC__ #define __NKGSINC__ #define __OBSPARINC__ #define __PARPARINC__ #define __PARPAEINC__ #define __RUNPARINC__ #include "corsika.h" DOUBLE PRECISION AE,AS,ASE,AUXIL,BS,CCP,CPC,CPCP,CPH,CSGA, * DE,DISTL,ECRI,ECR1,ECR2,ENERN,GAM,GRCUT, * G1,G2,G3,S,SC1,SC2,SIGNE,SM,SMRM, * SQRZ1I,SQZC1I,SQZC2I,SS2,SS45,TEX,THICK,THICKP, * XMOL,XNE,XS,X0,YM,YS,ZC1,ZC2,ZG1,ZG2,ZG3,Z1 INTEGER IL,IOL,M SAVE EXTERNAL GAM,THICK C X0 IS RADIATON LENGTH IN AIR (G/CM**2) C (SEE ALSO MIKOCKI ET AL. J.PHYS.G.:NUCL.PART.PHYS. 17 (1991) 1303 ) C GRCUT IS GREISEN CUT OFF, ECRI IS CRITICAL ENERGY IN AIR C ECR2 IS 0.4 * ECRI DATA X0 / 36.66D0 /, GRCUT / 0.1D0 /, ECRI / 0.086D0 / DATA ECR2 / 0.0344D0 / C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*)'NKG : ',SNGL(SECPAR(0)),SNGL(ENERN) C CHECK WHETHER SUBSHOWER IS SUBTRACTED IF ( ENERN .GE. 0.D0 ) THEN SIGNE = +1.D0 ELSE ENERN = -ENERN SIGNE = -1.D0 ENDIF C OPTIONAL STATEMENT TO SUPPRESS EM-PARTICLES COMING FROM MUONS C ONLY 'PURE' EM SIGNAL TO BE COUNTED IN NKG C IF ( SECPAR(9) .GT. 50.D0 ) RETURN C ERASE THE COMMENT TO ACTIVATE THIS STATEMENT C ENERGY CUT OFF IN GREISEN FORMULA C (EM PARTICLE BELOW THIS CUT CAN NOT PRODUCE A SHOWER) IF ( ENERN .LT. GRCUT ) RETURN C DON''T CALCULATE NKG FOR BACKWARD GOING PARTICLES IF ( SECPAR(2) .LE. 0.D0 ) RETURN C DON''T CALCULATE NKG IF PARTICLE BELOW THE LOWEST OBSERVATION LEVEL IF ( SECPAR(5) .LT. OBSATI(1) ) RETURN Z1 = LOG( ENERN / ECRI ) SQRZ1I = 1.D0 / SQRT( Z1 ) C THIS CUT IS ONLY IMPORTANT FOR ELCUT > .0672 ECR1 = ECR2 + ELCUT(3) IF ( ENERN .LT. ECR1 ) RETURN ZC1 = LOG( ENERN / ECR1 ) SQZC1I = 1.D0 / SQRT( ZC1 ) C LOG(ENERN/ECR2) IS LOG(ENERN / ECRI) - LOG(0.4) ZC2 = Z1 + 0.916290732D0 SQZC2I = 1.D0 / SQRT( ZC2 ) THICKP = THICK( SECPAR(5) ) C LOOP OVER LEVELS DO 14 IL = 1, IALT(1) C DISREGARD LEVELS ABOVE THE PARTICLE IF ( TLEVCM(IL) .GT. SECPAR(5) ) GOTO 14 C DISTANCE IN G/CM**2 .... (ALONG GAMMA-AXIS) IN RADIATION LENGTHS XMOL = (TLEV(IL) - THICKP) / ( X0 * SECPAR(2) ) C CORRECT DEPTH FOR SUBSHOWERS TO BE SUBTRACTED BY 9/7 C CORRECTION IS ALREADY DONE IN PIGEN (D.H. MARCH 10, 1998) CDH IF ( SIGNE .LT. 0.D0 ) XMOL = XMOL + 1.285714286D0 C XMOL IS DEPTH IN RADIATION LENGTHS C RESPECT THE DIFFERENT DEVELOPMENT OF ELECTRON-INDUCED SUBSHOWERS C BY 0.6 RADIATION LENGTH (D.H. MAY 2001) C SEE J. NISHIMURA, HANDBUCH DER PHYSIK XLVI/2 (1967) 27 IF ( SECPAR(0) .NE. 1.D0 ) XMOL = XMOL + 0.6D0 IF ( XMOL .GT. 60.D0 .OR. XMOL .LT. 1.D0 ) GOTO 14 C S IS AGE PARAMETER S = 3.D0 * XMOL / (XMOL + 2.D0 * Z1) IF ( S .LE. 0.2D0 ) GOTO 14 SC1 = 3.D0 * XMOL / (XMOL + 2.D0 * ZC1) SC2 = 3.D0 * XMOL / (XMOL + 2.D0 * ZC2) C ELECTRON NUMBER AT OBSERVATION LEVEL CPH = .31D0 * EXP( XMOL * (1.D0 - 1.5D0 * LOG(S) ) ) * SQRZ1I CPC = EXP( XMOL * ( 1.D0 - 1.5D0 * LOG( SC1 ) ) ) * SQZC1I CCP = EXP( XMOL * ( 1.D0 - 1.5D0 * LOG( SC2 ) ) ) * SQZC2I #if __THIN__ CPCP = SIGNE * SECPAR(13) * CPH * CPC / CCP #else CPCP = SIGNE * CPH * CPC / CCP #endif C INTERMEDIATE FACTORS FOR LATERAL DISTRIBUTION AND AGE PARAMETER AE = 4.D0 * EXP( 0.915D0 * (S - 1.D0) ) / S DE = ( 1.D0 + S ) / ( 1.15D0 + 0.15D0 * S ) ASE = AE**DE ZG3 = GAM( (S + 2.D0) * DE ) IF ( ZG3 .LE. 0.D0 ) GOTO 14 ZG1 = GAM(S * DE) ZG2 = GAM( (S + 1.D0) * DE ) AUXIL = 4.D0 / (S * ASE) XNE = CPCP * ( ZG2 + AUXIL * ZG3 ) / ( ASE * (ZG1 + AUXIL*ZG2) ) C SUM OF N_E AT FIXED LEVEL ZNE(IL) = ZNE(IL) + XNE SL(IL) = SL(IL) + CPCP C CALCULATE THE ELECTRON LATERAL DISTRIBUTION FOR THE 2 SELECTED C OBSERVATION LEVELS IF ( IL .EQ. IALT(1) ) THEN IOL = 1 ELSEIF ( IL .EQ. IALT(2) ) THEN IOL = 2 ELSE GOTO 14 ENDIF C CALCULATION OF LATERAL ELECTRON DISTRIBUTION IF ( SC1 .GE. 2.25D0 ) GOTO 14 G1 = GAM(4.5D0 - SC1) G2 = GAM(SC1) G3 = GAM(4.5D0 - 2.D0 * SC1) C DISTANCE IN CM BETWEEN GAMMA INITIATION AND OBSERVATION (VERTICAL) DISTL = SECPAR(5) - TLEVCM(IL) C MODULATION BY AGE PARAMETER FOLLOWING LAGUTIN & UCHAIKIN C (AGE PARAMETER LIES BETWEEN 0.2 AND 2.25) SM = 0.78D0 - 0.21D0 * SC1 SMRM = 1.D0 / ( SM * RMOL(IOL) ) CSGA = CPCP * SMRM**2 * G1 / ( PI2 * G2 * G3 ) SS2 = SC1 - 2.D0 SS45 = SC1 - 4.5D0 AS = SECPAR(3) BS = SECPAR(4) TEX = DISTL / SECPAR(2) C DISTANCE TO THE CENTER OF THE CASCADE (IN CM) XS = SECPAR(7) + TEX * AS - XOFF(NOBSLV+1-IOL) YS = SECPAR(8) + TEX * BS - YOFF(NOBSLV+1-IOL) C NKG-FORMULA C LOOP OVER ALL LATERAL DISTANCES GETTING THE DENSITY IN MOLIERE UNITS DO 171 M = -10, 10 IF ( M .EQ. 0 ) GOTO 171 C X DIRECTION YM = SMRM * MAX( 1.D0, SQRT( (DISX(M)-XS)**2 + YS**2 ) ) CZX (M,IOL) = CZX (M,IOL) + CSGA * YM**SS2 * (YM+1.D0)**SS45 C Y DIRECTION YM = SMRM * MAX( 1.D0, SQRT( XS**2 + (DISY(M)-YS)**2 ) ) CZY (M,IOL) = CZY (M,IOL) + CSGA * YM**SS2 * (YM+1.D0)**SS45 C XY DIRECTION YM = SMRM * * MAX( 1.D0, SQRT((DISXY(M,1)-XS)**2 + (DISXY(M,2)-YS)**2) ) CZXY(M,IOL) = CZXY(M,IOL) + CSGA * YM**SS2 * (YM+1.D0)**SS45 C YX DIRECTION YM = SMRM * * MAX( 1.D0, SQRT((DISYX(M,1)-XS)**2 + (DISYX(M,2)-YS)**2) ) CZYX(M,IOL) = CZYX(M,IOL) + CSGA * YM**SS2 * (YM+1.D0)**SS45 171 CONTINUE 14 CONTINUE RETURN END *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE STANKG C----------------------------------------------------------------------- C STA(RT) NKG C C INITIALIZES ARRAYS FOR SINGLE SHOWERS NKG CALCULATED VARIABLES. C THIS SUBROUTINE IS CALLED FROM AAMAIN. C----------------------------------------------------------------------- IMPLICIT NONE #define __NKGSINC__ #define __RUNPARINC__ #include "corsika.h" INTEGER I,K SAVE C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'STANKG:' C CLEAR ARRAYS FOR AGE PARAMETER CALCULATION FOR EACH SHOWER DO I = 1, 10 SAH(I) = 0.D0 SL (I) = 0.D0 ZNE(I) = 0.D0 ENDDO C CLEAR LATERAL ELECTRON DISTRIBUTION COUNTERS FOR EACH SHOWER DO K = 1, 2 DO I = -10, 10 CZX (I,K) = 0.D0 CZY (I,K) = 0.D0 CZXY(I,K) = 0.D0 CZYX(I,K) = 0.D0 ENDDO ENDDO RETURN END #if __CONEX__ && __CURVED__ *-- Author : T.PIEROG IK FZK KARLSRUHE 14/12/2007 C======================================================================= SUBROUTINE CONEXINI C----------------------------------------------------------------------- C CONEX INI(TIALIZATION) C C THIS SUBROUTINE TRANSFER TO CONEX ALL PARAMETERS WHICH CAN BE TAKEN C FROM CORSIKA AND COMMON TO ALL EVENTS. C CONEX IS ONLY COMPATIBLE WITH THE CURVED OPTION (FOR GEOMETRY C COMPATIBILITY) C THIS SUBROUTINE IS CALLED FROM AAMAIN. C ARGUMENTS: C----------------------------------------------------------------------- IMPLICIT NONE #define __AIRINC__ #define __ATMOS3INC__ #define __BUFFSINC__ #define __CONEXINC__ #define __CROBSINC__ #define __DPMFLGINC__ #define __ELABCTINC__ #define __GLOBALINC__ #define __LONGIINC__ #define __OBSPARINC__ #define __PARPARINC__ #define __RUNPARINC__ #if __THIN__ #define __REJECTINC__ #endif #include "corsika.h" #include "conex.h" double precision energy,HEIGH,elcut1min integer id,ighe,i dimension ighe(3) #if __SLANT__ double precision dzratio integer idzcx2cors #endif INTEGER IDTRAFOCX,L EXTERNAL IDTRAFOCX,HEIGH SAVE C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'CONEXINI:' C Initialize Air composition for CONEX aira(1)=14.d0 aira(2)=16.d0 aira(3)=40.d0 airz(1)=7.d0 airz(2)=8.d0 airz(3)=18.d0 airavz=0.d0 do i=1,3 airw(i)=COMPOS(i) airavz=airavz+airw(i)*airz(i) enddo airava=AVERAW C Initialize Atmospher for CONEX DO L = 1, 5 aatm(L) = AATMCRS(L) batm(L) = BATMCRS(L) catm(L) = CATMCRS(L)*1D-2 eatm(L) = max(0.d0,EATMCRS(L)*1D-2) if(L.gt.1) & datm(L-1) = aatm(L) + batm(L) * exp ( -eatm(L) / catm(L) ) ENDDO datm(5) = 0d0 eatm(6) = EATMCRS(6)*1D-2 C Initialize primary particle id for CONEX id=int(prmpar(0)) if(id.ge.201)then !nucleus id=id/100 idcx=id*100 elseif(id.eq.41.or.id.eq.43.or.id.eq.42)then !exotics idcx=id if(idcx.eq.42)idcx=-50000 else idcx=idtrafocx('cor','pdg',id) endif energy=0d0 !not used here C hadronic only shower mode if ( FEGS ) then mode=8 else mode=5 endif C CORSIKA compiled with GHEISHA or not #if __GHEISHAD__ ighe(1)=1 #else ighe(1)=0 #endif c debug output = same as corsika (or changed by conex_param) ifck=MDEBUG C Fragmentation of primary nucleus ifragm=min(NFRAGM,2) C Initialize parameters with default value and from conex_*.param file call ConexInit(nshow,0,INLUN,OUTLUN,ighe) C Minimum EM energy (emin can be set in param file) emin=max(emin,min(ELCUT(3),ELCUT(4))) C Minimum hadronic energy (enymin can be set in param file) enymin=max(enymin,min(ELCUT(1),ELCUT(2))) c minimal debug output if(DEBUG.and.isx.le.4)isx=4 ISX0 = isx C initialize Muon Cross Sections (after minimum energy definition) call CXMUPINI C initialize Monopole Cross Sections (after minimum energy definition) if(PRMPAR(0).eq.43)then write(MONIOU,'(a)')'initialize Monopole Cross Sections ...' call CXMMPINI endif C Ground height IF ( THETPR(1) .LE. 0.5D0 * PI ) THEN hground=(OBSLEV(1)+1d0)*1d-2 ! hground in meter in CONEX (-1cm to stop particle in CONEX before real observation level in CORSIKA) altitude= -1d-2 !to correct for the 1cm offset of hground ELSE !in case of upward going shower, ground at starting altitude if(THICK0.gt.0.d0)then ! hground 1cm below starting point to allow propagation in CONEX hground=(HEIGH( THICK0 ) - 1.d0)*1d-2 else hground=(FIXHEI-1.d0)*1d-2 endif altitude=OBSLEV(1)*1d-2-hground ENDIF C Global coordinates (for magnetic field) latitude=GLATI longitude=GLONG year=GRFYEAR C Parameters for transition MC->CE->MC fehcut=CXTHR(1) EVTH(162)=CXTHR(1) femcut=CXTHR(2) EVTH(163)=CXTHR(2) feecut=CXTHR(3) EVTH(164)=CXTHR(3) #if __URQMD__ c URQMD cannot be used above 1000 GeV in CONEX, so use CORSIKA MC instead IF ( HILOELB .GT. 1000.D0 .AND. CXMCC(1) .LT. 1000.D0 ) THEN WRITE(MONIOU,*) 'WARNING: LOW ENERGY HADRONIC INTERACTION' * ,' MODEL URQMD CAN NOT BE USED ABOVE 1 TEV IN CONEX' IF ( FCXGHE ) THEN WRITE(MONIOU,*) ' PLEASE DO NOT USE CASCADE ONLY', * ' OR USE HILOW < 1000 GEV' STOP ELSE CXMCC(1) = HILOELB WRITE(MONIOU,*) 'LOW ENERGY MC TRANSITION ENERGY HAS BEEN ' * ,'CHANGED TO ',CXMCC(1) ENDIF ENDIF #elif __FLUKA__ c FLUKA cannot be used above 1000 GeV in CONEX, so use CORSIKA MC instead IF ( HILOELB .GT. 1000.D0 .AND. CXMCC(1) .LT. 1000.D0 ) THEN WRITE(MONIOU,*) 'WARNING: LOW ENERGY HADRONIC INTERACTION' * ,' MODEL FLUKA CAN NOT BE USED ABOVE 1 TEV IN CONEX' IF ( FCXGHE ) THEN WRITE(MONIOU,*) ' PLEASE DO NOT USE CASCADE ONLY', * ' OR USE HILOW < 1000 GEV' STOP ELSE CXMCC(1) = HILOELB WRITE(MONIOU,*) 'LOW ENERGY MC TRANSITION ENERGY HAS BEEN ' * ,'CHANGED TO ',CXMCC(1) ENDIF ENDIF #else c GHEISHA cannot be used above 100 GeV in CONEX, so use CORSIKA MC instead IF ( HILOELB .GT. 100.D0 .AND. CXMCC(1) .LT. 100.D0 ) THEN WRITE(MONIOU,*) 'WARNING: LOW ENERGY HADRONIC INTERACTION' * ,' MODEL GHEISHA CAN NOT BE USED ABOVE 100 GEV IN CONEX' IF ( FCXGHE ) THEN WRITE(MONIOU,*) ' PLEASE DO NOT USE CASCADE ONLY', * ' OR USE HILOW < 1000 GEV' STOP ELSE CXMCC(1) = HILOELB WRITE(MONIOU,*) 'LOW ENERGY MC TRANSITION ENERGY HAS BEEN ' * ,'CHANGED TO ',CXMCC(1) ENDIF ENDIF #endif IF ( ELCUT(1) .LT. enymin .AND. ( CXMCC(1) .LT. enymin * .OR. FCXGHE ) ) THEN WRITE(MONIOU,*) 'WARNING: HADRONS CANNOT BE FOLLOWED' * ,' BELOW', enymin, 'GEV IN CONEX (ELCUT(1))' IF ( FCORS .OR. .NOT. LLONGI ) THEN CXMCC(1) = HILOELB !NOT 1. TO GET SECONDARIES FROM PARTICLES WITH HIGHER ENERGY WRITE(MONIOU,*) 'LOW ENERGY MC TRANSITION ENERGY HAS BEEN ', * 'CHANGED TO ',CXMCC(1) ENDIF ENDIF IF ( ELCUT(2) .LT. enymin .AND. ( CXMCC(2) .LT. enymin * .OR. FCXGHE ) ) THEN WRITE(MONIOU,*) 'WARNING: MUONS CANNOT BE FOLLOWED' * ,' BELOW ',enymin,' GEV IN CONEX (ELCUT(2))' IF ( FCORS .OR. .NOT. LLONGI ) THEN CXMCC(1) = MAX(HILOELB,CXMCC(1)) !NOT 1. TO GET SECONDARIES FROM PARTICLES WITH HIGHER ENERGY CXMCC(2) = 1.D0 WRITE(MONIOU,*) 'LOW ENERGY MC TRANSITION ENERGY HAS BEEN ', * 'CHANGED TO ',CXMCC(1),' AND ',CXMCC(2) ENDIF ENDIF IF ( ELCUT(3) .LT. emin .OR. ELCUT(4) .LT. emin ) THEN IF ( LLONGI ) CXMCS = 1.D20 !LOW ENERGY MC ON FULL SLANT DEPTH RANGE TO GET LONGITUDINAL PROFILE RIGHT IF ( ( CXMCC(3) .LT. MIN( ELCUT(3), ELCUT(4) ) * .OR. FCXGHE ) ) THEN WRITE(MONIOU,*) 'WARNING: E/M PARTICLES CANNOT BE FOLLOWED' WRITE(MONIOU,*) ' BELOW 1 MEV IN CONEX ', * '(ELCUT(3) OR ELCUT(4) < 1 MEV)' IF ( FCORS .OR. .NOT. LLONGI ) THEN CXMCC(3) = MAX( 0.2D0, CXMCC(3) ) !NOT 0.001 TO GET SECONDARIES FROM PARTICLES WITH HIGHER ENERGY (NOT MORE THAN 200 MEV TO AVOID PRODUCTION OF LARGE WEIGHT MUONS OR HADRONS) WRITE(MONIOU,*) 'LOW ENERGY MC TRANSITION ENERGY HAS ', * 'BEEN CHANGED TO ',CXMCC(3),' GEV' ENDIF ENDIF ENDIF C IF CORSIKA NOT USED FORCE MAXIMUM USE OF CE (DO NOT CHANGE FIRST DEVELOPMENT C OF THE SHOWER BUT RESULTS ARE VALID ONLY FOR EDEP AND XMAX) IF ( .NOT. FCORS .AND. LLONGI ) THEN WRITE(MONIOU,*) ' ' WRITE(MONIOU,*) 'NO MC IN CORSIKA PART : FORCE USE OF CE !' WRITE(MONIOU,*) 'RESULTS ARE VALID ONLY FOR ENERGY ', * 'DEPOSIT AND XMAX' CXMCC(1) = 0D0 CXMCC(2) = 0D0 CXMCC(3) = 0D0 ENDIF zshlow=CXMCS EVTH(161)=CXMCS ehlowi=CXMCC(1) EVTH(165)=CXMCC(1) emlowi=CXMCC(2) EVTH(166)=CXMCC(2) eelowi=CXMCC(3) EVTH(167)=CXMCC(3) C print out parameter mshow=1 C Transition energy for hadronic models EgyHiLoLim=min(100d0,max(HILOELB,enymin)) C 3D MC i1DMC=0 C LPM effect #if __LPM__ || __THIN__ ilpmeffect=1 #else ilpmeffect=0 #endif C Flat (T) or curved (F) hground lFlat=FFLATOUT #ifdef __PRESHOW__ C Preshower ipreshow=IPREPR #endif #if __SLANT__ if ( LLONGI ) then dzcnx=delzsh dzratio=THSTEP/dzcnx idzcx2cors=max(1,nint(dzratio)) if ( abs(dzratio-dble(idzcx2cors)) .gt. 1d-6 ) then WRITE(MDEBUG,*)'CONEXINI: GIVEN LONGI THSTEP NOT COMPATIBLE ', * 'WITH CONEX, USE ',dble(idzcx2cors)*dzcnx STOP endif else dzcnx=1.d0 endif #endif #if __STACKIN__ ifinput=1 !read particles from stackin file #endif RETURN END *-- Author : T.PIEROG IK FZK KARLSRUHE 14/12/2007 C======================================================================= SUBROUTINE CONEXLNK( THICK1,CHISUM,CHISM2 ) C----------------------------------------------------------------------- C CONEX L(I)NK C C THIS SUBROUTINE CALLS CONEX TO SIMULATE THE SHOWER FROM THE FIRST C INTERACTION UNTIL THE END OF CASCADE EQUATIONS AND STORES THE SECONDARY C PARTICLES ONTO STACK TO TREAT THEM AS ONE SINGLE SHOWER. C THIS SUBROUTINE IS CALLED FROM AAMAIN. C ARGUMENTS: C THICK1 = THICKNESS OF FIRST INTERACTION (G/CM**2) C CHISUM = SUM OF THICKNESS OF FIRST INTERACTION (G/CM**2) C CHISM2 = SQUARE OF CHISUM C----------------------------------------------------------------------- IMPLICIT NONE #define __ATMOS2INC__ #define __BUFFSINC__ #define __CONEXINC__ #define __ELASTYINC__ #define __LONGIINC__ #define __OBSPARINC__ #define __PAMINC__ #define __PARPARINC__ #define __REJECTINC__ #define __RUNPARINC__ #define __SFRONTINC__ #if __THIN__ #define __THNVARINC__ #endif #include "corsika.h" #include "conex.h" DOUBLE PRECISION ENERGY,thedeg,phideg,distL,H,CHISUM,CHISM2 & ,THICK1 INTEGER ighe,J dimension ighe(3) #if __SLANT__ DOUBLE PRECISION EDEPB,WEI,dzratio INTEGER ILcx,iz,IL,idzcx2cors,LPCT0,LPCT1,LPCT2 #endif DOUBLE PRECISION distance0,heightt,THICK,dimpact,TANTE,DXY EXTERNAL distance0,heightt,THICK SAVE C----------------------------------------------------------------------- #if __CURVED__ IF (DEBUG) WRITE(MDEBUG,1) (PRMPAR(J),J=0,8),PRMPAR(14) 1 FORMAT(' CONEXLNK: ',1P,10E11.3) #else IF ( DEBUG ) WRITE(MDEBUG,1) (PRMPAR(J),J=0,8) 1 FORMAT(' CONEXLNK: ',1P,9E11.3) #endif #if __SLANT__ if ( LLONGI ) then dzratio=THSTEP/dzcnx idzcx2cors=max(1,nint(dzratio)) if ( abs(dzratio-dble(idzcx2cors)) .gt. 1d-6 ) then WRITE(MDEBUG,*)'CONEXLNK: THSTEP NOT COMPATIBLE WITH CONEX' WRITE(MDEBUG,*)'PLEASE CHECK AUTOMATIC SETTING OF THSTEP !' STOP endif endif #endif IF ( PAMA(NINT( PRMPAR(0) )) .NE. 0.D0 ) THEN energy = PRMPAR(1) * PAMA(NINT( PRMPAR(0) )) else energy = PRMPAR(1) endif #if __THIN__ C THINNING AND SAMPLING FOR HADRONS hthin=EFRCTHN*THINRATH if ( hthin .lt. 1.d-15 ) then ihthin=0 else ihthin=1 endif fwhmax=CXWMX(1) !sampling weight wshmax=WMAX !sampling weight overwritten if fwhmax>0 whmax=WMAX !thinning weight C SAMPLING FOR MUONS fwmmax=CXWMX(2) !sampling weight wsmmax=WMAX !sampling weight overwritten if fwmmax>0 C THINNING AND SAMPLING FOR EM thin=EFRCTHN*THINRAT if ( thin .lt. 1.d-15 ) then iothin=0 else iothin=1 endif fwemax=CXWMX(3) !sampling weight wsemax=WMAXEM !sampling weight overwritten if fwemax>0 wtmax=WMAXEM !thinning weight C IF LOW ENERGY CASCADE ARE USED FORCE THINNING WEIGHT IN CORSIKA C TO SAMPLING WEIGHT IN CONEX IF ( FCXCE .AND. .NOT.FCXWMX .AND. CXWMX(1) .GT. 0.D0 * .AND. CXWMX(3) .GT. 0.D0 ) THEN WMAX = MAX( 1.D0, CXWMX(1) * PRMPAR(1) ) WMAXEM = MAX( 1.D0, CXWMX(3) * PRMPAR(1) ) EVTH(150) = WMAX EVTH(151) = WMAXEM ENDIF EVTH(169) = whmax EVTH(170) = wtmax EVTH(171) = WMAX if(fwhmax.gt.0d0)EVTH(171)=max(1d0,energy*fwhmax) EVTH(172) = WMAX if(fwmmax.gt.0d0)EVTH(172)=max(1d0,energy*fwmmax) EVTH(173) = WMAXEM if(fwemax.gt.0d0)EVTH(173)=max(1d0,energy*fwemax) #else iothin=0 ihthin=0 fwhmax=1d-20 fwmmax=1d-20 fwemax=1d-20 whmax=1d0 wtmax=1d0 EVTH(169) = 0. EVTH(170) = 0. EVTH(171) = 0. EVTH(172) = 0. EVTH(173) = 0. #endif C Conversion factor for X,Y and T CXXCONV=0.D0 CXYCONV=0.D0 CXTCONV=TCEN #if __UPWARD__ IF ( FIMPCT ) altitude= HIMPCT*1d-2 - hground !skimming impact parameter (horizontal showers) #endif C Conversion parameters thedeg=THETAP*180.d0/PI phideg=(PHIP-PI*0.5D0)*180.d0/PI !in CORSIKA, Phi=0 == coming from x<0 == from south to north : correspond to -90 deg in CONEX (where phi=0=x=coming from East) c height of starting point of the shower XminP=PRMPAR(5)*1d-2 lxfirst=.false. Xfirst=1.d30 !first Interaction point IF( FIX1I ) THEN Xfirst=FIXHEI*1d-2 !first Interaction point lxfirst=.true. XfirstIn=dble( N1STTR ) ENDIF C CORSIKA compiled with CORSIKA or not #if __GHEISHAD__ ighe(1)=1 #else ighe(1)=0 #endif FINCNX = .TRUE. dimpact = HIMPCT*0.01D0 !impact parameter (m) call ConexRun(idcx,energy,thedeg,phideg,dimpact,ighe) c plot distributions from conex in histo file c call xHadronCascade(1,7) c call xElectronPhotonCascade C First interaction parameters for statistics if(XfirstIn.ge.0d0) &ELAST = 1.d0-XfirstIn distL = abs(distance0(Xfirst)) H = heightt(distL,radtr0)*100d0 ! altitude (cm) of first int. THICK1 = THICK( H ) IF ( PRMPAR(0) .GT. 3.D0 .OR. .NOT. FEGS ) THEN CHISUM = CHISUM + THICK1 CHISM2 = CHISM2 + THICK1**2 ENDIF #if __SLANT__ IF ( LLONGI ) THEN LPCT0=max( 0 , nminX/idzcx2cors -1 ) LPCT1=LPCT0 + 1 LPCT2=min( NSTEP , nmaxX/idzcx2cors ) C Fill longitunal histograms C LOOP OVER ALL LONGITUDINAL BINS FOR ENERGY DEPOSIT DO IL = LPCT1, LPCT2 ilcx=IL*idzcx2cors+1 C GAMMA LONGITUDINAL DEVELOPMENT FOR DEPOSIT EDEPB=0.d0 do iz=ilcx-idzcx2cors,ilcx-1 EDEPB=EDEPB+Edepo(iz,1) enddo EDEPB = EDEPB * dzcnx !in CONEX, edepo is given per g/cm2 DLONG(IL,1) = DLONG(IL,1) + EDEPB C E(+/-) LONGITUDINAL DEVELOPMENT FOR DEPOSIT EDEPB=0.d0 do iz=ilcx-idzcx2cors,ilcx-1 EDEPB=EDEPB+Edepo(iz,2) enddo EDEPB = EDEPB * dzcnx !in CONEX, edepo is given per g/cm2 DLONG(IL,2) = DLONG(IL,2) + EDEPB C EM (+HAD in CONEX) LOST ENERGY (CUT) EDEPB=0.d0 do iz=ilcx-idzcx2cors,ilcx-1 EDEPB=EDEPB+Edepo(iz,3) enddo EDEPB = EDEPB * dzcnx !in CONEX, edepo is given per g/cm2 DLONG(IL,3) = DLONG(IL,3) + EDEPB C MUON(+/-) LONGITUDINAL DEVELOPMENT FOR DEPOSIT EDEPB=0.d0 do iz=ilcx-idzcx2cors,ilcx-1 EDEPB=EDEPB+Edepo(iz,5) enddo EDEPB = EDEPB * dzcnx !in CONEX, edepo is given per g/cm2 DLONG(IL,4) = DLONG(IL,4) + EDEPB C CHARGED HADRON LONGITUDINAL DEVELOPMENT FOR DEPOSIT EDEPB=0.d0 do iz=ilcx-idzcx2cors,ilcx-1 EDEPB=EDEPB+Edepo(iz,4)-Edepo(iz,9)-Edepo(iz,10) enddo EDEPB = EDEPB * dzcnx !in CONEX, edepo is given per g/cm2 DLONG(IL,6) = DLONG(IL,6) + EDEPB C NEUTRAL HADRON LONGITUDINAL DEVELOPMENT FOR DEPOSIT EDEPB=0.d0 do iz=ilcx-idzcx2cors,ilcx-1 EDEPB=EDEPB+Edepo(iz,9)+Edepo(iz,10) enddo EDEPB = EDEPB * dzcnx !in CONEX, edepo is given per g/cm2 DLONG(IL,7) = DLONG(IL,7) + EDEPB ENDDO C LOOP OVER ALL LONGITUDINAL BINS FOR NUMBER OF PARTICLES DO IL = LPCT0, LPCT2 ilcx=IL*idzcx2cors+1 c print *,Il,ilcx,zshmin+delzsh*(ilcx-1),THCKRL(IL) C GAMMA LONGITUDINAL DEVELOPMENT FOR ENERGY, PARTICLES WEI=XProf(ilcx,1,1) c ELONG(IL,1) = ELONG(IL,1) + (EFRST+(IL-LPCT1)*EDEPB) !not in CONEX yet PLONG(IL,1) = PLONG(IL,1) + WEI C POSITRON LONGITUDINAL DEVELOPMENT FOR ENERGY, PARTICLES WEI=XProf(ilcx,1,2) c ELONG(IL,2) = ELONG(IL,2) + (EFRST+(IL-LPCT1)*EDEPB) !not in CONEX yet PLONG(IL,2) = PLONG(IL,2) + WEI C ELECTRON LONGITUDINAL DEVELOPMENT FOR ENERGY, PARTICLES WEI=XProf(ilcx,1,-1) c ELONG(IL,3) = ELONG(IL,3) + (EFRST+(IL-LPCT1)*EDEPB) !not in CONEX yet PLONG(IL,3) = PLONG(IL,3) + WEI C MUON(+) LONGITUDINAL DEVELOPMENT FOR ENERGY, PARTICLES WEI=XProf(ilcx,1,3)*0.5D0 !in CONEX mu+ + mu- stored c ELONG(IL,4) = ELONG(IL,4) + (EFRST+(IL-LPCT1)*EDEPB) !not in CONEX yet PLONG(IL,4) = PLONG(IL,4) + WEI C MUON(-) LONGITUDINAL DEVELOPMENT FOR ENERGY, PARTICLES c ELONG(IL,5) = ELONG(IL,5) + (EFRST+(IL-LPCT1)*EDEPB) !not in CONEX yet PLONG(IL,5) = PLONG(IL,5) + WEI C HADRON LONGITUDINAL DEVELOPMENT FOR ENERGY, PARTICLES WEI=XProf(ilcx,1,4) c ELONG(IL,6) = ELONG(IL,6) + (EFRST+(IL-LPCT1)*EDEPB) c ELONG(IL,7) = ELONG(IL,7) + (EFRST+(IL-LPCT1)*EDEPB) PLONG(IL,6) = PLONG(IL,6) + WEI C CHARGED HADRON LONGITUDINAL DEVELOPMENT FOR ENERGY, PARTICLES WEI=XProf(ilcx,1,6)+XProf(ilcx,1,7)+XProf(ilcx,1,8) PLONG(IL,7) = PLONG(IL,7) + WEI C NUCLEI LONGITUDINAL DEVELOPMENT FOR PARTICLES WEI=XProf(ilcx,1,0)-XProf(ilcx,1,2)-XProf(ilcx,1,3)-WEI & -XProf(ilcx,1,-1) c ELONG(IL,8) = ELONG(IL,8) + (EFRST+(IL-LPCT1)*EDEPB) PLONG(IL,8) = PLONG(IL,8) + max(0.d0,WEI) #if __ANAHIST__ C NUCLEON LONGITUDINAL DEVELOPMENT FOR PARTICLES WEI=XProf(ilcx,1,5) PLONG(IL,11) = PLONG(IL,11) + WEI C PROTON LONGITUDINAL DEVELOPMENT FOR PARTICLES WEI=XProf(ilcx,1,8) PLONG(IL,12) = PLONG(IL,12) + WEI C NEUTRON LONGITUDINAL DEVELOPMENT FOR PARTICLES WEI=XProf(ilcx,1,9) PLONG(IL,13) = PLONG(IL,13) + WEI C PI(+/-) LONGITUDINAL DEVELOPMENT FOR PARTICLES WEI=XProf(ilcx,1,6) PLONG(IL,14) = PLONG(IL,14) + WEI C K(+/-) LONGITUDINAL DEVELOPMENT FOR PARTICLES WEI=XProf(ilcx,1,7) PLONG(IL,15) = PLONG(IL,15) + WEI C K(l/s) LONGITUDINAL DEVELOPMENT FOR PARTICLES WEI=XProf(ilcx,1,10) c PLONG(IL,16) = PLONG(IL,16) + WEI !Kl not separatly in CONEX c PLONG(IL,17) = PLONG(IL,17) + WEI !Ks not separatly in CONEX PLONG(IL,18) = PLONG(IL,18) + WEI #endif ENDDO ENDIF #endif #if __PARALLEL__ C CLOSE FILE FOR ECUT PARTICLE OUTPUT AFTER CONEX NOT C TO WAIT UNTIL THE SHOWER IS FINISHED TO BE ABLE TO START A NEW JOB C (NO PARTICLE WITH E>ECTCUT CAN BE CREATED AFTER CONEX) IF ( FECTOUT .AND. FCORS ) THEN C GROUP PARTICLE IN ECUT BY ENERGY TO REACH ECTMAX C AND SEND INFORMATION TO OUTSIDE CALL SENDCUT IF ( DEBUG ) * WRITE(MDEBUG,*) 'CONEXLNK: ECUT PARTICLE OUTPUT SAVED' FECTOUT = .FALSE. ELSE FECTOUT = .FALSE. ENDIF #endif RETURN END *-- 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 #define __BUFFSINC__ #define __CONEXINC__ #define __OBSPARINC__ #define __PARPARINC__ #define __REJECTINC__ #define __RUNPARINC__ #include "corsika.h" #include "conex.h" DOUBLE PRECISION distance0,heightt,distL,H,COSTAP,COSTEA,SINTEA * ,HAPP,DXY,Xfirsti EXTERNAL distance0,heightt SAVE C----------------------------------------------------------------------- C First interaction parameters FNPRIM = .TRUE. FIRSTI = .FALSE. distL = abs(distance0(Xfirsti)) distL = distL*100d0 ! distance on shower axis (cm) of first int. ctp update prmpar with position of first interaction for PRMINFO COSTAP = COS( THETAP ) HAPP = distL*COSTAP DXY = SQRT( (distL - HAPP)*(distL+HAPP) ) HAPP = HAPP + OBSLEV(1) H = SQRT( (HAPP+C(1))**2 + DXY**2 ) - C(1) ! altitude of first int COSTEA = ( HAPP + C(1) ) / ( H + C(1) ) COSTEA = MIN( 1D0, COSTEA ) PRMPAR(5) = H PRMPAR(6) = CXTCONV - distL/C(25) PRMPAR(7) = - COS( PHIP ) * DXY PRMPAR(8) = - SIN( PHIP ) * DXY PRMPAR(9) = Xfirsti PRMPAR(14) = HAPP PRMPAR(15) = COSTAP PRMPAR(16) = COSTEA EVTH(7)= -H !TMARGIN=.true. for CONEX CALL TOBUF( EVTH,0 ) !save evth after first interaction in CONEX RETURN END *-- Author : T.PIEROG IK FZK KARLSRUHE 14/12/2007 C======================================================================= SUBROUTINE CXMUBREM( id,epi,LIT ) 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 (GeV) c LIT = Material (1=Nitrogen, 2=Oxygen, 3=Argon) c orig : d. heck jun. 25, 2003 c Adaptation for Conex by T. Pierog mar. 15, 2005 C----------------------------------------------------------------------- IMPLICIT NONE #define __MUPARTINC__ #define __SIGMUINC__ #include "corsika.h" #include "conex.h" include 'conex.incnex' 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,KCOUNT,LIT,id DOUBLE PRECISION CBRSGM,drangen EXTERNAL CBRSGM,drangen double precision epi(5),epf(5),RD(3),PT SAVE ALFA1 DATA ALFA1/0.625D0/ 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 ( LIT .EQ. 1 ) THEN SIGOLD = FRABTN / airw(1) ELSEIF ( LIT .EQ. 2 ) THEN SIGOLD = (FRBTNO - FRABTN) / airw(2) ELSEIF ( LIT .EQ. 3 ) THEN SIGOLD = (SIGBRM - FRBTNO) / airw(3) ELSE WRITE(ifck,*) 'CXMUBREM: WRONG TARGET LIT =',LIT,' STOP' STOP ENDIF C GET NEW CROSS-SECTION SIGNEW = CBRSGM( EE,LIT,1 ) RD(1) = drangen(dble(LIT)) 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+LIT)/EE C MAXIMUM OF BREMSSTRAHLUNG SPECTRUM IS NEGATIVE, NO BREMSSTRAHLUNG IF ( VM .LE. 0.D0 ) GOTO 900 CREJ = CMUON(3+LIT)/EE KCOUNT = 0 50 CONTINUE KCOUNT = KCOUNT + 1 IF ( KCOUNT .GT. 1000 ) GOTO 900 RD(1) = drangen(dble(KCOUNT)) RD(2) = drangen(dble(KCOUNT)) V = VC*(VM/VC)**RD(1) V1 = 1.D0 - V C COMPUTE REJECTION FUNCTION F1 = CMUON(LIT) - LOG(1.D0 + CREJ*V/V1) SCREJ = (V1 + 0.75D0*V*V)*F1/CMUON(LIT) 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 LIT (1=N, 2=O, 3=AR) WHICH HAS BEEN SET IN BOX2 Z = airz(LIT) 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__ write(*,*) 'Negative Energy in CXMUBREM !!!' write(ifck,*) 'Negative Energy in CXMUBREM !!!' write(ifck,*) kcount,id,epf,V1,ekin,ekin write(ifck,*) 'try again ...' #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 *-- Author : T.PIEROG IK FZK KARLSRUHE 14/12/2007 C======================================================================= SUBROUTINE CXMUNUCL( id,epi,LIT ) C----------------------------------------------------------------------- C C(ONE)X MU(ON) NUCL(EAR INTERACTION) 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 (GeV) c LIT = Material (1=Nitrogen, 2=Oxygen, 3=Argon) c orig : d. heck jun. 25, 2003 c Adaptation for Conex by T. Pierog mar. 16, 2005 C----------------------------------------------------------------------- IMPLICIT NONE #define __MUPARTINC__ #define __SIGMUINC__ #include "corsika.h" #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 c EGS4 Stack 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,X,Y,Z,U,V,W,DNEAR,WT integer IQ,IR,LATCH,LATCHI,NP 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,KCOUNT,id,LIT double precision rtr1,pinv,sintheP,sinphiP,costheP * ,cosphiP,ep(3),distance0 DOUBLE PRECISION CNUSGM,drangen,epi(5),epf(5),RD(2),EGAM SAVE EXTERNAL CNUSGM,drangen,distance0 C----------------------------------------------------------------------- C SET MATERIAL CONSTANTS ACCORDING TO TARGET INDEX LIT (1=N, 2=O, 3=AR) C WHICH HAS BEEN SET IN BOX2, AND RESTORE OLD CROSS-SECTIONS IF ( LIT .EQ. 1 ) THEN SIGOLD = FRANTN / airw(1) ELSEIF ( LIT .EQ. 2 ) THEN SIGOLD = (FRNTNO - FRANTN) / airw(2) ELSEIF ( LIT .EQ. 3 ) THEN SIGOLD = (SIGNUC - FRNTNO) / airw(3) ELSE WRITE(*,*) 'CXMUNUCL: WRONG TARGET LIT=',LIT,' STOP' STOP ENDIF AATOM=aira(LIT) 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 = CNUSGM( EE,LIT,1 ) RD(1) = drangen(dble(LIT)) 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 KCOUNT = 0 1 CONTINUE KCOUNT = KCOUNT + 1 C WRITE MUON UNCHANGED TO STACK IF ( KCOUNT .GT. 1000 ) GOTO 900 RD(1) = drangen(dble(KCOUNT)) RD(2) = drangen(dble(KCOUNT)) 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 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 #ifdef __MC3D__ 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 #ifdef __MC3D__ 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 *-- Author : T.PIEROG IK FZK KARLSRUHE 14/12/2007 C======================================================================= SUBROUTINE CXMUPINI C----------------------------------------------------------------------- C C(ONE)X MU(ON) P(ARAMETER) INI(TIALIZATION) C 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 jun. 25, 2003 c Adaptation for Conex by T. Pierog mar. 15, 2005 C----------------------------------------------------------------------- IMPLICIT NONE #define __ELABCTINC__ #define __MUPARTINC__ #define __PIONINC__ #define __RUNPARINC__ #include "corsika.h" #include "conex.h" DOUBLE PRECISION cdeca DOUBLE PRECISION DEDXBR,DEDXNI,DEDXPR INTEGER J,JJMAT DOUBLE PRECISION DBRELM,DNIELM,DPRELM SAVE EXTERNAL DBRELM,DNIELM,DPRELM C----------------------------------------------------------------------- #ifdef __CXDEBUG__ call utisx1('CXMUPINI ',8) #endif 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) 106 FORMAT(' ',I3,1P,1X,E12.5,4(1X,E13.6)) #endif ENDDO endif #ifdef __CXDEBUG__ call utisx2 #endif C SET AGAIN BCUT BELOW THE PI THERSHOLD BCUT = MIN( ELCUT(3), PITHR*1.D-3 ) IF ( DEBUG ) WRITE(MDEBUG,*) 'CXMUPINI: BCUT =',BCUT,' GEV' RETURN END *-- Author : T.PIEROG IK FZK KARLSRUHE 14/12/2007 C======================================================================= SUBROUTINE CXMUPRPR( id,epi,LIT ) 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 (GeV) c LIT = Material (1=Nitrogen, 2=Oxygen, 3=Argon) c orig : d. heck jun. 25, 2003 c Adaptation for Conex by T. Pierog 2009 C----------------------------------------------------------------------- IMPLICIT NONE #define __MUPARTINC__ #define __SIGMUINC__ #include "corsika.h" #include "conex.h" include 'conex.incnex' 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) double precision epi(5),epf(5),RD(3),PT,Ptot INTEGER I,KCOUNT,id,LIT DOUBLE PRECISION CPRSGM,DKOKOI,PPCS,drangen,EELOG SAVE EXTERNAL CPRSGM,DKOKOI,PPCS,drangen C----------------------------------------------------------------------- C SET MATERIAL CONSTANTS CMUON(.) ACCORDING TO TARGET INDEX LIT C (1=N, 2=O, 3=AR) WHICH WAS SET IN BOX2; RESTORE OLD CROSS-SECTION IF ( LIT .EQ. 1 ) THEN SIGOLD = FRAPTN / airw(1) ELSEIF ( LIT .EQ. 2 ) THEN SIGOLD = (FRPTNO - FRAPTN) / airw(2) ELSEIF ( LIT .EQ. 3 ) THEN SIGOLD = (SIGPRM - FRPTNO) / airw(3) ELSE WRITE(*,*) 'CXMUPRPR: WRONG TARGET LIT =',LIT,' STOP' STOP ENDIF ZATOM = airz(LIT) 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 = CPRSGM( EE,LIT,1 ) RD(1) = drangen(dble(LIT)) 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 KCOUNT = 0 321 CONTINUE KCOUNT = KCOUNT + 1 IF ( KCOUNT .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 *-- Author : T.PIEROG IK FZK KARLSRUHE 14/12/2007 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 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 ee particle kinetic energy (GeV) C rho air density (g/cm**3) (for Sternheimer correction for muons) C----------------------------------------------------------------------- implicit none #include "conex.h" common /CRMMMASS/pmassmm double precision pmassmm double precision xm,etot,rho,ee double precision CDEDXM,AIRDEDXMU,AIRDEDX,AIRDEDXMM integer np,nucl SAVE external CDEDXM,AIRDEDXMU,AIRDEDX,AIRDEDXMM C----------------------------------------------------------------------- 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 + CDEDXM(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 RETURN END *-- Author : T.PIEROG IK FZK KARLSRUHE 14/12/2007 C======================================================================= SUBROUTINE FROMCNX C----------------------------------------------------------------------- C FROM C(O)N(E)X C C THIS SUBROUTINE IS CALLED BY CONEX TO STORE THE SECONDARY C PARTICLES ONTO CORSIKA STACK. C THIS SUBROUTINE IS CALLED FROM d2cors IN CONEX. C ARGUMENTS: C----------------------------------------------------------------------- IMPLICIT NONE #define __BUFFSINC__ #define __CONEXINC__ #define __GENERINC__ #define __OBSPARINC__ #define __PAMINC__ #define __PARPARINC__ #define __RANDPAINC__ #define __RUNPARINC__ #define __SFRONTINC__ #define __THNVARINC__ #if __MULTITHIN__ #define __MULTHININC__ #endif #if __THIN__ #define __PARPAEINC__ #endif #include "corsika.h" c #include "conex.h" !conflict with RANDPAINC double precision dptl common /cxoptl/dptl(16) !to be changed if mxblk change in CONEX integer mxisx,isx,nisx,isxsave,isxxsave,isxsub character*500 subisx,textisx parameter (mxisx=200) common/cxisx/isx,nisx,subisx(mxisx),isxsub(mxisx) & ,isxsave,isxxsave,textisx !also in gheisha_nexus c end conex common DOUBLE PRECISION XXX,YYY,PX,PY,PZ,EN,AUXIL DOUBLE PRECISION COSTHJ,CPHIJ,SPHIJ,EP(3),AHEIGHT DOUBLE PRECISION sphiP,cphiP,DIST,RRR INTEGER ID,NTYP,idtrafocx,I,nchrg,NPART DOUBLE PRECISION DIAG #if !__PARALLEL__ DOUBLE PRECISION FACS,U1S,U2S LOGICAL KNORS #endif EXTERNAL ToObs,idtrafocx SAVE DATA NPART/0/ C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'FROMCNX:' IF ( .NOT. FCORS ) RETURN c Read CONEX stack until it''s empty IF ( DEBUG ) THEN WRITE(MDEBUG,100) dptl 100 format(' conex:',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 NTYP = 0 id = nint(dptl(10)) if(id.eq.41.or.id.eq.43)then NTYP = id else if(mod(id,100).ne.0)then NTYP = idtrafocx('nxs','cor',id) elseif(id.lt.0)then !strangelet NTYP = 42 else !nuclei nchrg = id/100 if(id.eq.3)then nchrg = 1 else nchrg = int(dble(nchrg) / 2.15d0 + 0.7d0) endif NTYP = id + nchrg endif endif if(NTYP.le.0)then WRITE(MDEBUG,*) 'FROMCNX: PROBLEM WITH ID ! ',id,NTYP GOTO 333 endif PX = dptl(1) PY = dptl(2) PZ = dptl(3) EN = dptl(4) ALEVEL = dptl(8)*100d0 if(ALEVEL.le.OBSLEV(1))ALEVEL = OBSLEV(1) + 1d-4 !add 1 micrometer to be just above ground AHEIGHT = C(1) + ALEVEL SECPAR(5) = ALEVEL SECPAR(6) = CXTCONV + dptl(9)*100d0/C(25) !time in s (time is <0 and in m in CONEX) GEN = dptl(12) SECPAR(9) = GEN SECPAR(10) = ALEVEL C POLARIZATION NOT USED SECPAR(11) = 0.D0 ! POLARIZATION SECPAR(12) = 0.D0 ! POLARIZATION C NO THINNING OF SECONDARY PARTICLES #if __THIN__ WEIGHT = dptl(11) SECPAR(13) = WEIGHT #endif XXX = dptl(6)*100.d0 YYY = dptl(7)*100.d0 DIST = SQRT ( XXX*XXX + YYY*YYY ) C CALCULATE GLOBAL PARAMETERS VALID FOR ALL SECONDARIES. C FOR FURTHER COMMENTS SEE SUBR. COOINC. if ( AHEIGHT .ge. DIST ) then SECPAR(14) = SQRT( ( AHEIGHT - DIST ) * ( AHEIGHT + DIST ) )!total height at mid detector (in observer frame HAPP) else WRITE(MDEBUG,*) 'FROMCNX: PROBLEM WITH HEIGHT ! ',AHEIGHT,DIST GOTO 333 endif C CALCULATE COSTEA SECPAR(16) = MIN( 1d0, SECPAR(14) / AHEIGHT ) SECPAR(14) = SECPAR(14) - C(1) C RRR is projection on Earth surface of DIST C Note that we use Earth surface at C(1) not at observation level ! RRR= C(1) * ACOS( SECPAR(16) ) C DIAG is the distance between particle and impact point at observer level DIAG= SQRT( DIST*DIST + (SECPAR(14)-OBSLEV(1))**2 ) C COSINE OF APPARARENT ZENITH ANGLE OF PARTICLE POSITION SECPAR(15) = (SECPAR(14)-OBSLEV(1))/DIAG C CALCULATE THE GAMMA FACTORS IF ( PAMA(NTYP) .NE. 0.D0 ) THEN SECPAR(1) = EN / PAMA(NTYP) IF ( SECPAR(1) .LE. 1.D0 ) THEN WRITE(MONIOU,*) 'FROMCNX: PARTICLE PT REJECT ',EN,PAMA(NTYP) GOTO 333 ENDIF ELSE SECPAR(1) = EN ENDIF AUXIL = PX**2 + PY**2 + PZ**2 C SKIP PARTICLE WITH WRONG MOMENTA IF ( AUXIL .LE. 0.D0 ) GOTO 333 C CALCULATE THE EMISSION ANGLES AUXIL = SQRT( AUXIL ) COSTHJ = PZ / AUXIL COSTHJ = MAX( -1.D0, MIN( 1.D0, COSTHJ ) ) CPHIJ = PX / AUXIL SPHIJ = PY / AUXIL if ( DIST .gt. 1.d-20 ) then sphiP = YYY/DIST cphiP = XXX/DIST else sphiP = 0.d0 cphiP = 1.d0 endif ep(1) = CPHIJ ep(2) = SPHIJ ep(3) = COSTHJ C COSINE OF LOCAL ZENITH ANGLE SECPAR(2) = COSTHJ !angle compared to vertical to Earth center (local frame) call ToObs(ep,sphiP,cphiP,0d0,1d0) !direction of P in obs. frame for X and Y SECPAR(3) = ep(2) !in CORSIKA, x at North : conex y -> x corsika SECPAR(4) =-ep(1) !in CORSIKA, y at West : conex x -> -y corsika IF ( DEBUG ) WRITE(MDEBUG,*) * 'FROMCNX: COSTHE,HAPP,COSTAP,COSTEA =',SNGL(SECPAR(2)) * ,SNGL(SECPAR(14)),SNGL(SECPAR(15)),SNGL(SECPAR(16)) C X and Y coordinates are given in observer frame in CONEX but on Earth surface in CORSIKA SECPAR(7) = RRR * sphiP !(in CONEX Y=north, so X_cors= Y_conex) SECPAR(8) =-RRR * cphiP !(in CONEX X=east, so Y_cors=-X_conex) IF ( DEBUG ) WRITE(MDEBUG,*) 'FROMCNX: X,Y,DIST =', * SNGL(SECPAR(7)),SNGL(SECPAR(8)),SNGL(DIST) #if __MULTITHIN__ C CLEAR AND INITIALIZE WEIGHTS FOR THE DIFFERENT THINNING MODES SECPAR(40) = 8888000.D0 DO I = 1, 6 SECPAR(40+I) = 0.D0 ENDDO DO I = 1, NMTHIN SECPAR(40+I) = 1.D0 ENDDO #endif C STORE ONLY PARTICLES ABOVE ANGULAR CUT TO THE CORSIKA STACK #if __UPWARD__ IF ( SECPAR(2) .GE. -1.D0 ) THEN #else IF ( SECPAR(2) .GT. C(29) ) THEN #endif SECPAR(0) = NTYP INT_ICOUNT = 0 CALL TSTACK if( INT_ICOUNT .gt. 0 ) then DO I = 0, MAXLEN SECPAR(I) = STACKINT(I,1) STACKINT(I,1) = 0.D0 ENDDO CALL TSTOUT endif ELSEIF ( DEBUG ) THEN WRITE(MONIOU,*)'FROMCNX: PARTICLE BELOW ANGLE CUT ',SECPAR(2) ENDIF #if !__PARALLEL__ C COUNT THE NUMBER OF PARTICLE FROM CONEX SAVED IN CORSIKA STACK NPART = NPART +1 C EMPTY CORSIKA STACK BEFORE BUFFER IS SAVED TO DISK IF ( NPART .GE. 255 ) THEN C IF ( NPART .GE. 0 ) THEN C SAVE KNOR,FAC,U1 AND U2 TO AVOID VARIATIONS IN RANDOM NUMBERS KNORS = KNOR FACS = FAC U1S = U1 U2S = U2 C AND RESET KNOR KNOR = .TRUE. C SHOWER DEVELOPMENT IN CORSIKA MC FINCNX = .FALSE. CALL RUNSHOWER NPART = 0 FINCNX = .TRUE. IF ( DEBUG ) THEN isx = max ( 4, ISX0 ) ELSE isx = ISX0 ENDIF C RESTORE KNOR,FAC,U1 AND U2 TO AVOID VARIATIONS IN RANDOM NUMBERS KNOR = KNORS FAC = FACS U1 = U1S U2 = U2S ENDIF #else C IN PARALLEL MODE, ALL PARTICLES FROM CONEX GO TO SECOND STACK #endif 1000 RETURN 333 WRITE(MONIOU,*) 'FROMCNX: PARTICLE LOST' GOTO 1000 END *-- Author : T.PIEROG IK FZK KARLSRUHE 14/12/2007 C======================================================================= SUBROUTINE MUINTERACTION(id) C----------------------------------------------------------------------- C Muon Interaction Calculation c c subroutine called by cnexus c ARGUMANT: C ID = c c by T. Pierog mar. 15, 2005 C----------------------------------------------------------------------- implicit none #define __SIGMUINC__ #include "corsika.h" #include "conex.h" include 'conex.incnex' common/cxmubrint/cxMuBRPair,cxMuBRBrem double precision cxMuBRPair,cxMuBRBrem,dummy,rdmBR,ep(5),rd1 double precision drangen integer i,LIT,id SAVE external drangen C----------------------------------------------------------------------- c Initialize temporary stack do i=1,5 ep(i)=0.d0 istptlxs(i)=1 xsptl(1,i)=0.d0 xsptl(2,i)=0.d0 xsptl(3,i)=0.d0 xsptl(4,i)=0.d0 xsptl(5,i)=0.d0 ityptlxs(i)=0 iorptlxs(i)=1 jorptlxs(i)=1 ifrptlxs(1,i)=0 ifrptlxs(2,i)=0 xsorptl(1,i)=0.d0 xsorptl(2,i)=0.d0 xsorptl(3,i)=0.d0 xsorptl(4,i)=0.d0 xstivptl(1,i)=0.d0 xstivptl(2,i)=0.d0 idptlxs(i)=0 enddo nptlxs=0 ep(4)=dptl(4) ep(5)=dptl(5) 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 LIT = 1 ELSEIF ( RD1*SIGPRM .LE. FRPTNO ) THEN C PAIR PRODUCTION WITH OXYGEN LIT = 2 ELSE C PAIR PRODUCTION WITH ARGON LIT = 3 ENDIF #ifdef __CXDEBUG__ IF ( isx .ge. 4 ) WRITE(ifck,*) 'MuInteraction : Pair ',LIT #endif call CXMUPRPR(id,ep,LIT) elseif ( rdmBR .le. cxMuBRBrem ) then !Bremstrahlung IF ( RD1*SIGBRM .LE. FRABTN ) THEN C BREMSSTRAHLUNG WITH NITROGEN LIT = 1 ELSEIF ( RD1*SIGBRM .LE. FRBTNO ) THEN C BREMSSTRAHLUNG WITH OXYGEN LIT = 2 ELSE C BREMSSTRAHLUNG WITH ARGON LIT = 3 ENDIF #ifdef __CXDEBUG__ IF ( isx .ge. 4 ) WRITE(ifck,*) 'MuInteraction : Brems ',LIT #endif call CXMUBREM(id,ep,LIT) else !Nucl. Int IF ( RD1*SIGNUC .LE. FRANTN ) THEN C NUCLEAR INTERACTION WITH NITROGEN LIT = 1 ELSEIF ( RD1*SIGNUC .LE. FRNTNO ) THEN C NUCLEAR INTERACTION WITH OXYGEN LIT = 2 ELSE C NUCLEAR INTERACTION WITH ARGON LIT = 3 ENDIF #ifdef __CXDEBUG__ IF ( isx .ge. 4 ) WRITE(ifck,*) 'MuInteraction : Nuc. Int. ',LIT #endif call CXMUNUCL(id,ep,LIT) endif #ifdef __CXDEBUG__ if ( isx .ge. 6 ) call cxalist('MuIntera&',1,nptlxs,2) #endif RETURN END *-- Author : T.PIEROG IK FZK KARLSRUHE 14/12/2007 C======================================================================= SUBROUTINE MUSIGMA(Elab,SIGINEL) C----------------------------------------------------------------------- C Muon cross sections C c subroutine called by rlam C ARGUMENTS: C Elab = Muon total energy (GeV) (input) C SIGINEL = inelastic cross section (mb) (output) c c orig : d. heck jun. 25, 2003 c Adaptation for Conex by T. Pierog mar. 15, 2005 C----------------------------------------------------------------------- implicit none #define __SIGMUINC__ #include "corsika.h" #include "conex.h" common/cxmubrint/cxMuBRPair,cxMuBRBrem double precision Elab,SIGINEL,cxMuBRPair,cxMuBRBrem DOUBLE PRECISION CBRSGM,CNUSGM,CPRSGM SAVE EXTERNAL CBRSGM,CNUSGM,CPRSGM C----------------------------------------------------------------------- C CALCULATE MUON BREMSSTRAHLUNG CROSS-SECTION FOR AIR (MILLIBARN) FRABTN = airw(1) * CBRSGM( ELAB,1,1 ) FRBTNO = FRABTN + airw(2) * CBRSGM( ELAB,2,1 ) SIGBRM = FRBTNO + airw(3) * CBRSGM( ELAB,3,1 ) C CALCULATE MUON PAIR PRODUCTION CROSS-SECTION FOR AIR (MILLIBARN) FRAPTN = airw(1) * CPRSGM( ELAB,1,1 ) FRPTNO = FRAPTN + airw(2) * CPRSGM( ELAB,2,1 ) SIGPRM = FRPTNO + airw(3) * CPRSGM( ELAB,3,1 ) C CALCULATE MUON NUCLEAR INTERACTION CROSS-SECTION FOR AIR (MILLIBARN) FRANTN = airw(1) * CNUSGM( ELAB,1,1 ) FRNTNO = FRANTN + airw(2) * CNUSGM( ELAB,2,1 ) SIGNUC = FRNTNO + airw(3) * CNUSGM( ELAB,3,1 ) cxMuBRPair=SIGPRM cxMuBRBrem=SIGBRM+SIGPRM SIGINEL=cxMuBRBrem+SIGNUC if ( SIGINEL .gt. 0.d0 ) then cxMuBRPair=cxMuBRPair/SIGINEL cxMuBRBrem=cxMuBRBrem/SIGINEL endif RETURN END #endif #if __FLUKA__ *-- Author : D. HECK IK FZK KARLSRUHE 18/03/2003 C======================================================================= DOUBLE PRECISION FUNCTION FLRNDM() C----------------------------------------------------------------------- C FL(UKA) R(A)ND(O)M (GENERATOR) C SEE SUBROUT. RMMARD C WE USE HERE A SIMPLIFIED FORM OF RMMARD WITH JSEQ=1, LENV=1. C THIS FUNCTON IS CALLED FROM FLUKA ROUTINES. C----------------------------------------------------------------------- IMPLICIT NONE #define __RANMA3INC__ #define __RANMA4INC__ #if __CONEX__ #define __CONEXINC__ #endif #include "corsika.h" #if __CONEX__ #include "conex.h" #endif SAVE C----------------------------------------------------------------------- JSEQ = 1 #if __CONEX__ IF ( FINCNX ) JSEQ = lseq #endif 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 FLRNDM = UNI NTOT(JSEQ) = NTOT(JSEQ) + 1 IF ( NTOT(JSEQ) .GE. MODCNS ) THEN NTOT2(JSEQ) = NTOT2(JSEQ) + 1 NTOT(JSEQ) = NTOT(JSEQ) - MODCNS ENDIF RETURN END *-- Author : D. HECK IK FZK KARLSRUHE 22/10/2002 C======================================================================= BLOCK DATA FLUDAT C----------------------------------------------------------------------- C FLU(KA) DAT(A) C C SETS PARTICLE CODE TABLES FOR CONVERIONS BETWEEN CORSIKA AND FLUKA C----------------------------------------------------------------------- IMPLICIT NONE #define __FLULININC__ #include "corsika.h" C ICTABL CONVERTS CORSIKA PARTICLES INTO FLUKA PARTICLES C FIRST TABLE ONLY IF CHARMED PARTICLES CAN BE TREATED C DATA ICFTABL/ C * 7, 4, 3, 0, 10, 11, 23, 13, 14, 12, ! 10 C * 15, 16, 8, 1, 2, 19, 0, 17, 21, 22, ! 20 C * 20, 34, 36, 38, 9, 18, 31, 32, 33, 34, ! 30 C * 37, 39, 8*0, C * 10*0, ! 50 C * 10*0, C * 0, 0, 0, 0, 0, 5, 6, 27, 28, 0, ! 70 C * 10*0, C * 10*0, C * 10*0, !100 C * 10*0, C * 0, 0, 0, 0, 0, 47, 45, 46, 48, 49, !120 C * 50, 0, 0, 0, 0, 0, 0, 0, 0, 0, !130 C * 41, 42, 43, 44, 0, 0, 51, 52, 53, 0, !140 C * 0, 0, 54, 55, 56, 0, 0, 0, 57, 58, !150 C * 59, 0, 0, 0, 60, 61, 62, 0, 0, 0, !160 C * 40*0/ C MODIFIED TABLE AS CHARMED PARTICLES CANNOT BE TREATED BY FLUKA C REPLACE CHARMED QUARK BY STRANGE QUARK 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, 8*0, * 10*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, 16, 25, 24, 15, 0, !120 * 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, !130 * 41, 42, 43, 44, 0, 0, 17, 34, 36, 21, !140 * 22, 20, 34, 36, 38, 0, 0, 0, 18, 35, !150 * 37, 31, 32, 33, 35, 37, 39, 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, 0, 0, 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/ END *-- Author : D. HECK IK FZK KARLSRUHE 22/10/2002 C======================================================================= SUBROUTINE FLUINI C----------------------------------------------------------------------- C FLU(KA) INI(TIALIZATION) C C INITIALIZES FLUKA 2011.2 C THIS SUBROUTINE IS CALLED FROM START. C----------------------------------------------------------------------- #if __LINUX__ INCLUDE '(DBLPRC)' INCLUDE '(DIMPAR)' INCLUDE '(IOUNIT)' INCLUDE '(FLKCMP)' INCLUDE '(FHEAVY)' INCLUDE '(GENSTK)' INCLUDE '(FLKMAT)' INCLUDE '(NUCDAT)' INCLUDE '(NUCGEO)' INCLUDE '(PAPROP)' INCLUDE '(PAREVT)' INCLUDE '(PART2)' INCLUDE '(PHNCCM)' INCLUDE '(RESNUC)' INCLUDE '(CTITLE)' #else INCLUDE 'DBLPRC' INCLUDE 'DIMPAR' INCLUDE 'IOUNIT' INCLUDE 'FLKCMP' INCLUDE 'FHEAVY' INCLUDE 'GENSTK' INCLUDE 'FLKMAT' INCLUDE 'NUCDAT' INCLUDE 'NUCGEO' INCLUDE 'PAPROP' INCLUDE 'PAREVT' INCLUDE 'PART2' INCLUDE 'PHNCCM' INCLUDE 'RESNUC' INCLUDE 'CTITLE' #endif C FLUKA 2011.2 BLOCK DATA PROGRAMS EXTERNAL BDINPT,BDTRNS,BDHDR1,BDHDR2,BDHDR3,BDPART,BDPRDC, & BDNOPT,BDEVAP,BDPREE #define __AIRINC__ #define __RUNPARINC__ #include "corsika.h" DIMENSION WHAT (6) CHARACTER SDUM*10 #if !__GFORTRAN__ SAVE #endif DATA WHAT / 6 * ZERZER / C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'FLUINI:' 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 DECAY WHEN ORIGINATING LCHDCY = .TRUE. C SET UP VARIABLES IN COMMON FLKMAT: NREGS = 4 C FLUKA MATERIAL NUMBER 3 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 4 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 5 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 6 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 C INITIALIZATION OF RM48 IS DONE IN START IF ( DEBUG ) WRITE(MDEBUG,*)'FLUINI: INITIALIZATION DONE' RETURN END *-- Author : D. HECK IK FZK KARLSRUHE 22/10/2002 C======================================================================= SUBROUTINE FLULNK C----------------------------------------------------------------------- C FLU(KA) L(I)NK ROUTINE C C LINKING SUBROUTINE TO FLUKA 2011.2 C THIS SUBROUTINE IS CALLED FROM SDPM. C----------------------------------------------------------------------- #if __LINUX__ INCLUDE '(DBLPRC)' INCLUDE '(DIMPAR)' INCLUDE '(IOUNIT)' INCLUDE '(FLKCMP)' INCLUDE '(FHEAVY)' INCLUDE '(GENSTK)' INCLUDE '(FLKMAT)' INCLUDE '(NUCDAT)' INCLUDE '(NUCGEO)' INCLUDE '(PAPROP)' INCLUDE '(PAREVT)' INCLUDE '(PART2)' INCLUDE '(PHNCCM)' INCLUDE '(RESNUC)' #else INCLUDE 'DBLPRC' INCLUDE 'DIMPAR' INCLUDE 'IOUNIT' INCLUDE 'FLKCMP' INCLUDE 'FHEAVY' INCLUDE 'GENSTK' INCLUDE 'FLKMAT' INCLUDE 'NUCDAT' INCLUDE 'NUCGEO' INCLUDE 'PAPROP' INCLUDE 'PAREVT' INCLUDE 'PART2' INCLUDE 'PHNCCM' INCLUDE 'RESNUC' #endif #define __FLULININC__ #define __INTERINC__ #define __PAMINC__ #define __PARPARINC__ #define __PARPAEINC__ #define __RANDPAINC__ #define __RESTINC__ #define __RUNPARINC__ #define __SIGMINC__ #include "corsika.h" C ADD "CABINX(ICOMAX)" AS LOCAL VARIABLE SINCE IT''S REMOVED FROM C FLUKA COMMON DOUBLE PRECISION ETOTAL,CABINX(ICOMAX) INTEGER IRAND(3),L #if !__GFORTRAN__ SAVE #endif C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'FLULNK: ' C CONVERT PARTICLE TYPE TO FLUKA KPROJ = ICFTABL(ITYPE) IF ( KPROJ .EQ. 0 ) THEN WRITE(MONIOU,*) 'FLULNK: ILLEGAL PARTICLE TYPE (CORSIKA):', * ITYPE RETURN ENDIF C CALCULATE KINETIC ENERGY EKIN IF ( PAMA(ITYPE) .NE. 0.D0 ) THEN ETOTAL = CURPAR(1) * PAMA(ITYPE) ELSE ETOTAL = CURPAR(1) ENDIF ELAB = ETOTAL EKIN = ETOTAL - PAMA(ITYPE) C CALCULATE MOMENTUM PPROJ PPROJ = SQRT( EKIN * (EKIN + 2.D00 * AAM(IPTOKP(KPROJ)) ) ) IF ( DEBUG ) THEN WRITE(MDEBUG,*) 'FLULNK: KPROJ,EKIN=',KPROJ,EKIN C RANDOM GENERATOR STATUS (SEQUENCE L=1) AT BEGINNING OF EVENT CALL RMMAQD( ISEED(1,1),1,'R' ) IRAND(1) = ISEED(1,1) C NUMBER OF CALLS IRAND(2) = ISEED(2,1) C NUMBER OF BILLIONS IRAND(3) = ISEED(3,1) WRITE(MDEBUG,158) (IRAND(J),J=1,3) 158 FORMAT(' FLULNK: RANDOM NUMBER GENERATOR AT BEGIN:' * ,' SEQUENCE= 1 SEED= ',I9,' CALLS=',I9, * ' BILLIONS=',I9) ENDIF LEVFIN = .FALSE. C USE FLUKA MATERIAL NUMBER 6 (= AIR) MMAT = 6 IF ( DEBUG ) WRITE(MDEBUG,*) 'FLULNK: ICOMP(MMAT)=', * ICOMP(6),' ICOMPL(MMAT)=',ICOMPL(6) AINTLN = ZERZER C NOW LOOP ON THE CONSTITUENTS OF AIR DO I = ICOMP(MMAT), ICOMP(MMAT)+ICOMPL(MMAT)-1 MMMAT = MATNUM(I) CALL SIGINM( KPROJ,MMMAT,EKIN,PPROJ,SIMB,SIGMCI ) CABINX(I) = CONTNT(I) * SIGMCI / RHO(MMMAT) CABINX(I) = CABINX(I) + AINTLN AINTLN = CABINX(I) ENDDO AINTNR = AINTLN C NOW DECIDE BY RANDOM WHICH OF CONSTITUENTS IS TARGET RCONT = AINTNR * FLRNDM( ) IF ( DEBUG ) WRITE(MDEBUG,*) 'FLULNK: FRACTIONAL CROSS-SECTIONS ', * 'N:',SNGL(CABINX(1)),' N+O:',SNGL(CABINX(2)), * ' N+O+A:',SNGL(CABINX(3)),' RCONT=',SNGL(RCONT) DO L = ICOMP(MMAT), ICOMP(MMAT)+ICOMPL(MMAT)-1 IF ( RCONT .LE. CABINX(L) ) GO TO 100 ENDDO L = L - 1 100 CONTINUE MMMAT = MATNUM(L) IF ( DEBUG ) WRITE(MDEBUG,*) 'FLULNK: MATERIAL L=',L, * ' MMMAT=',MMMAT,' ',MATNAM(MMMAT) IF ( L .EQ. 1 ) THEN TAR = 14.D0 ELSEIF ( L .EQ. 2 ) THEN TAR = 16.D0 ELSEIF ( L .EQ. 3 ) THEN TAR = 40.D0 ENDIF C USE THE FLUKA-INTERNALLY USED DIRECTION COSINES: TXX = CURPAR(3) TYY = CURPAR(4) TZZ = CURPAR(2) WEE = ONEONE IJ = KPROJ C CALCULATE THE MOMENTUM WITH FLUKA MASSES POO = PPROJ C NOW INTERACTION IS PERFORMED CALL EVENTV( IJ,POO,EKIN,TXX,TYY,TZZ,WEE,MMMAT ) IF ( DEBUG ) WRITE(MDEBUG,*) 'FLULNK: NOW STORE PARTICLES' C STORE THE RESULTING PARTICLES CALL FLUSTR RETURN END *-- Author : D. HECK IK FZK KARLSRUHE 22/10/2002 C======================================================================= SUBROUTINE FLUSIG( EKIN0,PLAB ) C----------------------------------------------------------------------- C FLU(KA) SIG(MA) C C DETERMINES THE INTERACTION CROSS SECTION USED BY FLUKA 2011.2 C THIS SUBROUTINE IS CALLED FROM BOX2. C ARGUMENTS: C EKIN0 = KINETIC ENERGY OF PARTICLE (GEV) C PLAB = MOMENTUM OF PARTICLE (GEV) C----------------------------------------------------------------------- #if __LINUX__ INCLUDE '(DBLPRC)' INCLUDE '(DIMPAR)' INCLUDE '(IOUNIT)' INCLUDE '(FLKCMP)' INCLUDE '(FHEAVY)' INCLUDE '(GENSTK)' INCLUDE '(FLKMAT)' INCLUDE '(NUCDAT)' INCLUDE '(NUCGEO)' INCLUDE '(PAPROP)' INCLUDE '(PAREVT)' INCLUDE '(PART2)' INCLUDE '(PHNCCM)' INCLUDE '(RESNUC)' #else INCLUDE 'DBLPRC' INCLUDE 'DIMPAR' INCLUDE 'IOUNIT' INCLUDE 'FLKCMP' INCLUDE 'FHEAVY' INCLUDE 'GENSTK' INCLUDE 'FLKMAT' INCLUDE 'NUCDAT' INCLUDE 'NUCGEO' INCLUDE 'PAPROP' INCLUDE 'PAREVT' INCLUDE 'PART2' INCLUDE 'PHNCCM' INCLUDE 'RESNUC' #endif #define __AIRINC__ #define __FLULININC__ #define __PAMINC__ #define __PARPARINC__ #define __RUNPARINC__ #define __SIGMINC__ #include "corsika.h" DOUBLE PRECISION EKIN0,EKIN,PLAB INTEGER MMAT #if !__GFORTRAN__ SAVE #endif C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'FLUSIG: EKIN=',EKIN0 EKIN = EKIN0 C CONVERT PARTICLE TYPE TO FLUKA KPROJ = ICFTABL(ITYPE) IF ( KPROJ .EQ. 0 ) THEN WRITE(MONIOU,*) 'FLUSIG: ILLEGAL PARTICLE TYPE (CORSIKA):', * ITYPE SIGAIR = 0.D0 RETURN ENDIF * PPROJ = SQRT( EKIN * (EKIN + PAMA(ITYPE)*2.D0) ) PPROJ = PLAB C MATERIAL NUMBER 6 IS AIR 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,EKIN,PPROJ,SIGREA,ZLDUM ) SIGMA = 0.D0 SIGAIR = SIGREA IF ( DEBUG ) WRITE(MDEBUG,*) 'FLUSIG: SIGAIR=',SIGAIR RETURN END *-- Author : D. HECK IK FZK KARLSRUHE 22/10/2002 C======================================================================= SUBROUTINE FLUSTR C----------------------------------------------------------------------- C FLU(KA) ST(O)R(E) C C STORES THE SECONDARY PARTICLES OF FLUKA INTO CORSIKA. C FOR FLUKA 2011.2 C THIS SUBROUTINE IS CALLED FROM FLULNK. C----------------------------------------------------------------------- #if __LINUX__ INCLUDE '(DBLPRC)' INCLUDE '(DIMPAR)' INCLUDE '(IOUNIT)' INCLUDE '(FLKCMP)' INCLUDE '(FHEAVY)' INCLUDE '(GENSTK)' INCLUDE '(FLKMAT)' INCLUDE '(NUCDAT)' INCLUDE '(NUCGEO)' INCLUDE '(PAPROP)' INCLUDE '(PAREVT)' INCLUDE '(PART2)' INCLUDE '(PHNCCM)' INCLUDE '(RESNUC)' #else INCLUDE 'DBLPRC' INCLUDE 'DIMPAR' INCLUDE 'IOUNIT' INCLUDE 'FLKCMP' INCLUDE 'FHEAVY' INCLUDE 'GENSTK' INCLUDE 'FLKMAT' INCLUDE 'NUCDAT' INCLUDE 'NUCGEO' INCLUDE 'PAPROP' INCLUDE 'PAREVT' INCLUDE 'PART2' INCLUDE 'PHNCCM' INCLUDE 'RESNUC' #endif #define __ELADPMINC__ #define __ELASTYINC__ #define __FLULININC__ #define __INTERINC__ #define __ISTAINC__ #define __LONGIINC__ #define __MULTINC__ #define __PAMINC__ #define __PARPARINC__ #define __PARPAEINC__ #define __RANDPAINC__ #define __RESTINC__ #define __RUNPARINC__ #define __SIGMINC__ #if __AUGERHIST__ || __EHISTORY__ #define __GENERINC__ #endif #if __AUGERHIST__ || __COASTUSERLIB__ #define __OBSPARINC__ #endif #include "corsika.h" DOUBLE PRECISION ELASTI,EMAX,ENP,ETOT,FAC1,FAC2,PTOTRES INTEGER I,J,KODCRS,LL #if __EHISTORY__ INTEGER IK #endif #if __AUGERHIST__ DOUBLE PRECISION EDEP,THICKLOC,THICK INTEGER II EXTERNAL THICK #endif #if __COASTUSERLIB__ c definition of the COAST crs::CInteraction class COMMON/coastInteraction/coastX, coastY, coastZ, & coastE, coastCX, coastEl, coastProjId, coastTargId, & coastT double precision coastX, coastY, coastZ double precision coastE, coastCX, coastEl double precision coastT integer coastProjId, coastTargId #endif #if !__GFORTRAN__ SAVE #endif C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'FLUSTR: ELAB=',ELAB IF ( DEBUG ) THEN WRITE(MDEBUG,*) 'FLUSTR:',NP,' HADRONIC SECONDARIES' WRITE(MDEBUG,*) 'NO TYPE EKIN CX CY CZ' DO I = 1, NP WRITE(MDEBUG,1010) I,KPART(I),TKI(I),CXR(I),CYR(I),CZR(I) 1010 FORMAT(I4,I4,(1P,E10.2),0P,3(1X,F8.5)) ENDDO ENDIF EMAX = 0.D0 ELASTI = 1.D0 ETOT = 0.D0 #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME GRANDMOTHER PARTICLE DO IK = 0, 6 SECPAR(28+IK) = CURPAR(IK) ENDDO C STORE GENERATION COUNTER OF MOTHER SECPAR(35) = GEN C STORE MASS PENETRATION BEFORE INTERACTION SECPAR(36) = CURPAR(9) #if __THIN__ SECPAR(37) = CURPAR(13) #endif #endif C LOOP OVER ALL PARTICLES IN COMMON /GENSTK/ DO 1001 J = 1, NP C TAKE K0SHORT OR K0LONG AT RANDOM INSTEAD OF K0 OR K0_BAR IF ( KPART(J) .EQ. 24 .OR. KPART(J) .EQ. 25 ) THEN CALL RMMARD( RD,1,1 ) IF ( RD(1) .GE. 0.5D0 ) THEN KPART(J) = 19 ELSE KPART(J) = 12 ENDIF ENDIF C CONVERT FLUKA PARTICLE CODE INTO CORSIKA PARTICLE CODE KODCRS = IFCTABL(KPART(J)) C CHECK PARTICLE CODE IF ( KODCRS .EQ. 0 ) THEN WRITE(MONIOU,*) 'FLUSTR: UNKNOWN PARTICLE NR.',J, * ' WITH FLUKA CODE =', KPART(J) GOTO 1001 ENDIF #if !__NEUTRINO__ C SKIP NEUTRINOS IF ( ( KODCRS .GE. 66 .AND. KODCRS .LE. 69 ) #if __CHARM__ || __TAULEP__ * .OR. KODCRS .EQ. 133 .OR. KODCRS .EQ. 134 #endif * ) THEN IF ( LLONGI ) THEN C FILL NEUTRINO ENERGY INTO LONGITUDINAL ENERGY DEPOSIT #if __THIN__ DLONG(LHEIGH,8) = DLONG(LHEIGH,8) + TKI(J) * WEIGHT #else DLONG(LHEIGH,8) = DLONG(LHEIGH,8) + TKI(J) #endif ENDIF GOTO 1001 ENDIF #endif C CALCULATE GAMMA FACTOR RSP. ENERGY IF ( PAMA(KODCRS) .NE. 0.D0 ) THEN ENP = TKI(J) + PAMA(KODCRS) SECPAR(1) = ENP / PAMA(KODCRS) ELSE ENP = TKI(J) SECPAR(1) = TKI(J) ENDIF ETOT = ETOT + ENP IF ( KODCRS .GT. 1 .AND. KODCRS .LE. 65 ) THEN IF ( ENP .GT. EMAX ) THEN EMAX = ENP C CALCULATE ELASTICITY FROM MOST ENERGETIC PARTICLE (LEADER) ELASTI = EMAX / ELAB ENDIF ENDIF C COUNTER FOR ENERGY-MULTIPLICITY MATRIX MSMM = MSMM + 1 SECPAR(0) = KODCRS C CALCULATE EMISSION ANGLES SECPAR(2) = CZR(J) SECPAR(3) = CXR(J) SECPAR(4) = CYR(J) #if __UPWARD__ IF ( SECPAR(2) .GE. -1.D0 ) THEN #else IF ( SECPAR(2) .GT. C(29) ) THEN #endif #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER PARTICLE DO IK = 0, 8 SECPAR(17+IK) = SECPAR(IK) ENDDO #if __THIN__ SECPAR(26) = SECPAR(13) #endif #endif CALL TSTACK ELSE IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT IF ( KODCRS .EQ. 1 ) THEN #if __THIN__ DLONG(LHEIGH,11) = DLONG(LHEIGH,11) + SECPAR(1)*WEIGHT ELSEIF ( KODCRS .EQ. 2 ) THEN DLONG(LHEIGH,13) = DLONG(LHEIGH,13) * + (SECPAR(1)+1.D0)*PAMA(2)*WEIGHT ELSEIF ( KODCRS .EQ. 3 ) THEN DLONG(LHEIGH,13) = DLONG(LHEIGH,13) * + (SECPAR(1)-1.D0)*PAMA(2)*WEIGHT ELSEIF ( KODCRS .EQ. 5 .OR. KODCRS .EQ. 6 ) THEN DLONG(LHEIGH,15) = DLONG(LHEIGH,15) * + SECPAR(1)*PAMA(5)*WEIGHT ELSE IF ( KODCRS .EQ. 8 .OR. KODCRS .EQ. 9 .OR. * KODCRS .EQ. 11 .OR. KODCRS .EQ. 12 ) THEN FAC1 = 0.25D0 FAC2 = 0.75D0 ELSEIF ( KODCRS .EQ. 10 .OR. KODCRS .EQ. 16 ) THEN FAC1 = 0.5D0 FAC2 = 0.5D0 ELSE FAC1 = 1.D0 FAC2 = 0.D0 ENDIF C ADD TO THE HADRON ENERGY DEPOSIT DLONG(LHEIGH,17) = DLONG(LHEIGH,17) * + ( SECPAR(1)*PAMA(KODCRS)-RESTMS(KODCRS) )*WEIGHT*FAC1 C ADD TO THE NEUTRINO DEPOSIT DLONG(LHEIGH,18) = DLONG(LHEIGH,18) * + ( SECPAR(1)*PAMA(KODCRS)-RESTMS(KODCRS) )*WEIGHT*FAC2 #else DLONG(LHEIGH,11) = DLONG(LHEIGH,11) + SECPAR(1) ELSEIF ( KODCRS .EQ. 2 ) THEN DLONG(LHEIGH,13) = DLONG(LHEIGH,13) * + (SECPAR(1)+1.D0)*PAMA(2) ELSEIF ( KODCRS .EQ. 3 ) THEN DLONG(LHEIGH,13) = DLONG(LHEIGH,13) * + (SECPAR(1)-1.D0)*PAMA(2) ELSEIF ( KODCRS .EQ. 5 .OR. KODCRS .EQ. 6 ) THEN DLONG(LHEIGH,15) = DLONG(LHEIGH,15) * + SECPAR(1) * PAMA(5) ELSE IF ( KODCRS .EQ. 8 .OR. KODCRS .EQ. 9 .OR. * KODCRS .EQ. 11 .OR. KODCRS .EQ. 12 ) THEN FAC1 = 0.25D0 FAC2 = 0.75D0 ELSEIF ( KODCRS .EQ. 10 .OR. KODCRS .EQ. 16 ) THEN FAC1 = 0.5D0 FAC2 = 0.5D0 ELSE FAC1 = 1.D0 FAC2 = 0.D0 ENDIF C ADD TO THE HADRON ENERGY DEPOSIT DLONG(LHEIGH,17) = DLONG(LHEIGH,17) * + ( SECPAR(1)*PAMA(KODCRS)-RESTMS(KODCRS) )*FAC1 C ADD TO THE NEUTRINO DEPOSIT DLONG(LHEIGH,18) = DLONG(LHEIGH,18) * + ( SECPAR(1)*PAMA(KODCRS)-RESTMS(KODCRS) )*FAC2 #endif ENDIF ENDIF #if __AUGERHIST__ THICKLOC = THICK( H ) DO LL = 1, NOBSLV IF ( THICKLOC .GE. THCKOB(LL) .AND. * THICKLOC .LT. THCKOB(LL)+SAMPTH ) THEN C THICKH IS WITHIN 1 G/CM^2 BELOW OBSLEV(LL) C BRING THE ENERGY BELOW ANGULAR CUT TO THE HISTO OF LEVEL LL DO II = 0, 8 OUTPAR(II) = SECPAR(II) ENDDO OUTPAR( 9) = GEN OUTPAR(10) = ALEVEL OUTPAR(13) = WEIGHT IF ( KODCRS .EQ. 1 ) THEN EDEP = OUTPAR(1) * WEIGHT ELSE EDEP = ( OUTPAR(1) * PAMA(KODCRS) * - RESTMS(KODCRS) ) * WEIGHT ENDIF IF ( KODCRS .EQ. 2. .OR. KODCRS .EQ. 3 ) * OUTPAR(1) = OUTPAR(1) * PAMA(2) C WE HAVE ANGULAR CUT CALL AUGERDEPFIL( EDEP,LL,1 ) ELSEIF ( THICKLOC .LT. THCKOB(LL) ) THEN GOTO 113 ENDIF ENDDO 113 CONTINUE #endif ENDIF C COUNTERS FOR FIRST INTERACTION IF ( FIRSTI ) THEN IF ( SECPAR(0).EQ. 7.D0 .OR. SECPAR(0).EQ. 8.D0 * .OR. SECPAR(0).EQ. 9.D0 ) THEN IFINPI = IFINPI + 1 ELSEIF ( SECPAR(0).EQ.13.D0 .OR. SECPAR(0).EQ.14.D0 * .OR. SECPAR(0).EQ.15.D0 .OR. SECPAR(0).EQ.25.D0 ) THEN IFINNU = IFINNU + 1 ELSEIF ( SECPAR(0).EQ.10.D0 .OR. SECPAR(0).EQ.11.D0 * .OR. SECPAR(0).EQ.12.D0 .OR. SECPAR(0).EQ.16.D0 ) THEN IFINKA = IFINKA + 1 ELSEIF ( SECPAR(0).EQ.17.D0 ) THEN IFINET = IFINET + 1 ELSEIF ((SECPAR(0).GE.18.D0 .AND. SECPAR(0).LE.24.D0) * .OR. (SECPAR(0).GE.26.D0 .AND. SECPAR(0).LE.32.D0)) THEN IFINHY = IFINHY + 1 ELSEIF ( SECPAR(0).GE.51.D0 .AND. SECPAR(0).LE.53.D0 ) THEN IFINRHO = IFINRHO + 1 ELSE IFINOT = IFINOT + 1 ENDIF ENDIF 1001 CONTINUE C END OF ORDINARY PARTICLE LOOP C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C NOW TREAT THE FRAGMENTS OF TARGET C CALCULATE INTERACTING TARGET NUCLEONS (INCLUDING EVAPORATION) IWOUNT = 0 IF ( DEBUG ) WRITE(MDEBUG,*) 'FLUSTR: ',NPHEAV,' HEAVY PARTICLES' IF ( NPHEAV .GT. 0 ) THEN IF ( DEBUG ) THEN WRITE(MDEBUG,*) * ' J KHY IBH ICH TKHEAV CX CY CZ' DO J = 1, NPHEAV WRITE(MDEBUG,1020) J,KHEAVY(J),IBHEAV(J),ICHEAV(J), * TKHEAV(J),CXHEAV(J),CYHEAV(J),CZHEAV(J) 1020 FORMAT(1H ,I2,3I4,1P,4(E12.5,1X),0P) ENDDO ENDIF DO J = 1, NPHEAV IF ( KHEAVY(J) .EQ. 1 ) THEN C NEUTRON KODCRS = 13 IWOUNT = IWOUNT + 1 ELSEIF ( KHEAVY(J) .EQ. 2 ) THEN C PROTON KODCRS = 14 IWOUNT = IWOUNT + 1 ELSEIF ( KHEAVY(J) .EQ. 3 ) THEN C DEUTERON KODCRS = 201 IWOUNT = IWOUNT + 2 ELSEIF ( KHEAVY(J) .EQ. 4 ) THEN C TRITON KODCRS = 301 IWOUNT = IWOUNT + 3 ELSEIF ( KHEAVY(J) .EQ. 5 ) THEN C 3-HELIUM KODCRS = 302 IWOUNT = IWOUNT + 3 ELSEIF ( KHEAVY(J) .EQ. 6 ) THEN C 4-HELIUM KODCRS = 402 IWOUNT = IWOUNT + 4 ELSEIF ( KHEAVY(J) .GE. 7 .AND. KHEAVY(J) .LE. 12 ) THEN C SPECIFY HEAVY FRAGMENT BY NUCLEON AND CHARGE NUMBER KODCRS = IBHEAV(KHEAVY(J))*100 + ICHEAV(KHEAVY(J)) C REPLACE SINGLE NUCLEONS BY THE ORDINARY HADRONIC CODE IF ( KODCRS .EQ. 100 ) THEN KODCRS = 13 ELSEIF ( KODCRS .EQ. 101 ) THEN KODCRS = 14 C SKIP ILLEGAL FRAGMENT ELSEIF ( KODCRS .EQ. 0 ) THEN WRITE(MONIOU,*) * 'FLUSTR: WRONG FRAGMENT: KHEAVY,IBHEAV,ICHEAV=', * KHEAVY(J),IBHEAV(KHEAVY(J)),ICHEAV(KHEAVY(J)) GOTO 1030 ENDIF IWOUNT = IWOUNT + IBHEAV(KHEAVY(J)) ELSE WRITE(MONIOU,*) 'FLUSTR: WRONG FRAGMENT = ',KHEAVY(J) GOTO 1030 ENDIF ENP = TKHEAV(J) + PAMA(KODCRS) SECPAR(0) = KODCRS SECPAR(1) = ENP / PAMA(KODCRS) ETOT = ETOT + TKHEAV(J) IF ( KODCRS .GT. 1 .AND. KODCRS .LE. 65 ) THEN IF ( ENP .GT. EMAX ) THEN EMAX = ENP C CALCULATE ELASTICITY FROM MOST ENERGETIC PARTICLE (LEADER) ELASTI = EMAX / ELAB ENDIF ENDIF C CALCULATE EMISSION ANGLES SECPAR(2) = CZHEAV(J) SECPAR(3) = CXHEAV(J) SECPAR(4) = CYHEAV(J) #if __UPWARD__ IF ( SECPAR(2) .GE. -1.D0 ) THEN #else IF ( SECPAR(2) .GT. C(29) ) THEN #endif #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER PARTICLE DO IK = 0, 8 SECPAR(17+IK) = SECPAR(IK) ENDDO #if __THIN__ SECPAR(26) = SECPAR(13) #endif #endif CALL TSTACK ELSE IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT #if __THIN__ DLONG(LHEIGH,17) = DLONG(LHEIGH,17) * + ( SECPAR(1)*PAMA(KODCRS)-RESTMS(KODCRS) )*WEIGHT #else DLONG(LHEIGH,17) = DLONG(LHEIGH,17) * + SECPAR(1)*PAMA(KODCRS)-RESTMS(KODCRS) #endif ENDIF #if __AUGERHIST__ THICKLOC = THICK( H ) DO LL = 1, NOBSLV IF ( THICKLOC .GE. THCKOB(LL) .AND. * THICKLOC .LT. THCKOB(LL)+SAMPTH ) THEN C THICKH IS WITHIN 1 G/CM^2 BELOW OBSLEV(LL) C BRING THE ENERGY BELOW ANGULAR CUT TO THE HISTO OF LEVEL LL DO II = 0, 8 OUTPAR(II) = SECPAR(II) ENDDO OUTPAR( 9) = GEN OUTPAR(10) = ALEVEL OUTPAR(13) = WEIGHT EDEP = ( OUTPAR(1) * PAMA(KODCRS) * - RESTMS(KODCRS) ) * WEIGHT C WE HAVE ANGULAR CUT CALL AUGERDEPFIL( EDEP,LL,1 ) ELSEIF ( THICKLOC .LT. THCKOB(LL) ) THEN GOTO 111 ENDIF ENDDO 111 CONTINUE #endif ENDIF C COUNTERS FOR FIRST INTERACTION IF ( FIRSTI ) THEN IF ( SECPAR(0).EQ. 7.D0 .OR. SECPAR(0).EQ. 8.D0 * .OR. SECPAR(0).EQ. 9.D0 ) THEN IFINPI = IFINPI + 1 ELSEIF ( SECPAR(0).EQ.13.D0 .OR. SECPAR(0).EQ.14.D0 * .OR. SECPAR(0).EQ.15.D0 .OR. SECPAR(0).EQ.25.D0 ) THEN IFINNU = IFINNU + 1 ELSEIF ( SECPAR(0).EQ.10.D0 .OR. SECPAR(0).EQ.11.D0 * .OR. SECPAR(0).EQ.12.D0 .OR. SECPAR(0).EQ.16.D0 ) THEN IFINKA = IFINKA + 1 ELSEIF ( SECPAR(0).EQ.17.D0 ) THEN IFINET = IFINET + 1 ELSEIF ((SECPAR(0).GE.18.D0 .AND. SECPAR(0).LE.24.D0) * .OR. (SECPAR(0).GE.26.D0 .AND. SECPAR(0).LE.32.D0)) THEN IFINHY = IFINHY + 1 ELSEIF ( SECPAR(0).GE.51.D0 .AND. SECPAR(0).LE.53.D0 ) THEN IFINRHO = IFINRHO + 1 ELSE IFINOT = IFINOT + 1 ENDIF ENDIF 1030 CONTINUE ENDDO C CALCULATE INTERACTING PROJECTILE NUCLEONS (INCLUDING EVAPORATION) IWOUNP = 1 C END OF HEAVY PARTICLE LOOP ENDIF C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C NOW TREAT THE REMAINING TARGET NUCLEUS IF ( DEBUG ) WRITE(MDEBUG,*) 'FLUSTR: REMAINING NUCLEUS' IF ( DEBUG ) WRITE(MDEBUG,*) ' MASS=',IBRES,' CHARGE=',ICRES, * ' ETOT=',EKRES KODCRS = IBRES*100 + ICRES IF ( KODCRS .EQ. 0 ) THEN GOTO 112 C REPLACE SINGLE NUCEONS BY THE ORDINARY HADRONIC CODE ELSEIF ( KODCRS .EQ. 100 ) THEN KODCRS = 13 ELSEIF ( KODCRS .EQ. 101 ) THEN KODCRS = 14 ENDIF ETOT = ETOT + EKRES SECPAR(0) = KODCRS SECPAR(1) = (EKRES+PAMA(KODCRS)) / PAMA(KODCRS) C CALCULATE RECOIL ANGLES PTOTRES = SQRT( PXRES**2 + PYRES**2 + PZRES**2 ) IF ( PTOTRES .EQ. 0.D0 ) GOTO 112 SECPAR(2) = PZRES / PTOTRES #if __UPWARD__ IF ( SECPAR(2) .GE. -1.D0 ) THEN #else IF ( SECPAR(2) .GT. C(29) ) THEN #endif SECPAR(3) = PXRES / PTOTRES SECPAR(4) = PYRES / PTOTRES #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER PARTICLE DO IK = 0, 8 SECPAR(17+IK) = SECPAR(IK) ENDDO #if __THIN__ SECPAR(26) = SECPAR(13) #endif #endif CALL TSTACK ELSE IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT #if __THIN__ DLONG(LHEIGH,17) = DLONG(LHEIGH,17) * + ( SECPAR(1)*PAMA(KODCRS) - RESTMS(KODCRS) )*WEIGHT #else DLONG(LHEIGH,17) = DLONG(LHEIGH,17) * + ( SECPAR(1)*PAMA(KODCRS) - RESTMS(KODCRS) ) #endif ENDIF #if __AUGERHIST__ THICKLOC = THICK( H ) DO LL = 1, NOBSLV IF ( THICKLOC .GE. THCKOB(LL) .AND. * THICKLOC .LT. THCKOB(LL)+SAMPTH ) THEN C THICKH IS WITHIN 1 G/CM^2 BELOW OBSLEV(LL) C BRING THE ENERGY BELOW ANGULAR CUT TO THE HISTO OF LEVEL LL DO II = 2, 8 OUTPAR(II) = CURPAR(II) ENDDO OUTPAR( 0) = KODCRS OUTPAR( 1) = ERES / PAMA(KODCRS) OUTPAR( 9) = GEN OUTPAR(10) = ALEVEL OUTPAR(13) = WEIGHT EDEP = EKRES * WEIGHT C WE HAVE ENERGY CUT CALL AUGERDEPFIL( EDEP,LL,2 ) ELSEIF ( THICKLOC .LT. THCKOB(LL) ) THEN GOTO 110 ENDIF ENDDO 110 CONTINUE #endif ENDIF 112 CONTINUE C FILL ELASTICITY IN MATRICES MEL = MIN ( 1.D0+10.D0* MAX( 0.D0, ELASTI ) , 11.D0 ) MEN = MIN ( 4.D0+ 3.D0*LOG10(MAX( .1D0, EKINL )), 40.D0 ) #if __THIN__ IELDPM(MEN,MEL) = IELDPM(MEN,MEL) + NINT( WEIGHT ) IELDPA(MEN,MEL) = IELDPA(MEN,MEL) + NINT( WEIGHT ) IF ( ELASTI .LT. 1.D0 ) THEN ELMEAN(MEN) = ELMEAN(MEN) + ELASTI * WEIGHT ELMEAA(MEN) = ELMEAA(MEN) + ELASTI * WEIGHT #else IELDPM(MEN,MEL) = IELDPM(MEN,MEL) + 1 IELDPA(MEN,MEL) = IELDPA(MEN,MEL) + 1 IF ( ELASTI .LT. 1.D0 ) THEN ELMEAN(MEN) = ELMEAN(MEN) + ELASTI ELMEAA(MEN) = ELMEAA(MEN) + ELASTI #endif ENDIF #if __COASTUSERLIB__ coastProjId = nint(curpar(0)) coastTargId = nint(tar) coastX = curpar(7) coastY = curpar(8) #if __CURVED__ coastZ = curpar(14) #else coastX = coastX - XOFF(NOBSLV) coastY = coastY - YOFF(NOBSLV) coastZ = curpar(5) #endif coastT = curpar(6) coastE = pama(coastProjId)*curpar(1) coastCX = sigair coastEl = elasti call interaction(coastX) #endif IF ( FIRSTI ) THEN TARG1I = NINT( TAR ) SIG1I = SIGAIR ELAST = ELASTI FIRSTI = .FALSE. C RANDOM GENERATOR STATUS (SEQUENCE L=1) AT END OF EVENT LL = 1 CALL RMMAQD( ISEED(1,LL),LL,'R' ) C SEED ISEED1I(1) = ISEED(1,LL) C NUMBER OF CALLS ISEED1I(2) = ISEED(2,LL) C NUMBER OF BILLIONS ISEED1I(3) = ISEED(3,LL) ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) 'FLUSTR: ETOT=',ETOT RETURN END *-- Author : Alfredo Ferrari, INFN - Milan 24/10/2002 C======================================================================= SUBROUTINE ZEREMF C----------------------------------------------------------------------- C THIS DUMMY SUBROUTINE IS NECESSARY TO OVERRIDE A FLUKA SUBROUTINE C WITH IDENTICAL NAME WHICH OTHERWISE WOULD ERASE SOME CORSIKA COMMONS. C THIS SUBROUTINE IS CALLED FROM ZEROIN. C----------------------------------------------------------------------- #if __LINUX__ INCLUDE '(DBLPRC)' INCLUDE '(DIMPAR)' INCLUDE '(IOUNIT)' #else INCLUDE 'DBLPRC' INCLUDE 'DIMPAR' INCLUDE 'IOUNIT' #endif C----------------------------------------------------------------------- RETURN END #endif #if __GHEISHAD__ *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE CGHEI C----------------------------------------------------------------------- C C(ORSIKA) GHE(ISHA) I(NTERFACE) C C MAIN STEERING SUBROUT. FOR HADRON PACKAGE GHEISHA *** C THIS SUBROUTINE IS CALLED FROM NUCINT. C C ORIGIN : F.CARMINATI, H.FESEFELDT (SUBROUT. GHESIG) C REDESIGN: P. GABRIEL IK1 FZK KARLSRUHE C----------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION(A-H, O-Z) #define __CGCOMPINC__ #define __ELABCTINC__ #define __ELADPMINC__ #define __ELASTYINC__ #define __GENERINC__ #define __ISTAINC__ #define __LONGIINC__ #define __MULTINC__ #define __PAMINC__ #define __PARPARINC__ #define __RANDPAINC__ #define __RUNPARINC__ #define __SIGMINC__ #if __AUGERHIST__ || __COASTUSERLIB__ #define __OBSPARINC__ #endif #include "corsika.h" DOUBLE PRECISION ELASTI,ELABOR,ETOT,PLX,PLY,PLZ,PLSQ,PLTOT,RMASSK COMMON/GSECTI/ AIEL(20),AIIN(20),AIFI(20),AICA(20),ALAM,K0FLAG INTEGER K0FLAG DOUBLE PRECISION AIEL,AIIN,AIFI,AICA,ALAM 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) DOUBLE PRECISION EMAX,EEESQ DIMENSION RNDM(1) 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 --- DIMENSION KIPART(48),IKPART(35) C --- ANGLES FOR NEW COUPLING WITH CORSIKA D. HECK DEC. 2000 DOUBLE PRECISION PHIRAN,PHIG,THETG DOUBLE PRECISION FAC1,FAC2 INTEGER LL #if __AUGERHIST__ C QUANTITIES FOR AUGERHISTOGRAMS DOUBLE PRECISION EDEP,THICKLOC,THICK INTEGER II EXTERNAL THICK #endif #if __COASTUSERLIB__ c definition of the COAST crs::CInteraction class COMMON/coastInteraction/coastX, coastY, coastZ, & coastE, coastCX, coastEl, coastProjId, coastTargId, & coastT double precision coastX, coastY, coastZ double precision coastE, coastCX, coastEl double precision coastT integer coastProjId, coastTargId #endif 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 --- 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/ 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 --- 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----------------------------------------------------------------------- #if __THIN__ IF ( DEBUG ) WRITE(MDEBUG,445) (CURPAR(I),I=0,9),CURPAR(13) 445 FORMAT(' CGHEI : CURPAR=',1P,11E11.3) #else IF ( DEBUG ) WRITE(MDEBUG,445) (CURPAR(I),I=0,9) 445 FORMAT(' CGHEI : CURPAR=',1P,10E11.3) #endif IF ( DEBUG ) WRITE(MDEBUG,*) * 'CGHEI : E = ',CURPAR(1)*PAMA(NINT( CURPAR(0) )) C --- DEFINE PARTICLE TYPE IF ( ITYPE .LT. 48 ) THEN IPART = ITYPE ELSEIF ( ITYPE .EQ. 201 ) THEN IPART = 45 ELSEIF ( ITYPE .EQ. 301 ) THEN IPART = 46 ELSEIF ( ITYPE .EQ. 402 ) THEN IPART = 47 ELSE #if __THIN__ WRITE(MONIOU,445) (CURPAR(I),I=0,9),CURPAR(13) #else WRITE(MONIOU,445) (CURPAR(I),I=0,9) #endif WRITE(MONIOU,7795) ITYPE 7795 FORMAT(/,/,' *CGHEI* ILLEGAL PARTICLE TYPE OCCURS =',I5) IPART = 48 ENDIF NETEST = IKPART(KPART) IF ( NETEST .EQ. IPART ) GOTO 9004 WRITE(MONIOU,8881) IPART,KPART 8881 FORMAT(' *CGHEI* IPART,KPART = ',2(I3,1X),/, $ ' *CGHEI* ======> PARTICLE TYPES DO NOT MATCH <=======') STOP 9004 CONTINUE #if !__INTTEST__ C MIXING OF NEUTRAL KAONS IF ( IPART .EQ. 10 .OR. IPART .EQ. 16 ) THEN CALL GRNDM( RNDM,1 ) IF ( RNDM(1) .LT. 0.5D0 ) THEN IPART = 10 ELSE IPART = 16 ENDIF ENDIF #endif KPART = KIPART(IPART) 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.D0 NEXT = 1 NTOT = 0 IINT = 0 TOF = 0.D0 C --- RESET ITYPE SECPAR(0) = 0.D0 C --- FILL RESULT COMMON FOR THIS TRACK WITH CORSIKA VALUES --- AMAS = RMASS(KPART) NCH = RCHARG(KPART) XEND = CURPAR(7) YEND = CURPAR(8) ZEND = CURPAR(5) USERW = 0.D0 AMASQ=AMAS*AMAS EN = CURPAR(1) * ABS(AMAS) EK = ABS ( EN - ABS(AMAS) ) ENOLD = EN EMAX = 0.D0 ETOT = 0.D0 P = SQRT ( (EN-AMAS)*(EN+AMAS) ) ELABOR = EN C OLD COUPLING OF GHEISHA WITH CORSIKA C SINL = -CURPAR(2) C PHIX = CURPAR(3) C PHIY = CURPAR(4) C C SINP = SIN( PHI ) C COSP = COS( PHI ) C COSL = SQRT ( ABS(1.D0-SINL**2) ) C NEW COUPLING WITH CORSIKA D. HECK DEC. 2000 C WE ASSUME MOVEMENT ALONG Z AXIS. AFTER COLLISION WE ROTATE THE C INTERACTION PLANE AROUND Z AT RANDOM TO ELIMINATE PREFERENCES OF PHI SINL = -1.D0 COSL = 0.D0 SINP = 0.D0 COSP = 1.D0 PX = COSL * COSP PY = COSL * SINP PZ = SINL CALL GRNDM( RNDM,1 ) PHIRAN = RNDM(1) * TWPI 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) = 14.56D0 ZNO(IND+1) = 7.265D0 DEN(IND+1) = 0.D0 RADLTH(IND+1) = 0.D0 ABSLTH(IND+1) = 0.D0 C --- SETUP PARMAT FOR PHYSICS STEERING --- PARMAT(IND+1,10) = 0.D0 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 "IINT" *** C THE CONVENTION FOR "IINT" IS THE FOLLOWING C IINT = -1 REACTION CROSS-SECTIONS NOT YET TABULATED/PROGRAMMED C = 0 NO INTERACTION C = 1 ELEASTIC SCATTERING C = 2 INELASTIC SCATTERING C = 3 NUCLEAR FISSION WITH INELEASTIC SCATTERING C = 4 NEUTRON CAPTURE C IINT = 3, 4 SHOULD BE DELETED FOR AIR TARGET C --- INTACT CODE --- ALAM1 = 0.D0 CALL GRNDM( RNDM,1 ) RAT = RNDM(1)*ALAM C --- DEFAULT VALUES FOR AIR C ATNO2 = 14.56D0 C ZNO2 = 7.265D0 DO K = 1, KK ATNO2 = ACOMP(K) ZNO2 = ZCOMP(K) C --- TRY FOR ELASTIC SCATTERING --- IINT = 1 ALAM1 = ALAM1+AIEL(K) IF (RAT .LT. ALAM1) GOTO 8 C --- TRY FOR INELASTIC SCATTERING --- IINT = 2 ALAM1 = ALAM1+AIIN(K) IF (RAT .LT. ALAM1) GOTO 8 C --- TRY FOR NEUTRON CAPTURE --- IINT = 4 ALAM1 = ALAM1+AICA(K) IF (RAT .LT. ALAM1) GOTO 8 ENDDO C --- NO REACTION SELECTED ==> ELASTIC SCATTERING --- IINT = 1 C *** TAKE ACTION ACCORDING TO SELECTED REACTION CHANNEL *** C --- FOLLOWING CODE IS A TRANSLATION OF "CALIM" INTO GEANT JARGON --- 8 CONTINUE #if __INTTEST__ C WE ARE INTERESTED ONLY IN INELASTIC SCATTERING IINT = 2 #endif IF (NPRT(9)) WRITE(MDEBUG,1001) IINT 1001 FORMAT(' *CGHEI* INTERACTION TYPE CHOSEN IINT = ',I3) #if __EHISTORY__ C CONSIDER ONLY INELASTIC INTERACTIONS IF ( IINT .EQ. 2 ) THEN C COPY PARTICLE INFORMATION, LATER TO BECOME GRANDMOTHER PARTICLE DO IK = 0, 6 SECPAR(28+IK) = CURPAR(IK) ENDDO C STORE GENERATION COUNTER OF MOTHER SECPAR(35) = GEN C STORE MASS PENETRATION BEFORE INTERACTION SECPAR(36) = CURPAR(9) #if __THIN__ SECPAR(37) = CURPAR(13) #endif ENDIF #endif IF (IINT .NE. 4) GOTO 10 C --- NEUTRON CAPTURE --- IF (NPRT(9)) WRITE(MDEBUG,2000) 2000 FORMAT(' *CGHEI* SUBROUT. CAPTUR WILL BE CALLED') CALL CAPTUR( NOPT ) GOTO 40 10 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 (IINT .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 --- IF ( NPRT(9) ) WRITE(MDEBUG,2002) 2002 FORMAT(' *CGHEI* SUBROUT. COSCAT WILL BE CALLED') 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.D0) .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 IF (NPRT(9)) WRITE(MDEBUG,1002) KPART,EK,EN,P,ENP(5),ENP(6),ENP(7) 1002 FORMAT(' *CGHEI* ENERGY BELOW CUT-OFF FOR GHEISHA PARTICLE ',I3,/, $ ' EK,EN,P,ENP(5),ENP(6),ENP(7) = ',6(G12.5,1X)) IF ( (KPART .NE. 14) .AND. (KPART .NE. 16) ) GOTO 14 IF ( KPART .EQ. 16 ) GOTO 86 C --- SLOW PROTON --- 85 CONTINUE IF ( NPRT(9) ) WRITE(MDEBUG,2003) EK,KPART 2003 FORMAT(' *CGHEI* SUBROUT. NUCREC WILL BE CALLED', $ ' EK = ',G12.5,' GEV KPART = ',I3) CALL NUCREC( NOPT,2 ) IF ( NOPT .NE. 0 ) GOTO 50 IF ( NPRT(9) ) WRITE(MDEBUG,2004)EK,KPART 2004 FORMAT(' *CGHEI* SUBROUT. COSCAT WILL BE CALLED', $ ' EK = ',G12.5,' GEV KPART = ',I3) CALL COSCAT GOTO 40 C --- SLOW NEUTRON --- 86 CONTINUE IF ( NPRT(9) ) WRITE(MDEBUG,2015) NUCFLG = 0 CALL GNSLWD( NUCFLG,IINT,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.D0 NFL = 1 IF ( IPA(2) .EQ. 16 ) NFL = 2 IPPP = KPART IF ( NPRT(9) ) WRITE(MDEBUG,2005) 2005 FORMAT(' *CGHEI* SUBROUT. TWOB WILL BE CALLED') 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 IF ( NPRT(9) ) WRITE(MDEBUG,2006) 2006 FORMAT(' *CGHEI* SUBROUT. CASPIP WILL BE CALLED') CALL CASPIP( J,IINT,NFL ) GOTO 40 C --- PI0 ==> NO CASCADE --- 308 CONTINUE GOTO 40 C --- PI- CASCADE --- 309 CONTINUE IF ( NPRT(9) ) WRITE(MDEBUG,2007) 2007 FORMAT(' *CGHEI* SUBROUT. CASPIM WILL BE CALLED') CALL CASPIM( J,IINT,NFL ) GOTO 40 C --- K+ CASCADE --- 310 CONTINUE IF ( NPRT(9) ) WRITE(MDEBUG,2008) 2008 FORMAT(' *CGHEI* SUBROUT. CASKP WILL BE CALLED') CALL CASKP( J,IINT,NFL ) GOTO 40 C --- K0 CASCADE --- 311 CONTINUE IF ( NPRT(9) ) WRITE(MDEBUG,2009) 2009 FORMAT(' *CGHEI* SUBROUT. CASK0 WILL BE CALLED') CALL CASK0( J,IINT,NFL ) GOTO 40 C --- K0 BAR CASCADE --- 312 CONTINUE IF ( NPRT(9) ) WRITE(MDEBUG,2010) 2010 FORMAT(' *CGHEI* SUBROUT. CASK0B WILL BE CALLED') CALL CASK0B( J,IINT,NFL ) GOTO 40 C --- K- CASCADE --- 313 CONTINUE IF ( NPRT(9) ) WRITE(MDEBUG,2011) 2011 FORMAT(' *CGHEI* SUBROUT. CASKM WILL BE CALLED') CALL CASKM( J,IINT,NFL ) GOTO 40 C --- PROTON CASCADE --- 314 CONTINUE IF ( NPRT(9) ) WRITE(MDEBUG,2012) 2012 FORMAT(' *CGHEI* SUBROUT. CASP WILL BE CALLED') CALL CASP( J,IINT,NFL ) GOTO 40 C --- PROTON BAR CASCADE --- 315 CONTINUE IF ( NPRT(9) ) WRITE(MDEBUG,2013) 2013 FORMAT(' *CGHEI* SUBROUT. CASPB WILL BE CALLED') CALL CASPB( J,IINT,NFL ) GOTO 40 C --- NEUTRON CASCADE --- 316 CONTINUE NUCFLG = 0 IF ( EK .GT. SWTEKN ) THEN CALL CASN( J,IINT,NFL ) IF ( NPRT(9) ) WRITE(MDEBUG,2014) 2014 FORMAT(' *CGHEI* SUBROUT. CASN WILL BE CALLED') ELSE CALL GNSLWD( NUCFLG,IINT,NFL,TEKLOW ) IF ( NPRT(9) ) WRITE(MDEBUG,2015) 2015 FORMAT(' *CGHEI* SUBROUT. GNSLWD WILL BE CALLED') ENDIF IF ( NUCFLG .NE. 0 ) GOTO 50 GOTO 40 C --- NEUTRON BAR CASCADE --- 317 CONTINUE IF ( NPRT(9) ) WRITE(MDEBUG,2016) 2016 FORMAT(' *CGHEI* SUBROUT. CASNB WILL BE CALLED') CALL CASNB( J,IINT,NFL ) GOTO 40 C --- LAMBDA CASCADE --- 318 CONTINUE IF ( NPRT(9) ) WRITE(MDEBUG,2017) 2017 FORMAT(' *CGHEI* SUBROUT. CASL0 WILL BE CALLED') CALL CASL0( J,IINT,NFL ) GOTO 40 C --- LAMBDA BAR CASCADE --- 319 CONTINUE IF ( NPRT(9) ) WRITE(MDEBUG,2018) 2018 FORMAT(' *CGHEI* SUBROUT. CASAL0 WILL BE CALLED') CALL CASAL0( J,IINT,NFL ) GOTO 40 C --- SIGMA + CASCADE --- 320 CONTINUE IF ( NPRT(9) ) WRITE(MDEBUG,2019) 2019 FORMAT(' *CGHEI* SUBROUT. CASSP WILL BE CALLED') CALL CASSP( J,IINT,NFL ) GOTO 40 C --- SIGMA 0 ==> NO CASCADE --- 321 CONTINUE GOTO 40 C --- SIGMA - CASCADE --- 322 CONTINUE IF ( NPRT(9) ) WRITE(MDEBUG,2020) 2020 FORMAT(' *CGHEI* SUBROUT. CASSM WILL BE CALLED') CALL CASSM( J,IINT,NFL ) GOTO 40 C --- SIGMA + BAR CASCADE --- 323 CONTINUE IF ( NPRT(9) ) WRITE(MDEBUG,2021) 2021 FORMAT(' *CGHEI* SUBROUT. CASASP WILL BE CALLED') CALL CASASP( J,IINT,NFL ) GOTO 40 C --- SIGMA 0 BAR ==> NO CASCADE --- 324 CONTINUE GOTO 40 C --- SIGMA - BAR CASCADE --- 325 CONTINUE IF ( NPRT(9) ) WRITE(MDEBUG,2022) 2022 FORMAT(' *CGHEI* SUBROUT. CASASM WILL BE CALLED') CALL CASASM( J,IINT,NFL ) GOTO 40 C --- XI 0 CASCADE --- 326 CONTINUE IF ( NPRT(9) ) PRINT 2023 2023 FORMAT(' *CGHEI* SUBROUT. CASX0 WILL BE CALLED') CALL CASX0( J,IINT,NFL ) GOTO 40 C --- XI - CASCADE --- 327 CONTINUE IF ( NPRT(9) ) PRINT 2024 2024 FORMAT(' *CGHEI* SUBROUT. CASXM WILL BE CALLED') CALL CASXM( J,IINT,NFL ) GOTO 40 C --- XI 0 BAR CASCADE --- 328 CONTINUE IF ( NPRT(9) ) PRINT 2025 2025 FORMAT(' *CGHEI* SUBROUT. CASAX0 WILL BE CALLED') CALL CASAX0( J,IINT,NFL ) GOTO 40 C --- XI - BAR CASCADE --- 329 CONTINUE IF ( NPRT(9) ) PRINT 2026 2026 FORMAT(' *CGHEI* SUBROUT. CASAXM WILL BE CALLED') CALL CASAXM( J,IINT,NFL ) GOTO 40 C --- OMEGA - CASCADE --- 330 CONTINUE IF ( NPRT(9) ) PRINT 2027 2027 FORMAT(' *CGHEI* SUBROUT. CASOM WILL BE CALLED') CALL CASOM( J,IINT,NFL ) GOTO 40 C --- OMEGA - BAR CASCADE --- 331 CONTINUE IF ( NPRT(9) ) PRINT 2028 2028 FORMAT(' *CGHEI* SUBROUT. CASAOM WILL BE CALLED') CALL CASAOM( J,IINT,NFL ) GOTO 40 C --- HEAVY FRAGMENT CASCADE --- 390 CONTINUE IF ( NPRT(9) ) WRITE(MDEBUG,2090) 2090 FORMAT(' *CGHEI* SUBROUT. CASFRG WILL BE CALLED') NUCFLG = 0 CALL CASFRG( NUCFLG,IINT,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 50 CONTINUE NVEDUM = KIPART(IPART) IF (NPRT(9)) WRITE(MDEBUG,1004)NTOT,IPART,KPART,KKPART,NVEDUM 1004 FORMAT(' *CGHEI* SEC. GEN. NTOT,IPART,KPART,KKPART,KIPART = ', $ 5(I3,1X)) 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 = 11.5D0+RNDM(1) 52 CONTINUE C --- IN CASE THE NEW PARTICLE IS A NEUTRINO ==> FORGET IT --- IF ( KPART .EQ. 2 ) GOTO 60 C --- PUT CURRENT GHEISHA PARTICLE ON THE CORSIKA STACK C --- ( IF SURVIVING ANGLE CUT ! ) NGKINE = 1 C --- CALCULATE ELASTICITY IF ( EN .GT. EMAX ) THEN EMAX = EN ENDIF ITY=IKPART(KPART) IF ( ITY .LT. 45 ) THEN SECPAR(0) = DBLE(ITY) ELSEIF ( ITY .EQ. 45 ) THEN SECPAR(0) = 201.D0 ELSEIF ( ITY .EQ. 46 ) THEN SECPAR(0) = 301.D0 ELSEIF ( ITY .EQ. 47 ) THEN SECPAR(0) = 402.D0 ENDIF ITY = SECPAR(0) IF ( ABS(AMAS) .LT. 1.D-9 ) THEN SECPAR(1) = EN ELSE SECPAR(1) = DBLE(EN) / DBLE(ABS(AMAS)) ENDIF IF ( ITY .EQ. 13 .OR. ITY .EQ. 14 ) THEN ETOT = ETOT + (SECPAR(1) - 1.D0) * PAMA(ITY) ELSEIF ( ITY .EQ. 15 .OR. ITY .EQ. 25 ) THEN ETOT = ETOT + (SECPAR(1) + 1.D0) * PAMA(ITY) ELSE ETOT = ETOT + EN ENDIF C NEW COUPLING WITH CORSIKA D. HECK DEC. 2000 C NOTE: (PX,PY,PZ) IS NORMALIZED TO 1! THETG = -PZ IF ( PX .NE. 0.D0 .OR. PY .NE. 0.D0 ) THEN PHIG = ATAN2( PY, PX ) + PHIRAN ELSE PHIG = 0.D0 + PHIRAN ENDIF #if __INTTEST__ SECPAR(17) = P * SQRT( PX**2 + PY**2 ) #endif CALL ADDANG3( CURPAR(2),CURPAR(3),CURPAR(4), THETG,PHIG, * SECPAR(2),SECPAR(3),SECPAR(4) ) C CHECK WHETHER PARTICLE SURVIVES ANGULAR CUT #if __UPWARD__ IF ( SECPAR(2) .GE. -1.D0 ) THEN #else IF ( SECPAR(2) .GT. C(29) ) THEN #endif #if __EHISTORY__ C CONSIDER ONLY INELASTIC INTERACTIONS IF ( IINT .EQ. 2 ) THEN C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER PARTICLE DO IK = 0, 8 SECPAR(17+IK) = SECPAR(IK) ENDDO #if __THIN__ SECPAR(26) = SECPAR(13) #endif ENDIF #endif CALL TSTACK ELSE IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT IF ( ITY .EQ. 1 ) THEN #if __THIN__ DLONG(LHEIGH,11) = DLONG(LHEIGH,11) + EN * CURPAR(13) ELSEIF ( ITY .EQ. 2 ) THEN DLONG(LHEIGH,13) = DLONG(LHEIGH,13) * +(EN+PAMA(2))*CURPAR(13) ELSEIF ( ITY .EQ. 3 ) THEN DLONG(LHEIGH,13) = DLONG(LHEIGH,13) * +(EN-PAMA(2))*CURPAR(13) ELSEIF ( ITY .EQ. 5 .OR. ITY .EQ. 6 ) THEN DLONG(LHEIGH,15) = DLONG(LHEIGH,15) + EN * CURPAR(13) ELSEIF ( ITY .GE. 7 ) THEN IF ( ITY .EQ. 8 .OR. ITY .EQ. 9 .OR. * ITY .EQ. 11 .OR. ITY .EQ. 12 ) THEN FAC1 = 0.25D0 FAC2 = 0.75D0 ELSEIF ( ITY .EQ. 10 .OR. ITY .EQ. 16 ) THEN FAC1 = 0.5D0 FAC2 = 0.5D0 ELSE FAC1 = 1.D0 FAC2 = 0.D0 ENDIF C ADD TO THE HADRON ENERGY DEPOSIT DLONG(LHEIGH,17) = DLONG(LHEIGH,17) * + ( EN - RESTMS(ITY) )*CURPAR(13)*FAC1 C ADD TO THE NEUTRINO DEPOSIT DLONG(LHEIGH,18) = DLONG(LHEIGH,18) * + ( EN - RESTMS(ITY) )*CURPAR(13)*FAC2 #else DLONG(LHEIGH,11) = DLONG(LHEIGH,11) + EN ELSEIF ( ITY .EQ. 2 ) THEN DLONG(LHEIGH,13) = DLONG(LHEIGH,13) + EN + PAMA(2) ELSEIF ( ITY .EQ. 3 ) THEN DLONG(LHEIGH,13) = DLONG(LHEIGH,13) + EN - PAMA(2) ELSEIF ( ITY .EQ. 5 .OR. ITY .EQ. 6 ) THEN DLONG(LHEIGH,15) = DLONG(LHEIGH,15) + EN ELSEIF ( ITY .GE. 7 ) THEN IF ( ITY .EQ. 8 .OR. ITY .EQ. 9 .OR. * ITY .EQ. 11 .OR. ITY .EQ. 12 ) THEN FAC1 = 0.25D0 FAC2 = 0.75D0 ELSEIF ( ITY .EQ. 10 .OR. ITY .EQ. 16 ) THEN FAC1 = 0.5D0 FAC2 = 0.5D0 ELSE FAC1 = 1.D0 FAC2 = 0.D0 ENDIF C ADD TO THE HADRON ENERGY DEPOSIT DLONG(LHEIGH,17) = DLONG(LHEIGH,17) * + ( EN - RESTMS(ITY) )*FAC1 C ADD TO THE NEUTRINO DEPOSIT DLONG(LHEIGH,18) = DLONG(LHEIGH,18) * + ( EN - RESTMS(ITY) )*FAC2 #endif ENDIF ENDIF #if __AUGERHIST__ THICKLOC = THICK( CURPAR(5) ) DO LL = 1, NOBSLV IF ( THICKLOC .GE. THCKOB(LL) .AND. * THICKLOC .LT. THCKOB(LL)+SAMPTH ) THEN C THICKH IS WITHIN 1 G/CM^2 BELOW OBSLEV(LL) C BRING THE ENERGY BELOW ANGULAR CUT TO THE HISTO OF LEVEL LL DO II = 0, 8 OUTPAR(II) = SECPAR(II) ENDDO IF ( SECPAR(0) .EQ. 1.D0 ) THEN EDEP = OUTPAR(1) * CURPAR(13) ELSEIF ( SECPAR(0) .EQ. 2.D0 .OR. * SECPAR(0) .EQ. 3.D0 ) THEN OUTPAR(1) = OUTPAR(1) * PAMA(2) EDEP = ( OUTPAR(1) - RESTMS(ITY) ) * CURPAR(13) ELSE EDEP = ( OUTPAR(1)*PAMA(ITY) - RESTMS(ITY) ) * CURPAR(13) ENDIF OUTPAR( 9) = GEN OUTPAR(10) = ALEVEL OUTPAR(13) = CURPAR(13) C WE HAVE ANGULAR CUT CALL AUGERDEPFIL( EDEP,LL,1 ) ELSEIF ( THICKLOC .LT. THCKOB(LL) ) THEN GOTO 111 ENDIF ENDDO 111 CONTINUE #endif ENDIF 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 = 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 = 11.5D0+RNDM(1) C --- FORGET ABOUT NEUTRINOS --- 63 CONTINUE IF ( JND .EQ. 2 ) GOTO 61 C --- SWITCH TO CORSIKA QUANTITIES --- ITY = IKPART(JND) IF (NPRT(9)) WRITE(MDEBUG,1006) $ ITY,NGKINE,L,(EVE(INDEX+J),J=1,12) 1006 FORMAT(' *CGHEI* GEANT PART. ',I3,' ALSO PUT ONTO STACK AT', $ ' POS. ',I3,/, $ ' EVE(',I2,') = ',(' ',10G12.5)) PLX = EVE(INDEX+9) PLY = EVE(INDEX+10) PLZ = EVE(INDEX+11) PLSQ = PLX**2 + PLY**2 + PLZ**2 PLTOT = SQRT( PLSQ ) RMASSK = ABS(RMASS(JND)) C FIND HIGHEST ENERGY PARTICLE FOR ELASTICITY EEESQ = PLSQ + RMASSK**2 IF ( EEESQ .GT. EMAX**2 ) THEN EMAX = SQRT( EEESQ ) ENDIF C --- APPLY ANGLE CUT AND C --- ADD PARTICLE TO THE CORSIKA STACK (RESTRICTED TO 100) --- IF ( PLTOT .LE. 1.D-10 ) GOTO 61 IF ( RMASSK .LT. 1.D-9 ) THEN SECPAR(1) = PLTOT ELSE SECPAR(1) = SQRT (PLSQ+RMASSK**2) / RMASSK ENDIF IF ( ITY .LT. 45 ) THEN SECPAR(0) = DBLE(ITY) ELSEIF ( ITY .EQ. 45 ) THEN SECPAR(0) = 201.D0 ELSEIF ( ITY .EQ. 46 ) THEN SECPAR(0) = 301.D0 ELSEIF ( ITY .EQ. 47 ) THEN SECPAR(0) = 402.D0 ELSE SECPAR(0) = 0.D0 WRITE(MONIOU,*) '*CGHEI* ILLEGAL PARTICLE TYPE',ITY ENDIF C --- COUNTERS FOR FIRST INTERACTION ITY = SECPAR(0) IF ( ITY .EQ. 1 ) THEN ETOT = ETOT + SQRT( EEESQ ) ELSEIF ( ITY .EQ. 13 .OR. ITY .EQ. 14 ) THEN ETOT = ETOT + (SECPAR(1) - 1.D0) * PAMA(ITY) ELSEIF ( ITY .EQ. 15 .OR. ITY .EQ. 25 ) THEN ETOT = ETOT + (SECPAR(1) + 1.D0) * PAMA(ITY) ELSE ETOT = ETOT + SECPAR(1) * PAMA(ITY) ENDIF IF ( FIRSTI ) THEN IF ( ITY .EQ. 7 .OR. ITY .EQ. 8 .OR. * ITY .EQ. 9 ) THEN IFINPI = IFINPI + 1 ELSEIF ( ITY .EQ. 13 .OR. ITY .EQ. 14 .OR. * ITY .EQ. 15 .OR. ITY .EQ. 25 ) THEN IFINNU = IFINNU + 1 ELSEIF ( ITY .EQ. 10 .OR. ITY .EQ. 11 .OR. * ITY .EQ. 12 .OR. ITY .EQ. 16 ) THEN IFINKA = IFINKA + 1 ELSEIF ( ITY .EQ. 17 ) THEN IFINET = IFINET + 1 ELSEIF ((ITY .GE. 18 .AND. ITY .LE. 24) * .OR. (ITY .GE. 26 .AND. ITY .LE. 32)) THEN IFINHY = IFINHY + 1 ELSEIF ( ITY .GE. 51 .AND. ITY .LE. 53 ) THEN IFINRHO = IFINRHO + 1 ELSE IFINOT = IFINOT + 1 ENDIF ENDIF C NEW COUPLING WITH CORSIKA D. HECK DEC. 2000 IF ( NGKINE .GE. MXGKGH ) GOTO 9999 NGKINE = NGKINE+1 THETG = (-PLZ) / PLTOT IF ( PLX .NE. 0.D0 .OR. PLY .NE. 0.D0 ) THEN PHIG = ATAN2( PLY, PLX ) + PHIRAN ELSE PHIG = 0.D0 + PHIRAN ENDIF #if __INTTEST__ SECPAR(17) = SQRT( PLX**2 + PLY**2 ) #endif CALL ADDANG3( CURPAR(2),CURPAR(3),CURPAR(4), THETG,PHIG, * SECPAR(2),SECPAR(3),SECPAR(4) ) C CHECK WHETHER PARTICLE SURVIVES ANGULAR CUT #if __UPWARD__ IF ( SECPAR(2) .GE. -1.D0 ) THEN #else IF ( SECPAR(2) .GT. C(29) ) THEN #endif #if __EHISTORY__ C CONSIDER ONLY INELASTIC INTERACTIONS IF ( IINT .EQ. 2 ) THEN C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER PARTICLE DO IK = 0, 8 SECPAR(17+IK) = SECPAR(IK) ENDDO #if __THIN__ SECPAR(26) = SECPAR(13) #endif ENDIF #endif CALL TSTACK ELSE IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT IF ( ITY .EQ. 1 ) THEN #if __THIN__ DLONG(LHEIGH,11) = DLONG(LHEIGH,11)+SECPAR(1)*CURPAR(13) ELSEIF ( ITY .EQ. 2 ) THEN DLONG(LHEIGH,13) = DLONG(LHEIGH,13) * + (SECPAR(1)+1.D0)*PAMA(2)*CURPAR(13) ELSEIF ( ITY .EQ. 3 ) THEN DLONG(LHEIGH,13) = DLONG(LHEIGH,13) * + (SECPAR(1)-1.D0)*PAMA(2)*CURPAR(13) ELSEIF ( ITY .EQ. 5 .OR. ITY .EQ. 6 ) THEN DLONG(LHEIGH,15) = DLONG(LHEIGH,15) * + SECPAR(1)*PAMA(5)*CURPAR(13) ELSEIF ( ITY .GE. 7 ) THEN IF ( ITY .EQ. 8 .OR. ITY .EQ. 9 .OR. * ITY .EQ. 11 .OR. ITY .EQ. 12 ) THEN FAC1 = 0.25D0 FAC2 = 0.75D0 ELSEIF ( ITY .EQ. 10 .OR. ITY .EQ. 16 ) THEN FAC1 = 0.5D0 FAC2 = 0.5D0 ELSE FAC1 = 1.D0 FAC2 = 0.D0 ENDIF C ADD TO THE HADRON ENERGY DEPOSIT DLONG(LHEIGH,17) = DLONG(LHEIGH,17) * + ( SECPAR(1)*PAMA(ITY)-RESTMS(ITY) )*CURPAR(13)*FAC1 C ADD TO THE NEUTRINO DEPOSIT DLONG(LHEIGH,18) = DLONG(LHEIGH,18) * + ( SECPAR(1)*PAMA(ITY)-RESTMS(ITY) )*CURPAR(13)*FAC2 #else DLONG(LHEIGH,11) = DLONG(LHEIGH,11) + SECPAR(1) ELSEIF ( ITY .EQ. 2 ) THEN DLONG(LHEIGH,13) = DLONG(LHEIGH,13) * + (SECPAR(1)+1.D0)*PAMA(2) ELSEIF ( ITY .EQ. 3 ) THEN DLONG(LHEIGH,13) = DLONG(LHEIGH,13) * + (SECPAR(1)-1.D0)*PAMA(2) ELSEIF ( ITY .EQ. 5 .OR. ITY .EQ. 6 ) THEN DLONG(LHEIGH,15) = DLONG(LHEIGH,15) + SECPAR(1)*PAMA(5) ELSEIF ( ITY .GE. 7 ) THEN IF ( ITY .EQ. 8 .OR. ITY .EQ. 9 .OR. * ITY .EQ. 11 .OR. ITY .EQ. 12 ) THEN FAC1 = 0.25D0 FAC2 = 0.75D0 ELSEIF ( ITY .EQ. 10 .OR. ITY .EQ. 16 ) THEN FAC1 = 0.5D0 FAC2 = 0.5D0 ELSE FAC1 = 1.D0 FAC2 = 0.D0 ENDIF C ADD TO THE HADRON ENERGY DEPOSIT DLONG(LHEIGH,17) = DLONG(LHEIGH,17) * + ( SECPAR(1)*PAMA(ITY)-RESTMS(ITY) )*FAC1 C ADD TO THE NEUTRINO DEPOSIT DLONG(LHEIGH,18) = DLONG(LHEIGH,18) * + ( SECPAR(1)*PAMA(ITY)-RESTMS(ITY) )*FAC2 #endif ENDIF ENDIF #if __AUGERHIST__ THICKLOC = THICK( CURPAR(5) ) DO LL = 1, NOBSLV IF ( THICKLOC .GE. THCKOB(LL) .AND. * THICKLOC .LT. THCKOB(LL)+SAMPTH ) THEN C THICKH IS WITHIN 1 G/CM^2 BELOW OBSLEV(LL) C BRING THE ENERGY BELOW ANGULAR CUT TO THE HISTO OF LEVEL LL DO II = 0, 8 OUTPAR(II) = SECPAR(II) ENDDO IF ( SECPAR(0) .EQ. 1.D0 ) THEN EDEP = OUTPAR(1) * CURPAR(13) ELSEIF ( SECPAR(0) .EQ. 2.D0 .OR. * SECPAR(0) .EQ. 3.D0 ) THEN OUTPAR(1) = OUTPAR(1) * PAMA(2) EDEP = ( OUTPAR(1) - RESTMS(ITY) ) * CURPAR(13) ELSE EDEP = ( OUTPAR(1) * PAMA(ITY) * - RESTMS(ITY) ) * CURPAR(13) ENDIF OUTPAR( 9) = GEN OUTPAR(10) = ALEVEL OUTPAR(13) = CURPAR(13) C WE HAVE ANGULAR CUT CALL AUGERDEPFIL( EDEP,LL,1 ) ELSEIF ( THICKLOC .LT. THCKOB(LL) ) THEN GOTO 112 ENDIF ENDDO 112 CONTINUE #endif ENDIF 61 CONTINUE C --- COUNTER FOR ENERGY-MULTIPLICITY MATRIX MSMM = MSMM + NTOT C --- FILL ELASTICITY IN MATRICES ELASTI = EMAX/ENOLD MELL = MIN ( 1.D0+10.D0* MAX( 0.D0, ELASTI ) , 11.D0 ) MEN = MIN ( 4.D0+ 3.D0*LOG10(MAX( .1D0, EKINL )), 40.D0 ) #if __THIN__ IELDPM(MEN,MELL) = IELDPM(MEN,MELL) + NINT( CURPAR(13) ) IELDPA(MEN,MELL) = IELDPA(MEN,MELL) + NINT( CURPAR(13) ) IF ( ELASTI .LT. 1. ) THEN ELMEAN(MEN) = ELMEAN(MEN) + ELASTI*CURPAR(13) ELMEAA(MEN) = ELMEAA(MEN) + ELASTI*CURPAR(13) #else IELDPM(MEN,MELL) = IELDPM(MEN,MELL) + 1 IELDPA(MEN,MELL) = IELDPA(MEN,MELL) + 1 IF ( ELASTI .LT. 1. ) THEN ELMEAN(MEN) = ELMEAN(MEN) + ELASTI ELMEAA(MEN) = ELMEAA(MEN) + ELASTI #endif ENDIF #if __COASTUSERLIB__ coastProjId = nint(curpar(0)) coastTargId = nint(atno2) coastX = curpar(7) coastY = curpar(8) #if __CURVED__ coastZ = curpar(14) #else coastX = coastX - XOFF(NOBSLV) coastY = coastY - YOFF(NOBSLV) coastZ = curpar(5) #endif coastT = curpar(6) coastE = pama(coastProjId)*curpar(1) coastCX = sigair coastEl = elasti call interaction(coastX) #endif IF ( FIRSTI ) THEN TARG1I = ATNO2 SIG1I = SIGAIR ELAST = ELASTI C RANDOM GENERATOR STATUS (SEQUENCE L=1) AT END OF EVENT LL = 1 CALL RMMAQD( ISEED(1,LL),LL,'R' ) C SEED ISEED1I(1) = ISEED(1,LL) C NUMBER OF CALLS ISEED1I(2) = ISEED(2,LL) C NUMBER OF BILLIONS ISEED1I(3) = ISEED(3,LL) FIRSTI = .FALSE. ENDIF IF ( DEBUG ) WRITE(MDEBUG,*)'CGHEI : EXIT WITH ETOT=',SNGL(ETOT) 9999 CONTINUE C --- LIMIT THE VALUE OF NGKINE IN CASE OF OVERFLOW --- NGKINE = MIN( NGKINE, MXGKGH ) RETURN END #endif #if __GHEISHAD__ *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE CGHINI C----------------------------------------------------------------------- C C(ORSIKA) GH(EISHA) INI(TIALIZATION) C INITIALIZATION OF RELEVANT GHEISHA VARIABLES. C THIS SUBROUTINE IS CALLED FROM START. C C ORIGIN : GHEISHA SUBROUT. "GHEINI", F.CARMINATI C REDESIGN: P. GABRIEL IK1 FZK KARLSRUHE C----------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION(A-H, O-Z) #define __AIRINC__ #define __CGCOMPINC__ #define __PAMINC__ #define __RUNPARINC__ #if __INTTEST__ #define __PRIMSPINC__ #define __TSTINTINC__ #endif #include "corsika.h" COMMON /GSECTI/ AIEL(20),AIIN(20),AIFI(20),AICA(20),ALAM,K0FLAG INTEGER K0FLAG DOUBLE PRECISION AIEL,AIIN,AIFI,AICA,ALAM 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) COMMON /PRNTFL/ INBCD,NEWBCD,INBIN,NEWBIN,NPEVT,NEVTP, * LPRT,NPRT(10) LOGICAL LPRT,NPRT 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 SAVE C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'CGHINI:' #if __INTTEST__ IF ( NDIF .NE. 0 .AND. LLIMIT .LE. HILOELB ) THEN WRITE(MONIOU,*)'CGHINI: ONLY DIFFRACTIVE AND NON DIFFRACTIVE', * 'MIXED IS POSSIBLE WITH GHEISHA' STOP ENDIF IF ( ITTAR .EQ. 1 ) THEN C PROTON TARGET KK = 1 WCOMP(1) = 1.D0 ACOMP(1) = 1.D0 ZCOMP(1) = 1.D0 ELSEIF ( ITTAR .EQ. 2 ) THEN C NEUTRON TARGET KK = 1 WCOMP(1) = 1.D0 ACOMP(1) = 1.D0 ZCOMP(1) = 0.D0 ELSEIF ( ITTAR .EQ. 9 ) THEN C BERYLLIUM TARGET KK = 1 WCOMP(1) = 1.D0 ACOMP(1) = 9.D0 ZCOMP(1) = 4.D0 ELSEIF ( ITTAR .EQ. 12 ) THEN C CARBON TARGET KK = 1 WCOMP(1) = 1.D0 ACOMP(1) = 12.D0 ZCOMP(1) = 6.D0 ELSEIF ( ITTAR .EQ. 14 ) THEN C NITROGEN TARGET KK = 1 WCOMP(1) = 1.D0 ACOMP(1) = 14.D0 ZCOMP(1) = 7.D0 ELSEIF ( ITTAR .EQ. 16 ) THEN C OXYGEN TARGET KK = 1 WCOMP(1) = 1.D0 ACOMP(1) = 16.D0 ZCOMP(1) = 8.D0 ELSEIF ( ITTAR .EQ. 40 ) THEN C ARGON TARGET KK = 1 WCOMP(1) = 1.D0 ACOMP(1) = 40.D0 ZCOMP(1) = 18.D0 ELSEIF ( ITTAR .EQ. 99 ) THEN C AIR TARGET KK = 3 WCOMP(1) = COMPOS(1) WCOMP(2) = COMPOS(2) WCOMP(3) = COMPOS(3) ACOMP(1) = 14.D0 ACOMP(2) = 16.D0 ACOMP(3) = 40.D0 ZCOMP(1) = 7.D0 ZCOMP(2) = 8.D0 ZCOMP(3) = 18.D0 ENDIF #else C --- INITIALIZE COMPOSITION OF AIR KK = 3 WCOMP(1) = COMPOS(1) WCOMP(2) = COMPOS(2) WCOMP(3) = COMPOS(3) ACOMP(1) = 14.D0 ACOMP(2) = 16.D0 ACOMP(3) = 40.D0 ZCOMP(1) = 7.D0 ZCOMP(2) = 8.D0 ZCOMP(3) = 18.D0 #endif C --- SET GHEISHA I/O UNITS TO THE SAME AS FOR CORSIKA -- INBCD=MONIIN NEWBCD=MONIOU IF ( DEBUG .OR. DEBDEL ) NEWBCD=MDEBUG C --- INITIALIZE ALL GHEISHA PRINT FLAGS AS FALSE --- C --- ACTIVATION IS DONE BY "DEBUG" STEERING CARD --- DO J = 1, 10 NPRT(J) = .FALSE. ENDDO IF ( DEBUG .AND. GHEISDB ) THEN NPRT(4) = .TRUE. NPRT(9) = .TRUE. ELSE NPRT(4) = .FALSE. NPRT(9) = .FALSE. ENDIF 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 GEANT VALUES --- TOFCUT = 1.0D+20 NSIZE = MXEVEN K0FLAG = 0 CENG(3) = 0.D0 CENG(4) = 0.D0 C --- INITIALIZE PI, 2*PI, PI/2 AND PARTICLE PARAMETERS --- PI = ACOS( -1.D0 ) TWPI = 2.D0*PI PIBTW = PI/2.D0 C *** GAMMA *** RMASS(1) = PAMA(1) RCHARG(1) = 0.D0 C *** NEUTRINO *** RMASS(2) = PAMA(4) RCHARG(2) = 0.D0 C *** E+ *** RMASS(3) = PAMA(2) RCHARG(3) = 1.D0 C *** E- *** RMASS(4) = PAMA(3) RCHARG(4) = -1.D0 C *** MU+ *** RMASS(5) = PAMA(5) RCHARG(5) = 1.D0 C *** MU- *** RMASS(6) = PAMA(6) RCHARG(6) = -1.D0 C *** PI+ *** RMASS(7) = PAMA(8) RCHARG(7) = 1.D0 CT = 780.4D0 C *** PI0 *** RMASS(8) = PAMA(7) RCHARG(8) = 0.D0 C *** PI- *** RMASS(9) = PAMA(9) RCHARG(9) = -1.D0 C *** K+ *** RMASS(10) = PAMA(11) RCHARG(10) = 1.D0 CTKCH = 370.9D0 C *** K0 SHORT (==> K0) *** RMASS(11) = PAMA(16) RCHARG(11) = 0.D0 CTK0 = 2.675D0 C *** K0 LONG (==> K0 BAR) *** RMASS(12) = -PAMA(10) RCHARG(12) = 0.D0 C *** K- *** RMASS(13) = PAMA(12) RCHARG(13) = -1.D0 C *** P *** RMASS(14) = PAMA(14) RCHARG(14) = 1.D0 C *** P BAR *** RMASS(15) = -PAMA(15) RCHARG(15) = -1.D0 C *** N *** RMASS(16) = PAMA(13) RCHARG(16) = 0.D0 C *** N BAR *** RMASS(17) = -PAMA(25) RCHARG(17) = 0.D0 C *** L0 *** RMASS(18) = PAMA(18) RCHARG(18) = 0.D0 CTL0 = 7.89D0 C *** L0 BAR *** RMASS(19) = -PAMA(26) RCHARG(19) = 0.D0 C *** S+ *** RMASS(20) = PAMA(19) RCHARG(20) = 1.D0 CTSP = 2.4D0 C *** S0 *** RMASS(21) = PAMA(20) RCHARG(21) = 0.D0 C *** S- *** RMASS(22) = PAMA(21) RCHARG(22) = -1.D0 CTSM = 4.44D0 C *** S+ BAR *** RMASS(23) = -PAMA(27) RCHARG(23) = -1.D0 C *** S0 BAR *** RMASS(24) = -PAMA(28) RCHARG(24) = 0.D0 C *** S- BAR *** RMASS(25) = -PAMA(29) RCHARG(25) = 1.D0 C *** XI0 *** RMASS(26) = PAMA(22) RCHARG(26) = 0.D0 CTX0 = 8.69D0 C *** XI- *** RMASS(27) = PAMA(23) RCHARG(27) = -1.D0 CTXM = 4.92D0 C *** XI0 BAR *** RMASS(28) = -PAMA(30) RCHARG(28) = 0.D0 CTX0 = 8.69D0 C *** XI- BAR *** RMASS(29) = -PAMA(31) RCHARG(29) = 1.D0 C *** DEUTERON *** RMASS(30) = PAMA(201) RCHARG(30) = 1.D0 C *** TRITON *** RMASS(31) = PAMA(301) RCHARG(31) = 1.D0 C *** ALPHA *** RMASS(32) = PAMA(402) RCHARG(32) = 2.D0 C *** OMEGA- *** RMASS(33) = PAMA(24) RCHARG(33) = -1.D0 C *** OMEGA- BAR *** RMASS(34) = -PAMA(32) RCHARG(34) = 1.D0 C *** NEW PARTICLE (GEANTINO) *** RMASS(35) = 0.D0 RCHARG(35) = 0.D0 IF ( NPRT(9) ) $ WRITE(MDEBUG,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) 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.D0 EXPXU = 82.D0 IF ( NPRT(9) ) WRITE(MDEBUG,1001) EXPXL,EXPXU 1001 FORMAT(' *GHEINI* === INTRINSIC FUNCTION BOUNDARIES ===',/, $ ' EXPXL,EXPXU = ',2(G12.5,1X)) RETURN END *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= DOUBLE PRECISION FUNCTION CGHSIG( PPART,EKIN,LPART ) C----------------------------------------------------------------------- C C(ORSIKA) 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 LPART = PARTICLE TYPE C C ORIGIN : F.CARMINATI, H.FESEFELDT (SUBROUT. GHESIG) C REDESIGN: P. GABRIEL IK1 FZK KARLSRUHE C----------------------------------------------------------------------- C *** IPART 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) #define __CGCOMPINC__ #define __RUNPARINC__ #include "corsika.h" 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 --- DIMENSION KIPART(48) * DIMENSION IKPART(35) 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 --- 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/ * 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 PARAMETERIZATION 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"). #if !__GFORTRAN__ SAVE ALPHA,ALPHAC,PARTEL,PARTIN,CSA,IPART2,INTRC #endif C H AL CU PB DATA CSA / 1.D0, 27.00D0, 63.54D0, 207.19D0 / DATA IPART2 / 9, 8, 7, 11, 10, 13, 12 / C----------------------------------------------------------------------- IF ( DEBUG .AND. GHEISDB ) THEN WRITE(MDEBUG,*) 'CGHSIG:' NPRT(4) = .TRUE. NPRT(9) = .TRUE. ELSE NPRT(4) = .FALSE. NPRT(9) = .FALSE. ENDIF C --- INITIALIZE CGHSIG AND SWITCH TO GHEISHA PARTICLE CODE --- CGHSIG=0.0 IF ( LPART .LT. 48 ) THEN IPART = KIPART(LPART) ELSEIF ( LPART .EQ. 201 ) THEN IPART = 30 ELSEIF ( LPART .EQ. 301 ) THEN IPART = 31 ELSEIF ( LPART .EQ. 402 ) THEN IPART = 32 ELSE GOTO 160 ENDIF 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 C --- INITIALIZE THE CROSS-SECTIONS WITH 0.0 --- DO K = 1, KK AIEL(K) = 0.D0 AIIN(K) = 0.D0 AICA(K) = 0.D0 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.D0**ONETHR ELSEIF ( IPART .EQ. 31 ) THEN APART = 3.D0**ONETHR ELSEIF ( IPART .EQ. 32 ) THEN APART = 4.D0**ONETHR ENDIF DO K = 1, KK AIIN(K) = 49.D0*(APART+ACOMP(K)**ONETHR)**2 ENDDO IF ( NPRT(9) ) WRITE(MDEBUG,10000) ELSEIF ( (IPART .EQ. 16) .AND. (EK .LE. 0.0327) ) 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 = ZCOMP(K)+0.01D0 AICA(K) = 11.12D0*CSCAP(IZNO)/(EKX*1.0D6)**0.577D0 70 CONTINUE IF ( NPRT(9) ) WRITE(MDEBUG,10100) ELSE C --- USE PARAMETERIZATION OF CROSS-SECTION DATA FOR ALL OTHER CASES --- IF ( NPRT(9) ) WRITE(MDEBUG,10200) 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 PARAMETERIZATION --- CREL = 1.D0 CRIN = 1.D0 C --- GET MEDIUM BIN 1=HYDR. 2=AL 3=CU 4=PB --- I = 3 IF ( ACOMP(K) .LT. 50.D0 ) I = 2 IF ( ACOMP(K) .GT. 100.D0 ) 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.D0 ) + WGCH = 0.5D0+0.5D0*EXP( -(ACOMP(K)-1.0) ) AIEL(K) = WGCH*AIEL(K)+(1.D0-WGCH)*XSECEL AIIN(K) = WGCH*AIIN(K)+(1.D0-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.D0 DO K = 1, KK AIEL(K) = AIEL(K)*WCOMP(K) AIIN(K) = AIIN(K)*WCOMP(K) AICA(K) = AICA(K)*WCOMP(K) ALAM = ALAM + AIEL(K) + AIIN(K) + AICA(K) ENDDO C --- PASS THE CROSS-SECTION (MBARN) TO CORSIKA --- CGHSIG = ALAM GOTO 999 C --- PRINTOUT OF SKIPPED PARTICLES IN CASE OF INTERFACE DEBUG --- 160 IF (NPRT(9)) WRITE(MDEBUG,10300) IPART 10000 FORMAT(' *CGHSIG* GEOM X-SECT. FOR INEL. SCAT. OF D,T AND ALPHA') 10100 FORMAT(' *CGHSIG* X-SECT. FROM LOW ENERGY NEUTRON TABLES') 10200 FORMAT(' *CGHSIG* X-SECT. FROM PARAMETERIZATION OF DATA') 10300 FORMAT(' *CGHSIG* GHEISHA PARTICLE ',I3,' SKIPPED') 999 RETURN END *-- 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 .LE. 0 ) THEN GOTO 50 ELSE GOTO 10 ENDIF 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 *-- Author : D. HECK IK FZK KARLSRUHE 17/03/2003 C======================================================================= SUBROUTINE GRNDM( RVEC,LENV ) C----------------------------------------------------------------------- C G(HEISHA) R(A)ND(O)M (NUMBER GENERATOR) C C WE USE HERE A SIMPLIFIED FORM OF RMMARD WITH JSEQ=1. C THIS SUBROUTINE IS CALLED FROM GHEISHA ROUTINES. C ARGUMENTS: C RVEC = VECTOR FIELD TO BE FILLED WITH RANDOM NUMBERS (REAL*8) C LENV = LENGTH OF VECTOR (# OF RANDNUMBERS TO BE GENERATED) C----------------------------------------------------------------------- IMPLICIT NONE #define __RANMA3INC__ #define __RANMA4INC__ #if __CONEX__ #define __CONEXINC__ #endif #include "corsika.h" #if __CONEX__ #include "conex.h" #endif DOUBLE PRECISION RVEC(*) INTEGER IVEC,LENV SAVE C----------------------------------------------------------------------- JSEQ = 1 #if __CONEX__ IF ( FINCNX ) JSEQ = lseq #endif 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 #endif #if __URQMD__ *-- Author : D. HECK IK FZK KARLSRUHE 09/03/2004 C======================================================================= BLOCK DATA URQDAT C----------------------------------------------------------------------- C UrQ(MD) DAT(A) C C SETS PARTICLE CODE TABLES FOR CONVERSION FROM CORSIKA TO URQMD C----------------------------------------------------------------------- IMPLICIT NONE #define __URQCOMINC__ #include "corsika.h" C SET THE IMPACT PARAMETERS DATA BIM / 6.D0, 6.D0, 7.D0 / 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 / END *-- Author : J. Wentz IK FZK KARLSRUHE 10/05/1999 C======================================================================= SUBROUTINE URQINI C----------------------------------------------------------------------- C URQ(MD) INI(TIALIZATION) C C FIRST INITIALIZATION C THIS SUBROUTINE IS CALLED FROM START. C----------------------------------------------------------------------- IMPLICIT NONE #define __RUNPARINC__ #define __URQCOMINC__ #include "corsika.h" include 'boxinc.f' include 'coms.f' include 'inputs.f' include 'options.f' 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 iamax,idmax,iemax common /cxs_u1/ sig_u1(mxie,mxid,mxia),iamax,idmax,iemax SAVE C----------------------------------------------------------------------- IF ( DEBUG ) THEN WRITE(MDEBUG,*) 'URQINI: START' IUDEBUG = IUDEBG0 ELSE IUDEBUG = 0 ENDIF WRITE (MONIOU,*) $ '############################################################' WRITE (MONIOU,*) $ '## ##' WRITE (MONIOU,*) $ '## UrQMD 1.3.1 University of Frankfurt ##' WRITE (MONIOU,*) $ '## urqmd@th.physik.uni-frankfurt.de ##' WRITE (MONIOU,*) $ '## ##' WRITE (MONIOU,*) $ '############################################################' WRITE (MONIOU,*) $ '## ##' WRITE (MONIOU,*) $ '## please cite when using this model: ##' WRITE (MONIOU,*) $ '## S.A.Bass et al. Prog.Part.Nucl.Phys. 41 (1998) 225 ##' WRITE (MONIOU,*) $ '## M.Bleicher et al. J.Phys. G25 (1999) 1859 ##' WRITE (MONIOU,*) $ '## ##' WRITE (MONIOU,*) $ '############################################################' 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,MDEBUG) bf15 = .true. ELSEIF ( IUDEBUG .EQ. 2 ) THEN bf13 = .false. call uounit(13,MDEBUG) bf14 = .true. bf15 = .true. ELSEIF ( IUDEBUG .GT. 2 ) THEN bf13 = .true. bf14 = .true. bf15 = .false. call uounit(15,MDEBUG) 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 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(MDEBUG,*) '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 OPEN(UNIT=76,FILE=DATDIR(1:INDEX(DATDIR,' ')-1)// * 'UrQMD-1.3.1-xs.dat',STATUS='OLD') read(76,'(a1,i2,2i4)') adum,iamax,idmax,iemax do ia=1,iamax do id=1,idmax do ie=1,iemax 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 IF ( IUDEBUG .GT. 0 ) WRITE(MDEBUG,*) 'URQINI: END' RETURN END *-- Author : D. HECK IK FZK KARLSRUHE 12/03/2004 C======================================================================= SUBROUTINE URQLNK C----------------------------------------------------------------------- C URQ(MD) L(I)NK (WITH CORSIKA) C C LINKS URQMD MODEL TO CORSIKA TO PERFORM COLLISIONS. C THIS SUBROUTINE IS CALLED FROM NUCINT AND SDPM. C----------------------------------------------------------------------- IMPLICIT NONE #define __PAMINC__ #define __PARPARINC__ #define __RANDPAINC__ #define __RESTINC__ #define __RUNPARINC__ #define __SIGMINC__ #define __URQCOMINC__ #if __INTTEST__ #define __TSTINTINC__ #endif #include "corsika.h" include 'boxinc.f' include 'comres.f' include 'coms.f' include 'comwid.f' include 'inputs.f' include 'options.f' double precision caltim,outtim,ELABU,nucrad save c----------------------------------------------------------------------- IF ( DEBUG ) THEN #if __INTTEST__ WRITE(MDEBUG,*) 'URQLNK: TARGET=',ITTAR #else WRITE(MDEBUG,*) 'URQLNK:' #endif IUDEBUG = IUDEBG0 C SET DEBUG OUTPUT DEPENDING ON CHOSEN DEBUG LEVEL IF ( IUDEBUG .EQ. 1 ) THEN bf13 = .true. bf14 = .false. call uounit(14,MDEBUG) bf15 = .true. ELSEIF ( IUDEBUG .EQ. 2 ) THEN bf13 = .false. call uounit(13,MDEBUG) bf14 = .true. bf15 = .true. ELSEIF ( IUDEBUG .GT. 2 ) THEN bf13 = .true. bf14 = .true. bf15 = .false. call uounit(15,MDEBUG) ENDIF ELSE IUDEBUG = 0 bf13 = .true. bf14 = .true. bf15 = .true. ENDIF C SELECT AND INITIALIZE TARGET trspflg = 0 #if __INTTEST__ IF ( ITTAR .EQ. 1 ) THEN C PROTON TARGET trspflg = 1 spityp(2) = 1 spiso3(2) = 1 At = 1 TAR = 1.D0 ELSEIF ( ITTAR .EQ. 2 ) THEN C NEUTRON TARGET trspflg = 1 spityp(2) = 1 spiso3(2) = -1 At = 1 TAR = 2.D0 ELSEIF ( ITTAR .EQ. 9 ) THEN C BERYLLIUM TARGET At = 9 Zt = 4 LIT = 1 TAR = 9.D0 ELSEIF ( ITTAR .EQ. 12 ) THEN C CARBON TARGET At = 12 Zt = 6 LIT = 1 TAR = 12.D0 ELSEIF ( ITTAR .EQ. 14 ) THEN C NITROGEN TARGET At = 14 Zt = 7 LIT = 1 TAR = 14.D0 ELSEIF ( ITTAR .EQ. 16 ) THEN C OXYGEN TARGET At = 16 Zt = 8 LIT = 2 TAR = 16.D0 ELSEIF ( ITTAR .EQ. 40 ) THEN C ARGON TARGET At = 40 Zt = 18 LIT = 3 TAR = 40.D0 ELSEIF ( ITTAR .EQ. 99 ) THEN C FOR AIR TARGET TAKE THE NORMAL PROCEDURE, NO SPECIAL ACTION GOTO 101 ENDIF GOTO 100 101 CONTINUE #endif C TARGET IS A NUCLEUS IF ( FIXTAR ) THEN C TARGET OF FIRST INTERACTION IS FIXED LIT = N1STTR IF ( N1STTR .EQ. 1 ) THEN At = 14 Zt = 7 TAR = 14.D0 ELSEIF ( N1STTR .EQ. 2 ) THEN At = 16 Zt = 8 TAR = 16.D0 ELSE At = 40 Zt = 18 TAR = 40.D0 ENDIF FIXTAR = .FALSE. ELSE C TARGET IS CHOSEN AT RANDOM ACCORDING TO CROSS-SECTION CALL RMMARD( RD,1,1 ) IF ( RD(1) * SIGAIR .LE. FRACTN ) THEN C INTERACTION WITH NITROGEN LIT = 1 At = 14 Zt = 7 TAR = 14.D0 ELSEIF ( RD(1) * SIGAIR .LE. FRCTNO ) THEN C INTERACTION WITH OXYGEN LIT = 2 At = 16 Zt = 8 TAR = 16.D0 ELSE C INTERACTION WITH ARGON LIT = 3 At = 40 Zt = 18 TAR = 40.D0 ENDIF ENDIF #if __INTTEST__ 100 CONTINUE #endif IF ( IUDEBUG .GT. 0 ) WRITE(MDEBUG,*) * 'URQLNK: TARGET WITH At=',At,' Zt=',Zt C PROJECTILE IS A SPECIAL PARTICLE prspflg = 1 Ap = 1 C SET THE PROJECTILE IF ( ITYPE .LT. 200 ) THEN spityp(1) = ICUTBL(ITYPE) spiso3(1) = ICU2I3(ITYPE) ELSE C WE HAVE A NUCLEUS, WHICH AT PRESENT CANNOT BE TREATED WRITE(MONIOU,*) 'URQLNK: ITYPE =',ITYPE RETURN ENDIF C SPECIAL TREATMENT OF K(O)LONG AND K(0)SHORT #if __INTTEST__ IF ( ITYPE .EQ. 10 ) THEN C DEFINE K0L AS K0BAR spityp(1) = -106 spiso3(1) = 1 ELSEIF ( ITYPE .EQ. 16 ) THEN C DEFINE K0S AS K0 spityp(1) = 106 spiso3(1) = -1 #else IF ( ITYPE .EQ. 10 .OR. ITYPE .EQ. 16 ) THEN CALL RMMARD( RD,1,1 ) IF ( RD(1) .LT. 0.5D0 ) THEN C K(0) spityp(1) = 106 spiso3(1) = -1 ELSE C K(0)BAR spityp(1) = -106 spiso3(1) = 1 ENDIF #endif ENDIF C ENERGY OF COLLISION (LAB-SYSTEM) ELABU = CURPAR(1) * PAMA(ITYPE) ebeam = ELABU - PAMA(ITYPE) C imp: impact parameter C NEGATIVE BIM MEANS MIN. BIAS UP TO BIM(LIT) bmin = 0.d0 CTOption(5) = 1 if ( iflbmax.eq.1 ) then bdist = BIM(LIT) else bdist=nucrad(Ap)+nucrad(At)+2*CTParam(30) endif 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) C DO NOT INITIALIZE PROJECTILE AND TARGET IF OLD EVENT IS READ IN if ( CTOption(40) .eq. 1 ) goto 300 C constraints for skyrme pots: if ( eos .ne. 0 .and. ((srtflag.eq.0.and.ebeam.gt.4.d0) & .or. (srtflag.eq.1.and.srtmax.gt.3.3d0) & .or. (srtflag.eq.2.and.pbeam.gt.4.9d0)) ) then C write(6,*)'***(W) I switched off the potentials' eos=0 endif if ( eos .ne. 0 ) then CTOption(11) = 1 CTOption(28) = 0 CTOption(30) = 0 endif 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 300 CONTINUE C NOW THE REAL WORK IS DONE CALL URQMD( IFLBMAX ) C STORE SECONDARY PARTICLES TO CORSIKA CALL URQSTR( ELABU ) RETURN END *-- Author : D. HECK IK FZK KARLSRUHE 18/03/2003 C======================================================================= DOUBLE PRECISION FUNCTION RANF(IDUM) C----------------------------------------------------------------------- C RAN(DOM GENERATOR) F(UNCTION FOR URQMD) C C THIS ROUTINE LINKS THE RMMARD-RANDOM NUMBER GENERATOR OF C CORSIKA TO URQMD. C WE USE HERE A SIMPLIFIED FORM OF RMMARD WITH JSEQ=1, LENV=1. C THIS SUBROUTINE IS CALLED FROM THE URQMD ROUTINES. C ARGUMENT: C IDUM = DUMMY ARGUMENT c---------------------------------------------------------------------- IMPLICIT NONE #define __RANMA3INC__ #define __RANMA4INC__ #define __CONEXINC__ #if __CONEX__ #endif #include "corsika.h" #if __CONEX__ #include "conex.h" #endif INTEGER IDUM SAVE C----------------------------------------------------------------------- JSEQ = 1 #if __CONEX__ IF ( FINCNX ) JSEQ = lseq #endif 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 RANF = UNI NTOT(JSEQ) = NTOT(JSEQ) + 1 IF ( NTOT(JSEQ) .GE. MODCNS ) THEN NTOT2(JSEQ) = NTOT2(JSEQ) + 1 NTOT(JSEQ) = NTOT(JSEQ) - MODCNS ENDIF RETURN END *-- Author : D. HECK IK FZK KARLSRUHE 08/03/2004 C======================================================================= SUBROUTINE URQSIG( ETOT, NTYPE ) C----------------------------------------------------------------------- C URQ(MD) SIG(MA) C C RETURNS THE MAXIMAL TOTAL CROSS-SECTION FOR URQMD C THIS SUBROUTINE IS CALLED FROM BOX2. C ARGUMENTS: C ETOT = TOTAL ENERGY IN LABORATORY SYSTEM (GEV) C NTYPE = PARTICLE TYPE (CORSIKA TYPE) C----------------------------------------------------------------------- IMPLICIT NONE #define __AIRINC__ #define __PAMINC__ #define __RUNPARINC__ #define __SIGMINC__ #define __URQCOMINC__ #include "corsika.h" DOUBLE PRECISION ETOT,RA,ekin,xsu(3) INTEGER NTYPE,idu,iflb SAVE C----------------------------------------------------------------------- IF ( IUDEBUG .GT. 0 ) WRITE(MDEBUG,*) & 'URQSIG: ETOT=',ETOT,' TYPE=',NTYPE ekin = ETOT-PAMA(NTYPE) C CALCUTE CROSS-SECTIONS * CONTRIBUTION IN AIR FOR N, N+O, call cxtot_u(ekin,NTYPE,xsu,iflb) IFLBMAX = iflb FRACTN = COMPOS(1) * xsu(1) FRCTNO = COMPOS(2) * xsu(2) + FRACTN C AND THE CROSS-SECTION FOR AIR SIGAIR = COMPOS(3) * xsu(3) + FRCTNO IF ( NTYPE .GE. 200 ) THEN C INCREASE THE CROSS_SECTION IN CASE OF NUCLEI BY A FACTOR C WHICH RISES UP WITH A**(2/3) CORRESPONDING WITH THE NUCLEAR RADIUS RA = (DBLE( NTYPE/100) )**0.666666666D0 FRACTN = FRACTN * RA FRCTNO = FRCTNO * RA SIGAIR = SIGAIR * RA ENDIF IF ( IUDEBUG .GT. 0 ) & WRITE(MDEBUG,85) xsu(1),xsu(2),xsu(3),SIGAIR,IFLBMAX 85 FORMAT(' URQSIG: CROSS-SECT N=',F8.3,' O=',F8.3,' Ar=',F8.3, & ' AIR=',F8.3,' IFLBMAX',I2) RETURN END C----------------------------------------------------------------------- subroutine cxtot_u(ekin,ntype,xsu,iflb) C----------------------------------------------------------------------- C ARGUMENTS: c ekin = kinetic energy in GeV c ntype = CORSIKA id converted to id=1..9 c proton, anti-proton, neutron,anti-neutron,pi+,pi-,K+,K-,KS c iflb = flag for retrying interaction if xs not from table C----------------------------------------------------------------------- implicit none #define __URQCOMINC__ #include "corsika.h" double precision ekin,xsu(3) integer mxie,mxid,mxia parameter (mxie=41,mxid=10,mxia=3) double precision sig_u1 integer iamax,idmax,iemax common /cxs_u1/ sig_u1(mxie,mxid,mxia),iamax,idmax,iemax dimension we(3) double precision ye,we integer je,i,id,ia,ntype,iflb iflb=0 ye = log10(ekin)*10.d0+10.5d0 if ( ye. lt. 1d0 ) ye = 1.d0 je = min(iemax-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) if ( ntype .eq. 14 ) then id = 1 elseif( ntype .eq. 15 ) then id = 2 elseif( ntype .eq. 13 ) then id = 3 elseif( ntype .eq. 25 ) then id = 4 elseif( ntype .eq. 8 ) then id = 5 elseif( ntype .eq. 9 ) then id = 6 elseif( ntype .eq. 11 ) then id = 7 elseif( ntype .eq. 12 ) then id = 8 elseif( ntype .eq. 10 .or. ntype .eq. 16 ) then id = 9 else iflb = 1 do ia = 1,3 xsu(ia) = XS(ia) enddo return endif c ia=1..3 c N,O,Ar do ia = 1,3 xsu(ia) = 0.d0 do i = 1,3 xsu(ia) = xsu(ia)+sig_u1(je+i-1,id,ia)*we(i) enddo enddo return end *-- Author : D. HECK IK FZK KARLSRUHE 08/03/2004 C======================================================================= SUBROUTINE URQSTR( ELABU ) C----------------------------------------------------------------------- C URQ(MD PARTICLES) ST(O)R(E) C C THIS SUBROUTINE IS CALLED FROM URQLNK C ARGUMENT: C ELABU = TOTAL INCOMING ENERGY (GEV) C----------------------------------------------------------------------- IMPLICIT NONE #define __ELADPMINC__ #define __ELASTYINC__ #define __ISTAINC__ #define __LONGIINC__ #define __MULTINC__ #define __PAMINC__ #define __PARPARINC__ #define __RANDPAINC__ #define __RESTINC__ #define __RUNPARINC__ #define __SIGMINC__ #if __AUGERHIST__ || __EHISTORY__ #define __GENERINC__ #endif #if __AUGERHIST__ || __COASTUSERLIB__ #define __OBSPARINC__ #endif #if __INTTEST__ #define __TSTINTINC__ #define __URQINTESTINC__ #endif #include "corsika.h" include 'coms.f' include 'inputs.f' DOUBLE PRECISION COSTET,CPHIU,ELABU,ELASTI,EMAX,ETOT,FERMTH, * PLSQ,PTOT,PTSQ,SPHIU DOUBLE PRECISION FAC1,FAC2 INTEGER J,MEL,MEN,NTYPE,LL #if __EHISTORY__ INTEGER IK #endif #if __AUGERHIST__ DOUBLE PRECISION EDEP,THICKLOC,THICK INTEGER II EXTERNAL THICK #endif #if __COASTUSERLIB__ c definition of the COAST crs::CInteraction class COMMON/coastInteraction/coastX, coastY, coastZ, & coastE, coastCX, coastEl, coastProjId, coastTargId, & coastT double precision coastX, coastY, coastZ double precision coastE, coastCX, coastEl double precision coastT integer coastProjId, coastTargId #endif SAVE C FERMI TEMPERATURE IN GEV DATA FERMTH / 5.D-3 / c----------------------------------------------------------------------- IF ( IUDEBUG .GT. 0 ) THEN WRITE(MDEBUG,*) 'URQSTR: ctag,NElColl=', ctag,NElColl WRITE(MDEBUG,*) 'URQSTR: ',npart,' HADRONIC SECONDARIES' WRITE(MDEBUG,*) 'NO TYPE ETOT PX PY ', * ' PZ' ENDIF EMAX = 0.D0 ELASTI = 1.D0 ETOT = 0.D0 #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME GRANDMOTHER PARTICLE DO IK = 0, 6 SECPAR(28+IK) = CURPAR(IK) ENDDO C STORE GENERATION COUNTER OF MOTHER SECPAR(35) = GEN C STORE MASS PENETRATION BEFORE INTERACTION SECPAR(36) = CURPAR(9) #if __THIN__ SECPAR(37) = CURPAR(13) #endif #endif C LOOP OVER ALL PARTICLES IN COMMONS OF coms.f DO 1001 J = 1, npart C CONVERT URQMD PARTICLE CODE TO CORSIKA PARTICLE CODE C PROTON, NEUTRON IF ( ityp(J) .EQ. 1 ) THEN IF ( iso3(J) .EQ. 1 .AND. charge(J) .EQ. 1 ) THEN NTYPE = 14 ! PROTON ELSEIF ( iso3(J) .EQ. -1 .AND. charge(J) .EQ. 0 ) THEN NTYPE = 13 ! NEUTRON ENDIF C PIONS ELSEIF ( ityp(J) .EQ. 101 ) THEN IF ( charge(J) .EQ. 0 ) THEN NTYPE = 7 ! PI(0) ELSEIF ( charge(J) .EQ. 1 ) THEN NTYPE = 8 ! PI(+) ELSEIF ( charge(J) .EQ. -1 ) THEN NTYPE = 9 ! PI(-) ENDIF C KAONS ELSEIF ( ityp(J) .EQ. 106 ) THEN IF ( charge(J) .EQ. 1 .AND. iso3(J) .EQ. 1 ) THEN NTYPE = 11 ! K(+) ELSEIF ( charge(J) .EQ. 0 .AND. iso3(J) .EQ. -1 ) THEN IF ( ctag .GT. 0 .AND. ctag .GT. NElColl ) THEN C EVENT IS MARKED TO HAVE INTERACTION C K(0) GIVES MIXING OF K(0)LONG AND K(0)SHORT CALL RMMARD ( RD,1,1 ) IF ( RD(1) .LE. 0.5D0 ) THEN NTYPE = 10 ! K(0) LONG ELSE NTYPE = 16 ! K(0) SHORT ENDIF ELSE C EVENT IS MARKED TO HAVE NO INELASTIC INTERACTION, KEEP PROJECTILE NTYPE = NINT( CURPAR(0) ) ENDIF ENDIF ELSEIF ( ityp(J) .EQ. -106 ) THEN IF ( charge(J) .EQ. -1 .AND. iso3(J) .EQ. -1 ) THEN NTYPE = 12 ! K(-) ELSEIF ( charge(J) .EQ. 0 .AND. iso3(J) .EQ. 1 ) THEN IF ( ctag .GT. 0 .AND. ctag .GT. NElColl ) THEN C EVENT IS MARKED TO HAVE INTERACTION C K(0)-BAR GIVES MIXING OF K(0)LONG AND K(0)SHORT CALL RMMARD ( RD,1,1 ) IF ( RD(1) .LE. 0.5D0 ) THEN NTYPE = 10 ! K(0) LONG ELSE NTYPE = 16 ! K(0) SHORT ENDIF ELSE C EVENT IS MARKED TO HAVE NO INELASTIC INTERACTION, KEEP PROJECTILE NTYPE = NINT( CURPAR(0) ) ENDIF ENDIF C GAMMA ELSEIF ( ityp(J) .EQ. 100 ) THEN IF ( charge(J) .EQ. 0 .AND. iso3(J) .EQ. 0 ) NTYPE = 1 C ETA ELSEIF ( ityp(J) .EQ. 102 ) THEN IF ( charge(J) .EQ. 0 .AND. iso3(J) .EQ. 0 ) NTYPE = 17 C ANTI-NUCLEONS ELSEIF ( ityp(J) .EQ. -1 ) THEN IF ( iso3(J) .EQ. -1 .AND. charge(J) .EQ. -1 ) THEN NTYPE = 15 ! ANTI-PROTON ELSEIF ( iso3(J) .EQ. 1 .AND. charge(J) .EQ. 0 ) THEN NTYPE = 25 ! ANTI-NEUTRON ENDIF C STRANGE BARYONS ELSEIF ( ityp(J) .EQ. 27 ) THEN C LAMBDA IF ( charge(J) .EQ. 0 .AND. iso3(J) .EQ. 0 ) NTYPE = 18 ELSEIF ( ityp(J) .EQ. 40 ) THEN IF ( charge(J) .EQ. 1 .AND. iso3(J) .EQ. 2 ) THEN NTYPE = 19 ! SIGMA(+) ELSEIF ( charge(J) .EQ. 0 .AND. iso3(J) .EQ. 0 ) THEN NTYPE = 20 ! SIGMA(0) ELSEIF ( charge(J) .EQ. -1 .AND. iso3(J) .EQ. -2 ) THEN NTYPE = 21 ! SIGMA(-) ENDIF ELSEIF ( ityp(J) .EQ. 49 ) THEN IF ( charge(J) .EQ. 0 .AND. iso3(J) .EQ. 1 ) THEN NTYPE = 22 ! XI(0) ELSEIF ( charge(J) .EQ. -1 .AND. iso3(J) .EQ. -1 ) THEN NTYPE = 23 ! XI(-) ENDIF ELSEIF ( ityp(J) .EQ. 55 ) THEN C OMEGA(-) IF ( charge(J) .EQ. -1 .AND. iso3(J) .EQ. 0 ) NTYPE = 24 ELSEIF ( ityp(J) .EQ. -27 ) THEN C ANTI-LAMBDA IF ( charge(J) .EQ. 0 .AND. iso3(J) .EQ. 0 ) NTYPE = 26 ELSEIF ( ityp(J) .EQ. -40 ) THEN IF ( charge(J) .EQ. -1 .AND. iso3(J) .EQ. -2 ) THEN NTYPE = 27 ! ANTI-SIGMA(-) ELSEIF ( charge(J) .EQ. 0 .AND. iso3(J) .EQ. 0 ) THEN NTYPE = 28 ! ANTI-SIGMA(0) ELSEIF ( charge(J) .EQ. 1 .AND. iso3(J) .EQ. 2 ) THEN NTYPE = 29 ! ANTI-SIGMA(+) ENDIF ELSEIF ( ityp(J) .EQ. -49 ) THEN IF ( charge(J) .EQ. 0 .AND. iso3(J) .EQ. -1 ) THEN NTYPE = 30 ! ANTI-XI(0) ELSEIF ( charge(J) .EQ. 1 .AND. iso3(J) .EQ. 1 ) THEN NTYPE = 31 ! ANTI-XI(+) ENDIF ELSEIF ( ityp(J) .EQ. -55 ) THEN C ANTI-OMEGA(+) IF ( charge(J) .EQ. 1 .AND. iso3(J) .EQ. 0 ) NTYPE = 32 ELSE C UNKNOWN PARTICLE WRITE(MONIOU,*) 'URQSTR: UNKNOWN PARTICLE ITYP,CHARGE,ISO3=', & ityp(J),charge(J),iso3(J) ENDIF C PRINT TABLE OF SECONDARY PARTICLES IF ( IUDEBUG .GT. 0 ) WRITE(MDEBUG,1010) & J,NTYPE,p0(J),px(J),py(J),pz(J) 1010 FORMAT(1X,I4,I4,(1P,E12.4),0P,3(1X,F10.5)) C FILL DATA IN SECPAR SECPAR(0) = DBLE(NTYPE) C GAMMA FACTOR IF ( PAMA(NTYPE) .EQ. 0.D0 ) THEN SECPAR(1) = p0(J) ELSE SECPAR(1) = p0(J) / PAMA(NTYPE) C CALCULATE ELASTICITY C PROJECTILE MUST HAVE UNDERGONE INELASTIC INTERACTION IF ( ctag .GT. 0 .AND. ctag .GT. NElColl ) THEN IF ( SECPAR(1)*PAMA(NTYPE) .GT. EMAX ) THEN EMAX = SECPAR(1)*PAMA(NTYPE) C CALCULATE ELASTICITY FROM MOST ENERGETIC PARTICLE (LEADER) ELASTI = EMAX / ELABU ENDIF ENDIF MSMM = MSMM + 1 ENDIF C CALCULATE EMISSION ANGLES PTSQ = DBLE(px(J)**2 + py(J)**2) PLSQ = DBLE(pz(J)**2) IF ( PLSQ+PTSQ .LE. 0.D0 ) GOTO 1001 PTOT = SQRT( PLSQ + PTSQ ) COSTET = DBLE(pz(J)) / PTOT COSTET = MAX( -1.D0, MIN( 1.D0, COSTET ) ) IF ( ityp(j) .EQ. 1 ) THEN C CHECK NUCLEON PARTICLE FOR TARGET SPECTATOR IF ( PLSQ+PTSQ .LT. FERMTH**2 ) GOTO 1001 C REJECT PARTICLE GOING BACKWARD FROM COLLISION (TARGET SPECTATORS) IF ( COSTET .LT. 0.D0 ) GOTO 1001 ENDIF C INCREMENT TOTAL ENERGY SUM AND MULTIPLICITY COUNTER CPHIU = DBLE(px(J)) / PTOT SPHIU = DBLE(py(J)) / PTOT #if __INTTEST__ SECPAR(17) = SQRT( PTSQ ) C IF ( COSTET .EQ. 0.D0 ) COSTET = 1.D-4 #endif IF ( PAMA(NTYPE) .EQ. 0.D0 ) THEN ETOT = ETOT + SECPAR(1) ELSE ETOT = ETOT + SECPAR(1)*PAMA(NTYPE) C INCREMENT COUNTER FOR ENERGY-MULTIPLICITY MATRIX ONLY FOR C INELASTIC EVENTS IF ( ctag .GT. 0 .AND. ctag .GT. NElColl ) THEN MSMM = MSMM + 1 ENDIF ENDIF C ADD ANGLE TO DIRECTION OF INCOMING PARTICLE CALL ADDANG4( CURPAR(2),CURPAR(3),CURPAR(4), COSTET,CPHIU,SPHIU, & SECPAR(2),SECPAR(3),SECPAR(4) ) C STORE ONLY PARTICLES ABOVE ANGULAR CUT TO CORSIKA STACK #if __UPWARD__ IF ( SECPAR(2) .GE. -1.D0 ) THEN #else IF ( SECPAR(2) .GT. C(29) ) THEN #endif #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER PARTICLE DO IK = 0, 8 SECPAR(17+IK) = SECPAR(IK) ENDDO #if __THIN__ SECPAR(26) = SECPAR(13) #endif #endif CALL TSTACK ELSE C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT (ANGULAR CUT) IF ( LLONGI ) THEN IF ( NTYPE .EQ. 1 ) THEN #if __THIN__ DLONG(LHEIGH,11) = DLONG(LHEIGH,11) +SECPAR(1)*CURPAR(13) ELSEIF ( NTYPE .EQ. 2 ) THEN DLONG(LHEIGH,13) = DLONG(LHEIGH,13) * + (SECPAR(1)+1.D0)*PAMA(2)*CURPAR(13) ELSEIF ( NTYPE .EQ. 3 ) THEN DLONG(LHEIGH,13) = DLONG(LHEIGH,13) * + (SECPAR(1)-1.D0)*PAMA(2)*CURPAR(13) ELSEIF ( NTYPE .EQ. 5 .OR. NTYPE .EQ. 6 ) THEN DLONG(LHEIGH,15) = DLONG(LHEIGH,15) * + SECPAR(1)*PAMA(5)*CURPAR(13) ELSEIF ( NTYPE .GE. 7 ) THEN IF ( NTYPE .EQ. 8 .OR. NTYPE .EQ. 9 .OR. * NTYPE .EQ. 11 .OR. NTYPE .EQ. 12 ) THEN FAC1 = 0.25D0 FAC2 = 0.75D0 ELSEIF ( NTYPE .EQ. 10 .OR. NTYPE .EQ. 16 ) THEN FAC1 = 0.5D0 FAC2 = 0.5D0 ELSE FAC1 = 1.D0 FAC2 = 0.D0 ENDIF C ADD TO THE HADRON ENERGY DEPOSIT DLONG(LHEIGH,17) = DLONG(LHEIGH,17) * +( SECPAR(1)*PAMA(NTYPE)-RESTMS(NTYPE) )*CURPAR(13)*FAC1 C ADD TO THE NEUTRINO DEPOSIT DLONG(LHEIGH,18) = DLONG(LHEIGH,18) * +( SECPAR(1)*PAMA(NTYPE)-RESTMS(NTYPE) )*CURPAR(13)*FAC2 #else DLONG(LHEIGH,11) = DLONG(LHEIGH,11) + SECPAR(1) ELSEIF ( NTYPE .EQ. 2 ) THEN DLONG(LHEIGH,13) = DLONG(LHEIGH,13) * + (SECPAR(1)+1.D0)*PAMA(2) ELSEIF ( NTYPE .EQ. 3 ) THEN DLONG(LHEIGH,13) = DLONG(LHEIGH,13) * + (SECPAR(1)-1.D0)*PAMA(2) ELSEIF ( NTYPE .EQ. 5 .OR. NTYPE .EQ. 6 ) THEN DLONG(LHEIGH,15) = DLONG(LHEIGH,15) + SECPAR(1)*PAMA(5) ELSEIF ( NTYPE .GE. 7 ) THEN IF ( NTYPE .EQ. 8 .OR. NTYPE .EQ. 9 .OR. * NTYPE .EQ. 11 .OR. NTYPE .EQ. 12 ) THEN FAC1 = 0.25D0 FAC2 = 0.75D0 ELSEIF ( NTYPE .EQ. 10 .OR. NTYPE .EQ. 16 ) THEN FAC1 = 0.5D0 FAC2 = 0.5D0 ELSE FAC1 = 1.D0 FAC2 = 0.D0 ENDIF C ADD TO THE HADRON ENERGY DEPOSIT DLONG(LHEIGH,17) = DLONG(LHEIGH,17) * + ( SECPAR(1)*PAMA(NTYPE)-RESTMS(NTYPE) )*FAC1 C ADD TO THE NEUTRINO DEPOSIT DLONG(LHEIGH,18) = DLONG(LHEIGH,18) * + ( SECPAR(1)*PAMA(NTYPE)-RESTMS(NTYPE) )*FAC2 #endif ENDIF ENDIF #if __AUGERHIST__ THICKLOC = THICK( CURPAR(5) ) DO LL = 1, NOBSLV IF ( THICKLOC .GE. THCKOB(LL) .AND. * THICKLOC .LT. THCKOB(LL)+SAMPTH ) THEN C THICKH IS WITHIN 1 G/CM^2 BELOW OBSLEV(LL) C BRING THE ENERGY BELOW ANGULAR CUT TO THE HISTO OF LEVEL LL DO II = 0, 8 OUTPAR(II) = SECPAR(II) ENDDO OUTPAR( 9) = GEN OUTPAR(10) = ALEVEL OUTPAR(13) = CURPAR(13) IF ( NTYPE .EQ. 1 ) THEN EDEP = OUTPAR(1) * CURPAR(13) ELSEIF ( NTYPE .EQ. 2 .OR. NTYPE .EQ. 3 ) THEN OUTPAR(1) = OUTPAR(1) * PAMA(2) EDEP = ( OUTPAR(1) - RESTMS(NTYPE) ) * CURPAR(13) ENDIF C WE HAVE ANGULAR CUT CALL AUGERDEPFIL( EDEP,LL,1 ) ELSEIF ( THICKLOC .LT. THCKOB(LL) ) THEN GOTO 113 ENDIF ENDDO 113 CONTINUE #endif ENDIF IF ( FIRSTI ) THEN C COUNTERS FOR FIRST INTERACTION IF ( SECPAR(0).EQ. 7.D0 .OR. SECPAR(0).EQ. 8.D0 * .OR. SECPAR(0).EQ. 9.D0 ) THEN IFINPI = IFINPI + 1 ELSEIF ( SECPAR(0).EQ.13.D0 .OR. SECPAR(0).EQ.14.D0 * .OR. SECPAR(0).EQ.15.D0 .OR. SECPAR(0).EQ.25.D0 ) THEN IFINNU = IFINNU + 1 ELSEIF ( SECPAR(0).EQ.10.D0 .OR. SECPAR(0).EQ.11.D0 * .OR. SECPAR(0).EQ.12.D0 .OR. SECPAR(0).EQ.16.D0 ) THEN IFINKA = IFINKA + 1 ELSEIF ( SECPAR(0).EQ.17.D0 ) THEN IFINET = IFINET + 1 ELSEIF ((SECPAR(0).GE.18.D0 .AND. SECPAR(0).LE.24.D0) * .OR. (SECPAR(0).GE.26.D0 .AND. SECPAR(0).LE.32.D0)) THEN IFINHY = IFINHY + 1 ELSEIF ( SECPAR(0).GE.51.D0 .AND. SECPAR(0).LE.53.D0 ) THEN IFINRHO = IFINRHO + 1 ELSE IFINOT = IFINOT + 1 ENDIF ENDIF C END OF PARTICLE LOOP 1001 CONTINUE C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if __INTTEST__ CTAG2 = ctag NELCOLL2 = NElColl #endif C PROJECTILE MUST HAVE INTERACTION AND NOT ONLY ELASTC COLLISIONS C FLAGS FOR NO INTERACTION AND ELASTIC SCATTERING (SEE coms.f) IF ( ctag .GT. 0 .AND. ctag .GT. NElColl ) THEN C FILL ELASTICITY IN MATRICES MEL = MIN ( 1.D0+10.D0* MAX( 0.D0, ELASTI ) , 11.D0 ) MEN = MIN ( 4.D0+ 3.D0*LOG10(MAX( .1D0, EKINL )), 40.D0 ) #if __THIN__ IELDPM(MEN,MEL) = IELDPM(MEN,MEL) + NINT( CURPAR(13) ) IELDPA(MEN,MEL) = IELDPA(MEN,MEL) + NINT( CURPAR(13) ) IF ( ELASTI .LT. 1.D0 ) THEN ELMEAN(MEN) = ELMEAN(MEN) + ELASTI * CURPAR(13) ELMEAA(MEN) = ELMEAA(MEN) + ELASTI * CURPAR(13) #else IELDPM(MEN,MEL) = IELDPM(MEN,MEL) + 1 IELDPA(MEN,MEL) = IELDPA(MEN,MEL) + 1 IF ( ELASTI .LT. 1.D0 ) THEN ELMEAN(MEN) = ELMEAN(MEN) + ELASTI ELMEAA(MEN) = ELMEAA(MEN) + ELASTI #endif ENDIF #if __COASTUSERLIB__ coastProjId = nint(curpar(0)) c warning TARGET PARTICLE ID FOR URQMD INTERACTIONS ??? coastTargId = 0 coastX = curpar(7) coastY = curpar(8) #if __CURVED__ coastZ = curpar(14) #else coastX = coastX - XOFF(NOBSLV) coastY = coastY - YOFF(NOBSLV) coastZ = curpar(5) #endif coastT = curpar(6) coastE = pama(coastProjId)*curpar(1) coastCX = sigair coastEl = elasti call interaction(coastX) #endif IF ( FIRSTI ) THEN SIG1I = SIGAIR ELAST = ELASTI C RANDOM GENERATOR STATUS (SEQUENCE L=1) AT END OF EVENT LL = 1 CALL RMMAQD( ISEED(1,LL),LL,'R' ) C SEED ISEED1I(1) = ISEED(1,LL) C NUMBER OF CALLS ISEED1I(2) = ISEED(2,LL) C NUMBER OF BILLIONS ISEED1I(3) = ISEED(3,LL) FIRSTI = .FALSE. ENDIF ENDIF IF ( IUDEBUG .GT. 0 ) WRITE(MDEBUG,*) 'URQSTR: ETOT=',ETOT RETURN END #endif #if __DPMJET__ *-- Author : D. HECK IKP KIT KARLSRUHE 15/06/2016 C======================================================================= SUBROUTINE DPJSIG( PLAB, ICZ ) C----------------------------------------------------------------------- C D(UAL) P(ARTON) J(ET MODEL 3) SIG(MA) C C CALCULATES INELASTIC CROSS-SECTION. C THIS SUBROUTINE IS CALLED FROM BOX2. C ARGUMENTS: C PLAB = LABORATORY MOMENTUM (IN GEV) C FOR NUCLEI: MOMENTUM/NUCLEON (IN GEV) C ICZ = HADRON TYPE: 1 = NUCLEON C 2 = PION C 3 = KAON C 4 = LAMBDA, SIGMA, XI, OMEGA STRANGE BARYON C >99 = NUCLEUS C----------------------------------------------------------------------- IMPLICIT NONE #define __PARPARINC__ #define __RUNPARINC__ #define __SIGMINC__ #include "corsika.h" DOUBLE PRECISION PLAB,PLABLG,SQPLLG, * SGFRCN(7),SGFRNO(7),SGPAIR(7), * SGPICN(7),SGPINO(7),SGPIAIR(7), * SGKCN(7),SGKNO(7),SGKAIR(7), * SGSBCN(7),SGSBNO(7),SGSBAIR(7), * SIGPP(7) * * ,SIGPIP(7),SIGKP(7),SIGSBP(7) INTEGER I,ICZ SAVE C THE FITTED VALUES OF THE COMPONETS OF AIR ARE ALREADY MULTIPLIED C WITH THE COMPOSITION FRACTION C THE FIT IS A PLOYNOMIAL OF 5TH DEGREE IN PLAB PLUS A TERM(7) C FOR 1/SQRT(PLAB) C FITTED VALUES FOR CROSS-SECTION FUNCTION BY D. HECK, JUNE 2016 C FOR PROTON NITROGEN DATA SGFRCN /248.68D0, -18.272D0, 4.4490D0, 0.42562D0, * -0.87355D-1, 0.36525D-2, -31.5494D0 / C FOR PROTON NITROGEN+OXYGEN DATA SGFRNO /325.29D0, -25.254D0, 6.4493D0, 0.42414D0, * -0.10291D0, 0.44275D-2, -41.285D0 / C FOR PROTON AIR DATA SGPAIR /343.66D0,-35.051D0, 9.9036D0, -0.16433D0, * -0.55482D-1, 0.29880D-2, -49.715D0 / C C FITTED VALUES FOR CROSS-SECTION FUNCTION BY D. HECK, JUNE 2016 C FOR PION NITROGEN DATA SGPICN /255.09D0, -78.5490, 28.763D0, -3.4284D0, * 0.18354D0, -0.34298D-2, -27.957D0 / C FOR PION NITROGEN+OXYGEN DATA SGPINO /321.35D0, -97.641D0, 36.524D0, -4.4068D0, * 0.24058D0, -0.46651D-2, -29.399D0 / C FOR PION AIR DATA SGPIAIR /313.63D0, -92.424D0, 36.012D0, -4.4144D0, * 0.24339D0 ,-0.47283D-2, -25.790D0 / C C FITTED VALUES FOR CROSS-SECTION FUNCTION BY D. HECK, JUNE 2016 C FOR KAON NITROGEN DATA SGKCN /147.07D0, -17.393D0, 9.3394D0, -0.54846D0, * -0.18385D-1, 0.19544D-2, -9.2561D0 / C FOR KAON NITROGEN+OXYGEN DATA SGKNO /191.53D0,-22.653D0, 12.197D0, -0.72242D0, * -0.23670D-1, 0.25491D-2, -11.659D0 / C FOR KAON AIR DATA SGKAIR /209.02D0, -31.699D0, 15.217D0, -1.2067D0, * 0.13272D-1, 0.14798D-2, -20.455D0 / C C FITTED VALUES FOR CROSS-SECTION FUNCTION BY D. HECK, JUNE 2016 C FOR STRANG BARYON NITROGEN DATA SGSBCN /192.78D0, -18.493D0, 10.645D0, -1.1081D0, * 0.53765D-1, -0.86981D-3, 12.078D0 / C FOR STRANG BARYON NITROGEN+OXYGEN DATA SGSBNO /250.17D0, -23.155D0, 13.401D0, -1.3423D0, * 0.59761D-1, -0.76369D-3, 16.387D0 / C FOR STRANG BARYON AIR DATA SGSBAIR /205.73D0, 6.3569D0, 3.0729D0, 0.44071D0, * -0.84425D-1, 0.36056D-2, 41.721D0 / C C FOR PROTON-PROTON (JUNE 2016) DATA SIGPP / 30.652D0, 1.3311D0, -1.0157D0, 0.45767D0, * -0.43820D-1, 0.14248D-2, -1.4376D0 / C FOR PION PROTON (JUNE 2016) * DATA SIGPIP /21.245D0, -3.7606D0, 0.92442D0, 0.22511D0, * * -0.34797D-1, 0.13996D-2, 3.9314D0 / C FOR KAON PROTON (JUNE 2016) * DATA SIGKP /15.753D0, -0.47603D-1, -0.29367D-1, 0.27351D0, * * -0.31721D-1, 0.11495D-2, -0.45344D0 / C FOR STRAGE BARYON PROTON (JUNE 2016) * DATA SIGSBP /15.385D0, 2.8087D0, -0.98146D-1, 0.18648D0, * * -0.17482D-1, 0.55590D-3, 9.7159D0 / C----------------------------------------------------------------------- IF (DEBUG) WRITE(MDEBUG,*) 'DPJSIG: PLAB=',SNGL(PLAB),' ICZ=',ICZ C DECADIC LOGARITH OF LABORATORY MOMENTUM PLABLG = LOG10( PLAB ) SQPLLG = SQRT( PLABLG ) IF ( ICZ .EQ. 1 ) THEN C FOR BARYON PROJECTILES SIGAIR = SGPAIR(1) + SGPAIR(2)*PLABLG + SGPAIR(3)*PLABLG**2 * + SGPAIR(4)*PLABLG**3 + SGPAIR(5)*PLABLG**4 * + SGPAIR(6)*PLABLG**5 + SGPAIR(7)/SQPLLG FRACTN = SGFRCN(1) + SGFRCN(2)*PLABLG + SGFRCN(3)*PLABLG**2 * + SGFRCN(4)*PLABLG**3 + SGFRCN(5)*PLABLG**4 * + SGFRCN(6)*PLABLG**5 + SGFRCN(7)/SQPLLG FRCTNO = SGFRNO(1) + SGFRNO(2)*PLABLG + SGFRNO(3)*PLABLG**2 * + SGFRNO(4)*PLABLG**3 + SGFRNO(5)*PLABLG**4 * + SGFRNO(6)*PLABLG**5 + SGFRNO(7)/SQPLLG SIGMA = 0.D0 ELSEIF ( ICZ .EQ. 2 ) THEN C FOR PION PROJECTILES SIGAIR = SGPIAIR(1) + SGPIAIR(2)*PLABLG + SGPIAIR(3)*PLABLG**2 * + SGPIAIR(4)*PLABLG**3 + SGPIAIR(5)*PLABLG**4 * + SGPIAIR(6)*PLABLG**5 + SGPIAIR(7)/SQPLLG FRACTN = SGPICN(1) + SGPICN(2)*PLABLG + SGPICN(3)*PLABLG**2 * + SGPICN(4)*PLABLG**3 + SGPICN(5)*PLABLG**4 * + SGPICN(6)*PLABLG**5 + SGPICN(7)/SQPLLG FRCTNO = SGPINO(1) + SGPINO(2)*PLABLG + SGPINO(3)*PLABLG**2 * + SGPINO(4)*PLABLG**3 + SGPINO(5)*PLABLG**4 * + SGPINO(6)*PLABLG**5 + SGPINO(7)/SQPLLG SIGMA = 0.D0 ELSEIF ( ICZ .EQ. 3 ) THEN C FOR KAON PROJECTILES SIGAIR = SGKAIR(1) + SGKAIR(2)*PLABLG + SGKAIR(3)*PLABLG**2 * + SGKAIR(4)*PLABLG**3 + SGKAIR(5)*PLABLG**4 * + SGKAIR(6)*PLABLG**5 + SGKAIR(7)/SQPLLG FRACTN = SGKCN(1) + SGKCN(2)*PLABLG + SGKCN(3)*PLABLG**2 * + SGKCN(4)*PLABLG**3 + SGKCN(5)*PLABLG**4 * + SGKCN(6)*PLABLG**5 + SGKCN(7)/SQPLLG FRCTNO = SGKNO(1) + SGKNO(2)*PLABLG + SGKNO(3)*PLABLG**2 * + SGKNO(4)*PLABLG**3 + SGKNO(5)*PLABLG**4 * + SGKNO(6)*PLABLG**5 + SGKNO(7)/SQPLLG SIGMA = 0.D0 ELSEIF ( ICZ .EQ. 4 ) THEN C FOR STRANGE BARYON PROJECTILES (S = -1) SIGAIR = SGSBAIR(1) + SGSBAIR(2)*PLABLG + SGSBAIR(3)*PLABLG**2 * + SGSBAIR(4)*PLABLG**3 + SGSBAIR(5)*PLABLG**4 * + SGSBAIR(6)*PLABLG**5 + SGSBAIR(7)/SQPLLG FRACTN = SGSBCN(1) + SGSBCN(2)*PLABLG + SGSBCN(3)*PLABLG**2 * + SGSBCN(4)*PLABLG**3 + SGSBCN(5)*PLABLG**4 * + SGSBCN(6)*PLABLG**5 + SGSBCN(7)/SQPLLG FRCTNO = SGSBNO(1) + SGSBNO(2)*PLABLG + SGSBNO(3)*PLABLG**2 * + SGSBNO(4)*PLABLG**3 + SGSBNO(5)*PLABLG**4 * + SGSBNO(6)*PLABLG**5 + SGSBNO(7)/SQPLLG SIGMA = 0.D0 ELSEIF ( ICZ .GE. 200 ) THEN C FOR NUCLEUS PROJECTILES DETERMINE ONLY NN CROSS-SECTION SIGMA = SIGPP(1) + SIGPP(2)*PLABLG + SIGPP(3)*PLABLG**2 * + SIGPP(4)*PLABLG**3 + SIGPP(5)*PLABLG**4 * + SIGPP(6)*PLABLG**5 + SIGPP(7)/SQPLLG SIGAIR = 0.D0 FRACTN = 0.D0 FRCTNO = 0.D0 ELSE #if __THIN__ WRITE(MONIOU,444) (CURPAR(I),I=0,9),CURPAR(13) 444 FORMAT(' DPJSIG: CURPAR=',1P,11E11.3) #else WRITE(MONIOU,444) (CURPAR(I),I=0,9) 444 FORMAT(' DPJSIG: CURPAR=',1P,10E11.3) #endif WRITE(MONIOU,*) 'DPJSIG: ILLEGAL PROJECTILE TYP =',ICZ STOP ENDIF IF (DEBUG) WRITE(MDEBUG,*) 'DPJSIG: SIGMA=',SNGL(SIGMA), * ' SIGAIR=',SNGL(SIGAIR) RETURN END *-- Author : D. HECK IKP KIT KARLSRUHE 01/04/2016 C======================================================================= BLOCK DATA DPMDAT C----------------------------------------------------------------------- C DPM(JET) DAT(A) C C SETS PARTICLE CODE TABLES FOR DPMJET-III (VERS. 2017.1) LINK C----------------------------------------------------------------------- IMPLICIT NONE #define __DPMLININC__ #include "corsika.h" INTEGER I C ICTABL CONVERTS CORSIKA PARTICLES INTO DPMJET-3 PARTICLES DATA (ICTABL(I), I=1,100)/ * 7, 4, 3, 0, 10, 11, 23, 13, 14, 12, ! 10 * 15, 16, 8, 1, 2, 19, 31, 17, 21, 22, ! 20 * 20, 97, 98, 109, 9, 18, 99, 100, 101, 102, ! 30 * 103, 115, 17*0, 35, ! 50 * 33, 32, 34, 7*0, ! 60 * 0, 0, 0, 0, 0, 5, 6, 135, 136, 0, ! 70 * 30*0/ !100 #if __CHARM__ C CHARMED PARTICLES DATA (ICTABL(I), I=101,200)/ * 10*0, !110 * 0, 0, 0, 0, 0, 116, 117, 118, 119, 120, !120 * 121, 122, 123, 124, 125, 126, 127, 128, 0, 130, !130 * 131, 132, 133, 134, 0, 0, 137, 138, 139, 140, !140 * 141, 142, 143, 144, 145, 0, 0, 0, 149, 150, !150 * 151, 152, 153, 154, 155, 156, 157, 0, 0, 0, !160 * 161, 162, 163, 0, 0, 0, 0, 0, 0, 0, !170 * 171, 172, 173, 0, 0, 25*0/ !200 #endif END *-- Author : D. HECK IKP KIT KARLSRUHE 25/05/2016 C======================================================================= SUBROUTINE DPMJIN C----------------------------------------------------------------------- C DPMJ(ET) IN(ITIALIZE) C C INITIALIZES DPMJET-III (VERS. 2017.1) C THIS SUBROUTINE IS CALLED FROM START. C----------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) #define __AIRINC__ #define __DPMJETINC__ #define __PARPARINC__ #define __PRIMSPINC__ #define __RUNPARINC__ #if __INTTEST__ #define __TSTINTINC__ #endif #include "corsika.h" LOGICAL LBEAMC, LPPERP, LPFRAC, LDPGSS, LDVGSS, LDXGSS, LDYGSS, & LBAXIS, LFLOOD, LVLCAR, LVLCYL, LVLSPH, LSOURC, LRDBEA, & LNUFIN COMMON /BEAMCM/ PBEAM , DPBEAM, PBMMAX, DIVBM , XSPOT , YSPOT , & XBEAM , YBEAM , ZBEAM , UBEAM , VBEAM , WBEAM , & UBMPOL, VBMPOL, WBMPOL, POLFRA, BEAWEI, & BMAXIS (3,3) , RFLOOD, RVLMIN, RVLMAX, DXVLMN, & DXVLMX, DYVLMN, DYVLMX, DZVLMN, DZVLMX, & IJBEAM, IJHION, NUCDBM, ISOURC, & LDPGSS, LDVGSS, LDXGSS, LDYGSS, LBEAMC, LPPERP, & LPFRAC, LBAXIS, LFLOOD, LVLCAR, LVLCYL, LVLSPH, & LSOURC, LRDBEA, LNUFIN PARAMETER (MXXMDF=710) COMMON /IOIOCM/ EKNION, ETNION, PLNION, EEXION, T12ION, & MATPRJ (MXXMDF), NMATPR, IPROA , IPROZ , IPROM c emulsion treatment PARAMETER (NCOMPX=100,NEB=8,NQB= 5,KSITEB=50) COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX), & NCOMPO,IEMUL PARAMETER (NMAXD=100) INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO, & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG, & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD c event history PARAMETER (NMXHKK=250000) COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) c event flag COMMON /DTEVNO/ NEVENT,ICASCA c Glauber formalism: flags and parameters for statistics LOGICAL LPROD CHARACTER*8 CGLB COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD c flags for input different options LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT, & IFUSION,IFLOW c pythia COMMON /PYDAT1/ MSTU(200),PARU(200),MSTJ(200),PARJ(200) DOUBLE PRECISION PARU,PARJ INTEGER MSTU,MSTJ COMMON /PYDAT3/ MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) c flags for diffractive interactions (DTUNUC 1.x) COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF c commons for input and output/debug output ... COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR c datadir for path to the data sets to be read in by dpmjet/phojet COMMON /DATADIR/ DATADIR CHARACTER*132 DATADIR DOUBLE PRECISION EPN,PPN INTEGER I,IDXSTA(40),KC,PYCOMP EXTERNAL PYCOMP SAVE DATA IDXSTA * K0s pi0 Lam aLam Sig+ aSig+ Sig- aSig- Xi0 aXi0 & /310, 111, 3122,-3122, 3222,-3222, 3112,-3112, 3322,-3322, !10 * Xi- aXi- Om- Aom- D+ D- D0 aD0 Ds+ aDs+ & 3312,-3312, 3334,-3334, 411, -411, 421, -421, 431, -431, !20 * etac Lamc+ aLamc+ Sigc++ Sigc+ Sigc0aSigc++Asigc+aSigc0 Xic+ & 441, 4122, -4122, 4222, 4212, 4112, -4222,-4212,-4112, 4232, !30 * Xic0 aXic+ aXic0 Sig0 aSig0 & 4132, -4232, -4132, 3212,-3212, 5*0/ !40 C----------------------------------------------------------------------- IF ( DEBUG ) THEN WRITE(MDEBUG,*) 'DPMJIN: at beginning' C SET PRINT PARAMETERS (DEFAULT SETTING IN BLOCK DATA BLKD41) LPRI = LEVLDB IPEV = LEVLDB IPPA = LEVLDB IPCO = LEVLDB INIT = LEVLDB LOUT = MDEBUG MSTU(25) = 1 ! enable printing of pythia warnings DO I = 1,6 IOULEV(I) = LEVLDB ENDDO ELSE C OUTLEVEL LPRI = 0 IPEV = 0 IPPA = 0 IPCO = -2 INIT = 0 MSTU(12) = 12345 ! suppress pythia logo MSTU(25) = 0 ! suppress printing of pythia warnings LOUT = MONIOU ENDIF MSTU(22) = 50000 ! max. printing of pythia errors MSTU(26) = 10 ! max. printing of pythia warnings C SET PARTICLES WHICH SHOULD NOT DECAY IN THE JETSET-COMMON C PREVENT STRANGE PARTICLES FROM DECAY IN PYTHIA, C AS THESE DECAYS ARE HANDLED IN CORSIKA ROUTINE STRDEC DO I = 1,14 KC = PYCOMP(IDXSTA(I)) MDCY(KC,1) = 0 ! PREVENT PARTICLE FROM DECAY ENDDO DO I = 34,35 KC = PYCOMP(IDXSTA(I)) MDCY(KC,1) = 0 ! PREVENT PARTICLE FROM DECAY ENDDO #if __CHARM__ || __TAULEP__ #if __CHARM__ C PREVENT CHARMED PARTICLES FROM DECAY AT VERTEX DO I = 15, 33 KC = PYCOMP(IDXSTA(I)) MDCY(KC,1) = 0 ! PREVENT PARTICLE FROM DECAY ENDDO #else C LET CHARMED PARTICLES DECAY AT VERTEX DO I = 15, 33 KC = PYCOMP(IDXSTA(I)) MDCY(KC,1) = 1 ! PARTICLE DECAYS BY JETSET ENDDO #endif C KEEP TAU-LEPTON NOT DECAYING KC = PYCOMP(15) ! TAU- MDCY(KC,1) = 0 KC = PYCOMP(-15) ! TAU+ MDCY(KC,1) = 0 #else C LET CHARMED PARTICLES DECAY AT VERTEX DO I = 15, 33 KC = PYCOMP(IDXSTA(I)) MDCY(KC,1) = 1 ! PARTICLE DECAYS BY JETSET ENDDO C LET TAU-LEPTON DECAY (DEFAULT IN PYTHIA) KC = PYCOMP(15) ! TAU- DECAYS MDCY(KC,1) = 1 KC = PYCOMP(-15) ! TAU+ DECAYS MDCY(KC,1) = 1 #endif #if __INTTEST__ IF ( NDIF .EQ. 0 ) THEN C ALL EVENTS MIXED WRITE(MONIOU,*) * 'DPMJIN: NDIF = 0 DIFFRACTIVE AND NON-DIFFRACTIVE EVENTS MIXED' ISINGD = 1 IDOUBD = 1 ELSEIF ( NDIF .EQ. 1 ) THEN C ONLY NON-DIFFRACTIVE EVENTS WRITE(MONIOU,*) * 'DPMJIN: NDIF = 1 ONLY NON-SINGLE-DIFFRACTIVE EVENTS' ISINGD = 0 IDOUBD = 1 ELSEIF ( NDIF .EQ. 2 ) THEN C ONLY DIFFRACTIVE EVENTS WRITE(MONIOU,*) * 'DPMJIN: NDIF = 2 ONLY SINGLE-DIFFRACTIVE EVENTS' ISINGD = 2 IDOUBD = 0 ENDIF #else ISINGD = 1 IDOUBD = 1 #endif #if __INTTEST__ IF ( ITTAR .LE. 12 ) THEN C USE SPECIAL GLAUBER DATA TABLE FOR LIGHT TARGET C GLAUBER DATA SET CONTAINS TARGET 'EMULSION' WITH PROTON, 9bE, 12C CGLB = 'glaubint' NCOMPO = 3 NB = 12 IEMUMA(1) = 1 ! PROTON TARGET IEMUCH(1) = 1 EMUFRA(1) = 1.D0 IEMUMA(2) = 9 ! BERYLLIUM TARGET IEMUCH(2) = 4 EMUFRA(2) = 1.D0 IEMUMA(3) = 12 ! CARBON TARGET IEMUCH(3) = 6 EMUFRA(3) = 1.D0 ELSE C USE STANDARD GLAUBER DATA TABLE FOR AIR TARGET C GLAUBER DATA SET CONTAINS TARGET EMULSION WITH 14N, 16O, 40AR CGLB = 'glaubtar' NCOMPO = 3 NB = 40 IEMUMA(1) = 14 ! NITROGEWN ARGET IEMUCH(1) = 7 EMUFRA(1) = COMPOS(1) IEMUMA(2) = 16 ! OXYGEN TARGET IEMUCH(2) = 8 EMUFRA(2) = COMPOS(2) IEMUMA(3) = 40 ! ARGON TARGET IEMUCH(3) = 18 EMUFRA(3) = COMPOS(3) ENDIF #else CGLB = 'glaubtar' C GLAUBER DATA SET CONTAINS TARGET EMULSION WITH 14N, 16O, 40AR NCOMPO = 3 NB = 40 IEMUMA(1) = 14 ! NITROGEWN ARGET IEMUCH(1) = 7 EMUFRA(1) = COMPOS(1) IEMUMA(2) = 16 ! OXYGEN TARGET IEMUCH(2) = 8 EMUFRA(2) = COMPOS(2) IEMUMA(3) = 40 ! ARGON TARGET IEMUCH(3) = 18 EMUFRA(3) = COMPOS(3) #endif C SET DATA DIRECTORY DATADIR(1:132) = DATDIR(1:132) C FLAGS FOR SPECIAL SETTINGS NEEDED TU RUN DPMJET-III AS EVENT C GENERATOR IN CORSIKA ITRSPT = 1 IEMUL = 0 IFUSION = 1 ! ENABLE FUSION IN NUCLEUS-NUCLEUS COLLISIONS NINP = -1 ! becomes NCASES, bypass for -1 to avoid ! reading DPMJET-III input cards for FLUKA EPN = ULIMIT ! MAX. ENERGY WE EXPECT FOR THE SHOWER NPMASS = 1 NPCHAR = 1 NTMASS = 14 NTCHAR = 7 c IDP = ?? ! is set in DT_INIT C INITIALIZATION OF DPMJET-III IGLAU = 0 ! dummy argument, will be set in first call in DT_INIT IF ( DEBUG ) WRITE(MDEBUG,*) 'DPMJIN: BEFORE DT_INIT CALL' CALL DT_INIT(NINP,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,IGLAU) IF ( DEBUG ) WRITE(MDEBUG,*) 'DPMJIN: AFTER DT_INIT CALL' CALL DT_STATIS(1) NEVENT = 0 cdh set debug flags * ideb(25) = 21 ! debug flag for PHO_HADRIN * ideb(37) = 5 ! debug flag for PHO_PDF * ideb(38) = 5 ! debug flag for PHO_HARWGX c ideb(64) = 25 ! debug flag for PHO_HARWGI c ideb(79) = 20 ! debug flag for PHO_HARISR * ideb(87) = 20 ! debug flag for PHO_SETPAR * ideb(90) = 11 ! debug flag for PHO_SETPCOMB RETURN END *-- Author : D. HECK IKP KIT KARLSRUHE 11/04/2016 C======================================================================= SUBROUTINE DPMJLK C----------------------------------------------------------------------- C DPMJ(ET) L(IN)K C C LINKING SUBROUT. TO DPMJET-III (VERS. 2017.1) C THIS SUBROUTINE IS CALLED FROM SDPM C----------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) #define __DPMDBGINC__ #define __DPMJETINC__ #define __DPMLININC__ #define __INTERINC__ #define __PAMINC__ #define __PARPARINC__ #define __PARPAEINC__ #define __RANDPAINC__ #define __RESTINC__ #define __RUNPARINC__ #if __INTTEST__ #define __TSTINTINC__ #endif #include "corsika.h" PARAMETER (MXFFBK = 6) PARAMETER (MXZFBK = 10) PARAMETER (MXNFBK = 12) PARAMETER (MXAFBK = 16) PARAMETER (MXASST = 25) PARAMETER (NXAFBK = MXAFBK + 1) PARAMETER (NXZFBK = MXZFBK + MXFFBK / 3 + MXASST - NXAFBK) PARAMETER (NXNFBK = MXNFBK + MXFFBK / 3 + MXASST - NXAFBK) PARAMETER (MXPSST = 700) PARAMETER (MXPPFB = 42000) PARAMETER (MXPSFB = 43000) PARAMETER (IBFRBK = 73) PARAMETER (JPWFBX = 4) c flavors of partons (DTUNUC 1.x) PARAMETER (MAXNCL = 260, & MAXVQU = MAXNCL, & MAXSQU = 20*MAXVQU, & MAXINT = MAXVQU+MAXSQU) c emulsion treatment PARAMETER (NCOMPX=100,NEB=8,NQB= 5,KSITEB=50) c Glauber formalism: cross sections COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2, & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX), & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX), & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX), & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX), & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX), & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX), & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX), & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX), & BSLOPE,NEBINI,NQBINI c particle properties (BAMJET index convention) CHARACTER*8 ANAME COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210), & IICH(210),IIBAR(210),K1(210),K2(210) COMMON /DTFLKA/ LINP,LOUT,LDAT, LPRI COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR COMMON / DBGPRE / LDBGPR LOGICAL LDBGPR c INTEGER NMAXD PARAMETER (NMAXD=100) INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO, & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG, & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD c nucleon-nucleon event-generator CHARACTER*8 CMODEL LOGICAL LPHOIN COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN LOGICAL LFRMBK, LNCMSS COMMON /FRBKCM/ AMUFBK, EEXFBK(MXPSST), AMFRBK(MXPSST), & WEIFBK(MXPSST) ,GAMFBK(MXPSST), EXFRBK(MXPSFB), & SDMFBK(MXPSFB), COUFBK(MXPSFB), CENFBK(MXPSFB), & EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK, FRBKLS, & IFRBKN(MXPSST), IFRBKZ(MXPSST), IFBKSP(MXPSST), & IFBKPR(MXPSST), IFBKST(MXPSST), IFBKLV(MXPSST), & IPSIND(0:NXNFBK,0:NXZFBK,2), JPSIND(0:MXASST), & IFBIND(0:NXNFBK,0:NXZFBK,2), JFBIND(0:NXAFBK), & IFBCHA(9,MXPSFB), IPOSST,IPOSFB,IFBSTF, IFBPSF, & IFBPSI, IFBFRB, IFBCHN, IFBNC1, IFBNC2, NBUFBK, & LFRMBK, LNCMSS c Lorentz-parameters of the current interaction COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB, & UMO,PPCM,EPROJ,PPROJ c properties of interacting particles COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG LOGICAL LDIFFR,LINCTV,LEVPRT,LHEAVY,LDEEXG,LGDHPR,LPREEX, & LHLFIX,LPRFIX,LPARWV,LPOWER,LSNGCH,LSCHDF,LHADRI, & LNUCRI,LPEANU,LEVBME,LPHDRC,LATMSS,LISMRS,LCHDCY, & LCHDCR,LMLCCR,LRVKIN,LVP2XX,LV2XNW,LNWV2X,LEVFIN PARAMETER (NALLWP = 64) COMMON /PAREVT/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, RNSWTC, & LDIFFR(NALLWP), LPOWER, LINCTV, LEVPRT, LHEAVY, & LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV, & LSNGCH, LSCHDF, LHADRI, LNUCRI, LPEANU, LEVBME, & LPHDRC, LATMSS, LISMRS, LCHDCY, LCHDCR, LMLCCR, & LRVKIN, LVP2XX, LV2XNW, LNWV2X, LEVFIN c flags for particle decays COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20), & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20), & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0 COMMON /PYDAT1/ MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON /PYDAT3/ MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) c various options for treatment of partons (DTUNUC 1.x) c (chain recombination, Cronin,..) LOGICAL LCO2CR,LINTPT COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM, & LCO2CR,LINTPT c parameter for intranuclear cascade LOGICAL LPAULI COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI c Glauber formalism: flags and parameters for statistics LOGICAL LPROD CHARACTER*8 CGLB COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD c event flag COMMON /DTEVNO/ NEVENT,ICASCA c flags for input different options LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6), & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT, & IFUSION,IFLOW INTEGER I,IDXSTA(40),KC,PYCOMP INTEGER KKMAT INTEGER IREJ, IREJCT LOGICAL FIRST EXTERNAL PYCOMP SAVE DATA FIRST / .TRUE. / DATA IDXSTA * K0s pi0 Lam aLam Sig+ aSig+ Sig- aSig- Xi0 aXi0 & /310, 111, 3122,-3122, 3222,-3222, 3112,-3112, 3322,-3322, !10 * Xi- aXi- Om- aOm- D+ D- D0 aD0 Ds+ aDs+ & 3312,-3312, 3334,-3334, 411, -411, 421, -421, 431, -431, !20 * etac Lamc+ aLamc+ Sigc++ Sigc+ Sigc0aSigc++aSigc+aSigc0 Xic+ & 441, 4122, -4122, 4222, 4212, 4112, -4222,-4212,-4112, 4232, !30 * Xic0 aXic+ aXic0 Sig0 aSig0 & 4132, -4232, -4132, 3212,-3212, 5*0/ !40 C----------------------------------------------------------------------- IF ( DEBUG ) THEN WRITE(MDEBUG,*) 'DPMJLK: TAR=',TAR LPRI = LEVLDB LDBGPR = LEVLDB IPEV = LEVLDB IPPA = LEVLDB IPCO = LEVLDB INIT = LEVLDB ELSE LPRI = 0 LDBGPR = 0 IPEV = 0 IPPA = 0 IPCO = -2 INIT = 0 DO I = 1,6 IOULEV(I) = -1 ENDDO MSTU(25) = 0 ! suppress printing of pythia warnings ENDIF MSTU(22) = 50000 ! max. printing of pythia errors MSTU(26) = 10 ! max. printing of pythia warnings c IPI0 = 0 ! NO PI(0) DECAY IN DPMJET, IS SET BY DEFAULT IN DT_DEFAUL C PREVENT K0S, PI(0) AND STRANGE BARYONS FROM DECAY AT VERTEX DO I = 1, 14 KC = PYCOMP(IDXSTA(I)) MDCY(KC,1) = 0 ! PREVENT PARTICLE FROM DECAY ENDDO C PREVENT SIGMA(0) AND ANTI_SIGMA(0) FROM DECAY AT VERTEX DO I = 34, 35 KC = PYCOMP(IDXSTA(I)) MDCY(KC,1) = 0 ! PREVENT PARTICLE FROM DECAY ENDDO #if __CHARM__ C PREVENT CHARMED PARTICLES FROM DECAY AT VERTEX DO I = 15, 33 KC = PYCOMP(IDXSTA(I)) MDCY(KC,1) = 0 ! PREVENT PARTICLE FROM DECAY ENDDO #else C LET CHARMED PARTICLES DECAY AT VERTEX DO I = 15, 33 KC = PYCOMP(IDXSTA(I)) MDCY(KC,1) = 1 ! PARTICLE DECAYS BY JETSET ENDDO #endif C SET TARGET PARAMETERS FOR INTERACTION IF ( TAR .EQ. 14.D0 ) THEN IT = 14 ITZ = 7 ELSEIF ( TAR .EQ. 16.D0 ) THEN IT = 16 ITZ = 8 ELSEIF ( TAR .EQ. 40.D0 ) THEN IT = 40 ITZ = 18 #if __INTTEST__ ELSEIF (TAR .EQ. 1.D0 ) THEN C PROTON TARGET IT = 1 ITZ = 1 ELSEIF (TAR .EQ. 2.D0 ) THEN C NEUTRON TARGET WRITE(MONIOU,*) 'DPMJLK: NEUTRON TARGET NOT POSSIBLE' WRITE(MONIOU,*) ' TAKE INSTEAD PROTON TARGET' IT = 1 ITZ = 1 #endif ELSE WRITE(MONIOU,*)'DPMJLK: TAR=',TAR,' NOT POSSIBLE' STOP ENDIF C TARGET IS NUCLEUS COMPOSED FROM NUCLEONS (OR IS SINGLE NUCLEON) IJTARG = 1 IBTARG = 1 AMTAR = AAM(1) C WE HAVE 58 PROJECTILE TABLES FOR EACH ENERGY IF (DEBUG ) WRITE(MDEBUG,*) 'DPMJLK: AFTER TAGET SELECTION', * ' TAR=',TAR C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C ORDINARY HADRONIC PROJECTILE C PIONS, KAONS, NUCLEONS, ANTI-NUCLEONS, STRANGE (ANTI-)BARYONS IF ( ( ITYPE .GE. 7 .AND. ITYPE .LE. 34 ) ) THEN IF ( ITYPE .EQ. 10 .OR. ITYPE .EQ. 16 ) THEN ! K0L, K0S C TRANSFORM K(0)L/S TO K(0) OR ANTI-K(0) CALL RMMARD( RD,1,1 ) IF ( RD(1) .GE. 0.5D0 ) THEN IJPROJ = 24 ELSE IJPROJ = 25 ENDIF ELSE IJPROJ = ICTABL(ITYPE) ! CORSIKA -> DPMJET conversion table ENDIF C SET PROJECTILE PARAMETERS FOR INTERACTION IP = 1 IPZ = 1 IBPROJ = IIBAR(IJPROJ) ! baryon number IF ( IJPROJ .LE. 0 ) THEN WRITE(MONIOU,*) 'DPMJLK: IJPROJ=',IJPROJ,' NOT VALID, STOP' STOP ENDIF EPN = GAMMA * PAMA(ITYPE) ELAB = EPN MKCRON = 1 ! ALLOW CRONIN'S MULTIPLE SCATTERING C NUCLEUS PROJECTILE ELSEIF ( ITYPE .GE. 200 ) THEN IP = INT( ITYPE/100 ) IPZ = MOD( ITYPE, 100 ) IJPROJ = 1 IBPROJ = 1 EPN = GAMMA * 0.5D0 * (PAMA(13)+PAMA(14)) ELAB = GAMMA * PAMA(ITYPE) MKCRON = 0 ! DISALLOW CRONIN'S MULTIPLE SCATTERING C GAMMA PROJECTILE ELSEIF ( ITYPE .EQ. 1 ) THEN IP = 1 IPZ = 1 IJPROJ = 23 ! pi(0) cdh IJPROJ = 7 ! gamma IBPROJ = IIBAR(IJPROJ) EPN = GAMMA ELAB = EPN MKCRON = 1 ! ALLOW CRONIN'S MULTIPLE SCATTERING ELSE WRITE(MONIOU,*) 'DPMJLK: ILLEGAL PROJECTILE: ITYPE=',ITYPE ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) 'DPMJLK: AFTER PROJECTILE SELECTION', * ' IJPROJ=',IJPROJ,' EPN=',EPN,' ELAB=',ELAB NPMASS = IP NPCHAR = IPZ NTMASS = IT NTCHAR = ITZ IDP = IJPROJ IDT = IJTARG PPN = 0.D0 CMENER = 0.D0 C EVAPORATION MODULES NOT AVAILABLE WITH THIS VERSION LEVPRT = .FALSE. LDEEXG = .FALSE. LHEAVY = .FALSE. LFRMBK = .FALSE. IFISS = 0 IEVFSS = 0 C FORCE USE OF PHOJET FOR g-A c IF ((IDP.EQ.7).AND.(MCGENE.NE.3)) MCGENE = 2 C INITIALIZATION OF NUCLEON-NUCLEON EVENT GENERATOR c IF (MCGENE.EQ.2) THEN c CALL DT_PHOINI c ENDIF C NO STATISTICAL INFO NEEDED IN SHOWER SIMULATION ICASCA = 1 C STORE ENERGY FOR ELASTICITY CALCULATION E000 = ELAB EPROJ = EPN C PARAMETERS FOR GETTING CORRECT INTERPOLATION OF GLAUBER TABLES KKMAT = -2 IOGLB = 100 NEVENT = NEVENT + 1 C NOW THE REAL WORK STARTS C ENTRY POINT FOR REJECT IREJCT = 0 200 CONTINUE IF ( DEBUG ) THEN C RANDOM GENERATOR STATUS (SEQUENCE L=1) AT BEGINNING OF EVENT LL = 1 CALL RMMAQD( ISEED(1,LL),LL,'R' ) C SEED IRAND(1) = ISEED(1,LL) C NUMBER OF CALLS IRAND(2) = ISEED(2,LL) C NUMBER OF BILLIONS IRAND(3) = ISEED(3,LL) WRITE(MDEBUG,159) (IRAND(J),J=1,3) 159 FORMAT(' DPMJLK: RANDOM NUMBER GENERATOR AT BEGIN OF EVENT:', * /,(' SEQUENCE = 1 SEED =',I9 ,' CALLS =',I9, * ' BILLIONS =',I9)) WRITE(MDEBUG,*) * 'DPMJLK: NOW KKINC IS CALLED WITH NPMASS=',NPMASS, * ' NTMASS=',NTMASS,' KKMAT=',KKMAT,' IOGLB=',IOGLB ENDIF C CALL DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,KKMAT,IREJ) C IF ( IREJ .NE. 0 ) THEN IREJCT = IREJCT + 1 IF ( IREJCT .GT. 100 ) THEN WRITE(MONIOU,*) 'DPMJLK: MORE THAN 100 REJECTS, STOP' STOP ENDIF GOTO 200 ENDIF C STORE SECONDARY PARTICLES TO STACK CALL DPMJST RETURN END *-- Author : D. HECK IKP KIT KARLSRUHE 12/04/2016 C======================================================================= SUBROUTINE DPMJST C----------------------------------------------------------------------- C DPMJ(ET) ST(ORE) C C STORES SECONDARY PARTICLES OF DPMJET-III (VERS. 2017.1) INTO CORSIKA C THIS SUBROUTINE IS CALLED FROM DPMJLK C----------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) #define __CONSTAINC__ #define __DPMDBGINC__ #define __DPMFLGINC__ #define __DPMLININC__ #define __ELADPMINC__ #define __ELASTYINC__ #define __INTERINC__ #define __ISTAINC__ #define __LONGIINC__ #define __MULTINC__ #define __PAMINC__ #define __PARPARINC__ #define __PARPAEINC__ #define __RANDPAINC__ #define __RESTINC__ #define __RUNPARINC__ #define __SIGMINC__ #if __AUGERHIST__ || __EHISTORY__ #define __GENERINC__ #endif #if __AUGERHIST__ || __COASTUSERLIB__ #define __OBSPARINC__ #endif #if __INTTEST__ #define __TSTINTINC__ #endif #include "corsika.h" c event history PARAMETER (NMXHKK= 250000) COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK), & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK), & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK) c extended event history COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK), & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10), & IHIST(2,NMXHKK) c properties of interacting particles COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG DOUBLE PRECISION EA,ELASTI,EMAX,ETOT,FAC1,FAC2 DOUBLE PRECISION PFRX(60),PFRY(60),PL2,PTM,PTOT,PT2,PT3, & COSTET,CPHIV,SPHIV INTEGER ITYP(60),JFIN INTEGER IPROJS,ITARGS,J,NPTLS,INEW,KNEW,KODCRS INTEGER NZNEW,NNNEW,MEL,MEN #if __EHISTORY__ INTEGER IK,IPP #endif #if __AUGERHIST__ DOUBLE PRECISION EDEP,THICKLOC,THICK INTEGER II,LL EXTERNAL THICK #endif #if __COASTUSERLIB__ c definition of the COAST crs::CInteraction class COMMON/coastInteraction/ coastX, coastY, coastZ, & coastE, coastCX, coastEl, coastProjId, & coastTargId, coastT double precision coastX, coastY, coastZ double precision coastE, coastCX, coastEl double precision coastT integer coastProjId, coastTargId #endif SAVE C----------------------------------------------------------------------- IF ( DEBUG ) THEN WRITE(MDEBUG,*) 'DPMJST:',NHKK,' ENTRIES' DO I = 1, NHKK WRITE(6,1010) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),JMOHKK + (2,I), JDAHKK(1,I),JDAHKK(2,I),(PHKK(KHKK,I),KHKK=1,5), + (VHKK(KHKK,I),KHKK=1,4) 1010 FORMAT (I6,I4,5I6,9(1P,E10.2)) ENDDO ENDIF C RESET COUNTERS IPROJS = 0 ITARGS = 0 #if __INTTEST__ IWOUNT = 0 IWOUNP = 0 #endif NPTLS = 0 INEW = 0 EMAX = 0.D0 ETOT = 0.D0 #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME GRANDMOTHER PARTICLE DO IK = 0, 6 SECPAR(28+IK) = CURPAR(IK) ENDDO C STORE GENERATION COUNTER OF GRANDMOTHER SECPAR(35) = GEN C STORE MASS PENETRATION BEFORE INTERACTION SECPAR(36) = CURPAR(9) #if __THIN__ SECPAR(37) = CURPAR(13) #endif #endif IF (DEBUG) WRITE(MDEBUG,*) 'DPMJST: NHKK=',NHKK,' NFRAGM=',NFRAGM C LOOP OVER ALL PARTICLES IN COMMON /HKKEVT/ DO 1001 J = 1, NHKK IF ( ISTHKK(J) .EQ. 1 ) THEN C ORDINARY SECONDARY PARTICLE, KEEP IT NPTLS = NPTLS + 1 ELSEIF ( ISTHKK(J) .EQ. 11 ) THEN C PARTICLE IS WOUNDED PROJECTILE NUCLEON IWOUNP = IWOUNP + 1 KODCRS = 0 GOTO 1000 ELSEIF ( ISTHKK(J) .EQ. 12 ) THEN C PARTICLE IS WOUNDED TARGET NUCLEON IWOUNT = IWOUNT + 1 KODCRS = 0 GOTO 1000 ELSEIF ( ISTHKK(J) .EQ. 13 ) THEN C PARTICLE IS PROJECTILE SPECTATOR, KEEP IT IPROJS = IPROJS + 1 IF ( NFRAGM .EQ. 0 ) THEN C FOR TOTAL FRAGMENTATON PHKK(4,J) = GAMMA*PHKK(5,J) PHKK(1,J) = 0.D0 PHKK(2,J) = 0.D0 PHKK(3,J) = ( PHKK(4,J)+PHKK(5,J) )*( PHKK(4,J)-PHKK(5,J) ) ELSEIF ( NFRAGM .GE. 1 .AND. NFRAGM .LE. 4 ) THEN C FOR NON-FRAGMENTATION: FORM PROJECTILE RESIDUAL INEW = INEW + 100 IF ( IDHKK(J) .EQ. 2212 ) INEW = INEW+1 KODCRS = 0 GOTO 1000 ELSE KODCRS = 0 GOTO 1000 ENDIF ELSEIF ( ISTHKK(J) .EQ. 14 ) THEN C PARTICLE IS SPECTATOR TARGET NUCLEON ITARGS = ITARGS + 1 #if __INTTEST__ IF ( NFRAGM .LT. 5 ) THEN PHKK(1,J) = 0.D0 PHKK(2,J) = 0.D0 PHKK(3,J) = 1.D-7 PHKK(4,J) = PHKK(5,J) ELSE KODCRS = 0 GOTO 1000 ENDIF #else KODCRS = 0 GOTO 1000 #endif ELSEIF ( ISTHKK(J) .EQ. 16 ) THEN C PARTICLE IS BOUND IN TARGET NUCLEUS ITARGS = ITARGS + 1 #if __INTTEST__ IF ( NFRAGM .LT. 5 ) THEN PHKK(1,J) = 0.D0 PHKK(2,J) = 0.D0 PHKK(3,J) = 1.D-7 PHKK(4,J) = PHKK(5,J) ELSE KODCRS = 0 GOTO 1000 ENDIF #else KODCRS = 0 GOTO 1000 #endif ELSEIF ( ISTHKK(J) .EQ. 1001 ) THEN C PARTICLE IS REMAINDER OF PROJECTILE OR TARGET NUCLEUS IF ( NFRAGM .LT. 5 ) THEN KODCRS = 0 GOTO 1000 ELSE KODCRS = IDRES(J) * 100 + IDXRES(J) ENDIF ELSEIF ( ISTHKK(J) .EQ. -1 ) THEN C PARTICLE IS EVAPORATED FRAGMENT IF ( NFRAGM .LT. 5 ) THEN KODCRS = 0 GOTO 1000 ELSE IF (IDHKK(J) .EQ. 80000 ) THEN C PARTICLE IS FRAGMENT NUCLEUS IF ( NOBAM(J) .EQ. 1 ) THEN C PROJECTILE FRAGMENT IPROJS = IPROJS + IDRES(J) KODCRS = IDRES(J) * 100 + IDXRES(J) ELSEIF ( NOBAM(J) .EQ. 2 ) THEN C TARGET FRAGMENT ITARGS = ITARGS + IDRES(J) #if !__INTTEST__ C DISREGARD TARGET FRAGMENTS KODCRS = 0 GOTO 1000 #endif ENDIF ELSE IF ( IDHKK(J) .EQ. 2212 .OR. IDHKK(J) .EQ. 2112 ) THEN C EVAPORATED NUCLEON IF ( NOBAM(J) .EQ. 1 ) THEN IPROJS = IPROJS +1 ELSEIF ( NOBAM(J) .EQ. 2 ) THEN ITARGS = ITARGS + 1 ENDIF ELSE C EVAPORATED ORDINARY PARTICLE NPTLS = NPTLS + 1 ENDIF ENDIF ENDIF ELSE C PARTICLE HAS DECAYED OR IS INTERMEDIATE STATE KODCRS = 0 GOTO 1000 ENDIF C CONVERT DATA PARTICLE GROUP CODE TO CORSIKA CODE IF ( ABS(IDHKK(J)).GT.100 .AND. ABS(IDHKK(J)).LT.340 ) THEN C MESONS, ALSO WITH STRANGENESS C MESONS IF ( IDHKK(J) .EQ. 111 ) THEN ! PI(0) KODCRS = 7 ELSEIF ( IDHKK(J) .EQ. 211 ) THEN ! PI(+) KODCRS = 8 ELSEIF ( IDHKK(J) .EQ. -211 ) THEN ! PI(-) KODCRS = 9 ELSEIF ( IDHKK(J) .EQ. 221 ) THEN ! ETA KODCRS = 17 C STRANGE MESONS ELSEIF ( IDHKK(J) .EQ. 130 ) THEN ! K0L KODCRS = 10 ELSEIF ( IDHKK(J) .EQ. 321 ) THEN ! K(+) KODCRS = 11 ELSEIF ( IDHKK(J) .EQ. -321 ) THEN ! K(-) KODCRS = 12 ELSEIF ( IDHKK(J) .EQ. 310 ) THEN ! K0S KODCRS = 16 ELSEIF ( IDHKK(J) .EQ. 311 .OR. ! K(0) * IDHKK(J) .EQ. -311 ) THEN ! ANTI-K(0) CALL RMMARD( RD,1,1 ) IF ( RD(1) .GE. 0.5D0 ) THEN KODCRS = 10 ! K0L ELSE KODCRS = 16 ! K0S ENDIF ENDIF ELSEIF ( ABS(IDHKK(J)).GT.1000 .AND. ABS(IDHKK(J)).LT.3400 )THEN C BARYONS, ALSO WITH STRANGENESS C NUCLEAONS IF ( IDHKK(J) .EQ. 2112 ) THEN ! N KODCRS = 13 ELSEIF ( IDHKK(J) .EQ. 2212 ) THEN ! P KODCRS = 14 ELSEIF ( IDHKK(J) .EQ. -2212 ) THEN ! ANTI-P KODCRS = 15 ELSEIF ( IDHKK(J) .EQ. -2112 ) THEN ! ANTI-N KODCRS = 25 C STRANGE BARYONS ELSEIF ( IDHKK(J) .EQ. 3122 ) THEN ! LAMBDA KODCRS = 18 ELSEIF ( IDHKK(J) .EQ. 3222 ) THEN ! SIGMA(+) KODCRS = 19 ELSEIF ( IDHKK(J) .EQ. 3212 ) THEN ! SIGMA(0) KODCRS = 20 ELSEIF ( IDHKK(J) .EQ. 3112 ) THEN ! SIGMA(-) KODCRS = 21 ELSEIF ( IDHKK(J) .EQ. 3322 ) THEN ! XI(0) KODCRS = 22 ELSEIF ( IDHKK(J) .EQ. 3312 ) THEN ! XI(-) KODCRS = 23 ELSEIF ( IDHKK(J) .EQ. 3334 ) THEN ! OMEGA(-) KODCRS = 24 ELSEIF ( IDHKK(J) .EQ. -3122 ) THEN ! ANTI_LAMBDA KODCRS = 26 ELSEIF ( IDHKK(J) .EQ. -3222 ) THEN ! ANTI-SIGMA(-) KODCRS = 27 ELSEIF ( IDHKK(J) .EQ. -3212 ) THEN ! ANTI-SIGMA(0) KODCRS = 28 ELSEIF ( IDHKK(J) .EQ. -3112 ) THEN ! ANTI-SIGMA(+) KODCRS = 29 ELSEIF ( IDHKK(J) .EQ. -3322 ) THEN ! ANTI-XI(0) KODCRS = 30 ELSEIF ( IDHKK(J) .EQ. -3312 ) THEN ! ANTI-XI(+) KODCRS = 31 ELSEIF ( IDHKK(J) .EQ. -3334 ) THEN ! ANTI-OMEGA(+) KODCRS = 32 ENDIF ELSEIF ( ABS(IDHKK(J)) .LE. 22 )THEN C GAMMAS, LEPTONS AND NEUTRINOS IF ( IDHKK(J) .EQ. 22 ) THEN ! GAMMA KODCRS = 1 C LEPTONS ELSEIF ( IDHKK(J) .EQ. -11 ) THEN ! E(+) KODCRS = 2 ELSEIF ( IDHKK(J) .EQ. 11 ) THEN ! E(-) KODCRS = 3 ELSEIF ( IDHKK(J) .EQ. -13 ) THEN ! MU(+) KODCRS = 5 ELSEIF ( IDHKK(J) .EQ. 13 ) THEN ! MU(-) KODCRS = 6 #if __CHARM__ || __TAULEP__ C TAU LEPTONS ELSEIF ( IDHKK(J) .EQ. -15 ) THEN ! TAU(+) KODCRS = 131 ELSEIF ( IDHKK(J) .EQ. 15 ) THEN ! TAU(-) KODCRS = 132 #else C TAU LEPTONS CANNOT BE TREATED, TAKE INSTEAD MUONS ELSEIF ( IDHKK(J) .EQ. -15 ) THEN ! TAU(+) KODCRS = 5 ! BECOMES MU(+) ELSEIF ( IDHKK(J) .EQ. 15 ) THEN ! TAU(-) KODCRS = 6 ! BECOMES MU(-) #endif #if __NEUTRINO__ C NEUTRINOS ELSEIF ( IDHKK(J) .EQ. 12 ) THEN ! NU_E KODCRS = 66 ELSEIF ( IDHKK(J) .EQ. -12 ) THEN ! ANTI-NU_E KODCRS = 67 ELSEIF ( IDHKK(J) .EQ. 14 ) THEN ! NU_MU KODCRS = 68 ELSEIF ( IDHKK(J) .EQ. -14 ) THEN ! ANTI-NU_MU KODCRS = 69 C TAU NEUTRINOS #if __CHARM__ || __TAULEP__ ELSEIF ( IDHKK(J) .EQ. 16 ) THEN ! NU_TAU KODCRS = 133 ELSEIF ( IDHKK(J) .EQ. -16 ) THEN ! ANTI-NU_TAU KODCRS = 134 #else ELSEIF ( IDHKK(J) .EQ. 16 ) THEN ! NU_TAU KODCRS = 68 ! BECOMES NU_MU ELSEIF ( IDHKK(J) .EQ. -16 ) THEN ! ANTI-NU_TAU KODCRS = 69 ! BECOMES ANTI-NU_MU #endif #else C NEUTRINOS ARE SKIPPED ELSEIF ( IDHKK(J) .EQ. 12 ) THEN ! NU_E GOTO 999 ELSEIF ( IDHKK(J) .EQ. -12 ) THEN ! ANTI-NU_E GOTO 999 ELSEIF ( IDHKK(J) .EQ. 14 ) THEN ! NU_MU GOTO 999 ELSEIF ( IDHKK(J) .EQ. -14 ) THEN ! ANTI-NU_MU GOTO 999 C TAU NEUTRINOS ELSEIF ( IDHKK(J) .EQ. 16 ) THEN ! NU_TAU GOTO 999 ELSEIF ( IDHKK(J) .EQ. -16 ) THEN ! ANTI-NU_TAU GOTO 999 #endif ENDIF ELSEIF ( ABS(IDHKK(J)).GT.400 .AND. ABS(IDHKK(J)).LT.450 ) THEN C CHARMED MESONS #if __CHARM__ IF ( IDHKK(J) .EQ. 421 ) THEN ! D(0) KODCRS = 116 ELSEIF ( IDHKK(J) .EQ. 411 ) THEN ! D(+) KODCRS = 117 ELSEIF ( IDHKK(J) .EQ. -411 ) THEN ! D(-) KODCRS = 118 ELSEIF ( IDHKK(J) .EQ. -421 ) THEN ! ANTI-D(0) KODCRS = 119 C CHARMED MESONS WITH STRANGENESS ELSEIF ( IDHKK(J) .EQ. 431 ) THEN ! D_S(+) KODCRS = 120 ELSEIF ( IDHKK(J) .EQ. -431 ) THEN ! D_S(-) KODCRS = 121 C CHARMED ETA MESON ELSEIF ( IDHKK(J) .EQ. 441 .OR. ! ETA_C * IDHKK(J) .EQ. -441 ) THEN KODCRS = 122 C EXCITED CHARMED MESONS ELSEIF ( IDHKK(J) .EQ. 423 ) THEN ! D*(0) KODCRS = 123 ELSEIF ( IDHKK(J) .EQ. 413 ) THEN ! D*(+) KODCRS = 124 ELSEIF ( IDHKK(J) .EQ. -413 ) THEN ! D*(-) KODCRS = 125 ELSEIF ( IDHKK(J) .EQ. -423 ) THEN ! ANTI-D*(0) KODCRS = 126 ELSEIF ( IDHKK(J) .EQ. 433 ) THEN ! D_S*(+) KODCRS = 127 ELSEIF ( IDHKK(J) .EQ. -433 ) THEN ! D_S*(-) KODCRS = 128 ELSEIF ( IDHKK(J) .EQ. 443 .OR. ! J/PSI * IDHKK(J) .EQ. -443 ) THEN KODCRS = 130 #else C CHARMED MESONS CANNOT BE TREATED, TAKE INSTEAD STRANGE MESONS IF ( IDHKK(J) .EQ. 421 ) THEN ! D(0) KODCRS = 11 ! BECOMES K(+) ELSEIF ( IDHKK(J) .EQ. 411 .OR. ! D(+) * IDHKK(J) .EQ. -411 ) THEN ! D(-) CALL RMMARD( RD,1,1 ) IF ( RD(1) .GE. 0.5D0 ) THEN KODCRS = 10 ! BECOMES K0L ELSE KODCRD = 16 ! BECOMES KOS ENDIF ELSEIF ( IDHKK(J) .EQ. -421 ) THEN ! ANTI-D(0) KODCRS = 12 ! BECOMES K(-) C CHARMED MESONS WITH STRANGENESS ELSEIF ( IDHKK(J) .EQ. 431 .OR. ! D_S((+) * IDHKK(J) .EQ. -431 ) THEN ! ANTI-D_S(-) CALL RMMARD( RD,1,1 ) IF ( RD(1) .GE. 0.5D0 ) THEN KODCRS = 10 ! BECOMES K0L ELSE KODCRD = 16 ! BECOMES KOS ENDIF C CHARMED ETA MESON ELSEIF ( IDHKK(J) .EQ. 441 .OR. ! ETA_C * IDHKK(J) .EQ. -441 ) THEN KODCRS = 17 ! BECOMES ETA C EXCITED CHARMED MESONS ELSEIF ( IDHKK(J) .EQ. 423 ) THEN ! D*(0) KODCRS = 11 ! BECOMES K(+) ELSEIF ( IDHKK(J) .EQ. 413 .OR. ! D*(+) * IDHKK(J) .EQ. -413 .OR. ! ANTI-D*(-) * IDHKK(J) .EQ. 433 .OR. ! D_S*(+) * IDHKK(J) .EQ. -433 ) THEN ! ANTI D_S*(-) CALL RMMARD( RD,1,1 ) IF ( RD(1) .GE. 0.5D0 ) THEN KODCRS = 10 ! BECOMES K0L ELSE KODCRD = 16 ! BECOMES K0S ENDIF ELSEIF ( IDHKK(J) .EQ. -423 ) THEN ! ANTI-D*(0) KODCRS = 12 ! BECOMES K(-) ELSEIF ( IDHKK(J) .EQ. 443 .OR. ! J/PSI * IDHKK(J) .EQ. -443 ) THEN KODCRS = 17 ! BECOMES ETA #endif ENDIF ELSEIF ( ABS(IDHKK(J)).GT.4000 .AND. ABS(IDHKK(J)).LT.4500 )THEN C BARYONS WITH CHARM #if __CHARM__ IF ( IDHKK(J) .EQ. 4122 ) THEN ! LAMBDA_C(+) KODCRS = 137 ELSEIF ( IDHKK(J) .EQ. 4232 ) THEN ! XI_C(+) KODCRS = 138 ELSEIF ( IDHKK(J) .EQ. 4132 ) THEN ! XI_C(0) KODCRS = 139 ELSEIF ( IDHKK(J) .EQ. 4222 ) THEN ! SIGMA_C(++) KODCRS = 140 ELSEIF ( IDHKK(J) .EQ. 4212 ) THEN ! SIGMA_C(+) KODCRS = 141 ELSEIF ( IDHKK(J) .EQ. 4112 ) THEN ! SIGMA_C(0) KODCRS = 142 ELSEIF ( IDHKK(J) .EQ. 4322 ) THEN ! XI_C'(+) ' KODCRS = 143 ELSEIF ( IDHKK(J) .EQ. 4312 ) THEN ! XI_C'(0) ' KODCRS = 144 ELSEIF ( IDHKK(J) .EQ. 4332 ) THEN ! OMEGA_C(0) KODCRS = 145 ELSEIF ( IDHKK(J) .EQ. -4122 ) THEN ! ANTI-LAMBDA_C(-) KODCRS = 149 ELSEIF ( IDHKK(J) .EQ. -4232 ) THEN ! ANTI-XI_C(-) KODCRS = 150 ELSEIF ( IDHKK(J) .EQ. -4132 ) THEN ! ANTI-XI-C(0) KODCRS = 151 ELSEIF ( IDHKK(J) .EQ. -4222 ) THEN ! ANTI-SIGMA_C(--) KODCRS = 152 ELSEIF ( IDHKK(J) .EQ. -4212 ) THEN ! ANTI-SIGMA_C(-) KODCRS = 153 ELSEIF ( IDHKK(J) .EQ. -4112 ) THEN ! ANTI-SIGMA_C(0) KODCRS = 154 ELSEIF ( IDHKK(J) .EQ. -4322 ) THEN ! ANTI-XI_C'(-) ' KODCRS = 155 ELSEIF ( IDHKK(J) .EQ. -4312 ) THEN ! ANTI-XI_C'(0) ' KODCRS = 156 ELSEIF ( IDHKK(J) .EQ. -4332 ) THEN ! ANTI-OMEGA_C(0) KODCRS = 157 C EXCITED CHARMED BARYONS ELSEIF ( IDHKK(J) .EQ. 4224 ) THEN ! SIGMA_C*(++) KODCRS = 161 ELSEIF ( IDHKK(J) .EQ. 4214 ) THEN ! SIGMA_C*(+) KODCRS = 162 ELSEIF ( IDHKK(J) .EQ. 4114 ) THEN ! SIGMA_C*(0) KODCRS = 163 ELSEIF ( IDHKK(J) .EQ. -4224 ) THEN ! ANTI-SIGMA_C*(--) KODCRS = 171 ELSEIF ( IDHKK(J) .EQ. -4214 ) THEN ! ANTI-SIGMA_C*(-) KODCRS = 172 ELSEIF ( IDHKK(J) .EQ. -4114 ) THEN ! ANTI-SIGMA_C*(0) KODCRS = 173 C DOUBLE CHARMED BARYONS CANNOT BE TREATED, TAKE CHARMED STRANGE BARYS ELSEIF ( IDHKK(J) .EQ. 4422 ) THEN ! XI_CC(++) KODCRS = 143 ! BECOMES XI_C'(+) ' ELSEIF ( IDHKK(J) .EQ. 4412 ) THEN ! XI_CC(+) KODCRS = 144 ! BECOMES XI_C'(0) ' ELSEIF ( IDHKK(J) .EQ. 4432 ) THEN ! OMEGA_CC(+) KODCRS = 145 ! BECOMES OMEGA_C(0) ELSEIF ( IDHKK(J) .EQ. -4422 ) THEN ! ANTI-XI_CC(--) KODCRS = 150 ! BECOMES ANTI-XI_C(-) ELSEIF ( IDHKK(J) .EQ. -4412 ) THEN ! ANTI-XI_CC(-) KODCRS = 156 ! BECOMES ANTI-XI_C'(0) ' ELSEIF ( IDHKK(J) .EQ. -4432 ) THEN ! ANTI-OMEGA_CC(-) KODCRS = 157 ! BECOMES ANTI-OMEGA_C(0) C TRIPLE CHARMED BARYONS CANNOT BE TREATED, TAKE CHARMED STRANGE BARYS ELSEIF ( IDHKK(J) .EQ. 4444 ) THEN ! OMEGA_CCC(++) KODCRS = 145 ! BECOMES OMEGA_C(0) ELSEIF ( IDHKK(J) .EQ. -4444 ) THEN ! ANTI-OMEGA_CCC(--) KODCRS = 157 ! BECOMES ANTI-OMEGA_C(0) #else C CHARMED BARYONS CANNOT BE TREATED, TAKE INSTEAD STRANGE BARYONS IF ( IDHKK(J) .EQ. 4122 ) THEN ! LAMBDA_C(+) KODCRS = 18 ! BECOMES LAMBDA ELSEIF ( IDHKK(J) .EQ. 4232 ) THEN ! XI_C(+) KODCRS = 22 ! BECOMES XI(0) ELSEIF ( IDHKK(J) .EQ. 4132 ) THEN ! XI_C(0) KODCRS = 23 ! BECOMES XI(-) ELSEIF ( IDHKK(J) .EQ. 4222 ) THEN ! SIGMA_C(++) KODCRS = 19 ! BECOMES SIGMA(+) ELSEIF ( IDHKK(J) .EQ. 4212 ) THEN ! SIGMA_C(+) KODCRS = 20 ! BECOMES SIGMA(0) ELSEIF ( IDHKK(J) .EQ. 4112 ) THEN ! SIGMA_C(0) KODCRS = 21 ! BECOMES SIGMA(-) ELSEIF ( IDHKK(J) .EQ. 4322 ) THEN ! XI_C'(+) ' KODCRS = 22 ! BECOMES XI(0) ELSEIF ( IDHKK(J) .EQ. 4312 ) THEN ! XI_C'(0) ' KODCRS = 23 ! BECOMES XI(-) ELSEIF ( IDHKK(J) .EQ. 4332 ) THEN ! OMEGA_C(0) KODCRS = 24 ! BECOMES OMEGA(-) ELSEIF ( IDHKK(J) .EQ. -4122 ) THEN ! ANTI-LAMBDA_C(-) KODCRS = 26 ! BECOMES ANTI-LAMBDA ELSEIF ( IDHKK(J) .EQ. -4232 ) THEN ! ANTI-XI_C(-) KODCRS = 30 ! BECOMES ANTI-XI(0) ELSEIF ( IDHKK(J) .EQ. -4132 ) THEN ! ANTI-XI-C(0) KODCRS = 31 ! BECOMES ANTI-XI(+) ELSEIF ( IDHKK(J) .EQ. -4222 ) THEN ! ANTI-SIGMA_C(--) KODCRS = 27 ! BECOMES ANTI-SIGMA(-) ELSEIF ( IDHKK(J) .EQ. -4212 ) THEN ! ANTI-SIGMA_C(-) KODCRS = 28 ! BECOMES ANTI-SIGMA(0) ELSEIF ( IDHKK(J) .EQ. -4112 ) THEN ! ANTI-SIGMA_C(0) KODCRS = 29 ! BECOMES ANTI-SIGMA(+) ELSEIF ( IDHKK(J) .EQ. -4322 ) THEN ! ANTI-XI_C'(-) ' KODCRS = 30 ! BECOMES ANTI-XI(0) ELSEIF ( IDHKK(J) .EQ. -4312 ) THEN ! ANTI-XI_C'(0) ' KODCRS = 31 ! BECOMES ANTI-XI(+) ELSEIF ( IDHKK(J) .EQ. -4332 ) THEN ! ANTI-OMEGA_C(0) KODCRS = 32 ! BECOMES ANTI-OMEGA(+) C EXCITED CHARMED BARYONS CANNOT BE TREATED, TAKE STRANGE BARYONS ELSEIF ( IDHKK(J) .EQ. 4224 ) THEN ! SIGMA_C*(++) KODCRS = 19 ! BECOMES SIGMA(+) ELSEIF ( IDHKK(J) .EQ. 4214 ) THEN ! SIGMA_C*(+) KODCRS = 20 ! BECOMES SIGMA(0) ELSEIF ( IDHKK(J) .EQ. 4114 ) THEN ! SIGMA_C*(0) KODCRS = 21 ! BECOMES SIGMA(-) ELSEIF ( IDHKK(J) .EQ. -4224 ) THEN ! ANTI-SIGMA_C*(--) KODCRS = 27 ! BECOMES ANTI-SIGMA(-) ELSEIF ( IDHKK(J) .EQ. -4214 ) THEN ! ANTI-SIGMA_C*(-) KODCRS = 28 ! BECOMES ANTI-SIGMA(0) ELSEIF ( IDHKK(J) .EQ. -4114 ) THEN ! ANTI-SIGMA_C*(0) KODCRS = 29 ! BECOMES ANTI-SIGMA(+) C DOUBLE CHARMED BARYONS CANNOT BE TREATED, TAKE STRANGE BARYS ELSEIF ( IDHKK(J) .EQ. 4422 ) THEN ! XI_CC(++) KODCRS = 22 ! BECOMES XI(0) ELSEIF ( IDHKK(J) .EQ. 4412 ) THEN ! XI_CC(+) KODCRS = 23 ! BECOMES XI(-) ELSEIF ( IDHKK(J) .EQ. 4432 ) THEN ! OMEGA_CC(+) KODCRS = 24 ! BECOMES OMEGA(-) ELSEIF ( IDHKK(J) .EQ. -4422 ) THEN ! ANTI-XI_CC(--) KODCRS = 30 ! BECOMES ANTI-XI(0) ELSEIF ( IDHKK(J) .EQ. -4412 ) THEN ! ANTI-XI_CC(-) KODCRS = 31 ! BECOMES ANTI-XI(+) ELSEIF ( IDHKK(J) .EQ. -4432 ) THEN ! ANTI-OMEGA_CC(-) KODCRS = 32 ! BECOMES ANTI-OMEGA(+) C TRIPLE CHARMED BARYONS CANNOT BE TREATED, TAKE STRANGE BARYS ELSEIF ( IDHKK(J) .EQ. 4444 ) THEN ! OMEGA_CCC*(++) KODCRS = 24 ! BECOMES OMEGA(-) ELSEIF ( IDHKK(J) .EQ. -4444 ) THEN ! ANTI-OMEGA_CCC*(--) KODCRS = 32 ! BECOMES ANTI-OMEGA(+) #endif ENDIF C PROJECTILE FRAGMENT NUCLEUS ELSEIF ( IDHKK(J) .EQ. 80000 ) THEN KODCRS = IDRES(J) * 100 + IDXRES(J) ELSE WRITE(MONIOU,*) 'DPMJST: UNKNOWN PARTICLE CODE=',IDHKK(J) STOP ENDIF SECPAR(0) = KODCRS *100 CONTINUE IF ( PAMA(KODCRS) .GT. 0.D0 ) THEN C ORDINARY SECONDARY PARTICLES (WITH MASS) SECPAR(1) = PHKK(4,J)/PAMA(KODCRS) C DISREGARD PROJECTILE SPECTATORS FOR ELASTICITY IF ( ISTHKK(J) .EQ. 13 .OR. ISTHKK(J) .EQ. 15 ) GOTO 7 C DISREGARD EVAPORATED PARTICLES FOR ELASTICITY IF ( ISTHKK(J) .EQ. -1 ) GOTO 7 CC IF ( SECPAR(1) .GT. GAMMAX ) THEN CC GAMMAX = SECPAR(1) C CALCULATE ELASTICITY FROM ENERGY OF FASTEST PARTICLE (LEADER) CC ELASTI = GAMMAX * PAMA(KODCRS) / ELAB CC ENDIF IF ( SECPAR(1)*PAMA(KODCRS) .GT. EMAX ) THEN EMAX = SECPAR(1)*PAMA(KODCRS) C CALCULATE ELASTICITY FROM MOST ENERGETIC PARTICLE (LEADER) ELASTI = EMAX / E000 ENDIF ELSE C GAMMAS AND NEUTRINOS (WITHOUT MASS) SECPAR(1) = PHKK(4,J) ENDIF C COUNTER FOR ENERGY-MULTIPLICITY MATRIX MSMM = MSMM + 1 C DETERMINE ANGLES FROM LONGITUDINAL AND TRANSVERSAL MOMENTA 7 CONTINUE PT2 = PHKK(1,J)**2 + PHKK(2,J)**2 PL2 = PHKK(3,J)**2 IF ( PL2+PT2 .GT. 0.D0 ) THEN PTOT = SQRT( PL2 + PT2 ) COSTET = MAX( MIN( PHKK(3,J)/PTOT, 1.D0 ), -1.D0 ) CPHIV = MAX( MIN( PHKK(1,J)/PTOT, 1.D0 ), -1.D0 ) SPHIV = MAX( MIN( PHKK(2,J)/PTOT, 1.D0 ), -1.D0 ) ELSE PTOT = 0.D0 COSTET = 0.D0 CPHIV = 1.D0 SPHIV = 0.D0 ENDIF #if __INTTEST__ C IF ( COSTET .EQ. 0.D0 ) COSTET = 1.D-4 SECPAR(17) = SQRT( PT2 ) #endif ETOT = ETOT + PHKK(4,J) CALL ADDANG4( COSTHE,PHIX,PHIY, COSTET,CPHIV,SPHIV, * SECPAR(2),SECPAR(3),SECPAR(4) ) #if __UPWARD__ IF ( SECPAR(2) .GE. -1.D0 ) THEN #else IF ( SECPAR(2) .GT. C(29) ) THEN #endif IF ( NFRAGM .GE. 5 .AND. KODCRS .GT. 200 ) THEN #if __INTTEST__ C STORE RESIDUAL NUCLEUS AS SINGLE NUCLEONS WITH PT=0 NZNEW = MOD(KODCRS,100) NNNEW = KODCRS/100 - NZNEW SECPAR(2) = 1.D0 SECPAR(3) = 0.D0 SECPAR(4) = 0.D0 SECPAR(17) = 0.D0 IF ( NZNEW .GE. 1 ) THEN SECPAR(0) = 14.D0 DO JJ = 1, NZNEW CALL TSTACK ENDDO ENDIF IF ( NNNEW .GE. 1 ) THEN SECPAR(0) = 13.D0 DO JJ = 1, NNNEW CALL TSTACK ENDDO ENDIF #else IF ( INT( KODCRS/100 ) .EQ. 8 ) THEN C REMAINING NUCLEUS: MASS 8 CANNOT BE TREATED IN BOX2 IF ( MOD(KODCRS,100) .GE. 5 ) THEN C MASS 8: SPLIT OFF ONE PROTON SECPAR(0) = 14.D0 #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER PARTICLE DO IK = 0, 8 SECPAR(IK+17) = SECPAR(IK) ENDDO #if __THIN__ SECPAR(26) = SECPAR(13) #endif #endif CALL TSTACK KODCRS = KODCRS - 101 ELSEIF ( MOD(KODCRS,100) .LE. 3 ) THEN C MASS 8: SPLIT OFF ONE NEUTRON SECPAR(0) = 13.D0 #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER PARTICLE DO IK = 0, 8 SECPAR(IK+17) = SECPAR(IK) ENDDO #if __THIN__ SECPAR(26) = SECPAR(13) #endif #endif CALL TSTACK KODCRS = KODCRS - 100 ELSE C MASS 8: SPLIT OFF ONE ALPHA PARTICLE SECPAR(0) = 402.D0 #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER PARTICLE DO IK = 0, 8 SECPAR(IK+17) = SECPAR(IK) ENDDO #if __THIN__ SECPAR(26) = SECPAR(13) #endif #endif CALL TSTACK KODCRS = KODCRS - 402 ENDIF ELSEIF ( INT( KODCRS/100 ) .EQ. 5 ) THEN C REMAINING NUCLEUS: MASS 5 CANNOT BE TREATED IN BOX2 IF ( MOD(KODCRS,100) .GE. 3 ) THEN C MASS 5: SPLIT OFF ONE PROTON SECPAR(0) = 14.D0 #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER PARTICLE DO IK = 0, 8 SECPAR(IK+17) = SECPAR(IK) ENDDO #if __THIN__ SECPAR(26) = SECPAR(13) #endif #endif CALL TSTACK KODCRS = KODCRS - 101 ELSE C MASS 5: SPLIT OFF ONE NEUTRON SECPAR(0) = 13.D0 #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER PARTICLE DO IK = 0, 8 SECPAR(IK+17) = SECPAR(IK) ENDDO #if __THIN__ SECPAR(26) = SECPAR(13) #endif #endif CALL TSTACK KODCRS = KODCRS - 100 ENDIF ENDIF SECPAR(0) = KODCRS #endif ENDIF C IF WE HAVE HERE A MUON OR A NEUTRINO IT MUST COME FROM CHARM DECAY C INCREMENT GENERATION COUNTER BY 30 FOR MU(+-) AND NU FROM CHARM DECAY IF ( KODCRS .EQ. 5 .OR. KODCRS .EQ. 6 ) THEN SECPAR(9) = GEN + 30.D0 ELSEIF ( KODCRS .GE. 66 .AND. KODCRS .LE. 69 ) THEN SECPAR(9) = GEN + 30.D0 ELSE SECPAR(9) = GEN ENDIF C LIMIT GENERATION COUNTER TO 99 SECPAR(9) = MIN( SECPAR(9), 99.D0 ) #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER PARTICLE DO IK = 0, 8 SECPAR(IK+17) = SECPAR(IK) ENDDO #if __THIN__ SECPAR(26) = SECPAR(13) #endif C RECORD THE PARENT PARTICLES OF NEUTRINOS AND MUONS IN THE INTERNAL C DECAYS OF DPMJET-III (VERS. 2017.1) IF ( (KODCRS .EQ. 5 .OR. KODCRS .EQ. 6) .OR. * (KODCRS .GE. 66 .AND. KODCRS .LE. 69) ) THEN * IF ( DEBUG ) WRITE(MDEBUG,888) (SECPAR(IK+17), IK=0,8) *888 FORMAT(' DPMJST: PARENT1=',1P,9E11.3) C WE STORE AS PARENT PATICLE THE INTERMEDIATE PARTICLE WHICH C PRODUCES THE MUON OR NEUTRINO. IPP = JMOHKK(1,J) CALL PDGTOCRS( IDHKK(IPP), SECPAR(17) ) C TREAT MOTHER PARTICLES WITH MASS = ZERO C OR UNIDENTIFIED INTERMEDIATE STATES IF ( SECPAR(17) .EQ. 9999.D0 .OR. * PAMA(NINT(SECPAR(17))) .EQ. 0.D0 ) THEN SECPAR(18) = PHKK(4,IPP) ELSE SECPAR(18) = PHKK(4,IPP)/PAMA(NINT(SECPAR(17))) ENDIF PT2 = PHKK(1,IPP)**2 + PHKK(2,IPP)**2 PL2 = PHKK(3,IPP)**2 IF ( PL2+PT2 .GT. 0.D0 ) THEN PTOT = SQRT( PL2 + PT2 ) COSTET = MAX( MIN( PHKK(3,IPP)/PTOT, 1.D0 ), -1.D0 ) CPHIV = MAX( MIN( PHKK(1,IPP)/PTOT, 1.D0 ), -1.D0 ) SPHIV = MAX( MIN( PHKK(2,IPP)/PTOT, 1.D0 ), -1.D0 ) ELSE PTOT = 0.D0 COSTET = 0.D0 CPHIV = 1.D0 SPHIV = 0.D0 ENDIF CALL ADDANG4( COSTHE,PHIX,PHIY, COSTET,CPHIV,SPHIV, * SECPAR(2+17),SECPAR(3+17),SECPAR(4+17) ) * IF ( DEBUG ) WRITE(MDEBUG,889) (SECPAR(IK+17), IK=0,4) *889 FORMAT(' DPMJST: PARENT2=',1P,5E11.3) ENDIF #if __THIN__ SECPAR(26) = SECPAR(13) #endif #endif CALL TSTACK ELSE ! ANGULAR CUT IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT IF ( KODCRS .LE. 3 ) THEN #if __THIN__ DLONG(LHEIGH,13) = DLONG(LHEIGH,13) * + (PHKK(4,J) - RESTMS(KODCRS))* WEIGHT ELSEIF ( KODCRS .EQ. 5 .OR. KODCRS .EQ. 6 ) THEN DLONG(LHEIGH,15) = DLONG(LHEIGH,15) + PHKK(4,J) * WEIGHT #if __NEUTRINO__ ELSEIF ( ( KODCRS .GE. 66 .AND. KODCRS .LE. 69 ) .OR. * KODCRS .EQ. 133 .OR. KODCRS .EQ. 134 ) THEN DLONG(LHEIGH,18) = DLONG(LHEIGH,18) + PHKK(4,J) * WEIGHT #endif ELSEIF ( KODCRS .GE. 7 ) THEN IF ( KODCRS .EQ. 8 .OR. KODCRS .EQ. 9 .OR. * KODCRS .EQ. 11 .OR. KODCRS .EQ. 12 ) THEN FAC1 = 0.25D0 FAC2 = 0.75D0 ELSEIF ( KODCRS .EQ. 10 .OR. KODCRS .EQ. 16 ) THEN FAC1 = 0.5D0 FAC2 = 0.5D0 ELSE FAC1 = 1.D0 FAC2 = 0.D0 ENDIF C ADD TO THE HADRON ENERGY DEPOSIT DLONG(LHEIGH,17) = DLONG(LHEIGH,17) * + (PHKK(4,J) - RESTMS(KODCRS))* WEIGHT*FAC1 C ADD TO THE NEUTRINO DEPOSIT DLONG(LHEIGH,18) = DLONG(LHEIGH,18) * + (PHKK(4,J) - RESTMS(KODCRS))* WEIGHT*FAC2 #else DLONG(LHEIGH,13) = DLONG(LHEIGH,13) + PHKK(4,J) * - RESTMS(KODCRS) ELSEIF ( KODCRS .EQ. 5 .OR. KODCRS .EQ. 6 ) THEN DLONG(LHEIGH,15) = DLONG(LHEIGH,15) + PHKK(4,J) #if __NEUTRINO__ ELSEIF ( ( KODCRS .GE. 66 .AND. KODCRS .LE. 69 ) .OR. * KODCRS .EQ. 133 .OR. KODCRS .EQ. 134 ) THEN DLONG(LHEIGH,18) = DLONG(LHEIGH,18) + PHKK(4,J) #endif ELSEIF ( KODCRS .GE. 7 ) THEN IF ( KODCRS .EQ. 8 .OR. KODCRS .EQ. 9 .OR. * KODCRS .EQ. 11 .OR. KODCRS .EQ. 12 ) THEN FAC1 = 0.25D0 FAC2 = 0.75D0 ELSEIF ( KODCRS .EQ. 10 .OR. KODCRS .EQ. 16 ) THEN FAC1 = 0.5D0 FAC2 = 0.5D0 ELSE FAC1 = 1.D0 FAC2 = 0.D0 ENDIF C ADD TO THE HADRON ENERGY DEPOSIT DLONG(LHEIGH,17) = DLONG(LHEIGH,17) * + (PHKK(4,J) - RESTMS(KODCRS))*FAC1 C ADD TO THE NEUTRINO DEPOSIT DLONG(LHEIGH,18) = DLONG(LHEIGH,18) * + (PHKK(4,J) - RESTMS(KODCRS))*FAC2 #endif ENDIF ENDIF #if __AUGERHIST__ THICKLOC = THICK( H ) DO LL = 1, NOBSLV IF ( THICKLOC .GE. THCKOB(LL) .AND. * THICKLOC .LT. THCKOB(LL)+SAMPTH ) THEN C THICKH IS WITHIN 1 G/CM^2 BELOW OBSLEV(LL) C BRING THE ENERGY BELOW ANGULAR CUT TO THE HISTO OF LEVEL LL OUTPAR(0) = KODCRS IF ( KODCRS .EQ. 1 ) THEN OUTPAR(1) = PHKK(4,J) EDEP = OUTPAR(1) * WEIGHT ELSEIF ( KODCRS .EQ. 2 .OR. KODCRS .EQ. 3 ) THEN OUTPAR(1) = PHKK(4,J) EDEP = ( OUTPAR(1) - RESTMS(KODCRS) ) * WEIGHT ELSE OUTPAR(1) = PHKK(4,J) / PAMA(KODCRS) EDEP = ( PHKK(4,J) - RESTMS(KODCRS) ) * WEIGHT ENDIF DO II = 2, 8 OUTPAR(II) = SECPAR(II) ENDDO OUTPAR( 9) = GEN OUTPAR(10) = ALEVEL OUTPAR(13) = WEIGHT C WE HAVE ANGULAR CUT CALL AUGERDEPFIL( EDEP,LL,1 ) ELSEIF ( THICKLOC .LT. THCKOB(LL) ) THEN GOTO 111 ENDIF ENDDO 111 CONTINUE #endif ENDIF C COUNTERS FOR FIRST INTERACTION IF ( FIRSTI ) THEN IF ( KODCRS .EQ. 7 .OR. KODCRS .EQ. 8 * .OR. KODCRS .EQ. 9 ) THEN IFINPI = IFINPI + 1 ELSEIF ( KODCRS .EQ. 13 .OR. KODCRS .EQ. 14 * .OR. KODCRS .EQ. 15 .OR. KODCRS .EQ. 25 ) THEN IFINNU = IFINNU + 1 ELSEIF ( KODCRS .EQ. 10 .OR. KODCRS .EQ. 11 * .OR. KODCRS .EQ. 12 .OR. KODCRS .EQ. 16 ) THEN IFINKA = IFINKA + 1 ELSEIF ( KODCRS .EQ. 17 ) THEN IFINET = IFINET + 1 ELSEIF ((KODCRS .GE. 18 .AND. KODCRS .LE. 24) * .OR. (KODCRS .GE. 26 .AND. KODCRS .LE. 32)) THEN IFINHY = IFINHY + 1 ELSEIF ( KODCRS .GE. 51 .AND. KODCRS .LE. 53 ) THEN IFINRHO = IFINRHO + 1 #if __CHARM__ ELSEIF ((KODCRS .GE. 116 .AND. KODCRS .LE. 130) .OR. * (KODCRS .GE. 137 .AND. KODCRS .LE. 173)) THEN IFINCM = IFINCM + 1 #endif ELSE IFINOT = IFINOT + 1 ENDIF ENDIF GOTO 1000 999 IF ( LLONGI ) THEN C ADD NEUTRINO ENERGY TO LONGITUDINAL ENERGY DEPOSIT #if __THIN__ DLONG(LHEIGH,8) = DLONG(LHEIGH,8) + PHKK(4,J) * WEIGHT #else DLONG(LHEIGH,8) = DLONG(LHEIGH,8) + PHKK(4,J) #endif ENDIF 1000 CONTINUE IF (DEBUG) WRITE(MDEBUG,*) * 'DPMJST: J=',J,' KODCRS=',KODCRS,' ISTHKK=',ISTHKK(J) 1001 CONTINUE IF ( NFRAGM .GE. 1 .AND. NFRAGM .LE. 4 ) THEN IF ( INEW .EQ. 0 ) GOTO 140 C TREAT REMAINING NUCLEUS IF ( DEBUG ) WRITE(MDEBUG,150) INEW,(CURPAR(I),I=1,8) 150 FORMAT(' DPMJST: REMNNT=',1P,I10,8E11.3) DO IK = 0, 4 SECPAR(IK) = CURPAR(IK) ENDDO #if __INTTEST__ SECPAR(17) = CURPAR(17) #endif IF ( INEW .EQ. 100 ) THEN C REMAINING NUCLEUS IS SINGLE NEUTRON SECPAR(0) = 13.D0 #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER PARTICLE DO IK = 0, 8 SECPAR(IK+17) = SECPAR(IK) ENDDO #if __THIN__ SECPAR(26) = SECPAR(13) #endif #endif CALL TSTACK ETOT = ETOT + SECPAR(1) * PAMA(13) GOTO 140 ELSEIF ( INEW .EQ. 101 ) THEN C REMAINING NUCLEUS IS SINGLE PROTON SECPAR(0) = 14.D0 #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER PARTICLE DO IK = 0, 8 SECPAR(IK+17) = SECPAR(IK) ENDDO #if __THIN__ SECPAR(26) = SECPAR(13) #endif #endif CALL TSTACK ETOT = ETOT + SECPAR(1) * PAMA(14) GOTO 140 ELSEIF ( INEW .EQ. 102 ) THEN C REMAINING NUCLEUS IS DIPROTON, STORE TWO PROTONS SECPAR(0) = 14.D0 #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER PARTICLE DO IK = 0, 8 SECPAR(IK+17) = SECPAR(IK) ENDDO #if __THIN__ SECPAR(26) = SECPAR(13) #endif #endif CALL TSTACK CALL TSTACK ETOT = ETOT + 2.D0 * SECPAR(1) * PAMA(14) GOTO 140 ELSEIF ( INEW .EQ. 200 ) THEN C REMAINING NUCLEUS IS DINEUTRON, STORE TWO NEUTRONS SECPAR(0) = 13.D0 #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER PARTICLE DO IK = 0, 8 SECPAR(IK+17) = SECPAR(IK) ENDDO #if __THIN__ SECPAR(26) = SECPAR(13) #endif #endif CALL TSTACK CALL TSTACK ETOT = ETOT + 2.D0 * SECPAR(1) * PAMA(13) GOTO 140 ELSE C REMAINING NUCLEUS IS ONE FRAGMENT NZNEW = MOD(INEW,100) NNNEW = INEW/100 - NZNEW ENDIF IF ( NFRAGM .EQ. 1 ) THEN KNEW = INEW ELSEIF ( NFRAGM .GE. 2 .AND. NFRAGM .LE. 4 ) THEN C REMAINING NUCLEUS IS EVAPORATING NUCLEONS AND ALPHA PARTICLES JFIN = 0 CALL VAPOR( IP,INEW,JFIN,ITYP,PFRX,PFRY ) IF ( JFIN .EQ. 0 ) GOTO 139 C LOOP TO TREAT THE REMANENTS OF THE DESINTEGRATED FRAGMENT KNEW = 0 DO 135 J = 1, JFIN EA = GAMMA * PAMA(ITYP(J)) IF (DEBUG) WRITE(MDEBUG,*) 'DPMJST: J,ITYP,EA=', * J,ITYP(J),SNGL(EA) C MOMENTA SQUARED PTM = (EA-PAMA(ITYP(J))) * (EA+PAMA(ITYP(J))) PT2 = PFRX(J)**2 + PFRY(J)**2 IF ( PT2 .GE. PTM ) THEN IF (DEBUG) WRITE(MDEBUG,*) 'DPMJST: PT REJECT PARTICLE',J GOTO 135 ENDIF IF ( PTM .GT. 0.D0 ) THEN COSTET = SQRT( 1.D0 - PT2/PTM ) PT3 = SQRT( PTM ) CPHIV = PFRX(J) / PT3 SPHIV = PFRY(J) / PT3 ELSE COSTET = 1.D0 CPHIV = 1.D0 SPHIV = 0.D0 PT3 = 0.D0 ENDIF CALL ADDANG4( COSTHE,PHIX,PHIY, COSTET,CPHIV,SPHIV, * SECPAR(2),SECPAR(3),SECPAR(4) ) #if __UPWARD__ IF ( SECPAR(2) .GE. -1.D0 ) THEN #else IF ( SECPAR(2) .GT. C(29) ) THEN #endif IF ( J .LT. JFIN ) THEN SECPAR(0) = ITYP(J) #if __INTTEST__ SECPAR(17) = SQRT( PT2 ) #endif #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER PARTICLE DO IK = 0, 8 SECPAR(IK+17) = SECPAR(IK) ENDDO #if __THIN__ SECPAR(26) = SECPAR(13) #endif #endif CALL TSTACK ELSE KNEW = ITYP(JFIN) ENDIF ELSE ! ANGLE REJECT IF ( DEBUG ) WRITE(MDEBUG,*) * 'DPMJST: ANGLE REJECT PARTICLE',J IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT #if __THIN__ DLONG(LHEIGH,17) = DLONG(LHEIGH,17) * + ( EA - RESTMS(ITYP(J)) ) * WEIGHT #else DLONG(LHEIGH,17) = DLONG(LHEIGH,17) + EA-RESTMS(ITYP(J)) #endif ENDIF #if __AUGERHIST__ THICKLOC = THICK( H ) DO LL = 1, NOBSLV IF ( THICKLOC .GE. THCKOB(LL) .AND. * THICKLOC .LT. THCKOB(LL)+SAMPTH ) THEN C THICKH IS WITHIN 1 G/CM^2 BELOW OBSLEV(LL) C BRING THE ENERGY BELOW ANGULAR CUT TO THE HISTO OF LEVEL LL OUTPAR(0) = ITYP(J) DO II = 1, 8 OUTPAR(II) = SECPAR(II) ENDDO OUTPAR( 9) = GEN OUTPAR(10) = ALEVEL OUTPAR(13) = WEIGHT EDEP = ( EA - RESTMS(ITYP(J)) ) * WEIGHT C WE HAVE ANGULAR CUT CALL AUGERDEPFIL( EDEP,LL,1 ) ELSEIF ( THICKLOC .LT. THCKOB(LL) ) THEN GOTO 112 ENDIF ENDDO 112 CONTINUE #endif ENDIF 135 CONTINUE ENDIF IF ( KNEW/100 .EQ. 5 ) THEN C REMAINING NUCLEUS: MASS 5 CANNOT BE TREATED IN BOX2 IF ( MOD(KNEW,100) .GE. 3 ) THEN C MASS 5: SPLIT OFF ONE PROTON SECPAR(0) = 14.D0 #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER PARTICLE DO IK = 0, 8 SECPAR(IK+17) = SECPAR(IK) ENDDO #if __THIN__ SECPAR(26) = SECPAR(13) #endif #endif CALL TSTACK KNEW = KNEW - 101 ELSE C MASS 5: SPLIT OFF ONE NEUTRON SECPAR(0) = 13.D0 #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER PARTICLE DO IK = 0, 8 SECPAR(IK+17) = SECPAR(IK) ENDDO #if __THIN__ SECPAR(26) = SECPAR(13) #endif #endif CALL TSTACK KNEW = KNEW - 100 ENDIF ELSEIF ( KNEW/100 .EQ. 8 ) THEN C REMAINING NUCLEUS: MASS 8 CANNOT BE TREATED IN BOX2 IF ( MOD(KNEW,100) .GE. 5 ) THEN C MASS 8: SPLIT OFF ONE PROTON SECPAR(0) = 14.D0 #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER PARTICLE DO IK = 0, 8 SECPAR(IK+17) = SECPAR(IK) ENDDO #if __THIN__ SECPAR(26) = SECPAR(13) #endif #endif CALL TSTACK KNEW = KNEW - 101 ELSEIF ( MOD(KNEW,100) .LE. 3 ) THEN C MASS 8: SPLIT OFF ONE NEUTRON SECPAR(0) = 13.D0 #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER PARTICLE DO IK = 0, 8 SECPAR(IK+17) = SECPAR(IK) ENDDO #if __THIN__ SECPAR(26) = SECPAR(13) #endif #endif CALL TSTACK KNEW = KNEW - 100 ELSE C MASS 8: SPLIT OFF ONE ALPHA PARTICLE SECPAR(0) = 402.D0 #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER PARTICLE DO IK = 0, 8 SECPAR(IK+17) = SECPAR(IK) ENDDO #if __THIN__ SECPAR(26) = SECPAR(13) #endif #endif CALL TSTACK KNEW = KNEW - 402 ENDIF ENDIF C CHECK IF A = Z (NOT ALLOWED IN DPMJET!) IN THIS CASE CHANGE C ONE PROTON TO A NEUTRON IF ( ( KNEW .GT. 200 ) .AND. * ( KNEW/100 .EQ. MOD(KNEW,100) ) ) KNEW = KNEW - 1 SECPAR(0) = KNEW #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER PARTICLE DO IK = 0, 8 SECPAR(IK+17) = SECPAR(IK) ENDDO #if __THIN__ SECPAR(26) = SECPAR(13) #endif #endif CALL TSTACK ENDIF 139 ETOT = ETOT + SECPAR(1)*(PAMA(13)*NNNEW + PAMA(14)*NZNEW) 140 CONTINUE IF ( DEBUG ) THEN WRITE(MDEBUG,*) 'DPMJST:',NPTLS,' SECONDARY PARTICLES' WRITE(MDEBUG,*) 'DPMJST: ELASTI,ETOT,ELAB= ',ELASTI,ETOT,ELAB ENDIF C FILL ELASTICITY IN MATRICES MEL = MIN ( 1.D0+10.D0* MAX( 0.D0, ELASTI ) , 11.D0 ) MEN = MIN ( 4.D0+ 3.D0*LOG10(MAX( .1D0, EKINL )), 40.D0 ) #if __THIN__ IELDPM(MEN,MEL) = IELDPM(MEN,MEL) + NINT( WEIGHT ) IELDPA(MEN,MEL) = IELDPA(MEN,MEL) + NINT( WEIGHT ) IF ( ELASTI .LT. 1.D0 ) THEN ELMEAN(MEN) = ELMEAN(MEN) + ELASTI * WEIGHT ELMEAA(MEN) = ELMEAA(MEN) + ELASTI * WEIGHT #else IELDPM(MEN,MEL) = IELDPM(MEN,MEL) + 1 IELDPA(MEN,MEL) = IELDPA(MEN,MEL) + 1 IF ( ELASTI .LT. 1.D0 ) THEN ELMEAN(MEN) = ELMEAN(MEN) + ELASTI ELMEAA(MEN) = ELMEAA(MEN) + ELASTI #endif ENDIF #if __COASTUSERLIB__ coastProjId = nint(curpar(0)) coastTargId = nint(tar) coastX = curpar(7) coastY = curpar(8) #if __CURVED__ coastZ = curpar(14) #else coastX = coastX - XOFF(NOBSLV) coastY = coastY - YOFF(NOBSLV) coastZ = curpar(5) #endif coastT = curpar(6) coastE = pama(coastProjId)*curpar(1) coastCX = sigair coastEl = elasti call interaction(coastX) #endif IF ( FIRSTI ) THEN TARG1I = TAR SIG1I = SIGAIR ELAST = ELASTI FIRSTI = .FALSE. C RANDOM GENERATOR STATUS (SEQUENCE L=1) AT END OF EVENT LL = 1 CALL RMMAQD( ISEED(1,LL),LL,'R' ) C SEED ISEED1I(1) = ISEED(1,LL) C NUMBER OF CALLS ISEED1I(2) = ISEED(2,LL) C NUMBER OF BILLIONS ISEED1I(3) = ISEED(3,LL) ENDIF RETURN END #if __EHISTORY__ *-- Author : J. van Santen (UW-Madison) 25/10/2013 C======================================================================= SUBROUTINE PDGTOCRS( PDG, CRS ) C----------------------------------------------------------------------- C CONVERT PDG PARTICLE CODES TO CORSIKA CONVENTION C THIS SUBROUTINE IS CALLED FROM DPMJST c----------------------------------------------------------------------- IMPLICIT NONE #define __RANDPAINC__ #define __RUNPARINC__ #include "corsika.h" DOUBLE PRECISION CRS INTEGER PDG SAVE c----------------------------------------------------------------------- C CONVERT DATA PARTICLE GROUP CODE TO CORSIKA CODE C MESONS IF ( PDG .EQ. 111 ) THEN CRS = 7 !i PI(0) ELSEIF ( PDG .EQ. 211 ) THEN CRS = 8 ! PI+ ELSEIF ( PDG .EQ. -211 ) THEN CRS = 9 ! PI- ELSEIF ( PDG .EQ. 221 ) THEN CRS = 17 ! ETA C NUCLEONS ELSEIF ( PDG .EQ. 2112 ) THEN CRS = 13 ! N ELSEIF ( PDG .EQ. 2212 ) THEN CRS = 14 ! P ELSEIF ( PDG .EQ. -2212 ) THEN CRS = 15 ! ANTI-P ELSEIF ( PDG .EQ. -2112 ) THEN CRS = 25 ! ANTI-N C STRANGE MESONS ELSEIF ( PDG .EQ. 130 ) THEN CRS = 10 ! K0L ELSEIF ( PDG .EQ. 321 ) THEN CRS = 11 ! K+ ELSEIF ( PDG .EQ. -321 ) THEN CRS = 12 ! K- ELSEIF ( PDG .EQ. 310 ) THEN CRS = 16 ! K0S ELSEIF ( PDG .EQ. 311 .OR. ! K(0) * PDG .EQ. -311 ) THEN ! ANTI-K(0) CALL RMMARD( RD,1,1 ) IF ( RD(1) .GE. 0.5D0 ) THEN CRS = 10 ELSE CRS = 16 ENDIF C STRANGE BARYONS ELSEIF ( PDG .EQ. 3122 ) THEN ! LAMBDA CRS = 18 ELSEIF ( PDG .EQ. 3222 ) THEN ! SIGMA+ CRS = 19 ELSEIF ( PDG .EQ. 3212 ) THEN ! SIGMA(0) CRS = 20 ELSEIF ( PDG .EQ. 3112 ) THEN ! SIGMA- CRS = 21 ELSEIF ( PDG .EQ. 3322 ) THEN ! XI(0) CRS = 22 ELSEIF ( PDG .EQ. 3312 ) THEN ! XI- CRS = 23 ELSEIF ( PDG .EQ. 3334 ) THEN ! OMEGA- CRS = 24 ELSEIF ( PDG .EQ. -3122 ) THEN ! ANTI-LAMBDA CRS = 26 ELSEIF ( PDG .EQ. -3222 ) THEN ! ANTI-SIGMA- CRS = 27 ELSEIF ( PDG .EQ. -3212 ) THEN ! ANTI-SIGMA(0) CRS = 28 ELSEIF ( PDG .EQ. -3112 ) THEN ! ANTI-SIGMA+ CRS = 29 ELSEIF ( PDG .EQ. -3322 ) THEN ! ANTI-XI(0) CRS = 30 ELSEIF ( PDG .EQ. -3312 ) THEN ! ANTI-XI+ CRS = 31 ELSEIF ( PDG .EQ. -3334 ) THEN ! ANTI-OMEGA+ CRS = 32 C GAMMAS ELSEIF ( PDG .EQ. 22 ) THEN ! GAMMA CRS = 1 C LEPTONS ELSEIF ( PDG .EQ. -11 ) THEN ! E+ CRS = 2 ELSEIF ( PDG .EQ. 11 ) THEN ! E- CRS = 3 ELSEIF ( PDG .EQ. -13 ) THEN ! MU+ CRS = 5 ELSEIF ( PDG .EQ. 13 ) THEN ! MU- CRS = 6 #if __CHARM__ || __TAULEB__ C TAU LEPTONS ELSEIF ( PDG .EQ. -15 ) THEN ! TAU+ CRS = 131 ELSEIF ( PDG .EQ. 15 ) THEN ! TAU- CRS = 132 #endif #if __CHARM__ C CHARMED MESONS ELSEIF ( PDG .EQ. 421 ) THEN CRS = 116 ! D(0) ELSEIF ( PDG .EQ. 411 ) THEN CRS = 117 ! D(+) ELSEIF ( PDG .EQ. -411 ) THEN CRS = 118 ! D(-) ELSEIF ( PDG .EQ. -421 ) THEN CRS = 119 ! A-D(0) C CHARMED MESONS WITH STRANGENESS ELSEIF ( PDG .EQ. 431 ) THEN CRS = 120 ! D_S(+) ELSEIF ( PDG .EQ. -431 ) THEN CRS = 121 ! D_S(-) C CHARMED ETA MESON ELSEIF ( PDG .EQ. 441 .OR. * PDG .EQ. -441 ) THEN CRS = 122 ! ETA_C C EXCITED CHARMED MESONS ELSEIF ( PDG .EQ. 423 ) THEN CRS = 123 ! D*(0) ELSEIF ( PDG .EQ. 413 ) THEN CRS = 124 ! D*(+) ELSEIF ( PDG .EQ. -413 ) THEN CRS = 125 ! D*(-) ELSEIF ( PDG .EQ. -423 ) THEN CRS = 126 ! A-D*(0) ELSEIF ( PDG .EQ. 433 ) THEN CRS = 127 ! D_S*(+) ELSEIF ( PDG .EQ. -433 ) THEN CRS = 128 ! D_S*(-) ELSEIF ( PDG .EQ. 443 .OR. * PDG .EQ. -443 ) THEN CRS = 130 ! J/PSI C CHARMED BARYONS ELSEIF ( PDG .EQ. 4122 ) THEN CRS = 137 ! LAMBDA_C(+) ELSEIF ( PDG .EQ. 4232 ) THEN CRS = 138 ! XI_C(+) ELSEIF ( PDG .EQ. 4132 ) THEN CRS = 139 ! XI_C(0) ELSEIF ( PDG .EQ. 4222 ) THEN CRS = 140 ! SIGMA_C(++) ELSEIF ( PDG .EQ. 4212 ) THEN CRS = 141 ! SIGMA_C(+) ELSEIF ( PDG .EQ. 4112 ) THEN CRS = 142 ! SIGMA_C(0) ELSEIF ( PDG .EQ. 4322 ) THEN CRS = 143 ! XI_C*(+) ELSEIF ( PDG .EQ. 4312 ) THEN CRS = 144 ! XI_C*(0) ELSEIF ( PDG .EQ. 4332 ) THEN CRS = 145 ! OMEGA_C(0) ELSEIF ( PDG .EQ. -4122 ) THEN CRS = 149 ! A-LAMBDA_C(-) ELSEIF ( PDG .EQ. -4232 ) THEN CRS = 150 ! A-XI_C(-) ELSEIF ( PDG .EQ. -4132 ) THEN CRS = 151 ! A-XI-C(0) ELSEIF ( PDG .EQ. -4222 ) THEN CRS = 152 ! A-SIGMA_C(--) ELSEIF ( PDG .EQ. -4212 ) THEN CRS = 153 ! A-SIGMA_C(-) ELSEIF ( PDG .EQ. -4112 ) THEN CRS = 154 ! A-SIGMA_C(0) ELSEIF ( PDG .EQ. -4322 ) THEN CRS = 155 ! A-XI_C*(-) ELSEIF ( PDG .EQ. -4312 ) THEN CRS = 156 ! A-XI_C*(0) ELSEIF ( PDG .EQ. -4332 ) THEN CRS = 157 ! A-OMEGA_C(0) C EXCITED CHARMED BARYONS ELSEIF ( PDG .EQ. 4224 ) THEN CRS = 161 ! SIGMA_C*(++) ELSEIF ( PDG .EQ. 4214 ) THEN CRS = 162 ! SIGMA_C*(+) ELSEIF ( PDG .EQ. 4114 ) THEN CRS = 163 ! SIGMA_C*(0) ELSEIF ( PDG .EQ. -4224 ) THEN CRS = 171 ! A-SIGMA_C*(--) ELSEIF ( PDG .EQ. -4214 ) THEN CRS = 172 ! A-SIGMA_C*(-) ELSEIF ( PDG .EQ. -4114 ) THEN CRS = 173 ! A-SIGMA_C*(0) C DOUBLE CHARMED BARYONS CANNOT BE TREATED, TAKE CHARMED STRANGE BARYS ELSEIF ( PDG .EQ. 4422 ) THEN CRS = 138 ELSEIF ( PDG .EQ. 4412 ) THEN CRS = 144 ELSEIF ( PDG .EQ. 4432 ) THEN CRS = 145 ELSEIF ( PDG .EQ. -4422 ) THEN CRS = 155 ELSEIF ( PDG .EQ. -4412 ) THEN CRS = 156 ELSEIF ( PDG .EQ. -4432 ) THEN CRS = 157 C TRIPLE CHARMED BARYONS CANNOT BE TREATED, TAKE CHARMED STRANGE BARYS ELSEIF ( PDG .EQ. 4444 ) THEN CRS = 145 ELSEIF ( PDG .EQ. -4444 ) THEN CRS = 157 #endif C NEUTRINOS ELSEIF ( PDG .EQ. 12 ) THEN CRS = 66 ELSEIF ( PDG .EQ. -12 ) THEN CRS = 67 ELSEIF ( PDG .EQ. 14 ) THEN CRS = 68 ELSEIF ( PDG .EQ. -14 ) THEN CRS = 69 C TAU NEUTRINOS ELSEIF ( PDG .EQ. 16 ) THEN CRS = 133 ELSEIF ( PDG .EQ. -16 ) THEN CRS = 134 ELSE WRITE(MONIOU,*) 'PDGtoCRS: UNKNOWN PARTICLE CODE=',PDG CRS = 9999 ENDIF RETURN END #endif *-- Author : D. HECK IK FZK KARLSRUHE 18/03/2003 C======================================================================= DOUBLE PRECISION FUNCTION RNDM() C----------------------------------------------------------------------- C R(A)ND(O)M (GENERATOR FOR DPMJET-III) C C SEE SUBROUT. RMMARD C WE USE HERE A SIMPLIFIED FORM OF RMMARD WITH JSEQ=1, LENV=1. C THIS FUNCTON IS CALLED FROM DPMJET-III ROUTINES. C----------------------------------------------------------------------- IMPLICIT NONE #define __RANMA3INC__ #define __RANMA4INC__ #include "corsika.h" SAVE C----------------------------------------------------------------------- UNI = U(I97(1),1) - U(J97(1),1) IF ( UNI .LT. 0.D0 ) UNI = UNI + 1.D0 U(I97(1),1) = UNI I97(1) = I97(1) - 1 IF ( I97(1) .EQ. 0 ) I97(1) = 97 J97(1) = J97(1) - 1 IF ( J97(1) .EQ. 0 ) J97(1) = 97 C(1) = C(1) - CD IF ( C(1) .LT. 0.D0 ) C(1) = C(1) + CM UNI = UNI - C(1) 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 RNDM = UNI NTOT(1) = NTOT(1) + 1 IF ( NTOT(1) .GE. MODCNS ) THEN NTOT2(1) = NTOT2(1) + 1 NTOT(1) = NTOT(1) - MODCNS ENDIF RETURN END #endif #if __NUPRIM__ && !__DPMJET__ *-- Author : Bryan Webber C======================================================================= SUBROUTINE PDFSET(PARM,VAL) C----------------------------------------------------------------------- C DUMMY SUBROUTINE: DELETE AND SET MODPDF(I) C IN MAIN PROGRAM IF YOU USE PDFLIB CERN-LIBRARY C PACKAGE FOR NUCLEON STRUCTURE FUNCTIONS C----------------------------------------------------------------------- IMPLICIT NONE DOUBLE PRECISION VAL(20) CHARACTER*20 PARM(20) #if __GFORTRAN__ CTP060202 TO AVOID WARNINGS WITH GFORTRAN COMPILATION LOGICAL CTP060202 CTP060202 = .FALSE. IF ( CTP060202 ) WRITE(*,*) PARM,VAL #endif WRITE (6,10) 10 FORMAT(/10X,'PDFSET CALLED BUT NOT LINKED') STOP END *-- Author : Bryan Webber C======================================================================= SUBROUTINE STRUCTM(X,QSCA,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU) C----------------------------------------------------------------------- C DUMMY SUBROUTINE: DELETE IF YOU USE PDFLIB CERN-LIBRARY C PACKAGE FOR NUCLEON STRUCTURE FUNCTIONS C----------------------------------------------------------------------- IMPLICIT NONE DOUBLE PRECISION X,QSCA,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU #if __GFORTRAN__ CTP060202 TO AVOID WARNINGS WITH GFORTRAN COMPILATION LOGICAL CTP060202 CTP060202 = .FALSE. IF(CTP060202)WRITE(*,*)X,QSCA,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP &,GLU #endif WRITE (6,10) 10 FORMAT(/10X,'STRUCTM CALLED BUT NOT LINKED') STOP END #endif *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE AVEPT( ECM,SLOG ) C----------------------------------------------------------------------- C AVE(RAGE) PT (TRANSVERSE MOMENTUM) C C CALCULATES AVERAGE RATIO PT(PARTICLE)/PT(PION) DEPENDING ON ENERGY C THE DEPENDENCE OF PT ON ENERGY IS DONE IN SUBROUT. PTRAM/PTRAN C THIS SUBROUTINE IS CALLED FROM HDPM. C ARGUMENTS: C ECM = ENERGY IN THE CM SYSTEM (GEV) C SLOG = LOG(S) ( = LOG(ECM**2) ) C----------------------------------------------------------------------- IMPLICIT NONE #define __AVPTINC__ #define __RUNPARINC__ #include "corsika.h" DOUBLE PRECISION ECM,SLOG SAVE C----------------------------------------------------------------------- CC IF ( DEBUG ) WRITE(MDEBUG,*) 'AVEPT : ECM =',SNGL(ECM) C AVERAGE TRANSVERSE MOMENTUM C ... FOR PIONS (=AVPT) IF ( ECM .LT. 132.D0 ) THEN AVPT = 0.3D0 + 6.272D-3 * SLOG ELSE AVPT = ( 0.442105D0 + 0.016276D0 * SLOG )**2 ENDIF C ... FOR KAONS (=AVPK) IF ( ECM .LT. 131.D0 ) THEN AVPK = 1.27D0 * AVPT ELSE AVPK = (0.403146D0 + 0.0281D0 * SLOG)**2 ENDIF C ... FOR NUCLEONS (=AVPN) IF ( ECM .LT. 102.D0 ) THEN AVPN = 1.39D0 * AVPT ELSE AVPN = (0.389873D0 + 0.034127D0 * SLOG)**2 ENDIF C SET AVERAGE PT RELATED TO AVERAGE PT FOR PIONS C ... FOR STRANGE BARYONS (=AVPH) AVPH = 1.3D0 * (1.45D0 * AVPN - 0.45D0 * AVPK) / AVPT C ... FOR ETA MESONS (=AVPE) AVPE = 1.3D0 * (0.88D0 * AVPK + 0.12D0 * AVPN) / AVPT AVPK = 1.3D0 * AVPK / AVPT AVPN = 1.3D0 * AVPN / AVPT AVPT = 1.3D0 IF ( DEBUG ) WRITE(MDEBUG,100) * SNGL(AVPT),SNGL(AVPK),SNGL(AVPN),SNGL(AVPH),SNGL(AVPE) 100 FORMAT(' AVEPT : AVPT,AVPK,AVPN,AVPH,AVPE=',5F12.5) RETURN END *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE DIFRAC( NRETFL ) C----------------------------------------------------------------------- C (SINGLE) DIF(F)RAC(TION) C C SETS PARAMETERS FOR HDPM IN CASE OF SINGLE DIFFRACTION. C THIS SUBROUTINE IS CALLED FROM HDPM. C ARGUMENT: C NRETFL = 0 CORRECT ENDING OF SUBROUTINE C = 1 INCORRECT ENDING OF SUBROUTINE C----------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) #define __DPMFLGINC__ #define __INTERINC__ #define __LEPARINC__ #define __PAMINC__ #define __PARPARINC__ #define __PARPAEINC__ #define __RANDPAINC__ #define __RESTINC__ #define __RUNPARINC__ #include "corsika.h" SAVE C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'DIFRAC:' C DECIDE FIRST, WHETHER PROJECTILE OR TARGET DIFFRACTION CALL RMMARD( RD,1,1 ) IF ( RD(1) .LE. 0.5D0 ) THEN C PROJECTILE DIFFRACTON, TARGET DIFFRACTION FLAG IS NOT SET NFTARD = 0 C MASS OF INCOMING PARTICLE AND PI(0) MASS C PI(0) IS MINIMAL OUTCOME OF SECONDARIES IN DIFRAC XM0 = ( PAMA(LEPAR1) + PAMA(7) )**2 ELSE C TARGET DIFFRACTON, SET TARGET DIFFRACTION FLAG NFTARD = 1 C MASS OF NUCLEON AND PI(0) MASS C PI(0) IS MINIMAL OUTCOME OF SECONDARIES IN DIFRAC XM0 = ( PAMA(LEPAR2) + PAMA(7) )**2 ENDIF C MAXIMAL DIFFRACTIVE MASS, FACTOR 0.15 GIVEN BY COHERENCE CONDITION XMX = 0.15D0 * S C THROW MAXIMAL 200 TIMES TO GET A GOOD DIFFRACTIVE MASS NCDIFL = 0 7 CONTINUE C GET DIFFRACTIVE MASS CALL RMMARD( RD,2,1 ) C GET S (=ECM**2) (WHY THIS WAY OF THROWING ???) SDIF = (XMX/XM0)**RD(1) * XM0 IF ( SDIF .LE. XM0 ) THEN IF ( NCDIFL .LE. 200 ) THEN NCDIFL = NCDIFL + 1 GOTO 7 ELSE C SET RETURN FLAG TO ERROR NRETFL = 1 RETURN ENDIF ENDIF C DISTRIBUTION OF DIFFRACTIVE MASS FLATTENS OFF FOR DIFFRACTIVE C MASS SQUARED .LE. 2 GEV IF ( SDIF .LE. 2.D0 ) THEN C----- SO GEHT DAS NICHT!! 16.12.91 D.H. SDIF = RD(2) * (2.D0 - XM0) + XM0 ENDIF C SQRT(S) IS ECM ECMDIF = SQRT( SDIF ) C LOG(S), LOG(S)**2 DLOGS = LOG( SDIF ) DLOGSQ = DLOGS**2 IF ( DEBUG ) WRITE(MDEBUG,*) 'DIFRAC: SDIF,ECMDIF,NFTARD=', * SNGL(SDIF),SNGL(ECMDIF),NFTARD C RAPIDITY IN CMS OF DIFFRACTIVE SYSTEM C TO CALCULATE DMLOG, SUBTRACT SUM OF MASS SQUARES FROM SDIF C PI(0) MASS SQUARED IS 0.0182. IF ( NFTARD .EQ. 0 ) THEN YY0 = LOG( ECMDPM/ECMDIF ) DMLOG = LOG( SDIF - 0.0182D0 - PAMA(LEPAR1)**2 ) ELSE YY0 = -LOG( ECMDPM/ECMDIF ) DMLOG = LOG( SDIF - 0.0182D0 - PAMA(LEPAR2)**2 ) ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) 'DIFRAC: YY0,DMLOG=', * SNGL(YY0),SNGL(DMLOG) C CENTRAL RAPIDITY DENSITY IN CMS OF DIFFRACTIVE SYSTEM C PARAMETERISATION SEE CAPDEVIELLE,J.PHYS.G:NUCL.PHYS.16(1990)1539 EQ.7 C WE USE ONLY THE LOW-ENERGY PART OF THE PARAMETERISATION, AS SDIF DOES C NOT REACH THE HIGHER VALUES DC0 = 0.82D0 * (SDIF**0.107D0) C THERE ARE 3 ENERGY DEPENDENT FORMULAS FOR AVERAGE CHARGED C MULTIPLICITY ( AVCH1 ); C PARAMETERISATIONS SEE CAPDEVIELLE,J.PHYS.G:NUCL.PHYS.16(1990)1539 EQ.8 IF ( ECMDIF .LE. 187.5D0 ) THEN C CHARGED MULTIPLICITY (M**2 IN PLACE OF S) AVCH1 = 0.57D0 + 0.584D0*DLOGS + 0.127D0*DLOGSQ ELSEIF ( ECMDIF .LE. 945.5D0 ) THEN AVCH1 = -6.55D0 + 6.89D0 * SDIF**0.131D0 ELSE AVCH1 = 3.4D0 * SDIF**0.17D0 ENDIF C PARAMETERISATION IS BASED ON COLLIDER DATA WHERE PROTON AND ANTIPROTON C ARE INCLUDED. LOWER LIMIT FOR AVERAGE CHARGED MULTIPLICITY IS 1. AVCH1 = MAX( 1.D0, AVCH1 ) C CENTER OF GAUSSIAN 1ST+2ND STRING OF FRAGMENTATION SYSTEM POSC2 = 0.146D0 * DMLOG + 0.072D0 C WIDTH OF GAUSSIAN 1ST+2ND STRING OF FRAGMENTATION SYSTEM WIDC2 = 0.120D0 * DMLOG + 0.180D0 C INTERACTION FACTOR GNU FOR INTERACTION WITH NUCLEUS; IF ( NFLAIN .EQ. 0 ) THEN GNU = 1.D0 AVCH3 = 0.D0 POSC3 = 0.D0 WIDC3 = 1.D0 ELSE C NEW PARAMETERIZATION OF J.N.CAPDEVIELLE (MARCH 93) GNU = (0.4826D0 + 3.522D-2 * DLOGS) * TAR**0.31D0 C CENTER OF GAUSSIAN FOR 3RD STRING (FROM TARGET) POSC3 = +3.D0 - 2.575D0 * EXP( (-0.081756452D0) * GNU ) C WIDTH OF GAUSSIAN FOR 3RD STRING (FROM TARGET) WIDC3 = 1.2338466D0 + 0.078969916D0 * LOG( GNU ) IF ( ECMDIF .LE. 137.D0 ) THEN AVCH3 = 0.57D0 * AVCH1 * (GNU-1.D0) ELSE AVCH3 = 0.5D0 * AVCH1 * (GNU-1.D0) ENDIF ENDIF IF ( DEBUG ) WRITE(MDEBUG,100) * SNGL(POSC2),SNGL(WIDC2),SNGL(POSC3),SNGL(WIDC3) 100 FORMAT(' DIFRAC: POSC2,WIDC2,POSC3,WIDC3=',4F12.7) C AVERAGE CHARGED, INCLUDING THOSE FROM TARGET AVCH = AVCH1 + AVCH3 C THE FOLOWING PROCEDURE IS TO PRODUCE GAMMAS FROM UNKNOWN NEUTRAL C DECAYS FOLLOWING CORRELATION WITH CHARGED PARTICLES BASED ON C GAMMA EXCESS AT COLLIDER EXPERIMENTS. SEUGP IS C PROBLEM OF THE RISE OF THE UNKNOWN ETA PRODUCTION CROSS-SECTION C IS SOLVED WITH PARAMETERISATION OF UA5 (Z. PHYS. C43 (1989) 75) IF ( ECMDIF .LE. 103.D0 ) THEN SEUGP = -1.27D0 + 0.52D0 * DLOGS + 0.148D0 * DLOGSQ ELSE C AT HIGH DIFFRACTIVE MASS USE PARAMETERISATION OF THOUW ???? SEUGP = -18.7D0 + 11.55D0 * SDIF**0.1195D0 ENDIF SEUGP = MAX( 0.5D0, SEUGP ) IF ( DEBUG ) WRITE(MDEBUG,110) * SNGL(DC0),SNGL(AVCH1),SNGL(AVCH3),SNGL(AVCH),SNGL(SEUGP) 110 FORMAT(' DIFRAC: DC0,AVCH1,AVCH3,AVCH,SEUGP=',5F12.6) C SET RETURN FLAG TO OK NRETFL = 0 RETURN END *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= DOUBLE PRECISION FUNCTION DPFUNC( ENER ) C----------------------------------------------------------------------- C D(IFFRACTION) P(ORTION) FUNC(TION) C C CALCULATES THE FRACTION OF DIFFRACTION C THIS FUNCTION IS CALLED FROM HDPM C ARGUMNENT: C ENER = C.M. ENERGY (GEV) C----------------------------------------------------------------------- IMPLICIT NONE #define __RUNPARINC__ #include "corsika.h" DOUBLE PRECISION ENER SAVE C----------------------------------------------------------------------- C FUNCTION DPFUNC IS DUMMY DPFUNC = 0.15D0 IF ( DEBUG ) WRITE(MDEBUG,*) * 'DPFUNC: ENER=',SNGL(ENER),' DPFUNC=',SNGL(DPFUNC) RETURN END *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE HDPM C----------------------------------------------------------------------- C H(ADRONIC) D(UAL) P(ARTON) M(ODEL) C C GENERATOR OF HADRONIC COLLISION INSPIRED BY DUAL PARTON MODEL. C THIS SUBROUTINE IS CALLED FROM SDPM. C----------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) #define __CONSTAINC__ #define __DPMFLGINC__ #define __ELADPMINC__ #define __ELASTYINC__ #define __INDICEINC__ #define __INTERINC__ #define __ISTAINC__ #define __LEPARINC__ #define __LONGIINC__ #define __MULTINC__ #define __NEWPARINC__ #define __PAMINC__ #define __PARPARINC__ #define __PARPAEINC__ #define __RANDPAINC__ #define __RATIOSINC__ #define __RESONINC__ #define __RESTINC__ #define __RUNPARINC__ #define __SIGMINC__ #if __AUGERHIST__ || __EHISTORY__ #define __GENERINC__ #endif #if __AUGERHIST__ || __COASTUSERLIB__ #define __OBSPARINC__ #endif #if __INTTEST__ #define __TSTINTINC__ #endif #include "corsika.h" DOUBLE PRECISION CPHIJ,SPHIJ,DPFUNC,RANNOR,PTOT DOUBLE PRECISION FAC1,FAC2 INTEGER LL #if __AUGERHIST__ DOUBLE PRECISION EDEP,THICKLOC,THICk INTEGER II EXTERNAL THICK #endif #if __EHISTORY__ INTEGER IK #endif #if __COASTUSERLIB__ c definition of the COAST crs::CInteraction class COMMON/coastInteraction/coastX, coastY, coastZ, & coastE, coastCX, coastEl, coastProjId, coastTargId, & coastT double precision coastX, coastY, coastZ double precision coastE, coastCX, coastEl double precision coastT integer coastProjId, coastTargId #endif SAVE EXTERNAL DPFUNC,RANNOR C----------------------------------------------------------------------- #if __THIN__ IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=0,9),WEIGHT 444 FORMAT(' HDPM : CURPAR=',1P,11E11.3) #else IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=0,9) 444 FORMAT(' HDPM : CURPAR=',1P,10E11.3) #endif C SET ANTI-LEADER TO PROTON OR NEUTRON; TARGET IS ALWAYS NUCLEON CALL RMMARD( RD,1,1 ) IF ( RD(1) .LE. CONTNE(LIT) ) THEN ITAR = 13 ELSE ITAR = 14 ENDIF #if __INTTEST__ C SELECT TARGET TO PROTON OR NEUTRON IF REQUIRED BY DATACARD IF ( ITTAR .EQ. 1 ) THEN ITAR = 14 ELSEIF ( ITTAR .EQ. 2 ) THEN ITAR = 13 ENDIF #endif #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME GRANDMOTHER PARTICLE DO IK = 0, 6 SECPAR(28+IK) = CURPAR(IK) ENDDO C STORE GENERATION COUNTER OF MOTHER SECPAR(35) = GEN C STORE MASS PENETRATION BEFORE INTERACTION SECPAR(36) = CURPAR(9) #if __THIN__ SECPAR(37) = CURPAR(13) #endif #endif C CALCULATE LAB AND CM ENERGY IF ( ITYPE .NE. 1 ) THEN ELAB = PAMA(ITYPE) * GAMMA PLAB = ELAB * BETA S = PAMA(ITYPE)**2 + PAMA(ITAR)**2 + 2.D0*PAMA(ITAR)*ELAB ELSE C FOR GAMMA-INDUCED REACTION TAKE PI(0) AS LEADING PARTICLE ITYPE = 7 ELAB = GAMMA PLAB = ELAB S = PAMA(ITAR)**2 + 2.D0*PAMA(ITAR)*ELAB ENDIF ECMDPM = SQRT( S ) IF ( DEBUG ) WRITE(MDEBUG,*) 'HDPM : ITYPE,ELAB,PLAB,S,ECMDPM=', * ITYPE,SNGL(ELAB),SNGL(PLAB),SNGL(S),SNGL(ECMDPM) C LN(S), LN(S)**2 AND RAPIDITY OF C. M. SYSTEM IN LAB SLOG = LOG( S ) SLOGSQ = SLOG**2 SMLOG = LOG( 2.D0 * PAMA(ITAR) * ELAB ) ELABLG = LOG( ELAB ) EPLUSP = ELAB + PLAB CDH YCM = 0.5D0 * LOG( (ELAB+PAMA(ITAR)+PLAB)/(ELAB+PAMA(ITAR)-PLAB) ) YCM = 0.5D0 * LOG( (EPLUSP**2 +PAMA(ITAR)*EPLUSP)/ * (PAMA(ITYPE)**2+PAMA(ITAR)*EPLUSP) ) IF ( DEBUG ) WRITE(MDEBUG,*) 'HDPM : SLOG,SLOGSQ,YCM=', * SNGL(SLOG),SNGL(SLOGSQ),SNGL(YCM) C----------------------------------------------------------------------- C RETURN POINT IF CALCULATION OF PARTICLES GOES WRONG 1 CONTINUE IF ( ITYPE .NE. 7 ) THEN C CHOOSE NUMBER OF INTERACTIONS IN TARGET CALL TARINT ELSE C FOR GAMMA-INDUCED REACTIONS TAKE ALWAYS ONE COLLISION GNU = 1.D0 ENDIF #if __INTTEST__ C SET NUMBER OF INTERACTING NUCLEONS TO 1 IF REQUIRED IF ( ITTAR .LE. 2 ) GNU = 1.D0 IWOUNT = IWOUNT + GNU #endif C----------------------------------------------------------------------- C NO DIFFRACTION IF C OR THE NUMBER OF INTERACTIONS IN TARGET IS CHOSEN RANDOMLY C AND MORE THAN ONE INTERACTION TAKES PLACE C OR PROJECTILE PARTICLE IS GAMMA (PI0) C NOW NFLDIF DECIDES WHETHER DIFFRACTIVE PROCESS POSSIBLE OR NOT IF ( ( NFLAIN.EQ.0 .AND. GNU.GT.1.D0 .AND. NFLDIF.EQ.0 ) * .OR. ( ITYPE .EQ. 7 ) ) THEN IDIF = 0 ELSE C SET DIFFRACTION FLAG IF RANDOM NUMBER < PROBABILITY CALL RMMARD( RD,1,1 ) C IDIF IS 0 : NO DIFFRACTION ; IDIF IS 1 : DIFFRACTION C DIFFRACTION RISES WITH ENERGY AND SATURATES AT 10000 GEV C *** DAS TUT ES ABER NICHT: ES IST KONSTANT 0.15 (SIEHE DPFUNC) !!!! IF ( RD(1) .GT. DPFUNC(ECMDPM) ) THEN IDIF = 0 ELSE IDIF = 1 ENDIF ENDIF #if __INTTEST__ C DIFFRACTION MAY BE SWITCHED ON OR OFF FOR TESTING IF ( NDIF .EQ. 1 ) IDIF = 0 IF ( NDIF .EQ. 2 ) IDIF = 1 #endif C PRINTOUT FOR DEBUG IF ( DEBUG ) WRITE(MDEBUG,*) * ' DIFFRACTIVE INTERACTION (0/1) = ',IDIF C SET COUNTER FOR REPEAT TO 0 NREPRD = 0 C GENERATION OF INTERACTION 1919 CONTINUE C FLAG TO CHECK NUMBER OF SECONDARIES; C IS CHANGED TO 1 IF SECONDARY MULTIPLICITY IS LOW ISEL = 0 C SET LEADING PARTICLE TO INCOMING PARTICLE AND ANTI-LEADER TO NUCLEON C (AS IT COMES FROM TARGET NUCLEUS) BOTH MAY BE CHANGED BY LEPACX LEPAR1 = ITYPE LEPAR2 = ITAR IF ( IDIF .EQ. 0 ) THEN C----------------------------------------------------------------------- C NON SINGLE DIFFRACTIVE PROCESS STARTS HERE CALL NSD C CHARGE EXCHANGE ENABLED? EXCHANGE LEADER AND ANTI-LEADER LASTPI = 0 NRESPC = 0 NRESPN = 0 NCPLUS = 0 IF ( NFLCHE .EQ. 0 ) THEN CALL LEPACX( ECMDPM,ELABLG,LEPAR1,1 ) CALL LEPACX( ECMDPM,ELABLG,LEPAR2,2 ) ENDIF 1921 CONTINUE CALL RNEGBI( NCH,AVCH,ECMDPM ) C NCH IS # OF ALL CHARGED PARTICLES INCLUDING EXCESS FROM TARGET IF ( NCH .LT. 1 ) THEN IF ( LEPAR1 .LT. 50 .OR. LEPAR2 .LT. 50 ) THEN NREPRD = NREPRD + 1 IF ( NREPRD .GT. 10 ) GOTO 1 GOTO 1921 ELSE C INTERACTION IS ONLY RESONANCE PRODUCTION ISEL = 1 ENDIF ENDIF C WIDTH PLATEAU FOR CLUSTERS AND FOR CALCULATION OF CENTR.RAP.DENSITY DELRAP = 0.6722D0 * (2.95D0 + 0.0302D0 * SLOG) C SET RSLOG FOR CALCULATION OF PARTICLE RATIOS RSLOG = SLOG C AVERAGE TRANSVERSE MOMENTUM CALL AVEPT( ECMDPM,SLOG ) ELSE C----------------------------------------------------------------------- C SINGLE DIFFRACTIVE PROCESS STARTS HERE 1920 CONTINUE CALL DIFRAC( NRETDF ) IF ( NRETDF .EQ. 1 ) GOTO 1 C CHARGE EXCHANGE ENABLED? EXCHANGE CHARGE OF DIFFRACTING PARTICLE LASTPI = 0 NRESPC = 0 NRESPN = 0 NCPLUS = 0 IF ( NFLCHE .EQ. 0 ) THEN IF ( YY0 .GT. 0.D0 ) THEN C PROJECTILE DIFFRACTION CALL LEPACX( ECMDIF,DMLOG,LEPAR1,1 ) ELSE C TARGET DIFFRACTION CALL LEPACX( ECMDIF,DMLOG,LEPAR2,2 ) ENDIF ENDIF C FLUCTUATION OF MULTIPLICITY ACCORDING TO NEG.BIN. DISTRIBUTION CALL RNEGBI( NCH,AVCH,ECMDIF ) C REPEAT CALCULATION AS SOMETHING WENT WRONG IF ( NCH .LT. 1 ) THEN IF ( (YY0 .GT. 0.D0 .AND. LEPAR1 .LT. 50) .OR. * (YY0 .LT. 0.D0 .AND. LEPAR2 .LT. 50) ) THEN NREPRD = NREPRD + 1 IF ( NREPRD .GT. 10 ) GOTO 1 GOTO 1920 ELSE C DIFFRACTIVE INTERACTION IS ONLY RESONANCE PRODUCTION ISEL = 1 ENDIF ENDIF C SET RSLOG FOR CALCULATION OF PARTICLE RATIOS RSLOG = DLOGS C HERE WE USE ECMDPM, BECAUSE THE MOMENTUM TRANSFER IS DEPENDENT C ON THE ENERGY OF THE TOTAL SYSTEM AND NOT ON THE DIFFRACTING MASS CALL AVEPT( ECMDPM,SLOG ) ENDIF C----------------------------------------------------------------------- C NOW FOR NSD AND DIFFRACTIVE PROCESSES C IN CASE OF LOW MULTIPLICITY SET FLAG ISEL IF ( NCH .LE. 2 ) ISEL=1 C FNCH IS FLUCTUATING TOT.NUMBER OF CHARGED PARTICLES FOR ALL 3 STRINGS FNCH = DBLE(NCH) C RATIO ALL CHARGED PARTICLES WITH FLUCTUATION/WITHOUT FLUCTUATION XZ = FNCH / AVCH C FNCH3 IS FLUCTUATING NUMBER OF CHARGED PARTICLES FOR 3RD STRING FNCH3 = XZ * AVCH3 C FNCH2 IS FLUCTUATING NUMBER OF CHARGED PARTICLES 1ST AND 2ND STRING FNCH2 = FNCH - FNCH3 C RC3TO2 IS RATIO (CHARGED 3RD STRING)/(CHARGED 1ST AND 2ND STRING) IF ( FNCH2 .NE. 0.D0 ) THEN RC3TO2 = FNCH3 / FNCH2 ELSE RC3TO2 = 0.D0 ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) ' FNCH,FNCH2,FNCH3,RC3TO2=', * SNGL(FNCH),SNGL(FNCH2),SNGL(FNCH3),SNGL(RC3TO2) C IS NUMBER OF NEUTRALS FLUCTUATING AS NUMBER OF CHARGED ? IF ( NFLPIF .EQ. 0 .OR. IDIF .EQ. 1 .OR. * ECMDPM .LT. 60.D0 ) THEN C SET NUMBER OF GAMMAS ACCORDING TO NEG. BIN. VARIABLE XZ C AS NUMBER OF NEUTRALS FLUCTUATES AS CHARGED. SEUGF = SEUGP * XZ ZG = XZ ELSE C NFLPIF IS 1 MEANS: # OF PI(0) FLUCTUATES AS MEASURED AT COLLIDER IF ( ECMDPM .LT. 200.D0 ) THEN SEUGF = SEUGP * XZ * SEUGF = (0.0786D0*SLOG-0.010D0)*FNCH2 + (0.391D0*SLOG+0.305D0) ELSE C DETERMINE NEW NUMBER OF GAMMAS WITH FLUCTUATION AROUND SEUGP*XZ AGR = EXP( -XZ ) DGR = SEUGP * XZ * (0.9823D0 - 0.3756D0 * AGR) SGS = DGR * (0.14718D0 + 2.53213D0 * AGR) 723 CONTINUE SEUGF = 0.88D0 * RANNOR(DGR,SGS) IF ( SEUGF .LT. 1.D0 ) GOTO 723 ENDIF C SET NEGATIVE BINOMIAL VARIABLE ZG FOR GAMMAS ZG = SEUGF / SEUGP ENDIF SEUGF = MAX( 1.D0, SEUGF ) IF ( DEBUG ) WRITE(MDEBUG,*) 'HDPM :XZ,ZG,SEUGF=', * SNGL(XZ),SNGL(ZG),SNGL(SEUGF) C----------------------------------------------------------------------- C RATIO ALL-NUCLEON/ALL-CHARGED C PARAMETERISATION FROM UA5, NUCL. PHYS. B291 (1987) 445 EQ.(2.4) RNUCCH = MAX( 0.D0, -0.008D0 + 0.00865D0 * RSLOG ) C NUMBER FOR DIRECT NEUTRON/ANTINEUTRON PRODUCTION 1ST AND 2ND STRING C MULTIPLY BY 0.5 BECAUSE RATIO RNUCCH GIVES (ALL-NUCL)/(ALL-CHARGED) C AND HERE ONLY THE NEUTRON-ANTINEUTRONS ARE COUNTED FNUCN = 0.5D0 * RNUCCH * FNCH2 C RATIO (ALL CHARGED SIGMAS)/(ALL CHARGED) IS 1/3 OF ALL STRANGE BARYON C PARAMETERISATION FROM UA5, NUCL. PHYS. B291 (1987) 445 EQ.(2.5) RHYPCH = MAX( 0.D0, (-0.007D0 + 0.0028D0 * RSLOG) * OB3 ) C NEUTRAL STRANGE BARYONS ARE DOUBLE OF CHARGED STRANGE BARYONS FHYPN = 2.D0 * RHYPCH * FNCH2 C CORRECT NUMBER OF GAMMAS FROM NEUTRAL HYPERON DECAY S0-->L+GAMMA SEUGFC = MAX( 0.D0, SEUGF - 0.5D0 * FHYPN ) C RATIO CHARGED-KAON/CHARGED PIONS C PARAMETERISATION FROM UA5, NUCL. PHYS. B291 (1987) 445 EQ.(2.7) RKPI = MAX (0.D0, 0.024D0 + 0.0062D0 * RSLOG ) C RKCH IS RATIO (CHARGED-KAON)/(ALL-CHARGED) DERIVED FROM RKPI; C THE FACTOR 0.5 IN FRONT OF RNUCCH IS BECAUSE ONLY HALF OF NUCLEONS C ARE P/PBAR. THE 1.17 IS AN APROXIMATE CONVERSION FACTOR FROM C (ALL-NUCL)/(ALL-CHARGED) TO (ALL-NUCL)/(CHARGED-PI), WHICH IS A BIT C ENERGY DEPENDENT (1.14 ...1.21) SEE GEICH-GIMBEL TABLE 7.1 RKCH = RKPI / (1.D0 + RKPI + (0.5D0*RNUCCH+RHYPCH) * 1.17D0) C K0/K0-BAR FOR 1ST AND 2ND STRING C NEUTRAL KAONS ARE PRODUCED WITH THE SAME RATE AS CHARGED KAONS FKA0 = RKCH * FNCH2 C RATIO ETA/PI(0) IS ASSUMED TO BE INDEPENDENT OF ENERGY = 0.19 C SEE: ANSORGE ET AL. (UA5-COLLABORATION) Z.PHYS.C43(1989)75 * RETPI0 = 0.19D0 C RATIO ETA/PI(0) IS ASSUMED TO BE DEPENDENT ON ENERGY C SEE: GEICH-GIMBEL,INT.J.MOD.PHYS.A4(1989)1527 TAB.7.1 C HECK''S FIT: RETPI0 IS 0.06 + 0.006*RSLOG + 0.0011*RSLOG**2 RETPI0 = 0.06D0 + 0.006D0 * RSLOG + 0.0011D0 * RSLOG**2 C AUXIL1 IS FRACTION OF PI(0)/(PI(0)+ETA) AUXIL1 = 1.D0 / (1.D0 + RETPI0) C NUMBER OF GAMMAS FROM PI(0) IS 2, FROM ETA IS 3.216 IN AVERAGE; C AUXIL2 IS NUMBER OF GAMMA-PRODUCING-PARTICLES: PI(0) AND ETA AUXIL2 = SEUGFC / ( AUXIL1 * 2.D0 + (1.D0 - AUXIL1) * 3.216D0 ) FETA = (1.D0 - AUXIL1) * AUXIL2 FPI0 = AUXIL1 * AUXIL2 C CORRECT FPI0 BY DECAYS OF STRANGE BARYONS; NEUTRAL: FHYPN*0.357 C CHARGED: 0.5*FNCH2*RHYPCH*0.5157; IT YIELDS FHYPN*(0.357+0.12893) FPI0 = MAX( 0.D0, FPI0 - FHYPN * 0.486D0 ) C SUMMED NEUTRAL PARTICLES FOR 1ST AND 2ND STRING FNEUT2 = FNUCN + FKA0 + FHYPN + FETA + FPI0 C NEUTRAL PARTICLES FROM 3RD STRING FNEUT3 = RC3TO2 * FNEUT2 C TOTAL NUMBER OF NEUTRALS FNEUT = FNEUT2 + FNEUT3 NEUTOT = NINT( FNEUT ) C CALCULATE TOTAL NUMBER OF PARTICLES TO BE CREATED NTOTEM = NCH + NEUTOT IF ( DEBUG ) WRITE(MDEBUG,*) * ' FNUCN,FKA0,FHYPN,FETA,FPI0,FNEUT2,FNEUT3,NTOTEM=', * SNGL(FNUCN),SNGL(FKA0),SNGL(FHYPN),SNGL(FETA),SNGL(FPI0), * SNGL(FNEUT2),SNGL(FNEUT3),NTOTEM C LIMIT OF SECONDARIES PRODUCED (GIVEN BY SIZE OF ARRAY: 3000) C LIMIT IS ARRAY SIZE - SIZE OF LARGEST TARGET NUCLEUS(40) IF ( NTOTEM .GE. 2956 ) THEN WRITE(MONIOU,*) 'HDPM : REJECT EVENT WITH ',NTOTEM, * ' SECONDARIES' GOTO 1 ENDIF C SPECIAL TREATMENT IF MULTIPLICITY IS TOO LOW IF ( NTOTEM .LE. 3 ) ISEL = 1 C FRACTION OF THE VARIOUS NEUTRAL PARTICLES (NN, K(0), L+S0 AS PAIRS) C NORMALIZE WITH THE SUM OF ALL NEUTRAL PARTICLES FNORML = 1.D0 / ( 0.5D0 * (FNUCN+FKA0+FHYPN) + FETA + FPI0 ) RNUCNR = FNUCN * FNORML * 0.5D0 RKA0R = FKA0 * FNORML * 0.5D0 RHYPNR = FHYPN * FNORML * 0.5D0 RETAR = FETA * FNORML RPI0R = FPI0 * FNORML C CUMULATED RATIOS (NN, K(0), LAMBDA+SIGMA0 AS PAIRS) RPIER = RPI0R + RETAR RPEKR = RPIER + RKA0R RPEKNR = RPEKR + RNUCNR C THEN THE REMAINDER (1-RPEKNR) MUST BE NEUTRAL HYPERON PAIRS IF ( DEBUG ) WRITE(MDEBUG,*) * ' RPI0R,RETAR,RKA0R,RNUCNR,RHYPNR,FNORML=', * SNGL(RPI0R),SNGL(RETAR),SNGL(RKA0R),SNGL(RNUCNR),SNGL(RHYPNR), * SNGL(FNORML) C PROBABILITY TO PRODUCE CHARGED PIONS IS PROBABILITY NOT TO PRODUCE C CHARGED KAONS OR PROTONS OR CHARGED HYPERONS, WHERE PROTON/ANTIPROTON C IS HALF OF (ALL-NUCL)/(ALL-CHARGED) AUXIL = RKCH + 0.5D0 * RNUCCH + RHYPCH AUXIL3 = 1.D0 - AUXIL C RENORMALIZATION AS P/P_BAR, K+-, AND HYPERONS ARE PRODUCED IN PAIRS C AUXIL2 IS INVERSE OF NORMALISATION AUXIL2 = 1.D0 / (1.D0 - 0.5D0 * AUXIL) C CUMULATED PROBABILITIES (PP, K+-, SIGMA+- AS PAIRS) PPICH = AUXIL3 * AUXIL2 PPINCH = PPICH + 0.25D0 * RNUCCH * AUXIL2 PPNKCH = PPINCH + 0.5D0 * RKCH * AUXIL2 C THEN THE REMAINDER (1-PPNKCH) MUST BE CHARGED HYPERON PAIRS IF ( DEBUG ) WRITE(MDEBUG,*) ' PPICH,PPINCH,PPNKCH=', * SNGL(PPICH),SNGL(PPINCH),SNGL(PPNKCH) C NOW SELECT HOW MANY PARTICLES OF EACH TYPE ARE PRODUCED CALL PARNUM( INUMFL ) IF ( INUMFL .NE. 0 ) GOTO 1919 C DEFINE PARTICLE NUMBERS WHERE SPECIAL RAPIDITY IS CALCULATED C FOR PARTICLES FROM TARGET (THIRD STRING) PPP = RC3TO2 / (1.D0+RC3TO2) C NUMBER OF PARTICLES IN PROTON ANTIPROTON PAIRS FROM TARGET ITA = NINT( PPP * 2.D0 * NNC ) C NUMBER OF PARTICLES IN K+ K- PAIRS FROM TARGET ITB = NINT( PPP * 2.D0 * NKC ) C NUMBER OF PARTICLES IN SIGMA+ SIGMA- PAIRS FROM TARGET ITC = NINT( PPP * 2.D0 * NHC ) C NUMBER OF PI+ PI- FROM TARGET ITD = NINT( PPP * NPC ) C CALCULATE BOUNDARIES IA1 = 2 IA2 = IA1 + ITA IB1 = IA1 + 2 * NNC IB2 = IB1 + ITB IC1 = IB1 + 2 * NKC IC2 = IC1 + ITC ID1 = IC1 + 2 * NHC ID2 = ID1 + ITD IE1 = ID1 + NPC C NUMBER OF PARTICLES IN NEUTRON ANTINEUTRON PAIRS FROM TARGET IE2 = IE1 + 2 * NNUCN(3) IF1 = IE1 + 2 * NNN C NUMBER OF PARTICLES IN K0S K0L PAIRS FROM TARGET IF2 = IF1 + 2 * NKA0(3) IG1 = IF1 + 2 * NKN C NUMBER OF PARTICLES IN NEUTRAL HYPERON PAIRS FROM TARGET IG2 = IG1 + 2 * NHYPN(3) IH1 = IG1 + 2 * NHN C NUMBER OF ETA FROM TARGET IH2 = IH1 + NETAS(3) II1 = IH1 + NET C NUMBER OF PI(0) FROM TARGET II2 = II1 + NPIZER(3) IJ1 = II1 + NPN IF ( DEBUG ) THEN WRITE(MDEBUG,*) ' CHARGED FROM TARGET:',ITA,ITB,ITC,ITD WRITE(MDEBUG,*) ' NEUTRAL FROM TARGET:', * 2*NNUCN(3),2*NKA0(3),2*NHYPN(3),NETAS(3),NPIZER(3) WRITE(MDEBUG,*) ' NTOTEM,IJ1=',NTOTEM,IJ1 ENDIF C REDEFINE TOTAL NUMBER OF SECONDARY PARTICLES : NTOTEM C BY CHARGE EXCHANGE AND RESONANCE FORMATION THIS NUMBER MAY BE ALTERED NTOTEM = IJ1 - 2 C----------------------------------------------------------------------- C RATIO OF RAPIDITY DENSITY TO MEAN PSEUDORAPIDITY IN CENTER C PARAMETERISATION SEE CAPDEVIELLE, J.PHYS.G:NUCL.PHYS.15(1989)909,EQ.6 IF ( XZ .LT. 1.5D0 ) THEN RDS = (0.24396D0 + 0.70150424D0 * XZ)**2 ELSE RDS = (0.55685D0 + 0.48664753D0 * XZ)**2 ENDIF C CALCULATE NOW: DN/DY AT Y = 0; DC0 IS AVERAGE PSEUDORAPIDITY DENSITY C TRAP IS RATIO (RAPID.DENS.)/(PSEUDORAP.DENS.) IN CENTER OF RAPIDITY TRAP = 1.25D0 IF ( IDIF .EQ. 0 .AND. ECMDPM .GT. 19.4D0 ) * TRAP = MAX( 1.D0, 1.28852D0 - 0.0065D0 * SMLOG ) DCN2 = DC0 * RDS * TRAP IF ( DEBUG ) WRITE(MDEBUG,*) ' RDS,TRAP,DCN2=', * SNGL(RDS),SNGL(TRAP),SNGL(DCN2) C AMPLITUDE OF GAUSSIAN 1ST AND 2ND STRING ATG2 = FNCH2 / (5.0132566D0 * WIDC2) C NEW DEFINITION OF POSITION BASED ON SEMI INCLUSIVE DATA SQ2 = 2.D0 * ATG2 / DCN2 C FINAL POSITION OF GAUSSIAN; WIDTH WIDC2 IS UNCHANGED IF ( SQ2 .GT. 1.D0 ) POSC2 = WIDC2 * SQRT( 2.D0*LOG( SQ2 ) ) C DENSITY OF CHARGED IN EXCESS FROM TARGET IN CENTER OF RAPIDITY DCN3 = 0.5D0 * (GNU - 1.D0) * DCN2 IF ( DEBUG ) WRITE(MDEBUG,*) ' SQ2,POSC2,DCN3=', * SNGL(SQ2),SNGL(POSC2),SNGL(DCN3) IF ( DCN3 .GT. 0.D0 ) THEN C AMPLITUDE 3RD GAUSSIAN ATG3 = FNCH3 / (5.0132566D0 * WIDC3) C AMPLITUDE IS DIVIDED BY DENSITY FOR GETTING CENTER OF 3RD GAUSSIAN SQ3 = 2.D0 * ATG3 / DCN3 C CHECK IF ADDITIVE MULTIPLICITY IS TOO LOW IF ( SQ3 .GT. 1.D0 ) POSC3 = WIDC3 * SQRT( 2.D0*LOG( SQ3 ) ) IF (DEBUG) WRITE(MDEBUG,*)' SQ3,POSC3=',SNGL(SQ3),SNGL(POSC3) ENDIF C NFLPI0 .EQ. 0 MEANS TREAT PI(0) RAPIDITY ACCORDING TO COLLIDER DATA IF ( NFLPI0 .EQ. 0 ) THEN C RATIO OF RAPIDITY DENSITY TO MEAN PSEUDORAPIDITY AT CENTER WITH Z<1.5 IF ( ZG .LT. 1.5D0 ) THEN RDG = (0.24396D0 + 0.70150424D0 * ZG)**2 ELSE RDG = (0.55685D0 + 0.48664753D0 * ZG)**2 ENDIF C GAMMAS USE RATIO TRAG TO CALCULATE RATIO OF RAPIDITY TO C PSEUDO RAPIDITY DENSITY IN CENTER (TRAG = 1.1 * 0.5 ). C FACTOR 0.5 COMES FROM RATIO NEUTRAL/CHARGED, AS WE USE DC0, WHICH C IS AVERAGE PSEUDORAPIDITY DENSITY FOR CHARGED PIONS TRAG = 0.55D0 IF ( IDIF .EQ. 0 ) THEN IF ( ECMDPM .GT. 19.4D0 ) * TRAG = MAX( 0.4D0, 0.6658D0 - 0.01954D0 * SMLOG ) IF ( ECMDPM .LE. 50.D0 ) THEN DCG = DC0 * RDG * TRAG ELSEIF ( ECMDPM .LE. 200.D0 ) THEN DCG = DC0 * RDG * TRAG * (1.D0 + 0.18D0 * LOG(ECMDPM/50.D0)) ELSE DCG = DC0 * RDG * TRAG * 1.25D0 ENDIF ELSE DCG = DC0 * RDG * TRAG ENDIF C DEFINE WIDTH OF STRINGS FOR NEUTRAL PIONS AND ETAS WIDN2 = WIDC2 * MIN( 1.D0, 1.12275D0 - 0.0208D0 * RSLOG ) C NEW DEFINITION OF CENTER OF GAUSSIAN BASED ON SEMI INCLUSIVE DATA C USING AMPLITUDE OF THE GAUSSIAN FOR NEUTRALS AUXIL = 2.D0 / (5.0132566D0 * WIDN2 * DCG) C TOTAL MULTIPLICITY USED FOR 1ST AND 2ND STRING OF PI(0) AND ETA C IS GIVEN BY THEIR NUMBERS. ANALOGOUS FOR 3RD STRING SP2 = DBLE ( NPIZER(2)+NETAS(2)) * AUXIL C FINAL CENTER OF GAUSSIANS FOR PI(0) AND ETA (WIDC2 IS UNCHANGED) IF ( SP2 .GT. 1.D0 ) THEN POSN2 = WIDN2 * SQRT( 2.D0 * LOG( SP2 ) ) ELSE POSN2 = POSC2 ENDIF WIDN3 = WIDN2 SP3 = DBLE(NPIZER(3)+NETAS(3)) * AUXIL IF ( SP3 .GT. 1.D0 ) THEN POSN3 = WIDN3 * SQRT( 2.D0 * LOG( SP3 ) ) ELSE POSN3 = POSC3 ENDIF ELSE C NFLPI0 .EQ. 1 MEANS RAPIDITY OF PI(0) AND ETA SAME AS THAT OF CHARGED POSN2 = POSC2 WIDN2 = WIDC2 POSN3 = POSC3 WIDN3 = WIDC3 ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) * ' ZG,RDG,DCG,SP2,SP3,POSN2,POSN3,WIDN2 =', * SNGL(ZG),SNGL(RDG),SNGL(DCG),SNGL(SP2),SNGL(SP3),SNGL(POSN2), * SNGL(POSN3),SNGL(WIDN2) C----------------------------------------------------------------------- NREPR1 = 0 C RETURN POINT. NUMBERS OF PARTICLES REMAIN UNCHANGED FOR NEXT TRY, C BUT INDIVIDUAL RAPIDITIES GET NEW VALUES. C START FROM BEGINNING IF NO MATCH AFTER 20 TRIES 30 CONTINUE NREPR1 = NREPR1 + 1 IF ( NREPR1 .GT. 20 ) THEN IF ( IDIF .EQ. 1 .AND. NREPRD .LE. 10 ) GOTO 1919 GOTO 1 ENDIF C FOR TOTAL NUMBER OF PARTICLES ADD 2 FOR LEADER AND ANTILEADER NTOT = NTOTEM + 2 C PRODUCTION OF INDIVIDUAL RAPIDITIES FOR ALL SECONDARY PARTICLES CALL PARRAP CC IF ( DEBUG ) THEN CC WRITE(MDEBUG,*) ' RAPIDITIES:' CC WRITE(MDEBUG,134) (I,YR(I), I=3,NTOT) C134 FORMAT(' ',1P, (1X, I4, 5X, G13.6 )) CC ENDIF C CALCULATION OF CENTRAL RAPIDITY WITHOUT (ANTI)LEADER C MULTIPLICITY IN CENTER OF RAPIDITY DISTRIBUTION IZN = 0.D0 IF ( IDIF .EQ. 0 ) THEN DO I = 3, NTOT IF ( ABS(YR(I)) .LT. DELRAP ) IZN = IZN + 1 ENDDO IF ( IZN .LT. 1 ) THEN IF ( ISEL .EQ. 0 ) GOTO 30 C IN CASE OF FEW PARTICLES, SET PARTICLE NUMBER IN PLATEAU TO 1 IZN = 1 ENDIF C CENTRAL RAPIDITY DENSITY FOR CHARGED PARTICLES IF ( NTOTEM .GE. 1 ) THEN ZNC = MAX( 1.1D0, DBLE(NCH)*IZN/(DBLE(NTOTEM)*2.D0*DELRAP) ) ELSE ZNC = 1.1D0 ENDIF ELSE C DIFFRACTION: SHIFT RAPIDITIES + TAKE CENT.RAP.DENS. FROM PARAMETERISAT DO I = 3, NTOT YR(I) = YR(I) + YY0 ENDDO ZNC = MAX( 1.1D0, DCN2 ) ENDIF C ZN ACCOUNTS FOR THE RISE OF PT WITH CENTRAL RAP.DENSITY. THE FORMULA C IS A FIT TO UA1 VALUES OF ARNISON ET AL, PHYS.LETT.B118(1982)167 C REGARD, THAT OUR ZN IS DEFINED DIFFERENT FROM LITERATURE N BY 1 C - - - - - - C MODIFICATION AFTER J.N. CAPDEVIELLE, (DEC.96) * IF ( ECMDPM .LE. 500.D0 ) THEN * ZN = MAX( 1.00001D0, 3.669D0 / ZNC**0.435D0 + 6.4D0 ) * ELSE C TAKE INTO ACCOUNT THE RESULTS OF UA1/MIMI EXPERIMENT C FOR SMALL CENTR. RAP. DENS. RHOC < 3.00 (MIMI)(TO BE USED IN PTRAM) IF ( ZNC .LT. 3.D0 ) THEN PTAVE = 0.0033D0 * (ZNC-1.56D0)**2 + 0.406D0 ELSE C FOR LARGE CENTR. RAP. DENSITIES PTAVE = ZNC*0.010853D0 + 0.3828D0 ENDIF ZN = 2.64D0/PTAVE + 3.D0 * ENDIF C - - - - - - C NOW SET PARTICLE TYPE AND TRANSV. MOMENTA FOR NEW PARTICLES IN PPARAM C SET ALSO TRANSVERSE MASS FOR ALL PARTICLES (INCL. LEADER+ANTILEADER) CALL PPARAM IF ( IDIF .EQ. 0 ) THEN C NOW SET THE RAPIDITY OF THE ANTILEADER ACCORDING TO THE DISTRIBUTION C IN THE FEYNMAN X VARIABLE; SET THE RAPIDITY OF LEADER TO CONSUME C THE REMAINDER OF ENERGY CALL LEDENY( LEDEFL ) IF ( LEDEFL .NE. 0 ) THEN IF ( DEBUG ) WRITE(MDEBUG,*) ' LEDEFL=',LEDEFL GOTO 30 ENDIF C CALCULATE FOR SINGLE COLLISION SYSTEM C.M. ENERGY + RAPIDITY SHIFT IF ( GNU .LE. 1.D0 ) THEN JGNU = 0.D0 DYGNU = 0.D0 ECMJAD = ECMDPM ELSE C MULTIPLE COLLISION IN TARGET JGNU = NINT( GNU-1.D0 ) C ADD ADDITIONALLY INTERACTING C TARGET NUCLEONS TO GET CORRECT JADACH FILTERING C CHOSE RANDOMLY WHETHER PROTON OR NEUTRON CALL RMMARD( RD,JGNU,1 ) IPR = 0 INE = 0 TARMAS = PAMA(ITYP(2)) DO I = 1, JGNU NTOT = NTOT + 1 IF ( RD(I) .LE. .5D0 ) THEN ITYP(NTOT) = 13 INE = INE + 1 ELSE ITYP(NTOT) = 14 IPR = IPR + 1 ENDIF TMAS(NTOT) = PAMA(ITYP(NTOT)) TARMAS = TARMAS + TMAS(NTOT) EA(NTOT) = TMAS(NTOT) PX(NTOT) = 0.D0 PY(NTOT) = 0.D0 PT2(NTOT) = 0.D0 ENDDO C CALCULATE C.M. ENERGY + RAPIDITY SHIFT CDH YCMGNU = 0.5D0 * LOG( (ELAB+TARMAS+PLAB)/(ELAB+TARMAS-PLAB) ) YCMGNU = 0.5D0 * LOG( (EPLUSP**2 +TARMAS*EPLUSP)/ * (PAMA(ITYPE)**2+TARMAS*EPLUSP) ) DYGNU = YCM - YCMGNU C CALCULATE RAPIDITIES OF ADDITIONALLY INTERACTING TARGET NUCLEONS C IN THE CM SYSTEM OF NUCLEON-NUCLEON SYSTEM DO I = NTOT-JGNU+1, NTOT YR(I) = - YCM ENDDO C SHIFT RAPIDITIES INTO CM SYSTEM OF GNU+1 MASSES DO I = 1, NTOT YR(I) = YR(I) + DYGNU ENDDO C CENTER OF MASS ENERGY OF 1 PROJECTILE AND GNU TARGET NUCLEONS TO C BE USED IN THE JADACH FILTER. ECMJAD = SQRT( PAMA(ITYPE)**2 + TARMAS**2 + 2.D0*TARMAS*ELAB ) ENDIF ELSE C IN CASE OF DIFFRACTION SET THE RAPIDITY OF LEADER AND ANTILEADER C IN SUBROUT. LEADDF DYGNU = 0.D0 ECMJAD = ECMDPM CALL LEADDF( IFLGLD ) IF ( IFLGLD .NE. 0 ) THEN IF ( DEBUG ) WRITE(MDEBUG,*) ' IFLGLD=',IFLGLD GOTO 30 ENDIF ENDIF C CORRECT THE RAPIDITIES TO CONSERVE LONGITUDINAL MOMENTA AND ENERGY C USING THE ALGORITHM OF JADACH (SIMPLIFIED VERSION BY R. ATTALLAH) CALL JADACH( ECMJAD,JADFLG ) IF ( JADFLG .NE. 0 ) THEN IF ( DEBUG ) WRITE(MDEBUG,*) ' JADFLG=', JADFLG IF ( JADFLG .GT. 0 ) GOTO 30 IF ( JADFLG .LT. 0 ) THEN NREPRD = NREPRD + 1 IF ( NREPRD .GT. 10 ) GOTO 1 GOTO 1919 ENDIF ENDIF #if __INTTEST__ C REMEMBER ECM INCLUDING THE INTERACTING TARGET NUCLEONS ECMEFF = ECMJAD C ADD THE SPECTATORS IN THE TARGET FOR COMPLETENESS IF ( TAR .EQ. 14.D0 ) THEN IINE = 7 IIPR = 7 ELSEIF ( TAR .EQ. 16.D0 ) THEN IINE = 8 IIPR = 8 ELSEIF ( TAR .EQ. 40.D0 ) THEN IINE = 22 IIPR = 18 ELSEIF ( TAR .EQ. 1.D0 ) THEN IINE = 0 IIPR = 1 ELSEIF ( TAR .EQ. 2.D0 ) THEN IINE = 1 IIPR = 0 ELSEIF ( TAR .EQ. 9.D0 ) THEN IINE = 5 IIPR = 4 ELSEIF ( TAR .EQ. 12.D0 ) THEN IINE = 6 IIPR = 6 ELSE WRITE(MONIOU,*) 'HDPM : ILLEGAL TAR =',SNGL(TAR) ENDIF C COUNT AS WELL THE ANTILEADER IF ( ITAR .EQ. 14 ) THEN IPR = IPR + 1 ELSE INE = INE + 1 ENDIF C ADD NEUTRONS DO I = INE+1, IINE NTOT = NTOT + 1 ITYP(NTOT) = 13 TMAS(NTOT) = PAMA(ITYP(NTOT)) EA(NTOT) = TMAS(NTOT) PX(NTOT) = 0.D0 PY(NTOT) = 0.D0 PT2(NTOT) = 0.D0 YR(NTOT) = DYGNU - YCM ENDDO C ADD PROTONS DO I = IPR+1, IIPR NTOT = NTOT + 1 ITYP(NTOT) = 14 TMAS(NTOT) = PAMA(ITYP(NTOT)) EA(NTOT) = TMAS(NTOT) PX(NTOT) = 0.D0 PY(NTOT) = 0.D0 PT2(NTOT) = 0.D0 YR(NTOT) = DYGNU - YCM ENDDO #endif C CALCULATE LAB ENERGIES OF SECONDARY PARTICLES FROM THE RAPIDITIES C INCLUDING THE ADDITIONAL TARGET NUCLEONS ETOT = 0.D0 DO I = 1, NTOT YR(I) = YR(I) + YCM - DYGNU EA(I) = TMAS(I) * COSH( YR(I) ) ETOT = ETOT + EA(I) ENDDO IF ( DEBUG ) WRITE(MDEBUG,136) * (I,ITYP(I),PX(I),PY(I),YR(I),EA(I),I=1,NTOT) 136 FORMAT(' NO ITYP PX PY YR EA'/ * (' ',I4,I3,1X,1P,4G13.6) ) C----------------------------------------------------------------------- C LOOP OVER ALL SECONDARY PARTICLES AND THE LEADING PARTICLE C PROCESS LOOP DO 140 J = 1, NTOT #if !__INTTEST__ C REJECTION OF BACKWARD GOING PARTICLES IF ( YR(J) .LE. 0.D0 ) THEN IF ( DEBUG ) WRITE(MDEBUG,*) 'HDPM : YR REJECT PARTICLE ',J IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT IF ( ITYP(J) .EQ. 8 .OR. ITYP(J) .EQ. 9 .OR. * ITYP(J) .EQ. 11 .OR. ITYP(J) .EQ. 12 ) THEN FAC1 = 0.25D0 FAC2 = 0.75D0 ELSEIF ( ITYP(J) .EQ. 10 .OR. ITYP(J) .EQ. 16 ) THEN FAC1 = 0.5D0 FAC2 = 0.5D0 ELSE FAC1 = 1.D0 FAC2 = 0.D0 ENDIF #if __THIN__ C ADD TO THE HADRON ENERGY DEPOSIT DLONG(LHEIGH,17) = DLONG(LHEIGH,17) + ( EA(J) * - RESTMS(ITYP(J)) ) * WEIGHT*FAC1 C ADD TO THE NEUTRINO DEPOSIT DLONG(LHEIGH,18) = DLONG(LHEIGH,18) + ( EA(J) * - RESTMS(ITYP(J)) ) * WEIGHT*FAC2 #else C ADD TO THE HADRON ENERGY DEPOSIT DLONG(LHEIGH,17) = DLONG(LHEIGH,17) + ( EA(J) * - RESTMS(ITYP(J)) ) * FAC1 C ADD TO THE NEUTRINO DEPOSIT DLONG(LHEIGH,18) = DLONG(LHEIGH,18) + ( EA(J) * - RESTMS(ITYP(J)) ) * FAC2 #endif ENDIF #if __AUGERHIST__ GOTO 138 #else GOTO 140 #endif ENDIF #endif C CALCULATE THE PROPERTIES OF ALL SECONDARIES C PARTICLE TYPE SECPAR(0) = ITYP(J) C CALCULATE GAMMA FACTOR SECPAR(1) = EA(J) / PAMA(ITYP(J)) C TOTAL MOMENTUM SQUARED PTM = ( EA(J)-PAMA(ITYP(J)) ) * ( EA(J)+PAMA(ITYP(J)) ) IF ( PT2(J) .GT. PTM ) THEN IF ( DEBUG ) WRITE(MDEBUG,*) 'HDPM : PT REJECT PARTICLE ',J IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT IF ( ITYP(J) .EQ. 8 .OR. ITYP(J) .EQ. 9 .OR. * ITYP(J) .EQ. 11 .OR. ITYP(J) .EQ. 12 ) THEN FAC1 = 0.25D0 FAC2 = 0.75D0 ELSEIF ( ITYP(J) .EQ. 10 .OR. ITYP(J) .EQ. 16 ) THEN FAC1 = 0.5D0 FAC2 = 0.5D0 ELSE FAC1 = 1.D0 FAC2 = 0.D0 ENDIF #if __THIN__ C ADD TO THE HADRON ENERGY DEPOSIT DLONG(LHEIGH,17) = DLONG(LHEIGH,17) + ( EA(J) * - RESTMS(ITYP(J)) ) * WEIGHT*FAC1 C ADD TO THE NEUTRINO DEPOSIT DLONG(LHEIGH,18) = DLONG(LHEIGH,18) + ( EA(J) * - RESTMS(ITYP(J)) ) * WEIGHT*FAC2 #else C ADD TO THE HADRON ENERGY DEPOSIT DLONG(LHEIGH,17) = DLONG(LHEIGH,17) + ( EA(J) * - RESTMS(ITYP(J)) ) * FAC1 C ADD TO THE NEUTRINO DEPOSIT DLONG(LHEIGH,18) = DLONG(LHEIGH,18) + ( EA(J) * - RESTMS(ITYP(J)) ) * FAC2 #endif ENDIF #if __AUGERHIST__ GOTO 138 #else GOTO 140 #endif ENDIF C EMISSION ZENITH ANGLE AGAINST TRAJECTORY OF PROJECTILE IF ( PTM .LE. 0.D0 ) THEN COSTET = 0.D0 PTOT = 0.D0 CPHIJ = 1.D0 SPHIJ = 0.D0 ELSE COSTET = SQRT( 1.D0 - PT2(J) / PTM ) PTOT = SQRT( PTM ) C EMISSION AZIMUTH ANGLE CPHIJ = PX(J) / PTOT SPHIJ = PY(J) / PTOT ENDIF #if __INTTEST__ C IF ( COSTET .EQ. 0.D0 ) COSTET = 1.D-4 IF ( YR(J) .LT. 0.D0 ) COSTET = -COSTET SECPAR(17) = SQRT( PX(J)**2 + PY(J)**2 ) #endif CALL ADDANG4( COSTHE,PHIX,PHIY, COSTET,CPHIJ,SPHIJ, * SECPAR(2),SECPAR(3),SECPAR(4) ) #if __UPWARD__ IF ( SECPAR(2) .LT. -1.D0 ) THEN #else IF ( SECPAR(2) .LT. C(29) ) THEN #endif C OMIT UPWARD GOING PARTICLES IF (DEBUG) WRITE(MDEBUG,*) 'HDPM : ANGLE REJECT PARTICLE ',J IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT IF ( ITYP(J) .EQ. 8 .OR. ITYP(J) .EQ. 9 .OR. * ITYP(J) .EQ. 11 .OR. ITYP(J) .EQ. 12 ) THEN FAC1 = 0.25D0 FAC2 = 0.75D0 ELSEIF ( ITYP(J) .EQ. 10 .OR. ITYP(J) .EQ. 16 ) THEN FAC1 = 0.5D0 FAC2 = 0.5D0 ELSE FAC1 = 1.D0 FAC2 = 0.D0 ENDIF #if __THIN__ C ADD TO THE HADRON ENERGY DEPOSIT DLONG(LHEIGH,17) = DLONG(LHEIGH,17) + ( EA(J) * - RESTMS(ITYP(J)) ) * WEIGHT*FAC1 C ADD TO THE NEUTRINO DEPOSIT DLONG(LHEIGH,18) = DLONG(LHEIGH,18) + ( EA(J) * - RESTMS(ITYP(J)) ) * WEIGHT*FAC2 #else C ADD TO THE HADRON ENERGY DEPOSIT DLONG(LHEIGH,17) = DLONG(LHEIGH,17) + ( EA(J) * - RESTMS(ITYP(J)) ) * FAC1 C ADD TO THE NEUTRINO DEPOSIT DLONG(LHEIGH,18) = DLONG(LHEIGH,18) + ( EA(J) * - RESTMS(ITYP(J)) ) * FAC2 #endif ENDIF #if __AUGERHIST__ GOTO 139 #else GOTO 140 #endif ENDIF C PUT SECONDARY PARTICLES ON STACK, IF NOT GOING UPWARDS IF ( J .GT. 2 ) THEN #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER PARTICLE DO IK = 0, 8 SECPAR(IK+17) = SECPAR(IK) ENDDO #if __THIN__ SECPAR(26) = SECPAR(13) #endif #endif CALL TSTACK ELSE C PUT LEADER OR ANTI-LEADER ON STACK, IF NOT GOING UPWARDS IF ( ITYP(J) .GT. 50 ) THEN C LEADER OR ANTI LEADER ARE RESONANCES AND DECAY IRESPAR = IRESPAR + 1 IF ( IRESPAR .GE. 1000000 ) THEN WRITE(MONIOU,*) * 'HDPM : STACK OF RESDEC RANDOM NUMBERS FULL' IRESPAR = 999999 ENDIF RESRAN(IRESPAR) = RDRES(J) SECPAR(0) = SECPAR(0) + IRESPAR * 1.D-7 C COUNTER FOR ENERGY-MULTIPLICITY MATRIX MSMM = MSMM + 1 ENDIF #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER PARTICLE DO IK = 0, 8 SECPAR(IK+17) = SECPAR(IK) ENDDO #if __THIN__ SECPAR(26) = SECPAR(13) #endif #endif CALL TSTACK C CALCULATE ELASTICITY FROM ENERGY OF LEADER (REST OF RESONANCE DECAY) IF ( J .EQ. 1 ) THEN ELASTI = SECPAR(1) * PAMA(NINT( SECPAR(0) )) / ELAB ENDIF ENDIF C COUNTERS FOR FIRST INTERACTION IF ( FIRSTI ) THEN IF ( SECPAR(0) .EQ. 7.D0 .OR. SECPAR(0) .EQ. 8.D0 * .OR. SECPAR(0) .EQ. 9.D0 ) THEN IFINPI = IFINPI + 1 ELSEIF ( SECPAR(0) .EQ. 13.D0 .OR. SECPAR(0) .EQ. 14.D0 * .OR. SECPAR(0) .EQ. 15.D0 .OR. SECPAR(0) .EQ. 25.D0) THEN IFINNU = IFINNU + 1 ELSEIF ( SECPAR(0) .EQ. 10.D0 .OR. SECPAR(0) .EQ. 11.D0 * .OR. SECPAR(0) .EQ. 12.D0 .OR. SECPAR(0) .EQ. 16.D0) THEN IFINKA = IFINKA + 1 ELSEIF ( SECPAR(0) .GE. 71.D0 .AND. SECPAR(0) .LE. 74.D0) THEN IFINET = IFINET + 1 ELSEIF ((SECPAR(0) .GE. 18.D0 .AND. SECPAR(0) .LE. 24.D0) * .OR. (SECPAR(0) .GE. 26.D0 .AND. SECPAR(0) .LE. 32.D0))THEN IFINHY = IFINHY + 1 ELSEIF ( SECPAR(0) .GE. 51.D0 .AND. SECPAR(0) .LT. 54.D0) THEN IFINRHO = IFINRHO + 1 ELSE IFINOT = IFINOT + 1 ENDIF ENDIF #if __AUGERHIST__ GOTO 140 138 CONTINUE SECPAR(2) = -1.D0 SECPAR(3) = 1.D0 SECPAR(4) = 0.D0 SECPAR(0) = 0.D0 139 CONTINUE THICKLOC = THICK( H ) DO LL = 1, NOBSLV IF ( THICKLOC .GE. THCKOB(LL) .AND. * THICKLOC .LT. THCKOB(LL)+SAMPTH ) THEN C THICKH IS WITHIN 1 G/CM^2 BELOW OBSLEV(LL) C BRING THE ENERGY BELOW ANGULAR CUT TO THE HISTO OF LEVEL LL OUTPAR(0) = ITYP(J) OUTPAR(1) = EA(J) / PAMA(ITYP(J)) DO II = 2, 8 OUTPAR(II) = SECPAR(II) ENDDO OUTPAR( 9) = GEN OUTPAR(10) = ALEVEL OUTPAR(13) = WEIGHT EDEP = ( EA(J) - RESTMS(ITYP(J)) ) * WEIGHT C WE HAVE ANGULAR CUT CALL AUGERDEPFIL( EDEP,LL,1 ) ELSEIF ( THICKLOC .LT. THCKOB(LL) ) THEN GOTO 111 ENDIF ENDDO 111 CONTINUE #endif 140 CONTINUE C COUNTER FOR ENERGY-MULTIPLICITY MATRIX MSMM = MSMM + NTOT - 2 C FILL ELASTICITY IN MATRICES MEL = MIN ( 1.D0+10.D0* MAX( 0.D0, ELASTI ) , 11.D0 ) MEN = MIN ( 4.D0+ 3.D0*LOG10(MAX( .1D0, EKINL )), 40.D0 ) #if __THIN__ IELDPM(MEN,MEL) = IELDPM(MEN,MEL) + NINT( WEIGHT ) IELDPA(MEN,MEL) = IELDPA(MEN,MEL) + NINT( WEIGHT ) IF ( ELASTI .LT. 1.D0 ) THEN ELMEAN(MEN) = ELMEAN(MEN) + ELASTI * WEIGHT ELMEAA(MEN) = ELMEAA(MEN) + ELASTI * WEIGHT #else IELDPM(MEN,MEL) = IELDPM(MEN,MEL) + 1 IELDPA(MEN,MEL) = IELDPA(MEN,MEL) + 1 IF ( ELASTI .LT. 1.D0 ) THEN ELMEAN(MEN) = ELMEAN(MEN) + ELASTI ELMEAA(MEN) = ELMEAA(MEN) + ELASTI #endif ENDIF #if __COASTUSERLIB__ coastProjId = nint(curpar(0)) coastTargId = nint(tar) coastX = curpar(7) coastY = curpar(8) #if __CURVED__ coastZ = curpar(14) #else coastX = coastX - XOFF(NOBSLV) coastY = coastY - YOFF(NOBSLV) coastZ = curpar(5) #endif coastT = curpar(6) coastE = pama(coastProjId)*curpar(1) coastCX = sigair coastEl = elasti call interaction(coastX) #endif IF ( FIRSTI ) THEN TARG1I = TAR SIG1I = SIGAIR ELAST = ELASTI C RANDOM GENERATOR STATUS (SEQUENCE L=1) AT END OF EVENT LL = 1 CALL RMMAQD( ISEED(1,LL),LL,'R' ) C SEED ISEED1I(1) = ISEED(1,LL) C NUMBER OF CALLS ISEED1I(2) = ISEED(2,LL) C NUMBER OF BILLIONS ISEED1I(3) = ISEED(3,LL) FIRSTI = .FALSE. ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) 'HDPM : ELAST=',SNGL(ELASTI), * SNGL(ETOT),SNGL(ELAB) RETURN END *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE JADACH( ECMJAD,JADFLG ) C----------------------------------------------------------------------- C JADACH (FILTER) C C ADJUSTS THE RAPIDITIES OF ALL SECONDARIES SUCH THAT C ENERGY AND LONGITUDINAL MOMENTUM ARE CONSERVED AT THE SAME TIME. C THE ALGORITHM IS TAKEN FROM S.JADACH, COM.PHYS.COMM. 9 (1975) 297 C THE ROUTINE MUST BE CALLED AFTER THE PT IS CONSERVED AND BEFORE C THE TRANSFORMATION TO THE LAB SYSTEM IS DONE. C THIS SUBROUTINE IS CALLED FROM HDPM. C ARGUMENTS: C ECMJAD = CM ENERGY IN THE PROJECTILE -- GNU*NUCLEONS SYSTEM (GEV) C JADFLG = 0 JADACH FILTER CORRECTLY ENDED C = 1 BAD RAPIDITIES, SELECT RAPIDITIES AGAIN C =-1 SUM OF TRANSVERSE MASSES EXCEEDS AVAILABLE CM ENERGY C----------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) #define __INTERINC__ #define __NEWPARINC__ #define __PAMINC__ #define __RUNPARINC__ #include "corsika.h" DOUBLE PRECISION YRJAD(3000) SAVE DATA EPS / 1.D-7 / C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'JADACH: NTOT=',NTOT JADFLG = 0 C SUM UP TRANSVERSE MOMENTA AND COMPARE WITH AVAILABLE C.M.ENERGY STMAS = 0.D0 ECMI = 1.D0 / ECMJAD DO I = 1, NTOT STMAS = STMAS + TMAS(I) YRJAD(I) = YR(I) ENDDO REST = ( ECMJAD - STMAS ) * ECMI IF ( REST .LE. 0.D0 ) THEN C SUMMED TRANSVERSE MASS > AVAILABLE C.M. ENERGY JADFLG = -1 RETURN ENDIF FACT = 1.5D0 / REST AA = 1.D0 DIFOLD = 0.D0 KCOUNT = 0 C OPTIMIZATION LOOP TO DEFINE PARAMETER AA 1 CONTINUE KCOUNT = KCOUNT + 1 IF ( KCOUNT .GE. 50 ) GOTO 999 C FORM SUMS S1 AND S2 S1 = 0.D0 S2 = 0.D0 DO I = 1, NTOT EXPO = EXP( AA * YR(I) ) S1 = S1 + TMAS(I) * ECMI * EXPO S2 = S2 + TMAS(I) * ECMI / EXPO ENDDO DIFF = 0.1D0 * LOG( S1*S2 ) C ACCELERATING OF CONVERGENCE IF NO CHANGE OF SIGN IN DIFF IF ( DIFOLD*DIFF .GE. 0.D0 ) DIFF = DIFF * FACT DIFOLD = DIFF IF ( DEBUG ) WRITE(MDEBUG,*) ' DIFF=',SNGL(DIFF) AA = AA * MAX( 0.1D0, (1.D0 - DIFF) ) IF ( ABS(DIFF) .GT. EPS ) GOTO 1 C ITERATION HAS CONVERGED, CALCULATE PARAMETER BB BB = 0.5D0 * LOG( S2/S1 ) IF ( DEBUG ) WRITE(MDEBUG,110) KCOUNT,STMAS,REST 110 FORMAT(' KCOUNT, STMAS, REST = ',I5,2E13.5,/ * ' NUM ITYP TMAS YR(OLD) YR(NEW)') C CORRECT RAPIDITIES DO I = 1, NTOT YR(I) = AA * YR(I) + BB IF ( DEBUG ) WRITE(MDEBUG,111) I,ITYP(I),TMAS(I),YRJAD(I),YR(I) 111 FORMAT(' ',I4,I6,F12.5,2F16.8) C IMPOSSIBLE RAPIDITY, DETERMINE AGAIN THE RAPIDITIES IF ( ABS(YR(I)) .GT. LOG(ECMJAD/PAMA(ITYP(I))) ) GOTO 999 ENDDO RETURN C ERROR EXIT 999 JADFLG = 1 C NO CONVERGENCE AFTER 50 ITERATIONS OR IMPOSSIBLE RAPIDITY RETURN END *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE LEADDF( IFLGLD ) C----------------------------------------------------------------------- C LEAD(ING PARTICLE RAPIDITY FOR) D(I)F(FFRACTING SYSTEM) C C SELECTS THE RAPIDITY OF THE (ANTI)LEADING PARTICLES IN CASE OF C DIFFRACTION. THE NON-DIFFRACTING (ANTI)LEADER GETS ITS RAPIDITY C FROM THE REMAINDER ENERGY, THE DIFFRACTING (ANTI)LEADER GETS ITS C RAPIDITY FROM THE GAUSSIAN (STRING) OF THE DECAYING DIFFRACTIVE MASS. C THIS SUBROUTINE IS CALLED FROM HDPM. C ARGUMENT: C IFLGLD = 0 RAPIDITY SELECTION SUCCESSFUL C = 1 RAPIDITY SELECTION NOT SUCCESSFULL C----------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) #define __INTERINC__ #define __LEPARINC__ #define __NEWPARINC__ #define __RANDPAINC__ #define __RUNPARINC__ #include "corsika.h" DOUBLE PRECISION RANNOR SAVE EXTERNAL RANNOR C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'LEADDF: LEPAR1,LEPAR2=', * LEPAR1,LEPAR2 IF ( YY0 .GT. 0.D0 ) THEN C PROJECTILE DIFFRACTION; CALCULATE TARGET RAPIDITY USING TARGET C ENERGY ECMTAR AND LONGITUDINAL MOMENTUM PCMTAR THE IN C.M. SYSTEM ECMTAR = (ECMDPM**2 - ECMDIF**2 + TMAS(2)**2) / (2.D0 * ECMDPM) PTLSQ = (ECMTAR-TMAS(2)) * (ECMTAR+TMAS(2)) IF ( PTLSQ .LE. 0.D0 ) THEN IFLGLD = 1 RETURN ENDIF PCMTAR = SQRT( PTLSQ ) CDH YR(2) = (-0.5D0) * LOG( (ECMTAR+PCMTAR) / (ECMTAR-PCMTAR) ) YR(2) = -LOG( (ECMTAR+PCMTAR) / TMAS(2) ) C RAPIDITY OF DIFFRACTING PROJECTILE CALL RMMARD( RD,1,1 ) IF ( RD(1) .GE. 0.5D0 ) THEN YR(1) = RANNOR( POSC2, WIDC2 ) + YY0 ELSE YR(1) = RANNOR(-POSC2, WIDC2 ) + YY0 ENDIF ELSE C TARGET DIFFRACTION; CALCULATE PROJECTILE RAPIDITY USING PROJECTILE C ENERGY ECMPRO AND LONGITUDINAL MOMENTUM PLPRO IN THE C.M. SYSTEM ECMPRO = (ECMDPM**2 -ECMDIF**2 +TMAS(1)**2) / (2.D0*ECMDPM) PPLSQ = (ECMPRO-TMAS(1)) * (ECMPRO+TMAS(1)) IF ( PPLSQ .LE. 0.D0 ) THEN IFLGLD = 1 RETURN ENDIF PCMPRO = SQRT( PPLSQ ) CDH YR(1) = 0.5D0 * LOG( (ECMPRO+PCMPRO) / (ECMPRO-PCMPRO) ) YR(1) = LOG( (ECMPRO+PCMPRO) / TMAS(1) ) C RAPIDITY OF DIFFRACTING TARGET NUCLEON CALL RMMARD( RD,1,1 ) IF ( RD(1) .GE. 0.5D0 ) THEN YR(2) = RANNOR( POSC2, WIDC2 ) + YY0 ELSE YR(2) = RANNOR(-POSC2, WIDC2 ) + YY0 ENDIF ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) 'LEADDF: YR(2),YR(1)=', * SNGL(YR(2)),SNGL(YR(1)) IFLGLD = 0 RETURN END *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE LEDENY( LEDEFL ) C----------------------------------------------------------------------- C LE(A)D(ER''S) EN(ERG)Y C C SELECTS THE FEYNMAN X OF THE ANTILEADING PARTICLES FROM A THEORETICAL C DISTRIBUTION AND CALCULATES THE RAPIDITY FROM IT. C CALCULATE THE RAPIDITY OF THE LEADER FROM THE REMAINDER OF ENERGY. C THIS SUBROUTINE IS CALLED FROM HDPM. C ARGUMENT: C LEDEFL = 0 CORRECT ENDING OF LEDENY C = 1 NOT CORRECT ENDING OF LEDENY C----------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) #define __INTERINC__ #define __LEPARINC__ #define __NEWPARINC__ #define __PAMINC__ #define __PARPARINC__ #define __PARPAEINC__ #define __RANDPAINC__ #define __RUNPARINC__ #define __VKININC__ #include "corsika.h" SAVE DATA SL / 3.D0 / C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'LEDENY: ITYPE,ITAR=',ITYPE,ITAR C BETACM IS AVAILABLE IN COMMON /VKIN/ BUT NOT FOR PHOTOPRODUCTION IF ( ITYPE .EQ. 7 ) BETACM = SQRT( (GCM-1.D0)*(GCM+1.D0) ) / GCM C MOMENTUM OF INCOMING TARGET IN CM SYSTEM PNT = PAMA(ITAR) * GCM * BETACM IF ( DEBUG ) WRITE(MDEBUG,*) 'LEDENY: PNT=',SNGL(PNT) C GET FEYNMAN X FOR ANTILEADER DEPENDING ON ENERGY C DISCRIPTION OF THE FEYNMAN X DISTRIBUTION DEPENDING ON ENERGY C DN/DXF = SL*XF 0 < XF < X1 C DN/DXF = SL*X1 X1 < XF < X2 C DN/DXF = SL*X1 * EXP(-AL*(XF-X2)) X2 < XF < 1 IF ( ECMDPM .LT. 13.76D0 ) THEN X1 = 0.20D0 X2 = 0.65D0 AL = 1.265D0 ELSEIF ( ECMDPM .LT. 5580.D0 ) THEN X1 = 0.716D0 + 0.00543D0 * SMLOG X2 = 0.8175D0 - 0.032D0 * SMLOG AL = 1.14D0 + 0.022D0 * SMLOG ELSE X1 = 0.265D0 X2 = 0.265D0 AL = 1.14D0 + 0.022D0*SMLOG ENDIF C CALCULATE THE INTEGRALS OVER THE THREE PARTS OF THE FUNCTION AA = 0.5D0 * SL * X1**2 BB = SL * X1 * (X2 - X1) CC = SL * X1 / AL * ( 1.D0 - EXP( AL*(X2-1.D0) ) ) C NORMALIZE TO 1 TT = 1.D0 / (AA + BB + CC) CC = CC * TT AA = AA * TT BB = BB * TT AB = AA + BB CALL RMMARD( RD,1,1 ) C GET XF FOR ANTILEADER IF ( RD(1) .LE. AA ) THEN XF = SQRT( RD(1)*2.D0 / (SL*TT) ) ELSEIF ( RD(1) .LE. AB ) THEN XF = (RD(1)-AA) / (SL*X1*TT) + X1 ELSE XF = X2 - LOG( 1.D0 - (RD(1)-AB)*AL/(SL*X1*TT) ) / AL ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) 'LEDENY: XF(TARGET)=',SNGL(XF) C CONVERT FEYNMAN X INTO RAPIDITY FOR ANTILEADER PLAL = PNT * XF * PAMA(LEPAR2) / PAMA(ITAR) EA(2) = SQRT( PLAL**2 + TMAS(2)**2 ) CDH YR(2) = (-0.5D0) * LOG( (EA(2)+PLAL)/(EA(2)-PLAL) ) YR(2) = -LOG( (EA(2)+PLAL)/TMAS(2) ) C CALCULATE THE REMAINDER OF ENERGY AND LONG. MOMENTUM OF LEADER C THIS HOLDS ALSO FOR MULTIPLE COLLISIONS (GNU > 1) ESUM = 0.D0 DO I = 2, NTOT EA(I) = TMAS(I) * COSH( YR(I) + YCM ) ESUM = ESUM + EA(I) ENDDO EA(1) = ELAB + PAMA(ITAR) - ESUM IF ( EA(1) .LE. TMAS(1) ) THEN LEDEFL = 1 RETURN ENDIF PLLBSQ = (EA(1)-TMAS(1)) * (EA(1)+TMAS(1)) PLLB = SQRT( PLLBSQ ) CDH YR(1) = 0.5D0 * LOG( (EA(1) + PLLB) / (EA(1) - PLLB) ) - YCM YR(1) = LOG( (EA(1) + PLLB) / TMAS(1) ) - YCM IF ( DEBUG ) WRITE(MDEBUG,*) 'LEDENY: EA(1),YR(2),YR(1)=', * SNGL(EA(1)),SNGL(YR(2)),SNGL(YR(1)) LEDEFL = 0 RETURN END *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE LEPACX( ECMCE,SDMLOG,LEPART,IPART ) C----------------------------------------------------------------------- C LE(ADING) PA(RTICLE) C(HARGE) (E)X(CHANGE) C C CONSIDERS CHARGE EXCHANGE POSSIBILITY OF (ANTI)LEADING PARTICLE. C CONSIDERS RESONANCE EXCITATION WITHOUT/WITH CHARGE EXCHANGE. C LASTPI INCREASED: CREATE ONE CHARGED PION FOR CHARGE CONSERVATION C LASTPI UNCHANGED: NO CHARGE EXCHANGE C LASTPI DECREASED: CANCEL ONE CHARGED PION FOR CHARGE CONSERVATION C NRESPC INCREASED BY 1, IF PI(+-) WILL BE GENERATED BY RESON. DECAY C NRESPN INCREASED BY 1, IF PI(0) WILL BE GENERATED BY RESON. DECAY C NCPLUS INCREASED BY 1, IF POSITIVE CHARGE IS CREATED C NCPLUS DECREASED BY 1, IF NEGATIVE CHARGE IS CREATED C THIS SUBROUTINE IS CALLED FROM HDPM. C ARGUMENTS: C ECMCE = ENERGY FOR CHARGE EXCHANGE (ECMDPM OR ECMDIF) (GEV) C SDMLOG = ELABLG FOR NSD, DMLOG FOR DIFFRACTION C LEPART = PARTICLE CODE OF (ANTI)LEADER EXCHANGING CHARGE C IPART = PARTICLE NUMBER IN ARRAY OF SECONDARY PARTICLES C = 1 FOR LEADER, = 2 FOR ANTI-LEADER C----------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) #define __CONSTAINC__ #define __LEPARINC__ #define __RANDPAINC__ #define __RESONINC__ #define __RUNPARINC__ #include "corsika.h" SAVE C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'LEPACX: LEPART=',LEPART C SET PROBABILITIES FOR RESONANCE PRODUCTION (PRESPR) AND FOR C CHARGE EXCHANGE OR RESONANCE PRODUCTION (PCEXRS) IF ( ECMCE .LE. 19.4D0 ) THEN PCEXRS = 0.45D0 PRESPR = 0.35D0 ELSEIF ( ECMCE .LT. 968.5D0 ) THEN PCEXRS = 0.45D0 + 0.034509D0 * (SDMLOG - 5.29832D0) PRESPR = 0.0881897D0 * (SDMLOG - 5.29832D0) ELSE PCEXRS = 0.72D0 PRESPR = 0.69D0 ENDIF PRESPR = MAX( 0.35D0, PRESPR ) IF ( LEPART .EQ. 7 ) THEN C ASSUME 50% CHARGE EXCHANGE FOR GAMMA INITIATED INTERACTION PCEXRS = 0.5D0 PRESPR = 0.D0 ENDIF C THROW RANDOM NUMBER TO LOOK FOR RES. PRODUCTION OR CHARGE EXCHANGE CALL RMMARD( RD,2,1 ) C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C RESONANCE IS FORMED. IF ADDITIONAL CHARGE EXCHANGE, THEN SET LASTPI IF ( RD(1) .LE. PRESPR ) THEN C FIRST FOR NUCLEONS (AS MOST FREQUENT) IF ( LEPART .EQ. 13 ) THEN IF ( RD(2) .LE. 0.5D0 ) THEN C NEUTRON ----> DELTA(-) LEPART = 57 NRESPC = NRESPC + 1 NCPLUS = NCPLUS - 1 ELSEIF ( RD(2) .GT. TB3 ) THEN C NEUTRON ----> DELTA(0) LEPART = 56 CALL RMMARD( RDRES(IPART),1,1 ) IF ( RDRES(IPART) .LE. TB3 ) THEN NRESPN = NRESPN + 1 ELSE NRESPC = NRESPC + 1 LASTPI = LASTPI - 1 ENDIF ELSE C NEUTRON ----> DELTA(+) LEPART = 55 CALL RMMARD( RDRES(IPART),1,1 ) IF ( RDRES(IPART) .LE. TB3 ) THEN NRESPN = NRESPN + 1 LASTPI = LASTPI - 1 ELSE NRESPC = NRESPC + 1 ENDIF NCPLUS = NCPLUS + 1 ENDIF ELSEIF ( LEPART .EQ. 14 ) THEN IF ( RD(2) .LE. 0.5D0 ) THEN C PROTON ----> DELTA(++) LEPART = 54 NRESPC = NRESPC + 1 NCPLUS = NCPLUS + 1 ELSEIF ( RD(2) .GT. TB3 ) THEN C PROTON ----> DELTA(+) LEPART = 55 CALL RMMARD( RDRES(IPART),1,1 ) IF ( RDRES(IPART) .LE. TB3 ) THEN NRESPN = NRESPN + 1 ELSE NRESPC = NRESPC + 1 LASTPI = LASTPI + 1 ENDIF ELSE C PROTON ----> DELTA(0) LEPART = 56 CALL RMMARD( RDRES(IPART),1,1 ) IF ( RDRES(IPART) .LE. TB3 ) THEN NRESPN = NRESPN + 1 LASTPI = LASTPI + 1 ELSE NRESPC = NRESPC + 1 ENDIF NCPLUS = NCPLUS - 1 ENDIF C NOW FOR PIONS ELSEIF ( LEPART .EQ. 8 .OR. LEPART .EQ. 9 ) THEN IF ( RD(2) .LE. 0.5D0 ) THEN C PI(+-) ----> RHO(+-) LEPART = LEPART + 44 NRESPN = NRESPN + 1 ELSE C PI(+-) ----> RHO(0) ( ----> PI(+) + PI(-) ) NCPLUS = NCPLUS + 2 * LEPART - 17 LEPART = 51 NRESPC = NRESPC + 1 ENDIF C NOW FOR KAONS ELSEIF ( LEPART .EQ. 11 .OR. LEPART .EQ. 12 ) THEN IF ( RD(2) .LE. 0.5D0 ) THEN C K(+-) ----> K*(+-) LEPART = LEPART + 52 CALL RMMARD( RDRES(IPART),1,1 ) IF ( RDRES(IPART) .LE. TB3 ) THEN NRESPN = NRESPN + 1 ELSE NRESPC = NRESPC + 1 LASTPI = LASTPI + 1 ENDIF ELSE C K(+) ----> K*(0) C K(-) ----> ANTI-K*(0) CALL RMMARD( RDRES(IPART),1,1 ) NCPLUS = NCPLUS + 2 * LEPART - 23 IF ( RDRES(IPART) .LE. TB3 ) THEN NRESPC = NRESPC + 1 ELSE NRESPN = NRESPN + 1 LASTPI = LASTPI + 1 ENDIF LEPART = 3*LEPART + 29 ENDIF ELSEIF ( LEPART .EQ. 10 .OR. LEPART .EQ. 16 ) THEN IF ( RD(2) .LE. 0.5D0 ) THEN C K(0) ----> (ANTI) K*(0) CALL RMMARD( RD,1,1 ) IF ( RD(1) .LE. 0.5D0 ) THEN LEPART = 62 ELSE LEPART = 65 ENDIF CALL RMMARD( RDRES(IPART),1,1 ) IF ( RDRES(IPART) .LE. TB3 ) THEN NRESPC = NRESPC + 1 LASTPI = LASTPI - 1 ELSE NRESPN = NRESPN + 1 ENDIF ELSE C K(0) ----> K*(+-) CALL RMMARD( RD,1,1 ) IF ( RD(1) .LE. 0.5D0 ) THEN LEPART = 63 NCPLUS = NCPLUS + 1 ELSE LEPART = 64 NCPLUS = NCPLUS - 1 ENDIF CALL RMMARD( RDRES(IPART),1,1 ) IF ( RDRES(IPART) .LE. TB3 ) THEN NRESPN = NRESPN + 1 LASTPI = LASTPI - 1 ELSE NRESPC = NRESPC + 1 ENDIF ENDIF C NOW FOR ANTINUCLEONS ELSEIF ( LEPART .EQ. 25 ) THEN IF ( RD(2) .LE. 0.5D0 ) THEN C ANTINEUTRON ----> ANTI-DELTA(0) LEPART = 60 CALL RMMARD( RDRES(IPART),1,1 ) IF ( RDRES(IPART) .LE. TB3 ) THEN NRESPN = NRESPN + 1 ELSE NRESPC = NRESPC + 1 LASTPI = LASTPI - 1 ENDIF ELSEIF ( RD(2) .GT. TB3 ) THEN C ANTINEUTRON ----> ANTI-DELTA(+) LEPART = 61 NRESPC = NRESPC + 1 NCPLUS = NCPLUS + 1 ELSE C ANTINEUTRON ----> ANTI-DELTA(-) LEPART = 59 CALL RMMARD( RDRES(IPART),1,1 ) IF ( RDRES(IPART) .LE. TB3 ) THEN NRESPN = NRESPN + 1 LASTPI = LASTPI - 1 ELSE NRESPC = NRESPC + 1 ENDIF NCPLUS = NCPLUS - 1 ENDIF ELSEIF ( LEPART .EQ. 15 ) THEN IF ( RD(2) .LE. 0.5D0 ) THEN C ANTIPROTON ----> ANTI-DELTA(--) LEPART = 58 NRESPC = NRESPC + 1 NCPLUS = NCPLUS - 1 ELSEIF ( RD(2) .GT. TB3 ) THEN C ANTIPROTON ----> ANTI-DELTA(-) LEPART = 59 CALL RMMARD( RDRES(IPART),1,1 ) IF ( RDRES(IPART) .LE. TB3 ) THEN NRESPN = NRESPN + 1 ELSE NRESPC = NRESPC + 1 LASTPI = LASTPI + 1 ENDIF ELSE C ANTIPROTON ----> ANTI-DELTA(0) LEPART = 60 CALL RMMARD( RDRES(IPART),1,1 ) IF ( RDRES(IPART) .LE. TB3 ) THEN NRESPN = NRESPN + 1 LASTPI = LASTPI + 1 ELSE NRESPC = NRESPC + 1 ENDIF NCPLUS = NCPLUS + 1 ENDIF ELSEIF ( LEPART .EQ. 7 ) THEN C NO RESONANCE FORMATION FOR INDUCING GAMMA RADIATION IF ( DEBUG ) WRITE(MDEBUG,*) 'LEPACX: NO EXCHANGE' ELSEIF ( (LEPART .GE. 18 .AND. LEPART .LE. 24) .OR. * (LEPART .GE. 26 .AND. LEPART .LE. 32) ) THEN C NO RESONANCE FORMATION FOR STRANGE BARYONS IF ( DEBUG ) WRITE(MDEBUG,*) 'LEPACX: NO EXCHANGE' ELSEIF ( LEPART .EQ. 17 ) THEN C NO RESONANCE FORMATION FOR INDUCING ETA IF ( DEBUG ) WRITE(MDEBUG,*) 'LEPACX: NO EXCHANGE' ELSEIF ( LEPART .GE. 71 .AND. LEPART .LE. 74 ) THEN C NO RESONANCE FORMATION FOR INDUCING ETA IF ( DEBUG ) WRITE(MDEBUG,*) 'LEPACX: NO EXCHANGE' ELSE WRITE(MONIOU,100) LEPART 100 FORMAT(1H ,'LEPACX: UNIDENTIFIED PARTICLE CODE= ',I4, * ' FOR RESONANCE FORMATION') ENDIF IF ( DEBUG ) WRITE(MDEBUG,102) * LEPART,LASTPI,NRESPC,NRESPN,NCPLUS 102 FORMAT(' LEPACX: LEPART,LASTPI,NRESPC,NRESPN,NCPLUS=',5I5) C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C CHARGE EXCHANGE WITHOUT RESONANCE FORMATION ELSEIF ( RD(1) .LE. PCEXRS ) THEN C FIRST FOR NUCLEONS (AS MOST FREQUENT) IF ( LEPART .EQ. 13 ) THEN C NEUTRON ( + PI(+) ) ----> PROTON ( + PI(0) ) LEPART = 14 LASTPI = LASTPI - 1 NCPLUS = NCPLUS + 1 ELSEIF ( LEPART .EQ. 14 ) THEN C PROTON ( + PI(0) ) ----> NEUTRON ( + PI(+) ) LEPART = 13 LASTPI = LASTPI + 1 NCPLUS = NCPLUS - 1 C NOW FOR PIONS ELSEIF ( LEPART .EQ. 8 .OR. LEPART .EQ. 9 ) THEN C PI(+-) ----> PI(0) NCPLUS = NCPLUS + 2 * LEPART - 17 LEPART = 7 LASTPI = LASTPI + 1 C NOW FOR KAONS ELSEIF ( LEPART .EQ. 11 .OR. LEPART .EQ. 12 ) THEN C K(+-) ----> K(0) (S OR L) NCPLUS = NCPLUS + 2 * LEPART - 23 IF ( RD(2) .LE. 0.5D0 ) THEN LEPART = 10 ELSE LEPART = 16 ENDIF LASTPI = LASTPI + 1 ELSEIF ( LEPART .EQ. 10 .OR. LEPART .EQ. 16 ) THEN C K(0) ----> K(+-) IF ( RD(2) .LE. 0.5D0 ) THEN LEPART = 11 NCPLUS = NCPLUS + 1 ELSE LEPART = 12 NCPLUS = NCPLUS - 1 ENDIF LASTPI = LASTPI - 1 C NOW FOR ANTINUCLEONS ELSEIF ( LEPART .EQ. 25 ) THEN C ANTINEUTRON ( + PI(-) ) ----> ANTIPROTON ( + PI(0) ) LEPART = 15 LASTPI = LASTPI - 1 NCPLUS = NCPLUS - 1 ELSEIF ( LEPART .EQ. 15 ) THEN C ANTIPROTON ( + PI(0) ) ----> ANTINEUTRON ( + PI(-) ) LEPART = 25 LASTPI = LASTPI + 1 NCPLUS = NCPLUS + 1 C NOW FOR GAMMA INDUCED REACTIONS (ITYPE=7) ELSEIF ( LEPART .EQ. 7 ) THEN C TEST IF CHARGE EXCHANGE REACTION FOR PI(0) C PI(0) ----> PI(+-) IF ( RD(2) .LE. 0.5D0 ) THEN LEPART = 8 NCPLUS = NCPLUS + 1 ELSE LEPART = 9 NCPLUS = NCPLUS - 1 ENDIF LASTPI = LASTPI - 1 ELSEIF ( (LEPART .GE. 18 .AND. LEPART .LE. 24) .OR. * (LEPART .GE. 26 .AND. LEPART .LE. 32) ) THEN C NO CHARGE EXCHANGE FOR STRANGE BARYONS IF ( DEBUG ) WRITE(MDEBUG,*) 'LEPACX: NO EXCHANGE' ELSEIF ( LEPART .EQ. 17 ) THEN C NO CHARGE EXCHANGE FOR INDUCING ETA IF ( DEBUG ) WRITE(MDEBUG,*) 'LEPACX: NO EXCHANGE' ELSEIF ( LEPART .GE. 71 .AND. LEPART .LE. 74 ) THEN C NO CHARGE EXCHANGE FOR INDUCING ETA IF ( DEBUG ) WRITE(MDEBUG,*) 'LEPACX: NO EXCHANGE' ELSE WRITE(MONIOU,101) LEPART 101 FORMAT(1H ,'LEPACX: UNIDENTIFIED PARTICLE CODE= ',I4, * ' FOR CHARGE EXCHANGE') ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) 'LEPACX: LEPART,LASTPI,NCPLUS=', * LEPART,LASTPI,NCPLUS ELSE IF ( DEBUG ) WRITE(MDEBUG,*) 'LEPACX: NO EXCHANGE' ENDIF RETURN END *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE NSD C----------------------------------------------------------------------- C N(ON) S(INGLE) D(IFFRACTION CASE) C C SETS PARAMETERS FOR HDPM IN CASE OF NON-SINGLE-DIFFRACTION EVENT. C THIS SUBROUTINE IS CALLED FROM HDPM. C----------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) #define __INTERINC__ #define __RUNPARINC__ #include "corsika.h" SAVE C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'NSD :' C CENTRAL RAPIDITY DENSITY ( RHO ) FOR NSD REACTION C PARAMETERISATION SEE CAPDEVIELLE,J.PHYS.G:NUCL.PHYS.16(1990)1539 EQ.7 IF ( ECMDPM .LE. 680.D0 ) THEN DC0 = 0.82D0 * (S**0.107D0) ELSE DC0 = 0.64D0 * (S**0.126D0) ENDIF C THERE ARE 3 ENERGY DEPENDENT FORMULAS FOR AVERAGE CHARGED C MULTIPLICITY ( AVCH0 ); C PARAMETERISATIONS SEE CAPDEVIELLE,J.PHYS.G:NUCL.PHYS.16(1990)1539 EQ.8 IF ( ECMDPM .LE. 187.5D0 ) THEN AVCH0 = 0.57D0 + 0.584D0 * SLOG + 0.127D0 * SLOGSQ ELSEIF ( ECMDPM .LT. 945.5D0 ) THEN AVCH0 = -6.55D0 + 6.89D0 * S**0.131D0 ELSE AVCH0 = 3.4D0 * S**0.17D0 ENDIF C MINIMUM AVERAGE CHARGED MULTIPLICITY IS 1 AVCH0 = MAX( 1.D0, AVCH0 ) C EXCESS OF CHARGED PARTICLES WHICH COME FROM AIR TARGET IF ( ECMDPM .LE. 137.D0 ) THEN AVCH3 = 0.57D0 * AVCH0 * (GNU - 1.D0) ELSE AVCH3 = 0.5D0 * AVCH0 * (GNU - 1.D0) ENDIF C AVERAGE NUMBER OF ALL CHARGED AVCH = AVCH0 + AVCH3 C THE FOLOWING PROCEDURE IS TO PRODUCE GAMMAS FROM UNKNOWN NEUTRAL C DECAYS FOLLOWING CORRELATION WITH CHARGED PARTICLES BASED ON GAMMA C EXCESS AT COLLIDER EXPERIMENTS. SEUGP IS C PARAMETERISATION OF UA5: ANSORGE ET AL., Z.PHYS.C43 (1989) 75 IF ( ECMDPM .LE. 103.D0 ) THEN SEUGP = -1.27D0 + 0.52D0 * SLOG + 0.148D0 * SLOGSQ ELSE C PROBLEM OF THE RISE OF THE UNKNOWN ETA PRODUCTION CROSS-SECTION C IS SOLVED WITH THOUW''S PARAMETERISATION OF UA5 DATA: SEUGP = -18.7D0 + 11.55D0 * S**0.1195D0 ENDIF SEUGP = MAX( 0.5D0, SEUGP ) IF ( DEBUG ) WRITE(MDEBUG,100) * SNGL(DC0),SNGL(AVCH0),SNGL(AVCH3),SNGL(AVCH),SNGL(SEUGP) 100 FORMAT(' NSD : DC0,AVCH0,AVCH3,AVCH,SEUGP=',5F12.7) C CENTER OF GAUSSIAN FOR CHARGED SECONDARIES 1ST AND 2ND STRING C NEEDED FOR SOME CALCULATION ; FINAL POSITION CALCULATED LATER POSC2 = 0.146D0 * SMLOG + 0.072D0 C WIDTH OF GAUSSIAN FOR CHARGED SECONDARIES 1ST AND 2ND STRING WIDC2 = 0.12D0 * SMLOG + 0.18D0 IF ( GNU .LE. 1.D0 ) THEN POSC3 = 0.D0 WIDC3 = 1.D0 ELSE C CENTER OF GAUSSIAN 3RD STRING (TARGET CONTRIB. FOR PROJECTILE-AIR) POSC3 = 3.D0 - 2.575D0 * EXP( (-0.081756452D0) * GNU ) C WIDTH OF GAUSSIAN FOR 3RD STRING WIDC3 = 1.2338466D0 + 0.078969916D0 * LOG( GNU ) ENDIF IF ( DEBUG ) WRITE(MDEBUG,110) * SNGL(POSC2),SNGL(WIDC2),SNGL(POSC3),SNGL(WIDC3) 110 FORMAT(' NSD : POSC2,WIDC2,POSC3,WIDC3=',4F12.7) RETURN END *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE PARNUM( INUMFL ) C----------------------------------------------------------------------- C PART(ICLE TYPE) NUM(BERS) C C DETERMINES THE NUMBERS OF SECONDARY PARTICLES FOR EACH TYPE. C THIS SUBROUTINE IS CALLED FROM HDPM. C ARGUMENT: C INUMFL = 0 CORRECT DETERMINATION OF PARTICLE NUMBERS C = 1 SOMETHING WENT WRONG WITH NEUTRAL PARTICLE NUMBERS C----------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) #define __CONSTAINC__ #define __EDECAYINC__ #define __INDICEINC__ #define __INTERINC__ #define __LEPARINC__ #define __RANDPAINC__ #define __RATIOSINC__ #define __RUNPARINC__ #include "corsika.h" DOUBLE PRECISION RDETA DIMENSION RDETA(1) SAVE C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'PARNUM: NCH,NEUTOT,NTOTEM=', * NCH,NEUTOT,NTOTEM INUMFL = 0 C RESET PARTICLE NUMBERS NNC = 0 NKC = 0 NHC = 0 NPC = 0 C ISEL IS 1 MEANS VERY LOW MULTIPLICITY C CREATE ONLY PIONS (TO RISKY TO CREATE OTHER PARTICLES) IF ( ISEL .EQ. 1 ) THEN NNN = 0 NKN = 0 NET = 0 NHN = 0 NPN = 0 NNUCN(2) = 0 NKA0(2) = 0 NHYPN(2) = 0 NETAS(2) = 0 NPIZER(2) = 0 C CREATE RANDOM NUMBERS CALL RMMARD( RD,NTOTEM,1 ) DO I = 1, NTOTEM IF ( RD(I) .LE. TB3 ) THEN NPC = NPC + 1 ELSE NPN = NPN + 1 ENDIF ENDDO C NO NEUTRAL PARTICLES FOR THE 3RD STRING EXCEPT EVENTUALLY PI(0) NNUCN(3) = 0 NKA0(3) = 0 NHYPN(3) = 0 NETAS(3) = 0 NPIZER(3) = MAX( 0, NINT( RC3TO2/(1.D0+RC3TO2)*DBLE(NPN) ) ) IF ( DEBUG ) WRITE(MDEBUG,*) ' ISEL=1, NTOTEM=',NTOTEM ELSE C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C NOW THE CASE OF HAVING ENOUGH PARTICLES TO BE ABLE TO CREATE C KAONS, NUCLEONS, AND HYPERONS TOO. C ...FOR NEUTRALS NCOUNT = 0 C BEGIN OF REJECT LOOP 1002 CONTINUE K = 1 CALL RMMARD( RD,NEUTOT+3,1 ) C DETERMINE NUMBER OF PI(0), ETA, K0S/K0 PAIRS, NEUTRON/ANTINEUTRON C PAIRS, AND NEUTRAL HYPERON PAIRS AND SUM UP THE GAMMAS C FOR 1ST + 2ND STRING: J IS 2; FOR 3RD STRING: J IS 3 SGAMMA = 0.D0 DO 1010 J = 2, 3 NNUCN(J) = 0 NKA0(J) = 0 NHYPN(J) = 0 NETA(J,1) = 0 NETA(J,2) = 0 NETA(J,3) = 0 NETA(J,4) = 0 NPIZER(J) = 0 IF ( J .EQ. 2 ) THEN C SET BOUNDARY FOR GAMMA SUM GABOU = SEUGF NNTOT = INT( FNEUT2 ) C CALCULATE BOUNDARY NNTOT OF PARTICLE LOOP RATHER AT RANDOM THAN BY C ROUNDING OF FNEUT2 TO AVOID DIGITIZING EFFECTS ON THE NEUTRAL C PARTICLE COMPOSITION AT COLLISIONS WITH LOW MULTIPLICITY IF ( NNTOT+RD(NEUTOT+2) .GE. FNEUT2 ) NNTOT = NNTOT+1 ELSE IF ( RC3TO2 .LE. 0.D0 ) GOTO 1010 GABOU = GABOU + SEUGF* RC3TO2 NNTOT = INT( FNEUT ) IF ( NNTOT+RD(NEUTOT+3) .GE. FNEUT ) NNTOT = NNTOT+1 ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) ' J,NNTOT=',J,NNTOT C START NEUTRAL PARTICLE PRODUCTION LOOP 1003 CONTINUE IF ( K .LT. NNTOT ) THEN RNDM = RD(K) ELSEIF ( K .EQ. NNTOT ) THEN C RENORMALIZE THE RANDOM NUMBER, THAT ONLY PI(0) OR ETA IS PRODUCED C BUT PAIR PRODUCTION BECOMES IMPOSSIBLE RNDM = RD(K) * RPIER ELSEIF ( K .GT. NNTOT ) THEN GOTO 1010 ENDIF IF ( RNDM .LE. RPI0R ) THEN C PI(0) SGAMMA = SGAMMA + 2.D0 NPIZER(J) = NPIZER(J) + 1 K = K + 1 ELSEIF ( RNDM .LE. RPIER ) THEN C ETA CALL RMMARD( RDETA(1),1,1 ) IF ( RDETA(1) .LE. CETA(1) ) THEN SGAMMA = SGAMMA + 2.D0 NETA(J,1) = NETA(J,1) + 1 ELSEIF ( RDETA(1) .LE. CETA(2) ) THEN SGAMMA = SGAMMA + 6.D0 NETA(J,2) = NETA(J,2) + 1 ELSEIF ( RDETA(1) .LE. CETA(3) ) THEN SGAMMA = SGAMMA + 2.D0 NETA(J,3) = NETA(J,3) + 1 ELSE SGAMMA = SGAMMA + 1.D0 NETA(J,4) = NETA(J,4) + 1 ENDIF K = K + 1 ELSEIF ( RNDM .LE. RPEKR ) THEN C K0S/K0L PAIR; RPEKR IS NORMALIZED FOR K0 PAIR FORMATION C THE UA5 GAMMA YIELD DOES NOT INCLUDE GAMMAS FROM K DECAY !!! C SEE: ANSORGE ET AL., Z. PHYS. C43 (1989) 75 NKA0(J) = NKA0(J) + 1 K = K + 2 ELSEIF ( RNDM .LE. RPEKNR ) THEN C NEUTRON-ANTINEUTRON PAIR NNUCN(J) = NNUCN(J) + 1 K = K + 2 ELSE C HYPERON-ANTIHYPERON PAIR C AVERAGE NEUTRAL HYPERON PAIR L0 --> .357*2 GAMMAS = 0.714 GAMMAS C S0 --> L0 + 1 GAMMA = 1.714 GAMMAS C THEY ARE INCLUDED IN UA5 GAMMA MULTIPLICITIES, THEREFORE COUNT SGAMMA = SGAMMA + 2.428D0 NHYPN(J) = NHYPN(J) + 1 K = K + 2 ENDIF GOTO 1003 1010 CONTINUE IF ( DEBUG ) WRITE(MDEBUG,1020) ( 2*NNUCN(J),2*NKA0(J), * 2*NHYPN(J),NETA(J,1),NETA(J,2),NETA(J,3),NETA(J,4), * NPIZER(J),J=2,3 ), NNTOT,GABOU,SGAMMA,SGAMMA/GABOU 1020 FORMAT(' PARNUM: NEUTRALS (1.,2.STRING)=',8I5,/, * ' NEUTRALS (3. STRING) =',8I5,/, * ' NNTOT,SEUGF2+3,SGAMMA,RATIO=',I6,3(2X,F10.5)) C REJECT ALL NEUTRALS, IF SUM OF GAMMAS DEVIATES BY MORE THAN SIGMA IF ( (SGAMMA - GABOU)**2 .GT. GABOU ) THEN NCOUNT = NCOUNT + 1 C AFTER 20 TRIES SET FLAG INUMFL TO 1 AND RETURN IF ( NCOUNT .LE. 20 ) GOTO 1002 INUMFL = 1 RETURN ENDIF C ALL NEUTRALS NNN = NNUCN(2) + NNUCN(3) NKN = NKA0(2) + NKA0(3) NHN = NHYPN(2) + NHYPN(3) NETAS(2) = NETA(2,1) + NETA(2,2) + NETA(2,3) + NETA(2,4) NETAS(3) = NETA(3,1) + NETA(3,2) + NETA(3,3) + NETA(3,4) NET = NETAS(2) + NETAS(3) NPN = NPIZER(2) + NPIZER(3) C ...FOR CHARGED I = 1 CALL RMMARD( RD,NCH-1,1 ) C START CHARGED PARTICLE PRODUCTION LOOP 1101 CONTINUE RNDM = RD(I) IF ( RNDM .LT. PPICH ) THEN C PI(+-) NPC = NPC + 1 I = I + 1 ELSEIF ( RNDM .LT. PPINCH ) THEN C PROTON/ANTIPROTON PAIR NNC = NNC + 1 I = I + 2 ELSEIF ( RNDM .LT. PPNKCH ) THEN C KAON(+,-) PAIR NKC = NKC + 1 I = I + 2 ELSE C CHARGED HYPERON/ANTIHYPERON PAIR NHC = NHC + 1 I = I + 2 ENDIF IF ( I .LT. NCH ) THEN GOTO 1101 ELSEIF ( I .EQ. NCH ) THEN C ONLY 1 CHARGED PARTICLE TO BE PRODUCED WHICH IS PI(+-) NPC = NPC + 1 ENDIF C CORRECT CHARGED PION NUMBER FOR DECAY OF ETA''S NCORR = 2 * ( NETA(2,3) + NETA(2,4) + NETA(3,3) + NETA(3,4) ) NPC = MAX( 0, NPC - NCORR ) IF ( DEBUG ) WRITE(MDEBUG,*) ' NPC,NPN,NCORR,LASTPI=', * NPC,NPN,NCORR,LASTPI ENDIF C CORRECT NUMBER OF CHARGED AND NEUTRAL PIONS FOR RESONANCE DECAY C (NRESPC, NRESPN) NPC = MAX( 0, NPC - NRESPC + LASTPI ) C INCREASE NPN ADDITIONALLY BY 1 TO MEET UA5 DATA, WHICH REPRODUCE ON C AVERAGE ONE EXCHANGED CHARGE (LASTPI = +1). NPN = MAX( 0, NPN - NRESPN - LASTPI + 1 ) C TOTAL NUMBER OF CHARGED PARTICLES NCH = (NNC + NKC + NHC) * 2 + NPC C NOW ALL PARTICLES ARE DETERMINED IF ( DEBUG ) WRITE(MDEBUG,*) * 'PARNUM: TOT.CHARGED=',2*NNC,2*NKC,2*NHC,NPC, * 'PARNUM: TOT.NEUTRAL=',2*NNN,2*NKN,2*NHN,NET,NPN RETURN END *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE PARRAP C----------------------------------------------------------------------- C PAR(TICLE) RAP(IDITY) C C ROUTINE GIVES THE NEW PARTICLES OF HDPM THEIR RAPIDITIES. C THIS SUBROUTINE IS CALLED FROM HDPM. C----------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) #define __INTERINC__ #define __NEWPARINC__ #define __RANDPAINC__ #define __RUNPARINC__ #include "corsika.h" DOUBLE PRECISION RAND(3000) SAVE DOUBLE PRECISION RANNOR EXTERNAL RANNOR C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'PARRAP: NTOT=',NTOT C PROTON ANTIPROTON PAIRS CALL RMMARD( RAND(3),IJ1-2,1 ) DO K = 3, IB1 C GENERATION OF RAPIDITY FOR EXTRA PARTICLES FROM TARGET. IF ( K .LE. IA2 ) THEN YR(K) = RANNOR(-POSC3,WIDC3) ELSE C GENERATION OF RAPIDITY FOR PARTICLES FROM PP-COLLISION AND PROJECTILE IF ( RAND(K) .LE. 0.5D0 ) THEN YR(K) = RANNOR(POSC2,WIDC2) ELSE YR(K) = RANNOR(-POSC2,WIDC2) ENDIF ENDIF ENDDO C K+ K- PAIRS DO K = IB1+1, IC1 IF ( K .LE. IB2 ) THEN C GENERATION OF RAPIDITY FOR EXTRA PARTICLES FROM TARGET. YR(K) = RANNOR(-POSC3,WIDC3) ELSE C GENERATION OF RAPIDITY FOR PARTICLES FROM PP-COLLISION AND PROJECTILE IF ( RAND(K) .LE. 0.5D0 ) THEN YR(K) = RANNOR(POSC2,WIDC2) ELSE YR(K) = RANNOR(-POSC2,WIDC2) ENDIF ENDIF ENDDO C CHARGED HYPERON PAIRS DO K = IC1+1, ID1 IF ( K .LE. IC2 ) THEN C GENERATION OF RAPIDITY FOR EXTRA PARTICLES FROM TARGET. YR(K) = RANNOR(-POSC3,WIDC3) ELSE C GENERATION OF RAPIDITY FOR PARTICLES FROM PP-COLLISION AND PROJECTILE IF ( RAND(K) .LE. 0.5D0 ) THEN YR(K) = RANNOR(POSC2,WIDC2) ELSE YR(K) = RANNOR(-POSC2,WIDC2) ENDIF ENDIF ENDDO C PI +- DO K = ID1+1, IE1 IF ( K .LE. ID2 ) THEN C GENERATION OF RAPIDITY FOR EXTRA PARTICLES FROM TARGET. YR(K) = RANNOR(-POSC3,WIDC3) ELSE C GENERATION OF RAPIDITY FOR PARTICLES FROM PP-COLLISION AND PROJECTILE IF ( RAND(K) .LE. 0.5D0 ) THEN YR(K) = RANNOR(POSC2,WIDC2) ELSE YR(K) = RANNOR(-POSC2,WIDC2) ENDIF ENDIF ENDDO C NEUTRON ANTINEUTRON PAIRS DO K = IE1+1, IF1 IF ( K .LE. IE2 ) THEN C GENERATION OF RAPIDITY FOR EXTRA PARTICLES FROM TARGET. YR(K) = RANNOR(-POSC3,WIDC3) ELSE C GENERATION OF RAPIDITY FOR PARTICLES FROM PP-COLLISION AND PROJECTILE IF ( RAND(K) .LE. 0.5D0 ) THEN YR(K) = RANNOR(POSC2,WIDC2) ELSE YR(K) = RANNOR(-POSC2,WIDC2) ENDIF ENDIF ENDDO C K0L K0S PAIRS DO K = IF1+1, IG1 IF ( K .LE. IF2 ) THEN C GENERATION OF RAPIDITY FOR EXTRA PARTICLES FROM TARGET. YR(K) = RANNOR(-POSC3,WIDC3) ELSE C GENERATION OF RAPIDITY FOR PARTICLES FROM PP-COLLISION AND PROJECTILE IF ( RAND(K) .LE. 0.5D0 ) THEN YR(K) = RANNOR(POSC2,WIDC2) ELSE YR(K) = RANNOR(-POSC2,WIDC2) ENDIF ENDIF ENDDO C NEUTRAL HYPERON PAIRS DO K = IG1+1, IH1 IF ( K .LE. IG2 ) THEN C GENERATION OF RAPIDITY FOR EXTRA PARTICLES FROM TARGET. YR(K) = RANNOR(-POSC3,WIDC3) ELSE C GENERATION OF RAPIDITY FOR PARTICLES FROM PP-COLLISION AND PROJECTILE IF ( RAND(K) .LE. 0.5D0 ) THEN YR(K) = RANNOR(POSC2,WIDC2) ELSE YR(K) = RANNOR(-POSC2,WIDC2) ENDIF ENDIF ENDDO C ETA DO K = IH1+1, II1 IF ( K .LE. IH2 ) THEN C GENERATION OF RAPIDITY FOR EXTRA PARTICLES FROM TARGET. YR(K) = RANNOR(-POSN3,WIDN3) ELSE C GENERATION OF RAPIDITY FOR PARTICLES FROM PP-COLLISION AND PROJECTILE IF ( RAND(K) .LE. 0.5D0 ) THEN YR(K) = RANNOR(POSN2,WIDN2) ELSE YR(K) = RANNOR(-POSN2,WIDN2) ENDIF ENDIF ENDDO C PI(0) DO K = II1+1, IJ1 IF ( K .LE. II2 ) THEN C GENERATION OF RAPIDITY FOR EXTRA PARTICLES FROM TARGET. YR(K) = RANNOR(-POSN3,WIDN3) ELSE C GENERATION OF RAPIDITY FOR PARTICLES FROM PP-COLLISION AND PROJECTILE IF ( RAND(K) .LE. 0.5D0 ) THEN YR(K) = RANNOR(POSN2,WIDN2) ELSE YR(K) = RANNOR(-POSN2,WIDN2) ENDIF ENDIF ENDDO RETURN END *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE PPARAM C----------------------------------------------------------------------- C P(ARTICLE) PARAM(ETERS) C C SETS PARAMETERS (PARTICLE TYP, TRANSVERSE MOMENTUM) C OF SECONDARY PARTICLES IN HDPM. C THIS SUBROUTINE IS CALLED FROM HDPM. C C CHANGES : J.N. CAPDEVIELLE CDF PARIS C----------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) #define __AVPTINC__ #define __DPMFLGINC__ #define __INDICEINC__ #define __INTERINC__ #define __LEPARINC__ #define __NEWPARINC__ #define __PAMINC__ #define __RANDPAINC__ #define __RUNPARINC__ #include "corsika.h" SAVE C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'PPARAM: NTOT,NPC,NCPLUS=', * NTOT,NPC,NCPLUS C FILL PARTICLES INTO ARRAYS, CALCULATE PT AND SUM UP SPX = 0.D0 SPY = 0.D0 NPART = 3 C PROTON ANTIPROTON PAIRS DO K = 1, NNC CALL RMMARD( RD,1,1 ) IF ( RD(1) .LT. 0.5D0 ) THEN ITYP(NPART) = 14 ITYP(NPART+1) = 15 ELSE ITYP(NPART) = 15 ITYP(NPART+1) = 14 ENDIF CALL PTRAM( ZN,AVPN,PX(NPART),PY(NPART) ) CALL PTRAM( ZN,AVPN,PX(NPART+1),PY(NPART+1) ) SPX = SPX + PX(NPART) + PX(NPART+1) SPY = SPY + PY(NPART) + PY(NPART+1) NPART = NPART + 2 ENDDO C K+ K- PAIRS DO K = 1, NKC CALL RMMARD( RD,1,1 ) IF ( RD(1) .LT. 0.5D0 ) THEN ITYP(NPART) = 11 ITYP(NPART+1) = 12 ELSE ITYP(NPART) = 12 ITYP(NPART+1) = 11 ENDIF CALL PTRAM( ZN,AVPK,PX(NPART),PY(NPART) ) CALL PTRAM( ZN,AVPK,PX(NPART+1),PY(NPART+1) ) SPX = SPX + PX(NPART) + PX(NPART+1) SPY = SPY + PY(NPART) + PY(NPART+1) NPART = NPART + 2 ENDDO C SIGMA PAIRS DO K = 1, NHC CALL RMMARD( RD,2,1 ) IF ( RD(1) .LT. 0.5D0 ) THEN IF ( RD(2) .LT. 0.5D0 ) THEN ITYP(NPART) = 19 ITYP(NPART+1) = 27 ELSE ITYP(NPART) = 27 ITYP(NPART+1) = 19 ENDIF ELSE IF ( RD(2) .LT. 0.5D0 ) THEN ITYP(NPART) = 21 ITYP(NPART+1) = 29 ELSE ITYP(NPART) = 29 ITYP(NPART+1) = 21 ENDIF ENDIF CALL PTRAM( ZN,AVPH,PX(NPART),PY(NPART) ) CALL PTRAM( ZN,AVPH,PX(NPART+1),PY(NPART+1) ) SPX = SPX + PX(NPART) + PX(NPART+1) SPY = SPY + PY(NPART) + PY(NPART+1) NPART = NPART + 2 ENDDO C DECIDE WITH WHICH CHARGED PION TO START WITH C NUMBER OF PIONS MAY BE ODD IN THE CASE IF ISEL IS 1 CALL RMMARD( RD,1,1 ) IF ( RD(1) .GT. 0.5D0 ) THEN NPIOCH = 0 ELSE NPIOCH = 1 ENDIF NPOS = NCPLUS C PI +- DO K = 1, NPC IF ( NPC-K+1 .LE. NPOS ) THEN NPIOCH = 1 IF ( DEBUG ) WRITE(MDEBUG,*) ' NPC,K,NPOS,NPIOCH=', * NPC,K,NPOS,NPIOCH ELSEIF ( NPC-K+1 .LE. -NPOS ) THEN NPIOCH = 0 IF ( DEBUG ) WRITE(MDEBUG,*) ' NPC,K,-NPOS,NPIOCH=', * NPC,K,-NPOS,NPIOCH ENDIF IF ( NPIOCH .EQ. 0 ) THEN ITYP(NPART) = 8 NPIOCH = 1 NPOS = NPOS + 1 ELSE ITYP(NPART) = 9 NPIOCH = 0 NPOS = NPOS - 1 ENDIF CALL PTRAM( ZN,AVPT,PX(NPART),PY(NPART) ) SPX = SPX + PX(NPART) SPY = SPY + PY(NPART) NPART = NPART + 1 ENDDO C NEUTRON ANTINEUTRON PAIRS DO K = 1, NNN CALL RMMARD( RD,1,1 ) IF ( RD(1) .LT. 0.5D0 ) THEN ITYP(NPART) = 13 ITYP(NPART+1) = 25 ELSE ITYP(NPART) = 25 ITYP(NPART+1) = 13 ENDIF CALL PTRAM( ZN,AVPN,PX(NPART),PY(NPART) ) CALL PTRAM( ZN,AVPN,PX(NPART+1),PY(NPART+1) ) SPX = SPX + PX(NPART) + PX(NPART+1) SPY = SPY + PY(NPART) + PY(NPART+1) NPART = NPART + 2 ENDDO C K0L K0S PAIRS DO K = 1, NKN CALL RMMARD( RD,1,1 ) IF ( RD(1) .LT. 0.5D0 ) THEN ITYP(NPART) = 10 ITYP(NPART+1) = 16 ELSE ITYP(NPART) = 16 ITYP(NPART+1) = 10 ENDIF CALL PTRAM( ZN,AVPK,PX(NPART),PY(NPART) ) CALL PTRAM( ZN,AVPK,PX(NPART+1),PY(NPART+1) ) SPX = SPX + PX(NPART) + PX(NPART+1) SPY = SPY + PY(NPART) + PY(NPART+1) NPART = NPART + 2 ENDDO C LAMDA/SIGMA0 PAIRS DO K = 1, NHN CALL RMMARD( RD,2,1 ) IF ( RD(1) .LT. 0.5D0 ) THEN IF ( RD(2) .LT. 0.5D0 ) THEN ITYP(NPART) = 18 ITYP(NPART+1) = 28 ELSE ITYP(NPART) = 28 ITYP(NPART+1) = 18 ENDIF ELSE IF ( RD(2) .LT. 0.5D0 ) THEN ITYP(NPART) = 26 ITYP(NPART+1) = 20 ELSE ITYP(NPART) = 20 ITYP(NPART+1) = 26 ENDIF ENDIF C ----- CHANGE BY JNC DEC.96) * IF ( ECMDPM .LE. 500.D0 ) THEN * CALL PTRAN( ZN,AVPH,PX(NPART),PY(NPART) ) * CALL PTRAN( ZN,AVPH,PX(NPART+1),PY(NPART+1) ) * ELSE CALL PTRAM( ZN,AVPH,PX(NPART),PY(NPART) ) CALL PTRAM( ZN,AVPH,PX(NPART+1),PY(NPART+1) ) * ENDIF SPX = SPX + PX(NPART) + PX(NPART+1) SPY = SPY + PY(NPART) + PY(NPART+1) NPART = NPART + 2 ENDDO C ETA DO K = 1, NET C FIRST FOR ETAS FROM THIRD STRING IF ( K .LE. NETA(3,1) ) THEN ITYP(NPART) = 71 ELSEIF ( K .LE. NETA(3,1)+NETA(3,2) ) THEN ITYP(NPART) = 72 ELSEIF ( K .LE. NETA(3,1)+NETA(3,2)+NETA(3,3) ) THEN ITYP(NPART) = 73 ELSEIF ( K .LE. NETA(3,1)+NETA(3,2)+NETA(3,3)+NETA(3,4)) THEN ITYP(NPART) = 74 C NOW FOR ETAS FROM FIRST AND SECOND STRING ELSEIF ( K .LE. NETAS(3)+NETA(2,1) ) THEN ITYP(NPART) = 71 ELSEIF ( K .LE. NETAS(3)+NETA(2,1)+NETA(2,2) ) THEN ITYP(NPART) = 72 ELSEIF ( K .LE. NETAS(3)+NETA(2,1)+NETA(2,2)+NETA(2,3) ) THEN ITYP(NPART) = 73 ELSE ITYP(NPART) = 74 ENDIF C ----- CHANGE BY JNC DEC.96) IF ( ECMDPM .LE. 500.D0 ) THEN CALL PTRAN( ZN,AVPE,PX(NPART),PY(NPART) ) ELSE CALL PTRAM( ZN,AVPE,PX(NPART),PY(NPART) ) ENDIF SPX = SPX + PX(NPART) SPY = SPY + PY(NPART) NPART = NPART + 1 ENDDO C PI(0) DO K = 1, NPN ITYP(NPART) = 7 C ----- CHANGE BY JNC DEC.96) IF ( ECMDPM .LE. 500.D0 ) THEN CALL PTRAN( ZN,AVPT,PX(NPART),PY(NPART) ) ELSE CALL PTRAM( ZN,AVPT,PX(NPART),PY(NPART) ) ENDIF SPX = SPX + PX(NPART) SPY = SPY + PY(NPART) NPART = NPART + 1 ENDDO C ANTILEADER (FROM TARGET, THEREFORE ALWAYS NUCLEON OR DELTA RESONANCE) ITYP(2) = LEPAR2 C ----- CHANGE BY JNC DEC.96 IF ( ECMDPM .LE. 500.D0 ) THEN CALL PTRAN( ZN,AVPN,PX(2),PY(2) ) ELSE CALL PTRAM( ZN,AVPN,PX(2),PY(2) ) ENDIF C FIRST PARTICLE IS LEADING PARTICLE ITYP(1) = LEPAR1 IF ( (LEPAR1 .GE. 7 .AND. LEPAR1 .LE. 9) .OR. * (LEPAR1 .GE. 51 .AND. LEPAR1 .LE. 53) ) THEN C LEADING PARTICLE IS PION OR RHO RESONANCE AVERPT = AVPT C LEADING PARTICLE IS KAON OR KAON RESONANCE ELSEIF ( LEPAR1 .EQ. 10 .OR. LEPAR1 .EQ. 11 .OR. * LEPAR1 .EQ. 12 .OR. LEPAR1 .EQ. 16 .OR. * (LEPAR1 .GE. 62 .AND. LEPAR1 .LE. 65) ) THEN AVERPT = AVPK ELSE C LEADING PARTICLE IS NUCLEON OR ANTINUCLEON OR DELTA RESONANCE C OR STRANGE BARYON AVERPT = AVPN ENDIF C ----- CHANGE BY JNC DEC.96 IF ( ECMDPM .LE. 500.D0 ) THEN CALL PTRAN( ZN,AVERPT,PX(1),PY(1) ) ELSE CALL PTRAM( ZN,AVERPT,PX(1),PY(1) ) ENDIF SPX = SPX + PX(1) + PX(2) SPY = SPY + PY(1) + PY(2) C AVERAGE EXCESS PT PER PARTICLE SPX = SPX / NTOT SPY = SPY / NTOT C RENORMALIZATION OF PT AND CALCULATION OF TRANSVERSE MASSES DO I = 1, NTOT PX(I) = PX(I) - SPX PY(I) = PY(I) - SPY PT2(I) = PX(I)**2 + PY(I)**2 TMAS(I) = SQRT( PAMA(ITYP(I))**2 + PT2(I) ) ENDDO RETURN END *-- Author : J.N. Capdevielle CdF Paris/France 26/11/1996 C======================================================================= SUBROUTINE PTRAM( ZN,FACT,PTX,PTY ) C----------------------------------------------------------------------- C TRA(NSVERSE MOMENTUM FROM) M(IMI EXPERIMENT) C C GENERATION OF TRANSVERSE MOMENTUM FOR PARTICLES IN HDPM GENERATOR C SEE RESULTS FROM UA1/MIMI/96. C SOME CONSTANTS CHANGED FROM MATHEMATICAL SOLUTION BY DICHOTOMY TO C TO TAKE INTO ACCOUNT EFFECT OF REJECTIONS. (TESTIFIED AT VS=630 GEV C ONLY) SEE J.N. CAPDEVIELLE, 24TH ICRC, ROMA 1995, RAPPORTEUR TALK C NUOV. CIM. C19 (1996) 623 C AND J.N. CAPDEVIELLE, 9TH ISVHECRI, KARLSRUHE 1996 C NUCL.PHYS.B (CONF.PROC.) 52B (1997) 146 C THIS SUBROUTINE IS CALLED FROM PPARAM. C ARGUMENTS: C ZN = POWER OF TRANSV.MOMENTUM FUNCTION, DEP. ON CENT.RAP.DENSITY C FACT = FACTOR TAKING INTO ACCOUNT PARTICLE SPEC. TRANSV.MOMENTUM C PTX = TRANSVERSE MOMENTUM IN X DIRECTION (GEV) C PTY = TRANSVERSE MOMENTUM IN Y DIRECTION (GEV) C----------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) #define __CONSTAINC__ #define __RANDPAINC__ #define __RUNPARINC__ #include "corsika.h" SAVE C----------------------------------------------------------------------- CC IF ( DEBUG ) WRITE(MDEBUG,*) 'PTRAM : ZN=',SNGL(ZN) C TWO RANDOM NUMBERS CALL RMMARD( RD,2,1 ) C GENERATE ALFA = -0.05D0 B = ZN-1.D0 A = RD(1)/B U = 0.D0 DO J = 1, 1000 F1 = A * (U+1.D0)**B - 1.D0/B IF ( F1 .GE. U ) GOTO 15 U = U + 0.05D0 ENDDO 15 CONTINUE BETA = U ALFA = U - 0.05D0 IF ( F1-U .EQ. 0.D0 ) GOTO 30 I = 0 14 CONTINUE U = 0.5D0 * (ALFA+BETA) I = I + 1 F = A * (U+1.D0)**B - 1.D0/B - U IF ( F .EQ. 0.D0 ) GOTO 30 IF ( ABS(U-BETA) .LE. 1.D-4 ) GOTO 30 FA = A * (ALFA+1.D0)**B - ALFA - 1.D0/B FB = B * (BETA+1.D0)**B - BETA - 1.D0/B IF ( F*FA .GE. 0.D0 ) THEN ALFA = U ELSE BETA = U ENDIF GOTO 14 30 CONTINUE XPT = 0.9154D0 * U C 2*PI*RANDOM NUMBER FOR ANGLE PHI Z = PI2 * RD(2) PTX = XPT * FACT * COS( Z ) PTY = XPT * FACT * SIN( Z ) CC IF ( DEBUG ) WRITE(MDEBUG,*) 'PTRAM : RD(1,2),XPT=', CC * RD(1),RD(2),SNGL(XPT) RETURN END *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE PTRAN( ZN,FACT,PTX,PTY ) C----------------------------------------------------------------------- C TRAN(SVERSE MOMENTUM) C C GENERATION OF TRANSVERSE MOMENTUM FOR PARTICLES IN HDPM. C THIS SUBROUTINE IS CALLED FROM PPARAM. C ARGUMENTS: C ZN = POWER OF TRANSV.MOMENTUM FUNCTION, DEP. ON CENT.RAP.DENSITY C FACT = FACTOR TAKING INTO ACCOUNT PARTICLE SPEC. TRANSV.MOMENTUM C PTX = TRANSVERSE MOMENTUM IN X DIRECTION (GEV) C PTY = TRANSVERSE MOMENTUM IN Y DIRECTION (GEV) C----------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) #define __CONSTAINC__ #define __RANDPAINC__ #define __RUNPARINC__ #include "corsika.h" SAVE C----------------------------------------------------------------------- CC IF ( DEBUG ) WRITE(MDEBUG,*) 'PTRAN : ZN=',SNGL(ZN) C TWO RANDOM NUMBERS CALL RMMARD( RD,2,1 ) C GENERATE (REFERENCE??) B = ZN * (ZN - 1.D0) ZZ = SQRT( 1.D0/RD(1) - 1.D0 ) XPT = ZZ * SQRT( 2.D0/B ) 11 CONTINUE IF ( XPT .LT. 0.5D-3 ) GOTO 22 X1 = 1.D0 + XPT XB = X1**ZN XC = 1.D0 + ZN * XPT ZA = SQRT( XB/XC - 1.D0 ) XD = (ZZ - ZA) * (X1 * 2.D0 * ZA * XC**2 ) / ( B * XPT * XB ) XPT = XPT + XD IF ( ABS(XD) .GT. 1.D-3 ) GOTO 11 22 CONTINUE C 2*PI*RANDOM NUMBER FOR ANGLE PHI Z = PI2 * RD(2) PTX = XPT * FACT * COS( Z ) PTY = XPT * FACT * SIN( Z ) CC IF ( DEBUG ) WRITE(MDEBUG,*) 'PTRAN : RD(1,2),XPT=', CC * RD(1),RD(2),SNGL(XPT) RETURN END *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE RESDEC C----------------------------------------------------------------------- C RES(ONANCE) DEC(AY) C C ROUTINE TREATES DECAY OF THE RESONANCES RHO, K*, AND DELTA. C THE DECAY MODE IS SELECTED BY THE RANDOM NUMBER RESRAN, WHICH IS C SET IN THE SUBROUT. HDPM/LEPACX, WHERE THE RESONANCE IS FORMED. C DECAY WITH FULL KINEMATIC, ENERGY AND MOMENTA CONSERVED. C THIS SUBROUTINE IS CALLED FROM BOX3. C----------------------------------------------------------------------- IMPLICIT NONE #define __CONSTAINC__ #define __DECAYCINC__ #define __GENERINC__ #define __LONGIINC__ #define __PAMINC__ #define __PARPARINC__ #define __PARPAEINC__ #define __RANDPAINC__ #define __RESONINC__ #define __RUNPARINC__ #if __AUGERHIST__ #define __OBSPARINC__ #endif #if __MULTITHIN__ #define __MULTHININC__ #endif #include "corsika.h" DOUBLE PRECISION FAC1,FAC2 INTEGER I,KK,M3,M4,IRESP SAVE #if __AUGERHIST__ DOUBLE PRECISION EDEP,THICKLOC,THICK INTEGER II,LL EXTERNAL THICK #endif C----------------------------------------------------------------------- #if __THIN__ IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=0,9),WEIGHT 444 FORMAT(' RESDEC: CURPAR=',1P,11E11.3) #else IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=0,9) 444 FORMAT(' RESDEC: CURPAR=',1P,10E11.3) #endif C COPY VERTEX COORDINATES INTO SECPAR DO KK = 5, 8 SECPAR(KK) = CURPAR(KK) ENDDO SECPAR( 9) = GEN SECPAR(10) = ALEVEL #if __THIN__ SECPAR(13) = WEIGHT #endif #if __CURVED__ SECPAR(14) = CURPAR(14) SECPAR(15) = CURPAR(15) SECPAR(16) = CURPAR(16) #endif #if __INTTEST__ SECPAR(17) = CURPAR(17) #endif #if __EHISTORY__ DO I = 17, 38 SECPAR(I) = CURPAR(I) ENDDO #endif #if __PARALLEL__ C SET ECTFLG TO OFF SECPAR(39) = CURPAR(39) #endif #if __MULTITHIN__ DO I = 1, NMTHIN SECPAR(40+I) = CURPAR(40+I) ENDDO #endif BETA = SQRT( (GAMMA-1.D0)*(GAMMA+1.D0) ) / GAMMA IRESP = NINT(MOD( CURPAR(0), 1.D0) * 1.D7 ) IF ( (IRESP .EQ. 0 .OR. IRESP .GT. 999999) * .AND. ITYPE .GE. 54 ) THEN IF ( DEBUG ) WRITE(MDEBUG,*) 'RESDEC: GENERATE RESRAN ...' IRESP = 0 CALL RMMARD( RD,1,1 ) RESRAN(IRESP) = RD(1) ENDIF C----------------------------------------------------------------------- C TREAT FIRST NUCLEON RESONANCES, AS MOST FREQUENT IF ( ITYPE .EQ. 54 ) THEN C DECAY DELTA(++) ----> P + PI(+) CALL DECAY1( ITYPE,14,8 ) ELSEIF ( ITYPE .EQ. 55 .OR. ITYPE .EQ. 56 ) THEN C DECAY DELTA(+) OR DECAY DELTA(0) IF ( RESRAN(IRESP) .LE. TB3 ) THEN C DECAY DELTA(+) ----> P + PI(0) C DECAY DELTA(0) ----> N + PI(0) M3 = 69 - ITYPE CALL DECAY1( ITYPE,M3,7 ) ELSE C DECAY DELTA(+) ----> N + PI(+) C DECAY DELTA(0) ----> P + PI(-) M3 = ITYPE - 42 M4 = M3 - 5 CALL DECAY1( ITYPE,M3,M4 ) ENDIF ELSEIF ( ITYPE .EQ. 57 ) THEN C DECAY DELTA(-) ----> N + PI(-) CALL DECAY1( ITYPE,13,9 ) ELSEIF ( ITYPE .EQ. 58 ) THEN C DECAY ANTI_DELTA(--) ----> ANTI-P + PI(-) CALL DECAY1( ITYPE,15,9 ) ELSEIF ( ITYPE .EQ. 59 ) THEN IF ( RESRAN(IRESP) .LE. TB3 ) THEN C DECAY ANTI-DELTA(-) ----> ANTI-P + PI(0) CALL DECAY1( ITYPE,15,7 ) ELSE C DECAY ANTI-DELTA(-) ----> ANTI-N + PI(-) CALL DECAY1( ITYPE,25,9 ) ENDIF ELSEIF ( ITYPE .EQ. 60 ) THEN IF ( RESRAN(IRESP) .LE. TB3 ) THEN C DECAY ANTI-DELTA(0) ----> ANTI-N + PI(0) CALL DECAY1( ITYPE,25,7 ) ELSE C DECAY ANTI-DELTA(0) ----> ANTI-P + PI(+) CALL DECAY1( ITYPE,15,8 ) ENDIF ELSEIF ( ITYPE .EQ. 61 ) THEN C DECAY ANTI-DELTA(+) ----> ANTI-N + PI(+) CALL DECAY1( ITYPE,25,8 ) C----------------------------------------------------------------------- C RHO RESONANCES ELSEIF ( ITYPE .EQ. 51 ) THEN C DECAY RHO(0) ----> PI(+) + PI(-) C HANDLE DECAY OF RHO(0) BY ROUTINE RHO0DC WHICH MIGHT ALSO TREAT C RARE DECAY RHO(0) ----> MU(+) + MU(-) CALL RHO0DC(0) ELSEIF ( ITYPE .EQ. 52 .OR. ITYPE .EQ. 53 ) THEN C DECAY RHO(+,-) ----> PI(+,-) + PI(0) M3 = ITYPE - 44 CALL DECAY1( ITYPE,M3,7 ) C----------------------------------------------------------------------- C OMEGA MESON RESONANCE (COMES FROM PHOTONUCLEAR REACTION) ELSEIF ( ITYPE .EQ. 50 ) THEN CALL RMMARD( RD,1,1 ) C BRANCHING RATIO IS 89.2%, BUT WE NEGLECT SMALL BRANCHINGS, C SO WE USE 89.2/0.9901 = 90.092% IF ( RD(1) .LE. 0.90092D0 ) THEN C DECAY OMEGA ----> PI(+) + PI(-) + PI(0) C (UNIFORM PHASE SPACE DISTRIBUTION IS ASSUMED FOR THIS DECAY) CALL DECAY6( PAMA(50), PAMA(8),PAMA(9),PAMA(7), * 0.D0,0.D0,0.D0, 1.D0, 2 ) DO I = 1, 3 CALL ADDANG3( COSTHE,PHIX,PHIY, COS345(I),PHI345(I), * SECPAR(2),SECPAR(3),SECPAR(4) ) #if __UPWARD__ IF ( SECPAR(2) .GE. -1.D0 ) THEN #else IF ( SECPAR(2) .GT. C(29) ) THEN #endif IF ( I .EQ. 3 ) THEN SECPAR(0) = 7.D0 ELSE SECPAR(0) = 7 + I ENDIF SECPAR(1) = GAM345(I) CALL TSTACK ELSE IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT IF ( I .EQ. 3 ) THEN #if __THIN__ DLONG(LHEIGH,17) = DLONG(LHEIGH,17) * +GAM345(I) * PAMA(7) * WEIGHT #else DLONG(LHEIGH,17) = DLONG(LHEIGH,17)+GAM345(I)*PAMA(7) #endif ELSE FAC1 = 0.25D0 FAC2 = 0.75D0 #if __THIN__ DLONG(LHEIGH,17) = DLONG(LHEIGH,17) * +GAM345(I)*PAMA(8)*WEIGHT*FAC1 DLONG(LHEIGH,18) = DLONG(LHEIGH,18) * +GAM345(I)*PAMA(8)*WEIGHT*FAC2 #else DLONG(LHEIGH,17) = DLONG(LHEIGH,17) * + GAM345(I)*PAMA(8)*FAC1 DLONG(LHEIGH,18) = DLONG(LHEIGH,18) * + GAM345(I)*PAMA(8)*FAC2 #endif ENDIF ENDIF #if __AUGERHIST__ THICKLOC = THICK( H ) DO LL = 1, NOBSLV IF ( THICKLOC .GE. THCKOB(LL) .AND. * THICKLOC .LT. THCKOB(LL)+SAMPTH ) THEN C THICKH IS WITHIN 1 G/CM^2 BELOW OBSLEV(LL) C BRING THE ENERGY BELOW ANGULAR CUT TO THE HISTO OF LEVEL LL OUTPAR(1) = GAM345(I) IF ( I .EQ. 3 ) THEN OUTPAR(0) = 7.D0 EDEP = OUTPAR(1) * PAMA(7) * WEIGHT ELSE OUTPAR(0) = 7 + I EDEP = OUTPAR(1) * PAMA(8) * WEIGHT ENDIF DO II = 2, 8 OUTPAR(II) = SECPAR(II) ENDDO OUTPAR( 9) = GEN OUTPAR(10) = ALEVEL OUTPAR(13) = WEIGHT C WE HAVE ANGULAR CUT CALL AUGERDEPFIL( EDEP,LL,1 ) ELSEIF ( THICKLOC .LT. THCKOB(LL) ) THEN GOTO 111 ENDIF ENDDO 111 CONTINUE #endif ENDIF ENDDO C BRANCHING RATIO IS 8.28%, BUT WE NEGLECT SMALL BRANCHINGS, C SO WE USE (89.2+ 8.28)/0.9901 = 98.455 % ELSEIF ( RD(1) .LE. 0.98455D0 ) THEN C DECAY OMEGA ----> PI(0) + GAMMA CALL DECAY1( ITYPE,7,1 ) C BRANCHING RATIO IS 1.53%, BUT WE NEGLECT SMALL BRANCHINGS, C SO WE USE (100. - 98.455) = 1.545% ELSE C DECAY OMEGA ----> PI(+) + PI(-) CALL DECAY1( ITYPE,8,9 ) ENDIF cdh Sept 2015 here the rare decays should be added: c omega ---> pi(0) + mu(+) + mu(-) (B.R. = 1.3E(-4)) c omega ---> mu(+) + mu(-) (B.R. = 9.0E(-5)) C----------------------------------------------------------------------- C EXCITED KAON RESONANCES ELSEIF ( ITYPE .EQ. 62 ) THEN C DECAY K*(0) ----> 2/3: K(+) + PI(-) C ----> 1/3: K0(L,S) + PI(0) IF ( RESRAN(IRESP) .LE. TB3 ) THEN CALL DECAY1( ITYPE,11,9 ) ELSEIF ( RESRAN(IRESP) .LE. .8333333D0 ) THEN CALL DECAY1( ITYPE,10,7 ) ELSE CALL DECAY1( ITYPE,16,7 ) ENDIF ELSEIF ( ITYPE .EQ. 65 ) THEN C DECAY ANTI-K*(0) ----> 2/3: K(-) + PI(+) C ----> 1/3: K0(L,S) + PI(0) IF ( RESRAN(IRESP) .LE. TB3 ) THEN CALL DECAY1( ITYPE,12,8 ) ELSEIF ( RESRAN(IRESP) .LE. .8333333D0 ) THEN CALL DECAY1( ITYPE,10,7 ) ELSE CALL DECAY1( ITYPE,16,7 ) ENDIF ELSEIF ( ITYPE .EQ. 63 .OR. ITYPE .EQ. 64 ) THEN C DECAY K*(+-) ----> 2/3: K(+-) + PI(0) C ----> 1/3: K0(L,S) + PI(+-) IF ( RESRAN(IRESP) .LE. TB3 ) THEN CALL DECAY1( ITYPE,ITYPE-52,7 ) ELSEIF ( RESRAN(IRESP) .LE. .8333333D0 ) THEN CALL DECAY1( ITYPE,10,ITYPE-55 ) ELSE CALL DECAY1( ITYPE,16,ITYPE-55 ) ENDIF C----------------------------------------------------------------------- ELSE #if __THIN__ WRITE(MONIOU,444) (CURPAR(I),I=0,9),CURPAR(13) #else WRITE(MONIOU,444) (CURPAR(I),I=0,9) #endif WRITE(MONIOU,*) 'RESDEC: UNFORESEEN PARTICLE CODE =',ITYPE ENDIF IF ( IRESP .GT. 0 ) THEN IF ( DEBUG ) WRITE(MDEBUG,*) 'RESDEC: IRESPAR .GT. 0, RESET ID' CURPAR(0) = NINT( CURPAR(0) ) ENDIF RETURN END *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE RNEGBI( N,XN,ECM ) C----------------------------------------------------------------------- C R(ANDOM NUMBER WITH) NEG(ATIVE) BI(NOMIAL DISTRIBUTION) C C RANDOM NUMBER GENERATOR FOR INTEGER NUMBERS DISTRIBUTED ACCORDING TO C A NEGATIVE BINOMIAL DISTRIBUTION WITH PARAMETERS AND K C DELIVERS ONLY EVEN NUMBERS AS CHARGE MUST BE CONSERVED. C THIS SUBROUTINE IS CALLED FROM HDPM. C ARGUMENTS: C N = RANDOM NUMBER DISTRIBUTED WITH NEG. BIN. DISTR. C XN = AVERAGE VALUE OF N C ECM = CENTER OF MASS ENERGY (GEV) C----------------------------------------------------------------------- IMPLICIT NONE #define __RANDPAINC__ #define __RUNPARINC__ #include "corsika.h" DOUBLE PRECISION ECM,P,PN,Q,R,SUM,XI,XK,XN INTEGER N,IX SAVE C----------------------------------------------------------------------- CC IF ( DEBUG ) WRITE(MDEBUG,*) 'RNEGBI: XN,ECM=',SNGL(XN),SNGL(ECM) C PARAMETERIZATION OF PARAMETER K OF NEG.BIN. DISTRIBUTION ACCORDING C TO UA5 COLLABORATION, PHYS. LETT. 167B (1986) 476 XK = 1.D0 / ( -0.104D0 + 0.058D0 * LOG( ECM ) ) C OTHER PARAMETERS R = XN / XK Q = 1.D0 / (1.D0 + R) P = R * Q C VALUES FOR N EQUAL 0 1 CONTINUE N = 0 PN = Q**XK SUM = PN C GET UNIFORM RANDOM NUMBER CALL RMMARD( RD,1,1 ) IF ( RD(1) .LE. SUM ) GOTO 100 C COMPARE WITH SUM OVER P(N) DO IX = 1, 1350 XI = DBLE(IX) PN = PN * P * (XK - 1.D0 + XI) / XI SUM = SUM + PN IF ( RD(1) .LE. SUM ) THEN N = XI GOTO 100 ENDIF ENDDO N = 1350 100 CONTINUE IF ( MOD(N,2) .NE. 0 .AND. N .NE. 1 ) GOTO 1 CC IF (DEBUG) WRITE(MDEBUG,*)'RNEGBI: RD(1),N,=',RD(1),N,SNGL(XN) RETURN END *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE TARINT C----------------------------------------------------------------------- C TAR(GET) INT(ERACTIONS) C C ROUTINE DETERMINES HOW MANY INTERACTIONS OCCUR IN TARGET. C THIS SUBROUTINE IS CALLED FROM HDPM. C----------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) #define __DPMFLGINC__ #define __GNUPRINC__ #define __INTERINC__ #define __PARPARINC__ #define __RANDPAINC__ #define __RESTINC__ #define __RUNPARINC__ #define __SIGMINC__ #include "corsika.h" SAVE C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'TARINT: ITYPE,TAR,NFLAIN', * ITYPE,SNGL(TAR),NFLAIN C NFLAIN EQUAL 0 : NUMBER OF INTERACTIONS IN TARGET CHOSEN RANDOMLY IF ( NFLAIN .EQ. 0 ) THEN C SIGMA IS ALREADY CALCULATED IN BOX2 DELSIG = SIGMA - 45.D0 DSIGSQ = DELSIG**2 C CHOOSE RANDOM NUMBER CALL RMMARD( RD,1,1 ) IF ( DEBUG ) WRITE(MDEBUG,*) 'TARINT: DELSIG,DSIGSQ,RD(1),TAR=', * SNGL(DELSIG),SNGL(DSIGSQ),SNGL(RD(1)),SNGL(TAR) C DO INTERACTION WITH CHOSEN TARGET ( N, O, AR ) PROB = 0.D0 C TREAT INTERACTION WITH NITROGEN TARGET IF ( TAR .EQ. 14.D0 ) THEN C SUM OF PROBABILITIES FOR COLLISION WITH NITROGEN TARGET DO JL = 1, 14 PROB = PROB + * SE14(1,JL) + SE14(2,JL)*DELSIG + SE14(3,JL)*DSIGSQ IF ( RD(1) .LE. PROB ) GOTO 7332 ENDDO C TREAT INTERACTION WITH OXYGEN TARGET ELSEIF ( TAR .EQ. 16.D0 ) THEN C SUM OF PROBABILITIES FOR COLLISION WITH OXYGEN TARGET DO JL = 1, 16 PROB = PROB + * SE16(1,JL) + SE16(2,JL)*DELSIG + SE16(3,JL)*DSIGSQ IF ( RD(1) .LE. PROB ) GOTO 7332 ENDDO C TREAT INTERACTION WITH ARGON TARGET ELSEIF ( TAR .EQ. 40.D0 ) THEN C SUM OF PROBABILITIES FOR COLLISION WITH ARGON TARGET DO JL = 1, 40 PROB = PROB + * SE40(1,JL) + SE40(2,JL)*DELSIG + SE40(3,JL)*DSIGSQ IF ( RD(1) .LE. PROB ) GOTO 7332 ENDDO ELSE #if !__INTTEST__ WRITE(MONIOU,*) 'TARINT: UNKNOWN TARGET = ',SNGL(TAR) #endif ENDIF JL = 1 C NUMBER OF COLLISIONS IN TARGET 7332 CONTINUE GNU = DBLE(JL) ELSE C NFLAIN EQUAL 1 : AVERAGE NUMBER OF INTERACTIONS IN TARGET IS TAKEN C NEW PARAMETERIZATION OF J.N.CAPDEVIELLE (MARCH 93) GNU = (0.4826D0 + 3.522D-2 * SLOG) * TAR**0.31D0 ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) * 'TARINT: # COLLISIONS IN TARGET=',SNGL(GNU) RETURN END #if __NUPRIM__ *-- Author : O. Pisanti Uni Naples 28/04/2003 C======================================================================= BLOCK DATA HERDAT C----------------------------------------------------------------------- C DATA FOR HERWIG-CORSIKA CPOUPLING C----------------------------------------------------------------------- IMPLICIT NONE INTEGER I #define __HWCRSKINC__ #include "corsika.h" C PARTICLES RECOGNIZED BY CORSIKA DATA (RNAMCOR(I),I=1,75)/ $'GAMMA ','E+ ','E- ','*** ','MU+ ', $'MU- ','PI0 ','PI+ ','PI- ','K_L0 ', ! 10 $'K+ ','K- ','N ','P ','PBAR ', $'K_S0 ','ETA ','LAMBDA ','SIGMA+ ','SIGMA0 ', ! 20 $'SIGMA- ','XI0 ','XI- ','OMEGA- ','NBAR ', $'LAMBDABR','SIGMABR-','SIGMABR0','SIGMABR+','XIBAR0 ', ! 30 $'XIBAR+ ','OMEGABR+','*** ','*** ','*** ', $'*** ','*** ','*** ','*** ','*** ', ! 40 $'*** ','*** ','*** ','*** ','*** ', $'*** ','*** ','*** ','*** ','OMEGA ', ! 50 $'RHO0 ','RHO+ ','RHO- ','DELTA++ ','DELTA+ ', $'DELTA0 ','DELTA- ','DLTABR--','DELTABR-','DELTABR0', ! 60 $'DELTABR+','K*0 ','K*+ ','K*- ','K*BAR0 ', $'NU_E ','NU_EBAR ','NU_MU ','NU_MUBAR','*** ', ! 70 $'*** ','*** ','*** ','*** ','*** '/ ! 75 #if __TAULEP__ DATA (RNAMCOR(I),I=76,130)/ $ 55*'*** '/ DATA (RNAMCOR(I),I=131,134)/ $'TAU+ ','TAU- ','NU_TAU ','NU_TAUBR'/ DATA (RNAMCOR(I),I=135,195)/ $ 61*'*** '/ #elif __CHARM__ DATA (RNAMCOR(I),I=76,195)/ $ 40*'*** ', $'D0 ','D+ ','D- ','DBAR0 ','D_S+ ', !120 $'D_S- ','ETA_C ','D*0 ','D*+ ','D*- ', $'D*BAR0 ','D*_S+ ','D*_S- ','*** ','JPSI ', !130 $'TAU+ ','TAU- ','NU_TAU ','NU_TAUBR','*** ', $'*** ','LMBDA_C+','XI_C+ ','XI_C0 ','SGMA_C++', !140 $'SIGMA_C+','SIGMA_C0','XIP_C+ ','XIP_C0 ','OMEGA_C0', $'*** ','*** ','*** ','LMBDA_C-','XI_C- ', !150 $'XI_CBAR0','SGMA_C--','SIGMA_C-','SGM_CBR0','XIP_C- ', $'XIP_CBR0','OMG_CBR0','*** ','*** ','*** ', !160 $'SGM*_C++','SGMA*_C+','SGMA*_C0','*** ','*** ', $ 5*'*** ', !170 $'SGM*_C--','SGMA*_C-','SG*_CBR0','*** ','*** ', $'B_D0 ','B+ ','B- ','B_DBAR0 ','B_S0 ', !180 $'B_SBAR0 ','B_C+ ','B_C- ','LMBDA_B0','SIGMA_B-', $'SIGMA_B+','XI_B0 ','XI_B- ','OMEGA_B-','LMD_BBR0', !190 $'SGM_BBR+','SGM_BBR-','XI_BBAR0','XI_B+ ','OMG_BBR+'/ #else DATA (RNAMCOR(I),I=76,195)/ 120*'*** '/ #endif END *-- Author : D. HECK IK FZK KARLSRUHE 28/04/2003 C======================================================================= SUBROUTINE HERLNK C----------------------------------------------------------------------- C HER(WIG) L(I)NK(ING ROUTINE) C C LINKS HERWIG MODEL TO CORSIKA. C THIS SUBROUTINE IS CALLED FROM SDPM. C----------------------------------------------------------------------- IMPLICIT NONE #define __INTERINC__ #define __MULTINC__ #define __NUPROCINC__ #define __PARPARINC__ #define __PARPAEINC__ #define __RANDPAINC__ #define __RUNPARINC__ #include "corsika.h" DOUBLE PRECISION SIGCC,SIGNC SAVE C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'HERLNK: ITYPE=',ITYPE C NEUTRINO-NUCLEON CHARGED AND NEUTRAL CROSS-SECTIONS IF ( ITYPE .EQ. 66 .OR. ITYPE .EQ. 68 #if __CHARM__ || __TAULEP__ * .OR. ITYPE .EQ. 133 #endif * ) THEN SIGCC = 5.53D-9 * GAMMA**.363D0 SIGNC = 2.31D-9 * GAMMA**.363D0 C ANTINEUTRINO-NUCLEON CHARGED AND NEUTRAL CROSS-SECTIONS ELSEIF ( ITYPE .EQ. 67 .OR. ITYPE .EQ. 69 #if __CHARM__ || __TAULEP__ * .OR. ITYPE .EQ. 134 #endif * ) THEN SIGCC = 5.52D-9 * GAMMA**.363D0 SIGNC = 2.29D-9 * GAMMA**.363D0 ENDIF C CHOSE PROCESS: CHARGED OR NEUTRAL CURRENT DEEP INELASTIC SCATTERING IF ( FIRSTI .AND. NUSLCT .EQ. 0 ) THEN JPROC = 9000 ! neutral current ELSEIF ( FIRSTI .AND. NUSLCT .EQ. 1 ) THEN JPROC = 9010 ! charge exchange ELSE CALL RMMARD( RD,1,5 ) IF ( RD(1) .LT. SIGCC/(SIGCC+SIGNC) ) THEN JPROC = 9010 ! charge exchange ELSE JPROC = 9000 ! neutral current ENDIF ENDIF EKINL = GAMMA C CALL HERWIG MAIN STEERING ROUTINE CALL HERMIN( ITYPE,ITAR,GAMMA,JPROC ) RETURN END *-- Author : O. Pisanti Uni Naples 28/04/2003 C======================================================================= SUBROUTINE HERMIN( ITYPE,ITAR,GAMMA,JPROC ) C----------------------------------------------------------------------- C HE(RWIG) MAIN (STEERING ROUTINE) C C THIS SUBROUTINE IS CALLED FROM HERLNK. C ARGUMENTS: C ITYPE = PARTICLE TYPE OF PROJECTILE C ITAR = PARTICLE TYPE OF TARGET (13 = NEUTRON, 14 = PROTON) C GAMMA = ENERGY OF NEUTRINO (GEV) C JPROC = PROCESS TO BE TREATED (CC = 9010, NC = 9000) C----------------------------------------------------------------------- INCLUDE 'HERWIG_C.INC' #define __ACCEPTEDINC__ #define __EE00INC__ #define __HWCRSKINC__ #define __PAMINC__ #define __RANDPAINC__ #define __RUNPARINC__ #include "corsika.h" DOUBLE PRECISION GAMMA INTEGER IRAND(3),ITAR,ITYPE,J,JPROC,LL,NN SAVE EXTERNAL HWUDAT C----------------------------------------------------------------------- IF ( DEBUG ) THEN IF ( JPROC .EQ. 9010 ) WRITE(MDEBUG,*) * 'HERMIN: JPROC=',JPROC,' CHARGE EXCHANGE' IF ( JPROC .EQ. 9000 ) WRITE(MDEBUG,*) * 'HERMIN: JPROC=',JPROC,' NEUTRAL CURRENT' ENDIF C NUMBER OF EVENTS HERWIG HAS TO GENERATE MAXEV = 100 C BEAM PARTICLES PART1 = RNAMCOR(ITYPE) PART2 = RNAMCOR(ITAR) C BEAM MOMENTA PBEAM1 = GAMMA PBEAM2 = 0.D0 ENU = PBEAM1 IF ( PART2 .EQ. 'P' ) THEN C PROTON ETLAB = PAMA(14) + ENU ELSEIF ( PART2 .EQ. 'N' ) THEN C NEUTRON ETLAB = PAMA(13) + ENU ELSE WRITE(MONIOU,*) 'HERMIN: ERROR IN THE TARGET PARTICLE' STOP ENDIF C CHOSE PROCESS: CHARGED OR NEUTRAL CURRENT DEEP INELASTIC SCATTERING IPROC = JPROC C INITIALIZE OTHER COMMON BLOCKS CALL HWIGIN C USER CAN RESET PARAMETERS AT THIS POINT, OTHERWISE DEFAULT C VALUES IN HWIGIN WILL BE USED C FOR NOT TO WRITE SUDAKOV FORM FACTORS LWSUD = 0 C FOR PRINTING DATA IN LARGER COLUMNS NPRFMT = 2 C FOR PRINTING ALL THE EVENTS MAXPR = 5 C MAXIMUM NUMBER OF NON FATAL ERRORS AFTER WHICH THE PROGRAM HAS C TO STOP MAXER = 100000000 C MINIMUM ALLOWED EFFICIENCY; SET IT TO LOWER VALUES IF THE PROGRAM C STOPS WITHOUT EVENTS EFFMIN = 1.D-8 C! Q2MAX=S-MN^2 AND ONE SHOULD HAVE Q2MIN<0) or off(0) iorshh=0 !other hadron-hadron int. turned on(1) or off(0) #elif __NEXUS__ C INITIALIZING FOR neXus3 egymin = 1.5 ! MINIMUM ENERGY CORREPSONDS WITH ELAB= 1 GeV egymax = 1.5E6 ! MAXIMUM ENERGY CORRESPONDS WITH ELAB=1000EeV #endif istore = 0 ! DO NOT STORE EVENTS ON zzz.data FILE CC the following commented statements are read by NEXPRM (see DATAC) CC ndecay = 1111110 ! let only resonances decay CC nrnody = nrnody + 1 ! number of nody to be set CC nody(nrnody) = 220 ! no decay for eta particles CC iappl = 1 ! C READ PARAMETERS SPECIFIED BY INPUT WITH KEY WORD 'EPOPAR' OR 'NEXPAR' CALL aread #if __EPOS__ IF(NFRAGM.GE.3)THEN infragm=0 ELSE infragm=NFRAGM ENDIF #elif __NEXUS__ C INITIALIZE THE n! CALL factoriel #endif CLOSE( NEXPRM ) airanxs(1)=14. airanxs(2)=16. airanxs(3)=40. airznxs(1)=7. airznxs(2)=8. airznxs(3)=18. airavznxs=0. do i=1,3 airwnxs(i)=sngl(COMPOS(i)) airavznxs=airavznxs+airwnxs(i)*airznxs(i) enddo airavanxs=sngl(AVERAW) NEXVER = iversn C DUMMY INITIALIZATIONS (FOR FILLING CROSS-SECTION TABLE) IF ( FNEXSG ) THEN #if __EPOS__ idprojin = 1120 idtargin = 1120 #elif __NEXUS__ idproj = 1120 idtarg = 1120 #endif maproj = 56 laproj = 28 matarg = 14 latarg = 1 pnll = 200. engy = -1. C SAVE AND RESTORE RANDOM NUMBER SEQUENCE because "ainit" can change it CALL RMMAQD( ISEEDUM(1),1,'R' ) CALL ainit CALL RMMAQD( ISEEDUM(1),1,'S' ) ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) 'NEXINI: EXIT' WRITE(MDEBUG,*) ' ' #if __INTTEST__ IF ( NDIF .NE. 0 ) THEN WRITE(MONIOU,*)'NEXINI: ONLY DIFFRACTIVE AND NON DIFFRACTIVE', * 'MIXED IS POSSIBLE WITH NEXPAR' STOP ENDIF #endif RETURN END *-- Author : D. HECK IK FZK KARLSRUHE 10/09/1998 C======================================================================= SUBROUTINE NEXLNK C----------------------------------------------------------------------- C (EPOS/)NEX(US) L(I)NK (TO CORSIKA) C C LINKS EPOS/NEXUS PACKAGE TO CORSIKA, NEEDS FIRST CALL OF NEXINI. C THIS SUBROUTINE IS CALLED FROM SDPM. C----------------------------------------------------------------------- IMPLICIT NONE #define __NEXLININC__ #define __NEXPARINC__ #define __NEXUSINC__ #define __PAMINC__ #define __PARPARINC__ #define __PARPAEINC__ #define __RANDPAINC__ #define __RESTINC__ #define __RUNPARINC__ #if __INTTEST__ #define __TSTINTINC__ #endif #include "corsika.h" #if __EPOS__ C--------------------------- EPOS COMMON ------------------------------ real pnll,ptq,exmass,cutmss,wproj,wtarg common/hadr1/pnll,ptq,exmass,cutmss,wproj,wtarg integer nevt,kolevt,npjevt,minfra,maxfra,nglevt,koievt,kohevt *,ntgevt,npnevt,nppevt,ntnevt,ntpevt,jpnevt,jppevt,jtnevt,jtpevt real phievt,bimevt,pmxevt,egyevt,xbjevt,qsqevt,zppevt,zptevt common/cevt/phievt,nevt,bimevt,kolevt,koievt,pmxevt,egyevt,npjevt *,ntgevt,npnevt,nppevt,ntnevt,ntpevt,jpnevt,jppevt,jtnevt,jtpevt *,xbjevt,qsqevt,nglevt,zppevt,zptevt,minfra,maxfra,kohevt integer idprojin,idtargin,irdmpr & ,isoproj,isotarg real rexdifi,rexndii common/hadr25/idprojin,idtargin,rexdifi(4),rexndii(4),irdmpr & ,isoproj,isotarg double precision seedi,seedj,seedj2,seedc integer iseqini,iseqsim common/cseed/seedi,seedj,seedj2,seedc,iseqini,iseqsim #elif __NEXUS__ C--------------------------- NEXUS COMMON ------------------------------ real pnll,ptq,exmass,cutmss,rstras,wproj,wtarg common/hadr1/pnll,ptq,exmass,cutmss,rstras,wproj,wtarg integer nevt,kolevt,npjevt *,ntgevt,npnevt,nppevt,ntnevt,ntpevt,jpnevt,jppevt,jtnevt,jtpevt real phievt,bimevt,pmxevt,egyevt,xbjevt,qsqevt common/cevt/phievt,nevt,bimevt,kolevt,pmxevt,egyevt,npjevt *,ntgevt,npnevt,nppevt,ntnevt,ntpevt,jpnevt,jppevt,jtnevt,jtpevt *,xbjevt,qsqevt double precision seedi,seedj,seedc common/cseed/seedi,seedj,seedc #endif integer iprmpt,ish,ishsub,irandm,irewch,iecho,modsho,idensi common/prnt1/iprmpt,ish,ishsub,irandm,irewch,iecho,modsho,idensi integer iomodl,idproj,idtarg,laproj,maproj,latarg,matarg real wexcit,core,fctrmx common/hadr2/iomodl,idproj,idtarg,wexcit common/nucl1/laproj,maproj,latarg,matarg,core,fctrmx integer icinpu real engy,elepti,elepto,angmue common/lept1/engy,elepti,elepto,angmue,icinpu real egymin,egymax,elab,ecms,ekin common/enrgy/egymin,egymax,elab,ecms,ekin C----------------------------------------------------------------------- DOUBLE PRECISION ELABN INTEGER J,NNEUT,NPROT SAVE C----------------------------------------------------------------------- IF ( DEBUG ) THEN WRITE(MDEBUG,*) 'NEXLNK: TAR',SNGL(TAR) ish = ISH0N C RANDOM GENERATOR STATUS (SEQUENCE L=1) AT BEGINNING OF EVENT CALL RMMAQD( ISEED(1,1),1,'R' ) IRAND(1) = ISEED(1,1) C NUMBER OF CALLS IRAND(2) = ISEED(2,1) C NUMBER OF BILLIONS IRAND(3) = ISEED(3,1) WRITE(MDEBUG,158) (IRAND(J),J=1,3) 158 FORMAT(' NEXLNK: RANDOM NUMBER GENERATOR AT BEGIN:' * ,' SEQUENCE= 1 SEED= ',I9,' CALLS=',I9, * ' BILLIONS=',I9) ctp ELSE ctp ish = 0 ENDIF seedc=ISEED(2,1)+1.D9*ISEED(3,1) C CALCULATE ENERGY IN LAB SYSTEM FOR ELASTICITY FOR VARIOUS PROJECTILES IF ( ITYPE .EQ. 1 ) THEN C TREAT GAMMA PROJECTILES (FROM EGS) C RHO0 USED AS PRIMARY ITYPE = 51 c CALL RMMARD( RD,1,1 ) c IF ( RD(1) .LE. 0.5D0 ) THEN c ITYPE = 7 c ELSE c ITYPE = 17 c ENDIF ELABN = CURPAR(1) CURPAR(1) = ELABN / PAMA(ITYPE) ELSEIF ( ITYPE .LT. 200 ) THEN C TREAT ORDINARY PROJECTILES ELABN = CURPAR(1) * PAMA(ITYPE) ELSE C TREAT NUCLEI PROJECTILES NPROT = MOD(ITYPE,100) NNEUT = ITYPE/100 - NPROT ELABN = CURPAR(1) * ( PAMA(14)*NPROT + PAMA(13)*NNEUT ) ENDIF C SET TARGET PARAMETERS matarg = NINT( TAR ) #if __EPOS__ idtargin = 1120 #elif __NEXUS__ idtarg = 1120 #endif IF ( TAR .EQ. 14.D0 ) THEN latarg = 7 ELSEIF ( TAR .EQ. 16.D0 ) THEN latarg = 8 ELSEIF ( TAR .EQ. 40.D0 ) THEN latarg = 18 #if __INTTEST__ ELSEIF ( TAR .EQ. 9.D0 ) THEN latarg = 4 ELSEIF ( TAR .EQ. 12.D0 ) THEN latarg = 6 ELSE IF ( DEBUG ) WRITE(MDEBUG,*) 'NEXLNK: TARGET TAR=',SNGL(TAR) IF ( ITTAR .EQ. 1 ) THEN C PROTON TARGET matarg = 1 latarg = 1 #if __EPOS__ idtargin = 1120 #elif __NEXUS__ idtarg = 1120 #endif TAR = 1.D0 ELSEIF ( ITTAR .EQ. 2 ) THEN C NEUTRON TARGET matarg = 1 latarg = -1 #if __EPOS__ idtargin = 1220 #elif __NEXUS__ idtarg = 1220 #endif TAR = 2.D0 ELSE C TARGET OF ARBITRARY NUCLEUS matarg = NINT( TAR ) latarg = NINT( TAR )/2 #if __EPOS__ idtargin = 1120 #elif __NEXUS__ idtarg = 1120 #endif ENDIF #else ELSE WRITE(MONIOU,*) 'NEXLNK: UNDEFINED TARGET TAR=',SNGL(TAR) #endif ENDIF C SET PROJECTILE PARAMETERS IF ( ITYPE .LT. 200 ) THEN #if __EPOS__ idprojin = IDTABL(ITYPE) IF ( idprojin .EQ. 20 .OR. idprojin .EQ. -20 ) THEN C TREAT NEUTRAL KAONS (K(0)S AND K(0)L) CALL RMMARD( RD,1,1 ) IF ( RD(1) .LE. 0.5D0 ) THEN idprojin = 230 ELSE idprojin = -230 ENDIF ELSEIF ( idprojin .EQ. 2130 ) THEN C EPOS CANNOT TREAT LAMBDA, TAKE INSTEAD SIGMA(0) idprojin = 1230 ELSEIF ( idprojin .EQ. -2130 ) THEN C EPOS CANNOT TREAT ANTI-LAMBDA, TAKE INSTEAD ANTI-SIGMA(0) idprojin = -1230 #if __CHARM__ cdh * ELSEIF ( IDPROJ .EQ. ?????) THEN C EPOS CANNOT TREAT ???? (charmed particles) #endif #elif __NEXUS__ idproj = IDTABL(ITYPE) IF ( IDPROJ .EQ. 20 .OR. IDPROJ .EQ. -20 ) THEN C TREAT NEUTRAL KAONS (K(0)S AND K(0)L) CALL RMMARD( RD,1,1 ) IF ( RD(1) .LE. 0.5D0 ) THEN idproj = 230 ELSE idproj = -230 ENDIF ELSEIF ( IDPROJ .EQ. 2130 ) THEN C NEXUS CANNOT TREAT LAMBDA, TAKE INSTEAD SIGMA(0) idproj = 1230 ELSEIF ( IDPROJ .EQ. -2130 ) THEN C NEXUS CANNOT TREAT ANTI-LAMBDA, TAKE INSTEAD ANTI-SIGMA(0) idproj = -1230 #endif ENDIF C ALL OTHER PARTICLE CODES UNCHANGED laproj = -1 maproj = 1 CDH2003 PNLL = CURPAR(1)*PAMA(ITYPE) pnll = PAMA(ITYPE) * BETA * GAMMA ELSE C PROJECTILE IS NUCLEUS #if __EPOS__ idprojin = 1120 #elif __NEXUS__ idproj = 1120 #endif laproj = MOD(ITYPE,100) maproj = ITYPE/100 CDH2003 PNLL = CURPAR(1)*(PAMA(14)+PAMA(13))*0.5 pnll = 0.5 * (PAMA(14)+PAMA(13)) * BETA * GAMMA ENDIF C SET ENGY NEGATIVE TO FORCE CALCULATION IN LAB FRAME engy = -1. ecms = -1. elab = -1. ekin = -1. C INTIALIZE ENERGY AND PARTICLE DEPENDENT PORTION OF EPOS/NEXUS C AT THE FIRST CALL: READ ALSO DATA SETS CALL AINIT #if __EPOS__ IF ( DEBUG ) WRITE(MDEBUG,*) 'NEXLNK: AEPOS IS NOW CALLED' C CALL TO EPOS CALL AEPOS( 1 ) IF ( DEBUG ) WRITE(MDEBUG,*) 'NEXLNK: RETURN FROM AEPOS' #elif __NEXUS__ IF ( DEBUG ) WRITE(MDEBUG,*) 'NEXLNK: ANEXUS IS NOW CALLED' C CALL TO neXus3 CALL ANEXUS( 1 ) IF ( DEBUG ) WRITE(MDEBUG,*) 'NEXLNK: RETURN FROM ANEXUS' #endif IF ( NEVT .EQ. 1 ) CALL AFINAL C NOW BRING PARTICLES TO CORSIKA STACK CALL NSTORE( ELABN ) IF ( DEBUG ) WRITE(MDEBUG,*) 'NEXLNK: (EXIT)' RETURN END *-- Author : D. HECK IK FZK KARLSRUHE 10/09/1998 C======================================================================= SUBROUTINE NEXSIG( ELAB,ICZ ) C----------------------------------------------------------------------- #if __EPOS__ C EPOS SIG(MAS) C C CALCULATES INELASTIC HADRON-AIR CROSS-SECTIONS FOR EPOS MODEL. #elif __NEXUS__ C NEX(US) SIG(MAS) C C CALCULATES INELASTIC HADRON-AIR CROSS-SECTIONS FOR NEXUS MODEL. #endif C NUCLEUS-AIR CROSS-SECTIONS ARE DETERMINED BY P-P CROSS-SECTIONS AND C THE CORSIKA GLAUBER TABLES (SEE BOX2). C THIS SUBROUTINE IS CALLED FROM BOX2. C ARGUMENTS: C ELAB = LABORATORY ENERGY (GEV) C ICZ = HADRON TYPE: 1 = PION, 2 = NUCLEON, 3 = KAON C----------------------------------------------------------------------- IMPLICIT NONE #define __NEXSSGMINC__ #define __PARPARINC__ #define __RUNPARINC__ #define __SIGMINC__ #include "corsika.h" DOUBLE PRECISION DELTAE,ELAB,SECT,WK(3),YE INTEGER I,ICZ,JE SAVE C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'NEXSIG: ELAB=',SNGL(ELAB), * ' ICZ=',ICZ C DETERMINE ENERGY INTERVAL FOR INTERPOLATION YE = LOG10(ELAB) IF ( YE .LT. 1.D0 ) YE = 1.D0 JE = INT( YE ) IF ( JE .GT. 9 ) JE = 9 DELTAE = YE - JE WK(3) = DELTAE * (DELTAE-1.D0) * .5D0 WK(1) = 1.D0 - DELTAE + WK(3) WK(2) = DELTAE - 2.D0 * WK(3) IF ( ICZ .LE. 3 ) THEN C FOR HADRON PROJECTILES SECT = 0.D0 DO I = 1, 3 SECT = SECT + SIGNAIR(JE+I-1,ICZ)*WK(I) ENDDO SIGAIR = EXP( SECT ) SECT = 0.D0 DO I = 1, 3 SECT = SECT + XFRACN(JE+I-1,ICZ)*WK(I) ENDDO FRACTN = EXP( SECT ) SECT = 0.D0 DO I = 1, 3 SECT = SECT + XFRANO(JE+I-1,ICZ)*WK(I) ENDDO FRCTNO = EXP( SECT ) SIGMA = 0.D0 ELSEIF ( ICZ .GE. 200 ) THEN C FOR NUCLEUS PROJECTILES DETERMINE ONLY NN CROSS-SECTION SIGAIR = 0.D0 FRACTN = 0.D0 FRCTNO = 0.D0 SIGMA = 0.D0 DO I = 1, 3 SIGMA = SIGMA + SIGNHN(JE+I-1,2)*WK(I) ENDDO SIGMA = EXP( SIGMA ) ELSE #if __THIN__ WRITE(MONIOU,444) (CURPAR(I),I=0,9),CURPAR(13) 444 FORMAT(' NEXSIG: CURPAR=',1P,11E11.3) #else WRITE(MONIOU,444) (CURPAR(I),I=0,9) 444 FORMAT(' NEXSIG: CURPAR=',1P,10E11.3) #endif WRITE(MONIOU,*) 'NEXSIG: ILLEGAL PROJECTILE TYP =',ICZ STOP ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) 'NEXSIG: SIGMA=',SNGL(SIGMA), * ' SIGAIR=',SNGL(SIGAIR) RETURN END *-- Author : D. HECK IK FZK KARLSRUHE 10/09/1998 C======================================================================= SUBROUTINE NEXSIGINI C----------------------------------------------------------------------- C NEX(US) SIG(MAS) INI(TIALIZATION) C C INITIALIZES INELASTIC CROSS-SECTION. C INTEGER 'ICZ' IS HADRON TYPE: 1 = PION, 2 = NUCLEON, 3 = KAON C THIS SUBROUTINE IS CALLED FROM START. C----------------------------------------------------------------------- IMPLICIT NONE #define __AIRINC__ #define __NEXSSGMINC__ #define __PAMINC__ #define __RUNPARINC__ #include "corsika.h" COMMON /PSAR33/ ASECT,ASECTN REAL ASECT(7,4,7) ! neXus3 REAL ASECTN(7,7,7) ! neXus3 for nucleus-nucleus DOUBLE PRECISION ATAR,ELAB,ENGY,EON,SECT(3),SECTN,SECTA,SECTO DOUBLE PRECISION WA(3),WK(3),YA,YE INTEGER IAT,ICZ,IPROJ,JA,JE,JEE,K,M SAVE C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'NEXSIGINI - START' IF ( DEBUG ) WRITE(MDEBUG,90) 90 FORMAT(' ENERGY(LAB) SIGAIR(PI) SIGAIR(N) SIGAIR(K)', * ' SIGMA(pi-p) SIGMA(p-p) SIGMA(K-p) ') DO 100 JEE = 1, 12 C LOOP 100 RUNS OVER ALL ENERGY VALUES C CALCULATE CM ENERGY 'ENGY' FROM LAB ENERGY 'ELAB' ELAB = 10.D0**JEE DO 99 ICZ = 1, 3 C HADRON PROJECTILES ICZ ARE: PI - 1, N - 2, K - 3 C FIRST FOR NITROGEN TARGET IF ( ICZ .EQ. 1 ) THEN IPROJ = 8 ELSEIF ( ICZ .EQ. 2 ) THEN IPROJ = 14 ELSEIF ( ICZ .EQ. 3 ) THEN IPROJ = 11 ENDIF ATAR = PAMA(14) ENGY = SQRT( 2.D0*ELAB*ATAR +ATAR**2+PAMA(IPROJ)**2 ) YE = LOG10(MAX( 1.D0, ENGY/1.5D0 ))+1.D0 CC IF ( DEBUG ) WRITE(MDEBUG,*) 'ENGY=',ENGY,' ELAB=',ELAB IF ( YE .LT. 1.D0 ) YE = 1.D0 JE = MIN( 5, 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) IAT = 14 YA = IAT YA = DLOG( YA ) / 0.69315D0 + 1.D0 JA = MIN( INT( YA ), 4 ) WA(2) = YA - JA WA(3) = WA(2) * (WA(2)-1.D0) * .5D0 WA(1) = 1.D0 - WA(2) + WA(3) WA(2) = WA(2) - 2.D0*WA(3) SECTN = 0.D0 DO K = 1, 3 DO M = 1, 3 SECTN = SECTN + ASECT(JE+K-1,ICZ,JA+M-1)*WA(M)*WK(K) ENDDO ENDDO CC IF ( DEBUG ) WRITE(MDEBUG,*) CC * 'ICZ,JEE,JE=',ICZ,JEE,JE,' SECTN=',SECTN SECTN = EXP( SECTN ) C THEN FOR OXYGEN TARGET ATAR = PAMA(14) ENGY = SQRT( 2.D0*ELAB*ATAR+ATAR**2+PAMA(IPROJ)**2 ) YE = LOG10(MAX( 1.D0, ENGY/1.5D0 ))+1.D0 IF ( YE .LT. 1.D0 ) YE = 1.D0 JE = MIN( 5, 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) IAT = 16 YA = IAT YA = DLOG( YA ) / 0.69315D0 + 1.D0 JA = MIN( INT( YA ), 4 ) WA(2) = YA - JA WA(3) = WA(2) * (WA(2)-1.D0) * .5D0 WA(1) = 1.D0 - WA(2) + WA(3) WA(2) = WA(2) - 2.D0*WA(3) SECTO = 0.D0 DO K = 1, 3 DO M = 1, 3 SECTO = SECTO + ASECT(JE+K-1,ICZ,JA+M-1)*WA(M)*WK(K) ENDDO ENDDO CC IF ( DEBUG ) WRITE(MDEBUG,*) CC * 'ICZ,JEE,JE=',ICZ,JEE,JE,' SECTO=',SECTO SECTO = EXP( SECTO ) C THEN FOR ARGON TARGET ATAR = PAMA(14) ENGY = SQRT( 2.D0*ELAB*ATAR+ATAR**2+PAMA(IPROJ)**2 ) YE = LOG10(MAX( 1.D0, ENGY/1.5D0 ))+1.D0 IF ( YE .LT. 1.D0 ) YE = 1.D0 JE = MIN( 5, 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) IAT = 40 YA = IAT YA = DLOG( YA ) / 0.69315D0 + 1.D0 JA = MIN( INT( YA ), 4 ) WA(2) = YA - JA WA(3) = WA(2) * (WA(2)-1.D0) * .5D0 WA(1) = 1.D0 - WA(2) + WA(3) WA(2) = WA(2) - 2.D0*WA(3) SECTA = 0.D0 DO K = 1, 3 DO M = 1, 3 SECTA = SECTA+ASECT(JE+K-1,ICZ,JA+M-1)*WA(M)*WK(K) ENDDO ENDDO CC IF ( DEBUG ) WRITE(MDEBUG,*) CC * 'ICZ,JEE,JE=',ICZ,JEE,JE,' SECTA=',SECTA SECTA = EXP( SECTA ) C NOW TAKE THE COMPOSITION OF AIR TO CALCULATE AIR CROSS-SECTION SECT(ICZ) = COMPOS(1)*SECTN XFRACN(JEE,ICZ) = LOG( SECT(ICZ) ) SECT(ICZ) = SECT(ICZ) + COMPOS(2)*SECTO XFRANO(JEE,ICZ) = LOG( SECT(ICZ) ) SECT(ICZ) = SECT(ICZ) + COMPOS(3)*SECTA SIGNAIR(JEE,ICZ) = LOG( SECT(ICZ) ) C PION NUCLEON, NUCLEON NUCLEON, KAON NUCLEON CROSS-SECTION ENGY = SQRT( 2.D0*ELAB*PAMA(14)+PAMA(14)**2+PAMA(IPROJ)**2 ) YE = LOG10(MAX( 1.D0, ENGY/1.5D0 ))+1.D0 IF ( YE .LT. 1.D0 ) YE = 1.D0 JE = MIN( 5, 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) SIGNHN(JEE,ICZ) = 0.D0 DO K = 1, 3 SIGNHN(JEE,ICZ) = SIGNHN(JEE,ICZ)+ASECT(JE+K-1,ICZ,1)*WK(K) ENDDO 99 CONTINUE IF ( DEBUG ) THEN EON = 10.D0**JEE WRITE(MDEBUG,103) EON,SECT(1),SECT(2),SECT(3), * EXP(SIGNHN(JEE,1)),EXP(SIGNHN(JEE,2)),EXP(SIGNHN(JEE,3)) 103 FORMAT(' ',7G14.5) ENDIF 100 CONTINUE IF ( DEBUG ) THEN WRITE(MDEBUG,*) WRITE(MDEBUG,*) 'NOW LOGARITHMS OF THE CROSS-SECTIONS' WRITE(MDEBUG,90) DO JEE = 1, 12 EON = 10.D0**JEE WRITE(MDEBUG,103) EON,SIGNAIR(JEE,1),SIGNAIR(JEE,2), * SIGNAIR(JEE,3),SIGNHN(JEE,1),SIGNHN(JEE,2),SIGNHN(JEE,3) ENDDO WRITE(MDEBUG,*) 'NEXSIGINI - END' ENDIF RETURN END *-- Author : D. HECK IK FZK KARLSRUHE 10/09/1998 C======================================================================= SUBROUTINE NSTORE( ELABN ) C----------------------------------------------------------------------- #if __EPOS__ C EPOS PARTICLES STORE (INTO CORSIKA STACK) #elif __NEXUS__ C N(EXUS PARTICLES) STORE (INTO CORSIKA STACK) #endif C C STORES EPOS/NEXUS OUTPUT PARTICLES INTO CORSIKA STACK. C THIS SUBROUTINE IS CALLED FROM NEXLNK. C ARGUMENT: C ELABN = ENERGY/NUCLEON OF PROJECTILE (GEV) C----------------------------------------------------------------------- IMPLICIT NONE #define __DPMFLGINC__ #define __ELADPMINC__ #define __ELASTYINC__ #define __ISTAINC__ #define __LONGIINC__ #define __MULTINC__ #define __PAMINC__ #define __PARPARINC__ #define __PARPAEINC__ #define __RANDPAINC__ #define __RESTINC__ #define __RUNPARINC__ #define __SIGMINC__ #if __AUGERHIST__ || __EHISTORY__ #define __GENERINC__ #endif #if __AUGERHIST__ || __COASTUSERLIB__ #define __OBSPARINC__ #endif #if __INTTEST__ #define __TSTINTINC__ #endif #include "corsika.h" integer mmry,mxptl parameter (mmry=1) !memory saving factor #if __EPOS__ C--------------------------- EPOS COMMON ------------------------------ integer nevt,kolevt,npjevt,minfra,maxfra,nglevt,koievt,kohevt *,ntgevt,npnevt,nppevt,ntnevt,ntpevt,jpnevt,jppevt,jtnevt,jtpevt real phievt,bimevt,pmxevt,egyevt,xbjevt,qsqevt,zppevt,zptevt common/cevt/phievt,nevt,bimevt,kolevt,koievt,pmxevt,egyevt,npjevt *,ntgevt,npnevt,nppevt,ntnevt,ntpevt,jpnevt,jppevt,jtnevt,jtpevt *,xbjevt,qsqevt,nglevt,zppevt,zptevt,minfra,maxfra,kohevt parameter (mxptl=200000/mmry) !max nr of particles in nexus particle list integer infragm common/nucl6/infragm #elif __NEXUS__ C--------------------------- NEXUS COMMON ------------------------------ integer nevt,kolevt,npjevt *,ntgevt,npnevt,nppevt,ntnevt,ntpevt,jpnevt,jppevt,jtnevt,jtpevt real phievt,bimevt,pmxevt,egyevt,xbjevt,qsqevt common/cevt/phievt,nevt,bimevt,kolevt,pmxevt,egyevt,npjevt *,ntgevt,npnevt,nppevt,ntnevt,ntpevt,jpnevt,jppevt,jtnevt,jtpevt *,xbjevt,qsqevt parameter (mxptl=50000/mmry) !max nr of particles in nexus particle list #endif integer nptl,iorptl,idptl,ifrptl,jorptl,istptl,ibptl,ityptl real pptl,tivptl,xorptl 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) integer laproj,maproj,latarg,matarg real core,fctrmx common/nucl1/laproj,maproj,latarg,matarg,core,fctrmx C----------------------------------------------------------------------- DOUBLE PRECISION EA,ELABN,ELASTI,EMAX,COSTET,PL2,PT2,PTM CC DOUBLE PRECISION GAMMAX DOUBLE PRECISION PFRX(60),PFRY(60),PTOT,CPHIV,SPHIV DOUBLE PRECISION FAC1,FAC2 REAL ETOT,GNU INTEGER ITYP(60),NREST,IREST,NNEW,INEW,NZNEW,NNNEW,I, * KODNEX,KODCRS,JFIN,KNEW,J,MEL,MEN,LL #if __EHISTORY__ INTEGER IK #endif SAVE #if __AUGERHIST__ DOUBLE PRECISION EDEP,THICKLOC,THICK INTEGER II EXTERNAL THICK #endif #if __COASTUSERLIB__ c definition of the COAST crs::CInteraction class COMMON/coastInteraction/coastX, coastY, coastZ, & coastE, coastCX, coastEl, coastProjId, coastTargId, & coastT double precision coastX, coastY, coastZ double precision coastE, coastCX, coastEl double precision coastT integer coastProjId, coastTargId #endif C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'NSTORE:' C NUMBER OF SPECTATORS OF REMAINING NUCLEUS IS NREST NREST = ITYPE/100 - npjevt IREST = ITYPE #if __INTTEST__ IWOUNP = npjevt IWOUNT = ntgevt #endif NNEW = 0 INEW = 0 ETOT = 0. ELASTI = 0. NZNEW = 0 NNNEW = 0 KNEW = 0 c event variables: c nrevt.......... event number c nptevt ........ number of (stored!) particles per event c bimevt ........ absolute value of impact parameter c phievt ........ angle of impact parameter c kolevt ........ number of collisions c pmxevt ........ reference momentum c egyevt ........ pp cm energy (hadron) or string energy (lepton) c npjevt ........ number of primary projectile participants c ntgevt ........ number of primary target participants GNU = kolevt EMAX = 0.D0 CC GAMMAX = 0.D0 #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME GRANDMOTHER PARTICLE DO IK = 0, 6 SECPAR(28+IK) = CURPAR(IK) ENDDO C STORE GENERATION COUNTER OF MOTHER SECPAR(35) = GEN C STORE MASS PENETRATION BEFORE INTERACTION SECPAR(36) = CURPAR(9) #if __THIN__ SECPAR(37) = CURPAR(13) #endif #endif C PARTICLE LOOP DO 5 I = 1, nptl C SKIP PARTICLES NOT FROM LAST GENERATION (ISTPTL=0) IF ( istptl(I) .GT. 0 ) GOTO 5 c particle variables: c i ............. particle number c idptl(i) ...... particle id c pptl(1,i) ..... x-component of particle momentum c pptl(2,i) ..... y-component of particle momentum c pptl(3,i) ..... z-component of particle momentum c pptl(4,i) ..... particle energy c pptl(5,i) ..... particle mass c iorptl(i) ..... particle number of father c jorptl(i) ..... particle number of mother c ifrptl(1,i) ... particle number of first child c ifrptl(2,i) ... particle number of last child c istptl(i) ..... generation flag: last gen.(0) or not(1) or ghost(2) c xorptl(1,i) ... x-component of formation point c xorptl(2,i) ... y-component of formation point c xorptl(3,i) ... z-component of formation point c xorptl(4,i) ... formation time c tivptl(1,i) ... formation time (always in the pp-cms!) c tivptl(2,i) ... destruction time (always in the pp-cms!) c ityptl(i) .....from target (10-19), soft (20-29), hard (30-39), c projectile (40-49) string, droplet (50) c idiptl(i) ..... id of father (999 if no father) c idjptl(i) ..... id of mother (999 if no mother) #if !__INTTEST__ C ELIMINATE TARGET SPECTATORS IF ( PPTL(3,I) .LT. 0.1D0 ) GOTO 5 C ELIMINATE BACKWARD GOING PARTICLES IF ( .NOT. LLONGI .AND. PPTL(3,I) .LT. 0. ) GOTO 5 #endif C CONVERT PARTICLE CODE NEX(US) ---> C(O)RS(IKA) C MOST FREQUENT PARTICLES COME FIRST KODNEX = idptl(I) C NUCLEUS IF ( KODNEX .GT. 10000 ) THEN KODCRS = MOD(KODNEX,10000)*10 + MOD(KODNEX/10000,1000) ELSEIF ( KODNEX .EQ. 17 ) THEN KODCRS = 201 ELSEIF ( KODNEX .EQ. 18 ) THEN KODCRS = 301 ELSEIF ( KODNEX .EQ. 19 ) THEN KODCRS = 402 C MESONS ELSEIF ( KODNEX .EQ. 110 ) THEN KODCRS = 7 ELSEIF ( KODNEX .EQ. 120 ) THEN KODCRS = 8 ELSEIF ( KODNEX .EQ. -120 ) THEN KODCRS = 9 ELSEIF ( KODNEX .EQ. 220 ) THEN KODCRS = 17 C NUCLEONS ELSEIF ( KODNEX .EQ. 1220 ) THEN KODCRS = 13 ELSEIF ( KODNEX .EQ. 1120 ) THEN KODCRS = 14 ELSEIF ( KODNEX .EQ. -1120 ) THEN KODCRS = 15 ELSEIF ( KODNEX .EQ. -1220 ) THEN KODCRS = 25 C STRANGE MESONS ELSEIF ( KODNEX .EQ. -20 .or. KODNEX .EQ. 230 ) THEN KODCRS = 10 ELSEIF ( KODNEX .EQ. 130 ) THEN KODCRS = 11 ELSEIF ( KODNEX .EQ. -130 ) THEN KODCRS = 12 ELSEIF ( KODNEX .EQ. 20 .or. KODNEX .EQ. -230 ) THEN KODCRS = 16 C STRANGE BARYONS ELSEIF ( KODNEX .EQ. 2130 ) THEN KODCRS = 18 ELSEIF ( KODNEX .EQ. 1130 ) THEN KODCRS = 19 ELSEIF ( KODNEX .EQ. 1230 ) THEN KODCRS = 20 ELSEIF ( KODNEX .EQ. 2230 ) THEN KODCRS = 21 ELSEIF ( KODNEX .EQ. 1330 ) THEN KODCRS = 22 ELSEIF ( KODNEX .EQ. 2330 ) THEN KODCRS = 23 ELSEIF ( KODNEX .EQ. 3331 ) THEN KODCRS = 24 ELSEIF ( KODNEX .EQ. -2130 ) THEN KODCRS = 26 ELSEIF ( KODNEX .EQ. -1130 ) THEN KODCRS = 27 ELSEIF ( KODNEX .EQ. -1230 ) THEN KODCRS = 28 ELSEIF ( KODNEX .EQ. -2230 ) THEN KODCRS = 29 ELSEIF ( KODNEX .EQ. -1330 ) THEN KODCRS = 30 ELSEIF ( KODNEX .EQ. -2330 ) THEN KODCRS = 31 ELSEIF ( KODNEX .EQ. -3331 ) THEN KODCRS = 32 C LEPTONS ELSEIF ( KODNEX .EQ. 10 ) THEN KODCRS = 1 ELSEIF ( KODNEX .EQ. -12 ) THEN KODCRS = 2 ELSEIF ( KODNEX .EQ. 12 ) THEN KODCRS = 3 ELSEIF ( KODNEX .EQ. -14 ) THEN KODCRS = 5 ELSEIF ( KODNEX .EQ. 14 ) THEN KODCRS = 6 #if __CHARM__ || __TAULEP__ C TAU LEPTONS ELSEIF ( KODNEX .EQ. -16 ) THEN KODCRS = 131 ! TAU(+) ELSEIF ( KODNEX .EQ. 16 ) THEN KODCRS = 132 ! TAU(-) #else C CANNOT TREAT TAU LEPTONS, CONVERT TO MUONS ELSEIF ( KODNEX .EQ. -16 ) THEN ! TAU(+) KODCRS = 5 ELSEIF ( KODNEX .EQ. 16 ) THEN ! TAU(- KODCRS = 6 #endif #if __CHARM__ C CHARMED MESONS ELSEIF ( KODNEX .EQ. -140 ) THEN ! D(0) KODCRS = 116 ELSEIF ( KODNEX .EQ. -240 ) THEN ! D(+) KODCRS = 117 ELSEIF ( KODNEX .EQ. 240 ) THEN ! A-D(-) KODCRS = 118 ELSEIF ( KODNEX .EQ. 140 ) THEN ! A-D(0) KODCRS = 119 ELSEIF ( KODNEX .EQ. -340 ) THEN ! D_S(+) KODCRS = 120 ELSEIF ( KODNEX .EQ. 340 ) THEN ! A-D_S(-) KODCRS = 121 ELSEIF ( KODNEX .EQ. 440 ) THEN ! ETA_C KODCRS = 122 ELSEIF ( KODNEX .EQ. -141 ) THEN ! D*(0) KODCRS = 123 ELSEIF ( KODNEX .EQ. -241 ) THEN ! D*(+) KODCRS = 124 ELSEIF ( KODNEX .EQ. 241 ) THEN ! A-D*(-) KODCRS = 125 ELSEIF ( KODNEX .EQ. 141 ) THEN ! A-D*(0) KODCRS = 126 ELSEIF ( KODNEX .EQ. -341 ) THEN ! D_S*(+) KODCRS = 127 ELSEIF ( KODNEX .EQ. 341 ) THEN ! A-D_S*(-) KODCRS = 128 ELSEIF ( KODNEX .EQ. 441 ) THEN ! J/PSI KODCRS = 130 C CHARMED BARYONS ELSEIF ( KODNEX .EQ. 2140 ) THEN ! LAMBDA_C(+) KODCRS = 137 ELSEIF ( KODNEX .EQ. 3140 ) THEN ! XI_C(+) KODCRS = 138 ELSEIF ( KODNEX .EQ. 3240 ) THEN ! XI_C(0) KODCRS = 139 ELSEIF ( KODNEX .EQ. 1140 ) THEN ! SIGMA_C(++) KODCRS = 140 ELSEIF ( KODNEX .EQ. 1240 ) THEN ! SIGMA_C(+) KODCRS = 141 ELSEIF ( KODNEX .EQ. 2240 ) THEN ! SIGMA_C(0) KODCRS = 142 ELSEIF ( KODNEX .EQ. 1340 ) THEN ! XI_C''(+) KODCRS = 143 ELSEIF ( KODNEX .EQ. 2340 ) THEN ! XI_C''(0) KODCRS = 144 ELSEIF ( KODNEX .EQ. 3340 ) THEN ! OMEGA_C(0) KODCRS = 145 ELSEIF ( KODNEX .EQ. -2140 ) THEN ! A-LAMBDA_C(-) KODCRS = 149 ELSEIF ( KODNEX .EQ. -3140 ) THEN ! A-XI_C(-) KODCRS = 150 ELSEIF ( KODNEX .EQ. -3240 ) THEN ! A-XI_C(0) KODCRS = 151 ELSEIF ( KODNEX .EQ. -1140 ) THEN ! A-SIGMA_C(--) KODCRS = 152 ELSEIF ( KODNEX .EQ. -1240 ) THEN ! A-SIGMA_C(-) KODCRS = 153 ELSEIF ( KODNEX .EQ. -2240 ) THEN ! A-SIGMA_C(0) KODCRS = 154 ELSEIF ( KODNEX .EQ. -1340 ) THEN ! A-XI_C''(-) KODCRS = 155 ELSEIF ( KODNEX .EQ. -2340 ) THEN ! A-XI_C''(0) KODCRS = 156 ELSEIF ( KODNEX .EQ. -3340 ) THEN ! A-OMEGA_C(0) KODCRS = 157 ELSEIF ( KODNEX .EQ. 1141 ) THEN ! SIGMA_C*(++) KODCRS = 161 ELSEIF ( KODNEX .EQ. 1241 ) THEN ! SIGMA_C*(+) KODCRS = 162 ELSEIF ( KODNEX .EQ. 2241 ) THEN ! SIGMA_C*(0) KODCRS = 163 ELSEIF ( KODNEX .EQ. -1141 ) THEN ! A-SIGMA_C*(--) KODCRS = 171 ELSEIF ( KODNEX .EQ. -1241 ) THEN ! A-SIGMA_C*(-) KODCRS = 172 ELSEIF ( KODNEX .EQ. -2241 ) THEN ! A-SIGMA_C*(0) KODCRS = 173 #else C CHARMED MESONS CANNOT BE TREATED, TAKE INSTEAD STRANGE MESONS ELSEIF ( KODNEX .EQ. -140 ) THEN ! D(0) KODCRS = 12 ELSEIF ( KODNEX .EQ. -240 .OR. ! D(+) * KODNEX .EQ. 240 ) THEN ! A-D(-) CALL RMMARD( RD,1,1 ) IF ( RD(1) .GE. 0.5D0 ) THEN KODCRS = 10 ELSE KODCRS = 16 ENDIF ELSEIF ( KODNEX .EQ. 140 ) THEN ! A-D(0) KODCRS = 11 ELSEIF ( KODNEX .EQ. -340 .OR. ! D_S(+) * KODNEX .EQ. 340 ) THEN ! A-D_S(-) IF ( RD(1) .GE. 0.5D0 ) THEN KODCRS = 10 ELSE KODCRS = 16 ENDIF ELSEIF ( KODNEX .EQ. 440 ) THEN ! ETA_C KODCRS = 17 ELSEIF ( KODNEX .EQ. -141 ) THEN ! D*(0) KODCRS = 12 ELSEIF ( KODNEX .EQ. -241 .OR. ! D*(+) * KODNEX .EQ. 241 .OR. ! A-D*(-) * KODNEX .EQ. -341 .OR. ! D_S*(+) * KODNEX .EQ. 341 ) THEN ! A-D_S*(-) IF ( RD(1) .GE. 0.5D0 ) THEN KODCRS = 10 ELSE KODCRS = 16 ENDIF ELSEIF ( KODNEX .EQ. 141 ) THEN ! A-D*(0) KODCRS = 11 ELSEIF ( KODNEX .EQ. 441 ) THEN ! J/PSI KODCRS = 17 C CHARMED BARYONS CANNOT BE TREATED, TAKE INSTEAD STRANGE BARYON ELSEIF ( KODNEX .EQ. 2140 ) THEN ! LAMBDA_C(+) KODCRS = 18 ELSEIF ( KODNEX .EQ. 3140 ) THEN ! XI_C(+) KODCRS = 22 ELSEIF ( KODNEX .EQ. 3240 ) THEN ! XI_C(0) KODCRS = 23 ELSEIF ( KODNEX .EQ. 1140 ) THEN ! SIGMA_C(++) KODCRS = 19 ELSEIF ( KODNEX .EQ. 1240 ) THEN ! SIGMA_C(+) KODCRS = 20 ELSEIF ( KODNEX .EQ. 2240 ) THEN ! SIGMA_C(0) KODCRS = 21 ELSEIF ( KODNEX .EQ. 1340 ) THEN ! XI_C''(+) KODCRS = 23 ELSEIF ( KODNEX .EQ. 2340 ) THEN ! XI_C''(0) KODCRS = 22 ELSEIF ( KODNEX .EQ. 3340 ) THEN ! OMEGA_C(0) KODCRS = 24 ELSEIF ( KODNEX .EQ. -2140 ) THEN ! A-LAMBDA_C(-) KODCRS = 26 ELSEIF ( KODNEX .EQ. -3140 ) THEN ! A-XI_C(-) KODCRS = 30 ELSEIF ( KODNEX .EQ. -3240 ) THEN ! A-XI_C(0) KODCRS = 31 ELSEIF ( KODNEX .EQ. -1140 ) THEN ! A-SIGMA_C(--) KODCRS = 27 ELSEIF ( KODNEX .EQ. -1240 ) THEN ! A-SIGMA_C(-) KODCRS = 28 ELSEIF ( KODNEX .EQ. -2240 ) THEN ! A-SIGMA_C(0) KODCRS = 29 ELSEIF ( KODNEX .EQ. -1340 ) THEN ! A-XI_C''(-) KODCRS = 31 ELSEIF ( KODNEX .EQ. -2340 ) THEN ! A-XI_C''(0) KODCRS = 30 ELSEIF ( KODNEX .EQ. -3340 ) THEN ! A-OMEGA_C(0) KODCRS = 32 ELSEIF ( KODNEX .EQ. 1141 ) THEN ! SIGMA_C*(++) KODCRS = 161 ELSEIF ( KODNEX .EQ. 1241 ) THEN ! SIGMA_C*(+) KODCRS = 162 ELSEIF ( KODNEX .EQ. 2241 ) THEN ! SIGMA_C*(0) KODCRS = 163 ELSEIF ( KODNEX .EQ. -1141 ) THEN ! A-SIGMA_C*(--) KODCRS = 171 ELSEIF ( KODNEX .EQ. -1241 ) THEN ! A-SIGMA_C*(-) KODCRS = 172 ELSEIF ( KODNEX .EQ. -2241 ) THEN ! A-SIGMA_C*(0) KODCRS = 173 #endif #if __NEUTRINO__ ELSEIF ( KODNEX .EQ. 11 ) THEN KODCRS = 66 ELSEIF ( KODNEX .EQ. -11 ) THEN KODCRS = 67 ELSEIF ( KODNEX .EQ. 13 ) THEN KODCRS = 68 ELSEIF ( KODNEX .EQ. -13 ) THEN KODCRS = 69 #if __CHARM__ || __TAULEP__ C TAU NEUTRINO CANNOT BE TREATED, TAKE INSTEAD MUONIC NEUTRINO ELSEIF ( KODNEX .EQ. 15 ) THEN ! NU_TAU KODCRS = 133 ELSEIF ( KODNEX .EQ. -15 ) THEN ! A-NU_TAU KODCRS = 134 #else C CANNOT TREAT TAU NEUTRINO, TAKE INSTEAD MUONIC NEUTRINO ELSEIF ( KODNEX .EQ. 15 ) THEN ! NU_TAU KODCRS = 68 ELSEIF ( KODNEX .EQ. -15 ) THEN ! A-NU_TAU KODCRS = 69 #endif #else C NEUTRINOS ARE SKIPPED ELSEIF ( KODNEX .EQ. 11 ) THEN GOTO 55 ELSEIF ( KODNEX .EQ. -11 ) THEN GOTO 55 ELSEIF ( KODNEX .EQ. 13 ) THEN GOTO 55 ELSEIF ( KODNEX .EQ. -13 ) THEN GOTO 55 ELSEIF ( KODNEX .EQ. 15 ) THEN GOTO 55 ELSEIF ( KODNEX .EQ. -15 ) THEN GOTO 55 #endif ELSE WRITE(MONIOU,*)'NSTORE: UNKNOWN PARTICLE CODE IDPTL=',idptl(I) GOTO 5 ENDIF SECPAR(0) = KODCRS C ELIMINATE BACKWARD GOING PARTICLES IF ( LLONGI .AND. PPTL(3,I) .LT. 0. ) GOTO 56 IF ( ( KODCRS .NE. 1 .AND. KODCRS .LE. 65 ) * .OR. KODCRS .GE. 100 ) THEN C ORDINARY SECONDARY PARTICLES SECPAR(1) = PPTL(4,I)/PAMA(KODCRS) C LOOK FOR SPECTATOR NUCLEONS IF ( KODCRS .EQ. 13 .OR. KODCRS .EQ. 14 ) THEN #if !__INTTEST__ C ELIMINATE 'ABSOLUTE' TARGET SPECTATORS #if __EPOS__ IF ( iorptl(I).GT.maproj .AND. iorptl(I).LE.maproj+matarg * .AND. ityptl(I).EQ.0 .AND. istptl(I).EQ.0 ) GOTO 5 #elif __NEXUS__ IF ( I.GT.maproj .AND. I.LE.maproj+matarg .AND. * iorptl(I).EQ.0 .AND. istptl(I).EQ.0 ) GOTO 5 #endif #endif C TREAT 'ABSOLUTE' PROJECTILE SPECTATORS #if __EPOS__ IF ( iorptl(I).GE.1 .AND. iorptl(I).LE.maproj * .AND. ityptl(I).EQ.0 .AND. istptl(I).EQ.0 ) THEN IF ( infragm .EQ. 0 .AND. NFRAGM .NE. 0 ) THEN #elif __NEXUS__ IF ( I .GE. 1 .AND. I .LE. maproj .AND. * iorptl(I) .EQ. 0 .AND. istptl(I) .EQ. 0 ) THEN IF ( NFRAGM .NE. 0 ) THEN #endif C COMPOSE PROJECTILE SPECTATORS TO REMAINING NUCLEUS NREST = NREST - 1 NNEW = NNEW + 1 IF ( KODCRS .EQ. 14 ) THEN INEW = INEW + 101 IREST = IREST - 101 ELSEIF ( KODCRS .EQ. 13 ) THEN INEW = INEW + 100 IREST = IREST - 100 ENDIF #if !__INTTEST__ GOTO 5 #endif ENDIF C DISREGARD PROJECTILE SPECTATORS FOR ELASTICITY GOTO 7 ENDIF ENDIF CC IF ( SECPAR(1) .GT. GAMMAX ) THEN CC GAMMAX = SECPAR(1) C CALCULATE ELASTICITY FROM ENERGY OF FASTEST PARTICLE (LEADER) CC ELASTI = GAMMAX * PAMA(KODCRS) / ELABN CC ENDIF IF ( PPTL(4,I) .GT. EMAX ) THEN EMAX = PPTL(4,I) C CALCULATE ELASTICITY FROM MOST ENERGETIC PARTICLE (LEADER) ELASTI = EMAX * maproj / ELABN ENDIF ELSE C GAMMAS AND NEUTRINOS SECPAR(1) = PPTL(4,I) ENDIF C COUNTER FOR ENERGY-MULTIPLICITY MATRIX MSMM = MSMM + 1 C DETERMINE ANGLES FROM LONGITUDINAL AND TRANSVERSAL MOMENTA 7 CONTINUE PT2 = DBLE(PPTL(1,I))**2 + DBLE(PPTL(2,I))**2 PL2 = DBLE(PPTL(3,I))**2 IF ( PL2+PT2 .LE. 0.D0 ) THEN PTOT = 0.D0 COSTET = 0.D0 CPHIV = 1.D0 SPHIV = 0.D0 ELSE PTOT = SQRT( PL2 + PT2 ) COSTET = DBLE(PPTL(3,I)) / PTOT COSTET = MAX( MIN(COSTET, 1.D0), -1.D0 ) CPHIV = DBLE(PPTL(1,I)) / PTOT SPHIV = DBLE(PPTL(2,I)) / PTOT ENDIF #if __INTTEST__ C IF ( COSTET .EQ. 0.D0 ) COSTET = 1.D-4 SECPAR(17) = SQRT( PPTL(1,I)**2 + PPTL(2,I)**2 ) #endif C COUNTERS FOR FIRST INTERACTION IF ( FIRSTI ) THEN IF ( SECPAR(0) .EQ. 7.D0 .OR. SECPAR(0) .EQ. 8.D0 * .OR. SECPAR(0) .EQ. 9.D0 ) THEN IFINPI = IFINPI + 1 ELSEIF ( SECPAR(0) .EQ. 13.D0 .OR. SECPAR(0) .EQ. 14.D0 * .OR. SECPAR(0) .EQ. 15.D0 .OR. SECPAR(0) .EQ. 25.D0) THEN IFINNU = IFINNU + 1 ELSEIF ( SECPAR(0) .EQ. 10.D0 .OR. SECPAR(0) .EQ. 11.D0 * .OR. SECPAR(0) .EQ. 12.D0 .OR. SECPAR(0) .EQ. 16.D0) THEN IFINKA = IFINKA + 1 ELSEIF ( SECPAR(0) .EQ. 17.D0 ) THEN IFINET = IFINET + 1 ELSEIF ((SECPAR(0) .GE. 18.D0 .AND. SECPAR(0) .LE. 24.D0) * .OR. (SECPAR(0) .GE. 26.D0 .AND. SECPAR(0) .LE. 32.D0))THEN IFINHY = IFINHY + 1 ELSEIF ( SECPAR(0) .GE. 51.D0 .AND. SECPAR(0) .LE. 53.D0) THEN IFINRHO = IFINRHO + 1 #if __CHARM__ ELSEIF ((SECPAR(0).GE.116.D0 .AND. SECPAR(0).LE.130.D0) .OR. * (SECPAR(0).GE.137.D0 .AND. SECPAR(0).LE.173.D0)) THEN IFINCM = IFINCM + 1 #endif ELSE IFINOT = IFINOT + 1 ENDIF ENDIF ETOT = ETOT + PPTL(4,I) CALL ADDANG4( COSTHE,PHIX,PHIY, COSTET,CPHIV,SPHIV, * SECPAR(2),SECPAR(3),SECPAR(4) ) #if __UPWARD__ IF ( SECPAR(2) .GE. -1.D0 ) THEN #else IF ( SECPAR(2) .GT. C(29) ) THEN #endif #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER PARTICLE DO IK = 0, 8 SECPAR(IK+17) = SECPAR(IK) ENDDO #if __THIN__ SECPAR(26) = SECPAR(13) #endif #endif CALL TSTACK GOTO 5 ELSE GOTO 56 ENDIF #if !__NEUTRINO__ 55 IF ( LLONGI ) THEN C ADD NEUTRINO ENERGY TO LONGITUDINAL ENERGY DEPOSIT #if __THIN__ DLONG(LHEIGH,8) = DLONG(LHEIGH,8) + PPTL(4,I) * WEIGHT #else DLONG(LHEIGH,8) = DLONG(LHEIGH,8) + PPTL(4,I) #endif ENDIF GOTO 5 #endif 56 IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT IF ( KODCRS .LE. 3 ) THEN #if __THIN__ DLONG(LHEIGH,13) = DLONG(LHEIGH,13) * + (PPTL(4,I) - RESTMS(KODCRS) ) * WEIGHT ELSEIF ( KODCRS .EQ. 5 .OR. KODCRS .EQ. 6 ) THEN DLONG(LHEIGH,15) = DLONG(LHEIGH,15) + PPTL(4,I) * WEIGHT #if __NEUTRINO__ ELSEIF ( ( KODCRS .GE. 66 .AND. KODCRS .LE. 69 ) #if __CHARM__ || __TAULEP__ * .OR. KODCRS .EQ. 133 .OR. KODCRS .EQ. 134 #endif * ) THEN DLONG(LHEIGH,18) = DLONG(LHEIGH,18) + PPTL(4,I) * WEIGHT #endif ELSE IF ( KODCRS .EQ. 8 .OR. KODCRS .EQ. 9 .OR. * KODCRS .EQ. 11 .OR. KODCRS .EQ. 12 ) THEN FAC1 = 0.25D0 FAC2 = 0.75D0 ELSEIF ( KODCRS .EQ. 10 .OR. KODCRS .EQ. 16 ) THEN FAC1 = 0.5D0 FAC2 = 0.5D0 ELSE FAC1 = 1.D0 FAC2 = 0.D0 ENDIF C ADD TO THE HADRON ENERGY DEPOSIT DLONG(LHEIGH,17) = DLONG(LHEIGH,17) * + (PPTL(4,I)-RESTMS(KODCRS) )*WEIGHT*FAC1 C ADD TO THE NEUTRINO DEPOSIT DLONG(LHEIGH,18) = DLONG(LHEIGH,18) * + (PPTL(4,I)-RESTMS(KODCRS) )*WEIGHT*FAC2 #else DLONG(LHEIGH,13) = DLONG(LHEIGH,13) + PPTL(4,I) * - RESTMS(KODCRS) ELSEIF ( KODCRS .EQ. 5 .OR. KODCRS .EQ. 6 ) THEN DLONG(LHEIGH,15) = DLONG(LHEIGH,15) + PPTL(4,I) #if __NEUTRINO__ ELSEIF ( ( KODCRS .GE. 66 .AND. KODCRS .LE. 69 ) #if __CHARM__ || __TAULEP__ * .OR. KODCRS .EQ. 133 .OR. KODCRS .EQ. 134 #endif * ) THEN DLONG(LHEIGH,18) = DLONG(LHEIGH,18) + PPTL(4,I) #endif ELSE IF ( KODCRS .EQ. 8 .OR. KODCRS .EQ. 9 .OR. * KODCRS .EQ. 11 .OR. KODCRS .EQ. 12 ) THEN FAC1 = 0.25D0 FAC2 = 0.75D0 ELSEIF ( KODCRS .EQ. 10 .OR. KODCRS .EQ. 16 ) THEN FAC1 = 0.5D0 FAC2 = 0.5D0 ELSE FAC1 = 1.D0 FAC2 = 0.D0 ENDIF C ADD TO THE HADRON ENERGY DEPOSIT DLONG(LHEIGH,17) = DLONG(LHEIGH,17) * + (PPTL(4,I)-RESTMS(KODCRS) )*FAC1 C ADD TO THE NEUTRINO DEPOSIT DLONG(LHEIGH,18) = DLONG(LHEIGH,18) * + (PPTL(4,I)-RESTMS(KODCRS) )*FAC2 #endif ENDIF ENDIF #if __AUGERHIST__ THICKLOC = THICK( H ) DO LL = 1, NOBSLV IF ( THICKLOC .GE. THCKOB(LL) .AND. * THICKLOC .LT. THCKOB(LL)+SAMPTH ) THEN C THICKH IS WITHIN 1 G/CM^2 BELOW OBSLEV(LL) C BRING THE ENERGY BELOW ANGULAR CUT TO THE HISTO OF LEVEL LL OUTPAR(0) = KODCRS IF ( KODCRS .EQ. 1 ) THEN OUTPAR(1) = PPTL(4,I) EDEP = OUTPAR(1) * WEIGHT ELSEIF ( KODCRS .EQ. 2 .OR. KODCRS .EQ. 3 ) THEN OUTPAR(1) = PPTL(4,I) EDEP = ( PPTL(4,I) - RESTMS(KODCRS) ) * WEIGHT ELSE OUTPAR(1) = PPTL(4,I) / PAMA(KODCRS) EDEP = ( PPTL(4,I) - RESTMS(KODCRS) ) * WEIGHT ENDIF DO II = 2, 8 OUTPAR(II) = SECPAR(II) ENDDO OUTPAR( 9) = GEN OUTPAR(10) = ALEVEL OUTPAR(13) = WEIGHT C WE HAVE ANGULAR CUT CALL AUGERDEPFIL( EDEP,LL,1 ) ELSEIF ( THICKLOC .LT. THCKOB(LL) ) THEN GOTO 111 ENDIF ENDDO 111 CONTINUE #endif 5 CONTINUE IF ( DEBUG ) WRITE(MDEBUG,*) 'NSTORE: NTGEVT,ETOT =',ntgevt,ETOT IF ( NFRAGM .NE. 0 .AND. INEW .GT. 0 ) THEN C TREAT REMAINING NUCLEUS IF ( DEBUG ) WRITE(MDEBUG,150) INEW,(CURPAR(I),I=1,8) 150 FORMAT(' NSTORE: REMNNT=',1P,I10,8E10.3) SECPAR(1) = CURPAR(1) SECPAR(2) = CURPAR(2) SECPAR(3) = CURPAR(3) SECPAR(4) = CURPAR(4) #if __INTTEST__ SECPAR(17) = CURPAR(17) #endif IF ( INEW .EQ. 100 ) THEN C REMAINING NUCLEUS IS SINGLE NEUTRON SECPAR(0) = 13.D0 #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER PARTICLE DO IK = 0, 8 SECPAR(IK+17) = SECPAR(IK) ENDDO #if __THIN__ SECPAR(26) = SECPAR(13) #endif #endif CALL TSTACK ETOT = ETOT + SECPAR(1) * PAMA(13) GOTO 140 ELSEIF ( INEW .EQ. 101 ) THEN C REMAINING NUCLEUS IS SINGLE PROTON SECPAR(0) = 14.D0 #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER PARTICLE DO IK = 0, 8 SECPAR(IK+17) = SECPAR(IK) ENDDO #if __THIN__ SECPAR(26) = SECPAR(13) #endif #endif CALL TSTACK ETOT = ETOT + SECPAR(1) * PAMA(14) GOTO 140 ELSEIF ( NFRAGM .GE. 2 ) THEN C REMAINING NUCLEUS IS EVAPORATING NUCLEONS AND ALPHA PARTICLES NZNEW = MOD(INEW,100) NNNEW = INEW/100 - NZNEW JFIN = 0 CALL VAPOR( MAPROJ,INEW,JFIN,ITYP,PFRX,PFRY ) IF ( JFIN .EQ. 0 ) GOTO 139 C LOOP TO TREAT THE REMANENTS OF THE DESINTEGRATED FRAGMENT KNEW = 0 DO 135 J = 1, JFIN EA = GAMMA * PAMA(ITYP(J)) IF (DEBUG) WRITE(MDEBUG,*) 'NSTORE: J,ITYP,EA=', * J,ITYP(J),EA C MOMENTA SQUARED PTM = ( EA - PAMA(ITYP(J)) ) * ( EA + PAMA(ITYP(J)) ) PT2 = PFRX(J)**2 + PFRY(J)**2 IF ( PT2 .GE. PTM ) THEN IF (DEBUG) WRITE(MDEBUG,*) 'NSTORE: PT REJECT PARTICLE',J GOTO 135 ENDIF IF ( PTM .GT. 0.D0 ) THEN PTOT = SQRT( PTM ) COSTET = SQRT( 1.D0 - PT2/PTM ) CPHIV = PFRX(J) / PTOT SPHIV = PFRY(J) / PTOT ELSE PTOT = 0.D0 COSTET = 0.D0 CPHIV = 1.D0 SPHIV = 0.D0 ENDIF CALL ADDANG4( COSTHE,PHIX,PHIY, COSTET,CPHIV,SPHIV, * SECPAR(2),SECPAR(3),SECPAR(4) ) #if __UPWARD__ IF ( SECPAR(2) .GE. -1.D0 ) THEN #else IF ( SECPAR(2) .GT. C(29) ) THEN #endif IF ( J .LT. JFIN ) THEN SECPAR(0) = ITYP(J) #if __INTTEST__ SECPAR(17) = SQRT( PT2 ) #endif #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER PARTICLE DO IK = 0, 8 SECPAR(IK+17) = SECPAR(IK) ENDDO #if __THIN__ SECPAR(26) = SECPAR(13) #endif #endif CALL TSTACK ELSE KNEW = ITYP(JFIN) ENDIF ELSE IF ( DEBUG ) WRITE(MDEBUG,*) * 'NSTORE: ANGLE REJECT PARTICLE',J IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT #if __THIN__ DLONG(LHEIGH,17) = DLONG(LHEIGH,17) + ( EA * - RESTMS(ITYP(J)) )* WEIGHT #else DLONG(LHEIGH,17) = DLONG(LHEIGH,17) +EA-RESTMS(ITYP(J)) #endif ENDIF #if __AUGERHIST__ THICKLOC = THICK( H ) DO LL = 1, NOBSLV IF ( THICKLOC .GE. THCKOB(LL) .AND. * THICKLOC .LT. THCKOB(LL)+SAMPTH ) THEN C THICKH IS WITHIN 1 G/CM^2 BELOW OBSLEV(LL) C BRING THE ENERGY BELOW ANGULAR CUT TO THE HISTO OF LEVEL LL OUTPAR(0) = ITYP(J) DO II = 1, 8 OUTPAR(II) = SECPAR(II) ENDDO OUTPAR( 9) = GEN OUTPAR(10) = ALEVEL OUTPAR(13) = WEIGHT EDEP = ( OUTPAR(1) * PAMA(ITYP(J)) * - RESTMS(ITYP(J)) ) * WEIGHT C WE HAVE ANGULAR CUT CALL AUGERDEPFIL( EDEP,LL,1 ) ELSEIF ( THICKLOC .LT. THCKOB(LL) ) THEN GOTO 112 ENDIF ENDDO 112 CONTINUE #endif ENDIF 135 CONTINUE ELSEIF ( NFRAGM .EQ. 1 ) THEN C REMAINING NUCLEUS IS ONE FRAGMENT NZNEW = MOD(INEW,100) NNNEW = INEW/100 - NZNEW KNEW = INEW ENDIF IF ( KNEW/100 .EQ. 5 ) THEN C REMAINING NUCLEUS: MASS 5 CANNOT BE TREATED IN BOX2 IF ( MOD(KNEW,100) .GE. 3 ) THEN C MASS 5: SPLIT OFF ONE PROTON SECPAR(0) = 14.D0 #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER PARTICLE DO IK = 0, 8 SECPAR(IK+17) = SECPAR(IK) ENDDO #if __THIN__ SECPAR(26) = SECPAR(13) #endif #endif CALL TSTACK KNEW = KNEW - 101 ELSE C MASS 5: SPLIT OFF ONE NEUTRON SECPAR(0) = 13.D0 #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER PARTICLE DO IK = 0, 8 SECPAR(IK+17) = SECPAR(IK) ENDDO #if __THIN__ SECPAR(26) = SECPAR(13) #endif #endif CALL TSTACK KNEW = KNEW - 100 ENDIF ELSEIF ( KNEW/100 .EQ. 8 ) THEN C REMAINING NUCLEUS: MASS 8 CANNOT BE TREATED IN BOX2 IF ( MOD(KNEW,100) .GE. 5 ) THEN C MASS 8: SPLIT OFF ONE PROTON SECPAR(0) = 14.D0 #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER PARTICLE DO IK = 0, 8 SECPAR(IK+17) = SECPAR(IK) ENDDO #if __THIN__ SECPAR(26) = SECPAR(13) #endif #endif CALL TSTACK KNEW = KNEW - 101 ELSEIF ( MOD(KNEW,100) .LE. 3 ) THEN C MASS 8: SPLIT OFF ONE NEUTRON SECPAR(0) = 13.D0 #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER PARTICLE DO IK = 0, 8 SECPAR(IK+17) = SECPAR(IK) ENDDO #if __THIN__ SECPAR(26) = SECPAR(13) #endif #endif CALL TSTACK KNEW = KNEW - 100 ELSE C MASS 8: SPLIT OFF ONE ALPHA PARTICLE SECPAR(0) = 402.D0 #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER PARTICLE DO IK = 0, 8 SECPAR(IK+17) = SECPAR(IK) ENDDO #if __THIN__ SECPAR(26) = SECPAR(13) #endif #endif CALL TSTACK KNEW = KNEW - 402 ENDIF ENDIF SECPAR(0) = KNEW #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER PARTICLE DO IK = 0, 8 SECPAR(IK+17) = SECPAR(IK) ENDDO #if __THIN__ SECPAR(26) = SECPAR(13) #endif #endif CALL TSTACK ENDIF 139 ETOT = ETOT + SECPAR(1)*(PAMA(13)*NNNEW + PAMA(14)*NZNEW) 140 CONTINUE IF ( DEBUG ) WRITE(MDEBUG,1401) ELASTI,ETOT,ELABN,ETOT/ELABN 1401 FORMAT(1H ,'NSTORE: ELASTI,ETOT,ELABN,MISMATCH=', * F8.5,1X,2(F15.2,1X),F8.5) C FILL ELASTICITY IN MATRICES MEL = MIN ( 1.D0+10.D0* MAX( 0.D0, ELASTI ) , 11.D0 ) MEN = MIN ( 4.D0+ 3.D0*LOG10(MAX( .1D0, EKINL )), 40.D0 ) #if __THIN__ IELDPM(MEN,MEL) = IELDPM(MEN,MEL) + NINT( WEIGHT ) IELDPA(MEN,MEL) = IELDPA(MEN,MEL) + NINT( WEIGHT ) IF ( ELASTI .LT. 1.D0 ) THEN ELMEAN(MEN) = ELMEAN(MEN) + ELASTI * WEIGHT ELMEAA(MEN) = ELMEAA(MEN) + ELASTI * WEIGHT #else IELDPM(MEN,MEL) = IELDPM(MEN,MEL) + 1 IELDPA(MEN,MEL) = IELDPA(MEN,MEL) + 1 IF ( ELASTI .LT. 1.D0 ) THEN ELMEAN(MEN) = ELMEAN(MEN) + ELASTI ELMEAA(MEN) = ELMEAA(MEN) + ELASTI #endif ENDIF #if __COASTUSERLIB__ C for epos/nexus coastProjId = nint(curpar(0)) coastTargId = nint(tar) coastX = curpar(7) coastY = curpar(8) #if __CURVED__ coastZ = curpar(14) #else coastX = coastX - XOFF(NOBSLV) coastY = coastY - YOFF(NOBSLV) coastZ = curpar(5) #endif coastT = curpar(6) coastE = pama(coastProjId)*curpar(1) coastCX = sigair coastEl = elasti call interaction(coastX) #endif IF ( FIRSTI ) THEN TARG1I = TAR SIG1I = SIGAIR ELAST = ELASTI C RANDOM GENERATOR STATUS (SEQUENCE L=1) AT END OF EVENT LL = 1 CALL RMMAQD( ISEED(1,LL),LL,'R' ) C SEED ISEED1I(1) = ISEED(1,LL) C NUMBER OF CALLS ISEED1I(2) = ISEED(2,LL) C NUMBER OF BILLIONS ISEED1I(3) = ISEED(3,LL) FIRSTI = .FALSE. ENDIF RETURN END #endif #if __EPOS__ || __NEXUS__ || __CONEX__ *-- Author : D. HECK IK FZK KARLSRUHE 18/03/2003 C======================================================================= FUNCTION RANGEN() C----------------------------------------------------------------------- C RAN(DOM NUMBER) GEN(ERATOR) C C SEE SUBROUT. RMMARD C WE USE HERE A SIMPLIFIED FORM OF RMMARD WITH JSEQ=1, LENV=1. C THIS FUNCTION IS CALLED FROM MANY EPOS/NEXUS ROUTINES. C----------------------------------------------------------------------- IMPLICIT NONE #define __RANMA3INC__ #define __RANMA4INC__ #if __CONEX__ #define __CONEXINC__ #endif #include "corsika.h" #if __CONEX__ #include "conex.h" #endif REAL RANGEN SAVE C----------------------------------------------------------------------- JSEQ = 1 #if __CONEX__ IF ( FINCNX ) JSEQ = lseq #endif 1 CONTINUE 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 RANGEN = SNGL( UNI ) NTOT(JSEQ) = NTOT(JSEQ) + 1 IF ( NTOT(JSEQ) .GE. MODCNS ) THEN NTOT2(JSEQ) = NTOT2(JSEQ) + 1 NTOT(JSEQ) = NTOT(JSEQ) - MODCNS ENDIF C AN EXACT ZERO HERE IS VERY UNLIKELY, BUT LET''S BE SAFE AND C TAKE A NEW RANDOM NUMBER IF ( RANGEN .EQ. 0. ) THEN GO TO 1 ELSEIF ( RANGEN .EQ. 1. ) THEN GO TO 1 ENDIF RETURN END *-- Author : T. PIEROG IK FZK KARLSRUHE 24/11/2005 C======================================================================= DOUBLE PRECISION FUNCTION G900GT() C----------------------------------------------------------------------- C GET SEED FROM RANDOM NUMBER GENERATOR C C THIS FUNCTION IS CALLED FROM RANFGT IN EPOS/NEXUS ROUTINES. C----------------------------------------------------------------------- IMPLICIT NONE #define __RANMA3INC__ #define __RANMA4INC__ #if __CONEX__ #define __CONEXINC__ #endif #include "corsika.h" #if __CONEX__ #include "conex.h" common/cxransto/ diu0(100),iiseed(3,2) double precision diu0 integer iiseed,i #endif SAVE C----------------------------------------------------------------------- JSEQ = 1 #if __CONEX__ IF ( FINCNX ) JSEQ = lseq IISEED(1,1) = IJKL(JSEQ) IISEED(2,1) = NTOT(JSEQ) IISEED(3,1) = NTOT2(JSEQ) DIU0(1) = C(JSEQ) DO I = 2,98 DIU0(I) = U(I-1,JSEQ) ENDDO DIU0(99) = DBLE(I97(JSEQ)) DIU0(100) = DBLE(J97(JSEQ)) #endif UNI = NTOT(JSEQ) + 1.D9*NTOT2(JSEQ) G900GT = UNI RETURN END *-- Author : T. PIEROG IK FZK KARLSRUHE 24/11/2005 C======================================================================= DOUBLE PRECISION FUNCTION G900ST(DSEED) C----------------------------------------------------------------------- C STORE SEED FROM RANDOM NUMBER GENERATOR (DUMMY FUNCTION IN CORSIKA) C C THIS FUNCTION IS CALLED FROM RANFST IN EPOS/NEXUS ROUTINES. C----------------------------------------------------------------------- IMPLICIT NONE #define __RANMA3INC__ #define __RANMA4INC__ #if __CONEX__ #define __CONEXINC__ #endif #include "corsika.h" #if __CONEX__ #include "conex.h" common/cxransto/ diu0(100),iiseed(3,2) double precision diu0 integer iiseed,i #endif DOUBLE PRECISION DSEED SAVE C----------------------------------------------------------------------- JSEQ = 1 #if __CONEX__ IF ( FINCNX ) JSEQ = lseq IJKL(JSEQ) = IISEED(1,1) NTOT(JSEQ) = IISEED(2,1) NTOT2(JSEQ) = IISEED(3,1) C(JSEQ) = DIU0(1) DO I = 2,98 U(I-1,JSEQ) = DIU0(I) ENDDO I97(JSEQ) = NINT(DIU0(99)) J97(JSEQ) = NINT(DIU0(100)) #endif UNI = DSEED G900ST = UNI RETURN END #if __EPOS__ || __CONEX__ *-- Author : T. PIEROG IK FZK KARLSRUHE 24/11/2005 C======================================================================= SUBROUTINE RANFGT(SEED) C----------------------------------------------------------------------- DOUBLE PRECISION SEED,G900GT,G900ST,DUMMY C----------------------------------------------------------------------- SEED = G900GT() RETURN C======================================================================= ENTRY RANFST(SEED) DUMMY = G900ST(SEED) RETURN END *-- Author : D. HECK IK FZK KARLSRUHE 18/03/2003 C======================================================================= DOUBLE PRECISION FUNCTION DRANGEN(DUMMY) C----------------------------------------------------------------------- C D(OUBLE PRECISION) RAN(DOM NUMBER) GEN(ERATOR) C C SEE SUBROUT. RMMARD C WE USE HERE A SIMPLIFIED FORM OF RMMARD WITH JSEQ=1, LENV=1. C THIS FUNCTION IS CALLED FROM MANY EPOS ROUTINES. C----------------------------------------------------------------------- IMPLICIT NONE #define __RANMA3INC__ #define __RANMA4INC__ #if __CONEX__ #define __CONEXINC__ #endif #include "corsika.h" #if __CONEX__ #include "conex.h" #endif DOUBLE PRECISION DUMMY SAVE C----------------------------------------------------------------------- JSEQ = 1 #if __CONEX__ IF ( FINCNX ) JSEQ = lseq #endif 1 CONTINUE 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 DRANGEN = UNI NTOT(JSEQ) = NTOT(JSEQ) + 1 IF ( NTOT(JSEQ) .GE. MODCNS ) THEN NTOT2(JSEQ) = NTOT2(JSEQ) + 1 NTOT(JSEQ) = NTOT(JSEQ) - MODCNS ENDIF RETURN END #if __CONEX__ *-- Author : D. HECK IK FZK KARLSRUHE 18/03/2003 C======================================================================= DOUBLE PRECISION FUNCTION DRANEGS(DUMMY) C----------------------------------------------------------------------- C D(OUBLE PRECISION) RAN(DOM NUMBER) GEN(ERATOR) FOR EGS4 IN CONEX C C SEE SUBROUT. RMMARD C WE USE HERE A SIMPLIFIED FORM OF RMMARD WITH JSEQ=1, LENV=1. C THIS FUNCTION IS CALLED FROM MANY EPOS ROUTINES. C----------------------------------------------------------------------- IMPLICIT NONE #define __RANMA3INC__ #define __RANMA4INC__ #define __CONEXINC__ #include "corsika.h" #if __CONEX__ #include "conex.h" #endif DOUBLE PRECISION DUMMY SAVE C----------------------------------------------------------------------- JSEQ = lseq !USE SAME AS CONEX HAD TO REPRODUCE SHOWER WITH CONEX 1 CONTINUE 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 DRANEGS = UNI NTOT(JSEQ) = NTOT(JSEQ) + 1 IF ( NTOT(JSEQ) .GE. MODCNS ) THEN NTOT2(JSEQ) = NTOT2(JSEQ) + 1 NTOT(JSEQ) = NTOT(JSEQ) - MODCNS ENDIF RETURN END #endif *-- Author : T.PIEROG IK FZK KARLSRUHE 14/12/2007 C======================================================================= SUBROUTINE RANFCV(SEED) C----------------------------------------------------------------------- c Dummy function in CORSIKA c Convert input seed to EPOS random number seed c Since input seed and EPOS (from Corsika) seed are different, c define input seed as : seed=ISEED(3)*1E9+ISEED(2) c----------------------------------------------------------------------- IMPLICIT NONE DOUBLE PRECISION SEED,DUMMY DUMMY = SEED RETURN END *-- Author : T.PIEROG IK FZK KARLSRUHE 14/12/2007 C======================================================================= SUBROUTINE RANFINI(SEED,ISEQ,IQQ) c----------------------------------------------------------------------- c Dummy function in CORSIKA c Initialize random number sequence iseq with seed c if iqq=-1, run first ini c iqq=0 , set what sequence should be used c iqq=1 , initialize sequence for initialization c iqq=2 , initialize sequence for first event c----------------------------------------------------------------------- IMPLICIT NONE DOUBLE PRECISION SEED,DUMMY INTEGER ISEQ,IQQ,IDUM DUMMY = SEED IDUM = IQQ IDUM = ISEQ RETURN END #if __EPOS__ && !__URQMD__ *-- Author : T.PIEROG IK FZK KARLSRUHE 14/12/2007 C======================================================================= SUBROUTINE URQMD(idum) c----------------------------------------------------------------------- c Dummy function for compilation of EPOS if URQMD is not selected c Initialize random number sequence iseq with seed c----------------------------------------------------------------------- IMPLICIT NONE integer idum0,idum idum0=idum return end #endif #endif #endif #if (__CHARM__ || __TAULEP__) && !__DPMJET__ *-- Author : D. HECK IK FZK KARLSRUHE 18/03/2003 C======================================================================= DOUBLE PRECISION FUNCTION PYR(IDUMMY) C----------------------------------------------------------------------- C PY(THIA) R(ANDOM GENERATOR) C C SEE SUBROUT. RMMARD C WE USE HERE A SIMPLIFIED FORM OF RMMARD WITH JSEQ=1, LENV=1. C THIS FUNCTION IS CALLED FROM PYTHIA ROUTINES. C ARGUMENT: C IDUMMY = DUMMY ARGUMENT C----------------------------------------------------------------------- IMPLICIT NONE #define __RANMA3INC__ #define __RANMA4INC__ #include "corsika.h" INTEGER IDUMMY SAVE C----------------------------------------------------------------------- UNI = U(I97(1),1) - U(J97(1),1) IF ( UNI .LT. 0.D0 ) UNI = UNI + 1.D0 U(I97(1),1) = UNI I97(1) = I97(1) - 1 IF ( I97(1) .EQ. 0 ) I97(1) = 97 J97(1) = J97(1) - 1 IF ( J97(1) .EQ. 0 ) J97(1) = 97 C(1) = C(1) - CD IF ( C(1) .LT. 0.D0 ) C(1) = C(1) + CM UNI = UNI - C(1) 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 PYR = UNI NTOT(1) = NTOT(1) + 1 IF ( NTOT(1) .GE. MODCNS ) THEN NTOT2(1) = NTOT2(1) + 1 NTOT(1) = NTOT(1) - MODCNS ENDIF RETURN END *-- Author : D. HECK IK FZK KARLSRUHE 18/03/2003 C======================================================================= SUBROUTINE PYRGET(KDUMMY,LDUMMY) C----------------------------------------------------------------------- C DUMMY SUBROUTINE C----------------------------------------------------------------------- INTEGER KDUMMY,LDUMMY RETURN END *-- Author : D. HECK IK FZK KARLSRUHE 18/03/2003 C======================================================================= SUBROUTINE PYRSET(KDUMMY,LDUMMY) C----------------------------------------------------------------------- C DUMMY SUBROUTINE C----------------------------------------------------------------------- INTEGER KDUMMY,LDUMMY RETURN END #endif #if __CHARM__ || __TAULEP__ *-- Author : D. HECK IK FZK KARLSRUHE 19/02/2007 C======================================================================= BLOCK DATA PYTDAT C----------------------------------------------------------------------- C PYT(HIA) DAT(A INITIALIZATION) C C INITIALIZES DATA FOR PYTHIA LINK C----------------------------------------------------------------------- IMPLICIT NONE #define __PYTLININC__ #include "corsika.h" C CONVERTS CORSIKA PARTICLE CODE TO PYTHIA(PDG) PARTICLE CODE DATA IPTABL/ * 22, -11, 11, 0, -13, 13, 111, 211, -211, 130, ! 10 * 321, -321, 2112, 2212,-2212, 310, 221, 3122, 3222, 3212, ! 20 * 3112, 3322, 3312, 3334,-2112,-3122,-3222,-3212,-3112,-3322, ! 30 *-3312,-3334, 0, 0, 0, 0, 0, 0, 0, 0, ! 40 * 0, 0, 0, 0, 0, 0, 0, 331, 333, 223, ! 50 * 113, 213, -213, 2224, 2214, 2114, 1114,-2224,-2214,-2114, ! 60 *-1114, 313, 323, -323, -313, 12, -12, 14, -14, 0, ! 70 * 221, 221, 221, 221, 0, 0, 0, 0, 0, 0, ! 80 * 30*0 , !110 * 0, 0, 0, 0, 0, 421, 411, -411, -421, 431, !120 * -431, 441, 423, 413, -413, -423, 433, -433, 0, 443, !130 * -15, 15, 16, -16, 14, -14, 4122, 4232, 4132, 4222, !140 * 4212, 4112, 4322, 4312, 4332, 0, 0, 0,-4122,-4232, !150 *-4132,-4222,-4212,-4112,-4322,-4312,-4332, 0, 0, 0, !160 * 4224, 4214, 4114, 0, 0, 0, 0, 0, 0, 0, !170 *-4224,-4214,-4114, 0, 0, 511, 521, -521, -511, 531, !180 * -531, 541, -541, 5122, 5112, 5222, 5232, 5132, 5332,-5122, !190 *-5112,-5222,-5232,-5132,-5332, 0, 0, 0, 0, 0/ !200 END #endif #if __CHARM__ *-- Author : D. HECK IK FZK KARLSRUHE 03/08/2012 C======================================================================= SUBROUTINE PYTDCSET C----------------------------------------------------------------------- C PYT(HIA) D(E)C(AY) SET C C PYTDCSET DECLARES CHARMED (AND BOTTOM) PARTICLES STABLE C THIS SUBROUTINE IS CALLED FROM HEPARIN, NUCINT, AND PYTINI. C----------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION(A-H, O-Z) #define __PYTLININC__ #define __RUNPARINC__ #include "corsika.h" C...Pythia parameters. COMMON/PYDAT1/ MSTU(200),PARU(200),MSTJ(200),PARJ(200) C...Pythia decay information. COMMON/PYDAT3/ MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) INTEGER IDXSTA(60),KC,PYCOMP SAVE EXTERNAL PYCOMP C KEEP ALL CHARMED AND BOTTOM PARTICLES STABLE IF THEIR LIFETIME IS C LONGER THAN 10**-20 SEC DATA IDXSTA / C K0s pi0 lam alam sig+ asig+ sig- asig- Xi0 aXi0 & 310, 111, 3122, -3122, 3222,-3222, 3112,-3112, 3322, -3322, !10 C Xi- aXi- om- aom- D+ D- D0 aD0 Ds+ aDs+ & 3312,-3312, 3334, -3334, 411, -411, 421, -421, 431, -431, !20 C etac lamc+ alamc+ sigc++ sigc+sigc0 asigc++asigc+asigc0 Xic+ & 441, 4122,-4122, 4222, 4212, 4112, -4222,-4212,-4112, 4232, !30 C Xic0 aXic+ aXic0 sig0 asig0 & 4132,-4232,-4132, 3212,-3212, 5*0 , !40 C B+ B0 aB0 B- Bs+ aBs- Bc+ aBc- Lamb0 Xib0 & 521, 511, -511, -521, 531, -531, 541, -541, 5122, 5232, !50 C Xib- Omb- aLamb0 aXib0 aXib+ aOmb+ & 5132, 5332,-5122, -5232,-5132,-5332, 4*0 / !60 C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'PYTDCSET:' IF ( DEBUG ) THEN C WRITE TITLE PAGE MSTU(12) = 0 ELSE C SUPPRESS TITLE PAGE MSTU(12) = 12345 ! suppress pythia logo ENDIF C INITIALIZE PYTHIA ROUTINES FOR CHARMED PARTICLE DECAYS C BY CALL OF PYTHIA ROUTINE PYINIT CALL PYINIT( 'NONE', 'DUMMY', 'DUMMY', 'DUMMY' ) C INITIALIZE PYTHIA ROUTINES FOR CHARMED PARTICLE DECAYS IF ( IFLGPYE .GT. 0 ) THEN C ENABLE PRINTING OF PYTHIA ERRORS MSTU(22) = IFLGPYE ELSE C SUPPRESS PYTHIA ERRORS after ten messages MSTU(22) = 10 ENDIF IF ( IFLGPYW .GT. 0 ) THEN C ENABLE PRINTING OF PYTHIA WARNINGS MSTU(25) = 1 MSTU(26) = IFLGPYW ELSE C SUPPRESS PYTHIA WARNINGS MSTU(25) = 0 MSTU(26) = 0 ENDIF C INITIALIZE PYCOMP FUNCTION MSTU(20) = 0 C SET PARTICLES WHICH SHOULD NOT DECAY IN THE JETSET-COMMON C PREVENT CHARMED AND BOTTOM PARTICLES FROM DECAY AT VERTEX C AS THESE DECAYS ARE HANDLED IN CORSIKA SUBR. CHRMDC C C KEEP ALL CHARMED PARTICLES STABLE IF THEIR LIFETIME IS C LONGER THAN 10**-20 SEC DO I = 15,35 KC = PYCOMP(IDXSTA(I)) MDCY(KC,1) = 0 ! PREVENT CHARMED PARTICLE FROM DECAY ENDDO #if !__SIBYLL__ C KEEP ALL BOTTOM PARTICLES STABLE IF THEIR LIFETIME IS C LONGER THAN 10**-20 SEC DO I = 41,56 KC = PYCOMP(IDXSTA(I)) MDCY(KC,1) = 0 ! PREVENT BOTTOM PARTICLE FROM DECAY ENDDO #endif IF ( DEBUG ) WRITE(MDEBUG,*) 'PYTDCSET-END' RETURN END #endif #if __CHARM__ || __TAULEP__ *-- Author : D. HECK IK FZK KARLSRUHE 01/03/2007 C======================================================================= SUBROUTINE PYTINI C----------------------------------------------------------------------- C PYT(HIA) INI(TIALIZATION) C C PYTINI INITIALIZES PYTHIA PACKAGE. C THIS SUBROUTINE IS CALLED FROM START. C----------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION(A-H, O-Z) #define __PYTLININC__ #define __RUNPARINC__ #include "corsika.h" C...Pythia parameters. COMMON/PYDAT1/ MSTU(200),PARU(200),MSTJ(200),PARJ(200) C...Pythia decay information. COMMON/PYDAT3/ MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) INTEGER IDXSTA(40),KC,PYCOMP SAVE EXTERNAL PYCOMP DATA IDXSTA / C K0s pi0 lam alam sig+ asig+ sig- asig- Xi0 aXi0 & 310, 111, 3122,-3122, 3222,-3222, 3112,-3112, 3322,-3322, !10 C Xi- aXi- om- aom- D+ D- D0 aD0 Ds+ aDs+ & 3312,-3312, 3334,-3334, 411, -411, 421, -421, 431, -431, !20 C etac lamc+ alamc+ sigc++ sigc+ sigc0asigc++asigc+asigc0 Xic+ & 441, 4122, -4122, 4222, 4212, 4112, -4222,-4212,-4112, 4232, !30 C Xic0 aXic+ aXic0 sig0 asig0 & 4132, -4232, -4132, 3212,-3212, 5*0 / !40 C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'PYTINI:' IF ( DEBUG ) THEN C WRITE TITLE PAGE MSTU(12) = 0 ELSE C SUPPRESS TITLE PAGE MSTU(12) = 12345 ! suppress pythia logo ENDIF C INITIALIZE PYTHIA ROUTINES FOR CHARMED PARTICLE DECAYS C BY CALL OF PYTHIA ROUTINE PYINIT CALL PYINIT( 'NONE', 'DUMMY', 'DUMMY', 'DUMMY' ) C INITIALIZE PYTHIA ROUTINES FOR CHARMED PARTICLE DECAYS IF ( IFLGPYE .GT. 0 ) THEN C ENABLE PRINTING OF PYTHIA ERRORS MSTU(22) = IFLGPYE ELSE C SUPPRESS PYTHIA ERRORS MSTU(22) = 10 ! suppress pythia error messages after 10 messages ENDIF IF ( IFLGPYW .GT. 0 ) THEN C ENABLE PRINTING OF PYTHIA WARNINGS MSTU(25) = 1 MSTU(26) = IFLGPYW ELSE C SUPPRESS PYTHIA WARNINGS MSTU(25) = 0 MSTU(26) = 0 ENDIF C INITIALIZE PYCOMP FUNCTION MSTU(20) = 0 C DISABLE DECAY OF ALL UNSTABLE PARTICLES TO BE TREATED IN BOX2 C PIO KC = PYCOMP(111) MDCY(KC,1) = 0 C PI+ KC = PYCOMP(211) MDCY(KC,1) = 0 C PI- KC = PYCOMP(-211) MDCY(KC,1) = 0 C K+ KC = PYCOMP(321) MDCY(KC,1) = 0 C K- KC = PYCOMP(-321) MDCY(KC,1) = 0 C KOL KC = PYCOMP(130) MDCY(KC,1) = 0 C KOS KC = PYCOMP(310) MDCY(KC,1) = 0 C KO KC = PYCOMP(311) MDCY(KC,1) = 0 C A-KO KC = PYCOMP(-311) MDCY(KC,1) = 0 C ETA KC = PYCOMP(221) MDCY(KC,1) = 0 C OMEGA MESON KC = PYCOMP(223) MDCY(KC,1) = 0 C RHO(0) KC = PYCOMP(113) MDCY(KC,1) = 0 C RHO+ KC = PYCOMP(213) MDCY(KC,1) = 0 C RHO- KC = PYCOMP(-213) MDCY(KC,1) = 0 C SET PARTICLES WHICH SHOULD NOT DECAY IN THE JETSET-COMMON C PREVENT STRANGE PARTICLES FROM DECAY IN PYTHIA, C AS THESE DECAYS ARE HANDLED IN CORSIKA SUBR. STRDEC C PREVENT ALSO CHARMED PARTICLES FROM DECAY AT VERTEX C AS THESE DECAYS ARE HANDLED IN CORSIKA SUBR. CHRMDC DO I = 1,35 KC = PYCOMP(IDXSTA(I)) MDCY(KC,1) = 0 ! PREVENT PARTICLE FROM DECAY ENDDO #if __TAULEP__ DO I = 15,33 KC = PYCOMP(IDXSTA(I)) MDCY(KC,1) = 1 ! ENABLE CHARMED PARTICLE DECAY AT VERTEX ENDDO #endif IF ( DEBUG ) WRITE(MDEBUG,*) 'PYTINI END' RETURN END *-- Author : D. HECK IK FZK KARLSRUHE 01/03/2007 C======================================================================= SUBROUTINE PYTSTO C----------------------------------------------------------------------- C PYT(HIA) STO(RE ROUTINE) C C THIS SUBROUTINE TRANSPORTS RESULTING PYTHIA PARTICLES TO THE C CORSIKA STACK. C THIS SUBROUTINE IS CALLED FROM CHRMDC AND HEPARIN. C----------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION(A-H, O-Z) #define __GENERINC__ #define __LONGIINC__ #define __PAMINC__ #define __PARPARINC__ #define __PARPAEINC__ #define __PYTLININC__ #define __RANDPAINC__ #define __RUNPARINC__ #if __AUGERHIST__ #define __OBSPARINC__ #endif #include "corsika.h" C...The Pythia event record. #if __DPMJET__ INTEGER MAXLND,N,NPAD,K PARAMETER (MAXLND=12000) COMMON/PYJETS/ N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5) #else COMMON/PYJETS/ N,NPAD,K(4000,5),P(4000,5),V(4000,5) #endif C...Pythia parameters. COMMON/PYDAT1/ MSTU(200),PARU(200),MSTJ(200),PARJ(200) DOUBLE PRECISION ETOT,PL2,PT2,PTOT,CPHIV,SPHIV DOUBLE PRECISION FAC1,FAC2 INTEGER J,KODCRS,NPTLS,NSKIP #if __AUGERHIST__ DOUBLE PRECISION EDEP,THICKLOC,THICK INTEGER II,LL EXTERNAL THICK #endif #if __EHISTORY__ INTEGER IK #endif SAVE C----------------------------------------------------------------------- IF ( DEBUG ) THEN WRITE(MDEBUG,*) 'PYTSTO:',N,' ENTRIES' WRITE(MDEBUG,1009) 1009 FORMAT(1X,' J STAT ID MOTH DAUTF DAUTL', * 6X,'PX',9X,'PY',9X,'PZ',9X,' E',8X,'M') DO J = 1, N WRITE(6,1010) J,(K(J,LL),LL=1,5),(P(J,MM),MM=1,5) 1010 FORMAT(1X,I3,I5,I8,3I7,1X,4(1P,E11.3),0P,F8.4) ENDDO ENDIF IF ( IFLGPYE .GT. 0 ) THEN C ENABLE PRINTING OF PYTHIA ERRORS MSTU(22) = IFLGPYE ELSE C SUPPRESS PYTHIA ERRORS MSTU(22) = 10 ! suppress pythia error messages after 10 messages ENDIF IF ( IFLGPYW .GT. 0 ) THEN C ENABLE PRINTING OF PYTHIA WARNINGS MSTU(25) = 1 MSTU(26) = IFLGPYW ELSE C SUPPRESS PYTHIA WARNINGS MSTU(25) = 0 MSTU(26) = 0 ENDIF #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME GRANDMOTHER PARTICLE DO IK = 0, 6 SECPAR(28+IK) = CURPAR(IK) ENDDO C STORE GENERATION COUNTER OF MOTHER SECPAR(35) = GEN C STORE MASS PENETRATION BEFORE INTERACTION SECPAR(36) = CURPAR(9) #if __THIN__ SECPAR(37) = CURPAR(13) #endif #endif ETOT = 0.D0 NPTLS = 0 NSKIP = 0 C LOOP OVER ALL SECONDARY PARTICLES DO J = 1, N C SKIP UNSTABLE PARTICLES IF ( K(J,1) .NE. 1 ) GOTO 1001 C SKIP PARTICLES WITHOUT PARENTS IF ( K(J,3) .EQ. 0 ) GOTO 1001 C SKIP UNSTABLE PARTICLES WITH DAUGHTERS IF ( K(J,4) .NE. 0 .OR. K(J,5) .NE. 0 ) GOTO 1001 C SKIP SINGLE QUARKS, GLUONS, GAUGE BOSONS... C BUT KEEP LEPTONS AND GAMMA IF ( ABS(K(J,2)) .LT. 10 .OR. ABS(K(J,2)) .EQ. 21 .OR. * ( ABS(K(J,2)) .GE. 23 .AND. ABS(K(J,2)) .LT. 111 ) ) THEN GOTO 1001 ENDIF C SKIP DIQUARKS (NO QQ SHOULD APPEAR AT THS STAGE) IF ( ABS(K(J,2)) .EQ. 1103 .OR. ABS(K(J,2)) .EQ. 2101 .OR. * ABS(K(J,2)) .EQ. 2103 .OR. ABS(K(J,2)) .EQ. 2203 .OR. * ABS(K(J,2)) .EQ. 3101 .OR. ABS(K(J,2)) .EQ. 3103 .OR. * ABS(K(J,2)) .EQ. 3201 .OR. ABS(K(J,2)) .EQ. 3203 .OR. * ABS(K(J,2)) .EQ. 3303 .OR. ABS(K(J,2)) .EQ. 4101 .OR. * ABS(K(J,2)) .EQ. 4103 .OR. ABS(K(J,2)) .EQ. 4201 .OR. * ABS(K(J,2)) .EQ. 4203 .OR. ABS(K(J,2)) .EQ. 4301 .OR. * ABS(K(J,2)) .EQ. 4303 .OR. ABS(K(J,2)) .EQ. 4403 .OR. * ABS(K(J,2)) .EQ. 5101 .OR. ABS(K(J,2)) .EQ. 5103 .OR. * ABS(K(J,2)) .EQ. 5201 .OR. ABS(K(J,2)) .EQ. 5203 .OR. * ABS(K(J,2)) .EQ. 5301 .OR. ABS(K(J,2)) .EQ. 5303 .OR. * ABS(K(J,2)) .EQ. 5401 .OR. ABS(K(J,2)) .EQ. 5403 .OR. * ABS(K(J,2)) .EQ. 5503 ) GOTO 1001 C CONVERT DATA PARTICLE GROUP CODE TO CORSIKA CODE C MESONS IF ( K(J,2) .EQ. 111 ) THEN C PI(0) KODCRS = 7 ELSEIF ( K(J,2) .EQ. 211 ) THEN C PI+ KODCRS = 8 ELSEIF ( K(J,2) .EQ. -211 ) THEN C PI- KODCRS = 9 ELSEIF ( K(J,2) .EQ. 221 ) THEN C ETA KODCRS = 17 ELSEIF ( K(J,2) .EQ. 223 ) THEN C ETA PRIME AND PHI MESONS DECAY IN SIBYLL C OMEGA MESON KODCRS = 50 ELSEIF ( K(J,2) .EQ. 113 ) THEN C RHO(0) KODCRS = 51 ELSEIF ( K(J,2) .EQ. 213 ) THEN C RHO+ KODCRS = 52 ELSEIF ( K(J,2) .EQ. -213 ) THEN C RHO- KODCRS = 53 C NUCLEONS AND ANTI-NUCLEONS ELSEIF ( K(J,2) .EQ. 2112 ) THEN C N KODCRS = 13 ELSEIF ( K(J,2) .EQ. 2212 ) THEN C P KODCRS = 14 ELSEIF ( K(J,2) .EQ. -2212 ) THEN C ANTI-P KODCRS = 15 ELSEIF ( K(J,2) .EQ. -2112 ) THEN C ANTI-N KODCRS = 25 C STRANGE MESONS ELSEIF ( K(J,2) .EQ. 130 ) THEN C K(0)LONG KODCRS = 10 ELSEIF ( K(J,2) .EQ. 321 ) THEN C K+ KODCRS = 11 ELSEIF ( K(J,2) .EQ. -321 ) THEN C K- KODCRS = 12 ELSEIF ( K(J,2) .EQ. 310 ) THEN C K(0)SHORT KODCRS = 16 ELSEIF ( K(J,2) .EQ. 311 .OR. * K(J,2) .EQ. -311 ) THEN C K(0) GO TO K(0)LONG OR K(0)SHORT CALL RMMARD( RD,1,1 ) IF ( RD(1) .GE. 0.5D0 ) THEN KODCRS = 10 ELSE KODCRS = 16 ENDIF C STRANGE BARYONS ELSEIF ( K(J,2) .EQ. 3122 ) THEN C LAMBDA KODCRS = 18 ELSEIF ( K(J,2) .EQ. 3222 ) THEN C SIGMA+ KODCRS = 19 ELSEIF ( K(J,2) .EQ. 3212 ) THEN C SIGMA(0) KODCRS = 20 ELSEIF ( K(J,2) .EQ. 3112 ) THEN C SIGMA- KODCRS = 21 ELSEIF ( K(J,2) .EQ. 3322 ) THEN C XI(0) KODCRS = 22 ELSEIF ( K(J,2) .EQ. 3312 ) THEN C XI- KODCRS = 23 ELSEIF ( K(J,2) .EQ. 3334 ) THEN C OMEGA- KODCRS = 24 C STRANGE ANTI-BARYONS ELSEIF ( K(J,2) .EQ. -3122 ) THEN C ANTI-LAMBDA KODCRS = 26 ELSEIF ( K(J,2) .EQ. -3222 ) THEN C ANTI-SIGMA- KODCRS = 27 ELSEIF ( K(J,2) .EQ. -3212 ) THEN C ANTI-SIGMA(0) KODCRS = 28 ELSEIF ( K(J,2) .EQ. -3112 ) THEN C ANTI-SIGMA+ KODCRS = 29 ELSEIF ( K(J,2) .EQ. -3322 ) THEN C ANTI-XI(0) KODCRS = 30 ELSEIF ( K(J,2) .EQ. -3312 ) THEN C ANTI-XI+ KODCRS = 31 ELSEIF ( K(J,2) .EQ. -3334 ) THEN C ANTI-OMEGA+ KODCRS = 32 ELSEIF ( K(J,2) .EQ. 22 ) THEN C GAMMA KODCRS = 1 C LEPTONS ELSEIF ( K(J,2) .EQ. -11 ) THEN C E+ KODCRS = 2 ELSEIF ( K(J,2) .EQ. 11 ) THEN C E- KODCRS = 3 ELSEIF ( K(J,2) .EQ. -13 ) THEN C MU+ KODCRS = 5 ELSEIF ( K(J,2) .EQ. 13 ) THEN C MU- KODCRS = 6 ELSEIF ( K(J,2) .EQ. -15 ) THEN C TAU+ KODCRS = 131 ELSEIF ( K(J,2) .EQ. 15 ) THEN C TAU- KODCRS = 132 C CHARMED MESONS ELSEIF ( K(J,2) .EQ. 421 ) THEN C D(0) KODCRS = 116 ELSEIF ( K(J,2) .EQ. -421 ) THEN C D(0)BAR KODCRS = 119 ELSEIF ( K(J,2) .EQ. 411 ) THEN C D(+) KODCRS = 117 ELSEIF ( K(J,2) .EQ. -411 ) THEN C D(-) KODCRS = 118 C CHARMED MESONS WITH STRANGENESS ELSEIF ( K(J,2) .EQ. 431 ) THEN C D_S(+) KODCRS = 120 ELSEIF ( K(J,2) .EQ. -431 ) THEN C D_S(-) KODCRS = 121 C CHARMED ETA MESON ELSEIF ( K(J,2) .EQ. 441 .OR. * K(J,2) .EQ. -441 ) THEN KODCRS = 122 C CHARMED BARYONS ELSEIF ( K(J,2) .EQ. 4122 ) THEN C LAMBDA_C+ KODCRS = 137 ELSEIF ( K(J,2) .EQ. 4222 ) THEN C SIGMA_C++ KODCRS = 140 ELSEIF ( K(J,2) .EQ. 4212 ) THEN C SIGMA_C+ KODCRS = 141 ELSEIF ( K(J,2) .EQ. 4112 ) THEN C SIGMA_C(0) KODCRS = 142 ELSEIF ( K(J,2) .EQ. 4322 ) THEN C XI_C_PRIME+ KODCRS = 143 ELSEIF ( K(J,2) .EQ. 4232 ) THEN C XI_C+ KODCRS = 138 ELSEIF ( K(J,2) .EQ. 4312 ) THEN C XI_C_PRIME(0) KODCRS = 144 ELSEIF ( K(J,2) .EQ. 4132 ) THEN C XI_C(0) KODCRS = 139 ELSEIF ( K(J,2) .EQ. 4332 ) THEN C OMEGA_C(0) KODCRS = 145 ELSEIF ( K(J,2) .EQ. -4122 ) THEN C ANTI-LAMBDA_C- KODCRS = 149 ELSEIF ( K(J,2) .EQ. -4222 ) THEN C ANTI-SIGMA_C-- KODCRS = 152 ELSEIF ( K(J,2) .EQ. -4212 ) THEN C ANTI-SIGMA_C- KODCRS = 153 ELSEIF ( K(J,2) .EQ. -4112 ) THEN C ANTI-SIGMA_C(0) KODCRS = 154 ELSEIF ( K(J,2) .EQ. -4322 ) THEN C ANTI-XI_C_PRIME- KODCRS = 155 ELSEIF ( K(J,2) .EQ. -4232 ) THEN C ANTI-XI_C- KODCRS = 150 ELSEIF ( K(J,2) .EQ. -4312 ) THEN C ANTI-XI_C_PRIME(0) KODCRS = 156 ELSEIF ( K(J,2) .EQ. -4132 ) THEN C ANTI-XI_C(0) KODCRS = 151 ELSEIF ( K(J,2) .EQ. -4332 ) THEN C ANTI-OMEGA_C(0) KODCRS = 157 #if __SIBYLL__ C K* RESONANCES DO NOT DECAY IN SIBYLL ELSEIF ( K(J,2) .EQ. 313 ) THEN C K*(0) KODCRS = 62 ELSEIF ( K(J,2) .EQ. 323 ) THEN C K*+ KODCRS = 63 ELSEIF ( K(J,2) .EQ. -323 ) THEN C K*- KODCRS = 64 ELSEIF ( K(J,2) .EQ. -313 ) THEN C K*(0)BAR KODCRS = 65 C DELTA RESONANCES DO NOT DECAY IN SIBYLL ELSEIF ( K(J,2) .EQ. 2224 ) THEN C DELTA++ KODCRS = 54 ELSEIF ( K(J,2) .EQ. 2214 ) THEN C DELTA+ KODCRS = 55 ELSEIF ( K(J,2) .EQ. 2114 ) THEN C DELTA0 KODCRS = 56 ELSEIF ( K(J,2) .EQ. 1114 ) THEN C DELTA- KODCRS = 57 ELSEIF ( K(J,2) .EQ. -2224 ) THEN C ANTI-DELTA-- KODCRS = 58 ELSEIF ( K(J,2) .EQ. -2214 ) THEN C ANTI-DELTA- KODCRS = 59 ELSEIF ( K(J,2) .EQ. -2114 ) THEN C ANTI-DELTA0 KODCRS = 60 ELSEIF ( K(J,2) .EQ. -1114 ) THEN C ANTI-DELTA+ KODCRS = 61 #endif #if !__SIBYLL__ C BOTTOM MESONS ELSEIF ( K(J,2) .EQ. 511 ) THEN C B(0) KODCRS = 176 ELSEIF ( K(J,2) .EQ. -511 ) THEN C B(0)BAR KODCRS = 179 ELSEIF ( K(J,2) .EQ. 521 ) THEN C B(+) KODCRS = 177 ELSEIF ( K(J,2) .EQ. -521 ) THEN C ANTI-B(-) KODCRS = 178 C BOTTOM MESONS WITH STRANGENESS ELSEIF ( K(J,2) .EQ. 531 ) THEN C B_S(0) KODCRS = 180 ELSEIF ( K(J,2) .EQ. -531 ) THEN C ANTI-B_S(-) KODCRS = 181 C BOTTOM MESONS WITH CHARM ELSEIF ( K(J,2) .EQ. 541 ) THEN C B_C(+) KODCRS = 182 ELSEIF ( K(J,2) .EQ. -541 ) THEN C ANTI-B_C(-) KODCRS = 183 C BOTTOM BARYONS ELSEIF ( K(J,2) .EQ. 5122 ) THEN C LAMBDA_B(0) KODCRS = 184 ELSEIF ( K(J,2) .EQ. 5112 ) THEN C SIGMA_B(-) KODCRS = 185 ELSEIF ( K(J,2) .EQ. 5212 ) THEN C SIGMA_B(0) replaced by LAMBDA_B(0)BAR KODCRS = 184 ELSEIF ( K(J,2) .EQ. 5222 ) THEN C SIGMA_B(+) KODCRS = 186 ELSEIF ( K(J,2) .EQ. 5232 ) THEN C XI_B(0) KODCRS = 187 ELSEIF ( K(J,2) .EQ. 5132 ) THEN C XI_B(-) KODCRS = 188 ELSEIF ( K(J,2) .EQ. 5322 ) THEN C XI_B(0) PRIME KODCRS = 187 ELSEIF ( K(J,2) .EQ. 5312 ) THEN C XI_B(-) PRIME KODCRS = 188 ELSEIF ( K(J,2) .EQ. 5332 ) THEN C OMEGA_B(-) KODCRS = 189 C BOTTOM ANTI-BARYONS ELSEIF ( K(J,2) .EQ. -5122 ) THEN C ANTI-LAMBDA_B(0) KODCRS = 190 ELSEIF ( K(J,2) .EQ. -5112 ) THEN C ANTI-SIGMA_B(+) KODCRS = 191 ELSEIF ( K(J,2) .EQ. -5212 ) THEN C ANTI-SIGMA_B(0)BAR replaced by A-LAMBDA_B(0)BAR KODCRS = 190 ELSEIF ( K(J,2) .EQ. -5222 ) THEN C ANTI-SIGMA_B(-) KODCRS = 192 ELSEIF ( K(J,2) .EQ. -5232 ) THEN C ANTI-XI_B(0) KODCRS = 193 ELSEIF ( K(J,2) .EQ. -5132 ) THEN C ANTI-XI_B(+) KODCRS = 194 ELSEIF ( K(J,2) .EQ. -5322 ) THEN C ANTI-XI_B(0) PRIME KODCRS = 193 ELSEIF ( K(J,2) .EQ. -5312 ) THEN C ANTI-XI_B(+) PRIME KODCRS = 194 ELSEIF ( K(J,2) .EQ. -5332 ) THEN C ANTI-OMEGA_B(+) KODCRS = 195 #endif #if __NEUTRINO__ C NEUTRINOS ELSEIF ( K(J,2) .EQ. 12 ) THEN C NU_E KODCRS = 66 ELSEIF ( K(J,2) .EQ. -12 ) THEN C ANTI-NU_E KODCRS = 67 ELSEIF ( K(J,2) .EQ. 14 ) THEN C NU_MU KODCRS = 68 ELSEIF ( K(J,2) .EQ. -14 ) THEN C ANTI-NU_MU KODCRS = 69 ELSEIF ( K(J,2) .EQ. 16 ) THEN C NU_TAU KODCRS = 133 ELSEIF ( K(J,2) .EQ. -16 ) THEN C ANTI-NU_TAU KODCRS = 134 #else C NEUTRINOS ARE SKIPPED ELSEIF ( K(J,2) .EQ. 12 ) THEN C NU_E GOTO 999 ELSEIF ( K(J,2) .EQ. -12 ) THEN C ANTI-NU_E GOTO 999 ELSEIF ( K(J,2) .EQ. 14 ) THEN C NU_MU GOTO 999 ELSEIF ( K(J,2) .EQ. -14 ) THEN C ANTI-NU_MU GOTO 999 ELSEIF ( K(J,2) .EQ. 16 ) THEN C NU_TAU GOTO 999 ELSEIF ( K(J,2) .EQ. -16 ) THEN C ANTI-NU_TAU GOTO 999 #endif ELSE WRITE(MONIOU,*) 'PYTSTO: UNKNOWN PARTICLE CODE=',K(J,2) C * ,' GOTO 1001' C GOTO 1001 STOP ENDIF IF ( KODCRS .LE. 0 .OR. KODCRS .GT. 195 ) GOTO 1001 NPTLS = NPTLS + 1 SECPAR(0) = KODCRS IF ( PAMA(KODCRS) .GT. 0.D0 ) THEN C ORDINARY SECONDARY PARTICLES (WITHOUT GAMMAS AND NEUTRINOS) SECPAR(1) = P(J,4)/PAMA(KODCRS) ELSE SECPAR(1) = P(J,4) ENDIF C DETERMINE ANGLES FROM LONGITUDINAL AND TRANSVERSAL MOMENTA 7 CONTINUE PT2 = P(J,1)**2 + P(J,2)**2 PL2 = P(J,3)**2 IF ( PL2+PT2 .GT. 0.D0 ) THEN PTOT = SQRT( PL2 + PT2 ) COSTET = MAX( MIN( P(J,3)/PTOT, 1.D0 ), -1.D0 ) CPHIV = MAX( MIN( P(J,1)/PTOT, 1.D0 ), -1.D0 ) SPHIV = MAX( MIN( P(J,2)/PTOT, 1.D0 ), -1.D0 ) ELSE PTOT = 0.D0 COSTET = 0.D0 CPHIV = 1.D0 SPHIV = 0.D0 ENDIF #if __INTTEST__ C IF ( COSTET .EQ. 0.D0 ) COSTET = 1.D-4 SECPAR(17) = SQRT( PT2 ) #endif CALL ADDANG4( COSTHE,PHIX,PHIY, COSTET,CPHIV,SPHIV, * SECPAR(2),SECPAR(3),SECPAR(4) ) #if __UPWARD__ IF ( SECPAR(2) .GE. -1.D0 ) THEN #else IF ( SECPAR(2) .GT. C(29) ) THEN #endif C IF WE HAVE HERE A MUON OR A NEUTRINO IT MUST COME FROM CHARM DECAY C INCREMENT GENERATION COUNTER BY 30 FOR MU(+-) AND NU FROM CHARM DECAY IF ( KODCRS .EQ. 5 .OR. KODCRS .EQ. 6 ) THEN SECPAR(9) = GEN + 30.D0 ELSEIF ( KODCRS .GE. 66 .AND. KODCRS .LE. 69 ) THEN SECPAR(9) = GEN + 30.D0 ELSE SECPAR(9) = GEN ENDIF CALL TSTACK ELSE IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT IF ( KODCRS .LE. 3 ) THEN #if __THIN__ DLONG(LHEIGH,13) = DLONG(LHEIGH,13) * + (P(J,4) - RESTMS(KODCRS))* WEIGHT ELSEIF ( KODCRS .EQ. 5 .OR. KODCRS .EQ. 6 ) THEN DLONG(LHEIGH,15) = DLONG(LHEIGH,15) + P(J,4) * WEIGHT #if __NEUTRINO__ ELSEIF ( ( KODCRS .GE. 66 .AND. KODCRS .LE. 69 ) #if __CHARM__ || __TAULEP__ * .OR. KODCRS .EQ. 133 .OR. KODCRS .EQ. 134 #endif * ) THEN DLONG(LHEIGH,18) = DLONG(LHEIGH,18) + P(J,4) * WEIGHT #endif ELSEIF ( KODCRS .GE. 7 ) THEN IF ( KODCRS .EQ. 8 .OR. KODCRS .EQ. 9 .OR. * KODCRS .EQ. 11 .OR. KODCRS .EQ. 12 ) THEN FAC1 = 0.25D0 FAC2 = 0.75D0 ELSEIF ( KODCRS .EQ. 10 .OR. KODCRS .EQ. 16 ) THEN FAC1 = 0.5D0 FAC2 = 0.5D0 ELSE FAC1 = 1.D0 FAC2 = 0.D0 ENDIF C ADD TO THE HADRON ENERGY DEPOSIT DLONG(LHEIGH,17) = DLONG(LHEIGH,17) * + (P(J,4) - RESTMS(KODCRS))* WEIGHT*FAC1 C ADD TO THE NEUTRINO DEPOSIT DLONG(LHEIGH,18) = DLONG(LHEIGH,18) * + (P(J,4) - RESTMS(KODCRS))* WEIGHT*FAC2 #else DLONG(LHEIGH,13) = DLONG(LHEIGH,13) + P(J,4) * - RESTMS(KODCRS) ELSEIF ( KODCRS .EQ. 5 .OR. KODCRS .EQ. 6 ) THEN DLONG(LHEIGH,15) = DLONG(LHEIGH,15) + P(J,4) #if __NEUTRINO__ ELSEIF ( ( KODCRS .GE. 66 .AND. KODCRS .LE. 69 ) #if __CHARM__ || __TAULEP__ * .OR. KODCRS .EQ. 133 .OR. KODCRS .EQ. 134 #endif * ) THEN DLONG(LHEIGH,18) = DLONG(LHEIGH,18) + P(J,4) #endif ELSEIF ( KODCRS .GE. 7 ) THEN IF ( KODCRS .EQ. 8 .OR. KODCRS .EQ. 9 .OR. * KODCRS .EQ. 11 .OR. KODCRS .EQ. 12 ) THEN FAC1 = 0.25D0 FAC2 = 0.75D0 ELSEIF ( KODCRS .EQ. 10 .OR. KODCRS .EQ. 16 ) THEN FAC1 = 0.5D0 FAC2 = 0.5D0 ELSE FAC1 = 1.D0 FAC2 = 0.D0 ENDIF C ADD TO THE HADRON ENERGY DEPOSIT DLONG(LHEIGH,17) = DLONG(LHEIGH,17) * + (P(J,4) - RESTMS(KODCRS))*FAC1 C ADD TO THE NEUTRINO DEPOSIT DLONG(LHEIGH,18) = DLONG(LHEIGH,18) * + (P(J,4) - RESTMS(KODCRS))*FAC2 #endif ENDIF ENDIF #if __AUGERHIST__ THICKLOC = THICK( H ) DO LL = 1, NOBSLV IF ( THICKLOC .GE. THCKOB(LL) .AND. * THICKLOC .LT. THCKOB(LL)+SAMPTH ) THEN C THICKH IS WITHIN 1 G/CM^2 BELOW OBSLEV(LL) C BRING THE ENERGY BELOW ANGULAR CUT TO THE HISTO OF LEVEL LL OUTPAR(0) = KODCRS IF ( KODCRS .EQ. 1 ) THEN OUTPAR(1) = P(J,4) EDEP = OUTPAR(1) * WEIGHT ELSEIF ( KODCRS .EQ. 2 .OR. KODCRS .EQ. 3 ) THEN OUTPAR(1) = P(J,4) EDEP = ( OUTPAR(1) - RESTMS(KODCRS) ) * WEIGHT ELSE OUTPAR(1) = P(J,4) / PAMA(KODCRS) EDEP = ( P(J,4) - RESTMS(KODCRS) ) * WEIGHT ENDIF DO II = 2, 8 OUTPAR(II) = SECPAR(II) ENDDO OUTPAR( 9) = GEN OUTPAR(10) = ALEVEL OUTPAR(13) = WEIGHT C WE HAVE ANGULAR CUT CALL AUGERDEPFIL( EDEP,LL,1 ) ELSEIF ( THICKLOC .LT. THCKOB(LL) ) THEN GOTO 111 ENDIF ENDDO 111 CONTINUE #endif ENDIF GOTO 1000 999 IF ( LLONGI ) THEN C ADD NEUTRINO ENERGY TO LONGITUDINAL ENERGY DEPOSIT #if __THIN__ DLONG(LHEIGH,8) = DLONG(LHEIGH,8) + P(J,4) * WEIGHT #else DLONG(LHEIGH,8) = DLONG(LHEIGH,8) + P(J,4) #endif ENDIF NSKIP = NSKIP + 1 1000 ETOT = ETOT + P(J,4) 1001 CONTINUE ENDDO IF ( DEBUG ) THEN WRITE(MDEBUG,*) 'PYTSTO:',NPTLS,' SECONDARY AND',NSKIP, * ' SKIPPED PARTICLES WITH ETOT=',ETOT ENDIF RETURN END #endif #if __QGSJET__ *-- Author : D. HECK IK FZK KARLSRUHE 12/01/1996 C======================================================================= #if __QGSII__ DOUBLE PRECISION FUNCTION QGRAN(B10) #else DOUBLE PRECISION FUNCTION PSRAN(B10) #endif C----------------------------------------------------------------------- C RAN(DOM GENERATOR FOR QGSJET) C C SEE SUBROUT. RMMARD C WE USE HERE A SIMPLIFIED FORM OF RMMARD WITH JSEQ=1, LENV=1. C THIS FUNCTON IS CALLED FROM QGSJET01C AND QGSJET_II ROUTINES. C ARGUMENT: C B10 = DUMMY ARGUMENT C----------------------------------------------------------------------- IMPLICIT NONE #define __RANMA3INC__ #define __RANMA4INC__ #if __CONEX__ #define __CONEXINC__ #endif #include "corsika.h" #if __CONEX__ #include "conex.h" #endif DOUBLE PRECISION B10 SAVE C----------------------------------------------------------------------- JSEQ = 1 #if __CONEX__ IF ( FINCNX ) JSEQ = lseq #endif 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 #if __QGSII__ QGRAN = UNI #else PSRAN = UNI #endif NTOT(JSEQ) = NTOT(JSEQ) + 1 IF ( NTOT(JSEQ) .GE. MODCNS ) THEN NTOT2(JSEQ) = NTOT2(JSEQ) + 1 NTOT(JSEQ) = NTOT(JSEQ) - MODCNS ENDIF RETURN END *-- Author : D. HECK IK FZK KARLSRUHE 12/01/1996 C======================================================================= BLOCK DATA QGSDAT C----------------------------------------------------------------------- C Q(UARK) G(LUON) S(TRING JET MODEL) DAT(A INITIALIZATION) C C INITIALIZES DATA FOR QGSJET LINK. C----------------------------------------------------------------------- IMPLICIT NONE #define __QGSLININC__ #include "corsika.h" C FOLLOWING NOTATIONS FOR PARTICLES TYPES ARE USED WITHIN QGSJET: C 0 - PI0, C 1 - PI+, C -1 - PI-, C 2 - P, C -2 - P-BAR, C 3 - N, C -3 - N-BAR, C 4 - K+, C -4 - K-, C 5 - K0S, C -5 - K0L C 6 - LAMBDA C -6 - LAMBDA-BAR C 7 - D+ C -7 - D- C 8 - D0 C -8 - D0-BAR C 9 - LAMBDA_C C -9 - LAMBDA_C-BAR C 10 - ETA C -10 - RHO0 C ICTABL CONVERTS CORSIKA PARTICLES INTO QGSJET PARTICLES C NO CHARMED PARTICLES POSSIBLE AS PROJECTILES DATA ICTABL/ * 0, 0, 0, 0, 0, 0, 1, 1, -1, -5, ! 10 * 4, -4, 3, 2, -2, 5, 10, 6, 0, 0, ! 20 * 0, 0, 0, 0, -3, -6, 0, 0, 0, 0, ! 30 * 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, ! 40 * 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, ! 50 * 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, ! 60 * 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, ! 70 * 10, 10, 10, 10, 26*0, C CHARMED MESONS C CONVERT UNKNOWN CHARMED MESONS TO KNOWN D-MESONS * 10*0, !110 * 0, 0, 0, 0, 0, 8, 7, -7, -8, 7, !120 * -7, 0, 8, 7, -7, -8, 7, -7, 0, 0, !130 C CHARMED BARYONS * 0, 0, 0, 0, 0, 0, 9, 0, 0, 0 , !140 * 0, 0, 0, 0, 0, 0, 0, 0, -9, 0 , !150 * 50*0 / C IQTABL CONVERTS QGSJET PARTICLES INTO CORSIKA PARTICLES C INCLUDES CHARMED PARTICLES C IQTABL RUNS FROM -10:10 DATA IQTABL/ * 51, 149, 119, 118, 26, 10, 12, 25, 15, 9, ! -10 .... -1 * 7, ! 0 * 8, 14, 13, 11, 16, 18, 117, 116, 137, 17/ ! 1 .... 10 END *-- Author : D. HECK IK FZK KARLSRUHE 12/01/1996 C======================================================================= SUBROUTINE QGSINI( MODE ) C----------------------------------------------------------------------- C Q(UARK) G(LUON) S(TRING JET MODEL) INI(TIALZATION) C C INITIALIZES QGSJET MODEL. C THIS SUBROUTINE IS CALLED FROM START. C ARGUMENT: C MODE = 1 : QGSJET INTERACTION MODEL IS INITIALIZED C MODE = 2 : QGSJET CROSS-SECTIONS ARE INITIALIZED C MODE = 3 : QGSJET INTERACT MODEL & CROSS-SECTIONS ARE INITIALIZED C----------------------------------------------------------------------- IMPLICIT NONE #define __DPMFLGINC__ #define __QGSCINC__ #define __RUNPARINC__ #if __INTTEST__ #define __TSTINTINC__ #endif #include "corsika.h" #if __QGSII__ COMMON /QGARR43/ MONIOQ INTEGER MONIOQ #else COMMON /AREA15/ FP(5),RQ(5),CD(5) DOUBLE PRECISION FP,RQ,CD COMMON /AREA17/ DEL,RS,RS0,FS,ALFP,RR,SH,DELH DOUBLE PRECISION DEL,RS,RS0,FS,ALFP,RR,SH,DELH COMMON /AREA20/ WPPP DOUBLEPRECISION WPPP COMMON /AREA40/ JDIFR INTEGER JDIFR COMMON /AREA43/ MONIOQ INTEGER MONIOQ #if __CHARM__ COMMON /AREA8/ WWM,BE(4),DC(5),DETA,ALMPT DOUBLE PRECISION WWM,BE,DC,DETA,ALMPT #endif #endif COMMON /DEBUG/ DEBUGQ INTEGER DEBUGQ COMMON /VERSION/ VERSION DOUBLE PRECISION VERSION INTEGER MODE SAVE C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'QGSINI:',MODE IF ( DEBUG ) THEN DEBUGQ = LEVLDQ ELSE DEBUGQ = 0 ENDIF MONIOQ = MONIOU C COMMON MODEL PARAMETERS SETTING #if __QGSII__ CALL QGSET #else C TO DISTINGISH QGSJET01C FROM QGSJET01 WE USE DIFFERENT NAMES FOR PSASET CALL PSASETC C RR = 0.35D0 ! TO ADJUST SIGMA PP TO 76 MBARN AT TEVATRON/CDF C IS SET BY DEFAULT IN XXASET C OTHERWISE RR = 0.53 TO ADJUST SIGMA=80MBARN C PARTICULAR MODEL PARAMETERS SETTING CALL XXASET #if __CHARM__ DC(3) = .0003D0 ! To switch off charmed particles set to 0.000 DC(5) = .01D0 ! To switch off charmed particles set to 0.000 #endif C SET DIFFRACTION FLAG BY DEFAULT JDIFR = 1 #endif #if __INTTEST__ IF ( NDIF .EQ. 0 ) THEN C ALL EVENTS MIXED WRITE(MONIOU,*) * 'QGSINI: NDIF = 0 DIFFRACTIVE AND NON-DIFFRACTIVE EVENTS MIXED' #if !__QGSII__ C WPPP=0.4 IS ALREADY SET BY DEFAULT IN XXASET !24.2.2000 WRITE(MONIOU,*) ' HIGH MASS DIFFR. PROBABILITY =',WPPP WRITE(MONIOU,*) ' LOW MASS DIFFR. TREATMENT =',JDIFR WRITE(MONIOU,*) ' POMERON-NUCLEON COUPLING RR =',RR #endif ELSEIF ( NDIF .EQ. 1 ) THEN #if __QGSII__ WRITE(MONIOU,*) 'QGSINI: NDIF = 1 NOT POSSIBLE FOR QGSJET_II' WRITE(MONIOU,*) 'USE THE TRIGGER CONDITION INSTEAD' WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE' WRITE(MONIOU,*) 'SEE KEYWORD: TRIGGER' STOP #else C ONLY NON-DIFFRACTIVE EVENTS WRITE(MONIOU,*) * 'QGSINI: NDIF = 1 ONLY NON-DIFFRACTIVE EVENTS' C OVERWRITE JDIFFR AND WPPP, WHICH ARE SET IN SUBROUT. XXASET JDIFR = 0 WPPP = 0.D0 WRITE(MONIOU,*) ' HIGH MASS DIFFR. PROBABILITY =',WPPP WRITE(MONIOU,*) ' LOW MASS DIFFR. TREATMENT =',JDIFR WRITE(MONIOU,*) ' POMERON-NUCLEON COUPLING RR =',RR #endif ELSEIF ( NDIF .EQ. 2 ) THEN C ONLY DIFFRACTIVE EVENTS WRITE(MONIOU,*) 'QGSINI: NDIF = 2 NOT POSSIBLE FOR QGSJET' STOP ENDIF #endif C COMMON INITIALIZATION PROCEDURE IF ( MODE .EQ. 1 ) THEN #if __QGSII__ CALL QGAINI( DATDIR ) ELSEIF ( MODE .EQ. 2 ) THEN CALL QGAINI( DATDIR ) #else CALL PSAINI( DATDIR ) ELSEIF ( MODE .EQ. 2 ) THEN CALL PSAINI( DATDIR ) #endif C 110 FORMAT(' ', C * '====================================================', C * /,' ','| |', C * /,' ','| ONLY QGSJET CROSS-SECTIONS ARE USED |', C * /,' ','| |', C * /,' ','====================================================') CALL QGSSIGINI ELSEIF ( MODE .EQ. 3 ) THEN #if __QGSII__ CALL QGAINI( DATDIR ) #else CALL PSAINI( DATDIR ) #endif C 120 FORMAT(' ', C * '====================================================', C * /,' ','| |', C * /,' ','| ALSO QGSJET CROSS-SECTIONS ARE USED |', C * /,' ','| |', C * /,' ','====================================================') CALL QGSSIGINI ENDIF IQGSVER = VERSION*10 C HOW TO TREAT FRAGMENTATION IF ( MODE .NE. 2 ) THEN IF ( NFRAGM .EQ. 0 ) THEN WRITE(MONIOU,*) 'NUCLEUS PROJECTILES DESINTEGRATE COMPLETELY', * ' IN THE FIRST INTERACTION' ELSEIF ( NFRAGM .EQ. 1 ) THEN WRITE(MONIOU,*) 'NUCLEUS PROJECTILES REMAIN AS ONE FRAGMENT', * ' IN THE FIRST INTERACTION' ELSEIF ( NFRAGM .GE. 2 ) THEN WRITE(MONIOU,*) 'NUCLEUS PROJECTILES FRAGMENT REALISTICALLY', * ' IN THE FIRST INTERACTION' ENDIF ENDIF RETURN END *-- Author : D. HECK IK FZK KARLSRUHE 12/01/1996 C======================================================================= SUBROUTINE QGSLNK C----------------------------------------------------------------------- C Q(UARK) G(LUON) S(TRING JET MODEL) L(I)NK (TO CORSIKA) C C LINKS QGSJET MODEL TO CORSIKA. C THIS SUBROUTINE IS CALLED FROM SDPM. C----------------------------------------------------------------------- IMPLICIT NONE #define __INTERINC__ #define __PAMINC__ #define __PARPARINC__ #define __PARPAEINC__ #define __QGSCINC__ #define __QGSDEBINC__ #define __QGSLININC__ #define __RANDPAINC__ #define __RESTINC__ #define __RUNPARINC__ #define __THNVARINC__ #if __INTTEST__ #define __TSTINTINC__ #endif #include "corsika.h" #if __QGSII__ INTEGER NPTMAX PARAMETER (NPTMAX=95000) COMMON /qgarr12/ NSP INTEGER NSP COMMON /qgarr14/ ESP,ICH DOUBLE PRECISION ESP(4,NPTMAX) INTEGER ICH(NPTMAX) #else COMMON /AREA12/ NSP INTEGER NSP COMMON /AREA14/ ESP,ICH DOUBLE PRECISION ESP(4,95000) INTEGER ICH(95000) COMMON /AREA20/ WPPP DOUBLEPRECISION WPPP COMMON /AREA40/ JDIFR INTEGER JDIFR #endif COMMON /DEBUG/ DEBUGQ INTEGER DEBUGQ DOUBLE PRECISION E0 INTEGER I,IAP,IAT,ICP,J,LL LOGICAL FREJECT SAVE C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'QGSLNK: TAR=',SNGL(TAR) IF ( DEBUG ) THEN DEBUGQ = LEVLDQ ELSE DEBUGQ = 0 ENDIF C SET TARGET NUCLEON NUMBER IAT = INT( TAR ) #if __INTTEST__ INTTAR = IAT C NEUTRON TARGET IF ( TAR .EQ. 2.D0 ) IAT = 1 #endif IF ( ITYPE .EQ. 1 ) THEN C PROJECTILE IS A GAMMA C REPLACE GAMMA BY PI(+) OR PI(-) ELAB = GAMMA CALL RMMARD( RD,1,1 ) IF ( RD(1) .LE. 0.5D0 ) THEN ICP = 1 ELSE ICP = -1 ENDIF IAP = 1 E0 = ELAB #if !__QGSII__ C NO DIFFRACTION FOR GAMMA INDUCED INTERACTON JDIFR = 0 #endif #if __CHARM__ && !__QGSII__ ELSEIF ( ITYPE .LE. 173 ) THEN #else ELSEIF ( ITYPE .LT. 75 ) THEN #endif C TREAT ORDINARY PROJECTILE PARTICLES ELAB = GAMMA*PAMA(ITYPE) ICP = ICTABL(ITYPE) IF ( ITYPE .EQ. 7 ) THEN C REPLACE PI(0) BY PI(+) OR PI(-) IF ( RD(1) .LE. 0.5D0 ) THEN ICP = 1 ELSE ICP = -1 ENDIF ENDIF IF ( ICP .EQ. 0 ) THEN #if __THIN__ WRITE(MONIOU,444) (CURPAR(I),I=0,9),CURPAR(13) 444 FORMAT(' QGSLNK: CURPAR=',1P,11E11.3) #else WRITE(MONIOU,444) (CURPAR(I),I=0,9) 444 FORMAT(' QGSLNK: CURPAR=',1P,10E11.3) #endif WRITE(MONIOU,*) 'QGSLNK: UNKNOWN CORSIKA PARTICLE TYPE:',ITYPE STOP ENDIF IAP = 1 E0 = ELAB #if !__QGSII__ #if __INTTEST__ C SET DIFFRACTION ACCORDING WITH SELECTION IF ( NDIF .EQ. 0 ) THEN JDIFR = 1 ELSE JDIFR = 0 ENDIF #else JDIFR = 1 #endif #endif ELSEIF ( ITYPE .GE. 200 ) THEN C TREAT PROJECTILE NUCLEI ICP = 2 IAP = ITYPE/100 C E0 IS ENERGY PER NUCLEON E0 = GAMMA * (PAMA(13)+PAMA(14)) * 0.5D0 ELAB = GAMMA*PAMA(ITYPE) #if !__QGSII__ #if __INTTEST__ C SET DIFFRACTION ACCORDING WITH SELECTION IF ( NDIF .EQ. 0 ) THEN JDIFR = 1 ELSE JDIFR = 0 ENDIF #else JDIFR = 1 #endif #endif ELSE C ILLEGAL PROJECTILE WRITE(MONIOU,*) 'QGSLNK: ITYPE=',ITYPE,' ILLEGAL' * STOP RETURN ENDIF #if !__QGSII__ C SET WPPP ACCORDING DIFFRACTION FLAG IF ( JDIFR .EQ. 1 ) THEN WPPP = 0.4D0 ELSEIF ( JDIFR .EQ. 0 ) THEN WPPP = 0.D0 ENDIF #endif ICPP = ICP IAPP = IAP IATT = IAT E000 = E0 100 CONTINUE IF ( DEBUG ) THEN C RANDOM GENERATOR STATUS (SEQUENCE L=1) AT BEGINNING OF EVENT LL = 1 CALL RMMAQD( ISEED(1,LL),LL,'R' ) C SEED IRAND(1) = ISEED(1,LL) C NUMBER OF CALLS IRAND(2) = ISEED(2,LL) C NUMBER OF BILLIONS IRAND(3) = ISEED(3,LL) ENDIF C ADDITIONAL INITIALIZATION PROCEDURE (ENERGY DEPENDENT) #if __QGSII__ CALL QGINI( E0,ICP,IAP,IAT ) #else CALL XXAINI( E0,ICP,IAP,IAT ) #endif C INTERACTION PROCEDURE CALL, SIMULATION OF INTERACTION CONFIGURATION IF ( DEBUG ) THEN WRITE(MDEBUG,158) (IRAND(J),J=1,3) 158 FORMAT(' QGSLNK: RANDOM NUMBER GENERATOR AT BEGIN:' * ,' SEQUENCE= 1 SEED= ',I9,' CALLS=',I9, * ' BILLIONS=',I9) #if __QGSII__ WRITE(MDEBUG,*) 'QGSLNK: NOW QGCONF IS CALLED' ENDIF CALL QGCONF #else WRITE(MDEBUG,*) 'QGSLNK: NOW PSCONF IS CALLED' ENDIF CALL PSCONF #endif IF ( DEBUG ) THEN WRITE(MDEBUG,199) 199 FORMAT(' NUMBER TYP ENERGY MOMENTA Z, X, Y') DO J = 1, NSP WRITE(MDEBUG,201) J,ICH(J),(SNGL(ESP(LL,J)),LL=1,4) 201 FORMAT(' ',I4,1X,I4,2X,1P,E13.6,3(1X,E13.6)) ENDDO ENDIF C STORE SECONDARY PARTICLES CALL QGSTOR( E0,FREJECT ) C RETREAT EVENT, IF REJECTED BECAUSE OF MISSING BALANCE IF ( FREJECT ) THEN IF ( DEBUG ) WRITE(MDEBUG,*) 'QGSLNK: EVENT REJECTED' ICP = ICPP IAP = IAPP IAT = IATT E0 = E000 C RESET INTERMEDIATE STACK INT_ICOUNT = 0 GOTO 100 ENDIF #if __EHISTORY__ IF ( FIRSTI ) FIRSTI = .FALSE. #endif RETURN END *-- Author : D. HECK IK FZK KARLSRUHE 13/09/1996 C======================================================================= SUBROUTINE QGSSIG( ELAB,ICZ ) C----------------------------------------------------------------------- C Q(UARK) G(LUON) S(TRING JET MODEL) SIG(MA) C C CALCULATES INELASTIC CROSS-SECTIONS. C IN CASE OF NUCLEUS-AIR INTERACTIONS THE CROSS-SECTIONS ARE C CALCULATED BY THE FUNCTION SECTNU SUPPLIED WITH QGSJET SINCE OCT. 98 C THIS SUBROUTINE IS CALLED FROM BOX2. C ARGUMENTS: C ELAB = LABORATORY ENERGY (GEV) C ICZ = HADRON TYPE: 1 = PION, 2 = NUCLEON, 3 = KAON C >200 = NUCLEUS PROJECTILE C----------------------------------------------------------------------- IMPLICIT NONE #define __AIRINC__ #define __PARPARINC__ #define __QGSLININC__ #define __QGSSGMINC__ #define __RUNPARINC__ #define __SIGMINC__ #include "corsika.h" DOUBLE PRECISION DELTAE,ELAB,ENUCL,SECT, * SIGA,SIGN,SIGO,WK(3),YE INTEGER I,IAP,ICZ,JE SAVE #if __QGSII__ DOUBLE PRECISION QGSECT EXTERNAL QGSECT #else DOUBLE PRECISION SECTNU EXTERNAL SECTNU #endif C----------------------------------------------------------------------- IF (DEBUG) WRITE(MDEBUG,*) 'QGSSIG: ELAB=',SNGL(ELAB),' ICZ=',ICZ C DETERMINE ENERGY INTERVAL FOR INTERPOLATION YE = DLOG10(ELAB) IF ( YE .LT. 1.D0 ) YE = 1.D0 JE = INT( YE ) IF ( JE .GT. 8 ) JE = 8 DELTAE = YE - JE WK(3) = DELTAE * (DELTAE-1.D0) * .5D0 WK(1) = 1.D0 - DELTAE + WK(3) WK(2) = DELTAE - 2.D0 * WK(3) IF ( ICZ .LE. 3 ) THEN C HADRON PROJECTILES ICZ ARE: PI - 1, N - 2, K - 3 SECT = 0.D0 DO I = 1, 3 SECT = SECT + SIGQAIR(JE+I-1,ICZ)*WK(I) ENDDO SIGAIR = EXP( SECT ) SECT = 0.D0 DO I = 1, 3 SECT = SECT + QFRACN(JE+I-1,ICZ)*WK(I) ENDDO FRACTN = EXP( SECT ) SECT = 0.D0 DO I = 1, 3 SECT = SECT + QFRANO(JE+I-1,ICZ)*WK(I) ENDDO FRCTNO = EXP( SECT ) SIGMA = 0.D0 ELSEIF ( ICZ .GE. 200 ) THEN C FOR NUCLEUS PROJECTILES TAKE CROSS-SECTIONS FROM QGSJET IAP = ICZ/100 C ELAB IS ENERGY/NUCLEON ENUCL = ELAB #if __QGSII__ SIGN = QGSECT(ENUCL,2,IAP,14) SIGO = QGSECT(ENUCL,2,IAP,16) SIGA = QGSECT(ENUCL,2,IAP,40) #else SIGN = SECTNU(ENUCL,IAP,14) SIGO = SECTNU(ENUCL,IAP,16) SIGA = SECTNU(ENUCL,IAP,40) #if !__QGSJETOLD__ C RESPECT LARGER NUCLEAR DENSITY RADIUS FOR OXYGEN SIGN = SIGN * 1.03D0 SIGO = SIGO * 1.03D0 #endif #endif FRACTN = COMPOS(1)*SIGN FRCTNO = FRACTN + COMPOS(2)*SIGO SIGAIR = FRCTNO + COMPOS(3)*SIGA SIGMA = 0.D0 ELSE #if __THIN__ WRITE(MONIOU,444) (CURPAR(I),I=0,9),CURPAR(13) 444 FORMAT(' QGSSIG: CURPAR=',1P,11E11.3) #else WRITE(MONIOU,444) (CURPAR(I),I=0,9) 444 FORMAT(' QGSSIG: CURPAR=',1P,10E11.3) #endif WRITE(MONIOU,*) 'QGSSIG: ILLEGAL PROJECTILE TYP =',ICZ STOP ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) 'QGSSIG: SIGAIR=',SNGL(SIGAIR) RETURN END *-- Author : D. HECK IK FZK KARLSRUHE 12/09/1996 C======================================================================= SUBROUTINE QGSSIGINI C----------------------------------------------------------------------- C Q(UARK) G(LUON) S(TRING JET MODEL) SIG(MA) INI(TIALIZATION) C C INITIALIZES INELASTIC CROSS-SECTIONS. C THIS SUBROUTINE IS CALLED FROM QGSINI. C----------------------------------------------------------------------- IMPLICIT NONE #define __AIRINC__ #define __QGSCINC__ #define __QGSSGMINC__ #define __RUNPARINC__ #include "corsika.h" #if __QGSII__ COMMON /qgarr47/ GSECT DOUBLE PRECISION GSECT(10,5,6) #else COMMON /XSECT/ GSECT DOUBLE PRECISION GSECT(10,5,4) #endif DOUBLE PRECISION EON,SECT(3),SECTN,SECTA,SECTO, * WA(3),YA INTEGER IAT,ICZ,JA,JE,M SAVE C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'QGSSIGINI - START' IF ( DEBUG ) WRITE(MDEBUG,*) * ' INELASTIC CROSS-SECTIONS WITH AIR ', * '(WITH NUCLEON)' IF ( DEBUG ) WRITE(MDEBUG,*) * ' ENERGY SIGMA(PI) SIGMA(N) SIGMA(K) ', * ' SIGMA(N-N)' DO 100 JE = 1, 10 C LOOP 100 RUNS OVER ALL ENERGY VALUES JE = 1: E = 1GeV C JE = 10: E = C (SEE PSAINI RSP. QGSECT) DO ICZ = 1, 3 C LOOP OVER HADRON PROJECTILES C HADRON PROJECTILES ICZ ARE: PI - 1, N - 2, K - 3 C FIRST FOR NITROGEN TARGET SECTN=0.D0 #if __QGSII__ SECTN = SECTN+GSECT(JE,ICZ,5) SECTN = EXP( SECTN ) #else IAT = 14 ! TARGET YA = IAT YA = DLOG( YA ) / 1.38629D0+1.D0 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) DO M = 1, 3 SECTN = SECTN+GSECT(JE,ICZ,JA+M-1)*WA(M) ENDDO SECTN = EXP( SECTN ) #if !__QGSJETOLD__ C RESPECT LARGER NUCLEAR DENSITY RADIUS FOR NITROGEN SECTN = SECTN * 1.03D0 #endif #endif C THEN FOR OXYGEN TARGET SECTO = 0.D0 IAT = 16 !TARGET YA = IAT YA = DLOG( YA ) / 1.38629D0+1.D0 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) DO M = 1, 3 #if __QGSII__ SECTO = SECTO+GSECT(JE,ICZ,JA+M-1)*WA(M) ENDDO SECTO = EXP( SECTO ) #else SECTO = SECTO+GSECT(JE,ICZ,JA+M-1)*WA(M) ENDDO SECTO = EXP( SECTO ) #if !__QGSJETOLD__ C RESPECT LARGER NUCLEAR DENSITY RADIUS FOR OXYGEN SECTO = SECTO * 1.03D0 #endif #endif C THEN FOR ARGON TARGET SECTA = 0.D0 #if __QGSII__ SECTA = SECTA+GSECT(JE,ICZ,6) #else IAT = 40 YA = IAT ! TARGET YA = DLOG( YA ) / 1.38629D0+1.D0 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) DO M = 1, 3 SECTA = SECTA+GSECT(JE,ICZ,JA+M-1)*WA(M) ENDDO #endif SECTA = EXP( SECTA ) C NOW TAKE THE COMPOSITION OF AIR TO CALCULATE AIR CROSS-SECTION SECT(ICZ) = COMPOS(1)*SECTN QFRACN(JE,ICZ) = LOG( SECT(ICZ) ) SECT(ICZ) = SECT(ICZ) + COMPOS(2)*SECTO QFRANO(JE,ICZ) = LOG( SECT(ICZ) ) SECT(ICZ) = SECT(ICZ) + COMPOS(3)*SECTA SIGQAIR(JE,ICZ) = LOG( SECT(ICZ) ) ENDDO C NUCLEON NUCLEON CROSS-SECTION IF ( DEBUG ) THEN SIGQHN(JE) = GSECT(JE,2,1) EON = 10.D0**JE WRITE(MDEBUG,101) SNGL(EON), SNGL(SECT(1)), * SNGL(SECT(2)),SNGL(SECT(3)),SNGL(EXP(SIGQHN(JE))) 101 FORMAT(1H ,E14.7,1X,F9.4,3(6X,F9.4)) ENDIF 100 CONTINUE IF ( DEBUG ) THEN WRITE(MDEBUG,*) WRITE(MDEBUG,*) 'NOW LOGARITHMS OF THE CROSS-SECTIONS WITH AIR' WRITE(MDEBUG,*) * ' ENERGY SIGMA(PI) SIGMA(N) SIGMA(K) ', * ' SIGMA(N-N)' DO JE = 1, 10 EON = 10.D0**JE WRITE(MDEBUG,102) SNGL(EON),SNGL(SIGQAIR(JE,1)), * SNGL(SIGQAIR(JE,2)),SNGL(SIGQAIR(JE,3)),SNGL(SIGQHN(JE)) 102 FORMAT(1H ,E14.7,1X,F9.6,3(6X,F9.6)) ENDDO WRITE(MDEBUG,*) 'QGSSIGINI - END' ENDIF RETURN END *-- Author : D. HECK IK FZK KARLSRUHE 12/01/1996 C======================================================================= SUBROUTINE QGSTOR( E0,FREJECT ) C----------------------------------------------------------------------- C Q(UARK) G(LUON STRING JET MODEL) STOR(E TO CORSIKA) C C STORE QGSJET RESULTS TO CORSIKA STACK. C THIS SUBROUTINE IS CALLED FROM QGSLNK. C ARGUMENT: C E0 = LABORATORY ENERGY (GEV) C IN CASE OF NUCLEUS PROJECTILE: LAB.ENERGY/NUCLEON C FREJECT= REJECTION FLAG IF ENERGY OF SEC. PARTICLES UNBALANCED C----------------------------------------------------------------------- IMPLICIT NONE #define __CONSTAINC__ #define __DPMFLGINC__ #define __ELADPMINC__ #define __ELASTYINC__ #define __INTERINC__ #define __ISTAINC__ #define __LONGIINC__ #define __MULTINC__ #define __PAMINC__ #define __PARPARINC__ #define __PARPAEINC__ #define __QGSDEBINC__ #define __QGSLININC__ #define __RANDPAINC__ #define __RESTINC__ #define __RUNPARINC__ #define __SIGMINC__ #if __AUGERHIST__ || __EHISTORY__ #define __GENERINC__ #endif #if __AUGERHIST__ || __COASTUSERLIB__ #define __OBSPARINC__ #endif #if __INTTEST__ #define __TSTINTINC__ #endif #include "corsika.h" #if __QGSII__ INTEGER IAPMAX,NPTMAX PARAMETER (IAPMAX=208) PARAMETER (NPTMAX=95000) COMMON /qgarr12/ NSP INTEGER NSP COMMON /qgarr13/ NSF,IAF INTEGER NSF,IAF(IAPMAX) COMMON /qgarr14/ ESP,ICH DOUBLE PRECISION ESP(4,NPTMAX) INTEGER ICH(NPTMAX) C for qgsjetII-04 version: COMMON /qgarr55/ NWT,NWP INTEGER NWT,NWP #else COMMON /AREA11/ B10 DOUBLE PRECISION B10 COMMON /AREA12/ NSP INTEGER NSP COMMON /AREA13/ NSF,IAF(56) INTEGER NSF,IAF COMMON /AREA14/ ESP,ICH DOUBLE PRECISION ESP(4,95000) INTEGER ICH(95000) COMMON /AREA99/ NWT INTEGER NWT #endif DOUBLE PRECISION AGLH,AUXIL,BGLH,COSTHI,COSTHJ,CPHII,CPHIJ DOUBLE PRECISION EI,EPT(4),E0,ELASTI,EMAX,ETOT,RANRES DIMENSION RANRES(1) DOUBLE PRECISION FAC1,FAC2 * DOUBLE PRECISION GAMMAX DOUBLE PRECISION PHII,PFR(56),PFRX(56),PFRY(56) DOUBLE PRECISION PL2,PTOT,PT2,SPFRX,SPFRY,SPHII,SPHIJ DOUBLE PRECISION RANNOR INTEGER I,IADDI,ITYPJ,J,K,L,LL,LOUT,MEL,MEN,NP INTEGER ITYPI(56) INTEGER IANEW,INNEW,IZNEW,MAPROJ #if __EHISTORY__ INTEGER IK #endif LOGICAL ERRFLG,FREJECT SAVE #if __AUGERHIST__ DOUBLE PRECISION EDEP,THICKLOC,THICK INTEGER II EXTERNAL THICK #endif #if __COASTUSERLIB__ c definition of the COAST crs::CInteraction class COMMON/coastInteraction/coastX, coastY, coastZ, & coastE, coastCX, coastEl, coastProjId, coastTargId, & coastT double precision coastX, coastY, coastZ double precision coastE, coastCX, coastEl double precision coastT integer coastProjId, coastTargId #endif EXTERNAL RANNOR C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'QGSTOR:',NSP,' SECONDARIES AND', * NWT,' PARTICIPATING TARGET NUCLEONS' #if __INTTEST__ C INTERACTING TARGET NUCLEONS IWOUNT = NWT #endif FREJECT= .FALSE. ERRFLG = .FALSE. * GAMMAX = 0.D0 EMAX = 0.D0 ELASTI = 0.D0 ETOT = 0.D0 EPT(1) = -ELAB EPT(2) = -ELAB EPT(3) = 0.D0 EPT(4) = 0.D0 IF ( DEBUG ) WRITE(MDEBUG,159) (IRAND(J),J=1,3) 159 FORMAT(' QGSTOR: RANDOM NUMBER GENERATOR AT BEGIN:' * ,' SEQUENCE= 1 SEED=',I9,' CALLS=',I9, * ' BILLIONS=',I9) #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME GRANDMOTHER PARTICLE DO IK = 0, 6 SECPAR(28+IK) = CURPAR(IK) ENDDO C STORE GENERATION COUNTER OF MOTHER SECPAR(35) = GEN C STORE MASS PENETRATION BEFORE INTERACTION SECPAR(36) = CURPAR(9) #if __THIN__ SECPAR(37) = CURPAR(13) #endif #endif C TREAT PROJECTILE SPECTATORS IF ( NSF .GT. 0 ) THEN IF (DEBUG) WRITE(MDEBUG,*) 'QGSTOR:',NSF,' SPECTATOR FRAGMENTS' IANEW = 0 C DETERMINE THE NUMBER OF SPECTATOR NUCLEONS DO I = 1, NSF IANEW = IANEW + IAF(I) ENDDO C DETERMINE THE NUMBER OF SPECTATOR PROTONS AND NEUTRONS IZNEW = INT( DBLE(IANEW)/2.15D0 + 0.7D0 ) INNEW = IANEW - IZNEW #if __INTTEST__ IWOUNP = INT( ITYPE/100 ) - IANEW #endif IF ( NFRAGM .EQ. 0 ) THEN C NUCLEUS FRAGMENTATES COMPLETELY IN INTERACTION IF ( DEBUG ) WRITE(MDEBUG,*) * ' WHICH DESINTEGRATE COMPLETELY' SECPAR(1) = CURPAR(1) SECPAR(2) = CURPAR(2) SECPAR(3) = CURPAR(3) SECPAR(4) = CURPAR(4) #if __INTTEST__ SECPAR(17) = CURPAR(17) #endif IF ( IZNEW .GT. 0 ) THEN C PROTONS DO I = 1, IZNEW SECPAR(0) = 14.D0 EI = PAMA(14)*GAMMA ETOT = ETOT + EI PL2 = ( EI - PAMA(14) ) * ( EI + PAMA(14) ) EPT(2) = EPT(2) + SQRT( PL2 ) EPT(1) = EPT(1) + EI #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER PARTICLE DO IK = 0, 8 SECPAR(17+IK) = SECPAR(IK) ENDDO #if __THIN__ SECPAR(26) = SECPAR(13) #endif #endif CALL TSTACK ENDDO ENDIF IF ( INNEW .GT. 0 ) THEN C NEUTRONS DO I = 1, INNEW SECPAR(0) = 13.D0 EI = PAMA(13)*GAMMA ETOT = ETOT + EI PL2 = ( EI - PAMA(13) ) * ( EI + PAMA(13) ) EPT(2) = EPT(2) + SQRT( PL2 ) EPT(1) = EPT(1) + EI #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER PARTICLE DO IK = 0, 8 SECPAR(17+IK) = SECPAR(IK) ENDDO #if __THIN__ SECPAR(26) = SECPAR(13) #endif #endif CALL TSTACK ENDDO ENDIF ELSEIF ( NFRAGM .EQ. 1 ) THEN C FORM A NUCLEUS WITH MASS NUMBER IANEW AND CHARGE IZNEW IF ( DEBUG ) WRITE(MDEBUG,*) * ' WHICH FORM A NEW NUCLEUS' ITYPJ = IANEW*100+IZNEW C REPLACE SINGLE PROTON OR NEUTRON BY HADRONIC PARTICLE TYPE IF ( ITYPJ .EQ. 100 ) THEN ITYPJ = 13 ELSEIF ( ITYPJ .EQ. 101 ) THEN ITYPJ = 14 ENDIF EI = PAMA(ITYPJ)*GAMMA ETOT = ETOT + EI PL2 = ( EI - PAMA(ITYPJ) ) * ( EI + PAMA(ITYPJ) ) EPT(2) = EPT(2) + SQRT( PL2 ) EPT(1) = EPT(1) + EI SECPAR(1) = CURPAR(1) SECPAR(2) = CURPAR(2) SECPAR(3) = CURPAR(3) SECPAR(4) = CURPAR(4) #if __INTTEST__ SECPAR(17) = CURPAR(17) #endif IF ( IANEW .EQ. 8 ) THEN C MASS 8 CANNOT BE TREATED IN BOX2 AND DECAYS INTO 2 ALPHA PARTICLES SECPAR(0) = 402.D0 #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER PARTICLE DO IK = 0, 8 SECPAR(17+IK) = SECPAR(IK) ENDDO #if __THIN__ SECPAR(26) = SECPAR(13) #endif #endif CALL TSTACK CALL TSTACK ELSEIF ( IANEW .EQ. 5 ) THEN C MASS 5 CANNOT BE TREATED IN BOX2 AND DECAYS INTO 1 ALPHA + 1 NUCLEON IF ( IZNEW .GE. 3 ) THEN SECPAR(0) = 14.D0 ELSE SECPAR(0) = 13.D0 ENDIF #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER PARTICLE DO IK = 0, 8 SECPAR(17+IK) = SECPAR(IK) ENDDO #if __THIN__ SECPAR(26) = SECPAR(13) #endif #endif CALL TSTACK SECPAR(0) = 402.D0 #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER PARTICLE DO IK = 0, 8 SECPAR(17+IK) = SECPAR(IK) ENDDO #if __THIN__ SECPAR(26) = SECPAR(13) #endif #endif CALL TSTACK ELSE C ALL OTHER NUCLEI CAN BE TREATED IN BOX2 SECPAR(0) = DBLE(ITYPJ) #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER PARTICLE DO IK = 0, 8 SECPAR(17+IK) = SECPAR(IK) ENDDO #if __THIN__ SECPAR(26) = SECPAR(13) #endif #endif CALL TSTACK ENDIF ELSEIF ( NFRAGM .GE. 2 ) THEN C NUCLEAR FRAGMENTS ARE DELIVERED FROM QGSJET-MODEL IF ( DEBUG ) WRITE(MDEBUG,*) * ' WHICH PROPAGATE' MAPROJ = ITYPE/100 IADDI = 0 DO I = 1, NSF CALL RMMARD( RD,1,1 ) IF ( IAF(I) .EQ. 1 ) THEN ITYPI(I) = 13 + NINT( RD(1) ) ELSEIF ( IAF(I) .EQ. 2 ) THEN ITYPI(I) = 201 ELSEIF ( IAF(I) .EQ. 3 ) THEN ITYPI(I) = 301 + NINT( RD(1) ) ELSEIF ( IAF(I) .EQ. 4 ) THEN ITYPI(I) = 402 ELSEIF ( IAF(I) .EQ. 5 ) THEN C FRAGMENT NUCLEUS WITH MASS NUMBER 5 CANNOT EXIST IAF(I) = 4 IADDI = IADDI + 1 IAF(NSF+IADDI) = 1 ITYPI(I) = 402 ITYPI(NSF+IADDI) = 13 + NINT( RD(1) ) ELSEIF ( IAF(I) .EQ. 8 ) THEN C FRAGMENT NUCLEUS WITH MASS NUMBER 8 CANNOT EXIST IAF(I) = 4 IADDI = IADDI + 1 IAF(NSF+IADDI) = 4 ITYPI(I) = 402 ITYPI(NSF+IADDI) = 402 ELSE IZNEW = INT( DBLE(IAF(I))/2.15D0 + 0.7D0 ) ITYPI(I) = IAF(I)*100+IZNEW ENDIF ENDDO IF ( IADDI .GT. 0 ) THEN NSF = NSF + IADDI IF ( DEBUG ) WRITE(MDEBUG,*) * ' WHICH DESINTEGRATE INTO', * NSF,' FRAGMENTS' ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) * ' NUMBER TYP-QGSJET TYP TRANSV.MOMENT' DO I = 1, NSF IF ( NFRAGM .EQ. 2 ) THEN C EVAPORATION WITH PT AFTER PARAMETERIZED JACEE DATA PFR(I) = RANNOR(0.088D0,0.044D0) ELSEIF ( NFRAGM .EQ. 3 ) THEN C EVAPORATION WITH PT AFTER GOLDHABER''S MODEL (PHYS.LETT.53B(1974)306) K = MAX( 1, ITYPI(I)/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(I) = RANNOR(0.D0,AGLH) ELSEIF ( NFRAGM .EQ. 4 ) THEN C EVAPORATION WITHOUT TRANSVERSE MOMENTUM PFR(I) = 0.D0 ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) I,IAF(I),ITYPI(I),SNGL(PFR(I)) ENDDO C CALCULATE RESIDUAL TRANSVERSE MOMENTUM SPFRX = 0.D0 SPFRY = 0.D0 CALL RMMARD( RD,NSF,1 ) DO I = 1, NSF PHII = PI * RD(I) PFRX(I) = PFR(I) * COS( PHII ) PFRY(I) = PFR(I) * SIN( PHII ) SPFRY = SPFRY + PFRY(I) SPFRX = SPFRX + PFRX(I) ENDDO C CORRECT ALL TRANSVERSE MOMENTA FOR MOMENTUM CONSERVATION SPFRX = SPFRX / DBLE(NSF) SPFRY = SPFRY / DBLE(NSF) DO I = 1, NSF PFRX(I) = PFRX(I) - SPFRX PFRY(I) = PFRY(I) - SPFRY ENDDO C CALCULATE COSTHI AND PHII DO 190 I = 1, NSF EI = PAMA(ITYPI(I))*GAMMA ETOT = ETOT + EI PL2 = ( EI - PAMA(ITYPI(I)) ) * ( EI + PAMA(ITYPI(I)) ) EPT(1) = EPT(1) + EI PT2 = PFRX(I)**2 + PFRY(I)**2 IF ( PT2 .GE. PL2 ) THEN IF ( DEBUG ) THEN WRITE(MDEBUG,*) 'QGSTOR: PT REJECT PARTICLE',I WRITE(MDEBUG,*) * ' PT =',SNGL(SQRT(PT2)),' EI =',SNGL(EI) ENDIF GOTO 190 ENDIF IF ( PL2 .GT. 0.D0 ) THEN PTOT = SQRT( PL2 ) EPT(2) = EPT(2) + PTOT COSTHI = SQRT( 1.D0 - PT2/PL2 ) CPHII = PFRX(I) / PTOT SPHII = PFRY(I) / PTOT ELSE COSTHI = 0.D0 CPHII = 1.D0 SPHII = 0.D0 ENDIF CALL ADDANG4( COSTHE,PHIX,PHIY, COSTHI,CPHII,SPHII, * SECPAR(2),SECPAR(3),SECPAR(4) ) #if __UPWARD__ IF ( SECPAR(2) .GE. -1.D0 ) THEN #else IF ( SECPAR(2) .GT. C(29) ) THEN #endif SECPAR(0) = ITYPI(I) SECPAR(1) = CURPAR(1) #if __INTTEST__ SECPAR(17) = SQRT( PT2 ) #endif #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER PARTICLE DO IK = 0, 8 SECPAR(17+IK) = SECPAR(IK) ENDDO #if __THIN__ SECPAR(26) = SECPAR(13) #endif #endif CALL TSTACK ELSE IF ( DEBUG ) WRITE(MDEBUG,*) * 'QGSTOR: ANGLE REJECT PARTICLE',I IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT #if __THIN__ DLONG(LHEIGH,17) = DLONG(LHEIGH,17) + ( EI * - RESTMS(ITYPI(I)) ) * WEIGHT #else DLONG(LHEIGH,17) = DLONG(LHEIGH,17)+EI-RESTMS(ITYPI(I)) #endif ENDIF #if __AUGERHIST__ THICKLOC = THICK( H ) DO LL = 1, NOBSLV IF ( THICKLOC .GE. THCKOB(LL) .AND. * THICKLOC .LT. THCKOB(LL)+SAMPTH ) THEN C THICKH IS WITHIN 1 G/CM^2 BELOW OBSLEV(LL) C BRING THE ENERGY BELOW ANGULAR CUT TO THE HISTO OF LEVEL LL OUTPAR(0) = ITYPI(I) OUTPAR(1) = CURPAR(1) DO II = 2, 8 OUTPAR(II) = SECPAR(II) ENDDO OUTPAR( 9) = GEN OUTPAR(10) = ALEVEL OUTPAR(13) = WEIGHT EDEP = ( OUTPAR(1) * PAMA(ITYPI(I)) * - RESTMS(ITYPI(I)) ) * WEIGHT C WE HAVE ANGULAR CUT CALL AUGERDEPFIL( EDEP,LL,1 ) ELSEIF ( THICKLOC .LT. THCKOB(LL) ) THEN GOTO 112 ENDIF ENDDO 112 CONTINUE #endif ENDIF 190 CONTINUE ENDIF ENDIF C NSP IS THE NUMBER OF SECONDARY PARTICLES PRODUCED C ICH(IS) IS THE TYPE OF SECONDARY HADRON C ESP(I,IS) ISITS 4- MOMENTUM: ESP(1,IS) = ENERGY, C ESP(2,IS) = PLONG, ESP(3,IS) = PTRANS*COS, ESP(4,IS) = PTRANS*SIN C THE FOLLOWING NOTATIONS FOR THE PARTICLES TYPES ARE USED: C 0 - PI0, C 1 - PI+, C -1 - PI-, C 2 - P, C -2 - P-BAR, C 3 - N, C -3 - N-BAR, C 4 - K+, C -4 - K-, C 5 - K0S, C -5 - K0L C 6 - LAMBDA C -6 - LAMBDA-BAR C 7 - D+ C -7 - D- C 8 - D0 C -8 - D0-BAR C 9 - LAMBDA_C C -9 - LAMBDA_C-BAR C 10 - ETA C -10 - RHO0 NP = NSP C LOOP OVER ALL NP SECONDARY PARTICLES DO 100 J = 1, NP DO I = 1, 4 EPT(I) = EPT(I) + ESP(I,J) ENDDO L = ICH(J) C CHECK PARTICLE CODE #if __QGSII__ IF ( L .LT. -10 .OR. L .GT. 10 ) THEN #else IF ( L .LT. -9 .OR. L .GT. 10 ) THEN #endif WRITE(MONIOU,*) 'QGSTOR: UNKNOWN PARTICLE NR.',J, * ' WITH QGSJET CODE =', ICH(J) ERRFLG = .TRUE. GOTO 100 ENDIF C CONVERT PARTICLE CODE ITYPJ = IQTABL(L) IF ( ITYPJ .EQ. 0 ) THEN WRITE(MONIOU,*) 'QGSTOR: UNKNOWN PARTICLE NR.',J, * ' WITH QGSJET CODE =', ICH(J) ERRFLG = .TRUE. GOTO 100 ENDIF C CALCULATE THE EMISSION ANGLES AND GAMMA FACTORS ETOT = ETOT + ESP(1,J) AUXIL = ESP(2,J)**2 + ESP(3,J)**2 + ESP(4,J)**2 SECPAR(1) = ESP(1,J) IF ( PAMA(ITYPJ) .GT. 0.D0 ) THEN SECPAR(1) = SECPAR(1) / PAMA(ITYPJ) #if !__INTTEST__ C ELIMINATE TARGET SPECTATORS IF ( SECPAR(1) .LE. 1.0001D0 ) THEN GOTO 100 ENDIF ENDIF IF ( AUXIL .LE. 0.D0 ) GOTO 100 PTOT = SQRT( AUXIL ) CPHIJ = ESP(3,J) / PTOT SPHIJ = ESP(4,J) / PTOT COSTHJ = ESP(2,J) / PTOT COSTHJ = MAX( -1.D0, MIN( 1.D0, COSTHJ ) ) #else IF ( SECPAR(1) .LE. 1.D0 ) THEN C TREAT TARGET SPECTATORS COSTHJ = 1.D0 ELSE IF ( AUXIL .LE. 0.D0 ) GOTO 100 PTOT = SQRT( AUXIL ) CPHIJ = ESP(3,J) / PTOT SPHIJ = ESP(4,J) / PTOT COSTHJ = ESP(2,J) / PTOT COSTHJ = MAX( -1.D0, MIN( 1.D0, COSTHJ ) ) ENDIF ENDIF C IF ( COSTHJ .EQ. 0.D0 ) COSTHJ = 1.D-4 SECPAR(17) = SQRT( ESP(4,J)**2 + ESP(3,J)**2 ) #endif IF ( ITYPJ .NE. 1 .AND. ITYPJ .LE. 26 ) THEN * IF ( SECPAR(1) .GT. GAMMAX ) THEN * GAMMAX = SECPAR(1) C CALCULATE ELASTICITY FROM ENERGY OF FASTEST PARTICLE (LEADER) * ELASTI = GAMMAX * PAMA(ITYPJ) / E0 * ENDIF IF ( ESP(1,J) .GT. EMAX ) THEN EMAX = ESP(1,J) C CALCULATE ELASTICITY FROM MOST ENERGETIC PARTICLE (LEADER) ELASTI = EMAX / E0 ENDIF ENDIF C COUNTER FOR ENERGY-MULTIPLICITY MATRIX MSMM = MSMM + 1 SECPAR(0) = ITYPJ CALL ADDANG4( COSTHE,PHIX,PHIY, COSTHJ,CPHIJ,SPHIJ, * SECPAR(2),SECPAR(3),SECPAR(4) ) C STORE ONLY PARTICLES ABOVE ANGULAR CUT TO THE CORSIKA STACK #if __UPWARD__ IF ( SECPAR(2) .GE. -1.D0 ) THEN #else IF ( SECPAR(2) .GT. C(29) ) THEN #endif #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER PARTICLE DO IK = 0, 8 SECPAR(17+IK) = SECPAR(IK) ENDDO #if __THIN__ SECPAR(26) = SECPAR(13) #endif #endif CALL TSTACK ELSE IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT IF ( ITYPJ .EQ. 8 .OR. ITYPJ .EQ. 9 .OR. * ITYPJ .EQ. 11 .OR. ITYPJ .EQ. 12 ) THEN FAC1 = 0.25D0 FAC2 = 0.75D0 ELSEIF ( ITYPJ .EQ. 10 .OR. ITYPJ .EQ. 16 ) THEN FAC1 = 0.5D0 FAC2 = 0.5D0 ELSE FAC1 = 1.D0 FAC2 = 0.D0 ENDIF #if __THIN__ C ADD TO THE HADRON ENERGY DEPOSIT DLONG(LHEIGH,17) = DLONG(LHEIGH,17) + ( ESP(1,J) * - RESTMS(ITYPJ) ) * WEIGHT * FAC1 C ADD TO THE NEUTRINO DEPOSIT DLONG(LHEIGH,18) = DLONG(LHEIGH,18) + ( ESP(1,J) * - RESTMS(ITYPJ) ) * WEIGHT * FAC2 #else C ADD TO THE HADRON ENERGY DEPOSIT DLONG(LHEIGH,17) = DLONG(LHEIGH,17) + ( ESP(1,J) * - RESTMS(ITYPJ) ) * FAC1 C ADD TO THE NEUTRINO DEPOSIT DLONG(LHEIGH,18) = DLONG(LHEIGH,18) + ( ESP(1,J) * - RESTMS(ITYPJ) ) * FAC2 #endif ENDIF #if __AUGERHIST__ THICKLOC = THICK( H ) DO LL = 1, NOBSLV IF ( THICKLOC .GE. THCKOB(LL) .AND. * THICKLOC .LT. THCKOB(LL)+SAMPTH ) THEN C THICKH IS WITHIN 1 G/CM^2 BELOW OBSLEV(LL) C BRING THE ENERGY BELOW ANGULAR CUT TO THE HISTO OF LEVEL LL DO II = 0, 8 OUTPAR(II) = SECPAR(II) ENDDO OUTPAR( 9) = GEN OUTPAR(10) = ALEVEL OUTPAR(13) = WEIGHT EDEP = ( ESP(1,J) - RESTMS(ITYPJ) ) * WEIGHT C WE HAVE ANGULAR CUT CALL AUGERDEPFIL( EDEP,LL,1 ) ELSEIF ( THICKLOC .LT. THCKOB(LL) ) THEN GOTO 111 ENDIF ENDDO 111 CONTINUE #endif ENDIF C COUNTERS FOR FIRST INTERACTION IF ( FIRSTI ) THEN IF ( SECPAR(0).EQ. 7.D0 .OR. SECPAR(0).EQ. 8.D0 * .OR. SECPAR(0).EQ. 9.D0 ) THEN IFINPI = IFINPI + 1 ELSEIF ( SECPAR(0).EQ.13.D0 .OR. SECPAR(0).EQ.14.D0 * .OR. SECPAR(0).EQ.15.D0 .OR. SECPAR(0).EQ.25.D0 ) THEN IFINNU = IFINNU + 1 ELSEIF ( SECPAR(0).EQ.10.D0 .OR. SECPAR(0).EQ.11.D0 * .OR. SECPAR(0).EQ.12.D0 .OR. SECPAR(0).EQ.16.D0 ) THEN IFINKA = IFINKA + 1 ELSEIF ( SECPAR(0).EQ.17.D0 ) THEN IFINET = IFINET + 1 ELSEIF ((SECPAR(0).GE.18.D0 .AND. SECPAR(0).LE.24.D0) * .OR. (SECPAR(0).GE.26.D0 .AND. SECPAR(0).LE.32.D0)) THEN IFINHY = IFINHY + 1 ELSEIF ( SECPAR(0) .GE. 51.D0 .AND. SECPAR(0) .LE. 53.D0) THEN IFINRHO = IFINRHO + 1 #if __CHARM__ ELSEIF ((SECPAR(0).GE.116.D0 .AND. SECPAR(0).LE.130.D0) .OR. * (SECPAR(0).GE.137.D0 .AND. SECPAR(0).LE.173.D0)) THEN IFINCM = IFINCM + 1 #endif ELSE IFINOT = IFINOT + 1 ENDIF ENDIF 100 CONTINUE C EPT(1) WAS INITIALIZED WITH THE NEGATIVE ENERGY; IN CASE OF CORRECT C ENERGY BALANCE EPT(1) SHOULD BE 0; IF DISAGREEMENT > 20% ENERGY/NUCLEON, C THE EVENT IS UNBALANCED AND PRINTED OUT. CC IF ( DEBUG .OR. ERRFLG .OR. CC * (ABS(EPT(1)/E000) .GE. 0.2D0) ) THEN C PRINT UNBALANCED EVENTS IF ( DEBUG .OR. ERRFLG ) THEN C PRINT EVENTS WITH ERROR IF ( DEBUG ) THEN LOUT = MDEBUG ELSE LOUT = MONIOU ENDIF #if __THIN__ WRITE(LOUT,444) (CURPAR(I),I=0,9),CURPAR(13) 444 FORMAT(' QGSTOR: CURPAR=',1P,11E11.3) #else WRITE(LOUT,444) (CURPAR(I),I=0,9) 444 FORMAT(' QGSTOR: CURPAR=',1P,10E11.3) #endif WRITE(LOUT,148) IQTABL(ICPP),IAPP,E000 148 FORMAT(' PROJECTILE PARTICLE TYPE',I4,' WITH',I4, * ' NUCLEONS AND ',1P,E10.3,' GEV') WRITE(LOUT,*) ' TARGET NUCLEUS IS ',IATT WRITE(LOUT,158) (IRAND(J),J=1,3) 158 FORMAT(' QGSTOR: RANDOM NUMBER GENERATOR AT BEGIN:', * ' SEQUENCE= 1 SEED=',I9,' CALLS=',I9,' BILLIONS=',I9) IF ( .NOT. DEBUG ) THEN WRITE(LOUT,199) 199 FORMAT(' NUMBER TYP ENERGY MOMENTA Z, X, Y') DO J = 1, NP WRITE(LOUT,201) J,ICH(J),(SNGL(ESP(LL,J)),LL=1,4) 201 FORMAT(' ',I4,1X,I4,2X,1P,E13.6,3(1X,E13.6)) ENDDO ENDIF WRITE(LOUT,108) (SNGL(EPT(I)),I=4,1,-1) 108 FORMAT(' QGSTOR: 4-MOMENTA BALANCE OF EVENT:',1P,4(1X,E14.7)) WRITE(LOUT,*) 'QGSTOR: ELASTI,ETOT,ELAB=', * SNGL(ELASTI),SNGL(ETOT),SNGL(ELAB) WRITE(LOUT,*) ' PROJECTILE ENERGY WAS ',E000 ENDIF C REJECT EVENT, IF NO SECONDARIES ARE PRODUCED OR ENERGY BALANCE C IS MISMATCHED BY >20% ENERGY/NUCLEON IF ( NSP .EQ. 0 .OR. ABS(EPT(1)/E000) .GE. 0.2D0 ) THEN FREJECT = .TRUE. RETURN ENDIF C FILL ELASTICITY IN MATRICES ONLY IF NOT REJECTED IF ( .NOT. FREJECT ) THEN MEL = MIN ( 1.D0+10.D0* MAX( 0.D0, ELASTI ) , 11.D0 ) MEN = MIN ( 4.D0+ 3.D0*LOG10(MAX( .1D0, EKINL )), 40.D0 ) #if __THIN__ IELDPM(MEN,MEL) = IELDPM(MEN,MEL) + NINT( WEIGHT ) IELDPA(MEN,MEL) = IELDPA(MEN,MEL) + NINT( WEIGHT ) IF ( ELASTI .LT. 1.D0 ) THEN ELMEAN(MEN) = ELMEAN(MEN) + ELASTI * WEIGHT ELMEAA(MEN) = ELMEAA(MEN) + ELASTI * WEIGHT #else IELDPM(MEN,MEL) = IELDPM(MEN,MEL) + 1 IELDPA(MEN,MEL) = IELDPA(MEN,MEL) + 1 IF ( ELASTI .LT. 1.D0 ) THEN ELMEAN(MEN) = ELMEAN(MEN) + ELASTI ELMEAA(MEN) = ELMEAA(MEN) + ELASTI #endif ENDIF #if __COASTUSERLIB__ c for qgsjet coastProjId = nint(curpar(0)) coastTargId = nint(tar) coastX = curpar(7) coastY = curpar(8) #if __CURVED__ coastZ = curpar(14) #else coastX = coastX - XOFF(NOBSLV) coastY = coastY - YOFF(NOBSLV) coastZ = curpar(5) #endif coastT = curpar(6) coastE = pama(coastProjId)*curpar(1) coastCX = sigair coastEl = elasti call interaction(coastX) #endif IF ( FIRSTI ) THEN TARG1I = TAR SIG1I = SIGAIR ELAST = ELASTI C RANDOM GENERATOR STATUS (SEQUENCE L=1) AT END OF EVENT LL = 1 CALL RMMAQD( ISEED(1,LL),LL,'R' ) C SEED ISEED1I(1) = ISEED(1,LL) C NUMBER OF CALLS ISEED1I(2) = ISEED(2,LL) C NUMBER OF BILLIONS ISEED1I(3) = ISEED(3,LL) FIRSTI = .FALSE. ENDIF #if __INTTEST__ C ADD SPECTATORS FROM TARGET TO STACK SECPAR(1) = 1.D0 SECPAR(2) = 1.D0 SECPAR(3) = 0.D0 SECPAR(4) = 0.D0 SECPAR(17) = 0.D0 DO I = 1, (INTTAR-IWOUNT)/2 SECPAR(0) = 14.D0 CALL TSTACK ENDDO DO I = (INTTAR-IWOUNT)/2+1, INTTAR-IWOUNT SECPAR(0) = 13.D0 CALL TSTACK ENDDO #endif ENDIF C RESET COUNTER FOR PROJECTILE SPECTATORS NSF = 0 RETURN END #if __QGSII__ *-- Author : T. Pierog IKP KIT KARLSRUHE 25/10/2012 C======================================================================= SUBROUTINE LZMAOPENFILE(name) C----------------------------------------------------------------------- C DUMMY FUNCTION TO BE COMPATIBLE WITH CRMC C----------------------------------------------------------------------- IMPLICIT NONE character*256 name,name2 name2=name end *-- Author : T. Pierog IKP KIT KARLSRUHE 25/10/2012 C======================================================================= SUBROUTINE LZMACLOSEFILE() C----------------------------------------------------------------------- C DUMMY FUNCTION TO BE COMPATIBLE WITH CRMC C----------------------------------------------------------------------- IMPLICIT NONE end *-- Author : T. Pierog IKP KIT KARLSRUHE 25/10/2012 C======================================================================= SUBROUTINE LZMAFILLARRAY(dum,idum) C----------------------------------------------------------------------- C DUMMY FUNCTION TO BE COMPATIBLE WITH CRMC C----------------------------------------------------------------------- IMPLICIT NONE double precision dum,dum2 integer idum,idum2 dum2=dum idum2=idum end *-- Author : T. Pierog IKP KIT KARLSRUHE 25/10/2012 C======================================================================= INTEGER FUNCTION SIZE(array) C----------------------------------------------------------------------- C DUMMY FUNCTION TO BE COMPATIBLE WITH CRMC C----------------------------------------------------------------------- IMPLICIT NONE double precision array(*) size=int(array(1)) end #endif #endif #if __SIBYLL__ #if !__CHARM__ && !__TAULEP__ *-- Author : D. HECK IK FZK KARLSRUHE 11/11/2015 C======================================================================= INTEGER FUNCTION PYCOMP(IDUMMY) C----------------------------------------------------------------------- C DUMMY FUNCTION IF PYTHIA IS NOT SELECTED C----------------------------------------------------------------------- PYCOMP = 0 RETURN END *-- Author : D. HECK IK FZK KARLSRUHE 11/11/2015 C======================================================================= SUBROUTINE PYLIST(IDUMMY) C----------------------------------------------------------------------- C DUMMY ROUTINE IF PYTHIA IS NOT SELECTED C----------------------------------------------------------------------- INTEGER IDUMMY RETURN END *-- Author : D. HECK IK FZK KARLSRUHE 11/11/2015 C======================================================================= SUBROUTINE PYDECY(IDUMMY) C----------------------------------------------------------------------- C DUMMY ROUTINE IF PYTHIA IS NOT SELECTED C----------------------------------------------------------------------- INTEGER IDUMMY RETURN END #endif *-- Author : D. HECK IK FZK KARLSRUHE 06/12/1995 C======================================================================= BLOCK DATA SIBDAT C----------------------------------------------------------------------- C SIB(YLL) DAT(A INITIALIZATION) C C INITIALIZES DATA FOR SIBYLL LINK C UPDATED FOR SIBYLL-2.3 Sept. 2015 by D. Heck C----------------------------------------------------------------------- IMPLICIT NONE #define __SIBLININC__ #include "corsika.h" INTEGER I C ICTABL CONVERTS CORSIKA PARTICLES INTO SIBYLL PARTICLES DATA (ICTABL(I), I=1,100)/ * 1, 2, 3, 0, 4, 5, 6, 7, 8, 11, ! 10 * 9, 10, 14, 13, -13, 12, 23, 39, 34, 35, ! 20 * 36, 37, 38, 49, -14, -39, -34, -35, -36, -37, ! 30 * -38, -49, 0, 0, 0, 0, 0, 0, 0, 0, ! 40 * 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, ! 50 * 27, 25, 26, 40, 41, 42, 43, -40, -41, -42, ! 60 * -43, 30, 28, 29, 31, 15, 16, 17, 18, 0, ! 70 * 7, 7, 7, 7, 0, 0, 0, 0, 0, 0, ! 80 * 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, ! 90 * 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 / ! 100 DATA (ICTABL(I), I=101,200)/ * 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, ! 110 * 0, 0, 0, 0, 0, 71, 59, 60, 72, 74, ! 120 * 75, 73, 80, 78, 79, 81, 76, 77, 0, 83, ! 130 * 90, 91, 92, 93, 0, 0, 89, 87, 88, 84, ! 140 * 85, 86, 0, 0, 99, 0, 0, 0, -89, -87, ! 150 * -88, -84, -85, -86, 0, 0, -99, 0, 0, 0, ! 160 * 94, 95, 96, 0, 0, 0, 0, 0, 0, 0, ! 170 * -94, -95, -96, 0, 0, 0, 0, 0, 0, 0, ! 180 * 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, ! 190 * 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 / ! 200 C ISTABL CONVERTS SIBYLL PARTICLES INTO CORSIKA PARTICLES C UPDATED FOR SIBYLL-2.3 Sept. 2015 by D. Heck DATA (ISTABL(I),I=-99,0)/ * 157, 0, 0, 173, 172, 171, 0, 0, 0, 0, ! -90 * 149, 151, 150, 154, 153, 152, 130, 0, 0, 0, ! -80 * 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, ! -70 * 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, ! -60 * 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, ! -50 * 32, 0, 0, 0, 0, 0, 61, 60, 59, 58, ! -40 * 26, 31, 30, 29, 28, 27, 0, 0, 0, 0, ! -30 * 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, ! -20 * 0, 0, 0, 0, 0, 25, 15, 16, 10, 0, ! -10 * 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/ ! 0 DATA (ISTABL(I),I=1,99)/ * 1, 2, 3, 5, 6, 7, 8, 9, 11, 12, ! 10 * 10, 16, 14, 13, 66, 67, 68, 69, 15, 25, ! 20 * 0, 0, 17, 48, 52, 53, 51, 63, 64, 62, ! 30 * 65, 50, 49, 19, 20, 21, 22, 23, 18, 54, ! 40 * 55, 56, 57, 0, 0, 0, 0, 0, 24, 0, ! 50 * 0, 0, 0, 0, 0, 0, 0, 0, 117, 118, ! 60 * 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, ! 70 * 116, 119, 122, 120, 121, 127, 128, 124, 125, 123, ! 80 * 126, 0, 130, 140, 141, 142, 138, 139, 137, 131, ! 90 * 132, 133, 134, 161, 163, 172, 0, 0, 145/ ! 99 END *-- Author : D. HECK IK FZK KARLSRUHE 06/12/1995 C======================================================================= SUBROUTINE SIBINI( MODE ) C----------------------------------------------------------------------- C SIB(YLL) INI(TIALIZATION) C C FIRST INITIALIZATION OF SIBYLL PROGRAM PACKAGE. C UPDATED FOR SIBYLL-2.3 Sept. 2015 by D. Heck C THIS SUBROUTINE IS CALLED FROM START. C ARGUMENT: C MODE = 1 : SIBYLL INTERACTION MODEL IS INITIALIZED C MODE = 2 : SIBYLL CROSS-SECTIONS ARE INITIALIZED C MODE = 3 : SIBYLL INTERACT MODEL & CROSS-SECTIONS ARE INITIALIZED C----------------------------------------------------------------------- IMPLICIT NONE #define __DPMFLGINC__ #define __PAMINC__ #define __RUNPARINC__ #define __SIBDBGINC__ #define __SIBLININC__ #if __INTTEST__ #define __TSTINTINC__ #endif #include "corsika.h" COMMON /S_CLDIF/ LDIFF INTEGER LDIFF COMMON /S_CSYDEC/CBR(223+16+12+8), KDEC(1338+6*(16+12+8)), & LBARP(99), IDB(99) DOUBLE PRECISION CBR INTEGER IDB,KDEC,LBARP COMMON /S_MASS1/ AM(99), AM2(99) DOUBLE PRECISION AM, AM2 COMMON /S_MODEL/ ICSPP,ICSPA,ICSAA,IMPPL,IMPPH INTEGER ICSPP,ICSPA,ICSAA,IMPPL,IMPPH COMMON /S_DEBUG/ NCALL, NDEBUG, LUN INTEGER NCALL, NDEBUG, LUN INTEGER I,MODE SAVE C----------------------------------------------------------------------- IF ( DEBUG ) THEN WRITE(MDEBUG,*) 'SIBINI:',MODE ISIBDB = ISDEBUG NDEBUG = ISDEBUG LUN = MDEBUG ELSE ISIBDB = 0 NDEBUG = 0 LUN = MDEBUG ENDIF C MODEL SWITCHES ICSPP = 0 ICSPA = 0 ICSAA = 0 IMPPL = 0 IMPPH = 0 IF ( MODE .EQ. 1 ) THEN CALL SIBYLL_INI #if !__CHARM__ CALL NO_CHARM #endif IF ( NFRAGM .EQ. 0 ) THEN WRITE(MONIOU,*) 'SIBINI: NUCLEUS PROJECTILES DESINTEGRATE', * ' COMPLETELY IN THE FIRST INTERACTION' ELSEIF ( NFRAGM .EQ. 1 ) THEN WRITE(MONIOU,*) 'SIBINI: NUCLEUS PROJECTILES REMAIN ONE ', * 'FRAGMENT IN THE FIRST INTERACTION' ELSEIF ( NFRAGM .GE. 2 ) THEN NFRAGM = 2 WRITE(MONIOU,*) 'SIBINI: NUCLEUS PROJECTILES FRAGMENT ', * 'REALISTICALLY IN THE FIRST INTERACTION ', * ' WITH PT = 0.' ENDIF ELSEIF ( MODE .EQ. 2 ) THEN CALL SIBYLL_INI #if !__CHARM__ CALL NO_CHARM #endif WRITE(MONIOU,110) 110 FORMAT(' ','====================================================', * /,' ','| |', * /,' ','| ONLY SIBYLL CROSS-SECTIONS ARE USED |', * /,' ','| |', * /,' ','====================================================', * /) C CROSS-SECTIONS FOR NUCLEUS-NUCLEUS AND HADRON-NUCLEUS INTERACTION CALL SIGMA_INI CALL NUC_NUC_INI ELSEIF ( MODE .EQ. 3 ) THEN CALL SIBYLL_INI #if !__CHARM__ CALL NO_CHARM #endif WRITE(MONIOU,120) 120 FORMAT(' ','====================================================', * /,' ','| |', * /,' ','| ALSO SIBYLL CROSS-SECTIONS ARE USED |', * /,' ','| |', * /,' ','====================================================', * /) C CROSS-SECTIONS FOR NUCLEUS-NUCLEUS AND HADRON-NUCLEUS INTERACTION c CALL SIGMA_INI CALL NUC_NUC_INI IF ( NFRAGM .EQ. 0 ) THEN WRITE(MONIOU,*) 'SIBINI: NUCLEUS PROJECTILES DESINTEGRATE', * ' COMPLETELY IN THE FIRST INTERACTION' ELSEIF ( NFRAGM .EQ. 1 ) THEN WRITE(MONIOU,*) 'SIBINI: NUCLEUS PROJECTILES REMAIN ONE ', * 'FRAGMENT IN THE FIRST INTERACTION' ELSEIF ( NFRAGM .GE. 2 ) THEN NFRAGM = 2 WRITE(MONIOU,*) 'SIBINI: NUCLEUS PROJECTILES FRAGMENT ', * 'REALISTICALLY IN THE FIRST INTERACTION ', * ' WITH PT = 0.' ENDIF ENDIF C MODIFY DECAY TABLE TO KEEP PARTICLES, WHICH ARE KNOWN TO CORSIKA C KEEP MUONS, PIONS, KAONS DO I = 4, 12 IDB(I) = -ABS(IDB(I)) ENDDO C KEEP ETA IDB(23) = -ABS(IDB(23)) #if !__INTTEST__ C KEEP RHO MESONS DO I = 25, 27 IDB(I) = -ABS(IDB(I)) ENDDO C KEEP K* RESONANCES DO I = 28, 31 IDB(I) = -ABS(IDB(I)) ENDDO C KEEP OMEGA RESONANCE IDB(32) = -ABS(IDB(32)) C KEEP STRANGE BARYONS (SIGMA, XI, LAMBDA) DO I = 34, 39 IDB(I) = -ABS(IDB(I)) ENDDO C KEEP DELTA-RESONANCES DO I = 40, 43 IDB(I) = -ABS(IDB(I)) ENDDO C KEEP OMEGA- BARYON IDB(49) = -ABS(IDB(49)) #endif #if __CHARM__ || __TAULEP__ C KEEP CHARMED MESONS IDB(59) = -ABS(IDB(59)) IDB(60) = -ABS(IDB(60)) DO I = 71, 81 IDB(I) = -ABS(IDB(I)) ENDDO C KEPP J/PSI IDB(83) = -ABS(IDB(83)) C KEEP CHARMED BARYONS DO I = 84, 89 IDB(I) = -ABS(IDB(I)) ENDDO DO I = 94, 96 IDB(I) = -ABS(IDB(I)) ENDDO IDB(99) = -ABS(IDB(99)) C KEEP TAU LEPTONS AND TAU NEUTRINOS DO I = 90, 93 IDB(I) = -ABS(IDB(I)) ENDDO C ALL OTHER INSTABLE PARTICLES SHOULD DECAY IN SIBYLL AS THEY ARE C NOT TREATED BY CORSIKA #else C CHARMED MESONS, CHARMED BARYONS, TAU LEPTONS, AND TAU NEUTRINOS C ARE SET UNSTABLE IN SIBYLL BY DEFAULT AND DECAY WITHIN SIBYLL #endif C REPLACE SIBYLL MASSES BY CORSIKA MASSES TO AVOID ROUNDING PROBLEMS c DO I = 1, 96 c IF ( ISTABL(I) .NE. 0 ) THEN c AM(I) = PAMA( ISTABL(I) ) c AM2(I) = AM(I)**2 c ENDIF c ENDDO c IF ( ISTABL(99) .NE. 0 ) THEN c AM(99) = PAMA( ISTABL(99) ) c AM2(99) = AM(99)**2 c ENDIF C PRINT SIBYLL PARTICLE LIST IF ( NDEBUG .GT. 1 ) THEN CALL SIB_PARTPR(MDEBUG) CALL DECPR(MDEBUG) ENDIF C PRINT PARAMETERS AND MODEL SWITCHES USED IN PRESENT SIBYLL VERSION IF ( NDEBUG .GT. 3 ) CALL PARAM_PRINT(MDEBUG) C DIFFRACTIVE AND NON-DIFFRACTIVE EVENTS MIXED LDIFF = 0 #if __INTTEST__ IF ( NDIF .EQ. 0 ) THEN C ALL EVENTS MIXED LDIFF = 0 ELSEIF ( NDIF .EQ. 1 ) THEN C ONLY NON-DIFFRACTIVE EVENTS LDIFF = -1 ELSEIF ( NDIF .EQ. 2 ) THEN C ONLY DIFFRACTIVE EVENTS LDIFF = 2 WRITE(MONIOU,*)'"DIFFRACTION INTERACTIONS ONLY" IS NOT POSSIBLE' * ,' WITH SIBYLL' WRITE(MONIOU,*) 'FORWARD DIFFRACTIVE INTERACTIONS ONLY ARE ', * 'SIMULATED' WRITE(MONIOU,*) '==========================================', * '=========' ENDIF #endif RETURN END *-- Author : D. HECK IK FZK KARLSRUHE 06/12/1995 C======================================================================= SUBROUTINE SIBLNK C----------------------------------------------------------------------- C SIB(YLL) L(I)NK (TO CORSIKA) C C LINKS SIBYLL PROGRAM PACKAGE TO CORSIKA, NEEDS FIRST CALL OF C SIBINI. C UPDATED FOR SIBYLL-2.3 Sept. 2015 by D. Heck C THIS SUBROUTINE IS CALLED FROM SDPM. C----------------------------------------------------------------------- IMPLICIT NONE #define __DPMFLGINC__ #define __INTERINC__ #define __PAMINC__ #define __PARPARINC__ #define __PARPAEINC__ #define __RANDPAINC__ #define __RESTINC__ #define __RUNPARINC__ #define __SIBDBGINC__ #define __SIBLININC__ #define __VKININC__ #if __INTTEST__ #define __TSTINTINC__ #endif #include "corsika.h" COMMON /S_CLDIF/ LDIFF INTEGER LDIFF COMMON /S_MASS1/ AM(99), AM2(99) DOUBLE PRECISION AM, AM2 INTEGER LLIST,NP, NP_MAX PARAMETER (NP_max=8000) COMMON /S_PLIST/ P(NP_max,5), LLIST(NP_max), NP DOUBLE PRECISION P COMMON /S_PLNUC/ PA(5,40000), LLA(40000), NPA DOUBLE PRECISION PA INTEGER LLA,NPA COMMON /S_DEBUG/ NCALL, NDEBUG, LUN INTEGER NCALL, NDEBUG, LUN DOUBLE PRECISION ENUC DOUBLE PRECISION SQS INTEGER I,IAB,IATAR,IRAND(3),J,LO SAVE C----------------------------------------------------------------------- IF ( DEBUG ) THEN WRITE(MDEBUG,*) 'SIBLNK: TAR=',SNGL(TAR) ISIBDB = ISDEBUG NDEBUG = ISDEBUG ELSE ISIBDB = 0 NDEBUG = 0 ENDIF C SELECT THE TARGET IATAR = INT( TAR ) #if __INTTEST__ IF ( IATAR .GT. 20 ) IATAR = 20 INTTAR = IATAR #endif C IN DOUBT SET TARGET TO AIR IF ( TAR .GT. 20.D0 ) IATAR = 0 IF ( IATAR .EQ. 99 ) IATAR = 0 #if __INTTEST__ C NEUTRON TARGET IF ( IATAR .EQ. 2 ) IATAR = 1 #endif C RESET COUNTER OF SECONDARIES NP = 0 NPA = 0 IF ( ITYPE .LT. 200 ) THEN C CONVERT CORSIKA PARTICLE CODE INTO SIBYLL PARTICLE CODE LO = ICTABL(ITYPE) IF ( LO .EQ. 0 ) THEN #if __THIN__ WRITE(MONIOU,444) (CURPAR(I),I=0,9),CURPAR(13) 444 FORMAT(' SIBLNK: CURPAR=',1P,11E11.3) #else WRITE(MONIOU,444) (CURPAR(I),I=0,9) 444 FORMAT(' SIBLNK: CURPAR=',1P,10E11.3) #endif WRITE(MONIOU,*) 'SIBLNK: UNKNOWN CORSIKA PARTICLE TYPE=',ITYPE STOP ENDIF C CONVERT ELAB INTO SQRT(S), TARGETMASS=MEAN OF PROTON AND NEUTRON MASS IF ( ITYPE .NE. 1 ) THEN C NORMAL PROJECTILE ELAB = CURPAR(1) * PAMA(ITYPE) ECM = SQRT( (PAMA(ITYPE)+PAMA(14))**2 + 2.D0*AM(13)*ELAB ) IF ( ITYPE .EQ. 7 .OR. ITYPE .EQ. 17 .OR. * (ITYPE .GE. 71 .AND. ITYPE .LE. 74) ) THEN C PI(0) AND ETA PROJECTLE: TAKE RHO(0) INSTEAD ITYPE = 51 LO = 27 ENDIF #if __INTTEST__ C SET DIFFRACTION FLAG ACCORDING WITH SELECTION NDIF IF ( NDIF .EQ. 0 ) THEN LDIFF = 0 ELSEIF ( NDIF .EQ. 1 ) THEN LDIFF = -1 ELSEIF ( NDIF .EQ. 2 ) THEN LDIFF = 2 ENDIF #else LDIFF = 0 #endif ELSE C GAMMA PROJECTILE: TAKE RHO(0) INSTEAD ITYPE = 51 LO = 27 ELAB = CURPAR(1) ECM = SQRT( AM2(13) + 2.D0*AM(13)*ELAB ) C DISABLE DIFFRACTION LDIFF = -1 ENDIF GCM = ( ELAB + 0.5D0*(PAMA(13)+PAMA(14)) )/ ECM BETACM = SQRT( (GCM-1.D0)*(GCM+1.D0) ) / GCM SQS = ECM IF ( DEBUG ) WRITE(MDEBUG,*) * 'SIBLNK: SIBYLLTYP=',LO,' IATAR=',IATAR,' SQS=',SQS IF ( SQS .LE. 10.D0 ) THEN #if __THIN__ WRITE(MONIOU,444) (CURPAR(I),I=0,9),CURPAR(13) #else WRITE(MONIOU,444) (CURPAR(I),I=0,9) #endif WRITE(MONIOU,*)'SIBLNK: ENERGY(CM)=',SQS,' TOO LOW FOR SIBYLL' STOP ENDIF IF ( DEBUG ) THEN C RANDOM GENERATOR STATUS (SEQUENCE L=1) AT BEGINNING OF EVENT CALL RMMAQD( ISEED(1,1),1,'R' ) IRAND(1) = ISEED(1,1) C NUMBER OF CALLS IRAND(2) = ISEED(2,1) C NUMBER OF BILLIONS IRAND(3) = ISEED(3,1) WRITE(MDEBUG,158) (IRAND(J),J=1,3) 158 FORMAT(' SIBLNK: RANDOM NUMBER GENERATOR AT BEGIN:' * ,' SEQUENCE= 1 SEED= ',I9,' CALLS=',I9, * ' BILLIONS=',I9) WRITE(MDEBUG,*) 'SIBLNK: NOW SIBYLL IS CALLED' ENDIF C NOW SIBYLL IS CALLED TO PERFORM THE INTERACTION CALL SIBYLL( LO,IATAR,SQS ) C WRITE SIBYLL OUTPUT IN CASE OF DEBUG IF ( DEBUG ) THEN WRITE(MDEBUG,*) 'SIBLNK: SIBYLL PARTICLES BEFORE DECAY' CALL SIB_LIST( MDEBUG ) ENDIF C ALL PARTICLES NOT KNOWN TO CORSIKA HAVE TO DECAY C THESE ARE MESONS: OMEGA, ETA*; BARYONS: DELTA_RESONANCES C THE DECAYS ARE HANDLED BY DECSIB CALL DECSIB ELSE C PROJECTILE IS NUCLEUS TO BE TREATED BY SUPERPOSITION C MASS NUMBER OF PROJECTILE IS IAB IAB = ITYPE/100 C MASS NUMBER OF TARGET IS IATAR ELAB = GAMMA * PAMA(ITYPE) C CALCULATE CM ENERGY FOR NUCLEON-NUCLEON SYSTEM C MASS OF PROJECTILE AND TARGET NUCLEON IS AVERAGE NUCLEON MASS ENUC = GAMMA * 0.5D0 *(PAMA(13)+PAMA(14)) ECM = SQRT( (PAMA(13)+PAMA(14))**2 + (PAMA(13)+PAMA(14))*ENUC ) GCM = ( ENUC + 0.5D0*(PAMA(13)+PAMA(14)) )/ ECM BETACM = SQRT( (GCM-1.D0)*(GCM+1.D0) ) / GCM SQS = ECM IF ( DEBUG ) WRITE(MDEBUG,*) * 'SIBLNK: SIBYLLTYP=',IAB,' IATAR=',IATAR,' SQS=',SQS IF ( SQS .LE. 8.D0 ) THEN #if __THIN__ WRITE(MONIOU,444) (CURPAR(I),I=0,9),CURPAR(13) #else WRITE(MONIOU,444) (CURPAR(I),I=0,9) #endif WRITE(MONIOU,*)'SIBLNK: ENERGY(CM)=',SQS,' TOO LOW FOR SIBYLL' STOP ENDIF IF ( DEBUG ) THEN C RANDOM GENERATOR STATUS (SEQUENCE L=1) AT BEGINNING OF EVENT CALL RMMAQD( ISEED(1,1),1,'R' ) IRAND(1) = ISEED(1,1) C NUMBER OF CALLS IRAND(2) = ISEED(2,1) C NUMBER OF BILLIONS IRAND(3) = ISEED(3,1) WRITE(MDEBUG,159) (IRAND(J),J=1,3) 159 FORMAT(' SIBLNK: RANDOM NUMBER GENERATOR AT BEGIN:' * ,' SEQUENCE= 1 SEED= ',I9,' CALLS=',I9, * ' BILLIONS=',I9) WRITE(MDEBUG,*) 'SIBLNK: NOW SIBNUC IS CALLED' ENDIF #if __INTTEST__ C SET DIFFRACTION FLAG ACCORDING WITH SELECTION NDIF IF ( NDIF .EQ. 0 ) THEN LDIFF = 0 ELSEIF ( NDIF .EQ. 1 ) THEN LDIFF = -1 ELSEIF ( NDIF .EQ. 2 ) THEN LDIFF = 2 ENDIF #else LDIFF = 0 #endif C NOW SIBYLL IS CALLED TO PERFORM NUCLEUS INTERACTIONS BY SIBNUC CALL SIBNUC( IAB,IATAR,SQS ) C ALL PARTICLES NOT KNOWN TO CORSIKA HAVE TO DECAY C THIS IS DONE IN ROUTINE DECSIB CALLED BY SIBNUC BEFORE EXITING ENDIF C C WRITE SIBYLL OUTPUT IN CASE OF DEBUG IF ( DEBUG ) THEN WRITE(MDEBUG,*) 'SIBLNK: SIBYLL PARTICLES AFTER DECAY' CALL SIB_LIST( MDEBUG ) ENDIF C STORE GENERATED PARTICLES AND SPECTATORS TO CORSIKA STACK CALL SIBSTR RETURN END *-- Author : D. HECK IK FZK KARLSRUHE 12/12/1995 C======================================================================= SUBROUTINE SIBSIG( ELAB,KK ) C----------------------------------------------------------------------- C SIB(YLL) SIG(MA) C C CALCULATES INELASTIC CROSS-SECTIONS FOR HADRON-AIR COLLISIONS C FOR NUCLEUS-AIR INTERACTIONS THE TOTAL CROSS-SECTION IS TAKEN C FROM SUBROUT. SIGNUC_INI2. C SELECTS CROSS-SECTION FROM QCD-CALCULATION C UPDATED FOR SIBYLL-2.3 Sept. 2015 by D. Heck C THIS SUBROUTINE IS CALLED FROM BOX2. C ARGUMENTS: C ELAB = LABORATORY ENERGY (GEV) C KK = 1 FOR NUCLEONS, 2 FOR PION, 3 FOR KAON, >3 FOR NUCLEI C----------------------------------------------------------------------- IMPLICIT NONE #define __PAMINC__ #define __PARPARINC__ #define __PARPAEINC__ #define __RUNPARINC__ #define __SIBDBGINC__ #define __SIBLININC__ #define __SIGMINC__ #include "corsika.h" INTEGER NS_max,NH_max PARAMETER (NS_max = 20, NH_max = 80) COMMON /S_CCSIG/ SSIG,PJETC,SSIGN,SSIGNSD,ALINT,ASQSMIN,ASQSMAX, * DASQS,NSQS DOUBLE PRECISION SSIG(61,3),PJETC(0:NS_max,0:NH_max,61,2), * SSIGN(61,3),SSIGNSD(61,3),ALINT(61,3),ASQSMIN, * ASQSMAX,DASQS INTEGER NSQS COMMON /CSAIR/ ASQSMIN1, ASQSMAX1, DASQS1, * SSIG01(61,3),SSIGA1(61,3),ALINT1(61,3),NSQS1 DOUBLE PRECISION ASQSMIN1,ASQSMAX1,DASQS1,SSIG01,SSIGA1,ALINT1 INTEGER NSQS1 COMMON /S_DEBUG/ NCALL, NDEBUG, LUN INTEGER NCALL, NDEBUG, LUN DOUBLE PRECISION ECM0,ELAB,SIGBDIF DOUBLE PRECISION SSIG0(41,2),AL,E0,SIGINEL,SQS,SSIGNUC,TT INTEGER IA,J,J1,KK SAVE C----------------------------------------------------------------------- IF ( DEBUG ) THEN WRITE(MDEBUG,*) 'SIBSIG: ELAB=',SNGL(ELAB),' KK=',KK ISIBDB = ISDEBUG NDEBUG = ISDEBUG ELSE ISIBDB = 0 NDEBUG = 0 ENDIF IF ( KK .LE. 3 ) THEN C FOR HADRON PROJECTILES C ENERGY IN THE LAB AND THE CENTER OF MASS ECM0 = SQRT( ( PAMA(ITYPE) + 0.5D0*(PAMA(13)+PAMA(14)) )**2 * + ELAB * (PAMA(13)+PAMA(14)) ) SQS = ECM0 IF ( DEBUG ) WRITE(MDEBUG,*) 'SIBSIG: SQS=',SQS AL = DLOG10(SQS) J1 = INT((AL - 1.D0)*10.D0) + 1 TT = (AL-1.D0)*10.D0 - DBLE(J1-1) C TAKES CROSS-SECTION FROM SIB_SIGMA_PP AND SIB_SIGMA_PIP CALL SIB_SIGMA_HAIR( KK,SQS,SIGINEL,SIGBDIF) SIGAIR = SIGINEL C FROM SIB_SIGMA_PP AND SIB_SIGMA_PIP SIGMA = SSIG(J1,KK)*(1.-TT) + SSIG(J1+1,KK)*TT ELSE C FOR NUCLEUS PROJECTILES IA = KK/100 C ELAB IS ENERGY PER NUCLEON IN GEV E0 = ELAB IF ( DEBUG ) WRITE(MDEBUG,*) 'SIBSIG: E0=',E0 CALL SIGNUC_INI2( IA,E0,SSIGNUC ) SIGAIR = SSIGNUC ECM0 = SQRT( (PAMA(13)+PAMA(14))**2 + E0 * (PAMA(13)+PAMA(14)) ) SQS = ECM0 IF ( DEBUG ) WRITE(MDEBUG,*) 'SIBSIG: SQS=',SQS AL = DLOG10(SQS) J1 = INT((AL - 1.D0)*10.D0) + 1 TT = (AL-1.D0)*10.D0 - DBLE(J1-1) C FROM SIB_SIGMA_PP SIGMA = SSIG(J1,1)*(1.-TT) + SSIG(J1+1,1)*TT ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) 'SIBSIG: SIGMA, SIGAIR=', * SNGL(SIGMA),SNGL(SIGAIR) RETURN END *-- Author : D. HECK IK FZK KARLSRUHE 06/12/1995 C======================================================================= SUBROUTINE SIBSTR C----------------------------------------------------------------------- C SIB(YLL RESULTS) ST(O)R(E) C C STORE SIBYLL RESULTS TO CORSIKA STACK, NEEDS FIRST CALL OF SIBINI. C UPDATED FOR SIBYLL-2.3 Sept. 2015 by D. Heck C THIS SUBROUTINE IS CALLED FROM SIBLNK. C----------------------------------------------------------------------- IMPLICIT NONE #define __DPMFLGINC__ #define __ELADPMINC__ #define __ELASTYINC__ #define __INTERINC__ #define __ISTAINC__ #define __LONGIINC__ #define __MULTINC__ #define __PAMINC__ #define __PARPARINC__ #define __PARPAEINC__ #define __RANDPAINC__ #define __RESTINC__ #define __RUNPARINC__ #define __SIBLININC__ #define __SIBYLCINC__ #define __SIGMINC__ #define __VKININC__ #if __AUGERHIST__ || __EHISTORY__ #define __GENERINC__ #endif #if __AUGERHIST__ || __COASTUSERLIB__ #define __OBSPARINC__ #endif #if __INTTEST__ #define __TSTINTINC__ #endif #include "corsika.h" COMMON /S_PLIST/ P(8000,5), LLIST(8000), NP DOUBLE PRECISION P INTEGER LLIST,NP COMMON /S_PLNUC/ PA(5,40000), LLA(40000), NPA DOUBLE PRECISION PA INTEGER LLA,NPA INTEGER NW_max PARAMETER (NW_max = 20) COMMON /S_CHIST/ NNSOF(NW_max),NNJET(NW_max), & JDIF(NW_max),NWD,NJET,NSOF INTEGER NNSOF,NNJET,JDIF,NWD,NJET,NSOF DOUBLE PRECISION COSTHJ,CPHIJ,ELASTI,EMAX,ESIBCM,ETOT DOUBLE PRECISION FAC1,FAC2 DOUBLE PRECISION PLONGLAB,PTOTLAB,SPHIJ INTEGER ITYPJ,IZNEW,J,L,LJ,MEL,MEN,LL #if !__INTTEST__ INTEGER IWOUNT #else INTEGER I #endif #if __EHISTORY__ INTEGER IK #endif #if __COASTUSERLIB__ c definition of the COAST crs::CInteraction class COMMON/coastInteraction/coastX, coastY, coastZ, & coastE, coastCX, coastEl, coastProjId, coastTargId, & coastT double precision coastX, coastY, coastZ double precision coastE, coastCX, coastEl double precision coastT integer coastProjId, coastTargId #endif SAVE #if __AUGERHIST__ DOUBLE PRECISION EDEP,THICKLOC,THICK INTEGER II,LL EXTERNAL THICK #endif C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'SIBSTR:',NP+NPA,' SECONDARIES' EMAX = 0.D0 ELASTI = 0.D0 ETOT = 0.D0 #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME GRANDMOTHER PARTICLE DO IK = 0, 6 SECPAR(28+IK) = CURPAR(IK) ENDDO C STORE GENERATION COUNTER OF MOTHER SECPAR(35) = GEN C STORE MASS PENETRATION BEFORE INTERACTION SECPAR(36) = CURPAR(9) #if __THIN__ SECPAR(37) = CURPAR(13) #endif #endif IF ( NPA .GT. 0 ) THEN C TREAT ALL SECONDARIES FROM NUCLEUS-NUCLEUS COLLISION C TAKE THE PARTICLES FROM COMMON S_PLNUC DO 90 J = 1, NPA L = MOD(LLA(J),10000) IF ( L .LT. 200 ) THEN C WE HAVE ORDINARY PARTICLE IF ( L .LT. -99 .OR. L .GT. 99 ) THEN WRITE(MONIOU,*) 'SIBSTR: UNKNOWN PARTICLE NR.',J, * ' WITH SIBYLL CODE =', LLA(J) GOTO 90 ENDIF C SKIP INSTABLE PRECURSERS IF ( LLA(J) .NE. L ) GOTO 90 ITYPJ = ISTABL(L) IF ( ITYPJ .EQ. 0 ) THEN WRITE(MONIOU,*) 'SIBSTR: UNKNOWN PARTICLE NR.',J, * ' WITH SIBYLL CODE =', LLA(J) GOTO 90 ENDIF C CALCULATE GAMMA FACTORS AND EMISSION ANGLES ESIBCM = SQRT( PA(1,J)**2 + PA(2,J)**2 * + PA(3,J)**2 + PA(5,J)**2 ) ctp SECPAR(1) = GCM * ( ESIBCM + DBLE(PA(3,J)) * BETACM ) PLONGLAB = GCM * ( PA(3,J) + ESIBCM * BETACM ) PTOTLAB = SQRT( PA(1,J)**2 + PA(2,J)**2 + PLONGLAB**2 ) CPHIJ = PA(1,J) / PTOTLAB SPHIJ = PA(2,J) / PTOTLAB C RECALCULATE E TO HAVE PARTICLE ON-SHELL WITH CORSIKA MASS C (DIFFERENT MASS IN SIBYLL) SECPAR(1) = SQRT( PTOTLAB**2 + PAMA(ITYPJ)**2 ) ETOT = ETOT + SECPAR(1) IF ( PAMA(ITYPJ) .GT. 0.D0 ) THEN SECPAR(1) = SECPAR(1) / PAMA(ITYPJ) #if !__INTTEST__ C ELIMINATE TARGET SPECTATORS IF ( SECPAR(1) .LE. 1.D0 ) GOTO 90 COSTHJ = MAX( -1.D0, MIN( 1.D0, PLONGLAB / PTOTLAB ) ) #else IF ( SECPAR(1) .LE. 1.D0 ) THEN SECPAR(1) = 1.D0 COSTHJ = 1.D0 ELSE COSTHJ = MAX( -1.D0, MIN( 1.D0, PLONGLAB / PTOTLAB ) ) ENDIF #endif ELSE COSTHJ = MAX( -1.D0, MIN( 1.D0, PLONGLAB / PTOTLAB ) ) ENDIF #if __INTTEST__ C IF ( COSTHJ .EQ. 0.D0 ) COSTHJ = 1.D-4 SECPAR(17) = SQRT( PA(2,J)**2 + PA(1,J)**2 ) #endif IF ( (ITYPJ .NE. 1 .AND. ITYPJ .LE. 65) .OR. * (ITYPJ .GE. 116 .AND. ITYPJ .LE. 132) .OR. * (ITYPJ .GE. 137 .AND. ITYPJ .LE. 173) ) THEN IF ( SECPAR(1)*PAMA(ITYPJ) .GT. EMAX ) THEN EMAX = SECPAR(1)*PAMA(ITYPJ) C CALCULATE ELASTICITY FROM MOST ENERGETIC PARTICLE (LEADER) ELASTI = (EMAX/ELAB) * DBLE(ITYPE/100) ENDIF ENDIF C COUNTER FOR ENERGY-MULTIPLICITY MATRIX MSMM = MSMM + 1 SECPAR(0) = ITYPJ CALL ADDANG4( COSTHE,PHIX,PHIY, COSTHJ,CPHIJ,SPHIJ, * SECPAR(2),SECPAR(3),SECPAR(4) ) C STORE ONLY PARTICLES ABOVE ANGULAR CUT TO THE CORSIKA STACK #if __UPWARD__ IF ( SECPAR(2) .GE. -1.D0 ) THEN #else IF ( SECPAR(2) .GT. C(29) ) THEN #endif #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER PARTICLE DO IK = 0, 8 SECPAR(17+IK) = SECPAR(IK) ENDDO #if __THIN__ SECPAR(26) = SECPAR(13) #endif #endif CALL TSTACK ELSE IF ( LLONGI ) THEN C ADD ENERGY OF CUTTED PARTCLE TO LONGITUDINAL ENERGY DEPOSIT IF ( ITYPJ .EQ. 1 ) THEN #if __THIN__ DLONG(LHEIGH,11) = DLONG(LHEIGH,11)+SECPAR(1)*WEIGHT ELSEIF ( ITYPJ .EQ. 2 ) THEN DLONG(LHEIGH,13) = DLONG(LHEIGH,13) * + (SECPAR(1)+1.D0)*PAMA(2)*WEIGHT ELSEIF ( ITYPJ .EQ. 3 ) THEN DLONG(LHEIGH,13) = DLONG(LHEIGH,13) * + (SECPAR(1)-1.D0)*PAMA(2)*WEIGHT ELSEIF ( ITYPJ .EQ. 5 .OR. ITYPJ .EQ. 6 ) THEN DLONG(LHEIGH,15) = DLONG(LHEIGH,15) * + SECPAR(1)*PAMA(5) * WEIGHT ELSE IF ( ITYPJ .EQ. 8 .OR. ITYPJ .EQ. 9 .OR. * ITYPJ .EQ. 11 .OR. ITYPJ .EQ. 12 ) THEN FAC1 = 0.25D0 FAC2 = 0.75D0 ELSEIF ( ITYPJ .EQ. 10 .OR. ITYPJ .EQ. 16 ) THEN FAC1 = 0.5D0 FAC2 = 0.5D0 ELSE FAC1 = 1.D0 FAC2 = 0.D0 ENDIF C ADD TO THE HADRON ENERGY DEPOSIT DLONG(LHEIGH,17) = DLONG(LHEIGH,17) + ( SECPAR(1) * * PAMA(ITYPJ)-RESTMS(ITYPJ) )*WEIGHT*FAC1 C ADD TO THE NEUTRINO DEPOSIT DLONG(LHEIGH,18) = DLONG(LHEIGH,18) + ( SECPAR(1) * * PAMA(ITYPJ)-RESTMS(ITYPJ) )*WEIGHT*FAC2 #else DLONG(LHEIGH,11) = DLONG(LHEIGH,11) + SECPAR(1) ELSEIF ( ITYPJ .EQ. 2 ) THEN DLONG(LHEIGH,13) = DLONG(LHEIGH,13) * + (SECPAR(1)+1.D0) * PAMA(2) ELSEIF ( ITYPJ .EQ. 3 ) THEN DLONG(LHEIGH,13) = DLONG(LHEIGH,13) * + (SECPAR(1)-1.D0) * PAMA(2) ELSEIF ( ITYPJ .EQ. 5 .OR. ITYPJ .EQ. 6 ) THEN DLONG(LHEIGH,15) = DLONG(LHEIGH,15)+SECPAR(1)*PAMA(5) ELSE IF ( ITYPJ .EQ. 8 .OR. ITYPJ .EQ. 9 .OR. * ITYPJ .EQ. 11 .OR. ITYPJ .EQ. 12 ) THEN FAC1 = 0.25D0 FAC2 = 0.75D0 ELSEIF ( ITYPJ .EQ. 10 .OR. ITYPJ .EQ. 16 ) THEN FAC1 = 0.5D0 FAC2 = 0.5D0 ELSE FAC1 = 1.D0 FAC2 = 0.D0 ENDIF C ADD TO THE HADRON ENERGY DEPOSIT DLONG(LHEIGH,17) = DLONG(LHEIGH,17) + ( SECPAR(1) * * PAMA(ITYPJ)-RESTMS(ITYPJ) )*FAC1 C ADD TO THE NEUTRINO DEPOSIT DLONG(LHEIGH,18) = DLONG(LHEIGH,18) + ( SECPAR(1) * * PAMA(ITYPJ)-RESTMS(ITYPJ) )*FAC2 #endif ENDIF ENDIF #if __AUGERHIST__ THICKLOC = THICK( H ) DO LL = 1, NOBSLV IF ( THICKLOC .GE. THCKOB(LL) .AND. * THICKLOC .LT. THCKOB(LL)+SAMPTH ) THEN C THICKH IS WITHIN 1 G/CM^2 BELOW OBSLEV(LL) C BRING THE ENERGY BELOW ANGULAR CUT TO THE HISTO OF LEVEL LL DO II = 0, 8 OUTPAR(II) = SECPAR(II) ENDDO OUTPAR( 9) = GEN OUTPAR(10) = ALEVEL OUTPAR(13) = WEIGHT IF ( ITYPJ .EQ. 1 ) THEN EDEP = OUTPAR(1) * WEIGHT ELSE EDEP = ( OUTPAR(1) * PAMA(ITYPJ) * - RESTMS(ITYPJ) ) * WEIGHT ENDIF IF ( ITYPJ .EQ. 2. .OR. ITYPJ .EQ. 3 ) * OUTPAR(1) = OUTPAR(1) * PAMA(2) C WE HAVE ANGULAR CUT CALL AUGERDEPFIL( EDEP,LL,1 ) ELSEIF ( THICKLOC .LT. THCKOB(LL) ) THEN GOTO 111 ENDIF ENDDO 111 CONTINUE #endif ENDIF C END OF ORDINARY PARTICLE TRTEATMENT ELSE C PARTICLE IS SPECTATOR NUCLEUS. FIND NUCLEUS CLOSE TO STABILITY LINE LJ = LLA(J) - 1000 IZNEW = INT( DBLE(LJ)/2.15D0 +0.7D0 ) SECPAR(1) = CURPAR(1) SECPAR(2) = CURPAR(2) SECPAR(3) = CURPAR(3) SECPAR(4) = CURPAR(4) #if __INTTEST__ SECPAR(17) = CURPAR(17) #endif IF ( FSIBSG ) THEN IF ( LJ .EQ. 1 ) THEN C SPECATOR IS SINGLE NUCLEON, WHICH CANNOT BE TREATED IN BOX2+SIBSIG CALL RMMARD( RD,1,0 ) IF ( RD(1) .GT. 0.5D0 ) THEN SECPAR(0) = 13.D0 ELSE SECPAR(0) = 14.D0 ENDIF ELSE C ALL OTHER SPECTATOR FRAGMENTS CAN BE TREATED BY BOX2+SIBSIG SECPAR(0) = DBLE(LJ*100 + IZNEW) ENDIF #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER PARTICLE DO IK = 0, 8 SECPAR(17+IK) = SECPAR(IK) ENDDO #if __THIN__ SECPAR(26) = SECPAR(13) #endif #endif CALL TSTACK ETOT = ETOT + GAMMA * PAMA(NINT( SECPAR(0) )) ELSE IF ( LJ .EQ. 8 ) THEN C SPECTATOR FRAGMENT WITH MASS 8 CANNOT BE TREATED IN BOX2 C DECAY INTO 2 ALPHA PARTICLES SECPAR(0) = 402.D0 #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER PARTICLE DO IK = 0, 8 SECPAR(17+IK) = SECPAR(IK) ENDDO #if __THIN__ SECPAR(26) = SECPAR(13) #endif #endif CALL TSTACK CALL TSTACK ETOT = ETOT + 2.D0 * GAMMA * PAMA(402) ELSEIF ( LJ .EQ. 5 ) THEN C SPECTATOR FRAGMENT WITH MASS 5 CANNOT BE TREATED IN BOX2 C DECAY INTO 1 ALPHA PARTICLE AND 1 NUCLEON IF ( IZNEW .LE. 2 ) THEN C DECAY INTO 1 ALPHA PARTICLE AND 1 NEUTRON SECPAR(0) = 402.D0 #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER PARTICLE DO IK = 0, 8 SECPAR(17+IK) = SECPAR(IK) ENDDO #if __THIN__ SECPAR(26) = SECPAR(13) #endif #endif CALL TSTACK ETOT = ETOT + GAMMA * PAMA(402) SECPAR(0) = 13.D0 #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER PARTICLE DO IK = 0, 8 SECPAR(17+IK) = SECPAR(IK) ENDDO #if __THIN__ SECPAR(26) = SECPAR(13) #endif #endif CALL TSTACK ETOT = ETOT + GAMMA * PAMA(13) ELSE C DECAY INTO 1 ALPHA PARTICLE AND 1 PROTON SECPAR(0) = 402.D0 #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER PARTICLE DO IK = 0, 8 SECPAR(17+IK) = SECPAR(IK) ENDDO #if __THIN__ SECPAR(26) = SECPAR(13) #endif #endif CALL TSTACK ETOT = ETOT + GAMMA * PAMA(402) SECPAR(0) = 14.D0 #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER PARTICLE DO IK = 0, 8 SECPAR(17+IK) = SECPAR(IK) ENDDO #if __THIN__ SECPAR(26) = SECPAR(13) #endif #endif CALL TSTACK ETOT = ETOT + GAMMA * PAMA(14) ENDIF ELSEIF ( LJ .EQ. 1 ) THEN C SPECATOR IS SINGLE NUCLEON CALL RMMARD( RD,1,0 ) IF ( RD(1) .GT. 0.5D0 ) THEN SECPAR(0) = 13.D0 ELSE SECPAR(0) = 14.D0 ENDIF #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER PARTICLE DO IK = 0, 8 SECPAR(17+IK) = SECPAR(IK) ENDDO #if __THIN__ SECPAR(26) = SECPAR(13) #endif #endif CALL TSTACK ETOT = ETOT + GAMMA * PAMA(NINT( SECPAR(0) )) ELSE C ALL OTHER SPECTATOR FRAGMENTS CAN BE TREATED IN BOX2 SECPAR(0) = DBLE(LJ*100 + IZNEW) #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER PARTICLE DO IK = 0, 8 SECPAR(17+IK) = SECPAR(IK) ENDDO #if __THIN__ SECPAR(26) = SECPAR(13) #endif #endif CALL TSTACK ETOT = ETOT + GAMMA * PAMA(NINT( SECPAR(0) )) ENDIF ENDIF ENDIF C COUNTERS FOR FIRST INTERACTION IF ( FIRSTI ) THEN IF ( SECPAR(0).EQ. 7.D0 .OR. SECPAR(0).EQ. 8.D0 * .OR. SECPAR(0).EQ. 9.D0 ) THEN IFINPI = IFINPI + 1 ELSEIF ( SECPAR(0).EQ.13.D0 .OR. SECPAR(0).EQ.14.D0 * .OR. SECPAR(0).EQ.15.D0 .OR. SECPAR(0).EQ.25.D0 ) THEN IFINNU = IFINNU + 1 ELSEIF ( SECPAR(0).EQ.10.D0 .OR. SECPAR(0).EQ.11.D0 * .OR. SECPAR(0).EQ.12.D0 .OR. SECPAR(0).EQ.16.D0 ) THEN IFINKA = IFINKA + 1 ELSEIF ( SECPAR(0).EQ.17.D0 ) THEN IFINET = IFINET + 1 ELSEIF ((SECPAR(0).GE.18.D0 .AND. SECPAR(0).LE.24.D0) * .OR. (SECPAR(0).GE.26.D0 .AND. SECPAR(0).LE.32.D0)) THEN IFINHY = IFINHY + 1 ELSEIF ( SECPAR(0).GE.51.D0 .AND. SECPAR(0).LE.53.D0 ) THEN IFINRHO = IFINRHO + 1 ELSEIF ((SECPAR(0).GE.116.D0 .AND. SECPAR(0).LE.130.D0) * .OR. (SECPAR(0).GE.137.D0 .AND. SECPAR(0).LE.173.D0))THEN IFINCM = IFINCM + 1 ELSE IFINOT = IFINOT + 1 ENDIF ENDIF 90 CONTINUE C INTERACTING TARGET NUCLEONS NOT DEFINED IN SUPERPOSIOTION MODEL IWOUNT = 0 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ELSE C TREAT SECONDARY PARTICLES FROM HADRON NUCLEUS COLLISION C TAKE THE PARTICLES FROM COMMON S_PLIST DO 100 J = 1, NP L = MOD(LLIST(J),10000) IF ( L .LT. -99 .OR. L .GT. 99 ) THEN WRITE(MONIOU,*) 'SIBSTR: UNKNOWN PARTICLE NR.',J, * ' WITH SIBYLL CODE =', LLIST(J) GOTO 100 ENDIF C SKIP INSTABLE PRECURSERS IF ( LLIST(J) .NE. L ) GOTO 100 ITYPJ = ISTABL(L) IF ( ITYPJ .EQ. 0 ) THEN WRITE(MONIOU,*) 'SIBSTR: UNKNOWN PARTICLE NR.',J, * ' WITH SIBYLL CODE =', LLIST(J) GOTO 100 ENDIF C CALCULATE THE EMISSION ANGLES AND GAMMA FACTORS ESIBCM = SQRT( P(J,1)**2 + P(J,2)**2 * + P(J,3)**2 + P(J,5)**2 ) ctp SECPAR(1) = GCM * ( ESIBCM + P(J,3) * BETACM ) PLONGLAB = GCM * ( P(J,3) + ESIBCM * BETACM ) PTOTLAB = SQRT( P(J,1)**2 + P(J,2)**2 + PLONGLAB**2 ) CPHIJ = P(J,1) / PTOTLAB SPHIJ = P(J,2) / PTOTLAB C RECALCULATE E TO HAVE PARTICLE ON-SHELL WITH CORSIKA MASS C (DIFFERENT MASS IN SIBYLL) SECPAR(1) = SQRT( PTOTLAB**2 + PAMA(ITYPJ)**2 ) ETOT = ETOT + SECPAR(1) IF ( PAMA(ITYPJ) .GT. 0.D0 ) THEN SECPAR(1) = SECPAR(1) / PAMA(ITYPJ) #if !__INTTEST__ C ELIMINATE TARGET SPECTATORS IF ( SECPAR(1) .LE. 1.D0 ) GOTO 100 COSTHJ = MAX( -1.D0, MIN( 1.D0, PLONGLAB / PTOTLAB ) ) #else IF ( SECPAR(1) .LE. 1.D0 ) THEN SECPAR(1) = 1.D0 COSTHJ = 1.D0 ELSE COSTHJ = MAX( -1.D0, MIN( 1.D0, PLONGLAB / PTOTLAB ) ) COSTHJ = MAX( -1.D0, COSTHJ) ENDIF #endif ELSE COSTHJ = MAX( -1.D0, MIN( 1.D0, PLONGLAB / PTOTLAB ) ) ENDIF #if __INTTEST__ C IF ( COSTHJ .EQ. 0.D0 ) COSTHJ = 1.D-4 SECPAR(17) = SQRT( P(J,2)**2 + P(J,1)**2 ) #endif IF ( (ITYPJ .NE. 1 .AND. ITYPJ .LE. 65) .OR. * (ITYPJ .GE. 116 .AND. ITYPJ .LE. 132) .OR. * (ITYPJ .GE. 137 .AND. ITYPJ .LE. 173) ) THEN IF ( SECPAR(1)*PAMA(ITYPJ) .GT. EMAX ) THEN EMAX = SECPAR(1)*PAMA(ITYPJ) C CALCULATE ELASTICITY FROM MOST ENERGETIC PARTICLE (LEADER) ELASTI = EMAX / ELAB ENDIF ENDIF C COUNTER FOR ENERGY-MULTIPLICITY MATRIX MSMM = MSMM + 1 SECPAR(0) = ITYPJ CALL ADDANG4( COSTHE,PHIX,PHIY, COSTHJ,CPHIJ,SPHIJ, * SECPAR(2),SECPAR(3),SECPAR(4) ) C STORE ONLY PARTICLES ABOVE ANGULAR CUT TO THE CORSIKA STACK #if __UPWARD__ IF ( SECPAR(2) .GE. -1.D0 ) THEN #else IF ( SECPAR(2) .GT. C(29) ) THEN #endif #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER PARTICLE DO IK = 0, 8 SECPAR(17+IK) = SECPAR(IK) ENDDO #if __THIN__ SECPAR(26) = SECPAR(13) #endif #endif CALL TSTACK ELSE IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT IF ( ITYPJ .EQ. 1 ) THEN #if __THIN__ DLONG(LHEIGH,11) = DLONG(LHEIGH,11) + SECPAR(1)*WEIGHT ELSEIF ( ITYPJ .EQ. 2 ) THEN DLONG(LHEIGH,13) = DLONG(LHEIGH,13) * + (SECPAR(1)+1.D0)*PAMA(2)*WEIGHT ELSEIF ( ITYPJ .EQ. 3 ) THEN DLONG(LHEIGH,13) = DLONG(LHEIGH,13) * + (SECPAR(1)-1.D0)*PAMA(2)*WEIGHT ELSEIF ( ITYPJ .EQ. 5 .OR. ITYPJ .EQ. 6 ) THEN DLONG(LHEIGH,15) = DLONG(LHEIGH,15) * + SECPAR(1)*PAMA(5)*WEIGHT ELSE IF ( ITYPJ .EQ. 8 .OR. ITYPJ .EQ. 9 .OR. * ITYPJ .EQ. 11 .OR. ITYPJ .EQ. 12 ) THEN FAC1 = 0.25D0 FAC2 = 0.75D0 ELSEIF ( ITYPJ .EQ. 10 .OR. ITYPJ .EQ. 16 ) THEN FAC1 = 0.5D0 FAC2 = 0.5D0 ELSE FAC1 = 1.D0 FAC2 = 0.D0 ENDIF C ADD TO THE HADRON ENERGY DEPOSIT DLONG(LHEIGH,17) = DLONG(LHEIGH,17) + ( SECPAR(1) * * PAMA(ITYPJ)-RESTMS(ITYPJ) )*WEIGHT*FAC1 C ADD TO THE NEUTRINO DEPOSIT DLONG(LHEIGH,18) = DLONG(LHEIGH,18) + ( SECPAR(1) * * PAMA(ITYPJ)-RESTMS(ITYPJ) )*WEIGHT*FAC2 #else DLONG(LHEIGH,11) = DLONG(LHEIGH,11) + SECPAR(1) ELSEIF ( ITYPJ .EQ. 2 ) THEN DLONG(LHEIGH,13) = DLONG(LHEIGH,13) * + (SECPAR(1)+1.D0)*PAMA(2) ELSEIF ( ITYPJ .EQ. 3 ) THEN DLONG(LHEIGH,13) = DLONG(LHEIGH,13) * + (SECPAR(1)-1.D0)*PAMA(2) ELSEIF ( ITYPJ .EQ. 5 .OR. ITYPJ .EQ. 6 ) THEN DLONG(LHEIGH,15) = DLONG(LHEIGH,15) * + SECPAR(1) * PAMA(5) ELSE IF ( ITYPJ .EQ. 8 .OR. ITYPJ .EQ. 9 .OR. * ITYPJ .EQ. 11 .OR. ITYPJ .EQ. 12 ) THEN FAC1 = 0.25D0 FAC2 = 0.75D0 ELSEIF ( ITYPJ .EQ. 10 .OR. ITYPJ .EQ. 16 ) THEN FAC1 = 0.5D0 FAC2 = 0.5D0 ELSE FAC1 = 1.D0 FAC2 = 0.D0 ENDIF C ADD TO THE HADRON ENERGY DEPOSIT DLONG(LHEIGH,17) = DLONG(LHEIGH,17) + ( SECPAR(1) * * PAMA(ITYPJ)-RESTMS(ITYPJ) )*FAC1 C ADD TO THE NEUTRINO DEPOSIT DLONG(LHEIGH,18) = DLONG(LHEIGH,18) + ( SECPAR(1) * * PAMA(ITYPJ)-RESTMS(ITYPJ) )*FAC2 #endif ENDIF ENDIF #if __AUGERHIST__ THICKLOC = THICK( H ) DO LL = 1, NOBSLV IF ( THICKLOC .GE. THCKOB(LL) .AND. * THICKLOC .LT. THCKOB(LL)+SAMPTH ) THEN C THICKH IS WITHIN 1 G/CM^2 BELOW OBSLEV(LL) C BRING THE ENERGY BELOW ANGULAR CUT TO THE HISTO OF LEVEL LL DO II = 0, 8 OUTPAR(II) = SECPAR(II) ENDDO OUTPAR( 9) = GEN OUTPAR(10) = ALEVEL OUTPAR(13) = WEIGHT IF ( ITYPJ .EQ. 1 ) THEN EDEP = OUTPAR(1) * WEIGHT ELSE EDEP = ( OUTPAR(1) * PAMA(ITYPJ) * - RESTMS(ITYPJ) ) * WEIGHT ENDIF IF ( ITYPJ .EQ. 2. .OR. ITYPJ .EQ. 3 ) * OUTPAR(1) = OUTPAR(1) * PAMA(2) C WE HAVE ANGULAR CUT CALL AUGERDEPFIL( EDEP,LL,1 ) ELSEIF ( THICKLOC .LT. THCKOB(LL) ) THEN GOTO 112 ENDIF ENDDO 112 CONTINUE #endif ENDIF C COUNTERS FOR FIRST INTERACTION IF ( FIRSTI ) THEN IF ( SECPAR(0).EQ. 7.D0 .OR. SECPAR(0).EQ. 8.D0 * .OR. SECPAR(0).EQ. 9.D0 ) THEN IFINPI = IFINPI + 1 ELSEIF ( SECPAR(0).EQ.13.D0 .OR. SECPAR(0).EQ.14.D0 * .OR. SECPAR(0).EQ.15.D0 .OR. SECPAR(0).EQ.25.D0 ) THEN IFINNU = IFINNU + 1 ELSEIF ( SECPAR(0).EQ.10.D0 .OR. SECPAR(0).EQ.11.D0 * .OR. SECPAR(0).EQ.12.D0 .OR. SECPAR(0).EQ.16.D0 ) THEN IFINKA = IFINKA + 1 ELSEIF ( SECPAR(0).EQ.17.D0 ) THEN IFINET = IFINET + 1 ELSEIF ((SECPAR(0).GE.18.D0 .AND. SECPAR(0).LE.24.D0) * .OR. (SECPAR(0).GE.26.D0 .AND. SECPAR(0).LE.32.D0)) THEN IFINHY = IFINHY + 1 ELSEIF ( SECPAR(0).GE.51.D0 .AND. SECPAR(0).LE.53.D0 ) THEN IFINRHO = IFINRHO + 1 ELSEIF ((SECPAR(0).GE.116.D0 .AND. SECPAR(0).LE.130.D0) * .OR. (SECPAR(0).GE.137.D0 .AND. SECPAR(0).LE.173.D0))THEN IFINCM = IFINCM + 1 ELSE IFINOT = IFINOT + 1 ENDIF ENDIF 100 CONTINUE C INTERACTING TARGET NUCLEONS IWOUNT = NWD ENDIF IF ( DEBUG ) THEN WRITE(MDEBUG,*) 'SIBSTR: ',IWOUNT,' WOUNDED TARGET NUCLEONS' WRITE(MDEBUG,*) 'SIBSTR: ELASTI,ETOT,ELAB=', * SNGL(ELASTI),SNGL(ETOT),SNGL(ELAB) ENDIF C FILL ELASTICITY IN MATRICES MEL = MIN ( 1.D0+10.D0* MAX( 0.D0, ELASTI ) , 11.D0 ) MEN = MIN ( 4.D0+ 3.D0*LOG10(MAX( .1D0, EKINL )), 40.D0 ) #if __THIN__ IELDPM(MEN,MEL) = IELDPM(MEN,MEL) + NINT( WEIGHT ) IELDPA(MEN,MEL) = IELDPA(MEN,MEL) + NINT( WEIGHT ) IF ( ELASTI .LT. 1.D0 ) THEN ELMEAN(MEN) = ELMEAN(MEN) + ELASTI * WEIGHT ELMEAA(MEN) = ELMEAA(MEN) + ELASTI * WEIGHT #else IELDPM(MEN,MEL) = IELDPM(MEN,MEL) + 1 IELDPA(MEN,MEL) = IELDPA(MEN,MEL) + 1 IF ( ELASTI .LT. 1.D0 ) THEN ELMEAN(MEN) = ELMEAN(MEN) + ELASTI ELMEAA(MEN) = ELMEAA(MEN) + ELASTI #endif ENDIF #if __COASTUSERLIB__ c for sibyll coastProjId = nint(curpar(0)) coastTargId = nint(tar) coastX = curpar(7) coastY = curpar(8) #if __CURVED__ coastZ = curpar(14) #else coastX = coastX - XOFF(NOBSLV) coastY = coastY - YOFF(NOBSLV) coastZ = curpar(5) #endif coastT = curpar(6) coastE = pama(coastProjId)*curpar(1) coastCX = sigair coastEl = elasti call interaction(coastX) #endif IF ( FIRSTI ) THEN TARG1I = TAR SIG1I = SIGAIRS ELAST = ELASTI C RANDOM GENERATOR STATUS (SEQUENCE L=1) AT END OF EVENT LL = 1 CALL RMMAQD( ISEED(1,LL),LL,'R' ) C SEED ISEED1I(1) = ISEED(1,LL) C NUMBER OF CALLS ISEED1I(2) = ISEED(2,LL) C NUMBER OF BILLIONS ISEED1I(3) = ISEED(3,LL) FIRSTI = .FALSE. ENDIF #if __INTTEST__ C ADD SPECTATORS FROM TARGET TO STACK SECPAR(1) = 1.D0 SECPAR(2) = 1.D0 SECPAR(3) = 0.D0 SECPAR(4) = 0.D0 SECPAR(17) = 0.D0 DO I = 1, (INTTAR-IWOUNT)/2 SECPAR(0) = 14.D0 CALL TSTACK ENDDO DO I = (INTTAR-IWOUNT)/2+1, INTTAR-IWOUNT SECPAR(0) = 13.D0 CALL TSTACK ENDDO #endif RETURN END *-- Author : D. HECK IK FZK KARLSRUHE 06/12/1996 C======================================================================= SUBROUTINE SIGNUC_INI2( IA,E0,SSIGNUC ) C----------------------------------------------------------------------- C SIG(MA) NUC(LEUS) INI(TIALIZATION) 2 C C IN ANALOGY WITH SUBROUT. SIGNUC_INI OF SIBYLL PACKAGE C THIS SUBROUT. RECEIVES IN INPUT E0 (GEV) ENERGY PER NUCLEON AND C INTERPOLATES THE CROSS-SECTIONS FOR NUCLEI WITH A < 56. C UPDATED FOR SIBYLL-2.3 Sept. 2015 by D. Heck C THIS SUBROUTINE IS CALLED FROM SIBSIG. C ARGUMENTS: C IA = MASS NUMBER OF PROJECTILE NUCLEUS C E0 = LAB.ENERGY/NUCLEON OF PROJECTILE (GEV) C SSIGNUC= CROSS-SECTION OF NUCLEUS IA WITH AIR C C. ATTENTION: THE TABULATED CROSS-SECTIONS ARE OBTAINED WITH C. NEW P-P CROSS-SECTIONS AS USED IN SIBYLL 2.1, C. IN ADDITION FIELD DIMENSIONS CHANGED (RE 04/2000) C----------------------------------------------------------------------- IMPLICIT NONE DIMENSION SIGMA(6,56), SIGQE(6,56) DOUBLE PRECISION SIGMA,SIGQE DIMENSION AA(6) DOUBLE PRECISION AA,DA,AMIN,ABEAM,S1,S2,ASQS DOUBLE PRECISION E0,SSIGNUC INTEGER IA,J,JE,NE DOUBLE PRECISION QUAD_INT EXTERNAL QUAD_INT SAVE DATA NE /6/, AMIN /1.D0/, DA /1.D0/ DATA AA /1.D0,2.D0,3.D0,4.D0,5.D0,6.D0/ * DATA AVOG /6.0221367D-04/ * DATA ATARGET /14.514D0/ ! EFFECTIVE MASSS OF AIR C DATA ON 'INELASTIC-PRODUCTION' NUCLEUS-AIR CROSS-SECTION DATA (SIGMA(J, 2),J=1,6) / &3.842D+02,4.287D+02,4.940D+02,5.887D+02,6.922D+02,7.767D+02/ DATA (SIGMA(J, 3),J=1,6) / &4.601D+02,5.149D+02,5.595D+02,6.663D+02,7.641D+02,8.446D+02/ DATA (SIGMA(J, 4),J=1,6) / &4.881D+02,5.373D+02,6.005D+02,6.895D+02,7.716D+02,8.967D+02/ DATA (SIGMA(J, 5),J=1,6) / &5.874D+02,6.176D+02,7.181D+02,7.993D+02,9.089D+02,1.031D+03/ DATA (SIGMA(J, 6),J=1,6) / &7.054D+02,7.399D+02,8.388D+02,9.463D+02,1.080D+03,1.197D+03/ DATA (SIGMA(J, 7),J=1,6) / &7.192D+02,7.611D+02,8.449D+02,9.539D+02,1.061D+03,1.176D+03/ DATA (SIGMA(J, 8),J=1,6) / &7.550D+02,7.975D+02,9.153D+02,9.944D+02,1.126D+03,1.236D+03/ DATA (SIGMA(J, 9),J=1,6) / &7.929D+02,8.392D+02,9.265D+02,1.059D+03,1.167D+03,1.262D+03/ DATA (SIGMA(J, 10),J=1,6) / &8.157D+02,8.644D+02,9.512D+02,1.058D+03,1.182D+03,1.298D+03/ DATA (SIGMA(J, 11),J=1,6) / &8.039D+02,8.587D+02,9.534D+02,1.055D+03,1.182D+03,1.298D+03/ DATA (SIGMA(J, 12),J=1,6) / &8.515D+02,8.957D+02,9.869D+02,1.122D+03,1.253D+03,1.366D+03/ DATA (SIGMA(J, 13),J=1,6) / &8.769D+02,9.100D+02,1.018D+03,1.119D+03,1.252D+03,1.341D+03/ DATA (SIGMA(J, 14),J=1,6) / &9.058D+02,9.532D+02,1.057D+03,1.171D+03,1.302D+03,1.391D+03/ DATA (SIGMA(J, 15),J=1,6) / &9.555D+02,9.799D+02,1.098D+03,1.201D+03,1.342D+03,1.444D+03/ DATA (SIGMA(J, 16),J=1,6) / &1.009D+03,1.058D+03,1.149D+03,1.290D+03,1.414D+03,1.520D+03/ DATA (SIGMA(J, 17),J=1,6) / &9.907D+02,1.045D+03,1.166D+03,1.290D+03,1.384D+03,1.516D+03/ DATA (SIGMA(J, 18),J=1,6) / &1.036D+03,1.121D+03,1.198D+03,1.328D+03,1.470D+03,1.592D+03/ DATA (SIGMA(J, 19),J=1,6) / &1.083D+03,1.162D+03,1.250D+03,1.371D+03,1.516D+03,1.661D+03/ DATA (SIGMA(J, 20),J=1,6) / &1.146D+03,1.215D+03,1.295D+03,1.443D+03,1.544D+03,1.744D+03/ DATA (SIGMA(J, 21),J=1,6) / &1.158D+03,1.234D+03,1.292D+03,1.467D+03,1.618D+03,1.750D+03/ DATA (SIGMA(J, 22),J=1,6) / &1.153D+03,1.205D+03,1.329D+03,1.451D+03,1.596D+03,1.734D+03/ DATA (SIGMA(J, 23),J=1,6) / &1.210D+03,1.274D+03,1.356D+03,1.493D+03,1.655D+03,1.803D+03/ DATA (SIGMA(J, 24),J=1,6) / &1.212D+03,1.273D+03,1.398D+03,1.489D+03,1.641D+03,1.800D+03/ DATA (SIGMA(J, 25),J=1,6) / &1.236D+03,1.315D+03,1.423D+03,1.561D+03,1.669D+03,1.855D+03/ DATA (SIGMA(J, 26),J=1,6) / &1.279D+03,1.345D+03,1.431D+03,1.595D+03,1.734D+03,1.889D+03/ DATA (SIGMA(J, 27),J=1,6) / &1.228D+03,1.304D+03,1.438D+03,1.546D+03,1.714D+03,1.836D+03/ DATA (SIGMA(J, 28),J=1,6) / &1.289D+03,1.370D+03,1.451D+03,1.597D+03,1.754D+03,1.913D+03/ DATA (SIGMA(J, 29),J=1,6) / &1.411D+03,1.469D+03,1.613D+03,1.777D+03,1.910D+03,2.075D+03/ DATA (SIGMA(J, 30),J=1,6) / &1.347D+03,1.401D+03,1.498D+03,1.642D+03,1.816D+03,1.975D+03/ DATA (SIGMA(J, 31),J=1,6) / &1.359D+03,1.448D+03,1.551D+03,1.694D+03,1.858D+03,2.007D+03/ DATA (SIGMA(J, 32),J=1,6) / &1.358D+03,1.460D+03,1.559D+03,1.698D+03,1.842D+03,1.974D+03/ DATA (SIGMA(J, 33),J=1,6) / &1.418D+03,1.448D+03,1.578D+03,1.727D+03,1.872D+03,2.047D+03/ DATA (SIGMA(J, 34),J=1,6) / &1.433D+03,1.466D+03,1.605D+03,1.738D+03,1.892D+03,2.019E+03/ DATA (SIGMA(J, 35),J=1,6) / &1.430D+03,1.511D+03,1.602D+03,1.752D+03,1.935D+03,2.060D+03/ DATA (SIGMA(J, 36),J=1,6) / &1.462D+03,1.499D+03,1.653D+03,1.805D+03,1.920D+03,2.057D+03/ DATA (SIGMA(J, 37),J=1,6) / &1.470D+03,1.520D+03,1.656D+03,1.818D+03,1.946D+03,2.131D+03/ DATA (SIGMA(J, 38),J=1,6) / &1.470D+03,1.542D+03,1.691D+03,1.800D+03,1.968D+03,2.133D+03/ DATA (SIGMA(J, 39),J=1,6) / &1.495D+03,1.588D+03,1.676D+03,1.834D+03,1.969D+03,2.163D+03/ DATA (SIGMA(J, 40),J=1,6) / &1.525D+03,1.551D+03,1.722D+03,1.833D+03,2.020D+03,2.192D+03/ DATA (SIGMA(J, 41),J=1,6) / &1.526D+03,1.615D+03,1.709D+03,1.899D+03,2.040D+03,2.181D+03/ DATA (SIGMA(J, 42),J=1,6) / &1.510D+03,1.567D+03,1.716D+03,1.892D+03,2.056D+03,2.197D+03/ DATA (SIGMA(J, 43),J=1,6) / &1.557D+03,1.658D+03,1.776D+03,1.898D+03,2.092D+03,2.200D+03/ DATA (SIGMA(J, 44),J=1,6) / &1.556D+03,1.645D+03,1.752D+03,1.920D+03,2.091D+03,2.243D+03/ DATA (SIGMA(J, 45),J=1,6) / &1.583D+03,1.663D+03,1.798D+03,1.940D+03,2.051D+03,2.263D+03/ DATA (SIGMA(J, 46),J=1,6) / &1.599D+03,1.642D+03,1.799D+03,1.941D+03,2.107D+03,2.268D+03/ DATA (SIGMA(J, 47),J=1,6) / &1.611D+03,1.692D+03,1.811D+03,1.956D+03,2.107D+03,2.264D+03/ DATA (SIGMA(J, 48),J=1,6) / &1.625D+03,1.706D+03,1.819D+03,1.986D+03,2.139D+03,2.354D+03/ DATA (SIGMA(J, 49),J=1,6) / &1.666D+03,1.737D+03,1.854D+03,1.971D+03,2.160D+03,2.318D+03/ DATA (SIGMA(J, 50),J=1,6) / &1.648D+03,1.747D+03,1.856D+03,2.023D+03,2.181D+03,2.352D+03/ DATA (SIGMA(J, 51),J=1,6) / &1.653D+03,1.763D+03,1.868D+03,2.015D+03,2.203D+03,2.386D+03/ DATA (SIGMA(J, 52),J=1,6) / &1.690D+03,1.720D+03,1.902D+03,2.027D+03,2.189D+03,2.357D+03/ DATA (SIGMA(J, 53),J=1,6) / &1.690D+03,1.750D+03,1.921D+03,2.059D+03,2.208D+03,2.417D+03/ DATA (SIGMA(J, 54),J=1,6) / &1.705D+03,1.781D+03,1.911D+03,2.073D+03,2.242D+03,2.411D+03/ DATA (SIGMA(J, 55),J=1,6) / &1.714D+03,1.806D+03,1.896D+03,2.100D+03,2.253D+03,2.411D+03/ DATA (SIGMA(J, 56),J=1,6) / &1.774D+03,1.813D+03,1.954D+03,2.098D+03,2.280D+03,2.482D+03/ C DATA ON 'QUASI-ELASTIC' NUCLEUS-AIR CROSS-SECTION DATA (SIGQE(J, 2),J=1,6) / &4.141D+01,3.708D+01,5.428D+01,8.696D+01,1.403D+02,1.885D+02/ DATA (SIGQE(J, 3),J=1,6) / &4.357D+01,3.894D+01,5.177D+01,9.675D+01,1.447D+02,2.029D+02/ DATA (SIGQE(J, 4),J=1,6) / &4.123D+01,3.933D+01,6.070D+01,9.482D+01,1.474D+02,2.023D+02/ DATA (SIGQE(J, 5),J=1,6) / &4.681D+01,4.287D+01,6.381D+01,1.050D+02,1.519D+02,2.198D+02/ DATA (SIGQE(J, 6),J=1,6) / &5.407D+01,5.195D+01,6.723D+01,1.108D+02,1.750D+02,2.368D+02/ DATA (SIGQE(J, 7),J=1,6) / &4.975D+01,4.936D+01,6.880D+01,1.162D+02,1.689D+02,2.329D+02/ DATA (SIGQE(J, 8),J=1,6) / &5.361D+01,5.027D+01,6.858D+01,1.177D+02,1.759D+02,2.412D+02/ DATA (SIGQE(J, 9),J=1,6) / &4.980D+01,5.063D+01,7.210D+01,1.196D+02,1.806D+02,2.299D+02/ DATA (SIGQE(J, 10),J=1,6) / &5.170D+01,5.070D+01,7.105D+01,1.182D+02,1.679D+02,2.411D+02/ DATA (SIGQE(J, 11),J=1,6) / &4.950D+01,4.950D+01,7.286D+01,1.137D+02,1.769D+02,2.477D+02/ DATA (SIGQE(J, 12),J=1,6) / &5.262D+01,5.133D+01,7.110D+01,1.204D+02,1.789D+02,2.501D+02/ DATA (SIGQE(J, 13),J=1,6) / &5.320D+01,5.378D+01,6.847D+01,1.200D+02,1.805D+02,2.442D+02/ DATA (SIGQE(J, 14),J=1,6) / &5.638D+01,5.271D+01,6.985D+01,1.209D+02,1.867D+02,2.610D+02/ DATA (SIGQE(J, 15),J=1,6) / &5.294D+01,5.353D+01,7.435D+01,1.211D+02,1.899D+02,2.612D+02/ DATA (SIGQE(J, 16),J=1,6) / &5.668D+01,5.254D+01,7.557D+01,1.269D+02,1.917D+02,2.707D+02/ DATA (SIGQE(J, 17),J=1,6) / &5.456D+01,5.721D+01,7.481D+01,1.208D+02,1.859D+02,2.658D+02/ DATA (SIGQE(J, 18),J=1,6) / &5.901D+01,5.382D+01,7.591D+01,1.246D+02,1.872D+02,2.874D+02/ DATA (SIGQE(J, 19),J=1,6) / &6.328D+01,6.116D+01,8.451D+01,1.318D+02,2.088D+02,2.749D+02/ DATA (SIGQE(J, 20),J=1,6) / &5.779D+01,5.924D+01,8.382D+01,1.370D+02,2.062D+02,2.837D+02/ DATA (SIGQE(J, 21),J=1,6) / &7.155D+01,5.732D+01,8.231D+01,1.363D+02,2.047D+02,2.820D+02/ DATA (SIGQE(J, 22),J=1,6) / &6.699D+01,5.651D+01,8.511D+01,1.477D+02,2.031D+02,2.921D+02/ DATA (SIGQE(J, 23),J=1,6) / &6.179D+01,6.269D+01,9.395D+01,1.437D+02,2.195D+02,2.964D+02/ DATA (SIGQE(J, 24),J=1,6) / &6.784D+01,6.028D+01,8.622D+01,1.279D+02,2.214D+02,2.867D+02/ DATA (SIGQE(J, 25),J=1,6) / &6.589D+01,5.795D+01,8.890D+01,1.385D+02,2.055D+02,2.988D+02/ DATA (SIGQE(J, 26),J=1,6) / &6.364D+01,6.325D+01,8.942D+01,1.421D+02,2.128D+02,3.083D+02/ DATA (SIGQE(J, 27),J=1,6) / &6.449D+01,6.664D+01,8.986D+01,1.453D+02,2.140D+02,2.932D+02/ DATA (SIGQE(J, 28),J=1,6) / &7.284D+01,6.139D+01,8.867D+01,1.425D+02,2.179D+02,2.978D+02/ DATA (SIGQE(J, 29),J=1,6) / &7.221D+01,7.085D+01,9.079D+01,1.482D+02,2.277D+02,2.913D+02/ DATA (SIGQE(J, 30),J=1,6) / &6.928D+01,6.294D+01,8.935D+01,1.463D+02,2.265D+02,2.834D+02/ DATA (SIGQE(J, 31),J=1,6) / &6.611D+01,6.586D+01,9.133D+01,1.461D+02,2.201D+02,2.959D+02/ DATA (SIGQE(J, 32),J=1,6) / &6.401D+01,6.177D+01,8.971D+01,1.480D+02,2.155D+02,3.152D+02/ DATA (SIGQE(J, 33),J=1,6) / &7.057D+01,6.918D+01,8.410D+01,1.465D+02,2.288D+02,3.088D+02/ DATA (SIGQE(J, 34),J=1,6) / &6.453D+01,7.020D+01,9.272D+01,1.517D+02,2.189D+02,2.999D+02/ DATA (SIGQE(J, 35),J=1,6) / &6.741D+01,6.295D+01,9.323D+01,1.536D+02,2.190D+02,2.930D+02/ DATA (SIGQE(J, 36),J=1,6) / &6.807D+01,7.046D+01,1.025D+02,1.565D+02,2.315D+02,3.090D+02/ DATA (SIGQE(J, 37),J=1,6) / &8.082D+01,6.565D+01,9.160D+01,1.572D+02,2.229D+02,3.125D+02/ DATA (SIGQE(J, 38),J=1,6) / &6.494D+01,6.964D+01,9.089D+01,1.653D+02,2.336D+02,3.120D+02/ DATA (SIGQE(J, 39),J=1,6) / &6.833D+01,6.860D+01,8.933D+01,1.601D+02,2.261D+02,3.167D+02/ DATA (SIGQE(J, 40),J=1,6) / &7.021D+01,6.866D+01,8.437D+01,1.588D+02,2.249D+02,2.941D+02/ DATA (SIGQE(J, 41),J=1,6) / &7.122D+01,6.205D+01,9.545D+01,1.582D+02,2.335D+02,3.395D+02/ DATA (SIGQE(J, 42),J=1,6) / &7.265D+01,6.936D+01,9.486D+01,1.505D+02,2.379D+02,3.248D+02/ DATA (SIGQE(J, 43),J=1,6) / &7.048D+01,7.539D+01,9.192D+01,1.566D+02,2.532D+02,3.182D+02/ DATA (SIGQE(J, 44),J=1,6) / &6.650D+01,7.139D+01,9.862D+01,1.602D+02,2.289D+02,3.077D+02/ DATA (SIGQE(J, 45),J=1,6) / &7.511D+01,6.893D+01,9.245D+01,1.641D+02,2.519D+02,3.381D+02/ DATA (SIGQE(J, 46),J=1,6) / &6.437D+01,6.894D+01,8.697D+01,1.544D+02,2.391D+02,3.213D+02/ DATA (SIGQE(J, 47),J=1,6) / &7.980D+01,6.958D+01,1.022D+02,1.609D+02,2.408D+02,3.246D+02/ DATA (SIGQE(J, 48),J=1,6) / &7.265D+01,7.313D+01,8.989D+01,1.578D+02,2.387D+02,3.235D+02/ DATA (SIGQE(J, 49),J=1,6) / &6.959D+01,6.337D+01,9.084D+01,1.656D+02,2.331D+02,3.226D+02/ DATA (SIGQE(J, 50),J=1,6) / &7.371D+01,6.807D+01,9.726D+01,1.535D+02,2.445D+02,3.189D+02/ DATA (SIGQE(J, 51),J=1,6) / &7.882D+01,6.680D+01,9.377D+01,1.629D+02,2.448D+02,3.297D+02/ DATA (SIGQE(J, 52),J=1,6) / &7.223D+01,6.794D+01,9.925D+01,1.738D+02,2.446D+02,3.162D+02/ DATA (SIGQE(J, 53),J=1,6) / &7.703D+01,6.971D+01,9.601D+01,1.595D+02,2.484D+02,3.265D+02/ DATA (SIGQE(J, 54),J=1,6) / &7.549D+01,7.459D+01,8.984D+01,1.645D+02,2.348D+02,3.201D+02/ DATA (SIGQE(J, 55),J=1,6) / &7.891D+01,6.840D+01,1.017D+02,1.698D+02,2.501D+02,3.429D+02/ DATA (SIGQE(J, 56),J=1,6) / &7.545D+01,6.673D+01,1.057D+02,1.684D+02,2.424D+02,3.181D+02/ C----------------------------------------------------------------------- C ENERGY E0 IN GEV ASQS = 0.5D0*LOG10(1.876D0*E0) JE = MIN( INT( (ASQS-AMIN)/DA )+1, NE-2 ) ABEAM = DBLE(IA) C INELASTIC CROSS-SECTION S1 = QUAD_INT( ASQS, AA(JE),AA(JE+1),AA(JE+2), + SIGMA(JE,IA),SIGMA(JE+1,IA),SIGMA(JE+2,IA) ) C QUASI ELASTIC CROSS-SECTION S2 = QUAD_INT( ASQS, AA(JE),AA(JE+1),AA(JE+2), + SIGQE(JE,IA),SIGQE(JE+1,IA),SIGQE(JE+2,IA) ) C ADD INELASTIC AND QUASI-ELASTIC CROSS-SECTIONS SSIGNUC = S1 + S2 RETURN END *-- Author : D. HECK IK FZK KARLSRUHE 18/03/2003 C======================================================================= DOUBLE PRECISION FUNCTION S_RNDM(IDUM) C----------------------------------------------------------------------- C S(IBYLL) R(A)ND(O)M (GENERATOR) C C SEE SUBROUT. RMMARD C WE USE HERE A SIMPLIFIED FORM OF RMMARD WITH JSEQ=1, LENV=1. C THIS FUNCTON IS CALLED FROM SIBYLL ROUTINES. C ARGUMENT: C IDUM = DUMMY ARGUMENT C----------------------------------------------------------------------- IMPLICIT NONE #define __RANMA3INC__ #define __RANMA4INC__ #if __CONEX__ #define __CONEXINC__ #endif #include "corsika.h" #if __CONEX__ #include "conex.h" #endif INTEGER IDUM SAVE C----------------------------------------------------------------------- JSEQ = 1 #if __CONEX__ IF ( FINCNX ) JSEQ = lseq #endif 1 CONTINUE 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 S_RNDM = UNI NTOT(JSEQ) = NTOT(JSEQ) + 1 IF ( NTOT(JSEQ) .GE. MODCNS ) THEN NTOT2(JSEQ) = NTOT2(JSEQ) + 1 NTOT(JSEQ) = NTOT(JSEQ) - MODCNS ENDIF C AN EXACT ZERO HERE IS VERY UNLIKELY, BUT LET''S BE SAFE AND C TAKE A NEW RANDOM NUMBER IF ( S_RNDM .EQ. 0.D0 ) THEN GO TO 1 ELSEIF ( S_RNDM .EQ. 1.D0 ) THEN GO TO 1 ENDIF RETURN END *-- Author : T. Pierog IKP KIT KARLSRUHE 25/10/2012 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 #if __VENUS__ *-- Author : D. HECK IK FZK KARLSRUHE 18/03/2003 C======================================================================= FUNCTION RANGEN() C----------------------------------------------------------------------- C RAN(DOM NUMBER) GEN(ERATOR) C C SEE SUBROUT. RMMARD C WE USE HERE A SIMPLIFIED FORM OF RMMARD WITH JSEQ=1, LENV=1. C THIS FUNCTION IS CALLED FROM MANY VENUS ROUTINES. C----------------------------------------------------------------------- IMPLICIT NONE #define __RANMA3INC__ #define __RANMA4INC__ #include "corsika.h" REAL RANGEN SAVE C----------------------------------------------------------------------- 1 CONTINUE UNI = U(I97(1),1) - U(J97(1),1) IF ( UNI .LT. 0.D0 ) UNI = UNI + 1.D0 U(I97(1),1) = UNI I97(1) = I97(1) - 1 IF ( I97(1) .EQ. 0 ) I97(1) = 97 J97(1) = J97(1) - 1 IF ( J97(1) .EQ. 0 ) J97(1) = 97 C(1) = C(1) - CD IF ( C(1) .LT. 0.D0 ) C(1) = C(1) + CM UNI = UNI - C(1) IF ( UNI .LT. 0.D0 ) UNI = UNI + 1.D0 RANGEN = UNI NTOT(1) = NTOT(1) + 1 IF ( NTOT(1) .GE. MODCNS ) THEN NTOT2(1) = NTOT2(1) + 1 NTOT(1) = NTOT(1) - MODCNS ENDIF C AN EXACT ZERO HERE IS VERY UNLIKELY, BUT LET''S BE SAFE AND C TAKE A NEW RANDOM NUMBER IF ( RANGEN .EQ. 0. ) THEN GOTO 1 ELSEIF ( RANGEN .EQ. 1. ) THEN GOTO 1 ENDIF RETURN END *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE UTQSEA( X1,X2,X3 ) C----------------------------------------------------------------------- C UT(ILITY ROUTINE) SEA (QUARK STRUCTURE FUNCTION) C C SEA QUARK STRUCTURE FUNCTION INTEGRAL. C RETURNS INTEGRAL (XSE(1)->XSE(I)) OF FU(Z) DZ. C THIS SUBROUTINE IS CALLED FROM VENLNK. C ARGUMENTS: C X1 = C X2 = C X3 = C----------------------------------------------------------------------- #define __RUNPARINC__ #include "corsika.h" PARAMETER (NSTRU=2049) COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /PARO1/ AMPRIF,AMSIAC,BMAXIM,BMINIM,CORE,CUTMSQ,CUTMSS * ,DELMSS,DELREM,FCTRMX,GAUMX,OVERLP,PAREA,PDIQUA * ,PHARD,PSPINL,PSPINH,PISPN,PTF,PTH,PTMX,PTQ,PUD * ,PVALEN,QSEPC,QSETC,QMUST,QVAPC,QVATC,RADIAC * ,RADIAS,RSTRAS,SIGJ,SIGPPI,TAUMAX,TAUMIN * ,TAUMX,TAUNLL,TENSN,THEMAS,WPROJ,WTARG,WTMINI * ,WTSTEP,XCUT * ,IAQU,IFRADE,IOJINT,IOPBRK,IOPENT,IOPENU * ,IOPTF,IOPTQ,IRESCL,IWCENT,KENTRO,KO1KO2 * ,LABSYS,MAXRES,NCLEAN,NCOLMX,NDECAW,NEQMN,NEQMX * ,NSTTAU,NTRYMX,NUMTAU COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA * ,YHAHA,YMXIMI,YPJTL * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG * ,MODSHO,NDECAX,NDECAY,NEVENT COMMON /STRU2/ DELTA0,DELTA1,QSEH(NSTRU),QSEPI(NSTRU) * ,QVAH(NSTRU),QVAPI(NSTRU),XSE(NSTRU),XVA(NSTRU) SAVE C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'UTQSEA:' X0 = 0. N = NSTRU IF ( ISH .GE. 90 ) THEN IF ( X1 .LT. X0 .OR. X2 .LT. X1 .OR. X3 .LT. X2 ) THEN CALL UTMSG( 'UTQSEA' ) WRITE(IFCH,*) ' XI=',X0,X1,X2,X3 CALL UTMSGF ENDIF ENDIF I1 = N/3 I2 = 2*N/3 FAC1 = (X1-X0)/FLOAT(I1-1) DO I = 1, I1-1 XSE(I) = (I-1.)*FAC1+X0 ENDDO FAC2 = (X2-X1)/FLOAT(I2-I1) DO I = I1, I2-1 XSE(I) = FLOAT(I-I1)*FAC2 +X1 ENDDO FAC3 = (X3-X2)/FLOAT(N-I2) DO I = I2, N XSE(I) = MIN( FLOAT(I-I2)*FAC3 +X2, 0.99999999 ) ENDDO XCUT2 = XCUT**2 XCUT4 = XCUT2**2 XCUT6 = XCUT2*XCUT4 CUTLOG = LOG( XCUT ) C COEFFICIENTS FOR HADRONIC SEA QUARK STRUCTURE FUNCTION AH0 = -8. + 37.333333*XCUT2 - 29.866667*XCUT4 + 3.65714286*XCUT6 AH1 = 14. - 26.25*XCUT2 + 8.75*XCUT4 - 0.2734375*XCUT6 AH2 = -18.666667 + 14.933333*XCUT2 - 1.82857143*XCUT4 AH3 = 17.5 - 5.8333333*XCUT2 + 0.182291667*XCUT4 AH4 = -11.2 + 1.37142857*XCUT2 AH5 = 4.6666667 - 0.14583333*XCUT2 AH6 = -1.14285714 AH7 = 0.125 QAH = 1. - AH1 * XCUT2 AHCUT = AH0 * XCUT C COEFFICIENTS FOR PIONIC SEA QUARK STRUCTURE FUNCTION API0 = -5. + 6.6666667*XCUT2 - 0.53333333*XCUT4 API1 = 5. - 1.875*XCUT2 API2 = -3.3333333 + 0.26666667*XCUT2 API3 = 1.25 API4 = -0.2 QAPI = 1. - API1 * XCUT2 APICUT = API0 * XCUT QSEH(1) = 0. QSEPI(1) = 0. DO I = 2, N Z = XSE(I) ROOT = SQRT( Z**2 + XCUT2 ) ROOTLG = LOG( Z + ROOT ) - CUTLOG QSEH(I) = 1.265 * ( QAH * ROOTLG - AHCUT * + ROOT * (AH0 + Z*(AH1 + Z*(AH2 + Z*(AH3 * + Z*(AH4 + Z*(AH5 + Z*(AH6 + Z*AH7))))))) ) QSEPI(I) = 0.9 * ( QAPI * ROOTLG - APICUT * + ROOT * (API0+Z*(API1+Z*(API2+Z*(API3+Z*API4)))) ) ENDDO RETURN END *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE UTQVAL( Q,NEND ) C----------------------------------------------------------------------- C UT(ILITY ROUTINE) VAL(ENCE QUARK STRUCTURE FUNCTION) C C VALENCE QUARK STRUCTURE FUNCTION. C RETURNS INTEGRAL (XVA(1)->XVA(I)) FU(Z) DZ. C THIS INTEGRAL IS ONLY CALCULATED FOR SMALL VALUES OF XVA UP TO 25 C TIMES THE VALUE OF XCUT. FOR LARGER VALUES THE TABULATED VALUES OF C DATASET 'VENUSDAT' ARE TAKEN AND CORRECTED BY THE CONSTANT SHIFT C DELTA0 (FOR HADRONS) OR DELTA1 (FOR PIONS). C THIS SUBROUTINE IS CALLED FROM VENLNK. C ARGUMENTS: C Q = INTEGRAL VALUE C NEND = POINTER TO LAST ARGUMENT C----------------------------------------------------------------------- #define __RUNPARINC__ #include "corsika.h" PARAMETER (NSTRU=2049) COMMON /CIPIO/ IPIO COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /PARO1/ AMPRIF,AMSIAC,BMAXIM,BMINIM,CORE,CUTMSQ,CUTMSS * ,DELMSS,DELREM,FCTRMX,GAUMX,OVERLP,PAREA,PDIQUA * ,PHARD,PSPINL,PSPINH,PISPN,PTF,PTH,PTMX,PTQ,PUD * ,PVALEN,QSEPC,QSETC,QMUST,QVAPC,QVATC,RADIAC * ,RADIAS,RSTRAS,SIGJ,SIGPPI,TAUMAX,TAUMIN * ,TAUMX,TAUNLL,TENSN,THEMAS,WPROJ,WTARG,WTMINI * ,WTSTEP,XCUT * ,IAQU,IFRADE,IOJINT,IOPBRK,IOPENT,IOPENU * ,IOPTF,IOPTQ,IRESCL,IWCENT,KENTRO,KO1KO2 * ,LABSYS,MAXRES,NCLEAN,NCOLMX,NDECAW,NEQMN,NEQMX * ,NSTTAU,NTRYMX,NUMTAU COMMON /STRU2/ DELTA0,DELTA1,QSEH(NSTRU),QSEPI(NSTRU) * ,QVAH(NSTRU),QVAPI(NSTRU),XSE(NSTRU),XVA(NSTRU) DIMENSION Y0(9),Y1(9),Q(NEND) SAVE C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'UTQVAL: IPIO,NEND=',IPIO,NEND XCUT2 = XCUT**2 Q(1) = 0. Z = XVA(1) DENOMI = 1. / SQRT( Z**2 + XCUT2 ) IF ( IPIO .EQ. 0 ) THEN C CALCULATE THE FIRST NEND VALUES OF STRUCTURE FUNCTION FOR HADRONS Y0(1) = 0. DO I = 2, NEND FACT = (XVA(I) - Z) * 0.125 DO J = 2, 8 Z = Z + FACT DENOMI = 1. / SQRT( Z**2 + XCUT2 ) Y0(J) = (1.-Z)**3.46 * Z**.419 * (2.74793064*Z + 0.62452969) * * DENOMI ENDDO Z = XVA(I) DENOMI = 1. / SQRT( Z**2 + XCUT2 ) Y0(9) = (1.-Z)**3.46 * Z**.419 * (2.74793064*Z + 0.62452969) * * DENOMI C INTEGRATION AFTER BODE''S RULE (ABRAMOWITZ + STEGUN, HANDBOOK OF C MATHEMATICAL FUNCTIONS, DOVER PUBLICATIONS (1970), FORMULA 25.4.18) Q(I) = 2.8218694E-4 * FACT * ( 989. * (Y0(1) + Y0(9)) * + 5888. * (Y0(2) + Y0(8)) - 928. * (Y0(3) + Y0(7)) * + 10496. * (Y0(4) + Y0(6)) - 4540. * Y0(5) ) * + Q(I-1) Y0(1) = Y0(9) ENDDO ELSE C CALCULATE THE FIRST NEND VALUES OF STRUCTURE FUNCTION FOR PIONS Y1(1) = 0. DO I = 2, NEND FACT = (XVA(I) - Z) * 0.125 DO J = 2, 8 Z = Z + FACT DENOMI = 1. / SQRT( Z**2 + XCUT2 ) Y1(J) = (1.-Z)**0.7 * Z**.4 * DENOMI ENDDO Z = XVA(I) DENOMI = 1. / SQRT( Z**2 + XCUT2 ) Y1(9) = (1.-Z)**0.7 * Z**.4 * DENOMI C INTEGRATION AFTER BODE''S RULE (ABRAMOWITZ + STEGUN, HANDBOOK OF C MATHEMATICAL FUNCTIONS, DOVER PUBLICATIONS (1970), FORMULA 25.4.18) Q(I) = 2.8218694E-4 * FACT * ( 989. * (Y1(1) + Y1(9)) * + 5888. * (Y1(2) + Y1(8)) - 928. * (Y1(3) + Y1(7)) * + 10496. * (Y1(4) + Y1(6)) - 4540. * Y1(5) ) * * 0.1730725 + Q(I-1) Y1(1) = Y1(9) ENDDO ENDIF RETURN END *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= BLOCK DATA VENDAT C----------------------------------------------------------------------- C VEN(US) DAT(A INITIALIZATION) C C INITIALIZES DATA FOR VENUS LINK C----------------------------------------------------------------------- #define __VENLININC__ #include "corsika.h" C CONVERTS CORSIKA PARTICLES INTO VENUS (PDG) PARTICLES DATA IDTABL/ * 10, -12, 12, 0, -14, 14, 110, 120, -120, -20, ! 10 * 130, -130, 1220, 1120,-1120, 20, 220, 2130, 1130, 1230, ! 20 * 2230, 1330, 2330, 3331,-1220,-2130,-1130,-1230,-2230,-1330, ! 30 *-2330,-3331, -16, 16, -240, 240, -140, 140, -340, 340, ! 40 * 2140, 0, 0, 0, 0, 0, 0, 0, 0, 0, ! 50 * 111, 121, -121, 1111, 1121, 1221, 2221,-1111,-1121,-1221, ! 60 *-2221, 231, 131, -131, -231, 11, -11, 13, -13, 0, ! 70 * 220, 220, 220, 220, 0, 25*0 / END *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE VENINI C----------------------------------------------------------------------- C VEN(US) INI(TIALIZATION) C C FIRST INITIALIZATION OF VENUS ARRAYS AND PARAMETERS. C THIS SUBROUTINE IS CALLED FROM START. C----------------------------------------------------------------------- #define __AIRINC__ #define __PAMINC__ #define __RANDPAINC__ #define __RUNPARINC__ #define __VENLININC__ #define __VENPARINC__ #define __VENUSINC__ #include "corsika.h" PARAMETER (KOLLMX=2500) PARAMETER (MXEPS=10) PARAMETER (MXTAU=4) PARAMETER (MXVOL=10) PARAMETER (NGAU=129) PARAMETER (NDEP=129) PARAMETER (NDET=129) PARAMETER (NPTF=129) PARAMETER (NPTJ=129) PARAMETER (NSTRU=2049) COMMON /ACCUM/ AMSAC,ILAMAS,IMSG,INOIAC,IPAGE,JERR,NAEVT,NREVT * ,NRPTL,NRSTR,NTEVT COMMON /CDEN/ MASSNR,RMX,R0 COMMON /CGAU/ QGAU(NGAU),XGAU(NGAU) COMMON /CIUTOT/ IUTOTC,IUTOTE COMMON /CJINTC/ CLUST(MXTAU,MXVOL,MXEPS) COMMON /CJINTD/ VOLSUM(MXTAU),VO2SUM(MXTAU),NCLSUM(MXTAU) COMMON /CLEP/ ICINPU,IDSCAT COMMON /CNSTA/ AINFIN,PI,PIOM,PROM COMMON /COL/ BIMP,BMAX,COORD(4,KOLLMX),DISTCE(KOLLMX) * ,QDEP(NDEP),QDET14(NDET),QDET16(NDET),QDET40(NDET) * ,QDET99(NDET),RMPROJ,RMTARG(4),XDEP(NDEP) * ,XDET14(NDET),XDET16(NDET),XDET40(NDET) * ,XDET99(NDET) * ,KOLL,LTARG,NORD(KOLLMX),NPROJ,NRPROJ(KOLLMX) * ,NRTARG(KOLLMX),NTARG COMMON /CPTF/ FPTFS,FPTFSS,FPTFU,FPTFUS,FPTFUU * ,QPTFS(NPTF),QPTFSS(NPTF),QPTFU(NPTF),QPTFUS(NPTF) * ,QPTFUU(NPTF),XPTF(NPTF) COMMON /CPTJ/ QPTJ(NPTJ),XPTJ(NPTJ) COMMON /CPTLU/ NPTLU COMMON /CQUAMA / QUAMA DOUBLE PRECISION SEEDC,SEEDI COMMON /CSEED/ SEEDC,SEEDI COMMON /CVSN/ IVERSN COMMON /EPSCR/ EPSCRI COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /NEVNT/ NEVNT COMMON /PARO1/ AMPRIF,AMSIAC,BMAXIM,BMINIM,CORE,CUTMSQ,CUTMSS * ,DELMSS,DELREM,FCTRMX,GAUMX,OVERLP,PAREA,PDIQUA * ,PHARD,PSPINL,PSPINH,PISPN,PTF,PTH,PTMX,PTQ,PUD * ,PVALEN,QSEPC,QSETC,QMUST,QVAPC,QVATC,RADIAC * ,RADIAS,RSTRAS,SIGJ,SIGPPI,TAUMAX,TAUMIN * ,TAUMX,TAUNLL,TENSN,THEMAS,WPROJ,WTARG,WTMINI * ,WTSTEP,XCUT * ,IAQU,IFRADE,IOJINT,IOPBRK,IOPENT,IOPENU * ,IOPTF,IOPTQ,IRESCL,IWCENT,KENTRO,KO1KO2 * ,LABSYS,MAXRES,NCLEAN,NCOLMX,NDECAW,NEQMN,NEQMX * ,NSTTAU,NTRYMX,NUMTAU COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA * ,YHAHA,YMXIMI,YPJTL * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG * ,MODSHO,NDECAX,NDECAY,NEVENT COMMON /PARO3/ ASUHAX(7),ASUHAY(7),OMEGA,SIGPPD,SIGPPE,UENTRO * ,IWZZZZ COMMON /PARO4/ GRICEL,GRIDEL,GRIGAM,GRIRSQ,GRISLO COMMON /PARO5/ DELEPS,DELVOL COMMON /QUARKM/ SMAS,SSMAS,USMAS,UUMAS COMMON /STRU2/ DELTA0,DELTA1,QSEH(NSTRU),QSEPI(NSTRU) * ,QVAH(NSTRU),QVAPI(NSTRU),XSE(NSTRU),XVA(NSTRU) SAVE EXTERNAL SDENSI,SGAU,SPTF,SPTJ C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'VENINI:' IFMT = MONIOU IFCH = MDEBUG ICHOIC = 2 NEVNT = 0 C VERSION NUMBER C -------------- IVERSN=4125 IVERVN=IVERSN C FRAGMENTATION PARAMETERS/OPTIONS C -------------------------------- C PROB. FOR U OR D QUARK PRODUCTION ( =(1-P_STRANGE)/2 ): PUD=0.455 C QQ-QQBAR PROBABILITY PDIQUA=0.12 C SPIN PROBABILITIES (FOR LIGHT AND HEAVY FLAVOURS): PSPINL=0.50 PSPINH=0.75 C ISOSPIN PROBABILITY: PISPN=0.50 C OPTION FOR P_T DISTRIBUTION (1=EXPONENTIAL,2=GAUSSIAN): IOPTF=1 C AVERAGE P_TRANSVERSE PTF=0.40 C STRING TENSION: TENSN=1.0 C STRING DECAY PARAMETER PAREA=.60 C THRESHOLD RESONANCE -> STRING DELREM=1.0 C CUTOFF FOR KMAXOR BEYOND WHICH PDIQ=0 IN SR JSPLIT KUTDIQ=4 C OPTION FOR BREAKING PROCEDURE (1=AMOR,2=SAMBA) IOPBRK=1 C PROTON-PROTON PARAMETERS/OPTIONS C -------------------------------- C OPTION FOR QUARK P_T DISTRIBUTION (1=EXPONENTIAL,2=GAUSSIAN,3=POWE IOPTQ=2 C MEAN TRANSVERSE MOMENTUM OF QUARKS C (Q1+Q2*LN(E)+Q3*LN(E)**2, E=SQRT(S)): PTQ1=0.260 PTQ2=0. PTQ3=0. C PROBABILITY FOR SEMIHARD INTERACTION (NOT USED IF NEGATIVE): C PHARD=-1.0 C CUTOFF PARAMETER FOR P_T DISTR. FOR SEMIHARD INTERACTIONS: PTH=1.0 C EFFECTIVE RATIO OF STRANGE SEA OVER U SEA: RSTRAS=0. C EFFECTIVE CUTOFF MASS IN STRUCTURE FUNCTIONS: CUTMSQ=2.0 CUTMSS=0.001 C VALENCE QUARK FRACTION IN CASE OF DIFFRACTIVE INTERACTION PVALEN=0.30 C PHASE SPACE PARAMETERS: DELMSS=0.300 C GRIBOV-REGGE-THEORY PARAMETERS C ------------------------------ C GAMMA (IN FM**2): GRIGAM=3.64*0.04 C R**2(IN FM**2): GRIRSQ=3.56*0.04 C DELTA=INTERCEPT OF REGGE TRAJECTORY-1: GRIDEL=0.07 C SLOPE OF REGGE TRAJECTORY (IN FM**2): GRISLO=0.25*0.04 C C (DETERMINES RELATIVE WEIGHT OF ELASTIC AND DIFFR CROSS-SCTN): GRICEL=1.5 C NUCLEUS-NUCLEUS PARAMETERS C -------------------------- C HARD CORE DISTANCE: CORE=0.8 C JPSI NUCLEON CROSS-SECTION (FM**2): SIGJ=0.2 C RESCATTERING PARAMETERS C ----------------------- C REACTION TIME: TAUREA=1.5 C OVERLAP PARAMETER (NOT USED IF NEGATIVE) OVERLP=-1.0 C BARYON RADIUS: RADIAC=0.65 C MESON RADIUS: RADIAS=0.35 C CRITICAL ENERGY DENSITY (<0 TO AVOID SECONDARY INTERACTIONS): EPSCRI=1.0 C BARYON ENERGY DENSITY EPSBAR=2.0 C INTERACTION MASS: AMSIAC=0.8 C OPTION TO CALL JINTA1 (1) OR JINTA2 (2) IOJINT=2 C PRINT OPTIONS AMPRIF=0. DELVOL=1.0 DELEPS=1.0 C CLUSTER DECAY PARAMETERS/OPTIONS C -------------------------------- C CORRELATION LENGTH C (CORLEN>1.0: FIRST FIX SHORT CLUSTER BREAKING CORLEN=1.0 C MINIMUM MASS AMUSEG=3.0 C BAG CONSTANT -1/4 BAG4RT=0.200 C OPTION FOR ENTROPY CALCULATION: C IOPENT=0: ZERO ENTROPY C IOPENT=1: OSCILLATOR MODEL (0 FOR K.LE.UENTRO) C IOPENT=2: FERMI GAS WITH CONST VOLUME (0 FOR K.LE.UENTRO) C IOPENT=3: FERMI GAS WITH CONST DENSITY (0 FOR K.LE.UENTRO) C IOPENT=4: FERMI GAS WITH CONST VOLUME - NEW (0 FOR K.LE.UENTRO) C IOPENT=5: RESONANCE GAS (HAGEDORN) (0 FOR U.LE.UENTRO) IOPENT=5 UENTRO=4.0 KENTRO=100000 C DECAY TIME (COMOVING FRAME): TAUNLL=1.0 C OSCILLATOR QUANTUM OMEGA=0.500 C PRESENTLY NOT USED C ------------------ C CLUSTER DECAY INITIALIZATIONS C ----------------------------- C AVERAGE HADRON MASSES, TWO LOWEST MULTIPLETS (IF POSSIBLE): C N/DELTA,LAMBDA/SIGMA,XI,OMEGA,PI/RHO,KAON,DELTA: ASUHAX(1)=1.134 ASUHAX(2)=1.301 ASUHAX(3)=1.461 ASUHAX(4)=1.673 ASUHAX(5)=0.6125 ASUHAX(6)=0.7915 ASUHAX(7)=1.2320 C LOWEST MASSES: ASUHAY(1)=0.940 ASUHAY(2)=1.200 ASUHAY(3)=1.322 ASUHAY(4)=1.673 ASUHAY(5)=0.1400 ASUHAY(6)=0.4977 ASUHAY(7)=1.2320 C TECHNICAL PARAMETERS C -------------------- C DELTA_ZETA FOR /C4PTL/...WEIPTL() DLZETA=0.5 C MIN TAU FOR SPACE-TIME EVOLUTION: TAUMIN=0. C MAX TAU FOR SPACE-TIME EVOLUTION TAUMAX=10.0 C TAU STEPS FOR SPACE-TIME EVOTUTION (46+40) NUMTAU=51 C RANGE FOR PT DISTRIBUTION PTMX=6.0 C RANGE FOR GAUSS DISTRIBUTION GAUMX=8.0 C PARAMETER DETERMINING RANGE FOR DENSITY DISTRIBUTION FCTRMX=10.0 C TRY-AGAIN PARAMETER NTRYMX=10 C MAX TIME FOR JPSI EVOLUTION TAUMX=20.0 C TIME STEPS FOR JPSI EVOLUTION NSTTAU=100 C OPTIONS C ------- C OPTION FOR MINIMUM ENERGY IN SJCGAM: C IOPENU = 1 : SUM OF HADRON MASSES C IOPENU = 2 : BAG MODEL CURVE WITH MINIMUM AT NONZERO STRANGEN. IOPENU=1 C PARAMETER THETA IN BERGER/JAFFE MASS FORMULA THEMAS=0.51225 C SEA PROBABILITY (IF .LT. 0. THEN CALCULATED FROM STRUCTURE FNCTS) PROSEA=-1.0 C INELASTIC PP CROSS-SECTION (FM**2) C (IF NEGATIVE: CALCULATED FROM GRIBOV-REGGE-THEORY): CDH SIGPPI=-1.0 C MULTISTRING PARAMETER (Q1+Q2*LN(E)+Q3*LN(E)**2, E=SQRT(S)): C (NOT USED IF RACPRO IS CALLED WITH 'GRI'-OPTION (DEFAULT)) QMUST1=0.50 QMUST2=0. QMUST3=0. C ENTRO() CALCULATED (1) OR FROM DATA (2) IENTRO=2 C DUAL PARTON MODEL (1) OR NOT (ELSE) IDPM=0 C ANTIQUARK COLOR EXCHANGE (1) OR NOT (0): IAQU=1 C MINIMUM NUMBER OF VALENCE QUARKS: NEQMN=-5 C MAXIMUM NUMBER OF VALENCE QUARKS: NEQMX=5 C UPPER LIMIT FOR RAPIDITY INTERVAL FOR INTERMITTENCY ANALYSIS YMXIMI=2.0 C CLEAN /CPTL/ IF NCLEAN > 0 (EVERY NCLEAN_TH TIME STEP) NCLEAN=0 C TRAFO FROM PP-CM INTO LAB-SYSTEM (1) OR NOT (.NE.1) LABSYS=1 C MAXIMUM NUMBER OF COLLISIONS: NCOLMX=1000 C MAXIMUM RESONANCE SPIN (SPIN IN A GENARAL SENSE: MOD(/ID/,10)) MAXRES=99999 C MOMENTUM RESCALING (1=YES): IRESCL=1 C NUE ENERGY ELEPTI=43.00 C MUE ENERGY ELEPTO=26.24 C MUE ANGLE ANGMUE=3.9645/180.*3.1415926 C JPSI TO BE PRODUCED (1) OR NOT (0): JPSI=0 C JPSI FINAL STATE INTERACTION (1) OR NOT (0): JPSIFI=0 C COLLISION TRIGGER (ONLY COLL BETWEEN KO1 AND KO2 ARE USED): KO1KO2=00009999 C PRINT OPTION: C ISH=14: CALL UTTIMA C ISH=15: PRINTS PTLS READ FROM DATA FILE IN SR VEANLY C ISH=16: PRINTS SEA PROB. C ISH=17: PRINTS RANDOM NUMBERS C ISH=18: SR JCLUDE, NO-PHASE-SPACE CLUSTERS C ISH=19: SR AINITL, CALL SMASSP C ISH=20: SR VEANLY, PRINTS EVT NR IF EVT IS ACCEPTED C ISH=21: CREATES HISTOGRAM FOR SEA DISTRIBUTION C ISH=22: SR JFRADE, MSG AFTER CALL UTCLEA C ISH=23: CALL JINTFP C ISH=24: CALL JINTCL C ISH=25: CALL JCHPRT C ISH=90,91,92,93,94,outfi95: MORE AND MORE DETAILED MESSAGES. IF ( DEBUG ) THEN ISH = ISH00 ELSE ISH = 0 ENDIF C PRINT OPTION: C ISHSUB=IJMN, IJ SPECIFIES LOCATION WHERE ISH=MN. C IJ=01: SR JCLUDE C IJ=02: SR JETGEN C IJ=03: SR JFRADE, STARTING BEFORE FRAGMENTATION C IJ=04: SR JDECAY C IJ=05: SR JDECAX C IJ=06: SR NUCOLL C IJ=07: SR NUCOGE+- C IJ=08: SR ASTORE C IJ=09: SR JFRADE, STARTING AFTER FRAGMENTATION C IJ=10: SR JFRADE, STARTING BEFORE DECAY C IJ=11: SR JFRADE, STARTING AFTER INTERACTIONS C IJ=12: SR JCENTR, ENTRO() IN DATA FORMAT C IJ=13: SR JCENTP C IJ=14: SR JDECAX IF CLUSTER DECAY C IJ=15: SR JSPLIT C IJ=16: SR JFRADE C IJ=17: SR RACPRO C IJ=18: SR UTCLEA C IJ=19: SR JINTA1, JINTA2, AFTER CALL UTCLEA C IJ=20: SR JDECAS C IJ=21: SR JDECAS (WITHOUT JDECAX) ISHSUB=0 C PRINT OPTION: C IF ISHEVT.NE.0: FOR EVT#.NE.ISHEVT ISH IS SET TO 0 ISHEVT=0 C PRINT MARKS BETWEEN WHOM ISH IS SET TO ISH(INIT): IPAGI=0 C VERIFY OPTION FOR INPUT READING: IVI=1 C MAXIMUM IMPACT PARAMETER (BMAXIM=0=>CENTRAL): BMAXIM=10000. C MINIMUM IMPACT PARAMETER: BMINIM=0. C STORE ONLY STABLE PTL (0) OR ALSO PARENTS (1): ISTMAX=0 C RANDOM GENERATOR SEED SEEDI=ISEED(1,1) SEEDC=ISEED(2,1)+1.D9*ISEED(3,1) C SUPPRESSION (1) OR NOT OF MESSAGES ISUP=0 C SUPPRESSION OF CALLING JFRADE (0). JFRADE=FRAGM+DECAY+RESCATTERING IFRADE=1 C.. DECAY SUPPRESSION. NDECAY SPECIFIES WHICH RESONANCES ARE NOT DECAY C.. 0000001 : ALL RESONANCES C.. 0000010 : K_SHORT/LONG (+-20) C.. 0000100 : LAMBDA (+-2130) C.. 0001000 : SIGMA (+-1130,+-2230) C.. 0010000 : CASCADE (+-2330,+-1330) C.. 0100000 : OMEGA (+-3331) C.. 1000000 : PI0 (110) NDECAY=1111110 C.. DECAY SUPPRESSION. NDECAX SPECIFIES WHICH RESONANCES ARE NOT DECAY C.. 0000001 : JPSI C.. 0000010 : K_ZERO (+-230) C.. 0000100 : DELTA (+-1111,+-1121,+-1221,+-2221) C.. 0001000 : RHO,OMEGA,PHI (111,+-121,221,331) C.. 0010000 : ETA (220) C.. 0100000 : ETAPRIME (330) C.. 1000000 : A0 (112), A+- (+-122) NDECAX=0010000 C.. DECAY SUPPRESSION. NDECAW SPECIFIES WHICH RESONANCES ARE NOT DECAY C.. 0000001 : F0 (332) C.. 0000010 : K* (+-131,+-231) NDECAW=0 C FILL ZZZZ HISTOGRAMS (1) OR NOT (0) C IWZZZZ=0 C FILL INTERMITTENCY HISTOGRAMS (1) OR NOT (0) C IMIHIS=0 C FILL SPACE-TIME HISTOGRAMS (1) OR NOT (0) ISPHIS=0 C FILL CLUSTER HISTOGRAMS (1) OR NOT (0) C ICLHIS=0 C FILL JPSI HISTOGRAMS (1) OR NOT (0) C IJPHIS=0 C RHO/RHO+PHI RATIO RHOPHI=0.5 C WSPA: ALL PTLS (1) OR ONLY INTERACTING PTLS (ELSE) ISPALL=1 C TMIN IN WSPA WTMINI=-3.0 C T-STEP IN WSPA WTSTEP=1.0 C ONLY CENTRAL POINT (1) OR LONGITUDINAL DISTRIBUTION (ELSE) IN WSPA IWCENT=0 C QUARK MASSES SMAS=0. UUMAS=0. USMAS=0. SSMAS=0. C CONSTANTS (PROTON MASS, PION MASS, PI, INFINITE) C --------- C PROM=0.94 PROM=PAMA(14) C PIOM=0.14 PIOM=PAMA(8) PI=3.141592654 AINFIN=1.E+30 C INITIALIZATIONS C --------------- LAPROJ = 0 MAPROJ = 0 LATARG = 0 MAPROJ = 0 IDPROJ = 1120 IDTARG = 1120 DO I = 1, 99 PROB(I) = 0. ICBAC(I,1) = 0 ICBAC(I,2) = 0 ICFOR(I,1) = 0 ICFOR(I,2) = 0 ENDDO PNLL = 0. C FEW INITIALIZATIONS FOR CROSS-SECTION CALCULATIONS C -------------------------------------------------- IMSG = 0 JERR = 0 NTEVT = 0 NREVT = 0 NAEVT = 0 NRSTR = 0 NRPTL = 0 INOIAC = 0 ILAMAS = 0 NPTLU = 0 DO ITAU = 1, MXTAU VOLSUM(ITAU) = 0. VO2SUM(ITAU) = 0. NCLSUM(ITAU) = 0 ENDDO DO IEPS = 1, MXEPS DO IVOL = 1, MXVOL DO ITAU = 1, MXTAU CLUST(ITAU,IVOL,IEPS) = 0. ENDDO ENDDO ENDDO IUTOTC = 0 IUTOTE = 0 IF ( NPARAM .GT. 0 ) THEN DO 3 N = 1, NPARAM CALL UTLOW6( PARCHA(N) ) IF ( DEBUG ) WRITE(MDEBUG,*) PARCHA(N),PARVAL(N) IF ( PARCHA(N) .EQ. 'AMPRIF' ) THEN AMPRIF = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'AMSIAC' ) THEN AMSIAC = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'AMUSEG' ) THEN AMUSEG = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'ANGMUE' ) THEN ANGMUE = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'BAG4RT' ) THEN BAG4RT = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'BMAXIM' ) THEN BMAXIM = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'BMINIM' ) THEN BMINIM = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'CORE ' ) THEN CORE = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'CORLEN' ) THEN CORLEN = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'CUTMSQ' ) THEN CUTMSQ = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'CUTMSS' ) THEN CUTMSS = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'DELEPS' ) THEN DELEPS = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'DELMSS' ) THEN DELMSS = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'DELREM' ) THEN DELREM = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'DELVOL' ) THEN DELVOL = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'ELEPTI' ) THEN ELEPTI = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'ELEPTO' ) THEN ELEPTO = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'EPSCRI' ) THEN EPSCRI = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'FCTRMX' ) THEN FCTRMX = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'GAUMX ' ) THEN GAUMX = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'GRICEL' ) THEN GRICEL = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'GRIDEL' ) THEN GRIDEL = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'GRIGAM' ) THEN GRIGAM = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'GRIRSQ' ) THEN GRIRSQ = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'GRISLO' ) THEN GRISLO = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'IAQU ' ) THEN IAQU = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'ICLHIS' ) THEN ICLHIS = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'IDPM ' ) THEN IDPM = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'IENTRO' ) THEN IENTRO = NINT( PARVAL(N) ) ELSEIF ( PARCHA(N) .EQ. 'IFRADE' ) THEN IFRADE = NINT( PARVAL(N) ) ELSEIF ( PARCHA(N) .EQ. 'IJPHIS' ) THEN IJPHIS = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'IMIHIS' ) THEN IMIHIS = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'IOJINT' ) THEN IOJINT = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'IOPBRK' ) THEN IOPBRK = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'IOPENT' ) THEN IOPENT = PARVAL(N) IOPENT = MOD(IOPENT,10) ELSEIF ( PARCHA(N) .EQ. 'IOPENU' ) THEN IOPENU = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'IOPTF ' ) THEN IOPTF = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'IOPTQ ' ) THEN IOPTQ = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'IPAGI ' ) THEN IPAGI = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'IRESCL' ) THEN IRESCL = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'ISH ' ) THEN ISH = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'ISHEVT' ) THEN ISHEVT = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'ISHSUB' ) THEN ISHSUB = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'ISPALL' ) THEN ISPALL = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'ISPHIS' ) THEN ISPHIS = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'ISTMAX' ) THEN ISTMAX = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'ISUP ' ) THEN ISUP = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'IVERSN' ) THEN IVERSN = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'IVI ' ) THEN IVI = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'IWCENT' ) THEN IWCENT = NINT( PARVAL(N) ) ELSEIF ( PARCHA(N) .EQ. 'IWZZZZ' ) THEN IWZZZZ = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'JPSI ' ) THEN JPSI = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'JPSIFI' ) THEN JPSIFI = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'KENTRO' ) THEN KENTRO = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'KO1KO2' ) THEN KO1KO2 = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'KUTDIQ' ) THEN KUTDIQ = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'LABSYS' ) THEN LABSYS = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'MAXRES' ) THEN MAXRES = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'NCLEAN' ) THEN NCLEAN = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'NCOLMX' ) THEN NCOLMX = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'NDECAW' ) THEN NDECAW = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'NDECAX' ) THEN NDECAX = NINT( PARVAL(N) ) ELSEIF ( PARCHA(N) .EQ. 'NDECAY' ) THEN NDECAY = NINT( PARVAL(N) ) ELSEIF ( PARCHA(N) .EQ. 'NEQMN ' ) THEN NEQMN = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'NEQMX ' ) THEN NEQMX = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'NSTTAU' ) THEN NSTTAU = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'NTRYMX' ) THEN NTRYMX = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'NUMTAU' ) THEN NUMTAU = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'OVERLP' ) THEN OVERLP = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'PAREA ' ) THEN PAREA = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'PDIQUA' ) THEN PDIQUA = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'PISPN ' ) THEN PISPN = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'PROSEA' ) THEN PROSEA = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'PSPINH' ) THEN PSPINH = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'PSPINL' ) THEN PSPINL = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'PTF ' ) THEN PTF = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'PTH ' ) THEN PTH = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'PHARD ' ) THEN PHARD = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'PTMX ' ) THEN PTMX = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'PTQ1 ' ) THEN PTQ1 = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'PTQ2 ' ) THEN PTQ2 = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'PTQ3 ' ) THEN PTQ3 = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'PUD ' ) THEN PUD = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'PVALEN' ) THEN PVALEN = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'QMUST ' ) THEN CALL UTSTOP( 'VENINI: *** QMUST NOT USED ANYMORE! *** ' ) ELSEIF ( PARCHA(N) .EQ. 'QMUST1' ) THEN QMUST1 = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'QMUST2' ) THEN QMUST2 = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'QMUST3' ) THEN QMUST3 = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'RADIAC' ) THEN RADIAC = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'RADIAS' ) THEN RADIAS = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'RHOPHI' ) THEN RHOPHI = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'RSTRAS' ) THEN RSTRAS = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'SEEDI ' ) THEN SEEDI = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'SIGJ ' ) THEN SIGJ = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'SIGPPI' ) THEN SIGPPI = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'SMAS ' ) THEN SMAS = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'SSMAS ' ) THEN SSMAS = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'TAUMAX' ) THEN TAUMAX = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'TAUMIN' ) THEN TAUMIN = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'TAUMX ' ) THEN TAUMX = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'TAUNLL' ) THEN TAUNLL = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'TAUREA' ) THEN TAUREA = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'TENSN ' ) THEN TENSN = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'THEMAS' ) THEN THEMAS = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'UENTRO' ) THEN UENTRO = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'USMAS ' ) THEN USMAS = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'UUMAS ' ) THEN UUMAS = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'WPROJ ' ) THEN WPROJ = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'WTARG ' ) THEN WTARG = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'WTMINI' ) THEN WTMINI = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'WTSTEP' ) THEN WTSTEP = PARVAL(N) ELSEIF ( PARCHA(N) .EQ. 'YMXIMI' ) THEN YMXIMI = PARVAL(N) ENDIF 3 CONTINUE ENDIF IF ( ISPHIS .EQ. 1 ) LABSYS = 0 IF ( IDPM .EQ. 1 ) THEN IAQU = 0 NEQMN = 2 NEQMX = 3 ENDIF IF ( IOPENU .EQ. 2 ) THEN CALL SMASSI( THEMAS ) IF ( ISH .EQ. 19 ) THEN CALL SMASSP CALL UTSTOP( ' VENINI: ' ) ENDIF ENDIF IF ( IOJINT .EQ. 2 ) THEN IF ( EPSCRI .LT. 0. ) THEN RADIAC = 0. RADIAS = 0. ELSEIF ( EPSCRI .GT. 0. ) THEN VOLBAR = PROM/EPSBAR*PI*0.25 CDH RADIAC = (VOLBAR*0.5/PI)**0.3333333 VOLMES = 0.455/EPSCRI*PI*0.25 CDH RADIAS = (VOLMES*0.5/PI)**0.3333333 ELSE CALL UTSTOP( 'EPSCRI MUST NOT BE 0. ' ) ENDIF ENDIF CALL JDECIN( .FALSE. ) C INITIALIZE ALL PT DISTRIBUTIONS CX = PTMX QUAMA = 0. IF ( IOPTF .EQ. 1 ) THEN ROOT = SQRT( PTMX**2 + QUAMA**2 ) AUXIL = 2./PTF BPTFU = (+0.25)*PTF**2*EXP((-AUXIL)*QUAMA)*(AUXIL*QUAMA+1.) FPTFU = (-0.25)*PTF**2*EXP((-AUXIL)*ROOT)*(AUXIL*ROOT+1.)+BPTFU CALL UTQUAF( SPTF,NPTF,XPTF,QPTFU,0.,.33*CX,.66*CX,CX ) C DO N = 1, NPTF C WRITE(IFCH,*) 'N,X,Q=',N,XPTF(N),QPTFU(N) C ENDDO ELSE AUXIL = 0.25*PI/PTF**2 BPTFU = (+EXP( (-AUXIL)* QUAMA**2 ))*0.5/AUXIL FPTFU = (-EXP( (-AUXIL)*(QUAMA**2+PTMX**2) ))*0.5/AUXIL+BPTFU ENDIF QUAMA = SMAS IF ( QUAMA .NE. 0. ) THEN IF ( IOPTF .EQ. 1 ) THEN ROOT = SQRT( PTMX**2 + SMAS**2 ) AUXIL = 2./PTF BPTFS = (+0.25)*PTF**2*EXP( (-AUXIL)*SMAS )*(AUXIL*SMAS+1.) FPTFS = (-0.25)*PTF**2*EXP( (-AUXIL)*ROOT )*(AUXIL*ROOT+1.)+ * BPTFS CALL UTQUAF( SPTF,NPTF,XPTF,QPTFS,0.,.33*CX,.66*CX,CX ) ELSE AUXIL = 0.25*PI/PTF**2 BPTFS = (+EXP( (-AUXIL)* SMAS**2 ))*0.5/AUXIL FPTFS = (-EXP( (-AUXIL)*(SMAS**2+PTMX**2) ))*0.5/AUXIL+BPTFS ENDIF ELSE DO N = 1, NPTF QPTFS(N) = QPTFU(N) ENDDO FPTFS = FPTFU ENDIF QUAMA = UUMAS IF ( QUAMA .NE. 0. ) THEN IF ( IOPTF .EQ. 1 ) THEN ROOT = SQRT( PTMX**2 + UUMAS**2 ) AUXIL = 2./PTF BPTFUU = (+0.25)*PTF**2*EXP( (-AUXIL)*UUMAS )*(AUXIL*UUMAS+1.) FPTFUU = (-0.25)*PTF**2*EXP( (-AUXIL)*ROOT )*(AUXIL*ROOT+1.)+ * BPTFUU CALL UTQUAF( SPTF,NPTF,XPTF,QPTFUU,0.,.33*CX,.66*CX,CX ) ELSE AUXIL = 0.25*PI/PTF**2 BPTFUU = EXP( (-AUXIL)* UUMAS**2 )*0.5/AUXIL FPTFUU = (-EXP((-AUXIL)*(UUMAS**2+PTMX**2)))*0.5/AUXIL+BPTFUU ENDIF ELSE DO N = 1, NPTF QPTFUU(N) = QPTFU(N) ENDDO FPTFUU = FPTFU ENDIF QUAMA = USMAS IF ( QUAMA .NE. 0. ) THEN IF ( IOPTF .EQ. 1 ) THEN ROOT = SQRT( PTMX**2 + USMAS**2 ) AUXIL = 2./PTF BPTFUS = 0.25*PTF**2*EXP( (-AUXIL)*USMAS )*(AUXIL*USMAS+1.) FPTFUS = (-0.25)*PTF**2*EXP( (-AUXIL)*ROOT )*(AUXIL*ROOT+1.)+ * BPTFUS CALL UTQUAF( SPTF,NPTF,XPTF,QPTFUS,0.,.33*CX,.66*CX,CX ) ELSE AUXIL = 0.25*PI/PTF**2 BPTFUS = EXP( (-AUXIL)* USMAS**2 )*0.5/AUXIL FPTFUS = (-EXP((-AUXIL)*(USMAS**2+PTMX**2)))*0.5/AUXIL+BPTFUS ENDIF ELSE DO N = 1, NPTF QPTFUS(N) = QPTFU(N) ENDDO FPTFUS = FPTFU ENDIF QUAMA = SSMAS IF ( QUAMA .NE. 0. ) THEN IF ( IOPTF .EQ. 1 ) THEN ROOT = SQRT( PTMX**2 + SSMAS**2 ) AUXIL = 2./PTF BPTFSS = (+0.25)*PTF**2*EXP( (-AUXIL)*SSMAS )*(AUXIL*SSMAS+1.) FPTFSS = (-0.25)*PTF**2*EXP( (-AUXIL)*ROOT )*(AUXIL*ROOT+1.)+ * BPTFSS CALL UTQUAF( SPTF,NPTF,XPTF,QPTFSS,0.,.33*CX,.66*CX,CX ) ELSE AUXIL = 0.25*PI/PTF**2 BPTFSS = EXP( (-AUXIL)* SSMAS**2 )*0.5/AUXIL FPTFSS = (-EXP((-AUXIL)*(SSMAS**2+PTMX**2)))*0.5/AUXIL+BPTFSS ENDIF ELSE DO N = 1, NPTF QPTFSS(N) = QPTFU(N) ENDDO FPTFSS = FPTFU ENDIF C INITIALIZE FUNCTIONS FOR JPSI GENERATION IF ( JPSI .EQ. 1 ) THEN CX = GAUMX CALL UTQUAF( SGAU,NGAU,XGAU,QGAU,0.,.33*CX,.66*CX,CX ) CX = PTMX CALL UTQUAF( SPTJ,NPTJ,XPTJ,QPTJ,0.,.33*CX,.66*CX,CX ) ENDIF C INITIALIZE DENSITY DISTRIBUTION INTEGRALS FOR NITROGEN, OXYGEN, ARGON MASSNR = 14. R0 = 1.19*MASSNR**(.3333333) -1.61*MASSNR**(-.3333333) CX = R0+FCTRMX*0.54 RMTARG(1) = CX CALL UTQUAF( SDENSI,NDET,XDET14,QDET14,0.,.33*CX,.66*CX,CX ) MASSNR = 16. R0 = 1.19*MASSNR**(.3333333) -1.61*MASSNR**(-.3333333) CX = R0+FCTRMX*0.54 RMTARG(2) = CX CALL UTQUAF( SDENSI,NDET,XDET16,QDET16,0.,.33*CX,.66*CX,CX ) MASSNR = 40. R0 = 1.19*MASSNR**(.3333333) -1.61*MASSNR**(-.3333333) CX = R0+FCTRMX*0.54 RMTARG(3) = CX CALL UTQUAF( SDENSI,NDET,XDET40,QDET40,0.,.33*CX,.66*CX,CX ) C QDET99 AND XDET99 ARE NOT INITIALIZED MTAR99 = 0 #if __UNIX__ OPEN(UNIT=14,FILE=DATDIR(1:INDEX(DATDIR,' ')-1)//'VENUSDAT', * STATUS='OLD') #endif READ(14,*)(IDUMMY, XVA(I), QVAH(I), QVAPI(I), I=1,2049) CLOSE( UNIT=14 ) WRITE(IFMT,105) FLOAT(IVERSN)/1000. 105 FORMAT( * ' !-----------------------------------------------------!',/, * ' ! V(ERY) E(NERGETIC) NU(CLEAR) S(CATTERING) !',/, * ' ! VENUS',F6.3,5X,'- K. WERNER !',/, * ' ! SUBROUTINE TURBOVERSION D. HECK !',/, * ' !-----------------------------------------------------!') RETURN END *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE VENLNK C----------------------------------------------------------------------- C VEN(US) L(I)NK (TO CORSIKA) C C LINKS VENUS PACKAGE TO CORSIKA, NEEDS FIRST CALL OF VENINI. C THIS SUBROUTINE IS CALLED FROM SDPM. C----------------------------------------------------------------------- #define __INTERINC__ #define __PAMINC__ #define __PARPARINC__ #define __PARPAEINC__ #define __RANDPAINC__ #define __RESTINC__ #define __RUNPARINC__ #define __VENLININC__ #define __VENUSINC__ #if __INTTEST__ #define __TSTINTINC__ #endif #include "corsika.h" PARAMETER (KOLLMX=2500) PARAMETER (MXEPS=10) PARAMETER (NDEP=129) PARAMETER (NDET=129) PARAMETER (NPRBMS=20) PARAMETER (NPTQ=129) PARAMETER (NSTRU=2049) COMMON /ACCUM/ AMSAC,ILAMAS,IMSG,INOIAC,IPAGE,JERR,NAEVT,NREVT * ,NRPTL,NRSTR,NTEVT COMMON /CDEN/ MASSNR,RMX,R0 COMMON /CIPIO/ IPIO COMMON /CNSTA/ AINFIN,PI,PIOM,PROM COMMON /COL/ BIMP,BMAX,COORD(4,KOLLMX),DISTCE(KOLLMX) * ,QDEP(NDEP),QDET14(NDET),QDET16(NDET),QDET40(NDET) * ,QDET99(NDET),RMPROJ,RMTARG(4),XDEP(NDEP) * ,XDET14(NDET),XDET16(NDET),XDET40(NDET) * ,XDET99(NDET) * ,KOLL,LTARG,NORD(KOLLMX),NPROJ,NRPROJ(KOLLMX) * ,NRTARG(KOLLMX),NTARG COMMON /CPRBMS/ PRBMS(NPRBMS) COMMON /CPTQ/ QPTH(NPTQ),QPTQ(NPTQ),XPTQ(NPTQ),QPTQMX,QPTHMX DOUBLE PRECISION SEEDC,SEEDI COMMON /CSEED/ SEEDC,SEEDI COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /NEVNT/ NEVNT COMMON /PARO1/ AMPRIF,AMSIAC,BMAXIM,BMINIM,CORE,CUTMSQ,CUTMSS * ,DELMSS,DELREM,FCTRMX,GAUMX,OVERLP,PAREA,PDIQUA * ,PHARD,PSPINL,PSPINH,PISPN,PTF,PTH,PTMX,PTQ,PUD * ,PVALEN,QSEPC,QSETC,QMUST,QVAPC,QVATC,RADIAC * ,RADIAS,RSTRAS,SIGJ,SIGPPI,TAUMAX,TAUMIN * ,TAUMX,TAUNLL,TENSN,THEMAS,WPROJ,WTARG,WTMINI * ,WTSTEP,XCUT * ,IAQU,IFRADE,IOJINT,IOPBRK,IOPENT,IOPENU * ,IOPTF,IOPTQ,IRESCL,IWCENT,KENTRO,KO1KO2 * ,LABSYS,MAXRES,NCLEAN,NCOLMX,NDECAW,NEQMN,NEQMX * ,NSTTAU,NTRYMX,NUMTAU COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA * ,YHAHA,YMXIMI,YPJTL * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG * ,MODSHO,NDECAX,NDECAY,NEVENT COMMON /PARO3/ ASUHAX(7),ASUHAY(7),OMEGA,SIGPPD,SIGPPE,UENTRO * ,IWZZZZ COMMON /PARO4/ GRICEL,GRIDEL,GRIGAM,GRIRSQ,GRISLO COMMON /PARO5/ DELEPS,DELVOL COMMON /QUARKM/ SMAS,SSMAS,USMAS,UUMAS COMMON /STRU/ QSEP(NSTRU),QSET(NSTRU),QVAP(NSTRU) * ,QVAT(NSTRU),XCUTAR,XSTRU(NSTRU) * ,IDTG COMMON /STRU2/ DELTA0,DELTA1,QSEH(NSTRU),QSEPI(NSTRU) * ,QVAH(NSTRU),QVAPI(NSTRU),XSE(NSTRU),XVA(NSTRU) DOUBLE PRECISION ERRER,VALUE INTEGER IFLAG SAVE EXTERNAL SDENSI,SPTQ,SSE0,SVA0,SVA1 C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'VENLNK: TAR',SNGL(TAR) NSTRUC = NSTRU IF ( DEBUG ) THEN ISH = ISH00 ELSE ISH = 0 ENDIF NEVNT = ISHOWNO C SET RANDOM NUMBER GENERATOR STATUS SEEDC = ISEED(2,1) + 1.D9 * ISEED(3,1) C CALCULATE ENERGY IN LAB SYSTEM FOR ELASTICITY FOR VARIOUS PROJECTILES IF ( ITYPE .EQ. 1 ) THEN C TREAT GAMMA PROJECTILES (FROM EGS) CALL RMMARD( RD,1,1 ) IF ( RD(1) .LE. 0.5D0 ) THEN ITYPE = 7 ELSE ITYPE = 17 ENDIF ELAB = CURPAR(1) CURPAR(1) = ELAB / PAMA(ITYPE) ELSEIF ( ITYPE .LT. 200 ) THEN C TREAT ORDINARY PROJECTILES ELAB = CURPAR(1) * PAMA(ITYPE) ELSE C TREAT NUCLEI PROJECTILES NPROT = MOD(ITYPE,100) NNEUT = ITYPE/100 - NPROT ELAB = CURPAR(1) * ( PAMA(14)*NPROT + PAMA(13)*NNEUT ) ENDIF C SET TARGET PARAMETERS MATARG = NINT( TAR ) IDTARG = 1120 AMTARG = PAMA(14) IF ( TAR .EQ. 14.D0 ) THEN LTARG = 1 LATARG = 7 ELSEIF ( TAR .EQ. 16.D0 ) THEN LTARG = 2 LATARG = 8 ELSEIF ( TAR .EQ. 40.D0 ) THEN LTARG = 3 LATARG = 18 #if __INTTEST__ ELSE IF ( DEBUG ) WRITE(MDEBUG,*) 'VENLNK: TARGET TAR=',SNGL(TAR) LTARG = 4 IF ( ITTAR .EQ. 1 ) THEN MATARG = 1 LATARG = 1 IDTARG = 1120 ELSEIF ( ITTAR .EQ. 2 ) THEN MATARG = 1 LATARG = 0 IDTARG = 1220 ELSEIF ( TAR .EQ. 9.D0 ) THEN LATARG = 4 ELSEIF ( TAR .EQ. 12.D0 ) THEN LATARG = 6 ELSE LATARG = NINT( TAR )/2 ENDIF #else ELSE WRITE(MONIOU,*) 'VENLNK: UNDEFINED TARGET TAR=',SNGL(TAR) #endif ENDIF C FOR THE CASE OF AN ARBITRARY TARGET (NOT AIR) IF ( LTARG .GT. 3 ) THEN MASSNR = MATARG IF ( MASSNR .GT. 1 ) THEN IF ( MASSNR .NE. MTAR99 ) THEN R0 = 1.19*MASSNR**(.3333333) -1.61*MASSNR**(-.3333333) CX = R0+FCTRMX*0.54 RMTARG(4) = CX CALL UTQUAF( SDENSI,NDET,XDET99,QDET99,0.,.33*CX,.66*CX,CX ) MTAR99 = MATARG ENDIF ELSE RMTARG(4) = 0. ENDIF ENDIF C SET PROJECTILE PARAMETERS IF ( ITYPE .LT. 200 ) THEN IDPROJ = IDTABL(ITYPE) IF ( IDPROJ .EQ. 20 .OR. IDPROJ .EQ. -20 ) THEN C TREAT NEUTRAL KAONS (K(0)S AND K(0)L) CALL RMMARD( RD,1,1 ) IF ( RD(1) .LE. 0.5D0 ) THEN IDPROJ = 230 ELSE IDPROJ = -230 ENDIF ELSEIF ( IDPROJ .EQ. 2130 ) THEN C VENUS CANNOT TREAT LAMBDA, TAKE INSTEAD SIGMA(0)) IDPROJ = 1230 ELSEIF ( IDPROJ .EQ. -2130 ) THEN C VENUS CANNOT TREAT ANTI-LAMBDA, TAKE INSTEAD ANTI-SIGMA(0)) IDPROJ = -1230 ENDIF C ALL OTHER PARTICLE CODES UNCHANGED CALL IDMASS( IDPROJ,AMPROJ ) LAPROJ = -1 MAPROJ = 1 CDH2003 PNLL = CURPAR(1)*AMPROJ PNLL = AMPROJ * BETA * GAMMA ELSE C PROJECTILE IS NUCLEUS IDPROJ = 1120 CALL IDMASS( IDPROJ,AMPROJ ) LAPROJ = MOD(ITYPE,100) MAPROJ = ITYPE/100 CDH2003 PNLL = CURPAR(1)*(PAMA(14)+PAMA(13))*0.5 PNLL = 0.5 * (PAMA(14)+PAMA(13)) * BETA * GAMMA ENDIF IF ( ABS(IDPROJ) .LT. 1000 ) THEN IF ( ABS(IDPROJ) .EQ. 230 .OR. ABS(IDPROJ) .EQ. 130 ) THEN C DIFFRACTIVE PROBABILITY FOR KAON PROJECTILES WPROJ = 0.24 C DIFFRACTIVE PROBABILITY FOR TARGET (ALWAYS NUCLEONS) WTARG = 0.32 ELSEIF ( IDPROJ .EQ. 110 .OR. IDPROJ .EQ. 220 ) THEN C PI(0) AND ETA (ORIGINATING FROM GAMMA PROJECTILE) WITHOUT DIFFRACTION WPROJ = 0.002 C DIFFRACTIVE PROBABILITY FOR TARGET WTARG = 0.002 ELSE C DIFFRACTIVE PROBABILITY FOR PION PROJECTILES WPROJ = 0.20 C DIFFRACTIVE PROBABILITY FOR TARGET (ALWAYS NUCLEONS) WTARG = 0.32 ENDIF ELSE C DIFFRACTIVE PROBABILITY FOR BARYON PROJECTILES WPROJ = 0.32 C DIFFRACTIVE PROBABILITY FOR TARGET (ALWAYS NUCLEONS) WTARG = 0.32 ENDIF #if __INTTEST__ IF ( NDIF .EQ. 1 ) THEN WPROJ = 0.002 WTARG = 0.002 ELSEIF ( NDIF .EQ. 2 ) THEN WPROJ = 0.998 WTARG = 0.998 ENDIF #endif ENGY = SQRT( 2.*SQRT(PNLL**2+AMPROJ**2)*AMTARG+AMTARG**2 * +AMPROJ**2 ) IF ( DEBUG ) WRITE(MDEBUG,*) 'VENLNK: ELAB = ',PNLL, * ' ENGY = ',ENGY CDH IF ( ENGY .LT. 12. ) THEN IF ( ENGY .LT. 9.5 ) THEN WRITE(IFMT,*) 'VENLNK: ENGY, IDPROJ=',ENGY,IDPROJ CALL UTSTOP( 'VENLNK: INCIDENT ENERGY TOO SMALL ' ) ENDIF ENGYI = ENGY PNLLI = PNLL IF ( PNLL .LT. 1.E2 * AMPROJ ) THEN TRM = SQRT( PNLL**2 + AMPROJ**2 ) ENGY = SQRT( (TRM+AMTARG-PNLL) * (TRM+AMTARG+PNLL) ) ELSE TRM = AMPROJ**2*0.5/PNLL+AMTARG ENGY = SQRT( TRM * (2.*PNLL+TRM) ) ENDIF D1 = ABS(PNLLI-PNLL)/PNLL D2 = ABS(ENGYI-ENGY)/ENGY IF ( D1 .GT. 1.E-3 .OR. D2 .GT. 1.E-3 ) THEN IF ( ISH .GE. 0 ) THEN CALL UTMSG( 'VENLNK' ) WRITE(IFCH,*) '***** PNLL,PNLLI:',PNLL,PNLLI WRITE(IFCH,*) '***** ENGY,ENGYI:',ENGY,ENGYI CALL UTMSGF ENDIF ENDIF S = ENGY**2 SROOTI = 1./ENGY PNLLX = UTPCM(ENGY,AMPROJ,AMTARG) YHAHA = LOG( (SQRT( PNLL**2+S)+PNLL )/ENGY ) YPJTL = LOG( (SQRT( PNLL**2+AMPROJ**2 )+PNLL)/AMPROJ ) IF ( ISH .GE. 91 ) WRITE(IFCH,*) 'VENLNK: YPJTL=',YPJTL ENGYLG = LOG( ENGY ) QMUST = QMUST1+QMUST2*ENGYLG+QMUST3*ENGYLG**2 PTQ = PTQ1+PTQ2*ENGYLG+PTQ3*ENGYLG**2 CDH PHARD = 0.030+0.12*(LOG10(S)-LOG10(30.**2)) PHARD = 0.030+0.12*(LOG10(S)-2.9542425) PHARD = MIN( 1., PHARD ) PHARD = MAX( 0.030, PHARD ) C PROJECTILE XCUT = CUTMSQ*SROOTI XCUT2 = XCUT**2 IF ( ABS(IDPROJ) .GE. 1000 ) THEN C STRUCTURE FUNCTION INTEGRAL FOR BARYONS OF PROJECTILE IPIO = 0 CALL UINTEG( VALUE,SSE0,0.D0,1.D0,0.D0,1.D-5,1,ERRER,IFLAG ) IF ( IFLAG .GT. 3 .AND. ISH .GT. 0 ) * WRITE(IFCH,*) 'VENLNK: SSE0:IFLAG=',IFLAG QSEPC = VALUE CALL UINTEG( VALUE,SVA0,0.D0,1.D0,0.D0,1.D-5,1,ERRER,IFLAG ) IF ( IFLAG .GT. 3 .AND. ISH .GT. 0 ) * WRITE(IFCH,*) 'VENLNK: SVA0:IFLAG=',IFLAG QVAPC = VALUE ELSE C STRUCTURE FUNCTION INTEGRAL FOR MESONS OF PROJECTILE IPIO = 1 A0 = -5.0 + 6.6666667*XCUT2 - 0.53333333*XCUT2**2 A1 = 5.0 - 1.875*XCUT2 A2 = -3.3333333 + 0.26666667*XCUT2 A3 = 1.25 A4 = -0.2 ROOT = SQRT( XCUT2 + 1. ) QSEPC = 0.9*( (1.-XCUT2*A1)*( LOG( 1.+ROOT )-LOG( XCUT ) ) * - XCUT*A0 + ROOT*(A0+A1+A2+A3+A4) ) CALL UINTEG( VALUE,SVA1,0.D0,1.D0,0.D0,1.D-5,1,ERRER,IFLAG ) IF ( IFLAG .GT. 3 .AND. ISH .GT. 0 ) * WRITE(IFCH,*) 'VENLNK: SVA1:IFLAG=',IFLAG QVAPC = VALUE ENDIF IDTG = IPIO C TARGET IF ( IDTG .EQ. 1 ) THEN IF ( ABS(IDTARG) .GE. 1000 ) THEN C STRUCTURE FUNCTION INTEGRAL FOR BARYONS OF TARGET IPIO = 0 CALL UINTEG( VALUE,SSE0,0.D0,1.D0,0.D0,1.D-5,1,ERRER,IFLAG ) IF ( IFLAG .GT. 3 .AND. ISH .GT. 0 ) * WRITE(IFCH,*) 'VENLNK: SSE0:IFLAG=',IFLAG QSETC = VALUE CALL UINTEG( VALUE,SVA0,0.D0,1.D0,0.D0,1.D-5,1,ERRER,IFLAG ) IF ( IFLAG .GT. 3 .AND. ISH .GT. 0 ) * WRITE(IFCH,*) 'VENLNK: SVA0:IFLAG=',IFLAG QVATC = VALUE ELSE IPIO = 1 QVATC = QVAPC QSETC = QSEPC ENDIF ELSE IF ( ABS(IDTARG) .GE. 1000 ) THEN IPIO = 0 QVATC = QVAPC QSETC = QSEPC ELSE C STRUCTURE FUNCTION INTEGRAL FOR BARYONS OF TARGET IPIO = 1 A0 = -5.0 + 6.6666667*XCUT2 - 0.53333333*XCUT2**2 A1 = 5.0 - 1.875*XCUT2 A2 = -3.3333333 + 0.26666667*XCUT2 A3 = 1.25 A4 = -0.2 ROOT = SQRT( XCUT2 + 1. ) QSETC = 0.9*( (1.-XCUT2*A1)*( LOG( 1.+ROOT )-LOG( XCUT ) ) * - XCUT*A0 + ROOT*(A0+A1+A2+A3+A4) ) CALL UINTEG( VALUE,SVA1,0.D0,1.D0,0.D0,1.D-5,1,ERRER,IFLAG ) IF ( IFLAG .GT. 3 .AND. ISH .GT. 0 ) * WRITE(IFCH,*) 'VENLNK: SVA1:IFLAG=',IFLAG QVATC = VALUE ENDIF ENDIF IF ( ISH .EQ. 16 .OR. DEBUG ) THEN WRITE(IFCH,301) QVAPC, QSEPC, QVATC, QSETC 301 FORMAT(' VENLNK: QVAPC, QSEPC, QVATC, QSETC=',4(F10.7,2X)) ENDIF IF ( PROSEA .GE. 0. ) THEN QVAPC = 1.0 QVATC = 1.0 QSEPC = PROSEA QSETC = PROSEA ENDIF XCUT = CUTMSS*SROOTI XCUTAR = XCUT B = MIN( 0.05, XCUT*500. ) A = MIN( 0.2*B, XCUT*100. ) PNLLLG = LOG( PNLL ) DELTA0 = EXP( -2.791922 - 0.2091742 * PNLLLG ) DELTA1 = EXP( -3.885293 - 0.2029558 * PNLLLG ) CALL UTQSEA( A,B,1. ) IF ( XCUT .LT. 0.04 ) THEN NEND = 1.+REAL(NSTRUC)*2./PI*ACOS(1.-2./PI*ACOS(1.-25.*XCUT)) ELSE NEND = NSTRUC ENDIF IF ( ABS(IDPROJ) .GE. 1000 ) THEN IPIO = 0 DO N = 1, NSTRUC QSEP(N) = QSEH(N) ENDDO DO N = NEND, NSTRUC QVAP(N) = QVAH(N) - DELTA0 ENDDO ELSE IPIO = 1 DO N = 1, NSTRUC QSEP(N) = QSEPI(N) ENDDO DO N = NEND, NSTRUC QVAP(N) = QVAPI(N) - DELTA1 ENDDO ENDIF CALL UTQVAL( QVAP,NEND ) IF ( IDTG .EQ. 0 ) THEN IF ( ABS(IDTARG) .GE. 1000 ) THEN IPIO = 0 DO N = 1, NSTRUC QSET(N) = QSEP(N) QVAT(N) = QVAP(N) ENDDO ELSE IPIO = 1 DO N = 1, NSTRUC QSET(N) = QSEPI(N) ENDDO DO N = NEND, NSTRUC QVAT(N) = QVAPI(N) - DELTA1 ENDDO CALL UTQVAL( QVAT,NEND ) ENDIF ELSE IF ( ABS(IDTARG) .GE. 1000 ) THEN IPIO = 0 DO N = 1, NSTRUC QSET(N) = QSEH(N) ENDDO DO N = NEND, NSTRUC QVAT(N) = QVAH(N) - DELTA0 ENDDO CALL UTQVAL( QVAT,NEND ) ELSE IPIO = 1 DO N = 1, NSTRUC QSET(N) = QSEP(N) QVAT(N) = QVAP(N) ENDDO ENDIF ENDIF IF ( ISH .EQ. 21 ) THEN CALL UTHSEA CALL UTSTOP( ' VENLNK: ' ) ENDIF QPTHMX = 0.5/PTH**2-PTH**2/(2.*(PTH**2+PTMX**2)**2) IF ( IOPTQ .EQ. 2 ) THEN QPTQMX = 1. - EXP( (-PI)*PTMX**2/(4.*PTQ**2) ) ELSEIF ( IOPTQ .EQ. 3 ) THEN QPTQMX = 1. - PTQ**2/(PTQ**2+PTMX**2) ELSE CX = PTMX CALL UTQUAF( SPTQ,NPTQ,XPTQ,QPTQ,0.,.33*CX,.66*CX,CX ) ENDIF SIGPPI = -1.0 C CALCULATE ENERGY DEPENDENT CROSS-SECTION FOR BARYONS CALL RACPRO( 'GRI',QMUST,NPRBMS,PRBMS ) IF ( ABS(IDPROJ) .LE. 120 .OR. ABS(IDPROJ) .EQ. 220 ) THEN C CROSS-SECTION FOR PIONS (OR ETA FOR GAMMA FROM EGS) SIGPPI = SIGPPI * 0.6667 ELSEIF ( ABS(IDPROJ) .EQ. 130 .OR. ABS(IDPROJ) .EQ. 230 ) THEN C CROSS-SECTION FOR KAONS SIGPPI = SIGPPI * 0.5541 ENDIF MASSNR = MAPROJ RMPROJ = 0. IF ( MASSNR .GT. 1 ) THEN R0 = 1.19*MASSNR**(.3333333) -1.61*MASSNR**(-.3333333) CX = R0+FCTRMX*0.54 RMPROJ = CX CALL UTQUAF( SDENSI,NDEP,XDEP,QDEP,0.,.33*CX,.66*CX,CX ) ENDIF IF ( IDPM .EQ. 1 ) THEN QSEPC = 0. QSETC = 0. ENDIF BMAX = RMPROJ+RMTARG(LTARG) IF ( ISH .GE. 91 ) WRITE(IFCH,*) 'VENLNK: AVENUS IS NOW CALLED' CALL AVENUS C NOW BRING PARTICLES TO CORSIKA STACK CALL VSTORE IF ( ISH .GE. 91 ) WRITE(IFCH,*) 'VENLNK: (EXIT)' RETURN END *-- Author : D. HECK IK FZK KARLSRUHE 21/11/1996 C======================================================================= SUBROUTINE VENSIG( ELAB,ITYPV ) C----------------------------------------------------------------------- C VEN(US) SIG(MAS) C C CALCULATES INELASTIC HADRON-AIR CROSS-SECTIONS FOR VENUS MODEL. C NUCLEUS-AIR CROSS-SECTIONS ARE DETERMINED BY P-P CROSS-SECTIONS AND C THE CORSIKA GLAUBER TABLES (SEE BOX2). C THIS SUBROUTINE IS CALLED FROM BOX2. C ARGUMENTS: C ELAB = LABORATORY ENERGY (GEV) C ITYPV = HADRON TYPE: 1 = NUCLEON, 2 = PION, 3 = KAON C----------------------------------------------------------------------- IMPLICIT NONE #define __PARPARINC__ #define __RUNPARINC__ #define __SIGMINC__ #define __VENSSGINC__ #include "corsika.h" DOUBLE PRECISION DELTAE,ELAB,SECT,WK(3),YE INTEGER I,ITYPV,JE SAVE C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'VENSIG: ELAB=',SNGL(ELAB), * ' ITYPV=',ITYPV C DETERMINE ENERGY INTERVAL FOR INTERPOLATION YE = DLOG10(ELAB) IF ( YE .LT. 1.D0 ) YE = 1.D0 JE = INT( YE ) IF ( JE .GT. 9 ) JE = 9 DELTAE = YE - JE WK(3) = DELTAE * (DELTAE-1.D0) * .5D0 WK(1) = 1.D0 - DELTAE + WK(3) WK(2) = DELTAE - 2.D0 * WK(3) IF ( ITYPV .EQ. 1 ) THEN C FOR BARYON PROJECTILES SECT = 0.D0 DO I = 1, 3 SECT = SECT + SGVPL(JE+I-1)*WK(I) ENDDO SIGAIR = EXP( SECT ) SECT = 0.D0 DO I = 1, 3 SECT = SECT + FRNVPL(JE+I-1)*WK(I) ENDDO FRACTN = EXP( SECT ) SECT = 0.D0 DO I = 1, 3 SECT = SECT + FRNOVPL(JE+I-1)*WK(I) ENDDO FRCTNO = EXP( SECT ) SIGMA = 0.D0 ELSEIF ( ITYPV .EQ. 2 ) THEN C FOR PION PROJECTILES SECT = 0.D0 DO I = 1, 3 SECT = SECT + SGVPIL(JE+I-1)*WK(I) ENDDO SIGAIR = EXP( SECT ) SECT = 0.D0 DO I = 1, 3 SECT = SECT + FRNVPIL(JE+I-1)*WK(I) ENDDO FRACTN = EXP( SECT ) SECT = 0.D0 DO I = 1, 3 SECT = SECT + FRNOVPIL(JE+I-1)*WK(I) ENDDO FRCTNO = EXP( SECT ) SIGMA = 0.D0 ELSEIF ( ITYPV .EQ. 3 ) THEN C FOR KAON PROJECTILES SECT = 0.D0 DO I = 1, 3 SECT = SECT + SGVKL(JE+I-1)*WK(I) ENDDO SIGAIR = EXP( SECT ) SECT = 0.D0 DO I = 1, 3 SECT = SECT + FRNVKL(JE+I-1)*WK(I) ENDDO FRACTN = EXP( SECT ) SECT = 0.D0 DO I = 1, 3 SECT = SECT + FRNOVKL(JE+I-1)*WK(I) ENDDO FRCTNO = EXP( SECT ) SIGMA = 0.D0 ELSEIF ( ITYPV .GE. 200 ) THEN C FOR NUCLEUS PROJECTILES DETERMINE ONLY NN CROSS-SECTION SIGAIR = 0.D0 FRACTN = 0.D0 FRCTNO = 0.D0 SIGMA = 0.D0 DO I = 1, 3 SIGMA = SIGMA + SVPPL(JE+I-1)*WK(I) ENDDO SIGMA = EXP( SIGMA ) ELSE #if __THIN__ WRITE(MONIOU,444) (CURPAR(I),I=0,9),CURPAR(13) 444 FORMAT(' VENSIG: CURPAR=',1P,11E11.3) #else WRITE(MONIOU,444) (CURPAR(I),I=0,9) 444 FORMAT(' VENSIG: CURPAR=',1P,10E11.3) #endif WRITE(MONIOU,*) 'VENSIG: ILLEGAL PROJECTILE TYP =',ITYPV STOP ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) 'VENSIG: SIGMA=',SNGL(SIGMA), * ' SIGAIR=',SNGL(SIGAIR) RETURN END *-- Author : D. HECK IK FZK KARLSRUHE 21/11/1996 C======================================================================= SUBROUTINE VENSIGINI C----------------------------------------------------------------------- C VEN(US) SIG(MAS) INI(TIALIZATION) C C INITIALIZES INELASTIC CROSS-SECTION. C THIS SUBROUTINE IS CALLED FROM START. C----------------------------------------------------------------------- IMPLICIT NONE #define __RUNPARINC__ #define __VENSSGINC__ #include "corsika.h" DOUBLE PRECISION AI,ELAB(11),FRNVK(11),FRNVPI(11),FRNVP(11), * FRNOVK(11),FRNOVPI(11),FRNOVP(11), * SIGP(11),SIGPI(11),SIGK(11), SPP(11) INTEGER I SAVE C THE CROSS-SECTION TABLES START AT ELAB=10., 100., 1000., .... C BUT AFTERWARDS IS USED ONLY ABOVE 80 GEV C PROTON AIR INELASTIC CROSS-SECTION DATA SIGP /0.241E+03, * 0.264E+03,0.287E+03,0.311E+03,0.334E+03,0.358E+03, * 0.381E+03,0.405E+03,0.429E+03,0.454E+03,0.478E+03/ C PION AIR INELASTIC CROSS-SECTION DATA SIGPI/0.182E+03, * 0.201E+03,0.222E+03,0.242E+03,0.263E+03,0.284E+03, * 0.303E+03,0.323E+03,0.346E+03,0.363E+03,0.386E+03/ C KAON AIR INELASTIC CROSS-SECTION DATA SIGK /0.157E+03, * 0.176E+03,0.195E+03,0.215E+03,0.234E+03,0.253E+03, * 0.270E+03,0.290E+03,0.311E+03,0.328E+03,0.348E+03/ C PROTON NITROGEN INELASTIC CROSS-SECTION DATA FRNVP /0.184E+03, * 0.202E+03,0.219E+03,0.239E+03,0.255E+03,0.276E+03, * 0.289E+03,0.311E+03,0.329E+03,0.349E+03,0.368E+03/ C PION NITROGEN INELASTIC CROSS-SECTION DATA FRNVPI/0.137E+03, * 0.153E+03,0.169E+03,0.185E+03,0.201E+03,0.217E+03, * 0.232E+03,0.246E+03,0.265E+03,0.278E+03,0.296E+03/ C KAON NITROGEN INELASTIC CROSS-SECTION DATA FRNVK /0.119E+03, * 0.134E+03,0.149E+03,0.164E+03,0.179E+03,0.194E+03, * 0.207E+03,0.221E+03,0.239E+03,0.251E+03,0.266E+03/ C PROTON NITROGEN+OXYGEN INELASTIC CROSS-SECTION DATA FRNOVP /0.238E+03, * 0.261E+03,0.284E+03,0.309E+03,0.331E+03,0.357E+03, * 0.375E+03,0.401E+03,0.424E+03,0.450E+03,0.474E+03/ C PION NITROGEN+OXYGEN INELASTIC CROSS-SECTION DATA FRNOVPI/0.178E+03, * 0.199E+03,0.220E+03,0.240E+03,0.261E+03,0.281E+03, * 0.300E+03,0.319E+03,0.343E+03,0.360E+03,0.382E+03/ C KAON NITROGEN+OXYGEN INELASTIC CROSS-SECTION DATA FRNOVK /0.157E+03, * 0.175E+03,0.193E+03,0.212E+03,0.232E+03,0.251E+03, * 0.268E+03,0.287E+03,0.308E+03,0.325E+03,0.345E+03/ C PROTON PROTON INELASTIC CROSS-SECTION * DATA SPP / 24.705D0, * * 28.749D0,33.001D0,37.675D0,42.785D0,48.348D0, * * 54.381D0,60.897D0,67.905D0,75.415D0,83.433D0 / C PROTON PROTON INELASTIC CROSS-SECTION (INCLUDING DIFFRACTION) C (MODIFIED APR 2ND, 1997) DATA SPP / 27.444D0, * 31.599D0,36.382D0,41.693D0,47.555D0,54.000D0, * 61.059D0,68.756D0,77.113D0,86.146D0,95.870D0 / C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'VENSIGINI: START' C FORM LOGARITH OF THE CROSS-SECTIONS FOR BETTER INTERPOLATION DO I = 1, 11 SGVPL(I) = LOG( SIGP(I) ) SGVPIL(I) = LOG( SIGPI(I) ) SGVKL(I) = LOG( SIGK(I) ) FRNVKL(I) = LOG( FRNVK(I) ) FRNVPIL(I) = LOG( FRNVPI(I) ) FRNVPL(I) = LOG( FRNVP(I) ) FRNOVKL(I) = LOG( FRNOVK(I) ) FRNOVPIL(I) = LOG( FRNOVPI(I) ) FRNOVPL(I) = LOG( FRNOVP(I) ) SVPPL(I) = LOG( SPP(I) ) ENDDO IF ( DEBUG ) THEN WRITE(MDEBUG,25) 25 FORMAT(' LOGARITHMS OF THE INELASTIC CROSS-SECTIONS (MBARN)',/, * ' ELAB(GEV) SIG(P,P) ', * 'SIG(P,AIR) SG(PI,AIR) SIG(K,AIR)') DO I = 1, 11 AI = DBLE(I) ELAB(I) = 10.D0**AI WRITE(MDEBUG,26) ELAB(I),SVPPL(I), * SGVPL(I),SGVPIL(I),SGVKL(I) 26 FORMAT(1X,1P,E9.3,4(1X,E10.4)) ENDDO WRITE(MDEBUG,*) 'VENSIGINI: END' ENDIF RETURN END *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE VSTORE C----------------------------------------------------------------------- C V(ENUS PARTICLES) STORE (INTO CORSIKA STACK) C C STORES VENUS OUTPUT PARTICLES INTO CORSIKA STACK. C THIS SUBROUTINE IS CALLED FROM VENLNK. C----------------------------------------------------------------------- #define __CONSTAINC__ #define __DPMFLGINC__ #define __ELADPMINC__ #define __ELASTYINC__ #define __INTERINC__ #define __ISTAINC__ #define __LONGIINC__ #define __MULTINC__ #define __PAMINC__ #define __PARPARINC__ #define __PARPAEINC__ #define __RANDPAINC__ #define __RESTINC__ #define __RUNPARINC__ #define __SIGMINC__ #if __AUGERHIST__ || __EHISTORY__ #define __GENERINC__ #endif #if __AUGERHIST__ || __COASTUSERLIB__ #define __OBSPARINC__ #endif #if __INTTEST__ #define __TSTINTINC__ #endif #include "corsika.h" PARAMETER (KOLLMX=2500) PARAMETER (MXPTL=70000) PARAMETER (MXSTR=3000) PARAMETER (NDEP=129) PARAMETER (NDET=129) COMMON /ACCUM/ AMSAC,ILAMAS,IMSG,INOIAC,IPAGE,JERR,NAEVT,NREVT * ,NRPTL,NRSTR,NTEVT COMMON /CEVT/ BIMEVT,COLEVT,EGYEVT,PHIEVT,PMXEVT * ,KOLEVT,NEVT,NPJEVT,NTGEVT COMMON /COL/ BIMP,BMAX,COORD(4,KOLLMX),DISTCE(KOLLMX) * ,QDEP(NDEP),QDET14(NDET),QDET16(NDET),QDET40(NDET) * ,QDET99(NDET),RMPROJ,RMTARG(4),XDEP(NDEP) * ,XDET14(NDET),XDET16(NDET),XDET40(NDET) * ,XDET99(NDET) * ,KOLL,LTARG,NORD(KOLLMX),NPROJ,NRPROJ(KOLLMX) * ,NRTARG(KOLLMX),NTARG COMMON /CPTL/ PPTL(5,MXPTL),TIVPTL(2,MXPTL),XORPTL(4,MXPTL) * ,IBPTL(4,MXPTL),ICLPTL(MXPTL),IDPTL(MXPTL) * ,IFRPTL(2,MXPTL),IORPTL(MXPTL),ISTPTL(MXPTL) * ,JORPTL(MXPTL),NPTL,NQJPTL(MXPTL) COMMON /CSTR/ PSTR(5,MXSTR),ROTSTR(3,MXSTR),XORSTR(4,MXSTR) * ,ICSTR(4,MXSTR),IORSTR(MXSTR),IRLSTR(MXSTR),NSTR COMMON /FILES/ IFCH,IFDT,IFHI,IFMT,IFOP COMMON /PARO2/ AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY * ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA * ,YHAHA,YMXIMI,YPJTL * ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM * ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH * ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI * ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG * ,MODSHO,NDECAX,NDECAY,NEVENT COMMON /PARO3/ ASUHAX(7),ASUHAY(7),OMEGA,SIGPPD,SIGPPE,UENTRO * ,IWZZZZ DOUBLE PRECISION EA,ELASTI,EMAX,COSTET,PL2,PTOT,PT2,PTM DOUBLE PRECISION FAC1,FAC2 CC DOUBLE PRECISION GAMMAX DOUBLE PRECISION PFRX(60),PFRY(60),CPHIV,SPHIV INTEGER ITYP(60),NRPTLA(MXPTL),LL #if __EHISTORY__ INTEGER IK #endif #if __COASTUSERLIB__ c definition of the COAST crs::CInteraction class COMMON/coastInteraction/coastX, coastY, coastZ, & coastE, coastCX, coastEl, coastProjId, coastTargId, & coastT double precision coastX, coastY, coastZ double precision coastE, coastCX, coastEl double precision coastT integer coastProjId, coastTargId #endif SAVE #if __AUGERHIST__ DOUBLE PRECISION EDEP,THICKLOC,THICK INTEGER II EXTERNAL THICK #endif C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'VSTORE:' C NUMBER OF SPECTATORS OF REMAINING NUCLEUS IS NREST NREST = ITYPE/100 - NPJEVT IREST = ITYPE #if __INTTEST__ IWOUNP = NPJEVT IWOUNT = NTGEVT #endif NNEW = 0 INEW = 0 ETOT = 0. ELASTI = 0. NZNEW = 0 NNNEW = 0 KNEW = 0 LEVT = 1 LPTL = 3 NPTLS = 0 DO 1 I = 1, NPTL NRPTLA(I) = -999 IF ( ISTPTL(I) .GT. ISTMAX ) GOTO 1 NPTLS = NPTLS+1 NRPTLA(I) = NPTLS 1 CONTINUE C EVENT VARIABLES: C LEVT................... RECORD LABEL (LEVT=1) C NREVT.................. EVENT NUMBER C NPTLS ................. NUMBER OF (STORED!) PARTICLES PER EVENT C BIMEVT ................ IMPACT PARAMETER C KOLEVT,COLEVT ......... REAL/EFFECTIVE # OF COLLISIONS C PMXEVT ................ REFERENCE MOMENTUM C EGYEVT ................ PP CM ENERGY (HAD) OR STRING ENERGY (STR) C NPJEVT,NTGEVT ......... # OF PROJ/TARG PARTICIPANTS GNU = KOLEVT GNU = COLEVT CC GAMMAX = 0.D0 EMAX = 0.D0 #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME GRANDMOTHER PARTICLE DO IK = 0, 6 SECPAR(28+IK) = CURPAR(IK) ENDDO C STORE GENERATION COUNTER OF MOTHER SECPAR(35) = GEN C STORE MASS PENETRATION BEFORE INTERACTION SECPAR(36) = CURPAR(9) #if __THIN__ SECPAR(37) = CURPAR(13) #endif #endif C PARTICLE LOOP DO 5 I = 1, NPTL IF ( NRPTLA(I) .LE. 0 ) GOTO 5 C PARTICLE VARIABLES: C LPTL ......... RECORD LABEL (LPTL=3) C NREVT ........ EVENT NUMBER C NRPTL ........ PARTICLE NUMBER C I ............ ORIGINAL PTL NUMBER C IDPTL ........ PARTICLE ID C PPTL ......... 5-MOMENTUM (PX,PY,PZ,EN,MASS) IN LAB C IOPTL ........ ORIGIN (-999:PARENT NOT STORED, -1,0:NO PARENT) C JOPTL ........ ORIGIN (SECOND PARENT) C ISTPTL ....... STABLE (=0) OR NOT (=1) C XORPTL ....... SPACE-TIME POINT (X,Y,Z,T) ON PTL TRACK (PP-CM) C TIVPTL ....... TIME INTERVAL OF EXISTENCE C NQJPTL ....... QUARK NUMBERS OF JETS #if !__INTTEST__ C ELIMINATE TARGET SPECTATORS IF ( PPTL(3,I) .EQ. 0. ) GOTO 5 C ELIMINATE BACKWARD GOING PARTICLES IF ( .NOT. LLONGI .AND. PPTL(3,I) .LT. 0. ) GOTO 5 #endif C CONVERT PARTICLE CODE VEN(US) ---> C(O)RS(IKA) C MOST FREQUENT PARTICLES COME FIRST KODVEN = IDPTL(I) C MESONS IF ( KODVEN .EQ. 110 ) THEN KODCRS = 7 ELSEIF ( KODVEN .EQ. 120 ) THEN KODCRS = 8 ELSEIF ( KODVEN .EQ. -120 ) THEN KODCRS = 9 ELSEIF ( KODVEN .EQ. 220 ) THEN KODCRS = 17 C NUCLEONS ELSEIF ( KODVEN .EQ. 1220 ) THEN KODCRS = 13 ELSEIF ( KODVEN .EQ. 1120 ) THEN KODCRS = 14 ELSEIF ( KODVEN .EQ. -1120 ) THEN KODCRS = 15 ELSEIF ( KODVEN .EQ. -1220 ) THEN KODCRS = 25 C STRANGE MESONS ELSEIF ( KODVEN .EQ. -20 ) THEN KODCRS = 10 ELSEIF ( KODVEN .EQ. 130 ) THEN KODCRS = 11 ELSEIF ( KODVEN .EQ. -130 ) THEN KODCRS = 12 ELSEIF ( KODVEN .EQ. 20 ) THEN KODCRS = 16 C STRANGE BARYONS ELSEIF ( KODVEN .EQ. 2130 ) THEN KODCRS = 18 ELSEIF ( KODVEN .EQ. 1130 ) THEN KODCRS = 19 ELSEIF ( KODVEN .EQ. 1230 ) THEN KODCRS = 20 ELSEIF ( KODVEN .EQ. 2230 ) THEN KODCRS = 21 ELSEIF ( KODVEN .EQ. 1330 ) THEN KODCRS = 22 ELSEIF ( KODVEN .EQ. 2330 ) THEN KODCRS = 23 ELSEIF ( KODVEN .EQ. 3331 ) THEN KODCRS = 24 ELSEIF ( KODVEN .EQ. -2130 ) THEN KODCRS = 26 ELSEIF ( KODVEN .EQ. -1130 ) THEN KODCRS = 27 ELSEIF ( KODVEN .EQ. -1230 ) THEN KODCRS = 28 ELSEIF ( KODVEN .EQ. -2230 ) THEN KODCRS = 29 ELSEIF ( KODVEN .EQ. -1330 ) THEN KODCRS = 30 ELSEIF ( KODVEN .EQ. -2330 ) THEN KODCRS = 31 ELSEIF ( KODVEN .EQ. -3331 ) THEN KODCRS = 32 C LEPTONS ELSEIF ( KODVEN .EQ. 10 ) THEN KODCRS = 1 ELSEIF ( KODVEN .EQ. -12 ) THEN KODCRS = 2 ELSEIF ( KODVEN .EQ. 12 ) THEN KODCRS = 3 ELSEIF ( KODVEN .EQ. -14 ) THEN KODCRS = 5 ELSEIF ( KODVEN .EQ. 14 ) THEN KODCRS = 6 #if __NEUTRINO__ ELSEIF ( KODVEN .EQ. 11 ) THEN KODCRS = 66 ELSEIF ( KODVEN .EQ. -11 ) THEN KODCRS = 67 ELSEIF ( KODVEN .EQ. 13 ) THEN KODCRS = 68 ELSEIF ( KODVEN .EQ. -13 ) THEN KODCRS = 69 #else C NEUTRINOS ARE SKIPPED ELSEIF ( KODVEN .EQ. 11 ) THEN GOTO 55 ELSEIF ( KODVEN .EQ. -11 ) THEN GOTO 55 ELSEIF ( KODVEN .EQ. 13 ) THEN GOTO 55 ELSEIF ( KODVEN .EQ. -13 ) THEN GOTO 55 #endif ELSE WRITE(MONIOU,*)'VSTORE: UNKNOWN PARTICLE CODE IDPTL=',IDPTL(I) GOTO 5 ENDIF SECPAR(0) = KODCRS C ELIMINATE BACKWARD GOING PARTICLES IF ( LLONGI .AND. PPTL(3,I) .LT. 0. ) GOTO 56 IF ( KODCRS .NE. 1 .AND. KODCRS .LE. 65 ) THEN C ORDINARY SECONDARY PARTICLES SECPAR(1) = PPTL(4,I)/PAMA(KODCRS) C LOOK FOR SPECTATOR NUCLEONS IF ( KODCRS .EQ. 13 .OR. KODCRS .EQ. 14 ) THEN #if !__INTTEST__ C ELIMINATE TARGET SPECTATORS IF ( SECPAR(1) .LE. 1.002D0 ) GOTO 5 #endif C TREAT PROJECTILE SPECTATORS IF ( SECPAR(1) .GT. 0.999D0*GAMMA .AND. * SECPAR(1) .LT. 1.001D0*GAMMA .AND. * PPTL(1,I) .EQ. 0. .AND. PPTL(2,I) .EQ. 0. ) THEN IF ( NFRAGM .NE. 0 ) THEN C COMPOSE PROJECTILE SPECTATORS TO REMAINING NUCLEUS NREST = NREST - 1 NNEW = NNEW + 1 IF ( KODCRS .EQ. 14 ) THEN INEW = INEW + 101 IREST = IREST - 101 ELSEIF ( KODCRS .EQ. 13 ) THEN INEW = INEW + 100 IREST = IREST - 100 ENDIF #if !__INTTEST__ GOTO 5 #endif ENDIF C DISREGARD PROJECTILE SPECTATORS FOR ELASTICITY GOTO 7 ENDIF ENDIF CC IF ( SECPAR(1) .GT. GAMMAX ) THEN CC GAMMAX = SECPAR(1) C CALCULATE ELASTICITY FROM ENERGY OF FASTEST PARTICLE (LEADER) CC ELASTI = GAMMAX * PAMA(KODCRS) / ELAB CC ENDIF IF ( SECPAR(1)*PAMA(KODCRS) .GT. EMAX ) THEN EMAX = SECPAR(1)*PAMA(KODCRS) C CALCULATE ELASTICITY FROM MOST ENERGETIC PARTICLE (LEADER) ELASTI = EMAX * MAPROJ / ELAB ENDIF ELSE C GAMMAS AND NEUTRINOS SECPAR(1) = PPTL(4,I) ENDIF C COUNTER FOR ENERGY-MULTIPLICITY MATRIX MSMM = MSMM + 1 C DETERMINE ANGLES FROM LONGITUDINAL AND TRANSVERSAL MOMENTA 7 CONTINUE PT2 = DBLE( PPTL(1,I) )**2 + DBLE( PPTL(2,I) )**2 PL2 = DBLE( PPTL(3,I) )**2 IF ( PL2+PT2 .LE. 0.D0 ) THEN PTOT = 0.D0 COSTET = 0.D0 CPHIV = 1.D0 SPHIV = 0.D0 ELSE PTOT = SQRT( PL2 + PT2 ) COSTET = DBLE( PPTL(3,I) ) / PTOT COSTET = MAX( MIN(COSTET, 1.D0), -1.D0 ) CPHIV = DBLE( PPTL(2,I) ) / PTOT SPHIV = DBLE( PPTL(1,I) ) / PTOT ENDIF #if __INTTEST__ C IF ( COSTET .EQ. 0.D0 ) COSTET = 1.D-4 SECPAR(17) = SQRT( PPTL(1,I)**2 + PPTL(2,I)**2 ) #endif C COUNTERS FOR FIRST INTERACTION IF ( FIRSTI ) THEN IF ( SECPAR(0) .EQ. 7.D0 .OR. SECPAR(0) .EQ. 8.D0 * .OR. SECPAR(0) .EQ. 9.D0 ) THEN IFINPI = IFINPI + 1 ELSEIF ( SECPAR(0) .EQ. 13.D0 .OR. SECPAR(0) .EQ. 14.D0 * .OR. SECPAR(0) .EQ. 15.D0 .OR. SECPAR(0) .EQ. 25.D0) THEN IFINNU = IFINNU + 1 ELSEIF ( SECPAR(0) .EQ. 10.D0 .OR. SECPAR(0) .EQ. 11.D0 * .OR. SECPAR(0) .EQ. 12.D0 .OR. SECPAR(0) .EQ. 16.D0) THEN IFINKA = IFINKA + 1 ELSEIF ( SECPAR(0) .EQ. 17.D0 ) THEN IFINET = IFINET + 1 ELSEIF ((SECPAR(0) .GE. 18.D0 .AND. SECPAR(0) .LE. 24.D0) * .OR. (SECPAR(0) .GE. 26.D0 .AND. SECPAR(0) .LE. 32.D0))THEN IFINHY = IFINHY + 1 ELSEIF ( SECPAR(0) .GE .51.D0 .AND. SECPAR(0) .LE. 53.D0) THEN IFINRHO = IFINRHO + 1 ELSE IFINOT = IFINOT + 1 ENDIF ENDIF ETOT = ETOT + PPTL(4,I) CALL ADDANG4( COSTHE,PHIX,PHIY, COSTET,CPHIV,SPHIV, * SECPAR(2),SECPAR(3),SECPAR(4) ) #if __UPWARD__ IF ( SECPAR(2) .GE. -1.D0 ) THEN #else IF ( SECPAR(2) .GT. C(29) ) THEN #endif #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER PARTICLE DO IK = 0, 8 SECPAR(IK+17) = SECPAR(IK) ENDDO #if __THIN__ SECPAR(26) = SECPAR(13) #endif #endif CALL TSTACK GOTO 5 ELSE GOTO 56 ENDIF #if !__NEUTRINO__ 55 IF ( LLONGI ) THEN C ADD NEUTRINO ENERGY TO LONGITUDINAL ENERGY DEPOSIT #if __THIN__ DLONG(LHEIGH,8) = DLONG(LHEIGH,8) + PPTL(4,I) * WEIGHT #else DLONG(LHEIGH,8) = DLONG(LHEIGH,8) + PPTL(4,I) #endif ENDIF GOTO 5 #endif 56 IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT IF ( KODCRS .LE. 3 ) THEN #if __THIN__ DLONG(LHEIGH,13) = DLONG(LHEIGH,13) * + ( PPTL(4,I) - RESTMS(KODCRS) ) * WEIGHT ELSEIF ( KODCRS .EQ. 5 .OR. KODCRS .EQ. 6 ) THEN DLONG(LHEIGH,15) = DLONG(LHEIGH,15) + PPTL(4,I) * WEIGHT #if __NEUTRINO__ ELSEIF ( KODCRS .GE. 66 .AND. KODCRS .LE. 69 ) THEN DLONG(LHEIGH,18) = DLONG(LHEIGH,18) + PPTL(4,I) * WEIGHT #endif ELSE IF ( KODCRS .EQ. 8 .OR. KODCRS .EQ. 9 .OR. * KODCRS .EQ. 11 .OR. KODCRS .EQ. 12 ) THEN FAC1 = 0.25D0 FAC2 = 0.75D0 ELSEIF ( KODCRS .EQ. 10 .OR. KODCRS .EQ. 16 ) THEN FAC1 = 0.5D0 FAC2 = 0.5D0 ELSE FAC1 = 1.D0 FAC2 = 0.D0 ENDIF C ADD TO THE HADRON ENERGY DEPOSIT DLONG(LHEIGH,17) = DLONG(LHEIGH,17) * + ( PPTL(4,I) - RESTMS(KODCRS) ) * WEIGHT*FAC1 C ADD TO THE NEUTRINO DEPOSIT DLONG(LHEIGH,18) = DLONG(LHEIGH,18) * + ( PPTL(4,I) - RESTMS(KODCRS) ) * WEIGHT*FAC2 #else DLONG(LHEIGH,13) = DLONG(LHEIGH,13) + PPTL(4,I) * - RESTMS(KODCRS) ELSEIF ( KODCRS .EQ. 5 .OR. KODCRS .EQ. 6 ) THEN DLONG(LHEIGH,15) = DLONG(LHEIGH,15) + PPTL(4,I) #if __NEUTRINO__ ELSEIF ( KODCRS .GE. 66 .AND. KODCRS .LE. 69 ) THEN DLONG(LHEIGH,18) = DLONG(LHEIGH,18) + PPTL(4,I) #endif ELSE IF ( KODCRS .EQ. 8 .OR. KODCRS .EQ. 9 .OR. * KODCRS .EQ. 11 .OR. KODCRS .EQ. 12 ) THEN FAC1 = 0.25D0 FAC2 = 0.75D0 ELSEIF ( KODCRS .EQ. 10 .OR. KODCRS .EQ. 16 ) THEN FAC1 = 0.5D0 FAC2 = 0.5D0 ELSE FAC1 = 1.D0 FAC2 = 0.D0 ENDIF C ADD TO THE HADRON ENERGY DEPOSIT DLONG(LHEIGH,17) = DLONG(LHEIGH,17) * + ( PPTL(4,I) - RESTMS(KODCRS) ) * FAC1 C ADD TO THE NEUTRINO DEPOSIT DLONG(LHEIGH,18) = DLONG(LHEIGH,18) * + ( PPTL(4,I) - RESTMS(KODCRS) ) * FAC2 #endif ENDIF ENDIF #if __AUGERHIST__ THICKLOC = THICK( H ) DO LL = 1, NOBSLV IF ( THICKLOC .GE. THCKOB(LL) .AND. * THICKLOC .LT. THCKOB(LL)+SAMPTH ) THEN C THICKH IS WITHIN 1 G/CM^2 BELOW OBSLEV(LL) C BRING THE ENERGY BELOW ANGULAR CUT TO THE HISTO OF LEVEL LL DO II = 0, 8 OUTPAR(II) = SECPAR(II) ENDDO OUTPAR( 9) = GEN OUTPAR(10) = ALEVEL OUTPAR(13) = WEIGHT IF ( KODCRS .EQ. 1 ) THEN EDEP = OUTPAR(1) * WEIGHT ELSE EDEP = ( OUTPAR(1) * PAMA(KODCRS) * - RESTMS(KODCRS) ) * WEIGHT ENDIF IF ( KODCRS .EQ. 2 .OR. KODCRS .EQ. 3 ) * OUTPAR(1) = OUTPAR(1) * PAMA(2) C WE HAVE ANGULAR CUT CALL AUGERDEPFIL( EDEP,LL,1 ) ELSEIF ( THICKLOC .LT. THCKOB(LL) ) THEN GOTO 111 ENDIF ENDDO 111 CONTINUE #endif 5 CONTINUE IF ( DEBUG ) WRITE(MDEBUG,*) 'VSTORE: NTGEVT,ETOT =',NTGEVT,ETOT IF ( NFRAGM .NE. 0 .AND. INEW .GT. 0 ) THEN C TREAT REMAINING NUCLEUS IF ( DEBUG ) WRITE(MDEBUG,150) INEW,(CURPAR(I),I=1,8) 150 FORMAT(' VSTORE: REMNNT=',1P,I10,8E10.3) SECPAR(1) = CURPAR(1) SECPAR(2) = CURPAR(2) SECPAR(3) = CURPAR(3) SECPAR(4) = CURPAR(4) #if __INTTEST__ SECPAR(17) = CURPAR(17) #endif IF ( INEW .EQ. 100 ) THEN C REMAINING NUCLEUS IS SINGLE NEUTRON SECPAR(0) = 13.D0 #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER PARTICLE DO IK = 0, 8 SECPAR(IK+17) = SECPAR(IK) ENDDO #if __THIN__ SECPAR(26) = SECPAR(13) #endif #endif CALL TSTACK ETOT = ETOT + SECPAR(1) * PAMA(13) GOTO 140 ELSEIF ( INEW .EQ. 101 ) THEN C REMAINING NUCLEUS IS SINGLE PROTON SECPAR(0) = 14.D0 #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER PARTICLE DO IK = 0, 8 SECPAR(IK+17) = SECPAR(IK) ENDDO #if __THIN__ SECPAR(26) = SECPAR(13) #endif #endif CALL TSTACK ETOT = ETOT + SECPAR(1) * PAMA(14) GOTO 140 ELSEIF ( NFRAGM .GE. 2 ) THEN C REMAINING NUCLEUS IS EVAPORATING NUCLEONS AND ALPHA PARTICLES NZNEW = MOD(INEW,100) NNNEW = INEW/100 - NZNEW JFIN = 0 CALL VAPOR( MAPROJ,INEW,JFIN,ITYP,PFRX,PFRY ) IF ( JFIN .EQ. 0 ) GOTO 139 C LOOP TO TREAT THE REMANENTS OF THE DESINTEGRATED FRAGMENT KNEW = 0 DO 135 J = 1, JFIN EA = GAMMA * PAMA(ITYP(J)) IF (DEBUG) WRITE(MDEBUG,*) 'VSTORE: J,ITYP,EA=', * J,ITYP(J),EA C MOMENTA SQUARED PTM = ( EA - PAMA(ITYP(J)) ) * ( EA + PAMA(ITYP(J)) ) PT2 = PFRX(J)**2 + PFRY(J)**2 IF ( PT2 .GE. PTM ) THEN IF (DEBUG) WRITE(MDEBUG,*) 'VSTORE: PT REJECT PARTICLE',J GOTO 135 ENDIF IF ( PTM .GT. 0.D0 ) THEN PTOT = SQRT( PTM ) COSTET = SQRT( 1.D0 - PT2/PTM ) CPHIV = PFRX(J) / PTOT SPHIV = PFRY(J) / PTOT ELSE PTOT = 0.D0 COSTET = 0.D0 CPHIV = 1.D0 SPHIV = 0.D0 ENDIF CALL ADDANG4( COSTHE,PHIX,PHIY, COSTET,CPHIV,SPHIV, * SECPAR(2),SECPAR(3),SECPAR(4) ) #if __UPWARD__ IF ( SECPAR(2) .GE. -1.D0 ) THEN #else IF ( SECPAR(2) .GT. C(29) ) THEN #endif IF ( J .LT. JFIN ) THEN SECPAR(0) = ITYP(J) #if __INTTEST__ SECPAR(17) = SQRT( PT2 ) #endif #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER PARTICLE DO IK = 0, 8 SECPAR(IK+17) = SECPAR(IK) ENDDO #if __THIN__ SECPAR(26) = SECPAR(13) #endif #endif CALL TSTACK ELSE KNEW = ITYP(JFIN) ENDIF ELSE IF ( DEBUG ) WRITE(MDEBUG,*) * 'VSTORE: ANGLE REJECT PARTICLE',J IF ( LLONGI ) THEN C ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT #if __THIN__ DLONG(LHEIGH,17) = DLONG(LHEIGH,17) + ( EA * - RESTMS(ITYP(J)) ) * WEIGHT #else DLONG(LHEIGH,17) = DLONG(LHEIGH,17) +EA-RESTMS(ITYP(J)) #endif ENDIF #if __AUGERHIST__ THICKLOC = THICK( H ) DO LL = 1, NOBSLV IF ( THICKLOC .GE. THCKOB(LL) .AND. * THICKLOC .LT. THCKOB(LL)+SAMPTH ) THEN C THICKH IS WITHIN 1 G/CM^2 BELOW OBSLEV(LL) C BRING THE ENERGY BELOW ANGULAR CUT TO THE HISTO OF LEVEL LL OUTPAR(0) = ITYP(J) DO II = 1, 8 OUTPAR(II) = CURPAR(II) ENDDO OUTPAR( 9) = GEN OUTPAR(10) = ALEVEL OUTPAR(13) = WEIGHT EDEP = ( OUTPAR(1) * PAMA(ITYP(J)) * - RESTMS(ITYP(J)) ) * WEIGHT C WE HAVE ANGULAR CUT CALL AUGERDEPFIL( EDEP,LL,1 ) ELSEIF ( THICKLOC .LT. THCKOB(LL) ) THEN GOTO 112 ENDIF ENDDO 112 CONTINUE #endif ENDIF 135 CONTINUE ELSEIF ( NFRAGM .EQ. 1 ) THEN C REMAINING NUCLEUS IS ONE FRAGMENT NZNEW = MOD(INEW,100) NNNEW = INEW/100 - NZNEW KNEW = INEW ENDIF IF ( KNEW/100 .EQ. 5 ) THEN C REMAINING NUCLEUS: MASS 5 CANNOT BE TREATED IN BOX2 IF ( MOD(KNEW,100) .GE. 3 ) THEN C MASS 5: SPLIT OFF ONE PROTON SECPAR(0) = 14.D0 #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER PARTICLE DO IK = 0, 8 SECPAR(IK+17) = SECPAR(IK) ENDDO #if __THIN__ SECPAR(26) = SECPAR(13) #endif #endif CALL TSTACK KNEW = KNEW - 101 ELSE C MASS 5: SPLIT OFF ONE NEUTRON SECPAR(0) = 13.D0 #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER PARTICLE DO IK = 0, 8 SECPAR(IK+17) = SECPAR(IK) ENDDO #if __THIN__ SECPAR(26) = SECPAR(13) #endif #endif CALL TSTACK KNEW = KNEW - 100 ENDIF ELSEIF ( KNEW/100 .EQ. 8 ) THEN C REMAINING NUCLEUS: MASS 8 CANNOT BE TREATED IN BOX2 IF ( MOD(KNEW,100) .GE. 5 ) THEN C MASS 8: SPLIT OFF ONE PROTON SECPAR(0) = 14.D0 #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER PARTICLE DO IK = 0, 8 SECPAR(IK+17) = SECPAR(IK) ENDDO #if __THIN__ SECPAR(26) = SECPAR(13) #endif #endif CALL TSTACK KNEW = KNEW - 101 ELSEIF ( MOD(KNEW,100) .LE. 3 ) THEN C MASS 8: SPLIT OFF ONE NEUTRON SECPAR(0) = 13.D0 #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER PARTICLE DO IK = 0, 8 SECPAR(IK+17) = SECPAR(IK) ENDDO #if __THIN__ SECPAR(26) = SECPAR(13) #endif #endif CALL TSTACK KNEW = KNEW - 100 ELSE C MASS 8: SPLIT OFF ONE ALPHA PARTICLE SECPAR(0) = 402.D0 #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER PARTICLE DO IK = 0, 8 SECPAR(IK+17) = SECPAR(IK) ENDDO #if __THIN__ SECPAR(26) = SECPAR(13) #endif #endif CALL TSTACK KNEW = KNEW - 402 ENDIF ENDIF SECPAR(0) = KNEW #if __EHISTORY__ C COPY PARTICLE INFORMATION, LATER TO BECOME MOTHER PARTICLE DO IK = 0, 8 SECPAR(IK+17) = SECPAR(IK) ENDDO #if __THIN__ SECPAR(26) = SECPAR(13) #endif #endif CALL TSTACK ENDIF 139 ETOT = ETOT + SECPAR(1)*(PAMA(13)*NNNEW + PAMA(14)*NZNEW) 140 CONTINUE IF ( DEBUG ) WRITE(MDEBUG,*) 'VSTORE: ELASTI,ETOT,ELAB=', * SNGL(ELASTI),ETOT,ELAB C FILL ELASTICITY IN MATRICES MEL = MIN ( 1.D0+10.D0* MAX( 0.D0, ELASTI ) , 11.D0 ) MEN = MIN ( 4.D0+ 3.D0*LOG10(MAX( .1D0, EKINL )), 40.D0 ) #if __THIN__ IELDPM(MEN,MEL) = IELDPM(MEN,MEL) + NINT( WEIGHT ) IELDPA(MEN,MEL) = IELDPA(MEN,MEL) + NINT( WEIGHT ) IF ( ELASTI .LT. 1.D0 ) THEN ELMEAN(MEN) = ELMEAN(MEN) + ELASTI * WEIGHT ELMEAA(MEN) = ELMEAA(MEN) + ELASTI * WEIGHT #else IELDPM(MEN,MEL) = IELDPM(MEN,MEL) + 1 IELDPA(MEN,MEL) = IELDPA(MEN,MEL) + 1 IF ( ELASTI .LT. 1.D0 ) THEN ELMEAN(MEN) = ELMEAN(MEN) + ELASTI ELMEAA(MEN) = ELMEAA(MEN) + ELASTI #endif ENDIF #if __COASTUSERLIB__ coastProjId = nint(curpar(0)) coastTargId = nint(tar) coastX = curpar(7) coastY = curpar(8) #if __CURVED__ coastZ = curpar(14) #else coastX = coastX - XOFF(NOBSLV) coastY = coastY - YOFF(NOBSLV) coastZ = curpar(5) #endif coastT = curpar(6) coastE = pama(coastProjId)*curpar(1) coastCX = sigair coastEl = elasti call interaction(coastX) #endif IF ( FIRSTI ) THEN TARG1I = TAR SIG1I = SIGAIR ELAST = ELASTI C RANDOM GENERATOR STATUS (SEQUENCE L=1) AT END OF EVENT LL = 1 CALL RMMAQD( ISEED(1,LL),LL,'R' ) C SEED ISEED1I(1) = ISEED(1,LL) C NUMBER OF CALLS ISEED1I(2) = ISEED(2,LL) C NUMBER OF BILLIONS ISEED1I(3) = ISEED(3,LL) FIRSTI = .FALSE. ENDIF RETURN END #endif #if __CEFFIC__ && __CERENKOV__ *-- Author : V. de Souza Filho, Uni. Campinas 22/06/1999 C======================================================================= SUBROUTINE ATABSO( ABSORB ) C----------------------------------------------------------------------- C AT(MOSPHERIC) ABSO(RPTION) C C LOOKS WHETHER CHERENKOV PHOTON IS ABSORBED IN ATMOSPHERE. C TAKES INTO ACCOUNT THE ZENITH ANGLE OF THE EMITTED PHOTON. C RIWL = R(EFERENCE) I(NDEX OF) W(AVE)L(ENGTH). THIS VARIABLE IS C USED TO DETERMINE THE ADJACENT TABULATED POINTS. C IWL = INDEX OF WAVELENGTH. USED TO RUN LOOPS AND GET THE RIGHT C VALUE IN THE ATMABS MATRIX FOR INTERPOLATING IN HEIGHT. C FX0,FX1= VARIABLES USED TO CALL LINEAR. C PIH = POINTS AFTER INTERPOLATING IN HEIGHT. C COATEX = COEFFICIENT OF ATMOSPHERIC EXTINTICION FOR THE C INTERPOLATED WAVELENGTH AND HEIGHT. C PROBS = PROBABILITY OF REACHING THE OBSERVATION LEVEL. C STORES THE PROBABILITY OF OBSERVATION AFTER ATM. ABSORPTION. C THIS SUBROUTINE IS CALLED FROM CERENK. C ARGUMENT: C ABSORB = LOGICAL, TRUE IF CHERENKOV PHOTON IS GONE BY ATMOSPHERIC C ABSORPTION C----------------------------------------------------------------------- IMPLICIT NONE #define __CERABSINC__ #define __CEREN1INC__ #define __CEREN2INC__ #define __RANDPAINC__ #define __RUNPARINC__ #include "corsika.h" DOUBLE PRECISION HTKM,PIH(0:1),COATEX,PROBS,FX0,FX1 INTEGER RIWL,IWL,WLI0,WLI1,HTI0,HTI1,I LOGICAL ABSORB SAVE DOUBLE PRECISION LINEAR EXTERNAL LINEAR C----------------------------------------------------------------------- CC IF ( LCERDB ) WRITE(MDEBUG,*) 'ATABSO:' C CALCULATE THE REFERENCE WL AND INDEX OF WL FOR THE INTERPOLATIONS RIWL = 1 + INT( (WL-180.D0)/5.D0 ) WLI0 = RIWL*5 + 175 WLI1 = RIWL*5 + 175 + 5 C CONSIDER ATMOSPHERIC EXTINCITION HTKM = ZEMIS/1.D5 HTI0 = INT( HTKM ) HTI1 = INT( HTKM ) + 1 IF ( HTI0 .LT. 0 ) THEN PIH(0) = ATMABS(RIWL,0) PIH(1) = ATMABS(RIWL+1,0) GOTO 100 ENDIF IF ( HTI1 .GT. 50 ) THEN PIH(0) = ATMABS(RIWL,50) - ATEOBS(RIWL) PIH(1) = ATMABS(RIWL+1,50) - ATEOBS(RIWL+1) GOTO 100 ENDIF C INTERPOLATION IN HEIGHT DO I = 0, 1 IWL = RIWL + I FX0 = ATMABS(IWL,HTI0) FX1 = ATMABS(IWL,HTI1) PIH(I) = LINEAR( HTKM,HTI0,HTI1,FX0,FX1 ) PIH(I) = PIH(I) - ATEOBS(IWL) ENDDO 100 CONTINUE C INTERPOLATION IN WAVELENGTH COATEX = LINEAR( WL,WLI0,WLI1,PIH(0),PIH(1) ) IF ( WEMIS .GT. 0.D0 ) THEN PROBS = EXP( -COATEX/WEMIS ) CALL RMMARD( RD,1,3 ) IF ( RD(1) .LE. PROBS ) THEN ABSORB = .FALSE. ELSE ABSORB = .TRUE. ENDIF ELSE ABSORB = .TRUE. ENDIF RETURN END #endif #if __CERENKOV__ || __AUGCERLONG__ *-- Author : K. BERNLOEHR MPIK HEIDELBERG 15/06/1998 C======================================================================= SUBROUTINE CERENK( STEPCR,UMEAN,VMEAN,WMEAN,EBEG,EEND,XBEG,YBEG, * ZBEG,XEND,YEND,ZEND,TBEG,TEND,AMASS,CHARGE,WTTHIN,CTEA ) C----------------------------------------------------------------------- C C(H)ERENK(OV RADIATION FROM ALL KINDS OF CHARGED PARTICLES) C C CREATION OF CHERENKOV PHOTONS ALONG THE TRACKS OF CHARGED PARTICLES. C CHERENKOV RADIATION IS ONLY CALCULATED FOR THE LOWEST OBSERVATION C LEVEL. ALL PARAMETERS OF THE PARTICLE TRACK STEP ARE PASSED AS C ARGUMENTS. C THIS SUBROUTINE IS CALLED FROM ELECTR AND UPDATE. C ARGUMENTS (ALL DOUBLE PRECISION): C STEPCR = STEP LENGTH FOR THE PARTICLE [CM] C UMEAN = DIRECTION COSINE TO X AXIS (STEP AVERAGE) C VMEAN = DIRECTION COSINE TO Y AXIS (STEP AVERAGE) C WMEAN = DIRECTION COSINE TO -Z AXIS (STEP AVERAGE) C EBEG = ENERGY [GEV] AT BEGINNING OF STEP C EEND = ENERGY [GEV] AT END OF STEP C XBEG = X POSITION [CM] AT BEGINNING OF STEP C YBEG = Y POSITION [CM] AT BEGINNING OF STEP C ZBEG = Z POSITION [CM] AT BEGINNING OF STEP C XEND = X POSITION [CM] AT END OF STEP C YEND = Y POSITION [CM] AT END OF STEP C ZEND = Z POSITION [CM] AT END OF STEP C TBEG = TIME [NSEC] AT BEGIN OF STEP C TEND = TIME [NSEC] AT END OF STEP C AMASS = PARTICLE MASS [GEV/C**2] C CHARGE = CHARGE NUMBER (OR NEGATIVE - WE NEED ONLY THE SQUARE OF IT) C WTTHIN = PARTICLE WEIGHT FOR THINNING VERSION, ELSE 1. C CTEA = COSINE OF EARTH ANGLE IN CURVED VERSION, ELSE 1. C C THIS IMPLEMENTATION WRITTEN BY C K. BERNLOEHR MPIK HEIDELBERG (1998) C THIS SUBROUTINE IS BASED IN PART ON THE FORMER CHERENKOV ROUTINES C CERENE AND CERENH ORIGINALLY WRITTEN BY C M. ROZANSKA UNIVERSITY OF KRAKOW C F. ARQUEROS, S. MARTINEZ UNIVERSITY OF MADRID C AND SUBSEQUENTLY MODIFIED BY C D. HECK IK FZK KARLSRUHE C C EXTERNAL IACT (IMAGING ATMOSPHERIC CHERENKOV TECHNIQUE) FUNCTIONS C FOR COLLECTING PHOTON BUNCHES AT ARBITRARY TELESCOPE LOCATIONS C WRITTEN (IN C) BY K. BERNLOEHR MPIK HEIDELBERG (1997) C AND AVAILABLE SEPARATELY. C THE SAME APPLIES TO FUNCTIONS FOR TABULATED ATMOSPHERIC MODELS AND C FUNCTIONS TO ACCOUNT FOR THE ATMOSPHERIC REFRACTION. C----------------------------------------------------------------------- IMPLICIT NONE #define __CEREN1INC__ #define __CEREN2INC__ #define __EGSDEBINC__ #define __LONGIINC__ #define __OBSPARINC__ #define __PARPARINC__ #define __RUNPARINC__ #if __CERENKOV__ #define __CONSTAINC__ #define __MAGANGINC__ #define __RANDPAINC__ #endif #if __ATMEXT__ #define __ATMOSXINC__ #endif #if __CURVED__ #define __CORFRAMINC__ #endif #if __CEFFIC__ #define __CERABSINC__ #endif #if !__IACT__ #define __CERTELINC__ #define __CEREN3INC__ #endif #include "corsika.h" #if __CERENKOV__ DOUBLE PRECISION PHICER,SINPSI,SINPS2,UEMIS2,VEMIS2,XCER2,YCER2 DOUBLE PRECISION TC11,TC21,TC12,TC22,TC32,TC13,TC23,TC33 DOUBLE PRECISION SINPHI,COSPHI,STCP,STSP,THKBEG,DTHKLG,STHETA #endif DOUBLE PRECISION STEPCR DOUBLE PRECISION UMEAN,VMEAN,WMEAN DOUBLE PRECISION EBEG,EEND DOUBLE PRECISION XBEG,YBEG,ZBEG,XEND,YEND,ZEND DOUBLE PRECISION TBEG,TEND,AMASS,CHARGE,WTTHIN,CTEA DOUBLE PRECISION BETAE,BETAI,CTHETA,ETA1,ETA1I,ETA1E DOUBLE PRECISION BETAM,ETA1M DOUBLE PRECISION BETA,BETAN,CINTEN,ENER DOUBLE PRECISION PHOTCT,PSTEP,PATHL,ZEM DOUBLE PRECISION DEDPL,STHET2 DOUBLE PRECISION BEMX,TEMIS,TSTEP C WLFLAG PHOTON/PHOTO-ELECTRON FLAG (OR WAVELENGTH IN NANOMETER) DOUBLE PRECISION WLFLAG #if __CURVED__ DOUBLE PRECISION AUXILSQ,CDDIF,CDIFA,CDIFB,CUMEAN,CVMEAN, * CWMEAN,RDIST,SDIFB,STHE, * ZAPP,ZHBEG,ZHEM,ZHEND,ZHSTEP #if !__IACT__ DOUBLE PRECISION SWEMIS,STHE2,ETA2 #endif #if __CERENKOV__ DOUBLE PRECISION DISTIP,TOFIP EXTERNAL DISTIP,TOFIP #endif #else #if !__CERWLEN__ DOUBLE PRECISION ETALI,ETALE,DETAL,BETANI,DBETAN #endif INTEGER LOOPFL #if __CERENKOV__ DOUBLE PRECISION PATHCR,THCKEM #endif #endif #if __CEFFIC__ C OUTPUT DATA ARE PHOTOELECTRON BUNCHES ORIGINATING FROM PHOTONS C OF SPECIFIC WAVELENGTH PARAMETER (WLFLAG = -1.D0 ) LOGICAL ABSORB #elif __CERWLEN__ C OUTPUT DATA ARE PHOTON BUNCHES OF SPECIFIC WAVELENGTH PARAMETER (WLFLAG = 1.D0 ) #else C OUTPUT DATA ARE PHOTON BUNCHES OF UNSPECIFIED WAVELENGTH PARAMETER (WLFLAG = 0.D0 ) #endif INTEGER ISTC,MSTEPC #if __CERENKOV__ INTEGER IRDM,MAXRDM,NRDM PARAMETER ( MAXRDM = 100 ) DOUBLE PRECISION RDM(MAXRDM) #if __CERWLEN__ DOUBLE PRECISION ETCMAX,ETACOR #endif DOUBLE PRECISION XCER1,YCER1,XXX,YYY,DXXX,DYYY INTEGER TELOUT,ITHIT EXTERNAL TELOUT INTEGER I #endif #if __ATMEXT__ DOUBLE PRECISION REFIDX EXTERNAL REFIDX #endif DOUBLE PRECISION RHOF,THICK EXTERNAL RHOF,THICK SAVE C----------------------------------------------------------------------- #if __GFORTRAN__ CTP060202 TO AVOID WARNINGS WITH GFORTRAN COMPILATION LOGICAL CTP060202 CTP060202 = .FALSE. #if __THIN__ IF ( CTP060202 ) WRITE(*,*) CTEA,UMEAN,VMEAN #else IF ( CTP060202 ) WRITE(*,*) CTEA,UMEAN,VMEAN,WTTHIN #endif #endif IF ( DEBUG .OR. LCERDB .OR. FEGSDB ) $ WRITE(MDEBUG,444) EBEG,AMASS,WMEAN,STEPCR 444 FORMAT(' CERENK: EBEG=',1P,E12.5,' AMASS=',E12.5,' WMEAN=',E12.5, $ ' STEPCR=',E12.5) C SKIP PARTICLES OUT OF ZENITH ANGULAR CUT (WITH WMEAN>0 DOWNWARDS). C NOTE: USUALLY C(29) IS 0, I.E. UPWARD GOING PARTICLES ARE REJECTED. #if __UPWARD__ IF ( WMEAN .LT. 0.D0 .OR. STEPCR .LE. 0.D0 ) RETURN #else IF ( WMEAN .LT. C(29) .OR. STEPCR .LE. 0.D0 ) RETURN #endif C LOOK WHETHER CHERENKOV CONDITION IS FULFILLED FOR THIS STEP. BETAI = SQRT( (1.D0-(AMASS/EBEG))*(1.D0+(AMASS/EBEG)) ) BETAE = SQRT( (1.D0-(AMASS/EEND))*(1.D0+(AMASS/EEND)) ) C REFRACTIVE INDEX PARAMETERISATION: N=1+ETA = ETA1 C NOTE: ETA = N-1 IS CALLED THE REFRACTIVITY. #if __ATMEXT__ IF ( IATMOX .GE. 1 ) THEN ETA1I = REFIDX(ZBEG) ETA1E = REFIDX(ZEND) ELSE ETA1I = 1.D0 + ETADSN * RHOF( ZBEG ) ETA1E = 1.D0 + ETADSN * RHOF( ZEND ) ENDIF #else ETA1I = 1.D0 + ETADSN * RHOF( ZBEG ) ETA1E = 1.D0 + ETADSN * RHOF( ZEND ) #endif #if __CERWLEN__ C MAXIMUM CORRECTION FACTOR FOR ETA IS FOR SHORTEST WAVELENGTH. ETCMAX = 0.967D0 + 0.033D0*(400.D0/WAVLGL)**2.5D0 C USE MAXIMUM VALUES OVER WAVELENGTH RANGE RATHER THAN TYPICAL VALUES. C WE COULD HAVE PARTICLES THAT EMIT ONLY AT THE SHORTEST WAVELENGTHS. ETA1I = 1.D0 + (ETA1I-1.D0) * ETCMAX ETA1E = 1.D0 + (ETA1E-1.D0) * ETCMAX #endif IF ( BETAI*ETA1I .LT. 1.D0 .AND. BETAE*ETA1E .LT. 1.D0 ) THEN IF ( LCERDB ) WRITE(MDEBUG,*) 'CERENK: EXIT1' RETURN ENDIF BETAM = SQRT( 1.D0 - (AMASS*2.D0/(EBEG+EEND))**2 ) #if __ATMEXT__ IF ( IATMOX .GE. 1 ) THEN ETA1M = REFIDX(0.5D0 * (ZBEG+ZEND)) ELSE ETA1M = 1.D0 + ETADSN * RHOF( 0.5D0 * (ZBEG+ZEND) ) ENDIF #else ETA1M = 1.D0 + ETADSN * RHOF( 0.5D0 * (ZBEG+ZEND) ) #endif #if __CERWLEN__ ETA1M = 1.D0 + (ETA1M-1.D0) * ETCMAX #endif BEMX = MAX( BETAE*ETA1E, BETAI*ETA1I ) CINTEN = CYIELD * CHARGE**2 PHOTCT = CINTEN * STEPCR * (1.D0 - 1.D0/BEMX**2) MSTEPC = PHOTCT / CERSIZ + 1 IF ( MSTEPC .LT. 1 ) RETURN #if __CURVED__ C TRANSFORM ALL COORDINATES INTO DETECTOR FRAME (IF NOT DONE UNTIL NOW) C XBEG, XEND, YBEG, YEND ARE TRANSFORMED IN UPDATE (OR PARTLY IN UPDATC) IF ( .NOT. DETSYS ) THEN C FIRST TRANSFORM ANGLES INTO DETECTOR FRAME C (ROTATE LOCAL FRAME WITH EARTH ANGLE DIF) CDIFB = CTEA CDIFB = MIN( 1.D0, CDIFB ) SDIFB = SQRT( (1.D0 - CTEA) * (1.D0 + CTEA) ) SDIFB = MIN( 1.D0, SDIFB ) STHE = SQRT( UMEAN**2 + VMEAN**2 ) IF ( STHE .GT. 0.D0 ) THEN CUMEAN = UMEAN/STHE CVMEAN = VMEAN/STHE CUMEAN = WMEAN*SDIFB*CUMEAN + CDIFB*STHE*CUMEAN CVMEAN = WMEAN*SDIFB*CVMEAN + CDIFB*STHE*CVMEAN CWMEAN = WMEAN*CDIFB - SDIFB*STHE ELSE CUMEAN = WMEAN*SDIFB*UMEAN CVMEAN = WMEAN*SDIFB*VMEAN CWMEAN = WMEAN*CDIFB ENDIF IF ( LCERDB ) WRITE(MDEBUG,*) 'CERENK: CURVED; CWMEAN=',CWMEAN IF ( CWMEAN .LT. C(29) ) RETURN C ZBEG, ZEND IN DETECTOR FRAME (ZHBEG, ZHEND) C ACTUAL EARTH ANGLE AUXILSQ = SQRT( XBEG**2 + YBEG**2 ) CDIFA = COS( AUXILSQ/C(1) ) IF ( CDIFA .GT. CTEA ) THEN C TRANSFORM FIRST INTO THE INTERMEDIATE LOCAL SYSTEM CDDIF = CTEA*CDIFA * + SQRT( (1.D0-CTEA)*(1.D0+CTEA)*(1.D0-CDIFA)*(1.D0+CDIFA) ) ZBEG = (ZBEG+C(1)) / CDDIF - C(1) ZEND = (ZEND+C(1)) / CDDIF - C(1) ENDIF ZHBEG = (ZBEG+C(1)) * CDIFA - C(1) IF ( ZHBEG .LE. OBSLEV(1) ) RETURN C TAKE EARTH ANGLE OF END POINT OF PART OF TRACK FOR CALCULATING ZHEND AUXILSQ = SQRT( XEND**2 + YEND**2) ZHEND = (ZEND+C(1)) * COS( AUXILSQ/C(1) ) - C(1) C NOW TRANSFORM CURVED COORDINATES INTO FLAT COORDINATE FRAME C TAKING THE NOW AVAILABLE VALUES OF HAPP (X = X(HAPP)) XBEG = (ZHBEG+C(1)) * TAN( XBEG/C(1) ) YBEG = (ZHBEG+C(1)) * TAN( YBEG/C(1) ) XEND = (ZHEND+C(1)) * TAN( XEND/C(1) ) YEND = (ZHEND+C(1)) * TAN( YEND/C(1) ) ENDIF DEDPL = (EEND-EBEG) / STEPCR #else C NOW CHECK WHICH KIND OF CALCULATING (BETA*N) FOR EACH SUB-STEP C IS LIKELY TO BE THE MOST EFFICIENT. C CASE 0: ONLY ONE STEP - WE HAVE ALREADY THE NUMBERS AT MID-STEP. #if __UPWARD__ IF ( WMEAN .GT. 0.D0 ) THEN #endif IF ( MSTEPC .EQ. 1 ) THEN LOOPFL = 0 #if __CERWLEN__ C WITH EXPLICIT WAVELENGTH DEPENDENCE, WE NEED A DIFFERENT C WAVELENGTH AND REFRACTIVE INDEX FOR EACH STEP. #else C CASE 1: LINEAR INTERPOLATION OF (BETA*N) IF THE RELATIVE ERROR ON C THE LIGHT INTENSITY IN THE MIDDLE IS LESS THAN 1E-3 (THEN THE ERROR C ON THE IMPACT POINT FOR VERTICAL INCIDENCE IS LESS THAN ABOUT 5 CM). ELSEIF ( (BETAE*ETA1E) .GT. 1.D0 .AND. (BETAI*ETA1I) .GT. 1.D0 * .AND. (BETAM*ETA1M) .GT. 1.D0 .AND. * ABS((2.D0-1.D0/(BETAI*ETA1I)**2-1.D0/(BETAE*ETA1E)**2)/ * (1.D0-1.D0/(BETAM*ETA1M)**2)-2.D0) .LT. 2.D-3*WMEAN ) THEN LOOPFL = 1 DBETAN = (BETAE*ETA1E-BETAI*ETA1I) / STEPCR BETANI = BETAI * ETA1I DEDPL = (EEND-EBEG) / STEPCR C CASE 2: LOGARITHMIC INTERPOLATION OF (N-1) IS GOOD ENOUGH FOR C ERRORS ON THE IMPACT POINT BEING LESS THAN 10 CM. C BETA IS CALCULATED EXPLICITLY ASSUMING CONSTANT ENERGY LOSS. C NOTE THAT WE USE CONSTANT ENERGY LOSS PER CENTIMETER RATHER THAN C PER UNIT G/CM**2 FOR EFFICIENCY REASONS. THE POSSIBLE DIFFERENCE C OF ENERGY AT MIDDLE OF STEP SHOULD BE INSIGNIFICANT IN ALMOST C ANY CASE. ELSEIF ( ZBEG**2*ABS((ETA1I-1.D0)*(ETA1E-1.D0)/(ETA1M-1.D0)**2 * - 1.D0) .LT. (10.D0*ABS(WMEAN))**2 ) THEN LOOPFL = 2 ETALI = LOG( ETA1I-1.D0 ) ETALE = LOG( ETA1E-1.D0 ) DETAL = (ETALE-ETALI) / STEPCR DEDPL = (EEND-EBEG) / STEPCR ELSE C CASE 3: BOTH N AND BETA HAVE TO BE CALCULATED IN FULL DETAIL. #endif LOOPFL = 3 DEDPL = (EEND-EBEG) / STEPCR ENDIF #if __UPWARD__ IF ( LCERDB ) WRITE(MDEBUG,*) * 'CERENK: LOOPFL=',LOOPFL,' DEDPL=',DEDPL ENDIF #endif #endif C VARIOUS START VALUES AND STEP LENGTHS FOR SUB-STEP LOOP TSTEP = (TEND-TBEG) * (1.D0/DBLE(MSTEPC)) XSTEP = (XEND-XBEG) * (1.D0/DBLE(MSTEPC)) YSTEP = (YEND-YBEG) * (1.D0/DBLE(MSTEPC)) ZSTEP = (ZEND-ZBEG) * (1.D0/DBLE(MSTEPC)) PSTEP = STEPCR * (1.D0/DBLE(MSTEPC)) PATHL = (-0.5D0) * PSTEP TEMIS = TBEG - 0.5D0*TSTEP XSTEP2 = 0.5D0 * XSTEP XEMIS = XBEG - XSTEP2 YSTEP2 = 0.5D0 * YSTEP YEMIS = YBEG - YSTEP2 ZSTEP2 = 0.5D0 * ZSTEP ZEM = ZBEG - ZSTEP2 #if __CERENKOV__ #if __CURVED__ C THE TC.. ELEMENTS ARE DESCRIBED FURTHER DOWN. IF ( .NOT. DETSYS ) THEN ZHSTEP = (ZHEND-ZHBEG) * (1.D0/DBLE(MSTEPC)) ZHEM = ZHBEG - 0.5D0*ZHSTEP IF ( ZHEM .LE. OBSLEV(1) ) RETURN SINPS2 = MAX( 1.D-20, CUMEAN**2 + CVMEAN**2 ) SINPSI = SQRT( SINPS2 ) TC11 = CVMEAN*(1.D0/SINPSI) TC12 = CUMEAN*CWMEAN*(1.D0/SINPSI) TC13 = CUMEAN TC21 = (-CUMEAN)*(1.D0/SINPSI) TC22 = CVMEAN*CWMEAN*(1.D0/SINPSI) TC23 = CVMEAN TC32 = -SINPSI TC33 = CWMEAN ELSE #else C THE TC.. ELEMENTS ARE DESCRIBED FURTHER DOWN. #endif SINPS2 = MAX( 1.D-20, UMEAN**2 + VMEAN**2 ) SINPSI = SQRT( SINPS2 ) TC11 = VMEAN*(1.D0/SINPSI) TC12 = UMEAN*WMEAN*(1.D0/SINPSI) TC13 = UMEAN TC21 = (-UMEAN)*(1.D0/SINPSI) TC22 = VMEAN*WMEAN*(1.D0/SINPSI) TC23 = VMEAN TC32 = -SINPSI TC33 = WMEAN #if __CURVED__ ENDIF #endif C SINCE EXPONENTIAL ATMOSPHERIC LAYERS ARE ASSUMED, A LOGARITHMIC C INTERPOLATION OF THE ATMOSPHERIC THICKNESS CAN BE APPLIED. IF ( MSTEPC .GT. 3 ) THEN THKBEG = MAX( 1.D-3, THICK( ZBEG ) ) DTHKLG = LOG( THICK( ZEND )/THKBEG ) / STEPCR ENDIF C DON''T GET RANDOM NUMBERS ONE-BY-ONE BUT IN LARGER CHUNKS. #if __CERWLEN__ NRDM = 2*MSTEPC #else NRDM = MSTEPC #endif IRDM = 0 IF ( NRDM .GT. MAXRDM ) THEN CALL RMMARD( RDM,MAXRDM,3 ) ELSE CALL RMMARD( RDM,NRDM,3 ) ENDIF #endif C LOOP OVER THE NUMBER OF SUB-STEPS WITH CONSTANT PARTICLE DIRECTION C BUT CONTINUOUS ENERGY LOSS AND REFRACTION INDEX CHANGE ARE ACCOUNTED FOR. C SINCE ACTUAL VELOCITY CHANGES OF PARTICLES EMITTING CHERENKOV LIGHT C IN THE ATMOSPHERE ARE VERY SMALL, CONSTANT STEPS IN (X,Y,Z,T) ARE USED. DO 1000 ISTC = 1, MSTEPC #if (__CERWLEN__ || __CEFFIC__) && __CERENKOV__ C WAVELENGTH OF THE EMITTED PHOTON CALL CESPEC( WL ) #endif #if __CEFFIC__ IF ( CERQEF .OR. CERMIR ) THEN C APPLY TELESCOPE EFFICIENCY CALL TELEFF( ABSORB ) IF ( ABSORB ) GOTO 1000 ENDIF #endif PATHL = PATHL + PSTEP XEMIS = XEMIS + XSTEP YEMIS = YEMIS + YSTEP ZEM = ZEM + ZSTEP TEMIS = TEMIS + TSTEP #if __CURVED__ IF ( .NOT. DETSYS ) THEN ZHEM = ZHEM + ZHSTEP IF ( ZHEM .LE. OBSLEV(1) ) RETURN ENDIF #else #if !__CERWLEN__ C DEPENDING ON CONDITIONS USE THE FASTEST METHOD TO GET (BETA*N). IF ( LOOPFL .EQ. 1 ) THEN C THE MOST FREQUENT AND SIMPLEST CASE (WELL ABOVE THRESHOLD). BETAN = BETANI + DBETAN*PATHL ELSEIF ( MSTEPC .EQ. 1 ) THEN C THIS CASE IS USALLY ENCOUNTERED NEAR THRESHOLD. BETAN = BETAM*ETA1M ELSEIF ( LOOPFL .EQ. 2 ) THEN C THIS CASE IS ALSO USALLY ENCOUNTERED NEAR THRESHOLD. ETA1 = 1.D0 + EXP( ETALI+DETAL*PATHL ) ENER = EBEG + DEDPL*PATHL BETA = SQRT( (1.D0-(AMASS/ENER))*(1.D0+(AMASS/ENER)) ) BETAN = BETA*ETA1 ELSE C THIS MOST GENERAL CASE IS RARELY ENCOUNTERED. #endif #endif #if __ATMEXT__ IF ( IATMOX .GE. 1 ) THEN ETA1 = REFIDX(ZEM) ELSE ETA1 = 1.D0 + ETADSN * RHOF( ZEM ) ENDIF #else ETA1 = 1.D0 + ETADSN * RHOF( ZEM ) #endif ENER = EBEG + DEDPL*PATHL BETA = SQRT( (1.D0-(AMASS/ENER))*(1.D0+(AMASS/ENER)) ) #if __CERWLEN__ #if __CEFFIC__ && __CERENKOV__ C THE WAVELENGTH WAS THROWN BEFORE. WE JUST HAVE TO CALCULATE THE C WAVELENGTH-DEPENDENT REFRACTIVE INDEX. #else C DON''T GET RANDOM NUMBERS ONE-BY-ONE BUT IN LARGER CHUNKS FROM SEQ. 3 IRDM = IRDM + 1 IF ( IRDM .GT. MAXRDM ) THEN IF ( NRDM .GT. MAXRDM ) THEN CALL RMMARD( RDM,MAXRDM,3 ) NRDM = NRDM - MAXRDM ELSE CALL RMMARD( RDM,NRDM,3 ) NRDM = 0 ENDIF IRDM = 1 ENDIF C THROW A RANDOM WAVELENGTH AND CALCULATE THE WAVELENGTH-DEPENDENT C REFRACTIVE INDEX. WL = 1.D0/(1.D0/WAVLGU+(1.D0/WAVLGL-1.D0/WAVLGU)*RDM(IRDM)) #endif ETACOR= 0.967D0 + 0.033D0*(400.D0/WL)**2.5D0 ETA1 = 1.D0 + (ETA1-1.D0)*ETACOR #endif BETAN = BETA*ETA1 #if __CURVED__ IF ( LCERDB ) WRITE(MDEBUG,*) 'CERENK: BETAN=',BETAN #else #if !__CERWLEN__ ENDIF #endif IF ( LCERDB ) WRITE(MDEBUG,*) * 'CERENK: LOOPFL=',LOOPFL,' BETAN=',BETAN #endif CTHETA = 1.D0 / BETAN STHET2 = ( 1.D0 - CTHETA ) * ( 1.D0 + CTHETA ) C PARTICLE IS BELOW ENERGY THRESHOLD IF THE EMISSION ANGLE IS <=0 IF ( CTHETA .GT. 1.D0 .OR. STHET2 .LE. 0.D0 ) THEN #if __CERENKOV__ #if __CERWLEN__ NRDM = NRDM - 2 #else NRDM = NRDM - 1 #endif #endif GOTO 1000 ENDIF C NUMBER OF EMITTED PHOTONS IN THIS SUB-STEP PHOTCM = (CINTEN*PSTEP) * STHET2 C ASSUME EMISSION POINT OF ALL PHOTONS IN THE MIDDLE OF THE STEP #if __CURVED__ C SAVE EMMISION HEIGHT SEEN FROM THE DETECTOR IF ( .NOT. DETSYS ) THEN ZEMIS = ZHEM ZAPP = ZHEM ELSE ZEMIS = ZEM ZAPP = ZEM ENDIF #else ZEMIS = ZEM #endif #if __CERENKOV__ STHETA = SQRT( STHET2 ) C CALCULATE PHOTON DIRECTION IN THE CORSIKA COORDINATE FRAME C C NOTE: TO DERIVE THESE EQUATIONS YOU SHOULD FIRST DERIVE A MATRIX (T) C WHICH ROTATES THE PARTICLE DIRECTION (U, V, W) TO (0, 0, 1): C C ( V/SQRT(U**2+V**2) -U/SQRT(U**2+V**2) 0 ) C (T) = ( UW/SQRT(U**2+V**2) VW/SQRT(U**2+V**2) -SQRT(U**2+V**2) ) C ( U V W ) C C CHERENKOV EMISSION IN THIS ROTATED COORDINATE SYSTEM IS DESCRIBED BY C A MATRIX (C): C C ( COS(PHI) -SIN(PHI) 0 ) ( COS(THETA) 0 SIN(THETA) ) C (C) = ( SIN(PHI) COS(PHI) 0 ) ( 0 1 0 ) C ( 0 0 1 ) ( -SIN(THETA) 0 COS(THETA) ) C C WHERE THETA IS THE CHERENKOV OPENING ANGLE AND PHI IS RANDOM. C THE RESULT IS (T_T)**-1 (C) (0,0,1): C C (0) C (T_T)**-1 (C) (0) = C (1) C C ( V/S*SIN(T)*COS(PHI)+U*W/S*SIN(T)*SIN(PHI)+U*COS(T) ) C = (-U/S*SIN(T)*COS(PHI)+V*W/S*SIN(T)*SIN(PHI)+V*COS(T) ) C ( -S*SIN(T)*SIN(PHI)+W*COS(T) ) C C WITH S = SQRT(U**2+V**2) AND T=THETA. THE CONSTANT PARTS ARE CALCULATED C AS TC11 ... TC33 BEFORE THE '1000' LOOP. C DON''T GET RANDOM NUMBERS ONE-BY-ONE BUT IN LARGER CHUNKS FROM SEQ. 3 IRDM = IRDM + 1 IF ( IRDM .GT. MAXRDM ) THEN IF ( NRDM .GT. MAXRDM ) THEN CALL RMMARD( RDM,MAXRDM,3 ) NRDM = NRDM - MAXRDM ELSE CALL RMMARD( RDM,NRDM,3 ) NRDM = 0 ENDIF IRDM = 1 ENDIF PHICER = RDM(IRDM) * PI2 SINPHI = SIN( PHICER ) COSPHI = COS( PHICER ) IF ( SINPS2 .LE. 1.D-12 ) THEN UEMIS2 = STHETA * COSPHI VEMIS2 = STHETA * SINPHI WEMIS = CTHETA IF ( WMEAN .LT. 0.D0 ) WEMIS = -CTHETA ELSE STCP = STHETA * COSPHI STSP = STHETA * SINPHI UEMIS2 = TC11*STCP + TC12*STSP + TC13*CTHETA VEMIS2 = TC21*STCP + TC22*STSP + TC23*CTHETA WEMIS = TC32*STSP + TC33*CTHETA ENDIF IF ( LCERDB ) WRITE(MDEBUG,*) 'CERENK: UEMIS2,VEMIS2,WEMIS=', * UEMIS2,VEMIS2,WEMIS C EMISSION ANGLE WITHIN ZENITH ANGULAR CUT? #if __UPWARD__ C WE MAY HAVE UPWARD PARTICLES BUT UPWARD PHOTONS ARE USELESS. IF ( WEMIS .LT. C(29) .OR. WEMIS .LE. 0.D0 ) GOTO 1000 #else IF ( WEMIS .LT. C(29) ) GOTO 1000 #endif WEMIS = MIN( 1.D0, WEMIS ) #if __CEFFIC__ C APPLY ATMOSPHERIC ABSORPTION IF ( CERATA ) THEN CALL ATABSO( ABSORB ) IF ( ABSORB ) GOTO 1000 ENDIF #endif C CALCULATE OFFSET FROM SHOWER AXIS AT THE DETECTOR LEVEL. #if __CURVED__ C CALCULATE NEW DETECTOR COORDINATES BY INTERPOLATING BETWEEN C TABULATED VALUES WHICH WERE NUMERICALLY INTEGRATED C TAKING INTO ACCOUNT ATMOSPHERIC REFRACTION IN A CURVED GEOMETRY STHE = SQRT( UEMIS2**2 + VEMIS2**2 ) RDIST = DISTIP( WEMIS, ZAPP) IF ( LCERDB ) WRITE(MDEBUG,*) 'CERENK: WEMIS,ZEM,STHE,RDIST=', * WEMIS,ZEM,STHE,RDIST IF ( STHE .GT. 0.D0 ) THEN C UEMIS2=COSPHI, VEMIS2=SINPHI XCER2 = XEMIS + RDIST/STHE * UEMIS2 YCER2 = YEMIS + RDIST/STHE * VEMIS2 ELSE XCER2 = XEMIS YCER2 = YEMIS ENDIF C CERDIST IS SLANT DISTANCE TO DETECTOR MIDDLE CERDIST = ( ZAPP - OBSLEV(NOBSLV) ) / WEMIS #else PATHCR = ( ZEM - OBSLEV(NOBSLV) ) / WEMIS XCER2 = XEMIS + PATHCR * UEMIS2 - XOFF(NOBSLV) YCER2 = YEMIS + PATHCR * VEMIS2 - YOFF(NOBSLV) C CERDIST IS SLANT DISTANCE TO DETECTOR MIDDLE CERDIST = PATHCR #endif #endif #if __THIN__ C IN CERLDE, CERLDH, AND OUTPT2 THE VARIABLE WTCER IS USED. WTCER = WTTHIN #endif #if !__NOCLONG__ C ADD THE CHERENKOV PHOTONS TO THE LONGITUDINAL DEVELOPMENT. IF ( LLONGI ) THEN CALL CERLDE ENDIF #endif #if __CERENKOV__ C TAKE THE ROTATION RELATIVE TO MAGNETIC NORTH INTO ACCOUNT XCER = XCER2 * COSANG + YCER2 * SINANG YCER = YCER2 * COSANG - XCER2 * SINANG UEMIS = UEMIS2 * COSANG + VEMIS2 * SINANG VEMIS = VEMIS2 * COSANG - UEMIS2 * SINANG IF ( LCERDB ) WRITE(MDEBUG,*) 'CERENK: UEMIS,VEMIS,PHOTCM=', * SNGL(UEMIS),SNGL(VEMIS),SNGL(PHOTCM) #if __IACT__ C BUNCH COULD FALL ON A TELESCOPE, CALCULATE ARRIVAL TIME (NSEC). C NOTE: C(25) IS VELOCITY OF LIGHT IN CM/SEC. #if __ATMEXT__ C ATMOSPHERIC BENDING CORRECTION WORKS BOTH WITH CORSIKA BUILT-IN C ATMOSPHERIC MODELS AND WITH EXTERNAL TABLES BUT THE TABLES ARE C FAR MORE ACCURATE. YOU NEED TO ENABLE IT WITH THE SECOND C PARAMETER OF THE ATMOSPHERE DATA CARD, E.G. 'ATMOSPHERE 0 T' IF ( FREFRX ) THEN #if __CURVED__ C CALCULATE TIME OF FLIGHT BY INTERPOLATING BETWEEN TABULATED VALUES C TEMIS IS IN SECONDS, CARTIM IS IN NANOSECONDS. CARTIM = TEMIS * 1.D9 + TOFIP(WEMIS,ZAPP) #else C TEMIS IS IN SECONDS, CARTIM IS IN NANOSECONDS. CARTIM = TEMIS * 1.D9 C TAKE BENDING OF RAY BY ATMOSPHERIC REFRACTION INTO ACCOUNT. C THE ARRIVAL DIRECTION, THE ARRIVAL POSITION AND THE ARRIVAL C TIME ARE CORRECTED. CALL RAYBND( ZEM,UEMIS,VEMIS,WEMIS,XCER,YCER,CARTIM ) #endif ELSE #endif C WITHOUT REFRACTION CODE OR IF DESELECTED FALL BACK TO THE OLD METHOD. #if __CURVED__ C CALCULATE TIME OF FLIGHT BY INTERPOLATING BETWEEN TABULATED VALUES C TEMIS IS IN SECONDS, CARTIM IS IN NANOSECONDS. CARTIM = TEMIS * 1.D9 + TOFIP(WEMIS,ZAPP) #else IF ( MSTEPC .GT. 3 ) THEN THCKEM = THKBEG * EXP( DTHKLG*PATHL ) ELSE THCKEM = THICK( ZEM ) ENDIF C TEMIS IS IN SECONDS, CARTIM IS IN NANOSECONDS. CARTIM = (TEMIS + (ETADSN*(THCKOB(NOBSLV)-THCKEM) * /WEMIS+PATHCR)/C(25))* 1.D9 #endif #if __ATMEXT__ ENDIF #endif #if __THIN__ ITHIT = TELOUT( PHOTCM,WTCER,XCER,YCER, #else ITHIT = TELOUT( PHOTCM,1.D0,XCER,YCER, #endif * UEMIS,VEMIS,CARTIM,ZEMIS, #if __CEFFIC__ || __CERWLEN__ * WL*WLFLAG #else * WLFLAG #endif #if __IACTEXT__ * ,TEMIS, * EBEG + (EEND-EBEG)*(ZEM-ZBEG)/(ZEND-ZBEG), * AMASS,CHARGE #endif * ) C WHETHER THE PHOTON BUNCH SHOULD BE OUTPUT VIA THE OUTPT2 FUNCTION C DEPENDS ON THE RETURN CODE FROM TELOUT. IF STORING OF BUNCHES IS C DONE ALREADY IN TELOUT, ITHIT=0 WOULD INDICATE NO TELESCOPE WAS HIT C AND ITHIT=1 THAT A TELESCOPE WAS HIT BUT CORSIKA SHOULD NOT CARE C ABOUT OUTPUT FOR THIS PHOTON BUNCH, EXCEPT TO REMEMBER THE TOTALS. IF ( ITHIT .EQ. 1 .OR. ITHIT .EQ. 3 ) THEN IF ( AMASS .LT. 1.D-3 ) THEN CERELE = CERELE + PHOTCM ELSE CERHAD = CERHAD + PHOTCM ENDIF ENDIF IF ( ITHIT .GE. 2 ) CALL OUTPT2(1) #else C WE ARE NOT IN IACT OPTION C CHECK WHETHER WE HAVE CHERENKOV TELESCOPES (WITHOUT IACT) IF ( NCERTEL .GT. 0 ) THEN ITHIT = 0 C EQUAL < 0 MEANS THE PHOTON SHOULD NOT BE SAVED, WHILE C OTHERWISE THE CERTELID OF THE HIT TELESCOPE IS RETURNED C (as specified in the steering card) ITHIT = TELOUT( XCER,YCER,UEMIS,VEMIS ) IF ( ITHIT .GE. 0 ) THEN ! WE HAVE HIT A TELESCOPE IF ( AMASS .LT. 1.D-3 ) THEN CERELE = CERELE + PHOTCM ELSE CERHAD = CERHAD + PHOTCM ENDIF C NO FURTHER CORRECTIONS, SEE CHER-ARRAY (!) ONLY CARTIM NEEDED #if __ATMEXT__ IF ( FREFRX ) THEN #if __CURVED__ C CALCULATE TIME OF FLIGHT BY INTERPOLATING BETWEEN TABULATED VALUES C TEMIS IS IN SECONDS, CARTIM IS IN NANOSECONDS. CARTIM = TEMIS * 1.D9 + TOFIP(WEMIS,ZAPP) #else C TEMIS IS IN SECONDS, CARTIM IS IN NANOSECONDS. CARTIM = TEMIS * 1.D9 CALL RAYBND( ZEMIS,UEMIS,VEMIS,WEMIS,XCER, * YCER,CARTIM ) #endif ELSE #endif #if __CURVED__ C CALCULATE TIME OF FLIGHT BY INTERPOLATING BETWEEN TABULATED VALUES C TEMIS IS IN SECONDS, CARTIM IS IN NANOSECONDS. CARTIM = TEMIS * 1.D9 + TOFIP(WEMIS,ZAPP) #else IF ( MSTEPC .GT. 3 ) THEN THCKEM = THKBEG * EXP( DTHKLG*PATHL ) ELSE THCKEM = THICK( ZEM ) ENDIF C TEMIS IS IN SECONDS, CARTIM IS IN NANOSECONDS. CARTIM = (TEMIS + (ETADSN*(THCKOB(NOBSLV)-THCKEM) * /WEMIS+PATHCR)/C(25)) * 1.D9 #endif #if __ATMEXT__ ENDIF #endif #if __CURVED__ C CORRECT ZENITH ANGLE DUE TO ATMOSPHERIC REFRACTION FOR OUTPUT #if __ATMEXT__ IF ( IATMOX .GE. 1 ) THEN ETA2 = REFIDX( OBSLEV(1) ) ELSE ETA2 = 1.D0 + ETADSN * RHOF( OBSLEV(1) ) ENDIF #else ETA2 = 1.D0 + ETADSN * RHOF( OBSLEV(1) ) #endif SWEMIS = ( 1.D0 - WEMIS ) * ( 1.D0 + WEMIS ) SWEMIS = (ETA1/ETA2)**2 * SWEMIS WEMIS = MIN( 1.D0, SQRT( 1.D0 - SWEMIS ) ) C NOW CORRECT ALSO THE OTHER DIRECTION COSINE STHE = SQRT( VEMIS**2 + UEMIS**2 ) STHE2 = SQRT( (1.D0-WEMIS)*(1.D0+WEMIS) ) VEMIS = VEMIS/STHE * STHE2 UEMIS = UEMIS/STHE * STHE2 #endif CALL OUTPT2( cerbuf(ITHIT) ) GOTO 1000 ENDIF ! END OF CASE HITTING A TELESCOPE ELSE C HERE WE CONSIDER THE NON-TELESCOPE CASE C ONLY PHOTON BUNCHES INSIDE CHERENKOV ARRAY IF ( ABS(XCER).LT.XCMAXS .AND. ABS(YCER).LT.YCMAXS ) THEN IF ( AMASS .LT. 1.D-3 ) THEN CERELE = CERELE + PHOTCM ELSE CERHAD = CERHAD + PHOTCM ENDIF DO 7001 I = 1, ICERML XCER1 = XCER - CERXOS(I) XXX = XCER1 * DCERXI + FCERX DXXX = ABS( XXX - NINT( XXX ) ) IF ( DXXX .LE. EPSX ) THEN IF ( XCER1.LT.-XCMAX .OR. XCER1.GT.XCMAX ) GOTO 7001 YCER1 = YCER - CERYOS(I) YYY = YCER1 * DCERYI + FCERY DYYY = ABS( YYY - NINT( YYY ) ) IF ( DYYY .LE. EPSY ) THEN IF ( YCER1.LT.-YCMAX .OR. YCER1.GT.YCMAX ) GOTO 7001 C BUNCH FALLS ON A DETECTOR, CALCULATE ARRIVAL TIME (NSEC) #if __ATMEXT__ IF ( FREFRX ) THEN #if __CURVED__ C CALCULATE TIME OF FLIGHT BY INTERPOLATING BETWEEN TABULATED VALUES C TEMIS IS IN SECONDS, CARTIM IS IN NANOSECONDS. CARTIM = TEMIS * 1.D9 + TOFIP(WEMIS,ZAPP) #else C TEMIS IS IN SECONDS, CARTIM IS IN NANOSECONDS. CARTIM = TEMIS * 1.D9 CALL RAYBND( ZEMIS,UEMIS,VEMIS,WEMIS,XCER, * YCER,CARTIM ) #endif ELSE #endif #if __CURVED__ C CALCULATE TIME OF FLIGHT BY INTERPOLATING BETWEEN TABULATED VALUES C TEMIS IS IN SECONDS, CARTIM IS IN NANOSECONDS. CARTIM = TEMIS * 1.D9 + TOFIP(WEMIS,ZAPP) #else IF ( MSTEPC .GT. 3 ) THEN THCKEM = THKBEG * EXP( DTHKLG*PATHL ) ELSE THCKEM = THICK( ZEM ) ENDIF C TEMIS IS IN SECONDS, CARTIM IS IN NANOSECONDS. CARTIM = (TEMIS + (ETADSN*(THCKOB(NOBSLV)-THCKEM) * /WEMIS+PATHCR)/C(25)) * 1.D9 #endif #if __ATMEXT__ ENDIF #endif #if __CURVED__ C CORRECT ZENITH ANGLE DUE TO ATMOSPHERIC REFRACTION FOR OUTPUT #if __ATMEXT__ IF ( IATMOX .GE. 1 ) THEN ETA2 = REFIDX( OBSLEV(1) ) ELSE ETA2 = 1.D0 + ETADSN * RHOF( OBSLEV(1) ) ENDIF #else ETA2 = 1.D0 + ETADSN * RHOF( OBSLEV(1) ) #endif SWEMIS = ( 1.D0 - WEMIS ) * ( 1.D0 + WEMIS ) SWEMIS = (ETA1/ETA2)**2 * SWEMIS WEMIS = MIN( 1.D0, SQRT( 1.D0 - SWEMIS ) ) C NOW CORRECT ALSO THE OTHER DIRECTION COSINE STHE = SQRT( VEMIS**2 + UEMIS**2 ) STHE2 = SQRT( (1.D0-WEMIS)*(1.D0+WEMIS) ) VEMIS = VEMIS/STHE * STHE2 UEMIS = UEMIS/STHE * STHE2 #endif CALL OUTPT2( 1 ) GOTO 1000 ENDIF ENDIF 7001 CONTINUE ENDIF ! END OF CASE PHOTON INSIDE ARRAY ENDIF !END OF NON-TELESCOPE CASE #endif #endif 1000 CONTINUE RETURN END #endif #if ( __CERENKOV__ && !__NOCLONG__ ) || ( __AUGCERLONG__ && !__NOCLONG__ ) *-- Author : K. BERNLOEHR MPIK HEIDELBERG 15/06/1998 C======================================================================= SUBROUTINE CERLDE C----------------------------------------------------------------------- C C(H)ER(ENKOV) L(ONGITUNAL) DE(VELOPMENT) C C THIS SUBROUTINE IS CALLED FROM CERENK. C----------------------------------------------------------------------- IMPLICIT NONE #define __CEREN2INC__ #define __LONGIINC__ #define __PARPARINC__ #include "corsika.h" DOUBLE PRECISION PHOTB,PHOTB1,PHOTBN,STEPT,THCKHN,THCKHO INTEGER IL,LPCT1,LPCT2 #if __SLANT__ #if __CURVED__ DOUBLE PRECISION PHI1,RRR,WANEW,WAOLD,XNEW,XOLD,XXX, * YNEW,YOLD,YYY,ZAPNEW,ZAPOLD,ZNEW,ZOLD #endif DOUBLE PRECISION AUXNEW,AUXOLD,THCKSI INTEGER LBIN EXTERNAL LBIN,THCKSI #else DOUBLE PRECISION THICK EXTERNAL THICK #endif SAVE C----------------------------------------------------------------------- #if __SLANT__ #if __CURVED__ C CALCULATE AUXILIAR QUANTITIES AT BEGIN OF STEP XOLD = XEMIS-XSTEP2 YOLD = YEMIS-YSTEP2 ZOLD = ZEMIS-ZSTEP2 WAOLD = COS( SQRT( XOLD**2 + YOLD**2 ) / C(1) ) ZAPOLD = ( C(1) + ZOLD ) * WAOLD - C(1) IF ( WAOLD .NE. 1.D0 ) THEN C WE ARE AWAY FROM DETECOR C CALCULATE AZIMUTH ANGLE OF PARTICLE SEEN FROM DETECTOR IF ( YOLD .NE. 0.D0 .OR. XOLD .NE. 0.D0 ) THEN PHI1 = ATAN2( YOLD, XOLD ) ELSE PHI1 = 0.D0 ENDIF C HORIZONTAL DISTANCE OF PARTICLE TO DETECTOR RRR = SQRT( (1.D0-WAOLD)*(1.D0+WAOLD) ) * * ( C(1) + ZAPOLD ) / WAOLD XXX = RRR * COS( PHI1 ) YYY = RRR * SIN( PHI1 ) ELSE C WE ARE IN THE DETECTOR SYSTEM AND NEED NO COORDINATE CALCULATION XXX = XOLD YYY = YOLD ENDIF C LOOK FOR SLANT THICKNESS OF BEGIN OF STEP AUXOLD = XXX * STHCPH + YYY * STHSPH - ZAPOLD * CTH + RLOFF C FIND FIRST THE EQUIVALENT LEVELS C THE PARTICLE IS TRACKED FROM ZEMIS-ZSTEP2 DOWN TO ZEMIS+ZSTEP2 THCKHO = THCKSI( AUXOLD ) LPCT1 = MIN( INT( THCKHO*THSTPI + 1.D0 ), NSTEP+1 ) #else C LOOK FOR SLANT THICKNESS OF BEGIN OF STEP AUXOLD = (XEMIS-XSTEP2)*STHCPH + (YEMIS-YSTEP2)*STHSPH * - (ZEMIS-ZSTEP2)*CTH + RLOFF #endif C IF STARTING POINT BEYOND FURTHEST LEVEL THEN DON''T CHECK IF ( RLONG(NSTEP) .GT. AUXOLD ) THEN #if __CURVED__ XNEW = XEMIS+XSTEP2 YNEW = YEMIS+YSTEP2 ZNEW = ZEMIS+ZSTEP2 WANEW = COS( SQRT( XNEW**2 + YNEW**2 ) / C(1) ) ZAPNEW = ( C(1) + ZNEW ) * WANEW - C(1) C CALCULATE AUXILIAR QUANTITIES AT END OF STEP IF ( WANEW .NE. 1.D0 ) THEN C WE ARE AWAY FROM DETECOR C CALCULATE AZIMUTH ANGLE OF PARTICLE SEEN FROM DETECTOR IF ( YNEW .NE. 0.D0 .OR. XNEW .NE. 0.D0 ) THEN PHI1 = ATAN2( YNEW, XNEW ) ELSE PHI1 = 0.D0 ENDIF C HORIZONTAL DISTANCE OF PARTICLE TO DETECTOR RRR = SQRT( (1.D0-WANEW)*(1.D0+WANEW) ) * * ( C(1) + ZAPNEW ) / WANEW XXX = RRR * COS( PHI1 ) YYY = RRR * SIN( PHI1 ) ELSE C WE ARE IN THE DETECTOR SYSTEM AND NEED NO COORDINATE CALCULATION XXX = XNEW YYY = YNEW ENDIF C SLANT THICKNESS AT END OF STEP AUXNEW = XXX*STHCPH + YYY*STHSPH - ZAPNEW*CTH + RLOFF THCKHN = THCKSI( AUXNEW ) LPCT2 = MIN( INT( THCKHN*THSTPI ), NSTEP ) #else C SLANT THICKNESS AT END OF STEP AUXNEW = (XEMIS+XSTEP2)*STHCPH + (YEMIS+YSTEP2)*STHSPH * - (ZEMIS+ZSTEP2)*CTH + RLOFF C FIND FIRST THE EQUIVALENT LEVELS C THE PARTICLE IS TRACKED FROM ZEMIS-ZSTEP2 DOWN TO ZEMIS+ZSTEP2 THCKHO = THCKSI( AUXOLD ) !old thicknes THCKHN = THCKSI( AUXNEW ) !new thicknes LPCT1 = LBIN( XEMIS-XSTEP2,YEMIS-YSTEP2,ZEMIS-ZSTEP2,1 ) LPCT2 = LBIN( XEMIS+XSTEP2,YEMIS+YSTEP2,ZEMIS+ZSTEP2,LPCT1 ) * - 1 LPCT2 = MIN( LPCT2, NSTEP+1 ) #endif #else C IF STARTING POINT IS BELOW LOWEST LEVEL THEN DON''T CHECK. IF ( HLONG(NSTEP) .LE. (ZEMIS-ZSTEP2) ) THEN C FIND FIRST THE EQUIVALENT LEVELS C THE PARTICLE IS TRACKED FROM ZEMIS-ZSTEP2 DOWN TO ZEMIS+ZSTEP2 THCKHO = THICK( ZEMIS-ZSTEP2 ) THCKHN = THICK( ZEMIS+ZSTEP2 ) LPCT1 = INT( THCKHO*THSTPI + 1.D0 ) LPCT2 = INT( THCKHN*THSTPI ) LPCT2 = MIN( LPCT2, NSTEP ) #endif C TOTAL PATH LENGTH STEPT IN UNITS OF LONGI BINS STEPT = (THCKHN - THCKHO) * THSTPI C OLD INTEGRATED MODE IS OBTAINED BY INTEGRATION OF THE LONGITUDINAL C CHERENKOV DISTRIBUTION AT THE END OF THE SHOWER IN AAMAIN. THIS IS C MUCH MORE EFFICIENT THAN THE OLDER PROCEDURE. HOMOGENEOUS GENERATION C OF CHERENKOV PHOTONS ALONG PATH IS ASSUMED. C PHOTB IS NUMBER OF CHERENKOV PHOTONS EMITTED IN EACH BIN. IF ( STEPT .GT. 0.D0 ) THEN #if __THIN__ PHOTB = PHOTCM * WTCER / STEPT #else PHOTB = PHOTCM / STEPT #endif ELSE PHOTB = 0.D0 ENDIF C PHOTONS EMITTED IN FIRST BIN PHOTB1 = PHOTB * (DBLE(LPCT1) - THCKHO*THSTPI) C PHOTONS EMITTED IN LAST BIN IF ( LPCT2 .GE. LPCT1 ) THEN PHOTBN = PHOTB*(THCKHN*THSTPI - DBLE(LPCT2)) ELSE PHOTBN = PHOTB*(THCKHN*THSTPI - DBLE(LPCT1)) ENDIF C NOW FILL FIRST AND LAST+1 BIN, THEN LOOP OVER THE BINS BETWEEN PLONG(LPCT1,9) = PLONG(LPCT1,9) + PHOTB1 IF ( LPCT2 .LT. NSTEP ) THEN PLONG(LPCT2+1,9) = PLONG(LPCT2+1,9) + PHOTBN ENDIF C LOOP OVER ALL LONGITUDINAL BINS IF ( LPCT2 .GT. LPCT1 ) THEN DO IL = LPCT1, LPCT2-1 PLONG(IL+1,9) = PLONG(IL+1,9) + PHOTB ENDDO ENDIF ENDIF RETURN END #endif #if (__CERWLEN__ || __CEFFIC__) && __CERENKOV__ *-- Author : V. de Souza Filho, Uni. Campinas 22/06/1999 C======================================================================= SUBROUTINE CESPEC( CEWL ) C----------------------------------------------------------------------- C CE(RENKOV) SPEC(TRUM) C C THIS FUNCTION DRAWS A WAVELENGTH FOR THE EMITTED CHERENKOV PHOTON. C THE VARIABLE WAVLGL AND WAVLGU ARE INPUT PARAMETERS DETERMINED C IN THE STEERING DATA FILE. C THE WAVELENGTH RETURNED IN THIS SUBROUT. OBEYS THE C DISTRIBUITION FUNTION 1/LAMBDA**2. C WAVLGL = MINIMUM WAVELENGTH FOR THE CHERENKOV EMISSION C WAVLGU = MAXIMUM WAVELENGTH FOR THE CHERENKOV EMISSION C CERNOR = NORMALIZATION CONSTANT FOR THE DISTRIBUITION C THIS SUBROUTINE IS CALLED FROM CERENK. C ARGUMENT: C CEWL = EMISSION WAVELENGTH (NM) C----------------------------------------------------------------------- IMPLICIT NONE #define __CEREN1INC__ #define __RANDPAINC__ #define __RUNPARINC__ #include "corsika.h" DOUBLE PRECISION CEWL SAVE C----------------------------------------------------------------------- CC IF ( DEBUG .OR. LCERDB ) WRITE(MDEBUG,*) 'CESPEC:' CALL RMMARD( RD,1,3 ) CEWL = CERNOR*WAVLGL/(CERNOR-RD(1)*WAVLGL) RETURN END #endif #if __CURVED__ && __CERENKOV__ *-- Author : F. SCHROEDER UNI WUPPERTAL 30/06/99 C======================================================================= DOUBLE PRECISION FUNCTION DISTIP(THEAP,HEAPP) C----------------------------------------------------------------------- C DIST(ANCE) I(NTER)P(OLATION) C C DETERMINES CHANGE IN DISTANCE FROM SHOWER CORE BY INTERPOLATING C BETWEEN VALUES OF A TWO DIMENSIONAL TABLE TAKING INTO ACCOUNT BENDING C OF THE CHERENKOV LIGHT IN CURVED ATMOSPHERE. C THIS FUNCTION IS CALLED FROM CERENK. C ARGUMENTS: C THEAP = COSINE OF EMISSION ANGLE (DEG) OF CHERENKOV PHOTON C SEEN FROM THE DETECTOR C HEAPP = EMISSION HEIGHT (CM) OF CHERENKOV PHOTON C SEEN FROM THE DETECTOR IN CM C C DESIGN : F. SCHROEDER UNI WUPPERTAL C----------------------------------------------------------------------- IMPLICIT NONE #define __CONSTAINC__ #define __OBSPARINC__ #define __RTABLEINC__ #include "corsika.h" DOUBLE PRECISION ADIST,BDIST,B,FACT,HEAPP,HEAPP2,HM1,HM2,OBS, * THEAP,THEAP2,THN1,THN2 INTEGER M1,M2,N1,N2 LOGICAL FIRST SAVE DATA FIRST / .TRUE. / C----------------------------------------------------------------------- IF ( FIRST ) THEN FACT = 180.D0/PI FIRST = .FALSE. C TRANSFORM OBSLEV(1) IN UNITS OF KM*4 OBS = OBSLEV(1) * 1.D-5 * 4.D0 ENDIF C TRANSFORM INPUT PARAMETERS IN BETTER UNITS THEAP2 = ACOS( THEAP ) * FACT * 4.D0 ! NOW THETA IN DEG*4 HEAPP2 = HEAPP * 1.D-5 * 4.D0 ! AND HEIGHT IN KM*4 C DISTIP = DISTIP(THEAP, HEAPP) = DISTEF(N, M) (N*M-MATRIX) C MONOTONIC ASCENDING ORDER: C THEAP: [0- 90] DEG => THEAP(0) = 0 DEG, THEAP(NTHETA) = 90 DEG C HEAPP: [0-113] KM => HEAPP(1) = 0 KM, HEAPP(MHEIGH) = 113 KM C GET NUMBERS (APPARENT THETA) (N2,N1) WHICH ARE NEAREST TO THEAP N2 = INT( THEAP2 ) N1 = N2 + 1 C GET NUMBERS (APPARENT HEIGHT) (M2,M1) WHICH ARE NEAREST TO HEAPP M2 = INT( HEAPP2 ) M1 = M2 + 1 C NOW PERFORM LINEAR INTERPOLATION OF DISTEF BETWEEN TABULATED VALUES C HEAPP(M) = M*4 [KM] C THEAP(N) = N*4 [DEG] THN1 = DBLE(N1) THN2 = DBLE(N2) HM1 = DBLE(M1) HM2 = DBLE(M2) IF ( HM2 .LT. OBS ) HM2 = OBS C INTERPOLATE BETWEEN DISTEF(N2, M2) AND DISTEF(N2, M1) B = ( DISTEF(N2, M1) - DISTEF(N2, M2) ) / ( HM1 - HM2 ) ADIST = B * ( HEAPP2 - HM2 ) + DISTEF(N2, M2) C INTERPOLATE BETWEEN DISTEF(N1, M2) AND DISTEF(N1, M1) B = ( DISTEF(N1, M1) - DISTEF(N1, M2) ) / ( HM1 - HM2 ) BDIST = B * ( HEAPP2 - HM2 ) + DISTEF(N1, M2) C INTERPOLATE BETWEEN ADIST=DISTEF(N2,M_MEAN) C AND BDIST=DISTEF(N1,M_MEAN) B = ( BDIST - ADIST ) / ( THN1 - THN2 ) DISTIP = B * ( THEAP2 - THN2 ) + ADIST RETURN END #endif #if __CERENKOV__ || __AUGCERLONG__ *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE GETBUS( IPARTI,ENERGYP,THETAP,CERSZE ) C----------------------------------------------------------------------- C GET BU(NCH) S(IZE) C C CALCULATES OPTIMAL BUNCH SIZE FOR CHERENKOV PHOTONS. CHERENKOV PHOTONS C ARE GROUPED IN BUNCHES IN ORDER TO ACCELERATE COMPUTING TIME. C HOWEVER, WE SET A MAXIMAL VALUE FOR THE GROUPING OF CHERENKOV PHOTONS C SO THAT WE GET AT LEAST 100 BUNCHES/M**2 AT A CHERENKOV FLUX OF 3000 C PHOTONS/M**2. THIS IS THE MINIMUM CHERENKOV FLUX WHICH CAN BE C DISTINGUISHED FROM THE NIGHT SKY LIGHT BACKGROUND IN THE HEGRA C EXPERIMENT AT THE ISLAND LA PALMA. SO THE PARAMETERIZATION OF THE C CHERENKOV BUNCH AS CALCULATED IN THIS SUBROUTINE IS VALID FOR C OBSERVATION LEVELS SIMILAR TO THAT OF THE HEGRA EXPERIMENT. C FOR A GIVEN PRIMARY PARTICLE, INCIDENT ENERGY AND ANGLE, AN C OPTIMAL BUNCH SIZE IS CALCULATED BY INTERPOLATION IN A TABLE, C WHERE WE HAVE CHOSEN AN ENERGY RANGE UP TO 1000 TEV, INCIDENT C ANGLES 0 AND 40 DEGREES, AND 4 TYPES OF PRIMARIS: GAMMAS, C PROTONS, NITROGEN, AND IRON. C THIS SUBROUTINE IS CALLED FROM AAMAIN. C ARGUMENTS: C IPARTI = TYPE OF PRIMARY PARTICLE C ENERGYP= PARTICLES ENERGY (GEV) C THETAP = ANGLE (RAD) C CERSZE = SIZE OF CHERENKOV BUNCH C----------------------------------------------------------------------- IMPLICIT NONE #define __CEREN1INC__ #define __CONSTAINC__ #define __RUNPARINC__ #if __IACT__ #define __CEREN2INC__ #endif #include "corsika.h" #if __IACT__ DOUBLE PRECISION CCF,CERSZE,ENERGYP,THETAP INTEGER IPARTI SAVE C----------------------------------------------------------------------- IF ( IPARTI .GE. 200 ) THEN CCF = 2.D0 + 0.5D0 *LOG( 0.01D0*IPARTI ) ELSEIF ( IPARTI .GT. 3 ) THEN CCF = 2.D0 ELSE CCF = 1.D0 ENDIF CERSZE=.1D-3*ENERGYP/CCF*(ACERX/3.D2)*(ACERY/3.D2)*COS( THETAP ) IF ( CERSZE .LT. 1.D0 ) CERSZE = 1.D0 IF ( CERSZE .GT. 100.D0 ) CERSZE = 100.D0 #else DOUBLE PRECISION ANGLE(2),ENGAM(3),ENHAD(3),ENNIT(2), * SIFE(3,2),SIGAM(3,2),SINIT(2),SIPRO(3,2) DOUBLE PRECISION CERSZE,ENERGY,ENERGYP,THETA,THETAP DOUBLE PRECISION CERS1F,CERS1P,S1,S2 INTEGER I,IANFE,IANP,IATNUM,IPARTI,I1,I2 SAVE DATA ANGLE / 0.D0, 40.D0 / DATA ENGAM / 100.D0, 200.D0, 500.D0 / DATA ENHAD / 100.D0, 200.D0, 1000.D0 / DATA ENNIT / 200.D0, 1000.D0 / DATA ( SIFE (I,1),I=1,3 ) / 30.D0, 30.D0, 140.D0 / DATA ( SIFE (I,2),I=1,3 ) / 30.D0, 30.D0, 110.D0 / DATA ( SIGAM(I,1),I=1,3 ) / 30.D0, 45.D0, 100.D0 / DATA ( SIGAM(I,2),I=1,3 ) / 30.D0, 40.D0, 100.D0 / DATA SINIT / 30.D0, 150.D0 / DATA ( SIPRO(I,1),I=1,3 ) / 30.D0, 30.D0, 120.D0 / DATA ( SIPRO(I,2),I=1,3 ) / 30.D0, 30.D0, 160.D0 / DATA IANP / 1 /, IANFE / 26 / C----------------------------------------------------------------------- IF ( DEBUG .OR. LCERDB ) WRITE(MDEBUG,100) IPARTI,ENERGYP,THETAP 100 FORMAT(' GETBUS: INPUT PARTICLE = ',I5,1P,2E10.3) C DEFAULT VALUE CERSZE = 100.D0 ENERGY = 1.D-3*ENERGYP IF ( ENERGY .LE. 100.D0 ) THEN CERSZE = 30.D0 IF ( DEBUG .OR. LCERDB ) WRITE(MDEBUG,101) CERSZE RETURN ENDIF THETA = THETAP / PI * 180.D0 C----------------------------------------------------------------------- C GAMMA, ELECTRON OR POSITRON AS PRIMARY PARTICLE IF ( IPARTI .LE. 3 ) THEN C FIND ENERGY BIN FOR INTERPOLATION IF ( ENERGY .LE. ENGAM(2) ) THEN I1 = 1 I2 = 2 ELSE I1 = 2 I2 = 3 ENDIF S1 = SIGAM(I1,1) + (ENERGY - ENGAM(I1)) * / (ENGAM(I2) - ENGAM(I1)) * * (SIGAM(I2,1) - SIGAM(I1,1)) S2 = SIGAM(I1,2) + (ENERGY - ENGAM(I1)) * / (ENGAM(I2) - ENGAM(I1)) * * (SIGAM(I2,2) - SIGAM(I1,2)) CERSZE = S1 + (THETA-ANGLE(1))/(ANGLE(2)-ANGLE(1)) * (S2-S1) IF ( DEBUG .OR. LCERDB ) WRITE(MDEBUG,101) CERSZE RETURN ENDIF C----------------------------------------------------------------------- C NITROGEN AS PRIMARY PARTICLE AND VERTICAL INCIDENCE CJOK WHY SPECIAL TREATMENT FOR NITROGEN ???? CJOK WHY ONLY VERTICAL INCIDENCE ???? IF ( IPARTI .EQ. 1407 .AND. ABS(THETA) .LT. 1.D-1 ) THEN IF ( ENERGY .LT. 200.D0 ) THEN CERSZE = 30.D0 ELSE CERSZE = SINIT(1) + (ENERGY-ENNIT(1)) * / (ENNIT(2)-ENNIT(1)) * (SINIT(2)-SINIT(1)) ENDIF IF ( DEBUG .OR. LCERDB ) WRITE(MDEBUG,101) CERSZE RETURN ENDIF C----------------------------------------------------------------------- C GET THE ATOMIC NUMBER OF THE NUCLEUS C Z IS 1, IF PROTON IF ( IPARTI .EQ. 14 ) THEN IATNUM = 1 C REST OF POSSIBLE NUCLEI ELSEIF ( IPARTI .GE. 200 ) THEN IATNUM = MOD(IPARTI,100) IF ( IATNUM .GT. 26 ) THEN WRITE(MONIOU,*) 'GETBUS: UNEXPECTED PARTICLE CODE',IPARTI RETURN ENDIF ELSE WRITE(MONIOU,*) 'GETBUS: UNEXPECTED PARTICLE CODE',IPARTI RETURN ENDIF C FIND ENERGY BIN FOR INTERPOLATION IN CASE OF HADRONIC PRIMARY IF ( ENERGY .LE. ENHAD(2) ) THEN I1 = 1 I2 = 2 ELSE I1 = 2 I2 = 3 ENDIF C INTERPOLATION FOR HADRONS S1 = SIPRO(I1,1) + (ENERGY-ENHAD(I1)) * / (ENHAD(I2)-ENHAD(I1)) * (SIPRO(I2,1)-SIPRO(I1,1)) S2 = SIPRO(I1,2) + (ENERGY-ENHAD(I1)) * / (ENHAD(I2)-ENHAD(I1)) * (SIPRO(I2,2)-SIPRO(I1,2)) CERS1P = S1 + (THETA-ANGLE(1)) / (ANGLE(2)-ANGLE(1)) * (S2-S1) S1 = SIFE(I1,1) + (ENERGY-ENHAD(I1)) / (ENHAD(I2)-ENHAD(I1)) * * (SIFE(I2,1)-SIFE(I1,1)) S2 = SIFE(I1,2) + (ENERGY-ENHAD(I1)) / (ENHAD(I2)-ENHAD(I1)) * * (SIFE(I2,2)-SIFE(I1,2)) CERS1F = S1 + (THETA-ANGLE(1)) / (ANGLE(2)-ANGLE(1)) * (S2-S1) CERSZE = CERS1P + (IATNUM-IANP) * (CERS1F-CERS1P) / (IANFE-IANP) #endif IF ( DEBUG .OR. LCERDB ) WRITE(MDEBUG,101) CERSZE 101 FORMAT(' GETBUS: BUNCH SIZE = ',1P,1E10.3) RETURN END #endif #if __CURVED__ && __CERENKOV__ *-- Author : F. SCHROEDER UNI WUPPERTAL 09/04/99 C======================================================================= SUBROUTINE INRTAB C----------------------------------------------------------------------- C IN(IT) R(EFRACTION) TAB(LE) C C INITIALIZES TABLE FOR INTERPOLATION OF DISTANCE FROM SHOWER CORE C AND TIME OF FLIGHT OF THE CHERENKOV PHOTON C NUMERICAL CALCULATION OF DISTANCE FROM SHOWER CORE AND TIME OF FLIGHT C FOR DISCRETE ZENITH ANGLES AND HEIGHT DIFFERENCES TAKING INTO ACCOUNT C BENDING OF THE CHERENKOV LIGHT IN A CURVED ATMOSPHERE C THIS SUBROUTINE IS CALLED FROM INPRM. C ARGUMENTS: C OBS = HEIGHT OF OBSERVATION LEVEL IN CM C----------------------------------------------------------------------- IMPLICIT NONE #define __CONSTAINC__ #define __CEREN1INC__ #define __OBSPARINC__ #define __PARPARINC__ #define __RTABLEINC__ #define __RUNPARINC__ #if __ATMEXT__ #define __ATMOSXINC__ #endif #include "corsika.h" DOUBLE PRECISION DDIST,DHAPP,DHELP,DLEN,DT,HE,HAPPST,HEAPP, * HST,HSTM,HSTOLD,R,RHE, * RHST,RHSTM,THEAP,THAPP1,THAPP2,VLIGHTI INTEGER I,M,N,NSTEPS SAVE #if __ATMEXT__ DOUBLE PRECISION REFIDX EXTERNAL REFIDX #endif DOUBLE PRECISION RHOF EXTERNAL RHOF C NUMBER OF STEPS FOR NUMERIC INTEGRATION DATA NSTEPS / 1000 / C----------------------------------------------------------------------- IF ( DEBUG .OR. LCERDB ) * WRITE(MONIOU,*) 'REFRACTIVE INDEX TABLE IS INITIALIZED BY INRTAB' C ETADSN = 0.00028232D0 / RHOF(0.D0) C INVERSE OF VELOCITY OF LIGHT IN CM/NS VLIGHTI = 1.D9/C(25) C EARTH RADIUS IN CM R = C(1) C DISTEF = DISTEF(THEAP, HEAPP) = DISTEF(N, M) (N*M-MATRIX) C TOF = TOF(THEAP, HEAPP) = TOF(N, M) (N*M-MATRIX) C MONOTONIC ASCENDING ORDER: C THEAP: [0- 90] DEG => THEAP(0) = 0 DEG, THEAP(NTHETA) = 90 DEG C HEAPP: [0-113] KM => HEAPP(0) = 0 KM, HEAPP(MHEIGH) = 113 KM C THEAP = EMISSION ANGLE OF CHERENKOV PHOTON SEEN FROM THE DETECTOR C HEAPP = EMISSION HEIGHT OF CHERENKOV PHOTON SEEN FROM THE DETECTOR DO N = 0, NTHETA DO M = 0, MHEIGH C APPARENT EMISSION ANGLE IN RAD * 1/4 THEAP = DBLE(N) * .25D0 * PI / 180.D0 C APPARENT EMISSION HEIGHT IN CM * 1/4 HEAPP = DBLE(M) * .25D0 * 1.D5 IF ( HEAPP .LE. OBSLEV(1) .OR. * THEAP .GT. 89.0D0*PI/180.D0 ) THEN DISTEF(N,M) = 0.D0 ! NO CALCULATION OF DISTEF AND TOF TOF(N, M) = 0.D0 ! IF EMISSION HEIGHT IS UNDER GOTO 100 ! OBSERVATION LEVEL ENDIF C LOCAL EMISSION HEIGHT FOR INDEX OF REFRACTION DHELP = (HEAPP-OBSLEV(1)) * TAN( THEAP ) HE = -R + SQRT( DHELP**2 + (R+HEAPP)**2 ) #if __ATMEXT__ IF ( IATMOX .GE. 1 ) THEN RHE = REFIDX( HE ) ELSE RHE = 1.D0 + ETADSN * RHOF(HE) ENDIF #else RHE = 1.D0 + ETADSN * RHOF(HE) #endif C SMALL CHANGE IN HEAPP FOR NUMERICAL INTEGRATION DHAPP = (HEAPP-OBSLEV(1)) / DBLE( NSTEPS ) C START VALUES FOR NUMERICAL INTEGRATION C PERFORM CALCULATION IN APPARENT COORDINATES + LOCAL HEIGHT C FOR THE INDEX OF REFRACTION HST = HE HAPPST = HEAPP THAPP2 = THEAP DISTEF(N,M) = 0.D0 TOF(N, M) = 0.D0 DO I = 1, NSTEPS HAPPST = HAPPST - DHAPP DHELP = (HAPPST-OBSLEV(1)) * TAN( THAPP2 ) HSTOLD = HST HST = -R + SQRT( DHELP**2 + (R+HAPPST)**2 ) HSTM = HST + 0.5D0 * (HSTOLD-HST) #if __ATMEXT__ IF ( IATMOX .GE. 1 ) THEN RHST = REFIDX( HST ) RHSTM = REFIDX( HSTM ) ELSE RHST = 1.D0 + ETADSN * RHOF(HST) RHSTM = 1.D0 + ETADSN * RHOF(HSTM) ENDIF #else RHST = 1.D0 + ETADSN * RHOF(HST) RHSTM = 1.D0 + ETADSN * RHOF(HSTM) #endif THAPP1 = THAPP2 THAPP2 = ASIN( RHE/RHST * SIN( THEAP ) ) DDIST = DHAPP * TAN( 0.5D0*(THAPP1 + THAPP2) ) DLEN = DHAPP / COS( 0.5D0*(THAPP1 + THAPP2) ) DT = DLEN * RHSTM * VLIGHTI DISTEF(N, M) = DISTEF(N,M) + DDIST TOF(N, M) = TOF(N, M) + DT ENDDO 100 CONTINUE ENDDO ENDDO C PRINT A SECTION OF THE TOF(N,M) TABLE IF ( DEBUG .OR. LCERDB ) THEN WRITE(MDEBUG,201) 201 FORMAT(1H ,' HEIGHT | ANGLE (DEG) ') WRITE(MDEBUG,202) (DBLE(N)*.25D0,N=0,9) 202 FORMAT(1H ,' (KM) |',10F8.2) WRITE(MDEBUG,203) (N,N=0,9) 203 FORMAT(1H ,' N =',10(I7,1X)) WRITE(MDEBUG,204) 204 FORMAT(1H ,92('-'),'| M') C LOOP OVER HEIGHT DO M = 0, 40 WRITE(MDEBUG,211) DBLE(M)*.25D0,(TOF(N,M),N=0,9),M 211 FORMAT(1H ,F9.5,' |',10(1X,F7.1),' |',I3) ENDDO WRITE(MDEBUG,*) ' ' ENDIF RETURN END #endif #if __CEFFIC__ && __CERENKOV__ *-- Author : V. de Souza Filho, Uni. Campinas 22/06/1999 C======================================================================= DOUBLE PRECISION FUNCTION LINEAR( X,IX0,IX1,FX0,FX1 ) C----------------------------------------------------------------------- C LINEAR (INTERPOLATION) C C THIS FUNCTION INTERPOLATES A TABLE FOR THE POINT X C GIVEN TWO POINTS (X0 AND X1) AND THEIR CORRESPONDING VALUES FX0 C AND FX1. THE INTERPOLATION IS LINEAR. C X0 AND X1 HAVE INTEGER VALUES BECAUSE THEY ARE USED AS ARRAY C PARAMETERS IN OTHER FUNCTIONS. C SOME INTERPOLATION METHODS WERE TESTED: LAGRANGIAN C POLYNOMIALS, LINEAR INTERPOLATION AND CUBIC SPLINES. THE RESULTS C SHOWED THAT A LINEAR INTERPOLATION OFFERS A GOOD APROXIMATION OWING TO C THE TABLES'' CHARACTERISTICS. BESIDES THAT, LINEAR INTERPOLATION IS A C VERY FAST INTERPOLATION METHOD. C C THIS FUNCTION IS CALLED FROM TPDINI, TPDCP FOR INTERPOLATIONS C IN HEIGHT AND WAVELENGTH OF THE ABSORTION TABLE. C ARGUMENTS: C X = ABSCISSA VALUE FOR WHICH THE FUNCTION VALUE IS SEARCHED C IX0 = LOWER ABSCISSA VALUE C IK1 = UPPER ABSCISSA VALUE C FX0 = FUNCTION VALUE FOR IX0 C FX1 = FUNCTION VALUE FOR IX1 C----------------------------------------------------------------------- IMPLICIT NONE #define __RUNPARINC__ #include "corsika.h" DOUBLE PRECISION FX0,FX1,X INTEGER IX0,IX1 SAVE C----------------------------------------------------------------------- CC IF ( DEBUG ) WRITE(MDEBUG,*) 'LINEAR:' LINEAR = FX0 + (FX1-FX0)*(X-IX0)/(IX1-IX0) RETURN END #endif #if __CERENKOV__ *-- Author : The CORSIKA development group 21/04/94 C======================================================================= SUBROUTINE OUTND2 C----------------------------------------------------------------------- C OUT(PUT AT E)ND (OF SHOWER) C C WRITE REST OF PARTICLES TO OUTPUT BUFFER C THIS SUBROUTINE IS CALLED FROM AAMAIN. C----------------------------------------------------------------------- IMPLICIT NONE #define __RUNPARINC__ #define __CEREN2INC__ #define __CERTELINC__ #define __CEREN3INC__ #include "corsika.h" INTEGER I, II SAVE C----------------------------------------------------------------------- do II=1,ncerbuf IF ( LHCER(II) .GT. 0 ) THEN CALL TOBUFC( DATAB2(1, II), 0, II ) C CLEAR DATAB2 BUFFER DO I = 1,MAXBF2 DATAB2(I, II) = 0. ENDDO ENDIF LHCER(II) = 0 enddo WRITE(MONIOU,*) 'CERCNT = ',SNGL( CERCNT ) CERCNT = 0.D0 RETURN END #endif #if __CERENKOV__ *-- Author : The CORSIKA development group 21/04/94 C======================================================================= SUBROUTINE OUTPT2( ICERBUF ) C----------------------------------------------------------------------- C (WRITE CHERENKOV RADIATION) OUTP(U)T C C OUTPUT SUBROUT. FOR CHERENKOV PHOTONS C THIS SUBROUTINE IS CALLED FROM CERENK. C----------------------------------------------------------------------- IMPLICIT NONE #define __BUFFSINC__ #define __EGSDEBINC__ #define __RUNPARINC__ #define __CEREN1INC__ #define __CEREN2INC__ #define __CERTELINC__ #define __CEREN3INC__ #if __THIN__ #define __RANDPAINC__ #define __THNVARINC__ #endif #include "corsika.h" DOUBLE PRECISION WLFLAG #if __CEFFIC__ C OUTPUT DATA ARE PHOTOELECTRON BUNCHES ORIGINATING FROM PHOTONS C OF SPECIFIC WAVELENGTH PARAMETER (WLFLAG = -1.D0 ) #elif __CERWLEN__ C OUTPUT DATA ARE PHOTON BUNCHES OF SPECIFIC WAVELENGTH PARAMETER (WLFLAG = 1.D0 ) #else C OUTPUT DATA ARE PHOTON BUNCHES OF UNSPECIFIED WAVELENGTH PARAMETER (WLFLAG = 0.D0 ) #endif #if __THIN__ DOUBLE PRECISION PROBTH,RR2 #endif INTEGER ICERBUF, IBUF INTEGER I LOGICAL ROUT SAVE C----------------------------------------------------------------------- IF ( FEGSDB .OR. LCERDB ) WRITE(MDEBUG,3) * PHOTCM,XCER,YCER,UEMIS,VEMIS,CARTIM,ZEMIS #if __THIN__ * ,WTCER #endif 3 FORMAT(' OUTPT2: ',1P,8E11.3) ROUT = .TRUE. #if __THIN__ C DO RADIAL THIN-OUT OF OUTPUT PARTICLES (ACC. S. SCIUTTO) C (ONLY WRITING TO FILE IS AFFECTED, ALL TABLES AND COUNTERS ARE NOT.) RR2 = XCER**2 + YCER**2 PROBTH = 1.D0 IF ( RLIM ) THEN IF ( RR2 .LT. RMAX2 ) THEN CALL RMMARD( RD,1,1) * PROBTH = RR2/RMAX2 PROBTH = (RR2/RMAX2)**2 IF ( RD(1) .GT. PROBTH ) THEN ROUT = .FALSE. ENDIF ENDIF ENDIF #endif C WRITE A BLOCK OF 39 PARTICLES TO THE CHERENKOV OUTPUT BUFFER AND C CLEAR FIELD CERCNT = CERCNT + PHOTCM IF ( MCERFI .NE. 0 ) THEN ! WRITE TO CER OUTPUT FILE IF ( ROUT ) THEN IBUF = ICERBUF IF ( MCERFI .EQ. 1 ) THEN DATAB2(LHCER(IBUF)+1, IBUF ) = PHOTCM ELSE C CASE OF MCERFI IS 2 OR 3 #if __THIN__ DATAB2(LHCER(IBUF)+1,IBUF) = PHOTCM*WTCER/MAX(1.D-10,PROBTH) #else DATAB2(LHCER(IBUF)+1,IBUF) = PHOTCM #endif ENDIF DATAB2(LHCER(IBUF)+2, IBUF) = XCER DATAB2(LHCER(IBUF)+3, IBUF) = YCER DATAB2(LHCER(IBUF)+4, IBUF) = UEMIS DATAB2(LHCER(IBUF)+5, IBUF) = VEMIS DATAB2(LHCER(IBUF)+6, IBUF) = CARTIM IF ( MCERFI .LE. 2 ) THEN DATAB2(LHCER(IBUF)+7, IBUF) = ZEMIS ELSE ! CASE OF MCERFI IS 3 DATAB2(LHCER(IBUF)+7, IBUF) = CERDIST ENDIF #if __THIN__ IF ( MCERFI .EQ. 1 ) THEN DATAB2(LHCER(IBUF)+8, IBUF) = WTCER/MAX( 1.D-10, PROBTH ) ELSE C CASE OF MCERFI IS 2 OR 3 #if __CEFFIC__ || __CERWLEN__ DATAB2(LHCER(IBUF)+8, IBUF) = WL*WLFLAG #else DATAB2(LHCER(IBUF)+8, IBUF) = WLFLAG #endif ENDIF LHCER(IBUF) = LHCER(IBUF) + 8 #else LHCER(IBUF) = LHCER(IBUF) + 7 #endif C COUNT CERENKOV BUNCHES THAT ARE WRITTEN TO TAPE NOCERB = NOCERB + 1 IF ( LHCER(IBUF) .GE. MAXBF2 ) THEN CALL TOBUFC( DATAB2(1, IBUF), 0, IBUF ) DO I = 1,MAXBF2 DATAB2(I, IBUF) = 0. ENDDO LHCER(IBUF) = 0 ENDIF ENDIF ELSE ! NOW MCERFI IS 0, PARTICLE DATA OUTPUT C WRITE A BLOCK OF 39 PARTICLES TO THE PARTICLE OUTPUT BUFFER AND C CLEAR FIELD IF ( ROUT ) THEN #if __THIN__ DATAB(LH+1) = 99.E5 + 1.0 + * NINT( PHOTCM*WTCER/MAX(1.D-10,PROBTH) )*10. #else DATAB(LH+1) = 99.E5 + NINT( PHOTCM )*10. + 1. #endif DATAB(LH+2) = XCER DATAB(LH+3) = YCER DATAB(LH+4) = UEMIS DATAB(LH+5) = VEMIS DATAB(LH+6) = CARTIM DATAB(LH+7) = ZEMIS cdh DATAB(LH+7) = CERDIST !cdh EMISSION PATH LENGTH NOT cdh ! COMPATIBLE WITH OLDER VERSIONS cdh ! WHICH USED EMISSION HEIGHT #if __THIN__ #if __CEFFIC__ || __CERWLEN__ DATAB(LH+8) = WL*WLFLAG #else DATAB(LH+8) = WTCER/MAX( 1.D-10,PROBTH ) #endif LH = LH + 8 #else LH = LH + 7 #endif C COUNT CERENKOV BUNCHES THAT ARE WRITTEN TO TAPE NOPART = NOPART + 1 IF ( LH .GE. MAXBUF ) THEN CALL TOBUF( DATAB,0 ) DO I = 1,MAXBUF DATAB(I) = 0. ENDDO LH = 0 ENDIF ENDIF ENDIF RETURN END #endif #if __CERENKOV__ && !__IACT__ *-- Author : The CORSIKA development group 06/10/1995 C======================================================================= SUBROUTINE SELCOR( XX,YY ) C----------------------------------------------------------------------- C SEL(ECT) COR(E LOCATION) C C SELECT A QUASI RANDOM CORE LOCATION. C THIS SUBROUTINE IS CALLED FROM INPRM. C ARGUMENTS: C XX = X-VALUE OF QUASI-RANDOM CORE LOCATION (CM) C YY = Y-VALUE OF QUASI-RANDOM CORE LOCATION (CM) C----------------------------------------------------------------------- IMPLICIT NONE #define __CEREN1INC__ #define __CEREN2INC__ #define __RANDPAINC__ #define __RUNPARINC__ #include "corsika.h" DOUBLE PRECISION RND(2),XX,YY INTEGER I LOGICAL FIRST SAVE DATA FIRST / .TRUE. / C----------------------------------------------------------------------- IF ( DEBUG .OR. LCERDB ) WRITE(MDEBUG,*) 'SELCOR:' C INITIALIZE SOBOL NUMBER GENERATOR IF ( FIRST ) THEN FIRST = .FALSE. CALL SOBSEQ( -2,RND ) C CALL THE RANDOM GENERATOR MANY TIMES ACCORDING SEED OF THIRD SEQUENCE C (WHICH IS USED FOR CERENKOV PHOTON GENERATION) C TO PREVENT STARTING WITH IDENTICAL NUMBER FOR DIFFERENT RUNS DO I = 1, ISEED(1,3) CALL SOBSEQ( 2,RND ) ENDDO ENDIF C TAKE A PAIR OF QUASI RANDOM NUMBERS CALL SOBSEQ( 2,RND ) XX = XSCATT * (2.D0*RND(1)-1.D0) YY = YSCATT * (2.D0*RND(2)-1.D0) IF ( DEBUG .OR. LCERDB ) * WRITE(MDEBUG,*) 'SELCOR: CORE LOCATION X=',XX,' Y=',YY RETURN END #endif #if (__CERENKOV__ && !__IACT__) || __AUGERHIT__ *-- Author : The CORSIKA development group 06/10/1995 C======================================================================= SUBROUTINE SOBSEQ( N,XX ) C----------------------------------------------------------------------- C SOB(OL) SEQ(UENCE) C C SOBOL QUASI RANDOM NUMBER GENERATOR C REFERENCE : NUMERICAL RECIPES, W.H. PRESS ET AL., C CAMBRIDGE UNIVERSITY PRESS, 1992 ISBN 0 521 43064 X C THIS SUBROUTINE IS CALLED FROM SELCOR. C ARGUMENTS: C N = NUMBER OF QUASI-RANDOM NUMBERS C XX = ARRAY CONTAINING THE RANDOM NUMBERS C C THIS ROUTINE USES 'LOGICAL AND' AND 'EXCLUSIVE OR' SYSTEM FUNCTIONS C 'IAND' AND 'IEOR' WHICH ARE NON-STANDARD FORTRAN FUNCTIONS !! C-==============================================================-------- IMPLICIT NONE #define __RUNPARINC__ #include "corsika.h" DOUBLE PRECISION XX(*),FAC INTEGER N,MAXBIT,MAXDIM PARAMETER ( MAXBIT = 30, MAXDIM = 6 ) INTEGER I,IM,IN,IPP,J,K,L,IP(MAXDIM),IU(MAXDIM,MAXBIT), * IV(MAXBIT*MAXDIM),IX(MAXDIM),MDEG(MAXDIM) EQUIVALENCE (IV,IU) SAVE DATA IP /0,1,1,2,1,4/, MDEG /1,2,3,3,4,4/, IX /6*0/, * IV /6*1, 3,1,3,3,1,1, 5,7,7,3,3,5, * 15,11,5,15,13,9, 156*0/ C----------------------------------------------------------------------- IF ( N .LT. 0 ) THEN #if __PARALLEL__ C TO INITIALIZE THE SLAVES CORRECTLY IN THE PARALLEL VERSION C THESE VALUES MUST NOT BE TAKEN FROM DATA STATEMENT IV( 1) = 1 IV( 2) = 1 IV( 3) = 1 IV( 4) = 1 IV( 5) = 1 IV( 6) = 1 IV( 7) = 3 IV( 8) = 1 IV( 9) = 3 IV(10) = 3 IV(11) = 1 IV(12) = 1 IV(13) = 5 IV(14) = 7 IV(15) = 7 IV(16) = 3 IV(17) = 3 IV(18) = 5 IV(19) = 15 IV(20) = 11 IV(21) = 5 IV(22) = 15 IV(23) = 13 IV(24) = 9 DO I = 25, 180 IV(I) = 0 ENDDO DO I = 1, 6 IX = 0 ENDDO #endif DO K = 1, MAXDIM DO J = 1, MDEG(K) IU(K,J) = IU(K,J) * 2**(MAXBIT-J) ENDDO DO J = MDEG(K)+1, MAXBIT IPP = IP(K) I = IU(K,J-MDEG(K)) C IEOR IS A NON-STANDARD FORTRAN SYSTEM FUNCTION MAKING 'EXCLUSIVE OR' I = IEOR(I,I/2**MDEG(K)) DO L = MDEG(K)-1, 1, -1 C IAND IS A NON-STANDARD FORTRAN SYSTEM FUNCTION MAKING 'LOGICAL AND' IF ( IAND(IPP,1) .NE. 0 ) I = IEOR(I,IU(K,J-L)) IPP = IPP/2 ENDDO IU(K,J) = I ENDDO ENDDO FAC = 1.D0/(2.D0**MAXBIT) IN = 0 ELSE IM = IN DO J = 1, MAXBIT C IAND IS A NON-STANDARD FORTRAN SYSTEM FUNCTION MAKING 'LOGICAL AND' IF ( IAND(IM,1) .EQ. 0 ) GOTO 1 IM = IM/2 ENDDO WRITE(MONIOU,*)'SOBSEQ: MAXBIT =',MAXBIT,' TOO SMALL IN SOBSEQ' STOP 1 CONTINUE IM = (J-1) * MAXDIM DO K = 1, MIN( N, MAXDIM ) C IEOR IS A NON-STANDARD FORTRAN SYSTEM FUNCTION MAKING 'EXCLUSIVE OR' IX(K) = IEOR(IX(K),IV(IM+K)) XX(K) = IX(K) * FAC ENDDO IN = IN+1 ENDIF RETURN END #endif #if __CERENKOV__ && !__IACT__ *-- Author : R. Ulrich IKP KIT Karlsruhe 22/10/16 C======================================================================= INTEGER FUNCTION TELOUT(XPOSCER,YPOSCER,UDIRCER,VDIRCER) C----------------------------------------------------------------------- C ROUTINE TO CHECK WETHER CHERENKOV PHOTON HITS TELESCOPE C THIS FUNCTION IS CALLED FROM CERENK. C ARGUMENTS: C XPOSCER = X-POSITION OF PHOTON AT TELESCOPE C YPOSCER = Y-POSITION OF PHOTON AT TELESCOPE C UDIRCER = DIRECTION OF PHOTON RELATIVE TO X-DIRECTION C VDIRCER = DIRECTION OF PHOTON RELATIVE TO Y-DIRECTION C----------------------------------------------------------------------- IMPLICIT NONE #define __CEREN2INC__ #define __CERTELINC__ #define __OBSPARINC__ #define __RUNPARINC__ #include "corsika.h" DOUBLE PRECISION XPOSCER, YPOSCER, UDIRCER, VDIRCER DOUBLE PRECISION DUMX, DUMY, DUMZ, DUMPD, DUMSPH DOUBLE PRECISION DXCER, DYCER, DZCER DOUBLE PRECISION TELX, TELY, TELZ INTEGER I,J SAVE C----------------------------------------------------------------------- C PHOTON DIRECTION DXCER = UDIRCER DYCER = VDIRCER DZCER = -SQRT( 1.D0 - UDIRCER**2 - VDIRCER**2 ) C LOOP OVER POSSIBLE EVENTS/CORES DO I = 1, ICERML C LOOP OVER ALL TELESCOPES DO J = 1, NCERTEL C -CORE + TEL_POS TELX = -CERXOS(I) + CERTELX(J) TELY = -CERYOS(I) + CERTELY(J) TELZ = -OBSLEV(NOBSLV) + CERTELZ(J) C CHER_POS + CORE - TEL_POS DUMX = XPOSCER - TELX DUMY = YPOSCER - TELY c DUMZ = OBSLEV(NOBSLV) - TELZ DUMZ = 0.d2 - TELZ C XPOSCER + CERXOS(I) - CERTELX(j) DUMPD = DXCER*DUMX + DYCER*DUMY + DZCER*DUMZ DUMSPH = DUMPD**2-(DUMX**2+DUMY**2+DUMZ**2)+CERTELR(J)**2 IF ( DUMSPH .GE. 0.D0 ) THEN TELOUT = CERTELID(J) RETURN ENDIF ENDDO ENDDO TELOUT = -1 RETURN END *-- Author : R. Ulrich IKP KIT Karlsruhe 22/10/16 C======================================================================= SUBROUTINE TELSET( TELX,TELY,TELZ,TELR,TELID ) C----------------------------------------------------------------------- C ALSO WITHOUT THE IACT C ROUTINES WE WANT TO KEEP THE C OPTION TO RECORD CHERENKOV PHOTONS IN TELESCOP POSITION "SPHERES" C THIS ROUTINE IS CALLED FROM DATAC. C ARGUMENTS: C TELX, TELY, TELZ = COORDINATES OF CHERENKOV TELESCOPE POSITION C TELR = RADIUS OF SPHERE IN WHICH TELESCOPE IS CONTAINED C TELID = TELESCOPE IDENTIFICATION C----------------------------------------------------------------------- IMPLICIT NONE #define __RUNPARINC__ #define __CERTELINC__ #include "corsika.h" DOUBLE PRECISION TELX, TELY, TELZ, TELR INTEGER TELID SAVE C----------------------------------------------------------------------- IF ( NCERTEL .GT. NMAXCERTEL ) THEN WRITE(MONIOU,*) 'TOO MANY CHERENKOV TELESCOPES DEFINED' WRITE(MONIOU,*) 'MAXIMUM NUMBER IS: ', NMAXCERTEL STOP ENDIF NCERTEL = NCERTEL + 1 CERTELX(NCERTEL) = TELX CERTELY(NCERTEL) = TELY CERTELZ(NCERTEL) = TELZ CERTELR(NCERTEL) = TELR CERTELID(NCERTEL) = TELID RETURN END #endif #if __CEFFIC__ && __CERENKOV__ *-- Author : V. de Souza Filho, Uni. Campinas 22/06/1999 C===================================================================== SUBROUTINE TELEFF( ABSORB ) C----------------------------------------------------------------------- C TEL(ESCOPE) EFF(ICIENCY) C C THIS SUBROUT. RETURNS THE LOGICAL VARIABLE ABSORB. C ABSORB WILL RECEIVE TRUE IF THE CHERENKOV PHOTON WAS CONSIDERED C ABSORBED AFTER APPLYING MIRROR REFLECTIVITY AND QUANTUM EFFICIENCY. C RIWL = R(EFERENCE) I(NDEX OF) W(AVE)L(ENGTH). THIS VARIABLE IS C USED TO DETERMINE THE ADJACENT TABULATED POINTS. C FX0,FX1= VARIABLES USED TO CALL LINEAR. C MIRREC = PROBABILITY OF NOT BEING ABSORBED OWING TO MIRROR C REFLECTIVITY C QEFFC = PORBABILITY OF A PHOTON BEING CONVERTED TO A PHOTO-ELECTRON C OWING TO QUANTUM EFFICIENCY OF THE PMT. C THIS SUBROUTINE IS CALLED FROM CERENK. C ARGUMENT: C ABSORB = LOGICAL, TRUE IF PHOTON IS ABSORBED. C----------------------------------------------------------------------- IMPLICIT NONE #define __CERABSINC__ #define __CEREN1INC__ #define __CEREN2INC__ #define __RANDPAINC__ #define __RUNPARINC__ #include "corsika.h" DOUBLE PRECISION LINEAR,PROBAB,MIRREC,QEFFC,FX0,FX1 INTEGER RIWL,WLI0,WLI1 LOGICAL ABSORB SAVE EXTERNAL LINEAR C----------------------------------------------------------------------- CC IF ( LCERDB ) WRITE(MDEBUG,*) 'TELEFF:' C CALCULATE THE REFERENCE WL AND INDEX OF WL FOR THE INTERPOLATIONS RIWL = 1 + INT( (WL-180.D0)/5.D0 ) WLI0 = RIWL*5 + 175 WLI1 = RIWL*5 + 175 + 5 C TELESCOPE EFFICIENCY C CONSIDER MIRROR REFLECTIVITY IF ( CERMIR ) THEN FX0 = MIRREF(RIWL) FX1 = MIRREF(RIWL + 1) MIRREC = LINEAR(WL,WLI0,WLI1,FX0,FX1) ELSE MIRREC = 1.D0 ENDIF C CONSIDER QUANTUM EFFICIENCY IF ( CERQEF ) THEN FX0 = QUAEFF(RIWL) FX1 = QUAEFF(RIWL + 1) QEFFC = LINEAR(WL,WLI0,WLI1,FX0,FX1) ELSE QEFFC = 1.D0 ENDIF PROBAB = MIRREC*QEFFC CALL RMMARD( RD,1,3 ) IF ( RD(1) .LE. PROBAB ) THEN ABSORB = .FALSE. ELSE ABSORB = .TRUE. ENDIF RETURN END #endif #if __CERENKOV__ *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE TOBUFC( A,IFL,ICERBUF ) C----------------------------------------------------------------------- C (WRITE) TO BUF(FER) C(HERENKOV DATA) C C COPY TO BUFFER CHERENKOV DATA. C THIS SUBROUTINE IS CALLED FROM AAMAIN, INPRM, ELECTR, PHOTON, OUTND2, C AND OUTPT2. C ARGUMENTS: C A = ARRAY TO BE WRITTEN TO FILE C IFL = STARTING OF FINAL OUTPUT C = 0 NORMAL BLOCK C = 1 NORMAL BLOCK WITH END OF OUTPUT C = 2 ONLY END OF OUTPUT C ICERBUF = NUMBER OF TELESCOPE OUTPUT FILE C----------------------------------------------------------------------- IMPLICIT NONE #define __BUFFSINC__ #define __CEREN1INC__ #define __CERTELINC__ #define __CEREN3INC__ #define __RUNPARINC__ #include "corsika.h" C NSUBBL IS NUMBER OF SUBBLOCKS IN ONE OUTPUT RECORD INTEGER NSUBBL PARAMETER ( NSUBBL = 21 ) REAL A(*),A1 #if __THIN__ C (OUTPUT RECORD LENGTH = NSUBBL * 39 * 8 * 4 BYTES <= 26208 ) #else C (OUTPUT RECORD LENGTH = NSUBBL * 39 * 7 * 4 BYTES <= 22932 ) #endif C OUTPUT BUFFER FOR CHERENKOV OUTPUT REAL OUTBF2(MAXBF2,NSUBBL,NMAXCERTEL) * ,OUTVECT(MAXBF2*NSUBBL,NMAXCERTEL) INTEGER ICERBUF C IBLK2 IS COUNTER FOR SUBBLOCKS OF CHERENKOV OUTPUT INTEGER I,IBLK2(NMAXCERTEL),IFL,K * ,J CHARACTER*4 CNAME SAVE DATA IBLK2/ NMAXCERTEL*0 / C----------------------------------------------------------------------- A1=A(1) IF ( LCERDB ) WRITE(MDEBUG,*) 'TOBUFC ('//CNAME//'): IFL =',IFL IF ( IFL .LE. 1 ) THEN IBLK2(ICERBUF) = IBLK2(ICERBUF) + 1 DO I = 1, MAXBF2 OUTBF2(I,IBLK2(ICERBUF),ICERBUF) = A(I) ENDDO ENDIF C WRITE TO FILE IF BLOCK IS FULL OR IF IFL IS 1 IF ( IFL .GE. 1 .OR. IBLK2(ICERBUF) .EQ. NSUBBL ) THEN NRECER = NRECER + 1 c WRITE(MCETAP) ((OUTBF2(I,K),I=1,MAXBF2),K=1,NSUBBL) J = 0 DO K = 1, NSUBBL DO I = 1, MAXBF2 J = J + 1 OUTVECT(J,ICERBUF) = OUTBF2(I,K,ICERBUF) ENDDO ENDDO #if __PARALLEL__ CALL JOINDAT( MAXBF2, NSUBBL, OUTVECT(1,ICERBUF) ) #else CALL FWRITEMCETAP( MAXBF2, NSUBBL, OUTVECT(1,ICERBUF), ICERBUF ) #endif IBLK2(ICERBUF) = 0 DO K = 1, NSUBBL DO I = 1, MAXBF2 OUTBF2(I,K,ICERBUF) = 0.0 ENDDO ENDDO ENDIF RETURN END #endif #if __CURVED__ && __CERENKOV__ *-- Author : F. SCHROEDER UNI WUPPERTAL 01/07/99 C======================================================================= DOUBLE PRECISION FUNCTION TOFIP(THEAP,HEAPP) C----------------------------------------------------------------------- C T(IME) O(F) F(LIGHT) I(NTER)P(OLATION) C C DETERMINES TIME OF FLIGHT OF CHERENKOV PHOTON BY INTERPOLATING C BETWEEN VALUES OF A TWO DIMENSIONAL TABLE TAKING INTO ACCOUNT C BENDING OF THE CHERENKOV LIGHT IN A CURVED ATMOSPHERE C THIS SUBROUTINE IS CALLED FROM CERENK. C ARGUMENTS: C THEAP = COSINE OF EMISSION ANGLE OF CHERENKOV PHOTON C SEEN FROM THE DETECTOR C HEAPP = EMISSION HEIGHT (CM) OF CHERENKOV PHOTON C SEEN FROM THE DETECTOR C C DESIGN : F. SCHROEDER UNI WUPPERTAL C----------------------------------------------------------------------- IMPLICIT NONE #define __CEREN1INC__ #define __CONSTAINC__ #define __EGSDEBINC__ #define __OBSPARINC__ #define __RTABLEINC__ #define __RUNPARINC__ #include "corsika.h" DOUBLE PRECISION ATOF,BTOF,B,FACT,HEAPP,HEAPP2,HM1,HM2,OBS, * THEAP,THEAP2,THN1,THN2 INTEGER M1,M2,N1,N2 LOGICAL FIRST SAVE DATA FIRST / .TRUE. / C----------------------------------------------------------------------- IF ( FIRST ) THEN FACT = 180.D0/PI FIRST = .FALSE. C TRANSFORM ALSO OBSLEV(1) IN UNITS OF KM*4 OBS = OBSLEV(1) * 1.D-5 * 4.D0 ENDIF C TRANSFORM INPUT PARAMETERS IN BETTER UNITS THEAP2 = ACOS( THEAP ) * FACT * 4.D0 ! NOW THETA IN DEG*4 HEAPP2 = HEAPP * 1.D-5 * 4.D0 ! AND HEIGHT IN KM*4 C TOF = TOF(THEAP, HEAPP) = TOF(N, M) (N*M-MATRIX) C MONOTONIC ASCENDING ORDER: C THEAP: [0- 90] DEG => THEAP(0) = 0 DEG, THEAP(NTHETA) = 90 DEG C HEAPP: [0-113] KM => HEAPP(0) = 0 KM, HEAPP(MHEIGH) = 113 KM C GET NUMBERS (APPARENT THETA) (N2,N1) WHICH ARE NEAREST TO THEAP N2 = INT( THEAP2 ) N1 = N2 + 1 C GET NUMBERS (APPARENT HEIGHT) (M2,M1) WHICH ARE NEAREST TO HEAPP M2 = INT( HEAPP2 ) M1 = M2 + 1 C NOW PERFORM LINEAR INTERPOLATION OF TOF BETWEEN TABULATED VALUES C HEAPP(M) = M*4 [KM] C THEAP(N) = N*4 [DEG] THN1 = DBLE(N1) THN2 = DBLE(N2) HM1 = DBLE(M1) HM2 = DBLE(M2) IF ( HM2 .LT. OBS ) HM2 = OBS C INTERPOLATE BETWEEN TOF(N2,M2) AND TOF(N2,M1) B = ( TOF(N2, M1) - TOF(N2, M2) ) / ( HM1 - HM2 ) ATOF = B * ( HEAPP2 - HM2 ) + TOF(N2, M2) C INTERPOLATE BETWEEN TOF(N1,M2) AND TOF(N1,M1) B = ( TOF(N1, M1) - TOF(N1, M2) ) / ( HM1 - HM2 ) BTOF = B * ( HEAPP2 - HM2 ) + TOF(N1, M2) C INTERPOLATE BETWEEN ATOF = TOF(N-1,M_MEAN) C AND BTOF = TOF(N,M_MEAN) B = ( BTOF - ATOF ) / ( THN1 - THN2 ) TOFIP = B * ( THEAP2 - THN2 ) + ATOF IF ( LCERDB ) THEN WRITE(MDEBUG,*) 'TOFIP =',SNGL(TOFIP),' N2=',N2,' M2=',M2 ENDIF RETURN END #endif #if __CEFFIC__ && __CERENKOV__ *-- Author : V. de Souza Filho, Uni. Campinas 22/06/1999 C======================================================================= SUBROUTINE TPDINI( OBLECE ) C----------------------------------------------------------------------- C T(OTAL) P(ROBABILITY OF) D(ETECTION) INI(TIATION) C C THIS SUBROUTINE: C - READS THE ATMOSPHERIC EXTINCTION COEFFICIENT C - READS THE MIRROR REFLECTIVITY C - READS THE QUANTUM EFFICIENCY C - CALCULATES THE ATMOSPHERIC EXTINCTION COEFFICIENT FOR THE C OBSERVATION LEVEL. C ATMABS: THIS MATRIX STORES THE ATMOSPHERIC EXTINCTION C COEFFICIENT. THE ROWS STAND FOR THE WAVELENGTH (THERE ARE 105 C POINTS IN THE INTERVAL 180-700 NM IN BINS OF 5 NM) C AND THE COLUMNS STAND FOR THE HEIGHT OF EMISSION. THE HEIGHT C IS IN THE INTERVAL 0-50 KM IN BINS OF 1 KM. C ATEOBS: ATMOSPHERIC EXTINCTION COEFFICIENT FOR THE OBSERVATION LEVEL. C QUAEFF: ARRAY STORES THE QUANTUM EFFECIENCY OF THE PMT C MIRREF: ARRAY STORES THE MIRROR REFLECTIVITY C C THE TABLE FOR THE ATMOSPHERIC EXTINCTION COEFFICIENTS IS C GIVEN IN TERMS OF THE WAVELENGTH AND HEIGHT OF EMISSION OF C THE PHOTON. IT IS STORED IN THE FILE atmabs.dat. C C THE QUANTUM EFFICIENCY USED HERE WAS MEASURED BY GLENN SEMBROSKI C FOR A HAMAMATSU R1398HA PHOTOMULTIPLIER WITH UV WINDOW AND C 1.125'' TUBE. THE DATA IS WRITTEN IN THE FILE quanteff.dat IN THE C FORMAT(8F6.3) C C THE MIRROR REFLECTIVITY WAS MEASURED FOR THE RECOATED MIRRORS C IN THE WHIPPLE TELESCOPE ON SEPTEMBER 1993. IT IS WRITTEN IN THE FILE C mirreff.dat IN THE FORMAT (8F6.3). C C THIS SUBROUTINE IS CALLED FROM INPRM. C ARGUMENT: C OBLECE = OBSERVATION LEVEL (CM) C----------------------------------------------------------------------- IMPLICIT NONE #define __CEREN1INC__ #define __CERABSINC__ #define __RUNPARINC__ #include "corsika.h" DOUBLE PRECISION OBLECE,X,LINEAR,FX0,FX1 INTEGER I,J,WLT,X0,X1,IWL CHARACTER*80 TEXTABS,TEXTQEF,TEXTREF SAVE EXTERNAL LINEAR C----------------------------------------------------------------------- CC IF ( LCERDB ) WRITE(MDEBUG,*) 'TPDINI:' IF ( CERATA ) THEN C READ THE TABLE OF ATMOSPHERIC EXTINCTION AND STORE IT IN THE C ATMABS MATRIX. OPEN(UNIT=MCERABS,FILE=DATDIR(1:INDEX(DATDIR,' ')-1)// * 'atmabs.dat',STATUS='OLD',FORM='FORMATTED',ERR=994) READ(MCERABS,20) TEXTABS 20 FORMAT(A80) DO I = 1, 105 READ(MCERABS,21) WLT 21 FORMAT(I4) READ(MCERABS,*,ERR=995,END=995) (ATMABS(I,J), J=0,50) ENDDO CLOSE( MCERABS ) WRITE(MONIOU,22) TEXTABS 22 FORMAT(1X,A80,' IS READ') C CALCULATE THE ATMOSPHERIC EXTINCTION FOR THE OBSERVATION LEVEL C FOR ALL WAVELENGTH PREVIOUS RECORDED (180-700 NM IN 5 NM INTERVALS) C SET THE VALUES TO INTERPOLATE X = OBLECE/1.D5 X0 = INT( X ) X1 = INT( X ) + 1 C CALCULATE THE ATM. EXTINCTION FOR OBS. LEVEL INTERPOLATING THE TABLE DO IWL = 1, 105 FX0 = ATMABS(IWL,X0) FX1 = ATMABS(IWL,X1) ATEOBS(IWL) = LINEAR(X,X0,X1,FX0,FX1) ENDDO ENDIF IF ( CERQEF ) THEN C READ THE QUANTUM EFFECIENCY OF THE PMT OPEN(UNIT=MCERQEF,FILE=DATDIR(1:INDEX(DATDIR,' ')-1)// * 'quanteff.dat',STATUS='OLD',FORM='FORMATTED',ERR=996) READ(MCERQEF,20) TEXTQEF READ(MCERQEF,23,ERR=997,END=997) (QUAEFF(I),I = 1,105) 23 FORMAT(8F6.3) CLOSE( MCERQEF ) WRITE(MONIOU,22) TEXTQEF ENDIF IF ( CERMIR ) THEN C READ THE MIRROR REFLECTIVITY OPEN(UNIT=MCERMIR,FILE=DATDIR(1:INDEX(DATDIR,' ')-1)// * 'mirreff.dat',STATUS='OLD',FORM='FORMATTED',ERR=998) READ(MCERMIR,20) TEXTREF READ(MCERMIR,23,END=999,ERR=999) (MIRREF(I), I=1,105) CLOSE( MCERMIR ) WRITE(MONIOU,22) TEXTREF ENDIF RETURN 994 CONTINUE WRITE(MONIOU,*) 'TPDINI: ERROR WHEN OPENING FILE atmabs.dat' STOP 995 CONTINUE WRITE(MONIOU,*) 'TPDINI: ERROR WHEN READING FILE atmabs.dat' STOP 996 CONTINUE WRITE(MONIOU,*) 'TPDINI: ERROR WHEN OPENING FILE quanteff.dat' STOP 997 CONTINUE WRITE(MONIOU,*) 'TPDINI: ERROR WHEN READING FILE quanteff.dat' STOP 998 CONTINUE WRITE(MONIOU,*) 'TPDINI: ERROR WHEN OPENING FILE mirreff.dat' STOP 999 CONTINUE WRITE(MONIOU,*) 'TPDINI: ERROR WHEN READING FILE mirreff.dat' STOP END #endif #if __ANAHIST__ || __AUGERHIST__ || __MUONHIST__ *-- Author : M. RISSE IK FZK KARLSRUHE 16/02/2001 C======================================================================= SUBROUTINE AHISTOUT C----------------------------------------------------------------------- #if __ANAHIST__ C A(NALYSE) HIST(OGRAM) OUT C C WRITES OUT HISTOGRAMMING OF SHOWER ANALYSIS #endif #if __AUGERHIST__ C A(UGER) HIST(OGRAM) OUT C C WRITES OUT HISTOGRAMMING TO FOLLOW THE EVOLUTION OF SHOWERS C FOR THE AUGER EXPERIMENT. #endif #if __MUONHIST__ C C WRITES OUT HISTOGRAMMING OF MUONS IN THE SHOWER DEVELOPMENT #endif C THIS SUBROUTINE IS CALLED FROM AAMAIN. C----------------------------------------------------------------------- IMPLICIT NONE #define __RUNPARINC__ #include "corsika.h" INTEGER ICYCLE,LREC #if __BYTERECL__ INTEGER ISTAT #endif SAVE C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'AHISTOUT: START' C DATASET FOR HBOOK HISTOGRAM OUTPUT C DATASET MUST BE PREFORMATTED ctp20130823 OPEN, OUT and CLOSE can be replaced by HRPUT only c#if __BYTERECL__ c LREC = 4*1024 cctp File is open in HROPEN (with lower case letters: DATnnn -> datnnn) cctp OPEN(UNIT=LUNHST,FORM='UNFORMATTED',RECL=4*1024,ACCESS='DIRECT', cctp * STATUS='UNKNOWN',FILE=DSNHST) c WRITE(MONIOU,10) DSNHST c 10 FORMAT(' AHISTOUT: HISTOGRAMS WILL BE WRITTEN TO ',/,9X,A79) c CALL HROPEN( LUNHST,'TOP', DSNHST,'N',LREC,ISTAT ) c WRITE(MONIOU,*) 'ISTAT = ',ISTAT c#else c LREC = 1024 cC WITH DEC FORTRAN COMPILER RECL IS USUALLY IN WORDS c OPEN(UNIT=LUNHST,FORM='UNFORMATTED',RECL=1024,ACCESS='DIRECT', c * STATUS='UNKNOWN',FILE=DSNHST) c WRITE(MONIOU,10) DSNHST c 10 FORMAT(' AHISTOUT: HISTOGRAMS WILL BE WRITTEN TO ',/,9X,A79) cccc CALL HROPEN( LUNHST,'TOP', DSNHST,'N',LREC,ISTAT ) c CALL HRFILE( LUNHST,'TOP','N' ) c#endif c CALL HROUT( 0,ICYCLE,' ' ) c CALL RZSTAT( '//TOP',10,' ' ) c CALL HREND( 'TOP' ) c CLOSE( UNIT=LUNHST ) c IF ( ISTAT .EQ. 0 ) THEN c WRITE(MONIOU,11) DSNHST c 11 FORMAT(/,' AHISTOUT: HISTOGRAMS ARE WRITTEN TO ',/,9X,A79) c ELSE c WRITE(MONIOU,*) 'AHISTOUT: PROBLEMS TO WRITE ON FILE ',DSNHST c ENDIF WRITE(MONIOU,10) DSNHST 10 FORMAT(' AHISTOUT: HISTOGRAMS WILL BE WRITTEN TO ',/,9X,A79) CALL HRPUT( 0, DSNHST, 'N') WRITE(MONIOU,11) DSNHST 11 FORMAT(/,' AHISTOUT: HISTOGRAMS ARE WRITTEN TO ',/,9X,A79) C PRINT WARNING RESPECTING THE CORRECT NUMBER OF ENTRIES WRITE(MONIOU,*) * 'ATTENTION: LISTED ENTRIES MUST EVENTUALLY BE DIVIDED BY 2' WRITE(MONIOU,*) * '=========================================================' C PRINT INDEX OF FILLED HISTOGRAMS CALL HINDEX RETURN END #endif #if __ANAHIST__ *-- Author : M. RISSE IK FZK KARLSRUHE 16/02/2001 C======================================================================= SUBROUTINE ANAHISTFIL C----------------------------------------------------------------------- C ANA(LYZE) HIST(OGRAM) FIL(LING) C C FILLING OF THE HISTOGRAMMING TO ANALYZE SHOWERS. C THE POSITION COORDINATES IN OUTPAR ARE RELATIVE TO SHOWER AXIS. C THIS SUBROUTINE IS CALLED FROM OUTPT1. C----------------------------------------------------------------------- IMPLICIT NONE #define __CONSTAINC__ #define __OBSPARINC__ #define __PAMINC__ #define __PARPARINC__ #define __RUNPARINC__ #define __SFRONTINC__ #include "corsika.h" DOUBLE PRECISION X,XX,XXPROJ,Y,YY,YYPROJ,RRPROJ REAL COSTHE,EPART,EPLOG,PHI,phix,phiy,THETA REAL LOGR,LOGT,LOGWT,T,TF,TABS,TREL,WT INTEGER IDENT,IDI SAVE C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'ANAHISTFIL: LEVL=',LEVL C------- GET PARTICLE COORDINATES AND PARAMETER IDENT = NINT( OUTPAR(0) ) WT = OUTPAR(13) X = OUTPAR(7) Y = OUTPAR(8) COSTHE = OUTPAR(2) PHIX = OUTPAR(3) PHIY = OUTPAR(4) IF ( PHIX .NE. 0. .OR. PHIY .NE. 0. ) THEN PHI = ATAN2( PHIY,PHIX ) ELSE PHI = 0. ENDIF T = OUTPAR(6)* 1.E9 C------- EPART: TOT. ENERGY (GeV); EPLOG = LOG10(EKIN) C------- FOR EM PART (+ NEUTRINOS): OUTPAR(1)=E_TOT C------- ELSE: OUTPAR(1)=GAMMA-FACTOR IF ( IDENT .EQ. 1 ) THEN EPART = OUTPAR(1) EPLOG = LOG10(OUTPAR(1)) ELSEIF ( IDENT .EQ. 2 .OR. IDENT .EQ. 3 ) THEN EPART = OUTPAR(1) EPLOG = LOG10(OUTPAR(1)-PAMA(IDENT)) ELSEIF ( IDENT .GT. 4 .AND. IDENT .LE. 65 ) THEN EPART = OUTPAR(1) * PAMA(IDENT) EPLOG = LOG10((OUTPAR(1)-1.D0) * PAMA(IDENT)) ELSE EPART = 0. EPLOG = -5. ENDIF IF ( LEVL .EQ. NOBSLV ) THEN THETA = ACOS( COSTHE ) C CALCULATE ARRIVAL TIME OF SPHERICAL SHOWER FRONT AT POINT(X,Y) TF = SQRT( ( HEIGHPS-OBSLEV(LEVL) )**2 + * ( X-XOFFS )**2 + ( Y-YOFFS )**2 ) * 1.D9 / C(25) IF ( DEBUG ) WRITE(MDEBUG,*) 'ANAHISTFIL: TF=',TF C GET THE ARRIVAL TIME (IN NSEC) OF PARTICLE WITH RESPECT TO THE C SPHERICAL SHOWER FRONT THIS A GOOD QUANTITY TO GET A LOCAL TIME C DISTRIBUTION AT ONE DETECTOR TREL = T - TF C HOWEVER, WITH TREL VALUES ONE CANNOT RECONSTRUCT A SHOWER FRONT C SINCE TF IS SUBTRACTED FROM THE TIMES AND TF IS DEPENDENT ON THE C POSITION IN X AND Y. C TO GET THE CORRECT ARRIVAL TIMES AT DIFFERENT DETECTORS SUBTRACT FROM C THE SIMPLE ARRIVAL TIME T THE TIME TCEN WHEN THE SHOWER AXIS HITS THE C GROUND. (SEE EVALUATION OF TCEN IN ROUT. SHOWERFRONT.) C THIS DIFFERENCE IS NEGATIVE FOR ABOUT HALF THE PARTICLES IN INCLINED C SHOWERS TABS = T - TCEN IF ( TREL .GT. 0. ) THEN LOGT = LOG10(TREL) ELSE LOGT = -1.E30 ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) 'ANAHISTFIL: T=',T * ,' LOGT=',LOGT C CALCULATE DISTANCE FROM SHOWER AXIS IN METERS XX = X * 0.01D0 YY = Y * 0.01D0 C CALCULATE THE RADIUS PROJECTED ON TO THE PLANE PERPENDICULAR TO THE C SHOWER AXIS IN METERS XXPROJ = XX * PROFAK1 + YY * PROFAK2 YYPROJ = XX * PROFAK2 + YY * PROFAK3 RRPROJ = SQRT( XXPROJ**2 + YYPROJ**2 ) C USE FOR PLOTTING THE RADIUS IN THE PLANE PERPENDICULAR TO THE SHOWER C AXIS IF ( RRPROJ .GT. 0.D0 ) THEN LOGR = LOG10(RRPROJ) ELSE LOGR = -1.E30 ENDIF LOGWT = LOG10(WT) C NOW FILLING OF HISTOGRAMS STARTS C OVERALL CALL HFILL( 99,FLOAT(IDENT),LOGR,WT ) C DEFINE PARTICLE TYPE AND COUNT PARTICLES C ...... EGS GAMMAS IF ( IDENT .EQ. 1 ) THEN IDI = 1 C ...... POSITRONS ELSEIF ( IDENT .EQ. 2 ) THEN IDI = 2 C ...... ELECTRONS ELSEIF ( IDENT .EQ. 3 ) THEN IDI = 3 C ...... MUONS+ ELSEIF ( IDENT .EQ. 5 ) THEN IDI = 4 C ...... MUONS- ELSEIF ( IDENT .EQ. 6 ) THEN IDI = 5 C ...... PIONS+ ELSEIF ( IDENT .EQ. 8 ) THEN IDI = 6 C ...... PIONS- ELSEIF ( IDENT .EQ. 9 ) THEN IDI = 7 C ...... PROTON/ANTIPROTON ELSEIF ( IDENT .EQ. 14 .OR. IDENT .EQ. 15 ) THEN IDI = 8 C ...... NEUTRON/ANTINEUTRON ELSEIF ( IDENT .EQ. 13 .OR. IDENT .EQ. 25 ) THEN IDI = 9 ELSE C ...... OTHER PARTICLES IDI = 11 ENDIF C FILL HISTOGRAMS C HERE WE PLOT RADIAL DISTRIBUTIONS WHERE THE RADIUS C IS CALCULATED IN THE PLANE PERPENDICULAR TO THE SHOWER AXIS. C WE USE HERE THE RADIUS BEFORE ANY CUT BY RADIAL THINNING IN C SUBR. OUTPT1 IS MADE CALL HFILL( 100+IDI,LOGR,0.,WT ) CALL HFILL( 120+IDI,LOGR,0.,1. ) CALL HFILL( 140+IDI,LOGR,0.,WT*EPART ) C WE GET THE PARTICLE BEFORE THE RADIAL THINNING, MUST ALSO C NOT CARE ABOUT RMAX CALL HFILL( 160+IDI,EPLOG,0.,WT ) CALL HFILL( 180+IDI,EPLOG,0.,1. ) CALL HFILL( 200+IDI,LOGT,0.,WT ) CALL HFILL( 220+IDI,LOGT,0.,1. ) CALL HFILL( 240+IDI,THETA,0.,WT ) CALL HFILL( 260+IDI,THETA,0.,1. ) CALL HFILL( 280+IDI,PHI,0.,WT ) CALL HFILL( 300+IDI,PHI,0.,1. ) CALL HFILL( 320+IDI,LOGWT,0.,1. ) CALL HFILL( 340+IDI,EPLOG,LOGR,WT ) CALL HFILL( 360+IDI,LOGT,LOGR,WT ) CALL HFILL( 380+IDI,EPLOG,LOGT,WT ) CALL HFILL( 400+IDI,LOGWT,EPLOG,1. ) CALL HFILL( 420+IDI,LOGWT,LOGR,1. ) CALL HFILL( 440+IDI,LOGWT,LOGT,1. ) ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) 'ANAHISTFIL: END' RETURN END #endif #if __AUGERHIST__ *-- Author : D. HECK IK FZK KARLSRUHE 21/06/2001 C======================================================================= SUBROUTINE AUGACT( EDEP,LL,VONWO ) C----------------------------------------------------------------------- C AUG(ER) A(NGULAR) C(U)T(TED EGS PARTICLES AT OBSERVATION LEVEL SLICE) C C THE PARTICLE COORDINATES ARE MOVED FROM THE EGS STACK STACKE TO C THE OUTPUT STACK OUTPAR. C THIS SUBROUTINE IS CALLED FROM ELECTR AND PHOTON. C ARGUMENTS: C EDEP = DEPOSITED ENERGY (IN MEV!!!) (WITHOUT WEIGHTING) C LL = NUMBER OF OBSERVATION LEVEL C VONWO = CHARACTER*10 GIVING CALLING ROUTINE C----------------------------------------------------------------------- IMPLICIT NONE #define __GENERINC__ #define __PARPARINC__ #define __RUNPARINC__ #define __STACKEINC__ #include "corsika.h" DOUBLE PRECISION EDEP,EDEP2 INTEGER II,LL CHARACTER*10 VONWO SAVE C----------------------------------------------------------------------- IF (DEBUG) WRITE(MDEBUG,*) * 'AUGACT: EDEP=',EDEP*0.001D0,' LL=',LL,' CALLED FROM ',VONWO C PARTICLE IS WRITTEN IN OUTPUT BUFFER ARRAY OUTPAR(0) = IQ(NP) OUTPAR(1) = E(NP)*0.001D0 OUTPAR(2) = MIN( 1.D0, W(NP) ) OUTPAR(3) = U(NP) OUTPAR(4) =-V(NP) OUTPAR(5) =-Z(NP) OUTPAR(6) = TIM(NP) OUTPAR(7) = X(NP) OUTPAR(8) =-Y(NP) OUTPAR(9) = IGEN(NP) OUTPAR(10) = ALEVEL OUTPAR(13) = WT(NP) IF ( DEBUG ) WRITE(MDEBUG,444) (OUTPAR(II),II=0,9), WT(NP) 444 FORMAT(' AUGACT: EGSPAR=',1P,9E11.3,0P,F10.0,1P,E10.3) C CONVERT DEPOSIT FROM MEV TO GEV EDEP2 = EDEP * 0.001D0 * WT(NP) C NOW FILL IN THE ENERGY DEPOSIT INTO THE HISTOS CALL AUGERDEPFIL( EDEP2,LL,1 ) RETURN END #endif #if __AUGERHIST__ *-- Author : D. HECK IK FZK KARLSRUHE 25/09/2001 C======================================================================= SUBROUTINE AUGCER( STEPCR,UMEAN,VMEAN,WMEAN,EBEG,EEND,XBEG,YBEG, * ZBEG,XEND,YEND,ZEND,TBEG,TEND,AMASS,CHARGE,WTTHIN ) C----------------------------------------------------------------------- C AUG(ER) C(H)ER(ENKOV RADIATION FROM ALL KINDS OF CHARGED PARTICLES) C C CREATION OF CHERENKOV PHOTONS ALONG THE TRACKS OF CHARGED PARTICLES C WHICH CROSS LAYER OF 1 G/CM^2 THICKNESS. C ALL PARAMETERS OF THE PARTICLE TRACK STEP ARE PASSED AS ARGUMENTS. C THIS SUBROUTINE IS CALLED FROM AUGCERTRACK. C ARGUMENTS (ALL DOUBLE PRECISION): C STEPCR = STEP LENGTH FOR THE PARTICLE [CM] C UMEAN = DIRECTION COSINE TO X AXIS (STEP AVERAGE) C VMEAN = DIRECTION COSINE TO Y AXIS (STEP AVERAGE) C WMEAN = DIRECTION COSINE TO -Z AXIS (STEP AVERAGE) C EBEG = ENERGY [GEV] AT BEGINNING OF STEP C EEND = ENERGY [GEV] AT END OF STEP C XBEG = X POSITION [CM] AT BEGINNING OF STEP C YBEG = Y POSITION [CM] AT BEGINNING OF STEP C ZBEG = Z POSITION [CM] AT BEGINNING OF STEP C XEND = X POSITION [CM] AT END OF STEP C YEND = Y POSITION [CM] AT END OF STEP C ZEND = Z POSITION [CM] AT END OF STEP C TBEG = TIME [NSEC] AT BEGIN OF STEP C TEND = TIME [NSEC] AT END OF STEP C AMASS = PARTICLE MASS [GEV/C**2] C CHARGE = CHARGE NUMBER (OR NEGATIVE - WE NEED ONLY THE SQUARE OF IT) C WTTHIN = PARTICLE WEIGHT FOR THINNING VERSION, ELSE 1. C C THIS IMPLEMENTATION IS ORIGINALLY DESIGNED BY C K. BERNLOEHR MPIK HEIDELBERG (1998) C C FUNCTIONS FOR TABULATED ATMOSPHERIC MODELS AND FUNCTIONS TO ACCOUNT C FOR THE ATMOSPHERIC REFRACTION ARE WRITTEN (IN C) BY C K. BERNLOEHR MPIK HEIDELBERG (1997) C AND AVAILABLE SEPARATELY. C----------------------------------------------------------------------- IMPLICIT NONE #define __CEREN1INC__ #define __CONSTAINC__ #define __EGSDEBINC__ #define __MAGANGINC__ #define __OBSPARINC__ #define __PARPARINC__ #define __RANDPAINC__ #define __RUNPARINC__ #if __ATMEXT__ #define __ATMOSXINC__ #endif #include "corsika.h" DOUBLE PRECISION PHICER,SINPSI,SINPS2,XEMIS,YEMIS,ZEMIS DOUBLE PRECISION STEPCR DOUBLE PRECISION UMEAN,VMEAN,WMEAN DOUBLE PRECISION EBEG,EEND DOUBLE PRECISION XBEG,YBEG,ZBEG,XEND,YEND,ZEND DOUBLE PRECISION TBEG,TEND,AMASS,CHARGE,WTTHIN DOUBLE PRECISION BETAE,BETAI,CTHETA,ETA1,ETA1I,ETA1E,STHETA DOUBLE PRECISION BETAM,ETA1M DOUBLE PRECISION TC11,TC21,TC12,TC22,TC32,TC13,TC23,TC33 DOUBLE PRECISION BETA,BETAN,BETANI,DBETAN,ENER DOUBLE PRECISION ETALI,ETALE,DETAL,CINTEN DOUBLE PRECISION PHOTCT,PSTEP,PATHL,XSTEP,YSTEP,ZSTEP,ZEM DOUBLE PRECISION DEDPL,STHET2,SINPHI,COSPHI DOUBLE PRECISION PHOTCM,UEMIS,VEMIS,WEMIS DOUBLE PRECISION BEMX,STCP,STSP,TEMIS,TSTEP DOUBLE PRECISION WTCER INTEGER MAXRDM PARAMETER ( MAXRDM = 100 ) DOUBLE PRECISION RDM(MAXRDM) INTEGER LOOPFL,IRDM,NRDM INTEGER ISTC,NSTEPC SAVE #if __ATMEXT__ DOUBLE PRECISION REFIDX EXTERNAL REFIDX #endif DOUBLE PRECISION RHOF,THICK EXTERNAL RHOF,THICK C----------------------------------------------------------------------- IF ( FEGSDB .OR. DEBUG ) WRITE(MDEBUG,*) 'AUGCER: EBEG=',EBEG, * ' AMASS=',AMASS IF ( STEPCR .LE. 0.D0 ) RETURN #if !__UPWARD__ C SKIP PARTICLES OUT OF ZENITH ANGULAR CUT (WITH WMEAN>0 DOWNWARDS). C NOTE: USUALLY C(29) IS 0, I.E. UPWARD GOING PARTICLES ARE REJECTED. IF ( WMEAN .LT. C(29) ) RETURN #endif C LOOK WHETHER CHERENKOV CONDITION IS FULFILLED FOR THIS STEP. BETAI = SQRT( 1.D0 - (AMASS/EBEG)**2 ) BETAE = SQRT( 1.D0 - (AMASS/EEND)**2 ) C REFRACTIVE INDEX PARAMETERISATION: N=1+ETA = ETA1 #if __ATMEXT__ IF ( IATMOX .GE. 1 ) THEN ETA1I = REFIDX(ZBEG) ETA1E = REFIDX(ZEND) ELSE ETA1I = 1.D0 + ETADSN * RHOF( ZBEG ) ETA1E = 1.D0 + ETADSN * RHOF( ZEND ) ENDIF #else ETA1I = 1.D0 + ETADSN * RHOF( ZBEG ) ETA1E = 1.D0 + ETADSN * RHOF( ZEND ) #endif IF ( BETAI*ETA1I.LT.1.D0 .AND. BETAE*ETA1E.LT.1.D0 ) RETURN BETAM = SQRT( 1.D0 - (AMASS*2.D0/(EBEG+EEND))**2 ) #if __ATMEXT__ IF ( IATMOX .GE. 1 ) THEN ETA1M = REFIDX(0.5D0 * (ZBEG+ZEND)) ELSE ETA1M = 1.D0 + ETADSN * RHOF( 0.5D0 * (ZBEG+ZEND) ) ENDIF #else ETA1M = 1.D0 + ETADSN * RHOF( 0.5D0 * (ZBEG+ZEND) ) #endif BEMX = MAX( BETAE*ETA1E, BETAI*ETA1I ) CINTEN = CYIELD * CHARGE**2 PHOTCT = CINTEN * STEPCR * (1.D0 - 1.D0/BEMX**2) NSTEPC = PHOTCT / CERSIZ + 1 IF ( NSTEPC .LT. 1 ) RETURN C NOW CHECK WHICH KIND OF CALCULATING (BETA*N) FOR EACH SUB-STEP C IS LIKELY TO BE THE MOST EFFICIENT. C CASE 0: ONLY ONE STEP - WE HAVE ALREADY THE NUMBERS AT MID-STEP. IF ( NSTEPC .EQ. 1 ) THEN LOOPFL = 0 C CASE 1: LINEAR INTERPOLATION OF (BETA*N) IF THE RELATIVE ERROR ON C THE LIGHT INTENSITY IN THE MIDDLE IS LESS THAN 1E-3 (THEN THE ERROR C ON THE IMPACT POINT FOR VERTICAL INCIDENCE IS LESS THAN ABOUT 5 CM). ELSEIF ( (BETAE*ETA1E) .GT. 1.D0 .AND. (BETAI*ETA1I) .GT. 1.D0 * .AND. (BETAM*ETA1M) .GT. 1.D0 .AND. * ABS((2.D0-1.D0/(BETAI*ETA1I)**2-1.D0/(BETAE*ETA1E)**2)/ * (1.D0-1.D0/(BETAM*ETA1M)**2)-2.D0) .LT. * 2.D-3*ABS(WMEAN) ) THEN LOOPFL = 1 DBETAN = (BETAE*ETA1E-BETAI*ETA1I) / STEPCR BETANI = BETAI * ETA1I DEDPL = (EEND-EBEG) / STEPCR C CASE 2: LOGARITHMIC INTERPOLATION OF (N-1) IS GOOD ENOUGH FOR C ERRORS ON THE IMPACT POINT BEING LESS THAN 10 CM. C BETA IS CALCULATED EXPLICITLY ASSUMING CONSTANT ENERGY LOSS. C NOTE THAT WE USE CONSTANT ENERGY LOSS PER CENTIMETER RATHER THAN C PER UNIT G/CM**2 FOR EFFICIENCY REASONS. THE POSSIBLE DIFFERENCE C OF ENERGY AT MIDDLE OF STEP SHOULD BE INSIGNIFICANT IN ALMOST C ANY CASE. ELSEIF ( ZBEG**2*ABS((ETA1I-1.D0)*(ETA1E-1.D0)/(ETA1M-1.D0)**2 * - 1.D0) .LT. (10.D0*ABS(WMEAN))**2 ) THEN LOOPFL = 2 ETALI = LOG( ETA1I - 1.D0 ) ETALE = LOG( ETA1E - 1.D0 ) DETAL = (ETALE-ETALI) / STEPCR DEDPL = (EEND-EBEG) / STEPCR ELSE C CASE 3: BOTH N AND BETA HAVE TO BE CALCULATED IN FULL DETAIL. LOOPFL = 3 DEDPL = (EEND-EBEG) / STEPCR ENDIF C VARIOUS START VALUES AND STEP LENGTHS FOR SUB-STEP LOOP PSTEP = STEPCR * (1.D0/DBLE(NSTEPC)) PATHL = (-0.5D0)*PSTEP XSTEP = (XEND-XBEG) * (1.D0/DBLE(NSTEPC)) YSTEP = (YEND-YBEG) * (1.D0/DBLE(NSTEPC)) TSTEP = (TEND-TBEG) * (1.D0/DBLE(NSTEPC)) XEMIS = XBEG - 0.5D0*XSTEP YEMIS = YBEG - 0.5D0*YSTEP TEMIS = TBEG - 0.5D0*TSTEP ZSTEP = (ZEND-ZBEG) * (1.D0/DBLE(NSTEPC)) ZEM = ZBEG - 0.5D0*ZSTEP C THE TC.. ELEMENTS ARE DESCRIBED FURTHER DOWN. SINPS2 = UMEAN**2 + VMEAN**2 #if __UPWARD__ IF ( SINPS2 .LT. 1.D-20 ) SINPS2 = 1.D-76 #else IF ( SINPS2 .LT. 1.D-20 ) SINPS2 = 1.D-20 #endif SINPSI = SQRT( SINPS2 ) TC11 = VMEAN*(1.D0/SINPSI) TC12 = UMEAN*WMEAN*(1.D0/SINPSI) TC13 = UMEAN TC21 = (-UMEAN)*(1.D0/SINPSI) TC22 = VMEAN*WMEAN*(1.D0/SINPSI) TC23 = VMEAN TC32 = -SINPSI TC33 = WMEAN C DON''T GET RANDOM NUMBERS ONE-BY-ONE BUT IN LARGER CHUNKS. NRDM = NSTEPC IRDM = 0 IF ( NRDM .GT. MAXRDM ) THEN CALL RMMARD( RDM,MAXRDM,3 ) ELSE CALL RMMARD( RDM,NRDM,3 ) ENDIF C LOOP OVER THE NUMBER OF SUB-STEPS WITH CONSTANT PARTICLE DIRECTION C BUT CONTINUOUS ENERGY LOSS AND REFRACTION INDEX CHANGE ACCOUNTED FOR. C SINCE ACTUAL VELOCITY CHANGES OF PARTICLES EMITTING CHERENKOV LIGHT C IN THE ATMOSPHERE ARE VERY SMALL, CONSTANT STEPS IN (X,Y,Z,T) ARE USED. DO 1000 ISTC = 1, NSTEPC PATHL = PATHL + PSTEP XEMIS = XEMIS + XSTEP YEMIS = YEMIS + YSTEP ZEM = ZEM + ZSTEP TEMIS = TEMIS + TSTEP C DEPENDING ON CONDITIONS USE THE FASTEST METHOD TO GET (BETA*N). IF ( LOOPFL .EQ. 1 ) THEN C THE MOST FREQUENT AND SIMPLEST CASE (WELL ABOVE THRESHOLD). BETAN = BETANI + DBETAN*PATHL ELSEIF ( NSTEPC .EQ. 1 ) THEN C THIS CASE IS USALLY ENCOUNTERED NEAR THRESHOLD. BETAN = BETAM*ETA1M ELSEIF ( LOOPFL .EQ. 2 ) THEN C THIS CASE IS ALSO USALLY ENCOUNTERED NEAR THRESHOLD. ETA1 = 1.D0 + EXP( ETALI + DETAL*PATHL ) ENER = EBEG + DEDPL*PATHL BETA = SQRT( 1.D0 - (AMASS/ENER)**2 ) BETAN = BETA*ETA1 ELSE C THIS MOST GENERAL CASE IS RARELY ENCOUNTERED. #if __ATMEXT__ IF ( IATMOX .GE. 1 ) THEN ETA1 = REFIDX(ZEM) ELSE ETA1 = 1.D0 + ETADSN * RHOF( ZEM ) ENDIF #else ETA1 = 1.D0 + ETADSN * RHOF( ZEM ) #endif ENER = EBEG + DEDPL*PATHL BETA = SQRT( 1.D0 - (AMASS/ENER)**2 ) BETAN = BETA*ETA1 ENDIF IF ( FEGSDB .OR. DEBUG ) WRITE(MDEBUG,*) * 'AUGCER: LOOPFL=',LOOPFL,' BETAN=',BETAN CTHETA = 1.D0 / BETAN STHET2 = ( 1.D0 - CTHETA ) * ( 1.D0 + CTHETA ) C PARTICLE IS BELOW ENERGY THRESHOLD IF THE EMISSION ANGLE IS <=0 IF ( CTHETA .GT. 1.D0 .OR. STHET2 .LE. 0.D0 ) THEN NRDM = NRDM - 1 GOTO 1000 ENDIF C NUMBER OF EMITTED PHOTONS IN THIS SUB-STEP PHOTCM = (CINTEN*PSTEP) * STHET2 STHETA = SQRT( STHET2 ) C ASSUME EMISSION POINT OF ALL PHOTONS IN THE MIDDLE OF THE STEP ZEMIS = ZEM C CALCULATE PHOTON DIRECTION IN THE CORSIKA COORDINATE FRAME C C NOTE: TO DERIVE THESE EQUATIONS YOU SHOULD FIRST DERIVE A MATRIX (T) C WHICH ROTATES THE PARTICLE DIRECTION (U, V, W) TO (0, 0, 1): C C ( V/SQRT(U**2+V**2) -U/SQRT(U**2+V**2) 0 ) C (T) = ( UW/SQRT(U**2+V**2) VW/SQRT(U**2+V**2) -SQRT(U**2+V**2) ) C ( U V W ) C C CHERENKOV EMISSION IN THIS ROTATED COORDINATE SYSTEM IS DESCRIBED BY C A MATRIX (C): C C ( COS(PHI) -SIN(PHI) 0 ) ( COS(THETA) 0 SIN(THETA) ) C (C) = ( SIN(PHI) COS(PHI) 0 ) ( 0 1 0 ) C ( 0 0 1 ) ( -SIN(THETA) 0 COS(THETA) ) C C WHERE THETA IS THE CHERENKOV OPENING ANGLE AND PHI IS RANDOM. C THE RESULT IS (T_T)**-1 (C) (0,0,1): C C (0) C (T_T)**-1 (C) (0) = C (1) C C ( V/S*SIN(T)*COS(PHI)+U*W/S*SIN(T)*SIN(PHI)+U*COS(T) ) C = (-U/S*SIN(T)*COS(PHI)+V*W/S*SIN(T)*SIN(PHI)+V*COS(T) ) C ( -S*SIN(T)*SIN(PHI)+W*COS(T) ) C C WITH S = SQRT(U**2+V**2) AND T=THETA. THE CONSTANT PARTS ARE CALCULATED C AS TC11 ... TC33 BEFORE THE '1000' LOOP. C DON''T GET RANDOM NUMBERS ONE-BY-ONE BUT IN LARGER CHUNKS FROM SEQ. 3 IRDM = IRDM + 1 IF ( IRDM .GT. MAXRDM ) THEN IF ( NRDM .GT. MAXRDM ) THEN CALL RMMARD( RDM,MAXRDM,3 ) NRDM = NRDM - MAXRDM ELSE CALL RMMARD( RDM,NRDM,3 ) NRDM = 0 ENDIF IRDM = 1 ENDIF PHICER = RDM(IRDM) * PI2 SINPHI = SIN( PHICER ) COSPHI = COS( PHICER ) #if __UPWARD__ IF ( SINPS2 .LE. 1.D-12 ) THEN #else IF ( SINPS2 .LE. 1.D-76 ) THEN #endif UEMIS = STHETA * COSPHI VEMIS = STHETA * SINPHI WEMIS = CTHETA IF ( WMEAN .LT. 0.D0 ) WEMIS = -CTHETA ELSE STCP = STHETA * COSPHI STSP = STHETA * SINPHI UEMIS = TC11*STCP + TC12*STSP + TC13*CTHETA VEMIS = TC21*STCP + TC22*STSP + TC23*CTHETA WEMIS = TC32*STSP + TC33*CTHETA ENDIF IF ( FEGSDB .OR. DEBUG ) WRITE(MDEBUG,*) * 'AUGCER: UEMIS,VEMIS,WEMIS=',UEMIS,VEMIS,WEMIS #if __UPWARD__ WEMIS = MAX( -1.D0, WEMIS ) #else C EMISSION ANGLE WITHIN ZENITH ANGULAR CUT? IF ( WEMIS .LT. C(29) ) GOTO 1000 #endif WEMIS = MIN( 1.D0, WEMIS ) WTCER = WTTHIN C THE ROTATION RELATIVE TO MAGNETIC NORTH IS ALRREADY TAKEN INTO C ACCOUNT IN SUBR. AUGCERTRACK C THE SHIFT OF COORDINATE ORIGIN IS ALREADY DONE IN OUTPT1 IF ( FEGSDB .OR. DEBUG ) WRITE(MDEBUG,*) * 'AUGCER: UEMIS,VEMIS,PHOTCM=', * SNGL(UEMIS),SNGL(VEMIS),SNGL(PHOTCM) C NOW ALL PARAMETERS OF THE CHERENKOV PHOTONS ARE KOWN. C TEMIS TIME OF EMISSION SINCE FIRST INTERACTION C UEMIS,VEMIS,WEMIS EMISSION DIRECTION COSINES IN X, Y, Z DIRECTION C XEMIS,YEMIS,ZEMIS POSITIONS OF CHERENKOV EMISSION C PHOTCM NUMBER OF PHOTONS WITHIN BUNCH C WTCER WEIGHT OF PHOTON BUNCH C THE COORDINATES OF THE EMITTING PARTICLE ARE AVAILABLE IN __OBSPARINC__ CALL AUGCERFIL( TEMIS,UEMIS,VEMIS,WEMIS,XEMIS,YEMIS,ZEMIS, * PHOTCM,WTCER ) 1000 CONTINUE RETURN END #endif #if __AUGERHIST__ *-- Author : M. RISSE IK FZK KARLSRUHE 27/09/2001 C======================================================================= SUBROUTINE AUGCERFIL( TEMIS,UEMIS,VEMIS,WEMIS,XEMIS,YEMIS,ZEMIS, * PHOTCM,WTCER ) C----------------------------------------------------------------------- C AUG(ER) CER(ENKOV) FIL(LING OF HISTOGRAMS) C C FILLS THE CERENKOV PARAMETERS INTO HISTOGRAMS. C THE COORDINATES OF THE EMITTING PARTICLE ARE AVAILABLE IN OUTPAR. C THIS SUBROUTINE IS CALLED FROM AUGCER. C ARGUMENTS: C TEMIS = TIME OF EMISSION SINCE FIRST INTERACTION (NSEC) C UEMIS,VEMIS,WEMIS = EMISSION DIRECTION COSINES IN X, Y, Z DIRECTION C XEMIS,YEMIS,ZEMIS = POSITIONS OF CHERENKOV EMISSION (CM) C PHOTCM = NUMBER OF PHOTONS WITHIN BUNCH C WTCER = WEIGHT OF PHOTON BUNCH C----------------------------------------------------------------------- IMPLICIT NONE #define __CONSTAINC__ #define __OBSPARINC__ #define __PAMINC__ #define __PARPARINC__ #define __RUNPARINC__ #include "corsika.h" DOUBLE PRECISION TEMIS,UEMIS,VEMIS,WEMIS,PHOTCM,WTCER DOUBLE PRECISION XEMIS,YEMIS,ZEMIS DOUBLE PRECISION SINTEC,SINTES,THEE,DIFFCS * DOUBLE PRECISION DIFFCE REAL THCOS,THDEG * REAL DISTANCE,EDEPHI,LGEDEP,EKINPA,LGEKINPA,X_M,Y_M REAL CHTHDEG,CHWEIGHT INTEGER IDHIST,ITYPO SAVE #if __GFORTRAN__ CTP060202 TO AVOID WARNINGS WITH GFORTRAN COMPILATION LOGICAL CTP060202 CTP060202 = .FALSE. IF ( CTP060202 ) WRITE(*,*) TEMIS,YEMIS,XEMIS,ZEMIS CTP060202 END WARNING #endif C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'AUGCERFIL: LEVL=',LEVL C EXTRACT PARTICLE CHARACTERISTICS. CHANGE DISTANCES TO [M] ITYPO = NINT( OUTPAR(0) ) * DISTANCE = 0.01 * SQRT( OUTPAR(7)**2 + OUTPAR(8)**2 ) C CONVERT CM TO METER * X_M = 0.01 * OUTPAR(7) * Y_M = 0.01 * OUTPAR(8) THCOS = OUTPAR(2) THDEG = 180./PI * ACOS( OUTPAR(2) ) C CALCULATE ANGULAR DIFFERENCE OF CHERENKOV ("C") BUNCH TO: C (II) EMITTING PARTICLE ("E") SINTEC = SQRT( (1.D0-WEMIS)*(1.D0+WEMIS) ) SINTES = SQRT( (1.D0-PRMPAR(2))*(1.D0+PRMPAR(2)) ) THEE = ACOS( OUTPAR(2) ) DIFFCS = UEMIS*PRMPAR(3) + VEMIS*PRMPAR(4) + WEMIS*PRMPAR(2) * DIFFCE = UEMIS*OUTPAR(3) + VEMIS*OUTPAR(4) + WEMIS*OUTPAR(2) C DETERMINE CHERENKOV ANGLE AND FILLING WEIGHT FOR HISTO C CHERENKOV HISTO ENDING IS 10 (COMPARE AUGERHISTINI) * CHTHDEG = 180./PI * ACOS( WEMIS ) ! ONLY FOR VERTICAL SHOWERS C ANGLE TO AXIS CHTHDEG = 180./PI * ACOS( DIFFCS ) CHWEIGHT = PHOTCM * WTCER / SAMPTH C FILL HISTOS C ANGLE TO AXIS IDHIST = 200000 + LEVL*100 + 10 CALL HFILL( IDHIST,CHTHDEG,0.,CHWEIGHT ) RETURN END #endif #if __AUGERHIST__ *-- Author : D. HECK IK FZK KARLSRUHE 25/09/2001 C======================================================================= SUBROUTINE AUGCERTRACK C----------------------------------------------------------------------- C AUG(ER) CER(ENKOV) TRACK(ING) C C TRACKS CHARGED PARTICLES TO LET THEM RADIATE CHERENKOV PHOTONS. C PARTICLE COORDINATES ARE AVAILABLE IN OUTPAR. C DEFINITION OF LOCAL VARIABLES SEE SUBR. AUGCER C THIS SUBROUTINE IS CALLED FROM OUTPT1. C----------------------------------------------------------------------- IMPLICIT NONE #define __MAGANGINC__ #define __OBSPARINC__ #define __PAMINC__ #define __PARPARINC__ #define __RUNPARINC__ #include "corsika.h" DOUBLE PRECISION AMASS,BET1CI,BET2CI,CHARGE,EBEG,EEND,GAM1CR, * GAM2CR,PHIPAR,STEPCR,STT,TBEG,TEND, * UMEAN,VMEAN,WMEAN, * XBEG,XEND,YBEG,YEND,ZBEG,ZDIF,ZEND DOUBLE PRECISION AUGEDP,HEIGH,RHOF DOUBLE PRECISION WTTHIN INTEGER I,ITYPC SAVE EXTERNAL AUGEDP,HEIGH,RHOF C----------------------------------------------------------------------- IF (DEBUG) WRITE(MDEBUG,1) (OUTPAR(I),I=0,9),OUTPAR(13),LEVL 1 FORMAT(' AUGCERTRACK: ',1P,9E11.3,0P,F10.0,1P,E10.3,I5) C PARTICLE TYPE, MASS, CHARGE, AND WEIGHT ITYPC = NINT( OUTPAR(0) ) AMASS = PAMA(ITYPC) CHARGE = SIGNUM(ITYPC) WTTHIN = OUTPAR(13) C PARTICLE ANGLES WMEAN = OUTPAR(2) STT = SQRT( (1.D0 - OUTPAR(2)) * (1.D0 + OUTPAR(2)) ) IF ( OUTPAR(3) .NE. 0.D0 .OR. OUTPAR(4) .NE. 0.D0 ) THEN PHIPAR = ATAN2( OUTPAR(4), OUTPAR(3) ) ELSE PHIPAR = 0.D0 ENDIF UMEAN = STT * COS( PHIPAR - ARRANR ) VMEAN = STT * SIN( PHIPAR - ARRANR ) C PARTICLE ENERGIES, GAMMA FACTORS AND INVERSE OF VELOCITY BETA IF ( ITYPC .LE. 3 ) THEN C ELECTROMAGNETIC PARTICLES EBEG = OUTPAR(1) GAM1CR = EBEG / AMASS BET1CI = GAM1CR / SQRT( (GAM1CR - 1.D0) * (GAM1CR + 1.D0) ) EEND = EBEG - AUGEDP()/OUTPAR(13) IF ( EEND .LE. AMASS ) THEN C WE DEAL WITH LOW ENERGY PARTICLES WHICH COME AT REST AND C ANYWAY MAKE NO CHERENKOV RADIATION RETURN ENDIF GAM2CR = EEND / AMASS BET2CI = GAM2CR / SQRT( (GAM2CR - 1.D0) * (GAM2CR + 1.D0) ) ELSE C MUONIC OR HADRONIC PARTICLES EBEG = OUTPAR(1) * AMASS EEND = EBEG - AUGEDP()/OUTPAR(13) IF ( EEND .LE. AMASS ) THEN C WE DEAL WITH LOW ENERGY PARTICLES WHICH COME AT REST AND C ANYWAY MAKE NO CHERENKOV RADIATION RETURN ENDIF GAM2CR = EEND / AMASS BET2CI = GAM2CR / SQRT( (GAM2CR - 1.D0)*(GAM2CR + 1.D0) ) BET1CI = OUTPAR(1)/SQRT( (OUTPAR(1)-1.D0)*(OUTPAR(1)+1.D0) ) ENDIF C PARTICLE POSITIONS AT BEGIN AND END OF STEP AND STEP LENGTH ZBEG = OBSLEV(LEVL) IF ( WMEAN .GT. 0.D0 ) THEN C PARTICLE MOVES DOWNWARD, LAYER IS BELOW OBSERVATION LEVEL ZEND = HEIGH( THCKOB(LEVL) + SAMPTH ) ZDIF = ZBEG - ZEND STEPCR = ZDIF/WMEAN #if __UPWARD__ ELSEIF ( WMEAN .LT. 0.D0 ) THEN C PARTICLE MOVES UPWARD, LAYER IS ABOVE OBSERVATON LEVEL ZEND = HEIGH( THCKOB(LEVL) - SAMPTH ) ZDIF = ZBEG - ZEND STEPCR = ZDIF/WMEAN ELSE C PARTICLE MOVES HORIZONTALLY, STEP EXTENDS UNTIL ENERGY C IS DISSIPATED INTO IONIZATION ZEND = OBSLEV(LEVL) STEPCR = (EEND - EBEG) / ( RHOF( OBSLEV(LEVL) ) * C(24) ) #else ELSE C UPWARD MOVING PARTICLES ARE DISREGARDED RETURN #endif ENDIF XBEG = OUTPAR(7) * COSANG + OUTPAR(8) * SINANG YBEG = OUTPAR(8) * COSANG - OUTPAR(7) * SINANG XEND = XBEG + STEPCR * UMEAN YEND = YBEG + STEPCR * VMEAN C PARTICLE TIMES AT BEGIN AND END OF STEP TBEG = OUTPAR(6) TEND = TBEG + 0.5D0 * STEPCR * ( BET1CI + BET2CI ) / C(25) C NOW ALL VARIABLES ARE SET TO CALCULATE THE CHERENKOV RADIATION C WITHIN THE LAYER OF 1 G/CM^2 VERTICAL THICKNESS CALL AUGCER( STEPCR,UMEAN,VMEAN,WMEAN,EBEG,EEND,XBEG,YBEG, * ZBEG,XEND,YEND,ZEND,TBEG,TEND,AMASS,CHARGE,WTTHIN ) RETURN END #endif #if __AUGERHIST__ *-- Author : D. HECK IK FZK KARLSRUHE 20/06/2001 C======================================================================= SUBROUTINE AUGCUT( LL ) C----------------------------------------------------------------------- C AUG(ER) CUT(TED ENERGY PARTICLES AT OBSERVATION LEVEL SLICE) C C TRACES HADRONS AND MUONS TO CUTTING POINT AND STORES THEIR C COORDINATES IN OUTPAR. C THIS SUBROUTINE IS CALLED FROM AAMAIN, BOX3, MUTRAC, AND UPDATE. C ARGUMENT: C LL = NUMBER OF OBSERVATION LEVEL C----------------------------------------------------------------------- IMPLICIT NONE #define __ATMOS2INC__ #define __GENERINC__ #define __MAGNETINC__ #define __MUMULTINC__ #define __OBSPARINC__ #define __PAMINC__ #define __PARPARINC__ #define __PARPAEINC__ #define __RUNPARINC__ #include "corsika.h" DOUBLE PRECISION ALPHA1,ALPHA2,AUX2,BETAN,DH,DTHICK,ELOSS, * FNORM1,FNORM2,F1COS1,F1COS2,F1SIN1,F1SIN2, * GAMMAN,GAMSQ,GMSQM1,HMIDDL,RADINV, * SINTH1,SN,SN1,SN2,SN3,SN4, * SNMIDDL1,SNMIDDL2, * THICKMDL,USW,U10,U12,U20,U22,V,VVV, * V10,V12,V20,V22,W10,W12,W20,W22 DOUBLE PRECISION EDEP,GAM0,TH0 DOUBLE PRECISION ARGLOG,CDNS,CDNS1,HFDNS DOUBLE PRECISION CDEDXM,HEIGH,RHOF,THICK INTEGER I,ICUT,IL,ILAY,LL LOGICAL MUS SAVE EXTERNAL CDEDXM,HEIGH,RHOF,THICK C CONSTANT IN DENSITY EFFECT FOR IONIZATION LOSS IN AIR DATA CDNS1 / 0.020762D0 / C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'AUGCUT: LL=',LL IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=0,9),CURPAR(13),LL 444 FORMAT(1H ,'AUGCUT: CURPAR=',1P,9E11.3,0P,F10.0,1P,E10.3,I5) ICUT = 0 C TOTAL HEIGHT DIFFERENCE DH = MAX( H - OBSLEV(LL), 1.D-10 ) C ATMOSPHERE THICKNESS TRAVERSED DTHICK = MAX( 0.D0, (THCKOB(LL) - THICKH) / COSTHE ) C TOTAL PATH FOR UNDEFLECTED PARTICLE SN = DH / COSTHE C GEOMETRICAL MIDDLE CDH HMIDDL = H - 0.5D0*DH C MIDDLE OF THICKNESS THICKMDL = THICKH + 0.5D0*DTHICK*COSTHE HMIDDL = HEIGH( THICKMDL ) SNMIDDL1 = ((H-HMIDDL))/COSTHE SNMIDDL2 = SN - SNMIDDL1 SN1 = 0.5D0 * SNMIDDL1 C CALCULATE KINETIC ENERGY CUT IF ( ITYPE .EQ. 5 .OR. ITYPE .EQ. 6 .OR. * ITYPE .EQ. 131 .OR. ITYPE .EQ. 132 ) THEN MUS = .TRUE. ELSE MUS = .FALSE. ENDIF C CALCULATE THE ENERGY LOSS FOR CHARGED PARTICLES IF ( SIGNUM(ITYPE) .NE. 0.D0 ) THEN C LOOK WITHIN WHICH LAYER THE PARTICLE STARTS IF ( H .LE. HLAY(2) ) THEN ILAY = 1 TH0 = THICKH ELSEIF ( H .LE. HLAY(3) ) THEN ILAY = 2 TH0 = THICKH ELSEIF ( H .LE. HLAY(4) ) THEN ILAY = 3 TH0 = THICKH ELSE ILAY = 4 TH0 = MAX( THICKH, THICKL(5) ) ENDIF C SET START VALUES FOR ITERATION GAM0 = GAMMA HFDNS = H IL = ILAY 1 CONTINUE GAM0 = MAX( GAM0, 1.0001D0 ) GAMSQ = GAM0**2 GMSQM1 = GAMSQ - 1.D0 C ENERGY LOSS BY IONIZATION IF ( ITYPE .EQ. 5 .OR. ITYPE .EQ. 6 ) THEN C DENSITY EFFECT PARAMETERIZATION (R.P. KOKOULIN, 2006) CDNS = CDNS1 * RHOF(HFDNS) ARGLOG = GMSQM1**2/( (GAM0*C(16)+1.D0)*(1.D0+GMSQM1*CDNS) ) ELOSS = C(22) * ( GAMSQ * (0.5D0 * LOG( ARGLOG ) + C(23)) * / GMSQM1 - 1.D0 ) C ADD ENERGY LOSS OF SUBTHRESHOLD BEMSSTRAHLUNG AND PAIRPRODUCTION AUX2 = CDEDXM( PAMA(5)*GAM0 ) IF ( DEBUG ) WRITE(MDEBUG,*) * 'AUGCUT: ELOSS,DEDXM=',ELOSS,AUX2 ELOSS = ELOSS + AUX2 #if __CHARM__ || __TAULEP__ ELSEIF ( ITYPE .EQ. 131 .OR. ITYPE .EQ. 132 ) THEN C TAU LEPTON C DENSITY EFFECT PARAMETERIZATION (R.P. KOKOULIN, 2006) CDNS = CDNS1 * RHOF(HFDNS) ARGLOG = GMSQM1**2/( (GAM0*C(18)+1.D0)*(1.D0+GMSQM1*CDNS) ) ELOSS = C(22) * ( GAMSQ * (0.5D0 * LOG( ARGLOG ) + C(23)) * / GMSQM1 - 1.D0 ) C ADD ENERGY LOSS OF SUBTHRESHOLD BEMSSTRAHLUNG AND PAIRPRODUCTION AUX2 = CDEDXM( PAMA(131)*GAM0 ) IF ( DEBUG ) WRITE(MDEBUG,*) * 'AUGCUT: ELOSS,DEDXM=',ELOSS,AUX2 ELOSS = ELOSS + AUX2 #endif ELSE ELOSS = SIGNUM(ITYPE)**2 * C(22) * ( GAMSQ * (LOG( GMSQM1 ) * - 0.5D0 * LOG( GAM0 * 2.D0 * PAMA(2)/PAMA(ITYPE) * + 1.D0 + (PAMA(2)/PAMA(ITYPE))**2 ) * + C(23)) / GMSQM1 - 1.D0 ) IF ( DEBUG ) WRITE(MDEBUG,*) 'AUGCUT: ELOSS=',ELOSS ENDIF C LOOK WHETHER PARTICLE PENETRATES LAYER BOUNDARY IF ( THICKL(IL) .LT. THCKOB(LL) .AND. IL .GT. 1 ) THEN C CALCULATE NEW START VALUES AT LAYER BOUNDARY GAM0 = GAM0 - ELOSS * (THICKL(IL) - TH0) / COSTHE IF ( GAM0 .LE. 1.D0 ) THEN GAMMAN = 1.0001D0 GOTO 3 ENDIF TH0 = THICKL(IL) HFDNS = HLAY(IL) IL = IL - 1 GOTO 1 ENDIF C GAMMA VALUE FOR CHARGED PARTICLES AT END OF STEP GAMMAN = GAM0 - ELOSS * (THCKOB(LL)-TH0) / COSTHE GAMMAN = MAX( GAMMAN, 1.0001D0 ) 3 CONTINUE ELSE C NO LOSS FOR NEUTRAL PARTICLES GAMMAN = GAMMA ENDIF IF ( MUS ) THEN C COULOMB SCATTERING ANGLE (FOR MUONS ONLY) V = VSCAT * SQRT( DTHICK / CHI ) ENDIF C----------------------------------------------------------------------- C TRANSPORT CHARGED PARTICLES THE FIRST PORTION OF STEP IF ( SIGNUM(ITYPE) .NE. 0.D0 ) THEN C CHARGED PARTICLES SUFFER IONIZATION LOSS, DEFLECTION IN MAGNETIC C FIELD AND MUONS IN ADDITION DO MULTIPLE COULOMB SCATTERING. C DEFLECTION IN EARTH MAGNETIC FIELD ON FIRST HALF OF STEP ALPHA1 = SIGNUM(ITYPE) * * MIN( 1.D0, 2.D0*SN1*BNORMC /(PAMA(ITYPE)*BETA*GAMMA) ) SINTH1 = SQRT( 1.D0 - COSTHE**2 ) U10 = PHIX V10 = -PHIY W10 = COSTHE FNORM1 = 1.D0 - 0.5D0*ALPHA1**2 * (1.D0 - 0.75D0*ALPHA1**2) F1COS1 = ( 1.D0 - FNORM1 ) * COSB F1SIN1 = ( 1.D0 - FNORM1 ) * SINB VVV = V10 * ALPHA1 * FNORM1 USW = U10 * SINB - W10 * COSB U12 = U10 - F1SIN1 * USW + VVV * SINB V12 = FNORM1 * ( V10 - ALPHA1 * USW ) W12 = W10 + F1COS1 * USW - VVV * COSB RADINV = 1.5D0 - 0.5D0 * ( U12**2 + V12**2 + W12**2 ) W12 = MIN( 1.D0, RADINV * W12 ) IF ( W12 .LE. C(29) ) THEN IF ( DEBUG ) WRITE(MDEBUG,*) * 'AUGCUT: PARTICLE ',ITYPE,' BELOW ANGLE CUT 1' ICUT = 1 RETURN ENDIF SN2 = SN1 * COSTHE / W12 U12 = RADINV * U12 V12 = RADINV * V12 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C CHANGE DIRECTION BY COULOMB SCATTERING (FOR MUONS ONLY) IF ( MUS ) THEN C BEFORE SCATTERING : DIRECTION COSINES ARE U12,V12,W12 CALL ADDANG3( W12,U12,V12, COS( V ),-PHISCT, W20,U20,V20 ) IF ( W20 .LE. C(29) ) THEN IF ( DEBUG ) WRITE(MDEBUG,*) 'AUGCUT: MUON BELOW ANGLE CUT' ICUT = 1 RETURN ENDIF C AFTER SCATTERING : DIRECTION COSINES ARE U20,V20,W20 ELSE U20 = U12 V20 = V12 W20 = W12 ENDIF SN3 = 0.5D0 * SNMIDDL2 * COSTHE / W20 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C TRANSPORT CHARGED PARTICLES THE SECOND PORTION OF STEP C NEW PATH LENGTH, NEW BETA VALUE BECAUSE OF IONIZATION ENERGY LOSS BETAN = SQRT( GAMMAN**2 - 1.D0 ) / GAMMAN C DEFLECTION IN EARTH MAGNETIC FIELD ON SECOND HALF OF STEP ALPHA2 = SIGNUM(ITYPE) * * MIN(1.D0,2.D0*SN3*BNORMC / (PAMA(ITYPE)*BETAN*GAMMAN)) FNORM2 = 1.D0 - 0.5D0*ALPHA2**2 * (1.D0 - 0.75D0*ALPHA2**2) F1SIN2 = ( 1.D0 - FNORM2 ) * SINB F1COS2 = ( 1.D0 - FNORM2 ) * COSB VVV = V20 * ALPHA2 * FNORM2 USW = U20 * SINB - W20 * COSB U22 = U20 - F1SIN2 * USW + VVV * SINB V22 = FNORM2 * ( V20 - ALPHA2 * USW ) W22 = W20 + F1COS2 * USW - VVV * COSB RADINV = 1.5D0 - 0.5D0 * ( U22**2 + V22**2 + W22**2 ) W22 = MIN( 1.D0, RADINV * W22 ) IF ( W22 .LE. C(29) ) THEN IF ( DEBUG ) WRITE(MDEBUG,*) * 'AUGCUT: PARTICLE ',ITYPE,' BELOW ANGLE CUT 2' ICUT = 1 RETURN ENDIF SN4 = SN3 * W20 / W22 U22 = RADINV * U22 V22 = RADINV * V22 OUTPAR(2) = W22 OUTPAR(3) = U22 OUTPAR(4) = -V22 C UPDATE COORDINATES AND TIME TO THE END OF DISTANCE OUTPAR(6) = T + (SN1 + SN2)/(BETA *C(25)) + * (SN3 + SN4)/(BETAN*C(25)) OUTPAR(7) = X + SN1*U10 + SN2*U12 + SN3*U20 + SN4*U22 OUTPAR(8) = Y - SN1*V10 - SN2*V12 - SN3*V20 - SN4*V22 C----------------------------------------------------------------------- ELSE C NEUTRAL PARTICLES C NO COULOMB SCATTERING, NO DEFLECTION IN MAGNETIC FIELD C UPDATE COORDINATES AND TIME OUTPAR(2) = COSTHE OUTPAR(3) = PHIX OUTPAR(4) = PHIY OUTPAR(6) = T + SN / ( C(25) * BETA ) C HORIZONTAL PATH LENGTH OUTPAR(7) = X + SN * PHIX OUTPAR(8) = Y + SN * PHIY ENDIF C----------------------------------------------------------------------- OUTPAR( 0) = CURPAR(0) OUTPAR( 1) = GAMMAN OUTPAR( 5) = OBSLEV(LL) OUTPAR( 9) = GEN OUTPAR(10) = ALEVEL OUTPAR(13) = WEIGHT IF (DEBUG) WRITE(MDEBUG,458) (OUTPAR(I),I=0,9),OUTPAR(13) 458 FORMAT(' AUGCUT: OUTPAR=',1P,9E11.3,0P,F10.0,1P,E10.3) C CALCULATE THE ENERGY DEPOSIT IF ( OUTPAR(0) .EQ. 5.D0 .OR. OUTPAR(0) .EQ. 6.D0 ) THEN EDEP = OUTPAR(1) * PAMA(NINT( OUTPAR(0) )) C CONSIDER RELEASABLE ENERGY IN CASE OF (ANTI)NUCLEONS ELSE EDEP = OUTPAR(1) * PAMA(NINT( OUTPAR(0) )) * - RESTMS(NINT( OUTPAR(0) )) ENDIF EDEP = EDEP * WEIGHT C NOW FILL IN THE ENERGY DEPOSIT INTO THE HISTOS CALL AUGERDEPFIL( EDEP,LL,ICUT ) RETURN END #endif #if __AUGERHIST__ *-- Author : D. HECK IK FZK KARLSRUHE 21/06/2001 C======================================================================= SUBROUTINE AUGECT( EDEP,LL,VONWO ) C----------------------------------------------------------------------- C AUG(ER) E(GS) C(U)T(TED ENERGY PARTICLES AT OBSERVATION LEVEL SLICE?) C C THE PARTICLE COORDINATES ARE MOVED FROM STACKE (EGS-STACK) TO C OUTPAR (OUTPUT STACK). C THIS SUBROUTINE IS CALLED FROM ELECTR, MUPROP, PHOTO, PHOTON, C PIGEN1, PIGEN2, AND RHOGEN. C ARGUMENTS: C EDEP = DEPOSITED ENERGY (IN MEV!!!) (WITHOUT WEIGHTING) C LL = NUMBER OF OBSERVATION LEVEL C VONWO = CHARACTER*10 GIVING CALLING ROUTINE C----------------------------------------------------------------------- IMPLICIT NONE #define __GENERINC__ #define __PARPARINC__ #define __RUNPARINC__ #define __STACKEINC__ #include "corsika.h" DOUBLE PRECISION EDEP,EDEP2 INTEGER II,LL CHARACTER*10 VONWO SAVE C----------------------------------------------------------------------- IF (DEBUG) WRITE(MDEBUG,*) * 'AUGECT: EDEP=',EDEP*0.001D0,' LL=',LL,' CALLED FROM ',VONWO C PARTICLE IS WRITTEN IN OUTPUT BUFFER ARRAY OUTPAR(0) = IQ(NP) IF ( IQ(NP) .LE. 3 ) THEN C E(NP) CONTAINS ENERGY IN MEV OUTPAR(1) = E(NP)*0.001D0 ELSE C E(NP) CONTAINS THE GAMMA FACTOR OUTPAR(1) = E(NP) ENDIF OUTPAR(2) = MIN( 1.D0, W(NP) ) OUTPAR(3) = U(NP) OUTPAR(4) = V(NP) OUTPAR(5) =-Z(NP) OUTPAR(6) = TIM(NP) OUTPAR(7) = X(NP) OUTPAR(8) =-Y(NP) OUTPAR(9) = IGEN(NP) OUTPAR(10) = ALEVEL OUTPAR(13) = WT(NP) IF ( DEBUG ) WRITE(MDEBUG,444) (OUTPAR(II),II=0,9), WT(NP) 444 FORMAT(' AUGECT: EGSPAR=',1P,9E11.3,0P,F10.0,1P,E10.3) C CONVERT DEPOSIT FROM MEV TO GEV EDEP2 = EDEP * 0.001D0 * WT(NP) C NOW FILL IN THE ENERGY DEPOSIT INTO THE HISTOS CALL AUGERDEPFIL( EDEP2,LL,0 ) RETURN END #endif #if __AUGERHIST__ *-- Author : D. HECK IK FZK KARLSRUHE 11/05/2001 C======================================================================= DOUBLE PRECISION FUNCTION AUGEDP() C----------------------------------------------------------------------- C AUG(ER) E(NERGY) D(E)P(OSIT BY IONIZATION) C C CALCULATES THE ENERGY DEPOSIT (IN GEV) BY IONIZATION FOR THE C NEXT 1 G/CM**2 VERTICAL DEPTH FOR THE PARTICLE IN THE ARRAY OUTPAR. C TAKES THE INFORMATION ON THE PARTICLE UNDER CONSIDERATION FROM OUTPAR C THIS FUNCTION IS CALLED FROM AUGCERTRACK AND AUGERHISTFIL. C----------------------------------------------------------------------- IMPLICIT NONE #define __ELABCTINC__ #define __ELECININC__ #define __MEDIAINC__ #define __OBSPARINC__ #define __PAMINC__ #define __PARPARINC__ #define __RUNPARINC__ #include "corsika.h" DOUBLE PRECISION DEDX,DEDX0,EKE,ELKE,GAM0,GAMSQ,GMSQM1,X0 INTEGER ITYPO,LELKE SAVE DOUBLE PRECISION CDEDXM EXTERNAL CDEDXM C RADIATION LENGTH OF AIR AS USED IN EGS4 (G/CM**2) DATA X0 / 36.62D0 / C----------------------------------------------------------------------- * IF ( DEBUG ) WRITE(MDEBUG,444) (OUTPAR(I),I=0,9),OUTPAR(13),LEVL * 444 FORMAT(' AUGEDP: OUTPAR=',1P,9E11.3,0P,F10.0,1P,E10.3,I5) ITYPO = NINT( OUTPAR(0) ) IF ( ITYPO .LE. 3 ) THEN C WE HAVE AN EM PARTICLE IF (ITYPO .EQ. 1 ) THEN C NO ENERGY DEPOSIT FOR GAMMAS AUGEDP = 0.D0 ELSE C ENERGY DEPOSIT FOR ELELCTON OR POSITRON C NOTE: FOR EM-PARTICLES IS OUTPAR(1) THE TOTAL ENERGY IN GEV C CONVERT TOTAL ENERGY (GEV) TO KINETIC ENERGY (MEV) EKE = (OUTPAR(1) - PAMA(2)) * 1.D3 ELKE = LOG( EKE ) LELKE = EKE1*ELKE+EKE0 IF ( ITYPO .EQ. 3 ) THEN C ELECTRON DEDX0 = EDEDX1(LELKE)*ELKE+EDEDX0(LELKE) ELSE C POSITRON DEDX0 = PDEDX1(LELKE)*ELKE+PDEDX0(LELKE) ENDIF C ENERGY DEPOSIT PER RADIATION LENGTH IN MEV IF (EKE .GE. 3.D0 ) THEN DEDX = RLDU * MIN( DEDX0, * (86.65D0-STERNCOR-OUTPAR(5)*8.D-6)*RLDUI ) ELSE C NO DENSITY DEPENDENT STERNHEIMER CORRECTION AT LOW ENERGIES DEDX = RLDU * DEDX0 ENDIF C ENERGY DEPOSIT IN 1 G/CM**2; CONVERT ENERGY DEPOSIT FROM MEV TO GEV AUGEDP = DEDX * 1.D-3 / X0 C CONSIDER ENERGY DEPOSIT FOR VERTICAL DEPTH AND THICKNESS OF LAYER IF ( OUTPAR(2) .NE. 0.D0 ) THEN AUGEDP = AUGEDP / ABS( OUTPAR(2) ) * SAMPTH ELSE C HORIZONTAL MOVEMENT: RELEASABLE ENERGY IS ABSORBED WITHIN LAYER IF ( ITYPO .EQ. 3 ) THEN AUGEDP = OUTPAR(1)-PAMA(2) ELSE AUGEDP = OUTPAR(1)+PAMA(2) ENDIF ENDIF C WE TAKE THAT PART OF KINETIC ENERGY WHICH IS C AVAILABLE FOR CALCULATION OF TRANSPORT LENGTH. THIS IS INDEPENDENT C OF THE PARTICLE TYPE. THE (PARTICLE-DEPENDENT) RELEASABLE ENERGY IS C COUNTED WHEN THE PARTICLE COMES TO REST, SEE ---> AUGERDEPFIL. C THE KINETIC ENERGY BELOW THE ENERGY CUT IS NOT COUNTED HERE BUT C IN AUGECT. AUGEDP = MIN( AUGEDP, OUTPAR(1)-PAMA(2)-ELCUT(3) ) C TAKE INTO ACCOUNT THE WEIGHT AUGEDP = AUGEDP * OUTPAR(13) IF ( DEBUG ) WRITE(MDEBUG,*) 'AUGEDP=',AUGEDP ENDIF ELSE C HADRONIC PARTICLES IF ( SIGNUM(ITYPO) .NE. 0.D0 ) THEN C HADRONIC CHARGED PARTICLE GAM0 = MAX( OUTPAR(1), 1.0001D0 ) GAMSQ = GAM0**2 GMSQM1 = GAMSQ - 1.D0 C ENERGY LOSS IN 1 G/CM**2 AUGEDP = SIGNUM(ITYPO)**2 * C(22) * ( GAMSQ * (LOG( GMSQM1 ) * - 0.5D0 * LOG( GAM0 * C(16) + C(15) ) * + C(23)) / GMSQM1 - 1.D0 ) IF ( ITYPO .EQ. 5 .OR. ITYPO .EQ. 6 ) THEN AUGEDP = AUGEDP + CDEDXM( PAMA(5)*GAM0 ) ENDIF C CONSIDER ENERGY DEPOSIT FOR VERTICAL DEPTH AND THICKNESS OF LAYER AUGEDP = AUGEDP / OUTPAR(2) * SAMPTH C WE CALCULATE ONLY THE IONIZATION ENERGY EXCEEDING KINETIC ENERGY CUT C THE KINETIC ENERGY BELOW THE ENERGY CUT IS NOT COUNTED HERE BUT C IN AUGCUT. IF ( ITYPO .EQ. 5 .OR. ITYPO .EQ. 6 ) THEN AUGEDP = MIN( AUGEDP, (OUTPAR(1)-1.D0)*PAMA(5)-ELCUT(2) ) ELSE AUGEDP = MIN(AUGEDP, (OUTPAR(1)-1.D0)*PAMA(ITYPO)-ELCUT(1)) ENDIF C TAKE INTO ACCOUNT THE WEIGHT AUGEDP = AUGEDP * OUTPAR(13) IF ( DEBUG ) WRITE(MDEBUG,*) 'AUGEDP=',AUGEDP ELSE C HADRONIC NEUTRAL PARTICLE AUGEDP = 0.D0 ENDIF ENDIF RETURN END #endif #if __AUGERHIST__ *-- Author : D. HECK IK FZK KARLSRUHE 21/06/2001 C======================================================================= SUBROUTINE AUGERDEPFIL( EDEP,LL,ICUT ) C----------------------------------------------------------------------- C AUGER DEP(OSIT HISTOGRAM) FIL(LING) C C TO BE USED IF PARTICLE IS STOPPED OR GOES BELOW ENERGY THRESHOLD C IN THE LAYER BELOW THE OBSERVATION LEVEL. C FILLING OF THE HISTOGRAMMING TO FOLLOW THE LONGITUDINAL C EVOLUTION OF SHOWERS FOR THE AUGER EXPERIMENT. C AT LEVEL LL THE ENERGY EDEP IS DEPOSITED. THE COORDINATES OF THE C STOPPED PARTICLE ARE AVAILABLE IN OUTPAR. C THIS SUBROUTINE IS CALLED FROM AAMAIN, EM, MUBREM, MUPRPR, TSTACK, C AUGACT, AUGCUT, AND AUGECT. C ARGUMENTS: C EDEP = DEPOSITED ENERGY (GEV) (ALREADY CORRECTED BY WEIGHT) C LL = NUMBER OF OBSERVATION LEVEL C ICUT = 0 FOR ENERGY CUT, 1 FOR ANGULAR CUT C----------------------------------------------------------------------- IMPLICIT NONE #define __CONSTAINC__ #define __OBSPARINC__ #define __PAMINC__ #define __PARPARINC__ #define __RUNPARINC__ #include "corsika.h" DOUBLE PRECISION DXY,EDEP REAL DISTANCE,EDEPHI * REAL EKINPA,LGEKINPA,LGEDEP,THCOS,THDEG,X_M,Y_M INTEGER ICUT,IDHIST,ITYPO,J,LL SAVE C----------------------------------------------------------------------- IF (DEBUG) WRITE(MDEBUG,*) 'AUGERDEPFIL: EDEP=',EDEP,' LEVL=',LL, * 'ICUT=',ICUT C CORRECT COORDINATE SYSTEM FOR INCLINED SHOWER AXIS DXY = TANTEP * (HEIGHTP - OUTPAR(5)) OUTPAR(7) = OUTPAR(7) - COSPHIP*DXY OUTPAR(8) = OUTPAR(8) - SINPHIP*DXY C EXTRACT PARTICLE CHARACTERISTICS. CHANGE DISTANCES TO [M] ITYPO = NINT( OUTPAR(0) ) DISTANCE = 0.01 * SQRT( OUTPAR(7)**2 + OUTPAR(8)**2 ) C CONVERT CM TO METER * X_M = 0.01 * OUTPAR(7) * Y_M = 0.01 * OUTPAR(8) C EDEPHI: ENERGY RELEASE INTO AIR IN GEV IN NEXT VERT. G/CM^2 EDEPHI = EDEP * IF ( EDEPHI .GT. 0. ) THEN * LGEDEP = LOG10(EDEPHI) * ELSE * IF ( DEBUG ) WRITE(MDEBUG,*) 'AUGERDEPFIL: ATTENTION EDEPHI = 0' * * ,ITYPO,OUTPAR(1) * LGEDEP = -30. * ENDIF C DISTINGUISH PARTICLE ID''S C HERE: J=0: GAMMA, C J=1: E-, C J=2: E+, C J=3: MUON, C J=4: HADRON C REMEMBER: 66 =< ITYPO =< 69: NEUTRINOS C ITYPO >= 200: NUCLEI IF ( ITYPO .EQ. 1 ) THEN J = 0 ELSEIF ( ITYPO .EQ. 2 ) THEN J = 2 ELSEIF ( ITYPO .EQ. 3 ) THEN J = 1 ELSEIF ( ITYPO .EQ. 5 .OR. ITYPO .EQ. 6 ) THEN J = 3 ELSEIF ( ITYPO .GE. 7 .AND. ITYPO .LE. 65 .OR. * ITYPO .GE. 200 ) THEN J = 4 ELSE IF ( DEBUG ) WRITE(MDEBUG,*) 'AUGERDEPFIL: ATTENTION ITYPO = ', * ITYPO RETURN ENDIF C NOW FILL THE HISTOGRAMS IF ( J .GE. 0 .AND. J .LE. 4 ) THEN C RELEASABLE ENERGY VS DISTANCE C RELEASABLE ENERGY (SEE RISSE & HECK, ASTROPART PHYS 20 (2004) 661): C E_KIN : ELECTRON, POSITRON, MUON, NUCLEON, NUCLEUS C E_TOT-M_NUCLEON: UNSTABLE BARYON C E_TOT : GAMMA, MESON C E_TOT+M_NUCLEON: UNSTABLE ANTIBARYON C FOR POSITRONS, ANNIHILATION QUANTA ARE PRODUCED C DEPENDING ON PARTICLE TYPE, ONLY A FRACTION GOES INTO AIR IONIZATION IF ( EDEPHI .GT. 0. ) THEN IDHIST = 410000 + LEVL*100 + J CALL HFILL( IDHIST,DISTANCE,0.,EDEPHI ) ENDIF ENDIF RETURN END #endif #if __AUGERHIST__ *-- Author : M. RISSE IK FZK KARLSRUHE 16/02/2001 C======================================================================= SUBROUTINE AUGERHISTFIL C----------------------------------------------------------------------- C AUGER HIST(OGRAM) FIL(LING) C C FILLING OF THE HISTOGRAMMING TO FOLLOW THE LONGITUDINAL C EVOLUTION OF SHOWERS FOR THE AUGER EXPERIMENT. C THE POSITION COORDINATES IN OUTPAR ARE RELATIVE TO SHOWER AXIS. C HERE ALL PARTICLES PENETRATING THE LAYER BELOW THE OBSLEV ARE C REGARDED. C THIS SUBROUTINE IS CALLED FROM OUTPT1. C----------------------------------------------------------------------- IMPLICIT NONE #define __CONSTAINC__ #define __OBSPARINC__ #define __PAMINC__ #define __PARPARINC__ #define __RUNPARINC__ #include "corsika.h" DOUBLE PRECISION AUGEDP REAL DISTANCE,EDEPHI,EKINPA,LGEKINPA,WEIGHT INTEGER J,IDHIST,ITYPO SAVE EXTERNAL AUGEDP C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'AUGERHISTFIL: LEVL=',LEVL C EXTRACT PARTICLE CHARACTERISTICS. CHANGE DISTANCES TO [M] ITYPO = NINT( OUTPAR(0) ) DISTANCE = 0.01 * SQRT( OUTPAR(7)**2 + OUTPAR(8)**2 ) WEIGHT = OUTPAR(13) C EDEPHI: ENERGY RELEASE INTO AIR IN GEV IN NEXT VERT. G/CM^2 EDEPHI = REAL( AUGEDP() / SAMPTH ) C EKINPA: KINET. ENERGY (GEV). C FOR EM PARTICLES (+ NEUTRINOS): OUTPAR(1) = E_TOT, C ELSE: OUTPAR(1) = GAMMA-FACTOR IF ( ITYPO .LE. 3 ) THEN EKINPA = OUTPAR(1) - PAMA(ITYPO) ELSEIF ( ITYPO .GE. 4 .AND. ITYPO .LE. 65 .OR. * ITYPO .GE. 200 ) THEN EKINPA = (OUTPAR(1) - 1.D0) * PAMA(ITYPO) ELSE EKINPA = 0. ENDIF IF ( EKINPA .GT. 0. ) THEN LGEKINPA = LOG10( EKINPA ) ELSE IF ( DEBUG ) WRITE(*,*) 'AUGERHISTFIL: ATTENTION EKINPA=0', * ITYPO,OUTPAR(1) LGEKINPA = -99. ENDIF C DISTINGUISH PARTICLE ID''S C HERE: J=0: GAMMA, C J=1: E-, C J=2: E+, C J=3: MUON, C J=4: HADRON C REMEMBER: 66 =< ITYPO =< 69: NEUTRINOS C ITYPO >= 200: NUCLEI IF ( ITYPO .EQ. 1 ) THEN J = 0 ELSEIF ( ITYPO .EQ. 2 ) THEN J = 2 ELSEIF ( ITYPO .EQ. 3 ) THEN J = 1 ELSEIF ( ITYPO .EQ. 5 .OR. ITYPO .EQ. 6 ) THEN J = 3 ELSEIF ( ITYPO .GE. 7 .AND. ITYPO .LE. 65 .OR. * ITYPO .GE. 200 ) THEN J = 4 ELSE IF ( DEBUG ) WRITE(MDEBUG,*) 'AUGERHISTFIL: ATTENTION ITYPO = 0' RETURN ENDIF C FILL HISTOS C N VS DISTANCE IDHIST = 100000 + LEVL*100 + J CALL HFILL( IDHIST,DISTANCE,0.,WEIGHT ) C N VS LOG KIN. ENERGY IDHIST = 300000 + LEVL*100 + J CALL HFILL( IDHIST,LGEKINPA,0.,WEIGHT ) C EDEP VS DISTANCE IF ( EDEPHI .GT. 0. ) THEN IDHIST = 400000 + LEVL*100 + J CALL HFILL( IDHIST,DISTANCE,0.,EDEPHI ) ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) 'AUGERHISTFIL: END' RETURN END #endif #if __AUGERHIST__ || __ANAHIST__ || __MUONHIST__ *-- Author : M. RISSE IK FZK KARLSRUHE 16/02/2001 C======================================================================= SUBROUTINE AUGERHISTINI C----------------------------------------------------------------------- C AUGER HIST(OGRAM) INI(TIALIZATION) C C INITIALIZATION OF THE HISTOGRAMMING TO FOLLOW THE LONGITUDINAL C EVOLUTION OF SHOWERS FOR THE AUGER EXPERIMENT. C INITIALIZES ALSO ANAHISTO''S. C INITIALIZES ALSO MUONHISTO''S. C THIS SUBROUTINE IS CALLED FROM START. C----------------------------------------------------------------------- IMPLICIT NONE #define __OBSPARINC__ #define __RUNPARINC__ #if __ANAHIST__ #define __CONSTAINC__ #define __SFRONTINC__ #endif #include "corsika.h" COMMON/PAWC/ MEMOR(10000000) INTEGER I,LIMIT,MEMOR #if __ANAHIST__ CHARACTER*80 HTIT REAL LL,LL2,UL,UL2 INTEGER NB,NB2,NN #endif #if __AUGERHIST__ INTEGER J,IDHIST CHARACTER HISTNAME*45 CHARACTER PARTNAME(0:4)*11 #endif #if __MUONHIST__ INTEGER INDEX CHARACTER*27 TITLE #endif SAVE DATA LIMIT / 10000000 / C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'AUGERHISTINI: START' CALL HLIMIT( LIMIT ) #if __ANAHIST__ C HISTOGRAMS FROM THE STANDARD LYON ANALYSYS PROGRAM C 1-DIM HISTOGRAMS C HISTOGRAMS AS FUNCTION OF LOG10(RADIUS) NB = 100 LL = 0. UL = 5. C PARTICLE DENSITY HTIT = 'part density of vs log10(r)' NN = 100 DO I = 1, 11 HTIT(17:21) = CCLA(I) CALL HBOOK1( NN+I,HTIT,NB,LL,UL,0. ) ENDDO C RECORD DENSITY HTIT = 'rec density of vs log10(r)' NN = 120 DO I = 1, 11 HTIT(17:21) = CCLA(I) CALL HBOOK1( NN+I,HTIT,NB,LL,UL,0. ) ENDDO C ENERGY DENSITY HTIT = 'ener density of vs log10(r)' NN = 140 DO I = 1, 11 HTIT(17:21) = CCLA(I) CALL HBOOK1( NN+I,HTIT,NB,LL,UL,0. ) ENDDO C HISTOGRAMS AS FUNCTION OF LOG10(ENERGY) NB = 210 LL = -4. UL = 6. C ENERGY DISTRIBUTION FOR PARTICLES HTIT = 'N vs log10(kin. energy)' NN = 160 DO I = 1, 11 HTIT(3:7) = CCLA(I) CALL HBOOK1( NN+I,HTIT,NB,LL,UL,0. ) ENDDO C ENERGY DISTRIBUTION FOR RECS HTIT = 'N rec vs log10(kin. energy)' NN = 180 DO I = 1, 11 HTIT(7:11) = CCLA(I) CALL HBOOK1( NN+I,HTIT,NB,LL,UL,0. ) ENDDO C HISTOGRAMS AS FUNCTION OF LOG10(TIME) NB = 40 LL = 0. UL = 4. C TIME DISTRIBUTION FOR PARTICLES HTIT = 'N vs log10(time)' NN = 200 DO I = 1, 11 HTIT(3:7) = CCLA(I) CALL HBOOK1( NN+I,HTIT,NB,LL,UL,0. ) ENDDO C TIME DISTRIBUTION FOR RECS HTIT = 'N rec vs log10(time)' NN = 220 DO I = 1, 11 HTIT(7:11) = CCLA(I) CALL HBOOK1( NN+I,HTIT,NB,LL,UL,0. ) ENDDO C HISTOGRAMS AS FUNCTION OF THETA NB = 100 LL = 0. UL = PI/2. C THETA DISTRIBUTION FOR PARTICLES HTIT = 'N vs theta' NN = 240 DO I = 1, 11 HTIT(3:7) = CCLA(I) CALL HBOOK1( NN+I,HTIT,NB,LL,UL,0. ) ENDDO C THETA DISTRIBUTION FOR RECs HTIT = 'N rec vs theta' NN = 260 DO I = 1, 11 HTIT(7:11) = CCLA(I) CALL HBOOK1( NN+I,HTIT,NB,LL,UL,0. ) ENDDO C HISTOGRAMS AS FUNCTION OF PHI NB = 100 LL = -PI UL = PI C PHI DISTRIBUTION FOR PARTICLES HTIT = 'N vs phi' NN = 280 DO I = 1, 11 HTIT(3:7) = CCLA(I) CALL HBOOK1( NN+I,HTIT,NB,LL,UL,0. ) ENDDO C PHI DISTRIBUTION FOR RECS HTIT = 'N rec vs phi' NN = 300 DO I = 1, 11 HTIT(7:11) = CCLA(I) CALL HBOOK1( NN+I,HTIT,NB,LL,UL,0. ) ENDDO C HISTOGRAMS AS FUNCTION OF WEIGHT NB = 100 LL = 0. UL = 10. C WEIGHT DISTRIBUTION HTIT = 'N vs log10(weight)' NN = 320 DO I = 1, 11 HTIT(3:7) = CCLA(I) CALL HBOOK1( NN+I,HTIT,NB,LL,UL,0. ) ENDDO C 2-DIM HISTOGRAMS C PARTICLE NUMBERS AS FUNCTION OF PARTICLE CODE AND R NB = 30 LL = 0.5 UL = 30.5 NB2 = 100 LL2 = 0. UL2 = 5. CALL HBOOK2( 99,'particle codes vs log10(r)', * NB,LL,UL,NB2,LL2,UL2,0. ) CALL HBPRO( 99,0. ) C PARTICLE NUMBERS AS FUNCTION OF ENERGY AND R NB = 100 LL = -4. UL = 6. NB2 = 100 LL2 = 0. UL2 = 5. HTIT = 'N vs log10(Ek) and log10(r)' NN = 340 DO I = 1, 11 HTIT(3:7) = CCLA(I) CALL HBOOK2( NN+I,HTIT,NB,LL,UL,NB2,LL2,UL2,0. ) ENDDO C PARTICLE NUMBERS AS FUNCTION OF TIME AND R NB = 40 LL = 0. UL = 4. NB2 = 100 LL2 = 0. UL2 = 5. HTIT = 'N vs log10(t) and log10(r)' NN = 360 DO I = 1, 11 HTIT(3:7) = CCLA(I) CALL HBOOK2( NN+I,HTIT,NB,LL,UL,NB2,LL2,UL2,0. ) ENDDO C PARTICLE NUMBERS AS FUNCTION OF ENERGY AND T NB = 100 LL = -4. UL = 6. NB2 = 40 LL2 = 0. UL2 = 4. HTIT = 'N vs log10(Ek) and log10(t)' NN = 380 DO I = 1, 11 HTIT(3:7) = CCLA(I) CALL HBOOK2( NN+I,HTIT,NB,LL,UL,NB2,LL2,UL2,0. ) ENDDO C PARTICLE NUMBERS AS FUNCTION OF WEIGHT AND ENERGY NB = 100 LL = 0. UL = 10. NB2 = 100 LL2 = -4. UL2 = 6. HTIT = 'N vs log10(wt) and log10(e)' NN = 400 DO I = 1, 11 HTIT(3:7) = CCLA(I) CALL HBOOK2( NN+I,HTIT,NB,LL,UL,NB2,LL2,UL2,0. ) ENDDO C PARTICLE NUMBERS AS FUNCTION OF WEIGHT AND R NB = 100 LL = 0. UL = 10. NB2 = 100 LL2 = 0. UL2 = 5. HTIT = 'N vs log10(wt) and log10(r)' NN = 420 DO I = 1, 11 HTIT(3:7) = CCLA(I) CALL HBOOK2( NN+I,HTIT,NB,LL,UL,NB2,LL2,UL2,0. ) ENDDO C PARTICLE NUMBERS AS FUNCTION OF WEIGHT AND TIME NB = 100 LL = 0. UL = 10. NB2 = 40 LL2 = 0. UL2 = 4. HTIT = 'N vs log10(wt) and log10(t)' NN = 440 DO I = 1, 11 HTIT(3:7) = CCLA(I) CALL HBOOK2( NN+I,HTIT,NB,LL,UL,NB2,LL2,UL2,0. ) ENDDO CALL HIDOPT( 0,'STAT' ) C END OF THE HISTOGRAMS OF STANDARD ANALYSIS AT LYON #endif #if __MUONHIST__ C HISTOGRAMS FOR MUONHIST CALL HBOOK1(9111,'N vs. z',1000000,0.,20000000.,0.) CALL HBOOK2(9112,'N(z,logE)',10000,0.,20000000.,120,-1.,5.,0.) C cos (theta) C CALL HBOOK1(9113,'N vs. cos(th)',1000,-1.2,1.2,0.) CALL HBOOK2(9114,'N(z,logpt)',10000,0.,20000000.,140,-3.,4.,0.) CALL HBOOK2(9115,'logE vs logpt',120,-1.,5.,140,-3.,4.,0.) C CALL HBOOK2(9116,'N(z,logsina)',10000,0.,20000000.,100,-5.,0.,0.) CALL HBOOK1(9121,'N vs. X',5000,0.,5000.,0.) CALL HBOOK2(9122,'N(X,logE)',5000,0.,5000.,120,-1.,5.,0.) CALL HBOOK2(9123,'N(X,logpt)',5000,0.,5000.,140,-3.,4.,0.) C CALL HBOOK2(9124,'N(X,logpt) late',5000,0.,5000.,140,-3.,4.,0.) C CALL HBOOK2(9126,'N(X,logsina)',5000,0.,5000.,100,-5.,0.,0.) CALL HBOOK2(9127,'N(X,x(m))',2000,0.,2000.,200,0.,200.,0.) C HISTOGRAMS FOR LATERAL DISTRIBUTION TITLE = 'logE vs logpt ( 0200 ARE CHARGED AND NUCLEI C C DESIGN : J. KNAPP IEKP U KARLSRUHE C----------------------------------------------------------------------- IMPLICIT NONE #define __TSTINTINC__ #include "corsika.h" INTEGER I,J DATA ((PARCLA(I,J),I=1,5),J=1,115) / C PARTICLE TYPES 1 .. 32 * 1,3,15,0,0, 1,2,0,0,0, 1,2,0,0,0, 0,0,0,0,0, 1,2,0,0,0, * 1,2,0,0,0, 1,3,6,0,0, 1,2,4,22,27, 1,2,5,22,27, 1,3,9,23,0, ! 10 * 1,2,7,23,27, 1,2,8,23,27, 1,3,12,24,26,1,2,11,24,26,1,2,13,25,26, * 1,3,10,23,0, 1,3,17,0,0, 1,3,16,24,26,1,2,16,24,26,1,3,16,24,26, ! 20 * 1,2,16,24,26,1,3,16,24,26,1,2,16,24,26,1,2,16,24,26,1,3,14,25,26, * 1,3,16,25,26,1,2,16,25,26,1,3,16,25,26,1,2,16,25,26,1,3,16,25,26, ! 30 * 1,2,16,25,26,1,2,16,25,26,90*0, 1,3,18,0,0, 1,2,18,27,0, ! 52 C PARTICLE TYPES 53 ...75 * 1,2,18,27,0, 1,2,19,24,26,1,2,19,24,26,1,3,19,24,26,1,2,19,24,26, ! 57 * 1,2,19,25,26,1,2,19,25,26,1,3,19,25,26,1,2,19,25,26,1,3,20,23,0, ! 62 * 1,2,20,23,27,1,2,20,23,27,1,3,20,23,0, 25*0, 1,3,17,0,0, ! 71 C PARTICLE TYPES 72 ... 115 * 1,3,17,0,0, 1,3,17,0,0, 1,3,17,0,0, 1,2,21,0,0, 200*0/ !115 DATA ((PARCLA(I,J),I=1,5),J=116,195) / C PARTICLE TYPES 116 ... 195 * 1,3,30,0,0, 1,2,27,30,0, 1,2,27,30,0, 1,3,30,0,0, 1,2,27,30, 0, !120 * 1,2,27,30,0, 1,3,30,0,0, 1,3,30,0,0, 1,2,27,30,0, 1,2,27,30, 0, * 1,3,30,0,0, 1,2,27,30,0, 1,2,27,30,0, 5*0, 1,3,30, 0, 0, !130 * 1,2,0,0,0, 1,2,0,0,0, 20*0, 1,2,16,24,31,1,2,16,24,31, !138 * 1,3,16,24,31,1,2,16,24,31,1,2,16,24,31,1,3,16,24,31,1,2,16,24,31, !143 * 1,3,16,24,31,1,3,16,24,31,15*0, 1,2,16,24,31,1,2,16,24,31, !150 * 1,3,16,24,31,1,2,16,24,31,1,2,16,24,31,1,3,16,24,31,1,2,16,24,31, !155 * 1,3,16,24,31,1,3,16,24,31,15*0, 1,2,16,24,31,1,2,16,24,31, !162 * 1,3,16,24,31,35*0, 1,2,16,24,31,1,2,16,24,31,1,3,16,24,31, 10*0, !175 * 1,3,33,0,0, 1,2,33,0,0, 1,2,33,0,0, 1,3,33,0,0, 1,3,33,0,0, !180 * 1,3,33,0,0, 1,2,33,0,0, 1,2,33,0,0, 1,3,16,24,34,1,3,16,24,34, !185 * 1,2,16,24,34,1,3,16,24,34,1,2,16,24,34,1,2,16,24,34,1,3,16,25,34, !190 * 1,3,16,25,34,1,2,16,25,34,1,3,16,25,34,1,2,16,25,34,1,2,16,25,34/ !195 END *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE HISFIL C----------------------------------------------------------------------- C HIS(TOGRAM) FIL(LING) C C FILL THE HISTOGRAMS C THIS SUBROUTINE IS CALLED FROM AAMAIN. C----------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) #define __PARPAEINC__ #define __PARPARINC__ #define __RUNPARINC__ #define __TSTINTINC__ #include "corsika.h" REAL VAL,VALX,VALY SAVE C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'HISFIL: ENTERING WITH ',NNI,' PART.' IF ( NNI .LE. 0 ) RETURN C FIND LEADING PARTICLES (ONLY AMONGST THE NON SPECTATORS) C (HIGHEST ENERGY NON-CHARMED BARYON IN LAB SYSTEM) IF ( DEBUG ) WRITE(MDEBUG,*) 'HISFIL: FIND LEADERS' ILEADTOT = 0 ELEADTOT = 0.D0 ILEAD = 0 ELEAD = 0.D0 DO 2 I = 1, NNI IF ( HENL(I) .GT. ELEADTOT ) THEN ILEADTOT = I ELEADTOT = HENL(I) ENDIF IT = MIN( HIT(I), 175 ) IF ( PARCLA(5,IT) .NE. 26 ) GOTO 2 IF ( IT .EQ. 137 .OR. IT .EQ. 149 ) GOTO 2 IF ( HENL(I) .GT. ELEAD ) THEN ILEAD = I ELEAD = HENL(I) ENDIF 2 CONTINUE C HIGHEST ENERGY CHARMED BARYON ELEADCB = 0.D0 ILEADCB = 0 DO 2112 I = 1, NNI IT = MIN( HIT(I), 175 ) IF ( IT .NE. 137 .AND. IT .NE. 149 ) GOTO 2112 IF ( HENL(I) .GT. ELEADCB ) THEN ILEADCB = I ELEADCB = HENL(I) ENDIF 2112 CONTINUE C HIGHEST ENERGY CHARMED MESON ILEADCM = 0 ELEADCM = 0.D0 DO 4444 I = 1, NNI IT = MIN( HIT(I), 175 ) IF ( IT .NE. 116 .AND. IT .NE.117 * .AND. IT .NE. 118 .AND. IT .NE. 119 ) GOTO 4444 IF ( HENL(I) .GT. ELEADCM ) THEN ILEADCM = I ELEADCM = HENL(I) ENDIF 4444 CONTINUE C HIGHEST ENERGY NON-CHARMED MESON (NO PI0 NO ETA) IN LAB SYSTEM ILEADPI = 0 ELEADPI = 0.D0 DO 42 I = 1, NNI IT = MIN( HIT(I), 175 ) IF ( PARCLA(4,IT) .NE. 27 .AND. * PARCLA(5,IT) .NE. 27 .AND. * PARCLA(4,IT) .NE. 23 .AND. * IT .NE. 51 ) GOTO 42 IF ( IT .EQ. 116 .OR. IT .EQ. 117 .OR. * IT .EQ. 118 .OR. IT .EQ. 119 ) GOTO 42 IF ( HENL(I) .GT. ELEADPI ) THEN ILEADPI = I ELEADPI = HENL(I) ENDIF 42 CONTINUE C LOOK FOR THE HIGHEST ENERGY HADRON (LEADING HADRON) IF ( ELEAD .GE. ELEADPI ) THEN ELEADHAD = ELEAD ILEADHAD = ILEAD ELSE ELEADHAD = ELEADPI ILEADHAD = ILEADPI ENDIF IF ( ELEADCM .GE. ELEADHAD ) THEN ELEADHAD = ELEADCM ILEADHAD = ILEADCM ENDIF IF ( ELEADBM .GE. ELEADHAD ) THEN ELEADHAD = ELEADBM ILEADHAD = ILEADBM ENDIF IF ( DEBUG ) THEN WRITE(MDEBUG,*) ' HIGHEST TOT ',ILEADTOT,ELEADTOT WRITE(MDEBUG,*) ' HIGHEST BARY ',ILEAD,ELEAD WRITE(MDEBUG,*) ' HIGHEST MESON',ILEADPI,ELEADPI WRITE(MDEBUG,*) ' HIGHEST HADRON',ILEADHAD,ELEADHAD WRITE(MDEBUG,*) ' HIGHEST CHRD. MES',ILEADCM,ELEADCM WRITE(MDEBUG,*) ' HIGHEST CHRD, BAR',ILEADCB,ELEADCB ENDIF Cg WRITE(MONIOU,*) LOG10(HENL(ILEADTOT)) C HIGHEST ENERGY PARTICLE IF ( ILEADTOT .EQ. 0 ) THEN IF ( DEBUG ) * WRITE(MDEBUG,*) 'HISFIL: NO LEADING PARTICLE' ELSE IF ( DEBUG ) * WRITE(MDEBUG,*) 'HISFIL: LEADING PARTICLE ', * ILEADTOT,HIT(ILEADTOT),ELEADTOT VAL = HIT(ILEADTOT) CALL HFILL( 7,VAL,0.,1. ) ENDIF C PARTICLE ID IF ( DEBUG ) WRITE(MDEBUG,*) ' PARTICLE ID' DO I = 1, NNI VAL = HIT(I) CALL HFILL( 1,VAL,0.,1. ) IF ( VAL .GT. 200 ) CALL HFILL( 8,VAL/100.,0.,1. ) !FRAGMENTS C ENTRIES PER CLASS IT = MIN( HIT(I), 175 ) DO IL = 1, 5 IC = PARCLA(IL,IT) IF ( IC .NE. 0 ) THEN MCLA(IC) = MCLA(IC) + 1 ENDIF ENDDO ENDDO C PT DISTRIBUTION IF ( DEBUG ) WRITE(MDEBUG,*) ' PT' IOBS = 100 DO I = 1, NNI VAL = HPT(I) IT = MIN( HIT(I), 175 ) DO IL = 1, 5 IC = PARCLA(IL,IT) IF ( IC .NE. 0 ) THEN CALL HFILL( IOBS+IC,VAL,0.,1. ) PTAV(IC) = PTAV(IC) + HPT(I) ENDIF ENDDO ENDDO IF ( ILEAD .GT. 0 .AND. ILEAD .EQ. ILEADTOT ) THEN VAL = HPT(ILEAD) CALL HFILL( IOBS+28,VAL,0.,1. ) ENDIF IF ( ILEADPI .GT. 0 .AND. ILEADPI .EQ. ILEADTOT ) THEN VAL = HPT(ILEADPI) CALL HFILL( IOBS+29,VAL,0.,1. ) ENDIF C LEADING HADRON IF ( ILEADHAD .GT. 0 .AND. ILEADHAD .EQ. ILEADTOT ) THEN VAL = HPT(ILEADHAD) CALL HFILL( IOBS+32,VAL,0.,1. ) ENDIF C LEADING CHARMED MESON IF ( ILEADCM .GT. 0 .AND. ILEADCM .EQ. ILEADTOT ) THEN VAL = HPT(ILEADCM) CALL HFILL( IOBS+33,VAL,0.,1. ) ENDIF C LEADING CHARMED BARYON IF ( ILEADCB .GT. 0 .AND. ILEADCB .EQ. ILEADTOT ) THEN VAL = HPT(ILEADCB) CALL HFILL( IOBS+34,VAL,0.,1. ) ENDIF C PT**2 DISTRIBUTION IF ( DEBUG ) WRITE(MDEBUG,*) ' PT**2' IOBS = 200 DO I = 1, NNI VAL = HPT2(I) IT = MIN( HIT(I), 175 ) DO IL = 1, 5 IC = PARCLA(IL,IT) IF ( IC .NE. 0 ) THEN CALL HFILL( IOBS+IC,VAL,0.,1. ) PT2AV(IC) = PT2AV(IC) + HPT2(I) ENDIF ENDDO ENDDO IF ( ILEAD .GT. 0 .AND. ILEAD .EQ. ILEADTOT ) THEN VAL = HPT2(ILEAD) CALL HFILL( IOBS+28,VAL,0.,1. ) ENDIF IF ( ILEADPI .GT. 0 .AND. ILEADPI .EQ. ILEADTOT ) THEN VAL = HPT2(ILEADPI) CALL HFILL( IOBS+29,VAL,0.,1. ) ENDIF C LEADING HADRON IF ( ILEADHAD .GT. 0 .AND. ILEADHAD .EQ. ILEADTOT ) THEN VAL = HPT2(ILEADHAD) CALL HFILL( IOBS+32,VAL,0.,1. ) ENDIF C LEADING CHARMED MESON IF ( ILEADCM .GT. 0 .AND. ILEADCM .EQ. ILEADTOT ) THEN VAL = HPT2(ILEADCM) CALL HFILL( IOBS+33,VAL,0.,1. ) ENDIF C LEADING CHARMED BARYON IF ( ILEADCB .GT. 0 .AND. ILEADCB .EQ. ILEADTOT ) THEN VAL = HPT2(ILEADCB) CALL HFILL( IOBS+34,VAL,0.,1. ) ENDIF C PL DISTRIBUTION IF ( DEBUG ) WRITE(MDEBUG,*) ' PL' IOBS = 300 DO I = 1, NNI VAL = ABS(HPL(I)) IT = MIN( HIT(I), 175 ) DO IL = 1, 5 IC = PARCLA(IL,IT) IF ( IC .NE. 0 ) THEN CALL HFILL( IOBS+IC,VAL,0.,1. ) PLAV(IC) = PLAV(IC) + ABS(HPL(I)) ENDIF ENDDO ENDDO IF ( ILEAD .GT. 0 .AND. ILEAD .EQ. ILEADTOT ) THEN VAL = HPL(ILEAD) CALL HFILL( IOBS+28,VAL,0.,1. ) ENDIF IF ( ILEADPI .GT. 0 .AND. ILEADPI .EQ. ILEADTOT ) THEN VAL = HPL(ILEADPI) CALL HFILL( IOBS+29,VAL,0.,1. ) ENDIF C LEADING HADRON IF ( ILEADHAD .GT. 0 .AND. ILEADHAD .EQ. ILEADTOT ) THEN VAL = HPL(ILEADHAD) CALL HFILL( IOBS+32,VAL,0.,1. ) ENDIF C LEADING CHARMED MESON IF ( ILEADCM .GT. 0 .AND. ILEADCM .EQ. ILEADTOT ) THEN VAL = HPL(ILEADCM) CALL HFILL( IOBS+33,VAL,0.,1. ) ENDIF C LEADING CHARMED BARYON IF ( ILEADCB .GT. 0 .AND. ILEADCB .EQ. ILEADTOT ) THEN VAL = HPL(ILEADCB) CALL HFILL( IOBS+34,VAL,0.,1. ) ENDIF C XF DISTRIBUTION IF ( DEBUG ) WRITE(MDEBUG,*) ' XF' IOBS = 400 DO I = 1, NNI VAL = HXF(I) IT = MIN( HIT(I), 175 ) DO IL = 1, 5 IC = PARCLA(IL,IT) IF ( IC .NE. 0 ) THEN CALL HFILL( IOBS+IC,VAL,0.,1. ) XFAV(IC) = XFAV(IC) + HXF(I) ENDIF ENDDO ENDDO IF ( ILEAD .GT. 0 .AND. ILEAD .EQ. ILEADTOT ) THEN VAL = HXF(ILEAD) CALL HFILL( IOBS+28,VAL,0.,1. ) ENDIF IF ( ILEADPI .GT. 0 .AND. ILEADPI .EQ. ILEADTOT ) THEN VAL = HXF(ILEADPI) CALL HFILL( IOBS+29,VAL,0.,1. ) ENDIF C LEADING HADRON IF ( ILEADHAD .GT. 0 .AND. ILEADHAD .EQ. ILEADTOT ) THEN VAL = HXF(ILEADHAD) CALL HFILL( IOBS+32,VAL,0.,1. ) ENDIF C LEADING CHARMED MESON IF ( ILEADCM .GT. 0 .AND. ILEADCM .EQ. ILEADTOT ) THEN VAL = HXF(ILEADCM) CALL HFILL( IOBS+33,VAL,0.,1. ) ENDIF C LEADING CHARMED BARYON IF ( ILEADCB .GT. 0 .AND. ILEADCB .EQ. ILEADTOT ) THEN VAL = HXF(ILEADCB) CALL HFILL( IOBS+34,VAL,0.,1. ) ENDIF C LOG10(XF) DISTRIBUTION IF ( DEBUG ) WRITE(MDEBUG,*) ' LOG10(XF)' IOBS = 2000 DO I = 1, NNI VAL = HXFL(I) IT = MIN( HIT(I), 175 ) DO IL = 1, 5 IC = PARCLA(IL,IT) IF ( IC .NE. 0 ) THEN CALL HFILL( IOBS+IC,VAL,0.,1. ) XFLAV(IC) = XFLAV(IC) + HXFL(I) ENDIF ENDDO ENDDO IF ( ILEAD .GT. 0 .AND. ILEAD .EQ. ILEADTOT ) THEN VAL = HXFL(ILEAD) CALL HFILL( IOBS+28,VAL,0.,1. ) ENDIF IF ( ILEADPI .GT. 0 .AND. ILEADPI .EQ. ILEADTOT ) THEN VAL = HXFL(ILEADPI) CALL HFILL( IOBS+29,VAL,0.,1. ) ENDIF C LEADING HADRON IF ( ILEADHAD .GT. 0 .AND. ILEADHAD .EQ. ILEADTOT ) THEN VAL = HXFL(ILEADHAD) CALL HFILL( IOBS+32,VAL,0.,1. ) ENDIF C LEADING CHARMED MESON IF ( ILEADCM .GT. 0 .AND. ILEADCM .EQ. ILEADTOT ) THEN VAL = HXFL(ILEADCM) CALL HFILL( IOBS+33,VAL,0.,1. ) ENDIF C LEADING CHARMED BARYON IF ( ILEADCB .GT. 0 .AND. ILEADCB .EQ. ILEADTOT ) THEN VAL = HXFL(ILEADCB) CALL HFILL( IOBS+34,VAL,0.,1. ) ENDIF C XFCM DISTRIBUTION IF ( DEBUG ) WRITE(MDEBUG,*) ' XFCM' IOBS = 2400 DO I = 1, NNI VAL = HXFCM(I) IT = MIN( HIT(I), 175 ) DO IL = 1, 5 IC = PARCLA(IL,IT) IF ( IC .NE. 0 ) THEN CALL HFILL( IOBS+IC,VAL,0.,1. ) ENDIF ENDDO ENDDO IF ( ILEAD .GT. 0 .AND. ILEAD .EQ. ILEADTOT ) THEN VAL = HXFCM(ILEAD) CALL HFILL( IOBS+28,VAL,0.,1. ) ENDIF IF ( ILEADPI .GT. 0 .AND. ILEADPI .EQ. ILEADTOT ) THEN VAL = HXFCM(ILEADPI) CALL HFILL( IOBS+29,VAL,0.,1. ) ENDIF C LEADING HADRON IF ( ILEADHAD .GT. 0 .AND. ILEADHAD .EQ. ILEADTOT ) THEN VAL = HXFCM(ILEADHAD) CALL HFILL( IOBS+32,VAL,0.,1. ) ENDIF C LEADING CHARMED MESON IF ( ILEADCM .GT. 0 .AND. ILEADCM .EQ. ILEADTOT ) THEN VAL = HXFCM(ILEADCM) CALL HFILL( IOBS+33,VAL,0.,1. ) ENDIF C LEADING CHARMED BARYON IF ( ILEADCB .GT. 0 .AND. ILEADCB .EQ. ILEADTOT ) THEN VAL = HXFCM(ILEADCB) CALL HFILL( IOBS+34,VAL,0.,1. ) ENDIF C RAPIDITY DISTRIBUTION IF ( DEBUG ) WRITE(MDEBUG,*) ' RAPIDITY' IOBS = 500 DO I = 1, NNI VAL = HYR(I) IT = MIN( HIT(I), 175 ) DO IL = 1, 5 IC = PARCLA(IL,IT) IF ( IC .NE. 0 ) THEN CALL HFILL( IOBS+IC,VAL,0.,1. ) C WEIGHT IS ENERGY IN CM SYSTEM CALL HFILL( 2200+IC,VAL,0.,SNGL(HEN(I)) ) RAPAV(IC) = RAPAV(IC) + HYR(I) ENDIF ENDDO ENDDO IF ( ILEAD .GT. 0 .AND. ILEAD .EQ. ILEADTOT ) THEN VAL = HYR(ILEAD) CALL HFILL( IOBS+28,VAL,0.,1. ) ENDIF IF ( ILEADPI .GT. 0 .AND. ILEADPI .EQ. ILEADTOT ) THEN VAL = HYR(ILEADPI) CALL HFILL( IOBS+29,VAL,0.,1. ) ENDIF C LEADING HADRON IF ( ILEADHAD .GT. 0 .AND. ILEADHAD .EQ. ILEADTOT ) THEN VAL = HYR(ILEADHAD) CALL HFILL( IOBS+32,VAL,0.,1. ) ENDIF C LEADING CHARMED MESON IF ( ILEADCM .GT. 0 .AND. ILEADCM .EQ. ILEADTOT ) THEN VAL = HYR(ILEADCM) CALL HFILL( IOBS+33,VAL,0.,1. ) ENDIF C LEADING CHARMED BARYON IF ( ILEADCB .GT. 0 .AND. ILEADCB .EQ. ILEADTOT ) THEN VAL = HYR(ILEADCB) CALL HFILL( IOBS+34,VAL,0.,1. ) ENDIF C PSEUDO RAPIDITY DISTRIBUTION AND CENTRAL PSEUDO RAPIDITY DENSITY IF ( DEBUG ) WRITE(MDEBUG,*) ' PSEUDORAPIDITY' IOBS = 600 DO I = 1, NNI VAL = HPR(I) IF ( ABS(HPR(I)) .LE. 1.D0 ) THEN CCC = 1.D0 ELSE CCC = 0.D0 ENDIF IT = MIN( HIT(I), 175 ) DO IL = 1, 5 IC = PARCLA(IL,IT) IF ( IC .NE. 0 ) THEN CALL HFILL( IOBS+IC,VAL,0.,1. ) C WEIGHT IS ENERGY IN CM SYSTEM CALL HFILL( 2300+IC,VAL,0.,SNGL(HEN(I)) ) PRAPAV(IC) = PRAPAV(IC) + HPR(I) CRD(IC) = CRD(IC) + CCC ENDIF ENDDO ENDDO IF ( ILEAD .GT. 0 .AND. ILEAD .EQ. ILEADTOT ) THEN VAL = HPR(ILEAD) CALL HFILL( IOBS+28,VAL,0.,1. ) ENDIF IF ( ILEADPI .GT. 0 .AND. ILEADPI .EQ. ILEADTOT ) THEN VAL = HPR(ILEADPI) CALL HFILL( IOBS+29,VAL,0.,1. ) ENDIF C LEADING HADRON IF ( ILEADHAD .GT. 0 .AND. ILEADHAD .EQ. ILEADTOT ) THEN VAL = HPR(ILEADHAD) CALL HFILL( IOBS+32,VAL,0.,1. ) ENDIF C LEADING CHARMED MESON IF ( ILEADCM .GT. 0 .AND. ILEADCM .EQ. ILEADTOT ) THEN VAL = HPR(ILEADCM) CALL HFILL( IOBS+33,VAL,0.,1. ) ENDIF C LEADING CHARMED BARYON IF ( ILEADCB .GT. 0 .AND. ILEADCB .EQ. ILEADTOT ) THEN VAL = HPR(ILEADCB) CALL HFILL( IOBS+34,VAL,0.,1. ) ENDIF C MOMENTUM FRACTION OF BEAM MOMENTUM P/P_BEAM IF ( DEBUG ) WRITE(MDEBUG,*) ' BEAM MOMENTUM FRACTION' IOBS = 2500 DO I = 1, NNI IF ( HCT(NNI) .GT. 0.D0 ) THEN VAL = HPP(I)/PTOT0N ELSE VAL = -HPP(I)/PTOT0N ENDIF IT = MIN( HIT(I), 175 ) DO IL = 1, 5 IC = PARCLA(IL,IT) IF ( IC .NE. 0 ) THEN CALL HFILL( IOBS+IC,VAL,0.,1. ) ENDIF ENDDO ENDDO IF ( ILEAD .GT. 0 .AND. ILEAD .EQ. ILEADTOT ) THEN VAL = HPP(ILEAD)/PTOT0N CALL HFILL( IOBS+28,VAL,0.,1. ) ENDIF IF ( ILEADPI .GT. 0 .AND. ILEADPI .EQ. ILEADTOT ) THEN VAL = HPP(ILEADPI)/PTOT0N CALL HFILL( IOBS+29,VAL,0.,1. ) ENDIF C LEADING HADRON IF ( ILEADHAD .GT. 0 .AND. ILEADHAD .EQ. ILEADTOT ) THEN VAL = HPP(ILEADHAD)/PTOT0N CALL HFILL( IOBS+32,VAL,0.,1. ) ENDIF C LEADING CHARMED MESON IF ( ILEADCM .GT. 0 .AND. ILEADCM .EQ. ILEADTOT ) THEN VAL = HPP(ILEADCM)/PTOT0N CALL HFILL( IOBS+33,VAL,0.,1. ) ENDIF C LEADING CHARMED BARYON IF ( ILEADCB .GT. 0 .AND. ILEADCB .EQ. ILEADTOT ) THEN VAL = HPP(ILEADCB)/PTOT0N CALL HFILL( IOBS+34,VAL,0.,1. ) ENDIF IF ( ILEADTOT .GT. 0) THEN VAL = HPP(ILEADTOT)/PTOT0N CALL HFILL( IOBS+35,VAL,0.,1. ) ENDIF C ENERGY SUMMING FOR INELASTICITY DISTRIBUTION (ALL INCLUDING LEADER) DO I = 1, NNI CC IF ( I .EQ. ILEAD ) GOTO 177 IT = MIN( HIT(I), 175 ) DO IL = 1, 5 IC = PARCLA(IL,IT) IF ( IC .NE. 0 ) THEN INEL(IC) = INEL(IC) + HENL(I) ENDIF ENDDO ENDDO IF ( ILEAD .GT. 0 .AND. ILEAD .EQ. ILEADTOT ) THEN INEL(28) = HENL(ILEAD) ELSE INEL(28) = 0.D0 ENDIF IF ( ILEADPI .GT. 0 .AND. ILEADPI .EQ. ILEADTOT ) THEN INEL(29) = HENL(ILEADPI) ELSE INEL(29) = 0.D0 ENDIF C LEADING HADRON IF ( ILEADHAD .GT. 0 .AND. ILEADHAD .EQ. ILEADTOT ) THEN INEL(32) = HENL(ILEADHAD) ELSE INEL(32) = 0.D0 ENDIF C LEADING CHARMED MESON IF ( ILEADCM .GT. 0 .AND. ILEADCM .EQ. ILEADTOT ) THEN INEL(33) = HENL(ILEADCM) ELSE INEL(33) = 0.D0 ENDIF C LEADING CHARMED BARYON IF ( ILEADCB .GT. 0 .AND. ILEADCB .EQ. ILEADTOT ) THEN INEL(34) = HENL(ILEADCB) ELSE INEL(34) = 0.D0 ENDIF C LEADING AMONG ALL IF ( ILEADTOT .GT. 0 ) THEN INEL(35) = HENL(ILEADTOT) ELSE INEL(35) = 0.D0 ENDIF C 2-DIM HISTOGRAM TRANSVERSE MOMENTUM VS. RAPIDITY IF ( DEBUG ) WRITE(MDEBUG,*) ' P_T VS. RAPIDITY' IOBS = 2600 DO I = 1, NNI VALX = HPT(I) VALY = HYR(I) IT = MIN( HIT(I), 175 ) DO IL = 1, 5 IC = PARCLA(IL,IT) IF ( IC .NE. 0 ) THEN CALL HFILL( IOBS+IC,VALX,VALY,1. ) ENDIF ENDDO ENDDO IF ( ILEAD .GT. 0 .AND. ILEAD .EQ. ILEADTOT ) THEN VALX = HPT(ILEAD) VALY = HYR(ILEAD) CALL HFILL( IOBS+28,VALX,VALY,1. ) ENDIF IF ( ILEADPI .GT. 0 .AND. ILEADPI .EQ. ILEADTOT ) THEN VALX = HPT(ILEADPI) VALY = HYR(ILEADPI) CALL HFILL( IOBS+29,VALX,VALY,1. ) ENDIF C LEADING HADRON IF ( ILEADHAD .GT. 0 .AND. ILEADHAD .EQ. ILEADTOT ) THEN VALX = HPT(ILEADHAD) VALY = HYR(ILEADHAD) CALL HFILL( IOBS+32,VALX,VALY,1. ) ENDIF C LEADING CHARMED MESON IF ( ILEADCM .GT. 0 .AND. ILEADCM .EQ. ILEADTOT ) THEN VALX = HPT(ILEADCM) VALY = HYR(ILEADCM) CALL HFILL( IOBS+33,VALX,VALY,1. ) ENDIF C LEADING CHARMED BARYON IF ( ILEADCB .GT. 0 .AND. ILEADCB .EQ. ILEADTOT ) THEN VALX = HPT(ILEADCB) VALY = HYR(ILEADCB) CALL HFILL( IOBS+34,VALX,VALY,1. ) ENDIF C 2-DIM HISTOGRAM TRANSVERSE MOMENTUM VS. FEYNMAN X IF ( DEBUG ) WRITE(MDEBUG,*) ' P_T VS. XF' IOBS = 2700 DO I = 1, NNI VALX = HPT(I) VALY = HXF(I) IT = MIN( HIT(I), 175 ) DO IL = 1, 5 IC = PARCLA(IL,IT) IF ( IC .NE. 0 ) THEN CALL HFILL( IOBS+IC,VALX,VALY,1. ) ENDIF ENDDO ENDDO IF ( ILEAD .GT. 0 .AND. ILEAD .EQ. ILEADTOT ) THEN VALX = HPT(ILEAD) VALY = HXF(ILEAD) CALL HFILL( IOBS+28,VALX,VALY,1. ) ENDIF IF ( ILEADPI .GT. 0 .AND. ILEADPI .EQ. ILEADTOT ) THEN VALX = HPT(ILEADPI) VALY = HXF(ILEADPI) CALL HFILL( IOBS+29,VALX,VALY,1. ) ENDIF C LEADING HADRON IF ( ILEADHAD .GT. 0 .AND. ILEADHAD .EQ. ILEADTOT ) THEN VALX = HPT(ILEADHAD) VALY = HXF(ILEADHAD) CALL HFILL( IOBS+32,VALX,VALY,1. ) ENDIF C LEADING CHARMED MESON IF ( ILEADCM .GT. 0 .AND. ILEADCM .EQ. ILEADTOT ) THEN VALX = HPT(ILEADCM) VALY = HXF(ILEADCM) CALL HFILL( IOBS+33,VALX,VALY,1. ) ENDIF C LEADING CHARMED BARYON IF ( ILEADCB .GT. 0 .AND. ILEADCB .EQ. ILEADTOT ) THEN VALX = HPT(ILEADCB) VALY = HXF(ILEADCB) CALL HFILL( IOBS+34,VALX,VALY,1. ) ENDIF C MORE PLOTS CAN BE ADDED HERE ... DON''t FORGET TO INCREASE C "NOBS" AND CHANGE ID OF HISTOGRAMS C LAST ONE SHOULD ALWAYS BE "IOBS=NOBS*100" AND PREVIOUS C "IOBS=(NOBS-1)*100". "IOBS=NOBS-2", ETC ... C END OF HISTOGRAMS FOR ALL PARTICLES C----------------------------------------------------------------------- C NOW HISTOGRAMS PER EVENT C MULTIPLICITY DISTRIBUTION IF ( DEBUG ) WRITE(MDEBUG,*) ' MULTIPLICITY' IOBS = 700 DO I = 1, NCLASS VAL = MCLA(I) IF (VAL .GE. 19200.) THEN WRITE(MONIOU,*) 'HISFIL: CLASS=',I,' MCLA(I)=',MCLA(I), * ' > 19200' VAL = 19200. ENDIF CALL HFILL( IOBS+I,VAL,0.,1. ) ENDDO C GET THE TOTAL ENERGY ENLSUM = INEL(1) IF ( DEBUG ) THEN ECMEKK = SQRT( ECMEFF**2 + PTOT0**2 ) WRITE(MDEBUG,*) 'HISFIL: E00,ECMEFF,ENLSUM=',E00,ECMEKK,ENLSUM ENDIF c$$$C MULTIPLICITY VS AVERGAGE ELASTICITY c$$$ IOBS = 2800 c$$$ if(enlsum.gt.0d0)then c$$$ DO I = 1, NCLASS c$$$ VALY = MCLA(I) c$$$ VALX = INEL(I)/ENLSUM c$$$ IF (VALY .GE. 19200.) THEN c$$$ WRITE(MONIOU,*) 'HISFIL: CLASS=',I,' MCLA(I)=',MCLA(I), c$$$ * ' > 19200' c$$$ VALY = 19200. c$$$ ENDIF c$$$ CALL HFILL( IOBS+I,VALX,VALY,1. ) c$$$ ENDDO c$$$ endif C MULTIPLICITY **2 DISTRIBUTION IF ( DEBUG ) WRITE(MDEBUG,*) ' N**2' IOBS = 800 DO I = 1, NCLASS VAL = REAL(MCLA(I))**2 CALL HFILL( IOBS+I,VAL,0.,1. ) ENDDO C MULTIPLICITY **3 DISTRIBUTION IF ( DEBUG ) WRITE(MDEBUG,*) ' N**3' IOBS = 900 DO I = 1, NCLASS VAL = REAL(MCLA(I))**3 CALL HFILL( IOBS+I,VAL,0.,1. ) ENDDO C MULTIPLICITY **4 DISTRIBUTION IF ( DEBUG ) WRITE(MDEBUG,*) ' N**4' IOBS = 1000 DO I = 1, NCLASS VAL = REAL(MCLA(I))**4 CALL HFILL( IOBS+I,VAL,0.,1. ) ENDDO C MULTIPLICITY **5 DISTRIBUTION IF ( DEBUG ) WRITE(MDEBUG,*) ' N**5' IOBS = 1100 DO I = 1, NCLASS VAL = REAL(MCLA(I))**5 CALL HFILL( IOBS+I,VAL,0.,1. ) ENDDO C AVERAGE PT DISTRIBUTION IF ( DEBUG ) WRITE(MDEBUG,*) ' AVERAGE PT' IOBS = 1200 DO I = 1, NCLASS IF ( MCLA(I) .GT. 0 ) THEN VAL = PTAV(I)/MCLA(I) CALL HFILL( IOBS+I,VAL,0.,REAL(MCLA(I)) ) ENDIF ENDDO C AVERAGE PT**2 DISTRIBUTION IF ( DEBUG ) WRITE(MDEBUG,*) ' AVERAGE PT**2' IOBS = 1300 DO I = 1, NCLASS IF ( MCLA(I) .GT. 0 ) THEN VAL = PT2AV(I)/MCLA(I) CALL HFILL( IOBS+I,VAL,0.,REAL(MCLA(I)) ) ENDIF ENDDO C AVERAGE PL DISTRIBUTION IF ( DEBUG ) WRITE(MDEBUG,*) ' AVERAGE PL' IOBS = 1400 DO I = 1, NCLASS IF ( MCLA(I) .GT. 0 ) THEN VAL = PLAV(I)/MCLA(I) CALL HFILL( IOBS+I,VAL,0.,REAL(MCLA(I)) ) ENDIF ENDDO C AVERAGE XF DISTRIBUTION IF ( DEBUG ) WRITE(MDEBUG,*) ' AVERAGE XF' IOBS = 1500 DO I = 1, NCLASS IF ( MCLA(I) .GT. 0 ) THEN VAL = XFAV(I)/MCLA(I) CALL HFILL( IOBS+I,VAL,0.,REAL(MCLA(I)) ) ENDIF ENDDO C AVERAGE log10(xf) DISTRIBUTION IF ( DEBUG ) WRITE(MDEBUG,*) ' AVERAGE LOG10(XF)' IOBS = 2100 DO I = 1, NCLASS IF ( MCLA(I) .GT. 0 ) THEN VAL = XFLAV(I)/MCLA(I) CALL HFILL( IOBS+I,VAL,0.,REAL(MCLA(I)) ) ENDIF ENDDO C AVERAGE RAPIDITY DISTRIBUTION IF ( DEBUG ) WRITE(MDEBUG,*) ' AVERAGE RAPIDITY' IOBS = 1600 DO I = 1, NCLASS IF ( MCLA(I) .GT. 0 ) THEN VAL = RAPAV(I)/MCLA(I) CALL HFILL( IOBS+I,VAL,0.,REAL(MCLA(I)) ) ENDIF ENDDO C AVERAGE PSEUDO RAPIDITY DISTRIBUTION IF ( DEBUG ) WRITE(MDEBUG,*) ' AVERAGE PSEUDORAPIDITY' IOBS = 1700 DO I = 1, NCLASS IF ( MCLA(I) .GT. 0 ) THEN VAL = PRAPAV(I)/MCLA(I) CALL HFILL( IOBS+I,VAL,0.,REAL(MCLA(I)) ) ENDIF ENDDO C CENTRAL PSEUDO RAPIDITY DENSITY DISTRIBUTION IF ( DEBUG ) WRITE(MDEBUG,*) ' CENTRAL PSEUDORAPIDITY DENSITY' IOBS = 1800 DO I = 1, NCLASS IF ( MCLA(I) .GT. 0 ) THEN VAL = CRD(I)/2.D0 CALL HFILL( IOBS+I,VAL,0.,1. ) ENDIF ENDDO C GET THE TOTAL ENERGY ENLSUM = INEL(1) IF ( DEBUG ) THEN ECMEKK = SQRT( ECMEFF**2 + PTOT0**2 ) WRITE(MDEBUG,*) 'HISFIL: E00,ECMEFF,ENLSUM=',E00,ECMEKK,ENLSUM ENDIF C INELASTICITY IF ( DEBUG ) WRITE(MDEBUG,*) ' INELASTICITY' IOBS = 1900 IF ( ENLSUM .GT. 0.D0 ) THEN DO I = 1, NCLASS VAL = INEL(I)/ENLSUM CALL HFILL( IOBS+I,VAL,0.,1. ) ENDDO ENDIF c$$$C LEADING PARTICLE LOG10(ENERGY) c$$$ IF ( DEBUG ) WRITE(MDEBUG,*) ' LE' c$$$ IOBS = 2800 c$$$ VAL = LOG10(INEL(35)) c$$$ IF ( VAL .NE. 0 ) CALL HFILL( IOBS+1,VAL,0.,1. ) IF ( DEBUG ) WRITE(MDEBUG,*) 'HISFIL: END' RETURN END *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE HISINI C----------------------------------------------------------------------- C HIS(TOGRAM) INI(TIALIZATION) C C INITIALIZATION OF THE HISTOGRAMMING FOR TEST OF THE INTERACTION MODEL C OF CORSIKA C THIS SUBROUTINE IS CALLED FROM START. C----------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) #define __PAMINC__ #define __PRIMSPINC__ #define __TSTINTINC__ #define __RUNPARINC__ #include "corsika.h" REAL HLI(3,NOBS),HXL,HXU,HYL,HYU CHARACTER*20 CLASS(0:NCLASS) CHARACTER*80 HT CHARACTER*25 LSTOUT CHARACTER*12 OBS(NOBS) SAVE C CHANGE NUMBERS HERE ONLY IF MEMORY IS NOT BIG ENOUGH (ERROR MESSAGE C WHEN RUNNING CORSIKA) COMMON /PAWC/ HMEMOR( 1990000 ) DATA LIMIT / 1990000 / DATA LSTOUT / 'lstoutdataset' / C PARTICLE CLASSES DATA CLASS / ' ', * 'ALL ', 'CHARGED ', * 'NEUTRAL ', 'PI + ', * 'PI - ', 'PI 0 ', * 'K + ', 'K - ', * 'K 0 L ', 'K 0 S ', * 'PROTONS ', 'NEUTRONS ', * 'ANTI P ', 'ANTI N ', * 'GAMMAS ', 'HYPERONS ', * 'ETAS ', 'RHOS ', * 'DELTAS ', 'K * ', * 'NUCLEI ', 'CHARGED PI ', * 'ALL K ', 'BARYONS ', * 'ANTI BARY. ', 'ALL BARYO. ', * 'CH. MESONS ', 'HIGH BARY ', * 'HIGH MESON ', 'CHARM.MES. ', * 'CHARM.BAR. ', 'HIGH HADR ', * 'HIGH CHRM. MESON ', 'HIGH CHRM. BARYON ', * 'HIGH ALL '/ C HISTOGRAMS WITH QUANTITIES PER PARTICLE C OBSERVABLES DATA OBS / * 'PT ', 'PT**2 ', '|PL| ', * 'XF ', 'RAPIDITY ', 'PS.RAP. ', C HISTOGRAMS WITH QUANTITIES PER EVENT * 'N ', 'N**2 ', 'N**3 ', * 'N**4 ', 'N**5 ', ' ', * ' ', '<|PL|> ', ' ', * ' ', ' ', 'PS.RAP.DENS.', * 'INELASTICITY', C ADDITIONAL HISTOGRAMS * 'LOG10(XF) ', ' ', * 'RAP.ENER. ', 'PS.RAP.ENER.', 'XF_CMS ', * 'P_TOT/PBEAM ','P_T VS. Y ','P_T VS. XF ' / C HISTOGRAM LIMITS (LOWER, UPPER LIMIT, #BINS) DATA HLI / * 0.,50., 1000., 0.,50., 1000., 0.,50., 100., * 0.,1.01, 101., -15.0,15.0,200., -15.0,15.0,200., C TO GET PARTICLE NUMBERS CORRECTLY ENLARGE HISTO''S 701...729 * 0.,19200.,19200., 0.,4.E4, 100., 0.,8.E6,100., * 0.,16.E8,100., 0.,32.E10,100., 0.,50., 1000., * 0.,50., 1000., 0.,25., 100., 0.,1.01, 101., * -15.0,15.0,200., -15.0,15.0,200., 0.,1.E2,100., * 0.,1.01,101., * -7.,0.05,141., -7.,0.05,141., * -15.0,15.0,200., -15.0,15.0,200., -1.,1.,100. , * 0., 1.01, 101. , 0., 0., 0., 0., 0., 0. / C----------------------------------------------------------------------- C INITIALIZE HBOOK CALL HLIMIT( LIMIT ) ISHWW = 0 C PRINT INFORMATION WRITE(MONIOU,410) 410 FORMAT(/,' DECAYING PARTICLES',/, * ' ==================') IF ( LPI0 ) THEN WRITE(MONIOU,*) ' PI 0 ARE DECAYING' ELSE WRITE(MONIOU,*) ' PI 0 ARE KEPT STABLE' ENDIF IF ( LETA ) THEN WRITE(MONIOU,*) ' ETAS ARE DECAYING' ELSE WRITE(MONIOU,*) ' ETAS ARE KEPT STABLE' ENDIF IF ( LHYP ) THEN WRITE(MONIOU,*) ' HYPERONS ARE DECAYING' ELSE WRITE(MONIOU,*) ' HYPERONS ARE KEPT STABLE' ENDIF IF ( LK0S ) THEN WRITE(MONIOU,*) ' K0S ARE DECAYING' ELSE WRITE(MONIOU,*) ' K0S ARE KEPT STABLE' ENDIF WRITE(MONIOU,411) 411 FORMAT(/,' SPECTATORS',/, * ' ==========') IF ( LSPEC ) THEN WRITE(MONIOU,*) ' SPECTATORS ARE PLOTTED' ELSE WRITE(MONIOU,*) ' SPECTATORS ARE NOT PLOTTED' ENDIF WRITE(MONIOU,10) 10 FORMAT(/,' OBSERVABLES TO BE PLOTTET AND HISTOGRAM LIMITS',/, * ' ==============================================',/, * ' NO OBSERVABLE LOW EDGE', * ' HIGH EDGE BINS',/) DO I = 1, NOBS WRITE(MONIOU,11) I,OBS(I),(HLI(K,I),K=1,3) 11 FORMAT(' ',I2,' ',A12,' ',1P,3E15.2 ) ENDDO WRITE(MONIOU,12) 12 FORMAT(/,' PARTICLE CLASSES TO BE PLOTTET',/, * ' ==============================',/, * ' NO CLASS ',/) DO I = 1, NCLASS WRITE(MONIOU,13) I,CLASS(I) 13 FORMAT(' ',I2,' ',A21) ENDDO WRITE(MONIOU,14) 14 FORMAT(/,' PARTICLES BELONGING TO WHICH CLASSES',/, * ' ====================================',/, * ' ID ATTRIBUTED TO CLASSES',/) DO I = 1, 175 IF ( PARCLA(1,I) .NE. 0 ) THEN WRITE(MONIOU,15) I,(CLASS(PARCLA(K,I)),K=5,1,-1) 15 FORMAT(' ',I3,' ',5(' ',A10)) ENDIF ENDDO C BOOK HISTOGRAMS IH = 1 HT(1:80) = 'particle codes' CALL HBOOK1( IH,HT,180,-4.5,175.5,0. ) IF ( DEBUG ) WRITE(MDEBUG,412) IH,HT 412 FORMAT(' HISINI:',I5,1X,A80) IH = 2 HT(1:80) = 'log10(abs(sum pt)) (in GeV)' CALL HBOOK1( IH,HT,100,-9.,1.,0. ) IF ( DEBUG ) WRITE(MDEBUG,412) IH,HT IH = 3 HT(1:80) = 'pl conservation mismatch (rel.)' CALL HBOOK1( IH,HT,100,-.05,.05,0. ) IF ( DEBUG ) WRITE(MDEBUG,412) IH,HT IH = 4 HT(1:80) = 'energy conservation mismatch (rel.)' CALL HBOOK1( IH,HT,100,-.05,.05,0. ) IF ( DEBUG ) WRITE(MDEBUG,412) IH,HT IH = 5 HT(1:80) = 'number of interacting projectile nucleons' CALL HBOOK1( IH,HT,100,-0.5,99.5,0. ) IF ( DEBUG ) WRITE(MDEBUG,412) IH,HT IH = 6 HT(1:80) = 'number of interacting target nucleons' CALL HBOOK1( IH,HT,100,-0.5,99.5,0. ) IF ( DEBUG ) WRITE(MDEBUG,412) IH,HT IH = 7 HT(1:80) = 'particle code of highest energy particle' CALL HBOOK1( IH,HT,200,-4.5,195.5,0. ) IF ( DEBUG ) WRITE(MDEBUG,412) IH,HT IH = 8 HT(1:80) = 'mass of fragments' CALL HBOOK1( IH,HT,80,-4.5,75.5,0. ) IF ( DEBUG ) WRITE(MDEBUG,412) IH,HT C 1-DIMENSIONAL HISTOGRAMS DO IOBS = 1, 25 C IF ( IOBS .EQ. 7 .OR. IOBS .EQ. 19 .OR. IOBS .EQ. 25 ) THEN DO ICLASS = 1, NCLASS IH = IOBS * 100 + ICLASS HT( 1:12) = OBS(IOBS) HT(13:17) = ' FOR ' HT(18:27) = CLASS(ICLASS) HT(28:80) = ' ' LI = NINT( HLI(3,IOBS) ) CALL HBOOK1( IH,HT,LI,HLI(1,IOBS),HLI(2,IOBS),0. ) IF ( DEBUG ) WRITE(MDEBUG,412) IH,HT ENDDO C CALCULATE THE BINWIDTH HILI(IOBS) = (HLI(2,IOBS)-HLI(1,IOBS)) / HLI(3,IOBS) C ENDIF ENDDO C TWO-DIMENSIONAL HISTOGRAM: P_T VERS. RAPIDITY DO ICLASS = 1, NCLASS IH = 26*100 + ICLASS HT( 1:12) = OBS(26) HT(13:17) = ' FOR ' HT(18:27) = CLASS(ICLASS) HT(28:80) = ' ' LX = 100 ! # of points in p_t HXL = 0. HXU = 5. LY = 100 ! # of points in y HYL = -10. HYU = +10. CALL HBOOK2( IH,HT,LX,HXL,HXU,LY,HYL,HYU,0. ) IF ( DEBUG ) WRITE(MDEBUG,412) IH,HT HILI(26) = (HXU-HXL)/FLOAT(LX) HILI(26) = HILI(26) * (HYU-HYL)/FLOAT(LY) ENDDO C TWO-DIMENSIONAL HISTOGRAM: P_T VERS. XF DO ICLASS = 1, NCLASS IH = (NOBS)*100 + ICLASS HT( 1:12) = OBS(NOBS) HT(13:17) = ' FOR ' HT(18:27) = CLASS(ICLASS) HT(28:80) = ' ' LX = 100 ! # of points in p_t HXL = 0. HXU = 5. LY = 100 ! # of points in x_f HYL = 0. HYU = +1. CALL HBOOK2( IH,HT,LX,HXL,HXU,LY,HYL,HYU,0. ) IF ( DEBUG ) WRITE(MDEBUG,412) IH,HT HILI(NOBS) = (HXU-HXL)/FLOAT(LX) HILI(NOBS) = HILI(NOBS) * (HYU-HYL)/FLOAT(LY) ENDDO c$$$C TWO-DIMENSIONAL HISTOGRAM: N VERS. ELAST c$$$ DO ICLASS = 1, NCLASS c$$$ IH = 28*100 + ICLASS c$$$ HT( 1:12) = OBS(28) c$$$ HT(13:17) = ' FOR ' c$$$ HT(18:27) = CLASS(ICLASS) c$$$ HT(28:80) = ' ' c$$$ LX = 50 ! # of points in p_t c$$$ HXL = 0. c$$$ HXU = 1. c$$$ LY = 1000 ! # of points in x_f c$$$ HYL = 0. c$$$ HYU = +1000. c$$$ CALL HBOOK2( IH,HT,LX,HXL,HXU,LY,HYL,HYU,0. ) c$$$ IF ( DEBUG ) WRITE(MDEBUG,412) IH,HT c$$$ HILI(28) = (HXU-HXL)/FLOAT(LX) c$$$ HILI(28) = HILI(28) * (HYU-HYL)/FLOAT(LY) c$$$ ENDDO CALL HIDOPT( 0,'STAT' ) C FORM DATASET NAME AND OPEN OUTPUT DATASET WRITE(LSTOUT(10:13),'(I4)') ITPRO WRITE(LSTOUT(15:16),'(I2)') ITTAR C LAB ENERGY FOR DSN NAME IEX = INT( LOG10(LLIMIT) ) IF ( IEX .GE. 2 ) THEN IEX = IEX - 2 ELSEIF ( IEX .EQ. 1 ) THEN IEX = IEX - 1 ENDIF IMA = NINT( LLIMIT / 10**IEX ) WRITE(LSTOUT(19:23),555) IMA,IEX 555 FORMAT(I3,'E',I1) C MARK WHETHER DIFFRACTIVE IS ALLOWED OR NOT IF ( NDIF .EQ. 1 ) THEN LSTOUT(24:25) = 'ND' ELSEIF ( NDIF .EQ. 2 ) THEN LSTOUT(24:25) = 'SD' ELSE LSTOUT(24:25) = 'MD' ENDIF C AVOID BLANKS DO I = 10, 25 IF ( LSTOUT(I:I) .EQ. ' ' ) LSTOUT(I:I) = '0' ENDDO CCC OPEN(UNIT=33,FORM='FORMATTED',STATUS='UNKNOWN',FILE=LSTOUT) CCC WRITE(MONIOU,*) 'HISINI: OPENED EVENT OUTPUT ON DSN ',LSTOUT RETURN END *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE HISOUT C----------------------------------------------------------------------- C HIS(TOGRAM) OUT(PUT) C C OUTPUT OF THE HISTOGRAMS ON DISK C THIS SUBROUTINE IS CALLED FROM AAMAIN. C----------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) #define __PRIMSPINC__ #define __RUNPARINC__ #define __TSTINTINC__ #include "corsika.h" REAL C1 INTEGER LREC,IDCHAR #if __BYTERECL__ INTEGER ISTAT #endif CHARACTER*50 SUBDIR CHARACTER*50 SUBDIR2 LOGICAL HEXIST SAVE C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'HISOUT:' C FOR ALL NORMALIZATIONS THE NUMBER OF ENTRIES BECOMES THE DOUBLE C OF THE CORRECT VALUE BY THE USAGE OF THE HBOOK ROUTINE HOPERA C C NORMALIZE: C PARTICLE CODE HISTOGRAM (DIVIDE BY NUMBER OF ACCEPTED EVENTS) C PT AND ENERGY CONSERVATION HISTOGRAMS C PARTICIPANTS HISTOGRAMS DO ID = 1, 7 C1 = 1.D0 / ISHWW CALL HOPERA( ID,'+',ID,ID,C1,0. ) ENDDO C NORMALIZE ALL OTHER HISTOGRAMS C (DIVIDE BY BINWIDTH AND NUMBER OF ACCEPTED EVENTS) DO IOBS = 1, 25 C IF ( IOBS .EQ. 7 .OR. IOBS .EQ. 19 .OR. IOBS .EQ. 25 ) THEN C1 = 1.D0 / ( HILI(IOBS)*ISHWW ) DO ICL = 1, NCLASS ID = IOBS*100 + ICL CALL HOPERA( ID,'+',ID,ID,C1,0. ) ENDDO C ENDIF ENDDO C NORMALIZE THE 2-DIM. HISTOGRAMM (P_T VS. Y) C1 = 1.D0 / (HILI(26)*ISHWW ) DO ICL = 1, NCLASS ID = (26)*100 + ICL CALL HOPERA( ID,'+',ID,ID,C1,0. ) ENDDO C NORMALIZE THE 2-DIM. HISTOGRAMM (P_T VS. XF) C1 = 1.D0 / (HILI(NOBS)*ISHWW ) DO ICL = 1, NCLASS ID = NOBS*100 + ICL CALL HOPERA( ID,'+',ID,ID,C1,0. ) ENDDO c$$$C NORMALIZE THE 2-DIM. HISTOGRAMM (N VS. ELAST) c$$$ C1 = 1.D0 / (HILI(28)*ISHWW ) c$$$ DO ICL = 1, NCLASS c$$$ ID = 28*100 + ICL c$$$ CALL HOPERA( ID,'+',ID,ID,C1,0. ) c$$$ ENDDO C CHOSE SUBDIRECTORY DEPENDING ON WHETHER DIFFRACTIVE IS ALLOWED C OR NOT IF ( NDIF .EQ. 0 ) THEN SUBDIR2 = 'mixed' ELSEIF ( NDIF .EQ. 1 ) THEN SUBDIR2 = 'nondiffractive' ELSE SUBDIR2 = 'diffractive' ENDIF C FORM SUBDIRECTORY''S NAME SUBDIR = 'P0000T00E00000' WRITE(SUBDIR( 2: 5),'(I4)') ITPRO WRITE(SUBDIR( 7: 8),'(I2)') ITTAR IEX = INT( LOG10(LLIMIT) ) IF ( IEX .GE. 2 ) THEN IEX = IEX - 2 ELSEIF ( IEX .EQ. 1 ) THEN IEX = IEX - 1 ENDIF IMA = NINT( LLIMIT / 10**IEX ) WRITE(SUBDIR(10:14),555) IMA,IEX 555 FORMAT(I3,'E',I1) C AVOID BLANKS DO I = 2, 14 IF ( SUBDIR(I:I) .EQ. ' ' ) SUBDIR(I:I) = '0' ENDDO C FORM COMPLETE DS NAME IB = INDEX(HISTDS,' ') HISTDS(IB:IB) = '.' HISTDS(IB+1:IB+14) = SUBDIR(1:14) IB = INDEX(HISTDS,' ') HISTDS(IB:IB) = '.' HISTDS(IB+1:IB+14) = SUBDIR2 IB = INDEX(HISTDS,' ') WRITE( HISTDS(IB:IB+5),'(I6)') NRRUN DO I = IB, IB+5 IF ( HISTDS(I:I) .EQ. ' ' ) HISTDS(I:I) = '0' ENDDO HISTDS(IB+6:120) = '.hbook' C CONVERT HISTDS FROM UPPER CASE CHARACTERS TO LOWER CASE (HAS USED BY PAW) DO I = 1, 120 CALL UPLOW( HISTDS(I:I),IDCHAR ) ENDDO WRITE(MONIOU,100) HISTDS 100 FORMAT(/,' HISOUT: HISTOGRAM DATASET IS',/, * ' HISTDS = ',A120) IF ( INDEX(HISTDS,'DUMMY') .NE. 0 ) THEN WRITE(MONIOU,*) 'HISOUT: NO HISTOGRAMS STORED' RETURN ENDIF C DATASET FOR HBOOK HISTOGRAM OUTPUT C DATASET MUST BE PREFORMATTED #if __BYTERECL__ LREC = 4*1024 c THIS FILE IS OPEND IN HROPEN (with lower case letters) c OPEN(UNIT=LUNPLT,FORM='UNFORMATTED',RECL=4*1024,ACCESS='DIRECT', c * STATUS='UNKNOWN',FILE=HISTDS) WRITE(MONIOU,10) HISTDS 10 FORMAT(' HISOUT: HISTOGRAMS WILL BE WRITTEN TO ',/,9X,A79) CALL HROPEN( LUNPLT,'TOP',HISTDS,'N',LREC,ISTAT ) WRITE(MONIOU,*) 'ISTAT = ',ISTAT #else C WITH DEC FORTRAN COMPILER RECL IS USUALLY IN WORDS LREC = 1024 OPEN(UNIT=LUNPLT,FORM='UNFORMATTED',RECL=1024,ACCESS='DIRECT', * STATUS='UNKNOWN',FILE=HISTDS) CALL HRFILE( LUNPLT,'TOP','N' ) #endif WRITE(MONIOU,*) 'HISTOGRAMS ARE WRITTEN TO ',HISTDS C STORE HISTOGRAMS DO ID = 1, 10 IF ( HEXIST(ID) ) THEN CALL HNOENT( ID,NENT ) IF ( NENT .GT. 0 ) THEN CALL HROUT( ID,ICYCLE,' ' ) ENDIF ENDIF ENDDO DO IOBS = 1, NOBS DO ICL = 1, NCLASS ID = IOBS*100 + ICL IF ( HEXIST(ID) ) THEN CALL HNOENT( ID,NENT ) IF ( NENT .GT. 0 ) THEN CALL HROUT( ID,ICYCLE,' ' ) ENDIF ENDIF ENDDO ENDDO C PRINT STATISTICS CALL RZSTAT( '//TOP',10,' ' ) CALL HREND( 'TOP' ) CLOSE( UNIT=LUNPLT ) IF ( ISTAT .EQ. 0 ) THEN WRITE(MONIOU,11) HISTDS 11 FORMAT(/,' HISOUT: HISTOGRAMS ARE WRITTEN TO ',/,9X,A79) ELSE WRITE(MONIOU,*) 'HISOUT: PROBLEMS TO WRITE ON FILE ',HISTDS ENDIF C PRINT WARNING RESPECTING THE CORRECT NUMBER OF ENTRIES WRITE(MONIOU,*) * 'ATTENTION: ALL LISTED ENTRIES MUST BE DIVIDED BY 2' WRITE(MONIOU,*) * '==================================================' C PRINT ONLY FILLED HISTOGRAMS CALL HINDEX RETURN END *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE HISPRP C----------------------------------------------------------------------- C HIS(TOGRAM) PR(E)P(ARATION) C GATHERS PARTICLES OF ONE COLLISION C THIS SUBROUTINE IS CALLED FROM AAMAIN. C----------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) #define __CONSTAINC__ #define __PAMINC__ #define __PARPARINC__ #define __RUNPARINC__ #define __TSTINTINC__ #include "corsika.h" SAVE C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'HISPRP: ENTERING' C COPY CURPAR AND DERIVED QUANTITIES INTO WORKING ARRAYS IF ( NNI .EQ. 1 ) MM = 1 MM = MM + 1 IF ( NNI .GE. MAXPAR ) THEN WRITE(MONIOU,*) 'HISPRP: TOO MANY PARTICLES FROM STACK',MM WRITE(MONIOU,*) 'TSTACK: INCREASE PARAMETER MAXPAR TO ', * ' CIRCUMVENT THIS PROBLEM.' STOP * RETURN ENDIF NNI = NNI + 1 C CALCULATE QUANTITIES IN THE LAB SYSTEM CC WRITE(*,*) '1',CURPAR(0),NNI HIT(NNI) = NINT( CURPAR(0) ) CC WRITE(*,*) '2',HIT(NNI) HMA(NNI) = PAMA(HIT(NNI)) CC WRITE(*,*) '3',HMA(NNI) IF ( HIT(NNI) .NE. 1 ) THEN HENL(NNI) = HMA(NNI) * CURPAR(1) ELSE HENL(NNI) = CURPAR(1) ENDIF CC WRITE(*,*) '4',HENL(NNI) HCT(NNI) = CURPAR(2) CC WRITE(*,*) '5',HCT(NNI) HTH(NNI) = ACOS( HCT(NNI) ) CC WRITE(*,*) '6',HTH(NNI) HST(NNI) = SQRT( (1.D0-HCT(NNI))*(1.D0+HCT(NNI)) ) CC WRITE(*,*) '7',HST(NNI) C HPT2(NNI) = HPP(NNI)**2 * (1.D0-HCT(NNI)**2) C TO GET CORRECT TRANSVERSE MOMENTUM ALSO AT HIGHEST ENERGIES: HPT2(NNI) = CURPAR(17)**2 CC WRITE(*,*) '10',HPT2(NNI) HPT(NNI) = SQRT( HPT2(NNI) ) HPT(NNI) = CURPAR(17) CC WRITE(*,*) '11',HPT(NNI) HPP(NNI) = SQRT( (HENL(NNI)-HMA(NNI))*(HENL(NNI)+HMA(NNI)) ) CC WRITE(*,*) '8',HPP(NNI) HPL(NNI) = SQRT( MAX( 0.D0, * (HPP(NNI)-HPT(NNI))*(HPP(NNI)+HPT(NNI)) ) ) AUXIL = HPP(NNI) * HCT(NNI) IF ( AUXIL .LT. 0.D0 ) HPL(NNI) = -HPL(NNI) CC WRITE(*,*) '9',HPL(NNI) IF ( CURPAR(4) .NE. 0.D0 .OR. CURPAR(3) .NE. 0.D0 ) THEN HPHI(NNI) = ATAN2( CURPAR(4), CURPAR(3) ) ELSE HPHI(NNI) = 0.D0 ENDIF CC WRITE(*,*) '12',HPHI(NNI) HPX(NNI) = HPT(NNI) * COS( HPHI(NNI) ) CC WRITE(*,*) '13',HPX(NNI) HPY(NNI) = HPT(NNI) * SIN( HPHI(NNI) ) CC WRITE(*,*) '14',HPY(NNI) IF ( DEBUG ) THEN WRITE(MDEBUG,100) NNI,HIT(NNI),HENL(NNI),HTH(NNI), * HPP(NNI),HPL(NNI),HPT(NNI),HPX(NNI),HPY(NNI), * HPT2(NNI),HXF(NNI),HYR(NNI),HPR(NNI),HPHI(NNI) 100 FORMAT(' HISPRP:',I4,I5,1P,12E10.3) ENDIF C MAY BE WE HAVE TO TRANSFORM BACK WHAT WE DID IN TSTACK2? IF ( FLOR ) THEN ELORP = GACM * ( HENL(NNI) + BECM * HPL(NNI) ) PLLORP = GACM * ( BECM * HENL(NNI) + HPL(NNI) ) IF ( DEBUG ) WRITE(*,*) ELORP,PLLORP,HMA(NNI) HENL(NNI) = ELORP HPL(NNI) = PLLORP CC HPP(NNI) = SQRT( HPL(NNI)**2+HPT2(NNI) ) HPP(NNI) = SQRT( MAX( 0.D0, * (HENL(NNI)-HMA(NNI))*(HENL(NNI)+HMA(NNI)) ) ) IF ( DEBUG ) WRITE(*,*) HPP(NNI),HPL(NNI) IF ( HPP(NNI) .EQ. 0.D0 ) THEN HCT(NNI) = 1.D0 ELSE HCT(NNI) = MAX(-1.D0,MIN(1.D0,HPL(NNI)/HPP(NNI))) ENDIF IF ( DEBUG ) WRITE(*,*) HCT(NNI) HTH(NNI) = ACOS( HCT(NNI) ) IF ( DEBUG ) WRITE(*,*) HTH(NNI) HST(NNI) = SQRT( (1.D0 - HCT(NNI))*(1.D0 + HCT(NNI)) ) IF ( DEBUG ) WRITE(*,*) HST(NNI) ENDIF IF ( DEBUG ) THEN WRITE(MDEBUG,100) NNI,HIT(NNI),HENL(NNI),HTH(NNI), * HPP(NNI),HPL(NNI),HPT(NNI),HPX(NNI),HPY(NNI), * HPT2(NNI),HXF(NNI),HYR(NNI),HPR(NNI),HPHI(NNI) ENDIF C THESE VARIABLES ARE FILLED IN THE LAB SYSTEM HXF(NNI) = ABS(HPL(NNI)/PTOT0N) HXFL(NNI) = LOG10(MAX(HXF(NNI),1.D-12)) IF ( DEBUG ) WRITE(*,*) HXFL(NNI) C CALCULATE RAPIDITY AND PSEUDRAPIDITY IF ( HPT(NNI) .EQ. 0.D0 ) THEN IF ( HPL(NNI) .GT. 0.D0 ) THEN HPR(NNI) = 23.99D0 ELSEIF ( HPL(NNI) .LT. 0.D0 ) THEN HPR(NNI) = -23.99D0 ELSE HPR(NNI) = 0.D0 ENDIF ELSE IF ( DEBUG ) WRITE(*,*) HENL(NNI),HMA(NNI),HPP(NNI),HPL(NNI), * HPT(NNI) IF ( HPP(NNI) .LE. -HPL(NNI) ) THEN HPR(NNI) = -23.99D0 ELSE IF ( HPL(NNI) .GE. 0.D0 ) THEN HPR(NNI) = LOG( (HPP(NNI)+HPL(NNI))/HPT(NNI) ) ELSE HPR(NNI) = -LOG( HPT(NNI)/(HPP(NNI)-HPL(NNI)) ) ENDIF ENDIF ENDIF IF ( HMA(NNI) .EQ. 0.D0 ) THEN HYR(NNI) = HPR(NNI) ELSE IF ( HENL(NNI) .LE. -HPL(NNI) ) THEN HYR(NNI) = -23.99D0 ELSE IF ( HPL(NNI) .GE. 0.D0 ) THEN HYR(NNI) = LOG( (HENL(NNI)+HPL(NNI)) * /SQRT( HPT2(NNI)+HMA(NNI)**2 ) ) ELSE HYR(NNI) = -LOG( SQRT( HPT2(NNI)+HMA(NNI)**2 ) * /(HEN(NNI)-HPL(NNI)) ) ENDIF ENDIF ENDIF IF ( DEBUG ) THEN WRITE(MDEBUG,100) NNI,HIT(NNI),HENL(NNI),HTH(NNI), * HPP(NNI),HPL(NNI),HPT(NNI),HPX(NNI),HPY(NNI), * HPT2(NNI),HXF(NNI),HYR(NNI),HPR(NNI),HPHI(NNI) ENDIF RETURN END *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE HISRES C----------------------------------------------------------------------- C HIS(TOGRAM) RES(ET) C C RESET HISTOGRAMMING FOR ONE EVENT C THIS SUBROUTINE IS CALLED FROM AAMAIN. C----------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) #define __RUNPARINC__ #define __TSTINTINC__ #include "corsika.h" SAVE C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'HISRES:' C RESET ALL COUNTERS FOR ONE EVENT NNI = 0 DO I = 1, NCLASS MCLA(I) = 0 PTAV(I) = 0.D0 PT2AV(I) = 0.D0 PLAV(I) = 0.D0 XFAV(I) = 0.D0 XFLAV(I) = 0.D0 RAPAV(I) = 0.D0 PRAPAV(I) = 0.D0 CRD(I) = 0.D0 INEL(I) = 0.D0 ENDDO RETURN END *-- Author : The CORSIKA development group 21/04/1994 C======================================================================= SUBROUTINE HISTRA( FLAG ) C----------------------------------------------------------------------- C HIS(TOGRAM) TRA(NSFORMATION) C C LORENTZ TRANSFORM QUANTITIES FROM LAB INTO THE DESIRED SYSTEM C (TRANSFORMATION ALONG THE VERTICAL DIRECTION) C THIS SUBROUTINE IS CALLED FROM AAMAIN. C ARGUMENT : C FKAG = INDICATING IF TRANSFORMATION WAS SUCCESSFUL C----------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) #define __CONSTAINC__ #define __INTERINC__ #define __NPARTIINC__ #define __PAMINC__ #define __PARPARINC__ #define __PARPAEINC__ #define __RESTINC__ #define __RUNPARINC__ #define __TSTINTINC__ #if __URQMD__ #define __URQINTESTINC__ #endif #include "corsika.h" INTEGER III1,III2,IPOS,INEG LOGICAL FLAG SAVE C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,*) 'HISTRA: ENTERING' FLAG = .FALSE. C CHECK TRIGGER CONDITION (ONLY FOR PROTON OR NEUTRON TARGET) IF ( NTRIG .NE. 0 ) THEN III1 = 0 III2 = 0 IPOS = 0 INEG = 0 NSDIFF = 0 DO 60 I = 1, NNI C LORENTZ TRANSFORMATION ALONG Z AXIS C TRANSFORM ENERGY AND MOMENTA (PX,PY STAY UNCHANGED) HPLTRG(I) = GACM * ((-BECM) * HENL(I) + HPL(I) ) PPP = SQRT( HPX(I)**2 + HPY(I)**2 + HPLTRG(I)**2 ) IF (PPP .GT. ABS(HPLTRG(I)) ) THEN YYY = 0.5D0 * LOG( (PPP+HPLTRG(I))/(PPP-HPLTRG(I)) ) ELSE YYY = SIGN(100.D0, HPLTRG(I)) ENDIF C PARTICLE MUST BE CHARGED TO MAKE A TRIGGER IF ( HIT(I) .NE. 8 .AND. HIT(I) .NE. 9 .AND. * HIT(I) .NE. 11 .AND. HIT(I) .NE. 12 .AND. * HIT(I) .NE. 14 .AND. HIT(I) .NE. 15 .AND. * HIT(I) .NE. 19 .AND. HIT(I) .NE. 21 .AND. * HIT(I) .NE. 27 .AND. HIT(I) .NE. 29 .AND. * HIT(I) .NE. 23 .AND. HIT(I) .NE. 31 .AND. * HIT(I) .NE. 24 .AND. HIT(I) .NE. 32 .AND. * HIT(I) .NE.117 .AND. HIT(I) .NE.118 .AND. * HIT(I) .NE.120 .AND. HIT(I) .NE.121 .AND. * HIT(I) .NE.124 .AND. HIT(I) .NE.125 .AND. * HIT(I) .NE.127 .AND. HIT(I) .NE.128 .AND. * HIT(I) .NE.137 .AND. HIT(I) .NE.138 .AND. * HIT(I) .NE.140 .AND. HIT(I) .NE.141 .AND. * HIT(I) .NE.143 .AND. HIT(I) .NE.149 .AND. * HIT(I) .NE.150 .AND. HIT(I) .NE.152 .AND. * HIT(I) .NE.153 .AND. HIT(I) .NE.155 .AND. * HIT(I) .NE.161 .AND. HIT(I) .NE.162 .AND. * HIT(I) .NE.171 .AND. HIT(I) .NE.172 * ) GOTO 60 IF ( NTRIG .EQ. 1 ) THEN C TRIGGER CONDITIONS FOR UA5 IF ( YYY .GT. 2.0 .AND. YYY .LT. 5.6 ) III1 = 1 IF ( YYY .GT.-5.6 .AND. YYY .LT.-2.0 ) III2 = 1 ELSEIF ( NTRIG .EQ. 2 ) THEN C TRIGGER CONDITIONS FOR CDF IF ( YYY .GT. 3.2 .AND. YYY .LT. 5.9 ) III1 = 1 IF ( YYY .GT.-5.9 .AND. YYY .LT.-3.2 ) III2 = 1 IF ( YYY .GT. 0.0 .AND. YYY .LT. 3.0 ) IPOS = IPOS+1 IF ( YYY .GT.-3.0 .AND. YYY .LT. 0.0 ) INEG = INEG+1 ELSEIF ( NTRIG .EQ. 3 ) THEN C TRIGGER CONDITIONS FOR P238 (Harr et al.) C CORRESPONDING WITH -110mrad TO -27mrad AND +27mrad TO +110mrad * IF (YYY .GT. 2.899 .AND. YYY .LT. 4.305 ) III1 = 1 * IF (YYY .LT.-2.899 .AND. YYY .GT.-4.305 ) III2 = 1 C BUT PUBLISHED DATA ARE CORRECTED FOR FULL ETA RANGE ACCEPTANCE OF C TRIGGER, THEREFORE ENLARGE ETA RANGE UNTIL DIFFRACTION PEAK APPEARS IF (YYY .GT. 0.0 .AND. YYY .LT. 6.5 ) III1 = 1 IF (YYY .LT.-0.0 .AND. YYY .GT.-6.5 ) III2 = 1 ENDIF 60 CONTINUE IF ( NTRIG .EQ. 1 ) THEN C TRIGGER FOR UA5 TRUE? IF ( III1 .EQ. 1 .AND. III2 .EQ. 1 ) NSDIFF = 1 ELSEIF ( NTRIG .EQ. 2 ) THEN C TRIGGER FOR CDF TRUE? IF ( (III1 .EQ. 1 .AND. III2 .EQ. 1 ) .AND. * ((IPOS .NE. 0 .AND. INEG .NE. 0 ) .AND. * IPOS+INEG .GE. 4 )) NSDIFF = 1 ELSEIF ( NTRIG .EQ. 3 ) THEN C TRIGGER FOR P238 (Harr et al.) IF ( III1 .EQ. 1 .AND. III2 .EQ. 1 ) NSDIFF = 1 ENDIF C SKIP EVENTS WHICH DO NOT FULFILL THE TRIGGER REQUIREMENTS IF ( NSDIFF .EQ. 0 ) THEN IF ( DEBUG ) WRITE(MDEBUG,*) * 'EVENT NOT TRIGGERED, FORGET THIS EVENT' RETURN ENDIF ENDIF C WE DEMAND SECONDARY PARTICLE PRODUCTION, DISREGARDING NUCLEONS C FROM THE TARGET DESINTEGRATION ===> WE MUST HAVE AT MINIMUM C ONE SECONDARY THAT IS NO NUCLEUS AND NO NUCLEON AND NO GAMMA. DO I = 1, NNI IF ( HIT(I) .LT. 175 .AND. HIT(I) .GT. 0 .AND. * ( HIT(I) .NE. 13 .AND. HIT(I) .NE. 14 ) ) THEN C WE HAVE AT MINIMUM ONE PARTICLE FROM INELASTIC PRODUCTION INTERACTION GOTO 70 ENDIF ENDDO C DISABLE INELASTICITY CHECK GOTO 70 C WE HAVE NO INELASTICLLY PRODUCED PARTICLE, SKIP THE EVENT NOINT = NOINT + 1 NNI = 0 IF ( DEBUG ) WRITE(MDEBUG,*) * 'NO PRODUCED SECONDARY PARTICLE, FORGET THIS EVENT' RETURN 70 CONTINUE C RESET VARIABLES FOR ENERGY AND MOMENTUM BALANCE ENSUM = 0.D0 PXSUM = 0.D0 PYSUM = 0.D0 PZSUM = 0.D0 C SUM UP ENERGIES AND MOMENTA FOR ENERGY AND MOMENTUM BALANCE DO I = 1, NNI ENSUM = ENSUM + HENL(I) PXSUM = PXSUM + HPX(I) PYSUM = PYSUM + HPY(I) PZSUM = PZSUM + HPL(I) ENDDO PTSUM = SQRT( PXSUM**2 + PYSUM**2 ) IF ( DEBUG ) WRITE(MDEBUG,*) 'HISTRA: TAR,ITTAR=',TAR,ITTAR IF ( TAR .EQ. 1.D0 ) THEN ETARG = PAMA(14) ELSEIF ( TAR .EQ. 2.D0 ) THEN ETARG = PAMA(13) ELSEIF ( TAR .EQ. 14.D0 ) THEN ETARG = PAMA(1407) ELSEIF ( TAR .EQ. 16.D0 ) THEN ETARG = PAMA(1608) ELSEIF ( TAR .EQ. 40.D0 ) THEN ETARG = PAMA(4018) ELSEIF ( TAR .EQ. 12.D0 ) THEN ETARG = PAMA(1206) ELSEIF ( TAR .EQ. 9.D0 ) THEN ETARG = PAMA(904) ELSEIF ( TAR .EQ. 99.D0 ) THEN ETARG = 13.646D0 ELSE WRITE(MONIOU,*) 'HISTRA: ILLEGAL TARGET',TAR Cjok STOP ETARG = PAMA(1407) TAR = 14.D0 Cjok ENDIF IF ( DEBUG ) THEN WRITE(MDEBUG,*) 'HISTRA: PX,PY,PZ,E =',PXSUM,PYSUM,PZSUM,ENSUM WRITE(MDEBUG,*) ' P0,E0,ETARG =',PTOT0,E00,ETARG ENDIF PDIFF = (PZSUM-PTOT0)/PTOT0 EDIFF = (ENSUM-E00-ETARG)/(E00+ETARG) CALL HFILL( 2,SNGL(LOG10(MAX(PTSUM,1.D-15))),0.,1. ) CALL HFILL( 3,SNGL(PDIFF),0.,1. ) CALL HFILL( 4,SNGL(EDIFF),0.,1. ) IF ( DEBUG ) THEN WRITE(MDEBUG,*) ' PLDIFF,EDIFF =',PDIFF,EDIFF ENDIF CALL HFILL( 5,FLOAT(IWOUNP),0.,1. ) CALL HFILL( 6,FLOAT(IWOUNT),0.,1. ) C FIND AND COUNT THE SPECTATORS IN THE LIST IPSPEC = 0 ITSPEC = 0 IF ( DEBUG ) THEN WRITE(MDEBUG,*) 'E00PN =',E00PN WRITE(MDEBUG,*) 'FIND SPECTATORS:' ENDIF CC WRITE(*,*) 'E00PN =',E00PN DO IALT = 1, NNI CC WRITE(*,*) 'E00PN HENL=',E00PN,HENL(IALT) IF ( ( HIT(IALT) .EQ. 13 .OR. HIT(IALT) .EQ. 14 ) .AND. * (( HCT(IALT) .EQ. 1.D0 .AND. HPHI(IALT) .EQ. 0.D0 ) .OR. * ( HCT(IALT) .EQ.- 1.D0 .AND. HPHI(IALT) .EQ. 0.D0 ) .OR. #if __EPOS__ || __NEXUS__ * ( HCT(IALT) .EQ. 0.D0 .AND. HPHI(IALT) .EQ. 0.D0 ) .OR. #endif * ( HCT(IALT) .EQ. 1.D-4 .AND. HPHI(IALT) .EQ. 0.D0 )).AND. * ( HENL(IALT)/HMA(IALT) .LE. 1.002D0 .OR. * ABS(1.D0 - HENL(IALT)/E00PN) .LT. 2.D-3 ) ) THEN C SPECTATOR IF ( HENL(IALT)/HMA(IALT) .LE. 1.002D0 ) THEN C ELIMINATE TARGET SPECTATORS ONLY, IF TARGET IS NUCLEUS IF ( ITTAR .GT. 2 ) THEN ITSPEC = ITSPEC + 1 HSPEC(IALT) = -1 ELSE HSPEC(IALT) = 0 ENDIF ELSE C ELIMINATE PROJECTILE SPECTATORS ONLY, IF PROJECTILE IS NUCLEUS IF ( PRMPAR(0) .GE. 200.D0 ) THEN IPSPEC = IPSPEC + 1 HSPEC(IALT) = 1 ELSE HSPEC(IALT) = 0 ENDIF ENDIF ELSE HSPEC(IALT) = 0 ENDIF IF ( DEBUG ) THEN WRITE(MDEBUG,4567) IALT,HIT(IALT),HENL(IALT), * HCT(IALT),HPHI(IALT),HSPEC(IALT) 4567 FORMAT(' IALT=',I4,' ID=',I6,' E=',1P,1E10.3, * ' COST,PHI=',2E10.3,I3) ENDIF ENDDO C REMOVE ALL THE SPECTATORS FROM THE LIST IF REQUIRED BY DATACARD IF ( LSPEC ) THEN INEW = NNI ELSE INEW = 0 DO IALT = 1, NNI C KEEP ALL PARTICLES WHICH ARE NOT MARKED AS SPECTATORS IF ( HSPEC(IALT) .EQ. 0 ) THEN INEW = INEW + 1 HIT(INEW) = HIT(IALT) HMA(INEW) = HMA(IALT) HENL(INEW) = HENL(IALT) HEN(INEW) = HEN(IALT) HCT(INEW) = HCT(IALT) HTH(INEW) = HTH(IALT) HST(INEW) = HST(IALT) HPP(INEW) = HPP(IALT) HPL(INEW) = HPL(IALT) HPT2(INEW) = HPT2(IALT) HPT(INEW) = HPT(IALT) HPX(INEW) = HPX(IALT) HPY(INEW) = HPY(IALT) HXF(INEW) = HXF(IALT) HXFl(INEW) = HXFl(IALT) HYR(INEW) = HYR(IALT) HPR(INEW) = HPR(IALT) HPHI(INEW) = HPHI(IALT) HSPEC(INEW) = HSPEC(IALT) ENDIF ENDDO ENDIF IF ( DEBUG ) THEN WRITE(MDEBUG,*) 'HISTRA: NNI,INEW =',NNI,INEW WRITE(MDEBUG,*) 'HISTRA: SPECTATORS P/T =',IPSPEC,ITSPEC WRITE(MDEBUG,*) 'HISTRA: WOUNDED P/T =',IWOUNP,IWOUNT WRITE(MDEBUG,*) 'HISTRA: SUM P/T =',IWOUNP+IPSPEC, * IWOUNT+ITSPEC ENDIF NNI = INEW #if __URQMD__ IF ( CTAG2 .EQ. 0 ) THEN C PROJECTILES WITHOUT INTERACTION ARE SKIPPED NOINT = NOINT + 1 NNI = 0 IF ( DEBUG ) * WRITE(MDEBUG,*) 'NO INTERACTING PARTICLE, FORGET THIS EVENT' RETURN ENDIF IF ( NELCOLL2 .GT. 0 .AND. CTAG2 .EQ. NELCOLL2 ) THEN C PROJECTILES WITH ELASTIC SCATTERING ARE SKIPPED C NUMBER OF ELASTIG SCATTERING 'NElColl' MUST BE EQUAL TO NUMBER OF C ALL INTERACTIONS 'ctag' NELAST = NELAST + 1 NOINT = NOINT + 1 NNI = 0 IF ( DEBUG ) * WRITE(MDEBUG,*) 'ELASTIC EVENT, FORGET THIS EVENT' RETURN ENDIF #endif C J. WENTZ (PROJECTILES WITHOUT REACTION MUST BE SKIPPED) IF ( NNI .EQ. 1 ) THEN IF ( HPX(1) .EQ. 0.D0 .AND. HPY(1) .EQ. 0.D0 ) THEN NOINT = NOINT + 1 NNI = 0 IF ( DEBUG ) * WRITE(MDEBUG,*) 'NO INTERACTING PARTICLE, FORGET THIS EVENT' RETURN ENDIF ENDIF C ADD UP ACCEPTED EVENTS FOR NORMALIZATION ISHWW = ISHWW + 1 C RECALCULATE SUMS WITHOUT SPECTATORS C RESET VARIABLES FOR ENERGY AND MOMENTUM BALANCE ENSUM = 0.D0 PXSUM = 0.D0 PYSUM = 0.D0 PZSUM = 0.D0 C SUM UP ENERGIES AND MOMENTA FOR ENERGY AND MOMENTUM BALANCE DO I = 1, NNI ENSUM = ENSUM + HENL(I) PXSUM = PXSUM + HPX(I) PYSUM = PYSUM + HPY(I) PZSUM = PZSUM + HPL(I) ENDDO C COUNT PARTICLES FOR PRINTOUT DO I = 1, NNI III = HIT(I) IF ( III .LT. 18 ) THEN NPARTO(1,III) = NPARTO(1,III) + 1.D0 ELSEIF ( III .EQ. 25 ) THEN NNEUTB(1) = NNEUTB(1) + 1.D0 ELSEIF ( (III .GE. 18 .AND. III .LE. 24) .OR. * (III .GE. 26 .AND. III .LE. 32) ) THEN NHYP(1) = NHYP(1) + 1.D0 #if __CHARM__ ELSEIF ( III .GE. 116 .AND. III .LE. 128 ) THEN NCHRMM(1) = NCHRMM(1) + AUGM ELSEIF ( III .GE. 137 .AND. III .LE. 173 ) THEN NCHRMB(1) = NCHRMB(1) + AUGM #endif ELSEIF ( III .EQ. 201 ) THEN NDEUT(1) = NDEUT(1) + 1.D0 ELSEIF ( III .EQ. 301 ) THEN NTRIT(1) = NTRIT(1) + 1.D0 ELSEIF ( III .EQ. 302 ) THEN NHELI3(1) = NHELI3(1) + 1.D0 ELSEIF ( III .EQ. 402 ) THEN NALPHA(1) = NALPHA(1) + 1.D0 ELSEIF ( (III .GE. 66 .AND. III .LE. 69) #if __CHARM__ || __TAULEP__ * .OR. III .EQ. 133 .OR. III .EQ. 134 #endif * ) THEN NPARTO(1,4) = NPARTO(1,4) + 1.D0 ELSE NOTHER(1) = NOTHER(1) + 1.D0 ENDIF ENDDO C TRANSFORM TO CM SYSTEM OF NUCLEON-NUCLEON IF ( MCM .EQ. 1 ) THEN C GACM AND BECM AS STORED IN SUBR. NUCINT C STAY IN LAB SYSTEM; NO TRANSFORMATION ELSEIF ( MCM .EQ. 2 ) THEN GACM = 1.D0 BECM = 0.D0 C TRANSFORM TO CM SYSTEM OF ALL SECONDARIES ELSEIF ( MCM .EQ. 3 ) THEN C GAMMA AND BETA OF THE CENTER OF MASS PSUM2 = PXSUM**2 + PYSUM**2 + PZSUM**2 XMASS = SQRT( ENSUM**2 - PSUM2 ) GACM = ENSUM/XMASS BECM = SQRT( (GACM-1.D0)*(GACM+1.D0) ) / GACM ELSE WRITE(MONIOU,*) 'HISTRA: INVALID CM TRANSFORMATION MODE ',MCM STOP ENDIF IF ( DEBUG ) THEN WRITE(MDEBUG,*) 'HISTRA: E00,PTOT0N,MCM =',SNGL(E00),PTOT0N,MCM WRITE(MDEBUG,*) 'HISTRA: GACM,BECM=',GACM,BECM ENDIF C----------------------------------------------------------------------- IF ( MCM .EQ. 1 .OR. MCM .EQ. 3 ) THEN C DEFINE MAX PZ IN CMS SYSTEM IF ( DEBUG ) WRITE(MDEBUG,*) * ' PTOT0N,ITYPE,ECM=',SNGL(PTOT0N),ITYPE,ECMI PZMAXCM = PTOT0N * PAMA(14) / ECMI IF ( DEBUG ) WRITE(MDEBUG,*) ' PZMAXCM =',PZMAXCM C LORENTZ TRANSFORMATION ALONG Z AXIS DO I = 1, NNI C TRANSFORM ENERGY AND MOMENTA (PX,PY STAY UNCHANGED) HEN(I) = GACM * ( HENL(I) - BECM * HPL(I) ) HPL(I) = GACM * ((-BECM) * HENL(I) + HPL(I) ) C TOTAL MOMENTUM HPP(I) = SQRT( HPT2(I) + HPL(I)**2 ) C FEYNMAN X IN CM SYSTEM HXFCM(I) = HPL(I)/PZMAXCM C EMISSION ANGLE HTH(I) = ATAN2(HPT(I),HPL(I)) C CALCULATE RAPIDITY AND PSEUDRAPIDITY IF ( DEBUG ) WRITE(*,*) I,HENL(I),HMA(I),HEN(I),HPP(I),HPL(I) * ,HPT(I) IF ( HPT(I) .EQ. 0.D0 ) THEN IF ( HPL(I) .GT. 0.D0 ) THEN HPR(I) = 23.99D0 ELSEIF ( HPL(I) .LT. 0.D0 ) THEN HPR(I) = -23.99D0 ELSE HPR(I) = 0.D0 ENDIF ELSE IF ( HPP(I) .LE. -HPL(I) ) THEN HPR(I) = -23.99D0 ELSE IF ( HPL(I) .GE. 0.D0 ) THEN HPR(I) = LOG( (HPP(I)+HPL(I))/HPT(I) ) ELSE HPR(I) = LOG( HPT(I)/(HPP(I)-HPL(I)) ) ENDIF ENDIF ENDIF IF ( HMA(I) .EQ. 0.D0 ) THEN HYR(I) = HPR(I) ELSE IF ( HEN(I) .LE. -HPL(I) ) THEN HYR(I) = -23.99D0 ELSE IF ( HPL(I) .GE. 0.D0 ) THEN HYR(I) = LOG( (HEN(I)+HPL(I)) * /SQRT( HPT2(I)+HMA(I)**2 ) ) ELSE HYR(I) = LOG( SQRT( HPT2(I)+HMA(I)**2 ) * /(HEN(I)-HPL(I)) ) ENDIF ENDIF ENDIF ENDDO ELSE DO I = 1, NNI HEN(I) = HENL(I) ENDDO ENDIF C----------------------------------------------------------------------- C PRINT OUT AFTER TRANSFORMATION IF ( DEBUG ) THEN WRITE(MDEBUG,3345) 3345 FORMAT(' ',7X, * ' I HIT HEN HTH HPP HPL HPT', * ' HPX HPY HPT2 HYRi HPR') DO I = 1, NNI WRITE(MDEBUG,100) I,HIT(I),HEN(I),HTH(I), * HPP(I),HPL(I),HPT(I),HPX(I),HPY(I),HPT2(I), * HYR(I),HPR(I) 100 FORMAT(' HISTRA:',I4,I5,' ',1P,10E10.3) ENDDO ENDIF FLAG = .TRUE. RETURN END *-- Author : K. BERNLOEHR MPIK HEIDELBERG 15/06/1998 C======================================================================= SUBROUTINE UPLOW( CHAR,IDX ) C----------------------------------------------------------------------- C (CONVERTS) UP(PER CASE CHARACTER TO) LOW(ER CASE CHARACTER) C C THIS SUBROUTINE IS CALLED FROM HISOUT. C ARGUMENT: C CHAR = CHARACTER TO BE CONVERTED C IDX = INDEX OF CONVERTED CHARACTER C----------------------------------------------------------------------- IMPLICIT NONE INTEGER IDX CHARACTER*1 CHAR CHARACTER LOWCHR*26, UPRCHR*26 SAVE DATA UPRCHR / 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' / DATA LOWCHR / 'abcdefghijklmnopqrstuvwxyz' / C----------------------------------------------------------------------- IDX = INDEX(UPRCHR,CHAR) IF ( IDX .NE. 0 ) CHAR = LOWCHR(IDX:IDX) RETURN END #endif #if __PRESHOWER__ *-- Author : K.S. Koelbig, CERN, MATHLIB 15/10/1994 C======================================================================= SUBROUTINE DBSKA( X,IA,JA,NL,B ) C----------------------------------------------------------------------- C D(OUBLE PRECISION) B(E)S(SEL FUNCTION) K (OF ORDER) A C C CERN ROUTINE FOR MODIFIED BESSEL FUNCTION K OF CERTAIN ORDER A. C SPECIALIZED VERSION FOR A = IA/JA = 1/3 OR 2/3. C NEEDS FUNCTION DBSKR3 C SEE: http://wwwasdoc.web.cern.ch/wwwasdoc/cernlib.html (c341) C THIS SUBROUTINE IS CALLED FROM PRESHW. C ARGUMENTS: SEE REFERENCE C----------------------------------------------------------------------- IMPLICIT NONE DOUBLE PRECISION A,U,X INTEGER IA,J,JA,MODE,N,NL DOUBLE PRECISION B(0:*) DOUBLE PRECISION Z1,Z2,Z3,Z13,Z23 PARAMETER (Z1 = 1.D0) PARAMETER (Z2 = 2.D0) PARAMETER (Z3 = 3.D0) PARAMETER (Z13 = Z1/Z3) PARAMETER (Z23 = Z2/Z3) DOUBLE PRECISION DBSKR3 EXTERNAL DBSKR3 SAVE C----------------------------------------------------------------------- MODE = 10*IA+JA N = NL - 1 U = 2.D0 / X IF ( X .LE. 0.D0 ) THEN N = 0 WRITE(*,111) X 111 FORMAT(' DBSKA : NON-POSITIVE ARGUMENT X = ',E15.6) ELSEIF ( NL .LT. 0 .OR. NL .GT. 100 ) THEN N = 0 WRITE(*,*) NL,IA,JA,X WRITE(*,113) NL 113 FORMAT(' DBSKA : ILLEGAL NL =',3I9) ELSEIF ( MODE .EQ. 13 ) THEN A = Z13 B(0) = DBSKR3(X,1) B(1) = DBSKR3(X,2)+A*U*B(0) ELSEIF ( MODE .EQ. 23 ) THEN A = Z23 B(0) = DBSKR3(X,2) B(1) = DBSKR3(X,1)+A*U*B(0) ELSE N = 0 A = 0.D0 B(0) = 0.D0 B(1) = 0.D0 WRITE(*,112) IA,JA 112 FORMAT(' DBSKA : PAIR (IA,JA) = (',I5,',',I5,') ILLEGAL') ENDIF DO J = 1,N A = A + 1.D0 B(J+1) = B(J-1) + A*U*B(J) ENDDO * WRITE(*,*)'B0=',B(0),' B1=',B(1) RETURN END *-- Author : K.S. Koelbig, CERN, MATHLIB 15/10/1994 C======================================================================= DOUBLE PRECISION FUNCTION DBSKR3( X,NU ) C----------------------------------------------------------------------- C CERN ROUTINE FOR MODIFIED BESSEL FUNCTION K OF ORDER 1/3 OR 2/3. C SEE: http://wwwasdoc.web.cern.ch/wwwasdoc/cernlib.html (c341) C THIS FUNCTION IS CALLED FROM DBSKA. C ARGUMENTS: SEE REFERENCE AND CALLING ROUTINE C----------------------------------------------------------------------- IMPLICIT NONE DOUBLE PRECISION A,ALFA,A0,A1,A2,B,BK,BK1,B0,B1,B2,C,C0,D,E, * F,FN,FN1,FN2,FN3,FN4,FN5,F1,F2,F3,G,H, * P,Q,R,RAN,S,X,XN INTEGER I,MU,N,NU DOUBLE PRECISION C1,EPS,GM,GP,G1,G2,HF,PI,PIH,RPIH,W3 PARAMETER (EPS = 1.D-15) PARAMETER (HF = 1.D0/2.D0) PARAMETER (PI = 3.14159 26535 89793 24D0) PARAMETER (W3 = 1.73205 08075 68877 29D0) PARAMETER (G1 = 2.67893 85347 07747 63D0) PARAMETER (G2 = 1.35411 79394 26400 42D0) PARAMETER (PIH = PI/2.D0, RPIH = 2.D0/PI) PARAMETER (C1 = 2.D0*PI/(3.D0*W3)) PARAMETER (GM = 3.D0*(1.D0/G2-3.D0/G1)/2.D0) PARAMETER (GP = (3.D0/G1+1.D0/G2)/2.D0) DOUBLE PRECISION CC(0:15,2),PP(-2:2) SAVE DATA PP(-2) /-0.66666 66666 66666 67D0/ DATA PP(-1) /-0.33333 33333 33333 33D0/ DATA PP( 1) / 0.33333 33333 33333 33D0/ DATA PP( 2) / 0.66666 66666 66666 67D0/ DATA CC( 0,1) / 0.99353 64122 76093 39D0/ DATA CC( 1,1) /-0.00631 44392 60798 63D0/ DATA CC( 2,1) / 0.00014 30095 80961 13D0/ DATA CC( 3,1) /-0.00000 57870 60592 03D0/ DATA CC( 4,1) / 0.00000 03265 50333 20D0/ DATA CC( 5,1) /-0.00000 00231 23231 95D0/ DATA CC( 6,1) / 0.00000 00019 39555 14D0/ DATA CC( 7,1) /-0.00000 00001 85897 89D0/ DATA CC( 8,1) / 0.00000 00000 19868 42D0/ DATA CC( 9,1) /-0.00000 00000 02326 79D0/ DATA CC(10,1) / 0.00000 00000 00294 68D0/ DATA CC(11,1) /-0.00000 00000 00039 95D0/ DATA CC(12,1) / 0.00000 00000 00005 75D0/ DATA CC(13,1) /-0.00000 00000 00000 87D0/ DATA CC(14,1) / 0.00000 00000 00000 14D0/ DATA CC(15,1) /-0.00000 00000 00000 02D0/ DATA CC( 0,2) / 1.00914 95380 72789 40D0/ DATA CC( 1,2) / 0.00897 12068 42483 60D0/ DATA CC( 2,2) /-0.00017 13895 98261 54D0/ DATA CC( 3,2) / 0.00000 65547 92549 82D0/ DATA CC( 4,2) /-0.00000 03595 19190 49D0/ DATA CC( 5,2) / 0.00000 00250 24412 19D0/ DATA CC( 6,2) /-0.00000 00020 74924 13D0/ DATA CC( 7,2) / 0.00000 00001 97223 67D0/ DATA CC( 8,2) /-0.00000 00000 20946 47D0/ DATA CC( 9,2) / 0.00000 00000 02440 93D0/ DATA CC(10,2) /-0.00000 00000 00307 91D0/ DATA CC(11,2) / 0.00000 00000 00041 61D0/ DATA CC(12,2) /-0.00000 00000 00005 97D0/ DATA CC(13,2) / 0.00000 00000 00000 91D0/ DATA CC(14,2) /-0.00000 00000 00000 14D0/ DATA CC(15,2) / 0.00000 00000 00000 02D0/ C----------------------------------------------------------------------- MU = ABS(NU) IF ( MU .NE. 1 .AND. MU .NE. 2 .OR. X .LE. 0.D0 ) THEN S = 0.D0 C WRITE(*,101) X,NU C 101 FORMAT(' DBSKR3: INCORRECT ARGUMENT OR INDEX, X = ',1P,E15.6, C * ' NU = ',I5) ELSEIF ( X .LE. 1.D0 ) THEN A0 = PP(-1) B = HF*X D = -LOG( B ) F = A0*D E = EXP( F ) G = (GM*A0+GP)*E BK = C1*( HF*GM*(E+1.D0/E) + GP*D*SINH( F )/F ) F = BK E = A0**2 P = HF*C1*G Q = HF/G C = 1.D0 D = B**2 BK1 = P DO N = 1, 15 FN = N F = (FN*F+P+Q)/(FN**2-E) C = C*D/FN P = P/(FN-A0) Q = Q/(FN+A0) G = C*(P-FN*F) H = C*F BK = BK + H BK1 = BK1 + G IF ( H*BK1+ABS(G)*BK .LE. EPS*BK*BK1 ) GOTO 12 ENDDO 12 S = BK IF ( MU .EQ. 2 ) S = BK1/B ELSEIF ( X .LE. 5.D0 ) THEN XN = 4.D0*PP(MU)**2 A = 9.D0 - XN B = 25.D0 - XN C = 768.D0*X**2 C0 = 48.D0*X A0 = 1.D0 A1 = (16.D0*X + 7.D0 + XN)/A A2 = ( C + C0*(XN+23.D0) + XN*(XN+62.D0) + 129.D0 )/(A*B) B0 = 1.D0 B1 = (16.D0*X + 9.D0 - XN)/A B2 = (C + C0*B)/(A*B) + 1.D0 C = 0.D0 DO N = 3, 30 C0 = C FN = N FN2 = FN + FN FN1 = FN2 - 1.D0 FN3 = FN1/(FN2-3.D0) FN4 = 12.D0*FN**2 - (1.D0-XN) FN5 = 16.D0*FN1*X RAN = 1.D0/((FN2+1.D0)**2-XN) F1 = FN3*(FN4 - 20.D0*FN) + FN5 F2 = 28.D0*FN - FN4 - 8.D0 + FN5 F3 = FN3*((FN2-5.D0)**2 - XN) A = (F1*A2 + F2*A1 + F3*A0)*RAN B = (F1*B2 + F2*B1 + F3*B0)*RAN C = A/B IF ( ABS(C0-C) .LT. EPS*ABS(C) ) GOTO 25 A0 = A1 A1 = A2 A2 = A B0 = B1 B1 = B2 B2 = B ENDDO 25 S = C/SQRT( RPIH*X ) S = EXP( -X )*S ELSE R = 1.D0/X H = 10.D0*R - 1.D0 ALFA = H + H B1 = 0.D0 B2 = 0.D0 DO I = 15, 0, -1 B0 = CC(I,MU) + ALFA*B1 - B2 B2 = B1 B1 = B0 ENDDO S = SQRT( PIH*R )*(B0-H*B2) S = EXP( -X )*S ENDIF DBSKR3 = S RETURN END *-- Author : N.A. TSYGANENKO 22/11/2001 C======================================================================= SUBROUTINE IGRF( IY,NM,R,T,F,BR,BT,BF ) C----------------------------------------------------------------------- C Modified to include IGRF-11 (rel. 2010) coefficients C instead of IGRF-8 (rel. 2000). C (http://www.ngdc.noaa.gov/IAGA/vmod/igrf.html) C - Years up to 2015 are accepted. C - The highest order of spherical harmonics available C is now 13 (instead of 10) C C.B. 25/08/2010 C----------------------------------------------------------------------- C CALCULATES COMPONENTS OF THE MAIN (INTERNAL) GEOMAGNETIC FIELD IN C SPHERICAL GEOGRAPHICAL COORDINATE SYSTEM, USING IAGA INTERNATIONAL C GEOMAGNETIC REFERENCE MODEL COEFFICIENTS C (e.g., http://www.ngdc.noaa.gov/IAGA/wg8/igrf2000.html) C C UPDATING THE COEFFICIENTS TO A GIVEN EPOCH IS MADE AUTOMATICALLY C UPON THE FIRST CALL AND AFTER EVERY CHANGE OF THE PARAMETER IY. C C THE CODE WAS MODIFIED TO ACCEPT DATES THROUGH 2005. C IT HAS ALSO BEEN SLIGHTLY SIMPLIFIED BY TAKING OUT SOME REDUNDANT C STATEMENTS, AND A "SAVE" STATEMENT WAS ADDED, TO AVOID POTENTIAL C PROBLEMS WITH SOME FORTRAN COMPILERS. C LAST MODIFICATION: JANUARY 5, 2001. C----------------------------------------------------------------------- C THIS SUBROUTINE IS CALLED FROM PRESHW.C C ARGUMENTS INPUT: C IY - YEAR NUMBER (FOUR-DIGIT; 1965 &LE IY &LE 2015) C NM - HIGHEST ORDER OF SPHERICAL HARMONICS IN THE SCALAR C POTENTIAL (NM & LE 13) C R,T,F - SPHERICAL COORDINATES (RADIUS R IN UNITS RE=6371.2 KM, C GEOGRAPHIC COLATITUDE T AND LONGITUDE F IN RADIANS) C ARGUMENTS OUTPUT: C BR,BT,BF - SPHERICAL COMPONENTS OF THE MAIN GEOMAGNETIC FIELD IN C NANOTESLA C C WRITTEN BY: N. A. TSYGANENKO C----------------------------------------------------------------------- C SAVE MA,IYR,IPR C DIMENSION A(14),B(14),G(105),H(105),REC(105),G65(105),H65(105), *G70(105),H70(105),G75(105),H75(105),G80(105),H80(105),G85(105), *H85(105),G90(105),H90(105),G95(105),H95(105),G00(105),H00(105), *G05(105),H05(105),G10(105),H10(105),DG10(45),DH10(45) C C DATA DG10/ 0.00, 11.40, 16.70, -11.30, -3.90, * 2.70, 1.30, -3.90, -2.90, -8.10, * -1.40, 2.00, -8.90, 4.40, -2.30, * -0.50, 0.50, -1.50, -0.70, 1.30, * 1.40, -0.30, -0.30, -0.30, 1.90, * -1.60, -0.20, 1.80, 0.20, -0.10, * -0.60, 1.40, 0.30, 0.10, -0.80, * 0.40, -0.10, 0.10, -0.50, 0.30, * -0.30, 0.30, 0.20, -0.50, 0.20/ C DATA DH10/ 0.00, 0.00, -28.80, 0.00, -23.00, * -12.90, 0.00, 8.60, -2.90, -2.10, * 0.00, 0.40, 3.20, 3.60, -0.80, * 0.00, 0.50, 1.50, 0.90, 3.70, * -0.60, 0.00, -0.10, -2.10, -0.40, * -0.50, 0.80, 0.50, 0.00, 0.60, * 0.30, -0.20, -0.10, -0.80, -0.30, * 0.20, 0.00, 0.00, 0.20, 0.50, * 0.40, 0.10, -0.10, 0.40, 0.40/ C C DATA G10/ 0.00, -29496.50, -1585.90, -2396.60, 3026.00, * 1668.60, 1339.70, -2326.30, 1231.70, 634.20, * 912.60, 809.00, 166.60, -357.10, 89.70, * -231.10, 357.20, 200.30, -141.20, -163.10, * -7.70, 72.80, 68.60, 76.00, -141.40, * -22.90, 13.10, -77.90, 80.40, -75.00, * -4.70, 45.30, 14.00, 10.40, 1.60, * 4.90, 24.30, 8.20, -14.50, -5.70, * -19.30, 11.60, 10.90, -14.10, -3.70, * 5.40, 9.40, 3.40, -5.30, 3.10, * -12.40, -0.80, 8.40, -8.40, -10.10, * -2.00, -6.30, 0.90, -1.10, -0.20, * 2.50, -0.30, 2.20, 3.10, -1.00, * -2.80, 3.00, -1.50, -2.10, 1.60, * -0.50, 0.50, -0.80, 0.40, 1.80, * 0.20, 0.80, 3.80, -2.10, -0.20, * 0.30, 1.00, -0.70, 0.90, -0.10, * 0.50, -0.40, -0.40, 0.20, -0.80, * 0.00, -0.20, -0.90, 0.30, 0.40, * -0.40, 1.10, -0.30, 0.80, -0.20, * 0.40, 0.00, 0.40, -0.30, -0.30/ C DATA H10/ 0.00, 0.00, 4945.10, 0.00, -2707.70, * -575.40, 0.00, -160.50, 251.70, -536.80, * 0.00, 286.40, -211.20, 164.40, -309.20, * 0.00, 44.70, 188.90, -118.10, 0.10, * 100.90, 0.00, -20.80, 44.20, 61.50, * -66.30, 3.10, 54.90, 0.00, -57.80, * -21.20, 6.60, 24.90, 7.00, -27.70, * -3.40, 0.00, 10.90, -20.00, 11.90, * -17.40, 16.70, 7.10, -10.80, 1.70, * 0.00, -20.50, 11.60, 12.80, -7.20, * -7.40, 8.00, 2.20, -6.10, 7.00, * 0.00, 2.80, -0.10, 4.70, 4.40, * -7.20, -1.00, -4.00, -2.00, -2.00, * -8.30, 0.00, 0.10, 1.70, -0.60, * -1.80, 0.90, -0.40, -2.50, -1.30, * -2.10, -1.90, -1.80, 0.00, -0.80, * 0.30, 2.20, -2.50, 0.50, 0.60, * 0.00, 0.10, 0.30, -0.90, -0.20, * 0.80, 0.00, -0.80, 0.30, 1.70, * -0.60, -1.20, -0.10, 0.50, 0.10, * 0.50, 0.40, -0.20, -0.50, -0.80/ C C DATA G05/ 0.00, -29554.63, -1669.05, -2337.24, 3047.69, * 1657.76, 1336.30, -2305.83, 1246.39, 672.51, * 920.55, 797.96, 210.65, -379.86, 100.00, * -227.00, 354.41, 208.95, -136.54, -168.05, * -13.55, 73.60, 69.56, 76.74, -151.34, * -14.58, 14.58, -86.36, 79.88, -74.46, * -1.65, 38.73, 12.30, 9.37, 5.42, * 1.94, 24.80, 7.62, -11.73, -6.88, * -18.11, 10.17, 9.36, -11.25, -4.87, * 5.58, 9.76, 3.58, -6.94, 5.01, * -10.76, -1.25, 8.76, -6.66, -9.22, * -2.17, -6.12, 1.42, -2.35, -0.15, * 3.06, 0.29, 2.06, 3.77, -0.21, * -2.09, 2.95, -1.60, -1.88, 1.44, * -0.31, 0.29, -0.79, 0.53, 1.80, * 0.16, 0.96, 3.99, -2.15, -0.29, * 0.21, 0.89, -0.38, 0.96, -0.30, * 0.46, -0.35, -0.36, 0.08, -0.49, * -0.08, -0.16, -0.88, 0.30, 0.28, * -0.43, 1.18, -0.37, 0.75, -0.26, * 0.35, -0.05, 0.41, -0.10, -0.18/ C DATA H05/ 0.00, 0.00, 5077.99, 0.00, -2594.50, * -515.43, 0.00, -198.86, 269.72, -524.72, * 0.00, 282.07, -225.23, 145.15, -305.36, * 0.00, 42.72, 180.25, -123.45, -19.57, * 103.85, 0.00, -20.33, 54.75, 63.63, * -63.53, 0.24, 50.94, 0.00, -61.14, * -22.57, 6.82, 25.35, 10.93, -26.32, * -4.64, 0.00, 11.20, -20.88, 9.83, * -19.71, 16.22, 7.61, -12.76, -0.06, * 0.00, -20.11, 12.69, 12.67, -6.72, * -8.16, 8.10, 2.92, -7.73, 6.01, * 0.00, 2.19, 0.10, 4.46, 4.76, * -6.58, -1.01, -3.47, -0.86, -2.31, * -7.93, 0.00, 0.26, 1.44, -0.77, * -2.27, 0.90, -0.58, -2.69, -1.08, * -1.58, -1.90, -1.39, 0.00, -0.55, * 0.23, 2.38, -2.63, 0.61, 0.40, * 0.01, 0.02, 0.28, -0.87, -0.34, * 0.88, 0.00, -0.76, 0.33, 1.72, * -0.54, -1.07, -0.04, 0.63, 0.21, * 0.53, 0.38, -0.22, -0.57, -0.82/ C C DATA G00/ 0.00, -29619.40, -1728.20, -2267.70, 3068.40, * 1670.90, 1339.60, -2288.00, 1252.10, 714.50, * 932.30, 786.80, 250.00, -403.00, 111.30, * -218.80, 351.40, 222.30, -130.40, -168.60, * -12.90, 72.30, 68.20, 74.20, -160.90, * -5.90, 16.90, -90.40, 79.00, -74.00, * 0.00, 33.30, 9.10, 6.90, 7.30, * -1.20, 24.40, 6.60, -9.20, -7.90, * -16.60, 9.10, 7.00, -7.90, -7.00, * 5.00, 9.40, 3.00, -8.40, 6.30, * -8.90, -1.50, 9.30, -4.30, -8.20, * -2.60, -6.00, 1.70, -3.10, -0.50, * 3.70, 1.00, 2.00, 4.20, 0.30, * -1.10, 2.70, -1.70, -1.90, 1.50, * -0.10, 0.10, -0.70, 0.70, 1.70, * 0.10, 1.20, 4.00, -2.20, -0.30, * 0.20, 0.90, -0.20, 0.90, -0.50, * 0.30, -0.30, -0.40, -0.10, -0.20, * -0.40, -0.20, -0.90, 0.30, 0.10, * -0.40, 1.30, -0.40, 0.70, -0.40, * 0.30, -0.10, 0.40, 0.00, 0.10/ C DATA H00/ 0.00, 0.00, 5186.10, 0.00, -2481.60, * -458.00, 0.00, -227.60, 293.40, -491.10, * 0.00, 272.60, -231.90, 119.80, -303.80, * 0.00, 43.80, 171.90, -133.10, -39.30, * 106.30, 0.00, -17.40, 63.70, 65.10, * -61.20, 0.70, 43.80, 0.00, -64.60, * -24.20, 6.20, 24.00, 14.80, -25.40, * -5.80, 0.00, 11.90, -21.50, 8.50, * -21.50, 15.50, 8.90, -14.90, -2.10, * 0.00, -19.70, 13.40, 12.50, -6.20, * -8.40, 8.40, 3.80, -8.20, 4.80, * 0.00, 1.70, 0.00, 4.00, 4.90, * -5.90, -1.20, -2.90, 0.20, -2.20, * -7.40, 0.00, 0.10, 1.30, -0.90, * -2.60, 0.90, -0.70, -2.80, -0.90, * -1.20, -1.90, -0.90, 0.00, -0.40, * 0.30, 2.50, -2.60, 0.70, 0.30, * 0.00, 0.00, 0.30, -0.90, -0.40, * 0.80, 0.00, -0.90, 0.20, 1.80, * -0.40, -1.00, -0.10, 0.70, 0.30, * 0.60, 0.30, -0.20, -0.50, -0.90/ C C DATA G95/ 0.00, -29692.00, -1784.00, -2200.00, 3070.00, * 1681.00, 1335.00, -2267.00, 1249.00, 759.00, * 940.00, 780.00, 290.00, -418.00, 122.00, * -214.00, 352.00, 235.00, -118.00, -166.00, * -17.00, 68.00, 67.00, 68.00, -170.00, * -1.00, 19.00, -93.00, 77.00, -72.00, * 1.00, 28.00, 5.00, 4.00, 8.00, * -2.00, 25.00, 6.00, -6.00, -9.00, * -14.00, 9.00, 6.00, -5.00, -7.00, * 4.00, 9.00, 3.00, -10.00, 8.00, * -8.00, -1.00, 10.00, -2.00, -8.00, * -3.00, -6.00, 2.00, -4.00, -1.00, * 4.00, 2.00, 2.00, 5.00, 1.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00/ C DATA H95/ 0.00, 0.00, 5306.00, 0.00, -2366.00, * -413.00, 0.00, -262.00, 302.00, -427.00, * 0.00, 262.00, -236.00, 97.00, -306.00, * 0.00, 46.00, 165.00, -143.00, -55.00, * 107.00, 0.00, -17.00, 72.00, 67.00, * -58.00, 1.00, 36.00, 0.00, -69.00, * -25.00, 4.00, 24.00, 17.00, -24.00, * -6.00, 0.00, 11.00, -21.00, 8.00, * -23.00, 15.00, 11.00, -16.00, -4.00, * 0.00, -20.00, 15.00, 12.00, -6.00, * -8.00, 8.00, 5.00, -8.00, 3.00, * 0.00, 1.00, 0.00, 4.00, 5.00, * -5.00, -1.00, -2.00, 1.00, -2.00, * -7.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00/ C C DATA G90/ 0.00, -29775.00, -1848.00, -2131.00, 3059.00, * 1686.00, 1314.00, -2239.00, 1248.00, 802.00, * 939.00, 780.00, 325.00, -423.00, 141.00, * -214.00, 353.00, 245.00, -109.00, -165.00, * -36.00, 61.00, 65.00, 59.00, -178.00, * 3.00, 18.00, -96.00, 77.00, -64.00, * 2.00, 26.00, -1.00, 5.00, 9.00, * 0.00, 23.00, 5.00, -1.00, -10.00, * -12.00, 3.00, 4.00, 2.00, -6.00, * 4.00, 9.00, 1.00, -12.00, 9.00, * -4.00, -2.00, 7.00, 1.00, -6.00, * -3.00, -4.00, 2.00, -5.00, -2.00, * 4.00, 3.00, 1.00, 3.00, 3.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00/ C DATA H90/ 0.00, 0.00, 5406.00, 0.00, -2279.00, * -373.00, 0.00, -284.00, 293.00, -352.00, * 0.00, 247.00, -240.00, 84.00, -299.00, * 0.00, 46.00, 154.00, -153.00, -69.00, * 97.00, 0.00, -16.00, 82.00, 69.00, * -52.00, 1.00, 24.00, 0.00, -80.00, * -26.00, 0.00, 21.00, 17.00, -23.00, * -4.00, 0.00, 10.00, -19.00, 6.00, * -22.00, 12.00, 12.00, -16.00, -10.00, * 0.00, -20.00, 15.00, 11.00, -7.00, * -7.00, 9.00, 8.00, -7.00, 2.00, * 0.00, 2.00, 1.00, 3.00, 6.00, * -4.00, 0.00, -2.00, 3.00, -1.00, * -6.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00/ C C DATA G85/ 0.00, -29873.00, -1905.00, -2072.00, 3044.00, * 1687.00, 1296.00, -2208.00, 1247.00, 829.00, * 936.00, 780.00, 361.00, -424.00, 170.00, * -214.00, 355.00, 253.00, -93.00, -164.00, * -46.00, 53.00, 65.00, 51.00, -185.00, * 4.00, 16.00, -102.00, 74.00, -62.00, * 3.00, 24.00, -6.00, 4.00, 10.00, * 0.00, 21.00, 6.00, 0.00, -11.00, * -9.00, 4.00, 4.00, 4.00, -4.00, * 5.00, 10.00, 1.00, -12.00, 9.00, * -3.00, -1.00, 7.00, 1.00, -5.00, * -4.00, -4.00, 3.00, -5.00, -2.00, * 5.00, 3.00, 1.00, 2.00, 3.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00/ C DATA H85/ 0.00, 0.00, 5500.00, 0.00, -2197.00, * -306.00, 0.00, -310.00, 284.00, -297.00, * 0.00, 232.00, -249.00, 69.00, -297.00, * 0.00, 47.00, 150.00, -154.00, -75.00, * 95.00, 0.00, -16.00, 88.00, 69.00, * -48.00, -1.00, 21.00, 0.00, -83.00, * -27.00, -2.00, 20.00, 17.00, -23.00, * -7.00, 0.00, 8.00, -19.00, 5.00, * -23.00, 11.00, 14.00, -15.00, -11.00, * 0.00, -21.00, 15.00, 9.00, -6.00, * -6.00, 9.00, 9.00, -7.00, 2.00, * 0.00, 1.00, 0.00, 3.00, 6.00, * -4.00, 0.00, -1.00, 4.00, 0.00, * -6.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00/ C C DATA G80/ 0.00, -29992.00, -1956.00, -1997.00, 3027.00, * 1663.00, 1281.00, -2180.00, 1251.00, 833.00, * 938.00, 782.00, 398.00, -419.00, 199.00, * -218.00, 357.00, 261.00, -74.00, -162.00, * -48.00, 48.00, 66.00, 42.00, -192.00, * 4.00, 14.00, -108.00, 72.00, -59.00, * 2.00, 21.00, -12.00, 1.00, 11.00, * -2.00, 18.00, 6.00, 0.00, -11.00, * -7.00, 4.00, 3.00, 6.00, -1.00, * 5.00, 10.00, 1.00, -12.00, 9.00, * -3.00, -1.00, 7.00, 2.00, -5.00, * -4.00, -4.00, 2.00, -5.00, -2.00, * 5.00, 3.00, 1.00, 2.00, 3.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00/ C DATA H80/ 0.00, 0.00, 5604.00, 0.00, -2129.00, * -200.00, 0.00, -336.00, 271.00, -252.00, * 0.00, 212.00, -257.00, 53.00, -297.00, * 0.00, 46.00, 150.00, -151.00, -78.00, * 92.00, 0.00, -15.00, 93.00, 71.00, * -43.00, -2.00, 17.00, 0.00, -82.00, * -27.00, -5.00, 16.00, 18.00, -23.00, * -10.00, 0.00, 7.00, -18.00, 4.00, * -22.00, 9.00, 16.00, -13.00, -15.00, * 0.00, -21.00, 16.00, 9.00, -5.00, * -6.00, 9.00, 10.00, -6.00, 2.00, * 0.00, 1.00, 0.00, 3.00, 6.00, * -4.00, 0.00, -1.00, 4.00, 0.00, * -6.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00/ C C DATA G75/ 0.00, -30100.00, -2013.00, -1902.00, 3010.00, * 1632.00, 1276.00, -2144.00, 1260.00, 830.00, * 946.00, 791.00, 438.00, -405.00, 216.00, * -218.00, 356.00, 264.00, -59.00, -159.00, * -49.00, 45.00, 66.00, 28.00, -198.00, * 1.00, 6.00, -111.00, 71.00, -56.00, * 1.00, 16.00, -14.00, 0.00, 12.00, * -5.00, 14.00, 6.00, -1.00, -12.00, * -8.00, 4.00, 0.00, 10.00, 1.00, * 7.00, 10.00, 2.00, -12.00, 10.00, * -1.00, -1.00, 4.00, 1.00, -2.00, * -3.00, -3.00, 2.00, -5.00, -2.00, * 5.00, 4.00, 1.00, 0.00, 3.00, * -1.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00/ C DATA H75/ 0.00, 0.00, 5675.00, 0.00, -2067.00, * -68.00, 0.00, -333.00, 262.00, -223.00, * 0.00, 191.00, -265.00, 39.00, -288.00, * 0.00, 31.00, 148.00, -152.00, -83.00, * 88.00, 0.00, -13.00, 99.00, 75.00, * -41.00, -4.00, 11.00, 0.00, -77.00, * -26.00, -5.00, 10.00, 22.00, -23.00, * -12.00, 0.00, 6.00, -16.00, 4.00, * -19.00, 6.00, 18.00, -10.00, -17.00, * 0.00, -21.00, 16.00, 7.00, -4.00, * -5.00, 10.00, 11.00, -3.00, 1.00, * 0.00, 1.00, 1.00, 3.00, 4.00, * -4.00, -1.00, -1.00, 3.00, 1.00, * -5.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00/ C C DATA G70/ 0.00, -30220.00, -2068.00, -1781.00, 3000.00, * 1611.00, 1287.00, -2091.00, 1278.00, 838.00, * 952.00, 800.00, 461.00, -395.00, 234.00, * -216.00, 359.00, 262.00, -42.00, -160.00, * -56.00, 43.00, 64.00, 15.00, -212.00, * 2.00, 3.00, -112.00, 72.00, -57.00, * 1.00, 14.00, -22.00, -2.00, 13.00, * -2.00, 14.00, 6.00, -2.00, -13.00, * -3.00, 5.00, 0.00, 11.00, 3.00, * 8.00, 10.00, 2.00, -12.00, 10.00, * -1.00, 0.00, 3.00, 1.00, -1.00, * -3.00, -3.00, 2.00, -5.00, -1.00, * 6.00, 4.00, 1.00, 0.00, 3.00, * -1.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00/ C DATA H70/ 0.00, 0.00, 5737.00, 0.00, -2047.00, * 25.00, 0.00, -366.00, 251.00, -196.00, * 0.00, 167.00, -266.00, 26.00, -279.00, * 0.00, 26.00, 139.00, -139.00, -91.00, * 83.00, 0.00, -12.00, 100.00, 72.00, * -37.00, -6.00, 1.00, 0.00, -70.00, * -27.00, -4.00, 8.00, 23.00, -23.00, * -11.00, 0.00, 7.00, -15.00, 6.00, * -17.00, 6.00, 21.00, -6.00, -16.00, * 0.00, -21.00, 16.00, 6.00, -4.00, * -5.00, 10.00, 11.00, -2.00, 1.00, * 0.00, 1.00, 1.00, 3.00, 4.00, * -4.00, 0.00, -1.00, 3.00, 1.00, * -4.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00/ C C DATA G65/ 0.00, -30334.00, -2119.00, -1662.00, 2997.00, * 1594.00, 1297.00, -2038.00, 1292.00, 856.00, * 957.00, 804.00, 479.00, -390.00, 252.00, * -219.00, 358.00, 254.00, -31.00, -157.00, * -62.00, 45.00, 61.00, 8.00, -228.00, * 4.00, 1.00, -111.00, 75.00, -57.00, * 4.00, 13.00, -26.00, -6.00, 13.00, * 1.00, 13.00, 5.00, -4.00, -14.00, * 0.00, 8.00, -1.00, 11.00, 4.00, * 8.00, 10.00, 2.00, -13.00, 10.00, * -1.00, -1.00, 5.00, 1.00, -2.00, * -2.00, -3.00, 2.00, -5.00, -2.00, * 4.00, 4.00, 0.00, 2.00, 2.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00/ C DATA H65/ 0.00, 0.00, 5776.00, 0.00, -2016.00, * 114.00, 0.00, -404.00, 240.00, -165.00, * 0.00, 148.00, -269.00, 13.00, -269.00, * 0.00, 19.00, 128.00, -126.00, -97.00, * 81.00, 0.00, -11.00, 100.00, 68.00, * -32.00, -8.00, -7.00, 0.00, -61.00, * -27.00, -2.00, 6.00, 26.00, -23.00, * -12.00, 0.00, 7.00, -12.00, 9.00, * -16.00, 4.00, 24.00, -3.00, -17.00, * 0.00, -22.00, 15.00, 7.00, -4.00, * -5.00, 10.00, 10.00, -4.00, 1.00, * 0.00, 2.00, 1.00, 2.00, 6.00, * -4.00, 0.00, -2.00, 3.00, 0.00, * -6.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00, * 0.00, 0.00, 0.00, 0.00, 0.00/ C C DATA MA,IYR,IPR /0, 0, 0 / C----------------------------------------------------------------------- IF ( MA .NE. 1 ) GOTO 10 IF ( IY .NE. IYR ) GOTO 30 C NEED TO COMMENT OUT THE LINE BELOW (AND CORRESPONDING LABEL) C BECAUSE FOR SOME C COMPILERS WHEN MULTIPLE CALLING WITH THE SAME PARAMETERS NM, IY C FIELD COEFFICIENTS FOR THESE VALUES ARE NOT SAVED SO IT IS SAFER C TO CALCULATE THEM EACH TIME, Piotr Homola 16.07.02 C GOTO 130 10 MA = 1 C MAX ORDER INCREASED FROM 10 TO 13 C.B.25.08.10 DO N = 1, 14 N2 = 2*N - 1 N2 = N2*(N2-2) DO M = 1, N MN = N*(N-1)/2+M REC(MN) = FLOAT((N-M)*(N+M-2))/FLOAT(N2) ENDDO ENDDO C C MAX YEAR IS NOW 2015 C.B.25.08.10 30 IYR = IY IF ( IYR .LT. 1965) IYR = 1965 IF ( IYR .GT. 2015) IYR = 2015 IF ( IYR .NE. IY ) IPR=1 IF ( IYR .LT. 1970 ) GOTO 50 !INTERPOLATE BETWEEN 1965 - 1970 IF ( IYR .LT. 1975 ) GOTO 55 !INTERPOLATE BETWEEN 1970 - 1975 IF ( IYR .LT. 1980 ) GOTO 60 !INTERPOLATE BETWEEN 1975 - 1980 IF ( IYR .LT. 1985 ) GOTO 65 !INTERPOLATE BETWEEN 1980 - 1985 IF ( IYR .LT. 1990 ) GOTO 70 !INTERPOLATE BETWEEN 1985 - 1990 IF ( IYR .LT. 1995 ) GOTO 75 !INTERPOLATE BETWEEN 1990 - 1995 IF ( IYR .LT. 2000 ) GOTO 80 !INTERPOLATE BETWEEN 1995 - 2000 IF ( IYR .LT. 2005 ) GOTO 85 !INTERPOLATE BETWEEN 2000 - 2005 IF ( IYR .LT. 2010 ) GOTO 90 !INTERPOLATE BETWEEN 2005 - 2010 C C EXTRAPOLATE BEYOND 2010: C DT = FLOAT(IYR) - 2010. DO N = 1, 105 G(N) = G10(N) H(N) = H10(N) IF ( N .GT. 45 ) GOTO 40 G(N) = G(N) + DG10(N)*DT H(N) = H(N) + DH10(N)*DT 40 CONTINUE ENDDO GOTO 300 C C INTERPOLATE BETWEEEN 1965 - 1970: C 50 F2 = (IYR-1965)/5. F1 = 1. - F2 DO N = 1, 105 G(N) = G65(N)*F1 + G70(N)*F2 H(N) = H65(N)*F1 + H70(N)*F2 ENDDO GOTO 300 C C INTERPOLATE BETWEEN 1970 - 1975: C 55 F2 = (IYR-1970)/5. F1 = 1. - F2 DO N = 1, 105 G(N) = G70(N)*F1 + G75(N)*F2 H(N) = H70(N)*F1 + H75(N)*F2 ENDDO GOTO 300 C C INTERPOLATE BETWEEN 1975 - 1980: C 60 F2 = (IYR-1975)/5. F1 = 1. - F2 DO N = 1, 105 G(N) = G75(N)*F1 + G80(N)*F2 H(N) = H75(N)*F1 + H80(N)*F2 ENDDO GOTO 300 C C INTERPOLATE BETWEEN 1980 - 1985: C 65 F2 = (IYR-1980)/5. F1 = 1. - F2 DO N = 1, 105 G(N) = G80(N)*F1 + G85(N)*F2 H(N) = H80(N)*F1 + H85(N)*F2 ENDDO GOTO 300 C C INTERPOLATE BETWEEN 1985 - 1990: C 70 F2 = (IYR-1985)/5. F1 = 1. - F2 DO N = 1, 105 G(N) = G85(N)*F1 + G90(N)*F2 H(N) = H85(N)*F1 + H90(N)*F2 ENDDO GOTO 300 C C INTERPOLATE BETWEEN 1990 - 1995: C 75 F2 = (IYR-1990)/5. F1 = 1. - F2 DO N = 1, 105 G(N) = G90(N)*F1 + G95(N)*F2 H(N) = H90(N)*F1 + H95(N)*F2 ENDDO GOTO 300 C C INTERPOLATE BETWEEN 1995 - 2000: C 80 F2 = (IYR-1995)/5. F1 = 1. - F2 DO N = 1, 105 G(N) = G95(N)*F1 + G00(N)*F2 H(N) = H95(N)*F1 + H00(N)*F2 ENDDO GOTO 300 C C INTERPOLATE BETWEEN 2000 - 2005: C 85 F2 = (IYR-2000)/5. F1 = 1. - F2 DO N = 1, 105 G(N) = G00(N)*F1 + G05(N)*F2 H(N) = H00(N)*F1 + H05(N)*F2 ENDDO GOTO 300 C C INTERPOLATE BETWEEN 2005 - 2010: C 90 F2 = (IYR-2005)/5. F1 = 1. - F2 DO N = 1, 105 G(N) = G05(N)*F1 + G10(N)*F2 H(N) = H05(N)*F1 + H10(N)*F2 ENDDO GOTO 300 C C COEFFICIENTS FOR A GIVEN YEAR HAVE BEEN CALCULATED; NOW MULTIPLY C THEM BY SCHMIDT NORMALIZATION FACTORS: C 300 S = 1. ! max order increased from 10 to 13 DO N = 2, 14 ! C.B.25.08.10 MN = N*(N-1)/2 + 1 S = S*FLOAT(2*N-3)/FLOAT(N-1) G(MN) = G(MN)*S H(MN) = H(MN)*S P = S DO M = 2, N AA = 1. IF ( M .EQ. 2 ) AA = 2. P = P*SQRT( AA*FLOAT(N-M+1)/FLOAT(N+M-2) ) MNN = MN + M - 1 G(MNN) = G(MNN)*P H(MNN) = H(MNN)*P ENDDO ENDDO C C NOW CALCULATE THE FIELD COMPONENTS C (IN CASE OF MULTIPLE INVOCATIONS WITH THE SAME VALUES OF IY AND NM, C CALCULATIONS START RIGHT HERE): C C 130 CONTINUE PP = 1./R P = PP K = NM+1 DO N = 1, K P = P*PP A(N) = P B(N) = P*N ENDDO P = 1. D = 0. BBR = 0. BBT = 0. BBF = 0. U = T CF = COS( F ) SF = SIN( F ) C = COS( U ) S = SIN( U ) DO M = 1, K IF ( M .EQ. 1 ) GOTO 160 MM = M - 1 W = X X = W*CF + Y*SF Y = Y*CF - W*SF GOTO 170 160 X = 0. Y = 1. 170 Q = P Z = D BI = 0. P2 = 0. D2 = 0. DO N = M, K AN = A(N) MN = N*(N-1)/2 + M E = G(MN) HH = H(MN) W = E*Y + HH*X BBR = BBR + B(N)*W*Q BBT = BBT - AN*W*Z IF ( M .EQ. 1 ) GOTO 180 QQ = Q IF ( S .LT. 1.E-5 ) QQ = Z BI = BI + AN*(E*X-HH*Y)*QQ 180 XK = REC(MN) DP = C*Z - S*Q - XK*D2 PM = C*Q - XK*P2 D2 = Z P2 = Q Z = DP Q = PM ENDDO D = S*D+C*P P = S*P IF ( M .EQ. 1 ) GOTO 200 BI = BI*MM BBF = BBF+BI 200 CONTINUE ENDDO BR = BBR BT = BBT IF ( S .LT. 1.E-5 ) GOTO 210 BF = BBF/S RETURN 210 IF ( C .LT. 0. ) BBF = -BBF BF = BBF RETURN END #endif #if __PARALLEL__ *-- Author : The CORSIKA development group 26/05/2009 C======================================================================= SUBROUTINE CUTREAD C----------------------------------------------------------------------- C CUT(FILE) READER C C FILL JSTACK FROM CUTFILE C ARGUMENTS: C CFILINP = FILE FROM WHICH THE CUTTED PARTICLES ARE READ C I1CUTPAR = INDEX OF FIRST PARTICLE TO BE READ C I2CUTPAR = INDEX OF LAST PARTICLE TO BE READ C----------------------------------------------------------------------- IMPLICIT NONE #define __BUFFSINC__ #define __ETHMAPINC__ #define __PAMINC__ #define __PARPARINC__ #define __RANDPAINC__ #define __RUNPARINC__ #define __STACKFINC__ #include "corsika.h" INTEGER I,J,NCUTPAR,ISTK,II LOGICAL FEXIST SAVE DATA ISTK / MAXSTK / C----------------------------------------------------------------------- #if !__PARALLELIB__ IF ( DEBUG ) WRITE(MONIOU,*) * ' READING THE CUT FILE FOR',I1CUTPAR,I2CUTPAR INQUIRE(FILE=CFILINP,EXIST=FEXIST) IF ( FEXIST ) THEN OPEN(UNIT=MPACUT,FILE=CFILINP,STATUS='OLD', * FORM='UNFORMATTED',ACCESS='SEQUENTIAL') ELSE WRITE(MONIOU,*) ' CUTREAD ERROR: CUTFILE :',CFILINP WRITE(MONIOU,*) ' DOES NOT EXIST !' STOP ENDIF #endif IF ( I1CUTPAR .LE. 0 ) THEN WRITE(MONIOU,*) ' CUTREAD ERROR: I1CUTPAR SHOULD BE > 0 !' STOP ENDIF IF ( I2CUTPAR .LE. I1CUTPAR ) I2CUTPAR = I1CUTPAR C READ PARTICLES IN FILE C CHANGE--------------------------------------------- by Sushant SCC NCUTPAR = 0 #if __PARALLELIB__ DO II = I1CUTPAR, I2CUTPAR CALL readparticle(CUTPAR,II) #else DO II = 1, I2CUTPAR READ( MPACUT ) CUTPAR IF ( II .GE. I1CUTPAR ) THEN #endif NCUTPAR = NCUTPAR + 1 IF ( .NOT. (FECTOUT .AND. NCUTPAR .GT. 1 ) ) THEN IF ( DEBUG ) WRITE(MONIOU,102) II,(CUTPAR(J),J = 0,18) 102 FORMAT (' PARAMETERS OF PARTICLE',I6,':',1P,19E11.3) C SAVE PARTICLE IN 2ND STACK IF ( MSTACKPJ .GE. ISTK ) THEN CALL FSTACKJO(1) WRITE(MEXSTJ,REC=NOURECJ+1) (STACKJ(I),I= 1,ISTK/2) WRITE(MEXSTJ,REC=NOURECJ+2) (STACKJ(I),I=ISTK/2+1,ISTK ) NOURECJ = NOURECJ + 2 NSHIFTJ = NSHIFTJ + 2 MSTACKPJ = 0 ENDIF NTOJ = NTOJ + 1 JCOUNT = JCOUNT + 1 C INITIALIZE ISEED FOR 6TH SEQUENCE HERE TO USE IT IN FILENAMES ISEED(1,6) = INT( CUTPAR(18) ) DO J = 0, 18 STACKJ(MSTACKPJ+J+1) = CUTPAR(J) ENDDO #if __MULTITHIN__ DO J = 19, 40 STACKJ(MSTACKPJ+J+1) = 0.D0 ENDDO DO J = 41, 46 STACKJ(MSTACKPJ+J+1) = CUTPAR(J) ENDDO #else DO J = 19, MAXLEN STACKJ(MSTACKPJ+J+1) = 0.D0 ENDDO #endif MSTACKPJ = MSTACKPJ + MAXLEN + 1 C COUNT ENERGY IN 2ND STACK BUT WITHOUT WEIGHT BECAUSE ONLY C PARTICLE ENERGY IS IMPORTANT HERE IF ( PAMA(NINT( CUTPAR(0) )) .LE. 0.D0 ) THEN ELEFTJ = ELEFTJ + CUTPAR(1) ELSE ELEFTJ = ELEFTJ + (CUTPAR(1)-1.D0)*PAMA(NINT(CUTPAR(0))) ENDIF ELSE WRITE(MONIOU,*) ' CUTREAD ERROR: ONLY ONE PARTICLE FROM CUTFILE', * ' IF PARALLEL=T' STOP ENDIF #if !__PARALLELIB__ ENDIF #endif ENDDO CLOSE( MPACUT ) RETURN END *-- Author : The CORSIKA development group 26/05/2009 C======================================================================= SUBROUTINE SENDCUT C----------------------------------------------------------------------- C CUT(FILE) WRITER C C TRANSFER PARTICLES FROM JSTACK TO CUTFILE C NOT ALL PARTICLES ARE SENT (BUT WITH REMAINING ENERGY SUM < ECTMAX/2) C SO STACKJ IS NOT EMPTY AND CAN EVEN GAIN NEW PARTICLES (JCOUNT.NE.1) C----------------------------------------------------------------------- IMPLICIT NONE #define __BUFFSINC__ #define __ETHMAPINC__ #define __PAMINC__ #define __PARPARINC__ #define __RUNPARINC__ #define __STACKFINC__ #define __THNVARINC__ #include "corsika.h" DOUBLE PRECISION ESUM,EPART INTEGER ILIST,NLIST,MXLIST,I,J,K,ISTK,KK,I0,II,ID,IBL,MXGRP C THE FOLLOWING PARAMETERS SHOULD BE CONSISTENT WITH MPIRUNNER PARAMETER (MXLIST=200001,MXGRP=2001) DIMENSION ILIST(MXLIST) #if __PARALLELIB__ INTEGER ISEED0 #endif SAVE DATA ISTK / MAXSTK / C----------------------------------------------------------------------- C RESET STACKINT DO K = 1, MAXICOUNT DO J = 0, MAXLEN STACKINT(J,K) = 0.D0 ENDDO ENDDO #if __PARALLELIB__ C RESET NUMBER OF PARTICLE IN LIST NLIST = 0 #endif C OPEN ECUT FILE #if !__PARALLELIB__ OPEN(UNIT=MPACUT,FILE=DSNCUT,STATUS='UNKNOWN', * FORM='UNFORMATTED',ACCESS='SEQUENTIAL') #endif IBL = INDEX(DSNCUT,' ') IF ( IBL .LE. 1 ) IBL = LEN(DSNCUT)+1 #if !__PARALLELIB__ C OPEN JOB LIST FILE OPEN(UNIT=MPAJOB,FILE=DSNJOB,STATUS='UNKNOWN', * FORM='FORMATTED',ACCESS='SEQUENTIAL') #endif KK = 0 II = 0 ESUM = 0.D0 NTOC = 0 C TRANSFER PARTICLES FROM 2ND STACK TO INTERMEDIATE STACK BUT STOP IF C REMAINING PARTICLES HAVE A KINETIC ENERGY SUM BELOW ECTMAX/2 C (NOT TO HAVE A TOO SHORT RUN) DO WHILE ( JCOUNT .GT. 1 .AND. * ( ELEFTJ .GT. ECTMAX*0.5D0 .OR. KK .NE. 0 ) ) IF ( MSTACKPJ .EQ. 0 ) THEN #if __THIN__ C READ LAST BLOCK OF 312 PARTICLES FROM 2ND SCRATCH FILE #else C READ LAST BLOCK OF 256 PARTICLES FROM 2ND SCRATCH FILE #endif READ(MEXSTJ,REC=NOURECJ) (STACKJ(I),I=1,ISTK/2) NOURECJ = NOURECJ - 1 MSTACKPJ = ISTK/2 ENDIF C ADD PARTICLE IN INTERMEDIATE STACK FROM 2ND STACK TO GROUP PARTICULES C BY ENERGY TO REACH ECTMAX NFROMJ = NFROMJ + 1 JCOUNT = JCOUNT - 1 C PUT PARTICLE FROM 2ND STACK INTO STACKINT MSTACKPJ = MSTACKPJ - MAXLEN - 1 KK = KK + 1 DO J = 0, 18 STACKINT(J,KK) = STACKJ(MSTACKPJ+J+1) ENDDO DO J = 19, MAXLEN STACKINT(J,KK) = 0.D0 ENDDO #if __MULTITHIN__ DO J = 41, 46 STACKINT(J,KK) = STACKJ(MSTACKPJ+J+1) ENDDO #endif ID = NINT(STACKINT(0,KK)) IF ( PAMA(ID) .LE. 0.D0 ) THEN EPART = STACKINT(1,KK) ELSE EPART = (STACKINT(1,KK) - 1.D0)*PAMA(ID) ENDIF C COUNT KINETIC ENERGY IN 2ND STACK BUT WITHOUT WEIGHT BECAUSE ONLY C PARTICLE ENERGY IS IMPORTANT HERE ELEFTJ = ELEFTJ - EPART C IF PARTICLE ENERGY ABOVE ECTMAX/2 WRITE IT DIRECTLY INTO ECUT IF ( EPART .GT. ECTMAX*0.5D0 ) THEN DO J = 0, 18 CUTPAR(J) = STACKINT(J,KK) C RESET STACKINT STACKINT(J,KK) = 0.D0 ENDDO #if __MULTITHIN__ DO J = 41, 46 CUTPAR(J) = STACKINT(J,KK) C RESET STACKINT STACKINT(J,K) = 0.D0 ENDDO #endif KK = KK - 1 II = II + 1 NTOC = NTOC + 1 #if __PARALLELIB__ CALL writeparticle(CUTPAR,MPIID,II) #else WRITE(MPACUT)CUTPAR #endif #if __PARALLELIB__ C ----> CALL MASTER HERE TO RUN A JOB WITH PARTICLE II !!!!!!!<------ NLIST=NLIST+1 IF ( NLIST .GT. MXLIST ) STOP 'TOO MANY PARTICLES SENT TO MPI' ILIST(NLIST)=II c call newparticle(II,II,DSNCUT) #else C WRITE JOB CALL OF SINGLE PARTICLE INTO JOB LIST FILE WRITE(MPAJOB,100)ECTCUT,ECTMAX,MPIID,'T',DSNCUT(1:IBL-1),II,II #endif c WRITE(MONIOU,*) ' particle ',ii,epart,epart/ectmax,JCOUNT,KK ELSE C GROUP PARTICLES UNTIL ENERGY IS ABOVE ECTMAX/2 OR KK REACHED THE C MAXIMUM NUMBER OF PARTICLE IN A GROUP (BECAUSE OF MPI LIMITATIONS) C AND WRITE THEM INTO ECUT ESUM = ESUM + EPART ENDIF C WRITE PARTICLES IN ECUT FILE IF ONE OF THE LIMIT IS REACHED IF ( ESUM .GT. ECTMAX*0.5D0 .OR. (JCOUNT .EQ. 1 .AND. KK .GT. 0) * .OR. KK .EQ. MXGRP ) THEN C INITIAL INDICE I0 = II + 1 C LOOP ON PARTICLES IN STACKINT DO K = 1, KK DO J = 0, 18 CUTPAR(J) = STACKINT(J,K) C RESET STACKINT STACKINT(J,K) = 0.D0 ENDDO #if __MULTITHIN__ DO J = 41, 46 CUTPAR(J) = STACKINT(J,K) C RESET STACKINT STACKINT(J,K) = 0.D0 ENDDO #endif II = II + 1 NTOC = NTOC + 1 #if __PARALLELIB__ CALL writeparticle(CUTPAR,MPIID,II) #else WRITE(MPACUT)CUTPAR #endif ENDDO #if __PARALLELIB__ C ---> CALL MPI (MPIID) HERE TO RUN A JOB WITH PARTICLE I0 TO II !!!!!!!<---- NLIST=NLIST+1 IF ( NLIST .GT. MXLIST ) STOP 'TOO MANY PARTICLES SENT TO MPI' ILIST(NLIST)=I0 c call newparticle(I0,II,DSNCUT) #else C WRITE JOB CALL OF PARTICLE GROUP INTO JOB LIST FILE WRITE(MPAJOB,100)ECTCUT,ECTMAX,MPIID,'F',DSNCUT(1:IBL-1),I0,II #endif c WRITE(MONIOU,*)' group of particles',i0,ii,esum,esum/ectmax, c * JCOUNT KK = 0 ESUM = 0.D0 ENDIF c WRITE(MONIOU,*)' energy',jcount,ntoc,nfromj,kk,eleftj, c * eleftj/ectmax ENDDO #if !__PARALLELIB__ CLOSE( MPACUT ) #endif c WRITE(MONIOU,*)' end',jcount,ntoc,nfromj,kk,eleftj, c * eleftj/ectmax #if __PARALLELIB__ C ----> CALL MASTER HERE TO SAY THAT TRANSFER IS COMPLETE !!!!!!!<------ NLIST=NLIST+1 IF ( NLIST .GT. MXLIST ) STOP 'TOO MANY PARTICLES SENT TO MPI' ILIST(NLIST)=II+1 READ(DSNCUT(IBL-23:IBL-15),*,ERR=999) ISEED0 call endOfFile(ILIST,NLIST,NRRUN,ISEED0,MPIID) #else WRITE(MPAJOB,*) 'END' CLOSE( MPAJOB ) 100 FORMAT(' PARALLEL ',1P,2(E16.9),I10,1X,1A,' CUTFILE ',A,2(I10)) #endif RETURN #if __PARALLELIB__ C ERROR OUTPUT 999 WRITE(MONIOU,6002) DSNCUT(IBL-33:IBL),IBL,DSNCUT(IBL-23:IBL-15) 6002 FORMAT(1X,'CUTFILE ',A,' PARAMETER',I3,' IS INVALID: ',A,'!') STOP 'STOP WITH PROBLEM IN SENDCUT' #endif END #endif *-- Author : The CORSIKA development group 26/05/2009 C======================================================================= INTEGER FUNCTION PRMINFO(iptr) C----------------------------------------------------------------------- C function to return the primary particle at first interaction information C FIRSTI: logical flag to indicate if primary interaction already occured c PDATA: use COAST CParticle data format for easier data transfer C----------------------------------------------------------------------- IMPLICIT DOUBLE PRECISION (A-H,O-Z) #define __OBSPARINC__ #define __PARPARINC__ #define __PAMINC__ #define __REJECTINC__ #define __RUNPARINC__ #include "corsika.h" integer*8 iptr common/CParticle/pntx, pnty, pntz, pntd, pntt, & pnte, pntw, pntid, pntgen double precision pntx, pnty, pntz, pntd, pntt, pnte, pntw integer pntid, pntgen LOGICAL PRMINF #if __CURVED__ DOUBLE PRECISION COSTEA,SINTEA,X,Y,XXX,YYY,RRR,PHI1 #endif SAVE C----------------------------------------------------------------------- PRMINFO = 0 c write (*,8002) 'pppp input iptr:', iptr, LOC(iptr) c 8002 format(A,X,Z16,X,Z16) c write (*,8003) 'pppp intern pntx:', pntx, LOC(pntx) c 8003 format(A,X,E20.5,X,Z16) c pntx=5. c write (*,8003) 'pppp test pntx=5: ', pntx, LOC(pntx) iptr=LOC(pntx) c write (*,8002) 'pppp iptr=LOC(pntx): ', iptr, LOC(iptr) IF ( PRMPAR(0) .LE. 3 ) THEN PRMINF = FNPRIM ELSE PRMINF = .not.FIRSTI ENDIF IF ( PRMINF ) THEN C FILL THE CParticle DATA pntid = nint(PRMPAR(0)) pntgen= 0.d0 ! this is primary particle. By definition, it is not generated... C POSITION OF INTERACTION #if __CURVED__ COSTEA = PRMPAR(16) X = PRMPAR(7) Y = PRMPAR(8) IF ( COSTEA .NE. 1.D0 ) THEN C WE ARE AWAY FROM DETECOR C CALCULATE AZIMUTH ANGLE OF PARTICLE SEEN FROM DETECTOR IF ( Y .NE. 0.D0 .OR. X .NE. 0.D0 ) THEN PHI1 = ATAN2( Y, X ) ELSE PHI1 = 0.D0 ENDIF SINTEA = SQRT( (1.D0-COSTEA)*(1.D0+COSTEA) ) C HORIZONTAL DISTANCE OF PARTICLE TO DETECTOR RRR = ( PRMPAR(14) + C(1) ) * SINTEA / COSTEA XXX = RRR * COS( PHI1 ) YYY = RRR * SIN( PHI1 ) ELSE C WE ARE IN THE DETECTOR SYSTEM AND NEED NO COORDINATE CALCULATION XXX = X YYY = Y ENDIF pntz = PRMPAR(14) ! HAPP pntx = XXX pnty = YYY #else pntz = PRMPAR(5) pntx = PRMPAR(7) - XOFF(NOBSLV) pnty = PRMPAR(8) - YOFF(NOBSLV) #endif C TRACK LENGTH (g/cm2) pntd = PRMPAR(9) C TIME pntt = PRMPAR(6) C ENERGY IN LAB FRAME IF ( PAMA(pntid) .EQ. 0.D0 ) THEN C PRIMARY ENERGY FOR MASSLESS PARTICLES (GAMMAS, NEUTRINOS) pnte = PRMPAR(1) ELSE pnte = PRMPAR(1) * PAMA(pntid) ENDIF pntw = 1.D0 PRMINFO = 1 ELSE c initialize the CParticle data pntid = -1 pntgen= -1 pntz = 1.D35 pntx = 1.D35 pnty = 1.D35 pntd = -1.D0 pntt = -1.D0 pnte = -1.D0 pntw = -1.D0 ENDIF IF ( DEBUG ) WRITE(MDEBUG,*) + 'PRMINFO (coast): id,x,y,z,d,t,e,w' + , pntid, pntx,pnty,pntz,pntd,pntt,pnte,pntw,PRMINFO RETURN END #else /* HAVE_CONFIG_H */ C======================================================================= PROGRAM AAMAIN C----------------------------------------------------------------------- WRITE(*,*)' CORSIKA not compiled properly (options not set)' WRITE(*,*)' missing preprocessor option HAVE_CONFIG_H' END #endif /* HAVE_CONFIG_H */