# 1 "corsika.F"
# 1 "<built-in>"
# 1 "<command-line>"

# 1 "/usr/include/stdc-predef.h" 1 3 4

# 17 "/usr/include/stdc-predef.h" 3 4























# 1 "<command-line>" 2
# 1 "corsika.F"










*TITLE : CORSIKA 7.7500  14/04/2023
*SVN: $HeadURL: https://devel-ik.fzk.de/svn/mc/corsika/trunk/src/corsika.F $
*REV: $Id$
*
*D. HECK AND T.PIEROG, IAP 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 ASTROTEILCHENPHYSIK
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.iap.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      FLUKACERN  VERSION USING FLUKA CERN VERSION
C      FLUKAINFN  VERSION USING FLUKA INFN VERSION
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    NRREXT     VERSION ENABLES EXTENDED RUN NUMBERS
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    UPWARDOLD  VERSION FOR UPWARD GOING PRIMARY FOR LONGITUDINAL PROFILE
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-----------------------------------------------------------------------


# 1 "../include/config.h" 1



































































































































































































































































































































































































































































































































































































































# 206 "corsika.F" 2






*-- 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
# 300 "corsika.F"
C  SIBYLL       L,I     SELECT SIBYLL FOR HIGH ENERGY HADRONIC INTERACT.
C                       AMOUNT OF SIBYLL DEBUG OUTPUT
C  SIBSIG         L     SELECT SIBYLL CROSS-SECTIONS






C  HILOW          F     SETS BORDER BETWEEN HIGH AND LOW ENERGY MODEL





C  URQMD        L,I     SELECT URQMD FOR LOW EN.HADR.INT.MODEL & DEBUG


C  PYTHIA        2I     MAX. WARNING AND ERRORS FOR PYTHIA PACKAGE
# 352 "corsika.F"
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.
# 366 "corsika.F"
C  IMPACT        2F     IMPACT PARAMETER RANGE FOR SKIMMING SHOWERS


C  TIMLIM         F     MAX. DISTANCE FOR PARTICLE CUT BY TIME LIMIT


C  CURVOUT        L     CURVED (FLAT) OBSERVATION LEVEL 
C  FLATOUT        L     FLAT (CURVED) OBSERVATIN LEVEL
# 424 "corsika.F"
C  OUTFILE      A132     DATASET NAME OF STACK OF FIRST INTERACTION OUTOUT FILE


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
# 449 "corsika.F"
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
# 486 "corsika.F"
C  SIBYLL  T  0 
C  SIBSIG  T





C  HILOW   80.





C  URQMD   T  0


C  PYTHIA   0  0

C  ECUTS   .3  .3  .003  .003
C  ECTMAP  1.E11
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







C  DIRECT 'anynameupto239characters/'
# 554 "corsika.F"
C  INCLIN 0. 0. OBSLEV(1) 0. 0.
# 566 "corsika.F"
C  IMPACT  0. 112.82920E5


C  TIMLIM   1.D8


C  CURVOUT    T   
C  FLATOUT    F
# 625 "corsika.F"
C  OUTFILE '       '


C  THIN    1.E-4  1.E30 0.
C  THINEM  1.  1.
C  THINH   1.  1.
# 647 "corsika.F"
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

C   ( BLOCKLENGTH = 26208 FIXED, ALL WORDS ARE 4 BYTES LONG )
C   EACH BLOCK CONSISTS OF 21 SUBBLOCKS OF 312 WORDS




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
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 (DEG)
C    79     PHI ANGLE OF THE NORMAL TO THE INCLINED OBSERVATION PLANE (DEG)
C    80     DEPTH ON THE AXIS FOR AUTOMATIC PLANE PERPENDICULAR TO SHOWER AXIS (IF >0, PREVIOUS NUMBERS ARE CHANGING EVENT BY EVENT)
C
C    80+I   0,       I=1,11      NO LONGER USED
C    92     ARRANG
C    93     NSHOW
C    94     FLAG FOR SLANT OPTION
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)

C   274..312  NOT USED

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)
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     INDEX OF MULTITHIN WEIGHT USED IN COAST
C   224     FLAG INDICATING THAT MUTLITHIN OUTPUT IS ACTIVE
C   225     X CARTESIAN COORDINATE OF THE ORIGIN OF THE INCLINED OBSERVATION PLANE RELATIVE TO SHOWER CORE
C   226     Y CARTESIAN COORDINATE OF THE ORIGIN OF THE INCLINED OBSERVATION PLANE RELATIVE TO SHOWER CORE
C   227     Z APPARENT HEIGHT OF THE ORIGIN OF THE INCLINED OBSERVATION PLANE RELATIVE TO SEA LEVEL AT THE VERTICAL OF CORE POSITION
C   228     THETA ANGLE OF THE NORMAL TO THE INCLINED OBSERVATION PLANE (RAD)
C   229     PHI ANGLE OF THE NORMAL TO THE INCLINED OBSERVATION PLANE (RAD)
C   230     DEPTH (SLANT OR VERTICAL) OF THE ORIGIN OF THE INCLINED OBSERVATION PLANE
C   231..273  NOT YET USED
C
C=======================================================================
C
C      PARTICLE DATA BLOCKS :
C      ======================
C

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
# 993 "corsika.F"
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

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
# 1031 "corsika.F"
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

C   274..312  NOT USED

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

C   268..312  NOT YET USED



C
C=======================================================================
C
C      END RUN
C      =======
C
C     1     'RUNE'
C     2     RUNNR




C      STATISTICS FOR RUN
C     3     NUMBER OF EVENTS PROCESSED
C     4     NOT USED

C

C     5..312  NOT YET USED



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-----------------------------------------------------------------------



# 1 "corsika.h" 1

C=======================================================================
C
C  DESCRIPTION OF GLOBAL VARIABLES USED IN THE COMMONS OF THE PROGRAM
C  ==================================================================
C  (IN ALPHABETIC ORDER OF COMMONS)
C





C --------------/CRAIR/--------------------------
C  COMPOS(3)   = COMPOSITION OF AIR, ATOMIC FRACTIONS OF N, O, AR
C  PROBTA(3)   = INTEGRATED ATOMIC FRACTIONS
C  AVERAW      = AVERAGE ATOMIC WEIGHT OF AIR
C  AVOGDR      = AVOGADROS NUMBER * MILLIBARN/CM**2
C
C --------------/CRATMOS/------------------------
C  AATM(5)     = ACTUAL COEFFICIENTS FOR PARAMETRIZATION OF ATMOSPHERE
C  AATM0(5,..) = COEFFICIENTS FOR PARAMETRIZATION OF ATMOSPHERE
C  BATM(5)     = ACTUAL COEFFICIENTS FOR PARAMETRIZATION OF ATMOSPHERE
C  BATM0(5,..) = COEFFICIENTS FOR PARAMETRIZATION OF ATMOSPHERE
C  CATM(5)     = ACTUAL COEFFICIENTS FOR PARAMETRIZATION OF ATMOSPHERE
C  CATM0(5,..) = COEFFICIENTS FOR PARAMETRIZATION OF ATMOSPHERE
C  DATM(5)     = 1. / CATM(I)
C  MODATM      = INDEX OF ATMOSPHERIC MODEL
C
C --------------/CRATMOS2/-----------------------
C  HLAY(6)     = ALTITUDE OF ACTUAL ATMOSPHERIC LAYER BOUNDARIES
C  HLAY0(5,..) = ALTITUDE OF ATMOSPHERIC LAYER BOUNDARIES
C  THICKL(5)   = THICKNESS AT ATMOSPHERIC LAYER BOUNDARIES
C  LAYNO(..)   = POINTER OF ATMOSPHERE TO LAYER NUMBER
C  LAYNEW      = FLAG INDICATING NEW ATMOSPHERIC LAYER BOUNDARIES
C
# 52 "corsika.h"
C --------------/CRATMOSL/-----------------------
C  MAXSLANT    = # OF POINTS FOR SLANT THICKNSS FUNCTION
C  MAXSLANT2   = # OF POINTS FOR SLANT THICKNSS FUNCTION IN ATM. LAYER
C  PATH1(.)    = SLANT PATH LENGTH FOR BIN
C  RHOSLT(.)   = DENSITY ALONG SLANT BIN
C  TSLANT(.)   = SLANT THICKNESS  TOP OF ATMOSPHERE TO BIN
C  HLAYS(6)    = SLANT PATH FROM TOP OF ATMOSPHERE TO LAYER BOUNDARY
C  RHOS(6)     = DENSITY AT LAYER BOUNDARY
C  THICKS(6)   = SLANT THICKNESS TOP OF ATMOSPHERE TO LAYER BOUNDARY
C  CCATM(5)    = LOG( BATM(I)/CATM(I) )
C  HLAYC(6)    = LAYER BOUNDARY (CM) FOR SLANT DEPTH CALCULATION
C  HGROUND     = ALTITUDE OF GROUND (= OBSLEV(1))
C  RADGRD      = RADIUS OF GROUND (= C(1) + HGROUND)
C  IENDT       = LAST BIN FOR SLANT DEPTH INTERPOLATION
C
# 84 "corsika.h"
C --------------/CRAVPT/-------------------------
C  AVPT        = AVERAGE TRANSVERSE MOMENTUM FOR PIONS
C  AVPK        = AVERAGE TRANSVERSE MOMENTUM FOR KAONS
C  AVPN        = AVERAGE TRANSVERSE MOMENTUM FOR NUCLEONS
C  AVPH        = AVERAGE TRANSVERSE MOMENTUM FOR STRANGE BARYONS
C  AVPE        = AVERAGE TRANSVERSE MOMENTUM FOR ETAS
C
C --------------/CRBOUNDS/-----------------------
C  (SEE EGS4 MANUAL)
C
C --------------/CRBREMPR/-----------------------
C  (SEE EGS4 MANUAL)
C
C --------------/CRBUFFS/------------------------
C  MAXBUF      = PARAMETER FOR MAXIMAL BUFFER SIZE
C  MAXLEN      = PARAMETER FOR SIZE OF PARTICLE FIELDS
C
C  RUNH(MAXBUF)= BUFFER FOR RUN   HEADER
C  RUNE(MAXBUF)= BUFFER FOR RUN   END
C  EVTH(MAXBUF)= BUFFER FOR EVENT HEADER
C  EVTE(MAXBUF)= BUFFER FOR EVENT END
C  DATAB(MAXBUF)= BUFFER FOR DATA
C  ARRAYLONG( )= BUFFER FOR LONGITUDINAL PARTICLE DISTRIBUTION
C  LH          = BUFFER POINTER

C  WRRUNH      = FLAG INDICATING RUNHEADER IS WRITTEN
C  WRRUNE      = FLAG INDICATING RUNEND    IS WRITTEN
C  WREVTH      = FLAG INDICATING EVTHEADER IS WRITTEN
C  WREVTE      = FLAG INDICATING EVTEND    IS WRITTEN

C
# 203 "corsika.h"
C --------------/CRCHISTA/-----------------------
C  IHYCHI(124) = INTERACTION LENGTH STATISTICS FOR STRANGE BARYONS
C  IKACHI(124) = INTERACTION LENGTH STATISTICS FOR KAONS
C  IMUCHI(124) = INTERACTION LENGTH STATISTICS FOR MUONS
C  INNCHI(124) = INTERACTION LENGTH STATISTICS FOR NUCLEI
C  INUCHI(124) = INTERACTION LENGTH STATISTICS FOR NUCLEONS
C  IPICHI(124) = INTERACTION LENGTH STATISTICS FOR PIONS
C  INECHI(124) = INTERACTION LENGTH STATISTICS FOR NEUTRINOS
C
C --------------/CRCONSTA/-----------------------
C  PI          = 3.14159...     SET IN BLOCK DATA
C  PI2         = 2 * PI
C  OB3         = ONE BY THREE = 1./3.
C  TB3         = TWO BY THREE = 2./3.
C  ENEPER      = 2.718281828 (EULER''S CONSTANT)
C  SQRT3       = SQRT(3.)
C





C --------------/CRCURVE/------------------------
C  CHAPAR      = ARRAY OF PARTICLE NUMBERS FOR LONGIT. DISTRIBUTION
C  DEP         = ARRAY OF DEPTH VALUES FOR LONGITUDINAL DISTRIBUTION
C  ERR         = ARRAY OF ERRORS OF PARTICLE NUMBERS IN LONG. DIST.
C  NSTP        = NUMBER OF STEPS FOR LONGITUDINAL DIST. FIT
C
C --------------/CRDECAYC/------------------------
C  GAM345(3)   = GAMMA FACTOR OF PARTICLE EMERGING FROM 3 BODY DECAY
C  COS345(3)   = COSINE THETA OF PARTICLE EMERGING FROM 3 BODY DECAY
C  PHI345(3)   = ANGLE  PHI   OF PARTICLE EMERGING FROM 3 BODY DECAY
C  CPHI345(3)  = COSINE PHI   OF PARTICLE EMERGING FROM 3 BODY DECAY
C  SPHI345(3)  = SINE   PHI   OF PARTICLE EMERGING FROM 3 BODY DECAY
C
# 249 "corsika.h"
C --------------/CRDPMFLG/-----------------------
C  NFLAIN      = 0  RANDOM NUMBER OF INTERACTIONS IN AIR TARGET
C              = 1  FIXED  NUMBER OF INTERACTIONS IN AIR TARGET
C  NFLDIF      = 0  NO DIFFRACTIVE INTERACTION IF NFLAIN = 0 AND MORE
C                   THAN 1 INTERACTION
C  NFLPI0      = 0  RAPIDITY OF PI0 TREATED ACCORDING TO COLLIDER DATA
C              = 1  RAPIDITY OF PI0 SAME AS THAT OF CHARGED
C  NFLCHE      = 0  CHARGE EXCHANGE INTERACTION POSSIBLE
C              = 1  NO CHARGE EXCHANGE INTERACTION POSSIBLE
C  NFLPIF      = 0  NO FLUCTUATION OF NUMBER OF PI0
C              = 1  FLUCTUATION OF NUMBER OF PI0 AS SEEN IN COLLIDER
C  NFRAGM      = 0  TOTAL FRAGMENTATION OF PRIMARY NUCLEUS IN 1.INTERACT
C              = 1  NO FRAGMENTATION AND NO EVAPORATION
C              = 2  REALISTIC FRAGMENTATION OR EVAPORATION (PT AFTER JACEE)
C              = 3  REALISTIC FRAGMENTATION OR EVAPORATION (PT AFTER GOLDHABER)
C              = 4  REALISTIC FRAGMENTATION OR EVAPORATION WITH PT-0
C
# 277 "corsika.h"
C --------------/CREDECAY/-----------------------
C  CETA(1)     = BRANCHING RATIO FOR ETA DECAY
C  CETA(2)     = BRANCHING RATIO FOR ETA DECAY
C  CETA(3)     = BRANCHING RATIO FOR ETA DECAY
C  CETA(4)     = ASYMMETRY TERM    IN DECAY  ETA-->PI(+) + PI(-) + PI(0)
C  CETA(5)     = MAXIMUM AMPLITUDE IN DECAY  ETA-->PI(+) + PI(-) + PI(0)
C






C --------------/CREGSDEB/-----------------------
C  JCLOCK      = PRESET COUNTER FOR EGS-DEBUG ACTIVATION
C  NCLOCK      = ACTUAL ELECTRON COUNTER FOR EGS-DEBUG
C  FEGSDB      = DEBUG FALG FOR EGS-DEBUGGING
C
C --------------/CRELABCT/-----------------------
C  ELCUT(.)    = CUT ON KINETIC ENERGY OF PARTICLES (HADR.,MU, E, GAMMA)
C
C --------------/CRELADPM/-----------------------
C  ELMEAN(40)  = MEAN ELASTICITY FOR ENERGY BINS PER SHOWER
C  ELMEAA(40)  = MEAN ELASTICITY FOR ENERGY BINS FOR ALL SHOWERS
C  IELDPM(.)   = ELASTICITY STATISTICS IN DUAL PARTON MODELL FOR SHOWER
C  IELDPA(.)   = ELASTICITY STATISTICS IN DUAL PARTON MODELL FOR ALL
C
C --------------/CRELASTY/-----------------------
C  ELAST       = ELASTICITY OF FIRST REACTION
C
C --------------/CRELECIN/-----------------------
C  (SEE EGS4 MANUAL)
C  STERNCOR    = PARAMETER FOR STERNHEIMER CORRECTION (SEE SUBR. ELECTR)
C
C --------------/CREPCONT/-----------------------
C  EDEP        = ENERGY DEPOSITED ALONG STEP
C  RATIO       = RATIO TOTAL STEP LENGTH/SCATTERING LENGTH FOR ELECTRONS
C  TSTEP       = DISTANCE TO NEXT INTERACTION
C  TUSTEP      = TOTAL (CURVED) STEP LENGTH REQUESTED
C  USTEP       = USER STEP LENGTH REQUESTED
C  TVSTEP      = ACTUAL TOTAL STEP LENGTH
C  VSTEP       = ACTUAL STEP LENGTH
C  RHOFAC      = DENSITY FACTOR
C  EOLD        = ENERGY AT BEGIN OF STEP
C  ENEW        = ENERGY AT END OF STEP
C  EKE         = KINETIC ENERGY OF ELECTRON
C  ELKE        = LOGARITHM OF ELECTRON KINETIC ENERGY
C  BETA2       = VELOCITY OF ELECTRON SQUARED
C  GLE         = LOGARITHM OF GAMMA ENERGY
C  TSCAT       = SEE EQ. 2.14.82 IN SLAC-265
C  IDISC       = FLAG INDICATING PARTICLE IS TO BE DISCARDED
C  IROLD       = INDEX OF OLD ATMOSPERIC LAYER
C  IRNEW       = INDEX OF NEW ATMOSPHERIC LAYER
C
C --------------/CRETHMAP/-----------------------
C  ECTMAP      = CUT TO PRINT OUT PARTICLES
C  ELEFT       = SUMMED ENERGY OF PARTICLES ON STACK



C






C --------------/CRGENER/------------------------
C  GEN         = GENERATION OF PARTICLE
C  ALEVEL      = LEVEL OF LAST HADRONIC INTERACTION
C
C --------------/GHEISHA COMMONS/----------------
C             SEE: GHEISHA ROUTINES
C
C --------------/CGCOMP/-------------------------
C  ACOMP       = ATOMIC WEIGHT OF COMPONENT (GHEISHA)
C  ZCOMP       = ATOMIC NUMBER OF COMPONENT (GHEISHA)
C  WCOMP       = ATOMIC FRACTION OF COMPONENT (GHEISHA)
C  KK          = NUMBER OF TARGET COMPONENTS (GHEISHA)
C
C --------------/CRGEOMEGS/----------------------
C  ZALTIT      = STARTING ALTITUDE (EGS4)
C  BOUND       = BOUNDARIES OF ATMOSPHERIC LAYERS (EGS4)
C  OBSLVL      = OBSERVATION LEVEL (EGS4)
C  OBSLV2      = OBSERVATION LEVEL - 1G/CM**2 (EGS4 AUGERHIST)
C  NEWOBS      = POINTER FOR NEXT OBSERVATION LEVEL (EGS4)
C
# 374 "corsika.h"
C --------------/CRGNUPR/------------------------
C  SE14(.)     = ARRAY FOR COLLISION PROBABILITY
C  SE16(.)     = ARRAY FOR COLLISION PROBABILITY
C  SE40(.)     = ARRAY FOR COLLISION PROBABILITY
C

C --------------/CRINCLINED/------------------------
C  XPINCL      = X COORDINATE OF INCLINED OBSERVATION PLANE
C  YPINCL      = Y COORDINATE OF INCLINED OBSERVATION PLANE
C  ZPINCL      = Z COORDINATE OF INCLINED OBSERVATION PLANE
C  THINCL      = THETA ANGLE OF THE NORMAL TO THE INCLINED OBSERVATION PLANE
C  PHINCL      = PHI ANGLE OF THE NORMAL TO THE INCLINED OBSERVATION PLANE
C  TDINCL      = DEPTH ON THE AXIS FOR AUTOMATIC PLANE PERPENDICULAR TO SHOWER AXIS 
C

C --------------/CRINDICE/-----------------------
C  NNUCN(.)    = # OF NEUTRON       PAIRS  IN 1ST + 2ND / 3RD STRING
C  NKA0(.)     = # OF NEUTRAL KAON  PAIRS  IN 1ST + 2ND / 3RD STRING
C  NHYPN(.)    = # OF NEUTR.STR.BAR.PAIRS  IN 1ST + 2ND / 3RD STRING
C  NETA(I,K)   = # OF ETAS                 IN 1ST + 2ND / 3RD STRING
C                SEPARATELY DEFINED FOR EACH DECAY MODE K
C  NETAS(I)    = # OF ETAS                 IN 1ST + 2ND / 3RD STRING
C  NPIZER(.)   = # OF PI(0)S               IN 1ST + 2ND / 3RD STRING
C  NNC         = # OF PROTON                 PAIRS
C  NKC         = # OF CHARGED KAON           PAIRS
C  NHC         = # OF CHARGED STRANGE BARYON PAIRS
C  NPC         = # OF CHARGED PIONS
C  NCH         = # OF CHARGED PARTICLES
C  NNN         = TOTAL # OF NEUTRON        PAIRS
C  NKN         = TOTAL # OF NEUTRAL KAON   PAIRS
C  NHN         = TOTAL # OF NEUTR.STR.BAR. PAIRS
C  NET         = TOTAL # OF ETAS
C  NPN         = TOTAL # OF PI(0)S
C
C --------------/CRINTER/------------------------
C  AVCH        = AVERAGE # OF CHARGED PARTICLES
C  AVCH3       = AVERAGE # OF CHARGED PARTICLES IN 3RD STRING
C  DC0         = AVERAGE DENSITY AT CENTRE OF RAPIDITY
C  DLOGS       = LOG OF DIFFRACTIVE MASS SQUARED
C  DMLOG       = LOG(ECMDIF**2 - MASS PI(0)**2 - MASS DIFFR.PART.**2)
C  ECMDIF      = DIFFRACTIVE MASS FOR HDPM
C  ECMDPM      = C.M ENERGY FOR HDPM
C  ELAB        = LAB ENERGY OF INCOMING PARTICLE IN SDPM/HDPM
C  FNEUT       = # OF NEUTRAL PARTICLES (ALL 3 STRINGS)  WITH FLUCTUAT
C  FNEUT2      = # OF NEUTRAL PARTICLES (1ST+2ND STRING) WITH FLUCTUAT
C  GNU         = # OF COLLISIONS IN TARGET
C  PLAB        = MOMENTUM OF INCOMING PARTICLE IN LAB SYSTEM
C  POSC2       = POSITION OF GAUSSIAN FOR 1ST+2ND STRING (CHARGED)
C  POSC3       = POSITION OF GAUSSIAN FOR 3RD     STRING (CHARGED)
C  POSN2       = POSITION OF GAUSSIAN FOR 1ST+2ND STRING (NEUTRAL)
C  POSN3       = POSITION OF GAUSSIAN FOR 3RD     STRING (NEUTRAL)
C  RC3TO2      = RATIO (CHARGED OF 3RD STRING)/(CHARGED 1ST+2ND STRING)
C  S           = C.M. ENERGY SQUARED
C  SEUGF       = NUMBER OF GAMMAS (WITH FLUCTUATION)
C  SEUGP       = NUMBER OF GAMMAS (AVERAGE PARAMETRIZED)
C  SLOG        = LOG OF C.M.ENERGY SQUARED
C  SLOGSQ      = SQUARE OF LOG OF C.M.ENERGY SQUARED
C  SMLOG       = LOG ( C.M. ENERGY SQUARED  - 2 * NUCL.MASS**2 )(HDPM)
C  WIDC2       = WIDTH    OF GAUSSIAN FOR 1ST+2ND STRING (CHARGED)
C  WIDC3       = WIDTH    OF GAUSSIAN FOR 3RD     STRING (CHARGED)
C  WIDN2       = WIDTH    OF GAUSSIAN FOR 1ST+2ND STRING (NEUTRAL)
C  WIDN3       = WIDTH    OF GAUSSIAN FOR 3RD     STRING (NEUTRAL)
C  YCM         = RAPIDITY OF CM SYSTEM IN LABORATORY
C  YY0         = RAPIDITY OF DIFFRACTIVE SYSTEM IN CMS
C  ZN          = CENTR. RAP. DENSITY FOR CALCULATION OF PT
C  IDIF        = DIFFRACTION FLAG IN HDPM
C  ITAR        = PARTICLE CODE OF TARGET NUCLEON IN HDPM
C
C --------------/CRIRET/-------------------------
C  IRET1       = RETURN CODE; IRET1=1: PARTICLE CUTTED
C  IRET2       = RETURN CODE; IRET2=1: PARTICLE CUTTED IN UPDATE
C  IRETE       = RETURN CODE; IRETE=T: ENERGY CUT (LOGICAL) IN UPDATE
C
C --------------/CRISTA/-------------------------
C  IFINET      = # ETAS PRODUCED IN FIRST INTERACTION
C  IFINNU      = # NUCLEONS PRODUCED IN FIRST INTERACTION
C  IFINKA      = # KAONS PRODUCED IN FIRST INTERACTION
C  IFINPI      = # PIONS PRODUCED IN FIRST INTERACTION
C  IFINHY      = # STRANG BARYONS PRODUCED IN FIRST INTERACTION
C  IFINCM      = # CHARMED PART. PRODUCED IN FIRST INTERACTION
C  IFINOT      = # OTHER HADRONS PRODUCED IN FIRST INTERACTION
C  IFINRHO     = # RHO MESONS PRODUCED IN FIRST INTERACTION
C
C --------------/CRKAONS/------------------------
C  CKA(.)      = PHYSICAL CONSTANTS FOR KAONS
C  CKA(2)      = MEAN FOR KAON LONG. MOMENTUM COMING FROM VHMESO
C  CKA(23)     = BRANCH RATIO K(+,-) DECAY
C  CKA(24)     = BRANCH RATIO K0S DECAY
C  CKA(25)     = BRANCH RATIO K0L DECAY
C  CKA(26)     = BRANCH RATIO K0L DECAY
C  CKA(27)     = BRANCH RATIO K0L DECAY
C  CKA(47)     = BRANCH RATIO K(+,-) DECAY
C  CKA(48)     = BRANCH RATIO K(+,-) DECAY
C  CKA(49)     = BRANCH RATIO K(+,-) DECAY
C  CKA(50)     = BRANCH RATIO K(+,-) DECAY
C  CKA(51)     = G     OF K+,- ===> PI+,- + PI+,- + PI-,+
C  CKA(52)     = H     OF K+,- ===> PI+,- + PI+,- + PI-,+
C  CKA(53)     = K     OF K+,- ===> PI+,- + PI+,- + PI-,+
C  CKA(54)     = AMPMX OF K+,- ===> PI+,- + PI+,- + PI-,+
C  CKA(55)     = G     OF K+,- ===> PI0 + PI0 + PI+,-
C  CKA(56)     = H     OF K+,- ===> PI0 + PI0 + PI+,-
C  CKA(57)     = K     OF K+,- ===> PI0 + PI0 + PI+,-
C  CKA(58)     = AMPMX OF K+,- ===> PI0 + PI0 + PI+,-
C  CKA(59)     = G,H,K OF K0L ===> PI0 + PI0 + PI0
C  CKA(60)     = AMPMX OF K0L ===> PI0 + PI0 + PI0
C  CKA(61)     = G     OF K0L ===> PI+ + PI- + PI0
C  CKA(62)     = H     OF K0L ===> PI+ + PI- + PI0
C  CKA(63)     = K     OF K0L ===> PI+ + PI- + PI0
C  CKA(64)     = AMPMX OF K0L ===> PI+ + PI- + PI0
C  CKA(65)     = LAMBDA-PLUS OF K+,- ===> PI0 + E + NU
C  CKA(66)     = LAMBDA-ZERO OF K+,- ===> PI0 + E + NU
C  CKA(67)     = AMPMX       OF K+,- ===> PI0 + E + NU
C  CKA(68)     = LAMBDA-PLUS OF K+,- ===> PI0 + MU + NU
C  CKA(69)     = LAMBDA-ZERO OF K+,- ===> PI0 + MU + NU
C  CKA(70)     = AMPMX       OF K+,- ===> PI0 + MU + NU
C  CKA(71)     = LAMBDA-PLUS OF K0L ===> PI + E + NU
C  CKA(72)     = LAMBDA-ZERO OF K0L ===> PI + E + NU
C  CKA(73)     = AMPMX       OF K0L ===> PI + E + NU
C  CKA(74)     = LAMBDA-PLUS OF K0L ===> PI + MU + NU
C  CKA(75)     = LAMBDA-ZERO OF K0L ===> PI + MU + NU
C  CKA(76)     = AMPMX       OF K0L ===> PI + MU + NU
C
C --------------/CRLAYER/------------------------
C  HBARO       = BAROMETRIC EXPONENT OF ATMOSPHERIC LAYER (EGS4)
C  HBAROI      = INVERSE OF BAROMETRIC EXP. OF ATMOSPHERIC LAYER (EGS4)
C
C --------------/CRLEPAR/------------------------
C  LEPAR1      = TYPE OF LEADING PARTICLE BEFORE / AFTER CHARGE EXCHANGE
C  LEPAR2      = TYPE OF TARGET  PARTICLE BEFORE / AFTER CHARGE EXCHANGE
C  LASTPI      = # OF CHARGED PIONS CREATED/DELETED BY CHARGE EXCHANGE
C  NRESPC      = # OF CHARGED PIONS TO BE CREATED BY RESONANCE DECAY
C  NRESPN      = # OF NEUTRAL PIONS TO BE CREATED BY RESONANCE DECAY
C  NCPLUS      = POSITIVE CHARGE EXCESS BY RESONANCE/CHARGE EXCHANGE
C
C --------------/CRLONGI/------------------------
C  LNGMAX      = MAXIMUM ARRAY LENGTH OF LONGI ARRAYS (=15000)
C  ADLONG(I,K) = AVERAGE OF DLONG OVER ALL SHOWERS
C  AELONG(I,K) = AVERAGE OF ELONG OVER ALL SHOWERS
C  APLONG(I,K) = AVERAGE OF PLONG OVER ALL SHOWERS
C  DLONG(I,K)  = LONGITUDINAL ENERGY DEPOSITS PER SHOWER IN I BINS FOR
C                1=ABSORBED GAMMAS, 2=EM-IONIZATION, 3=E-CUTTED EM,
C                4=MU-& MU+ IONOZATION, 5= E-CUTTED MUONS,
C                6=HADRON IONIZATION, 7=E-CUTTED HADRONS, 8=NEUTRINO,
C                9=SUM OF DEPOSITS, 10=DUMMY,
C                11=ANGL. CUTTED GAMMAS, 12=DUMMY, 13=ANGL. CUTTED EM,
C                14=DUMMY, 15=ANGL. CUTTED MUONS, 16=DUMMY,
C                17=ANGL. CUTTED HADRONS, 18=ANGL. CUTTED NEUTRINOS,
C                19=DUMMY
C  ELONG(I,K)  = LONGITUDINAL ENERGY DISTRIBUTIONS PER SHOWER IN I
C                BINS FOR K= GAMMAS, POSITRONS, ELECTRONS, MU+, MU-,
C                HADRONS, CHARGED, NUCLEI, CHERENKOV PHOTONS, NEUTRINOS
C  HLONG(I)    = THE HEIGHT VALUES IN CM FOR THE LEVELS IN G/CM**2
C  PLONG(I,K)  = LONGITUDINAL PARTICLE DISTRIBUTIONS PER SHOWER IN I
C                BINS FOR K= GAMMAS, POSITRONS, ELECTRONS, MU+, MU-,
C                HADRONS, CHARGED, NUCLEI, CHERENKOV PHOTONS, NEUTRINOS
C  SDLONG(I,K) = STANDARD DEVIATION OF DLONG
C  SELONG(I,K) = STANDARD DEVIATION OF ELONG
C  SPLONG(I,K) = STANDARD DEVIATION OF PLONG
C  THSTEP      = STEP WIDTH IN G/CM**2 FOR LONGITUDINAL DISTRIBUTION
C  THSTPI      = 1/THSTEP
C  LHEIGH      = STEP NUMBER AT INTERACTION POINT
C  NSTEP       = NUMBER OF STEPS FOR LONGITUDINAL DISTRIBUTION
C  LLONGI      = LOGICAL TO STEER THE SAMPLING OF LONGITUDINAL DISTRIBUTION
C  FLGFIT      = LOGICAL TO ENABLE/DISABLE FIT TO CHARGED PART. LONG. DISTR.
C

C - - - - - - - /CRSLANT/ - - - - - - - - - - - -
C  RLONG(.)    = ARRAY FOR DISTANCES TO PLANE NORMAL TO SHOWER AXIS
C  THCKRL(.)   = ARRAY FOR THICKNESS TO PLANE NORMAL TO SHOWER AXIS
C  CTH         = COSINE OF PRIMARY FOR PLANE NORMAL TO SHOWER AXIS
C  STHCPH      = SINTHE*COSPHI OF PRIMARY FOR PLANE NORM. TO SHOWER AXIS
C  STHSPH      = SINTHE*SINPHI OF PRIMARY FOR PLANE NORM. TO SHOWER AXIS
C  RLOFF       = OFFSET OF PLANE NORMAL TO SHOWER AXIS
C

C --------------/CRMAGANG/-----------------------
C  ARRANG      = ANGLE (DEG) ARRAY X-DIRECTION AND MAGNETIC NORD
C  ARRANR      = ANGLE (RAD) ARRAY X-DIRECTION AND MAGNETIC NORD
C  COSANG      = COSINE OF ARRANR
C  SINANG      = SIN OF ARRANR
C
C --------------/CRMAGNET/-----------------------
C  BX          = MAGNET FIELD STRENGTH COMPONENT TO NORTH [MICROTESLA]
C  BZ          = MAGNET FIELD STRENGTH COMPONENT DOWNWARD [MICROTESLA]
C  BVAL        = SQUARED MAGNET FIELD STRENGTH
C  BNORMC      = MAGNETIC DEFLECTION CONSTANT [GEV/CM]
C  BNORM       = MAGNETIC DEFLECTION CONSTANT [MEV/CM]
C  COSB        = COS OF INCLINATION ANGLE
C  SINB        = SIN OF INCLINATION ANGLE
C  BLIMIT      = LIMIT FACTOR FOR STEP SIZE OF ELECTRONS IN MAGN.FIELD
C
C --------------/CRMEDIA/------------------------
C  (SEE EGS4 MANUAL)
C
C --------------/CRMEDIAC/------------------------
C  (SEE EGS4 MANUAL)
C
C --------------/CRMISC/--------------------------
C  (SEE EGS4 MANUAL)
C
C --------------/CRMPARTI/-----------------------
C  MPARTO(.)   = ARRAY FOR MEAN # OF PARTICLES
C  MPHOTO(20)  = MEAN # OF GAMMAS WRITTEN TO TAPE PER LEVEL
C  MPOSIT(20)  = MEAN # OF E+ WRITTEN TO TAPE PER LEVEL
C  MELECT(20)  = MEAN # OF E- WRITTEN TO TAPE PER LEVEL
C  MNU(20)     = MEAN # OF NEUTRINOS WRITTEN TO TAPE PER LEVEL
C  MMUP(20)    = MEAN # OF MU+ WRITTEN TO TAPE PER LEVEL
C  MMUM(20)    = MEAN # OF MU- WRITTEN TO TAPE PER LEVEL
C  MPI0(20)    = MEAN # OF PI(0) WRITTEN TO TAPE PER LEVEL
C  MPIP(20)    = MEAN # OF PI+ WRITTEN TO TAPE PER LEVEL
C  MPIM(20)    = MEAN # OF PI- WRITTEN TO TAPE PER LEVEL
C  MK0L(20)    = MEAN # OF K0L WRITTEN TO TAPE PER LEVEL
C  MKPL(20)    = MEAN # OF K + WRITTEN TO TAPE PER LEVEL
C  MKMI(20)    = MEAN # OF K - WRITTEN TO TAPE PER LEVEL
C  MNEUTR(20)  = MEAN # OF NEUTRONS WRITTEN TO TAPE PER LEVEL
C  MPROTO(20)  = MEAN # OF PROTONS WRITTEN TO TAPE PER LEVEL
C  MPROTB(20)  = MEAN # OF ANTIPROTONS WRITTEN TO TAPE PER LEVEL
C  MK0S(20)    = MEAN # OF K0S WRITTEN TO TAPE PER LEVEL
C  MHYP(20)    = MEAN # OF STRANGE BARYONS WRITTEN TO TAPE PER LEVEL
C  MDEUT(20)   = MEAN # OF DEUTERONS WRITTEN TO TAPE PER LEVEL
C  MTRIT(20)   = MEAN # OF TRITONS WRITTEN TO TAPE PER LEVEL
C  MHELI3(20)  = MEAN # OF 3HELIUM WRITTEN TO TAPE PER LEVEL
C  MALPHA(20)  = MEAN # OF ALPHAS WRITTEN TO TAPE PER LEVEL
C  MCHRMM(20)  = MEAN # OF CHARMED MESONS WRITTEN TO TAPE PER LEVEL
C  MCHRMB(20)  = MEAN # OF CHARMED BARYONS WRITTEN TO TAPE PER LEVEL
C  MOTHER(20)  = MEAN # OF OTHER PARTICLES WRITTEN TO TAPE PER LEVEL
C  MMUOND      = MEAN # OF MUONS DECAYED TO ELECTRONS/POSITRONS
C  MNEUTB(20)  = MEAN # OF ANTINEUTRONS WRITTEN TO TAPE PER LEVEL
C  MMUONE      = MEAN # OF MUONS ELIMINATED BECAUSE OF ENERGY/ANGULAR CUT
C
C --------------/CRMULT/-------------------------
C  EKINL       = ENERGY FOR ENERGY-MULTIPLICITY MATRIX
C  MSMM        = MULTIPLICITY FOR ENERGY-MULTIPLICITY MATRIX
C  MULTMA(.)   = ENERGY-MULTIPLICITY MATRIX FOR SHOWER
C  MULTOT(.)   = ENERGY-MULTIPLICITY MATRIX FOR SHOWER GROUP
C
# 625 "corsika.h"
C --------------/CRMULTS/-------------------------
C  (SEE EGS4 MANUAL)
C
C --------------/CRMUMULT/-----------------------
C  CHC         = CONSTANT CHI_C   FOR MUOMN MULTIPLE SCATTERING
C  OMC         = CONSTANT OMEGA_C FOR MUOMN MULTIPLE SCATTERING
C  PHISCT      = AZIMUTAL ANGLE OF MUON MULTIPLE SCATTERING
C  CPHISCT     = COSINE OF AZIMUTAL ANGLE OF MUON MULTIPLE SCATTERING
C  SPHISCT     = SINE   OF AZIMUTAL ANGLE OF MUON MULTIPLE SCATTERING
C  STEPL       = STEP LENGTH FOR MUON TRANSPORT STEP
C  VSCAT       = POLAR ANGLE OF MUON MULTIPLE SCATTERING
C  FMOLI       = FLAG INDICATING MOLIERE (T) OR GAUSS (F) SCATTERING
C
C --------------/CRMUON/-------------------------
C  PRRMMU      = REST MASS OF MUON (EGS4)
C  RMMUT4      = 4 * REST MASS OF MUON (EGS4)
C
C --------------/CRMUPART/-----------------------
C  AMUPAR(0:..)= REGISTER FOR MUON PARTICLE ADDITIONAL INFO
C  BCUT        = CUT-OFF ENERGY FOR MUON/TAU BREMSSTRAHLUNG
C  CMUON(11)   = CONSTANTS FOR MUON BREMSSTRAHLUNG CALCULATION
C  CTAU(11)    = CONSTANTS FOR TAU  BREMSSTRAHLUNG CALCULATION
C  AATOM       = NUCLEONS IN TARGET FOR MUON/TAU INTERACTIONS
C  CONSTKINE   = KINEMATIC CONSTANT FOR MUON/TAU INTERACTIONS
C  EBYMU       = MASS RATION ELECT. MASS / MUON MASS
C  EBYTAU      = MASS RATION ELECT. MASS / TAU  MASS
C  EE          = TOTAL ENERGY OF MUON/TAU FOR INTERACTIONS
C  SE          = SQUARE ROOT OF E_NEPER
C  VFRAC       = ENERGY FRACTION FOR SECONDARY IN MUON/TAU INTERACTION
C  VMAX        = MAX. VALUE OF ENERGY FRACTION FOR MUON/TAU INTERACT.
C  VMIN        = MIN. VALUE OF ENERGY FRACTION FOR MUON/TAU INTERACT.
C  ZATOM       = ATOMIC NUMBER OF TARGET FOR MUON/TAU INTERACTIONS
C  MT          = FLAG INDICATING MU(=1) OR TAU(=2)
C  FMUBRM      = FLAG TO INDICATE MUON/TAU HAS TO UNDERGO BREMSSTRAHLUNG
C  FMUNUC      = FLAG TO INDICATE MUON/TAU HAS TO UNDERGO NUCL.INTERACT.
C  FMUORG      = FLAG TO INDICATE WHETHER MUON BELONGS TO AMUPAR(.)
C
C --------------/CRNCSNCS/-----------------------
C  SIGN30(.)   = ARRAY FOR CROSS-SECTIONS NITROGEN
C  SIGN45(.)   = ARRAY FOR CROSS-SECTIONS NITROGEN
C  SIGN60(.)   = ARRAY FOR CROSS-SECTIONS NITROGEN
C  SIGO30(.)   = ARRAY FOR CROSS-SECTIONS OXYGEN
C  SIGO45(.)   = ARRAY FOR CROSS-SECTIONS OXYGEN
C  SIGO60(.)   = ARRAY FOR CROSS-SECTIONS OXYGEN
C  SIGA30(.)   = ARRAY FOR CROSS-SECTIONS ARGON
C  SIGA45(.)   = ARRAY FOR CROSS-SECTIONS ARGON
C  SIGA60(.)   = ARRAY FOR CROSS-SECTIONS ARGON
C  PNOA30(.)   = ARRAY FOR PROBABILITY OF # OF INTERACTIONS
C  PNOA45(.)   = ARRAY FOR PROBABILITY OF # OF INTERACTIONS
C  PNOA60(.)   = ARRAY FOR PROBABILITY OF # OF INTERACTIONS
C  SIG30A(.)   = ARRAY FOR CROSS-SECTIONS AIR
C  SIG45A(.)   = ARRAY FOR CROSS-SECTIONS AIR
C  SIG60A(.)   = ARRAY FOR CROSS-SECTIONS AIR
C
C --------------/CRNEWPAR/-----------------------
C  EA(3000)    = ENERGY            OF SECONDARY PARTICLE IN HDPM
C  PT2(3000)   = PT**2             OF SECONDARY PARTICLE IN HDPM
C  PX(3000)    = PT IN X DIRECTION OF SECONDARY PARTICLE IN HDPM
C  PY(3000)    = PT IN Y DIRECTION OF SECONDARY PARTICLE IN HDPM
C  TMAS(3000)  = TRANSVERSE MASS   OF SECONDARY PARTICLE IN HDPM
C  YR(3000)    = RAPIDITY          OF SECONDARY PARTICLE IN HDPM
C  ITYP(3000)  = PARTICLE TYPE     OF SECONDARY PARTICLE IN HDPM
C  IA1 ... IJ1 = LOWER BOUNDARY OF PARTICLE SPECIES
C  IA2 ... II2 = UPPER BOUNDARY OF PARTICLES 3RD STRING
C  NTOT        = TOTAL NUMBER OF PARTICLES
C
# 714 "corsika.h"
C --------------/CRNKGI/-------------------------
C  SEL(10)     = USED FOR AVERAGING OF SL(10)
C  SELLG(10)   = USED FOR LOGARITHMIC AVERAGING OF SL(10)
C  STH(10)     = AGE IN STEPS OF 100 G/CM**2, SUM OVER ALL SHOWERS
C  ZEL(10)     = USED FOR FLUCTUATION OF SEL(10)
C  ZELLG(10)   = USED FOR FLUCTUATION OF SELLG(10)
C  ZSL(10)     = USED FOR FLUCTUATION OF STH(10))
C  DIST(10)    = DISTANCES FROM CORE IN CM (USED BY AVAGE)
C  DISX(.)     = DISTANCES OF BINS FOR RADIAL DISTRIBUTION IN X  (IN CM)
C  DISY(.)     = DISTANCES OF BINS FOR RADIAL DISTRIBUTION IN Y  (IN CM)
C  DISXY(.)    = DISTANCES OF BINS FOR RADIAL DISTRIBUTION IN XY (IN CM)
C  DISYX(.)    = DISTANCES OF BINS FOR RADIAL DISTRIBUTION IN YX (IN CM)
C  DLAX(.)     = USED FOR AVERAGING OF CZX
C  DLAY(.)     = USED FOR AVERAGING OF CZY
C  DLAXY(.)    = USED FOR AVERAGING OF CZXY
C  DLAYX(.)    = USED FOR AVERAGING OF CZYX
C  OBSATI(2)   = OBSERVATION LEVELS IN CM (USED IN NKG) (MAX. 2)
C  RADNKG      = RADIUS RANGE FOR NKG ELECTRON DENSITIES IN CM
C  RMOL(1)     = MOLIERE RADIUS IN AIR IN CM AT LOWER LEVEL
C  RMOL(2)     = MOLIERE RADIUS IN AIR IN CM AT HIGHER LEVEL
C  TLEV(10)    = LEVELS IN NKG IN G/CM**2
C  TLEVCM(10)  = LEVELS IN NKG IN CM
C  IALT(2)     = # OF LEVELS IN NKG FOR WHICH ELECT.DENSITIES ARE CALCUL
C
C --------------/CRNKGS/-------------------------
C  CZX(.)      = LATERAL DIST. OF ELECTRONDENSITY IN X (NKG) (/CM**2)
C  CZY(.)      = LATERAL DIST. OF ELECTRONDENSITY IN Y (NKG) (/CM**2)
C  CZXY(.)     = LATERAL DIST. OF ELECTRONDENSITY IN XY (NKG) (/CM**2)
C  CZYX(.)     = LATERAL DIST. OF ELECTRONDENSITY IN YX (NKG) (/CM**2)
C  SAH(10)     = AGE IN STEPS OF 100 G/CM**2
C  SL(10)      = NUMBER OF ELECTRONS IN STEPS OF 100 G/CM**2
C  ZNE(10)     = PARAMETER USED FOR LONGITUDINAL AGE CALCULATION
C
C --------------/CRNKGSUB/-----------------------
C  XXOLD       = COORDINATE OF EM PARTICLE FOR SUBTRACT. FROM NKG (EGS4)
C  YYOLD       = COORDINATE OF EM PARTICLE FOR SUBTRACT. FROM NKG (EGS4)
C  ZZOLD       = COORDINATE OF EM PARTICLE FOR SUBTRACT. FROM NKG (EGS4)
C
C --------------/CRNPARTI/-----------------------
C  NPARTO(.)   = ARRAY CONTAINING  # OF PARTICLES AT OBSERVATION LEVEL
C  NPART2(.)   = ARRAY CONTAINING  # OF PARTICLES AT OBSERVATION LEVEL
C  NPHOTO(20)  = # OF GAMMAS WRITTEN TO TAPE PER LEVEL
C  NPOSIT(20)  = # OF E+ WRITTEN TO TAPE PER LEVEL
C  NELECT(20)  = # OF E- WRITTEN TO TAPE PER LEVEL
C  NNU(20)     = # OF NEUTRINOS WRITTEN TO TAPE PER LEVEL
C  NMUP(20)    = # OF MU+ WRITTEN TO TAPE PER LEVEL
C  NMUM(20)    = # OF MU- WRITTEN TO TAPE PER LEVEL
C  NPI0(20)    = # OF PI(0) WRITTEN TO TAPE PER LEVEL
C  NPIP(20)    = # OF PI+ WRITTEN TO TAPE PER LEVEL
C  NPIM(20)    = # OF PI- WRITTEN TO TAPE PER LEVEL
C  NK0L(20)    = # OF K0L WRITTEN TO TAPE PER LEVEL
C  NKPL(20)    = # OF K+ WRITTEN TO TAPE PER LEVEL
C  NKMI(20)    = # OF K- WRITTEN TO TAPE PER LEVEL
C  NNEUTR(20)  = # OF NEUTRONS WRITTEN TO TAPE PER LEVEL
C  NPROTO(20)  = # OF PROTONS WRITTEN TO TAPE PER LEVEL
C  NPROTB(20)  = # OF ANTIPROTONS WRITTEN TO TAPE PER LEVEL
C  NK0S(20)    = # OF K0S WRITTEN TO TAPE PER LEVEL
C  NHYP(20)    = # OF STR. BARYONS WRITTEN TO TAPE PER LEVEL
C  NDEUT(20)   = # OF DEUTERONS WRITTEN TO TAPE PER LEVEL
C  NTRIT(20)   = # OF TRITONS WRITTEN TO TAPE PER LEVEL
C  NHELI3(20)  = # OF 3HELIUM WRITTEN TO TAPE PER LEVEL
C  NALPHA(20)  = # OF ALPHAS WRITTEN TO TAPE PER LEVEL
C  NCHRMM(20)  = # OF CHARMED MESONS WRITTEN TO TAPE PER LEVEL
C  NCHRMB(20)  = # OF CHARMED BARYONS WRITTEN TO TAPE PER LEVEL
C  NOTHER(20)  = # OF OTHER PARTICLES WRITTEN TO TAPE PER LEVEL
C  NMUOND      = # OF MUONS DECAYED TO ELECTRONS/POSITRONS
C  NNEUTB(20)  = # OF ANTINEUTRONS WRITTEN TO TAPE PER LEVEL
C  NMUONE      = # OF MUONS ELIMINATED BECAUSE OF ENERGY/ANGULAR CUT
C






C --------------/CROBSPAR/-----------------------
C  OBSLEV(..)  = OBSERVATION LEVELS (CM)
C  THCKOB(..)  = LAYER THICKNESS AT OBSERVATION LEVEL (G/CM**2)
C  XOFF(..)    = OFFSET OF X COOR. FOR INCLINED SHOWERS AT OBS. LEVEL
C  YOFF(..)    = OFFSET OF Y COOR. FOR INCLINED SHOWERS AT OBS. LEVEL
C  HEIGHP      = HEIGHT OF FIRST INTERACTION
C  THETAP      = ACTUAL THETA OF PRIMARY PARTICLE IN RADIAN
C  PHIP        = ACTUAL PHI OF PRIMARY PARTICLE IN RADIAN
C  THETPR(2)   = RANGE OF THETA OF PRIMARY PARTICLE IN RADIAN
C  PHIPR(2)    = RANGE OF PHI OF PRIMARY PARTICLE IN RADIAN

C  CORRXY      = CORRECTION FOR CURVOUT OPTION
# 812 "corsika.h"
C  NOBSLV      = # OF OBSERVATION LEVELS
C
C --------------/CRPAM/--------------------------
C  PAMA(6000)  = MASS OF PARTICLE (GEV)
C  SIGNUM(6000)= SIGN AND CHARGE OF PARTICLES
C  RESTMS(6000)= RELEASABLE KINETIC ENERGY OF PARTICLE
C  DECTIM(200) = LIFE TIME AT REST OF UNSTABLE PARTICLES
C
C --------------/CRPARPAR/-----------------------
C..CURRENT PARTICLE AND EQUIVALENCED QUANTITIES
C  CURPAR(0)   = PARTICLE TYPE
C  CURPAR(1)   = GAMMA,  LORENTZ FACTOR IN LAB
C  CURPAR(2)   = COSTHE, DIRECTION COSINE Z-DIRECTION
C  CURPAR(3)   = PHIX,   DIRECTION COSINE X-DIRECTION
C  CURPAR(4)   = PHIY,   DIRECTION COSINE Y-DIRECTION
C  CURPAR(5)   = H,      HEIGHT (TRUE HEIGHT)
C  CURPAR(6)   = T,      ACCUMULATED TIME IN SEC
C  CURPAR(7)   = X,      X-POSITION
C  CURPAR(8)   = Y,      Y-POSITION
C  CURPAR(9)   = CHI,    PENETRATED MATERIAL UNTIL DECAY OR REACTION
C                (G/CM**2)  CALCULATED IN BOX2
C  CURPAR(10)  = BETA,   V/C, CALCULATED IN BOX2
C  CURPAR(11)  = GCM,    GAMMA  IN CM, CALCULATED IN NUCINT
C  CURPAR(12)  = ECM,    ENERGY IN CM, CALCULATED IN NUCINT

C  CURPAR(13)  = WEIGHT, WEIGHT FOR THINNING


C  CURPAR(14)  = HAPP,   APPARENT HEIGHT  IN CARTESIAN COORDINATE SYSTEM
C  CURPAR(15)  = COSTAP, APPARENT ZENITH ANGLE IN CART.COORDINATE SYSTEM
C  CURPAR(16)  = COSTEA, ANGLE PARTICLE TO MID DETECT AT CENTER EARTH
# 868 "corsika.h"
C..SECONDARY PARTICLE
C  SECPAR(..)  = PARTICLE FIELD FOR SECONDARY PARTICLE (COMP. CURPAR)
C  SECPAR(9)   = GENERATION OF PARTICLE
C  SECPAR(10)  = LEVEL OF LAST INTERACTION
C  SECPAR(11)  = POLARIZATION DIRECTION: COS(THETA) FOR MUONS
C  SECPAR(12)  = POLARIZATION DIRECTION: PHI FOR MUONS

C  SECPAR(13)  = WEIGHT FOR THINNING


C  SECPAR(14)  = APPARENT HEIGHT  IN CARTESIAN COORDINATE SYSTEM
C  SECPAR(15)  = APPARENT ZENITH ANGLE OF PARTICLE POSITION IN CART.COORDINATE SYSTEM
C  SECPAR(16)  = ANGLE PARTICLE TO MID DETECT AT CENTER EARTH
# 918 "corsika.h"
C..PRIMARY PARTICLE
C  PRMPAR(..)  = PARTICLE FIELD FOR PRIMARY PARTICLE (COMP. CURPAR)
C..PARTICLE TO BE WRITTEN TO TAPE
C  OUTPAR(..)  = PARTICLE FIELD FOR OUTPUT PARTICLE (COMP. SECPAR)
# 930 "corsika.h"
C  C(.)        = PHYSICAL CONSTANSTS
C  C(1)        = EARTH'' RADIUS (CM)
C  C(2)        = MAX DISTANCE IN LOCAL COORDINATE SYSTEM AT SEA LEVEL
C  C(3)        = MAX DISTANCE IN LOCAL COORD. SYSTEM AT TOP OF ATMOSPH.
C  C(4)        = CONSTANT FOR MAX DIST IN LOCAL COORD. SYSTEM (SEE START)
C  C(6)        = (MASS OF MUON+/MASS OF KAON+)**2       (SEE START)
C  C(7)        = (MASS OF MUON+/MASS OF PION+)**2       (SEE START)
C  C(8)        = (PAMA(5)**2 + PAMA(2)**2)/(2*PAMA(5))  (SEE START)
C  C(9)        = MAX DISTANCE IN LOCAL COORDINATE SYSTEM (CHIMAX/RHO)
C  C(10)       = CUTOFF LORENTZ FACTOR FOR RECOIL NUCLEON
C  C(11)       = CUTOFF LORENTZ FACTOR FOR RECOIL PION
C  C(12)       = PEAK POSITION FOR PT DISTRIBUTION (IN PTRANS)
C  C(15)       = 1. + (MASS OF ELECTRON/MASS OF MUON)**2 (SEE START)
C  C(16)       = 2. * MASS OF ELECTRON / MASS OF MUON    (SEE START)
C  C(17)       = 1. + (MASS OF ELECTRON/MASS OF TAU)**2  (SEE START)
C  C(18)       = 2. * MASS OF ELECTRON / MASS OF TAU     (SEE START)
C  C(21)       = COULOMB SCATTERING LENGTH (G/CM**2)
C  C(22)       = CONSTANT FOR SPECIFIC IONISATION LOSS IN AIR
C  C(23)       = CONSTANT FOR SPECIFIC IONISATION LOSS IN AIR
C  C(24)       = (SPECIFIC IONIS. LOSS IN AIR FOR MIN.ION. PARTICLES)
C  C(25)       = SPEED OF LIGHT (CM/SEC)
C  C(26)       = CUT IN     THETA  FOR ANGLES TO BE ADDED
C  C(27)       = CUT IN COS(THETA) FOR ANGLES TO BE ADDED
C  C(28)       = CUT IN     THETA  FOR ALL PARTICLES, CUTS UPWARD GOING
C  C(29)       = CUT IN COS(THETA) FOR ALL PARTICLES, CUTS UPWARD GOING
C  C(30)       = PARAMETER FOR COULOMB SCATTERING OF MUONS
C  C(34)       = CUTOFF FOR PT IN SUBROUT. PTRANS
C  C(45)       = 2 * PAMA(14) * PAMA(8)             INTERNALLY COMPUTED
C  C(46)       = PAMA(14)**2 + PAMA(8)**2           INTERNALLY COMPUTED
C  C(48)       = (PAMA(8)**2 + PAMA(5)**2) /(2.D0*PAMA(8)*PAMA(5))
C  C(49)       = SQRT(C(48)**2 - 1.D0) / C(48)      INTERNALLY COMPUTED
C  C(50)       = FINE STRUCTURE CONSTANT
C  E00         = ENERGY OF PRIMARY
C  E00PN       = ENERGY OF PRIMARY PER NUCLEON
C  PTOT0       = TOTAL MOMENTUM OF PRIMARY
C  PTOT0N      = TOTAL MOMENTUM OF PRIMARY PER NUCLEON
C  THICKH      = THICK(H) MASS OVERBURDEN OF ACTUAL PARTICLE ALTITUDE
C  ITYPE       = CURPAR(0)  PARTICLE TYPES ACCORDING TO GEANT
C                IN ADDITION : A*100+Z=HEAVY NUCLEI (FOR PRIMARIES ONLY)
C  LEVL        = LEVEL # OF PARTICLE WRITTEN TO TAPE






C





C --------------/CRPATHCM/------------------------
C  (SEE EGS4 MANUAL)
C
C --------------/CRPHOTIN/------------------------
C  (SEE EGS4 MANUAL)
C
C --------------/CRPION/--------------------------
C  PI0MSQ      = MASS OF PI(0) SQUARED (EGS4)
C  PITHR       = THRESHOLD ENERGY FOR PHOTONUCLEAR INTERACT. (EGS4)
C  PICMAS      = MASS OF CHARGED PION (EGS4)
C  PI0MAS      = MASS OF PI(0) (EGS4)
C  AMASK0      = MASS OF NEUTRAL KAON (EGS4)
C  AMASKC      = MASS OF CHARGED KAON (EGS4)
C  AMASPR      = MASS OF PROTON (EGS4)
C  AMASNT      = MASS OF NEUTRON (EGS4)
C
# 1030 "corsika.h"
C --------------/CRPOLAR/------------------------
C  POLART      = COS(THETA) ; POLARIZATION DIRECTION OF MUON
C  POLARF      = PHI        ; POLARIZATION DIRECTION OF MUON
C
C --------------/CRPRIMSP/-----------------------
C  PSLOPE      = SLOPE OF PRIMARY DIFFERENTIAL ENERGY SPECTRUM
C                IF PRIMARY ENERGY IS TO BE COMPUTED FROM A SPECTRUM
C  LLIMIT      = LOWER LIMIT OF ENERGY SECTION FOR PRIMARY (GEV)
C  ULIMIT      = UPPER LIMIT OF ENERGY SECTION FOR PRIMARY (GEV)
C  LL          = USED FOR PRIMARY ENERGY SELECTION
C  UL          = USED FOR PRIMARY ENERGY SELECTION
C  SLEX        = EXPONENT OF SLOPE OF PRIMARY SPECTRUM
C  ISPEC       = 0 FOR FIXED ENERGY   = 1 FOR ENERGY SPECTRUM
C

C --------------/CRPYTLIN/-----------------------
C  IPTABL(.)   = CONVERSION TABLE CORSIKA CODE TO PYTHIA CODE
C  IFLGPYE     = ERROR FLAG FOR PYTHIA ERROR OUTPUT (1=0N, 0=OFF)
C  IFLGPYW     = WARNING FLAG FOR PYTHIA WARNING OUTPUT (1=0N, 0=OFF)
C
# 1076 "corsika.h"
C --------------/CRRANDPA/-----------------------
C  RD(3000)    = ARRAY (DOUBLE PRECISION) FOR RANDOM NUMBERS
C  FAC         = VARIABLE OF SUBROUT. RANNOR
C  U1          = VARIABLE OF SUBROUT. RANNOR
C  U2          = VARIABLE OF SUBROUT. RANNOR
C  NSEQ        = # OF RANDOM GENERATOR SEQUENCE
C  ISEED(.,.)  = RANDOM GENERATOR SEED
C  KNOR        = FLAG TO STEER GENERATION OF NORMAL DISTRIBUTED RANDOMS
C
C --------------/CRRANMA3/-----------------------
C  KSEQ        = PARAMETER DEFINING MAX. NUMBER OF INDEPENDENT SEQUENCES
C  CD          = STARTING NUMBER FOR RANDOM GENERATOR
C  CINT        = STARTING NUMBER FOR RANDOM GENERATOR
C  CM          = STARTING NUMBER FOR RANDOM GENERATOR
C  TWOM24      = 2**-24 (MANTISSA SINGLE PRECISION)
C  TWOM48      = 2**-48 (MANTISSA DOUBLE PRECISION)
C  MODCNS      = MODULUS (NOTOT * MODCNS = NTOT2) FOR RANDOM GENERATOR
C
C --------------/CRRANMA4/-----------------------
C  C(.)        = ARRAY(KSEQ) FOR RANDOM GENERATOR
C  U(.)        = ARRAY(97,KSEQ) FOR RANDOM GENERATOR
C  IJKL(.)     = ARRAY(KSEQ) FOR RANDOM GENERATOR
C  I97(.)      = ARRAY(KSEQ) FOR RANDOM GENERATOR
C  J97(.)      = ARRAY(KSEQ) FOR RANDOM GENERATOR
C  NTOT(.)     = ARRAY(KSEQ) FOR RANDOM GENERATOR
C  NTOT2(.)    = ARRAY(KSEQ) FOR RANDOM GENERATOR
C  JSEQ        = ACTUAL SEQUENCE NUMBER
C  UNI         = FINAL RANDOM NUMBER
C
C --------------/CRRATIOS/-----------------------
C  RPI0R       = RATIO # PI(0) / # ALL NEUTRAL PARTICLES
C  RPIER       = RATIO # PI(0)+ETA / # ALL NEUTRAL PARTICLES
C  RPEKR       = RATIO # PI(0)+ETA+KA0/ # ALL NEUTRAL PARTICLES
C  RPEKNR      = RATIO # PI(0)+ETA+KA0+NEUTR/ # ALL NEUTRAL PARTICLES
C  PPICH       = RATIO # PI+(+-) / # ALL CHARGED PARTICLES
C  PPINCH      = RATIO # PI+(+-)+PROTON / # ALL CHARGED PARTICLES
C  PPNKCH      = RATIO # PI+(+-)+PROTON+K(+-) / # ALL CHARGED PARTICLES
C  ISEL        = INDICATOR FOR LOW MULTIPLICITY OF SECONDARY PARTICLES
C  NEUTOT      = TOTAL # OF NEUTRAL PARTICLES  IN HDPM
C  NTOTEM      = TOTAL #OF SECONDARY PARTICLES IN HDPM
C
C --------------/CRRECORD/-----------------------
C  DRECOR      = # WORDS WRITTEN ON PARTICLE TAPE RECORDS
C
C --------------/CRREJECT/-----------------------
C  AVNREJ(..)  = AVERAGE NUMBER OF REJECTED ELECTRONS IN EGS
C  ALTMIN(..)  = MINIMUM ALTITUDE FOR REJECTION OF ELECTRONS AT OBS.LEVL
C  ANEXP(..)   = AVERAGE NUMBER OF ELECTRONS TO BE EXPECTED AT OBS.LEVEL
C  THICKA(..)  = THICKNESS OF AIR LAYER
C  THICKD(..)  = THICKNESS OF AIR LAYER BELOW OBSERVATION LEVEL
C  CUTLN       = LOGARITHM OF CUTTING ENERGY FOR REJECT IN EGS
C  EONCUT      = CUTTING ENERGY (IN MEV) FOR REJECT IN EGS

C  EFRCTHN     = THINNING BELOW ENERGY FRACTION OF PRIMARY(=EPSILON)
C  ETHINN      = THINNING BELOW ENERGY ETHINN  IN MEV FOR EM-PARTICLES
C  ETHINNG     = THINNING BELOW ENERGY ETHINNG IN GEV FOR HADR.PARTICLES
C  THINRAT     = ENERGY RATIO (EPSILON_EM)/(EPSILON)
C  THINRATH    = ENERGY RATIO (EPSILON_HADR)/(EPSILON)
C  WEITRAT     = WEIGHT LIMIT RATIO (WMAX_EM)/(WMAX)
C  WEITRATH    = WEIGHT LIMIT RATIO (WMAX_HADR)/(WMAX)
C  EEFRTHN     = THINNING EM ENERGY FRACTION OF PRIMARY(=EPSILON_EM)

C  FNPRIM      = FLAG INDICATING THE PRIMARY PARTICLE IN EGS
C
C --------------/CRRESON/------------------------
C  RDRES(2)    = RANDOM NUMBERS FOR RESONANCE DECAYS
C  RESRAN(.)   = RANDOM NUMBERS FOR RESONANCE DECAYS
C  IRESPAR     = POINTER FOR ARRAY RESRAN
C
C --------------/CRREST/-------------------------
C  CONTNE(3)   = FRACTION OF NEUTRONS IN TARGET LIT
C  TAR         = NUMBER OF NUCLEONS IN TARGET
C  LIT         = INDEX FOR INTERACTING TARGET (1=N, 2=O, 3=AR)
C
# 1159 "corsika.h"
C --------------/CRRUNPAR/-----------------------
C  FIXHEI      = HEIGHT OF FIRST INTERACTION IF TAKEN FIXED (CM)
C  THICK0      = HEIGHT OF START OF PRIMARY (IN G/CM**2)
C  HILOECM     = ENERGY THRESHOLD FOR HIGH ENERGY MODEL IN CM
C  HILOELB     = ENERGY THRESHOLD FOR HIGH ENERGY MODEL IN LAB
C  SIG1I       = CROSS-SECTION FOR FIRST INTERACTION
C  TARG1I      = TARGET OF FIRST INTERACTION
C  STEPFC      = STEP LENGTH FACTOR FOR ELECTRON MULTIPLE SCATTERING
C  RCUT        = RADIUS WITHIN WHICH PARTICLES ARE DISCARDED FROM OUTPUT
C  RCUT2       = RCUT**2

C  SIGMAQ      = CROSS SECTION FOR CHARMED AND BOTTOM PARTICLES


C  HIMPACT(2)  = RANGE OF MINIMAL HEIGHT (IMPACT) FOR SKIMMING PRIMARY
C  HIMPCT      = ACTUAL IMPACT PARAMTER FOR SKIMMING PRIMARY

C  NRRUN       = # OF RUN
C  NSHOW       = # OF SHOWERS TO GENERATE
C  MPATAP      = LUN OF DATASET FOR PARTICLE OUTPUT
C  MONIIN      = LUN OF CARD READER
C  MONIOU      = LUN OF LINE PRINTER
C  MDEBUG      = LUN OF DEBUG OUTPUT
C  NUCNUC      = LUN OF CROSS-SECTION FILE
C  MTABOUT     = LUN OF TABLE OUTPUT FOR CHARGED PARTICLES
C  MLONGOUT    = LUN OF LONGITUDINAL TABLE OUTPUT






C  PROPMOD     = FLAG FOR USE OF STANDARD INTERACTION(0) OR HEPARIN(1)


C  IUDEBUG     = ACTUAL DEBUG LEVEL FOR URQMD
C  IUDEBG0     = PRESET DEBUG LEVEL FOR URQMD
# 1210 "corsika.h"
C  LSTCK       = LUN OF PARTICLE PARAMETERS INPUT/OUTPUT FILE

C  LSTCK1      = LUN OF FIRST INT PARTICLE PARAMETERS HEADER
C  LSTCK2      = LUN OF FIRST INT PARTICLE PARAMETERS LIST

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
cC  LUNHST      = LUN OF HBOOK HISTOGRAM OUTPUT
c#endif
C  ISHOWNO     = # OF ACTUAL SHOWER
C  ISHW        = INDEX OF SHOWER LOOP
C  NOPART      = COUNTER FOR PARTICLES WRITTEN TO TAPE
C  NRECS       = # OF BIG   BLOCKS PUT OUT (FOR TP)
C  NBLKS       = # OF SMALL BLOCKS PUT OUT (FOR TP)
C  MAXPRT      = MAXIMUM NUMBER OF EVENTS TO BE PRINTED
C  NDEBDL      = NUMBER OF MAPPED PARTICLE THAT ACTIVATES DELAYED DEBUG
C  N1STTR      = NUMBER OF FIXED FIRST TARGET 0=RANDOM, 1=N, 2=O, 3=AR
C  MDBASE      = LUN OF DATABASE FILE





C  DEBDEL      = FLAG TO STEER DELAYED ACTIVATION OF DEBUG
C  DEBUG       = FLAG TO STEER PRINTOUT FOR DEBUGGING
C  FDECAY      = FLAG INDICATING PARTICLE UNDERGOES DECAY
C  FEGS        = FLAG FOR USE OF EGS4





C  FFLATOUT    = FLAG INDICATING PARTICLE OUTPUT TYPE (FLAT OR SPHERE)

C  FIRSTI      = FLAG INDICATING FIRST INTERACTION IN HDPM
C  FIXINC      = FLAG TO KEEP ANGLES OF INCIDENCE FIXED
C  FIXTAR      = FLAG TO INDICATE FIXED TARGET FOR FIRST INTERACTION
C  FIX1I       = FLAG TO KEEP HEIGHT OF FIRST INTERACTION FIXED
C  FMUADD      = FLAG TO INDICATE ADDITIONAL MUON OUTPUT ON MPATAP
C  FNKG        = FLAG FOR USE OF NKG FORMULAS
C  FPRINT      = LOGICAL VARIABLE TO STEER PRINTING
C  FDBASE      = FLAG FOR WRITING SUMMARY FILE FOR DATABASE
C  FPAROUT     = FLAG INDICATING PARTICLE OUTPUT
C  FTABOUT     = FLAG INDICATING TABLE OUTPUT
C  FLONGOUT    = FLAG INDICATING LONGITUDINAL OUTPUT

C  FOUTFILE    = FLAG INDICATING FIRST INTERACTION STACK OUTPUT
C  IFINAM      = # PART. PRODUCED IN FIRST INTERACTION

C  GHEISH      = FLAG TO ACTIVATE GHEISHA ROUTINES
C  GHESIG      = FLAG TO INDICATE THAT GHEISHA CROSS-SECTION IS USED
C  GHEISDB     = FLAG TO ACTIVATE GHEISHA DEBUG OUTPUT
C  USELOW      = FLAG INDICATING LOW ENERGY HADRONIC INTERACTION
C  TMARGIN     = FLAG INDICATING ARR. TIME ZERO AT ENTRANCE INTO ATMOSPHERE
# 1277 "corsika.h"
C  FIMPCT      = FLAG INDICATING SKIMMING PRIMARY (IMPACT)






C  FURQMD      = FLAG INDICATING USE OF URQMD
C  FURQSG      = FLAG INDICATING THAT URQMD SIGMA IS AVAILABLE
# 1297 "corsika.h"
C
C --------------/CRRUNPAC/-----------------------
C  DSN         = DATA SET NAME OF PARTICLE OUTPUT
C  DSNTAB      = DATA SET NAME OF TABLE OUTPUT
C  DSNLONG     = DATA SET NAME OF LONGITUDINAL OUTPUT
C  HOST        = NAME OF HOST COMPUTER IN USE
C  USER        = NAME OF USER
C  DATDIR      = DIRECTORY OF INPUT DATA TABLES






C  LSTDSN      = DATA SET NAME OF LIST OUTPUT
# 1323 "corsika.h"
C  FILOUT      = DATA SET NAME OF STACK OF FIRST INTERACTION OUTOUT FILE
# 1334 "corsika.h"
C
# 1350 "corsika.h"
C --------------/CRSIBDBG/-----------------------
C  ISIBDB      = ACTUAL      DEBUG LEVEL FOR SIBYLL
C  ISDEBUG     = PRESELECTED DEBUG LEVEL FOR SIBYLL
C
C --------------/CRSIBLIN/-----------------------
C  ICTABL(.)   = TABLE TO CONVERT PARTICLE TYPE FROM CORSIKA TO SIBYLL
C  ISTABL(.)   = TABLE TO CONVERT PARTICLE TYPE FROM SIBYLL TO CORSIKA
C
C --------------/CRSIBYLC/-----------------------
C  FSIBYL      = FLAG TO ACTIVATE SIBYLL ROUTINES
C  FSIBSG      = FLAG TO ACTIVATE SIBYLL CROSS-SECTIONS
C  FSIBCH      = FLAG TO ACTIVATE CHARM PRODUCTION IN SIBYLL				
C

C --------------/CRSIGM/-------------------------
C  SIGMA       = INELASTIC CROSS-SECTION FOR HADRON NUCLEON COLLISION
C  SIGANN      = NUCLEON ANNIHILATION CROSS-SECTION
C  SIGAIR      = INELASTIC CROSS-SECTION IN AIR
C  FRACTN      = NITROGEN FACTION OF INELASTIC AIR CROSS-SECTION
C  FRCTNO      = NITROGEN+OXYGEN FACTION OF INELASTIC AIR CROSS-SECTION
C
C --------------/CRSIGMU/-------------------------
C  BREMSTAB    = TABLE OF MUON/TAU BREMSSTRAHLUNG CROSS-SECTIONS
C  NUCTAB      = TABLE OF MUON/TAU NUCLEAR INTERACTION CROSS-SECTIONS
C  PAIRTAB     = TABLE OF MUON/TAU PAIR PRODUCTION CROSS-SECTIONS
C  DEDXMU      = TABLE OF MUON/TAU ENEGY LOSS IN DIFFERENT MATERIALS
C  DEDXM       = TABLE OF MUON/TAU ENEGY LOSS IN AIR
C
C --------------/CRSTACKE/-----------------------
C  E(NP)       = ENERGY OF PARTICLE ON EGS STACK
C  TIM(NP)     = TIME OF PARTICLE ON EGS STACK
C  U(NP)       = X DIRECTION COSINE OF PARTICLE ON EGS STACK
C  V(NP)       = Y DIRECTION COSINE OF PARTICLE ON EGS STACK
C  W(NP)       = Z DIRECTION COSINE OF PARTICLE ON EGS STACK
C  X(NP)       = X COORDINATE OF PARTICLE ON EGS STACK
C  Y(NP)       = Y COORDINATE OF PARTICLE ON EGS STACK
C  Z(NP)       = Z COORDINATE OF PARTICLE ON EGS STACK
C  DNEAR       = DISTANCE TO NEXT LAYER BOUNDARY OF PART. ON EGS STACK

C  WT(NP)      = WEIGHT IN CASE OF THINNING (EGS)


C  ZAP(NP)     = APPARENT HEIGHT IN CARTESIAN COORDINATE SYSTEM (EGS)
C  WAP(NP)     = APPARENT ZENITH ANGLE IN CART.COORDINATE SYSTEM (EGS)
C  WA(NP)      = ANGLE PARTICLE TO MID DETECT AT CENTER EARTH (EGS)

C  XXXX(NP)    = X COORDINATE IN DETECTOR SYSTEM (CURVED)
C  YYYY(NP)    = Y COORDINATE IN DETECTOR SYSTEM (CURVED)



C  TSLAN(NP)   = SLANT DEPTH OF PARTICLE ON EGS STACK




C  IQ(NP)      = PARTICLE IDENTIFIER (EGS)
C  IGEN(NP)    = GENERATION COUNTER OF PARTICLE ON EGS STACK
C  IR(NP)      = ACTUAL ATMOSPHERIC LAYER OF PARTICLE ON EGS STACK
C  IOBS(NP)    = # OF NEXT OBSERVATION LEVEL FOR PARTICLE ON EGS STACK
C  LPCTE(NP)   = INDEX OF LONGITUDINAL LAYER FOR PARTICLE ON EGS STACK
C  NP          = STACK POINTER OF PARTICLE ON EGS STACK
C
C --------------/CRSTACKF/-----------------------
C  MAXSTK      = PARAMETER FOR MAXIMAL STACK SIZE
# 1430 "corsika.h"
C  STACKI(MAXSTK) = PARTICLE STACK FOR 2 * 256 PARTICLES A 17 WORDS
# 1442 "corsika.h"
C  MSTACKP     = STACK POINTER
C  MEXST       = LUN OF SCRATCH DSN FOR EXTERNAL STACK
C  NSHIFT      = # OF STACK SHIFTS
C  NOUREC      = # OF STACK OUTPUT RECORDS
C  NOURECMAX   = MAX # OF STACK OUTPUT RECORDS
C  ICOUNT      = POSITION OF PARTICLE WITHIN STACK
C  NTO         = # OF PARTICLES WRITTEN TO STACK
C  NFROM       = # OF PARTICLES READ FROM STACK
# 1460 "corsika.h"
C
C --------------/CRSTATI/-------------------------
C  SABIN(40)   = LOW  EDGE OF KIN. ENERGY FOR INTERACTION-ENERGY TABLE
C  SBBIN(40)   = HIGH EDGE OF KIN. ENERGY FOR INTERACTION-ENERGY TABLE
C  INBIN(40)   = COUNTER FOR NUCLEON TABLE FOR SHOWER
C  IPBIN(40)   = COUNTER FOR PION TABLE FOR SHOWER
C  IKBIN(40)   = COUNTER FOR KAON TABLE FOR SHOWER
C  IHBIN(40)   = COUNTER FOR STRANGE BARYON TABLE FOR SHOWER
C
C --------------/CRSTRBAR/-----------------------
C  CSTRBA(5)   = BRANCHING RATIO FOR DECAY OF LAMDA
C  CSTRBA(6)   = BRANCHING RATIO FOR DECAY OF SIGMA(+)
C  CSTRBA(10)  = BRANCHING RATIO FOR DECAY OF OMEGA(-)
C  CSTRBA(11)  = BRANCHING RATIO FOR DECAY OF OMEGA(-)
C
C --------------/CRTABLES/-----------------------
C  IEBIN       = PARAMETER # OF ENERGY BINS
C  ITBIN       = PARAMETER # OF ARRIVAL TIME BINS
C  IDBIN       = PARAMETER # OF DISTANCE BINS
C  G_ARRAY     = ARRAY FOR GAMMAS IN BINS IN ENERGY, TIME, CORE DISTANCE
C  E_ARRAY     = ARRAY FOR ELECTRONS IN BINS IN ENERGY, TIME, CORE DIST.
C  M_ARRAY     = ARRAY FOR MUONS IN BINS IN ENERGY, TIME, CORE DISTANCE
C  EBOFF       = ENERGY       OFFSET         FOR BINNING
C  EBFAC       = ENERGY       SCALING FACTOR FOR BINNING
C  TBOFF       = ARRIVAL TIME OFFSET         FOR BINNING
C  TBFAC       = ARRIVAL TIME SCALING FACTOR FOR BINNING
C  DBOFF       = DISTSANCE    OFFSET         FOR BINNING
C  DBFAC       = DISTSANCE    SCALING FACTOR FOR BINNING
C  EBMIN       = PARAMETER: MINIMUM ENERGY FOR ENERGY TABLE
C  EBMAX       = PARAMETER: MAXIMUM ENERGY FOR ENERGY TABLE
C  TBMIN       = PARAMETER: MINIMUM ARRIVAL TIME FOR TIME TABLE
C  TBMAX       = PARAMETER: MAXIMUM ARRIVAL TIME FOR TIME TABLE
C  DBMIN       = PARAMETER: MINIMUM DISTANCE FOR DISTANCE TABLE
C  DBMAX       = PARAMETER: MAXIMUM DISTANCE FOR DISTANCE TABLE
C
C --------------/CRTHNVAR/-----------------------
C  MAXICOUNT   = PARAMETER FOR MAXIMAL INTERMEDIATE STACK SIZE
C  STACKINT(,) = INTERMEDIATE STACK OF PARTICLE COORDINATES

C  EEPP(.)     = ENERGY OF PARTICLE ON INTERMEDIATE STACK
C  ELIM        = ENERGY LIMIT FOR THINNING


C  RMAX        = MAX. RADIUS FOR RADIAL THINNING
C  RMAX2       = RMAX**2
C  WMAX        = MAX. ACTUAL WEIGHT FOR WEIGHT LIMITATION (HADR.)
C  WMAX0       = MAX. WEIGHT FOR WEIGHT LIMITATION (HADR.)
C  WMAXE       = MAX. ACTUAL WEIGHT FOR WEIGHT LIMITATION (EM)
C  WMAXE0      = MAX. WEIGHT FOR WEIGHT LIMITATION (EM)
C  WMAXEM      = MAX. WEIGHT LIMIT (EM-PARTICLES) FOR WEIGHT LIMITATION

C  INT_ICOUNT  = POINTER FOR INTERMEDIATE PARTICLE STACK
C  MODETHN     = MODE FOR READING IN THIN VARIABLES
C  THINNING    = FLAG INDICATING THINNING FOR CURRENT INTERACTION

C  RLIM        = FLAG INDICATING THAT RADIAL THINNING IS ACTIVE
C  WLIM        = FLAG INDICATING THAT WEIGHT LIMITATION IS ACTIVE

C
# 1543 "corsika.h"
C --------------/CRTHRESH/-----------------------
C  (SEE EGS4 MANUAL)
C

C --------------/CRTIMLIM/-----------------------
C  DSTLIM      = DISTANCE LIMIT (DOWNSTREAM DETECTOR) FOR TIME LIMIT
C  TIMLIM      = TIME LIMIT FOR PARTICLE SINCE 1. INTERACT (SEC)
C  LTMLMPR     = FLAG FOR PRINTING OF PARTICLE EXCEEDS TIME LIMIT
C
# 1609 "corsika.h"
C --------------/CRURQCLC/-----------------------
C  MAXCLU      = PARAMETER MAXIMUM CLUSTERS
C  MAXENT      = PARAMETER MAXIMUM ?
C
C  NCLUSTER    =
C  NCLUENT     =
C  NCLUST      =
C
C --------------/CRURQSIG/-----------------------
C  MAXA        = MAXIMUM NUCLEON NUMBER FOR PROJECTILE NUCLEUS
C  MAXS        = MAXIMUM PARTICLE  NUMBER FOR PROJECTILE
C  MAXZ        = MAXIMUM ATOMIC NUMBER FOR PROJECTILE NUCLEUS
C  URCRNU      = CROSS-SECTION FOR NUCLEUS-AIR COLLISION
C  URCRSP      = CROSS-SECTION FOR HADRON-AIR COLLISION
C

C --------------/CRUSEFUL/-----------------------
C  (SEE EGS4 MANUAL)
C
# 1663 "corsika.h"
C --------------/CRVERS/-------------------------
C  VERNUM      = VERSION NUMBER OF CORSIKA
C  MVDATE      = DATE OF VERSION AS INTEGER (YYYYMMDD)
C  VERDAT(.)   = DATE OF RELEASE OF VERSION
C
C --------------/CRVKIN/-------------------------
C  BETACM      = BETA IN CENTER OF MASS
C
C --------------/CRWGHTMA/-----------------------
C  MWGHMA(,)   = WEIGHT MATRIX OF SINGLE SHOWER
C  MWGHTOT(,)  = TOTALIZED WEIGHT MATRIX OF ALL SHOWERS
C
# 1703 "corsika.h"
C=======================================================================
C
C  DESCRIPTION OF GLOBAL VARIABLES USED IN THE COMMONS OF THE PROGRAM
C  ==================================================================
C  (IN ALPHABETIC ORDER OF THE VARIABLE NAMES)
C
C  AATM(5)     = ACTUAL COEFFICIENTS FOR PARAMETRIZATION OF ATMOSPHERE
C  AATM0(5,..) = COEFFICIENTS FOR PARAMETRIZATION OF ATMOSPHERE



C  AATOM       = NUCLEONS IN TARGET FOR MUON/TAU INTERACTIONS




C  ACOMP       = ATOMIC WEIGHT OF COMPONENT (GHEISHA)
C  ADLONG(I,K) = AVERAGE OF DLONG OVER ALL SHOWERS
C  AELONG(I,K) = AVERAGE OF ELONG OVER ALL SHOWERS
C  ALEVEL      = LEVEL OF LAST HADRONIC INTERACTION
C  ALTMIN(..)  = MINIMUM ALTITUDE FOR REJECTION OF ELECTRONS AT OBS.LEVL
C  AMUPAR(0:..)= REGISTER FOR MUON PARTICLE ADDITIONAL INFO
C  ANEXP(..)   = AVERAGE NUMBER OF ELECTRONS TO BE EXPECTED AT OBS.LEVEL
C  APLONG(I,K) = AVERAGE OF PLONG OVER ALL SHOWERS
C  ARRANG      = ANGLE (DEG) ARRAY X-DIRECTION AND MAGNETIC NORD
C  ARRANR      = ANGLE (RAD) ARRAY X-DIRECTION AND MAGNETIC NORD
C  ARRAYLONG( )= BUFFER FOR LONGITUDINAL PARTICLE DISTRIBUTION




C  AVCH        = AVERAGE # OF CHARGED PARTICLES IN HDPM
C  AVCH3       = AVERAGE # OF CHARGED PARTICLES IN 3RD STRING IN HDPM
C  AVERAW      = AVERAGE ATOMIC WEIGHT OF AIR
C  AVNREJ(..)  = AVERAGE NUMBER OF REJECTED ELECTRONS IN EGS
C  AVOGDR      = AVOGADROS NUMBER * MILLIBARN/CM**2
C  AVPE        = AVERAGE TRANSVERSE MOMENTUM FOR ETAS
C  AVPH        = AVERAGE TRANSVERSE MOMENTUM FOR STRANGE BARYONS
C  AVPK        = AVERAGE TRANSVERSE MOMENTUM FOR KAONS
C  AVPN        = AVERAGE TRANSVERSE MOMENTUM FOR NUCLEONS
C  AVPT        = AVERAGE TRANSVERSE MOMENTUM FOR PIONS
C
C  BETA2       = VELOCITY OF ELECTRON SQUARED
C  BATM(5)     = ACTUAL COEFFICIENTS FOR PARAMETRIZATION OF ATMOSPHERE
C  BATM0(5,..) = COEFFICIENTS FOR PARAMETRIZATION OF ATMOSPHERE



C  BCUT        = CUT-OFF ENERGY FOR MUON/TAU BREMSSTRAHLUNG



C  BETA        = CURPAR(10)
C  BETACM      = BETA IN CENTER OF MASS
C  BLIMIT      = LIMIT FACTOR FOR STEP SIZE OF ELECTRONS IN MAGN.FIELD
C  BNORM       = MAGNETIC DEFLECTION CONSTANT [MEV/CM]
C  BNORMC      = MAGNETIC DEFLECTION CONSTANT [GEV/CM]
C  BOUND       = BOUNDARIES OF ATMOSPHERIC LAYERS (EGS4)
C  BREMSTAB    = TABLE OF MUON/TAU BREMSSTRAHLUNG CROSS-SECTIONS
C  BVAL        = SQUARED MAGNET FIELD STRENGTH
C  BX          = MAGNET FIELD STRENGTH COMPONENT TO NORTH [MICROTESLA]
C  BZ          = MAGNET FIELD STRENGTH COMPONENT DOWNWARD [MICROTESLA]
C
C  C(.)  PHYSICAL CONSTANSTS
C  C(1)        = EARTH'' RADIUS (CM)
C  C(2)        = MAX DISTANCE IN LOCAL COORDINATE SYSTEM AT SEA LEVEL
C  C(3)        = MAX DISTANCE IN LOCAL COORD. SYSTEM AT TOP OF ATMOSPH.
C  C(4)        = CONSTANT FOR MAX DIST IN LOCAL COORD. SYSTEM (SEE START)
C  C(6)        = (MASS OF MUON+/MASS OF KAON+)**2
C  C(7)        = (MASS OF MUON+/MASS OF PION+)**2
C  C(8)        = (PAMA(5)**2 + PAMA(2)**2)/(2*PAMA(5))
C  C(9)        = MAX DISTANCE IN LOCAL COORDINATE SYSTEM (CHIMAX/RHO)
C  C(10)       = CUTOFF LORENTZ FACTOR FOR RECOIL NUCLEON
C  C(11)       = CUTOFF LORENTZ FACTOR FOR RECOIL PION
C  C(12)       = PEAK POSITION FOR PT DISTRIBUTION (IN PTRANS)
C  C(15)       = 1. + (MASS OF ELECTRON/MASS OF MUON)**2 (SEE START)
C  C(16)       = 2. * MASS OF ELECTRON / MASS OF MUON (SEE START)
C  C(17)       = 1. + (MASS OF ELECTRON/MASS OF TAU)**2 (SEE START)
C  C(18)       = 2. * MASS OF ELECTRON / MASS OF TAU (SEE START)
C  C(21)       = COULOMB SCATTERING LENGTH (G/CM**2)
C  C(22)       = CONSTANT FOR SPECIFIC IONISATION LOSS IN AIR
C  C(23)       = CONSTANT FOR SPECIFIC IONISATION LOSS IN AIR
C  C(24)       = (SPECIFIC IONIS. LOSS IN AIR FOR MIN.ION. PARTICLES)
C  C(25)       = SPEED OF LIGHT (CM/SEC)
C  C(26)       = CUT IN     THETA  FOR ANGLES TO BE ADDED
C  C(27)       = CUT IN COS(THETA) FOR ANGLES TO BE ADDED
C  C(28)       = CUT IN     THETA  FOR ALL PARTICLES, CUTS UPWARD GOING
C  C(29)       = CUT IN COS(THETA) FOR ALL PARTICLES, CUTS UPWARD GOING
C  C(30)       = PARAMETER FOR COULOMB SCATTERING OF MUONS
C  C(34)       = CUTOFF FOR PT IN SUBROUT. PTRANS
C  C(35)       = MEAN FOR PION LONG. MOMENTUM COMING FROM FORW. ISOBAR
C  C(36)       = MEAN FOR PION LONG. MOMENTUM COMING FROM FORW. ISOBAR
C  C(45)       = 2 * PAMA(14) * PAMA(8) INTERNALLY COMPUTED
C  C(46)       = PAMA(14)**2 + PAMA(8)**2 INTERNALLY COMPUTED
C  C(48)       = (PAMA(8)**2 + PAMA(5)**2) /(2.D0*PAMA(8)*PAMA(5))
C  C(49)       = SQRT(C(48)**2 - 1.D0) / C(48) INTERNALLY COMPUTED
C  C(50)       = FINE STRUCTURE CONSTANT
C  C(.)        = ARRAY(KSEQ) FOR RANDOM GENERATOR



C  CATM(5)     = ACTUAL COEFFICIENTS FOR PARAMETRIZATION OF ATMOSPHERE
C  CATM0(5,..) = COEFFICIENTS FOR PARAMETRIZATION OF ATMOSPHERE




C  CCATM(5)    = LOG( BATM(I)/CATM(I) )




C  CD          = STARTING NUMBER FOR RANDOM GENERATOR
# 1840 "corsika.h"
C  CETA(1)     = BRANCHING RATIO FOR ETA DECAY
C  CETA(2)     = BRANCHING RATIO FOR ETA DECAY
C  CETA(3)     = BRANCHING RATIO FOR ETA DECAY
C  CETA(4)     = ASYMMETRY TERM    IN DECAY  ETA-->PI(+) + PI(-) + PI(0)
C  CETA(5)     = MAXIMUM AMPLITUDE IN DECAY  ETA-->PI(+) + PI(-) + PI(0)




C  CHAPAR      = ARRAY OF PARTICLE NUMBERS FOR LONGIT. DISTRIBUTION
C  CHC         = CONSTANT CHI_C   FOR MUOMN MULTIPLE SCATTERING
C  CHI         = CURPAR(9)
C  CINT        =STARTING NUMBER FOR RANDOM GENERATOR
C  CKA(.)  PHYSICAL CONSTANTS FOR KAONS
C  CKA(2)      = MEAN FOR KAON LONG. MOMENTUM COMING FROM VHMESO
C  CKA(23)     = BRANCH RATIO K(+,-) DECAY
C  CKA(24)     = BRANCH RATIO K0S DECAY
C  CKA(25)     = BRANCH RATIO K0L DECAY
C  CKA(26)     = BRANCH RATIO K0L DECAY
C  CKA(27)     = BRANCH RATIO K0L DECAY
C  CKA(47)     = BRANCH RATIO K(+,-) DECAY
C  CKA(48)     = BRANCH RATIO K(+,-) DECAY
C  CKA(49)     = BRANCH RATIO K(+,-) DECAY
C  CKA(50)     = BRANCH RATIO K(+,-) DECAY
C  CKA(51)     = G     OF K+,- ===> PI+,- + PI+,- + PI-,+
C  CKA(52)     = H     OF K+,- ===> PI+,- + PI+,- + PI-,+
C  CKA(53)     = K     OF K+,- ===> PI+,- + PI+,- + PI-,+
C  CKA(54)     = AMPMX OF K+,- ===> PI+,- + PI+,- + PI-,+
C  CKA(55)     = G     OF K+,- ===> PI0 + PI0 + PI+,-
C  CKA(56)     = H     OF K+,- ===> PI0 + PI0 + PI+,-
C  CKA(57)     = K     OF K+,- ===> PI0 + PI0 + PI+,-
C  CKA(58)     = AMPMX OF K+,- ===> PI0 + PI0 + PI+,-
C  CKA(59)     = G,H,K OF K0L ===> PI0 + PI0 + PI0
C  CKA(60)     = AMPMX OF K0L ===> PI0 + PI0 + PI0
C  CKA(61)     = G     OF K0L ===> PI+ + PI- + PI0
C  CKA(62)     = H     OF K0L ===> PI+ + PI- + PI0
C  CKA(63)     = K     OF K0L ===> PI+ + PI- + PI0
C  CKA(64)     = AMPMX OF K0L ===> PI+ + PI- + PI0
C  CKA(65)     = LAMBDA-PLUS OF K+,- ===> PI0 + E + NU
C  CKA(66)     = LAMBDA-ZERO OF K+,- ===> PI0 + E + NU
C  CKA(67)     = AMPMX       OF K+,- ===> PI0 + E + NU
C  CKA(68)     = LAMBDA-PLUS OF K+,- ===> PI0 + MU + NU
C  CKA(69)     = LAMBDA-ZERO OF K+,- ===> PI0 + MU + NU
C  CKA(70)     = AMPMX       OF K+,- ===> PI0 + MU + NU
C  CKA(71)     = LAMBDA-PLUS OF K0L ===> PI + E + NU
C  CKA(72)     = LAMBDA-ZERO OF K0L ===> PI + E + NU
C  CKA(73)     = AMPMX       OF K0L ===> PI + E + NU
C  CKA(74)     = LAMBDA-PLUS OF K0L ===> PI + MU + NU
C  CKA(75)     = LAMBDA-ZERO OF K0L ===> PI + MU + NU
C  CKA(76)     = AMPMX       OF K0L ===> PI + MU + NU
C  CM          =STARTING NUMBER FOR RANDOM GENERATOR
C  CMUON(11)   = CONSTANTS FOR MUON BREMSSTRAHLUNG CALCULATION



C  COMPOS(3)   = COMPOSITION OF AIR, ATOMIC FRACTIONS OF N, O, AR



C  CONSTKINE   = KINEMATIC CONSTANT FOR MUON/TAU INTERACTIONS
C  CONTNE(3)   = FRACTION OF NEUTRONS IN TARGET LIT

C  CORRXY      = CORRECTION FOR CURVOUT OPTION

C  COSANG      = COSINE OF ARRANR




C  COSTAP      = CURPAR(15) APPARENT ZENITH ANGLE OF PARTICLE POSITION IN CART.COORD. SYSTEM
C  COSTEA      = CURPAR(16) ANGLE PARTICLE TO MID DETECTOR AT CENTER EARTH

C  COSTHE      = CURPAR(2)
C  COSB        = COS OF INCLINATION ANGLE MAGNETIC FIELD
C  COS345(3)   = COSINE THETA OF PARTICLE EMERGING FROM 3 BODY DECAY
C  CPHISCT     = COSINE OF AZIMUTAL ANGLE OF MUON MULTIPLE SCATTERING
C  CPHI345(3)  = COSINE PHI   OF PARTICLE EMERGING FROM 3 BODY DECAY
# 1926 "corsika.h"
C  CSTRBA(5)   = BRANCHING RATIO FOR DECAY OF LAMDA
C  CSTRBA(6)   = BRANCHING RATIO FOR DECAY OF SIGMA(+)
C  CSTRBA(10)  = BRANCHING RATIO FOR DECAY OF OMEGA(-)
C  CSTRBA(11)  = BRANCHING RATIO FOR DECAY OF OMEGA(-)
C  CTAU(11)    = CONSTANTS FOR TAU  BREMSSTRAHLUNG CALCULATION

C  CTH         = COSINE OF PRIMARY FOR PLANE NORMAL TO SHOWER AXIS

C..CURRENT PARTICLE AND EQUIVALENCED QUANTITIES
C  CURPAR(0)   = PARTICLE TYPE
C  CURPAR(1)   = GAMMA,  LORENTZ FACTOR IN LAB
C  CURPAR(2)   = COSTHE, DIRECTION COSINE Z-DIRECTION
C  CURPAR(3)   = PHIX,   DIRECTION COSINE X-DIRECTION
C  CURPAR(4)   = PHIY,   DIRECTION COSINE Y-DIRECTION
C  CURPAR(5)   = H,      HEIGHT
C  CURPAR(6)   = T,      ACCUMULATED TIME IN SEC
C  CURPAR(7)   = X,      X-POSITION
C  CURPAR(8)   = Y,      Y-POSITION
C  CURPAR(9)   = CHI,    PENETRATED MATERIAL UNTIL DECAY OR REACTION
C                (G/CM**2)  CALCULATED IN BOX2
C  CURPAR(10)  = BETA,   V/C, CALCULATED IN BOX2
C  CURPAR(11)  = GCM,    GAMMA  IN CM, CALCULATED IN NUCINT
C  CURPAR(12)  = ECM,    ENERGY IN CM, CALCULATED IN NUCINT

C  CURPAR(13)  = WEIGHT, WEIGHT FOR THINNING


C  CURPAR(14)  = HAPP,   APPARENT HEIGHT  IN CARTESIAN COORDINATE SYSTEM
C  CURPAR(15)  = COSTAP, APPARENT ZENITH ANGLE  OF PARTICLE POSITION IN CART.COORDINATE SYSTEM
C  CURPAR(16)  = COSTEA, ANGLE PARTICLE TO MID DETECTOR AT CENTER EARTH
# 1981 "corsika.h"
C  CUTLN       = LOGARITHM OF CUTTING ENERGY FOR REJECT IN EGS
# 2002 "corsika.h"
C  CZX(.)      = LATERAL DIST. OF ELECTRONDENSITY IN X (NKG) (/CM**2)
C  CZY(.)      = LATERAL DIST. OF ELECTRONDENSITY IN Y (NKG) (/CM**2)
C  CZXY(.)     = LATERAL DIST. OF ELECTRONDENSITY IN XY (NKG) (/CM**2)
C  CZYX(.)     = LATERAL DIST. OF ELECTRONDENSITY IN YX (NKG) (/CM**2)
C
C  DATAB(MAXBUF)= BUFFER FOR DATA



C  DATDIR      = DIRECTORY OF INPUT DATA TABLES
C  DATM(5)     = 1. / CATM(I) ACT. COEFFICIENT FOR PARAM. OF ATMOSPHERE



C  DBFAC       = DISTSANCE    SCALING FACTOR FOR BINNING
C  DBMAX       = MAXIMUM DISTANCE FOR DISTANCE TABLE
C  DBMIN       = MINIMUM DISTANCE FOR DISTANCE TABLE
C  DBOFF       = DISTSANCE    OFFSET         FOR BINNING






C  DC0         = AVERAGE DENSITY AT CENTRE OF RAPIDITY (HDPM)
C  DEBDEL      = FLAG TO STEER DELAYED ACTIVATION OF DEBUG
C  DEBUG       = FLAG TO STEER PRINTOUT FOR DEBUGGING



C  DECTIM(...) = LIFE TIME AT REST OF UNSTABLE PARTICLES
C  DEDXMU      = TABLE OF MUON/TAU ENEGY LOSS IN DIFFERENT MATERIALS
C  DEDXM       = TABLE OF MUON/TAU ENEGY LOSS IN AIR
C  DEP         = ARRAY OF DEPTH VALUES FOR LONGITUDINAL DISTRIBUTION
# 2047 "corsika.h"
C  DIAG        = DISTANCE BETWEEN STARTING POINT AND MIDDLE OF DETECTOR

C  DRECOR      = # WORDS WRITTEN ON PARTICLE TAPE RECORDS
C  DIST(10)    = DISTANCES FROM CORE IN CM (USED BY AVAGE)  (NKG)
C  DISX(.)     = DISTANCES OF BINS FOR RADIAL DISTRIBUTION IN X  (IN CM)
C  DISXY(.)    = DISTANCES OF BINS FOR RADIAL DISTRIBUTION IN XY (IN CM)
C  DISY(.)     = DISTANCES OF BINS FOR RADIAL DISTRIBUTION IN Y  (IN CM)
C  DISYX(.)    = DISTANCES OF BINS FOR RADIAL DISTRIBUTION IN YX (IN CM)
C  DLAX(.)     = USED FOR AVERAGING OF CZX
C  DLAXY(.)    = USED FOR AVERAGING OF CZXY
C  DLAY(.)     = USED FOR AVERAGING OF CZY
C  DLAYX(.)    = USED FOR AVERAGING OF CZYX
C  DLOGS       = LOG OF DIFFRACTIVE MASS SQUARED  (HDPM)
C  DLONG(I,K)  = LONGITUDINAL ENERGY DEPOSITS PER SHOWER IN I BINS FOR
C                1=ABSORBED GAMMAS, 2=EM-IONIZATION, 3=E-CUTTED EM,
C                4=MU-& MU+ IONOZATION, 5= E-CUTTED MUONS,
C                6=HADRON IONIZATION, 7=E-CUTTED HADRONS, 8=NEUTRINO,
C                9=SUM OF DEPOSITS, 10=DUMMY,
C                11=ANGL. CUTTED GAMMAS, 12=DUMMY, 13=ANGL. CUTTED EM,
C                14=DUMMY, 15=ANGL. CUTTED MUONS, 16=DUMMY,
C                17=ANGL. CUTTED HADRONS, 18=ANGL. CUTTED NEUTRINOS,
C                19=DUMMY
C  DMLOG       = LOG(ECMDIF**2 - MASS PI(0)**2 - MASS DIFFR.PART.**2)
C  DNEAR(NP)   = DISTANCE TO NEXT LAYER BOUNDARY OF PART. ON EGS STACK
C  DSN(.)      = DATA SET NAME OF PARTICLE OUTPUT
# 2087 "corsika.h"
C  DSNLONG     = DATA SET NAME OF LONGITUDINAL OUTPUT
C  DSNTAB      = DATA SET NAME OF TABLE OUTPUT

C  DSTLIM      = DISTANCE LIMIT (DOWNSTREAM DETECTOR) FOR TIME LIMIT




C
C  E(NP)       = ENERGY OF PARTICLE ON EGS STACK
C  EA(3000)    = ENERGY OF SECONDARY PARTICLE IN HDPM



C  EBFAC       = ENERGY       SCALING FACTOR FOR BINNING
C  EBMAX       = MAXIMUM ENERGY FOR ENERGY TABLE
C  EBMIN       = MINIMUM ENERGY FOR ENERGY TABLE
C  EBOFF       = ENERGY       OFFSET         FOR BINNING
C  EBYMU       = MASS RATION ELECT. MASS / MUON MASS
C  EBYTAU      = MASS RATION ELECT. MASS / TAU  MASS
C  ECM         = CURPAR(12)



C  ECMDIF      = DIFFRACTIVE MASS FOR HDPM
C  ECMDPM      = C.M. ENERGY FOR HDPM





C  ECTMAP      = CUT TO PRINT OUT PARTICLES
C  EDEP        = ENERGY DEPOSITED ALONG STEP
C  EE          = TOTAL ENERGY OF MUON/TAU FOR INTERACTIONS

C  EEFRTHN     = THINNING EM ENERGY FRACTION OF PRIMARY(=EPSILON_EM)


C  EEPP(.)     = ENERGY OF PARTICLE ON INTERMEDIATE STACK


C  EFRCTHN     = THINNING BELOW ENERGY FRACTION OF PRIMARY

C  EKE         = KINETIC ENERGY OF ELECTRON
C  EKINL       = ENERGY FOR ENERGY-MULTIPLICITY MATRIX
C  ELAB        = LAB ENERGY OF INCOMING PARTICLE IN SDPM/HDPM
C  ELAST       = ELASTICITY OF FIRST REACTION
C  ELCUT(.)    = CUT ON KINETIC ENERGY OF PARTICLES
C  ELEFT       = SUMMED ENERGY OF PARTICLES ON STACK




C  ELIM        = ENERGY LIMIT FOR THINNING

C  ELKE        = LOGARITHM OF ELECTRON KINETIC ENERGY
C  ELMEAA(.)   = MEAN ELASTICITY FOR ENERGY BINS FOR ALL SHOWERS
C  ELMEAN(.)   = MEAN ELASTICITY FOR ENERGY BINS PER SHOWER
C  ELONG(I,K)  = LONGITUDINAL ENERGY DISTRIBUTIONS PER SHOWER IN I
C                BINS FOR K= GAMMAS, POSITRONS, ELECTRONS, MU+, MU-,
C                HADRONS, CHARGED, NUCLEI, AND CHERENKOV PHOTONS





C  ENEPER      = 2.718281828 (EULER''S CONSTANT)



C  ENEW        = ENERGY AT END OF STEP



C  EOLD        = ENERGY AT BEGIN OF STEP
C  EONCUT      = CUTTING ENERGY (IN MEV) FOR REJECT IN EGS




C  ERR         = ARRAY OF ERRORS OF PARTICLE NUMBERS IN LONG. DIST.




C  ETHINN      = THINNING BELOW ENERGY ETHINN  IN MEV FOR EM-PARTICLES
C  ETHINNG     = THINNING BELOW ENERGY ETHINNG IN GEV FOR HADR.PARTICLES




C  EVTE(MAXBUF)= BUFFER FOR EVENT END
C  EVTH(MAXBUF)= BUFFER FOR EVENT HEADER
C  E00         = ENERGY OF PRIMARY NEEDED FOR REJECT IN EGS
C  E00PN       = ENERGY OF PRIMARY PER NUCLEON



C  E_ARRAY     = ARRAY FOR ELECTRONS IN BINS IN ENERGY, TIME, CORE DIST.
C
C  FAC         = VARIABLE OF SUBROUT. RANNOR
# 2204 "corsika.h"
C  FDBASE      = FLAG FOR WRITING SUMMARY FILE FOR DATABASE
C  FDECAY      = FLAG INDICATING PARTICLE UNDERGOES DECAY
# 2215 "corsika.h"
C  FEGS        = FLAG FOR USE OF EGS4
C  FEGSDB      = DEBUG FALG FOR EGS-DEBUGGING




C  FFLATOUT    = FLAG INDICATING PARTICLE OUTPUT TYPE (FLAT OR SPHERE)
# 2231 "corsika.h"
C  FILOUT      = DATA SET NAME OF STACK OF FIRST INTERACTION OUTOUT FILE


C  FIMPCT      = FLAG INDICATING SKIMMING PRIMARY (IMPACT)




C  FIRSTI      = FLAG INDICATING FIRST INTERACTION IN HDPM
C  FIXHEI      = HEIGHT OF FIRST INTERACTION IF TAKEN FIXED (CM)
C  FIXINC      = FLAG TO KEEP ANGLES OF INCIDENCE FIXED
C  FIXTAR      = FLAG TO INDICATE FIXED TARGET FOR FIRST INTERACTION
C  FIX1I       = FLAG TO KEEP HEIGHT OF FIRST INTERACTION FIXED
C  FLGFIT      = LOGICAL TO ENABLE/DISABLE FIT TO CHARGED PART. LONG. DISTR.
C  FLONGOUT    = FLAG INDICATING LONGITUDINAL OUTPUT
C  FMOLI       = FLAG INDICATING MOLIERE (T) OR GAUSS (F) SCATTERING
C  FMUADD      = FLAG TO INDICATE ADDITIONAL MUON OUTPUT ON MPATAP
C  FMUBRM      = FLAG TO INDICATE MUON/TAU HAS TO UNDERGO BREMSSTRAHLUNG
C  FMUNUC      = FLAG TO INDICATE MUON/TAU HAS TO UNDERGO NUCL.INTERACT.
C  FMUORG      = FLAG TO INDICATE WHETHER MUON BELONGS TO AMUPAR(.)
C  FNEUT       = # OF NEUTRAL PARTICLES (ALL 3 STRINGS)  WITH FLUCTUAT
C  FNEUT2      = # OF NEUTRAL PARTICLES (1ST+2ND STRING) WITH FLUCTUAT




C  FNKG        = FLAG FOR USE OF NKG FORMULAS
C  FNPRIM      = FLAG INDICATING THE PRIMARY PARTICLE IN EGS




C  FOUTFILE    = FLAG INDICATING FIRST INTERACTION STACK OUTPUT

C  FPAROUT     = FLAG INDICATING PARTICLE OUTPUT
C  FPRINT      = LOGICAL VARIABLE TO STEER PRINTING







C  FRACTN      = NITROGEN FACTION OF INELASTIC AIR CROSS-SECTION
C  FRCTNO      = NITROGEN+OXYGEN FACTION OF INELASTIC AIR CROSS-SECTION
# 2288 "corsika.h"
C  FSIBSG      = FLAG TO ACTIVATE SIBYLL CROSS-SECTIONS
C  FSIBYL      = FLAG TO ACTIVATE SIBYLL ROUTINES
C  FSIBCH      = FLAG TO ACTIVATE CHARM PRODUCTION IN SIBYLL  

C  FTABOUT     = FLAG INDICATING TABLE OUTPUT




C  FURQMD      = FLAG INDICATING USE OF URQMD
C  FURQSG      = FLAG INDICATING THAT URQMD SIGMA IS AVAILABLE





C



C  GAMMA       = CURPAR(1)
C  GAM345(3)   = GAMMA FACTOR OF PARTICLE EMERGING FROM 3 BODY DECAY
C  GCM         = CURPAR(11)
C  GEN         = GENERATION OF PARTICLE



C  GHEISDB     = FLAG TO ACTIVATE GHEISHA DEBUG OUTPUT
C  GHEISH      = FLAG TO ACTIVATE GHEISHA ROUTINES
C  GHESIG      = FLAG TO INDICATE THAT GHEISHA CROSS-SECTION IS USED




C  GLE         = LOGARITHM OF GAMMA ENERGY
C  GNU         = # OF COLLISIONS IN TARGET (HDPM)



C  G_ARRAY     = ARRAY FOR GAMMAS IN BINS IN ENERGY, TIME, CORE DISTANCE
C
C  H           = CURPAR(5)
C  HBARO       = BAROMETRIC EXPONENT OF ATMOSPHERIC LAYER (EGS4)
C  HBAROI      = INVERSE OF BAROMETRIC EXP. OF ATMOSPHERIC LAYER (EGS4)
C  HEIGHP      = HEIGHT OF FIRST INTERACTION

C  HAPP        = CURPAR(14) APPARENT HEIGHT IN CARTESIAN COORD. SYSTEM
# 2349 "corsika.h"
C  HGROUND     = ALTITUDE OF GROUND (= OBSLEV(1))




C  HILOECM     = ENERGY THRESHOLD FOR HIGH ENERGY MODEL IN CM
C  HILOELB     = ENERGY THRESHOLD FOR HIGH ENERGY MODEL IN LAB

C  HIMPACT(2)  = RANGE OF MINIMAL HEIGHT (IMPACT) FOR SKIMMING PRIMARY
C  HIMPCT      = ACTUAL IMPACT PARAMTER FOR SKIMMING PRIMARY





C  HLAY(6)     = ALTITUDE OF ACTUAL ATMOSPHERIC LAYER BOUNDARIES

C  HLAYC(6)    = LAYER BOUNDARY (CM) FOR SLANT DEPTH CALCULATION
C  HLAYS(6)    = SLANT PATH FROM TOP OF ATMOSPHERE TO LAYER BOUNDARY

C  HLAY0(5,..) = ALTITUDE OF ATMOSPHERIC LAYER BOUNDARIES
C  HLONG(I)    = THE HEIGHT VALUES IN CM FOR THE LEVELS IN G/CM**2



C  HOST        = NAME OF HOST COMPUTER IN USE
# 2392 "corsika.h"
C
C  IALT(2)     = # OF LEVELS IN NKG FOR WHICH ELECT.DENSITIES ARE CALCUL







C  IA1 ... IJ1 = LOWER BOUNDARY OF PARTICLE SPECIES IN HDPM
C  IA2 ... II2 = UPPER BOUNDARY OF PARTICLES 3RD STRING IN HDPM






C  ICOUNT      = POSITION OF PARTICLE WITHIN STACK
# 2420 "corsika.h"
C  ICTABL(.)   = TABLE TO CONVERT PARTICLE TYPE FROM CORSIKA TO SIBYLL

C  IDBIN       = PARAMETER # OF DISTANCE BINS



C  IDIF        = DIFFRACTION FLAG IN HDPM
C  IDISC       = FLAG INDICATING PARTICLE IS TO BE DISCARDED






C  IEBIN       = PARAMETER # OF ENERGY BINS
C  IELDPA(.)   = ELASTICITY STATISTICS IN DUAL PARTON MODELL FOR ALL
C  IELDPM(.)   = ELASTICITY STATISTICS IN DUAL PARTON MODELL FOR SHOWER

C  IENDT       = LAST BIN FOR SLANT DEPTH INTERPOLATION





C  IFINAM      = # PART. PRODUCED IN FIRST INTERACTION

C  IFINCM      = # CHARMED PART. PRODUCED IN FIRST INTERACTION
C  IFINET      = # ETAS PRODUCED IN FIRST INTERACTION
C  IFINHY      = # STRANG BARYONS PRODUCED IN FIRST INTERACTION
C  IFINKA      = # KAONS PRODUCED IN FIRST INTERACTION
C  IFINNU      = # NUCLEONS PRODUCED IN FIRST INTERACTION
C  IFINOT      = # OTHER HADRONS PRODUCED IN FIRST INTERACTION
C  IFINPI      = # PIONS PRODUCED IN FIRST INTERACTION
C  IFINRHO     = # RHO MESONS PRODUCED IN FIRST INTERACTION

C  IFLGPYE     = ERROR FLAG FOR PYTHIA ERROR OUTPUT
C  IFLGPYW     = WARNING FLAG FOR PYTHIA WARNING OUTPUT

C  IGEN(NP)    = GENERATION COUNTER OF PARTICLE ON EGS STACK
C  IHBIN(40)   = COUNTER FOR STRANGE BARYON TABLE FOR SHOWER
C  IHYCHI(124) = INTERACTION LENGTH STATISTICS FOR STRANGE BARYONS
C  IKACHI(124) = INTERACTION LENGTH STATISTICS FOR KAONS
C  IKBIN(40)   = COUNTER FOR KAON TABLE FOR SHOWER
C  IJKL(.)     = ARRAY(KSEQ) FOR RANDOM GENERATOR
C  IMUCHI(124) = INTERACTION LENGTH STATISTICS FOR MUONS



C  INBIN(40)   = COUNTER FOR NUCLEON TABLE FOR SHOWER
C  INECHI(124) = INTERACTION LENGTH STATISTICS FOR NEUTRINOS






C  INNCHI(124) = INTERACTION LENGTH STATISTICS FOR NUCLEI
C  INT_ICOUNT  = POINTER FOR INTERMEDIATE PARTICLE STACK
C  INUCHI(124) = INTERACTION LENGTH STATISTICS FOR NUCLEONS
C  IOBS(NP)    = # OF NEXT OBSERVATION LEVEL FOR PARTICLE ON EGS STACK
C  IPBIN(40)   = COUNTER FOR PION TABLE FOR SHOWER
C  IPICHI(124) = INTERACTION LENGTH STATISTICS FOR PIONS





C  IPTABL(.)   = CONVERSION TABLE CORSIKA CODE TO PYTHIA CODE

C  IQ(NP)      = PARTICLE IDENTIFIER (EGS)




C  IR(NP)      = ACTUAL ATMOSPHERIC LAYER OF PARTICLE ON EGS STACK



C  IRESPAR     = POINTER FOR ARRAY RESRAN
C  IRET1       = RETURN CODE; IRET1=1: PARTICLE CUTTED
C  IRET2       = RETURN CODE; IRET2=1: PARTICLE CUTTED IN UPDATE
C  IRETE       = RETURN CODE; IRETE=T: ENERGY CUT (LOGICAL) IN UPDATE
C  IRNEW       = INDEX OF NEW ATMOSPHERIC LAYER
C  IROLD       = INDEX OF OLD ATMOSPERIC LAYER

C  ISDEBUG     = PRESELECTED DEBUG LEVEL FOR SIBYLL

C  ISEED(.,.)  = RANDOM GENERATOR SEED
C  ISEED1I(3)  = RANDOM GENERATOR SEED AFTER FIRST INTERACTION
C  ISEL        = INDICATOR FOR LOW MULTIPLICITY OF SEC.PARTICLES (HDPM)
C  ISHOWNO     = # OF ACTUAL SHOWER
C  ISHW        = INDEX OF SHOWER LOOP
# 2522 "corsika.h"
C  ISIBDB      = ACTUAL      DEBUG LEVEL FOR SIBYLL

C  ISPEC       = 0 FOR FIXED ENERGY   = 1 FOR ENERGY SPECTRUM

C  ISTABL(.)   = TABLE TO CONVERT PARTICLE TYPE FROM SIBYLL TO CORSIKA




C  ITAR        = PARTICLE CODE OF TARGET NUCLEON IN HDPM
C  ITBIN       = PARAMETER # OF ARRIVAL TIME BINS




C  ITYP(3000)  = PARTICLE TYPE OF SECONDARY PARTICLE IN HDPM
C  ITYPE       = CURPAR(0)  PARTICLE TYPES ACCORDING TO GEANT
C                IN ADDITION : A*100+Z=HEAVY NUCLEI (FOR PRIMARIES ONLY)

C  IUDEBUG     = ACTUAL DEBUG LEVEL FOR URQMD
C  IUDEBG0     = PRESET DEBUG LEVEL FOR URQMD
# 2556 "corsika.h"
C  I97(.)      = ARRAY(KSEQ) FOR RANDOM GENERATOR
C
C  JCLOCK      = PRESET COUNTER FOR EGS-DEBUG ACTIVATION






C  JSEQ        = ACTUAL SEQUENCE NUMBER



C  J97(.)      = ARRAY(KSEQ) FOR RANDOM GENERATOR
C
C  KK          = NUMBER OF TARGET COMPONENTS (GHEISHA)
C  KNOR        = FLAG TO STEER GENERATION OF NORMAL DISTRIBUTED RANDOMS
C  KSEQ        = PARAMETER DEFINING MAX. NUMBER OF INDEPENDENT SEQUENCES
C
C  LASTPI      = # OF CHARGED PIONS CREATED/DELETED BY CHARGE EXCHANGE
C  LAYNEW      = FLAG INDICATING NEW ATMOSPHERIC LAYER BOUNDARIES
C  LAYNO(..)   = POINTER OF ATMOSPHERE MODEL TO LAYER NUMBER



C  LEPAR1      = TYPE OF LEADING PARTICLE BEFORE / AFTER CHARGE EXCHANGE
C  LEPAR2      = TYPE OF TARGET  PARTICLE BEFORE / AFTER CHARGE EXCHANGE



C  LEVL        = LEVEL # OF PARTICLE WRITTEN TO TAPE






C  LH          = BUFFER POINTER



C  LHEIGH      = STEP NUMBER AT INTERACTION POINT




C  LL          = USED FOR PRIMARY ENERGY SELECTION
C  LLIMIT      = LOWER LIMIT OF ENERGY SECTION FOR PRIMARY (GEV)
C  LLONGI      = LOGICAL TO STEER THE SAMPLING OF LONGITUDINAL DISTRIBUTION
C  LNGMAX      = MAXIMUM ARRAY LENGTH OF LONGI ARRAYS
C  LPCTE(NP)   = INDEX OF LONGITUDINAL LAYER FOR PARTICLE ON EGS STACK
# 2616 "corsika.h"
C  LSTCK       = LUN OF PARTICLE PARAMETES INPUT/OUTPUT FILE

C  LSTCK1      = LUN OF FIRST INT PARTICLE PARAMETERS HEADER
C  LSTCK2      = LUN OF FIRST INT PARTICLE PARAMETERS LIST

C  LIT         = INDEX FOR INTERACTING TARGET (1=N, 2=0, 3=A)

C  LTMLMPR     = FLAG FOR PRINTING OF PARTICLE EXCEEDS TIME LIMIT

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
cC  LUNHST      = LUN OF HBOOK HISTOGRAM OUTPUT
c#endif



C
C  MALPHA(20)  = MEAN # OF ALPHAS WRITTEN TO TAPE PER LEVEL





C  MAXA        = MAXIMUM NUCLEON NUMBER FOR PROJECTILE NUCLEUS




C  MAXBUF      = PARAMETER FOR MAXIMAL BUFFER SIZE

C  MAXCLU      = PARAMETER MAXIMUM CLUSTERS
C  MAXENT      = PARAMETER MAXIMUM

C  MAXICOUNT   = PARAMETER FOR MAXIMAL INTERMEDIATE STACK SIZE
C  MAXLEN      = PARAMETER FOR SIZE OF PARTICLE FIELDS
C  MAXPRT      = NUMBER OF SHOWERS TO BE PRINTED

C  MAXSLANT    = # OF POINTS FOR SLANT THICKNSS FUNCTION
C  MAXSLANT2   = # OF POINTS FOR SLANT THICKNSS FUNCTION IN ATM. LAYER

C  MAXSTK      = PARAMETER FOR MAXIMAL STACK SIZE

C  MAXS        = MAXIMUM PARTICLE  NUMBER FOR PROJECTILE
C  MAXZ        = MAXIMUM ATOMIC NUMBER FOR PROJECTILE NUCLEUS
# 2673 "corsika.h"
C  MCHRMM(20)  = MEAN # OF CHARMED MESONS WRITTEN TO TAPE PER LEVEL
C  MCHRMB(20)  = MEAN # OF CHARMED BARYONS WRITTEN TO TAPE PER LEVEL
C  MDBASE      = LUN OF DATABASE FILE
C  MDEBUG      = LUN OF DEBUG OUTPUT
C  MDEUT(20)   = MEAN # OF DEUTERONS WRITTEN TO TAPE PER LEVEL
C  MELECT(20)  = MEAN # OF E- WRITTEN TO TAPE PER LEVEL
C  MEXST       = LUN OF SCRATCH DSN FOR EXTERNAL STACK






C  MHELI3(20)  = MEAN # OF 3HELIUM WRITTEN TO TAPE PER LEVEL
C  MHYP(20)    = MEAN # OF STRANGE BARYONS WRITTEN TO TAPE PER LEVEL



C  MKMI(20)    = MEAN # OF K - WRITTEN TO TAPE PER LEVEL
C  MKPL(20)    = MEAN # OF K + WRITTEN TO TAPE PER LEVEL
C  MK0L(20)    = MEAN # OF K0L WRITTEN TO TAPE PER LEVEL
C  MK0S(20)    = MEAN # OF K0S WRITTEN TO TAPE PER LEVEL
C  MLONGOUT    = LUN OF LONGITUDINAL TABLE OUTPUT



C  MMUM(20)    = MEAN # OF MU- WRITTEN TO TAPE PER LEVEL
C  MMUOND      = MEAN # OF MUONS DECAYED TO ELECTRONS/POSITRONS
C  MMUONE      = MEAN # OF MUONS ELIMINATED BECAUSE OF ENERGY/ANGULAR CUT
C  MMUP(20)    = MEAN # OF MU+ WRITTEN TO TAPE PER LEVEL
C  MNEUTB(20)  = MEAN # OF ANTINEUTRONS WRITTEN TO TAPE PER LEVEL
C  MNEUTR(20)  = MEAN # OF NEUTRONS WRITTEN TO TAPE PER LEVEL
C  MNU(20)     = MEAN # OF NEUTRINOS WRITTEN TO TAPE PER LEVEL
C  MODATM      = INDEX OF ATMOSPHERIC MODEL
C  MODCNS      = MODULUS (NOTOT * MODCNS = NTOT2) FOR RANDOM GENERATOR

C  MODETHN     = MODE FOR READING IN THIN VARIABLES

C  MONIIN      = LUN OF CARD READER
C  MONIOU      = LUN OF LINE PRINTER
C  MOTHER(20)  = MEAN # OF OTHER PARTICLES WRITTEN TO TAPE PER LEVEL




C  MPARTO(.)   = ARRAY FOR MEAN # OF PARTICLES
C  MPATAP      = LUN OF DATASET FOR PARTICLE OUTPUT
C  MPHOTO(20)  = MEAN # OF GAMMAS WRITTEN TO TAPE PER LEVEL



C  MPIM(20)    = MEAN # OF PI- WRITTEN TO TAPE PER LEVEL
C  MPIP(20)    = MEAN # OF PI+ WRITTEN TO TAPE PER LEVEL
C  MPI0(20)    = MEAN # OF PI(0) WRITTEN TO TAPE PER LEVEL
C  MPOSIT(20)  = MEAN # OF E+ WRITTEN TO TAPE PER LEVEL
C  MPROTB(20)  = MEAN # OF ANTIPROTONS WRITTEN TO TAPE PER LEVEL
C  MPROTO(20)  = MEAN # OF PROTONS WRITTEN TO TAPE PER LEVEL
C  MSMM        = MULTIPLICITY FOR ENERGY-MULTIPLICITY MATRIX
C  MSTACKP     = STACK POINTER



C  MT          = FLAG INDICATING MU(=1) OR TAU(=2)
C  MTABOUT     = LUN OF TABLE OUTPUT FOR CHARGED PARTICLES






C  MTRIT(20)   = MEAN # OF TRITONS WRITTEN TO TAPE PER LEVEL
C  MULTMA(.)   = ENERGY-MULTIPLICITY MATRIX FOR SHOWER
C  MULTOT(.)   = ENERGY-MULTIPLICITY MATRIX FOR SHOWER GROUP
C  MVDATE      = DATE OF VERSION AS INTEGER (YYYYMMDD)

C  MWGHMA(,)   = WEIGHT MATRIX OF SINGLE SHOWER
C  MWGHTOT(,)  = TOTALIZED WEIGHT MATRIX OF ALL SHOWERS

C  M_ARRAY     = ARRAY FOR MUONS IN BINS IN ENERGY, TIME, CORE DISTANCE
C
C  NALPHA(20)  = # OF ALPHAS WRITTEN TO TAPE PER LEVEL
C  NBLKS       = # OF SMALL BLOCKS PUT OUT (FOR TP)






C  NCH         = # OF CHARGED PARTICLES (HDPM)
C  NCHRMM(20)  = # OF CHARMED MESONS WRITTEN TO TAPE PER LEVEL
C  NCHRMB(20)  = # OF CHARMED BARYONS WRITTEN TO TAPE PER LEVEL
C  NCLOCK      = ACTUAL ELECTRON COUNTER FOR EGS-DEBUG

C  NCLUSTER    =
C  NCLUENT     =
C  NCLUST      =

C  NCPLUS      = POSITIVE CHARGE EXCESS BY RESONANCE/CHARGE EXCHANGE
C  NDEBDL      = NUMBER OF MAPPED PARTICLE THAT ACTIVATES DELAYED DEBUG
C  NDEUT(20)   = # OF DEUTERONS WRITTEN TO TAPE PER LEVEL



C  NELECT(20)  = # OF ELECTRONS WRITTEN TO TAPE PER LEVEL
C  NET         = TOTAL # OF ETAS  (HDPM)
C  NETA(I,K)   = # OF ETAS  IN 1ST + 2ND / 3RD STRING (HDPM)
C                SEPARATELY DEFINED FOR EACH DECAY MODE K
C  NETAS(I)    = # OF ETAS                 IN 1ST + 2ND / 3RD STRING
C  NEUTOT      = TOTAL # OF NEUTRAL PARTICLES  IN HDPM
C  NEWOBS      = POINTER FOR NEXT OBSERVATIONLEVEL (EGS4)




C  NFLAIN      = 0  RANDOM NUMBER OF INTERACTIONS IN AIR TARGET
C              = 1  FIXED  NUMBER OF INTERACTIONS IN AIR TARGET
C  NFLCHE      = 0  CHARGE EXCHANGE INTERACTION POSSIBLE
C              = 1  NO CHARGE EXCHANGE INTERACTION POSSIBLE
C  NFLDIF      = 0  NO DIFFRACTIVE INTERACTION IF NFLAIN = 0 AND MORE
C                   THAN 1 INTERACTION
C  NFLPIF      = 0  NO FLUCTUATION OF NUMBER OF PI0
C              = 1  FLUCTUATION OF NUMBER OF PI0 AS SEEN IN COLLIDER
C  NFLPI0      = 0  RAPIDITY OF PI0 TREATED ACCORDING TO COLLIDER DATA
C              = 1  RAPIDITY OF PI0 SAME AS THAT OF CHARGED
C  NFRAGM      = 0  TOTAL FRAGMENTATION OF PRIMARY NUCLEUS IN 1.INTERACT
C              = 1  NO FRAGMENTATION AND NO EVAPORATION
C              = 2  REALISTIC FRAGMENTATION OR EVAPORATION (PT AFTER JACEE)
C              = 3  REALISTIC FRAGMENTATION OR EVAPORATION (PT AFTER GOLDHABER)
C              = 4  REALISTIC FRAGMENTATION OR EVAPORATION WITH PT-0
C  NFROM       = # OF PARTICLES READ FROM STACK



C  NHC         = # OF CHARGED STRANGE BARYON PAIRS  (HDPM)
C  NHELI3(20)  = # OF 3HELIUM WRITTEN TO TAPE PER LEVEL
C  NHN         = TOTAL # OF NEUTR.STR.BAR. PAIRS    (HDPM)
C  NHYP(20)    = # OF STR. BARYONS WRITTEN TO TAPE PER LEVEL
C  NHYPN(.)    = # OF NEUTR.STR.BAR.PAIRS  IN 1ST + 2ND / 3RD STRING
C  NKA0(.)     = # OF NEUTRAL KAON  PAIRS  IN 1ST + 2ND / 3RD STRING
C  NKC         = # OF CHARGED KAON  PAIRS  (HDPM)
C  NKMI(20)    = # OF K- WRITTEN TO TAPE PER LEVEL
C  NKN         = TOTAL # OF NEUTRAL KAON   PAIRS  (HDPM)
C  NKPL(20)    = # OF K+ WRITTEN TO TAPE PER LEVEL
C  NK0L(20)    = # OF K0L WRITTEN TO TAPE PER LEVEL
C  NK0S(20)    = # OF K0S WRITTEN TO TAPE PER LEVEL






C  NMUM(20)    = # OF MU- WRITTEN TO TAPE PER LEVEL
C  NMUOND      = # OF MUONS DECAYED TO ELECTRONS/POSITRONS
C  NMUONE      = # OF MUONS ELIMINATED BECAUSE OF ENERGY/ANGULAR CUT
C  NMUP(20)    = # OF MU+ WRITTEN TO TAPE PER LEVEL
C  NNC         = # OF PROTON/ANTIPROTON PAIRS  (HDPM)
C  NNEUTB(20)  = # OF ANTINEUTRONS WRITTEN TO TAPE PER LEVEL
C  NNEUTR(20)  = # OF NEUTRONS WRITTEN TO TAPE PER LEVEL



C  NNN         = TOTAL # OF NEUTRON/ANTINEUTRON PAIRS (HDPM)



C  NNU(20)     = # OF NEUTRINOS WRITTEN TO TAPE PER LEVEL
C  NNUCN(.)    = # OF NEUTRON PAIRS  IN 1ST + 2ND / 3RD STRING (HDPM)
C  NOBSLV      = # OF OBSERVATION LEVELS



C  NOPART      = COUNTER FOR PARTICLES WRITTEN TO TAPE
C  NOTHER(20)  = # OF OTHER PARTICLES WRITTEN TO TAPE PER LEVEL
C  NOUREC      = # OF STACK OUTPUT RECORDS
C  NOURECMAX   = MAX # OF STACK OUTPUT RECORDS



C  NP          = STACK POINTER OF PARTICLE ON EGS STACK



C  NPARTO(.)   = ARRAY CONTAINING  # OF PARTICLES AT OBSERVATION LEVEL
C  NPART2(.)   = ARRAY CONTAINING  # OF PARTICLES AT OBSERVATION LEVEL
C  NPC         = # OF CHARGED PIONS (HDPM)
C  NPHOTO(20)  = # OF GAMMAS WRITTEN TO TAPE PER LEVEL
C  NPIM(20)    = # OF PI- WRITTEN TO TAPE PER LEVEL
C  NPIP(20)    = # OF PI+ WRITTEN TO TAPE PER LEVEL
C  NPIZER(.)   = # OF PI(0)S IN 1ST + 2ND / 3RD STRING (HDPM)
C  NPI0(20)    = # OF PI(0) WRITTEN TO TAPE PER LEVEL





C  NPN         = TOTAL # OF PI(0)S  (HDPM)
C  NPOSIT(20)  = # OF POSITRONS WRITTEN TO TAPE PER LEVEL
C  NPROTB(20)  = # OF ANTIPROTONS WRITTEN TO TAPE PER LEVEL
C  NPROTO(20)  = # OF PROTONS WRITTEN TO TAPE PER LEVEL



C  NRECS       = # OF BIG BLOCKS PUT OUT (FOR TP)
C  NRESPC      = # OF CHARGED PIONS TO BE CREATED BY RESONANCE DECAY
C  NRESPN      = # OF NEUTRAL PIONS TO BE CREATED BY RESONANCE DECAY
C  NRRUN       = # OF RUN
C  NSEQ        = # OF RANDOM GENERATOR SEQUENCE
C  NSHIFT      = # OF STACK SHIFTS



C  NSHOW       = # OF SHOWERS TO GENERATE
C  NSTEP       = NUMBER OF STEPS FOR LONGITUDINAL DISTRIBUTION
C  NSTP        = NUMBER OF STEPS FOR LONGITUDINAL DIST. FIT



C  NTO         = # OF PARTICLES WRITTEN TO STACK




C  NTOT        = TOTAL NUMBER OF PARTICLES (HDPM)
C  NTOT(.)     = ARRAY(KSEQ) FOR RANDOM GENERATOR
C  NTOTEM      = TOTAL #OF SECONDARY PARTICLES IN HDPM
C  NTOT2(.)    = ARRAY(KSEQ) FOR RANDOM GENERATOR
C  NTRIT(20)   = # OF TRITONS WRITTEN TO TAPE PER LEVEL
C  NUCNUC      = LUN OF CROSS-SECTION FILE
C  NUCTAB      = TABLE OF MUON/TAU NUCLEAR INTERACTION CROSS-SECTIONS



C  N1STTR      = NUMBER OF FIXED FIRST TARGET 0=RANDOM, 1=N, 2=O, 3=AR




C
C  OBSATI(2)   = OBSERVATION LEVELS IN CM (USED IN NKG)(MAX. 2)
C  OBSLEV(..)  = OBSERVATION LEVELS (CM)
C  OBSLVL      = OBSERVATION LEVEL (EGS4)
C  OBSLV2      = OBSERVATION LEVEL - 1G/CM**2 (EGS4 AUGERHIST)
C  OB3         = ONE BY THREE = 1./3.
C  OMC         = CONSTANT OMEGA_C FOR MUOMN MULTIPLE SCATTERING



C  ..PARTICLE TO BE WRITTEN TO TAPE
C  OUTPAR(..)  = PARTICLE FIELD FOR OUTPUT PARTICLE (COMP. SECPAR)
C
C  PAIRTAB     = TABLE OF MUON/TAU PAIR PRODUCTION CROSS-SECTIONS
C  PAMA(6000)  = MASS OF PARTICLE (GEV)
# 2938 "corsika.h"
C  PATH1(.)    = SLANT PATH LENGTH


C  PHINCL      = PHI ANGLE OF THE NORMAL TO THE INCLINED OBSERVATION PLANE

C  PHIX        = CURPAR(3)
C  PHIY        = CURPAR(4)
C  PHIPR(2)    = RANGE PHI OF PRIMARY PARTICLE IN RADIAN
C  PHIP        = ACTUAL PHI OF PRIMARY PARTICLE IN RADIAN
C  PHISCT      = AZIMUTAL ANGLE OF MUON MULTIPLE SCATTERING
C  PHI345(3)   = ANGLE PHI OF PARTICLE EMERGING FROM 3 BODY DECAY



C  PI          = 3.14159...     SET IN BLOCK DATA
C  PI2         = 2 * PI
C  PICMAS      = MASS OF CHARGED PION (EGS4)



C  PITHR       = THRESHOLD ENERGY FOR PHOTONUCLEAR INTERACT. (EGS4)
C  PI0MAS      = MASS OF PI(0) (EGS4)
C  PI0MSQ      = MASS OF PI(0) SQUARED (EGS4)
C  PLAB        = MOMENTUM OF INCOMING PARTICLE IN LAB SYSTEM
# 2971 "corsika.h"
C  PLONG(I,K)  = LONGITUDINAL PARTICLE DISTRIBUTIONS PER SHOWER IN I
C                BINS FOR K= GAMMAS, POSITRONS, ELECTRONS, MU+, MU-,
C                HADRONS, CHARGED, NUCLEI, AND CHERENKOV PHOTONS
# 2986 "corsika.h"
C  PNOA30(.)   = ARRAY FOR PROBABILITY OF # OF INTERACTIONS
C  PNOA45(.)   = ARRAY FOR PROBABILITY OF # OF INTERACTIONS
C  PNOA60(.)   = ARRAY FOR PROBABILITY OF # OF INTERACTIONS
C  POLARF      = PHI        ; POLARIZATION DIRECTION OF MUON
C  POLART      = COS(THETA) ; POLARIZATION DIRECTION OF MUON
C  POSC2       = POSITION OF GAUSSIAN FOR 1ST+2ND STRING (CHARGED)
C  POSC3       = POSITION OF GAUSSIAN FOR 3RD     STRING (CHARGED)
C  POSN2       = POSITION OF GAUSSIAN FOR 1ST+2ND STRING (NEUTRAL)
C  POSN3       = POSITION OF GAUSSIAN FOR 3RD     STRING (NEUTRAL)
C  PPICH       = RATIO # PI+(+-) / # ALL CHARGED PARTICLES (HDPM)
C  PPINCH      = RATIO # PI+(+-)+PROTON / # ALL CHARGED PARTICLES (HDPM)
C  PPNKCH      = RATIO # PI+(+-)+PROTON+K(+-) / # ALL CHARGED PARTICLES



C  PRMPAR(..)  = PARTICLE FIELD FOR PRIMARY PARTICLE (COMP. CURPAR)
C  PROBTA(3)   = INTEGRATED ATOMIC FRACTIONS






C  PROPMOD     = FLAG FOR USE OF STANDARD INTERACTION(0) OR HEPARIN(1)

C  PRRMMU      = REST MASS OF MUON (EGS4)
C  PSLOPE      = SLOPE OF PRIMARY DIFFERENTIAL ENERGY SPECTRUM
C                IF PRIMARY ENERGY IS TO BE COMPUTED FROM A SPECTRUM
C  PTOT0       = TOTAL MOMENTUM OF PRIMARY
C  PTOT0N      = TOTAL MOMENTUM OF PRIMARY PER NUCLEON
# 3025 "corsika.h"
C  PT2(3000)   = PT**2             OF SECONDARY PARTICLE IN HDPM
C  PX(3000)    = PT IN X DIRECTION OF SECONDARY PARTICLE IN HDPM
C  PY(3000)    = PT IN Y DIRECTION OF SECONDARY PARTICLE IN HDPM
C
# 3041 "corsika.h"
C




C  RADGRD      = RADIUS OF GROUND (= C(1) + HGROUND)

C  RADNKG      = RADIUS RANGE FOR NKG ELECTRON DENSITIES IN CM



C  RATIO       = RATIO TOTAL STEP LENGTH/SCATTERING LENGTH FOR ELECTRONS
C  RC3TO2      = RATIO (CHARGED OF 3RD STRING)/(CHARGED 1ST+2ND STRING)
C  RCUT        = RADIUS WITHIN WHICH PARTICLES ARE DISCARDED FROM OUTPUT
C  RCUT2       = RCUT**2
C  RD(3000)    = ARRAY (DOUBLE PRECISION) FOR RANDOM NUMBERS
C  RDRES(2)    = RANDOM NUMBERS FOR RESONANCE DECAYS
C  RESRAN(.)   = RANDOM NUMBERS FOR RESONANCE DECAYS
C  RESTMS(6000)= RELEASABLE KINETIC ENERGY OF PARTICLE
C  RHOFAC      = DENSITY FACTOR

C  RHOSLT(.)   = DENSITY ALONG SLANT BIN


C  RHOS(6)     = DENSITY AT LAYER BOUNDARY
C  RLOFF       = OFFSET OF PLANE NORMAL TO SHOWER AXIS
C  RLONG(.)    = ARRAY FOR DISTANCES TO PLANE NORMAL TO SHOWER AXIS


C  RLIM        = FLAG INDICATING THAT RADIAL THINNING IS ACTIVE


C  RMAX        = MAX. RADIUS FOR RADIAL THINNING
C  RMAX2       = RMAX**2




C  RMOL(1)     = MOLIERE RADIUS IN AIR IN CM AT LOWER LEVEL
C  RMOL(2)     = MOLIERE RADIUS IN AIR IN CM AT HIGHER LEVEL
C  RMMUT4      = 4 * REST MASS OF MUON (EGS4)






C  RPEKNR      = RATIO # PI(0)+ETA+KA0+NEUTR/ # ALL NEUTRAL PARTICLES
C  RPEKR       = RATIO # PI(0)+ETA+KA0/ # ALL NEUTRAL PARTICLES (HDPM)
C  RPIER       = RATIO # PI(0)+ETA / # ALL NEUTRAL PARTICLES (HDPM)
C  RPI0R       = RATIO # PI(0) / # ALL NEUTRAL PARTICLES (HDPM)
C  RUNE(MAXBUF)= BUFFER FOR RUN   END
C  RUNH(MAXBUF)= BUFFER FOR RUN   HEADER
C
C  S           = C.M. ENERGY SQUARED  IN HDPM
C  SABIN(40)   = LOW  EDGE OF KIN. ENERGY FOR INTERACTION-ENERGY TABLE
C  SAH(10)     = AGE IN STEPS OF 100 G/CM**2



C  SBBIN(40)   = HIGH EDGE OF KIN. ENERGY FOR INTERACTION-ENERGY TABLE
C  ..SECONDARY PARTICLE
C  SECPAR(..)  = PARTICLE FIELD FOR SECONDARY PARTICLE (COMP. CURPAR)
C  SECPAR(9)   = GENERATION OF PARTICLE
C  SECPAR(10)  = LEVEL OF LAST INTERACTION
C  SECPAR(11)  = POLARIZATION DIRECTION: COS(THETA) FOR MUONS
C  SECPAR(12)  = POLARIZATION DIRECTION: PHI FOR MUONS

C  SECPAR(13)  = WEIGHT FOR THINNING


C  SECPAR(14)  = APPARENT HEIGHT  IN CARTESIAN COORDINATE SYSTEM
C  SECPAR(15)  = APPARENT ZENITH ANGLE OF PARTICLE POSITION IN CART.COORDINATE SYSTEM
C  SECPAR(16)  = ANGLE PARTICLE TO MID DETECT AT CENTER EARTH
# 3152 "corsika.h"
C  SDLONG(I,K) = STANDARD DEVIATION OF DLONG
C  SE          = SQUARE ROOT OF E_NEPER
C  SELONG(I,K) = STANDARD DEVIATION OF ELONG
C  SEL(10)     = USED FOR AVERAGING OF SL(10)   (NKG)
C  SELLG(10)   = USED FOR LOGARITHMIC AVERAGING OF SL(10)
C  SEUGF       = NUMBER OF GAMMAS (WITH FLUCTUATION) (HDPM)
C  SEUGP       = NUMBER OF GAMMAS (AVERAGE PARAMETRIZED) (HDPM)
C  SE14(.)     = ARRAY FOR COLLISION PROBABILITY
C  SE16(.)     = ARRAY FOR COLLISION PROBABILITY
C  SE40(.)     = ARRAY FOR COLLISION PROBABILITY





C  SIGAIR      = INELASTIC CROSS-SECTION IN AIR
C  SIGANN      = NUCLEON ANNIHILATION CROSS-SECTION
C  SIGA30(.)   = ARRAY FOR CROSS-SECTIONS ARGON
C  SIGA45(.)   = ARRAY FOR CROSS-SECTIONS ARGON
C  SIGA60(.)   = ARRAY FOR CROSS-SECTIONS ARGON
C  SIGMA       = INELASTIC CROSS-SECTION FOR HADRON NUCLEON COLLISION

C  SIGMAQ      = CROSS SECTION FOR CHARMED AND BOTTOM PARTICLES





C  SIGNUM(6000) = SIGN AND CHARGE OF PARTICLES
C  SIGN30(.)   = ARRAY FOR CROSS-SECTIONS NITROGEN
C  SIGN45(.)   = ARRAY FOR CROSS-SECTIONS NITROGEN
C  SIGN60(.)   = ARRAY FOR CROSS-SECTIONS NITROGEN
C  SIGO30(.)   = ARRAY FOR CROSS-SECTIONS OXYGEN
C  SIGO45(.)   = ARRAY FOR CROSS-SECTIONS OXYGEN
C  SIGO60(.)   = ARRAY FOR CROSS-SECTIONS OXYGEN




C  SIG1I       = CROSS-SECTION FOR FIRST INTERACTION
C  SIG30A(.)   = ARRAY FOR CROSS-SECTIONS AIR
C  SIG45A(.)   = ARRAY FOR CROSS-SECTIONS AIR
C  SIG60A(.)   = ARRAY FOR CROSS-SECTIONS AIR
C  SINANG      = SIN OF ARRANR
C  SINB        = SIN OF INCLINATION ANGLE MAGNETIC FIELD



C  SL(10)      = NUMBER OF ELECTRONS IN STEPS OF 100 G/CM**2 (NKG)
C  SLEX        = EXPONENT OF SLOPE OF PRIMARY SPECTRUM
C  SLOG        = LOG OF C.M. ENERGY SQUARED  (HDPM)
C  SLOGSQ      = SQUARE OF LOG OF C.M. ENERGY SQUARED  (HDPM)
C  SMLOG       = LOG ( C.M. ENERGY SQUARED  - 2 * NUCL.MASS**2 ) (HDPM)
C  SPHISCT     = SINE   OF AZIMUTAL ANGLE OF MUON MULTIPLE SCATTERING
C  SPHI345(3)  = SINE   PHI   OF PARTICLE EMERGING FROM 3 BODY DECAY
C  SPLONG(I,K) = STANDARD DEVIATION OF PLONG
C  SQRT3       = SQRT(3.)
# 3224 "corsika.h"
C  STACKI(MAXSTK) = PARTICLE STACK FOR 2 * 256 PARTICLES A 17 WORDS
# 3236 "corsika.h"
C  STACKINT(,) = INTERMEDIATE STACK OF PARTICLE COORDINATES
C  STEPFC      = STEP LENGTH FACTOR FOR ELECTRON MULTIPLE SCATTERING
C  STEPL       = STEP LENGTH FOR MUON TRANSPORT STEP
C  STERNCOR    = PARAMETER FOR STERNHEIMER CORRECTION (SEE SUBR. ELECTR)
C  STH(10)     = AGE IN STEPS OF 100 G/CM**2, SUM OVER ALL SHOWERS (NKG)

C  STHCPH      = SINTHE*COSPHI OF PRIMARY FOR PLANE NORM. TO SHOWER AXIS
C  STHSPH      = SINTHE*SINPHI OF PRIMARY FOR PLANE NORM. TO SHOWER AXIS







C
C  T           = CURPAR(6)



C  TAR         = NUMBER OF NUCLEONS IN TARGET (HDPM)
C  TARG1I      = TARGET OF FIRST INTERACTION
C  TBFAC       = ARRIVAL TIME SCALING FACTOR FOR BINNING
C  TBMAX       = MAXIMUM ARRIVAL TIME FOR TIME TABLE
C  TBMIN       = MINIMUM ARRIVAL TIME FOR TIME TABLE
C  TBOFF       = ARRIVAL TIME OFFSET         FOR BINNING
C  TB3         = TWO BY THREE = 2./3.
# 3271 "corsika.h"
C  TDINCL      = DEPTH ON THE AXIS FOR AUTOMATIC PLANE PERPENDICULAR TO SHOWER AXIS 

C  THCKOB(..)  = LAYER THICKNESS AT OBSERVATION LEVEL (G/CM**2)

C  THCKRL(.)   = ARRAY FOR THICKNESS TO PLANE NORMAL TO SHOWER AXIS

C  THETPR(2)   = RANGE OF THETA OF PRIMARY PARTICLE IN RADIAN
C  THETAP      = ACTUAL THETA OF PRIMARY PARTICLE IN RADIAN
C  THICKA(..)  = THICKNESS OF AIR LAYER (EGS)
C  THICKD(..)  = THICKNESS OF AIR LAYER BELOW OBSERVATION LEVEL (EGS)
C  THICKH      = THICK(H) MASS OVERBURDEN OF ACTUAL PARTICLE ALTITUDE
C  THICKL(5)   = THICKNESS AT ATMOSPHERIC LAYER BOUNDARIES

C  THICKS(6)   = SLANT THICKNESS TOP OF ATMOSPHERE TO LAYER BOUNDARY

C  THICK0      = HEIGHT OF START OF PRIMARY (IN G/CM**2)

C  THINCL      = THETA ANGLE OF THE NORMAL TO THE INCLINED OBSERVATION PLANE

C  THINNING    = FLAG INDICATING THINNING FOR CURRENT INTERACTION

C  THINRAT     = ENERGY RATIO (EPSILON_EM)/(EPSILON)
C  THINRATH    = ENERGY RATIO (EPSILON_HADR)/(EPSILON)







C  THSTEP      = STEP WIDTH IN G/CM**2 FOR LONGITUDINAL DISTRIBUTION
C  THSTPI      = 1/THSTEP
C  TIM(NP)     = TIME OF PARTICLE ON EGS STACK

C  TIMLIM      = TIME LIMIT FOR PARTICLE SINCE 1. INTERACT (SEC)







C  TLEV(10)    = LEVELS IN NKG IN G/CM**2  (NKG)
C  TLEVCM(10)  = LEVELS IN NKG IN CM  (NKG)







C  TMARGIN     = FLAG INDICATING ARR. TIME ZERO AT ENTRANCE INTO ATMOSPHERE
C  TMAS(3000)  = TRANSVERSE MASS   OF SECONDARY PARTICLE IN HDPM
# 3346 "corsika.h"
C  TSCAT       = SEE EQ. 2.14.82 IN SLAC-265




C  TSLAN(NP)   = SLANT DEPTH OF PARTICLE ON EGS STACK
C  TSLANT(.)   = SLANT THICKNESS  TOP OF ATMOSPHERE TO BIN

C  TSTEP       = DISTANCE TO NEXT INTERACTION
C  TUSTEP      = TOTAL (CURVED) STEP LENGTH REQUESTED
C  TVSTEP      = ACTUAL TOTAL STEP LENGTH
C  TWOM24      = 2**-24 (MANTISSA SINGLE PRECISION)
C  TWOM48      = 2**-48 (MANTISSA DOUBLE PRECISION)



C
C  U(NP)       = X DIRECTION COSINE OF PARTICLE ON EGS STACK
C  U(.)        = ARRAY(KSEQ) FOR RANDOM GENERATOR



C  UL          = USED FOR PRIMARY ENERGY SELECTION
C  ULIMIT      = UPPER LIMIT OF ENERGY SECTION FOR PRIMARY (GEV)
C  UNI         = FINAL RANDOM NUMBER

C  URCRNU      = CROSS-SECTION FOR NUCLEUS-AIR COLLISION
C  URCRSP      = CROSS-SECTION FOR HADRON-AIR COLLISION

C  USELOW      = FLAG INDICATING LOW ENERGY HADRONIC INTERACTION
C  USER        = NAME OF USER
C  USTEP       = USER STEP LENGTH REQUESTED
C  U1          = VARIABLE OF SUBROUT. RANNOR
C  U2          = VARIABLE OF SUBROUT. RANNOR
C
C  V(NP)       = Y DIRECTION COSINE OF PARTICLE ON EGS STACK



C  VERDAT(.)   = DATE OF RELEASE OF VERSION
C  VERNUM      = VERSION NUMBER OF CORSIKA
C  VFRAC       = ENERGY FRACTION FOR SECONDARY IN MUON/TAU INTERACTION
C  VMAX        = MAX. VALUE OF ENERGY FRACTION FOR MUON/TAU INTERACT.
C  VMIN        = MIN. VALUE OF ENERGY FRACTION FOR MUON/TAU INTERACT.
C  VSCAT       = POLAR ANGLE OF MUON MULTIPLE SCATTERING
C  VSTEP       = ACTUAL STEP LENGTH



C
C  W(NP)       = Z DIRECTION COSINE OF PARTICLE ON EGS STACK

C  WA(NP)      = ANGLE PARTICLE TO MID DETECT AT CENTER EARTH (EGS)
C  WAP(NP)     = APPARENT ZENITH ANGLE IN CART.COORDINATE SYSTEM (EGS)





C  WCOMP       = ATOMIC FRACTION OF COMPONENT (GHEISHA)

C  WEIGHT      = CURPAR(13), WEIGHT FOR THINNING
C  WEITRAT     = WEIGHT LIMIT RATIO (WMAX_EM)/(WMAX)
C  WEITRATH    = WEIGHT LIMIT RATIO (WMAX_HADR)/(WMAX)







C  WIDC2       = WIDTH OF GAUSSIAN FOR 1ST+2ND STRING (CHARGED) (HDPM)
C  WIDC3       = WIDTH OF GAUSSIAN FOR 3RD     STRING (CHARGED) (HDPM)
C  WIDN2       = WIDTH OF GAUSSIAN FOR 1ST+2ND STRING (NEUTRAL) (HDPM)
C  WIDN3       = WIDTH OF GAUSSIAN FOR 3RD     STRING (NEUTRAL) (HDPM)

C  WLIM        = FLAG INDICATING THAT WEIGHT LIMITATION IS ACTIVE
C  WMAX        = MAX. WEIGHT FOR WEIGHT LIMITATION (HADR.)
C  WMAX0       = MAX. WEIGHT FOR WEIGHT LIMITATION (HADR.)
C  WMAXE       = MAX. WEIGHT FOR WEIGHT LIMITATION (EM)
C  WMAXE0      = MAX. WEIGHT FOR WEIGHT LIMITATION (EM)
C  WMAXEM      = MAX. WEIGHT LIMIT (EM-PARTICLES) FOR WEIGHT LIMITATION
# 3436 "corsika.h"
C  WRRUNH      = FLAG INDICATING RUNHEADER IS WRITTEN
C  WRRUNE      = FLAG INDICATING RUNEND    IS WRITTEN
C  WREVTH      = FLAG INDICATING EVTHEADER IS WRITTEN
C  WREVTE      = FLAG INDICATING EVTEND    IS WRITTEN


C  WT(NP)      = WEIGHT IN CASE OF THINNING (EGS)
# 3451 "corsika.h"
C
C  X           = CURPAR(7)
C  X(NP)       = X COORDINATE OF PARTICLE ON EGS STACK
# 3470 "corsika.h"
C  XOFF(..)    = OFFSET OF X COOR. FOR INCLINED SHOWERS AT OBS. LEVEL




C  XPINCL      = X COORDINATE OF INCLINED OBSERVATION PLANE
# 3490 "corsika.h"
C  XXXX(NP)    = X COORDINATE IN DETECTOR SYSTEM (CURVED)


C
C  Y           = CURPAR(8)
C  Y(NP)       = Y COORDINATE OF PARTICLE ON EGS STACK





C  YCM         = RAPIDITY OF CM SYSTEM IN LABORATORY  (HDPM)



C  YOFF(..)    = OFFSET OF Y COOR. FOR INCLINED SHOWERS AT OBS. LEVEL




C  YPINCL      = Y COORDINATE OF INCLINED OBSERVATION PLANE

C  YR(3000)    = RAPIDITY  OF SECONDARY PARTICLE IN HDPM
# 3524 "corsika.h"
C  YYOLD       = COORDINATE OF EM PARTICLE FOR SUBTRACT. FROM NKG (EGS4)


C  YYYY(NP)    = Y COORDINATE IN DETECTOR SYSTEM (CURVED)


C  YY0         = RAPIDITY OF DIFFRACTIVE SYSTEM IN CMS (HDPM)
C
C  Z(NP)       = Z COORDINATE OF PARTICLE ON EGS STACK
C  ZALTIT      = STARTING ALTITUDE (EGS4)

C  ZAP(NP)     = APPARENT HEIGHT IN CARTESIAN COORDINATE SYSTEM (EGS)
C  ZATOM       = ATOMIC NUMBER OF TARGET FOR MUON/TAU INTERACTIONS

C  ZCOMP       = ATOMIC NUMBER OF COMPONENT (GHEISHA)



C  ZEL(10)     = USED FOR FLUCTUATION OF SEL(10)          (NKG)
C  ZELLG(10)   = USED FOR FLUCTUATION OF SELLG(10)



C  ZN          = CENTR. RAP. DENSITY FOR CALCULATION OF PT
C  ZNE(10)     = PARAMETER USED FOR LONGITUDINAL AGE CALCULATION (NKG)

C  ZPINCL      = Z COORDINATE OF INCLINED OBSERVATION PLANE

C  ZSL(10)     = USED FOR FLUCTUATION OF STH(10))         (NKG)




C  ZZOLD       = COORDINATE OF EM PARTICLE FOR SUBTRACT. FROM NKG (EGS4)
C
C=======================================================================










# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"

















# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 1310 "corsika.F" 2

*-- Author :    The CORSIKA development group   21/04/1994
C======================================================================

# 1337 "corsika.F"
      PROGRAM AAMAIN

C-----------------------------------------------------------------------
C  MAIN PROGRAM


# 1393 "corsika.F"
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)
# 1477 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"



      COMMON /CRATMOS2/HLAY,HLAY0,THICKL,LAYNO,LAYNEW
      DOUBLE PRECISION HLAY(6),HLAY0(5,0:28),THICKL(5)
      INTEGER          LAYNO(0:41)
      LOGICAL          LAYNEW











# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"



      COMMON /CRBUFFS/ RUNH,RUNE,EVTH,EVTE,DATAB,ARRAYLONG,LH

     *                 ,WRRUNH,WRRUNE,WREVTH,WREVTE

      INTEGER          MAXBUF,MAXLEN

      PARAMETER        (MAXBUF=39*8)
# 3681 "corsika.h"
      PARAMETER        (MAXLEN=16)
# 3693 "corsika.h"
      REAL             RUNH(MAXBUF),EVTH(MAXBUF),EVTE(MAXBUF),
     *                 RUNE(MAXBUF),DATAB(MAXBUF),ARRAYLONG(MAXBUF)
      INTEGER          LH

      LOGICAL          WRRUNH,WRRUNE,WREVTH,WREVTE

      CHARACTER*4      CRUNH,CRUNE,CEVTH,CEVTE,CLONG
      EQUIVALENCE      (RUNH(1),CRUNH), (RUNE(1),CRUNE)
      EQUIVALENCE      (EVTH(1),CEVTH), (EVTE(1),CEVTE)
      EQUIVALENCE      (ARRAYLONG(1),CLONG)





      COMMON /CRCHISTA/IHYCHI,IKACHI,IMUCHI,INNCHI,INUCHI,IPICHI,INECHI
      INTEGER          IHYCHI(124),IKACHI(124),IMUCHI(124),INNCHI(124),
     *                 INUCHI(124),IPICHI(124),INECHI(124)





      COMMON /CRCONSTA/PI,PI2,OB3,TB3,ENEPER,SQRT3
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER,SQRT3












      COMMON /CRCURVE/ CHAPAR,DEP,ERR,NSTP
      DOUBLE PRECISION CHAPAR(15000),DEP(15000),ERR(15000)
      INTEGER          NSTP
















































      COMMON /CRELADPM/ELMEAN,ELMEAA,IELDPM,IELDPA
      DOUBLE PRECISION ELMEAN(40),ELMEAA(40)
      INTEGER          IELDPM(40,13),IELDPA(40,13)





      COMMON /CRELASTY/ELAST
      DOUBLE PRECISION ELAST



# 3811 "corsika.h"

# 3824 "corsika.h"










      COMMON /CRGENER/ GEN,ALEVEL
      DOUBLE PRECISION GEN,ALEVEL











# 3855 "corsika.h"










      COMMON /CRINCLINED/XPINCL,YPINCL,ZPINCL,PHINCL,THINCL
     *,TDINCL
      DOUBLE PRECISION XPINCL,YPINCL,ZPINCL,PHINCL,THINCL,TDINCL



# 3880 "corsika.h"

# 3895 "corsika.h"



      COMMON /CRIRET/  IRET1,IRET2,IRETE
      INTEGER          IRET1,IRET2
      LOGICAL          IRETE





      COMMON /CRISTA/  IFINET,IFINNU,IFINKA,IFINPI,IFINHY,IFINCM,IFINOT,
     *                 IFINRHO
      INTEGER          IFINET,IFINNU,IFINKA,IFINPI,IFINHY,IFINCM,IFINOT,
     *                 IFINRHO


























      INTEGER          LNGMAX
      PARAMETER        (LNGMAX = 15000)
      INTEGER          TYPE1
      PARAMETER        (TYPE1 = 0)
      INTEGER          TYPE2
      PARAMETER        (TYPE2 = 1)
      INTEGER          TYPE3
      PARAMETER        (TYPE3 = 2)
      INTEGER          TYPE4
      PARAMETER        (TYPE4 = 3)
      COMMON /CRLONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP



     *                ,LLONGI,FLGFIT
# 3961 "corsika.h"
      DOUBLE PRECISION ADLONG(0:LNGMAX,19),AELONG(0:LNGMAX,10),
     *                 APLONG(0:LNGMAX,10),DLONG(0:LNGMAX,19),
     *                 ELONG(0:LNGMAX,10),
     *                 HLONG(0:LNGMAX),PLONG(0:LNGMAX,10),
     *                 SDLONG(0:LNGMAX,19),SELONG(0:LNGMAX,10),
     *                 SPLONG(0:LNGMAX,10),THSTEP,THSTPI




      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT

      COMMON /CRSLANT/ RLONG,THCKRL,CTH,STHCPH,STHSPH,RLOFF
      DOUBLE PRECISION RLONG(0:LNGMAX),THCKRL(0:LNGMAX),
     *                 CTH,STHCPH,STHSPH,RLOFF













      COMMON /CRMAGNET/BX,BZ,BVAL,BNORMC,BNORM,COSB,SINB,BLIMIT
      DOUBLE PRECISION BX,BZ,BVAL,BNORMC,BNORM,COSB,SINB,BLIMIT



# 4005 "corsika.h"


















      COMMON /CRMPARTI/MPARTO
      DOUBLE PRECISION MPARTO(20,28),MPHOTO(20),MPOSIT(20),MELECT(20),
     *                 MNU(20),MMUP(20),MMUM(20),MPI0(20),MPIP(20),
     *                 MPIM(20),MK0L(20),MKPL(20),MKMI(20),MNEUTR(20),
     *                 MPROTO(20),MPROTB(20),MK0S(20),MHYP(20),
     *                 MNEUTB(20),MDEUT(20),MTRIT(20),MHELI3(20),
     *                 MALPHA(20),MCHRMM(20),MCHRMB(20),MOTHER(20),
     *                 MMUOND,MMUONE
      EQUIVALENCE (MPARTO(1, 1),MPHOTO(1)), (MPARTO(1, 2),MPOSIT(1)),
     *            (MPARTO(1, 3),MELECT(1)), (MPARTO(1, 4),MNU(1))   ,
     *            (MPARTO(1, 5),MMUP(1))  , (MPARTO(1, 6),MMUM(1))  ,
     *            (MPARTO(1, 7),MPI0(1))  , (MPARTO(1, 8),MPIP(1))  ,
     *            (MPARTO(1, 9),MPIM(1))  , (MPARTO(1,10),MK0L(1))  ,
     *            (MPARTO(1,11),MKPL(1))  , (MPARTO(1,12),MKMI(1))  ,
     *            (MPARTO(1,13),MNEUTR(1)), (MPARTO(1,14),MPROTO(1)),
     *            (MPARTO(1,15),MPROTB(1)), (MPARTO(1,16),MK0S(1))  ,
     *            (MPARTO(1,18),MHYP(1))  , (MPARTO(1,19),MDEUT(1)) ,
     *            (MPARTO(1,20),MTRIT(1)) , (MPARTO(1,21),MHELI3(1)),
     *            (MPARTO(1,22),MALPHA(1)), (MPARTO(1,23),MCHRMM(1)),
     *            (MPARTO(1,24),MCHRMB(1)), (MPARTO(1,25),MOTHER(1)),
     *            (MPARTO(1,26),MMUOND)   , (MPARTO(1,27),MNEUTB(1)),
     *            (MPARTO(1,28),MMUONE)





      COMMON /CRMULT/  EKINL,MSMM,MULTMA,MULTOT
      DOUBLE PRECISION EKINL
      INTEGER          MSMM,MULTMA(40,13),MULTOT(40,13)



# 4075 "corsika.h"

# 4091 "corsika.h"



      COMMON /CRMUMULT/CHC,OMC,PHISCT,STEPL,VSCAT,FMOLI
      DOUBLE PRECISION CHC,OMC,PHISCT,STEPL,VSCAT
      LOGICAL          FMOLI












      COMMON /CRMUPART/AATOM,AMUPAR,BCUT,CMUON,CTAU,CONSTKINE,
     *                 EBYMU,EBYTAU,EE,SE,VFRAC,VMAX,VMIN,ZATOM,
     *                 MT,FMUBRM,FMUNUC,FMUORG






      DOUBLE PRECISION AMUPAR(0:18),BCUT,CMUON(11),CTAU(11),


     *                 AATOM,CONSTKINE,EBYMU,EBYTAU,EE,SE,
     *                 VFRAC,VMAX,VMIN,ZATOM
      INTEGER          MT
      LOGICAL          FMUBRM,FMUNUC,FMUORG



# 4140 "corsika.h"

# 4153 "corsika.h"



      COMMON /CRNKGI/  SEL,SELLG,STH,ZEL,ZELLG,ZSL,DIST,
     *                 DISX,DISY,DISXY,DISYX,DLAX,DLAY,DLAXY,DLAYX,
     *                 OBSATI,RADNKG,RMOL,TLEV,TLEVCM,IALT
      DOUBLE PRECISION SEL(10),SELLG(10),STH(10),ZEL(10),ZELLG(10),
     *                 ZSL(10),DIST(10),
     *                 DISX(-10:10),DISY(-10:10),
     *                 DISXY(-10:10,2),DISYX(-10:10,2),
     *                 DLAX (-10:10,2),DLAY (-10:10,2),
     *                 DLAXY(-10:10,2),DLAYX(-10:10,2),
     *                 OBSATI(2),RADNKG,RMOL(2),TLEV(10),TLEVCM(10)
      INTEGER          IALT(2)





      COMMON /CRNKGS/  CZX,CZY,CZXY,CZYX,SAH,SL,ZNE
      DOUBLE PRECISION CZX(-10:10,2),CZY(-10:10,2),CZXY(-10:10,2),
     *                 CZYX(-10:10,2),SAH(10),SL(10),ZNE(10)












      COMMON /CRNPARTI/NPARTO,NPART2
      DOUBLE PRECISION NPARTO(20,28), NPART2(20,28),
     *                 NPHOTO(20),NPOSIT(20),NELECT(20),
     *                 NNU(20),NMUP(20),NMUM(20),NPI0(20),NPIP(20),
     *                 NPIM(20),NK0L(20),NKPL(20),NKMI(20),NNEUTR(20),
     *                 NPROTO(20),NPROTB(20),NK0S(20),NHYP(20),
     *                 NNEUTB(20),NDEUT(20),NTRIT(20),NHELI3(20),
     *                 NALPHA(20),NCHRMM(20),NCHRMB(20),NOTHER(20),
     *                 NMUOND,NMUONE
      EQUIVALENCE (NPARTO(1, 1),NPHOTO(1)), (NPARTO(1, 2),NPOSIT(1)),
     *            (NPARTO(1, 3),NELECT(1)), (NPARTO(1, 4),NNU(1))   ,
     *            (NPARTO(1, 5),NMUP(1))  , (NPARTO(1, 6),NMUM(1))  ,
     *            (NPARTO(1, 7),NPI0(1))  , (NPARTO(1, 8),NPIP(1))  ,
     *            (NPARTO(1, 9),NPIM(1))  , (NPARTO(1,10),NK0L(1))  ,
     *            (NPARTO(1,11),NKPL(1))  , (NPARTO(1,12),NKMI(1))  ,
     *            (NPARTO(1,13),NNEUTR(1)), (NPARTO(1,14),NPROTO(1)),
     *            (NPARTO(1,15),NPROTB(1)), (NPARTO(1,16),NK0S(1))  ,
     *            (NPARTO(1,18),NHYP(1))  , (NPARTO(1,19),NDEUT(1)) ,
     *            (NPARTO(1,20),NTRIT(1)) , (NPARTO(1,21),NHELI3(1)),
     *            (NPARTO(1,22),NALPHA(1)), (NPARTO(1,23),NCHRMM(1)),
     *            (NPARTO(1,24),NCHRMB(1)), (NPARTO(1,25),NOTHER(1)),
     *            (NPARTO(1,26),NMUOND)   , (NPARTO(1,27),NNEUTB(1)),
     *            (NPARTO(1,28),NMUONE)












      COMMON /CROBSPAR/OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP,
     *                 THETPR,PHIPR,

     *                 CORRXY,







     *                 NOBSLV
      DOUBLE PRECISION OBSLEV(20),THCKOB(20),XOFF(20),YOFF(20),
     *                 HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2)

     *                 ,CORRXY







      INTEGER          NOBSLV










      COMMON /CRPAM/   PAMA,SIGNUM,RESTMS,DECTIM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000),
     *                 DECTIM(200)






      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL





      DOUBLE PRECISION GAMMA,COSTHE,PHIX,PHIY,H,T,X,Y,CHI,BETA,GCM,ECM

     *                 ,WEIGHT


     *                 ,HAPP,COSTAP,COSTEA




      EQUIVALENCE      (CURPAR(1), GAMMA ), (CURPAR(2), COSTHE),
     *                 (CURPAR(3), PHIX  ), (CURPAR(4), PHIY  ),
     *                 (CURPAR(5), H     ), (CURPAR(6), T     ),
     *                 (CURPAR(7), X     ), (CURPAR(8), Y     ),
     *                 (CURPAR(9), CHI   ), (CURPAR(10),BETA  ),
     *                 (CURPAR(11),GCM   ), (CURPAR(12),ECM   )

     *                ,(CURPAR(13),WEIGHT)


     *                ,(CURPAR(14),HAPP  ), (CURPAR(15),COSTAP),
     *                 (CURPAR(16),COSTEA)















# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"










      COMMON /CRPRIMSP/PSLOPE,LLIMIT,ULIMIT,LL,UL,SLEX,ISPEC
      DOUBLE PRECISION PSLOPE,LLIMIT,ULIMIT,LL,UL,SLEX
      INTEGER          ISPEC












      COMMON /CRRANDPA/RD,FAC,U1,U2,NSEQ,ISEED,KNOR
      DOUBLE PRECISION RD(3000),FAC,U1,U2



      INTEGER          ISEED(3,10),NSEQ

      LOGICAL          KNOR



# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"



      COMMON /CRRECORD/DRECOR
      DOUBLE PRECISION DRECOR





      COMMON /CRREJECT/AVNREJ,ALTMIN,ANEXP,THICKA,THICKD,CUTLN,EONCUT,

     *                 EFRCTHN,ETHINN,ETHINNG,THINRAT,THINRATH,WEITRAT,
     *                 WEITRATH,EEFRTHN,

     *                 FNPRIM
      DOUBLE PRECISION AVNREJ(20),ALTMIN(20),ANEXP(20),THICKA(20),
     *                 THICKD(20),CUTLN,EONCUT

     *                 ,EFRCTHN,ETHINN,ETHINNG,THINRAT,THINRATH,WEITRAT,
     *                 WEITRATH,EEFRTHN

      LOGICAL          FNPRIM





      COMMON /CRRESON/ RDRES,RESRAN,IRESPAR
      DOUBLE PRECISION RDRES(2),RESRAN(0:1000000)
      INTEGER          IRESPAR













      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"



      COMMON /CRSIGM/  SIGMA,SIGANN,SIGAIR,FRACTN,FRCTNO
      DOUBLE PRECISION SIGMA,SIGANN,SIGAIR,FRACTN,FRCTNO



# 4728 "corsika.h"

# 4762 "corsika.h"



      COMMON /CRSTACKF/STACKI,



     *                 MSTACKP,MEXST,NSHIFT,NOUREC,NOURECMAX,ICOUNT,
     *                 NTO,NFROM




      INTEGER          MAXSTK
# 4796 "corsika.h"
      PARAMETER        (MAXSTK = 17*256*2)
# 4809 "corsika.h"
      DOUBLE PRECISION STACKI(MAXSTK)



      INTEGER          MSTACKP,MEXST,NSHIFT,NOUREC,NOURECMAX,ICOUNT,
     *                 NTO,NFROM









      COMMON /CRSTATI/ SABIN,SBBIN,INBIN,IPBIN,IKBIN,IHBIN
      DOUBLE PRECISION SABIN(40),SBBIN(40)
      INTEGER          INBIN(40),IPBIN(40),IKBIN(40),IHBIN(40)












      INTEGER          IEBIN, ITBIN, IDBIN
      PARAMETER        (IEBIN=40,ITBIN=30,IDBIN=20)
      COMMON /CRTABLES/G_ARRAY, E_ARRAY, M_ARRAY,
     *                 EBOFF,EBFAC,TBOFF,TBFAC,DBOFF,DBFAC
      REAL             G_ARRAY(IEBIN,ITBIN,IDBIN)
      REAL             E_ARRAY(IEBIN,ITBIN,IDBIN)
      REAL             M_ARRAY(IEBIN,ITBIN,IDBIN)
      REAL             EBOFF,EBFAC,TBOFF,TBFAC,DBOFF,DBFAC
      REAL             EBMIN,EBMAX,TBMIN,TBMAX,DBMIN,DBMAX
      PARAMETER        (EBMIN=1.E-4,EBMAX=1.E4)
      PARAMETER        (TBMIN=10.,TBMAX=1.E4)
      PARAMETER        (DBMIN=5.E3,DBMAX=5.E5)





      COMMON /CRTHNVAR/STACKINT,

     *                 EEPP,ELIM,


     *                 RMAX,RMAX2,
     *                 WMAX,WMAX0,WMAXE,WMAXE0,WMAXEM,

     *                 INT_ICOUNT,MODETHN,THINNING

     *                 ,RLIM,WLIM

      INTEGER          MAXICOUNT
      PARAMETER        (MAXICOUNT = 200000)
# 4883 "corsika.h"
      DOUBLE PRECISION STACKINT(0:16,MAXICOUNT)
# 4892 "corsika.h"
     *                 ,EEPP(MAXICOUNT),ELIM


     *                 ,RMAX,RMAX2
     *                 ,WMAX,WMAX0,WMAXE,WMAXE0,WMAXEM

      INTEGER          INT_ICOUNT,MODETHN
      LOGICAL          THINNING

      LOGICAL           RLIM,WLIM














      COMMON /CRTIMLIM/DSTLIM,TIMLIM,LTMLMPR
      DOUBLE PRECISION DSTLIM,TIMLIM
      LOGICAL          LTMLMPR



# 4935 "corsika.h"


















      COMMON /CRVERS/  VERNUM,MVDATE,VERDAT
      DOUBLE PRECISION VERNUM
      INTEGER          MVDATE
      CHARACTER*18     VERDAT












      COMMON /CRWGHTMA/MWGHMA,MWGHTOT
      INTEGER          MWGHMA(46,15),MWGHTOT(46,15)



     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 1477 "corsika.F" 2

      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

      REAL             XLEFTA,XLEFTB
# 1516 "corsika.F"
      DOUBLE PRECISION THICK
      INTEGER          LPCT0,LPCT1,NSTEP1
      SAVE
      EXTERNAL         BLOCK1,EGS4BD,HEIGH,THICK



      EXTERNAL         PARAM_INI






      DOUBLE PRECISION DL,FIXHAPP,THCKHN

      DOUBLE PRECISION THICKC,DIAG
      EXTERNAL         THICKC

      LOGICAL          FLAGC
# 1563 "corsika.F"
      INTEGER          LBIN
      EXTERNAL         LBIN
# 1576 "corsika.F"
C  VARIABLES BEING USED FOR RUNTIME
      REAL             TDIFF
      INTEGER          ILEFTA,ILEFTB
      EXTERNAL         TIMER
# 1593 "corsika.F"
c     DOUBLE PRECISION ENERGY,EN,PZ,PX,PY,HEI0
c     INTEGER          NNN,NN,N,NTYP,IRET



      DOUBLE PRECISION AUX,THCKSI
      EXTERNAL         THCKSI

      DOUBLE PRECISION RRINCL
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




c      integer*8 iptr
c      integer PRMINFO,itest




C-----------------------------------------------------------------------

# 1634 "corsika.F"
C  RESET FIRST INTERACTION DATA (TO BE SET EARLY FOR PRMINFO)
      FIRSTI = .TRUE.
      FNPRIM = .FALSE.


C  INITIALIZE WRITE HEADERS FLAGS
      WRRUNH = .FALSE.
      WRRUNE = .FALSE.
      WREVTH = .FALSE.
      WREVTE = .FALSE.


# 1670 "corsika.F"

C  INITIALIZE AND READ RUN STEERING CARDS
      CALL START

# 1684 "corsika.F"

# 1693 "corsika.F"
C  RESET COUNTER FOR WORDS WRITTEN TO FILE
      DRECOR = 0.D0

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

# 1739 "corsika.F"


C  CHECK AND SET PRIMARY PARAMETERS
      CALL INPRM






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

C  RESET ENERGY-WEIGHT MATRIX FOR ALL SHOWERS
      DO  J = 1, 46
        DO  L = 1, 15
          MWGHTOT(J,L) = 0
        ENDDO
      ENDDO


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

C  TAKE MAXIMUM LENGTH OF LONGI TABLE FOR LONGI HISTOGRAMS
        NSTEP1 = LNGMAX
        NSTEP  = LNGMAX
        LPCT0  = 0




        LPCT1  = 1




        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




          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 )

# 1845 "corsika.F"
C  TIME AT BEGINNING
      CALL TIMER( ILEFTA )




      THICK00 = THICK0

# 1908 "corsika.F"

C-----------------------------------------------------------------------
C  LOOP OVER SHOWERS



      DO  2 ISHW = 1, NSHOW


        ISHOWNO = ISHOWNO + 1
        I       = ISHW
        IF ( ISHW .LE. MAXPRT ) THEN
          FPRINT = .TRUE.
        ELSE
          FPRINT = .FALSE.
        ENDIF






        THICK0 = THICK00

C  FIRST INTERACTION DATA
        FIRSTI = .TRUE.
        FNPRIM = .FALSE.
# 1943 "corsika.F"
c        itest= 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

        IFINAM = 0
        REWIND( LSTCK2 )


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




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

C  RESET ENERGY-WEIGHT MATRIX FOR ALL SHOWERS
        DO  J = 1, 46
          DO  L = 1, 15
            MWGHMA(J,L) = 0
          ENDDO
        ENDDO


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

        DO  L = 274, 312
          EVTH(L) = 0.
        ENDDO

        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


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) ))


C  GET PRIMARY ANGLES OF INCIDENCE
# 2094 "corsika.F"
        IF ( FIXINC ) THEN
C  PRIMARY ANGLE FIXED
          THETAP = THETPR(1)
          PHIP   = PHIPR(1)
# 2157 "corsika.F"
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

          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
# 2197 "corsika.F"
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 ( THETPR(1) .GT. 0.5D0*PI  .AND.
     *          THETPR(2) .GT. 0.5D0*PI ) THEN
             CTT  = -CTT
           ENDIF

           THETAP = ACOS( CTT )


          ENDIF

          PHIP   = RD(1) * ( PHIPR(2) - PHIPR(1) ) + PHIPR(1)





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)







        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 ( .NOT. FIXINC ) WRITE(MONIOU,669) THETAP,PHIP

 669      FORMAT(' PRIMARY ANGLES ARE: THETA = ',F7.4,
     *           ' RAD,',' PHI = ',F7.4,' RAD')
        ENDIF
# 2266 "corsika.F"


C  DEFINE HEIGHT FOR START AT THICK0 (IN G/CM**2)
C  WHICH IS 112.8 KM FOR THICK0 = 0

        IF ( PRMPAR(2) .GE. 0.D0 .OR. THICK0 .GT. 0.D0 ) THEN
          PRMPAR(5) = HEIGH( THICK0 )
        ELSE
C UPWARD GOING PRIMARY WITH THICK0 NOT ALREADY DEFINED BY FIXCHI



C STARTS JUST ABOVE LOWEST OBSERVATION LEVEL
          PRMPAR(5) = OBSLEV(NOBSLV)+0.0001D0

          THICK0    = THICK( PRMPAR(5) )
        ENDIF
        IF ( LLONGI ) LPCT0 = 0
# 2292 "corsika.F"
C  COUNTER FOR PARTICLE OUTPUT
        LH = 0

C  RESET GENERATION COUNTER
        GEN = 0.D0
# 2385 "corsika.F"
        EVTH(158) = PRMPAR(5)

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
# 2416 "corsika.F"
        NSTEP1 = NSTEP + 1




C       AUTOMATIC DEFINITION OF PLANE POSITION TO BE AT FIXED DEPTH AND PERPENDICULAR TO THE SHOWER AXIS
        IF ( ABS( TDINCL ) .GT. 0D0 ) THEN
          THINCL = THETAP
          PHINCL = PHIP

C         ZPINCL IS DEFINED IN COOINC AS DISTANCE TO CORE
          IF ( FIMPCT ) THEN    !SKIMMING SHOWERS
            RRINCL = ZPINCL
            ZPINCL = HIMPCT
          ELSE




            RRINCL = SIGN( SIN( THETAP ), PRMPAR(15)) * ZPINCL
            ZPINCL = ABS( PRMPAR(15) ) * ZPINCL + OBSLEV(1)

          ENDIF

# 2449 "corsika.F"
          XPINCL = -RRINCL * COS( PHIP )
          YPINCL = -RRINCL * SIN( PHIP )
          IF ( FPRINT  .OR.  DEBUG )
     *         WRITE(MONIOU,*) 'INCLINED PLANE X,Y,Z,THETA,PHI: '
     *         ,SNGL(XPINCL), SNGL(YPINCL), SNGL(ZPINCL)
     *         ,SNGL(THINCL), SNGL(PHINCL)
        ENDIF




        IF ( THETAP .EQ. 0D0 .AND. ZPINCL .LE. OBSLEV(NOBSLV))
     &       ZPINCL = OBSLEV(NOBSLV) + 1D0 ! add a centimeter not to be exactly at the observation level (important for EM particles, otherwise some are not counted !)

C  INCLINED PLANE FOR CURREN EVENT
        EVTH(225) = XPINCL
        EVTH(226) = YPINCL
        EVTH(227) = ZPINCL
        EVTH(228) = THINCL
        EVTH(229) = PHINCL

        IF ( LLONGI ) THEN

C         PLANE COORDINATES IN SAME FRAME THAN PARTICLES ((0,0) AT CORE)
          AUX  = XPINCL*STHCPH + YPINCL*STHSPH - ZPINCL*CTH + RLOFF






          EVTH(230) = THCKSI( AUX )
        ELSE
          EVTH(230) = -1D0
        ENDIF

# 2496 "corsika.F"
        IF ( FPRINT  .OR.  DEBUG )
     * WRITE(MONIOU,*)'DEPTH OF INCLINE PLANE (G/CM^2) ',SNGL(EVTH(230))

        
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



            ENDDO
          ENDDO
          DO  K = 1, 19
            DO  J = 0, NSTEP1
              DLONG(J,K) = 0.D0
            ENDDO
          ENDDO
        ENDIF
# 2564 "corsika.F"
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 1
          ENDIF
        ENDIF

C  SET WEIGHT
        WEIGHT = 1.D0
# 2595 "corsika.F"
C  SET PRIMARY TO CURRENT PARTICLE
        DO  J = 0, 8
          CURPAR(J) = PRMPAR(J)
        ENDDO
# 2607 "corsika.F"








C  CALCULATE FIRST INTERACTION POINT IF HADRONIC
        H = HEIGH( THICK0 )
        CALL BOX2
# 2627 "corsika.F"
        IF ( FIX1I ) THEN

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 ( 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

              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

            FIXHAPP = OBSLEV(1) + DIAG * PRMPAR(15)
            DL = (HAPP - FIXHAPP) / PRMPAR(15)

          ENDIF

          CALL NRANGC( DL )
# 2672 "corsika.F"
          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

        ELSEIF ( FIMPCT ) THEN
          H = MAX( H, HLAY(1) + 100.D0 )
          H = MIN( H, HLAY(6) - 1.D0 )


        ELSE
C  FIRST INTERACTION IS NOT FIXED
C  CHI IS GIVEN BY BOX2

          THICKH = THICK0
          THCKHN = THICKC( CHI )



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

        THICK1 = THICK( H )
        IF ( CURPAR(0) .GT. 3.D0  .OR.  .NOT. FEGS ) THEN
          CHISUM = CHISUM + THICK1
          CHISM2 = CHISM2 + THICK1**2
        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


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

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 ( ISPEC.NE.0  .AND.  (FPRINT .OR. DEBUG) ) THEN

            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
# 2886 "corsika.F"

        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
# 2904 "corsika.F"
        EVTH( 5) = THICK0
        EVTH( 7) = HEIGHP




        PTOT0    = SQRT( (E00-PAMA(NINT( CURPAR(0) )))
     *                  *(E00+PAMA(NINT( CURPAR(0) ))) )


        PTOT0N   = PTOT0 / INUCL
# 2923 "corsika.F"
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 )
# 2937 "corsika.F"
        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

        EVTH( 8) = PTOT0 * ST * COS( EVTH(12) )
        EVTH( 9) = PTOT0 * ST * SIN( EVTH(12) )


C  WRITE ENERGY AND ANGLES OF PRIMARY TO DBASE FILE FOR THE FIRST SHOWER
        IF ( FDBASE  .AND.  ISHW .EQ. 1 ) THEN

          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




 670      FORMAT(1P,'#thinnlev_em#',E14.7,'#maxweight_had#',E14.7,/,
     $         '#maxweight_em#',E14.7,'#rad_max#',E14.7)


          WRITE(MDBASE,668) E00, THETA*180.D0/PI, EVTH(12)*180.D0/PI




 668      FORMAT(1P,'#energy_prim#',E14.7,'#theta_prim#',E14.7,
     *           '#phi_prim#',E14.7)

          CLOSE(UNIT=MDBASE)
        ENDIF





        IF ( DEBUG  .OR.  FPRINT ) THEN
          WRITE(MONIOU,*)
          IF ( TMARGIN ) THEN



          ELSE
            WRITE(MONIOU,*) 'TRACKING STARTS AT FIRST INTERACTION'
          ENDIF
        ENDIF

        IF ( PRMPAR(0) .GT. 3.D0 ) THEN
CTP X AND Y COORDINATES ARE NOT UPDATED WITH HEIGHT OF FIRST INTERACTION SO BETTER NOT TO PRINT IT
          WRITE(MONIOU,102) CURPAR(5),(CURPAR(J),J = 0,5)
 102  FORMAT(' PRIMARY PARAMETERS AT FIRST INTERACTION POINT AT HEIGHT',
     *               1P,E16.8,' CM',/,
     *               16X,1P,9E11.3)
          IF ( DEBUG ) THEN




          ENDIF
        ELSE
          IF ( FPRINT  .OR.  DEBUG ) WRITE(MONIOU,132)
 132      FORMAT(/,' PRIMARY PARTICLE IS ELECTROMAGNETIC')
        ENDIF


# 3021 "corsika.F"
C  WRITE EVENT HEADER INTO BUFFER

C  FOR EM PARTICLES EVTH IS WRITTEN TO BUFFER IN EGS (IF ACTIVE)
        IF ( PRMPAR(0) .GT. 3.D0  .OR.  .NOT. FEGS ) THEN




C  NEGATIVE FIRST INTERACTIN HEIGHT, IF TRACKING STARTS AT ATMOS. MARGIN
          IF ( TMARGIN ) EVTH(7) = -EVTH(7)















# 3064 "corsika.F"
C  WREVTH SIGNALS THAT EVTH HAS BEEN WRITTEN OUT
          WREVTH = .TRUE.

          CALL TOBUF( EVTH,0 )
# 3078 "corsika.F"
        ENDIF














C  PRINT HEADER FOR HIGH ENERGY PARTICLES
        IF ( FPRINT  .OR.  DEBUG ) WRITE(MONIOU,103)

 103    FORMAT(/,'                    TYPE       GAMMA    COSTHETA ',
     *     '     PHIX      PHIY      HEIGHT      TIME       X-CM  ',
     *     '     Y-CM       GEN/CHI    WEIGHT   ALEVEL  E ON STACK',/)





        NOPART = 0




# 3176 "corsika.F"
        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
# 3194 "corsika.F"
            FNPRIM = .FALSE.

          ELSE
C  MUONS/TAU LEPTONS
            FNPRIM = .TRUE.
            H      = PRMPAR(5)
            IF ( TMARGIN ) BNORMC = BNORM*1.D-3
          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)

          PRMPAR(14) = CURPAR(14)
          PRMPAR(16) = CURPAR(16)

          FIRSTI = .FALSE.
          GOTO 4

        ELSEIF ( ( CURPAR(0) .GE.  75.D0  .AND.  CURPAR(0) .LT. 116.D0 )
     *      .OR. ( CURPAR(0) .GT. 174.D0  .AND.  CURPAR(0) .LT. 200.D0 )





     *                                                        ) 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 1
        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 )

C  TRACK THE PARTICLE WHEN ENTERING THE ATMOSPHERE
          FLAGC  = .FALSE.
          IPAS   = 0
# 3265 "corsika.F"
          CALL UPDATC( IPAS,FLAGC )

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
# 3292 "corsika.F"
C  JUMP INTO NORMAL PARTICLE TREATMENT FOR HADRONS
            GOTO 6
          ENDIF

# 3649 "corsika.F"
          IF ( DEBUG ) WRITE(MDEBUG,*)
     *       'AAMAIN: PRIMARY REACHED LOWEST OBSERVATION LEVEL'
          GOTO 4
        ENDIF


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
# 3673 "corsika.F"
C  ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT


              LHEIGH = LBIN( X,Y,HAPP,1 )






              IF     ( ITYPE .EQ. 2                      ) THEN

                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
# 3735 "corsika.F"
              ENDIF
            ENDIF
# 3757 "corsika.F"
            GOTO 4
          ENDIF
C  SPECIAL TREATMENT FOR GAMMAS







          ITYPE = 1
          CHI   = 0.D0
          GOTO 5

        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


  6     CONTINUE

        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

        MULTMA(MEN,MMU) = MULTMA(MEN,MMU) + NINT( WEIGHT )
        MULTOT(MEN,MMU) = MULTOT(MEN,MMU) + NINT( WEIGHT )




        IF ( DEBUG ) WRITE(MDEBUG,*) 'AAMAIN: EKINL,MSMM=',
     *                                  SNGL(EKINL),MSMM
cdh
c        if(.not.firsti)DEBUG=.false. !switch off debug after first interact
cdh

        IF ( IRET1 .EQ. 0 ) THEN

          IF ( DEBUG ) WRITE(MDEBUG,666) (CURPAR(II),II=0,9),WEIGHT
 666      FORMAT(' AAMAIN: CURPAR=',1P,11E11.3)




          GOTO 7
        ENDIF

C  GET NEXT PARTICLE FROM STACK, IF IRET=1 ALL PARTICLES ARE DONE
  4     CONTINUE

c        if(itest.ne.1)itest= PRMINFO(iptr)
# 3847 "corsika.F"
        IRET1 = 0
        CALL FSTACK

        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.



          ENDIF
        ENDIF


C  STACK IS EMPTY, IF IRET1 IS 1
        IF ( IRET1 .EQ. 0 ) GOTO 7

# 3921 "corsika.F"

C-----------------------------------------------------------------------
C  FINISH SHOWER AND PRINT INFORMATION
        CALL OUTEND

# 3945 "corsika.F"

*       IF ( DEBUG ) WRITE(MDEBUG,442) NPARTO
*442    FORMAT(' AAMAIN: NPARTO=',/,(' ',10F10.0))

        IF ( FPRINT  .OR.  DEBUG ) THEN
# 3963 "corsika.F"
          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.6,/)
          WRITE(MONIOU,555) (THCKOB(K),K=IFI,IOBSLV)
 555      FORMAT( ' HEIGHT IN G/CM**2    ',1P, 5E13.6,/)

          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)



          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)

          WRITE(MONIOU,776) 'CHRM. MESONS ',(NCHRMM(K),K=IFI,IOBSLV)
          WRITE(MONIOU,776) 'CHRM. BARYONS',(NCHRMB(K),K=IFI,IOBSLV)

          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 ( 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)



            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)

            WRITE(MONIOU,776) 'CHRM. MESONS ',(NCHRMM(K),K=6,IOBSLV)
            WRITE(MONIOU,776) 'CHRM. BARYONS',(NCHRMB(K),K=6,IOBSLV)

            WRITE(MONIOU,776) 'OTHER PARTIC.',(NOTHER(K),K=6,IOBSLV)
            WRITE(MONIOU,*)
          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



        IOBSLV  = NOBSLV

        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

# 4130 "corsika.F"
         IF ( FPRINT  .OR.  DEBUG ) WRITE(MONIOU,110)
     *                  IFINNU,IFINPI,IFINET,IFINKA,IFINHY,IFINRHO,

     *                  IFINCM,

     *                  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,/,

     *  ' NO OF CHRM.PART.PRODUCED IN FIRST HADR. INTERACTION =',I10,/,

     *  ' 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,/)










C  PRINT OUT NKG RESULT FOR ONE SHOWER IF SELECTED
        IF ( FNKG ) CALL AVAGE

        IF ( LLONGI ) THEN
C  TREAT LONGITUDINAL DISTRIBUTIONS



          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)





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




            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
# 4249 "corsika.F"
C  PARTICLE DISTRIBUTION
            WRITE(MONIOU,910) THSTEP,
     *      'GAMMAS','POSITRONS','ELECTRONS','MU+','MU-','HADRONS',
     *      'CHARGED','NUCLEI','CHERENKOV',

     *      ( 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-),/,





     *        '  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',

     *      ( 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-),/,





     *        '  DEPTH',9(A12,1X),/,(F7.1,1P,9E13.5,0P) )

C  ENERGY DEPOSIT
# 4318 "corsika.F"
            WRITE(MONIOU,909) THSTEP,
     *       ' GAMMA      ','EM IONIZ','EM CUT','MU IONIZ','MU CUT',
     *       'HADR IONIZ','HADR CUT','NEUTRINO ','    SUM',

     *       ( 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)
# 4355 "corsika.F"
 9091       FORMAT(F8.1,1X,1P,3E14.7,5E12.5,E13.6)


            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
# 4436 "corsika.F"
            WRITE(MLONGOUT,211) NSTEP1,THSTEP,ISHOWNO,
     *      'GAMMAS','POSITRONS','ELECTRONS','MU+','MU-','HADRONS',



     *      'CHARGED','NUCLEI','CHERENKOV'


 211        FORMAT(' LONGITUDINAL DISTRIBUTION IN ',I5,
     *             ' SLANT    STEPS OF ',F5.0,' G/CM**2 FOR SHOWER ',
     *             I7,/,' DEPTH  ',9(A11,1X) )
# 4455 "corsika.F"
C
            DO  J = 1, NSTEP1



              WRITE(MLONGOUT,212) J*THSTEP,(PLONG(J,K),K=1,9)


 212          FORMAT(' ',F7.1,1P,9(E12.5),0P)
# 4472 "corsika.F"
            ENDDO
            WRITE(MLONGOUT,213) NSTEP1,THSTEP,ISHOWNO,
     *             'GAMMA ','EM IONIZ','EM CUT','MU IONIZ','MU CUT',
     *             'HADR IONIZ','HADR CUT','NEUTRINO ','  SUM  '

 213        FORMAT(' LONGITUDINAL ENERGY DEPOSIT IN ',I5,
     *             ' SLANT    STEPS OF ',F5.0,' G/CM**2 FOR SHOWER ',
     *             I7,/,' DEPTH    ',3A11,6A12)
# 4488 "corsika.F"
C
C  CHECK LAST LONGITUDINAL DEPOSIT BIN TO CONTAIN NON-NEGATIVE CONTENT
            DLONG(NSTEP1,2) = MAX( 0.D0, DLONG(NSTEP1,2) )
            DLONG(NSTEP1,3) = MAX( 0.D0, DLONG(NSTEP1,3) )
            DLONG(NSTEP1,4) = MAX( 0.D0, DLONG(NSTEP1,4) )
            DLONG(NSTEP1,9) = MAX( 0.D0, DLONG(NSTEP1,9) )
            DO  J = 1, NSTEP1
              DEPSTEP = DBLE(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)

 214          FORMAT(' ',F7.1,1P,9(E12.5),0P)
# 4511 "corsika.F"
            ENDDO

          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



            ARRAYLONG(7)  = THICK( ABS( DBLE(EVTH(7)) ) )
     *                                           !THICKNS FIRST INTERACT

            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




              NSTP = NSTEP + 1 - LPCT1

              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




              NSTP = NSTEP + 1 - LPCT1

              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
# 4711 "corsika.F"
            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




        ENDIF





        EVTE(2) = REAL( ISHOWNO )






C  WRITE SHOWER END TO OUTPUT BUFFER
# 4749 "corsika.F"
C  WREVTE SIGNALS THAT EVTE HAS BEEN WRITTEN
        WREVTE = .TRUE.




        CALL TOBUF( EVTE,0 )
# 4783 "corsika.F"

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)





        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

# 4818 "corsika.F"

# 4834 "corsika.F"

  2   CONTINUE

C  END OF SHOWER LOOP


C-----------------------------------------------------------------------




      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




      RUNE(3) = REAL( ISHW )
cdh   TDIFF = ILEFTB - ILEFTA

C  WRITE RUN END TO OUTPUT BUFFER AND FINISH OUTPUT

C  WRRUNE SIGNALS THAT RUNE HAS BEEEN WRITTEN.
      WRRUNE = .TRUE.
# 4879 "corsika.F"
      CALL TOBUF( RUNE,1 )







# 4907 "corsika.F"
C  TIME SINCE BEGINNING NO VALID INFORMATION
      CALL TIMER( ILEFTB )
      TDIFF  = ILEFTB - ILEFTA






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,DRECOR,DRECOR/ISHW,
     *                   CHISUM,CHISM2
 201  FORMAT(/,/,1X,10('='),' RUN SUMMARY ',56('='),/,/,
     *  ' NUMBER OF GENERATED EVENTS = ',I10,/,
     *  ' TOTAL TIME USED            = ',F20.0,'   SEC',/,
     *  ' TIME PER EVENT             = ',F22.2,' SEC',/,
     *  ' TOTAL SPACE ON MPATAP USED = ',F20.0,' WORDS',/,
     *  ' SPACE PER EVENT ON MPATAP  = ',F20.0,' WORDS',/,
     *  ' AVERAGE HEIGHT OF 1ST INT. = ',F10.3,' +-',F10.3,' G/CM**2',/)

C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      IF ( ISHW .GT. 1 ) THEN
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')


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')


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)

C  END OF PRINTING OF AVERAGES ONLY IF MORE THAN 1 SHOWER IS SIMULATED
cdh   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
# 5032 "corsika.F"
        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),/)

      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)



      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)

      WRITE(MONIOU,778)'CHRM.MESONS ',(MCHRMM(K),MCRMM2(K),K=IFI,IOBSLV)
      WRITE(MONIOU,778)'CHRM.BARYONS',(MCHRMB(K),MCRMB2(K),K=IFI,IOBSLV)

      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 ( 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)



        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)

        WRITE(MONIOU,778)'CHRM.MESONS ',(MCHRMM(K),MCRMM2(K),K=4,IOBSLV)
        WRITE(MONIOU,778)'CHRM.BARYONS',(MCHRMB(K),MCRMB2(K),K=4,IOBSLV)

        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)



        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)

        WRITE(MONIOU,778)'CHRM.MESONS ',(MCHRMM(K),MCRMM2(K),K=7,IOBSLV)
        WRITE(MONIOU,778)'CHRM.BARYONS',(MCHRMB(K),MCRMB2(K),K=7,IOBSLV)

        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)



        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)

        WRITE(MONIOU,778)'CHRM.MESONS ',(MCHRMM(K),MCRMM2(K),K=7,IOBSLV)
        WRITE(MONIOU,778)'CHRM.BARYONS',(MCHRMB(K),MCRMB2(K),K=9,IOBSLV)

        WRITE(MONIOU,778)'OTHER PART. ',(MOTHER(K),MOTH2 (K),K=9,IOBSLV)
              WRITE(MONIOU,*)
            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





              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



              ENDDO
            ENDDO
          ENDIF

C  PRINT AVERAGE LONGITUDINAL PARTICLE DISTRIBUTIONS
C  DO PRINTING OF AVERAGES ONLY IF MORE THAN 1 SHOWER IS SIMULATED
          WRITE(MONIOU,911) THSTEP,
     *      'GAMMAS ','POSITRONS','ELECTRONS','MU+  ','MU-  ',

     *      (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 ))
# 5276 "corsika.F"
          WRITE(MONIOU,912) THSTEP,
     *      'HADRONS','CHARGED','NUCLEI','CHERENKOV',

     *      (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))
# 5294 "corsika.F"
C  PRINT AVERAGE LONGITUDINAL ENERGY DISTRIBUTIONS
          WRITE(MONIOU,915) THSTEP,
     *      'GAMMAS ','POSITRONS','ELECTRONS','MU+  ','MU-  ',

     *      (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))
# 5329 "corsika.F"
          WRITE(MONIOU,916) THSTEP,
     *      'HADRONS','CHARGED','NUCLEI','ENERGYSUM',

     *      (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))
# 5345 "corsika.F"
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',

     *      ( 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 ))
# 5375 "corsika.F"
          WRITE(MONIOU,9131) (2*NSTEP1-1)*.5*THSTEP,
     *       (ADLONG(NSTEP1,K),SDLONG(NSTEP1,K),K=1,5)

 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 )





          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',

     *      (0.5*(THCKRL(J-1)+THCKRL(J)),(ADLONG(J,K),SDLONG(J,K),



     *                                     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',

     *      ( 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))
# 5418 "corsika.F"
          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)',

     *      (0.5*(THCKRL(J-1)+THCKRL(J)),(ADLONG(J,K),SDLONG(J,K),



     *                                      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




              NSTP = NSTEP + 1 - LPCT0

              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




              NSTP = NSTEP + 1 - LPCT0

              WRITE(MONIOU,8229) 'AVERAGE MUONS AND CHARGED HADRONS'
            ENDIF

C  OMIT LAST (INCOMPLETE) BIN FOR FIT OF SLANT LONGI DISTRIBUTION
            NSTP = NSTP - 1

            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
# 5517 "corsika.F"
            ELSE
              WRITE(MONIOU,*) 'NO LONGI. FIT POSSIBLE, ',
     *                      ' NSTP = ',NSTP,'  TOO SMALL.'
            ENDIF
          ENDIF
        ENDIF

C  END OF PRINTING OF AVERAGES ONLY IF MORE THAN 1 SHOWER IS SIMULATED
      ENDIF
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

# 5547 "corsika.F"

C  CONTROL PRINT OUTPUT OF CONSTANTS
      IF ( DEBUG ) THEN
        CALL STAEND
        WRITE(MDEBUG,*) 'AAMAIN: STAEND CALLED'
      ENDIF

C  CLOSE ALL OPEN UNITS
# 5566 "corsika.F"
      CLOSE( MEXST )



      call cloda ()
# 5580 "corsika.F"
      IF ( FPAROUT ) CALL fclosempatap()



      IF ( FTABOUT ) CLOSE( MTABOUT )
      IF ( FLONGOUT  .AND.  LLONGI ) CLOSE( MLONGOUT )








      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







      STOP 1

      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



# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"











      COMMON /CRCONSTA/PI,PI2,OB3,TB3,ENEPER,SQRT3
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER,SQRT3












































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 5653 "corsika.F" 2

      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



# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"











      COMMON /CRCONSTA/PI,PI2,OB3,TB3,ENEPER,SQRT3
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER,SQRT3












































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 5709 "corsika.F" 2

      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



# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"











      COMMON /CRCONSTA/PI,PI2,OB3,TB3,ENEPER,SQRT3
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER,SQRT3












































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 5769 "corsika.F" 2

      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



# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"











      COMMON /CRCONSTA/PI,PI2,OB3,TB3,ENEPER,SQRT3
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER,SQRT3












































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 5825 "corsika.F" 2

      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



# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"











      COMMON /CRCONSTA/PI,PI2,OB3,TB3,ENEPER,SQRT3
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER,SQRT3












































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 5895 "corsika.F" 2

      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


# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 5958 "corsika.F" 2

      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


# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 6066 "corsika.F" 2

      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

# 6248 "corsika.F"

*-- 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
# 6289 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"



      COMMON /CRAIR/   COMPOS,PROBTA,AVERAW,AVOGDR
      DOUBLE PRECISION COMPOS(3),PROBTA(3),AVERAW,AVOGDR





      COMMON /CRATMOS/ AATM,AATM0,BATM,BATM0,CATM,CATM0,DATM,MODATM
     *                ,MATMFI,LATMNEW
      DOUBLE PRECISION AATM(5),AATM0(5,0:42),BATM(5),BATM0(5,0:42),
     *                 CATM(5),CATM0(5,0:42),DATM(5)
      INTEGER          MODATM,MATMFI
      LOGICAL          LATMNEW





      COMMON /CRATMOS2/HLAY,HLAY0,THICKL,LAYNO,LAYNEW
      DOUBLE PRECISION HLAY(6),HLAY0(5,0:28),THICKL(5)
      INTEGER          LAYNO(0:41)
      LOGICAL          LAYNEW











# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"



      COMMON /CRBUFFS/ RUNH,RUNE,EVTH,EVTE,DATAB,ARRAYLONG,LH

     *                 ,WRRUNH,WRRUNE,WREVTH,WREVTE

      INTEGER          MAXBUF,MAXLEN

      PARAMETER        (MAXBUF=39*8)
# 3681 "corsika.h"
      PARAMETER        (MAXLEN=16)
# 3693 "corsika.h"
      REAL             RUNH(MAXBUF),EVTH(MAXBUF),EVTE(MAXBUF),
     *                 RUNE(MAXBUF),DATAB(MAXBUF),ARRAYLONG(MAXBUF)
      INTEGER          LH

      LOGICAL          WRRUNH,WRRUNE,WREVTH,WREVTE

      CHARACTER*4      CRUNH,CRUNE,CEVTH,CEVTE,CLONG
      EQUIVALENCE      (RUNH(1),CRUNH), (RUNE(1),CRUNE)
      EQUIVALENCE      (EVTH(1),CEVTH), (EVTE(1),CEVTE)
      EQUIVALENCE      (ARRAYLONG(1),CLONG)













      COMMON /CRCONSTA/PI,PI2,OB3,TB3,ENEPER,SQRT3
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER,SQRT3









































      COMMON /CREDECAY/CETA
      DOUBLE PRECISION CETA(5)

































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"



      COMMON /CRGNUPR/ SE14,SE16,SE40
      DOUBLE PRECISION SE14(3,14),SE16(3,16),SE40(3,40)











# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"



      COMMON /CRKAONS/ CKA
      DOUBLE PRECISION CKA(80)

















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"


















      COMMON /CRMUPART/AATOM,AMUPAR,BCUT,CMUON,CTAU,CONSTKINE,
     *                 EBYMU,EBYTAU,EE,SE,VFRAC,VMAX,VMIN,ZATOM,
     *                 MT,FMUBRM,FMUNUC,FMUORG






      DOUBLE PRECISION AMUPAR(0:18),BCUT,CMUON(11),CTAU(11),


     *                 AATOM,CONSTKINE,EBYMU,EBYTAU,EE,SE,
     *                 VFRAC,VMAX,VMIN,ZATOM
      INTEGER          MT
      LOGICAL          FMUBRM,FMUNUC,FMUORG



# 4140 "corsika.h"

# 4153 "corsika.h"



      COMMON /CRNKGI/  SEL,SELLG,STH,ZEL,ZELLG,ZSL,DIST,
     *                 DISX,DISY,DISXY,DISYX,DLAX,DLAY,DLAXY,DLAYX,
     *                 OBSATI,RADNKG,RMOL,TLEV,TLEVCM,IALT
      DOUBLE PRECISION SEL(10),SELLG(10),STH(10),ZEL(10),ZELLG(10),
     *                 ZSL(10),DIST(10),
     *                 DISX(-10:10),DISY(-10:10),
     *                 DISXY(-10:10,2),DISYX(-10:10,2),
     *                 DLAX (-10:10,2),DLAY (-10:10,2),
     *                 DLAXY(-10:10,2),DLAYX(-10:10,2),
     *                 OBSATI(2),RADNKG,RMOL(2),TLEV(10),TLEVCM(10)
      INTEGER          IALT(2)


















# 4212 "corsika.h"








# 4248 "corsika.h"








      COMMON /CRPAM/   PAMA,SIGNUM,RESTMS,DECTIM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000),
     *                 DECTIM(200)






      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL





      DOUBLE PRECISION GAMMA,COSTHE,PHIX,PHIY,H,T,X,Y,CHI,BETA,GCM,ECM

     *                 ,WEIGHT


     *                 ,HAPP,COSTAP,COSTEA




      EQUIVALENCE      (CURPAR(1), GAMMA ), (CURPAR(2), COSTHE),
     *                 (CURPAR(3), PHIX  ), (CURPAR(4), PHIY  ),
     *                 (CURPAR(5), H     ), (CURPAR(6), T     ),
     *                 (CURPAR(7), X     ), (CURPAR(8), Y     ),
     *                 (CURPAR(9), CHI   ), (CURPAR(10),BETA  ),
     *                 (CURPAR(11),GCM   ), (CURPAR(12),ECM   )

     *                ,(CURPAR(13),WEIGHT)


     *                ,(CURPAR(14),HAPP  ), (CURPAR(15),COSTAP),
     *                 (CURPAR(16),COSTEA)















# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"











      COMMON /CRREST/  CONTNE,TAR,LIT
      DOUBLE PRECISION CONTNE(3),TAR
      INTEGER          LIT





      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"



      COMMON /CRSTACKF/STACKI,



     *                 MSTACKP,MEXST,NSHIFT,NOUREC,NOURECMAX,ICOUNT,
     *                 NTO,NFROM




      INTEGER          MAXSTK
# 4796 "corsika.h"
      PARAMETER        (MAXSTK = 17*256*2)
# 4809 "corsika.h"
      DOUBLE PRECISION STACKI(MAXSTK)



      INTEGER          MSTACKP,MEXST,NSHIFT,NOUREC,NOURECMAX,ICOUNT,
     *                 NTO,NFROM

















      COMMON /CRSTRBAR/CSTRBA
      DOUBLE PRECISION CSTRBA(11)



# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"


















      COMMON /CRVERS/  VERNUM,MVDATE,VERDAT
      DOUBLE PRECISION VERNUM
      INTEGER          MVDATE
      CHARACTER*18     VERDAT

















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 6289 "corsika.F" 2

      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 ((AATM0(I,J),I=1,5),J=30,41)
     */  -91.6956D0,   7.01491D0, 0.505452D0,-1.81302D-03, 2.07722D-03,!Jan
     *   -72.1988D0,  22.7002D0 , 0.430171D0,-1.2030D-03 , 2.07722D-03,!Feb
     *   -63.7290D0,  -1.02799D0, 0.324414D0,-4.90772D-04, 2.07722D-03,!Mar
     *   -69.7259D0,  -2.79781D0, 0.262692D0,-8.41695D-05, 2.07722D-03,!Apr
     *   -78.5551D0,  -5.33239D0, 0.312889D0,-9.20472D-05, 1.52236D-03,!May
     *   -92.6125D0,  -8.56450D0, 0.363986D0, 1.65164D-05, 2.07722D-03,!Jun
     *   -89.9639D0, -13.9697D0,  0.441631D0,-1.46525D-05, 2.07722D-03,!Jul
     *   -90.4253D0, -18.7154D0,  0.513930D0,-2.15650D-04, 1.52236D-03,!Aug
     *   -91.6860D0, -23.3519D0,  0.891302D0,-7.65666D-04, 2.07722D-03,!Sep
     *   451.616D0 , -85.5456D0,  2.06082D0 ,-1.07600D-03, 2.07722D-03,!Oct
     *  -152.853D0 ,   4.22741D0, 1.38352D0 ,-1.15014D-03, 2.07722D-03,!Nov
     *  -100.386D0 ,   5.43849D0, 0.399465D0,-1.75472D-03, 2.07722D-03/!Dec
C
      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 ((BATM0(I,J),I=1,5),J=30,41)
     */  1125.71D0,    1149.81D0,    1032.68D0,    490.789D0,  1.D0,   !Jan
     *   1108.19D0,    1159.77D0,    1079.25D0,    523.956D0,  1.D0,   !Feb
     *   1102.66D0,    1093.56D0,    1198.93D0,    589.827D0,  1.D0,   !Mar
     *   1111.70D0,    1128.64D0,    1413.98D0,    587.688D0,  1.D0,   !Apr
     *   1118.46D0,    1169.09D0,    1577.71D0,    452.177D0,  1.D0,   !May
     *   1129.88D0,    1191.98D0,    1619.82D0,    411.586D0,  1.D0,   !Jun
     *   1125.73D0,    1180.47D0,    1581.43D0,    373.796D0,  1.D0,   !Jul
     *   1125.01D0,    1175.60D0,    1518.03D0,    299.006D0,  1.D0,   !Aug
     *   1125.53D0,    1169.77D0,    1431.26D0,    247.030D0,  1.D0,   !Sep
     *    849.239D0,   1113.16D0,    1322.28D0,    372.242D0,  1.D0,   !Oct
     *   1174.09D0,    1272.49D0,    975.906D0,    481.615D0,  1.D0,   !Nov
     *   1128.71D0,    1198.10D0,    858.522D0,    480.142D0,  1.D0 /  !Dec
C
      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 ((CATM0(I,J),I=1,5),J=30,41)
     * / 821621.D0,  635444.D0,  682968.D0,  807327.D0,  54303203.D02,!Jan
     *   786271.D0,  599986.D0,  667432.D0,  780919.D0,  54303203.D02,!Feb
     *   764831.D0,  660389.D0,  636118.D0,  734909.D0,  54303203.D02,!Mar
     *   766099.D0,  641716.D0,  588082.D0,  693300.D0,  54303203.D02,!Apr
     *   776648.D0,  626683.D0,  553087.D0,  696835.D0,  74095699.D02,!May
     *   791177.D0,  618840.D0,  535235.D0,  692253.D0,  54303203.D02,!Jun
     *   784553.D0,  628042.D0,  531652.D0,  703417.D0,  54303203.D02,!Jul
     *   781628.D0,  633793.D0,  533269.D0,  737794.D0,  74095699.D02,!Aug
     *   786017.D0,  645241.D0,  545022.D0,  805419.D0,  54303203.D02,!Sep
     *   225286.D0,  789340.D0,  566132.D0,  796434.D0,  54303203.D02,!Oct
     *   891602.D0,  582119.D0,  643130.D0,  783786.D0,  54303203.D02,!Nov
     *   829352.D0,  612649.D0,  706104.D0,  806875.D0,  54303203.D02/!Dec
C
      DATA (LAYNO(J), J=0,41)
     * / 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, 17, 18, 19, 20, 21, 22, 23,
     *  24, 25, 26, 27, 28 /
      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
      DATA ((HLAY0(I,J),I=1,5),J=17,28)
     * / -5779.5D2,  7.8D05,  16.4D05,   40.4D05,   100.D05,           !Jan
     *   -5779.5D2,  8.0D05,  10.6D05,   40.4D05,   100.D05,           !Feb
     *   -5779.5D2,  6.7D05,  22.4D05,   40.4D05,   100.D05,           !Mar
     *   -5779.5D2,  7.6D05,  22.0D05,   40.4D05,   100.D05,           !Apr
     *   -5779.5D2,  8.4D05,  20.0D05,   39.7D05,   100.D05,           !May
     *   -5779.5D2,  8.5D05,  17.9D05,   38.4D05,   100.D05,           !Jun
     *   -5779.5D2,  8.5D05,  15.9D05,   37.5D05,   100.D05,           !Jul
     *   -5779.5D2,  8.5D05,  14.4D05,   37.5D05,   100.D05,           !Aug
     *   -5779.5D2,  8.5D05,  13.0D05,   36.2D05,   100.D05,           !Sep
     *   -5779.5D2,  3.1D05,  10.1D05,   31.5D05,   100.D05,           !Oct
     *   -5779.5D2,  8.5D05,  22.4D05,   32.4D05,   100.D05,           !Nov
     *   -5779.5D2,  8.5D05,  22.0D05,   40.4D05,   100.D05  /         !Dec




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 /, MATMFI / 19 /, MDBASE / 45 /,
     *     MTABOUT / 46 /,MLONGOUT / 48 /







c#if __ANAHIST__ || __AUGERHIST__
c     *    ,LUNHST / 53 /
c#endif
     *    ,LSTCK / 23 /

     *    ,LSTCK2 / 24 /
# 6575 "corsika.F"
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 / 7.7500 /
      DATA MVDATE / 20230414 /
C                   -YYYYMMDD-
      DATA VERDAT / 'APRIL     14, 2023' /
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
# 6737 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"



      COMMON /CRAIR/   COMPOS,PROBTA,AVERAW,AVOGDR
      DOUBLE PRECISION COMPOS(3),PROBTA(3),AVERAW,AVOGDR



# 3580 "corsika.h"



      COMMON /CRATMOS2/HLAY,HLAY0,THICKL,LAYNO,LAYNEW
      DOUBLE PRECISION HLAY(6),HLAY0(5,0:28),THICKL(5)
      INTEGER          LAYNO(0:41)
      LOGICAL          LAYNEW











# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"



      COMMON /CRCHISTA/IHYCHI,IKACHI,IMUCHI,INNCHI,INUCHI,IPICHI,INECHI
      INTEGER          IHYCHI(124),IKACHI(124),IMUCHI(124),INNCHI(124),
     *                 INUCHI(124),IPICHI(124),INECHI(124)





      COMMON /CRCONSTA/PI,PI2,OB3,TB3,ENEPER,SQRT3
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER,SQRT3












































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"



      COMMON /CRKAONS/ CKA
      DOUBLE PRECISION CKA(80)

















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"


















      COMMON /CRMUPART/AATOM,AMUPAR,BCUT,CMUON,CTAU,CONSTKINE,
     *                 EBYMU,EBYTAU,EE,SE,VFRAC,VMAX,VMIN,ZATOM,
     *                 MT,FMUBRM,FMUNUC,FMUORG






      DOUBLE PRECISION AMUPAR(0:18),BCUT,CMUON(11),CTAU(11),


     *                 AATOM,CONSTKINE,EBYMU,EBYTAU,EE,SE,
     *                 VFRAC,VMAX,VMIN,ZATOM
      INTEGER          MT
      LOGICAL          FMUBRM,FMUNUC,FMUORG





      COMMON /CRNCSNCS/SIGN30,SIGN45,SIGN60,SIGO30,SIGO45,SIGO60,
     *                 SIGA30,SIGA45,SIGA60,PNOA30,PNOA45,PNOA60,
     *                 SIG30A,SIG45A,SIG60A
      DOUBLE PRECISION SIGN30(56),SIGN45(56),SIGN60(56),
     *                 SIGO30(56),SIGO45(56),SIGO60(56),
     *                 SIGA30(56),SIGA45(56),SIGA60(56),
     *                 PNOA30(1540,3),PNOA45(1540,3),PNOA60(1540,3),
     *                 SIG30A(56),SIG45A(56),SIG60A(56)



# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"










      COMMON /CROBSPAR/OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP,
     *                 THETPR,PHIPR,

     *                 CORRXY,







     *                 NOBSLV
      DOUBLE PRECISION OBSLEV(20),THCKOB(20),XOFF(20),YOFF(20),
     *                 HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2)

     *                 ,CORRXY







      INTEGER          NOBSLV










      COMMON /CRPAM/   PAMA,SIGNUM,RESTMS,DECTIM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000),
     *                 DECTIM(200)






      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL





      DOUBLE PRECISION GAMMA,COSTHE,PHIX,PHIY,H,T,X,Y,CHI,BETA,GCM,ECM

     *                 ,WEIGHT


     *                 ,HAPP,COSTAP,COSTEA




      EQUIVALENCE      (CURPAR(1), GAMMA ), (CURPAR(2), COSTHE),
     *                 (CURPAR(3), PHIX  ), (CURPAR(4), PHIY  ),
     *                 (CURPAR(5), H     ), (CURPAR(6), T     ),
     *                 (CURPAR(7), X     ), (CURPAR(8), Y     ),
     *                 (CURPAR(9), CHI   ), (CURPAR(10),BETA  ),
     *                 (CURPAR(11),GCM   ), (CURPAR(12),ECM   )

     *                ,(CURPAR(13),WEIGHT)


     *                ,(CURPAR(14),HAPP  ), (CURPAR(15),COSTAP),
     *                 (CURPAR(16),COSTEA)















# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"

























      COMMON /CRRANDPA/RD,FAC,U1,U2,NSEQ,ISEED,KNOR
      DOUBLE PRECISION RD(3000),FAC,U1,U2



      INTEGER          ISEED(3,10),NSEQ

      LOGICAL          KNOR



# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"











      COMMON /CRREST/  CONTNE,TAR,LIT
      DOUBLE PRECISION CONTNE(3),TAR
      INTEGER          LIT





      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"



      COMMON /CRSIGM/  SIGMA,SIGANN,SIGAIR,FRACTN,FRCTNO
      DOUBLE PRECISION SIGMA,SIGANN,SIGAIR,FRACTN,FRCTNO





      COMMON /CRSIGMU/ BREMSTAB,NUCTAB,PAIRTAB,DEDXMU,DEDXM,
     *                 FRABTN,FRANTN,FRAPTN,FRBTNO,FRNTNO,FRPTNO,
     *                 SIGBRM,SIGNUC,SIGPRM
      DOUBLE PRECISION BREMSTAB(141,3,2),NUCTAB(141,3,2),
     *                 PAIRTAB(141,3,2), DEDXMU(141,3,2),DEDXM(141,2),
     *                 FRABTN,FRANTN,FRAPTN,FRBTNO,FRNTNO,FRPTNO,
     *                 SIGBRM,SIGNUC,SIGPRM



# 4762 "corsika.h"

# 4821 "corsika.h"











      COMMON /CRSTRBAR/CSTRBA
      DOUBLE PRECISION CSTRBA(11)



# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     
















      COMMON /CRSIBYLC/FSIBYL,FSIBSG,FSIBCH
      LOGICAL          FSIBYL,FSIBSG,FSIBCH



     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 6737 "corsika.F" 2

      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

      DOUBLE PRECISION HNEW






      SAVE




      EXTERNAL         HEIGH,THICK,CBRSGM,CNUSGM,CPRSGM
C-----------------------------------------------------------------------


      IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=0,9),WEIGHT
  444 FORMAT(' BOX2  : CURPAR=',1P,11E11.3)




      ITYPE = INT( CURPAR(0) )

# 6878 "corsika.F"

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. 49  .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

# 6906 "corsika.F"

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

C  IT IS A TAU LEPTON
          COR1 = (-LOG( RD(1) )) * C(25) * DECTIM(131)
          MT   = 2
# 6931 "corsika.F"
        ENDIF

C  DETERMINE RANGE FOR MUON/TAU DECAY

        CALL PRANGC( COR1,.TRUE.,HNEW )
        DH   = MAX( 0.D0, H - HNEW )
# 6946 "corsika.F"
cdh  elongate the muon range 
c       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.
# 7086 "corsika.F"
          CALL URQSIG( ELAB,ITYPE )
          FURQSG  = .TRUE.
          GHESIG  = .FALSE.
        ELSE
          FURQSG  = .FALSE.

          USELOW  = .FALSE.
          GHESIG  = .FALSE.
# 7107 "corsika.F"
          IF ( FSIBSG  .AND.  (ELAB .GE. HILOELB) ) THEN
            CALL SIBSIG( ELAB,2 )
          ELSE





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)

          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 (  COSTHE .LT. 0.D0 ) THEN
          CHIINT = MIN( CHIINT, -THICKH/COSTHE )
        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)

        CALL PRANGC( COR1,.FALSE.,HNEW )




        IF (  COSTHE .LT. 0.D0 ) THEN
          CHI = MIN( CHI, -THICKH/COSTHE )
        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.
# 7208 "corsika.F"
          IF ( FSIBSG ) THEN
            CALL SIBSIG( ELAB,2 )
          ELSE





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)

          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 (  COSTHE .LT. 0.D0 ) THEN
            CHIINT = MIN( CHIINT, -THICKH/COSTHE )
          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)

          CALL NRANGC( COR1*BETA*GAMMA )
# 7261 "corsika.F"
          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





        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.
# 7303 "corsika.F"
          CALL URQSIG( ELAB,ITYPE )
          FURQSG = .TRUE.
          GHESIG = .FALSE.
        ELSE
          FURQSG = .FALSE.

          USELOW = .FALSE.
          GHESIG = .FALSE.
# 7324 "corsika.F"
          IF ( FSIBSG  .AND.  (ELAB .GE. HILOELB) ) THEN
            CALL SIBSIG( ELAB,1 )
          ELSE





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)

          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
        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 (  COSTHE .LT. 0.D0 ) THEN
          CHI = MIN( CHI, ABS( THICKH/COSTHE ) )
        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.
# 7413 "corsika.F"
          CALL URQSIG( ELAB,ITYPE )
          FURQSG = .TRUE.
          GHESIG = .FALSE.
        ELSE
          FURQSG = .FALSE.

          USELOW = .FALSE.
          GHESIG = .FALSE.
# 7434 "corsika.F"
          IF ( FSIBSG  .AND.  (ELAB .GE. HILOELB) ) THEN
            CALL SIBSIG( ELAB,3 )
          ELSE





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)

          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 (  COSTHE .LT. 0.D0 ) THEN
          CHIINT = MIN( CHIINT, -THICKH/COSTHE )
        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

          CALL NRANGC( COR1*BETA*GAMMA )
# 7501 "corsika.F"
        ELSE
C  CHARGED KAONS

          CALL PRANGC( COR1,.FALSE.,HNEW )




          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 )
        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.
# 7567 "corsika.F"
          IF ( FSIBSG ) THEN
            CALL SIBSIG( ELAB,3 )
          ELSE





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)

          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 (  COSTHE .LT. 0.D0 ) THEN
            CHIINT = MIN( CHIINT, -THICKH/COSTHE )
          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)

          CALL NRANGC( COR1*BETA*GAMMA )
# 7620 "corsika.F"
          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

        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.
# 7671 "corsika.F"
          CALL URQSIG( ELAB,ITYPE )
          FURQSG = .TRUE.
          GHESIG = .FALSE.
        ELSE
          FURQSG = .FALSE.

          USELOW = .FALSE.
          GHESIG = .FALSE.
C  CROSS-SECTION FOR BARYONS IS ASSUMED TO BE THE SAME AS FOR NUCLEONS
# 7693 "corsika.F"
          IF ( FSIBSG  .AND.  (ELAB .GE. HILOELB) ) THEN
            CALL SIBSIG( ELAB,1 )
          ELSE





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)

          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

          CALL NRANGC( COR1*BETA*GAMMA )
# 7749 "corsika.F"
        ELSE
C  CHARGED STRANGE BARYONS

          CALL PRANGC( COR1,.FALSE.,HNEW )




          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)
        CHIINT = (-LOG( RD(1) )) * AVERAW / (AVOGDR * SIGAIR)

        IF (  COSTHE .LT. 0.D0 ) THEN
          CHIINT = MIN( CHIINT, -THICKH/COSTHE )
        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 )
# 7787 "corsika.F"
C  MODEL CAN TREAT ALL STRANGE BARYONS
        IF ( CHI .LT. CHIINT ) THEN
          FDECAY = .TRUE.
        ELSE
          FDECAY = .FALSE.
        ENDIF

C  GHEISHA CANNOT TREAT SIGMA0 AND ANTI-SIGMA0, LET THEM DECAY
        IF ( GHESIG  .AND.  (ITYPE .EQ. 20  .OR.  ITYPE .EQ. 28) )
     *                                              FDECAY = .TRUE.






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


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.
# 7909 "corsika.F"
          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

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)


          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 (  COSTHE .LT. 0.D0 ) THEN
            CHIINT = MIN( CHIINT, -THICKH/COSTHE )
          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 1
          ENDIF
          COR1   = (-LOG( RD(1) )) * C(25) * DECTIM(ITYPE)
          IF ( SIGNUM(ITYPE) .EQ. 0.D0 ) THEN

C  NEUTRAL PARTICLES
            CALL NRANGC( COR1*BETA*GAMMA )
# 7999 "corsika.F"
          ELSE
C  CHARGED PARTICLES

            CALL PRANGC( COR1,.FALSE.,HNEW )




            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(1),CHIDEC=',
     *                                    ITYPE,SNGL(RD(1)),SNGL(CHI)
          CHI    = MIN( CHIINT, CHI )
          IF ( CHI .LT. CHIINT ) THEN
            FDECAY = .TRUE.
          ELSE
            FDECAY = .FALSE.
          ENDIF
        ENDIF
# 8038 "corsika.F"
C  SIBYLL 2.3 WITH CHARM CAN TREAT CHARMED PROJECTILES




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.
# 8094 "corsika.F"
          IF ( FSIBSG ) THEN
            SIGAIR = 1.D-32
          ELSE
# 8130 "corsika.F"
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)


          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 (  COSTHE .LT. 0.D0 ) THEN
            CHIINT = MIN( CHIINT, -THICKH/COSTHE )
          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 1
          ENDIF
          COR1   = (-LOG(RD(1))) * C(25) * DECTIM(ITYPE)
          IF ( SIGNUM(ITYPE) .EQ. 0.D0 ) THEN

C  NEUTRAL PARTICLES
            CALL NRANGC( COR1*BETA*GAMMA )
# 8201 "corsika.F"
          ELSE
C  CHARGED PARTICLES

            CALL PRANGC( COR1,.FALSE.,HNEW )




            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(1),CHIDEC=',
     *                                    ITYPE,SNGL(RD(1)),SNGL(CHI)
          CHI    = MIN( CHIINT, CHI )

          IF ( CHI .LT. CHIINT ) THEN
            FDECAY = .TRUE.
          ELSE
            FDECAY = .FALSE.
          ENDIF
        ENDIF
# 8238 "corsika.F"
C  SIBYLL CANNOT TREAT SEVERAL BOTTOM PARTICLES
*       IF ( ITYPE .EQ. ???   )
          FDECAY = .TRUE.
# 8249 "corsika.F"
        IF ( DEBUG ) WRITE(MDEBUG,*)
     *               'BOX2  : BOTTOM PARTICLE',ITYPE,' FDECAY=',FDECAY


C-----------------------------------------------------------------------
C  HEAVY PRIMARIES ( ITYPE = 100 * A + Z ,  FE -> ITYPE = 5626 )
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 1
        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
# 8287 "corsika.F"
          USELOW = .TRUE.
          CALL URQSIG( ELABT,ITYPE )
          FURQSG = .TRUE.
          GHESIG = .FALSE.
        ELSE
          FURQSG = .FALSE.

          USELOW = .FALSE.
          GHESIG = .FALSE.
        ENDIF
# 8313 "corsika.F"
        IF ( FSIBSG  .AND.  (ELAB .GE. HILOELB) ) THEN
          CALL SIBSIG( ELAB,ITYPE )
          GOTO 333
        ELSE
# 8328 "corsika.F"
C  URQMD KNOWS LOW-ENERGY HEAVY PROJECTILE CROSS-SECTIONS
          IF ( FURQSG ) GOTO 333

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

        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




          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 1

        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 (  COSTHE .LT. 0.D0 ) THEN
          CHI = MIN( CHI, -THICKH/COSTHE )
        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 1
      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
# 8444 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"



      COMMON /CRBUFFS/ RUNH,RUNE,EVTH,EVTE,DATAB,ARRAYLONG,LH

     *                 ,WRRUNH,WRRUNE,WREVTH,WREVTE

      INTEGER          MAXBUF,MAXLEN

      PARAMETER        (MAXBUF=39*8)
# 3681 "corsika.h"
      PARAMETER        (MAXLEN=16)
# 3693 "corsika.h"
      REAL             RUNH(MAXBUF),EVTH(MAXBUF),EVTE(MAXBUF),
     *                 RUNE(MAXBUF),DATAB(MAXBUF),ARRAYLONG(MAXBUF)
      INTEGER          LH

      LOGICAL          WRRUNH,WRRUNE,WREVTH,WREVTE

      CHARACTER*4      CRUNH,CRUNE,CEVTH,CEVTE,CLONG
      EQUIVALENCE      (RUNH(1),CRUNH), (RUNE(1),CRUNE)
      EQUIVALENCE      (EVTH(1),CEVTH), (EVTE(1),CEVTE)
      EQUIVALENCE      (ARRAYLONG(1),CLONG)



























































































# 3811 "corsika.h"

# 3824 "corsika.h"










      COMMON /CRGENER/ GEN,ALEVEL
      DOUBLE PRECISION GEN,ALEVEL











# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"



      COMMON /CRIRET/  IRET1,IRET2,IRETE
      INTEGER          IRET1,IRET2
      LOGICAL          IRETE



# 3912 "corsika.h"
























      INTEGER          LNGMAX
      PARAMETER        (LNGMAX = 15000)
      INTEGER          TYPE1
      PARAMETER        (TYPE1 = 0)
      INTEGER          TYPE2
      PARAMETER        (TYPE2 = 1)
      INTEGER          TYPE3
      PARAMETER        (TYPE3 = 2)
      INTEGER          TYPE4
      PARAMETER        (TYPE4 = 3)
      COMMON /CRLONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP



     *                ,LLONGI,FLGFIT
# 3961 "corsika.h"
      DOUBLE PRECISION ADLONG(0:LNGMAX,19),AELONG(0:LNGMAX,10),
     *                 APLONG(0:LNGMAX,10),DLONG(0:LNGMAX,19),
     *                 ELONG(0:LNGMAX,10),
     *                 HLONG(0:LNGMAX),PLONG(0:LNGMAX,10),
     *                 SDLONG(0:LNGMAX,19),SELONG(0:LNGMAX,10),
     *                 SPLONG(0:LNGMAX,10),THSTEP,THSTPI




      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT

      COMMON /CRSLANT/ RLONG,THCKRL,CTH,STHCPH,STHSPH,RLOFF
      DOUBLE PRECISION RLONG(0:LNGMAX),THCKRL(0:LNGMAX),
     *                 CTH,STHCPH,STHSPH,RLOFF


















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"










      COMMON /CROBSPAR/OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP,
     *                 THETPR,PHIPR,

     *                 CORRXY,







     *                 NOBSLV
      DOUBLE PRECISION OBSLEV(20),THCKOB(20),XOFF(20),YOFF(20),
     *                 HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2)

     *                 ,CORRXY







      INTEGER          NOBSLV










      COMMON /CRPAM/   PAMA,SIGNUM,RESTMS,DECTIM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000),
     *                 DECTIM(200)






      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL





      DOUBLE PRECISION GAMMA,COSTHE,PHIX,PHIY,H,T,X,Y,CHI,BETA,GCM,ECM

     *                 ,WEIGHT


     *                 ,HAPP,COSTAP,COSTEA




      EQUIVALENCE      (CURPAR(1), GAMMA ), (CURPAR(2), COSTHE),
     *                 (CURPAR(3), PHIX  ), (CURPAR(4), PHIY  ),
     *                 (CURPAR(5), H     ), (CURPAR(6), T     ),
     *                 (CURPAR(7), X     ), (CURPAR(8), Y     ),
     *                 (CURPAR(9), CHI   ), (CURPAR(10),BETA  ),
     *                 (CURPAR(11),GCM   ), (CURPAR(12),ECM   )

     *                ,(CURPAR(13),WEIGHT)


     *                ,(CURPAR(14),HAPP  ), (CURPAR(15),COSTAP),
     *                 (CURPAR(16),COSTEA)















# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"

























      COMMON /CRRANDPA/RD,FAC,U1,U2,NSEQ,ISEED,KNOR
      DOUBLE PRECISION RD(3000),FAC,U1,U2



      INTEGER          ISEED(3,10),NSEQ

      LOGICAL          KNOR



# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"



      COMMON /CRTHNVAR/STACKINT,

     *                 EEPP,ELIM,


     *                 RMAX,RMAX2,
     *                 WMAX,WMAX0,WMAXE,WMAXE0,WMAXEM,

     *                 INT_ICOUNT,MODETHN,THINNING

     *                 ,RLIM,WLIM

      INTEGER          MAXICOUNT
      PARAMETER        (MAXICOUNT = 200000)
# 4883 "corsika.h"
      DOUBLE PRECISION STACKINT(0:16,MAXICOUNT)
# 4892 "corsika.h"
     *                 ,EEPP(MAXICOUNT),ELIM


     *                 ,RMAX,RMAX2
     *                 ,WMAX,WMAX0,WMAXE,WMAXE0,WMAXEM

      INTEGER          INT_ICOUNT,MODETHN
      LOGICAL          THINNING

      LOGICAL           RLIM,WLIM




















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 8444 "corsika.F" 2

      DOUBLE PRECISION THICK
      INTEGER          I,IRET3




      LOGICAL          FLAG
# 8468 "corsika.F"
      INTEGER          LBIN
      EXTERNAL         LBIN


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

      SAVE
      EXTERNAL         THICK
C-----------------------------------------------------------------------


      IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=0,9),WEIGHT
  444 FORMAT(' BOX3  : CURPAR=',1P,11E11.3)





      IF     ( ITYPE .EQ. 5  .OR.  ITYPE .EQ. 6

     *   .OR.  ITYPE .EQ. 131  .OR.  ITYPE .EQ. 132

     *                                              ) 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
C  RESONANCES, VECTOR MESONS INCLUDING PHI MESONS 
      ELSEIF ( ITYPE .GE. 49  .AND.  ITYPE .LE. 65 ) THEN
C  RESONANCES DECAY WITHIN SUBR. RESDEC


        IF ( LLONGI ) LHEIGH = MIN( LBIN( X,Y,HAPP,1 ), NSTEP+1 )






        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

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
# 8565 "corsika.F"
          ALEVEL = H
          BETA   = SQRT( (GAMMA-1.D0)*(GAMMA+1.D0) ) / GAMMA
        ENDIF

# 8793 "corsika.F"
      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




# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"


















      COMMON /CRMUPART/AATOM,AMUPAR,BCUT,CMUON,CTAU,CONSTKINE,
     *                 EBYMU,EBYTAU,EE,SE,VFRAC,VMAX,VMIN,ZATOM,
     *                 MT,FMUBRM,FMUNUC,FMUORG






      DOUBLE PRECISION AMUPAR(0:18),BCUT,CMUON(11),CTAU(11),


     *                 AATOM,CONSTKINE,EBYMU,EBYTAU,EE,SE,
     *                 VFRAC,VMAX,VMIN,ZATOM
      INTEGER          MT
      LOGICAL          FMUBRM,FMUNUC,FMUORG



# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"










      COMMON /CRSIGMU/ BREMSTAB,NUCTAB,PAIRTAB,DEDXMU,DEDXM,
     *                 FRABTN,FRANTN,FRAPTN,FRBTNO,FRNTNO,FRPTNO,
     *                 SIGBRM,SIGNUC,SIGPRM
      DOUBLE PRECISION BREMSTAB(141,3,2),NUCTAB(141,3,2),
     *                 PAIRTAB(141,3,2), DEDXMU(141,3,2),DEDXM(141,2),
     *                 FRABTN,FRANTN,FRAPTN,FRBTNO,FRNTNO,FRPTNO,
     *                 SIGBRM,SIGNUC,SIGPRM



# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 8824 "corsika.F" 2

      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




# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"


















      COMMON /CRMUPART/AATOM,AMUPAR,BCUT,CMUON,CTAU,CONSTKINE,
     *                 EBYMU,EBYTAU,EE,SE,VFRAC,VMAX,VMIN,ZATOM,
     *                 MT,FMUBRM,FMUNUC,FMUORG






      DOUBLE PRECISION AMUPAR(0:18),BCUT,CMUON(11),CTAU(11),


     *                 AATOM,CONSTKINE,EBYMU,EBYTAU,EE,SE,
     *                 VFRAC,VMAX,VMIN,ZATOM
      INTEGER          MT
      LOGICAL          FMUBRM,FMUNUC,FMUORG



# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"










      COMMON /CRSIGMU/ BREMSTAB,NUCTAB,PAIRTAB,DEDXMU,DEDXM,
     *                 FRABTN,FRANTN,FRAPTN,FRBTNO,FRNTNO,FRPTNO,
     *                 SIGBRM,SIGNUC,SIGPRM
      DOUBLE PRECISION BREMSTAB(141,3,2),NUCTAB(141,3,2),
     *                 PAIRTAB(141,3,2), DEDXMU(141,3,2),DEDXM(141,2),
     *                 FRABTN,FRANTN,FRAPTN,FRBTNO,FRNTNO,FRPTNO,
     *                 SIGBRM,SIGNUC,SIGPRM



# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 8879 "corsika.F" 2

      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


*-- 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)
# 8933 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"



      COMMON /CRIRET/  IRET1,IRET2,IRETE
      INTEGER          IRET1,IRET2
      LOGICAL          IRETE



# 3912 "corsika.h"
























      INTEGER          LNGMAX
      PARAMETER        (LNGMAX = 15000)
      INTEGER          TYPE1
      PARAMETER        (TYPE1 = 0)
      INTEGER          TYPE2
      PARAMETER        (TYPE2 = 1)
      INTEGER          TYPE3
      PARAMETER        (TYPE3 = 2)
      INTEGER          TYPE4
      PARAMETER        (TYPE4 = 3)
      COMMON /CRLONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP



     *                ,LLONGI,FLGFIT
# 3961 "corsika.h"
      DOUBLE PRECISION ADLONG(0:LNGMAX,19),AELONG(0:LNGMAX,10),
     *                 APLONG(0:LNGMAX,10),DLONG(0:LNGMAX,19),
     *                 ELONG(0:LNGMAX,10),
     *                 HLONG(0:LNGMAX),PLONG(0:LNGMAX,10),
     *                 SDLONG(0:LNGMAX,19),SELONG(0:LNGMAX,10),
     *                 SPLONG(0:LNGMAX,10),THSTEP,THSTPI




      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT

      COMMON /CRSLANT/ RLONG,THCKRL,CTH,STHCPH,STHSPH,RLOFF
      DOUBLE PRECISION RLONG(0:LNGMAX),THCKRL(0:LNGMAX),
     *                 CTH,STHCPH,STHSPH,RLOFF


















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"








      COMMON /CRPAM/   PAMA,SIGNUM,RESTMS,DECTIM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000),
     *                 DECTIM(200)






      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL





      DOUBLE PRECISION GAMMA,COSTHE,PHIX,PHIY,H,T,X,Y,CHI,BETA,GCM,ECM

     *                 ,WEIGHT


     *                 ,HAPP,COSTAP,COSTEA




      EQUIVALENCE      (CURPAR(1), GAMMA ), (CURPAR(2), COSTHE),
     *                 (CURPAR(3), PHIX  ), (CURPAR(4), PHIY  ),
     *                 (CURPAR(5), H     ), (CURPAR(6), T     ),
     *                 (CURPAR(7), X     ), (CURPAR(8), Y     ),
     *                 (CURPAR(9), CHI   ), (CURPAR(10),BETA  ),
     *                 (CURPAR(11),GCM   ), (CURPAR(12),ECM   )

     *                ,(CURPAR(13),WEIGHT)


     *                ,(CURPAR(14),HAPP  ), (CURPAR(15),COSTAP),
     *                 (CURPAR(16),COSTEA)















# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"


















      COMMON /CRPYTLIN/ IPTABL,IFLGPYE,IFLGPYW
      INTEGER           IPTABL(200),IFLGPYE,IFLGPYW





      COMMON /CRRANDPA/RD,FAC,U1,U2,NSEQ,ISEED,KNOR
      DOUBLE PRECISION RD(3000),FAC,U1,U2



      INTEGER          ISEED(3,10),NSEQ

      LOGICAL          KNOR



# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"











      COMMON /CRSTRBAR/CSTRBA
      DOUBLE PRECISION CSTRBA(11)



# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 8933 "corsika.F" 2

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

      INTEGER          PYCOMP
      EXTERNAL         PYCOMP


      INTEGER          LBIN
      EXTERNAL         LBIN

      SAVE
      EXTERNAL         THICK
C-----------------------------------------------------------------------


      IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=0,9),WEIGHT
 444  FORMAT(' CHRMDC: CURPAR=',1P,11E11.3)




      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

      SECPAR(13) = WEIGHT


      SECPAR(14) = CURPAR(14)
      SECPAR(15) = CURPAR(15)
      SECPAR(16) = CURPAR(16)
# 9011 "corsika.F"
      IF ( LLONGI ) LHEIGH = MIN( LBIN( X,Y,HAPP,1 ), NSTEP+1 )







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


*-- 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



# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























      COMMON /CRCURVE/ CHAPAR,DEP,ERR,NSTP
      DOUBLE PRECISION CHAPAR(15000),DEP(15000),ERR(15000)
      INTEGER          NSTP





























































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 9085 "corsika.F" 2

      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



# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























      COMMON /CRCURVE/ CHAPAR,DEP,ERR,NSTP
      DOUBLE PRECISION CHAPAR(15000),DEP(15000),ERR(15000)
      INTEGER          NSTP





























































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 9156 "corsika.F" 2

      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




# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"


















      COMMON /CRMUPART/AATOM,AMUPAR,BCUT,CMUON,CTAU,CONSTKINE,
     *                 EBYMU,EBYTAU,EE,SE,VFRAC,VMAX,VMIN,ZATOM,
     *                 MT,FMUBRM,FMUNUC,FMUORG






      DOUBLE PRECISION AMUPAR(0:18),BCUT,CMUON(11),CTAU(11),


     *                 AATOM,CONSTKINE,EBYMU,EBYTAU,EE,SE,
     *                 VFRAC,VMAX,VMIN,ZATOM
      INTEGER          MT
      LOGICAL          FMUBRM,FMUNUC,FMUORG



# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"










      COMMON /CRSIGMU/ BREMSTAB,NUCTAB,PAIRTAB,DEDXMU,DEDXM,
     *                 FRABTN,FRANTN,FRAPTN,FRBTNO,FRNTNO,FRPTNO,
     *                 SIGBRM,SIGNUC,SIGPRM
      DOUBLE PRECISION BREMSTAB(141,3,2),NUCTAB(141,3,2),
     *                 PAIRTAB(141,3,2), DEDXMU(141,3,2),DEDXM(141,2),
     *                 FRABTN,FRANTN,FRAPTN,FRBTNO,FRNTNO,FRPTNO,
     *                 SIGBRM,SIGNUC,SIGPRM



# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 9228 "corsika.F" 2

      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


*-- 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
# 9400 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"










      COMMON /CRATMOS/ AATM,AATM0,BATM,BATM0,CATM,CATM0,DATM,MODATM
     *                ,MATMFI,LATMNEW
      DOUBLE PRECISION AATM(5),AATM0(5,0:42),BATM(5),BATM0(5,0:42),
     *                 CATM(5),CATM0(5,0:42),DATM(5)
      INTEGER          MODATM,MATMFI
      LOGICAL          LATMNEW





      COMMON /CRATMOS2/HLAY,HLAY0,THICKL,LAYNO,LAYNEW
      DOUBLE PRECISION HLAY(6),HLAY0(5,0:28),THICKL(5)
      INTEGER          LAYNO(0:41)
      LOGICAL          LAYNEW













      COMMON /CRATMOSL/PATH1,RHOSLT,TSLANT,HLAYS,RHOS,THICKS,
     *                 CCATM,HLAYC,HGROUND,RADGRD,IENDT
      INTEGER          MAXSLANT,MAXSLANT2
      PARAMETER        (MAXSLANT2=1600, MAXSLANT=MAXSLANT2*5)
      DOUBLE PRECISION PATH1(MAXSLANT),RHOSLT(MAXSLANT),
     *                 TSLANT(MAXSLANT),HLAYS(6),RHOS(6),THICKS(6),
     *                 CCATM(5),HLAYC(6),HGROUND,RADGRD
      INTEGER          IENDT



# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"










      COMMON /CRINCLINED/XPINCL,YPINCL,ZPINCL,PHINCL,THINCL
     *,TDINCL
      DOUBLE PRECISION XPINCL,YPINCL,ZPINCL,PHINCL,THINCL,TDINCL



# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"
























      INTEGER          LNGMAX
      PARAMETER        (LNGMAX = 15000)
      INTEGER          TYPE1
      PARAMETER        (TYPE1 = 0)
      INTEGER          TYPE2
      PARAMETER        (TYPE2 = 1)
      INTEGER          TYPE3
      PARAMETER        (TYPE3 = 2)
      INTEGER          TYPE4
      PARAMETER        (TYPE4 = 3)
      COMMON /CRLONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP



     *                ,LLONGI,FLGFIT
# 3961 "corsika.h"
      DOUBLE PRECISION ADLONG(0:LNGMAX,19),AELONG(0:LNGMAX,10),
     *                 APLONG(0:LNGMAX,10),DLONG(0:LNGMAX,19),
     *                 ELONG(0:LNGMAX,10),
     *                 HLONG(0:LNGMAX),PLONG(0:LNGMAX,10),
     *                 SDLONG(0:LNGMAX,19),SELONG(0:LNGMAX,10),
     *                 SPLONG(0:LNGMAX,10),THSTEP,THSTPI




      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT

      COMMON /CRSLANT/ RLONG,THCKRL,CTH,STHCPH,STHSPH,RLOFF
      DOUBLE PRECISION RLONG(0:LNGMAX),THCKRL(0:LNGMAX),
     *                 CTH,STHCPH,STHSPH,RLOFF


















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"










      COMMON /CROBSPAR/OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP,
     *                 THETPR,PHIPR,

     *                 CORRXY,







     *                 NOBSLV
      DOUBLE PRECISION OBSLEV(20),THCKOB(20),XOFF(20),YOFF(20),
     *                 HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2)

     *                 ,CORRXY







      INTEGER          NOBSLV



# 4262 "corsika.h"



      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL





      DOUBLE PRECISION GAMMA,COSTHE,PHIX,PHIY,H,T,X,Y,CHI,BETA,GCM,ECM

     *                 ,WEIGHT


     *                 ,HAPP,COSTAP,COSTEA




      EQUIVALENCE      (CURPAR(1), GAMMA ), (CURPAR(2), COSTHE),
     *                 (CURPAR(3), PHIX  ), (CURPAR(4), PHIY  ),
     *                 (CURPAR(5), H     ), (CURPAR(6), T     ),
     *                 (CURPAR(7), X     ), (CURPAR(8), Y     ),
     *                 (CURPAR(9), CHI   ), (CURPAR(10),BETA  ),
     *                 (CURPAR(11),GCM   ), (CURPAR(12),ECM   )

     *                ,(CURPAR(13),WEIGHT)


     *                ,(CURPAR(14),HAPP  ), (CURPAR(15),COSTAP),
     *                 (CURPAR(16),COSTEA)















# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"











      COMMON /CRTIMLIM/DSTLIM,TIMLIM,LTMLMPR
      DOUBLE PRECISION DSTLIM,TIMLIM
      LOGICAL          LTMLMPR



# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 9400 "corsika.F" 2

      DOUBLE PRECISION AUXIL,DIST,TEA,THETA,DIAG,DIAGMX

      DOUBLE PRECISION AUXILH,DIAGFR,DIAGH,DISTI,DT,D1,D2,HH,HH1,HH2,
     *                 H1,H2,RIMPCT,STH,THCKMX,THCKTOT,XXX,YYY

      DOUBLE PRECISION DT1,DT2,HHHH2(MAXSLANT),THCKTOT1,THCKTOT2

      INTEGER          I,I3,JINV
      DOUBLE PRECISION HEIGH,HEIGHTD,RHOF,THICK
      EXTERNAL         HEIGH,HEIGHTD,RHOF,THICK

      DOUBLE PRECISION THOFF,DHOFF

      INTEGER          K
# 9425 "corsika.F"
      DOUBLE PRECISION HFRAME,HPLANE

      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 ( FIMPCT ) THEN
        COSTAP = 0.D0
C  DISTANCE DIAG BETWEEN DETECTOR POSITION  X=Y=0, Z = HIMPCT AND
C  STARTING POINT
ctp        AUXIL  = (C(1)+H)**2 - (C(1)+HIMPCT)**2
        AUXIL  = (2d0*C(1) + H + HIMPCT) * (H - HIMPCT)
        DIAG   = SQRT( AUXIL )
        DIAGMX = 2D0*DIAG  !PROPAGATION ON BOTH SIDE OF THE AXIS FOR TIME LIMIT
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)+OBSLEV(1)) * SQRT((1.D0-COSTAP)*(1.D0+COSTAP))
        AUXIL  = ((C(1)+H) - AUXIL) * ((C(1)+H) + AUXIL)
        IF ( PRMPAR(15) .LT. 0.D0 ) THEN




          DIAG = SQRT( AUXIL ) + (C(1)+OBSLEV(1)) * COSTAP
C  DISTANCE DIAGMX BETWEEN PARTICLE POSITION AND TOP OF ATM  
          AUXIL  = (C(1)+OBSLEV(1)) * SQRT((1.D0-COSTAP)*(1.D0+COSTAP))
          AUXIL  = ((C(1)+HLAY(6)) - AUXIL) * ((C(1)+HLAY(6)) + AUXIL)
          DIAGMX = SQRT( AUXIL ) + (C(1)+OBSLEV(1)) * COSTAP - DIAG         

        ELSE
          DIAG = SQRT( AUXIL ) - (C(1)+OBSLEV(1)) * COSTAP
          DIAGMX = DIAG
        ENDIF
C  APPARENT HEIGHT HAPP IS PARTICLE Z-COORDINATE IN DETECTOR SYSTEM



        HAPP   = OBSLEV(1) + DIAG * ABS(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))*ABS(COSTAP))/(C(1)+H)

        COSTHE = SIGN( COSTHE, COSTAP )
      ENDIF
# 9525 "corsika.F"

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 )

C TAKE INTO ACCOUNT THE FACT THAT WE ARE ON THE OTHER SIDE OF THE AXIS
      TEA = SIGN( TEA, COSTAP )

      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 ( 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

C TAKE INTO ACCOUNT THE FACT THAT WE ARE ON THE OTHER SIDE OF THE AXIS
        XXX = XXX * SIGN( 1D0, CTH )
        YYY = YYY * SIGN( 1D0, CTH )

        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



        HH       = HEIGH( THICK0 )

        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 WITH SLANT TDINCL IS SLANT DEPTH ALONG SHOWER AXIS
        IF ( ABS( TDINCL ) .GT. 0D0 )THEN
          ZPINCL = -1D0
          DHOFF  =  0D0
          THOFF  =  0D0

          IF ( FIX1I )THEN
C         DEFINE DISTANCE BETWEEN DETECTOR AND STARTING POINT



            HFRAME = OBSLEV(1)

            IF( FIMPCT ) HFRAME = HIMPCT
            HPLANE = FIXHEI
            AUXIL  = (C(1)+HFRAME) * SQRT((1.D0-COSTAP)*(1.D0+COSTAP))
            AUXIL  = ((C(1)+HPLANE) - AUXIL) * ((C(1)+HPLANE) + AUXIL)
            DHOFF  = SQRT( AUXIL ) - (C(1)+HFRAME) * ABS( COSTAP )
          ENDIF

        ENDIF

C  CLEAR  ALL ARRAYS
        DO  I = 1, MAXSLANT
          PATH1(I)  = 0.D0
          RHOSLT(I) = 0.D0
          TSLANT(I) = 0.D0
        ENDDO
C  NON-SKIMMING INCIDENCE (UPWARD OR DOWNWARD)
        RIMPCT = RADGRD * SQRT( (1.D0+COSTAP)*(1.D0-COSTAP) )

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  SHOWER AXIS WITH UPWARD OR DOWNWARD PRIMARY PARTICLE

          IF ( PRMPAR(15) .LT. 0.D0 ) THEN
C  PRIMARY PARTICLE GOES UPWARD
# 9676 "corsika.F"
C  THE REFERENCE IS THE DISTANCE TO THE OBSERVATION LEVEL EVEN IF PARTICLES START AT H1, BUT NO PROPAGATION BELOW H1
            DT = -DIAGMX
            D1 = DIAG

            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


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





        THSTEP = MAX( THSTEP, DBLE( INT( THCKMX+0.5D0 ) ) )


  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
# 9728 "corsika.F"
          THSTEP = THSTEP + 1.D0

          IF ( DEBUG ) WRITE(MDEBUG,*)
     *       'COOINC: LONGI THSTEP=',THSTEP,' NSTEP =',NSTEP
          GOTO 2

        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 ( 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)

            IF ( ABS( TDINCL ) .GT. 0D0  .AND. ZPINCL .LE. 0D0 ) THEN
              IF(DHOFF.GT.0D0)THEN
                IF ( D2 .GT. DHOFF ) THEN
                  THOFF = TSLANT(I3)
                ELSE
                  AUXIL = ( DHOFF - D2 ) / ( PATH1(I3) - PATH1(I3+1) )
                  THOFF = TSLANT(I3) + AUXIL*( TSLANT(I3+1)-TSLANT(I3) )
                  DHOFF = 0D0
                ENDIF
              ENDIF
              IF ( TSLANT(I3)-THOFF .GE. TDINCL ) THEN
                AUXIL = TSLANT(I3) - THOFF - TDINCL
                AUXIL = AUXIL / ( TSLANT(I3) - TSLANT(I3+1) )
                ZPINCL = D2 - AUXIL * ( PATH1(I3+1) - PATH1(I3) )
              ENDIF
            ENDIF

          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 )
          IF ( DEBUG ) WRITE(MDEBUG,127)
     *                         I3,HH2,PATH1(I3),RHOSLT(I3),TSLANT(I3)
        ELSE
C  NON_SKIMMING INCIDENCE (UPWARD OR DOWNWARD)
          IF ( PRMPAR(15) .LT. 0.D0 ) THEN
C  UPWARD PRIMARY
            DIAGFR = -DIAGMX / DBLE( MAXSLANT - 1.D0 )
            DISTI  = -DIAGFR



            D1     = DIAG

            DO   I3 = MAXSLANT, 2, -1
              DISTI = DISTI + DIAGFR
              CALL DL2DT( DISTI,TSLANT(MAXSLANT+1-I3),H1,H2,D1,D2,
     *                    RIMPCT )

C             SLANT DISTANCE DEFINED FROM STARTING POINT
              D2   = D2 - DIAG

              PATH1(MAXSLANT+1-I3)  = D2
              RHOSLT(MAXSLANT+1-I3) = RHOF( H2 )
              HHHH2(MAXSLANT+1-I3)  = H2

              IF ( ABS( TDINCL ) .GT. 0D0 .AND. ZPINCL .LE. 0D0 ) THEN
               K = MAXSLANT+1-I3
C             SLANT DISTANCE FROM DETECTOR POSITION
               IF(DHOFF.GT.0D0)THEN
                IF ( D2 .lT. DHOFF ) THEN
                  THOFF = TSLANT(K)
                ELSE
                  AUXIL = ( D2 - DHOFF ) / (PATH1(K)-PATH1(K-1))
                  THOFF = TSLANT(K) + AUXIL*( TSLANT(K-1)-TSLANT(K) )
                  DHOFF = 0D0
                ENDIF
               ENDIF
               IF ( TSLANT(K)-THOFF .GE. TDINCL ) THEN
                AUXIL = TSLANT(K) - THOFF - TDINCL
                AUXIL = AUXIL / ( TSLANT(K) - TSLANT(K-1) )



                ZPINCL = DIAG + D2 - AUXIL * ( PATH1(K) - PATH1(K-1) )

               ENDIF
c               print *,K,PATH1(K),DHOFF,TSLANT(K),THOFF,ZPINCL
              ENDIF

            ENDDO
            I3 = MAXSLANT
            PATH1(I3)  = 2.D0 * PATH1(I3-1)
            TSLANT(I3) = 2.D0 * TSLANT(I3-1)
            HHHH2(I3)  = HLAYC(6)
            RHOSLT(I3) = RHOF( HHHH2(I3) )
            DO   I3 = MAXSLANT, 1, -1
              IF ( DEBUG ) WRITE(MDEBUG,127)
     *                I3,HHHH2(I3),PATH1(I3),RHOSLT(I3),TSLANT(I3)
            ENDDO
          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)

              IF ( ABS( TDINCL ) .GT. 0D0 .AND. ZPINCL .LE. 0D0 ) THEN
               IF(DHOFF.GT.0D0)THEN
                IF ( D2 .GT. DHOFF ) THEN
                  THOFF = TSLANT(I3)
                ELSE
                  AUXIL = ( DHOFF - D2 ) / ( PATH1(I3) - PATH1(I3+1) )
                  THOFF = TSLANT(I3) + AUXIL*( TSLANT(I3+1)-TSLANT(I3) )
                  DHOFF = 0D0
                ENDIF
               ENDIF
               IF ( TSLANT(I3)-THOFF .GE. TDINCL ) THEN
                AUXIL = TSLANT(I3) - THOFF - TDINCL
                AUXIL = AUXIL / ( TSLANT(I3) - TSLANT(I3+1) )
                ZPINCL = D2 - AUXIL * ( PATH1(I3+1) - PATH1(I3) )
               ENDIF
              ENDIF

            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 )
            IF ( DEBUG ) WRITE(MDEBUG,127)
     *                            I3,HH2,PATH1(1),RHOSLT(1),TSLANT(1)

          ENDIF
        ENDIF

        IF ( DEBUG ) WRITE(MDEBUG,*) '        I3       H2          ',
     *                        '  PATH1        RHOSLT        TSLANT'
        IF ( DEBUG ) WRITE(MDEBUG,*) 'COOINC: BIN    HEIGHT        ',
     *                          'SL. PATH       DENSITY      SL.DEPTH'
        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 ( 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

        IF ( FPRINT .OR. DEBUG ) WRITE(MONIOU,*)' '
 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
# 10005 "corsika.F"
        
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     SET THE TIME LIMIT ACCORDING TO THE INCLINED SHOWER NOT TO LOSE TOO
C     MUCH TIME TRACKING PARTICLES BEYOND THE RELEVANT OBSERVATION PLANE
      IF ( ABS( TDINCL ) .GT. 0D0 ) THEN
        AUXIL  = ZPINCL
      ELSE
        HFRAME = OBSLEV(1)
        IF( FIMPCT ) HFRAME = HIMPCT
        HPLANE = ZPINCL
        AUXIL  = (C(1)+HFRAME) * SQRT((1.D0-COSTAP)*(1.D0+COSTAP))
        AUXIL  = ((C(1)+HPLANE) - AUXIL) * ((C(1)+HPLANE) + AUXIL)
        AUXIL  = SQRT( AUXIL ) - (C(1)+HFRAME) * ABS( COSTAP )
      ENDIF
C     NOW AUXIL IS THE DISTANCE TO THE CORE
      IF ( FIMPCT ) THEN
        DIAGMX = 0.5D0*DIAGMX - AUXIL
      ELSEIF ( PRMPAR(15) .GE. 0.D0 ) THEN
        DIAGMX = DIAGMX - AUXIL
      ELSE
C       FOR UPWARD GOING SHOWER, TIME IS LIMITED BY THE PROPAGATION FROM THE GROUND
        DIAGMX = AUXIL - DIAG
      ENDIF
      IF ( DIAGMX .LT. 0D0 ) WRITE(MDEBUG,*) 'COOINC: WARNING ! ',
     *     'DIAGMX=',DIAGMX,
     *     ' <0, INCLINED PLANE ORIGIN AFTER STARTING POINT...'

C  FOR SAFETY ADD ADDITIONAL 25 MICROSEC. (ALL TIME UNITS IN SEC)
      TIMLIM = ( DIAGMX + DSTLIM ) / C(25) + 2.5D-5
      IF ( DEBUG .OR. LTMLMPR ) WRITE(MDEBUG,*) 'COOINC: DIAG=',DIAG,
     *           'DIAGMX=',DIAGMX,'DSTLIM=',DSTLIM,' TIMLIM=',TIMLIM


      RETURN
      END

# 10418 "corsika.F"
*-- 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




# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"


















      COMMON /CRMUPART/AATOM,AMUPAR,BCUT,CMUON,CTAU,CONSTKINE,
     *                 EBYMU,EBYTAU,EE,SE,VFRAC,VMAX,VMIN,ZATOM,
     *                 MT,FMUBRM,FMUNUC,FMUORG






      DOUBLE PRECISION AMUPAR(0:18),BCUT,CMUON(11),CTAU(11),


     *                 AATOM,CONSTKINE,EBYMU,EBYTAU,EE,SE,
     *                 VFRAC,VMAX,VMIN,ZATOM
      INTEGER          MT
      LOGICAL          FMUBRM,FMUNUC,FMUORG



# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"










      COMMON /CRSIGMU/ BREMSTAB,NUCTAB,PAIRTAB,DEDXMU,DEDXM,
     *                 FRABTN,FRANTN,FRAPTN,FRBTNO,FRNTNO,FRPTNO,
     *                 SIGBRM,SIGNUC,SIGPRM
      DOUBLE PRECISION BREMSTAB(141,3,2),NUCTAB(141,3,2),
     *                 PAIRTAB(141,3,2), DEDXMU(141,3,2),DEDXM(141,2),
     *                 FRABTN,FRANTN,FRAPTN,FRBTNO,FRNTNO,FRPTNO,
     *                 SIGBRM,SIGNUC,SIGPRM



# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 10444 "corsika.F" 2

      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
# 10830 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"










      COMMON /CRATMOS/ AATM,AATM0,BATM,BATM0,CATM,CATM0,DATM,MODATM
     *                ,MATMFI,LATMNEW
      DOUBLE PRECISION AATM(5),AATM0(5,0:42),BATM(5),BATM0(5,0:42),
     *                 CATM(5),CATM0(5,0:42),DATM(5)
      INTEGER          MODATM,MATMFI
      LOGICAL          LATMNEW





      COMMON /CRATMOS2/HLAY,HLAY0,THICKL,LAYNO,LAYNEW
      DOUBLE PRECISION HLAY(6),HLAY0(5,0:28),THICKL(5)
      INTEGER          LAYNO(0:41)
      LOGICAL          LAYNEW











# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"











      COMMON /CRCONSTA/PI,PI2,OB3,TB3,ENEPER,SQRT3
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER,SQRT3


































      COMMON /CRDPMFLG/NFLAIN,NFLDIF,NFLPI0,NFLCHE,NFLPIF,NFRAGM
      INTEGER          NFLAIN,NFLDIF,NFLPI0,NFLCHE,NFLPIF,NFRAGM












      COMMON /CREGSDEB/JCLOCK,NCLOCK,FEGSDB
      INTEGER          JCLOCK,NCLOCK
      LOGICAL          FEGSDB





      COMMON /CRELABCT/ELCUT
      DOUBLE PRECISION ELCUT(4)


















# 3811 "corsika.h"

# 3824 "corsika.h"



      COMMON /CRETHMAP/ECTMAP,ELEFT,ELEFTJ
      DOUBLE PRECISION ECTMAP,ELEFT,ELEFTJ


















# 3855 "corsika.h"










      COMMON /CRINCLINED/XPINCL,YPINCL,ZPINCL,PHINCL,THINCL
     *,TDINCL
      DOUBLE PRECISION XPINCL,YPINCL,ZPINCL,PHINCL,THINCL,TDINCL



# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"
























      INTEGER          LNGMAX
      PARAMETER        (LNGMAX = 15000)
      INTEGER          TYPE1
      PARAMETER        (TYPE1 = 0)
      INTEGER          TYPE2
      PARAMETER        (TYPE2 = 1)
      INTEGER          TYPE3
      PARAMETER        (TYPE3 = 2)
      INTEGER          TYPE4
      PARAMETER        (TYPE4 = 3)
      COMMON /CRLONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP



     *                ,LLONGI,FLGFIT
# 3961 "corsika.h"
      DOUBLE PRECISION ADLONG(0:LNGMAX,19),AELONG(0:LNGMAX,10),
     *                 APLONG(0:LNGMAX,10),DLONG(0:LNGMAX,19),
     *                 ELONG(0:LNGMAX,10),
     *                 HLONG(0:LNGMAX),PLONG(0:LNGMAX,10),
     *                 SDLONG(0:LNGMAX,19),SELONG(0:LNGMAX,10),
     *                 SPLONG(0:LNGMAX,10),THSTEP,THSTPI




      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT

      COMMON /CRSLANT/ RLONG,THCKRL,CTH,STHCPH,STHSPH,RLOFF
      DOUBLE PRECISION RLONG(0:LNGMAX),THCKRL(0:LNGMAX),
     *                 CTH,STHCPH,STHSPH,RLOFF






      COMMON /CRMAGANG/ARRANG,ARRANR,COSANG,SINANG
      DOUBLE PRECISION ARRANG,ARRANR,COSANG,SINANG





      COMMON /CRMAGNET/BX,BZ,BVAL,BNORMC,BNORM,COSB,SINB,BLIMIT
      DOUBLE PRECISION BX,BZ,BVAL,BNORMC,BNORM,COSB,SINB,BLIMIT



# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"



      COMMON /CRMUMULT/CHC,OMC,PHISCT,STEPL,VSCAT,FMOLI
      DOUBLE PRECISION CHC,OMC,PHISCT,STEPL,VSCAT
      LOGICAL          FMOLI










# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"



      COMMON /CRNKGI/  SEL,SELLG,STH,ZEL,ZELLG,ZSL,DIST,
     *                 DISX,DISY,DISXY,DISYX,DLAX,DLAY,DLAXY,DLAYX,
     *                 OBSATI,RADNKG,RMOL,TLEV,TLEVCM,IALT
      DOUBLE PRECISION SEL(10),SELLG(10),STH(10),ZEL(10),ZELLG(10),
     *                 ZSL(10),DIST(10),
     *                 DISX(-10:10),DISY(-10:10),
     *                 DISXY(-10:10,2),DISYX(-10:10,2),
     *                 DLAX (-10:10,2),DLAY (-10:10,2),
     *                 DLAXY(-10:10,2),DLAYX(-10:10,2),
     *                 OBSATI(2),RADNKG,RMOL(2),TLEV(10),TLEVCM(10)
      INTEGER          IALT(2)


















# 4212 "corsika.h"










      COMMON /CROBSPAR/OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP,
     *                 THETPR,PHIPR,

     *                 CORRXY,







     *                 NOBSLV
      DOUBLE PRECISION OBSLEV(20),THCKOB(20),XOFF(20),YOFF(20),
     *                 HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2)

     *                 ,CORRXY







      INTEGER          NOBSLV



# 4262 "corsika.h"



      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL



# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"










      COMMON /CRPRIMSP/PSLOPE,LLIMIT,ULIMIT,LL,UL,SLEX,ISPEC
      DOUBLE PRECISION PSLOPE,LLIMIT,ULIMIT,LL,UL,SLEX
      INTEGER          ISPEC





      COMMON /CRPYTLIN/ IPTABL,IFLGPYE,IFLGPYW
      INTEGER           IPTABL(200),IFLGPYE,IFLGPYW





      COMMON /CRRANDPA/RD,FAC,U1,U2,NSEQ,ISEED,KNOR
      DOUBLE PRECISION RD(3000),FAC,U1,U2



      INTEGER          ISEED(3,10),NSEQ

      LOGICAL          KNOR





      INTEGER          KSEQ



      PARAMETER        (KSEQ = 9)

      COMMON /CRRANMA3/CD,CINT,CM,TWOM24,TWOM48,MODCNS
      DOUBLE PRECISION CD,CINT,CM,TWOM24,TWOM48
      INTEGER          MODCNS



# 4441 "corsika.h"

# 4450 "corsika.h"










      COMMON /CRREJECT/AVNREJ,ALTMIN,ANEXP,THICKA,THICKD,CUTLN,EONCUT,

     *                 EFRCTHN,ETHINN,ETHINNG,THINRAT,THINRATH,WEITRAT,
     *                 WEITRATH,EEFRTHN,

     *                 FNPRIM
      DOUBLE PRECISION AVNREJ(20),ALTMIN(20),ANEXP(20),THICKA(20),
     *                 THICKD(20),CUTLN,EONCUT

     *                 ,EFRCTHN,ETHINN,ETHINNG,THINRAT,THINRATH,WEITRAT,
     *                 WEITRATH,EEFRTHN

      LOGICAL          FNPRIM





















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"



      COMMON /CRTHNVAR/STACKINT,

     *                 EEPP,ELIM,


     *                 RMAX,RMAX2,
     *                 WMAX,WMAX0,WMAXE,WMAXE0,WMAXEM,

     *                 INT_ICOUNT,MODETHN,THINNING

     *                 ,RLIM,WLIM

      INTEGER          MAXICOUNT
      PARAMETER        (MAXICOUNT = 200000)
# 4883 "corsika.h"
      DOUBLE PRECISION STACKINT(0:16,MAXICOUNT)
# 4892 "corsika.h"
     *                 ,EEPP(MAXICOUNT),ELIM


     *                 ,RMAX,RMAX2
     *                 ,WMAX,WMAX0,WMAXE,WMAXE0,WMAXEM

      INTEGER          INT_ICOUNT,MODETHN
      LOGICAL          THINNING

      LOGICAL           RLIM,WLIM














      COMMON /CRTIMLIM/DSTLIM,TIMLIM,LTMLMPR
      DOUBLE PRECISION DSTLIM,TIMLIM
      LOGICAL          LTMLMPR



# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     


      COMMON /CRSIBDBG/ISIBDB,ISDEBUG
      INTEGER          ISIBDB,ISDEBUG












      COMMON /CRSIBYLC/FSIBYL,FSIBSG,FSIBCH
      LOGICAL          FSIBYL,FSIBSG,FSIBCH



     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 10830 "corsika.F" 2

      DOUBLE PRECISION R1,R2
      INTEGER          I,IE,IOBSLV,IS,ISEQ,LENVAL,MMM,MONNEW,NUMERR,
     *                 IDCHAR
      CHARACTER        FILEATM*1024

      INTEGER          NNTYP
# 10860 "corsika.F"
      DOUBLE PRECISION THICK
      EXTERNAL         THICK


      LOGICAL          FCURVOUT


      DOUBLE PRECISION HEIGH
      EXTERNAL         HEIGH

      CHARACTER        LINE*512,TAB*1
# 10881 "corsika.F"
      SAVE





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

      ISEED(1,2) = 2
      ISEED(2,2) = 0
      ISEED(3,2) = 0

      ISEED(1,3) = 3
      ISEED(2,3) = 0
      ISEED(3,3) = 0

      ISEED(1,4) = 4
      ISEED(2,4) = 0
      ISEED(3,4) = 0

      ISEED(1,5) = 5
      ISEED(2,5) = 0
      ISEED(3,5) = 0

      ISEED(1,6) = 6
      ISEED(2,6) = 0
      ISEED(3,6) = 0

      ISEED(1,7) = 7
      ISEED(2,7) = 0
      ISEED(3,7) = 0
      ISEED(1,8) = 8
      ISEED(2,8) = 0
      ISEED(3,8) = 0
ctp 9TH SEQUENCE USED AND DEFINED IN CONEX ONLY
ctp      ISEED(1,9) = 9
ctp      ISEED(2,9) = 0
ctp      ISEED(3,9) = 0

      NRRUN     = 1
      ISHOWNO   = 0



      LLIMIT    = 1.D4

      ULIMIT    = 1.D4
      PSLOPE    = 0.D0




      PRMPAR(0) = 14.D0

      THETPR(1) = 0.D0
      THETPR(2) = 0.D0
      PHIPR(1)  = 0.D0
      PHIPR(2)  = 0.D0

      NSHOW     = 1



      IOBSLV    = 0
      NOBSLV    = 1




C  DEFAULT VALUE FOR KASCADE
      OBSLEV(1) = 110.D2




      MODATM    = 1
      LAYNEW    = .FALSE.
      LATMNEW   = .FALSE.






      ELCUT(1)  = 0.3D0
      ELCUT(2)  = 0.3D0
      ELCUT(3)  = 0.003D0
      ELCUT(4)  = 0.003D0

      ECTMAP  = 1.D11
      NFLAIN  = 0
      NFLDIF  = 0
      NFLPI0  = 0
      NFLPIF  = 0
      NFLCHE  = 0
      NFRAGM  = 2
      FEGS    = .TRUE.
      FNKG    = .TRUE.
      FMOLI   = .TRUE.
      FMUADD  = .FALSE.
# 11008 "corsika.F"
      XPINCL = 0.D0
      YPINCL = 0.D0
      ZPINCL = OBSLEV(1)
      THINCL = 0.D0
      PHINCL = 0.D0
      TDINCL = 0.D0

      FPAROUT = .TRUE.
      FTABOUT = .FALSE.





      FFLATOUT= .FALSE.
      FCURVOUT= .TRUE.



      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

      RCUT    = 0.D0  ! [cm]
      RCUT2   = RCUT**2
# 11066 "corsika.F"
      STEPFC  = 1.D0



      MAXPRT  = 1 
# 11097 "corsika.F"
      ARRANG  = 0.D0
      BX      = 20.40D0  ! KASCADE MAGNETIC FIELD COMPONENT X-DIRECTION
      BZ      = 43.23D0  ! KASCADE MAGNETIC FIELD COMPONENT Z-DIRECTION
# 11133 "corsika.F"
      LLONGI  = .TRUE.



      THSTEP  = 20.D0
      FLGFIT  = .FALSE.
      FLONGOUT= .FALSE.
      RADNKG  = 200.D2



      FDBASE  = .FALSE.
      DEBUG   = .FALSE.
      DEBDEL  = .FALSE.
      NDEBDL  = 100000000
      THICK0  = 0.D0
      FIX1I   = .FALSE.
      FIXHEI  = 0.D0
      DSN     = 'anynameupto239characters/'
      DATDIR  = './'
# 11169 "corsika.F"
      TMARGIN = .TRUE.
# 11192 "corsika.F"
      DSTLIM  = 1204.4D5    !1204.4 km
      LTMLMPR = .FALSE.     !NO PRINTING IF PARTICLE EXCEEDS TIME LIMIT


      HIMPACT(1) = 0.D0
      HIMPACT(2) = HEIGH( 0.D0 )
      HIMPCT  = 0.D0
      FIMPCT  = .FALSE.

      HOST    = '                                                      ' 
      USER    = '                                                      '



      FILOUT  = '                    '
      FOUTFILE= .FALSE.
# 11254 "corsika.F"
      IFLGPYE = 0
      IFLGPYW = 0


C  DEFAULT VALUES
      SIGMAQ(1) = 0.D0
      SIGMAQ(2) = 0.D0
      SIGMAQ(3) = 0.D0
      SIGMAQ(4) = 0.D0
C  PROPAGATION
      PROPMOD = 1
# 11300 "corsika.F"
C  BORDER BETWEEN LOW AND HIGH ENERGY INTERACTION MODELS
C  SET BY DEFAULT TO ELAB = 80 GEV
      HILOELB = 80.D0
# 11312 "corsika.F"
      GHEISH  = .FALSE.
      FURQMD  = .TRUE.
      IUDEBUG = 0
      IUDEBG0 = 0
# 11362 "corsika.F"
      FSIBYL  = .TRUE.
      FSIBSG  = .TRUE.
      FSIBCH  = .TRUE.
      ISDEBUG = 0
# 11413 "corsika.F"
C-----------------------------------------------------------------------
C  OPEN DATASET FOR COMMANDS

      IF ( MONIIN .NE. 5 ) THEN



        OPEN(UNIT=MONIIN,FILE='INPUTS',STATUS='OLD',FORM='FORMATTED')

        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,*) '  '



      NUMERR = 0
C-----------------------------------------------------------------------
 1    CONTINUE

C  ERASE 'LINE' BY FILLING WITH BLANKS
      LINE = ' '







C  GET A NEW INPUT LINE AND PRINT IT
      READ(MONIIN,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 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:7) .NE. 'ATMFILE'
     *     .AND.  LINE(1:6) .NE. 'HISTDS'
# 11493 "corsika.F"
     *     .AND.  LINE(1:7) .NE. 'OUTFILE'
# 11504 "corsika.F"
     *                                   ) THEN
        DO  I = 2, LEN(LINE)
          CALL LOWUP( LINE(I:I),IDCHAR )
        ENDDO
# 11525 "corsika.F"
      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






C  GET ANGLE (DEGREES) BETWEEN ARRAY X-DIRECTION AND MAGNETIC NORD
      ELSEIF ( LINE(1:6) .EQ. 'ARRANG' ) THEN



        WRITE(MONIOU,*) 'DATAC : ARRANG NOT COMPATIBLE WITH COAST'




        STOP 1


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.
        IF ( LATMNEW ) THEN
          WRITE(MONIOU,*) 'DATAC : ATMFILE IS USED, '
     *                   ,'ATMLAY CAN NOT BE CHANGED'




          STOP 1
        ENDIF

C  GET INTERNAL ATMOSPHERIC MODEL NUMBER
      ELSEIF ( LINE(1:5) .EQ. 'ATMOD' ) THEN
        CALL DTCINT( LINE,IS,MODATM,'ATMOD',1 )
        IF ( LATMNEW ) THEN
          WRITE(MONIOU,*) 'DATAC : ATMFILE IS USED, '
     *                   ,'MODATM CAN NOT BE CHANGED'




          STOP 1
        ENDIF

# 11642 "corsika.F"
C  GET EXTERNAL ATMOSPHERIC TABLES
      ELSEIF ( LINE(1:7) .EQ. 'ATMFILE' ) THEN
        CALL DTCCHR( LINE,IS,FILEATM,'ATMFILE',1,LENVAL )
        IF ( LENVAL .GT. 0 ) THEN
          CALL RFILEATM(FILEATM,LENVAL)
        ELSE
          WRITE(MONIOU,*) 'DATAC : ATMFILE NAME IS EMPTY'




          STOP 1
        ENDIF
# 11834 "corsika.F"
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

# 11872 "corsika.F"
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

# 11977 "corsika.F"
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

# 12015 "corsika.F"
C  GET OUTPUT DIRECTORY FOR CALCULATIONS ON UNIX-STATION
      ELSEIF ( LINE(1:6) .EQ. 'DIRECT' ) THEN
        CALL DTCCHR( LINE,IS,DSN,'DIRECT',1,LENVAL )

# 12035 "corsika.F"
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 )







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 )








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 )


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 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.


C  OLD DEFINITION FOR COMPATIBILITY
      ELSEIF ( LINE(1:7) .EQ. 'FLATOUT' ) THEN
        CALL DTCLOG( LINE,IS,FFLATOUT,'FLATOUT',1 )

# 12139 "corsika.F"
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 )
# 12159 "corsika.F"







C  GET NAME OF HOST COMPUTER
      ELSEIF ( LINE(1:4) .EQ. 'HOST' ) THEN
        CALL DTCCHR( LINE,IS,HOST,'HOST',1,LENVAL )


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.



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 )
        CALL DTCDBL( LINE,IS,TDINCL,'INCLIN',6 )
# 12220 "corsika.F"
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 )

        CALL DTCLOG( LINE,IS,FLONGOUT,'LONGI',4 )




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 ( MAXPRT .LE. 0 ) MAXPRT = 1



C  GET FLAG FOR ADDITIONAL MUON INFORMATION ON MPATAP
      ELSEIF ( LINE(1:6) .EQ. 'MUADDI' ) THEN
        CALL DTCLOG( LINE,IS,FMUADD,'MUADDI',1 )


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 )

# 12328 "corsika.F"
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
# 12344 "corsika.F"

# 12357 "corsika.F"
C  GET HEIGHT OF OBSERVATION LEVELS
      ELSEIF ( LINE(1:6) .EQ. 'OBSLEV' ) THEN
        IOBSLV = IOBSLV + 1

        IF ( IOBSLV .LE. 1 ) THEN
          CALL DTCDBL( LINE,IS,OBSLEV(IOBSLV),'OBSLEV',1 )
          NOBSLV = IOBSLV
        ELSE

          WRITE(MONIOU,*) 'DATAC : ONLY ONE OBSERVATION LEVEL ,',
     *                    'POSSIBLE IN CURVED VERSION'
# 12377 "corsika.F"
          STOP 1
# 12390 "corsika.F"
        ENDIF


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.


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

# 12420 "corsika.F"
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 )

# 12465 "corsika.F"
C  GET TYPE OF PRIMARY PARTICLE
      ELSEIF ( LINE(1:6) .EQ. 'PRMPAR' ) THEN
        CALL DTCINT( LINE,IS,NNTYP,'PRMPAR',1 )
        PRMPAR(0) = NNTYP



      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



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 )

# 12502 "corsika.F"
C  GET WIDTH OF NKG LATERAL DISTRIBUTION
      ELSEIF ( LINE(1:6) .EQ. 'RADNKG' ) THEN
        CALL DTCDBL( LINE,IS,RADNKG,'RADNKG',1 )






C  GET RUN NUMBER
      ELSEIF ( LINE(1:5) .EQ. 'RUNNR' ) THEN
        CALL DTCINT( LINE,IS,NRRUN,'RUNNR',1 )
        NRRUN = ABS(NRRUN)

# 12532 "corsika.F"
C  GET SEEDS OF RANDOM NUMBER SEQUENCES
      ELSEIF ( LINE(1:4) .EQ. 'SEED' ) THEN
        ISEQ = ISEQ + 1
        IF ( ISEQ .LE. KSEQ ) THEN




            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 )



          NSEQ = ISEQ
        ELSE
          WRITE(MONIOU,*) 'DATAC : TOO MANY RANDOM GENERATOR SEEDS,',
     *                    ' IGNORE IT'
        ENDIF


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 CHARM PRODUCTION FLAG FOR SIBYLL HADRONIC INTERACTION MODEL        
      elseif ( line(1:6) .eq. 'SIBCHM' ) then
        call dtclog( line,is,fsibch,'SIBCHM',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 )



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 )

# 12589 "corsika.F"
C  GET FACTOR FOR ELECTRON''S MULTIPLE SCATTERING LENGTH
      ELSEIF ( LINE(1:6) .EQ. 'STEPFC' ) THEN
        CALL DTCDBL( LINE,IS,STEPFC,'STEPFC',1 )

# 12630 "corsika.F"
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 )


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



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 )

# 12727 "corsika.F"
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 )


C  GET NAME OF USER
      ELSEIF ( LINE(1:4) .EQ. 'USER' ) THEN
        CALL DTCCHR( LINE,IS,USER,'USER',1,LENVAL )

# 12771 "corsika.F"
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.')




        WRITE(0,*) 'BAD DATA CARDS'
        STOP 1
      ENDIF

      IF ( .NOT. LLONGI ) THEN




        WRITE(0,*) 'COASTUSERLIB + SLANT without LLONGI is&
     & not possible!'
        STOP 1
      ENDIF
# 12820 "corsika.F"


      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





# 1 "corsika.h" 1
# 3562 "corsika.h"



      COMMON /CRAIR/   COMPOS,PROBTA,AVERAW,AVOGDR
      DOUBLE PRECISION COMPOS(3),PROBTA(3),AVERAW,AVOGDR



# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"


















      COMMON /CRMUPART/AATOM,AMUPAR,BCUT,CMUON,CTAU,CONSTKINE,
     *                 EBYMU,EBYTAU,EE,SE,VFRAC,VMAX,VMIN,ZATOM,
     *                 MT,FMUBRM,FMUNUC,FMUORG






      DOUBLE PRECISION AMUPAR(0:18),BCUT,CMUON(11),CTAU(11),


     *                 AATOM,CONSTKINE,EBYMU,EBYTAU,EE,SE,
     *                 VFRAC,VMAX,VMIN,ZATOM
      INTEGER          MT
      LOGICAL          FMUBRM,FMUNUC,FMUORG



# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"








      COMMON /CRPAM/   PAMA,SIGNUM,RESTMS,DECTIM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000),
     *                 DECTIM(200)




# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 12848 "corsika.F" 2

      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 1
      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




# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"


















      COMMON /CRMUPART/AATOM,AMUPAR,BCUT,CMUON,CTAU,CONSTKINE,
     *                 EBYMU,EBYTAU,EE,SE,VFRAC,VMAX,VMIN,ZATOM,
     *                 MT,FMUBRM,FMUNUC,FMUORG






      DOUBLE PRECISION AMUPAR(0:18),BCUT,CMUON(11),CTAU(11),


     *                 AATOM,CONSTKINE,EBYMU,EBYTAU,EE,SE,
     *                 VFRAC,VMAX,VMIN,ZATOM
      INTEGER          MT
      LOGICAL          FMUBRM,FMUNUC,FMUORG



# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"








      COMMON /CRPAM/   PAMA,SIGNUM,RESTMS,DECTIM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000),
     *                 DECTIM(200)




# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 12916 "corsika.F" 2

      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 1
      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
# 13000 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"











      COMMON /CRCONSTA/PI,PI2,OB3,TB3,ENEPER,SQRT3
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER,SQRT3












































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"
























      INTEGER          LNGMAX
      PARAMETER        (LNGMAX = 15000)
      INTEGER          TYPE1
      PARAMETER        (TYPE1 = 0)
      INTEGER          TYPE2
      PARAMETER        (TYPE2 = 1)
      INTEGER          TYPE3
      PARAMETER        (TYPE3 = 2)
      INTEGER          TYPE4
      PARAMETER        (TYPE4 = 3)
      COMMON /CRLONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP



     *                ,LLONGI,FLGFIT
# 3961 "corsika.h"
      DOUBLE PRECISION ADLONG(0:LNGMAX,19),AELONG(0:LNGMAX,10),
     *                 APLONG(0:LNGMAX,10),DLONG(0:LNGMAX,19),
     *                 ELONG(0:LNGMAX,10),
     *                 HLONG(0:LNGMAX),PLONG(0:LNGMAX,10),
     *                 SDLONG(0:LNGMAX,19),SELONG(0:LNGMAX,10),
     *                 SPLONG(0:LNGMAX,10),THSTEP,THSTPI




      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT

      COMMON /CRSLANT/ RLONG,THCKRL,CTH,STHCPH,STHSPH,RLOFF
      DOUBLE PRECISION RLONG(0:LNGMAX),THCKRL(0:LNGMAX),
     *                 CTH,STHCPH,STHSPH,RLOFF


















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"








      COMMON /CRPAM/   PAMA,SIGNUM,RESTMS,DECTIM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000),
     *                 DECTIM(200)






      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL





      DOUBLE PRECISION GAMMA,COSTHE,PHIX,PHIY,H,T,X,Y,CHI,BETA,GCM,ECM

     *                 ,WEIGHT


     *                 ,HAPP,COSTAP,COSTEA




      EQUIVALENCE      (CURPAR(1), GAMMA ), (CURPAR(2), COSTHE),
     *                 (CURPAR(3), PHIX  ), (CURPAR(4), PHIY  ),
     *                 (CURPAR(5), H     ), (CURPAR(6), T     ),
     *                 (CURPAR(7), X     ), (CURPAR(8), Y     ),
     *                 (CURPAR(9), CHI   ), (CURPAR(10),BETA  ),
     *                 (CURPAR(11),GCM   ), (CURPAR(12),ECM   )

     *                ,(CURPAR(13),WEIGHT)


     *                ,(CURPAR(14),HAPP  ), (CURPAR(15),COSTAP),
     *                 (CURPAR(16),COSTEA)















# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"

























      COMMON /CRRANDPA/RD,FAC,U1,U2,NSEQ,ISEED,KNOR
      DOUBLE PRECISION RD(3000),FAC,U1,U2



      INTEGER          ISEED(3,10),NSEQ

      LOGICAL          KNOR



# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 13000 "corsika.F" 2

      DOUBLE PRECISION AUX1,AUX2,AUX2A,AUX3,AUX4,COSTCM,COSTH3,COSTH4,
     *                 FAC1,FAC2,GAMMA3,GAMMA4,PHI4,WORK1,WORK2
      INTEGER          I,M0,M3,M4





      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 ( SECPAR(2) .GE. C(29) ) THEN



        SECPAR(0) = M4
        SECPAR(1) = GAMMA4
# 13062 "corsika.F"
        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)




        CALL TSTACK
      ELSE
        IF ( LLONGI ) THEN
C  ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT
          IF ( M4 .EQ. 1 ) THEN

            DLONG(LHEIGH,11) = DLONG(LHEIGH,11) + GAMMA4 * WEIGHT



          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

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
# 13105 "corsika.F"
          ENDIF
        ENDIF
# 13138 "corsika.F"
      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 ( SECPAR(2) .GE. C(29) ) THEN



        SECPAR(0) = M3
        SECPAR(1) = GAMMA3




        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

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
# 13186 "corsika.F"
        ENDIF
# 13214 "corsika.F"
      ENDIF

      RETURN
      END

*-- Author :    D. HECK IKP KIT KARLSRUHE        29/08/2017
C=======================================================================

      SUBROUTINE DECAY2( M0 )

C-----------------------------------------------------------------------
C  DECAY (INTO TWO MUONS)
C
C  TWO PARTICLE DECAY WITH FULL KINEMATIC; ENERGY AND MOMENTA CONSERVED
C  INCLUDING POLARIZATION
C  THIS SUBROUTINE IS CALLED FROM ETADEC, RESDEC.
C  THIS ROUTINE IS A SPECIALIZED VERSION OF DECAY1.
C  ARGUMENT:
C   M0     = TYPE OF DECAYING PARTICLE
C
C   TESTED FOR ENERGY MOMENTUM CONSERVATION OK (2016.07.05)
C-----------------------------------------------------------------------

      IMPLICIT NONE
# 13251 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"











      COMMON /CRCONSTA/PI,PI2,OB3,TB3,ENEPER,SQRT3
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER,SQRT3












































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"
























      INTEGER          LNGMAX
      PARAMETER        (LNGMAX = 15000)
      INTEGER          TYPE1
      PARAMETER        (TYPE1 = 0)
      INTEGER          TYPE2
      PARAMETER        (TYPE2 = 1)
      INTEGER          TYPE3
      PARAMETER        (TYPE3 = 2)
      INTEGER          TYPE4
      PARAMETER        (TYPE4 = 3)
      COMMON /CRLONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP



     *                ,LLONGI,FLGFIT
# 3961 "corsika.h"
      DOUBLE PRECISION ADLONG(0:LNGMAX,19),AELONG(0:LNGMAX,10),
     *                 APLONG(0:LNGMAX,10),DLONG(0:LNGMAX,19),
     *                 ELONG(0:LNGMAX,10),
     *                 HLONG(0:LNGMAX),PLONG(0:LNGMAX,10),
     *                 SDLONG(0:LNGMAX,19),SELONG(0:LNGMAX,10),
     *                 SPLONG(0:LNGMAX,10),THSTEP,THSTPI




      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT

      COMMON /CRSLANT/ RLONG,THCKRL,CTH,STHCPH,STHSPH,RLOFF
      DOUBLE PRECISION RLONG(0:LNGMAX),THCKRL(0:LNGMAX),
     *                 CTH,STHCPH,STHSPH,RLOFF


















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"








      COMMON /CRPAM/   PAMA,SIGNUM,RESTMS,DECTIM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000),
     *                 DECTIM(200)






      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL





      DOUBLE PRECISION GAMMA,COSTHE,PHIX,PHIY,H,T,X,Y,CHI,BETA,GCM,ECM

     *                 ,WEIGHT


     *                 ,HAPP,COSTAP,COSTEA




      EQUIVALENCE      (CURPAR(1), GAMMA ), (CURPAR(2), COSTHE),
     *                 (CURPAR(3), PHIX  ), (CURPAR(4), PHIY  ),
     *                 (CURPAR(5), H     ), (CURPAR(6), T     ),
     *                 (CURPAR(7), X     ), (CURPAR(8), Y     ),
     *                 (CURPAR(9), CHI   ), (CURPAR(10),BETA  ),
     *                 (CURPAR(11),GCM   ), (CURPAR(12),ECM   )

     *                ,(CURPAR(13),WEIGHT)


     *                ,(CURPAR(14),HAPP  ), (CURPAR(15),COSTAP),
     *                 (CURPAR(16),COSTEA)















# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"



      COMMON /CRPOLAR/ POLART,POLARF
      DOUBLE PRECISION POLART,POLARF




















      COMMON /CRRANDPA/RD,FAC,U1,U2,NSEQ,ISEED,KNOR
      DOUBLE PRECISION RD(3000),FAC,U1,U2



      INTEGER          ISEED(3,10),NSEQ

      LOGICAL          KNOR



# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 13251 "corsika.F" 2

      DOUBLE PRECISION AUX1,AUX2,AUX2A,AUX3,AUX4,COSTCM,COSTH3,COSTH4,
     *                 GAMMA3,GAMMA4,PHI4,WORK1,WORK2
      INTEGER          I,M0,M3,M4





      SAVE
C-----------------------------------------------------------------------

      M3 = 5    ! MU+
      M4 = 6    ! MU-
      IF ( DEBUG ) WRITE(MDEBUG,444) BETA,M0,M3,M4
  444 FORMAT(' DECAY2: BETA,M0,M3,M4=',1P,E10.3,3I5)

C  PARTICLE COORDINATES 5..10 ARE COPIED INTO SECPAR IN CALLING PROGRAM
C  CALCULATE AUXILIARY QUANTITIES
c     AUX1   = ( ( PAMA(M0)**2 + PAMA(M3)**2 - PAMA(M4)**2 )
c    *            / (2.D0*PAMA(M0)) )**2  - PAMA(M3)**2
      AUX1   = ( ( PAMA(M0)**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,4,1 )
      COSTCM = 2.D0 * RD(1) - 1.D0
      GAMMA3 = WORK1 + WORK2 * COSTCM
C  SECOND MUON 
      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) )) )
      PHI4   = RD(2) * PI2
C  POLARISATION OF MUON (FOR ANGULAR CORRELATION IN IT''S DECAY)
      POLART = 2.D0*RD(3) - 1.D0
      POLARF = PI2*RD(4)
      CALL ADDANG3( COSTHE,PHIX,PHIY, COSTH4,PHI4,
     *                                 SECPAR(2),SECPAR(3),SECPAR(4) )

      IF ( SECPAR(2) .GE. C(29) ) THEN



        SECPAR(0) = M4
        SECPAR(1) = GAMMA4





        IF ( DEBUG ) WRITE(MDEBUG,445) (SECPAR(I),I=0,9),SECPAR(13)
  445   FORMAT(' DECAY2: SECPAR=',1P,9E11.3,0P,F10.0,1P,E10.3)




C  SET POLARIZATION
        SECPAR(11) = POLART
        SECPAR(12) = POLARF
        CALL TSTACK
      ELSE
        IF ( LLONGI ) THEN
C  ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT

C  ADD TO THE MUON ENERGY DEPOSIT
          DLONG(LHEIGH,15) = DLONG(LHEIGH,15) + ( GAMMA4*PAMA(M4)
     *                              - RESTMS(M4) ) * WEIGHT 





        ENDIF
# 13362 "corsika.F"
      ENDIF
C  FIRST MUON 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 ( SECPAR(2) .GE. C(29) ) THEN



        SECPAR(0) = M3
        SECPAR(1) = GAMMA3




        IF ( DEBUG ) WRITE(MDEBUG,445) (SECPAR(I),I=0,9)

C  INVERT POLARIZATION OPPOSIT TO SECOND MUON
        SECPAR(11) = -POLART
        SECPAR(12) =  POLARF + PI
        CALL TSTACK
      ELSE
        IF ( LLONGI ) THEN
C  ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT

C  ADD TO THE MUON ENERGY DEPOSIT
          DLONG(LHEIGH,15) = DLONG(LHEIGH,15) + ( GAMMA3*PAMA(M3)
     *                              - RESTMS(M3) ) * WEIGHT





        ENDIF
# 13425 "corsika.F"
      ENDIF

C  RESET POLARIZATION
      SECPAR(11) = 0.D0
      SECPAR(12) = 0.D0

      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
# 13484 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"











      COMMON /CRCONSTA/PI,PI2,OB3,TB3,ENEPER,SQRT3
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER,SQRT3




















      COMMON /CRDECAYC/GAM345,COS345,PHI345
      DOUBLE PRECISION GAM345(3),COS345(3),PHI345(3)






















































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"








      COMMON /CRPAM/   PAMA,SIGNUM,RESTMS,DECTIM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000),
     *                 DECTIM(200)






      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL





      DOUBLE PRECISION GAMMA,COSTHE,PHIX,PHIY,H,T,X,Y,CHI,BETA,GCM,ECM

     *                 ,WEIGHT


     *                 ,HAPP,COSTAP,COSTEA




      EQUIVALENCE      (CURPAR(1), GAMMA ), (CURPAR(2), COSTHE),
     *                 (CURPAR(3), PHIX  ), (CURPAR(4), PHIY  ),
     *                 (CURPAR(5), H     ), (CURPAR(6), T     ),
     *                 (CURPAR(7), X     ), (CURPAR(8), Y     ),
     *                 (CURPAR(9), CHI   ), (CURPAR(10),BETA  ),
     *                 (CURPAR(11),GCM   ), (CURPAR(12),ECM   )

     *                ,(CURPAR(13),WEIGHT)


     *                ,(CURPAR(14),HAPP  ), (CURPAR(15),COSTAP),
     *                 (CURPAR(16),COSTEA)















# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"



      COMMON /CRPOLAR/ POLART,POLARF
      DOUBLE PRECISION POLART,POLARF




















      COMMON /CRRANDPA/RD,FAC,U1,U2,NSEQ,ISEED,KNOR
      DOUBLE PRECISION RD(3000),FAC,U1,U2



      INTEGER          ISEED(3,10),NSEQ

      LOGICAL          KNOR



# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 13484 "corsika.F" 2

      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 ( MODE .LE. 2 ) THEN

        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

      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


*-- 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







# 1 "corsika.h" 1
# 3562 "corsika.h"










      COMMON /CRATMOS/ AATM,AATM0,BATM,BATM0,CATM,CATM0,DATM,MODATM
     *                ,MATMFI,LATMNEW
      DOUBLE PRECISION AATM(5),AATM0(5,0:42),BATM(5),BATM0(5,0:42),
     *                 CATM(5),CATM0(5,0:42),DATM(5)
      INTEGER          MODATM,MATMFI
      LOGICAL          LATMNEW





      COMMON /CRATMOS2/HLAY,HLAY0,THICKL,LAYNO,LAYNEW
      DOUBLE PRECISION HLAY(6),HLAY0(5,0:28),THICKL(5)
      INTEGER          LAYNO(0:41)
      LOGICAL          LAYNEW













      COMMON /CRATMOSL/PATH1,RHOSLT,TSLANT,HLAYS,RHOS,THICKS,
     *                 CCATM,HLAYC,HGROUND,RADGRD,IENDT
      INTEGER          MAXSLANT,MAXSLANT2
      PARAMETER        (MAXSLANT2=1600, MAXSLANT=MAXSLANT2*5)
      DOUBLE PRECISION PATH1(MAXSLANT),RHOSLT(MAXSLANT),
     *                 TSLANT(MAXSLANT),HLAYS(6),RHOS(6),THICKS(6),
     *                 CCATM(5),HLAYC(6),HGROUND,RADGRD
      INTEGER          IENDT



# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"










      COMMON /CROBSPAR/OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP,
     *                 THETPR,PHIPR,

     *                 CORRXY,







     *                 NOBSLV
      DOUBLE PRECISION OBSLEV(20),THCKOB(20),XOFF(20),YOFF(20),
     *                 HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2)

     *                 ,CORRXY







      INTEGER          NOBSLV



# 4262 "corsika.h"



      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL



# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 13727 "corsika.F" 2

      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
        WRITE(0,*) 'CRSDEPTH0: INCORRECT INPUT R<A!'
        STOP 1
      ELSEIF ( ABS( R1-R2 ) .LT. 1.D-10 ) THEN
        CRSDEPTH0 = 0.D0
        RETURN
      ENDIF
      IF ( J .EQ. 5 ) THEN     !LINEAR EVOLUTION
        CRSDEPTH0 = BATM(5) / CATM(5)
     &            * ABS( SQRT( (R2-A)*(R2+A) ) - SQRT( (R1-A)*(R2+A) ) )
      ELSE
        R2     = MIN( R2, RT+HLAYC(5) )
        RXX1   = (R1-A) * (1.D0+A/R1) * 0.5D0
        RXX2   = (R2-A) * (R2+A) / R1 * 0.5D0
        CRSDEPTH0 = EXP( -DATM(J)*(R1-RT-RXX1) ) * BATM(J)*DATM(J)*
     &          (GAMMQ( DATM(J)*RXX1 )- GAMMQ( DATM(J)*RXX2) )*
     &          SQRT( R1*CATM(J) ) * 1.253314137D0     !=SQRT(PI/2)
C  FACTOR FIXED TO HAVE Z(0 CM)=DEPTH(0) FOR THETA=0 DEG
        CORR   = ( ABS( RXX2-RXX1 )/ABS( R2-R1 ) - 1.D0 ) / 3.3604D0
C  TO CORRECT FOR THE APPROX. ON R1-R2 IN THE INTEGRAL
        CRSDEPTH0 = CRSDEPTH0 * ( 1.D0 + CORR )
      ENDIF


      RETURN
      END


*-- Author :    G.A. Erskine CERN          MATHLIB 01/04/1996
C=======================================================================

      DOUBLE PRECISION FUNCTION DGQUAD( F,A,B,N )

C-----------------------------------------------------------------------
C  D(OUBLE PRECISION) G(AUSS) QUAD(RATURE)
C
C  N-POINT GAUSSIAN QUADRATURE
C  SEE: http://wwwasdoc.web.cern.ch/wwwasdoc/cernlib.html (d107)
C  THIS FUNCTION IS CALLED FROM DKOKOE, DKOKOI, AND DKOKOS.
C  ARGUMENTS:   SEE REFERENCE
C-----------------------------------------------------------------------

      IMPLICIT NONE
      DOUBLE PRECISION A,B,F,W(1),X(1)
      INTEGER          N
      EXTERNAL         F
      SAVE
C-----------------------------------------------------------------------

      CALL D107D1( 1,F,A,B,N,X,W )
      DGQUAD = X(1)

      RETURN
      END

C=======================================================================

      SUBROUTINE D107D1( MODE,F,A,B,N,X,W )

C-----------------------------------------------------------------------
C  N-POINT GAUSSIAN QUADRATURE
C  SEE: http://wwwasdoc.web.cern.ch/wwwasdoc/cernlib.html (d107)
C  ARGUMENTS:   SEE REFERENCE
C-----------------------------------------------------------------------

      IMPLICIT NONE
      DOUBLE PRECISION Z1,HF
      PARAMETER        (Z1 = 1.D0)
      PARAMETER        (HF = Z1/2.D0)
      DOUBLE PRECISION U(273),V(273),W(*),X(*)
      DOUBLE PRECISION A,ALFA,B,BETA,DELTA,SUM,WTEMP
      INTEGER          J,J1,J2,KTBA(97),MODE,N
      DOUBLE PRECISION F
      EXTERNAL         F
      SAVE

      DATA KTBA
     1/0,1,2,4,6,9,12,16,20,25,30,36,42,49,56,64,3*0,72,3*0,82,7*0,94,
     2 7*0,110,7*0,130,15*0,154,15*0,186,15*0,226,0/

C  N=2.
      DATA U(1)  /5.7735026918962576D-1/, V(1)  /1.D0/
C  N=3.
      DATA U(2)  /7.7459666924148338D-1/, V(2)  /5.5555555555555556D-1/
      DATA U(3)  /0.D0/                 , V(3)  /8.8888888888888889D-1/
C  N=4.
      DATA U(4)  /8.6113631159405258D-1/, V(4)  /3.4785484513745386D-1/
      DATA U(5)  /3.3998104358485626D-1/, V(5)  /6.5214515486254614D-1/
C  N=5.
      DATA U(6)  /9.0617984593866399D-1/, V(6)  /2.3692688505618909D-1/
      DATA U(7)  /5.3846931010568309D-1/, V(7)  /4.7862867049936647D-1/
      DATA U(8)  /0.D0/                 , V(8)  /5.6888888888888889D-1/
C  N=6.
      DATA U(9)  /9.3246951420315203D-1/, V(9)  /1.7132449237917035D-1/
      DATA U(10) /6.6120938646626451D-1/, V(10) /3.6076157304813861D-1/
      DATA U(11) /2.3861918608319691D-1/, V(11) /4.6791393457269105D-1/
C  N=7.
      DATA U(12) /9.4910791234275852D-1/, V(12) /1.2948496616886969D-1/
      DATA U(13) /7.4153118559939444D-1/, V(13) /2.7970539148927667D-1/
      DATA U(14) /4.0584515137739717D-1/, V(14) /3.8183005050511894D-1/
      DATA U(15) /0.D0/                 , V(15) /4.1795918367346939D-1/
C  N=8.
      DATA U(16) /9.6028985649753623D-1/, V(16) /1.0122853629037626D-1/
      DATA U(17) /7.9666647741362674D-1/, V(17) /2.2238103445337447D-1/
      DATA U(18) /5.2553240991632899D-1/, V(18) /3.1370664587788729D-1/
      DATA U(19) /1.8343464249564980D-1/, V(19) /3.6268378337836198D-1/
C  N=9.
      DATA U(20) /9.6816023950762609D-1/, V(20) /8.1274388361574412D-2/
      DATA U(21) /8.3603110732663579D-1/, V(21) /1.8064816069485740D-1/
      DATA U(22) /6.1337143270059040D-1/, V(22) /2.6061069640293546D-1/
      DATA U(23) /3.2425342340380893D-1/, V(23) /3.1234707704000284D-1/
      DATA U(24) /0.D0/                 , V(24) /3.3023935500125976D-1/
C  N=10.
      DATA U(25) /9.7390652851717172D-1/, V(25) /6.6671344308688138D-2/
      DATA U(26) /8.6506336668898451D-1/, V(26) /1.4945134915058059D-1/
      DATA U(27) /6.7940956829902441D-1/, V(27) /2.1908636251598204D-1/
      DATA U(28) /4.3339539412924719D-1/, V(28) /2.6926671930999636D-1/
      DATA U(29) /1.4887433898163121D-1/, V(29) /2.9552422471475287D-1/
C  N=11.
      DATA U(30) /9.7822865814605699D-1/, V(30) /5.5668567116173666D-2/
      DATA U(31) /8.8706259976809530D-1/, V(31) /1.2558036946490462D-1/
      DATA U(32) /7.3015200557404932D-1/, V(32) /1.8629021092773425D-1/
      DATA U(33) /5.1909612920681182D-1/, V(33) /2.3319376459199048D-1/
      DATA U(34) /2.6954315595234497D-1/, V(34) /2.6280454451024666D-1/
      DATA U(35) /0.D0/                 , V(35) /2.7292508677790063D-1/
C  N=12.
      DATA U(36) /9.8156063424671925D-1/, V(36) /4.7175336386511827D-2/
      DATA U(37) /9.0411725637047486D-1/, V(37) /1.0693932599531843D-1/
      DATA U(38) /7.6990267419430469D-1/, V(38) /1.6007832854334623D-1/
      DATA U(39) /5.8731795428661745D-1/, V(39) /2.0316742672306592D-1/
      DATA U(40) /3.6783149899818019D-1/, V(40) /2.3349253653835481D-1/
      DATA U(41) /1.2523340851146892D-1/, V(41) /2.4914704581340279D-1/
C  N=13.
      DATA U(42) /9.8418305471858815D-1/, V(42) /4.0484004765315880D-2/
      DATA U(43) /9.1759839922297797D-1/, V(43) /9.2121499837728448D-2/
      DATA U(44) /8.0157809073330991D-1/, V(44) /1.3887351021978724D-1/
      DATA U(45) /6.4234933944034022D-1/, V(45) /1.7814598076194574D-1/
      DATA U(46) /4.4849275103644685D-1/, V(46) /2.0781604753688850D-1/
      DATA U(47) /2.3045831595513479D-1/, V(47) /2.2628318026289724D-1/
      DATA U(48) /0.D0/                 , V(48) /2.3255155323087391D-1/
C  N=14.
      DATA U(49) /9.8628380869681234D-1/, V(49) /3.5119460331751863D-2/
      DATA U(50) /9.2843488366357352D-1/, V(50) /8.0158087159760210D-2/
      DATA U(51) /8.2720131506976499D-1/, V(51) /1.2151857068790318D-1/
      DATA U(52) /6.8729290481168547D-1/, V(52) /1.5720316715819353D-1/
      DATA U(53) /5.1524863635815409D-1/, V(53) /1.8553839747793781D-1/
      DATA U(54) /3.1911236892788976D-1/, V(54) /2.0519846372129560D-1/
      DATA U(55) /1.0805494870734366D-1/, V(55) /2.1526385346315779D-1/
C  N=15.
      DATA U(56) /9.8799251802048543D-1/, V(56) /3.0753241996117268D-2/
      DATA U(57) /9.3727339240070590D-1/, V(57) /7.0366047488108125D-2/
      DATA U(58) /8.4820658341042722D-1/, V(58) /1.0715922046717194D-1/
      DATA U(59) /7.2441773136017005D-1/, V(59) /1.3957067792615431D-1/
      DATA U(60) /5.7097217260853885D-1/, V(60) /1.6626920581699393D-1/
      DATA U(61) /3.9415134707756337D-1/, V(61) /1.8616100001556221D-1/
      DATA U(62) /2.0119409399743452D-1/, V(62) /1.9843148532711158D-1/
      DATA U(63) /0.D0/                 , V(63) /2.0257824192556127D-1/
C  N=16.
      DATA U(64) /9.8940093499164993D-1/, V(64) /2.7152459411754095D-2/
      DATA U(65) /9.4457502307323258D-1/, V(65) /6.2253523938647893D-2/
      DATA U(66) /8.6563120238783174D-1/, V(66) /9.5158511682492785D-2/
      DATA U(67) /7.5540440835500303D-1/, V(67) /1.2462897125553387D-1/
      DATA U(68) /6.1787624440264375D-1/, V(68) /1.4959598881657673D-1/
      DATA U(69) /4.5801677765722739D-1/, V(69) /1.6915651939500254D-1/
      DATA U(70) /2.8160355077925891D-1/, V(70) /1.8260341504492359D-1/
      DATA U(71) /9.5012509837637440D-2/, V(71) /1.8945061045506850D-1/
C  N=20.
      DATA U(72) /9.9312859918509492D-1/, V(72) /1.7614007139152118D-2/
      DATA U(73) /9.6397192727791379D-1/, V(73) /4.0601429800386941D-2/
      DATA U(74) /9.1223442825132591D-1/, V(74) /6.2672048334109064D-2/
      DATA U(75) /8.3911697182221882D-1/, V(75) /8.3276741576704749D-2/
      DATA U(76) /7.4633190646015079D-1/, V(76) /1.0193011981724044D-1/
      DATA U(77) /6.3605368072651503D-1/, V(77) /1.1819453196151842D-1/
      DATA U(78) /5.1086700195082710D-1/, V(78) /1.3168863844917663D-1/
      DATA U(79) /3.7370608871541956D-1/, V(79) /1.4209610931838205D-1/
      DATA U(80) /2.2778585114164508D-1/, V(80) /1.4917298647260374D-1/
      DATA U(81) /7.6526521133497334D-2/, V(81) /1.5275338713072585D-1/
C  N=24.
      DATA U(82) /9.9518721999702136D-1/, V(82) /1.2341229799987200D-2/
      DATA U(83) /9.7472855597130950D-1/, V(83) /2.8531388628933663D-2/
      DATA U(84) /9.3827455200273276D-1/, V(84) /4.4277438817419806D-2/
      DATA U(85) /8.8641552700440103D-1/, V(85) /5.9298584915436781D-2/
      DATA U(86) /8.2000198597390292D-1/, V(86) /7.3346481411080306D-2/
      DATA U(87) /7.4012419157855436D-1/, V(87) /8.6190161531953276D-2/
      DATA U(88) /6.4809365193697557D-1/, V(88) /9.7618652104113888D-2/
      DATA U(89) /5.4542147138883954D-1/, V(89) /1.0744427011596563D-1/
      DATA U(90) /4.3379350762604514D-1/, V(90) /1.1550566805372560D-1/
      DATA U(91) /3.1504267969616337D-1/, V(91) /1.2167047292780339D-1/
      DATA U(92) /1.9111886747361631D-1/, V(92) /1.2583745634682830D-1/
      DATA U(93) /6.4056892862605626D-2/, V(93) /1.2793819534675216D-1/
C  N=32.
      DATA U(94) /9.9726386184948156D-1/, V(94) /7.0186100094700966D-3/
      DATA U(95) /9.8561151154526834D-1/, V(95) /1.6274394730905671D-2/
      DATA U(96) /9.6476225558750643D-1/, V(96) /2.5392065309262059D-2/
      DATA U(97) /9.3490607593773969D-1/, V(97) /3.4273862913021433D-2/
      DATA U(98) /8.9632115576605212D-1/, V(98) /4.2835898022226681D-2/
      DATA U(99) /8.4936761373256997D-1/, V(99) /5.0998059262376176D-2/
      DATA U(100)/7.9448379596794241D-1/, V(100)/5.8684093478535547D-2/
      DATA U(101)/7.3218211874028968D-1/, V(101)/6.5822222776361847D-2/
      DATA U(102)/6.6304426693021520D-1/, V(102)/7.2345794108848506D-2/
      DATA U(103)/5.8771575724076233D-1/, V(103)/7.8193895787070306D-2/
      DATA U(104)/5.0689990893222939D-1/, V(104)/8.3311924226946755D-2/
      DATA U(105)/4.2135127613063535D-1/, V(105)/8.7652093004403811D-2/
      DATA U(106)/3.3186860228212765D-1/, V(106)/9.1173878695763885D-2/
      DATA U(107)/2.3928736225213707D-1/, V(107)/9.3844399080804566D-2/
      DATA U(108)/1.4447196158279649D-1/, V(108)/9.5638720079274859D-2/
      DATA U(109)/4.8307665687738316D-2/, V(109)/9.6540088514727801D-2/
C  N=40.
      DATA U(110)/9.9823770971055920D-1/, V(110)/4.5212770985331913D-3/
      DATA U(111)/9.9072623869945701D-1/, V(111)/1.0498284531152814D-2/
      DATA U(112)/9.7725994998377426D-1/, V(112)/1.6421058381907889D-2/
      DATA U(113)/9.5791681921379166D-1/, V(113)/2.2245849194166957D-2/
      DATA U(114)/9.3281280827867653D-1/, V(114)/2.7937006980023401D-2/
      DATA U(115)/9.0209880696887430D-1/, V(115)/3.3460195282547847D-2/
      DATA U(116)/8.6595950321225950D-1/, V(116)/3.8782167974472018D-2/
      DATA U(117)/8.2461223083331166D-1/, V(117)/4.3870908185673272D-2/
      DATA U(118)/7.7830565142651939D-1/, V(118)/4.8695807635072232D-2/
      DATA U(119)/7.2731825518992710D-1/, V(119)/5.3227846983936824D-2/
      DATA U(120)/6.7195668461417955D-1/, V(120)/5.7439769099391551D-2/
      DATA U(121)/6.1255388966798024D-1/, V(121)/6.1306242492928939D-2/
      DATA U(122)/5.4946712509512820D-1/, V(122)/6.4804013456601038D-2/
      DATA U(123)/4.8307580168617871D-1/, V(123)/6.7912045815233904D-2/
      DATA U(124)/4.1377920437160500D-1/, V(124)/7.0611647391286780D-2/
      DATA U(125)/3.4199409082575847D-1/, V(125)/7.2886582395804059D-2/
      DATA U(126)/2.6815218500725368D-1/, V(126)/7.4723169057968264D-2/
      DATA U(127)/1.9269758070137110D-1/, V(127)/7.6110361900626242D-2/
      DATA U(128)/1.1608407067525521D-1/, V(128)/7.7039818164247966D-2/
      DATA U(129)/3.8772417506050822D-2/, V(129)/7.7505947978424811D-2/
C  N=48.
      DATA U(130)/9.9877100725242612D-1/, V(130)/3.1533460523058386D-3/
      DATA U(131)/9.9353017226635076D-1/, V(131)/7.3275539012762621D-3/
      DATA U(132)/9.8412458372282686D-1/, V(132)/1.1477234579234539D-2/
      DATA U(133)/9.7059159254624725D-1/, V(133)/1.5579315722943849D-2/
      DATA U(134)/9.5298770316043086D-1/, V(134)/1.9616160457355528D-2/
      DATA U(135)/9.3138669070655433D-1/, V(135)/2.3570760839324379D-2/
      DATA U(136)/9.0587913671556967D-1/, V(136)/2.7426509708356948D-2/
      DATA U(137)/8.7657202027424789D-1/, V(137)/3.1167227832798089D-2/
      DATA U(138)/8.4358826162439353D-1/, V(138)/3.4777222564770439D-2/
      DATA U(139)/8.0706620402944263D-1/, V(139)/3.8241351065830706D-2/
      DATA U(140)/7.6715903251574034D-1/, V(140)/4.1545082943464749D-2/
      DATA U(141)/7.2403413092381465D-1/, V(141)/4.4674560856694280D-2/
      DATA U(142)/6.7787237963266391D-1/, V(142)/4.7616658492490475D-2/
      DATA U(143)/6.2886739677651362D-1/, V(143)/5.0359035553854475D-2/
      DATA U(144)/5.7722472608397270D-1/, V(144)/5.2890189485193667D-2/
      DATA U(145)/5.2316097472223303D-1/, V(145)/5.5199503699984163D-2/
      DATA U(146)/4.6690290475095840D-1/, V(146)/5.7277292100403216D-2/
      DATA U(147)/4.0868648199071673D-1/, V(147)/5.9114839698395636D-2/
      DATA U(148)/3.4875588629216074D-1/, V(148)/6.0704439165893880D-2/
      DATA U(149)/2.8736248735545558D-1/, V(149)/6.2039423159892664D-2/
      DATA U(150)/2.2476379039468906D-1/, V(150)/6.3114192286254026D-2/
      DATA U(151)/1.6122235606889172D-1/, V(151)/6.3924238584648187D-2/
      DATA U(152)/9.7004699209462699D-2/, V(152)/6.4466164435950082D-2/
      DATA U(153)/3.2380170962869362D-2/, V(153)/6.4737696812683923D-2/
C  N=64.
      DATA U(154)/9.9930504173577214D-1/, V(154)/1.7832807216964329D-3/
      DATA U(155)/9.9634011677195528D-1/, V(155)/4.1470332605624676D-3/
      DATA U(156)/9.9101337147674432D-1/, V(156)/6.5044579689783629D-3/
      DATA U(157)/9.8333625388462596D-1/, V(157)/8.8467598263639477D-3/
      DATA U(158)/9.7332682778991096D-1/, V(158)/1.1168139460131129D-2/
      DATA U(159)/9.6100879965205372D-1/, V(159)/1.3463047896718643D-2/
      DATA U(160)/9.4641137485840282D-1/, V(160)/1.5726030476024719D-2/
      DATA U(161)/9.2956917213193958D-1/, V(161)/1.7951715775697343D-2/
      DATA U(162)/9.1052213707850281D-1/, V(162)/2.0134823153530209D-2/
      DATA U(163)/8.8931544599511412D-1/, V(163)/2.2270173808383254D-2/
      DATA U(164)/8.6599939815409282D-1/, V(164)/2.4352702568710873D-2/
      DATA U(165)/8.4062929625258036D-1/, V(165)/2.6377469715054659D-2/
      DATA U(166)/8.1326531512279756D-1/, V(166)/2.8339672614259483D-2/
      DATA U(167)/7.8397235894334141D-1/, V(167)/3.0234657072402479D-2/
      DATA U(168)/7.5281990726053190D-1/, V(168)/3.2057928354851554D-2/
      DATA U(169)/7.1988185017161083D-1/, V(169)/3.3805161837141609D-2/
      DATA U(170)/6.8523631305423324D-1/, V(170)/3.5472213256882384D-2/
      DATA U(171)/6.4896547125465734D-1/, V(171)/3.7055128540240046D-2/
      DATA U(172)/6.1115535517239325D-1/, V(172)/3.8550153178615629D-2/
      DATA U(173)/5.7189564620263403D-1/, V(173)/3.9953741132720341D-2/
      DATA U(174)/5.3127946401989455D-1/, V(174)/4.1262563242623529D-2/
      DATA U(175)/4.8940314570705296D-1/, V(175)/4.2473515123653589D-2/
      DATA U(176)/4.4636601725346409D-1/, V(176)/4.3583724529323453D-2/
      DATA U(177)/4.0227015796399160D-1/, V(177)/4.4590558163756563D-2/
      DATA U(178)/3.5722015833766812D-1/, V(178)/4.5491627927418144D-2/
      DATA U(179)/3.1132287199021096D-1/, V(179)/4.6284796581314417D-2/
      DATA U(180)/2.6468716220876742D-1/, V(180)/4.6968182816210017D-2/
      DATA U(181)/2.1742364374000708D-1/, V(181)/4.7540165714830309D-2/
      DATA U(182)/1.6964442042399282D-1/, V(182)/4.7999388596458308D-2/
      DATA U(183)/1.2146281929612055D-1/, V(183)/4.8344762234802957D-2/
      DATA U(184)/7.2993121787799039D-2/, V(184)/4.8575467441503427D-2/
      DATA U(185)/2.4350292663424433D-2/, V(185)/4.8690957009139720D-2/
C  N=80.
      DATA U(186)/9.9955382265163063D-1/, V(186)/1.1449500031869415D-3/
      DATA U(187)/9.9764986439823769D-1/, V(187)/2.6635335895126817D-3/
      DATA U(188)/9.9422754096568828D-1/, V(188)/4.1803131246948952D-3/
      DATA U(189)/9.8929130249975553D-1/, V(189)/5.6909224514031986D-3/
      DATA U(190)/9.8284857273862907D-1/, V(190)/7.1929047681173128D-3/
      DATA U(191)/9.7490914058572779D-1/, V(191)/8.6839452692608584D-3/
      DATA U(192)/9.6548508904379925D-1/, V(192)/1.0161766041103065D-2/
      DATA U(193)/9.5459076634363491D-1/, V(193)/1.1624114120797827D-2/
      DATA U(194)/9.4224276130987267D-1/, V(194)/1.3068761592401339D-2/
      DATA U(195)/9.2845987717244580D-1/, V(195)/1.4493508040509076D-2/
      DATA U(196)/9.1326310257175765D-1/, V(196)/1.5896183583725688D-2/
      DATA U(197)/8.9667557943877068D-1/, V(197)/1.7274652056269306D-2/
      DATA U(198)/8.7872256767821383D-1/, V(198)/1.8626814208299031D-2/
      DATA U(199)/8.5943140666311110D-1/, V(199)/1.9950610878141999D-2/
      DATA U(200)/8.3883147358025528D-1/, V(200)/2.1244026115782006D-2/
      DATA U(201)/8.1695413868146347D-1/, V(201)/2.2505090246332462D-2/
      DATA U(202)/7.9383271750460545D-1/, V(202)/2.3731882865930101D-2/
      DATA U(203)/7.6950242013504137D-1/, V(203)/2.4922535764115491D-2/
      DATA U(204)/7.4400029758359727D-1/, V(204)/2.6075235767565118D-2/
      DATA U(205)/7.1736518536209988D-1/, V(205)/2.7188227500486381D-2/
      DATA U(206)/6.8963764434202760D-1/, V(206)/2.8259816057276862D-2/
      DATA U(207)/6.6085989898611980D-1/, V(207)/2.9288369583267848D-2/
      DATA U(208)/6.3107577304687197D-1/, V(208)/3.0272321759557981D-2/
      DATA U(209)/6.0033062282975174D-1/, V(209)/3.1210174188114702D-2/
      DATA U(210)/5.6867126812270978D-1/, V(210)/3.2100498673487773D-2/
      DATA U(211)/5.3614592089713193D-1/, V(211)/3.2941939397645401D-2/
      DATA U(212)/5.0280411188878499D-1/, V(212)/3.3733214984611523D-2/
      DATA U(213)/4.6869661517054448D-1/, V(213)/3.4473120451753929D-2/
      DATA U(214)/4.3387537083175609D-1/, V(214)/3.5160529044747593D-2/
      DATA U(215)/3.9839340588196923D-1/, V(215)/3.5794393953416055D-2/
      DATA U(216)/3.6230475349948732D-1/, V(216)/3.6373749905835978D-2/
      DATA U(217)/3.2566437074770191D-1/, V(217)/3.6897714638276009D-2/
      DATA U(218)/2.8852805488451185D-1/, V(218)/3.7365490238730490D-2/
      DATA U(219)/2.5095235839227212D-1/, V(219)/3.7776364362001397D-2/
      DATA U(220)/2.1299450285766613D-1/, V(220)/3.8129711314477638D-2/
      DATA U(221)/1.7471229183264681D-1/, V(221)/3.8424993006959423D-2/
      DATA U(222)/1.3616402280914389D-1/, V(222)/3.8661759774076463D-2/
      DATA U(223)/9.7408398441584599D-2/, V(223)/3.8839651059051969D-2/
      DATA U(224)/5.8504437152420669D-2/, V(224)/3.8958395962769531D-2/
      DATA U(225)/1.9511383256793998D-2/, V(225)/3.9017813656306655D-2/
C  N=96.
      DATA U(226)/9.9968950388323077D-1/, V(226)/7.9679206555201243D-4/
      DATA U(227)/9.9836437586318168D-1/, V(227)/1.8539607889469217D-3/
      DATA U(228)/9.9598184298720929D-1/, V(228)/2.9107318179349464D-3/
      DATA U(229)/9.9254390032376262D-1/, V(229)/3.9645543384446867D-3/
      DATA U(230)/9.8805412632962380D-1/, V(230)/5.0142027429275177D-3/
      DATA U(231)/9.8251726356301468D-1/, V(231)/6.0585455042359617D-3/
      DATA U(232)/9.7593917458513647D-1/, V(232)/7.0964707911538653D-3/
      DATA U(233)/9.6832682846326421D-1/, V(233)/8.1268769256987592D-3/
      DATA U(234)/9.5968829144874254D-1/, V(234)/9.1486712307833866D-3/
      DATA U(235)/9.5003271778443764D-1/, V(235)/1.0160770535008416D-2/
      DATA U(236)/9.3937033975275522D-1/, V(236)/1.1162102099838499D-2/
      DATA U(237)/9.2771245672230869D-1/, V(237)/1.2151604671088320D-2/
      DATA U(238)/9.1507142312089807D-1/, V(238)/1.3128229566961573D-2/
      DATA U(239)/9.0146063531585234D-1/, V(239)/1.4090941772314861D-2/
      DATA U(240)/8.8689451740242042D-1/, V(240)/1.5038721026994938D-2/
      DATA U(241)/8.7138850590929650D-1/, V(241)/1.5970562902562291D-2/
      DATA U(242)/8.5495903343460146D-1/, V(242)/1.6885479864245172D-2/
      DATA U(243)/8.3762351122818712D-1/, V(243)/1.7782502316045261D-2/
      DATA U(244)/8.1940031073793168D-1/, V(244)/1.8660679627411467D-2/
      DATA U(245)/8.0030874413914082D-1/, V(245)/1.9519081140145022D-2/
      DATA U(246)/7.8036904386743322D-1/, V(246)/2.0356797154333325D-2/
      DATA U(247)/7.5960234117664750D-1/, V(247)/2.1172939892191299D-2/
      DATA U(248)/7.3803064374440013D-1/, V(248)/2.1966644438744349D-2/
      DATA U(249)/7.1567681234896763D-1/, V(249)/2.2737069658329374D-2/
      DATA U(250)/6.9256453664217156D-1/, V(250)/2.3483399085926220D-2/
      DATA U(251)/6.6871831004391615D-1/, V(251)/2.4204841792364691D-2/
      DATA U(252)/6.4416340378496712D-1/, V(252)/2.4900633222483610D-2/
      DATA U(253)/6.1892584012546857D-1/, V(253)/2.5570036005349361D-2/
      DATA U(254)/5.9303236477757208D-1/, V(254)/2.6212340735672414D-2/
      DATA U(255)/5.6651041856139717D-1/, V(255)/2.6826866725591762D-2/
      DATA U(256)/5.3938810832435744D-1/, V(256)/2.7412962726029243D-2/
      DATA U(257)/5.1169417715466767D-1/, V(257)/2.7970007616848334D-2/
      DATA U(258)/4.8345797392059636D-1/, V(258)/2.8497411065085386D-2/
      DATA U(259)/4.5470942216774301D-1/, V(259)/2.8994614150555237D-2/
      DATA U(260)/4.2547898840730055D-1/, V(260)/2.9461089958167906D-2/
      DATA U(261)/3.9579764982890860D-1/, V(261)/2.9896344136328386D-2/
      DATA U(262)/3.6569686147231364D-1/, V(262)/3.0299915420827594D-2/
      DATA U(263)/3.3520852289262542D-1/, V(263)/3.0671376123669149D-2/
      DATA U(264)/3.0436494435449635D-1/, V(264)/3.1010332586313837D-2/
      DATA U(265)/2.7319881259104914D-1/, V(265)/3.1316425596861356D-2/
      DATA U(266)/2.4174315616384001D-1/, V(266)/3.1589330770727167D-2/
      DATA U(267)/2.1003131046056720D-1/, V(267)/3.1828758894411006D-2/
      DATA U(268)/1.7809688236761860D-1/, V(268)/3.2034456231992663D-2/
      DATA U(269)/1.4597371465489694D-1/, V(269)/3.2206204794030251D-2/
      DATA U(270)/1.1369585011066592D-1/, V(270)/3.2343822568575928D-2/
      DATA U(271)/8.1297495464425559D-2/, V(271)/3.2447163714064269D-2/
      DATA U(272)/4.8812985136049731D-2/, V(272)/3.2516118713868836D-2/
      DATA U(273)/1.6276744849602970D-2/, V(273)/3.2550614492363166D-2/
C-----------------------------------------------------------------------

      IF ( KTBA( MIN( MAX(1,N), 97 ) ) .EQ. 0 ) THEN
        X(1) = 0.D0
        WRITE(*,101) N
 101    FORMAT(' DGQUAD: ERROR  N = ',I5,' IS NON-PERMISSIBLE')
        RETURN
      ENDIF
      ALFA = HF * (B + A)
      BETA = HF * (B - A)
      IF ( MODE .EQ. 1 ) THEN
        SUM = 0.D0
        J1 = MOD(N,2)
        J2 = KTBA(N) + (N-1)/2
        DO  J = KTBA(N), J2-J1
          DELTA = BETA * U(J)
          SUM   = SUM + V(J) * ( F(ALFA+DELTA) + F(ALFA-DELTA) )
        ENDDO
        IF ( J1 .EQ. 1 ) SUM = SUM + V(J2) * F(ALFA)
        X(1) = BETA * SUM
      ELSE
        J1 = KTBA(N) - 1
        J2 = N + 1
        DO  J = 1, J2/2
          WTEMP   = BETA * V(J1+J)
          DELTA   = BETA * U(J1+J)
          X(J)    = ALFA - DELTA
          W(J)    = WTEMP
          X(J2-J) = ALFA + DELTA
          W(J2-J) = WTEMP
        ENDDO
      ENDIF

      RETURN
      END


*-- Author :    S. Ostapchenko IK FZK Karlsruhe    19/09/2003
C=======================================================================

      DOUBLE PRECISION FUNCTION DISTAND( H,RADT )

C-----------------------------------------------------------------------
C  (SLANT) DISTAN(CE TO OBSERVATION LEVEL AT HEIGHT)
C
C  CALCULATES THE SLANT DISTANCE TO OBSERVATION LEVEL (RSP. IMPACT
C  POINT)(IN CM) ALONG A PATH WITH IMPACT RADIUS RADT AT HEIGHT H.
C  THIS FUNCTION IS CALLED FROM DL2DT.
C  ARGUMENTS:
C   H       = HEIGHT ABOVE SEA LEVEL (CM)
C   RADT    = IMPACT RADIUS (CM)
C-----------------------------------------------------------------------

      IMPLICIT NONE




# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"











      COMMON /CRATMOSL/PATH1,RHOSLT,TSLANT,HLAYS,RHOS,THICKS,
     *                 CCATM,HLAYC,HGROUND,RADGRD,IENDT
      INTEGER          MAXSLANT,MAXSLANT2
      PARAMETER        (MAXSLANT2=1600, MAXSLANT=MAXSLANT2*5)
      DOUBLE PRECISION PATH1(MAXSLANT),RHOSLT(MAXSLANT),
     *                 TSLANT(MAXSLANT),HLAYS(6),RHOS(6),THICKS(6),
     *                 CCATM(5),HLAYC(6),HGROUND,RADGRD
      INTEGER          IENDT



# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"










      COMMON /CROBSPAR/OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP,
     *                 THETPR,PHIPR,

     *                 CORRXY,







     *                 NOBSLV
      DOUBLE PRECISION OBSLEV(20),THCKOB(20),XOFF(20),YOFF(20),
     *                 HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2)

     *                 ,CORRXY







      INTEGER          NOBSLV



# 4262 "corsika.h"



      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL



# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"

















# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 14174 "corsika.F" 2

      DOUBLE PRECISION H,RADT
      SAVE
C-----------------------------------------------------------------------

      IF ( RADT .GE. RADGRD ) THEN
        DISTAND = SQRT( MAX( 0.D0,C(1)-RADT+H ) ) * SQRT( C(1)+RADT+H )
      ELSE
        DISTAND = ( H**2 + 2.D0*(H-HGROUND)*C(1) - HGROUND**2 )
     *        / ( SQRT( MAX( 0.D0,C(1)-RADT+H ) ) * SQRT( C(1)+RADT+H )
     *        + SQRT( MAX( 0.D0,RADGRD-RADT ) ) * SQRT( RADGRD+RADT ) )
      ENDIF

      RETURN
      END


*-- Author :    D. HECK IK FZK KARLSRUHE   26/06/2003
C=======================================================================

      DOUBLE PRECISION FUNCTION DKOKOE( Y )

C-----------------------------------------------------------------------
C  D(OUBLE PRECISION) KOKO(ULIN INTEGRATION FOR) E(NERGY LOSS)
C
C  SEE: S. BOTTAI AND L. PERRONE, NUCL. INST. METH. A459 (2001) 319
C     R.P. KOKOULIN AND A.A. PETRUKHIN, PROC. 12TH ICRC, 6 (1971) A2436
C  TO BE USED FOR ENERGY LOSS CALCULATION OF MUON/TAU PAIR PRODUCTION.
C  THIS FUNCTION IS CALLED FROM DADMUL (CALLED FROM DPRELM).
C  ARGUMENTS: (TO BE USED BY DADMUL)
C   Y      = DUMMY ARRAY OF DIMENSION N
C-----------------------------------------------------------------------

      IMPLICIT NONE




# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"











      COMMON /CRCONSTA/PI,PI2,OB3,TB3,ENEPER,SQRT3
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER,SQRT3












































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"


















      COMMON /CRMUPART/AATOM,AMUPAR,BCUT,CMUON,CTAU,CONSTKINE,
     *                 EBYMU,EBYTAU,EE,SE,VFRAC,VMAX,VMIN,ZATOM,
     *                 MT,FMUBRM,FMUNUC,FMUORG






      DOUBLE PRECISION AMUPAR(0:18),BCUT,CMUON(11),CTAU(11),


     *                 AATOM,CONSTKINE,EBYMU,EBYTAU,EE,SE,
     *                 VFRAC,VMAX,VMIN,ZATOM
      INTEGER          MT
      LOGICAL          FMUBRM,FMUNUC,FMUORG



# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"








      COMMON /CRPAM/   PAMA,SIGNUM,RESTMS,DECTIM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000),
     *                 DECTIM(200)




# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"

















# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 14212 "corsika.F" 2

      DOUBLE PRECISION Y(2)
      DOUBLE PRECISION ROMAX,ROMIN
      INTEGER          NPNTS
      DOUBLE PRECISION DGQUAD,PPCE
      EXTERNAL         DGQUAD,PPCE
      SAVE
      DATA             ROMIN /0.D0/, NPNTS / 64 /
C-----------------------------------------------------------------------

      VFRAC = 10.D0**Y(2)
C  INITIALIZATION FOR GAUSS INTEGRATION
      IF ( MT .EQ. 1 ) THEN
C  MUON
        ROMAX = SQRT( 1.D0 - 4.D0*PAMA(2)/(EE*VFRAC) )
     *           * ( 1.D0 - 6.D0*PAMA(5)**2/( (1.D0-VFRAC)*EE**2 ) )
      ELSE
C  TAU LEPTON
        ROMAX = SQRT( 1.D0 - 4.D0*PAMA(2)/(EE*VFRAC) )
     *           * ( 1.D0 - 6.D0*PAMA(131)**2/( (1.D0-VFRAC)*EE**2 ) )
      ENDIF
C  INTEGRATION WITH N-POINT GAUSSIAN QUADRATURE
      DKOKOE = LOG( 10.D0 ) * VFRAC * DGQUAD( PPCE,ROMIN,ROMAX,NPNTS )
C  NORMALIZATION IS MADE IN DPRELM
      IF ( DKOKOE .LT. 0.D0 ) DKOKOE = 0.D0

      RETURN
      END

*-- Author :    R.P. Kokoulin, A.G. Bogdanov MEPhi, Moscow 30/03/2007
C=======================================================================

      DOUBLE PRECISION FUNCTION DKOKOI()

C-----------------------------------------------------------------------
C  D(OUBLE PRECISION) KOKO(ULIN) I(NTEGRATION)
C
C  FUNCTION FOR INTEGRATION OF PAIR PRODUCTION CROSS SECTION WITH
C  RESPECT TO ENERGY ASYMMETRY PARAMETER RO.
C  SEE: S. BOTTAI AND L. PERRONE, NUCL. INST. METH. A459 (2001) 319
C     R.P. KOKOULIN AND A.A. PETRUKHIN, PROC. 12TH ICRC, 6 (1971) A2436
C  SUBSTITUTION T = LOG(1 - R) IS USED FOR INTEGRATION
C  SEE ALSO GEANT4 PHYS. REF. MANUAL R. KOKOULIN   (1998)
C  TO BE USED FOR SAMPLING OF MUON/TAU PAIR PRODUCTION.
C  THIS FUNCTION IS CALLED FROM MUPRPR.
C-----------------------------------------------------------------------

      IMPLICIT NONE




# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"











      COMMON /CRCONSTA/PI,PI2,OB3,TB3,ENEPER,SQRT3
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER,SQRT3












































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"


















      COMMON /CRMUPART/AATOM,AMUPAR,BCUT,CMUON,CTAU,CONSTKINE,
     *                 EBYMU,EBYTAU,EE,SE,VFRAC,VMAX,VMIN,ZATOM,
     *                 MT,FMUBRM,FMUNUC,FMUORG






      DOUBLE PRECISION AMUPAR(0:18),BCUT,CMUON(11),CTAU(11),


     *                 AATOM,CONSTKINE,EBYMU,EBYTAU,EE,SE,
     *                 VFRAC,VMAX,VMIN,ZATOM
      INTEGER          MT
      LOGICAL          FMUBRM,FMUNUC,FMUORG



# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"








      COMMON /CRPAM/   PAMA,SIGNUM,RESTMS,DECTIM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000),
     *                 DECTIM(200)




# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"

















# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 14264 "corsika.F" 2

      DOUBLE PRECISION ALPHFA,RE
      PARAMETER        (ALPHFA = 7.297353D-3)
      PARAMETER        (RE     = 3.8615932335D-11) !ELECTRON RADIUS (CM)

      DOUBLE PRECISION A1,A2,A3,TMAX,TMIN
      INTEGER          NPNTS
      DOUBLE PRECISION DGQUAD,PPCSL
      EXTERNAL         DGQUAD,PPCSL
      SAVE
      DATA             TMAX /0.D0/, NPNTS / 8 /
C-----------------------------------------------------------------------

C  EE IS THE TOTAL ENERGY OF INCOMING MUON

C  INITIALIZATION FOR GAUSS INTEGRATION
      A1 = 4.D0*PAMA(2)/(EE*VFRAC)
      IF ( A1 .GE. 1.D0 ) THEN
        DKOKOI = 0.D0
        RETURN
      ENDIF
      A2 = SQRT( 1.D0 - A1 )
C  MUON
      IF ( MT .EQ. 1 ) THEN
        A3 = 6.D0*PAMA(5)**2/( (1.D0-VFRAC) * EE**2 )
      ELSE
C  TAU LEPTON
        A3 = 6.D0*PAMA(131)**2/( (1.D0-VFRAC) * EE**2 )
      ENDIF
      TMIN   = LOG( A1/(1.D0+A2) + A3*A2 )
C  INTEGRATION WITH N-POINT GAUSSIAN QUADRATURE
      DKOKOI =  2.D0 * DGQUAD( PPCSL,TMIN,TMAX,NPNTS )
C  NORMALIZATION
      DKOKOI = DKOKOI * ALPHFA**4 * (TB3/PI)
     *                * ZATOM * (ZATOM+1.D0) * RE**2

      RETURN
      END

*-- Author :    D. HECK IK FZK KARLSRUHE   14/05/2003
C=======================================================================

      DOUBLE PRECISION FUNCTION DKOKOS( Y )

C-----------------------------------------------------------------------
C  D(OUBLE PRECISION) KOKO(ULIN INTEGRATION FOR) S(IGMA)
C
C  SEE: S. BOTTAI AND L. PERRONE, NUCL. INST. METH. A459 (2001) 319
C     R.P. KOKOULIN AND A.A. PETRUKHIN, PROC. 12TH ICRC, 6 (1971) A2436
C  TO BE USED FOR CROSS SECTION CALCULATION OF MUON PAIR PRODUCTION.
C  THIS FUNCTION IS CALLED FROM DADMUL (CALLED FROM DPRSGM).
C  ARGUMENTS: (TO BE USED BY DADMUL)
C   Y      = DUMMY ARRAY OF DIMENSION N
C-----------------------------------------------------------------------

      IMPLICIT NONE




# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"











      COMMON /CRCONSTA/PI,PI2,OB3,TB3,ENEPER,SQRT3
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER,SQRT3












































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"


















      COMMON /CRMUPART/AATOM,AMUPAR,BCUT,CMUON,CTAU,CONSTKINE,
     *                 EBYMU,EBYTAU,EE,SE,VFRAC,VMAX,VMIN,ZATOM,
     *                 MT,FMUBRM,FMUNUC,FMUORG






      DOUBLE PRECISION AMUPAR(0:18),BCUT,CMUON(11),CTAU(11),


     *                 AATOM,CONSTKINE,EBYMU,EBYTAU,EE,SE,
     *                 VFRAC,VMAX,VMIN,ZATOM
      INTEGER          MT
      LOGICAL          FMUBRM,FMUNUC,FMUORG



# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"








      COMMON /CRPAM/   PAMA,SIGNUM,RESTMS,DECTIM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000),
     *                 DECTIM(200)




# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"

















# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 14324 "corsika.F" 2

      DOUBLE PRECISION Y(2)
      DOUBLE PRECISION ROMAX,ROMIN
      INTEGER          NPNTS
      DOUBLE PRECISION DGQUAD,PPCS
      EXTERNAL         DGQUAD,PPCS
      SAVE
      DATA             ROMIN /0.D0/, NPNTS / 64 /
C-----------------------------------------------------------------------

      VFRAC = 10.D0**(Y(2))

C  INITIALIZATION FOR GAUSS INTEGRATION
      IF ( MT .EQ. 1 ) THEN
C  MUON
        ROMAX = SQRT( 1.D0 - 4.D0*PAMA(2)/(EE*VFRAC) )
     *           * ( 1.D0 - 6.D0*PAMA(5)**2/( (1.D0-VFRAC)*EE**2 ) )
      ELSE
        ROMAX = SQRT( 1.D0 - 4.D0*PAMA(2)/(EE*VFRAC) )
     *           * ( 1.D0 - 6.D0*PAMA(131)**2/( (1.D0-VFRAC)*EE**2 ) )
      ENDIF
C  TAU LEPTON
C  INTEGRATION WITH N-POINT GAUSSIAN QUADRATURE
      DKOKOS = LOG( 10.D0 ) * VFRAC * DGQUAD( PPCS,ROMIN,ROMAX,NPNTS )
C  NORMALIZATION IS MADE IN DPRSGM
      IF ( DKOKOS .LT. 0.D0 ) DKOKOS = 0.D0

      RETURN
      END


*-- Author :    V. Chernatkin Univ. Nantes    00/00/2003
C=======================================================================

      SUBROUTINE DL2DT( DL,DT,H1,H2,D1,D2,A )

C-----------------------------------------------------------------------
C  CONVERTS A SLANT DISTANCE INTERVAL INTO A SLANT DEPTH INTERVAL.
C  WORKS ONLY IN THE EXPONENTIAL LAYERS OF ATMOSPHERE.
C  THIS SUBROUTINE IS CALLED FROM COOINC.
C  ARGUMENTS:
C   DL      = SLANT DISTANCE INTERVAL (CM) (INPUT)
C             (UPDATED IF BORDER REACHED)
C             (>0 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






# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"



      COMMON /CRATMOS2/HLAY,HLAY0,THICKL,LAYNO,LAYNEW
      DOUBLE PRECISION HLAY(6),HLAY0(5,0:28),THICKL(5)
      INTEGER          LAYNO(0:41)
      LOGICAL          LAYNEW













      COMMON /CRATMOSL/PATH1,RHOSLT,TSLANT,HLAYS,RHOS,THICKS,
     *                 CCATM,HLAYC,HGROUND,RADGRD,IENDT
      INTEGER          MAXSLANT,MAXSLANT2
      PARAMETER        (MAXSLANT2=1600, MAXSLANT=MAXSLANT2*5)
      DOUBLE PRECISION PATH1(MAXSLANT),RHOSLT(MAXSLANT),
     *                 TSLANT(MAXSLANT),HLAYS(6),RHOS(6),THICKS(6),
     *                 CCATM(5),HLAYC(6),HGROUND,RADGRD
      INTEGER          IENDT



# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"










      COMMON /CROBSPAR/OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP,
     *                 THETPR,PHIPR,

     *                 CORRXY,







     *                 NOBSLV
      DOUBLE PRECISION OBSLEV(20),THCKOB(20),XOFF(20),YOFF(20),
     *                 HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2)

     *                 ,CORRXY







      INTEGER          NOBSLV



# 4262 "corsika.h"



      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL



# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 14385 "corsika.F" 2


      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


*-- 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






# 1 "corsika.h" 1
# 3562 "corsika.h"



      COMMON /CRAIR/   COMPOS,PROBTA,AVERAW,AVOGDR
      DOUBLE PRECISION COMPOS(3),PROBTA(3),AVERAW,AVOGDR



# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"





































































      COMMON /CRELABCT/ELCUT
      DOUBLE PRECISION ELCUT(4)


















# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"


















      COMMON /CRMUPART/AATOM,AMUPAR,BCUT,CMUON,CTAU,CONSTKINE,
     *                 EBYMU,EBYTAU,EE,SE,VFRAC,VMAX,VMIN,ZATOM,
     *                 MT,FMUBRM,FMUNUC,FMUORG






      DOUBLE PRECISION AMUPAR(0:18),BCUT,CMUON(11),CTAU(11),


     *                 AATOM,CONSTKINE,EBYMU,EBYTAU,EE,SE,
     *                 VFRAC,VMAX,VMIN,ZATOM
      INTEGER          MT
      LOGICAL          FMUBRM,FMUNUC,FMUORG



# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"








      COMMON /CRPAM/   PAMA,SIGNUM,RESTMS,DECTIM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000),
     *                 DECTIM(200)




# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 14507 "corsika.F" 2

      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 1
      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





# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"











      COMMON /CRCONSTA/PI,PI2,OB3,TB3,ENEPER,SQRT3
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER,SQRT3
























































      COMMON /CRELABCT/ELCUT
      DOUBLE PRECISION ELCUT(4)


















# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"


















      COMMON /CRMUPART/AATOM,AMUPAR,BCUT,CMUON,CTAU,CONSTKINE,
     *                 EBYMU,EBYTAU,EE,SE,VFRAC,VMAX,VMIN,ZATOM,
     *                 MT,FMUBRM,FMUNUC,FMUORG






      DOUBLE PRECISION AMUPAR(0:18),BCUT,CMUON(11),CTAU(11),


     *                 AATOM,CONSTKINE,EBYMU,EBYTAU,EE,SE,
     *                 VFRAC,VMAX,VMIN,ZATOM
      INTEGER          MT
      LOGICAL          FMUBRM,FMUNUC,FMUORG



# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"








      COMMON /CRPAM/   PAMA,SIGNUM,RESTMS,DECTIM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000),
     *                 DECTIM(200)




# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"

















# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 14584 "corsika.F" 2

      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 1
      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






# 1 "corsika.h" 1
# 3562 "corsika.h"



      COMMON /CRAIR/   COMPOS,PROBTA,AVERAW,AVOGDR
      DOUBLE PRECISION COMPOS(3),PROBTA(3),AVERAW,AVOGDR



# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"











      COMMON /CRCONSTA/PI,PI2,OB3,TB3,ENEPER,SQRT3
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER,SQRT3












































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"


















      COMMON /CRMUPART/AATOM,AMUPAR,BCUT,CMUON,CTAU,CONSTKINE,
     *                 EBYMU,EBYTAU,EE,SE,VFRAC,VMAX,VMIN,ZATOM,
     *                 MT,FMUBRM,FMUNUC,FMUORG






      DOUBLE PRECISION AMUPAR(0:18),BCUT,CMUON(11),CTAU(11),


     *                 AATOM,CONSTKINE,EBYMU,EBYTAU,EE,SE,
     *                 VFRAC,VMAX,VMIN,ZATOM
      INTEGER          MT
      LOGICAL          FMUBRM,FMUNUC,FMUORG



# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"








      COMMON /CRPAM/   PAMA,SIGNUM,RESTMS,DECTIM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000),
     *                 DECTIM(200)




# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 14663 "corsika.F" 2

      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 1
      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





# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"











      COMMON /CRCONSTA/PI,PI2,OB3,TB3,ENEPER,SQRT3
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER,SQRT3












































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"


















      COMMON /CRMUPART/AATOM,AMUPAR,BCUT,CMUON,CTAU,CONSTKINE,
     *                 EBYMU,EBYTAU,EE,SE,VFRAC,VMAX,VMIN,ZATOM,
     *                 MT,FMUBRM,FMUNUC,FMUORG






      DOUBLE PRECISION AMUPAR(0:18),BCUT,CMUON(11),CTAU(11),


     *                 AATOM,CONSTKINE,EBYMU,EBYTAU,EE,SE,
     *                 VFRAC,VMAX,VMIN,ZATOM
      INTEGER          MT
      LOGICAL          FMUBRM,FMUNUC,FMUORG



# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"








      COMMON /CRPAM/   PAMA,SIGNUM,RESTMS,DECTIM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000),
     *                 DECTIM(200)




# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 14739 "corsika.F" 2

      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 1
      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


# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 14820 "corsika.F" 2

      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


# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 14924 "corsika.F" 2

      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


# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 15007 "corsika.F" 2

      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


# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 15090 "corsika.F" 2

      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


# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 15179 "corsika.F" 2

      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


# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 15263 "corsika.F" 2

      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


*-- 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






# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"



      COMMON /CRATMOS2/HLAY,HLAY0,THICKL,LAYNO,LAYNEW
      DOUBLE PRECISION HLAY(6),HLAY0(5,0:28),THICKL(5)
      INTEGER          LAYNO(0:41)
      LOGICAL          LAYNEW













      COMMON /CRATMOSL/PATH1,RHOSLT,TSLANT,HLAYS,RHOS,THICKS,
     *                 CCATM,HLAYC,HGROUND,RADGRD,IENDT
      INTEGER          MAXSLANT,MAXSLANT2
      PARAMETER        (MAXSLANT2=1600, MAXSLANT=MAXSLANT2*5)
      DOUBLE PRECISION PATH1(MAXSLANT),RHOSLT(MAXSLANT),
     *                 TSLANT(MAXSLANT),HLAYS(6),RHOS(6),THICKS(6),
     *                 CCATM(5),HLAYC(6),HGROUND,RADGRD
      INTEGER          IENDT



# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"










      COMMON /CROBSPAR/OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP,
     *                 THETPR,PHIPR,

     *                 CORRXY,







     *                 NOBSLV
      DOUBLE PRECISION OBSLEV(20),THCKOB(20),XOFF(20),YOFF(20),
     *                 HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2)

     *                 ,CORRXY







      INTEGER          NOBSLV



# 4262 "corsika.h"



      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL



# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 15351 "corsika.F" 2

      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


*-- 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
# 15487 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























































































# 3811 "corsika.h"

# 3824 "corsika.h"










      COMMON /CRGENER/ GEN,ALEVEL
      DOUBLE PRECISION GEN,ALEVEL











# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"
























      INTEGER          LNGMAX
      PARAMETER        (LNGMAX = 15000)
      INTEGER          TYPE1
      PARAMETER        (TYPE1 = 0)
      INTEGER          TYPE2
      PARAMETER        (TYPE2 = 1)
      INTEGER          TYPE3
      PARAMETER        (TYPE3 = 2)
      INTEGER          TYPE4
      PARAMETER        (TYPE4 = 3)
      COMMON /CRLONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP



     *                ,LLONGI,FLGFIT
# 3961 "corsika.h"
      DOUBLE PRECISION ADLONG(0:LNGMAX,19),AELONG(0:LNGMAX,10),
     *                 APLONG(0:LNGMAX,10),DLONG(0:LNGMAX,19),
     *                 ELONG(0:LNGMAX,10),
     *                 HLONG(0:LNGMAX),PLONG(0:LNGMAX,10),
     *                 SDLONG(0:LNGMAX,19),SELONG(0:LNGMAX,10),
     *                 SPLONG(0:LNGMAX,10),THSTEP,THSTPI




      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT

      COMMON /CRSLANT/ RLONG,THCKRL,CTH,STHCPH,STHSPH,RLOFF
      DOUBLE PRECISION RLONG(0:LNGMAX),THCKRL(0:LNGMAX),
     *                 CTH,STHCPH,STHSPH,RLOFF


















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"








      COMMON /CRPAM/   PAMA,SIGNUM,RESTMS,DECTIM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000),
     *                 DECTIM(200)






      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL





      DOUBLE PRECISION GAMMA,COSTHE,PHIX,PHIY,H,T,X,Y,CHI,BETA,GCM,ECM

     *                 ,WEIGHT


     *                 ,HAPP,COSTAP,COSTEA




      EQUIVALENCE      (CURPAR(1), GAMMA ), (CURPAR(2), COSTHE),
     *                 (CURPAR(3), PHIX  ), (CURPAR(4), PHIY  ),
     *                 (CURPAR(5), H     ), (CURPAR(6), T     ),
     *                 (CURPAR(7), X     ), (CURPAR(8), Y     ),
     *                 (CURPAR(9), CHI   ), (CURPAR(10),BETA  ),
     *                 (CURPAR(11),GCM   ), (CURPAR(12),ECM   )

     *                ,(CURPAR(13),WEIGHT)


     *                ,(CURPAR(14),HAPP  ), (CURPAR(15),COSTAP),
     *                 (CURPAR(16),COSTEA)















# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 15487 "corsika.F" 2

      DOUBLE PRECISION ENER,THICK
      INTEGER          I





      INTEGER          LBIN
      EXTERNAL         LBIN

      SAVE
      EXTERNAL         THICK
C-----------------------------------------------------------------------


      IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=0,9),WEIGHT
  444 FORMAT(' EM    : CURPAR=',1P,11E11.3)
# 15515 "corsika.F"

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

      SECPAR(13) = WEIGHT


      SECPAR(14) = CURPAR(14)
      SECPAR(15) = CURPAR(15)
      SECPAR(16) = CURPAR(16)
# 15561 "corsika.F"

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


          LHEIGH = MIN( LBIN( X,Y,HAPP,1 ), NSTEP+1 )






          IF     ( SECPAR(0) .EQ. 1.D0 ) THEN

            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







          ENDIF
        ENDIF
# 15623 "corsika.F"
      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  UPDATED INCLUDING RARE DECAY ETA ---> MU(+) + MU(-) 
C-----------------------------------------------------------------------

      IMPLICIT NONE
# 15659 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"











      COMMON /CRCONSTA/PI,PI2,OB3,TB3,ENEPER,SQRT3
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER,SQRT3




















      COMMON /CRDECAYC/GAM345,COS345,PHI345
      DOUBLE PRECISION GAM345(3),COS345(3),PHI345(3)



















      COMMON /CREDECAY/CETA
      DOUBLE PRECISION CETA(5)

































# 3811 "corsika.h"

# 3824 "corsika.h"










      COMMON /CRGENER/ GEN,ALEVEL
      DOUBLE PRECISION GEN,ALEVEL











# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"
























      INTEGER          LNGMAX
      PARAMETER        (LNGMAX = 15000)
      INTEGER          TYPE1
      PARAMETER        (TYPE1 = 0)
      INTEGER          TYPE2
      PARAMETER        (TYPE2 = 1)
      INTEGER          TYPE3
      PARAMETER        (TYPE3 = 2)
      INTEGER          TYPE4
      PARAMETER        (TYPE4 = 3)
      COMMON /CRLONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP



     *                ,LLONGI,FLGFIT
# 3961 "corsika.h"
      DOUBLE PRECISION ADLONG(0:LNGMAX,19),AELONG(0:LNGMAX,10),
     *                 APLONG(0:LNGMAX,10),DLONG(0:LNGMAX,19),
     *                 ELONG(0:LNGMAX,10),
     *                 HLONG(0:LNGMAX),PLONG(0:LNGMAX,10),
     *                 SDLONG(0:LNGMAX,19),SELONG(0:LNGMAX,10),
     *                 SPLONG(0:LNGMAX,10),THSTEP,THSTPI




      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT

      COMMON /CRSLANT/ RLONG,THCKRL,CTH,STHCPH,STHSPH,RLOFF
      DOUBLE PRECISION RLONG(0:LNGMAX),THCKRL(0:LNGMAX),
     *                 CTH,STHCPH,STHSPH,RLOFF


















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"








      COMMON /CRPAM/   PAMA,SIGNUM,RESTMS,DECTIM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000),
     *                 DECTIM(200)






      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL





      DOUBLE PRECISION GAMMA,COSTHE,PHIX,PHIY,H,T,X,Y,CHI,BETA,GCM,ECM

     *                 ,WEIGHT


     *                 ,HAPP,COSTAP,COSTEA




      EQUIVALENCE      (CURPAR(1), GAMMA ), (CURPAR(2), COSTHE),
     *                 (CURPAR(3), PHIX  ), (CURPAR(4), PHIY  ),
     *                 (CURPAR(5), H     ), (CURPAR(6), T     ),
     *                 (CURPAR(7), X     ), (CURPAR(8), Y     ),
     *                 (CURPAR(9), CHI   ), (CURPAR(10),BETA  ),
     *                 (CURPAR(11),GCM   ), (CURPAR(12),ECM   )

     *                ,(CURPAR(13),WEIGHT)


     *                ,(CURPAR(14),HAPP  ), (CURPAR(15),COSTAP),
     *                 (CURPAR(16),COSTEA)















# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"



      COMMON /CRPOLAR/ POLART,POLARF
      DOUBLE PRECISION POLART,POLARF




















      COMMON /CRRANDPA/RD,FAC,U1,U2,NSEQ,ISEED,KNOR
      DOUBLE PRECISION RD(3000),FAC,U1,U2



      INTEGER          ISEED(3,10),NSEQ

      LOGICAL          KNOR



# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 15659 "corsika.F" 2

      DOUBLE PRECISION AUX1,AUX2,COSTH1,COSTH2,EETA2,FAC1,FAC2,FI1
      INTEGER          I





      SAVE
C-----------------------------------------------------------------------


      IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=0,9),WEIGHT
  444 FORMAT(' ETADEC: CURPAR=',1P,11E11.3)





C  SELECT MODE OF DECAY, IF NOT ALREADY SELECTED BY THE PARTICLE TYPE
C  NEW VALUES (2017) DERIVED FROM PARTICLE DATA GROUP VALUES
      IF ( ITYPE .EQ. 17 ) THEN
        CALL RMMARD( RD,1,1 )
        IF     ( RD(1) .LE. 0.3970317D0 ) THEN
          ITYPE = 71      !eta ----> gamma + gamma
        ELSEIF ( RD(1) .LE. 0.7262628D0 ) THEN
          ITYPE = 72      !eta ----> pi(0) + pi(0) + pi(0)
        ELSEIF ( RD(1) .LE. 0.9571678D0 ) THEN
          ITYPE = 73      !eta ----> pi(+) * pi(-) + pi(0)
        ELSEIF ( RD(1) .LE. 0.9996817D0 ) THEN
          ITYPE = 74      !eta ----> pi(+) + pi(-) + gamma
        ELSEIF ( RD(1) .LE. 0.9999940D0 ) THEN
          GOTO 201        ! RARE DECAY eta ----> mu(+) + mu(-) + gamma
        ELSE
          GOTO 202        ! RARE DECAY eta ----> mu(+) + mu(-)
        ENDIF
      ENDIF

C  DECAY OF ETA  WITH 6 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 ( SECPAR(2) .GE. C(29) ) THEN







          CALL TSTACK
        ELSE
          IF ( LLONGI ) THEN
C  ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT

            DLONG(LHEIGH,11) = DLONG(LHEIGH,11) + SECPAR(1) * WEIGHT



          ENDIF
# 15760 "corsika.F"
        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 ( SECPAR(2) .GE. C(29) ) THEN







          CALL TSTACK
        ELSE
          IF ( LLONGI ) THEN
C  ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT

            DLONG(LHEIGH,11) = DLONG(LHEIGH,11) + SECPAR(1) * WEIGHT



          ENDIF
# 15811 "corsika.F"
        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 ( SECPAR(2) .GE. C(29) ) THEN



            SECPAR(1) = GAM345(I)




            CALL TSTACK
          ELSE
            IF ( LLONGI ) THEN
C  ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT

              DLONG(LHEIGH,17) = DLONG(LHEIGH,17)
     *                               + GAM345(I)*PAMA(7) * WEIGHT



            ENDIF
# 15870 "corsika.F"
          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 ( SECPAR(2) .GE. C(29) ) THEN



            SECPAR(0) = 10 - I
            SECPAR(1) = GAM345(I)




            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

              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






            ENDIF
# 15942 "corsika.F"
          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 ( SECPAR(2) .GE. C(29) ) THEN



            IF ( I .EQ. 3 ) THEN
              SECPAR(0) = 1.D0
            ELSE
              SECPAR(0) = 7 + I
            ENDIF
            SECPAR(1)   = GAM345(I)
# 15973 "corsika.F"
            CALL TSTACK
          ELSE
            IF ( LLONGI ) THEN
C  ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT
              IF ( I .EQ. 3 ) THEN

                DLONG(LHEIGH,11) = DLONG(LHEIGH,11) + GAM345(I)*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






              ENDIF
            ENDIF
# 16031 "corsika.F"
          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
C  (UNIFORM PHASE SPACE DISTRIBUTION IS ASSUMED FOR THIS DECAY)
 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 ( SECPAR(2) .GE. C(29) ) THEN



          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
# 16081 "corsika.F"
          CALL TSTACK
        ELSE
          IF ( LLONGI ) THEN
C  ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT
            IF ( I .EQ. 3 ) THEN

              DLONG(LHEIGH,11) = DLONG(LHEIGH,11) + GAM345(I)*WEIGHT



            ELSE
C  ADD MUON ENERGY TO LONGITUDINAL ENERGY DEPOSIT

              DLONG(LHEIGH,15) = DLONG(LHEIGH,15)
     *                                 + GAM345(I)*PAMA(5)*WEIGHT



            ENDIF
          ENDIF
# 16133 "corsika.F"
        ENDIF
      ENDDO
C  RESET POLARIZATION
      SECPAR(11) = 0.D0
      SECPAR(12) = 0.D0
      RETURN

C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  RARE DECAY ETA ----> MU(+) + MU(-) 
C  DECAY ADDED IN AUG. 2017, SEE A. FEDYNITCH ET AL., arXiv: 1206.6710
C         ETA ---> MU(+) + MU(-)    (BR = 5.8E(-6))
C  THE POLARIZATION OF THE MUONS IS HANDLED IN SUBR. DECAY2

 202  CALL DECAY2( 17 )

      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-----------------------------------------------------------------------

# 16175 "corsika.F"
      IMPLICIT NONE
# 16195 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"



      COMMON /CRBUFFS/ RUNH,RUNE,EVTH,EVTE,DATAB,ARRAYLONG,LH

     *                 ,WRRUNH,WRRUNE,WREVTH,WREVTE

      INTEGER          MAXBUF,MAXLEN

      PARAMETER        (MAXBUF=39*8)
# 3681 "corsika.h"
      PARAMETER        (MAXLEN=16)
# 3693 "corsika.h"
      REAL             RUNH(MAXBUF),EVTH(MAXBUF),EVTE(MAXBUF),
     *                 RUNE(MAXBUF),DATAB(MAXBUF),ARRAYLONG(MAXBUF)
      INTEGER          LH

      LOGICAL          WRRUNH,WRRUNE,WREVTH,WREVTE

      CHARACTER*4      CRUNH,CRUNE,CEVTH,CEVTE,CLONG
      EQUIVALENCE      (RUNH(1),CRUNH), (RUNE(1),CRUNE)
      EQUIVALENCE      (EVTH(1),CEVTH), (EVTE(1),CEVTE)
      EQUIVALENCE      (ARRAYLONG(1),CLONG)



























































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"
























      INTEGER          LNGMAX
      PARAMETER        (LNGMAX = 15000)
      INTEGER          TYPE1
      PARAMETER        (TYPE1 = 0)
      INTEGER          TYPE2
      PARAMETER        (TYPE2 = 1)
      INTEGER          TYPE3
      PARAMETER        (TYPE3 = 2)
      INTEGER          TYPE4
      PARAMETER        (TYPE4 = 3)
      COMMON /CRLONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP



     *                ,LLONGI,FLGFIT
# 3961 "corsika.h"
      DOUBLE PRECISION ADLONG(0:LNGMAX,19),AELONG(0:LNGMAX,10),
     *                 APLONG(0:LNGMAX,10),DLONG(0:LNGMAX,19),
     *                 ELONG(0:LNGMAX,10),
     *                 HLONG(0:LNGMAX),PLONG(0:LNGMAX,10),
     *                 SDLONG(0:LNGMAX,19),SELONG(0:LNGMAX,10),
     *                 SPLONG(0:LNGMAX,10),THSTEP,THSTPI




      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT

      COMMON /CRSLANT/ RLONG,THCKRL,CTH,STHCPH,STHSPH,RLOFF
      DOUBLE PRECISION RLONG(0:LNGMAX),THCKRL(0:LNGMAX),
     *                 CTH,STHCPH,STHSPH,RLOFF


















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"










      COMMON /CRPRIMSP/PSLOPE,LLIMIT,ULIMIT,LL,UL,SLEX,ISPEC
      DOUBLE PRECISION PSLOPE,LLIMIT,ULIMIT,LL,UL,SLEX
      INTEGER          ISPEC










# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"



      COMMON /CRSTACKF/STACKI,



     *                 MSTACKP,MEXST,NSHIFT,NOUREC,NOURECMAX,ICOUNT,
     *                 NTO,NFROM




      INTEGER          MAXSTK
# 4796 "corsika.h"
      PARAMETER        (MAXSTK = 17*256*2)
# 4809 "corsika.h"
      DOUBLE PRECISION STACKI(MAXSTK)



      INTEGER          MSTACKP,MEXST,NSHIFT,NOUREC,NOURECMAX,ICOUNT,
     *                 NTO,NFROM
























      INTEGER          IEBIN, ITBIN, IDBIN
      PARAMETER        (IEBIN=40,ITBIN=30,IDBIN=20)
      COMMON /CRTABLES/G_ARRAY, E_ARRAY, M_ARRAY,
     *                 EBOFF,EBFAC,TBOFF,TBFAC,DBOFF,DBFAC
      REAL             G_ARRAY(IEBIN,ITBIN,IDBIN)
      REAL             E_ARRAY(IEBIN,ITBIN,IDBIN)
      REAL             M_ARRAY(IEBIN,ITBIN,IDBIN)
      REAL             EBOFF,EBFAC,TBOFF,TBFAC,DBOFF,DBFAC
      REAL             EBMIN,EBMAX,TBMIN,TBMAX,DBMIN,DBMAX
      PARAMETER        (EBMIN=1.E-4,EBMAX=1.E4)
      PARAMETER        (TBMIN=10.,TBMAX=1.E4)
      PARAMETER        (DBMIN=5.E3,DBMAX=5.E5)



# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 16195 "corsika.F" 2





      
      INTEGER          IBL,L,IBL0,IBL1,IBL2
      CHARACTER*8      RQSTAT
      CHARACTER*255    DSN0

      LOGICAL          FEXIST,LDEVNL






      INTEGER          COASTTHN,COASTCRV,COASTSNT,COASTSTK,COASTPRE

      SAVE
C-----------------------------------------------------------------------

      IF ( DEBUG ) WRITE(MDEBUG,*) 'FILOPN:'
C  CHECK CORRECTNESS OF RUN NUMBER
# 16227 "corsika.F"
      IF ( NRRUN .GT. 999999 ) THEN
        WRITE(MONIOU,*) 'RUN NUMBER = ',NRRUN,' EXCEEDS 999999, STOP'





        STOP 1
      ENDIF

# 16246 "corsika.F"
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.')




            WRITE(0,*) 'FILOPN: FATAL PROBLEM OPENING FILE'
            STOP 1
          ENDIF
          OPEN(UNIT=LSTCK,FILE=FILOUT,STATUS='UNKNOWN',FORM='FORMATTED')
          OPEN(UNIT=LSTCK2,STATUS='SCRATCH',FORM='FORMATTED')
        ENDIF





C  OUTPUT FILES SHOULD NORMALLY NOT EXIST BEFORE THE RUN STARTS



      RQSTAT = 'NEW'


C  LOOK FOR THE FIRST BLANK IN DATASET NAME
      IBL = INDEX(DSN,' ')
C  CHECK MAXIMUM LENGTH OF DATA FILE NAMES (ALL TOGETHER < 255)






      IF ( IBL .GE. 234 ) THEN


        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 1
      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 1
      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 1
      ENDIF
      DSN0 = DSN
C  REMOVE QUOTE FORM NAME
      IBL0 = INDEX(DSN,"'")
      IBL1 = INDEX(DSN,'"')
      DO WHILE (IBL0 + IBL1 .GT. 0)
        IF( IBL0 .EQ. 0 )IBL0 = 1000
        IF( IBL1 .EQ. 0 )IBL1 = 1000
        DO L=MIN(IBL0,IBL1),IBL
          DSN(L:L)=DSN(L+1:L+1)
        ENDDO
        IBL = IBL - 1
        IBL0 = INDEX(DSN,"'")
        IBL1 = INDEX(DSN,'"')
      ENDDO

C  OPEN OUTPUT DATA SET FOR RUN





      DSN(IBL:IBL+8) = 'DAT000000'
      WRITE(DSN(IBL+3:IBL+8),'(I6.6)') NRRUN
      IBL2 = IBL + 9
# 16369 "corsika.F"
      IF ( FTABOUT ) THEN
        DSNTAB = DSN
        DSNTAB(IBL2:IBL2+3) = '.tab'
      ENDIF
      IF ( FLONGOUT  .AND.  LLONGI ) THEN 
        DSNLONG = DSN
        DSNLONG(IBL2:IBL2+4) = '.long'
      ENDIF
# 16387 "corsika.F"
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)





          WRITE(0,*) 'FILOPN: FATAL PROBLEM OPENING FILE'
          STOP 1
        ENDIF




 5791 FORMAT(/,' FILE ',A,' ALREADY EXISTS. RENAME OR REMOVE IT',
     *           ' OR CHANGE ''DIRECT'' DATA CARD AND TRY AGAIN.')


C  INITIALIZE COAST

      coastthn = 1




      coastcrv = 1




      coastsnt = 1






      coaststk = 0




      coastpre = 0




      call inida( DSN, coastthn, coastcrv, coastsnt, coaststk, coastpre)






C  OPEN DATASET FOR PARTICLE OUTPUT
      IF ( FPAROUT ) THEN
# 16466 "corsika.F"
        CALL fopenmpatap( DSN , IBL2-1 )



        WRITE(MONIOU,579) DSN
 579    FORMAT(/,' PARTICLE OUTPUT TO FILE: ',A)



      ENDIF
# 16494 "corsika.F"

# 16527 "corsika.F"

C  OPEN DATASET FOR TABLE OUTPUT
      IF ( FTABOUT ) THEN

C  ON LINUX WITH G77 AN EXISTING FILE CAUSES A CORE DUMP -> FIRST INQUIRE



        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)




          WRITE(0,*) 'FILOPN: FATAL PROBLEM OPENING FILE'
          STOP 1
        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




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)




          WRITE(0,*) 'FILOPN: FATAL PROBLEM OPENING FILE'
          STOP 1
        ENDIF





        OPEN(UNIT=MLONGOUT,FILE=DSNLONG,STATUS=RQSTAT,
     *       FORM='FORMATTED',ACCESS='SEQUENTIAL')

        WRITE(MONIOU,5781) DSNLONG
 5781   FORMAT(/,' LONGITUDINAL OUTPUT TO FILE: ',A)
      ENDIF

# 16635 "corsika.F"

# 16755 "corsika.F"

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

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 1
      ENDIF

      OPEN(UNIT=MEXST,STATUS='SCRATCH',
     *     FORM='UNFORMATTED',ACCESS='DIRECT',RECL=4*MAXSTK)
# 16803 "corsika.F"
C-----------------------------------------------------------------------


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.
# 16823 "corsika.F"
        DSN(IBL:IBL+14) = 'DAT000000.dbase'





        WRITE(DSN(IBL+3:IBL+8),'(I6.6)') NRRUN




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)




            WRITE(0,*) 'FILOPN: FATAL PROBLEM OPENING FILE'
            STOP 1
          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
# 16912 "corsika.F"

      RETURN




      END

# 17026 "corsika.F"

*-- 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
# 17057 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"



      COMMON /CRBUFFS/ RUNH,RUNE,EVTH,EVTE,DATAB,ARRAYLONG,LH

     *                 ,WRRUNH,WRRUNE,WREVTH,WREVTE

      INTEGER          MAXBUF,MAXLEN

      PARAMETER        (MAXBUF=39*8)
# 3681 "corsika.h"
      PARAMETER        (MAXLEN=16)
# 3693 "corsika.h"
      REAL             RUNH(MAXBUF),EVTH(MAXBUF),EVTE(MAXBUF),
     *                 RUNE(MAXBUF),DATAB(MAXBUF),ARRAYLONG(MAXBUF)
      INTEGER          LH

      LOGICAL          WRRUNH,WRRUNE,WREVTH,WREVTE

      CHARACTER*4      CRUNH,CRUNE,CEVTH,CEVTE,CLONG
      EQUIVALENCE      (RUNH(1),CRUNH), (RUNE(1),CRUNE)
      EQUIVALENCE      (EVTH(1),CEVTH), (EVTE(1),CEVTE)
      EQUIVALENCE      (ARRAYLONG(1),CLONG)



























































































# 3811 "corsika.h"

# 3824 "corsika.h"



      COMMON /CRETHMAP/ECTMAP,ELEFT,ELEFTJ
      DOUBLE PRECISION ECTMAP,ELEFT,ELEFTJ





      COMMON /CRGENER/ GEN,ALEVEL
      DOUBLE PRECISION GEN,ALEVEL











# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"



      COMMON /CRIRET/  IRET1,IRET2,IRETE
      INTEGER          IRET1,IRET2
      LOGICAL          IRETE



# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"








      COMMON /CRPAM/   PAMA,SIGNUM,RESTMS,DECTIM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000),
     *                 DECTIM(200)






      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL





      DOUBLE PRECISION GAMMA,COSTHE,PHIX,PHIY,H,T,X,Y,CHI,BETA,GCM,ECM

     *                 ,WEIGHT


     *                 ,HAPP,COSTAP,COSTEA




      EQUIVALENCE      (CURPAR(1), GAMMA ), (CURPAR(2), COSTHE),
     *                 (CURPAR(3), PHIX  ), (CURPAR(4), PHIY  ),
     *                 (CURPAR(5), H     ), (CURPAR(6), T     ),
     *                 (CURPAR(7), X     ), (CURPAR(8), Y     ),
     *                 (CURPAR(9), CHI   ), (CURPAR(10),BETA  ),
     *                 (CURPAR(11),GCM   ), (CURPAR(12),ECM   )

     *                ,(CURPAR(13),WEIGHT)


     *                ,(CURPAR(14),HAPP  ), (CURPAR(15),COSTAP),
     *                 (CURPAR(16),COSTEA)















# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"



      COMMON /CRPOLAR/ POLART,POLARF
      DOUBLE PRECISION POLART,POLARF


















# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"



      COMMON /CRSTACKF/STACKI,



     *                 MSTACKP,MEXST,NSHIFT,NOUREC,NOURECMAX,ICOUNT,
     *                 NTO,NFROM




      INTEGER          MAXSTK
# 4796 "corsika.h"
      PARAMETER        (MAXSTK = 17*256*2)
# 4809 "corsika.h"
      DOUBLE PRECISION STACKI(MAXSTK)



      INTEGER          MSTACKP,MEXST,NSHIFT,NOUREC,NOURECMAX,ICOUNT,
     *                 NTO,NFROM






















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 17057 "corsika.F" 2





      INTEGER          I,ISTK,J,N
     *                ,IYEAR,MONTH,IDAY,IHOUR,IMINU



      DOUBLE PRECISION EAVAI,EINI
     *                ,SEC0,SEC1,STIME,TTIME



      SAVE
      DATA             ISTK / MAXSTK /, N / 0 /
C-----------------------------------------------------------------------

      IF ( DEBUG ) WRITE(MDEBUG,220) ICOUNT-1,ELEFT



 220  FORMAT(' FSTACK:',I7,E12.5



     *                    )

C  STACK EMPTY, SOMETHING TO BE READ FROM DISK ?







      IF ( MSTACKP .EQ. 0 ) THEN

        IF ( NOUREC .EQ. 0 ) THEN







          IF ( FPRINT  .OR.  DEBUG ) WRITE(MONIOU,224) NTO,NFROM

 224      FORMAT(/,' NO MORE SECONDARIES FOUND ON STACK',/,
     *            ' ',I11,' PARTICLES WRITTEN TO STACK',/,
     *            ' ',I11,' PARTICLES READ FROM STACK' )






          CURPAR(0) = 0.D0
          IRET1 = 1
          RETURN
# 17223 "corsika.F"
        ELSE
# 17232 "corsika.F"
C  READ LAST BLOCK OF 256 PARTICLES FROM SCRATCH FILE
# 17241 "corsika.F"
          READ(MEXST,REC=NOUREC) (STACKI(I),I=1,ISTK/2)
          NOUREC  = NOUREC - 1
          MSTACKP = ISTK/2
        ENDIF
      ENDIF

      NFROM  = NFROM + 1
      ICOUNT = ICOUNT - 1
# 17306 "corsika.F"
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)

      WEIGHT = STACKI(MSTACKP+14)


      CURPAR(14) = STACKI(MSTACKP+15)
      CURPAR(15) = STACKI(MSTACKP+16)
      CURPAR(16) = STACKI(MSTACKP+17)
# 17341 "corsika.F"
      IF ( PAMA(NINT( CURPAR(0) )) .NE. 0.D0 ) THEN

        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)
# 17363 "corsika.F"
      IF( PRMPAR(1) .GT. 5.D7 )THEN
        EINI = PRMPAR(1)*PAMA(NINT( PRMPAR(0) ))
        EAVAI = ELEFT







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

      RETURN
      END

# 17522 "corsika.F"


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


# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 17581 "corsika.F" 2

      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


# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 17639 "corsika.F" 2

      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 ) THEN
          WRITE(0,*) 'X < 0 IN GSER'
          STOP 1
        ENDIF
        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


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


# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 17696 "corsika.F" 2

      DOUBLE PRECISION SECONDS,TTIME
# 17712 "corsika.F"
      INTEGER          IYEAR,MONTH,IDAY,IHOUR,IMINU,ISEC
      SAVE
C-----------------------------------------------------------------------


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
# 17768 "corsika.F"

      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







# 1 "corsika.h" 1
# 3562 "corsika.h"










      COMMON /CRATMOS/ AATM,AATM0,BATM,BATM0,CATM,CATM0,DATM,MODATM
     *                ,MATMFI,LATMNEW
      DOUBLE PRECISION AATM(5),AATM0(5,0:42),BATM(5),BATM0(5,0:42),
     *                 CATM(5),CATM0(5,0:42),DATM(5)
      INTEGER          MODATM,MATMFI
      LOGICAL          LATMNEW





      COMMON /CRATMOS2/HLAY,HLAY0,THICKL,LAYNO,LAYNEW
      DOUBLE PRECISION HLAY(6),HLAY0(5,0:28),THICKL(5)
      INTEGER          LAYNO(0:41)
      LOGICAL          LAYNEW











# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 17797 "corsika.F" 2

      DOUBLE PRECISION ARG
      SAVE




C-----------------------------------------------------------------------

C      IF ( DEBUG ) WRITE(MDEBUG,*)'HEIGH : ARG=',SNGL(ARG)
C#if __ATMEXT__
C     *                                  ,' ARGMAX=',SNGL(THICKL(1))
C#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


*-- 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




# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"











      COMMON /CRATMOSL/PATH1,RHOSLT,TSLANT,HLAYS,RHOS,THICKS,
     *                 CCATM,HLAYC,HGROUND,RADGRD,IENDT
      INTEGER          MAXSLANT,MAXSLANT2
      PARAMETER        (MAXSLANT2=1600, MAXSLANT=MAXSLANT2*5)
      DOUBLE PRECISION PATH1(MAXSLANT),RHOSLT(MAXSLANT),
     *                 TSLANT(MAXSLANT),HLAYS(6),RHOS(6),THICKS(6),
     *                 CCATM(5),HLAYC(6),HGROUND,RADGRD
      INTEGER          IENDT



# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"










      COMMON /CROBSPAR/OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP,
     *                 THETPR,PHIPR,

     *                 CORRXY,







     *                 NOBSLV
      DOUBLE PRECISION OBSLEV(20),THCKOB(20),XOFF(20),YOFF(20),
     *                 HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2)

     *                 ,CORRXY







      INTEGER          NOBSLV



# 4262 "corsika.h"



      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL



# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"

















# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 17855 "corsika.F" 2

      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



*--   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
# 17900 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"



      COMMON /CRINTER/ AVCH,AVCH3,DC0,DLOGS,DMLOG,ECMDIF,ECMDPM,ELAB,
     *                 FNEUT,FNEUT2,GNU,PLAB,POSC2,POSC3,POSN2,POSN3,
     *                 RC3TO2,S,SEUGF,SEUGP,SLOG,SLOGSQ,SMLOG,
     *                 WIDC2,WIDC3,WIDN2,WIDN3,YCM,YY0,ZN,
     *                 IDIF,ITAR
      DOUBLE PRECISION AVCH,AVCH3,DC0,DLOGS,DMLOG,ECMDIF,ECMDPM,ELAB,
     *                 FNEUT,FNEUT2,GNU,PLAB,POSC2,POSC3,POSN2,POSN3,
     *                 RC3TO2,S,SEUGF,SEUGP,SLOG,SLOGSQ,SMLOG,
     *                 WIDC2,WIDC3,WIDN2,WIDN3,YCM,YY0,ZN
      INTEGER          IDIF,ITAR











# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"



      COMMON /CRNCSNCS/SIGN30,SIGN45,SIGN60,SIGO30,SIGO45,SIGO60,
     *                 SIGA30,SIGA45,SIGA60,PNOA30,PNOA45,PNOA60,
     *                 SIG30A,SIG45A,SIG60A
      DOUBLE PRECISION SIGN30(56),SIGN45(56),SIGN60(56),
     *                 SIGO30(56),SIGO45(56),SIGO60(56),
     *                 SIGA30(56),SIGA45(56),SIGA60(56),
     *                 PNOA30(1540,3),PNOA45(1540,3),PNOA60(1540,3),
     *                 SIG30A(56),SIG45A(56),SIG60A(56)



# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"








      COMMON /CRPAM/   PAMA,SIGNUM,RESTMS,DECTIM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000),
     *                 DECTIM(200)






      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL





      DOUBLE PRECISION GAMMA,COSTHE,PHIX,PHIY,H,T,X,Y,CHI,BETA,GCM,ECM

     *                 ,WEIGHT


     *                 ,HAPP,COSTAP,COSTEA




      EQUIVALENCE      (CURPAR(1), GAMMA ), (CURPAR(2), COSTHE),
     *                 (CURPAR(3), PHIX  ), (CURPAR(4), PHIY  ),
     *                 (CURPAR(5), H     ), (CURPAR(6), T     ),
     *                 (CURPAR(7), X     ), (CURPAR(8), Y     ),
     *                 (CURPAR(9), CHI   ), (CURPAR(10),BETA  ),
     *                 (CURPAR(11),GCM   ), (CURPAR(12),ECM   )

     *                ,(CURPAR(13),WEIGHT)


     *                ,(CURPAR(14),HAPP  ), (CURPAR(15),COSTAP),
     *                 (CURPAR(16),COSTEA)















# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"

























      COMMON /CRRANDPA/RD,FAC,U1,U2,NSEQ,ISEED,KNOR
      DOUBLE PRECISION RD(3000),FAC,U1,U2



      INTEGER          ISEED(3,10),NSEQ

      LOGICAL          KNOR



# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 17900 "corsika.F" 2

      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
      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

      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
      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

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


*-- 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
# 18078 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"










      COMMON /CRATMOS/ AATM,AATM0,BATM,BATM0,CATM,CATM0,DATM,MODATM
     *                ,MATMFI,LATMNEW
      DOUBLE PRECISION AATM(5),AATM0(5,0:42),BATM(5),BATM0(5,0:42),
     *                 CATM(5),CATM0(5,0:42),DATM(5)
      INTEGER          MODATM,MATMFI
      LOGICAL          LATMNEW





      COMMON /CRATMOS2/HLAY,HLAY0,THICKL,LAYNO,LAYNEW
      DOUBLE PRECISION HLAY(6),HLAY0(5,0:28),THICKL(5)
      INTEGER          LAYNO(0:41)
      LOGICAL          LAYNEW











# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"



      COMMON /CRBUFFS/ RUNH,RUNE,EVTH,EVTE,DATAB,ARRAYLONG,LH

     *                 ,WRRUNH,WRRUNE,WREVTH,WREVTE

      INTEGER          MAXBUF,MAXLEN

      PARAMETER        (MAXBUF=39*8)
# 3681 "corsika.h"
      PARAMETER        (MAXLEN=16)
# 3693 "corsika.h"
      REAL             RUNH(MAXBUF),EVTH(MAXBUF),EVTE(MAXBUF),
     *                 RUNE(MAXBUF),DATAB(MAXBUF),ARRAYLONG(MAXBUF)
      INTEGER          LH

      LOGICAL          WRRUNH,WRRUNE,WREVTH,WREVTE

      CHARACTER*4      CRUNH,CRUNE,CEVTH,CEVTE,CLONG
      EQUIVALENCE      (RUNH(1),CRUNH), (RUNE(1),CRUNE)
      EQUIVALENCE      (EVTH(1),CEVTH), (EVTE(1),CEVTE)
      EQUIVALENCE      (ARRAYLONG(1),CLONG)













      COMMON /CRCONSTA/PI,PI2,OB3,TB3,ENEPER,SQRT3
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER,SQRT3


































      COMMON /CRDPMFLG/NFLAIN,NFLDIF,NFLPI0,NFLCHE,NFLPIF,NFRAGM
      INTEGER          NFLAIN,NFLDIF,NFLPI0,NFLCHE,NFLPIF,NFRAGM




















      COMMON /CRELABCT/ELCUT
      DOUBLE PRECISION ELCUT(4)


















# 3811 "corsika.h"

# 3824 "corsika.h"



      COMMON /CRETHMAP/ECTMAP,ELEFT,ELEFTJ
      DOUBLE PRECISION ECTMAP,ELEFT,ELEFTJ


















# 3855 "corsika.h"










      COMMON /CRINCLINED/XPINCL,YPINCL,ZPINCL,PHINCL,THINCL
     *,TDINCL
      DOUBLE PRECISION XPINCL,YPINCL,ZPINCL,PHINCL,THINCL,TDINCL



# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"
























      INTEGER          LNGMAX
      PARAMETER        (LNGMAX = 15000)
      INTEGER          TYPE1
      PARAMETER        (TYPE1 = 0)
      INTEGER          TYPE2
      PARAMETER        (TYPE2 = 1)
      INTEGER          TYPE3
      PARAMETER        (TYPE3 = 2)
      INTEGER          TYPE4
      PARAMETER        (TYPE4 = 3)
      COMMON /CRLONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP



     *                ,LLONGI,FLGFIT
# 3961 "corsika.h"
      DOUBLE PRECISION ADLONG(0:LNGMAX,19),AELONG(0:LNGMAX,10),
     *                 APLONG(0:LNGMAX,10),DLONG(0:LNGMAX,19),
     *                 ELONG(0:LNGMAX,10),
     *                 HLONG(0:LNGMAX),PLONG(0:LNGMAX,10),
     *                 SDLONG(0:LNGMAX,19),SELONG(0:LNGMAX,10),
     *                 SPLONG(0:LNGMAX,10),THSTEP,THSTPI




      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT

      COMMON /CRSLANT/ RLONG,THCKRL,CTH,STHCPH,STHSPH,RLOFF
      DOUBLE PRECISION RLONG(0:LNGMAX),THCKRL(0:LNGMAX),
     *                 CTH,STHCPH,STHSPH,RLOFF






      COMMON /CRMAGANG/ARRANG,ARRANR,COSANG,SINANG
      DOUBLE PRECISION ARRANG,ARRANR,COSANG,SINANG





      COMMON /CRMAGNET/BX,BZ,BVAL,BNORMC,BNORM,COSB,SINB,BLIMIT
      DOUBLE PRECISION BX,BZ,BVAL,BNORMC,BNORM,COSB,SINB,BLIMIT



# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"



      COMMON /CRNKGI/  SEL,SELLG,STH,ZEL,ZELLG,ZSL,DIST,
     *                 DISX,DISY,DISXY,DISYX,DLAX,DLAY,DLAXY,DLAYX,
     *                 OBSATI,RADNKG,RMOL,TLEV,TLEVCM,IALT
      DOUBLE PRECISION SEL(10),SELLG(10),STH(10),ZEL(10),ZELLG(10),
     *                 ZSL(10),DIST(10),
     *                 DISX(-10:10),DISY(-10:10),
     *                 DISXY(-10:10,2),DISYX(-10:10,2),
     *                 DLAX (-10:10,2),DLAY (-10:10,2),
     *                 DLAXY(-10:10,2),DLAYX(-10:10,2),
     *                 OBSATI(2),RADNKG,RMOL(2),TLEV(10),TLEVCM(10)
      INTEGER          IALT(2)


















# 4212 "corsika.h"










      COMMON /CROBSPAR/OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP,
     *                 THETPR,PHIPR,

     *                 CORRXY,







     *                 NOBSLV
      DOUBLE PRECISION OBSLEV(20),THCKOB(20),XOFF(20),YOFF(20),
     *                 HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2)

     *                 ,CORRXY







      INTEGER          NOBSLV



# 4262 "corsika.h"



      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL





      DOUBLE PRECISION GAMMA,COSTHE,PHIX,PHIY,H,T,X,Y,CHI,BETA,GCM,ECM

     *                 ,WEIGHT


     *                 ,HAPP,COSTAP,COSTEA




      EQUIVALENCE      (CURPAR(1), GAMMA ), (CURPAR(2), COSTHE),
     *                 (CURPAR(3), PHIX  ), (CURPAR(4), PHIY  ),
     *                 (CURPAR(5), H     ), (CURPAR(6), T     ),
     *                 (CURPAR(7), X     ), (CURPAR(8), Y     ),
     *                 (CURPAR(9), CHI   ), (CURPAR(10),BETA  ),
     *                 (CURPAR(11),GCM   ), (CURPAR(12),ECM   )

     *                ,(CURPAR(13),WEIGHT)


     *                ,(CURPAR(14),HAPP  ), (CURPAR(15),COSTAP),
     *                 (CURPAR(16),COSTEA)















# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"










      COMMON /CRPRIMSP/PSLOPE,LLIMIT,ULIMIT,LL,UL,SLEX,ISPEC
      DOUBLE PRECISION PSLOPE,LLIMIT,ULIMIT,LL,UL,SLEX
      INTEGER          ISPEC












      COMMON /CRRANDPA/RD,FAC,U1,U2,NSEQ,ISEED,KNOR
      DOUBLE PRECISION RD(3000),FAC,U1,U2



      INTEGER          ISEED(3,10),NSEQ

      LOGICAL          KNOR



# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"










      COMMON /CRREJECT/AVNREJ,ALTMIN,ANEXP,THICKA,THICKD,CUTLN,EONCUT,

     *                 EFRCTHN,ETHINN,ETHINNG,THINRAT,THINRATH,WEITRAT,
     *                 WEITRATH,EEFRTHN,

     *                 FNPRIM
      DOUBLE PRECISION AVNREJ(20),ALTMIN(20),ANEXP(20),THICKA(20),
     *                 THICKD(20),CUTLN,EONCUT

     *                 ,EFRCTHN,ETHINN,ETHINNG,THINRAT,THINRATH,WEITRAT,
     *                 WEITRATH,EEFRTHN

      LOGICAL          FNPRIM





















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"



      COMMON /CRTHNVAR/STACKINT,

     *                 EEPP,ELIM,


     *                 RMAX,RMAX2,
     *                 WMAX,WMAX0,WMAXE,WMAXE0,WMAXEM,

     *                 INT_ICOUNT,MODETHN,THINNING

     *                 ,RLIM,WLIM

      INTEGER          MAXICOUNT
      PARAMETER        (MAXICOUNT = 200000)
# 4883 "corsika.h"
      DOUBLE PRECISION STACKINT(0:16,MAXICOUNT)
# 4892 "corsika.h"
     *                 ,EEPP(MAXICOUNT),ELIM


     *                 ,RMAX,RMAX2
     *                 ,WMAX,WMAX0,WMAXE,WMAXE0,WMAXEM

      INTEGER          INT_ICOUNT,MODETHN
      LOGICAL          THINNING

      LOGICAL           RLIM,WLIM




















# 4935 "corsika.h"


















      COMMON /CRVERS/  VERNUM,MVDATE,VERDAT
      DOUBLE PRECISION VERNUM
      INTEGER          MVDATE
      CHARACTER*18     VERDAT

















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     
















      COMMON /CRSIBYLC/FSIBYL,FSIBSG,FSIBCH
      LOGICAL          FSIBYL,FSIBSG,FSIBCH



     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 18078 "corsika.F" 2


      DOUBLE PRECISION EFRAC,VERVEN
      INTEGER          IDPM,ILONG,ILTHIN,ISO
      CHARACTER*1      MARK

      DOUBLE PRECISION H0
      DOUBLE PRECISION HEIGH,THICK

      DOUBLE PRECISION DELTA

      INTEGER          I,IA,IP
# 18101 "corsika.F"
      INTEGER          IONES,ITENS,IHUNS

      SAVE
      EXTERNAL         HEIGH,THICK



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



C  INCLINED PLANE
      RUNH(75) = XPINCL
      RUNH(76) = YPINCL
      RUNH(77) = ZPINCL
      RUNH(78) = THINCL
      RUNH(79) = PHINCL
      RUNH(80) = TDINCL
      THINCL = THINCL * PI / 180.D0   !CONVERT TO RADIAN
      PHINCL = PHINCL * PI / 180.D0   !CONVERT TO RADIAN
# 18163 "corsika.F"
      
      RUNH(92) = ARRANG
      RUNH(93) = REAL( NSHOW )

      RUNH(94) = 1.







      IF ( PRMPAR(0) .GT. 5655.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 1
      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 1
        ENDIF
      ENDIF

      WRITE(MONIOU,*) 'PRIMARY PARTICLE IDENTIFICATION IS ',
     *                NINT( PRMPAR(0) )

C  CHECK RECOMMENDED ENERGY RANGE
# 18239 "corsika.F"

C  CHECK ENERGY RANGE FOR CROSS-SECTIONS







      IF ( .NOT. FSIBSG  .AND.  ULIMIT .GT. 1.D8 ) THEN





        WRITE(MONIOU,*) ' WARNING: P-AIR CROSS-SECTION DOUBTFULL ',
     *               'FOR ENERGIES ABOVE 10**17 EV'
      ENDIF

      IF ( PRMPAR(0) .GE. 200.D0 ) THEN




        IF ( FURQMD ) THEN
C  URQMD1.3 LINK CANNOT TREAT NUCLEI




          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 1
          ENDIF
        ENDIF
      ENDIF




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 1
      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
# 18325 "corsika.F"

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

*       WRITE(MONIOU,*) 'TARGET OF FIRST INTERACTION IS CHOSEN RANDOMLY'

*     ENDIF


C  SET PRIMARY ZENITH ANGLE FOR HORIZONTALLY SKIMMING SHOWERS
      IF ( FIMPCT ) THEN
        THETPR(1) = 90.D0
        THETPR(2) = 90.D0
      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 1
      ENDIF


      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 1
      ENDIF
# 18402 "corsika.F"
      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 1
      ENDIF
      IF ( THETPR(2) .GT. 90.D0 ) THEN
# 18437 "corsika.F"
      ENDIF
# 18484 "corsika.F"

C  INCIDENCE ANGLE FIXED ?
      IF ( THETPR(1) .EQ. THETPR(2) .AND. PHIPR(1) .EQ. PHIPR(2) ) THEN
        FIXINC = .TRUE.

        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')

      ELSE
        FIXINC = .FALSE.
# 18510 "corsika.F"
        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
# 18586 "corsika.F"
      EVTH(81) = THETPR(1)
      EVTH(82) = THETPR(2)
      EVTH(83) = PHIPR(1)
      EVTH(84) = PHIPR(2)





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 1
        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 1
        ENDIF
        THCKOB(I) = THICK( OBSLEV(I) )
      ENDDO
# 18641 "corsika.F"

C  WRITE OBSERVATION LEVELS TO HEADER (IN CM)






      RUNH(5)  = REAL( NOBSLV )
      EVTH(47) = REAL( NOBSLV )
      DO  I = 1, NOBSLV
        RUNH(5+I)  = OBSLEV(I)
        EVTH(47+I) = OBSLEV(I)
      ENDDO


# 18687 "corsika.F"
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 1
        ENDIF

        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 1




        ENDIF


        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 1
        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 1
          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

        WRITE(MONIOU,*) 'HEIGHT OF FIRST INTERACTION IS CHOSEN RANDOMLY'

        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 1
      ENDIF
# 18834 "corsika.F"
        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 1
        ENDIF



      H0 = HEIGH( THICK0 )


      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)')

      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
# 18908 "corsika.F"
      IF ( 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 1
        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 1
        ENDIF

        FIXINC = .FALSE.
      ENDIF










# 18992 "corsika.F"

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-----------------------------------------------------------------------

C  CHECK INPUT OF ENERGY CUTS

      IF ( ELCUT(1) .LT. 0.3D0 ) THEN
        WRITE(MONIOU,*) 'ELCUT(1) TOO SMALL FOR URQMD'







        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 1
      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 1
      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 1
      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 1
      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 1
      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 1
      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 1
      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 1
      ENDIF


      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 1
      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 1
      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
# 19156 "corsika.F"
      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'

        STOP 1
      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 1
      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,*) ' '

      ELSE




        WRITE(MONIOU,702) EFRCTHN*THINRAT, EFRCTHN
 702    FORMAT(' ENERGY FRACTION FOR EM THINNING = ',1P, E11.4,/,
     *         '       AND FOR HADRONIC THINNING = ',E11.4)


# 19226 "corsika.F"
        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.
# 19253 "corsika.F"
            WRITE(MONIOU,*) 'HAD.WEIGHTS ARE LIMITED TO MAX.'
     *                      ,SNGL(WMAX0)
            WRITE(MONIOU,*) 'EM  WEIGHTS ARE LIMITED TO MAX.'
     *                      ,SNGL(WMAXE0)



          EVTH(150) = WMAX0
          EVTH(151) = WMAXE0




          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
# 19307 "corsika.F"

      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 1
      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 1
      ENDIF
C  LIMITING FACTOR FOR STEP SIZE OF ELECTRON IN MAGNETIC FIELD





C  WE USE A LIMIT OF ABOUT 11.4 DEG (0.2 RAD)
      BLIMIT   = 0.2D0 / BNORM

      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')
# 19389 "corsika.F"
      ENDIF

# 19579 "corsika.F"
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

# 19611 "corsika.F"
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 ( .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


C  PRINTOUT OF INFORMATIONS FOR DEBUGGING
      IF ( DEBUG ) WRITE(MONIOU,484) MDEBUG
  484 FORMAT(/,' ATTENTION ! DEBUGGING IS ACTIVE',/,
     *          ' ====> DEBUG INFORMATION WRITTEN TO UNIT ',I3,/,/)






C-----------------------------------------------------------------------
C  WRITE RUNHEADER TO OUTPUT BUFFER

C  WRRUNH SIGNALS THAT RUNH HAS BEEN WRITTEN OUT
      WRRUNH = .TRUE.
# 19652 "corsika.F"
      CALL TOBUF( RUNH,0 )
# 19664 "corsika.F"





# 19678 "corsika.F"
C-----------------------------------------------------------------------


C  WRITE DATA SET FOR INFORMATION BANK
      IF ( FDBASE ) THEN







        VERVEN = 2.3D0





C  LONGITUDINAL FLAG (0=NO LONGI, 1=VERT. DEPTH, 2=SLANT DEPTH)
        IF ( LLONGI ) THEN

          ILONG = 2



        ELSE
          ILONG = 0
        ENDIF
C  SET ISO-FLAG (0=ISOBAR MODEL, 1=GHEISHA, 2=URQMD, 3=FLUKA)





        ISO = 2



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

        MARK = '0'




        ILTHIN = 1
        EFRAC  = EFRCTHN
# 19764 "corsika.F"

        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
# 19791 "corsika.F"
 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)







        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),

     $    ELCUT(3), ELCUT(4),EVTH(81),
     $    EVTH(82),EVTH(83),EVTH(84),
     $    FIXHEI,N1STTR,THICK0,
     $    STEPFC,ARRANG,INT(EVTH(94)),

     $    HIMPACT(1),HIMPACT(2),NSEQ,



     $    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,



     $    ' ARC000.01',' ARC000.01',

     $    NSHOW,HOST,USER
# 19865 "corsika.F"
 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,'#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






     $    )
# 19909 "corsika.F"
        WRITE(MDBASE,670) ILTHIN,EFRAC



 670    FORMAT('#thinning#',I2,'#thinnlev_had#',1P,E14.7,0P)

      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







# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























































































# 3811 "corsika.h"

# 3824 "corsika.h"



      COMMON /CRETHMAP/ECTMAP,ELEFT,ELEFTJ
      DOUBLE PRECISION ECTMAP,ELEFT,ELEFTJ


















# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"



      COMMON /CRSTACKF/STACKI,



     *                 MSTACKP,MEXST,NSHIFT,NOUREC,NOURECMAX,ICOUNT,
     *                 NTO,NFROM




      INTEGER          MAXSTK
# 4796 "corsika.h"
      PARAMETER        (MAXSTK = 17*256*2)
# 4809 "corsika.h"
      DOUBLE PRECISION STACKI(MAXSTK)



      INTEGER          MSTACKP,MEXST,NSHIFT,NOUREC,NOURECMAX,ICOUNT,
     *                 NTO,NFROM






















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 19951 "corsika.F" 2

      SAVE
C-----------------------------------------------------------------------

      IF ( DEBUG ) WRITE(MDEBUG,*) 'ISTACK:'

      NTO       = 0
      NFROM     = 0
      NOUREC    = 0
      NOURECMAX = 0
      NSHIFT    = 0
      ELEFT     = 0.D0
      ICOUNT    = 1
# 19972 "corsika.F"
      MSTACKP   = 0


      RETURN
      END

# 20052 "corsika.F"

*-- 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
# 20088 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"











      COMMON /CRCONSTA/PI,PI2,OB3,TB3,ENEPER,SQRT3
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER,SQRT3




















      COMMON /CRDECAYC/GAM345,COS345,PHI345
      DOUBLE PRECISION GAM345(3),COS345(3),PHI345(3)






















































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"



      COMMON /CRIRET/  IRET1,IRET2,IRETE
      INTEGER          IRET1,IRET2
      LOGICAL          IRETE



# 3912 "corsika.h"



      COMMON /CRKAONS/ CKA
      DOUBLE PRECISION CKA(80)



















      INTEGER          LNGMAX
      PARAMETER        (LNGMAX = 15000)
      INTEGER          TYPE1
      PARAMETER        (TYPE1 = 0)
      INTEGER          TYPE2
      PARAMETER        (TYPE2 = 1)
      INTEGER          TYPE3
      PARAMETER        (TYPE3 = 2)
      INTEGER          TYPE4
      PARAMETER        (TYPE4 = 3)
      COMMON /CRLONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP



     *                ,LLONGI,FLGFIT
# 3961 "corsika.h"
      DOUBLE PRECISION ADLONG(0:LNGMAX,19),AELONG(0:LNGMAX,10),
     *                 APLONG(0:LNGMAX,10),DLONG(0:LNGMAX,19),
     *                 ELONG(0:LNGMAX,10),
     *                 HLONG(0:LNGMAX),PLONG(0:LNGMAX,10),
     *                 SDLONG(0:LNGMAX,19),SELONG(0:LNGMAX,10),
     *                 SPLONG(0:LNGMAX,10),THSTEP,THSTPI




      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT

      COMMON /CRSLANT/ RLONG,THCKRL,CTH,STHCPH,STHSPH,RLOFF
      DOUBLE PRECISION RLONG(0:LNGMAX),THCKRL(0:LNGMAX),
     *                 CTH,STHCPH,STHSPH,RLOFF


















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"








      COMMON /CRPAM/   PAMA,SIGNUM,RESTMS,DECTIM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000),
     *                 DECTIM(200)






      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL





      DOUBLE PRECISION GAMMA,COSTHE,PHIX,PHIY,H,T,X,Y,CHI,BETA,GCM,ECM

     *                 ,WEIGHT


     *                 ,HAPP,COSTAP,COSTEA




      EQUIVALENCE      (CURPAR(1), GAMMA ), (CURPAR(2), COSTHE),
     *                 (CURPAR(3), PHIX  ), (CURPAR(4), PHIY  ),
     *                 (CURPAR(5), H     ), (CURPAR(6), T     ),
     *                 (CURPAR(7), X     ), (CURPAR(8), Y     ),
     *                 (CURPAR(9), CHI   ), (CURPAR(10),BETA  ),
     *                 (CURPAR(11),GCM   ), (CURPAR(12),ECM   )

     *                ,(CURPAR(13),WEIGHT)


     *                ,(CURPAR(14),HAPP  ), (CURPAR(15),COSTAP),
     *                 (CURPAR(16),COSTEA)















# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"



      COMMON /CRPOLAR/ POLART,POLARF
      DOUBLE PRECISION POLART,POLARF




















      COMMON /CRRANDPA/RD,FAC,U1,U2,NSEQ,ISEED,KNOR
      DOUBLE PRECISION RD(3000),FAC,U1,U2



      INTEGER          ISEED(3,10),NSEQ

      LOGICAL          KNOR



# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 20088 "corsika.F" 2

      DOUBLE PRECISION BETA3,COSTCM,COSTH3,FAC1,FAC2,GAMMA3,GAMMA4,
     *                 PHINN,PHI3,RA,WORK1,WORK2
      INTEGER          I,ICHARG,IGO,M3



      SAVE





C-----------------------------------------------------------------------


      IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=0,9),WEIGHT
  444 FORMAT(' KDECAY: CURPAR=',1P,11E11.3)





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

C  NEUTRINO IS DROPPED

          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 ( SECPAR(2) .GE. C(29) ) THEN



            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

              DLONG(LHEIGH,15) = DLONG(LHEIGH,15)+GAMMA3*PAMA(5)*WEIGHT



            ENDIF
# 20205 "corsika.F"
          ENDIF
# 20231 "corsika.F"
          IF ( LLONGI ) THEN
C  ADD NEUTRINO ENERGY TO LONGITUDINAL ENERGY DEPOSIT
            GAMMA4 = PAMA(11) * GAMMA - PAMA(5) * GAMMA3

            DLONG(LHEIGH,8) = DLONG(LHEIGH,8) + GAMMA4 * WEIGHT



          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 ( SECPAR(2) .GE. C(29) ) THEN



              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

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
# 20287 "corsika.F"
              ENDIF
# 20319 "corsika.F"
            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 )
# 20341 "corsika.F"
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 ( SECPAR(2) .GE. C(29) ) THEN



              IF ( I .EQ. 1 ) THEN
                SECPAR(0) = 7.D0

              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

                  DLONG(LHEIGH,17) = DLONG(LHEIGH,17)
     *                             + GAM345(1) * PAMA(7) * WEIGHT




                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
# 20392 "corsika.F"
                ENDIF
              ENDIF
# 20427 "corsika.F"
            ENDIF
  250     CONTINUE

          IF ( LLONGI ) THEN
C  ADD NEUTRINO ENERGY TO LONGITUDINAL ENERGY DEPOSIT
            GAM345(3)=GAMMA*PAMA(11)-GAM345(1)*PAMA(7)-GAM345(2)*PAMA(2)

            DLONG(LHEIGH,8) = DLONG(LHEIGH,8) + GAM345(3) * WEIGHT



          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 )
# 20461 "corsika.F"
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 ( SECPAR(2) .GE. C(29) ) THEN



              SECPAR(1)   = GAM345(I)
              IF ( I .EQ. 1 ) THEN
                SECPAR(0) = 7.D0

              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

                   DLONG(LHEIGH,17) = DLONG(LHEIGH,17)
     *                               + GAM345(1) * PAMA(7) * WEIGHT




                 ELSE
                   DLONG(LHEIGH,15) = DLONG(LHEIGH,15)
     *                               + GAM345(1) * PAMA(5) * WEIGHT
# 20519 "corsika.F"
                 ENDIF
              ENDIF
# 20553 "corsika.F"
            ENDIF
  260     CONTINUE

          IF ( LLONGI ) THEN
C  ADD NEUTRINO ENERGY TO LONGITUDINAL ENERGY DEPOSIT
            GAM345(3)=GAMMA*PAMA(11)-GAM345(1)*PAMA(7)-GAM345(2)*PAMA(5)

            DLONG(LHEIGH,8) = DLONG(LHEIGH,8) + GAM345(3) * WEIGHT



          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 ( SECPAR(2) .GE. C(29) ) THEN



              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

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






              ENDIF
# 20644 "corsika.F"
            ENDIF
          ENDDO

        ENDIF

C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  DECAY OF K0S  (2 MODES RSP. 4 MODES)
      ELSEIF ( IGO .EQ. 3 ) THEN

        CALL RMMARD( RD,1,1 )
# 20870 "corsika.F"
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

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) )
# 20903 "corsika.F"
C  PI(+,-)  AND  E(-,+) / NEUTRINO IS DROPPED
          DO  420  I = 1, 2
            SECPAR(0) = 10 - 3*I - (2*I-3)*ICHARG

            CALL ADDANG3( COSTHE,PHIX,PHIY, COS345(I),PHI345(I),
     *                                  SECPAR(2),SECPAR(3),SECPAR(4) )

            IF ( SECPAR(2) .GE. C(29) ) THEN



              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

                  DLONG(LHEIGH,17) = DLONG(LHEIGH,17)
     *                              + GAM345(1)*PAMA(8)*WEIGHT*FAC1
                  DLONG(LHEIGH,18) = DLONG(LHEIGH,18)
     *                              + GAM345(1)*PAMA(8)*WEIGHT*FAC2




                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
# 20957 "corsika.F"
                ENDIF
              ENDIF
# 20988 "corsika.F"
            ENDIF
  420     CONTINUE

          IF ( LLONGI ) THEN
C  ADD NEUTRINO ENERGY TO LONGITUDINAL ENERGY DEPOSIT
            GAM345(3)=GAMMA*PAMA(10)-GAM345(1)*PAMA(8)-GAM345(2)*PAMA(2)

            DLONG(LHEIGH,8) = DLONG(LHEIGH,8) + GAM345(3) * WEIGHT



          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) )




C  PI(+,-)  AND  MU(-,+) / NEUTRINO IS DROPPED
          DO  430  I = 1, 2

            CALL ADDANG3( COSTHE,PHIX,PHIY, COS345(I),PHI345(I),
     *                                  SECPAR(2),SECPAR(3),SECPAR(4) )

            IF ( SECPAR(2) .GE. C(29) ) THEN



              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




              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

                   DLONG(LHEIGH,17) = DLONG(LHEIGH,17)
     *                                 + GAM345(1)*PAMA(8)*WEIGHT*FAC1
                   DLONG(LHEIGH,18) = DLONG(LHEIGH,18)
     *                                 + GAM345(1)*PAMA(8)*WEIGHT*FAC2




                 ELSE
                   DLONG(LHEIGH,15) = DLONG(LHEIGH,15)
     *                                 + GAM345(2) * PAMA(5) * WEIGHT
# 21082 "corsika.F"
                 ENDIF
              ENDIF
# 21116 "corsika.F"
            ENDIF
  430     CONTINUE

          IF ( LLONGI ) THEN
C  ADD NEUTRINO ENERGY TO LONGITUDINAL ENERGY DEPOSIT
            GAM345(3)=GAMMA*PAMA(10)-GAM345(1)*PAMA(8)-GAM345(2)*PAMA(5)

            DLONG(LHEIGH,8) = DLONG(LHEIGH,8) + GAM345(3) * WEIGHT



          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 ( SECPAR(2) .GE. C(29) ) THEN



              SECPAR(1) = GAM345(I)
              CALL TSTACK
            ELSE
              IF ( LLONGI ) THEN
C  ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT

                DLONG(LHEIGH,17) = DLONG(LHEIGH,17)
     *                                  + GAM345(I)*PAMA(7)*WEIGHT




              ENDIF
# 21185 "corsika.F"
            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 ( SECPAR(2) .GE. C(29) ) THEN



              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

                  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
# 21232 "corsika.F"
                ENDIF
              ENDIF
# 21266 "corsika.F"
            ENDIF
          ENDDO

        ENDIF
      ENDIF

C  KILL CURRENT PARTICLE
      IRET1 = 1

      RETURN
      END


*-- 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

C  PARTICLE WITH COORDINATES XX, YY AND APPARENT HEIGHT HH IN
C  CURVED COORDINATE SYSTEM



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)

C   HH    = HAPP APPARENT HEIGHT OF PARTICLE IN DET. SYSTEM (CM)



C   ISTART = STARTING BIN FOR FORWARD SEARCH
C-----------------------------------------------------------------------

      IMPLICIT NONE






# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"
























      INTEGER          LNGMAX
      PARAMETER        (LNGMAX = 15000)
      INTEGER          TYPE1
      PARAMETER        (TYPE1 = 0)
      INTEGER          TYPE2
      PARAMETER        (TYPE2 = 1)
      INTEGER          TYPE3
      PARAMETER        (TYPE3 = 2)
      INTEGER          TYPE4
      PARAMETER        (TYPE4 = 3)
      COMMON /CRLONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP



     *                ,LLONGI,FLGFIT
# 3961 "corsika.h"
      DOUBLE PRECISION ADLONG(0:LNGMAX,19),AELONG(0:LNGMAX,10),
     *                 APLONG(0:LNGMAX,10),DLONG(0:LNGMAX,19),
     *                 ELONG(0:LNGMAX,10),
     *                 HLONG(0:LNGMAX),PLONG(0:LNGMAX,10),
     *                 SDLONG(0:LNGMAX,19),SELONG(0:LNGMAX,10),
     *                 SPLONG(0:LNGMAX,10),THSTEP,THSTPI




      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT

      COMMON /CRSLANT/ RLONG,THCKRL,CTH,STHCPH,STHSPH,RLOFF
      DOUBLE PRECISION RLONG(0:LNGMAX),THCKRL(0:LNGMAX),
     *                 CTH,STHCPH,STHSPH,RLOFF


















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"










      COMMON /CROBSPAR/OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP,
     *                 THETPR,PHIPR,

     *                 CORRXY,







     *                 NOBSLV
      DOUBLE PRECISION OBSLEV(20),THCKOB(20),XOFF(20),YOFF(20),
     *                 HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2)

     *                 ,CORRXY







      INTEGER          NOBSLV



# 4262 "corsika.h"



      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL





      DOUBLE PRECISION GAMMA,COSTHE,PHIX,PHIY,H,T,X,Y,CHI,BETA,GCM,ECM

     *                 ,WEIGHT


     *                 ,HAPP,COSTAP,COSTEA




      EQUIVALENCE      (CURPAR(1), GAMMA ), (CURPAR(2), COSTHE),
     *                 (CURPAR(3), PHIX  ), (CURPAR(4), PHIY  ),
     *                 (CURPAR(5), H     ), (CURPAR(6), T     ),
     *                 (CURPAR(7), X     ), (CURPAR(8), Y     ),
     *                 (CURPAR(9), CHI   ), (CURPAR(10),BETA  ),
     *                 (CURPAR(11),GCM   ), (CURPAR(12),ECM   )

     *                ,(CURPAR(13),WEIGHT)


     *                ,(CURPAR(14),HAPP  ), (CURPAR(15),COSTAP),
     *                 (CURPAR(16),COSTEA)















# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 21314 "corsika.F" 2

      DOUBLE PRECISION AUXIL1,HHH,XXX,YYY,HH,XX,YY

      DOUBLE PRECISION PHI1,RRR,SINTEA

      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 ( 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


      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

# 21788 "corsika.F"

*-- Author :    The CORSIKA development group   31/05/2017
C=======================================================================
# 21836 "corsika.F"

*-- 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




# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























      COMMON /CRCURVE/ CHAPAR,DEP,ERR,NSTP
      DOUBLE PRECISION CHAPAR(15000),DEP(15000),ERR(15000)
      INTEGER          NSTP





























































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"



      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL



# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 21887 "corsika.F" 2

      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
# 22228 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"











      COMMON /CRCONSTA/PI,PI2,OB3,TB3,ENEPER,SQRT3
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER,SQRT3












































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"



      COMMON /CRMUMULT/CHC,OMC,PHISCT,STEPL,VSCAT,FMOLI
      DOUBLE PRECISION CHC,OMC,PHISCT,STEPL,VSCAT
      LOGICAL          FMOLI










# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"








      COMMON /CRPAM/   PAMA,SIGNUM,RESTMS,DECTIM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000),
     *                 DECTIM(200)






      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL





      DOUBLE PRECISION GAMMA,COSTHE,PHIX,PHIY,H,T,X,Y,CHI,BETA,GCM,ECM

     *                 ,WEIGHT


     *                 ,HAPP,COSTAP,COSTEA




      EQUIVALENCE      (CURPAR(1), GAMMA ), (CURPAR(2), COSTHE),
     *                 (CURPAR(3), PHIX  ), (CURPAR(4), PHIY  ),
     *                 (CURPAR(5), H     ), (CURPAR(6), T     ),
     *                 (CURPAR(7), X     ), (CURPAR(8), Y     ),
     *                 (CURPAR(9), CHI   ), (CURPAR(10),BETA  ),
     *                 (CURPAR(11),GCM   ), (CURPAR(12),ECM   )

     *                ,(CURPAR(13),WEIGHT)


     *                ,(CURPAR(14),HAPP  ), (CURPAR(15),COSTAP),
     *                 (CURPAR(16),COSTEA)















# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"

























      COMMON /CRRANDPA/RD,FAC,U1,U2,NSEQ,ISEED,KNOR
      DOUBLE PRECISION RD(3000),FAC,U1,U2



      INTEGER          ISEED(3,10),NSEQ

      LOGICAL          KNOR



# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 22228 "corsika.F" 2

      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




# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"











      COMMON /CRCONSTA/PI,PI2,OB3,TB3,ENEPER,SQRT3
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER,SQRT3












































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"

























      COMMON /CRRANDPA/RD,FAC,U1,U2,NSEQ,ISEED,KNOR
      DOUBLE PRECISION RD(3000),FAC,U1,U2



      INTEGER          ISEED(3,10),NSEQ

      LOGICAL          KNOR



# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 22371 "corsika.F" 2

      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 = NINT(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
# 22435 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"



      COMMON /CRAIR/   COMPOS,PROBTA,AVERAW,AVOGDR
      DOUBLE PRECISION COMPOS(3),PROBTA(3),AVERAW,AVOGDR



# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"











      COMMON /CRCONSTA/PI,PI2,OB3,TB3,ENEPER,SQRT3
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER,SQRT3
























































      COMMON /CRELABCT/ELCUT
      DOUBLE PRECISION ELCUT(4)


















# 3811 "corsika.h"

# 3824 "corsika.h"










      COMMON /CRGENER/ GEN,ALEVEL
      DOUBLE PRECISION GEN,ALEVEL











# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"
























      INTEGER          LNGMAX
      PARAMETER        (LNGMAX = 15000)
      INTEGER          TYPE1
      PARAMETER        (TYPE1 = 0)
      INTEGER          TYPE2
      PARAMETER        (TYPE2 = 1)
      INTEGER          TYPE3
      PARAMETER        (TYPE3 = 2)
      INTEGER          TYPE4
      PARAMETER        (TYPE4 = 3)
      COMMON /CRLONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP



     *                ,LLONGI,FLGFIT
# 3961 "corsika.h"
      DOUBLE PRECISION ADLONG(0:LNGMAX,19),AELONG(0:LNGMAX,10),
     *                 APLONG(0:LNGMAX,10),DLONG(0:LNGMAX,19),
     *                 ELONG(0:LNGMAX,10),
     *                 HLONG(0:LNGMAX),PLONG(0:LNGMAX,10),
     *                 SDLONG(0:LNGMAX,19),SELONG(0:LNGMAX,10),
     *                 SPLONG(0:LNGMAX,10),THSTEP,THSTPI




      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT

      COMMON /CRSLANT/ RLONG,THCKRL,CTH,STHCPH,STHSPH,RLOFF
      DOUBLE PRECISION RLONG(0:LNGMAX),THCKRL(0:LNGMAX),
     *                 CTH,STHCPH,STHSPH,RLOFF


















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"


















      COMMON /CRMUPART/AATOM,AMUPAR,BCUT,CMUON,CTAU,CONSTKINE,
     *                 EBYMU,EBYTAU,EE,SE,VFRAC,VMAX,VMIN,ZATOM,
     *                 MT,FMUBRM,FMUNUC,FMUORG






      DOUBLE PRECISION AMUPAR(0:18),BCUT,CMUON(11),CTAU(11),


     *                 AATOM,CONSTKINE,EBYMU,EBYTAU,EE,SE,
     *                 VFRAC,VMAX,VMIN,ZATOM
      INTEGER          MT
      LOGICAL          FMUBRM,FMUNUC,FMUORG



# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"








      COMMON /CRPAM/   PAMA,SIGNUM,RESTMS,DECTIM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000),
     *                 DECTIM(200)






      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL





      DOUBLE PRECISION GAMMA,COSTHE,PHIX,PHIY,H,T,X,Y,CHI,BETA,GCM,ECM

     *                 ,WEIGHT


     *                 ,HAPP,COSTAP,COSTEA




      EQUIVALENCE      (CURPAR(1), GAMMA ), (CURPAR(2), COSTHE),
     *                 (CURPAR(3), PHIX  ), (CURPAR(4), PHIY  ),
     *                 (CURPAR(5), H     ), (CURPAR(6), T     ),
     *                 (CURPAR(7), X     ), (CURPAR(8), Y     ),
     *                 (CURPAR(9), CHI   ), (CURPAR(10),BETA  ),
     *                 (CURPAR(11),GCM   ), (CURPAR(12),ECM   )

     *                ,(CURPAR(13),WEIGHT)


     *                ,(CURPAR(14),HAPP  ), (CURPAR(15),COSTAP),
     *                 (CURPAR(16),COSTEA)















# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"



      COMMON /CRPOLAR/ POLART,POLARF
      DOUBLE PRECISION POLART,POLARF




















      COMMON /CRRANDPA/RD,FAC,U1,U2,NSEQ,ISEED,KNOR
      DOUBLE PRECISION RD(3000),FAC,U1,U2



      INTEGER          ISEED(3,10),NSEQ

      LOGICAL          KNOR



# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"











      COMMON /CRREST/  CONTNE,TAR,LIT
      DOUBLE PRECISION CONTNE(3),TAR
      INTEGER          LIT





      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"










      COMMON /CRSIGMU/ BREMSTAB,NUCTAB,PAIRTAB,DEDXMU,DEDXM,
     *                 FRABTN,FRANTN,FRAPTN,FRBTNO,FRNTNO,FRPTNO,
     *                 SIGBRM,SIGNUC,SIGPRM
      DOUBLE PRECISION BREMSTAB(141,3,2),NUCTAB(141,3,2),
     *                 PAIRTAB(141,3,2), DEDXMU(141,3,2),DEDXM(141,2),
     *                 FRABTN,FRANTN,FRAPTN,FRBTNO,FRNTNO,FRPTNO,
     *                 SIGBRM,SIGNUC,SIGPRM



# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 22435 "corsika.F" 2

      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





      INTEGER          LBIN
      EXTERNAL         LBIN

      SAVE
      DOUBLE PRECISION CBRSGM,THICK
      EXTERNAL         CBRSGM,THICK
      DATA             ALFA1 / 0.625D0 /
C-----------------------------------------------------------------------


      IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=0,9),WEIGHT
  444 FORMAT(' MUBREM: CURPAR=',1P,11E11.3)





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

      SECPAR(13) = WEIGHT


      SECPAR(14) = CURPAR(14)
      SECPAR(15) = CURPAR(15)
      SECPAR(16) = CURPAR(16)
# 22495 "corsika.F"
      IF ( LLONGI ) LHEIGH = MIN( LBIN( X,Y,HAPP,1 ), NSTEP+1 )







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 1
      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

          DLONG(LHEIGH,1) = DLONG(LHEIGH,1) + SECPAR(1) * WEIGHT



        ENDIF
# 22606 "corsika.F"
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 ( SECPAR(2) .GE. C(29) ) THEN



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

          DLONG(LHEIGH,11) = DLONG(LHEIGH,11) + SECPAR(1) * WEIGHT



        ENDIF
# 22689 "corsika.F"
      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
# 22737 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"











      COMMON /CRCONSTA/PI,PI2,OB3,TB3,ENEPER,SQRT3
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER,SQRT3












































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"



      COMMON /CRMUMULT/CHC,OMC,PHISCT,STEPL,VSCAT,FMOLI
      DOUBLE PRECISION CHC,OMC,PHISCT,STEPL,VSCAT
      LOGICAL          FMOLI










# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"








      COMMON /CRPAM/   PAMA,SIGNUM,RESTMS,DECTIM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000),
     *                 DECTIM(200)






      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL





      DOUBLE PRECISION GAMMA,COSTHE,PHIX,PHIY,H,T,X,Y,CHI,BETA,GCM,ECM

     *                 ,WEIGHT


     *                 ,HAPP,COSTAP,COSTEA




      EQUIVALENCE      (CURPAR(1), GAMMA ), (CURPAR(2), COSTHE),
     *                 (CURPAR(3), PHIX  ), (CURPAR(4), PHIY  ),
     *                 (CURPAR(5), H     ), (CURPAR(6), T     ),
     *                 (CURPAR(7), X     ), (CURPAR(8), Y     ),
     *                 (CURPAR(9), CHI   ), (CURPAR(10),BETA  ),
     *                 (CURPAR(11),GCM   ), (CURPAR(12),ECM   )

     *                ,(CURPAR(13),WEIGHT)


     *                ,(CURPAR(14),HAPP  ), (CURPAR(15),COSTAP),
     *                 (CURPAR(16),COSTEA)















# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"

























      COMMON /CRRANDPA/RD,FAC,U1,U2,NSEQ,ISEED,KNOR
      DOUBLE PRECISION RD(3000),FAC,U1,U2



      INTEGER          ISEED(3,10),NSEQ

      LOGICAL          KNOR



# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 22737 "corsika.F" 2

      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
# 22800 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"











      COMMON /CRCONSTA/PI,PI2,OB3,TB3,ENEPER,SQRT3
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER,SQRT3












































































# 3811 "corsika.h"

# 3824 "corsika.h"










      COMMON /CRGENER/ GEN,ALEVEL
      DOUBLE PRECISION GEN,ALEVEL











# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"
























      INTEGER          LNGMAX
      PARAMETER        (LNGMAX = 15000)
      INTEGER          TYPE1
      PARAMETER        (TYPE1 = 0)
      INTEGER          TYPE2
      PARAMETER        (TYPE2 = 1)
      INTEGER          TYPE3
      PARAMETER        (TYPE3 = 2)
      INTEGER          TYPE4
      PARAMETER        (TYPE4 = 3)
      COMMON /CRLONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP



     *                ,LLONGI,FLGFIT
# 3961 "corsika.h"
      DOUBLE PRECISION ADLONG(0:LNGMAX,19),AELONG(0:LNGMAX,10),
     *                 APLONG(0:LNGMAX,10),DLONG(0:LNGMAX,19),
     *                 ELONG(0:LNGMAX,10),
     *                 HLONG(0:LNGMAX),PLONG(0:LNGMAX,10),
     *                 SDLONG(0:LNGMAX,19),SELONG(0:LNGMAX,10),
     *                 SPLONG(0:LNGMAX,10),THSTEP,THSTPI




      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT

      COMMON /CRSLANT/ RLONG,THCKRL,CTH,STHCPH,STHSPH,RLOFF
      DOUBLE PRECISION RLONG(0:LNGMAX),THCKRL(0:LNGMAX),
     *                 CTH,STHCPH,STHSPH,RLOFF


















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"








      COMMON /CRPAM/   PAMA,SIGNUM,RESTMS,DECTIM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000),
     *                 DECTIM(200)






      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL





      DOUBLE PRECISION GAMMA,COSTHE,PHIX,PHIY,H,T,X,Y,CHI,BETA,GCM,ECM

     *                 ,WEIGHT


     *                 ,HAPP,COSTAP,COSTEA




      EQUIVALENCE      (CURPAR(1), GAMMA ), (CURPAR(2), COSTHE),
     *                 (CURPAR(3), PHIX  ), (CURPAR(4), PHIY  ),
     *                 (CURPAR(5), H     ), (CURPAR(6), T     ),
     *                 (CURPAR(7), X     ), (CURPAR(8), Y     ),
     *                 (CURPAR(9), CHI   ), (CURPAR(10),BETA  ),
     *                 (CURPAR(11),GCM   ), (CURPAR(12),ECM   )

     *                ,(CURPAR(13),WEIGHT)


     *                ,(CURPAR(14),HAPP  ), (CURPAR(15),COSTAP),
     *                 (CURPAR(16),COSTEA)















# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"



      COMMON /CRPOLAR/ POLART,POLARF
      DOUBLE PRECISION POLART,POLARF




















      COMMON /CRRANDPA/RD,FAC,U1,U2,NSEQ,ISEED,KNOR
      DOUBLE PRECISION RD(3000),FAC,U1,U2



      INTEGER          ISEED(3,10),NSEQ

      LOGICAL          KNOR



# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 22800 "corsika.F" 2

      DOUBLE PRECISION AUX2,COSDE,COSTH3,COS3CM,COS3C1,COS3C2,
     *                 E3CM,GAMMA3,GAMMA4,PHINN,PHI3CM,PHI3C2,PHI31,
     *                 P3CM,THICK,XI
      INTEGER          I
# 22820 "corsika.F"
      INTEGER          LBIN
      EXTERNAL         LBIN

      SAVE
      EXTERNAL         THICK
C-----------------------------------------------------------------------


      IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=0,9),WEIGHT
  444 FORMAT(' MUDECY: CURPAR=',1P,11E11.3)





C  COPY VERTEX COORDINATES TO SECPAR
      DO  I = 5, 8
        SECPAR(I) = CURPAR(I)
      ENDDO
      SECPAR( 9) = GEN
      SECPAR(10) = ALEVEL

      SECPAR(13) = WEIGHT


      SECPAR(14) = CURPAR(14)
      SECPAR(15) = CURPAR(15)
      SECPAR(16) = CURPAR(16)
# 22868 "corsika.F"
      IF ( LLONGI ) LHEIGH = MIN( LBIN( X,Y,HAPP,1 ), NSTEP+1 )







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

# 23077 "corsika.F"
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 ( 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, 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 ( SECPAR(2) .GE. C(29) ) THEN



        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

            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





          ENDIF
        ENDIF
# 23146 "corsika.F"
      ENDIF
      POLART = 0.D0
      POLARF = 0.D0

      IF ( LLONGI ) THEN
C  ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT
        GAMMA4 = GAMMA * PAMA(5) - GAMMA3 * PAMA(2)

        DLONG(LHEIGH,8) = DLONG(LHEIGH,8) + GAMMA4 * WEIGHT



      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
# 23209 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"



      COMMON /CRAIR/   COMPOS,PROBTA,AVERAW,AVOGDR
      DOUBLE PRECISION COMPOS(3),PROBTA(3),AVERAW,AVOGDR



# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"



      COMMON /CRBUFFS/ RUNH,RUNE,EVTH,EVTE,DATAB,ARRAYLONG,LH

     *                 ,WRRUNH,WRRUNE,WREVTH,WREVTE

      INTEGER          MAXBUF,MAXLEN

      PARAMETER        (MAXBUF=39*8)
# 3681 "corsika.h"
      PARAMETER        (MAXLEN=16)
# 3693 "corsika.h"
      REAL             RUNH(MAXBUF),EVTH(MAXBUF),EVTE(MAXBUF),
     *                 RUNE(MAXBUF),DATAB(MAXBUF),ARRAYLONG(MAXBUF)
      INTEGER          LH

      LOGICAL          WRRUNH,WRRUNE,WREVTH,WREVTE

      CHARACTER*4      CRUNH,CRUNE,CEVTH,CEVTE,CLONG
      EQUIVALENCE      (RUNH(1),CRUNH), (RUNE(1),CRUNE)
      EQUIVALENCE      (EVTH(1),CEVTH), (EVTE(1),CEVTE)
      EQUIVALENCE      (ARRAYLONG(1),CLONG)













      COMMON /CRCONSTA/PI,PI2,OB3,TB3,ENEPER,SQRT3
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER,SQRT3
















































      COMMON /CREGSDEB/JCLOCK,NCLOCK,FEGSDB
      INTEGER          JCLOCK,NCLOCK
      LOGICAL          FEGSDB





      COMMON /CRELABCT/ELCUT
      DOUBLE PRECISION ELCUT(4)


















# 3811 "corsika.h"

# 3824 "corsika.h"










      COMMON /CRGENER/ GEN,ALEVEL
      DOUBLE PRECISION GEN,ALEVEL











# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"
























      INTEGER          LNGMAX
      PARAMETER        (LNGMAX = 15000)
      INTEGER          TYPE1
      PARAMETER        (TYPE1 = 0)
      INTEGER          TYPE2
      PARAMETER        (TYPE2 = 1)
      INTEGER          TYPE3
      PARAMETER        (TYPE3 = 2)
      INTEGER          TYPE4
      PARAMETER        (TYPE4 = 3)
      COMMON /CRLONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP



     *                ,LLONGI,FLGFIT
# 3961 "corsika.h"
      DOUBLE PRECISION ADLONG(0:LNGMAX,19),AELONG(0:LNGMAX,10),
     *                 APLONG(0:LNGMAX,10),DLONG(0:LNGMAX,19),
     *                 ELONG(0:LNGMAX,10),
     *                 HLONG(0:LNGMAX),PLONG(0:LNGMAX,10),
     *                 SDLONG(0:LNGMAX,19),SELONG(0:LNGMAX,10),
     *                 SPLONG(0:LNGMAX,10),THSTEP,THSTPI




      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT

      COMMON /CRSLANT/ RLONG,THCKRL,CTH,STHCPH,STHSPH,RLOFF
      DOUBLE PRECISION RLONG(0:LNGMAX),THCKRL(0:LNGMAX),
     *                 CTH,STHCPH,STHSPH,RLOFF


















# 4005 "corsika.h"
















# 4047 "corsika.h"



      COMMON /CRMULT/  EKINL,MSMM,MULTMA,MULTOT
      DOUBLE PRECISION EKINL
      INTEGER          MSMM,MULTMA(40,13),MULTOT(40,13)



# 4075 "corsika.h"

# 4091 "corsika.h"


















      COMMON /CRMUPART/AATOM,AMUPAR,BCUT,CMUON,CTAU,CONSTKINE,
     *                 EBYMU,EBYTAU,EE,SE,VFRAC,VMAX,VMIN,ZATOM,
     *                 MT,FMUBRM,FMUNUC,FMUORG






      DOUBLE PRECISION AMUPAR(0:18),BCUT,CMUON(11),CTAU(11),


     *                 AATOM,CONSTKINE,EBYMU,EBYTAU,EE,SE,
     *                 VFRAC,VMAX,VMIN,ZATOM
      INTEGER          MT
      LOGICAL          FMUBRM,FMUNUC,FMUORG



# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"


















      COMMON /CRNPARTI/NPARTO,NPART2
      DOUBLE PRECISION NPARTO(20,28), NPART2(20,28),
     *                 NPHOTO(20),NPOSIT(20),NELECT(20),
     *                 NNU(20),NMUP(20),NMUM(20),NPI0(20),NPIP(20),
     *                 NPIM(20),NK0L(20),NKPL(20),NKMI(20),NNEUTR(20),
     *                 NPROTO(20),NPROTB(20),NK0S(20),NHYP(20),
     *                 NNEUTB(20),NDEUT(20),NTRIT(20),NHELI3(20),
     *                 NALPHA(20),NCHRMM(20),NCHRMB(20),NOTHER(20),
     *                 NMUOND,NMUONE
      EQUIVALENCE (NPARTO(1, 1),NPHOTO(1)), (NPARTO(1, 2),NPOSIT(1)),
     *            (NPARTO(1, 3),NELECT(1)), (NPARTO(1, 4),NNU(1))   ,
     *            (NPARTO(1, 5),NMUP(1))  , (NPARTO(1, 6),NMUM(1))  ,
     *            (NPARTO(1, 7),NPI0(1))  , (NPARTO(1, 8),NPIP(1))  ,
     *            (NPARTO(1, 9),NPIM(1))  , (NPARTO(1,10),NK0L(1))  ,
     *            (NPARTO(1,11),NKPL(1))  , (NPARTO(1,12),NKMI(1))  ,
     *            (NPARTO(1,13),NNEUTR(1)), (NPARTO(1,14),NPROTO(1)),
     *            (NPARTO(1,15),NPROTB(1)), (NPARTO(1,16),NK0S(1))  ,
     *            (NPARTO(1,18),NHYP(1))  , (NPARTO(1,19),NDEUT(1)) ,
     *            (NPARTO(1,20),NTRIT(1)) , (NPARTO(1,21),NHELI3(1)),
     *            (NPARTO(1,22),NALPHA(1)), (NPARTO(1,23),NCHRMM(1)),
     *            (NPARTO(1,24),NCHRMB(1)), (NPARTO(1,25),NOTHER(1)),
     *            (NPARTO(1,26),NMUOND)   , (NPARTO(1,27),NNEUTB(1)),
     *            (NPARTO(1,28),NMUONE)












      COMMON /CROBSPAR/OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP,
     *                 THETPR,PHIPR,

     *                 CORRXY,







     *                 NOBSLV
      DOUBLE PRECISION OBSLEV(20),THCKOB(20),XOFF(20),YOFF(20),
     *                 HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2)

     *                 ,CORRXY







      INTEGER          NOBSLV










      COMMON /CRPAM/   PAMA,SIGNUM,RESTMS,DECTIM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000),
     *                 DECTIM(200)






      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL



# 4332 "corsika.h"









# 4354 "corsika.h"



      COMMON /CRPION/  PI0MSQ,PITHR,PICMAS,PI0MAS,AMASK0,AMASKC,AMASPR,
     *                 AMASNT
      DOUBLE PRECISION PI0MSQ,PITHR,PICMAS,PI0MAS,AMASK0,AMASKC,AMASPR,
     *                 AMASNT



# 4383 "corsika.h"



      COMMON /CRPOLAR/ POLART,POLARF
      DOUBLE PRECISION POLART,POLARF




















      COMMON /CRRANDPA/RD,FAC,U1,U2,NSEQ,ISEED,KNOR
      DOUBLE PRECISION RD(3000),FAC,U1,U2



      INTEGER          ISEED(3,10),NSEQ

      LOGICAL          KNOR



# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"










      COMMON /CRREJECT/AVNREJ,ALTMIN,ANEXP,THICKA,THICKD,CUTLN,EONCUT,

     *                 EFRCTHN,ETHINN,ETHINNG,THINRAT,THINRATH,WEITRAT,
     *                 WEITRATH,EEFRTHN,

     *                 FNPRIM
      DOUBLE PRECISION AVNREJ(20),ALTMIN(20),ANEXP(20),THICKA(20),
     *                 THICKD(20),CUTLN,EONCUT

     *                 ,EFRCTHN,ETHINN,ETHINNG,THINRAT,THINRATH,WEITRAT,
     *                 WEITRATH,EEFRTHN

      LOGICAL          FNPRIM













      COMMON /CRREST/  CONTNE,TAR,LIT
      DOUBLE PRECISION CONTNE(3),TAR
      INTEGER          LIT





      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"










      COMMON /CRSIGMU/ BREMSTAB,NUCTAB,PAIRTAB,DEDXMU,DEDXM,
     *                 FRABTN,FRANTN,FRAPTN,FRBTNO,FRNTNO,FRPTNO,
     *                 SIGBRM,SIGNUC,SIGPRM
      DOUBLE PRECISION BREMSTAB(141,3,2),NUCTAB(141,3,2),
     *                 PAIRTAB(141,3,2), DEDXMU(141,3,2),DEDXM(141,2),
     *                 FRABTN,FRANTN,FRAPTN,FRBTNO,FRNTNO,FRPTNO,
     *                 SIGBRM,SIGNUC,SIGPRM





      COMMON /CRSTACKE/E,TIM,U,V,W,X,Y,Z,DNEAR,

     *                 WT,


     *                 ZAP,WAP,WA,XXXX,YYYY,


     *                 TSLAN,




     *                 IQ,IGEN,IR,IOBS,LPCTE,NP
      DOUBLE PRECISION E(60),TIM(60),U(60),V(60),W(60),
     *                 X(60),Y(60),Z(60),DNEAR(60)

     *                 ,WT(60)


     *                 ,ZAP(60),WAP(60),WA(60),XXXX(60),YYYY(60)


     *                 ,TSLAN(60)




      INTEGER          IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP



# 4821 "corsika.h"
















# 4853 "corsika.h"



      COMMON /CRTHNVAR/STACKINT,

     *                 EEPP,ELIM,


     *                 RMAX,RMAX2,
     *                 WMAX,WMAX0,WMAXE,WMAXE0,WMAXEM,

     *                 INT_ICOUNT,MODETHN,THINNING

     *                 ,RLIM,WLIM

      INTEGER          MAXICOUNT
      PARAMETER        (MAXICOUNT = 200000)
# 4883 "corsika.h"
      DOUBLE PRECISION STACKINT(0:16,MAXICOUNT)
# 4892 "corsika.h"
     *                 ,EEPP(MAXICOUNT),ELIM


     *                 ,RMAX,RMAX2
     *                 ,WMAX,WMAX0,WMAXE,WMAXE0,WMAXEM

      INTEGER          INT_ICOUNT,MODETHN
      LOGICAL          THINNING

      LOGICAL           RLIM,WLIM




















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 23209 "corsika.F" 2

      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






      DOUBLE PRECISION PHI1,RRR

      DOUBLE PRECISION AUXIL,THCKSI,XXX,YYY,ZZ1
      INTEGER          LBIN
      EXTERNAL         LBIN,THCKSI

      SAVE
      DOUBLE PRECISION CNUSGM,THICK
      EXTERNAL         CNUSGM,THICK
C-----------------------------------------------------------------------


      IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=0,9),CURPAR(13)
  444 FORMAT(' MUNUCL: CURPAR=',1P,11E11.3)





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

      SECPAR(13) = CURPAR(13)
      AMUPR2(13) = CURPAR(13)


      SECPAR(14) = CURPAR(14)
      AMUPR2(14) = CURPAR(14)
      SECPAR(15) = CURPAR(15)
      AMUPR2(15) = CURPAR(15)
      SECPAR(16) = CURPAR(16)
      AMUPR2(16) = CURPAR(16)
# 23297 "corsika.F"
      IF ( LLONGI ) LHEIGH = MIN( LBIN(CURPAR(7),CURPAR(8),CURPAR(14),
     *                                                   1), NSTEP+1 )








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 1
      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 ( DEBUG ) WRITE(MDEBUG,445) (CURPAR(I),I=0,9),CURPAR(13)
  445 FORMAT(' MUNUCL: PIGEN =',1P,11E11.3)




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

          DLONG(LHEIGH,1) = DLONG(LHEIGH,1) + CURPAR(1) * CURPAR(13)



        ENDIF
# 23450 "corsika.F"

      ELSE
        CURPAR(12) = SQRT( (PAMA(14) + CURPAR(1)*2.D0)*PAMA(14) )
        CURPAR(11) = (CURPAR(1) + PAMA(14))/CURPAR(12)








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)

        WT(1)  = CURPAR(13)


        ZAP(1) =-CURPAR(14)
        WAP(1) = CURPAR(15)
        WA(1)  = CURPAR(16)






        IF ( LLONGI ) 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(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







          AUXIL    = XXX*STHCPH -YYY*STHSPH +ZZ1*CTH + RLOFF
          TSLAN(1) = THCKSI( AUXIL )
          LPCTE(1) = MIN( INT( TSLAN(1)*THSTPI + 1.D0 ), NSTEP+1 )




        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)

      SECPAR(13) = AMUPR2(13)


      SECPAR(14) = AMUPR2(14)
      SECPAR(15) = AMUPR2(15)
      SECPAR(16) = AMUPR2(16)
# 23571 "corsika.F"
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)






        NMUONE  = NMUONE + SECPAR(13)



        IF ( LLONGI ) THEN
C  ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT

          DLONG(LHEIGH,5) = DLONG(LHEIGH,5) + E1 * CURPAR(13)



        ENDIF
# 23625 "corsika.F"
      ELSE

        IF ( SECPAR(2) .GE. C(29) ) THEN



C  WRITE RESIDUAL MUON/TAU TO STACK
          CALL TSTACK
          CALL TSTEND
        ELSE
C  MUON DID NOT SURVIVE NUCLEAR INTERACTION (ANGULAR CUT)






          NMUONE  = NMUONE + SECPAR(13)




          IF ( LLONGI ) THEN
C  ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT

            DLONG(LHEIGH,15) = DLONG(LHEIGH,15) + E1 * SECPAR(13)



          ENDIF
# 23675 "corsika.F"
        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
# 23722 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"



      COMMON /CRAIR/   COMPOS,PROBTA,AVERAW,AVOGDR
      DOUBLE PRECISION COMPOS(3),PROBTA(3),AVERAW,AVOGDR



# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"











      COMMON /CRCONSTA/PI,PI2,OB3,TB3,ENEPER,SQRT3
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER,SQRT3
























































      COMMON /CRELABCT/ELCUT
      DOUBLE PRECISION ELCUT(4)


















# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"



      COMMON /CRMUMULT/CHC,OMC,PHISCT,STEPL,VSCAT,FMOLI
      DOUBLE PRECISION CHC,OMC,PHISCT,STEPL,VSCAT
      LOGICAL          FMOLI












      COMMON /CRMUPART/AATOM,AMUPAR,BCUT,CMUON,CTAU,CONSTKINE,
     *                 EBYMU,EBYTAU,EE,SE,VFRAC,VMAX,VMIN,ZATOM,
     *                 MT,FMUBRM,FMUNUC,FMUORG






      DOUBLE PRECISION AMUPAR(0:18),BCUT,CMUON(11),CTAU(11),


     *                 AATOM,CONSTKINE,EBYMU,EBYTAU,EE,SE,
     *                 VFRAC,VMAX,VMIN,ZATOM
      INTEGER          MT
      LOGICAL          FMUBRM,FMUNUC,FMUORG



# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"








      COMMON /CRPAM/   PAMA,SIGNUM,RESTMS,DECTIM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000),
     *                 DECTIM(200)






      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL



# 4332 "corsika.h"









# 4354 "corsika.h"



      COMMON /CRPION/  PI0MSQ,PITHR,PICMAS,PI0MAS,AMASK0,AMASKC,AMASPR,
     *                 AMASNT
      DOUBLE PRECISION PI0MSQ,PITHR,PICMAS,PI0MAS,AMASK0,AMASKC,AMASPR,
     *                 AMASNT



# 4383 "corsika.h"










      COMMON /CRPRIMSP/PSLOPE,LLIMIT,ULIMIT,LL,UL,SLEX,ISPEC
      DOUBLE PRECISION PSLOPE,LLIMIT,ULIMIT,LL,UL,SLEX
      INTEGER          ISPEC










# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"










      COMMON /CRSIGMU/ BREMSTAB,NUCTAB,PAIRTAB,DEDXMU,DEDXM,
     *                 FRABTN,FRANTN,FRAPTN,FRBTNO,FRNTNO,FRPTNO,
     *                 SIGBRM,SIGNUC,SIGPRM
      DOUBLE PRECISION BREMSTAB(141,3,2),NUCTAB(141,3,2),
     *                 PAIRTAB(141,3,2), DEDXMU(141,3,2),DEDXM(141,2),
     *                 FRABTN,FRANTN,FRAPTN,FRBTNO,FRNTNO,FRPTNO,
     *                 SIGBRM,SIGNUC,SIGPRM



# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 23722 "corsika.F" 2

      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 ( 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

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


      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
# 24098 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"



      COMMON /CRAIR/   COMPOS,PROBTA,AVERAW,AVOGDR
      DOUBLE PRECISION COMPOS(3),PROBTA(3),AVERAW,AVOGDR



# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"











      COMMON /CRCONSTA/PI,PI2,OB3,TB3,ENEPER,SQRT3
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER,SQRT3
























































      COMMON /CRELABCT/ELCUT
      DOUBLE PRECISION ELCUT(4)


















# 3811 "corsika.h"

# 3824 "corsika.h"










      COMMON /CRGENER/ GEN,ALEVEL
      DOUBLE PRECISION GEN,ALEVEL











# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"
























      INTEGER          LNGMAX
      PARAMETER        (LNGMAX = 15000)
      INTEGER          TYPE1
      PARAMETER        (TYPE1 = 0)
      INTEGER          TYPE2
      PARAMETER        (TYPE2 = 1)
      INTEGER          TYPE3
      PARAMETER        (TYPE3 = 2)
      INTEGER          TYPE4
      PARAMETER        (TYPE4 = 3)
      COMMON /CRLONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP



     *                ,LLONGI,FLGFIT
# 3961 "corsika.h"
      DOUBLE PRECISION ADLONG(0:LNGMAX,19),AELONG(0:LNGMAX,10),
     *                 APLONG(0:LNGMAX,10),DLONG(0:LNGMAX,19),
     *                 ELONG(0:LNGMAX,10),
     *                 HLONG(0:LNGMAX),PLONG(0:LNGMAX,10),
     *                 SDLONG(0:LNGMAX,19),SELONG(0:LNGMAX,10),
     *                 SPLONG(0:LNGMAX,10),THSTEP,THSTPI




      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT

      COMMON /CRSLANT/ RLONG,THCKRL,CTH,STHCPH,STHSPH,RLOFF
      DOUBLE PRECISION RLONG(0:LNGMAX),THCKRL(0:LNGMAX),
     *                 CTH,STHCPH,STHSPH,RLOFF


















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"


















      COMMON /CRMUPART/AATOM,AMUPAR,BCUT,CMUON,CTAU,CONSTKINE,
     *                 EBYMU,EBYTAU,EE,SE,VFRAC,VMAX,VMIN,ZATOM,
     *                 MT,FMUBRM,FMUNUC,FMUORG






      DOUBLE PRECISION AMUPAR(0:18),BCUT,CMUON(11),CTAU(11),


     *                 AATOM,CONSTKINE,EBYMU,EBYTAU,EE,SE,
     *                 VFRAC,VMAX,VMIN,ZATOM
      INTEGER          MT
      LOGICAL          FMUBRM,FMUNUC,FMUORG



# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"








      COMMON /CRPAM/   PAMA,SIGNUM,RESTMS,DECTIM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000),
     *                 DECTIM(200)






      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL





      DOUBLE PRECISION GAMMA,COSTHE,PHIX,PHIY,H,T,X,Y,CHI,BETA,GCM,ECM

     *                 ,WEIGHT


     *                 ,HAPP,COSTAP,COSTEA




      EQUIVALENCE      (CURPAR(1), GAMMA ), (CURPAR(2), COSTHE),
     *                 (CURPAR(3), PHIX  ), (CURPAR(4), PHIY  ),
     *                 (CURPAR(5), H     ), (CURPAR(6), T     ),
     *                 (CURPAR(7), X     ), (CURPAR(8), Y     ),
     *                 (CURPAR(9), CHI   ), (CURPAR(10),BETA  ),
     *                 (CURPAR(11),GCM   ), (CURPAR(12),ECM   )

     *                ,(CURPAR(13),WEIGHT)


     *                ,(CURPAR(14),HAPP  ), (CURPAR(15),COSTAP),
     *                 (CURPAR(16),COSTEA)















# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"



      COMMON /CRPOLAR/ POLART,POLARF
      DOUBLE PRECISION POLART,POLARF




















      COMMON /CRRANDPA/RD,FAC,U1,U2,NSEQ,ISEED,KNOR
      DOUBLE PRECISION RD(3000),FAC,U1,U2



      INTEGER          ISEED(3,10),NSEQ

      LOGICAL          KNOR



# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"











      COMMON /CRREST/  CONTNE,TAR,LIT
      DOUBLE PRECISION CONTNE(3),TAR
      INTEGER          LIT





      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"










      COMMON /CRSIGMU/ BREMSTAB,NUCTAB,PAIRTAB,DEDXMU,DEDXM,
     *                 FRABTN,FRANTN,FRAPTN,FRBTNO,FRNTNO,FRPTNO,
     *                 SIGBRM,SIGNUC,SIGPRM
      DOUBLE PRECISION BREMSTAB(141,3,2),NUCTAB(141,3,2),
     *                 PAIRTAB(141,3,2), DEDXMU(141,3,2),DEDXM(141,2),
     *                 FRABTN,FRANTN,FRAPTN,FRBTNO,FRNTNO,FRPTNO,
     *                 SIGBRM,SIGNUC,SIGPRM



# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 24098 "corsika.F" 2

      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





      INTEGER          LBIN
      EXTERNAL         LBIN

      SAVE
      DOUBLE PRECISION CPRSGM,DKOKOI,PPCS,THICK
      EXTERNAL         CPRSGM,DKOKOI,PPCS,THICK
C-----------------------------------------------------------------------


      IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=0,9),WEIGHT
  444 FORMAT(' MUPRPR: CURPAR=',1P,11E11.3)





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

      SECPAR(13) = WEIGHT


      SECPAR(14) = CURPAR(14)
      SECPAR(15) = CURPAR(15)
      SECPAR(16) = CURPAR(16)
# 24158 "corsika.F"
      IF ( LLONGI ) LHEIGH = MIN( LBIN( X,Y,HAPP,1 ), NSTEP+1 )







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 1
      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 ( SECPAR(2) .GE. C(29) ) THEN



          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

            DLONG(LHEIGH,13) = DLONG(LHEIGH,13) + (EPOS+PAMA(2))*WEIGHT



          ENDIF
# 24320 "corsika.F"
        ENDIF
      ELSE
        IF ( LLONGI ) THEN
C  ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT

          DLONG(LHEIGH,3) = DLONG(LHEIGH,3) + (EPOS+PAMA(2))*WEIGHT



        ENDIF
# 24353 "corsika.F"
      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 ( SECPAR(2) .GE. C(29) ) THEN



          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

            DLONG(LHEIGH,13) = DLONG(LHEIGH,13) + (ENEG-PAMA(3))*WEIGHT



          ENDIF
# 24403 "corsika.F"
        ENDIF
      ELSE
        IF ( LLONGI ) THEN
C  ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT

          DLONG(LHEIGH,3) = DLONG(LHEIGH,3) + (ENEG-PAMA(3))*WEIGHT



        ENDIF
# 24436 "corsika.F"
      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
# 24488 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"



      COMMON /CRBUFFS/ RUNH,RUNE,EVTH,EVTE,DATAB,ARRAYLONG,LH

     *                 ,WRRUNH,WRRUNE,WREVTH,WREVTE

      INTEGER          MAXBUF,MAXLEN

      PARAMETER        (MAXBUF=39*8)
# 3681 "corsika.h"
      PARAMETER        (MAXLEN=16)
# 3693 "corsika.h"
      REAL             RUNH(MAXBUF),EVTH(MAXBUF),EVTE(MAXBUF),
     *                 RUNE(MAXBUF),DATAB(MAXBUF),ARRAYLONG(MAXBUF)
      INTEGER          LH

      LOGICAL          WRRUNH,WRRUNE,WREVTH,WREVTE

      CHARACTER*4      CRUNH,CRUNE,CEVTH,CEVTE,CLONG
      EQUIVALENCE      (RUNH(1),CRUNH), (RUNE(1),CRUNE)
      EQUIVALENCE      (EVTH(1),CEVTH), (EVTE(1),CEVTE)
      EQUIVALENCE      (ARRAYLONG(1),CLONG)



























































































# 3811 "corsika.h"

# 3824 "corsika.h"










      COMMON /CRGENER/ GEN,ALEVEL
      DOUBLE PRECISION GEN,ALEVEL











# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"



      COMMON /CRIRET/  IRET1,IRET2,IRETE
      INTEGER          IRET1,IRET2
      LOGICAL          IRETE



# 3912 "corsika.h"
























      INTEGER          LNGMAX
      PARAMETER        (LNGMAX = 15000)
      INTEGER          TYPE1
      PARAMETER        (TYPE1 = 0)
      INTEGER          TYPE2
      PARAMETER        (TYPE2 = 1)
      INTEGER          TYPE3
      PARAMETER        (TYPE3 = 2)
      INTEGER          TYPE4
      PARAMETER        (TYPE4 = 3)
      COMMON /CRLONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP



     *                ,LLONGI,FLGFIT
# 3961 "corsika.h"
      DOUBLE PRECISION ADLONG(0:LNGMAX,19),AELONG(0:LNGMAX,10),
     *                 APLONG(0:LNGMAX,10),DLONG(0:LNGMAX,19),
     *                 ELONG(0:LNGMAX,10),
     *                 HLONG(0:LNGMAX),PLONG(0:LNGMAX,10),
     *                 SDLONG(0:LNGMAX,19),SELONG(0:LNGMAX,10),
     *                 SPLONG(0:LNGMAX,10),THSTEP,THSTPI




      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT

      COMMON /CRSLANT/ RLONG,THCKRL,CTH,STHCPH,STHSPH,RLOFF
      DOUBLE PRECISION RLONG(0:LNGMAX),THCKRL(0:LNGMAX),
     *                 CTH,STHCPH,STHSPH,RLOFF













      COMMON /CRMAGNET/BX,BZ,BVAL,BNORMC,BNORM,COSB,SINB,BLIMIT
      DOUBLE PRECISION BX,BZ,BVAL,BNORMC,BNORM,COSB,SINB,BLIMIT



# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"



      COMMON /CRMUMULT/CHC,OMC,PHISCT,STEPL,VSCAT,FMOLI
      DOUBLE PRECISION CHC,OMC,PHISCT,STEPL,VSCAT
      LOGICAL          FMOLI












      COMMON /CRMUPART/AATOM,AMUPAR,BCUT,CMUON,CTAU,CONSTKINE,
     *                 EBYMU,EBYTAU,EE,SE,VFRAC,VMAX,VMIN,ZATOM,
     *                 MT,FMUBRM,FMUNUC,FMUORG






      DOUBLE PRECISION AMUPAR(0:18),BCUT,CMUON(11),CTAU(11),


     *                 AATOM,CONSTKINE,EBYMU,EBYTAU,EE,SE,
     *                 VFRAC,VMAX,VMIN,ZATOM
      INTEGER          MT
      LOGICAL          FMUBRM,FMUNUC,FMUORG



# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"


















      COMMON /CRNPARTI/NPARTO,NPART2
      DOUBLE PRECISION NPARTO(20,28), NPART2(20,28),
     *                 NPHOTO(20),NPOSIT(20),NELECT(20),
     *                 NNU(20),NMUP(20),NMUM(20),NPI0(20),NPIP(20),
     *                 NPIM(20),NK0L(20),NKPL(20),NKMI(20),NNEUTR(20),
     *                 NPROTO(20),NPROTB(20),NK0S(20),NHYP(20),
     *                 NNEUTB(20),NDEUT(20),NTRIT(20),NHELI3(20),
     *                 NALPHA(20),NCHRMM(20),NCHRMB(20),NOTHER(20),
     *                 NMUOND,NMUONE
      EQUIVALENCE (NPARTO(1, 1),NPHOTO(1)), (NPARTO(1, 2),NPOSIT(1)),
     *            (NPARTO(1, 3),NELECT(1)), (NPARTO(1, 4),NNU(1))   ,
     *            (NPARTO(1, 5),NMUP(1))  , (NPARTO(1, 6),NMUM(1))  ,
     *            (NPARTO(1, 7),NPI0(1))  , (NPARTO(1, 8),NPIP(1))  ,
     *            (NPARTO(1, 9),NPIM(1))  , (NPARTO(1,10),NK0L(1))  ,
     *            (NPARTO(1,11),NKPL(1))  , (NPARTO(1,12),NKMI(1))  ,
     *            (NPARTO(1,13),NNEUTR(1)), (NPARTO(1,14),NPROTO(1)),
     *            (NPARTO(1,15),NPROTB(1)), (NPARTO(1,16),NK0S(1))  ,
     *            (NPARTO(1,18),NHYP(1))  , (NPARTO(1,19),NDEUT(1)) ,
     *            (NPARTO(1,20),NTRIT(1)) , (NPARTO(1,21),NHELI3(1)),
     *            (NPARTO(1,22),NALPHA(1)), (NPARTO(1,23),NCHRMM(1)),
     *            (NPARTO(1,24),NCHRMB(1)), (NPARTO(1,25),NOTHER(1)),
     *            (NPARTO(1,26),NMUOND)   , (NPARTO(1,27),NNEUTB(1)),
     *            (NPARTO(1,28),NMUONE)












      COMMON /CROBSPAR/OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP,
     *                 THETPR,PHIPR,

     *                 CORRXY,







     *                 NOBSLV
      DOUBLE PRECISION OBSLEV(20),THCKOB(20),XOFF(20),YOFF(20),
     *                 HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2)

     *                 ,CORRXY







      INTEGER          NOBSLV










      COMMON /CRPAM/   PAMA,SIGNUM,RESTMS,DECTIM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000),
     *                 DECTIM(200)






      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL





      DOUBLE PRECISION GAMMA,COSTHE,PHIX,PHIY,H,T,X,Y,CHI,BETA,GCM,ECM

     *                 ,WEIGHT


     *                 ,HAPP,COSTAP,COSTEA




      EQUIVALENCE      (CURPAR(1), GAMMA ), (CURPAR(2), COSTHE),
     *                 (CURPAR(3), PHIX  ), (CURPAR(4), PHIY  ),
     *                 (CURPAR(5), H     ), (CURPAR(6), T     ),
     *                 (CURPAR(7), X     ), (CURPAR(8), Y     ),
     *                 (CURPAR(9), CHI   ), (CURPAR(10),BETA  ),
     *                 (CURPAR(11),GCM   ), (CURPAR(12),ECM   )

     *                ,(CURPAR(13),WEIGHT)


     *                ,(CURPAR(14),HAPP  ), (CURPAR(15),COSTAP),
     *                 (CURPAR(16),COSTEA)















# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"



      COMMON /CRSTACKF/STACKI,



     *                 MSTACKP,MEXST,NSHIFT,NOUREC,NOURECMAX,ICOUNT,
     *                 NTO,NFROM




      INTEGER          MAXSTK
# 4796 "corsika.h"
      PARAMETER        (MAXSTK = 17*256*2)
# 4809 "corsika.h"
      DOUBLE PRECISION STACKI(MAXSTK)



      INTEGER          MSTACKP,MEXST,NSHIFT,NOUREC,NOURECMAX,ICOUNT,
     *                 NTO,NFROM






















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 24488 "corsika.F" 2






      LOGICAL          FLAG
# 24513 "corsika.F"
      INTEGER          LBIN
      EXTERNAL         LBIN


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

      DOUBLE PRECISION AUX,CHITOT,STPTOT
      INTEGER          I,IRET3
      LOGICAL          FSCAT
      SAVE
C-----------------------------------------------------------------------


      IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=0,9),WEIGHT
  444 FORMAT(' MUTRAC: CURPAR=',1P,11E11.3)





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

        STPTOT = STEPL
# 24555 "corsika.F"
      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
# 24584 "corsika.F"
      AUX = MIN( 10.D0, 0.015D0*GAMMA )

      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


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
# 24627 "corsika.F"
          BETA = SQRT( (GAMMA-1.D0)*(GAMMA+1.D0) ) / GAMMA
# 24636 "corsika.F"
        ELSE
C  KILL PARTICLE AS IT IS AT DETECTOR LEVEL
          IRET1 = 1
          FMUORG = .FALSE.
          RETURN
        ENDIF
      ENDIF

# 24865 "corsika.F"
      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





          CALL MUDECY
          CALL TSTEND

          NMUOND  = NMUOND + WEIGHT



        ELSE

C  PERFORM DECAY OF TAU LEPTON
          CALL CHRMDC
          CALL TSTEND
# 24902 "corsika.F"
        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 ( DEBUG ) WRITE(MDEBUG,457) (CURPAR(I),I=0,9),WEIGHT
 457  FORMAT(' MUTRAC: SCATTER',1P,11E11.3)




      GOTO 10

      END


*-- 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
# 24966 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"



      COMMON /CRAIR/   COMPOS,PROBTA,AVERAW,AVOGDR
      DOUBLE PRECISION COMPOS(3),PROBTA(3),AVERAW,AVOGDR



# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"



      COMMON /CRNCSNCS/SIGN30,SIGN45,SIGN60,SIGO30,SIGO45,SIGO60,
     *                 SIGA30,SIGA45,SIGA60,PNOA30,PNOA45,PNOA60,
     *                 SIG30A,SIG45A,SIG60A
      DOUBLE PRECISION SIGN30(56),SIGN45(56),SIGN60(56),
     *                 SIGO30(56),SIGO45(56),SIGO60(56),
     *                 SIGA30(56),SIGA45(56),SIGA60(56),
     *                 PNOA30(1540,3),PNOA45(1540,3),PNOA60(1540,3),
     *                 SIG30A(56),SIG45A(56),SIG60A(56)



# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"



      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL





      DOUBLE PRECISION GAMMA,COSTHE,PHIX,PHIY,H,T,X,Y,CHI,BETA,GCM,ECM

     *                 ,WEIGHT


     *                 ,HAPP,COSTAP,COSTEA




      EQUIVALENCE      (CURPAR(1), GAMMA ), (CURPAR(2), COSTHE),
     *                 (CURPAR(3), PHIX  ), (CURPAR(4), PHIY  ),
     *                 (CURPAR(5), H     ), (CURPAR(6), T     ),
     *                 (CURPAR(7), X     ), (CURPAR(8), Y     ),
     *                 (CURPAR(9), CHI   ), (CURPAR(10),BETA  ),
     *                 (CURPAR(11),GCM   ), (CURPAR(12),ECM   )

     *                ,(CURPAR(13),WEIGHT)


     *                ,(CURPAR(14),HAPP  ), (CURPAR(15),COSTAP),
     *                 (CURPAR(16),COSTEA)















# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"

























      COMMON /CRRANDPA/RD,FAC,U1,U2,NSEQ,ISEED,KNOR
      DOUBLE PRECISION RD(3000),FAC,U1,U2



      INTEGER          ISEED(3,10),NSEQ

      LOGICAL          KNOR



# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"











      COMMON /CRREST/  CONTNE,TAR,LIT
      DOUBLE PRECISION CONTNE(3),TAR
      INTEGER          LIT





      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"



      COMMON /CRSIGM/  SIGMA,SIGANN,SIGAIR,FRACTN,FRCTNO
      DOUBLE PRECISION SIGMA,SIGANN,SIGAIR,FRACTN,FRCTNO



# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 24966 "corsika.F" 2

      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



*-- 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
# 25164 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"



      COMMON /CRATMOS2/HLAY,HLAY0,THICKL,LAYNO,LAYNEW
      DOUBLE PRECISION HLAY(6),HLAY0(5,0:28),THICKL(5)
      INTEGER          LAYNO(0:41)
      LOGICAL          LAYNEW











# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"










      COMMON /CROBSPAR/OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP,
     *                 THETPR,PHIPR,

     *                 CORRXY,







     *                 NOBSLV
      DOUBLE PRECISION OBSLEV(20),THCKOB(20),XOFF(20),YOFF(20),
     *                 HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2)

     *                 ,CORRXY







      INTEGER          NOBSLV



# 4262 "corsika.h"



      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL





      DOUBLE PRECISION GAMMA,COSTHE,PHIX,PHIY,H,T,X,Y,CHI,BETA,GCM,ECM

     *                 ,WEIGHT


     *                 ,HAPP,COSTAP,COSTEA




      EQUIVALENCE      (CURPAR(1), GAMMA ), (CURPAR(2), COSTHE),
     *                 (CURPAR(3), PHIX  ), (CURPAR(4), PHIY  ),
     *                 (CURPAR(5), H     ), (CURPAR(6), T     ),
     *                 (CURPAR(7), X     ), (CURPAR(8), Y     ),
     *                 (CURPAR(9), CHI   ), (CURPAR(10),BETA  ),
     *                 (CURPAR(11),GCM   ), (CURPAR(12),ECM   )

     *                ,(CURPAR(13),WEIGHT)


     *                ,(CURPAR(14),HAPP  ), (CURPAR(15),COSTAP),
     *                 (CURPAR(16),COSTEA)















# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 25164 "corsika.F" 2

      DOUBLE PRECISION ARG,ARGNEW,COSDIF,COSPHI,COSTHENEW,
     *                 DH,HOLD,HNEW,SINPHI,
     *                 SINTHE,SINTHENEW,THICK,TRANS,TRANSNEW
      SAVE
      EXTERNAL         THICK

      DOUBLE PRECISION RHOF
      EXTERNAL         RHOF

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
# 25227 "corsika.F"
      IF ( HNEW-DH .LE. HLAY(1) ) THEN

        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



        IF ( DEBUG ) WRITE(MDEBUG,*)
     *               'NRANGC: HNEW,CHI= ',SNGL(HLAY(1)),SNGL(CHI)
        RETURN
      ENDIF


      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




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)

C  TERMINATE PROCESS IF PARTICLE BELOW SEA LEVEL OR ABOVE ATMOSPHERE
        IF ( ( HNEW .LT. HLAY(1) - 1.D5 )  .OR.
     *       ( HNEW .GT. HLAY(6) ) ) THEN




          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 .LT. C(29) ) RETURN



        GOTO 2
      ENDIF

      RETURN
      END


*-- 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
# 25340 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"



      COMMON /CRAIR/   COMPOS,PROBTA,AVERAW,AVOGDR
      DOUBLE PRECISION COMPOS(3),PROBTA(3),AVERAW,AVOGDR



# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"











      COMMON /CRCONSTA/PI,PI2,OB3,TB3,ENEPER,SQRT3
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER,SQRT3












































































# 3811 "corsika.h"

# 3824 "corsika.h"










      COMMON /CRGENER/ GEN,ALEVEL
      DOUBLE PRECISION GEN,ALEVEL











# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"



      COMMON /CRIRET/  IRET1,IRET2,IRETE
      INTEGER          IRET1,IRET2
      LOGICAL          IRETE



# 3912 "corsika.h"



      COMMON /CRKAONS/ CKA
      DOUBLE PRECISION CKA(80)



















      INTEGER          LNGMAX
      PARAMETER        (LNGMAX = 15000)
      INTEGER          TYPE1
      PARAMETER        (TYPE1 = 0)
      INTEGER          TYPE2
      PARAMETER        (TYPE2 = 1)
      INTEGER          TYPE3
      PARAMETER        (TYPE3 = 2)
      INTEGER          TYPE4
      PARAMETER        (TYPE4 = 3)
      COMMON /CRLONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP



     *                ,LLONGI,FLGFIT
# 3961 "corsika.h"
      DOUBLE PRECISION ADLONG(0:LNGMAX,19),AELONG(0:LNGMAX,10),
     *                 APLONG(0:LNGMAX,10),DLONG(0:LNGMAX,19),
     *                 ELONG(0:LNGMAX,10),
     *                 HLONG(0:LNGMAX),PLONG(0:LNGMAX,10),
     *                 SDLONG(0:LNGMAX,19),SELONG(0:LNGMAX,10),
     *                 SPLONG(0:LNGMAX,10),THSTEP,THSTPI




      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT

      COMMON /CRSLANT/ RLONG,THCKRL,CTH,STHCPH,STHSPH,RLOFF
      DOUBLE PRECISION RLONG(0:LNGMAX),THCKRL(0:LNGMAX),
     *                 CTH,STHCPH,STHSPH,RLOFF


















# 4005 "corsika.h"
















# 4047 "corsika.h"



      COMMON /CRMULT/  EKINL,MSMM,MULTMA,MULTOT
      DOUBLE PRECISION EKINL
      INTEGER          MSMM,MULTMA(40,13),MULTOT(40,13)



# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"








      COMMON /CRPAM/   PAMA,SIGNUM,RESTMS,DECTIM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000),
     *                 DECTIM(200)






      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL





      DOUBLE PRECISION GAMMA,COSTHE,PHIX,PHIY,H,T,X,Y,CHI,BETA,GCM,ECM

     *                 ,WEIGHT


     *                 ,HAPP,COSTAP,COSTEA




      EQUIVALENCE      (CURPAR(1), GAMMA ), (CURPAR(2), COSTHE),
     *                 (CURPAR(3), PHIX  ), (CURPAR(4), PHIY  ),
     *                 (CURPAR(5), H     ), (CURPAR(6), T     ),
     *                 (CURPAR(7), X     ), (CURPAR(8), Y     ),
     *                 (CURPAR(9), CHI   ), (CURPAR(10),BETA  ),
     *                 (CURPAR(11),GCM   ), (CURPAR(12),ECM   )

     *                ,(CURPAR(13),WEIGHT)


     *                ,(CURPAR(14),HAPP  ), (CURPAR(15),COSTAP),
     *                 (CURPAR(16),COSTEA)















# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"



      COMMON /CRPOLAR/ POLART,POLARF
      DOUBLE PRECISION POLART,POLARF




















      COMMON /CRRANDPA/RD,FAC,U1,U2,NSEQ,ISEED,KNOR
      DOUBLE PRECISION RD(3000),FAC,U1,U2



      INTEGER          ISEED(3,10),NSEQ

      LOGICAL          KNOR



# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"



      COMMON /CRSIGM/  SIGMA,SIGANN,SIGAIR,FRACTN,FRCTNO
      DOUBLE PRECISION SIGMA,SIGANN,SIGAIR,FRACTN,FRCTNO



# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"



      COMMON /CRSTATI/ SABIN,SBBIN,INBIN,IPBIN,IKBIN,IHBIN
      DOUBLE PRECISION SABIN(40),SBBIN(40)
      INTEGER          INBIN(40),IPBIN(40),IKBIN(40),IHBIN(40)










# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"



      COMMON /CRVKIN/  BETACM
      DOUBLE PRECISION BETACM










     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 25340 "corsika.F" 2

      DOUBLE PRECISION BETA3,COSMU,COSTCM,COSTH3,ETOT,GAMMA3,
     *                 PHI,PHIMU,PHI3,SINMU,THICK,WORK1,WORK2
      INTEGER          I,IGO,KJ
      LOGICAL          FIRSTINT

      DOUBLE PRECISION ENERGY,EN,PZ,PX,PY,HEI0
      INTEGER          NNN,NN,NTYP
c     INTEGER          N,IRET,IBL


      INTEGER          IA





      INTEGER          LBIN
      EXTERNAL         LBIN





      SAVE
      EXTERNAL         THICK
C-----------------------------------------------------------------------


      IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=0,9),WEIGHT
  444 FORMAT(' NUCINT: CURPAR=',1P,11E11.3)
# 25381 "corsika.F"

      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

C  SET WEIGHT
      SECPAR(13) = WEIGHT


      SECPAR(14) = CURPAR(14)
      SECPAR(15) = CURPAR(15)
      SECPAR(16) = CURPAR(16)
# 25421 "corsika.F"
      THICKH = THICK( H )


      IF ( LLONGI ) LHEIGH = MIN( LBIN( X,Y,HAPP,1 ), NSTEP+1 )







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

        IPBIN(KJ) = IPBIN(KJ) + NINT( WEIGHT )




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)
# 25492 "corsika.F"
C  NEUTRINO IS DROPPED
          IF ( LLONGI ) THEN
C  ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT
            SECPAR(1) = PAMA(8) * GAMMA - PAMA(5) * GAMMA3

            DLONG(LHEIGH,8) = DLONG(LHEIGH,8) + SECPAR(1) * WEIGHT



          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 .GE. 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

              DLONG(LHEIGH,15) = DLONG(LHEIGH,15)+GAMMA3*PAMA(5)*WEIGHT



            ENDIF
# 25580 "corsika.F"
          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
# 25601 "corsika.F"

C  LOW ENERGY HADRONIC INTERACTIONS
C  CHECK IF WE USE LOW ENERGY HADRONIC INTERACTION MODEL
        IF ( USELOW ) THEN
# 25621 "corsika.F"
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
C-----------------------------------------------------------------------
C  PI(0) INCIDENT
      ELSEIF ( ITYPE .EQ.  7 ) THEN
        IF ( DEBUG ) WRITE(MDEBUG,*) 'NUCINT: PI(0) EKINL=',SNGL(EKINL),
     *                               ' ETOT=',ETOT

        IPBIN(KJ) = IPBIN(KJ) + NINT( WEIGHT )




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
# 25662 "corsika.F"
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
# 25686 "corsika.F"
        INBIN(KJ) = INBIN(KJ) + NINT( WEIGHT )




C  LOW ENERGY HADRONIC INTERACTIONS
C  CHECK IF WE USE LOW ENERGY HADRONIC INTERACTION MODEL
        IF ( USELOW ) THEN
# 25710 "corsika.F"
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

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

        IKBIN(KJ) = IKBIN(KJ) + NINT( WEIGHT )




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
# 25769 "corsika.F"
C  LOW ENERGY HADRONIC INTERACTIONS
C  CHECK IF WE USE LOW ENERGY HADRONIC INTERACTION MODEL
          IF ( USELOW ) THEN
# 25788 "corsika.F"
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  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

        IPBIN(KJ) = IPBIN(KJ) + NINT( WEIGHT )




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
# 25834 "corsika.F"
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

        IHBIN(KJ) = IHBIN(KJ) + NINT( WEIGHT )



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
# 25868 "corsika.F"
C  LOW ENERGY HADRONIC INTERACTIONS
C  CHECK IF WE USE LOW ENERGY HADRONIC INTERACTION MODEL
        IF ( USELOW ) THEN







C  USE URQMD LOW ENERGY HADRONIC INTERACTION MODEL
          CALL URQLNK

        ELSE
# 25893 "corsika.F"
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






        ENDIF

C-----------------------------------------------------------------------
C  HEAVY PROJECTILE INCIDENT
      ELSEIF ( ITYPE .GE. 200 ) THEN
        IF ( DEBUG ) WRITE(MDEBUG,*) 'NUCINT: HEAVY PROJECTILE EKINL=',
     *                 SNGL(EKINL),' ETOT=',ETOT
# 25924 "corsika.F"
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
# 25945 "corsika.F"
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

# 25989 "corsika.F"
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

        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
# 26023 "corsika.F"
        ENDIF


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


C-----------------------------------------------------------------------
C  ILLEGAL PARTICLE
      ELSE

        WRITE(MONIOU,444) (CURPAR(I),I=0,9),WEIGHT



        WRITE(MONIOU,*) 'NUCINT: ILLEGAL PARTICLE = ',ITYPE
        STOP 1
      ENDIF


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


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
# 26174 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"



      COMMON /CRBUFFS/ RUNH,RUNE,EVTH,EVTE,DATAB,ARRAYLONG,LH

     *                 ,WRRUNH,WRRUNE,WREVTH,WREVTE

      INTEGER          MAXBUF,MAXLEN

      PARAMETER        (MAXBUF=39*8)
# 3681 "corsika.h"
      PARAMETER        (MAXLEN=16)
# 3693 "corsika.h"
      REAL             RUNH(MAXBUF),EVTH(MAXBUF),EVTE(MAXBUF),
     *                 RUNE(MAXBUF),DATAB(MAXBUF),ARRAYLONG(MAXBUF)
      INTEGER          LH

      LOGICAL          WRRUNH,WRRUNE,WREVTH,WREVTE

      CHARACTER*4      CRUNH,CRUNE,CEVTH,CEVTE,CLONG
      EQUIVALENCE      (RUNH(1),CRUNH), (RUNE(1),CRUNE)
      EQUIVALENCE      (EVTH(1),CEVTH), (EVTE(1),CEVTE)
      EQUIVALENCE      (ARRAYLONG(1),CLONG)





      COMMON /CRCHISTA/IHYCHI,IKACHI,IMUCHI,INNCHI,INUCHI,IPICHI,INECHI
      INTEGER          IHYCHI(124),IKACHI(124),IMUCHI(124),INNCHI(124),
     *                 INUCHI(124),IPICHI(124),INECHI(124)






































































      COMMON /CRELADPM/ELMEAN,ELMEAA,IELDPM,IELDPA
      DOUBLE PRECISION ELMEAN(40),ELMEAA(40)
      INTEGER          IELDPM(40,13),IELDPA(40,13)










# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"



      COMMON /CRMULT/  EKINL,MSMM,MULTMA,MULTOT
      DOUBLE PRECISION EKINL
      INTEGER          MSMM,MULTMA(40,13),MULTOT(40,13)



# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"


















      COMMON /CRNPARTI/NPARTO,NPART2
      DOUBLE PRECISION NPARTO(20,28), NPART2(20,28),
     *                 NPHOTO(20),NPOSIT(20),NELECT(20),
     *                 NNU(20),NMUP(20),NMUM(20),NPI0(20),NPIP(20),
     *                 NPIM(20),NK0L(20),NKPL(20),NKMI(20),NNEUTR(20),
     *                 NPROTO(20),NPROTB(20),NK0S(20),NHYP(20),
     *                 NNEUTB(20),NDEUT(20),NTRIT(20),NHELI3(20),
     *                 NALPHA(20),NCHRMM(20),NCHRMB(20),NOTHER(20),
     *                 NMUOND,NMUONE
      EQUIVALENCE (NPARTO(1, 1),NPHOTO(1)), (NPARTO(1, 2),NPOSIT(1)),
     *            (NPARTO(1, 3),NELECT(1)), (NPARTO(1, 4),NNU(1))   ,
     *            (NPARTO(1, 5),NMUP(1))  , (NPARTO(1, 6),NMUM(1))  ,
     *            (NPARTO(1, 7),NPI0(1))  , (NPARTO(1, 8),NPIP(1))  ,
     *            (NPARTO(1, 9),NPIM(1))  , (NPARTO(1,10),NK0L(1))  ,
     *            (NPARTO(1,11),NKPL(1))  , (NPARTO(1,12),NKMI(1))  ,
     *            (NPARTO(1,13),NNEUTR(1)), (NPARTO(1,14),NPROTO(1)),
     *            (NPARTO(1,15),NPROTB(1)), (NPARTO(1,16),NK0S(1))  ,
     *            (NPARTO(1,18),NHYP(1))  , (NPARTO(1,19),NDEUT(1)) ,
     *            (NPARTO(1,20),NTRIT(1)) , (NPARTO(1,21),NHELI3(1)),
     *            (NPARTO(1,22),NALPHA(1)), (NPARTO(1,23),NCHRMM(1)),
     *            (NPARTO(1,24),NCHRMB(1)), (NPARTO(1,25),NOTHER(1)),
     *            (NPARTO(1,26),NMUOND)   , (NPARTO(1,27),NNEUTB(1)),
     *            (NPARTO(1,28),NMUONE)










# 4248 "corsika.h"

# 4262 "corsika.h"



      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL





      DOUBLE PRECISION GAMMA,COSTHE,PHIX,PHIY,H,T,X,Y,CHI,BETA,GCM,ECM

     *                 ,WEIGHT


     *                 ,HAPP,COSTAP,COSTEA




      EQUIVALENCE      (CURPAR(1), GAMMA ), (CURPAR(2), COSTHE),
     *                 (CURPAR(3), PHIX  ), (CURPAR(4), PHIY  ),
     *                 (CURPAR(5), H     ), (CURPAR(6), T     ),
     *                 (CURPAR(7), X     ), (CURPAR(8), Y     ),
     *                 (CURPAR(9), CHI   ), (CURPAR(10),BETA  ),
     *                 (CURPAR(11),GCM   ), (CURPAR(12),ECM   )

     *                ,(CURPAR(13),WEIGHT)


     *                ,(CURPAR(14),HAPP  ), (CURPAR(15),COSTAP),
     *                 (CURPAR(16),COSTEA)















# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"



      COMMON /CRRECORD/DRECOR
      DOUBLE PRECISION DRECOR



# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"



      COMMON /CRSTACKF/STACKI,



     *                 MSTACKP,MEXST,NSHIFT,NOUREC,NOURECMAX,ICOUNT,
     *                 NTO,NFROM




      INTEGER          MAXSTK
# 4796 "corsika.h"
      PARAMETER        (MAXSTK = 17*256*2)
# 4809 "corsika.h"
      DOUBLE PRECISION STACKI(MAXSTK)



      INTEGER          MSTACKP,MEXST,NSHIFT,NOUREC,NOURECMAX,ICOUNT,
     *                 NTO,NFROM









      COMMON /CRSTATI/ SABIN,SBBIN,INBIN,IPBIN,IKBIN,IHBIN
      DOUBLE PRECISION SABIN(40),SBBIN(40)
      INTEGER          INBIN(40),IPBIN(40),IKBIN(40),IHBIN(40)










# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"










      COMMON /CRWGHTMA/MWGHMA,MWGHTOT
      INTEGER          MWGHMA(46,15),MWGHTOT(46,15)



     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 26174 "corsika.F" 2

      INTEGER          I

      INTEGER          J,K,NELMEA

      SAVE
C-----------------------------------------------------------------------

      IF ( LH .GT. 0 ) THEN







        IF ( FPAROUT ) CALL TOBUF( DATAB,0 )




        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
# 26221 "corsika.F"
      ENDIF


      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 ( 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


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)
# 26300 "corsika.F"
        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)


        WRITE(MONIOU,105) DRECOR
  105   FORMAT(/,' WORDS WRITTEN TO PARTICLE DATA FILE UP TO NOW =',
     *           1P,E22.15)
      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
# 26361 "corsika.F"


# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"



      COMMON /CRBUFFS/ RUNH,RUNE,EVTH,EVTE,DATAB,ARRAYLONG,LH

     *                 ,WRRUNH,WRRUNE,WREVTH,WREVTE

      INTEGER          MAXBUF,MAXLEN

      PARAMETER        (MAXBUF=39*8)
# 3681 "corsika.h"
      PARAMETER        (MAXLEN=16)
# 3693 "corsika.h"
      REAL             RUNH(MAXBUF),EVTH(MAXBUF),EVTE(MAXBUF),
     *                 RUNE(MAXBUF),DATAB(MAXBUF),ARRAYLONG(MAXBUF)
      INTEGER          LH

      LOGICAL          WRRUNH,WRRUNE,WREVTH,WREVTE

      CHARACTER*4      CRUNH,CRUNE,CEVTH,CEVTE,CLONG
      EQUIVALENCE      (RUNH(1),CRUNH), (RUNE(1),CRUNE)
      EQUIVALENCE      (EVTH(1),CEVTH), (EVTE(1),CEVTE)
      EQUIVALENCE      (ARRAYLONG(1),CLONG)



























































































# 3811 "corsika.h"

# 3824 "corsika.h"



      COMMON /CRETHMAP/ECTMAP,ELEFT,ELEFTJ
      DOUBLE PRECISION ECTMAP,ELEFT,ELEFTJ


















# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"
























      INTEGER          LNGMAX
      PARAMETER        (LNGMAX = 15000)
      INTEGER          TYPE1
      PARAMETER        (TYPE1 = 0)
      INTEGER          TYPE2
      PARAMETER        (TYPE2 = 1)
      INTEGER          TYPE3
      PARAMETER        (TYPE3 = 2)
      INTEGER          TYPE4
      PARAMETER        (TYPE4 = 3)
      COMMON /CRLONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP



     *                ,LLONGI,FLGFIT
# 3961 "corsika.h"
      DOUBLE PRECISION ADLONG(0:LNGMAX,19),AELONG(0:LNGMAX,10),
     *                 APLONG(0:LNGMAX,10),DLONG(0:LNGMAX,19),
     *                 ELONG(0:LNGMAX,10),
     *                 HLONG(0:LNGMAX),PLONG(0:LNGMAX,10),
     *                 SDLONG(0:LNGMAX,19),SELONG(0:LNGMAX,10),
     *                 SPLONG(0:LNGMAX,10),THSTEP,THSTPI




      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT

      COMMON /CRSLANT/ RLONG,THCKRL,CTH,STHCPH,STHSPH,RLOFF
      DOUBLE PRECISION RLONG(0:LNGMAX),THCKRL(0:LNGMAX),
     *                 CTH,STHCPH,STHSPH,RLOFF






      COMMON /CRMAGANG/ARRANG,ARRANR,COSANG,SINANG
      DOUBLE PRECISION ARRANG,ARRANR,COSANG,SINANG










# 4005 "corsika.h"
















# 4047 "corsika.h"



      COMMON /CRMULT/  EKINL,MSMM,MULTMA,MULTOT
      DOUBLE PRECISION EKINL
      INTEGER          MSMM,MULTMA(40,13),MULTOT(40,13)



# 4075 "corsika.h"

# 4091 "corsika.h"


















      COMMON /CRMUPART/AATOM,AMUPAR,BCUT,CMUON,CTAU,CONSTKINE,
     *                 EBYMU,EBYTAU,EE,SE,VFRAC,VMAX,VMIN,ZATOM,
     *                 MT,FMUBRM,FMUNUC,FMUORG






      DOUBLE PRECISION AMUPAR(0:18),BCUT,CMUON(11),CTAU(11),


     *                 AATOM,CONSTKINE,EBYMU,EBYTAU,EE,SE,
     *                 VFRAC,VMAX,VMIN,ZATOM
      INTEGER          MT
      LOGICAL          FMUBRM,FMUNUC,FMUORG



# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"


















      COMMON /CRNPARTI/NPARTO,NPART2
      DOUBLE PRECISION NPARTO(20,28), NPART2(20,28),
     *                 NPHOTO(20),NPOSIT(20),NELECT(20),
     *                 NNU(20),NMUP(20),NMUM(20),NPI0(20),NPIP(20),
     *                 NPIM(20),NK0L(20),NKPL(20),NKMI(20),NNEUTR(20),
     *                 NPROTO(20),NPROTB(20),NK0S(20),NHYP(20),
     *                 NNEUTB(20),NDEUT(20),NTRIT(20),NHELI3(20),
     *                 NALPHA(20),NCHRMM(20),NCHRMB(20),NOTHER(20),
     *                 NMUOND,NMUONE
      EQUIVALENCE (NPARTO(1, 1),NPHOTO(1)), (NPARTO(1, 2),NPOSIT(1)),
     *            (NPARTO(1, 3),NELECT(1)), (NPARTO(1, 4),NNU(1))   ,
     *            (NPARTO(1, 5),NMUP(1))  , (NPARTO(1, 6),NMUM(1))  ,
     *            (NPARTO(1, 7),NPI0(1))  , (NPARTO(1, 8),NPIP(1))  ,
     *            (NPARTO(1, 9),NPIM(1))  , (NPARTO(1,10),NK0L(1))  ,
     *            (NPARTO(1,11),NKPL(1))  , (NPARTO(1,12),NKMI(1))  ,
     *            (NPARTO(1,13),NNEUTR(1)), (NPARTO(1,14),NPROTO(1)),
     *            (NPARTO(1,15),NPROTB(1)), (NPARTO(1,16),NK0S(1))  ,
     *            (NPARTO(1,18),NHYP(1))  , (NPARTO(1,19),NDEUT(1)) ,
     *            (NPARTO(1,20),NTRIT(1)) , (NPARTO(1,21),NHELI3(1)),
     *            (NPARTO(1,22),NALPHA(1)), (NPARTO(1,23),NCHRMM(1)),
     *            (NPARTO(1,24),NCHRMB(1)), (NPARTO(1,25),NOTHER(1)),
     *            (NPARTO(1,26),NMUOND)   , (NPARTO(1,27),NNEUTB(1)),
     *            (NPARTO(1,28),NMUONE)












      COMMON /CROBSPAR/OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP,
     *                 THETPR,PHIPR,

     *                 CORRXY,







     *                 NOBSLV
      DOUBLE PRECISION OBSLEV(20),THCKOB(20),XOFF(20),YOFF(20),
     *                 HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2)

     *                 ,CORRXY







      INTEGER          NOBSLV










      COMMON /CRPAM/   PAMA,SIGNUM,RESTMS,DECTIM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000),
     *                 DECTIM(200)






      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL





      DOUBLE PRECISION GAMMA,COSTHE,PHIX,PHIY,H,T,X,Y,CHI,BETA,GCM,ECM

     *                 ,WEIGHT


     *                 ,HAPP,COSTAP,COSTEA




      EQUIVALENCE      (CURPAR(1), GAMMA ), (CURPAR(2), COSTHE),
     *                 (CURPAR(3), PHIX  ), (CURPAR(4), PHIY  ),
     *                 (CURPAR(5), H     ), (CURPAR(6), T     ),
     *                 (CURPAR(7), X     ), (CURPAR(8), Y     ),
     *                 (CURPAR(9), CHI   ), (CURPAR(10),BETA  ),
     *                 (CURPAR(11),GCM   ), (CURPAR(12),ECM   )

     *                ,(CURPAR(13),WEIGHT)


     *                ,(CURPAR(14),HAPP  ), (CURPAR(15),COSTAP),
     *                 (CURPAR(16),COSTEA)















# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"

























      COMMON /CRRANDPA/RD,FAC,U1,U2,NSEQ,ISEED,KNOR
      DOUBLE PRECISION RD(3000),FAC,U1,U2



      INTEGER          ISEED(3,10),NSEQ

      LOGICAL          KNOR



# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"


















      INTEGER          IEBIN, ITBIN, IDBIN
      PARAMETER        (IEBIN=40,ITBIN=30,IDBIN=20)
      COMMON /CRTABLES/G_ARRAY, E_ARRAY, M_ARRAY,
     *                 EBOFF,EBFAC,TBOFF,TBFAC,DBOFF,DBFAC
      REAL             G_ARRAY(IEBIN,ITBIN,IDBIN)
      REAL             E_ARRAY(IEBIN,ITBIN,IDBIN)
      REAL             M_ARRAY(IEBIN,ITBIN,IDBIN)
      REAL             EBOFF,EBFAC,TBOFF,TBFAC,DBOFF,DBFAC
      REAL             EBMIN,EBMAX,TBMIN,TBMAX,DBMIN,DBMAX
      PARAMETER        (EBMIN=1.E-4,EBMAX=1.E4)
      PARAMETER        (TBMIN=10.,TBMAX=1.E4)
      PARAMETER        (DBMIN=5.E3,DBMAX=5.E5)





      COMMON /CRTHNVAR/STACKINT,

     *                 EEPP,ELIM,


     *                 RMAX,RMAX2,
     *                 WMAX,WMAX0,WMAXE,WMAXE0,WMAXEM,

     *                 INT_ICOUNT,MODETHN,THINNING

     *                 ,RLIM,WLIM

      INTEGER          MAXICOUNT
      PARAMETER        (MAXICOUNT = 200000)
# 4883 "corsika.h"
      DOUBLE PRECISION STACKINT(0:16,MAXICOUNT)
# 4892 "corsika.h"
     *                 ,EEPP(MAXICOUNT),ELIM


     *                 ,RMAX,RMAX2
     *                 ,WMAX,WMAX0,WMAXE,WMAXE0,WMAXEM

      INTEGER          INT_ICOUNT,MODETHN
      LOGICAL          THINNING

      LOGICAL           RLIM,WLIM




















# 4935 "corsika.h"
















# 4959 "corsika.h"










      COMMON /CRWGHTMA/MWGHMA,MWGHTOT
      INTEGER          MWGHMA(46,15),MWGHTOT(46,15)



     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 26363 "corsika.F" 2

      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

      DOUBLE PRECISION COSTHPRPR





      DOUBLE PRECISION EKIN,PROBTH
      INTEGER          MEN,MMU
# 26389 "corsika.F"
      SAVE
      DATA             NCOUNT / 0 /, AUGM / 1.D0 /, AUGM2 / 1.D0 /
C-----------------------------------------------------------------------


      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)
# 26411 "corsika.F"






      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
# 26440 "corsika.F"
C  PRINT OUT PARTICLE IF IT IS ABOVE THE CUT
      IF ( FPRINT  .OR.  DEBUG  .OR.  DEBDEL ) THEN
        IF ( OUTPAR(1) .GE. ECTMAP ) THEN

          WRITE(MONIOU,3) (OUTPAR(I),I=0,9),OUTPAR(13),OUTPAR(10),ELEFT




    3     FORMAT(' OUTPT1:        ',1P,9E11.3,0P,F12.0,1P,3E10.3)
# 26467 "corsika.F"
          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

C  SET INCREMENT FOR COUNTERS
      AUGM = OUTPAR(13)

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

      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

      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
# 26512 "corsika.F"
      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     ( PRMPAR(15) .GT. 0.D0 ) THEN
          LHEIGH = NSTEP
        ELSEIF ( PRMPAR(15) .LE. 0.D0 ) THEN

          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
# 26557 "corsika.F"
        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

# 26614 "corsika.F"

      ROUT = .TRUE.
      RR2 = OUTPAR(7)**2 + OUTPAR(8)**2




C  DISCARD PARTICLES BY CORECUT WITHIN RADIUS < RMAX
       IF ( RR2 .LT. RCUT2 ) ROUT = .FALSE.




      PROBTH = 1.D0




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





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) )

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) )






          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)

          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






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

# 26884 "corsika.F"
        ENDIF
# 27049 "corsika.F"






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 )

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)
# 27074 "corsika.F"
        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

        RR = SQRT( RR2 )



        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

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)
# 27146 "corsika.F"
      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)


      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

        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

        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
# 27201 "corsika.F"
        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

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




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

# 27268 "corsika.F"

      RETURN
      END

# 27659 "corsika.F"
*-- 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



# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"











      COMMON /CRCONSTA/PI,PI2,OB3,TB3,ENEPER,SQRT3
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER,SQRT3












































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"








      COMMON /CRPAM/   PAMA,SIGNUM,RESTMS,DECTIM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000),
     *                 DECTIM(200)




# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"

















# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 27679 "corsika.F" 2

      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
# 27944 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"











      COMMON /CRCONSTA/PI,PI2,OB3,TB3,ENEPER,SQRT3
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER,SQRT3




















      COMMON /CRDECAYC/GAM345,COS345,PHI345
      DOUBLE PRECISION GAM345(3),COS345(3),PHI345(3)






















































# 3811 "corsika.h"

# 3824 "corsika.h"










      COMMON /CRGENER/ GEN,ALEVEL
      DOUBLE PRECISION GEN,ALEVEL











# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"
























      INTEGER          LNGMAX
      PARAMETER        (LNGMAX = 15000)
      INTEGER          TYPE1
      PARAMETER        (TYPE1 = 0)
      INTEGER          TYPE2
      PARAMETER        (TYPE2 = 1)
      INTEGER          TYPE3
      PARAMETER        (TYPE3 = 2)
      INTEGER          TYPE4
      PARAMETER        (TYPE4 = 3)
      COMMON /CRLONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP



     *                ,LLONGI,FLGFIT
# 3961 "corsika.h"
      DOUBLE PRECISION ADLONG(0:LNGMAX,19),AELONG(0:LNGMAX,10),
     *                 APLONG(0:LNGMAX,10),DLONG(0:LNGMAX,19),
     *                 ELONG(0:LNGMAX,10),
     *                 HLONG(0:LNGMAX),PLONG(0:LNGMAX,10),
     *                 SDLONG(0:LNGMAX,19),SELONG(0:LNGMAX,10),
     *                 SPLONG(0:LNGMAX,10),THSTEP,THSTPI




      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT

      COMMON /CRSLANT/ RLONG,THCKRL,CTH,STHCPH,STHSPH,RLOFF
      DOUBLE PRECISION RLONG(0:LNGMAX),THCKRL(0:LNGMAX),
     *                 CTH,STHCPH,STHSPH,RLOFF


















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"








      COMMON /CRPAM/   PAMA,SIGNUM,RESTMS,DECTIM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000),
     *                 DECTIM(200)






      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL





      DOUBLE PRECISION GAMMA,COSTHE,PHIX,PHIY,H,T,X,Y,CHI,BETA,GCM,ECM

     *                 ,WEIGHT


     *                 ,HAPP,COSTAP,COSTEA




      EQUIVALENCE      (CURPAR(1), GAMMA ), (CURPAR(2), COSTHE),
     *                 (CURPAR(3), PHIX  ), (CURPAR(4), PHIY  ),
     *                 (CURPAR(5), H     ), (CURPAR(6), T     ),
     *                 (CURPAR(7), X     ), (CURPAR(8), Y     ),
     *                 (CURPAR(9), CHI   ), (CURPAR(10),BETA  ),
     *                 (CURPAR(11),GCM   ), (CURPAR(12),ECM   )

     *                ,(CURPAR(13),WEIGHT)


     *                ,(CURPAR(14),HAPP  ), (CURPAR(15),COSTAP),
     *                 (CURPAR(16),COSTEA)















# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"

























      COMMON /CRRANDPA/RD,FAC,U1,U2,NSEQ,ISEED,KNOR
      DOUBLE PRECISION RD(3000),FAC,U1,U2



      INTEGER          ISEED(3,10),NSEQ

      LOGICAL          KNOR



# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 27944 "corsika.F" 2

      DOUBLE PRECISION AUX1,AUX2,COSTH1,COSTH2,EPITO2,FI1
      INTEGER          I





      SAVE
C-----------------------------------------------------------------------


      IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=0,9),WEIGHT
  444 FORMAT(' PI0DEC: CURPAR=',1P,11E11.3)





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 ( SECPAR(2) .GE. C(29) ) THEN



          SECPAR(0) = 1.D0




          CALL TSTACK
        ELSE
          IF ( LLONGI ) THEN
C  ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT

            DLONG(LHEIGH,11) = DLONG(LHEIGH,11) + SECPAR(1) * WEIGHT



          ENDIF
# 28024 "corsika.F"
        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 ( SECPAR(2) .GE. C(29) ) THEN



          SECPAR(0) = 1.D0




          CALL TSTACK
        ELSE
          IF ( LLONGI ) THEN
C  ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT

            DLONG(LHEIGH,11) = DLONG(LHEIGH,11) + SECPAR(1) * WEIGHT



          ENDIF
# 28074 "corsika.F"
        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 ( SECPAR(2) .GE. C(29) ) THEN



            SECPAR(0) = DBLE(4 - I)
            SECPAR(1) = GAM345(I)
# 28100 "corsika.F"
            CALL TSTACK
          ELSE
            IF ( LLONGI ) THEN
C  ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT
              IF     ( I .EQ. 1 ) THEN

                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
# 28122 "corsika.F"
              ENDIF
            ENDIF
# 28151 "corsika.F"
          ENDIF
       ENDDO
      ENDIF

      RETURN
      END

# 28383 "corsika.F"

*-- 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




# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"











      COMMON /CRCONSTA/PI,PI2,OB3,TB3,ENEPER,SQRT3
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER,SQRT3












































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"


















      COMMON /CRMUPART/AATOM,AMUPAR,BCUT,CMUON,CTAU,CONSTKINE,
     *                 EBYMU,EBYTAU,EE,SE,VFRAC,VMAX,VMIN,ZATOM,
     *                 MT,FMUBRM,FMUNUC,FMUORG






      DOUBLE PRECISION AMUPAR(0:18),BCUT,CMUON(11),CTAU(11),


     *                 AATOM,CONSTKINE,EBYMU,EBYTAU,EE,SE,
     *                 VFRAC,VMAX,VMIN,ZATOM
      INTEGER          MT
      LOGICAL          FMUBRM,FMUNUC,FMUORG



# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"








      COMMON /CRPAM/   PAMA,SIGNUM,RESTMS,DECTIM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000),
     *                 DECTIM(200)




# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"

















# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 28408 "corsika.F" 2

      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




# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"











      COMMON /CRCONSTA/PI,PI2,OB3,TB3,ENEPER,SQRT3
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER,SQRT3












































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"


















      COMMON /CRMUPART/AATOM,AMUPAR,BCUT,CMUON,CTAU,CONSTKINE,
     *                 EBYMU,EBYTAU,EE,SE,VFRAC,VMAX,VMIN,ZATOM,
     *                 MT,FMUBRM,FMUNUC,FMUORG






      DOUBLE PRECISION AMUPAR(0:18),BCUT,CMUON(11),CTAU(11),


     *                 AATOM,CONSTKINE,EBYMU,EBYTAU,EE,SE,
     *                 VFRAC,VMAX,VMIN,ZATOM
      INTEGER          MT
      LOGICAL          FMUBRM,FMUNUC,FMUORG



# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"








      COMMON /CRPAM/   PAMA,SIGNUM,RESTMS,DECTIM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000),
     *                 DECTIM(200)




# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"

















# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 28503 "corsika.F" 2

      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




# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"











      COMMON /CRCONSTA/PI,PI2,OB3,TB3,ENEPER,SQRT3
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER,SQRT3












































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"


















      COMMON /CRMUPART/AATOM,AMUPAR,BCUT,CMUON,CTAU,CONSTKINE,
     *                 EBYMU,EBYTAU,EE,SE,VFRAC,VMAX,VMIN,ZATOM,
     *                 MT,FMUBRM,FMUNUC,FMUORG






      DOUBLE PRECISION AMUPAR(0:18),BCUT,CMUON(11),CTAU(11),


     *                 AATOM,CONSTKINE,EBYMU,EBYTAU,EE,SE,
     *                 VFRAC,VMAX,VMIN,ZATOM
      INTEGER          MT
      LOGICAL          FMUBRM,FMUNUC,FMUORG



# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"








      COMMON /CRPAM/   PAMA,SIGNUM,RESTMS,DECTIM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000),
     *                 DECTIM(200)




# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"

















# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 28601 "corsika.F" 2

      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


*-- 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
# 28709 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"



      COMMON /CRAIR/   COMPOS,PROBTA,AVERAW,AVOGDR
      DOUBLE PRECISION COMPOS(3),PROBTA(3),AVERAW,AVOGDR





      COMMON /CRATMOS/ AATM,AATM0,BATM,BATM0,CATM,CATM0,DATM,MODATM
     *                ,MATMFI,LATMNEW
      DOUBLE PRECISION AATM(5),AATM0(5,0:42),BATM(5),BATM0(5,0:42),
     *                 CATM(5),CATM0(5,0:42),DATM(5)
      INTEGER          MODATM,MATMFI
      LOGICAL          LATMNEW





      COMMON /CRATMOS2/HLAY,HLAY0,THICKL,LAYNO,LAYNEW
      DOUBLE PRECISION HLAY(6),HLAY0(5,0:28),THICKL(5)
      INTEGER          LAYNO(0:41)
      LOGICAL          LAYNEW











# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"











      COMMON /CRCONSTA/PI,PI2,OB3,TB3,ENEPER,SQRT3
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER,SQRT3












































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"



      COMMON /CRMUMULT/CHC,OMC,PHISCT,STEPL,VSCAT,FMOLI
      DOUBLE PRECISION CHC,OMC,PHISCT,STEPL,VSCAT
      LOGICAL          FMOLI












      COMMON /CRMUPART/AATOM,AMUPAR,BCUT,CMUON,CTAU,CONSTKINE,
     *                 EBYMU,EBYTAU,EE,SE,VFRAC,VMAX,VMIN,ZATOM,
     *                 MT,FMUBRM,FMUNUC,FMUORG






      DOUBLE PRECISION AMUPAR(0:18),BCUT,CMUON(11),CTAU(11),


     *                 AATOM,CONSTKINE,EBYMU,EBYTAU,EE,SE,
     *                 VFRAC,VMAX,VMIN,ZATOM
      INTEGER          MT
      LOGICAL          FMUBRM,FMUNUC,FMUORG



# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"










      COMMON /CROBSPAR/OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP,
     *                 THETPR,PHIPR,

     *                 CORRXY,







     *                 NOBSLV
      DOUBLE PRECISION OBSLEV(20),THCKOB(20),XOFF(20),YOFF(20),
     *                 HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2)

     *                 ,CORRXY







      INTEGER          NOBSLV










      COMMON /CRPAM/   PAMA,SIGNUM,RESTMS,DECTIM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000),
     *                 DECTIM(200)






      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL





      DOUBLE PRECISION GAMMA,COSTHE,PHIX,PHIY,H,T,X,Y,CHI,BETA,GCM,ECM

     *                 ,WEIGHT


     *                 ,HAPP,COSTAP,COSTEA




      EQUIVALENCE      (CURPAR(1), GAMMA ), (CURPAR(2), COSTHE),
     *                 (CURPAR(3), PHIX  ), (CURPAR(4), PHIY  ),
     *                 (CURPAR(5), H     ), (CURPAR(6), T     ),
     *                 (CURPAR(7), X     ), (CURPAR(8), Y     ),
     *                 (CURPAR(9), CHI   ), (CURPAR(10),BETA  ),
     *                 (CURPAR(11),GCM   ), (CURPAR(12),ECM   )

     *                ,(CURPAR(13),WEIGHT)


     *                ,(CURPAR(14),HAPP  ), (CURPAR(15),COSTAP),
     *                 (CURPAR(16),COSTEA)















# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 28709 "corsika.F" 2

      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

      DOUBLE PRECISION DENS,STEPNEW

      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 ( ACOSTNEW .GT. 0.003D0 ) THEN
C  NORMAL TREATMENT FOR NON-HORIZONTAL PARTICLE (INCLINATION > 0.2 DEG)

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 ( COSTHENEW .LT. 0.D0 ) THEN
         ILAY = ILAY + 1
       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 ( 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





       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 ( 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   = 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     ( 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




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
# 28918 "corsika.F"
       IF ( FLAGMU ) THEN
         STEPL = STEPL + ( H0 - HEIGH( MAX(0.D0,TH0+COSTHENEW*CHIT2) ) )
     *                                              / COSTHENEW
       ENDIF


      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


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 ( 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





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)

C  TERMINATE PROCESS IF WELL BELOW SEA LEVEL
      IF ( HNEW .LT. HLAY(1) - 1.D5  ) THEN
# 29020 "corsika.F"
        IF ( DEBUG ) WRITE(MDEBUG,*) 'PRANGC: HNEW,CHI,ARG,STEPL=',
     *                    SNGL(HNEW),SNGL(CHI),SNGL(ARG),SNGL(STEPL)
        GOTO 100

      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
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 .LT. 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


# 29260 "corsika.F"

# 29457 "corsika.F"

*-- 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


# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 29479 "corsika.F" 2

      DOUBLE PRECISION TTIME
# 29495 "corsika.F"
      INTEGER          IYEAR,MONTH,IDAY,IHOUR,IMINU,ISEC
      SAVE
C-----------------------------------------------------------------------


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
# 29563 "corsika.F"
 100  FORMAT(' PRESENT TIME : ',I2.2,'.',I2.2,'.',I4,I4.2,':',I2.2,
     *       ':',I2.2,' UTC')





      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




# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"



      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL



# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"

























      COMMON /CRRANDPA/RD,FAC,U1,U2,NSEQ,ISEED,KNOR
      DOUBLE PRECISION RD(3000),FAC,U1,U2



      INTEGER          ISEED(3,10),NSEQ

      LOGICAL          KNOR



# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 29591 "corsika.F" 2

      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


*-- 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







# 1 "corsika.h" 1
# 3562 "corsika.h"










      COMMON /CRATMOS/ AATM,AATM0,BATM,BATM0,CATM,CATM0,DATM,MODATM
     *                ,MATMFI,LATMNEW
      DOUBLE PRECISION AATM(5),AATM0(5,0:42),BATM(5),BATM0(5,0:42),
     *                 CATM(5),CATM0(5,0:42),DATM(5)
      INTEGER          MODATM,MATMFI
      LOGICAL          LATMNEW





      COMMON /CRATMOS2/HLAY,HLAY0,THICKL,LAYNO,LAYNEW
      DOUBLE PRECISION HLAY(6),HLAY0(5,0:28),THICKL(5)
      INTEGER          LAYNO(0:41)
      LOGICAL          LAYNEW













      COMMON /CRATMOSL/PATH1,RHOSLT,TSLANT,HLAYS,RHOS,THICKS,
     *                 CCATM,HLAYC,HGROUND,RADGRD,IENDT
      INTEGER          MAXSLANT,MAXSLANT2
      PARAMETER        (MAXSLANT2=1600, MAXSLANT=MAXSLANT2*5)
      DOUBLE PRECISION PATH1(MAXSLANT),RHOSLT(MAXSLANT),
     *                 TSLANT(MAXSLANT),HLAYS(6),RHOS(6),THICKS(6),
     *                 CCATM(5),HLAYC(6),HGROUND,RADGRD
      INTEGER          IENDT



# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"










      COMMON /CROBSPAR/OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP,
     *                 THETPR,PHIPR,

     *                 CORRXY,







     *                 NOBSLV
      DOUBLE PRECISION OBSLEV(20),THCKOB(20),XOFF(20),YOFF(20),
     *                 HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2)

     *                 ,CORRXY







      INTEGER          NOBSLV



# 4262 "corsika.h"



      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL



# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 29669 "corsika.F" 2

      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
        WRITE(0,*) 'CRSRADIUS0: INCORRECT INPUT R < A!'
        STOP 1
      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


*-- 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







# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"











      COMMON /CRCONSTA/PI,PI2,OB3,TB3,ENEPER,SQRT3
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER,SQRT3












































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"

























      COMMON /CRRANDPA/RD,FAC,U1,U2,NSEQ,ISEED,KNOR
      DOUBLE PRECISION RD(3000),FAC,U1,U2



      INTEGER          ISEED(3,10),NSEQ

      LOGICAL          KNOR



# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 29769 "corsika.F" 2






      DOUBLE PRECISION A,B,RR
      INTEGER LLSEQ
      SAVE
C-----------------------------------------------------------------------

      LLSEQ = 1



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


# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 29828 "corsika.F" 2

      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.


C  Cannot check with gfortran because read errors not caught.
      goto 900
# 29883 "corsika.F"
  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 :    Tanguy Pierog, KIT   10/08/2017
C=======================================================================

      SUBROUTINE RFILEATM( FILEATM, LENVAL )

C-----------------------------------------------------------------------
C  R(ead)FILEATM(ospheric table)
C
C  READ EXTERNAL FILE CONTAINING ATMOSPHERIC LAYERS AND REFRACTIVE INDEX
C  TABLE FOR RADIO CALCULATION
C  ARGUMENTS:
C   FILEATM  = PATH AND FILE NAME (DOES NOT USE DATDIR)
C   LENVAL = LENGHT OF STRING FOR FILE NAME
C-----------------------------------------------------------------------

      IMPLICIT NONE




# 1 "corsika.h" 1
# 3562 "corsika.h"










      COMMON /CRATMOS/ AATM,AATM0,BATM,BATM0,CATM,CATM0,DATM,MODATM
     *                ,MATMFI,LATMNEW
      DOUBLE PRECISION AATM(5),AATM0(5,0:42),BATM(5),BATM0(5,0:42),
     *                 CATM(5),CATM0(5,0:42),DATM(5)
      INTEGER          MODATM,MATMFI
      LOGICAL          LATMNEW





      COMMON /CRATMOS2/HLAY,HLAY0,THICKL,LAYNO,LAYNEW
      DOUBLE PRECISION HLAY(6),HLAY0(5,0:28),THICKL(5)
      INTEGER          LAYNO(0:41)
      LOGICAL          LAYNEW











# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 29925 "corsika.F" 2

      INTEGER          LENVAL,I,L,IERR
      CHARACTER(*)     FILEATM
      LOGICAL LAVAIL

C HERE IS DEFINED THE TABLE FOR THE REFRACTICE INDEX
      INTEGER MAXENTRY
      PARAMETER (MAXENTRY=200000)
      DOUBLE PRECISION GDASHEIGHT,REFRACTIVEIDX
      COMMON/GDASATMO/GDASHEIGHT(MAXENTRY),REFRACTIVEIDX(MAXENTRY)
      SAVE
C-----------------------------------------------------------------------


      INQUIRE(FILE=FILEATM(1:LENVAL),EXIST=LAVAIL)
      
      IF ( LAVAIL ) THEN

        WRITE(MONIOU,*)'READ ATMSOPHERIC TABLES FROM FILE '
     *                 ,FILEATM(1:LENVAL)
        OPEN(UNIT=MATMFI,FILE=FILEATM(1:LENVAL),STATUS='OLD')

C READ THE ATMOSPHERIC PARAMETERS
        READ(MATMFI,*)
        READ(MATMFI,*)(HLAY0(L,0),L=1,5)
        READ(MATMFI,*)(AATM0(L,42),L=1,5)
        READ(MATMFI,*)(BATM0(L,42),L=1,5)
        READ(MATMFI,*)(CATM0(L,42),L=1,5)
        LAYNEW  = .TRUE.
        LATMNEW = .TRUE.
        MODATM  = 42

C READ THE REFRACTIVE INDEX TABLE
        IERR=0
        READ(MATMFI,*)
        I=1
        DO WHILE (I.LE.MAXENTRY)
          READ(MATMFI,*,END=100)GDASHEIGHT(I),REFRACTIVEIDX(I)
c          if(I.le.100)print *,'atmfile',I,GDASHEIGHT(I),REFRACTIVEIDX(I)
          I=I+1
        ENDDO
        WRITE(MONIOU,*)'TOO MANY HEIGHT BIN, ARRAY LIMIT REACHED'




        STOP 1
 100    CLOSE (MATMFI)
        WRITE(MONIOU,*)I,' BINS READ FOR GDAS REFRACTIVE INDEX TABLE'

C  use tabulated refractive index for CoREAS via ATMFILE input command
        CALL tabularizedatmosphere(I, GDASHEIGHT, REFRACTIVEIDX)

      ELSE

        WRITE(MONIOU,*)'FILE ',FILEATM(1:LENVAL),' NOT FOUND !'




        STOP 1

      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
# 30025 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"











      COMMON /CRCONSTA/PI,PI2,OB3,TB3,ENEPER,SQRT3
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER,SQRT3












































































# 3811 "corsika.h"

# 3824 "corsika.h"










      COMMON /CRGENER/ GEN,ALEVEL
      DOUBLE PRECISION GEN,ALEVEL











# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"
























      INTEGER          LNGMAX
      PARAMETER        (LNGMAX = 15000)
      INTEGER          TYPE1
      PARAMETER        (TYPE1 = 0)
      INTEGER          TYPE2
      PARAMETER        (TYPE2 = 1)
      INTEGER          TYPE3
      PARAMETER        (TYPE3 = 2)
      INTEGER          TYPE4
      PARAMETER        (TYPE4 = 3)
      COMMON /CRLONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP



     *                ,LLONGI,FLGFIT
# 3961 "corsika.h"
      DOUBLE PRECISION ADLONG(0:LNGMAX,19),AELONG(0:LNGMAX,10),
     *                 APLONG(0:LNGMAX,10),DLONG(0:LNGMAX,19),
     *                 ELONG(0:LNGMAX,10),
     *                 HLONG(0:LNGMAX),PLONG(0:LNGMAX,10),
     *                 SDLONG(0:LNGMAX,19),SELONG(0:LNGMAX,10),
     *                 SPLONG(0:LNGMAX,10),THSTEP,THSTPI




      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT

      COMMON /CRSLANT/ RLONG,THCKRL,CTH,STHCPH,STHSPH,RLOFF
      DOUBLE PRECISION RLONG(0:LNGMAX),THCKRL(0:LNGMAX),
     *                 CTH,STHCPH,STHSPH,RLOFF


















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"








      COMMON /CRPAM/   PAMA,SIGNUM,RESTMS,DECTIM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000),
     *                 DECTIM(200)






      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL



# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"



      COMMON /CRPOLAR/ POLART,POLARF
      DOUBLE PRECISION POLART,POLARF




















      COMMON /CRRANDPA/RD,FAC,U1,U2,NSEQ,ISEED,KNOR
      DOUBLE PRECISION RD(3000),FAC,U1,U2



      INTEGER          ISEED(3,10),NSEQ

      LOGICAL          KNOR



# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"



      COMMON /CRSTACKE/E,TIM,U,V,W,X,Y,Z,DNEAR,

     *                 WT,


     *                 ZAP,WAP,WA,XXXX,YYYY,


     *                 TSLAN,




     *                 IQ,IGEN,IR,IOBS,LPCTE,NP
      DOUBLE PRECISION E(60),TIM(60),U(60),V(60),W(60),
     *                 X(60),Y(60),Z(60),DNEAR(60)

     *                 ,WT(60)


     *                 ,ZAP(60),WAP(60),WA(60),XXXX(60),YYYY(60)


     *                 ,TSLAN(60)




      INTEGER          IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP



# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 30025 "corsika.F" 2

      DOUBLE PRECISION AUX2A,BETA,COSTCM,COSTH3,COSTH4,
     *                 FAC1,FAC2,GAMMA3,GAMMA4,PHI4,WORK1,WORK2
      DOUBLE PRECISION PAMSEC
      INTEGER          I,KFROM,LHERHO
# 30038 "corsika.F"
      SAVE
C-----------------------------------------------------------------------


      IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=0,9),CURPAR(13)
  444 FORMAT(' RHO0DC: CURPAR=',1P,11E11.3)





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

C  SET WEIGHT
      SECPAR(13) = CURPAR(13)


      SECPAR(14) = CURPAR(14)
      SECPAR(15) = CURPAR(15)
      SECPAR(16) = CURPAR(16)




      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 ( SECPAR(2) .GE. C(29) ) THEN



        SECPAR(1) = GAMMA4

        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)
# 30154 "corsika.F"
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

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
# 30186 "corsika.F"
          ELSE
C  WE HAVE A MUON(-) TO ADD TO THE MUON ENERGY DEPOSIT

            DLONG(LHERHO,15) = DLONG(LHERHO,15)
     *                                     + GAMMA4*PAMA(6)*CURPAR(13)



          ENDIF
        ENDIF

# 30221 "corsika.F"
      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 ( SECPAR(2) .GE. C(29) ) THEN



        SECPAR(1) = GAMMA3

        IF ( DEBUG ) WRITE(MDEBUG,445) (SECPAR(I),I=0,9),SECPAR(13)
# 30251 "corsika.F"
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

            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
C  WE HAVE A MUON(+) TO ADD TO THE MUON ENERGY DEPOSIT

            DLONG(LHERHO,15) = DLONG(LHERHO,15)
     *                                     + GAMMA3*PAMA(5)*CURPAR(13)



          ENDIF
        ENDIF
# 30313 "corsika.F"
      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







# 1 "corsika.h" 1
# 3562 "corsika.h"










      COMMON /CRATMOS/ AATM,AATM0,BATM,BATM0,CATM,CATM0,DATM,MODATM
     *                ,MATMFI,LATMNEW
      DOUBLE PRECISION AATM(5),AATM0(5,0:42),BATM(5),BATM0(5,0:42),
     *                 CATM(5),CATM0(5,0:42),DATM(5)
      INTEGER          MODATM,MATMFI
      LOGICAL          LATMNEW





      COMMON /CRATMOS2/HLAY,HLAY0,THICKL,LAYNO,LAYNEW
      DOUBLE PRECISION HLAY(6),HLAY0(5,0:28),THICKL(5)
      INTEGER          LAYNO(0:41)
      LOGICAL          LAYNEW











# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 30341 "corsika.F" 2

      DOUBLE PRECISION ARG




      SAVE
C-----------------------------------------------------------------------

CC    IF ( DEBUG ) WRITE(MDEBUG,*) 'RHOF  : ARG=',SNGL(ARG)







      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



# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"



      INTEGER          KSEQ



      PARAMETER        (KSEQ = 9)

      COMMON /CRRANMA3/CD,CINT,CM,TWOM24,TWOM48,MODCNS
      DOUBLE PRECISION CD,CINT,CM,TWOM24,TWOM48
      INTEGER          MODCNS





      COMMON /CRRANMA4/C,U,IJKL,I97,J97,NTOT,NTOT2,JSEQ
      DOUBLE PRECISION C(KSEQ),U(97,KSEQ),UNI
      INTEGER          IJKL(KSEQ),I97(KSEQ),J97(KSEQ),
     *                 NTOT(KSEQ),NTOT2(KSEQ),JSEQ



# 4450 "corsika.h"








# 4475 "corsika.h"

















# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 30400 "corsika.F" 2

      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



# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"



      INTEGER          KSEQ



      PARAMETER        (KSEQ = 9)

      COMMON /CRRANMA3/CD,CINT,CM,TWOM24,TWOM48,MODCNS
      DOUBLE PRECISION CD,CINT,CM,TWOM24,TWOM48
      INTEGER          MODCNS





      COMMON /CRRANMA4/C,U,IJKL,I97,J97,NTOT,NTOT2,JSEQ
      DOUBLE PRECISION C(KSEQ),U(97,KSEQ),UNI
      INTEGER          IJKL(KSEQ),I97(KSEQ),J97(KSEQ),
     *                 NTOT(KSEQ),NTOT2(KSEQ),JSEQ



# 4450 "corsika.h"








# 4475 "corsika.h"

















# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 30539 "corsika.F" 2

      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
# 30630 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"



      COMMON /CRAIR/   COMPOS,PROBTA,AVERAW,AVOGDR
      DOUBLE PRECISION COMPOS(3),PROBTA(3),AVERAW,AVOGDR



# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"











      COMMON /CRCONSTA/PI,PI2,OB3,TB3,ENEPER,SQRT3
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER,SQRT3


































      COMMON /CRDPMFLG/NFLAIN,NFLDIF,NFLPI0,NFLCHE,NFLPIF,NFRAGM
      INTEGER          NFLAIN,NFLDIF,NFLPI0,NFLCHE,NFLPIF,NFRAGM








































# 3811 "corsika.h"

# 3824 "corsika.h"










      COMMON /CRGENER/ GEN,ALEVEL
      DOUBLE PRECISION GEN,ALEVEL











# 3855 "corsika.h"
















# 3880 "corsika.h"



      COMMON /CRINTER/ AVCH,AVCH3,DC0,DLOGS,DMLOG,ECMDIF,ECMDPM,ELAB,
     *                 FNEUT,FNEUT2,GNU,PLAB,POSC2,POSC3,POSN2,POSN3,
     *                 RC3TO2,S,SEUGF,SEUGP,SLOG,SLOGSQ,SMLOG,
     *                 WIDC2,WIDC3,WIDN2,WIDN3,YCM,YY0,ZN,
     *                 IDIF,ITAR
      DOUBLE PRECISION AVCH,AVCH3,DC0,DLOGS,DMLOG,ECMDIF,ECMDPM,ELAB,
     *                 FNEUT,FNEUT2,GNU,PLAB,POSC2,POSC3,POSN2,POSN3,
     *                 RC3TO2,S,SEUGF,SEUGP,SLOG,SLOGSQ,SMLOG,
     *                 WIDC2,WIDC3,WIDN2,WIDN3,YCM,YY0,ZN
      INTEGER          IDIF,ITAR













      COMMON /CRISTA/  IFINET,IFINNU,IFINKA,IFINPI,IFINHY,IFINCM,IFINOT,
     *                 IFINRHO
      INTEGER          IFINET,IFINNU,IFINKA,IFINPI,IFINHY,IFINCM,IFINOT,
     *                 IFINRHO


























      INTEGER          LNGMAX
      PARAMETER        (LNGMAX = 15000)
      INTEGER          TYPE1
      PARAMETER        (TYPE1 = 0)
      INTEGER          TYPE2
      PARAMETER        (TYPE2 = 1)
      INTEGER          TYPE3
      PARAMETER        (TYPE3 = 2)
      INTEGER          TYPE4
      PARAMETER        (TYPE4 = 3)
      COMMON /CRLONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP



     *                ,LLONGI,FLGFIT
# 3961 "corsika.h"
      DOUBLE PRECISION ADLONG(0:LNGMAX,19),AELONG(0:LNGMAX,10),
     *                 APLONG(0:LNGMAX,10),DLONG(0:LNGMAX,19),
     *                 ELONG(0:LNGMAX,10),
     *                 HLONG(0:LNGMAX),PLONG(0:LNGMAX,10),
     *                 SDLONG(0:LNGMAX,19),SELONG(0:LNGMAX,10),
     *                 SPLONG(0:LNGMAX,10),THSTEP,THSTPI




      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT

      COMMON /CRSLANT/ RLONG,THCKRL,CTH,STHCPH,STHSPH,RLOFF
      DOUBLE PRECISION RLONG(0:LNGMAX),THCKRL(0:LNGMAX),
     *                 CTH,STHCPH,STHSPH,RLOFF


















# 4005 "corsika.h"
















# 4047 "corsika.h"



      COMMON /CRMULT/  EKINL,MSMM,MULTMA,MULTOT
      DOUBLE PRECISION EKINL
      INTEGER          MSMM,MULTMA(40,13),MULTOT(40,13)



# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"



      COMMON /CRNCSNCS/SIGN30,SIGN45,SIGN60,SIGO30,SIGO45,SIGO60,
     *                 SIGA30,SIGA45,SIGA60,PNOA30,PNOA45,PNOA60,
     *                 SIG30A,SIG45A,SIG60A
      DOUBLE PRECISION SIGN30(56),SIGN45(56),SIGN60(56),
     *                 SIGO30(56),SIGO45(56),SIGO60(56),
     *                 SIGA30(56),SIGA45(56),SIGA60(56),
     *                 PNOA30(1540,3),PNOA45(1540,3),PNOA60(1540,3),
     *                 SIG30A(56),SIG45A(56),SIG60A(56)



# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"








      COMMON /CRPAM/   PAMA,SIGNUM,RESTMS,DECTIM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000),
     *                 DECTIM(200)






      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL





      DOUBLE PRECISION GAMMA,COSTHE,PHIX,PHIY,H,T,X,Y,CHI,BETA,GCM,ECM

     *                 ,WEIGHT


     *                 ,HAPP,COSTAP,COSTEA




      EQUIVALENCE      (CURPAR(1), GAMMA ), (CURPAR(2), COSTHE),
     *                 (CURPAR(3), PHIX  ), (CURPAR(4), PHIY  ),
     *                 (CURPAR(5), H     ), (CURPAR(6), T     ),
     *                 (CURPAR(7), X     ), (CURPAR(8), Y     ),
     *                 (CURPAR(9), CHI   ), (CURPAR(10),BETA  ),
     *                 (CURPAR(11),GCM   ), (CURPAR(12),ECM   )

     *                ,(CURPAR(13),WEIGHT)


     *                ,(CURPAR(14),HAPP  ), (CURPAR(15),COSTAP),
     *                 (CURPAR(16),COSTEA)















# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"

























      COMMON /CRRANDPA/RD,FAC,U1,U2,NSEQ,ISEED,KNOR
      DOUBLE PRECISION RD(3000),FAC,U1,U2



      INTEGER          ISEED(3,10),NSEQ

      LOGICAL          KNOR



# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"











      COMMON /CRREST/  CONTNE,TAR,LIT
      DOUBLE PRECISION CONTNE(3),TAR
      INTEGER          LIT





      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"



      COMMON /CRSIGM/  SIGMA,SIGANN,SIGAIR,FRACTN,FRCTNO
      DOUBLE PRECISION SIGMA,SIGANN,SIGAIR,FRACTN,FRCTNO



# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"



      COMMON /CRVKIN/  BETACM
      DOUBLE PRECISION BETACM










     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     
















      COMMON /CRSIBYLC/FSIBYL,FSIBSG,FSIBCH
      LOGICAL          FSIBYL,FSIBSG,FSIBCH



     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 30630 "corsika.F" 2

      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
# 30645 "corsika.F"
      SAVE
      EXTERNAL         CGHSIG
C-----------------------------------------------------------------------


      IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=0,9),WEIGHT
  444 FORMAT(' SDPM  : CURPAR=',1P,11E11.3)





C  IA IS MASS NUMBER OF PROJECTILE
      IA = ITYPE / 100
      IF ( IA .GT. 56 ) THEN

        WRITE(MONIOU,444) (CURPAR(I),I=0,9),WEIGHT



        WRITE(MONIOU,*) 'SDPM  : NOT FORESEEN PARTICLE TYPE=',ITYPE
        STOP 1
      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
# 30734 "corsika.F"
C  GAMMAS ARE TREATED BY SIBYLL, IF SUFFICIENT ENERGY
        IF ( FSIBYL  .AND.  CURPAR(1) .GT. HILOELB ) THEN
          CALL SIBLNK
        ELSE
          CALL HDPM
        ENDIF
# 30750 "corsika.F"

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.
# 30788 "corsika.F"
        ELSE
C  SELECT THE TARGET ACCORDING OCCURENCE AND CROSS SECTION CONTRIBUTION
# 30802 "corsika.F"
C  TARGET IS CHOSEN AT RANDOM ACCORDING TO CROSS-SECTION
# 30819 "corsika.F"
C  SIGAIR, FRACTN, FRCTNO HAVE BEEN DETERMINED IN BOX2/SIBSIG          
C  SIGMA IS ENERGY DEPENDENT INELASTIC NUCLEON-NUCLEON CROSS-SECTION
C  AND IS SET IN BOX2/SIBSIG
          IF ( FSIBSG ) GOTO 333
# 30832 "corsika.F"
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

 333      CONTINUE

          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

# 30938 "corsika.F"
        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
# 30974 "corsika.F"

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
# 31010 "corsika.F"
C  AND IS SET IN BOX2/SIBSIG/SIGNUC_INI2
          IF ( FSIBSG ) GOTO 334
# 31024 "corsika.F"
C  CROSS SECTION HAS BEEN DETERMINED IN BOX2 WHICH MIGHT BE USED
          IF ( FURQSG ) GOTO 334

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

 334      CONTINUE

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
# 31092 "corsika.F"
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








C  TREATMENT OF NUCLEUS-NUCLEUS INTERACTION IN HDPM BY SUPERPOSITION
C
C  INDEX CALCULATION 1<I=<56     NUCLEONS IN PROJECTILE
C                    1<J<I       INTERACTING NUCLEONS
C                    P(I,I)=1    CUMULATIVE PROBABILITIES
C                    P(I,J)  ---> 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




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 ( DEBUG ) WRITE(MDEBUG,554) (CURPAR(I),I=0,9),WEIGHT
  554       FORMAT(' SDPM  : CURPAR=',1P,11E11.3)




            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 ( SECPAR(2) .GE. C(29) ) THEN



                  IF ( J .LT. JFIN ) THEN
                    SECPAR(0)  = ITYP(J)



                    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

                    DLONG(LHEIGH,17) = DLONG(LHEIGH,17)
     *                            + ( EA-RESTMS(ITYP(J)) )*WEIGHT




                  ENDIF
# 31273 "corsika.F"
                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 ( DEBUG ) WRITE(MDEBUG,555) (SECPAR(I),I=0,9),SECPAR(13)
 555        FORMAT(' SDPM  : SECPAR=',1P,9E11.3,0P,F10.0,1P,E10.3)




          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
# 31356 "corsika.F"
C  NEW URQMD LINK (MARCH 2004) WILL NOT TREAT NUCLEI,
C  THEREFORE USE SUPERPOSITION
              CALL URQLNK

            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
# 31390 "corsika.F"
C  NEW URQMDLINK (MARCH 2004) WILL NOT TREAT NUCLEI,
C  THEREFORE USE SUPERPOSITION
              CALL URQLNK

            ELSE
C  DUAL PARTON MODEL
              CALL HDPM
            ENDIF
          ENDDO
        ENDIF
C  ALL PARTICLES, INCLUDING THE LEADING ONE, ARE NOW WRITTEN TO STACK

      ELSE

        WRITE(MONIOU,444) (CURPAR(I),I=0,9),WEIGHT



        WRITE(MONIOU,*) 'SDPM  : NOT FORESEEN PARTICLE TYPE=',ITYPE
        STOP 1
      ENDIF

      RETURN
      END


*-- 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


# 31684 "corsika.F"

*-- 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
# 31711 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"










      COMMON /CRATMOS/ AATM,AATM0,BATM,BATM0,CATM,CATM0,DATM,MODATM
     *                ,MATMFI,LATMNEW
      DOUBLE PRECISION AATM(5),AATM0(5,0:42),BATM(5),BATM0(5,0:42),
     *                 CATM(5),CATM0(5,0:42),DATM(5)
      INTEGER          MODATM,MATMFI
      LOGICAL          LATMNEW





      COMMON /CRATMOS2/HLAY,HLAY0,THICKL,LAYNO,LAYNEW
      DOUBLE PRECISION HLAY(6),HLAY0(5,0:28),THICKL(5)
      INTEGER          LAYNO(0:41)
      LOGICAL          LAYNEW











# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"






















































      COMMON /CREDECAY/CETA
      DOUBLE PRECISION CETA(5)

































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"



      COMMON /CRKAONS/ CKA
      DOUBLE PRECISION CKA(80)

















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"



      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL





      DOUBLE PRECISION GAMMA,COSTHE,PHIX,PHIY,H,T,X,Y,CHI,BETA,GCM,ECM

     *                 ,WEIGHT


     *                 ,HAPP,COSTAP,COSTEA




      EQUIVALENCE      (CURPAR(1), GAMMA ), (CURPAR(2), COSTHE),
     *                 (CURPAR(3), PHIX  ), (CURPAR(4), PHIY  ),
     *                 (CURPAR(5), H     ), (CURPAR(6), T     ),
     *                 (CURPAR(7), X     ), (CURPAR(8), Y     ),
     *                 (CURPAR(9), CHI   ), (CURPAR(10),BETA  ),
     *                 (CURPAR(11),GCM   ), (CURPAR(12),ECM   )

     *                ,(CURPAR(13),WEIGHT)


     *                ,(CURPAR(14),HAPP  ), (CURPAR(15),COSTAP),
     *                 (CURPAR(16),COSTEA)















# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"











      COMMON /CRSTRBAR/CSTRBA
      DOUBLE PRECISION CSTRBA(11)



# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 31711 "corsika.F" 2

      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     ( MODATM .EQ.  0 ) THEN

        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) )')
      ELSEIF ( MODATM .EQ. 30 ) THEN
        WRITE(MONIOU,330)
  330   FORMAT('  ( SOUTH POLE ATMOSPHERE FOR JANUARY (ICETOP) )')
      ELSEIF ( MODATM .EQ. 31 ) THEN
        WRITE(MONIOU,331)
  331   FORMAT('  ( SOUTH POLE ATMOSPHERE FOR FEBRUARY (ICETOP) )')
      ELSEIF ( MODATM .EQ. 32 ) THEN
        WRITE(MONIOU,332)
  332   FORMAT('  ( SOUTH POLE ATMOSPHERE FOR MARCH (ICETOP) )')
      ELSEIF ( MODATM .EQ. 33 ) THEN
        WRITE(MONIOU,333)
  333   FORMAT('  ( SOUTH POLE ATMOSPHERE FOR APRIL (ICETOP) )')
      ELSEIF ( MODATM .EQ. 34 ) THEN
        WRITE(MONIOU,334)
  334   FORMAT('  ( SOUTH POLE ATMOSPHERE FOR MAY (ICETOP) )')
      ELSEIF ( MODATM .EQ. 35 ) THEN
        WRITE(MONIOU,335)
  335   FORMAT('  ( SOUTH POLE ATMOSPHERE FOR JUNE (ICETOP) )')
      ELSEIF ( MODATM .EQ. 36 ) THEN
        WRITE(MONIOU,336)
  336   FORMAT('  ( SOUTH POLE ATMOSPHERE FOR JULY (ICETOP) )')
      ELSEIF ( MODATM .EQ. 37 ) THEN
        WRITE(MONIOU,337)
  337   FORMAT('  ( SOUTH POLE ATMOSPHERE FOR AUGUST (ICETOP) )')
      ELSEIF ( MODATM .EQ. 38 ) THEN
        WRITE(MONIOU,338)
  338   FORMAT('  ( SOUTH POLE ATMOSPHERE FOR SEPTEMBER (ICETOP) )')
      ELSEIF ( MODATM .EQ. 39 ) THEN
        WRITE(MONIOU,339)
  339   FORMAT('  ( SOUTH POLE ATMOSPHERE FOR OCTOBER (ICETOP) )')
      ELSEIF ( MODATM .EQ. 40 ) THEN
        WRITE(MONIOU,340)
  340   FORMAT('  ( SOUTH POLE ATMOSPHERE FOR NOVEMBER (ICETOP) )')
      ELSEIF ( MODATM .EQ. 41 ) THEN
        WRITE(MONIOU,341)
  341   FORMAT('  ( SOUTH POLE ATMOSPHERE FOR DECEMBER (ICETOP) )')
      ELSEIF ( MODATM .EQ. 42 ) THEN
        WRITE(MONIOU,342)
  342   FORMAT('  ( ATMOSPHERE FROM EXTERNAL FILE (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
# 31966 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"



      COMMON /CRAIR/   COMPOS,PROBTA,AVERAW,AVOGDR
      DOUBLE PRECISION COMPOS(3),PROBTA(3),AVERAW,AVOGDR





      COMMON /CRATMOS/ AATM,AATM0,BATM,BATM0,CATM,CATM0,DATM,MODATM
     *                ,MATMFI,LATMNEW
      DOUBLE PRECISION AATM(5),AATM0(5,0:42),BATM(5),BATM0(5,0:42),
     *                 CATM(5),CATM0(5,0:42),DATM(5)
      INTEGER          MODATM,MATMFI
      LOGICAL          LATMNEW





      COMMON /CRATMOS2/HLAY,HLAY0,THICKL,LAYNO,LAYNEW
      DOUBLE PRECISION HLAY(6),HLAY0(5,0:28),THICKL(5)
      INTEGER          LAYNO(0:41)
      LOGICAL          LAYNEW











# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"



      COMMON /CRBUFFS/ RUNH,RUNE,EVTH,EVTE,DATAB,ARRAYLONG,LH

     *                 ,WRRUNH,WRRUNE,WREVTH,WREVTE

      INTEGER          MAXBUF,MAXLEN

      PARAMETER        (MAXBUF=39*8)
# 3681 "corsika.h"
      PARAMETER        (MAXLEN=16)
# 3693 "corsika.h"
      REAL             RUNH(MAXBUF),EVTH(MAXBUF),EVTE(MAXBUF),
     *                 RUNE(MAXBUF),DATAB(MAXBUF),ARRAYLONG(MAXBUF)
      INTEGER          LH

      LOGICAL          WRRUNH,WRRUNE,WREVTH,WREVTE

      CHARACTER*4      CRUNH,CRUNE,CEVTH,CEVTE,CLONG
      EQUIVALENCE      (RUNH(1),CRUNH), (RUNE(1),CRUNE)
      EQUIVALENCE      (EVTH(1),CEVTH), (EVTE(1),CEVTE)
      EQUIVALENCE      (ARRAYLONG(1),CLONG)













      COMMON /CRCONSTA/PI,PI2,OB3,TB3,ENEPER,SQRT3
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER,SQRT3


































      COMMON /CRDPMFLG/NFLAIN,NFLDIF,NFLPI0,NFLCHE,NFLPIF,NFRAGM
      INTEGER          NFLAIN,NFLDIF,NFLPI0,NFLCHE,NFLPIF,NFRAGM





      COMMON /CREDECAY/CETA
      DOUBLE PRECISION CETA(5)













      COMMON /CRELABCT/ELCUT
      DOUBLE PRECISION ELCUT(4)


















# 3811 "corsika.h"

# 3824 "corsika.h"



      COMMON /CRETHMAP/ECTMAP,ELEFT,ELEFTJ
      DOUBLE PRECISION ECTMAP,ELEFT,ELEFTJ


















# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"



      COMMON /CRKAONS/ CKA
      DOUBLE PRECISION CKA(80)

















# 3980 "corsika.h"










      COMMON /CRMAGNET/BX,BZ,BVAL,BNORMC,BNORM,COSB,SINB,BLIMIT
      DOUBLE PRECISION BX,BZ,BVAL,BNORMC,BNORM,COSB,SINB,BLIMIT



# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"



      COMMON /CRMUMULT/CHC,OMC,PHISCT,STEPL,VSCAT,FMOLI
      DOUBLE PRECISION CHC,OMC,PHISCT,STEPL,VSCAT
      LOGICAL          FMOLI












      COMMON /CRMUPART/AATOM,AMUPAR,BCUT,CMUON,CTAU,CONSTKINE,
     *                 EBYMU,EBYTAU,EE,SE,VFRAC,VMAX,VMIN,ZATOM,
     *                 MT,FMUBRM,FMUNUC,FMUORG






      DOUBLE PRECISION AMUPAR(0:18),BCUT,CMUON(11),CTAU(11),


     *                 AATOM,CONSTKINE,EBYMU,EBYTAU,EE,SE,
     *                 VFRAC,VMAX,VMIN,ZATOM
      INTEGER          MT
      LOGICAL          FMUBRM,FMUNUC,FMUORG





      COMMON /CRNCSNCS/SIGN30,SIGN45,SIGN60,SIGO30,SIGO45,SIGO60,
     *                 SIGA30,SIGA45,SIGA60,PNOA30,PNOA45,PNOA60,
     *                 SIG30A,SIG45A,SIG60A
      DOUBLE PRECISION SIGN30(56),SIGN45(56),SIGN60(56),
     *                 SIGO30(56),SIGO45(56),SIGO60(56),
     *                 SIGA30(56),SIGA45(56),SIGA60(56),
     *                 PNOA30(1540,3),PNOA45(1540,3),PNOA60(1540,3),
     *                 SIG30A(56),SIG45A(56),SIG60A(56)



# 4153 "corsika.h"



      COMMON /CRNKGI/  SEL,SELLG,STH,ZEL,ZELLG,ZSL,DIST,
     *                 DISX,DISY,DISXY,DISYX,DLAX,DLAY,DLAXY,DLAYX,
     *                 OBSATI,RADNKG,RMOL,TLEV,TLEVCM,IALT
      DOUBLE PRECISION SEL(10),SELLG(10),STH(10),ZEL(10),ZELLG(10),
     *                 ZSL(10),DIST(10),
     *                 DISX(-10:10),DISY(-10:10),
     *                 DISXY(-10:10,2),DISYX(-10:10,2),
     *                 DLAX (-10:10,2),DLAY (-10:10,2),
     *                 DLAXY(-10:10,2),DLAYX(-10:10,2),
     *                 OBSATI(2),RADNKG,RMOL(2),TLEV(10),TLEVCM(10)
      INTEGER          IALT(2)


















# 4212 "corsika.h"










      COMMON /CROBSPAR/OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP,
     *                 THETPR,PHIPR,

     *                 CORRXY,







     *                 NOBSLV
      DOUBLE PRECISION OBSLEV(20),THCKOB(20),XOFF(20),YOFF(20),
     *                 HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2)

     *                 ,CORRXY







      INTEGER          NOBSLV










      COMMON /CRPAM/   PAMA,SIGNUM,RESTMS,DECTIM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000),
     *                 DECTIM(200)






      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL





      DOUBLE PRECISION GAMMA,COSTHE,PHIX,PHIY,H,T,X,Y,CHI,BETA,GCM,ECM

     *                 ,WEIGHT


     *                 ,HAPP,COSTAP,COSTEA




      EQUIVALENCE      (CURPAR(1), GAMMA ), (CURPAR(2), COSTHE),
     *                 (CURPAR(3), PHIX  ), (CURPAR(4), PHIY  ),
     *                 (CURPAR(5), H     ), (CURPAR(6), T     ),
     *                 (CURPAR(7), X     ), (CURPAR(8), Y     ),
     *                 (CURPAR(9), CHI   ), (CURPAR(10),BETA  ),
     *                 (CURPAR(11),GCM   ), (CURPAR(12),ECM   )

     *                ,(CURPAR(13),WEIGHT)


     *                ,(CURPAR(14),HAPP  ), (CURPAR(15),COSTAP),
     *                 (CURPAR(16),COSTEA)















# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"










      COMMON /CRPRIMSP/PSLOPE,LLIMIT,ULIMIT,LL,UL,SLEX,ISPEC
      DOUBLE PRECISION PSLOPE,LLIMIT,ULIMIT,LL,UL,SLEX
      INTEGER          ISPEC












      COMMON /CRRANDPA/RD,FAC,U1,U2,NSEQ,ISEED,KNOR
      DOUBLE PRECISION RD(3000),FAC,U1,U2



      INTEGER          ISEED(3,10),NSEQ

      LOGICAL          KNOR



# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"



      COMMON /CRSTACKF/STACKI,



     *                 MSTACKP,MEXST,NSHIFT,NOUREC,NOURECMAX,ICOUNT,
     *                 NTO,NFROM




      INTEGER          MAXSTK
# 4796 "corsika.h"
      PARAMETER        (MAXSTK = 17*256*2)
# 4809 "corsika.h"
      DOUBLE PRECISION STACKI(MAXSTK)



      INTEGER          MSTACKP,MEXST,NSHIFT,NOUREC,NOURECMAX,ICOUNT,
     *                 NTO,NFROM

















      COMMON /CRSTRBAR/CSTRBA
      DOUBLE PRECISION CSTRBA(11)



# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"


















      COMMON /CRVERS/  VERNUM,MVDATE,VERDAT
      DOUBLE PRECISION VERNUM
      INTEGER          MVDATE
      CHARACTER*18     VERDAT

















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     
















      COMMON /CRSIBYLC/FSIBYL,FSIBSG,FSIBCH
      LOGICAL          FSIBYL,FSIBSG,FSIBCH



     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 31966 "corsika.F" 2

      DOUBLE PRECISION HEIGH,OOO,TEMP1,TEMP2,TEMP3,THICK,
     *                 TTIME,ZE,ZS,ZX
      INTEGER          I,IA,J,L,NSEQMN
      SAVE
      EXTERNAL         HEIGH,THICK




C-----------------------------------------------------------------------

# 31991 "corsika.F"

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',/,
# 32027 "corsika.F"
     *' SIBYLL 2.3 MODEL ACCORDING TO F. RIEHN & R. ENGEL, IKP KIT',
     *' KARLSRUHE,',/,




     *' HDPM MODEL ACCORDING TO J.N. CAPDEVIELLE, COLLEGE DE FRANCE,',
     *' PARIS, FRANCE',/,
# 32044 "corsika.F"
     *' URQMD-MODEL FROM THE URQMD-COLLABORATION, FRANKFURT(MAIN),',
     *' GERMANY',/,

     *' 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)',/,

     *'             D. HECK, J. KNAPP, REPORT FZKA 6097 (1998)',/,


     *'             D. HECK, REPORT FZKA 7254 (2006)',/,

     *'             SEE ALSO WEB PAGE https://www.iap.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 ,/)


      WRITE(MONIOU,*) 'VERSION GENERATED FOR UNIX OR COMPATIBLE SYSTEMS'
      WRITE(MONIOU,*) '^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^'

      WRITE(MONIOU,*) ' (RECL IS DEFINED IN BYTES)'
# 32091 "corsika.F"
      WRITE(MONIOU,*) ' WITH TIMERC DATE ROUTINE'
# 32107 "corsika.F"
      WRITE(MONIOU,*) 'ZENITH ANGLE DEPENDENCE FOR FLAT DETECTOR ARRAY'

      WRITE(MONIOU,*) ' '

# 32164 "corsika.F"
      WRITE(MONIOU,1556)

 1556 FORMAT(' COASTUSERLIB IS USED',/,
     *       ' ====================',/)
# 32178 "corsika.F"
      WRITE(MONIOU,*) 'CHARMED PARTICLES ARE EXPLICITELY TREATED'
      WRITE(MONIOU,*) '========================================='

      WRITE(MONIOU,*) ' '
# 32208 "corsika.F"
      WRITE(MONIOU,1502)
 1502 FORMAT(' CURVED VERSION WITH SLIDING PLANAR ATMOSPHERE',/,
     *       ' =============================================',/)
# 32301 "corsika.F"
      WRITE(MONIOU,1503)
 1503 FORMAT(' SLANT DEPTH FOR LONGITUDINAL DISTRIBUTIONS',/,
     *       ' ==========================================',/)







      WRITE(MONIOU,*) 'TAU LEPTONS ARE EXPLICITELY TREATED'
      WRITE(MONIOU,*) '==================================='
      WRITE(MONIOU,*) ' '


      WRITE(MONIOU,1563)
 1563 FORMAT(' THINNING IS ACTIVE',/,
     *       ' ==================',/)
# 32327 "corsika.F"
      WRITE(MONIOU,1620)
 1620 FORMAT(' UPWARD VERSION FOR UPWARD GOING PARTICLES',/,
     *       ' =========================================',/)
# 32341 "corsika.F"
      WRITE(MONIOU,*) ' '
C

C  INITIALIZE ARRAY WITH PARTICLE MASSES
      CALL PAMAF

C  READ RUN STEERING DATA CARDS
      CALL DATAC

# 32373 "corsika.F"
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


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',/,
     *         ' =====================================',/)

      WRITE(MONIOU,1441)
 1441 FORMAT(/)

C  PREPARE ATMOSPHERIC MODEL
      IF ( MODATM .LT. 0  .OR.  MODATM .GT. 42 ) THEN
        WRITE(MONIOU,*) 'START : MODATM < 0 OR > 42 NOT POSSIBLE! STOP'
        WRITE(MONIOU,*)
        WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE'
        WRITE(MONIOU,*) 'SEE KEYWORD: ATMOD'




        STOP 1
      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

# 32458 "corsika.F"
C  LIMIT ATMOSPHERE LOWER BOUNDARY TO SEA LEVEL
      HLAY(1) = MAX( HLAY(1), -1000.D2 )

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 1
        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')

# 32495 "corsika.F"


C IN CASE OF UPWARD GOING SHOWER, START FROM LOWEST OBSERVATION LEVEL
      IF ( THICK0 .LE. 0D0 .AND. THETPR(1) .GT.90.D0)
     *     THICK0 = THICK(OBSLEV(NOBSLV)+0.0001D0)


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.





      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
# 32665 "corsika.F"
      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
# 32690 "corsika.F"
        ENDIF
        CALL RMMAQD( ISEED(1,I),I,'S' )
      ENDDO
      KNOR = .TRUE.

      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))

# 32726 "corsika.F"

      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('='))
# 32818 "corsika.F"
      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
# 32858 "corsika.F"
 1506 FORMAT(' HDPM ROUTINES TREAT HIGH ENERGY HADRONIC INTERACTIONS')








      IF ( .NOT. FSIBYL ) THEN



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

      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'
# 32918 "corsika.F"
      ELSE
        NFRAGM = 2
        WRITE(MONIOU,*) 'FRAGMENTATION ACCORDING TO SIBYLL, PT=0'
      ENDIF
# 32947 "corsika.F"
      WRITE(MONIOU,*)

C  LOW ENERGY HADRONIC INTERACTION MODEL
# 32977 "corsika.F"
      IF ( FURQMD ) THEN
        WRITE(MONIOU,*) 'URQMD TREATS LOW ENERGY HADRONIC ',
     *                  'INTERACTIONS'
        CALL URQINI
      ELSE
        WRITE(MONIOU,*) 'NO LOW ENERGY HADRONIC INTERACTION',
     *      ' MODEL AVAILABLE'




        STOP 1
      ENDIF


C
C  INITIALIZE PYTHIA ROUTINES FOR CHARMED PARTICLE OR TAU LEPTON DECAYS
      CALL PYTINI






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








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

        WRITE(MONIOU,2121)
 2121   FORMAT(' ######################################################'

     *     ,/, ' # SIMULATION WITH NKG NOT POSSIBLE IN CURVED VERSION #'



     *     ,/, ' ######################################################'
     *     ,/ )
        FNKG = .FALSE.
# 33091 "corsika.F"
      ENDIF
C  WRITE STEERING FLAGS FOR ELECTROMAGNETIC PART AS REAL TO HEADER
      IF ( FNKG ) THEN




        RUNH(20) = 1.
        EVTH(74) = 1.

      ELSE
        RUNH(20) = 0.
        EVTH(74) = 0.
      ENDIF
      IF ( FEGS ) THEN




        RUNH(19) = 1.
        EVTH(73) = 1.

      ELSE
        RUNH(19) = 0.
        EVTH(73) = 0.
      ENDIF
      EVTH(95)  = STEPFC

C  PROGRAM CONFIGURATIONS FOR EVENT HEADER





      EVTH(75)  = 2.



      EVTH(76)  = 0.
      EVTH(139) = 0.
      EVTH(140) = 0.
      EVTH(141) = 0.
      EVTH(142) = 0.
      EVTH(143) = 0.
      EVTH(144) = 0.
      EVTH(145) = 0.
# 33209 "corsika.F"
      IF ( FSIBYL ) THEN
        EVTH(76)  = 2.
        EVTH(139) = 4.       !sibyll 2.3d
      ELSE
        EVTH(76)  = 0.
        EVTH(139) = 0.
      ENDIF
      IF ( FSIBSG ) THEN
        EVTH(140) = 4.
      ELSE
        EVTH(140) = 0.
      ENDIF
# 33237 "corsika.F"
      EVTH(153) = 0.
      EVTH(154) = 0.

      EVTH(155) = HILOELB

      EVTH(159) = 1.
# 33286 "corsika.F"
      EVTH(77) = 0.




      EVTH(78) = 0.


      EVTH(79) = 2.




      EVTH(80) = 3.




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)





      C(27)   = COS( C(26) )

      C(28)   = PI
      C(29)   = MAX( COS( C(28) ), -1.D0 )




C  CALCULATE CONSTANT FOR MAXIMAL HORIZONTAL RANGE WITHIN LOCAL SYSTEM
      C(4)    = (C(2)-C(3)) / THICK( 0.D0 )





      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




      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 1
        ENDIF
        IF ( STEPFC .NE. 1.D0 ) WRITE(MONIOU,*)'STEP LENGTH ',
     *        'FACTOR FOR ELECTRON MULTIPLE SCATTERING =',SNGL(STEPFC)





C  READ EGSDAT FILE IN EGSIN2
          CALL EGSIN2





      ENDIF
C-----------------------------------------------------------------------
# 33549 "corsika.F"
      CALL STAEND

      RETURN
      END

# 33938 "corsika.F"

*-- 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







# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"



      COMMON /CRIRET/  IRET1,IRET2,IRETE
      INTEGER          IRET1,IRET2
      LOGICAL          IRETE



# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"



      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL





      DOUBLE PRECISION GAMMA,COSTHE,PHIX,PHIY,H,T,X,Y,CHI,BETA,GCM,ECM

     *                 ,WEIGHT


     *                 ,HAPP,COSTAP,COSTEA




      EQUIVALENCE      (CURPAR(1), GAMMA ), (CURPAR(2), COSTHE),
     *                 (CURPAR(3), PHIX  ), (CURPAR(4), PHIY  ),
     *                 (CURPAR(5), H     ), (CURPAR(6), T     ),
     *                 (CURPAR(7), X     ), (CURPAR(8), Y     ),
     *                 (CURPAR(9), CHI   ), (CURPAR(10),BETA  ),
     *                 (CURPAR(11),GCM   ), (CURPAR(12),ECM   )

     *                ,(CURPAR(13),WEIGHT)


     *                ,(CURPAR(14),HAPP  ), (CURPAR(15),COSTAP),
     *                 (CURPAR(16),COSTEA)















# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"

























      COMMON /CRRANDPA/RD,FAC,U1,U2,NSEQ,ISEED,KNOR
      DOUBLE PRECISION RD(3000),FAC,U1,U2



      INTEGER          ISEED(3,10),NSEQ

      LOGICAL          KNOR



# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"











      COMMON /CRSTRBAR/CSTRBA
      DOUBLE PRECISION CSTRBA(11)



# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 33960 "corsika.F" 2

      INTEGER          I
      SAVE
C-----------------------------------------------------------------------


      IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=0,9),WEIGHT
 444  FORMAT(' STRDEC: CURPAR=',1P,11E11.3)





      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

        WRITE(MONIOU,444) (CURPAR(I),I=0,9),WEIGHT



        WRITE(MONIOU,*) 'STRDEC: UNFORESEEN PARTICLE CODE =',ITYPE
      ENDIF
      IRET1 = 1

      RETURN
      END

# 34130 "corsika.F"


*-- 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 STARTING POINT
C  (TOP OF ATMOSPHERE, FIXHEI, GROUND IF UPWARD)
C  THIS FUNCTION IS CALLED FROM  MUNUCL, UPDATC, UPDATE, EGS4, ELECTR,
C  PHOTON, CERLDE.
C  ARGUMENT:
C   ARGU   = SLANT PATH (CM)
C-----------------------------------------------------------------------

      IMPLICIT NONE






# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"











      COMMON /CRATMOSL/PATH1,RHOSLT,TSLANT,HLAYS,RHOS,THICKS,
     *                 CCATM,HLAYC,HGROUND,RADGRD,IENDT
      INTEGER          MAXSLANT,MAXSLANT2
      PARAMETER        (MAXSLANT2=1600, MAXSLANT=MAXSLANT2*5)
      DOUBLE PRECISION PATH1(MAXSLANT),RHOSLT(MAXSLANT),
     *                 TSLANT(MAXSLANT),HLAYS(6),RHOS(6),THICKS(6),
     *                 CCATM(5),HLAYC(6),HGROUND,RADGRD
      INTEGER          IENDT



# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"
























      INTEGER          LNGMAX
      PARAMETER        (LNGMAX = 15000)
      INTEGER          TYPE1
      PARAMETER        (TYPE1 = 0)
      INTEGER          TYPE2
      PARAMETER        (TYPE2 = 1)
      INTEGER          TYPE3
      PARAMETER        (TYPE3 = 2)
      INTEGER          TYPE4
      PARAMETER        (TYPE4 = 3)
      COMMON /CRLONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP



     *                ,LLONGI,FLGFIT
# 3961 "corsika.h"
      DOUBLE PRECISION ADLONG(0:LNGMAX,19),AELONG(0:LNGMAX,10),
     *                 APLONG(0:LNGMAX,10),DLONG(0:LNGMAX,19),
     *                 ELONG(0:LNGMAX,10),
     *                 HLONG(0:LNGMAX),PLONG(0:LNGMAX,10),
     *                 SDLONG(0:LNGMAX,19),SELONG(0:LNGMAX,10),
     *                 SPLONG(0:LNGMAX,10),THSTEP,THSTPI




      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT

      COMMON /CRSLANT/ RLONG,THCKRL,CTH,STHCPH,STHSPH,RLOFF
      DOUBLE PRECISION RLONG(0:LNGMAX),THCKRL(0:LNGMAX),
     *                 CTH,STHCPH,STHSPH,RLOFF


















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 34156 "corsika.F" 2

      DOUBLE PRECISION ARG,ARGU,SL
      INTEGER          I1,I2,II
      SAVE
C-----------------------------------------------------------------------

C  SET FIRST AND LAST BIN FOR SEARCH
      I1 = IENDT                ! last bin of slant longi distribution
      I2 = MAXSLANT             ! first bin of slant longi distribution

      IF ( ARGU .LT. 0.D0 ) THEN
C PARTICLE OUT OF RANGE

        IF ( CTH .LT. 0.D0 ) THEN
          THCKSI = 1.5D0 * TSLANT(I1)
        ELSE

          THCKSI = 1.5D0 * TSLANT(I2)

        ENDIF

        IF ( DEBUG ) WRITE(MDEBUG,*) 'THCKSI: ARGU,THCKSI=',
     *                     SNGL(ARGU),SNGL(THCKSI)
        RETURN
      ELSE
        ARG = ARGU
      ENDIF


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

       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

      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
      IF ( DEBUG ) WRITE(MDEBUG,*) 'THCKSI: I1,I2,ARG,SL,THCKSI=',
     *                     I1,I2,SNGL(ARG),SNGL(SL),SNGL(THCKSI)

      RETURN
      END


*-- 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







# 1 "corsika.h" 1
# 3562 "corsika.h"










      COMMON /CRATMOS/ AATM,AATM0,BATM,BATM0,CATM,CATM0,DATM,MODATM
     *                ,MATMFI,LATMNEW
      DOUBLE PRECISION AATM(5),AATM0(5,0:42),BATM(5),BATM0(5,0:42),
     *                 CATM(5),CATM0(5,0:42),DATM(5)
      INTEGER          MODATM,MATMFI
      LOGICAL          LATMNEW





      COMMON /CRATMOS2/HLAY,HLAY0,THICKL,LAYNO,LAYNEW
      DOUBLE PRECISION HLAY(6),HLAY0(5,0:28),THICKL(5)
      INTEGER          LAYNO(0:41)
      LOGICAL          LAYNEW











# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 34254 "corsika.F" 2

      DOUBLE PRECISION ARG
      SAVE




C-----------------------------------------------------------------------

CC    IF ( DEBUG ) WRITE(MDEBUG,*) 'THICK : ARG=',SNGL(ARG)








      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


*-- 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







# 1 "corsika.h" 1
# 3562 "corsika.h"










      COMMON /CRATMOS/ AATM,AATM0,BATM,BATM0,CATM,CATM0,DATM,MODATM
     *                ,MATMFI,LATMNEW
      DOUBLE PRECISION AATM(5),AATM0(5,0:42),BATM(5),BATM0(5,0:42),
     *                 CATM(5),CATM0(5,0:42),DATM(5)
      INTEGER          MODATM,MATMFI
      LOGICAL          LATMNEW





      COMMON /CRATMOS2/HLAY,HLAY0,THICKL,LAYNO,LAYNEW
      DOUBLE PRECISION HLAY(6),HLAY0(5,0:28),THICKL(5)
      INTEGER          LAYNO(0:41)
      LOGICAL          LAYNEW











# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"










      COMMON /CROBSPAR/OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP,
     *                 THETPR,PHIPR,

     *                 CORRXY,







     *                 NOBSLV
      DOUBLE PRECISION OBSLEV(20),THCKOB(20),XOFF(20),YOFF(20),
     *                 HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2)

     *                 ,CORRXY







      INTEGER          NOBSLV



# 4262 "corsika.h"



      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL





      DOUBLE PRECISION GAMMA,COSTHE,PHIX,PHIY,H,T,X,Y,CHI,BETA,GCM,ECM

     *                 ,WEIGHT


     *                 ,HAPP,COSTAP,COSTEA




      EQUIVALENCE      (CURPAR(1), GAMMA ), (CURPAR(2), COSTHE),
     *                 (CURPAR(3), PHIX  ), (CURPAR(4), PHIY  ),
     *                 (CURPAR(5), H     ), (CURPAR(6), T     ),
     *                 (CURPAR(7), X     ), (CURPAR(8), Y     ),
     *                 (CURPAR(9), CHI   ), (CURPAR(10),BETA  ),
     *                 (CURPAR(11),GCM   ), (CURPAR(12),ECM   )

     *                ,(CURPAR(13),WEIGHT)


     *                ,(CURPAR(14),HAPP  ), (CURPAR(15),COSTAP),
     *                 (CURPAR(16),COSTEA)















# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 34314 "corsika.F" 2

      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

      DOUBLE PRECISION RHOF
      EXTERNAL         RHOF

      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 ( 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




        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 = ( THICK(HLAY(IL)) - THCKHN ) / COSTHEOLD
ctp old formula ????
ctp          CHIMAX = ( THCKHN - AATM(IL) ) * SINI *
ctp     *                   ( 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=',F12.6,' 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 ( 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



C  CALCULATE THE REMAINING MATTER TO BE PENETRATED
      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
ctp      IF ( XNEW*PRMPAR(3) + YNEW*PRMPAR(4)
ctp     *     + (OBSLEV(1) - HNEW)*PRMPAR(2) .GT. 0.D0 ) THEN



      IF ( OBSLEV(1) - HNEW .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 .LT. 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


*-- 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







# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"



      COMMON /CRBUFFS/ RUNH,RUNE,EVTH,EVTE,DATAB,ARRAYLONG,LH

     *                 ,WRRUNH,WRRUNE,WREVTH,WREVTE

      INTEGER          MAXBUF,MAXLEN

      PARAMETER        (MAXBUF=39*8)
# 3681 "corsika.h"
      PARAMETER        (MAXLEN=16)
# 3693 "corsika.h"
      REAL             RUNH(MAXBUF),EVTH(MAXBUF),EVTE(MAXBUF),
     *                 RUNE(MAXBUF),DATAB(MAXBUF),ARRAYLONG(MAXBUF)
      INTEGER          LH

      LOGICAL          WRRUNH,WRRUNE,WREVTH,WREVTE

      CHARACTER*4      CRUNH,CRUNE,CEVTH,CEVTE,CLONG
      EQUIVALENCE      (RUNH(1),CRUNH), (RUNE(1),CRUNE)
      EQUIVALENCE      (EVTH(1),CEVTH), (EVTE(1),CEVTE)
      EQUIVALENCE      (ARRAYLONG(1),CLONG)



























































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"



      COMMON /CRRECORD/DRECOR
      DOUBLE PRECISION DRECOR



# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 34519 "corsika.F" 2




C  NSUBBL IS NUMBER OF SUBBLOCKS IN ONE OUTPUT RECORD
      INTEGER          NSUBBL
      PARAMETER        (NSUBBL=21)

C  (OUTPUT RECORD LENGTH = NSUBBL * 39 * 8 * 4 BYTES  <= 26208 )




C  OUTPUT BUFFER FOR PARTICLE OUTPUT
      REAL             OUTBUF(MAXBUF,NSUBBL)

     *                ,OUTVECT(MAXBUF*NSUBBL)

C  IBLK  IS  COUNTER FOR SUBBLOCKS
      INTEGER          I,K

     *                ,J


      INTEGER          IBLK
      DATA             IBLK / 0 /

      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

# 34587 "corsika.F"
C  COPY TO BUFFER
      IF ( IFL .LE. 1 ) THEN
        IBLK = IBLK + 1


        call wrida(a)





        DO  I = 1, MAXBUF
          OUTBUF(I,IBLK) = A(I)
        ENDDO

      ENDIF

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



          J = 0
          DO  K = 1, NSUBBL
            DO  I = 1, MAXBUF
              J = J + 1
              OUTVECT(J) = OUTBUF(I,K)
            ENDDO
          ENDDO



          CALL fwritempatap( MAXBUF, NSUBBL, OUTVECT )


        ENDIF
        DRECOR = DRECOR + DBLE(MAXBUF * NSUBBL)
        IBLK   = 0
        DO  K = 1, NSUBBL
          DO  I = 1, MAXBUF
            OUTBUF(I,K) = 0.0
          ENDDO
        ENDDO
      ENDIF



      RETURN
      END

# 34676 "corsika.F"

# 34858 "corsika.F"

*-- 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
# 34887 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"



      COMMON /CRBUFFS/ RUNH,RUNE,EVTH,EVTE,DATAB,ARRAYLONG,LH

     *                 ,WRRUNH,WRRUNE,WREVTH,WREVTE

      INTEGER          MAXBUF,MAXLEN

      PARAMETER        (MAXBUF=39*8)
# 3681 "corsika.h"
      PARAMETER        (MAXLEN=16)
# 3693 "corsika.h"
      REAL             RUNH(MAXBUF),EVTH(MAXBUF),EVTE(MAXBUF),
     *                 RUNE(MAXBUF),DATAB(MAXBUF),ARRAYLONG(MAXBUF)
      INTEGER          LH

      LOGICAL          WRRUNH,WRRUNE,WREVTH,WREVTE

      CHARACTER*4      CRUNH,CRUNE,CEVTH,CEVTE,CLONG
      EQUIVALENCE      (RUNH(1),CRUNH), (RUNE(1),CRUNE)
      EQUIVALENCE      (EVTH(1),CEVTH), (EVTE(1),CEVTE)
      EQUIVALENCE      (ARRAYLONG(1),CLONG)







































































      COMMON /CRELABCT/ELCUT
      DOUBLE PRECISION ELCUT(4)


















# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"
























      INTEGER          LNGMAX
      PARAMETER        (LNGMAX = 15000)
      INTEGER          TYPE1
      PARAMETER        (TYPE1 = 0)
      INTEGER          TYPE2
      PARAMETER        (TYPE2 = 1)
      INTEGER          TYPE3
      PARAMETER        (TYPE3 = 2)
      INTEGER          TYPE4
      PARAMETER        (TYPE4 = 3)
      COMMON /CRLONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP



     *                ,LLONGI,FLGFIT
# 3961 "corsika.h"
      DOUBLE PRECISION ADLONG(0:LNGMAX,19),AELONG(0:LNGMAX,10),
     *                 APLONG(0:LNGMAX,10),DLONG(0:LNGMAX,19),
     *                 ELONG(0:LNGMAX,10),
     *                 HLONG(0:LNGMAX),PLONG(0:LNGMAX,10),
     *                 SDLONG(0:LNGMAX,19),SELONG(0:LNGMAX,10),
     *                 SPLONG(0:LNGMAX,10),THSTEP,THSTPI




      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT

      COMMON /CRSLANT/ RLONG,THCKRL,CTH,STHCPH,STHSPH,RLOFF
      DOUBLE PRECISION RLONG(0:LNGMAX),THCKRL(0:LNGMAX),
     *                 CTH,STHCPH,STHSPH,RLOFF


















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"


















      COMMON /CRMUPART/AATOM,AMUPAR,BCUT,CMUON,CTAU,CONSTKINE,
     *                 EBYMU,EBYTAU,EE,SE,VFRAC,VMAX,VMIN,ZATOM,
     *                 MT,FMUBRM,FMUNUC,FMUORG






      DOUBLE PRECISION AMUPAR(0:18),BCUT,CMUON(11),CTAU(11),


     *                 AATOM,CONSTKINE,EBYMU,EBYTAU,EE,SE,
     *                 VFRAC,VMAX,VMIN,ZATOM
      INTEGER          MT
      LOGICAL          FMUBRM,FMUNUC,FMUORG



# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"








      COMMON /CRPAM/   PAMA,SIGNUM,RESTMS,DECTIM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000),
     *                 DECTIM(200)






      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL





      DOUBLE PRECISION GAMMA,COSTHE,PHIX,PHIY,H,T,X,Y,CHI,BETA,GCM,ECM

     *                 ,WEIGHT


     *                 ,HAPP,COSTAP,COSTEA




      EQUIVALENCE      (CURPAR(1), GAMMA ), (CURPAR(2), COSTHE),
     *                 (CURPAR(3), PHIX  ), (CURPAR(4), PHIY  ),
     *                 (CURPAR(5), H     ), (CURPAR(6), T     ),
     *                 (CURPAR(7), X     ), (CURPAR(8), Y     ),
     *                 (CURPAR(9), CHI   ), (CURPAR(10),BETA  ),
     *                 (CURPAR(11),GCM   ), (CURPAR(12),ECM   )

     *                ,(CURPAR(13),WEIGHT)


     *                ,(CURPAR(14),HAPP  ), (CURPAR(15),COSTAP),
     *                 (CURPAR(16),COSTEA)















# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"



      COMMON /CRTHNVAR/STACKINT,

     *                 EEPP,ELIM,


     *                 RMAX,RMAX2,
     *                 WMAX,WMAX0,WMAXE,WMAXE0,WMAXEM,

     *                 INT_ICOUNT,MODETHN,THINNING

     *                 ,RLIM,WLIM

      INTEGER          MAXICOUNT
      PARAMETER        (MAXICOUNT = 200000)
# 4883 "corsika.h"
      DOUBLE PRECISION STACKINT(0:16,MAXICOUNT)
# 4892 "corsika.h"
     *                 ,EEPP(MAXICOUNT),ELIM


     *                 ,RMAX,RMAX2
     *                 ,WMAX,WMAX0,WMAXE,WMAXE0,WMAXEM

      INTEGER          INT_ICOUNT,MODETHN
      LOGICAL          THINNING

      LOGICAL           RLIM,WLIM




















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 34887 "corsika.F" 2

      DOUBLE PRECISION FAC1,FAC2
      INTEGER          I,J
# 34898 "corsika.F"
      DOUBLE PRECISION EN,PZ,PX,PY,PTOT,CPHIV,SPHIV,COSTET
      INTEGER          NTYP

      SAVE
C-----------------------------------------------------------------------





      INT_ICOUNT = INT_ICOUNT + 1

      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)





      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 1
*       RETURN
      ENDIF


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







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

            DLONG(LHEIGH,5) = DLONG(LHEIGH,5)+SECPAR(1)*PAMA(5)*WEIGHT



          ENDIF
# 34997 "corsika.F"
          RETURN
# 35007 "corsika.F"
        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)

     *                        + (SECPAR(1)+1.D0)*PAMA(2)*WEIGHT
            ELSE
              DLONG(LHEIGH,3) = DLONG(LHEIGH,3)
     *                        + (SECPAR(1)-1.D0)*PAMA(2)*WEIGHT






            ENDIF
          ENDIF
# 35055 "corsika.F"
          RETURN
# 35065 "corsika.F"
        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

            DLONG(LHEIGH,1) = DLONG(LHEIGH,1) + SECPAR(1) * WEIGHT



          ENDIF
# 35102 "corsika.F"
          RETURN
# 35112 "corsika.F"
        ENDIF

# 35140 "corsika.F"

      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

            DLONG(LHEIGH,1) = DLONG(LHEIGH,1)+SECPAR(1)*PAMA(7)*WEIGHT



          ENDIF
# 35176 "corsika.F"
          RETURN
# 35186 "corsika.F"
        ENDIF


      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)

     *                  +  SECPAR(1) * PAMA(NINT(SECPAR(0))) * WEIGHT



          ENDIF
# 35227 "corsika.F"
          RETURN
        ENDIF



      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)))

     *                          - RESTMS(NINT(SECPAR(0))) )*WEIGHT



          ENDIF
# 35272 "corsika.F"
          RETURN
# 35283 "corsika.F"
        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)))

     *                                - RESTMS(NINT(SECPAR(0))) )*WEIGHT



          ENDIF
# 35326 "corsika.F"
          RETURN
# 35337 "corsika.F"
        ENDIF

# 35392 "corsika.F"

      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)))

     *                          - RESTMS(NINT(SECPAR(0))) )*WEIGHT*FAC1



C  ADD TO THE NEUTRINO DEPOSIT
            DLONG(LHEIGH,8) = DLONG(LHEIGH,8)
     *                  + ( SECPAR(1) * PAMA(NINT(SECPAR(0)))

     *                          - RESTMS(NINT(SECPAR(0))) )*WEIGHT*FAC2



          ENDIF
# 35457 "corsika.F"
          RETURN
# 35468 "corsika.F"
        ENDIF

      ENDIF
# 35488 "corsika.F"

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
# 35525 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"



      COMMON /CRBUFFS/ RUNH,RUNE,EVTH,EVTE,DATAB,ARRAYLONG,LH

     *                 ,WRRUNH,WRRUNE,WREVTH,WREVTE

      INTEGER          MAXBUF,MAXLEN

      PARAMETER        (MAXBUF=39*8)
# 3681 "corsika.h"
      PARAMETER        (MAXLEN=16)
# 3693 "corsika.h"
      REAL             RUNH(MAXBUF),EVTH(MAXBUF),EVTE(MAXBUF),
     *                 RUNE(MAXBUF),DATAB(MAXBUF),ARRAYLONG(MAXBUF)
      INTEGER          LH

      LOGICAL          WRRUNH,WRRUNE,WREVTH,WREVTE

      CHARACTER*4      CRUNH,CRUNE,CEVTH,CEVTE,CLONG
      EQUIVALENCE      (RUNH(1),CRUNH), (RUNE(1),CRUNE)
      EQUIVALENCE      (EVTH(1),CEVTH), (EVTE(1),CEVTE)
      EQUIVALENCE      (ARRAYLONG(1),CLONG)



























































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"


















      COMMON /CRMUPART/AATOM,AMUPAR,BCUT,CMUON,CTAU,CONSTKINE,
     *                 EBYMU,EBYTAU,EE,SE,VFRAC,VMAX,VMIN,ZATOM,
     *                 MT,FMUBRM,FMUNUC,FMUORG






      DOUBLE PRECISION AMUPAR(0:18),BCUT,CMUON(11),CTAU(11),


     *                 AATOM,CONSTKINE,EBYMU,EBYTAU,EE,SE,
     *                 VFRAC,VMAX,VMIN,ZATOM
      INTEGER          MT
      LOGICAL          FMUBRM,FMUNUC,FMUORG



# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"








      COMMON /CRPAM/   PAMA,SIGNUM,RESTMS,DECTIM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000),
     *                 DECTIM(200)






      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL





      DOUBLE PRECISION GAMMA,COSTHE,PHIX,PHIY,H,T,X,Y,CHI,BETA,GCM,ECM

     *                 ,WEIGHT


     *                 ,HAPP,COSTAP,COSTEA




      EQUIVALENCE      (CURPAR(1), GAMMA ), (CURPAR(2), COSTHE),
     *                 (CURPAR(3), PHIX  ), (CURPAR(4), PHIY  ),
     *                 (CURPAR(5), H     ), (CURPAR(6), T     ),
     *                 (CURPAR(7), X     ), (CURPAR(8), Y     ),
     *                 (CURPAR(9), CHI   ), (CURPAR(10),BETA  ),
     *                 (CURPAR(11),GCM   ), (CURPAR(12),ECM   )

     *                ,(CURPAR(13),WEIGHT)


     *                ,(CURPAR(14),HAPP  ), (CURPAR(15),COSTAP),
     *                 (CURPAR(16),COSTEA)















# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"

























      COMMON /CRRANDPA/RD,FAC,U1,U2,NSEQ,ISEED,KNOR
      DOUBLE PRECISION RD(3000),FAC,U1,U2



      INTEGER          ISEED(3,10),NSEQ

      LOGICAL          KNOR



# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"










      COMMON /CRREJECT/AVNREJ,ALTMIN,ANEXP,THICKA,THICKD,CUTLN,EONCUT,

     *                 EFRCTHN,ETHINN,ETHINNG,THINRAT,THINRATH,WEITRAT,
     *                 WEITRATH,EEFRTHN,

     *                 FNPRIM
      DOUBLE PRECISION AVNREJ(20),ALTMIN(20),ANEXP(20),THICKA(20),
     *                 THICKD(20),CUTLN,EONCUT

     *                 ,EFRCTHN,ETHINN,ETHINNG,THINRAT,THINRATH,WEITRAT,
     *                 WEITRATH,EEFRTHN

      LOGICAL          FNPRIM





















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"



      COMMON /CRSTACKF/STACKI,



     *                 MSTACKP,MEXST,NSHIFT,NOUREC,NOURECMAX,ICOUNT,
     *                 NTO,NFROM




      INTEGER          MAXSTK
# 4796 "corsika.h"
      PARAMETER        (MAXSTK = 17*256*2)
# 4809 "corsika.h"
      DOUBLE PRECISION STACKI(MAXSTK)



      INTEGER          MSTACKP,MEXST,NSHIFT,NOUREC,NOURECMAX,ICOUNT,
     *                 NTO,NFROM






















# 4853 "corsika.h"



      COMMON /CRTHNVAR/STACKINT,

     *                 EEPP,ELIM,


     *                 RMAX,RMAX2,
     *                 WMAX,WMAX0,WMAXE,WMAXE0,WMAXEM,

     *                 INT_ICOUNT,MODETHN,THINNING

     *                 ,RLIM,WLIM

      INTEGER          MAXICOUNT
      PARAMETER        (MAXICOUNT = 200000)
# 4883 "corsika.h"
      DOUBLE PRECISION STACKINT(0:16,MAXICOUNT)
# 4892 "corsika.h"
     *                 ,EEPP(MAXICOUNT),ELIM


     *                 ,RMAX,RMAX2
     *                 ,WMAX,WMAX0,WMAXE,WMAXE0,WMAXEM

      INTEGER          INT_ICOUNT,MODETHN
      LOGICAL          THINNING

      LOGICAL           RLIM,WLIM




















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 35525 "corsika.F" 2


      DOUBLE PRECISION ETOTAL,ETOTAL2,THNMRK,WT_OLD,ETOTALN
      LOGICAL          LABOVE

      INTEGER          I,K



      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


      ETOTAL  = 0.D0
      ETOTAL2 = 0.D0
      ETOTALN = 0.D0






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




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






        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
# 35684 "corsika.F"

# 35799 "corsika.F"

# 35813 "corsika.F"

# 35836 "corsika.F"

      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



C-----------------------------------------------------------------------

      IMPLICIT NONE
# 35868 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"



      COMMON /CRBUFFS/ RUNH,RUNE,EVTH,EVTE,DATAB,ARRAYLONG,LH

     *                 ,WRRUNH,WRRUNE,WREVTH,WREVTE

      INTEGER          MAXBUF,MAXLEN

      PARAMETER        (MAXBUF=39*8)
# 3681 "corsika.h"
      PARAMETER        (MAXLEN=16)
# 3693 "corsika.h"
      REAL             RUNH(MAXBUF),EVTH(MAXBUF),EVTE(MAXBUF),
     *                 RUNE(MAXBUF),DATAB(MAXBUF),ARRAYLONG(MAXBUF)
      INTEGER          LH

      LOGICAL          WRRUNH,WRRUNE,WREVTH,WREVTE

      CHARACTER*4      CRUNH,CRUNE,CEVTH,CEVTE,CLONG
      EQUIVALENCE      (RUNH(1),CRUNH), (RUNE(1),CRUNE)
      EQUIVALENCE      (EVTH(1),CEVTH), (EVTE(1),CEVTE)
      EQUIVALENCE      (ARRAYLONG(1),CLONG)



























































































# 3811 "corsika.h"

# 3824 "corsika.h"



      COMMON /CRETHMAP/ECTMAP,ELEFT,ELEFTJ
      DOUBLE PRECISION ECTMAP,ELEFT,ELEFTJ


















# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"








      COMMON /CRPAM/   PAMA,SIGNUM,RESTMS,DECTIM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000),
     *                 DECTIM(200)






      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL





      DOUBLE PRECISION GAMMA,COSTHE,PHIX,PHIY,H,T,X,Y,CHI,BETA,GCM,ECM

     *                 ,WEIGHT


     *                 ,HAPP,COSTAP,COSTEA




      EQUIVALENCE      (CURPAR(1), GAMMA ), (CURPAR(2), COSTHE),
     *                 (CURPAR(3), PHIX  ), (CURPAR(4), PHIY  ),
     *                 (CURPAR(5), H     ), (CURPAR(6), T     ),
     *                 (CURPAR(7), X     ), (CURPAR(8), Y     ),
     *                 (CURPAR(9), CHI   ), (CURPAR(10),BETA  ),
     *                 (CURPAR(11),GCM   ), (CURPAR(12),ECM   )

     *                ,(CURPAR(13),WEIGHT)


     *                ,(CURPAR(14),HAPP  ), (CURPAR(15),COSTAP),
     *                 (CURPAR(16),COSTEA)















# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"



      COMMON /CRSTACKF/STACKI,



     *                 MSTACKP,MEXST,NSHIFT,NOUREC,NOURECMAX,ICOUNT,
     *                 NTO,NFROM




      INTEGER          MAXSTK
# 4796 "corsika.h"
      PARAMETER        (MAXSTK = 17*256*2)
# 4809 "corsika.h"
      DOUBLE PRECISION STACKI(MAXSTK)



      INTEGER          MSTACKP,MEXST,NSHIFT,NOUREC,NOURECMAX,ICOUNT,
     *                 NTO,NFROM






















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 35868 "corsika.F" 2

      INTEGER          I,ISTK,J
      SAVE
      DATA             ISTK / MAXSTK /



C-----------------------------------------------------------------------





      IF ( DEBUG ) WRITE(MDEBUG,666) ICOUNT,(SECPAR(J),J=0,9),SECPAR(13)
# 35891 "corsika.F"
 666  FORMAT(' TSTOUT:',I7,1X,1P,9E11.3,0P,F10.0,1P,E10.3)
# 35915 "corsika.F"

# 35972 "corsika.F"


      IF ( MSTACKP .GE. ISTK ) THEN



        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


      NTO    = NTO + 1
      ICOUNT = ICOUNT + 1
# 36009 "corsika.F"
      DO  J = 0, MAXLEN
        STACKI(MSTACKP+J+1) = SECPAR(J)
      ENDDO
      MSTACKP = MSTACKP + MAXLEN + 1

      IF ( PAMA(NINT( SECPAR(0) )) .LE. 0.D0 ) THEN

        ELEFT  = ELEFT + SECPAR(1) * SECPAR(13)
      ELSE
        ELEFT  = ELEFT + SECPAR(1) * PAMA(NINT(SECPAR(0))) * SECPAR(13)





      ENDIF




      RETURN
      END


*-- 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
# 36081 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"










      COMMON /CRATMOS/ AATM,AATM0,BATM,BATM0,CATM,CATM0,DATM,MODATM
     *                ,MATMFI,LATMNEW
      DOUBLE PRECISION AATM(5),AATM0(5,0:42),BATM(5),BATM0(5,0:42),
     *                 CATM(5),CATM0(5,0:42),DATM(5)
      INTEGER          MODATM,MATMFI
      LOGICAL          LATMNEW





      COMMON /CRATMOS2/HLAY,HLAY0,THICKL,LAYNO,LAYNEW
      DOUBLE PRECISION HLAY(6),HLAY0(5,0:28),THICKL(5)
      INTEGER          LAYNO(0:41)
      LOGICAL          LAYNEW











# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"



      COMMON /CRBUFFS/ RUNH,RUNE,EVTH,EVTE,DATAB,ARRAYLONG,LH

     *                 ,WRRUNH,WRRUNE,WREVTH,WREVTE

      INTEGER          MAXBUF,MAXLEN

      PARAMETER        (MAXBUF=39*8)
# 3681 "corsika.h"
      PARAMETER        (MAXLEN=16)
# 3693 "corsika.h"
      REAL             RUNH(MAXBUF),EVTH(MAXBUF),EVTE(MAXBUF),
     *                 RUNE(MAXBUF),DATAB(MAXBUF),ARRAYLONG(MAXBUF)
      INTEGER          LH

      LOGICAL          WRRUNH,WRRUNE,WREVTH,WREVTE

      CHARACTER*4      CRUNH,CRUNE,CEVTH,CEVTE,CLONG
      EQUIVALENCE      (RUNH(1),CRUNH), (RUNE(1),CRUNE)
      EQUIVALENCE      (EVTH(1),CEVTH), (EVTE(1),CEVTE)
      EQUIVALENCE      (ARRAYLONG(1),CLONG)



























































































# 3811 "corsika.h"

# 3824 "corsika.h"










      COMMON /CRGENER/ GEN,ALEVEL
      DOUBLE PRECISION GEN,ALEVEL











# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"



      COMMON /CRIRET/  IRET1,IRET2,IRETE
      INTEGER          IRET1,IRET2
      LOGICAL          IRETE



# 3912 "corsika.h"
























      INTEGER          LNGMAX
      PARAMETER        (LNGMAX = 15000)
      INTEGER          TYPE1
      PARAMETER        (TYPE1 = 0)
      INTEGER          TYPE2
      PARAMETER        (TYPE2 = 1)
      INTEGER          TYPE3
      PARAMETER        (TYPE3 = 2)
      INTEGER          TYPE4
      PARAMETER        (TYPE4 = 3)
      COMMON /CRLONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP



     *                ,LLONGI,FLGFIT
# 3961 "corsika.h"
      DOUBLE PRECISION ADLONG(0:LNGMAX,19),AELONG(0:LNGMAX,10),
     *                 APLONG(0:LNGMAX,10),DLONG(0:LNGMAX,19),
     *                 ELONG(0:LNGMAX,10),
     *                 HLONG(0:LNGMAX),PLONG(0:LNGMAX,10),
     *                 SDLONG(0:LNGMAX,19),SELONG(0:LNGMAX,10),
     *                 SPLONG(0:LNGMAX,10),THSTEP,THSTPI




      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT

      COMMON /CRSLANT/ RLONG,THCKRL,CTH,STHCPH,STHSPH,RLOFF
      DOUBLE PRECISION RLONG(0:LNGMAX),THCKRL(0:LNGMAX),
     *                 CTH,STHCPH,STHSPH,RLOFF













      COMMON /CRMAGNET/BX,BZ,BVAL,BNORMC,BNORM,COSB,SINB,BLIMIT
      DOUBLE PRECISION BX,BZ,BVAL,BNORMC,BNORM,COSB,SINB,BLIMIT



# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"



      COMMON /CRMUMULT/CHC,OMC,PHISCT,STEPL,VSCAT,FMOLI
      DOUBLE PRECISION CHC,OMC,PHISCT,STEPL,VSCAT
      LOGICAL          FMOLI










# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"










      COMMON /CROBSPAR/OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP,
     *                 THETPR,PHIPR,

     *                 CORRXY,







     *                 NOBSLV
      DOUBLE PRECISION OBSLEV(20),THCKOB(20),XOFF(20),YOFF(20),
     *                 HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2)

     *                 ,CORRXY







      INTEGER          NOBSLV










      COMMON /CRPAM/   PAMA,SIGNUM,RESTMS,DECTIM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000),
     *                 DECTIM(200)






      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL





      DOUBLE PRECISION GAMMA,COSTHE,PHIX,PHIY,H,T,X,Y,CHI,BETA,GCM,ECM

     *                 ,WEIGHT


     *                 ,HAPP,COSTAP,COSTEA




      EQUIVALENCE      (CURPAR(1), GAMMA ), (CURPAR(2), COSTHE),
     *                 (CURPAR(3), PHIX  ), (CURPAR(4), PHIY  ),
     *                 (CURPAR(5), H     ), (CURPAR(6), T     ),
     *                 (CURPAR(7), X     ), (CURPAR(8), Y     ),
     *                 (CURPAR(9), CHI   ), (CURPAR(10),BETA  ),
     *                 (CURPAR(11),GCM   ), (CURPAR(12),ECM   )

     *                ,(CURPAR(13),WEIGHT)


     *                ,(CURPAR(14),HAPP  ), (CURPAR(15),COSTAP),
     *                 (CURPAR(16),COSTEA)















# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"











      COMMON /CRTIMLIM/DSTLIM,TIMLIM,LTMLMPR
      DOUBLE PRECISION DSTLIM,TIMLIM
      LOGICAL          LTMLMPR



# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 36081 "corsika.F" 2

      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




      DOUBLE PRECISION T1,T2,THCKSI
      INTEGER          LBIN
      LOGICAL          FLGLB
      EXTERNAL         LBIN,THCKSI


      DOUBLE PRECISION RHOF,PATH
      EXTERNAL         RHOF






      double precision T11

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


      LOGICAL          LPLOTCNT




      SAVE



      DATA NCOUNT / 0 /
C-----------------------------------------------------------------------


      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)






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

        FLGLB = .FALSE.
        T1    = THCKSI( XXX*STHCPH + YYY*STHSPH - HAPP*CTH + RLOFF )

        T11   = T1

        LPCT1 = INT( T1*THSTPI + 1.D0 )
        LPCT1 = MIN( LPCT1, NSTEP+1 )




      ENDIF


      LPLOTCNT = .FALSE.


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)


C  RECORD END OF INTERMEDIATE STEP (IF MORE THAN 1)
      IF ( LPLOTCNT ) THEN
# 36298 "corsika.F"
C  END OF TRACKING STEP
        pnt2id = ITYPE
        pnt2gen= GEN
        pnt2x  = XXX
        pnt2y  = YYY
        pnt2z  = HAPP

        pnt2d  = T11



        pnt2t  = T
        pnt2e  = PAMA(ITYPE)*GAMMA

        pnt2w  = WEIGHT






       if(WREVTH .AND. pnt1w.gt.0.d0.and.pnt2w.gt.0.d0)
     & call track(pnt1x, pnt2x)



C  END OF INTERMEDIATE STEP




      ELSE

        LPLOTCNT = .TRUE.
      ENDIF
# 36347 "corsika.F"
C  BEGINNING OF TRACKING STEP
      pnt1id = ITYPE
      pnt1gen= GEN
      pnt1x  = XXX
      pnt1y  = YYY
      pnt1z  = HAPP

      pnt1d  = T11



      pnt1t  = T
      pnt1e  = PAMA(ITYPE)*GAMMA

      pnt1w  = WEIGHT








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     ( 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)
# 36397 "corsika.F"
        WORK   = MIN( WORK, 1.D3 * BLIMIT * GAMMA * PAMA(ITYPE) )

        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



        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)
# 36425 "corsika.F"
        WORK   = MIN( WORK, 1.D3*BLIMIT * GAMMA * PAMA(ITYPE) * SINTHE )

*       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)
# 36454 "corsika.F"
        WORK   = 1.D3 * BLIMIT * GAMMA * PAMA(ITYPE)

        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     ( 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





      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



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 ( HNEW .LE. OBSLEV(1) ) THEN

        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)

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

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 )

          COSTHE = MAX( -1.D0, COSTHENEW )

C  KILL HORIZONTAL OR UPWARD GOING PARTICLES

          IF ( COSTHE .LT. 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 DETECTOR
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







        ELSE
C PROPAGATE PARTICLE UNTIL SPHERICAL GROUND SO X AND Y ARE NOT CORRECTED
        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







      ELSE
C  TRANSPORT ENDS AT RANGE OF PARTICLE
        IPASC  = 0
      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 ( FFLATOUT .AND. IPASC .NE. 0 ) COSTEA = 1.D0

          GOTO 150
        ELSE
C  PARTICLE SUFFERED FROM ANGULAR CUT
          GOTO 200
        ENDIF
      ENDIF

# 36644 "corsika.F"
C  FOR CHARGED PARTICLES COSINE OF ZENITH ANGLE IS CALCULATED IN UPDATE.
C  KILL HORIZONTAL OR UPWARD GOING PARTICLES

      IF ( OUTPAR(2) .LT. 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

          WRITE(MONIOU,571) (OUTPAR(I),I=0,8),WEIGHT
 571      FORMAT(' UPDATC: OUTPAR=',1P,10E11.3)




          WRITE(MONIOU,570)
 570      FORMAT(' UPDATC: PARTICLE ELIMINATED BECAUSE OF TIME LIMIT,',
     *           ' PLEASE READ THE USERS GUIDE, SEE KEYWORD: TIMLIM')
        ENDIF

        IF ( FFLATOUT .AND. IPASC .NE. 0 ) COSTEA = 1.D0

        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     ( 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




          IF ( DEBUG ) WRITE(MDEBUG,*) 'UPDATC: HNEW=',HNEW,' KILL'
          HNEW   = HLAY(6)
          THCKHN = 0.D0
          IRET2  = 1
          IRETC  = .FALSE.
          GOTO 150

        ELSEIF ( PRMPAR(15) .LT. 0.D0 .AND. HNEW .LE. HLAY(1)
     &                                .AND. COSTHE .GT. 0.D0 ) THEN
C  KILL PARTICLE WHICH REACH GROUND FOR UPWARD GOING SHOWERS
          IF ( DEBUG ) WRITE(MDEBUG,*) 'UPDATC: HNEW=',HNEW,' KILL'
          HNEW   = HLAY(1)
          THCKHN = THICKL(1)
          IRET2  = 1
          IRETC  = .FALSE.
          GOTO 150

        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 .LT. 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=',1P,3E17.9)
        T = TNEW


        T11   = THCKSI( XXX*STHCPH + YYY*STHSPH - HAPP*CTH + RLOFF )

        IF ( DEBUG ) WRITE(MDEBUG,562) COSTEA,HAPP
 562    FORMAT(' UPDATC: COSTEA,HAPP=',F18.15,1P,E17.9)

        IF ( DEBUG ) WRITE(MDEBUG,557) (CURPAR(I),I=0,9),WEIGHT
 557    FORMAT(' UPDATC: STPEND=',1P,11E11.3,0P)




        IF ( FFLATOUT ) THEN




        IF ( HAPP .LT. OBSLEV(1) ) THEN

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

C  COORDINATES NOW DEFINED IN UPDATE IN DETECTOR FRAME, NO NEED
C  FOR CORRECTION
          COSTEA    = 1.D0

         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)

C  COORDINATES DEFINED IN UPDATE IN DETECTOR FRAME, NO NEED
C  FOR CORRECTION
          COSTEA    = 1.D0

        ENDIF
      ENDIF

 150  CONTINUE








        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

      IF ( LLONGI ) THEN
C  THE PARTICLE IS TRACKED FROM SLANT THICKNES T1 TO T2

        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.






C  TOTAL PATH LENGTH IN UNITS OF LONGI BINS

        STEPT = (T2 - T1) * THSTPI



        IF ( SIGNUM(ITYPE) .NE. 0.D0 ) THEN
C  CHARGED PARTICLES
          GAMMAN = OUTPAR(1)



          IF     ( T2 .GT. T1 ) THEN
C  FORWARD MOVING PARTICLE





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

              EDEPB = PAMA(ITYPE) * (GAMMAOLD - GAMMAN) * WEIGHT / STEPT



            ELSE
              EDEPB = 0.D0
            ENDIF
C  ENERGY DEPOSIT IN FIRST BIN

            EDEP1 = EDEPB * (DBLE(LPCT1) - T1*THSTPI)




C  ENERGY AT FIRST BIN BOUNDARY

            EFRST = PAMA(ITYPE) * GAMMAOLD * WEIGHT - EDEP1



            IF ( LPCT2 .LT. LPCT1 ) THEN
C  SMALL STEP

              EDEPN = EDEPB * (T2*THSTPI - DBLE(LPCT1))



              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

                EDEPN = MAX( 0.D0, EDEPB * (T2*THSTPI - DBLE(LPCT2)) )
              ELSE
C  PARTICLE ARRIVES AT DETECTOR
                LPCT2 = MIN( LPCT2, NSTEP+1 )






                EDEPN = 0.D0
              ENDIF
            ENDIF

            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


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 )

                PLONG(LPCT2,4) = PLONG(LPCT2,4) + WEIGHT



              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 )

                PLONG(LPCT2,5) = PLONG(LPCT2,5) + WEIGHT



              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 )
# 37132 "corsika.F"
                PLONG(LPCT2,6) = PLONG(LPCT2,6) + WEIGHT
                PLONG(LPCT2,7) = PLONG(LPCT2,7) + WEIGHT




              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 )

                PLONG(LPCT2,8) = PLONG(LPCT2,8) + WEIGHT



              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 )

                  PLONG(IL,4) = PLONG(IL,4) + WEIGHT



                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 )

                  PLONG(IL,5) = PLONG(IL,5) + WEIGHT



                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 )
# 37214 "corsika.F"
                  PLONG(IL,6) = PLONG(IL,6) + WEIGHT
                  PLONG(IL,7) = PLONG(IL,7) + WEIGHT




                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 )

                  PLONG(IL,8) = PLONG(IL,8) + WEIGHT



                ENDIF
              ENDDO
            ENDIF


          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




            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

              EDEPB = PAMA(ITYPE) * (GAMMAOLD - GAMMAN) * WEIGHT / STEPT



            ELSE
              EDEPB = 0.D0
            ENDIF
C  ENERGY DEPOSIT IN FIRST BIN

            LPCT2 = MIN( LPCT2, NSTEP+1 )
            EDEP1 = EDEPB * (T1*THSTPI - DBLE(LPCT1))




C  ENERGY AT FIRST BIN BOUNDARY

            EFRST = PAMA(ITYPE) * GAMMAOLD * WEIGHT - EDEP1



            IF ( LPCT2. GT. LPCT1 ) THEN
C  SMALL STEP

              EDEPN = EDEPB * (DBLE(LPCT1) - T2*THSTPI)



            ELSE
C  STEP LONGER THAN ONE LONGITUDINAL BIN GIVES LPCT2 <= LPCT1
              IF ( IPASC .EQ. 0 ) THEN

                EDEPN = MAX( 0.D0, EDEPB * (DBLE(LPCT2) - T2*THSTPI) )



              ELSE
C  PARTICLE ARRIVES AT DETECTOR
                LPCT2 = MAX( 0, LPCT2 )
                EDEPN = 0.D0
              ENDIF
            ENDIF

            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


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 )

                PLONG(LPCT2,4) = PLONG(LPCT2,4) + WEIGHT



              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 )

                PLONG(LPCT2,5) = PLONG(LPCT2,5) + WEIGHT



              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 )
# 37374 "corsika.F"
                PLONG(LPCT2,6) = PLONG(LPCT2,6) + WEIGHT
                PLONG(LPCT2,7) = PLONG(LPCT2,7) + WEIGHT




              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 )

                PLONG(LPCT2,8) = PLONG(LPCT2,8) + WEIGHT



              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 )

                  PLONG(IL,4) = PLONG(IL,4) + WEIGHT



                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 )

                  PLONG(IL,5) = PLONG(IL,5) + WEIGHT



                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 )
# 37456 "corsika.F"
                  PLONG(IL,6) = PLONG(IL,6) + WEIGHT
                  PLONG(IL,7) = PLONG(IL,7) + WEIGHT




                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 )

                  PLONG(IL,8) = PLONG(IL,8) + WEIGHT



                ENDIF
              ENDDO
            ENDIF


          ELSE
C  ENERGY DEPOSIT FOR HORIZONTALLY MOVING PARTICLES IN FIRST BIN

            EDEP1 = PAMA(ITYPE) * (GAMMAOLD - GAMMAN) * WEIGHT



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


        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

              ELONG(IL,6) = ELONG(IL,6) + GAMMA * PAMA(ITYPE) * WEIGHT
              PLONG(IL,6) = PLONG(IL,6) + WEIGHT
# 37555 "corsika.F"
            ENDDO
          ENDIF
# 37581 "corsika.F"
        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

            DLONG(LHEIGH,5) = DLONG(LHEIGH,5) + GAMMAN*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) + ( 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
# 37618 "corsika.F"
          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- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -


C  END OF TRACKING STEP
      pnt2id = OUTPAR(0)
      pnt2gen= OUTPAR(9)
      pnt2x  = XXX
      pnt2y  = YYY
      pnt2z  = HAPP

      pnt2d  = T2



      pnt2t  = OUTPAR(6)
      pnt2e  = PAMA(pnt2id)*OUTPAR(1)

      pnt2w  = OUTPAR(13.)






      if(WREVTH .AND. pnt1w.gt.0.d0.and.pnt2w.gt.0.d0)
     &call track(pnt1x, pnt2x)



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

# 37741 "corsika.F"

      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


          DLONG(LPCT1+1,15) = DLONG(LPCT1+1,15)
     *                            +GAMMAOLD*PAMA(5)*WEIGHT
# 37762 "corsika.F"
        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
# 37809 "corsika.F"

# 37871 "corsika.F"
        ENDIF
      ENDIF
      IRET2 = 1

      RETURN
      END


*-- 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.



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
# 37939 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"



      COMMON /CRATMOS2/HLAY,HLAY0,THICKL,LAYNO,LAYNEW
      DOUBLE PRECISION HLAY(6),HLAY0(5,0:28),THICKL(5)
      INTEGER          LAYNO(0:41)
      LOGICAL          LAYNEW











# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"











      COMMON /CRCONSTA/PI,PI2,OB3,TB3,ENEPER,SQRT3
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER,SQRT3
























































      COMMON /CRELABCT/ELCUT
      DOUBLE PRECISION ELCUT(4)


















# 3811 "corsika.h"

# 3824 "corsika.h"










      COMMON /CRGENER/ GEN,ALEVEL
      DOUBLE PRECISION GEN,ALEVEL











# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"



      COMMON /CRIRET/  IRET1,IRET2,IRETE
      INTEGER          IRET1,IRET2
      LOGICAL          IRETE



# 3912 "corsika.h"
























      INTEGER          LNGMAX
      PARAMETER        (LNGMAX = 15000)
      INTEGER          TYPE1
      PARAMETER        (TYPE1 = 0)
      INTEGER          TYPE2
      PARAMETER        (TYPE2 = 1)
      INTEGER          TYPE3
      PARAMETER        (TYPE3 = 2)
      INTEGER          TYPE4
      PARAMETER        (TYPE4 = 3)
      COMMON /CRLONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP



     *                ,LLONGI,FLGFIT
# 3961 "corsika.h"
      DOUBLE PRECISION ADLONG(0:LNGMAX,19),AELONG(0:LNGMAX,10),
     *                 APLONG(0:LNGMAX,10),DLONG(0:LNGMAX,19),
     *                 ELONG(0:LNGMAX,10),
     *                 HLONG(0:LNGMAX),PLONG(0:LNGMAX,10),
     *                 SDLONG(0:LNGMAX,19),SELONG(0:LNGMAX,10),
     *                 SPLONG(0:LNGMAX,10),THSTEP,THSTPI




      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT

      COMMON /CRSLANT/ RLONG,THCKRL,CTH,STHCPH,STHSPH,RLOFF
      DOUBLE PRECISION RLONG(0:LNGMAX),THCKRL(0:LNGMAX),
     *                 CTH,STHCPH,STHSPH,RLOFF













      COMMON /CRMAGNET/BX,BZ,BVAL,BNORMC,BNORM,COSB,SINB,BLIMIT
      DOUBLE PRECISION BX,BZ,BVAL,BNORMC,BNORM,COSB,SINB,BLIMIT



# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"



      COMMON /CRMUMULT/CHC,OMC,PHISCT,STEPL,VSCAT,FMOLI
      DOUBLE PRECISION CHC,OMC,PHISCT,STEPL,VSCAT
      LOGICAL          FMOLI












      COMMON /CRMUPART/AATOM,AMUPAR,BCUT,CMUON,CTAU,CONSTKINE,
     *                 EBYMU,EBYTAU,EE,SE,VFRAC,VMAX,VMIN,ZATOM,
     *                 MT,FMUBRM,FMUNUC,FMUORG






      DOUBLE PRECISION AMUPAR(0:18),BCUT,CMUON(11),CTAU(11),


     *                 AATOM,CONSTKINE,EBYMU,EBYTAU,EE,SE,
     *                 VFRAC,VMAX,VMIN,ZATOM
      INTEGER          MT
      LOGICAL          FMUBRM,FMUNUC,FMUORG



# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"










      COMMON /CROBSPAR/OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP,
     *                 THETPR,PHIPR,

     *                 CORRXY,







     *                 NOBSLV
      DOUBLE PRECISION OBSLEV(20),THCKOB(20),XOFF(20),YOFF(20),
     *                 HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2)

     *                 ,CORRXY







      INTEGER          NOBSLV










      COMMON /CRPAM/   PAMA,SIGNUM,RESTMS,DECTIM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000),
     *                 DECTIM(200)






      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL





      DOUBLE PRECISION GAMMA,COSTHE,PHIX,PHIY,H,T,X,Y,CHI,BETA,GCM,ECM

     *                 ,WEIGHT


     *                 ,HAPP,COSTAP,COSTEA




      EQUIVALENCE      (CURPAR(1), GAMMA ), (CURPAR(2), COSTHE),
     *                 (CURPAR(3), PHIX  ), (CURPAR(4), PHIY  ),
     *                 (CURPAR(5), H     ), (CURPAR(6), T     ),
     *                 (CURPAR(7), X     ), (CURPAR(8), Y     ),
     *                 (CURPAR(9), CHI   ), (CURPAR(10),BETA  ),
     *                 (CURPAR(11),GCM   ), (CURPAR(12),ECM   )

     *                ,(CURPAR(13),WEIGHT)


     *                ,(CURPAR(14),HAPP  ), (CURPAR(15),COSTAP),
     *                 (CURPAR(16),COSTEA)















# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"

























      COMMON /CRRANDPA/RD,FAC,U1,U2,NSEQ,ISEED,KNOR
      DOUBLE PRECISION RD(3000),FAC,U1,U2



      INTEGER          ISEED(3,10),NSEQ

      LOGICAL          KNOR



# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 37939 "corsika.F" 2

      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



      LOGICAL          CFLAG,MUS,TCRNKV,TFLAG
      DOUBLE PRECISION CDEDXM,HEIGH,RANNOR,RHOF,THICK
# 37972 "corsika.F"
      DOUBLE PRECISION CHIT2,STEPNW
# 37997 "corsika.F"
      SAVE
      EXTERNAL         CDEDXM,HEIGH,RANNOR,RHOF,THICK
# 38011 "corsika.F"
      DATA             CFLAG / .FALSE. /

C  CONSTANT IN DENSITY EFFECT FOR IONIZATION LOSS IN AIR
      DATA             CDNS1 / 0.020762D0 /



C-----------------------------------------------------------------------


      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)








      IRET2  = 1
      IRETE  = .FALSE.
C  TOTAL HEIGHT DIFFERENCE

      DH     = H - HNEW



      ACOSTH = ABS( COSTHE )
C  ATMOSPHERE THICKNESS TRAVERSED

      IF ( ACOSTH .GT. 0.003D0 .AND. ABS(DH) .GT. 1.D-10 ) THEN
C  NORMAL TREATMENT FOR NON-HORIZONTAL PARTICLE (INCLINATION > 0.2 DEG)

       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

      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

      SNMIDDL2 = SN - SNMIDDL1
      SN1      = 0.5D0 * SNMIDDL1
      HNEWC    = HNEW

# 38112 "corsika.F"

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.
# 38133 "corsika.F"
        GLCUT = ELCUT(1) / PAMA(ITYPE) + 1.D0

      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 ( COSTHE .LT. 0.D0 ) ILAY = ILAY + 1

        IF ( ACOSTH .GT. 0.003D0 ) THEN
C  NORMAL TREATMENT FOR NON-HORIZONTAL PARTICLE (INCLINATION > 0.2 DEG)


         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     ( 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

          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)





         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)

        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

      ELSE
C  NO LOSS FOR NEUTRAL PARTICLES
        GAMMAN = GAMMA
      ENDIF
# 38307 "corsika.F"
      IF ( LLONGI  .OR.  CFLAG ) THEN

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 ( ACOSTH .GT. 0.003D0 .AND. ABS(DH) .GT. 1.D-10 ) THEN
C  NORMAL TREATMENT FOR NON-HORIZONTAL PARTICLE (INCLINATION > 0.2 DEG)

           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     ( 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



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 ( COSTHE .LT. 0.D0 ) THEN
             THCKHC = MAX( THCKHC, THCKHN )
# 38404 "corsika.F"
           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



           CHI    = (THCKHC - THICKH) / COSTHE
           HNEWC  = HEIGH( THCKHC )
           DT     = SN / (C(25) * BETA * GAMMA)
           RATIO  = 0.5D0 * (H-HNEWC) / DH

           DH     = H - HNEWC



           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)

          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

          SNMIDDL2 = SN - SNMIDDL1
          SN1      = 0.5D0 * SNMIDDL1
          TFLAG    = .TRUE.
        ELSE
          TFLAG    = .FALSE.
        ENDIF

      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


C-----------------------------------------------------------------------



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 ( 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







            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 ( LLONGI  .OR.  CFLAG ) THEN

          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
# 38585 "corsika.F"
          IF ( HNEW .GT. OBSLEV(NOBSLV) ) THEN

            TCRNKV = .TRUE.
          ELSE
            TCRNKV = .FALSE.
          ENDIF


        ENDIF


# 38618 "corsika.F"

C  REJECT ALL PARTICLES IF BELOW KINETIC ENERGY CUT

      IF ( LLONGI  .OR.  CFLAG ) THEN






        IF ( GAMMAN .LT. GLCUT  .AND.  .NOT.TCRNKV ) THEN
          IF ( DEBUG ) WRITE(MDEBUG,*) 'UPDATE: PARTICLE ',ITYPE,
     *      ' BELOW ENERGY CUT'


          OUTPAR(1) = GAMMAN

          IRETE = .TRUE.
          GOTO 1111
        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 .LT. C(29) ) THEN



          IF ( DEBUG ) WRITE(MDEBUG,*)
     *                'UPDATE: PARTICLE',ITYPE,' BELOW ANGLE CUT 1'
          IRETE  = .FALSE.
          GOTO 1111
        ENDIF

        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



        U12 = RADINV * U12
        V12 = RADINV * V12
# 38756 "corsika.F"

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 .LT. 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 ( HNEW .GT. OBSLEV(1) ) THEN




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

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 ( 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







              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

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 ( 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







              IF ( DEBUG ) WRITE(MDEBUG,*) 'UPDATE: INTAC HNEW=',
     *                        SNGL(HNEW),' SNMIDDL2=',SNGL(SNMIDDL2)
            ENDIF

C CHECK HNEW COMPARED TO OBSERVATION LEVEL




            IF ( HNEW .LE. 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

            STEPL = SNMIDDL1 + SNMIDDL2
            SN3   = 0.5D0 * SNMIDDL2
          ELSE
C  KEEP ARRIVAL HEIGHT AND SNMIDDL2, PARTICLE ARRIVES AT OBSERV. LEVEL

            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



          ENDIF
        ELSE                                 ! NON-MUON  CASE
          U20 = U12
          V20 = V12
          W20 = W12

          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



        ENDIF
# 38931 "corsika.F"
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 .LT. C(29) ) THEN



          IF ( DEBUG ) WRITE(MDEBUG,*)
     *                    'UPDATE: PARTICLE',ITYPE,' BELOW ANGLE CUT 2'
          IRETE = .FALSE.
          GOTO 1111
        ENDIF

        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



        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

# 39055 "corsika.F"
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# 39568 "corsika.F"

C  REJECT PARTICLES AFTER PRODUCTION OF CHERENKOV LIGHT
C  AND LONGITUDINAL DEVELOPMENT



        IF ( (LLONGI  .OR.  CFLAG)  .AND.  TCRNKV




     *                                            ) THEN
          IF ( GAMMAN .LT. GLCUT ) THEN




            IF ( DEBUG ) WRITE(MDEBUG,*) 'UPDATE: PARTICLE',ITYPE,
     *           ' BELOW ENERGY CUT'


            OUTPAR(1) = GAMMAN
# 39647 "corsika.F"
            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

# 39991 "corsika.F"
      ENDIF

C-----------------------------------------------------------------------

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

      OUTPAR( 0) = CURPAR(0)
      OUTPAR( 1) = GAMMAN
      OUTPAR( 5) = HNEW
      OUTPAR( 9) = GEN
      OUTPAR(10) = ALEVEL





      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)
# 40029 "corsika.F"

# 40154 "corsika.F"

c     if (debug) debug = .false.
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 
# 40190 "corsika.F"

      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





# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"











      COMMON /CRCONSTA/PI,PI2,OB3,TB3,ENEPER,SQRT3
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER,SQRT3


































      COMMON /CRDPMFLG/NFLAIN,NFLDIF,NFLPI0,NFLCHE,NFLPIF,NFRAGM
      INTEGER          NFLAIN,NFLDIF,NFLPI0,NFLCHE,NFLPIF,NFRAGM








































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"

























      COMMON /CRRANDPA/RD,FAC,U1,U2,NSEQ,ISEED,KNOR
      DOUBLE PRECISION RD(3000),FAC,U1,U2



      INTEGER          ISEED(3,10),NSEQ

      LOGICAL          KNOR



# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 40223 "corsika.F" 2

      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




# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"











      COMMON /CRCONSTA/PI,PI2,OB3,TB3,ENEPER,SQRT3
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER,SQRT3












































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"


















      COMMON /CRMUPART/AATOM,AMUPAR,BCUT,CMUON,CTAU,CONSTKINE,
     *                 EBYMU,EBYTAU,EE,SE,VFRAC,VMAX,VMIN,ZATOM,
     *                 MT,FMUBRM,FMUNUC,FMUORG






      DOUBLE PRECISION AMUPAR(0:18),BCUT,CMUON(11),CTAU(11),


     *                 AATOM,CONSTKINE,EBYMU,EBYTAU,EE,SE,
     *                 VFRAC,VMAX,VMIN,ZATOM
      INTEGER          MT
      LOGICAL          FMUBRM,FMUNUC,FMUORG



# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"








      COMMON /CRPAM/   PAMA,SIGNUM,RESTMS,DECTIM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000),
     *                 DECTIM(200)




# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"

















# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 40425 "corsika.F" 2

      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




# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"











      COMMON /CRCONSTA/PI,PI2,OB3,TB3,ENEPER,SQRT3
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER,SQRT3












































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"


















      COMMON /CRMUPART/AATOM,AMUPAR,BCUT,CMUON,CTAU,CONSTKINE,
     *                 EBYMU,EBYTAU,EE,SE,VFRAC,VMAX,VMIN,ZATOM,
     *                 MT,FMUBRM,FMUNUC,FMUORG






      DOUBLE PRECISION AMUPAR(0:18),BCUT,CMUON(11),CTAU(11),


     *                 AATOM,CONSTKINE,EBYMU,EBYTAU,EE,SE,
     *                 VFRAC,VMAX,VMIN,ZATOM
      INTEGER          MT
      LOGICAL          FMUBRM,FMUNUC,FMUORG



# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"








      COMMON /CRPAM/   PAMA,SIGNUM,RESTMS,DECTIM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000),
     *                 DECTIM(200)




# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"

















# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 40518 "corsika.F" 2

      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




# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"











      COMMON /CRCONSTA/PI,PI2,OB3,TB3,ENEPER,SQRT3
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER,SQRT3












































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"


















      COMMON /CRMUPART/AATOM,AMUPAR,BCUT,CMUON,CTAU,CONSTKINE,
     *                 EBYMU,EBYTAU,EE,SE,VFRAC,VMAX,VMIN,ZATOM,
     *                 MT,FMUBRM,FMUNUC,FMUORG






      DOUBLE PRECISION AMUPAR(0:18),BCUT,CMUON(11),CTAU(11),


     *                 AATOM,CONSTKINE,EBYMU,EBYTAU,EE,SE,
     *                 VFRAC,VMAX,VMIN,ZATOM
      INTEGER          MT
      LOGICAL          FMUBRM,FMUNUC,FMUORG



# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"








      COMMON /CRPAM/   PAMA,SIGNUM,RESTMS,DECTIM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000),
     *                 DECTIM(200)




# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"

















# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 40613 "corsika.F" 2

      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




# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"











      COMMON /CRCONSTA/PI,PI2,OB3,TB3,ENEPER,SQRT3
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER,SQRT3












































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"


















      COMMON /CRMUPART/AATOM,AMUPAR,BCUT,CMUON,CTAU,CONSTKINE,
     *                 EBYMU,EBYTAU,EE,SE,VFRAC,VMAX,VMIN,ZATOM,
     *                 MT,FMUBRM,FMUNUC,FMUORG






      DOUBLE PRECISION AMUPAR(0:18),BCUT,CMUON(11),CTAU(11),


     *                 AATOM,CONSTKINE,EBYMU,EBYTAU,EE,SE,
     *                 VFRAC,VMAX,VMIN,ZATOM
      INTEGER          MT
      LOGICAL          FMUBRM,FMUNUC,FMUORG



# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"








      COMMON /CRPAM/   PAMA,SIGNUM,RESTMS,DECTIM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000),
     *                 DECTIM(200)




# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"

















# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 40705 "corsika.F" 2

      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







# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"





























































      COMMON /CREGSDEB/JCLOCK,NCLOCK,FEGSDB
      INTEGER          JCLOCK,NCLOCK
      LOGICAL          FEGSDB

























# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"

























      COMMON /CRRANDPA/RD,FAC,U1,U2,NSEQ,ISEED,KNOR
      DOUBLE PRECISION RD(3000),FAC,U1,U2



      INTEGER          ISEED(3,10),NSEQ

      LOGICAL          KNOR



# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"



      COMMON /CRSTACKE/E,TIM,U,V,W,X,Y,Z,DNEAR,

     *                 WT,


     *                 ZAP,WAP,WA,XXXX,YYYY,


     *                 TSLAN,




     *                 IQ,IGEN,IR,IOBS,LPCTE,NP
      DOUBLE PRECISION E(60),TIM(60),U(60),V(60),W(60),
     *                 X(60),Y(60),Z(60),DNEAR(60)

     *                 ,WT(60)


     *                 ,ZAP(60),WAP(60),WA(60),XXXX(60),YYYY(60)


     *                 ,TSLAN(60)




      INTEGER          IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP



# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"



      COMMON /CRUPHIOT/THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI
      DOUBLE PRECISION THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI





      COMMON /CRUSEFUL/PRM,PRMT2,RMI,VCI,MEDIUM,MEDOLD,IBLOBE
      DOUBLE PRECISION PRM,PRMT2,RMI,VCI
      INTEGER          MEDIUM,MEDOLD,IBLOBE



# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 40876 "corsika.F" 2

      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
# 40947 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"





























































      COMMON /CREGSDEB/JCLOCK,NCLOCK,FEGSDB
      INTEGER          JCLOCK,NCLOCK
      LOGICAL          FEGSDB

























# 3811 "corsika.h"

# 3824 "corsika.h"










      COMMON /CRGENER/ GEN,ALEVEL
      DOUBLE PRECISION GEN,ALEVEL











# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"










      COMMON /CRMISC/  DUNIT,RHOR,KMPI,KMPO,NOSCAT,MED,IRAYLR
      DOUBLE PRECISION DUNIT,RHOR(6)
      INTEGER          KMPI,KMPO,NOSCAT,MED(6),IRAYLR(6)



# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"



      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL



# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"



      COMMON /CRSTACKE/E,TIM,U,V,W,X,Y,Z,DNEAR,

     *                 WT,


     *                 ZAP,WAP,WA,XXXX,YYYY,


     *                 TSLAN,




     *                 IQ,IGEN,IR,IOBS,LPCTE,NP
      DOUBLE PRECISION E(60),TIM(60),U(60),V(60),W(60),
     *                 X(60),Y(60),Z(60),DNEAR(60)

     *                 ,WT(60)


     *                 ,ZAP(60),WAP(60),WA(60),XXXX(60),YYYY(60)


     *                 ,TSLAN(60)




      INTEGER          IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP



# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"



      COMMON /CRUPHIOT/THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI
      DOUBLE PRECISION THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI





      COMMON /CRUSEFUL/PRM,PRMT2,RMI,VCI,MEDIUM,MEDOLD,IBLOBE
      DOUBLE PRECISION PRM,PRMT2,RMI,VCI
      INTEGER          MEDIUM,MEDOLD,IBLOBE



# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 40947 "corsika.F" 2

      DOUBLE PRECISION ANGLEX,ANGLEY,ANGLEZ,XX,YY,ZZ



      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

      OUTPAR(13) = WT(NP)
# 40992 "corsika.F"
      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)

     *      ,WT(NP)




 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

     *         ,1X,F10.2




     *          )
      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
# 41045 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"





























































      COMMON /CREGSDEB/JCLOCK,NCLOCK,FEGSDB
      INTEGER          JCLOCK,NCLOCK
      LOGICAL          FEGSDB

























# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"










      COMMON /CRMISC/  DUNIT,RHOR,KMPI,KMPO,NOSCAT,MED,IRAYLR
      DOUBLE PRECISION DUNIT,RHOR(6)
      INTEGER          KMPI,KMPO,NOSCAT,MED(6),IRAYLR(6)



# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"



      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL



# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"



      COMMON /CRSTACKE/E,TIM,U,V,W,X,Y,Z,DNEAR,

     *                 WT,


     *                 ZAP,WAP,WA,XXXX,YYYY,


     *                 TSLAN,




     *                 IQ,IGEN,IR,IOBS,LPCTE,NP
      DOUBLE PRECISION E(60),TIM(60),U(60),V(60),W(60),
     *                 X(60),Y(60),Z(60),DNEAR(60)

     *                 ,WT(60)


     *                 ,ZAP(60),WAP(60),WA(60),XXXX(60),YYYY(60)


     *                 ,TSLAN(60)




      INTEGER          IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP



# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"



      COMMON /CRUPHIOT/THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI
      DOUBLE PRECISION THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI





      COMMON /CRUSEFUL/PRM,PRMT2,RMI,VCI,MEDIUM,MEDOLD,IBLOBE
      DOUBLE PRECISION PRM,PRMT2,RMI,VCI
      INTEGER          MEDIUM,MEDOLD,IBLOBE



# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 41045 "corsika.F" 2

      DOUBLE PRECISION ANGLEX,ANGLEY,ANGLEZ,XX,YY,ZZ



      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)

     *  ,WT(NP)




 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

     *  ,1X,1P,E10.3,0P




     *  )

      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
# 41107 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"





























































      COMMON /CREGSDEB/JCLOCK,NCLOCK,FEGSDB
      INTEGER          JCLOCK,NCLOCK
      LOGICAL          FEGSDB

























# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"

























      COMMON /CRRANDPA/RD,FAC,U1,U2,NSEQ,ISEED,KNOR
      DOUBLE PRECISION RD(3000),FAC,U1,U2



      INTEGER          ISEED(3,10),NSEQ

      LOGICAL          KNOR



# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"



      COMMON /CRSTACKE/E,TIM,U,V,W,X,Y,Z,DNEAR,

     *                 WT,


     *                 ZAP,WAP,WA,XXXX,YYYY,


     *                 TSLAN,




     *                 IQ,IGEN,IR,IOBS,LPCTE,NP
      DOUBLE PRECISION E(60),TIM(60),U(60),V(60),W(60),
     *                 X(60),Y(60),Z(60),DNEAR(60)

     *                 ,WT(60)


     *                 ,ZAP(60),WAP(60),WA(60),XXXX(60),YYYY(60)


     *                 ,TSLAN(60)




      INTEGER          IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP



# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"



      COMMON /CRTHRESH/RMSQ,API,TE,THMOLL,AP,AE,UP,UE
      DOUBLE PRECISION RMSQ,API,TE,THMOLL
      REAL             AP,AE,UP,UE











# 4935 "corsika.h"



      COMMON /CRUPHIOT/THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI
      DOUBLE PRECISION THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI





      COMMON /CRUSEFUL/PRM,PRMT2,RMI,VCI,MEDIUM,MEDOLD,IBLOBE
      DOUBLE PRECISION PRM,PRMT2,RMI,VCI
      INTEGER          MEDIUM,MEDOLD,IBLOBE



# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 41107 "corsika.F" 2

      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

      SUBROUTINE BREMSLPM( FPASS )



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.

C  ARGUMENT:
C   FPASS  = (LOGICAL) FLAG INDICATING THAT INTERRACTION IS SUPPRESSED

C-----------------------------------------------------------------------

      IMPLICIT NONE
# 41208 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"

















      COMMON /CRBREMPR/PWR2I,DL1,DL2,DL3,DL4,DL5,DL6,DELCM,ALPHI,BPAR,
     *                 DELPOS
      DOUBLE PRECISION PWR2I(60)
      REAL             DL1(6),DL2(6),DL3(6),DL4(6),DL5(6),DL6(6),
     *                 DELCM,ALPHI(2),BPAR(2),DELPOS(2)



# 3705 "corsika.h"





























































      COMMON /CREGSDEB/JCLOCK,NCLOCK,FEGSDB
      INTEGER          JCLOCK,NCLOCK
      LOGICAL          FEGSDB

























# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"

























      COMMON /CRRANDPA/RD,FAC,U1,U2,NSEQ,ISEED,KNOR
      DOUBLE PRECISION RD(3000),FAC,U1,U2



      INTEGER          ISEED(3,10),NSEQ

      LOGICAL          KNOR



# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"



      COMMON /CRSTACKE/E,TIM,U,V,W,X,Y,Z,DNEAR,

     *                 WT,


     *                 ZAP,WAP,WA,XXXX,YYYY,


     *                 TSLAN,




     *                 IQ,IGEN,IR,IOBS,LPCTE,NP
      DOUBLE PRECISION E(60),TIM(60),U(60),V(60),W(60),
     *                 X(60),Y(60),Z(60),DNEAR(60)

     *                 ,WT(60)


     *                 ,ZAP(60),WAP(60),WA(60),XXXX(60),YYYY(60)


     *                 ,TSLAN(60)




      INTEGER          IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP



# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"



      COMMON /CRTHRESH/RMSQ,API,TE,THMOLL,AP,AE,UP,UE
      DOUBLE PRECISION RMSQ,API,TE,THMOLL
      REAL             AP,AE,UP,UE











# 4935 "corsika.h"



      COMMON /CRUPHIOT/THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI
      DOUBLE PRECISION THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI





      COMMON /CRUSEFUL/PRM,PRMT2,RMI,VCI,MEDIUM,MEDOLD,IBLOBE
      DOUBLE PRECISION PRM,PRMT2,RMI,VCI
      INTEGER          MEDIUM,MEDOLD,IBLOBE



# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 41208 "corsika.F" 2

      DOUBLE PRECISION ABREMS,AI2LN2,BR,DEL,DELTA,H,P,PEIE,PESG,PESE,
     *                 REJF,T
      INTEGER          IDISTR,LVL,LVL0,LVX

      LOGICAL          FPASS

      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

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

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
# 41385 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"





























































      COMMON /CREGSDEB/JCLOCK,NCLOCK,FEGSDB
      INTEGER          JCLOCK,NCLOCK
      LOGICAL          FEGSDB

























# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"

























      COMMON /CRRANDPA/RD,FAC,U1,U2,NSEQ,ISEED,KNOR
      DOUBLE PRECISION RD(3000),FAC,U1,U2



      INTEGER          ISEED(3,10),NSEQ

      LOGICAL          KNOR



# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"



      COMMON /CRSTACKE/E,TIM,U,V,W,X,Y,Z,DNEAR,

     *                 WT,


     *                 ZAP,WAP,WA,XXXX,YYYY,


     *                 TSLAN,




     *                 IQ,IGEN,IR,IOBS,LPCTE,NP
      DOUBLE PRECISION E(60),TIM(60),U(60),V(60),W(60),
     *                 X(60),Y(60),Z(60),DNEAR(60)

     *                 ,WT(60)


     *                 ,ZAP(60),WAP(60),WA(60),XXXX(60),YYYY(60)


     *                 ,TSLAN(60)




      INTEGER          IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP



# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"



      COMMON /CRTHRESH/RMSQ,API,TE,THMOLL,AP,AE,UP,UE
      DOUBLE PRECISION RMSQ,API,TE,THMOLL
      REAL             AP,AE,UP,UE











# 4935 "corsika.h"



      COMMON /CRUPHIOT/THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI
      DOUBLE PRECISION THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI





      COMMON /CRUSEFUL/PRM,PRMT2,RMI,VCI,MEDIUM,MEDOLD,IBLOBE
      DOUBLE PRECISION PRM,PRMT2,RMI,VCI
      INTEGER          MEDIUM,MEDOLD,IBLOBE



# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 41385 "corsika.F" 2

      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


*-- 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







# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"



      COMMON /CRATMOS2/HLAY,HLAY0,THICKL,LAYNO,LAYNEW
      DOUBLE PRECISION HLAY(6),HLAY0(5,0:28),THICKL(5)
      INTEGER          LAYNO(0:41)
      LOGICAL          LAYNEW











# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"










      COMMON /CROBSPAR/OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP,
     *                 THETPR,PHIPR,

     *                 CORRXY,







     *                 NOBSLV
      DOUBLE PRECISION OBSLEV(20),THCKOB(20),XOFF(20),YOFF(20),
     *                 HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2)

     *                 ,CORRXY







      INTEGER          NOBSLV



# 4262 "corsika.h"



      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL



# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"



      COMMON /CRSTACKE/E,TIM,U,V,W,X,Y,Z,DNEAR,

     *                 WT,


     *                 ZAP,WAP,WA,XXXX,YYYY,


     *                 TSLAN,




     *                 IQ,IGEN,IR,IOBS,LPCTE,NP
      DOUBLE PRECISION E(60),TIM(60),U(60),V(60),W(60),
     *                 X(60),Y(60),Z(60),DNEAR(60)

     *                 ,WT(60)


     *                 ,ZAP(60),WAP(60),WA(60),XXXX(60),YYYY(60)


     *                 ,TSLAN(60)




      INTEGER          IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP



# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"











      COMMON /CRTIMLIM/DSTLIM,TIMLIM,LTMLMPR
      DOUBLE PRECISION DSTLIM,TIMLIM
      LOGICAL          LTMLMPR



# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 41497 "corsika.F" 2

      DOUBLE PRECISION DIST,SIGNE,TANPHI,TEA,DIAG,DIAGMX,AUXIL
      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 ( 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
        DIAGMX = DIAG
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
        AUXIL  = (C(1)+OBSLEV(1)) * SQRT((1.D0-WAP(NP))*(1.D0+WAP(NP)))
        AUXIL  = ((C(1)-Z(NP)) - AUXIL) * ((C(1)-Z(NP)) + AUXIL)
        IF ( PRMPAR(15) .LT. 0.D0 ) THEN




          DIAG = SQRT( AUXIL ) + (C(1)+OBSLEV(1)) * WAP(NP)
C  DISTANCE DIAG BETWEEN DETECTOR POSITION STARTING POINT AND TOP OF ATM  
          AUXIL  = (C(1)+OBSLEV(1))*SQRT((1.D0-WAP(NP))*(1.D0+WAP(NP)))
          AUXIL  = ((C(1)+HLAY(6)) - AUXIL) * ((C(1)+HLAY(6)) + AUXIL)
          DIAGMX = SQRT( AUXIL ) + (C(1)+OBSLEV(1)) * WAP(NP) - DIAG        

        ELSE
          DIAG = SQRT( AUXIL ) - (C(1)+OBSLEV(1)) * WAP(NP)
          DIAGMX = DIAG
        ENDIF
C  APPARENT HEIGHT ZAP IS PARTICLE Z-COORDINATE IN DETECTOR SYSTEM



        ZAP(NP) = -OBSLEV(1) - DIAG * ABS(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))*ABS(WAP(NP)))/(C(1)-Z(NP))

        W(NP) = SIGN( W(NP), WAP(NP) )
      ENDIF
# 41604 "corsika.F"
      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  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) )

C TAKE INTO ACCOUNT THE FACT THAT WE ARE ON THE OTHER SIDE OF THE AXIS
      TEA = SIGN( TEA, WAP(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 ( W(NP) .LT. 1.D0  .AND.  W(NP) .GT. -1.D0 ) THEN



        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


*-- 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
# 41695 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"





























































      COMMON /CREGSDEB/JCLOCK,NCLOCK,FEGSDB
      INTEGER          JCLOCK,NCLOCK
      LOGICAL          FEGSDB

























# 3811 "corsika.h"

# 3824 "corsika.h"










      COMMON /CRGENER/ GEN,ALEVEL
      DOUBLE PRECISION GEN,ALEVEL





      COMMON /CRGEOMEGS/ZALTIT,BOUND,OBSLVL,OBSLV2,NEWOBS
      DOUBLE PRECISION ZALTIT,BOUND(6),OBSLVL(20),OBSLV2(20)
      INTEGER          NEWOBS



# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"
























      INTEGER          LNGMAX
      PARAMETER        (LNGMAX = 15000)
      INTEGER          TYPE1
      PARAMETER        (TYPE1 = 0)
      INTEGER          TYPE2
      PARAMETER        (TYPE2 = 1)
      INTEGER          TYPE3
      PARAMETER        (TYPE3 = 2)
      INTEGER          TYPE4
      PARAMETER        (TYPE4 = 3)
      COMMON /CRLONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP



     *                ,LLONGI,FLGFIT
# 3961 "corsika.h"
      DOUBLE PRECISION ADLONG(0:LNGMAX,19),AELONG(0:LNGMAX,10),
     *                 APLONG(0:LNGMAX,10),DLONG(0:LNGMAX,19),
     *                 ELONG(0:LNGMAX,10),
     *                 HLONG(0:LNGMAX),PLONG(0:LNGMAX,10),
     *                 SDLONG(0:LNGMAX,19),SELONG(0:LNGMAX,10),
     *                 SPLONG(0:LNGMAX,10),THSTEP,THSTPI




      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT

      COMMON /CRSLANT/ RLONG,THCKRL,CTH,STHCPH,STHSPH,RLOFF
      DOUBLE PRECISION RLONG(0:LNGMAX),THCKRL(0:LNGMAX),
     *                 CTH,STHCPH,STHSPH,RLOFF


















# 4005 "corsika.h"










      COMMON /CRMISC/  DUNIT,RHOR,KMPI,KMPO,NOSCAT,MED,IRAYLR
      DOUBLE PRECISION DUNIT,RHOR(6)
      INTEGER          KMPI,KMPO,NOSCAT,MED(6),IRAYLR(6)



# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"










      COMMON /CROBSPAR/OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP,
     *                 THETPR,PHIPR,

     *                 CORRXY,







     *                 NOBSLV
      DOUBLE PRECISION OBSLEV(20),THCKOB(20),XOFF(20),YOFF(20),
     *                 HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2)

     *                 ,CORRXY







      INTEGER          NOBSLV



# 4262 "corsika.h"



      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL



# 4332 "corsika.h"









# 4354 "corsika.h"



      COMMON /CRPION/  PI0MSQ,PITHR,PICMAS,PI0MAS,AMASK0,AMASKC,AMASPR,
     *                 AMASNT
      DOUBLE PRECISION PI0MSQ,PITHR,PICMAS,PI0MAS,AMASK0,AMASKC,AMASPR,
     *                 AMASNT



# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"










      COMMON /CRREJECT/AVNREJ,ALTMIN,ANEXP,THICKA,THICKD,CUTLN,EONCUT,

     *                 EFRCTHN,ETHINN,ETHINNG,THINRAT,THINRATH,WEITRAT,
     *                 WEITRATH,EEFRTHN,

     *                 FNPRIM
      DOUBLE PRECISION AVNREJ(20),ALTMIN(20),ANEXP(20),THICKA(20),
     *                 THICKD(20),CUTLN,EONCUT

     *                 ,EFRCTHN,ETHINN,ETHINNG,THINRAT,THINRATH,WEITRAT,
     *                 WEITRATH,EEFRTHN

      LOGICAL          FNPRIM





















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"



      COMMON /CRSTACKE/E,TIM,U,V,W,X,Y,Z,DNEAR,

     *                 WT,


     *                 ZAP,WAP,WA,XXXX,YYYY,


     *                 TSLAN,




     *                 IQ,IGEN,IR,IOBS,LPCTE,NP
      DOUBLE PRECISION E(60),TIM(60),U(60),V(60),W(60),
     *                 X(60),Y(60),Z(60),DNEAR(60)

     *                 ,WT(60)


     *                 ,ZAP(60),WAP(60),WA(60),XXXX(60),YYYY(60)


     *                 ,TSLAN(60)




      INTEGER          IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP



# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"



      COMMON /CRTHRESH/RMSQ,API,TE,THMOLL,AP,AE,UP,UE
      DOUBLE PRECISION RMSQ,API,TE,THMOLL
      REAL             AP,AE,UP,UE











# 4935 "corsika.h"










      COMMON /CRUSEFUL/PRM,PRMT2,RMI,VCI,MEDIUM,MEDOLD,IBLOBE
      DOUBLE PRECISION PRM,PRMT2,RMI,VCI
      INTEGER          MEDIUM,MEDOLD,IBLOBE



# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 41695 "corsika.F" 2

      DOUBLE PRECISION EEIN,THICK
      INTEGER          IDET,K
      SAVE
      EXTERNAL         THICK

      DOUBLE PRECISION PHI1,RRR,XXX,YYY


      DOUBLE PRECISION AUXIL,THCKSI
      EXTERNAL         THCKSI

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)

      WT(1)  = SECPAR(13)


      ZAP(NP) =-SECPAR(14)
      WAP(NP) = SECPAR(15)
      WA(NP)  = SECPAR(16)

      IGEN(1) = GEN






      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

      IF ( LLONGI ) THEN


        AUXIL    = XXX*STHCPH - YYY*STHSPH + ZAP(1)*CTH + RLOFF



        TSLAN(1) = THCKSI( AUXIL )
        LPCTE(1) = MIN( INT( TSLAN(1)*THSTPI + 1.D0 ), NSTEP+1 )



      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 1
        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 1
        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

      RETURN







 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
# 41838 "corsika.F"
      RETURN
# 41847 "corsika.F"
 130  CONTINUE
C  NEWOBS IS THE NEXT OBSERVATION LEVEL DOWNWARDS
      NEWOBS = IOBS(1)



      IF ( DEBUG ) WRITE(MDEBUG,*)
     *            'EGS4  :IQ=',IQ(1),' IR=',IR(1),' IOBS=',IOBS(1)
      CALL SHOWER
# 41867 "corsika.F"
      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
# 41895 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"










      COMMON /CRBOUNDS/ECUT,PCUT,VACDST
      DOUBLE PRECISION ECUT(6),PCUT(6),VACDST



# 3655 "corsika.h"

# 3705 "corsika.h"





























































      COMMON /CREGSDEB/JCLOCK,NCLOCK,FEGSDB
      INTEGER          JCLOCK,NCLOCK
      LOGICAL          FEGSDB



























      COMMON /CRELECIN/EKE0,EKE1,XR0,TEFF0,BLCC,XCC,ESIG0,ESIG1,PSIG0,
     *                 PSIG1,EDEDX0,EDEDX1,PDEDX0,PDEDX1,
     *                 EBR10,EBR11,EBR20,EBR21,
     *                 PBR10,PBR11,PBR20,PBR21,PBR30,PBR31,
     *                 TMXS0,TMXS1,ERANG0,
     *                 ERANG1,PRANG0,PRANG1,STERNCOR
      REAL             EKE0,EKE1,XR0,TEFF0,BLCC,XCC,
     *                 ESIG0(500),ESIG1(500),PSIG0(500),PSIG1(500),
     *                 EDEDX0(500),EDEDX1(500),PDEDX0(500),PDEDX1(500),
     *                 EBR10(500),EBR11(500),EBR20(500),EBR21(500),
     *                 PBR10(500),PBR11(500),PBR20(500),PBR21(500),
     *                 PBR30(500),PBR31(500),TMXS0(500),TMXS1(500),
     *                 ERANG0(1),ERANG1(1),PRANG0(1),PRANG1(1),STERNCOR





      COMMON /CREPCONT/EDEP,RATIO,TSTEP,TUSTEP,USTEP,TVSTEP,VSTEP,
     *                 RHOFAC,EOLD,ENEW,EKE,ELKE,BETA2,GLE,TSCAT,
     *                 WCUT,
     *                 IDISC,IROLD,IRNEW
      DOUBLE PRECISION EDEP,RATIO,TSTEP,TUSTEP,USTEP,TVSTEP,VSTEP,
     *                 RHOFAC,EOLD,ENEW, EKE,ELKE,BETA2,GLE,TSCAT,
     *                 WCUT
      INTEGER          IDISC,IROLD,IRNEW

























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"

















      COMMON /CRMEDIA/ RLDU,RLDUI,RHO,RLC,NMED,MSGE,MGE,MSEKE,MEKE,
     *                 MLEKE,MCMFP,MRANGE,IRAYLM
      DOUBLE PRECISION RLDU,RLDUI
      REAL             RHO,RLC
      INTEGER          NMED,MSGE,MGE,MSEKE,MEKE,MLEKE,MCMFP,MRANGE,
     *                 IRAYLM





      COMMON /CRMEDIAC/MEDIA
      CHARACTER        MEDIA*24





      COMMON /CRMISC/  DUNIT,RHOR,KMPI,KMPO,NOSCAT,MED,IRAYLR
      DOUBLE PRECISION DUNIT,RHOR(6)
      INTEGER          KMPI,KMPO,NOSCAT,MED(6),IRAYLR(6)



# 4047 "corsika.h"









# 4075 "corsika.h"



      COMMON /CRMULTS/ B0G21,B1G21,G210,G211,G212,
     *                 B0G22,B1G22,G220,G221,G222,
     *                 B0G31,B1G31,G310,G311,G312,
     *                 B0G32,B1G32,G320,G321,G322,
     *                 B0BGB,B1BGB,BGB0,BGB1,BGB2,NBGB
      DOUBLE PRECISION B0G21,B1G21,G210(7),G211(7),G212(7),
     *                 B0G22,B1G22,G220(8),G221(8),G222(8),
     *                 B0G31,B1G31,G310(11),G311(11),G312(11),
     *                 B0G32,B1G32,G320(25),G321(25),G322(25),
     *                 B0BGB,B1BGB,BGB0(8),BGB1(8),BGB2(8)
      INTEGER          NBGB


















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"



      COMMON /CRPATHCM/B0PTH,B1PTH,PTH0,PTH1,PTH2,NPTH
      DOUBLE PRECISION B0PTH,B1PTH,PTH0(6),PTH1(6),PTH2(6)
      INTEGER          NPTH



# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"

















# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"



      COMMON /CRTHRESH/RMSQ,API,TE,THMOLL,AP,AE,UP,UE
      DOUBLE PRECISION RMSQ,API,TE,THMOLL
      REAL             AP,AE,UP,UE











# 4935 "corsika.h"



      COMMON /CRUPHIOT/THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI
      DOUBLE PRECISION THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI





      COMMON /CRUSEFUL/PRM,PRMT2,RMI,VCI,MEDIUM,MEDOLD,IBLOBE
      DOUBLE PRECISION PRM,PRMT2,RMI,VCI
      INTEGER          MEDIUM,MEDOLD,IBLOBE



# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 41895 "corsika.F" 2

      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
# 42013 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"










      COMMON /CRATMOS/ AATM,AATM0,BATM,BATM0,CATM,CATM0,DATM,MODATM
     *                ,MATMFI,LATMNEW
      DOUBLE PRECISION AATM(5),AATM0(5,0:42),BATM(5),BATM0(5,0:42),
     *                 CATM(5),CATM0(5,0:42),DATM(5)
      INTEGER          MODATM,MATMFI
      LOGICAL          LATMNEW





      COMMON /CRATMOS2/HLAY,HLAY0,THICKL,LAYNO,LAYNEW
      DOUBLE PRECISION HLAY(6),HLAY0(5,0:28),THICKL(5)
      INTEGER          LAYNO(0:41)
      LOGICAL          LAYNEW











# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"










      COMMON /CRBOUNDS/ECUT,PCUT,VACDST
      DOUBLE PRECISION ECUT(6),PCUT(6),VACDST



# 3655 "corsika.h"

# 3705 "corsika.h"





































































      COMMON /CRELABCT/ELCUT
      DOUBLE PRECISION ELCUT(4)


















# 3811 "corsika.h"



      COMMON /CREPCONT/EDEP,RATIO,TSTEP,TUSTEP,USTEP,TVSTEP,VSTEP,
     *                 RHOFAC,EOLD,ENEW,EKE,ELKE,BETA2,GLE,TSCAT,
     *                 WCUT,
     *                 IDISC,IROLD,IRNEW
      DOUBLE PRECISION EDEP,RATIO,TSTEP,TUSTEP,USTEP,TVSTEP,VSTEP,
     *                 RHOFAC,EOLD,ENEW, EKE,ELKE,BETA2,GLE,TSCAT,
     *                 WCUT
      INTEGER          IDISC,IROLD,IRNEW



















      COMMON /CRGEOMEGS/ZALTIT,BOUND,OBSLVL,OBSLV2,NEWOBS
      DOUBLE PRECISION ZALTIT,BOUND(6),OBSLVL(20),OBSLV2(20)
      INTEGER          NEWOBS



# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"










      COMMON /CRLAYER/ HBARO,HBAROI
      DOUBLE PRECISION HBARO(6),HBAROI(6)










# 3980 "corsika.h"















# 4005 "corsika.h"



      COMMON /CRMEDIAC/MEDIA
      CHARACTER        MEDIA*24





      COMMON /CRMISC/  DUNIT,RHOR,KMPI,KMPO,NOSCAT,MED,IRAYLR
      DOUBLE PRECISION DUNIT,RHOR(6)
      INTEGER          KMPI,KMPO,NOSCAT,MED(6),IRAYLR(6)



# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"











      COMMON /CRMUON/  PRRMMU,RMMUT4
      DOUBLE PRECISION PRRMMU,RMMUT4



# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"










      COMMON /CROBSPAR/OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP,
     *                 THETPR,PHIPR,

     *                 CORRXY,







     *                 NOBSLV
      DOUBLE PRECISION OBSLEV(20),THCKOB(20),XOFF(20),YOFF(20),
     *                 HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2)

     *                 ,CORRXY







      INTEGER          NOBSLV










      COMMON /CRPAM/   PAMA,SIGNUM,RESTMS,DECTIM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000),
     *                 DECTIM(200)






      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL



# 4332 "corsika.h"









# 4354 "corsika.h"



      COMMON /CRPION/  PI0MSQ,PITHR,PICMAS,PI0MAS,AMASK0,AMASKC,AMASPR,
     *                 AMASNT
      DOUBLE PRECISION PI0MSQ,PITHR,PICMAS,PI0MAS,AMASK0,AMASKC,AMASPR,
     *                 AMASNT



# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"










      COMMON /CRREJECT/AVNREJ,ALTMIN,ANEXP,THICKA,THICKD,CUTLN,EONCUT,

     *                 EFRCTHN,ETHINN,ETHINNG,THINRAT,THINRATH,WEITRAT,
     *                 WEITRATH,EEFRTHN,

     *                 FNPRIM
      DOUBLE PRECISION AVNREJ(20),ALTMIN(20),ANEXP(20),THICKA(20),
     *                 THICKD(20),CUTLN,EONCUT

     *                 ,EFRCTHN,ETHINN,ETHINNG,THINRAT,THINRATH,WEITRAT,
     *                 WEITRATH,EEFRTHN

      LOGICAL          FNPRIM





















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"



      COMMON /CRTHRESH/RMSQ,API,TE,THMOLL,AP,AE,UP,UE
      DOUBLE PRECISION RMSQ,API,TE,THMOLL
      REAL             AP,AE,UP,UE











# 4935 "corsika.h"



      COMMON /CRUPHIOT/THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI
      DOUBLE PRECISION THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI





      COMMON /CRUSEFUL/PRM,PRMT2,RMI,VCI,MEDIUM,MEDOLD,IBLOBE
      DOUBLE PRECISION PRM,PRMT2,RMI,VCI
      INTEGER          MEDIUM,MEDOLD,IBLOBE



# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 42013 "corsika.F" 2

      INTEGER          I,IDET,IRL,JREG,KREG
      CHARACTER        MEDARR*24




      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
      WCUT   = C(29)
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)



        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 1
 80     CONTINUE
# 42107 "corsika.F"
      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
# 42135 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"










      COMMON /CRBOUNDS/ECUT,PCUT,VACDST
      DOUBLE PRECISION ECUT(6),PCUT(6),VACDST



# 3655 "corsika.h"

# 3705 "corsika.h"





































































      COMMON /CRELABCT/ELCUT
      DOUBLE PRECISION ELCUT(4)




















      COMMON /CRELECIN/EKE0,EKE1,XR0,TEFF0,BLCC,XCC,ESIG0,ESIG1,PSIG0,
     *                 PSIG1,EDEDX0,EDEDX1,PDEDX0,PDEDX1,
     *                 EBR10,EBR11,EBR20,EBR21,
     *                 PBR10,PBR11,PBR20,PBR21,PBR30,PBR31,
     *                 TMXS0,TMXS1,ERANG0,
     *                 ERANG1,PRANG0,PRANG1,STERNCOR
      REAL             EKE0,EKE1,XR0,TEFF0,BLCC,XCC,
     *                 ESIG0(500),ESIG1(500),PSIG0(500),PSIG1(500),
     *                 EDEDX0(500),EDEDX1(500),PDEDX0(500),PDEDX1(500),
     *                 EBR10(500),EBR11(500),EBR20(500),EBR21(500),
     *                 PBR10(500),PBR11(500),PBR20(500),PBR21(500),
     *                 PBR30(500),PBR31(500),TMXS0(500),TMXS1(500),
     *                 ERANG0(1),ERANG1(1),PRANG0(1),PRANG1(1),STERNCOR



# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"










      COMMON /CRMISC/  DUNIT,RHOR,KMPI,KMPO,NOSCAT,MED,IRAYLR
      DOUBLE PRECISION DUNIT,RHOR(6)
      INTEGER          KMPI,KMPO,NOSCAT,MED(6),IRAYLR(6)



# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"



      COMMON /CRTHRESH/RMSQ,API,TE,THMOLL,AP,AE,UP,UE
      DOUBLE PRECISION RMSQ,API,TE,THMOLL
      REAL             AP,AE,UP,UE











# 4935 "corsika.h"










      COMMON /CRUSEFUL/PRM,PRMT2,RMI,VCI,MEDIUM,MEDOLD,IBLOBE
      DOUBLE PRECISION PRM,PRMT2,RMI,VCI
      INTEGER          MEDIUM,MEDOLD,IBLOBE



# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 42135 "corsika.F" 2

      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 1
        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)

**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|      |')







      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
# 42348 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"










      COMMON /CRBOUNDS/ECUT,PCUT,VACDST
      DOUBLE PRECISION ECUT(6),PCUT(6),VACDST



# 3655 "corsika.h"



      COMMON /CRBUFFS/ RUNH,RUNE,EVTH,EVTE,DATAB,ARRAYLONG,LH

     *                 ,WRRUNH,WRRUNE,WREVTH,WREVTE

      INTEGER          MAXBUF,MAXLEN

      PARAMETER        (MAXBUF=39*8)
# 3681 "corsika.h"
      PARAMETER        (MAXLEN=16)
# 3693 "corsika.h"
      REAL             RUNH(MAXBUF),EVTH(MAXBUF),EVTE(MAXBUF),
     *                 RUNE(MAXBUF),DATAB(MAXBUF),ARRAYLONG(MAXBUF)
      INTEGER          LH

      LOGICAL          WRRUNH,WRRUNE,WREVTH,WREVTE

      CHARACTER*4      CRUNH,CRUNE,CEVTH,CEVTE,CLONG
      EQUIVALENCE      (RUNH(1),CRUNH), (RUNE(1),CRUNE)
      EQUIVALENCE      (EVTH(1),CEVTH), (EVTE(1),CEVTE)
      EQUIVALENCE      (ARRAYLONG(1),CLONG)































































      COMMON /CREGSDEB/JCLOCK,NCLOCK,FEGSDB
      INTEGER          JCLOCK,NCLOCK
      LOGICAL          FEGSDB





      COMMON /CRELABCT/ELCUT
      DOUBLE PRECISION ELCUT(4)




















      COMMON /CRELECIN/EKE0,EKE1,XR0,TEFF0,BLCC,XCC,ESIG0,ESIG1,PSIG0,
     *                 PSIG1,EDEDX0,EDEDX1,PDEDX0,PDEDX1,
     *                 EBR10,EBR11,EBR20,EBR21,
     *                 PBR10,PBR11,PBR20,PBR21,PBR30,PBR31,
     *                 TMXS0,TMXS1,ERANG0,
     *                 ERANG1,PRANG0,PRANG1,STERNCOR
      REAL             EKE0,EKE1,XR0,TEFF0,BLCC,XCC,
     *                 ESIG0(500),ESIG1(500),PSIG0(500),PSIG1(500),
     *                 EDEDX0(500),EDEDX1(500),PDEDX0(500),PDEDX1(500),
     *                 EBR10(500),EBR11(500),EBR20(500),EBR21(500),
     *                 PBR10(500),PBR11(500),PBR20(500),PBR21(500),
     *                 PBR30(500),PBR31(500),TMXS0(500),TMXS1(500),
     *                 ERANG0(1),ERANG1(1),PRANG0(1),PRANG1(1),STERNCOR





      COMMON /CREPCONT/EDEP,RATIO,TSTEP,TUSTEP,USTEP,TVSTEP,VSTEP,
     *                 RHOFAC,EOLD,ENEW,EKE,ELKE,BETA2,GLE,TSCAT,
     *                 WCUT,
     *                 IDISC,IROLD,IRNEW
      DOUBLE PRECISION EDEP,RATIO,TSTEP,TUSTEP,USTEP,TVSTEP,VSTEP,
     *                 RHOFAC,EOLD,ENEW, EKE,ELKE,BETA2,GLE,TSCAT,
     *                 WCUT
      INTEGER          IDISC,IROLD,IRNEW



















      COMMON /CRGEOMEGS/ZALTIT,BOUND,OBSLVL,OBSLV2,NEWOBS
      DOUBLE PRECISION ZALTIT,BOUND(6),OBSLVL(20),OBSLV2(20)
      INTEGER          NEWOBS



# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"










      COMMON /CRLAYER/ HBARO,HBAROI
      DOUBLE PRECISION HBARO(6),HBAROI(6)












      INTEGER          LNGMAX
      PARAMETER        (LNGMAX = 15000)
      INTEGER          TYPE1
      PARAMETER        (TYPE1 = 0)
      INTEGER          TYPE2
      PARAMETER        (TYPE2 = 1)
      INTEGER          TYPE3
      PARAMETER        (TYPE3 = 2)
      INTEGER          TYPE4
      PARAMETER        (TYPE4 = 3)
      COMMON /CRLONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP



     *                ,LLONGI,FLGFIT
# 3961 "corsika.h"
      DOUBLE PRECISION ADLONG(0:LNGMAX,19),AELONG(0:LNGMAX,10),
     *                 APLONG(0:LNGMAX,10),DLONG(0:LNGMAX,19),
     *                 ELONG(0:LNGMAX,10),
     *                 HLONG(0:LNGMAX),PLONG(0:LNGMAX,10),
     *                 SDLONG(0:LNGMAX,19),SELONG(0:LNGMAX,10),
     *                 SPLONG(0:LNGMAX,10),THSTEP,THSTPI




      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT

      COMMON /CRSLANT/ RLONG,THCKRL,CTH,STHCPH,STHSPH,RLOFF
      DOUBLE PRECISION RLONG(0:LNGMAX),THCKRL(0:LNGMAX),
     *                 CTH,STHCPH,STHSPH,RLOFF













      COMMON /CRMAGNET/BX,BZ,BVAL,BNORMC,BNORM,COSB,SINB,BLIMIT
      DOUBLE PRECISION BX,BZ,BVAL,BNORMC,BNORM,COSB,SINB,BLIMIT





      COMMON /CRMEDIA/ RLDU,RLDUI,RHO,RLC,NMED,MSGE,MGE,MSEKE,MEKE,
     *                 MLEKE,MCMFP,MRANGE,IRAYLM
      DOUBLE PRECISION RLDU,RLDUI
      REAL             RHO,RLC
      INTEGER          NMED,MSGE,MGE,MSEKE,MEKE,MLEKE,MCMFP,MRANGE,
     *                 IRAYLM





      COMMON /CRMEDIAC/MEDIA
      CHARACTER        MEDIA*24





      COMMON /CRMISC/  DUNIT,RHOR,KMPI,KMPO,NOSCAT,MED,IRAYLR
      DOUBLE PRECISION DUNIT,RHOR(6)
      INTEGER          KMPI,KMPO,NOSCAT,MED(6),IRAYLR(6)



# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"











      COMMON /CRMUON/  PRRMMU,RMMUT4
      DOUBLE PRECISION PRRMMU,RMMUT4



# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"










      COMMON /CROBSPAR/OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP,
     *                 THETPR,PHIPR,

     *                 CORRXY,







     *                 NOBSLV
      DOUBLE PRECISION OBSLEV(20),THCKOB(20),XOFF(20),YOFF(20),
     *                 HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2)

     *                 ,CORRXY







      INTEGER          NOBSLV



# 4262 "corsika.h"



      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL



# 4332 "corsika.h"



      COMMON /CRPATHCM/B0PTH,B1PTH,PTH0,PTH1,PTH2,NPTH
      DOUBLE PRECISION B0PTH,B1PTH,PTH0(6),PTH1(6),PTH2(6)
      INTEGER          NPTH



# 4354 "corsika.h"



      COMMON /CRPION/  PI0MSQ,PITHR,PICMAS,PI0MAS,AMASK0,AMASKC,AMASPR,
     *                 AMASNT
      DOUBLE PRECISION PI0MSQ,PITHR,PICMAS,PI0MAS,AMASK0,AMASKC,AMASPR,
     *                 AMASNT



# 4383 "corsika.h"

























      COMMON /CRRANDPA/RD,FAC,U1,U2,NSEQ,ISEED,KNOR
      DOUBLE PRECISION RD(3000),FAC,U1,U2



      INTEGER          ISEED(3,10),NSEQ

      LOGICAL          KNOR



# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"










      COMMON /CRREJECT/AVNREJ,ALTMIN,ANEXP,THICKA,THICKD,CUTLN,EONCUT,

     *                 EFRCTHN,ETHINN,ETHINNG,THINRAT,THINRATH,WEITRAT,
     *                 WEITRATH,EEFRTHN,

     *                 FNPRIM
      DOUBLE PRECISION AVNREJ(20),ALTMIN(20),ANEXP(20),THICKA(20),
     *                 THICKD(20),CUTLN,EONCUT

     *                 ,EFRCTHN,ETHINN,ETHINNG,THINRAT,THINRATH,WEITRAT,
     *                 WEITRATH,EEFRTHN

      LOGICAL          FNPRIM





















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"



      COMMON /CRSTACKE/E,TIM,U,V,W,X,Y,Z,DNEAR,

     *                 WT,


     *                 ZAP,WAP,WA,XXXX,YYYY,


     *                 TSLAN,




     *                 IQ,IGEN,IR,IOBS,LPCTE,NP
      DOUBLE PRECISION E(60),TIM(60),U(60),V(60),W(60),
     *                 X(60),Y(60),Z(60),DNEAR(60)

     *                 ,WT(60)


     *                 ,ZAP(60),WAP(60),WA(60),XXXX(60),YYYY(60)


     *                 ,TSLAN(60)




      INTEGER          IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP



# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"



      COMMON /CRTHRESH/RMSQ,API,TE,THMOLL,AP,AE,UP,UE
      DOUBLE PRECISION RMSQ,API,TE,THMOLL
      REAL             AP,AE,UP,UE





      COMMON /CRTIMLIM/DSTLIM,TIMLIM,LTMLMPR
      DOUBLE PRECISION DSTLIM,TIMLIM
      LOGICAL          LTMLMPR



# 4935 "corsika.h"



      COMMON /CRUPHIOT/THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI
      DOUBLE PRECISION THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI





      COMMON /CRUSEFUL/PRM,PRMT2,RMI,VCI,MEDIUM,MEDOLD,IBLOBE
      DOUBLE PRECISION PRM,PRMT2,RMI,VCI
      INTEGER          MEDIUM,MEDOLD,IBLOBE



# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 42348 "corsika.F" 2

      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
# 42385 "corsika.F"
      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


      DOUBLE PRECISION ZNEWUP





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





      DOUBLE PRECISION ZAPOLD,XXXOLD,YYYOLD,SPEED0,SPEED,TDIFF
      INTEGER          LCOUNT


      DOUBLE PRECISION AUXIL1,AUXOLD,AUXNEW,THCKSI,T1,T2
      EXTERNAL         THCKSI







      LOGICAL          FPASS


      DOUBLE PRECISION EKENP,EKENP1

      SAVE
      EXTERNAL         THICK
      DATA             NSTPCN / 0 /

     *                ,LCOUNT / 0 /




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)





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 )
# 42541 "corsika.F"
        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
# 42569 "corsika.F"
C  BEGINNING OF TRACKING STEP
      pnt1id =  IQ(NP)
      pnt1gen=  igen(NP)

      pnt1x  =  XXXX(NP)
      pnt1y  = -YYYY(NP)
      pnt1z  = -ZAP(NP)






      pnt1d  =  TSLAN(NP)



      pnt1t  =  TIM(NP)
      pnt1e  =  E(NP) * 0.001D0

      pnt1w  =  WT(NP)








      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 )
# 42715 "corsika.F"
C  LOOK HOW FAR WE CAN GO

      DNEAR(NP) = 0.D0

      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 1
          ENDIF
        ENDIF
        USTEP = 0.D0
      ENDIF

      ZOLD   = Z(NP)

      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 )

          W(NP) = MAX( -1.D0, W(NP) )

        ENDIF
C  KILL HORIZONTAL OR UPWARD GOING PARTICLES

        IF ( W(NP) .LT. 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



        ELSE



        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     ( W(NP) .GT. 0.D0 ) THEN



            USTEP = -(Z(NP)+OBSLEV(1))/W(NP)
# 42863 "corsika.F"
        ELSEIF ( W(NP) .LT. 0.D0 ) THEN







            IF ( FEGSDB ) WRITE(MDEBUG,*)'ELECTR: UPWARD GOING PARTICL'
     *        ,'E SHOULD NOT REACH DETECTOR !'

            IDISC = 1
            IRETC = .FALSE.
            GOTO 420



        ELSE
C  HORIZONTAL MOVEMENT
C         USTEP = MAX( C(4) * THICK( -Z(NP) ) + C(3), C(2) )
          IDISC = 1
          IRETC = .FALSE.
          GOTO 420
        ENDIF



        IF ( FEGSDB ) THEN
          WRITE(MDEBUG,*) 'ELECTR: CORR. FOR DET. ARRIVAL:USTEP=',USTEP
          CALL AUSGB2
        ENDIF
        USTEP = MAX( USTEP, 0.0001D0 )
        IPASC = 1
      ELSE



C  PARTICLE MOVES TO END OF ITS RANGE, WE DO NOT YET APPROACH DETECTOR
        IPASC  = 0
      ENDIF
# 42918 "corsika.F"

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))

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

          X(NP)  = X(NP) + VSTEP*UMEAN
          Y(NP)  = Y(NP) + VSTEP*VMEAN
          Z(NP)  = Z(NP) + VSTEP*WMEAN

          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) )

            W(NP)  = MAX( -1.D0, W(NP) )

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 )

            W(NP)     = MAX( -1.D0, W(NP) )

C  KILL HORIZONTAL OR UPWARD GOING PARTICLES

            IF ( W(NP) .LT. 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
# 43042 "corsika.F"
            IF ( FFLATOUT .AND. -ZAP(NP) .LE. OBSLEV(1) ) THEN
              IRETC = .TRUE.
              IDISC = -1
              IF ( FNPRIM ) GOTO 420
              GOTO 498
            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

# 43139 "corsika.F"

# 43205 "corsika.F"

C  ADD ELECTRONS TO THE LONGITUDINAL DEVELOPMENT
C  FIND FIRST THE EQUIVALENT LEVELS





            AUXOLD = XXXOLD*STHCPH - YYYOLD*STHSPH + ZAPOLD*CTH + RLOFF
            AUXNEW = XXXX(NP)*STHCPH-YYYY(NP)*STHSPH+ZAP(NP)*CTH + RLOFF






C  END OF TRACKING STEP
            pnt2id =  IQ(NP)
            pnt2gen=  igen(np)

            pnt2x  =  XXXX(NP)
            pnt2y  = -YYYY(NP)
            pnt2z  = -ZAP(NP)






            pnt2d  =  THCKSI( AUXNEW )



            pnt2t  =  TIM(NP)
            pnt2e  =  E(NP) * 0.001D0

            pnt2w  =  WT(NP)






            if(WREVTH .AND. pnt1w.gt.0.d0.and.pnt2w.gt.0.d0)
     &      call track(pnt1x, pnt2x)

          IF ( LLONGI ) THEN


C  IF STARTING POINT BEYOND FURTHEST LEVEL THEN DON''T CHECK
            IF ( RLONG(NSTEP) .GT. AUXOLD ) THEN
              T1    = TSLAN(NP)




              LPCT1 = LPCTE(NP)


              IF     ( AUXNEW .GT. AUXOLD ) THEN
C  FORWARD MOVING PARTICLE





C  Z_NEW IS PROBABLY ONLY LITTLE BELOW Z_OLD, DO INCREMENTAL SEARCH

               DO  I1 = LPCT1, NSTEP+1
                 IF ( RLONG(I1) .GT. AUXNEW ) GOTO 6003




               ENDDO
               I1 = NSTEP + 1
 6003          CONTINUE
               LPCT2 = I1 - 1
C  STORE END POINT AS POSSIBLE STARTPOINT OF NEXT TRACK
               LPCTE(NP) = LPCT2 + 1

               AUXNEW    = MIN( AUXNEW, RLONG(NSTEP+1) )
               TSLAN(NP) = THCKSI( AUXNEW )

               DO  I = LPCT1, LPCT2

                 PLONG(I,IQ(NP)) = PLONG(I,IQ(NP)) + WT(NP)



               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

     *            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)




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


              ELSEIF ( AUXNEW .LT. AUXOLD ) THEN
C  BACKWARD MOVING PARTICLE




C  Z_NEW IS PROBABLY ONLY LITTLE ABOVE Z_OLD, DO INCREMENTAL SEARCH
                DO  I1 = LPCT1-1, 0, -1

                  IF ( RLONG(I1) .LE. AUXNEW ) GOTO 6004



                ENDDO
                I1 = 0
 6004           CONTINUE
                LPCT2 = MAX( I1, 0 )

                LPCTE(NP) = LPCT2 + 1

                AUXNEW    = MIN( AUXNEW, RLONG(NSTEP+1) )
                TSLAN(NP) = THCKSI( AUXNEW )

                DO  I = LPCT2+1, LPCT1-1

                  PLONG(I,IQ(NP)) = PLONG(I,IQ(NP)) + WT(NP)



                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)) =

     *                                      PLONG(LPCT2,IQ(NP)) + WT(NP)
                ERELS = (E(NP) - DBLE(2*IQ(NP)-5) * PRM) * 1.D-3*WT(NP)




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
C  END LONGITUDINAL DISTRIBUTION FILLING
           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) .LT. 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




            CALL AUSGAB



            IOBS(NP) = NEWOBS

          ELSEIF ( NEWOBS .LT. IOBS(NP) ) THEN
            IOBS(NP) = NEWOBS




            CALL AUSGAB




          ENDIF

          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
        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) .LT. 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
# 43562 "corsika.F"
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))
# 43583 "corsika.F"
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

      X(NP)  = X(NP) + VSTEP*UMEAN
      Y(NP)  = Y(NP) + VSTEP*VMEAN
      Z(NP)  = Z(NP) + VSTEP*WMEAN

      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) )

        W(NP)  = MAX( -1.D0, W(NP) )

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 )

        W(NP)     = MAX( -1.D0, W(NP) )

C  KILL HORIZONTAL OR UPWARD GOING PARTICLES

        IF ( W(NP) .LT. 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
# 43673 "corsika.F"
        IF ( FFLATOUT  .AND.  -ZAP(NP) .LE. OBSLEV(1) ) THEN
          IRETC = .TRUE.
          IDISC = -1
          IF ( FNPRIM ) GOTO 420
          GOTO 498
        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

# 43770 "corsika.F"

# 43910 "corsika.F"

C  ADD ELECTRONS TO THE LONGITUDINAL DEVELOPMENT
C  FIND FIRST THE EQUIVALENT LEVELS





        AUXOLD = XXXOLD*STHCPH - YYYOLD*STHSPH + ZAPOLD*CTH + RLOFF
        AUXNEW = XXXX(NP)*STHCPH-YYYY(NP)*STHSPH+ZAP(NP)*CTH + RLOFF






C  END OF TRACKING STEP
        pnt2id =  IQ(NP)
        pnt2gen=  IGEN(NP)

        pnt2x  =  XXXX(NP)
        pnt2y  = -YYYY(NP)
        pnt2z  = -ZAP(NP)






        pnt2d  =  THCKSI( AUXNEW )



        pnt2t  =  TIM(NP)
        pnt2e  =  ENEW * 0.001D0

        pnt2w  =  WT(NP)






        if(WREVTH .AND. pnt1w.gt.0.d0.and.pnt2w.gt.0.d0)
     &  call track(pnt1x, pnt2x)

      IF ( LLONGI ) THEN


C  IF STARTING POINT BEYOND FURTHEST LEVEL THEN DON''T CHECK
        IF ( RLONG(NSTEP) .GT. AUXOLD ) THEN
          T1   = TSLAN(NP)




          LPCT1 = LPCTE(NP)


          IF     ( AUXNEW .GT. AUXOLD ) THEN
C  FORWARD MOVING PARTICLE





C  Z_NEW IS PROBABLY ONLY LITTLE BELOW Z_OLD, DO INCREMENTAL SEARCH

           DO  I1 = LPCT1, NSTEP+1
             IF ( RLONG(I1) .GT. AUXNEW ) GOTO 6103




           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

             PLONG(I,IQ(NP)) = PLONG(I,IQ(NP)) + WT(NP)



           ENDDO
C  ARE WE AT OBSERVATION LEVEL OR ATMOSPHERIC BOUNDARY
           IF ( IDISC .LT. 0 )

     *           PLONG(LPCT2+1,IQ(NP)) = PLONG(LPCT2+1,IQ(NP)) + WT(NP)



C  TOTAL PATH LENGTH STEPT IN UNITS OF LONGI BINS

           AUXNEW    = MIN( AUXNEW, RLONG(NSTEP+1) )
           TSLAN(NP) = THCKSI( AUXNEW )
           T2     = TSLAN(NP)
           STEPT  = (T2 - T1) * THSTPI





C  RELEASABLE ENERGY [IN GEV]

           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)
# 44033 "corsika.F"
           ENDIF
C  ENERGY DEPOSIT IN FIRST BIN [IN GEV]

           EDEP1 = EDEPB * (DBLE(LPCT1) - T1*THSTPI) 
cdh april 4, 2017
c          EDEP1 = MAX( 0.D0, EDEPB * (DBLE(LPCT1) - T1*THSTPI) )



C  ENERGY AT FIRST BIN BOUNDARY
           EFRST = ERELS - EDEP1
C  ENERGY DEPOSIT IN LAST BIN [IN GEV]
           IF ( LPCT2 .LE. LPCT1 ) THEN

             EDEPN = EDEPB * (T2*THSTPI - DBLE(LPCT1))
           ELSE
             EDEPN = MAX( 0.D0, EDEPB*(T2*THSTPI - DBLE(LPCT2)) )





           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


          ELSEIF ( AUXNEW .LT. AUXOLD ) THEN
C  BACKWARD MOVING PARTICLE




C  Z_NEW IS PROBABLY ONLY LITTLE ABOVE Z_OLD, DO INCREMENTAL SEARCH
            DO  I1 = LPCT1-1, 0, -1

              IF ( RLONG(I1) .LE. AUXNEW ) GOTO 6104



            ENDDO
            I1 = 0
 6104       CONTINUE
            LPCT2 = MAX( I1, 0 )
            LPCTE(NP) = LPCT2 + 1
            DO  I = LPCT2+1, LPCT1-1

              PLONG(I,IQ(NP)) = PLONG(I,IQ(NP)) + WT(NP)



            ENDDO
C  ARE WE AT OBSERVATION LEVEL OR ATMOSPHERIC BOUNDARY?
            IF ( IDISC .LT. 0 ) PLONG(LPCT2,IQ(NP)) =

     *                                     PLONG(LPCT2,IQ(NP)) + WT(NP)



C  TOTAL PATH LENGTH STEPT IN UNITS OF LONGI BINS

            AUXNEW = MIN( AUXNEW, RLONG(NSTEP+1) )
            TSLAN(NP) = THCKSI( AUXNEW )
            T2     = TSLAN(NP)
            STEPT  = (T1 - T2)*THSTPI






C  RELEASABLE ENERGY [IN GEV]

            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)
# 44150 "corsika.F"
            ENDIF
C  ENERGY DEPOSIT FOR UPWARD GOING PARTICLES IN FIRST BIN [IN GEV]

            EDEP1 = EDEPB * (T1 * THSTPI - DBLE(LPCT1-1))



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

              EDEPN = EDEPB * (DBLE(LPCT1-1) - T2*THSTPI)
            ELSE
              EDEPN = MAX( 0.D0, EDEPB*(DBLE(LPCT2+1) - T2*THSTPI) )





            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

            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)





          ENDIF


        ELSE
C  WE ARE AT END OF LONGITUDINAL DISTRIBUTION
C  FILL ALL IONIZATION ENERGY INTO LAST BIN

          DLONG(NSTEP+1,2) = DLONG(NSTEP+1,2) + EDEP * 1.D-3 * WT(NP)




C  END LONGITUDINAL DISTRIBUTION FILLING
        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) .LT. WCUT ) THEN



        IRETC = .FALSE.
        GOTO 420
      ENDIF
C  LOOK FOR OBSERVATION LEVEL AND GIVE TO OUTPUT
      IF ( NEWOBS .GT. IOBS(NP) ) THEN




        CALL AUSGAB



        IOBS(NP) = NEWOBS

      ELSEIF ( NEWOBS .LT. IOBS(NP) ) THEN
        IOBS(NP) = NEWOBS




        CALL AUSGAB




      ENDIF

      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

      IF ( IDISC .LT. 0 ) THEN
        IRETC = .TRUE.
        IF ( FNPRIM ) THEN

C  ADD ENERGY OF PARTICLE LEAVING THE ATMOSPHERE  TO DLONG
C  AND JUMP TO END OF ROUTINE
          IF ( IDISC .EQ. -2 ) GOTO 420

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





        ENDIF
        IF ( FIX1I ) THEN
C  IF HEIGHT OF FIRST INTERACTION IS FIXED, TAKE STARTING ANGLES OF
C  PRIMARY PARTICLE
          Z(1) = -FIXHEI
          NP   = 1





          LPCTE(1) = MIN( NSTEP, INT( THICK( FIXHEI )*THSTPI ) + 1 )

          DNEAR(NP) = 0.D0
          U(1) =  SECPAR(3)
          V(1) = -SECPAR(4)
          W(1) =  SECPAR(2)
        ENDIF

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

          AUXIL1   = XXX*STHCPH - YYY*STHSPH + ZAP(NP)*CTH + RLOFF
          TSLAN(1) = THCKSI( AUXIL1 )
          LPCTE(1) = MIN( NSTEP+1, INT( TSLAN(1)*THSTPI ) + 1 )

        ENDIF
C  STORE COORDINATES IN THE DETECTOR SYSTEM
        XXXX(1)  = XXX
        YYYY(1)  = YYY

        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)

        PRMPAR(14) = -ZAP(1)
        PRMPAR(16) = WA(1)
        PRMPAR(7)  = XXXX(1)
        PRMPAR(8)  = -YYYY(1)
# 44453 "corsika.F"
C  WREVTH SIGNALS THAT EVTH HAS BEEN WRITTEN OUT
        WREVTH = .TRUE.
# 44468 "corsika.F"
        CALL TOBUF( EVTH,0 )
# 44500 "corsika.F"
        IF ( .NOT. TMARGIN ) THEN
          TIM(1) = 0.D0
        ENDIF
# 44513 "corsika.F"
        WT(1)  = 1.D0

        FNPRIM = .TRUE.
        IF ( FPRINT ) THEN
          WRITE(KMPO,*)' FIRST INTERACTION AT ',ABS(EVTH(7)*0.01D0),
     *                 ' M ALTITUDE'
        ENDIF




C  FILL CURPAR TO UPDATE PRMPAR AFTER BOX3 CALL FOR PRIMARY PARTICLE 
        DO  I = 5, 8
          CURPAR(I) = PRMPAR(I)
        ENDDO

        CURPAR(14) = PRMPAR(14)
        CURPAR(16) = PRMPAR(16)
# 44541 "corsika.F"
        IF ( PEIE .LE. ECUT(IRL) ) GOTO 390
        IF ( IDISC .LT. 0 ) THEN
C  OBVIOUSLY THE PRIMARY HAS PASSED THROUGH TOTAL ATMOSPHERE.

C  ADD ENERGY OF PARTICLE LEAVING THE ATMOSPHERE  TO DLONG
C  AND JUMP TO END OF ROUTINE
          IF ( IDISC .EQ. -2 ) GOTO 420

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

          EKENP = E(NP) - PRM
          IF ( EKENP .LT. ETHINN ) THEN
            EKENP1 = E(NP-1) - PRM
            EKE    = PEIE - PRM
            CALL THIN( 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 ( 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
# 44631 "corsika.F"
        GOTO 380
      ENDIF
      PBR1 = PBR11(LELKE)*ELKE+PBR10(LELKE)
      IF ( RD(1) .GE. PBR1 ) THEN
C  ANNIHILATION
        CALL ANNIH

        EKENP = E(NP)
        IF ( EKENP .LT. ETHINN ) THEN
          EKENP1 = E(NP-1)
          EKE    = PEIE + PRM
          CALL THIN( 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

      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
# 44716 "corsika.F"
      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]

        DLONG(LPCTE(NP),3) = DLONG(LPCTE(NP),3) + EDEP*1.D-3*WT(NP)



      ENDIF
# 44758 "corsika.F"
      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)

          WT(NP) =  WT(NP-1)


          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)


          TSLAN(NP) = TSLAN(NP-1)

          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

          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)






        ENDIF
      ENDIF
# 44862 "corsika.F"
 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
# 44894 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"



      COMMON /CRAIR/   COMPOS,PROBTA,AVERAW,AVOGDR
      DOUBLE PRECISION COMPOS(3),PROBTA(3),AVERAW,AVOGDR



# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"





























































      COMMON /CREGSDEB/JCLOCK,NCLOCK,FEGSDB
      INTEGER          JCLOCK,NCLOCK
      LOGICAL          FEGSDB





      COMMON /CRELABCT/ELCUT
      DOUBLE PRECISION ELCUT(4)


















# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"








      COMMON /CRPAM/   PAMA,SIGNUM,RESTMS,DECTIM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000),
     *                 DECTIM(200)




# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"



      COMMON /CRPION/  PI0MSQ,PITHR,PICMAS,PI0MAS,AMASK0,AMASKC,AMASPR,
     *                 AMASNT
      DOUBLE PRECISION PI0MSQ,PITHR,PICMAS,PI0MAS,AMASK0,AMASKC,AMASPR,
     *                 AMASNT



# 4383 "corsika.h"

























      COMMON /CRRANDPA/RD,FAC,U1,U2,NSEQ,ISEED,KNOR
      DOUBLE PRECISION RD(3000),FAC,U1,U2



      INTEGER          ISEED(3,10),NSEQ

      LOGICAL          KNOR



# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"



      COMMON /CRSTACKE/E,TIM,U,V,W,X,Y,Z,DNEAR,

     *                 WT,


     *                 ZAP,WAP,WA,XXXX,YYYY,


     *                 TSLAN,




     *                 IQ,IGEN,IR,IOBS,LPCTE,NP
      DOUBLE PRECISION E(60),TIM(60),U(60),V(60),W(60),
     *                 X(60),Y(60),Z(60),DNEAR(60)

     *                 ,WT(60)


     *                 ,ZAP(60),WAP(60),WA(60),XXXX(60),YYYY(60)


     *                 ,TSLAN(60)




      INTEGER          IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP



# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"



      COMMON /CRUPHIOT/THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI
      DOUBLE PRECISION THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI











# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 44894 "corsika.F" 2

      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
# 45077 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"










      COMMON /CRBOUNDS/ECUT,PCUT,VACDST
      DOUBLE PRECISION ECUT(6),PCUT(6),VACDST





      COMMON /CRBREMPR/PWR2I,DL1,DL2,DL3,DL4,DL5,DL6,DELCM,ALPHI,BPAR,
     *                 DELPOS
      DOUBLE PRECISION PWR2I(60)
      REAL             DL1(6),DL2(6),DL3(6),DL4(6),DL5(6),DL6(6),
     *                 DELCM,ALPHI(2),BPAR(2),DELPOS(2)



# 3705 "corsika.h"



























































































      COMMON /CRELECIN/EKE0,EKE1,XR0,TEFF0,BLCC,XCC,ESIG0,ESIG1,PSIG0,
     *                 PSIG1,EDEDX0,EDEDX1,PDEDX0,PDEDX1,
     *                 EBR10,EBR11,EBR20,EBR21,
     *                 PBR10,PBR11,PBR20,PBR21,PBR30,PBR31,
     *                 TMXS0,TMXS1,ERANG0,
     *                 ERANG1,PRANG0,PRANG1,STERNCOR
      REAL             EKE0,EKE1,XR0,TEFF0,BLCC,XCC,
     *                 ESIG0(500),ESIG1(500),PSIG0(500),PSIG1(500),
     *                 EDEDX0(500),EDEDX1(500),PDEDX0(500),PDEDX1(500),
     *                 EBR10(500),EBR11(500),EBR20(500),EBR21(500),
     *                 PBR10(500),PBR11(500),PBR20(500),PBR21(500),
     *                 PBR30(500),PBR31(500),TMXS0(500),TMXS1(500),
     *                 ERANG0(1),ERANG1(1),PRANG0(1),PRANG1(1),STERNCOR



# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"

















      COMMON /CRMEDIA/ RLDU,RLDUI,RHO,RLC,NMED,MSGE,MGE,MSEKE,MEKE,
     *                 MLEKE,MCMFP,MRANGE,IRAYLM
      DOUBLE PRECISION RLDU,RLDUI
      REAL             RHO,RLC
      INTEGER          NMED,MSGE,MGE,MSEKE,MEKE,MLEKE,MCMFP,MRANGE,
     *                 IRAYLM





      COMMON /CRMEDIAC/MEDIA
      CHARACTER        MEDIA*24





      COMMON /CRMISC/  DUNIT,RHOR,KMPI,KMPO,NOSCAT,MED,IRAYLR
      DOUBLE PRECISION DUNIT,RHOR(6)
      INTEGER          KMPI,KMPO,NOSCAT,MED(6),IRAYLR(6)



# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"











      COMMON /CRPHOTIN/EBINDA,GE0,GE1,GMFP0,GMFP1,GBR10,GBR11,
     *                 GBR20,GBR21,GBR30,GBR31,GBR40,GBR41,
     *                 RCO0,RCO1,RSCT0,RSCT1,COHE0,COHE1,MPGEM,NGR
      REAL             EBINDA,GE0,GE1,GMFP0(500),GMFP1(500),
     *                 GBR10(500),GBR11(500),GBR20(500),GBR21(500),
     *                 GBR30(500),GBR31(500),GBR40(500),GBR41(500),
     *                 RCO0,RCO1,RSCT0(100),RSCT1(100),COHE0(500),
     *                 COHE1(500)
      INTEGER          MPGEM(1),NGR



# 4363 "corsika.h"

# 4383 "corsika.h"

























      COMMON /CRRANDPA/RD,FAC,U1,U2,NSEQ,ISEED,KNOR
      DOUBLE PRECISION RD(3000),FAC,U1,U2



      INTEGER          ISEED(3,10),NSEQ

      LOGICAL          KNOR



# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"



      COMMON /CRSTACKE/E,TIM,U,V,W,X,Y,Z,DNEAR,

     *                 WT,


     *                 ZAP,WAP,WA,XXXX,YYYY,


     *                 TSLAN,




     *                 IQ,IGEN,IR,IOBS,LPCTE,NP
      DOUBLE PRECISION E(60),TIM(60),U(60),V(60),W(60),
     *                 X(60),Y(60),Z(60),DNEAR(60)

     *                 ,WT(60)


     *                 ,ZAP(60),WAP(60),WA(60),XXXX(60),YYYY(60)


     *                 ,TSLAN(60)




      INTEGER          IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP



# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"



      COMMON /CRTHRESH/RMSQ,API,TE,THMOLL,AP,AE,UP,UE
      DOUBLE PRECISION RMSQ,API,TE,THMOLL
      REAL             AP,AE,UP,UE











# 4935 "corsika.h"



      COMMON /CRUPHIOT/THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI
      DOUBLE PRECISION THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI





      COMMON /CRUSEFUL/PRM,PRMT2,RMI,VCI,MEDIUM,MEDOLD,IBLOBE
      DOUBLE PRECISION PRM,PRMT2,RMI,VCI
      INTEGER          MEDIUM,MEDOLD,IBLOBE



# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 45077 "corsika.F" 2

      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 1
      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 1
      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
# 45386 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"





























































      COMMON /CREGSDEB/JCLOCK,NCLOCK,FEGSDB
      INTEGER          JCLOCK,NCLOCK
      LOGICAL          FEGSDB

























# 3811 "corsika.h"



      COMMON /CREPCONT/EDEP,RATIO,TSTEP,TUSTEP,USTEP,TVSTEP,VSTEP,
     *                 RHOFAC,EOLD,ENEW,EKE,ELKE,BETA2,GLE,TSCAT,
     *                 WCUT,
     *                 IDISC,IROLD,IRNEW
      DOUBLE PRECISION EDEP,RATIO,TSTEP,TUSTEP,USTEP,TVSTEP,VSTEP,
     *                 RHOFAC,EOLD,ENEW, EKE,ELKE,BETA2,GLE,TSCAT,
     *                 WCUT
      INTEGER          IDISC,IROLD,IRNEW



















      COMMON /CRGEOMEGS/ZALTIT,BOUND,OBSLVL,OBSLV2,NEWOBS
      DOUBLE PRECISION ZALTIT,BOUND(6),OBSLVL(20),OBSLV2(20)
      INTEGER          NEWOBS



# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"










      COMMON /CROBSPAR/OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP,
     *                 THETPR,PHIPR,

     *                 CORRXY,







     *                 NOBSLV
      DOUBLE PRECISION OBSLEV(20),THCKOB(20),XOFF(20),YOFF(20),
     *                 HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2)

     *                 ,CORRXY







      INTEGER          NOBSLV



# 4262 "corsika.h"



      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL



# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"



      COMMON /CRSTACKE/E,TIM,U,V,W,X,Y,Z,DNEAR,

     *                 WT,


     *                 ZAP,WAP,WA,XXXX,YYYY,


     *                 TSLAN,




     *                 IQ,IGEN,IR,IOBS,LPCTE,NP
      DOUBLE PRECISION E(60),TIM(60),U(60),V(60),W(60),
     *                 X(60),Y(60),Z(60),DNEAR(60)

     *                 ,WT(60)


     *                 ,ZAP(60),WAP(60),WA(60),XXXX(60),YYYY(60)


     *                 ,TSLAN(60)




      INTEGER          IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP



# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 45386 "corsika.F" 2

      DOUBLE PRECISION TVAL
      INTEGER          IRL,NOBS
      LOGICAL          IRETE

      DOUBLE PRECISION AUXIL,AUX3,BOUNDC,CEARTH,OBSGLOB,
     *                 XNEW,YNEW,ZB2,ZAPB2,
     *                 RADHOR,STEPMX,S2B,THICK,TOAXIS
      INTEGER          IBFLAG
      EXTERNAL         THICK


      DOUBLE PRECISION AUX1,AUX2

      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)

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 )



     *                            ) THEN
C  CALCULATE REAL STEP LENGTH TO NEXT SPHERICAL BOUNDARY S2B
C  (DUE TO TRANSFORMING INTO NEW LOCAL FRAME AT THIS POINT)





            ZB2   = MAX( OBSLVL(1), BOUND(IRL)-0.1D0 ) + C(1)



          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






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 ( 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

            AUX1 = BOUND(IRL-1)





              AUX2 = MAX( BOUND(IRL), OBSGLOB )



            DNEAR(NP) = MIN( Z(NP)+AUX1, -Z(NP)-AUX2 )



            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





                BOUNDC = MAX( OBSGLOB, BOUND(IRL) )



            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
# 45580 "corsika.F"
            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
# 45643 "corsika.F"
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 ( NEWOBS .GT. NOBSLV ) THEN

C  TRANSPORT AND ELIMINATE AFTERWARDS
                IDISC = -1
                IRETE = .TRUE.
                RETURN
              ENDIF
            ENDIF
          ENDIF
C  END OF 'PARTICLE GOING DOWNWARD'



        ELSE
C  PARTICLE IS GOING UPWARD OR NEARLY HORIZONTALLY





          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
# 45715 "corsika.F"
              TVAL = ABS( (-(BOUND(IRL-1)+0.1D0) -Z(NP) ) / W(NP) )



          ENDIF
# 45737 "corsika.F"
          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

            AUX1 = BOUND(IRL-1)





C  UPWARD GOING PARTICLE CAN LATER PRODUCE DOWNWARD GOING PARTICLES...
              AUX2    = MAX( BOUND(IRL), OBSGLOB )
# 45770 "corsika.F"
            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
# 45790 "corsika.F"
C  PARTICLE CROSSES DETECTOR ABOVE, TRANSPORT AND DISCARD AFTER STEP
# 45814 "corsika.F"
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
# 45857 "corsika.F"
          ENDIF
C  END OF 'PARTICLE GOING UPWARD'






C  END OF 'PARTICLE MOVES HORIZONTALLY'


        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 1
      ENDIF

      RETURN
      END


*-- 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 PAIRLPM
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





# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"











      COMMON /CRCONSTA/PI,PI2,OB3,TB3,ENEPER,SQRT3
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER,SQRT3
















































      COMMON /CREGSDEB/JCLOCK,NCLOCK,FEGSDB
      INTEGER          JCLOCK,NCLOCK
      LOGICAL          FEGSDB

























# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"

























      COMMON /CRRANDPA/RD,FAC,U1,U2,NSEQ,ISEED,KNOR
      DOUBLE PRECISION RD(3000),FAC,U1,U2



      INTEGER          ISEED(3,10),NSEQ

      LOGICAL          KNOR



# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 45930 "corsika.F" 2

      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


*-- 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
# 46023 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"





























































      COMMON /CREGSDEB/JCLOCK,NCLOCK,FEGSDB
      INTEGER          JCLOCK,NCLOCK
      LOGICAL          FEGSDB

























# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"

























      COMMON /CRRANDPA/RD,FAC,U1,U2,NSEQ,ISEED,KNOR
      DOUBLE PRECISION RD(3000),FAC,U1,U2



      INTEGER          ISEED(3,10),NSEQ

      LOGICAL          KNOR



# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"



      COMMON /CRSTACKE/E,TIM,U,V,W,X,Y,Z,DNEAR,

     *                 WT,


     *                 ZAP,WAP,WA,XXXX,YYYY,


     *                 TSLAN,




     *                 IQ,IGEN,IR,IOBS,LPCTE,NP
      DOUBLE PRECISION E(60),TIM(60),U(60),V(60),W(60),
     *                 X(60),Y(60),Z(60),DNEAR(60)

     *                 ,WT(60)


     *                 ,ZAP(60),WAP(60),WA(60),XXXX(60),YYYY(60)


     *                 ,TSLAN(60)




      INTEGER          IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP



# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"



      COMMON /CRTHRESH/RMSQ,API,TE,THMOLL,AP,AE,UP,UE
      DOUBLE PRECISION RMSQ,API,TE,THMOLL
      REAL             AP,AE,UP,UE











# 4935 "corsika.h"



      COMMON /CRUPHIOT/THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI
      DOUBLE PRECISION THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI





      COMMON /CRUSEFUL/PRM,PRMT2,RMI,VCI,MEDIUM,MEDOLD,IBLOBE
      DOUBLE PRECISION PRM,PRMT2,RMI,VCI
      INTEGER          MEDIUM,MEDOLD,IBLOBE



# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 46023 "corsika.F" 2

      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
# 46119 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"





























































      COMMON /CREGSDEB/JCLOCK,NCLOCK,FEGSDB
      INTEGER          JCLOCK,NCLOCK
      LOGICAL          FEGSDB



























      COMMON /CRELECIN/EKE0,EKE1,XR0,TEFF0,BLCC,XCC,ESIG0,ESIG1,PSIG0,
     *                 PSIG1,EDEDX0,EDEDX1,PDEDX0,PDEDX1,
     *                 EBR10,EBR11,EBR20,EBR21,
     *                 PBR10,PBR11,PBR20,PBR21,PBR30,PBR31,
     *                 TMXS0,TMXS1,ERANG0,
     *                 ERANG1,PRANG0,PRANG1,STERNCOR
      REAL             EKE0,EKE1,XR0,TEFF0,BLCC,XCC,
     *                 ESIG0(500),ESIG1(500),PSIG0(500),PSIG1(500),
     *                 EDEDX0(500),EDEDX1(500),PDEDX0(500),PDEDX1(500),
     *                 EBR10(500),EBR11(500),EBR20(500),EBR21(500),
     *                 PBR10(500),PBR11(500),PBR20(500),PBR21(500),
     *                 PBR30(500),PBR31(500),TMXS0(500),TMXS1(500),
     *                 ERANG0(1),ERANG1(1),PRANG0(1),PRANG1(1),STERNCOR





      COMMON /CREPCONT/EDEP,RATIO,TSTEP,TUSTEP,USTEP,TVSTEP,VSTEP,
     *                 RHOFAC,EOLD,ENEW,EKE,ELKE,BETA2,GLE,TSCAT,
     *                 WCUT,
     *                 IDISC,IROLD,IRNEW
      DOUBLE PRECISION EDEP,RATIO,TSTEP,TUSTEP,USTEP,TVSTEP,VSTEP,
     *                 RHOFAC,EOLD,ENEW, EKE,ELKE,BETA2,GLE,TSCAT,
     *                 WCUT
      INTEGER          IDISC,IROLD,IRNEW

























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"










      COMMON /CRMISC/  DUNIT,RHOR,KMPI,KMPO,NOSCAT,MED,IRAYLR
      DOUBLE PRECISION DUNIT,RHOR(6)
      INTEGER          KMPI,KMPO,NOSCAT,MED(6),IRAYLR(6)



# 4047 "corsika.h"









# 4075 "corsika.h"



      COMMON /CRMULTS/ B0G21,B1G21,G210,G211,G212,
     *                 B0G22,B1G22,G220,G221,G222,
     *                 B0G31,B1G31,G310,G311,G312,
     *                 B0G32,B1G32,G320,G321,G322,
     *                 B0BGB,B1BGB,BGB0,BGB1,BGB2,NBGB
      DOUBLE PRECISION B0G21,B1G21,G210(7),G211(7),G212(7),
     *                 B0G22,B1G22,G220(8),G221(8),G222(8),
     *                 B0G31,B1G31,G310(11),G311(11),G312(11),
     *                 B0G32,B1G32,G320(25),G321(25),G322(25),
     *                 B0BGB,B1BGB,BGB0(8),BGB1(8),BGB2(8)
      INTEGER          NBGB


















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"

























      COMMON /CRRANDPA/RD,FAC,U1,U2,NSEQ,ISEED,KNOR
      DOUBLE PRECISION RD(3000),FAC,U1,U2



      INTEGER          ISEED(3,10),NSEQ

      LOGICAL          KNOR



# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"



      COMMON /CRSTACKE/E,TIM,U,V,W,X,Y,Z,DNEAR,

     *                 WT,


     *                 ZAP,WAP,WA,XXXX,YYYY,


     *                 TSLAN,




     *                 IQ,IGEN,IR,IOBS,LPCTE,NP
      DOUBLE PRECISION E(60),TIM(60),U(60),V(60),W(60),
     *                 X(60),Y(60),Z(60),DNEAR(60)

     *                 ,WT(60)


     *                 ,ZAP(60),WAP(60),WA(60),XXXX(60),YYYY(60)


     *                 ,TSLAN(60)




      INTEGER          IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP



# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"



      COMMON /CRTHRESH/RMSQ,API,TE,THMOLL,AP,AE,UP,UE
      DOUBLE PRECISION RMSQ,API,TE,THMOLL
      REAL             AP,AE,UP,UE











# 4935 "corsika.h"



      COMMON /CRUPHIOT/THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI
      DOUBLE PRECISION THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI





      COMMON /CRUSEFUL/PRM,PRMT2,RMI,VCI,MEDIUM,MEDOLD,IBLOBE
      DOUBLE PRECISION PRM,PRMT2,RMI,VCI
      INTEGER          MEDIUM,MEDOLD,IBLOBE



# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 46119 "corsika.F" 2

      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<IB=',I9)
          IB = NBGB
        ENDIF
        B = BGB0(IB)+BLC*(BGB1(IB)+BLC*BGB2(IB))
      ENDIF
C  NOW GET REDUCING ANGLE=<*CHI-SUB-C*>*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
# 46249 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"



      COMMON /CRAIR/   COMPOS,PROBTA,AVERAW,AVOGDR
      DOUBLE PRECISION COMPOS(3),PROBTA(3),AVERAW,AVOGDR



# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"





























































      COMMON /CREGSDEB/JCLOCK,NCLOCK,FEGSDB
      INTEGER          JCLOCK,NCLOCK
      LOGICAL          FEGSDB

























# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"











      COMMON /CRMUON/  PRRMMU,RMMUT4
      DOUBLE PRECISION PRRMMU,RMMUT4





      COMMON /CRMUPART/AATOM,AMUPAR,BCUT,CMUON,CTAU,CONSTKINE,
     *                 EBYMU,EBYTAU,EE,SE,VFRAC,VMAX,VMIN,ZATOM,
     *                 MT,FMUBRM,FMUNUC,FMUORG






      DOUBLE PRECISION AMUPAR(0:18),BCUT,CMUON(11),CTAU(11),


     *                 AATOM,CONSTKINE,EBYMU,EBYTAU,EE,SE,
     *                 VFRAC,VMAX,VMIN,ZATOM
      INTEGER          MT
      LOGICAL          FMUBRM,FMUNUC,FMUORG



# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"











      COMMON /CRNKGSUB/XXOLD,YYOLD,ZZOLD
      DOUBLE PRECISION XXOLD,YYOLD,ZZOLD



# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"



      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL



# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"



      COMMON /CRPOLAR/ POLART,POLARF
      DOUBLE PRECISION POLART,POLARF




















      COMMON /CRRANDPA/RD,FAC,U1,U2,NSEQ,ISEED,KNOR
      DOUBLE PRECISION RD(3000),FAC,U1,U2



      INTEGER          ISEED(3,10),NSEQ

      LOGICAL          KNOR



# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"



      COMMON /CRSTACKE/E,TIM,U,V,W,X,Y,Z,DNEAR,

     *                 WT,


     *                 ZAP,WAP,WA,XXXX,YYYY,


     *                 TSLAN,




     *                 IQ,IGEN,IR,IOBS,LPCTE,NP
      DOUBLE PRECISION E(60),TIM(60),U(60),V(60),W(60),
     *                 X(60),Y(60),Z(60),DNEAR(60)

     *                 ,WT(60)


     *                 ,ZAP(60),WAP(60),WA(60),XXXX(60),YYYY(60)


     *                 ,TSLAN(60)




      INTEGER          IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP



# 4821 "corsika.h"
















# 4853 "corsika.h"



      COMMON /CRTHNVAR/STACKINT,

     *                 EEPP,ELIM,


     *                 RMAX,RMAX2,
     *                 WMAX,WMAX0,WMAXE,WMAXE0,WMAXEM,

     *                 INT_ICOUNT,MODETHN,THINNING

     *                 ,RLIM,WLIM

      INTEGER          MAXICOUNT
      PARAMETER        (MAXICOUNT = 200000)
# 4883 "corsika.h"
      DOUBLE PRECISION STACKINT(0:16,MAXICOUNT)
# 4892 "corsika.h"
     *                 ,EEPP(MAXICOUNT),ELIM


     *                 ,RMAX,RMAX2
     *                 ,WMAX,WMAX0,WMAXE,WMAXE0,WMAXEM

      INTEGER          INT_ICOUNT,MODETHN
      LOGICAL          THINNING

      LOGICAL           RLIM,WLIM




















# 4935 "corsika.h"



      COMMON /CRUPHIOT/THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI
      DOUBLE PRECISION THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI





      COMMON /CRUSEFUL/PRM,PRMT2,RMI,VCI,MEDIUM,MEDOLD,IBLOBE
      DOUBLE PRECISION PRM,PRMT2,RMI,VCI
      INTEGER          MEDIUM,MEDOLD,IBLOBE



# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 46249 "corsika.F" 2

      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

        SECPAR(13) =  WT(NP)

        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
# 46476 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"





























































      COMMON /CREGSDEB/JCLOCK,NCLOCK,FEGSDB
      INTEGER          JCLOCK,NCLOCK
      LOGICAL          FEGSDB





      COMMON /CRELABCT/ELCUT
      DOUBLE PRECISION ELCUT(4)


















# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"
























      INTEGER          LNGMAX
      PARAMETER        (LNGMAX = 15000)
      INTEGER          TYPE1
      PARAMETER        (TYPE1 = 0)
      INTEGER          TYPE2
      PARAMETER        (TYPE2 = 1)
      INTEGER          TYPE3
      PARAMETER        (TYPE3 = 2)
      INTEGER          TYPE4
      PARAMETER        (TYPE4 = 3)
      COMMON /CRLONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP



     *                ,LLONGI,FLGFIT
# 3961 "corsika.h"
      DOUBLE PRECISION ADLONG(0:LNGMAX,19),AELONG(0:LNGMAX,10),
     *                 APLONG(0:LNGMAX,10),DLONG(0:LNGMAX,19),
     *                 ELONG(0:LNGMAX,10),
     *                 HLONG(0:LNGMAX),PLONG(0:LNGMAX,10),
     *                 SDLONG(0:LNGMAX,19),SELONG(0:LNGMAX,10),
     *                 SPLONG(0:LNGMAX,10),THSTEP,THSTPI




      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT

      COMMON /CRSLANT/ RLONG,THCKRL,CTH,STHCPH,STHSPH,RLOFF
      DOUBLE PRECISION RLONG(0:LNGMAX),THCKRL(0:LNGMAX),
     *                 CTH,STHCPH,STHSPH,RLOFF


















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"











      COMMON /CRMUON/  PRRMMU,RMMUT4
      DOUBLE PRECISION PRRMMU,RMMUT4



# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"



      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL



# 4332 "corsika.h"









# 4354 "corsika.h"



      COMMON /CRPION/  PI0MSQ,PITHR,PICMAS,PI0MAS,AMASK0,AMASKC,AMASPR,
     *                 AMASNT
      DOUBLE PRECISION PI0MSQ,PITHR,PICMAS,PI0MAS,AMASK0,AMASKC,AMASPR,
     *                 AMASNT



# 4383 "corsika.h"



      COMMON /CRPOLAR/ POLART,POLARF
      DOUBLE PRECISION POLART,POLARF


















# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"



      COMMON /CRSTACKE/E,TIM,U,V,W,X,Y,Z,DNEAR,

     *                 WT,


     *                 ZAP,WAP,WA,XXXX,YYYY,


     *                 TSLAN,




     *                 IQ,IGEN,IR,IOBS,LPCTE,NP
      DOUBLE PRECISION E(60),TIM(60),U(60),V(60),W(60),
     *                 X(60),Y(60),Z(60),DNEAR(60)

     *                 ,WT(60)


     *                 ,ZAP(60),WAP(60),WA(60),XXXX(60),YYYY(60)


     *                 ,TSLAN(60)




      INTEGER          IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP



# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"



      COMMON /CRUPHIOT/THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI
      DOUBLE PRECISION THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI











# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 46476 "corsika.F" 2

# 46485 "corsika.F"

      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) .LT. 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

          SECPAR(13) =  WT(NP)


          SECPAR(14) = -ZAP(NP)
          SECPAR(15) =  WAP(NP)
          SECPAR(16) =  WA(NP)
# 46537 "corsika.F"
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

            DLONG(LPCTE(NP),15) = DLONG(LPCTE(NP),15)+E(NP)*1.D-3*WT(NP)



          ENDIF
# 46565 "corsika.F"
        ENDIF
      ELSE
        IF ( LLONGI ) THEN
C  CUTTED ENERGY TO LONGITUDINAL ENERGY SUMS OF MUONS [IN GEV]
C  ENERGY CUT

          DLONG(LPCTE(NP),5) = DLONG(LPCTE(NP),5)+E(NP)*1.D-3*WT(NP)



        ENDIF
# 46592 "corsika.F"
      ENDIF
C  ELIMINATE MUON FROM EGS-STACK
      NP = NP-1

      RETURN
      END

*-- Author :    STANFORD LINEAR ACCELERATOR CENTER
C=======================================================================
C                                STANFORD LINEAR ACCELERATOR CENTER

      SUBROUTINE PAIRLPM( FPASS )



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.

C  ARGUMENT:
C   FPASS  = (LOGICAL) FLAG INDICATING THAT INTERRACTION IS SUPPRESSED

C-----------------------------------------------------------------------

      IMPLICIT NONE
# 46634 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"

















      COMMON /CRBREMPR/PWR2I,DL1,DL2,DL3,DL4,DL5,DL6,DELCM,ALPHI,BPAR,
     *                 DELPOS
      DOUBLE PRECISION PWR2I(60)
      REAL             DL1(6),DL2(6),DL3(6),DL4(6),DL5(6),DL6(6),
     *                 DELCM,ALPHI(2),BPAR(2),DELPOS(2)



# 3705 "corsika.h"





























































      COMMON /CREGSDEB/JCLOCK,NCLOCK,FEGSDB
      INTEGER          JCLOCK,NCLOCK
      LOGICAL          FEGSDB

























# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"

























      COMMON /CRRANDPA/RD,FAC,U1,U2,NSEQ,ISEED,KNOR
      DOUBLE PRECISION RD(3000),FAC,U1,U2



      INTEGER          ISEED(3,10),NSEQ

      LOGICAL          KNOR



# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"



      COMMON /CRSTACKE/E,TIM,U,V,W,X,Y,Z,DNEAR,

     *                 WT,


     *                 ZAP,WAP,WA,XXXX,YYYY,


     *                 TSLAN,




     *                 IQ,IGEN,IR,IOBS,LPCTE,NP
      DOUBLE PRECISION E(60),TIM(60),U(60),V(60),W(60),
     *                 X(60),Y(60),Z(60),DNEAR(60)

     *                 ,WT(60)


     *                 ,ZAP(60),WAP(60),WA(60),XXXX(60),YYYY(60)


     *                 ,TSLAN(60)




      INTEGER          IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP



# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"



      COMMON /CRTHRESH/RMSQ,API,TE,THMOLL,AP,AE,UP,UE
      DOUBLE PRECISION RMSQ,API,TE,THMOLL
      REAL             AP,AE,UP,UE











# 4935 "corsika.h"



      COMMON /CRUPHIOT/THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI
      DOUBLE PRECISION THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI





      COMMON /CRUSEFUL/PRM,PRMT2,RMI,VCI,MEDIUM,MEDOLD,IBLOBE
      DOUBLE PRECISION PRM,PRMT2,RMI,VCI
      INTEGER          MEDIUM,MEDOLD,IBLOBE



# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 46634 "corsika.F" 2

      DOUBLE PRECISION BR,DEL,DELTA,PEIG,PESE1,PESE2,REJF
      INTEGER          LVL,LVL0,LVX

      LOGICAL          FPASS

      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

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

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
# 46767 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"





























































      COMMON /CREGSDEB/JCLOCK,NCLOCK,FEGSDB
      INTEGER          JCLOCK,NCLOCK
      LOGICAL          FEGSDB

























# 3811 "corsika.h"



      COMMON /CREPCONT/EDEP,RATIO,TSTEP,TUSTEP,USTEP,TVSTEP,VSTEP,
     *                 RHOFAC,EOLD,ENEW,EKE,ELKE,BETA2,GLE,TSCAT,
     *                 WCUT,
     *                 IDISC,IROLD,IRNEW
      DOUBLE PRECISION EDEP,RATIO,TSTEP,TUSTEP,USTEP,TVSTEP,VSTEP,
     *                 RHOFAC,EOLD,ENEW, EKE,ELKE,BETA2,GLE,TSCAT,
     *                 WCUT
      INTEGER          IDISC,IROLD,IRNEW

























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"
























      INTEGER          LNGMAX
      PARAMETER        (LNGMAX = 15000)
      INTEGER          TYPE1
      PARAMETER        (TYPE1 = 0)
      INTEGER          TYPE2
      PARAMETER        (TYPE2 = 1)
      INTEGER          TYPE3
      PARAMETER        (TYPE3 = 2)
      INTEGER          TYPE4
      PARAMETER        (TYPE4 = 3)
      COMMON /CRLONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP



     *                ,LLONGI,FLGFIT
# 3961 "corsika.h"
      DOUBLE PRECISION ADLONG(0:LNGMAX,19),AELONG(0:LNGMAX,10),
     *                 APLONG(0:LNGMAX,10),DLONG(0:LNGMAX,19),
     *                 ELONG(0:LNGMAX,10),
     *                 HLONG(0:LNGMAX),PLONG(0:LNGMAX,10),
     *                 SDLONG(0:LNGMAX,19),SELONG(0:LNGMAX,10),
     *                 SPLONG(0:LNGMAX,10),THSTEP,THSTPI




      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT

      COMMON /CRSLANT/ RLONG,THCKRL,CTH,STHCPH,STHSPH,RLOFF
      DOUBLE PRECISION RLONG(0:LNGMAX),THCKRL(0:LNGMAX),
     *                 CTH,STHCPH,STHSPH,RLOFF


















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"











      COMMON /CRPHOTIN/EBINDA,GE0,GE1,GMFP0,GMFP1,GBR10,GBR11,
     *                 GBR20,GBR21,GBR30,GBR31,GBR40,GBR41,
     *                 RCO0,RCO1,RSCT0,RSCT1,COHE0,COHE1,MPGEM,NGR
      REAL             EBINDA,GE0,GE1,GMFP0(500),GMFP1(500),
     *                 GBR10(500),GBR11(500),GBR20(500),GBR21(500),
     *                 GBR30(500),GBR31(500),GBR40(500),GBR41(500),
     *                 RCO0,RCO1,RSCT0(100),RSCT1(100),COHE0(500),
     *                 COHE1(500)
      INTEGER          MPGEM(1),NGR



# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"



      COMMON /CRSTACKE/E,TIM,U,V,W,X,Y,Z,DNEAR,

     *                 WT,


     *                 ZAP,WAP,WA,XXXX,YYYY,


     *                 TSLAN,




     *                 IQ,IGEN,IR,IOBS,LPCTE,NP
      DOUBLE PRECISION E(60),TIM(60),U(60),V(60),W(60),
     *                 X(60),Y(60),Z(60),DNEAR(60)

     *                 ,WT(60)


     *                 ,ZAP(60),WAP(60),WA(60),XXXX(60),YYYY(60)


     *                 ,TSLAN(60)




      INTEGER          IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP



# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"










      COMMON /CRUSEFUL/PRM,PRMT2,RMI,VCI,MEDIUM,MEDOLD,IBLOBE
      DOUBLE PRECISION PRM,PRMT2,RMI,VCI
      INTEGER          MEDIUM,MEDOLD,IBLOBE



# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 46767 "corsika.F" 2

      DOUBLE PRECISION PEIG




      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

        DLONG(LPCTE(NP),2) = DLONG(LPCTE(NP),2) + EDEP*1.D-3*WT(NP)



      ENDIF
# 46818 "corsika.F"
      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
# 46891 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"










      COMMON /CRBOUNDS/ECUT,PCUT,VACDST
      DOUBLE PRECISION ECUT(6),PCUT(6),VACDST



# 3655 "corsika.h"



      COMMON /CRBUFFS/ RUNH,RUNE,EVTH,EVTE,DATAB,ARRAYLONG,LH

     *                 ,WRRUNH,WRRUNE,WREVTH,WREVTE

      INTEGER          MAXBUF,MAXLEN

      PARAMETER        (MAXBUF=39*8)
# 3681 "corsika.h"
      PARAMETER        (MAXLEN=16)
# 3693 "corsika.h"
      REAL             RUNH(MAXBUF),EVTH(MAXBUF),EVTE(MAXBUF),
     *                 RUNE(MAXBUF),DATAB(MAXBUF),ARRAYLONG(MAXBUF)
      INTEGER          LH

      LOGICAL          WRRUNH,WRRUNE,WREVTH,WREVTE

      CHARACTER*4      CRUNH,CRUNE,CEVTH,CEVTE,CLONG
      EQUIVALENCE      (RUNH(1),CRUNH), (RUNE(1),CRUNE)
      EQUIVALENCE      (EVTH(1),CEVTH), (EVTE(1),CEVTE)
      EQUIVALENCE      (ARRAYLONG(1),CLONG)































































      COMMON /CREGSDEB/JCLOCK,NCLOCK,FEGSDB
      INTEGER          JCLOCK,NCLOCK
      LOGICAL          FEGSDB





      COMMON /CRELABCT/ELCUT
      DOUBLE PRECISION ELCUT(4)


















# 3811 "corsika.h"



      COMMON /CREPCONT/EDEP,RATIO,TSTEP,TUSTEP,USTEP,TVSTEP,VSTEP,
     *                 RHOFAC,EOLD,ENEW,EKE,ELKE,BETA2,GLE,TSCAT,
     *                 WCUT,
     *                 IDISC,IROLD,IRNEW
      DOUBLE PRECISION EDEP,RATIO,TSTEP,TUSTEP,USTEP,TVSTEP,VSTEP,
     *                 RHOFAC,EOLD,ENEW, EKE,ELKE,BETA2,GLE,TSCAT,
     *                 WCUT
      INTEGER          IDISC,IROLD,IRNEW



















      COMMON /CRGEOMEGS/ZALTIT,BOUND,OBSLVL,OBSLV2,NEWOBS
      DOUBLE PRECISION ZALTIT,BOUND(6),OBSLVL(20),OBSLV2(20)
      INTEGER          NEWOBS



# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"










      COMMON /CRLAYER/ HBARO,HBAROI
      DOUBLE PRECISION HBARO(6),HBAROI(6)












      INTEGER          LNGMAX
      PARAMETER        (LNGMAX = 15000)
      INTEGER          TYPE1
      PARAMETER        (TYPE1 = 0)
      INTEGER          TYPE2
      PARAMETER        (TYPE2 = 1)
      INTEGER          TYPE3
      PARAMETER        (TYPE3 = 2)
      INTEGER          TYPE4
      PARAMETER        (TYPE4 = 3)
      COMMON /CRLONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP



     *                ,LLONGI,FLGFIT
# 3961 "corsika.h"
      DOUBLE PRECISION ADLONG(0:LNGMAX,19),AELONG(0:LNGMAX,10),
     *                 APLONG(0:LNGMAX,10),DLONG(0:LNGMAX,19),
     *                 ELONG(0:LNGMAX,10),
     *                 HLONG(0:LNGMAX),PLONG(0:LNGMAX,10),
     *                 SDLONG(0:LNGMAX,19),SELONG(0:LNGMAX,10),
     *                 SPLONG(0:LNGMAX,10),THSTEP,THSTPI




      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT

      COMMON /CRSLANT/ RLONG,THCKRL,CTH,STHCPH,STHSPH,RLOFF
      DOUBLE PRECISION RLONG(0:LNGMAX),THCKRL(0:LNGMAX),
     *                 CTH,STHCPH,STHSPH,RLOFF




















      COMMON /CRMEDIA/ RLDU,RLDUI,RHO,RLC,NMED,MSGE,MGE,MSEKE,MEKE,
     *                 MLEKE,MCMFP,MRANGE,IRAYLM
      DOUBLE PRECISION RLDU,RLDUI
      REAL             RHO,RLC
      INTEGER          NMED,MSGE,MGE,MSEKE,MEKE,MLEKE,MCMFP,MRANGE,
     *                 IRAYLM





      COMMON /CRMEDIAC/MEDIA
      CHARACTER        MEDIA*24





      COMMON /CRMISC/  DUNIT,RHOR,KMPI,KMPO,NOSCAT,MED,IRAYLR
      DOUBLE PRECISION DUNIT,RHOR(6)
      INTEGER          KMPI,KMPO,NOSCAT,MED(6),IRAYLR(6)



# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"











      COMMON /CRMUON/  PRRMMU,RMMUT4
      DOUBLE PRECISION PRRMMU,RMMUT4



# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"











      COMMON /CRNKGSUB/XXOLD,YYOLD,ZZOLD
      DOUBLE PRECISION XXOLD,YYOLD,ZZOLD



# 4212 "corsika.h"










      COMMON /CROBSPAR/OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP,
     *                 THETPR,PHIPR,

     *                 CORRXY,







     *                 NOBSLV
      DOUBLE PRECISION OBSLEV(20),THCKOB(20),XOFF(20),YOFF(20),
     *                 HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2)

     *                 ,CORRXY







      INTEGER          NOBSLV



# 4262 "corsika.h"



      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL



# 4332 "corsika.h"











      COMMON /CRPHOTIN/EBINDA,GE0,GE1,GMFP0,GMFP1,GBR10,GBR11,
     *                 GBR20,GBR21,GBR30,GBR31,GBR40,GBR41,
     *                 RCO0,RCO1,RSCT0,RSCT1,COHE0,COHE1,MPGEM,NGR
      REAL             EBINDA,GE0,GE1,GMFP0(500),GMFP1(500),
     *                 GBR10(500),GBR11(500),GBR20(500),GBR21(500),
     *                 GBR30(500),GBR31(500),GBR40(500),GBR41(500),
     *                 RCO0,RCO1,RSCT0(100),RSCT1(100),COHE0(500),
     *                 COHE1(500)
      INTEGER          MPGEM(1),NGR





      COMMON /CRPION/  PI0MSQ,PITHR,PICMAS,PI0MAS,AMASK0,AMASKC,AMASPR,
     *                 AMASNT
      DOUBLE PRECISION PI0MSQ,PITHR,PICMAS,PI0MAS,AMASK0,AMASKC,AMASPR,
     *                 AMASNT



# 4383 "corsika.h"

























      COMMON /CRRANDPA/RD,FAC,U1,U2,NSEQ,ISEED,KNOR
      DOUBLE PRECISION RD(3000),FAC,U1,U2



      INTEGER          ISEED(3,10),NSEQ

      LOGICAL          KNOR



# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"










      COMMON /CRREJECT/AVNREJ,ALTMIN,ANEXP,THICKA,THICKD,CUTLN,EONCUT,

     *                 EFRCTHN,ETHINN,ETHINNG,THINRAT,THINRATH,WEITRAT,
     *                 WEITRATH,EEFRTHN,

     *                 FNPRIM
      DOUBLE PRECISION AVNREJ(20),ALTMIN(20),ANEXP(20),THICKA(20),
     *                 THICKD(20),CUTLN,EONCUT

     *                 ,EFRCTHN,ETHINN,ETHINNG,THINRAT,THINRATH,WEITRAT,
     *                 WEITRATH,EEFRTHN

      LOGICAL          FNPRIM





















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"



      COMMON /CRSTACKE/E,TIM,U,V,W,X,Y,Z,DNEAR,

     *                 WT,


     *                 ZAP,WAP,WA,XXXX,YYYY,


     *                 TSLAN,




     *                 IQ,IGEN,IR,IOBS,LPCTE,NP
      DOUBLE PRECISION E(60),TIM(60),U(60),V(60),W(60),
     *                 X(60),Y(60),Z(60),DNEAR(60)

     *                 ,WT(60)


     *                 ,ZAP(60),WAP(60),WA(60),XXXX(60),YYYY(60)


     *                 ,TSLAN(60)




      INTEGER          IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP



# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"



      COMMON /CRTHRESH/RMSQ,API,TE,THMOLL,AP,AE,UP,UE
      DOUBLE PRECISION RMSQ,API,TE,THMOLL
      REAL             AP,AE,UP,UE





      COMMON /CRTIMLIM/DSTLIM,TIMLIM,LTMLMPR
      DOUBLE PRECISION DSTLIM,TIMLIM
      LOGICAL          LTMLMPR



# 4935 "corsika.h"



      COMMON /CRUPHIOT/THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI
      DOUBLE PRECISION THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI





      COMMON /CRUSEFUL/PRM,PRMT2,RMI,VCI,MEDIUM,MEDOLD,IBLOBE
      DOUBLE PRECISION PRM,PRMT2,RMI,VCI
      INTEGER          MEDIUM,MEDOLD,IBLOBE



# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 46891 "corsika.F" 2

      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
# 46907 "corsika.F"
      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


      DOUBLE PRECISION ZNEWUP
# 46923 "corsika.F"
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


      DOUBLE PRECISION ZAPOLD,XXXOLD,YYYOLD,SPEED,SPEED0,TDIFF
      INTEGER          MCOUNT


      DOUBLE PRECISION AUXIL1,AUXOLD,AUXNEW,THCKSI,T1
      EXTERNAL         THCKSI





      DOUBLE PRECISION EKENP,EKENP1,EKG


      LOGICAL          FPASS

      SAVE
      EXTERNAL         THICK

      DATA             MCOUNT / 0 /




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





      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) .LT. WCUT ) THEN



        IDISC = 1
        IRETC = .FALSE.
        GOTO 1000
      ENDIF
      GLE    = LOG( PEIG )
# 47062 "corsika.F"

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
# 47089 "corsika.F"
C  BEGINNING OF TRACKING STEP
      pnt1id =  1
      pnt1gen = igen(np)

      pnt1x  =  XXXX(NP)
      pnt1y  = -YYYY(NP)
      pnt1z  = -ZAP(NP)






      pnt1d  =  TSLAN(NP)



      pnt1t  =  TIM(NP)
      pnt1e  =  PEIG * 0.001D0

      pnt1w  =  WT(NP)







      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)

      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 )

          W(NP) = MAX( -1.D0, W(NP) )

        ENDIF
C  KILL HORIZONTAL OR UPWARD GOING PARTICLES

        IF ( W(NP) .LT. 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     ( W(NP) .GT. 0.D0 ) THEN



            USTEP = -(Z(NP)+OBSLVL(1))/W(NP)
# 47260 "corsika.F"
        ELSEIF ( W(NP) .LT. 0.D0 ) THEN







            IF ( FEGSDB ) WRITE(MDEBUG,*)'PHOTON: UPWARD GOING PARTICL'
     *        ,'E SHOULD NOT REACH DETECTOR !'

            IDISC = 1
            IRETC = .FALSE.
            GOTO 1000



        ELSE
C  HORIZONTAL MOVEMENT
          IDISC = 1
          IRETC = .FALSE.
          GOTO 1000
        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






      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 )

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

      X(NP)   = X(NP)+U(NP)*USTEP
      Y(NP)   = Y(NP)+V(NP)*USTEP
      Z(NP)   = Z(NP)+W(NP)*USTEP

      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 )

        W(NP)     = MAX( -1.D0, W(NP) )

C  KILL HORIZONTAL OR UPWARD GOING PARTICLES

        IF ( W(NP) .LT. 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

# 47532 "corsika.F"
C  ADD GAMMAS TO THE LONGITUDINAL DEVELOPMENT





        AUXNEW = XXXX(NP)*STHCPH - YYYY(NP)*STHSPH + ZAP(NP)*CTH + RLOFF
        AUXOLD = XXXOLD *STHCPH - YYYOLD *STHSPH + ZAPOLD *CTH + RLOFF






C  END OF TRACKING STEP
        pnt2id =  1
        pnt2gen=  igen(np)

        pnt2x  =  XXXX(NP)
        pnt2y  = -YYYY(NP)
        pnt2z  = -ZAP(NP)






        pnt2d  =  THCKSI( AUXNEW )



        pnt2t  =  TIM(NP)
        pnt2e  =  PEIG * 0.001D0

        pnt2w  =  WT(NP)






        if(WREVTH .AND. pnt1w.gt.0.d0.and.pnt2w.gt.0.d0)
     &  call track(pnt1x, pnt2x)

      IF ( LLONGI ) THEN

C  FIND FIRST THE EQUIVALENT LEVELS

C  IF STARTING POINT BEYOND FURTHEST LEVEL THEN DON''T CHECK
        IF ( RLONG(NSTEP) .GT. AUXOLD ) THEN
          T1    = TSLAN(NP)




          LPCT1 = LPCTE(NP)


          IF     ( AUXNEW .GT. AUXOLD ) THEN
C  FORWARD MOVING PARTICLE





C  Z NEW IS PROBABLY ONLY LITTLE BELOW Z OLD, DO INCREMENTAL SEARCH

           DO  I1 = LPCT1, NSTEP+1
             IF ( RLONG(I1) .GT. AUXNEW ) GOTO 6003




           ENDDO
           I1 = NSTEP + 1
 6003      CONTINUE
           LPCT2 = I1 - 1
C  STORE END POINT AS POSSIBLE STARTPOINT OF NEXT TRACK
           LPCTE(NP) = LPCT2 + 1

           AUXNEW    = MIN( AUXNEW, RLONG(NSTEP+1) )
           TSLAN(NP) = THCKSI( AUXNEW )

C  ARE WE AT OBSERVATION LEVEL OR ATMOSPHERIC BOUNDARY?
           IF ( IDISC .LT. 0 ) LPCT2 = LPCT2+1
           DO  I = LPCT1, LPCT2

             PLONG(I,1) = PLONG(I,1) + WT(NP)
             ELONG(I,1) = ELONG(I,1) + E(NP) * 1.D-3 * WT(NP)




           ENDDO


          ELSEIF ( AUXNEW .LT. AUXOLD ) THEN
C  BACKWARD MOVING PARTICLE




C  Z_NEW IS PROBABLY ONLY LITTLE ABOVE Z_OLD: INCREMENTAL SEARCH
            DO  I1 = LPCT1-1, 0, -1

              IF ( RLONG(I1) .LE. AUXNEW ) GOTO 6004



            ENDDO
            I1 = 0
 6004       CONTINUE
            LPCT2 = MAX( I1, 0 )
            LPCTE(NP) = LPCT2 + 1

            AUXNEW    = MIN( AUXNEW, RLONG(NSTEP+1) )
            TSLAN(NP) = THCKSI( AUXNEW )

            DO  I = LPCT2+1, LPCT1-1

              PLONG(I,1) = PLONG(I,1) + WT(NP)
              ELONG(I,1) = ELONG(I,1) + E(NP) * 1.D-3 * WT(NP)




            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



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 ( 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  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




          CALL AUSGAB



        IOBS(NP) = NEWOBS

      ELSEIF ( NEWOBS .LT. IOBS(NP) ) THEN
        IOBS(NP) = NEWOBS




          CALL AUSGAB




      ENDIF

      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

      IF ( IDISC .LT. 0 ) THEN
        IRETC = .TRUE.
        IF ( FNPRIM )  THEN

C  ADD ENERGY OF PARTICLE LEAVING THE ATMOSPHERE  TO DLONG
C  AND JUMP TO END OF ROUTINE
          IF ( IDISC .EQ. -2 ) GOTO 1000

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





        ENDIF
        IF ( FIX1I ) THEN
C  IF HEIGHT OF FIRST INTERACTION IS FIXED, TAKE STARTING ANGLES OF
C  PRIMARY PARTICLE
          Z(1) = -FIXHEI
          NP   = 1





          LPCTE(1)  = MIN( NSTEP, INT( THICK( FIXHEI )*THSTPI ) + 1 )

          DNEAR(NP) = 0.D0
          U(1) =  SECPAR(3)
          V(1) = -SECPAR(4)
          W(1) =  SECPAR(2)
        ENDIF

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

          AUXIL1   = XXX*STHCPH - YYY*STHSPH + ZAP(NP)*CTH + RLOFF
          TSLAN(1) = THCKSI( AUXIL1 )
          LPCTE(1) = MIN( NSTEP+1, INT( TSLAN(1)*THSTPI ) + 1 )

        ENDIF
C  STORE COORDINATES IN THE DETECTOR SYSTEM
        XXXX(1) = XXX
        YYYY(1) = YYY

        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)

        PRMPAR(14) = -ZAP(1)
        PRMPAR(16) = WA(1)
        PRMPAR(7)  = XXXX(1)
        PRMPAR(8)  = -YYYY(1)
# 47872 "corsika.F"
C  WREVTH SIGNALS THAT EVTH HAS BEEN WRITTEN OUT
        WREVTH = .TRUE.
# 47887 "corsika.F"
        CALL TOBUF( EVTH,0 )
# 47898 "corsika.F"
        IF ( .NOT. TMARGIN ) THEN
          TIM(1) = 0.D0
        ENDIF
# 47911 "corsika.F"
        WT(1)  = 1.D0

        FNPRIM = .TRUE.
        IF ( FPRINT ) THEN
          WRITE(KMPO,*)' FIRST INTERACTION AT ',ABS(EVTH(7)*0.01D0),
     *                 ' M ALTITUDE'
        ENDIF




C  FILL CURPAR TO UPDATE PRMPAR AFTER BOX3 CALL FOR PRIMARY PARTICLE 
        DO  I = 5, 8
          CURPAR(I) = PRMPAR(I)
        ENDDO

        CURPAR(14) = PRMPAR(14)
        CURPAR(16) = PRMPAR(16)
# 47939 "corsika.F"
        IF ( IDISC .LT. 0 ) THEN
C  OBVIOUSLY THE PRIMARY HAS PASSED THROUGH TOTAL ATMOSPHERE.

C  ADD ENERGY OF PARTICLE LEAVING THE ATMOSPHERE  TO DLONG
C  AND JUMP TO END OF ROUTINE
          IF ( IDISC .EQ. -2 ) GOTO 1000

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 ( RD(1) .GE. GBR4  .AND.  E(NP) .GT. PRMT2 ) THEN
C  E+E- PAIR FORMATION

        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
# 47993 "corsika.F"
        RETURN
      ENDIF

      GBR3 = GBR31(LGLE)*GLE+GBR30(LGLE)



      IF ( RD(1) .GE. GBR3 ) THEN
C  COMPTON SCATTERING
        CALL COMPT

        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
# 48027 "corsika.F"
        IF ( IQ(NP) .NE. 1 ) RETURN
        GOTO 1060
      ENDIF

      GBR1 = GBR11(LGLE)*GLE+GBR10(LGLE)



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 ( 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) .LT. 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]

        DLONG(LPCTE(NP),1) = DLONG(LPCTE(NP),1) + EDEP * 1.D-3 * WT(NP)



      ENDIF
# 48111 "corsika.F"
      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

          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)






        ENDIF
      ENDIF
# 48163 "corsika.F"

 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
# 48209 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"



      COMMON /CRBUFFS/ RUNH,RUNE,EVTH,EVTE,DATAB,ARRAYLONG,LH

     *                 ,WRRUNH,WRRUNE,WREVTH,WREVTE

      INTEGER          MAXBUF,MAXLEN

      PARAMETER        (MAXBUF=39*8)
# 3681 "corsika.h"
      PARAMETER        (MAXLEN=16)
# 3693 "corsika.h"
      REAL             RUNH(MAXBUF),EVTH(MAXBUF),EVTE(MAXBUF),
     *                 RUNE(MAXBUF),DATAB(MAXBUF),ARRAYLONG(MAXBUF)
      INTEGER          LH

      LOGICAL          WRRUNH,WRRUNE,WREVTH,WREVTE

      CHARACTER*4      CRUNH,CRUNE,CEVTH,CEVTE,CLONG
      EQUIVALENCE      (RUNH(1),CRUNH), (RUNE(1),CRUNE)
      EQUIVALENCE      (EVTH(1),CEVTH), (EVTE(1),CEVTE)
      EQUIVALENCE      (ARRAYLONG(1),CLONG)































































      COMMON /CREGSDEB/JCLOCK,NCLOCK,FEGSDB
      INTEGER          JCLOCK,NCLOCK
      LOGICAL          FEGSDB

























# 3811 "corsika.h"

# 3824 "corsika.h"










      COMMON /CRGENER/ GEN,ALEVEL
      DOUBLE PRECISION GEN,ALEVEL











# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"
























      INTEGER          LNGMAX
      PARAMETER        (LNGMAX = 15000)
      INTEGER          TYPE1
      PARAMETER        (TYPE1 = 0)
      INTEGER          TYPE2
      PARAMETER        (TYPE2 = 1)
      INTEGER          TYPE3
      PARAMETER        (TYPE3 = 2)
      INTEGER          TYPE4
      PARAMETER        (TYPE4 = 3)
      COMMON /CRLONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP



     *                ,LLONGI,FLGFIT
# 3961 "corsika.h"
      DOUBLE PRECISION ADLONG(0:LNGMAX,19),AELONG(0:LNGMAX,10),
     *                 APLONG(0:LNGMAX,10),DLONG(0:LNGMAX,19),
     *                 ELONG(0:LNGMAX,10),
     *                 HLONG(0:LNGMAX),PLONG(0:LNGMAX,10),
     *                 SDLONG(0:LNGMAX,19),SELONG(0:LNGMAX,10),
     *                 SPLONG(0:LNGMAX,10),THSTEP,THSTPI




      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT

      COMMON /CRSLANT/ RLONG,THCKRL,CTH,STHCPH,STHSPH,RLOFF
      DOUBLE PRECISION RLONG(0:LNGMAX),THCKRL(0:LNGMAX),
     *                 CTH,STHCPH,STHSPH,RLOFF


















# 4005 "corsika.h"
















# 4047 "corsika.h"



      COMMON /CRMULT/  EKINL,MSMM,MULTMA,MULTOT
      DOUBLE PRECISION EKINL
      INTEGER          MSMM,MULTMA(40,13),MULTOT(40,13)



# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"











      COMMON /CRNKGSUB/XXOLD,YYOLD,ZZOLD
      DOUBLE PRECISION XXOLD,YYOLD,ZZOLD



# 4212 "corsika.h"








# 4248 "corsika.h"








      COMMON /CRPAM/   PAMA,SIGNUM,RESTMS,DECTIM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000),
     *                 DECTIM(200)






      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL



# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"

























      COMMON /CRRANDPA/RD,FAC,U1,U2,NSEQ,ISEED,KNOR
      DOUBLE PRECISION RD(3000),FAC,U1,U2



      INTEGER          ISEED(3,10),NSEQ

      LOGICAL          KNOR



# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"



      COMMON /CRSTACKE/E,TIM,U,V,W,X,Y,Z,DNEAR,

     *                 WT,


     *                 ZAP,WAP,WA,XXXX,YYYY,


     *                 TSLAN,




     *                 IQ,IGEN,IR,IOBS,LPCTE,NP
      DOUBLE PRECISION E(60),TIM(60),U(60),V(60),W(60),
     *                 X(60),Y(60),Z(60),DNEAR(60)

     *                 ,WT(60)


     *                 ,ZAP(60),WAP(60),WA(60),XXXX(60),YYYY(60)


     *                 ,TSLAN(60)




      INTEGER          IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP



# 4821 "corsika.h"
















# 4853 "corsika.h"



      COMMON /CRTHNVAR/STACKINT,

     *                 EEPP,ELIM,


     *                 RMAX,RMAX2,
     *                 WMAX,WMAX0,WMAXE,WMAXE0,WMAXEM,

     *                 INT_ICOUNT,MODETHN,THINNING

     *                 ,RLIM,WLIM

      INTEGER          MAXICOUNT
      PARAMETER        (MAXICOUNT = 200000)
# 4883 "corsika.h"
      DOUBLE PRECISION STACKINT(0:16,MAXICOUNT)
# 4892 "corsika.h"
     *                 ,EEPP(MAXICOUNT),ELIM


     *                 ,RMAX,RMAX2
     *                 ,WMAX,WMAX0,WMAXE,WMAXE0,WMAXEM

      INTEGER          INT_ICOUNT,MODETHN
      LOGICAL          THINNING

      LOGICAL           RLIM,WLIM




















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 48209 "corsika.F" 2

      DOUBLE PRECISION ENERN,PEIG,REGPAR(0:MAXLEN),REGGEN,REGLVL
      DOUBLE PRECISION AUXIL,ECMVM,VMFRAC



      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)

      SECPAR(13) =  WT(NP)


      SECPAR(14) = -ZAP(NP)
      SECPAR(15) =  WAP(NP)
      SECPAR(16) =  WA(NP)
# 48250 "corsika.F"
      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)



      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 )
# 48322 "corsika.F"
        IF ( FEGSDB .OR. DEBUG ) WRITE(MDEBUG,*) 'PIGEN : VMFRAC,RD=',
     *                              SNGL(VMFRAC),SNGL(RD(1))
C  WE TAKE INRO ACCOUNT THE PRODUCTION OF PHI MESON WITH RATIO
C  OMEGA : PHI = 0.4 : 0.6    (SEE SUBROUTINE RHOGEN)
        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)







          GEN    =  IGEN(NP)
          ALEVEL = -Z(NP)
          EKINL  =  CURPAR(1)

          CURPAR(13) = WT(NP)


          CURPAR(14) = -ZAP(NP)
          SECPAR(14) = -ZAP(NP)
          CURPAR(15) =  WAP(NP)
          SECPAR(15) =  WAP(NP)
          CURPAR(16) =  WA(NP)
          SECPAR(16) =  WA(NP)
# 48378 "corsika.F"
          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)



      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
# 48439 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"





























































      COMMON /CREGSDEB/JCLOCK,NCLOCK,FEGSDB
      INTEGER          JCLOCK,NCLOCK
      LOGICAL          FEGSDB





      COMMON /CRELABCT/ELCUT
      DOUBLE PRECISION ELCUT(4)


















# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"
























      INTEGER          LNGMAX
      PARAMETER        (LNGMAX = 15000)
      INTEGER          TYPE1
      PARAMETER        (TYPE1 = 0)
      INTEGER          TYPE2
      PARAMETER        (TYPE2 = 1)
      INTEGER          TYPE3
      PARAMETER        (TYPE3 = 2)
      INTEGER          TYPE4
      PARAMETER        (TYPE4 = 3)
      COMMON /CRLONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP



     *                ,LLONGI,FLGFIT
# 3961 "corsika.h"
      DOUBLE PRECISION ADLONG(0:LNGMAX,19),AELONG(0:LNGMAX,10),
     *                 APLONG(0:LNGMAX,10),DLONG(0:LNGMAX,19),
     *                 ELONG(0:LNGMAX,10),
     *                 HLONG(0:LNGMAX),PLONG(0:LNGMAX,10),
     *                 SDLONG(0:LNGMAX,19),SELONG(0:LNGMAX,10),
     *                 SPLONG(0:LNGMAX,10),THSTEP,THSTPI




      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT

      COMMON /CRSLANT/ RLONG,THCKRL,CTH,STHCPH,STHSPH,RLOFF
      DOUBLE PRECISION RLONG(0:LNGMAX),THCKRL(0:LNGMAX),
     *                 CTH,STHCPH,STHSPH,RLOFF


















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"








      COMMON /CRPAM/   PAMA,SIGNUM,RESTMS,DECTIM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000),
     *                 DECTIM(200)






      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL



# 4332 "corsika.h"









# 4354 "corsika.h"



      COMMON /CRPION/  PI0MSQ,PITHR,PICMAS,PI0MAS,AMASK0,AMASKC,AMASPR,
     *                 AMASNT
      DOUBLE PRECISION PI0MSQ,PITHR,PICMAS,PI0MAS,AMASK0,AMASKC,AMASPR,
     *                 AMASNT



# 4383 "corsika.h"

























      COMMON /CRRANDPA/RD,FAC,U1,U2,NSEQ,ISEED,KNOR
      DOUBLE PRECISION RD(3000),FAC,U1,U2



      INTEGER          ISEED(3,10),NSEQ

      LOGICAL          KNOR



# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"










      COMMON /CRREJECT/AVNREJ,ALTMIN,ANEXP,THICKA,THICKD,CUTLN,EONCUT,

     *                 EFRCTHN,ETHINN,ETHINNG,THINRAT,THINRATH,WEITRAT,
     *                 WEITRATH,EEFRTHN,

     *                 FNPRIM
      DOUBLE PRECISION AVNREJ(20),ALTMIN(20),ANEXP(20),THICKA(20),
     *                 THICKD(20),CUTLN,EONCUT

     *                 ,EFRCTHN,ETHINN,ETHINNG,THINRAT,THINRATH,WEITRAT,
     *                 WEITRATH,EEFRTHN

      LOGICAL          FNPRIM





















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"



      COMMON /CRSTACKE/E,TIM,U,V,W,X,Y,Z,DNEAR,

     *                 WT,


     *                 ZAP,WAP,WA,XXXX,YYYY,


     *                 TSLAN,




     *                 IQ,IGEN,IR,IOBS,LPCTE,NP
      DOUBLE PRECISION E(60),TIM(60),U(60),V(60),W(60),
     *                 X(60),Y(60),Z(60),DNEAR(60)

     *                 ,WT(60)


     *                 ,ZAP(60),WAP(60),WA(60),XXXX(60),YYYY(60)


     *                 ,TSLAN(60)




      INTEGER          IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP



# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"



      COMMON /CRUPHIOT/THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI
      DOUBLE PRECISION THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI











# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 48439 "corsika.F" 2

      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
# 48452 "corsika.F"
      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

# 48480 "corsika.F"
      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







      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) .GE. 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

            SECPAR(13) =  WT(NP)
# 48659 "corsika.F"
            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)

     *                             + (E(NP)-AMASS4) * 1.D-3 * WT(NP)



            ENDIF
# 48686 "corsika.F"
          ENDIF
        ELSE
          IF ( LLONGI ) THEN
C  CUTTED ENERGY TO LONGITUDINAL ENERGY SUMS OF NUCLEON [IN GEV]
            DLONG(LPCTE(NP),7) = DLONG(LPCTE(NP),7)

     *                             + (E(NP)-AMASS4) * 1.D-3 * WT(NP)



          ENDIF
# 48713 "corsika.F"
        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
# 48759 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"





























































      COMMON /CREGSDEB/JCLOCK,NCLOCK,FEGSDB
      INTEGER          JCLOCK,NCLOCK
      LOGICAL          FEGSDB





      COMMON /CRELABCT/ELCUT
      DOUBLE PRECISION ELCUT(4)


















# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"
























      INTEGER          LNGMAX
      PARAMETER        (LNGMAX = 15000)
      INTEGER          TYPE1
      PARAMETER        (TYPE1 = 0)
      INTEGER          TYPE2
      PARAMETER        (TYPE2 = 1)
      INTEGER          TYPE3
      PARAMETER        (TYPE3 = 2)
      INTEGER          TYPE4
      PARAMETER        (TYPE4 = 3)
      COMMON /CRLONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP



     *                ,LLONGI,FLGFIT
# 3961 "corsika.h"
      DOUBLE PRECISION ADLONG(0:LNGMAX,19),AELONG(0:LNGMAX,10),
     *                 APLONG(0:LNGMAX,10),DLONG(0:LNGMAX,19),
     *                 ELONG(0:LNGMAX,10),
     *                 HLONG(0:LNGMAX),PLONG(0:LNGMAX,10),
     *                 SDLONG(0:LNGMAX,19),SELONG(0:LNGMAX,10),
     *                 SPLONG(0:LNGMAX,10),THSTEP,THSTPI




      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT

      COMMON /CRSLANT/ RLONG,THCKRL,CTH,STHCPH,STHSPH,RLOFF
      DOUBLE PRECISION RLONG(0:LNGMAX),THCKRL(0:LNGMAX),
     *                 CTH,STHCPH,STHSPH,RLOFF


















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"








      COMMON /CRPAM/   PAMA,SIGNUM,RESTMS,DECTIM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000),
     *                 DECTIM(200)






      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL



# 4332 "corsika.h"









# 4354 "corsika.h"



      COMMON /CRPION/  PI0MSQ,PITHR,PICMAS,PI0MAS,AMASK0,AMASKC,AMASPR,
     *                 AMASNT
      DOUBLE PRECISION PI0MSQ,PITHR,PICMAS,PI0MAS,AMASK0,AMASKC,AMASPR,
     *                 AMASNT



# 4383 "corsika.h"

























      COMMON /CRRANDPA/RD,FAC,U1,U2,NSEQ,ISEED,KNOR
      DOUBLE PRECISION RD(3000),FAC,U1,U2



      INTEGER          ISEED(3,10),NSEQ

      LOGICAL          KNOR



# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"










      COMMON /CRREJECT/AVNREJ,ALTMIN,ANEXP,THICKA,THICKD,CUTLN,EONCUT,

     *                 EFRCTHN,ETHINN,ETHINNG,THINRAT,THINRATH,WEITRAT,
     *                 WEITRATH,EEFRTHN,

     *                 FNPRIM
      DOUBLE PRECISION AVNREJ(20),ALTMIN(20),ANEXP(20),THICKA(20),
     *                 THICKD(20),CUTLN,EONCUT

     *                 ,EFRCTHN,ETHINN,ETHINNG,THINRAT,THINRATH,WEITRAT,
     *                 WEITRATH,EEFRTHN

      LOGICAL          FNPRIM





















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"



      COMMON /CRSTACKE/E,TIM,U,V,W,X,Y,Z,DNEAR,

     *                 WT,


     *                 ZAP,WAP,WA,XXXX,YYYY,


     *                 TSLAN,




     *                 IQ,IGEN,IR,IOBS,LPCTE,NP
      DOUBLE PRECISION E(60),TIM(60),U(60),V(60),W(60),
     *                 X(60),Y(60),Z(60),DNEAR(60)

     *                 ,WT(60)


     *                 ,ZAP(60),WAP(60),WA(60),XXXX(60),YYYY(60)


     *                 ,TSLAN(60)




      INTEGER          IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP



# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"



      COMMON /CRUPHIOT/THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI
      DOUBLE PRECISION THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI











# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 48759 "corsika.F" 2

      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
# 48778 "corsika.F"
      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

# 48806 "corsika.F"
      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







 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) .GE. 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

          SECPAR(13) =  WT(NP)
# 49021 "corsika.F"
          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)

     *                             + (E(NP)-AMASS5) * 1.D-3 * WT(NP)



          ENDIF
# 49049 "corsika.F"
        ENDIF
      ELSE
        IF ( LLONGI ) THEN
C  CUTTED ENERGY TO LONGITUDINAL ENERGY [IN GEV]
C  ENERGY CUT
          DLONG(LPCTE(NP),7) = DLONG(LPCTE(NP),7)

     *                             + (E(NP)-AMASS5) * 1.D-3 * WT(NP)



        ENDIF
# 49077 "corsika.F"
      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
# 49120 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"





























































      COMMON /CREGSDEB/JCLOCK,NCLOCK,FEGSDB
      INTEGER          JCLOCK,NCLOCK
      LOGICAL          FEGSDB





      COMMON /CRELABCT/ELCUT
      DOUBLE PRECISION ELCUT(4)


















# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"
























      INTEGER          LNGMAX
      PARAMETER        (LNGMAX = 15000)
      INTEGER          TYPE1
      PARAMETER        (TYPE1 = 0)
      INTEGER          TYPE2
      PARAMETER        (TYPE2 = 1)
      INTEGER          TYPE3
      PARAMETER        (TYPE3 = 2)
      INTEGER          TYPE4
      PARAMETER        (TYPE4 = 3)
      COMMON /CRLONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP



     *                ,LLONGI,FLGFIT
# 3961 "corsika.h"
      DOUBLE PRECISION ADLONG(0:LNGMAX,19),AELONG(0:LNGMAX,10),
     *                 APLONG(0:LNGMAX,10),DLONG(0:LNGMAX,19),
     *                 ELONG(0:LNGMAX,10),
     *                 HLONG(0:LNGMAX),PLONG(0:LNGMAX,10),
     *                 SDLONG(0:LNGMAX,19),SELONG(0:LNGMAX,10),
     *                 SPLONG(0:LNGMAX,10),THSTEP,THSTPI




      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT

      COMMON /CRSLANT/ RLONG,THCKRL,CTH,STHCPH,STHSPH,RLOFF
      DOUBLE PRECISION RLONG(0:LNGMAX),THCKRL(0:LNGMAX),
     *                 CTH,STHCPH,STHSPH,RLOFF


















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"











      COMMON /CRMUON/  PRRMMU,RMMUT4
      DOUBLE PRECISION PRRMMU,RMMUT4



# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"



      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL



# 4332 "corsika.h"









# 4354 "corsika.h"



      COMMON /CRPION/  PI0MSQ,PITHR,PICMAS,PI0MAS,AMASK0,AMASKC,AMASPR,
     *                 AMASNT
      DOUBLE PRECISION PI0MSQ,PITHR,PICMAS,PI0MAS,AMASK0,AMASKC,AMASPR,
     *                 AMASNT



# 4383 "corsika.h"



      COMMON /CRPOLAR/ POLART,POLARF
      DOUBLE PRECISION POLART,POLARF


















# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"



      COMMON /CRSTACKE/E,TIM,U,V,W,X,Y,Z,DNEAR,

     *                 WT,


     *                 ZAP,WAP,WA,XXXX,YYYY,


     *                 TSLAN,




     *                 IQ,IGEN,IR,IOBS,LPCTE,NP
      DOUBLE PRECISION E(60),TIM(60),U(60),V(60),W(60),
     *                 X(60),Y(60),Z(60),DNEAR(60)

     *                 ,WT(60)


     *                 ,ZAP(60),WAP(60),WA(60),XXXX(60),YYYY(60)


     *                 ,TSLAN(60)




      INTEGER          IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP



# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"



      COMMON /CRUPHIOT/THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI
      DOUBLE PRECISION THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI











# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 49120 "corsika.F" 2

      DOUBLE PRECISION AMASS,CUT,FAC1,FAC2
# 49130 "corsika.F"
      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) .GE. 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

        SECPAR(13) =  WT(NP)


        SECPAR(14) = -ZAP(NP)
        SECPAR(15) =  WAP(NP)
        SECPAR(16) =  WA(NP)
# 49195 "corsika.F"
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

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






        ENDIF
# 49237 "corsika.F"
      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%)
CC   GAMMA + NUCLEON  -----> OMEGA + NUCLEON  (10%) WITHOUT PHI PRODUCT.
C    GAMMA + NUCLEON  -----> OMEGA + NUCLEON  ( 4%)
C    GAMMA + NUCLEON  -----> PHI + NUCLEON    (6%)
Cc HIGHER MASS VECTOR MESONS ARE OMITTED. THE RATIO FOR PRODUCTION
Cc OF RHO AND OMEGA IS ASSUMED TO BE 9:1 (WITHOUT PHI)
C  WE ASSUME PRODUCTION OF RHO, OMEGA, AND PHI WITH 9:0.4:0.6
C  LITERATURE: M.M. BLOCK ET AL., arXiv hep/ph/0003226 
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
# 49291 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"





























































      COMMON /CREGSDEB/JCLOCK,NCLOCK,FEGSDB
      INTEGER          JCLOCK,NCLOCK
      LOGICAL          FEGSDB





      COMMON /CRELABCT/ELCUT
      DOUBLE PRECISION ELCUT(4)


















# 3811 "corsika.h"

# 3824 "corsika.h"










      COMMON /CRGENER/ GEN,ALEVEL
      DOUBLE PRECISION GEN,ALEVEL











# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"
























      INTEGER          LNGMAX
      PARAMETER        (LNGMAX = 15000)
      INTEGER          TYPE1
      PARAMETER        (TYPE1 = 0)
      INTEGER          TYPE2
      PARAMETER        (TYPE2 = 1)
      INTEGER          TYPE3
      PARAMETER        (TYPE3 = 2)
      INTEGER          TYPE4
      PARAMETER        (TYPE4 = 3)
      COMMON /CRLONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP



     *                ,LLONGI,FLGFIT
# 3961 "corsika.h"
      DOUBLE PRECISION ADLONG(0:LNGMAX,19),AELONG(0:LNGMAX,10),
     *                 APLONG(0:LNGMAX,10),DLONG(0:LNGMAX,19),
     *                 ELONG(0:LNGMAX,10),
     *                 HLONG(0:LNGMAX),PLONG(0:LNGMAX,10),
     *                 SDLONG(0:LNGMAX,19),SELONG(0:LNGMAX,10),
     *                 SPLONG(0:LNGMAX,10),THSTEP,THSTPI




      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT

      COMMON /CRSLANT/ RLONG,THCKRL,CTH,STHCPH,STHSPH,RLOFF
      DOUBLE PRECISION RLONG(0:LNGMAX),THCKRL(0:LNGMAX),
     *                 CTH,STHCPH,STHSPH,RLOFF


















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"








      COMMON /CRPAM/   PAMA,SIGNUM,RESTMS,DECTIM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000),
     *                 DECTIM(200)






      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL



# 4332 "corsika.h"









# 4354 "corsika.h"



      COMMON /CRPION/  PI0MSQ,PITHR,PICMAS,PI0MAS,AMASK0,AMASKC,AMASPR,
     *                 AMASNT
      DOUBLE PRECISION PI0MSQ,PITHR,PICMAS,PI0MAS,AMASK0,AMASKC,AMASPR,
     *                 AMASNT



# 4383 "corsika.h"



      COMMON /CRPOLAR/ POLART,POLARF
      DOUBLE PRECISION POLART,POLARF




















      COMMON /CRRANDPA/RD,FAC,U1,U2,NSEQ,ISEED,KNOR
      DOUBLE PRECISION RD(3000),FAC,U1,U2



      INTEGER          ISEED(3,10),NSEQ

      LOGICAL          KNOR



# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"










      COMMON /CRREJECT/AVNREJ,ALTMIN,ANEXP,THICKA,THICKD,CUTLN,EONCUT,

     *                 EFRCTHN,ETHINN,ETHINNG,THINRAT,THINRATH,WEITRAT,
     *                 WEITRATH,EEFRTHN,

     *                 FNPRIM
      DOUBLE PRECISION AVNREJ(20),ALTMIN(20),ANEXP(20),THICKA(20),
     *                 THICKD(20),CUTLN,EONCUT

     *                 ,EFRCTHN,ETHINN,ETHINNG,THINRAT,THINRATH,WEITRAT,
     *                 WEITRATH,EEFRTHN

      LOGICAL          FNPRIM





















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"



      COMMON /CRSTACKE/E,TIM,U,V,W,X,Y,Z,DNEAR,

     *                 WT,


     *                 ZAP,WAP,WA,XXXX,YYYY,


     *                 TSLAN,




     *                 IQ,IGEN,IR,IOBS,LPCTE,NP
      DOUBLE PRECISION E(60),TIM(60),U(60),V(60),W(60),
     *                 X(60),Y(60),Z(60),DNEAR(60)

     *                 ,WT(60)


     *                 ,ZAP(60),WAP(60),WA(60),XXXX(60),YYYY(60)


     *                 ,TSLAN(60)




      INTEGER          IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP



# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"



      COMMON /CRUPHIOT/THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI
      DOUBLE PRECISION THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI











# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 49291 "corsika.F" 2

      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
# 49305 "corsika.F"

      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

# 49333 "corsika.F"
      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
C  HERE THE PRODUCTION OF PHI MESONS MUST BE INCLUDED
C    IF     ( RD(2) .LT. 0.1D0 ) THEN
      IF     ( RD(2) .LT. 0.06D0 ) THEN
C  PRESENTLY WE ARE TAKING INTO ACCOUNT RHO AND OMEGA, AND PHI  MESON.
        IQ(NP) = 49   ! PHI MESON
C  10% CHANCE FOR  (OMEGA + PHI)  MESON
      ELSEIF (RD(2) .LT. 0.1D0 ) THEN
        IQ(NP) = 50   ! OMEGA MESON
      ELSE
C  GENERATED MESON IS  RHO(0) WITH 90% CHANCE
        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







      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 (FEGSDB) WRITE(MDEBUG,*) 'RHOGEN: E2,E4,PCM2,PCM4,TMIN,TMAX=',

     *    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 ( FEGSDB ) WRITE(MDEBUG,*) 'RHOGEN: RD,T,PLNG3,PEOM=',

     *  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) .GE. 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

          SECPAR(13) =  WT(NP)
# 49498 "corsika.F"
          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)

     *                             + (E(NP)-AMASS4) * 1.D-3 * WT(NP)



          ENDIF
# 49525 "corsika.F"
        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)

     *                             + (E(NP)-AMASS4) * 1.D-3 * WT(NP)



        ENDIF
# 49555 "corsika.F"
C  ELIMINATE NUCLEON FROM EGS-STACK
        NP = NP-1
C  END OF RECOIL NUCLEON TREATMENT CASE
      ENDIF
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C     IF ( IQ(NP) .GE. 50 ) THEN
      IF ( IQ(NP) .GE. 49 ) THEN      ! WE INCLUDE PHI MESON
C  NOW TREAT THE VECTOR MESON

        IF ( W(NP) .GE. C(29) ) THEN



C         IF     ( IQ(NP) .EQ. 50 ) THEN
          IF     ( IQ(NP) .LE. 50 ) THEN
C  ADD OMEGA MESON TO CORSIKA-STACK (TO BE TREATED IN RESDEC)
C  ADD OMEGA/PHI 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

            SECPAR(13) =  WT(NP)


            SECPAR(14) = -ZAP(NP)
            SECPAR(15) =  WAP(NP)
            SECPAR(16) =  WA(NP)
# 49608 "corsika.F"
            CALL TSTACK
C  FINALLY OMEGA/PHI 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)

            CURPAR(13) =  WT(NP)


            CURPAR(14) = -ZAP(NP)
            CURPAR(15) =  WAP(NP)
            CURPAR(16) =  WA(NP)







C  RHO(0) DECAYS WITH DIPOLE CHARACTERISTIC IN RHO0DC



            CALL RHO0DC(1)
          ELSE
            WRITE(MONIOU,*) 'RHOGEN: WRONG PARTICLE CODE=',IQ(NP)
            STOP 1
          ENDIF
        ELSE
          IF ( LLONGI ) THEN
C  CUTTED ENERGY TO LONGITUDINAL ENERGY SUMS OF HADRONS [IN GEV]
C  ANGLE CUT

            DLONG(LPCTE(NP),17) = DLONG(LPCTE(NP),17)+E(NP)*1.D-3*WT(NP)



          ENDIF
# 49679 "corsika.F"
        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
# 49714 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"





























































      COMMON /CREGSDEB/JCLOCK,NCLOCK,FEGSDB
      INTEGER          JCLOCK,NCLOCK
      LOGICAL          FEGSDB

























# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"










      COMMON /CRMISC/  DUNIT,RHOR,KMPI,KMPO,NOSCAT,MED,IRAYLR
      DOUBLE PRECISION DUNIT,RHOR(6)
      INTEGER          KMPI,KMPO,NOSCAT,MED(6),IRAYLR(6)



# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"



      COMMON /CRSTACKE/E,TIM,U,V,W,X,Y,Z,DNEAR,

     *                 WT,


     *                 ZAP,WAP,WA,XXXX,YYYY,


     *                 TSLAN,




     *                 IQ,IGEN,IR,IOBS,LPCTE,NP
      DOUBLE PRECISION E(60),TIM(60),U(60),V(60),W(60),
     *                 X(60),Y(60),Z(60),DNEAR(60)

     *                 ,WT(60)


     *                 ,ZAP(60),WAP(60),WA(60),XXXX(60),YYYY(60)


     *                 ,TSLAN(60)




      INTEGER          IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP



# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 49714 "corsika.F" 2




      INTEGER          IRCODE



      SAVE
C-----------------------------------------------------------------------




C  TAKE FIRST PARTICLE IN STACK
      NP = 1

C  DECIDE WHAT IS ON TOP OF STACK

 261  CONTINUE


      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

# 49796 "corsika.F"

C  JUMP TO PARTICLE IN QUESTION.  THE FOLLOWING PARTICLE IDENTIFICATION
C  IS MADE BY THE VALUE OF IQ(NP) (ACCORDING TO CORSIKA)
C            IQ    =  1         GAMMA
C                  =  2         POSITRON E (+)
C                  =  3         ELECTRON E (-)
CC                 =  5         POSITIVE MUON (+)
CC                 =  6         NEGATIVE MUON (-)
CC                 =  7         NEUTRAL  PION (0)
CC                 =  8         POSITIVE PION (+)
CC                 =  9         NEGATIVE PION (-)
C                  =  OTHER VALUE, JUMP TO ERROR MESSAGE

      GOTO (270,280,280) (IQ(NP))
C  IQ OUT OF RANGE?
      WRITE(KMPO,320) IQ(NP),NP
 320  FORMAT(' SHOWER: PARTICLE TYPE ',I5,' NOT IDENTIFIED'/
     *       '         NP = ',I5)
      CALL AUSGB2
C  ELIMINATE UNEXPECTED PARTICLE
      NP = NP-1
      GOTO 262

C  PARTICLE IS GAMMA
 270  CALL PHOTON( IRCODE )
C  GAMMA DISCARDED ?



      IF ( IRCODE .EQ. 3 ) RETURN  !USED WITH PARALLEL WHEN GETTING PRIMARY INT
      IF ( IRCODE .EQ. 2 ) GOTO 262
      IF ( IQ(NP) .LT. 2  .OR.  IQ(NP) .GT. 3 ) GOTO 261


C  PARTICLE IS ELECTRON OR POSITRON
 280  CALL ELECTR( IRCODE )
C  ELECTRON DISCARDED ?



      IF ( IRCODE .EQ. 3 ) RETURN  !USED WITH PARALLEL WHEN GETTING PRIMARY INT
      IF ( IRCODE .EQ. 2 ) GOTO 262
      IF ( IQ(NP) .EQ. 1 ) GOTO 270
C  LOOP BACK UP TO PARTICLE SELECTION
      GOTO 261


 262  CONTINUE
C  CHECK TO SEE IF ANYTHING LEFT ON STACK

      IF ( NP .GT. 0 ) GOTO 261

C  NOTHING ON STACK, SO JUMP OUT OF LOOP

# 49871 "corsika.F"
      RETURN
      END


*-- 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







# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"





























































      COMMON /CREGSDEB/JCLOCK,NCLOCK,FEGSDB
      INTEGER          JCLOCK,NCLOCK
      LOGICAL          FEGSDB

























# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"

























      COMMON /CRRANDPA/RD,FAC,U1,U2,NSEQ,ISEED,KNOR
      DOUBLE PRECISION RD(3000),FAC,U1,U2



      INTEGER          ISEED(3,10),NSEQ

      LOGICAL          KNOR



# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"










      COMMON /CRREJECT/AVNREJ,ALTMIN,ANEXP,THICKA,THICKD,CUTLN,EONCUT,

     *                 EFRCTHN,ETHINN,ETHINNG,THINRAT,THINRATH,WEITRAT,
     *                 WEITRATH,EEFRTHN,

     *                 FNPRIM
      DOUBLE PRECISION AVNREJ(20),ALTMIN(20),ANEXP(20),THICKA(20),
     *                 THICKD(20),CUTLN,EONCUT

     *                 ,EFRCTHN,ETHINN,ETHINNG,THINRAT,THINRATH,WEITRAT,
     *                 WEITRATH,EEFRTHN

      LOGICAL          FNPRIM





















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"



      COMMON /CRSTACKE/E,TIM,U,V,W,X,Y,Z,DNEAR,

     *                 WT,


     *                 ZAP,WAP,WA,XXXX,YYYY,


     *                 TSLAN,




     *                 IQ,IGEN,IR,IOBS,LPCTE,NP
      DOUBLE PRECISION E(60),TIM(60),U(60),V(60),W(60),
     *                 X(60),Y(60),Z(60),DNEAR(60)

     *                 ,WT(60)


     *                 ,ZAP(60),WAP(60),WA(60),XXXX(60),YYYY(60)


     *                 ,TSLAN(60)




      INTEGER          IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP



# 4821 "corsika.h"
















# 4853 "corsika.h"



      COMMON /CRTHNVAR/STACKINT,

     *                 EEPP,ELIM,


     *                 RMAX,RMAX2,
     *                 WMAX,WMAX0,WMAXE,WMAXE0,WMAXEM,

     *                 INT_ICOUNT,MODETHN,THINNING

     *                 ,RLIM,WLIM

      INTEGER          MAXICOUNT
      PARAMETER        (MAXICOUNT = 200000)
# 4883 "corsika.h"
      DOUBLE PRECISION STACKINT(0:16,MAXICOUNT)
# 4892 "corsika.h"
     *                 ,EEPP(MAXICOUNT),ELIM


     *                 ,RMAX,RMAX2
     *                 ,WMAX,WMAX0,WMAXE,WMAXE0,WMAXEM

      INTEGER          INT_ICOUNT,MODETHN
      LOGICAL          THINNING

      LOGICAL           RLIM,WLIM




















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 49900 "corsika.F" 2

      DOUBLE PRECISION EK,EKHIGH,EKK,EKLOW,THNMRK
      LOGICAL          LABOVE
      SAVE
C-----------------------------------------------------------------------






      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

# 50125 "corsika.F"
*-- 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
# 50158 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























































































# 3811 "corsika.h"



      COMMON /CREPCONT/EDEP,RATIO,TSTEP,TUSTEP,USTEP,TVSTEP,VSTEP,
     *                 RHOFAC,EOLD,ENEW,EKE,ELKE,BETA2,GLE,TSCAT,
     *                 WCUT,
     *                 IDISC,IROLD,IRNEW
      DOUBLE PRECISION EDEP,RATIO,TSTEP,TUSTEP,USTEP,TVSTEP,VSTEP,
     *                 RHOFAC,EOLD,ENEW, EKE,ELKE,BETA2,GLE,TSCAT,
     *                 WCUT
      INTEGER          IDISC,IROLD,IRNEW

























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"

























      COMMON /CRRANDPA/RD,FAC,U1,U2,NSEQ,ISEED,KNOR
      DOUBLE PRECISION RD(3000),FAC,U1,U2



      INTEGER          ISEED(3,10),NSEQ

      LOGICAL          KNOR



# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"



      COMMON /CRSTACKE/E,TIM,U,V,W,X,Y,Z,DNEAR,

     *                 WT,


     *                 ZAP,WAP,WA,XXXX,YYYY,


     *                 TSLAN,




     *                 IQ,IGEN,IR,IOBS,LPCTE,NP
      DOUBLE PRECISION E(60),TIM(60),U(60),V(60),W(60),
     *                 X(60),Y(60),Z(60),DNEAR(60)

     *                 ,WT(60)


     *                 ,ZAP(60),WAP(60),WA(60),XXXX(60),YYYY(60)


     *                 ,TSLAN(60)




      INTEGER          IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP



# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"



      COMMON /CRUPHIOT/THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI
      DOUBLE PRECISION THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI











# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 50158 "corsika.F" 2

      DOUBLE PRECISION A,B,C,COSDEL,PHI,SINDEL,SINPSI,SINPS2,US,VS
      INTEGER          IENTRY,LVL



      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)

      WT(NP)    = WT(NP-1)


      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)


      TSLAN(NP) = TSLAN(NP-1)






 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


# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 50276 "corsika.F" 2

      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






# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"



      COMMON /CRBUFFS/ RUNH,RUNE,EVTH,EVTE,DATAB,ARRAYLONG,LH

     *                 ,WRRUNH,WRRUNE,WREVTH,WREVTE

      INTEGER          MAXBUF,MAXLEN

      PARAMETER        (MAXBUF=39*8)
# 3681 "corsika.h"
      PARAMETER        (MAXLEN=16)
# 3693 "corsika.h"
      REAL             RUNH(MAXBUF),EVTH(MAXBUF),EVTE(MAXBUF),
     *                 RUNE(MAXBUF),DATAB(MAXBUF),ARRAYLONG(MAXBUF)
      INTEGER          LH

      LOGICAL          WRRUNH,WRRUNE,WREVTH,WREVTE

      CHARACTER*4      CRUNH,CRUNE,CEVTH,CEVTE,CLONG
      EQUIVALENCE      (RUNH(1),CRUNH), (RUNE(1),CRUNE)
      EQUIVALENCE      (EVTH(1),CEVTH), (EVTE(1),CEVTE)
      EQUIVALENCE      (ARRAYLONG(1),CLONG)







































































      COMMON /CRELABCT/ELCUT
      DOUBLE PRECISION ELCUT(4)


















# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"



      COMMON /CRNKGI/  SEL,SELLG,STH,ZEL,ZELLG,ZSL,DIST,
     *                 DISX,DISY,DISXY,DISYX,DLAX,DLAY,DLAXY,DLAYX,
     *                 OBSATI,RADNKG,RMOL,TLEV,TLEVCM,IALT
      DOUBLE PRECISION SEL(10),SELLG(10),STH(10),ZEL(10),ZELLG(10),
     *                 ZSL(10),DIST(10),
     *                 DISX(-10:10),DISY(-10:10),
     *                 DISXY(-10:10,2),DISYX(-10:10,2),
     *                 DLAX (-10:10,2),DLAY (-10:10,2),
     *                 DLAXY(-10:10,2),DLAYX(-10:10,2),
     *                 OBSATI(2),RADNKG,RMOL(2),TLEV(10),TLEVCM(10)
      INTEGER          IALT(2)





      COMMON /CRNKGS/  CZX,CZY,CZXY,CZYX,SAH,SL,ZNE
      DOUBLE PRECISION CZX(-10:10,2),CZY(-10:10,2),CZXY(-10:10,2),
     *                 CZYX(-10:10,2),SAH(10),SL(10),ZNE(10)










# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 50332 "corsika.F" 2

      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





# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"



      COMMON /CRBUFFS/ RUNH,RUNE,EVTH,EVTE,DATAB,ARRAYLONG,LH

     *                 ,WRRUNH,WRRUNE,WREVTH,WREVTE

      INTEGER          MAXBUF,MAXLEN

      PARAMETER        (MAXBUF=39*8)
# 3681 "corsika.h"
      PARAMETER        (MAXLEN=16)
# 3693 "corsika.h"
      REAL             RUNH(MAXBUF),EVTH(MAXBUF),EVTE(MAXBUF),
     *                 RUNE(MAXBUF),DATAB(MAXBUF),ARRAYLONG(MAXBUF)
      INTEGER          LH

      LOGICAL          WRRUNH,WRRUNE,WREVTH,WREVTE

      CHARACTER*4      CRUNH,CRUNE,CEVTH,CEVTE,CLONG
      EQUIVALENCE      (RUNH(1),CRUNH), (RUNE(1),CRUNE)
      EQUIVALENCE      (EVTH(1),CEVTH), (EVTE(1),CEVTE)
      EQUIVALENCE      (ARRAYLONG(1),CLONG)



























































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"



      COMMON /CRNKGI/  SEL,SELLG,STH,ZEL,ZELLG,ZSL,DIST,
     *                 DISX,DISY,DISXY,DISYX,DLAX,DLAY,DLAXY,DLAYX,
     *                 OBSATI,RADNKG,RMOL,TLEV,TLEVCM,IALT
      DOUBLE PRECISION SEL(10),SELLG(10),STH(10),ZEL(10),ZELLG(10),
     *                 ZSL(10),DIST(10),
     *                 DISX(-10:10),DISY(-10:10),
     *                 DISXY(-10:10,2),DISYX(-10:10,2),
     *                 DLAX (-10:10,2),DLAY (-10:10,2),
     *                 DLAXY(-10:10,2),DLAYX(-10:10,2),
     *                 OBSATI(2),RADNKG,RMOL(2),TLEV(10),TLEVCM(10)
      INTEGER          IALT(2)


















# 4212 "corsika.h"










      COMMON /CROBSPAR/OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP,
     *                 THETPR,PHIPR,

     *                 CORRXY,







     *                 NOBSLV
      DOUBLE PRECISION OBSLEV(20),THCKOB(20),XOFF(20),YOFF(20),
     *                 HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2)

     *                 ,CORRXY







      INTEGER          NOBSLV



# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 50531 "corsika.F" 2

      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 ( 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


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




# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"





































































      COMMON /CRELABCT/ELCUT
      DOUBLE PRECISION ELCUT(4)


















# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"



      COMMON /CRNKGI/  SEL,SELLG,STH,ZEL,ZELLG,ZSL,DIST,
     *                 DISX,DISY,DISXY,DISYX,DLAX,DLAY,DLAXY,DLAYX,
     *                 OBSATI,RADNKG,RMOL,TLEV,TLEVCM,IALT
      DOUBLE PRECISION SEL(10),SELLG(10),STH(10),ZEL(10),ZELLG(10),
     *                 ZSL(10),DIST(10),
     *                 DISX(-10:10),DISY(-10:10),
     *                 DISXY(-10:10,2),DISYX(-10:10,2),
     *                 DLAX (-10:10,2),DLAY (-10:10,2),
     *                 DLAXY(-10:10,2),DLAYX(-10:10,2),
     *                 OBSATI(2),RADNKG,RMOL(2),TLEV(10),TLEVCM(10)
      INTEGER          IALT(2)


















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 50642 "corsika.F" 2

      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         <EL NR>        DEV<EL>',
     *   '   <LOG(EL NR)>  DEV<LOG(E)>   <PS-AGE>  DEV<AGE>',/,
     *   '  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 <N_E>
        SELEC   = SEL(LI) * RISH
C  LOG10 ELECTRON NUMBER <N_E>
        SELCLG  = SELLG(LI) * RISH
C  <S_....> AVERAGE LONGITUDINAL AGE
        ATH     = STH(LI) * RISH
        IF ( ISHW .GT. 1 ) THEN
C  ELECTRON NUMBER <N_E>
          ZEC   = SQRT( MAX( 0.D0, (ZEL(LI) - SEL(LI)**2*RISH)/
     *                              (ISHW-1.D0) ) )
C  LOG10 ELECTRON NUMBER <N_E>
          ZECLG = SQRT( MAX( 0.D0, (ZELLG(LI) - SELLG(LI)**2*RISH)/
     *                              (ISHW-1.D0) ) )
C  <S_....> 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
# 50779 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"











      COMMON /CRCONSTA/PI,PI2,OB3,TB3,ENEPER,SQRT3
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER,SQRT3
























































      COMMON /CRELABCT/ELCUT
      DOUBLE PRECISION ELCUT(4)


















# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"



      COMMON /CRNKGI/  SEL,SELLG,STH,ZEL,ZELLG,ZSL,DIST,
     *                 DISX,DISY,DISXY,DISYX,DLAX,DLAY,DLAXY,DLAYX,
     *                 OBSATI,RADNKG,RMOL,TLEV,TLEVCM,IALT
      DOUBLE PRECISION SEL(10),SELLG(10),STH(10),ZEL(10),ZELLG(10),
     *                 ZSL(10),DIST(10),
     *                 DISX(-10:10),DISY(-10:10),
     *                 DISXY(-10:10,2),DISYX(-10:10,2),
     *                 DLAX (-10:10,2),DLAY (-10:10,2),
     *                 DLAXY(-10:10,2),DLAYX(-10:10,2),
     *                 OBSATI(2),RADNKG,RMOL(2),TLEV(10),TLEVCM(10)
      INTEGER          IALT(2)





      COMMON /CRNKGS/  CZX,CZY,CZXY,CZYX,SAH,SL,ZNE
      DOUBLE PRECISION CZX(-10:10,2),CZY(-10:10,2),CZXY(-10:10,2),
     *                 CZYX(-10:10,2),SAH(10),SL(10),ZNE(10)










# 4212 "corsika.h"










      COMMON /CROBSPAR/OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP,
     *                 THETPR,PHIPR,

     *                 CORRXY,







     *                 NOBSLV
      DOUBLE PRECISION OBSLEV(20),THCKOB(20),XOFF(20),YOFF(20),
     *                 HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2)

     *                 ,CORRXY







      INTEGER          NOBSLV



# 4262 "corsika.h"



      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL





      DOUBLE PRECISION GAMMA,COSTHE,PHIX,PHIY,H,T,X,Y,CHI,BETA,GCM,ECM

     *                 ,WEIGHT


     *                 ,HAPP,COSTAP,COSTEA




      EQUIVALENCE      (CURPAR(1), GAMMA ), (CURPAR(2), COSTHE),
     *                 (CURPAR(3), PHIX  ), (CURPAR(4), PHIY  ),
     *                 (CURPAR(5), H     ), (CURPAR(6), T     ),
     *                 (CURPAR(7), X     ), (CURPAR(8), Y     ),
     *                 (CURPAR(9), CHI   ), (CURPAR(10),BETA  ),
     *                 (CURPAR(11),GCM   ), (CURPAR(12),ECM   )

     *                ,(CURPAR(13),WEIGHT)


     *                ,(CURPAR(14),HAPP  ), (CURPAR(15),COSTAP),
     *                 (CURPAR(16),COSTEA)















# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 50779 "corsika.F" 2

      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

        CPCP  = SIGNE * SECPAR(13) * CPH * CPC / CCP



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



# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"



      COMMON /CRNKGS/  CZX,CZY,CZXY,CZYX,SAH,SL,ZNE
      DOUBLE PRECISION CZX(-10:10,2),CZY(-10:10,2),CZXY(-10:10,2),
     *                 CZYX(-10:10,2),SAH(10),SL(10),ZNE(10)










# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 50948 "corsika.F" 2

      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

# 53979 "corsika.F"

# 55195 "corsika.F"

# 56935 "corsika.F"


*-- 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


# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"

















# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     


      COMMON /CRURQCOM/XS,BIM,ICUTBL,ICU2I3,IFLBMAX
      DOUBLE PRECISION XS(3),BIM(3)
      INTEGER          ICUTBL(200),ICU2I3(200),IFLBMAX










# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 56951 "corsika.F" 2

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



# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     


      COMMON /CRURQCOM/XS,BIM,ICUTBL,ICU2I3,IFLBMAX
      DOUBLE PRECISION XS(3),BIM(3)
      INTEGER          ICUTBL(200),ICU2I3(200),IFLBMAX










# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 56988 "corsika.F" 2

      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
# 57390 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"








      COMMON /CRPAM/   PAMA,SIGNUM,RESTMS,DECTIM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000),
     *                 DECTIM(200)






      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL



# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"

























      COMMON /CRRANDPA/RD,FAC,U1,U2,NSEQ,ISEED,KNOR
      DOUBLE PRECISION RD(3000),FAC,U1,U2



      INTEGER          ISEED(3,10),NSEQ

      LOGICAL          KNOR



# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"











      COMMON /CRREST/  CONTNE,TAR,LIT
      DOUBLE PRECISION CONTNE(3),TAR
      INTEGER          LIT





      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"



      COMMON /CRSIGM/  SIGMA,SIGANN,SIGAIR,FRACTN,FRCTNO
      DOUBLE PRECISION SIGMA,SIGANN,SIGAIR,FRACTN,FRCTNO



# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     


      COMMON /CRURQCOM/XS,BIM,ICUTBL,ICU2I3,IFLBMAX
      DOUBLE PRECISION XS(3),BIM(3)
      INTEGER          ICUTBL(200),ICU2I3(200),IFLBMAX










# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 57390 "corsika.F" 2

      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



        WRITE(MDEBUG,*) 'URQLNK:'

        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
# 57488 "corsika.F"
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 ( 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
# 57558 "corsika.F"
      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

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






# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"



      INTEGER          KSEQ



      PARAMETER        (KSEQ = 9)

      COMMON /CRRANMA3/CD,CINT,CM,TWOM24,TWOM48,MODCNS
      DOUBLE PRECISION CD,CINT,CM,TWOM24,TWOM48
      INTEGER          MODCNS





      COMMON /CRRANMA4/C,U,IJKL,I97,J97,NTOT,NTOT2,JSEQ
      DOUBLE PRECISION C(KSEQ),U(97,KSEQ),UNI
      INTEGER          IJKL(KSEQ),I97(KSEQ),J97(KSEQ),
     *                 NTOT(KSEQ),NTOT2(KSEQ),JSEQ



# 4450 "corsika.h"








# 4475 "corsika.h"

















# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     


      COMMON /CXINPUT/ CXTHR,CXMCC,CXWMX,CXMCS

     *                ,DZCNX

     *                ,INLUN,OUTLUN,IDCX,ISX0,FINCNX,FCXGHE,FCXWMX,FCXCE
     *                ,FCORS
      DOUBLE PRECISION CXTHR(3),CXMCC(3),CXWMX(3),CXMCS

     *                 ,DZCNX

      INTEGER          INLUN,OUTLUN,IDCX,ISX0
      LOGICAL          FINCNX,FCXGHE,FCXWMX,FCXCE,FCORS
      COMMON /CXCONVE/ CXXCONV,CXYCONV,CXTCONV
      DOUBLE PRECISION CXXCONV,CXYCONV,CXTCONV



     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 57662 "corsika.F" 2




      INTEGER   IDUM
      SAVE
C-----------------------------------------------------------------------

      JSEQ = 1




      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






# 1 "corsika.h" 1
# 3562 "corsika.h"



      COMMON /CRAIR/   COMPOS,PROBTA,AVERAW,AVOGDR
      DOUBLE PRECISION COMPOS(3),PROBTA(3),AVERAW,AVOGDR



# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"








      COMMON /CRPAM/   PAMA,SIGNUM,RESTMS,DECTIM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000),
     *                 DECTIM(200)




# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"



      COMMON /CRSIGM/  SIGMA,SIGANN,SIGAIR,FRACTN,FRCTNO
      DOUBLE PRECISION SIGMA,SIGANN,SIGAIR,FRACTN,FRCTNO



# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     


      COMMON /CRURQCOM/XS,BIM,ICUTBL,ICU2I3,IFLBMAX
      DOUBLE PRECISION XS(3),BIM(3)
      INTEGER          ICUTBL(200),ICU2I3(200),IFLBMAX










# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 57721 "corsika.F" 2

      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



# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"

















# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     


      COMMON /CRURQCOM/XS,BIM,ICUTBL,ICU2I3,IFLBMAX
      DOUBLE PRECISION XS(3),BIM(3)
      INTEGER          ICUTBL(200),ICU2I3(200),IFLBMAX










# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 57771 "corsika.F" 2

      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
# 57867 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"












































































      COMMON /CRELADPM/ELMEAN,ELMEAA,IELDPM,IELDPA
      DOUBLE PRECISION ELMEAN(40),ELMEAA(40)
      INTEGER          IELDPM(40,13),IELDPA(40,13)





      COMMON /CRELASTY/ELAST
      DOUBLE PRECISION ELAST



# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"











      COMMON /CRISTA/  IFINET,IFINNU,IFINKA,IFINPI,IFINHY,IFINCM,IFINOT,
     *                 IFINRHO
      INTEGER          IFINET,IFINNU,IFINKA,IFINPI,IFINHY,IFINCM,IFINOT,
     *                 IFINRHO


























      INTEGER          LNGMAX
      PARAMETER        (LNGMAX = 15000)
      INTEGER          TYPE1
      PARAMETER        (TYPE1 = 0)
      INTEGER          TYPE2
      PARAMETER        (TYPE2 = 1)
      INTEGER          TYPE3
      PARAMETER        (TYPE3 = 2)
      INTEGER          TYPE4
      PARAMETER        (TYPE4 = 3)
      COMMON /CRLONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP



     *                ,LLONGI,FLGFIT
# 3961 "corsika.h"
      DOUBLE PRECISION ADLONG(0:LNGMAX,19),AELONG(0:LNGMAX,10),
     *                 APLONG(0:LNGMAX,10),DLONG(0:LNGMAX,19),
     *                 ELONG(0:LNGMAX,10),
     *                 HLONG(0:LNGMAX),PLONG(0:LNGMAX,10),
     *                 SDLONG(0:LNGMAX,19),SELONG(0:LNGMAX,10),
     *                 SPLONG(0:LNGMAX,10),THSTEP,THSTPI




      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT

      COMMON /CRSLANT/ RLONG,THCKRL,CTH,STHCPH,STHSPH,RLOFF
      DOUBLE PRECISION RLONG(0:LNGMAX),THCKRL(0:LNGMAX),
     *                 CTH,STHCPH,STHSPH,RLOFF


















# 4005 "corsika.h"
















# 4047 "corsika.h"



      COMMON /CRMULT/  EKINL,MSMM,MULTMA,MULTOT
      DOUBLE PRECISION EKINL
      INTEGER          MSMM,MULTMA(40,13),MULTOT(40,13)



# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"










      COMMON /CROBSPAR/OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP,
     *                 THETPR,PHIPR,

     *                 CORRXY,







     *                 NOBSLV
      DOUBLE PRECISION OBSLEV(20),THCKOB(20),XOFF(20),YOFF(20),
     *                 HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2)

     *                 ,CORRXY







      INTEGER          NOBSLV










      COMMON /CRPAM/   PAMA,SIGNUM,RESTMS,DECTIM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000),
     *                 DECTIM(200)






      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL



# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"

























      COMMON /CRRANDPA/RD,FAC,U1,U2,NSEQ,ISEED,KNOR
      DOUBLE PRECISION RD(3000),FAC,U1,U2



      INTEGER          ISEED(3,10),NSEQ

      LOGICAL          KNOR



# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"











      COMMON /CRREST/  CONTNE,TAR,LIT
      DOUBLE PRECISION CONTNE(3),TAR
      INTEGER          LIT





      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"



      COMMON /CRSIGM/  SIGMA,SIGANN,SIGAIR,FRACTN,FRCTNO
      DOUBLE PRECISION SIGMA,SIGANN,SIGAIR,FRACTN,FRCTNO



# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 57867 "corsika.F" 2

      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
# 57884 "corsika.F"
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

      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
# 57921 "corsika.F"

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 ( 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 ( SECPAR(2) .GE. C(29) ) THEN
# 58111 "corsika.F"
          CALL TSTACK
        ELSE
C  ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT (ANGULAR CUT)
          IF ( LLONGI ) THEN
            IF     ( NTYPE .EQ. 1                   ) THEN

              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
# 58174 "corsika.F"
            ENDIF
          ENDIF
# 58203 "corsika.F"
        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 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -






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 )

        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)







        ENDIF


        coastProjId = nint(curpar(0))
c  warning TARGET PARTICLE ID FOR URQMD INTERACTIONS ???
        coastTargId = 0
        coastX = curpar(7)
        coastY = curpar(8)

        coastZ = curpar(14)





        coastT = curpar(6)
        coastE  = pama(coastProjId)*curpar(1)
        coastCX = sigair
        coastEl = elasti
        call interaction(coastX)


        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

# 60768 "corsika.F"

# 60821 "corsika.F"

*-- 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



# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"



      COMMON /CRAVPT/  AVPT,AVPK,AVPN,AVPH,AVPE
      DOUBLE PRECISION AVPT,AVPK,AVPN,AVPH,AVPE










# 3655 "corsika.h"

# 3705 "corsika.h"

























































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 60842 "corsika.F" 2

      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)
# 60914 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"















































      COMMON /CRDPMFLG/NFLAIN,NFLDIF,NFLPI0,NFLCHE,NFLPIF,NFRAGM
      INTEGER          NFLAIN,NFLDIF,NFLPI0,NFLCHE,NFLPIF,NFRAGM








































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"



      COMMON /CRINTER/ AVCH,AVCH3,DC0,DLOGS,DMLOG,ECMDIF,ECMDPM,ELAB,
     *                 FNEUT,FNEUT2,GNU,PLAB,POSC2,POSC3,POSN2,POSN3,
     *                 RC3TO2,S,SEUGF,SEUGP,SLOG,SLOGSQ,SMLOG,
     *                 WIDC2,WIDC3,WIDN2,WIDN3,YCM,YY0,ZN,
     *                 IDIF,ITAR
      DOUBLE PRECISION AVCH,AVCH3,DC0,DLOGS,DMLOG,ECMDIF,ECMDPM,ELAB,
     *                 FNEUT,FNEUT2,GNU,PLAB,POSC2,POSC3,POSN2,POSN3,
     *                 RC3TO2,S,SEUGF,SEUGP,SLOG,SLOGSQ,SMLOG,
     *                 WIDC2,WIDC3,WIDN2,WIDN3,YCM,YY0,ZN
      INTEGER          IDIF,ITAR











# 3912 "corsika.h"

















      COMMON /CRLEPAR/ LEPAR1,LEPAR2,LASTPI,NRESPC,NRESPN,NCPLUS
      INTEGER          LEPAR1,LEPAR2,LASTPI,NRESPC,NRESPN,NCPLUS



# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"








      COMMON /CRPAM/   PAMA,SIGNUM,RESTMS,DECTIM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000),
     *                 DECTIM(200)






      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL





      DOUBLE PRECISION GAMMA,COSTHE,PHIX,PHIY,H,T,X,Y,CHI,BETA,GCM,ECM

     *                 ,WEIGHT


     *                 ,HAPP,COSTAP,COSTEA




      EQUIVALENCE      (CURPAR(1), GAMMA ), (CURPAR(2), COSTHE),
     *                 (CURPAR(3), PHIX  ), (CURPAR(4), PHIY  ),
     *                 (CURPAR(5), H     ), (CURPAR(6), T     ),
     *                 (CURPAR(7), X     ), (CURPAR(8), Y     ),
     *                 (CURPAR(9), CHI   ), (CURPAR(10),BETA  ),
     *                 (CURPAR(11),GCM   ), (CURPAR(12),ECM   )

     *                ,(CURPAR(13),WEIGHT)


     *                ,(CURPAR(14),HAPP  ), (CURPAR(15),COSTAP),
     *                 (CURPAR(16),COSTEA)















# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"

























      COMMON /CRRANDPA/RD,FAC,U1,U2,NSEQ,ISEED,KNOR
      DOUBLE PRECISION RD(3000),FAC,U1,U2



      INTEGER          ISEED(3,10),NSEQ

      LOGICAL          KNOR



# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"











      COMMON /CRREST/  CONTNE,TAR,LIT
      DOUBLE PRECISION CONTNE(3),TAR
      INTEGER          LIT





      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 60914 "corsika.F" 2

      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 <N_PHOTON>
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


# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 61071 "corsika.F" 2

      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)
# 61128 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"











      COMMON /CRCONSTA/PI,PI2,OB3,TB3,ENEPER,SQRT3
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER,SQRT3


































      COMMON /CRDPMFLG/NFLAIN,NFLDIF,NFLPI0,NFLCHE,NFLPIF,NFRAGM
      INTEGER          NFLAIN,NFLDIF,NFLPI0,NFLCHE,NFLPIF,NFRAGM



























      COMMON /CRELADPM/ELMEAN,ELMEAA,IELDPM,IELDPA
      DOUBLE PRECISION ELMEAN(40),ELMEAA(40)
      INTEGER          IELDPM(40,13),IELDPA(40,13)





      COMMON /CRELASTY/ELAST
      DOUBLE PRECISION ELAST



# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"


















      COMMON /CRINDICE/NNUCN,NKA0,NHYPN,NETA,NETAS,NPIZER,
     *                 NNC,NKC,NHC,NPC,NCH,NNN,NKN,NHN,NET,NPN
      INTEGER          NNUCN(2:3),NKA0(2:3),NHYPN(2:3),NETA(2:3,1:4),
     *                 NETAS(2:3),NPIZER(2:3),
     *                 NNC,NKC,NHC,NPC,NCH,NNN,NKN,NHN,NET,NPN





      COMMON /CRINTER/ AVCH,AVCH3,DC0,DLOGS,DMLOG,ECMDIF,ECMDPM,ELAB,
     *                 FNEUT,FNEUT2,GNU,PLAB,POSC2,POSC3,POSN2,POSN3,
     *                 RC3TO2,S,SEUGF,SEUGP,SLOG,SLOGSQ,SMLOG,
     *                 WIDC2,WIDC3,WIDN2,WIDN3,YCM,YY0,ZN,
     *                 IDIF,ITAR
      DOUBLE PRECISION AVCH,AVCH3,DC0,DLOGS,DMLOG,ECMDIF,ECMDPM,ELAB,
     *                 FNEUT,FNEUT2,GNU,PLAB,POSC2,POSC3,POSN2,POSN3,
     *                 RC3TO2,S,SEUGF,SEUGP,SLOG,SLOGSQ,SMLOG,
     *                 WIDC2,WIDC3,WIDN2,WIDN3,YCM,YY0,ZN
      INTEGER          IDIF,ITAR













      COMMON /CRISTA/  IFINET,IFINNU,IFINKA,IFINPI,IFINHY,IFINCM,IFINOT,
     *                 IFINRHO
      INTEGER          IFINET,IFINNU,IFINKA,IFINPI,IFINHY,IFINCM,IFINOT,
     *                 IFINRHO



















      COMMON /CRLEPAR/ LEPAR1,LEPAR2,LASTPI,NRESPC,NRESPN,NCPLUS
      INTEGER          LEPAR1,LEPAR2,LASTPI,NRESPC,NRESPN,NCPLUS





      INTEGER          LNGMAX
      PARAMETER        (LNGMAX = 15000)
      INTEGER          TYPE1
      PARAMETER        (TYPE1 = 0)
      INTEGER          TYPE2
      PARAMETER        (TYPE2 = 1)
      INTEGER          TYPE3
      PARAMETER        (TYPE3 = 2)
      INTEGER          TYPE4
      PARAMETER        (TYPE4 = 3)
      COMMON /CRLONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP



     *                ,LLONGI,FLGFIT
# 3961 "corsika.h"
      DOUBLE PRECISION ADLONG(0:LNGMAX,19),AELONG(0:LNGMAX,10),
     *                 APLONG(0:LNGMAX,10),DLONG(0:LNGMAX,19),
     *                 ELONG(0:LNGMAX,10),
     *                 HLONG(0:LNGMAX),PLONG(0:LNGMAX,10),
     *                 SDLONG(0:LNGMAX,19),SELONG(0:LNGMAX,10),
     *                 SPLONG(0:LNGMAX,10),THSTEP,THSTPI




      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT

      COMMON /CRSLANT/ RLONG,THCKRL,CTH,STHCPH,STHSPH,RLOFF
      DOUBLE PRECISION RLONG(0:LNGMAX),THCKRL(0:LNGMAX),
     *                 CTH,STHCPH,STHSPH,RLOFF


















# 4005 "corsika.h"
















# 4047 "corsika.h"



      COMMON /CRMULT/  EKINL,MSMM,MULTMA,MULTOT
      DOUBLE PRECISION EKINL
      INTEGER          MSMM,MULTMA(40,13),MULTOT(40,13)



# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"



      COMMON /CRNEWPAR/EA,PT2,PX,PY,TMAS,YR,ITYP,
     *                 IA1,IA2,IB1,IB2,IC1,IC2,ID1,ID2,IE1,IE2,IF1,IF2,
     *                 IG1,IG2,IH1,IH2,II1,II2,IJ1,NTOT
      DOUBLE PRECISION EA(3000),PT2(3000),PX(3000),PY(3000),TMAS(3000),
     *                 YR(3000)
      INTEGER          ITYP(3000),
     *                 IA1,IA2,IB1,IB2,IC1,IC2,ID1,ID2,IE1,IE2,IF1,IF2,
     *                 IG1,IG2,IH1,IH2,II1,II2,IJ1,NTOT



# 4169 "corsika.h"
















# 4212 "corsika.h"










      COMMON /CROBSPAR/OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP,
     *                 THETPR,PHIPR,

     *                 CORRXY,







     *                 NOBSLV
      DOUBLE PRECISION OBSLEV(20),THCKOB(20),XOFF(20),YOFF(20),
     *                 HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2)

     *                 ,CORRXY







      INTEGER          NOBSLV










      COMMON /CRPAM/   PAMA,SIGNUM,RESTMS,DECTIM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000),
     *                 DECTIM(200)






      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL





      DOUBLE PRECISION GAMMA,COSTHE,PHIX,PHIY,H,T,X,Y,CHI,BETA,GCM,ECM

     *                 ,WEIGHT


     *                 ,HAPP,COSTAP,COSTEA




      EQUIVALENCE      (CURPAR(1), GAMMA ), (CURPAR(2), COSTHE),
     *                 (CURPAR(3), PHIX  ), (CURPAR(4), PHIY  ),
     *                 (CURPAR(5), H     ), (CURPAR(6), T     ),
     *                 (CURPAR(7), X     ), (CURPAR(8), Y     ),
     *                 (CURPAR(9), CHI   ), (CURPAR(10),BETA  ),
     *                 (CURPAR(11),GCM   ), (CURPAR(12),ECM   )

     *                ,(CURPAR(13),WEIGHT)


     *                ,(CURPAR(14),HAPP  ), (CURPAR(15),COSTAP),
     *                 (CURPAR(16),COSTEA)















# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"

























      COMMON /CRRANDPA/RD,FAC,U1,U2,NSEQ,ISEED,KNOR
      DOUBLE PRECISION RD(3000),FAC,U1,U2



      INTEGER          ISEED(3,10),NSEQ

      LOGICAL          KNOR



# 4432 "corsika.h"

# 4441 "corsika.h"



      COMMON /CRRATIOS/RPI0R,RPIER,RPEKR,RPEKNR,PPICH,PPINCH,PPNKCH,
     *                 ISEL,NEUTOT,NTOTEM
      DOUBLE PRECISION RPI0R,RPIER,RPEKR,RPEKNR,PPICH,PPINCH,PPNKCH
      INTEGER          ISEL,NEUTOT,NTOTEM










# 4475 "corsika.h"



      COMMON /CRRESON/ RDRES,RESRAN,IRESPAR
      DOUBLE PRECISION RDRES(2),RESRAN(0:1000000)
      INTEGER          IRESPAR





      COMMON /CRREST/  CONTNE,TAR,LIT
      DOUBLE PRECISION CONTNE(3),TAR
      INTEGER          LIT





      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"



      COMMON /CRSIGM/  SIGMA,SIGANN,SIGAIR,FRACTN,FRCTNO
      DOUBLE PRECISION SIGMA,SIGANN,SIGAIR,FRACTN,FRCTNO



# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 61128 "corsika.F" 2

      DOUBLE PRECISION CPHIJ,SPHIJ,DPFUNC,RANNOR,PTOT
      DOUBLE PRECISION FAC1,FAC2
      INTEGER          LL
# 61141 "corsika.F"
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

      SAVE
      EXTERNAL         DPFUNC,RANNOR
C-----------------------------------------------------------------------


      IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=0,9),WEIGHT
  444   FORMAT(' HDPM  : CURPAR=',1P,11E11.3)





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

# 61178 "corsika.F"

# 61192 "corsika.F"
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






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







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

# 61878 "corsika.F"

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

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

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
# 61930 "corsika.F"
          ENDIF



          GOTO 140

        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

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
# 61975 "corsika.F"
          ENDIF



          GOTO 140

        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





        CALL ADDANG4( COSTHE,PHIX,PHIY, COSTET,CPHIJ,SPHIJ,
     *                          SECPAR(2),SECPAR(3),SECPAR(4) )

        IF ( SECPAR(2) .LT. -1.D0 ) THEN



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

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
# 62037 "corsika.F"
          ENDIF



          GOTO 140

        ENDIF
C  PUT SECONDARY PARTICLES ON STACK, IF NOT GOING UPWARDS
        IF ( J .GT. 2 ) THEN
# 62055 "corsika.F"
          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
# 62080 "corsika.F"
          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
# 62140 "corsika.F"

 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 )

      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







      ENDIF


      coastProjId = nint(curpar(0))
      coastTargId = nint(tar)
      coastX = curpar(7)
      coastY = curpar(8)

      coastZ = curpar(14)





      coastT = curpar(6)
      coastE = pama(coastProjId)*curpar(1)
      coastCX = sigair
      coastEl = elasti
      call interaction(coastX)


      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)





# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"



      COMMON /CRINTER/ AVCH,AVCH3,DC0,DLOGS,DMLOG,ECMDIF,ECMDPM,ELAB,
     *                 FNEUT,FNEUT2,GNU,PLAB,POSC2,POSC3,POSN2,POSN3,
     *                 RC3TO2,S,SEUGF,SEUGP,SLOG,SLOGSQ,SMLOG,
     *                 WIDC2,WIDC3,WIDN2,WIDN3,YCM,YY0,ZN,
     *                 IDIF,ITAR
      DOUBLE PRECISION AVCH,AVCH3,DC0,DLOGS,DMLOG,ECMDIF,ECMDPM,ELAB,
     *                 FNEUT,FNEUT2,GNU,PLAB,POSC2,POSC3,POSN2,POSN3,
     *                 RC3TO2,S,SEUGF,SEUGP,SLOG,SLOGSQ,SMLOG,
     *                 WIDC2,WIDC3,WIDN2,WIDN3,YCM,YY0,ZN
      INTEGER          IDIF,ITAR











# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"



      COMMON /CRNEWPAR/EA,PT2,PX,PY,TMAS,YR,ITYP,
     *                 IA1,IA2,IB1,IB2,IC1,IC2,ID1,ID2,IE1,IE2,IF1,IF2,
     *                 IG1,IG2,IH1,IH2,II1,II2,IJ1,NTOT
      DOUBLE PRECISION EA(3000),PT2(3000),PX(3000),PY(3000),TMAS(3000),
     *                 YR(3000)
      INTEGER          ITYP(3000),
     *                 IA1,IA2,IB1,IB2,IC1,IC2,ID1,ID2,IE1,IE2,IF1,IF2,
     *                 IG1,IG2,IH1,IH2,II1,II2,IJ1,NTOT



# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"








      COMMON /CRPAM/   PAMA,SIGNUM,RESTMS,DECTIM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000),
     *                 DECTIM(200)




# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 62232 "corsika.F" 2

      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)






# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"



      COMMON /CRINTER/ AVCH,AVCH3,DC0,DLOGS,DMLOG,ECMDIF,ECMDPM,ELAB,
     *                 FNEUT,FNEUT2,GNU,PLAB,POSC2,POSC3,POSN2,POSN3,
     *                 RC3TO2,S,SEUGF,SEUGP,SLOG,SLOGSQ,SMLOG,
     *                 WIDC2,WIDC3,WIDN2,WIDN3,YCM,YY0,ZN,
     *                 IDIF,ITAR
      DOUBLE PRECISION AVCH,AVCH3,DC0,DLOGS,DMLOG,ECMDIF,ECMDPM,ELAB,
     *                 FNEUT,FNEUT2,GNU,PLAB,POSC2,POSC3,POSN2,POSN3,
     *                 RC3TO2,S,SEUGF,SEUGP,SLOG,SLOGSQ,SMLOG,
     *                 WIDC2,WIDC3,WIDN2,WIDN3,YCM,YY0,ZN
      INTEGER          IDIF,ITAR











# 3912 "corsika.h"

















      COMMON /CRLEPAR/ LEPAR1,LEPAR2,LASTPI,NRESPC,NRESPN,NCPLUS
      INTEGER          LEPAR1,LEPAR2,LASTPI,NRESPC,NRESPN,NCPLUS



# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"



      COMMON /CRNEWPAR/EA,PT2,PX,PY,TMAS,YR,ITYP,
     *                 IA1,IA2,IB1,IB2,IC1,IC2,ID1,ID2,IE1,IE2,IF1,IF2,
     *                 IG1,IG2,IH1,IH2,II1,II2,IJ1,NTOT
      DOUBLE PRECISION EA(3000),PT2(3000),PX(3000),PY(3000),TMAS(3000),
     *                 YR(3000)
      INTEGER          ITYP(3000),
     *                 IA1,IA2,IB1,IB2,IC1,IC2,ID1,ID2,IE1,IE2,IF1,IF2,
     *                 IG1,IG2,IH1,IH2,II1,II2,IJ1,NTOT



# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"

























      COMMON /CRRANDPA/RD,FAC,U1,U2,NSEQ,ISEED,KNOR
      DOUBLE PRECISION RD(3000),FAC,U1,U2



      INTEGER          ISEED(3,10),NSEQ

      LOGICAL          KNOR



# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 62326 "corsika.F" 2

      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)
# 62411 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"



      COMMON /CRINTER/ AVCH,AVCH3,DC0,DLOGS,DMLOG,ECMDIF,ECMDPM,ELAB,
     *                 FNEUT,FNEUT2,GNU,PLAB,POSC2,POSC3,POSN2,POSN3,
     *                 RC3TO2,S,SEUGF,SEUGP,SLOG,SLOGSQ,SMLOG,
     *                 WIDC2,WIDC3,WIDN2,WIDN3,YCM,YY0,ZN,
     *                 IDIF,ITAR
      DOUBLE PRECISION AVCH,AVCH3,DC0,DLOGS,DMLOG,ECMDIF,ECMDPM,ELAB,
     *                 FNEUT,FNEUT2,GNU,PLAB,POSC2,POSC3,POSN2,POSN3,
     *                 RC3TO2,S,SEUGF,SEUGP,SLOG,SLOGSQ,SMLOG,
     *                 WIDC2,WIDC3,WIDN2,WIDN3,YCM,YY0,ZN
      INTEGER          IDIF,ITAR











# 3912 "corsika.h"

















      COMMON /CRLEPAR/ LEPAR1,LEPAR2,LASTPI,NRESPC,NRESPN,NCPLUS
      INTEGER          LEPAR1,LEPAR2,LASTPI,NRESPC,NRESPN,NCPLUS



# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"



      COMMON /CRNEWPAR/EA,PT2,PX,PY,TMAS,YR,ITYP,
     *                 IA1,IA2,IB1,IB2,IC1,IC2,ID1,ID2,IE1,IE2,IF1,IF2,
     *                 IG1,IG2,IH1,IH2,II1,II2,IJ1,NTOT
      DOUBLE PRECISION EA(3000),PT2(3000),PX(3000),PY(3000),TMAS(3000),
     *                 YR(3000)
      INTEGER          ITYP(3000),
     *                 IA1,IA2,IB1,IB2,IC1,IC2,ID1,ID2,IE1,IE2,IF1,IF2,
     *                 IG1,IG2,IH1,IH2,II1,II2,IJ1,NTOT



# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"








      COMMON /CRPAM/   PAMA,SIGNUM,RESTMS,DECTIM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000),
     *                 DECTIM(200)






      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL





      DOUBLE PRECISION GAMMA,COSTHE,PHIX,PHIY,H,T,X,Y,CHI,BETA,GCM,ECM

     *                 ,WEIGHT


     *                 ,HAPP,COSTAP,COSTEA




      EQUIVALENCE      (CURPAR(1), GAMMA ), (CURPAR(2), COSTHE),
     *                 (CURPAR(3), PHIX  ), (CURPAR(4), PHIY  ),
     *                 (CURPAR(5), H     ), (CURPAR(6), T     ),
     *                 (CURPAR(7), X     ), (CURPAR(8), Y     ),
     *                 (CURPAR(9), CHI   ), (CURPAR(10),BETA  ),
     *                 (CURPAR(11),GCM   ), (CURPAR(12),ECM   )

     *                ,(CURPAR(13),WEIGHT)


     *                ,(CURPAR(14),HAPP  ), (CURPAR(15),COSTAP),
     *                 (CURPAR(16),COSTEA)















# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"

























      COMMON /CRRANDPA/RD,FAC,U1,U2,NSEQ,ISEED,KNOR
      DOUBLE PRECISION RD(3000),FAC,U1,U2



      INTEGER          ISEED(3,10),NSEQ

      LOGICAL          KNOR



# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"



      COMMON /CRVKIN/  BETACM
      DOUBLE PRECISION BETACM










     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 62411 "corsika.F" 2

      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)






# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"











      COMMON /CRCONSTA/PI,PI2,OB3,TB3,ENEPER,SQRT3
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER,SQRT3












































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"

















      COMMON /CRLEPAR/ LEPAR1,LEPAR2,LASTPI,NRESPC,NRESPN,NCPLUS
      INTEGER          LEPAR1,LEPAR2,LASTPI,NRESPC,NRESPN,NCPLUS



# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"

























      COMMON /CRRANDPA/RD,FAC,U1,U2,NSEQ,ISEED,KNOR
      DOUBLE PRECISION RD(3000),FAC,U1,U2



      INTEGER          ISEED(3,10),NSEQ

      LOGICAL          KNOR



# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



      COMMON /CRRESON/ RDRES,RESRAN,IRESPAR
      DOUBLE PRECISION RDRES(2),RESRAN(0:1000000)
      INTEGER          IRESPAR













      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 62529 "corsika.F" 2

      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)



# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"



      COMMON /CRINTER/ AVCH,AVCH3,DC0,DLOGS,DMLOG,ECMDIF,ECMDPM,ELAB,
     *                 FNEUT,FNEUT2,GNU,PLAB,POSC2,POSC3,POSN2,POSN3,
     *                 RC3TO2,S,SEUGF,SEUGP,SLOG,SLOGSQ,SMLOG,
     *                 WIDC2,WIDC3,WIDN2,WIDN3,YCM,YY0,ZN,
     *                 IDIF,ITAR
      DOUBLE PRECISION AVCH,AVCH3,DC0,DLOGS,DMLOG,ECMDIF,ECMDPM,ELAB,
     *                 FNEUT,FNEUT2,GNU,PLAB,POSC2,POSC3,POSN2,POSN3,
     *                 RC3TO2,S,SEUGF,SEUGP,SLOG,SLOGSQ,SMLOG,
     *                 WIDC2,WIDC3,WIDN2,WIDN3,YCM,YY0,ZN
      INTEGER          IDIF,ITAR











# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 62888 "corsika.F" 2

      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 <N_PHOTON>
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)
# 62983 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"











      COMMON /CRCONSTA/PI,PI2,OB3,TB3,ENEPER,SQRT3
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER,SQRT3









































      COMMON /CREDECAY/CETA
      DOUBLE PRECISION CETA(5)

































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"


















      COMMON /CRINDICE/NNUCN,NKA0,NHYPN,NETA,NETAS,NPIZER,
     *                 NNC,NKC,NHC,NPC,NCH,NNN,NKN,NHN,NET,NPN
      INTEGER          NNUCN(2:3),NKA0(2:3),NHYPN(2:3),NETA(2:3,1:4),
     *                 NETAS(2:3),NPIZER(2:3),
     *                 NNC,NKC,NHC,NPC,NCH,NNN,NKN,NHN,NET,NPN





      COMMON /CRINTER/ AVCH,AVCH3,DC0,DLOGS,DMLOG,ECMDIF,ECMDPM,ELAB,
     *                 FNEUT,FNEUT2,GNU,PLAB,POSC2,POSC3,POSN2,POSN3,
     *                 RC3TO2,S,SEUGF,SEUGP,SLOG,SLOGSQ,SMLOG,
     *                 WIDC2,WIDC3,WIDN2,WIDN3,YCM,YY0,ZN,
     *                 IDIF,ITAR
      DOUBLE PRECISION AVCH,AVCH3,DC0,DLOGS,DMLOG,ECMDIF,ECMDPM,ELAB,
     *                 FNEUT,FNEUT2,GNU,PLAB,POSC2,POSC3,POSN2,POSN3,
     *                 RC3TO2,S,SEUGF,SEUGP,SLOG,SLOGSQ,SMLOG,
     *                 WIDC2,WIDC3,WIDN2,WIDN3,YCM,YY0,ZN
      INTEGER          IDIF,ITAR











# 3912 "corsika.h"

















      COMMON /CRLEPAR/ LEPAR1,LEPAR2,LASTPI,NRESPC,NRESPN,NCPLUS
      INTEGER          LEPAR1,LEPAR2,LASTPI,NRESPC,NRESPN,NCPLUS



# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"

























      COMMON /CRRANDPA/RD,FAC,U1,U2,NSEQ,ISEED,KNOR
      DOUBLE PRECISION RD(3000),FAC,U1,U2



      INTEGER          ISEED(3,10),NSEQ

      LOGICAL          KNOR



# 4432 "corsika.h"

# 4441 "corsika.h"



      COMMON /CRRATIOS/RPI0R,RPIER,RPEKR,RPEKNR,PPICH,PPINCH,PPNKCH,
     *                 ISEL,NEUTOT,NTOTEM
      DOUBLE PRECISION RPI0R,RPIER,RPEKR,RPEKNR,PPICH,PPINCH,PPNKCH
      INTEGER          ISEL,NEUTOT,NTOTEM










# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 62983 "corsika.F" 2

      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)





# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"



      COMMON /CRINTER/ AVCH,AVCH3,DC0,DLOGS,DMLOG,ECMDIF,ECMDPM,ELAB,
     *                 FNEUT,FNEUT2,GNU,PLAB,POSC2,POSC3,POSN2,POSN3,
     *                 RC3TO2,S,SEUGF,SEUGP,SLOG,SLOGSQ,SMLOG,
     *                 WIDC2,WIDC3,WIDN2,WIDN3,YCM,YY0,ZN,
     *                 IDIF,ITAR
      DOUBLE PRECISION AVCH,AVCH3,DC0,DLOGS,DMLOG,ECMDIF,ECMDPM,ELAB,
     *                 FNEUT,FNEUT2,GNU,PLAB,POSC2,POSC3,POSN2,POSN3,
     *                 RC3TO2,S,SEUGF,SEUGP,SLOG,SLOGSQ,SMLOG,
     *                 WIDC2,WIDC3,WIDN2,WIDN3,YCM,YY0,ZN
      INTEGER          IDIF,ITAR











# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"



      COMMON /CRNEWPAR/EA,PT2,PX,PY,TMAS,YR,ITYP,
     *                 IA1,IA2,IB1,IB2,IC1,IC2,ID1,ID2,IE1,IE2,IF1,IF2,
     *                 IG1,IG2,IH1,IH2,II1,II2,IJ1,NTOT
      DOUBLE PRECISION EA(3000),PT2(3000),PX(3000),PY(3000),TMAS(3000),
     *                 YR(3000)
      INTEGER          ITYP(3000),
     *                 IA1,IA2,IB1,IB2,IC1,IC2,ID1,ID2,IE1,IE2,IF1,IF2,
     *                 IG1,IG2,IH1,IH2,II1,II2,IJ1,NTOT



# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"

























      COMMON /CRRANDPA/RD,FAC,U1,U2,NSEQ,ISEED,KNOR
      DOUBLE PRECISION RD(3000),FAC,U1,U2



      INTEGER          ISEED(3,10),NSEQ

      LOGICAL          KNOR



# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 63216 "corsika.F" 2

      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)
# 63390 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"



      COMMON /CRAVPT/  AVPT,AVPK,AVPN,AVPH,AVPE
      DOUBLE PRECISION AVPT,AVPK,AVPN,AVPH,AVPE










# 3655 "corsika.h"

# 3705 "corsika.h"















































      COMMON /CRDPMFLG/NFLAIN,NFLDIF,NFLPI0,NFLCHE,NFLPIF,NFRAGM
      INTEGER          NFLAIN,NFLDIF,NFLPI0,NFLCHE,NFLPIF,NFRAGM








































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"


















      COMMON /CRINDICE/NNUCN,NKA0,NHYPN,NETA,NETAS,NPIZER,
     *                 NNC,NKC,NHC,NPC,NCH,NNN,NKN,NHN,NET,NPN
      INTEGER          NNUCN(2:3),NKA0(2:3),NHYPN(2:3),NETA(2:3,1:4),
     *                 NETAS(2:3),NPIZER(2:3),
     *                 NNC,NKC,NHC,NPC,NCH,NNN,NKN,NHN,NET,NPN





      COMMON /CRINTER/ AVCH,AVCH3,DC0,DLOGS,DMLOG,ECMDIF,ECMDPM,ELAB,
     *                 FNEUT,FNEUT2,GNU,PLAB,POSC2,POSC3,POSN2,POSN3,
     *                 RC3TO2,S,SEUGF,SEUGP,SLOG,SLOGSQ,SMLOG,
     *                 WIDC2,WIDC3,WIDN2,WIDN3,YCM,YY0,ZN,
     *                 IDIF,ITAR
      DOUBLE PRECISION AVCH,AVCH3,DC0,DLOGS,DMLOG,ECMDIF,ECMDPM,ELAB,
     *                 FNEUT,FNEUT2,GNU,PLAB,POSC2,POSC3,POSN2,POSN3,
     *                 RC3TO2,S,SEUGF,SEUGP,SLOG,SLOGSQ,SMLOG,
     *                 WIDC2,WIDC3,WIDN2,WIDN3,YCM,YY0,ZN
      INTEGER          IDIF,ITAR











# 3912 "corsika.h"

















      COMMON /CRLEPAR/ LEPAR1,LEPAR2,LASTPI,NRESPC,NRESPN,NCPLUS
      INTEGER          LEPAR1,LEPAR2,LASTPI,NRESPC,NRESPN,NCPLUS



# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"



      COMMON /CRNEWPAR/EA,PT2,PX,PY,TMAS,YR,ITYP,
     *                 IA1,IA2,IB1,IB2,IC1,IC2,ID1,ID2,IE1,IE2,IF1,IF2,
     *                 IG1,IG2,IH1,IH2,II1,II2,IJ1,NTOT
      DOUBLE PRECISION EA(3000),PT2(3000),PX(3000),PY(3000),TMAS(3000),
     *                 YR(3000)
      INTEGER          ITYP(3000),
     *                 IA1,IA2,IB1,IB2,IC1,IC2,ID1,ID2,IE1,IE2,IF1,IF2,
     *                 IG1,IG2,IH1,IH2,II1,II2,IJ1,NTOT



# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"








      COMMON /CRPAM/   PAMA,SIGNUM,RESTMS,DECTIM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000),
     *                 DECTIM(200)




# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"

























      COMMON /CRRANDPA/RD,FAC,U1,U2,NSEQ,ISEED,KNOR
      DOUBLE PRECISION RD(3000),FAC,U1,U2



      INTEGER          ISEED(3,10),NSEQ

      LOGICAL          KNOR



# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 63390 "corsika.F" 2

      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)




# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"











      COMMON /CRCONSTA/PI,PI2,OB3,TB3,ENEPER,SQRT3
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER,SQRT3












































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"

























      COMMON /CRRANDPA/RD,FAC,U1,U2,NSEQ,ISEED,KNOR
      DOUBLE PRECISION RD(3000),FAC,U1,U2



      INTEGER          ISEED(3,10),NSEQ

      LOGICAL          KNOR



# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 63681 "corsika.F" 2

      SAVE
C-----------------------------------------------------------------------

CC    IF ( DEBUG ) WRITE(MDEBUG,*) 'PTRAM : ZN=',SNGL(ZN)

C  TWO RANDOM NUMBERS
      CALL RMMARD( RD,2,1 )
C  GENERATE <P_T>
      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)




# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"











      COMMON /CRCONSTA/PI,PI2,OB3,TB3,ENEPER,SQRT3
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER,SQRT3












































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"

























      COMMON /CRRANDPA/RD,FAC,U1,U2,NSEQ,ISEED,KNOR
      DOUBLE PRECISION RD(3000),FAC,U1,U2



      INTEGER          ISEED(3,10),NSEQ

      LOGICAL          KNOR



# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 63754 "corsika.F" 2

      SAVE
C-----------------------------------------------------------------------

CC    IF ( DEBUG ) WRITE(MDEBUG,*) 'PTRAN : ZN=',SNGL(ZN)

C  TWO RANDOM NUMBERS
      CALL RMMARD( RD,2,1 )
C  GENERATE <P_T>   (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 OMEGA, 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
# 63822 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"











      COMMON /CRCONSTA/PI,PI2,OB3,TB3,ENEPER,SQRT3
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER,SQRT3




















      COMMON /CRDECAYC/GAM345,COS345,PHI345
      DOUBLE PRECISION GAM345(3),COS345(3),PHI345(3)






















































# 3811 "corsika.h"

# 3824 "corsika.h"










      COMMON /CRGENER/ GEN,ALEVEL
      DOUBLE PRECISION GEN,ALEVEL











# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"
























      INTEGER          LNGMAX
      PARAMETER        (LNGMAX = 15000)
      INTEGER          TYPE1
      PARAMETER        (TYPE1 = 0)
      INTEGER          TYPE2
      PARAMETER        (TYPE2 = 1)
      INTEGER          TYPE3
      PARAMETER        (TYPE3 = 2)
      INTEGER          TYPE4
      PARAMETER        (TYPE4 = 3)
      COMMON /CRLONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP



     *                ,LLONGI,FLGFIT
# 3961 "corsika.h"
      DOUBLE PRECISION ADLONG(0:LNGMAX,19),AELONG(0:LNGMAX,10),
     *                 APLONG(0:LNGMAX,10),DLONG(0:LNGMAX,19),
     *                 ELONG(0:LNGMAX,10),
     *                 HLONG(0:LNGMAX),PLONG(0:LNGMAX,10),
     *                 SDLONG(0:LNGMAX,19),SELONG(0:LNGMAX,10),
     *                 SPLONG(0:LNGMAX,10),THSTEP,THSTPI




      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT

      COMMON /CRSLANT/ RLONG,THCKRL,CTH,STHCPH,STHSPH,RLOFF
      DOUBLE PRECISION RLONG(0:LNGMAX),THCKRL(0:LNGMAX),
     *                 CTH,STHCPH,STHSPH,RLOFF


















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"








      COMMON /CRPAM/   PAMA,SIGNUM,RESTMS,DECTIM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000),
     *                 DECTIM(200)






      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL





      DOUBLE PRECISION GAMMA,COSTHE,PHIX,PHIY,H,T,X,Y,CHI,BETA,GCM,ECM

     *                 ,WEIGHT


     *                 ,HAPP,COSTAP,COSTEA




      EQUIVALENCE      (CURPAR(1), GAMMA ), (CURPAR(2), COSTHE),
     *                 (CURPAR(3), PHIX  ), (CURPAR(4), PHIY  ),
     *                 (CURPAR(5), H     ), (CURPAR(6), T     ),
     *                 (CURPAR(7), X     ), (CURPAR(8), Y     ),
     *                 (CURPAR(9), CHI   ), (CURPAR(10),BETA  ),
     *                 (CURPAR(11),GCM   ), (CURPAR(12),ECM   )

     *                ,(CURPAR(13),WEIGHT)


     *                ,(CURPAR(14),HAPP  ), (CURPAR(15),COSTAP),
     *                 (CURPAR(16),COSTEA)















# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"



      COMMON /CRPOLAR/ POLART,POLARF
      DOUBLE PRECISION POLART,POLARF




















      COMMON /CRRANDPA/RD,FAC,U1,U2,NSEQ,ISEED,KNOR
      DOUBLE PRECISION RD(3000),FAC,U1,U2



      INTEGER          ISEED(3,10),NSEQ

      LOGICAL          KNOR



# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



      COMMON /CRRESON/ RDRES,RESRAN,IRESPAR
      DOUBLE PRECISION RDRES(2),RESRAN(0:1000000)
      INTEGER          IRESPAR













      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 63822 "corsika.F" 2

      DOUBLE PRECISION FAC1,FAC2
      INTEGER          I,KK,M3,M4,IRESP
      SAVE





C-----------------------------------------------------------------------


      IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=0,9),WEIGHT
  444 FORMAT(' RESDEC: CURPAR=',1P,11E11.3)





C  COPY VERTEX COORDINATES INTO SECPAR
      DO  KK = 5, 8
        SECPAR(KK) = CURPAR(KK)
      ENDDO
      SECPAR( 9) = GEN
      SECPAR(10) = ALEVEL

      SECPAR(13) = WEIGHT


      SECPAR(14) = CURPAR(14)
      SECPAR(15) = CURPAR(15)
      SECPAR(16) = CURPAR(16)
# 63872 "corsika.F"
  
      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.991524 = 89.96252
        IF     ( RD(1) .LE. 0.8996252D0 ) 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 ( SECPAR(2) .GE. C(29) ) THEN



              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

                  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






                ENDIF
              ENDIF
# 64031 "corsika.F"
            ENDIF
          ENDDO

C - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - - - - - 
C  BRANCHING RATIO IS 8.28%, BUT WE NEGLECT SMALL BRANCHINGS,
C  SO WE USE (89.86252 + 8.4718)/0.991524 = 98.43332 %
        ELSEIF ( RD(1) .LE. 0.9843332D0 ) THEN
C  DECAY    OMEGA  ---->  PI(0) + GAMMA
          CALL DECAY1( ITYPE,7,1 )

C - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - - - - - 
C  BRANCHING RATIO IS 1.53%, BUT WE NEGLECT SMALL BRANCHINGS,
C  SO WE USE (89.96252 + 8.47180 + 1.54307) = 99.97739% 
        ELSEIF ( RD(1) .LE. 0.9997739D0 ) THEN
C  DECAY    OMEGA  ---->  PI(+) + PI(-)
          CALL DECAY1( ITYPE,8,9 )

C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  RARE DECAYS:
C  BRANCHING RATIO IS 0.0134%, BUT WE NEGLECT MOST OF MALL BRANCHES
C  SO WE USE (89.96252 + 8.47180 + 1.54307 + 0.01351) = 99.99090%
        ELSEIF ( RD(1) .LE. 0.9999090D0 ) THEN
C  DECAY    OMEGA  ---->  MU(+) + MU(-) + PI(0)
C  (UNIFORM PHASE SPACE DISTRIBUTION IS ASSUMED FOR THIS DECAY)
          CALL DECAY6( PAMA(50), PAMA(5), PAMA(6), PAMA(7),
     *                 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 ( SECPAR(2) .GE. C(29) ) THEN



              SECPAR(0) = 4 + I
              SECPAR(1) = GAM345(I)
C  SET POLARIZATION
              IF     ( I .EQ. 1 ) THEN      ! MU(+)
                SECPAR(11) = POLART
                SECPAR(12) = POLARF
              ELSEIF (I .EQ. 2 ) THEN       ! MU(-)
                SECPAR(11) = -POLART
                SECPAR(12) = POLARF + PI
              ELSE                          ! PI(0)
                SECPAR(11) = 0.D0
                SECPAR(12) = 0.D0
              ENDIF
              CALL TSTACK
            ELSE
              IF ( LLONGI ) THEN
C  ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT
                IF     ( I .EQ. 3 ) THEN

                  DLONG(LHEIGH,17) = DLONG(LHEIGH,17)
     *                                   +GAM345(I) * PAMA(7) * WEIGHT



                ELSE

                  DLONG(LHEIGH,15) = DLONG(LHEIGH,15)
     *                                   +GAM345(I)*PAMA(5)*WEIGHT




                ENDIF
              ENDIF              
# 64127 "corsika.F"
            ENDIF
          ENDDO
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  BRANCHING RATIO IS 0.0090%, BUT WE NEGLECT NOST OF SMALL BRANCHES
C  SO WE USE (89.96252 + 8.47180 + 1.54307 + 0.01351 + 0.00907) = 
C                                               99.99997% 
        ELSE
C  DECAY    OMEGA  ---->  MU(+) + MU(-)
C  THE POLARIZATION OF THE MUONS IS HANDLED IN SUBR. DECAY2
          CALL DECAY2( ITYPE )

        ENDIF
C-----------------------------------------------------------------------
C  PHI MESON RESONANCE (COMES FROM PHOTONUCLEAR REACTION)

      ELSEIF ( ITYPE .EQ. 49 ) THEN
        CALL RMMARD( RD,1,1 )
C  BRANCHING RATIO IS 48.9%, BUT WE NEGLECT SMALL BRANCHINGS,
C  SO WE USE 48.9/0.997591 = 49.01808%
        IF     ( RD(1) .LE. 0.4901808D0 ) THEN
C  DECAY    PHI  ---->  K(+) + K(-)
          CALL DECAY1( ITYPE, 11, 12 )

C   BRANCHING RATIO IS 34.2%, BUT WE NEGLECT SMALL BRANCHINGS,
C  SO WE USE (49.01808 + 34.28258) = 83.30066%
        ELSEIF ( RD(1) .LE. 0.8330066D0 ) THEN
C  DECAY    PHI  ---->  K0L + K0S
          CALL DECAY1( ITYPE, 10, 16 )

C   BRANCHING RATIO IS 15.32%, BUT WE NEGLECT SMALL BRANCHINGS,
C  SO WE USE (49.01808 + 34.28258 + 15.35690) = 98.65765%
        ELSEIF ( RD(1) .LE. 0.9865765D0 ) THEN
C  DECAY    PHI  ---->  PI(+) + PI(-) + PI(0) 
C  (UNIFORM PHASE SPACE DISTRIBUTION IS ASSUMED FOR THIS DECAY)
          CALL DECAY6( PAMA(49), 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 ( SECPAR(2) .GE. C(29) ) THEN



              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

                  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






                ENDIF
              ENDIF
# 64233 "corsika.F"
            ENDIF
          ENDDO

C  BRANCHING RATIO IS 1.309%, BUT WE NEGLECT SMALL BRANCHINGS,
C  SO WE USE (49.01808 + 34.28258 + 15.35690 + 1.31216) = 99.96981%
        ELSEIF ( RD(1) .LE. 0.9996981D0 ) THEN
C  DECAY    PHI  ---->  ETA + GAMMA
          CALL DECAY1( ITYPE, 17, 1 )

C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  RARE DECAYS:
C  BRANCHING RATIO IS 2.87e-4, BUT WE NEGLECT SMALL BRANCHINGS,
C  SO WE USE (49.01808 + 34.28258 + 15.35690 + 1.31216 + 0.02876) 
C                                        = 99.99857%
        ELSEIF ( RD(1) .LE. 0.9999857D0 ) THEN
C  DECAY    PHI  ---->  MU(+) + MU(-)
C  THE POLARIZATION OF THE MUONS IS HANDLED IN SUBR. DECAY2
          CALL DECAY2( ITYPE )

C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  BRANCHING RATIO IS 1.4e-5, BUT WE NEGLECT MOST OF SMALL BRANCHES
C  SO WE USE (49.01808 + 34.28258 + 15.35690 + 1.31216 + 0.02876 + 
C              0.00140 ) = 99.9999997%
        ELSE
C  DECAY    PHI  ---->  MU(+) + MU(-) + GAMMA
C  (UNIFORM PHASE SPACE DISTRIBUTION IS ASSUMED FOR THIS DECAY)
          CALL DECAY6( PAMA(49), PAMA(5), PAMA(6), 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 ( SECPAR(2) .GE. C(29) ) THEN



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
              SECPAR(1) = GAM345(I)
# 64297 "corsika.F"
              CALL TSTACK
            ELSE
              IF ( LLONGI ) THEN
C  ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT
                IF ( I .EQ. 3 ) THEN

                  DLONG(LHEIGH,11) = DLONG(LHEIGH,11) + GAM345(I)*WEIGHT



                ELSE
C  ADD MUON ENERGY TO LONGITUDINAL ENERGY DEPOSIT

                  DLONG(LHEIGH,15) = DLONG(LHEIGH,15)
     *                                 + GAM345(I)*PAMA(5)*WEIGHT



                ENDIF
              ENDIF
# 64349 "corsika.F"
            ENDIF
          ENDDO
C  RESET POLARIZATION
          SECPAR(11) = 0.D0
          SECPAR(12) = 0.D0
        ENDIF

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

        WRITE(MONIOU,444) (CURPAR(I),I=0,9),CURPAR(13)



        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 <N> 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     = <N>  AVERAGE VALUE OF N
C   ECM    = CENTER OF MASS ENERGY (GEV)
C-----------------------------------------------------------------------

      IMPLICIT NONE



# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"

























      COMMON /CRRANDPA/RD,FAC,U1,U2,NSEQ,ISEED,KNOR
      DOUBLE PRECISION RD(3000),FAC,U1,U2



      INTEGER          ISEED(3,10),NSEQ

      LOGICAL          KNOR



# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 64432 "corsika.F" 2

      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,<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)
# 64497 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"















































      COMMON /CRDPMFLG/NFLAIN,NFLDIF,NFLPI0,NFLCHE,NFLPIF,NFRAGM
      INTEGER          NFLAIN,NFLDIF,NFLPI0,NFLCHE,NFLPIF,NFRAGM








































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"



      COMMON /CRGNUPR/ SE14,SE16,SE40
      DOUBLE PRECISION SE14(3,14),SE16(3,16),SE40(3,40)











# 3880 "corsika.h"



      COMMON /CRINTER/ AVCH,AVCH3,DC0,DLOGS,DMLOG,ECMDIF,ECMDPM,ELAB,
     *                 FNEUT,FNEUT2,GNU,PLAB,POSC2,POSC3,POSN2,POSN3,
     *                 RC3TO2,S,SEUGF,SEUGP,SLOG,SLOGSQ,SMLOG,
     *                 WIDC2,WIDC3,WIDN2,WIDN3,YCM,YY0,ZN,
     *                 IDIF,ITAR
      DOUBLE PRECISION AVCH,AVCH3,DC0,DLOGS,DMLOG,ECMDIF,ECMDPM,ELAB,
     *                 FNEUT,FNEUT2,GNU,PLAB,POSC2,POSC3,POSN2,POSN3,
     *                 RC3TO2,S,SEUGF,SEUGP,SLOG,SLOGSQ,SMLOG,
     *                 WIDC2,WIDC3,WIDN2,WIDN3,YCM,YY0,ZN
      INTEGER          IDIF,ITAR











# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"



      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL



# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"

























      COMMON /CRRANDPA/RD,FAC,U1,U2,NSEQ,ISEED,KNOR
      DOUBLE PRECISION RD(3000),FAC,U1,U2



      INTEGER          ISEED(3,10),NSEQ

      LOGICAL          KNOR



# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"











      COMMON /CRREST/  CONTNE,TAR,LIT
      DOUBLE PRECISION CONTNE(3),TAR
      INTEGER          LIT





      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"



      COMMON /CRSIGM/  SIGMA,SIGANN,SIGAIR,FRACTN,FRCTNO
      DOUBLE PRECISION SIGMA,SIGANN,SIGAIR,FRACTN,FRCTNO



# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 64497 "corsika.F" 2

      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

          WRITE(MONIOU,*) 'TARINT: UNKNOWN TARGET = ',SNGL(TAR)

        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

# 65413 "corsika.F"

# 67244 "corsika.F"

# 67607 "corsika.F"


*-- 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



# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"



      INTEGER          KSEQ



      PARAMETER        (KSEQ = 9)

      COMMON /CRRANMA3/CD,CINT,CM,TWOM24,TWOM48,MODCNS
      DOUBLE PRECISION CD,CINT,CM,TWOM24,TWOM48
      INTEGER          MODCNS





      COMMON /CRRANMA4/C,U,IJKL,I97,J97,NTOT,NTOT2,JSEQ
      DOUBLE PRECISION C(KSEQ),U(97,KSEQ),UNI
      INTEGER          IJKL(KSEQ),I97(KSEQ),J97(KSEQ),
     *                 NTOT(KSEQ),NTOT2(KSEQ),JSEQ



# 4450 "corsika.h"








# 4475 "corsika.h"

















# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 67628 "corsika.F" 2

      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



*-- 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


# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"


















      COMMON /CRPYTLIN/ IPTABL,IFLGPYE,IFLGPYW
      INTEGER           IPTABL(200),IFLGPYE,IFLGPYW



# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"

















# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 67699 "corsika.F" 2

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



*-- 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)



# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"


















      COMMON /CRPYTLIN/ IPTABL,IFLGPYE,IFLGPYW
      INTEGER           IPTABL(200),IFLGPYE,IFLGPYW



# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 67741 "corsika.F" 2

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
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

      IF ( DEBUG ) WRITE(MDEBUG,*) 'PYTDCSET-END'

      RETURN
      END



*-- 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)



# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"


















      COMMON /CRPYTLIN/ IPTABL,IFLGPYE,IFLGPYW
      INTEGER           IPTABL(200),IFLGPYE,IFLGPYW



# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 67842 "corsika.F" 2

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 ( 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)
# 67988 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























































































# 3811 "corsika.h"

# 3824 "corsika.h"










      COMMON /CRGENER/ GEN,ALEVEL
      DOUBLE PRECISION GEN,ALEVEL











# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"
























      INTEGER          LNGMAX
      PARAMETER        (LNGMAX = 15000)
      INTEGER          TYPE1
      PARAMETER        (TYPE1 = 0)
      INTEGER          TYPE2
      PARAMETER        (TYPE2 = 1)
      INTEGER          TYPE3
      PARAMETER        (TYPE3 = 2)
      INTEGER          TYPE4
      PARAMETER        (TYPE4 = 3)
      COMMON /CRLONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP



     *                ,LLONGI,FLGFIT
# 3961 "corsika.h"
      DOUBLE PRECISION ADLONG(0:LNGMAX,19),AELONG(0:LNGMAX,10),
     *                 APLONG(0:LNGMAX,10),DLONG(0:LNGMAX,19),
     *                 ELONG(0:LNGMAX,10),
     *                 HLONG(0:LNGMAX),PLONG(0:LNGMAX,10),
     *                 SDLONG(0:LNGMAX,19),SELONG(0:LNGMAX,10),
     *                 SPLONG(0:LNGMAX,10),THSTEP,THSTPI




      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT

      COMMON /CRSLANT/ RLONG,THCKRL,CTH,STHCPH,STHSPH,RLOFF
      DOUBLE PRECISION RLONG(0:LNGMAX),THCKRL(0:LNGMAX),
     *                 CTH,STHCPH,STHSPH,RLOFF


















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"








      COMMON /CRPAM/   PAMA,SIGNUM,RESTMS,DECTIM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000),
     *                 DECTIM(200)






      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL





      DOUBLE PRECISION GAMMA,COSTHE,PHIX,PHIY,H,T,X,Y,CHI,BETA,GCM,ECM

     *                 ,WEIGHT


     *                 ,HAPP,COSTAP,COSTEA




      EQUIVALENCE      (CURPAR(1), GAMMA ), (CURPAR(2), COSTHE),
     *                 (CURPAR(3), PHIX  ), (CURPAR(4), PHIY  ),
     *                 (CURPAR(5), H     ), (CURPAR(6), T     ),
     *                 (CURPAR(7), X     ), (CURPAR(8), Y     ),
     *                 (CURPAR(9), CHI   ), (CURPAR(10),BETA  ),
     *                 (CURPAR(11),GCM   ), (CURPAR(12),ECM   )

     *                ,(CURPAR(13),WEIGHT)


     *                ,(CURPAR(14),HAPP  ), (CURPAR(15),COSTAP),
     *                 (CURPAR(16),COSTEA)















# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"


















      COMMON /CRPYTLIN/ IPTABL,IFLGPYE,IFLGPYW
      INTEGER           IPTABL(200),IFLGPYE,IFLGPYW





      COMMON /CRRANDPA/RD,FAC,U1,U2,NSEQ,ISEED,KNOR
      DOUBLE PRECISION RD(3000),FAC,U1,U2



      INTEGER          ISEED(3,10),NSEQ

      LOGICAL          KNOR



# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 67988 "corsika.F" 2

C...The Pythia event record.





      COMMON/PYJETS/   N,NPAD,K(4000,5),P(4000,5),V(4000,5)

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
# 68011 "corsika.F"
      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

# 68054 "corsika.F"
      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


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

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

# 68451 "corsika.F"
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

        ELSE
          WRITE(MONIOU,*) 'PYTSTO: UNKNOWN PARTICLE CODE=',K(J,2)
C    *                     ,' GOTO 1001'
C         GOTO 1001
          STOP 1
        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
        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




        CALL ADDANG4( COSTHE,PHIX,PHIY, COSTET,CPHIV,SPHIV,
     *                          SECPAR(2),SECPAR(3),SECPAR(4) )

        IF ( SECPAR(2) .GE. C(29) ) THEN



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

              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
# 68540 "corsika.F"
            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
# 68590 "corsika.F"
            ENDIF
          ENDIF
# 68624 "corsika.F"
        ENDIF
        GOTO 1000
 999    IF ( LLONGI ) THEN
C  ADD NEUTRINO ENERGY TO LONGITUDINAL ENERGY DEPOSIT

          DLONG(LHEIGH,8) = DLONG(LHEIGH,8) + P(J,4) * WEIGHT



        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


# 70286 "corsika.F"

# 70326 "corsika.F"
*-- 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


# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"

















# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     









      COMMON /CRSIBLIN/ICTABL,ISTABL
      INTEGER          ICTABL(200),ISTABL(-99:99)










     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 70341 "corsika.F" 2

      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,  24,  33,  32,    !  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
# 70423 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"















































      COMMON /CRDPMFLG/NFLAIN,NFLDIF,NFLPI0,NFLCHE,NFLPIF,NFRAGM
      INTEGER          NFLAIN,NFLDIF,NFLPI0,NFLCHE,NFLPIF,NFRAGM








































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"








      COMMON /CRPAM/   PAMA,SIGNUM,RESTMS,DECTIM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000),
     *                 DECTIM(200)




# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     


      COMMON /CRSIBDBG/ISIBDB,ISDEBUG
      INTEGER          ISIBDB,ISDEBUG





      COMMON /CRSIBLIN/ICTABL,ISTABL
      INTEGER          ICTABL(200),ISTABL(-99:99)





      COMMON /CRSIBYLC/FSIBYL,FSIBSG,FSIBCH
      LOGICAL          FSIBYL,FSIBSG,FSIBCH



     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 70423 "corsika.F" 2

      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

C     CHARM PRODUCTION SWITCH
        if( FSIBCH ) then




           WRITE(MONIOU,*) 'SIBINI: EXTENDED CHARM TREATMENT: ',
     *      'DECAYS HANDLED BY PYTHIA, PROPAGATION AND REINTERACTION',
     *      'INCLUDED'

        else
           CALL NO_CHARM
           WRITE(MONIOU,*) 'SIBINI: CHARM TURNED OFF!'
        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

C     CHARM PRODUCTION SWITCH
        if( FSIBCH ) then




           WRITE(MONIOU,*) 'SIBINI: EXTENDED CHARM TREATMENT: ',
     *      'DECAYS HANDLED BY PYTHIA, PROPAGATION AND REINTERACTION',
     *      'INCLUDED'

        else
           CALL NO_CHARM
           WRITE(MONIOU,*) 'SIBINI: CHARM TURNED OFF!'
        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

C     CHARM PRODUCTION SWITCH
        if( FSIBCH ) then




           WRITE(MONIOU,*) 'SIBINI: EXTENDED CHARM TREATMENT: ',
     *      'DECAYS HANDLED BY PYTHIA, PROPAGATION AND REINTERACTION ',
     *      'INCLUDED'

        else
           CALL NO_CHARM
           WRITE(MONIOU,*) 'SIBINI: CHARM TURNED OFF!'
        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))

cdh
c  KEEP ETA_PRIME MESON
c     IDB(24) = -ABS(IDB(24))
C  KEEP RHO VECTOR MESON
      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 VECTOR MESON
      IDB(32) = -ABS(IDB(32))
C  KEEP PHI VECTOR MESON
      IDB(33) = -ABS(IDB(33))
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))


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 UNSTABLE PARTICLES SHOULD DECAY IN SIBYLL AS THEY ARE 
C  NOT TREATED BY CORSIKA 






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
# 70661 "corsika.F"

      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
# 70695 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"















































      COMMON /CRDPMFLG/NFLAIN,NFLDIF,NFLPI0,NFLCHE,NFLPIF,NFRAGM
      INTEGER          NFLAIN,NFLDIF,NFLPI0,NFLCHE,NFLPIF,NFRAGM








































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"



      COMMON /CRINTER/ AVCH,AVCH3,DC0,DLOGS,DMLOG,ECMDIF,ECMDPM,ELAB,
     *                 FNEUT,FNEUT2,GNU,PLAB,POSC2,POSC3,POSN2,POSN3,
     *                 RC3TO2,S,SEUGF,SEUGP,SLOG,SLOGSQ,SMLOG,
     *                 WIDC2,WIDC3,WIDN2,WIDN3,YCM,YY0,ZN,
     *                 IDIF,ITAR
      DOUBLE PRECISION AVCH,AVCH3,DC0,DLOGS,DMLOG,ECMDIF,ECMDPM,ELAB,
     *                 FNEUT,FNEUT2,GNU,PLAB,POSC2,POSC3,POSN2,POSN3,
     *                 RC3TO2,S,SEUGF,SEUGP,SLOG,SLOGSQ,SMLOG,
     *                 WIDC2,WIDC3,WIDN2,WIDN3,YCM,YY0,ZN
      INTEGER          IDIF,ITAR











# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"








      COMMON /CRPAM/   PAMA,SIGNUM,RESTMS,DECTIM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000),
     *                 DECTIM(200)






      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL





      DOUBLE PRECISION GAMMA,COSTHE,PHIX,PHIY,H,T,X,Y,CHI,BETA,GCM,ECM

     *                 ,WEIGHT


     *                 ,HAPP,COSTAP,COSTEA




      EQUIVALENCE      (CURPAR(1), GAMMA ), (CURPAR(2), COSTHE),
     *                 (CURPAR(3), PHIX  ), (CURPAR(4), PHIY  ),
     *                 (CURPAR(5), H     ), (CURPAR(6), T     ),
     *                 (CURPAR(7), X     ), (CURPAR(8), Y     ),
     *                 (CURPAR(9), CHI   ), (CURPAR(10),BETA  ),
     *                 (CURPAR(11),GCM   ), (CURPAR(12),ECM   )

     *                ,(CURPAR(13),WEIGHT)


     *                ,(CURPAR(14),HAPP  ), (CURPAR(15),COSTAP),
     *                 (CURPAR(16),COSTEA)















# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"

























      COMMON /CRRANDPA/RD,FAC,U1,U2,NSEQ,ISEED,KNOR
      DOUBLE PRECISION RD(3000),FAC,U1,U2



      INTEGER          ISEED(3,10),NSEQ

      LOGICAL          KNOR



# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"











      COMMON /CRREST/  CONTNE,TAR,LIT
      DOUBLE PRECISION CONTNE(3),TAR
      INTEGER          LIT





      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"



      COMMON /CRVKIN/  BETACM
      DOUBLE PRECISION BETACM










     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     


      COMMON /CRSIBDBG/ISIBDB,ISDEBUG
      INTEGER          ISIBDB,ISDEBUG





      COMMON /CRSIBLIN/ICTABL,ISTABL
      INTEGER          ICTABL(200),ISTABL(-99:99)










     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 70695 "corsika.F" 2

      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 )




C  IN DOUBT SET TARGET TO AIR
      IF ( TAR .GT. 20.D0 ) IATAR = 0
      IF ( IATAR .EQ. 99 ) IATAR = 0





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

          WRITE(MONIOU,444) (CURPAR(I),I=0,9),CURPAR(13)
 444      FORMAT(' SIBLNK: CURPAR=',1P,11E11.3)




          WRITE(MONIOU,*) 'SIBLNK: UNKNOWN CORSIKA PARTICLE TYPE=',ITYPE
         STOP 1
        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
# 70778 "corsika.F"
          LDIFF = 0


        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

          WRITE(MONIOU,444) (CURPAR(I),I=0,9),CURPAR(13)



          WRITE(MONIOU,*)'SIBLNK: ENERGY(CM)=',SQS,' TOO LOW FOR SIBYLL'
          STOP 1
        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

          WRITE(MONIOU,444) (CURPAR(I),I=0,9),CURPAR(13)



          WRITE(MONIOU,*)'SIBLNK: ENERGY(CM)=',SQS,' TOO LOW FOR SIBYLL'
          STOP 1
        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
# 70880 "corsika.F"
        LDIFF = 0

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
# 70929 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"








      COMMON /CRPAM/   PAMA,SIGNUM,RESTMS,DECTIM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000),
     *                 DECTIM(200)






      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL





      DOUBLE PRECISION GAMMA,COSTHE,PHIX,PHIY,H,T,X,Y,CHI,BETA,GCM,ECM

     *                 ,WEIGHT


     *                 ,HAPP,COSTAP,COSTEA




      EQUIVALENCE      (CURPAR(1), GAMMA ), (CURPAR(2), COSTHE),
     *                 (CURPAR(3), PHIX  ), (CURPAR(4), PHIY  ),
     *                 (CURPAR(5), H     ), (CURPAR(6), T     ),
     *                 (CURPAR(7), X     ), (CURPAR(8), Y     ),
     *                 (CURPAR(9), CHI   ), (CURPAR(10),BETA  ),
     *                 (CURPAR(11),GCM   ), (CURPAR(12),ECM   )

     *                ,(CURPAR(13),WEIGHT)


     *                ,(CURPAR(14),HAPP  ), (CURPAR(15),COSTAP),
     *                 (CURPAR(16),COSTEA)















# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"



















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"



      COMMON /CRSIGM/  SIGMA,SIGANN,SIGAIR,FRACTN,FRCTNO
      DOUBLE PRECISION SIGMA,SIGANN,SIGAIR,FRACTN,FRCTNO



# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     


      COMMON /CRSIBDBG/ISIBDB,ISDEBUG
      INTEGER          ISIBDB,ISDEBUG





      COMMON /CRSIBLIN/ICTABL,ISTABL
      INTEGER          ICTABL(200),ISTABL(-99:99)










     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 70929 "corsika.F" 2

      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,SIGdum1,SIGdum2,SSIGNUCN
      DOUBLE PRECISION SSIG0(41,2),AL,E0,SIGN,SIGO,SQS,SSIGNUCO,TT
      DOUBLE PRECISION FOX
      INTEGER          IA,J,J1,KK
      SAVE
      DATA FOX /0.21522D0/ !atomic percentage of 'non-nitrogen' in air
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     HADRON-NUCLEON CROSS SECTION
        SIGMA = SSIG(J1,KK)*(1.-TT) + SSIG(J1+1,KK)*TT       
C     TAKES CROSS-SECTION FROM TABLES CALCULATED DURING SIBYLL_INI
        CALL SIB_SIGMA_HNUC( KK,14,SQS,SIGN, SIGdum1, SIGdum2)
        CALL SIB_SIGMA_HNUC( KK,16,SQS,SIGO, SIGdum1, SIGdum2)        
        FRACTN =          (1.D0-FOX)*SIGN
        FRCTNO = FRACTN + FOX*SIGO
        SIGAIR = FRCTNO
      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,14,E0,SSIGNUCN )
        CALL SIGNUC_INI2( IA,16,E0,SSIGNUCO )
        FRACTN =          (1.D0-FOX)*SSIGNUCN
        FRCTNO = FRACTN + FOX*SSIGNUCO
        SIGAIR = FRCTNO
        SIGMA  = 0.D0

c        ECM0 = SQRT( (PAMA(13)+PAMA(14))**2 + E0 * (PAMA(13)+PAMA(14)) )
c        SQS  = ECM0
c        IF ( DEBUG ) WRITE(MDEBUG,*) 'SIBSIG: SQS=',SQS
c        AL   = DLOG10(SQS)
c        J1   = INT((AL - 1.D0)*10.D0) + 1
c        TT   = (AL-1.D0)*10.D0 - DBLE(J1-1)
cC  FROM SIB_SIGMA_PP
c        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
# 71050 "corsika.F"
# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"















































      COMMON /CRDPMFLG/NFLAIN,NFLDIF,NFLPI0,NFLCHE,NFLPIF,NFRAGM
      INTEGER          NFLAIN,NFLDIF,NFLPI0,NFLCHE,NFLPIF,NFRAGM



























      COMMON /CRELADPM/ELMEAN,ELMEAA,IELDPM,IELDPA
      DOUBLE PRECISION ELMEAN(40),ELMEAA(40)
      INTEGER          IELDPM(40,13),IELDPA(40,13)





      COMMON /CRELASTY/ELAST
      DOUBLE PRECISION ELAST



# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"



      COMMON /CRINTER/ AVCH,AVCH3,DC0,DLOGS,DMLOG,ECMDIF,ECMDPM,ELAB,
     *                 FNEUT,FNEUT2,GNU,PLAB,POSC2,POSC3,POSN2,POSN3,
     *                 RC3TO2,S,SEUGF,SEUGP,SLOG,SLOGSQ,SMLOG,
     *                 WIDC2,WIDC3,WIDN2,WIDN3,YCM,YY0,ZN,
     *                 IDIF,ITAR
      DOUBLE PRECISION AVCH,AVCH3,DC0,DLOGS,DMLOG,ECMDIF,ECMDPM,ELAB,
     *                 FNEUT,FNEUT2,GNU,PLAB,POSC2,POSC3,POSN2,POSN3,
     *                 RC3TO2,S,SEUGF,SEUGP,SLOG,SLOGSQ,SMLOG,
     *                 WIDC2,WIDC3,WIDN2,WIDN3,YCM,YY0,ZN
      INTEGER          IDIF,ITAR













      COMMON /CRISTA/  IFINET,IFINNU,IFINKA,IFINPI,IFINHY,IFINCM,IFINOT,
     *                 IFINRHO
      INTEGER          IFINET,IFINNU,IFINKA,IFINPI,IFINHY,IFINCM,IFINOT,
     *                 IFINRHO


























      INTEGER          LNGMAX
      PARAMETER        (LNGMAX = 15000)
      INTEGER          TYPE1
      PARAMETER        (TYPE1 = 0)
      INTEGER          TYPE2
      PARAMETER        (TYPE2 = 1)
      INTEGER          TYPE3
      PARAMETER        (TYPE3 = 2)
      INTEGER          TYPE4
      PARAMETER        (TYPE4 = 3)
      COMMON /CRLONGI/ ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP



     *                ,LLONGI,FLGFIT
# 3961 "corsika.h"
      DOUBLE PRECISION ADLONG(0:LNGMAX,19),AELONG(0:LNGMAX,10),
     *                 APLONG(0:LNGMAX,10),DLONG(0:LNGMAX,19),
     *                 ELONG(0:LNGMAX,10),
     *                 HLONG(0:LNGMAX),PLONG(0:LNGMAX,10),
     *                 SDLONG(0:LNGMAX,19),SELONG(0:LNGMAX,10),
     *                 SPLONG(0:LNGMAX,10),THSTEP,THSTPI




      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT

      COMMON /CRSLANT/ RLONG,THCKRL,CTH,STHCPH,STHSPH,RLOFF
      DOUBLE PRECISION RLONG(0:LNGMAX),THCKRL(0:LNGMAX),
     *                 CTH,STHCPH,STHSPH,RLOFF


















# 4005 "corsika.h"
















# 4047 "corsika.h"



      COMMON /CRMULT/  EKINL,MSMM,MULTMA,MULTOT
      DOUBLE PRECISION EKINL
      INTEGER          MSMM,MULTMA(40,13),MULTOT(40,13)



# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"










      COMMON /CROBSPAR/OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP,
     *                 THETPR,PHIPR,

     *                 CORRXY,







     *                 NOBSLV
      DOUBLE PRECISION OBSLEV(20),THCKOB(20),XOFF(20),YOFF(20),
     *                 HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2)

     *                 ,CORRXY







      INTEGER          NOBSLV










      COMMON /CRPAM/   PAMA,SIGNUM,RESTMS,DECTIM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000),
     *                 DECTIM(200)






      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL





      DOUBLE PRECISION GAMMA,COSTHE,PHIX,PHIY,H,T,X,Y,CHI,BETA,GCM,ECM

     *                 ,WEIGHT


     *                 ,HAPP,COSTAP,COSTEA




      EQUIVALENCE      (CURPAR(1), GAMMA ), (CURPAR(2), COSTHE),
     *                 (CURPAR(3), PHIX  ), (CURPAR(4), PHIY  ),
     *                 (CURPAR(5), H     ), (CURPAR(6), T     ),
     *                 (CURPAR(7), X     ), (CURPAR(8), Y     ),
     *                 (CURPAR(9), CHI   ), (CURPAR(10),BETA  ),
     *                 (CURPAR(11),GCM   ), (CURPAR(12),ECM   )

     *                ,(CURPAR(13),WEIGHT)


     *                ,(CURPAR(14),HAPP  ), (CURPAR(15),COSTAP),
     *                 (CURPAR(16),COSTEA)















# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"

























      COMMON /CRRANDPA/RD,FAC,U1,U2,NSEQ,ISEED,KNOR
      DOUBLE PRECISION RD(3000),FAC,U1,U2



      INTEGER          ISEED(3,10),NSEQ

      LOGICAL          KNOR



# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"








# 4475 "corsika.h"











      COMMON /CRREST/  CONTNE,TAR,LIT
      DOUBLE PRECISION CONTNE(3),TAR
      INTEGER          LIT





      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"



      COMMON /CRSIGM/  SIGMA,SIGANN,SIGAIR,FRACTN,FRCTNO
      DOUBLE PRECISION SIGMA,SIGANN,SIGAIR,FRACTN,FRCTNO



# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"



      COMMON /CRVKIN/  BETACM
      DOUBLE PRECISION BETACM










     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     









      COMMON /CRSIBLIN/ICTABL,ISTABL
      INTEGER          ICTABL(200),ISTABL(-99:99)





      COMMON /CRSIBYLC/FSIBYL,FSIBSG,FSIBCH
      LOGICAL          FSIBYL,FSIBSG,FSIBCH



     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 71050 "corsika.F" 2

      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,LLL

      INTEGER          IWOUNT







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

      SAVE





C-----------------------------------------------------------------------

      IF ( DEBUG ) WRITE(MDEBUG,*) 'SIBSTR:',NP+NPA,' SECONDARIES'

      EMAX   = 0.D0
      ELASTI = 0.D0
      ETOT   = 0.D0

# 71111 "corsika.F"
      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)

C  ELIMINATE TARGET SPECTATORS
              IF ( SECPAR(1) .LE. 1.D0 ) GOTO 90
              COSTHJ = MAX( -1.D0, MIN( 1.D0, PLONGLAB / PTOTLAB ) )
# 71158 "corsika.F"
            ELSE
              COSTHJ = MAX( -1.D0, MIN( 1.D0, PLONGLAB / PTOTLAB ) )
            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)
                IF ( ITYPJ .LT. 200 ) THEN
C  ELASTICITY FOR HADRON PROJECTILE
                  ELASTI = (EMAX/ELAB) 
                ELSE
C  ELSATICITY FOR NUCLEUS PROJECTILE
                  ELASTI = (EMAX/ELAB) * DBLE(ITYPE/100)
                ENDIF
              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 ( SECPAR(2) .GE. C(29) ) THEN
# 71201 "corsika.F"
              CALL TSTACK
            ELSE
              IF ( LLONGI ) THEN
C  ADD ENERGY OF CUTTED PARTCLE TO LONGITUDINAL ENERGY DEPOSIT
                IF     ( ITYPJ .EQ. 1                     ) THEN

                  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
# 71264 "corsika.F"
                ENDIF
              ENDIF
# 71295 "corsika.F"
            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 (  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
# 71330 "corsika.F"
              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
# 71346 "corsika.F"
                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
# 71364 "corsika.F"
                  CALL TSTACK
                  ETOT = ETOT + GAMMA * PAMA(402)
                  SECPAR(0) = 13.D0
# 71376 "corsika.F"
                  CALL TSTACK
                  ETOT = ETOT + GAMMA * PAMA(13)
                ELSE
C  DECAY INTO 1 ALPHA PARTICLE AND 1 PROTON
                  SECPAR(0) = 402.D0
# 71390 "corsika.F"
                  CALL TSTACK
                  ETOT = ETOT + GAMMA * PAMA(402)
                  SECPAR(0) = 14.D0
# 71402 "corsika.F"
                  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
# 71422 "corsika.F"
                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)
# 71436 "corsika.F"
                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)

C  ELIMINATE TARGET SPECTATORS
            IF ( SECPAR(1) .LE. 1.D0 ) GOTO 100
            COSTHJ = MAX( -1.D0, MIN( 1.D0, PLONGLAB / PTOTLAB ) )
# 71518 "corsika.F"
          ELSE
            COSTHJ = MAX( -1.D0, MIN( 1.D0, PLONGLAB / PTOTLAB ) )
          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 ( SECPAR(2) .GE. C(29) ) THEN
# 71555 "corsika.F"
            CALL TSTACK
          ELSE
            IF ( LLONGI ) THEN
C  ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT
              IF     ( ITYPJ .EQ. 1                     ) THEN

                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
# 71619 "corsika.F"
              ENDIF
            ENDIF
# 71650 "corsika.F"
          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 )

      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







      ENDIF


c  for sibyll
      coastProjId = nint(curpar(0))
      coastTargId = nint(tar)
      coastX = curpar(7)
      coastY = curpar(8)

      coastZ = curpar(14)





      coastT = curpar(6)
      coastE = pama(coastProjId)*curpar(1)
      coastCX = sigair
      coastEl = elasti
      call interaction(coastX)


      IF ( FIRSTI ) THEN
        TARG1I = TAR
        SIG1I  = SIGAIR
        ELAST  = ELASTI
C  RANDOM GENERATOR STATUS (SEQUENCE LLL=1) AT END OF EVENT
        LLL  = 1
        CALL RMMAQD( ISEED(1,LLL),LLL,'R' )
C  SEED
        ISEED1I(1) = ISEED(1,LLL)
C  NUMBER OF CALLS
        ISEED1I(2) = ISEED(2,LLL)
C  NUMBER OF BILLIONS
        ISEED1I(3) = ISEED(3,LLL)
        FIRSTI = .FALSE.
      ENDIF

# 71756 "corsika.F"

      RETURN
      END

*-- Author :    D. HECK IK FZK KARLSRUHE       06/12/1996
C=======================================================================

      SUBROUTINE SIGNUC_INI2( IA,IB,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   IB     = MASS NUMBER OF TARGET NUCLEUS (14 and 16 only!)
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,3), SIGQE(6,56,3)
      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,IK,IB
      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,1),J=1,6) /
     &3.900E+02,4.305E+02,5.019E+02,5.834E+02,6.791E+02,7.729E+02/
      DATA (SIGMA(J, 3,1),J=1,6) /
     &4.619E+02,5.031E+02,5.743E+02,6.642E+02,7.552E+02,8.597E+02/
      DATA (SIGMA(J, 4,1),J=1,6) /
     &4.918E+02,5.307E+02,6.002E+02,6.869E+02,7.880E+02,8.889E+02/
      DATA (SIGMA(J, 5,1),J=1,6) /
     &5.910E+02,6.336E+02,7.166E+02,8.095E+02,9.161E+02,1.021E+03/
      DATA (SIGMA(J, 6,1),J=1,6) /
     &6.966E+02,7.428E+02,8.269E+02,9.427E+02,1.058E+03,1.171E+03/
      DATA (SIGMA(J, 7,1),J=1,6) /
     &7.137E+02,7.614E+02,8.513E+02,9.561E+02,1.068E+03,1.182E+03/
      DATA (SIGMA(J, 8,1),J=1,6) /
     &7.544E+02,8.038E+02,8.914E+02,1.004E+03,1.120E+03,1.239E+03/
      DATA (SIGMA(J, 9,1),J=1,6) /
     &7.940E+02,8.464E+02,9.372E+02,1.057E+03,1.168E+03,1.295E+03/
      DATA (SIGMA(J, 10,1),J=1,6) /
     &8.061E+02,8.577E+02,9.443E+02,1.059E+03,1.186E+03,1.293E+03/
      DATA (SIGMA(J, 11,1),J=1,6) /
     &8.102E+02,8.643E+02,9.499E+02,1.065E+03,1.179E+03,1.303E+03/
      DATA (SIGMA(J, 12,1),J=1,6) /
     &8.561E+02,9.068E+02,9.899E+02,1.115E+03,1.234E+03,1.353E+03/
      DATA (SIGMA(J, 13,1),J=1,6) /
     &8.670E+02,9.201E+02,1.006E+03,1.126E+03,1.249E+03,1.370E+03/
      DATA (SIGMA(J, 14,1),J=1,6) /
     &9.126E+02,9.628E+02,1.056E+03,1.177E+03,1.293E+03,1.430E+03/
      DATA (SIGMA(J, 15,1),J=1,6) /
     &9.396E+02,9.931E+02,1.083E+03,1.213E+03,1.332E+03,1.453E+03/
      DATA (SIGMA(J, 16,1),J=1,6) /
     &9.944E+02,1.045E+03,1.145E+03,1.271E+03,1.389E+03,1.526E+03/
      DATA (SIGMA(J, 17,1),J=1,6) /
     &9.921E+02,1.047E+03,1.143E+03,1.264E+03,1.399E+03,1.516E+03/
      DATA (SIGMA(J, 18,1),J=1,6) /
     &1.044E+03,1.103E+03,1.204E+03,1.326E+03,1.462E+03,1.601E+03/
      DATA (SIGMA(J, 19,1),J=1,6) /
     &1.100E+03,1.147E+03,1.265E+03,1.388E+03,1.522E+03,1.663E+03/
      DATA (SIGMA(J, 20,1),J=1,6) /
     &1.144E+03,1.191E+03,1.308E+03,1.445E+03,1.570E+03,1.721E+03/
      DATA (SIGMA(J, 21,1),J=1,6) /
     &1.166E+03,1.224E+03,1.327E+03,1.460E+03,1.602E+03,1.747E+03/
      DATA (SIGMA(J, 22,1),J=1,6) /
     &1.158E+03,1.221E+03,1.327E+03,1.460E+03,1.598E+03,1.739E+03/
      DATA (SIGMA(J, 23,1),J=1,6) /
     &1.205E+03,1.266E+03,1.386E+03,1.508E+03,1.653E+03,1.794E+03/
      DATA (SIGMA(J, 24,1),J=1,6) /
     &1.222E+03,1.283E+03,1.398E+03,1.524E+03,1.678E+03,1.818E+03/
      DATA (SIGMA(J, 25,1),J=1,6) /
     &1.248E+03,1.307E+03,1.420E+03,1.562E+03,1.707E+03,1.856E+03/
      DATA (SIGMA(J, 26,1),J=1,6) /
     &1.266E+03,1.326E+03,1.435E+03,1.577E+03,1.729E+03,1.878E+03/
      DATA (SIGMA(J, 27,1),J=1,6) /
     &1.253E+03,1.315E+03,1.421E+03,1.558E+03,1.694E+03,1.859E+03/
      DATA (SIGMA(J, 28,1),J=1,6) /
     &1.300E+03,1.350E+03,1.457E+03,1.599E+03,1.742E+03,1.895E+03/
      DATA (SIGMA(J, 29,1),J=1,6) /
     &1.414E+03,1.489E+03,1.607E+03,1.757E+03,1.900E+03,2.081E+03/
      DATA (SIGMA(J, 30,1),J=1,6) /
     &1.351E+03,1.401E+03,1.523E+03,1.661E+03,1.820E+03,1.960E+03/
      DATA (SIGMA(J, 31,1),J=1,6) /
     &1.358E+03,1.432E+03,1.544E+03,1.687E+03,1.838E+03,1.981E+03/
      DATA (SIGMA(J, 32,1),J=1,6) /
     &1.377E+03,1.444E+03,1.559E+03,1.702E+03,1.851E+03,2.004E+03/
      DATA (SIGMA(J, 33,1),J=1,6) /
     &1.389E+03,1.465E+03,1.580E+03,1.727E+03,1.875E+03,2.023E+03/
      DATA (SIGMA(J, 34,1),J=1,6) /
     &1.414E+03,1.485E+03,1.595E+03,1.754E+03,1.905E+03,2.053E+03/
      DATA (SIGMA(J, 35,1),J=1,6) /
     &1.432E+03,1.505E+03,1.611E+03,1.758E+03,1.915E+03,2.075E+03/
      DATA (SIGMA(J, 36,1),J=1,6) /
     &1.443E+03,1.516E+03,1.631E+03,1.779E+03,1.928E+03,2.095E+03/
      DATA (SIGMA(J, 37,1),J=1,6) /
     &1.454E+03,1.529E+03,1.656E+03,1.792E+03,1.957E+03,2.102E+03/
      DATA (SIGMA(J, 38,1),J=1,6) /
     &1.479E+03,1.540E+03,1.667E+03,1.820E+03,1.970E+03,2.124E+03/
      DATA (SIGMA(J, 39,1),J=1,6) /
     &1.498E+03,1.561E+03,1.678E+03,1.837E+03,1.983E+03,2.147E+03/
      DATA (SIGMA(J, 40,1),J=1,6) /
     &1.506E+03,1.571E+03,1.701E+03,1.850E+03,2.006E+03,2.163E+03/
      DATA (SIGMA(J, 41,1),J=1,6) /
     &1.528E+03,1.598E+03,1.721E+03,1.867E+03,2.023E+03,2.171E+03/
      DATA (SIGMA(J, 42,1),J=1,6) /
     &1.540E+03,1.615E+03,1.729E+03,1.890E+03,2.041E+03,2.206E+03/
      DATA (SIGMA(J, 43,1),J=1,6) /
     &1.552E+03,1.624E+03,1.750E+03,1.907E+03,2.053E+03,2.218E+03/
      DATA (SIGMA(J, 44,1),J=1,6) /
     &1.569E+03,1.640E+03,1.758E+03,1.917E+03,2.065E+03,2.239E+03/
      DATA (SIGMA(J, 45,1),J=1,6) /
     &1.584E+03,1.654E+03,1.781E+03,1.930E+03,2.089E+03,2.267E+03/
      DATA (SIGMA(J, 46,1),J=1,6) /
     &1.601E+03,1.663E+03,1.794E+03,1.946E+03,2.110E+03,2.268E+03/
      DATA (SIGMA(J, 47,1),J=1,6) /
     &1.617E+03,1.681E+03,1.809E+03,1.966E+03,2.138E+03,2.290E+03/
      DATA (SIGMA(J, 48,1),J=1,6) /
     &1.626E+03,1.698E+03,1.829E+03,1.979E+03,2.146E+03,2.312E+03/
      DATA (SIGMA(J, 49,1),J=1,6) /
     &1.642E+03,1.724E+03,1.835E+03,1.994E+03,2.158E+03,2.321E+03/
      DATA (SIGMA(J, 50,1),J=1,6) /
     &1.654E+03,1.728E+03,1.852E+03,2.014E+03,2.183E+03,2.327E+03/
      DATA (SIGMA(J, 51,1),J=1,6) /
     &1.671E+03,1.749E+03,1.861E+03,2.030E+03,2.191E+03,2.362E+03/
      DATA (SIGMA(J, 52,1),J=1,6) /
     &1.681E+03,1.764E+03,1.882E+03,2.037E+03,2.198E+03,2.365E+03/
      DATA (SIGMA(J, 53,1),J=1,6) /
     &1.698E+03,1.767E+03,1.908E+03,2.062E+03,2.222E+03,2.382E+03/
      DATA (SIGMA(J, 54,1),J=1,6) /
     &1.714E+03,1.778E+03,1.912E+03,2.072E+03,2.227E+03,2.403E+03/
      DATA (SIGMA(J, 55,1),J=1,6) /
     &1.726E+03,1.803E+03,1.922E+03,2.075E+03,2.239E+03,2.419E+03/
      DATA (SIGMA(J, 56,1),J=1,6) /
     &1.753E+03,1.833E+03,1.956E+03,2.131E+03,2.279E+03,2.466E+03/
 
 
C  DATA ON 'QUASI-ELASTIC' NUCLEUS-AIR CROSS-SECTION
      DATA (SIGQE(J, 2,1),J=1,6) /
     &4.261E+01,3.981E+01,5.483E+01,9.091E+01,1.385E+02,1.947E+02/
      DATA (SIGQE(J, 3,1),J=1,6) /
     &4.194E+01,4.035E+01,5.667E+01,9.456E+01,1.461E+02,1.991E+02/
      DATA (SIGQE(J, 4,1),J=1,6) /
     &4.101E+01,3.922E+01,5.546E+01,9.422E+01,1.464E+02,2.058E+02/
      DATA (SIGQE(J, 5,1),J=1,6) /
     &4.606E+01,4.301E+01,6.119E+01,1.053E+02,1.588E+02,2.192E+02/
      DATA (SIGQE(J, 6,1),J=1,6) /
     &5.250E+01,4.912E+01,6.890E+01,1.094E+02,1.727E+02,2.339E+02/
      DATA (SIGQE(J, 7,1),J=1,6) /
     &4.974E+01,4.864E+01,6.644E+01,1.111E+02,1.715E+02,2.356E+02/
      DATA (SIGQE(J, 8,1),J=1,6) /
     &5.173E+01,5.004E+01,6.896E+01,1.156E+02,1.740E+02,2.367E+02/
      DATA (SIGQE(J, 9,1),J=1,6) /
     &5.229E+01,4.919E+01,7.108E+01,1.154E+02,1.751E+02,2.437E+02/
      DATA (SIGQE(J, 10,1),J=1,6) /
     &5.125E+01,5.075E+01,6.950E+01,1.180E+02,1.780E+02,2.459E+02/
      DATA (SIGQE(J, 11,1),J=1,6) /
     &5.122E+01,5.009E+01,6.848E+01,1.153E+02,1.772E+02,2.449E+02/
      DATA (SIGQE(J, 12,1),J=1,6) /
     &5.190E+01,5.036E+01,7.031E+01,1.197E+02,1.810E+02,2.529E+02/
      DATA (SIGQE(J, 13,1),J=1,6) /
     &5.337E+01,5.079E+01,7.131E+01,1.192E+02,1.797E+02,2.514E+02/
      DATA (SIGQE(J, 14,1),J=1,6) /
     &5.482E+01,5.338E+01,7.391E+01,1.217E+02,1.863E+02,2.543E+02/
      DATA (SIGQE(J, 15,1),J=1,6) /
     &5.503E+01,5.212E+01,7.422E+01,1.238E+02,1.888E+02,2.599E+02/
      DATA (SIGQE(J, 16,1),J=1,6) /
     &5.706E+01,5.476E+01,7.659E+01,1.301E+02,1.945E+02,2.643E+02/
      DATA (SIGQE(J, 17,1),J=1,6) /
     &5.764E+01,5.313E+01,7.540E+01,1.285E+02,1.924E+02,2.635E+02/
      DATA (SIGQE(J, 18,1),J=1,6) /
     &5.838E+01,5.552E+01,7.849E+01,1.290E+02,1.977E+02,2.691E+02/
      DATA (SIGQE(J, 19,1),J=1,6) /
     &6.135E+01,5.998E+01,8.314E+01,1.392E+02,2.046E+02,2.761E+02/
      DATA (SIGQE(J, 20,1),J=1,6) /
     &6.293E+01,5.879E+01,8.491E+01,1.365E+02,2.043E+02,2.842E+02/
      DATA (SIGQE(J, 21,1),J=1,6) /
     &6.376E+01,6.051E+01,8.558E+01,1.383E+02,2.108E+02,2.838E+02/
      DATA (SIGQE(J, 22,1),J=1,6) /
     &6.156E+01,6.113E+01,8.293E+01,1.367E+02,2.071E+02,2.788E+02/
      DATA (SIGQE(J, 23,1),J=1,6) /
     &6.489E+01,6.159E+01,8.602E+01,1.405E+02,2.113E+02,2.890E+02/
      DATA (SIGQE(J, 24,1),J=1,6) /
     &6.471E+01,6.160E+01,8.344E+01,1.398E+02,2.162E+02,2.874E+02/
      DATA (SIGQE(J, 25,1),J=1,6) /
     &6.581E+01,6.261E+01,8.805E+01,1.435E+02,2.123E+02,2.857E+02/
      DATA (SIGQE(J, 26,1),J=1,6) /
     &6.544E+01,6.353E+01,8.929E+01,1.421E+02,2.151E+02,2.966E+02/
      DATA (SIGQE(J, 27,1),J=1,6) /
     &6.543E+01,6.284E+01,8.540E+01,1.399E+02,2.134E+02,2.902E+02/
      DATA (SIGQE(J, 28,1),J=1,6) /
     &6.669E+01,6.396E+01,8.614E+01,1.415E+02,2.164E+02,2.915E+02/
      DATA (SIGQE(J, 29,1),J=1,6) /
     &6.987E+01,6.663E+01,9.115E+01,1.489E+02,2.288E+02,3.099E+02/
      DATA (SIGQE(J, 30,1),J=1,6) /
     &6.706E+01,6.456E+01,8.846E+01,1.464E+02,2.200E+02,3.003E+02/
      DATA (SIGQE(J, 31,1),J=1,6) /
     &6.752E+01,6.559E+01,9.113E+01,1.455E+02,2.259E+02,3.042E+02/
      DATA (SIGQE(J, 32,1),J=1,6) /
     &6.809E+01,6.459E+01,9.146E+01,1.470E+02,2.254E+02,2.987E+02/
      DATA (SIGQE(J, 33,1),J=1,6) /
     &6.862E+01,6.485E+01,9.169E+01,1.496E+02,2.264E+02,3.073E+02/
      DATA (SIGQE(J, 34,1),J=1,6) /
     &6.847E+01,6.590E+01,8.982E+01,1.503E+02,2.279E+02,3.027E+02/
      DATA (SIGQE(J, 35,1),J=1,6) /
     &7.032E+01,6.535E+01,9.131E+01,1.526E+02,2.229E+02,3.077E+02/
      DATA (SIGQE(J, 36,1),J=1,6) /
     &7.005E+01,6.783E+01,9.403E+01,1.522E+02,2.290E+02,3.102E+02/
      DATA (SIGQE(J, 37,1),J=1,6) /
     &6.892E+01,6.752E+01,9.283E+01,1.542E+02,2.297E+02,3.106E+02/
      DATA (SIGQE(J, 38,1),J=1,6) /
     &7.152E+01,6.644E+01,9.331E+01,1.511E+02,2.311E+02,3.164E+02/
      DATA (SIGQE(J, 39,1),J=1,6) /
     &6.976E+01,6.674E+01,9.349E+01,1.537E+02,2.315E+02,3.093E+02/
      DATA (SIGQE(J, 40,1),J=1,6) /
     &7.293E+01,6.687E+01,9.566E+01,1.544E+02,2.310E+02,3.175E+02/
      DATA (SIGQE(J, 41,1),J=1,6) /
     &7.195E+01,6.812E+01,9.500E+01,1.540E+02,2.319E+02,3.172E+02/
      DATA (SIGQE(J, 42,1),J=1,6) /
     &7.231E+01,6.827E+01,9.587E+01,1.542E+02,2.321E+02,3.142E+02/
      DATA (SIGQE(J, 43,1),J=1,6) /
     &7.147E+01,6.828E+01,9.562E+01,1.568E+02,2.392E+02,3.203E+02/
      DATA (SIGQE(J, 44,1),J=1,6) /
     &7.070E+01,6.780E+01,9.662E+01,1.571E+02,2.360E+02,3.187E+02/
      DATA (SIGQE(J, 45,1),J=1,6) /
     &7.185E+01,6.944E+01,9.714E+01,1.578E+02,2.372E+02,3.189E+02/
      DATA (SIGQE(J, 46,1),J=1,6) /
     &7.278E+01,7.053E+01,9.693E+01,1.590E+02,2.372E+02,3.288E+02/
      DATA (SIGQE(J, 47,1),J=1,6) /
     &7.105E+01,6.823E+01,9.908E+01,1.588E+02,2.377E+02,3.251E+02/
      DATA (SIGQE(J, 48,1),J=1,6) /
     &7.447E+01,7.170E+01,9.957E+01,1.586E+02,2.389E+02,3.196E+02/
      DATA (SIGQE(J, 49,1),J=1,6) /
     &7.144E+01,6.816E+01,9.702E+01,1.597E+02,2.422E+02,3.237E+02/
      DATA (SIGQE(J, 50,1),J=1,6) /
     &7.301E+01,6.947E+01,9.951E+01,1.614E+02,2.395E+02,3.289E+02/
      DATA (SIGQE(J, 51,1),J=1,6) /
     &7.501E+01,7.211E+01,9.602E+01,1.606E+02,2.434E+02,3.245E+02/
      DATA (SIGQE(J, 52,1),J=1,6) /
     &7.424E+01,7.079E+01,9.830E+01,1.609E+02,2.411E+02,3.283E+02/
      DATA (SIGQE(J, 53,1),J=1,6) /
     &7.307E+01,6.958E+01,9.924E+01,1.617E+02,2.449E+02,3.320E+02/
      DATA (SIGQE(J, 54,1),J=1,6) /
     &7.429E+01,7.279E+01,9.711E+01,1.690E+02,2.437E+02,3.371E+02/
      DATA (SIGQE(J, 55,1),J=1,6) /
     &7.451E+01,7.128E+01,1.008E+02,1.652E+02,2.500E+02,3.351E+02/
      DATA (SIGQE(J, 56,1),J=1,6) /
     &7.483E+01,7.359E+01,9.959E+01,1.676E+02,2.521E+02,3.326E+02/
 
 
C  DATA ON 'INELASTIC-PRODUCTION' NUCLEUS-NITROGEN CROSS-SECTION
      DATA (SIGMA(J, 2,2),J=1,6) /
     &3.801E+02,4.193E+02,4.889E+02,5.735E+02,6.657E+02,7.605E+02/
      DATA (SIGMA(J, 3,2),J=1,6) /
     &4.463E+02,4.853E+02,5.562E+02,6.460E+02,7.389E+02,8.392E+02/
      DATA (SIGMA(J, 4,2),J=1,6) /
     &4.807E+02,5.199E+02,5.911E+02,6.727E+02,7.716E+02,8.633E+02/
      DATA (SIGMA(J, 5,2),J=1,6) /
     &5.740E+02,6.179E+02,6.966E+02,7.882E+02,8.936E+02,1.003E+03/
      DATA (SIGMA(J, 6,2),J=1,6) /
     &6.756E+02,7.282E+02,8.150E+02,9.208E+02,1.031E+03,1.154E+03/
      DATA (SIGMA(J, 7,2),J=1,6) /
     &6.936E+02,7.435E+02,8.306E+02,9.305E+02,1.049E+03,1.167E+03/
      DATA (SIGMA(J, 8,2),J=1,6) /
     &7.379E+02,7.882E+02,8.771E+02,9.845E+02,1.094E+03,1.216E+03/
      DATA (SIGMA(J, 9,2),J=1,6) /
     &7.759E+02,8.256E+02,9.181E+02,1.022E+03,1.148E+03,1.263E+03/
      DATA (SIGMA(J, 10,2),J=1,6) /
     &7.873E+02,8.398E+02,9.302E+02,1.043E+03,1.158E+03,1.274E+03/
      DATA (SIGMA(J, 11,2),J=1,6) /
     &7.967E+02,8.467E+02,9.304E+02,1.041E+03,1.164E+03,1.282E+03/
      DATA (SIGMA(J, 12,2),J=1,6) /
     &8.344E+02,8.847E+02,9.719E+02,1.081E+03,1.211E+03,1.328E+03/
      DATA (SIGMA(J, 13,2),J=1,6) /
     &8.471E+02,9.035E+02,9.928E+02,1.095E+03,1.225E+03,1.343E+03/
      DATA (SIGMA(J, 14,2),J=1,6) /
     &8.897E+02,9.431E+02,1.038E+03,1.148E+03,1.276E+03,1.391E+03/
      DATA (SIGMA(J, 15,2),J=1,6) /
     &9.196E+02,9.685E+02,1.059E+03,1.187E+03,1.307E+03,1.432E+03/
      DATA (SIGMA(J, 16,2),J=1,6) /
     &9.720E+02,1.024E+03,1.126E+03,1.242E+03,1.369E+03,1.514E+03/
      DATA (SIGMA(J, 17,2),J=1,6) /
     &9.714E+02,1.027E+03,1.123E+03,1.244E+03,1.368E+03,1.497E+03/
      DATA (SIGMA(J, 18,2),J=1,6) /
     &1.019E+03,1.077E+03,1.179E+03,1.307E+03,1.434E+03,1.563E+03/
      DATA (SIGMA(J, 19,2),J=1,6) /
     &1.071E+03,1.128E+03,1.239E+03,1.360E+03,1.502E+03,1.637E+03/
      DATA (SIGMA(J, 20,2),J=1,6) /
     &1.112E+03,1.176E+03,1.285E+03,1.412E+03,1.546E+03,1.695E+03/
      DATA (SIGMA(J, 21,2),J=1,6) /
     &1.132E+03,1.196E+03,1.307E+03,1.442E+03,1.572E+03,1.711E+03/
      DATA (SIGMA(J, 22,2),J=1,6) /
     &1.135E+03,1.195E+03,1.301E+03,1.430E+03,1.573E+03,1.717E+03/
      DATA (SIGMA(J, 23,2),J=1,6) /
     &1.178E+03,1.242E+03,1.356E+03,1.474E+03,1.629E+03,1.762E+03/
      DATA (SIGMA(J, 24,2),J=1,6) /
     &1.199E+03,1.263E+03,1.368E+03,1.503E+03,1.644E+03,1.789E+03/
      DATA (SIGMA(J, 25,2),J=1,6) /
     &1.221E+03,1.285E+03,1.383E+03,1.525E+03,1.675E+03,1.810E+03/
      DATA (SIGMA(J, 26,2),J=1,6) /
     &1.242E+03,1.307E+03,1.415E+03,1.550E+03,1.705E+03,1.836E+03/
      DATA (SIGMA(J, 27,2),J=1,6) /
     &1.223E+03,1.286E+03,1.401E+03,1.530E+03,1.686E+03,1.823E+03/
      DATA (SIGMA(J, 28,2),J=1,6) /
     &1.267E+03,1.333E+03,1.436E+03,1.577E+03,1.727E+03,1.868E+03/
      DATA (SIGMA(J, 29,2),J=1,6) /
     &1.387E+03,1.464E+03,1.589E+03,1.722E+03,1.882E+03,2.033E+03/
      DATA (SIGMA(J, 30,2),J=1,6) /
     &1.308E+03,1.377E+03,1.503E+03,1.620E+03,1.784E+03,1.928E+03/
      DATA (SIGMA(J, 31,2),J=1,6) /
     &1.338E+03,1.403E+03,1.527E+03,1.656E+03,1.816E+03,1.951E+03/
      DATA (SIGMA(J, 32,2),J=1,6) /
     &1.353E+03,1.424E+03,1.528E+03,1.677E+03,1.824E+03,1.975E+03/
      DATA (SIGMA(J, 33,2),J=1,6) /
     &1.371E+03,1.437E+03,1.560E+03,1.690E+03,1.845E+03,1.995E+03/
      DATA (SIGMA(J, 34,2),J=1,6) /
     &1.388E+03,1.452E+03,1.573E+03,1.719E+03,1.863E+03,2.021E+03/
      DATA (SIGMA(J, 35,2),J=1,6) /
     &1.404E+03,1.471E+03,1.593E+03,1.734E+03,1.873E+03,2.036E+03/
      DATA (SIGMA(J, 36,2),J=1,6) /
     &1.421E+03,1.493E+03,1.605E+03,1.756E+03,1.904E+03,2.067E+03/
      DATA (SIGMA(J, 37,2),J=1,6) /
     &1.436E+03,1.503E+03,1.621E+03,1.766E+03,1.918E+03,2.080E+03/
      DATA (SIGMA(J, 38,2),J=1,6) /
     &1.452E+03,1.509E+03,1.644E+03,1.792E+03,1.948E+03,2.095E+03/
      DATA (SIGMA(J, 39,2),J=1,6) /
     &1.472E+03,1.539E+03,1.657E+03,1.798E+03,1.967E+03,2.116E+03/
      DATA (SIGMA(J, 40,2),J=1,6) /
     &1.485E+03,1.560E+03,1.664E+03,1.815E+03,1.964E+03,2.141E+03/
      DATA (SIGMA(J, 41,2),J=1,6) /
     &1.496E+03,1.575E+03,1.681E+03,1.833E+03,2.002E+03,2.164E+03/
      DATA (SIGMA(J, 42,2),J=1,6) /
     &1.519E+03,1.575E+03,1.703E+03,1.846E+03,2.012E+03,2.173E+03/
      DATA (SIGMA(J, 43,2),J=1,6) /
     &1.530E+03,1.595E+03,1.726E+03,1.877E+03,2.041E+03,2.183E+03/
      DATA (SIGMA(J, 44,2),J=1,6) /
     &1.548E+03,1.614E+03,1.726E+03,1.893E+03,2.042E+03,2.200E+03/
      DATA (SIGMA(J, 45,2),J=1,6) /
     &1.559E+03,1.620E+03,1.753E+03,1.914E+03,2.069E+03,2.219E+03/
      DATA (SIGMA(J, 46,2),J=1,6) /
     &1.577E+03,1.653E+03,1.768E+03,1.922E+03,2.076E+03,2.240E+03/
      DATA (SIGMA(J, 47,2),J=1,6) /
     &1.587E+03,1.667E+03,1.785E+03,1.928E+03,2.093E+03,2.244E+03/
      DATA (SIGMA(J, 48,2),J=1,6) /
     &1.596E+03,1.673E+03,1.797E+03,1.949E+03,2.113E+03,2.270E+03/
      DATA (SIGMA(J, 49,2),J=1,6) /
     &1.607E+03,1.682E+03,1.804E+03,1.961E+03,2.132E+03,2.289E+03/
      DATA (SIGMA(J, 50,2),J=1,6) /
     &1.629E+03,1.698E+03,1.827E+03,1.983E+03,2.136E+03,2.311E+03/
      DATA (SIGMA(J, 51,2),J=1,6) /
     &1.646E+03,1.712E+03,1.841E+03,1.991E+03,2.158E+03,2.320E+03/
      DATA (SIGMA(J, 52,2),J=1,6) /
     &1.660E+03,1.730E+03,1.864E+03,2.011E+03,2.178E+03,2.331E+03/
      DATA (SIGMA(J, 53,2),J=1,6) /
     &1.668E+03,1.749E+03,1.867E+03,2.027E+03,2.189E+03,2.350E+03/
      DATA (SIGMA(J, 54,2),J=1,6) /
     &1.685E+03,1.749E+03,1.880E+03,2.036E+03,2.203E+03,2.374E+03/
      DATA (SIGMA(J, 55,2),J=1,6) /
     &1.691E+03,1.763E+03,1.890E+03,2.040E+03,2.216E+03,2.388E+03/
      DATA (SIGMA(J, 56,2),J=1,6) /
     &1.718E+03,1.799E+03,1.924E+03,2.077E+03,2.262E+03,2.426E+03/
 
 
C  DATA ON 'QUASI-ELASTIC' NUCLEUS-NITROGEN CROSS-SECTION
      DATA (SIGQE(J, 2,2),J=1,6) /
     &4.055E+01,3.839E+01,5.336E+01,8.882E+01,1.361E+02,1.890E+02/
      DATA (SIGQE(J, 3,2),J=1,6) /
     &4.103E+01,3.960E+01,5.448E+01,9.190E+01,1.429E+02,1.981E+02/
      DATA (SIGQE(J, 4,2),J=1,6) /
     &3.950E+01,3.904E+01,5.489E+01,9.418E+01,1.438E+02,2.005E+02/
      DATA (SIGQE(J, 5,2),J=1,6) /
     &4.570E+01,4.216E+01,6.007E+01,1.007E+02,1.546E+02,2.118E+02/
      DATA (SIGQE(J, 6,2),J=1,6) /
     &5.177E+01,4.950E+01,6.778E+01,1.114E+02,1.674E+02,2.318E+02/
      DATA (SIGQE(J, 7,2),J=1,6) /
     &5.059E+01,4.721E+01,6.616E+01,1.118E+02,1.710E+02,2.328E+02/
      DATA (SIGQE(J, 8,2),J=1,6) /
     &5.083E+01,4.727E+01,6.840E+01,1.146E+02,1.747E+02,2.368E+02/
      DATA (SIGQE(J, 9,2),J=1,6) /
     &5.258E+01,5.055E+01,6.835E+01,1.160E+02,1.785E+02,2.427E+02/
      DATA (SIGQE(J, 10,2),J=1,6) /
     &5.187E+01,4.859E+01,6.852E+01,1.140E+02,1.760E+02,2.445E+02/
      DATA (SIGQE(J, 11,2),J=1,6) /
     &5.050E+01,4.829E+01,6.846E+01,1.163E+02,1.758E+02,2.428E+02/
      DATA (SIGQE(J, 12,2),J=1,6) /
     &5.155E+01,5.050E+01,6.997E+01,1.178E+02,1.785E+02,2.460E+02/
      DATA (SIGQE(J, 13,2),J=1,6) /
     &5.208E+01,5.065E+01,6.892E+01,1.172E+02,1.800E+02,2.460E+02/
      DATA (SIGQE(J, 14,2),J=1,6) /
     &5.313E+01,5.103E+01,7.111E+01,1.200E+02,1.856E+02,2.519E+02/
      DATA (SIGQE(J, 15,2),J=1,6) /
     &5.409E+01,5.309E+01,7.275E+01,1.240E+02,1.868E+02,2.567E+02/
      DATA (SIGQE(J, 16,2),J=1,6) /
     &5.734E+01,5.522E+01,7.603E+01,1.240E+02,1.871E+02,2.585E+02/
      DATA (SIGQE(J, 17,2),J=1,6) /
     &5.532E+01,5.350E+01,7.462E+01,1.252E+02,1.894E+02,2.639E+02/
      DATA (SIGQE(J, 18,2),J=1,6) /
     &5.724E+01,5.551E+01,7.675E+01,1.286E+02,1.952E+02,2.628E+02/
      DATA (SIGQE(J, 19,2),J=1,6) /
     &6.010E+01,5.755E+01,8.115E+01,1.300E+02,2.036E+02,2.734E+02/
      DATA (SIGQE(J, 20,2),J=1,6) /
     &6.080E+01,5.846E+01,8.134E+01,1.383E+02,2.048E+02,2.839E+02/
      DATA (SIGQE(J, 21,2),J=1,6) /
     &6.365E+01,6.049E+01,8.471E+01,1.353E+02,2.081E+02,2.810E+02/
      DATA (SIGQE(J, 22,2),J=1,6) /
     &6.223E+01,6.010E+01,8.107E+01,1.356E+02,2.091E+02,2.796E+02/
      DATA (SIGQE(J, 23,2),J=1,6) /
     &6.406E+01,6.098E+01,8.344E+01,1.387E+02,2.132E+02,2.847E+02/
      DATA (SIGQE(J, 24,2),J=1,6) /
     &6.417E+01,6.093E+01,8.388E+01,1.421E+02,2.086E+02,2.850E+02/
      DATA (SIGQE(J, 25,2),J=1,6) /
     &6.390E+01,6.108E+01,8.326E+01,1.402E+02,2.128E+02,2.931E+02/
      DATA (SIGQE(J, 26,2),J=1,6) /
     &6.484E+01,6.331E+01,8.603E+01,1.390E+02,2.152E+02,2.874E+02/
      DATA (SIGQE(J, 27,2),J=1,6) /
     &6.541E+01,6.045E+01,8.483E+01,1.417E+02,2.151E+02,2.885E+02/
      DATA (SIGQE(J, 28,2),J=1,6) /
     &6.536E+01,6.270E+01,8.582E+01,1.394E+02,2.123E+02,2.916E+02/
      DATA (SIGQE(J, 29,2),J=1,6) /
     &6.975E+01,6.793E+01,9.379E+01,1.527E+02,2.269E+02,3.054E+02/
      DATA (SIGQE(J, 30,2),J=1,6) /
     &6.545E+01,6.409E+01,8.711E+01,1.469E+02,2.188E+02,2.966E+02/
      DATA (SIGQE(J, 31,2),J=1,6) /
     &6.589E+01,6.400E+01,8.884E+01,1.478E+02,2.167E+02,2.983E+02/
      DATA (SIGQE(J, 32,2),J=1,6) /
     &6.699E+01,6.324E+01,8.936E+01,1.480E+02,2.169E+02,3.016E+02/
      DATA (SIGQE(J, 33,2),J=1,6) /
     &6.554E+01,6.587E+01,8.778E+01,1.480E+02,2.199E+02,3.023E+02/
      DATA (SIGQE(J, 34,2),J=1,6) /
     &6.908E+01,6.574E+01,8.950E+01,1.484E+02,2.241E+02,3.070E+02/
      DATA (SIGQE(J, 35,2),J=1,6) /
     &6.731E+01,6.560E+01,9.084E+01,1.510E+02,2.259E+02,3.044E+02/
      DATA (SIGQE(J, 36,2),J=1,6) /
     &6.945E+01,6.583E+01,9.039E+01,1.489E+02,2.290E+02,3.032E+02/
      DATA (SIGQE(J, 37,2),J=1,6) /
     &7.066E+01,6.668E+01,9.205E+01,1.515E+02,2.271E+02,3.118E+02/
      DATA (SIGQE(J, 38,2),J=1,6) /
     &7.005E+01,6.715E+01,8.964E+01,1.525E+02,2.249E+02,3.124E+02/
      DATA (SIGQE(J, 39,2),J=1,6) /
     &7.071E+01,6.711E+01,9.105E+01,1.547E+02,2.305E+02,3.127E+02/
      DATA (SIGQE(J, 40,2),J=1,6) /
     &6.920E+01,6.501E+01,9.499E+01,1.542E+02,2.329E+02,3.124E+02/
      DATA (SIGQE(J, 41,2),J=1,6) /
     &6.979E+01,6.653E+01,9.623E+01,1.560E+02,2.329E+02,3.085E+02/
      DATA (SIGQE(J, 42,2),J=1,6) /
     &6.949E+01,6.652E+01,9.372E+01,1.556E+02,2.328E+02,3.183E+02/
      DATA (SIGQE(J, 43,2),J=1,6) /
     &7.073E+01,6.731E+01,9.408E+01,1.530E+02,2.361E+02,3.124E+02/
      DATA (SIGQE(J, 44,2),J=1,6) /
     &6.931E+01,6.629E+01,9.438E+01,1.549E+02,2.324E+02,3.168E+02/
      DATA (SIGQE(J, 45,2),J=1,6) /
     &7.221E+01,6.909E+01,9.483E+01,1.569E+02,2.342E+02,3.134E+02/
      DATA (SIGQE(J, 46,2),J=1,6) /
     &7.204E+01,6.899E+01,9.559E+01,1.562E+02,2.399E+02,3.232E+02/
      DATA (SIGQE(J, 47,2),J=1,6) /
     &7.170E+01,6.912E+01,9.503E+01,1.585E+02,2.383E+02,3.239E+02/
      DATA (SIGQE(J, 48,2),J=1,6) /
     &7.384E+01,6.841E+01,9.621E+01,1.569E+02,2.382E+02,3.207E+02/
      DATA (SIGQE(J, 49,2),J=1,6) /
     &7.484E+01,6.985E+01,9.893E+01,1.574E+02,2.387E+02,3.222E+02/
      DATA (SIGQE(J, 50,2),J=1,6) /
     &7.408E+01,6.976E+01,9.764E+01,1.596E+02,2.414E+02,3.249E+02/
      DATA (SIGQE(J, 51,2),J=1,6) /
     &7.364E+01,6.896E+01,9.753E+01,1.607E+02,2.414E+02,3.249E+02/
      DATA (SIGQE(J, 52,2),J=1,6) /
     &7.428E+01,7.076E+01,9.556E+01,1.623E+02,2.373E+02,3.226E+02/
      DATA (SIGQE(J, 53,2),J=1,6) /
     &7.317E+01,7.214E+01,9.768E+01,1.609E+02,2.454E+02,3.253E+02/
      DATA (SIGQE(J, 54,2),J=1,6) /
     &7.390E+01,7.088E+01,9.930E+01,1.604E+02,2.417E+02,3.331E+02/
      DATA (SIGQE(J, 55,2),J=1,6) /
     &7.453E+01,7.097E+01,9.898E+01,1.633E+02,2.417E+02,3.328E+02/
      DATA (SIGQE(J, 56,2),J=1,6) /
     &7.629E+01,7.408E+01,1.017E+02,1.674E+02,2.452E+02,3.281E+02/
 
 
C  DATA ON 'INELASTIC-PRODUCTION' NUCLEUS-OXYGEN CROSS-SECTION
      DATA (SIGMA(J, 2,3),J=1,6) /
     &4.274E+02,4.721E+02,5.428E+02,6.398E+02,7.302E+02,8.279E+02/
      DATA (SIGMA(J, 3,3),J=1,6) /
     &5.013E+02,5.409E+02,6.209E+02,7.083E+02,8.119E+02,9.147E+02/
      DATA (SIGMA(J, 4,3),J=1,6) /
     &5.296E+02,5.757E+02,6.536E+02,7.435E+02,8.464E+02,9.471E+02/
      DATA (SIGMA(J, 5,3),J=1,6) /
     &6.337E+02,6.816E+02,7.623E+02,8.716E+02,9.787E+02,1.089E+03/
      DATA (SIGMA(J, 6,3),J=1,6) /
     &7.429E+02,7.994E+02,8.934E+02,1.005E+03,1.118E+03,1.241E+03/
      DATA (SIGMA(J, 7,3),J=1,6) /
     &7.623E+02,8.168E+02,9.071E+02,1.016E+03,1.134E+03,1.260E+03/
      DATA (SIGMA(J, 8,3),J=1,6) /
     &8.055E+02,8.634E+02,9.528E+02,1.069E+03,1.192E+03,1.308E+03/
      DATA (SIGMA(J, 9,3),J=1,6) /
     &8.487E+02,9.032E+02,1.006E+03,1.119E+03,1.242E+03,1.362E+03/
      DATA (SIGMA(J, 10,3),J=1,6) /
     &8.666E+02,9.203E+02,1.009E+03,1.125E+03,1.242E+03,1.377E+03/
      DATA (SIGMA(J, 11,3),J=1,6) /
     &8.649E+02,9.210E+02,1.013E+03,1.131E+03,1.254E+03,1.375E+03/
      DATA (SIGMA(J, 12,3),J=1,6) /
     &9.075E+02,9.667E+02,1.065E+03,1.180E+03,1.307E+03,1.430E+03/
      DATA (SIGMA(J, 13,3),J=1,6) /
     &9.252E+02,9.824E+02,1.083E+03,1.184E+03,1.322E+03,1.448E+03/
      DATA (SIGMA(J, 14,3),J=1,6) /
     &9.660E+02,1.025E+03,1.124E+03,1.250E+03,1.373E+03,1.504E+03/
      DATA (SIGMA(J, 15,3),J=1,6) /
     &1.000E+03,1.048E+03,1.151E+03,1.274E+03,1.401E+03,1.530E+03/
      DATA (SIGMA(J, 16,3),J=1,6) /
     &1.060E+03,1.113E+03,1.216E+03,1.339E+03,1.478E+03,1.612E+03/
      DATA (SIGMA(J, 17,3),J=1,6) /
     &1.053E+03,1.116E+03,1.214E+03,1.332E+03,1.472E+03,1.623E+03/
      DATA (SIGMA(J, 18,3),J=1,6) /
     &1.109E+03,1.171E+03,1.277E+03,1.401E+03,1.537E+03,1.678E+03/
      DATA (SIGMA(J, 19,3),J=1,6) /
     &1.158E+03,1.221E+03,1.334E+03,1.465E+03,1.603E+03,1.746E+03/
      DATA (SIGMA(J, 20,3),J=1,6) /
     &1.204E+03,1.272E+03,1.378E+03,1.517E+03,1.670E+03,1.808E+03/
      DATA (SIGMA(J, 21,3),J=1,6) /
     &1.229E+03,1.292E+03,1.403E+03,1.537E+03,1.689E+03,1.833E+03/
      DATA (SIGMA(J, 22,3),J=1,6) /
     &1.230E+03,1.287E+03,1.401E+03,1.527E+03,1.677E+03,1.823E+03/
      DATA (SIGMA(J, 23,3),J=1,6) /
     &1.280E+03,1.345E+03,1.457E+03,1.589E+03,1.747E+03,1.891E+03/
      DATA (SIGMA(J, 24,3),J=1,6) /
     &1.291E+03,1.365E+03,1.467E+03,1.610E+03,1.746E+03,1.907E+03/
      DATA (SIGMA(J, 25,3),J=1,6) /
     &1.322E+03,1.386E+03,1.493E+03,1.646E+03,1.790E+03,1.936E+03/
      DATA (SIGMA(J, 26,3),J=1,6) /
     &1.336E+03,1.409E+03,1.518E+03,1.662E+03,1.806E+03,1.969E+03/
      DATA (SIGMA(J, 27,3),J=1,6) /
     &1.322E+03,1.389E+03,1.506E+03,1.643E+03,1.788E+03,1.941E+03/
      DATA (SIGMA(J, 28,3),J=1,6) /
     &1.358E+03,1.422E+03,1.533E+03,1.690E+03,1.826E+03,1.991E+03/
      DATA (SIGMA(J, 29,3),J=1,6) /
     &1.500E+03,1.572E+03,1.686E+03,1.848E+03,1.998E+03,2.160E+03/
      DATA (SIGMA(J, 30,3),J=1,6) /
     &1.419E+03,1.485E+03,1.604E+03,1.744E+03,1.905E+03,2.056E+03/
      DATA (SIGMA(J, 31,3),J=1,6) /
     &1.429E+03,1.505E+03,1.616E+03,1.768E+03,1.910E+03,2.073E+03/
      DATA (SIGMA(J, 32,3),J=1,6) /
     &1.453E+03,1.526E+03,1.642E+03,1.798E+03,1.938E+03,2.105E+03/
      DATA (SIGMA(J, 33,3),J=1,6) /
     &1.475E+03,1.537E+03,1.667E+03,1.817E+03,1.968E+03,2.129E+03/
      DATA (SIGMA(J, 34,3),J=1,6) /
     &1.489E+03,1.568E+03,1.684E+03,1.831E+03,1.987E+03,2.151E+03/
      DATA (SIGMA(J, 35,3),J=1,6) /
     &1.508E+03,1.579E+03,1.695E+03,1.849E+03,2.008E+03,2.159E+03/
      DATA (SIGMA(J, 36,3),J=1,6) /
     &1.514E+03,1.599E+03,1.719E+03,1.862E+03,2.016E+03,2.179E+03/
      DATA (SIGMA(J, 37,3),J=1,6) /
     &1.546E+03,1.616E+03,1.746E+03,1.886E+03,2.044E+03,2.196E+03/
      DATA (SIGMA(J, 38,3),J=1,6) /
     &1.551E+03,1.624E+03,1.747E+03,1.904E+03,2.064E+03,2.229E+03/
      DATA (SIGMA(J, 39,3),J=1,6) /
     &1.574E+03,1.648E+03,1.765E+03,1.920E+03,2.078E+03,2.234E+03/
      DATA (SIGMA(J, 40,3),J=1,6) /
     &1.588E+03,1.673E+03,1.789E+03,1.934E+03,2.097E+03,2.269E+03/
      DATA (SIGMA(J, 41,3),J=1,6) /
     &1.609E+03,1.680E+03,1.804E+03,1.954E+03,2.124E+03,2.282E+03/
      DATA (SIGMA(J, 42,3),J=1,6) /
     &1.624E+03,1.695E+03,1.820E+03,1.978E+03,2.142E+03,2.305E+03/
      DATA (SIGMA(J, 43,3),J=1,6) /
     &1.637E+03,1.702E+03,1.834E+03,1.981E+03,2.148E+03,2.312E+03/
      DATA (SIGMA(J, 44,3),J=1,6) /
     &1.652E+03,1.725E+03,1.846E+03,2.003E+03,2.180E+03,2.349E+03/
      DATA (SIGMA(J, 45,3),J=1,6) /
     &1.672E+03,1.736E+03,1.866E+03,2.026E+03,2.189E+03,2.342E+03/
      DATA (SIGMA(J, 46,3),J=1,6) /
     &1.677E+03,1.748E+03,1.873E+03,2.044E+03,2.207E+03,2.369E+03/
      DATA (SIGMA(J, 47,3),J=1,6) /
     &1.690E+03,1.774E+03,1.888E+03,2.057E+03,2.221E+03,2.389E+03/
      DATA (SIGMA(J, 48,3),J=1,6) /
     &1.720E+03,1.781E+03,1.919E+03,2.077E+03,2.239E+03,2.408E+03/
      DATA (SIGMA(J, 49,3),J=1,6) /
     &1.725E+03,1.797E+03,1.932E+03,2.090E+03,2.264E+03,2.424E+03/
      DATA (SIGMA(J, 50,3),J=1,6) /
     &1.739E+03,1.811E+03,1.944E+03,2.099E+03,2.267E+03,2.437E+03/
      DATA (SIGMA(J, 51,3),J=1,6) /
     &1.748E+03,1.832E+03,1.964E+03,2.118E+03,2.286E+03,2.458E+03/
      DATA (SIGMA(J, 52,3),J=1,6) /
     &1.758E+03,1.848E+03,1.978E+03,2.138E+03,2.309E+03,2.475E+03/
      DATA (SIGMA(J, 53,3),J=1,6) /
     &1.775E+03,1.866E+03,1.987E+03,2.149E+03,2.312E+03,2.484E+03/
      DATA (SIGMA(J, 54,3),J=1,6) /
     &1.786E+03,1.863E+03,2.005E+03,2.163E+03,2.342E+03,2.502E+03/
      DATA (SIGMA(J, 55,3),J=1,6) /
     &1.815E+03,1.893E+03,2.013E+03,2.172E+03,2.332E+03,2.514E+03/
      DATA (SIGMA(J, 56,3),J=1,6) /
     &1.829E+03,1.923E+03,2.061E+03,2.218E+03,2.392E+03,2.568E+03/
 
 
C  DATA ON 'QUASI-ELASTIC' NUCLEUS-OXYGEN CROSS-SECTION
      DATA (SIGQE(J, 2,3),J=1,6) /
     &4.411E+01,4.214E+01,5.763E+01,9.526E+01,1.431E+02,2.003E+02/
      DATA (SIGQE(J, 3,3),J=1,6) /
     &4.397E+01,4.204E+01,5.841E+01,9.948E+01,1.499E+02,2.068E+02/
      DATA (SIGQE(J, 4,3),J=1,6) /
     &4.355E+01,4.141E+01,5.925E+01,9.736E+01,1.510E+02,2.069E+02/
      DATA (SIGQE(J, 5,3),J=1,6) /
     &4.900E+01,4.630E+01,6.462E+01,1.083E+02,1.603E+02,2.246E+02/
      DATA (SIGQE(J, 6,3),J=1,6) /
     &5.479E+01,5.264E+01,7.120E+01,1.153E+02,1.771E+02,2.420E+02/
      DATA (SIGQE(J, 7,3),J=1,6) /
     &5.282E+01,4.972E+01,6.824E+01,1.179E+02,1.771E+02,2.394E+02/
      DATA (SIGQE(J, 8,3),J=1,6) /
     &5.269E+01,5.147E+01,7.139E+01,1.186E+02,1.803E+02,2.490E+02/
      DATA (SIGQE(J, 9,3),J=1,6) /
     &5.485E+01,5.320E+01,7.324E+01,1.201E+02,1.831E+02,2.538E+02/
      DATA (SIGQE(J, 10,3),J=1,6) /
     &5.452E+01,5.241E+01,7.176E+01,1.200E+02,1.867E+02,2.543E+02/
      DATA (SIGQE(J, 11,3),J=1,6) /
     &5.288E+01,5.103E+01,7.247E+01,1.200E+02,1.841E+02,2.548E+02/
      DATA (SIGQE(J, 12,3),J=1,6) /
     &5.504E+01,5.275E+01,7.414E+01,1.243E+02,1.851E+02,2.546E+02/
      DATA (SIGQE(J, 13,3),J=1,6) /
     &5.497E+01,5.368E+01,7.494E+01,1.222E+02,1.878E+02,2.551E+02/
      DATA (SIGQE(J, 14,3),J=1,6) /
     &5.630E+01,5.475E+01,7.698E+01,1.272E+02,1.910E+02,2.637E+02/
      DATA (SIGQE(J, 15,3),J=1,6) /
     &5.622E+01,5.403E+01,7.742E+01,1.278E+02,1.929E+02,2.615E+02/
      DATA (SIGQE(J, 16,3),J=1,6) /
     &5.938E+01,5.647E+01,8.041E+01,1.313E+02,2.013E+02,2.740E+02/
      DATA (SIGQE(J, 17,3),J=1,6) /
     &5.831E+01,5.568E+01,7.869E+01,1.301E+02,1.998E+02,2.679E+02/
      DATA (SIGQE(J, 18,3),J=1,6) /
     &6.111E+01,5.782E+01,8.075E+01,1.353E+02,2.032E+02,2.796E+02/
      DATA (SIGQE(J, 19,3),J=1,6) /
     &6.429E+01,6.116E+01,8.409E+01,1.372E+02,2.081E+02,2.814E+02/
      DATA (SIGQE(J, 20,3),J=1,6) /
     &6.533E+01,6.172E+01,8.794E+01,1.427E+02,2.100E+02,2.905E+02/
      DATA (SIGQE(J, 21,3),J=1,6) /
     &6.552E+01,6.258E+01,8.657E+01,1.428E+02,2.118E+02,2.944E+02/
      DATA (SIGQE(J, 22,3),J=1,6) /
     &6.570E+01,6.287E+01,8.747E+01,1.423E+02,2.156E+02,2.935E+02/
      DATA (SIGQE(J, 23,3),J=1,6) /
     &6.691E+01,6.392E+01,8.925E+01,1.452E+02,2.160E+02,2.931E+02/
      DATA (SIGQE(J, 24,3),J=1,6) /
     &6.805E+01,6.303E+01,8.772E+01,1.440E+02,2.179E+02,2.937E+02/
      DATA (SIGQE(J, 25,3),J=1,6) /
     &6.652E+01,6.482E+01,8.920E+01,1.436E+02,2.198E+02,2.972E+02/
      DATA (SIGQE(J, 26,3),J=1,6) /
     &6.847E+01,6.523E+01,8.985E+01,1.490E+02,2.221E+02,2.945E+02/
      DATA (SIGQE(J, 27,3),J=1,6) /
     &6.747E+01,6.424E+01,8.848E+01,1.477E+02,2.291E+02,2.970E+02/
      DATA (SIGQE(J, 28,3),J=1,6) /
     &6.957E+01,6.661E+01,9.138E+01,1.495E+02,2.234E+02,3.029E+02/
      DATA (SIGQE(J, 29,3),J=1,6) /
     &7.165E+01,6.928E+01,9.551E+01,1.536E+02,2.331E+02,3.164E+02/
      DATA (SIGQE(J, 30,3),J=1,6) /
     &6.910E+01,6.637E+01,9.372E+01,1.531E+02,2.246E+02,3.080E+02/
      DATA (SIGQE(J, 31,3),J=1,6) /
     &7.269E+01,6.754E+01,9.363E+01,1.530E+02,2.296E+02,3.093E+02/
      DATA (SIGQE(J, 32,3),J=1,6) /
     &6.941E+01,6.728E+01,9.142E+01,1.528E+02,2.311E+02,3.088E+02/
      DATA (SIGQE(J, 33,3),J=1,6) /
     &7.102E+01,6.934E+01,9.383E+01,1.528E+02,2.371E+02,3.111E+02/
      DATA (SIGQE(J, 34,3),J=1,6) /
     &7.244E+01,6.679E+01,9.448E+01,1.577E+02,2.325E+02,3.149E+02/
      DATA (SIGQE(J, 35,3),J=1,6) /
     &6.943E+01,6.884E+01,9.335E+01,1.560E+02,2.331E+02,3.127E+02/
      DATA (SIGQE(J, 36,3),J=1,6) /
     &7.198E+01,6.928E+01,9.563E+01,1.558E+02,2.375E+02,3.135E+02/
      DATA (SIGQE(J, 37,3),J=1,6) /
     &7.150E+01,6.823E+01,9.526E+01,1.557E+02,2.354E+02,3.163E+02/
      DATA (SIGQE(J, 38,3),J=1,6) /
     &7.051E+01,6.823E+01,9.586E+01,1.573E+02,2.363E+02,3.228E+02/
      DATA (SIGQE(J, 39,3),J=1,6) /
     &7.317E+01,7.191E+01,9.633E+01,1.573E+02,2.350E+02,3.255E+02/
      DATA (SIGQE(J, 40,3),J=1,6) /
     &7.415E+01,6.910E+01,9.663E+01,1.573E+02,2.356E+02,3.214E+02/
      DATA (SIGQE(J, 41,3),J=1,6) /
     &7.402E+01,7.220E+01,9.591E+01,1.591E+02,2.428E+02,3.221E+02/
      DATA (SIGQE(J, 42,3),J=1,6) /
     &7.260E+01,6.905E+01,9.708E+01,1.612E+02,2.400E+02,3.260E+02/
      DATA (SIGQE(J, 43,3),J=1,6) /
     &7.385E+01,7.215E+01,9.835E+01,1.624E+02,2.388E+02,3.229E+02/
      DATA (SIGQE(J, 44,3),J=1,6) /
     &7.489E+01,6.990E+01,9.881E+01,1.607E+02,2.400E+02,3.290E+02/
      DATA (SIGQE(J, 45,3),J=1,6) /
     &7.558E+01,7.100E+01,9.615E+01,1.649E+02,2.416E+02,3.268E+02/
      DATA (SIGQE(J, 46,3),J=1,6) /
     &7.573E+01,7.333E+01,9.789E+01,1.635E+02,2.479E+02,3.327E+02/
      DATA (SIGQE(J, 47,3),J=1,6) /
     &7.538E+01,7.218E+01,9.889E+01,1.611E+02,2.437E+02,3.293E+02/
      DATA (SIGQE(J, 48,3),J=1,6) /
     &7.380E+01,7.255E+01,9.699E+01,1.626E+02,2.426E+02,3.272E+02/
      DATA (SIGQE(J, 49,3),J=1,6) /
     &7.499E+01,7.331E+01,9.820E+01,1.659E+02,2.457E+02,3.353E+02/
      DATA (SIGQE(J, 50,3),J=1,6) /
     &7.790E+01,7.338E+01,9.864E+01,1.647E+02,2.458E+02,3.409E+02/
      DATA (SIGQE(J, 51,3),J=1,6) /
     &7.460E+01,7.331E+01,1.013E+02,1.649E+02,2.516E+02,3.363E+02/
      DATA (SIGQE(J, 52,3),J=1,6) /
     &7.890E+01,7.704E+01,1.008E+02,1.638E+02,2.473E+02,3.383E+02/
      DATA (SIGQE(J, 53,3),J=1,6) /
     &7.672E+01,7.264E+01,1.008E+02,1.677E+02,2.527E+02,3.336E+02/
      DATA (SIGQE(J, 54,3),J=1,6) /
     &7.870E+01,7.413E+01,1.069E+02,1.664E+02,2.488E+02,3.403E+02/
      DATA (SIGQE(J, 55,3),J=1,6) /
     &7.592E+01,7.266E+01,1.036E+02,1.681E+02,2.516E+02,3.466E+02/
      DATA (SIGQE(J, 56,3),J=1,6) /
     &8.061E+01,7.595E+01,1.047E+02,1.708E+02,2.533E+02,3.410E+02/
C-----------------------------------------------------------------------
C     TARGET NUCLEUS
      IF(IB.eq.0)THEN
C     pre-mixed 'air'
         IK = 1
      ELSEIF(IB.eq.14)THEN
c     nitrogen
         IK = 2
      ELSEIF(IB.eq.16)THEN
c     oxygen
         IK = 3         
      ELSE
         print*,'target not supported by SIBYLL!', ib
         stop 2
      ENDIF
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,IK),SIGMA(JE+1,IA,IK),
     +     SIGMA(JE+2,IA,IK) )
C  QUASI ELASTIC CROSS-SECTION
      S2 = QUAD_INT( ASQS, AA(JE),AA(JE+1),AA(JE+2),
     +     SIGQE(JE,IA,IK),SIGQE(JE+1,IA,IK),
     +     SIGQE(JE+2,IA,IK) )
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






# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"








# 4248 "corsika.h"

# 4262 "corsika.h"

# 4301 "corsika.h"

# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"



      INTEGER          KSEQ



      PARAMETER        (KSEQ = 9)

      COMMON /CRRANMA3/CD,CINT,CM,TWOM24,TWOM48,MODCNS
      DOUBLE PRECISION CD,CINT,CM,TWOM24,TWOM48
      INTEGER          MODCNS





      COMMON /CRRANMA4/C,U,IJKL,I97,J97,NTOT,NTOT2,JSEQ
      DOUBLE PRECISION C(KSEQ),U(97,KSEQ),UNI
      INTEGER          IJKL(KSEQ),I97(KSEQ),J97(KSEQ),
     *                 NTOT(KSEQ),NTOT2(KSEQ),JSEQ



# 4450 "corsika.h"








# 4475 "corsika.h"

















# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 72528 "corsika.F" 2




      INTEGER          IDUM
      SAVE
C-----------------------------------------------------------------------

      JSEQ = 1




 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

# 75305 "corsika.F"

# 75396 "corsika.F"

# 76275 "corsika.F"

# 76474 "corsika.F"

# 76515 "corsika.F"

# 76596 "corsika.F"

# 76775 "corsika.F"

# 76922 "corsika.F"

# 76969 "corsika.F"

# 77011 "corsika.F"

# 77181 "corsika.F"

# 77237 "corsika.F"

# 77540 "corsika.F"

# 77629 "corsika.F"

# 77717 "corsika.F"

# 77858 "corsika.F"

# 77949 "corsika.F"

# 78129 "corsika.F"

# 78188 "corsika.F"

# 78542 "corsika.F"

# 78624 "corsika.F"

# 78746 "corsika.F"

# 79043 "corsika.F"

# 79109 "corsika.F"

# 79236 "corsika.F"

# 79345 "corsika.F"

# 79451 "corsika.F"

# 79821 "corsika.F"

# 79896 "corsika.F"

# 79964 "corsika.F"

# 80018 "corsika.F"

# 80128 "corsika.F"

# 80216 "corsika.F"

# 82294 "corsika.F"

# 83290 "corsika.F"

# 83642 "corsika.F"
*-- 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)






# 1 "corsika.h" 1
# 3562 "corsika.h"








# 3580 "corsika.h"

# 3589 "corsika.h"









# 3610 "corsika.h"

# 3619 "corsika.h"

# 3631 "corsika.h"















# 3655 "corsika.h"

# 3705 "corsika.h"

























































































# 3811 "corsika.h"

# 3824 "corsika.h"























# 3855 "corsika.h"
















# 3880 "corsika.h"

# 3895 "corsika.h"









# 3912 "corsika.h"






















# 3980 "corsika.h"















# 4005 "corsika.h"
















# 4047 "corsika.h"









# 4075 "corsika.h"

# 4091 "corsika.h"
















# 4127 "corsika.h"

# 4140 "corsika.h"

# 4153 "corsika.h"

# 4169 "corsika.h"
















# 4212 "corsika.h"










      COMMON /CROBSPAR/OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP,
     *                 THETPR,PHIPR,

     *                 CORRXY,







     *                 NOBSLV
      DOUBLE PRECISION OBSLEV(20),THCKOB(20),XOFF(20),YOFF(20),
     *                 HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2)

     *                 ,CORRXY







      INTEGER          NOBSLV










      COMMON /CRPAM/   PAMA,SIGNUM,RESTMS,DECTIM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000),
     *                 DECTIM(200)






      COMMON /CRPARPAR/CURPAR,SECPAR,PRMPAR,OUTPAR,



     *                 C,E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
# 4287 "corsika.h"
      DOUBLE PRECISION CURPAR(0:16),SECPAR(0:16),PRMPAR(0:16),
     *                 OUTPAR(0:16),



     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH





      INTEGER          ITYPE,LEVL



# 4332 "corsika.h"









# 4354 "corsika.h"

# 4363 "corsika.h"

# 4383 "corsika.h"























# 4418 "corsika.h"

# 4432 "corsika.h"

# 4441 "corsika.h"

# 4450 "corsika.h"










      COMMON /CRREJECT/AVNREJ,ALTMIN,ANEXP,THICKA,THICKD,CUTLN,EONCUT,

     *                 EFRCTHN,ETHINN,ETHINNG,THINRAT,THINRATH,WEITRAT,
     *                 WEITRATH,EEFRTHN,

     *                 FNPRIM
      DOUBLE PRECISION AVNREJ(20),ALTMIN(20),ANEXP(20),THICKA(20),
     *                 THICKD(20),CUTLN,EONCUT

     *                 ,EFRCTHN,ETHINN,ETHINNG,THINRAT,THINRATH,WEITRAT,
     *                 WEITRATH,EEFRTHN

      LOGICAL          FNPRIM





















      COMMON /CRRUNPAR/FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2,

     *                 SIGMAQ,


     *                 HIMPACT,HIMPCT,





     *                 NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 ISEED1I,

     *                 PROPMOD,


     *                 IUDEBUG,IUDEBG0,
# 4524 "corsika.h"
     *                 LSTCK,

     *                 LSTCK1,LSTCK2,

c#if __ANAHIST__||__AUGERHIST__||__MUONHIST__
c     *                 LUNHST,
c#endif
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,



     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FOUTFILE,IFINAM


     *                 ,FIMPCT


     *                 ,FFLATOUT




     *                 ,FURQMD,FURQSG
# 4568 "corsika.h"
      COMMON /CRRUNPAC/DATDIR,DSN,DSNTAB,DSNLONG,HOST,USER





     *                 ,LSTDSN
# 4585 "corsika.h"
     *                 ,FILOUT
# 4596 "corsika.h"
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,RCUT,RCUT2

      DOUBLE PRECISION SIGMAQ(4)


      DOUBLE PRECISION HIMPACT(2),HIMPCT

      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT,ISEED1I(3)




      INTEGER          PROPMOD


      INTEGER          IUDEBUG,IUDEBG0
# 4628 "corsika.h"
      INTEGER          LSTCK

     *                ,LSTCK1,LSTCK2
# 4639 "corsika.h"
      CHARACTER*132    FILOUT

      CHARACTER*255    DSN,DSNTAB,DSNLONG
      CHARACTER*132    DATDIR
      CHARACTER*60     HOST,USER




      CHARACTER*9      LSTDSN
# 4659 "corsika.h"
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN




     *                 ,FFLATOUT

     *                 ,FIMPCT



      LOGICAL          FOUTFILE
      INTEGER          IFINAM
# 4686 "corsika.h"
      LOGICAL          FURQMD,FURQSG
# 4699 "corsika.h"

# 4709 "corsika.h"








# 4728 "corsika.h"

# 4762 "corsika.h"

# 4821 "corsika.h"
















# 4853 "corsika.h"

# 4905 "corsika.h"

















# 4935 "corsika.h"
















# 4959 "corsika.h"















     
# 4983 "corsika.h"

# 4994 "corsika.h"

# 5019 "corsika.h"

# 5031 "corsika.h"

# 5050 "corsika.h"

# 5060 "corsika.h"

     
# 5080 "corsika.h"

     







     








     















# 5124 "corsika.h"

     























     




























     






























     































     





















     







# 5279 "corsika.h"

# 5289 "corsika.h"









     
# 83660 "corsika.F" 2

      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

      DOUBLE PRECISION COSTEA,SINTEA,X,Y,XXX,YYY,RRR,PHI1

      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

        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





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


# 83775 "corsika.F"