TEvtGen/PHOTOS/photos_make.F

   1       SUBROUTINE PHOTOS_MAKE(IPARR)
   2 C.----------------------------------------------------------------------
   3 C.
   4 C.    PHOTOS_MAKE:   General search routine
   5 C.
   6 C.    Purpose:  Search through the /PH_HEPEVT/ standard HEP common, sta-
   7 C.              rting from  the IPPAR-th  particle.  Whenevr  branching
   8 C.              point is found routine PHTYPE(IP) is called.
   9 C.              Finally if calls on PHTYPE(IP) modified entries, common
  10 C               /PH_HEPEVT/ is ordered.
  11 C.
  12 C.    Input Parameter:    IPPAR:  Pointer   to   decaying  particle  in
  13 C.                                /PH_HEPEVT/ and the common itself,
  14 C.
  15 C.    Output Parameters:  Common  /PH_HEPEVT/, either with or without
  16 C.                                new particles added.
  17 C.
  18 C.    Author(s):  Z. Was, B. van Eijk             Created at:  26/11/89
  19 C.                                                Last Update: 30/08/93
  20 C.
  21 C.----------------------------------------------------------------------
  22       IMPLICIT NONE
  23       REAL*8 PHOTON(5)
  24       INTEGER IP,IPARR,IPPAR,I,J,K,L,NLAST
  25       DOUBLE PRECISION DATA
  26       INTEGER MOTHER,POSPHO
  27       LOGICAL CASCAD
  28       INTEGER NMXHEP
  29       PARAMETER (NMXHEP=10000)
  30       INTEGER IDHEP,ISTHEP,JDAHEP,JMOHEP,NEVHEP,NHEP
  31       REAL*8 PHEP,VHEP
  32       COMMON/PH_HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
  33      &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
  34       LOGICAL QEDRAD
  35       COMMON/PHOQED/QEDRAD(NMXHEP)
  36       INTEGER NMXPHO
  37       PARAMETER (NMXPHO=10000)
  38       INTEGER ISTACK(0:NMXPHO),NUMIT,NTRY,KK,LL,II,NA,FIRST,LAST
  39       INTEGER FIRSTA,LASTA,IPP,IDA1,IDA2,MOTHER2,IDPHO,ISPHO
  40       REAL*8 PORIG(5,NMXPHO)
  41 C--
  42       IPPAR=ABS(IPARR)
  43 C--   Store pointers for cascade treatement...
  44       IP=IPPAR
  45       NLAST=NHEP
  46       CASCAD=.FALSE.
  47 C--
  48 C--   Check decay multiplicity and minimum of correctness..
  49       IF ((JDAHEP(1,IP).EQ.0).OR.(JMOHEP(1,JDAHEP(1,IP)).NE.IP)) RETURN
  50 C--
  51 C-- single branch mode
  52 C-- we start looking for the decay points in the cascade
  53 C-- IPPAR is original position where the program was called
  54       ISTACK(0)=IPPAR
  55 C--   NUMIT denotes number of secondary decay branches
  56       NUMIT=0
  57 C--   NTRY denotes number of secondary branches already checked for
  58 C--        for existence of further branches
  59       NTRY=0
  60 C-- let's search if IPARR does not prevent searching.
  61       IF (IPARR.GT.0)  THEN
  62  30    CONTINUE
  63          DO I=JDAHEP(1,IP),JDAHEP(2,IP)
  64           IF (JDAHEP(1,I).NE.0.AND.JMOHEP(1,JDAHEP(1,I)).EQ.I) THEN
  65             NUMIT=NUMIT+1
  66               IF (NUMIT.GT.NMXPHO) THEN
  67                DATA=NUMIT
  68                CALL PHOERR(7,'PHOTOS',DATA)
  69               ENDIF
  70             ISTACK(NUMIT)=I
  71           ENDIF
  72          ENDDO
  73       IF(NUMIT.GT.NTRY) THEN
  74        NTRY=NTRY+1
  75        IP=ISTACK(NTRY)
  76        GOTO 30
  77       ENDIF
  78       ENDIF
  79 C-- let's do generation
  80       DO 25 KK=0,NUMIT
  81         NA=NHEP
  82         FIRST=JDAHEP(1,ISTACK(KK))
  83         LAST=JDAHEP(2,ISTACK(KK))
  84         DO II=1,LAST-FIRST+1
  85          DO LL=1,5
  86           PORIG(LL,II)=PHEP(LL,FIRST+II-1)
  87          ENDDO
  88         ENDDO
  89 C--
  90         CALL PHTYPE(ISTACK(KK))
  91 C--
  92 C--  Correct energy/momentum of cascade daughters
  93         IF(NHEP.GT.NA) THEN
  94         DO II=1,LAST-FIRST+1
  95           IPP=FIRST+II-1
  96           FIRSTA=JDAHEP(1,IPP)
  97           LASTA=JDAHEP(2,IPP)
  98           IF(JMOHEP(1,IPP).EQ.ISTACK(KK))
  99      $      CALL PHOBOS(IPP,PORIG(1,II),PHEP(1,IPP),FIRSTA,LASTA)
 100         ENDDO
 101         ENDIF
 102  25   CONTINUE
 103 C--
 104 C--   rearrange  /PH_HEPEVT/  to get correct order..
 105         IF (NHEP.GT.NLAST) THEN
 106           DO 160 I=NLAST+1,NHEP
 107 C--
 108 C--   Photon mother and position...
 109             MOTHER=JMOHEP(1,I)
 110             POSPHO=JDAHEP(2,MOTHER)+1
 111 C--   Intermediate save of photon energy/momentum and pointers
 112               DO 90 J=1,5
 113    90         PHOTON(J)=PHEP(J,I)
 114               ISPHO =ISTHEP(I)
 115               IDPHO =IDHEP(I)
 116               MOTHER2 =JMOHEP(2,I)
 117               IDA1 =JDAHEP(1,I)
 118               IDA2 =JDAHEP(2,I)
 119 C--
 120 C--   Exclude photon in sequence !
 121             IF (POSPHO.NE.NHEP) THEN
 122 C--
 123 C--
 124 C--   Order /PH_HEPEVT/
 125               DO 120 K=I,POSPHO+1,-1
 126                 ISTHEP(K)=ISTHEP(K-1)
 127                 QEDRAD(K)=QEDRAD(K-1)
 128                 IDHEP(K)=IDHEP(K-1)
 129                 DO 100 L=1,2
 130                 JMOHEP(L,K)=JMOHEP(L,K-1)
 131   100           JDAHEP(L,K)=JDAHEP(L,K-1)
 132                 DO 110 L=1,5
 133   110           PHEP(L,K)=PHEP(L,K-1)
 134                 DO 120 L=1,4
 135   120         VHEP(L,K)=VHEP(L,K-1)
 136 C--
 137 C--   Correct pointers assuming most dirty /PH_HEPEVT/...
 138               DO 130 K=1,NHEP
 139                 DO 130 L=1,2
 140                   IF ((JMOHEP(L,K).NE.0).AND.(JMOHEP(L,K).GE.
 141      &            POSPHO)) JMOHEP(L,K)=JMOHEP(L,K)+1
 142                   IF ((JDAHEP(L,K).NE.0).AND.(JDAHEP(L,K).GE.
 143      &            POSPHO)) JDAHEP(L,K)=JDAHEP(L,K)+1
 144   130         CONTINUE
 145 C--
 146 C--   Store photon energy/momentum
 147               DO 140 J=1,5
 148   140         PHEP(J,POSPHO)=PHOTON(J)
 149             ENDIF
 150 C--
 151 C--   Store pointers for the photon...
 152             JDAHEP(2,MOTHER)=POSPHO
 153             ISTHEP(POSPHO)=ISPHO
 154             IDHEP(POSPHO)=IDPHO
 155             JMOHEP(1,POSPHO)=MOTHER
 156             JMOHEP(2,POSPHO)=MOTHER2
 157             JDAHEP(1,POSPHO)=IDA1
 158             JDAHEP(2,POSPHO)=IDA2
 159 C--
 160 C--   Get photon production vertex position
 161             DO 150 J=1,4
 162   150       VHEP(J,POSPHO)=VHEP(J,POSPHO-1)
 163   160     CONTINUE
 164         ENDIF
 165       RETURN
 166       END