pyupre.f

Go to the documentation of this file. Or view the newest version in sPHENIX GitHub for file pyupre.f

 
C*********************************************************************
 
C...PYUPRE
C...Rearranges contents of the HEPEUP commonblock so that
C...mothers precede daughters and daughters of a decay are
C...listed consecutively.
 
      SUBROUTINE pyupre
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(a-h, o-z)
      IMPLICIT INTEGER(i-n)
 
C...User process event common block.
      INTEGER maxnup
      parameter(maxnup=500)
      INTEGER nup,idprup,idup,istup,mothup,icolup
      DOUBLE PRECISION xwgtup,scalup,aqedup,aqcdup,pup,vtimup,spinup
      common/hepeup/nup,idprup,xwgtup,scalup,aqedup,aqcdup,idup(maxnup),
     &istup(maxnup),mothup(2,maxnup),icolup(2,maxnup),pup(5,maxnup),
     &vtimup(maxnup),spinup(maxnup)
      SAVE /hepeup/
 
C...Local arrays.
      dimension newpos(0:maxnup),idupt(maxnup),istupt(maxnup),
     &motupt(2,maxnup),icoupt(2,maxnup),pupt(5,maxnup),
     &vtiupt(maxnup),spiupt(maxnup)
 
C...Check whether a rearrangement is required.
      need=0
      DO 100 iup=1,nup
        IF(mothup(1,iup).GT.iup) need=need+1
  100 CONTINUE
      DO 110 iup=2,nup
        IF(mothup(1,iup).LT.mothup(1,iup-1)) need=need+1
  110 CONTINUE
 
      IF(need.NE.0) THEN
C...Find the new order that particles should have.
        newpos(0)=0
        nnew=0
        inew=-1
  120   inew=inew+1
        DO 130 iup=1,nup
          IF(mothup(1,iup).EQ.newpos(inew)) THEN
            nnew=nnew+1
            newpos(nnew)=iup
          ENDIF
  130   CONTINUE
        IF(inew.LT.nnew.AND.inew.LT.nup) goto 120
        IF(nnew.NE.nup) THEN
          CALL pyerrm(2,
     &    '(PYUPRE:) failed to make sense of mother pointers in HEPEUP')
          RETURN
        ENDIF
 
C...Copy old info into temporary storage.
        DO 150 i=1,nup
          idupt(i)=idup(i)
          istupt(i)=istup(i)
          motupt(1,i)=mothup(1,i)
          motupt(2,i)=mothup(2,i)
          icoupt(1,i)=icolup(1,i)
          icoupt(2,i)=icolup(2,i)
          DO 140 j=1,5
            pupt(j,i)=pup(j,i)
  140     CONTINUE
          vtiupt(i)=vtimup(i)
          spiupt(i)=spinup(i)
  150   CONTINUE
 
C...Copy info back into HEPEUP in right order.
        DO 180 i=1,nup
          iold=newpos(i)
          idup(i)=idupt(iold)
          istup(i)=istupt(iold)
          mothup(1,i)=0
          mothup(2,i)=0
          DO 160 imot=1,i-1
            IF(motupt(1,iold).EQ.newpos(imot)) mothup(1,i)=imot
            IF(motupt(2,iold).EQ.newpos(imot)) mothup(2,i)=imot
  160     CONTINUE
          IF(mothup(2,i).GT.0.AND.mothup(2,i).LT.mothup(1,i)) THEN
            mothsw=mothup(1,i)
            mothup(1,i)=mothup(2,i)
            mothup(2,i)=mothsw
          ENDIF
          icolup(1,i)=icoupt(1,iold)
          icolup(2,i)=icoupt(2,iold)
          DO 170 j=1,5
            pup(j,i)=pupt(j,iold)
  170     CONTINUE
          vtimup(i)=vtiupt(iold)
          spinup(i)=spiupt(iold)
  180   CONTINUE
      ENDIF
 
c...If incoming particles are massive recalculate to put them massless.
      IF(pup(5,1).NE.0d0.OR.pup(5,2).NE.0d0) THEN
        pplus=(pup(4,1)+pup(3,1))+(pup(4,2)+pup(3,2))
        pminus=(pup(4,1)-pup(3,1))+(pup(4,2)-pup(3,2))
        pup(4,1)=0.5d0*pplus
        pup(3,1)=pup(4,1)
        pup(5,1)=0d0
        pup(4,2)=0.5d0*pminus
        pup(3,2)=-pup(4,2)
        pup(5,2)=0d0
      ENDIF
 
      RETURN
      END