[u/mrichter/AliRoot.git] / GEANT321 / miface / gmicap.F

*
* $Id$
*
* $Log$
* Revision 1.1.1.1  1995/10/24 10:21:52  cernlib
* Geant
*
*
#include "geant321/pilot.h"
*CMZ :  3.21/02 29/03/94  15.41.47  by  S.Giani
*-- Author :
      SUBROUTINE GMICAP
C
#include "geant321/gctrak.inc"
#include "geant321/gcmate.inc"
#include "geant321/gcking.inc"
C MICAP commons
#include "geant321/mmicap.inc"
#include "geant321/minput.inc"
#include "geant321/mconst.inc"
      COMMON/MNUTRN/NAME,NAMEX,E,EOLD,NMED,MEDOLD,NREG,U,V,W,
     + UOLD,VOLD,WOLD,X,Y,ZZ,XOLD,YOLD,ZOLD,WATE,OLDWT,WTBC,
     + BLZNT,BLZON,AGE,OLDAGE,INEU,ENE(MAXNEU)
      INTEGER BLZNT
#include "geant321/mapoll.inc"
#include "geant321/mpoint.inc"
#include "geant321/mrecoi.inc"
#include "geant321/mmass.inc"
#include "geant321/mpstor.inc"
#include "geant321/cmagic.inc"
#include "geant321/mcreco.inc"
C
C convert Z,A of recoil to CALOR particle code
C only p = 0, D = 7, T = 8, He3 = 9, alpha=10
* n = 13, p = 14, D = 45, T = 46, He3 = 49, alpha = 47
      DIMENSION NGPART(4,0:2)
      DATA ((NGPART(I,J),I=1,4),J=0,2)/13 ,-1 ,-1 ,
*                                      n
     +                               -1 , 14 , 45 ,
*                                         p    D
     +                               -1 , 46 , 49 ,
*                                         T    He3
     +                               -1 ,-1  , 47/
*                                              alpha
      SAVE
C first check, if ZEBRA still in order
      IF(LD(LMAG1).NE.NMAGIC.OR.LD(LMAG2).NE.NMAGIC) THEN
         WRITE(6,*) ' CALOR: ZEBRA banks screwed up --> STOP'
         WRITE(IOUT,'('' MICAP: Magic number '',I12,'' not found: '',  '
     +   //'      2I12)') NMAGIC,LD(LMAG1),LD(LMAG2)
         STOP
      ENDIF
C       THIS ROUTINE PERFORMS THE RANDOM WALK FOR ALL PARTICLES
   10 CONTINUE
C get material and particle information
*     U = UINC(1)
*     V = UINC(2)
*     W = UINC(3)
      U = VECT(4)
      V = VECT(5)
      W = VECT(6)
      X = 0.0
      Y = 0.0
      ZZ = 0.0
      BLZNT = 1
      WATE = 1.0
      AGE = 0.0
      NREG = 1
      WTBC = 1.0
C Energy MeV -> eV
*      E = EINC * 1.E6
      E = GEKIN*1.E9
C Material number a la GEANT
*      NMED = NCEL
      NMED = NMAT
      NMEM=1
C reset counter of heavy/charged and gamma bank
      NMEMR = 0
      NMEMG = 0
      INALB=0
      IET=0
      EOLD=E
      UOLD=U
      VOLD=V
      WOLD=W
      OLDWT=WATE
      XOLD=X
      YOLD=Y
      ZOLD=ZZ
      BLZON=BLZNT
      MEDOLD=NMED
      OLDAGE=AGE
      I=1
      CALL GTMED(NMED,IMED)
C get total cross-section
      CALL NSIGTA(E,NMED,TSIG,D,LD(LFP32),LD(LFP33))
C       DETERMINE WHICH ISOTOPE HAS BEEN HIT
      CALL ISOTPE(D,LD,LD(LFP10),D(LFP12),LD(LFP16),LD(LFP26),LD(LFP27),
     +            E,TSIG,IMED,IIN,IIM)
C       THE PARAMETER (IIN) IS THE POINTER FOR ARRAYS DIMENSIONED BY
C       (NNUC) AND THE PARAMETER (IIM) IS THE POINTER FOR ARRAYS
C       DIMENSIONED BY (NMIX)
      LD(LFP42+IMED-1)=LD(LFP42+IMED-1)+1
      INEU = 0
      NNEU = 0
      NHEVY = 0
      NGAMA = 0
      NPSTOR = 0
      CALL COLISN(D,LD,
     + LD(LFP20),LD(LFP21),LD(LFP22),LD(LFP23),LD(LFP24),
     + LD(LFP25),LD(LFP26),LD(LFP27),LD(LFP28),LD(LFP29),LD(LFP30),
     + LD(LFP31),D(LFP34),D(LFP35),LD(LFP41),LD(LFP41+NNUC),
     + LD(LFP42),LD(LFP42+MEDIA),LD(LFP42+2*MEDIA),LD(LFP42+3*MEDIA),
     + LD(LFP42+4*MEDIA),LD(LFP42+5*MEDIA),LD(LFP42+6*MEDIA),
     + LD(LFP42+7*MEDIA),LD(LFP42+8*MEDIA),LD(LFP42+9*MEDIA),
     + LD(LFP42+10*MEDIA),LD(LFP42+11*MEDIA),LD(LFP42+12*MEDIA),
     + LD(LFP42+13*MEDIA),LD(LFP42+14*MEDIA),LD(LFP42+15*MEDIA),
     + LD(LFP42+16*MEDIA),LD(LFP42+17*MEDIA),LD(LFP42+18*MEDIA),
     + LD(LFP42+19*MEDIA),LD(LFP42+20*MEDIA),LD(LFP42+21*MEDIA),
     + LD(LFP42+22*MEDIA),LD(LFP45),LD(LFP46),LD(LFP13),
     + LD(LFP35+NQ*NNUC),D(LFP35+2*NQ*NNUC),IIN,IIM)
      CALL BANKR(D,LD,5)
C -------- fill return arrays with generated particles ---------------
C first heavy/charged particles
   20 NPHETC = 0
      NRECOL = 0
      ERMED  = 0.0
      EETOT = 0.0
C -------- store  neutrons -------------------------------------
      INTCAL = 0
C
      ISTOP = 1
      JPA = LQ(JPART-13)
      AGEMNE = Q(JPA+7)
      NGKINE = 0
      DO 30  N=1,NNEU
         CALL GETPAR(IDNEU,N,IERR)
         IF(IERR.EQ.0) THEN
            NGKINE = NGKINE + 1
            TTKIN  = EP * 1.E-9
            PGEANT = SQRT(TTKIN*(TTKIN+2*AGEMNE))
            GKIN(1,NGKINE) = UP*PGEANT
            GKIN(2,NGKINE) = VP*PGEANT
            GKIN(3,NGKINE) = WP*PGEANT
            GKIN(4,NGKINE) = TTKIN + AGEMNE
            GKIN(5,NGKINE) = 13
            TOFD(NGKINE)   = AGEP * 1.E-9
            GPOS(1,NGKINE) = VECT(1)
            GPOS(2,NGKINE) = VECT(2)
            GPOS(3,NGKINE) = VECT(3)
*           NPHETC = NPHETC + 1
*           IF(NPHETC.GT.MXCP) NPHETC=MXCP
*           IPCAL(NPHETC) = 1
C kinetic energy in MeV
*           EKINET(NPHETC) = EP * 1.E-6
*           UCAL(NPHETC,1) = UP
*           UCAL(NPHETC,2) = VP
*           UCAL(NPHETC,3) = WP
*           CALTIM(NPHETC) = AGEP
         ENDIF
   30 CONTINUE
C -------- store heavy recoil products ------------------------
      DO 40  N=1,NHEVY
         CALL GETPAR(IDHEVY,N,IERR)
         IF(IERR.EQ.0) THEN
C check particle type
            MA = NINT(AMP)
            MZ = NINT(ZMP)
            IF(MA.LE.4.AND.MZ.LE.2) THEN
               IF(NGPART(MA,MZ).EQ.-1) GOTO 40
            ELSE
C get heavy recoil nucleus
               NRECOL = NRECOL + 1
               AMED(NRECOL) = AMP
               ZMED(NRECOL) = ZMP
               ERMED = ERMED + EP * 1.E-9
               GOTO 40
            ENDIF
C store particle type
            NGKINE = NGKINE + 1
            JPA = LQ(JPART-NGPART(MA,MZ))
            AGEMAS = Q(JPA+7)
            TTKIN  = EP * 1.E-9
            PGEANT = SQRT(TTKIN*(TTKIN+2*AGEMAS))
            GKIN(1,NGKINE) = UP*PGEANT
            GKIN(2,NGKINE) = VP*PGEANT
            GKIN(3,NGKINE) = WP*PGEANT
            GKIN(4,NGKINE) = TTKIN + AGEMAS
            GKIN(5,NGKINE) = NGPART(MA,MZ)
            TOFD(NGKINE) = AGEP * 1.E-9
            GPOS(1,NGKINE) = VECT(1)
            GPOS(2,NGKINE) = VECT(2)
            GPOS(3,NGKINE) = VECT(3)
*           NPHETC = NPHETC + 1
*           IF(NPHETC.GT.MXCP) NPHETC=MXCP
*           IPCAL(NPHETC) = NPART(MA,MZ)
C kinetic energy in MeV
*           EKINET(NPHETC) = EP * 1.E-6
*           UCAL(NPHETC,1) = UP
*           UCAL(NPHETC,2) = VP
*           UCAL(NPHETC,3) = WP
*           CALTIM(NPHETC) = AGEP
         ENDIF
   40 CONTINUE
* Number of produced particles (may be > MXGKIN)
      NNEHEG = NGKINE + NGAMA
C
C----------- get generated gammas --------------------
      NS   = 0
      NREM = 0
      DO 50  N=1,NGAMA
         IF (NS.GE.NGAMA) GO TO 60
         NS = NS + 1
         CALL GETPAR(IDGAMA,NS,IERR)
         IF(IERR.EQ.0) THEN
            IF (NNEHEG-NREM.GT.MXGKIN) THEN
               NREM  = NREM + 1
               UP1   = UP
               VP1   = VP
               WP1   = WP
               EP1   = EP
               AGEP1 = AGEP
               NS = NS + 1
*    Get the other gamma to be summed with the previous one
               CALL GETPAR(IDGAMA,NS,IERR)
               IF(IERR.EQ.0) THEN
                 UP  = (UP1*EP1+UP*EP)
                 VP  = (VP1*EP1+VP*EP)
                 WP  = (WP1*EP1+WP*EP)
*    Normalize the new direction cosines
                 WUP = SQRT(UP**2+VP**2+WP**2)
                 UP  = UP/WUP
                 VP  = VP/WUP
                 WP  = WP/WUP
                 EP  = EP1 + EP
                 AGEP = AGEP1 + AGEP
               ENDIF
            ENDIF
            NGKINE = NGKINE + 1
            PGEANT = EP * 1.E-9
            GKIN(1,NGKINE) = UP*PGEANT
            GKIN(2,NGKINE) = VP*PGEANT
            GKIN(3,NGKINE) = WP*PGEANT
            GKIN(4,NGKINE) = PGEANT
            GKIN(5,NGKINE) = 1
            TOFD(NGKINE) = AGEP * 1.E-9
            GPOS(1,NGKINE) = VECT(1)
            GPOS(2,NGKINE) = VECT(2)
            GPOS(3,NGKINE) = VECT(3)
*           NG = NG + 1
*           NPHETC = NPHETC + 1
*           IF(NPHETC.GT.MXCP) NPHETC=MXCP
*           IPCAL(NPHETC) = 11
*           EKINET(NPHETC) = EP*1.E-6
*           UCAL(NPHETC,1) = UP
*           UCAL(NPHETC,2) = VP
*           UCAL(NPHETC,3) = WP
*           CALTIM(NPHETC) = AGEP
C nucleus is in ground state !
            EXMED = 0.0
         ENDIF
   50 CONTINUE
* only one neutron generated -> the particle is the same
   60 IF (NGKINE.EQ.1.AND.GKIN(5,1).EQ.13) THEN
         NGKINE  = 0
         CALL GETPAR(IDNEU,1,IERR)
         VECT(4) = UP
         VECT(5) = VP
         VECT(6) = WP
         GEKIN   = EP * 1.E-9
         GETOT   = GEKIN + AGEMNE
         VECT(7) = SQRT(GEKIN*(GEKIN+2.*AGEMNE))
         TOFG    = TOFG + AGEP * 1.E-9
         ISTOP   = 0
      ENDIF
*
      IF (MTP        .EQ.         2) THEN
         INTCAL = 13
      ELSEIF (MTP    .EQ.        18) THEN
         IF (NHEVY.GT.0) INTCAL = 15
      ELSEIF (MTP    .LT.       100) THEN
         IF (NNEU .GT.0) INTCAL = 20
      ELSEIF (MTP    .EQ.       102) THEN
         IF (NGAMA.GT.0) INTCAL = 18
      ELSEIF (MTP    .GE.       100) THEN
         IF (NHEVY+NGAMA.GT.0) INTCAL = 16
      ENDIF
      IF(NNEU+NHEVY+NGAMA.GT.0.AND.INTCAL.EQ.0) INTCAL=12
      KCASE = NAMEC(INTCAL)
      END
Commit	Line	Data
fe4da5cc	1	*
	2	* $Id$
	3	*
	4	* $Log$
	5	* Revision 1.1.1.1 1995/10/24 10:21:52 cernlib
	6	* Geant
	7	*
	8	*
	9	#include "geant321/pilot.h"
	10	*CMZ : 3.21/02 29/03/94 15.41.47 by S.Giani
	11	*-- Author :
	12	SUBROUTINE GMICAP
	13	C
	14	#include "geant321/gctrak.inc"
	15	#include "geant321/gcmate.inc"
	16	#include "geant321/gcking.inc"
	17	C MICAP commons
	18	#include "geant321/mmicap.inc"
	19	#include "geant321/minput.inc"
	20	#include "geant321/mconst.inc"
	21	COMMON/MNUTRN/NAME,NAMEX,E,EOLD,NMED,MEDOLD,NREG,U,V,W,
	22	+ UOLD,VOLD,WOLD,X,Y,ZZ,XOLD,YOLD,ZOLD,WATE,OLDWT,WTBC,
	23	+ BLZNT,BLZON,AGE,OLDAGE,INEU,ENE(MAXNEU)
	24	INTEGER BLZNT
	25	#include "geant321/mapoll.inc"
	26	#include "geant321/mpoint.inc"
	27	#include "geant321/mrecoi.inc"
	28	#include "geant321/mmass.inc"
	29	#include "geant321/mpstor.inc"
	30	#include "geant321/cmagic.inc"
	31	#include "geant321/mcreco.inc"
	32	C
	33	C convert Z,A of recoil to CALOR particle code
	34	C only p = 0, D = 7, T = 8, He3 = 9, alpha=10
	35	* n = 13, p = 14, D = 45, T = 46, He3 = 49, alpha = 47
	36	DIMENSION NGPART(4,0:2)
	37	DATA ((NGPART(I,J),I=1,4),J=0,2)/13 ,-1 ,-1 ,
	38	* n
	39	+ -1 , 14 , 45 ,
	40	* p D
	41	+ -1 , 46 , 49 ,
	42	* T He3
	43	+ -1 ,-1 , 47/
	44	* alpha
	45	SAVE
	46	C first check, if ZEBRA still in order
	47	IF(LD(LMAG1).NE.NMAGIC.OR.LD(LMAG2).NE.NMAGIC) THEN
	48	WRITE(6,*) ' CALOR: ZEBRA banks screwed up --> STOP'
	49	WRITE(IOUT,'('' MICAP: Magic number '',I12,'' not found: '', '
	50	+ //' 2I12)') NMAGIC,LD(LMAG1),LD(LMAG2)
	51	STOP
	52	ENDIF
	53	C THIS ROUTINE PERFORMS THE RANDOM WALK FOR ALL PARTICLES
	54	10 CONTINUE
	55	C get material and particle information
	56	* U = UINC(1)
	57	* V = UINC(2)
	58	* W = UINC(3)
	59	U = VECT(4)
	60	V = VECT(5)
	61	W = VECT(6)
	62	X = 0.0
	63	Y = 0.0
	64	ZZ = 0.0
65	BLZNT = 1
66	WATE = 1.0
67	AGE = 0.0
68	NREG = 1
69	WTBC = 1.0
70	C Energy MeV -> eV
71	* E = EINC * 1.E6
72	E = GEKIN*1.E9
73	C Material number a la GEANT
74	* NMED = NCEL
75	NMED = NMAT
76	NMEM=1
77	C reset counter of heavy/charged and gamma bank
78	NMEMR = 0
79	NMEMG = 0
80	INALB=0
81	IET=0
82	EOLD=E
83	UOLD=U
84	VOLD=V
85	WOLD=W
86	OLDWT=WATE
87	XOLD=X
88	YOLD=Y
89	ZOLD=ZZ
90	BLZON=BLZNT
91	MEDOLD=NMED
92	OLDAGE=AGE
93	I=1
94	CALL GTMED(NMED,IMED)
95	C get total cross-section
96	CALL NSIGTA(E,NMED,TSIG,D,LD(LFP32),LD(LFP33))
97	C DETERMINE WHICH ISOTOPE HAS BEEN HIT
98	CALL ISOTPE(D,LD,LD(LFP10),D(LFP12),LD(LFP16),LD(LFP26),LD(LFP27),
99	+ E,TSIG,IMED,IIN,IIM)
100	C THE PARAMETER (IIN) IS THE POINTER FOR ARRAYS DIMENSIONED BY
101	C (NNUC) AND THE PARAMETER (IIM) IS THE POINTER FOR ARRAYS
102	C DIMENSIONED BY (NMIX)
103	LD(LFP42+IMED-1)=LD(LFP42+IMED-1)+1
104	INEU = 0
105	NNEU = 0
106	NHEVY = 0
107	NGAMA = 0
108	NPSTOR = 0
109	CALL COLISN(D,LD,
110	+ LD(LFP20),LD(LFP21),LD(LFP22),LD(LFP23),LD(LFP24),
111	+ LD(LFP25),LD(LFP26),LD(LFP27),LD(LFP28),LD(LFP29),LD(LFP30),
112	+ LD(LFP31),D(LFP34),D(LFP35),LD(LFP41),LD(LFP41+NNUC),
113	+ LD(LFP42),LD(LFP42+MEDIA),LD(LFP42+2MEDIA),LD(LFP42+3MEDIA),
114	+ LD(LFP42+4MEDIA),LD(LFP42+5MEDIA),LD(LFP42+6*MEDIA),
115	+ LD(LFP42+7MEDIA),LD(LFP42+8MEDIA),LD(LFP42+9*MEDIA),
116	+ LD(LFP42+10MEDIA),LD(LFP42+11MEDIA),LD(LFP42+12*MEDIA),
117	+ LD(LFP42+13MEDIA),LD(LFP42+14MEDIA),LD(LFP42+15*MEDIA),
118	+ LD(LFP42+16MEDIA),LD(LFP42+17MEDIA),LD(LFP42+18*MEDIA),
119	+ LD(LFP42+19MEDIA),LD(LFP42+20MEDIA),LD(LFP42+21*MEDIA),
120	+ LD(LFP42+22*MEDIA),LD(LFP45),LD(LFP46),LD(LFP13),
121	+ LD(LFP35+NQNNUC),D(LFP35+2NQ*NNUC),IIN,IIM)
122	CALL BANKR(D,LD,5)
123	C -------- fill return arrays with generated particles ---------------
124	C first heavy/charged particles
125	20 NPHETC = 0
126	NRECOL = 0
127	ERMED = 0.0
128	EETOT = 0.0
129	C -------- store neutrons -------------------------------------
130	INTCAL = 0
131	C
132	ISTOP = 1
133	JPA = LQ(JPART-13)
134	AGEMNE = Q(JPA+7)
135	NGKINE = 0
136	DO 30 N=1,NNEU
137	CALL GETPAR(IDNEU,N,IERR)
138	IF(IERR.EQ.0) THEN
139	NGKINE = NGKINE + 1
140	TTKIN = EP * 1.E-9
141	PGEANT = SQRT(TTKIN(TTKIN+2AGEMNE))
142	GKIN(1,NGKINE) = UP*PGEANT
143	GKIN(2,NGKINE) = VP*PGEANT
144	GKIN(3,NGKINE) = WP*PGEANT
145	GKIN(4,NGKINE) = TTKIN + AGEMNE
146	GKIN(5,NGKINE) = 13
147	TOFD(NGKINE) = AGEP * 1.E-9
148	GPOS(1,NGKINE) = VECT(1)
149	GPOS(2,NGKINE) = VECT(2)
150	GPOS(3,NGKINE) = VECT(3)
151	* NPHETC = NPHETC + 1
152	* IF(NPHETC.GT.MXCP) NPHETC=MXCP
153	* IPCAL(NPHETC) = 1
154	C kinetic energy in MeV
155	* EKINET(NPHETC) = EP * 1.E-6
156	* UCAL(NPHETC,1) = UP
157	* UCAL(NPHETC,2) = VP
158	* UCAL(NPHETC,3) = WP
159	* CALTIM(NPHETC) = AGEP
160	ENDIF
161	30 CONTINUE
162	C -------- store heavy recoil products ------------------------
163	DO 40 N=1,NHEVY
164	CALL GETPAR(IDHEVY,N,IERR)
165	IF(IERR.EQ.0) THEN
166	C check particle type
167	MA = NINT(AMP)
168	MZ = NINT(ZMP)
169	IF(MA.LE.4.AND.MZ.LE.2) THEN
170	IF(NGPART(MA,MZ).EQ.-1) GOTO 40
171	ELSE
172	C get heavy recoil nucleus
173	NRECOL = NRECOL + 1
174	AMED(NRECOL) = AMP
175	ZMED(NRECOL) = ZMP
176	ERMED = ERMED + EP * 1.E-9
177	GOTO 40
178	ENDIF
179	C store particle type
180	NGKINE = NGKINE + 1
181	JPA = LQ(JPART-NGPART(MA,MZ))
182	AGEMAS = Q(JPA+7)
183	TTKIN = EP * 1.E-9
184	PGEANT = SQRT(TTKIN(TTKIN+2AGEMAS))
185	GKIN(1,NGKINE) = UP*PGEANT
186	GKIN(2,NGKINE) = VP*PGEANT
187	GKIN(3,NGKINE) = WP*PGEANT
188	GKIN(4,NGKINE) = TTKIN + AGEMAS
189	GKIN(5,NGKINE) = NGPART(MA,MZ)
190	TOFD(NGKINE) = AGEP * 1.E-9
191	GPOS(1,NGKINE) = VECT(1)
192	GPOS(2,NGKINE) = VECT(2)
193	GPOS(3,NGKINE) = VECT(3)
194	* NPHETC = NPHETC + 1
195	* IF(NPHETC.GT.MXCP) NPHETC=MXCP
196	* IPCAL(NPHETC) = NPART(MA,MZ)
197	C kinetic energy in MeV
198	* EKINET(NPHETC) = EP * 1.E-6
199	* UCAL(NPHETC,1) = UP
200	* UCAL(NPHETC,2) = VP
201	* UCAL(NPHETC,3) = WP
202	* CALTIM(NPHETC) = AGEP
203	ENDIF
204	40 CONTINUE
205	* Number of produced particles (may be > MXGKIN)
206	NNEHEG = NGKINE + NGAMA
207	C
208	C----------- get generated gammas --------------------
209	NS = 0
210	NREM = 0
211	DO 50 N=1,NGAMA
212	IF (NS.GE.NGAMA) GO TO 60
213	NS = NS + 1
214	CALL GETPAR(IDGAMA,NS,IERR)
215	IF(IERR.EQ.0) THEN
216	IF (NNEHEG-NREM.GT.MXGKIN) THEN
217	NREM = NREM + 1
218	UP1 = UP
219	VP1 = VP
220	WP1 = WP
221	EP1 = EP
222	AGEP1 = AGEP
223	NS = NS + 1
224	* Get the other gamma to be summed with the previous one
225	CALL GETPAR(IDGAMA,NS,IERR)
226	IF(IERR.EQ.0) THEN
227	UP = (UP1EP1+UPEP)
228	VP = (VP1EP1+VPEP)
229	WP = (WP1EP1+WPEP)
230	* Normalize the new direction cosines
231	WUP = SQRT(UP2+VP2+WP**2)
232	UP = UP/WUP
233	VP = VP/WUP
234	WP = WP/WUP
235	EP = EP1 + EP
236	AGEP = AGEP1 + AGEP
237	ENDIF
238	ENDIF
239	NGKINE = NGKINE + 1
240	PGEANT = EP * 1.E-9
241	GKIN(1,NGKINE) = UP*PGEANT
242	GKIN(2,NGKINE) = VP*PGEANT
243	GKIN(3,NGKINE) = WP*PGEANT
244	GKIN(4,NGKINE) = PGEANT
245	GKIN(5,NGKINE) = 1
246	TOFD(NGKINE) = AGEP * 1.E-9
247	GPOS(1,NGKINE) = VECT(1)
248	GPOS(2,NGKINE) = VECT(2)
249	GPOS(3,NGKINE) = VECT(3)
250	* NG = NG + 1
251	* NPHETC = NPHETC + 1
252	* IF(NPHETC.GT.MXCP) NPHETC=MXCP
253	* IPCAL(NPHETC) = 11
254	* EKINET(NPHETC) = EP*1.E-6
255	* UCAL(NPHETC,1) = UP
256	* UCAL(NPHETC,2) = VP
257	* UCAL(NPHETC,3) = WP
258	* CALTIM(NPHETC) = AGEP
259	C nucleus is in ground state !
260	EXMED = 0.0
261	ENDIF
262	50 CONTINUE
263	* only one neutron generated -> the particle is the same
264	60 IF (NGKINE.EQ.1.AND.GKIN(5,1).EQ.13) THEN
265	NGKINE = 0
266	CALL GETPAR(IDNEU,1,IERR)
267	VECT(4) = UP
268	VECT(5) = VP
269	VECT(6) = WP
270	GEKIN = EP * 1.E-9
271	GETOT = GEKIN + AGEMNE
272	VECT(7) = SQRT(GEKIN(GEKIN+2.AGEMNE))
273	TOFG = TOFG + AGEP * 1.E-9
274	ISTOP = 0
275	ENDIF
276	*
277	IF (MTP .EQ. 2) THEN
278	INTCAL = 13
279	ELSEIF (MTP .EQ. 18) THEN
280	IF (NHEVY.GT.0) INTCAL = 15
281	ELSEIF (MTP .LT. 100) THEN
282	IF (NNEU .GT.0) INTCAL = 20
283	ELSEIF (MTP .EQ. 102) THEN
284	IF (NGAMA.GT.0) INTCAL = 18
285	ELSEIF (MTP .GE. 100) THEN
286	IF (NHEVY+NGAMA.GT.0) INTCAL = 16
287	ENDIF
288	IF(NNEU+NHEVY+NGAMA.GT.0.AND.INTCAL.EQ.0) INTCAL=12
289	KCASE = NAMEC(INTCAL)
290	END