*$ CREATE STUPRE.FOR
*COPY STUPRE
*
*=== stupre ===========================================================*
*
      SUBROUTINE STUPRE

      INCLUDE '(DBLPRC)'
      INCLUDE '(DIMPAR)'
      INCLUDE '(IOUNIT)'
*
*----------------------------------------------------------------------*
*                                                                      *
*     Copyright (C) 1997-2005      by    Alfredo Ferrari & Paola Sala  *
*     All Rights Reserved.                                             *
*                                                                      *
*                                                                      *
*     SeT User PRoperties for Emf particles:                           *
*                                                                      *
*     Created on  09 october 1997  by    Alfredo Ferrari & Paola Sala  *
*                                                   Infn - Milan       *
*                                                                      *
*     Last change on  14-aug-99    by    Alfredo Ferrari               *
*                                                                      *
*     Useful variables:                                                *
*                                                                      *
*           Npstrt = EMF stack index before the interaction (since     *
*                    the projectile disappears it is also the start-   *
*                    ing index of secondaries)                         *
*                                                                      *
*     On contrary of Stuprf, the region/position etc are               *
*     already set inside the stack arrays                              *
*                                                                      *
*                                                                      *
*----------------------------------------------------------------------*
*
      INCLUDE '(EMFSTK)'
      INCLUDE '(EVTFLG)'
*   we need this
      INCLUDE '(PAPROP)'
      INCLUDE '(EMFSWT)'
      INCLUDE '(TRACKR)'
      include '(CASLIM)'
*
      LOGICAL LBHABH
*
      COMMON /FOLLOW/  THRESH, NPHOT, ICINT
*
      IF ( LDLTRY ) THEN
         LBHABH = ICHEMF (NPEMF) * ICHEMF (NPEMF-1) .LT. 0
      ELSE
         LBHABH = .FALSE.
      END IF
      DO 500 NPNW = NPSTRT,NPEMF
         DO 51 ISPR = 1, MKBMX1
            ESPARK (ISPR,NPNW) = SPAUSR (ISPR)
 51      CONTINUE
         DO 52 ISPR = 1, MKBMX2
            IESPAK (ISPR,NPNW) = ISPUSR (ISPR)
 52      CONTINUE
         LOUEMF (NPNW) = LLOUSE
 500  CONTINUE
*  Increment the track number and put it into the last flag:
      NEXTRK = 0
      DO 100 KP = NPSTRT, NPEMF
         NCRTRK = NTRCKS
         IF ( LPAIRP .OR. LPHOEL .OR. LANNFL .OR. LANNRS ) THEN
            IF ( NCRTRK .EQ. 2000000000 ) NCRTRK = -2000000000
            NEXTRK = NEXTRK + 1
            NCRTRK = NCRTRK + NEXTRK
            IESPAK (MKBMX2,KP) = NCRTRK
         ELSE IF ( LCMPTN ) THEN
            IF ( ICHEMF (KP) .NE. 0 ) THEN
               IF ( NCRTRK .EQ. 2000000000 ) NCRTRK = -2000000000
               NEXTRK = NEXTRK + 1
               NCRTRK = NCRTRK + NEXTRK
               IESPAK (MKBMX2,KP) = NCRTRK
            END IF
         ELSE IF ( LBRMSP ) THEN
            IF ( ICHEMF (KP) .EQ. 0 ) THEN
               IF ( NCRTRK .EQ. 2000000000 ) NCRTRK = -2000000000
               NEXTRK = NEXTRK + 1
               NCRTRK = NCRTRK + NEXTRK
               IESPAK (MKBMX2,KP) = NCRTRK
            END IF
         ELSE IF ( LDLTRY ) THEN
            IF ( LBHABH ) THEN
               IF ( ICHEMF (KP) .LT. 0 ) THEN
                  IF ( NCRTRK .EQ. 2000000000 ) NCRTRK = -2000000000
                  NEXTRK = NEXTRK + 1
                  NCRTRK = NCRTRK + NEXTRK
                  IESPAK (MKBMX2,KP) = NCRTRK
               END IF
            ELSE IF ( KP .EQ. NPEMF ) THEN
               IF ( NCRTRK .EQ. 2000000000 ) NCRTRK = -2000000000
               NEXTRK = NEXTRK + 1
               NCRTRK = NCRTRK + NEXTRK
               IESPAK (MKBMX2,KP) = NCRTRK
            END IF
         END IF
*  |  +----------------------------------------------------------------*
*  |  |   Look for first photon, means user variables not set.
         IF ( ICHEMF (KP) .EQ. 0 .AND. EMF2GV*ETEMF(KP) .GT. THRESH)
     &        THEN
*            write (lunout,*) 'photon in stupre', EMF2GV*ETEMF(KP),
*     &        IESPAK (5,KP)
*  |  |  +-------------------------------------------------------------*
*  |  |  |  not yet stored
            IF ( IESPAK (5,KP) .EQ. 0 ) THEN
*            write (lunout,*) 'first photon in stupre'
               EKGENP = ETRACK - AM (JTRACK)
               IDGENP = JTRACK
               IAP    = IBARCH (JTRACK)
               IZP    = ICHRGE (JTRACK)
               ICHTAR = -1
               ESPARK (8,KP) = EKGENP
               ESPARK (5,KP) = XEMF(KP)
               ESPARK (6,KP) = YEMF(KP)
               ESPARK (7,KP) = ZEMF(KP)
               ESPARK (9,KP) = ETEMF(KP)
               IESPAK (6,KP) = IESPAK (MKBMX2,KP)
               IESPAK (4,KP) = LTRACK +1
               IESPAK (1,KP) = ICHTAR
               IESPAK (2,KP) = IZP
               IESPAK (3,KP) = IAP
               IESPAK (5,KP) = NPHOT +1
               IESPAK (8,KP) = 200
               IESPAK (9,KP) = IDGENP
               IESPAK (10,KP) = IREMF(KP)
               NPHOT = NPHOT +1
            END IF
         END IF
*  |  |
*  |  +----------------------------------------------------------------*
*  |  +----------------------------------------------------------------*
*  |  |  Photon interactions: check if it is an uncollided  prompt photon,
*  |  |  in this case register the interaction point
         IF ( JTRACK .EQ. 7 .AND. (.NOT. LCOHSC)  .AND.
     &      ISPUSR (7) .EQ. 0   ) THEN
*  |  |  which photon?
            IPH = ISPUSR(5)
*  |  |   set region
            IESPAK (7,KP) = IREMF (KP)
*  |  |   
         END IF
*  |  
*  +-------------------------------------------------------------------*
          
 100  CONTINUE
      IF ( NTRCKS .EQ. 2000000000 .AND. NEXTRK .GT. 0 )
     &   NTRCKS = -2000000000
      NTRCKS = NTRCKS + NEXTRK
      RETURN
*=== End of subroutine Stupre =========================================*
      END