C++InterfacetoTauola
F/jetset-F/tauola_photos_ini.f
1 /* copyright(c) 1991-2012 free software foundation, inc.
2  this file is part of the gnu c library.
3 
4  the gnu c library is free software; you can redistribute it and/or
5  modify it under the terms of the gnu lesser general Public
6  license as published by the free software foundation; either
7  version 2.1 of the license, or(at your option) any later version.
8 
9  the gnu c library is distributed in the hope that it will be useful,
10  but without any warranty; without even the implied warranty of
11  merchantability or fitness for a particular purpose. see the gnu
12  lesser general Public license for more details.
13 
14  you should have received a copy of the gnu lesser general Public
15  license along with the gnu c library; if not, see
16  <http://www.gnu.org/licenses/>. */
17 
18 
19 /* this header is separate from features.h so that the compiler can
20  include it implicitly at the start of every compilation. it must
21  not itself include <features.h> or any other header that includes
22  <features.h> because the implicit include comes before any feature
23  test macros that may be defined in a source file before it first
24  explicitly includes a system header. gcc knows the name of this
25  header in order to preinclude it. */
26 
27 /* we do support the iec 559 math functionality, real and complex. */
28 
29 /* wchar_t uses iso/iec 10646 (2nd ed., published 2011-03-15) /
30  unicode 6.0. */
31 
32 /* we do not support c11 <threads.h>. */
33 
34 c this file is created by hand from taumain.f
35 c actions: remove routines: taudem dectes taufil filhep
36 c add: inietc will not necesarily work fine ...
37 c replace tralo4
38 c rename iniphy to iniphx
39 
40  SUBROUTINE inietc(jakk1,jakk2,itd,ifpho)
41  COMMON / idfc / idff
42  COMMON / taurad / xk0dec,itdkrc
43  DOUBLE PRECISION xk0dec
44  COMMON / jaki / jak1,jak2,jakp,jakm,ktom
45  COMMON /phoact/ ifphot
46  SAVE
47 c kto=1 will denote tau+, thus :: idff=-15
48  idff=-15
49 c xk0 for tau decays.
50  xk0dec=0.01
51 c radiative correction switch in tau --> e(mu) decays !
52  itdkrc=itd
53 c switches of tau+ tau- decay modes !!
54  jak1=jakk1
55  jak2=jakk2
56 c photos activation switch
57  ifphot=ifpho
58  end
59 
60  SUBROUTINE tralo4(KTOS,PHOI,PHOF,AM)
61 !! Corrected 11.10.96 (ZW) tralor for KORALW.
62 !! better treatment is to cascade from tau rest-frame through W
63 !! restframe down to LAB.
64  COMMON / momdec / q1,q2,p1,p2,p3,p4
65  COMMON /tralid/ idtra
66  double precision q1(4),q2(4),p1(4),p2(4),p3(4),p4(4),p1qq(4),p2qq(4)
67  double precision pin(4),pout(4),pbst(4),pbs1(4),qq(4),pi
68  double precision thet,phi,exe
69  REAL*4 phoi(4),phof(4)
70  SAVE
71  DATA pi /3.141592653589793238462643d0/
72  am=sqrt(abs
73  $ (phoi(4)**2-phoi(3)**2-phoi(2)**2-phoi(1)**2))
74  idtra=ktos
75  DO k=1,4
76  pin(k)=phoi(k)
77  phof(k)=phoi(k)
78  ENDDO
79 ! write(*,*) idtra
80  IF (idtra.EQ.1) THEN
81  DO k=1,4
82  pbst(k)=p1(k)
83  qq(k)=q1(k)
84  ENDDO
85  ELSEIF(idtra.EQ.2) THEN
86  DO k=1,4
87  pbst(k)=p2(k)
88  qq(k)=q1(k)
89  ENDDO
90  ELSEIF(idtra.EQ.3) THEN
91  DO k=1,4
92  pbst(k)=p3(k)
93  qq(k)=q2(k)
94  ENDDO
95  ELSE
96  DO k=1,4
97  pbst(k)=p4(k)
98  qq(k)=q2(k)
99  ENDDO
100  ENDIF
101 
102 
103 
104  CALL bostdq(1,qq,pbst,pbst)
105  CALL bostdq(1,qq,p1,p1qq)
106  CALL bostdq(1,qq,p2,p2qq)
107  pbs1(4)=pbst(4)
108  pbs1(3)=sqrt(pbst(3)**2+pbst(2)**2+pbst(1)**2)
109  pbs1(2)=0d0
110  pbs1(1)=0d0
111  exe=(pbs1(4)+pbs1(3))/dsqrt(pbs1(4)**2-pbs1(3)**2)
112 c for ktos=1 boost is antiparallel to 4-momentum of p2.
113 c restframes of tau+ tau- and 'first' frame of 'higgs' are all connected
114 c by boosts along z axis
115  IF(ktos.EQ.1) exe=(pbs1(4)-pbs1(3))/dsqrt(pbs1(4)**2-pbs1(3)**2)
116  CALL bostd3(exe,pin,pout)
117 
118 c once in z/gamma/higgs rest frame we control further kinematics by p2qq for ktos=1,2
119  thet=acos(p2qq(3)/sqrt(p2qq(3)**2+p2qq(2)**2+p2qq(1)**2))
120  phi=0d0
121  phi=acos(p2qq(1)/sqrt(p2qq(2)**2+p2qq(1)**2))
122  IF(p2qq(2).LT.0d0) phi=2*pi-phi
123 
124  CALL rotpox(thet,phi,pout)
125  CALL bostdq(-1,qq,pout,pout)
126  DO k=1,4
127  phof(k)=pout(k)
128  ENDDO
129  END
130 
131 
132  SUBROUTINE choice(MNUM,RR,ICHAN,PROB1,PROB2,PROB3,
133  $ amrx,gamrx,amra,gamra,amrb,gamrb)
134  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
135  * ,ampiz,ampi,amro,gamro,ama1,gama1
136  * ,amk,amkz,amkst,gamkst
137 c
138  REAL*4 amtau,amnuta,amel,amnue,ammu,amnumu
139  * ,ampiz,ampi,amro,gamro,ama1,gama1
140  * ,amk,amkz,amkst,gamkst
141 c
142  amrop=1.1
143  gamrop=0.36
144  amom=.782
145  gamom=0.0084
146 c xxxxa correspond to s2 channel !
147  IF(mnum.EQ.0) THEN
148  prob1=0.5
149  prob2=0.5
150  amrx =ama1
151  gamrx=gama1
152  amra =amro
153  gamra=gamro
154  amrb =amro
155  gamrb=gamro
156  ELSEIF(mnum.EQ.1) THEN
157  prob1=0.5
158  prob2=0.5
159  amrx =1.57
160  gamrx=0.9
161  amrb =amkst
162  gamrb=gamkst
163  amra =amro
164  gamra=gamro
165  ELSEIF(mnum.EQ.2) THEN
166  prob1=0.5
167  prob2=0.5
168  amrx =1.57
169  gamrx=0.9
170  amrb =amkst
171  gamrb=gamkst
172  amra =amro
173  gamra=gamro
174  ELSEIF(mnum.EQ.3) THEN
175  prob1=0.5
176  prob2=0.5
177  amrx =1.27
178  gamrx=0.3
179  amra =amkst
180  gamra=gamkst
181  amrb =amkst
182  gamrb=gamkst
183  ELSEIF(mnum.EQ.4) THEN
184  prob1=0.5
185  prob2=0.5
186  amrx =1.27
187  gamrx=0.3
188  amra =amkst
189  gamra=gamkst
190  amrb =amkst
191  gamrb=gamkst
192  ELSEIF(mnum.EQ.5) THEN
193  prob1=0.5
194  prob2=0.5
195  amrx =1.27
196  gamrx=0.3
197  amra =amkst
198  gamra=gamkst
199  amrb =amro
200  gamrb=gamro
201  ELSEIF(mnum.EQ.6) THEN
202  prob1=0.4
203  prob2=0.4
204  amrx =1.27
205  gamrx=0.3
206  amra =amro
207  gamra=gamro
208  amrb =amkst
209  gamrb=gamkst
210  ELSEIF(mnum.EQ.7) THEN
211  prob1=0.0
212  prob2=1.0
213  amrx =1.27
214  gamrx=0.9
215  amra =amro
216  gamra=gamro
217  amrb =amro
218  gamrb=gamro
219  ELSEIF(mnum.EQ.8) THEN
220  prob1=0.0
221  prob2=1.0
222  amrx =amrop
223  gamrx=gamrop
224  amrb =amom
225  gamrb=gamom
226  amra =amro
227  gamra=gamro
228  ELSEIF(mnum.EQ.101) THEN
229  prob1=.35
230  prob2=.35
231  amrx =1.2
232  gamrx=.46
233  amrb =amom
234  gamrb=gamom
235  amra =amom
236  gamra=gamom
237  ELSEIF(mnum.EQ.102) THEN
238  prob1=0.0
239  prob2=0.0
240  amrx =1.4
241  gamrx=.6
242  amrb =amom
243  gamrb=gamom
244  amra =amom
245  gamra=gamom
246  ELSE
247  prob1=0.0
248  prob2=0.0
249  amrx =ama1
250  gamrx=gama1
251  amra =amro
252  gamra=gamro
253  amrb =amro
254  gamrb=gamro
255  ENDIF
256 c
257  IF (rr.LE.prob1) THEN
258  ichan=1
259  ELSEIF(rr.LE.(prob1+prob2)) THEN
260  ichan=2
261  ax =amra
262  gx =gamra
263  amra =amrb
264  gamra=gamrb
265  amrb =ax
266  gamrb=gx
267  px =prob1
268  prob1=prob2
269  prob2=px
270  ELSE
271  ichan=3
272  ENDIF
273 c
274  prob3=1.0-prob1-prob2
275  END
276  SUBROUTINE initdk
277 * ----------------------------------------------------------------------
278 * initialisation of tau decay parameters and routines
279 *
280 * called by : koralz
281 * ----------------------------------------------------------------------
282 
283  COMMON / decpar / gfermi,gv,ga,ccabib,scabib,gamel
284  REAL*4 gfermi,gv,ga,ccabib,scabib,gamel
285  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
286  * ,ampiz,ampi,amro,gamro,ama1,gama1
287  * ,amk,amkz,amkst,gamkst
288 *
289  REAL*4 amtau,amnuta,amel,amnue,ammu,amnumu
290  * ,ampiz,ampi,amro,gamro,ama1,gama1
291  * ,amk,amkz,amkst,gamkst
292  COMMON / taubra / gamprt(30),jlist(30),nchan
293  COMMON / taukle / bra1,brk0,brk0b,brks
294  REAL*4 bra1,brk0,brk0b,brks
295  parameter(nmode=15,nm1=0,nm2=1,nm3=8,nm4=2,nm5=1,nm6=3)
296  COMMON / taudcd /idffin(9,nmode),mulpik(nmode)
297  & ,names
298  CHARACTER names(nmode)*31
299  CHARACTER oldnames(7)*31
300  CHARACTER*80 bxinit
301  parameter(
302  $ bxinit ='(1x,1h*,g17.8, 16x, a31,a4,a4, 1x,1h*)'
303  $ )
304  REAL*4 pi,pol1(4)
305 *
306 *
307 * list of branching ratios
308 cam normalised to e nu nutau channel
309 cam enu munu pinu rhonu a1nu knu k*nu pi
310 cam DATA jlist / 1, 2, 3, 4, 5, 6, 7,
311 *am DATA gamprt /1.000,0.9730,0.6054,1.2432,0.8432,0.0432,o.o811,0.616
312 *am
313 *am multipion decays
314 *
315 * conventions of particles names
316 * k-,p-,k+, k0,p-,kb, k-,p0,k0
317 * 3, 1,-3 , 4, 1,-4 , 3, 2, 4 ,
318 * p0,p0,k-, k-,p-,p+, p-,kb,p0
319 * 2, 2, 3 , 3, 1,-1 , 1,-4, 2 ,
320 * et,p-,p0 p-,p0,gm
321 * 9, 1, 2 , 1, 2, 8
322 *
323 c
324  dimension nopik(6,nmode),npik(nmode)
325 *am outgoing multiplicity and flavors of multi-pion /multi-k modes
326  DATA npik / 4, 4,
327  1 5, 5,
328  2 6, 6,
329  3 3, 3,
330  4 3, 3,
331  5 3, 3,
332  6 3, 3,
333  7 2 /
334  DATA nopik / -1,-1, 1, 2, 0, 0, 2, 2, 2,-1, 0, 0,
335  1 -1,-1, 1, 2, 2, 0, -1,-1,-1, 1, 1, 0,
336  2 -1,-1,-1, 1, 1, 2, -1,-1, 1, 2, 2, 2,
337  3 -3,-1, 3, 0, 0, 0, -4,-1, 4, 0, 0, 0,
338  4 -3, 2,-4, 0, 0, 0, 2, 2,-3, 0, 0, 0,
339  5 -3,-1, 1, 0, 0, 0, -1, 4, 2, 0, 0, 0,
340  6 9,-1, 2, 0, 0, 0, -1, 2, 8, 0, 0, 0,
341 c ajwmod fix sign bug, 2/22/99
342  7 -3,-4, 0, 0, 0, 0 /
343 * list of branching ratios
344  nchan = nmode + 7
345  DO 1 i = 1,30
346  IF (i.LE.nchan) THEN
347  jlist(i) = i
348  IF(i.EQ. 1) gamprt(i) =0.1800
349  IF(i.EQ. 2) gamprt(i) =0.1751
350  IF(i.EQ. 3) gamprt(i) =0.1110
351  IF(i.EQ. 4) gamprt(i) =0.2515
352  IF(i.EQ. 5) gamprt(i) =0.1790
353  IF(i.EQ. 6) gamprt(i) =0.0071
354  IF(i.EQ. 7) gamprt(i) =0.0134
355  IF(i.EQ. 8) gamprt(i) =0.0450
356  IF(i.EQ. 9) gamprt(i) =0.0100
357  IF(i.EQ.10) gamprt(i) =0.0009
358  IF(i.EQ.11) gamprt(i) =0.0004
359  IF(i.EQ.12) gamprt(i) =0.0003
360  IF(i.EQ.13) gamprt(i) =0.0005
361  IF(i.EQ.14) gamprt(i) =0.0015
362  IF(i.EQ.15) gamprt(i) =0.0015
363  IF(i.EQ.16) gamprt(i) =0.0015
364  IF(i.EQ.17) gamprt(i) =0.0005
365  IF(i.EQ.18) gamprt(i) =0.0050
366  IF(i.EQ.19) gamprt(i) =0.0055
367  IF(i.EQ.20) gamprt(i) =0.0017
368  IF(i.EQ.21) gamprt(i) =0.0013
369  IF(i.EQ.22) gamprt(i) =0.0010
370  IF(i.EQ. 1) oldnames(i)=' TAU- --> E- '
371  IF(i.EQ. 2) oldnames(i)=' TAU- --> MU- '
372  IF(i.EQ. 3) oldnames(i)=' TAU- --> PI- '
373  IF(i.EQ. 4) oldnames(i)=' TAU- --> PI-, PI0 '
374  IF(i.EQ. 5) oldnames(i)=' TAU- --> A1- (two subch) '
375  IF(i.EQ. 6) oldnames(i)=' TAU- --> K- '
376  IF(i.EQ. 7) oldnames(i)=' TAU- --> K*- (two subch) '
377  IF(i.EQ. 8) names(i-7)=' TAU- --> 2PI-, PI0, PI+ '
378  IF(i.EQ. 9) names(i-7)=' TAU- --> 3PI0, PI- '
379  IF(i.EQ.10) names(i-7)=' TAU- --> 2PI-, PI+, 2PI0 '
380  IF(i.EQ.11) names(i-7)=' TAU- --> 3PI-, 2PI+, '
381  IF(i.EQ.12) names(i-7)=' TAU- --> 3PI-, 2PI+, PI0 '
382  IF(i.EQ.13) names(i-7)=' TAU- --> 2PI-, PI+, 3PI0 '
383  IF(i.EQ.14) names(i-7)=' TAU- --> K-, PI-, K+ '
384  IF(i.EQ.15) names(i-7)=' TAU- --> K0, PI-, K0B '
385  IF(i.EQ.16) names(i-7)=' TAU- --> K-, K0, PI0 '
386  IF(i.EQ.17) names(i-7)=' TAU- --> PI0 PI0 K- '
387  IF(i.EQ.18) names(i-7)=' TAU- --> K- PI- PI+ '
388  IF(i.EQ.19) names(i-7)=' TAU- --> PI- K0B PI0 '
389  IF(i.EQ.20) names(i-7)=' TAU- --> ETA PI- PI0 '
390  IF(i.EQ.21) names(i-7)=' TAU- --> PI- PI0 GAM '
391  IF(i.EQ.22) names(i-7)=' TAU- --> K- K0 '
392  ELSE
393  jlist(i) = 0
394  gamprt(i) = 0.
395  ENDIF
396  1 CONTINUE
397  DO i=1,nmode
398  mulpik(i)=npik(i)
399  DO j=1,mulpik(i)
400  idffin(j,i)=nopik(j,i)
401  ENDDO
402  ENDDO
403 *
404 *
405 * --- coefficients to fix ratio of:
406 * --- a1 3charged/ a1 1charged 2 neutrals matrix elements(masless lim.)
407 * --- probability of k0 to be ks
408 * --- probability of k0b to be ks
409 * --- ratio of coefficients for k*--> k0 pi-
410 * --- all coefficents should be in the range(0.0,1.0)
411 * --- they meaning is probability of the first choice only IF one
412 * --- neglects mass-phase space effects
413  bra1=0.5
414  brk0=0.5
415  brk0b=0.5
416  brks=0.6667
417 *
418 
419  gfermi = 1.16637e-5
420  ccabib = 0.975
421  gv = 1.0
422  ga =-1.0
423 
424 
425 
426 * zw 13.04.89 here was an error
427  scabib = sqrt(1.-ccabib**2)
428  pi =4.*atan(1.)
429  gamel = gfermi**2*amtau**5/(192*pi**3)
430 *
431  CALL dexay(-1,pol1)
432 *
433  RETURN
434  END
435  FUNCTION dcdmas(IDENT)
436  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
437  * ,ampiz,ampi,amro,gamro,ama1,gama1
438  * ,amk,amkz,amkst,gamkst
439 *
440  REAL*4 amtau,amnuta,amel,amnue,ammu,amnumu
441  * ,ampiz,ampi,amro,gamro,ama1,gama1
442  * ,amk,amkz,amkst,gamkst
443  IF (ident.EQ. 1) THEN
444  apkmas=ampi
445  ELSEIF (ident.EQ.-1) THEN
446  apkmas=ampi
447  ELSEIF (ident.EQ. 2) THEN
448  apkmas=ampiz
449  ELSEIF (ident.EQ.-2) THEN
450  apkmas=ampiz
451  ELSEIF (ident.EQ. 3) THEN
452  apkmas=amk
453  ELSEIF (ident.EQ.-3) THEN
454  apkmas=amk
455  ELSEIF (ident.EQ. 4) THEN
456  apkmas=amkz
457  ELSEIF (ident.EQ.-4) THEN
458  apkmas=amkz
459  ELSEIF (ident.EQ. 8) THEN
460  apkmas=0.0001
461  ELSEIF (ident.EQ.-8) THEN
462  apkmas=0.0001
463  ELSEIF (ident.EQ. 9) THEN
464  apkmas=0.5488
465  ELSEIF (ident.EQ.-9) THEN
466  apkmas=0.5488
467  ELSE
468  print *, 'STOP IN APKMAS, WRONG IDENT=',ident
469  stop
470  ENDIF
471  dcdmas=apkmas
472  END
473  FUNCTION lunpik(ID,ISGN)
474  COMMON / taukle / bra1,brk0,brk0b,brks
475  REAL*4 bra1,brk0,brk0b,brks
476  REAL*4 xio(1)
477  ident=id*isgn
478  IF (ident.EQ. 1) THEN
479  ipkdef=-211
480  ELSEIF (ident.EQ.-1) THEN
481  ipkdef= 211
482  ELSEIF (ident.EQ. 2) THEN
483  ipkdef=111
484  ELSEIF (ident.EQ.-2) THEN
485  ipkdef=111
486  ELSEIF (ident.EQ. 3) THEN
487  ipkdef=-321
488  ELSEIF (ident.EQ.-3) THEN
489  ipkdef= 321
490  ELSEIF (ident.EQ. 4) THEN
491 *
492 * k0 --> k0_long(is 130) / k0_short(is 310) = 1/1
493  CALL ranmar(xio,1)
494  IF (xio(1).GT.brk0) THEN
495  ipkdef= 130
496  ELSE
497  ipkdef= 310
498  ENDIF
499  ELSEIF (ident.EQ.-4) THEN
500 *
501 * k0b--> k0_long(is 130) / k0_short(is 310) = 1/1
502  CALL ranmar(xio,1)
503  IF (xio(1).GT.brk0b) THEN
504  ipkdef= 130
505  ELSE
506  ipkdef= 310
507  ENDIF
508  ELSEIF (ident.EQ. 8) THEN
509  ipkdef= 22
510  ELSEIF (ident.EQ.-8) THEN
511  ipkdef= 22
512  ELSEIF (ident.EQ. 9) THEN
513  ipkdef= 221
514  ELSEIF (ident.EQ.-9) THEN
515  ipkdef= 221
516  ELSE
517  print *, 'STOP IN IPKDEF, WRONG IDENT=',ident
518  stop
519  ENDIF
520  lunpik=ipkdef
521  END
522 
523 
524 
525  SUBROUTINE taurdf(KTO)
526 c this routine can be called before any tau+ or tau- event is generated
527 c it can be used to generate tau+ and tau- samples of different
528 c contents
529  COMMON / taukle / bra1,brk0,brk0b,brks
530  REAL*4 bra1,brk0,brk0b,brks
531  COMMON / taubra / gamprt(30),jlist(30),nchan
532  IF (kto.EQ.1) THEN
533 c ==================
534 c ajwmod: set the brs for(a1+ -> rho+ pi0) and(k*+ -> k0 pi+)
535  bra1 = pkorb(4,1)
536  brks = pkorb(4,3)
537  brk0 = pkorb(4,5)
538  brk0b = pkorb(4,6)
539  ELSE
540 c ====
541 c ajwmod: set the brs for(a1+ -> rho+ pi0) and(k*+ -> k0 pi+)
542  bra1 = pkorb(4,2)
543  brks = pkorb(4,4)
544  brk0 = pkorb(4,5)
545  brk0b = pkorb(4,6)
546  ENDIF
547 c =====
548  END
549 
550  SUBROUTINE iniphx(XK00)
551 * ----------------------------------------------------------------------
552 * initialisation of parameters
553 * used in qed and/or gsw routines
554 * ----------------------------------------------------------------------
555  COMMON / qedprm /alfinv,alfpi,xk0
556  REAL*8 alfinv,alfpi,xk0
557  REAL*8 pi8,xk00
558 *
559  pi8 = 4.d0*datan(1.d0)
560  alfinv = 137.03604d0
561  alfpi = 1d0/(alfinv*pi8)
562  xk0=xk00
563  END
564 
565  SUBROUTINE inimas
566 c ----------------------------------------------------------------------
567 c initialisation of masses
568 c
569 c called by : koralz
570 c ----------------------------------------------------------------------
571  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
572  * ,ampiz,ampi,amro,gamro,ama1,gama1
573  * ,amk,amkz,amkst,gamkst
574 *
575  REAL*4 amtau,amnuta,amel,amnue,ammu,amnumu
576  * ,ampiz,ampi,amro,gamro,ama1,gama1
577  * ,amk,amkz,amkst,gamkst
578 c
579 c in-coming / out-going fermion masses
580  amtau = 1.7842
581 c --- tau mass must be the same as in the host program, what-so-ever
582  amtau = 1.777
583  amnuta = 0.010
584  amel = 0.0005111
585  amnue = 0.0
586  ammu = 0.105659
587  amnumu = 0.0
588 *
589 * masses used in tau decays
590  ampiz = 0.134964
591  ampi = 0.139568
592  amro = 0.773
593  gamro = 0.145
594 *c gamro = 0.666
595  ama1 = 1.251
596  gama1 = 0.599
597  amk = 0.493667
598  amkz = 0.49772
599  amkst = 0.8921
600  gamkst = 0.0513
601 c
602 c
603 c in-coming / out-going fermion masses
604 !! AMNUTA = PKORB(1,2)
605 !! AMNUE = PKORB(1,4)
606 !! AMNUMU = PKORB(1,6)
607 c
608 c masses used in tau decays cleo settings
609 !! AMPIZ = PKORB(1,7)
610 !! AMPI = PKORB(1,8)
611 !! AMRO = PKORB(1,9)
612 !! GAMRO = PKORB(2,9)
613  ama1 = 1.275 !! PKORB(1,10)
614  gama1 = 0.615 !! PKORB(2,10)
615 !! AMK = PKORB(1,11)
616 !! AMKZ = PKORB(1,12)
617 !! AMKST = PKORB(1,13)
618 !! GAMKST = PKORB(2,13)
619 c
620 
621  RETURN
622  END
623  subroutine bostdq(idir,vv,pp,q)
624 * *******************************
625 c boost along arbitrary vector v(see eg. j.d. jacson, classical
626 c electrodynamics).
627 c four-vector pp is boosted from an actual frame to the rest frame
628 c of the four-vector v(for idir=1) or back(for idir=-1).
629 c q is a resulting four-vector.
630 c note: v must be time-like, pp may be arbitrary.
631 c
632 c written by: wieslaw placzek date: 22.07.1994
633 c last update: 3/29/95 by: m.s.
634 c
635  implicit DOUBLE PRECISION (a-h,o-z)
636  parameter(nout=6)
637  DOUBLE PRECISION v(4),p(4),q(4),pp(4),vv(4)
638  save
639 !
640  do 1 i=1,4
641  v(i)=vv(i)
642  1 p(i)=pp(i)
643  amv=(v(4)**2-v(1)**2-v(2)**2-v(3)**2)
644  if (amv.le.0d0) then
645  write(6,*) 'bosstv: warning amv**2=',amv
646  endif
647  amv=sqrt(abs(amv))
648  if (idir.eq.-1) then
649  q(4)=( p(1)*v(1)+p(2)*v(2)+p(3)*v(3)+p(4)*v(4))/amv
650  wsp =(q(4)+p(4))/(v(4)+amv)
651  elseif (idir.eq.1) then
652  q(4)=(-p(1)*v(1)-p(2)*v(2)-p(3)*v(3)+p(4)*v(4))/amv
653  wsp =-(q(4)+p(4))/(v(4)+amv)
654  else
655  write(nout,*)' >>> boostv: wrong value of idir = ',idir
656  endif
657  q(1)=p(1)+wsp*v(1)
658  q(2)=p(2)+wsp*v(2)
659  q(3)=p(3)+wsp*v(3)
660  end
661 
662 
663 
664 
665 
666 
667 
668 
669