[u/mrichter/AliRoot.git] / GEANT321 / neutron / colisn.F

*
* $Id$
*
* $Log$
* Revision 1.1.1.1  1995/10/24 10:21:56  cernlib
* Geant
*
*
#include "geant321/pilot.h"
*CMZ :  3.21/04 23/02/95  14.46.01  by  S.Giani
*-- Author :
      SUBROUTINE COLISN(D,LD,IGAMS,LGAM,INABS,LNAB,ITHRMS,LTHRM,
     + IDICTS,LDICT,NTX,NTS,IGCBS,LGCB,AWR,Q,NSEI,NAEI,NMT2,NMT4,
     + NMT16,NMT17,NMT18,NMT22,NMT23,NMT24,NMT28,NMT51,NMT91,
     + NMT102,NMT103,NMT104,NMT105,NMT106,NMT107,NMT108,NMT109,
     + NMT111,NMT112,NMT113,NMT114,IGCBS2,LGCB2,KZ,LR,QLR,
     + IIN,IIM)
C        THIS ROUTINE IS CALLED AT EACH COLLISION TO
C        DETERMINE THE POST COLLISION PARAMETERS
#include "geant321/minput.inc"
#include "geant321/mconst.inc"
#include "geant321/mnutrn.inc"
#include "geant321/mapoll.inc"
#include "geant321/mcross.inc"
#include "geant321/mmass.inc"
#include "geant321/mupsca.inc"
#include "geant321/mpstor.inc"
#include "geant321/mmicab.inc"
      DIMENSION D(*),LD(*),IGAMS(*),LGAM(*),INABS(*),LNAB(*),
     + ITHRMS(*),LTHRM(*),IDICTS(NNR,NNUC),LDICT(NNR,NNUC),NTX(*),
     + NTS(*),IGCBS(NGR,NNUC),LGCB(NGR,NNUC),AWR(*),Q(NQ,NNUC),
     + NSEI(*),NAEI(*),NMT2(*),NMT4(*),NMT16(1),NMT17(*),NMT18(*),
     + NMT22(*),NMT23(*),NMT24(*),NMT28(*),NMT51(*),NMT91(*),
     + NMT102(*),NMT103(*),NMT104(*),NMT105(*),NMT106(*),NMT107(*),
     + NMT108(*),NMT109(*),NMT111(*),NMT112(*),NMT113(*),NMT114(*),
     + IGCBS2(NGR,NNUC),LGCB2(NGR,NNUC),KZ(*),LR(NQ,NNUC),QLR(NQ,NNUC),
     + FM(MAXNEU)
C
      CHARACTER*80 COMM
C
      DATA QBE8/-7.3686E+06/
      SAVE
      CALL GTMED(NMED,MED)
C       INITIALIZE THE COUNTERS AND FLAGS
C       ITRY ALLOWS FOR MULTIPLE ATTEMPTS IF THE ENDF/B PARTIAL
C       CROSS SECTIONS DO NOT EXACTLY SUM TO THE TOTAL
   10 ISTOP=0
      ITRY=0
      NCOL=NCOL+1
      SIGREC=0.0
      SUMREC=0.0
      FSUMS = 1.0
      FSUMIS = 1.0
      FSUMA = 1.0
   20 ID=0
      MT=0
      QI=0.0
      LRI=0
      QLRI=0.0
      DO 30 I=1,MAXNEU
         FM(I)=1.0
   30 CONTINUE
      DO 40 I=1,MAXNEU
         ENE(I)=0.0
   40 CONTINUE
      INEU = 0
      U1=0.0
      V1=0.0
      W1=0.0
      ERFGM=0.0
      IFLG=0
      LIFLAG=0
      AWRI=AWR(IIN)
      KZI=KZ(IIM)
#if defined(CERNLIB_MDEBUG)
      PRINT *,' COLISN: A=',AWRI,' K=',KZI
#endif
C       INITIALIZE THE CROSS SECTION VARIABLES
      SIGT=0.0
      SIGTNS=0.0
      SIGTNA=0.0
      SIGNES=0.0
      SIGNIS=0.0
      SGNISD=0.0
      SGNISC=0.0
      SIGN2N=0.0
      SIGN3N=0.0
      SIGNNA=0.0
      SGNN3A=0.0
      SGN2NA=0.0
      SIGNNP=0.0
      SIGNF=0.0
      SIGNG=0.0
      SIGNP=0.0
      SIGND=0.0
      SIGNT=0.0
      SGN3HE=0.0
      SIGNA=0.0
      SIGN2A=0.0
      SIGN3A=0.0
      SIGN2P=0.0
      SIGNPA=0.0
      SGNT2A=0.0
      SGND2A=0.0
      SUMIS=0.0
      SUMS=0.0
      SUMA=0.0
C       DETERMINE THE TOTAL CROSS SECTION (MT-1)
      L1=LDICT(1,IIN)
      IF(L1.EQ.0)GO TO 50
      LS1=IDICTS(1,IIN) + LMOX2
      LEN=L1/2
      CALL TBSPLT(D(LS1),E,LEN,SIGT)
      GO TO 60
   50 CONTINUE
      COMM=' COLISN: TOTAL CROSS SECTION LENGTH IS ZERO'
      SIGREC = 0.0
      SUMREC = 0.0
      GOTO 980
   60 CONTINUE
C       DETERMINE THE TOTAL NEUTRON DISAPPEARANCE (MT-102 TO MT-114
C       AND MT-18)
      L1=LNAB(IIN)
      IF(L1.EQ.0)GO TO 70
      LS1=INABS(IIN)+LMOX2
      LEN=L1/2
      CALL TBSPLT(D(LS1),E,LEN,SIGTNA)
      GO TO 80
   70 SIGTNA=0.0
   80 CONTINUE
C       DETERMINE THE NON-ABSORPTION PROBABILITY
      PNAB=1.0-SIGTNA/SIGT
C       DETERMINE THE COLLISION TYPE (ABSORPTION OR SCATTERING)
      R=FLTRNF(0)
      IF(R.GT.PNAB)GO TO 570
C       THE REACTION TYPE IS A SCATTER
      NSEI(IIN)=NSEI(IIN)+1
      SIGTNS=SIGT-SIGTNA
      R=FLTRNF(0)
C       DETERMINE (N,N) CROSS SECTION (MT-2)
      ID=2
      L1=LDICT(ID,IIN)
      IF(L1.EQ.0)GO TO 110
      LS1=IDICTS(ID,IIN)+LMOX2
      LEN=L1/2
      CALL TBSPLT(D(LS1),E,LEN,SIGNES)
      SUMS=SIGNES/SIGTNS*FSUMS
      IF(R.GT.SUMS)GO TO 120
C       REACTION TYPE IS (N,N)
      NMT2(MED)=NMT2(MED)+1
C       DETERMINE IF SCATTERING OCCURS IN THE THERMAL ENERGY RANGE
      ETHERM = 500.*8.617E-5*TEMP/AWRI
      IF(E.LE.ETHERM) THEN
C Reaction is a thermal scatter
         CALL THRMSC(D,D,ITHRMS,LTHRM,E,U,V,W,TEMP,FM,AWR,IIN,
     +               IFLG,IOUT)
         QI=Q(ID,IIN)
         CALL CMLABE(D,D,AWRI,KZI,ID,FM,QI,IFLG)
         EP = E
         VP = V
         UP = U
         WP = W
         AGEP = AGE
         MTP = 2
         CALL STOPAR(IDNEU,NNEU)
         RETURN
      ENDIF
C       DETERMINE THE COSINE OF THE NEUTRON SCATTERING ANGLE IN THE
C       CENTER OF MASS COORDINATE SYSTEM
      L1=LDICT(67,IIN)
      IF(L1.EQ.0)GO TO 90
      LS1=IDICTS(67,IIN)+LMOX2
      LEN=L1
      CALL CANGLE(D(LS1),D(LS1),E,FM(1),LEN)
      GO TO 100
C       ASSUME ISOTROPIC IN THE CENTER OF MASS COORDINATE SYSTEM
   90 R=FLTRNF(0)
      FM(1)=2.0*R-1.0
C       DETERMINE THE EXIT COLLISION PARAMETERS IN THE LABORATORY
C       COORDINATE SYSTEM
  100 CONTINUE
      QI=Q(ID,IIN)
      CALL CMLABE(D,D,AWRI,KZI,ID,FM(1),QI,IFLG)
      EP = E
      VP = V
      UP = U
      WP = W
      AGEP = AGE
      MTP = 2
      CALL STOPAR(IDNEU,NNEU)
      RETURN
  110 SIGNES=0.0
  120 CONTINUE
C       DETERMINE (N,N") CROSS SECTION (MT-4)
      ID=3
      L1=LDICT(ID,IIN)
      IF(L1.EQ.0)GO TO 240
      LS1=IDICTS(ID,IIN)+LMOX2
      LEN=L1/2
      CALL TBSPLT(D(LS1),E,LEN,SIGNIS)
      SUMS=SUMS+SIGNIS/SIGTNS*FSUMS
      IF(R.GT.SUMS)GO TO 250
C       REACTION TYPE IS (N,N")
      NMT4(MED)=NMT4(MED)+1
C       DETERMINE (N,N"-DISCRETE) CROSS SECTION (MT-51 TO MT-90)
      R=FLTRNF(0)
      DO 130 I=14,53
         L1=LDICT(I,IIN)
         IF(L1.EQ.0)GO TO 170
         LS1=IDICTS(I,IIN)+LMOX2
         LEN=L1/2
         CALL XSECNU(D,LEN,E,SGNISD,LS1,L1)
         SUMIS=SUMIS+SGNISD/SIGNIS*FSUMIS
         IF(R.LE.SUMIS)GO TO 140
  130 CONTINUE
      GO TO 180
  140 CONTINUE
C       REACTION TYPE IS (N,N") DISCRETE
      NMT51(MED)=NMT51(MED)+1
      I=I+68
C       DETERMINE THE COSINE OF THE NEUTRON SCATTERING ANGLE IN THE
C       CENTER OF MASS COORDINATE SYSTEM
      L1=LDICT(I,IIN)
      IF(L1.EQ.0)GO TO 150
      LS1=IDICTS(I,IIN)+LMOX2
      LEN=L1
      CALL CANGLE(D(LS1),D(LS1),E,FM(1),LEN)
      GO TO 160
C       ASSUME ISOTROPIC IN THE CENTER OF MASS COORDINATE SYSTEM
  150 R=FLTRNF(0)
      FM(1)=2.0*R-1.0
C       DETERMINE THE EXIT COLLISION PARAMETERS IN THE LABORATORY
C       COORDINATE SYSTEM
  160 ID=I-68
      QI=Q(ID,IIN)
      LRI=LR(ID,IIN)
      QLRI=QLR(ID,IIN)
      CALL CMLABI(D,D,AWRI,KZI,ID,FM(1),QI,IFLG,LIFLAG,LRI)
C Re-sample if no energy determined in CMLABI
      IF(IFLG.EQ.-1) GOTO 10
      EP = E
      VP = V
      UP = U
      WP = W
      AGEP = AGE
      MTP = 51
      CALL STOPAR(IDNEU,NNEU)
      IF(LRI.EQ.22)GO TO 520
      IF(LRI.EQ.23)GO TO 530
      IF(LRI.EQ.28)GO TO 540
      CALL PHOTON(D,D,IDICTS,LDICT,NTX,NTS,IGCBS,LGCB,AWR,
     +IGCBS2,LGCB2,LR,IGAMS,LGAM,QI,ID,IIN,LRI,SGNISD)
      RETURN
  170 SGNISD=0.0
  180 CONTINUE
C       DISCRETE INELASTIC SCATTERING LEVEL WAS NOT CHOSEN
C       DETERMINE (N,N"-CONTINUUM) CROSS SECTION (MT-91)
      ID=54
      L1=LDICT(ID,IIN)
      IF(L1.EQ.0)GO TO 210
      LS1=IDICTS(ID,IIN)+LMOX2
      LEN=L1/2
      CALL TBSPLT(D(LS1),E,LEN,SGNISC)
      SUMIS=SUMIS+SGNISC/SIGNIS*FSUMIS
      IF(R.GT.SUMIS)GO TO 220
C       REACTION TYPE IS (N,N") CONTINUUM
      NMT91(MED)=NMT91(MED)+1
C       DETERMINE THE COSINE OF THE NEUTRON SCATTERING ANGLE IN THE
C       LABORATORY COORDINATE SYSTEM
      L1=LDICT(122,IIN)
      IF(L1.EQ.0)GO TO 190
      LS1=IDICTS(122,IIN)+LMOX2
      LEN=L1
      CALL CANGLE(D(LS1),D(LS1),E,FM(1),LEN)
      GO TO 200
C       ASSUME ISOTROPIC IN THE LABORATORY COORDINATE SYSTEM
  190 CALL GTISO(U1,V1,W1)
      U=U1
      V=V1
      W=W1
      LIFLAG=1
C       DETERMINE THE EXIT NEUTRON ENERGY IN THE LABORATORY
C       COORDINATE SYSTEM
  200 L1=LDICT(133,IIN)
      IF(L1.EQ.0)GO TO 230
      LS1=IDICTS(133,IIN)+LMOX2
      CALL SECEGY(EX,D(LS1),E,D(LS1))
      E=EX
      IFLG=1
C       DETERMINE THE EXIT COLLISION PARAMETERS IN THE LABORATORY
C       COORDINATE SYSTEM
      QI=Q(ID,IIN)
      LRI=LR(ID,IIN)
      QLRI=QLR(ID,IIN)
      CALL CMLABI(D,D,AWRI,KZI,ID,FM(1),QI,IFLG,LIFLAG,LRI)
C Re-sample if no energy determined in CMLABI
      IF(IFLG.EQ.-1) GOTO 10
      EP = E
      VP = V
      UP = U
      WP = W
      AGEP = AGE
      MTP = 91
      CALL STOPAR(IDNEU,NNEU)
      IF(LRI.EQ.22)GO TO 520
      IF(LRI.EQ.23)GO TO 530
      IF(LRI.EQ.28)GO TO 540
      CALL PHOTON(D,D,IDICTS,LDICT,NTX,NTS,IGCBS,LGCB,AWR,
     +IGCBS2,LGCB2,LR,IGAMS,LGAM,QI,ID,IIN,LRI,SGNISC)
      RETURN
  210 SGNISC=0.0
  220 CONTINUE
      COMM= ' COLISN: INELASTIC SCATTERING CROSS SECTION WAS NOT CHOSEN'
      NMT4(MED)=NMT4(MED)-1
      FSUMIS = 1./SUMIS
      GO TO 550
  230 CONTINUE
      COMM=' COLISN: NO SECONDARY ENERGY DISTRIBUTION WAS FOUND MT-91'
      ISTOP=1
      GO TO 560
  240 SIGNIS=0.0
  250 CONTINUE
C       DETERMINE (N,2N) CROSS SECTION (MT-16)
      ID=8
      L1=LDICT(ID,IIN)
      IF(L1.EQ.0)GO TO 290
      LS1=IDICTS(ID,IIN)+LMOX2
      LEN=L1/2
      CALL TBSPLT(D(LS1),E,LEN,SIGN2N)
      SUMS=SUMS+SIGN2N/SIGTNS*FSUMS
      IF(R.GT.SUMS)GO TO 300
C       REACTION TYPE IS (N,2N)
      NMT16(MED)=NMT16(MED)+1
C       USE THE ONE NEUTRON EMISSION MODEL AND MULTIPLY THE
C       WEIGHT BY TWO
C changed to 2 neutron production CZ July 30, 1992
CZ      WATE=2.0*WATE
C       DETERMINE THE COSINE OF THE NEUTRON SCATTERING ANGLE IN THE
C       LABORATORY COORDINATE SYSTEM
      L1=LDICT(72,IIN)
      IF(L1.EQ.0)GO TO 260
      LS1=IDICTS(72,IIN)+LMOX2
      LEN=L1
C get scattering angle for 1. neutron
      CALL CANGLE(D(LS1),D(LS1),E,FM(1),LEN)
C get scattering angle for 2. neutron
      CALL CANGLE(D(LS1),D(LS1),E,FM(2),LEN)
      GO TO 270
C       ASSUME ISOTROPIC IN THE LABORATORY COORDINATE SYSTEM
  260 CONTINUE
      IFLG=1
C       DETERMINE THE EXIT NEUTRON ENERGY IN THE LABORATORY
C       COORDINATE SYSTEM
  270 INEU = 2
      L1=LDICT(123,IIN)
      IF(L1.EQ.0)GO TO 280
      LS1=IDICTS(123,IIN)+LMOX2
      CALL GETENE(E,D(LS1),D(LS1),INEU)
C       DETERMINE THE EXIT COLLISION PARAMETERS IN THE LABORATORY
C       COORDINATE SYSTEM
      QI=Q(ID,IIN)
      CALL N2NN3N(D,D,AWRI,KZI,ID,FM,QI,IFLG)
      CALL PHOTON(D,D,IDICTS,LDICT,NTX,NTS,IGCBS,LGCB,AWR,
     +IGCBS2,LGCB2,LR,IGAMS,LGAM,QI,ID,IIN,LRI,SIGN2N)
      RETURN
  280 CONTINUE
      COMM=' COLISN: NO SECONDARY ENERGY DISTRIBUTION WAS FOUND MT-16'
      ISTOP=1
      GO TO 560
  290 SIGN2N=0.0
  300 CONTINUE
C       DETERMINE (N,3N) CROSS SECTION (MT-17)
      ID=9
      L1=LDICT(ID,IIN)
      IF(L1.EQ.0)GO TO 350
      LS1=IDICTS(ID,IIN)+LMOX2
      LEN=L1/2
      CALL TBSPLT(D(LS1),E,LEN,SIGN3N)
      SUMS=SUMS+SIGN3N/SIGTNS*FSUMS
      IF(R.GT.SUMS)GO TO 360
C       REACTION TYPE IS (N,3N)
      NMT17(MED)=NMT17(MED)+1
C       USE THE ONE NEUTRON EMISSION MODEL AND MULTIPLY THE
C       WEIGHT BY THREE
C changed to 3 neutron production CZ July 30,1992
CZ      WATE=3.0*WATE
C       DETERMINE THE COSINE OF THE NEUTRON SCATTERING ANGLE IN THE
C       LABORATORY COORDINATE SYSTEM
      L1=LDICT(73,IIN)
      IF(L1.EQ.0)GO TO 320
      LS1=IDICTS(73,IIN)+LMOX2
      LEN=L1
      DO 310 KN=1,3
         CALL CANGLE(D(LS1),D(LS1),E,FM(KN),LEN)
  310 CONTINUE
      GO TO 330
C       ASSUME ISOTROPIC IN THE LABORATORY COORDINATE SYSTEM
  320 CONTINUE
      IFLG=1
C       DETERMINE THE EXIT NEUTRON ENERGY IN THE LABORATORY
C       COORDINATE SYSTEM
  330 L1=LDICT(124,IIN)
      IF(L1.EQ.0)GO TO 340
      LS1=IDICTS(124,IIN)+LMOX2
      INEU = 3
      CALL GETENE(E,D(LS1),D(LS1),INEU)
C       DETERMINE THE EXIT COLLISION PARAMETERS IN THE LABORATORY
C       COORDINATE SYSTEM
      QI=Q(ID,IIN)
      CALL N2NN3N(D,D,AWRI,KZI,ID,FM,QI,IFLG)
      CALL PHOTON(D,D,IDICTS,LDICT,NTX,NTS,IGCBS,LGCB,AWR,
     +IGCBS2,LGCB2,LR,IGAMS,LGAM,QI,ID,IIN,LRI,SIGN3N)
      RETURN
  340 CONTINUE
      COMM= ' COLISN; NO SECONDARY ENERGY DISTRIBUTION WAS FOUND MT-17'
      ISTOP=1
      GO TO 560
  350 SIGN3N=0.0
  360 CONTINUE
C       DETERMINE (N,N"A) CROSS SECTION (MT-22)
      ID=11
      L1=LDICT(ID,IIN)
      IF(L1.EQ.0)GO TO 400
      LS1=IDICTS(ID,IIN)+LMOX2
      LEN=L1/2
      CALL TBSPLT(D(LS1),E,LEN,SIGNNA)
      SUMS=SUMS+SIGNNA/SIGTNS*FSUMS
      IF(R.GT.SUMS)GO TO 410
C       REACTION TYPE IS (N,N"A)
      NMT22(MED)=NMT22(MED)+1
C       DETERMINE THE COSINE OF THE NEUTRON SCATTERING ANGLE IN THE
C       LABORATORY COORDINATE SYSTEM
      L1=LDICT(75,IIN)
      IF(L1.EQ.0)GO TO 370
      LS1=IDICTS(75,IIN)+LMOX2
      LEN=L1
      CALL CANGLE(D(LS1),D(LS1),E,FM(1),LEN)
      GO TO 380
C       ASSUME ISOTROPIC IN THE LABORATORY COORDINATE SYSTEM
  370 CALL GTISO(U1,V1,W1)
      U=U1
      V=V1
      W=W1
      LIFLAG=1
C       DETERMINE THE EXIT NEUTRON ENERGY IN THE LABORATORY
C       COORDINATE SYSTEM
  380 L1=LDICT(126,IIN)
      IF(L1.EQ.0)GO TO 390
      LS1=IDICTS(126,IIN)+LMOX2
      CALL SECEGY(EX,D(LS1),E,D(LS1))
      E=EX
      IFLG=1
C       DETERMINE THE EXIT COLLISION PARAMETERS IN THE LABORATORY
C       COORDINATE SYSTEM
      QI=Q(ID,IIN)
      LRI=22
      CALL CMLABI(D,D,AWRI,KZI,ID,FM(1),QI,IFLG,LIFLAG,LRI)
C Re-sample if no energy determined in CMLABI
      IF(IFLG.EQ.-1) GOTO 10
      UP = U
      VP = V
      WP = W
      EP = E
      AGEP = AGE
      MTP = 22
      CALL STOPAR(IDNEU,NNEU)
      KZ1=2
      KZ2=KZI-KZ1
      ATAR=AWRI*AN
      A1=AA
      A2=ATAR-AA
      Z1=ZA
      Z2=A2*9.31075E+08
      MT=22
      CALL NN2BOD(D,D,KZ1,KZ2,A1,A2,Z1,Z2,ATAR,QI,MT)
      CALL PHOTON(D,D,IDICTS,LDICT,NTX,NTS,IGCBS,LGCB,AWR,
     +IGCBS2,LGCB2,LR,IGAMS,LGAM,QI,ID,IIN,LRI,SIGNNA)
      RETURN
  390 CONTINUE
      COMM=' COLISN; NO SECONDARY ENERGY DISTRIBUTION WAS FOUND MT-22'
      ISTOP=1
      GO TO 560
  400 SIGNNA=0.0
  410 CONTINUE
C       DETERMINE (N,2NA) CROSS SECTION (MT-24)
      ID=12
      L1=LDICT(ID,IIN)
      IF(L1.EQ.0)GO TO 450
      LS1=IDICTS(ID,IIN)+LMOX2
      LEN=L1/2
      CALL TBSPLT(D(LS1),E,LEN,SGN2NA)
      SUMS=SUMS+SGN2NA/SIGTNS*FSUMS
      IF(R.GT.SUMS)GO TO 460
C       REACTION TYPE IS (N,2NA)
      NMT24(MED)=NMT24(MED)+1
C       USE THE ONE NEUTRON EMISSION MODEL AND MULTIPLY THE
C       WEIGHT BY TWO
C changed to 2 neutron production CZ July 30,1992
CZ      WATE=2.0*WATE
C       DETERMINE THE COSINE OF THE NEUTRON SCATTERING ANGLE IN THE
C       LABORATORY COORDINATE SYSTEM
      L1=LDICT(76,IIN)
      IF(L1.EQ.0)GO TO 420
      LS1=IDICTS(76,IIN)+LMOX2
      LEN=L1
      CALL CANGLE(D(LS1),D(LS1),E,FM(1),LEN)
      CALL CANGLE(D(LS1),D(LS1),E,FM(2),LEN)
      GO TO 430
C       ASSUME ISOTROPIC IN THE LABORATORY COORDINATE SYSTEM
  420 CONTINUE
      IFLG=1
C       DETERMINE THE EXIT NEUTRON ENERGY IN THE LABORATORY
C       COORDINATE SYSTEM
  430 L1=LDICT(127,IIN)
      IF(L1.EQ.0)GO TO 440
      LS1=IDICTS(127,IIN)+LMOX2
      INEU=2
      CALL GETENE(E,D(LS1),D(LS1),INEU)
C       DETERMINE THE EXIT COLLISION PARAMETERS IN THE LABORATORY
C       COORDINATE SYSTEM
      QI=Q(ID,IIN)
      CALL N2NN3N(D,D,AWRI,KZI,ID,FM,QI,IFLG)
      KZ1=2
      KZ2=KZI-KZ1
      ATAR=AWRI*AN
      A1=AA
      A2=ATAR-AN-AA
      Z1=ZA
      Z2=A2*9.31075E+08
      MT=24
      CALL NN2BOD(D,D,KZ1,KZ2,A1,A2,Z1,Z2,ATAR,QI,MT)
      CALL PHOTON(D,D,IDICTS,LDICT,NTX,NTS,IGCBS,LGCB,AWR,
     +IGCBS2,LGCB2,LR,IGAMS,LGAM,QI,ID,IIN,LRI,SGN2NA)
      RETURN
  440 CONTINUE
      COMM=' COLISN; NO SECONDARY ENERGY DISTRIBUTION WAS FOUND MT-24'
      ISTOP=1
      GO TO 560
  450 SGN2NA=0.0
  460 CONTINUE
C       DETERMINE (N,N"P) CROSS SECTION (MT-28)
      ID=13
      L1=LDICT(ID,IIN)
      IF(L1.EQ.0)GO TO 500
      LS1=IDICTS(ID,IIN)+LMOX2
      LEN=L1/2
      CALL TBSPLT(D(LS1),E,LEN,SIGNNP)
      SUMS=SUMS+SIGNNP/SIGTNS*FSUMS
      IF(R.GT.SUMS)GO TO 510
C       REACTION TYPE IS (N,N"P)
      NMT28(MED)=NMT28(MED)+1
C       DETERMINE THE COSINE OF THE NEUTRON SCATTERING ANGLE IN THE
C       LABORATORY COORDINATE SYSTEM
      L1=LDICT(77,IIN)
      IF(L1.EQ.0)GO TO 470
      LS1=IDICTS(77,IIN)+LMOX2
      LEN=L1
      CALL CANGLE(D(LS1),D(LS1),E,FM(1),LEN)
      GO TO 480
C       ASSUME ISOTROPIC IN THE LABORATORY COORDINATE SYSTEM
  470 CALL GTISO(U1,V1,W1)
      U=U1
      V=V1
      W=W1
      LIFLAG=1
C       DETERMINE THE EXIT NEUTRON ENERGY IN THE LABORATORY
C       COORDINATE SYSTEM
  480 L1=LDICT(128,IIN)
      IF(L1.EQ.0)GO TO 490
      LS1=IDICTS(128,IIN)+LMOX2
      CALL SECEGY(EX,D(LS1),E,D(LS1))
      E=EX
      IFLG=1
C       DETERMINE THE EXIT COLLISION PARAMETERS IN THE LABORATORY
C       COORDINATE SYSTEM
      QI=Q(ID,IIN)
      LRI=28
      CALL CMLABI(D,D,AWRI,KZI,ID,FM(1),QI,IFLG,LIFLAG,LRI)
C Re-sample if no energy determined in CMLABI
      IF(IFLG.EQ.-1) GOTO 10
      EP = E
      UP = U
      VP = V
      WP = W
      AGEP = AGE
      MTP = 28
      CALL STOPAR(IDNEU,NNEU)
      KZ1=1
      KZ2=KZI-KZ1
      ATAR=AWRI*AN
      A1=AP
      A2=ATAR-AP
      Z1=ZP
      Z2=A2*9.31075E+08
      MT=28
      CALL NN2BOD(D,D,KZ1,KZ2,A1,A2,Z1,Z2,ATAR,QI,MT)
      CALL PHOTON(D,D,IDICTS,LDICT,NTX,NTS,IGCBS,LGCB,AWR,
     +IGCBS2,LGCB2,LR,IGAMS,LGAM,QI,ID,IIN,LRI,SIGNNP)
      RETURN
  490 CONTINUE
      COMM=' COLISN; NO SECONDARY ENERGY DISTRIBUTION FOUND FOR MT-28'
      SIGREC=SIGTNS
      SUMREC=SUMS
      ISTOP=1
      GO TO 560
  500 SIGNNP=0.0
  510 CONTINUE
      FSUMS = 1./SUMS
      GO TO 550
  520 CONTINUE
C       REACTION TYPE IS (N,N"A) USING LR FLAG
      NMT22(MED)=NMT22(MED)+1
      SIGNNA=SGNISD
      IF(ID.EQ.54)SIGNNA=SGNISC
      KZ1=2
      KZ2=KZI-KZ1
      ATAR=AWRI*AN
      A1=AA
      A2=ATAR-AA
      Z1=ZA
      Z2=A2*9.31075E+08
      MT=22
      CALL LR2BOD(D,D,KZ1,KZ2,A1,A2,Z1,Z2,ATAR,QI,QLRI,ID,MT)
      CALL PHOTON(D,D,IDICTS,LDICT,NTX,NTS,IGCBS,LGCB,AWR,
     +IGCBS2,LGCB2,LR,IGAMS,LGAM,QI,ID,IIN,LRI,SIGNNA)
      RETURN
  530 CONTINUE
C       REACTION TYPE IS (N,N"3A) USING LR FLAG
C       CARBON-12 IS CURRENTLY THE ONLY ELEMENT CONTAINING MT-23
      NMT23(MED)=NMT23(MED)+1
      SGNN3A=SGNISD
      IF(ID.EQ.54)SGNN3A=SGNISC
      KZ1=2
      KZ2=KZI-KZ1
      ATAR=AWRI*AN
      A1=AA
      A2=ATAR-AA
      Z1=ZA
      Z2=A2*9.31075E+08
C       QBE8 IS THE MASS DIFFERENCE FOR A CARBON-ALPHA EMISSION
      MT=23
      CALL LR2BOD(D,D,KZ1,KZ2,A1,A2,Z1,Z2,ATAR,QI,QBE8,ID,MT)
      KZ1=2
      KZ2=KZ2-KZ1
      ATAR=AWRI*AN
      A1=AA
      A2=A2-AA
      Z1=ZA
      Z2=A2*9.31075E+08
      MT=23
      CALL LR2BOD(D,D,KZ1,KZ2,A1,A2,Z1,Z2,ATAR,QBE8,QLRI,ID,MT)
      CALL PHOTON(D,D,IDICTS,LDICT,NTX,NTS,IGCBS,LGCB,AWR,
     +IGCBS2,LGCB2,LR,IGAMS,LGAM,QI,ID,IIN,LRI,SGNN3A)
      RETURN
  540 CONTINUE
C       REACTION TYPE IS (N,N"P) USING LR FLAG
      NMT28(MED)=NMT28(MED)+1
      SIGNNP=SGNISD
      IF(ID.EQ.54)SIGNNP=SGNISC
      KZ1=1
      KZ2=KZI-KZ1
      ATAR=AWRI*AN
      A1=AP
      A2=ATAR-AP
      Z1=ZP
      Z2=A2*9.31075E+08
      MT=28
      CALL LR2BOD(D,D,KZ1,KZ2,A1,A2,Z1,Z2,ATAR,QI,QLRI,ID,MT)
      CALL PHOTON(D,D,IDICTS,LDICT,NTX,NTS,IGCBS,LGCB,AWR,
     +IGCBS2,LGCB2,LR,IGAMS,LGAM,QI,ID,IIN,LRI,SIGNNP)
      RETURN
  550 ITRY=ITRY+1
      NSEI(IIN)=NSEI(IIN)-1
      ISTOP = 1
      IF((FSUMS.GT.0.1.AND.FSUMS.LE.10.0).AND.
     +   (FSUMIS.GT.0.1.AND.FSUMIS.LE.10.0)) ISTOP = 0
      IF(ISTOP.EQ.0.AND.ITRY.LE.5) GOTO 20
C       A SCATTERING REACTION WAS NOT CHOSEN
      COMM=' COLISN: A SCATTERING REACTION TYPE WAS NOT CHOSEN '
      SIGREC=SIGTNS
      SUMREC=SUMS
      GOTO 980
  560 CONTINUE
      IF(ISTOP.EQ.1)GO TO 980
      ITRY=0
      GO TO 20
C       THE REACTION TYPE IS AN ABSORPTION
  570 NAEI(IIN)=NAEI(IIN)+1
      R=FLTRNF(0)
C       DETERMINE THE FISSION CROSS SECTION (MT-18)
C       THE TREATMENT OF THE FISSION REACTION ASSUMES THE FISSION
C       CROSS SECTION IS STORED AS NUBAR*SIGF
      ID=10
      L1=LDICT(ID,IIN)
      IF(L1.EQ.0)GO TO 640
      LS1=IDICTS(ID,IIN)+LMOX2
      LEN=L1/2
      CALL TBSPLT(D(LS1),E,LEN,SIGNF)
C       DETERMINE THE AVERAGE NUMBER OF NEUTRONS EMITTED PER FISSION
C       EVENT (NUBAR)
      L1=LDICT(134,IIN)
      IF(L1.EQ.0)GO TO 630
      LS1=IDICTS(134,IIN)+LMOX2
      LEN=L1
      CALL GETNU(D(LS1),D(LS1),EOLD,LEN,XNU)
C       EXTRACT THE FISSION CROSS SECTION FROM THE NUBAR*SIGF CROSS
C       SECTION STORED IN POSITION 10 OF THE DICTIONARY
      SIGNF=SIGNF/XNU
      SUMA=SIGNF/SIGTNA*FSUMA
      IF(R.GT.SUMA)GO TO 650
C       THE REACTION TYPE IS (N,F)
      NMT18(MED)=NMT18(MED)+1
      WATE = 0.0
C       DETERMINE THE COSINE OF THE NEUTRON SCATTERING ANGLE IN THE
C       LABORATORY COORDINATE SYSTEM
C changed in order to get N fission neutron CZ July 30,1992
C INEU is poisson distributed with mean XNU
  580 CALL GPOISS(XNU,INEU,1)
      IF(INEU.GT.INT(4.*XNU)) GOTO 580
C check for maximum number of neutrons emitted
      IF(INEU.GT.INT(AWRI)-KZ(MED)) INEU = INT(AWRI) - KZ(MED)
      IF(INEU.GT.MAXNEU) INEU = MAXNEU
      L1=LDICT(74,IIN)
      IF(L1.EQ.0)GO TO 600
      LS1=IDICTS(74,IIN)+LMOX2
      LEN=L1
      DO 590 KN=1,INEU
         CALL CANGLE(D(LS1),D(LS1),E,FM(KN),LEN)
  590 CONTINUE
      GO TO 610
C       ASSUME ISOTROPIC IN THE LABORATORY COORDINATE SYSTEM
  600 CONTINUE
      LIFLAG=1
C       DETERMINE THE EXIT NEUTRON ENERGY IN THE LABORATORY
C       COORDINATE SYSTEM
  610 L1=LDICT(125,IIN)
      IF(L1.EQ.0)GO TO 620
      LS1=IDICTS(125,IIN)+LMOX2
      IF(INEU.GT.0) CALL GETENE(E,D(LS1),D(LS1),INEU)
C       DETERMINE THE EXIT NEUTRON WEIGHT FROM THE AVERAGE NUMBER
C       OF NEUTRONS EMITTED PER FISSION REACTION (NU)
C changed CZ July 30,1992
CZ      WATE=WATE*XNU
C       DETERMINE THE EXIT COLLISION PARAMETERS IN THE LABORATORY
C       COORDINATE SYSTEM
      QI=Q(ID,IIN)
      IF(INEU.GT.0) CALL LABNF(D,D,FM,AWRI,KZI,QI,LIFLAG)
      CALL PHOTON(D,D,IDICTS,LDICT,NTX,NTS,IGCBS,LGCB,AWR,
     +IGCBS2,LGCB2,LR,IGAMS,LGAM,QI,ID,IIN,LRI,SIGNF)
      NPSCL(3)=NPSCL(3)+1
      CALL BANKR(D,D,3)
      RETURN
  620 CONTINUE
      COMM=' COLISN: NO SECONDARY ENERGY DISTRIBUTION FOUND FOR MT-18'
      SIGREC=SIGNF
      SUMREC=SUMA
      ISTOP=1
      GO TO 970
  630 CONTINUE
      COMM=' COLISN: NO NUMBER OF FISSION NEUTRON FOUND FOR MT-18'
      SIGREC=SIGNF
      SUMREC=SUMA
      ISTOP=1
      GO TO 970
  640 SIGNF=0.0
  650 CONTINUE
C       DETERMINE (N,G) CROSS SECTION (MT-102)
      ID=55
      L1=LDICT(ID,IIN)
      IF(L1.EQ.0)GO TO 660
      LS1=IDICTS(ID,IIN)+LMOX2
      LEN=L1/2
      CALL TBSPLT(D(LS1),E,LEN,SIGNG)
      SUMA=SUMA+SIGNG/SIGTNA*FSUMA
      IF(R.GT.SUMA)GO TO 670
C       THE REACTION TYPE IS (N,G)
      NMT102(MED)=NMT102(MED)+1
      QI=Q(ID,IIN)
      CALL PHOTON(D,D,IDICTS,LDICT,NTX,NTS,IGCBS,LGCB,AWR,
     +IGCBS2,LGCB2,LR,IGAMS,LGAM,QI,ID,IIN,LRI,SIGNG)
      MT=102
      CALL NGHEVY(D,D,KZI,AWRI,QI,MT)
      WATE=0.0
      RETURN
  660 SIGNG=0.0
  670 CONTINUE
C       DETERMINE (N,P) CROSS SECTION (MT-103)
      ID=56
      L1=LDICT(ID,IIN)
      IF(L1.EQ.0)GO TO 690
      LS1=IDICTS(ID,IIN)+LMOX2
      LEN=L1/2
      CALL TBSPLT(D(LS1),E,LEN,SIGNP)
      SUMA=SUMA+SIGNP/SIGTNA*FSUMA
      IF(R.GT.SUMA)GO TO 700
C       THE REACTION TYPE IS (N,P)
      NMT103(MED)=NMT103(MED)+1
      QI=Q(ID,IIN)
      KZ1=1
      KZ2=KZI-KZ1
      ATAR=AWRI*AN
      A1=AP
      A2=ATAR+AN-AP
      Z1=ZP
      Z2=A2*9.31075E+08
      MT=103
      IF(KZI.EQ.6)GO TO 680
      CALL TWOBOD(D,D,KZ1,KZ2,A1,A2,Z1,Z2,ATAR,QI,MT)
      CALL PHOTON(D,D,IDICTS,LDICT,NTX,NTS,IGCBS,LGCB,AWR,
     +IGCBS2,LGCB2,LR,IGAMS,LGAM,QI,ID,IIN,LRI,SIGNP)
      WATE=0.0
      RETURN
  680 CALL GRNDST(D,D,KZ1,KZ2,A1,A2,Z1,Z2,ATAR,QI,MT)
      WATE=0.0
      RETURN
  690 SIGNP=0.0
  700 CONTINUE
C       DETERMINE (N,D) CROSS SECTION (MT-104)
      ID=57
      L1=LDICT(ID,IIN)
      IF(L1.EQ.0)GO TO 720
      LS1=IDICTS(ID,IIN)+LMOX2
      LEN=L1/2
      CALL TBSPLT(D(LS1),E,LEN,SIGND)
      SUMA=SUMA+SIGND/SIGTNA*FSUMA
      IF(R.GT.SUMA)GO TO 730
C       THE REACTION TYPE IS (N,D)
      NMT104(MED)=NMT104(MED)+1
      QI=Q(ID,IIN)
      KZ1=1
      KZ2=KZI-KZ1
      ATAR=AWRI*AN
      A1=AD
      A2=ATAR+AN-AD
      Z1=ZD
      Z2=A2*9.31075E+08
      MT=104
      IF((KZI.EQ.5).OR.(KZI.EQ.6))GO TO 710
      IF((KZI.EQ.8).OR.(KZI.EQ.13))GO TO 710
      IF((KZI.EQ.14).OR.(KZI.EQ.20))GO TO 710
      CALL TWOBOD(D,D,KZ1,KZ2,A1,A2,Z1,Z2,ATAR,QI,MT)
      CALL PHOTON(D,D,IDICTS,LDICT,NTX,NTS,IGCBS,LGCB,AWR,
     +IGCBS2,LGCB2,LR,IGAMS,LGAM,QI,ID,IIN,LRI,SIGND)
      WATE=0.0
      RETURN
  710 CALL GRNDST(D,D,KZ1,KZ2,A1,A2,Z1,Z2,ATAR,QI,MT)
      WATE=0.0
      RETURN
  720 SIGND=0.0
  730 CONTINUE
C       DETERMINE (N,T) CROSS SECTION (MT-105)
      ID=58
      L1=LDICT(ID,IIN)
      IF(L1.EQ.0)GO TO 750
      LS1=IDICTS(ID,IIN)+LMOX2
      LEN=L1/2
      CALL TBSPLT(D(LS1),E,LEN,SIGNT)
      SUMA=SUMA+SIGNT/SIGTNA*FSUMA
      IF(R.GT.SUMA)GO TO 760
C       THE REACTION TYPE IS (N,T)
      NMT105(MED)=NMT105(MED)+1
      QI=Q(ID,IIN)
      KZ1=1
      KZ2=KZI-KZ1
      ATAR=AWRI*AN
      A1=AT
      A2=ATAR+AN-AT
      Z1=ZT
      Z2=A2*9.31075E+08
      MT=105
      IF((KZI.EQ.5).OR.(KZI.EQ.13))GO TO 740
      IF(KZI.EQ.20)GO TO 740
      CALL TWOBOD(D,D,KZ1,KZ2,A1,A2,Z1,Z2,ATAR,QI,MT)
      CALL PHOTON(D,D,IDICTS,LDICT,NTX,NTS,IGCBS,LGCB,AWR,
     +IGCBS2,LGCB2,LR,IGAMS,LGAM,QI,ID,IIN,LRI,SIGNT)
      WATE=0.0
      RETURN
  740 CALL GRNDST(D,D,KZ1,KZ2,A1,A2,Z1,Z2,ATAR,QI,MT)
      WATE=0.0
      RETURN
  750 SIGNT=0.0
  760 CONTINUE
C       DETERMINE (N,3HE) CROSS SECTION (MT-106)
      ID=59
      L1=LDICT(ID,IIN)
      IF(L1.EQ.0)GO TO 780
      LS1=IDICTS(ID,IIN)+LMOX2
      LEN=L1/2
      CALL TBSPLT(D(LS1),E,LEN,SGN3HE)
      SUMA=SUMA+SGN3HE/SIGTNA*FSUMA
      IF(R.GT.SUMA)GO TO 790
C       THE REACTION TYPE IS (N,3HE)
      NMT106(MED)=NMT106(MED)+1
      QI=Q(ID,IIN)
      KZ1=2
      KZ2=KZI-KZ1
      ATAR=AWRI*AN
      A1=AHE3
      A2=ATAR+AN-AHE3
      Z1=ZHE3
      Z2=A2*9.31075E+08
      MT=106
      IF(KZI.EQ.20)GO TO 770
      CALL TWOBOD(D,D,KZ1,KZ2,A1,A2,Z1,Z2,ATAR,QI,MT)
      CALL PHOTON(D,D,IDICTS,LDICT,NTX,NTS,IGCBS,LGCB,AWR,
     +IGCBS2,LGCB2,LR,IGAMS,LGAM,QI,ID,IIN,LRI,SGN3HE)
      WATE=0.0
      RETURN
  770 CALL GRNDST(D,D,KZ1,KZ2,A1,A2,Z1,Z2,ATAR,QI,MT)
      WATE=0.0
      RETURN
  780 SGN3HE=0.0
  790 CONTINUE
C       DETERMINE (N,A) CROSS SECTION (MT-107)
      ID=60
      L1=LDICT(ID,IIN)
      IF(L1.EQ.0)GO TO 810
      LS1=IDICTS(ID,IIN)+LMOX2
      LEN=L1/2
      CALL TBSPLT(D(LS1),E,LEN,SIGNA)
      SUMA=SUMA+SIGNA/SIGTNA*FSUMA
      IF(R.GT.SUMA)GO TO 820
C       THE REACTION TYPE IS (N,A)
      NMT107(MED)=NMT107(MED)+1
      QI=Q(ID,IIN)
      KZ1=2
      KZ2=KZI-KZ1
      ATAR=AWRI*AN
      A1=AA
      A2=ATAR+AN-AA
      Z1=ZA
      Z2=A2*9.31075E+08
      MT=107
      IF((KZI.EQ.6).OR.(KZI.EQ.13))GO TO 800
      CALL TWOBOD(D,D,KZ1,KZ2,A1,A2,Z1,Z2,ATAR,QI,MT)
      CALL PHOTON(D,D,IDICTS,LDICT,NTX,NTS,IGCBS,LGCB,AWR,
     +IGCBS2,LGCB2,LR,IGAMS,LGAM,QI,ID,IIN,LRI,SIGNA)
      WATE=0.0
      RETURN
  800 CALL GRNDST(D,D,KZ1,KZ2,A1,A2,Z1,Z2,ATAR,QI,MT)
      WATE=0.0
      RETURN
  810 SIGNA=0.0
  820 CONTINUE
C       DETERMINE (N,2A) CROSS SECTION (MT-108)
      ID=61
      L1=LDICT(ID,IIN)
      IF(L1.EQ.0)GO TO 840
      LS1=IDICTS(ID,IIN)+LMOX2
      LEN=L1/2
      CALL TBSPLT(D(LS1),E,LEN,SIGN2A)
      SUMA=SUMA+SIGN2A/SIGTNA*FSUMA
      IF(R.GT.SUMA)GO TO 850
C       THE REACTION TYPE IS (N,2A)
      NMT108(MED)=NMT108(MED)+1
      QI=Q(ID,IIN)
      KZ1=2
      KZ2=KZI-2*KZ1
      ATAR=AWRI*AN
      A1=AA
      A2=ATAR+AN-AA
      Z1=ZA
      Z2=A2*9.31075E+08
      MT=108
C       USE THE ONE PARTICLE EMISSION MODEL AND MULTIPLY THE
C       WEIGHT BY TWO
      IF((KZI.EQ.7).OR.(KZI.EQ.20))GO TO 830
      CALL TWOBOD(D,D,KZ1,KZ2,A1,A2,Z1,Z2,ATAR,QI,MT)
      CALL PHOTON(D,D,IDICTS,LDICT,NTX,NTS,IGCBS,LGCB,AWR,
     +IGCBS2,LGCB2,LR,IGAMS,LGAM,QI,ID,IIN,LRI,SIGN2A)
      WATE=0.0
      RETURN
  830 CALL GRNDST(D,D,KZ1,KZ2,A1,A2,Z1,Z2,ATAR,QI,MT)
      WATE=0.0
      RETURN
  840 SIGN2A=0.0
  850 CONTINUE
C       DETERMINE (N,3A) CROSS SECTION (MT-109)
      ID=62
      L1=LDICT(ID,IIN)
      IF(L1.EQ.0)GO TO 860
      LS1=IDICTS(ID,IIN)+LMOX2
      LEN=L1/2
      CALL TBSPLT(D(LS1),E,LEN,SIGN3A)
      SUMA=SUMA+SIGN3A/SIGTNA*FSUMA
      IF(R.GT.SUMA)GO TO 870
C       THE REACTION TYPE IS (N,3A)
      NMT109(MED)=NMT109(MED)+1
      QI=Q(ID,IIN)
      KZ1=2
      KZ2=KZI-3*KZ1
      ATAR=AWRI*AN
      A1=AA
      A2=ATAR+AN-AA
      Z1=ZA
      Z2=A2*9.31075E+08
      MT=109
C       USE THE ONE PARTICLE EMISSION MODEL AND MULTIPLY THE
C       WEIGHT BY THREE
      CALL TWOBOD(D,D,KZ1,KZ2,A1,A2,Z1,Z2,ATAR,QI,MT)
      CALL PHOTON(D,D,IDICTS,LDICT,NTX,NTS,IGCBS,LGCB,AWR,
     +IGCBS2,LGCB2,LR,IGAMS,LGAM,QI,ID,IIN,LRI,SIGN3A)
      WATE=0.0
      RETURN
  860 SIGN3A=0.0
  870 CONTINUE
C       DETERMINE (N,2P) CROSS SECTION (MT-111)
      ID=63
      L1=LDICT(ID,IIN)
      IF(L1.EQ.0)GO TO 890
      LS1=IDICTS(ID,IIN)+LMOX2
      LEN=L1/2
      CALL TBSPLT(D(LS1),E,LEN,SIGN2P)
      SUMA=SUMA+SIGN2P/SIGTNA*FSUMA
      IF(R.GT.SUMA)GO TO 900
C       THE REACTION TYPE IS (N,2P)
      NMT111(MED)=NMT111(MED)+1
      QI=Q(ID,IIN)
      KZ1=1
      KZ2=KZI-2*KZ1
      ATAR=AWRI*AN
      A1=AP
      A2=ATAR+AN-AP
      Z1=ZP
      Z2=A2*9.31075E+08
      MT=111
C       USE THE ONE PARTICLE EMISSION MODEL AND MULTIPLY THE
C       WEIGHT BY TWO
      IF(KZI.EQ.20)GO TO 880
      CALL TWOBOD(D,D,KZ1,KZ2,A1,A2,Z1,Z2,ATAR,QI,MT)
      CALL PHOTON(D,D,IDICTS,LDICT,NTX,NTS,IGCBS,LGCB,AWR,
     +IGCBS2,LGCB2,LR,IGAMS,LGAM,QI,ID,IIN,LRI,SIGN2P)
      WATE=0.0
      RETURN
  880 CALL GRNDST(D,D,KZ1,KZ2,A1,A2,Z1,Z2,ATAR,QI,MT)
      WATE=0.0
      RETURN
  890 SIGN2P=0.0
  900 CONTINUE
C       DETERMINE (N,PA) CROSS SECTION (MT-112)
      ID=64
      L1=LDICT(ID,IIN)
      IF(L1.EQ.0)GO TO 910
      LS1=IDICTS(ID,IIN)+LMOX2
      LEN=L1/2
      CALL TBSPLT(D(LS1),E,LEN,SIGNPA)
      SUMA=SUMA+SIGNPA/SIGTNA*FSUMA
      IF(R.GT.SUMA)GO TO 920
C       THE REACTION TYPE IS (N,PA)
      NMT112(MED)=NMT112(MED)+1
      QI=Q(ID,IIN)
      KZ1=1
      KZ2=2
      KZ3=KZI-KZ1-KZ2
      ATAR=AWRI*AN
      A1=AP
      A2=AA
      A3=ATAR+AN-A1
      Z1=ZP
      Z2=ZA
      Z3=A3*9.31075E+08
      MT=112
CZ July 30,1992 Three-Body process added ----
      CALL TREBOD(D,D,KZ1,KZ2,KZ3,A1,A2,A3,Z1,Z2,Z3,ATAR,QI,MT)
      CALL PHOTON(D,D,IDICTS,LDICT,NTX,NTS,IGCBS,LGCB,AWR,
     +IGCBS2,LGCB2,LR,IGAMS,LGAM,QI,ID,IIN,LRI,SIGNPA)
      WATE=0.0
      RETURN
  910 SIGNPA=0.0
  920 CONTINUE
C       DETERMINE (N,T2A) CROSS SECTION (MT-113)
      ID=65
      L1=LDICT(ID,IIN)
      IF(L1.EQ.0)GO TO 930
      LS1=IDICTS(ID,IIN)+LMOX2
      LEN=L1/2
      CALL TBSPLT(D(LS1),E,LEN,SGNT2A)
      SUMA=SUMA+SGNT2A/SIGTNA*FSUMA
      IF(R.GT.SUMA)GO TO 940
C       THE REACTION TYPE IS (N,T2A)
      NMT113(MED)=NMT113(MED)+1
      QI=Q(ID,IIN)
      KZ1=1
      KZ2=2
      KZ3=KZI-KZ1-2*KZ2
      ATAR=AWRI*AN
      A1=AT
      A2=AA
      A3=ATAR+AN-A1
      Z1=ZT
      Z2=ZA
      Z3=A3*9.31075E+08
      MT=113
CZ July 30,1992 Three-Body process added ----
      CALL TREBOD(D,D,KZ1,KZ2,KZ3,A1,A2,A3,Z1,Z2,Z3,ATAR,QI,MT)
      CALL PHOTON(D,D,IDICTS,LDICT,NTX,NTS,IGCBS,LGCB,AWR,
     +IGCBS2,LGCB2,LR,IGAMS,LGAM,QI,ID,IIN,LRI,SGNT2A)
      WATE=0.0
      RETURN
  930 SGNT2A=0.0
  940 CONTINUE
C       DETERMINE (N,D2A) CROSS SECTION (MT-114)
      ID=66
      L1=LDICT(ID,IIN)
      IF(L1.EQ.0)GO TO 950
      LS1=IDICTS(ID,IIN)+LMOX2
      LEN=L1/2
      CALL TBSPLT(D(LS1),E,LEN,SGND2A)
      SUMA=SUMA+SGND2A/SIGTNA*FSUMA
      IF(R.GT.SUMA)GO TO 960
C       THE REACTION TYPE IS (N,D2A)
      NMT114(MED)=NMT114(MED)+1
      QI=Q(ID,IIN)
      KZ1=1
      KZ2=2
      KZ3=KZI-KZ1-2*KZ2
      ATAR=AWRI*AN
      A1=AD
      A2=AA
      A3=ATAR+AN-A1
      Z1=ZD
      Z2=ZA
      Z3=A3*9.31075E+08
      MT=114
CZ July 30,1992 Three-Body process added ----
      CALL TREBOD(D,D,KZ1,KZ2,KZ3,A1,A2,A3,Z1,Z2,Z3,ATAR,QI,MT)
      CALL PHOTON(D,D,IDICTS,LDICT,NTX,NTS,IGCBS,LGCB,AWR,
     +IGCBS2,LGCB2,LR,IGAMS,LGAM,QI,ID,IIN,LRI,SGND2A)
      WATE=0.0
      RETURN
  950 SGND2A=0.0
  960 CONTINUE
      FSUMA = 1./SUMA
      ITRY=ITRY+1
      ISTOP=1
      IF(FSUMA.GT.0.1.AND.FSUMA.LE.10.0) ISTOP=0
      NAEI(IIN)=NAEI(IIN)-1
      IF(ISTOP.EQ.0.AND.ITRY.LE.5)GO TO 20
C       AN ABSORPTION REACTION WAS NOT CHOSEN
      COMM=' COLISN:AN ABSORPTION REACTION TYPE WAS NOT CHOSEN '
      SIGREC = SIGTNA
      SUMREC = SUMA
      GOTO 980
  970 CONTINUE
      IF(ISTOP.EQ.1)GO TO 980
      ITRY=0
      GO TO 20
  980 CONTINUE
      WRITE(IOUT,'(A80,/,I5,F7.1,I4,/,G18.7,I5,3G10.4)') COMM,
     +      NMED,AWR(IIN),KZ(IIM),
     +      E,MT,
     +      SIGT,SIGREC,SUMREC
      RETURN
      END