SUBROUTINE MPPROP
C
C*********************************************************************
C  DESIGN  : D. HECK   IK3  FZK KARLSRUHE
C  DATE    : JUL  14, 1989
C*********************************************************************
C  SUBROUTINE MOVES MUONS AND PIONS FROM EGS-STACK TO CORSIKA-STACK.
C*********************************************************************
      DOUBLE PRECISION AMASS
C     DOUBLE PRECISION CUT
*KEEP,ELABCT.
      COMMON /ELABCT/  ELCUT
      DOUBLE PRECISION ELCUT(4)
*KEND.
      DOUBLE PRECISION PRRMMU
      COMMON/MUON/PRRMMU,RMMU,RMMUT2
*KEEP,PARPAR.
      COMMON /PARPAR/  CURPAR,SECPAR,PRMPAR,OUTPAR,C,
     *                 E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
      DOUBLE PRECISION CURPAR(14),SECPAR(14),PRMPAR(14),OUTPAR(14),
     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH
      INTEGER          ITYPE,LEVL
*KEND.
      DOUBLE PRECISION PI0MSQ
      COMMON/PION/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,
     *                 STEPFC,NRRUN,NSHOW,PATAPE,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,
     *                 CETAPE,
     *                 SHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,
     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE
     *                ,GHEISH,GHESIG
      COMMON /RUNPAC/  DSN,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB
      REAL             STEPFC
      INTEGER          NRRUN,NSHOW,PATAPE,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 SHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE
      INTEGER          CETAPE
      CHARACTER*79     DSN
      CHARACTER*20     HOST,USER
 
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE
     *                ,GHEISH,GHESIG
*KEEP,STACKE.
      COMMON/STACKE/   E,TIME,X,Y,Z,U,V,W,DNEAR,IQ,IGEN,IR,IOBS,LPCTE,NP
      DOUBLE PRECISION E(60),TIME(60)
      REAL             X(60),Y(60),Z(60),U(60),V(60),W(60),DNEAR(60)
      INTEGER          IQ(60),IGEN(60),IR(60),IOBS(60),LPCTE(60),NP
*KEND.
      COMMON/UPHIOT/THETA,SINTHE,COSTHE,SINPHI, COSPHI,PI,TWOPI,PI5D2
      COMMON/ACLOCK/NCLOCK,JCLOCK
C_____IF (NCLOCK.GT.JCLOCK) THEN
C______WRITE(MDEBUG,* )' MPPROP:NP=',NP,' IR=',IR(NP),' IOBS=',IOBS(NP)
C______CALL AUSGB2
C_____END IF
C***  SET MASS AND CUT PARAMETER OF PARTICLE UNDER CONSIDERATION
      IF (IQ(NP).LT.7) THEN
       AMASS=PRRMMU
C      CUT=ELCUT(2)*1000.D0
      ELSEIF(IQ(NP).EQ.7) THEN
       AMASS=PI0MAS
C      CUT=ELCUT(1)*1000.D0
       POLART=1.D0
       POLARF=0.D0
      ELSE
       AMASS=PICMAS
C      CUT=ELCUT(1)*1000.D0
       POLART=1.D0
       POLARF=0.D0
      END IF
C***  USE PARTICLE ONLY IF ABOVE CUT AND INSIDE ACCEPTANCE CONE
C     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)**2+V(NP)**2.GT.3.E-38) THEN
        ANGLEX = -ATAN2(V(NP),U(NP))
       ELSE
        ANGLEX = 0.
       END IF
C ***  FILL MUON/PION COORDINATES INTO CORSIKA-STACK
       SECPAR(1)=IQ(NP)
       SECPAR(2)=E(NP)/AMASS
       SECPAR(3)=W(NP)
       SECPAR(4)=ANGLEX
       SECPAR(5)=-Z(NP)
       SECPAR(6)=TIME(NP)
       SECPAR(7)=X(NP)
       SECPAR(8)=-Y(NP)
       SECPAR(9)=IGEN(NP)
       SECPAR(10)=-Z(NP)
       SECPAR(11)=POLART
       SECPAR(12)=POLARF
C ***  ADD MUON/PION TO CORSIKA-STACK
       CALL TSTOUT
      END IF
C***  ELIMINATE MUON/PION FROM EGS-STACK
      POLART=-POLART
      POLARF=POLARF+PI
      NP=NP-1
      RETURN
      END