source: branches/start/MagicSoft/Simulation/Corsika/Mmcs/pparam.f

Last change on this file was 286, checked in by harald, 25 years ago
This is the start point for further developments of the Magic Monte Carlo Simulation written by Jose Carlos Gonzales. Now it is under control of one CVS repository for the whole collaboration. Everyone should use this CVS repository for further developments.
File size: 11.4 KB
Line 
1 SUBROUTINE PPARAM
2
3C-----------------------------------------------------------------------
4C P(ARTICLE) PARAM(ETERS)
5C
6C SETS PARAMETERS (PARTICLE TYP, TRANSVERSE MOMENTUM)
7C OF SECONDARY PARTICLES IN HDPM
8C THIS SUBROUTINE IS CALLED FROM HDPM
9C
10C DESIGN : D. HECK IK3 FZK KARLSRUHE
11C CHANGES : J.N. CAPDEVIELLE CDF PARIS
12C-----------------------------------------------------------------------
13
14 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15*KEEP,AVPT.
16 COMMON /AVPT/ AVPT,AVPK,AVPN,AVPH,AVPE
17 DOUBLE PRECISION AVPT,AVPK,AVPN,AVPH,AVPE
18*KEEP,DPMFLG.
19 COMMON /DPMFLG/ NFLAIN,NFLDIF,NFLPI0,NFLCHE,NFLPIF,NFRAGM
20 INTEGER NFLAIN,NFLDIF,NFLPI0,NFLCHE,NFLPIF,NFRAGM
21*KEEP,INDICE.
22 COMMON /INDICE/ NNUCN,NKA0,NHYPN,NETA,NETAS,NPIZER,
23 * NNC,NKC,NHC,NPC,NCH,NNN,NKN,NHN,NET,NPN
24 INTEGER NNUCN(2:3),NKA0(2:3),NHYPN(2:3),NETA(2:3,1:4),
25 * NETAS(2:3),NPIZER(2:3),
26 * NNC,NKC,NHC,NPC,NCH,NNN,NKN,NHN,NET,NPN
27*KEEP,INTER.
28 COMMON /INTER/ AVCH,AVCH3,DC0,DLOG,DMLOG,ECMDIF,ECMDPM,ELAB,
29 * FNEUT,FNEUT2,GNU,PLAB,POSC2,POSC3,POSN2,POSN3,
30 * RC3TO2,S,SEUGF,SEUGP,SLOG,SLOGSQ,SMLOG,
31 * WIDC2,WIDC3,WIDN2,WIDN3,YCM,YY0,ZN,
32 * IDIF,ITAR
33 DOUBLE PRECISION AVCH,AVCH3,DC0,DLOG,DMLOG,ECMDIF,ECMDPM,ELAB,
34 * FNEUT,FNEUT2,GNU,PLAB,POSC2,POSC3,POSN2,POSN3,
35 * RC3TO2,S,SEUGF,SEUGP,SLOG,SLOGSQ,SMLOG,
36 * WIDC2,WIDC3,WIDN2,WIDN3,YCM,YY0,ZN
37 INTEGER IDIF,ITAR
38*KEEP,LEPAR.
39 COMMON /LEPAR/ LEPAR1,LEPAR2,LASTPI,NRESPC,NRESPN,NCPLUS
40 INTEGER LEPAR1,LEPAR2,LASTPI,NRESPC,NRESPN,NCPLUS
41*KEEP,NEWPAR.
42 COMMON /NEWPAR/ EA,PT2,PX,PY,TMAS,YR,ITYP,
43 * IA1,IA2,IB1,IB2,IC1,IC2,ID1,ID2,IE1,IE2,IF1,IF2,
44 * IG1,IG2,IH1,IH2,II1,II2,IJ1,NTOT
45 DOUBLE PRECISION EA(3000),PT2(3000),PX(3000),PY(3000),TMAS(3000),
46 * YR(3000)
47 INTEGER ITYP(3000),
48 * IA1,IA2,IB1,IB2,IC1,IC2,ID1,ID2,IE1,IE2,IF1,IF2,
49 * IG1,IG2,IH1,IH2,II1,II2,IJ1,NTOT
50*KEEP,PAM.
51 COMMON /PAM/ PAMA,SIGNUM
52 DOUBLE PRECISION PAMA(6000),SIGNUM(6000)
53*KEEP,RANDPA.
54 COMMON /RANDPA/ FAC,U1,U2,RD,NSEQ,ISEED,KNOR
55 DOUBLE PRECISION FAC,U1,U2
56 REAL RD(3000)
57 INTEGER ISEED(103,10),NSEQ
58 LOGICAL KNOR
59*KEEP,RUNPAR.
60 COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,
61 * STEPFC,NRRUN,NSHOW,PATAPE,MONIIN,
62 * MONIOU,MDEBUG,NUCNUC,
63 * CETAPE,
64 * SHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
65 * N1STTR,MDBASE,
66 * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
67 * FIX1I,FMUADD,FNKG,FPRINT,FDBASE
68 * ,GHEISH,GHESIG
69 COMMON /RUNPAC/ DSN,HOST,USER
70 DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB
71 REAL STEPFC
72 INTEGER NRRUN,NSHOW,PATAPE,MONIIN,MONIOU,MDEBUG,NUCNUC,
73 * SHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
74 * N1STTR,MDBASE
75 INTEGER CETAPE
76 CHARACTER*79 DSN
77 CHARACTER*20 HOST,USER
78
79 LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
80 * FIX1I,FMUADD,FNKG,FPRINT,FDBASE
81 * ,GHEISH,GHESIG
82*KEND.
83
84C-----------------------------------------------------------------------
85
86 IF ( DEBUG ) WRITE(MDEBUG,*) 'PPARAM: NTOT,NPC,NCPLUS=',
87 * NTOT,NPC,NCPLUS
88
89C FILL PARTICLES INTO ARRAYS, CALCULATE PT AND SUM UP
90 SPX = 0.D0
91 SPY = 0.D0
92 NPART = 3
93C PROTON ANTIPROTON PAIRS
94 DO 1003 K = 1,NNC
95 CALL RMMAR( RD,1,1 )
96 IF ( RD(1) .LT. 0.5 ) THEN
97 ITYP(NPART) = 14
98 ITYP(NPART+1) = 15
99 ELSE
100 ITYP(NPART) = 15
101 ITYP(NPART+1) = 14
102 ENDIF
103 CALL PTRAM( ZN,AVPN,PX(NPART),PY(NPART) )
104 CALL PTRAM( ZN,AVPN,PX(NPART+1),PY(NPART+1) )
105 SPX = SPX + PX(NPART) + PX(NPART+1)
106 SPY = SPY + PY(NPART) + PY(NPART+1)
107 NPART = NPART + 2
108 1003 CONTINUE
109C K+ K- PAIRS
110 DO 1004 K = 1,NKC
111 CALL RMMAR( RD,1,1 )
112 IF ( RD(1) .LT. 0.5 ) THEN
113 ITYP(NPART) = 11
114 ITYP(NPART+1) = 12
115 ELSE
116 ITYP(NPART) = 12
117 ITYP(NPART+1) = 11
118 ENDIF
119 CALL PTRAM( ZN,AVPK,PX(NPART),PY(NPART) )
120 CALL PTRAM( ZN,AVPK,PX(NPART+1),PY(NPART+1) )
121 SPX = SPX + PX(NPART) + PX(NPART+1)
122 SPY = SPY + PY(NPART) + PY(NPART+1)
123 NPART = NPART + 2
124 1004 CONTINUE
125C SIGMA PAIRS
126 DO 1005 K = 1,NHC
127 CALL RMMAR( RD,2,1 )
128 IF ( RD(1) .LT. 0.5 ) THEN
129 IF ( RD(2) .LT. 0.5 ) THEN
130 ITYP(NPART) = 19
131 ITYP(NPART+1) = 27
132 ELSE
133 ITYP(NPART) = 27
134 ITYP(NPART+1) = 19
135 ENDIF
136 ELSE
137 IF ( RD(2) .LT. 0.5 ) THEN
138 ITYP(NPART) = 21
139 ITYP(NPART+1) = 29
140 ELSE
141 ITYP(NPART) = 29
142 ITYP(NPART+1) = 21
143 ENDIF
144 ENDIF
145 CALL PTRAM( ZN,AVPH,PX(NPART),PY(NPART) )
146 CALL PTRAM( ZN,AVPH,PX(NPART+1),PY(NPART+1) )
147 SPX = SPX + PX(NPART) + PX(NPART+1)
148 SPY = SPY + PY(NPART) + PY(NPART+1)
149 NPART = NPART + 2
150 1005 CONTINUE
151
152C DECIDE WITH WHICH CHARGED PION TO START WITH
153C NUMBER OF PIONS MAY BE ODD IN THE CASE IF ISEL IS 1
154 CALL RMMAR( RD,1,1 )
155 IF ( RD(1) .GT. 0.5 ) THEN
156 NPIOCH = 0
157 ELSE
158 NPIOCH = 1
159 ENDIF
160 NPOS = NCPLUS
161C PI +-
162 DO 1007 K = 1,NPC
163 IF ( NPC-K+1 .LE. NPOS ) THEN
164 NPIOCH = 1
165 IF ( DEBUG ) WRITE(MDEBUG,*) ' NPC,K,NPOS,NPIOCH=',
166 * NPC,K,NPOS,NPIOCH
167 ELSEIF ( NPC-K+1 .LE. -NPOS ) THEN
168 NPIOCH = 0
169 IF ( DEBUG ) WRITE(MDEBUG,*) ' NPC,K,-NPOS,NPIOCH=',
170 * NPC,K,-NPOS,NPIOCH
171 ENDIF
172 IF ( NPIOCH .EQ. 0 ) THEN
173 ITYP(NPART) = 8
174 NPIOCH = 1
175 NPOS = NPOS + 1
176 ELSE
177 ITYP(NPART) = 9
178 NPIOCH = 0
179 NPOS = NPOS - 1
180 ENDIF
181 CALL PTRAM( ZN,AVPT,PX(NPART),PY(NPART) )
182 SPX = SPX + PX(NPART)
183 SPY = SPY + PY(NPART)
184 NPART = NPART + 1
185 1007 CONTINUE
186C NEUTRON ANTINEUTRON PAIRS
187 DO 1008 K = 1,NNN
188 CALL RMMAR( RD,1,1 )
189 IF ( RD(1) .LT. 0.5 ) THEN
190 ITYP(NPART) = 13
191 ITYP(NPART+1) = 25
192 ELSE
193 ITYP(NPART) = 25
194 ITYP(NPART+1) = 13
195 ENDIF
196 CALL PTRAM( ZN,AVPN,PX(NPART),PY(NPART) )
197 CALL PTRAM( ZN,AVPN,PX(NPART+1),PY(NPART+1) )
198 SPX = SPX + PX(NPART) + PX(NPART+1)
199 SPY = SPY + PY(NPART) + PY(NPART+1)
200 NPART = NPART + 2
201 1008 CONTINUE
202C K0L K0S PAIRS
203 DO 1009 K = 1,NKN
204 CALL RMMAR( RD,1,1 )
205 IF ( RD(1) .LT. 0.5 ) THEN
206 ITYP(NPART) = 10
207 ITYP(NPART+1) = 16
208 ELSE
209 ITYP(NPART) = 16
210 ITYP(NPART+1) = 10
211 ENDIF
212 CALL PTRAM( ZN,AVPK,PX(NPART),PY(NPART) )
213 CALL PTRAM( ZN,AVPK,PX(NPART+1),PY(NPART+1) )
214 SPX = SPX + PX(NPART) + PX(NPART+1)
215 SPY = SPY + PY(NPART) + PY(NPART+1)
216 NPART = NPART + 2
217 1009 CONTINUE
218C LAMDA/SIGMA0 PAIRS
219 DO 1010 K = 1,NHN
220 CALL RMMAR( RD,2,1 )
221 IF ( RD(1) .LT. 0.5 ) THEN
222 IF ( RD(2) .LT. 0.5 ) THEN
223 ITYP(NPART) = 18
224 ITYP(NPART+1) = 28
225 ELSE
226 ITYP(NPART) = 28
227 ITYP(NPART+1) = 18
228 ENDIF
229 ELSE
230 IF ( RD(2) .LT. 0.5 ) THEN
231 ITYP(NPART) = 26
232 ITYP(NPART+1) = 20
233 ELSE
234 ITYP(NPART) = 20
235 ITYP(NPART+1) = 26
236 ENDIF
237 ENDIF
238C ----- CHANGE BY JNC DEC.96)
239 IF ( ECMDPM .LE. 500.D0 ) THEN
240 CALL PTRAN( ZN,AVPH,PX(NPART),PY(NPART) )
241 CALL PTRAN( ZN,AVPH,PX(NPART+1),PY(NPART+1) )
242 ELSE
243 CALL PTRAM( ZN,AVPH,PX(NPART),PY(NPART) )
244 CALL PTRAM( ZN,AVPH,PX(NPART+1),PY(NPART+1) )
245 ENDIF
246 SPX = SPX + PX(NPART) + PX(NPART+1)
247 SPY = SPY + PY(NPART) + PY(NPART+1)
248 NPART = NPART + 2
249 1010 CONTINUE
250C ETA
251 DO 1013 K = 1,NET
252C FIRST FOR ETAS FROM THIRD STRING
253 IF ( K .LE. NETA(3,1) ) THEN
254 ITYP(NPART) = 71
255 ELSEIF ( K .LE. NETA(3,1)+NETA(3,2) ) THEN
256 ITYP(NPART) = 72
257 ELSEIF ( K .LE. NETA(3,1)+NETA(3,2)+NETA(3,3) ) THEN
258 ITYP(NPART) = 73
259 ELSEIF ( K .LE. NETA(3,1)+NETA(3,2)+NETA(3,3)+NETA(3,4)) THEN
260 ITYP(NPART) = 74
261C NOW FOR ETAS FROM FIRST AND SECOND STRING
262 ELSEIF ( K .LE. NETAS(3)+NETA(2,1) ) THEN
263 ITYP(NPART) = 71
264 ELSEIF ( K .LE. NETAS(3)+NETA(2,1)+NETA(2,2) ) THEN
265 ITYP(NPART) = 72
266 ELSEIF ( K .LE. NETAS(3)+NETA(2,1)+NETA(2,2)+NETA(2,3) ) THEN
267 ITYP(NPART) = 73
268 ELSE
269 ITYP(NPART) = 74
270 ENDIF
271C ----- CHANGE BY JNC DEC.96)
272 IF ( ECMDPM .LE. 500.D0 ) THEN
273 CALL PTRAN( ZN,AVPE,PX(NPART),PY(NPART) )
274 ELSE
275 CALL PTRAM( ZN,AVPE,PX(NPART),PY(NPART) )
276 ENDIF
277 SPX = SPX + PX(NPART)
278 SPY = SPY + PY(NPART)
279 NPART = NPART + 1
280 1013 CONTINUE
281C PI(0)
282 DO 1014 K = 1,NPN
283 ITYP(NPART) = 7
284C ----- CHANGE BY JNC DEC.96)
285 IF ( ECMDPM .LE. 500.D0 ) THEN
286 CALL PTRAN( ZN,AVPT,PX(NPART),PY(NPART) )
287 ELSE
288 CALL PTRAM( ZN,AVPT,PX(NPART),PY(NPART) )
289 ENDIF
290 SPX = SPX + PX(NPART)
291 SPY = SPY + PY(NPART)
292 NPART = NPART + 1
293 1014 CONTINUE
294
295C ANTILEADER (FROM TARGET, THEREFORE ALWAYS NUCLEON OR DELTA RESONANCE)
296 ITYP(2) = LEPAR2
297C ----- CHANGE BY JNC DEC.96)
298 IF ( ECMDPM .LE. 500.D0 ) THEN
299 CALL PTRAN( ZN,AVPN,PX(2),PY(2) )
300 ELSE
301 CALL PTRAM( ZN,AVPN,PX(2),PY(2) )
302 ENDIF
303
304C FIRST PARTICLE IS LEADING PARTICLE
305 ITYP(1) = LEPAR1
306 IF ( (LEPAR1 .GE. 7 .AND. LEPAR1 .LE. 9) .OR.
307 * (LEPAR1 .GE. 51 .AND. LEPAR1 .LE. 53) ) THEN
308C LEADING PARTICLE IS PION OR RHO RESONANCE
309 AVERPT = AVPT
310C LEADING PARTICLE IS KAON OR KAON RESONANCE
311 ELSEIF ( LEPAR1 .EQ. 10 .OR. LEPAR1 .EQ. 11 .OR.
312 * LEPAR1 .EQ. 12 .OR. LEPAR1 .EQ. 16 .OR.
313 * (LEPAR1 .GE. 62 .AND. LEPAR1 .LE. 68) ) THEN
314 AVERPT = AVPK
315 ELSE
316C LEADING PARTICLE IS NUCLEON OR ANTINUCLEON OR DELTA RESONANCE
317C OR STRANGE BARYON
318 AVERPT = AVPN
319 ENDIF
320C ----- CHANGE BY JNC DEC.96)
321 IF ( ECMDPM .LE. 500.D0 ) THEN
322 CALL PTRAN( ZN,AVERPT,PX(1),PY(1) )
323 ELSE
324 CALL PTRAM( ZN,AVERPT,PX(1),PY(1) )
325 ENDIF
326 SPX = SPX + PX(1) + PX(2)
327 SPY = SPY + PY(1) + PY(2)
328
329C AVERAGE EXCESS PT PER PARTICLE
330 SPX = SPX / NTOT
331 SPY = SPY / NTOT
332
333C RENORMALIZATION OF PT AND CALCULATION OF TRANSVERSE MASSES
334 DO 130 I = 1,NTOT
335 PX(I) = PX(I) - SPX
336 PY(I) = PY(I) - SPY
337 PT2(I) = PX(I)**2 + PY(I)**2
338 TMAS(I) = SQRT( PAMA(ITYP(I))**2 + PT2(I) )
339 130 CONTINUE
340
341 RETURN
342 END
Note: See TracBrowser for help on using the repository browser.