C++InterfacetoTauola
F/tauface-KK-F/Tauface.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 */////////////////////////////////////////////////////////////////////////////////////
35 *// //
36 *// !!!!!!! WARNING!!!!! This source is agressive !!!! //
37 *// //
38 *// due to short common block names it owerwrites variables in other parts //
39 *// of the code. //
40 *// //
41 *// one should add suffix c_taul_ to names of all commons as soon as possible!!!! //
42 *// //
43 */////////////////////////////////////////////////////////////////////////////////////
44 
45 */////////////////////////////////////////////////////////////////////////////////////
46 *// //
47 *// standard tauola interface/initialization routines of functionality exactly //
48 *// as in tauola cpc but input is partially from xpar(*) matrix //
49 *// itauxpar is for indirect adressing //
50 *// //
51 */////////////////////////////////////////////////////////////////////////////////////
52 
53 
54  SUBROUTINE inietc(ITAUXPAR,xpar)
55  include "BXformat.h"
56  REAL*8 xpar(*)
57  INTEGER inut,iout
58  COMMON /inout/
59  $ inut, ! Input unit number (not used)
60  $ iout ! Ounput unit number
61  COMMON / idfc / idff
62  COMMON / taurad / xk0dec,itdkrc
63  DOUBLE PRECISION xk0dec
64  COMMON / jaki / jak1,jak2,jakp,jakm,ktom
65 * note: i dont see keya1=2,3 realy implemented in the code sj. ??????
66  INTEGER keya1
67  COMMON /testa1/
68  $ keya1 ! Special switch for tests of dGamma/dQ**2 in a1 decay
69 * keya1=1 constant width of a1 and rho
70 * keya1=2 free choice of rho propagator(defined in function fpik)
71 * and free choice of a1 mass and width. function g(Q**2)
72 * (see formula 3.48 in comp. phys. comm. 64 (1991) 275)
73 * hard coded both in monte carlo and in testing distribution.
74 * keya1=3 function g(Q**2) hardcoded in the Monte Carlo
75 * (it is timy to calculate!), but appropriately adjusted in testing distribution.
76  SAVE
77  idff = xpar(itauxpar+3) ! Lund identifier for first tau (15 for tau-)
78 c xk0 for tau decays.
79  xk0dec = xpar(itauxpar+5) ! IR-cut for QED rad. in leptonic decays
80 c radiative correction switch in tau --> e(mu) decays !
81  itdkrc = xpar(itauxpar+4) ! QED rad. in leptonic decays
82 c switches of tau+ tau- decay modes !!
83  jak1 = xpar(itauxpar+1) ! Decay Mask for first tau
84  jak2 = xpar(itauxpar+2) ! Decay Mask for second tau
85 c output file number for tauola
86  iout = xpar(4)
87 c keya1 is used for formfactors actually not in use
88  keya1 = xpar(itauxpar+6) ! Type of a1 current
89 
90  WRITE(iout,bxope)
91  WRITE(iout,bxtxt) ' Parameters passed from KK to Tauola: '
92  WRITE(iout,bxl1i) jak1, 'dec. type 1-st tau ','Jak1 ','t01'
93  WRITE(iout,bxl1i) jak2, 'dec. type 2-nd tau ','Jak2 ','t02'
94  WRITE(iout,bxl1i) keya1, 'current type a1 dec.','KeyA1 ','t03'
95  WRITE(iout,bxl1i) idff, 'PDG id 1-st tau ','idff ','t04'
96  WRITE(iout,bxl1i) itdkrc, 'R.c. switch lept dec','itdkRC','t05'
97  WRITE(iout,bxl1g) xk0dec, 'IR-cut for lept r.c.','xk0dec','t06'
98  WRITE(iout,bxclo)
99 
100  end
101 
102  SUBROUTINE initdk(ITAUXPAR,xpar)
103 * ----------------------------------------------------------------------
104 * initialisation of tau decay parameters and routines
105 *
106 * called by : koralz
107 * ----------------------------------------------------------------------
108  include "BXformat.h"
109  INTEGER inut,iout
110  COMMON /inout/
111  $ inut, ! Input unit number (not used)
112  $ iout ! Ounput unit number
113  REAL*8 xpar(*)
114 
115  COMMON / decpar / gfermi,gv,ga,ccabib,scabib,gamel
116  REAL*4 gfermi,gv,ga,ccabib,scabib,gamel
117  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
118  * ,ampiz,ampi,amro,gamro,ama1,gama1
119  * ,amk,amkz,amkst,gamkst
120 *
121  REAL*4 amtau,amnuta,amel,amnue,ammu,amnumu
122  * ,ampiz,ampi,amro,gamro,ama1,gama1
123  * ,amk,amkz,amkst,gamkst
124  COMMON / taubra / gamprt(30),jlist(30),nchan
125  COMMON / taukle / bra1,brk0,brk0b,brks
126  REAL*4 bra1,brk0,brk0b,brks
127  parameter(nmode=15,nm1=0,nm2=1,nm3=8,nm4=2,nm5=1,nm6=3)
128  COMMON / taudcd /idffin(9,nmode),mulpik(nmode)
129  & ,names
130  CHARACTER names(nmode)*31
131  CHARACTER oldnames(7)*31
132  CHARACTER*80 bxinit
133  parameter(
134  $ bxinit ='(1x,1h*,g17.8, 16x, a31,a4,a4, 1x,1h*)'
135  $ )
136  REAL*4 pi,pol1(4)
137 *
138 *
139 * list of branching ratios
140 cam normalised to e nu nutau channel
141 cam enu munu pinu rhonu a1nu knu k*nu pi
142 cam DATA jlist / 1, 2, 3, 4, 5, 6, 7,
143 *am DATA gamprt /1.000,0.9730,0.6054,1.2432,0.8432,0.0432,o.o811,0.616
144 *am
145 *am multipion decays
146 *
147 * conventions of particles names
148 * k-,p-,k+, k0,p-,kb, k-,p0,k0
149 * 3, 1,-3 , 4, 1,-4 , 3, 2, 4 ,
150 * p0,p0,k-, k-,p-,p+, p-,kb,p0
151 * 2, 2, 3 , 3, 1,-1 , 1,-4, 2 ,
152 * et,p-,p0 p-,p0,gm
153 * 9, 1, 2 , 1, 2, 8
154 *
155 c
156  dimension nopik(6,nmode),npik(nmode)
157 *am outgoing multiplicity and flavors of multi-pion /multi-k modes
158  DATA npik / 4, 4,
159  1 5, 5,
160  2 6, 6,
161  3 3, 3,
162  4 3, 3,
163  5 3, 3,
164  6 3, 3,
165  7 2 /
166  DATA nopik / -1,-1, 1, 2, 0, 0, 2, 2, 2,-1, 0, 0,
167  1 -1,-1, 1, 2, 2, 0, -1,-1,-1, 1, 1, 0,
168  2 -1,-1,-1, 1, 1, 2, -1,-1, 1, 2, 2, 2,
169  3 -3,-1, 3, 0, 0, 0, -4,-1, 4, 0, 0, 0,
170  4 -3, 2,-4, 0, 0, 0, 2, 2,-3, 0, 0, 0,
171  5 -3,-1, 1, 0, 0, 0, -1, 4, 2, 0, 0, 0,
172  6 9,-1, 2, 0, 0, 0, -1, 2, 8, 0, 0, 0,
173 c ajwmod fix sign bug, 2/22/99
174  7 -3,-4, 0, 0, 0, 0 /
175 * list of branching ratios
176  nchan = nmode + 7
177  DO 1 i = 1,30
178  IF (i.LE.nchan) THEN
179  jlist(i) = i
180  IF(i.EQ. 1) gamprt(i) =0.1800
181  IF(i.EQ. 2) gamprt(i) =0.1751
182  IF(i.EQ. 3) gamprt(i) =0.1110
183  IF(i.EQ. 4) gamprt(i) =0.2515
184  IF(i.EQ. 5) gamprt(i) =0.1790
185  IF(i.EQ. 6) gamprt(i) =0.0071
186  IF(i.EQ. 7) gamprt(i) =0.0134
187  IF(i.EQ. 8) gamprt(i) =0.0450
188  IF(i.EQ. 9) gamprt(i) =0.0100
189  IF(i.EQ.10) gamprt(i) =0.0009
190  IF(i.EQ.11) gamprt(i) =0.0004
191  IF(i.EQ.12) gamprt(i) =0.0003
192  IF(i.EQ.13) gamprt(i) =0.0005
193  IF(i.EQ.14) gamprt(i) =0.0015
194  IF(i.EQ.15) gamprt(i) =0.0015
195  IF(i.EQ.16) gamprt(i) =0.0015
196  IF(i.EQ.17) gamprt(i) =0.0005
197  IF(i.EQ.18) gamprt(i) =0.0050
198  IF(i.EQ.19) gamprt(i) =0.0055
199  IF(i.EQ.20) gamprt(i) =0.0017
200  IF(i.EQ.21) gamprt(i) =0.0013
201  IF(i.EQ.22) gamprt(i) =0.0010
202  IF(i.EQ. 1) oldnames(i)=' TAU- --> E- '
203  IF(i.EQ. 2) oldnames(i)=' TAU- --> MU- '
204  IF(i.EQ. 3) oldnames(i)=' TAU- --> PI- '
205  IF(i.EQ. 4) oldnames(i)=' TAU- --> PI-, PI0 '
206  IF(i.EQ. 5) oldnames(i)=' TAU- --> A1- (two subch) '
207  IF(i.EQ. 6) oldnames(i)=' TAU- --> K- '
208  IF(i.EQ. 7) oldnames(i)=' TAU- --> K*- (two subch) '
209  IF(i.EQ. 8) names(i-7)=' TAU- --> 2PI-, PI0, PI+ '
210  IF(i.EQ. 9) names(i-7)=' TAU- --> 3PI0, PI- '
211  IF(i.EQ.10) names(i-7)=' TAU- --> 2PI-, PI+, 2PI0 '
212  IF(i.EQ.11) names(i-7)=' TAU- --> 3PI-, 2PI+, '
213  IF(i.EQ.12) names(i-7)=' TAU- --> 3PI-, 2PI+, PI0 '
214  IF(i.EQ.13) names(i-7)=' TAU- --> 2PI-, PI+, 3PI0 '
215  IF(i.EQ.14) names(i-7)=' TAU- --> K-, PI-, K+ '
216  IF(i.EQ.15) names(i-7)=' TAU- --> K0, PI-, K0B '
217  IF(i.EQ.16) names(i-7)=' TAU- --> K-, K0, PI0 '
218  IF(i.EQ.17) names(i-7)=' TAU- --> PI0 PI0 K- '
219  IF(i.EQ.18) names(i-7)=' TAU- --> K- PI- PI+ '
220  IF(i.EQ.19) names(i-7)=' TAU- --> PI- K0B PI0 '
221  IF(i.EQ.20) names(i-7)=' TAU- --> ETA PI- PI0 '
222  IF(i.EQ.21) names(i-7)=' TAU- --> PI- PI0 GAM '
223  IF(i.EQ.22) names(i-7)=' TAU- --> K- K0 '
224  ELSE
225  jlist(i) = 0
226  gamprt(i) = 0.
227  ENDIF
228  1 CONTINUE
229  DO i=1,nmode
230  mulpik(i)=npik(i)
231  DO j=1,mulpik(i)
232  idffin(j,i)=nopik(j,i)
233  ENDDO
234  ENDDO
235 *
236 *
237 * --- coefficients to fix ratio of:
238 * --- a1 3charged/ a1 1charged 2 neutrals matrix elements(masless lim.)
239 * --- probability of k0 to be ks
240 * --- probability of k0b to be ks
241 * --- ratio of coefficients for k*--> k0 pi-
242 * --- all coefficents should be in the range(0.0,1.0)
243 * --- they meaning is probability of the first choice only IF one
244 * --- neglects mass-phase space effects
245  bra1=0.5
246  brk0=0.5
247  brk0b=0.5
248  brks=0.6667
249 *
250 
251  gfermi = 1.16637e-5
252  ccabib = 0.975
253  gv = 1.0
254  ga =-1.0
255 
256 
257 
258  gfermi = xpar(32)
259  IF (xpar(itauxpar+100+1).GT.-1d0) THEN
260 c initialization form kk
261  ccabib = xpar(itauxpar+7)
262  gv = xpar(itauxpar+8)
263  ga = xpar(itauxpar+9)
264 
265  bra1 = xpar(itauxpar+10)
266  brks = xpar(itauxpar+11)
267  brk0 = xpar(itauxpar+12)
268  brk0b = xpar(itauxpar+13)
269  DO k=1,nchan
270  gamprt(k)=xpar(itauxpar+100+k)
271  ENDDO
272  ENDIF
273 * zw 13.04.89 here was an error
274  scabib = sqrt(1.-ccabib**2)
275  pi =4.*atan(1.)
276  gamel = gfermi**2*amtau**5/(192*pi**3)
277 *
278 * CALL dexay(-1,pol1)
279 *
280 * printouts for kk version
281 
282  sum=0
283  DO k=1,nchan
284  sum=sum+gamprt(k)
285  ENDDO
286 
287 
288  WRITE(iout,bxope)
289  WRITE(iout,bxtxt) ' TAUOLA Initialization SUBROUTINE INITDK: '
290  WRITE(iout,bxtxt) ' Adopted to read from KK '
291  WRITE(iout,bxtxt) ' '
292  WRITE(iout,bxtxt) ' Choice Probability -- Decay Channel'
293  DO k=1,7
294  WRITE(iout,bxinit) gamprt(k)/sum, oldnames(k),'****','***'
295  ENDDO
296  DO k=8,7+nmode
297  WRITE(iout,bxinit) gamprt(k)/sum, names(k-7),'****','***'
298  ENDDO
299  WRITE(iout,bxtxt) ' In addition:'
300  WRITE(iout,bxinit) gv, 'Vector W-tau-nu coupl. ','****','***'
301  WRITE(iout,bxinit) ga, 'Axial W-tau-nu coupl. ','****','***'
302  WRITE(iout,bxinit) gfermi,'Fermi Coupling ','****','***'
303  WRITE(iout,bxinit) ccabib,'cabibo angle ','****','***'
304  WRITE(iout,bxinit) bra1, 'a1 br ratio (massless) ','****','***'
305  WRITE(iout,bxinit) brks, 'K* br ratio (massless) ','****','***'
306  WRITE(iout,bxclo)
307 
308  RETURN
309  END
310 
311  SUBROUTINE iniphy(XK00)
312 * ----------------------------------------------------------------------
313 * initialisation of parameters
314 * used in qed and/or gsw routines
315 * ----------------------------------------------------------------------
316  COMMON / qedprm /alfinv,alfpi,xk0
317  REAL*8 alfinv,alfpi,xk0
318  REAL*8 pi8,xk00
319 *
320  pi8 = 4.d0*datan(1.d0)
321  alfinv = 137.03604d0
322  alfpi = 1d0/(alfinv*pi8)
323  xk0=xk00
324  END
325 
326  SUBROUTINE inimas(ITAUXPAR,xpar)
327 * ----------------------------------------------------------------------
328 * initialisation of masses
329 *
330 * called by : koralz
331 * ----------------------------------------------------------------------
332  include "BXformat.h"
333  INTEGER inut,iout
334  COMMON /inout/
335  $ inut, ! Input unit number (not used)
336  $ iout ! Ounput unit number
337  REAL*8 xpar(*)
338  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
339  * ,ampiz,ampi,amro,gamro,ama1,gama1
340  * ,amk,amkz,amkst,gamkst
341 *
342  REAL*4 amtau,amnuta,amel,amnue,ammu,amnumu
343  * ,ampiz,ampi,amro,gamro,ama1,gama1
344  * ,amk,amkz,amkst,gamkst
345  CHARACTER*80 bxinit
346  parameter(
347  $ bxinit ='(1x,1h*,g17.8, 16x, a31,a4,a4, 1x,1h*)'
348  $ )
349 *
350 * in-coming / out-going fermion masses
351  amtau = xpar(656)
352  amnuta = 0.010
353  amel = xpar(616)
354  amnue = 0.0
355  ammu = xpar(636)
356  amnumu = 0.0
357 *
358 * masses used in tau decays
359  ampiz = 0.134964
360  ampi = 0.139568
361  amro = 0.773
362  gamro = 0.145
363 *c gamro = 0.666
364  ama1 = 1.251
365  gama1 = 0.599
366  amk = 0.493667
367  amkz = 0.49772
368  amkst = 0.8921
369  gamkst = 0.0513
370 c
371 c
372 c in-coming / out-going fermion masses
373 !! AMNUTA = PKORB(1,2)
374 !! AMNUE = PKORB(1,4)
375 !! AMNUMU = PKORB(1,6)
376 c
377 c masses used in tau decays cleo settings
378 !! AMPIZ = PKORB(1,7)
379 !! AMPI = PKORB(1,8)
380 !! AMRO = PKORB(1,9)
381 !! GAMRO = PKORB(2,9)
382  ama1 = 1.275 !! PKORB(1,10)
383  gama1 = 0.615 !! PKORB(2,10)
384 !! AMK = PKORB(1,11)
385 !! AMKZ = PKORB(1,12)
386 !! AMKST = PKORB(1,13)
387 !! GAMKST = PKORB(2,13)
388 c
389 
390  WRITE(iout,bxope)
391  WRITE(iout,bxtxt) ' TAUOLA Initialization SUBROUTINE INIMAS: '
392  WRITE(iout,bxtxt) ' Adopted to read from KK '
393  WRITE(iout,bxinit) amtau, 'AMTAU tau-mass ','****','***'
394  WRITE(iout,bxinit) amel , 'AMEL electron-mass ','****','***'
395  WRITE(iout,bxinit) ammu , 'AMMU muon-mass ','****','***'
396  WRITE(iout,bxclo)
397 
398  END
399  SUBROUTINE choice(MNUM,RR,ICHAN,PROB1,PROB2,PROB3,
400  $ amrx,gamrx,amra,gamra,amrb,gamrb)
401  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
402  * ,ampiz,ampi,amro,gamro,ama1,gama1
403  * ,amk,amkz,amkst,gamkst
404 c
405  REAL*4 amtau,amnuta,amel,amnue,ammu,amnumu
406  * ,ampiz,ampi,amro,gamro,ama1,gama1
407  * ,amk,amkz,amkst,gamkst
408 c
409  amrop=1.1
410  gamrop=0.36
411  amom=.782
412  gamom=0.0084
413 c xxxxa correspond to s2 channel !
414  IF(mnum.EQ.0) THEN
415  prob1=0.5
416  prob2=0.5
417  amrx =ama1
418  gamrx=gama1
419  amra =amro
420  gamra=gamro
421  amrb =amro
422  gamrb=gamro
423  ELSEIF(mnum.EQ.1) THEN
424  prob1=0.5
425  prob2=0.5
426  amrx =1.57
427  gamrx=0.9
428  amrb =amkst
429  gamrb=gamkst
430  amra =amro
431  gamra=gamro
432  ELSEIF(mnum.EQ.2) THEN
433  prob1=0.5
434  prob2=0.5
435  amrx =1.57
436  gamrx=0.9
437  amrb =amkst
438  gamrb=gamkst
439  amra =amro
440  gamra=gamro
441  ELSEIF(mnum.EQ.3) THEN
442  prob1=0.5
443  prob2=0.5
444  amrx =1.27
445  gamrx=0.3
446  amra =amkst
447  gamra=gamkst
448  amrb =amkst
449  gamrb=gamkst
450  ELSEIF(mnum.EQ.4) THEN
451  prob1=0.5
452  prob2=0.5
453  amrx =1.27
454  gamrx=0.3
455  amra =amkst
456  gamra=gamkst
457  amrb =amkst
458  gamrb=gamkst
459  ELSEIF(mnum.EQ.5) THEN
460  prob1=0.5
461  prob2=0.5
462  amrx =1.27
463  gamrx=0.3
464  amra =amkst
465  gamra=gamkst
466  amrb =amro
467  gamrb=gamro
468  ELSEIF(mnum.EQ.6) THEN
469  prob1=0.4
470  prob2=0.4
471  amrx =1.27
472  gamrx=0.3
473  amra =amro
474  gamra=gamro
475  amrb =amkst
476  gamrb=gamkst
477  ELSEIF(mnum.EQ.7) THEN
478  prob1=0.0
479  prob2=1.0
480  amrx =1.27
481  gamrx=0.9
482  amra =amro
483  gamra=gamro
484  amrb =amro
485  gamrb=gamro
486  ELSEIF(mnum.EQ.8) THEN
487  prob1=0.0
488  prob2=1.0
489  amrx =amrop
490  gamrx=gamrop
491  amrb =amom
492  gamrb=gamom
493  amra =amro
494  gamra=gamro
495  ELSEIF(mnum.EQ.101) THEN
496  prob1=.35
497  prob2=.35
498  amrx =1.2
499  gamrx=.46
500  amrb =amom
501  gamrb=gamom
502  amra =amom
503  gamra=gamom
504  ELSEIF(mnum.EQ.102) THEN
505  prob1=0.0
506  prob2=0.0
507  amrx =1.4
508  gamrx=.6
509  amrb =amom
510  gamrb=gamom
511  amra =amom
512  gamra=gamom
513  ELSE
514  prob1=0.0
515  prob2=0.0
516  amrx =ama1
517  gamrx=gama1
518  amra =amro
519  gamra=gamro
520  amrb =amro
521  gamrb=gamro
522  ENDIF
523 c
524  IF (rr.LE.prob1) THEN
525  ichan=1
526  ELSEIF(rr.LE.(prob1+prob2)) THEN
527  ichan=2
528  ax =amra
529  gx =gamra
530  amra =amrb
531  gamra=gamrb
532  amrb =ax
533  gamrb=gx
534  px =prob1
535  prob1=prob2
536  prob2=px
537  ELSE
538  ichan=3
539  ENDIF
540 c
541  prob3=1.0-prob1-prob2
542  END
543  FUNCTION dcdmas(IDENT)
544  COMMON / parmas / amtau,amnuta,amel,amnue,ammu,amnumu
545  * ,ampiz,ampi,amro,gamro,ama1,gama1
546  * ,amk,amkz,amkst,gamkst
547 *
548  REAL*4 amtau,amnuta,amel,amnue,ammu,amnumu
549  * ,ampiz,ampi,amro,gamro,ama1,gama1
550  * ,amk,amkz,amkst,gamkst
551  IF (ident.EQ. 1) THEN
552  apkmas=ampi
553  ELSEIF (ident.EQ.-1) THEN
554  apkmas=ampi
555  ELSEIF (ident.EQ. 2) THEN
556  apkmas=ampiz
557  ELSEIF (ident.EQ.-2) THEN
558  apkmas=ampiz
559  ELSEIF (ident.EQ. 3) THEN
560  apkmas=amk
561  ELSEIF (ident.EQ.-3) THEN
562  apkmas=amk
563  ELSEIF (ident.EQ. 4) THEN
564  apkmas=amkz
565  ELSEIF (ident.EQ.-4) THEN
566  apkmas=amkz
567  ELSEIF (ident.EQ. 8) THEN
568  apkmas=0.0001
569  ELSEIF (ident.EQ.-8) THEN
570  apkmas=0.0001
571  ELSEIF (ident.EQ. 9) THEN
572  apkmas=0.5488
573  ELSEIF (ident.EQ.-9) THEN
574  apkmas=0.5488
575  ELSE
576  print *, 'STOP IN APKMAS, WRONG IDENT=',ident
577  stop
578  ENDIF
579  dcdmas=apkmas
580  END
581  FUNCTION lunpik(ID,ISGN)
582  COMMON / taukle / bra1,brk0,brk0b,brks
583  REAL*4 bra1,brk0,brk0b,brks
584  REAL*4 xio(1)
585  ident=id*isgn
586  IF (ident.EQ. 1) THEN
587  ipkdef=-211
588  ELSEIF (ident.EQ.-1) THEN
589  ipkdef= 211
590  ELSEIF (ident.EQ. 2) THEN
591  ipkdef=111
592  ELSEIF (ident.EQ.-2) THEN
593  ipkdef=111
594  ELSEIF (ident.EQ. 3) THEN
595  ipkdef=-321
596  ELSEIF (ident.EQ.-3) THEN
597  ipkdef= 321
598  ELSEIF (ident.EQ. 4) THEN
599 *
600 * k0 --> k0_long(is 130) / k0_short(is 310) = 1/1
601  CALL ranmar(xio,1)
602  IF (xio(1).GT.brk0) THEN
603  ipkdef= 130
604  ELSE
605  ipkdef= 310
606  ENDIF
607  ELSEIF (ident.EQ.-4) THEN
608 *
609 * k0b--> k0_long(is 130) / k0_short(is 310) = 1/1
610  CALL ranmar(xio,1)
611  IF (xio(1).GT.brk0b) THEN
612  ipkdef= 130
613  ELSE
614  ipkdef= 310
615  ENDIF
616  ELSEIF (ident.EQ. 8) THEN
617  ipkdef= 22
618  ELSEIF (ident.EQ.-8) THEN
619  ipkdef= 22
620  ELSEIF (ident.EQ. 9) THEN
621  ipkdef= 221
622  ELSEIF (ident.EQ.-9) THEN
623  ipkdef= 221
624  ELSE
625  print *, 'STOP IN IPKDEF, WRONG IDENT=',ident
626  stop
627  ENDIF
628  lunpik=ipkdef
629  END
630 
631 
632 
633  SUBROUTINE taurdf(KTO)
634 c this routine can be called before any tau+ or tau- event is generated
635 c it can be used to generate tau+ and tau- samples of different
636 c contents
637  COMMON / taukle / bra1,brk0,brk0b,brks
638  REAL*4 bra1,brk0,brk0b,brks
639  COMMON / taubra / gamprt(30),jlist(30),nchan
640  IF (kto.EQ.1) THEN
641 c ==================
642 c ajwmod: set the brs for(a1+ -> rho+ pi0) and(k*+ -> k0 pi+)
643  bra1 = pkorb(4,1)
644  brks = pkorb(4,3)
645  brk0 = pkorb(4,5)
646  brk0b = pkorb(4,6)
647  ELSE
648 c ====
649 c ajwmod: set the brs for(a1+ -> rho+ pi0) and(k*+ -> k0 pi+)
650  bra1 = pkorb(4,2)
651  brks = pkorb(4,4)
652  brk0 = pkorb(4,5)
653  brk0b = pkorb(4,6)
654  ENDIF
655 c =====
656  END