SUBROUTINE ANNIH
C                                VERSION 4.00  --  26 JAN 1986/1900
C******************************************************************
C   GAMMA SPECTRUM FOR TWO GAMMA IN-FLIGHT POSITRON ANNIHILATION.
C   USING SCHEME BASED ON HEITLER'S P269-270 FORMULAE
C   THIS ROUTINE SHOULD GIVE THE CORRECT DISTRIBUTION, BUT MORE
C   THOUGHT COULD BE PUT INTO DEVISING A FASTER SCHEME.  HOWEVER,
C   SINCE POSITRON ANNIHILATION IN FLIGHT IS RELATIVELY INFREQUENT
C   THIS MAY NOT BE WORTHWHILE.
C******************************************************************
      DOUBLE PRECISION PAVIP
*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/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,* )' ANNIH: NP=',NP,' IR=',IR(NP),' IOBS=',IOBS(NP)
C______CALL AUSGB2
C_____END IF
      PAVIP=E(NP)+PRM
      AVIP=PAVIP
      A=AVIP*RMI
      AI=1.0/A
      G=A-1.0
      T=G-1.0
      P=SQRT(A*T)
      POT=P/T
      EP0I=(A+P)
331   CONTINUE
       CALL RMMAR(RD,2,2)
       RNNO01=RD(1)
       RNNO02=RD(2)
       EP=EXP(RNNO01*LOG(EP0I-1.0))/EP0I
       REJF=1.0-EP+AI*AI*(2.0*G-1.0/EP)
       IF((RNNO02.LE.REJF))GO TO332
      GO TO 331
332   CONTINUE
      ESG1=AVIP*MAX(EP,1.-EP)
      E(NP)=ESG1
      E(NP+1)=PAVIP-E(NP)
      ESG2=E(NP+1)
      IQ(NP)=1
      COSTHE=(ESG1-RM)*POT/ESG1
      SINTHE=SQRT(MAX(1.0-COSTHE*COSTHE,0.))
      CALL UPHI(2,1)
      NP=NP+1
      IQ(NP)=1
      COSTHE=(ESG2-RM)*POT/ESG2
      SINTHE=SQRT(MAX(1.0-COSTHE*COSTHE,0.))
      CALL UPHI(3,2)
      RETURN
      END