*CMZ :          05/03/2002  08.29.07  by  D. HECK IK FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
C======================================================================

      PROGRAM AAMAIN

C-----------------------------------------------------------------------
C  MAIN PROGRAM
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)
c-----changed--add
c>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
      parameter (xct=1)
      parameter (yct=2)
      parameter (zct=3)
      parameter (ctthet=4)
      parameter (ctphi=5)
      parameter (ctdiam=6)
      parameter (ctfoc=7)
c>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
c-----changed--add
*KEEP,ATMOS2.
      COMMON /ATMOS2/  HLAY,HLAY0,THICKL,LAYNO,LAYNEW
      DOUBLE PRECISION HLAY(6),HLAY0(5,0:4),THICKL(5)
      INTEGER          LAYNO(0:16)
      LOGICAL          LAYNEW,flag
c-----changed--add
      logical       fmfb
c-----changed--add
*KEEP,BUFFS.
      COMMON /BUFFS/   RUNH,RUNE,EVTH,EVTE,DATAB,ARRAYLONG,LH
      INTEGER          MAXBUF,MAXLEN
      PARAMETER        (MAXLEN=16)
      PARAMETER        (MAXBUF=39*7)
      REAL             RUNH(MAXBUF),EVTH(MAXBUF),EVTE(MAXBUF),
     *                 RUNE(MAXBUF),DATAB(MAXBUF),ARRAYLONG(MAXBUF)
      INTEGER          LH
      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)
*KEEP,CHISTA.
      COMMON /CHISTA/  IHYCHI,IKACHI,IMUCHI,INNCHI,INUCHI,IPICHI
      INTEGER          IHYCHI(124),IKACHI(124),IMUCHI(124),
     *                 INNCHI(124),INUCHI(124),IPICHI(124)
*KEEP,CONSTA.
      COMMON /CONSTA/  PI,PI2,OB3,TB3,ENEPER
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER
*KEEP,CURVE.
      COMMON /CURVE/   CHAPAR,DEP,ERR,NSTP
      DOUBLE PRECISION CHAPAR(1200),DEP(1200),ERR(1200)
      INTEGER          NSTP
*KEEP,ELADPM.
      COMMON /ELADPM/  ELMEAN,ELMEAA,IELDPM,IELDPA
      DOUBLE PRECISION ELMEAN(40),ELMEAA(40)
      INTEGER          IELDPM(40,13),IELDPA(40,13)
*KEEP,ELASTY.
      COMMON /ELASTY/  ELAST
      DOUBLE PRECISION ELAST
*KEEP,GENER.
      COMMON /GENER/   GEN,ALEVEL
      DOUBLE PRECISION GEN,ALEVEL
*KEEP,IRET.
      COMMON /IRET/    IRET1,IRET2,IRETE
      INTEGER          IRET1,IRET2
      LOGICAL          IRETE
*KEEP,ISTA.
      COMMON /ISTA/    IFINET,IFINNU,IFINKA,IFINPI,IFINHY
      INTEGER          IFINET,IFINNU,IFINKA,IFINPI,IFINHY
*KEEP,LONGI.
      COMMON /LONGI/   ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP,LLONGI,FLGFIT
      DOUBLE PRECISION ADLONG(0:1170,9),AELONG(0:1170,9),
     *                 APLONG(0:1170,9),DLONG(0:1170,9),ELONG(0:1170,9),
     *                 HLONG(0:1170),PLONG(0:1170,9),SDLONG(0:1170,9),
     *                 SELONG(0:1170,9),SPLONG(0:1170,9),THSTEP,THSTPI
      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT
*KEEP,MAGNET.
      COMMON /MAGNET/  BX,BZ,BVAL,BNORMC,BNORM,COSB,SINB,BLIMIT
      DOUBLE PRECISION BX,BZ,BVAL,BNORMC,BNORM,COSB,SINB,BLIMIT
*KEEP,MPARTI.
      COMMON /MPARTI/  MPARTO
      DOUBLE PRECISION MPARTO(10,25),MPHOTO(10),MPOSIT(10),MELECT(10),
     *                 MNU(10),MMUP(10),MMUM(10),MPI0(10),MPIP(10),
     *                 MPIM(10),MK0L(10),MKPL(10),MKMI(10),MNEUTR(10),
     *                 MPROTO(10),MPROTB(10),MK0S(10),MHYP(10),
     *                 MNEUTB(10),MDEUT(10),MTRIT(10),MALPHA(10),
     *                 MOTHER(10),MMUOND
      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),MALPHA(1)),
     *            (MPARTO(1,22),MOTHER(1)), (MPARTO(1,25),MNEUTB(1)),
     *            (MPARTO(1,23),MMUOND)
*KEEP,MULT.
      COMMON /MULT/    EKINL,MSMM,MULTMA,MULTOT
      DOUBLE PRECISION EKINL
      INTEGER          MSMM,MULTMA(40,13),MULTOT(40,13)
*KEEP,MUMULT.
      COMMON /MUMULT/  CHC,OMC,PHISCT,STEPL,VSCAT,FMOLI
      DOUBLE PRECISION CHC,OMC,PHISCT,STEPL,VSCAT
      LOGICAL          FMOLI
*KEEP,MUPART.
      COMMON /MUPART/  AMUPAR,BCUT,CMUON,FMUBRM,FMUORG
      DOUBLE PRECISION AMUPAR(16),BCUT,CMUON(11)
      LOGICAL          FMUBRM,FMUORG
*KEEP,NCOUNT.
      COMMON /NCOUNT/  NCOUN
      INTEGER          NCOUN(8)
*KEEP,NKGI.
      COMMON /NKGI/    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)
*KEEP,NKGS.
      COMMON /NKGS/    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)
*KEEP,NPARTI.
      COMMON /NPARTI/  NPARTO
      DOUBLE PRECISION NPARTO(10,25),NPHOTO(10),NPOSIT(10),NELECT(10),
     *                 NNU(10),NMUP(10),NMUM(10),NPI0(10),NPIP(10),
     *                 NPIM(10),NK0L(10),NKPL(10),NKMI(10),NNEUTR(10),
     *                 NPROTO(10),NPROTB(10),NK0S(10),NHYP(10),
     *                 NNEUTB(10),NDEUT(10),NTRIT(10),NALPHA(10),
     *                 NOTHER(10),NMUOND
      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),NALPHA(1)),
     *            (NPARTO(1,22),NOTHER(1)), (NPARTO(1,25),NNEUTB(1)),
     *            (NPARTO(1,23),NMUOND)
*KEEP,OBSPAR.
      COMMON /OBSPAR/  OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP,
     *                 THETPR,PHIPR,
     *                 VUECON,
     *                 NOBSLV
      DOUBLE PRECISION OBSLEV(10),THCKOB(10),XOFF(10),YOFF(10),
     *                 HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2)
      DOUBLE PRECISION VUECON(2)
      INTEGER          NOBSLV
*KEEP,PAM.
      COMMON /PAM/     PAMA,SIGNUM,RESTMS
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000)
*KEEP,PARPAR.
      COMMON /PARPAR/  CURPAR,SECPAR,PRMPAR,OUTPAR,C,
     *                 E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
      DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16),
     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH
      INTEGER          ITYPE,LEVL
*KEEP,PARPAE.
      DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM
     *                 ,WEIGHT
     *                 ,HAPP,COSTAP,COSTEA
      EQUIVALENCE      (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE),
     *                 (CURPAR(4), PHI   ), (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)
*KEEP,PRIMSP.
      COMMON /PRIMSP/  PSLOPE,LLIMIT,ULIMIT,LL,UL,SLEX,ISPEC
      DOUBLE PRECISION PSLOPE,LLIMIT,ULIMIT,LL,UL,SLEX
      INTEGER          ISPEC
*KEEP,RANDPA.
      COMMON /RANDPA/  FAC,U1,U2,RD,NSEQ,ISEED,KNOR
      DOUBLE PRECISION FAC,U1,U2
      REAL             RD(3000)
      INTEGER          ISEED(103,10),NSEQ
      LOGICAL          KNOR
*KEEP,RECORD.
      COMMON /RECORD/  IRECOR
      INTEGER          IRECOR
*KEEP,REJECT.
      COMMON /REJECT/  AVNREJ,ALTMIN,ANEXP,THICKA,THICKD,CUTLN,EONCUT,
     *                 FNPRIM
      DOUBLE PRECISION AVNREJ(10),ALTMIN(10),ANEXP(10),THICKA(10),
     *                 THICKD(10),CUTLN,EONCUT
      LOGICAL          FNPRIM
*KEEP,RESON.
      COMMON /RESON/   RDRES,RESRAN,IRESPAR
      REAL             RDRES(2),RESRAN(30000)
      INTEGER          IRESPAR
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEEP,SIGM.
      COMMON /SIGM/    SIGMA,SIGANN,SIGAIR,FRACTN,FRCTNO
      DOUBLE PRECISION SIGMA,SIGANN,SIGAIR,FRACTN,FRCTNO
*KEEP,STACKF.
      COMMON /STACKF/  STACK,MSTACKP,MEXST,NSHIFT,NOUREC,ICOUNT,
     *                 NTO,NFROM
      INTEGER          MAXSTK
      PARAMETER        (MAXSTK = 16*256*2)
      DOUBLE PRECISION STACK(MAXSTK)
      INTEGER          MSTACKP,MEXST,NSHIFT,NOUREC,ICOUNT,NTO,NFROM
*KEEP,STATI.
      COMMON /STATI/   SABIN,SBBIN,INBIN,IPBIN,IKBIN,IHBIN
      DOUBLE PRECISION SABIN(40),SBBIN(40)
      INTEGER          INBIN(40),IPBIN(40),IKBIN(40),IHBIN(40)
*KEEP,TABLES.
      INTEGER          IEBIN, ITBIN, IDBIN
      PARAMETER        (IEBIN=40,ITBIN=30,IDBIN=20)
      COMMON /TABLES/  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)
*KEEP,THNVAR.
      COMMON /THNVAR/  STACKINT,
     *                 INT_ICOUNT,MODETHN,THINNING
      INTEGER          MAXICOUNT
      PARAMETER        (MAXICOUNT=40000)
      DOUBLE PRECISION STACKINT(16,MAXICOUNT)
      INTEGER          INT_ICOUNT,MODETHN
      LOGICAL          THINNING
*KEEP,VERS.
      COMMON /VERS/    VERNUM,MVDATE,VERDAT
      DOUBLE PRECISION VERNUM
      INTEGER          MVDATE
      CHARACTER*18     VERDAT
*KEEP,CEREN1.
      COMMON /CEREN1/  CERELE,CERHAD,ETADSN,WAVLGL,WAVLGU,CYIELD,
     *                 CERSIZ,CERNOR,LCERFI
      DOUBLE PRECISION CERELE,CERHAD,ETADSN,WAVLGL,WAVLGU,CYIELD,
     *                 CERSIZ,CERNOR
      LOGICAL          LCERFI
*KEEP,CEREN2.
      COMMON /CEREN2/  ACERX,ACERY,CERXOS,CERYOS,
     *                 DCERX,DCERXI,DCERY,DCERYI,EPSX,EPSY,FCERX,FCERY,
     *                 WL,XCMAX,XCMAXS,XSCATT,YCMAX,YCMAXS,YSCATT,
     *                 PHOTCM,XCER,YCER,UEMIS,VEMIS,WEMIS,CARTIM,ZEMIS,
     *                 NCERX,NCERY,ICERML
      DOUBLE PRECISION ACERX,ACERY,CERXOS(20),CERYOS(20),
     *                 DCERX,DCERXI,DCERY,DCERYI,EPSX,EPSY,FCERX,FCERY,
     *                 WL,XCMAX,XCMAXS,XSCATT,YCMAX,YCMAXS,YSCATT
      DOUBLE PRECISION PHOTCM,XCER,YCER,UEMIS,VEMIS,WEMIS,CARTIM,ZEMIS
      INTEGER          NCERX,NCERY,ICERML
*KEEP,CEREN3.
      COMMON /CEREN3/  CERCNT,DATAB2,NRECER,LHCER
      INTEGER          MAXBF2
      PARAMETER        ( MAXBF2 = 39 * 7 )
      DOUBLE PRECISION CERCNT
      REAL             DATAB2(MAXBF2)
      INTEGER          NRECER,LHCER
*KEND.
c----add -changed
c>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
*keep,certel.
      common /certel/  cormxd,cord,coralp,ctpars,omega,
     +                 photn,photnp,phpt,pht,vphot,
     +                 vchi,veta,vzeta,vchim,vetam,vzetam,
     +                 lambda,mu,nu,nctels,ncph,phip1,thetap1
      double precision cormxd,cord,coralp,ctpars(20,7),omega(20,3,3),
     +                 photn(3),photnp(3),phpt(3),pht,vphot(3),
     +                 vchi(3),veta(3),vzeta(3),vchim,vetam,vzetam,
     +                 lambda,mu,nu
      integer          nctels,ncph(5)
      double precision xg,yg,zg,xgp,ygp,zgp,up,vp,wp,xpcut,ypcut,zpcut
      double precision thetap1,phip1
      equivalence (photn(1) ,xg)   ,(photn(2) ,yg)   ,(photn(3) ,zg)  ,
     +            (photnp(1),xgp)  ,(photnp(2),ygp)  ,(photnp(3),zgp),
     +            (phpt(1)  ,xpcut),(phpt(2)  ,ypcut),(phpt(3)  ,zpcut),
     +            (vphot(1) ,up)   ,(vphot(2) ,vp)   ,(vphot(3) ,wp)    

c>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
c     Angles for the "spinning" of a particle around the 
c     main axis of the CT
      common /spinang/ spinxi
      double precision spinxi
C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
c----add -changed

      DOUBLE PRECISION JNBIN(40),JPBIN(40),JKBIN(40),JHBIN(40)
      DOUBLE PRECISION CHI2,FPARAM(6)
      DOUBLE PRECISION MPART2(10,25),MPHOT2(10),MPOSI2(10),MELEC2(10),
     *                 MNU2(10),MMUP2(10),MMUM2(10),MPI02(10),MPIP2(10),
     *                 MPIM2(10),MK0L2(10),MKPL2(10),MKMI2(10),
     *                 MNETR2(10),MPROT2(10),MPRTB2(10),MK0S2(10),
     *                 MHYP2(10),MNETB2(10),MDEUT2(10),MTRIT2(10),
     *                 MALPH2(10),MOTH2(10)
      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),MALPH2(1)),
     *            (MPART2(1,22),MOTH2 (1)), (MPART2(1,25),MNETB2(1))
      DOUBLE PRECISION THICK
      INTEGER          LPCT0,LPCT1
      EXTERNAL         BLOCK1,EGS4BD,HEIGH,THICK
      DOUBLE PRECISION DL,DIAG,FIXHAPP,THCKHN,THICKC
      EXTERNAL         THICKC
      DOUBLE PRECISION XVC1,XVC2,YVC1,YVC2,ZVC1,ZVC2
C  VARIABLES BEING USED FOR RUNTIME
      REAL             TDIFF
      INTEGER          ILEFTA,ILEFTB
      EXTERNAL         TIMER
c-----changed---add
C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
      double precision ctdiams(20)
C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
      double precision theprim, phiprim
      double precision spinthe, spinphi
c      double precision thetap1,phip1

C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
c-----changed--add
C-----------------------------------------------------------------------


      CERELE = 0.D0
      CERHAD = 0.D0
      NRECER = 0
C  INITIALIZE AND READ RUN STEERING CARDS
      CALL START

      IF ( CERSIZ .LE. 0.D0 ) THEN
        ICRSIZ = 0
      ELSE
        ICRSIZ = 1
      ENDIF

C  RESET COUNTER FOR WORDS WRITTEN TO TAPE
      IRECOR = 0

C  RESET COUNTER FOR AVERAGE HEIGHT OF 1ST INTERACTION
      CHISUM = 0.D0
      CHISM2 = 0.D0

C  SET ARRAYS FOR SCALES OF KINETIC ENERGY-INTERACTION TABLE
      SABIN(1) = 0.D0
      SBBIN(1) = 0.1D0
      DO 13  J = 2,40
        SABIN(J) = 10.D0**((J-5.D0)/3.D0)
        SBBIN(J) = 10.D0**((J-4.D0)/3.D0)
  13  CONTINUE

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 17  J = 1,40
        JNBIN(J)  = 0.D0
        JPBIN(J)  = 0.D0
        JKBIN(J)  = 0.D0
        JHBIN(J)  = 0.D0
        ELMEAA(J) = 0.D0
        DO 17  L = 1,13
          MULTOT(J,L) = 0
          IELDPA(J,L) = 0
  17  CONTINUE

C  RESET ARRAYS FOR INTERACTION LENGTH STATISTICS
      DO 90  J = 1,124
        IHYCHI(J) = 0
        IKACHI(J) = 0
        IMUCHI(J) = 0
        INUCHI(J) = 0
        IPICHI(J) = 0
        INNCHI(J) = 0
  90  CONTINUE

C  RESET ARRAY FOR MEAN VALUES AND STANDARD DEVIATION
      DO 477  K = 1,25
      DO 477  J = 1,10
        MPARTO(J,K) = 0.D0
        MPART2(J,K) = 0.D0
 477  CONTINUE

C  RESET ARRAYS FOR AVERAGE LONGITUDINAL DISTRIBUTION
      IF ( LLONGI ) THEN
        LPCT0 = NSTEP
        LPCT1 = 1
        DO  J = 0,NSTEP
          DO  K = 1,9
            AELONG(J,K) = 0.D0
            APLONG(J,K) = 0.D0
            SELONG(J,K) = 0.D0
            SPLONG(J,K) = 0.D0
          ENDDO
          DO  K = 1,9
            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)

C  TIME AT BEGINNING
      CALL TIMER( ILEFTA )
c-----changed--add
cxxc>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
cxx       ILEFTA = 0
cxxc>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
CBC++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C     Modified by C. Bigongiari 2001 Jan 16 
C 
C
Cc>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
      print *,'JCIO::========================================'
      print *,'JCIO:: Initializing JCIO system for advanced'
      print *,'JCIO:: saving of data.'
      print *,'JCIO::========================================'
C
Cc- initialize jcio system
C      
      call jcinitio(dsn,nrrun)
Cc- create file run######
C      call jcstartrun(runh)
Cc>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
C
C- Modified JCSTARTRUN creates cer###### and dat###### files !
C
C     ###### is the RUN number !
C

      call jcstartrun(RUNH)

C
C- write Run Header on cer and dat files  
C 
      CALL TOBUF(RUNH,0)
      IF ( LCERFI ) CALL TOBUFC(RUNH,0)

C
CBC++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c------changed--add
C-----------------------------------------------------------------------
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

C  ENTRY POINT IF COLLISION WAS NOT ACCEPTED IN INTTEST
 2222   CONTINUE

C  FIRST INTERACTION DATA
        FIRSTI = .TRUE.
        IFINET = 0
        IFINNU = 0
        IFINKA = 0
        IFINPI = 0
        IFINHY = 0
        ELAST  = 0.D0
        THICK1 = 0.D0
        TARG1I = 0.D0
        SIGAIR = 0.D0
        SIG1I  = 0.D0

C  RESET COUNTERS
        DO 447  K = 1,25
        DO 447  J = 1,10
          NPARTO(J,K) = 0.D0
 447    CONTINUE

C  RESET ARRAY FOR LONGITUDINAL DISTRIBUTION PER SHOWER
        IF ( LLONGI ) THEN
          DO 479  K = 1,9
            DO  J = 0,NSTEP
              DLONG(J,K) = 0.D0
              ELONG(J,K) = 0.D0
              PLONG(J,K) = 0.D0
            ENDDO
 479      CONTINUE
        ENDIF

        NRECS = 0
        NBLKS = 0
        DO 922  KKK = 1,10
          AVNREJ(KKK) = 0.D0
 922    CONTINUE
        IRESPAR = 0

C  RESET COUNTERS FOR NUCLEON, PION AND KAON TABLE FOR SHOWER
C  RESET ENERGY-MULTIPLICITY & ENERGY-ELASTICITY MATRIX FOR SHOWER
        DO 11  J = 1,40
          INBIN(J) = 0
          IPBIN(J) = 0
          IKBIN(J) = 0
          IHBIN(J) = 0
          ELMEAN(J) = 0.D0
          DO 11  L = 1,13
            MULTMA(J,L) = 0
            IELDPM(J,L) = 0
  11    CONTINUE

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
C  RESET STACKINT
        DO   J = 1,MAXICOUNT
          DO   K = 1,MAXLEN
            STACKINT(K,J) = 0.D0
          ENDDO
        ENDDO
        IRET1 = 0

C  INITIALIZE EVENT HEADER AND END FOR EACH EVENT
        DO 2123  L = 2,43
          EVTH(L) = 0.
 2123   CONTINUE
        DO 123  L = 2,MAXBUF
          EVTE(L) = 0.
 123    CONTINUE

C  SHOWER BEGIN PRINTOUT
        IF ( FPRINT  .OR.  DEBUG ) WRITE(MONIOU,105) ISHOWNO
 105    FORMAT ('1',10('='),' SHOWER NO ',I10,' ',47('=')/)

C  RANDOM GENERATOR STATUS AT BEGINNING OF SHOWER CALCULATION
        EVTH(13) = NSEQ
        DO 45  L = 1,NSEQ
          CALL RMMAQ( ISEED(1,L), L, 'R' )
C  SEED
          EVTH(11+L*3) = 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 )
  45    CONTINUE
        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 RMMAQ( ISEED(1,L), L, 'RV' )
CC        WRITE(MONIOU,658) L,(ISEED(J,L),J=1,103)
CC658     FORMAT ( ' FULL RANDOM NUMBER GENERATOR STATUS ',
CC   *             'FOR SEQUENCE ',I2,/(' ',10I11))
CC495   CONTINUE

C  GET PRIMARY ENERGY INTO PRMPAR(2)
        IF ( ISPEC .EQ. 0 ) THEN
          PRMPAR(2) = LLIMIT
        ELSE
          CALL RMMAR( RD,1,1 )
          IF ( PSLOPE .NE. -1.D0 ) THEN
            PRMPAR(2) = ( RD(1)*UL + ( 1.D0-RD(1) )*LL )**SLEX
          ELSE
            PRMPAR(2) = LLIMIT * LL**RD(1)
          ENDIF
          IF ( FPRINT .OR. DEBUG .OR. MOD(ISHW-1,IPROUT).EQ.0 )
     *       WRITE(MONIOU,*) 'PRIMARY ENERGY = ',PRMPAR(2),' 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(2) = PRMPAR(2) + PAMA(NINT(PRMPAR(1)))
c-------------changes---add
          THETAP1 = THETPR(1)
          PHIP1   = PHIPR(1)
c-------------changes---add



C  GET PRIMARY ANGLES OF INCIDENCE
        IF ( FIXINC ) THEN
          THETAP = THETPR(1)
          PHIP   = PHIPR(1)
          IF ( VUECON(2) .GT. 0.D0 ) THEN
C  THROW UNIFORMLY DISTRIBUTED DIRECTION IN VIEWING CONE OR CONE RING
C  FOR NOW
   46       CALL RMMAR( RD,3,1 )
            CT1 = COS(VUECON(1))
            CT2 = COS(VUECON(2))
            CTT = RD(2) * ( CT2 - CT1 ) + CT1
            THETAP = ACOS(CTT)
            PHIP = RD(1) * PI2
C  TEMPORARY CARTESIAN COORDINATES
            XVC1 = COS(PHIP)*SIN(THETAP)
            YVC1 = SIN(PHIP)*SIN(THETAP)
            ZVC1 = COS(THETAP)
C  ROTATE AROUND Y AXIS
            XVC2 = XVC1*COS(THETPR(1)) + ZVC1*SIN(THETPR(1))
            YVC2 = YVC1
            ZVC2 = ZVC1*COS(THETPR(1)) - XVC1*SIN(THETPR(1))
C  FOR A HORIZONTAL TARGET, THE COS(THETA) WEIGHT IS OBTAINED BY
C  THROWING THE DICE ANOTHER TIME.
            IF ( RD(3) .GT. ZVC2 ) GOTO 46
            THETAP = ACOS(ZVC2)
            IF ( THETAP .GT. 88.D0*(PI/180.D0) ) GOTO 46
            PHIP   = ATAN2(YVC2,XVC2) + PHIPR(1)
            IF ( PHIP .GT. PI2  ) PHIP = PHIP - PI2
            IF ( PHIP .LT. 0.D0 ) PHIP = PHIP + PI2
          ENDIF

C  COSINE OF APPARENT ZENIT ANGLE IS PUT IN PRMPAR(15)
C  (COSINE OF LOCAL ZENIT ANGLE IS IN PRMPAR(3))
          PRMPAR(15) = COS(THETAP)
        ELSE
C  CHOOSE ANGLES AT RANDOM WITH EQUAL FLUX FOR ALL DIRECTIONS
C  WITH HORIZONTAL DETECTOR ARRAY (SEE: O.C. ALLKOFER & P.K.F. GRIEDER,
C  COSMIC RAYS ON EARTH, IN: PHYSICS DATA 25/1, H.BEHRENS & G.EBEL ED.,
C  (FACHINFORMATIONSZENTRUM KARLSRUHE, GERMANY, 1983) CHPT. 1.1.2)
          CALL RMMAR( RD,3,1 )
          CT1 = SIN(THETPR(1))**2
          CT2 = SIN(THETPR(2))**2
          CTT = SQRT( 1.D0 - RD(2)*(CT2 - CT1) - CT1 )
          THETAP = ACOS(CTT)
          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 IS PUT IN PRMPAR(15) = COSTAP
          PRMPAR(15) = CTT
        ENDIF
        PRMPAR(4) = PHIP
        IF ( FPRINT .OR. DEBUG .OR. MOD(ISHW-1,IPROUT).EQ.0 ) THEN
          IF ( VUECON(2) .GT. 0.D0 ) WRITE(MONIOU,669) THETAP,PHIP
 669      FORMAT(' PRIMARY ANGLES ARE: THETA = ',F6.4,' RAD  AND ',
     *               ' PHI = ',F6.4,' RAD')
        ENDIF

C  DEFINE HEIGHT FOR START AT THICK0 (IN G/CM**2)
C  WHICH IS 112.8 KM FOR THICK0 = 0
        PRMPAR(5) = HEIGH(THICK0)
        IF ( LLONGI ) LPCT0 = MIN( INT(THICK0*THSTPI), LPCT0 )

C  CALCULATE COORDINATE CORRECTION FOR TOP OF ATMOSPHERE
C  ALL CALCULATIONS FOR  CURPAR ARE MADE IN CORINC
C  (COSTHE, HAPP, COSTEA). (X, Y) FOR SHOWER CORE = (0,0)
        H  = PRMPAR(5)
        CURPAR(15) = PRMPAR(15)
        CALL CORINC

C  COUNTER FOR PARTICLE OUTPUT
        LH = 0
C  COUNTER FOR CHERENKOV OUTPUT
        IF ( LCERFI ) LHCER = 0
C  CALCULATE BUNCH SIZE FOR CHERENKOV PHOTONS IF NOT SET IN DATAC
        IF ( ICRSIZ .EQ. 0 ) THEN
          CALL GETBUS( NINT(PRMPAR(1)),PRMPAR(2),PRMPAR(3),CERSIZ )
          IF ( FPRINT  .OR.  DEBUG ) WRITE(MONIOU,*)
     *             'CHERENKOV BUNCH SIZE IS CALCULATED TO=',CERSIZ
        ENDIF
        IF ( ICERML .GE. 1 ) THEN
          DO 4438  III = 1,ICERML
c--changes--add
c 5226        CALL SELCOR(CERXOS(III),CERYOS(III))
          if(yscatt.eq.xscatt) then
             cerxos(iii)=yscatt/dcos(thetap1)*dcos(phip1)
             ceryos(iii)=yscatt/dcos(thetap1)*dsin(phip1)
             else
 5226     CALL RMMAR( RD,2,3 )
          CERXOS(III) = 2.0*YSCATT*(RD(1)-0.5)/dcos(thetap1)
          CERYOS(III) = 2.0*YSCATT*(RD(2)-0.5)/dcos(thetap1)
	xx=cerxos(iii)*dcos(phip1)-ceryos(iii)*dsin(phip1)
	yy=cerxos(iii)*dsin(phip1)+ceryos(iii)*dcos(phip1)
	r=dsqrt((xx*dcos(thetap1))**2+yy**2+1.d-7)
	
c          R=SQRT(CERXOS(I)**2+CERYOS(I)**2)
          IF ((R.LT.XSCATT).OR.(R.GT.YSCATT)) GOTO 5226
          endif
c--changes--add
          
            WRITE(MONIOU,4437) ISHW,III,CERXOS(III),CERYOS(III)
 4437       FORMAT(' CORE OF EVENT ',I5,' (SCATT# ',I2,
     *             ') AT ',F12.2,9X,F12.2,' CM')
 4438     CONTINUE
        ENDIF
        DO  480  III = 1,20
          EVTH( 98+III) = CERXOS(III)
          EVTH(118+III) = CERYOS(III)
 480    CONTINUE
C  GET GAMMA FACTOR FROM ENERGY
C  FOR  MASSLESS PRIMARIES  PRMPAR(2) STAYS = ENERGY
        IF ( PAMA(NINT(PRMPAR(1))) .NE. 0.D0 )
     *              PRMPAR(2) = PRMPAR(2) / PAMA(NINT(PRMPAR(1)))

C  SET PRIMARY TO CURRENT PARTICLE
        DO   J = 1,8
          CURPAR(J) = PRMPAR(J)
          NCOUN(J)  = 0
        ENDDO
C  CALCULATE FIRST INTERACTION POINT IF HADRONIC
        GEN = 0.D0
        H   = HEIGH(THICK0)
        CALL BOX2
        IF ( FIX1I ) THEN
C  CALCULATE GEOMETRIC PATH LENGHT 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
          DIAG = SQRT( (C(1)+FIXHEI)**2 - (C(1)+OBSLEV(1))**2
     *           * (1.D0-PRMPAR(15)**2) ) - (C(1)+OBSLEV(1))*PRMPAR(15)
          FIXHAPP = OBSLEV(1) + DIAG * PRMPAR(15)
          DL = (HAPP - FIXHAPP) / PRMPAR(15)
          CALL NRANGC(DL)
          H   = FIXHEI
          FDECAY = .FALSE.

        ELSE
C  CHI IS GIVEN BY BOX2
          THICKH = THICK0
          THCKHN = THICKC(CHI)
          H = HEIGH(THCKHN)
          H = MAX( H, HLAY(1) - 100.D0 )
        ENDIF
        HEIGHP = H
        THICK1 = THICK(H)
        IF ( CURPAR(1) .GT. 3.D0  .OR.  .NOT. FEGS ) THEN
          CHISUM = CHISUM + CHI
          CHISM2 = CHISM2 + CHI**2
        ENDIF
        ALEVEL = H

C  STORE PRIMARY COORDINATES FOR ADDITIONAL MUON INFORMATION
        IF ( FMUADD ) THEN
          IF ( CURPAR(1) .EQ. 5  .OR.  CURPAR(1) .EQ. 6 ) THEN
            DO   J = 1,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  SET TARGET FLAG IF SELECTED FOR FIRST INTERACTION
        IF ( N1STTR .GT. 0 ) 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) = CURPAR(1)
        IF ( PAMA(NINT(CURPAR(1))) .EQ. 0.D0 ) THEN
C  PRIMARY ENERGY FOR MASSLESS PARTICLES (PHOTONS, NEUTRINOS)
          E00   = GAMMA
          E00PN = GAMMA
          INUCL = 1
        ELSE
          E00   = GAMMA * PAMA(NINT(CURPAR(1)))
          INUCL = INT(MAX(1.D0,CURPAR(1)/100.D0))
          E00PN = E00 / INUCL
        ENDIF
        EVTH(148) = 0.
        EVTH(149) = 0.
        EVTH(150) = 0.
        EVTH(151) = 0.
        EVTH(152) = 0.

        IF ( FEGS ) THEN
C  PARAMETER FOR ELECTRON AND PHOTON REJECT (CONVERT ENERGY TO MEV)
          EONCUT = .5D-9*SQRT(E00*1000.D0)
          CUTLN  = LOG(EONCUT)
        ENDIF
        EVTH( 4) = E00
        EVTH( 5) = THICK0
        EVTH( 7) = HEIGHP
        PTOT0    = SQRT( E00**2 - PAMA(NINT(CURPAR(1)))**2 )
        PTOT0N   = PTOT0 / INUCL

C  PUT APPARENT ANGLES (SEEN FROM DETECTOR) INTO EVENT HEADER
        ST       = SQRT(1.D0-COSTAP**2)
        EVTH(10) = PTOT0 * COSTAP
        THETA    = ACOS(COSTAP)
        EVTH( 8) = PTOT0 * ST * COS(PHI)
        EVTH( 9) = PTOT0 * ST * SIN(PHI)
        EVTH(11) = THETA
        EVTH(12) = PHI
C  WRITE ENERGY AND ANGLES OF PRIMARY TO DBASE FILE FOR THE FIRST SHOWER
        IF ( FDBASE  .AND.  ISHW .EQ. 1 ) THEN
          WRITE(MDBASE,668) E00, THETA*180.D0/PI, PHI*180.D0/PI
 668      FORMAT(1P,'#energy_prim#',E14.7,'#theta_prim#',E14.7,
     *           '#phi_prim#',E14.7)
          CLOSE(UNIT=MDBASE)
        ENDIF
        EVTH(85) = CERSIZ

        IF ( DEBUG  .OR.  FPRINT ) THEN
          WRITE(MONIOU,*)
        ENDIF
        IF ( CURPAR(1) .GT. 3.D0 ) THEN
          IF ( DEBUG ) THEN
            WRITE(MONIOU,102) (CURPAR(J),J = 1,8)
 102        FORMAT (' PRIMARY PARAMETERS AT FIRST INTERACTION POINT'/
     *               16X,1P,8E10.3)
          ELSEIF ( FPRINT ) THEN
            WRITE(MONIOU,1021) (CURPAR(J),J = 1,8)
 1021     FORMAT (' PRIMARY PARAMETERS AT FIRST INTERACTION POINT'/
     *               1X,1P,8E10.3)
          ENDIF
        ELSE
          IF ( FPRINT  .OR.  DEBUG ) WRITE(MONIOU,132)
 132      FORMAT (/' PRIMARY PARTICLE IS ELECTROMAGNETIC')
        ENDIF

C  WRITE EVENT HEADER INTO BUFFER
C  FOR EM PARTICLES EVTH IS WRITTEN TO BUFFER IN EGS (IF ACTIVE)
        IF ( EVTH(3) .GT. 3.0  .OR.  .NOT. FEGS ) THEN
C  NEGATIVE FIRST INTERACTIN HEIGHT, IF TRACKING STARTS AT ATMOS. MARGIN
          CALL TOBUF ( EVTH,0 )
          IF ( LCERFI ) CALL TOBUFC( EVTH,0 )
        ENDIF

C  PRINT HEADER FOR HIGH ENERGY PARTICLES
        IF ( FPRINT  .OR.  DEBUG ) WRITE(MONIOU,103)
 103    FORMAT(/'                   TYPE      GAMMA   COSTHETA ',
     *          '    PHI     HEIGHT     TIME      X-CM      Y-CM   ',
     *          '  GEN   ALEVEL  E ON STACK'/)
        NOPART = 0



        IF ( CURPAR(1) .LE. 3.D0  .OR.
     *      (CURPAR(1) .EQ. 5.D0  .OR.  CURPAR(1) .EQ. 6.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 ( CURPAR(1) .LE. 3.D0 ) THEN
C  EM PARTICLES
            FNPRIM = .FALSE.
            BNORMC = BNORM*1.D-3
          ELSE
C  MUONS
            FNPRIM = .TRUE.
            H      = PRMPAR(5)
            IF ( TMARGIN ) BNORMC = BNORM*1.D-3
          ENDIF
c-----changed--add
          fmfb=.true.
          CALL BOX3(fmfb)
          fmfb=.false.
c-----changed--add
          BNORMC = BNORM*1.D-3
          IF ( FEGS ) THEN
            CHISUM = CHISUM + THICK(ABS(DBLE(EVTH(7))))
            CHISM2 = CHISM2 + THICK(ABS(DBLE(EVTH(7))))**2
          ENDIF
          FIRSTI = .FALSE.
          GOTO 4

        ELSE
C  HADRONIC PARTICLES
          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
          FLAG = .FALSE.
c--changed---add
          fmfb=.true.
          CALL UPDATC(IPAS,FLAG,fmfb)
          fmfb=.false.
c--changed---add

C  ELIMINATE PARTICLE IF BELOW CUTS BY JUMP TO LABEL 4
          IF ( IRET2 .NE. 0 ) GOTO 4
          IF ( IPAS .EQ. 0 ) THEN
C  PARTICLE DID NOT REACH OBSERVATION LEVEL
C  START CLOCK AT FIRST INTERACTION (MAGNETIC FIELD IS SET IN INPRM)
            CURPAR(6) = 0.D0
C  JUMP INTO NORMAL PARTICLE TREATMENT FOR HADRONS
            GOTO 6
          ENDIF

          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 ( CURPAR(1) .NE. 1.D0 ) THEN
            IF ( CURPAR(1).EQ.5.D0  .OR.  CURPAR(1).EQ.6.D0 )
     *                                        FMUORG = .FALSE.
            IF ( LLONGI ) THEN
C  ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT
              LHEIGH = INT(THICK(H)*THSTPI + 1.D0)
              IF     ( ITYPE .EQ. 2                       ) THEN
                DLONG(LHEIGH,3) = DLONG(LHEIGH,3) + (GAMMA+1.D0)*PAMA(2)
              ELSEIF ( ITYPE .EQ. 3                       ) THEN
                DLONG(LHEIGH,3) = DLONG(LHEIGH,3) + (GAMMA-1.D0)*PAMA(2)
              ELSEIF ( ITYPE .EQ. 5  .OR.   ITYPE .EQ. 6  ) THEN
                DLONG(LHEIGH,5) = DLONG(LHEIGH,5) + GAMMA * PAMA(5)
              ELSEIF ( ITYPE .GE. 7  .AND.  ITYPE .LE. 74 ) THEN
                DLONG(LHEIGH,7) = DLONG(LHEIGH,7) + GAMMA * PAMA(ITYPE)
     *                                            - RESTMS(ITYPE)
              ENDIF
            ENDIF
            GOTO 4
          ENDIF
C  SPECIAL TREATMENT FOR PHOTONS
          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(fmfb)
        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) + 1
        MULTOT(MEN,MMU) = MULTOT(MEN,MMU) + 1
        IF ( DEBUG ) WRITE(MDEBUG,*) 'AAMAIN: EKINL,MSMM=',
     *                                  SNGL(EKINL),MSMM

        IF ( IRET1 .EQ. 0 ) THEN
          IF ( DEBUG ) WRITE(MDEBUG,666) (CURPAR(II),II=1,9)
 666      FORMAT(' AAMAIN: CURPAR=',1P,9E10.3)
          GOTO 7
        ENDIF

C  GET NEXT PARTICLE FROM STACK, IF IRET=1 ALL PARTICLES ARE DONE
  4     CONTINUE
        IRET1 = 0
        CALL FSTACK
        IF ( FMUADD ) THEN
          IF ( (CURPAR(1) .EQ. 5  .OR.  CURPAR(1) .EQ. 6)
     *         .AND.  IRET1 .EQ. 0  .AND.  .NOT. FMUORG ) THEN
            DO   J = 1,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

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

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

        IF ( FPRINT  .OR.  DEBUG ) THEN
          IOBSLV = MIN( 5, NOBSLV )
          WRITE(MONIOU,54) (K,K=1,IOBSLV)
  54      FORMAT (/' PARTICLES AT DETECTOR LEVEL :'/
     *             ' FOR LEVEL         ', 5I13)
          WRITE(MONIOU,55) (OBSLEV(K),K=1,IOBSLV)
  55      FORMAT ( ' HEIGHT IN CM        ',1P, 5E13.3/)
          WRITE(MONIOU,555) (THCKOB(K),K=1,IOBSLV)
 555      FORMAT ( ' HEIGHT IN G/CM**2   ',1P, 5E13.3/)
          WRITE(MONIOU,776) 'PROTONS      ',(NPROTO(K),K=1,IOBSLV)
          WRITE(MONIOU,776) 'ANTIPROTONS  ',(NPROTB(K),K=1,IOBSLV)
          WRITE(MONIOU,776) 'NEUTRONS     ',(NNEUTR(K),K=1,IOBSLV)
          WRITE(MONIOU,776) 'ANTINEUTRONS ',(NNEUTB(K),K=1,IOBSLV)
          WRITE(MONIOU,775) 'PHOTONS      ',(NPHOTO(K),K=1,IOBSLV)
          WRITE(MONIOU,775) 'ELECTRONS    ',(NELECT(K),K=1,IOBSLV)
          WRITE(MONIOU,775) 'POSITRONS    ',(NPOSIT(K),K=1,IOBSLV)
          WRITE(MONIOU,776) 'MU -         ',(NMUM  (K),K=1,IOBSLV)
          WRITE(MONIOU,776) 'MU +         ',(NMUP  (K),K=1,IOBSLV)
          WRITE(MONIOU,776) 'PI 0         ',(NPI0  (K),K=1,IOBSLV)
          WRITE(MONIOU,776) 'PI -         ',(NPIM  (K),K=1,IOBSLV)
          WRITE(MONIOU,776) 'PI +         ',(NPIP  (K),K=1,IOBSLV)
          WRITE(MONIOU,776) 'K0L          ',(NK0L  (K),K=1,IOBSLV)
          WRITE(MONIOU,776) 'K0S          ',(NK0S  (K),K=1,IOBSLV)
          WRITE(MONIOU,776) 'K -          ',(NKMI  (K),K=1,IOBSLV)
          WRITE(MONIOU,776) 'K +          ',(NKPL  (K),K=1,IOBSLV)
          WRITE(MONIOU,776) 'STR. BARYONS ',(NHYP  (K),K=1,IOBSLV)
          WRITE(MONIOU,776) 'DEUTERONS    ',(NDEUT (K),K=1,IOBSLV)
          WRITE(MONIOU,776) 'TRITONS      ',(NTRIT (K),K=1,IOBSLV)
          WRITE(MONIOU,776) 'ALPHAS       ',(NALPHA(K),K=1,IOBSLV)
          WRITE(MONIOU,776) 'OTHER PARTIC.',(NOTHER(K),K=1,IOBSLV)
          WRITE(MONIOU,*)
          WRITE(MONIOU,776) 'DECAYED MUONS',NMUOND
 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) 'PHOTONS      ',(NPHOTO(K),K=6,IOBSLV)
            WRITE(MONIOU,775) 'ELECTRONS    ',(NELECT(K),K=6,IOBSLV)
            WRITE(MONIOU,775) 'POSITRONS    ',(NPOSIT(K),K=6,IOBSLV)
            WRITE(MONIOU,776) 'MU -         ',(NMUM  (K),K=6,IOBSLV)
            WRITE(MONIOU,776) 'MU +         ',(NMUP  (K),K=6,IOBSLV)
            WRITE(MONIOU,776) 'PI 0         ',(NPI0  (K),K=6,IOBSLV)
            WRITE(MONIOU,776) 'PI -         ',(NPIM  (K),K=6,IOBSLV)
            WRITE(MONIOU,776) 'PI +         ',(NPIP  (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 -          ',(NKMI  (K),K=6,IOBSLV)
            WRITE(MONIOU,776) 'K +          ',(NKPL  (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) 'ALPHAS       ',(NALPHA(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 779  K = 1,25
        DO 779  J = 1,10
          MPARTO(J,K) = MPARTO(J,K) + NPARTO(J,K)
          MPART2(J,K) = MPART2(J,K) + NPARTO(J,K)**2
 779    CONTINUE
        EVTE(2) = ISHOWNO
        IOBSLV = NOBSLV
        DO 335  K = 1,IOBSLV
          EVTE(3) = EVTE(3) + NPHOTO(K)
          EVTE(4) = EVTE(4) + NELECT(K) + NPOSIT(K)
          EVTE(5) = EVTE(5) + NPROTO(K) + NPROTB(K) + NNEUTR(K) +
     *              NNEUTB(K) + NPI0(K) + NPIM(K) + NPIP(K) + NK0L(K) +
     *              NK0S(K) + NKMI(K) + NKPL(K) + NHYP(K) +
     *              NDEUT(K) + NTRIT(K) + NALPHA(K) + NOTHER(K)
          EVTE(6) = EVTE(6) + NMUP(K) + NMUM(K)
 335    CONTINUE
        EVTE(7)   = NOPART

        IF ( FPRINT  .OR.  DEBUG ) WRITE(MONIOU,110)
     *                  IFINNU,IFINPI,IFINET,IFINKA,IFINHY,
     *                  IFINNU+IFINPI+IFINET+IFINKA+IFINHY,
     *                  ELAST,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/
     *    ' 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/
     *  ' 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
c--------changed------add
c>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
c   calculated here again, 'cos it's rewrite I dont know where
          LPCT1 = INT( THICK0 * THSTPI )
          LPCT2 = INT( (THICK0 + PRMPAR(3)*CHI) * THSTPI )
          LPCT2 = MIN(NSTEP,LPCT2)
c>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
c-------changed ---add---


        IF ( LLONGI ) THEN
C  TREAT LONGITUDINAL DISTRIBUTIONS
          DO 980  J = 0,NSTEP
C  ADD UP ENERGY DEPOSIT AND IONIZATION FOR SUM
            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)
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,9
              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,9
              ADLONG(J,K) = ADLONG(J,K) + DLONG(J,K)
              SDLONG(J,K) = SDLONG(J,K) + DLONG(J,K)**2
            ENDDO
 980      CONTINUE

C  PRINT LONGITUDINAL DISTRIBUTIONS PER SHOWER
          IF ( FPRINT  .OR.  DEBUG ) THEN
            WRITE(MONIOU,910) THSTEP,
     *      'GAMMAS','POSITRONS','ELECTRONS','MU+','MU-','HADRONS',
     *      'CHARGED','NUCLEI','CHERENKOV',
     *      (J*THSTEP,(PLONG(J,K),K=1,9),J=LPCT1,NSTEP)
 910        FORMAT(/' ---------- LONGITUDINAL PARTICLE DISTRIBUTION IN '
     *        ,'STEPS OF ',F5.0,' G/CM**2 ',50(1H-)/
     *        '  DEPTH ',3A14,3A12,A12,A11,A12/
     *        (' ',F6.0,F15.0,2F14.0,3F12.0,F14.0,F11.0,1P,E12.5,0P) )
CJOK  ADAPTED FOR HEAT CALCULATION
C910      FORMAT(/
C    *    ' LONGITUDINAL DISTRIBUTION IN STEPS OF ',F5.0,' G/CM**2'
C    *      /' ',92('=')/'  DEPTH',8A10,A12/1P
C    *      (' ',0P,F6.0,1P,9E11.4))
CJOK
C  ENERGY DISTRIBUTION
            WRITE(MONIOU,908) THSTEP,
     *      'GAMMAS','POSITRONS','ELECTRONS','MU+','MU-','HADRONS',
     *      'CHARGED','NUCLEI','SUM',
     *      (J*THSTEP,(ELONG(J,K),K=1,9),J=LPCT1,NSTEP)
 908        FORMAT(/' ---------- LONGITUDINAL ENERGY DISTRIBUTION ',
     *        '[GEV] IN STEPS OF ',F5.0,' G/CM**2 ',47(1H-)/
     *        '  DEPTH',9(A12,1X)/ (' ',F6.0,1P,9E13.5,0P) )
C  ENERGY DEPOSIT
            WRITE(MONIOU,909) THSTEP,
     *       ' GAMMA      ','EM IONIZ','EM CUT','MU IONIZ','MU CUT',
     *       'HADR IONIZ','HADR CUT','NEUTRINO ','    SUM',
     *      ((2*J-1)*.5*THSTEP,(DLONG(J,K),K=1,9),
     *                                     J=MAX(1,LPCT1),NSTEP-1)
 909        FORMAT(/' ---------- LONGITUDINAL ENERGY DEPOSIT [GEV] IN ',
     *        'STEPS OF ',F5.0,' G/CM**2 ',51(1H-)/
     *        '  DEPTH ',3A14,6A12,/,(' ',F6.1,1X,3F14.1,5F12.1,F13.1))
            WRITE(MONIOU,9091) (2*NSTEP-1)*.5*THSTEP,
     *                         (DLONG(NSTEP,K),K=1,9)
 9091       FORMAT(' ',F6.1,1X,1P,3E14.7,5E12.5,E13.6)
            DLONGSUM = 0.D0
            DO   K = 1,9
              DO   J = 0,NSTEP
                DLONG(1170,K) = DLONG(1170,K) + DLONG(J,K)
              ENDDO
              IF ( K .NE. 9 ) DLONGSUM = DLONGSUM + DLONG(1170,K)
            ENDDO
            WRITE(MONIOU,907) (DLONG(1170,K),K=1,8)
 907        FORMAT(' ',20X,'        LONGITUDINAL ENERGY SUM [GEV] ',/
     *         ,' ',7X,1P,3E14.7,5E12.5)
            WRITE(MONIOU,919) DLONGSUM
            DO   K = 1,9
              DLONG(1170,K) = 0.D0
            ENDDO
          ENDIF
C  WRITE OUT LONGITUDINAL DISTRIBUTION
          IF ( FLONGOUT ) THEN
            WRITE(MLONGOUT,211) NSTEP,THSTEP,ISHOWNO,
     *      'GAMMAS','POSITRONS','ELECTRONS','MU+','MU-','HADRONS',
     *      'CHARGED','NUCLEI','CHERENKOV'
C
C  DO NOT CHANGE THIS FORMAT, AS THE CorsTo Root PROGRAM DEPENDS ON IT
C
 211        FORMAT(' LONGITUDINAL DISTRIBUTION IN ',I5,
     *             ' VERTICAL STEPS OF ',F5.0,' G/CM**2 FOR SHOWER ',
     *             I7,/,' DEPTH',9(A11,1X) )
            DO  J = 1, NSTEP
              WRITE(MLONGOUT,212) J*THSTEP,(PLONG(J,K),K=1,9)
C
C  DO NOT CHANGE THIS FORMAT, AS THE CorsTo Root PROGRAM DEPENDS ON IT
C
 212          FORMAT(' ',F5.0,1P,9(E12.5),0P)
            ENDDO
            WRITE(MLONGOUT,213) NSTEP,THSTEP,ISHOWNO,
     *             'GAMMA ','EM IONIZ','EM CUT','MU IONIZ','MU CUT',
     *             'HADR IONIZ','HADR CUT','NEUTRINO ','  SUM  '
C
C  DO NOT CHANGE THIS FORMAT, AS THE CorsTo Root PROGRAM DEPENDS ON IT
C
 213        FORMAT(' LONGITUDINAL ENERGY DEPOSIT IN ',I5,
     *             ' VERTICAL STEPS OF ',F5.0,' G/CM**2 FOR SHOWER ',
     *             I7,/,' DEPTH  ',3A11,6A12)
            DO  J = 1, NSTEP
              DEPSTEP = (2*J-1)*.5*THSTEP
              WRITE(MLONGOUT,214) DEPSTEP,
     *         (DLONG(J,K),K=1,9)
C
C  DO NOT CHANGE THIS FORMAT, AS THE CorsTo Root PROGRAM DEPENDS ON IT
C
 214          FORMAT(' ',F6.1,1P,9(E12.5),0P)
            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(DBLE(EVTH(7))) !THICKNESS 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( (NSTEP-1)/26 ) + 1
            ARRAYLONG(5) = JJEND + 100*NSTEP     !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. NSTEP ) 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 930  J = 0,NSTEP-LPCT1
                DEP(J+1)    = (J+LPCT1)*THSTEP
                CHAPAR(J+1) = MAX( PLONG(J+LPCT1,7), 0.D0 )
 930          CONTINUE
              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 931  J = 1,IALT(1)
                DEP(J+1)    = TLEV(J)
                CHAPAR(J+1) = MAX( SL(J), 0.D0 )
 931          CONTINUE
              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 932  J = 0,NSTEP-LPCT1
                DEP(J+1)    = (J+LPCT1)*THSTEP
                CHAPAR(J+1) = MAX( PLONG(J+LPCT1,7), 0.D0 )
 932          CONTINUE
              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.
              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
              DO 933  K = 1,6
                EVTE(255+K) = FPARAM(K)
 933          CONTINUE
              EVTE(262) = CHI2
            ELSE
              WRITE(MONIOU,*) 'NO LONGI. FIT POSSIBLE, ',
     *          ' NSTP = ',NSTP,'  TOO SMALL.'
              DO 934  K = 1,6
                EVTE(255+K) = 0.
 934          CONTINUE
              EVTE(262) = 0.
            ENDIF
          ENDIF
        ENDIF
c----changed---add
CBC++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C     Modified by C. Bigongiari 2001 Jan 16 
C 
C
Cc>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
c   Saves statistics to sta###### file
cxxand many lines with comand - simply keep output like in standart
CBC++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 
c---changed--add

C  WRITE SHOWER END TO OUTPUT BUFFER
        CALL TOBUF( EVTE,0 )
        IF ( LCERFI ) THEN
          CALL OUTND2
          CALL TOBUFC( EVTE,0 )
        ENDIF

        IF ( FPRINT  .OR.  DEBUG ) WRITE(MONIOU,*)
     *                 'CHERENKOV PH. FROM ELECTRONS = ',SNGL(CERELE),
     *                 '  CHERENKOV PH. FROM HADRONS = ',SNGL(CERHAD)
        CERELE = 0.D0
        CERHAD = 0.D0
        NRECER = 0

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

  2   CONTINUE
C  END OF SHOWER LOOP

C-----------------------------------------------------------------------
 992  CONTINUE

      WRITE(MONIOU,*) ' '
      CALL PRTIME(TTIME)
      DO   L = 1,NSEQ
        CALL RMMAQ( 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)
      TDIFF = ILEFTB - ILEFTA

C  WRITE RUN END TO OUTPUT BUFFER AND FINISH OUTPUT
c---------changed------add
CBC++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C     Modified by C. Bigongiari 2001 Jan 16 
C
Cc>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
Cc      CALL TOBUF ( RUNE,1 )
C      call jcendrun(rune)
Cc      IF ( LCERFI ) CALL TOBUFC( RUNE,1 )
Cc>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
C
C- write Run End      
CBC++++++++++++++++++++++++++++++++++++++++++++++++++++++++++C
c---------changed------add
      CALL TOBUF ( RUNE,1 )
      IF ( LCERFI ) CALL TOBUFC( RUNE,1 )
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,IRECOR,IRECOR/ISHW,
     *                   CHISUM,CHISM2
 201  FORMAT('1',10('='),' RUN SUMMARY ',56('=')//
     *  ' NUMBER OF GENERATED EVENTS = ',I10,/
     *  ' TOTAL TIME USED            = ',F12.0,'   SEC'/
     *  ' TIME PER EVENT             = ',F14.2,' SEC'/
     *  ' TOTAL SPACE ON MPATAP USED = ',I12,' WORDS'/
     *  ' SPACE PER EVENT ON MPATAP  = ',I12,' WORDS'/
     *  ' AVERAGE HEIGHT OF 1ST INT. = ',F10.3,' +-',F10.3,' G/CM**2'/)

C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      IF ( ISHW .GT. 1 ) THEN
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,1X,1P,2E10.1,0P)//
     *    ' MULT. ',5I10,3I8,5I6,4X,'LOWER BIN LIMIT'/
     *    ' RANGE ',5I10,3I8,5I6,4X,'UPPER BIN LIMIT')


C  GET MEAN OF ELASTICITY FOR ENERGY BINS
        DO 3377  J = 1,40
          NELMEA = 0
          DO 3378  K = 1,10
            NELMEA = NELMEA + IELDPA(J,K)
 3378     CONTINUE
          IF ( NELMEA .NE. 0 ) ELMEAA(J) = ELMEAA(J) / NELMEA
 3377 CONTINUE

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'//
     *    ' ',5X,7I9,3I10,'   MEAN EL.   ENERGY RANGE (GEV)'/
     *    39(/' ',I4,1X,7I9,3I10,2X,1P,E10.3,2E10.1,0P)//
     *    ' ELA. ',7F9.2,3F10.2,5X,'LOWER BIN LIMIT'/
     *    ' RANGE',7F9.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  CALCULATE MEAN VALUES AND STANDARD DEVIATIONS OF PARTICLE NUMBERS
        IF ( ISHW .GT. 1 ) THEN
          DO 879  K = 1,25
            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
 879      CONTINUE
        ELSE
          DO 881  K = 1,25
            IOBSLV = NOBSLV
            DO  J = 1,IOBSLV
              MPART2(J,K) = 0.D0
            ENDDO
 881      CONTINUE
        ENDIF

C  PRINT MEAN VALUES AND STANDARD DEVIATIONS OF PARTICLE NUMBERS
        IOBSLV = MIN( 3, NOBSLV )
        WRITE(MONIOU,854) (K,K=1,IOBSLV)
 854    FORMAT (/ ' AVERAGE NUMBER OF PARTICLES PER EVENT :'/
     *                    ' FROM LEVEL NUMBER ', 3(10X,I10,10X) )
        WRITE(MONIOU,855) (OBSLEV(K),K=1,IOBSLV)
 855    FORMAT (  ' HEIGHT IN CM',1P,3(20X,E10.3)/)
        WRITE(MONIOU,856) (THCKOB(K),K=1,IOBSLV)
 856    FORMAT ( ' HEIGHT IN G/CM**2',1P,3(14X,E10.3,6X)/)

        WRITE(MONIOU,778)'PROTONS     ',(MPROTO(K),MPROT2(K),K=1,IOBSLV)
        WRITE(MONIOU,778)'ANTIPROTONS ',(MPROTB(K),MPRTB2(K),K=1,IOBSLV)
        WRITE(MONIOU,778)'NEUTRONS    ',(MNEUTR(K),MNETR2(K),K=1,IOBSLV)
        WRITE(MONIOU,778)'ANTINEUTRONS',(MNEUTB(K),MNETB2(K),K=1,IOBSLV)
        WRITE(MONIOU,777)'PHOTONS     ',(MPHOTO(K),MPHOT2(K),K=1,IOBSLV)
        WRITE(MONIOU,777)'ELECTRONS   ',(MELECT(K),MELEC2(K),K=1,IOBSLV)
        WRITE(MONIOU,777)'POSITRONS   ',(MPOSIT(K),MPOSI2(K),K=1,IOBSLV)
        WRITE(MONIOU,778)'MU -        ',(MMUM  (K),MMUM2 (K),K=1,IOBSLV)
        WRITE(MONIOU,778)'MU +        ',(MMUP  (K),MMUP2 (K),K=1,IOBSLV)
        WRITE(MONIOU,778)'PI 0        ',(MPI0  (K),MPI02 (K),K=1,IOBSLV)
        WRITE(MONIOU,778)'PI -        ',(MPIM  (K),MPIM2 (K),K=1,IOBSLV)
        WRITE(MONIOU,778)'PI +        ',(MPIP  (K),MPIP2 (K),K=1,IOBSLV)
        WRITE(MONIOU,778)'K0L         ',(MK0L  (K),MK0L2 (K),K=1,IOBSLV)
        WRITE(MONIOU,778)'K0S         ',(MK0S  (K),MK0S2 (K),K=1,IOBSLV)
        WRITE(MONIOU,778)'K -         ',(MKMI  (K),MKMI2 (K),K=1,IOBSLV)
        WRITE(MONIOU,778)'K +         ',(MKPL  (K),MKPL2 (K),K=1,IOBSLV)
        WRITE(MONIOU,778)'STR. BARYONS',(MHYP  (K),MHYP2 (K),K=1,IOBSLV)
        WRITE(MONIOU,778)'DEUTERONS   ',(MDEUT (K),MDEUT2(K),K=1,IOBSLV)
        WRITE(MONIOU,778)'TRITONS     ',(MTRIT (K),MTRIT2(K),K=1,IOBSLV)
        WRITE(MONIOU,778)'ALPHAS      ',(MALPHA(K),MALPH2(K),K=1,IOBSLV)
        WRITE(MONIOU,778)'OTHER PART. ',(MOTHER(K),MOTH2 (K),K=1,IOBSLV)
        WRITE(MONIOU,*)
        WRITE(MONIOU,778) 'DECAYED MUONS',MMUOND
 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)'PHOTONS     ',(MPHOTO(K),MPHOT2(K),K=4,IOBSLV)
        WRITE(MONIOU,777)'ELECTRONS   ',(MELECT(K),MELEC2(K),K=4,IOBSLV)
        WRITE(MONIOU,777)'POSITRONS   ',(MPOSIT(K),MPOSI2(K),K=4,IOBSLV)
        WRITE(MONIOU,778)'MU -        ',(MMUM  (K),MMUM2 (K),K=4,IOBSLV)
        WRITE(MONIOU,778)'MU +        ',(MMUP  (K),MMUP2 (K),K=4,IOBSLV)
        WRITE(MONIOU,778)'PI 0        ',(MPI0  (K),MPI02 (K),K=4,IOBSLV)
        WRITE(MONIOU,778)'PI -        ',(MPIM  (K),MPIM2 (K),K=4,IOBSLV)
        WRITE(MONIOU,778)'PI +        ',(MPIP  (K),MPIP2 (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 -         ',(MKMI  (K),MKMI2 (K),K=4,IOBSLV)
        WRITE(MONIOU,778)'K +         ',(MKPL  (K),MKPL2 (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)'ALPHAS      ',(MALPHA(K),MALPH2(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)'PHOTONS     ',(MPHOTO(K),MPHOT2(K),K=7,IOBSLV)
        WRITE(MONIOU,777)'ELECTRONS   ',(MELECT(K),MELEC2(K),K=7,IOBSLV)
        WRITE(MONIOU,777)'POSITRONS   ',(MPOSIT(K),MPOSI2(K),K=7,IOBSLV)
        WRITE(MONIOU,778)'MU -        ',(MMUM  (K),MMUM2 (K),K=7,IOBSLV)
        WRITE(MONIOU,778)'MU +        ',(MMUP  (K),MMUP2 (K),K=7,IOBSLV)
        WRITE(MONIOU,778)'PI 0        ',(MPI0  (K),MPI02 (K),K=7,IOBSLV)
        WRITE(MONIOU,778)'PI -        ',(MPIM  (K),MPIM2 (K),K=7,IOBSLV)
        WRITE(MONIOU,778)'PI +        ',(MPIP  (K),MPIP2 (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 -         ',(MKMI  (K),MKMI2 (K),K=7,IOBSLV)
        WRITE(MONIOU,778)'K +         ',(MKPL  (K),MKPL2 (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)'ALPHAS      ',(MALPHA(K),MALPH2(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)'PHOTONS     ',(MPHOTO(K),MPHOT2(K),K=9,IOBSLV)
        WRITE(MONIOU,777)'ELECTRONS   ',(MELECT(K),MELEC2(K),K=9,IOBSLV)
        WRITE(MONIOU,777)'POSITRONS   ',(MPOSIT(K),MPOSI2(K),K=9,IOBSLV)
        WRITE(MONIOU,778)'MU -        ',(MMUM  (K),MMUM2 (K),K=9,IOBSLV)
        WRITE(MONIOU,778)'MU +        ',(MMUP  (K),MMUP2 (K),K=9,IOBSLV)
        WRITE(MONIOU,778)'PI 0        ',(MPI0  (K),MPI02 (K),K=9,IOBSLV)
        WRITE(MONIOU,778)'PI -        ',(MPIM  (K),MPIM2 (K),K=9,IOBSLV)
        WRITE(MONIOU,778)'PI +        ',(MPIP  (K),MPIP2 (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 -         ',(MKMI  (K),MKMI2 (K),K=9,IOBSLV)
        WRITE(MONIOU,778)'K +         ',(MKPL  (K),MKPL2 (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)'ALPHAS      ',(MALPHA(K),MALPH2(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,NSTEP
              DO  K = 1,9
                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,9
                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,NSTEP
              DO   K = 1,9
                SDLONG(J,K) = 0.D0
              ENDDO
              DO   K = 1,9
                SELONG(J,K) = 0.D0
                SPLONG(J,K) = 0.D0
              ENDDO
            ENDDO
          ENDIF

C  PRINT AVERAGE LONGITUDINAL PARTICLE DISTRIBUTIONS
          WRITE(MONIOU,911) THSTEP,
     *      'GAMMAS ','POSITRONS','ELECTRONS','MU+  ','MU-  ',
     *      (J*THSTEP,(APLONG(J,K),SPLONG(J,K),K=1,5),J=LPCT0,NSTEP)
 911      FORMAT(/' AVERAGE LONGITUDINAL PARTICLE DISTRIBUTION IN ',
     *      'STEPS OF ',F5.0,' G/CM**2 '/' ',132('=')/
     *      ' DEPTH',6X,A9,16X,2(A10,17X),A9,16X,A9 //
     *      (' ',F5.0,1X,1P,E10.4,'+-',E10.4,0P,1X,F13.0,'+-',F12.0,
     *      1X,F13.0,'+-',F12.0,1X,F10.0,'+-',F11.0,
     *      1X,F10.0,'+-',F11.0 ))
          WRITE(MONIOU,912) THSTEP,
     *      'HADRONS','CHARGED','NUCLEI','CHERENKOV',
     *      (J*THSTEP,(APLONG(J,K),SPLONG(J,K),K=6,9),J=LPCT0,NSTEP)
 912      FORMAT(/' AVERAGE LONGITUDINAL PARTICLE DISTRIBUTION IN ',
     *      'STEPS OF ',F5.0,' G/CM**2 '/' ',118('=')/
     *      ' DEPTH',8X,A9,17X,A10,17X,A9,21X,A9 //
     *      (' ',F5.0,1X,F11.1,'+-',F11.1,1X,F13.0,'+-',F13.0,
     *      2X,F10.1,'+-',F10.1,1X,1P,E16.6,'+-',E16.6,0P))
C  PRINT AVERAGE LONGITUDINAL ENERGY DISTRIBUTIONS
          WRITE(MONIOU,915) THSTEP,
     *      'GAMMAS ','POSITRONS','ELECTRONS','MU+  ','MU-  ',
     *      (J*THSTEP,(AELONG(J,K),SELONG(J,K),K=1,5),J=LPCT0,NSTEP)
 915      FORMAT(/' AVERAGE LONGITUDINAL ENERGY DISTRIBUTION [GEV] ',
     *      'IN STEPS OF ',F5.0,' G/CM**2 '/' ',131('=')/
     *      ' DEPTH',6X,A9,4(16X,A9),//
     *      (' ',F5.0,1X,1P,5(1X,E11.5,'+-',E11.5),0P))
          WRITE(MONIOU,916) THSTEP,
     *      'HADRONS','CHARGED','NUCLEI','ENERGYSUM',
     *      (J*THSTEP,(AELONG(J,K),SELONG(J,K),K=6,9),J=LPCT0,NSTEP)
 916      FORMAT(/' AVERAGE LONGITUDINAL ENERGY DISTRIBUTION [GEV] ',
     *      'IN STEPS OF ',F5.0,' G/CM**2 '/' ',110('=')/
     *      ' DEPTH',7X,3(A8,17X),2X,A10, // (' ',F5.0,1X,1P,
     *      3(1X,E11.5,'+-',E11.5),1X,E13.7,'+-',E13.7,0P))
C  PRINT AVERAGE LONGITUDINAL ENERGY DEPOSIT
          ADLONGSUM = 0.D0
          DO   K = 1,9
            DO   J = 0,NSTEP
              ADLONG(1170,K) = ADLONG(1170,K) + ADLONG(J,K)
            ENDDO
            IF ( K .NE. 9 ) ADLONGSUM = ADLONGSUM + ADLONG(1170,K)
          ENDDO
          WRITE(MONIOU,913) THSTEP,
     *      'GAMMA ', 'EM IONIZ','EM CUT','MU IONIZ','MU CUT',
     *      ((2*J-1)*.5*THSTEP,(ADLONG(J,K),SDLONG(J,K),K=1,5),
     *                                                 J=LPCT0+1,NSTEP)
 913      FORMAT(/' AVERAGE LONGITUDINAL ENERGY DEPOSIT [GEV] IN ',
     *      'STEPS OF ', F5.0,' G/CM**2 '/' ',132('=')/
     *      ' DEPTH',6X,A11,14X,2(A10,17X),A9,16X,A9 //
     *      (' ',F6.1,   F10.0,'+-',F10.0,1X,F13.0,'+-',F12.0,
     *      1X,F13.0,'+-',F12.0,1X,F10.0,'+-',F11.0,
     *      1X,F10.0,'+-',F11.0 ))
          WRITE(MONIOU,917) (ADLONG(1170,K),K=1,5)
 917      FORMAT(' ',20X,'AVERAGE LONGITUDINAL ENERGY SUM [GEV] '/
     *      ' ',4X,F13.1,13X,F13.1,14X,F14.1,12X,F13.1,11X,F13.1)
          WRITE(MONIOU,914) THSTEP,
     *      'HADR IONIZ','HADR CUT','NEUTRINO','    SUM',
     *      ((2*J-1)*.5*THSTEP,(ADLONG(J,K),SDLONG(J,K),K=6,9),
     *                                                 J=LPCT0+1,NSTEP)
 914      FORMAT(/' AVERAGE LONGITUDINAL ENERGY DEPOSIT [GEV] IN ',
     *      'STEPS OF ',F5.0,' G/CM**2 '/' ',112('=')/
     *      ' DEPTH',7X,A10,16X,A10,16X,A10,15X,A9 //
     *      (' ',F6.1,   F11.1,'+-',F11.1,1X,F13.0,'+-',F13.0,
     *      2X,F10.1,'+-',F10.1,1X,F13.1,'+-',F13.1))
          WRITE(MONIOU,918) (ADLONG(1170,K),K=6,8)
 918      FORMAT(' ',20X,'AVERAGE LONGITUDINAL ENERGY SUM [GEV] ',
     *      /,' ',4X,F13.1,14X,F14.1,14X,F12.1)
          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 730  J = 0,NSTEP-LPCT0
                DEP(J+1)    = (J+LPCT0)*THSTEP
                CHAPAR(J+1) = MAX( APLONG(J+LPCT0,7), 0.D0 )
 730          CONTINUE
              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 731  J = 1,IALT(1)
                DEP(J+1)    = TLEV(J)
                CHAPAR(J+1) = MAX( SEL(J)/ISHW, 0.D0 )
 731          CONTINUE
              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 732  J = 0,NSTEP-LPCT0
                DEP(J+1)    = (J+LPCT0)*THSTEP
                CHAPAR(J+1) = MAX( APLONG(J+LPCT0,7), 0.D0 )
 732          CONTINUE
              NSTP = NSTEP + 1 - LPCT0
              WRITE(MONIOU,8229) 'AVERAGE 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.
              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
            ELSE
              WRITE(MONIOU,*) 'NO LONGI. FIT POSSIBLE, ',
     *                      ' NSTP = ',NSTP,'  TOO SMALL.'
            ENDIF
          ENDIF
        ENDIF

      ENDIF
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -


C  CONTROL PRINT OUTPUT OF CONSTANTS
      IF ( DEBUG ) THEN
        CALL STAEND
        WRITE(MDEBUG,*) 'AAMAIN: STAEND CALLED'
      ENDIF
c------changed ---add
CBC+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C     Modified by C. Bigongiari 2001 Jan 16 
C
Cc>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
C      call jcenddata(runh,rune)
Cc>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c------changed---add

      WRITE(MONIOU,*) ' '
      CALL PRTIME(TTIME)
      WRITE(MONIOU,101)
 101  FORMAT (/' ',10('='),' END OF RUN ',48('='))

C  CLOSE ALL OPEN UNITS
      IF ( MONIOU .NE. 6 ) CLOSE(MONIOU)
      IF ( MDEBUG .NE. 6 ) CLOSE(MDEBUG)
      CLOSE(MEXST)
      IF ( FPAROUT ) CLOSE(MPATAP)
      IF ( FTABOUT ) CLOSE(MTABOUT)
      IF ( FLONGOUT  .AND.  LLONGI ) CLOSE(MLONGOUT)
      IF ( LCERFI ) CLOSE(MCETAP)

      STOP
      END
*CMZ :          06/11/2000  10.53.24  by  D. HECK IK3 FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
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
*KEEP,CONSTA.
      COMMON /CONSTA/  PI,PI2,OB3,TB3,ENEPER
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEND.

      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**2)
      SINT  = SQRT(1.D0-COST **2)
      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(ZZZ, 1.D0)
      IF ( YYY .EQ. 0.D0  .AND.  XXX .EQ. 0.D0 ) THEN
        PHI1 = 0.D0
      ELSE
        PHI1 = ATAN2( YYY, XXX )
      ENDIF

      RETURN
      END
*CMZ :          18/10/2000  09.15.11  by  D. HECK IK3 FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
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
*KEEP,CONSTA.
      COMMON /CONSTA/  PI,PI2,OB3,TB3,ENEPER
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEND.

      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**2)
      CP  = COS(PHI0)
      SP  = SIN(PHI0)
      CT1 = COST1
      ST1 = SQRT(1.D0-CT1**2)
      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
*CMZ :          28/02/2002  13.08.19  by  D. HECK IK FZK KARLSRUHE
*-- Author :    The CORSIKA development group   16/05/95
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  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 FUNKTION (GIVING DERIVATIVES)
C   ITER   =  ITERATION COUNTER
C   IFLAG  =  ERROR FLAG
C
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEND.

      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  USES AMOTRY,FUNK
C-----------------------------------------------------------------------

      IF ( DEBUG ) WRITE(MDEBUG,*) 'AMOEBA:'

      IFLAG = 0
      ITER  = 0
 1    DO 12  N = 1,NDIM
        SUM = 0.D0
        DO 11  M = 1,NDIM+1
          SUM = SUM + P(M,N)
 11     CONTINUE
        PSUM(N) = SUM
 12   CONTINUE
 2    ILO = 1
      IF ( Y(1) .GT. Y(2) ) THEN
        IHI  = 1
        INHI = 2
      ELSE
        IHI  = 2
        INHI = 1
      ENDIF
      DO 13  I = 1,NDIM+1
        IF ( Y(I) .LE. Y(ILO) ) ILO = I
        IF     ( Y(I) .GT. Y(IHI)  ) THEN
          INHI = IHI
          IHI  = I
        ELSEIF ( Y(I) .GT. Y(INHI) ) THEN
          IF ( I .NE. IHI ) INHI = I
        ENDIF
 13   CONTINUE
      RTOL = 2.D0*ABS(Y(IHI)-Y(ILO))/(ABS(Y(IHI))+ABS(Y(ILO)))
      IF ( RTOL .LT. FTOL ) THEN
        SWAP   = Y(1)
        Y(1)   = Y(ILO)
        Y(ILO) = SWAP
        DO 14  N = 1,NDIM
          SWAP     = P(1,N)
          P(1,N)   = P(ILO,N)
          P(ILO,N) = SWAP
 14     CONTINUE
        RETURN
      ENDIF
      IF ( ITER .GE.ITMAX ) THEN
        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.0D0)
      IF     ( YTRY .LE. Y(ILO)  ) THEN
        YTRY = AMOTRY(P,Y,PSUM,MP,NP,NDIM,FUNK,IHI,2.0D0)
      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 16  I = 1,NDIM+1
            IF ( I .NE. ILO ) THEN
              DO 15  J = 1,NDIM
                PSUM(J) = 0.5D0 * (P(I,J) + P(ILO,J))
                P(I,J)  = PSUM(J)
 15           CONTINUE
              Y(I) = FUNK(PSUM)
            ENDIF
 16       CONTINUE
          ITER = ITER + NDIM
          GOTO 1
        ENDIF
      ELSE
        ITER = ITER - 1
      ENDIF
      GOTO 2
      END
C=======================================================================

      DOUBLE PRECISION FUNCTION AMOTRY(P,Y,PSUM,MP,NP,NDIM,FUNK,IHI,FAC)

C-----------------------------------------------------------------------
C
C  REFERENCE : NUMERICAL RECIPES, W.H. PRESS ET AL.,
C              CAMBRIDGE UNIVERSITY PRESS, 1992  ISBN 0 521 43064 X
C  ADAPTED FOR DOUBLE PRECISION
C  USES EXTERNAL FUNCTION FUNK
C  THIS FUNCTION IS CALLED FROM AMOEBA.
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEND.

      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 11  J = 1,NDIM
        PTRY(J) = PSUM(J) * FAC1 - P(IHI,J) * FAC2
 11   CONTINUE
      YTRY = FUNK(PTRY)
      IF ( YTRY .LT. Y(IHI) ) THEN
        Y(IHI) = YTRY
        DO 12  J = 1,NDIM
          PSUM(J)  = PSUM(J) - P(IHI,J) + PTRY(J)
          P(IHI,J) = PTRY(J)
 12     CONTINUE
      ENDIF
      AMOTRY = YTRY
      RETURN
      END
*CMZ :          05/03/2002  08.29.24  by  D. HECK IK FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
C=======================================================================

      BLOCK DATA BLOCK1

C-----------------------------------------------------------------------
C
C  INITIALIZES DATA
C  THIS ROUTINE IS CALLED FROM AAMAIN.
C-----------------------------------------------------------------------

*KEEP,AIR.
      COMMON /AIR/     COMPOS,PROBTA,AVERAW,AVOGAD
      DOUBLE PRECISION COMPOS(3),PROBTA(3),AVERAW,AVOGAD
*KEEP,ATMOS.
      COMMON /ATMOS/   AATM,AATM0,BATM,BATM0,CATM,CATM0,DATM,MODATM
      DOUBLE PRECISION AATM(5),AATM0(5,0:16),BATM(5),BATM0(5,0:16),
     *                 CATM(5),CATM0(5,0:16),DATM(5)
      INTEGER          MODATM
*KEEP,ATMOS2.
      COMMON /ATMOS2/  HLAY,HLAY0,THICKL,LAYNO,LAYNEW
      DOUBLE PRECISION HLAY(6),HLAY0(5,0:4),THICKL(5)
      INTEGER          LAYNO(0:16)
      LOGICAL          LAYNEW
*KEEP,BUFFS.
      COMMON /BUFFS/   RUNH,RUNE,EVTH,EVTE,DATAB,ARRAYLONG,LH
      INTEGER          MAXBUF,MAXLEN
      PARAMETER        (MAXLEN=16)
      PARAMETER        (MAXBUF=39*7)
      REAL             RUNH(MAXBUF),EVTH(MAXBUF),EVTE(MAXBUF),
     *                 RUNE(MAXBUF),DATAB(MAXBUF),ARRAYLONG(MAXBUF)
      INTEGER          LH
      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)
*KEEP,CONSTA.
      COMMON /CONSTA/  PI,PI2,OB3,TB3,ENEPER
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER
*KEEP,EDECAY.
      COMMON /EDECAY/  CETA
      DOUBLE PRECISION CETA(5)
*KEEP,GNUPR.
      COMMON /GNUPR/   SE14,SE16,SE40
      DOUBLE PRECISION SE14(3,14),SE16(3,16),SE40(3,40)
*KEEP,KAONS.
      COMMON /KAONS/   CKA
      DOUBLE PRECISION CKA(80)
*KEEP,MUPART.
      COMMON /MUPART/  AMUPAR,BCUT,CMUON,FMUBRM,FMUORG
      DOUBLE PRECISION AMUPAR(16),BCUT,CMUON(11)
      LOGICAL          FMUBRM,FMUORG
*KEEP,NKGI.
      COMMON /NKGI/    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)
*KEEP,PAM.
      COMMON /PAM/     PAMA,SIGNUM,RESTMS
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000)
*KEEP,PARPAR.
      COMMON /PARPAR/  CURPAR,SECPAR,PRMPAR,OUTPAR,C,
     *                 E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
      DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16),
     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH
      INTEGER          ITYPE,LEVL
*KEEP,PARPAE.
      DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM
     *                 ,WEIGHT
     *                 ,HAPP,COSTAP,COSTEA
      EQUIVALENCE      (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE),
     *                 (CURPAR(4), PHI   ), (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)
*KEEP,REST.
      COMMON /REST/    CONTNE,TAR,LT
      DOUBLE PRECISION CONTNE(3),TAR
      INTEGER          LT
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEEP,STACKF.
      COMMON /STACKF/  STACK,MSTACKP,MEXST,NSHIFT,NOUREC,ICOUNT,
     *                 NTO,NFROM
      INTEGER          MAXSTK
      PARAMETER        (MAXSTK = 16*256*2)
      DOUBLE PRECISION STACK(MAXSTK)
      INTEGER          MSTACKP,MEXST,NSHIFT,NOUREC,ICOUNT,NTO,NFROM
*KEEP,STRBAR.
      COMMON /STRBAR/  CSTRBA
      DOUBLE PRECISION CSTRBA(11)
*KEEP,VERS.
      COMMON /VERS/    VERNUM,MVDATE,VERDAT
      DOUBLE PRECISION VERNUM
      INTEGER          MVDATE
      CHARACTER*18     VERDAT
*KEEP,CEREN3.
      COMMON /CEREN3/  CERCNT,DATAB2,NRECER,LHCER
      INTEGER          MAXBF2
      PARAMETER        ( MAXBF2 = 39 * 7 )
      DOUBLE PRECISION CERCNT
      REAL             DATAB2(MAXBF2)
      INTEGER          NRECER,LHCER
*KEND.

C-----------------------------------------------------------------------
C  AIR
      DATA COMPOS / 0.78479D0, 0.21052D0, 0.00469D0 /
      DATA PROBTA / 0.78479D0, 0.99531D0, 1.00000D0 /
      DATA AVERAW / 14.543D0 /
C  VALUE OF AVOGADRO REVISED SEPT. 2000 BY D.H.
      DATA AVOGAD / 6.02214199D-4 /

C  ATMOS (U.S.STANDARD IS DEFAULT)
      DATA AATM / -186.5562D0,  -94.919D0,  0.61289D0,0.D0,.01128292D0 /
      DATA BATM / 1222.6562D0,1144.9069D0,1305.5948D0,540.1778D0,1.D0  /
      DATA CATM / 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.00000D0   , .4210330D-2 ,
     *  - 59.0293D0,  -21.5794D0,-7.14839D0, 0.00000D0   , .1901750D-3 /
      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 ((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 (LAYNO(J), J=0,16)
     * /  0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, 2, 3   /
      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,3)
     * /     -5779.5D2 ,   4.D5  ,      1.D6  ,     4.D6,   1.D7     ,
     *       -5779.5D2 ,   4.D5  ,      1.D6  ,     4.D6,   1.D7     ,
     *        0.D0  , 2.66667D5  , 5.33333D5  ,     8.D5,   1.D7     ,
     *        0.D0  , 6.66667D5  ,13.33333D0  ,    20.D5,   1.D7     /
C  CEREN3
      DATA CERCNT / 0.D0 /
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 /, LT / 1 /
C  KAON CONSTANTS
C  REVISED SEPT. 2000 BY D. HECK
      DATA CKA /     0.0D0,  0.1D0, 1.2386D-8, 1.2386D-8, 0.8935D-10,
     *             5.17D-8, 0.25D0,     0.5D0,    0.75D0,      1.0D0,
     *               0.5D0,  0.2D0,     0.0D0,     0.0D0,    149.6D0,
     *             149.6D0,0.236D0,   0.206D0,   0.135D0,    0.222D0,
     *               0.5D0,  0.0D0,   0.635D0,   0.686D0,   0.8734D0,
     *             0.6598D0,.3884D0,    0.0D0,     0.0D0,      0.0D0,
     *               0.0D0,  0.0D0,     0.0D0,     0.0D0,      1.0D0,
     *               1.0D5,  0.0D0,     0.0D0,     0.0D0,      0.0D0,
     *               0.0D0,  0.0D0,     0.0D0,     0.0D0,      0.0D0,
     *               0.0D0,0.8468D0, 0.9027D0,  0.9509D0,   0.9827D0,
     *           -0.2154D0, 0.012D0,-0.0101D0,    1.27D0,    0.652D0,
     *             0.057D0,   0.0D0,   1.84D0,     0.0D0,      1.0D0,
     *             0.678D0, 0.076D0, 0.0099D0,    2.22D0,   0.0288D0,
     *               0.0D0,1.288D-2,  0.031D0,   0.006D0,   1.194D-2,
     *            0.0288D0,   0.0D0, 1.310D-2,   0.034D0,    0.025D0,
     *            1.241D-2,   0.0D0,    0.0D0,     0.0D0,      0.0D0  /
C  DATA FOR ETA DECAY
      DATA CETA /  0.3960D0,  0.7206D0,  0.9522D0,  -1.07D0,  2.07D0 /
C  DATA FOR STRANGE BARYON DECAY
      DATA CSTRBA / 2.632D-10,0.8018D-10, 7.4D-20, 1.479D-10,0.6409D0,
     *              0.5163D0, 2.90D-10, 1.639D-10, 0.821D-10, 0.678D0,
     *              0.914D0 /
C  PARPAR
      DATA C /6371315.D2,  6.0D5,     20.0D5,      0.0D0,        0.0D0,
     *           0.0D0,    0.0D0,      0.0D0,      2.5D0,       2.07D0,
     *           8.2D0,    0.1D0,      0.0D0,      0.0D0,        0.0D0,
     *          88.0D0,   110.D0,     2.6033D-8,   2.19703D-6,   0.0D0,
     *          37.7D0, 1.532873D-4, 9.386417D0,   2.D-3, 29.9792458D9,
     *           1.0D0,    0.0D0,     1.57D0,      0.0D0,      0.021D0,
     *          88.0D0,  110.0D0,      0.0D0,      2.0D1,        0.0D0,
     *           0.0D0,    0.0D0,      0.0D0,      0.0D0,        0.0D0,
     *           0.0D0,    0.0D0,      0.0D0,      0.0D0,        0.0D0,
     *           0.0D0,    0.0D0,      0.0D0,      0.0D0,137.0359998D0 /
C  RUNPAR,STACKF
      DATA MONIIN /  5 /, MONIOU /  6 /, MPATAP / 90 /, MEXST / 96 /,
     *     MDEBUG /  6 /, NUCNUC / 11 /, MDBASE / 45 /, MTABOUT / 46 /,
     *     MLONGOUT / 48 /
     *    ,MCETAP / 91 /
C  UNRELEASABLE ENERGY (REST MASS) FOR THINNING
      DATA RESTMS/       0., -.511D-3,  .511D-3,      0., .105658 ,
     *             .105658 ,       0.,       0.,      0.,       0.,
     *                   0.,       0., .939566 , .93827 ,      0. ,
     *                   0.,       0.,    .939 ,   .939 ,    .939 ,
     *                .939 ,    .939 ,    .939 ,   .939 ,      0. ,
     *                  0. ,      0. ,      0. ,     0. ,      0. ,
     *                  0. ,      0. ,       0.,      0.,       0.,
     *                   0.,       0.,       0.,      0.,       0.,
     *                   0.,       0.,       0.,      0.,       0.,
     *                   0.,       0.,       0.,      0.,       0.,
     *                   0.,       0.,       0.,   .939 ,    .939 ,
     *                .939 ,    .939 ,      0. ,     0. ,      0. ,
     *                  0. ,       0.,       0.,      0.,       0.,
     *                   0.,       0.,       0.,      0.,       0.,
     *                   0.,       0.,       0.,      0.,       0.,
     *       5925*0.D0/
C  GNUPR   (NEW VERSION OCT 1991)
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 / 6.014 /
      DATA MVDATE / 20020305 /
C                  -YYYYMMDD-
      DATA VERDAT / 'MARCH     05, 2002' /
C                    ----+----+----+---
      END
*CMZ :          28/02/2002  13.08.19  by  D. HECK IK FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
C=======================================================================

      SUBROUTINE BOX2

C-----------------------------------------------------------------------
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
*KEEP,AIR.
      COMMON /AIR/     COMPOS,PROBTA,AVERAW,AVOGAD
      DOUBLE PRECISION COMPOS(3),PROBTA(3),AVERAW,AVOGAD
*KEEP,ATMOS2.
      COMMON /ATMOS2/  HLAY,HLAY0,THICKL,LAYNO,LAYNEW
      DOUBLE PRECISION HLAY(6),HLAY0(5,0:4),THICKL(5)
      INTEGER          LAYNO(0:16)
      LOGICAL          LAYNEW
*KEEP,CHISTA.
      COMMON /CHISTA/  IHYCHI,IKACHI,IMUCHI,INNCHI,INUCHI,IPICHI
      INTEGER          IHYCHI(124),IKACHI(124),IMUCHI(124),
     *                 INNCHI(124),INUCHI(124),IPICHI(124)
*KEEP,CONSTA.
      COMMON /CONSTA/  PI,PI2,OB3,TB3,ENEPER
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER
*KEEP,KAONS.
      COMMON /KAONS/   CKA
      DOUBLE PRECISION CKA(80)
*KEEP,MUPART.
      COMMON /MUPART/  AMUPAR,BCUT,CMUON,FMUBRM,FMUORG
      DOUBLE PRECISION AMUPAR(16),BCUT,CMUON(11)
      LOGICAL          FMUBRM,FMUORG
*KEEP,NCSNCS.
      COMMON /NCSNCS/  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)
*KEEP,OBSPAR.
      COMMON /OBSPAR/  OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP,
     *                 THETPR,PHIPR,
     *                 VUECON,
     *                 NOBSLV
      DOUBLE PRECISION OBSLEV(10),THCKOB(10),XOFF(10),YOFF(10),
     *                 HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2)
      DOUBLE PRECISION VUECON(2)
      INTEGER          NOBSLV
*KEEP,PAM.
      COMMON /PAM/     PAMA,SIGNUM,RESTMS
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000)
*KEEP,PARPAR.
      COMMON /PARPAR/  CURPAR,SECPAR,PRMPAR,OUTPAR,C,
     *                 E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
      DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16),
     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH
      INTEGER          ITYPE,LEVL
*KEEP,PARPAE.
      DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM
     *                 ,WEIGHT
     *                 ,HAPP,COSTAP,COSTEA
      EQUIVALENCE      (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE),
     *                 (CURPAR(4), PHI   ), (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)
*KEEP,RANDPA.
      COMMON /RANDPA/  FAC,U1,U2,RD,NSEQ,ISEED,KNOR
      DOUBLE PRECISION FAC,U1,U2
      REAL             RD(3000)
      INTEGER          ISEED(103,10),NSEQ
      LOGICAL          KNOR
*KEEP,REST.
      COMMON /REST/    CONTNE,TAR,LT
      DOUBLE PRECISION CONTNE(3),TAR
      INTEGER          LT
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEEP,SIGM.
      COMMON /SIGM/    SIGMA,SIGANN,SIGAIR,FRACTN,FRCTNO
      DOUBLE PRECISION SIGMA,SIGANN,SIGAIR,FRACTN,FRCTNO
*KEEP,STRBAR.
      COMMON /STRBAR/  CSTRBA
      DOUBLE PRECISION CSTRBA(11)
*KEEP,VENUS.
      COMMON /VENUS/   ISH00,IVERVN,MTAR99,FVENUS,FVENSG
      INTEGER          ISH00,IVERVN,MTAR99
      LOGICAL          FVENUS,FVENSG
*KEND.

      DOUBLE PRECISION CHIBRM,CHIPRM,CHIINT,CHI1,CHI2,CKA2,COR1,DH,
     *                 EKIN,ELAB,ELABLG,ELABT,FRAPTN,FRPTNO,
     *                 HEIGH,PLAB,PLABLG,SIGBRM,SIGPRM,
     *                 SIG45,S45SQ,S4530,THICK
      REAL             GBRSGM,GPRSGM
      INTEGER          I,IA,IHY,IP,KA,MU,NI,NU
      DOUBLE PRECISION HNEW
      SAVE
      DOUBLE PRECISION CGHSIG
      EXTERNAL         CGHSIG
      EXTERNAL         HEIGH,THICK,GBRSGM,GPRSGM
C-----------------------------------------------------------------------

      IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=1,9)
  444 FORMAT(' BOX2  : CURPAR=',1P,9E10.3)
      ITYPE = CURPAR(1)

C  PHOTONS AND ELECTRONS ETA ARE TREATED SEPARATELY (SEE BOX3)
      IF ( ITYPE .LE. 3 ) THEN
        CHI = 0.D0
        RETURN
      ENDIF

C-----------------------------------------------------------------------
C  RESONANCES ARE TREATED SEPARATELY (SEE BOX3)
      IF ( ITYPE .GE. 50  .AND.  ITYPE .LE. 65 ) THEN
        CHI = 0.D0
        RETURN
      ENDIF

      BETA = SQRT( GAMMA**2 - 1.D0 ) / GAMMA
      THICKH = THICK(H)
      ELAB   = PAMA(ITYPE) * GAMMA

C-----------------------------------------------------------------------
C  MU + , MU - DECAYS AFTER ITS LIFE TIME
C  MUON INTERACTS BY BREMSSTRAHLUNG OR PAIR PRODUCTION
      IF     ( ITYPE .EQ. 5  .OR.  ITYPE .EQ. 6 ) THEN
        CALL RMMAR( RD,3,1 )
        COR1 = (-LOG(RD(1))) * C(25) * C(19)
        CALL PRANGC(COR1,.TRUE.,HNEW)
        DH   = MAX( H - HNEW, 0.D0 )
        IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2  : ITYPE,RD(1),CHIDEC=',
     *                                      ITYPE,RD(1),SNGL(CHI)
        IF ( GAMMA .LE. 200.D0 ) THEN
          FDECAY = .TRUE.

        ELSE
C  AT HIGHER ENERGIES CHECK FOR MUON BREMSSTRAHLUNG AND PAIR PRODUCTION
          ELABLG = LOG(ELAB)
C  CALCULATE MUON BREMSSTRAHLUNG CROSS-SECTION FOR AIR
          IF ( ELAB .LE. 1.D5 ) THEN
            FRACTN =          COMPOS(1)*GBRSGM( 7.,SNGL(ELAB))
            FRCTNO = FRACTN + COMPOS(2)*GBRSGM( 8.,SNGL(ELAB))
            SIGBRM = FRCTNO + COMPOS(3)*GBRSGM(18.,SNGL(ELAB))
          ELSE
C  PRELIMINARY PARAMETRIZED FOR ULTRAHIGH ENERGIES (JAN 2000)
            SIGBRM = EXP( ELABLG*0.046816D0 - 7.80342D0 )
            FRACTN = SIGBRM * 0.78D0
            FRCTNO = SIGBRM * 0.99D0
          ENDIF
          IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2  : SIGBRM=',SNGL(SIGBRM)
C  CALCULATE
          CHIBRM = (-LOG(RD(2))) * AVERAW / (AVOGAD * SIGBRM)
          IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2  : ITYPE,RD(2),CHIBRM=',
     *                                     ITYPE,RD(2),SNGL(CHIBRM)
          CHI1   = MIN( CHIBRM, CHI )

          IF ( ELAB .LE. 1.D5 ) THEN
C  CALCULATE  MUON PAIR PRODUCTION CROSS-SECTION FOR AIR
            FRAPTN =          COMPOS(1)*GPRSGM( 7.,SNGL(ELAB))
            FRPTNO = FRAPTN + COMPOS(2)*GPRSGM( 8.,SNGL(ELAB))
            SIGPRM = FRPTNO + COMPOS(3)*GPRSGM(18.,SNGL(ELAB))
          ELSE
C  PRELIMINARY PARAMETRIZED FOR ULTRAHIGH ENERGIES (JAN 2000)
            SIGPRM = EXP( ELABLG*0.136048D0 - 3.70468D0 )
            FRAPTN = SIGPRM * 0.78D0
            FRPTNO = SIGPRM * 0.99D0
          ENDIF
          IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2  : SIGPRM=',SNGL(SIGPRM)
C  CALCULATE MEAN FREE PATH FOR PAIR PRODUCTION
          CHIPRM = (-LOG(RD(3))) * AVERAW / (AVOGAD * SIGPRM)
          IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2  : ITYPE,RD(3),CHIPRM=',
     *                                     ITYPE,RD(3),SNGL(CHIPRM)
          CHI2   = MIN( CHIPRM, CHI1 )
          IF     ( CHI2 .EQ. CHI    ) THEN
            FDECAY = .TRUE.
          ELSEIF ( CHI2 .EQ. CHIBRM ) THEN
            FDECAY = .FALSE.
            FMUBRM = .TRUE.
C  TARGET IS CHOSEN AT RANDOM FOR MUON BREMSSTRAHLUNG
            CALL RMMAR( RD,1,1 )
            IF     ( RD(1)*SIGBRM .LE. FRACTN ) THEN
C  BREMSSTRAHLUNG WITH NITROGEN
              LT  = 1
              TAR = 14.D0
            ELSEIF ( RD(1)*SIGBRM .LE. FRCTNO ) THEN
C  BREMSSTRAHLUNG WITH OXYGEN
              LT  = 2
              TAR = 16.D0
            ELSE
C  BREMSSTRAHLUNG WITH ARGON
              LT  = 3
              TAR = 40.D0
            ENDIF
          ELSEIF ( CHI2 .EQ. CHIPRM ) THEN
            FDECAY = .FALSE.
            FMUBRM = .FALSE.
C  TARGET IS CHOSEN AT RANDOM FOR MUON PAIR PRODUCTION
            CALL RMMAR( RD,1,1 )
            IF     ( RD(1)*SIGPRM .LE. FRAPTN ) THEN
C  PAIR PRODUCTION WITH NITROGEN
              LT  = 1
              TAR = 14.D0
            ELSEIF ( RD(1)*SIGPRM .LE. FRPTNO ) THEN
C  PAIR PRODUCTION WITH OXYGEN
              LT  = 2
              TAR = 16.D0
            ELSE
C  PAIR PRODUCTION WITH ARGON
              LT  = 3
              TAR = 40.D0
            ENDIF
          ENDIF
          CHI = CHI2
        ENDIF

C  DECAY LENGTH STATISTICS
        MU = 1.D0 + DH * 1.D-4 / COSTHE
        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 GHEISHA ROUTINES
        IF ( ELAB .LE. HILOELB ) THEN
          EKIN   = ELAB - PAMA(ITYPE)
          USELOW = .TRUE.
          SIGAIR = CGHSIG(SNGL(PLAB),SNGL(EKIN),ITYPE)
          GHESIG = .TRUE.
        ELSE
          USELOW = .FALSE.
          GHESIG = .FALSE.
          IF ( FVENSG  .AND.  (ELAB .GE. HILOELB) ) THEN
            CALL VENSIG(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 RMMAR( RD,2,1 )
C  MEAN FREE PATH FOR INTERACTION (CHIINT)  OR DECAY (CHI)
        CHIINT = (-LOG(RD(1))) * AVERAW / (AVOGAD * SIGAIR)
        IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2  : ITYPE,RD(1),CHIINT=',
     *                                   ITYPE,RD(1),SNGL(CHIINT)
        COR1   = (-LOG(RD(2))) * C(25) * C(18)
        CALL PRANGC(COR1,.FALSE.,HNEW)
        CHI    = MAX( CHI, 0.D0 )
        IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2  : ITYPE,RD(2),CHIDEC=',
     *                                        ITYPE,RD(2),SNGL(CHI)
        CHI    = MIN( CHIINT, CHI )
        IF ( CHI .LT. CHIINT ) THEN
          FDECAY = .TRUE.
        ELSE
          FDECAY = .FALSE.
        ENDIF

C  INTERACTION LENGTH STATISTICS
        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
        IF ( ELAB .LT. 1.D5 ) THEN
          FDECAY = .TRUE.
          CHI    = 0.D0
          IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2  : ITYPE,CHI,FDECAY=',
     *                                    ITYPE,SNGL(CHI),FDECAY
        ELSE
C  PION IS HIGH ENERGY AND MUST BE TRACKED
          PLAB   = ELAB * BETA
          GHESIG = .FALSE.
          IF ( FVENSG ) THEN
            CALL VENSIG(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 RMMAR( RD,2,1 )
C  MEAN FREE PATH FOR INTERACTION (CHIINT)  OR DECAY (CHI)
          CHIINT = (-LOG(RD(1))) * AVERAW / (AVOGAD * SIGAIR)
          IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2  : ITYPE,RD(1),CHIINT=',
     *                                     ITYPE,RD(1),SNGL(CHIINT)
          COR1   = (-LOG(RD(2))) * C(25) * 8.4D-17
          CALL NRANGC(COR1*BETA*GAMMA)
          IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2  : ITYPE,RD(2),CHIDEC=',
     *                                          ITYPE,RD(2),SNGL(CHI)
          CHI    = MIN( CHIINT, CHI )
          IF ( CHI .LT. CHIINT ) THEN
            FDECAY = .TRUE.
          ELSE
            FDECAY = .FALSE.
          ENDIF
        ENDIF

C  INTERACTION LENGTH STATISTICS
        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 GHEISHA ROUTINES
        IF ( ELAB .LE. HILOELB ) THEN
          EKIN   = ELAB - PAMA(ITYPE)
          USELOW = .TRUE.
          SIGAIR = CGHSIG(SNGL(PLAB),SNGL(EKIN),ITYPE)
          GHESIG = .TRUE.
        ELSE
          USELOW = .FALSE.
          GHESIG = .FALSE.
          IF ( FVENSG  .AND.  (ELAB .GE. HILOELB) ) THEN
            CALL VENSIG(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 RMMAR( RD,1,1 )
        CHI    = (-LOG(RD(1))) * AVERAW / (AVOGAD * SIGAIR)
        FDECAY = .FALSE.
        IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2  : ITYPE,RD(1),CHI=',
     *                                        ITYPE,RD(1),SNGL(CHI)

C  INTERACTION LENGTH STATISTICS
        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 GHEISHA ROUTINES
        IF ( ELAB .LE. HILOELB ) THEN
          EKIN   = ELAB - PAMA(ITYPE)
          USELOW = .TRUE.
          SIGAIR = CGHSIG(SNGL(PLAB),SNGL(EKIN),ITYPE)
          GHESIG = .TRUE.
        ELSE
          USELOW = .FALSE.
          GHESIG = .FALSE.
          IF ( FVENSG  .AND.  (ELAB .GE. HILOELB) ) THEN
            CALL VENSIG(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 RMMAR( RD,2,1 )
C  MEAN FREE PATH FOR INTERACTION (CHIINT)  OR DECAY (CHI)
        CHIINT = (-LOG(RD(1))) * AVERAW / (AVOGAD * SIGAIR)
        IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2  : ITYPE,RD(1),CHIINT=',
     *                                        ITYPE,RD(1),SNGL(CHIINT)

        IF     ( ITYPE .EQ. 16 ) THEN
          CKA2 = CKA(5)
        ELSEIF ( ITYPE .EQ. 10 ) THEN
          CKA2 = CKA(6)
        ELSE
          CKA2 = CKA(3)
        ENDIF
        COR1   = (-LOG(RD(2))) * C(25) * CKA2
        IF ( SIGNUM(ITYPE) .EQ. 0.D0 ) THEN
C  NEUTRAL KAONS
          CALL NRANGC(COR1*BETA*GAMMA)
        ELSE
C  CHARGED KAONS
          CALL PRANGC(COR1,.FALSE.,HNEW)
          CHI  = MAX( CHI, 0.D0 )
        ENDIF

        IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2  : ITYPE,RD(2),CHIDEC=',
     *                                        ITYPE,RD(2),SNGL(CHI)
        CHI    = MIN( CHIINT, CHI )
        IF ( CHI .LT. CHIINT ) THEN
          FDECAY = .TRUE.
        ELSE
          FDECAY = .FALSE.
        ENDIF

C  INTERACTION LENGTH STATISTICS
        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
          PLAB   = ELAB * BETA
          GHESIG = .FALSE.
          IF ( FVENSG ) THEN
            CALL VENSIG(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 RMMAR( RD,2,1 )
C  MEAN FREE PATH FOR INTERACTION (CHIINT)  OR DECAY (CHI)
          CHIINT = (-LOG(RD(1))) * AVERAW / (AVOGAD * SIGAIR)
          IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2  : ITYPE,RD(1),CHIINT=',
     *                                     ITYPE,RD(1),SNGL(CHIINT)
          COR1   = (-LOG(RD(2))) * C(25) * 5.531D-19
          CALL NRANGC(COR1*BETA*GAMMA)
          IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2  : ITYPE,RD(2),CHIDEC=',
     *                                          ITYPE,RD(2),SNGL(CHI)
          CHI    = MIN( CHIINT, CHI )
          IF ( CHI .LT. CHIINT ) THEN
            FDECAY = .TRUE.
          ELSE
            FDECAY = .FALSE.
          ENDIF
        ENDIF

C  INTERACTION LENGTH STATISTICS
        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 GHEISHA ROUTINES
        IF ( ELAB .LE. HILOELB ) THEN
          EKIN   = ELAB - PAMA(ITYPE)
          USELOW = .TRUE.
          SIGAIR = CGHSIG(SNGL(PLAB),SNGL(EKIN),ITYPE)
C  SET CROSS-SECTION VALUE TO A SMALL NUMBER FOR SIGMA0 AND ANTI SIGMA0
          IF ( ITYPE .EQ. 20  .OR.  ITYPE .EQ. 28 ) THEN
            SIGAIR = 1.D-3
          ENDIF
          GHESIG = .TRUE.
        ELSE
          USELOW = .FALSE.
          GHESIG = .FALSE.
C  CROSS-SECTION FOR BARYONS IS ASSUMED TO BE THE SAME AS FOR NUCLEONS
          IF ( FVENSG  .AND.  (ELAB .GE. HILOELB) ) THEN
            CALL VENSIG(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 RMMAR( RD,2,1 )
C  MEAN FREE PATH FOR INTERACTION (CHIINT)  OR DECAY (CHI)
        IF     ( ITYPE .GE. 18  .AND.  ITYPE .LE. 21 ) THEN
          COR1 = (-LOG(RD(2))) * C(25) * CSTRBA(ITYPE-17)
        ELSEIF ( ITYPE .GE. 22  .AND.  ITYPE .LE. 24 ) THEN
          COR1 = (-LOG(RD(2))) * C(25) * CSTRBA(ITYPE-15)
        ELSEIF ( ITYPE .GE. 26  .AND.  ITYPE .LE. 29 ) THEN
          COR1 = (-LOG(RD(2))) * C(25) * CSTRBA(ITYPE-25)
        ELSEIF ( ITYPE .GE. 30  .AND.  ITYPE .LE. 32 ) THEN
          COR1 = (-LOG(RD(2))) * C(25) * CSTRBA(ITYPE-23)
        ENDIF
        IF ( SIGNUM(ITYPE) .EQ. 0.D0 ) THEN
C  NEUTRAL STRANGE BARYONS
          CALL NRANGC(COR1*BETA*GAMMA)
        ELSE
C  CHARGED STRANGE BARYONS
          CALL PRANGC(COR1,.FALSE.,HNEW)
          CHI  = MAX( CHI, 0.D0 )
        ENDIF
        IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2  : ITYPE,RD(2),CHIDEC=',
     *                                        ITYPE,RD(2),SNGL(CHI)
        CHIINT = (-LOG(RD(1))) * AVERAW / (AVOGAD * SIGAIR)
        IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2  : ITYPE,RD(1),CHIINT=',
     *                                   ITYPE,RD(1),SNGL(CHIINT)
        CHI    = MIN( CHIINT, CHI )
          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
        IHY = 1.D0 + CHI * 0.1D0
        IHY = MIN( IHY, 123 )
        IHYCHI(IHY) = IHYCHI(IHY) + 1
        IHYCHI(124) = IHYCHI(124) + 1

C-----------------------------------------------------------------------
C  HEAVY PRIMARIES ( ITYPE = 100 * A + Z ,  FE -> ITYPE = 5626 )
C  ( APPEARING AT FIRST INTERACTION AND AS REMANENTS OF THE PRIMARY )
      ELSEIF ( ITYPE .GT. 100 ) THEN
        IA = ITYPE / 100
        IF ( IA .GT. 56 ) THEN
          WRITE(MONIOU,*) 'BOX2  : UNEXPECTED PARTICLE TYPE=',ITYPE
          WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE'
          WRITE(MONIOU,*) 'SEE KEYWORD: PRMPAR'
          STOP
        ENDIF
C  MEAN FREE PATH OF THE HEAVY PRIMARY IS DEDUCED FROM THAT OF A NUCLEON
C  ONLY INELASTIC SCATTERING AT INTERACTIONS WITH HEAVY PRIMARY/FRAGMENT
        ELAB = (PAMA(13) + PAMA(14)) * 0.5D0 * GAMMA
        PLAB = ELAB * BETA
C  CALCULATION OF CROSS-SECTION IN THE GHEISHA ROUTINES
        ELABT = ELAB * IA
        IF ( ELAB .LE. HILOELB ) THEN
          USELOW = .TRUE.
C  GHEISHA CANNOT TREAT NUCLEI
          GHESIG = .FALSE.
        ELSE
          USELOW = .FALSE.
          GHESIG = .FALSE.
        ENDIF
        IF ( FVENSG  .AND.  (ELAB .GE. HILOELB) ) THEN
          CALL VENSIG(ELAB,ITYPE)
        ELSE
          IF ( GHESIG ) 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,*) 'BOX2: SIGAIR=0.D0, PROGRAM STOPPED ',
     *       ' (UNALLOWED COMBINATION OF PRIMARY WITH CROSS-SECTION)'
          WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE'
          WRITE(MONIOU,*) 'SEE KEYWORD: PRMPAR'
          STOP
        ENDIF

        CALL RMMAR( RD,1,1 )
C  MEAN FREE PATH FROM MOLECULAR WEIGHT, AVOGADRO'S CONSTANT AND SIGMA
        CHI    = (-LOG(RD(1))) * AVERAW / (AVOGAD * SIGAIR)
        FDECAY = .FALSE.
        IF ( DEBUG ) WRITE(MDEBUG,*) 'BOX2  : ITYPE,RD(1),CHI=',
     *                                        ITYPE,RD(1),SNGL(CHI)

C  INTERACTION LENGTH STATISTICS
        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,*) 'BOX2  : UNEXPECTED PARTICLE TYPE=',ITYPE
        WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE'
        WRITE(MONIOU,*) 'SEE KEYWORD: PRMPAR'
        STOP
      ENDIF

      RETURN
      END
*CMZ :          05/03/2002  08.56.36  by  D. HECK IK FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
C=======================================================================

      SUBROUTINE BOX3(fmfb)

C-----------------------------------------------------------------------
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
*KEEP,GENER.
      COMMON /GENER/   GEN,ALEVEL
      DOUBLE PRECISION GEN,ALEVEL
*KEEP,IRET.
      COMMON /IRET/    IRET1,IRET2,IRETE
      INTEGER          IRET1,IRET2
      LOGICAL          IRETE
*KEEP,LONGI.
      COMMON /LONGI/   ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP,LLONGI,FLGFIT
      DOUBLE PRECISION ADLONG(0:1170,9),AELONG(0:1170,9),
     *                 APLONG(0:1170,9),DLONG(0:1170,9),ELONG(0:1170,9),
     *                 HLONG(0:1170),PLONG(0:1170,9),SDLONG(0:1170,9),
     *                 SELONG(0:1170,9),SPLONG(0:1170,9),THSTEP,THSTPI
      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT
*KEEP,OBSPAR.
      COMMON /OBSPAR/  OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP,
     *                 THETPR,PHIPR,
     *                 VUECON,
     *                 NOBSLV
      DOUBLE PRECISION OBSLEV(10),THCKOB(10),XOFF(10),YOFF(10),
     *                 HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2)
      DOUBLE PRECISION VUECON(2)
      INTEGER          NOBSLV
*KEEP,PAM.
      COMMON /PAM/     PAMA,SIGNUM,RESTMS
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000)
*KEEP,PARPAR.
      COMMON /PARPAR/  CURPAR,SECPAR,PRMPAR,OUTPAR,C,
     *                 E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
      DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16),
     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH
      INTEGER          ITYPE,LEVL
*KEEP,PARPAE.
      DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM
     *                 ,WEIGHT
     *                 ,HAPP,COSTAP,COSTEA
      EQUIVALENCE      (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE),
     *                 (CURPAR(4), PHI   ), (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)
*KEEP,RANDPA.
      COMMON /RANDPA/  FAC,U1,U2,RD,NSEQ,ISEED,KNOR
      DOUBLE PRECISION FAC,U1,U2
      REAL             RD(3000)
      INTEGER          ISEED(103,10),NSEQ
      LOGICAL          KNOR
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEEP,THNVAR.
      COMMON /THNVAR/  STACKINT,
     *                 INT_ICOUNT,MODETHN,THINNING
      INTEGER          MAXICOUNT
      PARAMETER        (MAXICOUNT=40000)
      DOUBLE PRECISION STACKINT(16,MAXICOUNT)
      INTEGER          INT_ICOUNT,MODETHN
      LOGICAL          THINNING
c-----changed--add
      logical fmfb
c-----changed--add
*KEND.

      DOUBLE PRECISION THICK
      INTEGER          I,IRET3
      SAVE
      LOGICAL          FLAG
      EXTERNAL         THICK
C-----------------------------------------------------------------------

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

      IF     ( ITYPE .EQ. 5  .OR.  ITYPE .EQ. 6 ) THEN
C  MUONS ARE TRACKED WITHIN SUBR. MUTRAC
        INT_ICOUNT = 0
        CALL MUTRAC(fmfb)
        CALL TSTEND
        IRET1 = 1
        RETURN

      ELSEIF ( ITYPE .LE. 3 ) THEN
C  ELECTRONS OR PHOTONS ARE TREATED IN SUBR. EM
        CALL EM
        IRET1 = 1
        RETURN

      ELSEIF ( ITYPE .GE. 50  .AND.  ITYPE .LE. 65 ) THEN
C  RESONANCES DECAY WITHIN SUBR. RESDEC
        IF (LLONGI) LHEIGH = INT(THICK(H)*THSTPI + 1.D0)
        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.
c-----changed--add
      CALL UPDATC(IRET3,FLAG,fmfb)
c-----changed--add
      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 = 1,8
            CURPAR(I) = OUTPAR(I)
          ENDDO
          ALEVEL = H
          BETA   = SQRT( GAMMA**2 - 1.D0 ) / GAMMA
        ENDIF

      ENDIF
      RETURN
      END
*CMZ :          23/10/2000  14.43.21  by  D. HECK IK3 FZK KARLSRUHE
*-- Author :    The CORSIKA development group   16/05/95
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  ARGUMETS:
C   F(1)  = HEIGHT AT MAXIMUM
C   F(2)  = SHOWER STARTING POINT
C   F(3)  = T AT MAXIMUM
C   F(4)  = WIDTH PARAMETER 1
C   F(5)  = WIDTH PARAMETER 2 T
C   F(6)  = WIDTH PARAMETER 3 T**2
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,CURVE.
      COMMON /CURVE/   CHAPAR,DEP,ERR,NSTP
      DOUBLE PRECISION CHAPAR(1200),DEP(1200),ERR(1200)
      INTEGER          NSTP
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEND.

      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
*CMZ :          23/10/2000  14.43.21  by  D. HECK IK3 FZK KARLSRUHE
*-- Author :    The CORSIKA development group   16/05/95
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  ARGUMETS:
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
*KEEP,CURVE.
      COMMON /CURVE/   CHAPAR,DEP,ERR,NSTP
      DOUBLE PRECISION CHAPAR(1200),DEP(1200),ERR(1200)
      INTEGER          NSTP
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEND.

      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
*CMZ :          18/10/2000  09.15.11  by  D. HECK IK3 FZK KARLSRUHE
*-- Author :     F. SCHROEDER UNI WUPPERTAL     18/11/98
C=======================================================================

      SUBROUTINE CORINC

C-----------------------------------------------------------------------
C  CO(O)R(DINATE) 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 SEA LEVEL.
C  THIS SUBROUTINE IS CALLED FROM AAMAIN.
C
C  AUTHOR  :  F. SCHROEDER UNI WUPPERTAL
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,OBSPAR.
      COMMON /OBSPAR/  OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP,
     *                 THETPR,PHIPR,
     *                 VUECON,
     *                 NOBSLV
      DOUBLE PRECISION OBSLEV(10),THCKOB(10),XOFF(10),YOFF(10),
     *                 HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2)
      DOUBLE PRECISION VUECON(2)
      INTEGER          NOBSLV
*KEEP,PARPAE.
      DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM
     *                 ,WEIGHT
     *                 ,HAPP,COSTAP,COSTEA
      EQUIVALENCE      (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE),
     *                 (CURPAR(4), PHI   ), (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)
*KEEP,PARPAR.
      COMMON /PARPAR/  CURPAR,SECPAR,PRMPAR,OUTPAR,C,
     *                 E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
      DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16),
     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH
      INTEGER          ITYPE,LEVL
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEND.

      DOUBLE PRECISION DIST,DIAG,TEA
      SAVE
C-----------------------------------------------------------------------

      IF ( DEBUG ) WRITE(MDEBUG,*) 'CORINC: 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  COSTAP IS SET IN AAMAIN BY EQUIVALENCE WITH CURPAR(15)

C  DISTANCE DIAG BETWEEN DETECTOR POSITION  X=Y=0, Z = OBSLEV(1) AND
C  STARTING POINT
      DIAG = SQRT( (C(1)+H)**2 - (C(1)+OBSLEV(1))**2 *(1.D0-COSTAP**2) )
     *                                    - (C(1)+OBSLEV(1)) * COSTAP

C  APPARENT HEIGHT HAPP IS PARTICLE Z-COORDINATE IN DETECTOR SYSTEM
      HAPP = OBSLEV(1) + DIAG * COSTAP

C  CALCULATING COSINE OF THETA_EARTH COSTEA, COSINE OF ZENITH ANGLE BY
C  TAKING A COORDINATE FRAME CENTERED IN THE MIDDLE OF EARTH
      COSTEA = (C(1)+HAPP) / (C(1)+H)
      IF ( DEBUG ) WRITE(MDEBUG,*) 'CORINC: HAPP,COSTEA,DIAG =',
     *                     SNGL(HAPP),COSTEA,SNGL(DIAG)
      COSTEA = MIN( 1.D0, COSTEA )
C  TRANSFORM THE APPARENT ANGLE SEEN FROM DETECTOR POSITION TO LOCAL
C  ANGLES RELATIVE TO THE VERTICAL TO THE MIDDLE OF EARTH
C  NOTE : LOCAL ZENITH ANGLE = DIFFERENCE OF APPARENT ZENITH ANGLE AND
C         THETA_EARTH
      COSTHE = (DIAG + (C(1)+OBSLEV(1))*COSTAP)/(C(1)+H)

C  DISTANCE DIST BETWEEN THE DETECTOR POSITION X=0, Y=0
C  AND THE ACTUAL INTERACTION POINT MEASURED ON THE EARTH'S SURFACE
      TEA  = ACOS(COSTEA)
      DIST = C(1) * TEA

C  CONCERNING TRANSFORMATION OF AZIMUTH ANGLE PHI
C  NOTE : THE COORDINATE SYTEMS ONLY DIFFER IN A SHIFT ALONG THE Z-AXIS
C         OR A ROTATION ALONG THE ZENITH ANGLE. BOTH TRANSFORMATIONS
C         JUST CHANGE THETA AND NOT PHI (THETA AND PHI ARE ORTHOGONAL
C         COORDINATES, THUS LINEAR INDEPENDENT).

C  X,Y-COORDINATES SEEN FROM THE DETECTOR POSITION (X=Y=0)
      X = -DIST * COS( PHIP )
      Y = -DIST * SIN( PHIP )
      IF ( DEBUG ) WRITE(MDEBUG,*) 'CORINC: X,Y,COSTHE,DIST =',
     *                    SNGL(X),SNGL(Y),SNGL(COSTHE),SNGL(DIST)

C   FILL PARAMETERS IN PRMPAR
      PRMPAR(3) = COSTHE
      PRMPAR(7) = X
      PRMPAR(8) = Y
C  WE HAVE EQUIVALENCES FOR HAPP AND COSTEA
C     CURPAR(14) = HAPP
C     CURPAR(16) = COSTEA

      RETURN
      END
*CMZ :          28/02/2002  13.08.19  by  D. HECK IK FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
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-----------------------------------------------------------------------
c------changed-------add and comand 
c      IMPLICIT NONE
c>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
c All this lines are under test
c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
      parameter (xct=1)
      parameter (yct=2)
      parameter (zct=3)
      parameter (ctthet=4)
      parameter (ctphi=5)
      parameter (ctdiam=6)
      parameter (ctfoc=7)
c>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
c------changed-------add and comand 

c      IMPLICIT NONE
*KEEP,ATMOS.
      COMMON /ATMOS/   AATM,AATM0,BATM,BATM0,CATM,CATM0,DATM,MODATM
      DOUBLE PRECISION AATM(5),AATM0(5,0:16),BATM(5),BATM0(5,0:16),
     *                 CATM(5),CATM0(5,0:16),DATM(5)
      INTEGER          MODATM
*KEEP,ATMOS2.
      COMMON /ATMOS2/  HLAY,HLAY0,THICKL,LAYNO,LAYNEW
      DOUBLE PRECISION HLAY(6),HLAY0(5,0:4),THICKL(5)
      INTEGER          LAYNO(0:16)
      LOGICAL          LAYNEW
*KEEP,CONSTA.
      COMMON /CONSTA/  PI,PI2,OB3,TB3,ENEPER
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER
*KEEP,DPMFLG.
      COMMON /DPMFLG/  NFLAIN,NFLDIF,NFLPI0,NFLCHE,NFLPIF,NFRAGM
      INTEGER          NFLAIN,NFLDIF,NFLPI0,NFLCHE,NFLPIF,NFRAGM
*KEEP,EGSDEB.
      COMMON /EGSDEB/  JCLOCK,NCLOCK,FEGSDB
      INTEGER          JCLOCK,NCLOCK
      LOGICAL          FEGSDB
*KEEP,ELABCT.
      COMMON /ELABCT/  ELCUT
      DOUBLE PRECISION ELCUT(4)
*KEEP,ETHMAP.
      COMMON /ETHMAP/  ECTMAP,ELEFT
      DOUBLE PRECISION ECTMAP,ELEFT
*KEEP,LONGI.
      COMMON /LONGI/   ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP,LLONGI,FLGFIT
      DOUBLE PRECISION ADLONG(0:1170,9),AELONG(0:1170,9),
     *                 APLONG(0:1170,9),DLONG(0:1170,9),ELONG(0:1170,9),
     *                 HLONG(0:1170),PLONG(0:1170,9),SDLONG(0:1170,9),
     *                 SELONG(0:1170,9),SPLONG(0:1170,9),THSTEP,THSTPI
      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT
*KEEP,MAGANG.
      COMMON /MAGANG/  ARRANG,ARRANR,COSANG,SINANG
      DOUBLE PRECISION ARRANG,ARRANR,COSANG,SINANG
*KEEP,MAGNET.
      COMMON /MAGNET/  BX,BZ,BVAL,BNORMC,BNORM,COSB,SINB,BLIMIT
      DOUBLE PRECISION BX,BZ,BVAL,BNORMC,BNORM,COSB,SINB,BLIMIT
*KEEP,MUMULT.
      COMMON /MUMULT/  CHC,OMC,PHISCT,STEPL,VSCAT,FMOLI
      DOUBLE PRECISION CHC,OMC,PHISCT,STEPL,VSCAT
      LOGICAL          FMOLI
*KEEP,NKGI.
      COMMON /NKGI/    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)
*KEEP,OBSPAR.
      COMMON /OBSPAR/  OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP,
     *                 THETPR,PHIPR,
     *                 VUECON,
     *                 NOBSLV
      DOUBLE PRECISION OBSLEV(10),THCKOB(10),XOFF(10),YOFF(10),
     *                 HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2)
      DOUBLE PRECISION VUECON(2)
      INTEGER          NOBSLV
*KEEP,PARPAR.
      COMMON /PARPAR/  CURPAR,SECPAR,PRMPAR,OUTPAR,C,
     *                 E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
      DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16),
     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH
      INTEGER          ITYPE,LEVL
*KEEP,PRIMSP.
      COMMON /PRIMSP/  PSLOPE,LLIMIT,ULIMIT,LL,UL,SLEX,ISPEC
      DOUBLE PRECISION PSLOPE,LLIMIT,ULIMIT,LL,UL,SLEX
      INTEGER          ISPEC
*KEEP,RANDPA.
      COMMON /RANDPA/  FAC,U1,U2,RD,NSEQ,ISEED,KNOR
      DOUBLE PRECISION FAC,U1,U2
      REAL             RD(3000)
      INTEGER          ISEED(103,10),NSEQ
      LOGICAL          KNOR
*KEEP,REJECT.
      COMMON /REJECT/  AVNREJ,ALTMIN,ANEXP,THICKA,THICKD,CUTLN,EONCUT,
     *                 FNPRIM
      DOUBLE PRECISION AVNREJ(10),ALTMIN(10),ANEXP(10),THICKA(10),
     *                 THICKD(10),CUTLN,EONCUT
      LOGICAL          FNPRIM
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEEP,VENPAR.
      COMMON /VENPAR/  PARVAL,NPARAM,PARCHA
      REAL             PARVAL(100)
      INTEGER          NPARAM
      CHARACTER*6      PARCHA(100)
*KEEP,VENUS.
      COMMON /VENUS/   ISH00,IVERVN,MTAR99,FVENUS,FVENSG
      INTEGER          ISH00,IVERVN,MTAR99
      LOGICAL          FVENUS,FVENSG
*KEEP,CEREN1.
      COMMON /CEREN1/  CERELE,CERHAD,ETADSN,WAVLGL,WAVLGU,CYIELD,
     *                 CERSIZ,CERNOR,LCERFI
      DOUBLE PRECISION CERELE,CERHAD,ETADSN,WAVLGL,WAVLGU,CYIELD,
     *                 CERSIZ,CERNOR
      LOGICAL          LCERFI
*KEEP,CEREN2.
      COMMON /CEREN2/  ACERX,ACERY,CERXOS,CERYOS,
     *                 DCERX,DCERXI,DCERY,DCERYI,EPSX,EPSY,FCERX,FCERY,
     *                 WL,XCMAX,XCMAXS,XSCATT,YCMAX,YCMAXS,YSCATT,
     *                 PHOTCM,XCER,YCER,UEMIS,VEMIS,WEMIS,CARTIM,ZEMIS,
     *                 NCERX,NCERY,ICERML
      DOUBLE PRECISION ACERX,ACERY,CERXOS(20),CERYOS(20),
     *                 DCERX,DCERXI,DCERY,DCERYI,EPSX,EPSY,FCERX,FCERY,
     *                 WL,XCMAX,XCMAXS,XSCATT,YCMAX,YCMAXS,YSCATT
      DOUBLE PRECISION PHOTCM,XCER,YCER,UEMIS,VEMIS,WEMIS,CARTIM,ZEMIS
      INTEGER          NCERX,NCERY,ICERML
*KEEP,ATMOSX.
C  EXTERNAL ATMOSPHERIC MODELS
      COMMON /ATMOSX/  IATMOX,FREFRX
      INTEGER          IATMOX
      LOGICAL          FREFRX
*KEND.
c------changed-----add
c>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
c All this lines are under test
c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
*keep,certel.
      common /certel/  cormxd,cord,coralp,ctpars,omega,
     +                 photn,photnp,phpt,pht,vphot,
     +                 vchi,veta,vzeta,vchim,vetam,vzetam,
     +                 lambda,mu,nu,nctels,ncph,phip1,thetap1
      double precision cormxd,cord,coralp,ctpars(20,7),omega(20,3,3),
     +                 photn(3),photnp(3),phpt(3),pht,vphot(3),
     +                 vchi(3),veta(3),vzeta(3),vchim,vetam,vzetam,
     +                 lambda,mu,nu
      integer          nctels,ncph(5)
      double precision xg,yg,zg,xgp,ygp,zgp,up,vp,wp,xpcut,ypcut,zpcut
      double precision thetap1,phip1
      equivalence (photn(1) ,xg)   ,(photn(2) ,yg)   ,(photn(3) ,zg)  ,
     +            (photnp(1),xgp)  ,(photnp(2),ygp)  ,(photnp(3),zgp),
     +            (phpt(1)  ,xpcut),(phpt(2)  ,ypcut),(phpt(3)  ,zpcut),
     +            (vphot(1) ,up)   ,(vphot(2) ,vp)   ,(vphot(3) ,wp)    

      character *72 ctfile

      character *6  keyw
c>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
c     Angles for the "spinning" of a particle around the 
c     main axis of the CT
      common /spinang/ spinxi
      double precision spinxi
C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
      integer m,nct
cxx----------------
c------changed-----add

      DOUBLE PRECISION R1,R2
      INTEGER          I,IE,IOBSLV,IS,ISEQ,MMM,MONNEW,NNTYP,NUMERR
      INTEGER          LENVAL
      INTEGER          IPARAM
      CHARACTER        LINE*132,TAB*1
      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 = 2
      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
      NRRUN     = 1
      ISHOWNO   = 0
      LLIMIT    = 1.D4
      ULIMIT    = 1.D4
      PSLOPE    = 0.D0
      PRMPAR(1) = 14.D0
      THETPR(1) = 0.D0
      THETPR(2) = 0.D0
      PHIPR(1)  = 0.D0
      PHIPR(2)  = 0.D0
      NSHOW     = 10
      IOBSLV    = 0
      NOBSLV    = 1
      OBSLEV(1) = 110.D2
      MODATM    = 1
      LAYNEW    = .FALSE.
      ELCUT(1)  = 0.3D0
      ELCUT(2)  = 0.3D0
      ELCUT(3)  = 0.003D0
      ELCUT(4)  = 0.003D0
      ECTMAP  = 1.D4
      NFLAIN  = 0
      NFLDIF  = 0
      NFLPI0  = 0
      NFLPIF  = 0
      NFLCHE  = 0
      NFRAGM  = 2
      FNKG    = .TRUE.
      FMOLI   = .TRUE.
      FMUADD  = .FALSE.
      FEGS    = .FALSE.
      FPAROUT = .TRUE.
      FTABOUT = .FALSE.
      STEPFC  = 1.D0
      MAXPRT  = 10
      BX      = 20.40D0
      BZ      = 43.23D0
      ARRANG  =  0.D0
      LLONGI  = .FALSE.
      THSTEP  = 20.D0
      FLGFIT  = .FALSE.
      FLONGOUT= .FALSE.
      RADNKG  = 200.D2
C  BORDER BETWEEN LOW AND HIGH ENERGY INTERACTION MODELS
C  SET BY DEFAULT TO ELAB = 80 GEV
      HILOELB = 80.D0
      GHEISH  = .TRUE.
      GHEISDB = .FALSE.
      FDBASE  = .FALSE.
      DEBUG   = .FALSE.
      DEBDEL  = .FALSE.
      NDEBDL  = 100000000
      THICK0  = 0.D0
      FIX1I   = .FALSE.
      FIXHEI  = 0.D0
      DSN     = 'anynameupto64characters                               '
      TMARGIN = .FALSE.
      HOST    = '                    '
      USER    = '                    '
      STEPFC  = 1.D0
      WAVLGL  = 300.D0
      WAVLGU  = 450.D0
      CERSIZ  = 0.D0
      NCERX   = 27
      NCERY   = 27
      DCERX   = 1500.D0
      DCERY   = 1500.D0
      ACERX   = 100.D0
      ACERY   = 100.D0
      LCERFI  = .TRUE.
      ICERML  = 1
      XSCATT  = 0.D0
      YSCATT  = 0.D0
      DO  554  I = 1,20
        CERXOS(I) = 0.D0
        CERYOS(I) = 0.D0
 554  CONTINUE
      IATMOX  = 0
      FREFRX  = .FALSE.
      FVENUS  = .TRUE.
      ISH00   = 91
      IPARAM  = 0
      NPARAM  = 0
      DO  555  I = 1,100
        PARVAL(I) = 0.
 555  CONTINUE
      FVENSG  = .TRUE.
      VUECON(1) = 0.D0
      VUECON(2) = 0.D0

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
      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 10  IE = LEN(LINE),1,-1
        IF ( LINE(IE:IE).NE.' ' ) GOTO 11
  10  CONTINUE
  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)
      ENDIF

C  CONVERT LOWER CASE CHARACTERS TO UPPER CASE
      DO 3  I = 1,5
        CALL LOWUP(LINE(I:I))
 3    CONTINUE
      IF ( LINE(1:4).NE.'HOST'  .AND.  LINE(1:4).NE.'USER' ) THEN
        CALL LOWUP(LINE(6:6))
        IF ( LINE(1:6).NE.'DIRECT' .AND.  LINE(1:6).NE.'HISTDS'
     *                                   ) THEN
          DO 4  I = 7,LEN(LINE)
            CALL LOWUP(LINE(I:I))
 4        CONTINUE
        ENDIF
      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-DIRCTION AND MAGNETIC NORD
      ELSEIF ( LINE(1:6) .EQ. 'ARRANG' ) THEN
        CALL DTCDBL(LINE,IS,ARRANG,'ARRANG',1)

C  GET INTERNAL ATMOSPHERIC MODEL NUMBER
      ELSEIF ( LINE(1:5) .EQ. 'ATMOD' ) THEN
        CALL DTCINT(LINE,IS,MODATM,'ATMOD',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.

C  SET EXTERNAL ATMOSPHERIC MODEL (MOST USEFUL FOR CHERENKOV LIGHT)
C  AND DETERMINE IF ATMOSPHERIC REFRACTION SHOULD BE ACCOUNTED FOR.
      ELSEIF ( LINE(1:10) .EQ. 'ATMOSPHERE' ) THEN
        CALL DTCINT(LINE,IS,IATMOX,'ATMOSPHERE',1)
        CALL DTCLOG(LINE,IS,FREFRX,'ATMOSPHERE',2)

C  GET CHERENKOV ARRAY SPECIFICATIONS
      ELSEIF ( LINE(1:6) .EQ. 'CERARY' ) THEN
        CALL DTCINT(LINE,IS,NCERX,'CERARY',1)
        CALL DTCINT(LINE,IS,NCERY,'CERARY',2)
        CALL DTCDBL(LINE,IS,DCERX,'CERARY',3)
        CALL DTCDBL(LINE,IS,DCERY,'CERARY',4)
        CALL DTCDBL(LINE,IS,ACERX,'CERARY',5)
        CALL DTCDBL(LINE,IS,ACERY,'CERARY',6)

C  GET CHERENKOV OUTPUT FLAG
      ELSEIF ( LINE(1:6) .EQ. 'CERFIL' ) THEN
        CALL DTCLOG(LINE,IS,LCERFI,'CERFIL',1)

C  GET MAXIMUM BUNCH SIZE FOR CHERENKOV PHOTONS
      ELSEIF ( LINE(1:6) .EQ. 'CERSIZ' ) THEN
        CALL DTCDBL(LINE,IS,CERSIZ,'CERSIZ',1)

C  GET CHERENKOV EVENT SCATTERING INFORMATION
      ELSEIF ( LINE(1:5) .EQ. 'CSCAT' ) THEN
        CALL DTCINT(LINE,IS,ICERML,'CSCAT',1)
        CALL DTCDBL(LINE,IS,XSCATT,'CSCAT',2)
        CALL DTCDBL(LINE,IS,YSCATT,'CSCAT',3)

C  GET CHERENKOV WAVELENGTH BAND
      ELSEIF ( LINE(1:6) .EQ. 'CWAVLG' ) THEN
        CALL DTCDBL(LINE,IS,R1,'CWAVLG',1)
        CALL DTCDBL(LINE,IS,R2,'CWAVLG',2)
        WAVLGL = MIN( R1, R2 )
        WAVLGU = MAX( R1, R2 )

C  GET DATABASE FLAG
      ELSEIF ( LINE(1:6) .EQ. 'DATBAS' ) THEN
        CALL DTCLOG(LINE,IS,FDBASE,'DATBAS',1)

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

C  GET OUTPUT DIRECTORY FOR CALCULATIONS ON UNIX-STATION
      ELSEIF ( LINE(1:6) .EQ. 'DIRECT' ) THEN
        CALL DTCCHR(LINE,IS,DSN,'DIRECT',1,LENVAL)

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 PHOTONS
      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 DEBUGGUNG
      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( ISHOWNO-1, 0 )
c------changed-----add-----
c>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>  
c  get cerenkov file name with cts array specifications
      elseif ( LINE(1:6) .eq. 'CERTEL' ) then
        read(line(7:),'(I10)') nctels
        d2r = 3.1415926535897932385/180.0
        do 1967 nct=1,nctels
          read(moniin,*) (ctpars(nct,m),m=1,7)
          ct = cos(ctpars(nct,ctthet)*d2r)
          st = sin(ctpars(nct,ctthet)*d2r)
          cp = cos(ctpars(nct,ctphi)*d2r)
          sp = sin(ctpars(nct,ctphi)*d2r)
          omega(nct,1,1) = cp
          omega(nct,1,2) = sp 
          omega(nct,1,3) = 0.0
          omega(nct,2,1) = -ct*sp 
          omega(nct,2,2) = ct*cp 
          omega(nct,2,3) = st 
          omega(nct,3,1) = st*sp 
          omega(nct,3,2) = -st*cp 
          omega(nct,3,3) = ct 
c          write(moniou,*) nct,(ctpars(nct,m),m=1,7)
 1967     continue
c>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>  
c---------changed-------add 

C  END OF DATA CARD INPUT
      ELSEIF ( LINE(1:4) .EQ. 'EXIT' ) THEN
        IF ( DEBUG ) THEN
          WRITE(MDEBUG,*) 'DATAC : END OF DATACARD INPUT'
        ELSE
          WRITE(MONIOU,*)
          WRITE(MONIOU,*) 'END OF DATACARD INPUT'
        ENDIF
        GOTO 1001

C  GET FIXED HEIGHT (G/CM**2) OF PARTICLE START
      ELSEIF ( LINE(1:6) .EQ. 'FIXCHI' ) THEN
        CALL DTCDBL(LINE,IS,THICK0,'FIXCHI',1)

C  GET FIXED HEIGHT OF FIRST INTERACTION AND FIRST TARGET
      ELSEIF ( LINE(1:6) .EQ. 'FIXHEI' ) THEN
        CALL DTCDBL(LINE,IS,FIXHEI,'FIXHEI',1)
        CALL DTCINT(LINE,IS,N1STTR,'FIXHEI',2)
        IF ( FIXHEI .GT. 0. ) FIX1I = .TRUE.

C  GET FLAG FOR GHEISHA DEBUG
      ELSEIF ( LINE(1:6) .EQ. 'GHEIDB' ) THEN
        CALL DTCLOG(LINE,IS,GHEISDB,'GHEIDB',1)

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 NAME OF HOST COMPUTER
      ELSEIF ( LINE(1:4) .EQ. 'HOST' ) THEN
        CALL DTCCHR(LINE,IS,HOST,'HOST',1,LENVAL)

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 .LT. 0 ) MAXPRT = 10

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)

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

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'
          STOP
        ENDIF

C  GET NEW MONITOR OUTPUT UNIT
      ELSEIF ( LINE(1:6) .EQ. 'OUTPUT' ) THEN
        CALL DTCINT(LINE,IS,MONNEW,'OUTPUT',1)
        WRITE(MONIOU,593) MONIOU,MONNEW
 593    FORMAT(' ATTENTION'/' ========='/
     *         ' LOGFILE OUTPUT REDIRECTED FROM UNIT ',I3,
     *         ' TO UNIT ',I3)
        MONIOU = MONNEW

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 )

C  GET TYPE OF PRIMARY PARTICLE
      ELSEIF ( LINE(1:6) .EQ. 'PRMPAR' ) THEN
        CALL DTCINT(LINE,IS,NNTYP,'PRMPAR',1)
        PRMPAR(1) = NNTYP

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)

C  GET SEEDS OF RANDOM NUMBER SEQUENCES
      ELSEIF ( LINE(1:4) .EQ. 'SEED' ) THEN
        ISEQ = ISEQ + 1
        IF ( ISEQ .LE. 10 ) 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 FACTOR FOR ELECTRON'S MULTIPLE SCATTERING LENGTH
      ELSEIF ( LINE(1:6) .EQ. 'STEPFC' ) THEN
        CALL DTCDBL(LINE,IS,STEPFC,'STEPFC',1)

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  GET NAME OF USER
      ELSEIF ( LINE(1:4) .EQ. 'USER' ) THEN
        CALL DTCCHR(LINE,IS,USER,'USER',1,LENVAL)

C  GET VENUS PARAMETER WITH CODE WORD AND VALUE
      ELSEIF ( LINE(1:6) .EQ. 'VENPAR' ) THEN
        IPARAM = IPARAM + 1
        IF ( IPARAM .LE. 100 ) THEN
          CALL DTCCHR(LINE,IS,PARCHA(IPARAM),'VENPAR',1,LENVAL)
          CALL DTCRL(LINE,IS,PARVAL(IPARAM),'VENPAR',2)
          NPARAM = IPARAM
        ELSE
          WRITE(MONIOU,*) 'DATAC : TOO MANY VENUS PARAMETERS,',
     *                    ' IGNORE IT'
        ENDIF

C  GET CROSS-SECTION FLAG FOR VENUS HADRONIC INTERACTION MODEL
      ELSEIF ( LINE(1:6) .EQ. 'VENSIG' ) THEN
        CALL DTCLOG(LINE,IS,FVENSG,'VENSIG',1)

C  GET FLAG FOR VENUS HIGH ENERGY HADRONIC INTERACTION MODEL
C  GET PARAMETER ISH00 FOR AMOUNT OF VENUS DEBUG
      ELSEIF ( LINE(1:5) .EQ. 'VENUS' ) THEN
        CALL DTCLOG(LINE,IS,FVENUS,'VENUS',1)
        CALL DTCINT(LINE,IS,ISH00,'VENUS',2)

C  GET CIRCULAR ANGLE RANGE FROM (FIXED) THETA AND PHI DIRECTION
C  WHERE SIMULATED SHOWER DIRECTION SHOULD BE.
      ELSEIF (LINE(1:8) .EQ. 'VIEWCONE' ) THEN
        CALL DTCDBL(LINE,IS,R1,'VIEWCONE',1)
        CALL DTCDBL(LINE,IS,R2,'VIEWCONE',2)
        VUECON(1) = MIN(R1,R2)
        VUECON(2) = MAX(R1,R2)

C  ILLEGAL KEYWORD
      ELSE
        IE = INDEX(LINE,' ')
        IF ( IE.LE.0 ) IE = LEN(LINE)+1
        WRITE(MONIOU,*) 'DATAC : UNKNOWN KEYWORD : ',LINE(1:IE-1)
        NUMERR = NUMERR + 1
      ENDIF

      IF ( LINE(1:1) .EQ. '!' ) NUMERR = NUMERR + 1

      GOTO 1

C-----------------------------------------------------------------------
 1000 CONTINUE
      IF ( DEBUG ) THEN
        WRITE(MDEBUG,*) 'DATAC : NO MORE DIRECTIVES FOUND'
      ELSE
        WRITE(MONIOU,*) '*** NO MORE DIRECTIVES FOUND ***'
      ENDIF

 1001 IF ( NUMERR .GT. 0 ) THEN
         WRITE(MONIOU,9000) NUMERR
 9000    FORMAT(1X,I3,' SYNTAX ERROR(S) IN INPUT DATA CARDS.')
         STOP 'BAD DATA CARDS'
      ENDIF

      RETURN
      END
*CMZ :          27/02/2002  16.27.13  by  D. HECK IK FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
C=======================================================================

      SUBROUTINE 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)
C
C  DESIGN  : D. HECK    IK3  FZK KARLSRUHE
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,CONSTA.
      COMMON /CONSTA/  PI,PI2,OB3,TB3,ENEPER
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER
*KEEP,LONGI.
      COMMON /LONGI/   ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP,LLONGI,FLGFIT
      DOUBLE PRECISION ADLONG(0:1170,9),AELONG(0:1170,9),
     *                 APLONG(0:1170,9),DLONG(0:1170,9),ELONG(0:1170,9),
     *                 HLONG(0:1170),PLONG(0:1170,9),SDLONG(0:1170,9),
     *                 SELONG(0:1170,9),SPLONG(0:1170,9),THSTEP,THSTPI
      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT
*KEEP,PAM.
      COMMON /PAM/     PAMA,SIGNUM,RESTMS
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000)
*KEEP,PARPAR.
      COMMON /PARPAR/  CURPAR,SECPAR,PRMPAR,OUTPAR,C,
     *                 E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
      DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16),
     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH
      INTEGER          ITYPE,LEVL
*KEEP,PARPAE.
      DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM
     *                 ,WEIGHT
     *                 ,HAPP,COSTAP,COSTEA
      EQUIVALENCE      (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE),
     *                 (CURPAR(4), PHI   ), (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)
*KEEP,RANDPA.
      COMMON /RANDPA/  FAC,U1,U2,RD,NSEQ,ISEED,KNOR
      DOUBLE PRECISION FAC,U1,U2
      REAL             RD(3000)
      INTEGER          ISEED(103,10),NSEQ
      LOGICAL          KNOR
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEND.

      DOUBLE PRECISION AUX1,AUX2,AUX2A,AUX3,AUX4,COSTCM,COSTH3,COSTH4,
     *                 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 RMMAR( 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**2 - 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 ADDANG( COSTHE,PHI, COSTH4,PHI4, SECPAR(3),SECPAR(4) )
      IF ( SECPAR(3) .GT. C(29) ) THEN
        SECPAR(1) = M4
        SECPAR(2) = GAMMA4
        IF ( DEBUG ) WRITE(MDEBUG,445) (SECPAR(I),I=1,9)
  445   FORMAT(' DECAY1: SECPAR=',1P,8E10.3,0P,F10.0)
        CALL TSTACK
      ELSE
        IF ( LLONGI ) THEN
C  ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT
          IF ( M4 .EQ. 1 ) THEN
            DLONG(LHEIGH,1) = DLONG(LHEIGH,1) + GAMMA4
          ELSE
            DLONG(LHEIGH,7) = DLONG(LHEIGH,7) + GAMMA4 * PAMA(M4)
          ENDIF
        ENDIF
      ENDIF
C  FIRST PRODUCT PARTICLE
      COSTH3 = MIN( 1.D0, (GAMMA * GAMMA3 - AUX2A)
     *                   / (BETA * GAMMA * SQRT(GAMMA3**2 - 1.D0)) )
      CALL ADDANG( COSTHE,PHI, COSTH3,PHI4+PI, SECPAR(3),SECPAR(4) )
      IF ( SECPAR(3) .GT. C(29) ) THEN
        SECPAR(1) = M3
        SECPAR(2) = GAMMA3
        IF ( DEBUG ) WRITE(MDEBUG,445) (SECPAR(I),I=1,9)
        CALL TSTACK
      ELSE
        IF ( LLONGI ) THEN
C  ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT
          IF     ( M3 .EQ. 13  .OR.  M3 .EQ. 14 ) THEN
            DLONG(LHEIGH,7) = DLONG(LHEIGH,7) + (GAMMA3-1.D0)*PAMA(M3)
          ELSEIF ( M3 .EQ. 15  .OR.  M3 .EQ. 25 ) THEN
            DLONG(LHEIGH,7) = DLONG(LHEIGH,7) + (GAMMA3+1.D0)*PAMA(M3)
          ELSE
            DLONG(LHEIGH,7) = DLONG(LHEIGH,7) + GAMMA3 * PAMA(M3)
          ENDIF
        ENDIF
      ENDIF

      RETURN
      END
*CMZ :          13/06/2001  15.08.42  by  D. HECK IK FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
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 PARAMETRISATION 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
C   AM3, AM4, AM5 = MASSES OF RESULTING PARTICLES
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 PARAMETRISATION SEE
C              PARAMB = H      PHYS. LETT. 204B (1988) 181 - 193
C              PARAMC = K
C
C  FOR MODE=2: PARAMA = A      DALITZ AMPLITUDE PARAMETRISATION 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 PARAMETRISATION
C              PARAMB = LAMBDA-ZERO    SEE PHYS. LETT. 204B (1988)
C              PARAMC = DUMMY          182 - 194
C
C  DESIGN  : D. HECK    IK3  FZK KARLSRUHE
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,CONSTA.
      COMMON /CONSTA/  PI,PI2,OB3,TB3,ENEPER
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER
*KEEP,DECAY.
      COMMON /DECAY/   GAM345,COS345,PHI345
      DOUBLE PRECISION GAM345(3),COS345(3),PHI345(3)
*KEEP,PAM.
      COMMON /PAM/     PAMA,SIGNUM,RESTMS
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000)
*KEEP,PARPAR.
      COMMON /PARPAR/  CURPAR,SECPAR,PRMPAR,OUTPAR,C,
     *                 E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
      DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16),
     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH
      INTEGER          ITYPE,LEVL
*KEEP,PARPAE.
      DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM
     *                 ,WEIGHT
     *                 ,HAPP,COSTAP,COSTEA
      EQUIVALENCE      (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE),
     *                 (CURPAR(4), PHI   ), (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)
*KEEP,POLAR.
      COMMON /POLAR/   POLART,POLARF
      DOUBLE PRECISION POLART,POLARF
*KEEP,RANDPA.
      COMMON /RANDPA/  FAC,U1,U2,RD,NSEQ,ISEED,KNOR
      DOUBLE PRECISION FAC,U1,U2
      REAL             RD(3000)
      INTEGER          ISEED(103,10),NSEQ
      LOGICAL          KNOR
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEND.

      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 RMMAR( 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**2) )
      COSBET = (P4SQ - P3SQ - P5SQ) / (2.D0 * P3CM * P5CM)
      SINBET = SQRT( MAX(0.D0, 1.D0 - COSBET**2) )
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 RMMAR( RD,3,1 )
      COS3CM = 2.D0*RD(1) - 1.D0
      SIN3CM = SQRT( MAX(0.D0, 1.D0 - COS3CM**2) )
      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**2)
         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)**2 - 1.D0) ) )
      GAM345(2) = GAMMA * (E4CM + BETA * P4CM * COS4CM) / AM4
      COS345(2) = MIN( 1.D0, (BETA * E4CM + P4CM * COS4CM) * GAMMA
     *                       / ( AM4 * SQRT(GAM345(2)**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**2)
          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)**2 - 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
*CMZ :          28/02/2002  10.53.59  by  D. HECK IK FZK KARLSRUHE
*-- Author :    K. BERNLOEHR MPIK HEIDELBERG    15/06/98
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  ARGUMETNS:
C   LINE   = CHARACTER STRING OF INPUT LINE
C   IS     = POINTER FOR START OF INTERPRETATION OF 'LINE'
C   CVAL   = CHARACTER STRING TO BE RETURNED
C   KEYWORD= KEYWORD AT BEGIN OF LINE
C   IKEY   = NUMBER OF ARGUMENT AFTER KEYWORD
C   LENVAL = LENGTH OF CHARACTER STRING TO BE RETURNED
C
C  AUTHOR: K. BERNLOEHR MPIK HEIDELBERG     1998
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEND.

      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  10  I = IS+1,L
        IF ( LINE(I:I) .NE. ' ' ) GOTO 11
   10 CONTINUE
   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 20  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
   20 CONTINUE
   21 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
*CMZ :          27/02/2002  16.27.13  by  D. HECK IK FZK KARLSRUHE
*-- Author :    K. BERNLOEHR MPIK HEIDELBERG    15/06/98
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  ARGUMETNS:
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   KEYWORD= KEYWORD AT BEGIN OF LINE
C   IKEY   = NUMBER OF ARGUMENT AFTER KEYWORD
C
C  AUTHOR: K. BERNLOEHR MPIK HEIDELBERG     1998
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEND.

      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  10  I = IS+1,L
        IF ( LINE(I:I) .NE. ' ' ) GOTO 11
   10 CONTINUE
   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  20  I = IS+1,L
        IF ( LINE(I:I) .EQ. ' '  .OR.  LINE(I:I) .EQ. '!' ) GOTO 21
   20 CONTINUE
   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
*CMZ :          27/02/2002  16.27.13  by  D. HECK IK FZK KARLSRUHE
*-- Author :    K. BERNLOEHR MPIK HEIDELBERG    15/06/98
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  ARGUMETNS:
C   LINE   = CHARACTER STRING OF INPUT LINE
C   IS     = POINTER FOR START OF INTERPRETATION OF 'LINE'
C   IVAL   = INTEGER VARIABLE TO BE RETURNED
C   KEYWORD= KEYWORD AT BEGIN OF LINE
C   IKEY   = NUMBER OF ARGUMENT AFTER KEYWORD
C
C  AUTHOR: K. BERNLOEHR MPIK HEIDELBERG     1998
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEND.

      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  10  I = IS+1,L
        IF ( LINE(I:I) .NE. ' ' ) GOTO 11
   10 CONTINUE
   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 20  I = IS+1,L
        IF ( LINE(I:I) .EQ. ' '  .OR.  LINE(I:I) .EQ. '!' ) GOTO 21
   20 CONTINUE
   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 30  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
   30 CONTINUE
      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
*CMZ :          27/02/2002  16.27.13  by  D. HECK IK FZK KARLSRUHE
*-- Author :    K. BERNLOEHR MPIK HEIDELBERG    15/06/98
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  ARGUMETNS:
C   LINE   = CHARACTER STRING OF INPUT LINE
C   IS     = POINTER FOR START OF INTERPRETATION OF 'LINE'
C   LVAL   = LOGICAL TO BE RETURNED
C   KEYWORD= KEYWORD AT BEGIN OF LINE
C   IKEY   = NUMBER OF ARGUMENT AFTER KEYWORD
C
C  AUTHOR: K. BERNLOEHR MPIK HEIDELBERG     1998
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEND.

      INTEGER          I,IE,IKEY,IS,L
      LOGICAL          LVAL
      CHARACTER        KEYWRD*(*),LINE*(*)
      SAVE
C-----------------------------------------------------------------------

      IF ( IS .LE. 0 ) IS = LEN(KEYWRD)

      L = LEN(LINE)
      DO  10  I = IS+1,L
        IF ( LINE(I:I) .NE. ' ' ) GOTO 11
   10 CONTINUE
   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  20  I = IS+1,L
        IF ( LINE(I:I) .EQ. ' '  .OR.  LINE(I:I) .EQ. '!' ) GOTO 21
   20 CONTINUE
   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
*CMZ :          27/02/2002  16.27.13  by  D. HECK IK FZK KARLSRUHE
*-- Author :    K. BERNLOEHR MPIK HEIDELBERG    15/06/98
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  ARGUMETNS:
C   LINE   = CHARACTER STRING OF INPUT LINE
C   IS     = POINTER FOR START OF INTERPRETATION OF 'LINE'
C   RVAL   = REAL VARIABLE TO BE RETURNED
C   KEYWORD= KEYWORD AT BEGIN OF LINE
C   IKEY   = NUMBER OF ARGUMENT AFTER KEYWORD
C
C  AUTHOR: K. BERNLOEHR MPIK HEIDELBERG     1998
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEND.

      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  10  I = IS+1,L
        IF ( LINE(I:I).NE.' ' ) GOTO 11
   10 CONTINUE
   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  20  I = IS+1,L
        IF ( LINE(I:I) .EQ. ' '  .OR.  LINE(I:I) .EQ. '!' ) GOTO 21
   20 CONTINUE
   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
*CMZ :          24/10/2000  15.40.59  by  D. HECK IK3 FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
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
*KEEP,GENER.
      COMMON /GENER/   GEN,ALEVEL
      DOUBLE PRECISION GEN,ALEVEL
*KEEP,LONGI.
      COMMON /LONGI/   ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP,LLONGI,FLGFIT
      DOUBLE PRECISION ADLONG(0:1170,9),AELONG(0:1170,9),
     *                 APLONG(0:1170,9),DLONG(0:1170,9),ELONG(0:1170,9),
     *                 HLONG(0:1170),PLONG(0:1170,9),SDLONG(0:1170,9),
     *                 SELONG(0:1170,9),SPLONG(0:1170,9),THSTEP,THSTPI
      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT
*KEEP,PAM.
      COMMON /PAM/     PAMA,SIGNUM,RESTMS
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000)
*KEEP,PARPAR.
      COMMON /PARPAR/  CURPAR,SECPAR,PRMPAR,OUTPAR,C,
     *                 E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
      DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16),
     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH
      INTEGER          ITYPE,LEVL
*KEEP,PARPAE.
      DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM
     *                 ,WEIGHT
     *                 ,HAPP,COSTAP,COSTEA
      EQUIVALENCE      (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE),
     *                 (CURPAR(4), PHI   ), (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)
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEND.

      DOUBLE PRECISION ENER,THICK
      INTEGER          I
      SAVE
      EXTERNAL         THICK
C-----------------------------------------------------------------------

      IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=1,9)
  444 FORMAT(' EM    : CURPAR=',1P,8E10.3,0P,F6.0)

C  GET CORRECT PARTICLE ENERGY
      IF     ( ITYPE  .EQ. 1 ) THEN
        ENER = CURPAR(2)
      ELSEIF ( ITYPE .EQ. 2  .OR.  ITYPE .EQ. 3 ) THEN
        ENER = CURPAR(2) * PAMA(2)
      ELSE
        WRITE(MONIOU,*) 'EM    : WRONG PARTICLE CODE =',ITYPE
        RETURN
      ENDIF

C  COPY PARTICLE COORDINATES INTO SECPAR
      DO 101  I = 1,8
        SECPAR(I) = CURPAR(I)
 101  CONTINUE
      SECPAR( 9)  = GEN
      SECPAR(10)  = ALEVEL
      SECPAR(14)  = CURPAR(14)
      SECPAR(15)  = CURPAR(15)
      SECPAR(16)  = CURPAR(16)

C  CALL NKG IF SELECTED
      IF ( FNKG ) THEN
        CALL NKG( ENER )
      ENDIF

C  CALL EGS4 IF SELECTED ( PARTICLE IS TAKEN IN EGS FROM COMMON )
      IF ( FEGS ) THEN
        CALL EGS4( ENER )
      ELSE
        IF ( LLONGI ) THEN
C  ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT
          LHEIGH = INT(THICK(H)*THSTPI + 1.D0)
          IF     ( SECPAR(1) .EQ. 1.D0 ) THEN
            DLONG(LHEIGH,1) = DLONG(LHEIGH,1) + ENER
          ELSEIF ( SECPAR(2) .EQ. 2.D0 ) THEN
            DLONG(LHEIGH,3) = DLONG(LHEIGH,3) + (ENER+PAMA(2))
          ELSE
            DLONG(LHEIGH,3) = DLONG(LHEIGH,3) + (ENER-PAMA(2))
          ENDIF
        ENDIF
      ENDIF

      RETURN
      END
*CMZ :          14/06/2000  15.06.16  by  D. HECK IK3 FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
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
C  DESIGN  : D. HECK    IK3  FZK KARLSRUHE
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,CONSTA.
      COMMON /CONSTA/  PI,PI2,OB3,TB3,ENEPER
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER
*KEEP,DECAY.
      COMMON /DECAY/   GAM345,COS345,PHI345
      DOUBLE PRECISION GAM345(3),COS345(3),PHI345(3)
*KEEP,EDECAY.
      COMMON /EDECAY/  CETA
      DOUBLE PRECISION CETA(5)
*KEEP,GENER.
      COMMON /GENER/   GEN,ALEVEL
      DOUBLE PRECISION GEN,ALEVEL
*KEEP,LONGI.
      COMMON /LONGI/   ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP,LLONGI,FLGFIT
      DOUBLE PRECISION ADLONG(0:1170,9),AELONG(0:1170,9),
     *                 APLONG(0:1170,9),DLONG(0:1170,9),ELONG(0:1170,9),
     *                 HLONG(0:1170),PLONG(0:1170,9),SDLONG(0:1170,9),
     *                 SELONG(0:1170,9),SPLONG(0:1170,9),THSTEP,THSTPI
      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT
*KEEP,PAM.
      COMMON /PAM/     PAMA,SIGNUM,RESTMS
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000)
*KEEP,PARPAR.
      COMMON /PARPAR/  CURPAR,SECPAR,PRMPAR,OUTPAR,C,
     *                 E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
      DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16),
     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH
      INTEGER          ITYPE,LEVL
*KEEP,PARPAE.
      DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM
     *                 ,WEIGHT
     *                 ,HAPP,COSTAP,COSTEA
      EQUIVALENCE      (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE),
     *                 (CURPAR(4), PHI   ), (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)
*KEEP,RANDPA.
      COMMON /RANDPA/  FAC,U1,U2,RD,NSEQ,ISEED,KNOR
      DOUBLE PRECISION FAC,U1,U2
      REAL             RD(3000)
      INTEGER          ISEED(103,10),NSEQ
      LOGICAL          KNOR
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEND.

      DOUBLE PRECISION AUX1,AUX2,COSTH1,COSTH2,EETA2,FI1
      INTEGER          I
      SAVE
C-----------------------------------------------------------------------

      IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=1,9)
  444 FORMAT(' ETADEC: CURPAR=',1P,9E10.3)

C  SELECT MODE OF DECAY, IF NOT ALREADY SELECTED BY THE PARTICLE TYPE
      IF ( ITYPE .EQ. 17 ) THEN
        CALL RMMAR( RD,1,1 )
        IF     ( RD(1) .LE. CETA(1) ) THEN
          ITYPE = 71
        ELSEIF ( RD(1) .LE. CETA(2) ) THEN
          ITYPE = 72
        ELSEIF ( RD(1) .LE. CETA(3) ) THEN
          ITYPE = 73
        ELSE
          ITYPE = 74
        ENDIF
      ENDIF

C  DECAY OF ETA  WITH 4 MODES
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  DECAY    ETA  ---->  GAMMA + GAMMA
      IF     ( ITYPE .EQ. 71 ) THEN
        EETA2  = 0.5D0 * GAMMA * PAMA(17)
        CALL RMMAR( 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(1) = 1.D0
C  FIRST GAMMA (WITH HIGHER ENERGY)
        FI1       = PI2 * RD(2)
        SECPAR(2) = AUX1 * EETA2
        CALL ADDANG( COSTHE,PHI, COSTH1,FI1, SECPAR(3),SECPAR(4) )
        IF ( SECPAR(3) .GT. C(29) ) THEN
          CALL TSTACK
        ELSE
          IF ( LLONGI ) THEN
C  ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT
            DLONG(LHEIGH,1) = DLONG(LHEIGH,1) + SECPAR(2)
          ENDIF
        ENDIF
C  SECOND GAMMA (WITH LOWER ENERGY)
        SECPAR(2) = AUX2 * EETA2
        CALL ADDANG( COSTHE,PHI, COSTH2,FI1+PI, SECPAR(3),SECPAR(4) )
        IF ( SECPAR(3) .GT. C(29) ) THEN
          CALL TSTACK
        ELSE
          IF ( LLONGI ) THEN
C  ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT
            DLONG(LHEIGH,1) = DLONG(LHEIGH,1) + SECPAR(2)
          ENDIF
        ENDIF

C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  DECAY    ETA  ---->  PI(0) + PI(0) + PI(0)
      ELSEIF ( ITYPE .EQ. 72 ) THEN
        CALL DECAY6( PAMA(17), PAMA(7),PAMA(7),PAMA(7),
     *               0.D0,0.D0,0.D0, 1.D0, 2 )
        SECPAR(1) = 7.D0
        DO 340  I = 1,3
          CALL ADDANG( COSTHE,PHI, COS345(I),PHI345(I),
     *                                SECPAR(3),SECPAR(4) )
          IF ( SECPAR(3) .GT. C(29) ) THEN
            SECPAR(2) = GAM345(I)
            CALL TSTACK
          ELSE
            IF ( LLONGI ) THEN
C  ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT
              DLONG(LHEIGH,7) = DLONG(LHEIGH,7) + GAM345(I) * PAMA(7)
            ENDIF
          ENDIF
  340   CONTINUE

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 360  I = 1,3
          CALL ADDANG( COSTHE,PHI, COS345(I),PHI345(I),
     *                                  SECPAR(3),SECPAR(4) )
          IF ( SECPAR(3) .GT. C(29) ) THEN
            SECPAR(1) = 10 - I
            SECPAR(2) = GAM345(I)
            CALL TSTACK
          ELSE
            IF ( LLONGI ) THEN
C  ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT
              DLONG(LHEIGH,7) = DLONG(LHEIGH,7) + GAM345(I)*PAMA(10-I)
            ENDIF
          ENDIF
  360   CONTINUE

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 380  I = 1,3
          CALL ADDANG( COSTHE,PHI, COS345(I),PHI345(I),
     *                                SECPAR(3),SECPAR(4) )
          IF ( SECPAR(3) .GT. C(29) ) THEN
            IF ( I .EQ. 3 ) THEN
              SECPAR(1) = 1.D0
            ELSE
              SECPAR(1) = 7 + I
            ENDIF
            SECPAR(2)   = GAM345(I)
            CALL TSTACK
          ELSE
            IF ( LLONGI ) THEN
C  ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT
              IF ( I .EQ. 3 ) THEN
                DLONG(LHEIGH,1) = DLONG(LHEIGH,1) + GAM345(I)
              ELSE
                DLONG(LHEIGH,7) = DLONG(LHEIGH,7) + GAM345(I)*PAMA(8)
              ENDIF
            ENDIF
          ENDIF
  380   CONTINUE

      ELSE
        WRITE(MONIOU,*) 'ETADEC: UNEXPECTED PARTICLE CODE ITYPE=',ITYPE
      ENDIF
      RETURN
      END
*CMZ :          27/02/2002  16.27.13  by  D. HECK IK FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
C=======================================================================

      SUBROUTINE FSTACK

C-----------------------------------------------------------------------
C  F(ROM) STACK
C
C  GETS PARTICLE FROM STACK AND READS FROM DISK IF NECESSARY
C  THIS SUBROUTINE IS CALLED FORM AAMAIN
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,BUFFS.
      COMMON /BUFFS/   RUNH,RUNE,EVTH,EVTE,DATAB,ARRAYLONG,LH
      INTEGER          MAXBUF,MAXLEN
      PARAMETER        (MAXLEN=16)
      PARAMETER        (MAXBUF=39*7)
      REAL             RUNH(MAXBUF),EVTH(MAXBUF),EVTE(MAXBUF),
     *                 RUNE(MAXBUF),DATAB(MAXBUF),ARRAYLONG(MAXBUF)
      INTEGER          LH
      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)
*KEEP,ETHMAP.
      COMMON /ETHMAP/  ECTMAP,ELEFT
      DOUBLE PRECISION ECTMAP,ELEFT
*KEEP,GENER.
      COMMON /GENER/   GEN,ALEVEL
      DOUBLE PRECISION GEN,ALEVEL
*KEEP,IRET.
      COMMON /IRET/    IRET1,IRET2,IRETE
      INTEGER          IRET1,IRET2
      LOGICAL          IRETE
*KEEP,PAM.
      COMMON /PAM/     PAMA,SIGNUM,RESTMS
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000)
*KEEP,PARPAR.
      COMMON /PARPAR/  CURPAR,SECPAR,PRMPAR,OUTPAR,C,
     *                 E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
      DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16),
     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH
      INTEGER          ITYPE,LEVL
*KEEP,PARPAE.
      DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM
     *                 ,WEIGHT
     *                 ,HAPP,COSTAP,COSTEA
      EQUIVALENCE      (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE),
     *                 (CURPAR(4), PHI   ), (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)
*KEEP,POLAR.
      COMMON /POLAR/   POLART,POLARF
      DOUBLE PRECISION POLART,POLARF
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEEP,STACKF.
      COMMON /STACKF/  STACK,MSTACKP,MEXST,NSHIFT,NOUREC,ICOUNT,
     *                 NTO,NFROM
      INTEGER          MAXSTK
      PARAMETER        (MAXSTK = 16*256*2)
      DOUBLE PRECISION STACK(MAXSTK)
      INTEGER          MSTACKP,MEXST,NSHIFT,NOUREC,ICOUNT,NTO,NFROM
*KEND.

      INTEGER          I,ISTK,J
      SAVE
      DATA             ISTK / MAXSTK /
C-----------------------------------------------------------------------

      IF ( DEBUG ) WRITE(MDEBUG,220) ICOUNT-1
 220  FORMAT(' FSTACK:',I7)

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'/
     *            ' ',I10,' PARTICLES WRITTEN TO STACK'/
     *            ' ',I10,' PARTICLES READ FROM STACK' )
          CURPAR(1) = 0.D0
          IRET1 = 1
          RETURN
        ENDIF
C  READ LAST BLOCK OF 256 PARTICLES FROM SCRATCH FILE
        READ(MEXST,REC=NOUREC) (STACK(I),I=1,ISTK/2)
        NOUREC  = NOUREC - 1
        MSTACKP = ISTK/2
      ENDIF

      NFROM  = NFROM + 1
      ICOUNT = ICOUNT - 1

C  PUT PARTICLE FROM STACK INTO CURPAR
      MSTACKP = MSTACKP - MAXLEN
      DO  5  J = 1,8
        CURPAR(J) = STACK(MSTACKP+J)
    5 CONTINUE
      GEN    = STACK(MSTACKP+ 9)
      ALEVEL = STACK(MSTACKP+10)
      POLART = STACK(MSTACKP+11)
      POLARF = STACK(MSTACKP+12)
      CURPAR(14) = STACK(MSTACKP+14)
      CURPAR(15) = STACK(MSTACKP+15)
      CURPAR(16) = STACK(MSTACKP+16)
      IF ( PAMA(NINT(CURPAR(1))) .NE. 0.D0 ) THEN
        ELEFT = ELEFT - CURPAR(2)*PAMA(NINT(CURPAR(1)))
      ELSE
        ELEFT = ELEFT - CURPAR(2)
      ENDIF

      IF ( DEBUG ) WRITE(MDEBUG,667) ICOUNT,(CURPAR(J),J=1,8)
  667 FORMAT('+       ',I7,1X,1P,8E10.3)

      RETURN
      END
*CMZ :          11/07/2000  10.08.30  by  D. HECK IK3 FZK KARLSRUHE
*-- Author :    D. HECK IK3 FZK KARLSRUHE       25/09/96
C=======================================================================

      REAL FUNCTION GBRSGM(Z,E)

C-----------------------------------------------------------------------
C  CALCULATES MUON BREMSSTRAHLUNG CROSS-SECTIONS
C
C  THIS SUBROUTINE IS TAKEN FROM GEANT321 PACKAGE (WITH MODIFICATIONS)
C  CALCULATES CROSS-SECTION IN CURRENT MATERIAL FOR DISCRETE(HARD) MUON
C  BREMSSTRAHLUNG.   (SIG IN BARN/ATOM)
C  FOR A DESCRIPTION SEE: CERN PROGRAM LIBRARY LONG WRITEUP W5013 (1993)
C  THIS FUNCTION IS CALLED FROM BOX2.
C  ARGUMENTS:
C   Z (R4) = ATOMIC NUMBER OF PENETRATET MATERIAL
C   E (R4) = TOTAL ENERGY OF MUON
C
C  AUTHOR  : L.URBAN
C  MODIFIED: D. HECK    IK3  FZK KARLSRUHE
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,MUPART.
      COMMON /MUPART/  AMUPAR,BCUT,CMUON,FMUBRM,FMUORG
      DOUBLE PRECISION AMUPAR(16),BCUT,CMUON(11)
      LOGICAL          FMUBRM,FMUORG
*KEEP,PAM.
      COMMON /PAM/     PAMA,SIGNUM,RESTMS
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000)
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEND.

      REAL             C(52),AKSI,ALFA,E,ECMAX,FAC,GAM,
     *                 S,SS,X,XX,YY,Z
      INTEGER          I,J,K
      SAVE
      DATA             AKSI/2.30/, ALFA/1.06/, GAM/0.63/
      DATA    C/ 0.949313E-07,-0.819600E-07, 0.529075E-07,-0.832023E-08
     +         , 0.539299E-09,-0.127042E-10,-0.165784E-08,-0.307788E-07
     +         , 0.977905E-08,-0.113658E-08, 0.574481E-10,-0.106221E-11
     +         , 0.968339E-09,-0.108640E-08,-0.177634E-09, 0.889497E-10
     +         ,-0.876878E-11, 0.264303E-12, 0.216263E-08,-0.152680E-08
     +         , 0.380989E-09,-0.455274E-10, 0.264172E-11,-0.596016E-13
     +         , 0.444927E-09,-0.272978E-09, 0.645634E-10,-0.748783E-11
     +         , 0.424890E-12,-0.940837E-14, 0.162289E-10,-0.362486E-11
     +         ,-0.576652E-12, 0.211269E-12,-0.185482E-13, 0.522065E-15
     +         ,-0.215590E-09, 0.112204E-09,-0.819133E-11, 0.145128E-12
     +         ,-0.206029E-09, 0.559940E-10,-0.483350E-11, 0.134252E-12
     +         ,-0.368469E-10, 0.999457E-11,-0.904967E-12, 0.272717E-13
     +         ,-0.303446E-11, 0.853429E-12,-0.785466E-13, 0.236435E-14/
C-----------------------------------------------------------------------

      GBRSGM = 0.
      IF ( E-PAMA(5) .LE. BCUT ) RETURN
      ECMAX = E - CMUON(10) * Z**0.333333
      IF ( ECMAX .LE. BCUT ) RETURN
      X = LOG(E/PAMA(5))

      S  = 0.
      YY = 1.
      DO 30  I = 1,6
        XX = 1.
        DO 20  J = 1,6
          K  = 6*I + J - 6
          S  = S + C(K) * XX * YY
          XX = XX * X
  20    CONTINUE
        YY = YY * CMUON(11)
  30  CONTINUE
      SS = 0.
      YY = 1.
      DO 50  I = 1,4
        XX = 1.
        DO 40  J = 1,4
          K  = 4*I + J + 32
          SS = SS + C(K) * XX * YY
          XX = XX * X
  40    CONTINUE
        YY = YY * CMUON(11)
  50  CONTINUE
      S = S + Z * SS
      IF ( S .LE. 0. ) RETURN

      FAC = LOG(ECMAX/BCUT)
      IF ( FAC .LE. 0. ) RETURN
      FAC = Z * ( Z + AKSI * (1.+GAM*LOG(Z)) ) * FAC**ALFA
      GBRSGM = FAC * S

      IF ( DEBUG ) WRITE(MDEBUG,444) Z,E,GBRSGM
  444 FORMAT(' GBRSGM: Z=',F3.0,' E=',1P,E10.4,' GBRSGM=',E10.4)

  99  RETURN
      END
*CMZ :          11/07/2000  10.08.30  by  D. HECK IK3 FZK KARLSRUHE
*-- Author :    D. HECK IK3 FZK KARLSRUHE       02/10/96
C=======================================================================

      REAL FUNCTION GPRSGM(Z,E)

C-----------------------------------------------------------------------
C  G(EANT) P(AI)R S(I)GM(A)
C  CALCULATES MUON PAIR PRODUCTION CROSS-SECTIONS
C
C  THIS SUBROUTINE IS TAKEN FROM GEANT321 PACKAGE (WITH MODIFICATIONS)
C  CALCULATES CROSS-SECTION IN CURRENT MATERIAL FOR DISCRETE(HARD) MUON
C  PAIR PRODUCTION.  (SIG IN BARN/ATOM)
C  FOR A DESCRIPTION SEE: CERN PROGRAM LIBRARY LONG WRITEUP W5013 (1993)
C  THIS SUBROUTINE IS CALLED FROM BOX2.
C  ARGUMENTS:
C   Z (R4) = ATOMIC NUMBER OF PENETRATET MATERIAL
C   E (R4) = TOTAL ENERGY OF MUON
C
C  AUTHOR  : L.URBAN
C  MODIFIED: D. HECK    IK3  FZK KARLSRUHE
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,CONSTA.
      COMMON /CONSTA/  PI,PI2,OB3,TB3,ENEPER
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER
*KEEP,MUPART.
      COMMON /MUPART/  AMUPAR,BCUT,CMUON,FMUBRM,FMUORG
      DOUBLE PRECISION AMUPAR(16),BCUT,CMUON(11)
      LOGICAL          FMUBRM,FMUORG
*KEEP,PAM.
      COMMON /PAM/     PAMA,SIGNUM,RESTMS
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000)
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEND.

      REAL        C(100),C1(60),C2(40),AKSI,ALFA,E,ECMAX,ECMIN,FAC,GAM,
     *            S,SS,VS,X,XX,Y,YY,Z,CUT
      INTEGER     I,J,K
      EQUIVALENCE (C(1),C1(1)),(C(61),C2(1))
      SAVE

      DATA        AKSI/1.16/,ALFA/3.46/,GAM/0.06/,VS/0.019/
      DATA        ECMIN/2.044E-3/
      DATA C1/0.230181E-08,-0.280842E-08, 0.137525E-08,-0.156503E-09
     +      , 0.728088E-11,-0.122631E-12, 0.133014E-08,-0.160591E-09
     +      ,-0.390814E-09, 0.314492E-10, 0.251296E-12,-0.574223E-13
     +      , 0.604923E-09,-0.560766E-09, 0.660253E-09,-0.103474E-09
     +      , 0.621338E-11,-0.135273E-12, 0.103739E-09, 0.710290E-09
     +      ,-0.544755E-10,-0.211241E-11, 0.286443E-12,-0.644602E-14
     +      , 0.332492E-09,-0.484785E-10, 0.126921E-10,-0.165217E-11
     +      , 0.845273E-13,-0.143180E-14,-0.112267E-13, 0.113308E-11
     +      , 0.292577E-12,-0.733441E-13, 0.475747E-14,-0.976279E-16
     +      ,-0.112856E-07, 0.936398E-08,-0.291882E-08, 0.422266E-09
     +      ,-0.279042E-10, 0.678485E-12, 0.112383E-07,-0.964400E-08
     +      , 0.313121E-08,-0.440224E-09, 0.278668E-10,-0.643012E-12
     +      ,-0.414131E-08, 0.355112E-08,-0.115035E-08, 0.158539E-09
     +      ,-0.976788E-11, 0.216911E-12, 0.521380E-09,-0.442265E-09
     +      , 0.141753E-09,-0.190826E-10, 0.114038E-11,-0.242085E-13/
      DATA C2/0.572943E-10,-0.296824E-10, 0.630217E-11,-0.623179E-12
     +      , 0.211467E-13,-0.143579E-10,-0.137247E-11, 0.118670E-11
     +      ,-0.793091E-13, 0.124745E-14,-0.269884E-10, 0.125314E-10
     +      ,-0.239259E-11, 0.181151E-12,-0.470277E-14,-0.342454E-11
     +      , 0.976666E-12,-0.236792E-12, 0.213290E-13,-0.607799E-15
     +      ,-0.748844E-12, 0.178214E-12,-0.226827E-13, 0.148441E-14
     +      ,-0.367972E-16, 0.840330E-12, 0.820025E-11,-0.294797E-11
     +      , 0.294669E-12,-0.970294E-14,-0.830636E-12,-0.309273E-11
     +      , 0.124169E-11,-0.135879E-12, 0.481683E-14, 0.438223E-12
     +      , 0.259162E-12,-0.149284E-12, 0.180170E-13,-0.677948E-15/
C-----------------------------------------------------------------------

      GPRSGM=0.
      CUT = BCUT
      IF ( ECMIN .GT. BCUT ) CUT=ECMIN

      ECMAX  = E - CMUON(10) * Z**OB3
      IF ( ECMAX .LE. CUT ) RETURN
      X = LOG(E/PAMA(5))
      Y = LOG( CUT/(VS*E) )

      S  = 0.
      YY = 1.
      DO 30  I = 1,2
        XX = 1.
        DO 20  J = 1,6
          K  = 6*I + J - 6
          S  = S + C(K) * XX * YY
          XX = XX * X
 20     CONTINUE
        YY = YY * Y
 30   CONTINUE
      DO 50  I = 3,6
        XX = 1.
        DO 40  J = 1,6
          K = 6*I + J - 6
          IF ( Y .LE. 0. ) THEN
            S = S + C(K) * XX * YY
          ELSE
            S = S + C(K+24) * XX * YY
          ENDIF
          XX = XX * X
 40     CONTINUE
        YY = YY * Y
 50   CONTINUE
      SS = 0.
      YY = 1.
      DO 70  I = 1,2
        XX = 1.
        DO 60  J = 1,5
          K  = 5*I + J + 55
          SS = SS + C(K) * XX * YY
          XX = XX * X
 60     CONTINUE
        YY = YY * Y
 70   CONTINUE
      DO 90  I = 3,5
        XX = 1.
        DO 80  J = 1,5
          K = 5*I + J + 55
          IF ( Y .LE. 0. ) THEN
            SS = SS + C(K) * XX * YY
          ELSE
            SS = SS + C(K+15) * XX * YY
          ENDIF
          XX = XX * X
 80     CONTINUE
        YY = YY * Y
 90   CONTINUE

      S = S + Z * SS
      IF ( S .LE. 0. ) RETURN
C  DE/DX SHOULD BE MONOTON INCREASING AS A
C  FUNCTION OF THE CUT
C  SOLUTION: LIN. INTERPOLATION FOR 0.2*ECMAX<CUT<ECMAX
      FAC = 2. * ( LOG(ECMAX/CUT) )**ALFA
      FAC = Z * ( Z + AKSI*( 1.+GAM*LOG(Z) ) ) * FAC
      GPRSGM = FAC * S
      IF ( DEBUG ) WRITE(MDEBUG,444) Z,E,GPRSGM
  444 FORMAT(' GPRSGM: Z=',F3.0,' E=',1P,E10.4,' GPRSGM=',E10.4)

 99   RETURN
      END
*CMZ :          19/10/2000  12.18.46  by  D. HECK IK3 FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
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, CORINC, INPRM,
C  MUTRAC, PRANGC, STAEND, THICKC, UPDATC, UPDATE, EGSINI, AND ININKG.
C  ARGUMENT:
C   ARG    = MASS OVERLAY IN G/CM**2
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,ATMOS.
      COMMON /ATMOS/   AATM,AATM0,BATM,BATM0,CATM,CATM0,DATM,MODATM
      DOUBLE PRECISION AATM(5),AATM0(5,0:16),BATM(5),BATM0(5,0:16),
     *                 CATM(5),CATM0(5,0:16),DATM(5)
      INTEGER          MODATM
*KEEP,ATMOS2.
      COMMON /ATMOS2/  HLAY,HLAY0,THICKL,LAYNO,LAYNEW
      DOUBLE PRECISION HLAY(6),HLAY0(5,0:4),THICKL(5)
      INTEGER          LAYNO(0:16)
      LOGICAL          LAYNEW
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEEP,ATMOSX.
C  EXTERNAL ATMOSPHERIC MODELS
      COMMON /ATMOSX/  IATMOX,FREFRX
      INTEGER          IATMOX
      LOGICAL          FREFRX
*KEND.

      DOUBLE PRECISION ARG
      SAVE
      DOUBLE PRECISION HEIGHX
      EXTERNAL         HEIGHX
C-----------------------------------------------------------------------

CC    IF ( DEBUG ) WRITE(MDEBUG,*) 'HEIGH : ARG=',SNGL(ARG)

      IF ( IATMOX .GE. 1 ) THEN
        HEIGH = HEIGHX(ARG)
        RETURN
      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
*CMZ :          01/03/2002  14.34.22  by  D. HECK IK FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
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
*KEEP,ATMOS.
      COMMON /ATMOS/   AATM,AATM0,BATM,BATM0,CATM,CATM0,DATM,MODATM
      DOUBLE PRECISION AATM(5),AATM0(5,0:16),BATM(5),BATM0(5,0:16),
     *                 CATM(5),CATM0(5,0:16),DATM(5)
      INTEGER          MODATM
*KEEP,ATMOS2.
      COMMON /ATMOS2/  HLAY,HLAY0,THICKL,LAYNO,LAYNEW
      DOUBLE PRECISION HLAY(6),HLAY0(5,0:4),THICKL(5)
      INTEGER          LAYNO(0:16)
      LOGICAL          LAYNEW
*KEEP,BUFFS.
      COMMON /BUFFS/   RUNH,RUNE,EVTH,EVTE,DATAB,ARRAYLONG,LH
      INTEGER          MAXBUF,MAXLEN
      PARAMETER        (MAXLEN=16)
      PARAMETER        (MAXBUF=39*7)
      REAL             RUNH(MAXBUF),EVTH(MAXBUF),EVTE(MAXBUF),
     *                 RUNE(MAXBUF),DATAB(MAXBUF),ARRAYLONG(MAXBUF)
      INTEGER          LH
      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)
*KEEP,CONSTA.
      COMMON /CONSTA/  PI,PI2,OB3,TB3,ENEPER
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER
*KEEP,DPMFLG.
      COMMON /DPMFLG/  NFLAIN,NFLDIF,NFLPI0,NFLCHE,NFLPIF,NFRAGM
      INTEGER          NFLAIN,NFLDIF,NFLPI0,NFLCHE,NFLPIF,NFRAGM
*KEEP,ELABCT.
      COMMON /ELABCT/  ELCUT
      DOUBLE PRECISION ELCUT(4)
*KEEP,ETHMAP.
      COMMON /ETHMAP/  ECTMAP,ELEFT
      DOUBLE PRECISION ECTMAP,ELEFT
*KEEP,LONGI.
      COMMON /LONGI/   ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP,LLONGI,FLGFIT
      DOUBLE PRECISION ADLONG(0:1170,9),AELONG(0:1170,9),
     *                 APLONG(0:1170,9),DLONG(0:1170,9),ELONG(0:1170,9),
     *                 HLONG(0:1170),PLONG(0:1170,9),SDLONG(0:1170,9),
     *                 SELONG(0:1170,9),SPLONG(0:1170,9),THSTEP,THSTPI
      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT
*KEEP,MAGANG.
      COMMON /MAGANG/  ARRANG,ARRANR,COSANG,SINANG
      DOUBLE PRECISION ARRANG,ARRANR,COSANG,SINANG
*KEEP,MAGNET.
      COMMON /MAGNET/  BX,BZ,BVAL,BNORMC,BNORM,COSB,SINB,BLIMIT
      DOUBLE PRECISION BX,BZ,BVAL,BNORMC,BNORM,COSB,SINB,BLIMIT
*KEEP,NKGI.
      COMMON /NKGI/    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)
*KEEP,OBSPAR.
      COMMON /OBSPAR/  OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP,
     *                 THETPR,PHIPR,
     *                 VUECON,
     *                 NOBSLV
      DOUBLE PRECISION OBSLEV(10),THCKOB(10),XOFF(10),YOFF(10),
     *                 HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2)
      DOUBLE PRECISION VUECON(2)
      INTEGER          NOBSLV
*KEEP,PARPAR.
      COMMON /PARPAR/  CURPAR,SECPAR,PRMPAR,OUTPAR,C,
     *                 E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
      DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16),
     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH
      INTEGER          ITYPE,LEVL
*KEEP,PARPAE.
      DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM
     *                 ,WEIGHT
     *                 ,HAPP,COSTAP,COSTEA
      EQUIVALENCE      (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE),
     *                 (CURPAR(4), PHI   ), (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)
*KEEP,PRIMSP.
      COMMON /PRIMSP/  PSLOPE,LLIMIT,ULIMIT,LL,UL,SLEX,ISPEC
      DOUBLE PRECISION PSLOPE,LLIMIT,ULIMIT,LL,UL,SLEX
      INTEGER          ISPEC
*KEEP,RANDPA.
      COMMON /RANDPA/  FAC,U1,U2,RD,NSEQ,ISEED,KNOR
      DOUBLE PRECISION FAC,U1,U2
      REAL             RD(3000)
      INTEGER          ISEED(103,10),NSEQ
      LOGICAL          KNOR
*KEEP,REJECT.
      COMMON /REJECT/  AVNREJ,ALTMIN,ANEXP,THICKA,THICKD,CUTLN,EONCUT,
     *                 FNPRIM
      DOUBLE PRECISION AVNREJ(10),ALTMIN(10),ANEXP(10),THICKA(10),
     *                 THICKD(10),CUTLN,EONCUT
      LOGICAL          FNPRIM
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEEP,STACKF.
      COMMON /STACKF/  STACK,MSTACKP,MEXST,NSHIFT,NOUREC,ICOUNT,
     *                 NTO,NFROM
      INTEGER          MAXSTK
      PARAMETER        (MAXSTK = 16*256*2)
      DOUBLE PRECISION STACK(MAXSTK)
      INTEGER          MSTACKP,MEXST,NSHIFT,NOUREC,ICOUNT,NTO,NFROM
*KEEP,TABLES.
      INTEGER          IEBIN, ITBIN, IDBIN
      PARAMETER        (IEBIN=40,ITBIN=30,IDBIN=20)
      COMMON /TABLES/  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)
*KEEP,VERS.
      COMMON /VERS/    VERNUM,MVDATE,VERDAT
      DOUBLE PRECISION VERNUM
      INTEGER          MVDATE
      CHARACTER*18     VERDAT
*KEEP,VENUS.
      COMMON /VENUS/   ISH00,IVERVN,MTAR99,FVENUS,FVENSG
      INTEGER          ISH00,IVERVN,MTAR99
      LOGICAL          FVENUS,FVENSG
*KEEP,CEREN1.
      COMMON /CEREN1/  CERELE,CERHAD,ETADSN,WAVLGL,WAVLGU,CYIELD,
     *                 CERSIZ,CERNOR,LCERFI
      DOUBLE PRECISION CERELE,CERHAD,ETADSN,WAVLGL,WAVLGU,CYIELD,
     *                 CERSIZ,CERNOR
      LOGICAL          LCERFI
*KEEP,CEREN2.
      COMMON /CEREN2/  ACERX,ACERY,CERXOS,CERYOS,
     *                 DCERX,DCERXI,DCERY,DCERYI,EPSX,EPSY,FCERX,FCERY,
     *                 WL,XCMAX,XCMAXS,XSCATT,YCMAX,YCMAXS,YSCATT,
     *                 PHOTCM,XCER,YCER,UEMIS,VEMIS,WEMIS,CARTIM,ZEMIS,
     *                 NCERX,NCERY,ICERML
      DOUBLE PRECISION ACERX,ACERY,CERXOS(20),CERYOS(20),
     *                 DCERX,DCERXI,DCERY,DCERYI,EPSX,EPSY,FCERX,FCERY,
     *                 WL,XCMAX,XCMAXS,XSCATT,YCMAX,YCMAXS,YSCATT
      DOUBLE PRECISION PHOTCM,XCER,YCER,UEMIS,VEMIS,WEMIS,CARTIM,ZEMIS
      INTEGER          NCERX,NCERY,ICERML
*KEEP,ATMOSX.
C  EXTERNAL ATMOSPHERIC MODELS
      COMMON /ATMOSX/  IATMOX,FREFRX
      INTEGER          IATMOX
      LOGICAL          FREFRX
*KEND.

      DOUBLE PRECISION HEIGH,H0,THICK
      DOUBLE PRECISION EFRAC,VERVEN
      INTEGER          I,IBL,J
      INTEGER          IDPM,ILONG,ISO,L
      INTEGER          ILTHIN
      CHARACTER*1      MARK
      CHARACTER*9      LSTDSN
      CHARACTER*8      RQSTAT

      INTEGER          IFREFRX
      LOGICAL          FEXIST
      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

      IF ( PRMPAR(1) .GE. 6000.D0  .OR.  PRMPAR(1) .LE. 0.D0 ) THEN
        WRITE(MONIOU,*)'INCORRECT SELECTION OF PRIMARY PARTICLE TYPE = '
     *                  ,INT(PRMPAR(1))
        WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE'
        WRITE(MONIOU,*) 'SEE KEYWORD: PRMPAR'
        STOP
      ENDIF
C  CHECK WETHER NUCLEUS IS A SINGLE NUCLEON
      IF (PRMPAR(1) .EQ. 100.D0 ) PRMPAR(1) = 13.D0
      IF (PRMPAR(1) .EQ. 101.D0 ) PRMPAR(1) = 14.D0
      WRITE(MONIOU,*) 'PRIMARY PARTICLE IDENTIFICATION IS ',
     *                NINT(PRMPAR(1))
C  CHECK RECOMMENDED ENERGY RANGE
      IF ( FVENUS  .AND.
     *     ULIMIT.GT.2.D7  .AND.  PRMPAR(1).GE.8.D0 ) THEN
        WRITE(MONIOU,502) ULIMIT
  502   FORMAT(' INTERACTION MODEL DOUBTFUL FOR THE SELECTED PRIMARY ',
     *       'ENERGY OF ',E10.3,' GEV'/' PLEASE READ THE USERS GUIDE')
        WRITE(MONIOU,*) 'SEE KEYWORD: ERANGE'
        STOP
      ENDIF

C CHECK ENERGY RANGE FOR CROSS-SECTIONS
      IF ( .NOT. FVENSG  .AND.  ULIMIT .GT. 1.D8 ) THEN
        WRITE(MONIOU,*) ' WARNING: P-AIR CROSS-SECTION DOUBTFULL ',
     *               'FOR ENERGIES ABOVE 10**17 EV'
      ENDIF

      IF ( PRMPAR(1) .GT. 101.D0 ) THEN
        IF ( GHEISH ) THEN
C  GHEISHA CANNOT TREAT NUCLEI
          IF ( LLIMIT .LT. HILOELB * INT(PRMPAR(1)/100.D0) ) THEN
            WRITE(MONIOU,503) INT(PRMPAR(1)/100.D0),LLIMIT
  503       FORMAT(' NUCLEUS WITH A =',I2,' AND PRIMARY ENERGY =',1P,
     *        E10.3,' GEV IS TOO LOW FOR HIGH ENERGY INTERACTION MODEL'/
     *        ' AND CANNOT BE TREATED BY LOW ENERGY INTERACTION MODEL'/
     *        ' SIMPLE SUPERPOSITION MODEL IS USED',0P)
            WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE'
            WRITE(MONIOU,*) 'SEE KEYWORD: ERANGE'
**          STOP
          ENDIF
        ENDIF
      ENDIF

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,E10.3,' IS LARGER THAN ULIMIT=',E10.3,' STOP')
        STOP
      ELSEIF ( LLIMIT .EQ. ULIMIT ) THEN
        ISPEC = 0
        WRITE(MONIOU,506) LLIMIT
  506   FORMAT(' PRIMARY ENERGY IS FIXED AT           ',1PE10.3,
     *         ' 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,E10.3/
     *  5X,' LOWER LIMIT CUT-OFF FOR PRIMARY SPECTRUM = ',E10.3,' GEV'/
     *  5X,' UPPER LIMIT CUT-OFF FOR PRIMARY SPECTRUM = ',E10.3,' 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

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  CHECK ANGULAR SETTINGS
      IF ( THETPR(1) .LT. 0.D0 ) THEN
        WRITE(MONIOU,*) 'UNALLOWED CHOICE OF THETPR = ',SNGL(THETPR(1)),
     *                  ' DEGREES'
        WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE'
        WRITE(MONIOU,*) 'SEE KEYWORD: THETAP'
        STOP
      ENDIF
      IF ( THETPR(2) .GT. 88.D0 ) THEN
        WRITE(MONIOU,*) 'UNALLOWED CHOICE OF THETPR = ',SNGL(THETPR(2)),
     *                  ' DEGREES'
        WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE'
        WRITE(MONIOU,*) 'SEE KEYWORD: THETAP'
        STOP
      ENDIF
C  INCIDENCE ANGLE FIXED ?
      IF ( THETPR(1) .EQ. THETPR(2) .AND. PHIPR(1) .EQ. PHIPR(2) ) THEN
        FIXINC = .TRUE.
      ELSE
        FIXINC = .FALSE.
        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
      IF     ( VUECON(2) .LT. 0.D0 ) THEN
        WRITE(MONIOU,*) 'UNALLOWED CHOICE OF VUECON = ',
     *              SNGL(VUECON(1)),SNGL(VUECON(2)),' DEGREES < 0.'
        WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE'
        WRITE(MONIOU,*) 'SEE KEYWORD: VIEWCONE'
        STOP
      ELSEIF ( VUECON(2) .GT. 0.D0 ) THEN
        IF ( .NOT. FIXINC ) THEN
          WRITE(MONIOU,*) 'THE VIEWCONE OPTION REQUIRES FIXED THETA',
     *           ' AND PHI VALUES.'
          WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE'
          WRITE(MONIOU,*) 'SEE KEYWORD: VIEWCONE'
          STOP
        ENDIF
        IF ( ABS(THETPR(2)-VUECON(2)) .GT. 88.D0-0.1D0 ) THEN
          WRITE(MONIOU,*) 'UNALLOWED COMBINATION OF THETA AND ',
     *        'VIEWCONE'
          WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE'
          WRITE(MONIOU,*) 'SEE KEYWORD: VIEWCONE AND THETAP'
          STOP
        ENDIF
        WRITE(MONIOU,519) THETPR(1),PHIPR(1),ABS(VUECON(1)),VUECON(2)
 519    FORMAT(' THETA OF VIEWING CONE IS FIXED TO ',F10.2,' DEGREES'/
     *        ' PHI   OF VIEWING CONE IS FIXED TO ',F10.2,' DEGREES'/
     *        ' VIEWING CONE HAS INNER OPENING OF +-',F10.2,' DEGREES'/
     *        ' VIEWING CONE HAS OUTER OPENING OF +-',F10.2,' DEGREES'/)
        IF ( THETPR(2)+VUECON(2) .GT. 88.D0 ) THEN
          WRITE(MONIOU,528)
  528     FORMAT(' A VIEWING CONE WAS CHOSEN WHICH DOES NOT FIT ',
     *      'ENTIRELY INTO THE ALLOWED RANGE',/,
     *      'OF ZENITH ANGLES. ONLY SHOWERS IN THE ALLOWED RANGE ARE ',
     *      'GENERATED BY CORSIKA.')
        ENDIF

      ENDIF
      EVTH(81) = THETPR(1)
      EVTH(82) = THETPR(2)
      EVTH(83) = PHIPR(1)
      EVTH(84) = PHIPR(2)
      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
      VUECON(1) = VUECON(1)*PI/180.D0
      VUECON(2) = VUECON(2)*PI/180.D0

C-----------------------------------------------------------------------
C  PRMPAR, OBSLEV, NOBSLV
      PRMPAR(2) = 0.D0
      PRMPAR(6) = 0.D0
      PRMPAR(7) = 0.D0
      PRMPAR(8) = 0.D0

C  CHECK WETHER OBSERVATION LEVELS ARE IN ALLOWED RANGE
      DO 12  I = 1,NOBSLV
        IF ( OBSLEV(I) .GE. HLAY(6) ) THEN
          WRITE(MONIOU,120) I,OBSLEV(I),HLAY(6)
 120      FORMAT(' UNALLOWED CHOICE OF OBSLEV '/' OBSERVATION LEVEL ',
     *           I2,' IS AT ',F12.3,' CM, WHICH IS ABOVE ',
     *           F12.3,' CM'/' PLEASE READ THE USERS GUIDE')
          WRITE(MONIOU,*) 'SEE KEYWORD: OBSLEV'
          STOP
        ENDIF
        IF ( OBSLEV(I) .LT. HLAY(1) ) THEN
          WRITE(MONIOU,121) I,OBSLEV(I)
 121      FORMAT(' UNALLOWED CHOICE OF OBSLEV '/' OBSERVATION LEVEL ',
     *          I2,' IS AT ',F12.3,' CM, WHICH IS BELOW LOWEST',
     *          ' ATMOSPHERE BOUNDARY'/' PLEASE READ THE USERS GUIDE')
          WRITE(MONIOU,*) 'SEE KEYWORD: OBSLEV'
          STOP
        ENDIF
        THCKOB(I) = THICK(OBSLEV(I))
   12 CONTINUE

C  WRITE OBSERVATION LEVELS TO HEADER (IN CM)
      RUNH(5)  = REAL(NOBSLV)
      EVTH(47) = REAL(NOBSLV)
      DO 114  I = 1,NOBSLV
        RUNH(5+I)  = OBSLEV(I)
        EVTH(47+I) = OBSLEV(I)
  114 CONTINUE

C  FIRST INTERACTION HEIGHT FIXED ?
      IF ( FIX1I ) THEN
        IF ( FIXHEI .GE. HLAY(6) ) THEN
          WRITE(MONIOU,122) FIXHEI,HLAY(6)
 122      FORMAT(' UNALLOWED CHOICE OF FIXHEI '/' FIRST INTERACTION ',
     *           'IS FIXED AT ',F12.3,' CM, WHICH IS ABOVE ',
     *           F12.3,' CM'/' PLEASE READ THE USERS GUIDE')
          WRITE(MONIOU,*) 'SEE KEYWORD: FIXHEI'
          STOP
        ENDIF
        IF ( FIXHEI .LE. OBSLEV(NOBSLV) ) THEN
          WRITE(MONIOU,123) FIXHEI,OBSLEV(NOBSLV)
 123      FORMAT(' UNALLOWED CHOICE OF FIXHEI '/' FIRST INTERACTION ',
     *           'IS FIXED AT ',F12.3,' CM, '/' WHICH IS BELOW ',
     *           'LOWEST OBSERVATION LEVEL AT ',F12.3,' CM'
     *           /' PLEASE READ THE USERS GUIDE')
          WRITE(MONIOU,*) 'SEE KEYWORD: FIXHEI'
          STOP
        ENDIF
          WRITE(MONIOU,507) FIXHEI
 507      FORMAT(' HEIGHT OF FIRST INTERACTION IS FIXED TO ',1P,E10.2,
     *         ' CM')
        IF ( N1STTR .GE. 1  .AND.  N1STTR .LE. 3 ) THEN
          IF ( PRMPAR(1) .LE. 3.D0 ) THEN
            WRITE(MONIOU,516) INT(PRMPAR(1))
 516        FORMAT(' TARGET OF FIRST INTERACTION CANNOT BE FIXED FOR ',
     *           'PRIMARY TYPE ',I5/' PLEASE READ THE USERS GUIDE')
            WRITE(MONIOU,*) 'SEE KEYWORD: FIXHEI'
            STOP
          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
        ELSE
          WRITE(MONIOU,*)
     *       'TARGET OF FIRST INTERACTION IS CHOSEN AT RANDOM'
        ENDIF
      ELSE
        FIXHEI = 0.D0
        WRITE(MONIOU,*) 'HEIGHT OF FIRST INTERACTION IS CHOSEN RANDOMLY'
      ENDIF

C  STARTING ALTITUDE WITHIN ATMOSPHERE?
      IF ( THICK0 .LT. 0.D0 ) THEN
        WRITE(MONIOU,130) THICK0
 130    FORMAT(' UNALLOWED STARTING ALTITUDE WITH NEGATIVE MASS OVERLAY'
     *          ,E12.3/' PLEASE READ THE USERS GUIDE')
        WRITE(MONIOU,*) 'SEE KEYWORD: FIXCHI'
        STOP
      ENDIF
      IF ( THICK0 .GE. THCKOB(NOBSLV) ) THEN
        WRITE(MONIOU,131) THICK0
 131    FORMAT(' UNALLOWED STARTING ALTITUDE AT ',F12.3,' G/CM**2',
     *         '  WHICH IS BELOW LOWEST OBSERVATION LEVEL'/
     *        ' PLEASE READ THE USERS GUIDE')
        WRITE(MONIOU,*) 'SEE KEYWORD: FIXCHI'
        STOP
      ENDIF
      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 (=',
     *                                          1P,E7.1,' G/CM**2)')
      WRITE(MONIOU,203) (OBSLEV(I),THCKOB(I),I=1,NOBSLV)
  203 FORMAT(/' OBSERVATION LEVELS IN  CM    AND IN   G/CM**2 ',
     *  1P /(6X, 2E21.8 /))

C  LONGITUDINAL SHOWER DEVELOPMENT
      IF ( LLONGI ) THEN
        THSTEP = NINT(THSTEP)
        THSTEP = MAX(THSTEP,1.D0)
        THSTEP = MIN(THSTEP,1170.D0)
        THSTPI = 1.D0/THSTEP
        NSTEP  = INT(THCKOB(NOBSLV)*THSTPI) + 1
        IF ( NSTEP .GE. 1170 ) THEN
          NSTEP  = 1170
          THSTEP = THCKOB(NOBSLV)/(NSTEP+1)
          THSTPI = 1.D0/THSTEP
          WRITE(MONIOU,*) 'LONGITUDINAL SHOWER SAMPLING MODIFIED'
        ENDIF
        WRITE(MONIOU,925) NSTEP,THSTEP
 925    FORMAT(/' LONGITUDINAL SHOWER DEVELOPMENT:'/
     *          '      SHOWER IS SAMPLED IN ',I4,
     *          ' STEPS OF ',F6.1,' G/CM**2')
C  GET HEIGHT VALUES IN CM FOR USE IN EGS
        DO 478  J = 0,NSTEP
          HLONG(J) = HEIGH(J*THSTEP)
          IF ( DEBUG ) WRITE(MDEBUG,*) J,HLONG(J),THSTEP
 478    CONTINUE
        IF ( FLGFIT ) THEN
          WRITE(MONIOU,*)
     *      '     FIT TO CHARGED PARTICLE LONG. DISTRIBUTION   ENABLED'
        ELSE
          WRITE(MONIOU,*)
     *      '     FIT TO CHARGED PARTICLE LONG. DISTRIBUTION   DISABLED'
        ENDIF
        WRITE(MONIOU,*)
      ENDIF

C-----------------------------------------------------------------------
C  CHECK INPUT OF ENERGY CUTS
      IF ( ELCUT(1) .LT. 0.05D0 ) THEN
        WRITE(MONIOU,*)'ELCUT(1) SELECTED INCORRECT TO ',ELCUT(1),' GEV'
        WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE'
        WRITE(MONIOU,*) 'SEE KEYWORD: ECUTS'
        STOP
      ENDIF
      IF ( ELCUT(2) .LT. 0.01D0 ) THEN
        WRITE(MONIOU,*)'ELCUT(2) SELECTED INCORRECT TO ',ELCUT(2),' GEV'
        WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE'
        WRITE(MONIOU,*) 'SEE KEYWORD: ECUTS'
        STOP
      ENDIF
      IF ( ELCUT(3) .LT. 5.D-5 ) THEN
        WRITE(MONIOU,*)'ELCUT(3) SELECTED INCORRECT TO ',ELCUT(3),' GEV'
        WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE'
        WRITE(MONIOU,*) 'SEE KEYWORD: ECUTS'
        STOP
      ENDIF
      IF ( ELCUT(4) .LT. 5.D-5 ) THEN
        WRITE(MONIOU,*)'ELCUT(4) SELECTED INCORRECT TO ',ELCUT(4),' GEV'
        WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE'
        WRITE(MONIOU,*) 'SEE KEYWORD: ECUTS'
        STOP
      ENDIF
      IF ( ELCUT(1) .GT. LLIMIT  .AND.  PRMPAR(1) .GE. 7.D0 ) THEN
        WRITE(MONIOU,*)'ELCUT(1) SELECTED INCORRECT < LLIMIT= ',LLIMIT
        WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE'
        WRITE(MONIOU,*) 'SEE KEYWORD: ECUTS'
        STOP
      ENDIF
      IF ( ELCUT(2) .GT. LLIMIT  .AND.
     *     (PRMPAR(1) .EQ. 5.D0  .OR.  PRMPAR(1) .EQ. 6.D0) ) THEN
        WRITE(MONIOU,*)'ELCUT(2) SELECTED INCORRECT < LLIMIT= ',LLIMIT
        WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE'
        WRITE(MONIOU,*) 'SEE KEYWORD: ECUTS'
        STOP
      ENDIF
      IF ( ELCUT(3) .GT. LLIMIT  .AND.
     *     (PRMPAR(1) .EQ. 2.D0  .OR.  PRMPAR(1) .EQ. 3.D0) ) THEN
        WRITE(MONIOU,*)'ELCUT(3) SELECTED INCORRECT < LLIMIT= ',LLIMIT
        WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE'
        WRITE(MONIOU,*) 'SEE KEYWORD: ECUTS'
        STOP
      ENDIF
      IF ( ELCUT(4) .GT. LLIMIT  .AND.  PRMPAR(1) .EQ. 1.D0 ) THEN
        WRITE(MONIOU,*)'ELCUT(4) SELECTED INCORRECT < LLIMIT= ',LLIMIT
        WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE'
        WRITE(MONIOU,*) 'SEE KEYWORD: ECUTS'
        STOP
      ENDIF
      WRITE(MONIOU,703) ECTMAP,ELCUT
  703 FORMAT (' PARTICLES WITH LORENTZ FACTOR LARGER THAN',1P,E15.4,
     *        ' ARE PRINTED OUT'/' SHOWER PARTICLES ENERGY CUT :'/
     *        '      FOR HADRONS   : ',E15.4,' GEV'/
     *        '      FOR MUONS     : ',E15.4,' GEV'/
     *        '      FOR ELECTRONS : ',E15.4,' GEV'/
     *        '      FOR PHOTONS   : ',E15.4,' GEV'//)

      DO 774  I = 1,4
        RUNH(20+I) = ELCUT(I)
        EVTH(60+I) = ELCUT(I)
  774 CONTINUE

C-----------------------------------------------------------------------
C  PARAMETERS OF EARTH MAGNETIC FIELD OF MIDDLE EUROPE
C  +X DIRECTION IS NORTH, +Y DIRECTION IS EAST, +Z DIRECTION IS DOWN
      BVAL   = SQRT( BX**2 + BZ**2 )
      IF ( BVAL .EQ. 0.D0 ) THEN
        WRITE(MONIOU,*) ' '
        WRITE(MONIOU,*) '==============================='
        WRITE(MONIOU,*) 'MAGNETIC FIELD MUST NOT BE ZERO'
        WRITE(MONIOU,*) '==============================='
        WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE'
        WRITE(MONIOU,*) 'SEE KEYWORD: MAGNET'
        STOP
      ENDIF
C  BNORM HAS DIMENSIONS OF MEV/CM
      BNORM  = BVAL * C(25) * 1.D-16
C  BNORMC HAS DIMENSIONS OF GEV/CM
      BNORMC = BNORM * 1.D-3
      SINB   = BZ / BVAL
      COSB   = BX / BVAL
      WRITE(MONIOU,*) 'EARTH MAGNETIC FIELD STRENGTH IS ',SNGL(BVAL),
     *                ' MICROTESLA'
      WRITE(MONIOU,*) '     WITH INCLINATION ANGLE      ',
     *               SNGL(ASIN(SINB)*180./PI),' DEGREES'
      IF ( BVAL .GE. 10000.D0 ) THEN
        WRITE(MONIOU,*) 'YOU WANT TO MAGNETIZE THE GALAXY ?'
        WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE'
        WRITE(MONIOU,*) 'SEE KEYWORD: MAGNET'
        STOP
      ENDIF
C  LIMITING FACTOR FOR STEP SIZE OF ELECTRON IN MAGNETIC FIELD
      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 EASTERN 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,*) 'DETECTOR COORDINATE SYSTEM IS ROTATED AWAY ',
     *                 'FROM NORTH BY ',SNGL(ARRANG),' DEGREES'
      ENDIF

C-----------------------------------------------------------------------
C  DEFINE CHERENKOV ARRAY
      NCERX = MAX( NCERX, 1 )
      NCERY = MAX( NCERY, 1 )
      ACERX = ABS(ACERX)
      ACERY = ABS(ACERY)
      IF ( NCERX .GT. 1 ) THEN
        DCERX = MAX( ABS(DCERX), 1.D0 )
      ELSE
        DCERX = 0.001D0
      ENDIF
      IF ( NCERY .GT. 1 ) THEN
        DCERY = MAX( ABS(DCERY), 1.D0 )
      ELSE
        DCERY = 0.001D0
      ENDIF
      XCMAX = (ACERX + (NCERX-1) * DCERX) * 0.5D0
      YCMAX = (ACERY + (NCERY-1) * DCERY) * 0.5D0
      DCERXI = 1.D0/DCERX
      EPSX   = ACERX * 0.5D0 * DCERXI
      DCERYI = 1.D0/DCERY
      EPSY   = ACERY * 0.5D0 * DCERYI
      IF ( MOD(NCERX,2) .EQ. 0 ) THEN
        FCERX = -0.5D0
      ELSE
        FCERX = 0.D0
      ENDIF
      IF ( MOD(NCERY,2) .EQ. 0 ) THEN
        FCERY = -0.5D0
      ELSE
        FCERY = 0.D0
      ENDIF

      WRITE(MONIOU,472) ACERX,ACERY, DCERX,DCERY,NCERX,NCERY
 472  FORMAT(/' CHERENKOV ARRAY:'/5X,
     *  ' CHERENKOV STATIONS ARE ',F10.2,'  *  ',F10.2,' CM**2 LARGE'/
     *  5X,' THE GRID SPACING IS   ',F10.2,' AND ',F10.2,' CM',/
     *  5X,' THERE ARE ',I3,' * ',I3,' STATIONS IN X/Y DIRECTIONS'/
     *  5X,' THE CHERENKOV ARRAY IS CENTERED AROUND (0., 0.)'/)
      IF ( NOBSLV .GT. 1 ) WRITE(MONIOU,473) OBSLEV(NOBSLV)*0.01
 473  FORMAT(/' CHERENKOV RADIATION IS REGISTERED ONLY FOR LOWEST',
     * ' OBSERVATION LEVEL AT ', F10.1,' METER'/)
C  CALCULATE CHERENKOV YIELD FACTOR FROM WAVELENGTH BAND
      IF ( WAVLGL .LT. 100.D0  .OR.  WAVLGU .GT. 700.D0
     *                         .OR.  WAVLGL .GE. WAVLGU ) THEN
        WRITE(MONIOU,*) 'CHERENKOV WAVELENGTH BAND FROM ',SNGL(WAVLGL),
     *              ' TO ',SNGL(WAVLGU),' NANOMETER'
        WRITE(MONIOU,*) ' IS OUT OF VALIDITY RANGE'
        WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE'
        WRITE(MONIOU,*) 'SEE KEYWORD: CWAVLG'
        STOP
      ENDIF
      WRITE(MONIOU,*) 'CHERENKOV WAVELENGTH BAND FROM ',SNGL(WAVLGL),
     *              ' TO ',SNGL(WAVLGU),' NANOMETER'
C  WAVELENGTH IS CONVERTED FROM NM TO CM
      CYIELD = (1.D0/WAVLGL - 1.D0/WAVLGU) * 2.D7 * PI / C(50)
C  CALCULATE FACTOR FOR ETA DENSITY NORML.
C  (ETA AT SEA LEVEL = 0.283D-3 FOR U.S. STDANDARD ATMOSPHERE)
      ETADSN = 0.283D-3 * CATM0(1,1) / BATM0(1,1)

      IF ( CERSIZ .GT. 0.D0 ) THEN
        WRITE(MONIOU,*) 'CHERENKOV BUNCH SIZE IS SET TO ',CERSIZ
      ELSE
        WRITE(MONIOU,*) 'CHERENKOV BUNCH SIZE IS CALCULATED FOR EACH ',
     *                 'SHOWER'
      ENDIF

      IF ( .NOT. LCERFI ) THEN
        WRITE(MONIOU,*) 'CHERENKOV PHOTONS ARE WRITTEN TO PARTICLE ',
     *                 'OUTPUT FILE'
      ELSE
        WRITE(MONIOU,*)
     *                'CHERENKOV PHOTONS ARE WRITTEN TO SEPARATE FILE'
      ENDIF
C  SCATTERING OF CENTER OF CHERENKOV ARRAY RELATIVE TO SHOWER AXIS
      ICERML = MIN(MAX(ICERML,1),20)
      IF ( ICERML .GE. 1 ) THEN
        XSCATT = ABS(XSCATT)
        YSCATT = ABS(YSCATT)
        WRITE(MONIOU,5225) ICERML,XSCATT,YSCATT
 5225   FORMAT(' DEFINE MULTIPLE CHERENKOV ARRAYS TO USE EACH',
     *   ' SHOWER SEVERAL TIMES'/ ' USE EACH EVENT ',I2,' TIMES'/
     *   ' THE EVENTS ARE SCATTERED QUASI RANDOMLY IN THE RANGE '/
     *   18X,'   X =  +- ',F10.2,'    Y = +- ',F10.2,' CM' )
        XCMAXS = XCMAX + XSCATT
        YCMAXS = YCMAX + YSCATT
      ENDIF

C  STORE CHERENKOV PARAMETERS IN EVENTHEADER
      EVTH(86) = NCERX
      EVTH(87) = NCERY
      EVTH(88) = DCERX
      EVTH(89) = DCERY
      EVTH(90) = ACERX
      EVTH(91) = ACERY
      IF ( LCERFI ) THEN
        EVTH(92) = 1.
      ELSE
        EVTH(92) = 0.
      ENDIF
      EVTH(96) = WAVLGL
      EVTH(97) = WAVLGU
      EVTH(98) = FLOAT(ICERML)
C  INITIALIZE REFRACTIVE INDEX TABLE
      CALL INRTAB

C-----------------------------------------------------------------------
C  FLAG FOR ADDITIONAL MUON INFORMATION
      IF ( FMUADD ) THEN
        WRITE(MONIOU,*)
        WRITE(MONIOU,*) 'ADDITIONAL INFORMATION ON MUON ORIGIN IS',
     *                  ' WRITTEN TO PARTICLE TAPE'
        EVTH(94) = 1.
      ELSE
        EVTH(94) = 0.
      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  CHECK CORRECTNESS OF RUN NUMBER
      IF ( NRRUN .GT. 999999 ) THEN
        WRITE(MONIOU,*)'RUN NUMBER = ',NRRUN,' EXCEEDS 999999, STOP'
        STOP
      ENDIF
c--------changed----command up to line labeld 5791
cxx------------
cxx call tobuf(runh,0) and tobufc(runh,0) are now in main program

c>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
c   Next block of code is obsolete.
c   Now it's used "jcio" routines (C)
C-------------------------------------

cxxC  OUTPUT FILES SHOULD NORMALLY NOT EXIST BEFORE THE RUN STARTS
      RQSTAT = 'NEW'
cC  OPEN OUTPUT DATA SET FOR RUN
c      IBL = INDEX(DSN,' ')
c      DSN(IBL:73) = 'DAT000000'
c      WRITE(DSN(IBL+3:IBL+8),'(I6)') NRRUN
c      DO 274  L = IBL+3,IBL+8
c        IF ( DSN(L:L) .EQ. ' ' ) DSN(L:L) = '0'
c 274  CONTINUE
c      IF ( FTABOUT ) THEN
c        DSNTAB=DSN
c        DSNTAB(IBL+9:IBL+12) = '.tab'
c      ENDIF
c      IF ( FLONGOUT  .AND.  LLONGI ) THEN
c        IF ( DSN(1:9) .EQ. '/dev/null' ) THEN
c          DSNLONG(1:9)   = DSN(10:18)
c          DSNLONG(10:14) = '.long '
c        ELSE
c          DSNLONG = DSN
c          DSNLONG(IBL+9:IBL+13) = '.long'
c        ENDIF
c      ENDIF
c      IF ( DSN(1:9) .EQ. '/dev/null' ) THEN
c         DSN    = '/dev/null'
c         RQSTAT = 'UNKNOWN'
c      ELSE
cC  ON LINUX WITH G77 AN EXISTING FILE CAUSES A CORE DUMP -> FIRST INQUIRE
c         INQUIRE(FILE=DSN,EXIST=FEXIST)
c         IF ( FEXIST ) THEN
c            IBL = INDEX(DSN,' ')
c            IF ( IBL .LE. 1 ) IBL = LEN(DSN)+1
c            WRITE(MONIOU,5791) DSN(1:IBL-1)
 5791       FORMAT(/' FILE ',A,' ALREADY EXISTS. RENAME OR REMOVE IT',
     *        ' OR CHANGE ''DIRECT'' DATA CARD AND TRY AGAIN.')
c            STOP 'FATAL PROBLEM'
c         ENDIF
c      ENDIF
cC  OPEN DATASET FOR PARTICLE OUTPUT
c      IF ( FPAROUT ) THEN
c        OPEN(UNIT=MPATAP,FILE=DSN,STATUS=RQSTAT,
c     *       FORM='UNFORMATTED',ACCESS='SEQUENTIAL')
c        WRITE(MONIOU,579) DSN
c 579    FORMAT(/' PARTICLE OUTPUT TO FILE : ',A79)
c      ENDIF
cC  OPEN DATASET FOR TABLE OUTPUT
c      IF ( FTABOUT ) THEN
c        OPEN(UNIT=MTABOUT,FILE=DSNTAB,STATUS=RQSTAT,
c     *       FORM='UNFORMATTED',ACCESS='SEQUENTIAL')
c        WRITE(MONIOU,578) DSNTAB,
c     *        IEBIN,EBMIN,EBMAX,
c     *        ITBIN,TBMIN,TBMAX,
c     *        IDBIN,DBMIN,DBMAX
c 578    FORMAT(/' TABLE OUTPUT TO FILE : ',A79/
c     *          '   ENERGY : ',I2,' BINS, RANGE :',1P,2E10.2,' GEV'/
c     *          '   TIME   : ',I2,' BINS, RANGE :',1P,2E10.2,' NS'/
c     *          '   RADIUS : ',I2,' BINS, RANGE :',1P,2E10.2,' CM')
c        WRITE(MTABOUT) IEBIN,EBMIN,EBMAX
c        WRITE(MTABOUT) ITBIN,TBMIN,TBMAX
c        WRITE(MTABOUT) IDBIN,DBMIN,DBMAX
c        EBOFF = LOG10(EBMIN)
c        EBFAC = 1./(LOG10(EBMAX/EBMIN)/IEBIN)
c        TBOFF = LOG10(TBMIN)
c        TBFAC = 1./(LOG10(TBMAX/TBMIN)/ITBIN)
c        DBOFF = LOG10(DBMIN)
c        DBFAC = 1./(LOG10(DBMAX/DBMIN)/IDBIN)
c      ENDIF
c      IF ( FLONGOUT  .AND.  LLONGI ) THEN
c        OPEN(UNIT=MLONGOUT,FILE=DSNLONG,STATUS=RQSTAT,
c     *       FORM='FORMATTED',ACCESS='SEQUENTIAL')
c        WRITE(MONIOU,5781) DSNLONG
c 5781   FORMAT(' LONGITUDINAL OUTPUT TO FILE: ',A79)
c      ENDIF
c
cC  WRITE RUNHEADER TO OUTPUT BUFFER
c      CALL TOBUF( RUNH,0 )
c
cC  OPEN OUTPUT DATA SET FOR CHERENKOV PHOTONS
c      IF ( LCERFI ) THEN
c        DSN(IBL:73) = 'CER000000'
c        WRITE(DSN(IBL+3:IBL+8),'(I6)') NRRUN
c        DO 249  L = IBL+3,IBL+8
c          IF ( DSN(L:L) .EQ. ' ' ) DSN(L:L) = '0'
c 249    CONTINUE
c        IF ( DSN(1:9) .EQ. '/dev/null' ) THEN
c          DSN    = '/dev/null'
c          RQSTAT = 'UNKNOWN'
c        ELSE
cC  ON LINUX WITH G77 AN EXISTING FILE CAUSES A CORE DUMP -> FIRST INQUIRE
c          INQUIRE(FILE=DSN,EXIST=FEXIST)
c          IF ( FEXIST ) THEN
c            IBL = INDEX(DSN,' ')
c            IF ( IBL .LE. 1 ) IBL = LEN(DSN)+1
c            WRITE(MONIOU,5791) DSN(1:IBL-1)
c            STOP 'FATAL PROBLEM'
c          ENDIF
c        ENDIF
c        OPEN(UNIT=MCETAP,FILE=DSN,STATUS=RQSTAT,
c     *       FORM='UNFORMATTED',ACCESS='SEQUENTIAL')
c        WRITE(MONIOU,580) DSN
c 580    FORMAT(' CHERENKOV OUTPUT TO FILE : ',A79)
c        CALL TOBUFC( RUNH,0 )
c      ELSE
c        WRITE(MONIOU,580) DSN
c      ENDIF
cC  RESET DSN
c      DSN(IBL:73) = '         '
c>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
c------changed - command above
c---------change to alpha - remove c*** and command some lines
C  OPEN THE EXTERNAL STACK
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.
C  FOR DEC UNIX (COMPAQ Tru64) MACHINES WITH f77 COMPILER (UNLESS USING
C  THE '-assume bytrecl' COMPILER OPTION) AND SOME OTHER MACHINES THE
C  RECL PARAMETER IS THE NUMBER OF (4-BYTE) WORDS.

c***      CALL RCLCHK(MEXST,4,L)
      CALL RCLCHK(MEXST,1,L)
      IF ( L .NE. 0 ) THEN
        WRITE(MONIOU,*) 'FATAL ERROR:',L,
     *                  ' RECL HANDLING NOT AS EXPECTED'
        STOP
      ENDIF
      OPEN(UNIT=MEXST,STATUS='SCRATCH',
     *     FORM='UNFORMATTED',ACCESS='DIRECT',RECL=4*MAXSTK)
c------changed to alpha
c***     *     FORM='UNFORMATTED',ACCESS='DIRECT',RECL=MAXSTK)
c------changed to alpha
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
C  WRITE DATA SET FOR INFORMATION BANK
      IF ( FDBASE ) THEN
C  OPEN OUTPUT DATA SET FOR RUN
        IBL = INDEX(DSN,' ')
C  IF NORMAL OUTPUT DISABLED BUT 'DATBAS T', TRY CURRENT DIRECTORY.
        IF ( DSN(1:9) .EQ. '/dev/null' ) IBL = 1
        DSN(IBL:79) = 'DAT000000.dbase'
        WRITE(DSN(IBL+3:IBL+8),'(I6)') NRRUN
        DO 275  L = IBL+3,IBL+8
          IF ( DSN(L:L) .EQ. ' ' ) DSN(L:L) = '0'
 275    CONTINUE
        IF ( DSN(1:9) .EQ. '/dev/null' ) THEN
          DSN    = '/dev/null'
          RQSTAT = 'UNKNOWN'
        ELSE
C  ON LINUX WITH G77 AN EXISTING FILE CAUSES A CORE DUMP -> FIRST INQUIRE
          INQUIRE(FILE=DSN,EXIST=FEXIST)
          IF ( FEXIST ) THEN
            IBL = INDEX(DSN,' ')
            IF ( IBL .LE. 1 ) IBL = LEN(DSN)+1
            WRITE(MONIOU,5791) DSN(1:IBL-1)
            STOP 'FATAL PROBLEM'
          ENDIF
        ENDIF
        OPEN(UNIT=MDBASE,FILE=DSN,STATUS=RQSTAT)
        WRITE(MONIOU,581) DSN
 581    FORMAT(/' DBASE OUTPUT TO FILE : ',A79)
C  RESET DSN
        DSN(IBL+9:IBL+14) = '      '

        LSTDSN(1:3) = 'LST'
        LSTDSN(4:9) = DSN(IBL+3:IBL+8)
C  RESET DSN TO '/dev/null' AS IT WAS BEFORE.
        IF ( IBL .EQ. 1 ) DSN = '/dev/null'

        VERVEN = FLOAT(IVERVN)/1000.D0
        IF ( LLONGI ) THEN
          ILONG = 1
        ELSE
          ILONG = 0
        ENDIF
        ISO = 0
C  SET DPMFLAG (0=HDPM, 1=VENUS, 2=SIBYLL, 3=QGSJET, 4=DPMJET, 5=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=NEXUSSIG)
        IF     ( EVTH(145) .EQ. 1. ) THEN
          IDPM = IDPM + 10
        ELSEIF ( EVTH(145) .EQ. 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 = '1'
        ILTHIN = 0
        EFRAC  = 0.D0
        IF ( FREFRX ) THEN
          IFREFRX = 1
        ELSE
          IFREFRX = 0
        ENDIF

        WRITE(MDBASE,666) VERNUM,MARK,MVDATE,SNGL(VERVEN),
     $                    INT(RUNH(3))+20000000,
     $    INT(EVTH(80)),INT(EVTH(79)),INT(EVTH(78)),
     $                    MOD(INT(EVTH(77)),10),INT(RUNH(2)),
     $    INT(PRMPAR(1)),LLIMIT,ULIMIT,
     $    PSLOPE,INT(RUNH(20)),INT(RUNH(19)),INT(EVTH(76)),
     $                    INT(EVTH(75)),ISO,IDPM,
     $    NFLAIN,NFLDIF,NFLPI0,NFLPIF,NFLCHE,NFRAGM,
     $    ILONG,THSTEP,BX,
     $    BZ,NOBSLV
 666    FORMAT('#version#',F6.3,A1,'#versiondate#',I9,
     $    '#modelversion#',F8.3,'#rundate#',I9,/,
     $    '#computer#',I2,'#curved#',I2,'#neutrino#',I2,
     $    '#cerenkov#',I2,'#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,'#isobar#',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)),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
     $    ,IATMOX,IFREFRX
     $    ,VUECON(1)*(180.D0/PI),VUECON(2)*(180.D0/PI)
 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,
     $    '#nseq#',I2,/,
     $    '#seq1seed1#',I9,'#seq1seed2#',I9,'#seq1seed3#',I9,/,
     $    '#seq2seed1#',I9,'#seq2seed2#',I9,'#seq2seed3#',I9,/,
     $    '#seq3seed1#',I9,'#seq3seed2#',I9,'#seq3seed3#',I9,/,
     $    '#size#',I10,/,'#dsn_events#',A59,/,
     $    '#dsn_prtout# ',A9,'#tape_name#',A10,'#backup#',A10,/,
     $    '#howmanyshowers#',I10,'#host#',A20,'#user#',A20
     $    ,/,'#atmosphere#',I3,'#refract#',I2
     $    ,/,1P,'#viewcon_l#',E14.7,'#viewcon_u#',E14.7,0P
     $    )
        WRITE(MDBASE,670) ILTHIN,EFRAC
 670    FORMAT('#thinning#',I2,'#thinnlev_had#',1P,E14.7,0P)

C  RESET DSN
        DSN(IBL:IBL+14) = '               '
C  THE MDBASE FILE IS CLOSED IN AAMAIN
      ENDIF

      WRITE(MONIOU,*) 'NUMBER OF SHOWERS TO GENERATE =',NSHOW
      WRITE(MONIOU,*)
      RETURN
      END
*CMZ :          18/10/2000  09.15.11  by  D. HECK IK3 FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
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
*KEEP,ETHMAP.
      COMMON /ETHMAP/  ECTMAP,ELEFT
      DOUBLE PRECISION ECTMAP,ELEFT
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEEP,STACKF.
      COMMON /STACKF/  STACK,MSTACKP,MEXST,NSHIFT,NOUREC,ICOUNT,
     *                 NTO,NFROM
      INTEGER          MAXSTK
      PARAMETER        (MAXSTK = 16*256*2)
      DOUBLE PRECISION STACK(MAXSTK)
      INTEGER          MSTACKP,MEXST,NSHIFT,NOUREC,ICOUNT,NTO,NFROM
*KEND.

      SAVE
C-----------------------------------------------------------------------

      IF ( DEBUG ) WRITE(MDEBUG,*) 'ISTACK:'

      NTO     = 0
      NFROM   = 0
      NOUREC  = 0
      NSHIFT  = 0
      MSTACKP = 0
      ELEFT   = 0.D0
      ICOUNT  = 1
      RETURN
      END
*CMZ :          31/01/2001  10.50.55  by  D. HECK IK FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
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
C  DESIGN  : D. HECK    IK3  FZK KARLSRUHE
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,CONSTA.
      COMMON /CONSTA/  PI,PI2,OB3,TB3,ENEPER
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER
*KEEP,DECAY.
      COMMON /DECAY/   GAM345,COS345,PHI345
      DOUBLE PRECISION GAM345(3),COS345(3),PHI345(3)
*KEEP,IRET.
      COMMON /IRET/    IRET1,IRET2,IRETE
      INTEGER          IRET1,IRET2
      LOGICAL          IRETE
*KEEP,KAONS.
      COMMON /KAONS/   CKA
      DOUBLE PRECISION CKA(80)
*KEEP,LONGI.
      COMMON /LONGI/   ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP,LLONGI,FLGFIT
      DOUBLE PRECISION ADLONG(0:1170,9),AELONG(0:1170,9),
     *                 APLONG(0:1170,9),DLONG(0:1170,9),ELONG(0:1170,9),
     *                 HLONG(0:1170),PLONG(0:1170,9),SDLONG(0:1170,9),
     *                 SELONG(0:1170,9),SPLONG(0:1170,9),THSTEP,THSTPI
      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT
*KEEP,PAM.
      COMMON /PAM/     PAMA,SIGNUM,RESTMS
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000)
*KEEP,PARPAR.
      COMMON /PARPAR/  CURPAR,SECPAR,PRMPAR,OUTPAR,C,
     *                 E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
      DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16),
     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH
      INTEGER          ITYPE,LEVL
*KEEP,PARPAE.
      DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM
     *                 ,WEIGHT
     *                 ,HAPP,COSTAP,COSTEA
      EQUIVALENCE      (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE),
     *                 (CURPAR(4), PHI   ), (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)
*KEEP,POLAR.
      COMMON /POLAR/   POLART,POLARF
      DOUBLE PRECISION POLART,POLARF
*KEEP,RANDPA.
      COMMON /RANDPA/  FAC,U1,U2,RD,NSEQ,ISEED,KNOR
      DOUBLE PRECISION FAC,U1,U2
      REAL             RD(3000)
      INTEGER          ISEED(103,10),NSEQ
      LOGICAL          KNOR
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEND.

      DOUBLE PRECISION BETA3,COSTCM,COSTH3,GAMMA3,GAMMA4,PHI3,RA,
     *                 WORK1,WORK2
      INTEGER          I,ICHARG,IGO,M3
      SAVE
C-----------------------------------------------------------------------

      IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=1,9)
  444 FORMAT(' KDECAY: CURPAR=',1P,9E10.3)

C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  DECAY OF K(+,-) (6 MODES)

      IF     ( IGO .LE. 2 ) THEN
   21   CALL RMMAR( 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 RMMAR( RD,2,1 )
          COSTCM = RD(1) * 2.D0 - 1.D0
C  MU(+,-)
          GAMMA3 = WORK1 + COSTCM * WORK2
          BETA3  = SQRT( 1.D0 - 1.D0 / GAMMA3**2 )
          COSTH3 = MIN( 1.D0, (GAMMA * GAMMA3 - CKA(28))
     *                   / (BETA * GAMMA * BETA3 * GAMMA3) )
          PHI3   = RD(2) * PI2
          CALL ADDANG( COSTHE,PHI, COSTH3,PHI3, SECPAR(3),SECPAR(4) )
          IF ( SECPAR(3) .GT. C(29) ) THEN
            SECPAR(1) = 4 + IGO
            SECPAR(2) = 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
            CALL ADDANG( SECPAR(3),SECPAR(4), 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 ENERGY TO LONGITUDINAL ENERGY DEPOSIT
              DLONG(LHEIGH,5) = DLONG(LHEIGH,5) + GAMMA3 * PAMA(5)
            ENDIF
          ENDIF
          IF ( LLONGI ) THEN
C  ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT
            GAMMA4 = PAMA(11) * GAMMA - PAMA(5) * GAMMA3
            DLONG(LHEIGH,8) = DLONG(LHEIGH,8) + GAMMA4
          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 230  I = 1,3
            CALL ADDANG( COSTHE,PHI, COS345(I),PHI345(I),
     *                                 SECPAR(3),SECPAR(4) )
            IF ( SECPAR(3) .GT. C(29) ) THEN
              IF ( I .EQ. 3 ) THEN
                SECPAR(1) = 10 - IGO
              ELSE
                SECPAR(1) =  7 + IGO
              ENDIF
              SECPAR(2) = GAM345(I)
              CALL TSTACK
            ELSE
              IF ( LLONGI ) THEN
C  ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT
                DLONG(LHEIGH,7) = DLONG(LHEIGH,7) + GAM345(I) * PAMA(8)
              ENDIF
            ENDIF
  230     CONTINUE

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 )
C  PI(0)  AND  E(+,-) / NEUTRINO IS DROPPED
          DO 250  I = 1,2
            CALL ADDANG( COSTHE,PHI, COS345(I),PHI345(I),
     *                                  SECPAR(3),SECPAR(4) )
            IF ( SECPAR(3) .GT. C(29) ) THEN
              IF ( I .EQ. 1 ) THEN
                SECPAR(1) = 7.D0
              ELSE
                SECPAR(1) = 1 + IGO
              ENDIF
              SECPAR(2) = GAM345(I)
              CALL TSTACK
            ELSE
              IF ( LLONGI ) THEN
C  ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT
                IF     ( I .EQ. 1 ) THEN
                  DLONG(LHEIGH,7) = DLONG(LHEIGH,7)+GAM345(1)*PAMA(7)
                ELSE
                  IF ( IGO .EQ. 1 ) THEN
                    DLONG(LHEIGH,3) = DLONG(LHEIGH,3)
     *                                + (GAM345(2)+1.D0) * PAMA(2)
                  ELSE
                    DLONG(LHEIGH,3) = DLONG(LHEIGH,3)
     *                                + (GAM345(2)-1.D0) * PAMA(2)
                  ENDIF
                ENDIF
              ENDIF
            ENDIF
  250     CONTINUE
          IF ( LLONGI ) THEN
C  ADD 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)
          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 )
C  PI(0)  AND  MU(+,-) / NEUTRINO IS DROPPED
          DO 260  I = 1,2
            CALL ADDANG( COSTHE,PHI, COS345(I),PHI345(I),
     *                                  SECPAR(3),SECPAR(4) )
            IF ( SECPAR(3) .GT. C(29) ) THEN
              SECPAR(2)   = GAM345(I)
              IF ( I .EQ. 1 ) THEN
                SECPAR(1) = 7.D0
              ELSE
                SECPAR(1) = 4 + IGO
                IF ( SECPAR(1) .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
                CALL ADDANG( SECPAR(3),SECPAR(4), 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,7) = DLONG(LHEIGH,7)+GAM345(2)*PAMA(7)
                 ELSE
                   DLONG(LHEIGH,5) = DLONG(LHEIGH,5)+GAM345(2)*PAMA(5)
                 ENDIF
              ENDIF
            ENDIF
  260     CONTINUE
          IF ( LLONGI ) THEN
C  ADD 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)
          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 270  I = 1,3
            IF ( I .EQ. 3 ) THEN
              SECPAR(1) = 7 + IGO
            ELSE
              SECPAR(1) = 7.D0
            ENDIF
            CALL ADDANG( COSTHE,PHI, COS345(I),PHI345(I),
     *                                  SECPAR(3),SECPAR(4) )
            IF ( SECPAR(3) .GT. C(29) ) THEN
              SECPAR(2) = GAM345(I)
              CALL TSTACK
            ELSE
              IF ( LLONGI ) THEN
C  ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT
                GAMMA4 = GAM345(I) * PAMA(NINT(SECPAR(1)))
                DLONG(LHEIGH,7) = DLONG(LHEIGH,7) + GAMMA4
              ENDIF
            ENDIF
  270     CONTINUE

        ENDIF

C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  DECAY OF K0S  (2 MODES)
      ELSEIF ( IGO .EQ. 3 ) THEN

        CALL RMMAR( RD,1,1 )
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 RMMAR( 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(2),0.D0,
     *                 CKA(71),CKA(72),0.D0, CKA(73), 4 )
          CALL RMMAR( RD,1,1 )
C  CHARGE ASYMMETRY PREFERS FORMATION OF PI(-)
          ICHARG = INT(1.5016 + RD(1))
C  PI(+,-)  AND  E(-,+) / NEUTRINO IS DROPPED
          DO 420  I = 1,2
            SECPAR(1) = 10 - 3*I - (2*I-3)*ICHARG
            CALL ADDANG( COSTHE,PHI, COS345(I),PHI345(I),
     *                                  SECPAR(3),SECPAR(4) )
            IF ( SECPAR(3) .GT. C(29) ) THEN
              SECPAR(2) = GAM345(I)
              CALL TSTACK
            ELSE
C  ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT
              IF ( LLONGI ) THEN
                 IF     ( I .EQ. 1 ) THEN
                   DLONG(LHEIGH,7) = DLONG(LHEIGH,7) + GAM345(1)*PAMA(8)
                 ELSE
                   IF ( SECPAR(1) .EQ. 2.D0 ) THEN
                     DLONG(LHEIGH,3) = DLONG(LHEIGH,3)
     *                                     + (GAM345(2)+1.D0) * PAMA(2)
                   ELSE
                     DLONG(LHEIGH,3) = DLONG(LHEIGH,3)
     *                                     + (GAM345(2)-1.D0) * PAMA(2)
                   ENDIF
                 ENDIF
              ENDIF
            ENDIF
  420     CONTINUE
          IF ( LLONGI ) THEN
C  ADD 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)
          ENDIF

C  DECAY   K0L  ---->  PI(+,-)  + MU(-,+) + NEUTRINO
        ELSEIF ( RA .LE. CKA(26) ) THEN
          CALL DECAY6( PAMA(10), PAMA(8),PAMA(5),0.D0,
     *                 CKA(74),CKA(75),0.D0, CKA(76), 3 )
          CALL RMMAR( RD,1,1 )
C  CHARGE ASYMMETRY PREFERS FORMATION OF PI(-)
          ICHARG = INT(1.5016 + RD(1))
C  PI(+,-)  AND  MU(-,+) / NEUTRINO IS DROPPED
          DO 430  I = 1,2
            CALL ADDANG( COSTHE,PHI, COS345(I),PHI345(I),
     *                                  SECPAR(3),SECPAR(4) )
            IF ( SECPAR(3) .GT. C(29) ) THEN
              SECPAR(2)   = GAM345(I)
              IF     ( I .EQ. 1 ) THEN
                SECPAR(1) = 7 + ICHARG
              ELSEIF ( I .EQ. 2 ) THEN
                SECPAR(1) = 7 - ICHARG
                IF ( SECPAR(1) .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
                CALL ADDANG( SECPAR(3),SECPAR(4), 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
                   DLONG(LHEIGH,7) = DLONG(LHEIGH,7) + GAM345(1)*PAMA(8)
                ELSE
                   DLONG(LHEIGH,5) = DLONG(LHEIGH,5) + GAM345(2)*PAMA(5)
                 ENDIF
              ENDIF
            ENDIF
  430     CONTINUE
          IF ( LLONGI ) THEN
C  ADD 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)
          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(1) = 7.D0
          DO 440  I = 1,3
            CALL ADDANG( COSTHE,PHI, COS345(I),PHI345(I),
     *                                  SECPAR(3),SECPAR(4) )
            IF ( SECPAR(3) .GT. C(29) ) THEN
              SECPAR(2) = GAM345(I)
              CALL TSTACK
            ELSE
              IF ( LLONGI ) THEN
C  ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT
                DLONG(LHEIGH,7) = DLONG(LHEIGH,7) + GAM345(I) * PAMA(7)
              ENDIF
            ENDIF
  440     CONTINUE

C  DECAY   K0L  ---->   PI(+) + PI(-) + PI(0)
        ELSE
          CALL DECAY6( PAMA(10), PAMA(8),PAMA(8),PAMA(7),
     *                 CKA(61),CKA(62),CKA(63), CKA(64), 1 )
C  PI(+)  AND  PI(-)  AND  PI(0)
          DO 450  I = 1,3
            CALL ADDANG( COSTHE,PHI, COS345(I),PHI345(I),
     *                                  SECPAR(3),SECPAR(4) )
            IF ( SECPAR(3) .GT. C(29) ) THEN
              IF ( I .EQ. 3 ) THEN
                SECPAR(1) = 7.D0
              ELSE
                SECPAR(1) = 7 + I
              ENDIF
              SECPAR(2) = GAM345(I)
              CALL TSTACK
            ELSE
              IF ( LLONGI ) THEN
C  ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT
                IF ( I .EQ. 3 ) THEN
                  DLONG(LHEIGH,7) = DLONG(LHEIGH,7) + GAM345(I)*PAMA(7)
                ELSE
                  DLONG(LHEIGH,7) = DLONG(LHEIGH,7) + GAM345(I)*PAMA(8)
                ENDIF
              ENDIF
            ENDIF
  450     CONTINUE

        ENDIF
      ENDIF

C  KILL CURRENT PARTICLE
      IRET1 = 1

      RETURN
      END
*CMZ :          27/02/2002  16.27.13  by  D. HECK IK FZK KARLSRUHE
*-- Author :    The CORSIKA development group   16/05/95
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 PARAMETERSTHE 6 PARAMETER
C   CHI2   = CHI SQUARED
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,CURVE.
      COMMON /CURVE/   CHAPAR,DEP,ERR,NSTP
      DOUBLE PRECISION CHAPAR(1200),DEP(1200),ERR(1200)
      INTEGER          NSTP
*KEEP,PARPAR.
      COMMON /PARPAR/  CURPAR,SECPAR,PRMPAR,OUTPAR,C,
     *                 E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
      DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16),
     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH
      INTEGER          ITYPE,LEVL
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEND.

      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
      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. CHI2 ) THEN
            DO 8 I=1,NPAR-2
              FPARAM1(I) = P1(1,I)
 8          CONTINUE
            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
*CMZ :          27/02/2002  16.27.13  by  D. HECK IK FZK KARLSRUHE
*-- Author :    K. BERNLOEHR MPIK HEIDELBERG    15/06/98
C=======================================================================

      SUBROUTINE LOWUP(CHAR)

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
C  REDESIGN : K. BERNLOEHR MPIK HEIDELBERG     1998
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
*CMZ :          28/02/2002  13.12.11  by  D. HECK IK FZK KARLSRUHE
*-- Author :    D. HECK IK3 FZK KARLSRUHE       15/10/96
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
*CMZ :          18/10/2000  09.15.11  by  D. HECK IK3 FZK KARLSRUHE
*-- Author :    D. HECK IK3 FZK KARLSRUHE       15/10/96
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
C
C  REDESIGN: D. HECK    IK3  FZK KARLSRUHE
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,CONSTA.
      COMMON /CONSTA/  PI,PI2,OB3,TB3,ENEPER
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER
*KEEP,MUMULT.
      COMMON /MUMULT/  CHC,OMC,PHISCT,STEPL,VSCAT,FMOLI
      DOUBLE PRECISION CHC,OMC,PHISCT,STEPL,VSCAT
      LOGICAL          FMOLI
*KEEP,PAM.
      COMMON /PAM/     PAMA,SIGNUM,RESTMS
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000)
*KEEP,PARPAR.
      COMMON /PARPAR/  CURPAR,SECPAR,PRMPAR,OUTPAR,C,
     *                 E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
      DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16),
     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH
      INTEGER          ITYPE,LEVL
*KEEP,PARPAE.
      DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM
     *                 ,WEIGHT
     *                 ,HAPP,COSTAP,COSTEA
      EQUIVALENCE      (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE),
     *                 (CURPAR(4), PHI   ), (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)
*KEEP,RANDPA.
      COMMON /RANDPA/  FAC,U1,U2,RD,NSEQ,ISEED,KNOR
      DOUBLE PRECISION FAC,U1,U2
      REAL             RD(3000)
      INTEGER          ISEED(103,10),NSEQ
      LOGICAL          KNOR
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEND.

      DOUBLE PRECISION TINT(40),B,BINV,CHIC,CNST,DB,DENS,OMEGA,SINTH,
     *                 TEST,TMP
      REAL             ARG(4),F0I(40),F1I(40),F2I(40),
     *                 THRED(40),VAL(4),F,THRI,XINT
      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 10  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
 10   CONTINUE
      RETURN
 20   CONTINUE
      IF ( B .LE. 0.D0 ) RETURN
C  CHC IS DEFINED DIFFERENTLY FROM GEANT
      CHIC = CHC*SQRT(CHI)/(PAMA(5)*GAMMA*BETA**2)
      BINV = 1.D0/B
      TINT(1) = 0.D0
      DO 30   JA = 2,4
        TINT(JA) = F0I(JA) + ( F1I(JA) + F2I(JA)*BINV ) * BINV
 30   CONTINUE
      NMAX = 4
 40   CONTINUE
      CALL RMMAR(RD,2,1)
      XINT = RD(2)
      DO 50  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
 50   CONTINUE
      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 70  M = 1,4
        NA3M   = NA3 + M
        ARG(M) = TINT(NA3M)
        VAL(M) = THRED(NA3M)**2
 70   CONTINUE
      F = THRED(NA) * .02D0
      CALL MMOL4(THRI,XINT,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
*CMZ :          18/10/2000  09.15.11  by  D. HECK IK3 FZK KARLSRUHE
*-- Author :    D. HECK IK3 FZK KARLSRUHE       15/10/96
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
C  REDESIGN: D. HECK    IK3  FZK KARLSRUHE
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,CONSTA.
      COMMON /CONSTA/  PI,PI2,OB3,TB3,ENEPER
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER
*KEEP,RANDPA.
      COMMON /RANDPA/  FAC,U1,U2,RD,NSEQ,ISEED,KNOR
      DOUBLE PRECISION FAC,U1,U2
      REAL             RD(3000)
      INTEGER          ISEED(103,10),NSEQ
      LOGICAL          KNOR
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEND.

      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 RMMAR(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 RMMAR(RD,2,1)
          RR = SQRT( (-2.D0)*LOG(RD(1)) )
          X  = RR * COS( PI2 * RD(2) )
          AN = MIN( MAX( AMEAN+X*SQRT(AMEAN), 0.D0 ), HMXINT )
        ENDIF
      ENDIF
 20   NPRAN = AN

      RETURN
      END
*CMZ :          28/02/2002  13.12.11  by  D. HECK IK FZK KARLSRUHE
*-- Author :    D. HECK IK3 FZK KARLSRUHE       25/09/96
C=======================================================================

      SUBROUTINE MUBREM

C-----------------------------------------------------------------------
C  MU(ON) BREM(SSTRAHLUNG)
C
C  TREATES MUON BREMSSTRAHLUNG (WITHOUT POLARISATION EFFECTS)
C  IN ANALOGY WITH SUBROUT. GBREMM FROM GEANT WRITTEN BY L. URBAN
C  EXPLANATIONS SEE CERN PROGRM LIBRARY LONG WRITEUP W5013
C  THIS SUBROUTINE IS CALLED FROM MUTRAC.
C
C  DESIGN  : D. HECK    IK3  FZK KARLSRUHE
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,CONSTA.
      COMMON /CONSTA/  PI,PI2,OB3,TB3,ENEPER
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER
*KEEP,ELABCT.
      COMMON /ELABCT/  ELCUT
      DOUBLE PRECISION ELCUT(4)
*KEEP,GENER.
      COMMON /GENER/   GEN,ALEVEL
      DOUBLE PRECISION GEN,ALEVEL
*KEEP,LONGI.
      COMMON /LONGI/   ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP,LLONGI,FLGFIT
      DOUBLE PRECISION ADLONG(0:1170,9),AELONG(0:1170,9),
     *                 APLONG(0:1170,9),DLONG(0:1170,9),ELONG(0:1170,9),
     *                 HLONG(0:1170),PLONG(0:1170,9),SDLONG(0:1170,9),
     *                 SELONG(0:1170,9),SPLONG(0:1170,9),THSTEP,THSTPI
      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT
*KEEP,MUPART.
      COMMON /MUPART/  AMUPAR,BCUT,CMUON,FMUBRM,FMUORG
      DOUBLE PRECISION AMUPAR(16),BCUT,CMUON(11)
      LOGICAL          FMUBRM,FMUORG
*KEEP,PAM.
      COMMON /PAM/     PAMA,SIGNUM,RESTMS
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000)
*KEEP,PARPAR.
      COMMON /PARPAR/  CURPAR,SECPAR,PRMPAR,OUTPAR,C,
     *                 E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
      DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16),
     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH
      INTEGER          ITYPE,LEVL
*KEEP,PARPAE.
      DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM
     *                 ,WEIGHT
     *                 ,HAPP,COSTAP,COSTEA
      EQUIVALENCE      (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE),
     *                 (CURPAR(4), PHI   ), (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)
*KEEP,POLAR.
      COMMON /POLAR/   POLART,POLARF
      DOUBLE PRECISION POLART,POLARF
*KEEP,RANDPA.
      COMMON /RANDPA/  FAC,U1,U2,RD,NSEQ,ISEED,KNOR
      DOUBLE PRECISION FAC,U1,U2
      REAL             RD(3000)
      INTEGER          ISEED(103,10),NSEQ
      LOGICAL          KNOR
*KEEP,REST.
      COMMON /REST/    CONTNE,TAR,LT
      DOUBLE PRECISION CONTNE(3),TAR
      INTEGER          LT
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEND.

      DOUBLE PRECISION ALFA1,BETA1,COSTH3,CREJ,D,F1,
     *                 EKIN,EMUON,PHI3,SCREJ,SINTH3,THETA3,U,UMAX,
     *                 V,VC,VM,V1,W1,Z,THICK
      INTEGER          I
      SAVE
      EXTERNAL         THICK
      DATA             ALFA1/0.625D0/
C-----------------------------------------------------------------------

      IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=1,9)
  444 FORMAT(' MUBREM: CURPAR=',1P,9E10.3)

C  COPY VERTEX COORDINATES TO SECPAR
      DO 11  I = 5,8
        SECPAR(I) = CURPAR(I)
 11   CONTINUE
      SECPAR( 9)  = GEN
      SECPAR(14)  = CURPAR(14)
      SECPAR(15)  = CURPAR(15)
      SECPAR(16)  = CURPAR(16)
      IF ( LLONGI ) LHEIGH = INT(THICK(H)*THSTPI + 1.D0)

C  TOTAL AND KINETIC ENERGY OF MUON
      EMUON = PAMA(5) * GAMMA
      EKIN  = EMUON - PAMA(5)
      IF ( EKIN .LE. BCUT ) THEN
C   MUON ENERGY IS TOO LOW TO PRODUCE BREMSSTRAHLUNG
        SECPAR(2) = CURPAR(2)
        GOTO 900
      ENDIF
      VC = BCUT/EMUON
      VM = 1.D0 - CMUON(6+LT)/EMUON
      IF ( VM .LE. 0.D0 ) THEN
C  MAXIMUM OF BREMSSTRAHLUNG SPECTRUM IS NEGATIVE, NO BREMSSTRAHLUNG
        SECPAR(2) = CURPAR(2)
        GOTO 900
      ENDIF
      CREJ  = CMUON(3+LT)/EMUON

  50  CALL RMMAR(RD,2,1)
      V     = VC*(VM/VC)**RD(1)
      V1    = 1.D0 - V
C  COMPUTE REJECTION FUNCTION
      F1    = CMUON(LT) - LOG(1.D0 + CREJ*V/V1)
      SCREJ = (V1 + 0.75D0*V*V)*F1/CMUON(LT)
      IF ( RD(2) .GT. SCREJ ) GOTO 50

C  PHOTON ENERGY
      SECPAR(2) = EMUON * V

C  RADIATED GAMMA BELOW CUT?
      IF ( SECPAR(2) .LE. ELCUT(4) ) THEN
        IF ( LLONGI ) THEN
C  ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT
          DLONG(LHEIGH,1) = DLONG(LHEIGH,1) + SECPAR(2)
        ENDIF
C  REDUCE ENERGY OF MUON
        GOTO 800
      ENDIF

C  SET MATERIAL CONSTANTS CMUON(.) ACCORDING TO
C  TARGET INDEX LT (1=N, 2=O, 3=AR)  WHICH HAS BEEN SET IN BOX2
      IF     ( LT .EQ. 1 ) THEN
        Z = 7.D0
      ELSEIF ( LT .EQ. 2 ) THEN
        Z = 8.D0
      ELSE
        Z = 18.D0
      ENDIF

C  GENERATE EMITTED PHOTON 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/EMUON) * (1.D0 + V)
      W1   = 9.D0 / (9.D0 + D)
      UMAX = EMUON * PI / PAMA(5)
10    CALL RMMAR(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) / EMUON
      COSTH3 = COS( THETA3 )
      SINTH3 = SIN( THETA3 )
      CALL RMMAR(RD,1,1)

      PHI3   = PI2 * RD(1)
      CALL ADDANG( COSTHE,PHI, COSTH3,PHI3, SECPAR(3),SECPAR(4))
      IF ( SECPAR(3) .GT. C(29) ) THEN
C  WRITE BREMSSTRAHLUNG PHOTON TO STACK
        SECPAR( 1) = 1.D0
        SECPAR(10) = H
        CALL TSTACK
      ELSE
        IF ( LLONGI ) THEN
C  ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT
          DLONG(LHEIGH,1) = DLONG(LHEIGH,1) + SECPAR(2)
        ENDIF

      ENDIF

C  REDUCE ENERGY OF MUON
 800  CONTINUE
      EMUON     = EMUON * V1
      SECPAR(2) = EMUON/PAMA(5)

 900  CONTINUE
C  WRITE MUON TO STACK
      SECPAR( 1) = CURPAR(1)
      SECPAR( 3) = CURPAR(3)
      SECPAR( 4) = CURPAR(4)
      SECPAR(10) = ALEVEL
      CALL TSTACK

      RETURN
      END
*CMZ :          18/10/2000  09.15.11  by  D. HECK IK3 FZK KARLSRUHE
*-- Author :    D. HECK IK3 FZK KARLSRUHE       15/10/96
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
C
C  REDESIGN: D. HECK    IK3  FZK KARLSRUHE
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,CONSTA.
      COMMON /CONSTA/  PI,PI2,OB3,TB3,ENEPER
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER
*KEEP,MUMULT.
      COMMON /MUMULT/  CHC,OMC,PHISCT,STEPL,VSCAT,FMOLI
      DOUBLE PRECISION CHC,OMC,PHISCT,STEPL,VSCAT
      LOGICAL          FMOLI
*KEEP,PAM.
      COMMON /PAM/     PAMA,SIGNUM,RESTMS
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000)
*KEEP,PARPAR.
      COMMON /PARPAR/  CURPAR,SECPAR,PRMPAR,OUTPAR,C,
     *                 E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
      DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16),
     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH
      INTEGER          ITYPE,LEVL
*KEEP,PARPAE.
      DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM
     *                 ,WEIGHT
     *                 ,HAPP,COSTAP,COSTEA
      EQUIVALENCE      (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE),
     *                 (CURPAR(4), PHI   ), (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)
*KEEP,RANDPA.
      COMMON /RANDPA/  FAC,U1,U2,RD,NSEQ,ISEED,KNOR
      DOUBLE PRECISION FAC,U1,U2
      REAL             RD(3000)
      INTEGER          ISEED(103,10),NSEQ
      LOGICAL          KNOR
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEND.

      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 RMMAR(RD,2*NSCA,1)

C  THMIN2 IS THE SCREENING ANGLE
      THMIN2 = CHC**2/( OMCF*OMC * (PAMA(5)*BETA*GAMMA)**2 )

      SUMX = 0.D0
      SUMY = 0.D0
      DO 12  I = 1,NSCA
        THET  = SQRT( THMIN2*((1./RD(I)) - 1.) )
        PHIS  = PI2 * RD(NSCA+I)
        SUMX  = SUMX + THET*COS(PHIS)
        SUMY  = SUMY + THET*SIN(PHIS)
 12   CONTINUE
      VSCAT  = SQRT(SUMX**2 + SUMY**2)

      RETURN
      END
*CMZ :          28/02/2002  13.12.11  by  D. HECK IK FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
C=======================================================================

      SUBROUTINE MUDECY

C-----------------------------------------------------------------------
C  MU(ON) DEC(A)Y
C
C  TREATES DECAY OF MUON INTO ELECTRON (INCLUDING POLARISATION EFFECTS)
C  INCLUDING NEUTRINOS, IF SELECTED
C  THIS SUBROUTINE IS CALLED FROM MUTRAC.
C
C  DESIGN  : D. HECK    IK3  FZK KARLSRUHE
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,CONSTA.
      COMMON /CONSTA/  PI,PI2,OB3,TB3,ENEPER
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER
*KEEP,GENER.
      COMMON /GENER/   GEN,ALEVEL
      DOUBLE PRECISION GEN,ALEVEL
*KEEP,LONGI.
      COMMON /LONGI/   ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP,LLONGI,FLGFIT
      DOUBLE PRECISION ADLONG(0:1170,9),AELONG(0:1170,9),
     *                 APLONG(0:1170,9),DLONG(0:1170,9),ELONG(0:1170,9),
     *                 HLONG(0:1170),PLONG(0:1170,9),SDLONG(0:1170,9),
     *                 SELONG(0:1170,9),SPLONG(0:1170,9),THSTEP,THSTPI
      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT
*KEEP,PAM.
      COMMON /PAM/     PAMA,SIGNUM,RESTMS
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000)
*KEEP,PARPAR.
      COMMON /PARPAR/  CURPAR,SECPAR,PRMPAR,OUTPAR,C,
     *                 E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
      DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16),
     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH
      INTEGER          ITYPE,LEVL
*KEEP,PARPAE.
      DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM
     *                 ,WEIGHT
     *                 ,HAPP,COSTAP,COSTEA
      EQUIVALENCE      (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE),
     *                 (CURPAR(4), PHI   ), (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)
*KEEP,POLAR.
      COMMON /POLAR/   POLART,POLARF
      DOUBLE PRECISION POLART,POLARF
*KEEP,RANDPA.
      COMMON /RANDPA/  FAC,U1,U2,RD,NSEQ,ISEED,KNOR
      DOUBLE PRECISION FAC,U1,U2
      REAL             RD(3000)
      INTEGER          ISEED(103,10),NSEQ
      LOGICAL          KNOR
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEND.

      DOUBLE PRECISION AUX2,COSDE,COSTH3,COS3CM,COS3C1,COS3C2,
     *                 E3CM,GAMMA3,GAMMA4,PHI3CM,PHI3C2,PHI31,
     *                 P3CM,THICK,XI
      INTEGER          I
      SAVE
      EXTERNAL         THICK
C-----------------------------------------------------------------------

      IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=1,9)
  444 FORMAT(' MUDECY: CURPAR=',1P,9E10.3)

C  COPY VERTEX COORDINATES TO SECPAR
      DO  4  I = 5,8
        SECPAR(I) = CURPAR(I)
   4  CONTINUE
      SECPAR( 9)  = GEN
      SECPAR(10)  = ALEVEL
      SECPAR(14)  = CURPAR(14)
      SECPAR(15)  = CURPAR(15)
      SECPAR(16)  = CURPAR(16)
      IF ( LLONGI ) LHEIGH = INT(THICK(H)*THSTPI + 1.D0)

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  CALL RMMAR( RD,4,1 )
      IF ( RD(1)**2*(3.-RD(1)*2.)  .LT.  RD(2) )  RD(1) = 1.-RD(1)
      E3CM   = PAMA(2) + RD(1) * ( C(8) - PAMA(2) )
      IF ( E3CM .GT. 0.5D0*PAMA(5) ) GOTO 6
      P3CM   = SQRT( E3CM**2 - PAMA(2)**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. - 2.*RD(1) ) / ( 3. - 2.*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

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
      CALL ADDANI( CURPAR(3),CURPAR(4), 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**2 - 1.D0)) )
      CALL ADDANG( CURPAR(3),CURPAR(4), COSTH3,PHI3CM,
     *                                    SECPAR(3),SECPAR(4) )
      IF ( SECPAR(3) .GT. C(29) ) THEN
        SECPAR(1) = ITYPE - 3
        SECPAR(2) = GAMMA3
        CALL TSTACK
      ELSE
        IF ( LLONGI ) THEN
C  ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT
          IF ( ITYPE .EQ. 5 ) THEN
            DLONG(LHEIGH,3) = DLONG(LHEIGH,3) + (GAMMA3+1.D0) * PAMA(2)
          ELSE
            DLONG(LHEIGH,3) = DLONG(LHEIGH,3) + (GAMMA3-1.D0) * PAMA(2)
          ENDIF
        ENDIF
      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
      ENDIF

      RETURN
      END
*CMZ :          05/07/2001  13.19.11  by  D. HECK IK FZK KARLSRUHE
*-- Author :    D. HECK IK3 FZK KARLSRUHE       04/10/96
C=======================================================================

      SUBROUTINE MUPRPR

C-----------------------------------------------------------------------
C  MU(ON) P(AI)R PR(ODUCTION)
C
C  TREATES MUON PAIR PRODUCTION (WITHOUT POLARISATION EFFECTS)
C  IN ANALOGY WITH SUBROUTINE SUBROUT. FROM GEANT WRITTEN BY L. URBAN
C  EXPLANATIONS SEE CERN PROGRM LIBRARY LONG WRITEUP W5013
C  THIS SUBROUTINE IS CALLED FROM MUTRAC.
C
C  DESIGN  : D. HECK    IK3  FZK KARLSRUHE
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,CONSTA.
      COMMON /CONSTA/  PI,PI2,OB3,TB3,ENEPER
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER
*KEEP,ELABCT.
      COMMON /ELABCT/  ELCUT
      DOUBLE PRECISION ELCUT(4)
*KEEP,GENER.
      COMMON /GENER/   GEN,ALEVEL
      DOUBLE PRECISION GEN,ALEVEL
*KEEP,LONGI.
      COMMON /LONGI/   ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP,LLONGI,FLGFIT
      DOUBLE PRECISION ADLONG(0:1170,9),AELONG(0:1170,9),
     *                 APLONG(0:1170,9),DLONG(0:1170,9),ELONG(0:1170,9),
     *                 HLONG(0:1170),PLONG(0:1170,9),SDLONG(0:1170,9),
     *                 SELONG(0:1170,9),SPLONG(0:1170,9),THSTEP,THSTPI
      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT
*KEEP,MUPART.
      COMMON /MUPART/  AMUPAR,BCUT,CMUON,FMUBRM,FMUORG
      DOUBLE PRECISION AMUPAR(16),BCUT,CMUON(11)
      LOGICAL          FMUBRM,FMUORG
*KEEP,PAM.
      COMMON /PAM/     PAMA,SIGNUM,RESTMS
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000)
*KEEP,PARPAR.
      COMMON /PARPAR/  CURPAR,SECPAR,PRMPAR,OUTPAR,C,
     *                 E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
      DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16),
     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH
      INTEGER          ITYPE,LEVL
*KEEP,PARPAE.
      DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM
     *                 ,WEIGHT
     *                 ,HAPP,COSTAP,COSTEA
      EQUIVALENCE      (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE),
     *                 (CURPAR(4), PHI   ), (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)
*KEEP,POLAR.
      COMMON /POLAR/   POLART,POLARF
      DOUBLE PRECISION POLART,POLARF
*KEEP,RANDPA.
      COMMON /RANDPA/  FAC,U1,U2,RD,NSEQ,ISEED,KNOR
      DOUBLE PRECISION FAC,U1,U2
      REAL             RD(3000)
      INTEGER          ISEED(103,10),NSEQ
      LOGICAL          KNOR
*KEEP,REST.
      COMMON /REST/    CONTNE,TAR,LT
      DOUBLE PRECISION CONTNE(3),TAR
      INTEGER          LT
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEND.

      DOUBLE PRECISION AA,ALE,ALFA,AL10T,A1,A1R,B,BETA1,CC,C1,C2,
     *                 COSTH3,EKIN,EMUON,ENEG,EPOS,EPP,
     *                 PHI3,R0,R0MAX,SCREJ,THICK,
     *                 V,VC,VMAX,VMIN,V0,Z
      INTEGER          I
      SAVE
      EXTERNAL         THICK
      DATA             AL10T/9.212D0/
C-----------------------------------------------------------------------

      IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=1,9)
  444 FORMAT(' MUPRPR: CURPAR=',1P,9E10.3)

C  COPY VERTEX COORDINATES TO SECPAR
      DO 11  I = 5,8
        SECPAR(I) = CURPAR(I)
 11   CONTINUE
      SECPAR( 9) = GEN
      SECPAR(14)  = CURPAR(14)
      SECPAR(15)  = CURPAR(15)
      SECPAR(16)  = CURPAR(16)
      IF ( LLONGI ) LHEIGH = INT(THICK(H)*THSTPI + 1.D0)

C  SET MATERIAL CONSTANTS CMUON(.) ACCORDING TO
C  TARGET INDEX LT (1=N, 2=O, 3=AR)  WHICH HAS BEEN SET IN BOX2
      IF     ( LT .EQ. 1 ) THEN
        Z = 7.D0
      ELSEIF ( LT .EQ. 2 ) THEN
        Z = 8.D0
      ELSE
        Z = 18.D0
      ENDIF
C  TOTAL AND KINETIC ENERGY OF MUON
      EMUON = PAMA(5) * GAMMA
      EKIN  = EMUON - PAMA(5)
      IF ( EKIN .LE. BCUT ) GOTO 900
C
      VMIN  = 4.D0 * PAMA(2) / EMUON
      VMAX  = 1.D0 - CMUON(10) * Z**OB3 / EMUON
      IF ( VMAX .LE. VMIN ) GOTO 900
      VC    = BCUT / EMUON
      ALE   = LOG(EMUON)
      ALFA  = 1.D0 + ALE/AL10T
      V0    = 0.18D0 * (4.D0 + ALE/AL10T) * ALFA * (ALFA*VMIN)**TB3
      BETA1 = 0.1D0 * (1.D0 + 3.D0 * ALE/AL10T)
      B     = 0.9D0 / (1.D0 + 0.4D0*ALE + 0.022D0*ALE**2)
      AA    = 1.D0 + 2.D0 * B * LOG(VC/V0)
      IF ( AA .LE. 1.D0 ) AA = 1.05D0
      A1    = 1.D0 - AA
      CC    = EXP((-0.25D0)*A1*A1/B)
      A1R   = 1.D0 / A1
      C1    = VMAX**A1
      C2    = VC**A1
C  SAMPLE ENERGY FRACTION V AND RO
 50   CALL RMMAR(RD,2,1)
      V     = ( RD(1)*C1 + (1.-RD(1))*C2 )**A1R
      IF ( V .LE. VMIN ) GOTO 50
      IF ( V .LT. V0 ) THEN
        SCREJ = CC * ( (V-VMIN)/(V0-VMIN) )**BETA * (V0/V)**A1
      ELSE
        SCREJ = CC * (V0/V)**( A1 + B*LOG(V/V0) )
      ENDIF
      IF ( RD(2) .GT. SCREJ ) GOTO 50
      R0MAX = SCREJ * ( 1.D0 - 6.D0 *PAMA(5)/( EMUON**2 * (1.D0-V) ) )
      CALL RMMAR(RD,2,1)
      R0    = R0MAX * (2.*RD(1)-1.)
C  ENERGIES
      EPP    = V * EMUON
      EPOS   = 0.5D0 * EPP * (1.D0 + R0)
      ENEG   = EPP - EPOS
C  ANGLES
      COSTH3 = COS( PAMA(5)/EMUON )
      PHI3   = PI2 * RD(2)
C  POSITRON
      IF ( EPOS .GT. BCUT+PAMA(2) ) THEN
        CALL ADDANG( COSTHE,PHI, COSTH3,PHI3, SECPAR(3),SECPAR(4) )
        IF ( SECPAR(3) .GT. C(29) ) THEN
          SECPAR( 1) = 2.D0
          SECPAR( 2) = EPOS/PAMA(2)
          SECPAR(10) = H
          CALL TSTACK
        ELSE
          IF ( LLONGI ) THEN
C  ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT
            DLONG(LHEIGH,3) = DLONG(LHEIGH,3) + EPOS + PAMA(2)
          ENDIF
        ENDIF
      ELSE
        IF ( LLONGI ) THEN
C  ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT
          DLONG(LHEIGH,3) = DLONG(LHEIGH,3) + EPOS + PAMA(2)
        ENDIF
      ENDIF
C  ELECTRON
      IF ( ENEG .GT. BCUT+PAMA(2) ) THEN
        CALL ADDANG( COSTHE,PHI, COSTH3,-PHI3, SECPAR(3),SECPAR(4) )
        IF ( SECPAR(3) .GT. C(29) ) THEN
          SECPAR( 1) = 3.D0
          SECPAR( 2) = ENEG/PAMA(2)
          SECPAR(10) = H
          CALL TSTACK
        ELSE
          IF ( LLONGI ) THEN
C  ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT
            DLONG(LHEIGH,3) = DLONG(LHEIGH,3) + ENEG - PAMA(2)
          ENDIF
        ENDIF
      ELSE
        IF ( LLONGI ) THEN
C  ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT
          DLONG(LHEIGH,3) = DLONG(LHEIGH,3) + ENEG - PAMA(2)
        ENDIF
      ENDIF
C  REDUCE ENERGY OF MUON
 60   CONTINUE
      GAMMA = (EMUON - EPP)/ PAMA(5)

 900  CONTINUE
C  WRITE MUON TO STACK
      SECPAR( 1) = CURPAR(1)
      SECPAR( 2) = GAMMA
      SECPAR( 3) = CURPAR(3)
      SECPAR( 4) = CURPAR(4)
      SECPAR(10) = ALEVEL
      CALL TSTACK

      RETURN
      END
*CMZ :          05/03/2002  08.29.07  by  D. HECK IK FZK KARLSRUHE
*-- Author :    D. HECK IK3 FZK KARLSRUHE       25/09/96
C=======================================================================

      SUBROUTINE MUTRAC(fmfb)

C-----------------------------------------------------------------------
C  MU(ON) TRAC(KING)
C
C  TRACKS THE MUON REGARDING MAX. STEP LENGTH FOR MULTIPLE SCATTERING
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
C  DESIGN  : D. HECK    IK3  FZK KARLSRUHE
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,GENER.
      COMMON /GENER/   GEN,ALEVEL
      DOUBLE PRECISION GEN,ALEVEL
*KEEP,IRET.
      COMMON /IRET/    IRET1,IRET2,IRETE
      INTEGER          IRET1,IRET2
      LOGICAL          IRETE
*KEEP,LONGI.
      COMMON /LONGI/   ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP,LLONGI,FLGFIT
      DOUBLE PRECISION ADLONG(0:1170,9),AELONG(0:1170,9),
     *                 APLONG(0:1170,9),DLONG(0:1170,9),ELONG(0:1170,9),
     *                 HLONG(0:1170),PLONG(0:1170,9),SDLONG(0:1170,9),
     *                 SELONG(0:1170,9),SPLONG(0:1170,9),THSTEP,THSTPI
      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT
*KEEP,MUMULT.
      COMMON /MUMULT/  CHC,OMC,PHISCT,STEPL,VSCAT,FMOLI
      DOUBLE PRECISION CHC,OMC,PHISCT,STEPL,VSCAT
      LOGICAL          FMOLI
*KEEP,MUPART.
      COMMON /MUPART/  AMUPAR,BCUT,CMUON,FMUBRM,FMUORG
      DOUBLE PRECISION AMUPAR(16),BCUT,CMUON(11)
      LOGICAL          FMUBRM,FMUORG
*KEEP,NPARTI.
      COMMON /NPARTI/  NPARTO
      DOUBLE PRECISION NPARTO(10,25),NPHOTO(10),NPOSIT(10),NELECT(10),
     *                 NNU(10),NMUP(10),NMUM(10),NPI0(10),NPIP(10),
     *                 NPIM(10),NK0L(10),NKPL(10),NKMI(10),NNEUTR(10),
     *                 NPROTO(10),NPROTB(10),NK0S(10),NHYP(10),
     *                 NNEUTB(10),NDEUT(10),NTRIT(10),NALPHA(10),
     *                 NOTHER(10),NMUOND
      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),NALPHA(1)),
     *            (NPARTO(1,22),NOTHER(1)), (NPARTO(1,25),NNEUTB(1)),
     *            (NPARTO(1,23),NMUOND)
*KEEP,OBSPAR.
      COMMON /OBSPAR/  OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP,
     *                 THETPR,PHIPR,
     *                 VUECON,
     *                 NOBSLV
      DOUBLE PRECISION OBSLEV(10),THCKOB(10),XOFF(10),YOFF(10),
     *                 HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2)
      DOUBLE PRECISION VUECON(2)
      INTEGER          NOBSLV
*KEEP,PAM.
      COMMON /PAM/     PAMA,SIGNUM,RESTMS
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000)
*KEEP,PARPAR.
      COMMON /PARPAR/  CURPAR,SECPAR,PRMPAR,OUTPAR,C,
     *                 E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
      DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16),
     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH
      INTEGER          ITYPE,LEVL
*KEEP,PARPAE.
      DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM
     *                 ,WEIGHT
     *                 ,HAPP,COSTAP,COSTEA
      EQUIVALENCE      (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE),
     *                 (CURPAR(4), PHI   ), (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)
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEND.

      DOUBLE PRECISION AUX,CHITOT,STPTOT
      INTEGER          I,IRET3
      LOGICAL          FSCAT
      LOGICAL          FLAG
c-----changed--add
      logical fmfb
c-----changed--add
      SAVE
C-----------------------------------------------------------------------

      IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=1,9)
  444 FORMAT(' MUTRAC: CURPAR=',1P,9E10.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
      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
      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.
c-----changed--add
      CALL UPDATC(IRET3,FLAG,fmfb)
c-----changed--add
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  MUON CUTTED 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 FOR FURTHER TREATMENT
          DO   I = 1,8
            CURPAR(I) = OUTPAR(I)
          ENDDO
          BETA = SQRT( GAMMA**2 - 1.D0 ) / GAMMA
        ELSE
C  KILL PARTICLE AS IT IS AT DETECTOR LEVEL
          IRET1 = 1
          FMUORG = .FALSE.
          RETURN
        ENDIF
      ENDIF

      IF ( FDECAY ) THEN
C  MUON 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
        CALL MUDECY
        NMUOND  = NMUOND + 1.D0
        FMUORG = .FALSE.

      ELSE
C  MUON UNDERGOES BREMSSTR/PAIRPR AT END OF PATH
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 ( FMUBRM ) THEN
          CALL MUBREM
        ELSE
          CALL MUPRPR
        ENDIF
      ENDIF
      IRET1 = 1
      RETURN

 11   CONTINUE
      IF ( DEBUG ) WRITE(MDEBUG,457) (CURPAR(I),I=1,9)
 457  FORMAT(' MUTRAC: SCATTER',1P,9E10.3)
      GOTO 10

      END
*CMZ :          27/02/2002  16.27.13  by  D. HECK IK FZK KARLSRUHE
*-- Author :    F. SCHROEDER UNI WUPPERTAL      17/09/98
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
C
C  DESIGN  : F. SCHROEDER UNI WUPPERTAL
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,ATMOS2.
      COMMON /ATMOS2/  HLAY,HLAY0,THICKL,LAYNO,LAYNEW
      DOUBLE PRECISION HLAY(6),HLAY0(5,0:4),THICKL(5)
      INTEGER          LAYNO(0:16)
      LOGICAL          LAYNEW
*KEEP,OBSPAR.
      COMMON /OBSPAR/  OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP,
     *                 THETPR,PHIPR,
     *                 VUECON,
     *                 NOBSLV
      DOUBLE PRECISION OBSLEV(10),THCKOB(10),XOFF(10),YOFF(10),
     *                 HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2)
      DOUBLE PRECISION VUECON(2)
      INTEGER          NOBSLV
*KEEP,PARPAR.
      COMMON /PARPAR/  CURPAR,SECPAR,PRMPAR,OUTPAR,C,
     *                 E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
      DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16),
     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH
      INTEGER          ITYPE,LEVL
*KEEP,PARPAE.
      DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM
     *                 ,WEIGHT
     *                 ,HAPP,COSTAP,COSTEA
      EQUIVALENCE      (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE),
     *                 (CURPAR(4), PHI   ), (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)
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEND.

      DOUBLE PRECISION ARG,ARGNEW,COSDIF,COSPHI,COSTAPNEW,COSTHENEW,
     *                 DH,DISTN2,DISTO2,HOLD,HNEW,RADIUS,SIGNE,
     *                 SINPHI,SINTHENEW,THICK,TRANS,TRANSNEW,XNEW,YNEW
      SAVE
      EXTERNAL         THICK
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
      XNEW = X
      YNEW = Y
      COSPHI = COS( PHI )
      SINPHI = SIN( PHI )
      DISTN2 = XNEW**2 + YNEW**2
      COSTHENEW = COSTHE
      COSTAPNEW = COSTAP

C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  LOOP OVER PIECES OF ARG (EACH IN ITS LOCAL FLAT COORDINATE FRAME)
  2   CONTINUE
      SINTHENEW = SQRT( 1.D0 - COSTHENEW**2 )
      TRANS     = ARG * SINTHENEW
C  MAXIMAL HORIZONTAL STEP (DEPENDS ON THICKNESS AT PARTICLE ALTITUDE)
      TRANSNEW = MIN( TRANS, C(4) * THICKH + C(3) )
      IF (DEBUG) WRITE(MDEBUG,*) 'NRANGC: TRANSNEW=',SNGL(TRANSNEW)

      IF ( SINTHENEW .LE. 0.D0 ) THEN
C  PARTICLE TRACK IS VERTICAL
        ARGNEW = ARG
      ELSE
        ARGNEW = TRANSNEW / SINTHENEW
      ENDIF
      DH  = ARGNEW * COSTHENEW
      IF ( HNEW-DH .LE. HLAY(1) ) THEN
        CHI = CHI + (THICKL(1) - THICK(HNEW)) / COSTHENEW
        IF ( DEBUG ) WRITE(MDEBUG,*)
     *               'NRANGC: HNEW,CHI= ',SNGL(HLAY(1)),SNGL(CHI)
        RETURN
      ENDIF
      CHI = CHI + (THICK(HNEW-DH) - THICK(HNEW)) / COSTHENEW
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 WELL BELOW OBSERVATION LEVEL
        IF ( HNEW .LT. OBSLEV(1) - 1.D5 ) THEN
          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  DIRECTION OF PARTICLE RELATIVE TO DETECTOR CENTER
        DISTO2 = DISTN2
        IF ( COSDIF .LT. 1.D0 ) THEN
          RADIUS = ARGNEW * SQRT( (1.D0-COSTAPNEW**2)/(1.D0-COSDIF**2) )
     *                    * C(1) * ACOS(COSDIF)/(C(1)+HNEW)
        ELSE
          RADIUS = ARGNEW * SQRT( 1.D0-COSTAPNEW**2 )
        ENDIF
        XNEW   = XNEW + RADIUS * COSPHI
        YNEW   = YNEW + RADIUS * SINPHI
        DISTN2 = XNEW**2 + YNEW**2
        IF ( DISTO2 .GT. DISTN2 ) THEN
          SIGNE = +1.D0
        ELSE
          SIGNE = -1.D0
        ENDIF
C  COSINE OF NEW LOCAL ZENITH ANGLE
        COSTHENEW = MIN( 1.D0, ( COSTHENEW * COSDIF - SIGNE *
     *               SQRT( (1.D0-COSTHENEW**2) * (1.D0-COSDIF**2) ) ) )
        IF (DEBUG) WRITE(MDEBUG,*) 'NRANGC: COSTHENEW=',COSTHENEW
C  TERMINATE PROCESS IF PARTICLE BECOMES UPWARD GOING
        IF ( COSTHENEW .LE. C(29) ) RETURN
        GOTO 2
      ENDIF

      RETURN
      END
*CMZ :          03/09/2001  11.12.38  by  D. HECK IK FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
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
*KEEP,AIR.
      COMMON /AIR/     COMPOS,PROBTA,AVERAW,AVOGAD
      DOUBLE PRECISION COMPOS(3),PROBTA(3),AVERAW,AVOGAD
*KEEP,CONSTA.
      COMMON /CONSTA/  PI,PI2,OB3,TB3,ENEPER
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER
*KEEP,GENER.
      COMMON /GENER/   GEN,ALEVEL
      DOUBLE PRECISION GEN,ALEVEL
*KEEP,IRET.
      COMMON /IRET/    IRET1,IRET2,IRETE
      INTEGER          IRET1,IRET2
      LOGICAL          IRETE
*KEEP,KAONS.
      COMMON /KAONS/   CKA
      DOUBLE PRECISION CKA(80)
*KEEP,LONGI.
      COMMON /LONGI/   ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP,LLONGI,FLGFIT
      DOUBLE PRECISION ADLONG(0:1170,9),AELONG(0:1170,9),
     *                 APLONG(0:1170,9),DLONG(0:1170,9),ELONG(0:1170,9),
     *                 HLONG(0:1170),PLONG(0:1170,9),SDLONG(0:1170,9),
     *                 SELONG(0:1170,9),SPLONG(0:1170,9),THSTEP,THSTPI
      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT
*KEEP,MULT.
      COMMON /MULT/    EKINL,MSMM,MULTMA,MULTOT
      DOUBLE PRECISION EKINL
      INTEGER          MSMM,MULTMA(40,13),MULTOT(40,13)
*KEEP,PAM.
      COMMON /PAM/     PAMA,SIGNUM,RESTMS
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000)
*KEEP,PARPAR.
      COMMON /PARPAR/  CURPAR,SECPAR,PRMPAR,OUTPAR,C,
     *                 E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
      DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16),
     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH
      INTEGER          ITYPE,LEVL
*KEEP,PARPAE.
      DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM
     *                 ,WEIGHT
     *                 ,HAPP,COSTAP,COSTEA
      EQUIVALENCE      (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE),
     *                 (CURPAR(4), PHI   ), (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)
*KEEP,POLAR.
      COMMON /POLAR/   POLART,POLARF
      DOUBLE PRECISION POLART,POLARF
*KEEP,RANDPA.
      COMMON /RANDPA/  FAC,U1,U2,RD,NSEQ,ISEED,KNOR
      DOUBLE PRECISION FAC,U1,U2
      REAL             RD(3000)
      INTEGER          ISEED(103,10),NSEQ
      LOGICAL          KNOR
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEEP,SIGM.
      COMMON /SIGM/    SIGMA,SIGANN,SIGAIR,FRACTN,FRCTNO
      DOUBLE PRECISION SIGMA,SIGANN,SIGAIR,FRACTN,FRCTNO
*KEEP,STATI.
      COMMON /STATI/   SABIN,SBBIN,INBIN,IPBIN,IKBIN,IHBIN
      DOUBLE PRECISION SABIN(40),SBBIN(40)
      INTEGER          INBIN(40),IPBIN(40),IKBIN(40),IHBIN(40)
*KEEP,VKIN.
      COMMON /VKIN/    BETACM
      DOUBLE PRECISION BETACM
*KEND.

      DOUBLE PRECISION BETA3,COSMU,COSTCM,COSTH3,ETOT,GAMMA3,
     *                 PHIMU,PHI3,THICK,WORK1,WORK2
      INTEGER          I,IGO,KJ
      SAVE
      EXTERNAL         THICK
C-----------------------------------------------------------------------

      IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=1,9)
  444 FORMAT(' NUCINT: CURPAR=',1P,9E10.3)

C  COPY VERTEX COORDINATES INTO SECPAR
      DO 10  I = 5,8
        SECPAR(I) =  CURPAR(I)
 10   CONTINUE
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
      SECPAR(14) = CURPAR(14)
      SECPAR(15) = CURPAR(15)
      SECPAR(16) = CURPAR(16)
      THICKH = THICK(H)
      IF ( LLONGI ) LHEIGH = INT(THICKH * THSTPI + 1.D0)

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

C  DECAY OR INTERACTION FOR CHARGED PIONS ?
        IF ( FDECAY ) THEN
C  INCREMENT GENERATION COUNTER TO DIFFERENTIATE BETWEEN MUONS FROM
C  DECAYS (K-DECAY: GEN=NORMAL, PI-DECAY: GEN INCREASED BY 50)
          SECPAR( 9) = SECPAR( 9) + 50.D0
C  DECAY  PI(+,-)  ---->  MU(+,-) + (ANTI)-NEUTRINO(MU)
          WORK1  = C(48) * GAMMA
          WORK2  = C(49) * BETA * WORK1
          CALL RMMAR( RD,2,1 )
          COSTCM = 2.D0 * RD(1) - 1.D0
          GAMMA3 = WORK1 + COSTCM * WORK2
          BETA3  = SQRT( 1.D0 - 1.D0 / GAMMA3**2 )
          COSTH3 = MIN( 1.D0, ( GAMMA * GAMMA3 - C(48) )
     *                      /( BETA * GAMMA * BETA3 * GAMMA3 ) )
          PHI3   = PI2 * RD(2)
C  NEUTRINO IS DROPPED
          IF ( LLONGI ) THEN
C  ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT
            SECPAR(2) = PAMA(8) * GAMMA - PAMA(5) * GAMMA3
            DLONG(LHEIGH,8) = DLONG(LHEIGH,8) + SECPAR(2)
          ENDIF

C  MUON
          CALL ADDANG( COSTHE,PHI, COSTH3,PHI3, COSMU,PHIMU )
          IF ( COSMU .GT. C(29) ) THEN
C  DIRECTION OF PION IN THE MUON CM SYSTEM (= DIRECTION OF POLARIZATION)
C  SEE: G. BARR ET AL., PHYS. REV. D39 (1989) 3532, EQ. 5
C  POLART IS COS OF ANGLE BETWEEN PION AND LABORATORY IN THE MU CM
C  POLARF IS ANGLE PHI AROUND THE LAB DIRECTION IN THE MU CM
C  POLART, POLARF ARE WITH RESPECT TO THE MU DIRECTION IN THE LAB SYSTEM
            POLART = ( 2.D0*PAMA(8)*GAMMA*C(7)/(PAMA(5)*GAMMA3)
     *                 - C(7) - 1.D0 ) / ( BETA3 * (1.D0 - C(7)) )
            POLARF = PHI3 - PI
C  PION DIRECTION IS DIRECTION OF POLARIZATION FOR PI+, OPPOSITE FOR PI-
            IF ( ITYPE .EQ. 9 ) THEN
              POLART = -POLART
              POLARF = POLARF + PI
            ENDIF
C  GET THE POLARIZATION DIRECTION IN THE MU CM RELATIVE TO THE CORSIKA
C  COORDINATE SYSTEM
            CALL ADDANG( COSMU,PHIMU, POLART,POLARF, POLART,POLARF )
C  MUON IS WRITTEN TO STACK
            SECPAR( 1) = CURPAR(1) - 3.D0
            SECPAR( 2) = GAMMA3
            SECPAR( 3) = COSMU
            SECPAR( 4) = 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,5) = DLONG(LHEIGH,5) + GAMMA3 * PAMA(5)
            ENDIF
          ENDIF
          IRET1 = 1
          RETURN
        ENDIF

C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  CHARGED PION INTERACTS

C  CALCULATE GAMMA, BETA AND ENERGY IN CENTER OF MASS
        ECM    = SQRT( C(45) * GAMMA + C(46) )
        GCM    = (PAMA(ITYPE) * GAMMA + PAMA(14)) / ECM
        BETACM = SQRT( 1.D0 - 1.D0 / GCM**2 )

C  LOW ENERGY HADRONIC INTERACTIONS
C  CHECK IF WE USE LOW ENERGY HADRONIC INTERACTION MODEL
        IF ( USELOW ) THEN
C  USE GHEISHA IF THE CROSS-SECTION HAS BEEN CALCULATED FOR GHEISHA
          CALL CGHEI
        ELSE
          CALL SDPM
        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) + 1

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( 1.D0 - 1.D0 / GCM**2 )
C  HIGH ENERGY INTERACTION MODEL
          CALL SDPM
        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( 1.D0 - 1.D0 / GCM**2 )
        INBIN(KJ) = INBIN(KJ) + 1

C  LOW ENERGY HADRONIC INTERACTIONS
C  CHECK IF WE USE LOW ENERGY HADRONIC INTERACTION MODEL
        IF ( USELOW ) THEN
C  USE GHEISHA IF THE CROSS-SECTION HAS BEEN CALCULATED FOR GHEISHA
          CALL CGHEI
        ELSE
          CALL SDPM
        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) + 1

C  DECAY OR INTERACTION FOR KAONS ?
        IF ( FDECAY ) THEN
C  KAON DECAYS. DETERMINE DECAY MODE FOR KAONS AND SET LIFE TIME
          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( 1.D0 - 1.D0 / GCM**2 )
C  LOW ENERGY HADRONIC INTERACTIONS
C  CHECK IF WE USE LOW ENERGY HADRONIC INTERACTION MODEL
          IF ( USELOW ) THEN
C  USE GHEISHA IF THE CROSS-SECTION HAS BEEN CALCULATED FOR GHEISHA
            CALL CGHEI
          ELSE
            CALL SDPM
          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) + 1

C  DECAY OR INTERACTION FOR ETAS ?
        IF ( FDECAY ) THEN
          CALL ETADEC
        ELSE
          CURPAR(1) = 17.D0
          ITYPE     = 17
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(17) * GAMMA
     *                  + PAMA(14)**2 +PAMA(17)**2 )
          GCM    = (PAMA(17) * GAMMA + PAMA(14)) / ECM
          BETACM = SQRT( 1.D0 - 1.D0 / GCM**2 )
C  HIGH ENERGY INTERACTION MODEL
          CALL SDPM
        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) + 1
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( 1.D0 - 1.D0 / GCM**2 )
C  LOW ENERGY HADRONIC INTERACTIONS
C  CHECK IF WE USE LOW ENERGY HADRONIC INTERACTION MODEL
        IF ( USELOW ) THEN
C  USE GHEISHA IF THE CROSS-SECTION HAS BEEN CALCULATED FOR GHEISHA
          CALL CGHEI
        ELSE
C  VENUS TREATS STRANGE BARYONS
          CALL SDPM
        ENDIF

C-----------------------------------------------------------------------
C  HEAVY PRIMARY INCIDENT
      ELSEIF ( ITYPE .GT. 100 ) THEN
        IF (DEBUG) WRITE(MDEBUG,*) 'NUCINT: HEAVY PRIMARY EKINL=',
     *                 SNGL(EKINL),' ETOT=',ETOT
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
C  USE GHEISHA IF THE CROSS-SECTION HAS BEEN CALCULATED FOR GHEISHA
C   (THIS MIGHT BE THE CASE FOR DEUTERONS, TRITONS AND ALPHAS)
          IF ( GHESIG ) THEN
            CALL CGHEI
          ELSE
            CALL SDPM
          ENDIF
        ELSE
          CALL SDPM
        ENDIF

C-----------------------------------------------------------------------
C  ILLEGAL PARTICLE
      ELSE
        WRITE(MONIOU,444) (CURPAR(I),I=1,9)
        WRITE(MONIOU,*) 'NUCINT: ILLEGAL PARTICLE = ',ITYPE
        STOP
      ENDIF

C-----------------------------------------------------------------------
C  KILL PARTICLE
      IRET1 = 1

      RETURN
      END
*CMZ :          27/02/2002  16.27.13  by  D. HECK IK FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
C=======================================================================

      SUBROUTINE 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
*KEEP,BUFFS.
      COMMON /BUFFS/   RUNH,RUNE,EVTH,EVTE,DATAB,ARRAYLONG,LH
      INTEGER          MAXBUF,MAXLEN
      PARAMETER        (MAXLEN=16)
      PARAMETER        (MAXBUF=39*7)
      REAL             RUNH(MAXBUF),EVTH(MAXBUF),EVTE(MAXBUF),
     *                 RUNE(MAXBUF),DATAB(MAXBUF),ARRAYLONG(MAXBUF)
      INTEGER          LH
      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)
*KEEP,CHISTA.
      COMMON /CHISTA/  IHYCHI,IKACHI,IMUCHI,INNCHI,INUCHI,IPICHI
      INTEGER          IHYCHI(124),IKACHI(124),IMUCHI(124),
     *                 INNCHI(124),INUCHI(124),IPICHI(124)
*KEEP,ELADPM.
      COMMON /ELADPM/  ELMEAN,ELMEAA,IELDPM,IELDPA
      DOUBLE PRECISION ELMEAN(40),ELMEAA(40)
      INTEGER          IELDPM(40,13),IELDPA(40,13)
*KEEP,MULT.
      COMMON /MULT/    EKINL,MSMM,MULTMA,MULTOT
      DOUBLE PRECISION EKINL
      INTEGER          MSMM,MULTMA(40,13),MULTOT(40,13)
*KEEP,NCOUNT.
      COMMON /NCOUNT/  NCOUN
      INTEGER          NCOUN(8)
*KEEP,NPARTI.
      COMMON /NPARTI/  NPARTO
      DOUBLE PRECISION NPARTO(10,25),NPHOTO(10),NPOSIT(10),NELECT(10),
     *                 NNU(10),NMUP(10),NMUM(10),NPI0(10),NPIP(10),
     *                 NPIM(10),NK0L(10),NKPL(10),NKMI(10),NNEUTR(10),
     *                 NPROTO(10),NPROTB(10),NK0S(10),NHYP(10),
     *                 NNEUTB(10),NDEUT(10),NTRIT(10),NALPHA(10),
     *                 NOTHER(10),NMUOND
      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),NALPHA(1)),
     *            (NPARTO(1,22),NOTHER(1)), (NPARTO(1,25),NNEUTB(1)),
     *            (NPARTO(1,23),NMUOND)
*KEEP,PARPAR.
      COMMON /PARPAR/  CURPAR,SECPAR,PRMPAR,OUTPAR,C,
     *                 E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
      DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16),
     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH
      INTEGER          ITYPE,LEVL
*KEEP,PARPAE.
      DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM
     *                 ,WEIGHT
     *                 ,HAPP,COSTAP,COSTEA
      EQUIVALENCE      (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE),
     *                 (CURPAR(4), PHI   ), (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)
*KEEP,RECORD.
      COMMON /RECORD/  IRECOR
      INTEGER          IRECOR
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEEP,STACKF.
      COMMON /STACKF/  STACK,MSTACKP,MEXST,NSHIFT,NOUREC,ICOUNT,
     *                 NTO,NFROM
      INTEGER          MAXSTK
      PARAMETER        (MAXSTK = 16*256*2)
      DOUBLE PRECISION STACK(MAXSTK)
      INTEGER          MSTACKP,MEXST,NSHIFT,NOUREC,ICOUNT,NTO,NFROM
*KEEP,STATI.
      COMMON /STATI/   SABIN,SBBIN,INBIN,IPBIN,IKBIN,IHBIN
      DOUBLE PRECISION SABIN(40),SBBIN(40)
      INTEGER          INBIN(40),IPBIN(40),IKBIN(40),IHBIN(40)
*KEND.

      INTEGER          I
      INTEGER          J,K,NELMEA
      SAVE
C-----------------------------------------------------------------------

      IF ( LH .GT. 0 ) THEN
        IF ( FPAROUT ) CALL TOBUF( DATAB,0 )
        DO  2  I = 1,MAXBUF
          DATAB(I) = 0.
    2   CONTINUE
      ENDIF
      LH = 0

      IF ( FPRINT  .OR.  DEBUG ) THEN
        WRITE(MONIOU,101) NSHIFT,NOPART
  101   FORMAT(' ',I10,' SHIFTS TO EXTERNAL STACK'/
     *         ' ',I10,' PARTICLES WRITTEN TO MPATAP')
      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'//
     *           ' ',5X,5I10,3I8,5I6,'    ENERGY RANGE (GEV)'/
     *           39(/' ',I4,1X,5I10,3I8,5I6,2X,1P,2E10.1,0P)//
     *           ' MULT.',5I10,3I8,5I6,5X,'LOWER BIN LIMIT'/
     *           ' RANGE',5I10,3I8,5I6,5X,'UPPER BIN LIMIT')
      ENDIF


C  GET MEAN OF ELASTICITY FOR ENERGY BINS
      DO 3377  J = 1,40
        NELMEA = 0
        DO 3378  K = 1,10
          NELMEA = NELMEA + IELDPM(J,K)
 3378   CONTINUE
        IF ( NELMEA .NE. 0 ) ELMEAN(J) = ELMEAN(J) / NELMEA
 3377 CONTINUE

      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)

        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) IRECOR
  105   FORMAT (/' NO OF WORDS WRITTEN TO PARTICLE TAPE UP TO NOW =',
     *           I10)
      ENDIF

      RETURN
      END
*CMZ :          28/02/2002  13.08.19  by  D. HECK IK FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
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
*KEEP,BUFFS.
      COMMON /BUFFS/   RUNH,RUNE,EVTH,EVTE,DATAB,ARRAYLONG,LH
      INTEGER          MAXBUF,MAXLEN
      PARAMETER        (MAXLEN=16)
      PARAMETER        (MAXBUF=39*7)
      REAL             RUNH(MAXBUF),EVTH(MAXBUF),EVTE(MAXBUF),
     *                 RUNE(MAXBUF),DATAB(MAXBUF),ARRAYLONG(MAXBUF)
      INTEGER          LH
      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)
*KEEP,ETHMAP.
      COMMON /ETHMAP/  ECTMAP,ELEFT
      DOUBLE PRECISION ECTMAP,ELEFT
*KEEP,LONGI.
      COMMON /LONGI/   ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP,LLONGI,FLGFIT
      DOUBLE PRECISION ADLONG(0:1170,9),AELONG(0:1170,9),
     *                 APLONG(0:1170,9),DLONG(0:1170,9),ELONG(0:1170,9),
     *                 HLONG(0:1170),PLONG(0:1170,9),SDLONG(0:1170,9),
     *                 SELONG(0:1170,9),SPLONG(0:1170,9),THSTEP,THSTPI
      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT
*KEEP,MAGANG.
      COMMON /MAGANG/  ARRANG,ARRANR,COSANG,SINANG
      DOUBLE PRECISION ARRANG,ARRANR,COSANG,SINANG
*KEEP,MULT.
      COMMON /MULT/    EKINL,MSMM,MULTMA,MULTOT
      DOUBLE PRECISION EKINL
      INTEGER          MSMM,MULTMA(40,13),MULTOT(40,13)
*KEEP,MUPART.
      COMMON /MUPART/  AMUPAR,BCUT,CMUON,FMUBRM,FMUORG
      DOUBLE PRECISION AMUPAR(16),BCUT,CMUON(11)
      LOGICAL          FMUBRM,FMUORG
*KEEP,NPARTI.
      COMMON /NPARTI/  NPARTO
      DOUBLE PRECISION NPARTO(10,25),NPHOTO(10),NPOSIT(10),NELECT(10),
     *                 NNU(10),NMUP(10),NMUM(10),NPI0(10),NPIP(10),
     *                 NPIM(10),NK0L(10),NKPL(10),NKMI(10),NNEUTR(10),
     *                 NPROTO(10),NPROTB(10),NK0S(10),NHYP(10),
     *                 NNEUTB(10),NDEUT(10),NTRIT(10),NALPHA(10),
     *                 NOTHER(10),NMUOND
      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),NALPHA(1)),
     *            (NPARTO(1,22),NOTHER(1)), (NPARTO(1,25),NNEUTB(1)),
     *            (NPARTO(1,23),NMUOND)
*KEEP,OBSPAR.
      COMMON /OBSPAR/  OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP,
     *                 THETPR,PHIPR,
     *                 VUECON,
     *                 NOBSLV
      DOUBLE PRECISION OBSLEV(10),THCKOB(10),XOFF(10),YOFF(10),
     *                 HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2)
      DOUBLE PRECISION VUECON(2)
      INTEGER          NOBSLV
*KEEP,PAM.
      COMMON /PAM/     PAMA,SIGNUM,RESTMS
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000)
*KEEP,PARPAR.
      COMMON /PARPAR/  CURPAR,SECPAR,PRMPAR,OUTPAR,C,
     *                 E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
      DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16),
     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH
      INTEGER          ITYPE,LEVL
*KEEP,PARPAE.
      DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM
     *                 ,WEIGHT
     *                 ,HAPP,COSTAP,COSTEA
      EQUIVALENCE      (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE),
     *                 (CURPAR(4), PHI   ), (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)
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEEP,TABLES.
      INTEGER          IEBIN, ITBIN, IDBIN
      PARAMETER        (IEBIN=40,ITBIN=30,IDBIN=20)
      COMMON /TABLES/  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)
*KEND.

      DOUBLE PRECISION AUGM,ETOT,PTOT,STT,XADDMU,YADDMU
      REAL             EE,TT,RR,TF
      INTEGER          IIE,IIT,IID
      INTEGER          I,IGG,III,NCOUNT
      LOGICAL          ROUT
      SAVE
      DATA             NCOUNT /0/,AUGM/1.D0/
C-----------------------------------------------------------------------

      IF ( DEBUG ) WRITE(MDEBUG,444) (OUTPAR(I),I=1,9),LEVL
  444 FORMAT(' OUTPT1: OUTPAR=',1P,8E10.3,0P,F10.0,I5)


C  PRINT OUT PARTICLE IF IT IS ABOVE THE CUT
      IF ( FPRINT  .OR.  DEBUG  .OR.  DEBDEL ) THEN
        IF ( OUTPAR(2) .GE. ECTMAP ) THEN
          WRITE(MONIOU,3) (OUTPAR(I),I=1,10),ELEFT
    3     FORMAT(' OUTPT1:        ',1P,8E10.3,0P,F6.0,1P,2E10.3)
          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

C  COUNT PARTICLES SPECIFIED BY THEIR PARTICLE CODE < 25
      III    = NINT(OUTPAR(1))
      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 .EQ. 201                      ) THEN
        NDEUT(LEVL) = NDEUT(LEVL) + AUGM
      ELSEIF ( III .EQ. 301                      ) THEN
        NTRIT(LEVL) = NTRIT(LEVL) + AUGM
      ELSEIF ( III .EQ. 402                      ) THEN
        NALPHA(LEVL) = NALPHA(LEVL) + AUGM
      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
        LHEIGH = NSTEP
        IF     ( III .EQ. 1                     ) THEN
          DLONG(LHEIGH,1) = DLONG(LHEIGH,1) + OUTPAR(2) * AUGM
        ELSEIF ( III .EQ. 2                     ) THEN
C  REMEMBER: FOR EM-PARTICLES OUTPAR(2) CONTAINS ENERGY IN GEV
          DLONG(LHEIGH,3) = DLONG(LHEIGH,3) + (OUTPAR(2)+PAMA(2))*AUGM
        ELSEIF ( III .EQ. 3                     ) THEN
          DLONG(LHEIGH,3) = DLONG(LHEIGH,3) + (OUTPAR(2)-PAMA(2))*AUGM
        ELSEIF ( III .EQ. 5  .OR.   III .EQ. 6  ) THEN
          DLONG(LHEIGH,5) = DLONG(LHEIGH,5)
     *                                   + OUTPAR(2)*PAMA(5)*AUGM
        ELSEIF ( III .EQ. 13 .AND.  III .EQ. 14 ) THEN
          DLONG(LHEIGH,7) = DLONG(LHEIGH,7)
     *                          + (OUTPAR(2)-1.D0)*PAMA(III)*AUGM
        ELSEIF ( III .EQ. 15 .AND.  III .EQ. 25 ) THEN
          DLONG(LHEIGH,7) = DLONG(LHEIGH,7)
     *                          + (OUTPAR(2)+1.D0)*PAMA(III)*AUGM
        ELSE
          DLONG(LHEIGH,7) = DLONG(LHEIGH,7)
     *                                 + OUTPAR(2)*PAMA(III)*AUGM
        ENDIF
      ENDIF

      ROUT = .TRUE.

C  TREATE 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
          IGG = MIN( OUTPAR(9), 99.D0 )
          DATAB(LH+1) = (III + 70) * 1000 + IGG*10 + MOD(LEVL,10)
          PTOT = PAMA(III) * SQRT( AMUPAR(2)**2 - 1.D0 )
          DATAB(LH+4) = PTOT * AMUPAR(15)
          XADDMU = AMUPAR(7)
          YADDMU = AMUPAR(8)
          STT  = SQRT( 1.D0 - AMUPAR(15)**2 )
          DATAB(LH+2) = PTOT * STT * COS( AMUPAR(4) + ARRANR )
          DATAB(LH+3) = PTOT * STT * SIN( AMUPAR(4) + ARRANR )
          DATAB(LH+5) = XADDMU * COSANG + YADDMU * SINANG
          DATAB(LH+6) = YADDMU * COSANG - XADDMU * SINANG
          DATAB(LH+7) = AMUPAR(5)
          IF ( DEBUG ) WRITE(MDEBUG,445) (DATAB(LH+I),I=1,7)
  445     FORMAT(' OUTPT1: MUADDI=',1P,7E10.3)
          LH = LH + 7

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  1  I = 1,MAXBUF
              DATAB(I) = 0.
  1         CONTINUE
            LH = 0
          ENDIF
        ENDIF

C   COPY PARTICLE TO DATAB FIELD
        IGG = MIN( OUTPAR(9), 99.D0 )
        DATAB(LH+1) = III*1000 + IGG*10 + MOD(LEVL,10)
        IF     ( OUTPAR(1) .LE. 3.D0 ) THEN
          ETOT = OUTPAR(2)
        ELSE
          ETOT = PAMA(III) * OUTPAR(2)
        ENDIF
        PTOT = SQRT( ETOT**2 - PAMA(III)**2 )
        STT  = SQRT( 1.D0 - OUTPAR(3)**2 )
        DATAB(LH+2) = PTOT * STT * COS( OUTPAR(4) + ARRANR )
        DATAB(LH+3) = PTOT * STT * SIN( OUTPAR(4) + ARRANR )
        DATAB(LH+4) = PTOT * OUTPAR(3)
        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(1) .LE. 3.D0 ) THEN
          ETOT = OUTPAR(2)
        ELSE
          ETOT = PAMA(III) * OUTPAR(2)
        ENDIF
        EE = ETOT
        RR = SQRT(OUTPAR(7)**2 + OUTPAR(8)**2)
        EE = MAX(EBMIN,EE)
        TT = MAX(TBMIN,TT)
        RR = MAX(DBMIN,RR)
C  GET CORRECT BIN
        IIE = (LOG10(EE) - EBOFF)*EBFAC + 1.
        IIT = (LOG10(TT) - TBOFF)*TBFAC + 1.
        IID = (LOG10(RR) - DBOFF)*DBFAC + 1.
        IIE = MIN(IIE,IEBIN)
        IIE = MAX(IIE,1)
        IIT = MIN(IIT,ITBIN)
        IIT = MAX(IIT,1)
        IID = MIN(IID,IDBIN)
        IID = MAX(IID,1)

        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  WRITE A BLOCK OF 39 PARTICLES TO OUTPUT BUFFER AND CLEAR FIELD
      IF ( ROUT ) THEN
C  COUNT PARTICLES, THAT ARE WRITTEN TO TAPE
        NOPART = NOPART + 1

        LH = LH + 7

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  2  I = 1,MAXBUF
            DATAB(I) = 0.
  2       CONTINUE
          LH = 0
        ENDIF
      ENDIF

      RETURN
      END
*CMZ :          25/02/2002  15.28.14  by  D. HECK IK FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
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 GEANT TABLE,
C  TAKEN FROM THE PERIODIC TABLE
C  OR CALCULATED WITH THE MASS FORMULA OF WEIZSAECKER
C  THIS SUBROUTINE IS CALLED FROM START.
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,CONSTA.
      COMMON /CONSTA/  PI,PI2,OB3,TB3,ENEPER
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER
*KEEP,PAM.
      COMMON /PAM/     PAMA,SIGNUM,RESTMS
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000)
*KEND.

      DOUBLE PRECISION CHARGE(75),MASSES(75)
C*    DOUBLE PRECISION AMUS(59,14),BIND,B1,B2,B3,B4,B5,SS
      INTEGER          IA,IC,IN,IP
C*    INTEGER          I,L
      SAVE
C-----------------------------------------------------------------------

C  MASSES REVISED SEPT 2000 BY D. HECK
      DATA MASSES /
     * 0.D0     ,.510998902D-3,.510998902D-3, 0.0D0      ,.105658357D0,
     * .105658357D0, .1349766D0, .13957018D0,.13957018D0 , 0.497672D0 ,
     * 0.493677D0 , 0.493677D0 ,.93956533D0 ,.93827200D0 ,.93827200D0 ,
     * 0.497672D0 , 0.54730D0  , 1.115683D0 , 1.18937D0  , 1.192642D0 ,
     * 1.197449D0 , 1.31483D0  , 1.32131D0  , 1.67245D0  ,.93956533D0 ,
     * 1.115683D0 , 1.18937D0  , 1.192642D0 , 1.197449D0 , 1.31483D0  ,
     * 1.32131D0  , 1.67245D0  , 1.7841D0   , 1.7841D0   , 1.8693D0   ,
     * 1.8693D0   , 1.8645D0   , 1.8645D0   , 1.9693D0   , 1.9693D0   ,
     * 2.2852D0   , 80.6D0     , 80.6D0     , 91.161D0   , 1.877D0    ,
     * 2.817D0    , 3.755D0    , 0.0D0      , 0.0D0      , 0.78257D0  ,
     * 0.7690D0   , 0.7665D0   , 0.7665D0   , 1.2305D0   , 1.2318D0   ,
     * 1.2331D0   , 1.2344D0   , 1.2309D0   , 1.2323D0   , 1.2336D0   ,
     * 1.2349D0   , 0.89610D0  , 0.89166D0  , 0.89166D0  , 0.89610D0  ,
     * 0.0D0      , 0.0D0      , 0.0D0      , 0.0D0      , 0.0D0      ,
     * 0.54730D0  , 0.54730D0  , 0.54730D0  , 0.54730D0  , 0.0D0      /

      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,+1.D0,-1.D0,+1.D0,-1.D0, 0.D0, 0.D0,+1.D0,-1.D0,
     * +1.D0,+1.D0,-1.D0, 0.D0,+1.D0,+1.D0,+2.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  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  1  IP = 1,75
        PAMA  (IP) = MASSES(IP)
        SIGNUM(IP) = CHARGE(IP)
  1   CONTINUE

C  RESET REST OF THE ARRAY
      DO  2  IP = 76,6000
        PAMA  (IP) = 0.D0
        SIGNUM(IP) = 0.D0
  2   CONTINUE

      DO  3  IA = 1,59
      DO  3  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  DO NOT USE BINDING ENERGY EFFECTS
        PAMA(IP) = IN * MASSES(13) + IC * MASSES(14)

C  NUCLEI ARE ASSUMED TO BE FULLY IONIZED
        SIGNUM(IP) = +IC
  3   CONTINUE

C  MASSES OF MULTINEUTRON CLUSTERS
      DO  4  IN = 1,59
        IP = 100 * IN
        PAMA  (IP) = IN * PAMA(13)
        SIGNUM(IP) = 0.D0
  4   CONTINUE
C  REST MASS OF LIGHT NUCLEI (DEUTERIUM, TRITIUM, ALPHA)
      RESTMS(201) =        RESTMS(13) +        RESTMS(14)
      RESTMS(301) = 2.D0 * RESTMS(13) +        RESTMS(14)
      RESTMS(402) = 2.D0 * RESTMS(13) + 2.D0 * RESTMS(14)

      RETURN
      END
*CMZ :          25/09/2000  16.46.23  by  D. HECK IK3 FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
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
C  DESIGN  : D. HECK    IK3  FZK KARLSRUHE
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,CONSTA.
      COMMON /CONSTA/  PI,PI2,OB3,TB3,ENEPER
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER
*KEEP,DECAY.
      COMMON /DECAY/   GAM345,COS345,PHI345
      DOUBLE PRECISION GAM345(3),COS345(3),PHI345(3)
*KEEP,GENER.
      COMMON /GENER/   GEN,ALEVEL
      DOUBLE PRECISION GEN,ALEVEL
*KEEP,LONGI.
      COMMON /LONGI/   ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP,LLONGI,FLGFIT
      DOUBLE PRECISION ADLONG(0:1170,9),AELONG(0:1170,9),
     *                 APLONG(0:1170,9),DLONG(0:1170,9),ELONG(0:1170,9),
     *                 HLONG(0:1170),PLONG(0:1170,9),SDLONG(0:1170,9),
     *                 SELONG(0:1170,9),SPLONG(0:1170,9),THSTEP,THSTPI
      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT
*KEEP,PAM.
      COMMON /PAM/     PAMA,SIGNUM,RESTMS
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000)
*KEEP,PARPAR.
      COMMON /PARPAR/  CURPAR,SECPAR,PRMPAR,OUTPAR,C,
     *                 E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
      DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16),
     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH
      INTEGER          ITYPE,LEVL
*KEEP,PARPAE.
      DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM
     *                 ,WEIGHT
     *                 ,HAPP,COSTAP,COSTEA
      EQUIVALENCE      (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE),
     *                 (CURPAR(4), PHI   ), (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)
*KEEP,RANDPA.
      COMMON /RANDPA/  FAC,U1,U2,RD,NSEQ,ISEED,KNOR
      DOUBLE PRECISION FAC,U1,U2
      REAL             RD(3000)
      INTEGER          ISEED(103,10),NSEQ
      LOGICAL          KNOR
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEND.

      DOUBLE PRECISION AUX1,AUX2,COSTH1,COSTH2,EPITO2,FI1
      INTEGER          I
      SAVE
C-----------------------------------------------------------------------

      IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=1,9)
  444 FORMAT(' PI0DEC: CURPAR=',1P,9E10.3)

C  LOOK FOR DECAY MODE
      CALL RMMAR (RD,3,1)

C  DECAY    PI(0)  ---->  GAMMA + GAMMA
      IF ( RD(3) .LT. 0.98798 ) 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(2) = AUX1 * EPITO2
        CALL ADDANG( COSTHE,PHI, COSTH1,FI1, SECPAR(3),SECPAR(4) )
        IF ( SECPAR(3) .GT. C(29) ) THEN
          SECPAR(1) = 1.D0
          CALL TSTACK
        ELSE
          IF ( LLONGI ) THEN
C  ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT
            DLONG(LHEIGH,1) = DLONG(LHEIGH,1) + SECPAR(2)
          ENDIF
        ENDIF

C  SECOND GAMMA   (WITH LOWER ENERGY)
C  ENERGY OF GAMMA
        SECPAR(2) = AUX2 * EPITO2
        CALL ADDANG( COSTHE,PHI, COSTH2,FI1+PI, SECPAR(3),SECPAR(4) )
        IF ( SECPAR(3) .GT. C(29) ) THEN
          SECPAR(1) = 1.D0
          CALL TSTACK
        ELSE
          IF ( LLONGI ) THEN
C  ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT
            DLONG(LHEIGH,1) = DLONG(LHEIGH,1) + SECPAR(2)
          ENDIF
        ENDIF

C  DECAY    PI(0)  ---->  E(-) + E(+) + GAMMA      (DALITZ DECAY)
C  (UNIFORM PHASE SPACE DISTRIBUTION IS ASSUMED FOR THIS DECAY)
      ELSE
        CALL DECAY6( PAMA(7), PAMA(2), PAMA(2), 0.D0,
     *                0.D0,0.D0,0.D0, 1.D0, 2)
        DO 11  I = 1,3
          CALL ADDANG( COSTHE,PHI, COS345(I),PHI345(I),
     *                                SECPAR(3),SECPAR(4) )
          IF ( SECPAR(3) .GT. C(29) ) THEN
            SECPAR(1) = FLOAT(4 - I)
            SECPAR(2) = GAM345(I)
            CALL TSTACK
          ELSE
            IF ( LLONGI ) THEN
C  ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT
              IF     ( I .EQ. 1 ) THEN
                DLONG(LHEIGH,3)=DLONG(LHEIGH,3)+(GAM345(I)-1.D0)*PAMA(2)
              ELSEIF ( I .EQ. 2 ) THEN
                DLONG(LHEIGH,3)=DLONG(LHEIGH,3)+(GAM345(I)+1.D0)*PAMA(2)
              ELSE
                DLONG(LHEIGH,1) = DLONG(LHEIGH,1) + GAM345(I)
              ENDIF
            ENDIF
          ENDIF
 11    CONTINUE

      ENDIF

      RETURN
      END
*CMZ :          01/03/2002  11.13.53  by  D. HECK IK FZK KARLSRUHE
*-- Author :    F. SCHROEDER UNI WUPPERTAL      17/09/98
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.
C  THIS SUBROUTINE IS CALLED FROM BOX2.
C  ARGUMENTS:
C   ARG    = -LOG(RANDOM NUMBER) * SPEED OF LIGHT * LIFETIME
C   FLAGMU = MUON FLAG (T FOR MUONS, F ELSE)
C   HNEW   = HEIGHT AFTER TOTAL STEP LENGTH
C
C  DESIGN  : F. SCHROEDER UNI WUPPERTAL
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,AIR.
      COMMON /AIR/     COMPOS,PROBTA,AVERAW,AVOGAD
      DOUBLE PRECISION COMPOS(3),PROBTA(3),AVERAW,AVOGAD
*KEEP,ATMOS.
      COMMON /ATMOS/   AATM,AATM0,BATM,BATM0,CATM,CATM0,DATM,MODATM
      DOUBLE PRECISION AATM(5),AATM0(5,0:16),BATM(5),BATM0(5,0:16),
     *                 CATM(5),CATM0(5,0:16),DATM(5)
      INTEGER          MODATM
*KEEP,ATMOS2.
      COMMON /ATMOS2/  HLAY,HLAY0,THICKL,LAYNO,LAYNEW
      DOUBLE PRECISION HLAY(6),HLAY0(5,0:4),THICKL(5)
      INTEGER          LAYNO(0:16)
      LOGICAL          LAYNEW
*KEEP,CONSTA.
      COMMON /CONSTA/  PI,PI2,OB3,TB3,ENEPER
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER
*KEEP,MUMULT.
      COMMON /MUMULT/  CHC,OMC,PHISCT,STEPL,VSCAT,FMOLI
      DOUBLE PRECISION CHC,OMC,PHISCT,STEPL,VSCAT
      LOGICAL          FMOLI
*KEEP,OBSPAR.
      COMMON /OBSPAR/  OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP,
     *                 THETPR,PHIPR,
     *                 VUECON,
     *                 NOBSLV
      DOUBLE PRECISION OBSLEV(10),THCKOB(10),XOFF(10),YOFF(10),
     *                 HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2)
      DOUBLE PRECISION VUECON(2)
      INTEGER          NOBSLV
*KEEP,PAM.
      COMMON /PAM/     PAMA,SIGNUM,RESTMS
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000)
*KEEP,PARPAR.
      COMMON /PARPAR/  CURPAR,SECPAR,PRMPAR,OUTPAR,C,
     *                 E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
      DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16),
     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH
      INTEGER          ITYPE,LEVL
*KEEP,PARPAE.
      DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM
     *                 ,WEIGHT
     *                 ,HAPP,COSTAP,COSTEA
      EQUIVALENCE      (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE),
     *                 (CURPAR(4), PHI   ), (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)
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEND.

      DOUBLE PRECISION AK,ARG,ARG0,ARGNEW,AUXIL,BETANEW,BK,CHIT,CHIT2,
     *                 COSDIF,COSPHI,COSTAPNEW,COSTHENEW,DISTN2,DISTO2,
     *                 DK,DL,ELOSS,GAMK,GAMNEW,GAMSQ,GAM0,GMSQM1,
     *                 HEIGH,HNEW,HOLD,H0,RADIUS,SIGNE,SINPHI,SINTHENEW,
     *                 TH0,THICK,THNEW,THOLD,TRANS,TRANSNEW,XNEW,YNEW
      INTEGER          ILAY
      LOGICAL          FLAGMU
      SAVE
      EXTERNAL         HEIGH,THICK
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
      XNEW = X
      YNEW = Y
      BETANEW   = BETA
      COSTHENEW = COSTHE
      COSTAPNEW = COSTAP
      STEPL  = 0.D0
      COSPHI = COS(PHI)
      SINPHI = SIN(PHI)
      DISTN2 = XNEW**2 + YNEW**2

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( 1.D0-COSTHENEW**2, 0.D0 ) )
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)
      TRANSNEW = MIN( TRANS, C(4) * THOLD + C(3) )

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

C  SET START VALUES FOR ITERATION OVER THE AIR LAYERS
      ARG0 = ARGNEW
      CHIT = 0.D0
      H0   = HNEW
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  2   CONTINUE
      GAM0   = MAX( GAM0, 1.0001D0 )
      GAMSQ  = GAM0**2
      GMSQM1 = GAMSQ - 1.D0
C  ENERGY LOSS BY IONIZATION
      ELOSS  = SIGNUM(ITYPE)**2 * C(22) *
     *           ( GAMSQ * (LOG(GMSQM1) + C(23)) / GMSQM1 - 1.D0 )
      ELOSS  = ELOSS / (PAMA(ITYPE) * COSTHENEW )
      BK     = ELOSS * (TH0 - AATM(ILAY))
      DK     = GAM0 + BK
      AK     = ARG0 * DK * COSTHENEW * DATM(ILAY)
      IF ( AK .GT. 0.D0 ) THEN
        IF ( AK .LT. 174.D0 ) THEN
C  LIMIT FOR EXPONENT (ON IBM COMPUTER)
          GAMNEW = MAX( GAM0 * DK / ( GAM0 + BK * EXP(AK) ), 1.0001D0 )
        ELSE
          GAMNEW = 1.0001D0
        ENDIF
        GAMK   = GAM0 - ELOSS * ( THICKL(ILAY) - TH0)
      ELSE
        GAMK   = 1.D0
        GAMNEW = 1.0001D0
      ENDIF
      IF ( DEBUG ) WRITE(MDEBUG,*) 'PRANGC: GAMNEW,GAMK=',
     *                           SNGL(GAMNEW),SNGL(GAMK)
C  LOOK WETHER PARTICLE PENETRATES LAYER BOUNDARY OR DECAYS BEFORE
      IF ( GAMNEW .LT. GAMK  .AND.  ILAY. GT. 1 ) 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

C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  PENETRATED MATTER THICKNESS
      CHIT2 = (GAM0 - GAMNEW) / (ELOSS*COSTHENEW)
      CHIT  = CHIT + CHIT2
      IF ( TH0 + CHIT*COSTHENEW .GT. THICKL(1) ) THEN
        CHI  = CHI + (THICKL(1) - TH0)/COSTHENEW
        HNEW = HLAY(1)
        IF ( FLAGMU ) STEPL =  STEPL + (H0 - HLAY(1))/COSTHENEW
        IF ( DEBUG ) WRITE(MDEBUG,*) 'PRANGC: CHI = ',SNGL(CHI)
        GOTO 100
      ENDIF
      IF ( FLAGMU ) STEPL = STEPL + ( H0 - HEIGH(TH0+CHIT2) )/COSTHENEW
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**2 - 1.D0 ) / GAMNEW

C  CALCULATE REAL TRANSNEW AND REAL GEOMETRIC LENGHT 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 = THOLD + COSTHENEW * CHIT
      HOLD  = HNEW
C  NEW HEIGHT IN OLD COORDINATE FRAME
      HNEW  = HEIGH( THNEW )
      DL    = ( HOLD - HNEW ) / COSTHENEW
      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 OBSERVATION LEVEL
      IF ( HNEW .LT. OBSLEV(1) - 1.D5 ) THEN
CDH 21.02.2002
*     IF ( HNEW .LT. MIN( OBSLEV(1) - 1.D5,
*    *           OBSLEV(1)-2.D0*C(2)*COSTHENEW/SINTHENEW ) ) THEN
        IF ( DEBUG ) WRITE(MDEBUG,*) 'PRANGC: HNEW,CHI,ARG,STEPL=',
     *                    SNGL(HNEW),SNGL(CHI),SNGL(ARG),SNGL(STEPL)
        GOTO 100
      ENDIF
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
      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  DIRECTION OF PARTICLE RELATIVE TO DETECTOR CENTER
      DISTO2 = DISTN2
      IF ( COSDIF .LT. 1.D0 ) THEN
        RADIUS = DL * SQRT( (1.D0-COSTAPNEW**2)/(1.D0-COSDIF**2) )
     *              * C(1) * ACOS(COSDIF)/(C(1)+HNEW)
      ELSE
        RADIUS = DL * SQRT( 1.D0 - COSTAPNEW**2 )
      ENDIF
      XNEW   = XNEW + RADIUS * COSPHI
      YNEW   = YNEW + RADIUS * SINPHI
      DISTN2 = XNEW**2 + YNEW**2
      IF ( DISTO2 .GT. DISTN2 ) THEN
        SIGNE = +1.D0
      ELSE
        SIGNE = -1.D0
      ENDIF
C  COSINE OF ZENITH ANGLE IN THE NEW FRAME
      COSTHENEW = MIN( 1.D0, ( COSTHENEW * COSDIF - SIGNE *
     *           SQRT( (1.D0-COSTHENEW**2) * (1.D0-COSDIF**2) ) ) )
      IF ( DEBUG ) WRITE(MDEBUG,*) 'PRANGC: COSTHENEW =',COSTHENEW
C  TERMINATE PROCESS IF PARTICLE BECOMES UPWARD GOING
      IF ( COSTHENEW .LE. C(29) ) GOTO 100
      TH0 = THICK(HNEW)
C  NEXT STEP IF ARG NOT COMPLETELY TRANSFORMED INTO 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
*CMZ :          20/06/2000  15.00.27  by  D. HECK IK3 FZK KARLSRUHE
*-- Author :    The CORSIKA development group   14/07/95
C=======================================================================

      SUBROUTINE PRANGE(ARG)

C-----------------------------------------------------------------------
C  (DECAYING) P(ARTICLE'S) RANGE
C
C  DETERMINES MEAN FREE PATH FOR DECAYING PARTICLES
C  INCLUDING IONIZATION ENERGY LOSS,
C  FOR EACH LAYER OF THE ATMOSOHERE SEPARATELY
C  PRECISELY
C  THIS SUBROUTINE IS CALLED FROM BOX2.
C  ARGUMENT:
C   ARG    = -LOG(RANDOM NUMBER) * SPEED OF LIGHT * LIFETIME
C
C  DESIGN  : D. HECK    IK3  FZK KARLSRUHE
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,AIR.
      COMMON /AIR/     COMPOS,PROBTA,AVERAW,AVOGAD
      DOUBLE PRECISION COMPOS(3),PROBTA(3),AVERAW,AVOGAD
*KEEP,ATMOS.
      COMMON /ATMOS/   AATM,AATM0,BATM,BATM0,CATM,CATM0,DATM,MODATM
      DOUBLE PRECISION AATM(5),AATM0(5,0:16),BATM(5),BATM0(5,0:16),
     *                 CATM(5),CATM0(5,0:16),DATM(5)
      INTEGER          MODATM
*KEEP,ATMOS2.
      COMMON /ATMOS2/  HLAY,HLAY0,THICKL,LAYNO,LAYNEW
      DOUBLE PRECISION HLAY(6),HLAY0(5,0:4),THICKL(5)
      INTEGER          LAYNO(0:16)
      LOGICAL          LAYNEW
*KEEP,CONSTA.
      COMMON /CONSTA/  PI,PI2,OB3,TB3,ENEPER
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER
*KEEP,OBSPAR.
      COMMON /OBSPAR/  OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP,
     *                 THETPR,PHIPR,
     *                 VUECON,
     *                 NOBSLV
      DOUBLE PRECISION OBSLEV(10),THCKOB(10),XOFF(10),YOFF(10),
     *                 HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2)
      DOUBLE PRECISION VUECON(2)
      INTEGER          NOBSLV
*KEEP,PAM.
      COMMON /PAM/     PAMA,SIGNUM,RESTMS
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000)
*KEEP,PARPAR.
      COMMON /PARPAR/  CURPAR,SECPAR,PRMPAR,OUTPAR,C,
     *                 E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
      DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16),
     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH
      INTEGER          ITYPE,LEVL
*KEEP,PARPAE.
      DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM
     *                 ,WEIGHT
     *                 ,HAPP,COSTAP,COSTEA
      EQUIVALENCE      (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE),
     *                 (CURPAR(4), PHI   ), (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)
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEND.

      DOUBLE PRECISION AK,ARG,ARG0,BK,CHIT,DK,ELOSS,
     *                 GAMK,GAMNEW,GAMSQ,GAM0,GMSQM1,H0,TH0
      INTEGER          ILAY
      SAVE
C-----------------------------------------------------------------------

      IF ( DEBUG ) WRITE(MDEBUG,444) ARG,THICKH
  444 FORMAT(' PRANGE: -LOG(RD)*C*TAU = ',1P,E10.3,' THICKH=',E10.3)

C  LOOK WITHIN WHICH LAYER THE PARTICLE STARTS
      IF     ( H .LE. HLAY(2) ) THEN
        ILAY = 1
        TH0  = THICKH
      ELSEIF ( H .LE. HLAY(3) ) THEN
        ILAY = 2
        TH0  = THICKH
      ELSEIF ( H .LE. HLAY(4) ) THEN
        ILAY = 3
        TH0  = THICKH
      ELSE
        ILAY = 4
        TH0  = MAX( THICKH, THICKL(5) )
      ENDIF
C  SET START VALUES FOR ITERATION
      ARG0 = ARG
      CHIT = 0.D0
      GAM0 = GAMMA
      H0   = H

  2   CONTINUE
      GAM0   = MAX( GAM0, 1.0001D0 )
      GAMSQ  = GAM0**2
      GMSQM1 = GAMSQ - 1.D0
C  ENERGY LOSS BY IONIZATION
      ELOSS  = SIGNUM(ITYPE)**2 * C(22) *
     *           ( GAMSQ * (LOG(GMSQM1) + C(23)) / GMSQM1 - 1.D0 )
      ELOSS  = ELOSS / (PAMA(ITYPE) * COSTHE )
      BK     = ELOSS * (TH0 - AATM(ILAY))
      DK     = GAM0 + BK
      AK     = ARG0 * DK * COSTHE * DATM(ILAY)
      IF ( AK .GT. 0.D0 ) THEN
        IF ( AK .LT. 174.D0 ) THEN
C  LIMIT FOR EXPONENT (ON IBM COMPUTER)
          GAMNEW = MAX( GAM0 * DK / ( GAM0 + BK * EXP(AK) ), 1.0001D0 )
        ELSE
          GAMNEW = 1.0001D0
        ENDIF
        GAMK   = GAM0 - ELOSS * ( THICKL(ILAY) - TH0)
      ELSE
        GAMK   = 1.D0
        GAMNEW = 1.0001D0
      ENDIF
      IF ( DEBUG ) WRITE(MDEBUG,*) 'PRANGE: GAMNEW,GAMK=',
     *                           SNGL(GAMNEW),SNGL(GAMK)
C  LOOK WETHER PARTICLE PENETRATES LAYER BOUNDARY OR DECAYS BEFORE
      IF ( GAMNEW .LT. GAMK  .AND.  ILAY. GT. 1 ) THEN
C  CALCULATE PORTION OF RANGE AND NEW START VALUES AT LAYER BOUNDARY
        ARG0 = ARG0 - ( H0 - HLAY(ILAY) + CATM(ILAY) * LOG(GAM0/GAMK) )
     *                       / (DK * COSTHE)
        CHIT = CHIT + (THICKL(ILAY) - TH0) / COSTHE
        GAM0 = GAMK
        H0   = HLAY(ILAY)
        TH0  = THICKL(ILAY)
        ILAY = ILAY - 1
        GOTO 2
      ENDIF
C  PENETRATED MATTER THICKNESS
      CHI = CHIT + (GAM0 - GAMNEW) / (ELOSS*COSTHE)
      IF ( DEBUG ) WRITE(MDEBUG,445) CHI
  445 FORMAT(' PRANGE: CHI = ',1P,E10.3)

      RETURN
      END
*CMZ :          19/10/2001  08.34.39  by  D. HECK IK FZK KARLSRUHE
*-- Author :    D. HECK IK3 FZK KARLSRUHE       26/06/95
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
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEND.

      DOUBLE PRECISION TTIME
      CHARACTER*8      YYYYMMDD
      CHARACTER*10     HHMMSS
      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
 100  FORMAT(' PRESENT TIME : ',I2.2,'.',I2.2,'.',I4,I4.2,':',I2.2,
     *       ':',I2.2,' UTC')
      RETURN
      END
*CMZ :          03/11/2000  16.13.44  by  D. HECK IK3 FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
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
C  CHANGES : J. KNAPP   IK1  FZK KARLSRUHE
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,PARPAR.
      COMMON /PARPAR/  CURPAR,SECPAR,PRMPAR,OUTPAR,C,
     *                 E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
      DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16),
     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH
      INTEGER          ITYPE,LEVL
*KEEP,RANDPA.
      COMMON /RANDPA/  FAC,U1,U2,RD,NSEQ,ISEED,KNOR
      DOUBLE PRECISION FAC,U1,U2
      REAL             RD(3000)
      INTEGER          ISEED(103,10),NSEQ
      LOGICAL          KNOR
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEND.

      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  2  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)
    2   CONTINUE
        SUMI = 1.D0 / GX(IMAX)
        DO  3  I = 1,IMAX
          GX(I) = GX(I) * SUMI
    3   CONTINUE
      ENDIF

C-----------------------------------------------------------------------
C  GET RANDOM VARIABLE DISTRIBUTED AS HX(X)
   11 CONTINUE
      CALL RMMAR( 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.-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
*CMZ :          27/02/2002  16.27.13  by  D. HECK IK FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
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
*KEEP,CONSTA.
      COMMON /CONSTA/  PI,PI2,OB3,TB3,ENEPER
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER
*KEEP,RANDPA.
      COMMON /RANDPA/  FAC,U1,U2,RD,NSEQ,ISEED,KNOR
      DOUBLE PRECISION FAC,U1,U2
      REAL             RD(3000)
      INTEGER          ISEED(103,10),NSEQ
      LOGICAL          KNOR
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEND.

      DOUBLE PRECISION A,B,RR
      SAVE
C-----------------------------------------------------------------------

CC    IF ( DEBUG ) WRITE(MDEBUG,100) SNGL(A),SNGL(B)
CC100 FORMAT(' RANNOR: A,B=',1P,2E10.3)
      IF ( KNOR ) THEN
  1     CONTINUE
        CALL RMMAR( RD,2,1 )
        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
CC    IF ( DEBUG ) WRITE(MDEBUG,101) RANNOR
CC101 FORMAT('+',34X,' RANNOR =',1P,E12.5)

      RETURN
      END
*CMZ :          14/06/2000  14.56.21  by  D. HECK IK3 FZK KARLSRUHE
*-- Author :    Konrad Bernloehr, Uni Hamburg   30/08/99
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 INPRM.
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
C  DESIGN:  K. BERNLOEHR UNI HAMBURG         1999
C-----------------------------------------------------------------------

      IMPLICIT         NONE
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEND.

      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     WELL, LET'S TRY TO CATCH THAT ONE AS WELL (READ ERROR IS O.K.)

      READ(MUNIT,REC=1,ERR=900) IDAT(1),IDAT(2),IDAT(3),IDAT(4),IDAT(5)
      WRITE(MONIOU,*) ' '
      WRITE(MONIOU,*) 'THE HANDLING OF UNFORMATTED DIRECT-ACCESS FILES',
     *    ' ON YOUR MACHINE SEEMS TO'
      WRITE(MONIOU,*) 'BE NOT AS EXPECTED. THE TEMPORARY CORSIKA ',
     *    'EXTERNAL STACK FILE MAY BECOME'
      WRITE(MONIOU,*) 'LARGER THAN NEEDED BUT NO DATA CORRUPTION IS ',
     *    'EXPECTED THERE.'
      WRITE(MONIOU,*) 'PERHAPS YOU USED THE BYTERECL OPTION FOR ',
     *    'EXTRACTING CORSIKA BUT DO NOT NEED IT.'
      WRITE(MONIOU,*) ' '

      IERR = -1
      RETURN

  900 CLOSE(MUNIT)

      IF ( IERR .NE. 0 ) THEN
        WRITE(MONIOU,*) ' '
        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 CMZ FILE. IT MAY ALSO BE ',
     *       'DUE TO USING COMPILER FLAGS'
        WRITE(MONIOU,*) 'INAPPROPRIATE FOR THE CORSIKA VERSION ',
     *       'EXTRACTED.'
        WRITE(MONIOU,*) ' '
      ENDIF

      RETURN

  990 IERR = 99
      GOTO 900

      END
*CMZ :          09/11/2000  14.19.13  by  D. HECK IK3 FZK KARLSRUHE
*-- Author :    D. HECK IK3 FZK KARLSRUHE       16/07/99
C=======================================================================

      SUBROUTINE RHO0DC

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 SUBROUTINE IS CALLED FROM RHOGEN.
C
C  DESIGN  : D. HECK    IK3  FZK KARLSRUHE
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,CONSTA.
      COMMON /CONSTA/  PI,PI2,OB3,TB3,ENEPER
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER
*KEEP,GENER.
      COMMON /GENER/   GEN,ALEVEL
      DOUBLE PRECISION GEN,ALEVEL
*KEEP,LONGI.
      COMMON /LONGI/   ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP,LLONGI,FLGFIT
      DOUBLE PRECISION ADLONG(0:1170,9),AELONG(0:1170,9),
     *                 APLONG(0:1170,9),DLONG(0:1170,9),ELONG(0:1170,9),
     *                 HLONG(0:1170),PLONG(0:1170,9),SDLONG(0:1170,9),
     *                 SELONG(0:1170,9),SPLONG(0:1170,9),THSTEP,THSTPI
      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT
*KEEP,PAM.
      COMMON /PAM/     PAMA,SIGNUM,RESTMS
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000)
*KEEP,PARPAR.
      COMMON /PARPAR/  CURPAR,SECPAR,PRMPAR,OUTPAR,C,
     *                 E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
      DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16),
     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH
      INTEGER          ITYPE,LEVL
*KEEP,RANDPA.
      COMMON /RANDPA/  FAC,U1,U2,RD,NSEQ,ISEED,KNOR
      DOUBLE PRECISION FAC,U1,U2
      REAL             RD(3000)
      INTEGER          ISEED(103,10),NSEQ
      LOGICAL          KNOR
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEEP,STACKE.
      COMMON /STACKE/  E,TIM,U,V,W,X,Y,Z,DNEAR,
     *                 ZAP,WAP,WA,
     *                 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)
     *                 ,ZAP(60),WAP(60),WA(60)
      INTEGER          IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP
*KEND.

      DOUBLE PRECISION AUX2A,BETA,COSTCM,COSTH3,COSTH4,
     *                 GAMMA3,GAMMA4,PHI4,WORK1,WORK2
      INTEGER          I
      SAVE
C-----------------------------------------------------------------------

      IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=1,9)
  444 FORMAT(' RHO0DC: CURPAR=',1P,8E10.3,0P,F10.0)

C  COPY VERTEX COORDINATES INTO SECPAR
      DO 10  I = 5,8
        SECPAR(I) = CURPAR(I)
 10   CONTINUE
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
      SECPAR(14) = CURPAR(14)
      SECPAR(15) = CURPAR(15)
      SECPAR(16) = CURPAR(16)

C  CALCULATE AUXILIARY QUANTITIES
      BETA   = SQRT( CURPAR(2)**2 - 1.D0 ) / CURPAR(2)
      AUX2A  = 0.5D0 * PAMA(51) / PAMA(8)
      WORK1  = CURPAR(2) * AUX2A
      WORK2  = BETA * CURPAR(2) * SQRT( AUX2A**2 - 1.D0 )

C  DETERMINE POLAR ANGLE IN CM SYSTEM WITH DIPOLE CHARACTERISTICS
C  PURE DIPOLE RADIATION: W(COSTH) = 1-3/5*COSTH**2
 210  CONTINUE
      CALL RMMAR( RD,2,1 )
      COSTCM = 2.D0 * RD(1) - 1.D0

C  PARAMETRIZATION FROM H1 COLLAB. [NUCL.PYS. B463(1996)3]
C  THIS PARAMETRIZATION 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  PARAMETRIZATION FROM ZEUSS COLLAB. [Z.PHYS. C69(1995)39]
      IF ( RD(2) .GT. 1.D0 - 0.8836D0 * COSTCM**2 ) GOTO 210

      GAMMA3 = WORK1 + WORK2 * COSTCM
C  SECOND PRODUCT PARTICLE  IS PI(-)
      GAMMA4 = CURPAR(2) * (PAMA(51)/PAMA(8)) - GAMMA3
      COSTH4 = MIN( 1.D0, (CURPAR(2)*GAMMA4 - AUX2A)
     *                  / (BETA * CURPAR(2) * SQRT(GAMMA4**2 - 1.D0)) )
      CALL RMMAR( RD,1,1 )
      PHI4 = RD(1)*PI2
      CALL ADDANG(CURPAR(3),CURPAR(4), COSTH4,PHI4, SECPAR(3),SECPAR(4))
      IF ( SECPAR(3) .GT. C(29) ) THEN
        SECPAR(1) = 9.D0
        SECPAR(2) = GAMMA4
        IF ( DEBUG ) WRITE(MDEBUG,445) (SECPAR(I),I=1,9)
  445   FORMAT(' RHO0DC: SECPAR=',1P,8E10.3,0P,F10.0)
        CALL TSTACK
      ELSE
        IF ( LLONGI ) THEN
C  ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT
          DLONG(LPCTE(NP),7) = DLONG(LPCTE(NP),7) + GAMMA4 * PAMA(8)
        ENDIF
      ENDIF
C  FIRST PRODUCT PARTICLE IS PI(+)
      COSTH3 = MIN( 1.D0, (CURPAR(2) * GAMMA3 - AUX2A)
     *                  / (BETA * CURPAR(2) * SQRT(GAMMA3**2 - 1.D0)) )
      CALL ADDANG( CURPAR(3),CURPAR(4), COSTH3,PHI4+PI,
     *                                            SECPAR(3),SECPAR(4) )
      IF ( SECPAR(3) .GT. C(29) ) THEN
        SECPAR(1) = 8.D0
        SECPAR(2) = GAMMA3
        IF ( DEBUG ) WRITE(MDEBUG,445) (SECPAR(I),I=1,9)
        CALL TSTACK
      ELSE
        IF ( LLONGI ) THEN
C  ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT
          DLONG(LPCTE(NP),7) = DLONG(LPCTE(NP),7) + GAMMA3 * PAMA(8)
        ENDIF
      ENDIF

      RETURN
      END
*CMZ :          20/06/2000  15.00.27  by  D. HECK IK3 FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
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  AND INRTAB.
C  ARGUMENT:
C   ARG    = HEIGHT IN CM
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,ATMOS.
      COMMON /ATMOS/   AATM,AATM0,BATM,BATM0,CATM,CATM0,DATM,MODATM
      DOUBLE PRECISION AATM(5),AATM0(5,0:16),BATM(5),BATM0(5,0:16),
     *                 CATM(5),CATM0(5,0:16),DATM(5)
      INTEGER          MODATM
*KEEP,ATMOS2.
      COMMON /ATMOS2/  HLAY,HLAY0,THICKL,LAYNO,LAYNEW
      DOUBLE PRECISION HLAY(6),HLAY0(5,0:4),THICKL(5)
      INTEGER          LAYNO(0:16)
      LOGICAL          LAYNEW
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEEP,ATMOSX.
C  EXTERNAL ATMOSPHERIC MODELS
      COMMON /ATMOSX/  IATMOX,FREFRX
      INTEGER          IATMOX
      LOGICAL          FREFRX
*KEND.

      DOUBLE PRECISION ARG
      DOUBLE PRECISION RHOFX
      EXTERNAL         RHOFX
      SAVE
C-----------------------------------------------------------------------

CC    IF ( DEBUG ) WRITE(MDEBUG,*) 'RHOF  : ARG=',SNGL(ARG)

      IF ( IATMOX .GE. 1 ) THEN
        RHOF = RHOFX(ARG)
        RETURN
      ENDIF

      IF     ( ARG .LT. HLAY(2) ) THEN
        RHOF = BATM(1) * DATM(1) * EXP ( (-ARG) * DATM(1) )
      ELSEIF ( ARG .LT. HLAY(3) ) THEN
        RHOF = BATM(2) * DATM(2) * EXP ( (-ARG) * DATM(2) )
      ELSEIF ( ARG .LT. HLAY(4) ) THEN
        RHOF = BATM(3) * DATM(3) * EXP ( (-ARG) * DATM(3) )
      ELSEIF ( ARG .LT. HLAY(5) ) THEN
        RHOF = BATM(4) * DATM(4) * EXP ( (-ARG) * DATM(4) )
      ELSE
        RHOF = DATM(5)
      ENDIF

      RETURN
      END
*CMZ :          27/02/2002  16.27.13  by  D. HECK IK FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
C=======================================================================

      SUBROUTINE RMMAQ( ISEED,ISEQ,CHOPT )

C-----------------------------------------------------------------------
C  R(ANDO)M (NUMBER GENERATOR OF) MA(RSAGLIA TYPE INITIALIZATION)
C
C  ROUTINE FOR INITIALIZATION OF RMMAR
C  THIS SUBROUTINE IS CALLED FROM AAMAIN AND START.
C  ARGUMENTS:
C   ISEED  = SEED TO INITIALIZE A SEQUENCE
C   ISEQ   = # OF RANDOM SEQUENCE
C   CHOPT  = CHARACTER TO STEER INITIALIZE OPTIONS
C
C  CERN PROGLIB# V113    RMMAQ           .VERSION KERNFOR  1.0
C  ORIG. 01/03/89 FCA + FJ
C-----------------------------------------------------------------------

      COMMON /RANMA2/ IU(1030),JSEQ
      COMMON /RANMA3/ TWOM24,TWOM48,CD,CM,CINT,MODCNS
      INTEGER I97(0:1030),J97(0:1030),NTOT(0:1030),NTOT2(0:1030),
     *        IJKL(0:1030)
      REAL    U(1030),C(0:1030),UU(1030)
      EQUIVALENCE (IJKL(0),IU(1)),(NTOT(0),IU(2)),(NTOT2(0),IU(3))
      EQUIVALENCE (U(1),IU(4)),(C(0),IU(101)),(I97(0),IU(102))
      EQUIVALENCE (J97(0),IU(103))
      INTEGER     ISEED(*)
      CHARACTER   CHOPT*(*), CCHOPT*12
      LOGICAL     FIRST
      SAVE        UU,FIRST,CCHOPT
      DATA        FIRST / .TRUE. /
C-----------------------------------------------------------------------

      IF ( FIRST ) THEN
        TWOM24 = 2.**(-24)
        TWOM48 = 2.**(-48)
        CD     = 7654321.*TWOM24
        CM     = 16777213.*TWOM24
        CINT   = 362436.*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 ) JSEQ = ISEQ
        IBASE = (JSEQ-1)*103
        IF ( INDEX(CCHOPT,'V') .NE. 0 ) THEN
          DO 10  JJ = 1,103
            IU(IBASE+JJ) = ISEED(JJ)
  10      CONTINUE
        ELSE
          IJKL(IBASE)  = ISEED(1)
          NTOT(IBASE)  = ISEED(2)
          NTOT2(IBASE) = ISEED(3)
          IJ = IJKL(IBASE) / 30082
          KL = IJKL(IBASE) - 30082*IJ
          I  = MOD(IJ/177, 177) + 2
          J  = MOD(IJ, 177)     + 2
          K  = MOD(KL/169, 178) + 1
          L  = MOD(KL, 169)
          DO 30  II = 1,97
            S = 0.
            T = .5
            DO 20  JJ = 1,24
              M = MOD(MOD(I*J,179)*K, 179)
              I = J
              J = K
              K = M
              L = MOD(53*L+1, 169)
              IF ( MOD(L*M,64) .GE. 32 ) S = S+T
              T = 0.5*T
  20        CONTINUE
            UU(II) = S
  30      CONTINUE
          CC   = CINT
          II97 = 97
          IJ97 = 33
C  COMPLETE INITIALIZATION BY SKIPPING (NTOT2*MODCNS+NTOT) RANDOMNUMBERS
          NITER = MODCNS
          DO 50  LOOP2 = 1,NTOT2(IBASE)+1
            IF ( LOOP2 .GT. NTOT2(IBASE) ) NITER = NTOT(IBASE)
            DO 40  IDUM = 1,NITER
              UNI = UU(II97)-UU(IJ97)
              IF ( UNI .LT. 0. ) UNI = UNI+1.
              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. ) CC = CC+CM
   40       CONTINUE
   50     CONTINUE
          I97(IBASE) = II97
          J97(IBASE) = IJ97
          C(IBASE)   = CC
          DO 60  JJ = 1,97
            U(IBASE+JJ) = UU(JJ)
  60      CONTINUE
        ENDIF
      ELSEIF ( INDEX(CCHOPT,'R') .NE. 0 ) THEN
        IF ( ISEQ .GT. 0 ) THEN
          JSEQ = ISEQ
        ELSE
          ISEQ = JSEQ
        ENDIF
        IBASE = (JSEQ-1)*103
        IF ( INDEX(CCHOPT,'V') .NE. 0 ) THEN
          NCOPY = 103
        ELSE
          NCOPY = 3
        ENDIF
        DO 70  JJ = 1,NCOPY
          ISEED(JJ) = IU(IBASE+JJ)
  70    CONTINUE
      ENDIF
      RETURN
      END
*CMZ :          28/02/2002  13.08.19  by  D. HECK IK FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
C=======================================================================

      SUBROUTINE RMMAR( RVEC,LENV,ISEQ )

C-----------------------------------------------------------------------
C  R(ANDO)M (NUMBER GENERATOR OF) MAR(SAGLIA TYPE)
C
C  THESE ROUTINES (RMMAR,RMMAQ) ARE TAKEN FROM THE CERN LIBRARIES
C  DESCRIPTION OF ALGORITHM SEE THERE
C  THIS SUBROUTINE IS CALLED FROM MANY ROUTINES.
C  ARGUMENTS:
C   RVEC   = 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  CERN PROGLIB# V113    RMMAR           .VERSION KERNFOR  1.0
C  ORIG. 01/03/89 FCA + FJ
C-----------------------------------------------------------------------

      REAL RVEC(*)
      COMMON /RANMA2/ IU(1030),JSEQ
      COMMON /RANMA3/ TWOM24,TWOM48,CD,CM,CINT,MODCNS
      INTEGER I97(0:1030),J97(0:1030),NTOT(0:1030),NTOT2(0:1030),
     *        IJKL(0:1030)
      REAL    U(1030),C(0:1030)
      EQUIVALENCE (IJKL(0),IU(1)),(NTOT(0),IU(2)),(NTOT2(0),IU(3))
      EQUIVALENCE (U(1),IU(4)),(C(0),IU(101)),(I97(0),IU(102))
      EQUIVALENCE (J97(0),IU(103))
      SAVE
C-----------------------------------------------------------------------

      IF ( ISEQ .GT. 0 ) JSEQ = ISEQ
      IBASE = (JSEQ-1)*103

      DO 100  IVEC = 1,LENV
        UNI = U(IBASE+I97(IBASE))-U(IBASE+J97(IBASE))
        IF ( UNI .LT. 0. ) UNI = UNI+1.
        U(IBASE+I97(IBASE)) = UNI
        I97(IBASE) = I97(IBASE)-1
        IF ( I97(IBASE) .EQ. 0 ) I97(IBASE) = 97
        J97(IBASE) = J97(IBASE)-1
        IF ( J97(IBASE) .EQ. 0 ) J97(IBASE) = 97
        C(IBASE)   = C(IBASE) - CD
        IF ( C(IBASE) .LT. 0. ) C(IBASE) = C(IBASE)+CM
        UNI = UNI-C(IBASE)
        IF ( UNI .LT. 0. ) UNI = UNI+1.
C  REPLACE EXACT ZEROES BY UNIFORM DISTR. *2**-24
        IF ( UNI .EQ. 0. ) THEN
          UNI = TWOM24*U(2)
C  AN EXACT ZERO HERE IS VERY UNLIKELY, BUT LET'S BE SAFE.
          IF ( UNI .EQ. 0. ) UNI = TWOM48
        ENDIF
        RVEC(IVEC) = UNI
  100 CONTINUE

      NTOT(IBASE) = NTOT(IBASE) + LENV
      IF ( NTOT(IBASE) .GE. MODCNS ) THEN
        NTOT2(IBASE) = NTOT2(IBASE) + 1
        NTOT(IBASE)  = NTOT(IBASE) - MODCNS
      ENDIF

      RETURN
      END
*CMZ :          28/02/2002  13.12.11  by  D. HECK IK FZK KARLSRUHE
*-- Author :    D. HECK IK3 FZK KARLSRUHE       27/04/94
C=======================================================================

      SUBROUTINE SDPM

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
C  REDESIGN: D. HECK    IK3  FZK KARLSRUHE
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,AIR.
      COMMON /AIR/     COMPOS,PROBTA,AVERAW,AVOGAD
      DOUBLE PRECISION COMPOS(3),PROBTA(3),AVERAW,AVOGAD
*KEEP,CONSTA.
      COMMON /CONSTA/  PI,PI2,OB3,TB3,ENEPER
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER
*KEEP,DPMFLG.
      COMMON /DPMFLG/  NFLAIN,NFLDIF,NFLPI0,NFLCHE,NFLPIF,NFRAGM
      INTEGER          NFLAIN,NFLDIF,NFLPI0,NFLCHE,NFLPIF,NFRAGM
*KEEP,GENER.
      COMMON /GENER/   GEN,ALEVEL
      DOUBLE PRECISION GEN,ALEVEL
*KEEP,INTER.
      COMMON /INTER/   AVCH,AVCH3,DC0,DLOG,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,DLOG,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
*KEEP,ISTA.
      COMMON /ISTA/    IFINET,IFINNU,IFINKA,IFINPI,IFINHY
      INTEGER          IFINET,IFINNU,IFINKA,IFINPI,IFINHY
*KEEP,LONGI.
      COMMON /LONGI/   ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP,LLONGI,FLGFIT
      DOUBLE PRECISION ADLONG(0:1170,9),AELONG(0:1170,9),
     *                 APLONG(0:1170,9),DLONG(0:1170,9),ELONG(0:1170,9),
     *                 HLONG(0:1170),PLONG(0:1170,9),SDLONG(0:1170,9),
     *                 SELONG(0:1170,9),SPLONG(0:1170,9),THSTEP,THSTPI
      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT
*KEEP,MULT.
      COMMON /MULT/    EKINL,MSMM,MULTMA,MULTOT
      DOUBLE PRECISION EKINL
      INTEGER          MSMM,MULTMA(40,13),MULTOT(40,13)
*KEEP,NCSNCS.
      COMMON /NCSNCS/  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)
*KEEP,PAM.
      COMMON /PAM/     PAMA,SIGNUM,RESTMS
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000)
*KEEP,PARPAR.
      COMMON /PARPAR/  CURPAR,SECPAR,PRMPAR,OUTPAR,C,
     *                 E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
      DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16),
     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH
      INTEGER          ITYPE,LEVL
*KEEP,PARPAE.
      DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM
     *                 ,WEIGHT
     *                 ,HAPP,COSTAP,COSTEA
      EQUIVALENCE      (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE),
     *                 (CURPAR(4), PHI   ), (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)
*KEEP,RANDPA.
      COMMON /RANDPA/  FAC,U1,U2,RD,NSEQ,ISEED,KNOR
      DOUBLE PRECISION FAC,U1,U2
      REAL             RD(3000)
      INTEGER          ISEED(103,10),NSEQ
      LOGICAL          KNOR
*KEEP,REST.
      COMMON /REST/    CONTNE,TAR,LT
      DOUBLE PRECISION CONTNE(3),TAR
      INTEGER          LT
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEEP,SIGM.
      COMMON /SIGM/    SIGMA,SIGANN,SIGAIR,FRACTN,FRCTNO
      DOUBLE PRECISION SIGMA,SIGANN,SIGAIR,FRACTN,FRCTNO
*KEEP,VKIN.
      COMMON /VKIN/    BETACM
      DOUBLE PRECISION BETACM
*KEEP,VENUS.
      COMMON /VENUS/   ISH00,IVERVN,MTAR99,FVENUS,FVENSG
      INTEGER          ISH00,IVERVN,MTAR99
      LOGICAL          FVENUS,FVENSG
*KEND.

      DOUBLE PRECISION PFRX(60),PFRY(60)
      DOUBLE PRECISION COSTET,EA,P,PHIV,PTM,PT2,
     *                 SIGMAA,SIGMAN,SIGMAO,SIG45,S45SQ,S4530
      DOUBLE PRECISION CGHSIG
      DOUBLE PRECISION EKIN

      INTEGER          ITYP(60),I,IA,IANEW,INACTA,INACTZ,INDEX,INEUTR,
     *                 IZ,IZNEW,J,JFIN,KNEW,L,LL,NPRPRO,NNEPRO
      SAVE
      EXTERNAL         CGHSIG
C-----------------------------------------------------------------------

      IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=1,9)
  444 FORMAT(' SDPM  : CURPAR=',1P,9E10.3)

C  IA IS MASS NUMBER OF PROJECTILE
      IA = ITYPE / 100
      IF ( IA .GT. 56 ) THEN
        WRITE(MONIOU,444) (CURPAR(I),I=1,9)
        WRITE(MONIOU,*) 'SDPM  : NOT FORESEEN PARTICLE TYPE=',ITYPE
        STOP
      ENDIF

C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  TREATMENT OF GAMMAS COMING FROM EGS4 (PIGEN)
      IF     ( ITYPE .EQ. 1 ) THEN
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 RMMAR( RD,1,1 )
        IF     ( RD(1)*SIGAIR .LE. FRACTN ) THEN
C  INTERACTION WITH NITROGEN
          LT  = 1
          TAR = 14.D0
        ELSEIF ( RD(1)*SIGAIR .LE. FRCTNO ) THEN
C  INTERACTION WITH OXYGEN
          LT  = 2
          TAR = 16.D0
        ELSE
C  INTERACTION WITH ARGON
          LT  = 3
          TAR = 40.D0
        ENDIF

C  GAMMAS ARE TREATED BY VENUS, IF SUFFICIENT ENERGY
        IF ( FVENUS  .AND.  CURPAR(2) .GT. HILOELB ) THEN
          CALL VENLNK
        ELSE
          CALL HDPM
        ENDIF

C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  NORMAL HADRON PROJECTILE
      ELSEIF ( ITYPE .LT. 100 ) THEN

C  WITH WHAT KIND OF TARGET DOES PROJECTILE INTERACT?
        IF ( FIXTAR ) THEN
C  TARGET OF FIRST INTERACTION IS FIXED
          LT = N1STTR
          IF     ( N1STTR .EQ. 1 ) THEN
            TAR = 14.D0
          ELSEIF ( N1STTR .EQ. 2 ) THEN
            TAR = 16.D0
          ELSE
            TAR = 40.D0
          ENDIF
          FIXTAR = .FALSE.
C  AUXIL. QUANTITIES FOR INTERPOLATION
          SIG45  = SIGMA - 45.D0
          S45SQ  = SIG45**2 / 450.D0
          S4530  = SIG45 / 30.D0
        ELSE
C  TARGET IS CHOSEN AT RANDOM ACCORDING TO CROSS-SECTION
C  SIGAIR, FRACTN, FRCTNO HAVE BEEN DETERMINED IN BOX2/VENSIG
          IF ( FVENSG ) GOTO 333
C  SIGMA IS ENERGY DEPENDENT INELASTIC NUCLEON-NUCLEON CROSS-SECTION
C  AND IS SET IN BOX2
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 RMMAR( RD,1,1 )
          IF ( DEBUG ) WRITE(MDEBUG,*) 'SDPM  : FRACTN=',SNGL(FRACTN),
     *                           ' FRCTNO=',SNGL(FRCTNO),' RD=',RD(1)
          IF     ( RD(1)*SIGAIR .LE. FRACTN ) THEN
C  INTERACTION WITH NITROGEN
            LT  = 1
            TAR = 14.D0
          ELSEIF ( RD(1)*SIGAIR .LE. FRCTNO ) THEN
C  INTERACTION WITH OXYGEN
            LT  = 2
            TAR = 16.D0
          ELSE
C  INTERACTION WITH ARGON
            LT  = 3
            TAR = 40.D0
          ENDIF
        ENDIF

        IF ( FVENUS ) THEN
C  MESONS, NUCLEONS AND STRANGE BARYONS ARE TREATED BY VENUS (JAN 95)
          IF ( ITYPE .GE. 7  .AND.  ITYPE .LE. 32 ) THEN
            CALL VENLNK
          ELSE
            CALL HDPM
          ENDIF
        ELSE
          CALL HDPM
        ENDIF

C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  HEAVY PRIMARY 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
          LT = 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 RMMAR( 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 PRIMARY/FRAGMENT
C  SIGMA IS ENERGY DEPENDENT INELASTIC NUCLEON-NUCLEON CROSS-SECTION
C  AND IS SET IN BOX2/VENSIG
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 RMMAR( RD,2,1 )
          IF ( DEBUG ) WRITE(MDEBUG,*) 'SDPM  : FRACTN=',SNGL(FRACTN),
     *                           ' FRCTNO=',SNGL(FRCTNO),' RD=',RD(1)
          IF     ( RD(1)*SIGAIR .LE. FRACTN ) THEN
C  INTERACTION WITH NITROGEN
            LT  = 1
            TAR = 14.D0
          ELSEIF ( RD(1)*SIGAIR .LE. FRCTNO ) THEN
C  INTERACTION WITH OXYGEN
            LT  = 2
            TAR = 16.D0
          ELSE
C  INTERACTION WITH ARGON
            LT  = 3
            TAR = 40.D0
          ENDIF
        ENDIF
C  TREAT NUCLEUS BY VENUS, IF SELECTED AND ENERGY/NUCLEON HIGH ENOUGH
        IF ( FVENUS  .AND.  PAMA(ITYPE)*GAMMA .GT. HILOELB*IA ) THEN
          CALL VENLNK
          RETURN
        ENDIF

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  LT     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 100  J = 1,IA-1
          INACTA = J
          INDEX  = IA * (IA-3) * 0.5 + 1 + J
          P = ( 1.D0 - S45SQ *2.D0 ) * PNOA45(INDEX,LT)
     *            +( S45SQ - S4530 ) * PNOA30(INDEX,LT)
     *            +( S45SQ + S4530 ) * PNOA60(INDEX,LT)
          IF ( RD(2) .LT. P ) GOTO 110
  100   CONTINUE
C  ALL NUCLEONS INTERACT  (INACTA EQUAL IA)
        INACTA = INACTA + 1

  110   CONTINUE
        IANEW  = IA - INACTA

C  REMAINING PROJECTILE WITH IANEW NUCLEONS
        DO 120  L = 2,4
          SECPAR(L) = CURPAR(L)
  120   CONTINUE

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( IZ-IZNEW, 0 )

          IF ( IZNEW .GT. 0 ) THEN
C  PROTONS
            SECPAR(1) = 14.D0
            DO 300  L = 1,IZNEW
              CALL TSTACK
  300       CONTINUE
          ENDIF
          IF ( INEUTR .GT. 0 ) THEN
C  NEUTRONS
            SECPAR(1) = 13.D0
            DO 310  L = 1,INEUTR
              CALL TSTACK
  310       CONTINUE
          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=1,9)
  554       FORMAT(' SDPM  : CURPAR=',1P,9E10.3)
            KNEW = 0

C  REMAINING NUCLEUS IS A NUCLEON
          ELSEIF ( IANEW .EQ. 1 ) THEN
            CALL RMMAR( 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 = FLOAT(IANEW) / 2.15D0 + 0.7D0
            INACTZ = MAX( IZ - IZNEW, 0 )
            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,SNGL(EA)
                PTM = EA**2 - PAMA(ITYP(J))**2
                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 )
                ELSE
                  COSTET = 1.D0
                ENDIF
                IF ( PFRX(J) .NE. 0.D0  .OR.  PFRY(J) .NE. 0.D0 ) THEN
                  PHIV = ATAN2( PFRY(J), PFRX(J) )
                ELSE
                  PHIV = 0.D0
                ENDIF
                CALL ADDANG( COSTHE,PHI, COSTET,PHIV,
     *                                           SECPAR(3),SECPAR(4) )
                IF ( SECPAR(3) .GT. C(29) ) THEN
                  IF ( J .LT. JFIN ) THEN
                    SECPAR(1) = 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,7) = DLONG(LHEIGH,7) + EA
                  ENDIF
                ENDIF
 135          CONTINUE
            ENDIF
          ENDIF

C  REMAINING NUCLEUS: MASS 5 CANNOT BE TREATED IN BOX2
          IF     ( KNEW/100 .EQ. 5 ) THEN
            IF ( MOD(KNEW,100) .GE. 3 ) THEN
C  MASS 5: SPLIT OFF ONE PROTON
              SECPAR(1) = 14.D0
              CALL TSTACK
              KNEW = KNEW - 101
            ELSE
C  MASS 5: SPLIT OFF ONE NEUTRON
              SECPAR(1) = 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(1) = 14.D0
              CALL TSTACK
              KNEW = KNEW - 101
            ELSEIF ( MOD(KNEW,100) .LE. 3 ) THEN
C  MASS 8: SPLIT OFF ONE NEUTRON
              SECPAR(1) = 13.D0
              CALL TSTACK
              KNEW = KNEW - 100
            ELSE
C  MASS 8: SPLIT OFF ONE ALPHA PARTICLE
              SECPAR(1) = 402.D0
              CALL TSTACK
              KNEW = KNEW - 402
            ENDIF
          ENDIF

          IF ( KNEW .GT. 0 ) THEN
            SECPAR(1) = KNEW
              CALL TSTACK
            IF ( DEBUG ) WRITE(MDEBUG,555) (SECPAR(I),I=1,9)
 555        FORMAT (' SDPM  : SECPAR=',1P,8E10.3,0P,F10.0)
          ENDIF
        ENDIF

C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  HERE THE REACTING NUCLEONS ARE TREATED
 190    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(1) = 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( 1.D0 - 1.D0 / GCM**2 )
          DO 200  LL = 1,NNEPRO
            IF ( ECM .LE. HILOECM ) THEN
C  USE GHEISHA AND CALCULATE THE CROSS-SECTION FOR GHEISHA
              ELAB = PAMA(ITYPE) *  GAMMA
              PLAB = ELAB * BETA
              EKIN = ELAB - PAMA(ITYPE)
              SIGAIR = CGHSIG(SNGL(PLAB),SNGL(EKIN),ITYPE)
              IF ( DEBUG ) WRITE(MDEBUG,*)
     *                     'SDPM  : SIGAIR=',SNGL(SIGAIR)
              CALL CGHEI
            ELSE
C  DUAL PARTON MODEL
              CALL HDPM
            ENDIF
 200      CONTINUE
        ENDIF

C  TREAT INTERACTING PROTONS FROM PROJECTILE IN SUBROUT. HDPM
        IF ( NPRPRO .GE. 1 ) THEN
          CURPAR(1) = 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( 1.D0 - 1.D0 / GCM**2 )
          DO 210  LL = 1,NPRPRO
            IF ( ECM .LE. HILOECM ) THEN
C  USE GHEISHA AND CALCULATE THE CROSS-SECTION FOR GHEISHA
              ELAB = PAMA(ITYPE) *  GAMMA
              PLAB = ELAB * BETA
              EKIN = ELAB - PAMA(ITYPE)
              SIGAIR = CGHSIG(SNGL(PLAB),SNGL(EKIN),ITYPE)
              IF ( DEBUG ) WRITE(MDEBUG,*)
     *                     'SDPM  : SIGAIR=',SNGL(SIGAIR)
              CALL CGHEI
            ELSE
C  DUAL PARTON MODEL
              CALL HDPM
            ENDIF
 210      CONTINUE
        ENDIF

C  ALL PARTICLES, INCLUDING THE LEADING ONE, ARE NOW WRITTEN TO STACK

      ELSE
        WRITE(MONIOU,444) (CURPAR(I),I=1,9)
        WRITE(MONIOU,*) 'SDPM  : NOT FORESEEN PARTICLE TYPE=',ITYPE
        STOP
      ENDIF

      RETURN
      END
*CMZ :          15/06/2000  16.19.29  by  D. HECK IK3 FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
C=======================================================================

      SUBROUTINE SEKDAT( IJAHR,IMONA,ITAGE,ISTUN,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
C   IMONA  = MONTH
C   ITAGE  = DAY
C   ISTUN  = HOUR
C   IMINU  = MINUTE
C   ISEKU  = SECOND
C
C  DESIGN  : J. OEHLSCHLAEGER   IK3  FZK KARLSRUHE
C-----------------------------------------------------------------------

      IMPLICIT NONE

      REAL             RJAHR
      INTEGER          I,IJAHR,ILANG,ILEAP,IMINU,IMONA,ISECO,ISEKU,
     *                 ISTUN,ITAGE
      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
      ISTUN = MOD(ISECO,24)
      ISECO = ISECO/24
      ITAGE = ISECO
      RJAHR = 2.73785E-3*ITAGE+1.4E-3
      IJAHR = 1970 + INT(RJAHR)
C  LEAP DAYS
      ILEAP = 0
      ILANG = 1
      DO  1  I = 1970,IJAHR
        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. IJAHR ) THEN
            ILANG = 2
            ILEAP = ILEAP - 1
          ENDIF
        ENDIF
    1 CONTINUE
      ITAGE = ITAGE - INT(RJAHR)*365 - ILEAP + 1
      IF ( I .EQ. IJAHR+4  .AND.  ITAGE .LT. IMONS(3,2) ) ITAGE=ITAGE+1
C  MONTH AND DAY
      DO  2  I = 2,13
        IF ( IMONS(I,ILANG) .GT. ITAGE ) GOTO 3
    2 CONTINUE
    3 CONTINUE
      IMONA = I-1
      ITAGE = ITAGE-IMONS(IMONA,ILANG)
      IF ( ITAGE .EQ. 0 ) THEN
        ITAGE = IMONS(IMONA,2+ILANG)
        IMONA = IMONA - 1
      ENDIF
      RETURN
      END
*CMZ :          01/03/2002  14.34.22  by  D. HECK IK FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
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
*KEEP,ATMOS.
      COMMON /ATMOS/   AATM,AATM0,BATM,BATM0,CATM,CATM0,DATM,MODATM
      DOUBLE PRECISION AATM(5),AATM0(5,0:16),BATM(5),BATM0(5,0:16),
     *                 CATM(5),CATM0(5,0:16),DATM(5)
      INTEGER          MODATM
*KEEP,ATMOS2.
      COMMON /ATMOS2/  HLAY,HLAY0,THICKL,LAYNO,LAYNEW
      DOUBLE PRECISION HLAY(6),HLAY0(5,0:4),THICKL(5)
      INTEGER          LAYNO(0:16)
      LOGICAL          LAYNEW
*KEEP,EDECAY.
      COMMON /EDECAY/  CETA
      DOUBLE PRECISION CETA(5)
*KEEP,KAONS.
      COMMON /KAONS/   CKA
      DOUBLE PRECISION CKA(80)
*KEEP,PARPAR.
      COMMON /PARPAR/  CURPAR,SECPAR,PRMPAR,OUTPAR,C,
     *                 E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
      DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16),
     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH
      INTEGER          ITYPE,LEVL
*KEEP,PARPAE.
      DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM
     *                 ,WEIGHT
     *                 ,HAPP,COSTAP,COSTEA
      EQUIVALENCE      (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE),
     *                 (CURPAR(4), PHI   ), (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)
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEEP,STRBAR.
      COMMON /STRBAR/  CSTRBA
      DOUBLE PRECISION CSTRBA(11)
*KEEP,ATMOSX.
C  EXTERNAL ATMOSPHERIC MODELS
      COMMON /ATMOSX/  IATMOX,FREFRX
      INTEGER          IATMOX
      LOGICAL          FREFRX
*KEND.

      DOUBLE PRECISION HEIGH
      INTEGER          I
      SAVE
      EXTERNAL         HEIGH
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     ( IATMOX .GE.  1 ) THEN
        WRITE(MONIOU,299) IATMOX
  299   FORMAT('  ( EXTERNAL ATMOSPHERE FROM TABLE',I3,' AS FITTED )'/)
      ELSEIF ( 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 PARAMETRIZED BY LINSLEY )')
      ELSEIF ( MODATM .EQ.  2 ) THEN
        WRITE(MONIOU,302)
  302   FORMAT('  ( ATMOSPHERE AT115     PARAMETRIZED BY H. ULRICH )')
      ELSEIF ( MODATM .EQ.  3 ) THEN
        WRITE(MONIOU,303)
  303   FORMAT('  ( ATMOSPHERE AT223     PARAMETRIZED BY H. ULRICH )')
      ELSEIF ( MODATM .EQ.  4 ) THEN
        WRITE(MONIOU,304)
  304   FORMAT('  ( ATMOSPHERE AT511     PARAMETRIZED BY H. ULRICH )')
      ELSEIF ( MODATM .EQ.  5 ) THEN
        WRITE(MONIOU,305)
  305   FORMAT('  ( ATMOSPHERE AT616     PARAMETRIZED BY H. ULRICH )')
      ELSEIF ( MODATM .EQ.  6 ) THEN
        WRITE(MONIOU,306)
  306   FORMAT('  ( ATMOSPHERE AT822     PARAMETRIZED BY H. ULRICH )')
      ELSEIF ( MODATM .EQ.  7 ) THEN
        WRITE(MONIOU,307)
  307   FORMAT('  ( ATMOSPHERE AT1014    PARAMETRIZED BY H. ULRICH )')
      ELSEIF ( MODATM .EQ.  8 ) THEN
        WRITE(MONIOU,308)
  308   FORMAT('  ( ATMOSPHERE AT1224    PARAMETRIZED 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) )')

      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
*CMZ :          01/03/2002  14.34.22  by  D. HECK IK FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
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
*KEEP,AIR.
      COMMON /AIR/     COMPOS,PROBTA,AVERAW,AVOGAD
      DOUBLE PRECISION COMPOS(3),PROBTA(3),AVERAW,AVOGAD
*KEEP,ATMOS.
      COMMON /ATMOS/   AATM,AATM0,BATM,BATM0,CATM,CATM0,DATM,MODATM
      DOUBLE PRECISION AATM(5),AATM0(5,0:16),BATM(5),BATM0(5,0:16),
     *                 CATM(5),CATM0(5,0:16),DATM(5)
      INTEGER          MODATM
*KEEP,ATMOS2.
      COMMON /ATMOS2/  HLAY,HLAY0,THICKL,LAYNO,LAYNEW
      DOUBLE PRECISION HLAY(6),HLAY0(5,0:4),THICKL(5)
      INTEGER          LAYNO(0:16)
      LOGICAL          LAYNEW
*KEEP,BUFFS.
      COMMON /BUFFS/   RUNH,RUNE,EVTH,EVTE,DATAB,ARRAYLONG,LH
      INTEGER          MAXBUF,MAXLEN
      PARAMETER        (MAXLEN=16)
      PARAMETER        (MAXBUF=39*7)
      REAL             RUNH(MAXBUF),EVTH(MAXBUF),EVTE(MAXBUF),
     *                 RUNE(MAXBUF),DATAB(MAXBUF),ARRAYLONG(MAXBUF)
      INTEGER          LH
      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)
*KEEP,CONSTA.
      COMMON /CONSTA/  PI,PI2,OB3,TB3,ENEPER
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER
*KEEP,DPMFLG.
      COMMON /DPMFLG/  NFLAIN,NFLDIF,NFLPI0,NFLCHE,NFLPIF,NFRAGM
      INTEGER          NFLAIN,NFLDIF,NFLPI0,NFLCHE,NFLPIF,NFRAGM
*KEEP,EDECAY.
      COMMON /EDECAY/  CETA
      DOUBLE PRECISION CETA(5)
*KEEP,ELABCT.
      COMMON /ELABCT/  ELCUT
      DOUBLE PRECISION ELCUT(4)
*KEEP,ETHMAP.
      COMMON /ETHMAP/  ECTMAP,ELEFT
      DOUBLE PRECISION ECTMAP,ELEFT
*KEEP,KAONS.
      COMMON /KAONS/   CKA
      DOUBLE PRECISION CKA(80)
*KEEP,MAGNET.
      COMMON /MAGNET/  BX,BZ,BVAL,BNORMC,BNORM,COSB,SINB,BLIMIT
      DOUBLE PRECISION BX,BZ,BVAL,BNORMC,BNORM,COSB,SINB,BLIMIT
*KEEP,MUMULT.
      COMMON /MUMULT/  CHC,OMC,PHISCT,STEPL,VSCAT,FMOLI
      DOUBLE PRECISION CHC,OMC,PHISCT,STEPL,VSCAT
      LOGICAL          FMOLI
*KEEP,MUPART.
      COMMON /MUPART/  AMUPAR,BCUT,CMUON,FMUBRM,FMUORG
      DOUBLE PRECISION AMUPAR(16),BCUT,CMUON(11)
      LOGICAL          FMUBRM,FMUORG
*KEEP,NCSNCS.
      COMMON /NCSNCS/  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)
*KEEP,NKGI.
      COMMON /NKGI/    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)
*KEEP,OBSPAR.
      COMMON /OBSPAR/  OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP,
     *                 THETPR,PHIPR,
     *                 VUECON,
     *                 NOBSLV
      DOUBLE PRECISION OBSLEV(10),THCKOB(10),XOFF(10),YOFF(10),
     *                 HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2)
      DOUBLE PRECISION VUECON(2)
      INTEGER          NOBSLV
*KEEP,PAM.
      COMMON /PAM/     PAMA,SIGNUM,RESTMS
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000)
*KEEP,PARPAR.
      COMMON /PARPAR/  CURPAR,SECPAR,PRMPAR,OUTPAR,C,
     *                 E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
      DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16),
     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH
      INTEGER          ITYPE,LEVL
*KEEP,PARPAE.
      DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM
     *                 ,WEIGHT
     *                 ,HAPP,COSTAP,COSTEA
      EQUIVALENCE      (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE),
     *                 (CURPAR(4), PHI   ), (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)
*KEEP,PRIMSP.
      COMMON /PRIMSP/  PSLOPE,LLIMIT,ULIMIT,LL,UL,SLEX,ISPEC
      DOUBLE PRECISION PSLOPE,LLIMIT,ULIMIT,LL,UL,SLEX
      INTEGER          ISPEC
*KEEP,RANDPA.
      COMMON /RANDPA/  FAC,U1,U2,RD,NSEQ,ISEED,KNOR
      DOUBLE PRECISION FAC,U1,U2
      REAL             RD(3000)
      INTEGER          ISEED(103,10),NSEQ
      LOGICAL          KNOR
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEEP,STACKF.
      COMMON /STACKF/  STACK,MSTACKP,MEXST,NSHIFT,NOUREC,ICOUNT,
     *                 NTO,NFROM
      INTEGER          MAXSTK
      PARAMETER        (MAXSTK = 16*256*2)
      DOUBLE PRECISION STACK(MAXSTK)
      INTEGER          MSTACKP,MEXST,NSHIFT,NOUREC,ICOUNT,NTO,NFROM
*KEEP,STRBAR.
      COMMON /STRBAR/  CSTRBA
      DOUBLE PRECISION CSTRBA(11)
*KEEP,VERS.
      COMMON /VERS/    VERNUM,MVDATE,VERDAT
      DOUBLE PRECISION VERNUM
      INTEGER          MVDATE
      CHARACTER*18     VERDAT
*KEEP,VENUS.
      COMMON /VENUS/   ISH00,IVERVN,MTAR99,FVENUS,FVENSG
      INTEGER          ISH00,IVERVN,MTAR99
      LOGICAL          FVENUS,FVENSG
*KEEP,CEREN3.
      COMMON /CEREN3/  CERCNT,DATAB2,NRECER,LHCER
      INTEGER          MAXBF2
      PARAMETER        ( MAXBF2 = 39 * 7 )
      DOUBLE PRECISION CERCNT
      REAL             DATAB2(MAXBF2)
      INTEGER          NRECER,LHCER
*KEEP,ATMOSX.
C  EXTERNAL ATMOSPHERIC MODELS
      COMMON /ATMOSX/  IATMOX,FREFRX
      INTEGER          IATMOX
      LOGICAL          FREFRX
*KEND.

      DOUBLE PRECISION HEIGH,OOO,SE,TEMP1,TEMP2,TEMP3,THICK,
     *                 TTIME,ZE,ZS,ZX
      INTEGER          I,IA,J,L
      SAVE
      EXTERNAL         HEIGH,THICK
      CHARACTER*1      MARK
C-----------------------------------------------------------------------

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'/
     *' VENUS MODEL ACCORDING TO K. WERNER, UNIVERSITY NANTES, FRANCE'/
     *' HDPM MODEL ACCORDING TO J.N. CAPDEVIELLE, COLLEGE DE FRANCE,',
     *' PARIS, FRANCE'/
     *' GHEISHA ROUTINES ACCORDING TO H. FESEFELDT, RWTH AACHEN,',
     *' 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)'/
     *'             J. KNAPP, D. HECK, G. SCHATZ, REPORT FZKA',
     *     ' 5828 (1996)'/
     *'             SEE ALSO WEB PAGE  http://www-ik3.fzk.de/',
     *     '~heck/corsika'//)

      MARK = '1'

      WRITE(MONIOU,912) VERNUM,MARK,VERDAT
  912 FORMAT('             INSTITUT FUER KERNPHYSIK '/
     *       '             FORSCHUNGSZENTRUM KARLSRUHE'/
     *       '             POSTFACH 3640'/
     *       '             D-76021 KARLSRUHE'/
     *       '             GERMANY'//
     *       ' IN CASE OF PROBLEMS CONTACT:   DIETER HECK '/
     *       '                      E-MAIL:   DIETER.HECK@IK.FZK.DE'/
     *       '                         FAX:   (49) 7247-82-4075 '/
     *       '                       PHONE:   (49) 7247-82-3777 '//
     *       ' NUMBER OF VERSION : ',F6.3,A1/
     *       ' DATE   OF VERSION : ',A18 /)

      WRITE(MONIOU,*) 'VERSION GENERATED FOR UNIX OR COMPATIBLE SYSTEMS'
      WRITE(MONIOU,*) '^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^'
      WRITE(MONIOU,*) ' (RECL IS DEFINED IN BYTES)'
      WRITE(MONIOU,*) ' WITH TIMERC DATE ROUTINE'

      WRITE(MONIOU,*) ' '

      WRITE(MONIOU,1413)
 1413 FORMAT(/' INTERFACE FOR EXTERNAL ATMOSPHERIC PROFILES ENABLED'/
     *        ' ==================================================='/)
      WRITE(MONIOU,*) ' '
      WRITE(MONIOU,141)
  141 FORMAT(/' CHERENKOV RADIATION IS GENERATED'/
     *        ' ================================'/)
      WRITE(MONIOU,*) ' '
      WRITE(MONIOU,119)
  119 FORMAT(/' CURVED VERSION WITH SLIDING PLANAR ATMOSPHERE'/
     *        ' ============================================='/)
      WRITE(MONIOU,1432)
 1432 FORMAT(/' PRIMARY DIRECTION IS SELECTED FROM VIEWING CONE'/
     *        ' ==============================================='/)
      WRITE(MONIOU,*) 'ZENITH ANGLE DEPENDENCE FOR FLAT DETECTOR ARRAY'
      WRITE(MONIOU,*) ' '
      WRITE(MONIOU,*) ' '
C

C  INITIALIZE ARRAY WITH PARTICLE MASSES
      CALL PAMAF

C  READ RUN STEERING DATA CARDS
      CALL DATAC

      IF ( FREFRX ) WRITE(MONIOU,144)
  144 FORMAT(/' ATMOSPHERIC REFRACTION IS TAKEN INTO ACCOUNT'/
     *        ' ============================================'/)
      WRITE(MONIOU,1441)
 1441 FORMAT(/)

C  ORDERING OF OBSERVATION LEVELS FROM TOP TO BOTTOM
      IF ( NOBSLV .GT. 1 ) THEN
  215 CONTINUE
        DO 11  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
   11   CONTINUE
      ENDIF

C  PREPARE ATMOSPHERIC MODEL
      IF ( MODATM .LT. 0  .OR.  MODATM .GT. 16 ) THEN
        WRITE(MONIOU,*) 'START: MODATM < 0 OR > 16 NOT POSSIBLE! STOP'
        WRITE(MONIOU,*) 'PLEASE READ THE USERS GUIDE'
        WRITE(MONIOU,*) 'SEE KEYWORD: ATMOD'
        STOP
      ENDIF
C  SET LOWER BOUNDARIES OF THE AIR LAYERS
      IF ( LAYNEW ) THEN
C  TAKE THE BOUNDARIES READ IN
        I = 0
      ELSE
C  TAKE THE DEFAULT BOUNDARIES
        I = LAYNO(MODATM)
      ENDIF
C  SET THE SELECTED ATMOSPHERE AND LAYERS
      DO   L = 1,5
        HLAY(L) = HLAY0(L,I)
        AATM(L) = AATM0(L,MODATM)
        BATM(L) = BATM0(L,MODATM)
        CATM(L) = CATM0(L,MODATM)
        DATM(L) = 1.D0 / CATM(L)
      ENDDO

C  SET THE ATMOSPHERIC MODEL NUMBER, READING AN EXTERNAL FILE IF NEEDED.
C  PARAMETERS FOR TAKING REFRACTION INTO ACCOUNT ARE CALCULATED EVEN
C  FOR CORSIKA BUILT-IN MODELS.
      IF ( IATMOX .GE. 1  .OR.  FREFRX ) THEN
        CALL ATMSET(IATMOX,OBSLEV(NOBSLV))
      ENDIF
C  FOR AN EXTERNAL ATMOSPHERE, FIT PARAMETERS USED IN CORSIKA-EGS PART.
      IF ( IATMOX .GE. 1 ) THEN
        IF ( LAYNEW ) THEN
          CALL ATMFIT(-5,HLAY,AATM,BATM,CATM)
        ELSE
          CALL ATMFIT(5,HLAY,AATM,BATM,CATM)
        ENDIF
        DO   L = 1,5
          DATM(L) = 1.D0 / CATM(L)
        ENDDO
      ENDIF
C  CALCULATE THICKNESS AT LOWER BOUNDARIES OF AIR LAYERS
      DO 100  L = 1,5
        THICKL(L) = THICK(HLAY(L))
 100  CONTINUE
      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,'  ',F11.2,'   ',F12.5,/),
     $          8X,'  6  ',F11.2,'        0.00000')

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

C  CLEARS BUFFERS FOR HEADER AND FILLS IN PERMANENT INFORMATION
      DO 889  L = 1,MAXBUF
        EVTH(L)  = 0.
        EVTE(L)  = 0.
        RUNH(L)  = 0.
        RUNE(L)  = 0.
        DATAB(L) = 0.
        ARRAYLONG(L) = 0.
        DATAB2(L) = 0.
  889 CONTINUE


C  PERMANENT INFORMATION
C  CHARACTER STRINGS
      CRUNH = 'RUNH'
      CRUNE = 'RUNE'
      CEVTH = 'EVTH'
      CEVTE = 'EVTE'
      CLONG = 'LONG'

      RUNH(2)  = NRRUN
      RUNE(2)  = NRRUN
      EVTH(44) = 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
      IF ( FEGS  .AND.  NSEQ .LT. 2 ) NSEQ = 2
C  CHERENKOV SELECTION DEMANDS ALWAYS EGS CALCULATION
      FEGS = .TRUE.
C  IN CASE OF CHERENKOV CALCULATIONS THE 3. RANDOM SEQUENCE IS NEEDED
      IF ( NSEQ .LT. 3 ) NSEQ = 3
      DO 281  I = 1,NSEQ
        IF ( .NOT. DEBUG   .AND.  .NOT. DEBDEL   .AND.
     *      (ISEED(2,I) .GT. 1000  .OR.  ISEED(3,I) .GT. 0) ) 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
        ENDIF
        CALL RMMAQ( ISEED(1,I), I, 'S' )
  281 CONTINUE
      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))

C-----------------------------------------------------------------------
C  READ CROSS-SECTIONS AND PROBABILITIES FOR NUCLEUS-NUCLEUS COLLISIONS
      OPEN(UNIT=NUCNUC,FILE='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.10 )
      CLOSE(UNIT=NUCNUC)

C  INELASTIC CROSS-SECTIONS FOR PROJECTICLE WITH MASS NUMBER IA
      DO 501  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)
 501  CONTINUE

      WRITE(MONIOU,503)
 503  FORMAT (//' ',10('='),' INTERACTION MODELS ',49('='))
C  HIGH ENERGY HADRONIC INTERACTION MODEL
      IF ( FVENUS ) THEN
        WRITE(MONIOU,*) 'VENUS TREATS HIGH ENERGY HADRONIC INTERACTIONS'
        CALL VENINI
        IF ( FVENSG ) THEN
          WRITE(MONIOU,*)
          WRITE(MONIOU,*) 'VENUS CROSS-SECTIONS ARE TAKEN'
          CALL VENSIGINI
        ENDIF
      ELSE
        IF ( FVENSG ) THEN
          WRITE(MONIOU,*)
          WRITE(MONIOU,*) 'VENUS CROSS-SECTIONS ARE TAKEN'
          CALL VENSIGINI
        ENDIF
        WRITE(MONIOU,1506)
      ENDIF
1506  FORMAT(' HDPM ROUTINES TREAT HIGH ENERGY HADRONIC INTERACTIONS')


      IF ( .NOT. FVENUS ) 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'
      ELSEIF ( NFRAGM .EQ. 2 ) THEN
        WRITE(MONIOU,1504)
1504    FORMAT('  NO FRAGMENTATION, EVAPORATION OF REMAINDER ',
     *           ' (PT AFTER JACEE)')
      ELSEIF ( NFRAGM .EQ. 3 ) THEN
        WRITE(MONIOU,1505)
1505    FORMAT('  NO FRAGMENTATION, EVAPORATION OF REMAINDER ',
     *           ' (PT AFTER GOLDHABER)')
      ELSEIF ( NFRAGM .EQ. 4 ) THEN
        WRITE(MONIOU,1507)
1507    FORMAT('  NO FRAGMENTATION, EVAPORATION OF REMAINDER ',
     *           ' (WITH PT = 0.)')
      ELSE
        NFRAGM = 4
        WRITE(MONIOU,1507)
      ENDIF
      WRITE(MONIOU,*)

C  LOW ENERGY HADRONIC INTERACTION MODEL
      WRITE(MONIOU,*) 'GHEISHA TREATS LOW ENERGY HADRONIC ',
     *                  'INTERACTIONS'
      CALL CGHINI

C  WRITE HADRONIC STEERING FLAGS TO RUNHEADER
      RUNH(270) = NFLAIN
      RUNH(271) = NFLDIF
      RUNH(272) = NFLPI0 + 100. * NFLPIF
      RUNH(273) = NFLCHE + 100. * NFRAGM

      EVTH(65)  = NFLAIN
      EVTH(66)  = NFLDIF
      EVTH(67)  = NFLPI0
      EVTH(68)  = NFLPIF
      EVTH(69)  = NFLCHE
      EVTH(70)  = 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 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 MULTIPLE SCATTERING AFTER MOLIERE'
      ELSE
        EVTH(146) = 0.
        WRITE(MONIOU,*)'MUON MULTIPLE SCATTERING IN GAUSS APPROXIMATION'
      ENDIF

C-----------------------------------------------------------------------
C  INPUT STEERING FLAGS FOR ELECTROMAGNETIC PART
      WRITE(MONIOU,*)
      IF ( FNKG ) THEN
        WRITE(MONIOU,121)
 121    FORMAT(' ######################################################'
     *     ,/, ' # SIMULATION WITH NKG NOT POSSIBLE IN CURVED VERSION #'
     *     ,/, ' ######################################################'
     *     ,/ )
        FNKG = .FALSE.
      ENDIF
      IF ( FEGS ) THEN
        WRITE(MONIOU,*) 'ELECTROMAGNETIC COMPONENT SIMULATED WITH EGS4'
        WRITE(MONIOU,*)
      ENDIF
      IF ( .NOT. (FNKG .OR. FEGS) ) WRITE(MONIOU,*)
     *              'ELECTROMAGNETIC COMPONENT IS NOT SIMULATED'
      IF ( FEGS ) THEN
        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,*) 'PLEASE READ THE USERS GUIDE'
          WRITE(MONIOU,*) 'SEE KEYWORD: STEPFC'
          STOP
        ENDIF
        IF ( STEPFC .LT. 10.D0 ) WRITE(MONIOU,*)'STEP LENGTH ',
     *        'FACTOR FOR ELECTRON MULTIPLE SCATTERING =',SNGL(STEPFC)
C  INITIALIZE EGS4 PACKAGE
        CALL EGSINI
      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) = 1.
      IF ( FVENUS ) THEN
        EVTH(76) = 1.
      ELSE
        EVTH(76) = 0.
      ENDIF
      EVTH(139) = 0.
      EVTH(140) = 0.
      EVTH(141) = 0.
      EVTH(142) = 0.
      EVTH(143) = 0.
      EVTH(144) = 0.
      IF ( FVENSG ) THEN
        EVTH(145) = 1.
      ELSE
        EVTH(145) = 0.
      ENDIF
      EVTH(153) = VUECON(1)
      EVTH(154) = VUECON(2)
C  ---------------------------------------------------------
C  ELEMENT 77 OF EVENT HEADER HAS THE FOLLOWING CONTENTS IF
C  CONVERTED TO AN INTEGER WITH SUITABLE ROUNDING APPLIED:
C  BIT  1: CERENKOV OPTION COMPILED IN
C       2: IACT OPTION COMPILED IN
C       3: CEFFIC OPTION COMPILED IN
C       4: ATMEXT OPTION COMPILED IN
C       5: ATMEXT OPTION USED WITH REFRACTION ENABLED
C       6: VOLUMEDET OPTION COMPILED IN
C       7: CURVED OPTION COMPILED IN (SEE ALSO EVTH(79))
C   11-21: TABLE NUMBER FOR EXTERNAL ATMOSPHERE TABLE
C          (BUT LIMITED TO 1023 IF THE NUMBER IS LARGER)
C  --------------------------------------------------------
      EVTH(77) = 1.
      EVTH(77) = EVTH(77) + 8.
      IF ( FREFRX ) EVTH(77) = EVTH(77) + 16.
      EVTH(77) = EVTH(77) + 1024. * MIN(IATMOX,1023)
      EVTH(77) = EVTH(77) + 64.
      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)
      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(20)   = 10.D0 * C(21)
      C(27)   = COS( C(26) )
      C(29)   = COS( C(28) )
C  CALCULATE CONSTANT FOR MAXIMAL HORIZONTAL RANGE WITHIN LOCAL SYSTEM
      C(4)    = (C(2)-C(3)) / THICK(0.D0)
C  EXTEND ANGULAR CUT UP TO HORIZONTAL FOR CURVED VERSION
      C(29)   = 1.D-15
      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(18) = SQRT( ( (PAMA(11)**2 + PAMA(8)**2 - PAMA(7)**2)
     *          / (2.D0*PAMA(11)) )**2 - PAMA(8)**2 )
      CKA(28) = SQRT(1.D0 + CKA(17)**2/PAMA(5)**2)
      CKA(29) = SQRT(1.D0 - 1.D0/CKA(28)**2)
      CKA(30) = SQRT(1.D0 + CKA(18)**2/PAMA(8)**2)
      CKA(31) = SQRT(1.D0 - 1.D0/CKA(30)**2)
      CKA(41) = PAMA(16)
      CKA(42) = (PAMA(11)**2 + PAMA(7)**2 - PAMA(8)**2) /
     *          (2.D0*PAMA(11)*PAMA(7))
      CKA(43) = CKA(41) / (2.D0*PAMA(7))
      CKA(44) = SQRT(1.D0 - 1.D0/CKA(43)**2)
      CKA(45) = CKA(41) / (2.D0*PAMA(8))
      CKA(46) = SQRT(1.D0 - 1.D0/CKA(45)**2)

C  SET CONSTANTS FOR MUON BREMSSTRAHLUNG
C  SET BCUT WELL BELOW  21 MEV
*     BCUT      = MIN( ELCUT(3), 100.D0*PAMA(5) )
C  BCUT IS FIXED, AS PARAMETRIZATION IN BOX2 IS INDEPENDENT OF BCUT.
      BCUT      = 0.002044D0
      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)) )
      CMUON(2)  = LOG( 189.D0 * PAMA(5) / (CMUON(8)*PAMA(2)) )
      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-----------------------------------------------------------------------
C  FILL CONSTANTS IN RUN HEADER
      DO 3001  L = 1,50
        RUNH(24+L)  = C(L)
        RUNH(154+L) = 0.
        RUNH(204+L) = 0.
 3001 CONTINUE
      DO 3002  L = 1,20
        RUNH(74+L)  = 0.
 3002 CONTINUE
      DO 3003  L = 1,40
        RUNH(94+L)  = CKA(L)
 3003 CONTINUE
      DO 3004  L = 1,5
        RUNH(134+L)  = CETA(L)
 3004 CONTINUE
      DO 3005  L = 1,11
        RUNH(139+L)  = CSTRBA(L)
 3005 CONTINUE
      DO 3007  L = 1,5
        RUNH(254+L) = AATM(L)
        RUNH(259+L) = BATM(L)
        RUNH(264+L) = CATM(L)
 3007 CONTINUE

      CALL STAEND

      RETURN
      END
*CMZ :          14/06/2000  14.56.21  by  D. HECK IK3 FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
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 FORM NUCINT
C
C  DESIGN  : D. HECK    IK3  FZK KARLSRUHE
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,IRET.
      COMMON /IRET/    IRET1,IRET2,IRETE
      INTEGER          IRET1,IRET2
      LOGICAL          IRETE
*KEEP,PARPAR.
      COMMON /PARPAR/  CURPAR,SECPAR,PRMPAR,OUTPAR,C,
     *                 E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
      DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16),
     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH
      INTEGER          ITYPE,LEVL
*KEEP,PARPAE.
      DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM
     *                 ,WEIGHT
     *                 ,HAPP,COSTAP,COSTEA
      EQUIVALENCE      (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE),
     *                 (CURPAR(4), PHI   ), (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)
*KEEP,RANDPA.
      COMMON /RANDPA/  FAC,U1,U2,RD,NSEQ,ISEED,KNOR
      DOUBLE PRECISION FAC,U1,U2
      REAL             RD(3000)
      INTEGER          ISEED(103,10),NSEQ
      LOGICAL          KNOR
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEEP,STRBAR.
      COMMON /STRBAR/  CSTRBA
      DOUBLE PRECISION CSTRBA(11)
*KEND.

      INTEGER          I
      SAVE
C-----------------------------------------------------------------------

      IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=1,9)
 444  FORMAT(' STRDEC: CURPAR=',1P,9E10.3)

      IF     ( ITYPE .EQ. 18 ) THEN
        CALL RMMAR( 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 RMMAR( 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 RMMAR( 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 RMMAR( 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 RMMAR( 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=1,9)
        WRITE(MONIOU,*) 'STRDEC: UNFORESEEN PARTICLE CODE =',ITYPE
      ENDIF
      IRET1 = 1
      RETURN
      END
*CMZ :          18/10/2000  09.15.11  by  D. HECK IK3 FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
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 IN CM
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,ATMOS.
      COMMON /ATMOS/   AATM,AATM0,BATM,BATM0,CATM,CATM0,DATM,MODATM
      DOUBLE PRECISION AATM(5),AATM0(5,0:16),BATM(5),BATM0(5,0:16),
     *                 CATM(5),CATM0(5,0:16),DATM(5)
      INTEGER          MODATM
*KEEP,ATMOS2.
      COMMON /ATMOS2/  HLAY,HLAY0,THICKL,LAYNO,LAYNEW
      DOUBLE PRECISION HLAY(6),HLAY0(5,0:4),THICKL(5)
      INTEGER          LAYNO(0:16)
      LOGICAL          LAYNEW
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEEP,ATMOSX.
C  EXTERNAL ATMOSPHERIC MODELS
      COMMON /ATMOSX/  IATMOX,FREFRX
      INTEGER          IATMOX
      LOGICAL          FREFRX
*KEND.

      DOUBLE PRECISION ARG
      SAVE
      DOUBLE PRECISION THICKX
      EXTERNAL         THICKX
C-----------------------------------------------------------------------

CC    IF ( DEBUG ) WRITE(MDEBUG,*) 'THICK : ARG=',SNGL(ARG)

      IF ( IATMOX .GE. 1 ) THEN
        THICK = THICKX(ARG)
        RETURN
      ENDIF

      IF     ( ARG .LT. HLAY(2) ) THEN
        THICK = AATM(1) + BATM(1) * EXP ( (-ARG) * DATM(1) )
      ELSEIF ( ARG .LT. HLAY(3) ) THEN
        THICK = AATM(2) + BATM(2) * EXP ( (-ARG) * DATM(2) )
      ELSEIF ( ARG .LT. HLAY(4) ) THEN
        THICK = AATM(3) + BATM(3) * EXP ( (-ARG) * DATM(3) )
      ELSEIF ( ARG .LT. HLAY(5) ) THEN
        THICK = AATM(4) + BATM(4) * EXP ( (-ARG) * DATM(4) )
      ELSE
        THICK = AATM(5) - ARG * DATM(5)
      ENDIF

      RETURN
      END
*CMZ :          18/10/2000  09.15.11  by  D. HECK IK3 FZK KARLSRUHE
*-- 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 OF ATMOSPHERIC THICKNESS AT INTERACTION POINT IN CURVED
C  COORDINATE SYSTEM  AFTER TRANSPORTING THE PARTICLE 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  DESIGN  : F. SCHROEDER UNI WUPPERTAL
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,ATMOS.
      COMMON /ATMOS/   AATM,AATM0,BATM,BATM0,CATM,CATM0,DATM,MODATM
      DOUBLE PRECISION AATM(5),AATM0(5,0:16),BATM(5),BATM0(5,0:16),
     *                 CATM(5),CATM0(5,0:16),DATM(5)
      INTEGER          MODATM
*KEEP,ATMOS2.
      COMMON /ATMOS2/  HLAY,HLAY0,THICKL,LAYNO,LAYNEW
      DOUBLE PRECISION HLAY(6),HLAY0(5,0:4),THICKL(5)
      INTEGER          LAYNO(0:16)
      LOGICAL          LAYNEW
*KEEP,OBSPAR.
      COMMON /OBSPAR/  OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP,
     *                 THETPR,PHIPR,
     *                 VUECON,
     *                 NOBSLV
      DOUBLE PRECISION OBSLEV(10),THCKOB(10),XOFF(10),YOFF(10),
     *                 HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2)
      DOUBLE PRECISION VUECON(2)
      INTEGER          NOBSLV
*KEEP,PARPAR.
      COMMON /PARPAR/  CURPAR,SECPAR,PRMPAR,OUTPAR,C,
     *                 E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
      DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16),
     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH
      INTEGER          ITYPE,LEVL
*KEEP,PARPAE.
      DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM
     *                 ,WEIGHT
     *                 ,HAPP,COSTAP,COSTEA
      EQUIVALENCE      (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE),
     *                 (CURPAR(4), PHI   ), (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)
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEND.

      DOUBLE PRECISION ARG,CHIC,CHIMAX,CHICNEW,COSDIF,COSPHI,COSTAPNEW,
     *                 COSTHENEW,DISTN2,DISTO2,DL,HEIGH,HNEW,HOLD,
     *                 RADIUS,SIGNE,SINI,SINPHI,
     *                 TRANSNEW,WORK,XNEW,YNEW
      INTEGER          IL
      SAVE
      EXTERNAL         HEIGH
C-----------------------------------------------------------------------

      IF ( DEBUG ) WRITE(MDEBUG,*) 'THICKC: ARG=',SNGL(ARG),'H=',SNGL(H)

C  START VALUES
      CHIC   = ARG
      HNEW   = H
      XNEW   = X
      YNEW   = Y
      THICKC = THICKH
      DISTN2 = XNEW**2 + YNEW**2
      COSPHI = COS(PHI)
      SINPHI = SIN(PHI)
      COSTHENEW = COSTHE
      COSTAPNEW = COSTAP

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  LOOK WITHIN WHICH LAYER THE PARTICLE STARTS
      IF     ( HNEW .LE. HLAY(2) ) THEN
        IL = 1
      ELSEIF ( HNEW .LE. HLAY(3) ) THEN
        IL = 2
      ELSEIF ( HNEW .LE. HLAY(4) ) THEN
        IL = 3
      ELSE
        IL = 4
      ENDIF
C  LOOK FOR MAXIMAL STEP OF CHICNEW, ONLY IF NOT CLOSE TO VERTICAL
      IF ( COSTHENEW .LT. 0.98D0 ) THEN
        SINI = DATM(IL) / SQRT(1.D0 - COSTHENEW**2)
        WORK = C(4) * THICKC + C(3)
        IF ( HNEW .LT. HLAY(5) ) THEN
          CHIMAX = ( THICKC - AATM(IL) ) * SINI *
     *             ( WORK + 0.5D0*COSTHENEW*SINI * WORK**2 )
        ELSE
          CHIMAX = WORK * SINI * DATM(5)/DATM(IL)
        ENDIF
        IF ( CHIC .GE. CHIMAX ) THEN
          CHICNEW = CHIMAX
        ELSE
          CHICNEW = CHIC
        ENDIF
      ELSE
        CHICNEW = CHIC
      ENDIF

C  ACTUAL VALUES
      THICKC = THICKC + COSTHENEW * CHICNEW
      CHIC   = CHIC - CHICNEW
      IF ( DEBUG ) WRITE(MDEBUG,*) 'THICKC: CHIC,THICKC=',
     *                           SNGL(CHIC),SNGL(THICKC)

C  IN CASE COMPLETE PARTICLE TRACK LENGTH IS CHIC, STOP THE LOOP
      IF ( CHIC .GT. 0.D0 ) THEN
C  NEW COORDINATE FRAME
        HOLD = HNEW
C  NEW HEIGHT IN OLD COORDINATE FRAME
        HNEW = HEIGH(THICKC)
        DL   = (HOLD - HNEW) * COSTHENEW
        TRANSNEW = DL * SQRT( 1.D0 - COSTHENEW**2 )
C  NEW ACTUAL HEIGHT AT NEW THICKNESS GRADIENT
C  (CALCULATED WITH PARAMETERS OF OLD COORDINATE FRAME)
        HNEW   = SQRT( TRANSNEW**2 + (C(1)+HNEW)**2 ) - C(1)
        IF ( HNEW .LT. OBSLEV(1) -1.D5 ) RETURN
        COSDIF = ( (C(1)+HNEW)**2 + (C(1)+HOLD)**2 - DL**2 ) /
     *                             ( 2.D0 * (C(1)+HNEW) * (C(1)+HOLD) )
        IF ( DEBUG ) WRITE(MDEBUG,*) 'THICKC: HNEW,COSDIF=',
     *             SNGL(HNEW),SNGL(COSDIF)
        COSDIF = MIN (1.D0, COSDIF)
C  DIRECTION OF PARTICLE RELATIV TO SHOWER CORE
        DISTO2 = DISTN2
        IF ( COSDIF .LT. 1.D0 ) THEN
          RADIUS = DL * SQRT( (1.D0-COSTAPNEW**2)/(1.D0-COSDIF**2) )
     *                * C(1) * ACOS(COSDIF)/(C(1)+HNEW)
        ELSE
          RADIUS = DL * SQRT( 1.D0 - COSTAPNEW**2 )
        ENDIF
        XNEW   = XNEW + RADIUS * COSPHI
        YNEW   = YNEW + RADIUS * SINPHI
        DISTN2 = XNEW**2 + YNEW**2
        IF ( DISTO2 .GT. DISTN2 ) THEN
          SIGNE = +1.D0
        ELSE
          SIGNE = -1.D0
        ENDIF
C  COSINE OF THE ZENITH ANGLE IN THE NEW FRAME
        COSTHENEW = MIN( 1.D0, ( COSTHENEW * COSDIF - SIGNE *
     *               SQRT( (1.D0-COSTHENEW**2) * (1.D0-COSDIF**2) ) ) )
        IF (DEBUG) WRITE(MDEBUG,*) 'THICKC: COSTHENEW=',SNGL(COSTHENEW)
        IF ( COSTHENEW .GT. C(29) ) GOTO 2
      ENDIF
      IF ( DEBUG ) WRITE(MDEBUG,*) 'THICKC: THICKC=',SNGL(THICKC)

      RETURN
      END
*CMZ :          23/11/2000  09.03.51  by  D. HECK IK3 FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
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 TAPE
C  THIS SUBROUTINE IS CALLED FROM AAMAIN, ELECTR, PHOTON, INPRM, OUTEND,
C  OUTPT1, OUTPT2, AND PHOTON.
C  ARGUMENTS:
C   A      = ARRAY TO BE WRITTEN TO TAPE
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
*KEEP,BUFFS.
      COMMON /BUFFS/   RUNH,RUNE,EVTH,EVTE,DATAB,ARRAYLONG,LH
      INTEGER          MAXBUF,MAXLEN
      PARAMETER        (MAXLEN=16)
      PARAMETER        (MAXBUF=39*7)
      REAL             RUNH(MAXBUF),EVTH(MAXBUF),EVTE(MAXBUF),
     *                 RUNE(MAXBUF),DATAB(MAXBUF),ARRAYLONG(MAXBUF)
      INTEGER          LH
      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)
*KEEP,RECORD.
      COMMON /RECORD/  IRECOR
      INTEGER          IRECOR
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEND.

C  NSUBBL IS NUMBER OF SUBBLOCKS IN ONE OUTPUT RECORD
      INTEGER          NSUBBL
      PARAMETER        (NSUBBL=21)
      REAL             A(*)
C  (OUTPUT RECORD LENGTH = NSUBBL * 39 * 7 * 4 BYTES  <= 22932 )
C  OUTPUT BUFFER FOR PARTICLE OUTPUT
      REAL             OUTBUF(MAXBUF,NSUBBL)
C  IBLK  IS  COUNTER FOR SUBBLOCKS
      INTEGER          I,IBLK,IFL,K
      SAVE
      DATA             IBLK / 0 /
C-----------------------------------------------------------------------

      IF ( DEBUG ) WRITE(MDEBUG,*) 'TOBUF : IFL =',IFL

C  COPY TO BUFFER
      IF ( IFL .LE. 1 ) THEN
        IBLK = IBLK + 1
        DO  1  I = 1,MAXBUF
          OUTBUF(I,IBLK) = A(I)
 1      CONTINUE
      ENDIF

C  WRITE TO TAPE 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
c------changed--add-and-comand
cxx          WRITE(MPATAP) ((OUTBUF(I,K),I=1,MAXBUF),K=1,NSUBBL)
c>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
c        WRITE(PATAPE)           ((OUTBUF(I,K),I=1,MAXBUF),K=1,NSUBBL)
        call jcdatsave(outbuf)
c>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
c------changed--add-and-comand

        ENDIF
        IRECOR = IRECOR + MAXBUF * NSUBBL
        IBLK   = 0
        DO  2  K = 1,NSUBBL
        DO  2  I = 1,MAXBUF
          OUTBUF(I,K) = 0.0
 2      CONTINUE
      ENDIF

      RETURN
      END
*CMZ :          25/02/2002  15.28.14  by  D. HECK IK FZK KARLSRUHE
*-- Author :    Johannes Knapp, IEKP U Karlsruhe    26/01/97
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
C  DESIGN  : J. KNAPP, IEKP U KARLSRUHE
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,BUFFS.
      COMMON /BUFFS/   RUNH,RUNE,EVTH,EVTE,DATAB,ARRAYLONG,LH
      INTEGER          MAXBUF,MAXLEN
      PARAMETER        (MAXLEN=16)
      PARAMETER        (MAXBUF=39*7)
      REAL             RUNH(MAXBUF),EVTH(MAXBUF),EVTE(MAXBUF),
     *                 RUNE(MAXBUF),DATAB(MAXBUF),ARRAYLONG(MAXBUF)
      INTEGER          LH
      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)
*KEEP,ELABCT.
      COMMON /ELABCT/  ELCUT
      DOUBLE PRECISION ELCUT(4)
*KEEP,LONGI.
      COMMON /LONGI/   ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP,LLONGI,FLGFIT
      DOUBLE PRECISION ADLONG(0:1170,9),AELONG(0:1170,9),
     *                 APLONG(0:1170,9),DLONG(0:1170,9),ELONG(0:1170,9),
     *                 HLONG(0:1170),PLONG(0:1170,9),SDLONG(0:1170,9),
     *                 SELONG(0:1170,9),SPLONG(0:1170,9),THSTEP,THSTPI
      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT
*KEEP,MUPART.
      COMMON /MUPART/  AMUPAR,BCUT,CMUON,FMUBRM,FMUORG
      DOUBLE PRECISION AMUPAR(16),BCUT,CMUON(11)
      LOGICAL          FMUBRM,FMUORG
*KEEP,PAM.
      COMMON /PAM/     PAMA,SIGNUM,RESTMS
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000)
*KEEP,PARPAR.
      COMMON /PARPAR/  CURPAR,SECPAR,PRMPAR,OUTPAR,C,
     *                 E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
      DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16),
     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH
      INTEGER          ITYPE,LEVL
*KEEP,PARPAE.
      DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM
     *                 ,WEIGHT
     *                 ,HAPP,COSTAP,COSTEA
      EQUIVALENCE      (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE),
     *                 (CURPAR(4), PHI   ), (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)
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEEP,THNVAR.
      COMMON /THNVAR/  STACKINT,
     *                 INT_ICOUNT,MODETHN,THINNING
      INTEGER          MAXICOUNT
      PARAMETER        (MAXICOUNT=40000)
      DOUBLE PRECISION STACKINT(16,MAXICOUNT)
      INTEGER          INT_ICOUNT,MODETHN
      LOGICAL          THINNING
*KEND.

      INTEGER          I,J
      SAVE
C-----------------------------------------------------------------------

      INT_ICOUNT = INT_ICOUNT + 1
      IF ( DEBUG ) WRITE(MDEBUG,1) INT_ICOUNT,(SECPAR(J),J=1,9)
 1    FORMAT(' TSTACK:',I7,1X,1P,8E10.3,0P,F10.0)

      IF ( INT_ICOUNT .GT. MAXICOUNT ) THEN
        WRITE(MONIOU,10) MAXICOUNT
 10     FORMAT(' TSTACK: TOO MANY SECONDARIES FOR THIS REACTION',
     *     '  EXCEEDED ',I7,'   A T T E N T I O N  PARTICLE IS LOST')
        INT_ICOUNT = INT_ICOUNT - 1
        RETURN
      ENDIF

C  CALCULATE APPROPRIATE KINETIC ENERGY CUT AND APPLY IT
      IF     ( SECPAR(1) .EQ. 5.D0 .OR. SECPAR(1) .EQ. 6.D0 ) THEN
C  ---MUONS---
        IF ( (SECPAR(2) - 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(2) * PAMA(5)
          ENDIF
          RETURN
        ENDIF

      ELSEIF ( SECPAR(1) .EQ. 2.D0 .OR. SECPAR(1) .EQ. 3.D0 ) THEN
C  ---ELECTRONS---
        IF ( (SECPAR(2) - 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(1) .EQ. 2.D0 ) THEN
              DLONG(LHEIGH,3) = DLONG(LHEIGH,3)
     *                        + (SECPAR(2)+1.D0) * PAMA(2)
            ELSE
              DLONG(LHEIGH,3) = DLONG(LHEIGH,3)
     *                        + (SECPAR(2)-1.D0) * PAMA(2)
            ENDIF
          ENDIF
          RETURN
        ENDIF

      ELSEIF ( SECPAR(1) .EQ. 1.D0 ) THEN
C  ---GAMMAS---
        IF ( SECPAR(2) .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(2)
          ENDIF
          RETURN
        ENDIF

      ELSEIF (SECPAR(1) .GE. 100.D0 ) THEN
C  ---NUCLEI---, CUTTED IF ENERGY/NUCLEON BELOW CUT
        IF ( (SECPAR(2)-1.D0)*PAMA(NINT(SECPAR(1)))
     *                     .LT.   ELCUT(1)*NINT(SECPAR(1)/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(2)*PAMA(NINT(SECPAR(1)))
     *                                - RESTMS(NINT(SECPAR(1))) )
          ENDIF
          RETURN
        ENDIF

      ELSE
C  ---HADRONS---
        IF ( (SECPAR(2)-1.D0)*PAMA(NINT(SECPAR(1))) .LT. ELCUT(1) ) THEN
          IF (DEBUG) WRITE(MDEBUG,*) 'TSTACK: PARTICLE BELOW ',
     *       'ENERGY CUT'
          INT_ICOUNT = INT_ICOUNT - 1
          IF ( LLONGI ) THEN
C  ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT
C  IN CASE OF NUCLEONS TAKE ONLY KINETIC ENERGY
C  IN CASE OF ANTINUCLEONS TAKE RELEASABLE ENERGY
            DLONG(LHEIGH,7) = DLONG(LHEIGH,7)
     *                 + ( SECPAR(2) * PAMA(NINT(SECPAR(1)))
     *                              - RESTMS(NINT(SECPAR(1))) )
          ENDIF
          RETURN
        ENDIF

      ENDIF

C  WRITE PARTICLE ABOVE CUT TO INTERMEDIATE STACK
      DO   I = 1,MAXLEN
        STACKINT(I,INT_ICOUNT) = SECPAR(I)
      ENDDO

      RETURN
      END
*CMZ :          27/02/2002  16.27.13  by  D. HECK IK FZK KARLSRUHE
*-- Author :    Johannes Knapp, IEKP U Karlsruhe    26/01/97
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
C  DESIGN  : J. KNAPP, IEKP U KARLSRUHE
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,BUFFS.
      COMMON /BUFFS/   RUNH,RUNE,EVTH,EVTE,DATAB,ARRAYLONG,LH
      INTEGER          MAXBUF,MAXLEN
      PARAMETER        (MAXLEN=16)
      PARAMETER        (MAXBUF=39*7)
      REAL             RUNH(MAXBUF),EVTH(MAXBUF),EVTE(MAXBUF),
     *                 RUNE(MAXBUF),DATAB(MAXBUF),ARRAYLONG(MAXBUF)
      INTEGER          LH
      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)
*KEEP,MUPART.
      COMMON /MUPART/  AMUPAR,BCUT,CMUON,FMUBRM,FMUORG
      DOUBLE PRECISION AMUPAR(16),BCUT,CMUON(11)
      LOGICAL          FMUBRM,FMUORG
*KEEP,PAM.
      COMMON /PAM/     PAMA,SIGNUM,RESTMS
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000)
*KEEP,PARPAR.
      COMMON /PARPAR/  CURPAR,SECPAR,PRMPAR,OUTPAR,C,
     *                 E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
      DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16),
     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH
      INTEGER          ITYPE,LEVL
*KEEP,PARPAE.
      DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM
     *                 ,WEIGHT
     *                 ,HAPP,COSTAP,COSTEA
      EQUIVALENCE      (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE),
     *                 (CURPAR(4), PHI   ), (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)
*KEEP,RANDPA.
      COMMON /RANDPA/  FAC,U1,U2,RD,NSEQ,ISEED,KNOR
      DOUBLE PRECISION FAC,U1,U2
      REAL             RD(3000)
      INTEGER          ISEED(103,10),NSEQ
      LOGICAL          KNOR
*KEEP,REJECT.
      COMMON /REJECT/  AVNREJ,ALTMIN,ANEXP,THICKA,THICKD,CUTLN,EONCUT,
     *                 FNPRIM
      DOUBLE PRECISION AVNREJ(10),ALTMIN(10),ANEXP(10),THICKA(10),
     *                 THICKD(10),CUTLN,EONCUT
      LOGICAL          FNPRIM
*KEEP,RESON.
      COMMON /RESON/   RDRES,RESRAN,IRESPAR
      REAL             RDRES(2),RESRAN(30000)
      INTEGER          IRESPAR
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEEP,THNVAR.
      COMMON /THNVAR/  STACKINT,
     *                 INT_ICOUNT,MODETHN,THINNING
      INTEGER          MAXICOUNT
      PARAMETER        (MAXICOUNT=40000)
      DOUBLE PRECISION STACKINT(16,MAXICOUNT)
      INTEGER          INT_ICOUNT,MODETHN
      LOGICAL          THINNING
*KEND.

      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

C  PUT ALL PARTICLES FROM INTERMEDIATE STACK TO REAL STACK
      DO   K = 1,INT_ICOUNT
        DO   I = 1,MAXLEN
          SECPAR(I) = STACKINT(I,K)
          STACKINT(I,K) = 0.D0
        ENDDO
        CALL TSTOUT
      ENDDO

      RETURN
      END
*CMZ :          27/02/2002  16.27.13  by  D. HECK IK FZK KARLSRUHE
*-- Author :    Johannes Knapp, IEKP U Karlsruhe    26/01/97
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 FORM MPPROP, PIGEN1, PIGEN2, RHOGEN,
C  AND TSTEND
C
C  DESIGN  : J. KNAPP, IEKP U KARLSRUHE
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,BUFFS.
      COMMON /BUFFS/   RUNH,RUNE,EVTH,EVTE,DATAB,ARRAYLONG,LH
      INTEGER          MAXBUF,MAXLEN
      PARAMETER        (MAXLEN=16)
      PARAMETER        (MAXBUF=39*7)
      REAL             RUNH(MAXBUF),EVTH(MAXBUF),EVTE(MAXBUF),
     *                 RUNE(MAXBUF),DATAB(MAXBUF),ARRAYLONG(MAXBUF)
      INTEGER          LH
      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)
*KEEP,ETHMAP.
      COMMON /ETHMAP/  ECTMAP,ELEFT
      DOUBLE PRECISION ECTMAP,ELEFT
*KEEP,PAM.
      COMMON /PAM/     PAMA,SIGNUM,RESTMS
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000)
*KEEP,PARPAR.
      COMMON /PARPAR/  CURPAR,SECPAR,PRMPAR,OUTPAR,C,
     *                 E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
      DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16),
     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH
      INTEGER          ITYPE,LEVL
*KEEP,PARPAE.
      DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM
     *                 ,WEIGHT
     *                 ,HAPP,COSTAP,COSTEA
      EQUIVALENCE      (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE),
     *                 (CURPAR(4), PHI   ), (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)
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEEP,STACKF.
      COMMON /STACKF/  STACK,MSTACKP,MEXST,NSHIFT,NOUREC,ICOUNT,
     *                 NTO,NFROM
      INTEGER          MAXSTK
      PARAMETER        (MAXSTK = 16*256*2)
      DOUBLE PRECISION STACK(MAXSTK)
      INTEGER          MSTACKP,MEXST,NSHIFT,NOUREC,ICOUNT,NTO,NFROM
*KEND.

      INTEGER          I,ISTK,J
      SAVE
      DATA             ISTK / MAXSTK /
C-----------------------------------------------------------------------

      IF ( DEBUG ) WRITE(MDEBUG,666) ICOUNT,(SECPAR(J),J=1,9)
 666  FORMAT(' TSTOUT:',I7,1X,1P,8E10.3,0P,F10.0)

      IF ( MSTACKP .GE. ISTK ) THEN
        WRITE(MEXST,REC=NOUREC+1) (STACK(I),I=       1,ISTK/2)
        WRITE(MEXST,REC=NOUREC+2) (STACK(I),I=ISTK/2+1,ISTK )
        NOUREC = NOUREC + 2
        NSHIFT = NSHIFT + 2
        MSTACKP = 0
      ENDIF

      NTO    = NTO + 1
      ICOUNT = ICOUNT + 1

      DO  2  J = 1,MAXLEN
        STACK(MSTACKP+J) = SECPAR(J)
 2    CONTINUE
      MSTACKP = MSTACKP + MAXLEN
      IF ( SECPAR(1) .LE. 1.D0 ) THEN
        ELEFT  = ELEFT + SECPAR(2)
      ELSE
        ELEFT  = ELEFT + SECPAR(2) * PAMA(NINT(SECPAR(1)))
      ENDIF

      RETURN
      END
*CMZ :          05/03/2002  08.55.01  by  D. HECK IK FZK KARLSRUHE
*-- Author :    F. SCHROEDER UNI WUPPERTAL      17/11/98
C=======================================================================

      SUBROUTINE UPDATC(IPASC,FLAGMU,fmfb)

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
C  DESIGN  : F. SCHROEDER UNI WUPPERTAL
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,ATMOS.
      COMMON /ATMOS/   AATM,AATM0,BATM,BATM0,CATM,CATM0,DATM,MODATM
      DOUBLE PRECISION AATM(5),AATM0(5,0:16),BATM(5),BATM0(5,0:16),
     *                 CATM(5),CATM0(5,0:16),DATM(5)
      INTEGER          MODATM
*KEEP,ATMOS2.
      COMMON /ATMOS2/  HLAY,HLAY0,THICKL,LAYNO,LAYNEW
      DOUBLE PRECISION HLAY(6),HLAY0(5,0:4),THICKL(5)
      INTEGER          LAYNO(0:16)
      LOGICAL          LAYNEW
*KEEP,GENER.
      COMMON /GENER/   GEN,ALEVEL
      DOUBLE PRECISION GEN,ALEVEL
*KEEP,IRET.
      COMMON /IRET/    IRET1,IRET2,IRETE
      INTEGER          IRET1,IRET2
      LOGICAL          IRETE
*KEEP,LONGI.
      COMMON /LONGI/   ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP,LLONGI,FLGFIT
      DOUBLE PRECISION ADLONG(0:1170,9),AELONG(0:1170,9),
     *                 APLONG(0:1170,9),DLONG(0:1170,9),ELONG(0:1170,9),
     *                 HLONG(0:1170),PLONG(0:1170,9),SDLONG(0:1170,9),
     *                 SELONG(0:1170,9),SPLONG(0:1170,9),THSTEP,THSTPI
      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT
*KEEP,MAGNET.
      COMMON /MAGNET/  BX,BZ,BVAL,BNORMC,BNORM,COSB,SINB,BLIMIT
      DOUBLE PRECISION BX,BZ,BVAL,BNORMC,BNORM,COSB,SINB,BLIMIT
*KEEP,MUMULT.
      COMMON /MUMULT/  CHC,OMC,PHISCT,STEPL,VSCAT,FMOLI
      DOUBLE PRECISION CHC,OMC,PHISCT,STEPL,VSCAT
      LOGICAL          FMOLI
*KEEP,OBSPAR.
      COMMON /OBSPAR/  OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP,
     *                 THETPR,PHIPR,
     *                 VUECON,
     *                 NOBSLV
      DOUBLE PRECISION OBSLEV(10),THCKOB(10),XOFF(10),YOFF(10),
     *                 HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2)
      DOUBLE PRECISION VUECON(2)
      INTEGER          NOBSLV
*KEEP,PAM.
      COMMON /PAM/     PAMA,SIGNUM,RESTMS
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000)
*KEEP,PARPAR.
      COMMON /PARPAR/  CURPAR,SECPAR,PRMPAR,OUTPAR,C,
     *                 E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
      DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16),
     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH
      INTEGER          ITYPE,LEVL
*KEEP,PARPAE.
      DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM
     *                 ,WEIGHT
     *                 ,HAPP,COSTAP,COSTEA
      EQUIVALENCE      (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE),
     *                 (CURPAR(4), PHI   ), (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)
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEEP,CORFRAM, IF=CURVED.
      COMMON /CORFRAM/ DETSYS
      LOGICAL          DETSYS
*KEND.

      DOUBLE PRECISION ARG,AUXIL,AUXILSQ,AUX2SQ,CHIC,CHIMAX,CHIN,CORR,
     *                 COSDIF,COSTHENEW,DISTN2,DISTO2,DSTEFF,
     *                 EDEPB,EDEPN,EDEP1,EFRST,GAMMAOLD,GAMMAN,
     *                 HEIGH,HNEW,HOLD,SIGNE,SINDIF,SINI,SINTEA,STEPLC,
     *                 STEPLO,STEPT,THCKHN,THCKHO,THICK,THICKHOLD,
     *                 TRANS2,WORK,XNEW,XOLD,YNEW,YOLD
      INTEGER          I,IL,IPASC,LPCT1,LPCT2
      LOGICAL          FLAGMU
c-----changed--add
      logical fmfb
c-----changed--add
      DOUBLE PRECISION HNEWO
      SAVE
      EXTERNAL         HEIGH,THICK
C-----------------------------------------------------------------------

      IF (DEBUG) WRITE(MDEBUG,457) (CURPAR(I),I=1,9),FLAGMU
  457 FORMAT(' UPDATC: CURPAR=',1P,9E10.3,0P/
     *       '         FLAGMU=',L2)

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
      SINTEA = SQRT(1.D0 - COSTEA**2)
      IF ( LLONGI ) THEN
        GAMMAOLD  = GAMMA
        THICKHOLD = THICKH
        LPCT1 = INT(THICKHOLD*THSTPI + 1.D0)
      ENDIF
C  CHOPPING OF TOTAL PATH LENGTH CHIC INTO SMALLER PIECES  AND
C  TRANSPORT IN LOCAL PLANE SYSTEMS. STEP LENGTH LIMITATION DEPENDS ON
C  THICKNESS OF STARTING POINT. LOOP OVER ALL SMALL PIECES OF STEP

 2    CONTINUE
C  SAVE OLD LOCAL HEIGHT FOR TRANSFORMATION AFTER UPDATE
      HOLD   = HNEW
      XOLD   = XNEW
      YOLD   = YNEW
      DISTO2 = XNEW**2 + YNEW**2
      IF (DEBUG) WRITE(MDEBUG,*) 'UPDATC: 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
C  LOOK FOR MAXIMAL STEP OF CHICNEW, ONLY IF NOT CLOSE TO VERTICAL
C  BEFORE ENTERING NEW ATMOSPHERIC LAYER
      IF ( COSTHE .LT. 0.98D0 ) THEN
        SINI = DATM(IL) / SQRT(1.D0 - COSTHE**2)
*       IF ( DEBUG ) WRITE(MDEBUG,*) 'UPDATC: SINI=',SINI
        WORK = C(4) * THCKHN + C(3)
        IF ( HOLD .LT. HLAY(5) ) THEN
          CHIMAX = ( THCKHN - AATM(IL) ) * SINI *
     *             ( WORK + 0.5D0*COSTHE*SINI * WORK**2 )
        ELSE
          CHIMAX = WORK * SINI * DATM(5)/DATM(IL)
        ENDIF
        IF (DEBUG) WRITE(MDEBUG,301) CHIMAX
 301    FORMAT(' UPDATC: CHIMAX=',F10.5,' TO NEXT ATMOSPHERIC BOUNDARY')
        IF ( CHIC .GE. CHIMAX ) THEN
          CHIN = CHIMAX
        ELSE
          CHIN = CHIC
        ENDIF
      ELSE
        CHIN = CHIC
      ENDIF

C  CALCULATE VALUES FOR UPDATE
      THCKHO = THCKHN
      THCKHN = THCKHO + CHIN * COSTHE
      HNEW   = HEIGH(THCKHN)
      IF ( HNEW .GT. HOLD ) THEN
C  MAKE A SMALL STEP  OF 0.1 CM DEEPER INTO THE ATMOSPHERE
        HNEW   = HOLD - 0.1D0
        THCKHN = THICK(HNEW)
      ENDIF

C  CHECK WETHER 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)
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) ) GOTO 200
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
        DSTEFF = -( COS(PHI)*X + SIN(PHI)*Y )
C  CALCULATE CORRECTION ANGLE DIF FROM EFFECTIVE DISTANCE
        SINDIF = SIN(DSTEFF/C(1))
        COSDIF = SQRT( 1.D0 - SINDIF**2 )
        COSTHENEW = COSTHE*COSDIF - SQRT(1.D0-COSTHE**2)*SINDIF
        IF (DEBUG) WRITE(MDEBUG,*) 'UPDATC: COSDIF,COSTHENEW=',
     *                     COSDIF,COSTHENEW
        COSTHE = MIN( 1.D0, COSTHENEW )
C  KILL HORIZONTAL OR UPWARD GOING PARTICLES
        IF ( COSTHE .LE. C(29) ) THEN
          IF ( DEBUG ) WRITE(MDEBUG,556) (CURPAR(I),I=1,9)
 556      FORMAT(' UPDATC: KILL 1=',1P,10E10.3)
          GOTO 200
        ENDIF
C  ANGLE DIF MIGHT BE LARGE (DUE TO CUT ON HAPP)
        X = (HAPP+C(1))*TAN(X/C(1))
        Y = (HAPP+C(1))*TAN(Y/C(1))
        H = HAPP
        IF ( DEBUG ) WRITE(MDEBUG,559) COSTHE,H,X,Y
  559   FORMAT(' UPDATC: CORREC COSTHE,H,X,Y=',1P,4E17.10,0P)
        HNEW   = OBSLEV(1)
        THCKHN = THCKOB(1)
        IPASC  = 1
        DETSYS = .TRUE.
      ELSE
        IPASC  = 0
        DETSYS = .FALSE.
      ENDIF
      HNEWO    = HNEW

C  CALL UPDATE WITH NEW INPUT PARAMETERS ( HNEW,THCKHN,CURPAR(..) )
      CHI  = CHIN
c-----changed--add
      CALL UPDATE( HNEW,THCKHN,0,fmfb )
c-----changed--add
      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=',CHIC,CHIN
      IF ( IRET2 .NE. 0 ) THEN
        IF ( IRETE ) THEN
C  PARTICLE SUFFERED FROM ENERGY CUT
          GOTO 150
        ELSE
C  PARTICLE SUFFERED FROM ANGULAR CUT
          GOTO 200
        ENDIF
      ENDIF

C  KILL PARTICLE AS IT HAS BEEN STOPPED (MODIFIED HNEW IN UPDATE)
C  (NORMALLY BEDCAUSE OF ENERGY CUT)
C     IF ( HNEW .NE. HNEWO ) THEN
C       IRET2 = 1
C       IRETE = .TRUE.
C       GOTO 150
C     ENDIF
C  FOR CHARGED PARTICLES COSINE OF ZENITH ANGLE IS CALCULATED IN UPDATE.
C  KILL HORIZONTAL OR UPWARD GOING PARTICLES
      IF ( OUTPAR(3) .LE. C(29) ) GOTO 200

C  FILL CURPAR WITH ACTUAL VALUES OF PARTICLE AFTER TRANSPORT IN UPDATE
C  OUTPAR(13-16) IS NOT MODIFIED IN UPDATE
      DO   I = 2,8
        CURPAR(I) = OUTPAR(I)
      ENDDO
      THICKH = THCKHN

      IF ( IPASC .EQ. 0 ) THEN
C  TRACK ENDS NOT AT OBSERVATION LEVEL
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) ) THEN
C  KILL PARTICLE WHICH LEAVES ATMOSPHERE
          IF ( DEBUG ) WRITE(MDEBUG,*) 'UPDATC: HNEW=',HNEW,' KILL'
          GOTO 200
        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 HAVWE TO BE TRANSFORMED INTO 'EARTH'-COORDINATES (SPHERE)
C  BEFORE THE COMPARISON WITH DISTO2 IS DONE.
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

C  NEW DISTANCE FROM PARTICLE TO DETECTOR CENTER
        DISTN2 = X**2 + Y**2
C  COMPARE NEW AND OLD DISTANCE TO DETECTOR CENTER
        IF ( DISTN2 .LT. DISTO2 ) THEN
C  PARTICLE MOVES TOWARDS DETECTOR CENTER
          SIGNE = +1.D0
        ELSE
          SIGNE = -1.D0
          IF (DEBUG) WRITE(MDEBUG,*) 'UPDATC: SIGNE=',SIGNE
        ENDIF

C  IN FIRST ORDER APPROXIMATION COSTHE AND COSDIF ARE IN THE SAME PLANE
C  OF PARTICLE MOVEMENT, THEREFORE THE ANGLES MAY BE ADDED DIRECTLY
        COSTHENEW = COSTHE*COSDIF - SIGNE*SINDIF*SQRT(1.D0-COSTHE**2)
        COSTHE    = MIN( 1.D0, COSTHENEW )
C  KILL HORIZONTAL OR UPWARD GOING PARTICLES
        IF ( COSTHE .LE. C(29) ) THEN
          IF ( DEBUG ) WRITE(MDEBUG,555) (CURPAR(I),I=1,9)
 555      FORMAT(' UPDATC: KILL 0=',1P,10E10.3)
          GOTO 200
        ENDIF

        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=1,9)
  557   FORMAT(' UPDATC: STPEND=',1P,9E10.3,0P/)
C  WE ARE NOT YET AT DETECTOR.
        IF ( FDECAY ) THEN
C  IS WHOLE CHIC OR STEPLC TRAVERSED ?
          IF ( CHIC .GT. 1.D-10  .AND.  STEPLO .LT. STEPLC ) GOTO 2
        ELSE
C   IS 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,*) 'MUTRAC: CHI,STEPL=',
     *                             SNGL(CHI),SNGL(STEPL)

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)
C  REJECT PARTICLE WHICH TRAVERSES BELOW OBSERVATION LEVEL MEASURED
C  IN THE DETECTOR FRAME
        IF ( HAPP .LT. OBSLEV(1) ) GOTO 200
        AUX2SQ  = SQRT( (C(1)+HNEW)**2*(1.D0 - COSTEA**2)
     *                                      + (HAPP-OBSLEV(1))**2 )
        COSTAP  = (HAPP-OBSLEV(1)) / AUX2SQ
        IF ( DEBUG ) WRITE(MDEBUG,*) 'UPDATC: COSTAP=',COSTAP
        COSTAP  = MIN( 1.D0, COSTAP )
        OUTPAR(3) = COSTHE
        OUTPAR(5) = H
        OUTPAR(7) = X
        OUTPAR(8) = Y
      ENDIF

 150  IF ( LLONGI ) THEN
C  THE PARTICLE IS TRACKED FROM THICKHOLD DOWN TO THCKHN
        LPCT2 = INT(THCKHN*THSTPI)
        IF ( SIGNUM(ITYPE) .NE. 0.D0 ) THEN
          GAMMAN = OUTPAR(2)
C  TOTAL PATH LENGTH IN UNITS OF LONGI BINS
          STEPT  = (THCKHN - THICKHOLD)*THSTPI
C  CHARGED PARTICLES SUFFER IONIZATION LOSS.
C  WE ASSUME HOMOGENEOUS ENERGY DEPOSIT ALONG PATH
          IF ( STEPT .GT. 0.D0 ) THEN
C  IONIZATION ENERGY DEPOSED IN EACH BIN
            EDEPB = PAMA(ITYPE) * (GAMMAOLD - GAMMAN) / STEPT
          ELSE
            EDEPB = 0.D0
          ENDIF
C  ENERGY DEPOSIT IN FIRST BIN
          EDEP1 = EDEPB * (DBLE(LPCT1) - THICKHOLD*THSTPI)
C  ENERGY AT FIRST BIN BOUNDARY
          EFRST = PAMA(ITYPE) * GAMMAOLD - EDEP1
          IF ( LPCT2. LT. LPCT1 ) THEN
            EDEPN = EDEPB * (THCKHN*THSTPI - DBLE(LPCT1))
          ELSE
            IF ( IPASC .EQ. 0 ) THEN
              EDEPN = MAX( 0.D0, EDEPB * (THCKHN*THSTPI - DBLE(LPCT2)) )
            ELSE
C  PARTICLE ARRIVED AT DETECTOR
              LPCT2 = NSTEP
              EDEPN = 0.D0
            ENDIF
          ENDIF

C  NOW FILL FIRST AND LAST+1 BIN, THEN LOOP OVER THE BINS BETWEEN
          IF     ( ITYPE .EQ. 5 ) THEN
C  MUON(+) LONGITUDIAL 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) + 1.D0
            ENDIF
          ELSEIF ( ITYPE .EQ. 6 ) THEN
C  MUON(-) LONGITUDIAL 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) + 1.D0
            ENDIF
          ELSEIF ( ITYPE .LT. 100 ) THEN
C  CHARGED HADRON LONGITUDIAL 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)
              PLONG(LPCT2,6) = PLONG(LPCT2,6) + 1.D0
              PLONG(LPCT2,7) = PLONG(LPCT2,7) + 1.D0
            ENDIF
          ELSE
C  NUCLEI LONGITUDIAL 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) + 1.D0
            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(+) LONGITUDIAL 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) + 1.D0
              ELSEIF ( ITYPE .EQ. 6 ) THEN
C  MUON(-) LONGITUDIAL 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) + 1.D0
              ELSEIF ( ITYPE .LT. 100 ) THEN
C  CHARGED HADRON LONGITUDIAL 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)
                PLONG(IL,6) = PLONG(IL,6) + 1.D0
                PLONG(IL,7) = PLONG(IL,7) + 1.D0
              ELSE
C  NUCLEI LONGITUDIAL 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) + 1.D0
              ENDIF
            ENDDO
          ENDIF
        ELSE
C  NEUTRAL PARTICLES
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)
              PLONG(IL,6) = PLONG(IL,6) + 1.D0
            ENDDO
          ENDIF
        ENDIF
        IF ( IRET2 .NE. 0  .AND.  IRETE ) THEN
C  FILL REMAINING CUTTED ENERGY INTO LONGI BIN AT CUTTING POINT
          LHEIGH = LPCT2
          IF ( ITYPE .EQ. 5  .OR.  ITYPE .EQ. 6 ) THEN
            DLONG(LHEIGH,5) = DLONG(LHEIGH,5) + GAMMAN*PAMA(5)
          ELSE
            DLONG(LHEIGH,7) = DLONG(LHEIGH,7) + GAMMAN*PAMA(ITYPE)
     *                                        - RESTMS(ITYPE)
          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- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

C  TRANSPORT TO END OF TRACK
      IF ( IPASC .EQ. 0 ) THEN
        ALEVEL = H
        BETA   = SQRT( GAMMA**2 - 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

      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
        IF     ( ITYPE .EQ. 5  .OR. ITYPE .EQ. 6 ) THEN
          DLONG(LPCT1,5) = DLONG(LPCT1,5) + GAMMAOLD * PAMA(5)
        ELSE
          DLONG(LPCT1,7) = DLONG(LPCT1,7) + GAMMAOLD * PAMA(ITYPE)
     *                                    - RESTMS(ITYPE)
        ENDIF
      ENDIF
 201  IRET2 = 1
      RETURN
      END
*CMZ :          28/02/2002  13.08.20  by  D. HECK IK FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
C=======================================================================

      SUBROUTINE UPDATE( HNEW,THCKHN,IPAS,fmfb )

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.
CCCTHE PARTICLE IS FLYING THE 1ST HALF (DH/2) WITH INITIAL ENERGY
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 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  CHERENKOV RADIATION IS CALCULATED ONLY FOR LOWEST OBSERVATION LEVEL
C  THIS SUBROUTINE IS CALLED FROM AAMAIN, BOX3, MUTRAC
C                                 AND UPDATC.
C  ARGUMENTS:
C   HNEW   = ALTITUDE OF PARTICLE AFTER UPDATE
C   THCKHN = THICKNESS OF HNEW
C   IPAS   = 0  TRANSPORT TO END OF RANGE OF PARTICLE
C       .NE. 0  TRANSPORT TO PASSAGE OF OBSERVATION LEVEL IPAS
C
C  REDESIGN: D. HECK    IK3  FZK KARLSRUHE
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,ATMOS2.
      COMMON /ATMOS2/  HLAY,HLAY0,THICKL,LAYNO,LAYNEW
      DOUBLE PRECISION HLAY(6),HLAY0(5,0:4),THICKL(5)
      INTEGER          LAYNO(0:16)
      LOGICAL          LAYNEW
*KEEP,CONSTA.
      COMMON /CONSTA/  PI,PI2,OB3,TB3,ENEPER
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER
*KEEP,ELABCT.
      COMMON /ELABCT/  ELCUT
      DOUBLE PRECISION ELCUT(4)
*KEEP,GENER.
      COMMON /GENER/   GEN,ALEVEL
      DOUBLE PRECISION GEN,ALEVEL
*KEEP,IRET.
      COMMON /IRET/    IRET1,IRET2,IRETE
      INTEGER          IRET1,IRET2
      LOGICAL          IRETE
*KEEP,LONGI.
      COMMON /LONGI/   ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP,LLONGI,FLGFIT
      DOUBLE PRECISION ADLONG(0:1170,9),AELONG(0:1170,9),
     *                 APLONG(0:1170,9),DLONG(0:1170,9),ELONG(0:1170,9),
     *                 HLONG(0:1170),PLONG(0:1170,9),SDLONG(0:1170,9),
     *                 SELONG(0:1170,9),SPLONG(0:1170,9),THSTEP,THSTPI
      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT
*KEEP,MAGNET.
      COMMON /MAGNET/  BX,BZ,BVAL,BNORMC,BNORM,COSB,SINB,BLIMIT
      DOUBLE PRECISION BX,BZ,BVAL,BNORMC,BNORM,COSB,SINB,BLIMIT
*KEEP,MUMULT.
      COMMON /MUMULT/  CHC,OMC,PHISCT,STEPL,VSCAT,FMOLI
      DOUBLE PRECISION CHC,OMC,PHISCT,STEPL,VSCAT
      LOGICAL          FMOLI
*KEEP,OBSPAR.
      COMMON /OBSPAR/  OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP,
     *                 THETPR,PHIPR,
     *                 VUECON,
     *                 NOBSLV
      DOUBLE PRECISION OBSLEV(10),THCKOB(10),XOFF(10),YOFF(10),
     *                 HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2)
      DOUBLE PRECISION VUECON(2)
      INTEGER          NOBSLV
*KEEP,PAM.
      COMMON /PAM/     PAMA,SIGNUM,RESTMS
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000)
*KEEP,PARPAR.
      COMMON /PARPAR/  CURPAR,SECPAR,PRMPAR,OUTPAR,C,
     *                 E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
      DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16),
     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH
      INTEGER          ITYPE,LEVL
*KEEP,PARPAE.
      DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM
     *                 ,WEIGHT
     *                 ,HAPP,COSTAP,COSTEA
      EQUIVALENCE      (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE),
     *                 (CURPAR(4), PHI   ), (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)
*KEEP,RANDPA.
      COMMON /RANDPA/  FAC,U1,U2,RD,NSEQ,ISEED,KNOR
      DOUBLE PRECISION FAC,U1,U2
      REAL             RD(3000)
      INTEGER          ISEED(103,10),NSEQ
      LOGICAL          KNOR
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEEP,CORFRAM, IF=CURVED.
      COMMON /CORFRAM/ DETSYS
      LOGICAL          DETSYS
*KEND.

      DOUBLE PRECISION ALPHA1,ALPHA2,BETAN,DENS,DH,DR,DTHICK,ELOSS,
     *                 FNORM1,FNORM2,F1COS1,F1COS2,F1SIN1,F1SIN2,
     *                 GAMMAN,GAMSQ,GLCUT,GMSQM1,HEIGH,HMIDDL,
     *                 HNEW,OMEGA,PHI1,RADINV,RANNOR,
     *                 SINTH1,SINTH2,SN,SN1,SN2,SN3,SN4,
     *                 SNMIDDL1,SNMIDDL2,THICK,
     *                 THCKHN,THICKMDL,USW,U10,U12,U20,U22,V,VVV,
     *                 V10,V12,V20,V22,W10,W12,W20,W22
      INTEGER          I,IL,IPAS
      LOGICAL          CFLAG,MUS
      DOUBLE PRECISION GAM0,TH0
      DOUBLE PRECISION CHIT,DT,GAMK,HNEWC,RATIO,THCKHC
      INTEGER          ILAY
      LOGICAL          TCRNKV,TFLAG
c-----changed--add
      logical fmfb
c-----changed--add
      DOUBLE PRECISION AUXIL,CORR,DX,DY,SINDIF,TRANS2
      SAVE
      EXTERNAL         HEIGH,RANNOR,THICK
      DOUBLE PRECISION XBEG,YBEG,ZBEG,TBEG,EBEG,XEND,YEND,ZEND,TEND,
     *                 EEND,TPART,XPART,YPART,ZPART,WTPART,CTEA
      DATA             CFLAG /.TRUE./
C-----------------------------------------------------------------------

      IF (DEBUG) WRITE(MDEBUG,457) (CURPAR(I),I=1,9),HNEW
  457 FORMAT(' UPDATE: CURPAR=',1P,9E10.3/
     *       '         TO HEIGHT ',0P,F13.1)

      IRET2  = 1
      IRETE  = .FALSE.
C  TOTAL HEIGHT DIFFERENCE
      DH     = MAX( H - HNEW, 1.D-10 )
C  ATMOSPHERE THICKNESS TRAVERSED
      DTHICK = 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*DTHICK*COSTHE
      HMIDDL   = HEIGH(THICKMDL)

      SNMIDDL1 = ((H-HMIDDL))/COSTHE
      SNMIDDL2 = SN - SNMIDDL1
      SN1      = 0.5D0 * SNMIDDL1


C  CALCULATE KINETIC ENERGY CUT
      IF ( ITYPE .EQ. 5  .OR.  ITYPE .EQ. 6 ) THEN
        MUS   = .TRUE.
        GLCUT = ELCUT(2) / PAMA(ITYPE) + 1.D0
      ELSE
        MUS   = .FALSE.
        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
        IL     = ILAY
 1      CONTINUE
        GAM0   = MAX( GAM0, 1.0001D0 )
        GAMSQ  = GAM0**2
        GMSQM1 = GAMSQ - 1.D0
C  ENERGY LOSS BY IONIZATION
        ELOSS  = SIGNUM(ITYPE)**2 * C(22) *
     *              ( GAMSQ * (LOG(GMSQM1) + C(23)) / GMSQM1 - 1.D0 )
C  LOOK WETHER PARTICLE PENETRATES LAYER BOUNDARY
        IF ( THICKL(IL) .LT. THCKHN  .AND.  IL .GT. 1 ) THEN
C  CALCULATE NEW START VALUES AT LAYER BOUNDARY
          GAM0 = GAM0 - ELOSS * (THICKL(IL) - TH0)
     *                              / (PAMA(ITYPE)*COSTHE)
          IF ( GAM0 .LE. 1.D0 ) THEN
            GAMMAN = 1.0001D0
            GOTO 3
          ENDIF
          TH0  = THICKL(IL)
          IL   = IL - 1
          GOTO 1
        ENDIF
C  GAMMA VALUE FOR CHARGED PARTICLES AT END OF STEP
        GAMMAN = GAM0 - ELOSS * (THCKHN-TH0) / (PAMA(ITYPE)*COSTHE)
 3      CONTINUE

      ELSE
C  NO LOSS FOR NEUTRAL PARTICLES
        GAMMAN = GAMMA
      ENDIF

      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
          TH0    = MAX( THICKH, THICKL(5) )
 2        CONTINUE
          GAM0   = MAX( GAM0, 1.0001D0 )
          GAMSQ  = GAM0**2
          GMSQM1 = GAMSQ - 1.D0
C  ENERGY LOSS BY IONIZATION
          ELOSS  = SIGNUM(ITYPE)**2 * C(22) *
     *             ( GAMSQ * (LOG(GMSQM1) + C(23)) / GMSQM1 -1.D0 )
          ELOSS  =  ELOSS / (PAMA(ITYPE) * COSTHE)
          GAMK   = GAM0 - ELOSS * (THICKL(IL) - TH0)
C  LOOK WETHER PARTICLE PENETRATES LAYER BOUNDARY
          IF ( GAMMAN .LT. GAMK  .AND.  IL. GT. 1 ) THEN
C  CALCULATE PORTION OF RANGE AND NEW START VALUES AT LAYER BOUNDARY
            CHIT = CHIT + (THICKL(IL) - TH0) / COSTHE
            GAM0 = GAMK
            TH0  = THICKL(IL)
            IL   = IL - 1
            GOTO 2
          ENDIF
C  PENETRATED MATTER THICKNESS
          CHI    = CHIT + (GAM0 - GAMMAN) / (ELOSS*COSTHE)
          IF ( DEBUG ) WRITE(MDEBUG,*) 'UPDATE: GAMMAN,CHI=',
     *                                  SNGL(GAMMAN),SNGL(CHI)
C  CALCULATE CORRECTED PATH PARAMETERS
          THCKHC = THICKH + COSTHE * CHI
          HNEWC  = HEIGH(THCKHC)
          DT     = SN / (C(25) * BETA * GAMMA)
          RATIO  = .5D0 * (H-HNEWC) / DH
          DH     = MAX( H - HNEWC, 1.D-10 )
          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
          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 ',ITYPE,' BELOW ENERGY CUT'
          IRETE = .TRUE.
          RETURN
        ENDIF
      ENDIF

C-----------------------------------------------------------------------
      IF ( IPAS .EQ. 0 ) THEN
C  UPDATE TO THE END POINT OF THE TRACK

        IF ( MUS ) THEN
C  COULOMB SCATTERING ANGLE (FOR MUONS ONLY)
          IF ( FMOLI ) THEN
C  TREAT MUON MULTIPLE SCATTERING BY MOLIERE THEORY (SEE GEANT)
C  CALCULATE AVERAGE DENSITY AND NUMBER OF SCATTERING (OMEGA)
            DENS  = COSTHE * CHI/DH
            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(5) * GAMMA * BETA**2) )
          ENDIF
          CALL RMMAR( RD,1,1 )
          PHISCT = RD(1) * PI2
          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
          TCRNKV   = .TRUE.
        ENDIF

C  UPDATE TO THE OBSERVATION LEVELS
      ELSE
        IF ( MUS ) THEN
C  COULOMB SCATTERING ANGLE (FOR MUONS ONLY)
          V = VSCAT * SQRT( DTHICK / CHI )
        ENDIF
        IF ( LLONGI  .OR.  CFLAG ) THEN
C  CHERENKOV RADIATION: LOOK, WHETHER LOWEST OBSERVATION LEVEL
          IF ( IPAS .EQ. NOBSLV ) THEN
            TCRNKV = .TRUE.
          ELSE
            TCRNKV = .FALSE.
          ENDIF
        ENDIF
      ENDIF

      IF ( LLONGI  .OR.  CFLAG ) THEN
C  REJECT ALL PARTICLES IF BELOW KINETIC ENERGY CUT
        IF ( GAMMAN .LT. GLCUT  .AND.  .NOT.TCRNKV ) THEN
          IF (DEBUG) WRITE(MDEBUG,*) 'UPDATE: PARTICLE ',ITYPE,
     *      ' BELOW ENERGY CUT, CHERENKOV LIGHT NOT CALCULATED'
          OUTPAR(2) = GAMMAN
          IRETE = .TRUE.
          RETURN
        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
c--------changed---add
         if(fmfb) then
cc        ALPHA1 = SIGNUM(ITYPE) *
cc     *         MIN( 1.D0, 2.D0*SN1*BNORMC /(PAMA(ITYPE)*BETA*GAMMA) )
        SINTH1 = SQRT( 1.D0 - COSTHE**2 )
        U10    = SINTH1 * COS(-PHI)
        V10    = SINTH1 * SIN(-PHI)
        W10    = COSTHE
cc        FNORM1 = 1.D0 - 0.5D0*ALPHA1**2 * (1.D0 - 0.75D0*ALPHA1**2)
cc        F1COS1 = ( 1.D0 - FNORM1 ) * COSB
cc        F1SIN1 = ( 1.D0 - FNORM1 ) * SINB
cc        VVV = V10 * ALPHA1 * FNORM1
cc        USW = U10 * SINB - W10 * COSB
cc        U12 = U10 - F1SIN1 * USW + VVV * SINB
cc        V12 = FNORM1 * ( V10 - ALPHA1 * USW )
cc        W12 = W10 + F1COS1 * USW - VVV * COSB
        U12 = U10 
        V12 = V10 
        W12 = W10 


        RADINV = 1.5D0 - 0.5D0 * ( U12**2 + V12**2 + W12**2 )
        W12 = MIN( 1.D0, RADINV * W12 )
        IF ( W12 .LE. C(29) ) THEN
          IF ( DEBUG ) WRITE(MDEBUG,*)
     *                'UPDATE: PARTICLE ',ITYPE,' BELOW ANGLE CUT 1'
          IRETE  = .FALSE.
          RETURN
        ENDIF
        SN2 = SN1 * COSTHE / W12
        U12 = RADINV * U12
        V12 = RADINV * V12
        IF ( U12 .NE. 0.D0  .OR.  V12 .NE. 0.D0 ) THEN
          PHI1 = -ATAN2( V12, U12 )
        ELSE
          PHI1 = 0.D0
        ENDIF

         else
c--------changed---add
        ALPHA1 = SIGNUM(ITYPE) *
     *         MIN( 1.D0, 2.D0*SN1*BNORMC /(PAMA(ITYPE)*BETA*GAMMA) )
        SINTH1 = SQRT( 1.D0 - COSTHE**2 )
        U10    = SINTH1 * COS(-PHI)
        V10    = SINTH1 * SIN(-PHI)
        W10    = COSTHE
        FNORM1 = 1.D0 - 0.5D0*ALPHA1**2 * (1.D0 - 0.75D0*ALPHA1**2)
        F1COS1 = ( 1.D0 - FNORM1 ) * COSB
        F1SIN1 = ( 1.D0 - FNORM1 ) * SINB
        VVV = V10 * ALPHA1 * FNORM1
        USW = U10 * SINB - W10 * COSB
        U12 = U10 - F1SIN1 * USW + VVV * SINB
        V12 = FNORM1 * ( V10 - ALPHA1 * USW )
        W12 = W10 + F1COS1 * USW - VVV * COSB
        RADINV = 1.5D0 - 0.5D0 * ( U12**2 + V12**2 + W12**2 )
        W12 = MIN( 1.D0, RADINV * W12 )
        IF ( W12 .LE. C(29) ) THEN
          IF ( DEBUG ) WRITE(MDEBUG,*)
     *                'UPDATE: PARTICLE ',ITYPE,' BELOW ANGLE CUT 1'
          IRETE  = .FALSE.
          RETURN
        ENDIF
        SN2 = SN1 * COSTHE / W12
        U12 = RADINV * U12
        V12 = RADINV * V12
        IF ( U12 .NE. 0.D0  .OR.  V12 .NE. 0.D0 ) THEN
          PHI1 = -ATAN2( V12, U12 )
        ELSE
          PHI1 = 0.D0
        ENDIF
c--------changed---add
        endif
c--------changed---add
C  CHERENKOV RADIATION: FILL PARTICLE COORDINATES
        IF ( TCRNKV ) THEN
C  ..BEG  ARE THE COORDINATES AT BEGIN OF THIS STEP
C  ..PART ARE THE COORDINATES AT END   OF THIS STEP
          IF ( .NOT. DETSYS ) THEN
C  TRANSFORM INTO DETECTOR FRAME
C  FIRST CALCULATE STEP TO X AND Y ALONG EARTH SURFACE
            DX     = +SN1 * U10 + SN2 * U12
            DY     = -SN1 * V10 - SN2 * V12
            TRANS2 = DX**2 + DY**2
            AUXIL  = SQRT( TRANS2 + (C(1)+HMIDDL)**2 )
            SINDIF = SQRT(TRANS2) / AUXIL
            IF ( SINDIF .GT. 0.D0 ) THEN
              CORR = C(1) * ASIN(SINDIF) / (AUXIL*SINDIF)
            ELSE
              CORR = 1.D0
            ENDIF
            XPART = X + DX*CORR
            YPART = Y + DY*CORR
C  CALCULATE ANGLE BETWEEN THE ACTUAL LOCAL AND THE APPARENT COORDINATE
C  SYSTEM  (IMPORTANT FOR DECIDING IN CERENK IF FIRST OR SECOND CALL
C  AND TO CALCULATE THE INTERMEDIATE DIF ANGLE)
            AUXIL = SQRT( X**2 + Y**2 )
            CTEA  = COS( AUXIL/C(1) )
C  NOW TRANSFORM THEM IN DETECTOR FRAME.  ATTENTION: ANGLE MIGHT BE
C  VERY LARGE, THEREFORE APPROXIMATION  TAN(X) EQUAL X IS NOT ALLOWED!
C  SINCE X = X(HAPP), DON'T TRANSFORM X AND Y HERE BUT IN CERENK
            XBEG  = X
            YBEG  = Y
          ELSE
            CTEA  = 1.D0
            XBEG  = X
            YBEG  = Y
            XPART = X + SN1 * U10 + SN2 * U12
            YPART = Y - SN1 * V10 - SN2 * V12
          ENDIF
          TPART = T + ( SN1 + SN2 ) / ( C(25) * BETA )
CDH       ZPART = H - DH * 0.5D0
          ZPART = HMIDDL
C  SET OTHER FUNCTION ARGUMENTS
          TBEG  = T
          ZBEG  = H
          EBEG  = PAMA(ITYPE)*GAMMA
          TEND  = TPART
          XEND  = XPART
          YEND  = YPART
          ZEND  = ZPART
          EEND  = PAMA(ITYPE)*GAMMAN
          WTPART = 1.D0
          CALL CERENK(SN1+SN2,U12,-V12,W12,EBEG,EEND-0.5D0*(EEND-EBEG),
     *       XBEG,YBEG,ZBEG,XEND,YEND,ZEND,TBEG,TEND,
     *       PAMA(ITYPE),SIGNUM(ITYPE),WTPART,CTEA)
        ENDIF

C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  CHANGE DIRECTION BY COULOMB SCATTERING (FOR MUONS ONLY)
        IF ( MUS ) THEN
C  BEFORE SCATTERING : DIRECTION COSINES ARE U12,V12,W12
          CALL ADDANG( W12,PHI1, COS(V),PHISCT, W20,PHI1 )
          IF ( W20 .LE. C(29) ) THEN
            IF (DEBUG) WRITE(MDEBUG,*) 'UPDATE: MUON BELOW ANGLE CUT'
            IRETE  = .FALSE.
            RETURN
          ENDIF
          SINTH2 = SQRT( 1.D0 - W20**2 )
          U20    = SINTH2 * COS( -PHI1 )
          V20    = SINTH2 * SIN( -PHI1 )
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
              THCKHN = THICK(HNEW)
              CHI    = 0.5D0 * CHI + (THCKHN - THICKMDL)/W20
              IF ( DEBUG ) WRITE(MDEBUG,*)
     *         'UPDATE: DECAY HNEW=',SNGL(HNEW),' CH=',SNGL(CHI)
              CHI = MAX( CHI, 1.D-20)
            ELSE
C  IN CASE OF INTERACTION THE PENETRATED MATTER IS KEPT CONSTANT
              THCKHN   = THICKMDL + 0.5D0*CHI*W20
              HNEW     = HEIGH(THCKHN)
              SNMIDDL2 = (HMIDDL - HNEW)/W20
              IF ( DEBUG ) WRITE(MDEBUG,*)
     *         'UPDATE: INTERACT HNEW=',SNGL(HNEW),' SNMIDDL2=',SNMIDDL2
            ENDIF
            STEPL = SNMIDDL1 + SNMIDDL2
            SN3   = 0.5D0 * SNMIDDL2
          ELSE
C  KEEP ARRIVAL HEIGHT AND SNMIDDL2, PARTICLE ARRIVES AT OBSERV. LEVEL
            SN3   = 0.5D0 * SNMIDDL2 * COSTHE / W20
          ENDIF
        ELSE
          U20 = U12
          V20 = V12
          W20 = W12
          SN3 = 0.5D0 * SNMIDDL2 * COSTHE / W20
        ENDIF

C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  TRANSPORT CHARGED PARTICLES THE SECOND PORTION OF STEP
C  NEW PATH LENGTH, NEW BETA VALUE BECAUSE OF IONIZATION ENERGY LOSS
        BETAN  = SQRT( GAMMAN**2 - 1.D0 ) / GAMMAN
C  DEFLECTION IN EARTH MAGNETIC FIELD ON SECOND HALF OF STEP
c--------changed---add
         if(fmfb) then

cc        ALPHA2 = SIGNUM(ITYPE) *
cc     *           MIN(1.D0,2.D0*SN3*BNORMC / (PAMA(ITYPE)*BETAN*GAMMAN))
cc        FNORM2 = 1.D0 - 0.5D0*ALPHA2**2 * (1.D0 - 0.75D0*ALPHA2**2)
cc        F1SIN2 = ( 1.D0 - FNORM2 ) * SINB
cc        F1COS2 = ( 1.D0 - FNORM2 ) * COSB
cc        VVV = V20 * ALPHA2 * FNORM2
cc        USW = U20 * SINB - W20 * COSB
cc        U22 = U20 - F1SIN2 * USW + VVV * SINB
cc        V22 = FNORM2 * ( V20 - ALPHA2 * USW )
cc        W22 = W20 + F1COS2 * USW - VVV * COSB
        U22 = U20
        V22 = V20
        W22 = W20


        RADINV = 1.5D0 - 0.5D0 * ( U22**2 + V22**2 + W22**2 )
        W22 = MIN( 1.D0, RADINV * W22 )
        IF ( W22 .LE. C(29) ) THEN
          IF ( DEBUG ) WRITE(MDEBUG,*)
     *                    'UPDATE: PARTICLE ',ITYPE,' BELOW ANGLE CUT 2'
          IRETE  = .FALSE.
          RETURN
        ENDIF
        SN4 = SN3 * W20 / W22
        U22 = RADINV * U22
        V22 = RADINV * V22

        else
c--changed---add

        ALPHA2 = SIGNUM(ITYPE) *
     *           MIN(1.D0,2.D0*SN3*BNORMC / (PAMA(ITYPE)*BETAN*GAMMAN))
        FNORM2 = 1.D0 - 0.5D0*ALPHA2**2 * (1.D0 - 0.75D0*ALPHA2**2)
        F1SIN2 = ( 1.D0 - FNORM2 ) * SINB
        F1COS2 = ( 1.D0 - FNORM2 ) * COSB
        VVV = V20 * ALPHA2 * FNORM2
        USW = U20 * SINB - W20 * COSB
        U22 = U20 - F1SIN2 * USW + VVV * SINB
        V22 = FNORM2 * ( V20 - ALPHA2 * USW )
        W22 = W20 + F1COS2 * USW - VVV * COSB
        RADINV = 1.5D0 - 0.5D0 * ( U22**2 + V22**2 + W22**2 )
        W22 = MIN( 1.D0, RADINV * W22 )
        IF ( W22 .LE. C(29) ) THEN
          IF ( DEBUG ) WRITE(MDEBUG,*)
     *                    'UPDATE: PARTICLE ',ITYPE,' BELOW ANGLE CUT 2'
          IRETE  = .FALSE.
          RETURN
        ENDIF
        SN4 = SN3 * W20 / W22
        U22 = RADINV * U22
        V22 = RADINV * V22
c--changed---add
        endif
c--changed---add

        OUTPAR(3) = W22
        IF ( U22 .NE. 0.D0  .OR.  V22 .NE. 0.D0 ) THEN
          OUTPAR(4) = -ATAN2( V22, U22 )
        ELSE
          OUTPAR(4) = 0.D0
        ENDIF
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
C  CHERENKOV RADIATION: FILL PARTICLE COORDINATES
        IF ( TCRNKV ) THEN
          IF ( .NOT. DETSYS ) THEN
C  RESAVE OLD COORDINATES DUE TO DIFFERENT DEFINITION IN CERENK
C  (COORDINATES WERE TRANSFORMED IN CERENK)
            XEND = XPART
            YEND = YPART
            ZEND = ZPART
C  TRANSFORM INTO DETECTOR FRAME
C  FIRST CALCULATE STEP TO X AND Y ALONG EARTH SURFACE
            DX     = +SN1*U10 + SN2*U12 + SN3*U20 + SN4*U22
            DY     = -SN1*V10 - SN2*V12 - SN3*V20 - SN4*V22
            TRANS2 = DX**2 + DY**2
            AUXIL  = SQRT( TRANS2 + (C(1)+HNEW)**2 )
            SINDIF = SQRT(TRANS2) / AUXIL
            IF ( SINDIF .GT. 0.D0 ) THEN
              CORR = C(1)*ASIN(SINDIF)/(AUXIL*SINDIF)
            ELSE
              CORR = 1.D0
            ENDIF
            XPART = X + DX*CORR
            YPART = Y + DY*CORR
C  CALCULATE EARTH ANGLE BETWEEN THE ACTUAL LOCAL AND THE
C  APPARENT COORDINATE SYSTEM (SEE ABOVE)
            AUXIL = SQRT( X**2 + Y**2 )
            CTEA  = COS( AUXIL/C(1) )
C  NOW TRANSFORM THEM IN DETECTOR FRAME.  ATTENTION: ANGLE MIGHT BE
C  VERY LARGE, THEREFORE APPROXIMATION  TAN(X) EQUAL X IS NOT ALLOWED!
C  DON'T TRANSFORM X AND Y HERE BUT IN CERENK (SEE ABOVE)
C  XBEG=XEND(LAST PART) AND YBEG=YEND(LAST PART) ARE SET ABOVE
          ELSE
            CTEA  = 1.D0
            XPART = OUTPAR(7)
            YPART = OUTPAR(8)
          ENDIF
          ZPART = HNEW
          TPART = OUTPAR(6)
C  SET OTHER FUNCTION ARGUMENTS (FORMER END IS NOW THE BEGIN)
          TBEG  = TEND
          XBEG  = XEND
          YBEG  = YEND
          ZBEG  = ZEND
          TEND  = TPART
          XEND  = XPART
          YEND  = YPART
          ZEND  = ZPART
          WTPART = 1.D0
          CALL CERENK(SN3+SN4,U22,-V22,W22,EBEG+0.5*(EEND-EBEG),EEND,
     *                XBEG,YBEG,ZBEG,XEND,YEND,ZEND,TBEG,TEND,
     *                PAMA(ITYPE),SIGNUM(ITYPE),WTPART,CTEA)
        ENDIF
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

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 AFTER CREATION OF CHERENKOV LIGHT'
            OUTPAR(2) = GAMMAN
            IRETE = .TRUE.
            RETURN
          ENDIF
        ENDIF

C-----------------------------------------------------------------------
      ELSE
C  NEUTRAL PARTICLES
C  NO COULOMB SCATTERING, NO DEFLECTION IN MAGNETIC FIELD

C  HORIZONTAL PATH LENGTH
        DR        = SN * SQRT( 1.D0 - COSTHE**2 )
C  UPDATE COORDINATES AND TIME
        OUTPAR(3) = COSTHE
        OUTPAR(4) = PHI
        OUTPAR(6) = T + SN / ( C(25) * BETA )
        OUTPAR(7) = X + DR * COS(PHI)
        OUTPAR(8) = Y + DR * SIN(PHI)

      ENDIF

C-----------------------------------------------------------------------
      OUTPAR( 1) = CURPAR(1)
      OUTPAR( 2) = GAMMAN
      OUTPAR( 5) = HNEW
      OUTPAR( 9) = GEN
      OUTPAR(10) = ALEVEL

      IF (DEBUG) WRITE(MDEBUG,458) (OUTPAR(I),I=1,9)
  458 FORMAT(' UPDATE: OUTPAR=',1P,8E10.3,0P,F10.0)


C  REGULAR END OF UPDATE
      IRET2 = 0
      RETURN
      END
*CMZ :          27/02/2002  16.27.14  by  D. HECK IK FZK KARLSRUHE
*-- Author :    D. HECK IK3 FZK KARLSRUHE       27/04/94
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 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
C   PFRY(1:JFIN) = TRANSVERSE MOMENTUM OF FRAGMENTS IN Y-DIRECTION
C
C  DESIGN  : D. HECK    IK3  FZK KARLSRUHE
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,CONSTA.
      COMMON /CONSTA/  PI,PI2,OB3,TB3,ENEPER
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER
*KEEP,DPMFLG.
      COMMON /DPMFLG/  NFLAIN,NFLDIF,NFLPI0,NFLCHE,NFLPIF,NFRAGM
      INTEGER          NFLAIN,NFLDIF,NFLPI0,NFLCHE,NFLPIF,NFRAGM
*KEEP,RANDPA.
      COMMON /RANDPA/  FAC,U1,U2,RD,NSEQ,ISEED,KNOR
      DOUBLE PRECISION FAC,U1,U2
      REAL             RD(3000)
      INTEGER          ISEED(103,10),NSEQ
      LOGICAL          KNOR
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEND.

      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 RMMAR(RD,2*NINTA,1)
      DO  22  L = 1,NINTA
        IF ( RD(NINTA+L) .LT. RD(L) ) RD(L) = 1. - RD(L)
        EEX = EEX + RD(L)
 22   CONTINUE
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 = FLOAT(NPRF)
      AFIN = APRF - 1.6D0 * FLOAT(NNSTEP)
      NFIN = MAX( INT(AFIN+0.5D0), 0 )
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  31  LS = 1,NNSTEP
          IARM = ITYPRM/100
          IF ( IARM .LE. 0 ) GOTO 100
          IZRM = MOD(ITYPRM,100)
          INRM = IARM - IZRM
          JC = JC + 1
          CALL RMMAR(RD,2,1)
          IF ( RD(1).LT.0.2 .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
 31     CONTINUE
      ENDIF

      IF ( NNUC .LT. 4 ) THEN
C  EVAPORATION WITHOUT FORMATION OF ALPHA PARTICLES
        CALL RMMAR(RD,NNUC,1)
        DO  32  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
 32     CONTINUE
      ENDIF

 50   CONTINUE
      JC = JC + 1
      IF     ( ITYPRM .GT. 101 ) THEN
        ITYP(JC) = ITYPRM
      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  JFIN = JC
      IF (DEBUG) WRITE(MDEBUG,*) 'VAPOR : NO   ITYP           PFR'
      IF     ( NFRAGM .EQ. 2 ) THEN
C  EVAPORATION WITH PT AFTER PARAMETRIZED JACEE DATA
        DO  150  MF = 1,JFIN
          PFR(MF) = RANNOR(0.088D0,0.044D0)
          IF ( DEBUG ) WRITE(MDEBUG,*) MF,ITYP(MF),SNGL(PFR(MF))
 150    CONTINUE
      ELSEIF ( NFRAGM .EQ. 3 ) THEN
C  EVAPORATION WITH PT AFTER GOLDHABER'S MODEL (PHYS.LETT.53B(1974)306)
        DO  160  MF = 1,JFIN
          K = MAX( 1, ITYP(MF)/100 )
          BGLH  = K * (MAPROJ - K) / FLOAT(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))
 160    CONTINUE
      ELSE
C  EVAPORATION WITHOUT TRANSVERSE MOMENTUM
        DO  165  MF = 1,JFIN
          PFR(MF) = 0.D0
          IF ( DEBUG ) WRITE(MDEBUG,*) MF,ITYP(MF),SNGL(PFR(MF))
 165    CONTINUE
      ENDIF
C  CALCULATE RESIDUAL TRANSVERSE MOMENTUM
      SPFRX = 0.D0
      SPFRY = 0.D0
      CALL RMMAR(RD,JFIN,1)
      DO  170  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)
 170  CONTINUE
C  CORRECT ALL TRANSVERSE MOMENTA FOR MOMENTUM CONSERVATION
      SPFRX = SPFRX / JFIN
      SPFRY = SPFRY / JFIN
      DO  180  MF = 1,JFIN
        PFRX(MF) = PFRX(MF) - SPFRX
        PFRY(MF) = PFRY(MF) - SPFRY
 180  CONTINUE

      IF (DEBUG) WRITE(MDEBUG,*) 'VAPOR : NINTA,JFIN= ',NINTA,JFIN
      RETURN
      END
*CMZ :          11/01/2002  09.25.08  by  D. HECK IK FZK KARLSRUHE
*-- 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
*KEEP,EGSDEB.
      COMMON /EGSDEB/  JCLOCK,NCLOCK,FEGSDB
      INTEGER          JCLOCK,NCLOCK
      LOGICAL          FEGSDB
*KEEP,RANDPA.
      COMMON /RANDPA/  FAC,U1,U2,RD,NSEQ,ISEED,KNOR
      DOUBLE PRECISION FAC,U1,U2
      REAL             RD(3000)
      INTEGER          ISEED(103,10),NSEQ
      LOGICAL          KNOR
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEEP,STACKE.
      COMMON /STACKE/  E,TIM,U,V,W,X,Y,Z,DNEAR,
     *                 ZAP,WAP,WA,
     *                 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)
     *                 ,ZAP(60),WAP(60),WA(60)
      INTEGER          IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP
*KEND.
      COMMON /UPHIOT/  THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI
      DOUBLE PRECISION THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI
      COMMON /USEFUL/  PRM,PRMT2,RMI,VCI,MEDIUM,MEDOLD,IBLOBE
      DOUBLE PRECISION PRM,PRMT2,RMI,VCI
      INTEGER          MEDIUM,MEDOLD,IBLOBE

      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 RMMAR(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**2 ))
      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**2 ))
      CALL UPHI(3,2)
      RETURN
      END
*CMZ :          11/01/2002  09.25.08  by  D. HECK IK FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
C=======================================================================

      SUBROUTINE AUSGAB

C-----------------------------------------------------------------------
C  WE USE AUSGAB TO FILL OUTPAR WITH PARTICLE COORDINATES.
C  THIS SUBROUTINE IS CALLED FROM ELECTR AND PHOTON.
C
C  DESIGN  : D. HECK   IK3  FZK KARLSRUHE
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,EGSDEB.
      COMMON /EGSDEB/  JCLOCK,NCLOCK,FEGSDB
      INTEGER          JCLOCK,NCLOCK
      LOGICAL          FEGSDB
*KEEP,GENER.
      COMMON /GENER/   GEN,ALEVEL
      DOUBLE PRECISION GEN,ALEVEL
*KEND.
      COMMON /MISC/    DUNIT,RHOR,KMPI,KMPO,NOSCAT,MED,IRAYLR
      DOUBLE PRECISION DUNIT,RHOR(6)
      INTEGER          KMPI,KMPO,NOSCAT,MED(6),IRAYLR(6)
*KEEP,PARPAR.
      COMMON /PARPAR/  CURPAR,SECPAR,PRMPAR,OUTPAR,C,
     *                 E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
      DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16),
     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH
      INTEGER          ITYPE,LEVL
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEEP,STACKE.
      COMMON /STACKE/  E,TIM,U,V,W,X,Y,Z,DNEAR,
     *                 ZAP,WAP,WA,
     *                 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)
     *                 ,ZAP(60),WAP(60),WA(60)
      INTEGER          IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP
*KEND.
      COMMON /UPHIOT/  THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI
      DOUBLE PRECISION THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI
      COMMON /USEFUL/  PRM,PRMT2,RMI,VCI,MEDIUM,MEDOLD,IBLOBE
      DOUBLE PRECISION PRM,PRMT2,RMI,VCI
      INTEGER          MEDIUM,MEDOLD,IBLOBE

      DOUBLE PRECISION ANGLEX,ANGLEZ,XX,YY,ZZ
      SAVE
C-----------------------------------------------------------------------

C  ANGLE WITH RESPECT TO X AXIS
      IF ( U(NP) .NE. 0.D0  .OR.  V(NP) .NE. 0.D0 ) THEN
        ANGLEX = -ATAN2(V(NP),U(NP))
      ELSE
        ANGLEX = 0.D0
      ENDIF
C  PARTICLE IS WRITTEN IN OUTPUT BUFFER ARRAY
      OUTPAR(1)  = IQ(NP)
      OUTPAR(2)  = E(NP)*0.001D0
      OUTPAR(3)  = MIN( 1.D0, W(NP) )
      OUTPAR(4)  = ANGLEX
      OUTPAR(5)  =-Z(NP)
      OUTPAR(6)  = TIM(NP)
      OUTPAR(7)  = X(NP)
      OUTPAR(8)  =-Y(NP)
      OUTPAR(9)  = IGEN(NP)
      OUTPAR(10) = ALEVEL
      LEVL = IOBS(NP)
      CALL OUTPT1
      IF ( FEGSDB ) THEN
        WRITE(MDEBUG,*) 'AUSGAB: NP=',NP,' IR=',IR(NP),' IOBS=',IOBS(NP)
        XX = X(NP)
        YY =-Y(NP)
        ZZ =-Z(NP)
        ANGLEZ = W(NP)
        WRITE(MDEBUG,170) IQ(NP),E(NP)*.001D0,ANGLEZ,ANGLEX,ZZ,
     *      TIM(NP)*1.D3,XX,YY,IGEN(NP)
 170    FORMAT(' AUSGAB:',13X,I4,1P,E11.3,0P,1X,F7.4,1X,F7.4,1X,F9.0,
     *          F9.6,1X,1P,E11.4,1X,E11.4,1X,I3
     *          )
      ENDIF
      RETURN
      END
*CMZ :          18/02/2002  16.47.35  by  D. HECK IK FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
C=======================================================================

      SUBROUTINE AUSGB2

C-----------------------------------------------------------------------
C  IN CASE OF DEBUGGING WE PRINT THE PARTICLE COORDINATES.
C  THIS SUBROUTINE IS CALLED FROM MANY EGS-ROUTINES.
C
C  DESIGN  : D. HECK   IK3  FZK KARLSRUHE
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,EGSDEB.
      COMMON /EGSDEB/  JCLOCK,NCLOCK,FEGSDB
      INTEGER          JCLOCK,NCLOCK
      LOGICAL          FEGSDB
*KEND.
      COMMON /MISC/    DUNIT,RHOR,KMPI,KMPO,NOSCAT,MED,IRAYLR
      DOUBLE PRECISION DUNIT,RHOR(6)
      INTEGER          KMPI,KMPO,NOSCAT,MED(6),IRAYLR(6)
*KEEP,PARPAR.
      COMMON /PARPAR/  CURPAR,SECPAR,PRMPAR,OUTPAR,C,
     *                 E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
      DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16),
     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH
      INTEGER          ITYPE,LEVL
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEEP,STACKE.
      COMMON /STACKE/  E,TIM,U,V,W,X,Y,Z,DNEAR,
     *                 ZAP,WAP,WA,
     *                 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)
     *                 ,ZAP(60),WAP(60),WA(60)
      INTEGER          IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP
*KEND.
      COMMON /UPHIOT/  THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI
      DOUBLE PRECISION THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI
      COMMON /USEFUL/  PRM,PRMT2,RMI,VCI,MEDIUM,MEDOLD,IBLOBE
      DOUBLE PRECISION PRM,PRMT2,RMI,VCI
      INTEGER          MEDIUM,MEDOLD,IBLOBE

      DOUBLE PRECISION ANGLEX,ANGLEZ,XX,YY,ZZ
      SAVE
C-----------------------------------------------------------------------

C  ANGLE WITH RESPECT TO X AXIS
      IF ( U(NP) .NE. 0.D0  .OR.  V(NP) .NE. 0.D0 ) THEN
        ANGLEX = -ATAN2(V(NP),U(NP))
      ELSE
        ANGLEX = 0.D0
      ENDIF
      XX = X(NP)
      YY =-Y(NP)
      ZZ =-Z(NP)
      ANGLEZ = W(NP)
      WRITE(MDEBUG,170) IQ(NP),E(NP)*.001D0,ANGLEZ,ANGLEX,ZZ,
     *    TIM(NP)*1.0D3,XX,YY,IGEN(NP)
 170  FORMAT(' AUSGB2:',13X,I4,1P,E11.3,0P,1X,F8.5,1X,F7.4,1X,F9.0,
     *  1X,F9.6,1X,1P,E11.4,1X,E11.4,0P,1X,I3
     * )
      RETURN
      END
*CMZ :          11/01/2002  09.25.08  by  D. HECK IK FZK KARLSRUHE
*-- 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
*KEEP,EGSDEB.
      COMMON /EGSDEB/  JCLOCK,NCLOCK,FEGSDB
      INTEGER          JCLOCK,NCLOCK
      LOGICAL          FEGSDB
*KEEP,RANDPA.
      COMMON /RANDPA/  FAC,U1,U2,RD,NSEQ,ISEED,KNOR
      DOUBLE PRECISION FAC,U1,U2
      REAL             RD(3000)
      INTEGER          ISEED(103,10),NSEQ
      LOGICAL          KNOR
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEEP,STACKE.
      COMMON /STACKE/  E,TIM,U,V,W,X,Y,Z,DNEAR,
     *                 ZAP,WAP,WA,
     *                 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)
     *                 ,ZAP(60),WAP(60),WA(60)
      INTEGER          IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP
*KEND.
      COMMON /THRESH/  RMSQ,API,TE,THMOLL,AP,AE,UP,UE
      DOUBLE PRECISION RMSQ,API,TE,THMOLL
      REAL             AP,AE,UP,UE
      COMMON /UPHIOT/  THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI
      DOUBLE PRECISION THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI
      COMMON /USEFUL/  PRM,PRMT2,RMI,VCI,MEDIUM,MEDOLD,IBLOBE
      DOUBLE PRECISION PRM,PRMT2,RMI,VCI
      INTEGER          MEDIUM,MEDOLD,IBLOBE

*     DOUBLE PRECISION BETAI2,BR,B1,B2,B3,B4,DCOSTH,EP0,EP0C,E0,E02,H1,
      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

      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
C  CORRECTED 18.12.98
*     BETAI2= E02/(E02-1.D0)
      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 RMMAR(RD,2,2)
      BR    = EP0/(1.D0-EP0C*RD(1))
C  CORRECTED 18.12.98
*     REJF2 = EP0C*(BETAI2-BR*(B1-BR*(B2-BR*(B3-BR*B4))))
      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
*CMZ :          11/01/2002  09.25.08  by  D. HECK IK FZK KARLSRUHE
*-- Author :    STANFORD LINEAR ACCELERATOR CENTER
C=======================================================================
C                                STANFORD LINEAR ACCELERATOR CENTER
      SUBROUTINE BREMS
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-----------------------------------------------------------------------

      IMPLICIT NONE
      COMMON /BREMPR/  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)
*KEEP,EGSDEB.
      COMMON /EGSDEB/  JCLOCK,NCLOCK,FEGSDB
      INTEGER          JCLOCK,NCLOCK
      LOGICAL          FEGSDB
*KEEP,RANDPA.
      COMMON /RANDPA/  FAC,U1,U2,RD,NSEQ,ISEED,KNOR
      DOUBLE PRECISION FAC,U1,U2
      REAL             RD(3000)
      INTEGER          ISEED(103,10),NSEQ
      LOGICAL          KNOR
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEEP,STACKE.
      COMMON /STACKE/  E,TIM,U,V,W,X,Y,Z,DNEAR,
     *                 ZAP,WAP,WA,
     *                 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)
     *                 ,ZAP(60),WAP(60),WA(60)
      INTEGER          IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP
*KEND.
      COMMON /THRESH/  RMSQ,API,TE,THMOLL,AP,AE,UP,UE
      DOUBLE PRECISION RMSQ,API,TE,THMOLL
      REAL             AP,AE,UP,UE
      COMMON /UPHIOT/  THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI
      DOUBLE PRECISION THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI
      COMMON /USEFUL/  PRM,PRMT2,RMI,VCI,MEDIUM,MEDOLD,IBLOBE
      DOUBLE PRECISION PRM,PRMT2,RMI,VCI
      INTEGER          MEDIUM,MEDOLD,IBLOBE

      DOUBLE PRECISION ABREMS,AI2LN2,BR,DEL,DELTA,P,PEIE,PESG,PESE,
     *                 REJF,T
      INTEGER          IDISTR,LVL,LVL0,LVX
      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 PHOTONS
C  OF MINIMUM DISCRETE TRANSPORT ENRGY AP, IN CASE THE (1-BR)/BR
C  PART OF THE DISTRIBUTION IS USED.
 351  CONTINUE
      CALL RMMAR(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 RMMAR(RD,3,2)
          BR =  1.D0-0.5D0*MAX(RD(2),RD(3))
          IF ( BR*RD(1) .GT. 0.5D0 ) GOTO 361
        ELSE
          CALL RMMAR(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=(PHOTON ENERGY)/E
C  ZG IS DEFINED IN THE PROGRAM SHINP, AND IS A WEIGHTED AVERAGE
C  OF LOG(Z**(-1./3.))  OVER THE VARIOUS TYPES OF ATOMS IN THE
C  MOLECULE (BUTCHER AND MESSEL, OP.CIT., P.17-19,22-24).
      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 RMMAR(RD,1,2)
C  SCREENING REJECTION
      IF ( RD(1) .GT. REJF ) GOTO 351
      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 PHOTON
        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
*CMZ :          11/01/2002  09.25.08  by  D. HECK IK FZK KARLSRUHE
*-- 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 PHOTON ENERGY /INITIAL PHOTON 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 PHOTON.
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,EGSDEB.
      COMMON /EGSDEB/  JCLOCK,NCLOCK,FEGSDB
      INTEGER          JCLOCK,NCLOCK
      LOGICAL          FEGSDB
*KEEP,RANDPA.
      COMMON /RANDPA/  FAC,U1,U2,RD,NSEQ,ISEED,KNOR
      DOUBLE PRECISION FAC,U1,U2
      REAL             RD(3000)
      INTEGER          ISEED(103,10),NSEQ
      LOGICAL          KNOR
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEEP,STACKE.
      COMMON /STACKE/  E,TIM,U,V,W,X,Y,Z,DNEAR,
     *                 ZAP,WAP,WA,
     *                 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)
     *                 ,ZAP(60),WAP(60),WA(60)
      INTEGER          IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP
*KEND.
      COMMON /THRESH/  RMSQ,API,TE,THMOLL,AP,AE,UP,UE
      DOUBLE PRECISION RMSQ,API,TE,THMOLL
      REAL             AP,AE,UP,UE
      COMMON /UPHIOT/  THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI
      DOUBLE PRECISION THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI
      COMMON /USEFUL/  PRM,PRMT2,RMI,VCI,MEDIUM,MEDOLD,IBLOBE
      DOUBLE PRECISION PRM,PRMT2,RMI,VCI
      INTEGER          MEDIUM,MEDOLD,IBLOBE

      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

      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 RMMAR(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 RMMAR(RD(4),1,2)
          BRP = MAX(RD(2),RD(4))
        ENDIF
        BR = ((BR0I-1.D0)*BRP+1.D0)*BR0
      ENDIF
C  BR=FINAL PHOTON ENERGY FRACTION
      PESG   = BR*PEIG
C  THE COMPTON ANGLES FOR PHOTON 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 RMMAR(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.0-COSTHE**2 ))
      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
*CMZ :          11/01/2002  09.25.08  by  D. HECK IK FZK KARLSRUHE
*-- Author :    D. HECK IK3 FZK KARLSRUHE   18/06/99
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   IK3  FZK KARLSRUHE
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,OBSPAR.
      COMMON /OBSPAR/  OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP,
     *                 THETPR,PHIPR,
     *                 VUECON,
     *                 NOBSLV
      DOUBLE PRECISION OBSLEV(10),THCKOB(10),XOFF(10),YOFF(10),
     *                 HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2)
      DOUBLE PRECISION VUECON(2)
      INTEGER          NOBSLV
*KEEP,PARPAR.
      COMMON /PARPAR/  CURPAR,SECPAR,PRMPAR,OUTPAR,C,
     *                 E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
      DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16),
     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH
      INTEGER          ITYPE,LEVL
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEEP,STACKE.
      COMMON /STACKE/  E,TIM,U,V,W,X,Y,Z,DNEAR,
     *                 ZAP,WAP,WA,
     *                 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)
     *                 ,ZAP(60),WAP(60),WA(60)
      INTEGER          IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP
*KEND.

      DOUBLE PRECISION DIST,DIAG,TANPHI,TEA
      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
      DIAG = SQRT( (C(1)-Z(NP))**2
     *            -(C(1)+OBSLEV(1))**2 *(1.D0-WAP(NP)**2) )
     *                                 - (C(1)+OBSLEV(1)) * WAP(NP)

C  APPARENT HEIGHT ZAP IS PARTICLE Z-COORDINATE IN DETECTOR SYSTEM
      ZAP(NP) = -OBSLEV(1) - DIAG * WAP(NP)

C  CALCULATING COSINE OF THETA_EARTH COSTEA, COSINE OF ZENITH ANGLE BY
C  TAKING A COORDINATE FRAME CENTERED IN THE MIDDLE OF EARTH
      WA(NP) = (C(1)-ZAP(NP)) / (C(1)-Z(NP))
      IF ( DEBUG ) WRITE(MDEBUG,*) 'CORNEC:-ZAP(NP),WA(NP),DIAG =',
     *                     SNGL(-ZAP(NP)),WA(NP),SNGL(DIAG)
      WA(NP) = MIN( 1.D0, WA(NP) )
C  TRANSFORM THE APPARENT ANGLE SEEN FROM DETECTOR POSITION TO LOCAL
C  ANGLES RELATIVE TO THE VERTICAL TO THE MIDDLE OF EARTH
C  NOTE : LOCAL ZENITH ANGLE = DIFFERENCE OF APPARENT ZENITH ANGLE AND
C         THETA_EARTH
      W(NP) = (DIAG + (C(1)+OBSLEV(1))*WAP(NP))/(C(1)-Z(NP))
      W(NP) = MIN( 1.D0, W(NP) )
      IF ( U(NP) .NE. 0.D0 ) THEN
        TANPHI= V(NP) / U(NP)
        U(NP) = SIGN(1.D0,U(NP))*SQRT((1.D0-W(NP)**2)/(1.D0+TANPHI**2))
        V(NP) = TANPHI * U(NP)
      ELSE
        IF ( V(NP) .NE. 0.D0 )
     *           V(NP) = SIGN(1.D0,V(NP)) * SQRT( 1.D0 - W(NP)**2 )
      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))
      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 OBSPAR, BUT IS NOT SENSIBEL TO USE IN THIS
C  ROUTINE; WE HAVE TO TAKE NOT PHI OF PRIMARY, BUT FROM CURRENT
C  PARTICLE. TAKE NEW LOCAL DIRECTION COSINES (SEE ABOVE)
      IF ( W(NP) .LT. 1.D0 ) THEN
        X(NP) = -DIST * U(NP) / SQRT( 1.D0 - W(NP)**2 )
        Y(NP) = -DIST * V(NP) / SQRT( 1.D0 - W(NP)**2 )
      ELSE
        X(NP) = -DIST * U(NP)
        Y(NP) = -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
*CMZ :          20/02/2002  09.17.35  by  D. HECK IK FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
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   = (R8) INCOMING PARTICLE ENERGY (GEV)
C
C  DESIGN  : D. HECK   IK3  FZK KARLSRUHE
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,EGSDEB.
      COMMON /EGSDEB/  JCLOCK,NCLOCK,FEGSDB
      INTEGER          JCLOCK,NCLOCK
      LOGICAL          FEGSDB
*KEEP,GENER.
      COMMON /GENER/   GEN,ALEVEL
      DOUBLE PRECISION GEN,ALEVEL
*KEND.
      COMMON /GEOMEGS/ ZALTIT,BOUND,OBSLVL,NEWOBS
      DOUBLE PRECISION ZALTIT,BOUND(6),OBSLVL(10)
      INTEGER          NEWOBS
*KEEP,LONGI.
      COMMON /LONGI/   ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP,LLONGI,FLGFIT
      DOUBLE PRECISION ADLONG(0:1170,9),AELONG(0:1170,9),
     *                 APLONG(0:1170,9),DLONG(0:1170,9),ELONG(0:1170,9),
     *                 HLONG(0:1170),PLONG(0:1170,9),SDLONG(0:1170,9),
     *                 SELONG(0:1170,9),SPLONG(0:1170,9),THSTEP,THSTPI
      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT
*KEND.
      COMMON /MISC/    DUNIT,RHOR,KMPI,KMPO,NOSCAT,MED,IRAYLR
      DOUBLE PRECISION DUNIT,RHOR(6)
      INTEGER          KMPI,KMPO,NOSCAT,MED(6),IRAYLR(6)
*KEEP,OBSPAR.
      COMMON /OBSPAR/  OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP,
     *                 THETPR,PHIPR,
     *                 VUECON,
     *                 NOBSLV
      DOUBLE PRECISION OBSLEV(10),THCKOB(10),XOFF(10),YOFF(10),
     *                 HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2)
      DOUBLE PRECISION VUECON(2)
      INTEGER          NOBSLV
*KEEP,PARPAR.
      COMMON /PARPAR/  CURPAR,SECPAR,PRMPAR,OUTPAR,C,
     *                 E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
      DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16),
     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH
      INTEGER          ITYPE,LEVL
*KEND.
      COMMON /PION/    PI0MSQ,PITHR,PICMAS,PI0MAS,AMASK0,AMASKC,AMASPR,
     *                 AMASNT
      DOUBLE PRECISION PI0MSQ,PITHR,PICMAS,PI0MAS,AMASK0,AMASKC,AMASPR,
     *                 AMASNT
*KEEP,REJECT.
      COMMON /REJECT/  AVNREJ,ALTMIN,ANEXP,THICKA,THICKD,CUTLN,EONCUT,
     *                 FNPRIM
      DOUBLE PRECISION AVNREJ(10),ALTMIN(10),ANEXP(10),THICKA(10),
     *                 THICKD(10),CUTLN,EONCUT
      LOGICAL          FNPRIM
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEEP,STACKE.
      COMMON /STACKE/  E,TIM,U,V,W,X,Y,Z,DNEAR,
     *                 ZAP,WAP,WA,
     *                 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)
     *                 ,ZAP(60),WAP(60),WA(60)
      INTEGER          IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP
*KEND.
      COMMON /THRESH/  RMSQ,API,TE,THMOLL,AP,AE,UP,UE
      DOUBLE PRECISION RMSQ,API,TE,THMOLL
      REAL             AP,AE,UP,UE
      COMMON /USEFUL/  PRM,PRMT2,RMI,VCI,MEDIUM,MEDOLD,IBLOBE
      DOUBLE PRECISION PRM,PRMT2,RMI,VCI
      INTEGER          MEDIUM,MEDOLD,IBLOBE

      DOUBLE PRECISION EEIN,SITHET,THICK
      INTEGER          IDET,K
      SAVE
      EXTERNAL         THICK
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)
      IF ( LLONGI ) LPCTE(1)=MIN(NSTEP,INT(THICK(SECPAR(5))*THSTPI)+1)
      SITHET = SQRT(1.D0-SECPAR(3)**2)
C  START DIRECTION COSINES
      U(NP)  = SITHET*COS(-SECPAR(4))
      V(NP)  = SITHET*SIN(-SECPAR(4))
      W(NP)  = SECPAR(3)
      ZAP(NP) =-SECPAR(14)
      WAP(NP) = SECPAR(15)
      WA(NP)  = SECPAR(16)
      IGEN(1) = GEN
C  CONVERSION GEV --> MEV
      E(1)    = EEIN*1000.D0
C  CHECK ENERGY RANGE
      IQ(1)   = NINT(SECPAR(1))
      IF ( IQ(1) .EQ. 1 ) THEN
        IF ( E(1) .GT. UP ) THEN
          CALL AUSGB2
          WRITE(KMPO,91) EEIN
 91       FORMAT(' EGS4  : ENERGY OF GAMMA =',1P,E10.3,' GEV TOO HIGH')
          STOP
        ENDIF
      ELSE
        IF ( E(1) .GT. UE ) THEN
          CALL AUSGB2
          WRITE(KMPO,92) EEIN
 92       FORMAT(' EGS4  : ENERGY OF ELECTRON/POSITRON =',1P,E10.3,
     *           ' GEV TOO HIGH')
          STOP
        ENDIF
      ENDIF
      DNEAR(1) = 0.D0
      DO 101  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
 101  CONTINUE
      CALL AUSGB2
      WRITE(KMPO,120) (-0.01)*Z(1)
 120  FORMAT (' EGS4  : START VALUE OF Z=',1P,E11.4,' M  NOT IN ',
     *  'ATMOSPHERE')
      RETURN
 110  CONTINUE
      DO 111  IDET = 1,NOBSLV
C  DETERMINE NEXT OBSERVATION LEVEL
        IF ( -Z(1) .GE. OBSLVL(IDET) ) THEN
          IOBS(1) = IDET
          GOTO 130
        ENDIF
 111  CONTINUE
      CALL AUSGB2
      WRITE(KMPO,140) (-0.01)*Z(1),OBSLVL(NOBSLV)*0.01
 140  FORMAT(' EGS4  : START VALUE OF Z= ',E11.4, ' M  BELOW LOWEST ',
     *  'DETECTOR AT',E11.4,' M')
      RETURN
 130  CONTINUE
C  NEWOBS IS THE NEXT OBSERVATION LEVEL
      NEWOBS = IOBS(NP)
      CALL SHOWER
      IF ( DEBUG ) WRITE(MDEBUG,*) 'EGS4  : EGS-STACK EMPTY, EXIT'
      RETURN
      END
*CMZ :          12/10/2001  14.53.55  by  D. HECK IK FZK KARLSRUHE
*-- 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
      COMMON /BOUNDS/  ECUT,PCUT,VACDST
      DOUBLE PRECISION ECUT(6),PCUT(6),VACDST
      COMMON /ELECIN/  EKE0,EKE1,XR0,TEFF0,BLCC,XCC,ESIG0,ESIG1,PSIG0,
     *                 PSIG1,EDEDX0,EDEDX1,PDEDX0,PDEDX1,EBR10,EBR11,
     *                 PBR10,PBR11,PBR20,PBR21,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),PBR10(500),PBR11(500),
     *                 PBR20(500),PBR21(500),TMXS0(500),TMXS1(500),
     *                 ERANG0(1),ERANG1(1),PRANG0(1),PRANG1(1),STERNCOR
*KEEP,EGSDEB.
      COMMON /EGSDEB/  JCLOCK,NCLOCK,FEGSDB
      INTEGER          JCLOCK,NCLOCK
      LOGICAL          FEGSDB
*KEEP,EPCONT.
      COMMON /EPCONT/  EDEP,RATIO,TSTEP,TUSTEP,USTEP,TVSTEP,VSTEP,
     *                 RHOFAC,EOLD,ENEW,EKE,ELKE,BETA2,GLE,TSCAT,
     *                 IDISC,IROLD,IRNEW
      DOUBLE PRECISION EDEP,RATIO,TSTEP,TUSTEP,USTEP,TVSTEP,VSTEP,
     *                 RHOFAC,EOLD,ENEW, EKE,ELKE,BETA2,GLE,TSCAT
      INTEGER          IDISC,IROLD,IRNEW

*KEND.
      COMMON /MEDIA/   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 /MEDIAC/  MEDIA
      CHARACTER        MEDIA*24
      COMMON /MISC/    DUNIT,RHOR,KMPI,KMPO,NOSCAT,MED,IRAYLR
      DOUBLE PRECISION DUNIT,RHOR(6)
      INTEGER          KMPI,KMPO,NOSCAT,MED(6),IRAYLR(6)
      COMMON /MULTS/   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
      COMMON /PATHCM/  B0PTH,B1PTH,PTH0,PTH1,PTH2,NPTH
      DOUBLE PRECISION B0PTH,B1PTH,PTH0(6),PTH1(6),PTH2(6)
      INTEGER          NPTH
      COMMON /THRESH/  RMSQ,API,TE,THMOLL,AP,AE,UP,UE
      DOUBLE PRECISION RMSQ,API,TE,THMOLL
      REAL             AP,AE,UP,UE
      COMMON /UPHIOT/  THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI
      DOUBLE PRECISION THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI
      COMMON /USEFUL/  PRM,PRMT2,RMI,VCI,MEDIUM,MEDOLD,IBLOBE
      DOUBLE PRECISION PRM,PRMT2,RMI,VCI
      INTEGER          MEDIUM,MEDOLD,IBLOBE

      CHARACTER        MEDIA1*24
      EQUIVALENCE      (MEDIA1,MEDIA)
C-----------------------------------------------------------------------
      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.0000D0/,B1G21/ 5.0000D0/
      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.0000D0/,B1G22/ 6.0000D0/
      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.0000D0/,B1G31/ 9.0000D0/
      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.0000D0/,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.0000D0/,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
*CMZ :          12/12/2001  11.52.56  by  D. HECK IK FZK KARLSRUHE
*-- Author :    D. HECK IK3 FZK KARLSRUHE       03/02/97
C=======================================================================

      SUBROUTINE EGSINI

C-----------------------------------------------------------------------
C  E(LECTRON) G(AMMA) S(HOWER) INI(TIALIZATION)
C
C  INITIALIZES EGS4 PACKAGE
C  THIS SUBROUTINE IS CALLED FROM START.
C
C  DESIGN  : D. HECK   IK3  FZK KARLSRUHE
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,ATMOS.
      COMMON /ATMOS/   AATM,AATM0,BATM,BATM0,CATM,CATM0,DATM,MODATM
      DOUBLE PRECISION AATM(5),AATM0(5,0:16),BATM(5),BATM0(5,0:16),
     *                 CATM(5),CATM0(5,0:16),DATM(5)
      INTEGER          MODATM
*KEEP,ATMOS2.
      COMMON /ATMOS2/  HLAY,HLAY0,THICKL,LAYNO,LAYNEW
      DOUBLE PRECISION HLAY(6),HLAY0(5,0:4),THICKL(5)
      INTEGER          LAYNO(0:16)
      LOGICAL          LAYNEW
*KEND.
      COMMON /BOUNDS/  ECUT,PCUT,VACDST
      DOUBLE PRECISION ECUT(6),PCUT(6),VACDST
*KEEP,ELABCT.
      COMMON /ELABCT/  ELCUT
      DOUBLE PRECISION ELCUT(4)
*KEND.
      COMMON /ELECIN/  EKE0,EKE1,XR0,TEFF0,BLCC,XCC,ESIG0,ESIG1,PSIG0,
     *                 PSIG1,EDEDX0,EDEDX1,PDEDX0,PDEDX1,EBR10,EBR11,
     *                 PBR10,PBR11,PBR20,PBR21,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),PBR10(500),PBR11(500),
     *                 PBR20(500),PBR21(500),TMXS0(500),TMXS1(500),
     *                 ERANG0(1),ERANG1(1),PRANG0(1),PRANG1(1),STERNCOR
      COMMON /GEOMEGS/ ZALTIT,BOUND,OBSLVL,NEWOBS
      DOUBLE PRECISION ZALTIT,BOUND(6),OBSLVL(10)
      INTEGER          NEWOBS
      COMMON /LAYER/   HBARO,HBAROI
      DOUBLE PRECISION HBARO(6),HBAROI(6)
      COMMON /MEDIA/   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 /MEDIAC/  MEDIA
      CHARACTER        MEDIA*24
      COMMON /MISC/    DUNIT,RHOR,KMPI,KMPO,NOSCAT,MED,IRAYLR
      DOUBLE PRECISION DUNIT,RHOR(6)
      INTEGER          KMPI,KMPO,NOSCAT,MED(6),IRAYLR(6)
      COMMON /MUON/    PRRMMU,RMMUT2
      DOUBLE PRECISION PRRMMU,RMMUT2
*KEEP,OBSPAR.
      COMMON /OBSPAR/  OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP,
     *                 THETPR,PHIPR,
     *                 VUECON,
     *                 NOBSLV
      DOUBLE PRECISION OBSLEV(10),THCKOB(10),XOFF(10),YOFF(10),
     *                 HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2)
      DOUBLE PRECISION VUECON(2)
      INTEGER          NOBSLV
*KEEP,PAM.
      COMMON /PAM/     PAMA,SIGNUM,RESTMS
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000)
*KEEP,PARPAR.
      COMMON /PARPAR/  CURPAR,SECPAR,PRMPAR,OUTPAR,C,
     *                 E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
      DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16),
     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH
      INTEGER          ITYPE,LEVL
*KEND.
      COMMON /PION/    PI0MSQ,PITHR,PICMAS,PI0MAS,AMASK0,AMASKC,AMASPR,
     *                 AMASNT
      DOUBLE PRECISION PI0MSQ,PITHR,PICMAS,PI0MAS,AMASK0,AMASKC,AMASPR,
     *                 AMASNT
*KEEP,REJECT.
      COMMON /REJECT/  AVNREJ,ALTMIN,ANEXP,THICKA,THICKD,CUTLN,EONCUT,
     *                 FNPRIM
      DOUBLE PRECISION AVNREJ(10),ALTMIN(10),ANEXP(10),THICKA(10),
     *                 THICKD(10),CUTLN,EONCUT
      LOGICAL          FNPRIM
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEND.
      COMMON /THRESH/  RMSQ,API,TE,THMOLL,AP,AE,UP,UE
      DOUBLE PRECISION RMSQ,API,TE,THMOLL
      REAL             AP,AE,UP,UE
      COMMON /UPHIOT/  THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI
      DOUBLE PRECISION THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI
      COMMON /USEFUL/  PRM,PRMT2,RMI,VCI,MEDIUM,MEDOLD,IBLOBE
      DOUBLE PRECISION PRM,PRMT2,RMI,VCI
      INTEGER          MEDIUM,MEDOLD,IBLOBE

      DOUBLE PRECISION ECUTMIN,HEIGH
      INTEGER          I,IDET,IRL,JREG,KREG
      CHARACTER        MEDARR*24
      LOGICAL          LAVAIL
      SAVE
      EXTERNAL         HEIGH
      DATA             MEDARR/'AIR-NTP                 '/
C-----------------------------------------------------------------------

C  INITIALIZATION BEFORE THE FIRST CALL OF EGS4
      IF ( DEBUG ) THEN
        WRITE(MDEBUG,*) 'EGSINI:'
        KMPO = MDEBUG
      ELSE
        KMPO = MONIOU
      ENDIF
      WRITE(KMPO,10)
 10   FORMAT (/' START EGS4  AIR SHOWER SUBROUTINE VERSION (JUN 99)'/)
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
      RMMUT2 = 2.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  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) = HEIGH(0.D0)
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 PHOTON HISTORIES AT PCUT (GEV TO MEV CONVERTED)
        PCUT(IRL) = 1000.D0*ELCUT(4)
      ENDDO
C  LOOK FOR MINIMUM ENERGY CUT TO SELECT OPTIMAL EGSDATA SET
      ECUTMIN = MIN(1000.D0*ELCUT(3), 1000.D0*ELCUT(3))
 33   CONTINUE
      IF     ( ECUTMIN .GE. 3.D0 ) THEN
        INQUIRE(FILE='EGSDAT3_3.',EXIST=LAVAIL)
        IF ( LAVAIL ) THEN
          OPEN(UNIT=KMPI,FILE='EGSDAT3_3.',STATUS='OLD')
          WRITE(KMPO,*) 'DATASET EGSDAT3_3. AVAILABLE'
          STERNCOR = 0.0
        ELSE
          ECUTMIN = 1.1D0
          WRITE(KMPO,*)
     *      'DATASET EGSDAT3_3. BEST SUITED BUT NOT AVAILABLE'
          GOTO 33
        ENDIF
      ELSEIF ( ECUTMIN .GE. 1.D0 ) THEN
        INQUIRE(FILE='EGSDAT3_1.',EXIST=LAVAIL)
        IF ( LAVAIL ) THEN
          OPEN(UNIT=KMPI,FILE='EGSDAT3_1.',STATUS='OLD')
          WRITE(KMPO,*) 'DATASET EGSDAT3_1. AVAILABLE'
          STERNCOR = 6.0
        ELSE
          ECUTMIN = 0.5D0
          WRITE(KMPO,*)
     *      'DATASET EGSDAT3_1. BEST SUITED BUT NOT AVAILABLE'
          GOTO 33
        ENDIF
      ELSEIF ( ECUTMIN .GE. 0.4D0 ) THEN
        INQUIRE(FILE='EGSDAT3_.4',EXIST=LAVAIL)
        IF ( LAVAIL ) THEN
          OPEN(UNIT=KMPI,FILE='EGSDAT3_.4',STATUS='OLD')
          WRITE(KMPO,*) 'DATASET EGSDAT3_.4 AVAILABLE'
          STERNCOR = 10.0
        ELSE
          ECUTMIN = 0.26D0
          WRITE(KMPO,*)
     *      'DATASET EGSDAT3_.4 BEST SUITED BUT NOT AVAILABLE'
          GOTO 33
        ENDIF
      ELSEIF ( ECUTMIN .GE. 0.25D0 ) THEN
        INQUIRE(FILE='EGSDAT3_.25',EXIST=LAVAIL)
        IF ( LAVAIL ) THEN
          OPEN(UNIT=KMPI,FILE='EGSDAT3_.25',STATUS='OLD')
          WRITE(KMPO,*) 'DATASET EGSDAT3_.25 AVAILABLE'
          STERNCOR = 11.0
        ELSE
          ECUTMIN = 0.16D0
          WRITE(KMPO,*)
     *      'DATASET EGSDAT3_.25 BEST SUITED BUT NOT AVAILABLE'
          GOTO 33
        ENDIF
      ELSEIF ( ECUTMIN .GE. 0.15D0 ) THEN
        INQUIRE(FILE='EGSDAT3_.15',EXIST=LAVAIL)
        IF ( LAVAIL ) THEN
          OPEN(UNIT=KMPI,FILE='EGSDAT3_.15',STATUS='OLD')
          WRITE(KMPO,*) 'DATASET EGSDAT3_.15 AVAILABLE'
          STERNCOR = 12.5
        ELSE
          ECUTMIN = 0.06D0
          WRITE(KMPO,*)
     *      'DATASET EGSDAT3_.15 BEST SUITED BUT NOT AVAILABLE'
          GOTO 33
        ENDIF
      ELSEIF ( ECUTMIN .GE. 0.05D0 ) THEN
        INQUIRE(FILE='EGSDAT3_.05',EXIST=LAVAIL)
        IF ( LAVAIL ) THEN
          OPEN(UNIT=KMPI,FILE='EGSDAT3_.05',STATUS='OLD')
          WRITE(KMPO,*) 'DATASET EGSDAT3_.05 AVAILABLE'
          STERNCOR = 15.0
        ELSE
          ECUTMIN = 0.04D0
          WRITE(KMPO,*)
     *      'DATASET EGSDAT3_.05 BEST SUITED BUT NOT AVAILABLE'
          GOTO 33
        ENDIF
      ELSE
        INQUIRE(FILE='EGSDAT3_.05',EXIST=LAVAIL)
        IF ( LAVAIL ) THEN
          OPEN(UNIT=KMPI,FILE='EGSDAT3_.05',STATUS='OLD')
          WRITE(KMPO,*) 'ONLY DATASET EGSDAT3_.05 AVAILABLE'
          STERNCOR = 15.0
        ELSE
          WRITE(KMPO,*) 'NO DATASET EGSDAT3_????  AVAILABLE'
          STOP
        ENDIF
      ENDIF
C  PICK UP CROSS-SECTION DATA FOR AIR-NTP FROM UNIT KMPI=12
      CALL HATCH
      CLOSE(UNIT=KMPI)
C  INVERTED PHOTON THRESHOLD
      API = 1.D0/AP
      WRITE(KMPO,40) (AE-PRM)*.001,AP*.001,ECUT(2)*.001,PCUT(2)*.001
 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'/' ELE',
     * 'CTRON HISTORIES ARE TERMINATED AT',F15.5,' GEV'/' GAMMA HISTO',
     * 'RIES ARE TERMINATED AT   ',F15.5,' GEV'/)
**    IF ( DEBUG ) WRITE(KMPO,50)
**50  FORMAT (10X,' PART|TOT.ENERGY|ANGLE Z|ANGLE X|ALTITUDE|',
**   * '  TIME  |  POS. X  |  POS. Y  |GENER|',/,11X,'ICLE|',
**   * '  (GEV)   |COSTHET| (RAD) |  (CM)  | (MSEC) |   (CM)   |',
**   * '   (CM)   |ATION|')
C  CALCULATE THE LAYER THICKNESS BELOW EACH DETECTOR
      DO 61  IDET = 1,NOBSLV
C  NECESSARY BECAUSE OF DOUBLE PRECIS.
        OBSLVL(IDET) = OBSLEV(IDET)
        DO 71  JREG = 2,5
          IF ( OBSLVL(IDET) .GE. BOUND(JREG) ) THEN
            KREG = JREG
            GOTO 80
          ENDIF
 71     CONTINUE
        WRITE(KMPO,90) IDET,OBSLVL(IDET)*0.01
 90     FORMAT (' EGSINI:', ' DETECTOR ',I2,' AT ',E10.3,' M IS OUT ',
     *    'OF ATMOSPHERE')
        STOP
 80     CONTINUE
 61   CONTINUE
      RETURN
      END
*CMZ :          28/02/2002  13.08.20  by  D. HECK IK FZK KARLSRUHE
*-- 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 NAD 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
      COMMON /BOUNDS/  ECUT,PCUT,VACDST
      DOUBLE PRECISION ECUT(6),PCUT(6),VACDST
*KEEP,BUFFS.
      COMMON /BUFFS/   RUNH,RUNE,EVTH,EVTE,DATAB,ARRAYLONG,LH
      INTEGER          MAXBUF,MAXLEN
      PARAMETER        (MAXLEN=16)
      PARAMETER        (MAXBUF=39*7)
      REAL             RUNH(MAXBUF),EVTH(MAXBUF),EVTE(MAXBUF),
     *                 RUNE(MAXBUF),DATAB(MAXBUF),ARRAYLONG(MAXBUF)
      INTEGER          LH
      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)
*KEEP,CEREN1.
      COMMON /CEREN1/  CERELE,CERHAD,ETADSN,WAVLGL,WAVLGU,CYIELD,
     *                 CERSIZ,CERNOR,LCERFI
      DOUBLE PRECISION CERELE,CERHAD,ETADSN,WAVLGL,WAVLGU,CYIELD,
     *                 CERSIZ,CERNOR
      LOGICAL          LCERFI
*KEEP,CORFRAM, IF=CURVED.
      COMMON /CORFRAM/ DETSYS
      LOGICAL          DETSYS
*KEND.
      COMMON /ELECIN/  EKE0,EKE1,XR0,TEFF0,BLCC,XCC,ESIG0,ESIG1,PSIG0,
     *                 PSIG1,EDEDX0,EDEDX1,PDEDX0,PDEDX1,EBR10,EBR11,
     *                 PBR10,PBR11,PBR20,PBR21,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),PBR10(500),PBR11(500),
     *                 PBR20(500),PBR21(500),TMXS0(500),TMXS1(500),
     *                 ERANG0(1),ERANG1(1),PRANG0(1),PRANG1(1),STERNCOR
*KEEP,EGSDEB.
      COMMON /EGSDEB/  JCLOCK,NCLOCK,FEGSDB
      INTEGER          JCLOCK,NCLOCK
      LOGICAL          FEGSDB
*KEEP,EPCONT.
      COMMON /EPCONT/  EDEP,RATIO,TSTEP,TUSTEP,USTEP,TVSTEP,VSTEP,
     *                 RHOFAC,EOLD,ENEW,EKE,ELKE,BETA2,GLE,TSCAT,
     *                 IDISC,IROLD,IRNEW
      DOUBLE PRECISION EDEP,RATIO,TSTEP,TUSTEP,USTEP,TVSTEP,VSTEP,
     *                 RHOFAC,EOLD,ENEW, EKE,ELKE,BETA2,GLE,TSCAT
      INTEGER          IDISC,IROLD,IRNEW

*KEND.
      COMMON /GEOMEGS/ ZALTIT,BOUND,OBSLVL,NEWOBS
      DOUBLE PRECISION ZALTIT,BOUND(6),OBSLVL(10)
      INTEGER          NEWOBS
      COMMON /LAYER/   HBARO,HBAROI
      DOUBLE PRECISION HBARO(6),HBAROI(6)
*KEEP,LONGI.
      COMMON /LONGI/   ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP,LLONGI,FLGFIT
      DOUBLE PRECISION ADLONG(0:1170,9),AELONG(0:1170,9),
     *                 APLONG(0:1170,9),DLONG(0:1170,9),ELONG(0:1170,9),
     *                 HLONG(0:1170),PLONG(0:1170,9),SDLONG(0:1170,9),
     *                 SELONG(0:1170,9),SPLONG(0:1170,9),THSTEP,THSTPI
      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT
*KEEP,MAGNET.
      COMMON /MAGNET/  BX,BZ,BVAL,BNORMC,BNORM,COSB,SINB,BLIMIT
      DOUBLE PRECISION BX,BZ,BVAL,BNORMC,BNORM,COSB,SINB,BLIMIT
*KEND.
      COMMON /MEDIA/   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 /MEDIAC/  MEDIA
      CHARACTER        MEDIA*24
      COMMON /MISC/    DUNIT,RHOR,KMPI,KMPO,NOSCAT,MED,IRAYLR
      DOUBLE PRECISION DUNIT,RHOR(6)
      INTEGER          KMPI,KMPO,NOSCAT,MED(6),IRAYLR(6)
      COMMON /MUON/    PRRMMU,RMMUT2
      DOUBLE PRECISION PRRMMU,RMMUT2
*KEEP,OBSPAR.
      COMMON /OBSPAR/  OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP,
     *                 THETPR,PHIPR,
     *                 VUECON,
     *                 NOBSLV
      DOUBLE PRECISION OBSLEV(10),THCKOB(10),XOFF(10),YOFF(10),
     *                 HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2)
      DOUBLE PRECISION VUECON(2)
      INTEGER          NOBSLV
*KEEP,PARPAR.
      COMMON /PARPAR/  CURPAR,SECPAR,PRMPAR,OUTPAR,C,
     *                 E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
      DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16),
     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH
      INTEGER          ITYPE,LEVL
*KEND.
      COMMON /PATHCM/  B0PTH,B1PTH,PTH0,PTH1,PTH2,NPTH
      DOUBLE PRECISION B0PTH,B1PTH,PTH0(6),PTH1(6),PTH2(6)
      INTEGER          NPTH
*KEEP,RANDPA.
      COMMON /RANDPA/  FAC,U1,U2,RD,NSEQ,ISEED,KNOR
      DOUBLE PRECISION FAC,U1,U2
      REAL             RD(3000)
      INTEGER          ISEED(103,10),NSEQ
      LOGICAL          KNOR
*KEEP,REJECT.
      COMMON /REJECT/  AVNREJ,ALTMIN,ANEXP,THICKA,THICKD,CUTLN,EONCUT,
     *                 FNPRIM
      DOUBLE PRECISION AVNREJ(10),ALTMIN(10),ANEXP(10),THICKA(10),
     *                 THICKD(10),CUTLN,EONCUT
      LOGICAL          FNPRIM
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEEP,STACKE.
      COMMON /STACKE/  E,TIM,U,V,W,X,Y,Z,DNEAR,
     *                 ZAP,WAP,WA,
     *                 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)
     *                 ,ZAP(60),WAP(60),WA(60)
      INTEGER          IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP
*KEND.
      COMMON /THRESH/  RMSQ,API,TE,THMOLL,AP,AE,UP,UE
      DOUBLE PRECISION RMSQ,API,TE,THMOLL
      REAL             AP,AE,UP,UE
      COMMON /UPHIOT/  THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI
      DOUBLE PRECISION THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI
      COMMON /USEFUL/  PRM,PRMT2,RMI,VCI,MEDIUM,MEDOLD,IBLOBE
      DOUBLE PRECISION PRM,PRMT2,RMI,VCI
      INTEGER          MEDIUM,MEDOLD,IBLOBE

      DOUBLE PRECISION A,ALPHA,ALTEXP,B,BETA3,CC,
     *                 COSDEL,DE,DEDX,DEDX0,DEMFP,DISC,EBR1,EDEPB,
     *                 EDEPN,EDEP1,EFRST,EKEF,EKEOLD,ERELS,FLIP,FNORM,
     *                 F1SIN,F1COS,PBR1,PBR2,PEIE,PHI,PTH,RADINV,RANGE,
     *                 RHOFI,SIG,SIGF,SIG0,SINDEL,SINPSI,SINPS2,SITHET,
     *                 STEPT,THCKHN,THCKHO,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
      DOUBLE PRECISION CTEA,EBEG,EEND,TBEG,TEND,
     *                 XBEG,XEND,YBEG,YEND,ZBEG,ZEND
      DOUBLE PRECISION AUXIL,AUXILSQ,AUX2SQ,CORR,COSDIF,COSTHENEW,
     *                 DISTN2,DISTO2,DSTEFF,PHIC,SIGNE,SINDIF,
     *                 TANPHI,TRANS2,XOLD,YOLD,ZNEW
      INTEGER          IPASC
      SAVE
      EXTERNAL         THICK
      DATA             NSTPCN/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,1) NP,IR(NP),IOBS(NP),NCLOCK
          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) ) GOTO 390
      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)
        CALL RMMAR(RD,1,2)
        DEMFP = MAX( -LOG(DBLE(RD(1))), 1.D-6 )
C  LOOK FOR CROSS-SECTION TO DETERMINE RANGE
        LELKE = EKE1*ELKE+EKE0
        IF ( LELEC .LT. 0 ) THEN
          SIG0 = ESIG1(LELKE)*ELKE+ESIG0(LELKE)
        ELSE
          SIG0 = PSIG1(LELKE)*ELKE+PSIG0(LELKE)
        ENDIF
      ENDIF
 451  CONTINUE

      IF ( 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 PARAMETRISATION IS ONLY VALID FOR U.S. STANDARD ATMOS.
        DEDX   = RHOFAC*MIN( DEDX0,
     *                       (86.65D0-STERNCOR-Z(NP)*8.D-6)*RLDUI )
        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 TEH 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
      USTEP  = MIN( USTEP, BLIMIT*PEIE )
C  LOOK HOW FAR WE CAN GO
      IF ( USTEP .GT. DNEAR(NP) ) CALL HOWFAR
      IF ( IDISC .GT. 0 ) GOTO 420
      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 NEGA',
     *              'TIVE USTEP, COUNTER = ',I5)
            STOP
          ENDIF
        ENDIF
        USTEP = 0.D0
      ENDIF
      IF ( IDISC .LT. 0 ) THEN
C  PARTICLE WILL CROSS THE DETECTOR LEVEL
        ZOLD = Z(NP)
        XOLD = X(NP)
        YOLD = Y(NP)
        DISTO2 = X(NP)**2 + Y(NP)**2
        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) )
        ZAP(NP) = - (C(1)-Z(NP)) * WA(NP) + C(1)
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  CALCULATE CORRECTION ANGLE DIF FROM EFFECTIVE DISTANCE DSTEFF
        SINDIF = SIN(DSTEFF/C(1))
        COSDIF = SQRT( 1.D0 - SINDIF**2)
        COSTHENEW = W(NP)*COSDIF - SQRT(1.D0-W(NP)**2)*SINDIF
        IF ( FEGSDB ) WRITE(MDEBUG,*) 'ELECTR: COSDIF,COSTHENEW=',
     *                              SNGL(COSDIF),SNGL(COSTHENEW)
        W(NP) = MIN( 1.D0, COSTHENEW )
C  KILL HORIZONTAL OR UPWARD GOING PARTICLES
        IF ( W(NP) .LE. C(29) ) GOTO 420
C  ANGLE DIF (= DSTEFF/C(1)) MIGHT BE LARGE DUE TO CUT ON HAPP
        X(NP) = (-ZAP(NP) + C(1)) * TAN(X(NP)/C(1))
        Y(NP) = (-ZAP(NP) + C(1)) * TAN(Y(NP)/C(1))
        Z(NP) = ZAP(NP)
        IF ( U(NP) .NE. 0.D0 ) THEN
          TANPHI= V(NP)/U(NP)
          U(NP) = SIGN(1.D0,U(NP)) *
     *                       SQRT((1.D0-W(NP)**2)/(1.D0+TANPHI**2))
          V(NP) = TANPHI * U(NP)
        ELSE
          IF ( V(NP) .NE. 0.D0 )
     *           V(NP) = SIGN(1.D0,V(NP)) * SQRT( 1.D0 - W(NP)**2 )
        ENDIF
        USTEP = -(Z(NP)+OBSLEV(1))/W(NP)
        IF ( FEGSDB ) THEN
          WRITE(MDEBUG,*) 'ELECTR: CORR. FOR DET. ARRIVAL:USTEP=',USTEP
          CALL AUSGB2
        ENDIF
        IPASC = 1
        DETSYS = .TRUE.
      ELSE
        DETSYS = .FALSE.
C  PARTICLE MOVES TO END OF ITS RANGE, WE DO NOT YET APPROACH DETECTOR
        IPASC = 0
        ZOLD  = Z(NP)
        XOLD  = X(NP)
        YOLD  = Y(NP)
        DISTO2= X(NP)**2 + Y(NP)**2
      ENDIF
C  FILL IN CHERENKOV COORDINATES AT BEGIN OF STEP
      EBEG = PEIE*1.D-3
      EEND = PEIE*1.D-3
      XBEG = X(NP)
      YBEG = -Y(NP)
      ZBEG = -Z(NP)
      TBEG = TIM(NP)

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))
          X(NP) = X(NP) + VSTEP*UMEAN
          Y(NP) = Y(NP) + VSTEP*VMEAN
          Z(NP) = Z(NP) + VSTEP*WMEAN
          IF ( IPASC .EQ. 0 ) THEN
C  NORMAL STEP TO END OF PARTICLE RANGE, WE DO NOT YET APPROACH DETECTOR
            W(NP)  = MIN( 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  CORRECTED X AND Y HAVE TO BE CALCULATED BEFORE DISTN2
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  NEW DISTANCE FROM PARTICLE TO DETECTOR CENTER
            DISTN2 = X(NP)**2 + Y(NP)**2
C  COMPARE NEW AND OLD DISTANCE TO DETECTOR CENTER
            IF ( DISTN2 .LT. DISTO2 ) THEN
C  PARTICLE MOVES TOWARDS DETECTOR CENTER
              SIGNE = +1.D0
            ELSE
              SIGNE = -1.D0
              IF ( FEGSDB ) WRITE(MDEBUG,*) 'ELECTR: SIGNE=',SIGNE
            ENDIF
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 - SIGNE*SINDIF*SQRT(1.D0-W(NP)**2)
            W(NP)     = MIN( 1.D0, COSTHENEW )
C  KILL HORIZONTAL OR UPWARD GOING PARTICLES
            IF ( W(NP) .LE. C(29) ) GOTO 420
            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,6E10.3,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)-ZNEW) * WA(NP) + C(1)
            AUX2SQ  = SQRT( (C(1)-ZNEW)**2*(1.D0 - WA(NP)**2)
     *                                    + (-ZAP(NP)-OBSLEV(1))**2 )
            WAP(NP) = -(OBSLEV(1)+ZAP(NP)) / AUX2SQ
            IF ( FEGSDB ) WRITE(MDEBUG,*) 'ELECTR: WAP=',WAP(NP)
C  KILL PARTICLES, WHICH ARE BELOW DETECTOR SURFACE
C  CUT ON APPARENT HEIGHT
            IF ( -ZAP(NP) .LE. OBSLEV(1) ) GOTO 420
            WAP(NP) = MIN( 1.D0, WAP(NP) )
            IF ( U(NP) .NE. 0.D0 ) THEN
              TANPHI= V(NP) / U(NP)
              U(NP) = SIGN(1.D0,U(NP)) *
     *                    SQRT( (1.D0-W(NP)**2)/(1.D0+TANPHI**2) )
              V(NP) = TANPHI * U(NP)
            ELSE
              IF ( V(NP) .NE. 0.D0 )
     *               V(NP) = SIGN(1.D0,V(NP)) * SQRT( 1.D0 - W(NP)**2 )
            ENDIF
          ENDIF
          TIM(NP) = TIM(NP) + TVSTPC*VCI/SQRT(1.D0-(PRM/E(NP))**2)
C  NO CHERENKOV PHOTONS, WE ARE IN VACUUM
C  ADD ELECTRONS TO THE LONGITUDINAL DEVELOPMENT
C  FIND FIRST THE EQUIVALENT LEVELS
          IF ( LLONGI ) THEN
C  IF STARTING POINT BELOW LOWEST LEVEL THEN DON'T CHECK
            IF ( HLONG(NSTEP) .LE. -ZOLD ) THEN
              LPCT1 = LPCTE(NP)
C  Z NEW IS PROBABLY ONLY LITTLE BELOW Z OLD, THEREFORE INCREMENTAL SEARCH
              DO   I1 = LPCT1,NSTEP
                IF ( HLONG(I1) .LT. -Z(NP) ) 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
              DO   I = LPCT1,LPCT2
                PLONG(I,IQ(NP)) = PLONG(I,IQ(NP)) + 1.D0
              ENDDO
              IF ( IDISC .LT. 0 )
     *           PLONG(LPCT2+1,IQ(NP)) = PLONG(LPCT2+1,IQ(NP)) + 1.D0
C  WE ARE IN VACUUM NO ENERGY LOSS. RELEASABLE ENERGY ERELS [GEV]
              ERELS = 1.D-3*( E(NP) - DBLE(2*IQ(NP)-5) * PRM )
C  NOW FILL FIRST AND LAST BINS, THEN LOOP OVER THE BINS BETWEEN
              IF ( LPCT2 .LT. NSTEP ) THEN
                IF ( IDISC .LT. 0 ) THEN
                  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
            ENDIF
C  END LONGITUDINAL DISTRIBUTION FILLING
          ENDIF

          DNEAR(NP) = DNEAR(NP)-VSTEP
          IROLD     = IR(NP)
C  END OF STEP IN VACUUM
        ENDIF
        IR(NP) = IRNEW
        IRL    = IRNEW
        MEDIUM = MED(IRL)
        IF ( PEIE .LE. ECUT(IRL) ) GOTO 390
C  KILL UPWARD GOING PARTICLES
        IF ( W(NP) .LE. C(29) ) GOTO 420
        IF ( USTEP .NE. 0.D0 ) THEN
          IF ( NEWOBS .GT. IOBS(NP) ) THEN
            CALL AUSGAB
            IOBS(NP) = NEWOBS
          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 HORIZONTAL OR UPWARD GOING PARTICLES
        IF ( W(NP) .LE. C(29) ) GOTO 420
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)
        ENDIF
C  PATH LENGTH CORRECTION FOR MULTIPLE SCATTERING
        VSTP   = VSTEPU/TSCAT
        IPTH   = B0PTH+B1PTH*VSTP
        IPTH   = MAX( IPTH, 1 )
        IF ( IPTH .GT. NPTH ) THEN
          CALL AUSGB2
          WRITE(KMPO,490) VSTP,IPTH,NPTH
 490      FORMAT (' ELECTR: OUT OF BOUNDS IPTH: VSTP,IPTH,NPTH=' , 1P ,
     *             G15.6,2I10)
          STOP
        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
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))
      X(NP) = X(NP) + VSTEP*UMEAN
      Y(NP) = Y(NP) + VSTEP*VMEAN
      Z(NP) = Z(NP) + VSTEP*WMEAN
      IF ( IPASC .EQ. 0 ) THEN
C  WE TRANSPORT THE PARTICLE TO END OF IT'S RANGE, NORMAL STEP
        W(NP)  = MIN( 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
        COSDIF = MIN( 1.D0, COSDIF )
C  CORRECTED X AND Y HAVE TO BE CALCULATED BEFORE DISTN2
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  NEW DISTANCE FROM PARTICLE TO DETECTOR CENTER
        DISTN2 = X(NP)**2 + Y(NP)**2
C  COMPARE NEW AND OLD DISTANCE TO DETECTOR CENTER
        IF ( DISTN2 .LT. DISTO2 ) THEN
C  PARTICLE MOVES TOWARDS DETECTOR CENTER
          SIGNE = +1.D0
        ELSE
          SIGNE = -1.D0
          IF ( FEGSDB ) WRITE(MDEBUG,*) 'ELECTR: SIGNE=',SIGNE
        ENDIF
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 - SIGNE*SINDIF*SQRT(1.D0-W(NP)**2)
        W(NP)     = MIN( 1.D0, COSTHENEW )
C  KILL HORIZONTAL OR UPWARD GOING PARTICLES
        IF ( W(NP) .LE. C(29) ) GOTO 420
        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)-ZNEW) * WA(NP) + C(1)
        AUX2SQ  = SQRT( (C(1)-ZNEW)**2*(1.D0 - WA(NP)**2)
     *                                    + (-ZAP(NP)-OBSLEV(1))**2 )
        WAP(NP) = -(OBSLEV(1)+ZAP(NP)) / AUX2SQ
        IF ( FEGSDB ) WRITE(MDEBUG,*) 'ELECTR: WAP=',WAP(NP)
C  LOOK WETHER PARTICLE IS ALREADY ON DETECTOR SURFACE
C  CUT ON APPARENT HEIGHT
        IF ( -ZAP(NP) .LE. OBSLEV(1) ) GOTO 420
        WAP(NP) = MIN( 1.D0, WAP(NP) )

        IF ( U(NP) .NE. 0.D0 ) THEN
          TANPHI= V(NP) / U(NP)
          U(NP) = SIGN(1.D0,U(NP)) *
     *                         SQRT((1.D0-W(NP)**2)/(1.D0+TANPHI**2))
          V(NP) = TANPHI * U(NP)
        ELSE
          IF ( V(NP) .NE. 0.D0 )
     *           V(NP) = SIGN(1.D0,V(NP)) * SQRT( 1.D0 - W(NP)**2 )
        ENDIF
      ENDIF
      TIM(NP) = TIM(NP) + TVSTPC*VCI/SQRT(1.D0-(PRM/E(NP))**2)
C  FILL IN CHERENKOV COORDINATES AT END OF STEP
      IF ( .NOT. DETSYS ) THEN
C  WE ARE NOT IN LOCAL SYSTEM OF DETECTOR
        TRANS2 = VSTEP**2 * (UMEAN**2 + VMEAN**2)
C  TAKE HEIGHT AT END POINT OF TRACK
        AUXIL  = SQRT( TRANS2 + (C(1)+(-Z(NP)))**2 )
        SINDIF = SQRT( TRANS2 )/AUXIL
        IF ( SINDIF .GT. 0.D0 ) THEN
          CORR = C(1) * ASIN(SINDIF) / (AUXIL*SINDIF)
        ELSE
          CORR = 1.D0
        ENDIF
        XEND  = XBEG + UMEAN * VSTEP * CORR
        YEND  = YBEG - VMEAN * VSTEP * CORR
C  CALCULATE EARTH ANGLE BETWEEN THE ACTUAL LOCAL AND THE
C  APPARENT COORDINATE SYSTEM
        AUXIL = SQRT( XBEG**2 + YBEG**2 )
        CTEA  = COS( AUXIL/C(1) )
      ELSE
C  HERE WE ARE IN LOCAL DETECTOR SYSTEM
        XEND = X(NP)
        YEND = -Y(NP)
      ENDIF
      ZEND = -Z(NP)
      TEND = TIM(NP)
      EEND = (PEIE - EDEP)*1.D-3
C  GENERATE CHERENKOV PHOTONS
      IF ( FNPRIM ) CALL CERENK(TVSTPC,UMEAN,-VMEAN,WMEAN,EBEG,EEND,
     *    XBEG,YBEG,ZBEG,XEND,YEND,ZEND,TBEG,TEND,PRM*1.D-3,1.D0,
     *    1.D0,CTEA)
C  ADD ELECTRONS TO THE LONGITUDINAL DEVELOPMENT
C  FIND FIRST THE EQUIVALENT LEVELS
      IF ( LLONGI ) THEN
C  IF STARTING POINT BELOW LOWEST LEVEL THEN DON'T CHECK
        IF ( HLONG(NSTEP) .LE. -ZOLD ) THEN
          LPCT1 = LPCTE(NP)
C  Z NEW IS PROBABLY ONLY LITTLE BELOW Z OLD, THEREFORE INCREMENTAL SEARCH
          DO   I1 = LPCT1,NSTEP
            IF ( HLONG(I1) .LT. -Z(NP) ) 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)) + 1.D0
          ENDDO
          IF ( IDISC .LT. 0 )
     *           PLONG(LPCT2+1,IQ(NP)) = PLONG(LPCT2+1,IQ(NP)) + 1.D0
C  TOTAL PATH LENGTH STEPT IN UNITS OF LONGI BINS
          THCKHO = THICK(-ZOLD)
          THCKHN = THICK(-Z(NP))
          STEPT  = (THCKHN - THCKHO)*THSTPI
C  RELEASABLE ENERGY [IN GEV]
          ERELS  = 1.D-3*( E(NP) - DBLE(2*IQ(NP)-5) * PRM )
C  WE ASSUME HOMOGENEOUS ENERGY DEPOSIT ALONG PATH
C  IONIZATION E(NERGY) DEP(OSED IN EACH) B(IN) [IN GEV]
          IF ( STEPT .GT. 0.D0 ) THEN
            EDEPB = EDEP*1.D-3/STEPT
          ELSE
            EDEPB = 0.D0
          ENDIF
C  ENERGY DEPOSIT IN FIRST BIN
          EDEP1  = EDEPB * (DBLE(LPCT1) - THCKHO*THSTPI)
C  ENERGY AT FIRST BIN BOUNDARY
          EFRST  = ERELS - EDEP1
          IF ( LPCT2. LT. LPCT1 ) THEN
            EDEPN = EDEPB * (THCKHN*THSTPI - DBLE(LPCT1))
          ELSE
            EDEPN = MAX( 0.D0, EDEPB*(THCKHN*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
              ELONG(LPCT2+1,IQ(NP)) = ELONG(LPCT2+1,IQ(NP))
     *                      + MAX( 0.D0, (EFRST-(LPCT2+1-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
C  END LONGITUDINAL DISTRIBUTION FILLING
        ENDIF
      ENDIF

      DNEAR(NP) = DNEAR(NP)-VSTEP
      IROLD     = IR(NP)
C  NOW ADD ANGLE OF MULTIPLE SCATTERING (SEE ALSO SUBR. UPHI)
      CALL RMMAR(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) ) GOTO 390
      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 ( IRNEW .NE. IROLD ) THEN
C  LAYER HAS CHANGED
        IR(NP) = IRNEW
        IRL    = IRNEW
        MEDIUM = MED(IRL)
      ENDIF
      IF ( PEIE .LE. ECUT(IRL) ) GOTO 390
C  KILL UPWARD GOING PARTICLES
      IF ( W(NP) .LE. C(29) ) GOTO 420
C  LOOK FOR OBSERVATION LEVEL AND GIVE TO OUTPUT
      IF ( NEWOBS .GT. IOBS(NP) ) THEN
        CALL AUSGAB
        IOBS(NP) = NEWOBS
      ENDIF
      IF ( IDISC .LT. 0 ) GOTO 420
      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-6 ) 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 RMMAR(RD,1,2)
      IF ( RD(1) .GT. SIGF/SIG0 ) GOTO 401

      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)
          SITHET   = SQRT(1.D0-SECPAR(3)**2)
          U(1) = SITHET*COS(-SECPAR(4))
          V(1) = SITHET*SIN(-SECPAR(4))
          W(1) = SECPAR(3)
        ENDIF
        EVTH(6) = 0.
        IF ( TMARGIN ) THEN
C  NEGATIVE FIRST INTERACTION HEIGHT,IF TRACKING STARTS AT ATMOS. MARGIN
          EVTH(7) = Z(1)
        ELSE
          EVTH(7) = -Z(1)
        ENDIF
        CALL TOBUF(EVTH,0)
C  OUTPUT OF EVENTHEADER TO THE CHERENKOV FILE
        IF ( LCERFI ) CALL TOBUFC( EVTH,0 )
        CALL CORNEC
        TIM(1) = 0.D0
        FNPRIM = .TRUE.
        IF ( FPRINT ) THEN
          WRITE(KMPO,*) ' FIRST INTERACTION AT ',ABS(EVTH(7)*0.01),' M'
        ENDIF
      ENDIF

C  NOW SAMPLE ELECTRON INTERACTION, LOOK FOR BRANCHING RATIOS
      IF ( LELEC .LT. 0 ) THEN
        EBR1 = EBR11(LELKE)*ELKE+EBR10(LELKE)
        CALL RMMAR(RD,1,2)
        IF ( RD(1) .LE. EBR1 ) THEN
C  MAKE BREMSSTRAHLUNG
          GOTO 500
        ELSE
          IF ( E(NP) .LE. THMOLL ) THEN
            IF ( EBR1 .LE. 0.D0 ) GOTO 380
            GOTO 500
          ENDIF
C  MOLLER SCATTERING
          CALL MOLLER
        ENDIF
C  ELECTRON IS LOWEST ENERGY - FOLLOW IT
        GOTO 380
      ENDIF

      PBR1 = PBR11(LELKE)*ELKE+PBR10(LELKE)
      CALL RMMAR(RD,1,2)
      IF ( RD(1) .LT. PBR1 ) THEN
C  BREMSSTRAHLUNG
        GOTO 500
      ENDIF
      PBR2 = PBR21(LELKE)*ELKE+PBR20(LELKE)
      IF ( RD(1) .LT. PBR2 ) THEN
C  BHABHA SCATTERING
        CALL BHABHA
      ELSE
C  ANNIHILATION
        CALL ANNIH
        RETURN
      ENDIF
      GOTO 380

 500  CONTINUE
C  BREMSSTRAHLUNG
      CALL BREMS
      IF ( IQ(NP) .EQ. 1 ) THEN
C  PHOTON ON TOP OF STACK
        RETURN
      ELSE
C  ELECTRON ON TOP OF STACK
        GOTO 380
      ENDIF

C  ENERGY DEPOSIT FOR ELECTRON BELOW 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
        DLONG(LPCTE(NP),3) = DLONG(LPCTE(NP),3) + EDEP*1.D-3
      ENDIF
      IF ( LELEC .GT. 0 ) THEN
C  IT'S A POSITRON. PRODUCE ANNIHILATION GAMMAS IF EDEP < PEI
        IF ( EDEP .LT. PEIE ) THEN
          CALL RMMAR(RD,2,2)
          COSTHE = RD(1)
          FLIP   = RD(2)
          IF ( FLIP .LE. 0.5D0 ) COSTHE = -COSTHE
          SINTHE = SQRT( MAX( 0.D0, 1.0-COSTHE**2 ) )
          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)
          ZAP(NP)= ZAP(NP-1)
          WAP(NP)= WAP(NP-1)
          WA(NP) = WA(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
        DLONG(LPCTE(NP),3) = DLONG(LPCTE(NP),3) + EDEP*1.D-3
      ENDIF
      IRCODE = 2
      NP = NP-1
      RETURN
      END
*CMZ :          12/10/2001  14.53.55  by  D. HECK IK FZK KARLSRUHE
*-- 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 PHOTON
C       CUT-OFF ENERGIES FOR EACH REGION RESPECTIVELY.  SETUP WILL
C       RAISE THESE IF NECESSARY TO MAKE THEM AT LEAST AS LARGE AS
C       THE REGION'S MEDIUM'S AE AND AP RESPECTIVELY.
C    6. FILL 'MED' ARRAY.  MED(IR) IS THE MEDIUM INDEX FOR REGION
C       IR.  A ZERO MEDIUM INDEX MEANS THE REGION IS IN A VACUUM.
C    7. FILL THE ARRAY 'IRAYLR' WITH 1 FOR EACH REGION IN WHICH
C       RAYLEIGH (COHERENT) SCATTERING IS TO BE INCLUDED.
C  THIS SUBROUTINE IS CALLED FROM EGSINI.
C-----------------------------------------------------------------------

      IMPLICIT NONE
      COMMON /BOUNDS/  ECUT,PCUT,VACDST
      DOUBLE PRECISION ECUT(6),PCUT(6),VACDST
      COMMON /BREMPR/  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)
      COMMON /ELECIN/  EKE0,EKE1,XR0,TEFF0,BLCC,XCC,ESIG0,ESIG1,PSIG0,
     *                 PSIG1,EDEDX0,EDEDX1,PDEDX0,PDEDX1,EBR10,EBR11,
     *                 PBR10,PBR11,PBR20,PBR21,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),PBR10(500),PBR11(500),
     *                 PBR20(500),PBR21(500),TMXS0(500),TMXS1(500),
     *                 ERANG0(1),ERANG1(1),PRANG0(1),PRANG1(1),STERNCOR
      COMMON /MEDIA/   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 /MEDIAC/  MEDIA
      CHARACTER        MEDIA*24
      COMMON /MISC/    DUNIT,RHOR,KMPI,KMPO,NOSCAT,MED,IRAYLR
      DOUBLE PRECISION DUNIT,RHOR(6)
      INTEGER          KMPI,KMPO,NOSCAT,MED(6),IRAYLR(6)
      COMMON /PHOTIN/  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
*KEEP,RANDPA.
      COMMON /RANDPA/  FAC,U1,U2,RD,NSEQ,ISEED,KNOR
      DOUBLE PRECISION FAC,U1,U2
      REAL             RD(3000)
      INTEGER          ISEED(103,10),NSEQ
      LOGICAL          KNOR
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEEP,STACKE.
      COMMON /STACKE/  E,TIM,U,V,W,X,Y,Z,DNEAR,
     *                 ZAP,WAP,WA,
     *                 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)
     *                 ,ZAP(60),WAP(60),WA(60)
      INTEGER          IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP
*KEND.
      COMMON /THRESH/  RMSQ,API,TE,THMOLL,AP,AE,UP,UE
      DOUBLE PRECISION RMSQ,API,TE,THMOLL
      REAL             AP,AE,UP,UE
      COMMON /UPHIOT/  THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI
      DOUBLE PRECISION THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI
      COMMON /USEFUL/  PRM,PRMT2,RMI,VCI,MEDIUM,MEDOLD,IBLOBE
      DOUBLE PRECISION PRM,PRMT2,RMI,VCI
      INTEGER          MEDIUM,MEDOLD,IBLOBE

      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/,DUNITO/1.D0/
      DATA             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 651  I = 1,60
          PWR2I(I) = P
          P = P*.5D0
 651     CONTINUE
      ENDIF

C  FILL IRAYLM ARRAY BASED ON IRAYLR INPUTS
      DO 661  IM = 1,NMED
 670    CONTINUE
        DO 671  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
 671    CONTINUE
 672    CONTINUE
 661  CONTINUE
C  NOW SEARCH FILE FOR DATA FOR REQUESTED MATERIALS
      REWIND KMPI
      NM = 0
      DO 681  IM = 1,NMED
        LOK = 0
        IF ( IRAYLM .EQ. 1 ) THEN
          WRITE(KMPO,690) IM
 690      FORMAT(' RAYLEIGH OPTION REQUESTED FOR MEDIUM NUMBER',I3,/)
        ENDIF
 681  CONTINUE

 701  CONTINUE
C  MEDIUM HEADER SEARCH LOOP, FIRST LOOK FOR MEDIUM HEADER
      READ(KMPI,530,END=720) MBUF
      DO 731  IB = 1,LMDL
        IF ( MBUF(IB:IB) .NE. MDLABL(IB:IB) ) GOTO 701
 731  CONTINUE
C  HEADER MATCHES. NOW SEE IF IT IS ONE OF REQUESTED MEDIA
      DO 741  IM = 1,NMED
        DO 751  IB = 1,LMDN
          IL = LMDL+IB
          IF ( MBUF(IL:IL) .NE. MEDIA(IB:IB) ) GOTO 741
          IF ( IB .EQ. LMDN ) GOTO 712
 751    CONTINUE
 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 791  IE = 1,NE
        READ(KMPI,530) MBUF
        WRITE(KMPO,530) MBUF
 791  CONTINUE
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),PBR10(I),
     *  PBR11(I),PBR20(I),PBR21(I),TMXS0(I),TMXS1(I),I=1,NEKE)
C  PHOTIN
      READ(KMPI,520) EBINDA,GE0,GE1
      READ(KMPI,520) (GMFP0(I),GMFP1(I),GBR10(I),GBR11(I),GBR20(I),
     *  GBR21(I),GBR30(I),GBR31(I),GBR40(I),GBR41(I),I=1,NGE)
      IF ( IRAYLM.EQ.1 .AND. IRAYL.NE.1 ) THEN
        WRITE(KMPO,800) IM
 800    FORMAT(' STOPPED IN HATCH: REQUESTED RAYLEIGH OPTION FOR MEDIUM'
     *  ,I3/ ' BUT RAYLEIGH DATA NOT INCLUDED IN DATA CREATED BY PEGS.')
        STOP
      ENDIF
      IF ( IRAYL .EQ. 1 ) THEN
        READ(KMPI,510) NGR
        NGRIM = NGR
        READ(KMPI,520) RCO0,RCO1
        READ(KMPI,520) (RSCT0(I),RSCT1(I),I=1,NGRIM)
        READ(KMPI,520) (COHE0(I),COHE1(I),I=1,NGE)
        IF ( IRAYLM .NE. 1 ) THEN
          WRITE(KMPO,810) IM
 810      FORMAT(' RAYLEIGH DATA AVAILABLE FOR MEDIUM',I3,' BUT OPTION',
     *           ' NOT REQUESTED.',/)
        ENDIF
      ENDIF
C  THAT'S ALL FOR THIS MEDIUM
      IF ( NM .LT. NMED ) GOTO 701

C  WE NOW HAVE DATA FOR ALL MEDIA REQUESTED. NOW DO DISTANCE UNIT
C  CHANGE. DATA FROM PEGS IS IN UNITS OF RADIATION LENGTHS. EGS IS
C  RUN IN UNITS OF 'DUNIT' CENTIMETERS, IF DUNIT.GT.0 OR IN UNITS OF
C  RLC(-DUNIT) CENTIMETERS IF DUNIT.LT.0. THAT IS, A NEGATIVE DUNIT
C  MEANS UNIT IS TO BE THE RADIATION LENGTH OF THE MEDIUM WHOSE INDEX
C  IS -DUNIT
      DUNITR = DUNIT
      IF ( DUNIT .LT. 0.D0 ) THEN
        MD = MAX(1,MIN(1,INT(-DUNIT)))
        DUNIT = RLC
      ENDIF
      IF ( DUNIT .NE. 1.D0 ) THEN
        WRITE(KMPO,820) DUNITR,DUNIT
 820    FORMAT(' DUNIT REQUESTED&USED ARE:',1P,2E14.5,'(CM.)')
      ENDIF
      DO 831  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    I = I+1
 843    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    I = I+1
 853    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    I = I+1
 863    IF ( I-(MGE) .GT. 0 ) GOTO 862
        GMFP0(I) = GMFP0(I)*DFACT
        GMFP1(I) = GMFP1(I)*DFACT
        GOTO 861
 862    CONTINUE
 831  CONTINUE
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 871  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.1D0*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
 871  CONTINUE
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 911  IM = 1,NMED
        IF ( LOK .NE. 1 ) THEN
          WRITE(KMPO,920) (MEDIA(I:I),I=1,LMDN)
 920      FORMAT(40X,'''',24A1,'''')
        ENDIF
 911  CONTINUE
      STOP
      END
*CMZ :          18/09/2001  09.00.42  by  D. HECK IK FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
C=======================================================================

      SUBROUTINE HOWFAR

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  THE USER CAN TERMINATE A HISTORY BY SETTING IDISC>0.
C  HERE WE TERMINATE ALL PARTICLES GOING UPWARD OR HORIZONTALLY.
C  THE USER CAN TRANSPORT AND TERMINATE THE LAST PARTICLE BY SETTING
C  IDISC<0.  HERE WE TRANSPORT AND TERMINATE ALL PARTICLES WHICH ENTER
C  REGION 6  OR HAVE PASSED THE LAST OBSERVATION LEVEL.
C*********************************************************************
C   ELECTRON OR PHOTON        POSITIVE Z-DIRECTION (W>0) IS DOWNWARDS
C            |
C            |                  REGION 1   (VACUUM)
C            V
C---------------------------    STARTING PLANE AT -BOUND(1) = -ZALTIT
C
C                               REGION 2   (AIR WITH EXPONENTIALLY
C                                           INCREASING DENSITY)
C
C---------------------------    BOUNDARY AT -BOUND(2)
C
C                               REGION 3   (AIR WITH EXPONENTIALLY
C                                           INCREASING DENSITY)
C
C---------------------------    BOUNDARY AT  -BOUND(3)
C
C                               REGION 4   (AIR WITH EXPONENTIALLY
C                                           INCREASING DENSITY)
C
C---------------------------    BOUNDARY AT  -BOUND(4)
C
C                               REGION 5   (AIR WITH EXPONENTIALLY
C                                           INCREASING DENSITY)
C
C---------------------------    BOUNDARY AT -BOUND(5)   (SEA LEVEL)
C////////////|/////////
C////////////|/////////         REGION 6   (VACUUM)
C////////////V/////////
C   ELECTRON OR PHOTON
C---------------------------    BOUNDARY AT -BOUND(6)
C
C*********************************************************************
C  THIS SUBROUTINE IS CALLED FROM ELECTR AND PHOTON.
C
C  DESIGN  : D. HECK   IK3  FZK KARLSRUHE
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,EGSDEB.
      COMMON /EGSDEB/  JCLOCK,NCLOCK,FEGSDB
      INTEGER          JCLOCK,NCLOCK
      LOGICAL          FEGSDB
*KEEP,EPCONT.
      COMMON /EPCONT/  EDEP,RATIO,TSTEP,TUSTEP,USTEP,TVSTEP,VSTEP,
     *                 RHOFAC,EOLD,ENEW,EKE,ELKE,BETA2,GLE,TSCAT,
     *                 IDISC,IROLD,IRNEW
      DOUBLE PRECISION EDEP,RATIO,TSTEP,TUSTEP,USTEP,TVSTEP,VSTEP,
     *                 RHOFAC,EOLD,ENEW, EKE,ELKE,BETA2,GLE,TSCAT
      INTEGER          IDISC,IROLD,IRNEW

*KEND.
      COMMON /GEOMEGS/ ZALTIT,BOUND,OBSLVL,NEWOBS
      DOUBLE PRECISION ZALTIT,BOUND(6),OBSLVL(10)
      INTEGER          NEWOBS
*KEEP,OBSPAR.
      COMMON /OBSPAR/  OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP,
     *                 THETPR,PHIPR,
     *                 VUECON,
     *                 NOBSLV
      DOUBLE PRECISION OBSLEV(10),THCKOB(10),XOFF(10),YOFF(10),
     *                 HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2)
      DOUBLE PRECISION VUECON(2)
      INTEGER          NOBSLV
*KEEP,PARPAR.
      COMMON /PARPAR/  CURPAR,SECPAR,PRMPAR,OUTPAR,C,
     *                 E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
      DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16),
     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH
      INTEGER          ITYPE,LEVL
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEEP,STACKE.
      COMMON /STACKE/  E,TIM,U,V,W,X,Y,Z,DNEAR,
     *                 ZAP,WAP,WA,
     *                 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)
     *                 ,ZAP(60),WAP(60),WA(60)
      INTEGER          IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP
*KEND.

      DOUBLE PRECISION TVAL
      INTEGER          IRL,NOBS
      DOUBLE PRECISION AUXIL,BOUNDC,CAP,CEARTH,OBSGLOB,
     *                 RADHOR,STEPMX,S2B,THICK
      INTEGER          IBFLAG
      EXTERNAL         THICK
      SAVE
C-----------------------------------------------------------------------

      IF ( FEGSDB ) THEN
        WRITE(MDEBUG,1) NP,IR(NP),IOBS(NP)
 1      FORMAT(' HOWFAR: NP=',I3,' IR=',I3,' IOBS=',I3)
        CALL AUSGB2
      ENDIF

      IF     ( IR(NP).GT.1 .AND. IR(NP).LT.6 ) THEN
C  WE ARE IN THE ATMOSPHERE - CHECK THE GEOMETRY
        IRL = IR(NP)
C  GOING FORWARD - CONSIDER FIRST SINCE MOST FREQUENT
        NOBS = IOBS(NP)
        IF ( W(NP) .GT. C(29) ) THEN
C  WE ARE GOING DOWNWARD
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)
          STEPMX = AUXIL / SQRT(RADHOR)
C  JUST SHORTEN USTEP
          IF ( STEPMX .LT. USTEP ) USTEP = STEPMX
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)
          CEARTH  = COS( SQRT( X(NP)**2 + Y(NP)**2 )/C(1) )
          OBSGLOB = ( C(1) + OBSLEV(1) ) / CEARTH - C(1)
          CAP     = W(NP)*CEARTH-SQRT((1.D0-W(NP))*(1.D0-CEARTH))
C  CALCULATE REAL STEP LENGHT TO NEXT BOUNDARY S2B
C  (DUE TO TRANSFORMING INTO NEW LOCAL FRAME AT THIS POINT)
          IF ( (BOUND(IRL)+C(1))**2 .GE.
     *                           (C(1)-Z(NP))**2*(1.D0-W(NP)**2) ) THEN
            S2B  = (C(1)-Z(NP))*W(NP) - SQRT( (BOUND(IRL)+C(1))**2
     *                            - (C(1)-Z(NP))**2 * (1.D0-W(NP)**2) )
            TVAL = MIN( S2B, (-Z(NP)-OBSGLOB)/W(NP) )
            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 GLOBAL OBSLEV
C  (LINE IN DETECTOR SYSTEM). DON'T CUT AT THIS STAGE.
            IBFLAG = 1
            IF ( CAP .GT. 0.D0 ) THEN
              TVAL = (-Z(NP)-OBSGLOB)/W(NP)
            ELSE
              TVAL = USTEP + 1.D0
            ENDIF
          ENDIF
          IF ( TVAL .GT. USTEP ) THEN
C  CAN TAKE CURRENTLY REQUESTED STEP. DNEAR HAS TO BE DISTANCE TO NEXT
C  BOUNDARY OR OBSLEV. KEEP DNEAR SMALL => CHECK CROSSING OF LAYER
C  BOUNDARY MORE OFTEN
            IF ( IBFLAG .NE. 0 ) THEN
              DNEAR(NP) = USTEP*W(NP)
            ELSE
              DNEAR(NP) = TVAL*W(NP)
            ENDIF
          ELSE
C  GO TO DETECTOR OR BOUNDARY, WHICH IS CLOSER
            USTEP = MAX(TVAL,0.0001D0)
C  CALCULATE THE RIGHT BOUND BOUNDC CONSIDERING THE TRANSFORMATION IN
C  A NEW LOCAL FRAME
            IF ( IBFLAG .NE. 0 ) THEN
C  IF S2B IS NOT DEFINED , BOUNDC IS NOT REACHED. IN THIS CASE BOUNDC
C  WILL NEVER BEEN REACHED
              BOUNDC = -9999999.9999D0
            ELSE
              BOUNDC = -Z(NP) - S2B*W(NP)
            ENDIF
            IF ( BOUNDC .GE. OBSGLOB ) THEN
C  PARTICLE CROSSES BOUNDARY
              IRNEW = IRL+1
C  PARTICLE LEAVES AIR
              IF ( IRNEW .GE. 6 ) IDISC = -1
            ENDIF
            IF ( BOUNDC .LE. OBSGLOB ) THEN
C  PARTICLE CROSSES DETECTOR
              NEWOBS = NOBS + 1
C  MAKE A VERY SMALL STEP TO AVOID HANGUP OF PROGRAM
              IF ( USTEP .LE. 0.D0 ) USTEP = 0.0001D0
C  TRANSPORT PARTICLE  TO FINAL DETECTOR LEVEL AND DISCARD IT
              IF ( NEWOBS .GT. NOBSLV ) IDISC = -1
            ENDIF
          ENDIF
C  END OF 'PARTICLE GOING DOWNWARD'

        ELSE
C  GOING UPWARD IN ATMOSPHERE OR MOVING HORIZONTALLY
C  DISCARD PARTICLE
          IDISC = 1
          RETURN
        ENDIF
C  END OF ATMOSPHERE REGION CASE

      ELSEIF ( IR(NP) .EQ. 6 ) THEN
C  TERMINATE THIS HISTORY, IT IS PAST THE ATMOSPHERE
        IDISC = 1
C  WE ARE IN THE REGION WITH SOURCE ABOVE AIR
      ELSEIF ( IR(NP) .EQ. 1 ) THEN
        IF ( W(NP) .GT. C(29) ) 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
          IDISC = 1
        ENDIF
C  END REGION 1 CASE
      ENDIF
      RETURN
      END
*CMZ :          11/01/2002  09.25.08  by  D. HECK IK FZK KARLSRUHE
*-- 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
*KEEP,EGSDEB.
      COMMON /EGSDEB/  JCLOCK,NCLOCK,FEGSDB
      INTEGER          JCLOCK,NCLOCK
      LOGICAL          FEGSDB
*KEEP,RANDPA.
      COMMON /RANDPA/  FAC,U1,U2,RD,NSEQ,ISEED,KNOR
      DOUBLE PRECISION FAC,U1,U2
      REAL             RD(3000)
      INTEGER          ISEED(103,10),NSEQ
      LOGICAL          KNOR
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEEP,STACKE.
      COMMON /STACKE/  E,TIM,U,V,W,X,Y,Z,DNEAR,
     *                 ZAP,WAP,WA,
     *                 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)
     *                 ,ZAP(60),WAP(60),WA(60)
      INTEGER          IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP
*KEND.
      COMMON /THRESH/  RMSQ,API,TE,THMOLL,AP,AE,UP,UE
      DOUBLE PRECISION RMSQ,API,TE,THMOLL
      REAL             AP,AE,UP,UE
      COMMON /UPHIOT/  THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI
      DOUBLE PRECISION THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI
      COMMON /USEFUL/  PRM,PRMT2,RMI,VCI,MEDIUM,MEDOLD,IBLOBE
      DOUBLE PRECISION PRM,PRMT2,RMI,VCI
      INTEGER          MEDIUM,MEDOLD,IBLOBE

*     DOUBLE PRECISION AUXIL,BETAI2,BR,EP0,E0,E02,EXTRAE,DCOSTH,G1,G2,
      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

      PEIE   = E(NP)
      PEKIN  = PEIE-PRM
      PEKINI = 1.D0/PEKIN
      T0     = PEKIN*RMI
      E0     = T0+1.D0
      EXTRAE = PEIE - THMOLL
      E02    = E0**2
*     BETAI2 = E02/(E02-1.0)
C  CORRECTED 18.12.98
      EP0    = TE*PEKINI
*     G1     = (1.D0-2.D0*EP0)*BETAI2
      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 RMMAR(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  = G1*(1.D0+G2*BR*BR+R*(R-G3))
*     IF ( RD(2) .GT. REJF4 ) GOTO 931
C  CORRECTED 18.12.98
      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
*CMZ :          11/01/2002  09.25.08  by  D. HECK IK FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
C=======================================================================

      SUBROUTINE MPPROP

C-----------------------------------------------------------------------
C  M(UON) P(ION) PROP(AGATION)
C
C  MOVES MUONS AND PIONS FROM EGS-STACK TO CORSIKA-STACK.
C  THIS SUBROUTINE IS CALLED FROM SHOWER.
C
C  DESIGN  : D. HECK   IK3  FZK KARLSRUHE
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,EGSDEB.
      COMMON /EGSDEB/  JCLOCK,NCLOCK,FEGSDB
      INTEGER          JCLOCK,NCLOCK
      LOGICAL          FEGSDB
*KEEP,ELABCT.
      COMMON /ELABCT/  ELCUT
      DOUBLE PRECISION ELCUT(4)
*KEEP,LONGI.
      COMMON /LONGI/   ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP,LLONGI,FLGFIT
      DOUBLE PRECISION ADLONG(0:1170,9),AELONG(0:1170,9),
     *                 APLONG(0:1170,9),DLONG(0:1170,9),ELONG(0:1170,9),
     *                 HLONG(0:1170),PLONG(0:1170,9),SDLONG(0:1170,9),
     *                 SELONG(0:1170,9),SPLONG(0:1170,9),THSTEP,THSTPI
      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT
*KEND.
      COMMON /MUON/    PRRMMU,RMMUT2
      DOUBLE PRECISION PRRMMU,RMMUT2
*KEEP,PARPAR.
      COMMON /PARPAR/  CURPAR,SECPAR,PRMPAR,OUTPAR,C,
     *                 E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
      DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16),
     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH
      INTEGER          ITYPE,LEVL
*KEND.
      COMMON /PION/    PI0MSQ,PITHR,PICMAS,PI0MAS,AMASK0,AMASKC,AMASPR,
     *                 AMASNT
      DOUBLE PRECISION PI0MSQ,PITHR,PICMAS,PI0MAS,AMASK0,AMASKC,AMASPR,
     *                 AMASNT
*KEEP,POLAR.
      COMMON /POLAR/   POLART,POLARF
      DOUBLE PRECISION POLART,POLARF
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEEP,STACKE.
      COMMON /STACKE/  E,TIM,U,V,W,X,Y,Z,DNEAR,
     *                 ZAP,WAP,WA,
     *                 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)
     *                 ,ZAP(60),WAP(60),WA(60)
      INTEGER          IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP
*KEND.
      COMMON /UPHIOT/  THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI
      DOUBLE PRECISION THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI

      DOUBLE PRECISION AMASS,ANGLEX,CUT
      SAVE
C-----------------------------------------------------------------------

      IF ( FEGSDB ) THEN
        WRITE(MDEBUG,1) NP,IR(NP),IOBS(NP)
 1      FORMAT(' MPPROP: NP=',I3,' IR=',I3,' IOBS=',I3)
        CALL AUSGB2
      ENDIF

C  SET MASS AND CUT PARAMETER OF PARTICLE UNDER CONSIDERATION
      IF     ( IQ(NP) .LT. 7 ) THEN
        AMASS = PRRMMU
        CUT   = ELCUT(2)*1000.D0
      ELSEIF ( IQ(NP) .EQ. 7 ) THEN
        AMASS  = PI0MAS
        CUT    = ELCUT(1)*1000.D0
        POLART = 1.D0
        POLARF = 0.D0
      ELSE
        AMASS  = PICMAS
        CUT    = ELCUT(1)*1000.D0
        POLART = 1.D0
        POLARF = 0.D0
      ENDIF
C  USE PARTICLE ONLY IF ABOVE CUT AND INSIDE ACCEPTANCE CONE
      IF ( E(NP)-AMASS.GT.CUT .AND. W(NP).GT.C(29) ) THEN
*     IF ( W(NP) .GT. C(29) ) THEN
C  ANGLE WITH RESPECT TO X AXIS
        IF ( U(NP) .NE. 0.D0  .OR.  V(NP) .NE. 0.D0 ) THEN
          ANGLEX = -ATAN2(V(NP),U(NP))
        ELSE
          ANGLEX = 0.D0
        ENDIF
C  FILL MUON/PION COORDINATES INTO CORSIKA-STACK
        SECPAR(1)  = IQ(NP)
        SECPAR(2)  = E(NP)/AMASS
        SECPAR(3)  = MIN( 1.D0, W(NP) )
        SECPAR(4)  = ANGLEX
        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(14) = -ZAP(NP)
        SECPAR(15) = WAP(NP)
        SECPAR(16) = WA(NP)
C  ADD MUON/PION TO CORSIKA-STACK
        CALL TSTOUT
      ELSE
        IF ( LLONGI ) THEN
C  CUTTED ENERGY TO LONGITUDINAL ENERGY SUMS OF MUONS/HADRONS
          IF ( IQ(NP) .LE. 6 ) THEN
            DLONG(LPCTE(NP),5) = DLONG(LPCTE(NP),5)+E(NP)*1.D-3
          ELSE
            DLONG(LPCTE(NP),7) = DLONG(LPCTE(NP),7)+E(NP)*1.D-3
          ENDIF
        ENDIF
      ENDIF
C  ELIMINATE MUON/PION FROM EGS-STACK
      POLART = -POLART
      POLARF = POLARF+PI
      NP = NP-1
      RETURN
      END
*CMZ :          28/02/2002  13.08.20  by  D. HECK IK FZK KARLSRUHE
*-- 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
*KEEP,EGSDEB.
      COMMON /EGSDEB/  JCLOCK,NCLOCK,FEGSDB
      INTEGER          JCLOCK,NCLOCK
      LOGICAL          FEGSDB
*KEND.
      COMMON /ELECIN/  EKE0,EKE1,XR0,TEFF0,BLCC,XCC,ESIG0,ESIG1,PSIG0,
     *                 PSIG1,EDEDX0,EDEDX1,PDEDX0,PDEDX1,EBR10,EBR11,
     *                 PBR10,PBR11,PBR20,PBR21,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),PBR10(500),PBR11(500),
     *                 PBR20(500),PBR21(500),TMXS0(500),TMXS1(500),
     *                 ERANG0(1),ERANG1(1),PRANG0(1),PRANG1(1),STERNCOR
*KEEP,EPCONT.
      COMMON /EPCONT/  EDEP,RATIO,TSTEP,TUSTEP,USTEP,TVSTEP,VSTEP,
     *                 RHOFAC,EOLD,ENEW,EKE,ELKE,BETA2,GLE,TSCAT,
     *                 IDISC,IROLD,IRNEW
      DOUBLE PRECISION EDEP,RATIO,TSTEP,TUSTEP,USTEP,TVSTEP,VSTEP,
     *                 RHOFAC,EOLD,ENEW, EKE,ELKE,BETA2,GLE,TSCAT
      INTEGER          IDISC,IROLD,IRNEW

*KEND.
      COMMON /MISC/    DUNIT,RHOR,KMPI,KMPO,NOSCAT,MED,IRAYLR
      DOUBLE PRECISION DUNIT,RHOR(6)
      INTEGER          KMPI,KMPO,NOSCAT,MED(6),IRAYLR(6)
      COMMON /MULTS/   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
*KEEP,RANDPA.
      COMMON /RANDPA/  FAC,U1,U2,RD,NSEQ,ISEED,KNOR
      DOUBLE PRECISION FAC,U1,U2
      REAL             RD(3000)
      INTEGER          ISEED(103,10),NSEQ
      LOGICAL          KNOR
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEEP,STACKE.
      COMMON /STACKE/  E,TIM,U,V,W,X,Y,Z,DNEAR,
     *                 ZAP,WAP,WA,
     *                 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)
     *                 ,ZAP(60),WAP(60),WA(60)
      INTEGER          IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP
*KEND.
      COMMON /THRESH/  RMSQ,API,TE,THMOLL,AP,AE,UP,UE
      DOUBLE PRECISION RMSQ,API,TE,THMOLL
      REAL             AP,AE,UP,UE
      COMMON /UPHIOT/  THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI
      DOUBLE PRECISION THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI
      COMMON /USEFUL/  PRM,PRMT2,RMI,VCI,MEDIUM,MEDOLD,IBLOBE
      DOUBLE PRECISION PRM,PRMT2,RMI,VCI
      INTEGER          MEDIUM,MEDOLD,IBLOBE

      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.D0+1.75D0*BI)
        BM1 = (1.D0-2.D0*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 RMMAR(RD,1,2)
      IF     ( RD(1) .LE. BM1 ) THEN
C  GAUSSIAN, F0
        CALL RMMAR(RD(2),1,2)
*       IF ( RD(2) .EQ. 0.D0 ) RD(2) = 1.E-30
        THR = SQRT(MAX( 0.D0, -LOG(DBLE(RD(2))) ))
      ELSEIF ( RD(1) .LE. BM2 ) THEN
C  TAIL, F3
        CALL RMMAR(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 RMMAR(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 RMMAR(RD,1,2)
C  BETHE CORRECTION FACTOR
      IF ( RD(1)**2*THETA .GT. SINTHE ) GOTO 951
      COSTHE = COS(THETA)
      RETURN
      END
*CMZ :          11/01/2002  09.25.08  by  D. HECK IK FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
C=======================================================================

      SUBROUTINE MUPAIR

C-----------------------------------------------------------------------
C  MU(ON) PAIR (FORMATION)
C
C  IN ANALOGY WITH THE SUBR. PAIR.
C  FOR A PHOTON ENERGY LESS THAN 434 MEV, THE APPROXIMATION IS
C  MADE THAT THE ENERGY OF ONE POSITIVE OR NEGATIVE MUON IS
C  UNIFORMLY DISTRIBUTED IN THE INTERVAL (PRRMMU, PEIG/2)  =
C  (MUON REST MASS, PHOTON ENERGY/2).
C  FOR PHOTON ENERGY ABOVE 434 MEV THE
C  COULOMB CORRECTED BETHE-HEITLER CROSS-SECTION IS USED.
C  (BUTCHER AND MESSEL, OP. CIT., P. 17-19, 22).
C  THIS MAY BE INCORRECT
C  THIS SUBROUTINE IS CALLED FROM PHOTON.
C
C  DESIGN  : D. HECK   IK3  FZK KARLSRUHE
C-----------------------------------------------------------------------

      IMPLICIT NONE
      COMMON /BREMPR/  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)
*KEEP,EGSDEB.
      COMMON /EGSDEB/  JCLOCK,NCLOCK,FEGSDB
      INTEGER          JCLOCK,NCLOCK
      LOGICAL          FEGSDB
*KEND.
      COMMON /MUON/    PRRMMU,RMMUT2
      DOUBLE PRECISION PRRMMU,RMMUT2
      COMMON /NKGSUB/  XXOLD,YYOLD,ZZOLD
      DOUBLE PRECISION XXOLD,YYOLD,ZZOLD
*KEEP,PARPAR.
      COMMON /PARPAR/  CURPAR,SECPAR,PRMPAR,OUTPAR,C,
     *                 E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
      DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16),
     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH
      INTEGER          ITYPE,LEVL
*KEEP,POLAR.
      COMMON /POLAR/   POLART,POLARF
      DOUBLE PRECISION POLART,POLARF
*KEEP,RANDPA.
      COMMON /RANDPA/  FAC,U1,U2,RD,NSEQ,ISEED,KNOR
      DOUBLE PRECISION FAC,U1,U2
      REAL             RD(3000)
      INTEGER          ISEED(103,10),NSEQ
      LOGICAL          KNOR
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEEP,STACKE.
      COMMON /STACKE/  E,TIM,U,V,W,X,Y,Z,DNEAR,
     *                 ZAP,WAP,WA,
     *                 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)
     *                 ,ZAP(60),WAP(60),WA(60)
      INTEGER          IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP
*KEND.
      COMMON /THRESH/  RMSQ,API,TE,THMOLL,AP,AE,UP,UE
      DOUBLE PRECISION RMSQ,API,TE,THMOLL
      REAL             AP,AE,UP,UE
      COMMON /UPHIOT/  THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI
      DOUBLE PRECISION THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI
      COMMON /USEFUL/  PRM,PRMT2,RMI,VCI,MEDIUM,MEDOLD,IBLOBE
      DOUBLE PRECISION PRM,PRMT2,RMI,VCI
      INTEGER          MEDIUM,MEDOLD,IBLOBE

      DOUBLE PRECISION ANGLEX,BR,DEL,DELTA,ENERN,PEIG,PESE1,PESE2,REJF
      INTEGER          LVL,LVL0,LVX
      SAVE
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

      IGEN(NP) = IGEN(NP) + 1
C  PRECISE ENERGY OF INCIDENT GAMMA
      PEIG = E(NP)
C  SUBTRACT EM SUBSHOWER FROM NKG CALCULATION
      IF ( FNKG ) THEN
        SECPAR(1) = 1.D0
        SECPAR(3) = MIN( 1.D0, W(NP) )
        IF ( U(NP) .NE. 0.D0  .OR.  V(NP) .NE. 0.D0 ) THEN
          ANGLEX = -ATAN2(V(NP),U(NP))
        ELSE
          ANGLEX = 0.D0
        ENDIF
        SECPAR(4) = ANGLEX
        SECPAR(5) = -ZZOLD
        SECPAR(7) =  XXOLD
        SECPAR(8) = -YYOLD
        ENERN = (-1.D-3)*PEIG
        CALL NKG(ENERN)
      ENDIF
C  ENERGY OF INCIDENT GAMMA
      IF ( PEIG .LE. 434.D0 ) THEN
C  BELOW 434.MEV, WE ASSUME UNIFORM ENERGY
C  DISTRIBUTION OF THE MUON #2 IN THE INTERVAL (PRRMMU, PEIG/2).
C  SEE ALSO SLAC-265, P.49  FOR FURTHER DISCUSSION.
        CALL RMMAR(RD,1,2)
        PESE2 = (PEIG*0.5D0-PRRMMU)*RD(1)+PRRMMU
      ELSE
C  ABOVE 434.MEV, MUST SAMPLE
C  COULOMB CORRECTED(LVX=2,LVL=4,6) CROSS-SECTIONS.
C  SEE RELATED COMMENTS IN BREMS.
        LVX  = 2
        LVL0 = 3
 181    CONTINUE
C  RETRY IF REJECTED BECAUSE DEL OUT OF RANGE, OR BY SCREENING
C  WE'LL NEED AT LEAST ONE RANDOM NUMBER
        CALL RMMAR(RD,2,2)
C  NOW DECIDE WHICH OF THE TWO SUBDISTRIBUTIONS TO USE.
        IF ( RD(2) .GE. BPAR(LVX) ) THEN
C  USE THE SUBDISTRIBUTION THAT IS PROPORTIONAL TO
C  12*(BR-0.5)**2. IT USES A(DELTA) FOR SCREENING FUNCTION
          LVL = LVL0+1
          CALL RMMAR(RD(3),2,2)
C  FROM SYMMETRY, ONLY NEED TO SAMPLE BR IN INTERVAL (0,.5)
*         BR = 0.5D0*(1.D0-MAX(RD(3),RD(4),RD(1)))
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.
C  UNIFORM.IT USES C(DELTA) FOR A SCREENING REJECT FUNCTION
          LVL = LVL0+3
          BR  = RD(1)*0.5D0
        ENDIF
C  THE SCREENING FUNCTIONS ARE FUNCTIONS OF DELTA=DELCM*DEL,
C  WHERE DELCM= 136.D0*EXP(ZG)*PRM (SAME AS FOR BREMS)
C  AND WHERE DEL=1./(EG0*BR*(1.0-BR))
C  WITH EG0 = INCIDENT PHOTON ENERGY AND BR=ENERGY FRACTION.
C  TO AVOID DIVISION BY ZERO
*       IF ( BR .EQ. 0.D0 ) GOTO 181
C CORRECTED JAN. 11, 1999
        IF ( BR*PEIG .LT. PRRMMU ) GOTO 181
        DEL = 1.D0/(PEIG*BR*(1.D0-BR))
        IF ( DEL .GE. (PRM/PRRMMU)*DELPOS(LVX) ) GOTO 181
C  NEXT TRY
C  THE PRECEDING CONDITION ENSURES THAT A(DELTA) AND C(DELTA)
C  WILL BE POSITIVE. IF IT IS NOT SATISFIED,LOOP BACK AND TRY
C  ANOTHER SAMPLE.
        DELTA = (PRRMMU*RMI)*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
C  RANDOM NUMBER FOR SCREENING REJECTION
        CALL RMMAR(RD,1,2)
C  RETRY UNTIL ACCEPTED
        IF ( RD(1) .GT. REJF ) GOTO 181
C  BR=PRODUCT ENERGY FRACTION
C  ENERGY OF SECONDARY 'MUON' #2
        PESE2 = BR*PEIG
C  END OF PEIG.GT.434 ELSE
      ENDIF
C  ENERGY GOING TO LOWER SECONDARY HAS NOW BEEN DETERMINED
C  PRECISE ENERGY OF SECONDARY 'MUON' 2
C  PRECISE ENERGY OF SECONDARY 'MUON' 1
      PESE1   = PEIG-PESE2
      E(NP)   = PESE1
      E(NP+1) = PESE2
C  THIS AVERAGE ANGLE OF EMISSION FOR BOTH PAIR PRODUCTION AND
C  BREMSSTRAHLUNG IS MUCH SMALLER THAN THE AVERAGE ANGLE OF
C  MULTIPLE SCATTERING FOR DELTA T TRANSPORT=0.01 R.L.
C  THE INITIAL AND FINAL MOMENTA ARE COPLANAR
C  SET UP A NEW 'MUON'
      THETA = PRRMMU/PEIG
      CALL UPHI(1,1)
C  SET UP A NEW 'MUON'
      NP = NP+1
      SINTHE = -SINTHE
      CALL UPHI(3,2)
C  NOW RANDOMLY DECIDED WHICH IS POSITIVE MUON, AND SET
C  CHARGES ACCORDINGLY
      CALL RMMAR(RD,3,2)
      IF ( RD(1) .LE. 0.5 ) THEN
C  POSITIVE MUON ON TOP
        IQ(NP)   = 5
        IQ(NP-1) = 6
      ELSE
C  NEGATIVE MUON ON TOP
        IQ(NP)   = 6
        IQ(NP-1) = 5
      ENDIF
      POLART = 2.D0*RD(2) -1.D0
      POLARF = TWOPI*RD(3)
      RETURN
      END
*CMZ :          10/01/2002  17.03.41  by  D. HECK IK FZK KARLSRUHE
*-- Author :    STANFORD LINEAR ACCELERATOR CENTER
C=======================================================================
C                                STANFORD LINEAR ACCELERATOR CENTER
      SUBROUTINE PAIR

C                                VERSION 4.00  --  26 JAN 1986/1900
C-----------------------------------------------------------------------
C  PAIR (FORMATION)
C
C  FOR A PHOTON ENERGY LESS THAN 2.1 MEV, THE APPROXIMATION IS
C  MADE THAT ONE PAIR ELECTRON (OR POSITRON) HAS ONLY ITS REST
C  MASS ENERGY.   FOR PHOTON ENERGY BETWEEN 2.1 MEV AND 50 MEV THE
C  BETHE-HEITLER CROSS-SECTION IS EMPLOYED.  ABOVE 50 MEV THE
C  COULOMB CORRECTED BETHE-HEITLER CROSS-SECTION IS USED.
C  (BUTCHER AND MESSEL, OP. CIT., P. 17-19, 22).
C  THIS SUBROUTINE IS CALLED FROM PHOTON.
C-----------------------------------------------------------------------

      IMPLICIT NONE
      COMMON /BREMPR/  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)
*KEEP,EGSDEB.
      COMMON /EGSDEB/  JCLOCK,NCLOCK,FEGSDB
      INTEGER          JCLOCK,NCLOCK
      LOGICAL          FEGSDB
*KEEP,RANDPA.
      COMMON /RANDPA/  FAC,U1,U2,RD,NSEQ,ISEED,KNOR
      DOUBLE PRECISION FAC,U1,U2
      REAL             RD(3000)
      INTEGER          ISEED(103,10),NSEQ
      LOGICAL          KNOR
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEEP,STACKE.
      COMMON /STACKE/  E,TIM,U,V,W,X,Y,Z,DNEAR,
     *                 ZAP,WAP,WA,
     *                 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)
     *                 ,ZAP(60),WAP(60),WA(60)
      INTEGER          IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP
*KEND.
      COMMON /THRESH/  RMSQ,API,TE,THMOLL,AP,AE,UP,UE
      DOUBLE PRECISION RMSQ,API,TE,THMOLL
      REAL             AP,AE,UP,UE
      COMMON /UPHIOT/  THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI
      DOUBLE PRECISION THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI
      COMMON /USEFUL/  PRM,PRMT2,RMI,VCI,MEDIUM,MEDOLD,IBLOBE
      DOUBLE PRECISION PRM,PRMT2,RMI,VCI
      INTEGER          MEDIUM,MEDOLD,IBLOBE

      DOUBLE PRECISION BR,DEL,DELTA,PEIG,PESE1,PESE2,REJF
      INTEGER          LVL,LVL0,LVX
      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 RMMAR(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 RMMAR(RD(3),2,2)
C  FROM SYMMETRY, ONLY NEED TO SAMPLE BR IN INTERVAL (0,.5)
*         BR = 0.5D0*(1.D0-MAX(RD(3),RD(4),RD(1)))
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 PHOTON ENERGY AND BR=ENERGY FRACTION.
C  AVOID DIVISION BY ZERO:
*       IF ( BR .EQ. 0.D0 ) GOTO 961
C  CORRECTED 18.12.98
        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 RMMAR(RD,1,2)
        IF ( RD(1) .GT. REJF ) GOTO 961
C  BR=PRODUCT ENERGY FRACTION
        PESE2 = BR*PEIG
      ENDIF
      PESE1 = PEIG-PESE2
      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 RMMAR(RD,1,2)
      IF ( RD(1) .LE. 0.5 ) THEN
        IQ(NP)   = 2
        IQ(NP-1) = 3
      ELSE
        IQ(NP)   = 3
        IQ(NP-1) = 2
      ENDIF
      RETURN
      END
*CMZ :          18/09/2001  13.38.55  by  D. HECK IK FZK KARLSRUHE
*-- 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 FORM PHOTON
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,EGSDEB.
      COMMON /EGSDEB/  JCLOCK,NCLOCK,FEGSDB
      INTEGER          JCLOCK,NCLOCK
      LOGICAL          FEGSDB
*KEEP,EPCONT.
      COMMON /EPCONT/  EDEP,RATIO,TSTEP,TUSTEP,USTEP,TVSTEP,VSTEP,
     *                 RHOFAC,EOLD,ENEW,EKE,ELKE,BETA2,GLE,TSCAT,
     *                 IDISC,IROLD,IRNEW
      DOUBLE PRECISION EDEP,RATIO,TSTEP,TUSTEP,USTEP,TVSTEP,VSTEP,
     *                 RHOFAC,EOLD,ENEW, EKE,ELKE,BETA2,GLE,TSCAT
      INTEGER          IDISC,IROLD,IRNEW

*KEEP,LONGI.
      COMMON /LONGI/   ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP,LLONGI,FLGFIT
      DOUBLE PRECISION ADLONG(0:1170,9),AELONG(0:1170,9),
     *                 APLONG(0:1170,9),DLONG(0:1170,9),ELONG(0:1170,9),
     *                 HLONG(0:1170),PLONG(0:1170,9),SDLONG(0:1170,9),
     *                 SELONG(0:1170,9),SPLONG(0:1170,9),THSTEP,THSTPI
      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT
*KEND.
      COMMON /PHOTIN/  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
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEEP,STACKE.
      COMMON /STACKE/  E,TIM,U,V,W,X,Y,Z,DNEAR,
     *                 ZAP,WAP,WA,
     *                 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)
     *                 ,ZAP(60),WAP(60),WA(60)
      INTEGER          IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP
*KEND.
      COMMON /USEFUL/  PRM,PRMT2,RMI,VCI,MEDIUM,MEDOLD,IBLOBE
      DOUBLE PRECISION PRM,PRMT2,RMI,VCI
      INTEGER          MEDIUM,MEDOLD,IBLOBE

      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  PHOTON IS COMPLETELY ABSORBED
        EDEP   = PEIG
        IBLOBE = 1
      ELSE
C  ASSUME ELECTRON WENT IN DIRECTION OF THE PHOTON 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
        DLONG(LPCTE(NP),1) = DLONG(LPCTE(NP),1) + EDEP*1.D-3
      ENDIF
      IF ( IBLOBE .EQ. 1 ) THEN
        E(NP) = 0.D0
        RETURN
      ENDIF
      IQ(NP) = 3
C  SET ELECTRON ENERGY
      E(NP)  = PEIG-EDEP+PRM
      RETURN
      END
*CMZ :          28/01/2002  09.50.31  by  D. HECK IK FZK KARLSRUHE
*-- 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 PHOTON 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
      COMMON /BOUNDS/  ECUT,PCUT,VACDST
      DOUBLE PRECISION ECUT(6),PCUT(6),VACDST
*KEEP,BUFFS.
      COMMON /BUFFS/   RUNH,RUNE,EVTH,EVTE,DATAB,ARRAYLONG,LH
      INTEGER          MAXBUF,MAXLEN
      PARAMETER        (MAXLEN=16)
      PARAMETER        (MAXBUF=39*7)
      REAL             RUNH(MAXBUF),EVTH(MAXBUF),EVTE(MAXBUF),
     *                 RUNE(MAXBUF),DATAB(MAXBUF),ARRAYLONG(MAXBUF)
      INTEGER          LH
      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)
*KEEP,CEREN1.
      COMMON /CEREN1/  CERELE,CERHAD,ETADSN,WAVLGL,WAVLGU,CYIELD,
     *                 CERSIZ,CERNOR,LCERFI
      DOUBLE PRECISION CERELE,CERHAD,ETADSN,WAVLGL,WAVLGU,CYIELD,
     *                 CERSIZ,CERNOR
      LOGICAL          LCERFI
*KEEP,EGSDEB.
      COMMON /EGSDEB/  JCLOCK,NCLOCK,FEGSDB
      INTEGER          JCLOCK,NCLOCK
      LOGICAL          FEGSDB
*KEEP,EPCONT.
      COMMON /EPCONT/  EDEP,RATIO,TSTEP,TUSTEP,USTEP,TVSTEP,VSTEP,
     *                 RHOFAC,EOLD,ENEW,EKE,ELKE,BETA2,GLE,TSCAT,
     *                 IDISC,IROLD,IRNEW
      DOUBLE PRECISION EDEP,RATIO,TSTEP,TUSTEP,USTEP,TVSTEP,VSTEP,
     *                 RHOFAC,EOLD,ENEW, EKE,ELKE,BETA2,GLE,TSCAT
      INTEGER          IDISC,IROLD,IRNEW

*KEND.
      COMMON /GEOMEGS/ ZALTIT,BOUND,OBSLVL,NEWOBS
      DOUBLE PRECISION ZALTIT,BOUND(6),OBSLVL(10)
      INTEGER          NEWOBS
      COMMON /LAYER/   HBARO,HBAROI
      DOUBLE PRECISION HBARO(6),HBAROI(6)
*KEEP,LONGI.
      COMMON /LONGI/   ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP,LLONGI,FLGFIT
      DOUBLE PRECISION ADLONG(0:1170,9),AELONG(0:1170,9),
     *                 APLONG(0:1170,9),DLONG(0:1170,9),ELONG(0:1170,9),
     *                 HLONG(0:1170),PLONG(0:1170,9),SDLONG(0:1170,9),
     *                 SELONG(0:1170,9),SPLONG(0:1170,9),THSTEP,THSTPI
      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT
*KEND.
      COMMON /MEDIA/   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 /MEDIAC/  MEDIA
      CHARACTER        MEDIA*24
      COMMON /MISC/    DUNIT,RHOR,KMPI,KMPO,NOSCAT,MED,IRAYLR
      DOUBLE PRECISION DUNIT,RHOR(6)
      INTEGER          KMPI,KMPO,NOSCAT,MED(6),IRAYLR(6)
      COMMON /MUON/    PRRMMU,RMMUT2
      DOUBLE PRECISION PRRMMU,RMMUT2
      COMMON /NKGSUB/  XXOLD,YYOLD,ZZOLD
      DOUBLE PRECISION XXOLD,YYOLD,ZZOLD
*KEEP,OBSPAR.
      COMMON /OBSPAR/  OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP,
     *                 THETPR,PHIPR,
     *                 VUECON,
     *                 NOBSLV
      DOUBLE PRECISION OBSLEV(10),THCKOB(10),XOFF(10),YOFF(10),
     *                 HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2)
      DOUBLE PRECISION VUECON(2)
      INTEGER          NOBSLV
*KEEP,PARPAR.
      COMMON /PARPAR/  CURPAR,SECPAR,PRMPAR,OUTPAR,C,
     *                 E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
      DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16),
     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH
      INTEGER          ITYPE,LEVL
*KEND.
      COMMON /PHOTIN/  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 /PION/    PI0MSQ,PITHR,PICMAS,PI0MAS,AMASK0,AMASKC,AMASPR,
     *                 AMASNT
      DOUBLE PRECISION PI0MSQ,PITHR,PICMAS,PI0MAS,AMASK0,AMASKC,AMASPR,
     *                 AMASNT
*KEEP,RANDPA.
      COMMON /RANDPA/  FAC,U1,U2,RD,NSEQ,ISEED,KNOR
      DOUBLE PRECISION FAC,U1,U2
      REAL             RD(3000)
      INTEGER          ISEED(103,10),NSEQ
      LOGICAL          KNOR
*KEEP,REJECT.
      COMMON /REJECT/  AVNREJ,ALTMIN,ANEXP,THICKA,THICKD,CUTLN,EONCUT,
     *                 FNPRIM
      DOUBLE PRECISION AVNREJ(10),ALTMIN(10),ANEXP(10),THICKA(10),
     *                 THICKD(10),CUTLN,EONCUT
      LOGICAL          FNPRIM
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEEP,STACKE.
      COMMON /STACKE/  E,TIM,U,V,W,X,Y,Z,DNEAR,
     *                 ZAP,WAP,WA,
     *                 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)
     *                 ,ZAP(60),WAP(60),WA(60)
      INTEGER          IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP
*KEND.
      COMMON /THRESH/  RMSQ,API,TE,THMOLL,AP,AE,UP,UE
      DOUBLE PRECISION RMSQ,API,TE,THMOLL
      REAL             AP,AE,UP,UE
      COMMON /UPHIOT/  THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI
      DOUBLE PRECISION THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI
      COMMON /USEFUL/  PRM,PRMT2,RMI,VCI,MEDIUM,MEDOLD,IBLOBE
      DOUBLE PRECISION PRM,PRMT2,RMI,VCI
      INTEGER          MEDIUM,MEDOLD,IBLOBE

      DOUBLE PRECISION ALTEXP,COHFAC,CSQTHE,DISC,DPMFP,
     *                 GBR1,GBR2,GBR3,GBR4,GMFP,GMFPR0,PEIG,Q2,
     *                 REJF,RHOFI,SITHET,THICK,USTEPU,X2,ZOLD
      INTEGER          IRCODE,IRL,I,IDR,I1,
     *                 LGLE,LPCT1,LPCT2,LXXX
      DOUBLE PRECISION AUXIL,AUXILSQ,AUX2SQ,CORR,COSDIF,COSTHENEW,
     *                 DISTN2,DISTO2,DSTEFF,PHI,SIGNE,SINDIF,
     *                 TANPHI,TRANS2,XOLD,YOLD,ZNEW
      INTEGER          IPASC
      SAVE
      EXTERNAL         THICK
C-----------------------------------------------------------------------

      IF ( FEGSDB ) THEN
        WRITE(MDEBUG,1) NP,IR(NP),IOBS(NP)
 1      FORMAT(' PHOTON: NP=',I3,' IR=',I3,' IOBS=',I3)
        CALL AUSGB2
      ENDIF

      NEWOBS = IOBS(NP)
      IRCODE = 1
      PEIG   = E(NP)
      IRL    = IR(NP)
      MEDIUM = MED(IRL)
      IF ( PEIG .LE. PCUT(IRL) ) GOTO 970
 980  CONTINUE
      XXOLD = X(NP)
      YYOLD = Y(NP)
      ZZOLD = Z(NP)
 981  CONTINUE
C  KILL HORIZONTAL OR UPWARD GOING PARTICLES
      IF ( W(NP) .LE. C(29) ) THEN
        IDISC = 1
        GOTO 1000
      ENDIF
      GLE   = LOG(PEIG)


C  HERE SAMPLE MEAN FREE PATH TO TRANSPORT BEFORE INTERACTING
      CALL RMMAR(RD,1,2)
      DPMFP = -LOG(DBLE(RD(1)))
      IROLD = IR(NP)
 1031 CONTINUE
      IF ( MEDIUM .NE. 0 ) THEN
        LGLE   = GE1*GLE+GE0
        GMFPR0 = GMFP1(LGLE)*GLE+GMFP0(LGLE)
      ENDIF
 1041 CONTINUE
      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  = GMFP*DPMFP
        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
      IF ( IDISC .GT. 0 ) GOTO 1000
      IF ( IDISC .LT. 0 ) THEN
C  PARTICLE WILL CROSS THE DETECTOR LEVEL
        ZOLD = Z(NP)
        XOLD = X(NP)
        YOLD = Y(NP)
        DISTO2 = X(NP)**2 + Y(NP)**2
        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) )
        ZAP(NP) = - (C(1)-Z(NP)) * WA(NP) + C(1)
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  CALCULATE CORRECTION ANGLE DIF FROM EFFECTIVE DISTANCE
        SINDIF = SIN( DSTEFF/C(1) )
        COSDIF = SQRT( 1.D0 - SINDIF**2 )
        COSTHENEW = W(NP)*COSDIF - SQRT(1.D0-W(NP)**2)*SINDIF
        IF ( FEGSDB ) WRITE(MDEBUG,*) 'PHOTON: COSDIF,COSTHENEW=',
     *                              SNGL(COSDIF),SNGL(COSTHENEW)
        W(NP) = MIN( 1.D0, COSTHENEW )
C  KILL HORIZONTAL OR UPWARD GOING PARTICLES
        IF ( W(NP) .LE. C(29) ) THEN
          IDISC = 1
          GOTO 1000
        ENDIF
C  ANGLE DIF MIGHT BE LARGE (DUE TO CUT ON APPARENT HEIGHT)
        X(NP) = ((-ZAP(NP))+C(1)) * TAN(X(NP)/C(1))
        Y(NP) = ((-ZAP(NP))+C(1)) * TAN(Y(NP)/C(1))
        Z(NP) = ZAP(NP)
        IF ( U(NP) .NE. 0.D0 ) THEN
          TANPHI= V(NP)/U(NP)
          U(NP) = SIGN(1.D0,U(NP)) *
     *                       SQRT((1.D0-W(NP)**2)/(1.D0+TANPHI**2))
          V(NP) = TANPHI * U(NP)
        ELSE
          IF ( V(NP) .NE. 0.D0 )
     *           V(NP) = SIGN(1.D0,V(NP)) * SQRT( 1.D0 - W(NP)**2 )
        ENDIF
        USTEP = -(Z(NP)+OBSLEV(1))/W(NP)
        IF ( FEGSDB ) THEN
          WRITE(MDEBUG,*) 'PHOTON: CORR. FOR DET. ARRIVAL:USTEP=',USTEP
          CALL AUSGB2
        ENDIF
        IPASC = 1
      ELSE
C  NORMAL TRANSPORT STEP FAR AWAY FROM DETECTOR
        IPASC = 0
        ZOLD  = Z(NP)
        XOLD  = X(NP)
        YOLD  = Y(NP)
        DISTO2 = X(NP)**2 + Y(NP)**2
      ENDIF
      VSTEP  = USTEP
      TVSTEP = VSTEP
C  NO ENERGY DEPOSITION ON PHOTON 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)
      ENDIF
      X(NP) = X(NP)+U(NP)*USTEP
      Y(NP) = Y(NP)+V(NP)*USTEP
      Z(NP) = Z(NP)+W(NP)*USTEP
      TIM(NP) = TIM(NP)+TVSTEP*VCI
      IF ( IPASC .EQ. 0 ) 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  CORRECTED X AND Y HAVE TO BE CALCULATED BEFORE DISTN2
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  NEW DISTANCE FROM PARTICLE TO DETECTOR CENTER
        DISTN2 = X(NP)**2 + Y(NP)**2
C  COMPARE NEW AND OLD DISTANCE TO DETECTOR CENTER
        IF ( DISTN2 .LT. DISTO2 ) THEN
C  PARTICLE MOVES TOWARDS DETECTOR CENTER
          SIGNE = +1.D0
        ELSE
          SIGNE = -1.D0
          IF ( FEGSDB ) WRITE(MDEBUG,*) 'PHOTON: SIGNE=',SIGNE
        ENDIF
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 - SIGNE*SINDIF*SQRT(1.D0-W(NP)**2)
        W(NP)     = MIN( 1.D0, COSTHENEW )
C  KILL HORIZONTAL OR UPWARD GOING PARTICLES
        IF ( W(NP) .LE. C(29) ) THEN
          IDISC = 1
          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,6E10.3,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)-ZNEW) * WA(NP) + C(1)
        AUX2SQ  = SQRT( (C(1)-ZNEW)**2*(1.D0 - WA(NP)**2)
     *                                    + (-ZAP(NP)-OBSLEV(1))**2 )
        WAP(NP) = -(OBSLEV(1)+ZAP(NP)) / AUX2SQ
        IF ( FEGSDB ) WRITE(MDEBUG,*) 'PHOTON: WAP=',WAP(NP)
        WAP(NP) = MIN( 1.D0, WAP(NP) )
        IF ( U(NP) .NE. 0.D0 ) THEN
          TANPHI= V(NP)/U(NP)
          U(NP) = SIGN(1.D0,U(NP)) *
     *                         SQRT((1.D0-W(NP)**2)/(1.D0+TANPHI**2))
          V(NP) = TANPHI * U(NP)
        ELSE
          IF ( V(NP) .NE. 0.D0 )
     *           V(NP) = SIGN(1.D0,V(NP)) * SQRT( 1.D0 - W(NP)**2 )
        ENDIF
      ENDIF
C  ADD PHOTONS TO THE LONGITUDINAL DEVELOPMENT
      IF ( LLONGI ) THEN
C  FIND FIRST THE EQUIVALENT LEVELS
C  IF STARTING POINT BELOW LOWEST LEVEL THEN DON'T CHECK
        IF ( HLONG(NSTEP) .LE. -ZOLD ) THEN
          LPCT1 = LPCTE(NP)
C  Z NEW IS PROBABLY ONLY LITTLE BELOW Z OLD, THEREFORE INCREMENTAL SEARCH
          DO   I1 = LPCT1,NSTEP
            IF ( HLONG(I1) .LT. -Z(NP) ) 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
          IF ( IDISC .LT. 0 ) LPCT2 = LPCT2+1
          DO   I = LPCT1,LPCT2
            PLONG(I,1) = PLONG(I,1) + 1.D0
            ELONG(I,1) = ELONG(I,1) + E(NP)*1.D-3
          ENDDO
        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 ( IRNEW .NE. IROLD ) THEN
C  CHANGE OF LAYER
        IR(NP) = IRNEW
        IRL    = IRNEW
        MEDIUM = MED(IRL)
        IF ( PEIG .LE. PCUT(IRL) ) GOTO 970
      ENDIF
C  KILL UPWARD GOING PARTICLES
      IF ( W(NP) .LE. C(29) ) THEN
        IDISC = 1
        GOTO 1000
      ENDIF
C  LOOK FOR OBSERVATION LEVEL AND GIVE TO OUTPUT
      IF ( NEWOBS .GT. IOBS(NP) ) THEN
        CALL AUSGAB
        IOBS(NP) = NEWOBS
      ENDIF
      IF ( IDISC .LT. 0 ) GOTO 1000
      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-6 ) GOTO 1032
      GOTO 1041

 1032 CONTINUE
C  RAYLEIGH SCATTERING
      IF ( IRAYLR(IRL) .EQ. 1 ) THEN
        CALL RMMAR(RD,1,2)
        IF ( RD(1) .LE. 1.D0-COHFAC ) THEN
 1050     CONTINUE
          CALL RMMAR(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 RMMAR(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

      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)
          SITHET   = SQRT(1.D0-SECPAR(3)**2)
          U(1) = SITHET*COS(-SECPAR(4))
          V(1) = SITHET*SIN(-SECPAR(4))
          W(1) = SECPAR(3)
        ENDIF
        EVTH(6) = 0.
        IF ( TMARGIN ) THEN
C  NEGATIVE FIRST INTERACTION HEIGHT,IF TRACKING STARTS AT ATMOS. MARGIN
          EVTH(7) = Z(1)
        ELSE
          EVTH(7) = -Z(1)
        ENDIF
        CALL TOBUF(EVTH,0)
C  OUTPUT OF EVENTHEADER TO THE CHERENKOV FILE
        IF ( LCERFI ) CALL TOBUFC( EVTH,0 )
        CALL CORNEC
        TIM(1) = 0.D0
        FNPRIM = .TRUE.
        IF ( FPRINT ) THEN
          WRITE(KMPO,*) ' FIRST INTERACTION AT ',ABS(EVTH(7)*0.01),' M'
        ENDIF
      ENDIF

C  THIS RANDOM NUMBER DETERMINES WHICH INTERACTION
      CALL RMMAR(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 PAIR
        RETURN
      ENDIF

      GBR3 = GBR31(LGLE)*GLE+GBR30(LGLE)
      IF ( RD(1) .GE. GBR3 ) THEN
C  COMPTON SCATTERING
        CALL COMPT
        IF ( IQ(NP) .NE. 1 ) RETURN
        GOTO 1060
      ENDIF

      GBR1 = GBR11(LGLE)*GLE+GBR10(LGLE)
      IF ( RD(1) .LE. GBR1  .AND.  E(NP) .GT. RMMUT2 ) THEN
C  MU+MU- PAIR FORMATION
        CALL MUPAIR
        RETURN
      ENDIF

      GBR2 = GBR21(LGLE)*GLE+GBR20(LGLE)
      IF ( RD(1) .LE. GBR2  .AND.  E(NP) .GT. PITHR ) THEN
C  PHOTONUCLEAR REACTION
        CALL PIGEN
        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 PEIG = E(NP)
C  KILL HORIZONTAL OR UPWARD GOING PARTICLES
      IF ( W(NP) .LE. C(29) ) THEN
        IDISC = 1
        GOTO 1000
      ENDIF
      IF ( PEIG .GE. PCUT(IRL) ) GOTO 980

 970  IF ( PEIG .GT. AP ) THEN
        IDR = 1
      ELSE
        IDR = 2
      ENDIF
      EDEP = PEIG
      IF ( LLONGI ) THEN
C  CUTTED ENERGY TO LONGITUDINAL ENERGY SUMS
        DLONG(LPCTE(NP),1) = DLONG(LPCTE(NP),1) + EDEP*1.D-3
      ENDIF
      IRCODE = 2
      NP = NP-1
      RETURN

 1000 EDEP = PEIG
      IF ( LLONGI  .AND.  IDISC .GT. 0 ) THEN
C  CUTTED ENERGY TO LONGITUDINAL ENERGY SUMS
        DLONG(LPCTE(NP),1) = DLONG(LPCTE(NP),1) + EDEP*1.D-3
      ENDIF
      IRCODE = 2
      NP = NP-1
      RETURN
      END
*CMZ :          11/01/2002  09.25.09  by  D. HECK IK FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
C=======================================================================

      SUBROUTINE PIGEN

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 PHOTON.
C
C  DESIGN  : D. HECK   IK3  FZK KARLSRUHE
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,BUFFS.
      COMMON /BUFFS/   RUNH,RUNE,EVTH,EVTE,DATAB,ARRAYLONG,LH
      INTEGER          MAXBUF,MAXLEN
      PARAMETER        (MAXLEN=16)
      PARAMETER        (MAXBUF=39*7)
      REAL             RUNH(MAXBUF),EVTH(MAXBUF),EVTE(MAXBUF),
     *                 RUNE(MAXBUF),DATAB(MAXBUF),ARRAYLONG(MAXBUF)
      INTEGER          LH
      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)
*KEEP,EGSDEB.
      COMMON /EGSDEB/  JCLOCK,NCLOCK,FEGSDB
      INTEGER          JCLOCK,NCLOCK
      LOGICAL          FEGSDB
*KEEP,GENER.
      COMMON /GENER/   GEN,ALEVEL
      DOUBLE PRECISION GEN,ALEVEL
*KEEP,MULT.
      COMMON /MULT/    EKINL,MSMM,MULTMA,MULTOT
      DOUBLE PRECISION EKINL
      INTEGER          MSMM,MULTMA(40,13),MULTOT(40,13)
*KEND.
      COMMON /NKGSUB/  XXOLD,YYOLD,ZZOLD
      DOUBLE PRECISION XXOLD,YYOLD,ZZOLD
*KEEP,PAM.
      COMMON /PAM/     PAMA,SIGNUM,RESTMS
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000)
*KEEP,PARPAR.
      COMMON /PARPAR/  CURPAR,SECPAR,PRMPAR,OUTPAR,C,
     *                 E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
      DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16),
     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH
      INTEGER          ITYPE,LEVL
*KEEP,RANDPA.
      COMMON /RANDPA/  FAC,U1,U2,RD,NSEQ,ISEED,KNOR
      DOUBLE PRECISION FAC,U1,U2
      REAL             RD(3000)
      INTEGER          ISEED(103,10),NSEQ
      LOGICAL          KNOR
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEEP,STACKE.
      COMMON /STACKE/  E,TIM,U,V,W,X,Y,Z,DNEAR,
     *                 ZAP,WAP,WA,
     *                 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)
     *                 ,ZAP(60),WAP(60),WA(60)
      INTEGER          IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP
*KEEP,THNVAR.
      COMMON /THNVAR/  STACKINT,
     *                 INT_ICOUNT,MODETHN,THINNING
      INTEGER          MAXICOUNT
      PARAMETER        (MAXICOUNT=40000)
      DOUBLE PRECISION STACKINT(16,MAXICOUNT)
      INTEGER          INT_ICOUNT,MODETHN
      LOGICAL          THINNING
*KEND.

      DOUBLE PRECISION ANGLEX,ENERN,PEIG,REGPAR(MAXLEN),REGGEN,REGLVL
      DOUBLE PRECISION AUXIL,ECMVM,VMFRAC
      INTEGER          K
      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 AGE, WE HAVE HADRONIC INTERACTION
      IGEN(NP)   = IGEN(NP)+1
      SECPAR(9)  = IGEN(NP)
      SECPAR(10) =-Z(NP)
      SECPAR(14) = -ZAP(NP)
      SECPAR(15) = WAP(NP)
      SECPAR(16) = WA(NP)
      PEIG = E(NP)
      IF ( U(NP) .NE. 0.D0  .OR.  V(NP) .NE. 0.D0 ) THEN
        ANGLEX = -ATAN2(V(NP),U(NP))
      ELSE
        ANGLEX = 0.D0
      ENDIF
C  SUBTRACT EM SUBSHOWER FROM NKG CALCULATION
C  WITH CORRECTION FOR ORIGIN OF GAMMA (MARCH 10, 1998)
      IF ( FNKG ) THEN
        SECPAR(1) = 1.D0

        SECPAR(3) = MIN( 1.D0, W(NP) )
        SECPAR(4) = ANGLEX
        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
      CALL RMMAR(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  SAVE CURPAR PARTICLE INTO REGISTER REGPAR
        DO   K = 1,MAXLEN
          REGPAR(K) = CURPAR(K)
        ENDDO
        REGGEN = GEN
        REGLVL = ALEVEL
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  ENERGY IN CM SYSTEM (GEV)
        ECMVM  = SQRT( AUXIL*(AUXIL + 2.D0*PEIG*0.001D0) )
C  THE FRACTION IS THE RATIO OF VECTOR MESON PRODUCTION CROSS-SECTION
C  (TO BE CALCULATED ACCORDING R. ENGEL ET AL., PHYS. REV. D55
C  (1997) 6957)  TO  TOTAL PHOTONUCLEAR CROSS-SECTION
C  (SEE  T. STANEV ET AL., PHYS. REV. D32 (1985) 1244)
C  THE FRACTION LEADING TO A RHO (90%) OR OMEGA (10%)  IS FITTED BY
        VMFRAC = .11195D0 * ECMVM**0.0870D0 + .51892D0/(ECMVM**1.2891D0)
        CALL RMMAR(RD,1,2)
        IF ( FEGSDB ) WRITE(MDEBUG,*) 'PIGEN : VMFRAC,RD=',
     *                                 SNGL(VMFRAC),RD(1)
        IF ( RD(1) .LT. VMFRAC ) THEN
          INT_ICOUNT = 0
          CALL RHOGEN
          CALL TSTEND
        ELSE
C  AT HIGHER ENERGIES MORE THAN 2 PIONS ARE GENERATED BY HIGH ENERGY
C  HADRONIC INTERACTION MODEL
C  FILL CURRENT EGS4-PARTICLE INTO CURPAR
          ITYPE = 1
          CURPAR(1)  = 1.D0
          CURPAR(2)  = PEIG*1.D-3
          CURPAR(3)  = MIN( 1.D0, W(NP) )
          CURPAR(4)  = ANGLEX
          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(2)
          CURPAR(14) = -ZAP(NP)
          SECPAR(14) = -ZAP(NP)
          CURPAR(15) = WAP(NP)
          SECPAR(15) = WAP(NP)
          CURPAR(16) = WA(NP)
          SECPAR(16) = WA(NP)
C  ELIMINATE GAMMA FROM EGS-STACK
          NP = NP-1
C  HDPM, VENUS, NEXUS, SIBYLL, QGSJET, DPMJET 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
          CALL TSTEND
C  END OF MANY PION GENERATION
        ENDIF
C  RESTORE CURPAR PARTICLE FROM REGPAR
        DO   K = 1,MAXLEN
          CURPAR(K) = REGPAR(K)
        ENDDO
        GEN    = REGGEN
        ALEVEL = REGLVL
      ENDIF
      RETURN
      END
*CMZ :          28/02/2002  13.12.11  by  D. HECK IK FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
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
C  DESIGN  : D. HECK   IK3  FZK KARLSRUHE
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,EGSDEB.
      COMMON /EGSDEB/  JCLOCK,NCLOCK,FEGSDB
      INTEGER          JCLOCK,NCLOCK
      LOGICAL          FEGSDB
*KEEP,ELABCT.
      COMMON /ELABCT/  ELCUT
      DOUBLE PRECISION ELCUT(4)
*KEEP,LONGI.
      COMMON /LONGI/   ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP,LLONGI,FLGFIT
      DOUBLE PRECISION ADLONG(0:1170,9),AELONG(0:1170,9),
     *                 APLONG(0:1170,9),DLONG(0:1170,9),ELONG(0:1170,9),
     *                 HLONG(0:1170),PLONG(0:1170,9),SDLONG(0:1170,9),
     *                 SELONG(0:1170,9),SPLONG(0:1170,9),THSTEP,THSTPI
      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT
*KEEP,PAM.
      COMMON /PAM/     PAMA,SIGNUM,RESTMS
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000)
*KEEP,PARPAR.
      COMMON /PARPAR/  CURPAR,SECPAR,PRMPAR,OUTPAR,C,
     *                 E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
      DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16),
     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH
      INTEGER          ITYPE,LEVL
*KEND.
      COMMON /PION/    PI0MSQ,PITHR,PICMAS,PI0MAS,AMASK0,AMASKC,AMASPR,
     *                 AMASNT
      DOUBLE PRECISION PI0MSQ,PITHR,PICMAS,PI0MAS,AMASK0,AMASKC,AMASPR,
     *                 AMASNT
*KEEP,RANDPA.
      COMMON /RANDPA/  FAC,U1,U2,RD,NSEQ,ISEED,KNOR
      DOUBLE PRECISION FAC,U1,U2
      REAL             RD(3000)
      INTEGER          ISEED(103,10),NSEQ
      LOGICAL          KNOR
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEEP,REJECT.
      COMMON /REJECT/  AVNREJ,ALTMIN,ANEXP,THICKA,THICKD,CUTLN,EONCUT,
     *                 FNPRIM
      DOUBLE PRECISION AVNREJ(10),ALTMIN(10),ANEXP(10),THICKA(10),
     *                 THICKD(10),CUTLN,EONCUT
      LOGICAL          FNPRIM
*KEEP,STACKE.
      COMMON /STACKE/  E,TIM,U,V,W,X,Y,Z,DNEAR,
     *                 ZAP,WAP,WA,
     *                 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)
     *                 ,ZAP(60),WAP(60),WA(60)
      INTEGER          IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP
*KEND.
      COMMON /UPHIOT/  THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI
      DOUBLE PRECISION THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI

      DOUBLE PRECISION AMASS2,AMAS2I,AMASS3,AMASS4,AMOM3,AMOM4,ANGLEX,
     *                 BETA,BRATIO,B3CM,B3CM2,COSTE3,ED,ENUCL,
     *                 ESQ,ETH,E3CM,GAMMA,G3,
     *                 PEIG,PEOP,PT,PTRANS,P3CM,W0,W0I,W0S,W0SI
      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

      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 RMMAR(RD,2,2)
C  0.49923 IS THE FRACTION OF PROTONS IN AIR
      IF ( RD(1) .LE. 0.49923 ) THEN
C  HIT NUCLEON IS PROTON
        AMASS2 = AMASPR
C  33% CHANCE FOR CHARGE EXCHANGE
        IF ( RD(2) .LE. 0.3333333 ) 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.3333333 ) 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  PHOTON ENERGY IS BELOW 900 MEV
 210    CONTINUE
        CALL RMMAR(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  PHOTON ENERGY BETWEEN 900 AND 1300 MEV
 220    CONTINUE
        CALL RMMAR(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**2-PT**2 ))/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**2-AMASS3**2 ))
      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.0D0, 1.D0-COSTHE**2 ))
      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**2-AMASS4**2)
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.0D0, 1.D0-COSTHE**2 ))
        CALL UPHI(3,2)
        IF ( E(NP)-AMASS4 .GT. ELCUT(1)*1000.D0 ) THEN
          IF ( W(NP) .GT. C(29) ) THEN
C  ANGLE WITH RESPECT TO X AXIS
            IF ( U(NP) .NE. 0.D0  .OR.  V(NP) .NE. 0.D0 ) THEN
              ANGLEX = -ATAN2(V(NP),U(NP))
            ELSE
              ANGLEX = 0.D0
            ENDIF
C  ADD NUCLEON TO CORSIKA STACK
            SECPAR(1)  = IQ(NP)
            SECPAR(2)  = E(NP)/AMASS4
            SECPAR(3)  = MIN( 1.D0, W(NP) )
            SECPAR(4)  = ANGLEX
            SECPAR(5)  = -Z(NP)
            SECPAR(6)  = TIM(NP)
            SECPAR(7)  = X(NP)
            SECPAR(8)  = -Y(NP)
            SECPAR(11) = 1.D0
            SECPAR(12) = 0.D0
            CALL TSTACK
          ELSE
            IF ( LLONGI ) THEN
C  CUTTED ENERGY TO LONGITUDINAL ENERGY SUMS OF NUCLEON
              DLONG(LPCTE(NP),7) = DLONG(LPCTE(NP),7)
     *                             + (E(NP)-AMASS4) * 1.D-3
            ENDIF
          ENDIF
        ELSE
          IF ( LLONGI ) THEN
C  CUTTED ENERGY TO LONGITUDINAL ENERGY SUMS OF NUCLEON
            DLONG(LPCTE(NP),7) = DLONG(LPCTE(NP),7)
     *                             + (E(NP)-AMASS4) * 1.D-3
          ENDIF
        ENDIF
C  ELIMINATE NUCLEON FROM EGS-STACK
        NP = NP-1
      ENDIF
C  END OF RECOIL NUCLEON TREATMENT CASE
      RETURN
      END
*CMZ :          11/01/2002  09.25.09  by  D. HECK IK FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
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
C  DESIGN  : D. HECK   IK3  FZK KARLSRUHE
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,EGSDEB.
      COMMON /EGSDEB/  JCLOCK,NCLOCK,FEGSDB
      INTEGER          JCLOCK,NCLOCK
      LOGICAL          FEGSDB
*KEEP,ELABCT.
      COMMON /ELABCT/  ELCUT
      DOUBLE PRECISION ELCUT(4)
*KEEP,LONGI.
      COMMON /LONGI/   ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP,LLONGI,FLGFIT
      DOUBLE PRECISION ADLONG(0:1170,9),AELONG(0:1170,9),
     *                 APLONG(0:1170,9),DLONG(0:1170,9),ELONG(0:1170,9),
     *                 HLONG(0:1170),PLONG(0:1170,9),SDLONG(0:1170,9),
     *                 SELONG(0:1170,9),SPLONG(0:1170,9),THSTEP,THSTPI
      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT
*KEEP,PAM.
      COMMON /PAM/     PAMA,SIGNUM,RESTMS
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000)
*KEEP,PARPAR.
      COMMON /PARPAR/  CURPAR,SECPAR,PRMPAR,OUTPAR,C,
     *                 E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
      DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16),
     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH
      INTEGER          ITYPE,LEVL
*KEND.
      COMMON /PION/    PI0MSQ,PITHR,PICMAS,PI0MAS,AMASK0,AMASKC,AMASPR,
     *                 AMASNT
      DOUBLE PRECISION PI0MSQ,PITHR,PICMAS,PI0MAS,AMASK0,AMASKC,AMASPR,
     *                 AMASNT
*KEEP,RANDPA.
      COMMON /RANDPA/  FAC,U1,U2,RD,NSEQ,ISEED,KNOR
      DOUBLE PRECISION FAC,U1,U2
      REAL             RD(3000)
      INTEGER          ISEED(103,10),NSEQ
      LOGICAL          KNOR
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEEP,REJECT.
      COMMON /REJECT/  AVNREJ,ALTMIN,ANEXP,THICKA,THICKD,CUTLN,EONCUT,
     *                 FNPRIM
      DOUBLE PRECISION AVNREJ(10),ALTMIN(10),ANEXP(10),THICKA(10),
     *                 THICKD(10),CUTLN,EONCUT
      LOGICAL          FNPRIM
*KEEP,STACKE.
      COMMON /STACKE/  E,TIM,U,V,W,X,Y,Z,DNEAR,
     *                 ZAP,WAP,WA,
     *                 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)
     *                 ,ZAP(60),WAP(60),WA(60)
      INTEGER          IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP
*KEND.
      COMMON /UPHIOT/  THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI
      DOUBLE PRECISION THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI

      DOUBLE PRECISION AMASS2,AMASS3,AMASS4,AMASS5,AM34SQ,AM35SQ,AM34I,
     *                 ANGLEX,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
      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

      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 RMMAR(RD,2,2)
C  LOOK WHICH TYPE OF REACTION
C  0.49923 IS THE FRACTION OF PROTONS IN AIR
      IF ( RD(1) .LE. 0.49923 ) THEN
C  HIT NUCLEON IS PROTON
        AMASS2 = AMASPR
C  BRANCHING FOR COLLISION WITH PROTON
        IF     ( RD(2) .LE. 0.3 ) THEN
C  PI(0) + PI(0) + PROTON
          IQ(NP)   = 7
          IQ(NP+1) = 7
          IQ(NP+2) = 14
        ELSEIF ( RD(2) .LE. 0.6 ) 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.3 ) THEN
C  PI(0) + PI(0) + NEUTRON
          IQ(NP)   = 7
          IQ(NP+1) = 7
          IQ(NP+2) = 13
        ELSEIF ( RD(2) .LE. 0.6 ) 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**2-AMASS4**2
      AUX6   = ECM**2-AMASS5**2
      AUX7   = 0.5D0/ECM
      AUX8   = (ECM - AMASS3)**2
      BETA   = PEIG/(AMASS2+PEIG)
      GAMMA  = 2.D0*(PEIG+AMASS2)*AUX7
 230  CONTINUE
      CALL RMMAR(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**2-AMASS3**2 ))
      ROOT2  = SQRT(MAX( 0.D0, E5STAR**2-AMASS5**2 ))
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**2-AMASS3**2
      P3CM = SQRT(MAX( 0.D0, P3SQ ))
      P4SQ = E4CM**2-AMASS4**2
      P4CM = SQRT(MAX( 0.D0, P4SQ ))
      P5SQ = E5CM**2-AMASS5**2
      P5CM = SQRT(MAX( 0.D0, P5SQ ))
      COSA = (P5SQ-P3SQ-P4SQ)/(2.D0*P3CM*P4CM)
      SINA =-SQRT(MAX( 0.D0, 1.D0-COSA**2 ))
      COSB = (P4SQ-P3SQ-P5SQ)/(2.D0*P3CM*P5CM)
      SINB = SQRT(MAX( 0.D0, 1.D0-COSB**2 ))
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**2)
      CALL RMMAR(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)**2
     *                                -AMASS3**2)),1.D0)
      SINTHE = SQRT(MAX( 0.D0, 1.D0-COSTHE**2 ))
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**2 ))
      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)**2
     *                -AMASS4**2)),1.D0)
      SINTHE = SQRT(MAX( 0.0D0, 1.D0-COSTHE**2 ))
      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**2 ))
      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**2-AMASS5**2)
     *                   , 1.D0)
      SINTHE = SQRT(MAX( 0.0D0, 1.D0-COSTHE**2 ))
      CALL UPHI(3,2)
      IF ( E(NP)-AMASS5 .GT. ELCUT(1)*1000.D0 ) THEN
        IF ( W(NP) .GT. C(29) ) THEN
C  ANGLE WITH RESPECT TO X AXIS
          IF ( U(NP) .NE. 0.D0  .OR.  V(NP) .NE. 0.D0 ) THEN
            ANGLEX = -ATAN2(V(NP),U(NP))
          ELSE
            ANGLEX = 0.D0
          ENDIF
C  ADD NUCLEON TO CORSIKA STACK
          SECPAR(1)  = IQ(NP)
          SECPAR(2)  = E(NP)/AMASS5
          SECPAR(3)  = MIN( 1.D0, W(NP) )
          SECPAR(4)  = ANGLEX
          SECPAR(5)  =-Z(NP)
          SECPAR(6)  = TIM(NP)
          SECPAR(7)  = X(NP)
          SECPAR(8)  =-Y(NP)
          SECPAR(11) = 1.D0
          SECPAR(12) = 0.D0
          CALL TSTACK
        ELSE
          IF ( LLONGI ) THEN
C  CUTTED ENERGY TO LONGITUDINAL ENERGY
            DLONG(LPCTE(NP),7) = DLONG(LPCTE(NP),7)
     *                             + (E(NP)-AMASS5) * 1.D-3
          ENDIF
        ENDIF
      ELSE
        IF ( LLONGI ) THEN
C  CUTTED ENERGY TO LONGITUDINAL ENERGY
          DLONG(LPCTE(NP),7) = DLONG(LPCTE(NP),7)
     *                             + (E(NP)-AMASS5) * 1.D-3
        ENDIF
      ENDIF
C  ELIMINATE NUCLEON FROM EGS-STACK
      NP = NP-1
C  END OF RECOIL NUCLEON TREATMENT CASE

C  STORE SECOND PION TO CORSIKA STACK
      CALL PIPROP
C  STORE FIRST PION TO CORSIKA STACK
      CALL PIPROP

      RETURN
      END
*CMZ :          11/01/2002  09.25.09  by  D. HECK IK FZK KARLSRUHE
*-- 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 PIGEN2.
C
C  DESIGN  : D. HECK   IK3  FZK KARLSRUHE
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,EGSDEB.
      COMMON /EGSDEB/  JCLOCK,NCLOCK,FEGSDB
      INTEGER          JCLOCK,NCLOCK
      LOGICAL          FEGSDB
*KEEP,ELABCT.
      COMMON /ELABCT/  ELCUT
      DOUBLE PRECISION ELCUT(4)
*KEEP,LONGI.
      COMMON /LONGI/   ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP,LLONGI,FLGFIT
      DOUBLE PRECISION ADLONG(0:1170,9),AELONG(0:1170,9),
     *                 APLONG(0:1170,9),DLONG(0:1170,9),ELONG(0:1170,9),
     *                 HLONG(0:1170),PLONG(0:1170,9),SDLONG(0:1170,9),
     *                 SELONG(0:1170,9),SPLONG(0:1170,9),THSTEP,THSTPI
      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT
*KEND.
      COMMON /MUON/    PRRMMU,RMMUT2
      DOUBLE PRECISION PRRMMU,RMMUT2
*KEEP,PARPAR.
      COMMON /PARPAR/  CURPAR,SECPAR,PRMPAR,OUTPAR,C,
     *                 E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
      DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16),
     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH
      INTEGER          ITYPE,LEVL
*KEND.
      COMMON /PION/    PI0MSQ,PITHR,PICMAS,PI0MAS,AMASK0,AMASKC,AMASPR,
     *                 AMASNT
      DOUBLE PRECISION PI0MSQ,PITHR,PICMAS,PI0MAS,AMASK0,AMASKC,AMASPR,
     *                 AMASNT
*KEEP,POLAR.
      COMMON /POLAR/   POLART,POLARF
      DOUBLE PRECISION POLART,POLARF
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEEP,STACKE.
      COMMON /STACKE/  E,TIM,U,V,W,X,Y,Z,DNEAR,
     *                 ZAP,WAP,WA,
     *                 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)
     *                 ,ZAP(60),WAP(60),WA(60)
      INTEGER          IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP
*KEND.
      COMMON /UPHIOT/  THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI
      DOUBLE PRECISION THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI

      DOUBLE PRECISION AMASS,ANGLEX,CUT
      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
      ELSE
        AMASS  = PICMAS
        CUT    = ELCUT(1)*1000.D0
        POLART = 1.D0
        POLARF = 0.D0
      ENDIF
C  USE PARTICLE ONLY IF INSIDE ACCEPTANCE CONE
      IF ( W(NP) .GT. C(29) ) THEN
C  ANGLE WITH RESPECT TO X AXIS
        IF ( U(NP) .NE. 0.D0  .OR.  V(NP) .NE. 0.D0 ) THEN
          ANGLEX = -ATAN2(V(NP),U(NP))
        ELSE
          ANGLEX = 0.D0
        ENDIF
C  FILL PION COORDINATES INTO CORSIKA-STACK
        SECPAR(1)  = IQ(NP)
        SECPAR(2)  = E(NP)/AMASS
        SECPAR(3)  = MIN( 1.D0, W(NP) )
        SECPAR(4)  = ANGLEX
        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(14) = -ZAP(NP)
        SECPAR(15) = WAP(NP)
        SECPAR(16) = WA(NP)
C  ADD PION TO CORSIKA-STACK
        CALL TSTACK
      ELSE
        IF ( LLONGI ) THEN
C  CUTTED ENERGY TO LONGITUDINAL ENERGY SUMS OF HADRONS
          DLONG(LPCTE(NP),7) = DLONG(LPCTE(NP),7)+E(NP)*1.D-3
        ENDIF
      ENDIF
C  ELIMINATE PION FROM EGS-STACK
      NP = NP-1
      RETURN
      END
*CMZ :          11/01/2002  09.25.09  by  D. HECK IK FZK KARLSRUHE
*-- Author :    D. HECK IK3 FZK KARLSRUHE       28/06/99
C=======================================================================

      SUBROUTINE RHOGEN

C-----------------------------------------------------------------------
C  RHO GEN(ERATION BY PHOTONUCLEAR REACTION)
C
C  THIS SUBROUT. DESCRIBES THE PHOTONUCLEAR REACTION
C    GAMMA + NUCLEON  -----> RHO + NUCLEON    (90%)
C    GAMMA + NUCLEON  -----> OMEGA + NUCLEON  (10%)
C  HIGHER MASS VECTOR MESONS ARE OMITTED. THE RATIO FOR PRODUCTION
C  OF RHO AND OMEGA IS ASSUMED TO BE 9:1
C  LITERATURE: A. DONNACHIE & G. SHAW, ELECTROMAGNETIC INTERACTIONS OF
C                HADRONS (PLENUM PRESS, NEW YORK, 1978)
C              A. MUECKE ET AL., SOPHIA: MONTE CARLO SIMULATIONS OF
C                PHOTOHADRONIC PROCESSES IN ASTROPHYSICS,
C                COMPUT. PHYS. COMMUN. (1999) IN PRESS
C  THIS SUBROUTINE IS CALLED FROM PIGEN.
C
C  DESIGN  : D. HECK   IK3  FZK KARLSRUHE
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,EGSDEB.
      COMMON /EGSDEB/  JCLOCK,NCLOCK,FEGSDB
      INTEGER          JCLOCK,NCLOCK
      LOGICAL          FEGSDB
*KEEP,ELABCT.
      COMMON /ELABCT/  ELCUT
      DOUBLE PRECISION ELCUT(4)
*KEEP,LONGI.
      COMMON /LONGI/   ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP,LLONGI,FLGFIT
      DOUBLE PRECISION ADLONG(0:1170,9),AELONG(0:1170,9),
     *                 APLONG(0:1170,9),DLONG(0:1170,9),ELONG(0:1170,9),
     *                 HLONG(0:1170),PLONG(0:1170,9),SDLONG(0:1170,9),
     *                 SELONG(0:1170,9),SPLONG(0:1170,9),THSTEP,THSTPI
      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT
*KEEP,PAM.
      COMMON /PAM/     PAMA,SIGNUM,RESTMS
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000)
*KEEP,PARPAR.
      COMMON /PARPAR/  CURPAR,SECPAR,PRMPAR,OUTPAR,C,
     *                 E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
      DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16),
     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH
      INTEGER          ITYPE,LEVL
*KEND.
      COMMON /PION/    PI0MSQ,PITHR,PICMAS,PI0MAS,AMASK0,AMASKC,AMASPR,
     *                 AMASNT
      DOUBLE PRECISION PI0MSQ,PITHR,PICMAS,PI0MAS,AMASK0,AMASKC,AMASPR,
     *                 AMASNT
*KEEP,POLAR.
      COMMON /POLAR/   POLART,POLARF
      DOUBLE PRECISION POLART,POLARF
*KEEP,RANDPA.
      COMMON /RANDPA/  FAC,U1,U2,RD,NSEQ,ISEED,KNOR
      DOUBLE PRECISION FAC,U1,U2
      REAL             RD(3000)
      INTEGER          ISEED(103,10),NSEQ
      LOGICAL          KNOR
*KEEP,RESON.
      COMMON /RESON/   RDRES,RESRAN,IRESPAR
      REAL             RDRES(2),RESRAN(30000)
      INTEGER          IRESPAR
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEEP,REJECT.
      COMMON /REJECT/  AVNREJ,ALTMIN,ANEXP,THICKA,THICKD,CUTLN,EONCUT,
     *                 FNPRIM
      DOUBLE PRECISION AVNREJ(10),ALTMIN(10),ANEXP(10),THICKA(10),
     *                 THICKD(10),CUTLN,EONCUT
      LOGICAL          FNPRIM
*KEEP,STACKE.
      COMMON /STACKE/  E,TIM,U,V,W,X,Y,Z,DNEAR,
     *                 ZAP,WAP,WA,
     *                 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)
     *                 ,ZAP(60),WAP(60),WA(60)
      INTEGER          IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP
*KEND.
      COMMON /UPHIOT/  THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI
      DOUBLE PRECISION THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI

      DOUBLE PRECISION AMASS2,AMAS2I,AMAS2S,AMASS3,AMASS4,AMOM3,AMOM4,
     *                 ANGLEX,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
      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

      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 RMMAR(RD,3,2)
C  0.49923 IS THE FRACTION OF PROTONS IN AIR
      IF ( RD(1) .LE. 0.49923 ) THEN
C  HIT NUCLEON IS PROTON
        IQ(NP+1) = 14
        AMASS2 = AMASPR
      ELSE
C  HIT NUCLEON IS NEUTRON
        IQ(NP+1) = 13
        AMASS2 = AMASNT
      ENDIF
      AMAS2I = 1.D0/AMASS2
      AMAS2S = AMASS2**2
      IF ( RD(2) .LT. 0.1 ) THEN
C  PRESENTLY WE ARE ONLY TAKING INTO ACCOUNT RHO AND OMEGA MESON.
C  PHI MESON IS NEGLECTED
C  10% CHANCE FOR  OMEGA MESON
        IQ(NP) = 50
      ELSE
C  GENERATED MESON IS  RHO(0)
        IQ(NP) = 51
      ENDIF
C  NOTE: THE ENERGIES IN EGS ARE IN MEV, IN CORSIKA IN GEV
      AMASS3 = PAMA(IQ(NP))*1.D3
      AMASS4 = PAMA(IQ(NP+1))*1.D3
C  TOTAL LABORATORY ENERGY AND ITS INVERSE
      W0     = PEIG+AMASS2
      W0I    = 1.D0/W0
C  TOTAL.C.M. ENERGY AND INVERSE OF TOTAL C.M.ENERGY
      W0S    = SQRT(AMASS2*(AMASS2+2.D0*PEIG))
      W0SI   = 1.D0/W0S
C  THRESHOLD ENERGY
      ETH    = 0.5D0*((AMASS3+AMASS4)**2-AMAS2S)*AMAS2I
C  BETA, GAMMA, ESQ, BRATIO, G3 ARE AUXILIARY QUANTITIES
      BETA   = PEIG*W0I
      GAMMA  = W0*W0SI
      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). ANGULAR DISTRIBUTION
C  IS ACCORDING  D(SIGMA)/DT = EXP( B_DIFFRACTIVE * T)
C  WITH       B_DIFFRACTIVE = 8 GEV^-2 = 8*10-6 [MEV^-2]
      BDIFF = 8.D-6
C  AUXILIAR QUANTITIES AUX3, E2, E4, PCM2, PCM4
      AUX3  = 0.5D0 * AMASS3**2 * W0SI
      E2    = 0.5D0 * (W0S + AMAS2S * W0SI)
      E4    = E2 - AUX3
      PCM2  = SQRT(E2**2 - AMAS2S)
      PCM4  = SQRT(E4**2 - AMAS2S)
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.001),SNGL(E4*0.001),SNGL(PCM2*0.001),
     *    SNGL(PCM4*0.001),SNGL(TMIN*0.001),SNGL(TMAX*0.001)
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=',
     *       RD(3),SNGL(T*0.001),SNGL(PLNG3*0.001),SNGL(PEOM*0.001)
C  ENERGY OF OUTGOING MESON IN STACK POSITION NP
      E(NP) = PEOM
C  MOMENTUM OF OUTGOING MESON = 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**2-AMASS3**2 ))
      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.0D0, 1.D0-COSTHE**2 ))
      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**2-AMASS4**2)
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.0D0, 1.D0-COSTHE**2 ))
        CALL UPHI(3,2)
        IF ( W(NP) .GT. C(29) ) THEN
C  ANGLE WITH RESPECT TO X AXIS
          IF ( U(NP) .NE. 0.D0  .OR.  V(NP) .NE. 0.D0 ) THEN
            ANGLEX = -ATAN2(V(NP),U(NP))
          ELSE
            ANGLEX = 0.D0
          ENDIF
C  ADD NUCLEON TO CORSIKA STACK
          SECPAR(1)  = IQ(NP)
          SECPAR(2)  = E(NP)/AMASS4
          SECPAR(3)  = MIN( 1.D0, W(NP) )
          SECPAR(4)  = ANGLEX
          SECPAR(5)  = -Z(NP)
          SECPAR(6)  = TIM(NP)
          SECPAR(7)  = X(NP)
          SECPAR(8)  = -Y(NP)
          SECPAR(11) = 1.D0
          SECPAR(12) = 0.D0
          CALL TSTACK
        ELSE
          IF ( LLONGI ) THEN
C  CUTTED ENERGY TO LONGITUDINAL ENERGY SUMS TO NUCLEON
             DLONG(LPCTE(NP),7) = DLONG(LPCTE(NP),7)
     *                             + (E(NP)-AMASS4) * 1.D-3
          ENDIF
        ENDIF
C  ELIMINATE NUCLEON FROM EGS-STACK
        NP = NP-1
        IF ( NP .LE. 0 ) RETURN
      ELSE
        IF ( LLONGI ) THEN
C  CUTTED ENERGY TO LONGITUDINAL ENERGY SUMS TO NUCLEON
           DLONG(LPCTE(NP),7) = DLONG(LPCTE(NP),7)
     *                             + (E(NP)-AMASS4) * 1.D-3
        ENDIF
C  ELIMINATE NUCLEON FROM EGS-STACK
        NP = NP-1
C  END OF RECOIL NUCLEON TREATMENT CASE
      ENDIF
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      IF ( IQ(NP) .GE. 50 ) THEN
C  NOW TREAT THE VECTOR MESON
        IF ( W(NP) .GT. C(29) ) THEN
C  ANGLE WITH RESPECT TO X AXIS
          IF ( U(NP) .NE. 0.D0  .OR.  V(NP) .NE. 0.D0 ) THEN
            ANGLEX = -ATAN2(V(NP),U(NP))
          ELSE
            ANGLEX = 0.D0
          ENDIF
          IF     ( IQ(NP) .EQ. 50 ) THEN
C  ADD OMEGA MESON TO CORSIKA-STACK (TO BE TREATED IN RESDEC)
            SECPAR(1)  = IQ(NP)
            SECPAR(2)  = E(NP)/AMASS3
            SECPAR(3)  = MIN( 1.D0, W(NP) )
            SECPAR(4)  = ANGLEX
            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(14) = -ZAP(NP)
            SECPAR(15) = WAP(NP)
            SECPAR(16) = WA(NP)
            IRESPAR    = IRESPAR + 1
            IF ( IRESPAR .GE. 30000 ) THEN
              WRITE(MONIOU,*)
     *                   'RHOGEN: STACK OF RESDEC RANDOM NUMBERS FULL'
              IRESPAR = 29999
            ENDIF
C  STORE DUMMY RANDOM NUMBER FOR TREATMENT OF OMEGA0 IN RESDEC
            RESRAN(IRESPAR) = 0.5
            CALL TSTACK
C  FINALLY OMEGA WILL BE TREATED IN OMEGDC (OMEGA DECAY ROUTINE)
C  WITH CORRECT ANGULAR DISTRIBUTION
*           CALL OMEGDC
          ELSEIF ( IQ(NP) .EQ. 51 ) THEN
C  FILL VECTOR MESON COORDINATES INTO CORSIKA-STACK
C  (CURPAR HAS BEEN SAVED IN PIGEN)
            ITYPE      = IQ(NP)
            CURPAR(1)  = IQ(NP)
            CURPAR(2)  = E(NP)/AMASS3
            CURPAR(3)  = MIN( 1.D0, W(NP) )
            CURPAR(4)  = ANGLEX
            CURPAR(5)  = -Z(NP)
            CURPAR(6)  = TIM(NP)
            CURPAR(7)  = X(NP)
            CURPAR(8)  = -Y(NP)
            CURPAR(9)  = IGEN(NP)
            CURPAR(10) = -Z(NP)
            CURPAR(11) = POLART
            CURPAR(12) = POLARF
            CURPAR(14) = -ZAP(NP)
            CURPAR(15) = WAP(NP)
            CURPAR(16) = WA(NP)
C  RHO(0) DECAYS WITH DIPOLE CHARACTERISTIC IN RHO0DC

            CALL RHO0DC
          ELSE
            WRITE(MONIOU,*) 'RHOGEN: WRONG PARTICLE CODE=',IQ(NP)
            STOP
          ENDIF
        ELSE
          IF ( LLONGI ) THEN
C  CUTTED ENERGY TO LONGITUDINAL ENERGY SUMS OF HADRONS
            DLONG(LPCTE(NP),7) = DLONG(LPCTE(NP),7)+E(NP)*1.D-3
          ENDIF
        ENDIF
C  ELIMINATE VECTOR MESON FROM EGS-STACK
        NP = NP-1
      ENDIF

      RETURN
      END
*CMZ :          18/09/2001  13.38.55  by  D. HECK IK FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
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
C  DESIGN  : D. HECK   IK3  FZK KARLSRUHE
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,EGSDEB.
      COMMON /EGSDEB/  JCLOCK,NCLOCK,FEGSDB
      INTEGER          JCLOCK,NCLOCK
      LOGICAL          FEGSDB
*KEND.
      COMMON /MISC/    DUNIT,RHOR,KMPI,KMPO,NOSCAT,MED,IRAYLR
      DOUBLE PRECISION DUNIT,RHOR(6)
      INTEGER          KMPI,KMPO,NOSCAT,MED(6),IRAYLR(6)
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEEP,STACKE.
      COMMON /STACKE/  E,TIM,U,V,W,X,Y,Z,DNEAR,
     *                 ZAP,WAP,WA,
     *                 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)
     *                 ,ZAP(60),WAP(60),WA(60)
      INTEGER          IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP
*KEND.

      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
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         PHOTON
C                  =  2         POSITRON E (+)
C                  =  3         ELECTRON E (-)
C                  =  5         POSITIVE MUON (+)
C                  =  6         NEGATIVE MUON (-)
C                  =  7         NEUTRAL  PION (0)
C                  =  8         POSITIVE PION (+)
C                  =  9         NEGATIVE PION (-)
C                  =  OTHER VALUE, JUMP TO ERROR MESSAGE

      GOTO (270,280,280,290, 300,300,300,300,300) (IQ(NP))
C  IQ OUT OF RANGE?
 290  WRITE(KMPO,320) IQ(NP)
 320  FORMAT(' SHOWER: PARTICLE TYPE ',I5,' NOT IDENTIFIED')
      CALL AUSGB2
      NP = NP-1
      GOTO 262

C  PARTICLE IS MUON OR PION
 300  CALL MPPROP
      GOTO 262

C  PARTICLE IS PHOTON
 270  CALL PHOTON(IRCODE)
C  PHOTON DISCARDED ?
      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. 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

      RETURN
      END
*CMZ :          18/12/2001  10.00.42  by  D. HECK IK FZK KARLSRUHE
*-- 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 NAD 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
*KEEP,EPCONT.
      COMMON /EPCONT/  EDEP,RATIO,TSTEP,TUSTEP,USTEP,TVSTEP,VSTEP,
     *                 RHOFAC,EOLD,ENEW,EKE,ELKE,BETA2,GLE,TSCAT,
     *                 IDISC,IROLD,IRNEW
      DOUBLE PRECISION EDEP,RATIO,TSTEP,TUSTEP,USTEP,TVSTEP,VSTEP,
     *                 RHOFAC,EOLD,ENEW, EKE,ELKE,BETA2,GLE,TSCAT
      INTEGER          IDISC,IROLD,IRNEW

*KEEP,RANDPA.
      COMMON /RANDPA/  FAC,U1,U2,RD,NSEQ,ISEED,KNOR
      DOUBLE PRECISION FAC,U1,U2
      REAL             RD(3000)
      INTEGER          ISEED(103,10),NSEQ
      LOGICAL          KNOR
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEEP,STACKE.
      COMMON /STACKE/  E,TIM,U,V,W,X,Y,Z,DNEAR,
     *                 ZAP,WAP,WA,
     *                 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)
     *                 ,ZAP(60),WAP(60),WA(60)
      INTEGER          IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP
*KEND.
      COMMON /UPHIOT/  THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI
      DOUBLE PRECISION THETA,SINTHE,COSTHE,SINPHI,COSPHI,PI,TWOPI

      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
 1090 CONTINUE
      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 CALL RMMAR(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 IF ( LVL .EQ. 2 ) GOTO 1100
      IF ( LVL .EQ. 3 ) GOTO 1110
 1120 A = U(NP)
      B = V(NP)
      C = W(NP)
      GOTO 1130

 1110 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 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)
      ZAP(NP)   = ZAP(NP-1)
      WAP(NP)   = WAP(NP-1)
      WA(NP)    = WA(NP-1)
 1130 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
*CMZ :          28/02/2002  10.19.53  by  D. HECK IK FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
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
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEND.

      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
*CMZ :          23/11/2000  10.59.37  by  D. HECK IK3 FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
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
*KEEP,BUFFS.
      COMMON /BUFFS/   RUNH,RUNE,EVTH,EVTE,DATAB,ARRAYLONG,LH
      INTEGER          MAXBUF,MAXLEN
      PARAMETER        (MAXLEN=16)
      PARAMETER        (MAXBUF=39*7)
      REAL             RUNH(MAXBUF),EVTH(MAXBUF),EVTE(MAXBUF),
     *                 RUNE(MAXBUF),DATAB(MAXBUF),ARRAYLONG(MAXBUF)
      INTEGER          LH
      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)
*KEEP,ELABCT.
      COMMON /ELABCT/  ELCUT
      DOUBLE PRECISION ELCUT(4)
*KEEP,NKGI.
      COMMON /NKGI/    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)
*KEEP,NKGS.
      COMMON /NKGS/    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)
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEND.

      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/PHOTON THRESHOLD AT ',F10.5,' /',F10.5,' GEV')

C  LOOP OVER ALL DISTANCES WHERE ELECTRON NUMBER IS CALCULATED
      DO 302  K = 1,2
        IF ( OBSATI(K) .GE. 0.D0 ) THEN
          DO 301  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)
 301      CONTINUE
        ENDIF
 302  CONTINUE

C  CALCULATE LONGITUDINAL SHOWER DEVELOPMENT
      DO 311  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)
 311  CONTINUE

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',7X,'AGE'
     *  /'  NO. ',2X,'  G/CM**2',8X,'    CM'/
     *        (' ',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 50  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
  50    CONTINUE

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

      RETURN
      END
*CMZ :          14/06/2000  14.40.12  by  D. HECK IK3 FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
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
      SAVE
C-----------------------------------------------------------------------

C  CALCULATE CORRESPONDING FUNCTION VALUE IN INTERVAL 1 ... 2
      Y   = MOD(Z,1.D0)
      YY  = Y + 1.D0

C  PARAMETRIZATION 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
        DO  1  U = YY, Z-1.D0, 1.D0
          GAM = GAM * U
 1      CONTINUE
      ENDIF

      RETURN
      END
*CMZ :          18/10/2000  09.15.11  by  D. HECK IK3 FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
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
*KEEP,BUFFS.
      COMMON /BUFFS/   RUNH,RUNE,EVTH,EVTE,DATAB,ARRAYLONG,LH
      INTEGER          MAXBUF,MAXLEN
      PARAMETER        (MAXLEN=16)
      PARAMETER        (MAXBUF=39*7)
      REAL             RUNH(MAXBUF),EVTH(MAXBUF),EVTE(MAXBUF),
     *                 RUNE(MAXBUF),DATAB(MAXBUF),ARRAYLONG(MAXBUF)
      INTEGER          LH
      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)
*KEEP,NKGI.
      COMMON /NKGI/    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)
*KEEP,OBSPAR.
      COMMON /OBSPAR/  OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP,
     *                 THETPR,PHIPR,
     *                 VUECON,
     *                 NOBSLV
      DOUBLE PRECISION OBSLEV(10),THCKOB(10),XOFF(10),YOFF(10),
     *                 HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2)
      DOUBLE PRECISION VUECON(2)
      INTEGER          NOBSLV
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEND.

      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 3333  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)
 3333 CONTINUE
C  CLEAR ARRAY FOR LATERAL ELECTRON DISTR. (AVERAGE OVER ALL SHOWERS)
      DO 45  K = 1,2
      DO 45  I = -10,10
        DLAX (I,K) = 0.D0
        DLAY (I,K) = 0.D0
        DLAXY(I,K) = 0.D0
        DLAYX(I,K) = 0.D0
  45  CONTINUE
C  CLEAR ARRAY FOR AGE PARAMETER CALCULATION (AVERAGE OVER ALL SHOWERS)
      DO 17  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
  17  CONTINUE

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 111  IL = 1,IALT(1)-1
        TLEV  (IL) = 100.D0 * IL
        TLEVCM(IL) = HEIGH(TLEV(IL))
 111  CONTINUE
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
*CMZ :          23/11/2000  10.59.37  by  D. HECK IK3 FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
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
*KEEP,ELABCT.
      COMMON /ELABCT/  ELCUT
      DOUBLE PRECISION ELCUT(4)
*KEEP,NKGI.
      COMMON /NKGI/    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)
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEND.

      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/PHOTON THRESHOLDS AT ',F10.5,' /',F10.5,' GEV'//
     *   ' LEVEL  THICKNESS   HEIGHT         <EL NR>        DEV<EL>',
     *   '   <LOG(EL NR)>  DEV<LOG(E)>      <AGE>  DEV<AGE>'/
     *   '  NO.   (G/CM**2)     (M) ' )

C  NORMALIZE AVERAGE ELECTRON DENSITIES
      RISH = 1.D0 / ISHW
      DO 161  K = 1,2
        IF ( OBSATI(K) .GE. 0.D0 ) THEN
          DO 162  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
  162     CONTINUE
        ENDIF
  161 CONTINUE

      DO 16  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.01,
     *                       SELEC,ZEC,SELCLG,ZECLG,ATH,ZSE
  219   FORMAT (' ',I4,F10.0,F11.2,1X,2F15.0,3X,2F12.5,F13.3,F9.3)
  16  CONTINUE

      DO 520  K = 1,2
        IF ( OBSATI(K) .LT. 0.D0 ) GOTO 520
C  DETERMINE LOCAL AGE PARAMETER
        DO 50  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
  50    CONTINUE

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
*CMZ :          07/01/2002  13.20.15  by  D. HECK IK FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
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/PHOTON GENERATING A SUBSHOWER
C            NEGATIVE FOR SUBSHOWERS TO BE SUBTRACTED AFTER
C            PHOTONUCLEAR REACTION
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,CONSTA.
      COMMON /CONSTA/  PI,PI2,OB3,TB3,ENEPER
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER
*KEEP,ELABCT.
      COMMON /ELABCT/  ELCUT
      DOUBLE PRECISION ELCUT(4)
*KEEP,NKGI.
      COMMON /NKGI/    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)
*KEEP,NKGS.
      COMMON /NKGS/    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)
*KEEP,OBSPAR.
      COMMON /OBSPAR/  OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP,
     *                 THETPR,PHIPR,
     *                 VUECON,
     *                 NOBSLV
      DOUBLE PRECISION OBSLEV(10),THCKOB(10),XOFF(10),YOFF(10),
     *                 HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2)
      DOUBLE PRECISION VUECON(2)
      INTEGER          NOBSLV
*KEEP,PARPAR.
      COMMON /PARPAR/  CURPAR,SECPAR,PRMPAR,OUTPAR,C,
     *                 E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
      DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16),
     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH
      INTEGER          ITYPE,LEVL
*KEEP,PARPAE.
      DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM
     *                 ,WEIGHT
     *                 ,HAPP,COSTAP,COSTEA
      EQUIVALENCE      (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE),
     *                 (CURPAR(4), PHI   ), (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)
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEND.

      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
CDH   DATA             X0 / 37.1D0 /, GRCUT / 0.1D0 /, ECRI / 0.082D0 /
CDH   DATA             ECR2 / 0.0328D0 /
      DATA             X0 / 36.66D0 /, GRCUT / 0.1D0 /, ECRI / 0.086D0 /
      DATA             ECR2 / 0.0344D0 /
C-----------------------------------------------------------------------

      IF (DEBUG) WRITE(MDEBUG,*)'NKG   : ',SNGL(SECPAR(1)),SNGL(ENERN)

C  CHECK WETHER SUBSHOWER IS SUBTRACTED
      IF ( ENERN .GE. 0.D0 ) THEN
        SIGNE = +1.D0
      ELSE
        ENERN = -ENERN
        SIGNE = -1.D0
      ENDIF

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(3) .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 PHOTON-AXIS) IN RADIATION LENGTHS
        XMOL  = (TLEV(IL) - THICKP) / ( X0 * SECPAR(3) )
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(1) .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 * 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 PHOTON 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    = SIN( SECPAR(4) )
        BS    = COS( SECPAR(4) )
        TEX   = DISTL * SQRT( 1.D0 - SECPAR(3)**2 ) / SECPAR(3)
C  DISTANCE TO THE CENTER OF THE CASCADE (IN CM)
        XS    = SECPAR(7) + TEX * BS - XOFF(NOBSLV+1-IOL)
        YS    = SECPAR(8) + TEX * AS - 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( SQRT((DISX(M)-XS)**2 + YS**2), 1.D0 )
          CZX (M,IOL) = CZX (M,IOL) + CSGA * YM**SS2 * (YM+1.D0)**SS45
C  Y DIRECTION
          YM  = SMRM * MAX( SQRT(XS**2 + (DISY(M)-YS)**2), 1.D0 )
          CZY (M,IOL) = CZY (M,IOL) + CSGA * YM**SS2 * (YM+1.D0)**SS45
C  XY DIRECTION
          YM  = SMRM *
     *       MAX( SQRT((DISXY(M,1)-XS)**2 + (DISXY(M,2)-YS)**2), 1.D0 )
          CZXY(M,IOL) = CZXY(M,IOL) + CSGA * YM**SS2 * (YM+1.D0)**SS45
C  YX DIRECTION
          YM  = SMRM *
     *       MAX( SQRT((DISYX(M,1)-XS)**2 + (DISYX(M,2)-YS)**2), 1.D0 )
          CZYX(M,IOL) = CZYX(M,IOL) + CSGA * YM**SS2 * (YM+1.D0)**SS45
  171   CONTINUE

   14 CONTINUE

      RETURN
      END
*CMZ :          18/10/2000  09.15.11  by  D. HECK IK3 FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
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
*KEEP,NKGS.
      COMMON /NKGS/    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)
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEND.

      INTEGER          I,K
      SAVE
C-----------------------------------------------------------------------

      IF ( DEBUG ) WRITE(MDEBUG,*) 'STANKG:'

C  CLEAR ARRAYS FOR AGE PARAMETER CALCULATION FOR EACH SHOWER
      DO 17  I = 1,10
        SAH(I) = 0.D0
        SL (I) = 0.D0
        ZNE(I) = 0.D0
  17  CONTINUE
C  CLEAR LATERAL ELECTRON DISTRIBUTION COUNTERS FOR EACH SHOWER
      DO 45  K = 1,2
      DO 45  I = -10,10
        CZX (I,K) = 0.D0
        CZY (I,K) = 0.D0
        CZXY(I,K) = 0.D0
        CZYX(I,K) = 0.D0
  45  CONTINUE

      RETURN
      END
*CMZ :          28/02/2002  13.08.20  by  D. HECK IK FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
C=======================================================================

      SUBROUTINE CGHEI

C-----------------------------------------------------------------------
C  C(ORSIKA) GHE(ISHA) I(NTERFACE)
C
C  MAIN STEERING SUBROUT. FOR HADRON PACKAGE GHEISHA ***
C  THIS SUBROUTINE IS CALLED FROM NUCINT.
C
C  ORIGIN  : F.CARMINATI, H.FESEFELDT (SUBROUT. GHESIG)
C  REDESIGN: P. GABRIEL IK1  FZK KARLSRUHE
C-----------------------------------------------------------------------

*KEEP,CGCOMP.
      PARAMETER (KK=3)
      COMMON/CGCOMP/ ACOMP,ZCOMP,WCOMP
      REAL           ACOMP(KK),ZCOMP(KK),WCOMP(KK)
*KEEP,ELABCT.
      COMMON /ELABCT/  ELCUT
      DOUBLE PRECISION ELCUT(4)
*KEEP,ELADPM.
      COMMON /ELADPM/  ELMEAN,ELMEAA,IELDPM,IELDPA
      DOUBLE PRECISION ELMEAN(40),ELMEAA(40)
      INTEGER          IELDPM(40,13),IELDPA(40,13)
*KEEP,ELASTY.
      COMMON /ELASTY/  ELAST
      DOUBLE PRECISION ELAST
*KEEP,GENER.
      COMMON /GENER/   GEN,ALEVEL
      DOUBLE PRECISION GEN,ALEVEL
*KEEP,ISTA.
      COMMON /ISTA/    IFINET,IFINNU,IFINKA,IFINPI,IFINHY
      INTEGER          IFINET,IFINNU,IFINKA,IFINPI,IFINHY
*KEEP,LONGI.
      COMMON /LONGI/   ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP,LLONGI,FLGFIT
      DOUBLE PRECISION ADLONG(0:1170,9),AELONG(0:1170,9),
     *                 APLONG(0:1170,9),DLONG(0:1170,9),ELONG(0:1170,9),
     *                 HLONG(0:1170),PLONG(0:1170,9),SDLONG(0:1170,9),
     *                 SELONG(0:1170,9),SPLONG(0:1170,9),THSTEP,THSTPI
      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT
*KEEP,MULT.
      COMMON /MULT/    EKINL,MSMM,MULTMA,MULTOT
      DOUBLE PRECISION EKINL
      INTEGER          MSMM,MULTMA(40,13),MULTOT(40,13)
*KEEP,PAM.
      COMMON /PAM/     PAMA,SIGNUM,RESTMS
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000)
*KEEP,PARPAR.
      COMMON /PARPAR/  CURPAR,SECPAR,PRMPAR,OUTPAR,C,
     *                 E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
      DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16),
     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH
      INTEGER          ITYPE,LEVL
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEEP,SIGM.
      COMMON /SIGM/    SIGMA,SIGANN,SIGAIR,FRACTN,FRCTNO
      DOUBLE PRECISION SIGMA,SIGANN,SIGAIR,FRACTN,FRCTNO
*KEND.

      DOUBLE PRECISION ELASTI,ELABOR,ETOT,PLX,PLY,PLZ,PLSQ,PLTOT,RMASSK

      COMMON/GSECTI/   AIEL(20),AIIN(20),AIFI(20),AICA(20),ALAM,K0FLAG
      INTEGER          K0FLAG
      REAL             AIEL,AIIN,AIFI,AICA,ALAM

C --- GHEISHA COMMONS ---
      PARAMETER (MXGKGH=100)
      PARAMETER (MXGKPV=MXGKGH)
      COMMON /VECUTY/ PV(10,MXGKPV)

      COMMON/CONSTS/ PI,TWPI,PIBTW,MP,MPI,MMU,MEL,MKCH,MK0,SMP,SMPI,
     $               SMU,CT,CTKCH,CTK0,
     $               ML0,MSP,MS0,MSM,MX0,MXM,CTL0,CTSP,CTSM,CTX0,CTXM,
     $               RMASS(35),RCHARG(35)

                     REAL MP,MPI,MMU,MEL,MKCH,MK0,
     *                    ML0,MSP,MS0,MSM,MX0,MXM

      PARAMETER (MXEVEN=12*MXGKGH)
      COMMON/EVENT / NSIZE,NCUR,NEXT,NTOT,EVE(MXEVEN)

      COMMON/PRNTFL/INBCD,NEWBCD,INBIN,NEWBIN,NPEVT,NEVTP,LPRT,NPRT(10)
                    LOGICAL LPRT,NPRT


C --- "NEVENT" CHANGED TO "KEVENT" IN COMMON /CURPAR/ DUE TO CLASH ---
C --- WITH VARIABLE "NEVENT" IN GEANT COMMON ---

      PARAMETER (MXGKCU=MXGKGH)
      COMMON /CURPAR/ WEIGHT(10),DDELTN,IFILE,IRUN,NEVT,KEVENT,SHFLAG,
     $                ITHST,ITTOT,ITLST,IFRND,TOFCUT,CMOM(5),CENG(5),
     $                RS,S,ENP(10),NP,NM,NN,NR,NO,NZ,IPA(MXGKCU),
     $                ATNO2,ZNO2

C --- "IPART" CHANGED TO "KPART" IN COMMON /RESULT/ DUE TO CLASH ---
C --- WITH VARIABLE "IPART" IN GEANT COMMON ---

      COMMON /RESULT/ XEND,YEND,ZEND,RCA,RCE,AMAS,NCH,TOF,PX,PY,PZ,
     $                USERW,INTCT,P,EN,EK,AMASQ,DELTN,ITK,NTK,KPART,IND,
     $                LCALO,ICEL,SINL,COSL,SINP,COSP,
     $                XOLD,YOLD,ZOLD,POLD,PXOLD,PYOLD,PZOLD,
     $                XSCAT,YSCAT,ZSCAT,PSCAT,PXSCAT,PYSCAT,PZSCAT
                      REAL NCH,INTCT

C --- "ABSL(21)" CHANGED TO "ABSLTH(21)" IN COMMON /MAT/ DUE TO CLASH ---
C --- WITH VARIABLE "ABSL" IN GEANT COMMON ---

      COMMON /MAT/ LMAT,
     $             DEN(21),RADLTH(21),ATNO(21),ZNO(21),ABSLTH(21),
     $             CDEN(21),MDEN(21),X0DEN(21),X1DEN(21),RION(21),
     $             MATID(21),MATID1(21,24),PARMAT(21,10),
     $             IFRAT,IFRAC(21),FRAC1(21,10),DEN1(21,10),
     $             ATNO1(21,10),ZNO1(21,10)

*     DIMENSION IPELOS(35)
      REAL EMAX,EEESQ

      DIMENSION RNDM(1)

C --- DIMENSION STMTS. FOR GEANT/GHEISHA PARTICLE CODE CONVERSIONS ---
C --- KIPART(I)=GHEISHA CODE CORRESPONDING TO GEANT   CODE I ---
C --- IKPART(I)=GEANT   CODE CORRESPONDING TO GHEISHA CODE I ---

      DIMENSION KIPART(48),IKPART(35)
C --- ANGLES FOR NEW COUPLING WITH CORSIKA D. HECK DEC. 2000
      DOUBLE PRECISION PHIRAN,PHIG,THETG

      SAVE

C --- DATA STMTS. FOR GEANT/GHEISHA PARTICLE CODE CONVERSIONS ---
C --- KIPART(I)=GHEISHA CODE CORRESPONDING TO GEANT   CODE I ---
C --- IKPART(I)=GEANT   CODE CORRESPONDING TO GHEISHA CODE I ---

      DATA KIPART/
     $               1,   3,   4,   2,   5,   6,   8,   7,
     $               9,  12,  10,  13,  16,  14,  15,  11,
     $              35,  18,  20,  21,  22,  26,  27,  33,
     $              17,  19,  23,  24,  25,  28,  29,  34,
     $              35,  35,  35,  35,  35,  35,  35,  35,
     $              35,  35,  35,  35,  30,  31,  32,  35/

      DATA IKPART/
     $               1,   4,   2,   3,   5,   6,   8,   7,
     $               9,  11,  16,  10,  12,  14,  15,  13,
     $              25,  18,  26,  19,  20,  21,  27,  28,
     $              29,  22,  23,  30,  31,  45,  46,  47,
     $              24,  32,  48/


C --- DENOTE STABLE PARTICLES ACCORDING TO GHEISHA CODE ---
C --- STABLE : GAMMA, NEUTRINO, ELECTRON, PROTON AND HEAVY FRAGMENTS ---
C --- WHEN STOPPING THESE PARTICLES ONLY LOOSE THEIR KINETIC ENERGY ---
*     DATA IPELOS/
*    $             1,   1,   0,   1,   0,   0,   0,   0,
*    $             0,   0,   0,   0,   0,   1,   0,   0,
*    $             0,   0,   0,   0,   0,   0,   0,   0,
*    $             0,   0,   0,   0,   0,   1,   1,   1,
*    $             0,   0,   1/

C --- LOWERBOUND OF KINETIC ENERGY BIN IN N CROSS-SECTION TABLES ---
      DATA TEKLOW /0.0001/

C --- KINETIC ENERGY TO SWITCH FROM "CASN" TO "GNSLWD" FOR N CASCADE ---
      DATA SWTEKN /0.05/
C-----------------------------------------------------------------------
      IF ( DEBUG ) WRITE(MDEBUG,445) (CURPAR(I),I=1,9)
 445  FORMAT(' CGHEI : CURPAR=',1P,9E10.3)

      IF ( DEBUG ) WRITE(MDEBUG,*)
     *                    'CGHEI : E = ',CURPAR(2)*PAMA(NINT(CURPAR(1)))

C --- DEFINE PARTICLE TYPE
      IF     ( ITYPE .LE.  48 ) THEN
         IPART = ITYPE
      ELSEIF ( ITYPE .EQ. 201 ) THEN
         IPART = 45
      ELSEIF ( ITYPE .EQ. 301 ) THEN
         IPART = 46
      ELSEIF ( ITYPE .EQ. 402 ) THEN
         IPART = 47
      ELSE
        WRITE(MONIOU,444) (CURPAR(I),I=1,9)
 444    FORMAT(' CGHEI : CURPAR=',1P,9E10.3)
         WRITE(MONIOU,7795) ITYPE
 7795    FORMAT (//,' *CGHEI*  ILLEGAL PARTICLE TYPE OCCURS =',I5)
         IPART = 48
      ENDIF

      NETEST=IKPART(KPART)
      IF ( NETEST .EQ. IPART ) GOTO 9004

      WRITE(MONIOU,8881) IPART,KPART
 8881 FORMAT(' *CGHEI* IPART,KPART = ',2(I3,1X)/
     $ ' *CGHEI* ======> PARTICLE TYPES DO NOT MATCH <=======')
      STOP

 9004 CONTINUE
      KPART  = KIPART(IPART)
      KKPART = KPART

C --- TRANSPORT THE TRACK NUMBER TO GHEISHA AND INITIALIZE SOME NUMBERS
C --- NTK=ITRA   ITRA = CURRENT TRACK NUMBER IN GEANT (GCKINE)
      NTK   = 0
      INTCT = 0.0
      NEXT  = 1
      NTOT  = 0
      INT   = 0
      TOF   = 0.0

C --- RESET ITYPE
      SECPAR(1) = 0.

C --- FILL RESULT COMMON FOR THIS TRACK WITH CORSIKA VALUES ---

      AMAS  = RMASS(KPART)
      NCH   = RCHARG(KPART)
  107 XEND  = CURPAR(7)
      YEND  = CURPAR(8)
      ZEND  = CURPAR(5)
      USERW = 0.0

      AMASQ=AMAS*AMAS
      EN = CURPAR(2) * ABS(AMAS)
      EK = ABS ( EN - ABS(AMAS) )
      ENOLD = EN
      EMAX  = 0.
      ETOT  = 0.D0
      P  = SQRT ( EN*EN - AMASQ )
      ELABOR = EN

C  OLD COUPLING OF GHEISHA WITH CORSIKA
C     SINL = -CURPAR(3)
C     PHI  = CURPAR(4)
C     SINP = SIN(PHI)
C     COSP = COS(PHI)
C     COSL = SQRT ( ABS(1.-SINL**2) )
C  NEW COUPLING WITH CORSIKA  D. HECK  DEC. 2000
C  WE ASSUME MOVEMENT ALONG Z AXIS. AFTER COLLISION WE ROTATE THE
C  INTERACTION PLANE AROUND Z AT RANDOM TO ELIMINATE PREFERENCES OF PHI
      SINL = -1.
      COSL =  0.
      SINP =  0.
      COSP =  1.
      PX = COSL * COSP
      PY = COSL * SINP
      PZ = SINL

      CALL GRNDM(RNDM,1)
      PHIRAN = RNDM(1) * TWPI

C --- SET GHEISHA INDEX FOR THE CURRENT MEDIUM ALWAYS TO 1 ---
      IND = 1

C --- TRANSFER GLOBAL MATERIAL CONSTANTS FOR CURRENT MEDIUM ---
C --- DETAILED DATA FOR COMPOUNDS IS OBTAINED VIA SUBROUT. COMPO ---
      ATNO(IND+1) = 14.56
      ZNO(IND+1)  =  7.265
      DEN(IND+1)  =  0.0
      RADLTH(IND+1)= 0.0
      ABSLTH(IND+1)= 0.0

C --- SETUP PARMAT FOR PHYSICS STEERING ---
      PARMAT(IND+1,10)=0.0

  5   CONTINUE

C --- INDICATE LIGHT (<= PI) AND HEAVY PARTICLES (HISTORICALLY) ---
C --- CALIM CODE ---
      J = 2
      TEST = RMASS(7)-0.001
      IF ( ABS(AMAS) .LT. TEST ) J=1

C *** DIVISION INTO VARIOUS INTERACTION CHANNELS DENOTED BY "INT" ***
C THE CONVENTION FOR "INT" IS THE FOLLOWING

C INT  = -1 REACTION CROSS-SECTIONS NOT YET TABULATED/PROGRAMMED
C      =  0 NO INTERACTION
C      =  1 ELEASTIC SCATTERING
C      =  2 INELASTIC SCATTERING
C      =  3 NUCLEAR FISSION WITH INELEASTIC SCATTERING
C      =  4 NEUTRON CAPTURE
C INT  =  3, 4  SHOULD BE DELETED FOR AIR TARGET

C --- INTACT CODE ---
      ALAM1 = 0.0
      CALL GRNDM(RNDM,1)
      RAT   = RNDM(1)*ALAM
      ATNO2 = 14.56
      ZNO2  = 7.265

      DO 6  K = 1,KK
      ATNO2 = ACOMP(K)
      ZNO2  = ZCOMP(K)

C --- TRY FOR ELASTIC SCATTERING ---
      INT = 1
      ALAM1 = ALAM1+AIEL(K)
      IF ( RAT .LT. ALAM1 ) GOTO 8

C --- TRY FOR INELASTIC SCATTERING ---
      INT = 2
      ALAM1 = ALAM1+AIIN(K)
      IF ( RAT .LT. ALAM1 ) GOTO 8

C --- TRY FOR NEUTRON CAPTURE ---
      INT = 4
      ALAM1 = ALAM1+AICA(K)
      IF ( RAT .LT. ALAM1 ) GOTO 8

 6    CONTINUE

C --- NO REACTION SELECTED ==> ELASTIC SCATTERING ---
      INT = 1

C *** TAKE ACTION ACCORDING TO SELECTED REACTION CHANNEL ***
C --- FOLLOWING CODE IS A TRANSLATION OF "CALIM" INTO GEANT JARGON ---

 8    CONTINUE
      IF ( NPRT(9) ) WRITE(MDEBUG,1001) INT
 1001 FORMAT(' *CGHEI* INTERACTION TYPE CHOSEN INT = ',I3)

      IF ( INT .NE. 4 ) GOTO 10

C --- NEUTRON CAPTURE ---
      IF ( NPRT(9) ) WRITE(MDEBUG,2000)
 2000 FORMAT(' *CGHEI* SUBROUT. CAPTUR WILL BE CALLED')
      CALL CAPTUR(NOPT)
      GOTO 40

 10   CONTINUE

C --- ELASTIC AND INELASTIC SCATTERING ---
      PV(1,MXGKPV) = P*PX
      PV(2,MXGKPV) = P*PY
      PV(3,MXGKPV) = P*PZ
      PV(4,MXGKPV) = EN
      PV(5,MXGKPV) = AMAS
      PV(6,MXGKPV) = NCH
      PV(7,MXGKPV) = TOF
      PV(8,MXGKPV) = KPART
      PV(9,MXGKPV) = 0.
      PV(10,MXGKPV)= USERW

C --- ADDITIONAL PARAMETERS TO SIMULATE FERMI MOTION AND EVAPORATION ---
      DO 111  JENP = 1,10
         ENP(JENP) = 0.
 111  CONTINUE
      ENP(5) = EK
      ENP(6) = EN
      ENP(7) = P

      IF ( INT .NE. 1 ) GOTO 12

C *** ELASTIC SCATTERING PROCESSES ***

C --- ONLY NUCLEAR INTERACTIONS FOR HEAVY FRAGMENTS ---
      IF ( (KPART .GE. 30)  .AND.  (KPART .LE. 32) ) GOTO 35

C --- NORMAL ELASTIC SCATTERING FOR LIGHT MEDIA ---
      IF ( ATNO2 .LT. 1.5 ) GOTO 35

C --- COHERENT ELASTIC SCATTERING FOR HEAVY MEDIA ---
      IF ( NPRT(9) ) WRITE(MDEBUG,2002)
 2002 FORMAT(' *CGHEI* SUBROUT. COSCAT WILL BE CALLED')
      CALL COSCAT
      GOTO 40

C *** NON-ELASTIC SCATTERING PROCESSES ***
 12   CONTINUE

C --- ONLY NUCLEAR INTERACTIONS FOR HEAVY FRAGMENTS ---
      IF ( (KPART .GE. 30)  .AND.  (KPART .LE. 32) ) GOTO 35

C *** USE SOMETIMES NUCLEAR REACTION SUBROUT. "NUCREC" FOR LOW ENERGY
C *** PROTON AND NEUTRON SCATTERING ***
      CALL GRNDM(RNDM,1)
      TEST1 = RNDM(1)
      TEST2 = 4.5*(EK-0.01)
      IF ( (KPART .EQ. 14)  .AND.  (TEST1 .GT. TEST2) ) GOTO 85
      IF ( (KPART .EQ. 16)  .AND.  (TEST1 .GT. TEST2) ) GOTO 86

C *** FERMI MOTION AND EVAPORATION ***
      TKIN = CINEMA(EK)
      PV(9,MXGKPV) = TKIN
      ENP(5) = EK+TKIN
C --- CHECK FOR LOWERBOUND OF EKIN IN CROSS-SECTION TABLES ---
      IF ( ENP(5) .LE. TEKLOW ) ENP(5)=TEKLOW
      ENP(6) = ENP(5)+ABS(AMAS)
      ENP(7) = (ENP(6)-AMAS)*(ENP(6)+AMAS)
      ENP(7) = SQRT(ABS(ENP(7)))
      TKIN   = FERMIG(ENP(5))
      ENP(5) = ENP(5)+TKIN
C --- CHECK FOR LOWERBOUND OF EKIN IN CROSS-SECTION TABLES ---
      IF ( ENP(5) .LE. TEKLOW ) ENP(5)=TEKLOW
      ENP(6) = ENP(5)+ABS(AMAS)
      ENP(7) = (ENP(6)-AMAS)*(ENP(6)+AMAS)
      ENP(7) = SQRT(ABS(ENP(7)))
      TKIN   = EXNU(ENP(5))
      ENP(5) = ENP(5)-TKIN
C --- CHECK FOR LOWERBOUND OF EKIN IN CROSS-SECTION TABLES ---
      IF ( ENP(5) .LE. TEKLOW ) ENP(5)=TEKLOW
      ENP(6) = ENP(5)+ABS(AMAS)
      ENP(7) = (ENP(6)-AMAS)*(ENP(6)+AMAS)
      ENP(7) = SQRT(ABS(ENP(7)))

C *** IN CASE OF ENERGY ABOVE CUT-OFF LET THE PARTICLE CASCADE ***
      IF ( ENP(5) .GT. ELCUT(1) ) GOTO 35

C --- SECOND CHANCE FOR ANTI-BARYONS DUE TO POSSIBLE ANNIHILATION ---
      IF ( (AMAS .GE. 0.0)  .OR.  (KPART .LE. 14) ) GOTO 13
      ANNI = 1.3*P
      IF ( ANNI .GT. 0.4 ) ANNI=0.4
      CALL GRNDM(RNDM,1)
      TEST = RNDM(1)
      IF ( TEST .GT. ANNI ) GOTO 35

C *** PARTICLE WITH ENERGY BELOW CUT-OFF ***
C --- ==> ONLY NUCLEAR EVAPORATION AND QUASI-ELASTIC SCATTERING ---
 13   CONTINUE

      IF ( NPRT(9) ) WRITE(MDEBUG,1002)
     *                           KPART,EK,EN,P,ENP(5),ENP(6),ENP(7)
 1002 FORMAT(' *CGHEI* ENERGY BELOW CUT-OFF FOR GHEISHA PARTICLE ',I3/
     $ ' EK,EN,P,ENP(5),ENP(6),ENP(7) = ',6(G12.5,1X))

      IF ( (KPART .NE. 14)  .AND.  (KPART .NE. 16) ) GOTO 14
      IF ( KPART .EQ. 16 ) GOTO 86

C --- SLOW PROTON ---
 85   CONTINUE
      IF ( NPRT(9) ) WRITE(MDEBUG,2003) EK,KPART
 2003 FORMAT(' *CGHEI* SUBROUT. NUCREC WILL BE CALLED',
     $ ' EK = ',G12.5,' GEV  KPART = ',I3)
      CALL NUCREC(NOPT,2)

      IF ( NOPT .NE. 0 ) GOTO 50

      IF ( NPRT(9) ) WRITE(MDEBUG,2004) EK,KPART
 2004 FORMAT(' *CGHEI* SUBROUT. COSCAT WILL BE CALLED',
     $ ' EK = ',G12.5,' GEV  KPART = ',I3)
      CALL COSCAT
      GOTO 40

C --- SLOW NEUTRON ---
 86   CONTINUE
      IF ( NPRT(9) ) WRITE(MDEBUG,2015)
      NUCFLG = 0
      CALL GNSLWD(NUCFLG,INT,NFL,TEKLOW)
      IF ( NUCFLG .NE. 0 ) GOTO 50
      GOTO 40

C --- OTHER SLOW PARTICLES ---
 14   CONTINUE
      IPA(1) = KPART
C --- DECIDE FOR PROTON OR NEUTRON TARGET ---
      IPA(2) = 16
      CALL GRNDM(RNDM,1)
      TEST1 = RNDM(1)
      TEST2 = ZNO2/ATNO2
      IF ( TEST1 .LT. TEST2 ) IPA(2) = 14
      AVERN = 0.0
      NFL = 1
      IF ( IPA(2) .EQ. 16 ) NFL = 2
      IPPP = KPART
      IF ( NPRT(9) ) WRITE(MDEBUG,2005)
 2005 FORMAT(' *CGHEI* SUBROUT. TWOB WILL BE CALLED')
      CALL TWOB(IPPP,NFL,AVERN)
      GOTO 40

C --- INITIALIZATION OF CASCADE QUANTITIES ---
 35   CONTINUE

C *** CASCADE GENERATION ***
C --- CALCULATE FINAL STATE MULTIPLICITY AND LONGITUDINAL AND ---
C --- TRANSVERSE MOMENTUM DISTRIBUTIONS ---

C --- FIXED PARTICLE TYPE TO STEER THE CASCADE ---
      KKPART = KPART

C --- NO CASCADE FOR LEPTONS ---
      IF ( KKPART .LE. 6 ) GOTO 9999

C *** WHAT TO DO WITH "NEW PARTICLES" FOR GHEISHA ?????? ***
C --- RETURN FOR THE TIME BEING ---
      IF ( KKPART .GE. 35 ) GOTO 9999

C --- CASCADE OF HEAVY FRAGMENTS
      IF ( (KKPART .GE. 30)  .AND.  (KKPART .LE. 32) ) GOTO 390

C --- INITIALIZE THE IPA ARRAY ---
*     CALL VZERO(IPA(1),MXGKCU)
CDH
      DO  III = 1, MXGKCU
        IPA(III) = 0
      ENDDO


C --- CASCADE OF OMEGA - AND OMEGA - BAR ---
      IF ( KKPART .EQ. 33 ) GOTO 330
      IF ( KKPART .EQ. 34 ) GOTO 331

      NVEPAR = KKPART-17
      IF ( NVEPAR .LE. 0 ) GOTO 15
      GOTO (318,319,320,321,322,323,324,325,326,327,328,329),NVEPAR

 15   CONTINUE
      NVEPAR = KKPART-6
      GOTO (307,308,309,310,311,312,313,314,315,316,317,318),NVEPAR

C --- PI+ CASCADE ---
 307  CONTINUE
      IF ( NPRT(9) ) WRITE(MDEBUG,2006)
 2006 FORMAT(' *CGHEI* SUBROUT. CASPIP WILL BE CALLED')
      CALL CASPIP(J,INT,NFL)
      GOTO 40

C --- PI0 ==> NO CASCADE ---
 308  CONTINUE
      GOTO 40

C --- PI- CASCADE ---
 309  CONTINUE
      IF ( NPRT(9) ) WRITE(MDEBUG,2007)
 2007 FORMAT(' *CGHEI* SUBROUT. CASPIM WILL BE CALLED')
      CALL CASPIM(J,INT,NFL)
      GOTO 40

C --- K+ CASCADE ---
 310  CONTINUE
      IF ( NPRT(9) ) WRITE(MDEBUG,2008)
 2008 FORMAT(' *CGHEI* SUBROUT. CASKP WILL BE CALLED')
      CALL CASKP(J,INT,NFL)
      GOTO 40

C --- K0 CASCADE ---
 311  CONTINUE
      IF ( NPRT(9) ) WRITE(MDEBUG,2009)
 2009 FORMAT(' *CGHEI* SUBROUT. CASK0 WILL BE CALLED')
      CALL CASK0(J,INT,NFL)
      GOTO 40

C --- K0 BAR CASCADE ---
 312  CONTINUE
      IF ( NPRT(9) ) WRITE(MDEBUG,2010)
 2010 FORMAT(' *CGHEI* SUBROUT. CASK0B WILL BE CALLED')
      CALL CASK0B(J,INT,NFL)
      GOTO 40

C --- K- CASCADE ---
 313  CONTINUE
      IF ( NPRT(9) ) WRITE(MDEBUG,2011)
 2011 FORMAT(' *CGHEI* SUBROUT. CASKM WILL BE CALLED')
      CALL CASKM(J,INT,NFL)
      GOTO 40

C --- PROTON CASCADE ---
 314  CONTINUE
      IF ( NPRT(9) ) WRITE(MDEBUG,2012)
 2012 FORMAT(' *CGHEI* SUBROUT. CASP WILL BE CALLED')
      CALL CASP(J,INT,NFL)
      GOTO 40

C --- PROTON BAR CASCADE ---
 315  CONTINUE
      IF ( NPRT(9) ) WRITE(MDEBUG,2013)
 2013 FORMAT(' *CGHEI* SUBROUT. CASPB WILL BE CALLED')
      CALL CASPB(J,INT,NFL)
      GOTO 40

C --- NEUTRON CASCADE ---
 316  CONTINUE
      NUCFLG = 0
      IF ( EK .GT. SWTEKN ) THEN
         CALL CASN(J,INT,NFL)
         IF ( NPRT(9) ) WRITE(MDEBUG,2014)
 2014 FORMAT(' *CGHEI* SUBROUT. CASN WILL BE CALLED')
      ELSE
         CALL GNSLWD(NUCFLG,INT,NFL,TEKLOW)
         IF ( NPRT(9) ) WRITE(MDEBUG,2015)
 2015 FORMAT(' *CGHEI* SUBROUT. GNSLWD WILL BE CALLED')
      ENDIF
      IF ( NUCFLG .NE. 0 ) GOTO 50
      GOTO 40

C --- NEUTRON BAR CASCADE ---
 317  CONTINUE
      IF ( NPRT(9) ) WRITE(MDEBUG,2016)
 2016 FORMAT(' *CGHEI* SUBROUT. CASNB WILL BE CALLED')
      CALL CASNB(J,INT,NFL)
      GOTO 40

C --- LAMBDA CASCADE ---
 318  CONTINUE
      IF ( NPRT(9) ) WRITE(MDEBUG,2017)
 2017 FORMAT(' *CGHEI* SUBROUT. CASL0 WILL BE CALLED')
      CALL CASL0(J,INT,NFL)
      GOTO 40

C --- LAMBDA BAR CASCADE ---
 319  CONTINUE
      IF ( NPRT(9) ) WRITE(MDEBUG,2018)
 2018 FORMAT(' *CGHEI* SUBROUT. CASAL0 WILL BE CALLED')
      CALL CASAL0(J,INT,NFL)
      GOTO 40

C --- SIGMA + CASCADE ---
 320  CONTINUE
      IF ( NPRT(9) ) WRITE(MDEBUG,2019)
 2019 FORMAT(' *CGHEI* SUBROUT. CASSP WILL BE CALLED')
      CALL CASSP(J,INT,NFL)
      GOTO 40

C --- SIGMA 0 ==> NO CASCADE ---
 321  CONTINUE
      GOTO 40

C --- SIGMA - CASCADE ---
 322  CONTINUE
      IF ( NPRT(9) ) WRITE(MDEBUG,2020)
 2020 FORMAT(' *CGHEI* SUBROUT. CASSM WILL BE CALLED')
      CALL CASSM(J,INT,NFL)
      GOTO 40

C --- SIGMA + BAR CASCADE ---
 323  CONTINUE
      IF ( NPRT(9) ) WRITE(MDEBUG,2021)
 2021 FORMAT(' *CGHEI* SUBROUT. CASASP WILL BE CALLED')
      CALL CASASP(J,INT,NFL)
      GOTO 40

C --- SIGMA 0 BAR ==> NO CASCADE ---
 324  CONTINUE
      GOTO 40

C --- SIGMA - BAR CASCADE ---
 325  CONTINUE
      IF ( NPRT(9) ) WRITE(MDEBUG,2022)
 2022 FORMAT(' *CGHEI* SUBROUT. CASASM WILL BE CALLED')
      CALL CASASM(J,INT,NFL)
      GOTO 40

C --- XI 0 CASCADE ---
 326  CONTINUE
      IF ( NPRT(9) ) PRINT 2023
 2023 FORMAT(' *CGHEI* SUBROUT. CASX0 WILL BE CALLED')
      CALL CASX0(J,INT,NFL)
      GOTO 40

C --- XI - CASCADE ---
 327  CONTINUE
      IF ( NPRT(9) ) PRINT 2024
 2024 FORMAT(' *CGHEI* SUBROUT. CASXM WILL BE CALLED')
      CALL CASXM(J,INT,NFL)
      GOTO 40

C --- XI 0 BAR CASCADE ---
 328  CONTINUE
      IF ( NPRT(9) ) PRINT 2025
 2025 FORMAT(' *CGHEI* SUBROUT. CASAX0 WILL BE CALLED')
      CALL CASAX0(J,INT,NFL)
      GOTO 40

C --- XI - BAR CASCADE ---
 329  CONTINUE
      IF ( NPRT(9) ) PRINT 2026
 2026 FORMAT(' *CGHEI* SUBROUT. CASAXM WILL BE CALLED')
      CALL CASAXM(J,INT,NFL)
      GOTO 40

C --- OMEGA - CASCADE ---
 330  CONTINUE
      IF ( NPRT(9) ) PRINT 2027
 2027 FORMAT(' *CGHEI* SUBROUT. CASOM WILL BE CALLED')
      CALL CASOM(J,INT,NFL)
      GOTO 40

C --- OMEGA - BAR CASCADE ---
 331  CONTINUE
      IF ( NPRT(9) ) PRINT 2028
 2028 FORMAT(' *CGHEI* SUBROUT. CASAOM WILL BE CALLED')
      CALL CASAOM(J,INT,NFL)
      GOTO 40

C --- HEAVY FRAGMENT CASCADE ---
 390  CONTINUE
      IF ( NPRT(9) ) WRITE(MDEBUG,2090)
 2090 FORMAT(' *CGHEI* SUBROUT. CASFRG WILL BE CALLED')
      NUCFLG = 0
      CALL CASFRG(NUCFLG,INT,NFL)
      IF ( NUCFLG .NE. 0 ) GOTO 50

C *** CHECK WHETHER THERE ARE NEW PARTICLES GENERATED ***
 40   CONTINUE
      IF ( (NTOT .NE. 0)  .OR.  (KKPART .NE. KPART) ) GOTO 50

 50   CONTINUE

      NVEDUM=KIPART(IPART)
      IF ( NPRT(9) ) WRITE(MDEBUG,1004)NTOT,IPART,KPART,KKPART,NVEDUM
 1004 FORMAT(' *CGHEI* SEC. GEN. NTOT,IPART,KPART,KKPART,KIPART = ',
     $ 5(I3,1X))

C --- INITIAL PARTICLE TYPE HAS BEEN CHANGED ==> PUT NEW TYPE ON ---
C --- THE TEMPORARY STACK ---

C --- MAKE CHOICE BETWEEN K0 LONG / K0 SHORT ---
      IF ( (KPART .NE. 11)  .AND.  (KPART .NE. 12) ) GOTO 52
      CALL GRNDM(RNDM,1)
      KPART = 11.5+RNDM(1)

 52   CONTINUE

C --- IN CASE THE NEW PARTICLE IS A NEUTRINO ==> FORGET IT ---
      IF ( KPART .EQ. 2 ) GOTO 60

C --- PUT CURRENT GHEISHA PARTICLE ON THE CORSIKA STACK
C --- ( IF SURVIVING ANGLE CUT ! )
      NGKINE = 1

C --- CALCULATE ELASTICITY
      IF ( EN .GT. EMAX ) THEN
         EMAX = EN
      ENDIF

      ITY=IKPART(KPART)
C  OLD COUPLING
C     SECPAR(3) = -PZ
C     IF ( SECPAR(3) .GT. C(29) ) THEN

      IF     ( ITY .LT. 45 ) THEN
        SECPAR(1) = DBLE(ITY)
      ELSEIF ( ITY .EQ. 45 ) THEN
        SECPAR(1) = 201.D0
      ELSEIF ( ITY .EQ. 46 ) THEN
        SECPAR(1) = 301.D0
      ELSEIF ( ITY .EQ. 47 ) THEN
        SECPAR(1) = 402.D0
      ENDIF
      IF ( ABS(AMAS) .LT. 1.E-9 ) THEN
        SECPAR(2) = EN
      ELSE
        SECPAR(2) = DBLE(EN) / DBLE(ABS(AMAS))
      ENDIF
      IF     ( ITY .EQ. 13  .OR. ITY .EQ. 14 ) THEN
        ETOT = ETOT + (SECPAR(2) - 1.D0) * PAMA(ITY)
      ELSEIF ( ITY .EQ. 15  .OR. ITY .EQ. 25 ) THEN
        ETOT = ETOT + (SECPAR(2) + 1.D0) * PAMA(ITY)
      ELSE
        ETOT = ETOT + EN
      ENDIF
C  NEW COUPLING WITH CORSIKA  D. HECK  DEC. 2000
      THETG = -PZ
      IF ( PX .NE. 0.  .OR.  PY .NE. 0. ) THEN
        PHIG = ATAN2( DBLE(PY), DBLE(PX) ) + PHIRAN
      ELSE
        PHIG = 0.D0 + PHIRAN
      ENDIF
      CALL ADDANG( CURPAR(3),CURPAR(4),THETG,PHIG, SECPAR(3),SECPAR(4))
C  CHECK WETHER PARTICLE SURVIVES ANGULAR CUT
      IF ( SECPAR(3) .GT. C(29) ) THEN
         CALL TSTACK
      ELSE
         IF ( LLONGI ) THEN
C  ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT
            IF     ( ITY .EQ. 1                   ) THEN
               DLONG(LHEIGH,1) = DLONG(LHEIGH,1) + EN
            ELSEIF ( ITY .EQ. 2                   ) THEN
               DLONG(LHEIGH,3) = DLONG(LHEIGH,3) + EN + PAMA(2)
            ELSEIF ( ITY .EQ. 3                   ) THEN
               DLONG(LHEIGH,3) = DLONG(LHEIGH,3) + EN - PAMA(2)
            ELSEIF ( ITY .EQ. 5  .OR.  ITY .EQ. 6 ) THEN
               DLONG(LHEIGH,5) = DLONG(LHEIGH,5) + EN
            ELSEIF ( ITY .GE. 7                   ) THEN
               DLONG(LHEIGH,7) = DLONG(LHEIGH,7) + EN - RESTMS(ITY)
            ENDIF
         ENDIF
      ENDIF

C *** CHECK WHETHER SECONDARIES HAVE BEEN GENERATED AND COPY THEM ***
C *** ALSO ON THE GEANT STACK ***
 60   CONTINUE

C --- ALL QUANTITIES ARE TAKEN FROM THE GHEISHA STACK WHERE THE ---
C --- CONVENTION IS THE FOLLOWING ---
C
C EVE(INDEX+ 1)= X
C EVE(INDEX+ 2)= Y
C EVE(INDEX+ 3)= Z
C EVE(INDEX+ 4)= NCAL
C EVE(INDEX+ 5)= NCELL
C EVE(INDEX+ 6)= MASS
C EVE(INDEX+ 7)= CHARGE
C EVE(INDEX+ 8)= TOF
C EVE(INDEX+ 9)= PX
C EVE(INDEX+10)= PY
C EVE(INDEX+11)= PZ
C EVE(INDEX+12)= TYPE

      IF ( NTOT .LE. 0 ) GOTO 9999

C --- ONE OR MORE SECONDARIES HAVE BEEN GENERATED ---
      DO 61  L = 1,NTOT
      INDEX = (L-1)*12
      JND = EVE(INDEX+12)

C --- MAKE CHOICE BETWEEN K0 LONG / K0 SHORT ---
      IF ( (JND .NE. 11)  .AND.  (JND .NE. 12) ) GOTO 63
      CALL GRNDM(RNDM,1)
      JND = 11.5+RNDM(1)

C --- FORGET ABOUT NEUTRINOS ---
 63   CONTINUE
      IF ( JND .EQ. 2 ) GOTO 61

C --- SWITCH TO CORSIKA QUANTITIES ---
      ITY = IKPART(JND)
      IF (NPRT(9)) WRITE(MDEBUG,1006) ITY,NGKINE,L,(EVE(INDEX+J),J=1,12)
 1006 FORMAT(' *CGHEI* GEANT PART. ',I3,' ALSO PUT ONTO STACK AT',
     $ ' POS. ',I3/
     $ ' EVE(',I2,') = ',(' ',10G12.5))

      PLX = EVE(INDEX+9)
      PLY = EVE(INDEX+10)
      PLZ = EVE(INDEX+11)
      PLSQ = PLX**2 + PLY**2 + PLZ**2
      PLTOT = SQRT (PLSQ)
      RMASSK = ABS(RMASS(JND))

C  FIND HIGHEST ENERGY PARTICLE FOR ELASTICITY
      EEESQ = PLSQ + RMASSK**2
      IF ( EEESQ .GT. EMAX**2 ) THEN
        EMAX = SQRT(EEESQ)
      ENDIF

C --- APPLY ANGLE CUT AND
C --- ADD PARTICLE TO THE CORSIKA STACK (RESTRICTED TO 100) ---
      IF ( PLTOT .LE. 1.D-10 ) GOTO 61
C     SECPAR(3) = (-PLZ) / PLTOT
      THETG     = (-PLZ) / PLTOT
      IF ( RMASSK .LT. 1.D-9 ) THEN
         SECPAR(2) = PLTOT
      ELSE
         SECPAR(2) = SQRT (PLSQ+RMASSK**2) / RMASSK
      ENDIF
      IF     ( ITY .LT. 45 ) THEN
         SECPAR(1) = DBLE(ITY)
      ELSEIF ( ITY .EQ. 45 ) THEN
         SECPAR(1) = 201.D0
      ELSEIF ( ITY .EQ. 46 ) THEN
         SECPAR(1) = 301.D0
      ELSEIF ( ITY .EQ. 47 ) THEN
         SECPAR(1) = 402.D0
      ELSE
         SECPAR(1) = 0.D0
         WRITE(MONIOU,*) '*CGHEI*  ILLEGAL PARTICLE TYPE',ITY
      ENDIF
C --- COUNTERS FOR FIRST INTERACTION
      ITY = SECPAR(1)
      IF     ( ITY .EQ. 1                    ) THEN
         ETOT = ETOT + SQRT(EEESQ)
      ELSEIF ( ITY .EQ. 13  .OR. ITY .EQ. 14 ) THEN
         ETOT = ETOT + (SECPAR(2) - 1.D0) * PAMA(ITY)
      ELSEIF ( ITY .EQ. 15  .OR. ITY .EQ. 25 ) THEN
         ETOT = ETOT + (SECPAR(2) + 1.D0) * PAMA(ITY)
      ELSE
         ETOT = ETOT + SECPAR(2) * PAMA(ITY)
      ENDIF
      IF ( FIRSTI ) THEN
        IF     ( ITY .EQ.  7  .OR.  ITY .EQ.  8  .OR.
     *                              ITY .EQ.  9 ) THEN
          IFINPI = IFINPI + 1
        ELSEIF ( ITY .EQ. 13  .OR.  ITY .EQ. 14  .OR.
     *           ITY .EQ. 15  .OR.  ITY .EQ. 25 ) THEN
          IFINNU = IFINNU + 1
        ELSEIF ( ITY .EQ. 10  .OR.  ITY .EQ. 11  .OR.
     *           ITY .EQ. 12  .OR.  ITY .EQ. 16 ) THEN
          IFINKA = IFINKA + 1
        ELSEIF ( ITY .EQ. 17 ) THEN
          IFINET = IFINET + 1
        ELSEIF ( (ITY .GE. 18  .AND. ITY .LE. 24)  .OR.
     *           (ITY .GE. 26  .AND. ITY .LE. 32) ) THEN
          IFINHY = IFINHY + 1
        ENDIF
      ENDIF

C  OLD COUPLING
C     IF ( SECPAR(3) .GT. C(29) ) THEN
C  NEW COUPLING WITH CORSIKA  D. HECK  DEC. 2000
      IF ( NGKINE .GE. MXGKGH ) GOTO 9999
      NGKINE = NGKINE+1
      IF ( PLX .NE. 0.D0  .OR.  PLY .NE. 0.D0 ) THEN
        PHIG = ATAN2( PLY, PLX ) + PHIRAN
      ELSE
        PHIG = 0.D0 + PHIRAN
      ENDIF
      CALL ADDANG( CURPAR(3),CURPAR(4),THETG,PHIG, SECPAR(3),SECPAR(4))
C  CHECK WETHER PARTICLE SURVIVES ANGULAR CUT
      IF ( SECPAR(3) .GT. C(29) ) THEN
         CALL TSTACK
      ELSE
         IF ( LLONGI ) THEN
C  ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT
            IF     ( ITY .EQ. 1                   ) THEN
               DLONG(LHEIGH,1) = DLONG(LHEIGH,1) + SECPAR(2)
            ELSEIF ( ITY .EQ. 2                   ) THEN
               DLONG(LHEIGH,3) = DLONG(LHEIGH,3)
     *                                      + (SECPAR(2)+1.D0)*PAMA(2)
            ELSEIF ( ITY .EQ. 3                   ) THEN
               DLONG(LHEIGH,3) = DLONG(LHEIGH,3)
     *                                      + (SECPAR(2)-1.D0)*PAMA(2)
            ELSEIF ( ITY .EQ. 5  .OR.  ITY .EQ. 6 ) THEN
               DLONG(LHEIGH,5) = DLONG(LHEIGH,5) + SECPAR(2)*PAMA(5)
            ELSEIF ( ITY .GE. 7                   ) THEN
               DLONG(LHEIGH,7) = DLONG(LHEIGH,7) + SECPAR(2)*PAMA(ITY)
     *                                            - RESTMS(ITY)
            ENDIF
         ENDIF
      ENDIF

 61   CONTINUE

C --- COUNTER FOR ENERGY-MULTIPLICITY MATRIX
      MSMM = MSMM + NTOT

C --- FILL ELASTICITY IN MATRICES
      ELASTI = EMAX/ENOLD
      MELL = MIN ( 1.D0+10.D0*      MAX( 0.D0, ELASTI ) , 11.D0 )
      MEN  = MIN ( 4.D0+ 3.D0*LOG10(MAX( .1D0, EKINL )), 40.D0 )
      IELDPM(MEN,MELL) = IELDPM(MEN,MELL) + 1
      IELDPA(MEN,MELL) = IELDPA(MEN,MELL) + 1
      IF ( ELASTI .LT. 1. ) THEN
        ELMEAN(MEN) = ELMEAN(MEN) + ELASTI
        ELMEAA(MEN) = ELMEAA(MEN) + ELASTI
      ENDIF

      IF ( FIRSTI ) THEN
        TARG1I = ATNO2
        SIG1I  = SIGAIR
        ELAST  = ELASTI
        FIRSTI = .FALSE.
      ENDIF
      IF ( DEBUG ) WRITE(MDEBUG,*)'CGHEI : EXIT WITH ETOT=',SNGL(ETOT)

 9999 CONTINUE
C --- LIMIT THE VALUE OF NGKINE IN CASE OF OVERFLOW ---
      NGKINE = MIN(NGKINE,MXGKGH)

      RETURN
      END
*CMZ :          28/02/2002  11.42.37  by  D. HECK IK FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
C=======================================================================

      SUBROUTINE CGHINI

C-----------------------------------------------------------------------
C  C(ORSIKA) GH(EISHA) INI(TIALIZATION)
C  INITIALIZATION OF RELEVANT GHEISHA VARIABLES
C  THIS SUBROUTINE IS CALLED FROM START.
C
C  ORIGIN  : GHEISHA SUBROUT. "GHEINI", F.CARMINATI
C  REDESIGN: P. GABRIEL IK1  FZK KARLSRUHE
C-----------------------------------------------------------------------

*KEEP,AIR.
      COMMON /AIR/     COMPOS,PROBTA,AVERAW,AVOGAD
      DOUBLE PRECISION COMPOS(3),PROBTA(3),AVERAW,AVOGAD
*KEEP,CGCOMP.
      PARAMETER (KK=3)
      COMMON/CGCOMP/ ACOMP,ZCOMP,WCOMP
      REAL           ACOMP(KK),ZCOMP(KK),WCOMP(KK)
*KEEP,PAM.
      COMMON /PAM/     PAMA,SIGNUM,RESTMS
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000)
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEND.

      COMMON/GSECTI/ AIEL(20),AIIN(20),AIFI(20),AICA(20),ALAM,K0FLAG
      INTEGER K0FLAG
      REAL AIEL,AIIN,AIFI,AICA,ALAM

C --- GHEISHA COMMONS ---
C --- INITIALIZATION FLAGS FOR VARIOUS GHEISHA ROUTINES ---
      COMMON /KGINIT/ KGINIT(50)

      COMMON/CONSTS/ PI,TWPI,PIBTW,MP,MPI,MMU,MEL,MKCH,MK0,SMP,SMPI,
     $               SMU,CT,CTKCH,CTK0,
     $               ML0,MSP,MS0,MSM,MX0,MXM,CTL0,CTSP,CTSM,CTX0,CTXM,
     $               RMASS(35),RCHARG(35)

                     REAL MP,MPI,MMU,MEL,MKCH,MK0,
     *                    ML0,MSP,MS0,MSM,MX0,MXM

      PARAMETER (MXGKGH=100)
      PARAMETER (MXEVEN=12*MXGKGH)
      COMMON/EVENT / NSIZE,NCUR,NEXT,NTOT,EVE(MXEVEN)

      COMMON/PRNTFL/INBCD,NEWBCD,INBIN,NEWBIN,NPEVT,NEVTP,LPRT,NPRT(10)
                    LOGICAL LPRT,NPRT

      PARAMETER (MXGKPV=MXGKGH)
      COMMON /VECUTY/ PV(10,MXGKPV)

C --- BOUNDARY LIMITS FOR ARGUMENTS OF INTRINSIC FUNCTIONS ---
C --- XL DENOTES LOWER BOUND WHEREAS XU DENOTES UPPER BOUND ---
      COMMON /LIMITS/ EXPXL,EXPXU


C --- "NEVENT" CHANGED TO "KEVENT" IN COMMON /CURPAR/ DUE TO CLASH ---
C --- WITH VARIABLE "NEVENT" IN GEANT COMMON ---

      PARAMETER (MXGKCU=MXGKGH)
      COMMON /CURPAR/ WEIGHT(10),DDELTN,IFILE,IRUN,NEVT,KEVENT,SHFLAG,
     $                ITHST,ITTOT,ITLST,IFRND,TOFCUT,CMOM(5),CENG(5),
     $                RS,S,ENP(10),NP,NM,NN,NR,NO,NZ,IPA(MXGKCU),
     $                ATNO2,ZNO2

      SAVE
C-----------------------------------------------------------------------

      IF ( DEBUG ) WRITE(MDEBUG,*) 'CGHINI:'

C --- INITIALIZE COMPOSITION OF AIR
      WCOMP(1) = COMPOS(1)
      WCOMP(2) = COMPOS(2)
      WCOMP(3) = COMPOS(3)
      ACOMP(1) = 14.
      ACOMP(2) = 16.
      ACOMP(3) = 40.
      ZCOMP(1) =  7.
      ZCOMP(2) =  8.
      ZCOMP(3) = 18.

C --- SET GHEISHA I/O UNITS TO THE SAME AS FOR CORSIKA --
      INBCD  = MONIIN
      NEWBCD = MONIOU
      IF ( DEBUG  .OR.  DEBDEL ) NEWBCD = MDEBUG

C --- INITIALIZE ALL GHEISHA PRINT FLAGS AS FALSE ---
C --- ACTIVATION IS DONE BY "DEBUG" STEERING CARD ---
      DO 11  J = 1,10
         NPRT(J)=.FALSE.
 11   CONTINUE
      IF ( DEBUG  .AND.  GHEISDB ) THEN
         NPRT(4)=.TRUE.
         NPRT(9)=.TRUE.
      ELSE
         NPRT(4)=.FALSE.
         NPRT(9)=.FALSE.
      ENDIF
      LPRT=.FALSE.
      DO 12  I = 1,MXGKPV
         DO 12  J = 1,10
            PV(J,I)=0.
 12   CONTINUE

C --- INITIALIZE KGINIT ARRAY ---
      DO 20  J = 1,50
         KGINIT(J)=0
 20   CONTINUE

C --- INITIALIZE SOME CUT-OFF PARAMETERS WITH GEANT VALUES ---
      TOFCUT=1.0E+20
      NSIZE=MXEVEN
      K0FLAG=0
      CENG(3)=0.
      CENG(4)=0.

C --- INITIALIZE PI, 2*PI, PI/2 AND PARTICLE PARAMETERS ---
      PI=ACOS(-1.0)
      TWPI=2.0*PI
      PIBTW=PI/2.0
C *** GAMMA ***
      RMASS(1)=PAMA(1)
      RCHARG(1)=0.0
C *** NEUTRINO ***
      RMASS(2)=PAMA(4)
      RCHARG(2)=0.0
C *** E+ ***
      RMASS(3)=PAMA(2)
      RCHARG(3)=1.0
C *** E- ***
      RMASS(4)=PAMA(3)
      RCHARG(4)=-1.0
C *** MU+ ***
      RMASS(5)=PAMA(5)
      RCHARG(5)=1.0
C *** MU- ***
      RMASS(6)=PAMA(6)
      RCHARG(6)=-1.0
C *** PI+ ***
      RMASS(7)=PAMA(8)
      RCHARG(7)=1.0
      CT=780.4
C *** PI0 ***
      RMASS(8)=PAMA(7)
      RCHARG(8)=0.0
C *** PI- ***
      RMASS(9)=PAMA(9)
      RCHARG(9)=-1.0
C *** K+ ***
      RMASS(10)=PAMA(11)
      RCHARG(10)=1.0
      CTKCH=370.9
C *** K0 SHORT (==> K0) ***
      RMASS(11)=PAMA(16)
      RCHARG(11)=0.0
      CTK0=2.675
C *** K0 LONG (==> K0 BAR) ***
      RMASS(12)=-PAMA(10)
      RCHARG(12)=0.0
C *** K- ***
      RMASS(13)=PAMA(12)
      RCHARG(13)=-1.0
C *** P ***
      RMASS(14)=PAMA(14)
      RCHARG(14)=1.0
C *** P BAR ***
      RMASS(15)=-PAMA(15)
      RCHARG(15)=-1.0
C *** N ***
      RMASS(16)=PAMA(13)
      RCHARG(16)=0.0
C *** N BAR ***
      RMASS(17)=-PAMA(25)
      RCHARG(17)=0.0
C *** L0 ***
      RMASS(18)=PAMA(18)
      RCHARG(18)=0.0
      CTL0=7.89
C *** L0 BAR ***
      RMASS(19)=-PAMA(26)
      RCHARG(19)=0.0
C *** S+ ***
      RMASS(20)=PAMA(19)
      RCHARG(20)=1.0
      CTSP=2.40
C *** S0 ***
      RMASS(21)=PAMA(20)
      RCHARG(21)=0.0
C *** S- ***
      RMASS(22)=PAMA(21)
      RCHARG(22)=-1.0
      CTSM=4.44
C *** S+ BAR ***
      RMASS(23)=-PAMA(27)
      RCHARG(23)=-1.0
C *** S0 BAR ***
      RMASS(24)=-PAMA(28)
      RCHARG(24)=0.0
C *** S- BAR ***
      RMASS(25)=-PAMA(29)
      RCHARG(25)=1.0
C *** XI0 ***
      RMASS(26)=PAMA(22)
      RCHARG(26)=0.0
      CTX0=8.69
C *** XI- ***
      RMASS(27)=PAMA(23)
      RCHARG(27)=-1.0
      CTXM=4.92
C *** XI0 BAR ***
      RMASS(28)=-PAMA(30)
      RCHARG(28)=0.0
      CTX0=8.69
C *** XI- BAR ***
      RMASS(29)=-PAMA(31)
      RCHARG(29)=1.0
C *** DEUTERON ***
      RMASS(30)=PAMA(45)
      RCHARG(30)=1.0
C *** TRITON ***
      RMASS(31)=PAMA(46)
      RCHARG(31)=1.0
C *** ALPHA ***
      RMASS(32)=PAMA(47)
      RCHARG(32)=2.0
C *** OMEGA- ***
      RMASS(33)=PAMA(24)
      RCHARG(33)=-1.0
C *** OMEGA- BAR ***
      RMASS(34)=-PAMA(32)
      RCHARG(34)=1.0
C *** NEW PARTICLE (GEANTINO) ***
      RMASS(35)=0.0
      RCHARG(35)=0.0

      IF ( NPRT(9) )
     $   WRITE(MDEBUG,1000) (I,RMASS(I),RCHARG(I),I=1,33),
     $            CT,CTKCH,CTK0,CTL0,CTSP,CTSM,CTX0,CTXM
 1000 FORMAT(' *CGHINI* === GHEISHA PARTICLE PROPERTIES ==='/
     $   '0INDEX',5X,'MASS (GEV)',5X,'CHARGE'/1H /
     $   33(1H ,1X,I3,5X,F11.6,6X,F5.2/),
     $   '0PI +-  CT = ',G12.5,' K  +-  CT = ',G12.5/
     $   ' K0     CT = ',G12.5,' L0     CT = ',G12.5/
     $   ' S+     CT = ',G12.5,' S-     CT = ',G12.5/
     $   ' X0     CT = ',G12.5,' X-     CT = ',G12.5)

      MP   = RMASS(14)
      MPI  = RMASS(7)
      MMU  = RMASS(5)
      MEL  = RMASS(3)
      MKCH = RMASS(10)
      MK0  = RMASS(11)
      SMP  = MP**2
      SMPI = MPI**2
      SMU  = MMU**2
      ML0  = RMASS(18)
      MSP  = RMASS(20)
      MS0  = RMASS(21)
      MSM  = RMASS(22)
      MX0  = RMASS(26)
      MXM  = RMASS(27)

C --- LOAD LIMITS FOR INTRINSIC FUNCTION ARGUMENTS ---
      EXPXL = -82.0
      EXPXU =  82.0

      IF ( NPRT(9) ) WRITE(MDEBUG,1001) EXPXL,EXPXU
 1001 FORMAT(' *GHEINI* === INTRINSIC FUNCTION BOUNDARIES ==='/
     $  ' EXPXL,EXPXU = ',2(G12.5,1X))

      RETURN
      END
*CMZ :          28/02/2002  11.42.37  by  D. HECK IK FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
C=======================================================================

      DOUBLE PRECISION FUNCTION CGHSIG( PPART,EKIN,LPART )

C-----------------------------------------------------------------------
C  C(ORSIKA) GH(EISHA) SIG(MA)
C
C  CALCULATION OF THE PROBABILITIES FOR (IN)ELASTIC INTERACTIONS ***
C  THIS FUNCTION IS CALLED FROM BOX2.
C  ARGUMENTS:
C   PPART  = R*4 PARTICLE MOMENTUM (GEV)
C   EKIN   = R*4 KINETIC ENERGY (GEV)
C   LPART  = PARTICLE TYPE
C
C  ORIGIN  : F.CARMINATI, H.FESEFELDT (SUBROUT. GHESIG)
C  REDESIGN: P. GABRIEL IK1  FZK KARLSRUHE
C-----------------------------------------------------------------------
C  *** IPART DENOTES THE GHEISHA PARTICLE INDEX ***
C
C  CONVENTION :
C
C   PARTICLE                 IPART
C   ------------------------------
C   GAMMA                    1
C   NEUTRINO                 2
C   POSITRON                 3
C   ELECTRON                 4
C   MUON +                   5
C   MUON -                   6
C   PION +                   7
C   PION 0                   8
C   PION -                   9
C   KAON +                  10
C   KAON 0 S                11
C   KAON 0 L                12
C   KAON -                  13
C   PROTON                  14
C   PROTON BAR              15
C   NEUTRON                 16
C   NEUTRON BAR             17
C   LAMBDA                  18
C   LAMBDA BAR              19
C   SIGMA +                 20
C   SIGMA 0                 21
C   SIGMA -                 22
C   SIGMA + BAR             23
C   SIGMA 0 BAR             24
C   SIGMA - BAR             25
C   XSI 0                   26
C   XSI -                   27
C   XSI 0 BAR               28
C   XSI - BAR               29
C   DEUTERON                30
C   TRITON                  31
C   ALPHA                   32
C   OMEGA -                 33
C   OMEGA - BAR             34
C   NEW PARTICLES           35
C
C-----------------------------------------------------------------------

*KEEP,CGCOMP.
      PARAMETER (KK=3)
      COMMON/CGCOMP/ ACOMP,ZCOMP,WCOMP
      REAL           ACOMP(KK),ZCOMP(KK),WCOMP(KK)
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEND.

      COMMON/GSECTI/ AIEL(20),AIIN(20),AIFI(20),AICA(20),ALAM,K0FLAG
      INTEGER K0FLAG
      REAL AIEL,AIIN,AIFI,AICA,ALAM

C --- GHEISHA COMMONS ---
      COMMON/RESULT/XEND,YEND,ZEND,RCA,RCE,AMAS,NCH,TOF,PX,PY,PZ,
     *              USERW,INTCT,P,EN,EK,AMASQ,DELTN,ITK,NTK,IPART,IND,
     *              LCALO,ICEL,SINL,COSL,SINP,COSP,
     *              XOLD,YOLD,ZOLD,POLD,PXOLD,PYOLD,PZOLD,
     *              XSCAT,YSCAT,ZSCAT,PSCAT,PXSCAT,PYSCAT,PZSCAT
                    REAL NCH,INTCT

      COMMON/PRNTFL/INBCD,NEWBCD,INBIN,NEWBIN,NPEVT,NEVTP,LPRT,NPRT(10)
                    LOGICAL LPRT,NPRT


      DIMENSION ALPHA(35),ALPHAC(41),IPART2(7),CSA(4)
      DIMENSION PARTEL(35),PARTIN(35),INTRC(35)
*     DIMENSION ICORR(35)

C --- DIMENSION STATEMENTS FOR CROSS-SECTION DATA ---
      DIMENSION PLAB(41),CSEL(35,41),CSIN(35,41),CSPIEL(3,41),
     $          CSPIIN(3,41),CSPNEL(3,41),CSPNIN(3,41),
     $          ELAB(17),CNLWAT(15),CNLWEL(15,17),CNLWIN(15,17),
     $          CSCAP(100)

C --- DIMENSION STMTS. FOR GEANT/GHEISHA PARTICLE CODE CONVERSIONS ---
C --- KIPART(I)=GHEISHA CODE CORRESPONDING TO GEANT   CODE I ---
C --- IKPART(I)=GEANT   CODE CORRESPONDING TO GHEISHA CODE I ---

      DIMENSION KIPART(48)
*     DIMENSION IKPART(35)

      SAVE

C --- CROSS-SECTION DATA BY "PCSDAT" 01-FEB-1989 ---
      DATA PLAB /
     $  0.00000E+00, 0.10000    , 0.15000    , 0.20000    , 0.25000    ,
     $  0.30000    , 0.35000    , 0.40000    , 0.45000    , 0.50000    ,
     $  0.55000    , 0.60000    , 0.65000    , 0.70000    , 0.75000    ,
     $  0.80000    , 0.85000    , 0.90000    , 0.95000    ,  1.0000    ,
     $   1.1000    ,  1.2000    ,  1.3000    ,  1.4000    ,  1.5000    ,
     $   1.6000    ,  1.8000    ,  2.0000    ,  2.2000    ,  2.4000    ,
     $   2.6000    ,  2.8000    ,  3.0000    ,  4.0000    ,  5.0000    ,
     $   6.0000    ,  8.0000    ,  10.000    ,  20.000    ,  100.00    ,
     $   1000.0    /

C  ELASTIC SCATTERING CROSS-SECTIONS ON FREE PROTONS
C  GAMMA, NEUTRINO, POSITRON, ELECTRON, MU(+), MU(-)
      DATA ((CSEL(I,J),I=1,6),J=1,41) / 246 * 0. /
C  PI(0)
      DATA (CSEL( 8,J),J=1,41) / 41 * 0. /
C  SIGMA(0)
      DATA (CSEL(21,J),J=1,41) / 41 * 0. /
C  SIGMA(0)_BAR
      DATA (CSEL(24,J),J=1,41) / 41 * 0. /
C  DEUTERIUM, TRITIUM, ALPHA
      DATA ((CSEL(I,J),I=30,32),J=1,41) / 123 * 0. /
C  NEW PARTICLES
      DATA (CSEL(35,J),J=1,41) / 41 * 0. /
C  PI(+)
      DATA (CSEL( 7,J),J=1,41) /
     $  0.00000E+00,  6.0000    ,  20.000    ,  71.000    ,  155.00    ,
     $   195.00    ,  130.00    ,  78.000    ,  60.000    ,  32.000    ,
     $   23.500    ,  18.500    ,  15.000    ,  12.500    ,  10.000    ,
     $   9.1000    ,  8.6000    ,  8.8000    ,  9.5000    ,  10.600    ,
     $   13.000    ,  15.500    ,  17.100    ,  17.200    ,  16.200    ,
     $   15.000    ,  12.300    ,  10.200    ,  9.0000    ,  8.0000    ,
     $   7.3000    ,  6.8000    ,  6.5000    ,  5.8000    ,  5.4000    ,
     $   5.2000    ,  5.0000    ,  4.9000    ,  3.8000    ,  3.2000    ,
     $   3.5000    /
C  PI(-)
      DATA (CSEL( 9,J),J=1,41) /
     $  0.00000E+00,  1.0000    ,  3.0000    ,  8.0000    ,  18.000    ,
     $   25.000    ,  27.500    ,  12.300    ,  10.600    ,  11.000    ,
     $   12.500    ,  14.500    ,  17.000    ,  19.400    ,  19.800    ,
     $   16.800    ,  14.000    ,  14.800    ,  20.000    ,  26.100    ,
     $   19.500    ,  15.000    ,  12.800    ,  11.500    ,  10.500    ,
     $   9.8000    ,  8.8000    ,  8.2000    ,  7.8000    ,  7.5000    ,
     $   7.2000    ,  7.0000    ,  6.8000    ,  6.1000    ,  5.7000    ,
     $   5.4000    ,  4.9000    ,  4.6000    ,  4.0000    ,  3.3000    ,
     $   3.5000    /
C  K(+)
      DATA (CSEL(10,J),J=1,41) /
     $   10.000    ,  11.200    ,  11.300    ,  11.400    ,  11.500    ,
     $   11.600    ,  11.800    ,  12.000    ,  12.100    ,  12.200    ,
     $   12.300    ,  12.400    ,  12.500    ,  12.500    ,  12.500    ,
     $   12.400    ,  12.300    ,  12.200    ,  12.000    ,  11.800    ,
     $   11.200    ,  11.500    ,  9.9000    ,  9.4000    ,  8.8000    ,
     $   8.4000    ,  7.5000    ,  6.9000    ,  6.3000    ,  5.9000    ,
     $   5.5000    ,  5.2000    ,  5.0000    ,  4.0000    ,  3.5000    ,
     $   3.3000    ,  3.1000    ,  3.1000    ,  3.0000    ,  2.5000    ,
     $   3.0000    /
C  K(0) SHORT
      DATA (CSEL(11,J),J=1,41) /
     $   10.000    ,  11.200    ,  11.300    ,  11.400    ,  11.500    ,
     $   11.600    ,  11.800    ,  12.000    ,  12.100    ,  12.200    ,
     $   12.300    ,  12.400    ,  12.500    ,  12.500    ,  12.500    ,
     $   12.400    ,  12.300    ,  12.200    ,  12.000    ,  11.800    ,
     $   11.200    ,  11.500    ,  9.9000    ,  9.4000    ,  8.8000    ,
     $   8.4000    ,  7.5000    ,  6.9000    ,  6.3000    ,  5.9000    ,
     $   5.5000    ,  5.2000    ,  5.0000    ,  4.0000    ,  3.5000    ,
     $   3.3000    ,  3.1000    ,  3.1000    ,  3.0000    ,  2.5000    ,
     $   3.0000    /
C  K(0) LONG
      DATA (CSEL(12,J),J=1,41) /
     $   160.83    ,  82.800    ,  58.575    ,  43.683    ,  34.792    ,
     $   28.650    ,  24.367    ,  20.917    ,  18.192    ,  16.300    ,
     $   14.608    ,  13.017    ,  12.250    ,  11.700    ,  12.017    ,
     $   14.075    ,  15.842    ,  16.433    ,  16.042    ,  15.008    ,
     $   12.575    ,  10.708    ,  9.2000    ,  8.0167    ,  7.2833    ,
     $   7.0750    ,  6.6333    ,  6.1250    ,  5.6583    ,  5.2750    ,
     $   4.9333    ,  4.6250    ,  4.4583    ,  3.7333    ,  3.3833    ,
     $   3.1833    ,  2.9833    ,  2.7500    ,  2.3667    ,  2.2000    ,
     $   2.6000    /
C  K(-)
      DATA (CSEL(13,J),J=1,41) /
     $   300.00    ,  140.00    ,  97.000    ,  70.000    ,  55.000    ,
     $   45.000    ,  37.000    ,  31.000    ,  26.000    ,  23.000    ,
     $   20.000    ,  17.000    ,  15.500    ,  14.500    ,  14.700    ,
     $   18.500    ,  22.000    ,  23.000    ,  22.500    ,  20.700    ,
     $   16.500    ,  14.000    ,  11.500    ,  9.6000    ,  8.6000    ,
     $   8.5000    ,  8.3000    ,  7.6000    ,  7.0000    ,  6.4000    ,
     $   5.9000    ,  5.5000    ,  5.3000    ,  4.4000    ,  4.1000    ,
     $   3.9000    ,  3.7000    ,  3.3000    ,  2.6000    ,  2.5000    ,
     $   3.0000    /
C  PROTON
      DATA (CSEL(14,J),J=1,41) /
     $   1100.0    ,  115.00    ,  105.00    ,  100.00    ,  56.000    ,
     $   40.000    ,  27.000    ,  22.000    ,  21.000    ,  20.000    ,
     $   20.000    ,  20.000    ,  20.500    ,  21.000    ,  22.000    ,
     $   23.000    ,  24.000    ,  24.000    ,  24.400    ,  24.500    ,
     $   25.000    ,  25.500    ,  26.000    ,  26.500    ,  27.000    ,
     $   27.000    ,  26.000    ,  23.000    ,  21.500    ,  20.000    ,
     $   19.000    ,  18.000    ,  17.000    ,  13.000    ,  11.500    ,
     $   10.300    ,  9.4000    ,  9.0000    ,  8.8000    ,  7.0000    ,
     $   7.5000    /
C  PROTON_BAR
      DATA (CSEL(15,J),J=1,41) /
     $   200.00    ,  163.00    ,  141.00    ,  120.00    ,  111.00    ,
     $   99.500    ,  92.500    ,  86.500    ,  82.000    ,  78.000    ,
     $   74.000    ,  71.000    ,  67.500    ,  65.000    ,  62.500    ,
     $   59.700    ,  58.100    ,  56.300    ,  54.700    ,  52.700    ,
     $   50.000    ,  48.400    ,  47.000    ,  46.000    ,  45.200    ,
     $   42.800    ,  39.200    ,  36.300    ,  32.800    ,  30.400    ,
     $   28.100    ,  26.300    ,  24.500    ,  19.250    ,  16.840    ,
     $   14.600    ,  12.340    ,  11.210    ,  8.8500    ,  7.5000    ,
     $   7.5000    /
C  NEUTRON
      DATA (CSEL(16,J),J=1,41) /
     $   4200.0    ,  440.00    ,  420.00    ,  400.00    ,  230.00    ,
     $   160.00    ,  105.00    ,  80.000    ,  62.000    ,  50.000    ,
     $   45.000    ,  41.000    ,  38.000    ,  36.000    ,  35.000    ,
     $   34.000    ,  33.000    ,  32.000    ,  31.500    ,  31.000    ,
     $   30.500    ,  30.000    ,  29.500    ,  29.000    ,  28.500    ,
     $   28.000    ,  26.000    ,  23.000    ,  21.500    ,  20.000    ,
     $   19.000    ,  18.000    ,  17.000    ,  13.000    ,  11.500    ,
     $   10.300    ,  9.4000    ,  9.0000    ,  8.8000    ,  7.0000    ,
     $   7.5000    /
C  NEUTRON_BAR
      DATA (CSEL(17,J),J=1,41) /
     $   185.88    ,  133.23    ,  119.37    ,  102.86    ,  93.102    ,
     $   82.752    ,  76.205    ,  71.008    ,  67.366    ,  64.096    ,
     $   60.891    ,  58.501    ,  55.735    ,  53.773    ,  51.839    ,
     $   49.671    ,  48.485    ,  47.045    ,  45.803    ,  44.306    ,
     $   42.623    ,  41.786    ,  41.115    ,  40.630    ,  40.129    ,
     $   38.242    ,  35.233    ,  32.662    ,  29.639    ,  27.573    ,
     $   25.536    ,  23.948    ,  22.356    ,  17.723    ,  15.614    ,
     $   13.653    ,  11.675    ,  10.653    ,  8.6198    ,  7.4464    ,
     $   7.4821    /
C  LAMBDA
      DATA (CSEL(18,J),J=1,41) /
     $   1100.0    ,  115.00    ,  105.00    ,  100.00    ,  56.000    ,
     $   40.000    ,  27.000    ,  22.000    ,  21.000    ,  20.000    ,
     $   20.000    ,  19.067    ,  19.333    ,  19.500    ,  19.833    ,
     $   20.567    ,  21.800    ,  22.900    ,  23.869    ,  23.809    ,
     $   22.161    ,  21.488    ,  19.732    ,  19.433    ,  19.345    ,
     $   19.029    ,  18.121    ,  16.280    ,  15.258    ,  14.280    ,
     $   13.644    ,  12.963    ,  12.316    ,  9.5333    ,  8.4333    ,
     $   7.5728    ,  6.9696    ,  6.7518    ,  6.6175    ,  5.6000    ,
     $   6.1145    /
C  LAMBDA_BAR
      DATA (CSEL(19,J),J=1,41) /
     $   157.65    ,  73.701    ,  76.096    ,  68.571    ,  57.305    ,
     $   49.257    ,  43.616    ,  40.024    ,  38.098    ,  36.287    ,
     $   34.674    ,  33.105    ,  31.712    ,  30.685    ,  29.613    ,
     $   28.602    ,  28.336    ,  28.075    ,  27.786    ,  27.215    ,
     $   26.380    ,  26.146    ,  25.108    ,  24.783    ,  24.360    ,
     $   23.219    ,  21.431    ,  20.095    ,  18.382    ,  17.267    ,
     $   16.100    ,  15.175    ,  14.271    ,  11.573    ,  10.305    ,
     $   9.1471    ,  8.0149    ,  7.4349    ,  6.2499    ,  5.8928    ,
     $   6.0774    /
C  SIGMA(+)
      DATA (CSEL(20,J),J=1,41) /
     $   1100.0    ,  115.00    ,  105.00    ,  100.00    ,  56.000    ,
     $   40.000    ,  27.000    ,  22.000    ,  21.000    ,  20.000    ,
     $   20.000    ,  19.067    ,  19.333    ,  19.500    ,  19.833    ,
     $   20.567    ,  21.800    ,  22.900    ,  23.869    ,  23.809    ,
     $   22.161    ,  21.488    ,  19.732    ,  19.433    ,  19.345    ,
     $   19.029    ,  18.121    ,  16.280    ,  15.258    ,  14.280    ,
     $   13.644    ,  12.963    ,  12.316    ,  9.5333    ,  8.4333    ,
     $   7.5728    ,  6.9696    ,  6.7518    ,  6.6175    ,  5.6000    ,
     $   6.1145    /
C  SIGMA(-)
      DATA (CSEL(22,J),J=1,41) /
     $   1100.0    ,  115.00    ,  105.00    ,  100.00    ,  56.000    ,
     $   40.000    ,  27.000    ,  22.000    ,  21.000    ,  20.000    ,
     $   20.000    ,  19.067    ,  19.333    ,  19.500    ,  19.833    ,
     $   20.567    ,  21.800    ,  22.900    ,  23.869    ,  23.809    ,
     $   22.161    ,  21.488    ,  19.732    ,  19.433    ,  19.345    ,
     $   19.029    ,  18.121    ,  16.280    ,  15.258    ,  14.280    ,
     $   13.644    ,  12.963    ,  12.316    ,  9.5333    ,  8.4333    ,
     $   7.5728    ,  6.9696    ,  6.7518    ,  6.6175    ,  5.6000    ,
     $   6.1145    /
C  SIGMA(+)_BAR
      DATA (CSEL(23,J),J=1,41) /
     $   185.88    ,  133.23    ,  119.37    ,  102.86    ,  93.102    ,
     $   82.752    ,  76.205    ,  71.008    ,  67.366    ,  64.096    ,
     $   60.891    ,  58.104    ,  55.241    ,  53.140    ,  50.934    ,
     $   48.660    ,  47.566    ,  46.585    ,  45.581    ,  44.003    ,
     $   41.134    ,  39.374    ,  36.878    ,  35.523    ,  34.503    ,
     $   32.334    ,  29.365    ,  27.370    ,  24.705    ,  22.921    ,
     $   21.229    ,  19.879    ,  18.559    ,  14.625    ,  12.758    ,
     $   11.041    ,  9.3440    ,  8.5484    ,  6.7104    ,  6.0000    ,
     $   6.1131    /
C  SIGMA(-)_BAR
      DATA (CSEL(25,J),J=1,41) /
     $   157.65    ,  73.701    ,  76.096    ,  68.571    ,  57.305    ,
     $   49.257    ,  43.616    ,  40.024    ,  38.098    ,  36.287    ,
     $   34.674    ,  33.105    ,  31.712    ,  30.685    ,  29.613    ,
     $   28.602    ,  28.336    ,  28.075    ,  27.786    ,  27.215    ,
     $   26.380    ,  26.146    ,  25.108    ,  24.783    ,  24.360    ,
     $   23.219    ,  21.431    ,  20.095    ,  18.382    ,  17.267    ,
     $   16.100    ,  15.175    ,  14.271    ,  11.573    ,  10.305    ,
     $   9.1471    ,  8.0149    ,  7.4349    ,  6.2499    ,  5.8928    ,
     $   6.0774    /
C  XI(0)
      DATA (CSEL(26,J),J=1,41) /
     $   1100.0    ,  115.00    ,  105.00    ,  100.00    ,  56.000    ,
     $   40.000    ,  27.000    ,  22.000    ,  21.000    ,  20.000    ,
     $   20.000    ,  18.133    ,  18.167    ,  18.000    ,  17.667    ,
     $   18.133    ,  19.600    ,  21.800    ,  23.338    ,  23.118    ,
     $   19.323    ,  17.476    ,  13.464    ,  12.367    ,  11.691    ,
     $   11.057    ,  10.242    ,  9.5593    ,  9.0151    ,  8.5591    ,
     $   8.2884    ,  7.9253    ,  7.6311    ,  6.0667    ,  5.3667    ,
     $   4.8456    ,  4.5392    ,  4.5036    ,  4.4351    ,  4.2000    ,
     $   4.7289    /
C  XI(-)
      DATA (CSEL(27,J),J=1,41) /
     $   1100.0    ,  115.00    ,  105.00    ,  100.00    ,  56.000    ,
     $   40.000    ,  27.000    ,  22.000    ,  21.000    ,  20.000    ,
     $   20.000    ,  18.133    ,  18.167    ,  18.000    ,  17.667    ,
     $   18.133    ,  19.600    ,  21.800    ,  23.338    ,  23.118    ,
     $   19.323    ,  17.476    ,  13.464    ,  12.367    ,  11.691    ,
     $   11.057    ,  10.242    ,  9.5593    ,  9.0151    ,  8.5591    ,
     $   8.2884    ,  7.9253    ,  7.6311    ,  6.0667    ,  5.3667    ,
     $   4.8456    ,  4.5392    ,  4.5036    ,  4.4351    ,  4.2000    ,
     $   4.7289    /
C  XI(0)_BAR
      DATA (CSEL(28,J),J=1,41) /
     $   157.65    ,  73.701    ,  76.096    ,  68.571    ,  57.305    ,
     $   49.257    ,  43.616    ,  40.024    ,  38.098    ,  36.287    ,
     $   34.674    ,  32.708    ,  31.218    ,  30.052    ,  28.707    ,
     $   27.591    ,  27.417    ,  27.615    ,  27.564    ,  26.913    ,
     $   24.891    ,  23.734    ,  20.871    ,  19.677    ,  18.734    ,
     $   17.311    ,  15.563    ,  14.803    ,  13.448    ,  12.615    ,
     $   11.794    ,  11.106    ,  10.474    ,  8.4745    ,  7.4498    ,
     $   6.5350    ,  5.6835    ,  5.3300    ,  4.3406    ,  4.4464    ,
     $   4.7083    /
C  XI(-)_BAR
      DATA (CSEL(29,J),J=1,41) /
     $   143.53    ,  43.935    ,  54.462    ,  51.429    ,  39.407    ,
     $   32.510    ,  27.321    ,  24.532    ,  23.465    ,  22.383    ,
     $   21.566    ,  20.209    ,  19.453    ,  18.825    ,  18.046    ,
     $   17.562    ,  17.802    ,  18.360    ,  18.667    ,  18.519    ,
     $   17.514    ,  17.120    ,  14.985    ,  14.306    ,  13.663    ,
     $   12.753    ,  11.596    ,  11.165    ,  10.287    ,  9.7882    ,
     $   9.2294    ,  8.7539    ,  8.3300    ,  6.9480    ,  6.2234    ,
     $   5.5881    ,  5.0189    ,  4.7733    ,  4.1104    ,  4.3929    ,
     $   4.6905    /
C  OMEGA(-)
      DATA (CSEL(33,J),J=1,41) /
     $   1100.0    ,  115.00    ,  105.00    ,  100.00    ,  56.000    ,
     $   40.000    ,  27.000    ,  22.000    ,  21.000    ,  20.000    ,
     $   20.000    ,  18.133    ,  18.167    ,  18.000    ,  17.667    ,
     $   18.133    ,  19.600    ,  21.800    ,  23.338    ,  23.118    ,
     $   19.323    ,  17.476    ,  13.464    ,  12.367    ,  11.691    ,
     $   11.057    ,  10.242    ,  9.5593    ,  9.0151    ,  8.5591    ,
     $   8.2884    ,  7.9253    ,  7.6311    ,  6.0667    ,  5.3667    ,
     $   4.8456    ,  4.5392    ,  4.5036    ,  4.4351    ,  4.2000    ,
     $   4.7289    /
C  OMEGA(-)_BAR
      DATA (CSEL(34,J),J=1,41) /
     $   143.53    ,  43.935    ,  54.462    ,  51.429    ,  39.407    ,
     $   32.510    ,  27.321    ,  24.532    ,  23.465    ,  22.383    ,
     $   21.566    ,  20.209    ,  19.453    ,  18.825    ,  18.046    ,
     $   17.562    ,  17.802    ,  18.360    ,  18.667    ,  18.519    ,
     $   17.514    ,  17.120    ,  14.985    ,  14.306    ,  13.663    ,
     $   12.753    ,  11.596    ,  11.165    ,  10.287    ,  9.7882    ,
     $   9.2294    ,  8.7539    ,  8.3300    ,  6.9480    ,  6.2234    ,
     $   5.5881    ,  5.0189    ,  4.7733    ,  4.1104    ,  4.3929    ,
     $   4.6905    /

C  INELASTIC CROSS-SECTIONS ON FREE PROTONS
C  GAMMA, NEUTRINO, POSITRON, ELECTRON, MU(+), MU(-)
      DATA ((CSIN(I,J),I=1,6),J=1,41) / 246 * 0. /
C  PI(0)
      DATA (CSIN( 8,J),J=1,41) / 41 * 0. /
C  SIGMA(0)
      DATA (CSIN(21,J),J=1,41) / 41 * 0. /
C  SIGMA(0)_BAR
      DATA (CSIN(24,J),J=1,41) / 41 * 0. /
C  DEUTERIUM, TRITIUM, ALPHA
      DATA ((CSIN(I,J),I=30,32),J=1,41) / 123 * 0. /
C  NEW PARTICLES
      DATA (CSIN(35,J),J=1,41) / 41 * 0. /
C  PI(+)
      DATA (CSIN( 7,J),J=1,41) /
     $  0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,
     $  0.00000E+00, 0.00000E+00, 0.50000    ,  1.2000    ,  1.7000    ,
     $   2.2500    ,  3.0000    ,  3.6000    ,  4.5000    ,  5.4000    ,
     $   6.3000    ,  8.6000    ,  9.0000    ,  10.000    ,  11.500    ,
     $   14.000    ,  17.000    ,  19.500    ,  22.000    ,  24.000    ,
     $   21.500    ,  18.500    ,  19.000    ,  20.500    ,  22.200    ,
     $   23.000    ,  23.300    ,  23.000    ,  21.000    ,  20.500    ,
     $   20.200    ,  20.100    ,  20.000    ,  20.000    ,  20.000    ,
     $   21.000    /
C  PI(-)
      DATA (CSIN( 9,J),J=1,41) /
     $  0.00000E+00,  3.0000    ,  9.2000    ,  20.500    ,  36.500    ,
     $   45.000    ,  28.000    ,  19.500    ,  15.500    ,  14.200    ,
     $   15.500    ,  17.500    ,  20.000    ,  23.000    ,  26.000    ,
     $   20.000    ,  23.000    ,  26.500    ,  32.000    ,  35.000    ,
     $   28.500    ,  22.000    ,  22.500    ,  23.500    ,  24.000    ,
     $   24.500    ,  26.000    ,  27.500    ,  27.500    ,  27.000    ,
     $   26.500    ,  25.500    ,  25.000    ,  23.000    ,  22.500    ,
     $   22.200    ,  22.000    ,  22.000    ,  21.200    ,  20.700    ,
     $   21.000    /
C  K(+)
      DATA (CSIN(10,J),J=1,41) /
     $  0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,
     $  0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,
     $  0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,
     $  0.50000    ,  1.5000    ,  2.7000    ,  3.8000    ,  4.8000    ,
     $   6.5000    ,  7.6000    ,  8.4000    ,  9.0000    ,  9.4000    ,
     $   9.8000    ,  10.500    ,  11.000    ,  11.500    ,  11.800    ,
     $   12.200    ,  12.400    ,  12.600    ,  13.200    ,  13.500    ,
     $   13.700    ,  14.000    ,  14.200    ,  14.500    ,  16.400    ,
     $   17.000    /
C  K(0) SHORT
      DATA (CSIN(11,J),J=1,41) /
     $  0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,
     $  0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,
     $  0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,
     $  0.50000    ,  1.5000    ,  2.7000    ,  3.8000    ,  4.8000    ,
     $   6.5000    ,  7.6000    ,  8.4000    ,  9.0000    ,  9.4000    ,
     $   9.8000    ,  10.500    ,  11.000    ,  11.500    ,  11.800    ,
     $   12.200    ,  12.400    ,  12.600    ,  13.200    ,  13.500    ,
     $   13.700    ,  14.000    ,  14.200    ,  14.500    ,  16.400    ,
     $   17.000    /
C  K(0) LONG
      DATA (CSIN(12,J),J=1,41) /
     $   266.67    ,  133.33    ,  83.333    ,  57.083    ,  44.500    ,
     $   33.250    ,  24.583    ,  20.833    ,  18.333    ,  16.083    ,
     $   15.625    ,  15.083    ,  14.833    ,  15.083    ,  15.833    ,
     $   17.042    ,  18.958    ,  20.758    ,  22.533    ,  22.825    ,
     $   21.250    ,  18.567    ,  17.767    ,  18.100    ,  19.933    ,
     $   20.783    ,  21.225    ,  21.000    ,  20.558    ,  20.258    ,
     $   20.017    ,  19.767    ,  19.600    ,  19.183    ,  18.850    ,
     $   18.575    ,  18.350    ,  18.175    ,  17.808    ,  17.558    ,
     $   19.250    /
C  K(-)
      DATA (CSIN(13,J),J=1,41) /
     $   400.00    ,  200.00    ,  120.00    ,  81.000    ,  62.000    ,
     $   47.000    ,  35.000    ,  28.000    ,  24.000    ,  21.000    ,
     $   19.500    ,  19.000    ,  18.800    ,  19.000    ,  20.000    ,
     $   21.000    ,  23.000    ,  25.000    ,  27.000    ,  27.500    ,
     $   25.500    ,  22.000    ,  20.800    ,  21.000    ,  23.000    ,
     $   24.000    ,  24.000    ,  23.800    ,  23.000    ,  22.500    ,
     $   22.000    ,  21.600    ,  21.400    ,  21.000    ,  20.500    ,
     $   20.200    ,  19.800    ,  19.500    ,  18.600    ,  17.500    ,
     $   20.000    /
C  PROTON
      DATA (CSIN(14,J),J=1,41) /
     $  0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,
     $  0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,
     $  0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,
     $  0.00000E+00, 0.00000E+00, 0.00000E+00, 0.10000    ,  1.5000    ,
     $   7.0000    ,  12.000    ,  17.000    ,  19.500    ,  20.500    ,
     $   22.000    ,  23.500    ,  24.800    ,  25.800    ,  26.500    ,
     $   27.000    ,  27.500    ,  28.000    ,  30.000    ,  31.000    ,
     $   32.000    ,  32.500    ,  32.500    ,  33.000    ,  33.500    ,
     $   34.000    /
C  PROTON_BAR
      DATA (CSIN(15,J),J=1,41) /
     $   1500.0    ,  1160.0    ,  310.00    ,  230.00    ,  178.00    ,
     $   153.00    ,  134.00    ,  124.00    ,  113.00    ,  106.00    ,
     $   101.00    ,  96.000    ,  92.000    ,  89.000    ,  87.000    ,
     $   84.000    ,  81.000    ,  78.500    ,  76.500    ,  75.000    ,
     $   72.000    ,  70.000    ,  68.000    ,  64.500    ,  63.000    ,
     $   62.000    ,  61.000    ,  59.500    ,  58.500    ,  56.500    ,
     $   56.500    ,  56.000    ,  55.500    ,  52.000    ,  50.000    ,
     $   48.000    ,  45.000    ,  44.000    ,  39.200    ,  34.500    ,
     $   34.500    /
C  NEUTRON
      DATA (CSIN(16,J),J=1,41) /
     $  0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,
     $  0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,
     $  0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,
     $  0.00000E+00, 0.00000E+00, 0.00000E+00, 0.10000    ,  1.5000    ,
     $   7.0000    ,  12.000    ,  17.000    ,  19.500    ,  20.500    ,
     $   22.000    ,  23.500    ,  24.800    ,  25.800    ,  26.500    ,
     $   27.000    ,  27.500    ,  28.000    ,  30.000    ,  31.000    ,
     $   32.000    ,  32.500    ,  32.500    ,  33.000    ,  33.500    ,
     $   34.000    /
C  NEUTRON_BAR
      DATA (CSIN(17,J),J=1,41) /
     $   1394.1    ,  948.17    ,  262.43    ,  197.14    ,  149.30    ,
     $   127.25    ,  110.39    ,  101.79    ,  92.834    ,  87.104    ,
     $   83.109    ,  79.099    ,  75.965    ,  73.627    ,  72.161    ,
     $   69.889    ,  67.595    ,  65.595    ,  64.057    ,  63.054    ,
     $   61.377    ,  60.434    ,  59.485    ,  56.970    ,  55.931    ,
     $   55.398    ,  54.827    ,  53.538    ,  52.861    ,  51.247    ,
     $   51.344    ,  50.992    ,  50.644    ,  47.876    ,  46.358    ,
     $   44.887    ,  42.577    ,  41.815    ,  38.180    ,  34.254    ,
     $   34.418    /
C  LAMBDA
      DATA (CSIN(18,J),J=1,41) /
     $  0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,
     $  0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,
     $  0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,
     $  0.00000E+00, 0.00000E+00, 0.00000E+00, 0.97815E-01,  1.4577    ,
     $   6.2052    ,  10.112    ,  12.902    ,  14.300    ,  14.688    ,
     $   15.505    ,  16.379    ,  17.554    ,  18.309    ,  18.920    ,
     $   19.389    ,  19.804    ,  20.284    ,  22.000    ,  22.733    ,
     $   23.527    ,  24.097    ,  24.382    ,  24.816    ,  26.800    ,
     $   27.719    /
C  LAMBDA_BAR
      DATA (CSIN(19,J),J=1,41) /
     $   1182.4    ,  524.50    ,  167.30    ,  131.43    ,  91.895    ,
     $   75.743    ,  63.184    ,  57.376    ,  52.502    ,  49.313    ,
     $   47.326    ,  44.762    ,  43.222    ,  42.015    ,  41.221    ,
     $   40.244    ,  39.504    ,  39.145    ,  38.860    ,  38.731    ,
     $   37.987    ,  37.814    ,  36.326    ,  34.750    ,  33.953    ,
     $   33.635    ,  33.349    ,  32.938    ,  32.785    ,  32.092    ,
     $   32.373    ,  32.312    ,  32.329    ,  31.261    ,  30.597    ,
     $   30.073    ,  29.228    ,  29.182    ,  27.683    ,  27.107    ,
     $   27.956    /
C  SIGMA(+)
      DATA (CSIN(20,J),J=1,41) /
     $  0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,
     $  0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,
     $  0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,
     $  0.00000E+00, 0.00000E+00, 0.00000E+00, 0.97815E-01,  1.4577    ,
     $   6.2052    ,  10.112    ,  12.902    ,  14.300    ,  14.688    ,
     $   15.505    ,  16.379    ,  17.554    ,  18.309    ,  18.920    ,
     $   19.389    ,  19.804    ,  20.284    ,  22.000    ,  22.733    ,
     $   23.527    ,  24.097    ,  24.382    ,  24.816    ,  26.800    ,
     $   27.719    /
C  SIGMA(-)
      DATA (CSIN(22,J),J=1,41) /
     $  0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,
     $  0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,
     $  0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,
     $  0.00000E+00, 0.00000E+00, 0.00000E+00, 0.97815E-01,  1.4577    ,
     $   6.2052    ,  10.112    ,  12.902    ,  14.300    ,  14.688    ,
     $   15.505    ,  16.379    ,  17.554    ,  18.309    ,  18.920    ,
     $   19.389    ,  19.804    ,  20.284    ,  22.000    ,  22.733    ,
     $   23.527    ,  24.097    ,  24.382    ,  24.816    ,  26.800    ,
     $   27.719    /
C  SIGMA(+)_BAR
      DATA (CSIN(23,J),J=1,41) /
     $   1394.1    ,  948.17    ,  262.43    ,  197.14    ,  149.30    ,
     $   127.25    ,  110.39    ,  101.79    ,  92.834    ,  87.104    ,
     $   83.109    ,  78.563    ,  75.292    ,  72.760    ,  70.900    ,
     $   68.467    ,  66.314    ,  64.955    ,  63.746    ,  62.623    ,
     $   59.233    ,  56.946    ,  53.355    ,  49.810    ,  48.090    ,
     $   46.839    ,  45.695    ,  44.863    ,  44.062    ,  42.599    ,
     $   42.684    ,  42.328    ,  42.041    ,  39.508    ,  37.880    ,
     $   36.299    ,  34.075    ,  33.553    ,  29.723    ,  27.600    ,
     $   28.120    /
C  SIGMA(-)_BAR
      DATA (CSIN(25,J),J=1,41) /
     $   1182.4    ,  524.50    ,  167.30    ,  131.43    ,  91.895    ,
     $   75.743    ,  63.184    ,  57.376    ,  52.502    ,  49.313    ,
     $   47.326    ,  44.762    ,  43.222    ,  42.015    ,  41.221    ,
     $   40.244    ,  39.504    ,  39.145    ,  38.860    ,  38.731    ,
     $   37.987    ,  37.814    ,  36.326    ,  34.750    ,  33.953    ,
     $   33.635    ,  33.349    ,  32.938    ,  32.785    ,  32.092    ,
     $   32.373    ,  32.312    ,  32.329    ,  31.261    ,  30.597    ,
     $   30.073    ,  29.228    ,  29.182    ,  27.683    ,  27.107    ,
     $   27.956    /
C  XI(0)
      DATA (CSIN(26,J),J=1,41) /
     $  0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,
     $  0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,
     $  0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,
     $  0.00000E+00, 0.00000E+00, 0.00000E+00, 0.95639E-01,  1.4154    ,
     $   5.4104    ,  8.2240    ,  8.8031    ,  9.1000    ,  8.8761    ,
     $   9.0095    ,  9.2576    ,  10.307    ,  10.818    ,  11.341    ,
     $   11.778    ,  12.108    ,  12.569    ,  14.000    ,  14.467    ,
     $   15.054    ,  15.694    ,  16.263    ,  16.632    ,  20.100    ,
     $   21.438    /
C  XI(-)
      DATA (CSIN(27,J),J=1,41) /
     $  0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,
     $  0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,
     $  0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,
     $  0.00000E+00, 0.00000E+00, 0.00000E+00, 0.95639E-01,  1.4154    ,
     $   5.4104    ,  8.2240    ,  8.8031    ,  9.1000    ,  8.8761    ,
     $   9.0095    ,  9.2576    ,  10.307    ,  10.818    ,  11.341    ,
     $   11.778    ,  12.108    ,  12.569    ,  14.000    ,  14.467    ,
     $   15.054    ,  15.694    ,  16.263    ,  16.632    ,  20.100    ,
     $   21.438    /
C  XI(0)_BAR
      DATA (CSIN(28,J),J=1,41) /
     $   1182.4    ,  524.50    ,  167.30    ,  131.43    ,  91.895    ,
     $   75.743    ,  63.184    ,  57.376    ,  52.502    ,  49.313    ,
     $   47.326    ,  44.225    ,  42.549    ,  41.148    ,  39.960    ,
     $   38.822    ,  38.223    ,  38.505    ,  38.549    ,  38.301    ,
     $   35.843    ,  34.326    ,  30.196    ,  27.590    ,  26.112    ,
     $   25.076    ,  24.217    ,  24.264    ,  23.985    ,  23.445    ,
     $   23.713    ,  23.647    ,  23.726    ,  22.892    ,  22.119    ,
     $   21.485    ,  20.726    ,  20.921    ,  19.226    ,  20.454    ,
     $   21.658    /
C  XI(-)_BAR
      DATA (CSIN(29,J),J=1,41) /
     $   1076.5    ,  312.66    ,  119.74    ,  98.571    ,  63.193    ,
     $   49.990    ,  39.579    ,  35.168    ,  32.335    ,  30.417    ,
     $   29.434    ,  27.325    ,  26.514    ,  25.775    ,  25.120    ,
     $   24.711    ,  24.818    ,  25.600    ,  26.106    ,  26.355    ,
     $   25.220    ,  24.760    ,  21.681    ,  20.060    ,  19.044    ,
     $   18.474    ,  18.044    ,  18.301    ,  18.347    ,  18.192    ,
     $   18.557    ,  18.639    ,  18.870    ,  18.769    ,  18.478    ,
     $   18.372    ,  18.302    ,  18.735    ,  18.206    ,  20.207    ,
     $   21.576    /
C  OMEGA(-)
      DATA (CSIN(33,J),J=1,41) /
     $  0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,
     $  0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,
     $  0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,
     $  0.00000E+00, 0.00000E+00, 0.00000E+00, 0.95639E-01,  1.4154    ,
     $   5.4104    ,  8.2240    ,  8.8031    ,  9.1000    ,  8.8761    ,
     $   9.0095    ,  9.2576    ,  10.307    ,  10.818    ,  11.341    ,
     $   11.778    ,  12.108    ,  12.569    ,  14.000    ,  14.467    ,
     $   15.054    ,  15.694    ,  16.263    ,  16.632    ,  20.100    ,
     $   21.438    /
C  OMEGA(-)_BAR
      DATA (CSIN(34,J),J=1,41) /
     $   1076.5    ,  312.66    ,  119.74    ,  98.571    ,  63.193    ,
     $   49.990    ,  39.579    ,  35.168    ,  32.335    ,  30.417    ,
     $   29.434    ,  27.325    ,  26.514    ,  25.775    ,  25.120    ,
     $   24.711    ,  24.818    ,  25.600    ,  26.106    ,  26.355    ,
     $   25.220    ,  24.760    ,  21.681    ,  20.060    ,  19.044    ,
     $   18.474    ,  18.044    ,  18.301    ,  18.347    ,  18.192    ,
     $   18.557    ,  18.639    ,  18.870    ,  18.769    ,  18.478    ,
     $   18.372    ,  18.302    ,  18.735    ,  18.206    ,  20.207    ,
     $   21.576    /

C  ELASTIC CROSS-SECTION FOR MEDI WITH PIONS
C  ALUMINIUM
      DATA (CSPIEL( 1,J),J=1,41) /
     $  0.00000E+00,  350.00    ,  580.00    ,  600.00    ,  550.00    ,
     $   450.00    ,  410.00    ,  370.00    ,  340.00    ,  230.00    ,
     $   220.00    ,  205.00    ,  180.00    ,  155.00    ,  145.00    ,
     $   140.00    ,  160.00    ,  195.00    ,  235.00    ,  250.00    ,
     $   270.00    ,  280.00    ,  300.00    ,  300.00    ,  290.00    ,
     $   285.00    ,  265.00    ,  240.00    ,  230.00    ,  222.00    ,
     $   204.00    ,  196.00    ,  190.00    ,  170.00    ,  170.00    ,
     $   160.00    ,  150.00    ,  140.00    ,  120.00    ,  80.000    ,
     $   80.000    /
C  COPPER
      DATA (CSPIEL( 2,J),J=1,41) /
     $  0.00000E+00,  700.00    ,  1000.0    ,  1200.0    ,  1300.0    ,
     $   1300.0    ,  1250.0    ,  1250.0    ,  1100.0    ,  1000.0    ,
     $   940.00    ,  740.00    ,  700.00    ,  670.00    ,  660.00    ,
     $   670.00    ,  680.00    ,  700.00    ,  735.00    ,  800.00    ,
     $   810.00    ,  820.00    ,  820.00    ,  810.00    ,  800.00    ,
     $   800.00    ,  700.00    ,  600.00    ,  500.00    ,  470.00    ,
     $   440.00    ,  410.00    ,  380.00    ,  330.00    ,  330.00    ,
     $   330.00    ,  330.00    ,  330.00    ,  285.00    ,  240.00    ,
     $   240.00    /
C  LEAD
      DATA (CSPIEL( 3,J),J=1,41) /
     $  0.00000E+00,  1700.0    ,  2200.0    ,  2200.0    ,  1800.0    ,
     $   1300.0    ,  1200.0    ,  900.00    ,  900.00    ,  1000.0    ,
     $   1100.0    ,  1300.0    ,  1400.0    ,  1420.0    ,  1490.0    ,
     $   1560.0    ,  1580.0    ,  1690.0    ,  1795.0    ,  2000.0    ,
     $   2070.0    ,  2140.0    ,  2050.0    ,  2010.0    ,  1970.0    ,
     $   1880.0    ,  1690.0    ,  1500.0    ,  1420.0    ,  1390.0    ,
     $   1350.0    ,  1360.0    ,  1370.0    ,  1280.0    ,  1290.0    ,
     $   1295.0    ,  1250.0    ,  1200.0    ,  1050.0    ,  900.00    ,
     $   900.00    /
C  INELASTIC CROSS-SECTION FOR MEDIA WITH PIONS
C  ALIMINUIM
      DATA (CSPIIN( 1,J),J=1,41) /
     $  0.00000E+00,  200.00    ,  320.00    ,  500.00    ,  600.00    ,
     $   600.00    ,  590.00    ,  530.00    ,  510.00    ,  470.00    ,
     $   430.00    ,  425.00    ,  420.00    ,  425.00    ,  425.00    ,
     $   430.00    ,  430.00    ,  435.00    ,  435.00    ,  440.00    ,
     $   430.00    ,  430.00    ,  420.00    ,  420.00    ,  420.00    ,
     $   415.00    ,  415.00    ,  410.00    ,  410.00    ,  408.00    ,
     $   406.00    ,  404.00    ,  400.00    ,  380.00    ,  340.00    ,
     $   340.00    ,  340.00    ,  340.00    ,  340.00    ,  340.00    ,
     $   340.00    /
C  COPPER
      DATA (CSPIIN( 2,J),J=1,41) /
     $  0.00000E+00,  400.00    ,  800.00    ,  1000.0    ,  1100.0    ,
     $   1200.0    ,  1150.0    ,  1050.0    ,  1000.0    ,  900.00    ,
     $   860.00    ,  860.00    ,  850.00    ,  850.00    ,  840.00    ,
     $   830.00    ,  820.00    ,  810.00    ,  805.00    ,  800.00    ,
     $   800.00    ,  800.00    ,  800.00    ,  800.00    ,  800.00    ,
     $   800.00    ,  800.00    ,  800.00    ,  800.00    ,  780.00    ,
     $   760.00    ,  740.00    ,  720.00    ,  720.00    ,  700.00    ,
     $   690.00    ,  680.00    ,  670.00    ,  665.00    ,  660.00    ,
     $   660.00    /
C  LEAD
      DATA (CSPIIN( 3,J),J=1,41) /
     $  0.00000E+00,  1000.0    ,  1900.0    ,  2600.0    ,  2900.0    ,
     $   3000.0    ,  2800.0    ,  2600.0    ,  2500.0    ,  2300.0    ,
     $   2200.0    ,  2000.0    ,  1900.0    ,  1880.0    ,  1860.0    ,
     $   1840.0    ,  1820.0    ,  1810.0    ,  1805.0    ,  1800.0    ,
     $   1780.0    ,  1760.0    ,  1750.0    ,  1740.0    ,  1730.0    ,
     $   1720.0    ,  1710.0    ,  1700.0    ,  1680.0    ,  1660.0    ,
     $   1650.0    ,  1640.0    ,  1630.0    ,  1620.0    ,  1610.0    ,
     $   1605.0    ,  1600.0    ,  1600.0    ,  1550.0    ,  1500.0    ,
     $   1500.0    /
C  ELASTIC CROSS-SECTION FOR MEDI WITH NUCLEONS
C  ALUMINIUM
      DATA (CSPNEL( 1,J),J=1,41) /
     $   2100.0    ,  1800.0    ,  1500.0    ,  1050.0    ,  900.00    ,
     $   950.00    ,  800.00    ,  650.00    ,  570.00    ,  390.00    ,
     $   300.00    ,  240.00    ,  230.00    ,  230.00    ,  220.00    ,
     $   220.00    ,  225.00    ,  225.00    ,  240.00    ,  240.00    ,
     $   290.00    ,  330.00    ,  335.00    ,  350.00    ,  355.00    ,
     $   370.00    ,  350.00    ,  330.00    ,  310.00    ,  290.00    ,
     $   270.00    ,  265.00    ,  260.00    ,  230.00    ,  210.00    ,
     $   210.00    ,  200.00    ,  200.00    ,  190.00    ,  180.00    ,
     $   180.00    /
C  COPPER
      DATA (CSPNEL( 2,J),J=1,41) /
     $   3800.0    ,  2900.0    ,  1850.0    ,  1550.0    ,  1450.0    ,
     $   1520.0    ,  1460.0    ,  1300.0    ,  1140.0    ,  880.00    ,
     $   700.00    ,  620.00    ,  540.00    ,  560.00    ,  460.00    ,
     $   460.00    ,  470.00    ,  470.00    ,  480.00    ,  480.00    ,
     $   580.00    ,  600.00    ,  610.00    ,  620.00    ,  620.00    ,
     $   620.00    ,  590.00    ,  580.00    ,  460.00    ,  440.00    ,
     $   420.00    ,  400.00    ,  480.00    ,  430.00    ,  380.00    ,
     $   380.00    ,  380.00    ,  380.00    ,  380.00    ,  380.00    ,
     $   380.00    /
C  LEAD
      DATA (CSPNEL( 3,J),J=1,41) /
     $   7000.0    ,  6000.0    ,  4500.0    ,  3350.0    ,  2700.0    ,
     $   3000.0    ,  3550.0    ,  3970.0    ,  3280.0    ,  2490.0    ,
     $   2100.0    ,  1510.0    ,  1440.0    ,  1370.0    ,  1370.0    ,
     $   1370.0    ,  1400.0    ,  1400.0    ,  1420.0    ,  1420.0    ,
     $   1440.0    ,  1460.0    ,  1460.0    ,  1450.0    ,  1450.0    ,
     $   1470.0    ,  1400.0    ,  1400.0    ,  1380.0    ,  1370.0    ,
     $   1360.0    ,  1350.0    ,  1340.0    ,  1330.0    ,  1320.0    ,
     $   1310.0    ,  1305.0    ,  1300.0    ,  1300.0    ,  1300.0    ,
     $   1300.0    /
C  INELASTIC CROSS-SECTION FOR MEDI WITH NUCLEONS
C  ALUMINIUM
      DATA (CSPNIN( 1,J),J=1,41) /
     $  0.00000E+00,  200.00    ,  400.00    ,  800.00    ,  800.00    ,
     $   550.00    ,  500.00    ,  450.00    ,  430.00    ,  410.00    ,
     $   400.00    ,  390.00    ,  380.00    ,  370.00    ,  370.00    ,
     $   370.00    ,  365.00    ,  365.00    ,  360.00    ,  360.00    ,
     $   360.00    ,  360.00    ,  365.00    ,  370.00    ,  375.00    ,
     $   380.00    ,  400.00    ,  410.00    ,  420.00    ,  430.00    ,
     $   440.00    ,  440.00    ,  440.00    ,  440.00    ,  440.00    ,
     $   440.00    ,  440.00    ,  440.00    ,  440.00    ,  440.00    ,
     $   440.00    /
C  COPPER
      DATA (CSPNIN( 2,J),J=1,41) /
     $  0.00000E+00,  400.00    ,  950.00    ,  1050.0    ,  1050.0    ,
     $   980.00    ,  940.00    ,  900.00    ,  860.00    ,  820.00    ,
     $   800.00    ,  780.00    ,  760.00    ,  740.00    ,  740.00    ,
     $   740.00    ,  730.00    ,  730.00    ,  720.00    ,  720.00    ,
     $   720.00    ,  720.00    ,  730.00    ,  740.00    ,  750.00    ,
     $   760.00    ,  800.00    ,  820.00    ,  820.00    ,  820.00    ,
     $   820.00    ,  820.00    ,  820.00    ,  820.00    ,  820.00    ,
     $   820.00    ,  820.00    ,  820.00    ,  820.00    ,  820.00    ,
     $   820.00    /
C  LEAD
      DATA (CSPNIN( 3,J),J=1,41) /
     $  0.00000E+00, 0.00000E+00,  500.00    ,  1450.0    ,  1700.0    ,
     $   1800.0    ,  1750.0    ,  1730.0    ,  1720.0    ,  1710.0    ,
     $   1700.0    ,  1690.0    ,  1660.0    ,  1630.0    ,  1630.0    ,
     $   1630.0    ,  1600.0    ,  1600.0    ,  1580.0    ,  1580.0    ,
     $   1580.0    ,  1580.0    ,  1600.0    ,  1630.0    ,  1650.0    ,
     $   1670.0    ,  1760.0    ,  1800.0    ,  1800.0    ,  1800.0    ,
     $   1800.0    ,  1800.0    ,  1800.0    ,  1800.0    ,  1800.0    ,
     $   1800.0    ,  1800.0    ,  1800.0    ,  1800.0    ,  1800.0    ,
     $   1800.0    /
      DATA ELAB /
     $  0.10000E-03, 0.20000E-03, 0.30000E-03, 0.40000E-03, 0.50000E-03,
     $  0.70000E-03, 0.10000E-02, 0.20000E-02, 0.30000E-02, 0.40000E-02,
     $  0.50000E-02, 0.70000E-02, 0.10000E-01, 0.15000E-01, 0.20000E-01,
     $  0.25000E-01, 0.32700E-01/
C  TABLES FOR VARIOUS ATOMIC WEIGHTS
      DATA CNLWAT /
     $   1.0000    ,  16.000    ,  27.000    ,  56.000    ,  59.000    ,
     $   64.000    ,  91.000    ,  112.00    ,  119.00    ,  127.00    ,
     $   137.00    ,  181.00    ,  207.00    ,  209.00    ,  238.00    /
      DATA (CNLWEL( 1,J),J=1,17) /
     $   6000.0    ,  5500.0    ,  5200.0    ,  4900.0    ,  4800.0    ,
     $   4400.0    ,  4000.0    ,  2900.0    ,  2200.0    ,  1800.0    ,
     $   1400.0    ,  1100.0    ,  900.00    ,  700.00    ,  600.00    ,
     $   560.00    ,  520.00    /
      DATA (CNLWEL( 2,J),J=1,17) /
     $   5400.0    ,  5050.0    ,  4800.0    ,  4600.0    ,  4399.0    ,
     $   4090.0    ,  3700.0    ,  2600.0    ,  1950.0    ,  1600.0    ,
     $   1300.0    ,  900.00    ,  700.00    ,  800.00    ,  1050.0    ,
     $   1250.0    ,  1320.0    /
      DATA (CNLWEL( 3,J),J=1,17) /
     $   5500.0    ,  5150.0    ,  4900.0    ,  4699.0    ,  4490.0    ,
     $   4150.0    ,  3750.0    ,  2790.0    ,  2100.0    ,  1650.0    ,
     $   1300.0    ,  950.00    ,  800.00    ,  860.00    ,  1000.0    ,
     $   1090.0    ,  1080.0    /
      DATA (CNLWEL( 4,J),J=1,17) /
     $   5499.0    ,  4970.0    ,  4450.0    ,  4080.0    ,  3750.0    ,
     $   3380.0    ,  2900.0    ,  2400.0    ,  2380.0    ,  2350.0    ,
     $   2300.0    ,  2100.0    ,  1720.0    ,  1370.0    ,  1200.0    ,
     $   1060.0    ,  870.00    /
      DATA (CNLWEL( 5,J),J=1,17) /
     $   5399.0    ,  4710.0    ,  4180.0    ,  3760.0    ,  3460.0    ,
     $   3150.0    ,  2730.0    ,  2270.0    ,  1850.0    ,  1850.0    ,
     $   2130.0    ,  2330.0    ,  2120.0    ,  1640.0    ,  1310.0    ,
     $   1100.0    ,  1050.0    /
      DATA (CNLWEL( 6,J),J=1,17) /
     $   5099.0    ,  4405.0    ,  3825.0    ,  3455.0    ,  3125.0    ,
     $   2695.0    ,  2350.0    ,  1850.0    ,  1580.0    ,  1820.0    ,
     $   2050.0    ,  2210.0    ,  2000.0    ,  1590.0    ,  1310.0    ,
     $   1120.0    ,  1040.0    /
      DATA (CNLWEL( 7,J),J=1,17) /
     $   6290.0    ,  5960.0    ,  5640.0    ,  5370.0    ,  5150.0    ,
     $   4800.0    ,  4250.0    ,  3150.0    ,  2470.0    ,  2100.0    ,
     $   2230.0    ,  2420.0    ,  2450.0    ,  2050.0    ,  1760.0    ,
     $   1550.0    ,  1330.0    /
      DATA (CNLWEL( 8,J),J=1,17) /
     $   6885.0    ,  6650.0    ,  6350.0    ,  6150.0    ,  6000.0    ,
     $   5700.0    ,  5360.0    ,  4250.0    ,  2800.0    ,  1870.0    ,
     $   1810.0    ,  1820.0    ,  2170.0    ,  2450.0    ,  2150.0    ,
     $   1700.0    ,  1390.0    /
      DATA (CNLWEL( 9,J),J=1,17) /
     $   6600.0    ,  6500.0    ,  6400.0    ,  6249.0    ,  6190.0    ,
     $   5950.0    ,  5520.0    ,  4250.0    ,  2750.0    ,  1900.0    ,
     $   1850.0    ,  1950.0    ,  2340.0    ,  2800.0    ,  2540.0    ,
     $   2100.0    ,  1760.0    /
      DATA (CNLWEL(10,J),J=1,17) /
     $   7400.0    ,  7200.0    ,  6999.0    ,  6840.0    ,  6655.0    ,
     $   6320.0    ,  5820.0    ,  4400.0    ,  2850.0    ,  2000.0    ,
     $   1800.0    ,  1800.0    ,  2150.0    ,  2600.0    ,  2350.0    ,
     $   1950.0    ,  2100.0    /
      DATA (CNLWEL(11,J),J=1,17) /
     $   7900.0    ,  7700.0    ,  7499.0    ,  7390.0    ,  7202.0    ,
     $   6810.0    ,  6360.0    ,  4920.0    ,  3450.0    ,  2600.0    ,
     $   2200.0    ,  1950.0    ,  2300.0    ,  2800.0    ,  2650.0    ,
     $   2250.0    ,  2050.0    /
      DATA (CNLWEL(12,J),J=1,17) /
     $   7900.0    ,  7750.0    ,  7699.0    ,  7590.0    ,  7450.0    ,
     $   7200.0    ,  6850.0    ,  5650.0    ,  4400.0    ,  3700.0    ,
     $   3400.0    ,  2800.0    ,  2700.0    ,  3100.0    ,  3250.0    ,
     $   3100.0    ,  2750.0    /
      DATA (CNLWEL(13,J),J=1,17) /
     $   6100.0    ,  5950.0    ,  5750.0    ,  5599.0    ,  5440.0    ,
     $   5200.0    ,  4800.0    ,  4300.0    ,  5800.0    ,  5750.0    ,
     $   4800.0    ,  3420.0    ,  2650.0    ,  3200.0    ,  3650.0    ,
     $   3500.0    ,  2980.0    /
      DATA (CNLWEL(14,J),J=1,17) /
     $   6100.0    ,  5950.0    ,  5750.0    ,  5599.0    ,  5440.0    ,
     $   5200.0    ,  4800.0    ,  4300.0    ,  5800.0    ,  5750.0    ,
     $   4800.0    ,  3420.0    ,  2650.0    ,  3200.0    ,  3650.0    ,
     $   3500.0    ,  2980.0    /
      DATA (CNLWEL(15,J),J=1,17) /
     $   6600.0    ,  6350.0    ,  6100.0    ,  5899.0    ,  5690.0    ,
     $   5300.0    ,  4850.0    ,  4450.0    ,  5650.0    ,  5700.0    ,
     $   4950.0    ,  3850.0    ,  3050.0    ,  3050.0    ,  3460.0    ,
     $   3650.0    ,  3340.0    /
      DATA (CNLWIN( 1,J),J=1,17) / 17*0.0E+00 /
      DATA (CNLWIN( 2,J),J=1,17) /
     $  0.00000E+00, 0.00000E+00, 0.00000E+00, 0.00000E+00,  1.0000    ,
     $   10.000    ,  50.000    ,  100.00    ,  200.00    ,  300.00    ,
     $   400.00    ,  600.00    ,  700.00    ,  750.00    ,  700.00    ,
     $   700.00    ,  680.00    /
      DATA (CNLWIN( 3,J),J=1,17) /
     $  0.00000E+00, 0.00000E+00, 0.00000E+00,  1.0000    ,  10.000    ,
     $   50.000    ,  100.00    ,  260.00    ,  450.00    ,  600.00    ,
     $   700.00    ,  800.00    ,  900.00    ,  940.00    ,  900.00    ,
     $   860.00    ,  820.00    /
      DATA (CNLWIN( 4,J),J=1,17) /
     $   1.0000    ,  80.000    ,  200.00    ,  320.00    ,  400.00    ,
     $   520.00    ,  700.00    ,  1000.0    ,  1120.0    ,  1200.0    ,
     $   1200.0    ,  1200.0    ,  1180.0    ,  1130.0    ,  1100.0    ,
     $   1090.0    ,  1080.0    /
      DATA (CNLWIN( 5,J),J=1,17) /
     $   1.0000    ,  90.000    ,  220.00    ,  340.00    ,  420.00    ,
     $   550.00    ,  720.00    ,  1080.0    ,  1300.0    ,  1400.0    ,
     $   1420.0    ,  1420.0    ,  1380.0    ,  1260.0    ,  1190.0    ,
     $   1150.0    ,  1100.0    /
      DATA (CNLWIN( 6,J),J=1,17) /
     $   1.0000    ,  95.000    ,  225.00    ,  345.00    ,  425.00    ,
     $   555.00    ,  750.00    ,  1150.0    ,  1500.0    ,  1680.0    ,
     $   1700.0    ,  1690.0    ,  1550.0    ,  1360.0    ,  1240.0    ,
     $   1180.0    ,  1120.0    /
      DATA (CNLWIN( 7,J),J=1,17) /
     $   10.000    ,  140.00    ,  260.00    ,  380.00    ,  450.00    ,
     $   600.00    ,  750.00    ,  1200.0    ,  1580.0    ,  1800.0    ,
     $   1820.0    ,  1830.0    ,  1800.0    ,  1750.0    ,  1690.0    ,
     $   1650.0    ,  1620.0    /
      DATA (CNLWIN( 8,J),J=1,17) /
     $   15.000    ,  150.00    ,  300.00    ,  400.00    ,  500.00    ,
     $   650.00    ,  840.00    ,  1500.0    ,  2100.0    ,  2130.0    ,
     $   2140.0    ,  2130.0    ,  2080.0    ,  2000.0    ,  1950.0    ,
     $   1900.0    ,  1860.0    /
      DATA (CNLWIN( 9,J),J=1,17) /
     $  0.00000E+00, 0.00000E+00, 0.00000E+00,  1.0000    ,  10.000    ,
     $   150.00    ,  380.00    ,  1000.0    ,  1650.0    ,  2100.0    ,
     $   2100.0    ,  2100.0    ,  2060.0    ,  1950.0    ,  1860.0    ,
     $   1800.0    ,  1740.0    /
      DATA (CNLWIN(10,J),J=1,17) /
     $  0.00000E+00, 0.00000E+00,  1.0000    ,  10.000    ,  45.000    ,
     $   180.00    ,  380.00    ,  1050.0    ,  1900.0    ,  2300.0    ,
     $   2300.0    ,  2200.0    ,  2150.0    ,  2000.0    ,  1900.0    ,
     $   1800.0    ,  1750.0    /
      DATA (CNLWIN(11,J),J=1,17) /
     $  0.00000E+00, 0.00000E+00,  1.0000    ,  10.000    ,  48.000    ,
     $   190.00    ,  390.00    ,  1080.0    ,  2000.0    ,  2400.0    ,
     $   2400.0    ,  2300.0    ,  2200.0    ,  2100.0    ,  1950.0    ,
     $   1850.0    ,  1800.0    /
      DATA (CNLWIN(12,J),J=1,17) /
     $  0.00000E+00, 0.00000E+00,  1.0000    ,  10.000    ,  50.000    ,
     $   200.00    ,  400.00    ,  1100.0    ,  2100.0    ,  2500.0    ,
     $   2500.0    ,  2450.0    ,  2300.0    ,  2100.0    ,  2000.0    ,
     $   1900.0    ,  1850.0    /
      DATA (CNLWIN(13,J),J=1,17) /
     $  0.00000E+00, 0.00000E+00, 0.00000E+00,  1.0000    ,  10.000    ,
     $   100.00    ,  350.00    ,  900.00    ,  1400.0    ,  2000.0    ,
     $   2300.0    ,  2380.0    ,  2400.0    ,  2300.0    ,  2250.0    ,
     $   2200.0    ,  2120.0    /
      DATA (CNLWIN(14,J),J=1,17) /
     $  0.00000E+00, 0.00000E+00, 0.00000E+00,  1.0000    ,  10.000    ,
     $   100.00    ,  350.00    ,  900.00    ,  1400.0    ,  2000.0    ,
     $   2300.0    ,  2380.0    ,  2400.0    ,  2300.0    ,  2250.0    ,
     $   2200.0    ,  2120.0    /
      DATA (CNLWIN(15,J),J=1,17) /
     $  0.00000E+00, 0.00000E+00, 0.00000E+00,  1.0000    ,  10.000    ,
     $   100.00    ,  400.00    ,  950.00    ,  1600.0    ,  2200.0    ,
     $   2550.0    ,  2750.0    ,  2700.0    ,  2600.0    ,  2540.0    ,
     $   2450.0    ,  2360.0    /
      DATA (CSCAP(J),J=1,50) /
     $   6.0000    ,  5.7000    ,  5.5000    ,  5.3000    ,  5.2000    ,
     $   5.1000    ,  5.0000    ,  4.9000    ,  4.8000    ,  4.8000    ,
     $   4.8000    ,  4.8000    ,  4.8000    ,  4.8000    ,  4.8000    ,
     $   4.8000    ,  4.9000    ,  5.0000    ,  5.2000    ,  5.5000    ,
     $   6.0000    ,  6.7000    ,  7.5000    ,  8.5000    ,  10.000    ,
     $   12.000    ,  14.500    ,  19.000    ,  26.500    ,  40.000    ,
     $   75.000    ,  120.00    ,  180.00    ,  260.00    ,  360.00    ,
     $   330.00    ,  60.000    ,  7.0000    ,  9.5000    ,  20.000    ,
     $   75.000    ,  140.00    ,  250.00    ,  360.00    ,  480.00    ,
     $   580.00    ,  590.00    ,  500.00    ,  300.00    ,  100.00    /
      DATA (CSCAP(J),J=51,100) /
     $   200.00    ,  300.00    ,  400.00    ,  470.00    ,  500.00    ,
     $   430.00    ,  100.00    ,  20.000    ,  22.000    ,  40.000    ,
     $   560.00    ,  950.00    ,  1000.0    ,  1000.0    ,  1000.0    ,
     $   990.00    ,  920.00    ,  860.00    ,  790.00    ,  740.00    ,
     $   650.00    ,  600.00    ,  540.00    ,  470.00    ,  440.00    ,
     $   390.00    ,  360.00    ,  340.00    ,  320.00    ,  310.00    ,
     $   280.00    ,  2.0000    ,  2.5000    ,  6.0000    ,  13.000    ,
     $   38.000    ,  65.000    ,  140.00    ,  280.00    ,  300.00    ,
     $   430.00    ,  580.00    ,  650.00    ,  800.00    ,  920.00    ,
     $   1100.0    ,  1250.0    ,  1400.0    ,  1550.0    ,  1700.0    /
C --- END OF CROSS-SECTION DATA STATEMENTS ---

C --- DATA STMTS. FOR GEANT/GHEISHA PARTICLE CODE CONVERSIONS ---
C --- KIPART(I)=GHEISHA CODE CORRESPONDING TO GEANT   CODE I ---
C --- IKPART(I)=GEANT   CODE CORRESPONDING TO GHEISHA CODE I ---

      DATA KIPART/
     $               1,   3,   4,   2,   5,   6,   8,   7,
     $               9,  12,  10,  13,  16,  14,  15,  11,
     $              35,  18,  20,  21,  22,  26,  27,  33,
     $              17,  19,  23,  24,  25,  28,  29,  34,
     $              35,  35,  35,  35,  35,  35,  35,  35,
     $              35,  35,  35,  35,  30,  31,  32,  35/

*     DATA IKPART/
*    $               1,   4,   2,   3,   5,   6,   8,   7,
*    $               9,  11,  16,  10,  12,  14,  15,  13,
*    $              25,  18,  26,  19,  20,  21,  27,  28,
*    $              29,  22,  23,  30,  31,  45,  46,  47,
*    $              24,  32,  48/


C     PARAMETER (ONETHR=1./3.)
      DATA ONETHR   / .33333333/
      DATA ALPHA    / 6*0.7,
     +                0.75 ,0.75 ,0.75 ,
     +                0.76,0.76 ,0.76 ,0.76 ,
     +                0.685,0.63 ,0.685,0.63,0.685,0.63,
     +                3*0.685,3*0.63,2*0.685,2*0.63,
     +                3*0.7,0.685,0.63,0.7/
      DATA ALPHAC    /1.2,1.2,1.2,1.15,0.90,0.91,0.98,1.06,1.10,1.11,
     +                1.10,1.08,1.05,1.01,0.985,0.962,0.945,0.932,
     +                0.925,0.920,0.920,0.921,0.922,0.923,0.928,0.931,
     +                0.940,0.945,0.950,0.955,0.958,0.962,0.965,0.976,
     +                0.982,0.988,0.992,1.010,1.020,1.030,1.040/
      DATA PARTEL/6*0.,29*1./
      DATA PARTIN/6*0.,1.00,0.00,1.05,1.20,1.35,1.30,1.20,1.00,1.30,
     +            1.00,1.30,1.00,1.30,1.00,1.00,1.00,1.30,1.30,1.30,
     +            1.00,1.00,1.30,1.30,1.00,1.,1.,1.,1.3,1./
*     DATA ICORR /14*1, 0, 1, 0, 1, 0, 3*1, 3*0, 2*1, 2*0, 4*1, 2*0/
C--  SET INTRC TO 0 FOR IPART = 26-29, 33, 34  ( XI'S AND OMEGA'S )
C-DH- DATA INTRC /6*0, 1, 0, 12*1, 0, 2*2, 0, 1, 4*0, 3*1, 3*0 /
C--  RESET INTRC FOR IPART = 26-29, 33, 34  ( XI'S AND OMEGA'S )
      DATA INTRC /6*0, 1, 0, 12*1, 0, 2*2, 0, 10*1, 0/

C CROSS-SECTIONS ON NUCLEUS ARE KNOWN ONLY FOR PIONS AND PROTONS.
C THE GENERAL LAW SIGMA(A)=1.25*SIGMA(TOT,PROTON)*A**ALPHA IS VALID
C ONLY FOR MOMENTA > 2 GEV.THE PARAMETRIZATION DONE HERE GIVES ONLY
C A BEHAVIOUR AVERAGED OVER MOMENTA AND PARTICLE TYPES.
C FOR A DETECTOR WITH ONLY A FEW MATERIALS IT'S OF COURSE MUCHBETTER
C TO USE TABLES OF THE MEASURED CROSS-SECTIONS .
C FOR ELEMENTS WITH THE FOLLOWING ATOMIC NUMBERS MEASURED CROSS-
C SECTIONS ARE AVAILABLE (SEE "PCSDATA").

C                 H   AL     CU     PB
      DATA  CSA  /1. ,27.00 ,63.54 ,207.19 /
      DATA IPART2/9,8,7,11,10,13,12/
      SAVE ALPHA,ALPHAC,PARTEL,PARTIN,CSA,IPART2,INTRC

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

      IF ( DEBUG  .AND.  GHEISDB ) THEN
         WRITE(MDEBUG,*) 'CGHSIG:'
         NPRT(4)=.TRUE.
         NPRT(9)=.TRUE.
      ELSE
         NPRT(4)=.FALSE.
         NPRT(9)=.FALSE.
      ENDIF

C --- INITIALIZE CGHSIG AND SWITCH TO GHEISHA PARTICLE CODE ---
      CGHSIG=0.0
      IF     ( LPART .LE.  48 ) THEN
         IPART = KIPART(LPART)
      ELSEIF ( LPART .EQ. 201 ) THEN
         IPART = 30
      ELSEIF ( LPART .EQ. 301 ) THEN
         IPART = 31
      ELSEIF ( LPART .EQ. 402 ) THEN
         IPART = 32
      ELSE
         GOTO 160
      ENDIF

C --- NO INTERACTION FOR GAMMAS, NEUTRINOS, ELECTRONS, POSITRONS, MUONS,
C --- NEUTRAL PIONS, NEUTRAL SIGMAS AND ANTISIGMAS AND NEW PARTICLES.
      IF ( INTRC(IPART) .EQ. 0 ) GOTO 160
      P  = PPART
      EK = EKIN

C --- INITIALIZE THE CROSS-SECTIONS WITH 0.0 ---
      DO 10  K = 1,KK
         AIEL(K) = 0.0
         AIIN(K) = 0.0
         AICA(K) = 0.0
   10 CONTINUE
C
      IF     ( (IPART .GE. 30)  .AND.  (IPART .LE. 32) ) THEN

C --- TAKE GEOMETRICAL CROSS-SECTIONS FOR INELASTIC SCATTERING ---
C --- OF DEUTERONS, TRITONS AND ALPHAS ---
         IF     ( IPART .EQ. 30 ) THEN
            APART = 2.0**ONETHR
         ELSEIF ( IPART .EQ. 31 ) THEN
            APART = 3.0**ONETHR
         ELSEIF ( IPART .EQ. 32 ) THEN
            APART = 4.0**ONETHR
         ENDIF
         DO 20  K = 1,KK
            AIIN(K) = 49.0*(APART+ACOMP(K)**ONETHR)**2
   20    CONTINUE
         IF ( NPRT(9) ) WRITE(MDEBUG,10000)

      ELSEIF ( (IPART .EQ. 16)  .AND.  (EK .LE. 0.0327) ) THEN

C --- USE TABLES FOR LOW ENERGY NEUTRONS ---
C --- GET ENERGY BIN ---
         JE2 = 17
         DO 30  J = 2,17
            IF ( EK .LT. ELAB(J) ) THEN
               JE2 = J
               GOTO 40
            ENDIF
   30    CONTINUE

   40    JE1   = JE2-1
         EKX   = MAX(EK,1.0E-9)
         DELAB = ELAB(JE2)-ELAB(JE1)
         DO 70  K = 1,KK

C --- GET A BIN ---
            JA2 = 15
            DO 50  J = 2,15
               IF ( ACOMP(K) .LT. CNLWAT(J) ) THEN
                  JA2=J
                  GOTO 60
               ENDIF
   50       CONTINUE

   60       JA1    = JA2-1
            DNLWAT = CNLWAT(JA2)-CNLWAT(JA1)

C --- USE LINEAR INTERPOLATION OR EXTRAPOLATION BY Y=RCE*X+RCA*X+B ---

C --- ELASTIC CROSS-SECTION ---
C --- E INTERPOLATION OR EXTRAPOLATION AT JA1 ---
            DY  = CNLWEL(JA1,JE2)-CNLWEL(JA1,JE1)
            RCE = DY/DELAB
C --- A INTERPOLATION OR EXTRAPOLATION AT JE1 ---
            DY  = CNLWEL(JA2,JE1)-CNLWEL(JA1,JE1)
            RCA = DY/DNLWAT
            B   = CNLWEL(JA1,JE1)-RCE*ELAB(JE1)-RCA*CNLWAT(JA1)
            AIEL(K) = RCE*EK+RCA*ACOMP(K)+B

C --- INELASTIC CROSS-SECTION ---
C --- E INTERPOLATION OR EXTRAPOLATION AT JA1 ---
            DY  = CNLWIN(JA1,JE2)-CNLWIN(JA1,JE1)
            RCE = DY/DELAB
C --- A INTERPOLATION OR EXTRAPOLATION AT JE1 ---
            DY  = CNLWIN(JA2,JE1)-CNLWIN(JA1,JE1)
            RCA = DY/DNLWAT
            B   = CNLWIN(JA1,JE1)-RCE*ELAB(JE1)-RCA*CNLWAT(JA1)
            AIIN(K) = RCE*EK+RCA*ACOMP(K)+B

            IZNO = ZCOMP(K)+0.01
            AICA(K) = 11.12*CSCAP(IZNO)/(EKX*1.0E6)**0.577
   70    CONTINUE
         IF ( NPRT(9) ) WRITE(MDEBUG,10100)
      ELSE

C --- USE PARAMETRIZATION OF CROSS-SECTION DATA FOR ALL OTHER CASES ---

         IF ( NPRT(9) ) WRITE(MDEBUG,10200)

C --- GET MOMENTUM BIN ---
         J = 40
         DO 80  I = 2,41
            IF (P .LT. PLAB(I)) THEN
               J = I - 1
               GOTO 90
            ENDIF
   80    CONTINUE

C --- START WITH  CROSS-SECTIONS FOR SCATTERING ON FREE PROTONS ---
C --- USE LINEAR INTERPOLATION OR EXTRAPOLATION BY Y=RC*X+B     ---
   90    DX = PLAB(J+1)-PLAB(J)
C --- ELASTIC CROSS-SECTION ---
         DY = CSEL(IPART,J+1)-CSEL(IPART,J)
         RC = DY/DX
         B  = CSEL(IPART,J)-RC*PLAB(J)
         AIELIN = RC*P+B
C --- INELASTIC CROSS-SECTION ---
         DY = CSIN(IPART,J+1)-CSIN(IPART,J)
         RC = DY/DX
         B  = CSIN(IPART,J)-RC*PLAB(J)
         AIININ = RC*P+B
         ALPH   = ALPHA(IPART)
         IF ( IPART .LT. 14 ) THEN
            DY = ALPHAC(J+1)-ALPHAC(J)
            RC = DY/DX
            B  = ALPHAC(J)-RC*PLAB(J)
            CORFAC = RC*P+B
            ALPH   = ALPH*CORFAC

            IPART3 = IPART2(IPART-6)

C --- ELASTIC CROSS-SECTION ---
            DY = CSEL(IPART3,J+1)-CSEL(IPART3,J)
            RC = DY/DX
            B  = CSEL(IPART3,J)-RC*PLAB(J)
            XSECEL = RC*P+B
C --- INELASTIC CROSS-SECTION ---
            DY = CSIN(IPART3,J+1)-CSIN(IPART3,J)
            RC = DY/DX
            B  = CSIN(IPART3,J)-RC*PLAB(J)
            XSECIN = RC*P+B

         ENDIF

C   NO MAKE CROSS-SECTIONS FOR COMPONENT K OF COMPOSITION
         DO 100  K = 1,KK
            AIEL(K) = AIELIN
            AIIN(K) = AIININ

            IF ( ACOMP(K) .GE. 1.5 ) THEN

C --- A-DEPENDENCE FROM PARAMETRIZATION ---
               CREL = 1.0
               CRIN = 1.0
C --- GET MEDIUM BIN  1=HYDR.  2=AL  3=CU  4=PB ---
               I = 3
               IF ( ACOMP(K) .LT.  50.0 ) I = 2
               IF ( ACOMP(K) .GT. 100.0 ) I = 4
               IF     ( (IPART .EQ. 14)  .OR.  (IPART .EQ. 16) ) THEN

C --- PROTONS AND NEUTRONS ---

C --- ELASTIC CROSS-SECTION ---
                  DY = CSPNEL(I-1,J+1)-CSPNEL(I-1,J)
                  RC = DY/DX
                  B  = CSPNEL(I-1,J)-RC*PLAB(J)
                  XSECEL = RC*P+B
C --- INELASTIC CROSS-SECTION ---
                  DY = CSPNIN(I-1,J+1)-CSPNIN(I-1,J)
                  RC = DY/DX
                  B  = CSPNIN(I-1,J)-RC*PLAB(J)
                  XSECIN = RC*P+B
                  IF ( AIEL(K) .GE. 0.001 ) CREL = XSECEL/(0.36*AIEL(K)*
     +                                           CSA(I)**1.17)
                  AITOT = AIEL(K)+AIIN(K)
                  IF ( AITOT .GE. 0.001 ) CRIN = XSECIN/(AITOT*CSA(I)**
     +                                                      ALPH)

               ELSEIF ( IPART .LT. 15 ) THEN

C --- CALCULATE CORRECTION FACTORS FROM VALUES ON AL,CU,PB FOR ALL ---
C --- MESONS USE LINEAR INTERPOLATION OR EXTRAPOLATION BY Y=RC*X+B ---
C --- NOTE THAT DATA IS ONLY AVAILABLE FOR PIONS AND PROTONS
                  WGCH = 0.5
                  IF ( ACOMP(K) .LT. 20.0 )
     +                             WGCH = 0.5+0.5*EXP(-(ACOMP(K)-1.0))
                  AIEL(K) = WGCH*AIEL(K)+(1.0-WGCH)*XSECEL
                  AIIN(K) = WGCH*AIIN(K)+(1.0-WGCH)*XSECIN

C --- THIS SECTION NOT FOR KAONS ---
                  IF ( IPART .LT. 10 ) THEN

C --- ELASTIC CROSS-SECTION ---
                     DY = CSPIEL(I-1,J+1)-CSPIEL(I-1,J)
                     RC = DY/DX
                     B  = CSPIEL(I-1,J)-RC*PLAB(J)
                     XSPIEL =R C*P+B
C --- INELASTIC CROSS-SECTION ---
                     DY = CSPIIN(I-1,J+1)-CSPIIN(I-1,J)
                     RC = DY/DX
                     B  = CSPIIN(I-1,J)-RC*PLAB(J)
                     XSPIIN = RC*P+B

                     IF ( AIEL(K) .GE. 0.001 ) CREL = XSPIEL/
     +                                  (0.36* AIEL(K)*CSA(I)**1.17)
                     AITOT = AIEL(K)+AIIN(K)
                     IF ( AITOT .GE. 0.001 ) CRIN = XSPIIN/(AITOT*CSA(I)
     +                                                 **ALPH)
                  ENDIF
               ENDIF
               AIIN(K) = CRIN*(AIIN(K)+AIEL(K))*ACOMP(K)**ALPH
               AIEL(K) = CREL*0.36*AIEL(K)*ACOMP(K)**1.17
               AIEL(K) = AIEL(K)*PARTEL(IPART)
               AIIN(K) = AIIN(K)*PARTIN(IPART)
            ENDIF
  100    CONTINUE

      ENDIF

C --- CALCULATE INTERACTION PROBABILITY ---

      ALAM = 0.0
      DO 150  K = 1,KK
         AIEL(K) = AIEL(K)*WCOMP(K)
         AIIN(K) = AIIN(K)*WCOMP(K)
         AICA(K) = AICA(K)*WCOMP(K)
         ALAM = ALAM + AIEL(K) + AIIN(K) + AICA(K)
  150 CONTINUE

C --- PASS THE CROSS-SECTION (MBARN) TO CORSIKA ---
      CGHSIG = ALAM

      GOTO 999

C --- PRINTOUT OF SKIPPED PARTICLES IN CASE OF INTERFACE DEBUG ---
  160 IF ( NPRT(9) ) WRITE(MDEBUG,10300) IPART
10000 FORMAT(' *CGHSIG* GEOM X-SECT. FOR INEL. SCAT. OF D,T AND ALPHA')
10100 FORMAT(' *CGHSIG* X-SECT. FROM LOW ENERGY NEUTRON TABLES')
10200 FORMAT(' *CGHSIG* X-SECT. FROM PARAMETRIZATION OF DATA')
10300 FORMAT(' *CGHSIG* GHEISHA PARTICLE ',I3,' SKIPPED')
  999 RETURN
      END
*CMZ :          28/02/2002  11.42.37  by  D. HECK IK FZK KARLSRUHE
*-- Author :    CERN PROGLIB# M103
C=======================================================================

      SUBROUTINE FLPSOR(A,N)

C-----------------------------------------------------------------------
C CERN PROGLIB# M103    FLPSOR          .VERSION KERNFOR  3.15  820113
C ORIG. 29/04/78
C-----------------------------------------------------------------------
C   SORT THE ONE-DIMENSIONAL FLOATING POINT ARRAY A(1),...,A(N) BY
C   INCREASING VALUES
C
C     PROGRAM  M103  TAKEN FROM CERN PROGRAM LIBRARY,  29-APR-78
C-----------------------------------------------------------------------

      DIMENSION A(*)
      COMMON /SLATE/ LT(20),RT(20)
      INTEGER R,RT
      SAVE
C-----------------------------------------------------------------------

      LEVEL = 1
      LT(1) = 1
      RT(1) = N
   10 L     = LT(LEVEL)
      R     = RT(LEVEL)
      LEVEL = LEVEL-1
   20 IF (R .GT. L ) GOTO 200
      IF ( LEVEL ) 50,50,10
C
C   SUBDIVIDE THE INTERVAL L,R
C     L : LOWER LIMIT OF THE INTERVAL (INPUT)
C     R : UPPER LIMIT OF THE INTERVAL (INPUT)
C     J : UPPER LIMIT OF LOWER SUB-INTERVAL (OUTPUT)
C     I : LOWER LIMIT OF UPPER SUB-INTERVAL (OUTPUT)
C
  200 I = L
      J = R
      M = (L+R)/2
      X = A(M)
  220 IF ( A(I) .GE. X ) GOTO 230
      I = I+1
      GOTO 220
  230 IF ( A(J) .LE. X ) GOTO 231
      J = J-1
      GOTO 230
C
  231 IF ( I .GT. J ) GOTO 232
      W    = A(I)
      A(I) = A(J)
      A(J) = W
      I    = I+1
      J    = J-1
      IF ( I .LE. J ) GOTO 220
C
  232 LEVEL = LEVEL+1
      IF ( (R-I) .GE. (J-L) ) GOTO 30
      LT(LEVEL) = L
      RT(LEVEL) = J
      L = I
      GOTO 20
   30 LT(LEVEL) = I
      RT(LEVEL) = R
      R = J
      GOTO 20
   50 RETURN
      END
*CMZ :          03/11/2000  12.13.41  by  D. HECK IK3 FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
C=======================================================================

      REAL FUNCTION GARNDM( )

C-----------------------------------------------------------------------
C  1 EXPONENTIALLY DISTRIBUTED RANDOM NUMBER
C-----------------------------------------------------------------------

      REAL RD(1)
      SAVE
C-----------------------------------------------------------------------

      CALL RMMAR(RD,1,1)
      GARNDM = -LOG(RD(1))
      RETURN
      END
*CMZ :          28/02/2002  11.42.37  by  D. HECK IK FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
C=======================================================================

      SUBROUTINE GRANOR(A,B)

C-----------------------------------------------------------------------
C  G(HEISHA) RA(NDOM NUMBERS WITH) NOR(MAL DISTRIBUTION)
C  TWO GAUSSIAN DISTRIBUTED RANDOM NUMBERS (MEAN=0, SIGMA=1)
C
C  RANDOM NUMBER GENERATORS USED BY THE GHEISHA ROUTINES
C  ADAPTED FOR USE WITH THE CORSIKA RANDOM NUMBER GENERATORS
C
C  DESIGN  : J. KNAPP   IK1  FZK KARLSRUHE
C-----------------------------------------------------------------------

      REAL RD(2)
      SAVE
C-----------------------------------------------------------------------

      CALL RMMAR(RD,2,1)
      U1 = SQRT((-2.)*LOG(RD(1)))
      U2 = RD(2) * 6.28318530718
      A  = COS(U2) * U1
      B  = SIN(U2) * U1
      RETURN
      END
*CMZ :          28/02/2002  13.08.20  by  D. HECK IK FZK KARLSRUHE
*-- Author :    CERN PROGLIB# V113
C=======================================================================

      SUBROUTINE GRNDM(RVEC,LENV)

C-----------------------------------------------------------------------
C  G(HEISHA) R(A)ND(O)M (NUMBER GENERATOR)
C
C  THIS ROUTINE IS IDENTICAL TO RMMAR
C  DESCRIPTION OF ALGORITHM SEE SUBROUT. RMMAR
C  THIS SUBROUTINE IS CALLED FROM GHEISHA ROUTINES.
C  ARGUMENTS:
C   RVEC   = VECTOR FIELD TO BE FILLED WITH RANDOM NUMBERS
C   LENV   = LENGTH OF VECTOR (# OF RANDNUMBERS TO BE GENERATED)
C
C  CERN PROGLIB# V113    RMMAR           .VERSION KERNFOR  1.0
C  ORIG. 01/03/89 FCA + FJ
C-----------------------------------------------------------------------

      REAL RVEC(*)
      COMMON /RANMA2/ IU(1030),JSEQ
      COMMON /RANMA3/ TWOM24,TWOM48,CD,CM,CINT,MODCNS
      INTEGER I97(0:1030),J97(0:1030),NTOT(0:1030),NTOT2(0:1030),
     *        IJKL(0:1030)
      REAL    U(1030),C(0:1030)
      EQUIVALENCE (IJKL(0),IU(1)),(NTOT(0),IU(2)),(NTOT2(0),IU(3))
      EQUIVALENCE (U(1),IU(4)),(C(0),IU(101)),(I97(0),IU(102))
      EQUIVALENCE (J97(0),IU(103))
      SAVE
C-----------------------------------------------------------------------

      ISEQ = 1
      IF ( ISEQ .GT. 0 ) JSEQ = ISEQ
      IBASE = (JSEQ-1)*103

      DO 100  IVEC = 1,LENV
        UNI = U(IBASE+I97(IBASE))-U(IBASE+J97(IBASE))
        IF ( UNI .LT. 0. ) UNI = UNI+1.
        U(IBASE+I97(IBASE)) = UNI
        I97(IBASE) = I97(IBASE)-1
        IF ( I97(IBASE) .EQ. 0 ) I97(IBASE) = 97
        J97(IBASE) = J97(IBASE)-1
        IF ( J97(IBASE) .EQ. 0 ) J97(IBASE) = 97
        C(IBASE)   = C(IBASE) - CD
        IF ( C(IBASE) .LT. 0. ) C(IBASE) = C(IBASE)+CM
        UNI = UNI-C(IBASE)
        IF ( UNI .LT. 0. ) UNI = UNI+1.
C  REPLACE EXACT ZEROES BY UNIFORM DISTR. *2**-24
        IF ( UNI .EQ. 0. ) THEN
          UNI = TWOM24*U(2)
C  AN EXACT ZERO HERE IS VERY UNLIKELY, BUT LET'S BE SAFE.
          IF ( UNI .EQ. 0. ) UNI = TWOM48
        ENDIF
        RVEC(IVEC) = UNI
  100 CONTINUE

      NTOT(IBASE) = NTOT(IBASE) + LENV
      IF ( NTOT(IBASE) .GE. MODCNS ) THEN
        NTOT2(IBASE) = NTOT2(IBASE) + 1
        NTOT(IBASE)  = NTOT(IBASE) - MODCNS
      ENDIF

      RETURN
      END
*CMZ :          18/10/2000  09.15.12  by  D. HECK IK3 FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
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
C   SLOG   = LOG(S) ( = LOG(ECM**2) )
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,AVPT.
      COMMON /AVPT/    AVPT,AVPK,AVPN,AVPH,AVPE
      DOUBLE PRECISION AVPT,AVPK,AVPN,AVPH,AVPE
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEND.

      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
*CMZ :          11/07/2000  10.08.31  by  D. HECK IK3 FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
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)
*KEEP,DPMFLG.
      COMMON /DPMFLG/  NFLAIN,NFLDIF,NFLPI0,NFLCHE,NFLPIF,NFRAGM
      INTEGER          NFLAIN,NFLDIF,NFLPI0,NFLCHE,NFLPIF,NFRAGM
*KEEP,INTER.
      COMMON /INTER/   AVCH,AVCH3,DC0,DLOG,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,DLOG,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
*KEEP,LEPAR.
      COMMON /LEPAR/   LEPAR1,LEPAR2,LASTPI,NRESPC,NRESPN,NCPLUS
      INTEGER          LEPAR1,LEPAR2,LASTPI,NRESPC,NRESPN,NCPLUS
*KEEP,PAM.
      COMMON /PAM/     PAMA,SIGNUM,RESTMS
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000)
*KEEP,PARPAR.
      COMMON /PARPAR/  CURPAR,SECPAR,PRMPAR,OUTPAR,C,
     *                 E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
      DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16),
     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH
      INTEGER          ITYPE,LEVL
*KEEP,PARPAE.
      DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM
     *                 ,WEIGHT
     *                 ,HAPP,COSTAP,COSTEA
      EQUIVALENCE      (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE),
     *                 (CURPAR(4), PHI   ), (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)
*KEEP,RANDPA.
      COMMON /RANDPA/  FAC,U1,U2,RD,NSEQ,ISEED,KNOR
      DOUBLE PRECISION FAC,U1,U2
      REAL             RD(3000)
      INTEGER          ISEED(103,10),NSEQ
      LOGICAL          KNOR
*KEEP,REST.
      COMMON /REST/    CONTNE,TAR,LT
      DOUBLE PRECISION CONTNE(3),TAR
      INTEGER          LT
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEND.

      SAVE
C-----------------------------------------------------------------------

      IF ( DEBUG ) WRITE(MDEBUG,*) 'DIFRAC:'

C  DECIDE FIRST, WHETHER PROJECTILE OR TARGET DIFFRACTION
      CALL RMMAR( RD,1,1 )
      IF ( RD(1) .LE. 0.5 ) 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 RMMAR( 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
      DLOG   = LOG(SDIF)
      DLOGSQ = DLOG**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  PARAMETRISATION SEE CAPDEVIELLE,J.PHYS.G:NUCL.PHYS.16(1990)1539 EQ.7
C  WE USE ONLY THE LOW-ENERGY PART OF THE PARAMETRISATION, 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  PARAMETRISATIONS 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*DLOG + 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  PARAMETRISATION 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 PARAMETRIZATION OF J.N.CAPDEVIELLE (MARCH 93)
        GNU   = (0.4826D0 + 3.522D-2 * DLOG) * 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 PHOTONS FROM UNKNOWN NEUTRAL
C  DECAYS FOLLOWING CORRELATION WITH CHARGED PARTICLES BASED ON
C  PHOTON EXCESS AT COLLIDER EXPERIMENTS. SEUGP IS <N_PHOTON>
C  PROBLEM OF THE RISE OF THE UNKNOWN ETA PRODUCTION CROSS-SECTION
C  IS SOLVED WITH PARAMETRISATION OF UA5 (Z. PHYS. C43 (1989) 75)
      IF ( ECMDIF .LE. 103.D0 ) THEN
        SEUGP = -1.27D0 + 0.52D0 * DLOG + 0.148D0 * DLOGSQ
      ELSE
C  AT HIGH DIFFRACTIVE MASS USE PARAMETRISATION 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
*CMZ :          28/02/2002  12.02.13  by  D. HECK IK FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
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
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEND.

      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
*CMZ :          28/02/2002  13.08.20  by  D. HECK IK FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
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)
*KEEP,CONSTA.
      COMMON /CONSTA/  PI,PI2,OB3,TB3,ENEPER
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER
*KEEP,DPMFLG.
      COMMON /DPMFLG/  NFLAIN,NFLDIF,NFLPI0,NFLCHE,NFLPIF,NFRAGM
      INTEGER          NFLAIN,NFLDIF,NFLPI0,NFLCHE,NFLPIF,NFRAGM
*KEEP,ELADPM.
      COMMON /ELADPM/  ELMEAN,ELMEAA,IELDPM,IELDPA
      DOUBLE PRECISION ELMEAN(40),ELMEAA(40)
      INTEGER          IELDPM(40,13),IELDPA(40,13)
*KEEP,ELASTY.
      COMMON /ELASTY/  ELAST
      DOUBLE PRECISION ELAST
*KEEP,INDICE.
      COMMON /INDICE/  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
*KEEP,INTER.
      COMMON /INTER/   AVCH,AVCH3,DC0,DLOG,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,DLOG,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
*KEEP,ISTA.
      COMMON /ISTA/    IFINET,IFINNU,IFINKA,IFINPI,IFINHY
      INTEGER          IFINET,IFINNU,IFINKA,IFINPI,IFINHY
*KEEP,LEPAR.
      COMMON /LEPAR/   LEPAR1,LEPAR2,LASTPI,NRESPC,NRESPN,NCPLUS
      INTEGER          LEPAR1,LEPAR2,LASTPI,NRESPC,NRESPN,NCPLUS
*KEEP,LONGI.
      COMMON /LONGI/   ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP,LLONGI,FLGFIT
      DOUBLE PRECISION ADLONG(0:1170,9),AELONG(0:1170,9),
     *                 APLONG(0:1170,9),DLONG(0:1170,9),ELONG(0:1170,9),
     *                 HLONG(0:1170),PLONG(0:1170,9),SDLONG(0:1170,9),
     *                 SELONG(0:1170,9),SPLONG(0:1170,9),THSTEP,THSTPI
      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT
*KEEP,MULT.
      COMMON /MULT/    EKINL,MSMM,MULTMA,MULTOT
      DOUBLE PRECISION EKINL
      INTEGER          MSMM,MULTMA(40,13),MULTOT(40,13)
*KEEP,NEWPAR.
      COMMON /NEWPAR/  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
*KEEP,PAM.
      COMMON /PAM/     PAMA,SIGNUM,RESTMS
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000)
*KEEP,PARPAR.
      COMMON /PARPAR/  CURPAR,SECPAR,PRMPAR,OUTPAR,C,
     *                 E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
      DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16),
     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH
      INTEGER          ITYPE,LEVL
*KEEP,PARPAE.
      DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM
     *                 ,WEIGHT
     *                 ,HAPP,COSTAP,COSTEA
      EQUIVALENCE      (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE),
     *                 (CURPAR(4), PHI   ), (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)
*KEEP,RANDPA.
      COMMON /RANDPA/  FAC,U1,U2,RD,NSEQ,ISEED,KNOR
      DOUBLE PRECISION FAC,U1,U2
      REAL             RD(3000)
      INTEGER          ISEED(103,10),NSEQ
      LOGICAL          KNOR
*KEEP,RATIOS.
      COMMON /RATIOS/  RPI0R,RPIER,RPEKR,RPEKNR,PPICH,PPINCH,PPNKCH,
     *                 ISEL,NEUTOT,NTOTEM
      DOUBLE PRECISION RPI0R,RPIER,RPEKR,RPEKNR,PPICH,PPINCH,PPNKCH
      INTEGER          ISEL,NEUTOT,NTOTEM
*KEEP,RESON.
      COMMON /RESON/   RDRES,RESRAN,IRESPAR
      REAL             RDRES(2),RESRAN(30000)
      INTEGER          IRESPAR
*KEEP,REST.
      COMMON /REST/    CONTNE,TAR,LT
      DOUBLE PRECISION CONTNE(3),TAR
      INTEGER          LT
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEEP,SIGM.
      COMMON /SIGM/    SIGMA,SIGANN,SIGAIR,FRACTN,FRCTNO
      DOUBLE PRECISION SIGMA,SIGANN,SIGAIR,FRACTN,FRCTNO
*KEND.

      DOUBLE PRECISION DPFUNC,RANNOR
      SAVE
      EXTERNAL         DPFUNC,RANNOR
C-----------------------------------------------------------------------

      IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=1,9)
  444   FORMAT(' HDPM  : CURPAR=',1P,9E10.3)

C  SET ANTI-LEADER TO PROTON OR NEUTRON; TARGET IS ALWAYS NUCLEON
      CALL RMMAR( RD,1,1 )
      IF ( RD(1) .LE. CONTNE(LT) ) THEN
        ITAR = 13
      ELSE
        ITAR = 14
      ENDIF


C  CALCULATE LAB AND CM ENERGY
      IF ( ITYPE .NE. 1 ) THEN
        ELAB  = PAMA(ITYPE) * GAMMA
        PLAB  = ELAB * BETA
        S     = PAMA(ITYPE)**2 + PAMA(ITAR)**2 + 2.D0*PAMA(ITAR)*ELAB
      ELSE
C  FOR GAMMA-INDUCED REACTION TAKE PI(0) AS LEADING PARTICLE
        ITYPE = 7
        ELAB  = GAMMA
        PLAB  = ELAB
        S     = PAMA(ITAR)**2 + 2.D0*PAMA(ITAR)*ELAB
      ENDIF

      ECMDPM  = SQRT(S)
      IF ( DEBUG ) WRITE(MDEBUG,*) 'HDPM  : ITYPE,ELAB,PLAB,S,ECMDPM=',
     *             ITYPE,SNGL(ELAB),SNGL(PLAB),SNGL(S),SNGL(ECMDPM)

C  LN(S), LN(S)**2 AND RAPIDITY OF C. M. SYSTEM IN LAB
      SLOG    = LOG(S)
      SLOGSQ  = SLOG**2
      SMLOG   = LOG( 2.D0 * PAMA(ITAR) * ELAB )
      ELABLG  = LOG(ELAB)
      EPLUSP  = ELAB + PLAB
*     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       PRIMARY 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 RMMAR( 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 ) THEN
        WRITE(MDEBUG,*) '    DIFFRACTIVE INTERACTION (0/1) = ',IDIF
      ENDIF

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 = DLOG
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  PARAMETRISATION 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  PARAMETRISATION FORM 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  PARAMETRISATION 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  PARAMETRISATION 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 111  I = 3,NTOT
          IF ( ABS(YR(I)) .LT. DELRAP ) IZN = IZN + 1
 111    CONTINUE
        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 PARAMETRISAT
        DO 112  I = 3,NTOT
          YR(I) = YR(I) + YY0
 112    CONTINUE
        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 RMMAR( RD,JGNU,1 )
          IPR = 0
          INE = 0
          TARMAS = PAMA(ITYP(2))
          DO 114  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
 114      CONTINUE

C  CALCULATE C.M. ENERGY + RAPIDITY SHIFT
*         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 115  I = NTOT-JGNU+1,NTOT
            YR(I) = - YCM
 115      CONTINUE
C  SHIFT RAPIDITIES INTO CM SYSTEM OF GNU+1 MASSES
          DO 113  I = 1,NTOT
            YR(I) = YR(I) + DYGNU
 113      CONTINUE

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


C  CALCULATE LAB ENERGIES OF SECONDARY PARTICLES FROM THE RAPIDITIES
C  INCLUDING THE ADDITIONAL TARGET NUCLEONS
      ETOT = 0.D0
      DO 135  I = 1,NTOT
        YR(I) = YR(I) + YCM - DYGNU
        EA(I) = TMAS(I) * COSH( YR(I) )
        ETOT  = ETOT + EA(I)
 135  CONTINUE

      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
            DLONG(LHEIGH,7) = DLONG(LHEIGH,7) + EA(J)
          ENDIF
          GOTO 140
        ENDIF
C  CALCULATE THE PROPERTIES OF ALL SECONDARIES
C  PARTICLE TYPE
        SECPAR(1) = ITYP(J)
C  CALCULATE GAMMA FACTOR
        SECPAR(2) = EA(J) / PAMA(ITYP(J))
C  TOTAL MOMENTUM SQUARED
        PTM = EA(J)**2 - PAMA(ITYP(J))**2
        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
            DLONG(LHEIGH,7) = DLONG(LHEIGH,7) + EA(J)
          ENDIF
          GOTO 140
        ENDIF
C  EMISSION ZENITH ANGLE AGAINST TRAJECTORY OF PROJECTILE
        IF ( PTM .EQ. 0.D0 ) THEN
          COSTET = 1.D0
        ELSE
          COSTET = SQRT( 1.D0 - PT2(J) / PTM )
        ENDIF
C  EMISSION AZIMUTH ANGLE
        IF ( PX(J) .NE. 0.D0  .OR.  PY(J) .NE. 0.D0 ) THEN
          PHIJ = ATAN2( PY(J), PX(J) )
        ELSE
          PHIJ = 0.D0
        ENDIF
        CALL ADDANG( COSTHE,PHI, COSTET,PHIJ, SECPAR(3),SECPAR(4) )
        IF ( SECPAR(3) .LT. C(29) ) 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
            DLONG(LHEIGH,7) = DLONG(LHEIGH,7) + EA(J)
          ENDIF
          GOTO 140
        ENDIF
C  PUT SECONDARY PARTICLES ON STACK, IF NOT GOING UPWARDS
        IF ( J .GT. 2 ) THEN
          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. 30000 ) THEN
              WRITE(MONIOU,*)
     *             'HDPM  : STACK OF RESDEC RANDOM NUMBERS FULL'
              IRESPAR = 29999
            ENDIF
            RESRAN(IRESPAR) = RDRES(J)
C  COUNTER FOR ENERGY-MULTIPLICITY MATRIX
            MSMM = MSMM + 1
          ENDIF
          CALL TSTACK

C  CALCULATE ELASTICITY FROM ENERGY OF LEADER (REST OF RESONANCE DECAY)
          IF ( J. EQ. 1 ) ELASTI = SECPAR(2)*PAMA(NINT(SECPAR(1)))/ELAB
        ENDIF
C  COUNTERS FOR FIRST INTERACTION
        IF ( FIRSTI ) THEN
          IF     ( SECPAR(1) .EQ.  7.D0  .OR.  SECPAR(1) .EQ.  8.D0
     *       .OR.  SECPAR(1) .EQ.  9.D0                           ) THEN
            IFINPI = IFINPI + 1
          ELSEIF ( SECPAR(1) .EQ. 13.D0  .OR.  SECPAR(1) .EQ. 14.D0
     *       .OR.  SECPAR(1) .EQ. 15.D0 .OR. SECPAR(1) .EQ. 25.D0 ) THEN
            IFINNU = IFINNU + 1
          ELSEIF ( SECPAR(1) .EQ. 10.D0  .OR.  SECPAR(1) .EQ. 11.D0
     *       .OR.  SECPAR(1) .EQ. 12.D0 .OR. SECPAR(1) .EQ. 16.D0 ) THEN
            IFINKA = IFINKA + 1
          ELSEIF ( SECPAR(1) .GE. 71.D0 .AND. SECPAR(1) .LE. 74.D0) THEN
            IFINET = IFINET + 1
          ELSEIF ((SECPAR(1) .GE. 18.D0 .AND. SECPAR(1) .LE. 24.D0)
     *       .OR. (SECPAR(1) .GE. 26.D0 .AND. SECPAR(1) .LE. 32.D0))THEN
            IFINHY = IFINHY + 1
          ENDIF
        ENDIF

 140  CONTINUE

C  COUNTER FOR ENERGY-MULTIPLICITY MATRIX
      MSMM = MSMM + NTOT - 2

C  FILL ELASTICITY IN MATRICES
      MEL = MIN ( 1.D0+10.D0*      MAX( 0.D0, ELASTI ) , 11.D0 )
      MEN = MIN ( 4.D0+ 3.D0*LOG10(MAX( .1D0, EKINL  )), 40.D0 )
      IELDPM(MEN,MEL) = IELDPM(MEN,MEL) + 1
      IELDPA(MEN,MEL) = IELDPA(MEN,MEL) + 1
      IF ( ELASTI .LT. 1.D0 ) THEN
        ELMEAN(MEN) = ELMEAN(MEN) + ELASTI
        ELMEAA(MEN) = ELMEAA(MEN) + ELASTI
      ENDIF

      IF ( FIRSTI ) THEN
        TARG1I = TAR
        SIG1I  = SIGAIR
        ELAST  = ELASTI
        FIRSTI = .FALSE.
      ENDIF

      IF ( DEBUG ) WRITE(MDEBUG,*) 'HDPM  : ELAST=',SNGL(ELASTI),
     *                            SNGL(ETOT),SNGL(ELAB)

      RETURN
      END
*CMZ :          28/09/2001  16.38.22  by  D. HECK IK FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
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
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)
*KEEP,INTER.
      COMMON /INTER/   AVCH,AVCH3,DC0,DLOG,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,DLOG,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
*KEEP,NEWPAR.
      COMMON /NEWPAR/  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
*KEEP,PAM.
      COMMON /PAM/     PAMA,SIGNUM,RESTMS
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000)
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEND.

      DIMENSION 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  4  I = 1,NTOT
        STMAS    = STMAS + TMAS(I)
        YRJAD(I) = YR(I)
  4   CONTINUE
      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
      JCOUNT = 0
C  OPTIMIZATION LOOP TO DEFINE PARAMETER AA
  1   CONTINUE
      JCOUNT = JCOUNT + 1
      IF ( JCOUNT .GE. 50 ) GOTO 999
C  FORM SUMS S1 AND S2
      S1     = 0.D0
      S2     = 0.D0
      DO  5  I = 1,NTOT
        EXPO = EXP( AA * YR(I) )
        S1   = S1 + TMAS(I) * ECMI * EXPO
        S2   = S2 + TMAS(I) * ECMI / EXPO
  5   CONTINUE
      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) JCOUNT,STMAS,REST
  110 FORMAT('   JCOUNT, STMAS, REST = ',I5,2E13.5,/
     *       '   NUM   ITYP    TMAS          YR(OLD)         YR(NEW)')
C  CORRECT RAPIDITIES
      DO 10  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
 10   CONTINUE
      RETURN

C  ERROR EXIT
 999  JADFLG = 1
C  NO CONVERGENCE AFTER 50 ITERATIONS OR IMPOSSIBLE RAPIDITY
      RETURN
      END
*CMZ :          14/06/2000  14.29.37  by  D. HECK IK3 FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
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)
*KEEP,INTER.
      COMMON /INTER/   AVCH,AVCH3,DC0,DLOG,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,DLOG,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
*KEEP,LEPAR.
      COMMON /LEPAR/   LEPAR1,LEPAR2,LASTPI,NRESPC,NRESPN,NCPLUS
      INTEGER          LEPAR1,LEPAR2,LASTPI,NRESPC,NRESPN,NCPLUS
*KEEP,NEWPAR.
      COMMON /NEWPAR/  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
*KEEP,RANDPA.
      COMMON /RANDPA/  FAC,U1,U2,RD,NSEQ,ISEED,KNOR
      DOUBLE PRECISION FAC,U1,U2
      REAL             RD(3000)
      INTEGER          ISEED(103,10),NSEQ
      LOGICAL          KNOR
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEND.

      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**2 - TMAS(2)**2
        IF ( PTLSQ .LE. 0.D0 ) THEN
          IFLGLD = 1
          RETURN
        ENDIF
        PCMTAR = SQRT(PTLSQ)
*       YR(2)  = (-0.5D0) * LOG( (ECMTAR+PCMTAR) / (ECMTAR-PCMTAR) )
        YR(2)  = - LOG( (ECMTAR+PCMTAR) / TMAS(2) )
C  RAPIDITY OF DIFFRACTING PROJECTILE
        CALL RMMAR( RD,1,1 )
        IF ( RD(1) .GE. 0.5 ) 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**2 - TMAS(1)**2
        IF ( PPLSQ .LE. 0.D0 ) THEN
          IFLGLD = 1
          RETURN
        ENDIF
        PCMPRO = SQRT(PPLSQ)
*       YR(1)  = 0.5D0 * LOG( (ECMPRO+PCMPRO) / (ECMPRO-PCMPRO) )
        YR(1)  = LOG( (ECMPRO+PCMPRO) / TMAS(1) )
C  RAPIDITY OF DIFFRACTING TARGET NUCLEON
        CALL RMMAR( RD,1,1 )
        IF ( RD(1) .GE. 0.5 ) 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
*CMZ :          14/06/2000  14.29.37  by  D. HECK IK3 FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
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)
*KEEP,INTER.
      COMMON /INTER/   AVCH,AVCH3,DC0,DLOG,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,DLOG,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
*KEEP,LEPAR.
      COMMON /LEPAR/   LEPAR1,LEPAR2,LASTPI,NRESPC,NRESPN,NCPLUS
      INTEGER          LEPAR1,LEPAR2,LASTPI,NRESPC,NRESPN,NCPLUS
*KEEP,NEWPAR.
      COMMON /NEWPAR/  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
*KEEP,PAM.
      COMMON /PAM/     PAMA,SIGNUM,RESTMS
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000)
*KEEP,PARPAR.
      COMMON /PARPAR/  CURPAR,SECPAR,PRMPAR,OUTPAR,C,
     *                 E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
      DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16),
     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH
      INTEGER          ITYPE,LEVL
*KEEP,PARPAE.
      DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM
     *                 ,WEIGHT
     *                 ,HAPP,COSTAP,COSTEA
      EQUIVALENCE      (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE),
     *                 (CURPAR(4), PHI   ), (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)
*KEEP,RANDPA.
      COMMON /RANDPA/  FAC,U1,U2,RD,NSEQ,ISEED,KNOR
      DOUBLE PRECISION FAC,U1,U2
      REAL             RD(3000)
      INTEGER          ISEED(103,10),NSEQ
      LOGICAL          KNOR
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEEP,VKIN.
      COMMON /VKIN/    BETACM
      DOUBLE PRECISION BETACM
*KEND.

      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( 1.D0 - 1.D0 / GCM**2 )

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 RMMAR( 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)
*     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 10  I = 2,NTOT
        EA(I) = TMAS(I) * COSH( YR(I) + YCM )
        ESUM  = ESUM + EA(I)
  10  CONTINUE
      EA(1) = ELAB + PAMA(ITAR) - ESUM
      IF ( EA(1) .LE. TMAS(1) ) THEN
        LEDEFL = 1
        RETURN
      ENDIF
      PLLBSQ = EA(1)**2 - TMAS(1)**2
      PLLB   = SQRT( PLLBSQ )
*     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
*CMZ :          15/06/2000  14.13.19  by  D. HECK IK3 FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
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)
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)
*KEEP,CONSTA.
      COMMON /CONSTA/  PI,PI2,OB3,TB3,ENEPER
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER
*KEEP,LEPAR.
      COMMON /LEPAR/   LEPAR1,LEPAR2,LASTPI,NRESPC,NRESPN,NCPLUS
      INTEGER          LEPAR1,LEPAR2,LASTPI,NRESPC,NRESPN,NCPLUS
*KEEP,RANDPA.
      COMMON /RANDPA/  FAC,U1,U2,RD,NSEQ,ISEED,KNOR
      DOUBLE PRECISION FAC,U1,U2
      REAL             RD(3000)
      INTEGER          ISEED(103,10),NSEQ
      LOGICAL          KNOR
*KEEP,RESON.
      COMMON /RESON/   RDRES,RESRAN,IRESPAR
      REAL             RDRES(2),RESRAN(30000)
      INTEGER          IRESPAR
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEND.

      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 RMMAR( 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.5 ) 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 RMMAR( 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 RMMAR( 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.5 ) THEN
C  PROTON ---->  DELTA(++)
            LEPART = 54
            NRESPC = NRESPC + 1
            NCPLUS = NCPLUS + 1
          ELSEIF ( RD(2) .GT. TB3 ) THEN
C  PROTON  ---->  DELTA(+)
            LEPART = 55
            CALL RMMAR( 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 RMMAR( 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.5 ) 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.5 ) THEN
C  K(+-)   ----> K*(+-)
            LEPART = LEPART + 52
            CALL RMMAR( 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 RMMAR( 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.5 ) THEN
C  K(0)   ----> (ANTI) K*(0)
            CALL RMMAR( RD,1,1 )
            IF ( RD(1) .LE. 0.5 ) THEN
              LEPART = 62
            ELSE
              LEPART = 65
            ENDIF
            CALL RMMAR( 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 RMMAR( RD,1,1 )
            IF ( RD(1) .LE. 0.5 ) THEN
              LEPART = 63
              NCPLUS = NCPLUS + 1
            ELSE
              LEPART = 64
              NCPLUS = NCPLUS - 1
            ENDIF
            CALL RMMAR( 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.5 ) THEN
C  ANTINEUTRON ---->  ANTI-DELTA(0)
            LEPART = 60
            CALL RMMAR( 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 RMMAR( 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.5 ) 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 RMMAR( 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 RMMAR( 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.5 ) 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.5 ) 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.5 ) 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
*CMZ :          11/07/2000  10.08.31  by  D. HECK IK3 FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
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)
*KEEP,INTER.
      COMMON /INTER/   AVCH,AVCH3,DC0,DLOG,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,DLOG,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
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEND.

      SAVE
C-----------------------------------------------------------------------

      IF ( DEBUG ) WRITE(MDEBUG,*) 'NSD   :'

C  CENTRAL RAPIDITY DENSITY ( RHO ) FOR NSD REACTION
C  PARAMETRISATION 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  PARAMETRISATIONS 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 PHOTONS FROM UNKNOWN NEUTRAL
C  DECAYS FOLLOWING CORRELATION WITH CHARGED PARTICLES BASED ON PHOTON
C  EXCESS AT COLLIDER EXPERIMENTS. SEUGP IS <N_PHOTON>
C  PARAMETRISATION 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 PARAMETRISATION 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
*CMZ :          28/02/2002  13.08.20  by  D. HECK IK FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
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)
*KEEP,CONSTA.
      COMMON /CONSTA/  PI,PI2,OB3,TB3,ENEPER
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER
*KEEP,EDECAY.
      COMMON /EDECAY/  CETA
      DOUBLE PRECISION CETA(5)
*KEEP,INDICE.
      COMMON /INDICE/  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
*KEEP,INTER.
      COMMON /INTER/   AVCH,AVCH3,DC0,DLOG,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,DLOG,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
*KEEP,LEPAR.
      COMMON /LEPAR/   LEPAR1,LEPAR2,LASTPI,NRESPC,NRESPN,NCPLUS
      INTEGER          LEPAR1,LEPAR2,LASTPI,NRESPC,NRESPN,NCPLUS
*KEEP,RANDPA.
      COMMON /RANDPA/  FAC,U1,U2,RD,NSEQ,ISEED,KNOR
      DOUBLE PRECISION FAC,U1,U2
      REAL             RD(3000)
      INTEGER          ISEED(103,10),NSEQ
      LOGICAL          KNOR
*KEEP,RATIOS.
      COMMON /RATIOS/  RPI0R,RPIER,RPEKR,RPEKNR,PPICH,PPINCH,PPNKCH,
     *                 ISEL,NEUTOT,NTOTEM
      DOUBLE PRECISION RPI0R,RPIER,RPEKR,RPEKNR,PPICH,PPINCH,PPNKCH
      INTEGER          ISEL,NEUTOT,NTOTEM
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEND.

      REAL             RDETA
      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 RMMAR( RD,NTOTEM,1 )
        DO 1000  I = 1,NTOTEM
          IF ( RD(I) .LE. TB3 ) THEN
            NPC = NPC + 1
          ELSE
            NPN = NPN + 1
          ENDIF
 1000   CONTINUE
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   K = 1
        CALL RMMAR( 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 RMMAR( RDETA,1,1 )
            IF     ( RDETA .LE. CETA(1) ) THEN
              SGAMMA    = SGAMMA + 2.D0
              NETA(J,1) = NETA(J,1) + 1
            ELSEIF ( RDETA .LE. CETA(2) ) THEN
              SGAMMA    = SGAMMA + 6.D0
              NETA(J,2) = NETA(J,2) + 1
            ELSEIF ( RDETA .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 RMMAR( 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
*CMZ :          14/06/2000  14.29.37  by  D. HECK IK3 FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
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)
*KEEP,INTER.
      COMMON /INTER/   AVCH,AVCH3,DC0,DLOG,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,DLOG,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
*KEEP,NEWPAR.
      COMMON /NEWPAR/  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
*KEEP,RANDPA.
      COMMON /RANDPA/  FAC,U1,U2,RD,NSEQ,ISEED,KNOR
      DOUBLE PRECISION FAC,U1,U2
      REAL             RD(3000)
      INTEGER          ISEED(103,10),NSEQ
      LOGICAL          KNOR
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEND.

      REAL             RAND(3000)
      SAVE
      DOUBLE PRECISION RANNOR
      EXTERNAL         RANNOR
C-----------------------------------------------------------------------

      IF ( DEBUG ) WRITE(MDEBUG,*) 'PARRAP: NTOT=',NTOT

C  PROTON ANTIPROTON PAIRS
      CALL RMMAR( RAND(3),IJ1-2,1 )
      DO 1013  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.5 ) THEN
            YR(K) = RANNOR(POSC2,WIDC2)
          ELSE
            YR(K) = RANNOR(-POSC2,WIDC2)
          ENDIF
        ENDIF
 1013 CONTINUE

C  K+ K- PAIRS
      DO 1014  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.5 ) THEN
            YR(K) = RANNOR(POSC2,WIDC2)
          ELSE
            YR(K) = RANNOR(-POSC2,WIDC2)
          ENDIF
        ENDIF
 1014 CONTINUE

C  CHARGED HYPERON PAIRS
      DO 1015  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.5 ) THEN
            YR(K) = RANNOR(POSC2,WIDC2)
          ELSE
            YR(K) = RANNOR(-POSC2,WIDC2)
          ENDIF
        ENDIF
 1015 CONTINUE

C  PI +-
      DO 1017  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.5 ) THEN
            YR(K) = RANNOR(POSC2,WIDC2)
          ELSE
            YR(K) = RANNOR(-POSC2,WIDC2)
          ENDIF
        ENDIF
 1017 CONTINUE

C  NEUTRON ANTINEUTRON PAIRS
      DO 1021  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.5 ) THEN
            YR(K) = RANNOR(POSC2,WIDC2)
          ELSE
            YR(K) = RANNOR(-POSC2,WIDC2)
          ENDIF
        ENDIF
 1021 CONTINUE

C  K0L K0S PAIRS
      DO 1022  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.5 ) THEN
            YR(K) = RANNOR(POSC2,WIDC2)
          ELSE
            YR(K) = RANNOR(-POSC2,WIDC2)
          ENDIF
        ENDIF
 1022 CONTINUE

C  NEUTRAL HYPERON PAIRS
      DO 1023  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.5 ) THEN
            YR(K) = RANNOR(POSC2,WIDC2)
          ELSE
            YR(K) = RANNOR(-POSC2,WIDC2)
          ENDIF
        ENDIF
 1023 CONTINUE

C  ETA
      DO 1025  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.5 ) THEN
            YR(K) = RANNOR(POSN2,WIDN2)
          ELSE
            YR(K) = RANNOR(-POSN2,WIDN2)
          ENDIF
        ENDIF
 1025 CONTINUE

C PI(0)
      DO 1026  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.5 ) THEN
            YR(K) = RANNOR(POSN2,WIDN2)
          ELSE
            YR(K) = RANNOR(-POSN2,WIDN2)
          ENDIF
        ENDIF
 1026 CONTINUE

      RETURN
      END
*CMZ :          02/11/2000  13.39.47  by  D. HECK IK3 FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
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  DESIGN  : D. HECK    IK3  FZK KARLSRUHE
C  CHANGES : J.N. CAPDEVIELLE CDF PARIS
C-----------------------------------------------------------------------

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
*KEEP,AVPT.
      COMMON /AVPT/    AVPT,AVPK,AVPN,AVPH,AVPE
      DOUBLE PRECISION AVPT,AVPK,AVPN,AVPH,AVPE
*KEEP,DPMFLG.
      COMMON /DPMFLG/  NFLAIN,NFLDIF,NFLPI0,NFLCHE,NFLPIF,NFRAGM
      INTEGER          NFLAIN,NFLDIF,NFLPI0,NFLCHE,NFLPIF,NFRAGM
*KEEP,INDICE.
      COMMON /INDICE/  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
*KEEP,INTER.
      COMMON /INTER/   AVCH,AVCH3,DC0,DLOG,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,DLOG,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
*KEEP,LEPAR.
      COMMON /LEPAR/   LEPAR1,LEPAR2,LASTPI,NRESPC,NRESPN,NCPLUS
      INTEGER          LEPAR1,LEPAR2,LASTPI,NRESPC,NRESPN,NCPLUS
*KEEP,NEWPAR.
      COMMON /NEWPAR/  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
*KEEP,PAM.
      COMMON /PAM/     PAMA,SIGNUM,RESTMS
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000)
*KEEP,RANDPA.
      COMMON /RANDPA/  FAC,U1,U2,RD,NSEQ,ISEED,KNOR
      DOUBLE PRECISION FAC,U1,U2
      REAL             RD(3000)
      INTEGER          ISEED(103,10),NSEQ
      LOGICAL          KNOR
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEND.

      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 1003  K = 1,NNC
        CALL RMMAR( RD,1,1 )
        IF ( RD(1) .LT. 0.5 ) 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
 1003 CONTINUE
C  K+ K- PAIRS
      DO 1004  K = 1,NKC
        CALL RMMAR( RD,1,1 )
        IF ( RD(1) .LT. 0.5 ) 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
 1004 CONTINUE
C  SIGMA PAIRS
      DO 1005  K = 1,NHC
        CALL RMMAR( RD,2,1 )
        IF ( RD(1) .LT. 0.5 ) THEN
          IF ( RD(2) .LT. 0.5 ) THEN
            ITYP(NPART)   = 19
            ITYP(NPART+1) = 27
          ELSE
            ITYP(NPART)   = 27
            ITYP(NPART+1) = 19
          ENDIF
        ELSE
          IF ( RD(2) .LT. 0.5 ) 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
 1005 CONTINUE

C  DECIDE WITH WHICH CHARGED PION TO START WITH
C  NUMBER OF PIONS MAY BE ODD IN THE CASE IF ISEL IS 1
      CALL RMMAR( RD,1,1 )
      IF ( RD(1) .GT. 0.5 ) THEN
        NPIOCH = 0
      ELSE
        NPIOCH = 1
      ENDIF
      NPOS = NCPLUS
C  PI +-
      DO 1007  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
 1007 CONTINUE
C  NEUTRON ANTINEUTRON PAIRS
      DO 1008  K = 1,NNN
        CALL RMMAR( RD,1,1 )
        IF ( RD(1) .LT. 0.5 ) 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
 1008 CONTINUE
C  K0L K0S PAIRS
      DO 1009  K = 1,NKN
        CALL RMMAR( RD,1,1 )
        IF ( RD(1) .LT. 0.5 ) 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
 1009 CONTINUE
C  LAMDA/SIGMA0 PAIRS
      DO 1010  K = 1,NHN
        CALL RMMAR( RD,2,1 )
        IF ( RD(1) .LT. 0.5 ) THEN
          IF ( RD(2) .LT. 0.5 ) THEN
            ITYP(NPART)   = 18
            ITYP(NPART+1) = 28
          ELSE
            ITYP(NPART)   = 28
            ITYP(NPART+1) = 18
          ENDIF
        ELSE
          IF ( RD(2) .LT. 0.5 ) 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
 1010 CONTINUE
C  ETA
      DO 1013  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
 1013 CONTINUE
C  PI(0)
      DO 1014  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
 1014 CONTINUE

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. 68) ) 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 130  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) )
 130  CONTINUE

      RETURN
      END
*CMZ :          28/02/2002  12.02.13  by  D. HECK IK FZK KARLSRUHE
*-- Author :    J.N. Capdevielle CdF Paris/France   26/11/96
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
C   PTY    = TRANSVERSE MOMENTUM IN Y DIRECTION
C
C  DESIGN  : J.N. CAPDEVIELLE CDF PARIS
C  CHANGES : D. HECK    IK3  FZK KARLSRUHE
C-----------------------------------------------------------------------

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
*KEEP,CONSTA.
      COMMON /CONSTA/  PI,PI2,OB3,TB3,ENEPER
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER
*KEEP,RANDPA.
      COMMON /RANDPA/  FAC,U1,U2,RD,NSEQ,ISEED,KNOR
      DOUBLE PRECISION FAC,U1,U2
      REAL             RD(3000)
      INTEGER          ISEED(103,10),NSEQ
      LOGICAL          KNOR
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEND.

      SAVE
C-----------------------------------------------------------------------

CC    IF ( DEBUG ) WRITE(MDEBUG,*) 'PTRAM : ZN=',SNGL(ZN)

C  TWO RANDOM NUMBERS
      CALL RMMAR( RD,2,1 )
C  GENERATE <P_T>
      ALFA = -0.05D0
      B = ZN-1.D0
      A = RD(1)/B
      U = 0.D0
      DO 5  J = 1,1000
        F1 =  A * (U+1.D0)**B - 1.D0/B
        IF ( F1 .GE. U ) GOTO 15
        U  = U + 0.05D0
 5    CONTINUE
 15   BETA = U
      ALFA = U - 0.05D0
      IF ( F1-U .EQ. 0.D0 ) GOTO 30
      I = 0
 14   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   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
*CMZ :          14/06/2000  14.29.37  by  D. HECK IK3 FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
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
C   PTY    = TRANSVERSE MOMENTUM IN Y DIRECTION
C
C  DESIGN  : T. THOUW   IK3  FZK KARLSRUHE
C  CHANGES : D. HECK    IK3  FZK KARLSRUHE
C-----------------------------------------------------------------------

      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
*KEEP,CONSTA.
      COMMON /CONSTA/  PI,PI2,OB3,TB3,ENEPER
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER
*KEEP,RANDPA.
      COMMON /RANDPA/  FAC,U1,U2,RD,NSEQ,ISEED,KNOR
      DOUBLE PRECISION FAC,U1,U2
      REAL             RD(3000)
      INTEGER          ISEED(103,10),NSEQ
      LOGICAL          KNOR
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEND.

      SAVE
C-----------------------------------------------------------------------

CC    IF ( DEBUG ) WRITE(MDEBUG,*) 'PTRAN : ZN=',SNGL(ZN)

C  TWO RANDOM NUMBERS
      CALL RMMAR( 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
*CMZ :          24/10/2000  15.41.00  by  D. HECK IK3 FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
C=======================================================================

      SUBROUTINE RESDEC

C-----------------------------------------------------------------------
C  RES(ONANCE) DEC(AY)
C
C  ROUTINE TREATES DECAY OF THE RESONANCES RHO, K*, AND DELTA
C  THE DECAY MODE IS SELECTED BY THE RANDOM NUMBER RESRAN, WHICH IS
C  SET IN THE SUBROUT. HDPM/LEPACX, WHERE THE RESONANCE IS FORMED
C  DECAY WITH FULL KINEMATIC, ENERGY AND MOMENTA CONSERVED
C  THIS SUBROUTINE IS CALLED FROM BOX3.
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,CONSTA.
      COMMON /CONSTA/  PI,PI2,OB3,TB3,ENEPER
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER
*KEEP,DECAY.
      COMMON /DECAY/   GAM345,COS345,PHI345
      DOUBLE PRECISION GAM345(3),COS345(3),PHI345(3)
*KEEP,GENER.
      COMMON /GENER/   GEN,ALEVEL
      DOUBLE PRECISION GEN,ALEVEL
*KEEP,LONGI.
      COMMON /LONGI/   ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP,LLONGI,FLGFIT
      DOUBLE PRECISION ADLONG(0:1170,9),AELONG(0:1170,9),
     *                 APLONG(0:1170,9),DLONG(0:1170,9),ELONG(0:1170,9),
     *                 HLONG(0:1170),PLONG(0:1170,9),SDLONG(0:1170,9),
     *                 SELONG(0:1170,9),SPLONG(0:1170,9),THSTEP,THSTPI
      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT
*KEEP,PAM.
      COMMON /PAM/     PAMA,SIGNUM,RESTMS
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000)
*KEEP,PARPAR.
      COMMON /PARPAR/  CURPAR,SECPAR,PRMPAR,OUTPAR,C,
     *                 E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
      DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16),
     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH
      INTEGER          ITYPE,LEVL
*KEEP,PARPAE.
      DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM
     *                 ,WEIGHT
     *                 ,HAPP,COSTAP,COSTEA
      EQUIVALENCE      (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE),
     *                 (CURPAR(4), PHI   ), (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)
*KEEP,RANDPA.
      COMMON /RANDPA/  FAC,U1,U2,RD,NSEQ,ISEED,KNOR
      DOUBLE PRECISION FAC,U1,U2
      REAL             RD(3000)
      INTEGER          ISEED(103,10),NSEQ
      LOGICAL          KNOR
*KEEP,RESON.
      COMMON /RESON/   RDRES,RESRAN,IRESPAR
      REAL             RDRES(2),RESRAN(30000)
      INTEGER          IRESPAR
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEND.

      INTEGER          I,KK,M3,M4
      SAVE
C-----------------------------------------------------------------------

      IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=1,9)
  444 FORMAT(' RESDEC: CURPAR=',1P,9E10.3)

C  COPY VERTEX COORDINATES INTO SECPAR
      DO 141  KK = 5,8
        SECPAR(KK) = CURPAR(KK)
 141  CONTINUE
      SECPAR( 9)  = GEN
      SECPAR(10)  = ALEVEL
      SECPAR(14)  = CURPAR(14)
      SECPAR(15)  = CURPAR(15)
      SECPAR(16)  = CURPAR(16)

      BETA = SQRT( GAMMA**2 - 1.D0 ) / GAMMA

      IF ( IRESPAR .LE. 0 ) THEN
        WRITE(MONIOU,*) 'RESDEC: IRESPAR .LE. 0, CORRECTED'
        IRESPAR = 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(IRESPAR) .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 )

C-----------------------------------------------------------------------
C  RHO RESONANCES

      ELSEIF ( ITYPE .EQ. 51 ) THEN
C  DECAY    RHO(0)  ---->  PI(+) + PI(-)
        CALL DECAY1( ITYPE, 8, 9 )

      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 RMMAR(RD,1,1)
        IF     ( RD(1) .LE. 0.8924 ) 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 ADDANG( COSTHE,PHI, COS345(I),PHI345(I),
     *                                SECPAR(3),SECPAR(4) )
            IF ( SECPAR(3) .GT. C(29) ) THEN
              IF ( I .EQ. 3 ) THEN
                SECPAR(1) = 7.D0
              ELSE
                SECPAR(1) = 7 + I
              ENDIF
              SECPAR(2) = GAM345(I)
              CALL TSTACK
            ELSE
              IF ( LLONGI ) THEN
C  ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT
                IF     ( I .EQ. 3 ) THEN
                  DLONG(LHEIGH,7) = DLONG(LHEIGH,7) + GAM345(I)*PAMA(7)
                ELSE
                  DLONG(LHEIGH,7) = DLONG(LHEIGH,7) + GAM345(I)*PAMA(8)
                ENDIF
              ENDIF
            ENDIF
          ENDDO
        ELSEIF ( RD(1) .LE. 0.9778 ) THEN
C  DECAY    OMEGA  ---->  PI(0) + GAMMA
          CALL DECAY1 ( ITYPE, 7, 1 )
        ELSE
C  DECAY    OMEGA  ---->  PI(+) + PI(-)
          CALL DECAY1( ITYPE, 8, 9 )
        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(IRESPAR) .LE.      TB3 ) THEN
          CALL DECAY1( ITYPE, 11, 9 )
        ELSEIF ( RESRAN(IRESPAR) .LE. .8333333 ) 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(IRESPAR) .LE.      TB3 ) THEN
          CALL DECAY1( ITYPE, 12, 8 )
        ELSEIF ( RESRAN(IRESPAR) .LE. .8333333 ) 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(IRESPAR) .LE.      TB3 ) THEN
          CALL DECAY1( ITYPE, ITYPE-52, 7 )
        ELSEIF ( RESRAN(IRESPAR) .LE. .8333333 ) THEN
          CALL DECAY1( ITYPE, 10, ITYPE-55 )
        ELSE
          CALL DECAY1( ITYPE, 16, ITYPE-55 )
        ENDIF

C-----------------------------------------------------------------------
C  ANTI-NUCLEON RESONANCES

      ELSEIF ( ITYPE .EQ. 58 ) THEN
C  DECAY    ANTI-DELTA(--)  ---->  ANTI-P + PI(-)
        CALL DECAY1( ITYPE, 15, 9 )

      ELSEIF ( ITYPE .EQ. 59  .OR.  ITYPE .EQ. 60 ) THEN
C  DECAY    ANTI-DELTA(-)   OR       DECAY    ANTI-DELTA(0)

        IF ( RESRAN(IRESPAR) .LE. TB3 ) THEN
C  DECAY    ANTI-DELTA(-)  ---->  ANTI-P + PI(0)
C  DECAY    ANTI-DELTA(0)  ---->  ANTI-N + PI(0)
          M3 = 15 + (ITYPE - 59) * 10
          CALL DECAY1( ITYPE, M3, 7 )

        ELSE
C  DECAY    ANTI-DELTA(-)  ---->  ANTI-N + PI(-)
C  DECAY    ANTI-DELTA(0)  ---->  ANTI-P + PI(+)
          M3 = 15 + (60 - ITYPE) * 10
          M4 = 68 - ITYPE
          CALL DECAY1( ITYPE, M3, M4 )
        ENDIF

      ELSEIF ( ITYPE .EQ. 61 ) THEN
C  DECAY    ANTI-DELTA(+)  ---->  ANTI-N + PI(+)
        CALL DECAY1( ITYPE, 25, 8 )

C-----------------------------------------------------------------------
      ELSE
        WRITE(MONIOU,444) (CURPAR(I),I=1,9)
        WRITE(MONIOU,*) 'RESDEC: UNFORESEEN PARTICLE CODE =',ITYPE
      ENDIF
      IRESPAR = IRESPAR - 1

      RETURN
      END
*CMZ :          14/06/2000  14.29.37  by  D. HECK IK3 FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
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   XN     = <N>  AVERAGE VALUE OF N
C   ECM    = CENTER OF MASS ENERGY
C   N      = RANDOM NUMBER DISTRIBUTED WITH NEG. BIN. DISTR.
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,RANDPA.
      COMMON /RANDPA/  FAC,U1,U2,RD,NSEQ,ISEED,KNOR
      DOUBLE PRECISION FAC,U1,U2
      REAL             RD(3000)
      INTEGER          ISEED(103,10),NSEQ
      LOGICAL          KNOR
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEND.

      DOUBLE PRECISION ECM,P,PN,Q,R,SUM,XI,XK,XN
      INTEGER          N
      SAVE
C-----------------------------------------------------------------------

CC    IF ( DEBUG ) WRITE(MDEBUG,*) 'RNEGBI: XN,ECM=',SNGL(XN),SNGL(ECM)

C  PARAMETRIZATION 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 RMMAR( RD,1,1 )
      IF ( RD(1) .LE. SUM ) GOTO 100
C  COMPARE WITH SUM OVER P(N)
      DO  2  XI = 1.D0, 1350.D0
        PN  = PN * P * (XK - 1.D0 + XI) / XI
        SUM = SUM + PN
        IF ( RD(1) .LE. SUM ) THEN
          N = XI
          GOTO 100
        ENDIF
  2   CONTINUE
      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
*CMZ :          14/06/2000  14.29.37  by  D. HECK IK3 FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
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)
*KEEP,DPMFLG.
      COMMON /DPMFLG/  NFLAIN,NFLDIF,NFLPI0,NFLCHE,NFLPIF,NFRAGM
      INTEGER          NFLAIN,NFLDIF,NFLPI0,NFLCHE,NFLPIF,NFRAGM
*KEEP,GNUPR.
      COMMON /GNUPR/   SE14,SE16,SE40
      DOUBLE PRECISION SE14(3,14),SE16(3,16),SE40(3,40)
*KEEP,INTER.
      COMMON /INTER/   AVCH,AVCH3,DC0,DLOG,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,DLOG,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
*KEEP,PARPAR.
      COMMON /PARPAR/  CURPAR,SECPAR,PRMPAR,OUTPAR,C,
     *                 E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
      DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16),
     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH
      INTEGER          ITYPE,LEVL
*KEEP,RANDPA.
      COMMON /RANDPA/  FAC,U1,U2,RD,NSEQ,ISEED,KNOR
      DOUBLE PRECISION FAC,U1,U2
      REAL             RD(3000)
      INTEGER          ISEED(103,10),NSEQ
      LOGICAL          KNOR
*KEEP,REST.
      COMMON /REST/    CONTNE,TAR,LT
      DOUBLE PRECISION CONTNE(3),TAR
      INTEGER          LT
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEEP,SIGM.
      COMMON /SIGM/    SIGMA,SIGANN,SIGAIR,FRACTN,FRCTNO
      DOUBLE PRECISION SIGMA,SIGANN,SIGAIR,FRACTN,FRCTNO
*KEND.

      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 RMMAR( RD,1,1 )
        IF ( DEBUG ) WRITE(MDEBUG,*) 'TARINT: DELSIG,DSIGSQ,RD(1),TAR=',
     *                      SNGL(DELSIG),SNGL(DSIGSQ),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 6151  JL = 1,14
            PROB = PROB +
     *             SE14(1,JL) + SE14(2,JL)*DELSIG + SE14(3,JL)*DSIGSQ
            IF ( RD(1) .LE. PROB ) GOTO 7332
 6151     CONTINUE

C  TREAT INTERACTION WITH OXYGEN TARGET
        ELSEIF ( TAR .EQ. 16.D0 ) THEN
C  SUM OF PROBABILITIES FOR COLLISION WITH OXYGEN TARGET
          DO 6152  JL = 1,16
            PROB = PROB +
     *             SE16(1,JL) + SE16(2,JL)*DELSIG + SE16(3,JL)*DSIGSQ
            IF ( RD(1) .LE. PROB ) GOTO 7332
 6152     CONTINUE

C  TREAT INTERACTION WITH ARGON TARGET
        ELSEIF ( TAR .EQ. 40.D0 ) THEN
C  SUM OF PROBABILITIES FOR COLLISION WITH ARGON TARGET
          DO 6153  JL = 1,40
            PROB = PROB +
     *             SE40(1,JL) + SE40(2,JL)*DELSIG + SE40(3,JL)*DSIGSQ
            IF ( RD(1) .LE. PROB ) GOTO 7332
 6153     CONTINUE
        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 PARAMETRIZATION 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
*CMZ :          28/02/2002  13.08.20  by  D. HECK IK FZK KARLSRUHE
*-- Author :    CERN PROGLIB# V113
C=======================================================================

      FUNCTION RANGEN()

C-----------------------------------------------------------------------
C  RAN(DOM  NUMBER) GEN(ERATOR)
C
C  SEE SUBROUT. RMMAR
C  THIS FUNCTION IS CALLED FROM MANY VENUS ROUTINES.
C
C  CERN PROGLIB# V113    RMMAR           .VERSION KERNFOR  1.0
C  ORIG. 01/03/89 FCA + FJ
C
C  CHANGES  : D. HECK    IK3  FZK KARLSRUHE
C  DATE     : FEB  02, 1994
C-----------------------------------------------------------------------

C     REAL RVEC(1)
      COMMON /RANMA2/ IU(1030),JSEQ
      COMMON /RANMA3/ TWOM24,TWOM48,CD,CM,CINT,MODCNS
      INTEGER I97(0:1030),J97(0:1030),NTOT(0:1030)
      INTEGER NTOT2(0:1030),IJKL(0:1030)
      REAL    U(97),C(0:1030)
      EQUIVALENCE (IJKL(0),IU(1)),(NTOT(0),IU(2)),(NTOT2(0),IU(3))
      EQUIVALENCE (U(1),IU(4)),(C(0),IU(101)),(I97(0),IU(102))
      EQUIVALENCE (J97(0),IU(103))
      SAVE
C-----------------------------------------------------------------------

C     ISEQ = 1
      LENV = 1
C     IF ( ISEQ .GT. 0 ) JSEQ = ISEQ
C     IBASE = (JSEQ-1)*103
      IBASE = 0

      IVEC = 1
C     DO 100  IVEC = 1,LENV
        UNI = U(     +I97(IBASE))-U(     +J97(IBASE))
        IF ( UNI .LT. 0. ) UNI = UNI+1.
        U(     +I97(IBASE)) = UNI
        I97(IBASE) = I97(IBASE)-1
        IF ( I97(IBASE) .EQ. 0 ) I97(IBASE) = 97
        J97(IBASE) = J97(IBASE)-1
        IF ( J97(IBASE) .EQ. 0 ) J97(IBASE) = 97
        C(IBASE)   = C(IBASE) - CD
        IF ( C(IBASE) .LT. 0. ) C(IBASE) = C(IBASE)+CM
        UNI = UNI-C(IBASE)
        IF ( UNI .LT. 0. ) UNI = UNI+1.
C  REPLACE EXACT ZEROES BY UNIFORM DISTR. *2**-24
        IF ( UNI .EQ. 0. ) THEN
          UNI = TWOM24*U(2)
C  AN EXACT ZERO HERE IS VERY UNLIKELY, BUT LET'S BE SAFE.
          IF ( UNI .EQ. 0. ) UNI = TWOM48
        ENDIF
        RANGEN = UNI
  100 CONTINUE

      NTOT(IBASE) = NTOT(IBASE) + LENV
      IF ( NTOT(IBASE) .GE. MODCNS ) THEN
        NTOT2(IBASE) = NTOT2(IBASE) + 1
        NTOT(IBASE)  = NTOT(IBASE) - MODCNS
      ENDIF

      RETURN
      END
*CMZ :          28/02/2002  12.36.15  by  D. HECK IK FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
C=======================================================================

      SUBROUTINE UTQSEA(X1,X2,X3)

C-----------------------------------------------------------------------
C  UT(ILITY ROUTINE) SEA (QUARK STRUCTURE FUNCTION)
C
C  SEA QUARK STRUCTURE FUNCTION INTEGRAL
C  RETURNS INTEGRAL (XSE(1)->XSE(I)) OF FU(Z) DZ
C  THIS SUBROUTINE IS CALLED FROM VENLNK.
C  ARGUMENTS:
C   X1     =
C   X2     =
C   X3     =
C
C  DESIGN   : D. HECK    IK3  FZK KARLSRUHE
C-----------------------------------------------------------------------

*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEND.

      PARAMETER (NSTRU=2049)
      COMMON /FILES/   IFCH,IFDT,IFHI,IFMT,IFOP
      COMMON /PARO1/   AMPRIF,AMSIAC,BMAXIM,BMINIM,CORE,CUTMSQ,CUTMSS
     *                ,DELMSS,DELREM,FCTRMX,GAUMX,OVERLP,PAREA,PDIQUA
     *                ,PHARD,PSPINL,PSPINH,PISPN,PTF,PTH,PTMX,PTQ,PUD
     *                ,PVALEN,QSEPC,QSETC,QMUST,QVAPC,QVATC,RADIAC
     *                ,RADIAS,RSTRAS,SIGJ,SIGPPI,TAUMAX,TAUMIN
     *                ,TAUMX,TAUNLL,TENSN,THEMAS,WPROJ,WTARG,WTMINI
     *                ,WTSTEP,XCUT
     *                ,IAQU,IFRADE,IOJINT,IOPBRK,IOPENT,IOPENU
     *                ,IOPTF,IOPTQ,IRESCL,IWCENT,KENTRO,KO1KO2
     *                ,LABSYS,MAXRES,NCLEAN,NCOLMX,NDECAW,NEQMN,NEQMX
     *                ,NSTTAU,NTRYMX,NUMTAU
      COMMON /PARO2/   AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY
     *                ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA
     *                ,YHAHA,YMXIMI,YPJTL
     *                ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM
     *                ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH
     *                ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI
     *                ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG
     *                ,MODSHO,NDECAX,NDECAY,NEVENT
      COMMON /STRU2/   DELTA0,DELTA1,QSEH(NSTRU),QSEPI(NSTRU)
     *                ,QVAH(NSTRU),QVAPI(NSTRU),XSE(NSTRU),XVA(NSTRU)
      SAVE
C-----------------------------------------------------------------------

      IF ( DEBUG ) WRITE(MDEBUG,*) 'UTQSEA:'

      X0 = 0.
      N = NSTRU
      IF ( ISH .GE. 90 ) THEN
        IF ( X1.LT.X0  .OR.  X2.LT.X1  .OR.  X3.LT.X2 ) THEN
          CALL UTMSG('UTQSEA')
          WRITE(IFCH,*) '   XI=',X0,X1,X2,X3
          CALL UTMSGF
        ENDIF
      ENDIF
      I1 = N/3
      I2 = 2*N/3
      FAC1 = (X1-X0)/FLOAT(I1-1)
      DO 11  I = 1,I1-1
        XSE(I)=(I-1.)*FAC1+X0
 11   CONTINUE
      FAC2 = (X2-X1)/FLOAT(I2-I1)
      DO 12  I = I1,I2-1
        XSE(I)=FLOAT(I-I1)*FAC2 +X1
 12   CONTINUE
      FAC3 = (X3-X2)/FLOAT(N-I2)
      DO 13  I = I2,N
        XSE(I)=MIN( FLOAT(I-I2)*FAC3 +X2, 0.99999999 )
 13   CONTINUE

      XCUT2 = XCUT**2
      XCUT4 = XCUT2**2
      XCUT6 = XCUT2*XCUT4
      CUTLOG = LOG(XCUT)
C  COEFFICIENTS FOR HADRONIC SEA QUARK STRUCTURE FUNCTION
      AH0 = -8. + 37.333333*XCUT2 - 29.866667*XCUT4 + 3.65714286*XCUT6
      AH1 = 14. - 26.25*XCUT2 + 8.75*XCUT4 - 0.2734375*XCUT6
      AH2 = -18.666667 + 14.933333*XCUT2 - 1.82857143*XCUT4
      AH3 = 17.5 - 5.8333333*XCUT2 + 0.182291667*XCUT4
      AH4 = -11.2 + 1.37142857*XCUT2
      AH5 = 4.6666667 - 0.14583333*XCUT2
      AH6 = -1.14285714
      AH7 = 0.125
      QAH = 1. - AH1 * XCUT2
      AHCUT = AH0 * XCUT
C  COEFFICIENTS FOR PIONIC SEA QUARK STRUCTURE FUNCTION
      API0 = -5. + 6.6666667*XCUT2 - 0.53333333*XCUT4
      API1 = 5. - 1.875*XCUT2
      API2 = -3.3333333 + 0.26666667*XCUT2
      API3 = 1.25
      API4 = -0.2
      QAPI = 1. - API1 * XCUT2
      APICUT = API0 * XCUT

      QSEH(1)  = 0.
      QSEPI(1) = 0.
      DO 2  I = 2,N
        Z = XSE(I)
        ROOT     = SQRT(Z**2 + XCUT2)
        ROOTLG   = LOG( Z + ROOT ) - CUTLOG
        QSEH(I)  = 1.265 * ( QAH * ROOTLG - AHCUT
     *             + ROOT * (AH0 + Z*(AH1 + Z*(AH2 + Z*(AH3
     *             + Z*(AH4 + Z*(AH5 + Z*(AH6 + Z*AH7))))))) )
        QSEPI(I) = 0.9 * ( QAPI * ROOTLG - APICUT
     *             + ROOT * (API0+Z*(API1+Z*(API2+Z*(API3+Z*API4)))) )
 2    CONTINUE

      RETURN
      END
*CMZ :          14/06/2000  14.17.24  by  D. HECK IK3 FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
C=======================================================================

      SUBROUTINE UTQVAL(Q,NEND)

C-----------------------------------------------------------------------
C  UT(ILITY ROUTINE) VAL(ENCE QUARK STRUCTURE FUNCTION)
C
C  VALENCE QUARK STRUCTURE FUNCTION
C  RETURNS  INTEGRAL (XVA(1)->XVA(I)) FU(Z) DZ
C  THIS INTEGRAL IS ONLY CALCULATED FOR SMALL VALUES OF XVA UP TO 25
C  TIMES THE VALUE OF XCUT. FOR LARGER VALUES THE TABULATED VALUES OF
C  DATASET 'VENUSDAT' ARE TAKEN AND CORRECTED BY THE CONSTANT SHIFT
C  DELTA0 (FOR HADRONS) OR DELTA1 (FOR PIONS).
C  THIS SUBROUTINE IS CALLED FROM VENLNK.
C  ARGUMENTS:
C   Q      = INTEGRAL VALUE
C   NEND   = POINTER TO LAST ARGUMENT
C
C  DESIGN   : D. HECK    IK3  FZK KARLSRUHE
C-----------------------------------------------------------------------

*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEND.

      PARAMETER (NSTRU=2049)
      COMMON /CIPIO/   IPIO
      COMMON /FILES/   IFCH,IFDT,IFHI,IFMT,IFOP
      COMMON /PARO1/   AMPRIF,AMSIAC,BMAXIM,BMINIM,CORE,CUTMSQ,CUTMSS
     *                ,DELMSS,DELREM,FCTRMX,GAUMX,OVERLP,PAREA,PDIQUA
     *                ,PHARD,PSPINL,PSPINH,PISPN,PTF,PTH,PTMX,PTQ,PUD
     *                ,PVALEN,QSEPC,QSETC,QMUST,QVAPC,QVATC,RADIAC
     *                ,RADIAS,RSTRAS,SIGJ,SIGPPI,TAUMAX,TAUMIN
     *                ,TAUMX,TAUNLL,TENSN,THEMAS,WPROJ,WTARG,WTMINI
     *                ,WTSTEP,XCUT
     *                ,IAQU,IFRADE,IOJINT,IOPBRK,IOPENT,IOPENU
     *                ,IOPTF,IOPTQ,IRESCL,IWCENT,KENTRO,KO1KO2
     *                ,LABSYS,MAXRES,NCLEAN,NCOLMX,NDECAW,NEQMN,NEQMX
     *                ,NSTTAU,NTRYMX,NUMTAU
      COMMON /STRU2/   DELTA0,DELTA1,QSEH(NSTRU),QSEPI(NSTRU)
     *                ,QVAH(NSTRU),QVAPI(NSTRU),XSE(NSTRU),XVA(NSTRU)

      DIMENSION        Y0(9),Y1(9),Q(NEND)
      SAVE
C-----------------------------------------------------------------------

      IF ( DEBUG ) WRITE(MDEBUG,*) 'UTQVAL: IPIO,NEND=',IPIO,NEND

      XCUT2 = XCUT**2
      Q(1)  = 0.
      Z = XVA(1)
      DENOMI = 1. / SQRT(Z**2 + XCUT2)

      IF ( IPIO .EQ. 0 ) THEN
C  CALCULATE THE FIRST NEND VALUES OF STRUCTURE FUNCTION FOR HADRONS
        Y0(1) = 0.
        DO 3  I = 2,NEND
          FACT = (XVA(I) - Z) * 0.125
          DO 2  J = 2,8
            Z = Z + FACT
            DENOMI = 1. / SQRT(Z**2 + XCUT2)
            Y0(J) = (1.-Z)**3.46 * Z**.419 * (2.74793064*Z + 0.62452969)
     *              * DENOMI
 2        CONTINUE
          Z = XVA(I)
          DENOMI = 1. / SQRT(Z**2 + XCUT2)
          Y0(9) = (1.-Z)**3.46 * Z**.419 * (2.74793064*Z + 0.62452969)
     *             * DENOMI
C  INTEGRATION AFTER BODE'S RULE (ABRAMOWITZ + STEGUN, HANDBOOK OF
C  MATHEMATICAL FUNCTIONS, DOVER PUBLICATIONS (1970), FORMULA 25.4.18)
          Q(I) =  2.8218694E-4 * FACT *       ( 989. * (Y0(1) + Y0(9))
     *            +  5888. * (Y0(2) + Y0(8)) -  928. * (Y0(3) + Y0(7))
     *            + 10496. * (Y0(4) + Y0(6)) - 4540. *  Y0(5) )
     *                         + Q(I-1)
          Y0(1) = Y0(9)
 3      CONTINUE

      ELSE
C  CALCULATE THE FIRST NEND VALUES OF STRUCTURE FUNCTION FOR PIONS
        Y1(1) = 0.
        DO 5  I = 2,NEND
          FACT = (XVA(I) - Z) * 0.125
          DO 4  J = 2,8
            Z = Z + FACT
            DENOMI = 1. / SQRT(Z**2 + XCUT2)
            Y1(J) = (1.-Z)**0.7 * Z**.4 * DENOMI
 4        CONTINUE
          Z = XVA(I)
          DENOMI = 1. / SQRT(Z**2 + XCUT2)
          Y1(9) = (1.-Z)**0.7 * Z**.4 * DENOMI
C  INTEGRATION AFTER BODE'S RULE (ABRAMOWITZ + STEGUN, HANDBOOK OF
C  MATHEMATICAL FUNCTIONS, DOVER PUBLICATIONS (1970), FORMULA 25.4.18)
          Q(I) =  2.8218694E-4 * FACT *       ( 989. * (Y1(1) + Y1(9))
     *            +  5888. * (Y1(2) + Y1(8)) -  928. * (Y1(3) + Y1(7))
     *            + 10496. * (Y1(4) + Y1(6)) - 4540. *  Y1(5) )
     *            * 0.1730725  + Q(I-1)
          Y1(1) = Y1(9)
 5      CONTINUE
      ENDIF

      RETURN
      END
*CMZ :          14/04/2000  12.25.46  by  D. HECK IK3 FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
C=======================================================================

      BLOCK DATA VENDAT

C-----------------------------------------------------------------------
C  VEN(US) DAT(A INITIALIZATION)
C
C  INITIALIZES DATA FOR VENUS LINK
C
C  DESIGN   : D. HECK    IK3  FZK KARLSRUHE
C-----------------------------------------------------------------------

      COMMON /VENLIN/  PTQ1,PTQ2,PTQ3,QMUST1,QMUST2,QMUST3
     *                ,IDTABL(100)

      DATA IDTABL/
     *   10,  -12,   12,    0,  -14,   14,  110,  120, -120,  -20,
     *  130, -130, 1220, 1120,-1120,   20,  220, 2130, 1130, 1230,
     * 2230, 1330, 2330, 3331,-1220,-2130,-1130,-1230,-2230,-1330,
     *-2330,-3331,  -16,   16, -240,  240, -140,  140, -340,  340,
     * 2140,    0,    0,    0,    0,    0,    0,    0,    0,    0,
     *  111,  121, -121, 1111, 1121, 1221, 2221,-1111,-1121,-1221,
     *-2221,  231,  131, -131, -231,   11,  -11,   13,  -13,    0,
     *  220,  220,  220,  220,    0,             25*0          /

      END
*CMZ :          28/02/2002  12.36.15  by  D. HECK IK FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
C=======================================================================

      SUBROUTINE VENINI

C-----------------------------------------------------------------------
C  VEN(US) INI(TIALIZATION)
C
C  FIRST INITIALIZATION OF VENUS ARRAYS AND PARAMETERS
C  THIS SUBROUTINE IS CALLED FROM START.
C
C  DESIGN   : D. HECK    IK3  FZK KARLSRUHE
C-----------------------------------------------------------------------

*KEEP,AIR.
      COMMON /AIR/     COMPOS,PROBTA,AVERAW,AVOGAD
      DOUBLE PRECISION COMPOS(3),PROBTA(3),AVERAW,AVOGAD
*KEEP,PAM.
      COMMON /PAM/     PAMA,SIGNUM,RESTMS
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000)
*KEEP,RANDPA.
      COMMON /RANDPA/  FAC,U1,U2,RD,NSEQ,ISEED,KNOR
      DOUBLE PRECISION FAC,U1,U2
      REAL             RD(3000)
      INTEGER          ISEED(103,10),NSEQ
      LOGICAL          KNOR
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEEP,VENPAR.
      COMMON /VENPAR/  PARVAL,NPARAM,PARCHA
      REAL             PARVAL(100)
      INTEGER          NPARAM
      CHARACTER*6      PARCHA(100)
*KEEP,VENUS.
      COMMON /VENUS/   ISH00,IVERVN,MTAR99,FVENUS,FVENSG
      INTEGER          ISH00,IVERVN,MTAR99
      LOGICAL          FVENUS,FVENSG
*KEND.

      PARAMETER (KOLLMX=2500)
      PARAMETER (MXEPS=10)
      PARAMETER (MXTAU=4)
      PARAMETER (MXVOL=10)
      PARAMETER (NGAU=129)
      PARAMETER (NDEP=129)
      PARAMETER (NDET=129)
      PARAMETER (NPTF=129)
      PARAMETER (NPTJ=129)
      PARAMETER (NSTRU=2049)
      COMMON /ACCUM/   AMSAC,ILAMAS,IMSG,INOIAC,IPAGE,JERR,NAEVT,NREVT
     *                ,NRPTL,NRSTR,NTEVT
      COMMON /CDEN/    MASSNR,RMX,R0
      COMMON /CGAU/    QGAU(NGAU),XGAU(NGAU)
      COMMON /CIUTOT/  IUTOTC,IUTOTE
      COMMON /CJINTC/  CLUST(MXTAU,MXVOL,MXEPS)
      COMMON /CJINTD/  VOLSUM(MXTAU),VO2SUM(MXTAU),NCLSUM(MXTAU)
      COMMON /CLEP/    ICINPU,IDSCAT
      COMMON /CNSTA/   AINFIN,PI,PIOM,PROM
      COMMON /COL/     BIMP,BMAX,COORD(4,KOLLMX),DISTCE(KOLLMX)
     *                ,QDEP(NDEP),QDET14(NDET),QDET16(NDET),QDET40(NDET)
     *                ,QDET99(NDET),RMPROJ,RMTARG(4),XDEP(NDEP)
     *                ,XDET14(NDET),XDET16(NDET),XDET40(NDET)
     *                ,XDET99(NDET)
     *                ,KOLL,LTARG,NORD(KOLLMX),NPROJ,NRPROJ(KOLLMX)
     *                ,NRTARG(KOLLMX),NTARG
      COMMON /CPTF/    FPTFS,FPTFSS,FPTFU,FPTFUS,FPTFUU
     *                ,QPTFS(NPTF),QPTFSS(NPTF),QPTFU(NPTF),QPTFUS(NPTF)
     *                ,QPTFUU(NPTF),XPTF(NPTF)
      COMMON /CPTJ/    QPTJ(NPTJ),XPTJ(NPTJ)
      COMMON /CPTLU/   NPTLU
      COMMON /CQUAMA / QUAMA
      DOUBLE PRECISION SEEDC,SEEDI
      COMMON /CSEED/   SEEDC,SEEDI
      COMMON /CVSN/    IVERSN
      COMMON /EPSCR/   EPSCRI
      COMMON /FILES/   IFCH,IFDT,IFHI,IFMT,IFOP
      COMMON /NEVNT/   NEVNT
      COMMON /PARO1/   AMPRIF,AMSIAC,BMAXIM,BMINIM,CORE,CUTMSQ,CUTMSS
     *                ,DELMSS,DELREM,FCTRMX,GAUMX,OVERLP,PAREA,PDIQUA
     *                ,PHARD,PSPINL,PSPINH,PISPN,PTF,PTH,PTMX,PTQ,PUD
     *                ,PVALEN,QSEPC,QSETC,QMUST,QVAPC,QVATC,RADIAC
     *                ,RADIAS,RSTRAS,SIGJ,SIGPPI,TAUMAX,TAUMIN
     *                ,TAUMX,TAUNLL,TENSN,THEMAS,WPROJ,WTARG,WTMINI
     *                ,WTSTEP,XCUT
     *                ,IAQU,IFRADE,IOJINT,IOPBRK,IOPENT,IOPENU
     *                ,IOPTF,IOPTQ,IRESCL,IWCENT,KENTRO,KO1KO2
     *                ,LABSYS,MAXRES,NCLEAN,NCOLMX,NDECAW,NEQMN,NEQMX
     *                ,NSTTAU,NTRYMX,NUMTAU
      COMMON /PARO2/   AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY
     *                ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA
     *                ,YHAHA,YMXIMI,YPJTL
     *                ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM
     *                ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH
     *                ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI
     *                ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG
     *                ,MODSHO,NDECAX,NDECAY,NEVENT
      COMMON /PARO3/   ASUHAX(7),ASUHAY(7),OMEGA,SIGPPD,SIGPPE,UENTRO
     *                ,IWZZZZ
      COMMON /PARO4/   GRICEL,GRIDEL,GRIGAM,GRIRSQ,GRISLO
      COMMON /PARO5/   DELEPS,DELVOL
      COMMON /QUARKM/  SMAS,SSMAS,USMAS,UUMAS
      COMMON /STRU2/   DELTA0,DELTA1,QSEH(NSTRU),QSEPI(NSTRU)
     *                ,QVAH(NSTRU),QVAPI(NSTRU),XSE(NSTRU),XVA(NSTRU)
      COMMON /VENLIN/  PTQ1,PTQ2,PTQ3,QMUST1,QMUST2,QMUST3
     *                ,IDTABL(100)

      SAVE
      EXTERNAL         SDENSI,SGAU,SPTF,SPTJ
C-----------------------------------------------------------------------

      IF ( DEBUG ) WRITE(MDEBUG,*) 'VENINI:'

      IFMT = MONIOU
      IFCH = MDEBUG
      ICHOIC = 2
      NEVNT = 0

C     VERSION NUMBER
C     --------------
         IVERSN=4125
         IVERVN=IVERSN

C     FRAGMENTATION PARAMETERS/OPTIONS
C     --------------------------------
C     PROB. FOR U OR D QUARK PRODUCTION ( =(1-P_STRANGE)/2 ):
         PUD=0.455
C     QQ-QQBAR PROBABILITY
         PDIQUA=0.12
C     SPIN PROBABILITIES (FOR LIGHT AND HEAVY FLAVOURS):
         PSPINL=0.50
         PSPINH=0.75
C     ISOSPIN PROBABILITY:
         PISPN=0.50
C     OPTION FOR P_T DISTRIBUTION (1=EXPONENTIAL,2=GAUSSIAN):
         IOPTF=1
C     AVERAGE P_TRANSVERSE
         PTF=0.40
C     STRING TENSION:
         TENSN=1.0
C     STRING DECAY PARAMETER
         PAREA=.60
C     THRESHOLD RESONANCE -> STRING
         DELREM=1.0
C     CUTOFF FOR KMAXOR BEYOND WHICH PDIQ=0 IN SR JSPLIT
         KUTDIQ=4
C     OPTION FOR BREAKING PROCEDURE (1=AMOR,2=SAMBA)
         IOPBRK=1

C     PROTON-PROTON PARAMETERS/OPTIONS
C     --------------------------------
C     OPTION FOR QUARK P_T DISTRIBUTION (1=EXPONENTIAL,2=GAUSSIAN,3=POWE
         IOPTQ=2
C     MEAN TRANSVERSE MOMENTUM OF QUARKS
C      (Q1+Q2*LN(E)+Q3*LN(E)**2, E=SQRT(S)):
         PTQ1=0.260
         PTQ2=0.
         PTQ3=0.
C     PROBABILITY FOR SEMIHARD INTERACTION (NOT USED IF NEGATIVE):
C        PHARD=-1.0
C     CUTOFF PARAMETER FOR P_T DISTR. FOR SEMIHARD INTERACTIONS:
         PTH=1.0
C     EFFECTIVE RATIO OF STRANGE SEA OVER U SEA:
         RSTRAS=0.
C     EFFECTIVE CUTOFF MASS IN STRUCTURE FUNCTIONS:
         CUTMSQ=2.0
         CUTMSS=0.001
C     VALENCE QUARK FRACTION IN CASE OF DIFFRACTIVE INTERACTION
         PVALEN=0.30
C     PHASE SPACE PARAMETERS:
         DELMSS=0.300

C     GRIBOV-REGGE-THEORY PARAMETERS
C     ------------------------------
C     GAMMA (IN FM**2):
         GRIGAM=3.64*0.04
C     R**2(IN FM**2):
         GRIRSQ=3.56*0.04
C     DELTA=INTERCEPT OF REGGE TRAJECTORY-1:
         GRIDEL=0.07
C     SLOPE OF REGGE TRAJECTORY (IN FM**2):
         GRISLO=0.25*0.04
C     C (DETERMINES RELATIVE WEIGHT OF ELASTIC AND DIFFR CROSS-SCTN):
         GRICEL=1.5

C     NUCLEUS-NUCLEUS PARAMETERS
C     --------------------------
C     HARD CORE DISTANCE:
         CORE=0.8
C     JPSI NUCLEON CROSS-SECTION (FM**2):
         SIGJ=0.2

C     RESCATTERING PARAMETERS
C     -----------------------
C     REACTION TIME:
         TAUREA=1.5
C     OVERLAP PARAMETER (NOT USED IF NEGATIVE)
         OVERLP=-1.0
C     BARYON RADIUS:
         RADIAC=0.65
C     MESON RADIUS:
         RADIAS=0.35
C     CRITICAL ENERGY DENSITY (<0 TO AVOID SECONDARY INTERACTIONS):
         EPSCRI=1.0
C     BARYON ENERGY DENSITY
         EPSBAR=2.0
C     INTERACTION MASS:
         AMSIAC=0.8
C     OPTION TO CALL JINTA1 (1) OR JINTA2 (2)
         IOJINT=2
C     PRINT OPTIONS
         AMPRIF=0.
         DELVOL=1.0
         DELEPS=1.0

C     CLUSTER DECAY PARAMETERS/OPTIONS
C     --------------------------------
C     CORRELATION LENGTH
C     (CORLEN>1.0: FIRST FIX SHORT CLUSTER BREAKING
         CORLEN=1.0
C     MINIMUM MASS
         AMUSEG=3.0
C     BAG CONSTANT -1/4
         BAG4RT=0.200
C     OPTION FOR ENTROPY CALCULATION:
C      IOPENT=0: ZERO ENTROPY
C      IOPENT=1: OSCILLATOR MODEL (0 FOR K.LE.UENTRO)
C      IOPENT=2: FERMI GAS WITH CONST VOLUME (0 FOR K.LE.UENTRO)
C      IOPENT=3: FERMI GAS WITH CONST DENSITY (0 FOR K.LE.UENTRO)
C      IOPENT=4: FERMI GAS WITH CONST VOLUME - NEW (0 FOR K.LE.UENTRO)
C      IOPENT=5: RESONANCE GAS (HAGEDORN) (0 FOR U.LE.UENTRO)
         IOPENT=5
         UENTRO=4.0
         KENTRO=100000
C     DECAY TIME (COMOVING FRAME):
         TAUNLL=1.0
C     OSCILLATOR QUANTUM
         OMEGA=0.500

C     PRESENTLY NOT USED
C     ------------------

C     CLUSTER DECAY INITIALIZATIONS
C     -----------------------------
C     AVERAGE HADRON MASSES, TWO LOWEST MULTIPLETS (IF POSSIBLE):
C     N/DELTA,LAMBDA/SIGMA,XI,OMEGA,PI/RHO,KAON,DELTA:
         ASUHAX(1)=1.134
         ASUHAX(2)=1.301
         ASUHAX(3)=1.461
         ASUHAX(4)=1.673
         ASUHAX(5)=0.6125
         ASUHAX(6)=0.7915
         ASUHAX(7)=1.2320
C     LOWEST MASSES:
         ASUHAY(1)=0.940
         ASUHAY(2)=1.200
         ASUHAY(3)=1.322
         ASUHAY(4)=1.673
         ASUHAY(5)=0.1400
         ASUHAY(6)=0.4977
         ASUHAY(7)=1.2320

C     TECHNICAL PARAMETERS
C     --------------------
C     DELTA_ZETA FOR /C4PTL/...WEIPTL()
         DLZETA=0.5
C     MIN TAU FOR SPACE-TIME EVOLUTION:
         TAUMIN=0.
C     MAX TAU FOR SPACE-TIME EVOLUTION
         TAUMAX=10.0
C     TAU STEPS FOR SPACE-TIME EVOTUTION (46+40)
         NUMTAU=51
C     RANGE FOR PT DISTRIBUTION
         PTMX=6.0
C     RANGE FOR GAUSS DISTRIBUTION
         GAUMX=8.0
C     PARAMETER DETERMINING RANGE FOR DENSITY DISTRIBUTION
         FCTRMX=10.0
C     TRY-AGAIN PARAMETER
         NTRYMX=10
C     MAX TIME FOR JPSI EVOLUTION
         TAUMX=20.0
C     TIME STEPS FOR JPSI EVOLUTION
         NSTTAU=100

C     OPTIONS
C     -------
C     OPTION FOR MINIMUM ENERGY IN SJCGAM:
C       IOPENU = 1 : SUM OF HADRON MASSES
C       IOPENU = 2 : BAG MODEL CURVE WITH MINIMUM AT NONZERO STRANGEN.
         IOPENU=1
C     PARAMETER THETA IN BERGER/JAFFE MASS FORMULA
         THEMAS=0.51225
C     SEA PROBABILITY (IF .LT. 0. THEN CALCULATED FROM STRUCTURE FNCTS)
         PROSEA=-1.0
C     INELASTIC PP CROSS-SECTION (FM**2)
C      (IF NEGATIVE: CALCULATED FROM GRIBOV-REGGE-THEORY):
CDH      SIGPPI=-1.0
C     MULTISTRING PARAMETER (Q1+Q2*LN(E)+Q3*LN(E)**2, E=SQRT(S)):
C      (NOT USED IF RACPRO IS CALLED WITH 'GRI'-OPTION (DEFAULT))
         QMUST1=0.50
         QMUST2=0.
         QMUST3=0.
C     ENTRO() CALCULATED (1) OR FROM DATA (2)
         IENTRO=2
C     DUAL PARTON MODEL (1) OR NOT (ELSE)
         IDPM=0
C     ANTIQUARK COLOR EXCHANGE (1) OR NOT (0):
         IAQU=1
C     MINIMUM NUMBER OF VALENCE QUARKS:
         NEQMN=-5
C     MAXIMUM NUMBER OF VALENCE QUARKS:
         NEQMX=5
C     UPPER LIMIT FOR RAPIDITY INTERVAL FOR INTERMITTENCY ANALYSIS
         YMXIMI=2.0
C     CLEAN /CPTL/ IF NCLEAN > 0 (EVERY NCLEAN_TH TIME STEP)
         NCLEAN=0
C     TRAFO FROM PP-CM INTO LAB-SYSTEM (1) OR NOT (.NE.1)
         LABSYS=1
C     MAXIMUM NUMBER OF COLLISIONS:
         NCOLMX=1000
C     MAXIMUM RESONANCE SPIN (SPIN IN A GENARAL SENSE: MOD(/ID/,10))
         MAXRES=99999
C     MOMENTUM RESCALING (1=YES):
         IRESCL=1
C     NUE ENERGY
         ELEPTI=43.00
C     MUE  ENERGY
         ELEPTO=26.24
C     MUE ANGLE
         ANGMUE=3.9645/180.*3.1415926
C     JPSI TO BE PRODUCED (1) OR NOT (0):
         JPSI=0
C     JPSI FINAL STATE INTERACTION (1) OR NOT (0):
         JPSIFI=0
C     COLLISION TRIGGER (ONLY COLL BETWEEN KO1 AND KO2 ARE USED):
         KO1KO2=00009999
C     PRINT OPTION:
C     ISH=14: CALL UTTIMA
C     ISH=15: PRINTS PTLS READ FROM DATA FILE IN SR VEANLY
C     ISH=16: PRINTS SEA PROB.
C     ISH=17: PRINTS RANDOM NUMBERS
C     ISH=18: SR JCLUDE, NO-PHASE-SPACE CLUSTERS
C     ISH=19: SR AINITL, CALL SMASSP
C     ISH=20: SR VEANLY, PRINTS EVT NR IF EVT IS ACCEPTED
C     ISH=21: CREATES HISTOGRAM FOR SEA DISTRIBUTION
C     ISH=22: SR JFRADE, MSG AFTER CALL UTCLEA
C     ISH=23: CALL JINTFP
C     ISH=24: CALL JINTCL
C     ISH=25: CALL JCHPRT
C     ISH=90,91,92,93,94,95: MORE AND MORE DETAILED MESSAGES.
      IF ( DEBUG ) THEN
        ISH  = ISH00
      ELSE
        ISH  = 0
      ENDIF
C     PRINT OPTION:
C     ISHSUB=IJMN, IJ SPECIFIES LOCATION WHERE ISH=MN.
C     IJ=01: SR JCLUDE
C     IJ=02: SR JETGEN
C     IJ=03: SR JFRADE, STARTING BEFORE FRAGMENTATION
C     IJ=04: SR JDECAY
C     IJ=05: SR JDECAX
C     IJ=06: SR NUCOLL
C     IJ=07: SR NUCOGE+-
C     IJ=08: SR ASTORE
C     IJ=09: SR JFRADE, STARTING AFTER FRAGMENTATION
C     IJ=10: SR JFRADE, STARTING BEFORE DECAY
C     IJ=11: SR JFRADE, STARTING AFTER INTERACTIONS
C     IJ=12: SR JCENTR, ENTRO() IN DATA FORMAT
C     IJ=13: SR JCENTP
C     IJ=14: SR JDECAX IF CLUSTER DECAY
C     IJ=15: SR JSPLIT
C     IJ=16: SR JFRADE
C     IJ=17: SR RACPRO
C     IJ=18: SR UTCLEA
C     IJ=19: SR JINTA1, JINTA2, AFTER CALL UTCLEA
C     IJ=20: SR JDECAS
C     IJ=21: SR JDECAS (WITHOUT JDECAX)
         ISHSUB=0
C     PRINT OPTION:
C     IF ISHEVT.NE.0: FOR EVT#.NE.ISHEVT ISH IS SET TO 0
         ISHEVT=0
C     PRINT MARKS BETWEEN WHOM ISH IS SET TO ISH(INIT):
         IPAGI=0
C     VERIFY OPTION FOR INPUT READING:
         IVI=1
C     MAXIMUM IMPACT PARAMETER (BMAXIM=0=>CENTRAL):
         BMAXIM=10000.
C     MINIMUM IMPACT PARAMETER:
         BMINIM=0.
C     STORE ONLY STABLE PTL (0) OR ALSO PARENTS (1):
         ISTMAX=0
C     RANDOM GENERATOR SEED
         SEEDI=ISEED(1,1)
         SEEDC=ISEED(2,1)+1.D9*ISEED(3,1)
C     SUPPRESSION (1) OR NOT OF MESSAGES
         ISUP=0
C     SUPPRESSION OF CALLING JFRADE (0). JFRADE=FRAGM+DECAY+RESCATTERING
         IFRADE=1
C..   DECAY SUPPRESSION. NDECAY SPECIFIES WHICH RESONANCES ARE NOT DECAY
C..   0000001 : ALL RESONANCES
C..   0000010 : K_SHORT/LONG (+-20)
C..   0000100 : LAMBDA (+-2130)
C..   0001000 : SIGMA (+-1130,+-2230)
C..   0010000 : CASCADE (+-2330,+-1330)
C..   0100000 : OMEGA (+-3331)
C..   1000000 : PI0 (110)
         NDECAY=1111110
C..   DECAY SUPPRESSION. NDECAX SPECIFIES WHICH RESONANCES ARE NOT DECAY
C..   0000001 : JPSI
C..   0000010 : K_ZERO (+-230)
C..   0000100 : DELTA (+-1111,+-1121,+-1221,+-2221)
C..   0001000 : RHO,OMEGA,PHI (111,+-121,221,331)
C..   0010000 : ETA (220)
C..   0100000 : ETAPRIME (330)
C..   1000000 : A0 (112), A+- (+-122)
         NDECAX=0010000
C..   DECAY SUPPRESSION. NDECAW SPECIFIES WHICH RESONANCES ARE NOT DECAY
C..   0000001 : F0 (332)
C..   0000010 : K* (+-131,+-231)
         NDECAW=0
C     FILL ZZZZ HISTOGRAMS (1) OR NOT (0)
C        IWZZZZ=0
C     FILL INTERMITTENCY HISTOGRAMS (1) OR NOT (0)
C        IMIHIS=0
C     FILL SPACE-TIME HISTOGRAMS (1) OR NOT (0)
         ISPHIS=0
C     FILL CLUSTER HISTOGRAMS (1) OR NOT (0)
C        ICLHIS=0
C     FILL JPSI HISTOGRAMS (1) OR NOT (0)
C        IJPHIS=0
C     RHO/RHO+PHI RATIO
         RHOPHI=0.5
C     WSPA: ALL PTLS (1) OR ONLY INTERACTING PTLS (ELSE)
         ISPALL=1
C     TMIN IN WSPA
         WTMINI=-3.0
C     T-STEP IN WSPA
         WTSTEP=1.0
C     ONLY CENTRAL POINT (1) OR LONGITUDINAL DISTRIBUTION (ELSE) IN WSPA
         IWCENT=0
C     QUARK MASSES
         SMAS=0.
         UUMAS=0.
         USMAS=0.
         SSMAS=0.

C  CONSTANTS (PROTON MASS, PION MASS, PI, INFINITE)
C  ---------
C     PROM=0.94
      PROM=PAMA(14)
C     PIOM=0.14
      PIOM=PAMA(8)
      PI=3.141592654
      AINFIN=1.E+30

C  INITIALIZATIONS
C  ---------------
      LAPROJ = 0
      MAPROJ = 0
      LATARG = 0
      MAPROJ = 0
      IDPROJ = 1120
      IDTARG = 1120
      DO 6  I = 1,99
        PROB(I)    = 0.
        ICBAC(I,1) = 0
        ICBAC(I,2) = 0
        ICFOR(I,1) = 0
        ICFOR(I,2) = 0
 6    CONTINUE
      PNLL = 0.

C  FEW INITIALIZATIONS FOR CROSS-SECTION CALCULATIONS
C  --------------------------------------------------

      IMSG=0
      JERR=0
      NTEVT=0
      NREVT=0
      NAEVT=0
      NRSTR=0
      NRPTL=0
      INOIAC=0
      ILAMAS=0
      NPTLU=0
      DO 44  ITAU = 1,MXTAU
        VOLSUM(ITAU)=0.
        VO2SUM(ITAU)=0.
        NCLSUM(ITAU)=0
 44   CONTINUE
      DO 43  IEPS = 1,MXEPS
        DO 43  IVOL = 1,MXVOL
          DO 43  ITAU = 1,MXTAU
            CLUST(ITAU,IVOL,IEPS) = 0.
 43   CONTINUE
      IUTOTC=0
      IUTOTE=0

      IF ( NPARAM .GT. 0 ) THEN
        DO 3  N = 1,NPARAM
          CALL UTLOW6(PARCHA(N))
          IF ( DEBUG ) WRITE(MDEBUG,*) PARCHA(N),PARVAL(N)
          IF     ( PARCHA(N) .EQ. 'AMPRIF' ) THEN
                                       AMPRIF = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'AMSIAC' ) THEN
                                       AMSIAC = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'AMUSEG' ) THEN
                                       AMUSEG = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'ANGMUE' ) THEN
                                       ANGMUE = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'BAG4RT' ) THEN
                                       BAG4RT = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'BMAXIM' ) THEN
                                       BMAXIM = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'BMINIM' ) THEN
                                       BMINIM = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'CORE  ' ) THEN
                                       CORE   = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'CORLEN' ) THEN
                                       CORLEN = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'CUTMSQ' ) THEN
                                       CUTMSQ = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'CUTMSS' ) THEN
                                       CUTMSS = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'DELEPS' ) THEN
                                       DELEPS = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'DELMSS' ) THEN
                                       DELMSS = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'DELREM' ) THEN
                                       DELREM = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'DELVOL' ) THEN
                                       DELVOL = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'ELEPTI' ) THEN
                                       ELEPTI = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'ELEPTO' ) THEN
                                       ELEPTO = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'EPSCRI' ) THEN
                                       EPSCRI = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'FCTRMX' ) THEN
                                       FCTRMX = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'GAUMX ' ) THEN
                                       GAUMX  = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'GRICEL' ) THEN
                                       GRICEL = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'GRIDEL' ) THEN
                                       GRIDEL = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'GRIGAM' ) THEN
                                       GRIGAM = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'GRIRSQ' ) THEN
                                       GRIRSQ = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'GRISLO' ) THEN
                                       GRISLO = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'IAQU  ' ) THEN
                                       IAQU   = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'ICLHIS' ) THEN
                                       ICLHIS = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'IDPM  ' ) THEN
                                       IDPM   = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'IENTRO' ) THEN
                                       IENTRO = NINT(PARVAL(N))
          ELSEIF ( PARCHA(N) .EQ. 'IFRADE' ) THEN
                                       IFRADE = NINT(PARVAL(N))
          ELSEIF ( PARCHA(N) .EQ. 'IJPHIS' ) THEN
                                       IJPHIS = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'IMIHIS' ) THEN
                                       IMIHIS = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'IOJINT' ) THEN
                                       IOJINT = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'IOPBRK' ) THEN
                                       IOPBRK = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'IOPENT' ) THEN
                                       IOPENT = PARVAL(N)
                                       IOPENT = MOD(IOPENT,10)
          ELSEIF ( PARCHA(N) .EQ. 'IOPENU' ) THEN
                                       IOPENU = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'IOPTF ' ) THEN
                                       IOPTF  = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'IOPTQ ' ) THEN
                                       IOPTQ  = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'IPAGI ' ) THEN
                                       IPAGI  = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'IRESCL' ) THEN
                                       IRESCL = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'ISH   ' ) THEN
                                       ISH    = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'ISHEVT' ) THEN
                                       ISHEVT = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'ISHSUB' ) THEN
                                       ISHSUB = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'ISPALL' ) THEN
                                       ISPALL = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'ISPHIS' ) THEN
                                       ISPHIS = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'ISTMAX' ) THEN
                                       ISTMAX = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'ISUP  ' ) THEN
                                       ISUP   = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'IVERSN' ) THEN
                                       IVERSN = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'IVI   ' ) THEN
                                       IVI    = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'IWCENT' ) THEN
                                       IWCENT = NINT(PARVAL(N))
          ELSEIF ( PARCHA(N) .EQ. 'IWZZZZ' ) THEN
                                       IWZZZZ = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'JPSI  ' ) THEN
                                       JPSI   = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'JPSIFI' ) THEN
                                       JPSIFI = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'KENTRO' ) THEN
                                       KENTRO = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'KO1KO2' ) THEN
                                       KO1KO2 = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'KUTDIQ' ) THEN
                                       KUTDIQ = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'LABSYS' ) THEN
                                       LABSYS = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'MAXRES' ) THEN
                                       MAXRES = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'NCLEAN' ) THEN
                                       NCLEAN = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'NCOLMX' ) THEN
                                       NCOLMX = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'NDECAW' ) THEN
                                       NDECAW = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'NDECAX' ) THEN
                                       NDECAX = NINT(PARVAL(N))
          ELSEIF ( PARCHA(N) .EQ. 'NDECAY' ) THEN
                                       NDECAY = NINT(PARVAL(N))
          ELSEIF ( PARCHA(N) .EQ. 'NEQMN ' ) THEN
                                       NEQMN  = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'NEQMX ' ) THEN
                                       NEQMX  = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'NSTTAU' ) THEN
                                       NSTTAU = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'NTRYMX' ) THEN
                                       NTRYMX = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'NUMTAU' ) THEN
                                       NUMTAU = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'OVERLP' ) THEN
                                       OVERLP = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'PAREA ' ) THEN
                                       PAREA  = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'PDIQUA' ) THEN
                                       PDIQUA = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'PISPN ' ) THEN
                                       PISPN  = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'PROSEA' ) THEN
                                       PROSEA = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'PSPINH' ) THEN
                                       PSPINH = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'PSPINL' ) THEN
                                       PSPINL = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'PTF   ' ) THEN
                                       PTF    = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'PTH   ' ) THEN
                                       PTH    = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'PHARD ' ) THEN
                                       PHARD  = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'PTMX  ' ) THEN
                                       PTMX   = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'PTQ1  ' ) THEN
                                       PTQ1   = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'PTQ2  ' ) THEN
                                       PTQ2   = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'PTQ3  ' ) THEN
                                       PTQ3   = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'PUD   ' ) THEN
                                       PUD    = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'PVALEN' ) THEN
                                       PVALEN = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'QMUST ' ) THEN
            CALL UTSTOP('VENINI: *** QMUST NOT USED ANYMORE! *** ')
          ELSEIF ( PARCHA(N) .EQ. 'QMUST1' ) THEN
                                       QMUST1 = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'QMUST2' ) THEN
                                       QMUST2 = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'QMUST3' ) THEN
                                       QMUST3 = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'RADIAC' ) THEN
                                       RADIAC = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'RADIAS' ) THEN
                                       RADIAS = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'RHOPHI' ) THEN
                                       RHOPHI = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'RSTRAS' ) THEN
                                       RSTRAS = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'SEEDI ' ) THEN
                                       SEEDI  = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'SIGJ  ' ) THEN
                                       SIGJ   = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'SIGPPI' ) THEN
                                       SIGPPI = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'SMAS  ' ) THEN
                                       SMAS   = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'SSMAS ' ) THEN
                                       SSMAS  = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'TAUMAX' ) THEN
                                       TAUMAX = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'TAUMIN' ) THEN
                                       TAUMIN = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'TAUMX ' ) THEN
                                       TAUMX  = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'TAUNLL' ) THEN
                                       TAUNLL = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'TAUREA' ) THEN
                                       TAUREA = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'TENSN ' ) THEN
                                       TENSN  = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'THEMAS' ) THEN
                                       THEMAS = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'UENTRO' ) THEN
                                       UENTRO = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'USMAS ' ) THEN
                                       USMAS  = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'UUMAS ' ) THEN
                                       UUMAS  = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'WPROJ ' ) THEN
                                       WPROJ  = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'WTARG ' ) THEN
                                       WTARG  = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'WTMINI' ) THEN
                                       WTMINI = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'WTSTEP' ) THEN
                                       WTSTEP = PARVAL(N)
          ELSEIF ( PARCHA(N) .EQ. 'YMXIMI' ) THEN
                                       YMXIMI = PARVAL(N)
          ENDIF
 3      CONTINUE
      ENDIF

      IF ( ISPHIS .EQ. 1 ) LABSYS = 0
      IF ( IDPM .EQ. 1 ) THEN
        IAQU = 0
        NEQMN = 2
        NEQMX = 3
      ENDIF
      IF ( IOPENU .EQ. 2 ) THEN
        CALL SMASSI(THEMAS)
        IF ( ISH .EQ. 19 ) THEN
          CALL SMASSP
          CALL UTSTOP(' VENINI:                                ')
        ENDIF
      ENDIF

      IF ( IOJINT .EQ. 2 ) THEN
        IF     ( EPSCRI .LT. 0. ) THEN
          RADIAC = 0.
          RADIAS = 0.
        ELSEIF ( EPSCRI .GT. 0. ) THEN
          VOLBAR = PROM/EPSBAR*PI*0.25
CDH       RADIAC = (VOLBAR*0.5/PI)**0.3333333
          VOLMES = 0.455/EPSCRI*PI*0.25
CDH       RADIAS = (VOLMES*0.5/PI)**0.3333333
        ELSE
          CALL UTSTOP('EPSCRI MUST NOT BE 0.                   ')
        ENDIF
      ENDIF

      CALL JDECIN(.FALSE.)
C  INITIALIZE ALL PT DISTRIBUTIONS
      CX = PTMX
      QUAMA = 0.
      IF ( IOPTF .EQ. 1 ) THEN
        ROOT  = SQRT(PTMX**2+QUAMA**2)
        AUXIL = 2./PTF
        BPTFU = (+0.25)*PTF**2*EXP((-AUXIL)*QUAMA)*(AUXIL*QUAMA+1.)
        FPTFU = (-0.25)*PTF**2*EXP((-AUXIL)*ROOT)*(AUXIL*ROOT+1.)+BPTFU
        CALL UTQUAF(SPTF,NPTF,XPTF,QPTFU,0.,.33*CX,.66*CX,CX)
C       DO 199  N = 1,NPTF
C         WRITE(IFCH,*) 'N,X,Q=',N,XPTF(N),QPTFU(N)
C199    CONTINUE
      ELSE
        AUXIL = 0.25*PI/PTF**2
        BPTFU = (+EXP((-AUXIL)* QUAMA**2))*0.5/AUXIL
        FPTFU = (-EXP((-AUXIL)*(QUAMA**2+PTMX**2)))*0.5/AUXIL+BPTFU
      ENDIF

      QUAMA = SMAS
      IF ( QUAMA .NE. 0. ) THEN
        IF ( IOPTF .EQ. 1 ) THEN
          ROOT  = SQRT(PTMX**2+SMAS**2)
          AUXIL = 2./PTF
          BPTFS = (+0.25)*PTF**2*EXP((-AUXIL)*SMAS)*(AUXIL*SMAS+1.)
          FPTFS = (-0.25)*PTF**2*EXP((-AUXIL)*ROOT)*(AUXIL*ROOT+1.)+
     *            BPTFS
          CALL UTQUAF(SPTF,NPTF,XPTF,QPTFS,0.,.33*CX,.66*CX,CX)
        ELSE
          AUXIL = 0.25*PI/PTF**2
          BPTFS = (+EXP((-AUXIL)* SMAS**2))*0.5/AUXIL
          FPTFS = (-EXP((-AUXIL)*(SMAS**2+PTMX**2)))*0.5/AUXIL+BPTFS
        ENDIF
      ELSE
        DO 201  N = 1,NPTF
          QPTFS(N) = QPTFU(N)
 201    CONTINUE
        FPTFS = FPTFU
      ENDIF

      QUAMA = UUMAS
      IF ( QUAMA .NE. 0. ) THEN
        IF ( IOPTF .EQ. 1 ) THEN
          ROOT   = SQRT(PTMX**2+UUMAS**2)
          AUXIL  = 2./PTF
          BPTFUU = (+0.25)*PTF**2*EXP((-AUXIL)*UUMAS)*(AUXIL*UUMAS+1.)
          FPTFUU = (-0.25)*PTF**2*EXP((-AUXIL)*ROOT)*(AUXIL*ROOT+1.)+
     *             BPTFUU
          CALL UTQUAF(SPTF,NPTF,XPTF,QPTFUU,0.,.33*CX,.66*CX,CX)
        ELSE
          AUXIL  = 0.25*PI/PTF**2
          BPTFUU =  EXP((-AUXIL)* UUMAS**2)*0.5/AUXIL
          FPTFUU = (-EXP((-AUXIL)*(UUMAS**2+PTMX**2)))*0.5/AUXIL+BPTFUU
        ENDIF
      ELSE
        DO 202  N = 1,NPTF
          QPTFUU(N) = QPTFU(N)
 202    CONTINUE
        FPTFUU = FPTFU
      ENDIF

      QUAMA = USMAS
      IF ( QUAMA .NE. 0. ) THEN
        IF ( IOPTF .EQ. 1 ) THEN
          ROOT   = SQRT(PTMX**2+USMAS**2)
          AUXIL  = 2./PTF
          BPTFUS =  0.25*PTF**2*EXP((-AUXIL)*USMAS)*(AUXIL*USMAS+1.)
          FPTFUS = (-0.25)*PTF**2*EXP((-AUXIL)*ROOT)*(AUXIL*ROOT+1.)+
     *             BPTFUS
          CALL UTQUAF(SPTF,NPTF,XPTF,QPTFUS,0.,.33*CX,.66*CX,CX)
        ELSE
          AUXIL  = 0.25*PI/PTF**2
          BPTFUS =  EXP((-AUXIL)* USMAS**2)*0.5/AUXIL
          FPTFUS = (-EXP((-AUXIL)*(USMAS**2+PTMX**2)))*0.5/AUXIL+BPTFUS
        ENDIF
      ELSE
        DO 203  N = 1,NPTF
          QPTFUS(N) = QPTFU(N)
 203    CONTINUE
        FPTFUS = FPTFU
      ENDIF

      QUAMA = SSMAS
      IF ( QUAMA .NE. 0. ) THEN
        IF ( IOPTF .EQ. 1 ) THEN
          ROOT   = SQRT(PTMX**2+SSMAS**2)
          AUXIL  = 2./PTF
          BPTFSS = (+0.25)*PTF**2*EXP((-AUXIL)*SSMAS)*(AUXIL*SSMAS+1.)
          FPTFSS = (-0.25)*PTF**2*EXP((-AUXIL)*ROOT)*(AUXIL*ROOT+1.)+
     *             BPTFSS
          CALL UTQUAF(SPTF,NPTF,XPTF,QPTFSS,0.,.33*CX,.66*CX,CX)
        ELSE
          AUXIL  = 0.25*PI/PTF**2
          BPTFSS =  EXP((-AUXIL)* SSMAS**2)*0.5/AUXIL
          FPTFSS =(-EXP((-AUXIL)*(SSMAS**2+PTMX**2)))*0.5/AUXIL+BPTFSS
        ENDIF
      ELSE
        DO 204  N = 1,NPTF
          QPTFSS(N) = QPTFU(N)
 204    CONTINUE
        FPTFSS = FPTFU
      ENDIF

C  INITIALIZE FUNCTIONS FOR JPSI GENERATION
      IF ( JPSI .EQ. 1 ) THEN
        CX = GAUMX
        CALL UTQUAF(SGAU,NGAU,XGAU,QGAU,0.,.33*CX,.66*CX,CX)
        CX = PTMX
        CALL UTQUAF(SPTJ,NPTJ,XPTJ,QPTJ,0.,.33*CX,.66*CX,CX)
      ENDIF

C INITIALIZE DENSITY DISTRIBUTION INTEGRALS FOR NITROGEN, OXYGEN, ARGON
      MASSNR = 14.
      R0 = 1.19*MASSNR**(.3333333) -1.61*MASSNR**(-.3333333)
      CX = R0+FCTRMX*0.54
      RMTARG(1) = CX
      CALL UTQUAF(SDENSI,NDET,XDET14,QDET14,0.,.33*CX,.66*CX,CX)

      MASSNR = 16.
      R0 = 1.19*MASSNR**(.3333333) -1.61*MASSNR**(-.3333333)
      CX = R0+FCTRMX*0.54
      RMTARG(2) = CX
      CALL UTQUAF(SDENSI,NDET,XDET16,QDET16,0.,.33*CX,.66*CX,CX)

      MASSNR = 40.
      R0 = 1.19*MASSNR**(.3333333) -1.61*MASSNR**(-.3333333)
      CX = R0+FCTRMX*0.54
      RMTARG(3) = CX
      CALL UTQUAF(SDENSI,NDET,XDET40,QDET40,0.,.33*CX,.66*CX,CX)

C  QDET99 AND XDET99 ARE NOT INITIALIZED
      MTAR99 = 0

      OPEN(UNIT=14,FILE='VENUSDAT',STATUS='OLD')
      READ(14,*)(IDUMMY, XVA(I), QVAH(I), QVAPI(I), I=1,2049)
      CLOSE(UNIT=14)

      WRITE(IFMT,105) FLOAT(IVERSN)/1000.
 105  FORMAT(
     * ' !-----------------------------------------------------!'
     */' !      V(ERY) E(NERGETIC) NU(CLEAR) S(CATTERING)      !'
     */' !      VENUS',F6.3,5X,'-          K. WERNER           !'
     */' !      SUBROUTINE TURBOVERSION    D. HECK             !'
     */' !-----------------------------------------------------!')
      RETURN
      END
*CMZ :          28/02/2002  12.36.15  by  D. HECK IK FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
C=======================================================================

      SUBROUTINE VENLNK

C-----------------------------------------------------------------------
C  VEN(US) L(I)NK (TO CORSIKA)
C
C  LINKS VENUS PACKAGE TO CORSIKA, NEEDS FIRST CALL OF VENINI
C  THIS SUBROUTINE IS CALLED FROM SDPM.
C
C  DESIGN   : D. HECK    IK3  FZK KARLSRUHE
C-----------------------------------------------------------------------

*KEEP,INTER.
      COMMON /INTER/   AVCH,AVCH3,DC0,DLOG,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,DLOG,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
*KEEP,PAM.
      COMMON /PAM/     PAMA,SIGNUM,RESTMS
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000)
*KEEP,PARPAR.
      COMMON /PARPAR/  CURPAR,SECPAR,PRMPAR,OUTPAR,C,
     *                 E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
      DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16),
     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH
      INTEGER          ITYPE,LEVL
*KEEP,PARPAE.
      DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM
     *                 ,WEIGHT
     *                 ,HAPP,COSTAP,COSTEA
      EQUIVALENCE      (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE),
     *                 (CURPAR(4), PHI   ), (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)
*KEEP,RANDPA.
      COMMON /RANDPA/  FAC,U1,U2,RD,NSEQ,ISEED,KNOR
      DOUBLE PRECISION FAC,U1,U2
      REAL             RD(3000)
      INTEGER          ISEED(103,10),NSEQ
      LOGICAL          KNOR
*KEEP,REST.
      COMMON /REST/    CONTNE,TAR,LT
      DOUBLE PRECISION CONTNE(3),TAR
      INTEGER          LT
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEEP,VENUS.
      COMMON /VENUS/   ISH00,IVERVN,MTAR99,FVENUS,FVENSG
      INTEGER          ISH00,IVERVN,MTAR99
      LOGICAL          FVENUS,FVENSG
*KEND.

      PARAMETER (KOLLMX=2500)
      PARAMETER (MXEPS=10)
      PARAMETER (NDEP=129)
      PARAMETER (NDET=129)
      PARAMETER (NPRBMS=20)
      PARAMETER (NPTQ=129)
      PARAMETER (NSTRU=2049)
      COMMON /ACCUM/   AMSAC,ILAMAS,IMSG,INOIAC,IPAGE,JERR,NAEVT,NREVT
     *                ,NRPTL,NRSTR,NTEVT
      COMMON /CDEN/    MASSNR,RMX,R0
      COMMON /CIPIO/   IPIO
      COMMON /CNSTA/   AINFIN,PI,PIOM,PROM
      COMMON /COL/     BIMP,BMAX,COORD(4,KOLLMX),DISTCE(KOLLMX)
     *                ,QDEP(NDEP),QDET14(NDET),QDET16(NDET),QDET40(NDET)
     *                ,QDET99(NDET),RMPROJ,RMTARG(4),XDEP(NDEP)
     *                ,XDET14(NDET),XDET16(NDET),XDET40(NDET)
     *                ,XDET99(NDET)
     *                ,KOLL,LTARG,NORD(KOLLMX),NPROJ,NRPROJ(KOLLMX)
     *                ,NRTARG(KOLLMX),NTARG
      COMMON /CPRBMS/  PRBMS(NPRBMS)
      COMMON /CPTQ/    QPTH(NPTQ),QPTQ(NPTQ),XPTQ(NPTQ),QPTQMX,QPTHMX
      DOUBLE PRECISION SEEDC,SEEDI
      COMMON /CSEED/   SEEDC,SEEDI
      COMMON /FILES/   IFCH,IFDT,IFHI,IFMT,IFOP
      COMMON /NEVNT/   NEVNT
      COMMON /PARO1/   AMPRIF,AMSIAC,BMAXIM,BMINIM,CORE,CUTMSQ,CUTMSS
     *                ,DELMSS,DELREM,FCTRMX,GAUMX,OVERLP,PAREA,PDIQUA
     *                ,PHARD,PSPINL,PSPINH,PISPN,PTF,PTH,PTMX,PTQ,PUD
     *                ,PVALEN,QSEPC,QSETC,QMUST,QVAPC,QVATC,RADIAC
     *                ,RADIAS,RSTRAS,SIGJ,SIGPPI,TAUMAX,TAUMIN
     *                ,TAUMX,TAUNLL,TENSN,THEMAS,WPROJ,WTARG,WTMINI
     *                ,WTSTEP,XCUT
     *                ,IAQU,IFRADE,IOJINT,IOPBRK,IOPENT,IOPENU
     *                ,IOPTF,IOPTQ,IRESCL,IWCENT,KENTRO,KO1KO2
     *                ,LABSYS,MAXRES,NCLEAN,NCOLMX,NDECAW,NEQMN,NEQMX
     *                ,NSTTAU,NTRYMX,NUMTAU
      COMMON /PARO2/   AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY
     *                ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA
     *                ,YHAHA,YMXIMI,YPJTL
     *                ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM
     *                ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH
     *                ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI
     *                ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG
     *                ,MODSHO,NDECAX,NDECAY,NEVENT
      COMMON /PARO3/   ASUHAX(7),ASUHAY(7),OMEGA,SIGPPD,SIGPPE,UENTRO
     *                ,IWZZZZ
      COMMON /PARO4/   GRICEL,GRIDEL,GRIGAM,GRIRSQ,GRISLO
      COMMON /PARO5/   DELEPS,DELVOL
      COMMON /QUARKM/  SMAS,SSMAS,USMAS,UUMAS
      COMMON /STRU/    QSEP(NSTRU),QSET(NSTRU),QVAP(NSTRU)
     *                ,QVAT(NSTRU),XCUTAR,XSTRU(NSTRU)
     *                ,IDTG
      COMMON /STRU2/   DELTA0,DELTA1,QSEH(NSTRU),QSEPI(NSTRU)
     *                ,QVAH(NSTRU),QVAPI(NSTRU),XSE(NSTRU),XVA(NSTRU)

      DOUBLE PRECISION ERRER,VALUE
      INTEGER          IFLAG

      COMMON /VENLIN/  PTQ1,PTQ2,PTQ3,QMUST1,QMUST2,QMUST3
     *                ,IDTABL(100)

      SAVE
      EXTERNAL         SDENSI,SPTQ,SSE0,SVA0,SVA1
C-----------------------------------------------------------------------

      IF ( DEBUG ) WRITE(MDEBUG,*) 'VENLNK: TAR',SNGL(TAR)

      NSTRUC = NSTRU
      IF ( DEBUG ) THEN
        ISH  = ISH00
      ELSE
        ISH  = 0
      ENDIF
      NEVNT = ISHOWNO
C  SET RANDOM NUMBER GENERATOR STATUS
      SEEDC=ISEED(2,1)+1.D9*ISEED(3,1)
C  CALCULATE ENERGY IN LAB SYSTEM FOR ELASTICITY FOR VARIOUS PROJECTILES
      IF     ( ITYPE .EQ. 1 ) THEN
C  TREAT PHOTON PROJECTILES (FROM EGS)
        CALL RMMAR(RD,1,1)
        IF ( RD(1) .LE. 0.5 ) THEN
          ITYPE = 7
        ELSE
          ITYPE = 17
        ENDIF
        ELAB  = CURPAR(2)
        CURPAR(2) = ELAB / PAMA(ITYPE)
      ELSEIF ( ITYPE .LT. 100 ) THEN
C  TREAT ORDINARY PROJECTILES
        ELAB  = CURPAR(2) * PAMA(ITYPE)
      ELSE
C  TREAT NUCLEI PROJECTILES
        NPROT = MOD(ITYPE,100)
        NNEUT = ITYPE/100 - NPROT
        ELAB  = CURPAR(2) * ( PAMA(14)*NPROT + PAMA(13)*NNEUT )
      ENDIF
C  SET TARGET PARAMETERS
      MATARG = NINT(TAR)
      IDTARG = 1120
      AMTARG = PAMA(14)
      IF     ( TAR. EQ. 14.D0 ) THEN
        LTARG  = 1
        LATARG = 7
      ELSEIF ( TAR .EQ. 16.D0 ) THEN
        LTARG  = 2
        LATARG = 8
      ELSEIF ( TAR .EQ. 40.D0 ) THEN
        LTARG  = 3
        LATARG = 18
      ELSE
        WRITE(MONIOU,*) 'VENLNK: UNDEFINED TARGET TAR=',SNGL(TAR)
      ENDIF

C  FOR THE CASE OF AN ARBITRARY TARGET (NOT AIR)
      IF ( LTARG .GT. 3 ) THEN
        MASSNR = MATARG
        IF ( MASSNR .GT. 1 ) THEN
          IF ( MASSNR .NE. MTAR99 ) THEN
            R0 = 1.19*MASSNR**(.3333333) -1.61*MASSNR**(-.3333333)
            CX = R0+FCTRMX*0.54
            RMTARG(4) = CX
            CALL UTQUAF(SDENSI,NDET,XDET99,QDET99,0.,.33*CX,.66*CX,CX)
            MTAR99 = MATARG
          ENDIF
        ELSE
          RMTARG(4) = 0.
        ENDIF
      ENDIF

C  SET PROJECTILE PARAMETERS
      IF ( ITYPE .LT. 100 ) THEN
        IDPROJ = IDTABL(ITYPE)
        IF     ( IDPROJ .EQ. 20  .OR.  IDPROJ .EQ. -20 ) THEN
C  TREAT NEUTRAL KAONS  (K(0)S AND K(0)L)
          CALL RMMAR(RD,1,1)
          IF ( RD(1) .LE. 0.5 ) THEN
            IDPROJ = 230
          ELSE
            IDPROJ = -230
          ENDIF
        ELSEIF ( IDPROJ .EQ. 2130 ) THEN
C  VENUS CANNOT TREAT LAMBDA, TAKE INSTEAD SIGMA(0))
          IDPROJ = 1230
        ELSEIF ( IDPROJ .EQ. -2130 ) THEN
C  VENUS CANNOT TREAT ANTI-LAMBDA, TAKE INSTEAD ANTI-SIGMA(0))
          IDPROJ = -1230
        ENDIF
C  ALL OTHER PARTICLE CODES UNCHANGED
        CALL IDMASS(IDPROJ,AMPROJ)
        LAPROJ = -1
        MAPROJ = 1
        PNLL   = CURPAR(2)*AMPROJ
      ELSE
C  PROJECTILE IS NUCLEUS
        IDPROJ = 1120
        CALL IDMASS(IDPROJ,AMPROJ)
        LAPROJ = MOD(ITYPE,100)
        MAPROJ = ITYPE/100
        PNLL   = CURPAR(2)*(PAMA(14)+PAMA(13))*0.5
      ENDIF

      IF ( ABS(IDPROJ) .LT. 1000 ) THEN
        IF ( ABS(IDPROJ) .EQ. 230  .OR.  ABS(IDPROJ) .EQ. 130 ) THEN
C  DIFFRACTIVE PROBABILITY FOR KAON PROJECTILES
          WPROJ = 0.24
        ELSE
C  DIFFRACTIVE PROBABILITY FOR PION PROJECTILES
          WPROJ = 0.20
        ENDIF
      ELSE
C  DIFFRACTIVE PROBABILITY FOR BARYON PROJECTILES
        WPROJ = 0.32
      ENDIF
C  DIFFRACTIVE PROBABILITY FOR TARGET (ALWAYS NUCLEONS)
      WTARG = 0.32

      ENGY = SQRT( 2.*SQRT(PNLL**2+AMPROJ**2)*AMTARG+AMTARG**2
     *                     +AMPROJ**2 )
      IF ( DEBUG ) WRITE(MDEBUG,*) 'VENLNK: ELAB = ',PNLL,
     *                                    ' ENGY = ',ENGY
CDH   IF ( ENGY .LT. 12. ) THEN
      IF ( ENGY .LT. 9.5 ) THEN
        WRITE(IFMT,*) 'VENLNK: ENGY, IDPROJ=',ENGY,IDPROJ
        CALL UTSTOP('VENLNK: INCIDENT ENERGY TOO SMALL       ')
      ENDIF
      ENGYI = ENGY
      PNLLI = PNLL
      IF ( PNLL .LT. 1.E2 * AMPROJ ) THEN
        TRM  = SQRT(PNLL**2+AMPROJ**2)
        ENGY = SQRT((TRM+AMTARG-PNLL)*(TRM+AMTARG+PNLL))
      ELSE
        TRM  = AMPROJ**2*0.5/PNLL+AMTARG
        ENGY = SQRT(TRM*(2.*PNLL+TRM))
      ENDIF
      D1 = ABS(PNLLI-PNLL)/PNLL
      D2 = ABS(ENGYI-ENGY)/ENGY
      IF ( D1 .GT. 1.E-3  .OR.  D2 .GT. 1.E-3 ) THEN
        IF ( ISH .GE. 0 ) THEN
          CALL UTMSG('VENLNK')
          WRITE(IFCH,*) '*****  PNLL,PNLLI:',PNLL,PNLLI
          WRITE(IFCH,*) '*****  ENGY,ENGYI:',ENGY,ENGYI
          CALL UTMSGF
        ENDIF
      ENDIF
      S = ENGY**2
      SROOTI = 1./ENGY
      PNLLX = UTPCM(ENGY,AMPROJ,AMTARG)
      YHAHA = LOG((SQRT(PNLL**2+S)+PNLL)/ENGY)
      YPJTL = LOG((SQRT(PNLL**2+AMPROJ**2)+PNLL)/AMPROJ)
      IF ( ISH .GE. 91 ) WRITE(IFCH,*) 'VENLNK: YPJTL=',YPJTL

      ENGYLG = LOG(ENGY)
      QMUST = QMUST1+QMUST2*ENGYLG+QMUST3*ENGYLG**2
      PTQ = PTQ1+PTQ2*ENGYLG+PTQ3*ENGYLG**2
CDH   PHARD = 0.030+0.12*(LOG10(S)-LOG10(30.**2))
      PHARD = 0.030+0.12*(LOG10(S)-2.9542425)
      PHARD = MIN(1.,PHARD)
      PHARD = MAX(0.030,PHARD)

C  PROJECTILE
      XCUT  = CUTMSQ*SROOTI
      XCUT2 = XCUT**2
      IF ( ABS(IDPROJ) .GE. 1000 ) THEN
C  STRUCTURE FUNCTION INTEGRAL FOR BARYONS OF PROJECTILE
        IPIO = 0
        CALL UINTEG(VALUE,SSE0,0.D0,1.D0,0.D0,1.D-5,1,ERRER,IFLAG)
        IF ( IFLAG .GT. 3  .AND.  ISH .GT. 0 )
     *                      WRITE(IFCH,*) 'VENLNK: SSE0:IFLAG=',IFLAG
        QSEPC = VALUE
        CALL UINTEG(VALUE,SVA0,0.D0,1.D0,0.D0,1.D-5,1,ERRER,IFLAG)
        IF ( IFLAG .GT. 3  .AND.  ISH .GT. 0 )
     *                      WRITE(IFCH,*) 'VENLNK: SVA0:IFLAG=',IFLAG
        QVAPC = VALUE
      ELSE
C  STRUCTURE FUNCTION INTEGRAL FOR MESONS OF PROJECTILE
        IPIO = 1
        A0 = -5.0 + 6.6666667*XCUT2 - 0.53333333*XCUT2**2
        A1 =  5.0 - 1.875*XCUT2
        A2 = -3.3333333 + 0.26666667*XCUT2
        A3 =  1.25
        A4 = -0.2
        ROOT  = SQRT(XCUT2+1.)
        QSEPC = 0.9*( (1.-XCUT2*A1)*( LOG(1.+ROOT)-LOG(XCUT) )
     *                   - XCUT*A0 + ROOT*(A0+A1+A2+A3+A4) )
        CALL UINTEG(VALUE,SVA1,0.D0,1.D0,0.D0,1.D-5,1,ERRER,IFLAG)
        IF ( IFLAG .GT. 3  .AND.  ISH .GT. 0 )
     *                      WRITE(IFCH,*) 'VENLNK: SVA1:IFLAG=',IFLAG
        QVAPC = VALUE
      ENDIF
      IDTG = IPIO

C  TARGET
      IF ( IDTG .EQ. 1 ) THEN
        IF ( ABS(IDTARG) .GE. 1000 ) THEN
C  STRUCTURE FUNCTION INTEGRAL FOR BARYONS OF TARGET
          IPIO = 0
          CALL UINTEG(VALUE,SSE0,0.D0,1.D0,0.D0,1.D-5,1,ERRER,IFLAG)
          IF ( IFLAG .GT. 3  .AND.  ISH .GT. 0 )
     *                        WRITE(IFCH,*) 'VENLNK: SSE0:IFLAG=',IFLAG
          QSETC = VALUE
          CALL UINTEG(VALUE,SVA0,0.D0,1.D0,0.D0,1.D-5,1,ERRER,IFLAG)
          IF ( IFLAG .GT. 3  .AND.  ISH .GT. 0 )
     *                        WRITE(IFCH,*) 'VENLNK: SVA0:IFLAG=',IFLAG
          QVATC = VALUE
        ELSE
          IPIO=1
          QVATC = QVAPC
          QSETC = QSEPC
        ENDIF
      ELSE
        IF ( ABS(IDTARG) .GE. 1000 ) THEN
          IPIO = 0
          QVATC = QVAPC
          QSETC = QSEPC
        ELSE
C  STRUCTURE FUNCTION INTEGRAL FOR BARYONS OF TARGET
          IPIO=1
          A0 = -5.0 + 6.6666667*XCUT2 - 0.53333333*XCUT2**2
          A1 =  5.0 - 1.875*XCUT2
          A2 = -3.3333333 + 0.26666667*XCUT2
          A3 =  1.25
          A4 = -0.2
          ROOT  = SQRT(XCUT2+1.)
          QSETC = 0.9*( (1.-XCUT2*A1)*( LOG(1.+ROOT)-LOG(XCUT) )
     *                     - XCUT*A0 + ROOT*(A0+A1+A2+A3+A4) )
          CALL UINTEG(VALUE,SVA1,0.D0,1.D0,0.D0,1.D-5,1,ERRER,IFLAG)
          IF ( IFLAG .GT. 3  .AND.  ISH .GT. 0 )
     *                        WRITE(IFCH,*) 'VENLNK: SVA1:IFLAG=',IFLAG
          QVATC = VALUE
        ENDIF
      ENDIF
      IF ( ISH .EQ. 16  .OR.  DEBUG ) THEN
        WRITE(IFCH,301) QVAPC, QSEPC, QVATC, QSETC
 301    FORMAT(' VENLNK: QVAPC, QSEPC, QVATC, QSETC=',4(F10.7,2X))
      ENDIF

      IF ( PROSEA .GE. 0. ) THEN
        QVAPC = 1.0
        QVATC = 1.0
        QSEPC = PROSEA
        QSETC = PROSEA
      ENDIF

      XCUT = CUTMSS*SROOTI
      XCUTAR = XCUT
      B = MIN( 0.05, XCUT*500. )
      A = MIN( 0.2*B, XCUT*100. )
      PNLLLG = LOG(PNLL)
      DELTA0 = EXP(-2.791922 - 0.2091742 * PNLLLG)
      DELTA1 = EXP(-3.885293 - 0.2029558 * PNLLLG)
      CALL UTQSEA(A,B,1.)
      IF ( XCUT .LT. 0.04 ) THEN
        NEND=1.+REAL(NSTRUC)*2./PI*ACOS(1.-2./PI*ACOS(1.-25.*XCUT))
      ELSE
        NEND = NSTRUC
      ENDIF

      IF ( ABS(IDPROJ) .GE. 1000 ) THEN
        IPIO = 0
        DO 203  N = 1,NSTRUC
          QSEP(N) = QSEH(N)
 203    CONTINUE
        DO 2031  N = NEND,NSTRUC
          QVAP(N) = QVAH(N) - DELTA0
 2031   CONTINUE
      ELSE
        IPIO = 1
        DO 204  N = 1,NSTRUC
          QSEP(N) = QSEPI(N)
 204    CONTINUE
        DO 2041  N = NEND,NSTRUC
          QVAP(N) = QVAPI(N) - DELTA1
 2041   CONTINUE
      ENDIF
      CALL UTQVAL(QVAP,NEND)

      IF ( IDTG .EQ. 0 ) THEN
        IF ( ABS(IDTARG) .GE. 1000 ) THEN
          IPIO = 0
          DO 205  N = 1,NSTRUC
            QSET(N) = QSEP(N)
            QVAT(N) = QVAP(N)
 205      CONTINUE
        ELSE
          IPIO = 1
          DO 209  N = 1,NSTRUC
            QSET(N) = QSEPI(N)
 209      CONTINUE
          DO 2091  N = NEND,NSTRUC
            QVAT(N) = QVAPI(N) - DELTA1
 2091     CONTINUE
          CALL UTQVAL(QVAT,NEND)
        ENDIF

      ELSE
        IF ( ABS(IDTARG) .GE. 1000 ) THEN
          IPIO = 0
          DO 210  N = 1,NSTRUC
            QSET(N) = QSEH(N)
 210      CONTINUE
          DO 2101  N = NEND,NSTRUC
            QVAT(N) = QVAH(N) - DELTA0
 2101     CONTINUE
          CALL UTQVAL(QVAT,NEND)

        ELSE
          IPIO = 1
          DO 216  N = 1,NSTRUC
            QSET(N) = QSEP(N)
            QVAT(N) = QVAP(N)
 216      CONTINUE
        ENDIF
      ENDIF

      IF ( ISH .EQ. 21 ) THEN
        CALL UTHSEA
        CALL UTSTOP(' VENLNK:                                ')
      ENDIF

      QPTHMX = 0.5/PTH**2-PTH**2/(2.*(PTH**2+PTMX**2)**2)
      IF     ( IOPTQ .EQ. 2 ) THEN
        QPTQMX = 1. - EXP((-PI)*PTMX**2/(4.*PTQ**2) )
      ELSEIF ( IOPTQ .EQ. 3 ) THEN
        QPTQMX = 1. - PTQ**2/(PTQ**2+PTMX**2)
      ELSE
        CX = PTMX
        CALL UTQUAF(SPTQ,NPTQ,XPTQ,QPTQ,0.,.33*CX,.66*CX,CX)
      ENDIF

      SIGPPI = -1.0
C  CALCULATE ENERGY DEPENDENT CROSS-SECTION FOR BARYONS
      CALL RACPRO('GRI',QMUST,NPRBMS,PRBMS)
      IF     ( ABS(IDPROJ) .LE. 120  .OR.  ABS(IDPROJ) .EQ. 220 ) THEN
C  CROSS-SECTION FOR PIONS (OR ETA FOR PHOTONS FROM EGS)
        SIGPPI = SIGPPI * 0.6667
      ELSEIF ( ABS(IDPROJ) .EQ. 130  .OR.  ABS(IDPROJ) .EQ. 230 ) THEN
C  CROSS-SECTION FOR KAONS
        SIGPPI = SIGPPI * 0.5541
      ENDIF

      MASSNR = MAPROJ
      RMPROJ = 0.
      IF ( MASSNR .GT. 1 ) THEN
        R0 = 1.19*MASSNR**(.3333333) -1.61*MASSNR**(-.3333333)
        CX = R0+FCTRMX*0.54
        RMPROJ = CX
        CALL UTQUAF(SDENSI,NDEP,XDEP,QDEP,0.,.33*CX,.66*CX,CX)
      ENDIF

      IF ( IDPM .EQ. 1 ) THEN
        QSEPC = 0.
        QSETC = 0.
      ENDIF
      BMAX = RMPROJ+RMTARG(LTARG)

      IF ( ISH .GE. 91 ) WRITE(IFCH,*) 'VENLNK: AVENUS IS NOW CALLED'
      CALL AVENUS

C  NOW BRING PARTICLES TO CORSIKA STACK
      CALL VSTORE

      IF ( ISH .GE. 91 ) WRITE(IFCH,*) 'VENLNK: (EXIT)'
      RETURN
      END
*CMZ :          11/07/2000  10.08.31  by  D. HECK IK3 FZK KARLSRUHE
*-- Author :    D. HECK IK3 FZK KARLSRUHE       21/11/96
C=======================================================================

      SUBROUTINE VENSIG(ELAB,ITYPV)

C-----------------------------------------------------------------------
C  VEN(US) SIG(MAS)
C
C  CALCULATES INELASTIC HADRON-AIR CROSS-SECTIONS FOR VENUS MODEL
C  NUCLEUS-AIR CROSS-SECTIONS ARE DETERMINED BY P-P CROSS-SECTIONS AND
C  THE CORSIKA GLAUBER TABLES (SEE BOX2)
C  THIS SUBROUTINE IS CALLED FROM BOX2.
C  ARGUMENTS:
C   ELAB   = LABORATORY ENERGY (IN GEV)
C   ITYPV  = HADRON TYPE: 1 = NUCLEON, 2 = PION, 3 = KAON
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,PARPAR.
      COMMON /PARPAR/  CURPAR,SECPAR,PRMPAR,OUTPAR,C,
     *                 E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
      DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16),
     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH
      INTEGER          ITYPE,LEVL
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEEP,SIGM.
      COMMON /SIGM/    SIGMA,SIGANN,SIGAIR,FRACTN,FRCTNO
      DOUBLE PRECISION SIGMA,SIGANN,SIGAIR,FRACTN,FRCTNO
*KEEP,VENSSG.
      COMMON /VENSSG/  FRNVKL,FRNVPIL,FRNVPL,FRNOVKL,FRNOVPIL,FRNOVPL,
     *                 SGVKL,SGVPIL,SGVPL,SVPPL
      DOUBLE PRECISION FRNVKL(11), FRNVPIL(11), FRNVPL(11),
     *                 FRNOVKL(11),FRNOVPIL(11),FRNOVPL(11),
     *                 SGVKL(11),SGVPIL(11),SGVPL(11),SVPPL(11)
*KEND.

      DOUBLE PRECISION DELTAE,ELAB,SECT,WK(3),YE
      INTEGER          I,ITYPV,JE
      SAVE
C-----------------------------------------------------------------------

      IF ( DEBUG ) WRITE(MDEBUG,*) 'VENSIG: ELAB=',SNGL(ELAB),
     *                                 ' ITYPV=',ITYPV

C  DETERMINE ENERGY INTERVAL FOR INTERPOLATION
      YE = DLOG10(ELAB)
      IF ( YE .LT. 1.D0 ) YE = 1.D0
      JE = INT(YE)
      IF ( JE .GT. 9 ) JE = 9
      DELTAE = YE - JE
      WK(3)  = DELTAE * (DELTAE-1.D0) * .5D0
      WK(1)  = 1.D0 - DELTAE  + WK(3)
      WK(2)  = DELTAE - 2.D0 * WK(3)

      IF     ( ITYPV .EQ.   1 ) THEN
C  FOR BARYON PROJECTILES
        SECT = 0.D0
        DO 16  I = 1,3
          SECT = SECT + SGVPL(JE+I-1)*WK(I)
 16     CONTINUE
        SIGAIR = EXP(SECT)
        SECT = 0.D0
        DO 17  I = 1,3
          SECT = SECT + FRNVPL(JE+I-1)*WK(I)
 17     CONTINUE
        FRACTN = EXP(SECT)
        SECT = 0.D0
        DO 18  I = 1,3
          SECT = SECT + FRNOVPL(JE+I-1)*WK(I)
 18     CONTINUE
        FRCTNO = EXP(SECT)
        SIGMA  = 0.D0

      ELSEIF ( ITYPV .EQ.   2 ) THEN
C  FOR PION PROJECTILES
        SECT = 0.D0
        DO 26  I = 1,3
          SECT = SECT + SGVPIL(JE+I-1)*WK(I)
 26     CONTINUE
        SIGAIR = EXP(SECT)
        SECT = 0.D0
        DO 27  I = 1,3
          SECT = SECT + FRNVPIL(JE+I-1)*WK(I)
 27     CONTINUE
        FRACTN = EXP(SECT)
        SECT = 0.D0
        DO 28  I = 1,3
          SECT = SECT + FRNOVPIL(JE+I-1)*WK(I)
 28     CONTINUE
        FRCTNO = EXP(SECT)
        SIGMA  = 0.D0

      ELSEIF ( ITYPV .EQ.   3 ) THEN
C  FOR KAON PROJECTILES
        SECT = 0.D0
        DO 36  I = 1,3
          SECT = SECT + SGVKL(JE+I-1)*WK(I)
 36     CONTINUE
        SIGAIR = EXP(SECT)
        SECT = 0.D0
        DO 37  I = 1,3
          SECT = SECT + FRNVKL(JE+I-1)*WK(I)
 37     CONTINUE
        FRACTN = EXP(SECT)
        SECT = 0.D0
        DO 38  I = 1,3
          SECT = SECT + FRNOVKL(JE+I-1)*WK(I)
 38     CONTINUE
        FRCTNO = EXP(SECT)
        SIGMA  = 0.D0

      ELSEIF ( ITYPV .GE. 100 ) THEN
C  FOR NUCLEUS PROJECTILES DETERMINE ONLY NN CROSS-SECTION
        SIGAIR = 0.D0
        FRACTN = 0.D0
        FRCTNO = 0.D0
        SIGMA = 0.D0
        DO 47  I = 1,3
          SIGMA = SIGMA + SVPPL(JE+I-1)*WK(I)
 47     CONTINUE
        SIGMA = EXP(SIGMA)

      ELSE
        WRITE(MONIOU,444) (CURPAR(I),I=1,9)
 444    FORMAT(' VENSIG: CURPAR=',1P,9E10.3)
        WRITE(MONIOU,*) 'VENSIG: ILLEGAL PROJECTILE TYP =',ITYPV
        STOP
      ENDIF
      IF ( DEBUG ) WRITE(MDEBUG,*) 'VENSIG: SIGMA=',SNGL(SIGMA),
     *                                  ' SIGAIR=',SNGL(SIGAIR)

      RETURN
      END
*CMZ :          11/07/2000  10.08.31  by  D. HECK IK3 FZK KARLSRUHE
*-- Author :    D. HECK IK3 FZK KARLSRUHE       21/11/96
C=======================================================================

      SUBROUTINE VENSIGINI

C-----------------------------------------------------------------------
C  VEN(US) SIG(MAS) INI(TIALIZATION)
C
C  INITIALIZES INELASTIC CROSS-SECTION
C  THIS SUBROUTINE IS CALLED FROM START.
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEEP,VENSSG.
      COMMON /VENSSG/  FRNVKL,FRNVPIL,FRNVPL,FRNOVKL,FRNOVPIL,FRNOVPL,
     *                 SGVKL,SGVPIL,SGVPL,SVPPL
      DOUBLE PRECISION FRNVKL(11), FRNVPIL(11), FRNVPL(11),
     *                 FRNOVKL(11),FRNOVPIL(11),FRNOVPL(11),
     *                 SGVKL(11),SGVPIL(11),SGVPL(11),SVPPL(11)
*KEND.

      DOUBLE PRECISION AI,ELAB(11),FRNVK(11),FRNVPI(11),FRNVP(11),
     *                 FRNOVK(11),FRNOVPI(11),FRNOVP(11),
     *                 SIGP(11),SIGPI(11),SIGK(11), SPP(11)
      INTEGER          I
      SAVE
C  THE CROSS-SECTION TABLES START AT ELAB=10., 100., 1000., ....
C  BUT AFTERWARDS IS USED ONLY ABOVE 80 GEV
C  PROTON AIR INELASTIC CROSS-SECTION
      DATA SIGP /0.241E+03,
     *           0.264E+03,0.287E+03,0.311E+03,0.334E+03,0.358E+03,
     *           0.381E+03,0.405E+03,0.429E+03,0.454E+03,0.478E+03/
C  PION AIR INELASTIC CROSS-SECTION
      DATA SIGPI/0.182E+03,
     *           0.201E+03,0.222E+03,0.242E+03,0.263E+03,0.284E+03,
     *           0.303E+03,0.323E+03,0.346E+03,0.363E+03,0.386E+03/
C  KAON AIR INELASTIC CROSS-SECTION
      DATA SIGK /0.157E+03,
     *           0.176E+03,0.195E+03,0.215E+03,0.234E+03,0.253E+03,
     *           0.270E+03,0.290E+03,0.311E+03,0.328E+03,0.348E+03/
C  PROTON NITROGEN INELASTIC CROSS-SECTION
      DATA FRNVP /0.184E+03,
     *            0.202E+03,0.219E+03,0.239E+03,0.255E+03,0.276E+03,
     *            0.289E+03,0.311E+03,0.329E+03,0.349E+03,0.368E+03/
C  PION NITROGEN INELASTIC CROSS-SECTION
      DATA FRNVPI/0.137E+03,
     *            0.153E+03,0.169E+03,0.185E+03,0.201E+03,0.217E+03,
     *            0.232E+03,0.246E+03,0.265E+03,0.278E+03,0.296E+03/
C  KAON NITROGEN INELASTIC CROSS-SECTION
      DATA FRNVK /0.119E+03,
     *            0.134E+03,0.149E+03,0.164E+03,0.179E+03,0.194E+03,
     *            0.207E+03,0.221E+03,0.239E+03,0.251E+03,0.266E+03/
C  PROTON NITROGEN+OXYGEN  INELASTIC CROSS-SECTION
      DATA FRNOVP /0.238E+03,
     *             0.261E+03,0.284E+03,0.309E+03,0.331E+03,0.357E+03,
     *             0.375E+03,0.401E+03,0.424E+03,0.450E+03,0.474E+03/
C  PION NITROGEN+OXYGEN  INELASTIC CROSS-SECTION
      DATA FRNOVPI/0.178E+03,
     *             0.199E+03,0.220E+03,0.240E+03,0.261E+03,0.281E+03,
     *             0.300E+03,0.319E+03,0.343E+03,0.360E+03,0.382E+03/
C  KAON NITROGEN+OXYGEN  INELASTIC CROSS-SECTION
      DATA FRNOVK /0.157E+03,
     *             0.175E+03,0.193E+03,0.212E+03,0.232E+03,0.251E+03,
     *             0.268E+03,0.287E+03,0.308E+03,0.325E+03,0.345E+03/
C  PROTON PROTON INELASTIC CROSS-SECTION
*     DATA SPP  / 24.705D0,
*    *            28.749D0,33.001D0,37.675D0,42.785D0,48.348D0,
*    *            54.381D0,60.897D0,67.905D0,75.415D0,83.433D0    /
C  PROTON PROTON INELASTIC CROSS-SECTION (INCLUDING DIFFRACTION)
C   (MODIFIED APR 2ND, 1997)
      DATA SPP  / 27.444D0,
     *            31.599D0,36.382D0,41.693D0,47.555D0,54.000D0,
     *            61.059D0,68.756D0,77.113D0,86.146D0,95.870D0    /
C-----------------------------------------------------------------------

      IF ( DEBUG ) WRITE(MDEBUG,*) 'VENSIGINI: START'

C  FORM LOGARITH OF THE CROSS-SECTIONS FOR BETTER INTERPOLATION
      DO 10  I = 1,11
        SGVPL(I)    = LOG(SIGP(I))
        SGVPIL(I)   = LOG(SIGPI(I))
        SGVKL(I)    = LOG(SIGK(I))
        FRNVKL(I)   = LOG(FRNVK(I))
        FRNVPIL(I)  = LOG(FRNVPI(I))
        FRNVPL(I)   = LOG(FRNVP(I))
        FRNOVKL(I)  = LOG(FRNOVK(I))
        FRNOVPIL(I) = LOG(FRNOVPI(I))
        FRNOVPL(I)  = LOG(FRNOVP(I))
        SVPPL(I)    = LOG(SPP(I))
 10   CONTINUE
      IF ( DEBUG ) THEN
        WRITE(MDEBUG,25)
 25     FORMAT(' LOGARITHMS OF THE INELASTIC CROSS-SECTIONS (MBARN)'/
     *       ' ELAB(GEV)   SIG(P,P) ',
     *                  'SIG(P,AIR) SG(PI,AIR) SIG(K,AIR)')
        DO 30  I = 1,11
          AI = FLOAT(I)
          ELAB(I) = 10.D0**AI
          WRITE(MDEBUG,26) ELAB(I),SVPPL(I),
     *                             SGVPL(I),SGVPIL(I),SGVKL(I)
 26       FORMAT(1X,1P,E9.3,4(1X,E10.4))
 30     CONTINUE
        WRITE(MDEBUG,*) 'VENSIGINI: END'
      ENDIF

      RETURN
      END
*CMZ :          28/02/2002  12.36.16  by  D. HECK IK FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
C=======================================================================

      SUBROUTINE VSTORE

C-----------------------------------------------------------------------
C  V(ENUS PARTICLES) STORE (INTO CORSIKA STACK)
C
C  STORES VENUS OUTPUT PARTICLES INTO CORSIKA STACK
C  THIS SUBROUTINE IS CALLED FROM VENLNK.
C
C  DESIGN   : D. HECK    IK3  FZK KARLSRUHE
C-----------------------------------------------------------------------

*KEEP,CONSTA.
      COMMON /CONSTA/  PI,PI2,OB3,TB3,ENEPER
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER
*KEEP,DPMFLG.
      COMMON /DPMFLG/  NFLAIN,NFLDIF,NFLPI0,NFLCHE,NFLPIF,NFRAGM
      INTEGER          NFLAIN,NFLDIF,NFLPI0,NFLCHE,NFLPIF,NFRAGM
*KEEP,ELADPM.
      COMMON /ELADPM/  ELMEAN,ELMEAA,IELDPM,IELDPA
      DOUBLE PRECISION ELMEAN(40),ELMEAA(40)
      INTEGER          IELDPM(40,13),IELDPA(40,13)
*KEEP,ELASTY.
      COMMON /ELASTY/  ELAST
      DOUBLE PRECISION ELAST
*KEEP,INTER.
      COMMON /INTER/   AVCH,AVCH3,DC0,DLOG,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,DLOG,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
*KEEP,ISTA.
      COMMON /ISTA/    IFINET,IFINNU,IFINKA,IFINPI,IFINHY
      INTEGER          IFINET,IFINNU,IFINKA,IFINPI,IFINHY
*KEEP,LONGI.
      COMMON /LONGI/   ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP,LLONGI,FLGFIT
      DOUBLE PRECISION ADLONG(0:1170,9),AELONG(0:1170,9),
     *                 APLONG(0:1170,9),DLONG(0:1170,9),ELONG(0:1170,9),
     *                 HLONG(0:1170),PLONG(0:1170,9),SDLONG(0:1170,9),
     *                 SELONG(0:1170,9),SPLONG(0:1170,9),THSTEP,THSTPI
      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT
*KEEP,MULT.
      COMMON /MULT/    EKINL,MSMM,MULTMA,MULTOT
      DOUBLE PRECISION EKINL
      INTEGER          MSMM,MULTMA(40,13),MULTOT(40,13)
*KEEP,PAM.
      COMMON /PAM/     PAMA,SIGNUM,RESTMS
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000),RESTMS(6000)
*KEEP,PARPAR.
      COMMON /PARPAR/  CURPAR,SECPAR,PRMPAR,OUTPAR,C,
     *                 E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
      DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16),
     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH
      INTEGER          ITYPE,LEVL
*KEEP,PARPAE.
      DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM
     *                 ,WEIGHT
     *                 ,HAPP,COSTAP,COSTEA
      EQUIVALENCE      (CURPAR(2), GAMMA ), (CURPAR(3), COSTHE),
     *                 (CURPAR(4), PHI   ), (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)
*KEEP,RANDPA.
      COMMON /RANDPA/  FAC,U1,U2,RD,NSEQ,ISEED,KNOR
      DOUBLE PRECISION FAC,U1,U2
      REAL             RD(3000)
      INTEGER          ISEED(103,10),NSEQ
      LOGICAL          KNOR
*KEEP,REST.
      COMMON /REST/    CONTNE,TAR,LT
      DOUBLE PRECISION CONTNE(3),TAR
      INTEGER          LT
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEEP,SIGM.
      COMMON /SIGM/    SIGMA,SIGANN,SIGAIR,FRACTN,FRCTNO
      DOUBLE PRECISION SIGMA,SIGANN,SIGAIR,FRACTN,FRCTNO
*KEND.

      PARAMETER (KOLLMX=2500)
      PARAMETER (MXPTL=70000)
      PARAMETER (MXSTR=3000)
      PARAMETER (NDEP=129)
      PARAMETER (NDET=129)
      COMMON /ACCUM/   AMSAC,ILAMAS,IMSG,INOIAC,IPAGE,JERR,NAEVT,NREVT
     *                ,NRPTL,NRSTR,NTEVT
      COMMON /CEVT/    BIMEVT,COLEVT,EGYEVT,PHIEVT,PMXEVT
     *                ,KOLEVT,NEVT,NPJEVT,NTGEVT
      COMMON /COL/     BIMP,BMAX,COORD(4,KOLLMX),DISTCE(KOLLMX)
     *                ,QDEP(NDEP),QDET14(NDET),QDET16(NDET),QDET40(NDET)
     *                ,QDET99(NDET),RMPROJ,RMTARG(4),XDEP(NDEP)
     *                ,XDET14(NDET),XDET16(NDET),XDET40(NDET)
     *                ,XDET99(NDET)
     *                ,KOLL,LTARG,NORD(KOLLMX),NPROJ,NRPROJ(KOLLMX)
     *                ,NRTARG(KOLLMX),NTARG
      COMMON /CPTL/    PPTL(5,MXPTL),TIVPTL(2,MXPTL),XORPTL(4,MXPTL)
     *                ,IBPTL(4,MXPTL),ICLPTL(MXPTL),IDPTL(MXPTL)
     *                ,IFRPTL(2,MXPTL),IORPTL(MXPTL),ISTPTL(MXPTL)
     *                ,JORPTL(MXPTL),NPTL,NQJPTL(MXPTL)
      COMMON /CSTR/    PSTR(5,MXSTR),ROTSTR(3,MXSTR),XORSTR(4,MXSTR)
     *                ,ICSTR(4,MXSTR),IORSTR(MXSTR),IRLSTR(MXSTR),NSTR
      COMMON /FILES/   IFCH,IFDT,IFHI,IFMT,IFOP
      COMMON /PARO2/   AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY
     *                ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA
     *                ,YHAHA,YMXIMI,YPJTL
     *                ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM
     *                ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH
     *                ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI
     *                ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG
     *                ,MODSHO,NDECAX,NDECAY,NEVENT
      COMMON /PARO3/   ASUHAX(7),ASUHAY(7),OMEGA,SIGPPD,SIGPPE,UENTRO
     *                ,IWZZZZ

      DOUBLE PRECISION EA,ELASTI,EMAX,COSTET,PHIV,PL2,PT2,PTM
CC    DOUBLE PRECISION GAMMAX
      DOUBLE PRECISION PFRX(60),PFRY(60)
      INTEGER          ITYP(60),NRPTLA(MXPTL)
      SAVE
C-----------------------------------------------------------------------

      IF ( DEBUG ) WRITE(MDEBUG,*) 'VSTORE:'

C  NUMBER OF SPECTATORS OF REMAINING NUCLEUS IS NREST
      NREST = ITYPE/100 - NPJEVT
      IREST = ITYPE
      NNEW  = 0
      INEW  = 0
      ETOT  = 0.
      ELASTI = 0.
      NZNEW = 0
      NNNEW = 0
      KNEW = 0

      LEVT  = 1
      LPTL  = 3
      NPTLS = 0
      DO  1  I = 1,NPTL
        NRPTLA(I) = -999
        IF ( ISTPTL(I) .GT. ISTMAX ) GOTO 1
        NPTLS = NPTLS+1
        NRPTLA(I) = NPTLS
 1    CONTINUE

C  EVENT VARIABLES:
C     LEVT................... RECORD LABEL (LEVT=1)
C     NREVT.................. EVENT NUMBER
C     NPTLS ................. NUMBER OF (STORED!) PARTICLES PER EVENT
C     BIMEVT ................ IMPACT PARAMETER
C     KOLEVT,COLEVT ......... REAL/EFFECTIVE # OF COLLISIONS
C     PMXEVT ................ REFERENCE MOMENTUM
C     EGYEVT ................ PP CM ENERGY (HAD) OR STRING ENERGY (STR)
C     NPJEVT,NTGEVT ......... # OF PROJ/TARG PARTICIPANTS

      GNU = KOLEVT
      GNU = COLEVT
CC    GAMMAX = 0.D0
      EMAX   = 0.D0

C  PARTICLE LOOP
      DO  5  I = 1,NPTL
        IF ( NRPTLA(I) .LE. 0 ) GOTO 5

C  PARTICLE VARIABLES:
C     LPTL ......... RECORD LABEL (LPTL=3)
C     NREVT ........ EVENT NUMBER
C     NRPTL ........ PARTICLE NUMBER
C     I ............ ORIGINAL PTL NUMBER
C     IDPTL ........ PARTICLE ID
C     PPTL ......... 5-MOMENTUM (PX,PY,PZ,EN,MASS) IN LAB
C     IOPTL ........ ORIGIN (-999:PARENT NOT STORED, -1,0:NO PARENT)
C     JOPTL ........ ORIGIN (SECOND PARENT)
C     ISTPTL ....... STABLE (=0) OR NOT (=1)
C     XORPTL ....... SPACE-TIME POINT (X,Y,Z,T) ON PTL TRACK (PP-CM)
C     TIVPTL ....... TIME INTERVAL OF EXISTENCE
C     NQJPTL ....... QUARK NUMBERS OF JETS

C  ELIMINATE TARGET SPECTATORS
        IF ( PPTL(3,I) .EQ. 0. ) GOTO 5

C  ELIMINATE BACKWARD GOING PARTICLES
        IF ( .NOT. LLONGI  .AND.  PPTL(3,I) .LT. 0. ) GOTO 5
C  CONVERT PARTICLE CODE  VEN(US) ---> C(O)RS(IKA)
C  MOST FREQUENT PARTICLES COME FIRST
        KODVEN = IDPTL(I)
C  MESONS
        IF     ( KODVEN .EQ.   110 ) THEN
          KODCRS = 7
        ELSEIF ( KODVEN .EQ.   120 ) THEN
          KODCRS = 8
        ELSEIF ( KODVEN .EQ.  -120 ) THEN
          KODCRS = 9
        ELSEIF ( KODVEN .EQ.   220 ) THEN
          KODCRS = 17
C  NUCLEONS
        ELSEIF ( KODVEN .EQ.  1220 ) THEN
          KODCRS = 13
        ELSEIF ( KODVEN .EQ.  1120 ) THEN
          KODCRS = 14
        ELSEIF ( KODVEN .EQ. -1120 ) THEN
          KODCRS = 15
        ELSEIF ( KODVEN .EQ. -1220 ) THEN
          KODCRS = 25
C  STRANGE MESONS
        ELSEIF ( KODVEN .EQ.   -20 ) THEN
          KODCRS = 10
        ELSEIF ( KODVEN .EQ.   130 ) THEN
          KODCRS = 11
        ELSEIF ( KODVEN .EQ.  -130 ) THEN
          KODCRS = 12
        ELSEIF ( KODVEN .EQ.    20 ) THEN
          KODCRS = 16
C  STRANGE BARYONS
        ELSEIF ( KODVEN .EQ.  2130 ) THEN
          KODCRS = 18
        ELSEIF ( KODVEN .EQ.  1130 ) THEN
          KODCRS = 19
        ELSEIF ( KODVEN .EQ.  1230 ) THEN
          KODCRS = 20
        ELSEIF ( KODVEN .EQ.  2230 ) THEN
          KODCRS = 21
        ELSEIF ( KODVEN .EQ.  1330 ) THEN
          KODCRS = 22
        ELSEIF ( KODVEN .EQ.  2330 ) THEN
          KODCRS = 23
        ELSEIF ( KODVEN .EQ.  3331 ) THEN
          KODCRS = 24
        ELSEIF ( KODVEN .EQ. -2130 ) THEN
          KODCRS = 26
        ELSEIF ( KODVEN .EQ. -1130 ) THEN
          KODCRS = 27
        ELSEIF ( KODVEN .EQ. -1230 ) THEN
          KODCRS = 28
        ELSEIF ( KODVEN .EQ. -2230 ) THEN
          KODCRS = 29
        ELSEIF ( KODVEN .EQ. -1330 ) THEN
          KODCRS = 30
        ELSEIF ( KODVEN .EQ. -2330 ) THEN
          KODCRS = 31
        ELSEIF ( KODVEN .EQ. -3331 ) THEN
          KODCRS = 32
C  LEPTONS
        ELSEIF ( KODVEN .EQ.    10 ) THEN
          KODCRS = 1
        ELSEIF ( KODVEN .EQ.   -12 ) THEN
          KODCRS = 2
        ELSEIF ( KODVEN .EQ.    12 ) THEN
          KODCRS = 3
        ELSEIF ( KODVEN .EQ.   -14 ) THEN
          KODCRS = 5
        ELSEIF ( KODVEN .EQ.    14 ) THEN
          KODCRS = 6
C  NEUTRINOS ARE SKIPPED
        ELSEIF ( KODVEN .EQ.    11 ) THEN
          GOTO 55
        ELSEIF ( KODVEN .EQ.   -11 ) THEN
          GOTO 55
        ELSEIF ( KODVEN .EQ.    13 ) THEN
          GOTO 55
        ELSEIF ( KODVEN .EQ.   -13 ) THEN
          GOTO 55
        ELSE
          WRITE(MONIOU,*)'VSTORE: UNKNOWN PARTICLE CODE IDPTL=',IDPTL(I)
          GOTO 5
        ENDIF
        SECPAR(1) = KODCRS

C  ELIMINATE BACKWARD GOING PARTICLES
        IF ( LLONGI  .AND.  PPTL(3,I) .LT. 0. ) GOTO 56

        IF ( KODCRS .NE. 1  .AND.  KODCRS .LE. 65 ) THEN
C  ORDINARY SECONDARY PARTICLES
          SECPAR(2) = PPTL(4,I)/PAMA(KODCRS)
C  LOOK FOR SPECTATOR NUCLEONS
          IF ( KODCRS .EQ. 13  .OR.  KODCRS .EQ. 14 ) THEN
C  ELIMINATE TARGET SPECTATORS
            IF ( SECPAR(2) .LE. 1.002D0 ) GOTO 5
C  TREAT PROJECTILE SPECTATORS
            IF ( SECPAR(2) .GT. 0.999D0*GAMMA  .AND.
     *           SECPAR(2) .LT. 1.001D0*GAMMA  .AND.
     *           PPTL(1,I).EQ.0.  .AND.  PPTL(2,I).EQ.0. ) THEN
              IF ( NFRAGM .NE. 0 ) THEN
C  COMPOSE PROJECTILE SPECTATORS TO REMAINING NUCLEUS
                NREST = NREST - 1
                NNEW  = NNEW + 1
                IF     ( KODCRS .EQ. 14 ) THEN
                  INEW  = INEW + 101
                  IREST = IREST - 101
                ELSEIF ( KODCRS .EQ. 13 ) THEN
                  INEW  = INEW + 100
                  IREST = IREST - 100
                ENDIF
                GOTO 5
              ENDIF
C  DISREGARD PROJECTILE SPECTATORS FOR ELASTICITY
              GOTO 7
            ENDIF
          ENDIF

CC        IF ( SECPAR(2) .GT. GAMMAX ) THEN
CC          GAMMAX = SECPAR(2)
C  CALCULATE ELASTICITY FROM ENERGY OF FASTEST PARTICLE (LEADER)
CC          ELASTI = GAMMAX * PAMA(KODCRS) / ELAB
CC        ENDIF
          IF ( SECPAR(2)*PAMA(KODCRS) .GT. EMAX ) THEN
            EMAX = SECPAR(2)*PAMA(KODCRS)
C  CALCULATE ELASTICITY FROM MOST ENERGETIC PARTICLE (LEADER)
            ELASTI = EMAX * MAPROJ / ELAB
          ENDIF
        ELSE
C  GAMMAS AND NEUTRINOS
          SECPAR(2) = PPTL(4,I)
        ENDIF

C  COUNTER FOR ENERGY-MULTIPLICITY MATRIX
        MSMM = MSMM + 1

C  DETERMINE ANGLES FROM LONGITUDINAL AND TRANSVERSAL MOMENTA
 7      CONTINUE
        PT2 = DBLE(PPTL(1,I))**2 + DBLE(PPTL(2,I))**2
        PL2 = DBLE(PPTL(3,I))**2

        IF ( PL2+PT2 .LE. 0.D0 ) THEN
          COSTET = 0.D0
        ELSE
          COSTET = PPTL(3,I) / SQRT(PL2+PT2)
        ENDIF
        COSTET = MAX( MIN(COSTET, 1.D0), -1.D0 )
        IF ( PPTL(1,I)  .NE. 0.  .OR.  PPTL(2,I) .NE. 0. ) THEN
          PHIV = ATAN2( DBLE(PPTL(2,I)), DBLE(PPTL(1,I)) )
        ELSE
          PHIV = 0.D0
        ENDIF


C  COUNTERS FOR FIRST INTERACTION
        IF ( FIRSTI ) THEN
          IF     ( SECPAR(1) .EQ.  7.D0  .OR.  SECPAR(1) .EQ.  8.D0
     *       .OR.  SECPAR(1) .EQ.  9.D0                           ) THEN
            IFINPI = IFINPI + 1
          ELSEIF ( SECPAR(1) .EQ. 13.D0  .OR.  SECPAR(1) .EQ. 14.D0
     *       .OR.  SECPAR(1) .EQ. 15.D0 .OR. SECPAR(1) .EQ. 25.D0 ) THEN
            IFINNU = IFINNU + 1
          ELSEIF ( SECPAR(1) .EQ. 10.D0  .OR.  SECPAR(1) .EQ. 11.D0
     *       .OR.  SECPAR(1) .EQ. 12.D0 .OR. SECPAR(1) .EQ. 16.D0 ) THEN
            IFINKA = IFINKA + 1
          ELSEIF ( SECPAR(1) .EQ. 17.D0 ) THEN
            IFINET = IFINET + 1
          ELSEIF ((SECPAR(1) .GE. 18.D0 .AND. SECPAR(1) .LE. 24.D0)
     *       .OR. (SECPAR(1) .GE. 26.D0 .AND. SECPAR(1) .LE. 32.D0))THEN
            IFINHY = IFINHY + 1
          ENDIF
        ENDIF

        ETOT = ETOT + PPTL(4,I)
        CALL ADDANG( COSTHE,PHI, COSTET,PHIV, SECPAR(3),SECPAR(4) )
        IF ( SECPAR(3) .GE. C(29) ) THEN
          CALL TSTACK
          GOTO 5
        ELSE
          GOTO 56
        ENDIF

 55     IF ( LLONGI ) THEN
C  ADD NEUTRINO ENERGY TO LONGITUDINAL ENERGY DEPOSIT
          DLONG(LHEIGH,9) = DLONG(LHEIGH,9) + PPTL(4,I)
        ENDIF
        GOTO 5

 56     IF ( LLONGI ) THEN
C  ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT
          IF     ( KODCRS .LE.  3                        ) THEN
            DLONG(LHEIGH,3) = DLONG(LHEIGH,3) + PPTL(4,I)
          ELSEIF ( KODCRS .EQ.  5  .OR.   KODCRS .EQ.  6 ) THEN
            DLONG(LHEIGH,5) = DLONG(LHEIGH,5) + PPTL(4,I)
          ELSE
            DLONG(LHEIGH,7) = DLONG(LHEIGH,7) + PPTL(4,I)
     *                                        - RESTMS(KODCRS)
          ENDIF
        ENDIF

 5    CONTINUE

      IF ( DEBUG ) WRITE(MDEBUG,*) 'VSTORE: NTGEVT,ETOT =',NTGEVT,ETOT

      IF ( NFRAGM .NE. 0  .AND.  INEW .GT. 0 ) THEN
C  TREAT REMAINING NUCLEUS
        IF ( DEBUG ) WRITE(MDEBUG,150) INEW,(CURPAR(I),I=2,8)
 150    FORMAT(' VSTORE: REMNNT=',1P,I10,7E10.3)
        SECPAR(2) = CURPAR(2)
        SECPAR(3) = CURPAR(3)
        SECPAR(4) = CURPAR(4)

        IF     ( INEW .EQ. 100 ) THEN
C  REMAINING NUCLEUS IS SINGLE NEUTRON
          SECPAR(1) = 13.D0
          CALL TSTACK
          ETOT = ETOT + SECPAR(2) * PAMA(13)
          GOTO 140

        ELSEIF ( INEW .EQ. 101 ) THEN
C  REMAINING NUCLEUS IS SINGLE PROTON
          SECPAR(1) = 14.D0
          CALL TSTACK
          ETOT = ETOT + SECPAR(2) * PAMA(14)
          GOTO 140

        ELSEIF ( NFRAGM .GE. 2 ) THEN
C  REMAINING NUCLEUS IS EVAPORATING NUCLEONS AND ALPHA PARTICLES
          NZNEW = MOD(INEW,100)
          NNNEW = INEW/100 - NZNEW
          JFIN  = 0
          CALL VAPOR(MAPROJ,INEW,JFIN,ITYP,PFRX,PFRY)
          IF ( JFIN .EQ. 0 ) GOTO 139
C  LOOP TO TREAT THE REMANENTS OF THE DESINTEGRATED FRAGMENT
          KNEW = 0
          DO  135  J = 1,JFIN
            EA = GAMMA * PAMA(ITYP(J))
            IF (DEBUG) WRITE(MDEBUG,*) 'VSTORE: J,ITYP,EA=',J,ITYP(J),EA
C  MOMENTA SQUARED
            PTM = EA**2 - PAMA(ITYP(J))**2
            PT2 = PFRX(J)**2 + PFRY(J)**2
            IF ( PT2 .GE. PTM ) THEN
              IF (DEBUG) WRITE(MDEBUG,*) 'VSTORE: PT REJECT PARTICLE',J
              GOTO 135
            ENDIF
            IF ( PTM .GT. 0.D0 ) THEN
              COSTET = SQRT( 1.D0 - PT2/PTM )
            ELSE
              COSTET = 1.D0
            ENDIF
            IF ( PFRX(J) .NE. 0.D0  .OR.  PFRY(J) .NE. 0.D0 ) THEN
              PHIV = ATAN2( PFRY(J), PFRX(J) )
            ELSE
              PHIV = 0.D0
            ENDIF
            CALL ADDANG( COSTHE,PHI, COSTET,PHIV, SECPAR(3),SECPAR(4) )
            IF ( SECPAR(3) .GE. C(29) ) THEN
              IF ( J .LT. JFIN ) THEN
                SECPAR(1) = ITYP(J)
                CALL TSTACK
              ELSE
                KNEW = ITYP(JFIN)
              ENDIF
            ELSE
              IF(DEBUG)WRITE(MDEBUG,*) 'VSTORE: ANGLE REJECT PARTICLE',J
              IF ( LLONGI ) THEN
C  ADD ENERGY TO LONGITUDINAL ENERGY DEPOSIT
                DLONG(LHEIGH,7) = DLONG(LHEIGH,7) + EA
              ENDIF
            ENDIF
 135      CONTINUE

        ELSEIF ( NFRAGM .EQ. 1 ) THEN
C  REMAINING NUCLEUS IS ONE FRAGMENT
          NZNEW = MOD(INEW,100)
          NNNEW = INEW/100 - NZNEW
          KNEW  = INEW
        ENDIF

        IF     ( KNEW/100 .EQ. 5 ) THEN
C  REMAINING NUCLEUS: MASS 5 CANNOT BE TREATED IN BOX2
          IF ( MOD(KNEW,100) .GE. 3 ) THEN
C  MASS 5: SPLIT OFF ONE PROTON
            SECPAR(1) = 14.D0
            CALL TSTACK
            KNEW = KNEW - 101
          ELSE
C  MASS 5: SPLIT OFF ONE NEUTRON
            SECPAR(1) = 13.D0
            CALL TSTACK
            KNEW = KNEW - 100
          ENDIF
        ELSEIF ( KNEW/100 .EQ. 8 ) THEN
C  REMAINING NUCLEUS: MASS 8 CANNOT BE TREATED IN BOX2
          IF     ( MOD(KNEW,100) .GE. 5 ) THEN
C  MASS 8: SPLIT OFF ONE PROTON
            SECPAR(1) = 14.D0
            CALL TSTACK
            KNEW = KNEW - 101
          ELSEIF ( MOD(KNEW,100) .LE. 3 ) THEN
C  MASS 8: SPLIT OFF ONE NEUTRON
            SECPAR(1) = 13.D0
            CALL TSTACK
            KNEW = KNEW - 100
          ELSE
C  MASS 8: SPLIT OFF ONE ALPHA PARTICLE
            SECPAR(1) = 402.D0
            CALL TSTACK
            KNEW = KNEW - 402
          ENDIF
        ENDIF

        SECPAR(1) = KNEW
        CALL TSTACK
      ENDIF

 139  ETOT = ETOT + SECPAR(2)*(PAMA(13)*NNNEW + PAMA(14)*NZNEW)
 140  CONTINUE
      IF ( DEBUG ) WRITE(MDEBUG,*) 'VSTORE: ELASTI,ETOT,ELAB=',
     *                                SNGL(ELASTI),ETOT,ELAB

C  FILL ELASTICITY IN MATRICES
      MEL = MIN ( 1.D0+10.D0*      MAX( 0.D0, ELASTI ) , 11.D0 )
      MEN = MIN ( 4.D0+ 3.D0*LOG10(MAX( .1D0, EKINL  )), 40.D0 )
      IELDPM(MEN,MEL) = IELDPM(MEN,MEL) + 1
      IELDPA(MEN,MEL) = IELDPA(MEN,MEL) + 1
      IF ( ELASTI .LT. 1.D0 ) THEN
        ELMEAN(MEN) = ELMEAN(MEN) + ELASTI
        ELMEAA(MEN) = ELMEAA(MEN) + ELASTI
      ENDIF

      IF ( FIRSTI ) THEN
        TARG1I = TAR
        SIG1I  = SIGAIR
        ELAST  = ELASTI
        FIRSTI = .FALSE.
      ENDIF

      RETURN
      END
*CMZ :          28/02/2002  12.41.48  by  D. HECK IK FZK KARLSRUHE
*-- Author :    K. BERNLOEHR MPIK HEIDELBERG    15/06/98
C=======================================================================

      SUBROUTINE CERENK(STEPCR,UMEAN,VMEAN,WMEAN,EBEG,EEND,XBEG,YBEG,
     *           ZBEG,XEND,YEND,ZEND,TBEG,TEND,AMASS,CHARGE,WTTHIN,CTEA)

C-----------------------------------------------------------------------
C  C(H)ERENK(OV RADIATION FROM ALL KINDS OF CHARGED PARTICLES)
C
C  CREATION OF CHERENKOV PHOTONS ALONG THE TRACKS OF CHARGED PARTICLES.
C  CHERENKOV RADIATION IS ONLY CALCULATED FOR THE LOWEST OBSERVATION
C  LEVEL. ALL PARAMETERS OF THE PARTICLE TRACK STEP ARE PASSED AS
C  ARGUMENTS.
C  THIS SUBROUTINE IS CALLED FROM ELECTR AND UPDATE..
C  ARGUMENTS (ALL DOUBLE PRECISION):
C   STEPCR = STEP LENGTH FOR THE PARTICLE [CM]
C   UMEAN  = DIRECTION COSINE TO X AXIS (STEP AVERAGE)
C   VMEAN  = DIRECTION COSINE TO Y AXIS (STEP AVERAGE)
C   WMEAN  = DIRECTION COSINE TO -Z AXIS (STEP AVERAGE)
C   EBEG   = ENERGY [GEV] AT BEGINNING OF STEP
C   EEND   = ENERGY [GEV] AT END OF STEP
C   XBEG   = X POSITION [CM] AT BEGINNING OF STEP
C   XEND   = X POSITION [CM] AT END OF STEP
C   YBEG   = Y POSITION [CM] AT BEGINNING OF STEP
C   YEND   = Y POSITION [CM] AT END OF STEP
C   ZBEG   = Z POSITION [CM] AT BEGINNING OF STEP
C   ZEND   = Z POSITION [CM] AT END OF STEP
C   AMASS  = PARTICLE MASS [GEV/C**2]
C   CHARGE = CHARGE NUMBER (OR NEGATIVE - WE NEED ONLY THE SQUARE OF IT)
C   WTTHIN = PARTICLE WEIGHT FOR THINNING VERSION, ELSE 1.
C   CTEA   = COSINE OF EARTH ANGLE IN CURVED VERSION, ELSE 1.
C
C  THIS IMPLEMENTATION WRITTEN BY
C       K. BERNLOEHR  MPIK HEIDELBERG (1998)
C  THIS SUBROUTINE IS BASED IN PART ON THE FORMER CHERENKOV ROUTINES
C  CERENE AND CERENH ORIGINALLY WRITTEN BY
C       M. ROZANSKA   UNIVERSITY OF KRAKOW
C       S. MARTINEZ   UNIVERSITY OF MADRID
C       F. ARQUEROS   UNIVERSITY OF MADRID
C  AND SUBSEQUENTLY MODIFIED BY
C       D. HECK       IK3 FZK KARLSRUHE
C       R. ATTALLAH   UNIVERSITY OF PERPIGNAN
C
C  EXTERNAL IACT (IMAGING ATMOSPHERIC CHERENKOV TECHNIQUE) FUNCTIONS
C  FOR COLLECTING PHOTON BUNCHES AT ARBITRARY TELESCOPE LOCATIONS
C  WRITTEN (IN C) BY
C       K. BERNLOEHR  MPIK HEIDELBERG (1997)
C  AND AVAILABLE SEPARATELY.
C  THE SAME APPLIES TO FUNCTIONS FOR TABULATED ATMOSPHERIC MODELS AND
C  FUNCTIONS TO ACCOUNT FOR THE ATMOSPHERIC REFRACTION.
C
C-----------------------------------------------------------------------
c-----changed-add-comand
c>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
      parameter (xct=1)
      parameter (yct=2)
      parameter (zct=3)
      parameter (ctthet=4)
      parameter (ctphi=5)
      parameter (ctdiam=6)
      parameter (ctfoc=7)
c>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
 
c      IMPLICIT NONE
cx------------

c      IMPLICIT NONE
*KEEP,CONSTA.
      COMMON /CONSTA/  PI,PI2,OB3,TB3,ENEPER
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER
*KEEP,EGSDEB.
      COMMON /EGSDEB/  JCLOCK,NCLOCK,FEGSDB
      INTEGER          JCLOCK,NCLOCK
      LOGICAL          FEGSDB
*KEEP,LONGI.
      COMMON /LONGI/   ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP,LLONGI,FLGFIT
      DOUBLE PRECISION ADLONG(0:1170,9),AELONG(0:1170,9),
     *                 APLONG(0:1170,9),DLONG(0:1170,9),ELONG(0:1170,9),
     *                 HLONG(0:1170),PLONG(0:1170,9),SDLONG(0:1170,9),
     *                 SELONG(0:1170,9),SPLONG(0:1170,9),THSTEP,THSTPI
      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT
*KEEP,MAGANG.
      COMMON /MAGANG/  ARRANG,ARRANR,COSANG,SINANG
      DOUBLE PRECISION ARRANG,ARRANR,COSANG,SINANG
*KEEP,OBSPAR.
      COMMON /OBSPAR/  OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP,
     *                 THETPR,PHIPR,
     *                 VUECON,
     *                 NOBSLV
      DOUBLE PRECISION OBSLEV(10),THCKOB(10),XOFF(10),YOFF(10),
     *                 HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2)
      DOUBLE PRECISION VUECON(2)
      INTEGER          NOBSLV
*KEEP,PARPAR.
      COMMON /PARPAR/  CURPAR,SECPAR,PRMPAR,OUTPAR,C,
     *                 E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
      DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16),
     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH
      INTEGER          ITYPE,LEVL
*KEEP,RANDPA.
      COMMON /RANDPA/  FAC,U1,U2,RD,NSEQ,ISEED,KNOR
      DOUBLE PRECISION FAC,U1,U2
      REAL             RD(3000)
      INTEGER          ISEED(103,10),NSEQ
      LOGICAL          KNOR
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEEP,STACKE.
      COMMON /STACKE/  E,TIM,U,V,W,X,Y,Z,DNEAR,
     *                 ZAP,WAP,WA,
     *                 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)
     *                 ,ZAP(60),WAP(60),WA(60)
      INTEGER          IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP
*KEEP,CEREN1.
      COMMON /CEREN1/  CERELE,CERHAD,ETADSN,WAVLGL,WAVLGU,CYIELD,
     *                 CERSIZ,CERNOR,LCERFI
      DOUBLE PRECISION CERELE,CERHAD,ETADSN,WAVLGL,WAVLGU,CYIELD,
     *                 CERSIZ,CERNOR
      LOGICAL          LCERFI
*KEEP,CEREN2.
      COMMON /CEREN2/  ACERX,ACERY,CERXOS,CERYOS,
     *                 DCERX,DCERXI,DCERY,DCERYI,EPSX,EPSY,FCERX,FCERY,
     *                 WL,XCMAX,XCMAXS,XSCATT,YCMAX,YCMAXS,YSCATT,
     *                 PHOTCM,XCER,YCER,UEMIS,VEMIS,WEMIS,CARTIM,ZEMIS,
     *                 NCERX,NCERY,ICERML
      DOUBLE PRECISION ACERX,ACERY,CERXOS(20),CERYOS(20),
     *                 DCERX,DCERXI,DCERY,DCERYI,EPSX,EPSY,FCERX,FCERY,
     *                 WL,XCMAX,XCMAXS,XSCATT,YCMAX,YCMAXS,YSCATT
      DOUBLE PRECISION PHOTCM,XCER,YCER,UEMIS,VEMIS,WEMIS,CARTIM,ZEMIS
      INTEGER          NCERX,NCERY,ICERML
*KEEP,ATMOSX.
C  EXTERNAL ATMOSPHERIC MODELS
      COMMON /ATMOSX/  IATMOX,FREFRX
      INTEGER          IATMOX
      LOGICAL          FREFRX
*KEEP,CORFRAM, IF=CURVED.
      COMMON /CORFRAM/ DETSYS
      LOGICAL          DETSYS
*KEND.
*keep,certel.
      common /certel/  cormxd,cord,coralp,ctpars,omega,
     +                 photn,photnp,phpt,pht,vphot,
     +                 vchi,veta,vzeta,vchim,vetam,vzetam,
     +                 lambda,mu,nu,nctels,ncph,phip1,thetap1
      double precision cormxd,cord,coralp,ctpars(20,7),omega(20,3,3),
     +                 photn(3),photnp(3),phpt(3),pht,vphot(3),
     +                 vchi(3),veta(3),vzeta(3),vchim,vetam,vzetam,
     +                 lambda,mu,nu
      integer          nctels,ncph(5)
      double precision xg,yg,zg,xgp,ygp,zgp,up,vp,wp,xpcut,ypcut,zpcut
      double precision thetap1,phip1
      equivalence (photn(1) ,xg)   ,(photn(2) ,yg)   ,(photn(3) ,zg)  ,
     +            (photnp(1),xgp)  ,(photnp(2),ygp)  ,(photnp(3),zgp),
     +            (phpt(1)  ,xpcut),(phpt(2)  ,ypcut),(phpt(3)  ,zpcut),
     +            (vphot(1) ,up)   ,(vphot(2) ,vp)   ,(vphot(3) ,wp)    

      character *72 ctfile
*keep,graal1.
      common /graal1/ wavelength ! (nm)
      real wavelength
c>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
cxx --------
      double precision dist2
      integer imov,ntt,nct,nx
      double precision xx,yy,r
c>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
C-changes---add
C JOK SLIGHT CHANGE HERE BECAUSE WEMIS IS NOW IN COMMON CERENK2
      DOUBLE PRECISION PHICER,SINPSI,SINPS2,UEMIS2,
     *                 VEMIS2,      XCER2,XEMIS,YCER2,YEMIS
      DOUBLE PRECISION STEPCR
      DOUBLE PRECISION UMEAN,VMEAN,WMEAN
      DOUBLE PRECISION EBEG,EEND
      DOUBLE PRECISION XBEG,YBEG,ZBEG,XEND,YEND,ZEND
      DOUBLE PRECISION TBEG,TEND,AMASS,CHARGE,WTTHIN,CTEA
      DOUBLE PRECISION BETAE,BETAI,CTHETA,ETA1,ETA1I,ETA1E,STHETA
      DOUBLE PRECISION BETAM,ETA1M
      DOUBLE PRECISION TC11,TC21,TC12,TC22,TC32,TC13,TC23,TC33
      DOUBLE PRECISION BETA,BETAN,BETANI,DBETAN,ENER
      DOUBLE PRECISION ETALI,ETALE,DETAL,CINTEN
      DOUBLE PRECISION PHOTCT,PSTEP,PATHL,XSTEP,YSTEP,ZSTEP,ZEM
      DOUBLE PRECISION DEDPL,STHET2, SINPHI,COSPHI
      DOUBLE PRECISION BEMX,STCP,STSP,TEMIS,TSTEP
      DOUBLE PRECISION THKBEG,DTHKLG
C  WLFLAG PHOTON/PHOTO-ELECTRON FLAG (OR WAVELENGTH IN NANOMETER)
      DOUBLE PRECISION WLFLAG
      SAVE
C  FOR WLFLAG = 0.D0:  OUTPUT DATA ARE PHOTON BUNCHES
      PARAMETER (WLFLAG = 0.D0 )
      INTEGER          MAXRDM
      PARAMETER        ( MAXRDM = 100 )
      REAL             RDM(MAXRDM)
      INTEGER          LOOPFL,IRDM,NRDM
      INTEGER          ISTC,NSTEPC
      DOUBLE PRECISION XCER1,YCER1,XXX,YYY,DXXX,DYYY
      INTEGER          I
      DOUBLE PRECISION REFIDX
      EXTERNAL         REFIDX
      DOUBLE PRECISION RHOF,THICK
      EXTERNAL         RHOF,THICK
      DOUBLE PRECISION AUXILSQ,CDDIF,CDIFA,CDIFB,CUMEAN,CVMEAN,
     *                 CWMEAN,DISTIP,ETA2,RDIST,SDIFB,STHE,STHE2,
     *                 SWEMIS,TOFIP,ZAPP,ZHBEG,ZHEM,ZHEND,ZHSTEP
      EXTERNAL         DISTIP,TOFIP
C-----------------------------------------------------------------------

      IF ( FEGSDB ) WRITE(MDEBUG,*) 'CERENK: EBEG=',EBEG,' AMASS=',AMASS

C  SKIP PARTICLES OUT OF ZENITH ANGULAR CUT (WITH WMEAN>0 DOWNWARDS).
C  NOTE: USUALLY C(29) IS 0, I.E. UPWARD GOING PARTICLES ARE REJECTED.
      IF ( WMEAN .LT. C(29)  .OR.  STEPCR .LE. 0.D0 ) RETURN

C  LOOK WETHER CHERENKOV CONDITION IS FULFILLED FOR THIS STEP.
      BETAI = SQRT( 1.D0 - (AMASS/EBEG)**2 )
      BETAE = SQRT( 1.D0 - (AMASS/EEND)**2 )

C  REFRACTIVE INDEX PARAMETRISATION: N=1+ETA = ETA1
      IF ( IATMOX .GE. 1 ) THEN
        ETA1I = REFIDX(ZBEG)
        ETA1E = REFIDX(ZEND)
      ELSE
        ETA1I = 1.D0 + ETADSN * RHOF(ZBEG)
        ETA1E = 1.D0 + ETADSN * RHOF(ZEND)
      ENDIF
      IF ( BETAI*ETA1I.LT.1.D0  .AND.  BETAE*ETA1E.LT.1.D0 ) RETURN
      BETAM = SQRT( 1.D0 - (AMASS*2.D0/(EBEG+EEND))**2 )
      IF ( IATMOX .GE. 1 ) THEN
        ETA1M = REFIDX(0.5D0 * (ZBEG+ZEND))
      ELSE
        ETA1M = 1.D0 + ETADSN * RHOF(0.5D0 * (ZBEG+ZEND))
      ENDIF

      BEMX   = MAX( BETAE*ETA1E, BETAI*ETA1I )
      CINTEN = CYIELD * CHARGE**2
      PHOTCT = CINTEN * STEPCR * (1.D0 - 1.D0/BEMX**2)
      NSTEPC = PHOTCT / CERSIZ + 1
      IF ( NSTEPC .LT. 1 ) RETURN
C  TRANSFORM ALL COORDINATES INTO DETECTOR FRAME (IF NOT DONE UNTIL NOW)
C  XBEG, XEND, YBEG, YEND ARE TRANSFORMED IN UPDATE (OR PARTLY IN UPDATC)
      IF ( .NOT. DETSYS ) THEN
C  FIRST TRANSFORM ANGLES INTO DETECTOR FRAME
C  (ROTATE LOCAL FRAME WITH EARTH ANGLE DIF)
        CDIFB = CTEA
        CDIFB = MIN( 1.D0, CDIFB )
        SDIFB = SQRT( 1.D0 - CTEA**2 )
        SDIFB = MIN( 1.D0, SDIFB )
        STHE  = SQRT(UMEAN**2 + VMEAN**2)
        IF ( STHE .GT. 0.D0 ) THEN
          CUMEAN = UMEAN/STHE
          CVMEAN = VMEAN/STHE
          CUMEAN = WMEAN*SDIFB*CUMEAN + CDIFB*STHE*CUMEAN
          CVMEAN = WMEAN*SDIFB*CVMEAN + CDIFB*STHE*CVMEAN
          CWMEAN = WMEAN*CDIFB        - SDIFB*STHE
        ELSE
          CUMEAN = WMEAN*SDIFB*UMEAN
          CVMEAN = WMEAN*SDIFB*VMEAN
          CWMEAN = WMEAN*CDIFB
        ENDIF
        IF ( FEGSDB ) WRITE(MDEBUG,*) 'CERENK: CURVED; CWMEAN=',CWMEAN
        IF ( CWMEAN .LT. C(29) ) RETURN
C  ZBEG, ZEND IN DETECTOR FRAME (ZHBEG, ZHEND)
C  ACTUAL EARTH ANGLE
        AUXILSQ = SQRT( XBEG**2 + YBEG**2 )
        CDIFA   = COS( AUXILSQ/C(1) )
        IF ( CDIFA .GT. CTEA ) THEN
C  TRANSFORM FIRST INTO THE INTERMEDIATE LOCAL SYSTEM
          CDDIF = CTEA*CDIFA + SQRT( (1.D0-CTEA**2)*(1.D0-CDIFA**2) )
          ZBEG  = (ZBEG+C(1)) / CDDIF - C(1)
          ZEND  = (ZEND+C(1)) / CDDIF - C(1)
        ENDIF
        ZHBEG = (ZBEG+C(1)) * CDIFA - C(1)
        IF ( ZHBEG .LE. OBSLEV(1) ) RETURN
C  TAKE EARTH ANGLE OF END POINT OF PART OF TRACK FOR CALCULATING ZHEND
        AUXILSQ = SQRT( XEND**2 + YEND**2)
        ZHEND = (ZEND+C(1)) * COS(AUXILSQ/C(1)) - C(1)
C  NOW TRANSFORM CURVED COORDINATES INTO FLAT COORDINATE FRAME
C  TAKING THE NOW AVAILABLE VALUES OF HAPP (X = X(HAPP))
        XBEG  = (ZHBEG+C(1)) * TAN(XBEG/C(1))
        YBEG  = (ZHBEG+C(1)) * TAN(YBEG/C(1))
        XEND  = (ZHEND+C(1)) * TAN(XEND/C(1))
        YEND  = (ZHEND+C(1)) * TAN(YEND/C(1))
      ENDIF

C  NOW CHECK WHICH KIND OF CALCULATING (BETA*N) FOR EACH SUB-STEP
C  IS LIKELY TO BE THE MOST EFFICIENT.
C  CASE 0: ONLY ONE STEP - WE HAVE ALREADY THE NUMBERS AT MID-STEP.
      IF     ( NSTEPC .EQ. 1 ) THEN
        LOOPFL = 0
C  CASE 1: LINEAR INTERPOLATION OF (BETA*N) IF THE RELATIVE ERROR ON
C  THE LIGHT INTENSITY IN THE MIDDLE IS LESS THAN 1E-3 (THEN THE ERROR
C  ON THE IMPACT POINT FOR VERTICAL INCIDENCE IS LESS THAN ABOUT 5 CM).
      ELSEIF ( (BETAE*ETA1E).GT.1D0 .AND. (BETAI*ETA1I).GT.1D0 .AND.
     *    (BETAM*ETA1M).GT.1D0 .AND.
     *    ABS((2.D0-1.D0/(BETAI*ETA1I)**2-1.D0/(BETAE*ETA1E)**2)/
     *    (1.D0-1.D0/(BETAM*ETA1M)**2)-2.D0) .LT. 2.D-3*WMEAN ) THEN
        LOOPFL = 1
        DBETAN = (BETAE*ETA1E-BETAI*ETA1I) / STEPCR
        BETANI = BETAI * ETA1I
        DEDPL  = (EEND-EBEG) / STEPCR
C  CASE 2: LOGARITHMIC INTERPOLATION OF (N-1) IS GOOD ENOUGH FOR
C  ERRORS ON THE IMPACT POINT BEING LESS THAN 10 CM.
C  BETA IS CALCULATED EXPLICITLY ASSUMING CONSTANT ENERGY LOSS.
C  NOTE THAT WE USE CONSTANT ENERGY LOSS PER CENTIMETER RATHER THAN
C  PER UNIT G/CM**2 FOR EFFICIENCY REASONS. THE POSSIBLE DIFFERENCE
C  OF ENERGY AT MIDDLE OF STEP SHOULD BE INSIGNIFICANT IN ALMOST
C  ANY CASE.
      ELSEIF ( ABS((ETA1I-1.D0)*(ETA1E-1.D0)/(ETA1M-1.D0)**2 - 1.D0)
     *      .LT. (10.D0/ZBEG*WMEAN)**2 ) THEN
        LOOPFL = 2
        ETALI  = LOG(ETA1I-1.D0)
        ETALE  = LOG(ETA1E-1.D0)
        DETAL  = (ETALE-ETALI) / STEPCR
        DEDPL  = (EEND-EBEG) / STEPCR
      ELSE
C  CASE 3: BOTH N AND BETA HAVE TO BE CALCULATED IN FULL DETAIL.
        LOOPFL = 3
        DEDPL  = (EEND-EBEG) / STEPCR
      ENDIF

C  VARIOUS START VALUES AND STEP LENGTHS FOR SUB-STEP LOOP
      PSTEP = STEPCR * (1.D0/DBLE(NSTEPC))
      PATHL = (-0.5D0)*PSTEP
      XSTEP = (XEND-XBEG) * (1.D0/DBLE(NSTEPC))
      YSTEP = (YEND-YBEG) * (1.D0/DBLE(NSTEPC))
      TSTEP = (TEND-TBEG) * (1.D0/DBLE(NSTEPC))
      XEMIS = XBEG - 0.5D0*XSTEP
      YEMIS = YBEG - 0.5D0*YSTEP
      TEMIS = TBEG - 0.5D0*TSTEP
      ZSTEP  = (ZEND-ZBEG) * (1.D0/DBLE(NSTEPC))
      ZEM    = ZBEG - 0.5D0*ZSTEP
C  THE TC.. ELEMENTS ARE DESCRIBED FURTHER DOWN.
      IF ( .NOT. DETSYS ) THEN
        ZHSTEP = (ZHEND-ZHBEG) * (1.D0/DBLE(NSTEPC))
        ZHEM   = ZHBEG - 0.5D0*ZHSTEP
        IF ( ZHEM .LE. OBSLEV(1) ) RETURN
        SINPS2 = CUMEAN**2 + CVMEAN**2
        IF ( SINPS2 .LT. 1.D-20 ) SINPS2 = 1.D-20
        SINPSI = SQRT(SINPS2)
        TC11   = CVMEAN*(1.D0/SINPSI)
        TC12   = CUMEAN*CWMEAN*(1.D0/SINPSI)
        TC13   = CUMEAN
        TC21   = (-CUMEAN)*(1.D0/SINPSI)
        TC22   = CVMEAN*CWMEAN*(1.D0/SINPSI)
        TC23   = CVMEAN
        TC32   = -SINPSI
        TC33   = CWMEAN
      ELSE
       SINPS2 = UMEAN**2 + VMEAN**2
       IF ( SINPS2 .LT. 1.D-20 ) SINPS2 = 1.D-20
       SINPSI = SQRT(SINPS2)
       TC11   = VMEAN*(1.D0/SINPSI)
       TC12   = UMEAN*WMEAN*(1.D0/SINPSI)
       TC13   = UMEAN
       TC21   = (-UMEAN)*(1.D0/SINPSI)
       TC22   = VMEAN*WMEAN*(1.D0/SINPSI)
       TC23   = VMEAN
       TC32   = -SINPSI
       TC33   = WMEAN
      ENDIF

C  SINCE EXPONENTIAL ATMOSPHERIC LAYERS ARE ASSUMED, A LOGARITHMIC
C  INTERPOLATION OF THE ATMOSPHERIC THICKNESS CAN BE APPLIED.
      IF ( NSTEPC .GT. 3 ) THEN
        THKBEG = MAX( 1.D-3, THICK(ZBEG))
        DTHKLG = LOG(THICK(ZEND)/THKBEG) / STEPCR
      ENDIF

C  DON'T GET RANDOM NUMBERS ONE-BY-ONE BUT IN LARGER CHUNKS.
      NRDM = NSTEPC
      IRDM = 0
      IF ( NRDM .GT. MAXRDM ) THEN
        CALL RMMAR(RDM,MAXRDM,3)
      ELSE
        CALL RMMAR(RDM,NRDM,3)
      ENDIF

C  LOOP OVER THE NUMBER OF SUB-STEPS WITH CONSTANT PARTICLE DIRECTION
C  BUT CONTINUOUS ENERGY LOSS AND REFRACTION INDEX CHANGE ACCOUNTED FOR.
C  SINCE ACTUAL VELOCITY CHANGES OF PARTICLES EMITTING CHERENKOV LIGHT
C  IN THE ATMOSPHERE ARE VERY SMALL, CONSTANT STEPS IN (X,Y,Z,T) ARE USED.
      DO 1000  ISTC = 1,NSTEPC
        PATHL = PATHL + PSTEP
        XEMIS = XEMIS + XSTEP
        YEMIS = YEMIS + YSTEP
        ZEM   = ZEM   + ZSTEP
        TEMIS = TEMIS + TSTEP
        IF ( .NOT. DETSYS ) THEN
          ZHEM = ZHEM + ZHSTEP
          IF ( ZHEM .LE. OBSLEV(1) ) RETURN
        ENDIF

C  DEPENDING ON CONDITIONS USE THE FASTEST METHOD TO GET (BETA*N).
        IF     ( LOOPFL .EQ. 1 ) THEN
C  THE MOST FREQUENT AND SIMPLEST CASE (WELL ABOVE THRESHOLD).
          BETAN = BETANI + DBETAN*PATHL
        ELSEIF ( NSTEPC .EQ. 1 ) THEN
C  THIS CASE IS USALLY ENCOUNTERED NEAR THRESHOLD.
          BETAN = BETAM*ETA1M
        ELSEIF ( LOOPFL .EQ. 2 ) THEN
C  THIS CASE IS ALSO USALLY ENCOUNTERED NEAR THRESHOLD.
          ETA1  = 1.D0 + EXP(ETALI+DETAL*PATHL)
          ENER  = EBEG + DEDPL*PATHL
          BETA  = SQRT(1.D0-(AMASS/ENER)**2)
          BETAN = BETA*ETA1
        ELSE
C  THIS MOST GENERAL CASE IS RARELY ENCOUNTERED.
          IF ( IATMOX .GE. 1 ) THEN
            ETA1 = REFIDX(ZEM)
          ELSE
            ETA1 = 1.D0 + ETADSN * RHOF(ZEM)
          ENDIF
          ENER  = EBEG + DEDPL*PATHL
          BETA  = SQRT(1.D0-(AMASS/ENER)**2)
          BETAN = BETA*ETA1
        ENDIF
        IF ( FEGSDB ) WRITE(MDEBUG,*)
     *                  'CERENK: LOOPFL=',LOOPFL,' BETAN=',BETAN
        CTHETA = 1.D0 / BETAN
        STHET2 = 1.D0 - CTHETA**2
C  PARTICLE IS BELOW ENERGY THRESHOLD IF THE EMISSION ANGLE IS <=0
        IF ( CTHETA .GT. 1.D0  .OR.  STHET2 .LE. 0.D0 ) THEN
          NRDM = NRDM - 1
          GOTO 1000
        ENDIF
C  NUMBER OF EMITTED PHOTONS IN THIS SUB-STEP
        PHOTCM = (CINTEN*PSTEP) * STHET2
        STHETA = SQRT(STHET2)
C  ASSUME EMISSION POINT OF ALL PHOTONS IN THE MIDDLE OF THE STEP
C  SAVE EMMISION HEIGHT SEEN FROM THE DETECTOR
        IF ( .NOT. DETSYS ) THEN
          ZEMIS = ZHEM
          ZAPP  = ZHEM
        ELSE
          ZEMIS = ZEM
          ZAPP  = ZEM
        ENDIF

C  CALCULATE PHOTON DIRECTION IN THE CORSIKA COORDINATE FRAME
C
C  NOTE: TO DERIVE THESE EQUATIONS YOU SHOULD FIRST DERIVE A MATRIX (T)
C  WHICH ROTATES THE PARTICLE DIRECTION (U, V, W) TO (0, 0, 1):
C
C         (  V/SQRT(U**2+V**2)    -U/SQRT(U**2+V**2)         0          )
C  (T) =  ( UW/SQRT(U**2+V**2)    VW/SQRT(U**2+V**2)  -SQRT(U**2+V**2)  )
C         (       U                       V                  W          )
C
C  CHERENKOV EMISSION IN THIS ROTATED COORDINATE SYSTEM IS DESCRIBED BY
C  A MATRIX (C):
C
C        ( COS(PHI)  -SIN(PHI)   0  )  (  COS(THETA)   0   SIN(THETA)  )
C  (C) = ( SIN(PHI)   COS(PHI)   0  )  (     0         1      0        )
C        (    0          0       1  )  ( -SIN(THETA)   0   COS(THETA)  )
C
C  WHERE THETA IS THE CHERENKOV OPENING ANGLE AND PHI IS RANDOM.
C  THE RESULT IS (T_T)**-1  (C) (0,0,1):
C
C                (0)
C  (T_T)**-1 (C) (0) =
C                (1)
C
C                ( V/S*SIN(T)*COS(PHI)+U*W/S*SIN(T)*SIN(PHI)+U*COS(T) )
C              = (-U/S*SIN(T)*COS(PHI)+V*W/S*SIN(T)*SIN(PHI)+V*COS(T) )
C                (                        -S*SIN(T)*SIN(PHI)+W*COS(T) )
C
C  WITH S = SQRT(U**2+V**2) AND T=THETA. THE CONSTANT PARTS ARE CALCULATED
C  AS TC11 ... TC33 BEFORE THE '1000' LOOP.

C  DON'T GET RANDOM NUMBERS ONE-BY-ONE BUT IN LARGER CHUNKS FROM SEQ. 3
        IRDM = IRDM + 1
        IF ( IRDM .GT. MAXRDM ) THEN
          IF ( NRDM .GT. MAXRDM ) THEN
            CALL RMMAR(RDM,MAXRDM,3)
            NRDM = NRDM - MAXRDM
          ELSE
            CALL RMMAR(RDM,NRDM,3)
            NRDM = 0
          ENDIF
          IRDM = 1
        ENDIF
        PHICER = RDM(IRDM) * PI2
        SINPHI = SIN(PHICER)
        COSPHI = COS(PHICER)

        IF ( SINPS2 .LE. 1.D-12 ) THEN
          UEMIS2 = STHETA * COSPHI
          VEMIS2 = STHETA * SINPHI
          WEMIS  = CTHETA
          IF ( WMEAN .LT. 0.D0 ) WEMIS = -CTHETA
        ELSE
          STCP   = STHETA * COSPHI
          STSP   = STHETA * SINPHI
          UEMIS2 = TC11*STCP + TC12*STSP + TC13*CTHETA
          VEMIS2 = TC21*STCP + TC22*STSP + TC23*CTHETA
          WEMIS  =             TC32*STSP + TC33*CTHETA
        ENDIF
        IF ( FEGSDB ) WRITE(MDEBUG,*) 'CERENK: UEMIS2,VEMIS2,WEMIS=',
     *                                         UEMIS2,VEMIS2,WEMIS
C  EMISSION ANGLE WITHIN ZENITH ANGULAR CUT?
        IF ( WEMIS .LT. C(29) ) GOTO 1000
        WEMIS = MIN( 1.D0, WEMIS )

C  CALCULATE OFFSET FROM SHOWER AXIS AT THE DETECTOR LEVEL.
C  CALCULATE NEW DETECTOR COORDINATES BY INTERPOLATING BETWEEN
C  TABULATED VALUES WHICH WERE NUMERICALLY INTEGRATED
C  TAKING INTO ACCOUNT ATMOSPHERIC REFRACTION IN A CURVED GEOMETRY
        STHE  = SQRT(UEMIS2**2 + VEMIS2**2)
        RDIST = DISTIP( WEMIS, ZAPP)
        IF ( FEGSDB ) WRITE(MDEBUG,*) 'CERENK: WEMIS,ZEM,STHE,RDIST=',
     *                                         WEMIS,ZEM,STHE,RDIST
        IF ( STHE .GT. 0.D0 ) THEN
C  UEMIS2=COSPHI, VEMIS2=SINPHI
          XCER2 = XEMIS + RDIST * UEMIS2/STHE
          YCER2 = YEMIS + RDIST * VEMIS2/STHE
        ELSE
          XCER2 = XEMIS
          YCER2 = YEMIS
        ENDIF

C  ADD THE CHERENKOV PHOTONS TO THE LONGITUDINAL DEVELOPMENT.
        IF ( LLONGI ) THEN
          IF ( AMASS .LT. 1.D-3 ) THEN
            CALL CERLDE
          ELSE
            CALL CERLDH
          ENDIF
        ENDIF

C  TAKE THE ROTATION RELATIVE TO MAGNETIC NORTH INTO ACCOUNT
        XCER  = XCER2  * COSANG + YCER2  * SINANG
        YCER  = YCER2  * COSANG - XCER2  * SINANG
        UEMIS = UEMIS2 * COSANG + VEMIS2 * SINANG
        VEMIS = VEMIS2 * COSANG - UEMIS2 * SINANG
        IF ( FEGSDB ) WRITE(MDEBUG,*) 'CERENK: UEMIS,VEMIS,PHOTCM=',
     *                          SNGL(UEMIS),SNGL(VEMIS),SNGL(PHOTCM)
C  ONLY PHOTON BUNCHES INSIDE CHERENKOV ARRAY

c--changes--add
c        IF ( ABS(XCER) .LT. XCMAXS  .AND.  ABS(YCER) .LT. YCMAXS ) THEN
          IF ( AMASS .LT. 1.D-3 ) THEN
            CERELE = CERELE + PHOTCM
          ELSE
            CERHAD = CERHAD + PHOTCM
          ENDIF

          DO 7001  I = 1,ICERML
             DO 101 NCT=1,NCTELS
                XCER1 = XCER - CERXOS(I) - CTPARS(NCT,XCT)
c            XXX   = XCER1 * DCERXI + FCERX
c            DXXX  = ABS( XXX - NINT(XXX) )
c            IF ( DXXX .LE. EPSX ) THEN
c              IF ( XCER1.LT.-XCMAX  .OR.  XCER1.GT.XCMAX ) GOTO 7001
                YCER1 = YCER - CERYOS(I) - CTPARS(NCT,YCT)
c              YYY   = YCER1 * DCERYI + FCERY
c              DYYY  = ABS( YYY - NINT(YYY) )
c              IF ( DYYY .LE. EPSY ) THEN
c                IF ( YCER1.LT.-YCMAX  .OR.  YCER1.GT.YCMAX ) GOTO 7001
c
                xx=xcer1*dcos(phip1)-ycer1*dsin(phip1)
                yy=xcer1*dsin(phip1)+ycer1*dcos(phip1)
                dist2=dsqrt((xx*dcos(thetap1))**2+yy**2+1.d-10)
c	
c                IF (dist2.GT.(CTPARS(NCT,CTDIAM)/2.)) GOTO 7001
c
c Fixed by AM, 24/7/2002, to allow use of CERTEL option with more
c than one telescope:
c
                IF (dist2.LT.(CTPARS(NCT,CTDIAM)/2.)) GOTO 102

 101         continue

c If photon is not within reach of any of the telescopes, skip it:
             GOTO 7001

c--changes
C  BUNCH FALLS ON A DETECTOR, CALCULATE ARRIVAL TIME (NSEC)
 102         IF ( FREFRX ) THEN
C  CALCULATE TIME OF FLIGHT BY INTERPOLATING BETWEEN TABULATED VALUES
                CARTIM = TEMIS * 1.D9 + TOFIP(WEMIS,ZAPP)
             ELSE
C  CALCULATE TIME OF FLIGHT BY INTERPOLATING BETWEEN TABULATED VALUES
                CARTIM = TEMIS * 1.D9 + TOFIP(WEMIS,ZAPP)
             ENDIF
C  CORRECT ZENITH ANGLE DUE TO ATMOSPHERIC REFRACTION FOR OUTPUT
             IF ( IATMOX .GE. 1 ) THEN
                ETA2 = REFIDX( OBSLEV(1) )
             ELSE
                ETA2 = 1.D0 + ETADSN * RHOF( OBSLEV(1) )
             ENDIF
             SWEMIS =  1.D0 - WEMIS**2
             SWEMIS = (ETA1/ETA2)**2 * SWEMIS
             WEMIS  = MIN( 1.D0, SQRT(1.D0 - SWEMIS) )
C     NOW CORRECT ALSO THE OTHER DIRECTION COSINE
             STHE   = SQRT( VEMIS**2 + UEMIS**2 )
             STHE2  = SQRT( 1.D0 - WEMIS**2 )
             VEMIS  = VEMIS/STHE * STHE2
             UEMIS  = UEMIS/STHE * STHE2
c-changes
c            CALL OUTPT2
c            GOTO 1000
c            ENDIF
c            ENDIF


C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
C GENERATE RANDOM WAVELENGTH FOR SINGLE C-PHOTON.
             CALL RMMAR( RD,1,3 )
             WAVELENGTH = 1. / (1/WAVLGL - 
     +            RD(1)/(WAVLGL*WAVLGU/(WAVLGU-WAVLGL)))
C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
             if(amass.lt.5.11d-4) then
                nx=2
             else 
                nx=itype
             endif
c      write(moniou,*) itype,nx,amass
             CALL OUTPT2(nx,I)
c      CALL OUTPT2(NCT,I)

             GOTO 1000

 7001     CONTINUE
cxx        ENDIF
 1000  CONTINUE

       RETURN
       END
*CMZ :          19/10/2000  11.44.20  by  D. HECK IK3 FZK KARLSRUHE
*-- Author :    K. BERNLOEHR MPIK HEIDELBERG    15/06/98
C=======================================================================

      SUBROUTINE CERLDE

C-----------------------------------------------------------------------
C  C(H)ER(ENKOV) L(ONGITUNAL) D(EVELOPMENT FOR) E(LECTRONS & POSITRONS)
C
C  THIS SUBROUTINE IS CALLED FROM CERENK.
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,CEREN2.
      COMMON /CEREN2/  ACERX,ACERY,CERXOS,CERYOS,
     *                 DCERX,DCERXI,DCERY,DCERYI,EPSX,EPSY,FCERX,FCERY,
     *                 WL,XCMAX,XCMAXS,XSCATT,YCMAX,YCMAXS,YSCATT,
     *                 PHOTCM,XCER,YCER,UEMIS,VEMIS,WEMIS,CARTIM,ZEMIS,
     *                 NCERX,NCERY,ICERML
      DOUBLE PRECISION ACERX,ACERY,CERXOS(20),CERYOS(20),
     *                 DCERX,DCERXI,DCERY,DCERYI,EPSX,EPSY,FCERX,FCERY,
     *                 WL,XCMAX,XCMAXS,XSCATT,YCMAX,YCMAXS,YSCATT
      DOUBLE PRECISION PHOTCM,XCER,YCER,UEMIS,VEMIS,WEMIS,CARTIM,ZEMIS
      INTEGER          NCERX,NCERY,ICERML
*KEEP,LONGI.
      COMMON /LONGI/   ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP,LLONGI,FLGFIT
      DOUBLE PRECISION ADLONG(0:1170,9),AELONG(0:1170,9),
     *                 APLONG(0:1170,9),DLONG(0:1170,9),ELONG(0:1170,9),
     *                 HLONG(0:1170),PLONG(0:1170,9),SDLONG(0:1170,9),
     *                 SELONG(0:1170,9),SPLONG(0:1170,9),THSTEP,THSTPI
      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT
*KEEP,STACKE.
      COMMON /STACKE/  E,TIM,U,V,W,X,Y,Z,DNEAR,
     *                 ZAP,WAP,WA,
     *                 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)
     *                 ,ZAP(60),WAP(60),WA(60)
      INTEGER          IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP
*KEND.

      INTEGER          I1,LPCT1
      SAVE
C-----------------------------------------------------------------------

C  IF STARTING POINT IS BELOW LOWEST LEVEL THEN DON'T CHECK.
      IF ( HLONG(NSTEP) .LE. ZEMIS ) THEN
C  FIND FIRST THE EQUIVALENT LEVELS
        LPCT1 = LPCTE(NP)
C  ZEMIS IS ONLY LITTLE BELOW Z OLD, THEREFORE INCREMENTAL SEARCH.
C  (REMEMBER: LPCTE IS AT START OF ELECTRON STEP)
        DO 6002  I1 = LPCT1,NSTEP
          IF ( HLONG(I1) .LT. ZEMIS ) GOTO 6003
 6002   CONTINUE
        I1 = NSTEP + 1
 6003   CONTINUE

C  PHOTONS ENTER THE VERTICAL DISTRIBUTION ONLY IN THE STEP WHERE THEY
C  WERE EMITTED. THIS IS FAR MORE EFFICIENT THAN OLD, INTEGRATED MODE.
        PLONG(I1,9) = PLONG(I1,9) + PHOTCM

      ENDIF
      RETURN
      END
*CMZ :          19/10/2000  11.45.12  by  D. HECK IK3 FZK KARLSRUHE
*-- Author :    K. BERNLOEHR MPIK HEIDELBERG    15/06/98
C=======================================================================

      SUBROUTINE CERLDH

C-----------------------------------------------------------------------
C  C(H)ER(ENKOV) L(ONGITUNAL) D(EVELOPMENT FOR) H(ADRONS & MUONS)
C
C  THIS SUBROUTINE IS CALLED FROM CERENK.
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,CEREN2.
      COMMON /CEREN2/  ACERX,ACERY,CERXOS,CERYOS,
     *                 DCERX,DCERXI,DCERY,DCERYI,EPSX,EPSY,FCERX,FCERY,
     *                 WL,XCMAX,XCMAXS,XSCATT,YCMAX,YCMAXS,YSCATT,
     *                 PHOTCM,XCER,YCER,UEMIS,VEMIS,WEMIS,CARTIM,ZEMIS,
     *                 NCERX,NCERY,ICERML
      DOUBLE PRECISION ACERX,ACERY,CERXOS(20),CERYOS(20),
     *                 DCERX,DCERXI,DCERY,DCERYI,EPSX,EPSY,FCERX,FCERY,
     *                 WL,XCMAX,XCMAXS,XSCATT,YCMAX,YCMAXS,YSCATT
      DOUBLE PRECISION PHOTCM,XCER,YCER,UEMIS,VEMIS,WEMIS,CARTIM,ZEMIS
      INTEGER          NCERX,NCERY,ICERML
*KEEP,LONGI.
      COMMON /LONGI/   ADLONG,AELONG,APLONG,DLONG,ELONG,HLONG,PLONG,
     *                 SDLONG,SELONG,SPLONG,THSTEP,THSTPI,
     *                 LHEIGH,NSTEP,LLONGI,FLGFIT
      DOUBLE PRECISION ADLONG(0:1170,9),AELONG(0:1170,9),
     *                 APLONG(0:1170,9),DLONG(0:1170,9),ELONG(0:1170,9),
     *                 HLONG(0:1170),PLONG(0:1170,9),SDLONG(0:1170,9),
     *                 SELONG(0:1170,9),SPLONG(0:1170,9),THSTEP,THSTPI
      INTEGER          LHEIGH,NSTEP
      LOGICAL          LLONGI,FLGFIT
*KEND.

      INTEGER          I1,I2,II
      SAVE
C-----------------------------------------------------------------------

C  IF STARTING POINT BELOW LOWEST LEVEL THEN DON'T CHECK
      IF ( HLONG(NSTEP) .LE. ZEMIS ) THEN
C  FIND FIRST THE EQUIVALENT LEVELS
        I1 = 0
        I2 = NSTEP
 6001   CONTINUE
        II = (I1+I2)/2
        IF ( HLONG(II) .LT. ZEMIS ) THEN
          I2 = II
        ELSE
          I1 = II
        ENDIF
        IF ( I2-I1 .GT. 1 ) GOTO 6001
C  PHOTONS ENTER THE VERTICAL DISTRIBUTION ONLY IN THE STEP WHERE THEY
C  WERE EMITTED. THIS IS FAR MORE EFFICIENT THAN OLD, INTEGRATED MODE.
        PLONG(I2,9) = PLONG(I2,9) + PHOTCM

      ENDIF
      RETURN
      END
*CMZ :          18/12/2001  11.46.20  by  D. HECK IK FZK KARLSRUHE
*-- Author :     F. SCHROEDER UNI WUPPERTAL     30/06/99
C=======================================================================

      DOUBLE PRECISION FUNCTION DISTIP(THEAP,HEAPP)

C-----------------------------------------------------------------------
C  DIST(ANCE) I(NTER)P(OLATION)
C
C  DETERMINES CHANGE IN DISTANCE FROM SHOWER CORE BY INTERPOLATING
C  BETWEEN VALUES OF A TWO DIMENSIONAL TABLE TAKING INTO ACCOUNT BENDING
C  OF THE CHERENKOV LIGHT IN CURVED ATMOSPHERE.
C  THIS FUNCTION IS CALLED FROM CERENK.
C  ARGUMENTS:
C   THEAP   = COSINE OF EMISSION ANGLE IN DEG OF CHERENKOV PHOTON
C               SEEN FROM THE DETECTOR
C   HEAPP   = EMISSION HEIGHT IN CM OF CHERENKOV PHOTON
C               SEEN FROM THE DETECTOR IN CM
C
C  DESIGN  :  F. SCHROEDER UNI WUPPERTAL
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,CONSTA.
      COMMON /CONSTA/  PI,PI2,OB3,TB3,ENEPER
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER
*KEEP,OBSPAR.
      COMMON /OBSPAR/  OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP,
     *                 THETPR,PHIPR,
     *                 VUECON,
     *                 NOBSLV
      DOUBLE PRECISION OBSLEV(10),THCKOB(10),XOFF(10),YOFF(10),
     *                 HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2)
      DOUBLE PRECISION VUECON(2)
      INTEGER          NOBSLV
*KEEP,RTABLE, IF=CURVED.
      COMMON /RTABLE/  DISTEF, TOF
      INTEGER          MHEIGH,NTHETA
      PARAMETER        ( MHEIGH = 453 ) ! NUMBER OF VALUES IN HEIGHT
      PARAMETER        ( NTHETA = 361 ) ! NUMBER OF VALUES IN THETA
      DOUBLE PRECISION DISTEF(NTHETA,MHEIGH),TOF(NTHETA,MHEIGH)
*KEND.

      DOUBLE PRECISION ADIST,BDIST,B,FACT,HEAPP,HEAPP2,HM,HM1,OBS,
     *                 THEAP,THEAP2,THN,THN1
      INTEGER          M,M1,M2,N,N1,N2
      LOGICAL          FIRST
      SAVE
      DATA             FIRST /.TRUE. /
C-----------------------------------------------------------------------

      IF ( FIRST ) THEN
        FACT  = 90.D0/ACOS(0.D0)
        FIRST = .FALSE.
C  TRANSFORM OBSLEV(1) IN UNITS OF KM
        OBS   = OBSLEV(1) * 1.D-5
      ENDIF

C  TRANSFORM INPUT PARAMETERS IN BETTER UNITS
      THEAP2 = ACOS( THEAP ) * FACT * 4.D0   ! NOW THETA IN DEG*4
      HEAPP2 = HEAPP * 1.D-5 * 4.D0          ! AND HEIGHT IN KM*4

C  DISTIP = DISTIP(THEAP, HEAPP) = DISTEF(N, M) (N*M-MATRIX)
C  MONOTONIC ASCENDING ORDER:
C  THEAP: [0- 90] DEG => THEAP(1) = 0 DEG, THEAP(NTHETA) =  90 DEG
C  HEAPP: [0-113] KM  => HEAPP(1) = 0 KM,  HEAPP(MHEIGH) = 113 KM

C  GET NUMBERS (APPARENT THETA) (N-1,N) WHICH ARE NEAREST TO THEAP
      N2 = INT(THEAP2)
      N1 = N2 + 1
      N  = N2 + 2
C  GET NUMBERS (APPARENT HEIGHT) (M-1,M) WHICH ARE NEAREST TO HEAPP
      M2 = INT(HEAPP2)
      M1 = M2 + 1
      M  = M2 + 2

C  NOW PERFORM LINEAR INTERPOLATION OF DISTEF BETWEEN TABULATED VALUES
C  HEAPP(M) = (M-1) [KM]
C  THEAP(N) = (N-1) [DEG]
      THN  = DBLE(N1)
      THN1 = DBLE(N2)
      HM   = DBLE(M1)
      HM1  = DBLE(M2)
      IF ( HM1 .LT. OBS ) HM1 = OBS

C  INTERPOLATE BETWEEN DISTEF(N-1, M-1) AND DISTEF(N-1,M)
      B     = ( DISTEF(N1, M) - DISTEF(N1, M1) ) / ( HM - HM1 )
      ADIST = B * ( HEAPP2 - HM1 ) + DISTEF(N1,M1)
C  INTERPOLATE BETWEEN DISTEF(N, M-1) AND DISTEF(N,M)
      B     = ( DISTEF(N, M) - DISTEF(N, M1) ) / ( HM - HM1 )
      BDIST = B * ( HEAPP2 - HM1 ) + DISTEF(N,M1)
C  INTERPOLATE BETWEEN ADIST=DISTEF(N-1,M_MEAN)
C                  AND BDIST=DISTEF(N,M_MEAN)
      B      = ( BDIST - ADIST ) / ( THN - THN1 )
      DISTIP = B * ( THEAP2 - THN1 ) + ADIST

      RETURN
      END
*CMZ :          28/02/2002  13.08.20  by  D. HECK IK FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
C=======================================================================

      SUBROUTINE GETBUS( IPARTI,ENERGYP,THETAP,CERSZE )

C-----------------------------------------------------------------------
C  GET BU(NCH) S(IZE)
C
C  CALCULATES OPTIMAL BUNCH SIZE FOR CHERENKOV PHOTONS. CHERENKOV PHOTONS
C  ARE GROUPED IN BUNCHES IN ORDER TO ACCELERATE COMPUTING TIME.
C  HOWEVER, WE SET A MAXIMAL VALUE FOR THE GROUPING OF CHERENKOV PHOTONS
C  SO THAT WE GET AT LEAST 100 BUNCHES/M**2 AT A CHERENKOV FLUX OF 3000
C  PHOTONS/M**2. THIS IS THE MINIMUM CHERENKOV FLUX WHICH CAN BE
C  DISTINGUISHED FROM THE NIGHT SKY LIGHT BACKGROUND IN THE HEGRA
C  EXPERIMENT AT THE ISLAND LA PALMA. SO THE PARAMETRIZATION OF THE
C  CHERENKOV BUNCH AS CALCULATED IN THIS SUBROUTINE IS VALID FOR
C  OBSERVATION LEVELS SIMILAR TO THAT OF THE HEGRA EXPERIMENT.
C     FOR A GIVEN PRIMARY PARTICLE, INCIDENT ENERGY AND ANGLE, AN
C  OPTIMAL BUNCH SIZE IS CALCULATED BY INTERPOLATION IN A TABLE,
C  WHERE WE HAVE CHOSEN AN ENERGY RANGE UP TO 1000 TEV, INCIDENT
C  ANGLES 0 AND 40 DEGREES, AND 4 TYPES OF PRIMARIS: GAMMAS,
C  PROTONS, NITROGEN, AND IRON.
C  THIS SUBROUTINE IS CALLED FROM AAMAIN.
C  ARGUMENTS:
C   IPARTI = TYPE OF PRIMARY PARTICLE
C   ENERGYP= PARTICLES ENERGY IN GEV
C   THETAP = ANGLE IN RAD
C   CERSZE = SIZE OF CHERENKOV BUNCH
C
C  AUTHORS : S. MARTINEZ  UNIVERSITY OF MADRID
C            F. ARQUEROS  UNIVERSITY OF MADRID
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,CONSTA.
      COMMON /CONSTA/  PI,PI2,OB3,TB3,ENEPER
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEND.

      DOUBLE PRECISION ANGLE(2),ENGAM(3),ENHAD(3),ENNIT(2),
     *                 SIFE(3,2),SIGAM(3,2),SINIT(2),SIPRO(3,2)
      DOUBLE PRECISION CERSZE,ENERGY,ENERGYP,THETA,THETAP
      DOUBLE PRECISION CERS1F,CERS1P,S1,S2
      INTEGER          I,IANFE,IANP,IATNUM,IPARTI,I1,I2

      DATA             ANGLE /  0.D0, 40.D0 /
      DATA             ENGAM /  100.D0,  200.D0,  500.D0 /
      DATA             ENHAD /  100.D0,  200.D0,  1000.D0 /
      DATA             ENNIT /  200.D0,  1000.D0 /
      DATA             ( SIFE (I,1),I=1,3 ) /  30.D0,  30.D0,  140.D0 /
      DATA             ( SIFE (I,2),I=1,3 ) /  30.D0,  30.D0,  110.D0 /
      DATA             ( SIGAM(I,1),I=1,3 ) /  30.D0,  45.D0,  100.D0 /
      DATA             ( SIGAM(I,2),I=1,3 ) /  30.D0,  40.D0,  100.D0 /
      DATA             SINIT /  30.D0,  150.D0 /
      DATA             ( SIPRO(I,1),I=1,3 ) /  30.D0,  30.D0,  120.D0 /
      DATA             ( SIPRO(I,2),I=1,3 ) /  30.D0,  30.D0,  160.D0 /
      DATA             IANP   / 1 /, IANFE / 26 /
C-----------------------------------------------------------------------

      IF ( DEBUG ) WRITE(MDEBUG,100) IPARTI,ENERGYP,THETAP
 100  FORMAT(' GETBUS: INPUT PARTICLE = ',I5,1P,2E10.3)

C  DEFAULT VALUE
      CERSZE = 100.D0

      ENERGY = 1.D-3*ENERGYP
      IF ( ENERGY .LE. 100.D0 ) THEN
        CERSZE = 30.D0
        IF ( DEBUG ) WRITE(MDEBUG,101) CERSZE
        RETURN
      ENDIF

      THETA  = THETAP / PI * 180.D0

C-----------------------------------------------------------------------
C  PHOTON, ELECTRON OR POSITRON AS PRIMARY PARTICLE
      IF ( IPARTI .LE. 3 ) THEN
C  FIND ENERGY BIN FOR INTERPOLATION
        IF ( ENERGY .LE. ENGAM(2) ) THEN
          I1 = 1
          I2 = 2
        ELSE
          I1 = 2
          I2 = 3
        ENDIF
        S1 = SIGAM(I1,1) + (ENERGY - ENGAM(I1))
     *       / (ENGAM(I2) - ENGAM(I1))
     *       * (SIGAM(I2,1) - SIGAM(I1,1))
        S2 = SIGAM(I1,2) + (ENERGY - ENGAM(I1))
     *       / (ENGAM(I2) - ENGAM(I1))
     *       * (SIGAM(I2,2) - SIGAM(I1,2))
        CERSZE = S1 + (THETA-ANGLE(1))/(ANGLE(2)-ANGLE(1)) * (S2-S1)
        IF ( DEBUG ) WRITE(MDEBUG,101) CERSZE
        RETURN
      ENDIF

C-----------------------------------------------------------------------
C  NITROGEN AS PRIMARY PARTICLE AND VERTICAL INCIDENCE
CJOK WHY SPECIAL TREATMENT FOR NITROGEN ????
CJOK WHY ONLY VERTICAL INCIDENCE ????
      IF ( IPARTI .EQ. 1407  .AND.  ABS(THETA) .LT. 1.D-1 ) THEN
        IF ( ENERGY .LT. 200.D0 ) THEN
          CERSZE = 30.D0
        ELSE
          CERSZE = SINIT(1) + (ENERGY-ENNIT(1))
     *             / (ENNIT(2)-ENNIT(1)) * (SINIT(2)-SINIT(1))
        ENDIF
        IF ( DEBUG ) WRITE(MDEBUG,101) CERSZE
        RETURN
      ENDIF

C-----------------------------------------------------------------------
C  GET THE ATOMIC NUMBER OF THE NUCLEUS
C  Z IS 1,  IF PROTON
      IF     ( IPARTI .EQ.  14 ) THEN
        IATNUM = 1
C  REST OF POSSIBLE NUCLEI
      ELSEIF ( IPARTI .GT. 100 ) THEN
        IATNUM = MOD(IPARTI,100)
        IF ( IATNUM .GT. 26 ) THEN
          WRITE(MONIOU,*) 'GETBUS: UNEXPECTED PARTICLE CODE',IPARTI
          RETURN
        ENDIF
      ELSE
        WRITE(MONIOU,*) 'GETBUS: UNEXPECTED PARTICLE CODE',IPARTI
        RETURN
      ENDIF

C  FIND ENERGY BIN FOR INTERPOLATION IN CASE OF HADRONIC PRIMARY
      IF ( ENERGY .LE. ENHAD(2) ) THEN
        I1 = 1
        I2 = 2
      ELSE
        I1 = 2
        I2 = 3
      ENDIF

C  INTERPOLATION FOR HADRONS
      S1 = SIPRO(I1,1) + (ENERGY-ENHAD(I1))
     *       / (ENHAD(I2)-ENHAD(I1)) * (SIPRO(I2,1)-SIPRO(I1,1))
      S2 = SIPRO(I1,2) + (ENERGY-ENHAD(I1))
     *       / (ENHAD(I2)-ENHAD(I1)) * (SIPRO(I2,2)-SIPRO(I1,2))
      CERS1P = S1 + (THETA-ANGLE(1)) / (ANGLE(2)-ANGLE(1)) * (S2-S1)

      S1 = SIFE(I1,1) + (ENERGY-ENHAD(I1)) / (ENHAD(I2)-ENHAD(I1))
     *                * (SIFE(I2,1)-SIFE(I1,1))
      S2 = SIFE(I1,2) + (ENERGY-ENHAD(I1)) / (ENHAD(I2)-ENHAD(I1))
     *                * (SIFE(I2,2)-SIFE(I1,2))
      CERS1F = S1 + (THETA-ANGLE(1)) / (ANGLE(2)-ANGLE(1)) * (S2-S1)

      CERSZE = CERS1P + (IATNUM-IANP) * (CERS1F-CERS1P) / (IANFE-IANP)

      IF ( DEBUG ) WRITE(MDEBUG,101) CERSZE
 101  FORMAT(' GETBUS: BUNCH SIZE = ',1P,1E10.3)

      RETURN
      END
*CMZ :          14/09/2000  08.40.31  by  D. HECK IK3 FZK KARLSRUHE
*-- Author :     F. SCHROEDER UNI WUPPERTAL     09/04/99
C=======================================================================

      SUBROUTINE INRTAB

C-----------------------------------------------------------------------
C  IN(IT) R(EFRACTION) TAB(LE)
C
C  INITIALIZES TABLE FOR INTERPOLATION OF DISTANCE FROM SHOWER CORE
C  AND TIME OF FLIGHT OF THE CHERENKOV PHOTON
C  NUMERICAL CALCULATION OF DISTANCE FROM SHOWER CORE AND TIME OF FLIGHT
C  FOR DISCRETE ZENITH ANGLES AND HEIGHT DIFFERENCES TAKING INTO ACCOUNT
C  BENDING OF THE CHERENKOV LIGHT IN A CURVED ATMOSPHERE
C  THIS SUBROUTINE IS CALLED FROM INPRM.
C  ARGUMENTS:
C   OBS    = HEIGHT OF OBSERVATION LEVEL IN CM
C
C  DESIGN  :  F. SCHROEDER UNI WUPPERTAL
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,CONSTA.
      COMMON /CONSTA/  PI,PI2,OB3,TB3,ENEPER
      DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER
*KEEP,OBSPAR.
      COMMON /OBSPAR/  OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP,
     *                 THETPR,PHIPR,
     *                 VUECON,
     *                 NOBSLV
      DOUBLE PRECISION OBSLEV(10),THCKOB(10),XOFF(10),YOFF(10),
     *                 HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2)
      DOUBLE PRECISION VUECON(2)
      INTEGER          NOBSLV
*KEEP,PARPAR.
      COMMON /PARPAR/  CURPAR,SECPAR,PRMPAR,OUTPAR,C,
     *                 E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
      DOUBLE PRECISION CURPAR(16),SECPAR(16),PRMPAR(16),OUTPAR(16),
     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH
      INTEGER          ITYPE,LEVL
*KEEP,RTABLE, IF=CURVED.
      COMMON /RTABLE/  DISTEF, TOF
      INTEGER          MHEIGH,NTHETA
      PARAMETER        ( MHEIGH = 453 ) ! NUMBER OF VALUES IN HEIGHT
      PARAMETER        ( NTHETA = 361 ) ! NUMBER OF VALUES IN THETA
      DOUBLE PRECISION DISTEF(NTHETA,MHEIGH),TOF(NTHETA,MHEIGH)
*KEEP,ATMOSX.
C  EXTERNAL ATMOSPHERIC MODELS
      COMMON /ATMOSX/  IATMOX,FREFRX
      INTEGER          IATMOX
      LOGICAL          FREFRX
*KEND.

      DOUBLE PRECISION DDIST,DHAPP,DHELP,DLEN,DT,ETADSN,HE,HAPPST,HEAPP,
     *                 HST,HSTM,HSTOLD,R,RHE,
     *                 RHST,RHSTM,THEAP,THAPP1,THAPP2,VLIGHTI
      INTEGER          I,M,N,NSTEPS
      SAVE
      DOUBLE PRECISION REFIDX
      EXTERNAL         REFIDX
      DOUBLE PRECISION RHOF
      EXTERNAL         RHOF
C NUMBER OF STEPS FOR NUMERIC INTEGRATION
      DATA             NSTEPS/ 1000 /
C-----------------------------------------------------------------------

      ETADSN  = 0.00028232D0 / RHOF(0.D0)
C  INVERSE OF VELOCITY OF LIGHT IN CM/NS
      VLIGHTI = 1.D9/C(25)
C  EARTH RADIUS IN CM
      R       = C(1)
C  DISTEF = DISTEF(THEAP, HEAPP) = DISTEF(N, M) (N*M-MATRIX)
C  TOF = TOF(THEAP, HEAPP) = TOF(N, M) (N*M-MATRIX)
C  MONOTONIC ASCENDING ORDER:
C  THEAP: [0- 90] DEG => THEAP(1) = 0 DEG, THEAP(NTHETA) =  90 DEG
C  HEAPP: [0-113] KM  => HEAPP(1) = 0 KM,  HEAPP(MHEIGH) = 113 KM
C  THEAP = EMISSION ANGLE OF CHERENKOV PHOTON SEEN FROM THE DETECTOR
C  HEAPP = EMISSION HEIGHT OF CHERENKOV PHOTON SEEN FROM THE DETECTOR

      DO   N = 1, NTHETA
        DO   M = 1, MHEIGH
C  APPARENT EMISSION ANGLE IN RAD * 1/4
          THEAP = DBLE(N-1) * .25D0 * PI / 180.D0
C  APPARENT EMISSION HEIGHT IN CM * 1/4
          HEAPP = DBLE(M-1) * .25D0 * 1.D5
          IF ( HEAPP .LE. OBSLEV(1)  .OR.
     *         THEAP .GT. 89.0D0*PI/180.D0 ) THEN
            DISTEF(N,M) = 0.D0     ! NO CALCULATION OF DISTEF AND TOF
            TOF(N, M)   = 0.D0     ! IF EMISSION HEIGHT IS UNDER
            GOTO 100               ! OBSERVATION LEVEL
          ENDIF
C  LOCAL EMISSION HEIGHT FOR INDEX OF REFRACTION
          DHELP = (HEAPP-OBSLEV(1)) * TAN(THEAP)
          HE    = -R + SQRT( DHELP**2 + (R+HEAPP)**2 )
          IF ( IATMOX .GE. 1 ) THEN
            RHE = REFIDX( HE )
          ELSE
            RHE = 1.D0 + ETADSN * RHOF(HE)
          ENDIF
C  SMALL CHANGE IN HEAPP FOR NUMERICAL INTEGRATION
          DHAPP = (HEAPP-OBSLEV(1))/DBLE(NSTEPS)
C  START VALUES FOR NUMERICAL INTEGRATION
C  PERFORM CALCULATION IN APPARENT COORDINATES + LOCAL HEIGHT
C  FOR THE INDEX OF REFRACTION
          HST         = HE
          HAPPST      = HEAPP
          THAPP2      = THEAP
          DISTEF(N,M) = 0.D0
          TOF(N, M)   = 0.D0
          DO   I = 1, NSTEPS
            HAPPST = HAPPST - DHAPP
            DHELP  = (HAPPST-OBSLEV(1)) * TAN(THAPP2)
            HSTOLD = HST
            HST    = -R + SQRT( DHELP**2 + (R+HAPPST)**2 )
            HSTM   = HST + 0.5D0 * (HSTOLD-HST)
            IF ( IATMOX .GE. 1 ) THEN
              RHST  = REFIDX( HST )
              RHSTM = REFIDX( HSTM )
            ELSE
              RHST  = 1.D0 + ETADSN * RHOF(HST)
              RHSTM = 1.D0 + ETADSN * RHOF(HSTM)
            ENDIF
            THAPP1 = THAPP2
            THAPP2 = ASIN(  RHE/RHST * SIN(THEAP) )
            DDIST  = DHAPP * TAN(0.5D0*(THAPP1 + THAPP2))
            DLEN   = DHAPP / COS(0.5D0*(THAPP1 + THAPP2))
            DT     = DLEN * RHSTM * VLIGHTI
            DISTEF(N, M) = DISTEF(N,M) + DDIST
            TOF(N, M)    = TOF(N, M) + DT
          ENDDO
 100      CONTINUE
        ENDDO
      ENDDO

      RETURN
      END
*CMZ :          18/10/2000  09.15.12  by  D. HECK IK3 FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
C=======================================================================

      SUBROUTINE OUTND2

C-----------------------------------------------------------------------
C  OUT(PUT AT E)ND (OF SHOWER)
C
C  WRITE REST OF PARTICLES TO OUTPUT BUFFER
C  THIS SUBROUTINE IS CALLED FROM AAMAIN.
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEEP,CEREN2.
      COMMON /CEREN2/  ACERX,ACERY,CERXOS,CERYOS,
     *                 DCERX,DCERXI,DCERY,DCERYI,EPSX,EPSY,FCERX,FCERY,
     *                 WL,XCMAX,XCMAXS,XSCATT,YCMAX,YCMAXS,YSCATT,
     *                 PHOTCM,XCER,YCER,UEMIS,VEMIS,WEMIS,CARTIM,ZEMIS,
     *                 NCERX,NCERY,ICERML
      DOUBLE PRECISION ACERX,ACERY,CERXOS(20),CERYOS(20),
     *                 DCERX,DCERXI,DCERY,DCERYI,EPSX,EPSY,FCERX,FCERY,
     *                 WL,XCMAX,XCMAXS,XSCATT,YCMAX,YCMAXS,YSCATT
      DOUBLE PRECISION PHOTCM,XCER,YCER,UEMIS,VEMIS,WEMIS,CARTIM,ZEMIS
      INTEGER          NCERX,NCERY,ICERML
*KEEP,CEREN3.
      COMMON /CEREN3/  CERCNT,DATAB2,NRECER,LHCER
      INTEGER          MAXBF2
      PARAMETER        ( MAXBF2 = 39 * 7 )
      DOUBLE PRECISION CERCNT
      REAL             DATAB2(MAXBF2)
      INTEGER          NRECER,LHCER
*KEND.

      INTEGER          I
C-----------------------------------------------------------------------

      IF ( LHCER .GT. 0 ) THEN
        IF ( FPAROUT ) CALL TOBUFC( DATAB2,0 )
C  CLEAR DATAB2 BUFFER
        DO  2  I = 1,MAXBF2
          DATAB2(I) = 0.
    2   CONTINUE
      ENDIF
      LHCER  = 0

      WRITE(MONIOU,*) 'CERCNT = ',SNGL( CERCNT )
      CERCNT = 0.D0

      RETURN
      END
*CMZ :          28/02/2002  12.41.48  by  D. HECK IK FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
C=======================================================================

       SUBROUTINE OUTPT2(J,IMOV)
c---changed--name  

C-----------------------------------------------------------------------
C  (WRITE CHERENKOV RADIATION) OUTP(U)T
C
C  OUTPUT SUBROUT. FOR CHERENKOV PHOTONS
C  THIS SUBROUTINE IS CALLED FROM CERENK.
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,BUFFS.
      COMMON /BUFFS/   RUNH,RUNE,EVTH,EVTE,DATAB,ARRAYLONG,LH
      INTEGER          MAXBUF,MAXLEN
      PARAMETER        (MAXLEN=16)
      PARAMETER        (MAXBUF=39*7)
      REAL             RUNH(MAXBUF),EVTH(MAXBUF),EVTE(MAXBUF),
     *                 RUNE(MAXBUF),DATAB(MAXBUF),ARRAYLONG(MAXBUF)
      INTEGER          LH
      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)
*KEEP,EGSDEB.
      COMMON /EGSDEB/  JCLOCK,NCLOCK,FEGSDB
      INTEGER          JCLOCK,NCLOCK
      LOGICAL          FEGSDB
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEEP,CEREN1.
      COMMON /CEREN1/  CERELE,CERHAD,ETADSN,WAVLGL,WAVLGU,CYIELD,
     *                 CERSIZ,CERNOR,LCERFI
      DOUBLE PRECISION CERELE,CERHAD,ETADSN,WAVLGL,WAVLGU,CYIELD,
     *                 CERSIZ,CERNOR
      LOGICAL          LCERFI
*KEEP,CEREN2.
      COMMON /CEREN2/  ACERX,ACERY,CERXOS,CERYOS,
     *                 DCERX,DCERXI,DCERY,DCERYI,EPSX,EPSY,FCERX,FCERY,
     *                 WL,XCMAX,XCMAXS,XSCATT,YCMAX,YCMAXS,YSCATT,
     *                 PHOTCM,XCER,YCER,UEMIS,VEMIS,WEMIS,CARTIM,ZEMIS,
     *                 NCERX,NCERY,ICERML
      DOUBLE PRECISION ACERX,ACERY,CERXOS(20),CERYOS(20),
     *                 DCERX,DCERXI,DCERY,DCERYI,EPSX,EPSY,FCERX,FCERY,
     *                 WL,XCMAX,XCMAXS,XSCATT,YCMAX,YCMAXS,YSCATT
      DOUBLE PRECISION PHOTCM,XCER,YCER,UEMIS,VEMIS,WEMIS,CARTIM,ZEMIS
      INTEGER          NCERX,NCERY,ICERML
*KEEP,CEREN3.
      COMMON /CEREN3/  CERCNT,DATAB2,NRECER,LHCER
      INTEGER          MAXBF2
      PARAMETER        ( MAXBF2 = 39 * 7 )
      DOUBLE PRECISION CERCNT
      REAL             DATAB2(MAXBF2)
      INTEGER          NRECER,LHCER
*KEND.
c-----changed-add 
c>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
      COMMON /GRAAL1/  WAVELENGTH ! (NM)
      REAL WAVELENGTH
c>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
*KEND.

      INTEGER J,IMOV
cxx-------------------- 
c>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
c-----changed-add 

      INTEGER          I
      LOGICAL          ROUT
      SAVE
C-----------------------------------------------------------------------

      IF ( FEGSDB ) WRITE(MDEBUG,3)
     *                  PHOTCM,XCER,YCER,UEMIS,VEMIS,CARTIM,ZEMIS
  3   FORMAT(' OUTPT2: ',1P,8E10.3)
      ROUT = .TRUE.

C  WRITE A BLOCK OF 39 PARTICLES TO THE CHERENKOV OUTPUT BUFFER AND
C  CLEAR FIELD
      CERCNT = CERCNT + PHOTCM
      IF ( LCERFI ) THEN
        IF ( ROUT ) THEN
c------changed--add -adn comand
c>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
c        DATAB2(LHCER+1) = PHOTCM
cc        DATAB2(LHCER+1) = WAVELENGTH + J*1000.
        DATAB2(LHCER+1) = J*100000. + IMOV*1000. + WAVELENGTH
c>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
c------changed--add -adn comand
          DATAB2(LHCER+2) = XCER
          DATAB2(LHCER+3) = YCER
          DATAB2(LHCER+4) = UEMIS
          DATAB2(LHCER+5) = VEMIS
          DATAB2(LHCER+6) = CARTIM
          DATAB2(LHCER+7) = ZEMIS
          LHCER = LHCER + 7
          IF ( LHCER .GE. MAXBF2 ) THEN
            IF ( FPAROUT ) CALL TOBUFC( DATAB2,0 )
            DO  1  I = 1,MAXBF2
              DATAB2(I) = 0.
    1       CONTINUE
            LHCER = 0
          ENDIF
        ENDIF
      ELSE
C  WRITE A BLOCK OF 39 PARTICLES TO THE PARTICLE OUTPUT BUFFER AND
C  CLEAR FIELD
        IF ( ROUT ) THEN
          DATAB(LH+1) = 99.E5 + NINT(PHOTCM)*10. + 1.
          DATAB(LH+2) = XCER
          DATAB(LH+3) = YCER
          DATAB(LH+4) = UEMIS
          DATAB(LH+5) = VEMIS
          DATAB(LH+6) = CARTIM
          DATAB(LH+7) = ZEMIS
          LH     = LH + 7
          NOPART = NOPART + 1
          IF ( LH .GE. MAXBUF ) THEN
            IF ( FPAROUT ) CALL TOBUF( DATAB,0 )
            DO  2  I = 1,MAXBUF
              DATAB(I) = 0.
    2       CONTINUE
            LH = 0
          ENDIF
        ENDIF
      ENDIF

      RETURN
      END
*CMZ :          25/04/2001  09.21.09  by  D. HECK IK FZK KARLSRUHE
*-- Author :    The CORSIKA development group   06/10/95
C=======================================================================

      SUBROUTINE SELCOR(XX,YY)

C-----------------------------------------------------------------------
C  SEL(ECT) COR(E LOCATION)
C
C  SELECT A QUASI RANDOM CORE LOCATION
C  THIS SUBROUTINE IS CALLED FROM INPRM.
C  ARGUMENTS:
C   XX     = X-VALUE OF QUASI-RANDOM CORE LOCATION
C   YY     = Y-VALUE OF QUASI-RANDOM CORE LOCATION
C
C  DESIGN  : J. KNAPP   IK1  FZK KARLSRUHE
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,CEREN2.
      COMMON /CEREN2/  ACERX,ACERY,CERXOS,CERYOS,
     *                 DCERX,DCERXI,DCERY,DCERYI,EPSX,EPSY,FCERX,FCERY,
     *                 WL,XCMAX,XCMAXS,XSCATT,YCMAX,YCMAXS,YSCATT,
     *                 PHOTCM,XCER,YCER,UEMIS,VEMIS,WEMIS,CARTIM,ZEMIS,
     *                 NCERX,NCERY,ICERML
      DOUBLE PRECISION ACERX,ACERY,CERXOS(20),CERYOS(20),
     *                 DCERX,DCERXI,DCERY,DCERYI,EPSX,EPSY,FCERX,FCERY,
     *                 WL,XCMAX,XCMAXS,XSCATT,YCMAX,YCMAXS,YSCATT
      DOUBLE PRECISION PHOTCM,XCER,YCER,UEMIS,VEMIS,WEMIS,CARTIM,ZEMIS
      INTEGER          NCERX,NCERY,ICERML
*KEEP,RANDPA.
      COMMON /RANDPA/  FAC,U1,U2,RD,NSEQ,ISEED,KNOR
      DOUBLE PRECISION FAC,U1,U2
      REAL             RD(3000)
      INTEGER          ISEED(103,10),NSEQ
      LOGICAL          KNOR
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEND.

      DOUBLE PRECISION RND(2),XX,YY
      INTEGER          I
      LOGICAL          FIRST
      SAVE
      DATA             FIRST /.TRUE./
C-----------------------------------------------------------------------

      IF ( DEBUG ) WRITE(MDEBUG,*) 'SELCOR:'

C  INITIALIZE SOBOL NUMBER GENERATOR
      IF ( FIRST ) THEN
        FIRST = .FALSE.
        CALL SOBSEQ(-2,RND)
C  CALL THE RANDOM GENERATOR MANY TIMES ACCORDING SEED OF THIRD SEQUENCE
C  TO PREVENT STARTING WITH IDENTICAL NUMBER FOR DIFFERENT RUNS
        DO  I = 1,ISEED(1,3)
          CALL SOBSEQ(1,RND)
        ENDDO
      ENDIF
C  TAKE A PAIR OF QUASI RANDOM NUMBERS
      CALL SOBSEQ(2,RND)
c--------change
      XX = ySCATT * (2.D0*RND(1)-1.D0)
      YY = YSCATT * (2.D0*RND(2)-1.D0)

      IF (DEBUG) WRITE(MDEBUG,*) 'SELCOR: CORE LOCATION X=',XX,' Y=',YY
      RETURN
      END
*CMZ :          25/04/2001  09.21.09  by  D. HECK IK FZK KARLSRUHE
*-- Author :    The CORSIKA development group   06/10/95
C=======================================================================

      SUBROUTINE SOBSEQ(N,XX)

C-----------------------------------------------------------------------
C  SOB(OL) SEQ(UENCE)
C
C  SOBOL QUASI RANDOM NUMBER GENERATOR
C  REFERENCE : NUMERICAL RECIPES, W.H. PRESS ET AL.,
C              CAMBRIDGE UNIVERSITY PRESS, 1992  ISBN 0 521 43064 X
C  THIS SUBROUTINE IS CALLED FROM SELCOR.
C  ARGUMENTS:
C   N      = NUMBER OF QUASI-RANDOM NUMBERS
C   XX     = ARRAY CONTAINING THE RANDOM NUMBERS
C
C  THIS ROUTINE USES `LOGICAL AND' AND `EXCLUSIVE OR' SYSTEM FUNCTIONS
C  `IAND' AND `IEOR' WHICH ARE NON-STANDARD FORTRAN FUNCTIONS !!
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEND.

      DOUBLE PRECISION XX(*),FAC
      INTEGER          N,MAXBIT,MAXDIM
      PARAMETER        ( MAXBIT = 30, MAXDIM = 6 )
      INTEGER          I,IM,IN,IPP,J,K,L,IP(MAXDIM),IU(MAXDIM,MAXBIT),
     *                 IV(MAXBIT*MAXDIM),IX(MAXDIM),MDEG(MAXDIM)
      EQUIVALENCE      (IV,IU)
      SAVE
      DATA             IP /0,1,1,2,1,4/, MDEG /1,2,3,3,4,4/, IX /6*0/,
     *                 IV /6*1,3,1,3,3,1,1,5,7,7,3,3,5,15,11,5,15,13,9,
     *                     156*0/
C-----------------------------------------------------------------------

      IF ( N .LT. 0 ) THEN
        DO 14  K = 1,MAXDIM
          DO 11  J = 1,MDEG(K)
            IU(K,J) = IU(K,J)*2**(MAXBIT-J)
 11       CONTINUE
          DO 13  J = MDEG(K)+1,MAXBIT
            IPP = IP(K)
            I   = IU(K,J-MDEG(K))
C  IEOR IS A NON-STANDARD FORTRAN SYSTEM FUNCTION MAKING `EXCLUSIVE OR'
            I   = IEOR(I,I/2**MDEG(K))
            DO 12  L = MDEG(K)-1,1,-1
C  IAND IS A NON-STANDARD FORTRAN SYSTEM FUNCTION MAKING `LOGICAL AND'
              IF ( IAND(IPP,1) .NE. 0 ) I = IEOR(I,IU(K,J-L))
              IPP = IPP/2
 12         CONTINUE
            IU(K,J) = I
 13       CONTINUE
 14     CONTINUE
        FAC = 1.D0/(2.D0**MAXBIT)
        IN  = 0
      ELSE
        IM  = IN
        DO 15  J = 1,MAXBIT
C  IAND IS A NON-STANDARD FORTRAN SYSTEM FUNCTION MAKING `LOGICAL AND'
          IF ( IAND(IM,1) .EQ. 0 ) GOTO 1
          IM = IM/2
 15     CONTINUE
        WRITE(MONIOU,*)'MAXBIT =',MAXBIT,' TOO SMALL IN SOBSEQ'
        STOP
 1      IM = (J-1)*MAXDIM
        DO 16  K = 1,MIN(N,MAXDIM)
C  IEOR IS A NON-STANDARD FORTRAN SYSTEM FUNCTION MAKING `EXCLUSIVE OR'
          IX(K) = IEOR(IX(K),IV(IM+K))
          XX(K)  = IX(K)*FAC
 16     CONTINUE
        IN = IN+1
      ENDIF
      RETURN
      END
*CMZ :          30/01/2001  17.27.18  by  D. HECK IK FZK KARLSRUHE
*-- Author :    The CORSIKA development group   21/04/94
C=======================================================================

      SUBROUTINE TOBUFC( A,IFL )

C-----------------------------------------------------------------------
C  (WRITE) TO BUF(FER) C(HERENKOV DATA)
C
C  COPY TO BUFFER CHERENKOV DATA
C  THIS SUBROUTINE IS CALLED FROM AAMAIN, INPRM, ELECTR, PHOTON, OUTND2,
C  AND OUTPT2.
C  ARGUMENTS:
C   A      = ARRAY TO BE WRITTEN TO TAPE
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
*KEEP,BUFFS.
      COMMON /BUFFS/   RUNH,RUNE,EVTH,EVTE,DATAB,ARRAYLONG,LH
      INTEGER          MAXBUF,MAXLEN
      PARAMETER        (MAXLEN=16)
      PARAMETER        (MAXBUF=39*7)
      REAL             RUNH(MAXBUF),EVTH(MAXBUF),EVTE(MAXBUF),
     *                 RUNE(MAXBUF),DATAB(MAXBUF),ARRAYLONG(MAXBUF)
      INTEGER          LH
      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)
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,
     *                 STEPFC,NRRUN,NSHOW,MPATAP,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,MTABOUT,MLONGOUT,
     *                 MCETAP,
     *                 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
      COMMON /RUNPAC/  DSN,DSNTAB,DSNLONG,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB,SIG1I,TARG1I,STEPFC
      INTEGER          NRRUN,NSHOW,MPATAP,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 ISHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,MTABOUT,MLONGOUT
      INTEGER          MCETAP
      CHARACTER*79     DSN,DSNTAB,DSNLONG
      CHARACTER*20     HOST,USER
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE,FPAROUT,FTABOUT,
     *                 FLONGOUT,GHEISH,GHESIG,GHEISDB,USELOW,TMARGIN
*KEEP,CEREN3.
      COMMON /CEREN3/  CERCNT,DATAB2,NRECER,LHCER
      INTEGER          MAXBF2
      PARAMETER        ( MAXBF2 = 39 * 7 )
      DOUBLE PRECISION CERCNT
      REAL             DATAB2(MAXBF2)
      INTEGER          NRECER,LHCER
*KEND.

C  NSUBBL IS NUMBER OF SUBBLOCKS IN ONE OUTPUT RECORD
      INTEGER          NSUBBL
      PARAMETER        ( NSUBBL = 21 )
      REAL             A(*)
C  (OUTPUT RECORD LENGTH = NSUBBL * 39 * 7 * 4 BYTES  <= 22932 )
C  OUTPUT BUFFER FOR CHERENKOV OUTPUT
      REAL             OUTBF2(MAXBF2,NSUBBL)
C  IBLK2 IS COUNTER FOR SUBBLOCKS OF CHERENKOV OUTPUT
      INTEGER          I,IBLK2,IFL,K
      SAVE
      DATA             IBLK2 / 0 /
C-----------------------------------------------------------------------

      IF ( IFL .LE. 1 ) THEN
        IBLK2 = IBLK2 + 1
        DO  3  I = 1,MAXBF2
          OUTBF2(I,IBLK2) = A(I)
    3   CONTINUE
      ENDIF

C  WRITE TO TAPE IF BLOCK IS FULL OR IF IFL IS 1
      IF ( IFL .GE. 1  .OR.  IBLK2 .EQ. NSUBBL ) THEN
        NRECER = NRECER + 1
c-----changed---add------command
cxx        WRITE(MCETAP) ((OUTBF2(I,K),I=1,MAXBF2),K=1,NSUBBL)
c>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
c        WRITE(CETAPE)            ((OUTBF2(I,K),I=1,MAXBF2),K=1,NSUBBL)
        call jccersave(outbf2)
c>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
c-----changed---add------command
        IBLK2 = 0
        DO  4  K = 1,NSUBBL
        DO  4  I = 1,MAXBF2
          OUTBF2(I,K) = 0.0
   4    CONTINUE
      ENDIF

      RETURN
      END
*CMZ :          14/06/2000  14.14.41  by  D. HECK IK3 FZK KARLSRUHE
*-- Author :    F. SCHROEDER UNI WUPPERTAL      01/07/99
C=======================================================================

      DOUBLE PRECISION FUNCTION TOFIP(THEAP,HEAPP)

C-----------------------------------------------------------------------
C  T(IME) O(F) F(LIGHT) I(NTER)P(OLATION)
C
C  DETERMINES TIME OF FLIGHT OF CHERENKOV PHOTON BY INTERPOLATING
C  BETWEEN VALUES OF A TWO DIMENSIONAL TABLE TAKING INTO ACCOUNT
C  BENDING OF THE CHERENKOV LIGHT IN A CURVED ATMOSPHERE
C  THIS SUBROUTINE IS CALLED FROM CERENK.
C  ARGUMENTS:
C   THEAP  = COSINE OF EMISSION ANGLE OF CHERENKOV PHOTON
C               SEEN FROM THE DETECTOR
C   HEAPP  = EMISSION HEIGHT IN CM OF CHERENKOV PHOTON
C               SEEN FROM THE DETECTOR
C
C  DESIGN  :  F. SCHROEDER UNI WUPPERTAL
C-----------------------------------------------------------------------

      IMPLICIT NONE
*KEEP,OBSPAR.
      COMMON /OBSPAR/  OBSLEV,THCKOB,XOFF,YOFF,HEIGHP,THETAP,PHIP,
     *                 THETPR,PHIPR,
     *                 VUECON,
     *                 NOBSLV
      DOUBLE PRECISION OBSLEV(10),THCKOB(10),XOFF(10),YOFF(10),
     *                 HEIGHP,THETAP,THETPR(2),PHIP,PHIPR(2)
      DOUBLE PRECISION VUECON(2)
      INTEGER          NOBSLV
*KEEP,RTABLE, IF=CURVED.
      COMMON /RTABLE/  DISTEF, TOF
      INTEGER          MHEIGH,NTHETA
      PARAMETER        ( MHEIGH = 453 ) ! NUMBER OF VALUES IN HEIGHT
      PARAMETER        ( NTHETA = 361 ) ! NUMBER OF VALUES IN THETA
      DOUBLE PRECISION DISTEF(NTHETA,MHEIGH),TOF(NTHETA,MHEIGH)
*KEND.

      DOUBLE PRECISION ATOF,BTOF,B,FACT,HEAPP,HEAPP2,HM,HM1,OBS,
     *                 THEAP,THEAP2,THN,THN1
      INTEGER          M,M1,M2,N,N1,N2
      LOGICAL          FIRST
      SAVE
      DATA             FIRST /.TRUE. /
C-----------------------------------------------------------------------

      IF ( FIRST ) THEN
        FACT  = 90.D0/ACOS(0.D0)
        FIRST = .FALSE.
C  TRANSFORM ALSO OBSLEV(1) IN UNITS OF KM
        OBS   = OBSLEV(1) * 1.D-5
      ENDIF
C  TRANSFORM INPUT PARAMETERS IN BETTER UNITS
      THEAP2 = ACOS( THEAP ) * FACT * 4.D0   ! NOW THETA IN DEG*4
      HEAPP2 = HEAPP * 1.D-5  * 4.D0         ! AND HEIGHT IN KM*4

C  TOF = TOF(THEAP, HEAPP) = TOF(N, M) (N*M-MATRIX)
C  MONOTONIC ASCENDING ORDER:
C  THEAP: [0- 90] DEG => THEAP(1) = 0 DEG, THEAP(NTHETA) =  90 DEG
C  HEAPP: [0-113] KM  => HEAPP(1) = 0 KM,  HEAPP(MHEIGH) = 113 KM

C  GET NUMBERS (APPARENT THETA) (N-1,N) WHICH ARE NEAREST TO THEAP
      N2 = INT(THEAP2)
      N1 = N2 + 1
      N  = N2 + 2
C  GET NUMBERS (APPARENT HEIGHT) (M-1,M) WHICH ARE NEAREST TO HEAPP
      M2 = INT(HEAPP2)
      M1 = M2 + 1
      M  = M2 + 2
C  NOW PERFORM LINEAR INTERPOLATION OF TOF BETWEEN TABULATED VALUES
C  HEAPP(M) = (M-1) [KM]
C  THEAP(N) = (N-1) [DEG]
      THN  = DBLE(N1)
      THN1 = DBLE(N2)
      HM   = DBLE(M1)
      HM1  = DBLE(M2)
      IF ( HM1 .LT. OBS ) HM1 = OBS

C  INTERPOLATE BETWEEN TOF(N-1, M-1) AND TOF(N-1,M)
      B    = ( TOF(N1, M) - TOF(N1, M1) ) / ( HM - HM1 )
      ATOF = B * ( HEAPP2 - HM1 ) + TOF(N1,M1)
C  INTERPOLATE BETWEEN TOF(N, M-1) AND TOF(N,M)
      B    = ( TOF(N, M) - TOF(N, M1) ) / ( HM - HM1 )
      BTOF = B * ( HEAPP2 - HM1 ) + TOF(N,M1)
C  INTERPOLATE BETWEEN ATOF = TOF(N-1,M_MEAN)
C                  AND BTOF = TOF(N,M_MEAN)
      B    = ( BTOF - ATOF ) / ( THN - THN1 )
      TOFIP = B * ( THEAP2 - THN1 ) + ATOF

      RETURN
      END
