      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,CONST.
      COMMON /CONST/   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(37),ELMEAA(37)
      INTEGER          IELDPM(37,13),IELDPA(37,13)
*KEEP,ELASTY.
      COMMON /ELASTY/  ELAST,IELIS,IELHM,IELNU,IELPI
      DOUBLE PRECISION ELAST
      INTEGER          IELIS(20),IELHM(20),IELNU(20),IELPI(20)
*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,MULT.
      COMMON /MULT/    EKINL,MSMM,MULTMA,MULTOT
      DOUBLE PRECISION EKINL
      INTEGER          MSMM,MULTMA(37,13),MULTOT(37,13)
*KEEP,PAM.
      COMMON /PAM/     PAMA,SIGNUM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000)
*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
*KEEP,PARPAE.
      DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM
      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 )
*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,
     *                 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
*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,GAMMAX,COSTET,PHIV,PL2,PT2,PTM
      DOUBLE PRECISION PFRX(60),PFRY(60)
      INTEGER          ITYP(60),NRPTLA(MXPTL)
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.
 
      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
C  SET COORDINATES, WHICH ARE IDENTICAL FOR ALL SECONDARY PARTICLES
      DO  6 I=5,8
        SECPAR(I) = CURPAR(I)
 6    CONTINUE
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 ( 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 5
        ELSEIF ( KODVEN .EQ.   -11 ) THEN
          GOTO 5
        ELSEIF ( KODVEN .EQ.    13 ) THEN
          GOTO 5
        ELSEIF ( KODVEN .EQ.   -13 ) THEN
          GOTO 5
        ELSE
          WRITE(MONIOU,*)'VSTORE: UNKNOWN PARTICLE CODE IDPTL=',IDPTL(I)
          GOTO 5
        ENDIF
        SECPAR(1) = KODCRS
 
        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 / 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(1,I)), DBLE(PPTL(2,I)) )
        ELSE
          PHIV = 0.D0
        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
        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
 
 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
            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  )), 37.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
        ELAST  = ELASTI
        FIRSTI = .FALSE.
      ENDIF
 
      RETURN
      END
