C   15/11/81 708291857  MEMBER NAME  INTSHW9  (S)           FORTRAN
      SUBROUTINE INTSHW(FRAC,N,A,Z,ROH,XX0)
C
C     A.SATO     XX-01-78
C
C     LATEST MODIFICATION  BY A.SATO      03-03-78  17:10
C     AFTER YAMADA'S MODIFICATION AT 17-02-78 19:10
C---- LAST MODIFICATION AT LICEPP 20-05-81  12:00
C     COPIED FROM LICEPP TO NOV-1981
C     LAST MOD    29-11-81  11:30
C
C  COPIED FROM F22YAM.LG.S(INTSHWM) ON 16.1.1986
C          INTENDED FOR MULTIPLE MATERIALS IN JADE: AL-ABS,SF5,SF6
C      CHANGE  16.1.1986
C  LAST CHANGE  29.8.1987    (ENELEL,ENELPO)
C                                   J.OLSSON
      COMMON / COLSON/ IPRO
      COMMON /TOTPAT/ PATH
      COMMON /CMATTR/ IMATTR,IMTLIS(10),XCM(10)
      COMMON /CAMPAR/CIC02,BP0
C  /RADLB/ HAS NO DIRECT USE IN SHOWER PROGRAM
      COMMON /RADLB/ XX0CM
C
      COMMON/FB1PAR/BGAM,PROSWD
      COMMON/BRPAR/BRA,BRB,BDEL
      COMMON/M0PAR/CUTM
      COMMON/PAPAR/CP
      COMMON /ENECUT/ ECUT,ECUTEL,ECUTPH,ECUTPS
      COMMON /SFCPA/SFC,SFE
      COMMON /ILPAR/AII,BII,CUTII/DFPAR/CID,AID,RMID,X0D,X1D
      EXTERNAL FPH
      DIMENSION SPTCL(9,MNP),PRTCL(9,MNP)
      DIMENSION PA0(3,3),PA1(3,3), PAQ0(9),PAQ1(9)
      DIMENSION POS(3),DIR(3)
      DIMENSION TETBL(20),ATETBL(20),TETBL0(21),ATETB0(21)
      DIMENSION DTETBL(20)
      EQUIVALENCE (TETBL(1),TETBL0(2)),(ATETBL(1),ATETB0(2))
C     DIMENSION ELTBL(200)
      DIMENSION ELOSEL(200),ELOSPO(200)
      DIMENSION ALTBL(200),ALTBL2(200)
      DIMENSION ECUTLS(3)
C     DIMENSION BUFF(40,10),BELTBL(200,10),BTETB0(21,10)
      DIMENSION BUFF(40,10),BELTEL(200,10),BELTPO(200,10),BTETB0(21,10)
      DIMENSION BDTETB(20,10),BATBT0(21,10)
C     NAMELIST /DMP/ ELTBL,TETBL0,ATETB0
      NAMELIST /DMP/ ELOSEL,ELOSPO,TETBL0,ATETB0
      DATA KPMAX/40/
      DATA NRCOM1/200/,NRCOM2/200/, ES/42./
      DATA EDCOM1/0.1/, CORP/0.284/, ANHAPF/1.60/
      DATA BPHE1/0.0489/,BPHE2/0.2559/,BPHE3/0.0583/
      DIMENSION FRAC(N),Z(N), A(N), X0(10)
      DIMENSION PR(10), POS0(3)
      EQUIVALENCE(ENE0,PA0(2,1)),(ENE1,PA1(2,1))
      EQUIVALENCE (CHG0,PA0(1,1)), (CHG1,PA1(1,1))
     @,(FLEN0,PA0(3,1)), (FLEN1,PA1(3,1))
      EQUIVALENCE(TMP,ITMP)
      EQUIVALENCE(PA0(1,1),PAQ0(1)), (PA1(1,1),PAQ1(1))
      EQUIVALENCE (PA0(1,2),POS(1)), (PA0(1,3),DIR(1))
      EQUIVALENCE (ECUTLS(1),ECUTEL)
      DATA NDV/100/, PAIRTH/2./, ECC/3./, NRR/20/, NRR2/200/
      DATA NTRR/20/, ETHANH/2.0/, PETH/1.82/, CHTHRE/1.272/
      DATA ISW/0/
C
C**** IF(N.GT.10)CALL MSG('COMPONENTS .GT. 10;;')
C         ZERO SET ARRAY BUFF
      IF(ISW.NE.0) GOTO 5000
      ISW=1
      CALL SETSL(BUFF,0,KPMAX*40,0)
C
5000  CONTINUE
      IF(IMATTR.LE. 0) IMATTR=1
      IF(IMATTR.GE.10) PRINT 81600
81600 FORMAT(' MATERIAL EXCEEDS 10')
      IF(IMATTR.GE.10) STOP
      IF( IMTLIS(IMATTR).NE.0 ) WRITE(6,81601) IMATTR
81601 FORMAT('++++ IMATTR=',I4,' IS INITIALIZED AGAIN.++++')
C---- REMEMBER THE SET PARAMETER NUMBER.
      IMTLIS(IMATTR) = 1
C
      CALL PARSET(FRAC,N,A,Z,CUTM,CUTB2,ROH,XX0,X0,ABR1,ABR2,
     +    ALPPA1,ALPPA2,ALPM,ALPBH,ACM,BGAM,AMEAN,ZMEAN)
C
        DO 80000 NPR=1,N
        WRITE(6,80600) A(NPR),Z(NPR),FRAC(NPR),X0(NPR)
80600   FORMAT(' A,Z,FRACTION=',2F10.2,F10.4,'   X0=',F12.4)
80000   CONTINUE
C
      XX0CM = XX0/ROH
      WRITE(6,80601) XX0,XX0CM,ROH ,IMATTR
80601 FORMAT(' XX0,XX0CM=',F10.3,'G/CM**2',F12.4,'CM   ROH=',F10.3,
     & ' INDEX OF MATERIAL',I4)
      XCM(IMATTR) = XX0CM
C
C
      ALPAN1=ACM/2.
      ALPAN0=ANHAPF*ALPAN1
C
C-----CALCULATE EFFECTIVE FRACTION OF LEAD TO DETERMINE THE CROSS
C      SECTION OF PAIR CORRECTION AND P-E EFFECT.
C
      PPB=0.
        DO 90 I=1,N
        IF(81.99 .GT. Z(I) .OR. Z(I) .GT. 82.01) GOTO 90
        PPB=PPB+FRAC(I)*XX0/X0(I)
   90   CONTINUE
C
      DAM=AMINT(FRAC,N,A,Z,XX0)
C
      CORPA0=CORP*PPB
      PROSWD=CUTB2
C       DO 80 I=1,N
        AL = ALOG(183./ZMEAN**0.333333)
        ALF=AL-FF(ZMEAN)
        BRA=1./(4.*ALF+1./3.)
        BRB=1./(4.*ALF)
        BDEL=136./(ZMEAN**0.3333333)
        CP=1./(4.*ALF-1./6.)
   80   A123=3.*SQRT(ZMEAN/137.0)
      PRL=SQRT(PROSWD)*511.*10**3
C
C     SFC---SCALING FACTOR TO REDUCE THE PHOTON 'FREE PATH'.
C     SFE---SCALING FACTOR TO REDUCE THE ELECTRON/POSITRON FREE PATH
C
      IF(SFC.LT.1.)SFC=1.
      ALPPA1=ALPPA1*SFC
      ALPPA2=ALPPA2*SFC
      ACM=ACM*SFC
C
      IF(SFE.LT.1.)SFE=1.
      ABR1=ABR1*SFE
      ABR2=ABR2*SFE
      ALPM=ALPM*SFE
      ALPBH=ALPBH*SFE
C
      CALL PARST2(ZMEAN,AMEAN,XX0,CUTM,PRL)
C
      IF(ECUT.GT.ECC) GOTO 45
C
      CALL STEST0(FPH,ECUT,ECC,TETBL,ACRTO,NRR,NDV)
      TETBL0(1)=0.
      DO 51 I=1,NRR
51    DTETBL(I)=TETBL(I)
      DO 50 I=2,NRR
50    TETBL(I)=TETBL(I-1)+TETBL(I)
      EDD=(ECC-ECUT)/NRR
C
C******GET INVERSE OF TETBL
C
      ATETB0(1)=ECUT
      TDD=TETBL(NRR)/NTRR
      T=0.
      NTRR1 = NTRR-1
      DO 40 J=1,NTRR1
      I=1
      T=T+TDD
41    IF(T.LT.TETBL0(I))GOTO 42
      I=I+1
      GO TO 41
42    I=I-1
      ATETBL(J)=ECUT+(I-1)*EDD+(T-TETBL0(I))*EDD/DTETBL(I)
40    CONTINUE
      ATETBL(NTRR)=ECC
C
   45 ECC2=ECUT+FLOAT(NRR2)
      ENE=ECUT
        DO 55 I=1,NRR2
C       ELTBL(I)=ENELS(ENE)
        ELOSEL(I)=ENELEL(ENE)
        ELOSPO(I)=ENELPO(ENE)
   55   ENE=ENE+1.
C
C     WRITE(6,8221) (ELTBL(I),I=1,200)
C221  FORMAT(' ',20(' ELTBL ',10(F10.4,1X),/))
      WRITE(6,8221) (ELOSEL(I),I=1,200)
8221  FORMAT(' ',20(' ELOSEL ',10(F10.4,1X),/))
      WRITE(6,8222) (ELOSPO(I),I=1,200)
8222  FORMAT(' ',20(' ELOSPO ',10(F10.4,1X),/))
C
      ENE=ECUTPH
        DO 60 I=1,NRCOM1
        ALTBL(I)=ALOG(1.+2.*ENE)
60      ENE=ENE+EDCOM1
      ECCOM1=ENE
        DO 61 I=1,NRCOM2
        ALTBL2(I)=ALOG(1.+2.*ENE)
61      ENE=ENE+1
      NRCM1=NRCOM1-1
      NRCM2=NRCOM2-1
C
C OF THE FOLLOWING PARAMETERS, SOME ARE NOT USED LATER ON
C    CUTB2 == PROSWD
C    XX0,AMEAN,ZMEAN,AL,ALF,PRL ARE ONLY USED FOR CALCULATIONS IN INIT.
C
C
      BUFF(1,IMATTR) = CUTB2
      BUFF(2,IMATTR) = XX0
      BUFF(3,IMATTR) = ABR1
      BUFF(4,IMATTR) = ABR2
      BUFF(5,IMATTR) = ALPPA1
      BUFF(6,IMATTR) = ALPPA2
      BUFF(7,IMATTR) = ALPM
      BUFF(8,IMATTR) = ALPBH
      BUFF(9,IMATTR) = ACM
      BUFF(10,IMATTR)= BGAM
      BUFF(11,IMATTR)= AMEAN
      BUFF(12,IMATTR)= ZMEAN
      BUFF(13,IMATTR)= XX0CM
      BUFF(14,IMATTR)= ALPAN1
      BUFF(15,IMATTR)= ALPAN0
      BUFF(16,IMATTR)= PPB
      BUFF(17,IMATTR)= CORPA0
      BUFF(18,IMATTR)= PROSWD
      BUFF(19,IMATTR)= AL
      BUFF(20,IMATTR)= ALF
      BUFF(21,IMATTR)= BRA
      BUFF(22,IMATTR)= BRB
      BUFF(23,IMATTR)= BDEL
      BUFF(24,IMATTR)= CP
      BUFF(25,IMATTR)= A123
      BUFF(26,IMATTR)= PRL
      BUFF(27,IMATTR)= ECUT
      BUFF(28,IMATTR)= ECUTEL
      BUFF(29,IMATTR)= ECUTPH
      BUFF(30,IMATTR)= ECUTPS
      BUFF(31,IMATTR)= EDD
      BUFF(32,IMATTR)= ECC
      BUFF(33,IMATTR)= CIC02
      BUFF(34,IMATTR)= BP0
      BUFF(35,IMATTR)= TDD
      CALL MVCL( BTETB0(1,IMATTR), 0, TETBL0, 0, 21*4)
      CALL MVCL( BDTETB(1,IMATTR), 0, DTETBL, 0, 20*4)
C     CALL MVCL( BELTBL(1,IMATTR), 0, ELTBL , 0, 200*4)
      CALL MVCL( BELTEL(1,IMATTR), 0, ELOSEL , 0, 200*4)
      CALL MVCL( BELTPO(1,IMATTR), 0, ELOSPO , 0, 200*4)
      CALL MVCL( BATBT0(1,IMATTR), 0, ATETB0, 0, 21*4)
CCC   WRITE(6,DMP)
       NMTTRO=IMATTR
      RETURN
C
C******************************
C
      ENTRY CASSHW(PRTCL,SPTCL,MNP,NP,IER,JBACK)
C
C JBACK IS STEERING CUTS ON SIDE ESCAPE IN LIGHTGUIDES ETC.
C    DOES NOT APPLY TO THE JADE SETUP, TO BE CALLED WITH JBACK=0
C
C
      IF(IPRO.NE.0) WRITE(6,2251) IMATTR,NMTTRO,PRTCL(4,1)
2251  FORMAT(' CASSHW: CALL WITH IMATTR NMTTRO:',2I4,' PRTCL41 ',E12.4)
C
      IF( IMTLIS(IMATTR).NE.0 ) GO TO 5001
         WRITE(6,6905) IMATTR,IMTLIS
 6905    FORMAT('  +++++ WRONG MATERIAL INDEX +++++,IMATTR=',I6,
     *          /' IMTLIS=',10I5,/)
C
 5001 IF(NMTTRO.EQ.IMATTR) GOTO 5100
       NMTTRO=IMATTR
C
       CUTB2     = BUFF( 1,IMATTR)
       XX0       = BUFF( 2,IMATTR)
       ABR1      = BUFF( 3,IMATTR)
       ABR2      = BUFF( 4,IMATTR)
       ALPPA1    = BUFF( 5,IMATTR)
       ALPPA2    = BUFF( 6,IMATTR)
       ALPM      = BUFF( 7,IMATTR)
       ALPBH     = BUFF( 8,IMATTR)
       ACM       = BUFF( 9,IMATTR)
       BGAM      = BUFF(10,IMATTR)
       AMEAN     = BUFF(11,IMATTR)
       ZMEAN     = BUFF(12,IMATTR)
       XX0CM     = BUFF(13,IMATTR)
       ALPAN1    = BUFF(14,IMATTR)
       ALPAN0    = BUFF(15,IMATTR)
       PPB       = BUFF(16,IMATTR)
       CORPA0    = BUFF(17,IMATTR)
       PROSWD    = BUFF(18,IMATTR)
       AL        = BUFF(19,IMATTR)
       ALF       = BUFF(20,IMATTR)
       BRA       = BUFF(21,IMATTR)
       BRB       = BUFF(22,IMATTR)
       BDEL      = BUFF(23,IMATTR)
       CP        = BUFF(24,IMATTR)
       A123      = BUFF(25,IMATTR)
       PRL       = BUFF(26,IMATTR)
       ECUT      = BUFF(27,IMATTR)
       ECUTEL    = BUFF(28,IMATTR)
       ECUTPH    = BUFF(29,IMATTR)
       ECUTPS    = BUFF(30,IMATTR)
       EDD       = BUFF(31,IMATTR)
       ECC       = BUFF(32,IMATTR)
       CIC02     = BUFF(33,IMATTR)
       BP0       = BUFF(34,IMATTR)
       TDD       = BUFF(35,IMATTR)
C
      IF(IPRO.GT.0) WRITE(6,2111) CUTB2,XX0,ABR1,ABR2,ALPPA1,ALPPA2
2111  FORMAT(' CUTB2,XX0,ABR1,ABR2,ALPPA1,ALPPA2 ',6E12.4)
      IF(IPRO.GT.0) WRITE(6,2112) ALPM,ALPBH,ACM,BGAM,AMEAN,ZMEAN
2112  FORMAT(' ALPM ALPBH ACM BGAM AMEAN ZMEAN   ',6E12.4)
      IF(IPRO.GT.0) WRITE(6,2113) XX0CM,ALPAN1,ALPAN0,PPB,CORPA0,PROSWD
2113  FORMAT(' XX0CM ALPAN1 ALPAN0 PPB CORPA0 PROSWD ',6E12.4)
      IF(IPRO.GT.0) WRITE(6,2114) AL,ALF,BRA,BRB,BDEL,CP
2114  FORMAT(' AL ALF BRA BRB BDEL CP                ',6E12.4)
      IF(IPRO.GT.0) WRITE(6,2115) A123,PRL,ECUT,ECUTEL,ECUTPH,ECUTPS
2115  FORMAT(' A123 PRL ECUT ECUTEL ECUTPH ECUTPS    ',6E12.4)
      IF(IPRO.GT.0) WRITE(6,2116) EDD,ECC,CIC02,BP0,TDD
2116  FORMAT(' EDD ECC CIC02 BP0 TDD                 ',5E12.4)
C
      CALL MVCL( TETBL0, 0, BTETB0(1,IMATTR), 0, 21*4)
      CALL MVCL( DTETBL, 0, BDTETB(1,IMATTR), 0, 20*4)
C     CALL MVCL( ELTBL , 0, BELTBL(1,IMATTR), 0, 200*4)
      CALL MVCL( ELOSEL, 0, BELTEL(1,IMATTR), 0, 200*4)
      CALL MVCL( ELOSPO, 0, BELTPO(1,IMATTR), 0, 200*4)
      CALL MVCL( ATETB0, 0, BATBT0(1,IMATTR), 0, 21*4)
CCC   WRITE(6,DMP)
C
5100   CONTINUE
      PATH=0.
      IER=0
      NSP=NP
        DO 20 K=1,NP
          DO 20 I=1,9
20      SPTCL(I,K)=PRTCL(I,K)
      NP=0
C
C*****     MAIN LOOP TO GENERATE SHOWER      *****
C
200   CONTINUE
C
      IF(IPRO.GT.0) WRITE(6,2252) NSP,SPTCL(1,NSP),SPTCL(2,NSP)
2252  FORMAT(' CASSHW MAIN LOOP : NSP AT 200 ',I4,' CHG0 ENE0 ',2F8.3)
C
      IF(NSP) 400,400,201
201   DO 210 I=1,9
210   PAQ0(I)=SPTCL(I,NSP)
      NSP=NSP-1
C
100   CONTINUE
      STH0=0.
      STH1 = 0.
      ECUT0=ECUTLS(CHG0+2.1)
C
C-----ECUT0 IS ECUT FOR THE PARTICLE IN PA0
C
      IF(IPRO.GT.0) WRITE(6,2253) NSP,ENE0,ECUT0,CHG0
2253  FORMAT(' CASSHW: NSP ENE0 ECUT0 CHG0 ',I4,3E12.4)
C
C  IF TOO LOW ENERGY, SKIP AND GET NEXT PARTICLE
C
      IF(ENE0.LE.ECUT0) GOTO 200
C
C  BRANCH ACCORDING TO CHARGE
C
      IF(CHG0) 2000,3000,2000
C
C********* ELECTRON AND POSITRON
C
 2000 CONTINUE
C
      IF(IPRO.GT.0) WRITE(6,2254) NSP
2254  FORMAT(' CASSHW: ENTERING EL. PART 2000 NSP: ',I5)
C
      CON=1.+A123/ENE0
      ALPBR1=ABR1*CON
      ALPBR2=ABR2*CON
      ALPMBH = ALPM
      ALPANH = 0.
C
      IF(CHG0.LT.0.) GO TO 1000
C
C                                     ****** POSITRONS  ******
C
C---- POSITRON ANNIHILATION
C
      ALPMBH = ALPBH
      ALPANH=ALPAN0*ENE0**(-0.77777)
C
       IF(ENE0.LT.ETHANH) ALPANH=
     &    ALPAN1/((ENE0+1.)*(ENE0**2-1.))
     &    *(    (ENE0**2+4.*ENE0+1.)
     &         *ALOG(ENE0+SQRT(ENE0**2-1.))
     &          -(ENE0+3.)*SQRT(ENE0**2-1.)  )
C
 1000 FAII=1./(ALPBR1+ALPBR2+ALPMBH+ALPANH)
 2001 T=-ALOG(RN(DAM))*FAII
C---- STARTING POSITION OF THE TRACK SEGMENT=POS0(1--3)
        DO 2203 I=1,3
 2203   POS0(I) =POS(I)
      ETMP=ENE0
C
      IF(IPRO.GT.0) WRITE(6,2291) ENE0,ECC
2291  FORMAT(' CASSHW: AFTER 2203 ENE0 ECC ',2E12.4)
C
      IF(ENE0.GT.ECC) GOTO 2201
C
      I=IFIX((ENE0-ECUT)/EDD)+1
      IF(I.GT.NRR)I=NRR
      TM=TETBL0(I)+( TETBL0(I+1)-TETBL0(I) )*
     &             ( (ENE0-ECUT)/EDD+FLOAT(1-I) )
C
C
      IF(IPRO.GT.0) WRITE(6,2292) T,TM
2292  FORMAT(' CASSHW: AT GO TO 2221, T TM ',2E12.4)
C
      IF(T.LE.TM) GOTO 2221
      T=TM
      TS=T*(1.-T/4.*(ENE0*ES/(ENE0**2-1.))**2)
C
      IF(IPRO.GT.0) WRITE(6,2293) TS
2293  FORMAT(' CASSHW: AT GO TO 22101 , TS',E12.4)
C
      IF(TS.LE.0.) GO TO 22101
        DO 2210 I=1,3
 2210   POS(I)=POS(I)+DIR(I)*TS
C
22101 CALL NEWDIR(DIR,AMSCAT(ENE0,T))
      ENE0=ECUT
      GOTO 2202
C
 2221 TS=T*(1.-T/4.*(ENE0*ES/(ENE0**2-1.))**2)
C
      IF(IPRO.GT.0) WRITE(6,2294) TS
2294  FORMAT(' CASSHW: AT GO TO 22131 , TS',E12.4)
C
      IF(TS.LE.0.) GO TO 22131
        DO 2213 I=1,3
 2213   POS(I)=POS(I)+DIR(I)*TS
22131 TRES=TM-T
      I=IFIX(TRES/TDD)+1
      CALL NEWDIR(DIR,AMSCAT(ENE0,T))
      ENE0=ATETB0(I)+(ATETB0(I+1)-ATETB0(I))*(TRES/TDD+FLOAT(1-I))
      GOTO 2202
C
2201  CONTINUE
      TS=T*(1.-T/4.*(ENE0*ES/(ENE0**2-1.))**2)
      IF(TS .LT. 0) TS = 0.
        DO 2211 I=1,3
 2211   POS(I)=POS(I)+DIR(I)*TS
      CALL NEWDIR(DIR,AMSCAT(ENE0,T))
      I=IFIX(ENE0-ECUT)+1
      IF(I.GT.NRR2)I=NRR2
C     ENE0=ENE0-T*ELTBL(I)
      IF(CHG0.LT.0.) ENE0=ENE0-T*ELOSEL(I)
      IF(CHG0.GT.0.) ENE0=ENE0-T*ELOSPO(I)
 2202 FLEN0=FLEN0+T
      IF(ENE0.GT.CHTHRE) PATH=PATH+T
C
      IF(IPRO.GT.0) WRITE(6,2295) PATH,T
2295  FORMAT(' CASSHW: AT 2202  PATH,T',2E12.4)
C
C     CALL CHKEL1(ETMP-ENE0)
C
C---- CERENKOV DATA FOR REAL DETECTOR
C
C    ENERGY STORAGE IN THE LEAD GLASS ARRAY IS DONE HERE. IF IN AL-ABS
C       THE ENERGY LOSS IS APPLIED ONLY
C       UNIT IS RADIATION LENGTH ON CALL
C
      IF(IPRO.GT.0) WRITE(6,2255) T,(POS0(IK),IK=1,3)
2255  FORMAT(' CASSHW:LSCCTC WITH T  POS0 ',4E12.4)
      IF(IPRO.GT.0) WRITE(6,2257) ((PA0(IK,IL),IK=1,3),IL=1,3)
2257  FORMAT(' PA0 ',9E12.4)
C
      CALL LSCCTC(POS0,PA0,T)
C
      IF(IPRO.GT.0) WRITE(6,2238) T,(POS0(IK),IK=1,3)
2238  FORMAT(' AFTER LSCCTC WITH T  POS0 ',4E12.4)
      IF(IPRO.GT.0) WRITE(6,2239) ((PA0(IK,IL),IK=1,3),IL=1,3)
2239  FORMAT('  PA0 ',9E12.4)
C
C
      BOUNDX = BOUND(PA0)
      IF(IPRO.GT.0) WRITE(6,2296) ENE0,ECUT0,BOUNDX
2296  FORMAT(' CASSHW: AT LSCCTC,ENE0 ECUT0 BOUND(PA0) ',3E12.4)
C
      IF(ENE0-ECUT0) 200,200,2002
C---- CHECK BOUNDARIES
2002  IF(BOUND(PA0).LE.0.) GO TO 300
      IF(JBACK.GT.0) CALL BOUND2(JBACK,PA0,&300)
C
      IF(IPRO.GT.0) WRITE(6,2297) CHG0,ENE0
2297  FORMAT(' CASSHW: AT BOUND2  CHG0 ENE0 ',2E12.4)
C
      IF(CHG0.GT.0. .AND. ENE0. LE. 1.001) GO TO 2040
C
      CON=1.+A123/ENE0
      ALPBR1=ABR1*CON
      ALPBR2=ABR2*CON
      ALPANH = 0.
      IF(CHG0.LT.0.) GOTO 2003
C---- POSITRON ANNIHILATION
      ALPANH=ALPAN0*ENE0**(-0.77777)
C
C*********************
C
       IF(ENE0.LT.ETHANH) ALPANH=
     &    ALPAN1/((ENE0+1.)*(ENE0**2-1.))
     &    *(    (ENE0**2+4.*ENE0+1.)
     &         *ALOG(ENE0+SQRT(ENE0**2-1.))
     &          -(ENE0+3.)*SQRT(ENE0**2-1.)  )
C
2003  FAII=1./(ALPBR1+ALPBR2+ALPMBH+ALPANH)
      PR(1)=ALPBR1*FAII
      PR(2)=ALPBR2*FAII
      PR(3)=ALPMBH*FAII
      PR(4)=ALPANH*FAII
      I=IPRDIV(PR,4)
C
      IF(IPRO.GT.0) WRITE(6,2298) I
2298  FORMAT(' CASSHW: AT 2003   I ',I4)
C
      GOTO (2010,2020,2030,2040),I
 2010 CALL BREMS1(ENE0,EPSI)
C
      IF(IPRO.GT.0) WRITE(6,2299) EPSI
2299  FORMAT(' CASSHW: EPSI AFTER BREMS1 ',E12.4)
C
      IF(EPSI)2001,2001,11
 2020 CALL BREMS2(ENE0,EPSI)
C
      IF(IPRO.GT.0) WRITE(6,2301) EPSI
2301  FORMAT(' CASSHW: EPSI AFTER BREMS2 ',E12.4)
C
      IF(EPSI)2001,2001,11
C---- MOLLER OR BHABHA
 2030 IF(CHG0) 1030,1030,2130
C
C---- ELECTRON MOLLER
 1030 CALL M0LLER(ENE0,EPSI)
C
      IF(IPRO.GT.0) WRITE(6,2302) EPSI
2302  FORMAT(' CASSHW: EPSI AFTER M0LLER ',E12.4)
C
      IF(EPSI)2001,2001,2032
C
C---- POSITRON,BHABHA
 2130 CALL BHABHA(ENE0,EPSI)
C
      IF(IPRO.GT.0) WRITE(6,2303) EPSI
2303  FORMAT(' CASSHW: EPSI AFTER BHABHA ',E12.4)
C
      IF(EPSI)2001,2001,2032
C
 2032 CHG1=-1.
      ECUT1=ECUTEL
      EKIN0=ENE0-1.
      EKIN1=EPSI*EKIN0
      ENE1=EKIN1+1.
      C2TH1=EKIN1*(EKIN0+2.)/(EKIN0*(EKIN1+2.))
      CTH1=SQRT(C2TH1)
      STH1=0.
      IF(CTH1.LT.1.) STH1=SQRT(1.-C2TH1)
      EKINX=ENE0-ENE1
      C2TH0=EKINX*(EKIN0+2.)/(EKIN0*(EKINX+2.))
      CTH0=SQRT(C2TH0)
      STH0=0.
      IF(CTH0.LT.1.) STH0=SQRT(1.-C2TH0)
      ENE0 = ENE0-EKIN1
C
      IF(IPRO.GT.0) WRITE(6,2304) ENE0
2304  FORMAT(' CASSHW: ENE0 AT GO TO 13 ',E12.4)
C
      GO TO 13
C
C---- ANNIHILATION
 2040 CHG0=0.
      CHG1=0.
      ECUT0=ECUTPH
      ECUT1=ECUTPH
      ENE0=ENE0+1.
      ENE1=ENE0*0.5*(RN(DAM)+RN(CON))
      FLEN0=0.
C
      IF(IPRO.GT.0) WRITE(6,2256) T,ENE0
2256  FORMAT(' CASSHW: EL AT ANNIHIL. , LEAVING TO 12, T ENE0  ',2E12.4)
C
      GO TO 12
C
C*******PHOTON
C
3000  CONTINUE
C
      IF(IPRO.GT.0) WRITE(6,2258) NSP,ENE0,ECCOM1
2258  FORMAT(' CASSHW: ENTERING PHOTON, NSP  ENE0 ECCOM1  ',I5,2E12.4)
C
      IF(ENE0.GE.ECCOM1)GOTO 3301
      CON=(ENE0-ECUTPH)/EDCOM1
      I=IFIX(CON)+1
      IF(I.GT.NRCM1)I=NRCM1
      ALOGEN=ALTBL(I)+(ALTBL(I+1)-ALTBL(I))*(CON+FLOAT(1-I))
      GOTO 3302
 3301 CONTINUE
C     CON=ENE0-ECUTP
C     I=IFIX(CON)+1
C     IF(I.GT.NRCM2)I=NRCM2
C     ALOGEN=ALTBL2(I)+(ALTBL2(I+1)-ALTBL2(I))*(CON+FLOAT(1-I))
       ALOGEN=ALOG(1.+2.*ENE0)
3302  ALPCOM=ACM*ALOGEN/ENE0
      CORPA=CORPA0*ALOG(ENE0)/ENE0
       ALPPHE=PPB*(BPHE1+BPHE2/ENE0+BPHE3/ENE0**2)/ENE0
C
C
      IF(IPRO.GT.0) WRITE(6,2278) ENE0,PAIRTH,ALPPHE
2278  FORMAT(' CASSHW: AT 3500: ENE0 PAIRTH ALPPHE ',3E12.4)
C
      IF(ENE0-PAIRTH) 3500,3500,3501
 3500 EALPA1 = 0.
      EALPA2 = 0.
      ECORPA = 0.
      GO TO 3600
 3501 EALPA1 = ALPPA1
      EALPA2 = ALPPA2
      ECORPA = CORPA
C
      ELPPHE=0.
      IF(ENE0.GT.PETH) ELPPHE=ALPPHE
C
 3600 FAII=1./(EALPA1+EALPA2+ALPCOM+ECORPA+ELPPHE)
3001  ALGARG = RN(DAM)
      T=-ALOG(ALGARG)*FAII
C
      IF(IPRO.GT.0) WRITE(6,2279) T
2279  FORMAT(' CASSHW: AT 3001: T  ',E12.4)
C
      POSREM = POS(1)
3201    DO 3211 I=1,3
3211    POS(I)=POS(I)+DIR(I)*T
C
      IF(IPRO.GT.0) WRITE(6,2305) (POS(IK),IK=1,3)
2305  FORMAT(' CASSHW: LOOP 3211  POS ',3E12.4)
C
      FLEN0=FLEN0+T
C*************************
C
C
      BOUNDP = BOUND(PA0)
      IF(IPRO.GT.0) WRITE(6,2280) ENE0,ECUTPH,BOUNDP
2280  FORMAT(' CASSHW: AT 3002: ENE0 ECUTPH BOUND(PA0) ',3E12.4)
C
      IF(ENE0-ECUTPH) 200,200,3002
3002  CONTINUE
C
      IF(BOUND(PA0).LE.0..AND.IPRO.NE.0) WRITE(6,3345)
     $ NSP,PA0(1,2),BOUNDP,T,FAII,PA0(1,3),ALGARG,POSREM
3345  FORMAT(' CASSHW: NSP P12 BND T FAII DIR RN POSR',I4,7E12.4)
C
      IF(BOUND(PA0).LE.0.) GOTO 300
      IF(JBACK.GT.0) CALL BOUND2(JBACK,PA0,&300)
      PR(1)=EALPA1*FAII
      PR(2)=EALPA2*FAII
      PR(3)=ALPCOM*FAII
      PR(4)=ECORPA*FAII
      PR(5)=ELPPHE*FAII
      I=IPRDIV(PR,5)
C
      IF(IPRO.GT.0) WRITE(6,2281) I
2281  FORMAT(' CASSHW: AT 3002: I=IPRDIV ',I5)
C
      GOTO(3010,3020,3030,3400,3050),I
3010  CONTINUE
C
      IF(IPRO.GT.0) WRITE(6,2307) ENE0,PAIRTH
2307  FORMAT(' CASSHW: AT 3010  ENE0 PAIRTH ',2E12.4)
C
      IF(ENE0-PAIRTH)3001,3001,3011
3011  CALL PAIRC1(ENE0,EPSI)
C
      IF(IPRO.GT.0) WRITE(6,2308) ENE0,EPSI
2308  FORMAT(' CASSHW: AFTER PAIRC1  ENE0 EPSI ',2E12.4)
C
      IF(EPSI)3001,3001,3004
3020  CONTINUE
C
      IF(IPRO.GT.0) WRITE(6,2310) ENE0,PAIRTH
2310  FORMAT(' CASSHW: AT 3020   ENE0 PAIRTH ',2E12.4)
      IF(ENE0-PAIRTH)3001,3001,3021
3021  CALL PAIRC2(ENE0,EPSI)
C
      IF(IPRO.GT.0) WRITE(6,2309) ENE0,EPSI
2309  FORMAT(' CASSHW: AFTER PAIRC2  ENE0 EPSI ',2E12.4)
C
      IF(EPSI)3001,3001,3004
C
C****** A(Z)*ALOG(K0)/K0 CORRECTION ******
C
3400  CONTINUE
C
      IF(IPRO.GT.0) WRITE(6,2311) ENE0,PAIRTH
2311  FORMAT(' CASSHW: AT 3400   ENE0 PAIRTH ',2E12.4)
C
      IF(ENE0-PAIRTH)3001,3001,3401
C   DIFFERENTIAL CROSS SECTION IS UNIFORM DISTRIBUTION
3401  EPSI=(1.-2./ENE0)*RN(DAM)+1./ENE0
C
3004  CHG1=1.
      CHG0=-1.
      ECUT0=ECUTEL
      ECUT1=ECUTPS
C
C----- TEMP.  CONVERSION POINT DISTRIBUTION
C      CALL CONPHS(PAQ0)
C
      FLEN0=0.
C
      IF(IPRO.GT.0) WRITE(6,2282)
2282  FORMAT(' CASSHW: AT 3030: GO TO 19 ')
C
      GO TO 19
C
3030  CALL COMPT(ENE0,ALOGEN,EPSI)
C
      IF(IPRO.GT.0) WRITE(6,2312) ENE0,EPSI
2312  FORMAT(' CASSHW: AFTER COMPT ENE0 EPSI ',2E12.4)
C
      IF(EPSI) 3001,3001,38
C
   38 CHG1=-1.
      ECUT1=ECUTEL
      ENEX=ENE0*EPSI
      CTH0=1.-1./ENEX+1./ENE0
      STH0=SQRT(1.-CTH0*CTH0)
      ENE1=ENE0-ENEX+1.
      PE=SQRT(ENE1*ENE1-1.)
C
      IF(IPRO.GT.0) WRITE(6,2313) PE
2313  FORMAT(' CASSHW: AT 38  PE             ',2E12.4)
C
      IF(PE.LE.0.)GOTO 3037
      CTH1=(ENE0-ENEX*CTH0)/PE
      IF(CTH1.GT.1.)CTH1=1.
      STH1=SQRT(1.-CTH1*CTH1)
3037  ENE0=ENE0+1.
C---- TEMP. PHOTON PATH LENGTH HIST.
C     CALL CONPHS(PAQ0)
C
C
      IF(IPRO.GT.0) WRITE(6,2283)
2283  FORMAT(' CASSHW: AT 3037: GO TO 12 ')
C
      GO TO 12
C
C---- PHOTO-ELECTRIC EFFECT
3050  CONTINUE
C     CALL CONPHS(PAQ0)
C
      CHG0 = -1.
      ECUT0=ECUTEL
      ENE0 = ENE0+0.82
      FLEN0 = 0.0
      CTH0 = 2.*(RN(DUM)-0.5)
      STH0 = SQRT(1.-CTH0**2)
      CALL RANAZI(CF,SF)
      PAQ0(7) = CF*STH0
      PAQ0(8) = SF*STH0
      PAQ0(9) = CTH0
C
      IF(IPRO.GT.0) WRITE(6,2284)
2284  FORMAT(' CASSHW: AFTER PHOTOEL EFF.  : GO TO 100')
C
      GO TO 100
C
C*******NOW SECONDARY PARTICLE IS IN PA1
C
11    CONTINUE
C
      CHG1=0.
      ECUT1=ECUTPH
19    ENE1=ENE0*EPSI
12    CONTINUE
      ENE0=ENE0-ENE1
13    DO 4010 I=4,9
4010  PAQ1(I)=PAQ0(I)
C
C---- GET NEWDIRECTIONS BY M0LLER/BHABHA/COMPTON SCATTERINGS**
C
      IF(IPRO.GT.0) WRITE(6,2314) ENE0,STH0,STH1
2314  FORMAT(' CASSHW: AT 4010 ENE0 STH0-1   ',3E12.4)
C
      IF(STH0.EQ.0. .AND. STH1.EQ.0.) GO TO 4110
      CALL RANAZI(CF,SF)
      IF(STH0.NE.0.) CALL NEWDR2(PA0(1,3),CTH0,STH0,CF,SF)
C
4100  CONTINUE
C
      IF(IPRO.GT.0) WRITE(6,2315) STH1,ENE1,ECUT1
2315  FORMAT(' CASSHW: AT 4100 STH1 ENE1 ECUT1  ',3E12.4)
C
      IF(STH1)4111,4110,4111
C---- SKIP LOW ENERGY SECONDARIES TO SAVE BUFFER SPACE AND TIME.
 4111 IF(ENE1 .LE. ECUT1) GOTO 100
      CF=-CF
      SF=-SF
      CALL NEWDR2(PA1(1,3),CTH1,STH1,CF,SF)
4110   CONTINUE
      FLEN1=0.
C**************
C     ***PA1 IS ALWAYS STACKED
      IF(NSP.LT.0)NSP=0
      NSP=NSP+1
C
      IF(IPRO.NE.0) WRITE(6,2316) NSP,MNP
2316  FORMAT(' CASSHW: AT 4210 NSP MNP ',2I5)
C
      IF(NSP.GT.MNP)GO TO 4202
      DO 4210 I=1,9
4210  SPTCL(I,NSP)=PAQ1(I)
C---- CHECK THE MAXIMUM NSP
C     DATA MAXNSP/10/
C     IF(NSP.LE.MAXNSP) GO TO 100
C     MAXNSP = NSP
C     IF(NSP.GT.200.OR.MOD(NSP,10).EQ.0) WRITE(6,6000) MAXNSP
C6000 FORMAT(' MAXNSP NEW MAXIMUM=',I4)
C
      IF(IPRO.GT.0) WRITE(6,2286)
2286  FORMAT(' CASSHW: AT MAXNSP, GO TO 100')
C
      GO TO 100
4202  IER=2
CCCCC CALL MSG('PRTLC OVERFLOW- IER=1;;')
      GO TO 301
C**************
C
C THIS PARTICLE OUT OF THE MATTER
300   NP=NP+1
C
      IF(IPRO.NE.0) WRITE(6,2287) NP,MNP
2287  FORMAT(' CASSHW: AT OUT OF MATTER 300  NP MNP ',2I5)
C
      IF(NP.GT.MNP)GOTO 301
      DO 310 I=1,9
310   PRTCL(I,NP)=PAQ0(I)
C
C           CALL CHKEL(PA0)
      GOTO 200
C
301   IER=1
      RETURN
400   NSP=0
C
      IF(IPRO.NE.0) WRITE(6,2259)
2259  FORMAT(' CASSHW: LEAVING WITH NSP=0 ')
C
      RETURN
      END
