SUBROUTINE BHABHA
C                                VERSION 4.00  --  26 JAN 1986/1900
C******************************************************************
C   DISCRETE BHABHA SCATTERING (A CALL TO THIS ROUTINE) HAS BEEN
C   ARBITRARILY DEFINED AND CALCULATED TO MEAN BHABHA SCATTERINGS
C   WHICH IMPART TO THE SECONDARY ELECTRON SUFFICIENT ENERGY THAT
C   IT BE TRANSPORTED DISCRETELY, I.E. E=AE OR T=TE.  IT IS NOT
C   GUARANTEED THAT THE FINAL POSITRON WILL HAVE THIS MUCH ENERGY
C   HOWEVER.  THE EXACT BHABHA DIFFERENTIAL CROSS SECTION IS USED.
C******************************************************************
      DOUBLE PRECISION PEIP,PEKSE2,PESE1,PESE2
      DOUBLE PRECISION PEKIN,PEKINI,H1,DCOSTH
*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,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/THRESH/RMT2,RMSQ,ESCD2,AP,API,AE,UP,UE,TE,THMOLL
      COMMON/UPHIOT/THETA,SINTHE,COSTHE,SINPHI, COSPHI,PI,TWOPI,PI5D2
      DOUBLE PRECISION PZERO,PRM,PRMT2,RMI,VC
      COMMON/USEFUL/PZERO,PRM,PRMT2,RMI,VC,RM,MEDIUM,MEDOLD,IBLOBE,ICALL
      COMMON/ACLOCK/NCLOCK,JCLOCK
C_____IF (NCLOCK.GT.JCLOCK) THEN
C______WRITE(MDEBUG,* )' BHABHA:NP=',NP,' IR=',IR(NP),' IOBS=',IOBS(NP)
C______CALL AUSGB2
C_____END IF
      PEIP=E(NP)
      EIP=PEIP
      PEKIN=PEIP-PRM
      EKIN=PEKIN
      PEKINI=1./PEKIN
      EKINI=PEKINI
      T0=EKIN*RMI
      E0=T0+1.
      YY=1./(T0+2.)
      E02=E0*E0
      BETAI2=E02/(E02-1.)
      EP0=TE*EKINI
      EP0C=1.-EP0
      Y2=YY*YY
      YP=1.-2.*YY
      YP2=YP*YP
      B4=YP2*YP
      B3=B4+YP2
      B2=YP*(3.+Y2)
      B1=2.-Y2
341   CONTINUE
       CALL RMMAR(RD,2,2)
       RNNO03=RD(1)
       RNNO04=RD(2)
       BR=EP0/(1.-EP0C*RNNO03)
       REJF2=EP0C*(BETAI2-BR*(B1-BR*(B2-BR*(B3-BR*B4))))
       IF((RNNO04.LE.REJF2))GO TO342
      GO TO 341
342   CONTINUE
      IF (BR.LT.0.5) THEN
       IQ(NP+1)=3
      ELSE
       IQ(NP)=3
       IQ(NP+1)=2
       BR=1.-BR
      END IF
      BR=MAX(BR,0.0)
      PEKSE2=BR*EKIN
      PESE1=PEIP-PEKSE2
      PESE2=PEKSE2+PRM
      E(NP)=PESE1
      E(NP+1)=PESE2
      H1=(PEIP+PRM)*PEKINI
      DCOSTH=MIN(H1*(PESE1-PRM)/(PESE1+PRM),1.D0)
      SINTHE=SQRT(1.D0-DCOSTH)
      COSTHE=SQRT(DCOSTH)
      CALL UPHI(2,1)
      NP=NP+1
      DCOSTH=MIN(H1*(PESE2-PRM)/(PESE2+PRM),1.D0)
      SINTHE=-SQRT(1.D0-DCOSTH)
      COSTHE=SQRT(DCOSTH)
      CALL UPHI(3,2)
      RETURN
      END