Index: branches/rel-2.3.0/medium-simple.f =================================================================== --- branches/rel-2.3.0/medium-simple.f (revision 0) +++ branches/rel-2.3.0/medium-simple.f (revision 477) @@ -0,0 +1,818 @@ +C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +C++ Copyright (C) 2017 Korinna C. Zapp [Korinna.Zapp@cern.ch] ++ +C++ ++ +C++ This file is part of JEWEL 2.2.0 ++ +C++ ++ +C++ The JEWEL homepage is jewel.hepforge.org ++ +C++ ++ +C++ The medium model was partly implemented by Jochen Klein. ++ +C++ Raghav Kunnawalkam Elayavalli helped with the implementation ++ +C++ of the V+jet processes. ++ +C++ ++ +C++ Please follow the MCnet GUIDELINES and cite Eur.Phys.J. C74 ++ +C++ (2014) no.2, 2762 [arXiv:1311.0048] for the code and ++ +C++ JHEP 1303 (2013) 080 [arXiv:1212.1599] and ++ +C++ optionally EPJC 60 (2009) 617 [arXiv:0804.3568] for the ++ +C++ physics. The reference for V+jet processes is EPJC 76 (2016) ++ +C++ no.12 695 [arXiv:1608.03099] and for recoil effects it is ++ +C++ arXiv:1707.01539. +C++ ++ +C++ JEWEL relies heavily on PYTHIA 6 for the event generation. The ++ +C++ modified version of PYTHIA 6.4.25 that is distributed with ++ +C++ JEWEL is, however, not an official PYTHIA release and must not ++ +C++ be used for anything else. Please refer to results as ++ +C++ "JEWEL+PYTHIA". ++ +C++ ++ +C++ JEWEL also uses code provided by S. Zhang and J. M. Jing ++ +C++ (Computation of Special Functions, John Wiley & Sons, New York, ++ +C++ 1996 and http://jin.ece.illinois.edu) for computing the ++ +C++ exponential integral Ei(x). ++ +C++ ++ +C++ ++ +C++ JEWEL is free software; you can redistribute it and/or ++ +C++ modify it under the terms of the GNU General Public License ++ +C++ as published by the Free Software Foundation; either version 2 ++ +C++ of the License, or (at your option) any later version. ++ +C++ ++ +C++ JEWEL is distributed in the hope that it will be useful, ++ +C++ but WITHOUT ANY WARRANTY; without even the implied warranty of ++ +C++ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ++ +C++ GNU General Public License for more details. ++ +C++ ++ +C++ You should have received a copy of the GNU General Public ++ +C++ License along with this program; if not, write to the Free ++ +C++ Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, ++ +C++ MA 02110-1301 USA ++ +C++ ++ +C++ Linking JEWEL statically or dynamically with other modules is ++ +C++ making a combined work based on JEWEL. Thus, the terms and ++ +C++ conditions of the GNU General Public License cover the whole ++ +C++ combination. ++ +C++ ++ +C++ In addition, as a special exception, I give you permission to ++ +C++ combine JEWEL with the code for the computation of special ++ +C++ functions provided by S. Zhang and J. M. Jing. You may copy and ++ +C++ distribute such a system following the terms of the GNU GPL for ++ +C++ JEWEL and the licenses of the other code concerned, provided ++ +C++ that you include the source code of that other code when and as ++ +C++ the GNU GPL requires distribution of source code. ++ +C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + + SUBROUTINE MEDINIT(FILE,id,etam,mass) + IMPLICIT NONE +C--medium parameters + COMMON/MEDPARAM/CENTRMIN,CENTRMAX,BREAL,CENTR,RAU,NF + INTEGER NF + DOUBLE PRECISION CENTRMIN,CENTRMAX,BREAL,CENTR,RAU + COMMON/MEDPARAMINT/TAUI,TI,TC,D3,ZETA3,D, + &N0,SIGMANN,A,WOODSSAXON + DOUBLE PRECISION TAUI,TI,TC,ALPHA,BETA,GAMMA,D3,ZETA3,D,N0, + &SIGMANN + INTEGER A + LOGICAL WOODSSAXON +C--max rapidity + common/rapmax2/etamax2 + double precision etamax2 +C--longitudinal boost of momentum distribution + common/boostmed/boost + logical boost +C--factor to vary Debye mass + COMMON/MDFAC/MDFACTOR,MDSCALEFAC + DOUBLE PRECISION MDFACTOR,MDSCALEFAC +C--nuclear thickness function + COMMON /THICKFNC/ RMAX,TA(100,2) + DOUBLE PRECISION RMAX,TA +C--geometrical cross section + COMMON /CROSSSEC/ IMPMAX,CROSS(200,3) + DOUBLE PRECISION IMPMAX,CROSS +C--identifier of log file + common/logfile/logfid + integer logfid + + DATA RAU/10./ + DATA D3/0.9d0/ + DATA ZETA3/1.2d0/ +C--local variables + INTEGER I,LUN,POS,IOS,id,mass + double precision etam + CHARACTER*100 BUFFER,LABEL,tempbuf + CHARACTER*80 FILE + character firstchar + logical fileexist + + etamax2 = etam + logfid = id + + IOS=0 + LUN=77 + +C--default settings + TAUI=0.6d0 + TI=0.36d0 + TC=0.17d0 + WOODSSAXON=.TRUE. + CENTRMIN=0.d0 + CENTRMAX=10.d0 + NF=3 + A=mass + N0=0.17d0 + D=0.54d0 + SIGMANN=6.2 + MDFACTOR=0.45d0 + MDSCALEFAC=0.9d0 + boost = .true. + +C--read settings from file + write(logfid,*) + inquire(file=FILE,exist=fileexist) + if(fileexist)then + write(logfid,*)'Reading medium parameters from ',FILE + OPEN(unit=LUN,file=FILE,status='old',err=10) + do 20 i=1,1000 + READ(LUN, '(A)', iostat=ios) BUFFER + if (ios.ne.0) goto 30 + firstchar = buffer(1:1) + if (firstchar.eq.'#') goto 20 + POS=SCAN(BUFFER,' ') + LABEL=BUFFER(1:POS) + BUFFER=BUFFER(POS+1:) + IF (LABEL=="TAUI")THEN + READ(BUFFER,*,IOSTAT=IOS) TAUI + ELSE IF (LABEL=="TI") THEN + READ(BUFFER,*,IOSTAT=IOS) TI + ELSE IF (LABEL=="TC") THEN + READ(BUFFER,*,IOSTAT=IOS) TC + ELSE IF (LABEL=="WOODSSAXON") THEN + READ(BUFFER,*,IOSTAT=IOS) WOODSSAXON + ELSE IF (LABEL=="CENTRMIN") THEN + READ(BUFFER,*,IOSTAT=IOS) CENTRMIN + ELSE IF (LABEL=="CENTRMAX") THEN + READ(BUFFER,*,IOSTAT=IOS) CENTRMAX + ELSE IF (LABEL=="NF") THEN + READ(BUFFER,*,IOSTAT=IOS) NF + ELSE IF (LABEL=="N0") THEN + READ(BUFFER,*,IOSTAT=IOS) N0 + ELSE IF (LABEL=="D") THEN + READ(BUFFER,*,IOSTAT=IOS) D + ELSE IF (LABEL=="SIGMANN") THEN + READ(BUFFER,*,IOSTAT=IOS) SIGMANN + ELSE IF (LABEL=="MDFACTOR") THEN + READ(BUFFER,*,IOSTAT=IOS) MDFACTOR + ELSE IF (LABEL=="MDSCALEFAC") THEN + READ(BUFFER,*,IOSTAT=IOS) MDSCALEFAC + else + write(logfid,*)'unknown label ',label + endif + 20 continue + + 30 close(LUN,status='keep') + write(logfid,*)'...done' + goto 40 + + 10 write(logfid,*)'Could not open medium parameter file, '// + & 'will run with default settings.' + + else + write(logfid,*)'No medium parameter file found, '// + & 'will run with default settings.' + endif + + 40 write(logfid,*)'using parameters:' + write(logfid,*)'TAUI =',TAUI + write(logfid,*)'TI =',TI + write(logfid,*)'TC =',TC + write(logfid,*)'WOODSSAXON =',WOODSSAXON + write(logfid,*)'CENTRMIN =',CENTRMIN + write(logfid,*)'CENTRMAX =',CENTRMAX + write(logfid,*)'NF =',NF + write(logfid,*)'A =',A + write(logfid,*)'N0 =',N0 + write(logfid,*)'D =',D + write(logfid,*)'SIGMANN =',SIGMANN + write(logfid,*)'MDFACTOR =',MDFACTOR + write(logfid,*)'MDSCALEFAC =',MDSCALEFAC + write(logfid,*) + write(logfid,*) + write(logfid,*) + +C--calculate T_A(x,y) + CALL CALCTA +C--calculate geometrical cross section + CALL CALCXSECTION + + END + + + + SUBROUTINE MEDNEXTEVT + IMPLICIT NONE +C--medium parameters + COMMON/MEDPARAM/CENTRMIN,CENTRMAX,BREAL,CENTR,RAU,NF + INTEGER NF + DOUBLE PRECISION CENTRMIN,CENTRMAX,BREAL,CENTR,RAU + COMMON/MEDPARAMINT/TAUI,TI,TC,D3,ZETA3,D, + &N0,SIGMANN,A,WOODSSAXON + DOUBLE PRECISION TAUI,TI,TC,ALPHA,BETA,GAMMA,D3,ZETA3,D,N0, + &SIGMANN + INTEGER A + LOGICAL WOODSSAXON +C--geometrical cross section + COMMON /CROSSSEC/ IMPMAX,CROSS(200,3) + DOUBLE PRECISION IMPMAX,CROSS +C--local variables + integer i,j + DOUBLE PRECISION PYR,R,b1,b2,gettemp + +C--pick an impact parameter + r=(pyr(0)*(centrmax-centrmin)+centrmin)/100. + i=0 + do 130 j=1,200 + if ((r-cross(j,3)/cross(200,3)).ge.0.) then + i=i+1 + else + goto 132 + endif + 130 continue + 132 continue + b1 = (i-1)*0.1d0 + b2 = i*0.1d0 + breal = (b2*(cross(i,3)/cross(200,3)-r) + & +b1*(r-cross(i+1,3)/cross(200,3)))/ + & (cross(i,3)/cross(200,3)-cross(i+1,3)/cross(200,3)) + centr = r; + END + + double precision function getcentrality() + implicit none + COMMON/MEDPARAM/CENTRMIN,CENTRMAX,BREAL,CENTR,RAU,NF + INTEGER NF + DOUBLE PRECISION CENTRMIN,CENTRMAX,BREAL,CENTR,RAU + getcentrality=centr + end + + + + SUBROUTINE PICKVTX(X,Y) + IMPLICIT NONE + DOUBLE PRECISION X,Y +C--medium parameters + COMMON/MEDPARAM/CENTRMIN,CENTRMAX,BREAL,CENTR,RAU,NF + INTEGER NF + DOUBLE PRECISION CENTRMIN,CENTRMAX,BREAL,CENTR,RAU +C--local variables + DOUBLE PRECISION X1,X2,Y1,Y2,Z,XVAL,YVAL,ZVAL,NTHICK,PYR + + X1=BREAL/2.-RAU + X2=RAU-BREAL/2. + Y1=-SQRT(4*RAU**2-BREAL**2)/2. + Y2=SQRT(4*RAU**2-BREAL**2)/2. + 131 XVAL=PYR(0)*(X2-X1)+X1 + YVAL=PYR(0)*(Y2-Y1)+Y1 + IF((NTHICK(XVAL-BREAL/2.,YVAL).EQ.0.d0).OR. + & NTHICK(XVAL+BREAL/2.,YVAL).EQ.0.d0) GOTO 131 + ZVAL=PYR(0)*NTHICK(-BREAL/2.,0d0)*NTHICK(BREAL/2.,0d0) + Z=NTHICK(XVAL-BREAL/2.,YVAL)*NTHICK(XVAL+BREAL/2.,YVAL) + IF(ZVAL.GT.Z) GOTO 131 + X=XVAL + Y=YVAL + END + + SUBROUTINE SETB(BVAL) + IMPLICIT NONE +C--medium parameters + COMMON/MEDPARAM/CENTRMIN,CENTRMAX,BREAL,CENTR,RAU,NF + INTEGER NF + DOUBLE PRECISION CENTRMIN,CENTRMAX,BREAL,CENTR,RAU + DOUBLE PRECISION BVAL + BREAL=BVAL + END + + + + SUBROUTINE GETSCATTERER(X,Y,Z,T,TYPE,PX,PY,PZ,E,MS) + IMPLICIT NONE +C--medium parameters + COMMON/MEDPARAM/CENTRMIN,CENTRMAX,BREAL,CENTR,RAU,NF + INTEGER NF + DOUBLE PRECISION CENTRMIN,CENTRMAX,BREAL,CENTR,RAU +C--internal medium parameters + COMMON/MEDPARAMINT/TAUI,TI,TC,D3,ZETA3,D, + &N0,SIGMANN,A,WOODSSAXON + DOUBLE PRECISION TAUI,TI,TC,ALPHA,BETA,GAMMA,D3,ZETA3,D,N0, + &SIGMANN + INTEGER A + LOGICAL WOODSSAXON +C--longitudinal boost of momentum distribution + common/boostmed/boost + logical boost +C--function calls + DOUBLE PRECISION GETTEMP,GETMD,GETMOM,GETMS +C--identifier of log file + common/logfile/logfid + integer logfid +C--local variables + DOUBLE PRECISION X,Y,Z,T,MS,PX,PY,PZ,E,MD,TEMP + INTEGER TYPE + DOUBLE PRECISION R,PYR,pmax,wt,tau,theta,phi,pi,p,ys,pz2,e2 + DATA PI/3.141592653589793d0/ + + R=PYR(0) + IF(R.LT.(2.*12.*NF*D3/3.)/(2.*12.*NF*D3/3.+3.*16.*ZETA3/2.))THEN + TYPE=2 + ELSE + TYPE=21 + ENDIF + MS=GETMS(X,Y,Z,T) + MD=GETMD(X,Y,Z,T) + TEMP=GETTEMP(X,Y,Z,T) + tau=sqrt(t**2-z**2) + if (boost) then + ys = 0.5*log((t+z)/(t-z)) + else + ys = 0.d0 + endif + pmax = 10.*temp + + IF(TEMP.LT.1.D-2)THEN + write(logfid,*)'asking for a scattering centre without medium:' + write(logfid,*)'at (x,y,z,t)=',X,Y,Z,T + write(logfid,*)'making one up to continue but '// + & 'something is wrong!' + TYPE=21 + PX=0.d0 + PY=0.d0 + PZ=0.d0 + MS=GETMS(0.d0,0.d0,0.d0,0.d0) + MD=GETMD(0.d0,0.d0,0.d0,0.d0) + E=SQRT(PX**2+PY**2+PZ**2+MS**2) + RETURN + ENDIF + + 10 p = pyr(0)**0.3333333*pmax + E2 = sqrt(p**2+ms**2) + if (type.eq.2) then + wt = (exp(ms/temp)-1.)/(exp(E2/temp)-1.) + else + wt = (exp(ms/temp)+1.)/(exp(E2/temp)+1.) + endif + if (wt.gt.1.) write(logfid,*)'Error in getscatterer: weight = ',wt + if (wt.lt.0.) write(logfid,*)'Error in getscatterer: weight = ',wt + if (pyr(0).gt.wt) goto 10 + phi = pyr(0)*2.*pi + theta = -acos(2.*pyr(0)-1.)+pi + px = p*sin(theta)*cos(phi) + py = p*sin(theta)*sin(phi) + pz2 = p*cos(theta) + E = cosh(ys)*E2 + sinh(ys)*pz2 + pz = sinh(ys)*E2 + cosh(ys)*pz2 + END + + + SUBROUTINE AVSCATCEN(X,Y,Z,T,PX,PY,PZ,E,m) + IMPLICIT NONE +C--longitudinal boost of momentum distribution + common/boostmed/boost + logical boost +C--max rapidity + common/rapmax2/etamax2 + double precision etamax2 +C--local variables + double precision x,y,z,t,px,py,pz,e,getms,m,ys + if (boost) then + ys = 0.5*log((t+z)/(t-z)) + if ((z.eq.0.d0).and.(t.eq.0.d0)) ys =0.d0 + if (ys.gt.etamax2) ys=etamax2 + if (ys.lt.-etamax2) ys=-etamax2 + else + ys = 0.d0 + endif + m = getms(x,y,z,t) + e = m*cosh(ys) + px = 0.d0 + py = 0.d0 + pz = m*sinh(ys) + end + + + SUBROUTINE maxscatcen(PX,PY,PZ,E,m) + IMPLICIT NONE +C--longitudinal boost of momentum distribution + common/boostmed/boost + logical boost +C--max rapidity + common/rapmax2/etamax2 + double precision etamax2 +C--local variables + double precision px,py,pz,e,getmsmax,m,ys + if (boost) then + ys = etamax2 + else + ys = 0.d0 + endif + m = getmsmax() + e = m*cosh(ys) + px = 0.d0 + py = 0.d0 + pz = m*sinh(ys) + end + + + + DOUBLE PRECISION FUNCTION GETMD(X1,Y1,Z1,T1) + IMPLICIT NONE +C--factor to vary Debye mass + COMMON/MDFAC/MDFACTOR,MDSCALEFAC + DOUBLE PRECISION MDFACTOR,MDSCALEFAC + DOUBLE PRECISION X1,Y1,Z1,T1,GETTEMP + GETMD=MDSCALEFAC*3.*GETTEMP(X1,Y1,Z1,T1) + GETMD=MAX(GETMD,MDFACTOR) + END + + + + DOUBLE PRECISION FUNCTION GETMS(X2,Y2,Z2,T2) + IMPLICIT NONE + DOUBLE PRECISION X2,Y2,Z2,T2,GETMD + GETMS=GETMD(X2,Y2,Z2,T2)/SQRT(2.) + END + + + + DOUBLE PRECISION FUNCTION GETNEFF(X3,Y3,Z3,T3) + IMPLICIT NONE + COMMON/MEDPARAM/CENTRMIN,CENTRMAX,BREAL,CENTR,RAU,NF + INTEGER NF + DOUBLE PRECISION CENTRMIN,CENTRMAX,BREAL,CENTR,RAU + COMMON/MEDPARAMINT/TAUI,TI,TC,D3,ZETA3,D, + &N0,SIGMANN,A,WOODSSAXON + DOUBLE PRECISION TAUI,TI,TC,ALPHA,BETA,GAMMA,D3,ZETA3,D,N0, + &SIGMANN + INTEGER A + LOGICAL WOODSSAXON +C-- local variables + DOUBLE PRECISION X3,Y3,Z3,T3,PI,GETTEMP,tau,cosheta + DATA PI/3.141592653589793d0/ + tau = sqrt(t3**2-z3**2) + cosheta = t3/tau + GETNEFF=(2.*6.*NF*D3*2./3. + 16.*ZETA3*3./2.) + & *GETTEMP(X3,Y3,Z3,T3)**3/PI**2 + getneff = getneff/cosheta + END + + + + DOUBLE PRECISION FUNCTION GETTEMP(X4,Y4,Z4,T4) + IMPLICIT NONE +C--medium parameters + COMMON/MEDPARAM/CENTRMIN,CENTRMAX,BREAL,CENTR,RAU,NF + INTEGER NF + DOUBLE PRECISION CENTRMIN,CENTRMAX,BREAL,CENTR,RAU + COMMON/MEDPARAMINT/TAUI,TI,TC,D3,ZETA3,D, + &N0,SIGMANN,A,WOODSSAXON + DOUBLE PRECISION TAUI,TI,TC,ALPHA,BETA,GAMMA,D3,ZETA3,D,N0, + &SIGMANN + INTEGER A + LOGICAL WOODSSAXON +C--max rapidity + common/rapmax2/etamax2 + double precision etamax2 +C--local variables + DOUBLE PRECISION X4,Y4,Z4,T4,TAU,NPART,EPS0,EPSIN,TEMPIN,PI, + &NTHICK,ys + DATA PI/3.141592653589793d0/ + + GETTEMP=0.D0 + + IF(ABS(Z4).GT.T4)RETURN + + TAU=SQRT(T4**2-Z4**2) +C--check for overlap region + IF((NTHICK(X4-BREAL/2.,Y4).EQ.0.d0).OR. + &NTHICK(X4+BREAL/2.,Y4).EQ.0.d0) RETURN + + ys = 0.5*log((t4+z4)/(t4-z4)) + if (abs(ys).gt.etamax2) return +C--determine initial temperature at transverse position + IF(WOODSSAXON)THEN + EPS0=(16.*8.+7.*2.*6.*NF)*PI**2*TI**4/240. + EPSIN=EPS0*NPART(X4-BREAL/2.,Y4,X4+BREAL/2.,Y4) + & *PI*RAU**2/(2.*A) + TEMPIN=(EPSIN*240./(PI**2*(16.*8.+7.*2.*6.*NF)))**0.25 + ELSE + TEMPIN=TI + ENDIF +C--calculate temperature if before initial time + IF(TAU.LE.TAUI)THEN + GETTEMP=TEMPIN*TAU/TAUI + ELSE +C--evolve temperature + GETTEMP=TEMPIN*(TAUI/TAU)**0.3333 + ENDIF + IF(GETTEMP.LT.TC) GETTEMP=0.d0 + END + + + + DOUBLE PRECISION FUNCTION GETTEMPMAX() + IMPLICIT NONE +C--medium parameters + COMMON/MEDPARAM/CENTRMIN,CENTRMAX,BREAL,CENTR,RAU,NF + INTEGER NF + DOUBLE PRECISION CENTRMIN,CENTRMAX,BREAL,CENTR,RAU + COMMON/MEDPARAMINT/TAUI,TI,TC,D3,ZETA3,D, + &N0,SIGMANN,A,WOODSSAXON + DOUBLE PRECISION TAUI,TI,TC,ALPHA,BETA,GAMMA,D3,ZETA3,D,N0, + &SIGMANN + INTEGER A + LOGICAL WOODSSAXON +C--function call + DOUBLE PRECISION GETTEMP + GETTEMPMAX=GETTEMP(0.D0,0.D0,0.D0,TAUI) + END + + + + DOUBLE PRECISION FUNCTION GETMDMAX() + IMPLICIT NONE +C--factor to vary Debye mass + COMMON/MDFAC/MDFACTOR,MDSCALEFAC + DOUBLE PRECISION MDFACTOR,MDSCALEFAC + DOUBLE PRECISION GETTEMPMAX + GETMDMAX=MDSCALEFAC*3.*GETTEMPMAX() + GETMDMAX=MAX(GETMDMAX,MDFACTOR) + END + + + + DOUBLE PRECISION FUNCTION GETMDMIN() + IMPLICIT NONE +C--medium parameters + COMMON/MEDPARAM/CENTRMIN,CENTRMAX,BREAL,CENTR,RAU,NF + INTEGER NF + DOUBLE PRECISION CENTRMIN,CENTRMAX,BREAL,CENTR,RAU + COMMON/MEDPARAMINT/TAUI,TI,TC,D3,ZETA3,D, + &N0,SIGMANN,A,WOODSSAXON + DOUBLE PRECISION TAUI,TI,TC,ALPHA,BETA,GAMMA,D3,ZETA3,D,N0, + &SIGMANN + INTEGER A + LOGICAL WOODSSAXON +C--factor to vary Debye mass + COMMON/MDFAC/MDFACTOR,MDSCALEFAC + DOUBLE PRECISION MDFACTOR,MDSCALEFAC + DOUBLE PRECISION GETTEMPMAX + GETMDMIN=MDSCALEFAC*3.*TC + GETMDMIN=MAX(GETMDMIN,MDFACTOR) + END + + + + DOUBLE PRECISION FUNCTION GETMSMAX() + IMPLICIT NONE + DOUBLE PRECISION GETMDMAX,SQRT + GETMSMAX=GETMDMAX()/SQRT(2.D0) + END + + + + DOUBLE PRECISION FUNCTION GETNATMDMIN() + IMPLICIT NONE +C--medium parameters + COMMON/MEDPARAM/CENTRMIN,CENTRMAX,BREAL,CENTR,RAU,NF + INTEGER NF + DOUBLE PRECISION CENTRMIN,CENTRMAX,BREAL,CENTR,RAU + COMMON/MEDPARAMINT/TAUI,TI,TC,D3,ZETA3,D, + &N0,SIGMANN,A,WOODSSAXON + DOUBLE PRECISION TAUI,TI,TC,ALPHA,BETA,GAMMA,D3,ZETA3,D,N0, + &SIGMANN + INTEGER A + LOGICAL WOODSSAXON +C--max rapidity + common/rapmax2/etamax2 + double precision etamax2 +C--factor to vary Debye mass + COMMON/MDFAC/MDFACTOR,MDSCALEFAC + DOUBLE PRECISION MDFACTOR,MDSCALEFAC,PI + DATA PI/3.141592653589793d0/ +C--local variables + DOUBLE PRECISION T,GETMDMIN + T=GETMDMIN()/(MDSCALEFAC*3.) + GETNATMDMIN=(2.*6.*NF*D3*2./3. + 16.*ZETA3*3./2.) + & *T**3/PI**2 + END + + + + DOUBLE PRECISION FUNCTION GETLTIMEMAX() + IMPLICIT NONE +C--medium parameters + COMMON/MEDPARAM/CENTRMIN,CENTRMAX,BREAL,CENTR,RAU,NF + INTEGER NF + DOUBLE PRECISION CENTRMIN,CENTRMAX,BREAL,CENTR,RAU + COMMON/MEDPARAMINT/TAUI,TI,TC,D3,ZETA3,D, + &N0,SIGMANN,A,WOODSSAXON + DOUBLE PRECISION TAUI,TI,TC,ALPHA,BETA,GAMMA,D3,ZETA3,D,N0, + &SIGMANN + INTEGER A + LOGICAL WOODSSAXON +C--max rapidity + common/rapmax2/etamax2 + double precision etamax2 +C--function call + DOUBLE PRECISION GETTEMPMAX + GETLTIMEMAX=TAUI*(GETTEMPMAX()/TC)**3*cosh(etamax2) + END + + + + DOUBLE PRECISION FUNCTION GETNEFFMAX() + IMPLICIT NONE + COMMON/MEDPARAM/CENTRMIN,CENTRMAX,BREAL,CENTR,RAU,NF + INTEGER NF + DOUBLE PRECISION CENTRMIN,CENTRMAX,BREAL,CENTR,RAU + COMMON/MEDPARAMINT/TAUI,TI,TC,D3,ZETA3,D, + &N0,SIGMANN,A,WOODSSAXON + DOUBLE PRECISION TAUI,TI,TC,ALPHA,BETA,GAMMA,D3,ZETA3,D,N0, + &SIGMANN + INTEGER A + LOGICAL WOODSSAXON +C--max rapidity + common/rapmax2/etamax2 + double precision etamax2 +C-- local variables + DOUBLE PRECISION PI,GETTEMPMAX + DATA PI/3.141592653589793d0/ + GETNEFFMAX=(2.*6.*NF*D3*2./3. + 16.*ZETA3*3./2.) + & *GETTEMPMAX()**3/PI**2 + END + + + + DOUBLE PRECISION FUNCTION NPART(XX1,YY1,XX2,YY2) + IMPLICIT NONE + COMMON/MEDPARAMINT/TAUI,TI,TC,D3,ZETA3,D, + &N0,SIGMANN,A,WOODSSAXON + DOUBLE PRECISION TAUI,TI,TC,ALPHA,BETA,GAMMA,D3,ZETA3,D,N0, + &SIGMANN + INTEGER A + LOGICAL WOODSSAXON +C--local variables + DOUBLE PRECISION XX1,YY1,XX2,YY2,NTHICK + + NPART = NTHICK(XX1,YY1)*(1.-EXP(-SIGMANN*NTHICK(XX2,YY2))) + + & NTHICK(XX2,YY2)*(1.-EXP(-SIGMANN*NTHICK(XX1,YY1))) + END + + + + DOUBLE PRECISION FUNCTION NTHICK(X1,Y1) + IMPLICIT NONE +C--medium parameters + COMMON/MEDPARAM/CENTRMIN,CENTRMAX,BREAL,CENTR,RAU,NF + INTEGER NF + DOUBLE PRECISION CENTRMIN,CENTRMAX,BREAL,CENTR,RAU + COMMON/MEDPARAMINT/TAUI,TI,TC,D3,ZETA3,D, + &N0,SIGMANN,A,WOODSSAXON + DOUBLE PRECISION TAUI,TI,TC,ALPHA,BETA,GAMMA,D3,ZETA3,D,N0, + &SIGMANN + INTEGER A + LOGICAL WOODSSAXON +C--identifier of log file + common/logfile/logfid + integer logfid +C--nuclear thickness function + COMMON /THICKFNC/ RMAX,TA(100,2) + DOUBLE PRECISION RMAX,TA + INTEGER LINE,LMIN,LMAX,I + DOUBLE PRECISION X1,Y1,XA(4),YA(4),Y,DY,R,C,B,DELTA + + R=SQRT(X1**2+Y1**2) + IF(R.GT.TA(100,1))THEN + NTHICK=0. + ELSE + LINE=INT(R*99.d0/TA(100,1)+1) + LMIN=MAX(LINE,1) + LMIN=MIN(LMIN,99) + IF((R.LT.TA(LMIN,1)).OR.(R.GT.TA(LMIN+1,1))) + & write(logfid,*)LINE,LMIN,R,TA(LMIN,1),TA(LMIN+1,1) + XA(1)=TA(LMIN,1) + XA(2)=TA(LMIN+1,1) + YA(1)=TA(LMIN,2) + YA(2)=TA(LMIN+1,2) + C=(YA(2)-YA(1))/(XA(2)-XA(1)) + B=YA(1)-C*XA(1) + NTHICK=C*R+B + ENDIF + END + + + + SUBROUTINE CALCTA() + IMPLICIT NONE +C--medium parameters + COMMON/MEDPARAM/CENTRMIN,CENTRMAX,BREAL,CENTR,RAU,NF + INTEGER NF + DOUBLE PRECISION CENTRMIN,CENTRMAX,BREAL,CENTR,RAU + COMMON/MEDPARAMINT/TAUI,TI,TC,D3,ZETA3,D, + &N0,SIGMANN,A,WOODSSAXON + DOUBLE PRECISION TAUI,TI,TC,ALPHA,BETA,GAMMA,D3,ZETA3,D,N0, + &SIGMANN + INTEGER A + LOGICAL WOODSSAXON +C-- nuclear thickness function + COMMON /THICKFNC/ RMAX,TA(100,2) + DOUBLE PRECISION RMAX,TA +C--variables for integration + COMMON/INTEG/B,R + DOUBLE PRECISION B,R +C--local variables + INTEGER NSTEPS,I + DOUBLE PRECISION EPS,HFIRST,Y + + NSTEPS=100 + EPS=1.E-4 + HFIRST=0.1D0 + + R=1.12*A**(0.33333)-0.86*A**(-0.33333) + RMAX=2.*R + + DO 10 I=1,NSTEPS +C--set transverse position + B=(I-1)*2.D0*R/NSTEPS + Y=0.D0 +C--integrate along longitudinal line + CALL ODEINT(Y,-2*R,2*R,EPS,HFIRST,0.d0,101) + TA(I,1)=B + TA(I,2)=Y + 10 CONTINUE + END + + + + SUBROUTINE CALCXSECTION() + IMPLICIT NONE +C--medium parameters + COMMON/MEDPARAM/CENTRMIN,CENTRMAX,BREAL,CENTR,RAU,NF + INTEGER NF + DOUBLE PRECISION CENTRMIN,CENTRMAX,BREAL,CENTR,RAU + COMMON/MEDPARAMINT/TAUI,TI,TC,D3,ZETA3,D, + &N0,SIGMANN,A,WOODSSAXON + DOUBLE PRECISION TAUI,TI,TC,ALPHA,BETA,GAMMA,D3,ZETA3,D,N0, + &SIGMANN + INTEGER A + LOGICAL WOODSSAXON +C-- geometrical cross section + COMMON /CROSSSEC/ IMPMAX,CROSS(200,3) + DOUBLE PRECISION IMPMAX,CROSS +C--local variables + INTEGER IX,IY,IB + DOUBLE PRECISION B,P,PROD,X,Y,NTHICK,NPART,pprev + + pprev=0. + DO 30 IB=1,200 + B=0.1d0*IB + PROD=1.d0 + DO 10 IX=1,100 + DO 20 IY=1,100 + X=-20.d0+IX*0.4d0 + Y=-20.d0+IY*0.4d0 + PROD=PROD* + &EXP(-NTHICK(X+B/2.D0,Y)*SIGMANN)**(0.16d0*NTHICK(X-B/2.D0,Y)) + 20 CONTINUE + 10 CONTINUE + P=(1.D0-PROD)*8.8D0/14.D0*B + CROSS(IB,1)=B + CROSS(IB,2)=P + if (ib.eq.1) then + cross(ib,3)=0. + else + cross(ib,3)=cross(ib-1,3)+(p+pprev)/2.*0.1 + endif + pprev=p + 30 CONTINUE + IMPMAX=19.95 + END + + + + DOUBLE PRECISION FUNCTION MEDDERIV(XVAL,W) + IMPLICIT NONE + DOUBLE PRECISION XVAL + INTEGER W +C--medium parameters + COMMON/MEDPARAMINT/TAUI,TI,TC,D3,ZETA3,D, + &N0,SIGMANN,A,WOODSSAXON + DOUBLE PRECISION TAUI,TI,TC,ALPHA,BETA,GAMMA,D3,ZETA3,D,N0, + &SIGMANN + INTEGER A + LOGICAL WOODSSAXON +C--variables for integration + COMMON/INTEG/B,R + DOUBLE PRECISION B,R + + IF (W.EQ.1) THEN +C--XVAL corresponds to z-coordinate + MEDDERIV=N0/(1+EXP((SQRT(B**2+XVAL**2)-R)/D)) + ELSE + MEDDERIV=0.D0 + ENDIF + END Index: branches/rel-2.3.0/medium-vac.f =================================================================== --- branches/rel-2.3.0/medium-vac.f (revision 0) +++ branches/rel-2.3.0/medium-vac.f (revision 477) @@ -0,0 +1,214 @@ +C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +C++ Copyright (C) 2017 Korinna C. Zapp [Korinna.Zapp@cern.ch] ++ +C++ ++ +C++ This file is part of JEWEL 2.2.0 ++ +C++ ++ +C++ The JEWEL homepage is jewel.hepforge.org ++ +C++ ++ +C++ The medium model was partly implemented by Jochen Klein. ++ +C++ Raghav Kunnawalkam Elayavalli helped with the implementation ++ +C++ of the V+jet processes. ++ +C++ ++ +C++ Please follow the MCnet GUIDELINES and cite Eur.Phys.J. C74 ++ +C++ (2014) no.2, 2762 [arXiv:1311.0048] for the code and ++ +C++ JHEP 1303 (2013) 080 [arXiv:1212.1599] and ++ +C++ optionally EPJC 60 (2009) 617 [arXiv:0804.3568] for the ++ +C++ physics. The reference for V+jet processes is EPJC 76 (2016) ++ +C++ no.12 695 [arXiv:1608.03099] and for recoil effects it is ++ +C++ arXiv:1707.01539. +C++ ++ +C++ JEWEL relies heavily on PYTHIA 6 for the event generation. The ++ +C++ modified version of PYTHIA 6.4.25 that is distributed with ++ +C++ JEWEL is, however, not an official PYTHIA release and must not ++ +C++ be used for anything else. Please refer to results as ++ +C++ "JEWEL+PYTHIA". ++ +C++ ++ +C++ JEWEL also uses code provided by S. Zhang and J. M. Jing ++ +C++ (Computation of Special Functions, John Wiley & Sons, New York, ++ +C++ 1996 and http://jin.ece.illinois.edu) for computing the ++ +C++ exponential integral Ei(x). ++ +C++ ++ +C++ ++ +C++ JEWEL is free software; you can redistribute it and/or ++ +C++ modify it under the terms of the GNU General Public License ++ +C++ as published by the Free Software Foundation; either version 2 ++ +C++ of the License, or (at your option) any later version. ++ +C++ ++ +C++ JEWEL is distributed in the hope that it will be useful, ++ +C++ but WITHOUT ANY WARRANTY; without even the implied warranty of ++ +C++ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ++ +C++ GNU General Public License for more details. ++ +C++ ++ +C++ You should have received a copy of the GNU General Public ++ +C++ License along with this program; if not, write to the Free ++ +C++ Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, ++ +C++ MA 02110-1301 USA ++ +C++ ++ +C++ Linking JEWEL statically or dynamically with other modules is ++ +C++ making a combined work based on JEWEL. Thus, the terms and ++ +C++ conditions of the GNU General Public License cover the whole ++ +C++ combination. ++ +C++ ++ +C++ In addition, as a special exception, I give you permission to ++ +C++ combine JEWEL with the code for the computation of special ++ +C++ functions provided by S. Zhang and J. M. Jing. You may copy and ++ +C++ distribute such a system following the terms of the GNU GPL for ++ +C++ JEWEL and the licenses of the other code concerned, provided ++ +C++ that you include the source code of that other code when and as ++ +C++ the GNU GPL requires distribution of source code. ++ +C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + + SUBROUTINE MEDINIT + IMPLICIT NONE + COMMON/MEDPARAM/BMIN,BMAX,CENTRMIN,CENTRMAX,BREAL,RAU + DOUBLE PRECISION BMIN,BMAX,CENTRMIN,CENTRMAX,BREAL,RAU + COMMON/MEDIUM/MEDIUM + LOGICAL MEDIUM + DATA MEDIUM/.FALSE./ + RAU=5.d0 + END + + + + SUBROUTINE MEDNEXTEVT + IMPLICIT NONE + END + + + + double precision function getcentrality() + implicit none + getcentrality=-1.d0 + end + + + + SUBROUTINE PICKVTX(X,Y) + IMPLICIT NONE + DOUBLE PRECISION X,Y + X=0.d0 + Y=0.d0 + END + + + + SUBROUTINE SETB(BVAL) + IMPLICIT NONE + DOUBLE PRECISION BVAL + END + + + + SUBROUTINE GETSCATTERER(X,Y,Z,T,TYPE,PX,PY,PZ,E,MS,MD,TEMP) + IMPLICIT NONE + DOUBLE PRECISION X,Y,Z,T,MS,PX,PY,PZ,E,MD,TEMP + INTEGER TYPE + WRITE(*,*)'GETSCATTERER called although in vacuum' + END + + + + SUBROUTINE AVSCATCEN(X,Y,Z,T,PX,PY,PZ,E,MS) + IMPLICIT NONE + DOUBLE PRECISION X,Y,Z,T,MS,PX,PY,PZ,E + WRITE(*,*)'AVSCATCEN called although in vacuum' + END + + + + SUBROUTINE MAXSCATCEN(PX,PY,PZ,E,MS) + IMPLICIT NONE + DOUBLE PRECISION MS,PX,PY,PZ,E + ms=0.5d0 + e=0.5d0 + px=0.d0 + py=0.d0 + pz=0.d0 + END + + + + DOUBLE PRECISION FUNCTION GETNEFF(X,Y,Z,T) + IMPLICIT NONE + DOUBLE PRECISION X,Y,Z,T + GETNEFF=0.d0 + END + + + + DOUBLE PRECISION FUNCTION GETTEMP(X,Y,Z,T) + IMPLICIT NONE + DOUBLE PRECISION X,Y,Z,T + GETTEMP=0.d0 + END + + + + DOUBLE PRECISION FUNCTION GETTEMPMAX() + IMPLICIT NONE + GETTEMPMAX=0.d0 + END + + + + DOUBLE PRECISION FUNCTION GETMDMAX() + IMPLICIT NONE + GETMDMAX=0.d0 + END + + + + DOUBLE PRECISION FUNCTION GETMDMIN() + IMPLICIT NONE + GETMDMIN=0.d0 + END + + + + DOUBLE PRECISION FUNCTION GETMSMAX() + IMPLICIT NONE + GETMSMAX=0.d0 + END + + + + DOUBLE PRECISION FUNCTION GETNEFFMAX() + IMPLICIT NONE + GETNEFFMAX=0.d0 + END + + + + DOUBLE PRECISION FUNCTION GETNATMDMIN() + IMPLICIT NONE + GETNATMDMIN=0.d0 + END + + + + DOUBLE PRECISION FUNCTION GETLTIMEMAX() + IMPLICIT NONE + GETLTIMEMAX=0. + END + + + + DOUBLE PRECISION FUNCTION GETMD(X,Y,Z,T) + IMPLICIT NONE + DOUBLE PRECISION X,Y,Z,T,GETTEMP + GETMD=0.D0 + END + + + + DOUBLE PRECISION FUNCTION GETMS(X,Y,Z,T) + IMPLICIT NONE + DOUBLE PRECISION X,Y,Z,T,GETMD + GETMS=0.D0 + END + + + + DOUBLE PRECISION FUNCTION MEDDERIV(XVAL,W) + MEDDERIV=0.D0 + END Index: branches/rel-2.3.0/Makefile =================================================================== --- branches/rel-2.3.0/Makefile (revision 0) +++ branches/rel-2.3.0/Makefile (revision 477) @@ -0,0 +1,21 @@ +all: jewel-2.2.0-vac jewel-2.2.0-simple + +# path to LHAPDF library +LHAPDF_PATH := /home/lhapdf/install/lib/ + +FC := gfortran +FFLAGS := -g -static + +jewel-2.2.0-vac: jewel-2.2.0.o medium-vac.o pythia6425mod.o meix.o + $(FC) -o $@ -L$(LHAPDF_PATH) $^ -lLHAPDF + +jewel-2.2.0-simple: jewel-2.2.0.o medium-simple.o pythia6425mod.o meix.o + $(FC) -o $@ -L$(LHAPDF_PATH) $^ -lLHAPDF + +clean: + rm -f medium-*.o + rm -f jewel*.o + rm -f pythia6425mod.o meix.o + rm -f *~ + +.PHONY: all Index: branches/rel-2.3.0/README =================================================================== --- branches/rel-2.3.0/README (revision 0) +++ branches/rel-2.3.0/README (revision 477) @@ -0,0 +1,95 @@ +-------- JEWEL -------- + +homepage: jewel.hepforge.org +contact : jewel@projects.hepforge.org + +----------------------- + +CONTENTS: + +1. REFERENCES + +2. GETTING STARTED + +3. ACKNOWLEDGEMENTS + +4. DISCLAIMER + +------------------------ + +1. REFERENCES +------------- + +The manual with information on how to run JEWEL is distributed with the JEWEL +release and can be obtained from +.................. + +If you use this code for scientific work please cite the manual for the code and +JHEP 1303 (2013) 080 [arXiv:1212.1599] and optionally EPJC C60 (2009) 617 +[arXiv:0804.3568] for the physics. + + +2. GETTING STARTED +------------------ + +JEWEL needs LHAPDF to provide the PDF's. Install LHAPDF following the instructions +on the LHAPDF web page (lhapdf.hepforge.org) and download the PDF sets you want to +use. In its default setup JEWEL needs the CTEPQ6LL (number 10042) and EPS09LOR_208 +sets. The latter can be downloaded from the EPS09 web page (www.jyu.fi/fysiikka/en/ +research/highenergy/urhic/eps09). + +The provided Makefile assumes that JEWEL will be compiled with gfortran. People who +wish to use a different compiler have to modify the Makefile accordingly. + +Download and unpack the tarball. +$ tar xvzf jewel-2.0.0.tar.gz +Edit the line +LHAPDF_PATH := /path/to/lhapdf +in the Makefile to point to your LHAPDF installation. +Compile the code by typing 'make'. The result of this are two executables: +jewel-2.0.0-vac and jewel-2.0.0-simple. The former simulates jet evolution in vacuum +(i.e. in e-e+ or pp collisions) while the latter simulates jet evolution in the +presence of a medium. In this case the medium is modelled by an ideal gas of quarks and +gluons undergoing boost-invariant longitudinal expansion with a transverse profile derived +from a Glauber model. + +The following paths need to be set for JEWEL to run: +$ export LD_LIBRARY_PATH=/path/to/lhapdf/:$LD_LIBRARY_PATH +$ export LHAPATH=/path/to/lhapdf/share/lhapdf/PDFsets +To run JEWEL with the default setting no parameter file is needed: +$./jewel-2.0.0-simple +or +$./jewel-2.0.0-vac +Note, however, that also in the latter case nuclear PDF's will be used. + +A parameter file can to be passed to change the setting: +$./jewel-2.0.0-simple params.example.dat +The file params.example.dat is included in the tarball as an example for a parameter file. The +file can contain one parameter per line, the format is ␣. Lines starting with a hash +are comment lines. For a list of parameters and their dafault values please refer to the manual. + + +3. ACKNOWLEDGEMENTS +------------------- + +JEWEL relies heavily on PYTHIA 6 (pythia6.hepforge.org) for the event generation. The modified +version of PYTHIA 6.4.25 that is distributed with JEWEL is, however, not an official PYTHIA +release and must not be used for anything else. Please refer to results as "JEWEL+PYTHIA". + +JEWEL contains code provided by S. Zhang and J. M. Jing (Computation of Special Functions, +John Wiley & Sons, New York, 1996 and http://jin.ece.illinois.edu) for computing the exponential +integral Ei(x). + +The medium model was partly implemented by Jochen Klein [Jochen.Klein@cern.ch]. + + +4. DISCLAIMER +------------- + +The JEWEL code is provided without any warranty, users should be wary and use common +sense when judging and interpreting their results. It is copyrighted but may be used for +scientific work provided proper reference is given. + + + +Copyright Korinna C. Zapp (2013) [Korinna.Zapp@cern.ch] Index: branches/rel-2.3.0/gpl-2.0.txt =================================================================== Binary files branches/rel-2.3.0/gpl-2.0.txt (revision 0) and branches/rel-2.3.0/gpl-2.0.txt (revision 477) differ Index: branches/rel-2.3.0/readme-meix.for =================================================================== --- branches/rel-2.3.0/readme-meix.for (revision 0) +++ branches/rel-2.3.0/readme-meix.for (revision 477) @@ -0,0 +1,516 @@ + **************************************** + * DISK TO ACCOMPANY * + * COMPUTATION OF SPECIAL FUNCTIONS * + * * + * Shanjie Zhang and Jianming Jin * + * * + * Copyright 1996 by John Wiley & * + * Sons, Inc. * + * * + **************************************** + +I. INTRODUCTION + + As stated in the preface of our book "Computation of Special +Functions," the purpose of this book is to share with the reader +a set of computer programs (130 in total) which we have developed +during the past several years for computing a variety of special +mathematical functions. For your convenience, we attach to the +book this diskette that contains all the computer programs +listed or mentioned in the book. + + In this diskette, we place all the programs under directory +SMF\PROGRAMS. In order to illustrate the use of these programs +and facilitate your testing of the programs, we wrote a short +simple main program for each program so that you can readily test +them. + + All the programs are written in FORTRAN-77 and tested on PCs +and workstations. Therefore, they should run on any computer with +implementation of the FORTRAN-77 standard. + + Although we have made a great effort to test these programs, +we would not be surprised to find some errors in them. We would +appreciate it if you can bring to our attention any errors you find. +You can do this by either writing us directly at the location +(e-mail: j-jin1@uiuc.edu) or writing to the publisher, whose address +appears on the back cover of the book. However, we must note that +all these programs are sold "as is," and we cannot guarantee to +correct the errors reported by readers on any fixed schedule. + + All the programs and subroutines contained in this diskette +are copyrighted. However, we give permission to the reader who +purchases this book to incorporate any of these programs into his +or her programs provided that the copyright is acknowledged. + + Regarding the specifics of the programs, we want to make the +following two points. + + 1) All the programs are written in double precision. Although + the use of double precision is necessary for some programs, + especially for those based on series expansions, it is not + necessary for all programs. For example, the computation of + of special functions based on polynomial approximations does + not have to use double precision. We chose to write all the + programs using double precision in order to avoid possible + confusion which may occur in using these programs. If + necessary, you can convert the programs into the single + precision format easily. However, doing so for some + programs may lead to a lower accuracy. + + 2) In the main programs that calculate a sequence of special + functions, we usually set the maximum order or degree to 100 + or 250. However, this is not a limit. To compute functions + with a higher order or degree, all you need to do is simply + set the dimension of proper arrays higher. + + +II. DISCLAIMER OF WARRANTY + + Although we have made a great effort to test and validate the +computer programs, we make no warranties, express or implied, that +these programs are free of error, or are consistent with any +particular standard of merchantability, or that they will meet +your requirements for any particular application. They should not +be relied on for solving problems whose incorrect solution could +result in injury to a person or loss of property. If you do use +the programs in such a manner, it is at your own risk. The authors +and publisher disclaim all liability for direct or consequential +damages resulting from your use of the programs. + + +III. LIST OF PROGRAMS + +(Please note that all file names of programs installed from the disk +begin with an M, for example, MBERNOA.FOR) + +BERNOA Evaluate a sequence of Bernoulli numbers (method 1). + +BERNOB Evaluate a sequence of Bernoulli numbers (method 2). + +EULERA Evaluate a sequence of Euler numbers (method 1). + +EULERB Evaluate a sequence of Euler numbers (method 2). + +***** + +OTHPL Evaluate a sequence of orthogonal polynomials and their +derivatives, including Chebyshev, Laguerre, and Hermite +polynomials. + +LEGZO Evaluate the nodes and weights for Gauss-Legendre quadrature. + +LAGZO Evaluate the nodes and weights for Gauss-Laguerre quadrature. + +HERZO Evaluate the nodes and weights for Gauss-Hermite quadrature. + +***** + +GAMMA Evaluate the gamma function. + +LGAMA Evaluate the gamma function or the logarithm of the gamma +function. + +CGAMA Evaluate the gamma function with a complex argument. + +BETA Evaluate the beta function. + +PSI Evaluate the psi function. + +CPSI Evaluate the psi function with a complex argument. + +INCOG Evaluate the incomplete gamma function. + +INCOB Evaluate the incomplete beta function. + +***** + +LPN Evaluate a sequence of Legendre polynomials and their +derivatives with real arguments. + +CLPN Evaluate a sequence of Legendre polynomials and their +derivatives with complex arguments. + +LPNI Evaluate a sequence of Legendre polynomials, their +derivatives, and their integrals. + +LQNA Evaluate a sequence of Legendre functions of the second +kind and their derivatives with restricted real arguments. + +LQNB Evaluate a sequence of Legendre functions of the second +kind and their derivatives with nonrestricted real arguments. + +CLQN Evaluate a sequence of Legendre functions of the second +kind and their derivatives with complex arguments. + +LPMN Evaluate a sequence of associated Legendre polynomials and +their derivatives with real arguments. + +CLPMN Evaluate a sequence of associated Legendre polynomials and +their derivatives with complex arguments. + +LQMN Evaluate a sequence of associated Legendre functions of the +second kind and their derivatives with real arguments. + +CLQMN Evaluate a sequence of associated Legendre functions of the +second kind and their derivatives with complex arguments. + +LPMV Evaluate associated Legendre functions of the first kind +with an integer order and arbitrary non-negative degree. + +***** + +JY01A Evaluate the zeroth- and first-order Bessel functions of the +first and second kinds with real arguments using series and +asymptotic expansions. + +JY01B Evaluate the zeroth- and first-order Bessel functions of the +first and second kinds with real arguments using polynomial +approximations. + +JYNA Evaluate a sequence of Bessel functions of the first and +second kinds and their derivatives with integer orders and +real arguments (method 1). + +JYNB Evaluate a sequence of Bessel functions of the first and +second kinds and their derivatives with integer orders and +real arguments (method 2). + +CJY01 Evaluate the zeroth- and first-order Bessel functions of the +first and second kinds and their derivatives with complex +arguments. + +CJYNA Evaluate a sequence of Bessel functions of the first and +second kinds and their derivatives with integer orders and +complex arguments (method 1). + +CJYNB Evaluate a sequence of Bessel functions of the first and +second kinds and their derivatives with integer orders and +complex arguments (method 2). + +JYV Evaluate a sequence of Bessel functions of the first and +second kinds and their derivatives with arbitrary real orders +and real arguments. + +CJYVA Evaluate a sequence of Bessel functions of the first and +second kinds and their derivatives with arbitrary real orders +and complex arguments (method 1). + +CJYVB Evaluate a sequence of Bessel functions of the first and +second kinds and their derivatives with arbitrary real orders +and complex arguments (method 2). + +CJK Evaluate the coefficients for the asymptotic expansion of +Bessel functions for large orders. + +CJYLV Evaluate Bessel functions of the first and second kinds and +their derivatives with a large arbitrary real order and complex +arguments. + +JYZO Evaluate the zeros of the Bessel functions of the first and +second kinds and their derivatives. + +JDZO Evaluate the zeros of the Bessel functions of the first kind +and their derivatives. + +CYZO Evaluate the complex zeros of the Bessel functions of the +second kind of order zero and one. + +LAMN Evaluate a sequence of lambda functions with integer orders +and their derivatives. + +LAMV Evaluate a sequence of lambda functions with arbitrary orders +and their derivatives. + +***** + +IK01A Evaluate the zeroth- and first-order modified Bessel +functions of the first and second kinds with real arguments. + +IK01B Evaluate the zeroth- and first-order modified Bessel +functions of the first and second kinds with real arguments. + +IKNA Evaluate a sequence of modified Bessel functions of the +first and second kinds and their derivatives with integer +orders and real arguments (method 1). + +IKNB Evaluate a sequence of modified Bessel functions of the +first and second kinds and their derivatives with integer +orders and real arguments (method 2). + +CIK01 Evaluate the zeroth- and first-order modified Bessel +functions of the first and second kinds and their derivatives +with complex arguments. + +CIKNA Evaluate a sequence of modified Bessel functions of the +first and second kinds and their derivatives with integer +orders and complex arguments (method 1). + +CIKNB Evaluate a sequence of modified Bessel functions of the +first and second kinds and their derivatives with integer +orders and complex arguments (method 2). + +IKV Evaluate a sequence of modified Bessel functions of the +first and second kinds and their derivatives with arbitrary +real orders and real arguments. + +CIKVA Evaluate a sequence of modified Bessel functions of the +first and second kinds and their derivatives with arbitrary +real orders and complex arguments. + +CIKVB Evaluate a sequence of modified Bessel functions of the +first and second kinds and their derivatives with arbitrary +real orders and complex arguments. + +CIKLV Evaluate modified Bessel functions of the first and second +kinds and their derivatives with a large arbitrary real order +and complex arguments. + +CH12N Evaluate a sequence of Hankel functions of the first and +second kinds and their derivatives with integer orders and +complex arguments. + +***** + +ITJYA Evaluate the integral of Bessel functions J0(t) and Y0(t) +from 0 to x using series and asymptotic expansions. + +ITJYB Evaluate the integral of Bessel functions J0(t) and Y0(t) +from 0 to x using polynomial approximations. + +ITTJYA Evaluate the integral of [1-J0(t)]/t from 0 to x and Y0(t)/t +from x to infinity using series and asymptotic expansions. + +ITTJYB Evaluate the integral of [1-J0(t)]/t from 0 to x and Y0(t)/t +from x to infinity using polynomial approximations. + +ITIKA Evaluate the integral of modified Bessel functions I0(t) and +K0(t) from 0 to x using series and asymptotic expansions. + +ITIKB Evaluate the integral of modified Bessel functions I0(t) and +K0(t) from 0 to x using polynomial approximations. + +ITTIKA Evaluate the integral of [1-I0(t)]/t from 0 to x and K0(t) +from x to infinity using series and asymptotic expansions. + +ITTIKB Evaluate the integral of [1-I0(t)]/t from 0 to x and K0(t) +from x to infinity using polynomial approximations. + +**** + +SPHJ Evaluate a sequence of spherical Bessel functions of the +first kind and their derivatives with integer orders and +real arguments. + +SPHY Evaluate a sequence of spherical Bessel functions of the +second kind and their derivatives with integer orders and +real arguments. + +CSPHJY Evaluate a sequence of spherical Bessel functions of the +first and second kinds and their derivatives with integer +orders and complex arguments. + +RCTJ Evaluate a sequence of Riccati-Bessel functions and their +derivatives of the first kind. + +RCTY Evaluate a sequence of Riccati-Bessel functions and their +derivatives of the second kind. + +SPHI Evaluate a sequence of modified spherical Bessel functions +of the first kind and their derivatives with integer orders +and real arguments. + +SPHK Evaluate a sequence of modified spherical Bessel functions +of the second kind and their derivatives with integer orders +and real arguments. + +CSPHIK Evaluate a sequence of modified spherical Bessel functions +of the first and second kinds and their derivatives with +integer orders and complex arguments. + +***** + + +KLVNA Evaluate the Kelvin functions and their derivatives using +series and asymptotic expansions. + +KLVNB Evaluate the Kelvin functions and their derivatives using +polynomial approximations. + +KLVNZO Evaluate the zeros of the Kelvin functions and their +derivatives. + +***** + +AIRYA Evaluate the Airy functions and their derivatives by means +of Bessel functions. + +AIRYB Evaluate the Airy functions and their derivatives using the +series and asymptotic expansions. + +ITAIRY Evaluate the integral of the Airy functions. + +AIRYZO Evaluate the zeros of Airy functions and their derivatives. + +***** + +STVH0 Evaluate the zeroth-order Struve function. + +STVH1 Evaluate the first-order Struve function. + +STVHV Evaluate the Struve functions with an arbitrary order. + +ITSH0 Evaluate the integral of Struve function H0(t) from 0 to x. + +ITTH0 Evaluate the integral of H0(t)/t from x to infinity. + +STVL0 Evaluate the zeroth-order modified Struve function. + +STVL1 Evaluate the first-order modified Struve function. + +STVLV Evaluate the modified Struve function with an arbitrary +order. + +ITSL0 Evaluate the integral of modified Struve function L0(t) +from 0 to x. + +***** + +HYGFX Evaluate the hypergeometric function with real arguments. + +HYGFZ Evaluate the hypergeometric function with complex arguments. + +***** + +CHGM Evaluate the confluent hypergeometric function M(a,b,x) with +real arguments. + +CCHG Evaluate the confluent hypergeometric function M(a,b,z) with +complex arguments. + +CHGU Evaluate the confluent hypergeometric function U(a,b,x) with +real arguments. + +***** + +PBDV Evaluate a sequence of parabolic cylinder functions Dv(x) and +their derivatives. + +PBVV Evaluate a sequence of parabolic cylinder functions Vv(x) and +their derivatives. + +PBWA Evaluate parabolic cylinder functions W(a,+/-x) and their +derivatives. + +CPBDN Evaluate a sequence of parabolic cylinder functions Dn(z) and +their derivatives for complex arguments. + +***** + +CVA1 Evaluate a sequence of characteristic values for the Mathieu +and modified Mathieu functions. + +CVA2 Evaluate a specific characteristic value for the Mathieu +and modified Mathieu functions. + +FCOEF Evaluate the expansion coefficients for the Mathieu and +modified Mathieu functions. + +MTU0 Evaluate the Mathieu functions and their derivatives. + +MTU12 Evaluate the modified Mathieu functions of the first and +second kinds and their derivatives. + +***** + +SEGV Evaluate a sequence of characteristic values for spheroidal +wave functions. + +SDMN Evaluate the expansion coefficients d_k^mn for spheroidal +wave functions. + +SCKA Evaluate the expansion coefficients c_2k^mn for spheroidal +wave functions (method 1). + +SCKB Evaluate the expansion coefficients c_2k^mn for spheroidal +wave functions (method 2). + +ASWFA Evaluate the angular spheroidal wave functions of the first +kind (method 1). + +ASWFB Evaluate the angular spheroidal wave functions of the first +kind (method 2). + +RSWFP Evaluate the radial prolate spheroidal wave functions of the +first and second kinds. + +RSWFO Evaluate the radial oblate spheroidal wave functions of the +first and second kinds. + +LPMNS Evaluate a sequence of the associated Legendre functions of +the first kind and their derivatives with real arguments +for a given order. + +LQMNS Evaluate a sequence of the associated Legendre functions of +the second kind and their derivatives with real arguments +for a given order. + +***** + +ERROR Evaluate the error function. + +CERROR Evaluate the error function with a complex argument. + +***** + +FCS Evaluate the Fresnel Integrals. + +FFK Evaluate the modified Fresnel integrals. + +CERZO Evaluate the complex zeros of the error function. + +FCSZO Evaluate the complex zeros of the Fresnel Integrals. + +***** + +CISIA Evaluate the cosine and sine integrals using their series +and asymptotic expansions. + +CISIB Evaluate the cosine and sine integrals using their rational +approximations. + +***** + +COMELP Evaluate the complete elliptic integrals of the first and +second kinds. + +ELIT Evaluate the incomplete elliptic integrals of the first and +second kinds. + +ELIT3 Evaluate the complete and incomplete elliptic integrals of +the third kind. + +JELP Evaluate the Jacobian elliptic functions. + +***** + +E1XA Evaluate the exponential integral E1(x) using its polynomial +approximations. + +E1XB Evaluate the exponential integral E1(x) using its series and +continued fraction expressions. + +E1Z Evaluate the exponential integral E1(z) for complex arguments. + +ENXA Evaluate a sequence of exponential integrals En(x) (method 1). + +ENXB Evaluate a sequence of exponential integrals En(x) (method 2). + +EIX Evaluate the exponential integral Ei(x). + + + + + + + Property changes on: branches/rel-2.3.0/readme-meix.for ___________________________________________________________________ Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: branches/rel-2.3.0/pythia6425mod.f =================================================================== --- branches/rel-2.3.0/pythia6425mod.f (revision 0) +++ branches/rel-2.3.0/pythia6425mod.f (revision 477) @@ -0,0 +1,80915 @@ +C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +C++ This version of PYTHIA 6.4.25 was modified to run with the ++ +C++ jet quenching Monte Carlo JEWEL. It is not an official release ++ +C++ of PYTHIA and may not be used for anything else. ++ +C++ ++ +C++ Modifications with respect to the official PYTHIA version: ++ +C++ * The event record was enlarged to 23000 lines. ++ +C++ * The LHAPDF interface was activated and modified such that ++ +C++ nuclear PDF's can be used. ++ +C++ * A customised version of PYEVWT was introduced to allow for ++ +C++ the generation of weighted events. ++ +C++ ++ +C++ Korinna Zapp ++ +C++ (Oct. 2013) ++ +C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +C +C********************************************************************* +C********************************************************************* +C* ** +C* Mar 2011 ** +C* ** +C* The Lund Monte Carlo ** +C* ** +C* PYTHIA version 6.4 ** +C* ** +C* Torbjorn Sjostrand ** +C* Department of Theoretical Physics ** +C* Lund University ** +C* Solvegatan 14A, S-223 62 Lund, Sweden ** +C* E-mail torbjorn@thep.lu.se ** +C* ** +C* SUSY and Technicolor parts by ** +C* Stephen Mrenna ** +C* Computing Division ** +C* Generators and Detector Simulation Group ** +C* Fermi National Accelerator Laboratory ** +C* MS 234, Batavia, IL 60510, USA ** +C* phone + 1 - 630 - 840 - 2556 ** +C* E-mail mrenna@fnal.gov ** +C* ** +C* New multiple interactions and more SUSY parts by ** +C* Peter Skands ** +C* CERN/PH, CH-1211 Geneva, Switzerland ** +C* phone +41 - 22 - 767 2447 ** +C* E-mail peter.skands@cern.ch ** +C* ** +C* Several parts are written by Hans-Uno Bengtsson ** +C* PYSHOW is written together with Mats Bengtsson ** +C* PYMAEL is written by Emanuel Norrbin ** +C* advanced popcorn baryon production written by Patrik Eden ** +C* code for virtual photons mainly written by Christer Friberg ** +C* code for low-mass strings mainly written by Emanuel Norrbin ** +C* Bose-Einstein code mainly written by Leif Lonnblad ** +C* CTEQ parton distributions are by the CTEQ collaboration ** +C* GRV 94 parton distributions are by Glueck, Reya and Vogt ** +C* SaS photon parton distributions together with Gerhard Schuler ** +C* g + g and q + qbar -> t + tbar + H code by Zoltan Kunszt ** +C* MSSM Higgs mass calculation code by M. Carena, ** +C* J.R. Espinosa, M. Quiros and C.E.M. Wagner ** +C* UED implementation by M. Elkacimi, D. Goujdami, H. Przysiezniak ** +C* PYGAUS adapted from CERN library (K.S. Kolbig) ** +C* NRQCD/colour octet production of onium by S. Wolf ** +C* ** +C* The latest program version and documentation is found on WWW ** +C* http://www.thep.lu.se/~torbjorn/Pythia.html ** +C* ** +C* Copyright Torbjorn Sjostrand, Lund 2010 ** +C* ** +C********************************************************************* +C********************************************************************* +C * +C List of subprograms in order of appearance, with main purpose * +C (S = subroutine, F = function, B = block data) * +C * +C B PYDATA to contain all default values * +C S PYCKBD to check that BLOCK DATA has been correctly loaded * +C S PYTEST to test the proper functioning of the package * +C S PYHEPC to convert between /PYJETS/ and /HEPEVT/ records * +C * +C S PYINIT to administer the initialization procedure * +C S PYEVNT to administer the generation of an event * +C S PYEVNW ditto, for new multiple interactions scenario * +C S PYSTAT to print cross-section and other information * +C S PYUPEV to administer the generation of an LHA hard process * +C S PYUPIN to provide initialization needed for LHA input * +C S PYLHEF to produce a Les Houches Event File from run * +C S PYINRE to initialize treatment of resonances * +C S PYINBM to read in beam, target and frame choices * +C S PYINKI to initialize kinematics of incoming particles * +C S PYINPR to set up the selection of included processes * +C S PYXTOT to give total, elastic and diffractive cross-sect. * +C S PYMAXI to find differential cross-section maxima * +C S PYPILE to select multiplicity of pileup events * +C S PYSAVE to save alternatives for gamma-p and gamma-gamma * +C S PYGAGA to handle lepton -> lepton + gamma branchings * +C S PYRAND to select subprocess and kinematics for event * +C S PYSCAT to set up kinematics and colour flow of event * +C S PYEVOL handler for pT-ordered ISR and multiple interactions * +C S PYSSPA to simulate initial state spacelike showers * +C S PYPTIS to do pT-ordered initial state spacelike showers * +C S PYMEMX auxiliary to PYSSPA/PYPTIS for ME correction maximum * +C S PYMEWT auxiliary to PYSSPA/.. for matrix element correction * +C S PYPTMI to do pT-ordered multiple interactions * +C F PYFCMP to give companion quark x*f distribution * +C F PYPCMP to calculate momentum integral for companion quarks * +C S PYUPRE to rearranges contents of the HEPEUP commonblock * +C S PYADSH to administrate sequential final-state showers * +C S PYVETO to allow the generation of an event to be aborted * +C S PYRESD to perform resonance decays * +C S PYMULT to generate multiple interactions - old scheme * +C S PYREMN to add on target remnants - old scheme * +C S PYMIGN to generate multiple interactions - new scheme * +C S PYMIHK to connect colours in mult. int. - new scheme * +C S PYCTTR to translate PYTHIA colour information to LHA1 tags * +C S PYMIHG to collapse two pairs of LHA1 colour tags. * +C S PYMIRM to add on target remnants in mult. int.- new scheme * +C S PYFSCR to perform final state colour reconnections - -"- * +C S PYDIFF to set up kinematics for diffractive events * +C S PYDISG to set up kinematics, remnant and showers for DIS * +C S PYDOCU to compute cross-sections and handle documentation * +C S PYFRAM to perform boosts between different frames * +C S PYWIDT to calculate full and partial widths of resonances * +C S PYOFSH to calculate partial width into off-shell channels * +C S PYRECO to handle colour reconnection in W+W- events * +C S PYKLIM to calculate borders of allowed kinematical region * +C S PYKMAP to construct value of kinematical variable * +C S PYSIGH to calculate differential cross-sections * +C S PYSGQC auxiliary to PYSIGH for QCD processes * +C S PYSGHF auxiliary to PYSIGH for heavy flavour processes * +C S PYSGWZ auxiliary to PYSIGH for W and Z processes * +C S PYSGHG auxiliary to PYSIGH for Higgs processes * +C S PYSGSU auxiliary to PYSIGH for supersymmetry processes * +C S PYSGTC auxiliary to PYSIGH for technicolor processes * +C S PYSGEX auxiliary to PYSIGH for various exotic processes * +C S PYPDFU to evaluate parton distributions * +C S PYPDFL to evaluate parton distributions at low x and Q^2 * +C S PYPDEL to evaluate electron parton distributions * +C S PYPDGA to evaluate photon parton distributions (generic) * +C S PYGGAM to evaluate photon parton distributions (SaS sets) * +C S PYGVMD to evaluate VMD part of photon parton distributions * +C S PYGANO to evaluate anomalous part of photon PDFs * +C S PYGBEH to evaluate Bethe-Heitler part of photon PDFs * +C S PYGDIR to evaluate direct contribution to photon PDFs * +C S PYPDPI to evaluate pion parton distributions * +C S PYPDPR to evaluate proton parton distributions * +C F PYCTEQ to evaluate the CTEQ 3 proton parton distributions * +C S PYGRVL to evaluate the GRV 94L proton parton distributions * +C S PYGRVM to evaluate the GRV 94M proton parton distributions * +C S PYGRVD to evaluate the GRV 94D proton parton distributions * +C F PYGRVV auxiliary to the PYGRV* routines * +C F PYGRVW auxiliary to the PYGRV* routines * +C F PYGRVS auxiliary to the PYGRV* routines * +C F PYCT5L to evaluate the CTEQ 5L proton parton distributions * +C F PYCT5M to evaluate the CTEQ 5M1 proton parton distributions * +C S PYPDPO to evaluate old proton parton distributions * +C F PYHFTH to evaluate threshold factor for heavy flavour * +C S PYSPLI to find flavours left in hadron when one removed * +C F PYGAMM to evaluate ordinary Gamma function Gamma(x) * +C S PYWAUX to evaluate auxiliary functions W1(s) and W2(s) * +C S PYI3AU to evaluate auxiliary function I3(s,t,u,v) * +C F PYSPEN to evaluate Spence (dilogarithm) function Sp(x) * +C S PYQQBH to evaluate matrix element for g + g -> Q + Qbar + H * +C S PYSTBH to evaluate matrix element for t + b + H processes * +C S PYTBHB auxiliary to PYSTBH * +C S PYTBHG auxiliary to PYSTBH * +C S PYTBHQ auxiliary to PYSTBH * +C F PYTBHS auxiliary to PYSTBH * +C * +C S PYMSIN to initialize the supersymmetry simulation * +C S PYSLHA to interface to SUSY spectrum and decay calculators * +C S PYAPPS to determine MSSM parameters from SUGRA input * +C S PYSUGI to determine MSSM parameters using ISASUSY * +C S PYFEYN to determine MSSM Higgs parameters using FEYNHIGGS * +C F PYRNMQ to determine running squark masses * +C S PYTHRG to calculate sfermion third-gen. mass eigenstates * +C S PYINOM to calculate neutralino/chargino mass eigenstates * +C F PYRNM3 to determine running M3, gluino mass * +C S PYEIG4 to calculate eigenvalues and -vectors in 4*4 matrix * +C S PYHGGM to determine Higgs mass spectrum * +C S PYSUBH to determine Higgs masses in the MSSM * +C S PYPOLE to determine Higgs masses in the MSSM * +C S PYRGHM auxiliary to PYPOLE * +C S PYGFXX auxiliary to PYRGHM * +C F PYFINT auxiliary to PYPOLE * +C F PYFISB auxiliary to PYFINT * +C S PYSFDC to calculate sfermion decay partial widths * +C S PYGLUI to calculate gluino decay partial widths * +C S PYTBBN to calculate 3-body decay of gluino to neutralino * +C S PYTBBC to calculate 3-body decay of gluino to chargino * +C S PYNJDC to calculate neutralino decay partial widths * +C S PYCJDC to calculate chargino decay partial widths * +C F PYXXZ6 auxiliary for ino 3-body decays * +C F PYXXGA auxiliary for ino -> ino + gamma decay * +C F PYX2XG auxiliary for ino -> ino + gauge boson decay * +C F PYX2XH auxiliary for ino -> ino + Higgs decay * +C S PYHEXT to calculate non-SM Higgs decay partial widths * +C F PYH2XX auxiliary for H -> ino + ino decay * +C F PYGAUS to perform Gaussian integration * +C F PYGAU2 copy of PYGAUS to allow two-dimensional integration * +C F PYSIMP to perform Simpson integration * +C F PYLAMF to evaluate the lambda kinematics function * +C S PYTBDY to perform 3-body decay of gauginos * +C S PYTECM to calculate techni_rho/omega masses * +C S PYXDIN to initialize Universal Extra Dimensions * +C S PYUEDC to compute UED mass radiative corrections * +C S PYXUED to compute UED cross sections * +C S PYGRAM to generate UED G* (excited graviton) mass spectrum * +C F PYGRAW to compute UED partial widths to G* * +C F PYWDKK to compute UED differential partial widths to G* * +C S PYEICG to calculate eigenvalues of a 4*4 complex matrix * +C S PYCMQR auxiliary to PYEICG * +C S PYCMQ2 auxiliary to PYEICG * +C S PYCDIV auxiliary to PYCMQR * +C S PYCSRT auxiliary to PYCMQR * +C S PYTHAG auxiliary to PYCMQR * +C S PYCBAL auxiliary to PYEICG * +C S PYCBA2 auxiliary to PYEICG * +C S PYCRTH auxiliary to PYEICG * +C S PYLDCM auxiliary to PYSIGH, for technicolor in QCD 2 -> 2 * +C S PYBKSB auxiliary to PYSIGH, for technicolor in QCD 2 -> 2 * +C S PYWIDX to calculate decay widths from within PYWIDT * +C S PYRVSF to calculate R-violating sfermion decay widths * +C S PYRVNE to calculate R-violating neutralino decay widths * +C S PYRVCH to calculate R-violating chargino decay widths * +C S PYRVGL to calculate R-violating gluino decay widths * +C F PYRVSB auxiliary to PYRVSF * +C S PYRVGW to calculate R-Violating 3-body widths * +C F PYRVI1 auxiliary to PYRVGW, to do PS integration for res. * +C F PYRVI2 auxiliary to PYRVGW, to do PS integration for LR-int.* +C F PYRVI3 auxiliary to PYRVGW, to do PS X integral for int. * +C F PYRVG1 auxiliary to PYRVI1, general matrix element, res. * +C F PYRVG2 auxiliary to PYRVI2, general matrix element, LR-int. * +C F PYRVG3 auxiliary to PYRVI3, to do PS Y integral for int. * +C F PYRVG4 auxiliary to PYRVG3, general matrix element, int. * +C F PYRVR auxiliary to PYRVG1, Breit-Wigner * +C F PYRVS auxiliary to PYRVG2 & PYRVG4 * +C * +C S PY1ENT to fill one entry (= parton or particle) * +C S PY2ENT to fill two entries * +C S PY3ENT to fill three entries * +C S PY4ENT to fill four entries * +C S PY2FRM to interface to generic two-fermion generator * +C S PY4FRM to interface to generic four-fermion generator * +C S PY6FRM to interface to generic six-fermion generator * +C S PY4JET to generate a shower from a given 4-parton config * +C S PY4JTW to evaluate the weight od a shower history for above * +C S PY4JTS to set up the parton configuration for above * +C S PYJOIN to connect entries with colour flow information * +C S PYGIVE to fill (or query) commonblock variables * +C S PYONOF to allow easy control of particle decay modes * +C S PYTUNE to select a predefined 'tune' for min-bias and UE * +C S PYEXEC to administrate fragmentation and decay chain * +C S PYPREP to rearrange showered partons along strings * +C S PYSTRF to do string fragmentation of jet system * +C S PYJURF to find boost to string junction rest frame * +C S PYINDF to do independent fragmentation of one or many jets * +C S PYDECY to do the decay of a particle * +C S PYDCYK to select parton and hadron flavours in decays * +C S PYKFDI to select parton and hadron flavours in fragm * +C S PYNMES to select number of popcorn mesons * +C S PYKFIN to calculate falvour prod. ratios from input params. * +C S PYPTDI to select transverse momenta in fragm * +C S PYZDIS to select longitudinal scaling variable in fragm * +C S PYSHOW to do m-ordered timelike parton shower evolution * +C S PYPTFS to do pT-ordered timelike parton shower evolution * +C F PYMAEL auxiliary to PYSHOW & PYPTFS: gluon emission ME's * +C S PYBOEI to include Bose-Einstein effects (crudely) * +C S PYBESQ auxiliary to PYBOEI * +C F PYMASS to give the mass of a particle or parton * +C F PYMRUN to give the running MSbar mass of a quark * +C S PYNAME to give the name of a particle or parton * +C F PYCHGE to give three times the electric charge * +C F PYCOMP to compress standard KF flavour code to internal KC * +C S PYERRM to write error messages and abort faulty run * +C F PYALEM to give the alpha_electromagnetic value * +C F PYALPS to give the alpha_strong value * +C F PYANGL to give the angle from known x and y components * +C F PYR to provide a random number generator * +C S PYRGET to save the state of the random number generator * +C S PYRSET to set the state of the random number generator * +C S PYROBO to rotate and/or boost an event * +C S PYEDIT to remove unwanted entries from record * +C S PYLIST to list event record or particle data * +C S PYLOGO to write a logo * +C S PYUPDA to update particle data * +C F PYK to provide integer-valued event information * +C F PYP to provide real-valued event information * +C S PYSPHE to perform sphericity analysis * +C S PYTHRU to perform thrust analysis * +C S PYCLUS to perform three-dimensional cluster analysis * +C S PYCELL to perform cluster analysis in (eta, phi, E_T) * +C S PYJMAS to give high and low jet mass of event * +C S PYFOWO to give Fox-Wolfram moments * +C S PYTABU to analyze events, with tabular output * +C * +C S PYEEVT to administrate the generation of an e+e- event * +C S PYXTEE to give the total cross-section at given CM energy * +C S PYRADK to generate initial state photon radiation * +C S PYXKFL to select flavour of primary qqbar pair * +C S PYXJET to select (matrix element) jet multiplicity * +C S PYX3JT to select kinematics of three-jet event * +C S PYX4JT to select kinematics of four-jet event * +C S PYXDIF to select angular orientation of event * +C S PYONIA to perform generation of onium decay to gluons * +C * +C S PYBOOK to book a histogram * +C S PYFILL to fill an entry in a histogram * +C S PYFACT to multiply histogram contents by a factor * +C S PYOPER to perform operations between histograms * +C S PYHIST to print and reset all histograms * +C S PYPLOT to print a single histogram * +C S PYNULL to reset contents of a single histogram * +C S PYDUMP to dump histogram contents onto a file * +C * +C S PYSTOP routine to handle Fortran STOP condition * +C * +C S PYKCUT dummy routine for user kinematical cuts * +C S PYEVWT dummy routine for weighting events * +C S UPINIT dummy routine to initialize user processes * +C S UPEVNT dummy routine to generate a user process event * +C S UPVETO dummy routine to abort event at parton level * +C S PDFSET dummy routine to be removed when using PDFLIB * +C S STRUCTM dummy routine to be removed when using PDFLIB * +C S STRUCTP dummy routine to be removed when using PDFLIB * +C S SUGRA dummy routine to be removed when linking with ISAJET * +C F VISAJE dummy functn. to be removed when linking with ISAJET * +C S SSMSSM dummy routine to be removed when linking with ISAJET * +C S FHSETFLAGS dummy routine -"- FEYNHIGGS * +C S FHSETPARA dummy routine -"- FEYNHIGGS * +C S FHHIGGSCORR dummy routine -"- FEYNHIGGS * +C S PYTAUD dummy routine for interface to tau decay libraries * +C S PYTIME dummy routine for giving date and time * +C * +C********************************************************************* + +C...PYDATA +C...Default values for switches and parameters, +C...and particle, decay and process data. + + BLOCK DATA PYDATA + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + COMMON/PYDAT4/CHAF(500,2) + CHARACTER CHAF*16 + COMMON/PYDATR/MRPY(6),RRPY(100) + COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) + COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000) + COMMON/PYINT4/MWID(500),WIDS(500,5) + COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) + COMMON/PYINT6/PROC(0:500) + CHARACTER PROC*28 + COMMON/PYINT7/SIGT(0:6,0:6,0:5) + COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) + COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), + &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) + COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3) + COMMON/PYTCSM/ITCM(0:99),RTCM(0:99) + COMMON/PYPUED/IUED(0:99),RUED(0:99) + COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000) + COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100), + & AU(3,3),AD(3,3),AE(3,3) + COMMON/PYLH3C/CPRO(2),CVER(2) + CHARACTER CPRO*12,CVER*12 + SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,/PYSUBS/, + &/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/, + &/PYINT6/,/PYINT7/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYTCSM/,/PYPUED/, + &/PYBINS/,/PYLH3P/,/PYLH3C/ + +C...PYDAT1, containing status codes and most parameters. + DATA MSTU/ + & 0, 0, 0, 23000,23000, 500, 8000, 0, 0, 2, + 1 6, 0, 1, 0, 0, 1, 0, 0, 0, 0, + 2 2, 10, 0, 0, 1, 10, 0, 0, 0, 0, + 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 4 2, 2, 1, 4, 2, 1, 1, 0, 0, 0, + 5 25, 24, 0, 1, 0, 0, 0, 0, 0, 0, + 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 7 30*0, + 1 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 2 1, 5, 3, 5, 0, 0, 0, 0, 0, 0, + & 80*0/ + DATA (PARU(I),I=1,100)/ + & 3.141592653589793D0, 6.283185307179586D0, + & 0.197327D0, 5.06773D0, 0.389380D0, 2.56819D0, 4*0D0, + 1 0.001D0, 0.09D0, 0.01D0, 2D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, + 2 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, + 3 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, + 4 2.0D0, 1.0D0, 0.25D0, 2.5D0, 0.05D0, + 4 0D0, 0D0, 0.0001D0, 0D0, 0D0, + 5 2.5D0,1.5D0,7.0D0,1.0D0,0.5D0,2.0D0,3.2D0, 0D0, 0D0, 0D0, + 6 40*0D0/ + DATA (PARU(I),I=101,200)/ + & 0.00729735D0, 0.232D0, 0.007764D0, 1.0D0, 1.16639D-5, + & 0D0, 0D0, 0D0, 0D0, 0D0, + 1 0.20D0, 0.25D0, 1.0D0, 4.0D0, 10D0, 0D0, 0D0, 0D0, 0D0, 0D0, + 2 -0.693D0, -1.0D0, 0.387D0, 1.0D0, -0.08D0, + 2 -1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0, + 3 1.0D0,-1.0D0, 1.0D0,-1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0, + 4 5.0D0, 1.0D0, 1.0D0, 0D0, 1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, + 5 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, + 6 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0, + 7 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0,0D0,0D0, + 8 1.0D0, 1.0D0, 1.0D0, 0.0D0, 0.0D0, 1.0D0, 1.0D0, 0D0,0D0,0D0, + 9 0D0, 0D0, 0D0, 0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0/ + DATA MSTJ/ + & 1, 3, 0, 0, 0, 0, 0, 0, 0, 0, + 1 4, 2, 0, 1, 0, 2, 2, 20, 0, 0, + 2 2, 1, 1, 2, 1, 2, 2, 0, 0, 0, + 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 4 2, 2, 4, 2, 5, 3, 3, 0, 0, 3, + 5 0, 3, 0, 2, 0, 0, 1, 0, 0, 0, + 6 40*0, + & 5, 2, 7, 5, 1, 1, 0, 2, 0, 2, + 1 0, 0, 0, 0, 1, 1, 0, 0, 0, 0, + 2 80*0/ + DATA PARJ/ + & 0.10D0, 0.30D0, 0.40D0, 0.05D0, 0.50D0, + & 0.50D0, 0.50D0, 0.6D0, 1.2D0, 0.6D0, + 1 0.50D0,0.60D0,0.75D0, 0D0, 0D0, 0D0, 0D0, 1.0D0, 1.0D0, 0D0, + 2 0.36D0, 1.0D0,0.01D0, 2.0D0,1.0D0,0.4D0, 0D0, 0D0, 0D0, 0D0, + 3 0.10D0, 1.0D0, 0.8D0, 1.5D0,0D0,2.0D0,0.2D0, 0D0,0.08D0,1D0, + 4 0.3D0, 0.58D0, 0.5D0, 0.9D0,0.5D0,1.0D0,1.0D0,1.5D0,1D0,10D0, + 5 0.77D0, 0.77D0, 0.77D0, -0.05D0, -0.005D0, + 5 0D0, 0D0, 0D0, 1.0D0, 0D0, + 6 4.5D0, 0.7D0, 0D0,0.003D0, 0.5D0, 0.5D0, 0D0, 0D0, 0D0, 0D0, + 7 10D0, 1000D0, 100D0, 1000D0, 0D0, 0.7D0,10D0, 0D0,0D0,0.5D0, + 8 0.29D0, 1.0D0, 1.0D0, 0D0, 10D0, 10D0, 0D0, 0D0, 0D0,1D-4, + 9 0.02D0, 1.0D0, 0.2D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, + & 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, + 1 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, + 2 1.0D0, 0.25D0,91.187D0,2.489D0, 0.01D0, + 2 2.0D0, 1.0D0, 0.25D0,0.002D0, 0D0, + 3 0D0, 0D0, 0D0, 0D0, 0.01D0, 0.99D0, 0D0, 0D0, 0.2D0, 0D0, + 4 10*0D0, + 5 10*0D0, + 6 10*0D0, + 7 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, -0.693D0, + 8 -1.0D0, 0.387D0, 1.0D0, -0.08D0, -1.0D0, + 8 1.0D0, 1.0D0, -0.693D0, -1.0D0, 0.387D0, + 9 1.0D0, -0.08D0, -1.0D0, 1.0D0, 1.0D0, + 9 5*0D0/ + +C...PYDAT2, with particle data and flavour treatment parameters. + DATA (KCHG(I,1),I= 1, 500)/-1,2,-1,2,-1,2,-1,2,2*0,-3,0,-3,0, + &-3,0,-3,6*0,3,9*0,3,2*0,3,4*0,-1,41*0,2,-1,20*0,3*3,7*0,3*3,3*0, + &3*3,3*0,3*3,6*0,3*3,3*0,3*3,4*0,-2,-3,2*1,2*0,4,2*3,6,2*-2,2*-3, + &0,2*1,2*0,2*3,-2,2*-3,2*0,-3,2*1,2*0,3,0,2*4,2*3,2*6,3,2*1,2*0, + &2*3,2*0,4,2*3,2*6,2*3,6,2*-2,2*-3,0,-3,0,2*1,2*0,2*3,0,3,2*-2, + &2*-3,2*0,2*-3,0,2*1,2*0,2*3,2*0,2*3,-2,2*-3,2*0,2*-3,2*0,-3,2*0, + &2*3,4*0,2*3,2*0,2*3,2*0,2*3,4*0,2*3,2*0,2*3,3*0,3,2*0,3,0,3,0,3, + &2*0,3,0,3,3*0,-1,2,-1,2,-1,2,-3,0,-3,0,-3,4*0,3,2*0,3,0,-1,2,-1, + &2,-1,2,-3,0,-3,0,-3,2*0,3,3*0,3,8*0,-1,2,-3,6*0,3,2*6,0,3,4*0,3, + &7*0,3, +C...UED singlet and doublet quarks, leptons, and KK g, gamma, Z, and W + &81*0,-1,2,-1,2,-1,2,-1,2,-1,2,-1,2, + &3*-3,0,-3,0,-3,0,-3, + &3*0,3, + &25*0/ + DATA (KCHG(I,2),I= 1, 500)/8*1,12*0,2,20*0,1,107*0,-1,0,2*-1, + &2*0,-1,3*0,2*-1,3*0,2*-1,4*0,-1,5*0,2*-1,4*0,2*-1,5*0,2*-1,6*0, + &-1,7*0,2*-1,5*0,2*-1,6*0,2*-1,7*0,2*-1,8*0,-1,56*0,6*1,6*0,2,7*0, + &6*1,9*0,2,3*0,2,0,5*2,2*1,17*0,6*2, + &83*0,12*1,9*0,2,3*0,25*0/ + DATA (KCHG(I,3),I= 1, 500)/8*1,2*0,8*1,5*0,1,9*0,1,2*0,1,3*0, + &2*1,39*0,1,0,2*1,20*0,3*1,4*0,6*1,3*0,9*1,3*0,12*1,4*0,100*1,2*0, + &2*1,2*0,4*1,2*0,6*1,2*0,8*1,3*0,1,0,2*1,0,3*1,0,4*1,3*0,12*1,3*0, + &1,2*0,1,0,12*1,0,1,3*0,1,8*0,4*1,5*0,3*1,0,1,3*0,2*1,7*0,1, + &81*0,21*1,3*0,1,25*0/ + DATA (KCHG(I,4),I= 1, 290)/1,2,3,4,5,6,7,8,9,10,11,12,13,14,15, + &16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36, + &37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57, + &58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78, + &79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99, + &100,110,111,113,115,130,211,213,215,221,223,225,310,311,313,315, + &321,323,325,331,333,335,411,413,415,421,423,425,431,433,435,441, + &443,445,511,513,515,521,523,525,531,533,535,541,543,545,551,553, + &555,990,1103,1114,2101,2103,2112,2114,2203,2212,2214,2224,3101, + &3103,3112,3114,3122,3201,3203,3212,3214,3222,3224,3303,3312,3314, + &3322,3324,3334,4101,4103,4112,4114,4122,4132,4201,4203,4212,4214, + &4222,4224,4232,4301,4303,4312,4314,4322,4324,4332,4334,4403,4412, + &4414,4422,4424,4432,4434,4444,5101,5103,5112,5114,5122,5132,5142, + &5201,5203,5212,5214,5222,5224,5232,5242,5301,5303,5312,5314,5322, + &5324,5332,5334,5342,5401,5403,5412,5414,5422,5424,5432,5434,5442, + &5444,5503,5512,5514,5522,5524,5532,5534,5542,5544,5554,10111, + &10113,10211,10213,10221,10223,10311,10313,10321,10323,10331, + &10333,10411,10413,10421,10423,10431,10433,10441,10443,10511, + &10513,10521,10523,10531,10533,10541,10543,10551,10553,20113, + &20213,20223,20313,20323,20333,20413,20423,20433,20443,20513/ + DATA (KCHG(I,4),I= 291, 500)/20523,20533,20543,20553,100443, + &100553,1000001,1000002,1000003,1000004,1000005,1000006,1000011, + &1000012,1000013,1000014,1000015,1000016,1000021,1000022,1000023, + &1000024,1000025,1000035,1000037,1000039,2000001,2000002,2000003, + &2000004,2000005,2000006,2000011,2000012,2000013,2000014,2000015, + &2000016,3000111,3000211,3000221,3000331,3000113,3000213,3000223, + &3100021,3100111,3200111,3100113,3200113,3300113,3400113,4000001, + &4000002,4000011,4000012,5000039,9900012,9900014,9900016,9900023, + &9900024,9900041,9900042,9900110,9900210,9900220,9900330,9900440, + &9902110,9902210,9900443,9900441,9910441,9900553,9900551,9910551, + &3000115,3000215, + &81*0, +C...UED singlet and doublet quarks and leptons, and KK g, gamma, Z, and W. + &6100001,6100002,6100003,6100004,6100005,6100006, + &5100001,5100002,5100003,5100004,5100005,5100006, + &6100011,6100013,6100015, + &5100012,5100011,5100014,5100013,5100016,5100015, + &5100021,5100022,5100023,5100024, + &25*0/ + DATA (PMAS(I,1),I= 1, 217)/2*0.33D0,0.5D0,1.5D0,4.8D0,175D0, + &2*400D0,2*0D0,0.00051D0,0D0,0.10566D0,0D0,1.777D0,0D0,400D0, + &5*0D0,91.188D0,80.45D0,115D0,6*0D0,500D0,900D0,500D0,3*300D0, + &3*0D0,5000D0,200D0,40*0D0,1D0,2D0,5D0,16*0D0,0.13498D0,0.7685D0, + &1.318D0,0.49767D0,0.13957D0,0.7669D0,1.318D0,0.54745D0,0.78194D0, + &1.275D0,2*0.49767D0,0.8961D0,1.432D0,0.4936D0,0.8916D0,1.425D0, + &0.95777D0,1.0194D0,1.525D0,1.8693D0,2.01D0,2.46D0,1.8645D0, + &2.0067D0,2.46D0,1.9685D0,2.1124D0,2.5735D0,2.9798D0,3.09688D0, + &3.5562D0,5.2792D0,5.3248D0,5.83D0,5.2789D0,5.3248D0,5.83D0, + &5.3693D0,5.4163D0,6.07D0,6.594D0,6.602D0,7.35D0,9.4D0,9.4603D0, + &9.9132D0,0D0,0.77133D0,1.234D0,0.57933D0,0.77133D0,0.93957D0, + &1.233D0,0.77133D0,0.93827D0,1.232D0,1.231D0,0.80473D0,0.92953D0, + &1.19744D0,1.3872D0,1.11568D0,0.80473D0,0.92953D0,1.19255D0, + &1.3837D0,1.18937D0,1.3828D0,1.09361D0,1.3213D0,1.535D0,1.3149D0, + &1.5318D0,1.67245D0,1.96908D0,2.00808D0,2.4521D0,2.5D0,2.2849D0, + &2.4703D0,1.96908D0,2.00808D0,2.4535D0,2.5D0,2.4529D0,2.5D0, + &2.4656D0,2.15432D0,2.17967D0,2.55D0,2.63D0,2.55D0,2.63D0,2.704D0, + &2.8D0,3.27531D0,3.59798D0,3.65648D0,3.59798D0,3.65648D0, + &3.78663D0,3.82466D0,4.91594D0,5.38897D0,5.40145D0,5.8D0,5.81D0, + &5.641D0,5.84D0,7.00575D0,5.38897D0,5.40145D0,5.8D0,5.81D0,5.8D0/ + DATA (PMAS(I,1),I= 218, 500)/5.81D0,5.84D0,7.00575D0,5.56725D0, + &5.57536D0,5.96D0,5.97D0,5.96D0,5.97D0,6.12D0,6.13D0,7.19099D0, + &6.67143D0,6.67397D0,7.03724D0,7.0485D0,7.03724D0,7.0485D0, + &7.21101D0,7.219D0,8.30945D0,8.31325D0,10.07354D0,10.42272D0, + &10.44144D0,10.42272D0,10.44144D0,10.60209D0,10.61426D0, + &11.70767D0,11.71147D0,15.11061D0,0.9835D0,1.231D0,0.9835D0, + &1.231D0,1D0,1.17D0,1.429D0,1.29D0,1.429D0,1.29D0,2*1.4D0,2.272D0, + &2.424D0,2.272D0,2.424D0,2.5D0,2.536D0,3.4151D0,3.46D0,5.68D0, + &5.73D0,5.68D0,5.73D0,5.92D0,5.97D0,7.25D0,7.3D0,9.8598D0,9.875D0, + &2*1.23D0,1.282D0,2*1.402D0,1.427D0,2*2.372D0,2.56D0,3.5106D0, + &2*5.78D0,6.02D0,7.3D0,9.8919D0,3.686D0,10.0233D0,32*500D0, + &3*110D0,350D0,3*210D0,500D0,125D0,250D0,400D0,2*350D0,300D0, + &4*400D0,1000D0,3*500D0,1200D0,750D0,2*200D0,7*0D0,3*3.1D0, + &3*9.5D0,2*250D0, + &81*0, +C...UED + &586.,588.,586.,588.,586.,586.,6*598., + &3*505.,6*516.,640.,501.,536.,536.,25*0.D0/ + DATA (PMAS(I,2),I= 1, 500)/5*0D0,1.39816D0,16*0D0,2.47813D0, + &2.07115D0,0.00367D0,6*0D0,14.54029D0,0D0,16.66099D0,8.38842D0, + &3.3752D0,4.17669D0,3*0D0,417.29147D0,0.39162D0,60*0D0,0.151D0, + &0.107D0,2*0D0,0.149D0,0.107D0,0D0,0.00843D0,0.185D0,2*0D0, + &0.0505D0,0.109D0,0D0,0.0498D0,0.098D0,0.0002D0,0.00443D0,0.076D0, + &2*0D0,0.023D0,2*0D0,0.023D0,2*0D0,0.015D0,0.0013D0,0D0,0.002D0, + &2*0D0,0.02D0,2*0D0,0.02D0,2*0D0,0.02D0,2*0D0,0.02D0,5*0D0,0.12D0, + &3*0D0,0.12D0,2*0D0,2*0.12D0,3*0D0,0.0394D0,4*0D0,0.036D0,0D0, + &0.0358D0,2*0D0,0.0099D0,0D0,0.0091D0,74*0D0,0.06D0,0.142D0, + &0.06D0,0.142D0,0D0,0.36D0,0.287D0,0.09D0,0.287D0,0.09D0,0.25D0, + &0.08D0,0.05D0,0.02D0,0.05D0,0.02D0,0.05D0,0D0,0.014D0,0.01D0, + &8*0.05D0,0D0,0.01D0,2*0.4D0,0.025D0,2*0.174D0,0.053D0,3*0.05D0, + &0.0009D0,4*0.05D0,3*0D0,19*1D0,0D0,7*1D0,0D0,1D0,0D0,1D0,0D0, + &0.0208D0,0.01195D0,0.03705D0,0.09511D0,1.89978D0,1.60746D0, + &0.13396D0,200.47294D0,0.02296D0,0.18886D0,94.66794D0,6.08718D0, + &0D0,2.17482D0,2.59359D0,2.59687D0,0.42896D0,0.41912D0,0.14153D0, + &2*0.00098D0,0.00097D0,26.7245D0,21.74916D0,0.88159D0,0.88001D0, + &7*0D0,6*0.01D0,0.25499D0,0.28446D0,131*0D0/ + DATA (PMAS(I,3),I= 1, 500)/5*0D0,13.98156D0,16*0D0,24.78129D0, + &20.71149D0,0.03669D0,6*0D0,145.40294D0,0D0,166.60993D0, + &83.88423D0,33.75195D0,41.76694D0,3*0D0,4172.91467D0,3.91621D0, + &60*0D0,0.4D0,0.25D0,2*0D0,0.4D0,0.25D0,0D0,0.1D0,0.17D0,2*0D0, + &0.2D0,0.12D0,0D0,0.2D0,0.12D0,0.002D0,0.015D0,0.2D0,2*0D0,0.12D0, + &2*0D0,0.12D0,2*0D0,0.05D0,0.005D0,0D0,0.01D0,2*0D0,0.05D0,2*0D0, + &0.05D0,2*0D0,0.05D0,2*0D0,0.05D0,5*0D0,0.14D0,3*0D0,0.14D0,2*0D0, + &2*0.14D0,3*0D0,0.04D0,4*0D0,0.035D0,0D0,0.035D0,2*0D0,0.05D0,0D0, + &0.05D0,74*0D0,0.05D0,0.25D0,0.05D0,0.25D0,0D0,0.2D0,0.4D0, + &0.005D0,0.4D0,0.01D0,0.35D0,0.001D0,0.1D0,0.08D0,0.1D0,0.08D0, + &0.1D0,0D0,0.05D0,0.02D0,6*0.1D0,0.05D0,0.1D0,0D0,0.02D0,2*0.3D0, + &0.05D0,2*0.3D0,0.02D0,2*0.1D0,0.03D0,0.001D0,4*0.1D0,3*0D0, + &19*10D0,0.00001D0,7*10D0,0.00001D0,10D0,0.00001D0,10D0,0.00001D0, + &0.20797D0,0.11949D0,0.37048D0,0.95114D0,18.99785D0,16.07463D0, + &1.33964D0,450D0,0.22959D0,1.88863D0,360D0,60.8718D0,0D0, + &21.74824D0,25.93594D0,25.96873D0,4.28961D0,4.19124D0,1.41528D0, + &0.00977D0,0.00976D0,0.00973D0,267.24501D0,217.49162D0,8.81592D0, + &8.80013D0,13*0D0,2.54987D0,2.84456D0, + &81*0, +C...UED + &12*0.2D0,9*0.1D0,0.2,10.,0.07,0.3,25*0.D0/ + DATA (PMAS(I,4),I= 1, 500)/12*0D0,658654D0,0D0,0.0872D0,68*0D0, + &0.1D0,0.387D0,16*0D0,0.00003D0,2*0D0,15500D0,7804.5D0,5*0D0, + &26.762D0,3*0D0,3709D0,5*0D0,0.317D0,2*0D0,0.1244D0,2*0D0,0.14D0, + &5*0D0,0.468D0,2*0D0,0.462D0,2*0D0,0.483D0,2*0D0,0.15D0,18*0D0, + &44.34D0,0D0,78.88D0,4*0D0,23.96D0,2*0D0,49.1D0,0D0,87.1D0,0D0, + &24.6D0,4*0D0,0.0618D0,0.029D0,6*0D0,0.106D0,6*0D0,0.019D0,2*0D0, + &7*0.1D0,4*0D0,0.342D0,2*0.387D0,6*0D0,2*0.387D0,6*0D0,0.387D0, + &0D0,0.387D0,2*0D0,8*0.387D0,0D0,9*0.387D0,120*0D0,131*0D0/ + + DATA PARF/ + & 0.5D0,0.25D0, 0.5D0,0.25D0, 1D0, 0.5D0, 0D0, 0D0, 0D0, 0D0, + 1 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0, + 2 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0, + 3 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0, + 4 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0, + 5 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0, + 6 0.75D0, 0.5D0, 0D0,0.1667D0,0.0833D0,0.1667D0,0D0,0D0,0D0, 0D0, + 7 0D0, 0D0, 1D0,0.3333D0,0.6667D0,0.3333D0,0D0,0D0,0D0, 0D0, + 8 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, + 9 0.0099D0, 0.0056D0, 0.199D0, 1.23D0, 4.17D0, 165D0, 4*0D0, + & 0.325D0,0.325D0,0.5D0,1.6D0, 5.0D0, 0D0, 0D0, 0D0, 0D0, 0D0, + 1 0D0,0.11D0,0.16D0,0.048D0,0.50D0,0.45D0,0.55D0,0.60D0,0D0,0D0, + 2 0.2D0, 0.1D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, + 3 60*0D0, + 4 0.2D0, 0.5D0, 8*0D0, + 5 1800*0D0/ + DATA ((VCKM(I,J),J=1,4),I=1,4)/ + & 0.95113D0, 0.04884D0, 0.00003D0, 0.00000D0, + & 0.04884D0, 0.94940D0, 0.00176D0, 0.00000D0, + & 0.00003D0, 0.00176D0, 0.99821D0, 0.00000D0, + & 0.00000D0, 0.00000D0, 0.00000D0, 1.00000D0/ + +C...PYDAT3, with particle decay parameters and data. + DATA (MDCY(I,1),I= 1, 500)/5*0,3*1,6*0,1,0,1,5*0,3*1,6*0,1,0, + &4*1,3*0,2*1,40*0,3*1,16*0,3*1,2*0,9*1,0,32*1,2*0,1,3*0,1,2*0,2*1, + &2*0,3*1,2*0,4*1,0,5*1,2*0,4*1,2*0,5*1,2*0,6*1,0,7*1,2*0,5*1,2*0, + &6*1,2*0,7*1,2*0,8*1,0,75*1,0,7*1,0,1,0,1,0,26*1,7*0,8*1, + &81*0, +C...UED + &5*1,0,5*1,0,13*1,25*0/ + DATA (MDCY(I,2),I= 1, 351)/1,9,17,25,33,41,56,66,2*0,76,80,82, + &87,89,143,145,150,2*0,153,162,174,190,210,6*0,289,0,311,334,420, + &503,3*0,530,539,40*0,540,541,545,16*0,554,556,561,570,579,581, + &583,590,598,604,613,615,617,620,630,636,639,650,656,667,673,736, + &739,747,808,810,818,851,853,857,858,861,863,899,900,908,944,945, + &953,992,993,997,1028,1029,1033,1034,1043,2*0,1045,3*0,1046,2*0, + &1049,1052,2*0,1053,1055,1058,2*0,1062,1063,1066,1069,0,1072,1077, + &1079,1082,1084,2*0,1088,1089,1090,1166,2*0,1170,1171,1172,1173, + &1174,2*0,1178,1179,1181,1182,1184,1188,0,1189,1193,1197,1201, + &1205,1209,1213,2*0,1217,1218,1219,1236,1245,2*0,1254,1255,1256, + &1257,1258,1267,2*0,1276,1277,1278,1279,1280,1289,1290,2*0,1299, + &1308,1317,1326,1335,1344,1353,1362,0,1371,1380,1389,1398,1407, + &1416,1425,1434,1443,1452,1453,1454,1455,1456,1461,1464,1466,1471, + &1473,1478,1485,1489,1491,1493,1495,1497,1499,1501,1503,1504,1506, + &1508,1510,1512,1514,1516,1518,1520,1522,1523,1525,1527,1541,1543, + &1545,1549,1551,1553,1555,1557,1559,1561,1563,1565,1567,1578,1592, + &1637,1661,1706,1730,1775,1802,1833,1859,1891,1917,1949,1975,2162, + &2331,2595,2826,3106,3402,0,3657,3706,3734,3783,3811,3860,3888,0, + &3924,0,3960,0,3996,4004,4012,4020,4217,4243,4270,4023,4029,4036, + &4043,4050,4056,4062,4071,4075,4079,4082,4084,4104,4126,4148,4170/ + DATA (MDCY(I,2),I= 352, 500)/4185,4197,4204,7*0,4211,4212,4213, + &4214,4215,4216,4296,4322, + &81*0, +C...UED + %5001,5003,5005,5007,5009,5011,5013,5016,5019,5022,5025,5028, + &5031,5032,5033, + &5034,5035,5036,5037,5038,5039,5040,5064,5065,5083, + &25*0/ + DATA (MDCY(I,3),I= 1, 500)/5*8,15,2*10,2*0,4,2,5,2,54,2,5,3, + &2*0,9,12,16,20,79,6*0,22,0,23,86,83,27,3*0,9,1,40*0,1,4,9,16*0,2, + &5,2*9,2*2,7,8,6,9,2*2,3,10,6,3,11,6,11,6,63,3,8,61,2,8,33,2,4,1, + &3,2,36,1,8,36,1,8,39,1,4,31,1,4,1,9,2,2*0,1,3*0,3,2*0,3,1,2*0,2, + &3,4,2*0,1,3*3,0,5,2,3,2,4,2*0,2*1,76,4,2*0,4*1,4,2*0,1,2,1,2,4,1, + &0,7*4,2*0,2*1,17,2*9,2*0,4*1,2*9,2*0,4*1,9,1,9,2*0,8*9,0,9*9,4*1, + &5,3,2,5,2,5,7,4,7*2,1,9*2,1,2*2,14,2*2,4,9*2,11,14,45,24,45,24, + &45,27,31,26,32,26,32,26,187,169,264,231,280,296,255,0,49,28,49, + &28,49,28,36,0,36,0,36,0,3*8,3,26,27,26,6,3*7,2*6,9,2*4,3,2,20, + &3*22,15,12,2*7,7*0,6*1,26,30, + &81*0, +C...UED + &6*2,6*3,9*1,24,1,18,6,25*0/ + DATA (MDME(I,1),I= 1,8000)/6*1,-1,7*1,-1,7*1,-1,7*1,-1,7*1,-1, + &7*1,-1,1,7*-1,8*1,2*-1,8*1,2*-1,73*1,-1,2*1,-1,5*1,0,2*-1,6*1,0, + &2*-1,3*1,-1,6*1,2*-1,6*1,2*-1,3*1,-1,3*1,-1,3*1,5*-1,3*1,-1,6*1, + &2*-1,3*1,-1,5*1,62*1,6*1,2*-1,6*1,8*-1,3*1,-1,3*1,-1,3*1,5*-1, + &3*1,4*-1,6*1,2*-1,3*1,-1,12*1,62*1,6*1,2*-1,3*1,-1,9*1,62*1, + &3*1,-1,3*1,-1,1,18*1,4*1,2*-1,2*1,-1,1249*1,2*-1,377*1,2*-1, + &1921*1,2*-1,6*1,2*-1,133*1,2*-1,6*1,2*-1,10*1,-1,3*1,-1,3*1,5*-1, + &3*1,-1,16*1,2*-1,6*1,2*-1,16*1,2*-1,6*1,2*-1,13*1,-1,3*1,-1,3*1, + &5*-1,3*1,-1, + &649*0, +C...UED + &10*1,2*0,15*1,3*0,9*1,5*1,0,5*1,0,5*1,0,5*1,0, + &1,24*1,2912*0/ + DATA (MDME(I,2),I= 1,8000)/43*102,4*0,102,0,6*53,3*102,4*0,102, + &2*0,3*102,4*0,102,2*0,6*102,42,6*102,2*42,2*0,8*41,2*0,36*41, + &8*102,0,102,0,102,2*0,21*102,8*32,8*0,16*32,4*0,8*32,9*0,62*53, + &8*32,14*0,16*32,7*0,8*32,16*0,62*53,8*32,13*0,62*53,4*32,5*0, + &18*53,6*32,4*0,12,2*42,2*11,9*42,0,2,3,15*0,4*42,5*0,3,12*0,2, + &3*0,1,0,3,16*0,2*3,15*0,2*42,2*3,18*0,2*3,3*0,1,11*0,22*42,41*0, + &2*3,9*0,16*42,45*0,3,10*0,10*42,20*0,2*13,6*0,12,2*0,12,0,12, + &14*42,16*0,48,3*13,2*42,9*0,14*42,16*0,48,3*13,2*42,9*0,14*42, + &19*0,48,3*13,2*42,6*0,2*11,28*42,5*0,32,3*0,4*32,2*4,0,32,45*0, + &14*42,52*0,10*13,2*42,2*11,4*0,2*42,2*11,6*0,2*42,2*11,0,2*42, + &2*11,2*42,2*11,2*42,2*11,2*42,2*11,2*42,2*11,2*42,2*11,2*42,2*11, + &2*0,3*42,8*0,48,3*13,20*42,4*0,18*42,4*0,9*42,0,162*42,50*0,2*12, + &17*0,2*32,33*0,12,9*0,32,2*0,12,11*0,4*32,2*4,5*0,2404*53,4*32, + &3*0,6*32,3*0,4*32,3*0,50*32,3*53,12*0,8*32,12*0,66*51,6*32,9*0, + &9*32,17*0,6*51,10*0,8*32,15*0,16*32,14*0,8*32,18*0,8*32,18*0, + &16*32, +C...UED + &653*0,30*0,9*0,12*0,37*0,2912*0/ + DATA (BRAT(I) ,I= 1, 348)/43*0D0,0.00003D0,0.001765D0, + &0.998205D0,35*0D0,1D0,6*0D0,0.1783D0,0.1735D0,0.1131D0,0.2494D0, + &0.003D0,0.09D0,0.0027D0,0.01D0,0.0014D0,0.0012D0,2*0.00025D0, + &0.0071D0,0.012D0,0.0004D0,0.00075D0,0.00006D0,2*0.00078D0, + &0.0034D0,0.08D0,0.011D0,0.0191D0,0.00006D0,0.005D0,0.0133D0, + &0.0067D0,0.0005D0,0.0035D0,0.0006D0,0.0015D0,0.00021D0,0.0002D0, + &0.00075D0,0.0001D0,0.0002D0,0.0011D0,3*0.0002D0,0.00022D0, + &0.0004D0,0.0001D0,2*0.00205D0,2*0.00069D0,0.00025D0,0.00051D0, + &0.00025D0,35*0D0,0.153995D0,0.11942D0,0.153984D0,0.119259D0, + &0.152272D0,3*0D0,0.033576D0,0.066806D0,0.033576D0,0.066806D0, + &0.0335D0,0.066806D0,2*0D0,0.321369D0,0.016494D0,2*0D0,0.016502D0, + &0.320615D0,2*0D0,0.00001D0,0.000591D0,6*0D0,2*0.108166D0, + &0.108087D0,0D0,0.000001D0,0D0,0.000353D0,0.04359D0,0.795274D0, + &4*0D0,0.000339D0,0.095746D0,0D0,0.060724D0,0.003054D0,0.000919D0, + &64*0D0,0.145835D0,0.113276D0,0.145835D0,0.113271D0,0.145781D0, + &0.049002D0,2*0D0,0.032025D0,0.063642D0,0.032025D0,0.063642D0, + &0.032022D0,0.063642D0,8*0D0,0.251225D0,0.0129D0,0.000006D0,0D0, + &0.0129D0,0.250764D0,0.00038D0,0D0,0.000008D0,0.000465D0, + &0.215418D0,5*0D0,2*0.085312D0,0.08531D0,7*0D0,0.000029D0, + &0.000536D0,5*0D0,0.000074D0,0D0,0.000417D0,0.000015D0,0.000061D0/ + DATA (BRAT(I) ,I= 349, 655)/0.306789D0,0.689189D0,0D0,0.00289D0, + &69*0D0,0.000001D0,0.000072D0,0.001333D0,4*0D0,0.000001D0, + &0.000184D0,0D0,0.003108D0,0.000015D0,0.000003D0,2*0D0,0.995284D0, + &66*0D0,0.000014D0,0.082234D0,2*0D0,0.000013D0,0.003746D0,0D0, + &0.913992D0,18*0D0,3*0.215119D0,0.214724D0,2*0D0,0.06996D0, + &0.069959D0,0D0,2*1D0,2*0.08D0,0.76D0,0.08D0,2*0.105D0,0.04D0, + &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,0.988D0,0.012D0, + &0.998739D0,0.00079D0,0.00038D0,0.000046D0,0.000045D0,2*0.34725D0, + &0.144D0,0.104D0,0.0245D0,2*0.01225D0,0.0028D0,0.0057D0,0.2112D0, + &0.1256D0,2*0.1939D0,2*0.1359D0,0.002D0,0.001D0,0.0006D0, + &0.999877D0,0.000123D0,0.99955D0,0.00045D0,2*0.34725D0,0.144D0, + &0.104D0,0.049D0,0.0028D0,0.0057D0,0.3923D0,0.321D0,0.2317D0, + &0.0478D0,0.0049D0,0.0013D0,0.0003D0,0.0007D0,0.89D0,0.08693D0, + &0.0221D0,0.00083D0,2*0.00007D0,0.564D0,0.282D0,0.072D0,0.028D0, + &0.023D0,2*0.0115D0,0.005D0,0.003D0,0.6861D0,0.3139D0,2*0.5D0, + &0.665D0,0.333D0,0.002D0,0.333D0,0.166D0,0.168D0,0.084D0,0.087D0, + &0.043D0,0.059D0,2*0.029D0,0.002D0,0.6352D0,0.2116D0,0.0559D0, + &0.0173D0,0.0482D0,0.0318D0,0.666D0,0.333D0,0.001D0,0.332D0, + &0.166D0,0.168D0,0.084D0,0.086D0,0.043D0,0.059D0,2*0.029D0, + &2*0.002D0,0.437D0,0.208D0,0.302D0,0.0302D0,0.0212D0,0.0016D0/ + DATA (BRAT(I) ,I= 656, 831)/0.48947D0,0.34D0,3*0.043D0,0.027D0, + &0.0126D0,0.0013D0,0.0003D0,0.00025D0,0.00008D0,0.444D0,2*0.222D0, + &0.104D0,2*0.004D0,0.07D0,0.065D0,2*0.005D0,2*0.011D0,5*0.001D0, + &0.07D0,0.065D0,2*0.005D0,2*0.011D0,5*0.001D0,0.026D0,0.019D0, + &0.066D0,0.041D0,0.045D0,0.076D0,0.0073D0,2*0.0047D0,0.026D0, + &0.001D0,0.0006D0,0.0066D0,0.005D0,2*0.003D0,2*0.0006D0,2*0.001D0, + &0.006D0,0.005D0,0.012D0,0.0057D0,0.067D0,0.008D0,0.0022D0, + &0.027D0,0.004D0,0.019D0,0.012D0,0.002D0,0.009D0,0.0218D0,0.001D0, + &0.022D0,0.087D0,0.001D0,0.0019D0,0.0015D0,0.0028D0,0.683D0, + &0.306D0,0.011D0,0.3D0,0.15D0,0.16D0,0.08D0,0.13D0,0.06D0,0.08D0, + &0.04D0,0.034D0,0.027D0,2*0.002D0,2*0.004D0,2*0.002D0,0.034D0, + &0.027D0,2*0.002D0,2*0.004D0,2*0.002D0,0.0365D0,0.045D0,0.073D0, + &0.062D0,3*0.021D0,0.0061D0,0.015D0,0.025D0,0.0088D0,0.074D0, + &0.0109D0,0.0041D0,0.002D0,0.0035D0,0.0011D0,0.001D0,0.0027D0, + &2*0.0016D0,0.0018D0,0.011D0,0.0063D0,0.0052D0,0.018D0,0.016D0, + &0.0034D0,0.0036D0,0.0009D0,0.0006D0,0.015D0,0.0923D0,0.018D0, + &0.022D0,0.0077D0,0.009D0,0.0075D0,0.024D0,0.0085D0,0.067D0, + &0.0511D0,0.017D0,0.0004D0,0.0028D0,0.619D0,0.381D0,0.3D0,0.15D0, + &0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,0.01D0,2*0.02D0,0.03D0, + &2*0.005D0,2*0.02D0,0.03D0,2*0.005D0,0.015D0,0.037D0,0.028D0/ + DATA (BRAT(I) ,I= 832, 997)/0.079D0,0.095D0,0.052D0,0.0078D0, + &4*0.001D0,0.028D0,0.033D0,0.026D0,0.05D0,0.01D0,4*0.005D0,0.25D0, + &0.0952D0,0.94D0,0.06D0,2*0.4D0,2*0.1D0,1D0,0.0602D0,0.0601D0, + &0.8797D0,0.135D0,0.865D0,0.02D0,0.055D0,2*0.005D0,0.008D0, + &0.012D0,0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,0.01D0,0.03D0, + &0.0035D0,0.011D0,0.0055D0,0.0042D0,0.009D0,0.018D0,0.015D0, + &0.0185D0,0.0135D0,0.025D0,0.0004D0,0.0007D0,0.0008D0,0.0014D0, + &0.0019D0,0.0025D0,0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0, + &1D0,0.3D0,0.15D0,0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0, + &0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,0.02D0,0.055D0, + &2*0.005D0,0.008D0,0.012D0,0.01D0,0.03D0,0.0035D0,0.011D0, + &0.0055D0,0.0042D0,0.009D0,0.018D0,0.015D0,0.0185D0,0.0135D0, + &0.025D0,0.0004D0,0.0007D0,0.0008D0,0.0014D0,0.0019D0,0.0025D0, + &0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,1D0,0.3D0,0.15D0, + &0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,0.02D0,0.055D0, + &2*0.005D0,0.008D0,0.012D0,0.02D0,0.055D0,2*0.005D0,0.008D0, + &0.012D0,0.01D0,0.03D0,0.0035D0,0.011D0,0.0055D0,0.0042D0,0.009D0, + &0.018D0,0.015D0,0.0185D0,0.0135D0,0.025D0,2*0.0002D0,0.0007D0, + &2*0.0004D0,0.0014D0,0.001D0,0.0009D0,0.0025D0,0.4291D0,0.08D0, + &0.07D0,0.02D0,0.015D0,0.005D0,1D0,2*0.3D0,2*0.2D0,0.047D0/ + DATA (BRAT(I) ,I= 998,1188)/0.122D0,0.006D0,0.012D0,0.035D0, + &0.012D0,0.035D0,0.003D0,0.007D0,0.15D0,0.037D0,0.008D0,0.002D0, + &0.05D0,0.015D0,0.003D0,0.001D0,0.014D0,0.042D0,0.014D0,0.042D0, + &0.24D0,0.065D0,0.012D0,0.003D0,0.001D0,0.002D0,0.001D0,0.002D0, + &0.014D0,0.003D0,1D0,2*0.3D0,2*0.2D0,1D0,0.0252D0,0.0248D0, + &0.0267D0,0.015D0,0.045D0,0.015D0,0.045D0,0.7743D0,0.029D0,0.22D0, + &0.78D0,1D0,0.331D0,0.663D0,0.006D0,0.663D0,0.331D0,0.006D0,1D0, + &0.999D0,0.001D0,0.88D0,2*0.06D0,0.639D0,0.358D0,0.002D0,0.001D0, + &1D0,0.88D0,2*0.06D0,0.516D0,0.483D0,0.001D0,0.88D0,2*0.06D0, + &0.9988D0,0.0001D0,0.0006D0,0.0004D0,0.0001D0,0.667D0,0.333D0, + &0.9954D0,0.0011D0,0.0035D0,0.333D0,0.667D0,0.676D0,0.234D0, + &0.085D0,0.005D0,2*1D0,0.018D0,2*0.005D0,0.003D0,0.002D0, + &2*0.006D0,0.018D0,2*0.005D0,0.003D0,0.002D0,2*0.006D0,0.0066D0, + &0.025D0,0.016D0,0.0088D0,2*0.005D0,0.0058D0,0.005D0,0.0055D0, + &4*0.004D0,2*0.002D0,2*0.004D0,0.003D0,0.002D0,2*0.003D0, + &3*0.002D0,2*0.001D0,0.002D0,2*0.001D0,2*0.002D0,0.0013D0, + &0.0018D0,5*0.001D0,4*0.003D0,2*0.005D0,2*0.002D0,2*0.001D0, + &2*0.002D0,2*0.001D0,0.2432D0,0.057D0,2*0.035D0,0.15D0,2*0.075D0, + &0.03D0,2*0.015D0,2*0.08D0,0.76D0,0.08D0,4*1D0,2*0.08D0,0.76D0, + &0.08D0,1D0,2*0.5D0,1D0,2*0.5D0,2*0.08D0,0.76D0,0.08D0,1D0/ + DATA (BRAT(I) ,I=1189,1381)/2*0.08D0,0.76D0,3*0.08D0,0.76D0, + &3*0.08D0,0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0, + &3*0.08D0,0.76D0,0.08D0,2*1D0,2*0.105D0,0.04D0,0.0077D0,0.02D0, + &0.0235D0,0.0285D0,0.0435D0,0.0011D0,0.0022D0,0.0044D0,0.4291D0, + &0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0, + &0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0, + &0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,4*1D0,2*0.105D0,0.04D0, + &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0, + &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,4*1D0,2*0.105D0, + &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,1D0,2*0.105D0, + &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0, + &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0, + &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0, + &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0, + &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0, + &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0, + &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0, + &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0, + &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0, + &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0/ + DATA (BRAT(I) ,I=1382,1582)/0.04D0,0.5D0,0.08D0,0.14D0,0.01D0, + &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0, + &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0, + &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0, + &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0, + &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0, + &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0, + &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0, + &0.015D0,0.005D0,4*1D0,0.52D0,0.26D0,0.11D0,2*0.055D0,0.333D0, + &0.334D0,0.333D0,0.667D0,0.333D0,0.28D0,0.14D0,0.313D0,0.157D0, + &0.11D0,0.667D0,0.333D0,0.28D0,0.14D0,0.313D0,0.157D0,0.11D0, + &0.36D0,0.18D0,0.03D0,2*0.015D0,2*0.2D0,4*0.25D0,0.667D0,0.333D0, + &0.667D0,0.333D0,0.667D0,0.333D0,0.667D0,0.333D0,4*0.5D0,0.007D0, + &0.993D0,1D0,0.667D0,0.333D0,0.667D0,0.333D0,0.667D0,0.333D0, + &0.667D0,0.333D0,8*0.5D0,0.02D0,0.98D0,1D0,4*0.5D0,3*0.146D0, + &3*0.05D0,0.15D0,2*0.05D0,4*0.024D0,0.066D0,0.667D0,0.333D0, + &0.667D0,0.333D0,4*0.25D0,0.667D0,0.333D0,0.667D0,0.333D0,2*0.5D0, + &0.273D0,0.727D0,0.667D0,0.333D0,0.667D0,0.333D0,4*0.5D0,0.35D0, + &0.65D0,2*0.0083D0,0.1866D0,0.324D0,0.184D0,0.027D0,0.001D0, + &0.093D0,0.087D0,0.078D0,0.0028D0,3*0.014D0,0.008D0,0.024D0/ + DATA (BRAT(I) ,I=1583,4150)/0.008D0,0.024D0,0.425D0,0.02D0, + &0.185D0,0.088D0,0.043D0,0.067D0,0.066D0,2404*0D0,0.024396D0, + &0.045285D0,0.83119D0,2*0D0,0.000349D0,0.09878D0,0D0,0.019884D0, + &0.02341D0,0.362776D0,0.550787D0,2*0D0,0.000152D0,0.042991D0, + &0.013695D0,0.025421D0,0.466595D0,2*0D0,0.000196D0,0.055451D0, + &0.438642D0,0.445781D0,0D0,0.554219D0,4*0.00335D0,0.522257D0, + &0.464343D0,6*0D0,1D0,6*0D0,1D0,4*0.013853D0,0.562703D0, + &0.376702D0,0.00518D0,4*0.006254D0,0.974985D0,7*0D0,4*0.148299D0, + &0.015351D0,0D0,0.182109D0,0.167099D0,0.042247D0,0.850973D0, + &0.005411D0,0.045025D0,0.098591D0,0.849898D0,0.021617D0, + &0.030018D0,0.098466D0,0.294448D0,0.10945D0,0.596102D0,0.389906D0, + &0.610094D0,3*0.0633D0,0.063299D0,0.063295D0,0.056281D0,2*0D0, + &6*0.020495D0,2*0D0,0.327919D0,0.04099D0,0.045236D0,0.090112D0, + &0.19874D0,0.010204D0,0.000003D0,0.010205D0,0.198356D0,0.000151D0, + &0.000006D0,0.000367D0,0.081967D0,0.19874D0,0.010204D0,0.000003D0, + &0.010205D0,0.198356D0,0.000151D0,0.000006D0,0.000367D0, + &0.081967D0,4*0D0,0.198776D0,0.010206D0,0.000003D0,0.010207D0, + &0.19839D0,0.000151D0,0.000006D0,0.000367D0,0.081893D0,0.198776D0, + &0.010206D0,0.000003D0,0.010207D0,0.19839D0,0.000151D0,0.000006D0, + &0.000367D0,0.081893D0,4*0D0,0.199344D0,0.010234D0,0.000003D0/ + DATA (BRAT(I) ,I=4151,4281)/0.010236D0,0.198928D0,0.000149D0, + &0.000006D0,0.000368D0,0.080733D0,0.199344D0,0.010234D0, + &0.000003D0,0.010236D0,0.198928D0,0.000149D0,0.000006D0, + &0.000368D0,0.080733D0,4*0D0,0.184738D0,0.104588D0,0.184738D0, + &0.104587D0,0.184731D0,0.09582D0,0.022902D0,0.008429D0,0.015602D0, + &0.022902D0,0.008429D0,0.015602D0,0.022902D0,0.008429D0, + &0.015602D0,0.28959D0,0.01487D0,0.000008D0,0.01487D0,0.289061D0, + &0.000492D0,0.000009D0,0.000536D0,0.27911D0,2*0.037151D0, + &0.03715D0,0.090266D0,2*0.001805D0,0.090266D0,0.001805D0, + &0.812263D0,0.00179D0,0.090428D0,0.001809D0,0.001808D0,0.090428D0, + &0.001808D0,0.81372D0,0D0,6*1D0,0.095602D0,2*0.338272D0, + &0.156896D0,0.019193D0,0.017993D0,0.001168D0,0.001462D0, + &0.009608D0,0.003306D0,0.002132D0,0.003127D0,0.002132D0, + &0.003127D0,0.00213D0,3*0D0,0.001411D0,0.00045D0,0.001411D0, + &0.00045D0,0.001411D0,0.00045D0,2*0D0,0.097996D0,0.399787D0, + &0.262464D0,0.185427D0,0.022683D0,0.007648D0,0.004259D0, + &0.005925D0,0.000304D0,2*0D0,0.000304D0,0.005914D0,0.000002D0, + &2*0D0,0.000011D0,0.001258D0,5*0D0,3*0.002005D0,0D0,0.272178D0, + &0.022112D0,0.255165D0,0.015534D0,2*0.108965D0,0.031557D0, + &0.005562D0,0.044965D0,0.004674D0,0.007637D0,0.020597D0/ + DATA (BRAT(I) ,I=4282,8000)/0.007636D0,0.020595D0,0.007616D0, + &3*0D0,0.017298D0,0.004782D0,0.017298D0,0.004782D0,0.017297D0, + &0.004782D0,2*0D0,0.055332D0,2*0.319757D0,0.121576D0,2*0.001556D0, + &4*0D0,0.0277D0,0.021481D0,0.027699D0,0.021477D0,0.027658D0,3*0D0, + &0.006071D0,0.01208D0,0.006071D0,0.01208D0,0.006069D0,0.01208D0, + &2*0D0,0.035891D0,0.209476D0,0.129084D0,0.286631D0,0.10742D0, + &0.109486D0,4*0D0,0.035282D0,0.001812D0,2*0D0,0.001812D0, + &0.035215D0,0.000021D0,0D0,0.000001D0,0.000065D0,0.011965D0,5*0D0, + &2*0.011947D0,0.011946D0,0D0, + &649*0.D0, +C....UED + &0.001D0,0.999D0,0.001D0,0.999D0,0.001D0,0.999D0, + &0.001D0,0.999D0,0.001D0,0.999D0,0.001D0,0.999D0, + &0.33D0,0.66D0,0.01D0,0.33D0,0.66D0,0.01D0,0.33D0,0.66D0,0.01D0, + &0.33D0,0.66D0,0.01D0,0.98D0,0.D0,0.02D0,0.33D0,0.66D0,0.01D0, + &9*1.D0, + &24*0.0416667, + &1., + &3*0.D0,6*0.08333D0, + &3*0.D0,6*0.08333D0, + &6*0.166667D0, + &2912*0.D0/ + DATA (KFDP(I,1),I= 1, 377)/21,22,23,4*-24,25,21,22,23,4*24,25, + &21,22,23,4*-24,25,21,22,23,4*24,25,21,22,23,4*-24,25,21,22,23, + &4*24,25,37,1000022,1000023,1000025,1000035,1000021,1000039,21,22, + &23,4*-24,25,2*-37,21,22,23,4*24,25,2*37,22,23,-24,25,23,24,-12, + &22,23,-24,25,23,24,-12,-14,48*16,22,23,-24,25,23,24,22,23,-24,25, + &-37,23,24,37,1,2,3,4,5,6,7,8,21,1,2,3,4,5,6,7,8,11,13,15,17,1,2, + &3,4,5,6,7,8,11,12,13,14,15,16,17,18,4*-1,4*-3,4*-5,4*-7,-11,-13, + &-15,-17,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,1000022, + &2*1000023,3*1000025,4*1000035,2*1000024,2*1000037,1000001, + &2000001,1000001,-1000001,1000002,2000002,1000002,-1000002, + &1000003,2000003,1000003,-1000003,1000004,2000004,1000004, + &-1000004,1000005,2000005,1000005,-1000005,1000006,2000006, + &1000006,-1000006,1000011,2000011,1000011,-1000011,1000012, + &2000012,1000012,-1000012,1000013,2000013,1000013,-1000013, + &1000014,2000014,1000014,-1000014,1000015,2000015,1000015, + &-1000015,1000016,2000016,1000016,-1000016,1,2,3,4,5,6,7,8,11,12, + &13,14,15,16,17,18,24,37,2*23,25,35,4*-1,4*-3,4*-5,4*-7,-11,-13, + &-15,-17,3*24,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,23,25,24, + &37,23,25,36,1000022,2*1000023,3*1000025,4*1000035,2*1000024, + &2*1000037,1000001,2000001,1000001,-1000001,1000002,2000002/ + DATA (KFDP(I,1),I= 378, 580)/1000002,-1000002,1000003,2000003, + &1000003,-1000003,1000004,2000004,1000004,-1000004,1000005, + &2000005,1000005,-1000005,1000006,2000006,1000006,-1000006, + &1000011,2000011,1000011,-1000011,1000012,2000012,1000012, + &-1000012,1000013,2000013,1000013,-1000013,1000014,2000014, + &1000014,-1000014,1000015,2000015,1000015,-1000015,1000016, + &2000016,1000016,-1000016,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23, + &24,23,25,24,37,1000022,2*1000023,3*1000025,4*1000035,2*1000024, + &2*1000037,1000001,2000001,1000001,-1000001,1000002,2000002, + &1000002,-1000002,1000003,2000003,1000003,-1000003,1000004, + &2000004,1000004,-1000004,1000005,2000005,1000005,-1000005, + &1000006,2000006,1000006,-1000006,1000011,2000011,1000011, + &-1000011,1000012,2000012,1000012,-1000012,1000013,2000013, + &1000013,-1000013,1000014,2000014,1000014,-1000014,1000015, + &2000015,1000015,-1000015,1000016,2000016,1000016,-1000016,-1,-3, + &-5,-7,-11,-13,-15,-17,24,2*1000022,2*1000023,2*1000025,2*1000035, + &1000006,2000006,1000006,2000006,-1000001,-1000003,-1000011, + &-1000013,-1000015,-2000015,1,2,3,4,5,6,11,13,15,2,82,-11,-13,2*2, + &-12,-14,-16,2*-2,2*-4,-2,-4,2*22,211,111,221,13,11,213,-213,221, + &223,321,130,310,111,331,111,211,-12,12,-14,14,211,111,22,-13,-11/ + DATA (KFDP(I,1),I= 581, 992)/2*211,213,113,221,223,321,211,331, + &22,111,211,2*22,211,22,111,211,22,211,221,111,11,211,111,2*211, + &321,130,310,221,111,211,111,130,310,321,2*311,321,311,323,313, + &323,313,321,3*311,-13,3*211,12,14,311,2*321,311,321,313,323,313, + &323,311,4*321,211,111,3*22,111,321,130,-213,113,213,211,22,111, + &11,13,211,321,130,310,221,211,111,11*-11,11*-13,-311,-313,-311, + &-313,-20313,2*-311,-313,-311,-313,2*111,2*221,2*331,2*113,2*223, + &2*333,-311,-313,2*-321,211,-311,-321,333,-311,-313,-321,211, + &2*-321,2*-311,-321,211,113,421,2*411,421,411,423,413,423,413,421, + &411,8*-11,8*-13,-321,-323,-321,-323,-311,2*-313,-311,-313,2*-311, + &-321,-10323,-321,-323,-321,-311,2*-313,211,111,333,3*-321,-311, + &-313,-321,-313,310,333,211,2*-321,-311,-313,-311,211,-321,3*-311, + &211,113,321,2*421,411,421,413,423,413,423,411,421,-15,5*-11, + &5*-13,221,331,333,221,331,333,10221,211,213,211,213,321,323,321, + &323,2212,221,331,333,221,2*2,2*431,421,411,423,413,82,11,13,82, + &443,82,6*12,6*14,2*16,3*-411,3*-413,2*-411,2*-413,2*441,2*443, + &2*20443,2*2,2*4,2,4,511,521,511,523,513,523,513,521,511,6*12, + &6*14,2*16,3*-421,3*-423,2*-421,2*-423,2*441,2*443,2*20443,2*2, + &2*4,2,4,521,511,521,513,523,513,523,511,521,6*12,6*14,2*16, + &3*-431,3*-433,2*-431,2*-433,3*441,3*443,3*20443,2*2,2*4,2,4,531/ + DATA (KFDP(I,1),I= 993,1402)/521,511,523,513,16,2*4,2*12,2*14, + &2*16,4*2,4*4,2*-11,2*-13,2*-1,2*-3,2*-11,2*-13,2*-1,541,511,521, + &513,523,21,11,13,15,1,2,3,4,21,22,553,21,2112,2212,2*2112,2212, + &2112,2*2212,2112,-12,3122,3212,3112,2212,2*2112,-12,2*3122,3222, + &3112,2212,2112,2212,3122,3222,3212,3122,3112,-12,-14,-12,3322, + &3312,2*3122,3212,3322,3312,3122,3322,3312,-12,2*4122,7*-11,7*-13, + &2*2224,2*2212,2*2214,2*3122,2*3212,2*3214,5*3222,4*3224,2*3322, + &3324,2*2224,7*2212,5*2214,2*2112,2*2114,2*3122,2*3212,2*3214, + &2*3222,2*3224,4*2,3,2*2,1,2*2,-11,-13,2*2,4*4122,-11,-13,2*2, + &3*4132,3*4232,-11,-13,2*2,4332,-11,-13,2*2,-11,-13,2*2,-11,-13, + &2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,2*5122,-12, + &-14,-16,5*4122,441,443,20443,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2, + &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,4*5122,-12,-14,-16,2*-2, + &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,2*5132,2*5232,-12,-14,-16, + &2*-2,2*-4,-2,-4,5332,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16, + &2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2, + &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2, + &-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12, + &-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16, + &2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2/ + DATA (KFDP(I,1),I=1403,1713)/2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2, + &-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12, + &-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,221,223,221, + &223,211,111,321,130,310,213,113,-213,321,311,321,311,323,313, + &2*311,321,311,321,313,323,321,211,111,321,130,310,2*211,313,-313, + &323,-323,421,411,423,413,411,421,413,423,411,421,423,413,443, + &2*82,521,511,523,513,511,521,513,523,521,511,523,513,511,521,513, + &523,553,2*21,213,-213,113,213,10211,10111,-10211,2*221,213,2*113, + &-213,2*321,2*311,113,323,2*313,323,313,-313,323,-323,423,2*413, + &2*423,413,443,82,523,2*513,2*523,2*513,523,553,21,11,13,82,4*443, + &10441,20443,445,441,11,13,15,1,2,3,4,21,22,2*553,10551,20553,555, + &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035, + &1000002,2000002,1000002,2000002,1000021,3*-12,3*-14,3*-16,12,11, + &12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6, + &1000039,1000024,1000037,1000022,1000023,1000025,1000035,1000001, + &2000001,1000001,2000001,1000021,3*-11,3*-13,3*-15,2*-1,-3, + &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035, + &1000004,2000004,1000004,2000004,1000021,3*-12,3*-14,3*-16,12,11, + &12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6, + &1000039,1000024,1000037,1000022,1000023,1000025,1000035,1000003/ + DATA (KFDP(I,1),I=1714,1984)/2000003,1000003,2000003,1000021, + &3*-11,3*-13,3*-15,2*-1,-3,1000039,-1000024,-1000037,1000022, + &1000023,1000025,1000035,1000006,2000006,1000006,2000006,1000021, + &3*-12,3*-14,3*-16,12,11,12,11,12,11,14,13,14,13,14,13,16,15,16, + &15,16,15,2*-2,2*-4,2*-6,1000039,1000024,1000037,1000022,1000023, + &1000025,1000035,1000005,2000005,1000005,2000005,1000021,1000022, + &1000016,-1000015,3*-11,3*-13,3*-15,2*-1,-3,1000039,-1000024, + &-1000037,1000022,1000023,1000025,1000035,1000012,2000012,1000012, + &2*12,2*14,2*16,3*-14,3*-16,3*-2,3*-4,3*-6,1000039,1000024, + &1000037,1000022,1000023,1000025,1000035,1000011,2000011,1000011, + &2000011,3*-13,3*-15,3*-1,3*-3,3*-5,1000039,-1000024,-1000037, + &1000022,1000023,1000025,1000035,1000014,2000014,1000014,2000014, + &2*12,2*14,2*16,3*-12,3*-16,3*-2,3*-4,3*-6,1000039,1000024, + &1000037,1000022,1000023,1000025,1000035,1000013,2000013,1000013, + &2000013,3*-11,3*-15,3*-1,3*-3,3*-5,1000039,-1000024,-1000037, + &1000022,1000023,1000025,1000035,1000016,2000016,1000016,2000016, + &2*12,2*14,2*16,3*-12,3*-14,3*-2,3*-4,3*-6,1000039,1000024, + &1000037,1000022,1000023,1000025,1000035,1000015,2000015,1000015, + &2000015,3*-11,3*-13,3*-1,3*-3,3*-5,1000039,1000001,-1000001, + &2000001,-2000001,1000002,-1000002,2000002,-2000002,1000003/ + DATA (KFDP(I,1),I=1985,2321)/-1000003,2000003,-2000003,1000004, + &-1000004,2000004,-2000004,1000005,-1000005,2000005,-2000005, + &1000006,-1000006,2000006,-2000006,6*1000022,6*1000023,6*1000025, + &6*1000035,1000024,-1000024,1000024,-1000024,1000024,-1000024, + &1000037,-1000037,1000037,-1000037,1000037,-1000037,-12,12,-11,11, + &-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12, + &-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-14,14,-13,13, + &-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14, + &-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-16,16,-15,15, + &-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16, + &-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-2,2,-2,2,-2,2, + &-4,4,-4,4,-4,4,-6,6,-6,6,-6,6,5*1000039,4,1,-12,12,-12,12,-12,12, + &-12,12,-12,12,-12,12,-14,14,-14,14,-14,14,-14,14,-14,14,-14,14, + &-16,16,-16,16,-16,16,-16,16,-16,16,-16,16,-12,12,-11,11,-12,12, + &-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11, + &-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-14,14,-13,13,-14,14, + &-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13, + &-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-16,16,-15,15,-16,16, + &-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15, + &-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-2,2,-2,2,-2,2,-4,4,-4/ + DATA (KFDP(I,1),I=2322,2573)/4,-4,4,-6,6,-6,6,-6,6,5*1000039, + &16*1000022,1000024,-1000024,1000024,-1000024,1000024,-1000024, + &1000024,-1000024,1000024,-1000024,1000024,-1000024,1000037, + &-1000037,1000037,-1000037,1000037,-1000037,1000037,-1000037, + &1000037,-1000037,1000037,-1000037,1000024,-1000024,1000037, + &-1000037,1000001,-1000001,2000001,-2000001,1000002,-1000002, + &2000002,-2000002,1000003,-1000003,2000003,-2000003,1000004, + &-1000004,2000004,-2000004,1000005,-1000005,2000005,-2000005, + &1000006,-1000006,2000006,-2000006,1000011,-1000011,2000011, + &-2000011,1000012,-1000012,2000012,-2000012,1000013,-1000013, + &2000013,-2000013,1000014,-1000014,2000014,-2000014,1000015, + &-1000015,2000015,-2000015,1000016,-1000016,2000016,-2000016, + &5*1000021,-12,12,-12,12,-12,12,-12,12,-12,12,-12,12,-14,14,-14, + &14,-14,14,-14,14,-14,14,-14,14,-16,16,-16,16,-16,16,-16,16,-16, + &16,-16,16,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11, + &11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12, + &12,-11,11,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13, + &13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14, + &14,-13,13,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15, + &15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16/ + DATA (KFDP(I,1),I=2574,2892)/16,-15,15,-2,2,-2,2,-2,2,-4,4,-4,4, + &-4,4,-6,6,-6,6,-6,6,2*1000039,6*1000022,6*1000023,6*1000025, + &6*1000035,1000022,1000023,1000025,1000035,1000002,2000002, + &-1000001,-2000001,1000004,2000004,-1000003,-2000003,1000006, + &2000006,-1000005,-2000005,1000012,2000012,-1000011,-2000011, + &1000014,2000014,-1000013,-2000013,1000016,2000016,-1000015, + &-2000015,2*1000021,-12,12,-11,-12,12,-11,-12,12,-11,-12,12,-11, + &-12,12,-11,-12,12,-11,-14,-13,-14,-13,-14,-13,-14,14,-13,-14,14, + &-13,-14,14,-13,-16,-15,-16,-15,-16,-15,-16,-15,-16,-15,-16,-15, + &-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12, + &-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-14,2*-13,14, + &-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14, + &-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-16,2*-15,16,-16,2*-15,16, + &-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16, + &-16,2*-15,16,-16,2*-15,16,2,-1,2,-1,2*2,-1,2,-1,3*2,-1,2*4,-3, + &3*4,-3,2*6,5*1000039,16*1000022,16*1000023,1000024,-1000024, + &1000024,-1000024,1000024,-1000024,1000024,-1000024,1000024, + &-1000024,1000024,-1000024,1000037,-1000037,1000037,-1000037, + &1000037,-1000037,1000037,-1000037,1000037,-1000037,1000037, + &-1000037,1000024,-1000024,1000037,-1000037,1000001,-1000001/ + DATA (KFDP(I,1),I=2893,3182)/2000001,-2000001,1000002,-1000002, + &2000002,-2000002,1000003,-1000003,2000003,-2000003,1000004, + &-1000004,2000004,-2000004,1000005,-1000005,2000005,-2000005, + &1000006,-1000006,2000006,-2000006,1000011,-1000011,2000011, + &-2000011,1000012,-1000012,2000012,-2000012,1000013,-1000013, + &2000013,-2000013,1000014,-1000014,2000014,-2000014,1000015, + &-1000015,2000015,-2000015,1000016,-1000016,2000016,-2000016, + &5*1000021,-12,12,-12,12,-12,12,-12,12,-12,12,-12,12,-14,14,-14, + &14,-14,14,-14,14,-14,14,-14,14,-16,16,-16,16,-16,16,-16,16,-16, + &16,-16,16,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11, + &11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12, + &12,-11,11,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13, + &13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14, + &14,-13,13,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15, + &15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16, + &16,-15,15,-2,2,-2,2,-2,2,-4,4,-4,4,-4,4,-6,6,-6,6,-6,6,5*1000039, + &16*1000022,16*1000023,16*1000025,1000024,-1000024,1000024, + &-1000024,1000024,-1000024,1000024,-1000024,1000024,-1000024, + &1000024,-1000024,1000037,-1000037,1000037,-1000037,1000037, + &-1000037,1000037,-1000037,1000037,-1000037,1000037,-1000037/ + DATA (KFDP(I,1),I=3183,3459)/1000024,-1000024,1000037,-1000037, + &1000001,-1000001,2000001,-2000001,1000002,-1000002,2000002, + &-2000002,1000003,-1000003,2000003,-2000003,1000004,-1000004, + &2000004,-2000004,1000005,-1000005,2000005,-2000005,1000006, + &-1000006,2000006,-2000006,1000011,-1000011,2000011,-2000011, + &1000012,-1000012,2000012,-2000012,1000013,-1000013,2000013, + &-2000013,1000014,-1000014,2000014,-2000014,1000015,-1000015, + &2000015,-2000015,1000016,-1000016,2000016,-2000016,5*1000021,-12, + &12,-12,12,-12,12,-12,12,-12,12,-12,12,-14,14,-14,14,-14,14,-14, + &14,-14,14,-14,14,-16,16,-16,16,-16,16,-16,16,-16,16,-16,16,-12, + &12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11, + &11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-14, + &14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13, + &13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-16, + &16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15, + &15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-2,2, + &-2,2,-2,2,-4,4,-4,4,-4,4,-6,6,-6,6,-6,6,2*1000039,15*1000024, + &6*1000022,6*1000023,6*1000025,6*1000035,1000022,1000023,1000025, + &1000035,1000002,2000002,-1000001,-2000001,1000004,2000004, + &-1000003,-2000003,1000006,2000006,-1000005,-2000005,1000012/ + DATA (KFDP(I,1),I=3460,3782)/2000012,-1000011,-2000011,1000014, + &2000014,-1000013,-2000013,1000016,2000016,-1000015,-2000015, + &2*1000021,-12,12,-11,-12,12,-11,-12,12,-11,-12,12,-11,-12,12,-11, + &-12,12,-11,-14,14,-13,-14,14,-13,-14,14,-13,-14,14,-13,-14,14, + &-13,-14,14,-13,-16,16,-15,-16,16,-15,-16,16,-15,-16,16,-15,-16, + &16,-15,-16,16,-15,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12, + &2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12, + &2*-11,12,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14, + &2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-16, + &2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16, + &2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,2,-1,2,-1,2*2,-1, + &2,-1,3*2,-1,2*4,-3,3*4,-3,2*6,1000039,-1000024,-1000037,1000022, + &1000023,1000025,1000035,4*1000001,1000002,2000002,1000002, + &2000002,1000021,3*-12,3*-14,3*-16,12,11,12,11,12,11,14,13,14,13, + &14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,1000039,1000024,1000037, + &1000022,1000023,1000025,1000035,4*1000002,1000001,2000001, + &1000001,2000001,1000021,3*-11,3*-13,3*-15,2*-1,-3,1000039, + &-1000024,-1000037,1000022,1000023,1000025,1000035,4*1000003, + &1000004,2000004,1000004,2000004,1000021,3*-12,3*-14,3*-16,12,11, + &12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6/ + DATA (KFDP(I,1),I=3783,4156)/1000039,1000024,1000037,1000022, + &1000023,1000025,1000035,4*1000004,1000003,2000003,1000003, + &2000003,1000021,3*-11,3*-13,3*-15,2*-1,-3,1000039,-1000024, + &-1000037,1000022,1000023,1000025,1000035,4*1000005,1000006, + &2000006,1000006,2000006,1000021,3*-12,3*-14,3*-16,12,11,12,11,12, + &11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,1000039, + &1000024,1000037,1000022,1000023,1000025,1000035,4*1000006, + &1000005,2000005,1000005,2000005,1000021,3*-11,3*-13,3*-15,2*-1, + &-3,1000039,-1000024,-1000037,1000022,1000023,1000025,1000035, + &4*1000011,1000012,2000012,1000012,2000012,2*12,2*14,2*16,3*-14, + &3*-16,3*-2,3*-4,3*-6,1000039,-1000024,-1000037,1000022,1000023, + &1000025,1000035,4*1000013,1000014,2000014,1000014,2000014,2*12, + &2*14,2*16,3*-12,3*-16,3*-2,3*-4,3*-6,1000039,-1000024,-1000037, + &1000022,1000023,1000025,1000035,4*1000015,1000016,2000016, + &1000016,2000016,2*12,2*14,2*16,3*-12,3*-14,3*-2,3*-4,3*-6,3,4,5, + &6,11,13,15,21,2*4,2,4,24,-11,-13,-15,3,4,5,6,11,13,15,21,5,6,21, + &1,2,3,4,5,6,1,2,3,4,5,6,21,1,2,3,4,5,6,21,1,2,3,4,5,6,21,1,2,3,4, + &5,6,1,2,3,4,5,6,1,2,3,4,5,6,21,3100111,3200111,21,22,23,-24,21, + &22,23,24,22,23,-24,23,24,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,18, + &21,22,23,24,9*11,9*-11,11,-11,11,-11,9*13,9*-13,13,-13,13,-13, + &9*15/ + DATA (KFDP(I,1),I=4157,8000)/9*-15,15,-15,15,-15,1,2,3,4,5,6,11, + &12,9900012,13,14,9900014,15,16,9900016,3*-1,3*-3,3*-5,-11,-13,-15, + &3*-11,2*-13,-15,24,3*-11,2*-13,-15,9900024,3*443,3*553,2*24, + &2*3000211,2*22,2*23,22,23,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17, + &18,2*24,3*3000211,2*24,4*-1,4*-3,4*-5,4*-7,-11,-13,-15,-17,22,23, + &22,23,24,3000211,24,3000211,22,23,1,2,3,4,5,6,7,8,11,12,13,14,15, + &16,17,18,2*24,-24,23,2*22,24,-24,2*23,1,2,3,4,5,6,7,8,11,12,13, + &14,15,16,17,18,2*22,23,2*24,23,22,2*24,23,4*-1,4*-3,4*-5,4*-7, + &-11,-13,-15,-17, + &649*0, +C...UED + &5100023,5100022,5100023,5100022,5100023,5100022, + &5100023,5100022,5100023,5100022,5100023,5100022, + &5100023,-5100024,5100022,5100023,5100024,5100022, + &5100023,-5100024,5100022,5100023,5100024,5100022, + &5100023,-5100024,5100022,5100023,5100024,5100022, + &9*5100022, + &6100001,6100002,6100003,6100004,6100005,6100006, + &5100001,5100002,5100003,5100004,5100005,5100006, + &-6100001,-6100002,-6100003,-6100004,-6100005,-6100006, + &-5100001,-5100002,-5100003,-5100004,-5100005,-5100006, + &39, + &6100011,6100013,6100015, + &5100011,5100013,5100015, + %5100012,5100014,5100016, + &-6100011,-6100013,-6100015, + &-5100011,-5100013,-5100015, + %-5100012,-5100014,-5100016, + &-5100011,-5100013,-5100015, + &5100012,5100014,5100016, + &2912*0/ + DATA (KFDP(I,2),I= 1, 339)/3*1,2,4,6,8,1,3*2,1,3,5,7,2,3*3,2,4, + &6,8,3,3*4,1,3,5,7,4,3*5,2,4,6,8,5,3*6,1,3,5,7,6,5,6*1000006,3*7, + &2,4,6,8,7,4,6,3*8,1,3,5,7,8,5,7,2*11,12,11,12,2*11,2*13,14,13,14, + &13,11,13,-211,-213,-211,-213,-211,-213,-211,-213,2*-211,-321, + &-323,-321,2*-323,3*-321,4*-211,-213,-211,-213,-211,-213,-211, + &-213,-211,-213,3*-211,-213,4*-211,-323,-321,2*-211,2*-321,3*-211, + &2*15,16,15,16,15,2*17,18,17,2*18,2*17,-1,-2,-3,-4,-5,-6,-7,-8,21, + &-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,-1,-2,-3,-4,-5,-6,-7,-8, + &-11,-12,-13,-14,-15,-16,-17,-18,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8, + &12,14,16,18,-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,2*23, + &-24,2*1000022,1000023,1000022,1000023,1000025,1000022,1000023, + &1000025,1000035,-1000024,-1000037,-1000024,-1000037,-1000001, + &2*-2000001,2000001,-1000002,2*-2000002,2000002,-1000003, + &2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005, + &2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011, + &2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013, + &2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015, + &2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6, + &-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,-24,-37,22,25,2*36,2,4,6,8, + &2,4,6,8,2,4,6,8,2,4,6,8,12,14,16,18,23,22,25,-1,-2,-3,-4,-5,-6/ + DATA (KFDP(I,2),I= 340, 533)/-7,-8,-11,-13,-15,-17,21,22,2*23, + &-24,2*25,-37,-24,3*36,2*1000022,1000023,1000022,1000023,1000025, + &1000022,1000023,1000025,1000035,-1000024,-1000037,-1000024, + &-1000037,-1000001,2*-2000001,2000001,-1000002,2*-2000002,2000002, + &-1000003,2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005, + &2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011, + &2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013, + &2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015, + &2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6, + &-7,-8,-11,-13,-15,-17,21,22,2*23,-24,2*25,-37,-24,2*1000022, + &1000023,1000022,1000023,1000025,1000022,1000023,1000025,1000035, + &-1000024,-1000037,-1000024,-1000037,-1000001,2*-2000001,2000001, + &-1000002,2*-2000002,2000002,-1000003,2*-2000003,2000003,-1000004, + &2*-2000004,2000004,-1000005,2*-2000005,2000005,-1000006, + &2*-2000006,2000006,-1000011,2*-2000011,2000011,-1000012, + &2*-2000012,2000012,-1000013,2*-2000013,2000013,-1000014, + &2*-2000014,2000014,-1000015,2*-2000015,2000015,-1000016, + &2*-2000016,2000016,2,4,6,8,12,14,16,18,25,1000024,1000037, + &1000024,1000037,1000024,1000037,1000024,1000037,2*-1000005, + &2*-2000005,1000002,1000004,1000012,1000014,2*1000016,-3,-4,-5,-6/ + DATA (KFDP(I,2),I= 534, 938)/-7,-8,-13,-15,-17,11,-82,12,14,-1, + &-3,11,13,15,1,4,3,4,1,3,22,11,-211,2*22,-13,-11,-211,211,111,211, + &-321,130,310,22,2*111,-211,11,-11,13,-13,-211,111,22,14,12,111, + &22,111,3*211,-311,22,211,22,111,-211,211,11,-211,13,22,-211,111, + &-211,22,111,-11,-211,111,2*-211,-321,130,310,221,111,-211,111, + &2*0,-211,111,22,-211,111,-211,111,-211,211,-213,113,223,221,14, + &111,211,111,-11,-13,211,111,22,211,111,211,111,2*211,213,113,223, + &221,22,-211,111,113,223,22,111,-321,310,211,111,2*-211,221,22, + &-11,-13,-211,-321,130,310,221,-211,111,11*12,11*14,2*211,2*213, + &211,20213,2*321,2*323,211,213,211,213,211,213,211,213,211,213, + &211,213,3*211,213,211,2*321,8*211,2*113,3*211,111,22,211,111,211, + &111,4*211,8*12,8*14,2*211,2*213,2*111,221,2*113,223,333,20213, + &211,2*321,323,2*311,313,-211,111,113,2*211,321,2*211,311,321,310, + &211,-211,4*211,321,4*211,113,2*211,-321,111,22,-211,111,-211,111, + &-211,211,-211,211,16,5*12,5*14,3*211,3*213,211,2*111,2*113, + &2*-311,2*-313,-2112,3*321,323,2*-1,22,111,321,311,321,311,-82, + &-11,-13,-82,22,-82,6*-11,6*-13,2*-15,211,213,20213,211,213,20213, + &431,433,431,433,311,313,311,313,311,313,-1,-4,-3,-4,-1,-3,22, + &-211,111,-211,111,-211,211,-211,211,6*-11,6*-13,2*-15,211,213, + &20213,211,213,20213,431,433,431,433,321,323,321,323,321,323,-1/ + DATA (KFDP(I,2),I= 939,1352)/-4,-3,-4,-1,-3,22,211,111,211,111, + &4*211,6*-11,6*-13,2*-15,211,213,20213,211,213,20213,431,433,431, + &433,221,331,333,221,331,333,221,331,333,-1,-4,-3,-4,-1,-3,22, + &-321,-311,-321,-311,-15,-3,-1,2*-11,2*-13,2*-15,-1,-4,-3,-4,-3, + &-4,-1,-4,2*12,2*14,2,3,2,3,2*12,2*14,2,1,22,411,421,411,421,21, + &-11,-13,-15,-1,-2,-3,-4,2*21,22,21,2*-211,111,22,111,211,22,211, + &-211,11,2*-211,111,-211,111,22,11,22,111,-211,211,111,211,22,211, + &111,211,-211,22,11,13,11,-211,2*111,2*22,111,211,-321,-211,111, + &11,2*-211,7*12,7*14,-321,-323,-311,-313,-311,-313,211,213,211, + &213,211,213,111,221,331,113,223,111,221,113,223,321,323,321,-211, + &-213,111,221,331,113,223,333,10221,111,221,331,113,223,211,213, + &211,213,321,323,321,323,321,323,311,313,311,313,2*-1,-3,-1,2203, + &3201,3203,2203,2101,2103,12,14,-1,-3,2*111,2*211,12,14,-1,-3,22, + &111,2*22,111,22,12,14,-1,-3,22,12,14,-1,-3,12,14,-1,-3,12,14,-1, + &-3,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,2*-211,11,13, + &15,-211,-213,-20213,-431,-433,3*3122,1,4,3,4,1,3,11,13,15,1,4,3, + &4,1,3,11,13,15,1,4,3,4,1,3,2*111,2*211,11,13,15,1,4,3,4,1,3,11, + &13,15,1,4,3,4,1,3,4*22,11,13,15,1,4,3,4,1,3,22,11,13,15,1,4,3,4, + &1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1, + &3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3/ + DATA (KFDP(I,2),I=1353,1815)/11,13,15,1,4,3,4,1,3,11,13,15,1,4,3, + &4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4, + &1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1, + &3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3, + &2*111,2*211,-211,111,-321,130,310,-211,111,211,-211,111,-213,113, + &-211,111,223,211,111,213,113,211,111,223,-211,111,-321,130,310, + &2*-211,-311,311,-321,321,211,111,211,111,-211,111,-211,111,311, + &2*321,311,22,2*-82,-211,111,-211,111,211,111,211,111,-321,-311, + &-321,-311,411,421,411,421,22,2*21,-211,2*211,111,-211,111,2*211, + &111,-211,211,111,211,-321,2*-311,-321,22,-211,111,211,111,-311, + &311,-321,321,211,111,-211,111,321,311,22,-82,-211,111,211,111, + &-321,-311,411,421,22,21,-11,-13,-82,211,111,221,111,4*22,-11,-13, + &-15,-1,-2,-3,-4,2*21,211,111,3*22,1,2*2,4*1,2*-24,2*-37,2*1,3,5, + &1,3,5,1,3,5,1,2,3,4,5,6,1,2,3,4,5,6,1,2,3,4,5,6,-3,-5,-3,-5,-3, + &-5,2,2*1,4*2,2*24,2*37,2,1,3,5,1,3,5,1,3,5,-3,2*-5,3,2*4,4*3, + &2*-24,2*-37,3,1,3,5,1,3,5,1,3,5,1,2,3,4,5,6,1,2,3,4,5,6,1,2,3,4, + &5,6,-1,-5,-1,-5,-1,-5,4,2*3,4*4,2*24,2*37,4,1,3,5,1,3,5,1,3,5,-3, + &2*-5,5,2*6,4*5,2*-24,2*-37,5,1,3,5,1,3,5,1,3,5,1,2,3,4,5,6,1,2,3, + &4,5,6,1,2,3,4,5,6,-1,-3,-1,-3,-1,-3,6,2*5,4*6,2*24,2*37,6,4,-15, + &16,1,3,5,1,3,5,1,3,5,-3,2*-5,11,2*12,4*11,2*-24,-37,13,15,11,15/ + DATA (KFDP(I,2),I=1816,2317)/11,13,11,13,15,11,13,15,1,3,5,1,3,5, + &1,3,5,12,2*11,4*12,2*24,2*37,11,13,15,11,13,15,1,3,5,1,3,5,1,3,5, + &13,2*14,4*13,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,13,15,1,3, + &5,1,3,5,1,3,5,14,2*13,4*14,2*24,2*37,11,13,15,11,13,15,1,3,5,1,3, + &5,1,3,5,15,2*16,4*15,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11, + &13,15,1,3,5,1,3,5,1,3,5,16,2*15,4*16,2*24,2*37,11,13,15,11,13,15, + &1,3,5,1,3,5,1,3,5,21,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,-4,4,-5, + &5,-5,5,-6,6,-6,6,1,3,5,2,4,6,1,3,5,2,4,6,1,3,5,2,4,6,1,3,5,2,4,6, + &1,-1,3,-3,5,-5,1,-1,3,-3,5,-5,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3, + &-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-2,2, + &-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5, + &-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4, + &-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-1,1,-3,3,-1,1,-1,1, + &-3,3,-1,1,-1,1,-3,3,22,23,25,35,36,-1,-3,-13,13,-13,13,-13,13, + &-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,-15,15,-15,15,-15,15, + &-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,-2,2,-1,1,-2,2,-1, + &1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6, + &6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5, + &5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4, + &4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-1,1,-3/ + DATA (KFDP(I,2),I=2318,2770)/3,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,22, + &23,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,-24,24,11, + &-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,13,-13,15,-15,1,-1,3, + &-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,-4,4,-5,5,-5, + &5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,-13,13,-14,14,-14, + &14,-15,15,-15,15,-16,16,-16,16,1,3,5,2,4,-13,13,-13,13,-13,13, + &-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,-15,15,-15,15,-15,15, + &-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,-2,2,-1,1,-2,2,-1, + &1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6, + &6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5, + &5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4, + &4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-1,1,-3, + &3,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,24,37,24,-11,-13,-15,-1,-3,24, + &-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,4*37, + &2*-1,2*2,2*-3,2*4,2*-5,2*6,2*-11,2*12,2*-13,2*14,2*-15,2*16,-1, + &-3,-13,14,2*-13,14,2*-13,14,-13,-15,16,2*-15,16,2*-15,16,-15, + &6*-11,-15,16,2*-15,16,2*-15,16,-15,6*-11,6*-13,-1,-2,-1,2,-1,-2, + &-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5, + &-6,-5,6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4, + &-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,-1,-2,-1/ + DATA (KFDP(I,2),I=2771,3221)/2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4, + &-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,2,-1,2,-1, + &2*4,-3,4,-3,3*6,-5,2*4,-3,3*6,-5,2*6,22,23,25,35,36,22,23,11,13, + &15,12,14,16,1,3,5,2,4,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4, + &25,35,36,-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,13, + &-13,15,-15,1,-1,3,-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3, + &-4,4,-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13, + &-13,13,-14,14,-14,14,-15,15,-15,15,-16,16,-16,16,1,3,5,2,4,-13, + &13,-13,13,-13,13,-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,-15, + &15,-15,15,-15,15,-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1, + &-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6, + &-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3, + &-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,2, + &-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5, + &-6,6,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,22,23,25,35,36, + &22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,22,23,11,13,15,12,14, + &16,1,3,5,2,4,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36, + &-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,13,-13,15, + &-15,1,-1,3,-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4, + &-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,-13/ + DATA (KFDP(I,2),I=3222,3669)/13,-14,14,-14,14,-15,15,-15,15,-16, + &16,-16,16,1,3,5,2,4,-13,13,-13,13,-13,13,-15,15,-15,15,-15,15, + &-11,11,-11,11,-11,11,-15,15,-15,15,-15,15,-11,11,-11,11,-11,11, + &-13,13,-13,13,-13,13,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3, + &3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2, + &2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5, + &5,-6,6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4, + &4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,-1, + &1,-1,1,-3,3,24,37,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,24,-11, + &-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11, + &-13,-15,-1,-3,4*37,2*-1,2*2,2*-3,2*4,2*-5,2*6,2*-11,2*12,2*-13, + &2*14,2*-15,2*16,-1,-3,-13,14,2*-13,14,2*-13,14,-13,-15,16,2*-15, + &16,2*-15,16,-15,-11,12,2*-11,12,2*-11,12,-11,-15,16,2*-15,16, + &2*-15,16,-15,-11,12,2*-11,12,2*-11,12,-11,-13,14,2*-13,14,2*-13, + &14,-13,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3, + &-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,2, + &-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5, + &6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4, + &-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,2,-1,2,-1,2*4, + &-3,4,-3,3*6,-5,2*4,-3,3*6,-5,2*6,1,2*2,4*1,23,25,35,36,2*-24/ + DATA (KFDP(I,2),I=3670,4183)/2*-37,2*1,3,5,1,3,5,1,3,5,1,2,3,4,5, + &6,1,2,3,4,5,6,1,2,3,4,5,6,-3,-5,-3,-5,-3,-5,2,2*1,4*2,23,25,35, + &36,2*24,2*37,2,1,3,5,1,3,5,1,3,5,-3,2*-5,3,2*4,4*3,23,25,35,36, + &2*-24,2*-37,3,1,3,5,1,3,5,1,3,5,1,2,3,4,5,6,1,2,3,4,5,6,1,2,3,4, + &5,6,-1,-5,-1,-5,-1,-5,4,2*3,4*4,23,25,35,36,2*24,2*37,4,1,3,5,1, + &3,5,1,3,5,-3,2*-5,5,2*6,4*5,23,25,35,36,2*-24,2*-37,5,1,3,5,1,3, + &5,1,3,5,1,2,3,4,5,6,1,2,3,4,5,6,1,2,3,4,5,6,-1,-3,-1,-3,-1,-3,6, + &2*5,4*6,23,25,35,36,2*24,2*37,6,1,3,5,1,3,5,1,3,5,-3,2*-5,11, + &2*12,4*11,23,25,35,36,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11, + &13,15,1,3,5,1,3,5,1,3,5,13,2*14,4*13,23,25,35,36,2*-24,2*-37,13, + &15,11,15,11,13,11,13,15,11,13,15,1,3,5,1,3,5,1,3,5,15,2*16,4*15, + &23,25,35,36,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,13,15,1,3, + &5,1,3,5,1,3,5,-3,-4,-5,-6,-11,-13,-15,21,-1,-3,2*-5,5,12,14,16, + &-3,-4,-5,-6,-11,-13,-15,21,-5,-6,21,-1,-2,-3,-4,-5,-6,-1,-2,-3, + &-4,-5,-6,21,-1,-2,-3,-4,-5,-6,21,-1,-2,-3,-4,-5,-6,21,-1,-2,-3, + &-4,-5,-6,-1,-2,-3,-4,-5,-6,-1,-2,-3,-4,-5,-6,3*21,3*1,4*2,1,2*11, + &2*12,11,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,-18, + &21,22,23,-24,3*-1,3*-3,3*-5,3*1,3*3,3*5,-13,13,-15,15,3*-1,3*-3, + &3*-5,3*1,3*3,3*5,-11,11,-15,15,3*-1,3*-3,3*-5,3*1,3*3,3*5,-11,11, + &-13,13,-1,-2,-3,-4,-5,-6,-11,-12,9900012,-13,-14,9900014,-15,-16/ + DATA (KFDP(I,2),I=4184,8000)/9900016,2,4,6,2,4,6,2,4,6,9900012, + &9900014,9900016,-11,-13,-15,-13,2*-15,24,-11,-13,-15,-13,2*-15, + &9900024,6*21,-24,-3000211,-24,-3000211,3000111,3000221,3000111, + &3000221,2*23,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17, + &-18,23,3000111,23,3000111,22,3000221,22,2,4,6,8,2,4,6,8,2,4,6,8, + &2,4,6,8,12,14,16,18,2*3000111,2*3000221,-3000211,2*-24,-3000211, + &2*23,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,-24, + &-3000211,3000211,3000221,3000113,3000223,-3000213,3000213, + &3000113,3000223,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16, + &-17,-18,24,3000211,24,3000111,3000221,3000211,3000213,3000113, + &3000223,3000213,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8,12,14,16,18, + &649*0, +C...UED + &1,1,2,2,3,3,4,4,5,5,6,6, + &1,2,1,2,1,2,3,4,3,4,3,4,5,6,5,6,5,6, + &11,13,15,12,11,14,13,16,15, + &-1,-2,-3,-4,-5,-6,-1,-2,-3,-4,-5,-6, + &1,2,3,4,5,6,1,2,3,4,5,6, + &22, + &-11,-13,-15,-11,-13,-15,-12,-14,-16, + &11,13,15,11,13,15,12,14,16, + &12,14,16,-11,-13,-15, + &2912*0/ + DATA (KFDP(I,3),I= 1,1021)/81*0,14,6*0,2*16,2*0,6*111,310,130, + &2*0,3*111,310,130,321,113,211,223,221,2*113,2*211,2*223,2*221, + &2*113,221,2*113,2*213,-213,113,2*111,310,130,310,130,2*310,130, + &402*0,4*3,4*4,1,4,3,2*2,0,-11,8*0,-211,5*0,2*111,211,-211,211, + &-211,10*0,111,4*0,2*111,-211,-11,11,-13,22,111,3*0,22,3*0,111, + &211,4*0,111,11*0,111,-211,6*0,-211,3*111,7*0,111,-211,5*0,2*221, + &3*0,111,5*0,111,11*0,-311,-313,-311,-321,-313,-323,111,221,331, + &113,223,-311,-313,-311,-321,-313,-323,111,221,331,113,223,22*0, + &111,113,2*211,-211,-311,211,111,3*211,-211,7*211,7*0,111,-211, + &111,-211,-321,-323,-311,-321,-313,-323,-211,-213,-321,-323,-311, + &-321,-313,-323,-211,-213,22*0,111,113,-311,2*-211,211,-211,310, + &-211,2*111,211,2*-211,-321,-211,2*211,-211,111,-211,2*211,6*0, + &111,-211,111,-211,0,221,331,333,321,311,221,331,333,321,311,20*0, + &3,13*0,-411,-413,-10413,-10411,-20413,-415,-411,-413,-10413, + &-10411,-20413,-415,-411,-413,16*0,-4,-1,-4,-3,2*-2,5*0,111,-211, + &111,-211,-421,-423,-10423,-10421,-20423,-425,-421,-423,-10423, + &-10421,-20423,-425,-421,-423,16*0,-4,-1,-4,-3,2*-2,5*0,111,-211, + &111,-211,-431,-433,-10433,-10431,-20433,-435,-431,-433,-10433, + &-10431,-20433,-435,-431,-433,19*0,-4,-1,-4,-3,2*-2,8*0,441,443, + &441,443,441,443,-4,-1,-4,-3,-4,-3,-4,-1,531,533,531,533,3,2,3,2/ + DATA (KFDP(I,3),I=1022,2223)/511,513,511,513,1,2,13*0,2*21,11*0, + &2112,6*0,2212,12*0,2*3122,3212,10*0,3322,2*0,3122,3212,3214,2112, + &2114,2212,2112,3122,3212,3214,2112,2114,2212,2112,52*0,3*3,1,6*0, + &4*3,4*0,4*3,6*0,4*3,0,28*3,2*0,3*4122,8*0,4,1,4,3,2*2,4*4,1,4,3, + &2*2,4*4,1,4,3,2*2,4*0,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*0,4*4,1,4,3, + &2*2,0,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2, + &4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4, + &3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2, + &4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4, + &3,2*2,31*0,211,111,45*0,-211,2*111,-211,3*111,-211,111,211,30*0, + &-211,111,13*0,2*21,-211,111,199*0,2*5,210*0,-1,-3,-5,-2,-4,-6,-1, + &-3,-5,-2,-4,-6,-1,-3,-5,-2,-4,-6,-1,-3,-5,-2,-4,-6,-2,2,-4,4,-6, + &6,-2,2,-4,4,-6,6,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3, + &-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5, + &-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5, + &-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1, + &-1,1,-1,3,-3,3,-3,5,-5,5,-5,-3,3,-5,5,-5,5,-3,3,-5,5,-5,5,-3,3, + &-5,5,-5,5,5*0,11,12,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11, + &-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11, + &-11,13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3/ + DATA (KFDP(I,3),I=2224,2783)/-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5, + &-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5, + &-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1, + &-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,-3,3, + &-5,5,-5,5,-3,3,-5,5,-5,5,-3,3,-5,5,-5,5,7*0,-11,-13,-15,-12,-14, + &-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16,-2,2,-4,4,2*0,-12,12, + &-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,11,-11,13,-13,15,-15, + &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15, + &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5, + &-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5, + &-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1, + &-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1, + &-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,-3,3,-5,5, + &-5,5,-3,3,-5,5,-5,5,-3,3,-5,5,-5,5,3*0,12,14,16,2,4,0,12,14,16,2, + &4,0,12,14,16,2,4,0,12,14,16,2,4,28*0,2,4,12,-11,11,14,-13,13,16, + &-15,15,12,-11,11,14,-13,13,16,-15,15,12,11,14,13,16,15,12,-11,11, + &14,-13,13,16,-15,15,12,11,14,13,16,15,12,11,14,13,16,15,2*2,1,-1, + &2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3, + &2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5, + &2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1/ + DATA (KFDP(I,3),I=2784,3354)/2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3, + &2*6,5,-5,3,-3,5,-5,1,3,-3,5,-5,1,3,5,-5,1,5,-5,1,3,5,-5,1,3,7*0, + &-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-11,-13,-15,-12,-14, + &-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16,-2,2,-4,4,2*0,-12,12, + &-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,11,-11,13,-13,15,-15, + &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15, + &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5, + &-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5, + &-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1, + &-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1, + &-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,-3,3,-5,5, + &-5,5,-3,3,-5,5,-5,5,-3,3,-5,5,-5,5,7*0,-11,-13,-15,-12,-14,-16, + &-1,-3,-5,-2,-4,5*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0, + &-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16, + &-2,2,-4,4,2*0,-12,12,-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4, + &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15, + &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,1, + &-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1, + &-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3, + &-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3/ + DATA (KFDP(I,3),I=3355,8000)/-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5, + &-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,-3,3,-5,5,-5,5,-3,3,-5,5, + &-5,5,-3,3,-5,5,-5,5,3*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4, + &4*0,12,14,16,2,4,0,12,14,16,2,4,0,12,14,16,2,4,0,12,14,16,2,4, + &28*0,2,4,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16, + &-15,15,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,-15, + &15,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,-15,15, + &2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1, + &2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3, + &2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5, + &2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,3,-3,5,-5, + &1,3,-3,5,-5,1,3,5,-5,1,5,-5,1,3,5,-5,1,3,351*0,-5,95*0,2,4,6,2,4, + &6,2,4,6,-2,-4,-6,-2,-4,-6,-2,-4,-6,2*9900014,2*9900016,2,4,6,2,4, + &6,2,4,6,-2,-4,-6,-2,-4,-6,-2,-4,-6,2*9900012,2*9900016,2,4,6,2,4, + &6,2,4,6,-2,-4,-6,-2,-4,-6,-2,-4,-6,2*9900012,2*9900014,3831*0/ + DATA (KFDP(I,4),I= 1,8000)/94*0,4*111,6*0,111,2*0,-211,0,-211, + &3*0,111,2*-211,0,111,0,2*111,113,221,2*111,-213,-211,211,113, + &6*111,310,2*130,402*0,13*81,41*0,-11,10*0,111,-211,4*0,111,62*0, + &111,211,111,211,7*0,111,211,111,211,35*0,2*-211,2*111,211,111, + &-211,2*211,2*-211,13*0,-211,111,-211,111,4*0,-211,111,-211,111, + &34*0,111,-211,3*111,3*-211,2*111,3*-211,14*0,-321,-311,3*0,-321, + &-311,20*0,-3,43*0,6*1,39*0,6*2,42*0,6*3,14*0,8*4,4*0,4*-5,4*0, + &2*-5,67*0,-211,111,5*0,-211,111,52*0,2101,2103,2*2101,6*0,4*81, + &4*0,4*81,6*0,4*81,0,28*81,13*0,6*2101,18*81,4*0,18*81,4*0,9*81,0, + &162*81,31*0,-211,111,6516*0/ + DATA (KFDP(I,5),I= 1,8000)/96*0,2*111,17*0,111,7*0,2*111,0, + &3*111,0,111,597*0,-211,2*111,-211,111,-211,111,65*0,111,-211, + &3*111,-211,111,7193*0/ + +C...PYDAT4, with particle names (character strings). + DATA (CHAF(I,1),I= 1, 202)/'d','u','s','c','b','t','b''','t''', + &2*' ','e-','nu_e','mu-','nu_mu','tau-','nu_tau','tau''-', + &'nu''_tau',2*' ','g','gamma','Z0','W+','h0',6*' ','Z''0','Z"0', + &'W''+','H0','A0','H+',' ','Graviton',' ','R0','LQ_ue',38*' ', + &'specflav','rndmflav','phasespa','c-hadron','b-hadron',2*' ', + &'junction',' ','system','cluster','string','indep.','CMshower', + &'SPHEaxis','THRUaxis','CLUSjet','CELLjet','table',' ','reggeon', + &'pi0','rho0','a_20','K_L0','pi+','rho+','a_2+','eta','omega', + &'f_2','K_S0','K0','K*0','K*_20','K+','K*+','K*_2+','eta''','phi', + &'f''_2','D+','D*+','D*_2+','D0','D*0','D*_20','D_s+','D*_s+', + &'D*_2s+','eta_c','J/psi','chi_2c','B0','B*0','B*_20','B+','B*+', + &'B*_2+','B_s0','B*_s0','B*_2s0','B_c+','B*_c+','B*_2c+','eta_b', + &'Upsilon','chi_2b','pomeron','dd_1','Delta-','ud_0','ud_1','n0', + &'Delta0','uu_1','p+','Delta+','Delta++','sd_0','sd_1','Sigma-', + &'Sigma*-','Lambda0','su_0','su_1','Sigma0','Sigma*0','Sigma+', + &'Sigma*+','ss_1','Xi-','Xi*-','Xi0','Xi*0','Omega-','cd_0', + &'cd_1','Sigma_c0','Sigma*_c0','Lambda_c+','Xi_c0','cu_0','cu_1', + &'Sigma_c+','Sigma*_c+','Sigma_c++','Sigma*_c++','Xi_c+','cs_0', + &'cs_1','Xi''_c0','Xi*_c0','Xi''_c+','Xi*_c+','Omega_c0', + &'Omega*_c0','cc_1','Xi_cc+','Xi*_cc+','Xi_cc++','Xi*_cc++'/ + DATA (CHAF(I,1),I= 203, 332)/'Omega_cc+','Omega*_cc+', + &'Omega*_ccc++','bd_0','bd_1','Sigma_b-','Sigma*_b-','Lambda_b0', + &'Xi_b-','Xi_bc0','bu_0','bu_1','Sigma_b0','Sigma*_b0','Sigma_b+', + &'Sigma*_b+','Xi_b0','Xi_bc+','bs_0','bs_1','Xi''_b-','Xi*_b-', + &'Xi''_b0','Xi*_b0','Omega_b-','Omega*_b-','Omega_bc0','bc_0', + &'bc_1','Xi''_bc0','Xi*_bc0','Xi''_bc+','Xi*_bc+','Omega''_bc0', + &'Omega*_bc0','Omega_bcc+','Omega*_bcc+','bb_1','Xi_bb-', + &'Xi*_bb-','Xi_bb0','Xi*_bb0','Omega_bb-','Omega*_bb-', + &'Omega_bbc0','Omega*_bbc0','Omega*_bbb-','a_00','b_10','a_0+', + &'b_1+','f_0','h_1','K*_00','K_10','K*_0+','K_1+','f''_0','h''_1', + &'D*_0+','D_1+','D*_00','D_10','D*_0s+','D_1s+','chi_0c','h_1c', + &'B*_00','B_10','B*_0+','B_1+','B*_0s0','B_1s0','B*_0c+','B_1c+', + &'chi_0b','h_1b','a_10','a_1+','f_1','K*_10','K*_1+','f''_1', + &'D*_1+','D*_10','D*_1s+','chi_1c','B*_10','B*_1+','B*_1s0', + &'B*_1c+','chi_1b','psi''','Upsilon''','~d_L','~u_L','~s_L', + &'~c_L','~b_1','~t_1','~e_L-','~nu_eL','~mu_L-','~nu_muL', + &'~tau_1-','~nu_tauL','~g','~chi_10','~chi_20','~chi_1+', + &'~chi_30','~chi_40','~chi_2+','~Gravitino','~d_R','~u_R','~s_R', + &'~c_R','~b_2','~t_2','~e_R-','~nu_eR','~mu_R-','~nu_muR', + &'~tau_2-','~nu_tauR','pi_tc0','pi_tc+','pi''_tc0','eta_tc0'/ + DATA (CHAF(I,1),I= 333, 500)/'rho_tc0','rho_tc+','omega_tc', + &'V8_tc','pi_22_1_tc','pi_22_8_tc','rho_11_tc','rho_12_tc', + &'rho_21_tc','rho_22_tc','d*','u*','e*-','nu*_e0','Graviton*', + &'nu_Re','nu_Rmu','nu_Rtau','Z_R0','W_R+','H_L++','H_R++', + &'rho_diff0','pi_diffr+','omega_di','phi_diff','J/psi_di', + &'n_diffr0','p_diffr+','cc~[3S18]','cc~[1S08]','cc~[3P08]', + &'bb~[3S18]','bb~[1S08]','bb~[3P08]','a_tc0','a_tc+', + &81*' ', +C...UED + &'d*_S','u*_S','s*_S','c*_S','b*_S','t*_S', + &'d*_D','u*_D','s*_D','c*_D','b*_D','t*_D', + &'e*_S-','mu*_S-','tau*_S-', + &'nu*_eD','e*_D-','nu*_muD','mu*_D-','nu*_tauD','tau*_D-', + &'g*','gamma*','Z*0','W*+',25*' '/ + DATA (CHAF(I,2),I= 1, 205)/'dbar','ubar','sbar','cbar','bbar', + &'tbar','b''bar','t''bar',2*' ','e+','nu_ebar','mu+','nu_mubar', + &'tau+','nu_taubar','tau''+','nu''_taubar',5*' ','W-',9*' ', + &'W''-',2*' ','H-',3*' ','Rbar0','LQ_uebar',39*' ','rndmflavbar', + &' ','c-hadronbar','b-hadronbar',20*' ','pi-','rho-','a_2-',4*' ', + &'Kbar0','K*bar0','K*_2bar0','K-','K*-','K*_2-',3*' ','D-','D*-', + &'D*_2-','Dbar0','D*bar0','D*_2bar0','D_s-','D*_s-','D*_2s-', + &3*' ','Bbar0','B*bar0','B*_2bar0','B-','B*-','B*_2-','B_sbar0', + &'B*_sbar0','B*_2sbar0','B_c-','B*_c-','B*_2c-',4*' ','dd_1bar', + &'Deltabar+','ud_0bar','ud_1bar','nbar0','Deltabar0','uu_1bar', + &'pbar-','Deltabar-','Deltabar--','sd_0bar','sd_1bar','Sigmabar+', + &'Sigma*bar+','Lambdabar0','su_0bar','su_1bar','Sigmabar0', + &'Sigma*bar0','Sigmabar-','Sigma*bar-','ss_1bar','Xibar+', + &'Xi*bar+','Xibar0','Xi*bar0','Omegabar+','cd_0bar','cd_1bar', + &'Sigma_cbar0','Sigma*_cbar0','Lambda_cbar-','Xi_cbar0','cu_0bar', + &'cu_1bar','Sigma_cbar-','Sigma*_cbar-','Sigma_cbar--', + &'Sigma*_cbar--','Xi_cbar-','cs_0bar','cs_1bar','Xi''_cbar0', + &'Xi*_cbar0','Xi''_cbar-','Xi*_cbar-','Omega_cbar0', + &'Omega*_cbar0','cc_1bar','Xi_ccbar-','Xi*_ccbar-','Xi_ccbar--', + &'Xi*_ccbar--','Omega_ccbar-','Omega*_ccbar-','Omega*_cccbar-'/ + DATA (CHAF(I,2),I= 206, 325)/'bd_0bar','bd_1bar','Sigma_bbar+', + &'Sigma*_bbar+','Lambda_bbar0','Xi_bbar+','Xi_bcbar0','bu_0bar', + &'bu_1bar','Sigma_bbar0','Sigma*_bbar0','Sigma_bbar-', + &'Sigma*_bbar-','Xi_bbar0','Xi_bcbar-','bs_0bar','bs_1bar', + &'Xi''_bbar+','Xi*_bbar+','Xi''_bbar0','Xi*_bbar0','Omega_bbar+', + &'Omega*_bbar+','Omega_bcbar0','bc_0bar','bc_1bar','Xi''_bcbar0', + &'Xi*_bcbar0','Xi''_bcbar-','Xi*_bcbar-','Omega''_bcba', + &'Omega*_bcbar0','Omega_bccbar-','Omega*_bccbar-','bb_1bar', + &'Xi_bbbar+','Xi*_bbbar+','Xi_bbbar0','Xi*_bbbar0','Omega_bbbar+', + &'Omega*_bbbar+','Omega_bbcbar0','Omega*_bbcbar0', + &'Omega*_bbbbar+',2*' ','a_0-','b_1-',2*' ','K*_0bar0','K_1bar0', + &'K*_0-','K_1-',2*' ','D*_0-','D_1-','D*_0bar0','D_1bar0', + &'D*_0s-','D_1s-',2*' ','B*_0bar0','B_1bar0','B*_0-','B_1-', + &'B*_0sbar0','B_1sbar0','B*_0c-','B_1c-',3*' ','a_1-',' ', + &'K*_1bar0','K*_1-',' ','D*_1-','D*_1bar0','D*_1s-',' ', + &'B*_1bar0','B*_1-','B*_1sbar0','B*_1c-',3*' ','~d_Lbar', + &'~u_Lbar','~s_Lbar','~c_Lbar','~b_1bar','~t_1bar','~e_L+', + &'~nu_eLbar','~mu_L+','~nu_muLbar','~tau_1+','~nu_tauLbar',3*' ', + &'~chi_1-',2*' ','~chi_2-',' ','~d_Rbar','~u_Rbar','~s_Rbar', + &'~c_Rbar','~b_2bar','~t_2bar','~e_R+','~nu_eRbar','~mu_R+'/ + DATA (CHAF(I,2),I= 326, 500)/'~nu_muRbar','~tau_2+', + &'~nu_tauRbar',' ','pi_tc-',3*' ','rho_tc-',8*' ','d*bar','u*bar', + &'e*bar+','nu*_ebar0',5*' ','W_R-','H_L--','H_R--',' ', + &'pi_diffr-',3*' ','n_diffrbar0','p_diffrbar-',7*' ','a_tc-', + &81*' ', +C...UED + &'d*_Sbar','u*_Sbar','s*_Sbar','c*_Sbar','b*_Sbar','t*_Sbar', + &'d*_Dbar','u*_Dbar','s*_Dbar','c*_Dbar','b*_Dbar','t*_Dbar', + &'e*_Sbar+','mu*_Sbar+','tau*_Sbar+', + &'nu*_eDbar','e*_Dbar+', + &'nu*_muDbar','mu*_Dbar+', + &'nu*_tauDbar','tau*_Dbar+', + &'g*','gamma*','Z*0','W*-',25*' '/ + +C...PYDATR, with initial values for the random number generator. + DATA MRPY/19780503,0,0,97,33,0/ + +C...Default values for allowed processes and kinematics constraints. + DATA MSEL/1/ + DATA MSUB/500*0/ + DATA ((KFIN(I,J),J=-40,40),I=1,2)/16*0,4*1,4*0,6*1,5*0,5*1,0, + &5*1,5*0,6*1,4*0,4*1,16*0,16*0,4*1,4*0,6*1,5*0,5*1,0,5*1,5*0, + &6*1,4*0,4*1,16*0/ + DATA CKIN/ + & 2.0D0, -1.0D0, 0.0D0, -1.0D0, 1.0D0, + & 1.0D0, -10D0, 10D0, -40D0, 40D0, + 1 -40D0, 40D0, -40D0, 40D0, -40D0, + 1 40D0, -1.0D0, 1.0D0, -1.0D0, 1.0D0, + 2 0.0D0, 1.0D0, 0.0D0, 1.0D0, -1.0D0, + 2 1.0D0, -1.0D0, 1.0D0, 0D0, 0D0, + 3 2.0D0, -1.0D0, 0D0, 0D0, 0.0D0, + 3 -1.0D0, 0.0D0, -1.0D0, 4.0D0, -1.0D0, + 4 12.0D0, -1.0D0, 12.0D0, -1.0D0, 12.0D0, + 4 -1.0D0, 12.0D0, -1.0D0, 0D0, 0D0, + 5 0.0D0, -1.0D0, 0.0D0, -1.0D0, 0.0D0, + 5 -1.0D0, 0D0, 0D0, 0D0, 0D0, + 6 0.0001D0, 0.99D0, 0.0001D0, 0.99D0, 0D0, + 6 -1D0, 0D0, -1D0, 0D0, -1D0, + 7 0D0, -1D0, 0.0001D0, 0.99D0, 0.0001D0, + 7 0.99D0, 2D0, -1D0, 0D0, 0D0, + 8 120*0D0/ + +C...Default values for main switches and parameters. Reset information. + DATA (MSTP(I),I=1,100)/ + & 3, 1, 2, 0, 0, 0, 0, 0, 0, 0, + 1 1, 0, 1, 30, 0, 1, 4, 3, 4, 3, + 2 1, 0, 1, 0, 0, 0, 0, 0, 0, 1, + 3 1, 8, 0, 1, 0, 2, 1, 5, 2, 0, + 4 2, 1, 3, 7, 3, 1, 1, 0, 1, 0, + 5 7, 1, 3, 1, 5, 1, 1, 5, 1, 7, + 6 2, 3, 2, 2, 1, 5, 2, 3, 0, 0, + 7 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, + 8 1, 4, 100, 1, 1, 2, 4, 1, 1, 0, + 9 1, 3, 1, 3, 1, 0, 0, 0, 0, 0/ + DATA (MSTP(I),I=101,200)/ + & 3, 1, 0, 0, 0, 0, 0, 0, 0, 0, + 1 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, + 2 0, 1, 2, 1, 1, 100, 0, 0, 10, 0, + 3 0, 4, 0, 1, 0, 0, 0, 0, 0, 0, + 4 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, + 5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 7 0, 2, 0, 0, 0, 0, 0, 0, 0, 0, + 8 6, 425, 2011, 03, 23, 0, 0, 0, 0, 0, + 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/ + DATA (PARP(I),I=1,100)/ + & 0.25D0, 10D0, 8*0D0, + 1 0D0, 0D0, 1.0D0, 0.01D0, 0.5D0, 1.0D0, 1.0D0, 0.4D0, 2*0D0, + 2 10*0D0, + 3 1.5D0,2.0D0,0.075D0,1.0D0,0.2D0,0D0,1.0D0,0.70D0,0.006D0,0D0, + 4 0.02D0,2.0D0,0.10D0,1000D0,2054D0,123D0,246D0,50D0,0D0,0.054D0, + 5 10*0D0, + 6 0.25D0, 1.0D0,0.25D0, 1.0D0, 2.0D0,1D-3, 4.0D0,1D-3,2*0D0, + 7 4.0D0, 0.25D0, 5*0D0, 0.025D0, 2.0D0, 0.1D0, + 8 1.90D0, 2.0D0, 0.5D0, 0.4D0, 0.90D0, + 8 0.95D0, 0.7D0, 0.5D0, 1800D0, 0.25D0, + 9 2.0D0,0.40D0,5.0D0,1.0D0,0.0D0,3.0D0,1.0D0,0.75D0,1.0D0,5.0D0/ + DATA (PARP(I),I=101,200)/ + & 0.5D0, 0.28D0, 1.0D0, 0.8D0, 0D0, 0D0, 0D0, 0D0, 0D0, 1D0, + 1 2.0D0, 3*0D0, 1.5D0, 0.5D0, 0.6D0, 2.5D0, 2.0D0, 1.0D0, + 2 1.0D0, 0.4D0, 8*0D0, + 3 0.01D0, 9*0D0, + 4 1.16D0, 0.0119D0, 0.01D0, 0.01D0, 0.05D0, + 4 9.28D0, 0.15D0, 0.02D0, 0.48D0, 0.09D0, + 5 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, + 6 2.20D0, 23.6D0, 18.4D0, 11.5D0, 0.5D0, 0D0, 0D0, 0D0, 2*0D0, + 7 0D0, 0D0, 0D0, 1.0D0, 6*0D0, + 8 0.1D0, 0.01D0, 0.01D0, 0.01D0, 0.1D0, 0.01D0, 0.01D0, 0.01D0, + 8 0.3D0, 0.64D0, + 9 0.64D0, 5.0D0, 1.0D4, 1.0D4, 6*0D0/ + DATA MSTI/200*0/ + DATA PARI/200*0D0/ + DATA MINT/400*0/ + DATA VINT/400*0D0/ + +C...Constants for the generation of the various processes. + DATA (ISET(I),I=1,100)/ + & 1, 1, 1, -1, 3, -1, -1, 3, -2, 2, + 1 2, 2, 2, 2, 2, 2, -1, 2, 2, 2, + 2 -1, 2, 2, 2, 2, 2, -1, 2, 2, 2, + 3 2, 2, 2, 2, 2, 2, -1, -1, -1, -1, + 4 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + 5 -1, -1, 2, 2, -1, -1, -1, 2, -1, -1, + 6 -1, -1, -1, -1, -1, -1, -1, 2, 2, 2, + 7 4, 4, 4, -1, -1, 4, 4, -1, -1, 2, + 8 2, 2, 2, 2, 2, 2, 2, 2, 2, -2, + 9 0, 0, 0, 0, 0, 9, -2, -2, 8, -2/ + DATA (ISET(I),I=101,200)/ + & -1, 1, 1, 1, 1, 2, 2, 2, -2, 2, + 1 2, 2, 2, 2, 2, -1, -1, -1, -2, -2, + 2 5, 5, 5, 5, -2, -2, -2, -2, -2, -2, + 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 4 1, 1, 1, 1, 1, 1, 1, 1, 1, -2, + 5 1, 1, 1, -2, -2, 1, 1, 1, -2, -2, + 6 2, 2, 2, 2, 2, 2, 2, 2, 2, -2, + 7 2, 2, 5, 5, -2, 2, 2, 5, 5, -2, + 8 5, 5, 2, 2, 2, 5, 5, 2, 2, 2, + 9 1, 1, 1, 2, 2, -2, -2, -2, -2, -2/ + DATA (ISET(I),I=201,300)/ + & 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 1 2, 2, 2, 2, -2, 2, 2, 2, 2, 2, + 2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 4 2, 2, 2, 2, -1, 2, 2, 2, 2, 2, + 5 2, 2, 2, 2, -1, 2, -1, 2, 2, -2, + 6 2, 2, 2, 2, 2, -1, -1, -1, -1, -1, + 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 8 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 9 2, 2, 2, 2, 2, 2, 2, 2, 2, 2/ + DATA (ISET(I),I=301,500)/ + & 2, 9*-2, 9*2, 21*-2, + 4 1, 1, 2, 2, 2, 2, 2, 2, 2, 2, + 5 5, 5, 1, 1, -1, -1, -1, -1, -1, -1, + 6 2, 2, 2, 2, 2, 2, 2, 2, -1, 2, + 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 8 2, 2, 2, 2, 2, 2, 2, 2, -2, -2, + 9 1, 1, 2, 2, 2, 5*-2, + & 5, 5, 18*-2, + 2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 21*-2, + 6 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 7 2, 2, 2, 2, 2, 2, 2, 2, 2, -2, + 8 2, 2, 18*-2/ + DATA ((KFPR(I,J),J=1,2),I=1,50)/ + & 23, 0, 24, 0, 25, 0, 24, 0, 25, 0, + & 24, 0, 23, 0, 25, 0, 0, 0, 0, 0, + 1 0, 0, 0, 0, 21, 21, 21, 22, 21, 23, + 1 21, 24, 21, 25, 22, 22, 22, 23, 22, 24, + 2 22, 25, 23, 23, 23, 24, 23, 25, 24, 24, + 2 24, 25, 25, 25, 0, 21, 0, 22, 0, 23, + 3 0, 24, 0, 25, 0, 21, 0, 22, 0, 23, + 3 0, 24, 0, 25, 0, 21, 0, 22, 0, 23, + 4 0, 24, 0, 25, 0, 21, 0, 22, 0, 23, + 4 0, 24, 0, 25, 0, 21, 0, 22, 0, 23/ + DATA ((KFPR(I,J),J=1,2),I=51,100)/ + 5 0, 24, 0, 25, 0, 0, 0, 0, 0, 0, + 5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 6 0, 0, 0, 0, 21, 21, 24, 24, 23, 24, + 7 23, 23, 24, 24, 23, 24, 23, 25, 22, 22, + 7 23, 23, 24, 24, 24, 25, 25, 25, 0, 211, + 8 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 8 443, 21,10441, 21,20443, 21, 445, 21, 0, 0, + 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/ + DATA ((KFPR(I,J),J=1,2),I=101,150)/ + & 23, 0, 25, 0, 25, 0,10441, 0, 445, 0, + & 443, 22, 443, 21, 443, 22, 0, 0, 22, 25, + 1 21, 25, 0, 25, 21, 25, 22, 22, 21, 22, + 1 22, 23, 23, 23, 24, 24, 0, 0, 0, 0, + 2 25, 6, 25, 6, 25, 0, 25, 0, 0, 0, + 2 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 3 0, 21, 0, 21, 0, 22, 0, 22, 0, 0, + 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 4 32, 0, 34, 0, 37, 0, 41, 0, 42, 0, + 4 4000011, 0, 4000001, 0, 4000002, 0, 3000331, 0, 0, 0/ + DATA ((KFPR(I,J),J=1,2),I=151,200)/ + 5 35, 0, 35, 0, 35, 0, 0, 0, 0, 0, + 5 36, 0, 36, 0, 36, 0, 0, 0, 0, 0, + 6 6, 37, 42, 0, 42, 42, 42, 42, 11, 0, + 6 11, 0, 0, 4000001, 0, 4000002, 0, 4000011, 0, 0, + 7 23, 35, 24, 35, 35, 0, 35, 0, 0, 0, + 7 23, 36, 24, 36, 36, 0, 36, 0, 0, 0, + 8 35, 6, 35, 6, 21, 35, 0, 35, 21, 35, + 8 36, 6, 36, 6, 21, 36, 0, 36, 21, 36, + 9 3000113, 0, 3000213, 0, 3000223, 0, 11, 0, 11, 0, + 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/ + DATA ((KFPR(I,J),J=1,2),I=201,240)/ + & 1000011, 1000011, 2000011, 2000011, 1000011, + & 2000011, 1000013, 1000013, 2000013, 2000013, + & 1000013, 2000013, 1000015, 1000015, 2000015, + & 2000015, 1000015, 2000015, 1000011, 1000012, + 1 1000015, 1000016, 2000015, 1000016, 1000012, + 1 1000012, 1000016, 1000016, 0, 0, + 1 1000022, 1000022, 1000023, 1000023, 1000025, + 1 1000025, 1000035, 1000035, 1000022, 1000023, + 2 1000022, 1000025, 1000022, 1000035, 1000023, + 2 1000025, 1000023, 1000035, 1000025, 1000035, + 2 1000024, 1000024, 1000037, 1000037, 1000024, + 2 1000037, 1000022, 1000024, 1000023, 1000024, + 3 1000025, 1000024, 1000035, 1000024, 1000022, + 3 1000037, 1000023, 1000037, 1000025, 1000037, + 3 1000035, 1000037, 1000021, 1000022, 1000021, + 3 1000023, 1000021, 1000025, 1000021, 1000035/ + DATA ((KFPR(I,J),J=1,2),I=241,280)/ + 4 1000021, 1000024, 1000021, 1000037, 1000021, + 4 1000021, 1000021, 1000021, 0, 0, + 4 1000002, 1000022, 2000002, 1000022, 1000002, + 4 1000023, 2000002, 1000023, 1000002, 1000025, + 5 2000002, 1000025, 1000002, 1000035, 2000002, + 5 1000035, 1000001, 1000024, 2000005, 1000024, + 5 1000001, 1000037, 2000005, 1000037, 1000002, + 5 1000021, 2000002, 1000021, 0, 0, + 6 1000006, 1000006, 2000006, 2000006, 1000006, + 6 2000006, 1000006, 1000006, 2000006, 2000006, + 6 0, 0, 0, 0, 0, + 6 0, 0, 0, 0, 0, + 7 1000002, 1000002, 2000002, 2000002, 1000002, + 7 2000002, 1000002, 1000002, 2000002, 2000002, + 7 1000002, 2000002, 1000002, 1000002, 2000002, + 7 2000002, 1000002, 1000002, 2000002, 2000002/ + DATA ((KFPR(I,J),J=1,2),I=281,350)/ + 8 1000005, 1000002, 2000005, 2000002, 1000005, + 8 2000002, 1000005, 1000002, 2000005, 2000002, + 8 1000005, 2000002, 1000005, 1000005, 2000005, + 8 2000005, 1000005, 1000005, 2000005, 2000005, + 9 1000005, 1000005, 2000005, 2000005, 1000005, + 9 2000005, 1000005, 1000021, 2000005, 1000021, + 9 1000005, 2000005, 37, 25, 37, + 9 35, 36, 25, 36, 35, + & 37, 37, 18*0, +C...UED: 311-319 + & 5100021, 5100021, + & 5100002, 5100021, + & 5100002, 5100001, + & 5100002, -5100002, + & 5100002, -5100002, + & 5100002, -6100001, + & 5100002, -5100001, + & 5100002, 6100001, + & 5100001, -5100001, + & 42*0, + 4 9900041, 0, 9900042, 0, 9900041, + 4 11, 9900042, 11, 9900041, 13, + 4 9900042, 13, 9900041, 15, 9900042, + 4 15, 9900041, 9900041, 9900042, 9900042/ + DATA ((KFPR(I,J),J=1,2),I=351,400)/ + 5 9900041, 0, 9900042, 0, 9900023, + 5 0, 9900024, 0, 0, 0, + 5 0, 0, 0, 0, 0, + 5 0, 0, 0, 0, 0, + 6 24, 24, 24, 3000211, 3000211, + 6 3000211, 22, 3000111, 22, 3000221, + 6 23, 3000111, 23, 3000221, 24, + 6 3000211, 0, 0, 24, 23, + 7 24, 3000111, 3000211, 23, 3000211, + 7 3000111, 22, 3000211, 23, 3000211, + 7 24, 3000111, 24, 3000221, 22, + 7 24, 22, 23, 23, 23, + 8 0, 0, 0, 0, 21, 21, 0, 21, 0, 0, + 8 21, 21, 0, 0, 0, 0, 0, 0, 0, 0, + 9 5000039, 0, 5000039, 0, 21, + 9 5000039, 0, 5000039, 21, 5000039, + 9 10*0/ + DATA ((KFPR(I,J),J=1,2),I=401,500)/ + & 37, 6, 37, 6, 36*0, + 2 443, 21, 9900443, 21, 9900441, + 2 21, 9910441, 21, 0, 9900443, + 2 0, 9900441, 0, 9910441, 21, + 2 9900443, 21, 9900441, 21, 9910441, + 3 10441, 21, 20443, 21, 445, 21, 0, 10441, 0, 20443, + 3 0, 445, 21, 10441, 21, 20443, 21, 445, 42*0, + 6 553, 21, 9900553, 21, 9900551, + 6 21, 9910551, 21, 0, 9900553, + 6 0, 9900551, 0, 9910551, 21, + 6 9900553, 21, 9900551, 21, 9910551, + 7 10551, 21, 20553, 21, 555, 21, 0, 10551, 0, 20553, + 7 0, 555, 21, 10551, 21, 20553, 21, 555, 42*0/ + DATA COEF/10000*0D0/ + DATA (((ICOL(I,J,K),K=1,2),J=1,4),I=1,40)/ + &4,0,3,0,2,0,1,0,3,0,4,0,1,0,2,0,2,0,0,1,4,0,0,3,3,0,0,4,1,0,0,2, + &3,0,0,4,1,4,3,2,4,0,0,3,4,2,1,3,2,0,4,1,4,0,2,3,4,0,3,4,2,0,1,2, + &3,2,1,0,1,4,3,0,4,3,3,0,2,1,1,0,3,2,1,4,1,0,0,2,2,4,3,1,2,0,0,1, + &3,2,1,4,1,4,3,2,4,2,1,3,4,2,1,3,3,4,4,3,1,2,2,1,2,0,3,1,2,0,0,0, + &4,2,1,0,0,0,1,0,3,0,0,3,1,2,0,0,4,0,0,4,0,0,1,2,2,0,0,1,4,4,3,3, + &2,2,1,1,4,4,3,3,3,3,4,4,1,1,2,2,3,2,1,3,1,2,0,0,4,2,1,4,0,0,1,2, + &4,0,0,0,4,0,1,3,0,0,3,0,2,4,3,0,3,4,0,0,1,0,0,1,0,0,3,4,2,0,0,2, + &3,0,0,0,1,0,0,0,0,0,3,0,2,0,0,0,2,0,3,1,2,0,0,0,3,2,1,0,1,0,0,0, + &4,4,3,3,2,2,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + &0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/ + +C...Treatment of resonances. + DATA (MWID(I) ,I= 1, 500)/5*0,3*1,8*0,1,5*0,3*1,6*0,1,0,4*1, + &3*0,2*1,254*0,19*2,0,7*2,0,2,0,2,0,26*1,7*0,6*2,2*1, + &81*0,21*1,4*1,25*0/ + +C...Character constants: name of processes. + DATA PROC(0)/ 'All included subprocesses '/ + DATA (PROC(I),I=1,20)/ + &'f + fbar -> gamma*/Z0 ', 'f + fbar'' -> W+/- ', + &'f + fbar -> h0 ', 'gamma + W+/- -> W+/- ', + &'Z0 + Z0 -> h0 ', 'Z0 + W+/- -> W+/- ', + &' ', 'W+ + W- -> h0 ', + &' ', 'f + f'' -> f + f'' (QFD) ', + 1'f + f'' -> f + f'' (QCD) ','f + fbar -> f'' + fbar'' ', + 1'f + fbar -> g + g ', 'f + fbar -> g + gamma ', + 1'f + fbar -> g + Z0 ', 'f + fbar'' -> g + W+/- ', + 1'f + fbar -> g + h0 ', 'f + fbar -> gamma + gamma ', + 1'f + fbar -> gamma + Z0 ', 'f + fbar'' -> gamma + W+/- '/ + DATA (PROC(I),I=21,40)/ + 2'f + fbar -> gamma + h0 ', 'f + fbar -> Z0 + Z0 ', + 2'f + fbar'' -> Z0 + W+/- ', 'f + fbar -> Z0 + h0 ', + 2'f + fbar -> W+ + W- ', 'f + fbar'' -> W+/- + h0 ', + 2'f + fbar -> h0 + h0 ', 'f + g -> f + g ', + 2'f + g -> f + gamma ', 'f + g -> f + Z0 ', + 3'f + g -> f'' + W+/- ', 'f + g -> f + h0 ', + 3'f + gamma -> f + g ', 'f + gamma -> f + gamma ', + 3'f + gamma -> f + Z0 ', 'f + gamma -> f'' + W+/- ', + 3'f + gamma -> f + h0 ', 'f + Z0 -> f + g ', + 3'f + Z0 -> f + gamma ', 'f + Z0 -> f + Z0 '/ + DATA (PROC(I),I=41,60)/ + 4'f + Z0 -> f'' + W+/- ', 'f + Z0 -> f + h0 ', + 4'f + W+/- -> f'' + g ', 'f + W+/- -> f'' + gamma ', + 4'f + W+/- -> f'' + Z0 ', 'f + W+/- -> f'' + W+/- ', + 4'f + W+/- -> f'' + h0 ', 'f + h0 -> f + g ', + 4'f + h0 -> f + gamma ', 'f + h0 -> f + Z0 ', + 5'f + h0 -> f'' + W+/- ', 'f + h0 -> f + h0 ', + 5'g + g -> f + fbar ', 'g + gamma -> f + fbar ', + 5'g + Z0 -> f + fbar ', 'g + W+/- -> f + fbar'' ', + 5'g + h0 -> f + fbar ', 'gamma + gamma -> f + fbar ', + 5'gamma + Z0 -> f + fbar ', 'gamma + W+/- -> f + fbar'' '/ + DATA (PROC(I),I=61,80)/ + 6'gamma + h0 -> f + fbar ', 'Z0 + Z0 -> f + fbar ', + 6'Z0 + W+/- -> f + fbar'' ', 'Z0 + h0 -> f + fbar ', + 6'W+ + W- -> f + fbar ', 'W+/- + h0 -> f + fbar'' ', + 6'h0 + h0 -> f + fbar ', 'g + g -> g + g ', + 6'gamma + gamma -> W+ + W- ', 'gamma + W+/- -> Z0 + W+/- ', + 7'Z0 + Z0 -> Z0 + Z0 ', 'Z0 + Z0 -> W+ + W- ', + 7'Z0 + W+/- -> Z0 + W+/- ', 'Z0 + Z0 -> Z0 + h0 ', + 7'W+ + W- -> gamma + gamma ', 'W+ + W- -> Z0 + Z0 ', + 7'W+/- + W+/- -> W+/- + W+/- ', 'W+/- + h0 -> W+/- + h0 ', + 7'h0 + h0 -> h0 + h0 ', 'q + gamma -> q'' + pi+/- '/ + DATA (PROC(I),I=81,100)/ + 8'q + qbar -> Q + Qbar, mass ', 'g + g -> Q + Qbar, massive ', + 8'f + q -> f'' + Q, massive ', 'g + gamma -> Q + Qbar, mass ', + 8'gamma + gamma -> F + Fbar, m', 'g + g -> J/Psi + g ', + 8'g + g -> chi_0c + g ', 'g + g -> chi_1c + g ', + 8'g + g -> chi_2c + g ', ' ', + 9'Elastic scattering ', 'Single diffractive (XB) ', + 9'Single diffractive (AX) ', 'Double diffractive ', + 9'Low-pT scattering ', 'Semihard QCD 2 -> 2 ', + 9' ', ' ', + 9'q + gamma* -> q ', ' '/ + DATA (PROC(I),I=101,120)/ + &'g + g -> gamma*/Z0 ', 'g + g -> h0 ', + &'gamma + gamma -> h0 ', 'g + g -> chi_0c ', + &'g + g -> chi_2c ', 'g + g -> J/Psi + gamma ', + &'gamma + g -> J/Psi + g ', 'gamma+gamma -> J/Psi + gamma', + &' ', 'f + fbar -> gamma + h0 ', + 1'q + qbar -> g + h0 ', 'q + g -> q + h0 ', + 1'g + g -> g + h0 ', 'g + g -> gamma + gamma ', + 1'g + g -> g + gamma ', 'g + g -> gamma + Z0 ', + 1'g + g -> Z0 + Z0 ', 'g + g -> W+ + W- ', + 1' ', ' '/ + DATA (PROC(I),I=121,140)/ + 2'g + g -> Q + Qbar + h0 ', 'q + qbar -> Q + Qbar + h0 ', + 2'f + f'' -> f + f'' + h0 ', + 2'f + f'' -> f" + f"'' + h0 ', + 2' ', ' ', + 2' ', ' ', + 2' ', ' ', + 3'f + gamma*_T -> f + g ', 'f + gamma*_L -> f + g ', + 3'f + gamma*_T -> f + gamma ', 'f + gamma*_L -> f + gamma ', + 3'g + gamma*_T -> f + fbar ', 'g + gamma*_L -> f + fbar ', + 3'gamma*_T+gamma*_T -> f+fbar ', 'gamma*_T+gamma*_L -> f+fbar ', + 3'gamma*_L+gamma*_T -> f+fbar ', 'gamma*_L+gamma*_L -> f+fbar '/ + DATA (PROC(I),I=141,160)/ + 4'f + fbar -> gamma*/Z0/Z''0 ', 'f + fbar'' -> W''+/- ', + 4'f + fbar'' -> H+/- ', 'f + fbar'' -> R ', + 4'q + l -> LQ ', 'e + gamma -> e* ', + 4'd + g -> d* ', 'u + g -> u* ', + 4'g + g -> eta_tc ', ' ', + 5'f + fbar -> H0 ', 'g + g -> H0 ', + 5'gamma + gamma -> H0 ', ' ', + 5' ', 'f + fbar -> A0 ', + 5'g + g -> A0 ', 'gamma + gamma -> A0 ', + 5' ', ' '/ + DATA (PROC(I),I=161,180)/ + 6'f + g -> f'' + H+/- ', 'q + g -> LQ + lbar ', + 6'g + g -> LQ + LQbar ', 'q + qbar -> LQ + LQbar ', + 6'f + fbar -> f'' + fbar'' (g/Z)', + 6'f +fbar'' -> f" + fbar"'' (W) ', + 6'q + q'' -> q" + d* ', 'q + q'' -> q" + u* ', + 6'q + qbar -> e + e* ', ' ', + 7'f + fbar -> Z0 + H0 ', 'f + fbar'' -> W+/- + H0 ', + 7'f + f'' -> f + f'' + H0 ', + 7'f + f'' -> f" + f"'' + H0 ', + 7' ', 'f + fbar -> Z0 + A0 ', + 7'f + fbar'' -> W+/- + A0 ', + 7'f + f'' -> f + f'' + A0 ', + 7'f + f'' -> f" + f"'' + A0 ', + 7' '/ + DATA (PROC(I),I=181,200)/ + 8'g + g -> Q + Qbar + H0 ', 'q + qbar -> Q + Qbar + H0 ', + 8'q + qbar -> g + H0 ', 'q + g -> q + H0 ', + 8'g + g -> g + H0 ', 'g + g -> Q + Qbar + A0 ', + 8'q + qbar -> Q + Qbar + A0 ', 'q + qbar -> g + A0 ', + 8'q + g -> q + A0 ', 'g + g -> g + A0 ', + 9'f + fbar -> rho_tc0 ', 'f + f'' -> rho_tc+/- ', + 9'f + fbar -> omega_tc0 ', 'f+fbar -> f''+fbar'' (ETC) ', + 9'f+fbar'' -> f"+fbar"'' (ETC)',' ', + 9' ', ' ', + 9' ', ' '/ + DATA (PROC(I),I=201,220)/ + &'f + fbar -> ~e_L + ~e_Lbar ', 'f + fbar -> ~e_R + ~e_Rbar ', + &'f + fbar -> ~e_R + ~e_Lbar ', 'f + fbar -> ~mu_L + ~mu_Lbar', + &'f + fbar -> ~mu_R + ~mu_Rbar', 'f + fbar -> ~mu_L + ~mu_Rbar', + &'f+fbar -> ~tau_1 + ~tau_1bar', 'f+fbar -> ~tau_2 + ~tau_2bar', + &'f+fbar -> ~tau_1 + ~tau_2bar', 'q + qbar'' -> ~l_L + ~nulbar ', + 1'q+qbar''-> ~tau_1 + ~nutaubar', 'q+qbar''-> ~tau_2 + ~nutaubar', + 1'f + fbar -> ~nul + ~nulbar ', 'f+fbar -> ~nutau + ~nutaubar', + 1' ', 'f + fbar -> ~chi1 + ~chi1 ', + 1'f + fbar -> ~chi2 + ~chi2 ', 'f + fbar -> ~chi3 + ~chi3 ', + 1'f + fbar -> ~chi4 + ~chi4 ', 'f + fbar -> ~chi1 + ~chi2 '/ + DATA (PROC(I),I=221,240)/ + 2'f + fbar -> ~chi1 + ~chi3 ', 'f + fbar -> ~chi1 + ~chi4 ', + 2'f + fbar -> ~chi2 + ~chi3 ', 'f + fbar -> ~chi2 + ~chi4 ', + 2'f + fbar -> ~chi3 + ~chi4 ', 'f+fbar -> ~chi+-1 + ~chi-+1 ', + 2'f+fbar -> ~chi+-2 + ~chi-+2 ', 'f+fbar -> ~chi+-1 + ~chi-+2 ', + 2'q + qbar'' -> ~chi1 + ~chi+-1', 'q + qbar'' -> ~chi2 + ~chi+-1', + 3'q + qbar'' -> ~chi3 + ~chi+-1', 'q + qbar'' -> ~chi4 + ~chi+-1', + 3'q + qbar'' -> ~chi1 + ~chi+-2', 'q + qbar'' -> ~chi2 + ~chi+-2', + 3'q + qbar'' -> ~chi3 + ~chi+-2', 'q + qbar'' -> ~chi4 + ~chi+-2', + 3'q + qbar -> ~chi1 + ~g ', 'q + qbar -> ~chi2 + ~g ', + 3'q + qbar -> ~chi3 + ~g ', 'q + qbar -> ~chi4 + ~g '/ + DATA (PROC(I),I=241,260)/ + 4'q + qbar'' -> ~chi+-1 + ~g ', 'q + qbar'' -> ~chi+-2 + ~g ', + 4'q + qbar -> ~g + ~g ', 'g + g -> ~g + ~g ', + 4' ', 'qj + g -> ~qj_L + ~chi1 ', + 4'qj + g -> ~qj_R + ~chi1 ', 'qj + g -> ~qj_L + ~chi2 ', + 4'qj + g -> ~qj_R + ~chi2 ', 'qj + g -> ~qj_L + ~chi3 ', + 5'qj + g -> ~qj_R + ~chi3 ', 'qj + g -> ~qj_L + ~chi4 ', + 5'qj + g -> ~qj_R + ~chi4 ', 'qj + g -> ~qk_L + ~chi+-1 ', + 5'qj + g -> ~qk_R + ~chi+-1 ', 'qj + g -> ~qk_L + ~chi+-2 ', + 5'qj + g -> ~qk_R + ~chi+-2 ', 'qj + g -> ~qj_L + ~g ', + 5'qj + g -> ~qj_R + ~g ', ' '/ + DATA (PROC(I),I=261,300)/ + 6'f + fbar -> ~t_1 + ~t_1bar ', 'f + fbar -> ~t_2 + ~t_2bar ', + 6'f + fbar -> ~t_1 + ~t_2bar ', 'g + g -> ~t_1 + ~t_1bar ', + 6'g + g -> ~t_2 + ~t_2bar ', ' ', + 6' ', ' ', + 6' ', ' ', + 7'qi + qj -> ~qi_L + ~qj_L ', 'qi + qj -> ~qi_R + ~qj_R ', + 7'qi + qj -> ~qi_L + ~qj_R ', 'qi+qjbar -> ~qi_L + ~qj_Lbar', + 7'qi+qjbar -> ~qi_R + ~qj_Rbar', 'qi+qjbar -> ~qi_L + ~qj_Rbar', + 7'f + fbar -> ~qi_L + ~qi_Lbar', 'f + fbar -> ~qi_R + ~qi_Rbar', + 7'g + g -> ~qi_L + ~qi_Lbar ', 'g + g -> ~qi_R + ~qi_Rbar ', + 8'b + qj -> ~b_1 + ~qj_L ', 'b + qj -> ~b_2 + ~qj_R ', + 8'b + qj -> ~b_1 + ~qj_R ', 'b + qjbar -> ~b_1 + ~qj_Lbar', + 8'b + qjbar -> ~b_2 + ~qj_Rbar', 'b + qjbar -> ~b_1 + ~qj_Rbar', + 8'f + fbar -> ~b_1 + ~b_1bar ', 'f + fbar -> ~b_2 + ~b_2bar ', + 8'g + g -> ~b_1 + ~b_1bar ', 'g + g -> ~b_2 + ~b_2bar ', + 9'b + b -> ~b_1 + ~b_1 ', 'b + b -> ~b_2 + ~b_2 ', + 9'b + b -> ~b_1 + ~b_2 ', 'b + g -> ~b_1 + ~g ', + 9'b + g -> ~b_2 + ~g ', 'b + bbar -> ~b_1 + ~b_2bar ', + 9'f + fbar'' -> H+/- + h0 ', 'f + fbar -> H+/- + H0 ', + 9'f + fbar -> A0 + h0 ', 'f + fbar -> A0 + H0 '/ + DATA (PROC(I),I=301,340)/ + &'f + fbar -> H+ + H- ', + &9*' ', 'g + g -> g* + g* ', + &'q + g -> q*_D + g* ', 'qi + qj -> q*_Di + q*_Dj ', + &'g + g -> q*_D + q*_Dbar ', 'q + qbar -> q*_D + q*_Dbar ', + &'qi + qbarj -> q*Di + q*Sbarj', 'qi + qjbar -> q*Di + q*Dbarj', + &'qi + qj -> q*_Di + q*_Sj ', 'qi + qibar -> q*Dj + q*Dbarj', + &21*' '/ + DATA (PROC(I),I=341,380)/ + 4'l + l -> H_L++/-- ', 'l + l -> H_R++/-- ', + 4'l + gamma -> H_L++/-- e-/+ ', 'l + gamma -> H_R++/-- e-/+ ', + 4'l + gamma -> H_L++/-- mu-/+ ', 'l + gamma -> H_R++/-- mu-/+ ', + 4'l + gamma -> H_L++/-- tau-/+', 'l + gamma -> H_R++/-- tau-/+', + 4'f + fbar -> H_L++ + H_L-- ', 'f + fbar -> H_R++ + H_R-- ', + 5'f + f -> f'' + f'' + H_L++/-- ', + 5'f + f -> f'' + f'' + H_R++/-- ','f + fbar -> Z_R0 ', + 5'f + fbar'' -> W_R+/- ',5*' ', + 6' ', 'f + fbar -> W_L+ W_L- ', + 6'f + fbar -> W_L+/- pi_T-/+ ', 'f + fbar -> pi_T+ pi_T- ', + 6'f + fbar -> gamma pi_T0 ', 'f + fbar -> gamma pi_T0'' ', + 6'f + fbar -> Z0 pi_T0 ', 'f + fbar -> Z0 pi_T0'' ', + 6'f + fbar -> W+/- pi_T-/+ ', ' ', + 7'f + fbar'' -> W_L+/- Z_L0 ', 'f + fbar'' -> W_L+/- pi_T0 ', + 7'f + fbar'' -> pi_T+/- Z_L0 ', 'f + fbar'' -> pi_T+/- pi_T0 ', + 7'f + fbar'' -> gamma pi_T+/- ', 'f + fbar'' -> Z0 pi_T+/- ', + 7'f + fbar'' -> W+/- pi_T0 ', + 7'f + fbar'' -> W+/- pi_T0'' ', + 7'f + fbar'' -> gamma W+/-(ETC)','f + fbar -> gamma Z0 (ETC)', + 7'f + fbar -> Z0 Z0 (ETC) '/ + DATA (PROC(I),I=381,420)/ + 8'f + f'' -> f + f'' (ETC) ','f + fbar -> f'' + fbar'' (ETC)', + 8'f + fbar -> g + g (ETC) ', 'f + g -> f + g (ETC) ', + 8'g + g -> f + fbar (ETC) ', 'g + g -> g + g (ETC) ', + 8'q + qbar -> Q + Qbar (ETC) ', 'g + g -> Q + Qbar (ETC) ', + 8' ', ' ', + 9'f + fbar -> G* ', 'g + g -> G* ', + 9'q + qbar -> g + G* ', 'q + g -> q + G* ', + 9'g + g -> g + G* ', ' ', + 9 4*' ', + &'g + g -> t + b + H+/- ', 'q + qbar -> t + b + H+/- ', + & 18*' '/ + DATA (PROC(I),I=421,460)/ + 2'g + g -> cc~[3S1(1)] + g ', 'g + g -> cc~[3S1(8)] + g ', + 2'g + g -> cc~[1S0(8)] + g ', 'g + g -> cc~[3PJ(8)] + g ', + 2'g + q -> q + cc~[3S1(8)] ', 'g + q -> q + cc~[1S0(8)] ', + 2'g + q -> q + cc~[3PJ(8)] ', 'q + q~ -> g + cc~[3S1(8)] ', + 2'q + q~ -> g + cc~[1S0(8)] ', 'q + q~ -> g + cc~[3PJ(8)] ', + 3'g + g -> cc~[3P0(1)] + g ', 'g + g -> cc~[3P1(1)] + g ', + 3'g + g -> cc~[3P2(1)] + g ', 'q + g -> q + cc~[3P0(1)] ', + 3'q + g -> q + cc~[3P1(1)] ', 'q + g -> q + cc~[3P2(1)] ', + 3'q + q~ -> g + cc~[3P0(1)] ', 'q + q~ -> g + cc~[3P1(1)] ', + 3'q + q~ -> g + cc~[3P2(1)] ', + 3 21 *' '/ + DATA (PROC(I),I=461,500)/ + 6'g + g -> bb~[3S1(1)] + g ', 'g + g -> bb~[3S1(8)] + g ', + 6'g + g -> bb~[1S0(8)] + g ', 'g + g -> bb~[3PJ(8)] + g ', + 6'g + q -> q + bb~[3S1(8)] ', 'g + q -> q + bb~[1S0(8)] ', + 6'g + q -> q + bb~[3PJ(8)] ', 'q + q~ -> g + bb~[3S1(8)] ', + 6'q + q~ -> g + bb~[1S0(8)] ', 'q + q~ -> g + bb~[3PJ(8)] ', + 7'g + g -> bb~[3P0(1)] + g ', 'g + g -> bb~[3P1(1)] + g ', + 7'g + g -> bb~[3P2(1)] + g ', 'q + g -> q + bb~[3P0(1)] ', + 7'q + g -> q + bb~[3P1(1)] ', 'q + g -> q + bb~[3P2(1)] ', + 7'q + q~ -> g + bb~[3P0(1)] ', 'q + q~ -> g + bb~[3P1(1)] ', + 7'q + q~ -> g + bb~[3P2(1)] ', + 7 21 *' '/ + +C...Cross sections and slope offsets. + DATA SIGT/294*0D0/ + +C...Supersymmetry switches and parameters. + DATA IMSS/0, + & 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, + 1 89*0/ + DATA RMSS/0D0, + & 80D0,160D0,500D0,800D0,2D0,250D0,200D0,800D0,700D0,800D0, + 1 700D0,500D0,250D0,200D0,800D0,400D0,0D0,0.1D0,850D0,0.041D0, + 2 1D0,800D0,1D4,1D4,1D4,0D0,0D0,0D0,24D17,0D0, + 3 10*0D0, + 4 0D0,1D0,8*0D0, + 5 49*0D0/ +C...Initial values for R-violating SUSY couplings. +C...Should not be changed here. See PYMSIN. + DATA RVLAM/27*0D0/ + DATA RVLAMP/27*0D0/ + DATA RVLAMB/27*0D0/ + +C...Technicolor switches and parameters + DATA ITCM/0, + & 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 1 89*0/ + DATA RTCM/0D0, + & 82D0,1.333D0,.333D0,0.408D0,1D0,1D0,.0182D0,1D0,0D0,1.333D0, + 1 .05D0,200D0,200D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0, + 2 .283D0,.707D0,0D0,0D0,0D0,1.667D0,250D0,250D0,.707D0,0D0, + 3 .707D0,0D0,1D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0, + 4 1000D0, 1D0, 1D0, 1D0, 1D0, 0D0, 1D0, 3*200D0, + 4 200D0, 48*0D0/ + +C...UED switches and parameters. +C... IUED(0) empty IUED vector element +C... IUED(1) UED ON(=1)/OFF(=0) switch +C... IUED(2) ON(=1)/OFF(=0) switch for gravity mediated decays +C... IUED(3) NFLAVOURS Number of KK excitation quark flavours +C... IUED(4) N the number of large extra dimensions +C... IUED(5) Selects whether the code takes Lambda (=0) +C... or Lambda*R (=1) as input. +C... IUED(6) With radiative corrections to the masses (=1) +C... or without (=0) +C... +C... RUED(0) empty RUED vector element +C... RUED(1) RINV (1/R) the curvature of the extra dimension +C... RUED(2) XMD the (4+N)-dimensional Planck scale +C... RUED(3) LAMUED (Lambda cutoff scale) +C... RUED(4) LAMUED/RINV (feasible values are order of 10-20) +C... + DATA IUED/0,0,0,5,6,0,1,93*0/ + DATA RUED/0.D0,1000D0,5000D0,20000.,20.,95*0D0/ + +C...Data for histogramming routines. + DATA IHIST/1000,20000,55,1/ + DATA INDX/1000*0/ + +C...Data for SUSY Les Houches Accord. + DATA CPRO/'PYTHIA ','PYTHIA '/ + DATA CVER/'6.4 ','6.4 '/ + DATA MODSEL/200*0/ + DATA PARMIN/100*0D0/ + DATA RMSOFT/101*0D0/ + DATA AU/9*0D0/ + DATA AD/9*0D0/ + DATA AE/9*0D0/ + + END + +C********************************************************************* + +C...PYCKBD +C...Check that BLOCK DATA PYDATA has been loaded. +C...Should not be required, except that some compilers/linkers +C...are pretty buggy in this respect. + + SUBROUTINE PYCKBD + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/ + +C...Check a few variables to see they have been sensibly initialized. + IF(MSTU(4).LT.10.OR.MSTU(4).GT.900000.OR.PMAS(2,1).LT.0.001D0 + &.OR.PMAS(2,1).GT.1D0.OR.CKIN(5).LT.0.01D0.OR.MSTP(1).LT.1.OR. + &MSTP(1).GT.5) THEN +C...If not, abort the run right away. + WRITE(*,*) 'Fatal error: BLOCK DATA PYDATA has not been loaded!' + WRITE(*,*) 'The program execution is stopped now!' + CALL PYSTOP(8) + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYTEST +C...A simple program (disguised as subroutine) to run at installation +C...as a check that the program works as intended. + + SUBROUTINE PYTEST(MTEST) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/ +C...Local arrays. + DIMENSION PSUM(5),PINI(6),PFIN(6) + +C...Save defaults for values that are changed. + MSTJ1=MSTJ(1) + MSTJ3=MSTJ(3) + MSTJ11=MSTJ(11) + MSTJ42=MSTJ(42) + MSTJ43=MSTJ(43) + MSTJ44=MSTJ(44) + PARJ17=PARJ(17) + PARJ22=PARJ(22) + PARJ43=PARJ(43) + PARJ54=PARJ(54) + MST101=MSTJ(101) + MST104=MSTJ(104) + MST105=MSTJ(105) + MST107=MSTJ(107) + MST116=MSTJ(116) + +C...First part: loop over simple events to be generated. + IF(MTEST.GE.1) CALL PYTABU(20) + NERR=0 + DO 180 IEV=1,500 + +C...Reset parameter values. Switch on some nonstandard features. + MSTJ(1)=1 + MSTJ(3)=0 + MSTJ(11)=1 + MSTJ(42)=2 + MSTJ(43)=4 + MSTJ(44)=2 + PARJ(17)=0.1D0 + PARJ(22)=1.5D0 + PARJ(43)=1D0 + PARJ(54)=-0.05D0 + MSTJ(101)=5 + MSTJ(104)=5 + MSTJ(105)=0 + MSTJ(107)=1 + IF(IEV.EQ.301.OR.IEV.EQ.351.OR.IEV.EQ.401) MSTJ(116)=3 + +C...Ten events each for some single jets configurations. + IF(IEV.LE.50) THEN + ITY=(IEV+9)/10 + MSTJ(3)=-1 + IF(ITY.EQ.3.OR.ITY.EQ.4) MSTJ(11)=2 + IF(ITY.EQ.1) CALL PY1ENT(1,1,15D0,0D0,0D0) + IF(ITY.EQ.2) CALL PY1ENT(1,3101,15D0,0D0,0D0) + IF(ITY.EQ.3) CALL PY1ENT(1,-2203,15D0,0D0,0D0) + IF(ITY.EQ.4) CALL PY1ENT(1,-4,30D0,0D0,0D0) + IF(ITY.EQ.5) CALL PY1ENT(1,21,15D0,0D0,0D0) + +C...Ten events each for some simple jet systems; string fragmentation. + ELSEIF(IEV.LE.130) THEN + ITY=(IEV-41)/10 + IF(ITY.EQ.1) CALL PY2ENT(1,1,-1,40D0) + IF(ITY.EQ.2) CALL PY2ENT(1,4,-4,30D0) + IF(ITY.EQ.3) CALL PY2ENT(1,2,2103,100D0) + IF(ITY.EQ.4) CALL PY2ENT(1,21,21,40D0) + IF(ITY.EQ.5) CALL PY3ENT(1,2101,21,-3203,30D0,0.6D0,0.8D0) + IF(ITY.EQ.6) CALL PY3ENT(1,5,21,-5,40D0,0.9D0,0.8D0) + IF(ITY.EQ.7) CALL PY3ENT(1,21,21,21,60D0,0.7D0,0.5D0) + IF(ITY.EQ.8) CALL PY4ENT(1,2,21,21,-2,40D0, + & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0) + +C...Seventy events with independent fragmentation and momentum cons. + ELSEIF(IEV.LE.200) THEN + ITY=1+(IEV-131)/16 + MSTJ(2)=1+MOD(IEV-131,4) + MSTJ(3)=1+MOD((IEV-131)/4,4) + IF(ITY.EQ.1) CALL PY2ENT(1,4,-5,40D0) + IF(ITY.EQ.2) CALL PY3ENT(1,3,21,-3,40D0,0.9D0,0.4D0) + IF(ITY.EQ.3) CALL PY4ENT(1,2,21,21,-2,40D0, + & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0) + IF(ITY.GE.4) CALL PY4ENT(1,2,-3,3,-2,40D0, + & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0) + +C...A hundred events with random jets (check invariant mass). + ELSEIF(IEV.LE.300) THEN + 100 DO 110 J=1,5 + PSUM(J)=0D0 + 110 CONTINUE + NJET=2D0+6D0*PYR(0) + DO 130 I=1,NJET + KFL=21 + IF(I.EQ.1) KFL=INT(1D0+4D0*PYR(0)) + IF(I.EQ.NJET) KFL=-INT(1D0+4D0*PYR(0)) + EJET=5D0+20D0*PYR(0) + THETA=ACOS(2D0*PYR(0)-1D0) + PHI=6.2832D0*PYR(0) + IF(I.LT.NJET) CALL PY1ENT(-I,KFL,EJET,THETA,PHI) + IF(I.EQ.NJET) CALL PY1ENT(I,KFL,EJET,THETA,PHI) + IF(I.EQ.1.OR.I.EQ.NJET) MSTJ(93)=1 + IF(I.EQ.1.OR.I.EQ.NJET) PSUM(5)=PSUM(5)+PYMASS(KFL) + DO 120 J=1,4 + PSUM(J)=PSUM(J)+P(I,J) + 120 CONTINUE + 130 CONTINUE + IF(PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2.LT. + & (PSUM(5)+PARJ(32))**2) GOTO 100 + +C...Fifty e+e- continuum events with matrix elements. + ELSEIF(IEV.LE.350) THEN + MSTJ(101)=2 + CALL PYEEVT(0,40D0) + +C...Fifty e+e- continuum event with varying shower options. + ELSEIF(IEV.LE.400) THEN + MSTJ(42)=1+MOD(IEV,2) + MSTJ(43)=1+MOD(IEV/2,4) + MSTJ(44)=MOD(IEV/8,3) + CALL PYEEVT(0,90D0) + +C...Fifty e+e- continuum events with coherent shower. + ELSEIF(IEV.LE.450) THEN + CALL PYEEVT(0,500D0) + +C...Fifty Upsilon decays to ggg or gammagg with coherent shower. + ELSE + CALL PYONIA(5,9.46D0) + ENDIF + +C...Generate event. Find total momentum, energy and charge. + DO 140 J=1,4 + PINI(J)=PYP(0,J) + 140 CONTINUE + PINI(6)=PYP(0,6) + CALL PYEXEC + DO 150 J=1,4 + PFIN(J)=PYP(0,J) + 150 CONTINUE + PFIN(6)=PYP(0,6) + +C...Check conservation of energy, momentum and charge; +C...usually exact, but only approximate for single jets. + MERR=0 + IF(IEV.LE.50) THEN + IF((PFIN(1)-PINI(1))**2+(PFIN(2)-PINI(2))**2.GE.10D0) + & MERR=MERR+1 + EPZREM=PINI(4)+PINI(3)-PFIN(4)-PFIN(3) + IF(EPZREM.LT.0D0.OR.EPZREM.GT.2D0*PARJ(31)) MERR=MERR+1 + IF(ABS(PFIN(6)-PINI(6)).GT.2.1D0) MERR=MERR+1 + ELSE + DO 160 J=1,4 + IF(ABS(PFIN(J)-PINI(J)).GT.0.0001D0*PINI(4)) MERR=MERR+1 + 160 CONTINUE + IF(ABS(PFIN(6)-PINI(6)).GT.0.1D0) MERR=MERR+1 + ENDIF + IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6), + & (PFIN(J),J=1,4),PFIN(6) + +C...Check that all KF codes are known ones, and that partons/particles +C...satisfy energy-momentum-mass relation. Store particle statistics. + DO 170 I=1,N + IF(K(I,1).GT.20) GOTO 170 + IF(PYCOMP(K(I,2)).EQ.0) THEN + WRITE(MSTU(11),5100) I + MERR=MERR+1 + ENDIF + PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2 + IF(ABS(PD).GT.MAX(0.1D0,0.001D0*P(I,4)**2).OR.P(I,4).LT.0D0) + & THEN + WRITE(MSTU(11),5200) I + MERR=MERR+1 + ENDIF + 170 CONTINUE + IF(MTEST.GE.1) CALL PYTABU(21) + +C...List all erroneous events and some normal ones. + IF(MERR.NE.0.OR.MSTU(24).NE.0.OR.MSTU(28).NE.0) THEN + IF(MERR.GE.1) WRITE(MSTU(11),6400) + CALL PYLIST(2) + ELSEIF(MTEST.GE.1.AND.MOD(IEV-5,100).EQ.0) THEN + CALL PYLIST(1) + ENDIF + +C...Stop execution if too many errors. + IF(MERR.NE.0) NERR=NERR+1 + IF(NERR.GE.10) THEN + WRITE(MSTU(11),6300) + CALL PYLIST(1) + CALL PYSTOP(9) + ENDIF + 180 CONTINUE + +C...Summarize result of run. + IF(MTEST.GE.1) CALL PYTABU(22) + +C...Reset commonblock variables changed during run. + MSTJ(1)=MSTJ1 + MSTJ(3)=MSTJ3 + MSTJ(11)=MSTJ11 + MSTJ(42)=MSTJ42 + MSTJ(43)=MSTJ43 + MSTJ(44)=MSTJ44 + PARJ(17)=PARJ17 + PARJ(22)=PARJ22 + PARJ(43)=PARJ43 + PARJ(54)=PARJ54 + MSTJ(101)=MST101 + MSTJ(104)=MST104 + MSTJ(105)=MST105 + MSTJ(107)=MST107 + MSTJ(116)=MST116 + +C...Second part: complete events of various kinds. +C...Common initial values. Loop over initiating conditions. + MSTP(122)=MAX(0,MIN(2,MTEST)) + MDCY(PYCOMP(111),1)=0 + DO 230 IPROC=1,8 + +C...Reset process type, kinematics cuts, and the flags used. + MSEL=0 + DO 190 ISUB=1,500 + MSUB(ISUB)=0 + 190 CONTINUE + CKIN(1)=2D0 + CKIN(3)=0D0 + MSTP(2)=1 + MSTP(11)=0 + MSTP(33)=0 + MSTP(81)=1 + MSTP(82)=1 + MSTP(111)=1 + MSTP(131)=0 + MSTP(133)=0 + PARP(131)=0.01D0 + +C...Prompt photon production at fixed target. + IF(IPROC.EQ.1) THEN + PZSUM=300D0 + PESUM=SQRT(PZSUM**2+PYMASS(211)**2)+PYMASS(2212) + PQSUM=2D0 + MSEL=10 + CKIN(3)=5D0 + CALL PYINIT('FIXT','pi+','p',PZSUM) + +C...QCD processes at ISR energies. + ELSEIF(IPROC.EQ.2) THEN + PESUM=63D0 + PZSUM=0D0 + PQSUM=2D0 + MSEL=1 + CKIN(3)=5D0 + CALL PYINIT('CMS','p','p',PESUM) + +C...W production + multiple interactions at CERN Collider. + ELSEIF(IPROC.EQ.3) THEN + PESUM=630D0 + PZSUM=0D0 + PQSUM=0D0 + MSEL=12 + CKIN(1)=20D0 + MSTP(82)=4 + MSTP(2)=2 + MSTP(33)=3 + CALL PYINIT('CMS','p','pbar',PESUM) + +C...W/Z gauge boson pairs + pileup events at the Tevatron. + ELSEIF(IPROC.EQ.4) THEN + PESUM=1800D0 + PZSUM=0D0 + PQSUM=0D0 + MSUB(22)=1 + MSUB(23)=1 + MSUB(25)=1 + CKIN(1)=200D0 + MSTP(111)=0 + MSTP(131)=1 + MSTP(133)=2 + PARP(131)=0.04D0 + CALL PYINIT('CMS','p','pbar',PESUM) + +C...Higgs production at LHC. + ELSEIF(IPROC.EQ.5) THEN + PESUM=15400D0 + PZSUM=0D0 + PQSUM=2D0 + MSUB(3)=1 + MSUB(102)=1 + MSUB(123)=1 + MSUB(124)=1 + PMAS(25,1)=300D0 + CKIN(1)=200D0 + MSTP(81)=0 + MSTP(111)=0 + CALL PYINIT('CMS','p','p',PESUM) + +C...Z' production at SSC. + ELSEIF(IPROC.EQ.6) THEN + PESUM=40000D0 + PZSUM=0D0 + PQSUM=2D0 + MSEL=21 + PMAS(32,1)=600D0 + CKIN(1)=400D0 + MSTP(81)=0 + MSTP(111)=0 + CALL PYINIT('CMS','p','p',PESUM) + +C...W pair production at 1 TeV e+e- collider. + ELSEIF(IPROC.EQ.7) THEN + PESUM=1000D0 + PZSUM=0D0 + PQSUM=0D0 + MSUB(25)=1 + MSUB(69)=1 + MSTP(11)=1 + CALL PYINIT('CMS','e+','e-',PESUM) + +C...Deep inelastic scattering at a LEP+LHC ep collider. + ELSEIF(IPROC.EQ.8) THEN + P(1,1)=0D0 + P(1,2)=0D0 + P(1,3)=8000D0 + P(2,1)=0D0 + P(2,2)=0D0 + P(2,3)=-80D0 + PESUM=8080D0 + PZSUM=7920D0 + PQSUM=0D0 + MSUB(10)=1 + CKIN(3)=50D0 + MSTP(111)=0 + CALL PYINIT('3MOM','p','e-',PESUM) + ENDIF + +C...Generate 20 events of each required type. + DO 220 IEV=1,20 + CALL PYEVNT + PESUMM=PESUM + IF(IPROC.EQ.4) PESUMM=MSTI(41)*PESUM + +C...Check conservation of energy/momentum/flavour. + PINI(1)=0D0 + PINI(2)=0D0 + PINI(3)=PZSUM + PINI(4)=PESUMM + PINI(6)=PQSUM + DO 200 J=1,4 + PFIN(J)=PYP(0,J) + 200 CONTINUE + PFIN(6)=PYP(0,6) + MERR=0 + DEVE=ABS(PFIN(4)-PINI(4))+ABS(PFIN(3)-PINI(3)) + DEVT=ABS(PFIN(1)-PINI(1))+ABS(PFIN(2)-PINI(2)) + DEVQ=ABS(PFIN(6)-PINI(6)) + IF(DEVE.GT.2D-3*PESUM.OR.DEVT.GT.MAX(0.01D0,1D-4*PESUM).OR. + & DEVQ.GT.0.1D0) MERR=1 + IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6), + & (PFIN(J),J=1,4),PFIN(6) + +C...Check that all KF codes are known ones, and that partons/particles +C...satisfy energy-momentum-mass relation. + DO 210 I=1,N + IF(K(I,1).GT.20) GOTO 210 + IF(PYCOMP(K(I,2)).EQ.0) THEN + WRITE(MSTU(11),5100) I + MERR=MERR+1 + ENDIF + PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2* + & SIGN(1D0,P(I,5)) + IF(ABS(PD).GT.MAX(0.1D0,0.002D0*P(I,4)**2,0.002D0*P(I,5)**2) + & .OR.(P(I,5).GE.0D0.AND.P(I,4).LT.0D0)) THEN + WRITE(MSTU(11),5200) I + MERR=MERR+1 + ENDIF + 210 CONTINUE + +C...Listing of erroneous events, and first event of each type. + IF(MERR.GE.1) NERR=NERR+1 + IF(NERR.GE.10) THEN + WRITE(MSTU(11),6300) + CALL PYLIST(1) + CALL PYSTOP(9) + ENDIF + IF(MTEST.GE.1.AND.(MERR.GE.1.OR.IEV.EQ.1)) THEN + IF(MERR.GE.1) WRITE(MSTU(11),6400) + CALL PYLIST(1) + ENDIF + 220 CONTINUE + +C...List statistics for each process type. + IF(MTEST.GE.1) CALL PYSTAT(1) + 230 CONTINUE + +C...Summarize result of run. + IF(NERR.EQ.0) WRITE(MSTU(11),6500) + IF(NERR.GT.0) WRITE(MSTU(11),6600) NERR + +C...Format statements for output. + 5000 FORMAT(/' Momentum, energy and/or charge were not conserved ', + &'in following event'/' sum of',9X,'px',11X,'py',11X,'pz',11X, + &'E',8X,'charge'/' before',2X,4(1X,F12.5),1X,F8.2/' after',3X, + &4(1X,F12.5),1X,F8.2) + 5100 FORMAT(/5X,'Entry no.',I4,' in following event not known code') + 5200 FORMAT(/5X,'Entry no.',I4,' in following event has faulty ', + &'kinematics') + 6300 FORMAT(/5X,'This is the tenth error experienced! Something is ', + &'wrong.'/5X,'Execution will be stopped after listing of event.') + 6400 FORMAT(5X,'Faulty event follows:') + 6500 FORMAT(//5X,'End result of PYTEST: no errors detected.') + 6600 FORMAT(//5X,'End result of PYTEST:',I2,' errors detected.'/ + &5X,'This should not have happened!') + + RETURN + END + +C********************************************************************* + +C...PYHEPC +C...Converts PYTHIA event record contents to or from +C...the standard event record commonblock. + + SUBROUTINE PYHEPC(MCONV) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ +C...HEPEVT commonblock. + PARAMETER (NMXHEP=4000) + COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP), + &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP) + DOUBLE PRECISION PHEP,VHEP + SAVE /HEPEVT/ + +C...Store HEPEVT commonblock size (for interfacing issues). + MSTU(8)=NMXHEP + +C...Initialize variable(s) + INEW = 1 + +C...Conversion from PYTHIA to standard, the easy part. + IF(MCONV.EQ.1) THEN + NEVHEP=0 + IF(N.GT.NMXHEP) CALL PYERRM(8, + & '(PYHEPC:) no more space in /HEPEVT/') + NHEP=MIN(N,NMXHEP) + DO 150 I=1,NHEP + ISTHEP(I)=0 + IF(K(I,1).GE.1.AND.K(I,1).LE.10) ISTHEP(I)=1 + IF(K(I,1).GE.11.AND.K(I,1).LE.20) ISTHEP(I)=2 + IF(K(I,1).GE.21.AND.K(I,1).LE.30) ISTHEP(I)=3 + IF(K(I,1).GE.31.AND.K(I,1).LE.100) ISTHEP(I)=K(I,1) + IDHEP(I)=K(I,2) + JMOHEP(1,I)=K(I,3) + JMOHEP(2,I)=0 + IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) THEN + JDAHEP(1,I)=K(I,4) + JDAHEP(2,I)=K(I,5) + ELSE + JDAHEP(1,I)=0 + JDAHEP(2,I)=0 + ENDIF + DO 100 J=1,5 + PHEP(J,I)=P(I,J) + 100 CONTINUE + DO 110 J=1,4 + VHEP(J,I)=V(I,J) + 110 CONTINUE + +C...Check if new event (from pileup). + IF(I.EQ.1) THEN + INEW=1 + ELSE + IF(K(I,1).EQ.21.AND.K(I-1,1).NE.21) INEW=I + ENDIF + +C...Fill in missing mother information. + IF(I.GE.INEW+2.AND.K(I,1).EQ.21.AND.K(I,3).EQ.0) THEN + IMO1=I-2 + 120 IF(IMO1.GT.INEW.AND.K(IMO1+1,1).EQ.21.AND.K(IMO1+1,3).EQ.0) + & THEN + IMO1=IMO1-1 + GOTO 120 + ENDIF + JMOHEP(1,I)=IMO1 + JMOHEP(2,I)=IMO1+1 + ELSEIF(K(I,2).GE.91.AND.K(I,2).LE.93) THEN + I1=K(I,3)-1 + 130 I1=I1+1 + IF(I1.GE.I) CALL PYERRM(8, + & '(PYHEPC:) translation of inconsistent event history') + IF(I1.LT.I.AND.K(I1,1).NE.1.AND.K(I1,1).NE.11) GOTO 130 + KC=PYCOMP(K(I1,2)) + IF(I1.LT.I.AND.KC.EQ.0) GOTO 130 + IF(I1.LT.I.AND.KCHG(KC,2).EQ.0) GOTO 130 + JMOHEP(2,I)=I1 + ELSEIF(K(I,2).EQ.94) THEN + NJET=2 + IF(NHEP.GE.I+3.AND.K(I+3,3).LE.I) NJET=3 + IF(NHEP.GE.I+4.AND.K(I+4,3).LE.I) NJET=4 + JMOHEP(2,I)=MOD(K(I+NJET,4)/MSTU(5),MSTU(5)) + IF(JMOHEP(2,I).EQ.JMOHEP(1,I)) JMOHEP(2,I)= + & MOD(K(I+1,4)/MSTU(5),MSTU(5)) + ENDIF + +C...Fill in missing daughter information. + IF(K(I,2).EQ.94.AND.MSTU(16).NE.2) THEN + DO 140 I1=JDAHEP(1,I),JDAHEP(2,I) + I2=MOD(K(I1,4)/MSTU(5),MSTU(5)) + JDAHEP(1,I2)=I + 140 CONTINUE + ENDIF + IF(K(I,2).GE.91.AND.K(I,2).LE.94) GOTO 150 + I1=JMOHEP(1,I) + IF(I1.LE.0.OR.I1.GT.NHEP) GOTO 150 + IF(K(I1,1).NE.13.AND.K(I1,1).NE.14) GOTO 150 + IF(JDAHEP(1,I1).EQ.0) THEN + JDAHEP(1,I1)=I + ELSE + JDAHEP(2,I1)=I + ENDIF + 150 CONTINUE + DO 160 I=1,NHEP + IF(K(I,1).NE.13.AND.K(I,1).NE.14) GOTO 160 + IF(JDAHEP(2,I).EQ.0) JDAHEP(2,I)=JDAHEP(1,I) + 160 CONTINUE + +C...Conversion from standard to PYTHIA, the easy part. + ELSE + IF(NHEP.GT.MSTU(4)) CALL PYERRM(8, + & '(PYHEPC:) no more space in /PYJETS/') + N=MIN(NHEP,MSTU(4)) + NKQ=0 + KQSUM=0 + DO 190 I=1,N + K(I,1)=0 + IF(ISTHEP(I).EQ.1) K(I,1)=1 + IF(ISTHEP(I).EQ.2) THEN + K(I,1)=11 + IF(K(I,4).GT.0.AND.(K(I,4).EQ.K(I,5)).AND. + $ (K(K(I,4),2).GE.91.AND.K(K(I,4),2).LE.93).AND. + $ (I.LT.N).AND.(K(I,4).EQ.K(I+1,4))) K(I,1)=12 + ENDIF + IF(ISTHEP(I).EQ.3) K(I,1)=21 + K(I,2)=IDHEP(I) + K(I,3)=JMOHEP(1,I) + K(I,4)=JDAHEP(1,I) + K(I,5)=JDAHEP(2,I) + DO 170 J=1,5 + P(I,J)=PHEP(J,I) + 170 CONTINUE + DO 180 J=1,4 + V(I,J)=VHEP(J,I) + 180 CONTINUE + V(I,5)=0D0 + IF(ISTHEP(I).EQ.2.AND.PHEP(4,I).GT.PHEP(5,I)) THEN + I1=JDAHEP(1,I) + IF(I1.GT.0.AND.I1.LE.NHEP) V(I,5)=(VHEP(4,I1)-VHEP(4,I))* + & PHEP(5,I)/PHEP(4,I) + ENDIF + +C...Fill in missing information on colour connection in jet systems. + IF(ISTHEP(I).EQ.1) THEN + KC=PYCOMP(K(I,2)) + KQ=0 + IF(KC.NE.0) KQ=KCHG(KC,2)*ISIGN(1,K(I,2)) + IF(KQ.NE.0) NKQ=NKQ+1 + IF(KQ.NE.2) KQSUM=KQSUM+KQ + IF(KQ.NE.0.AND.KQSUM.NE.0) THEN + K(I,1)=2 + ELSEIF(KQ.EQ.2.AND.I.LT.N) THEN + IF(K(I+1,2).EQ.21) K(I,1)=2 + ENDIF + ENDIF + 190 CONTINUE + IF(NKQ.EQ.1.OR.KQSUM.NE.0) CALL PYERRM(8, + & '(PYHEPC:) input parton configuration not colour singlet') + ENDIF + + END + +C********************************************************************* + +C...PYINIT +C...Initializes the generation procedure; finds maxima of the +C...differential cross-sections to be used for weighting. + + SUBROUTINE PYINIT(FRAME,BEAM,TARGET,WIN) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + COMMON/PYDAT4/CHAF(500,2) + CHARACTER CHAF*16 + COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) + COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) + COMMON/PYPUED/IUED(0:99),RUED(0:99) + SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/, + &/PYINT1/,/PYINT2/,/PYINT5/,/PYPUED/ +C...Local arrays and character variables. + DIMENSION ALAMIN(20),NFIN(20) + CHARACTER*(*) FRAME,BEAM,TARGET + CHARACTER CHFRAM*12,CHBEAM*12,CHTARG*12,CHLH(2)*6 + +C...Interface to PDFLIB. + COMMON/W50511/NPTYPE,NGROUP,NSET,MODE,NFL,LO,TMAS + COMMON/W50512/QCDL4,QCDL5 + SAVE /W50511/,/W50512/ + DOUBLE PRECISION VALUE(20),TMAS,QCDL4,QCDL5 + CHARACTER*20 PARM(20) + DATA VALUE/20*0D0/,PARM/20*' '/ + +C...Data:Lambda and n_f values for parton distributions.. + DATA ALAMIN/0.177D0,0.239D0,0.247D0,0.2322D0,0.248D0,0.248D0, + &0.192D0,0.326D0,2*0.2D0,0.2D0,0.2D0,0.29D0,0.2D0,0.4D0,5*0.2D0/, + &NFIN/20*4/ + DATA CHLH/'lepton','hadron'/ + +C...Check that BLOCK DATA PYDATA has been loaded. + CALL PYCKBD + +C...Reset MINT and VINT arrays. Write headers. + MSTI(53)=0 + DO 100 J=1,400 + MINT(J)=0 + VINT(J)=0D0 + 100 CONTINUE + IF(MSTU(12).NE.12345) CALL PYLIST(0) + IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) + +C...Reset error counters. + MSTU(23)=0 + MSTU(27)=0 + MSTU(30)=0 + +C...Reset processes that should not be on. + MSUB(96)=0 + MSUB(97)=0 + +C...Select global FSR/ISR/UE parameter set = 'tune' +C...See routine PYTUNE for details + IF (MSTP(5).NE.0) THEN + MSTP5=MSTP(5) + CALL PYTUNE(MSTP5) + ENDIF + +C...Call user process initialization routine. + IF(FRAME(1:1).EQ.'u'.OR.FRAME(1:1).EQ.'U') THEN + MSEL=0 + CALL UPINIT + MSEL=0 + ENDIF + +C...Maximum 4 generations; set maximum number of allowed flavours. + MSTP(1)=MIN(4,MSTP(1)) + MSTU(114)=MIN(MSTU(114),2*MSTP(1)) + MSTP(58)=MIN(MSTP(58),2*MSTP(1)) + +C...Sum up Cabibbo-Kobayashi-Maskawa factors for each quark/lepton. + DO 120 I=-20,20 + VINT(180+I)=0D0 + IA=IABS(I) + IF(IA.GE.1.AND.IA.LE.2*MSTP(1)) THEN + DO 110 J=1,MSTP(1) + IB=2*J-1+MOD(IA,2) + IF(IB.GE.6.AND.MSTP(9).EQ.0) GOTO 110 + IPM=(5-ISIGN(1,I))/2 + IDC=J+MDCY(IA,2)+2 + IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) VINT(180+I)= + & VINT(180+I)+VCKM((IA+1)/2,(IB+1)/2) + 110 CONTINUE + ELSEIF(IA.GE.11.AND.IA.LE.10+2*MSTP(1)) THEN + VINT(180+I)=1D0 + ENDIF + 120 CONTINUE + +C...Initialize parton distributions: PDFLIB. + IF(MSTP(52).EQ.2) THEN + PARM(1)='NPTYPE' + VALUE(1)=1 + PARM(2)='NGROUP' + VALUE(2)=MSTP(51)/1000 + PARM(3)='NSET' + VALUE(3)=MOD(MSTP(51),1000) + PARM(4)='TMAS' + VALUE(4)=PMAS(6,1) + call setlhaparm('SILENT') + CALL PDFSET(PARM,VALUE) + MINT(93)=1000000+MSTP(51) + ENDIF + +C...Choose Lambda value to use in alpha-strong. + MSTU(111)=MSTP(2) + IF(MSTP(3).GE.2) THEN + ALAM=0.2D0 + NF=4 + IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.20) THEN + ALAM=ALAMIN(MSTP(51)) + NF=NFIN(MSTP(51)) + ELSEIF(MSTP(52).EQ.2.AND.NFL.EQ.5) THEN + ALAM=QCDL5 + NF=5 + ELSEIF(MSTP(52).EQ.2) THEN + ALAM=QCDL4 + NF=4 + ENDIF + PARP(1)=ALAM + PARP(61)=ALAM + PARP(72)=ALAM + PARU(112)=ALAM + MSTU(112)=NF + IF(MSTP(3).EQ.3) PARJ(81)=ALAM + ENDIF + +C...Initialize the UED masses and widths + IF (IUED(1).EQ.1) CALL PYXDIN + +C...Initialize the SUSY generation: couplings, masses, +C...decay modes, branching ratios, and so on. + CALL PYMSIN +C...Initialize widths and partial widths for resonances. + CALL PYINRE +C...Set Z0 mass and width for e+e- routines. + PARJ(123)=PMAS(23,1) + PARJ(124)=PMAS(23,2) + +C...Identify beam and target particles and frame of process. + CHFRAM=FRAME//' ' + CHBEAM=BEAM//' ' + CHTARG=TARGET//' ' + CALL PYINBM(CHFRAM,CHBEAM,CHTARG,WIN) + IF(MINT(65).EQ.1) GOTO 170 + +C...For gamma-p or gamma-gamma allow many (3 or 6) alternatives. +C...For e-gamma allow 2 alternatives. + MINT(121)=1 + IF(MSTP(14).EQ.10.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN + IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND. + & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=3 + IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=6 + IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND. + & (IABS(MINT(11)).EQ.11.OR.IABS(MINT(12)).EQ.11)) MINT(121)=2 + ELSEIF(MSTP(14).EQ.20.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN + IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND. + & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=3 + IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=9 + ELSEIF(MSTP(14).EQ.25.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN + IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND. + & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=2 + IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=4 + ELSEIF(MSTP(14).EQ.30.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN + IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND. + & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=4 + IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=13 + ENDIF + MINT(123)=MSTP(14) + IF((MSTP(14).EQ.10.OR.MSTP(14).EQ.20.OR.MSTP(14).EQ.25.OR. + &MSTP(14).EQ.30).AND.MSEL.NE.1.AND.MSEL.NE.2) MINT(123)=0 + IF(MSTP(14).GE.11.AND.MSTP(14).LE.19) THEN + IF(MSTP(14).EQ.11) MINT(123)=0 + IF(MSTP(14).EQ.12.OR.MSTP(14).EQ.14) MINT(123)=5 + IF(MSTP(14).EQ.13.OR.MSTP(14).EQ.17) MINT(123)=6 + IF(MSTP(14).EQ.15) MINT(123)=2 + IF(MSTP(14).EQ.16.OR.MSTP(14).EQ.18) MINT(123)=7 + IF(MSTP(14).EQ.19) MINT(123)=3 + ELSEIF(MSTP(14).GE.21.AND.MSTP(14).LE.24) THEN + IF(MSTP(14).EQ.21) MINT(123)=0 + IF(MSTP(14).EQ.22.OR.MSTP(14).EQ.23) MINT(123)=4 + IF(MSTP(14).EQ.24) MINT(123)=1 + ELSEIF(MSTP(14).GE.26.AND.MSTP(14).LE.29) THEN + IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.28) MINT(123)=8 + IF(MSTP(14).EQ.27.OR.MSTP(14).EQ.29) MINT(123)=9 + ENDIF + +C...Set up kinematics of process. + CALL PYINKI(0) + +C...Set up kinematics for photons inside leptons. + IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(1,WTGAGA) + +C...Precalculate flavour selection weights. + CALL PYKFIN + +C...Loop over gamma-p or gamma-gamma alternatives. + CKIN3=CKIN(3) + MSAV48=0 + DO 160 IGA=1,MINT(121) + CKIN(3)=CKIN3 + MINT(122)=IGA + +C...Select partonic subprocesses to be included in the simulation. + CALL PYINPR + MINT(101)=1 + MINT(102)=1 + MINT(103)=MINT(11) + MINT(104)=MINT(12) + +C...Count number of subprocesses on. + MINT(48)=0 + DO 130 ISUB=1,500 + IF(MINT(50).EQ.0.AND.ISUB.GE.91.AND.ISUB.LE.96.AND. + & MSUB(ISUB).EQ.1.AND.MINT(121).GT.1) THEN + MSUB(ISUB)=0 + ELSEIF(MINT(50).EQ.0.AND.ISUB.GE.91.AND.ISUB.LE.96.AND. + & MSUB(ISUB).EQ.1) THEN + WRITE(MSTU(11),5200) ISUB,CHLH(MINT(41)),CHLH(MINT(42)) + CALL PYSTOP(1) + ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).EQ.-1) THEN + WRITE(MSTU(11),5300) ISUB + CALL PYSTOP(1) + ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).LE.-2) THEN + WRITE(MSTU(11),5400) ISUB + CALL PYSTOP(1) + ELSEIF(MSUB(ISUB).EQ.1) THEN + MINT(48)=MINT(48)+1 + ENDIF + 130 CONTINUE + +C...Stop or raise warning flag if no subprocesses on. + IF(MINT(121).EQ.1.AND.MINT(48).EQ.0) THEN + IF(MSTP(127).NE.1) THEN + WRITE(MSTU(11),5500) + CALL PYSTOP(1) + ELSE + WRITE(MSTU(11),5700) + MSTI(53)=1 + ENDIF + ENDIF + MINT(49)=MINT(48)-MSUB(91)-MSUB(92)-MSUB(93)-MSUB(94) + MSAV48=MSAV48+MINT(48) + +C...Reset variables for cross-section calculation. + DO 150 I=0,500 + DO 140 J=1,3 + NGEN(I,J)=0 + XSEC(I,J)=0D0 + 140 CONTINUE + 150 CONTINUE + +C...Find parametrized total cross-sections. + CALL PYXTOT + VINT(318)=VINT(317) + +C...Maxima of differential cross-sections. + IF(MSTP(121).LE.1) CALL PYMAXI + +C...Initialize possibility of pileup events. + IF(MINT(121).GT.1) MSTP(131)=0 + IF(MSTP(131).NE.0) CALL PYPILE(1) + +C...Initialize multiple interactions with variable impact parameter. + IF(MINT(50).EQ.1) THEN + PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90) + IF(MOD(MSTP(81),10).EQ.0.AND.(CKIN(3).GT.PTMN.OR. + & ((MSEL.NE.1.AND.MSEL.NE.2)))) MSTP(82)=MIN(1,MSTP(82)) + IF((MINT(49).NE.0.OR.MSTP(131).NE.0).AND.MSTP(82).GE.2) THEN + MINT(35)=1 + CALL PYMULT(1) + MINT(35)=3 + CALL PYMIGN(1) + ENDIF + ENDIF + +C...Save results for gamma-p and gamma-gamma alternatives. + IF(MINT(121).GT.1) CALL PYSAVE(1,IGA) + 160 CONTINUE + +C...Initialization finished. + IF(MSAV48.EQ.0) THEN + IF(MSTP(127).NE.1) THEN + WRITE(MSTU(11),5500) + CALL PYSTOP(1) + ELSE + WRITE(MSTU(11),5700) + MSTI(53)=1 + ENDIF + ENDIF + 170 IF(MSTP(122).GE.1) WRITE(MSTU(11),5600) + +C...Formats for initialization information. + 5100 FORMAT('1',18('*'),1X,'PYINIT: initialization of PYTHIA ', + &'routines',1X,17('*')) + 5200 FORMAT(1X,'Error: process number ',I3,' not meaningful for ',A6, + &'-',A6,' interactions.'/1X,'Execution stopped!') + 5300 FORMAT(1X,'Error: requested subprocess',I4,' not implemented.'/ + &1X,'Execution stopped!') + 5400 FORMAT(1X,'Error: requested subprocess',I4,' not existing.'/ + &1X,'Execution stopped!') + 5500 FORMAT(1X,'Error: no subprocess switched on.'/ + &1X,'Execution stopped.') + 5600 FORMAT(/1X,22('*'),1X,'PYINIT: initialization completed',1X, + &22('*')) + 5700 FORMAT(1X,'Error: no subprocess switched on.'/ + &1X,'Execution will stop if you try to generate events.') + + RETURN + END + +C********************************************************************* + +C...PYEVNT +C...Administers the generation of a high-pT event via calls to +C...a number of subroutines. + + SUBROUTINE PYEVNT + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP + PARAMETER (MAXNUR=1000) +C...Commonblocks. + COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR) + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYCTAG/NCT,MCT(4000,2) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) + COMMON/PYINT4/MWID(500),WIDS(500,5) + COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) + SAVE /PYJETS/,/PYDAT1/,/PYCTAG/,/PYDAT2/,/PYDAT3/,/PYPARS/, + &/PYINT1/,/PYINT2/,/PYINT4/,/PYINT5/ +C...Local array. + DIMENSION VTX(4) + +C...Optionally let PYEVNW do the whole job. + IF(MSTP(81).GE.20) THEN + CALL PYEVNW + RETURN + ENDIF + +C...Stop if no subprocesses on. + IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN + WRITE(MSTU(11),5100) + CALL PYSTOP(1) + ENDIF + +C...Initial values for some counters. + MSTU(1)=0 + MSTU(2)=0 + N=0 + MINT(5)=MINT(5)+1 + MINT(7)=0 + MINT(8)=0 + MINT(30)=0 + MINT(83)=0 + MINT(84)=MSTP(126) + MSTU(24)=0 + MSTU70=0 + MSTJ14=MSTJ(14) +C...Normally, use K(I,4:5) colour info rather than /PYCTAG/. + NCT=0 + MINT(33)=0 + +C...Let called routines know call is from PYEVNT (not PYEVNW). + MINT(35)=1 + IF (MSTP(81).GE.10) MINT(35)=2 + +C...If variable energies: redo incoming kinematics and cross-section. + MSTI(61)=0 + IF(MSTP(171).EQ.1) THEN + CALL PYINKI(1) + IF(MSTI(61).EQ.1) THEN + MINT(5)=MINT(5)-1 + RETURN + ENDIF + IF(MINT(121).GT.1) CALL PYSAVE(3,1) + CALL PYXTOT + ENDIF + +C...Loop over number of pileup events; check space left. + IF(MSTP(131).LE.0) THEN + NPILE=1 + ELSE + CALL PYPILE(2) + NPILE=MINT(81) + ENDIF + DO 270 IPILE=1,NPILE + IF(MINT(84)+100.GE.MSTU(4)) THEN + CALL PYERRM(11, + & '(PYEVNT:) no more space in PYJETS for pileup events') + IF(MSTU(21).GE.1) GOTO 280 + ENDIF + MINT(82)=IPILE + +C...Generate variables of hard scattering. + MINT(51)=0 + MSTI(52)=0 + 100 CONTINUE + IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1 + MINT(31)=0 + MINT(39)=0 + MINT(51)=0 + MINT(57)=0 + CALL PYRAND + IF(MSTI(61).EQ.1) THEN + MINT(5)=MINT(5)-1 + RETURN + ENDIF + IF(MINT(51).EQ.2) RETURN + ISUB=MINT(1) + IF(MSTP(111).EQ.-1) GOTO 260 + +C...Loopback point if PYPREP fails, especially for junction topologies. + NPREP=0 + MNT31S=MINT(31) + 110 NPREP=NPREP+1 + MINT(31)=MNT31S + + IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN +C...Hard scattering (including low-pT): +C...reconstruct kinematics and colour flow of hard scattering. + MINT31=MINT(31) + 120 MINT(31)=MINT31 + MINT(51)=0 + CALL PYSCAT + IF(MINT(51).EQ.1) GOTO 100 + IPU1=MINT(84)+1 + IPU2=MINT(84)+2 + IF(ISUB.EQ.95) GOTO 140 + +C...Reset statistics on activity in event. + DO 130 J=351,359 + MINT(J)=0 + VINT(J)=0D0 + 130 CONTINUE + +C...Showering of initial state partons (optional). + NFIN=N + ALAMSV=PARJ(81) + PARJ(81)=PARP(72) + IF(MSTP(61).GE.1.AND.MINT(47).GE.2.AND.MINT(111).NE.12) + & CALL PYSSPA(IPU1,IPU2) + PARJ(81)=ALAMSV + IF(MINT(51).EQ.1) GOTO 100 + +C...pT-ordered FSR off ISR (optional, must have at least 2 partons) + IF (NPART.GE.2.AND.(MSTJ(41).EQ.11.OR.MSTJ(41).EQ.12)) THEN + PTMAX=0.5*SQRT(PARP(71))*VINT(55) + CALL PYPTFS(3,PTMAX,0D0,PTGEN) + ENDIF + +C...Showering of final state partons (optional). + ALAMSV=PARJ(81) + PARJ(81)=PARP(72) + IF(MSTP(71).GE.1.AND.ISET(ISUB).GE.2.AND.ISET(ISUB).LE.10) + & THEN + IPU3=MINT(84)+3 + IPU4=MINT(84)+4 + IF(ISET(ISUB).EQ.5) IPU4=-3 + QMAX=VINT(55) + IF(ISET(ISUB).EQ.2) QMAX=SQRT(PARP(71))*VINT(55) + CALL PYSHOW(IPU3,IPU4,QMAX) + ELSEIF(ISET(ISUB).EQ.11) THEN + CALL PYADSH(NFIN) + ENDIF + PARJ(81)=ALAMSV + +C...Allow possibility for user to abort event generation. + IVETO=0 + IF(IPILE.EQ.1.AND.MSTP(143).EQ.1) CALL PYVETO(IVETO) + IF(IVETO.EQ.1) GOTO 100 + +C...Decay of final state resonances. + MINT(32)=0 + IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10) CALL PYRESD(0) + IF(MINT(51).EQ.1) GOTO 100 + MINT(52)=N + + +C...Multiple interactions - PYTHIA 6.3 intermediate style. + 140 IF(MSTP(81).GE.10.AND.MINT(50).EQ.1) THEN + IF(ISUB.EQ.95) MINT(31)=MINT(31)+1 + CALL PYMIGN(6) + IF(MINT(51).EQ.1) GOTO 100 + MINT(53)=N + +C...Beam remnant flavour and colour assignments - new scheme. + CALL PYMIHK + IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5) + & GOTO 120 + IF(MINT(51).EQ.1) GOTO 100 + +C...Primordial kT and beam remnant momentum sharing - new scheme. + CALL PYMIRM + IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5) + & GOTO 120 + IF(MINT(51).EQ.1) GOTO 100 + IF(ISUB.EQ.95) MINT(31)=MINT(31)-1 + +C...Multiple interactions - PYTHIA 6.2 style. + ELSEIF(MINT(111).NE.12) THEN + IF (MSTP(81).GE.1.AND.MINT(50).EQ.1.AND.ISUB.NE.95) THEN + CALL PYMULT(6) + MINT(53)=N + ENDIF + +C...Hadron remnants and primordial kT. + CALL PYREMN(IPU1,IPU2) + IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5) GOTO + & 110 + IF(MINT(51).EQ.1) GOTO 100 + ENDIF + + ELSEIF(ISUB.NE.99) THEN +C...Diffractive and elastic scattering. + CALL PYDIFF + + ELSE +C...DIS scattering (photon flux external). + CALL PYDISG + IF(MINT(51).EQ.1) GOTO 100 + ENDIF + +C...Check that no odd resonance left undecayed. + MINT(54)=N + IF(MSTP(111).GE.1) THEN + NFIX=N + DO 150 I=MINT(84)+1,NFIX + IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND. + & K(I,2).NE.22) THEN + KCA=PYCOMP(K(I,2)) + IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN + CALL PYRESD(I) + IF(MINT(51).EQ.1) GOTO 100 + ENDIF + ENDIF + 150 CONTINUE + ENDIF + +C...Boost hadronic subsystem to overall rest frame. +C..(Only relevant when photon inside lepton beam.) + IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA) + +C...Recalculate energies from momenta and masses (if desired). + IF(MSTP(113).GE.1) THEN + DO 160 I=MINT(83)+1,N + IF(K(I,1).GT.0.AND.K(I,1).LE.10) P(I,4)=SQRT(P(I,1)**2+ + & P(I,2)**2+P(I,3)**2+P(I,5)**2) + 160 CONTINUE + NRECAL=N + ENDIF + +C...Colour reconnection before string formation + IF (MSTP(95).GE.2) CALL PYFSCR(MINT(84)+1) + +C...Rearrange partons along strings, check invariant mass cuts. + MSTU(28)=0 + IF(MSTP(111).LE.0) MSTJ(14)=-1 + CALL PYPREP(MINT(84)+1) + MSTJ(14)=MSTJ14 + IF(MINT(51).EQ.1.AND.MSTU(24).EQ.1) THEN + MSTU(24)=0 + GOTO 100 + ENDIF + IF (MINT(51).EQ.1.AND.NPREP.LE.5) GOTO 110 + IF (MINT(51).EQ.1) GOTO 100 + IF(MSTP(112).EQ.1.AND.MSTU(28).EQ.3) GOTO 100 + IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) THEN + DO 190 I=MINT(84)+1,N + IF(K(I,2).EQ.94) THEN + DO 180 I1=I+1,MIN(N,I+10) + IF(K(I1,3).EQ.I) THEN + K(I1,3)=MOD(K(I1,4)/MSTU(5),MSTU(5)) + IF(K(I1,3).EQ.0) THEN + DO 170 II=MINT(84)+1,I-1 + IF(K(II,2).EQ.K(I1,2)) THEN + IF(MOD(K(II,4),MSTU(5)).EQ.I1.OR. + & MOD(K(II,5),MSTU(5)).EQ.I1) K(I1,3)=II + ENDIF + 170 CONTINUE + IF(K(I+1,3).EQ.0) K(I+1,3)=K(I,3) + ENDIF + ENDIF + 180 CONTINUE + ENDIF + 190 CONTINUE + CALL PYEDIT(12) + CALL PYEDIT(14) + IF(MSTP(125).EQ.0) CALL PYEDIT(15) + IF(MSTP(125).EQ.0) MINT(4)=0 + DO 210 I=MINT(83)+1,N + IF(K(I,1).EQ.11.AND.K(I,4).EQ.0.AND.K(I,5).EQ.0) THEN + DO 200 I1=I+1,N + IF(K(I1,3).EQ.I.AND.K(I,4).EQ.0) K(I,4)=I1 + IF(K(I1,3).EQ.I) K(I,5)=I1 + 200 CONTINUE + ENDIF + 210 CONTINUE + ENDIF + +C...Introduce separators between sections in PYLIST event listing. + IF(IPILE.EQ.1.AND.MSTP(125).LE.0) THEN + MSTU70=1 + MSTU(71)=N + ELSEIF(IPILE.EQ.1) THEN + MSTU70=3 + MSTU(71)=2 + MSTU(72)=MINT(4) + MSTU(73)=N + ENDIF + +C...Go back to lab frame (needed for vertices, also in fragmentation). + CALL PYFRAM(1) + +C...Set nonvanishing production vertex (optional). + IF(MSTP(151).EQ.1) THEN + DO 220 J=1,4 + VTX(J)=PARP(150+J)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0))))* + & SIN(PARU(2)*PYR(0)) + 220 CONTINUE + DO 240 I=MINT(83)+1,N + DO 230 J=1,4 + V(I,J)=V(I,J)+VTX(J) + 230 CONTINUE + 240 CONTINUE + ENDIF + +C...Perform hadronization (if desired). + IF(MSTP(111).GE.1) THEN + CALL PYEXEC + IF(MSTU(24).NE.0) GOTO 100 + ENDIF + IF(MSTP(113).GE.1) THEN + DO 250 I=NRECAL,N + IF(P(I,5).GT.0D0) P(I,4)=SQRT(P(I,1)**2+ + & P(I,2)**2+P(I,3)**2+P(I,5)**2) + 250 CONTINUE + ENDIF + IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) CALL PYEDIT(14) + +C...Store event information and calculate Monte Carlo estimates of +C...subprocess cross-sections. + 260 IF(IPILE.EQ.1) CALL PYDOCU + +C...Set counters for current pileup event and loop to next one. + MSTI(41)=IPILE + IF(IPILE.GE.2.AND.IPILE.LE.10) MSTI(40+IPILE)=ISUB + IF(MSTU70.LT.10) THEN + MSTU70=MSTU70+1 + MSTU(70+MSTU70)=N + ENDIF + MINT(83)=N + MINT(84)=N+MSTP(126) + IF(IPILE.LT.NPILE) CALL PYFRAM(2) + 270 CONTINUE + +C...Generic information on pileup events. Reconstruct missing history. + IF(MSTP(131).EQ.1.AND.MSTP(133).GE.1) THEN + PARI(91)=VINT(132) + PARI(92)=VINT(133) + PARI(93)=VINT(134) + IF(MSTP(133).GE.2) PARI(93)=PARI(93)*XSEC(0,3)/VINT(131) + ENDIF + CALL PYEDIT(16) + +C...Transform to the desired coordinate frame. + 280 CALL PYFRAM(MSTP(124)) + MSTU(70)=MSTU70 + PARU(21)=VINT(1) + +C...Error messages + 5100 FORMAT(1X,'Error: no subprocess switched on.'/ + &1X,'Execution stopped.') + + RETURN + END + +C********************************************************************* + +C...PYEVNW +C...Administers the generation of a high-pT event via calls to +C...a number of subroutines for the new multiple interactions and +C...showering framework. + + SUBROUTINE PYEVNW + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP + PARAMETER (MAXNUR=1000) +C...Commonblocks. + COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR) +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYCTAG/NCT,MCT(4000,2) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) + COMMON/PYINT4/MWID(500),WIDS(500,5) + COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) + COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6), + & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1), + & XMI(2,240),PT2MI(240),IMISEP(0:240) + SAVE /PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/, + & /PYPARS/,/PYINT1/,/PYINT2/,/PYINT4/,/PYINT5/,/PYINTM/ +C...Local arrays. + DIMENSION VTX(4) + +C...Stop if no subprocesses on. + IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN + WRITE(MSTU(11),5100) + CALL PYSTOP(1) + ENDIF + +C...Initial values for some counters. + MSTU(1)=0 + MSTU(2)=0 + N=0 + MINT(5)=MINT(5)+1 + MINT(7)=0 + MINT(8)=0 + MINT(30)=0 + MINT(83)=0 + MINT(84)=MSTP(126) + MSTU(24)=0 + MSTU70=0 + MSTJ14=MSTJ(14) +C...Normally, use K(I,4:5) colour info rather than /PYCT/. + NCT=0 + MINT(33)=0 +C...Zero counters for pT-ordered showers (failsafe) + NPART=0 + NPARTD=0 + +C...Let called routines know call is from PYEVNW (not PYEVNT). + MINT(35)=3 + +C...If variable energies: redo incoming kinematics and cross-section. + MSTI(61)=0 + IF(MSTP(171).EQ.1) THEN + CALL PYINKI(1) + IF(MSTI(61).EQ.1) THEN + MINT(5)=MINT(5)-1 + RETURN + ENDIF + IF(MINT(121).GT.1) CALL PYSAVE(3,1) + CALL PYXTOT + ENDIF + +C...Loop over number of pileup events; check space left. + IF(MSTP(131).LE.0) THEN + NPILE=1 + ELSE + CALL PYPILE(2) + NPILE=MINT(81) + ENDIF + DO 300 IPILE=1,NPILE + IF(MINT(84)+100.GE.MSTU(4)) THEN + CALL PYERRM(11, + & '(PYEVNW:) no more space in PYJETS for pileup events') + IF(MSTU(21).GE.1) GOTO 310 + ENDIF + MINT(82)=IPILE + +C...Generate variables of hard scattering. + MINT(51)=0 + MSTI(52)=0 + LOOPHS =0 + 100 CONTINUE + LOOPHS = LOOPHS + 1 + IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1 + IF(LOOPHS.GE.10) THEN + CALL PYERRM(19,'(PYEVNW:) failed to evolve shower or ' + & //'multiple interactions. Returning.') + MINT(51)=1 + RETURN + ENDIF + MINT(31)=0 + MINT(39)=0 + MINT(36)=0 + MINT(51)=0 + MINT(57)=0 + CALL PYRAND + IF(MSTI(61).EQ.1) THEN + MINT(5)=MINT(5)-1 + RETURN + ENDIF + IF(MINT(51).EQ.2) RETURN + ISUB=MINT(1) + IF(MSTP(111).EQ.-1) GOTO 290 + +C...Loopback point if PYPREP fails, especially for junction topologies. + NPREP=0 + MNT31S=MINT(31) + 110 NPREP=NPREP+1 + MINT(31)=MNT31S + + IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN +C...Hard scattering (including low-pT): +C...reconstruct kinematics and colour flow of hard scattering. + MINT31=MINT(31) + 120 MINT(31)=MINT31 + MINT(51)=0 + CALL PYSCAT + IF(MINT(51).EQ.1) GOTO 100 + NPARTD=N + NFIN=N + +C...Intertwined initial state showers and multiple interactions. +C...Force no IS showers if no pdfs defined: MSTP(61) -> 0 for PYEVOL. +C...Force no MI if cross section not known: MSTP(81) -> 0 for PYEVOL. + MSTP61=MSTP(61) + IF (MINT(47).LT.2) MSTP(61)=0 + MSTP81=MSTP(81) + IF (MINT(50).EQ.0) MSTP(81)=0 + IF ((MSTP(61).GE.1.OR.MOD(MSTP(81),10).GE.0).AND. + & MINT(111).NE.12) THEN +C...Absolute max pT2 scale for evolution: phase space limit. + PT2MXS=0.25D0*VINT(2) +C...Check if more constrained by ISR and MI max scales: + PT2MXS=MIN(PT2MXS,MAX(MAX(1D0,PARP(67))*VINT(56),VINT(62))) +C...Loopback point in case of failure in evolution. + LOOP=0 + 130 LOOP=LOOP+1 + MINT(51)=0 + IF(LOOP.GT.100) THEN + CALL PYERRM(9,'(PYEVNW:) failed to evolve shower or ' + & //'multiple interactions. Trying new point.') + MINT(51)=1 + RETURN + ENDIF + +C...Pre-initialization of interleaved MI/ISR/JI evolution, only done +C...once per event. (E.g. compute constants and save variables to be +C...restored later in case of failure.) + IF (LOOP.EQ.1) CALL PYEVOL(-1,DUMMY1,DUMMY2) + +C...Initialize interleaved MI/ISR/JI evolution. +C...PT2MAX: absolute upper limit for evolution - Initialization may +C... return a PT2MAX which is lower than this. +C...PT2MIN: absolute lower limit for evolution - Initialization may +C... return a PT2MIN which is larger than this (e.g. Lambda_QCD). + PT2MAX=PT2MXS + PT2MIN=0D0 + CALL PYEVOL(0,PT2MAX,PT2MIN) +C...If failed to initialize evolution, generate a new hard process + IF (MINT(51).EQ.1) GOTO 100 + +C...Perform interleaved MI/ISR/JI evolution from PT2MAX to PT2MIN. +C...In principle factorized, so can be stopped and restarted. +C...Example: stop/start at pT=10 GeV. (Commented out for now.) +C PT2MED=MAX(10D0**2,PT2MIN) +C CALL PYEVOL(1,PT2MAX,PT2MED) +C IF (MINT(51).EQ.1) GOTO 160 +C PT2MAX=PT2MED + CALL PYEVOL(1,PT2MAX,PT2MIN) +C...If fatal error (e.g., massive hard-process initiator, but no available +C...phase space for creation), generate a new hard process + IF (MINT(51).EQ.2) GOTO 100 +C...If smaller error, just try running evolution again + IF (MINT(51).EQ.1) GOTO 130 + +C...Finalize interleaved MI/ISR/JI evolution. + CALL PYEVOL(2,PT2MAX,PT2MIN) + IF (MINT(51).EQ.1) GOTO 130 + + ENDIF + MSTP(61)=MSTP61 + MSTP(81)=MSTP81 + IF(MINT(51).EQ.1) GOTO 100 +C...(MINT(52) is actually obsolete in this routine. Set anyway +C...to ensure PYDOCU stable.) + MINT(52)=N + MINT(53)=N + +C...Beam remnants - new scheme. + 140 IF(MINT(50).EQ.1) THEN + IF (ISUB.EQ.95) MINT(31)=1 + +C...Beam remnant flavour and colour assignments - new scheme. + CALL PYMIHK + IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5) + & GOTO 120 + IF(MINT(51).EQ.1) GOTO 100 + +C...Primordial kT and beam remnant momentum sharing - new scheme. + CALL PYMIRM + IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5) + & GOTO 120 + IF(MINT(51).EQ.1) GOTO 100 + IF (ISUB.EQ.95) MINT(31)=0 + ELSEIF(MINT(111).NE.12) THEN +C...Hadron remnants and primordial kT - old model. +C...Happens e.g. for direct photon on one side. + IPU1=IMI(1,1,1) + IPU2=IMI(2,1,1) + CALL PYREMN(IPU1,IPU2) + IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5) GOTO + & 110 + IF(MINT(51).EQ.1) GOTO 100 +C...PYREMN does not set colour tags for BRs, so needs to be done now. + DO 160 I=MINT(53)+1,N + DO 150 KCS=4,5 + IDA=MOD(K(I,KCS),MSTU(5)) + IF (IDA.NE.0) THEN + MCT(I,KCS-3)=MCT(IDA,6-KCS) + ELSE + MCT(I,KCS-3)=0 + ENDIF + 150 CONTINUE + 160 CONTINUE +C...Instruct PYPREP to use colour tags + MINT(33)=1 + + DO 360 MQGST=1,2 + DO 350 I=MINT(84)+1,N + +C...Look for coloured string endpoint, or (later) leftover gluon. + IF (K(I,1).NE.3) GOTO 350 + KC=PYCOMP(K(I,2)) + IF(KC.EQ.0) GOTO 350 + KQ=KCHG(KC,2) + IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 350 + +C... Pick up loose string end with no previous tag. + KCS=4 + IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5 + IF(MCT(I,KCS-3).NE.0) GOTO 350 + + CALL PYCTTR(I,KCS,I) + IF(MINT(51).NE.0) RETURN + + 350 CONTINUE + 360 CONTINUE +C...Now delete any colour processing information if set (since partons +C...otherwise not FS showered!) + DO 170 I=MINT(84)+1,N + IF (I.LE.N) THEN + K(I,4)=MOD(K(I,4),MSTU(5)**2) + K(I,5)=MOD(K(I,5),MSTU(5)**2) + ENDIF + 170 CONTINUE + ENDIF + +C...Showering of final state partons (optional). + ALAMSV=PARJ(81) + PARJ(81)=PARP(72) + IF(MSTP(71).GE.1.AND.ISET(ISUB).GE.1.AND.ISET(ISUB).LE.10) + & THEN + QMAX=VINT(55) + IF(ISET(ISUB).EQ.2) QMAX=SQRT(PARP(71))*VINT(55) + CALL PYPTFS(1,QMAX,0D0,PTGEN) +C...External processes: handle successive showers. + ELSEIF(ISET(ISUB).EQ.11) THEN + CALL PYADSH(NFIN) + ENDIF + PARJ(81)=ALAMSV + +C...Allow possibility for user to abort event generation. + IVETO=0 + IF(IPILE.EQ.1.AND.MSTP(143).EQ.1) CALL PYVETO(IVETO) ! sm + IF(IVETO.EQ.1) THEN +C...........No reason to count this as an error + LOOPHS = LOOPHS-1 + GOTO 100 + ENDIF + + +C...Decay of final state resonances. + MINT(32)=0 + IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10) THEN + CALL PYRESD(0) + IF(MINT(51).NE.0) GOTO 100 + ENDIF + + IF(MINT(51).EQ.1) GOTO 100 + + ELSEIF(ISUB.NE.99) THEN +C...Diffractive and elastic scattering. + CALL PYDIFF + + ELSE +C...DIS scattering (photon flux external). + CALL PYDISG + IF(MINT(51).EQ.1) GOTO 100 + ENDIF + +C...Check that no odd resonance left undecayed. + MINT(54)=N + IF(MSTP(111).GE.1) THEN + NFIX=N + DO 180 I=MINT(84)+1,NFIX + IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND. + & K(I,2).NE.22) THEN + KCA=PYCOMP(K(I,2)) + IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN + CALL PYRESD(I) + IF(MINT(51).EQ.1) GOTO 100 + ENDIF + ENDIF + 180 CONTINUE + ENDIF + +C...Boost hadronic subsystem to overall rest frame. +C..(Only relevant when photon inside lepton beam.) + IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA) + +C...Recalculate energies from momenta and masses (if desired). + IF(MSTP(113).GE.1) THEN + DO 190 I=MINT(83)+1,N + IF(K(I,1).GT.0.AND.K(I,1).LE.10) P(I,4)=SQRT(P(I,1)**2+ + & P(I,2)**2+P(I,3)**2+P(I,5)**2) + 190 CONTINUE + NRECAL=N + ENDIF + +C...Colour reconnection before string formation + CALL PYFSCR(MINT(84)+1) + +C...Rearrange partons along strings, check invariant mass cuts. + MSTU(28)=0 + IF(MSTP(111).LE.0) MSTJ(14)=-1 + CALL PYPREP(MINT(84)+1) + MSTJ(14)=MSTJ14 + IF(MINT(51).EQ.1.AND.MSTU(24).EQ.1) THEN + MSTU(24)=0 + GOTO 100 + ENDIF + IF(MINT(51).EQ.1) GOTO 110 + IF(MSTP(112).EQ.1.AND.MSTU(28).EQ.3) GOTO 100 + IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) THEN + DO 220 I=MINT(84)+1,N + IF(K(I,2).EQ.94) THEN + DO 210 I1=I+1,MIN(N,I+10) + IF(K(I1,3).EQ.I) THEN + K(I1,3)=MOD(K(I1,4)/MSTU(5),MSTU(5)) + IF(K(I1,3).EQ.0) THEN + DO 200 II=MINT(84)+1,I-1 + IF(K(II,2).EQ.K(I1,2)) THEN + IF(MOD(K(II,4),MSTU(5)).EQ.I1.OR. + & MOD(K(II,5),MSTU(5)).EQ.I1) K(I1,3)=II + ENDIF + 200 CONTINUE + IF(K(I+1,3).EQ.0) K(I+1,3)=K(I,3) + ENDIF + ENDIF + 210 CONTINUE +C...Also collapse particles decaying to themselves (if same KS) +C...Sep 22 2009: Commented out by PS following suggestion by TS to fix +C...problem with history point-backs in new shower, where a particle is +C...copied with a new momentum when it is the recoiler. +C ELSEIF (K(I,1).GT.0.AND.K(I,4).EQ.K(I,5).AND.K(I,4).GT.0 +C & .AND.K(I,4).LT.N) THEN +C IDA=K(I,4) +C IF (K(IDA,1).EQ.K(I,1).AND.K(IDA,2).EQ.K(I,2)) THEN +C K(I,1)=0 +C ENDIF + ENDIF + 220 CONTINUE + CALL PYEDIT(12) + CALL PYEDIT(14) + IF(MSTP(125).EQ.0) CALL PYEDIT(15) + IF(MSTP(125).EQ.0) MINT(4)=0 + DO 240 I=MINT(83)+1,N + IF(K(I,1).EQ.11.AND.K(I,4).EQ.0.AND.K(I,5).EQ.0) THEN + DO 230 I1=I+1,N + IF(K(I1,3).EQ.I.AND.K(I,4).EQ.0) K(I,4)=I1 + IF(K(I1,3).EQ.I) K(I,5)=I1 + 230 CONTINUE + ENDIF + 240 CONTINUE + ENDIF + +C...Introduce separators between sections in PYLIST event listing. + IF(IPILE.EQ.1.AND.MSTP(125).LE.0) THEN + MSTU70=1 + MSTU(71)=N + ELSEIF(IPILE.EQ.1) THEN + MSTU70=3 + MSTU(71)=2 + MSTU(72)=MINT(4) + MSTU(73)=N + ENDIF + +C...Go back to lab frame (needed for vertices, also in fragmentation). + CALL PYFRAM(1) + +C...Set nonvanishing production vertex (optional). + IF(MSTP(151).EQ.1) THEN + DO 250 J=1,4 + VTX(J)=PARP(150+J)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0))))* + & SIN(PARU(2)*PYR(0)) + 250 CONTINUE + DO 270 I=MINT(83)+1,N + DO 260 J=1,4 + V(I,J)=V(I,J)+VTX(J) + 260 CONTINUE + 270 CONTINUE + ENDIF + +C...Perform hadronization (if desired). + IF(MSTP(111).GE.1) THEN + CALL PYEXEC + IF(MSTU(24).NE.0) GOTO 100 + ENDIF + IF(MSTP(113).GE.1) THEN + DO 280 I=NRECAL,N + IF(P(I,5).GT.0D0) P(I,4)=SQRT(P(I,1)**2+ + & P(I,2)**2+P(I,3)**2+P(I,5)**2) + 280 CONTINUE + ENDIF + IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) CALL PYEDIT(14) + +C...Store event information and calculate Monte Carlo estimates of +C...subprocess cross-sections. + 290 IF(IPILE.EQ.1) CALL PYDOCU + +C...Set counters for current pileup event and loop to next one. + MSTI(41)=IPILE + IF(IPILE.GE.2.AND.IPILE.LE.10) MSTI(40+IPILE)=ISUB + IF(MSTU70.LT.10) THEN + MSTU70=MSTU70+1 + MSTU(70+MSTU70)=N + ENDIF + MINT(83)=N + MINT(84)=N+MSTP(126) + IF(IPILE.LT.NPILE) CALL PYFRAM(2) + 300 CONTINUE + +C...Generic information on pileup events. Reconstruct missing history. + IF(MSTP(131).EQ.1.AND.MSTP(133).GE.1) THEN + PARI(91)=VINT(132) + PARI(92)=VINT(133) + PARI(93)=VINT(134) + IF(MSTP(133).GE.2) PARI(93)=PARI(93)*XSEC(0,3)/VINT(131) + ENDIF + CALL PYEDIT(16) + +C...Transform to the desired coordinate frame. + 310 CALL PYFRAM(MSTP(124)) + MSTU(70)=MSTU70 + PARU(21)=VINT(1) + +C...Error messages + 5100 FORMAT(1X,'Error: no subprocess switched on.'/ + &1X,'Execution stopped.') + + RETURN + END + + +C*********************************************************************** + +C...PYSTAT +C...Prints out information about cross-sections, decay widths, branching +C...ratios, kinematical limits, status codes and parameter values. + + SUBROUTINE PYSTAT(MSTAT) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) + PARAMETER (EPS=1D-3) +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) + COMMON/PYINT4/MWID(500),WIDS(500,5) + COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) + COMMON/PYINT6/PROC(0:500) + CHARACTER PROC*28, CHTMP*16 + COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) + COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3) + SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/, + &/PYINT2/,/PYINT4/,/PYINT5/,/PYINT6/,/PYMSSM/,/PYMSRV/ +C...Local arrays, character variables and data. + DIMENSION WDTP(0:400),WDTE(0:400,0:5),NMODES(0:20),PBRAT(10) + CHARACTER PROGA(6)*28,CHAU*16,CHKF*16,CHD1*16,CHD2*16,CHD3*16, + &CHIN(2)*12,STATE(-1:5)*4,CHKIN(21)*18,DISGA(2)*28, + &PROGG9(13)*28,PROGG4(4)*28,PROGG2(2)*28,PROGP4(4)*28 + CHARACTER*24 CHD0, CHDC(10) + CHARACTER*6 DNAME(3) + DATA PROGA/ + &'VMD/hadron * VMD ','VMD/hadron * direct ', + &'VMD/hadron * anomalous ','direct * direct ', + &'direct * anomalous ','anomalous * anomalous '/ + DATA DISGA/'e * VMD','e * anomalous'/ + DATA PROGG9/ + &'direct * direct ','direct * VMD ', + &'direct * anomalous ','VMD * direct ', + &'VMD * VMD ','VMD * anomalous ', + &'anomalous * direct ','anomalous * VMD ', + &'anomalous * anomalous ','DIS * VMD ', + &'DIS * anomalous ','VMD * DIS ', + &'anomalous * DIS '/ + DATA PROGG4/ + &'direct * direct ','direct * resolved ', + &'resolved * direct ','resolved * resolved '/ + DATA PROGG2/ + &'direct * hadron ','resolved * hadron '/ + DATA PROGP4/ + &'VMD * hadron ','direct * hadron ', + &'anomalous * hadron ','DIS * hadron '/ + DATA STATE/'----','off ','on ','on/+','on/-','on/1','on/2'/, + &CHKIN/' m_hard (GeV/c^2) ',' p_T_hard (GeV/c) ', + &'m_finite (GeV/c^2)',' y*_subsystem ',' y*_large ', + &' y*_small ',' eta*_large ',' eta*_small ', + &'cos(theta*)_large ','cos(theta*)_small ',' x_1 ', + &' x_2 ',' x_F ',' cos(theta_hard) ', + &'m''_hard (GeV/c^2) ',' tau ',' y* ', + &'cos(theta_hard^-) ','cos(theta_hard^+) ',' x_T^2 ', + &' tau'' '/ + DATA DNAME /'q ','lepton','nu '/ + +C...Cross-sections. + IF(MSTAT.LE.1) THEN + IF(MINT(121).GT.1) CALL PYSAVE(5,0) + WRITE(MSTU(11),5000) + WRITE(MSTU(11),5100) + WRITE(MSTU(11),5200) 0,PROC(0),NGEN(0,3),NGEN(0,1),XSEC(0,3) + DO 100 I=1,500 + IF(MSUB(I).NE.1) GOTO 100 + WRITE(MSTU(11),5200) I,PROC(I),NGEN(I,3),NGEN(I,1),XSEC(I,3) + 100 CONTINUE + IF(MINT(121).GT.1) THEN + WRITE(MSTU(11),5300) + DO 110 IGA=1,MINT(121) + CALL PYSAVE(3,IGA) + IF(MINT(121).EQ.2.AND.MSTP(14).EQ.10) THEN + WRITE(MSTU(11),5200) IGA,DISGA(IGA),NGEN(0,3),NGEN(0,1), + & XSEC(0,3) + ELSEIF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN + WRITE(MSTU(11),5200) IGA,PROGG9(IGA),NGEN(0,3),NGEN(0,1), + & XSEC(0,3) + ELSEIF(MINT(121).EQ.4.AND.MSTP(14).EQ.30) THEN + WRITE(MSTU(11),5200) IGA,PROGP4(IGA),NGEN(0,3),NGEN(0,1), + & XSEC(0,3) + ELSEIF(MINT(121).EQ.4) THEN + WRITE(MSTU(11),5200) IGA,PROGG4(IGA),NGEN(0,3),NGEN(0,1), + & XSEC(0,3) + ELSEIF(MINT(121).EQ.2) THEN + WRITE(MSTU(11),5200) IGA,PROGG2(IGA),NGEN(0,3),NGEN(0,1), + & XSEC(0,3) + ELSE + WRITE(MSTU(11),5200) IGA,PROGA(IGA),NGEN(0,3),NGEN(0,1), + & XSEC(0,3) + ENDIF + 110 CONTINUE + CALL PYSAVE(5,0) + ENDIF + WRITE(MSTU(11),5400) MSTU(23),MSTU(30),MSTU(27), + & 1D0-DBLE(NGEN(0,3))/MAX(1D0,DBLE(NGEN(0,2))) + +C...Decay widths and branching ratios. + ELSEIF(MSTAT.EQ.2) THEN + WRITE(MSTU(11),5500) + WRITE(MSTU(11),5600) + DO 140 KC=1,500 + KF=KCHG(KC,4) + CALL PYNAME(KF,CHKF) + IOFF=0 + IF(KC.LE.22) THEN + IF(KC.GT.2*MSTP(1).AND.KC.LE.10) GOTO 140 + IF(KC.GT.10+2*MSTP(1).AND.KC.LE.20) GOTO 140 + IF(KC.LE.5.OR.(KC.GE.11.AND.KC.LE.16)) IOFF=1 + IF(KC.EQ.18.AND.PMAS(18,1).LT.1D0) IOFF=1 + IF(KC.EQ.21.OR.KC.EQ.22) IOFF=1 + ELSE + IF(MWID(KC).LE.0) GOTO 140 + IF(IMSS(1).LE.0.AND.(KF/KSUSY1.EQ.1.OR. + & KF/KSUSY1.EQ.2)) GOTO 140 + ENDIF +C...Off-shell branchings. + IF(IOFF.EQ.1) THEN + NGP=0 + IF(KC.LE.20) NGP=(MOD(KC,10)+1)/2 + IF(NGP.LE.MSTP(1)) WRITE(MSTU(11),5700) KF,CHKF(1:10), + & PMAS(KC,1),0D0,0D0,STATE(MDCY(KC,1)),0D0 + DO 120 J=1,MDCY(KC,3) + IDC=J+MDCY(KC,2)-1 + NGP1=0 + IF(IABS(KFDP(IDC,1)).LE.20) NGP1= + & (MOD(IABS(KFDP(IDC,1)),10)+1)/2 + NGP2=0 + IF(IABS(KFDP(IDC,2)).LE.20) NGP2= + & (MOD(IABS(KFDP(IDC,2)),10)+1)/2 + CALL PYNAME(KFDP(IDC,1),CHD1) + CALL PYNAME(KFDP(IDC,2),CHD2) + IF(KFDP(IDC,3).EQ.0) THEN + IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND. + & NGP2.LE.MSTP(1)) WRITE(MSTU(11),5800) IDC,CHD1(1:10), + & CHD2(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0 + ELSE + CALL PYNAME(KFDP(IDC,3),CHD3) + IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND. + & NGP2.LE.MSTP(1)) WRITE(MSTU(11),5900) IDC,CHD1(1:10), + & CHD2(1:10),CHD3(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0 + ENDIF + 120 CONTINUE +C...On-shell decays. + ELSE + CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE) + BRFIN=1D0 + IF(WDTE(0,0).LE.0D0) BRFIN=0D0 + WRITE(MSTU(11),5700) KF,CHKF(1:10),PMAS(KC,1),WDTP(0),1D0, + & STATE(MDCY(KC,1)),BRFIN + DO 130 J=1,MDCY(KC,3) + IDC=J+MDCY(KC,2)-1 + NGP1=0 + IF(IABS(KFDP(IDC,1)).LE.20) NGP1= + & (MOD(IABS(KFDP(IDC,1)),10)+1)/2 + NGP2=0 + IF(IABS(KFDP(IDC,2)).LE.20) NGP2= + & (MOD(IABS(KFDP(IDC,2)),10)+1)/2 + BRPRI=0D0 + IF(WDTP(0).GT.0D0) BRPRI=WDTP(J)/WDTP(0) + BRFIN=0D0 + IF(WDTE(0,0).GT.0D0) BRFIN=WDTE(J,0)/WDTE(0,0) + CALL PYNAME(KFDP(IDC,1),CHD1) + CALL PYNAME(KFDP(IDC,2),CHD2) + IF(KFDP(IDC,3).EQ.0) THEN + IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1)) + & WRITE(MSTU(11),5800) IDC,CHD1(1:10), + & CHD2(1:10),WDTP(J),BRPRI, + & STATE(MDME(IDC,1)),BRFIN + ELSE + CALL PYNAME(KFDP(IDC,3),CHD3) + IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1)) + & WRITE(MSTU(11),5900) IDC,CHD1(1:10), + & CHD2(1:10),CHD3(1:10),WDTP(J),BRPRI, + & STATE(MDME(IDC,1)),BRFIN + ENDIF + 130 CONTINUE + ENDIF + 140 CONTINUE + WRITE(MSTU(11),6000) + +C...Allowed incoming partons/particles at hard interaction. + ELSEIF(MSTAT.EQ.3) THEN + WRITE(MSTU(11),6100) + CALL PYNAME(MINT(11),CHAU) + CHIN(1)=CHAU(1:12) + CALL PYNAME(MINT(12),CHAU) + CHIN(2)=CHAU(1:12) + WRITE(MSTU(11),6200) CHIN(1),CHIN(2) + DO 150 I=-20,22 + IF(I.EQ.0) GOTO 150 + IA=IABS(I) + IF(IA.GT.MSTP(58).AND.IA.LE.10) GOTO 150 + IF(IA.GT.10+2*MSTP(1).AND.IA.LE.20) GOTO 150 + CALL PYNAME(I,CHAU) + WRITE(MSTU(11),6300) CHAU,STATE(KFIN(1,I)),CHAU, + & STATE(KFIN(2,I)) + 150 CONTINUE + WRITE(MSTU(11),6400) + +C...User-defined limits on kinematical variables. + ELSEIF(MSTAT.EQ.4) THEN + WRITE(MSTU(11),6500) + WRITE(MSTU(11),6600) + SHRMAX=CKIN(2) + IF(SHRMAX.LT.0D0) SHRMAX=VINT(1) + WRITE(MSTU(11),6700) CKIN(1),CHKIN(1),SHRMAX + PTHMIN=MAX(CKIN(3),CKIN(5)) + PTHMAX=CKIN(4) + IF(PTHMAX.LT.0D0) PTHMAX=0.5D0*SHRMAX + WRITE(MSTU(11),6800) CKIN(3),PTHMIN,CHKIN(2),PTHMAX + WRITE(MSTU(11),6900) CHKIN(3),CKIN(6) + DO 160 I=4,14 + WRITE(MSTU(11),6700) CKIN(2*I-1),CHKIN(I),CKIN(2*I) + 160 CONTINUE + SPRMAX=CKIN(32) + IF(SPRMAX.LT.0D0) SPRMAX=VINT(1) + WRITE(MSTU(11),6700) CKIN(31),CHKIN(15),SPRMAX + WRITE(MSTU(11),7000) + +C...Status codes and parameter values. + ELSEIF(MSTAT.EQ.5) THEN + WRITE(MSTU(11),7100) + WRITE(MSTU(11),7200) + DO 170 I=1,100 + WRITE(MSTU(11),7300) I,MSTP(I),PARP(I),100+I,MSTP(100+I), + & PARP(100+I) + 170 CONTINUE + +C...List of all processes implemented in the program. + ELSEIF(MSTAT.EQ.6) THEN + WRITE(MSTU(11),7400) + WRITE(MSTU(11),7500) + DO 180 I=1,500 + IF(ISET(I).LT.0) GOTO 180 + WRITE(MSTU(11),7600) I,PROC(I),ISET(I),KFPR(I,1),KFPR(I,2) + 180 CONTINUE + WRITE(MSTU(11),7700) + + ELSEIF(MSTAT.EQ.7) THEN + WRITE (MSTU(11),8000) + NMODES(0)=0 + NMODES(10)=0 + NMODES(9)=0 + DO 290 ILR=1,2 + DO 280 KFSM=1,16 + KFSUSY=ILR*KSUSY1+KFSM + NRVDC=0 +C...SDOWN DECAYS + IF (KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5) THEN + NRVDC=3 + DO 190 I=1,NRVDC + PBRAT(I)=0D0 + NMODES(I)=0 + 190 CONTINUE + CALL PYNAME(KFSUSY,CHTMP) + CHD0=CHTMP//' ' + CHDC(1)=DNAME(3) // ' + ' // DNAME(1) + CHDC(2)=DNAME(2) // ' + ' // DNAME(1) + CHDC(3)=DNAME(1) // ' + ' // DNAME(1) + KC=PYCOMP(KFSUSY) + DO 200 J=1,MDCY(KC,3) + IDC=J+MDCY(KC,2)-1 + ID1=IABS(KFDP(IDC,1)) + ID2=IABS(KFDP(IDC,2)) + IF (KFDP(IDC,3).EQ.0) THEN + IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2 + & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN + PBRAT(1)=PBRAT(1)+BRAT(IDC) + NMODES(1)=NMODES(1)+1 + IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 + IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 + ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND + & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6)) THEN + PBRAT(2)=PBRAT(2)+BRAT(IDC) + NMODES(2)=NMODES(2)+1 + IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 + IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 + ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND + & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN + PBRAT(3)=PBRAT(3)+BRAT(IDC) + NMODES(3)=NMODES(3)+1 + IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 + IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 + ENDIF + ENDIF + 200 CONTINUE + ENDIF +C...SUP DECAYS + IF (KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6) THEN + NRVDC=2 + DO 210 I=1,NRVDC + NMODES(I)=0 + PBRAT(I)=0D0 + 210 CONTINUE + CALL PYNAME(KFSUSY,CHTMP) + CHD0=CHTMP//' ' + CHDC(1)=DNAME(2) // ' + ' // DNAME(1) + CHDC(2)=DNAME(1) // ' + ' // DNAME(1) + KC=PYCOMP(KFSUSY) + DO 220 J=1,MDCY(KC,3) + IDC=J+MDCY(KC,2)-1 + ID1=IABS(KFDP(IDC,1)) + ID2=IABS(KFDP(IDC,2)) + IF (KFDP(IDC,3).EQ.0) THEN + IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND.(ID2 + & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN + PBRAT(1)=PBRAT(1)+BRAT(IDC) + NMODES(1)=NMODES(1)+1 + IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 + IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 + ELSE IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND.(ID2 + & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN + PBRAT(2)=PBRAT(2)+BRAT(IDC) + NMODES(2)=NMODES(2)+1 + IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 + IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 + ENDIF + ENDIF + 220 CONTINUE + ENDIF +C...SLEPTON DECAYS + IF (KFSM.EQ.11.OR.KFSM.EQ.13.OR.KFSM.EQ.15) THEN + NRVDC=2 + DO 230 I=1,NRVDC + PBRAT(I)=0D0 + NMODES(I)=0 + 230 CONTINUE + CALL PYNAME(KFSUSY,CHTMP) + CHD0=CHTMP//' ' + CHDC(1)=DNAME(3) // ' + ' // DNAME(2) + CHDC(2)=DNAME(1) // ' + ' // DNAME(1) + KC=PYCOMP(KFSUSY) + DO 240 J=1,MDCY(KC,3) + IDC=J+MDCY(KC,2)-1 + ID1=IABS(KFDP(IDC,1)) + ID2=IABS(KFDP(IDC,2)) + IF (KFDP(IDC,3).EQ.0) THEN + IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2 + & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15)) THEN + PBRAT(1)=PBRAT(1)+BRAT(IDC) + NMODES(1)=NMODES(1)+1 + IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 + IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 + ENDIF + IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND.(ID2 + & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN + PBRAT(2)=PBRAT(2)+BRAT(IDC) + NMODES(2)=NMODES(2)+1 + IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 + IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 + ENDIF + ENDIF + 240 CONTINUE + ENDIF +C...SNEUTRINO DECAYS + IF ((KFSM.EQ.12.OR.KFSM.EQ.14.OR.KFSM.EQ.16).AND.ILR.EQ.1) + & THEN + NRVDC=2 + DO 250 I=1,NRVDC + PBRAT(I)=0D0 + NMODES(I)=0 + 250 CONTINUE + CALL PYNAME(KFSUSY,CHTMP) + CHD0=CHTMP//' ' + CHDC(1)=DNAME(2) // ' + ' // DNAME(2) + CHDC(2)=DNAME(1) // ' + ' // DNAME(1) + KC=PYCOMP(KFSUSY) + DO 260 J=1,MDCY(KC,3) + IDC=J+MDCY(KC,2)-1 + ID1=IABS(KFDP(IDC,1)) + ID2=IABS(KFDP(IDC,2)) + IF (KFDP(IDC,3).EQ.0) THEN + IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND.(ID2 + & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15)) THEN + PBRAT(1)=PBRAT(1)+BRAT(IDC) + NMODES(1)=NMODES(1)+1 + IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 + IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 + ENDIF + IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND.(ID2 + & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN + NMODES(2)=NMODES(2)+1 + PBRAT(2)=PBRAT(2)+BRAT(IDC) + IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 + IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 + ENDIF + ENDIF + 260 CONTINUE + ENDIF + IF (NRVDC.NE.0) THEN + DO 270 I=1,NRVDC + WRITE (MSTU(11),8200) CHD0, CHDC(I), PBRAT(I), NMODES(I) + NMODES(0)=NMODES(0)+NMODES(I) + 270 CONTINUE + ENDIF + 280 CONTINUE + 290 CONTINUE + DO 370 KFSM=21,37 + KFSUSY=KSUSY1+KFSM + NRVDC=0 +C...NEUTRALINO DECAYS + IF (KFSM.EQ.22.OR.KFSM.EQ.23.OR.KFSM.EQ.25.OR.KFSM.EQ.35) THEN + NRVDC=4 + DO 300 I=1,NRVDC + PBRAT(I)=0D0 + NMODES(I)=0 + 300 CONTINUE + CALL PYNAME(KFSUSY,CHTMP) + CHD0=CHTMP//' ' + CHDC(1)=DNAME(3) // ' + ' // DNAME(2) // ' + ' // DNAME(2) + CHDC(2)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1) + CHDC(3)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1) + CHDC(4)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1) + KC=PYCOMP(KFSUSY) + DO 310 J=1,MDCY(KC,3) + IDC=J+MDCY(KC,2)-1 + ID1=IABS(KFDP(IDC,1)) + ID2=IABS(KFDP(IDC,2)) + ID3=IABS(KFDP(IDC,3)) + IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2 + & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ.11.OR + & .ID3.EQ.13.OR.ID3.EQ.15)) THEN + PBRAT(1)=PBRAT(1)+BRAT(IDC) + NMODES(1)=NMODES(1)+1 + IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 + IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 + ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND + & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1 + & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN + PBRAT(2)=PBRAT(2)+BRAT(IDC) + NMODES(2)=NMODES(2)+1 + IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 + IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 + ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND + & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ.1 + & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN + PBRAT(3)=PBRAT(3)+BRAT(IDC) + NMODES(3)=NMODES(3)+1 + IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 + IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 + ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND + & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1 + & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN + PBRAT(4)=PBRAT(4)+BRAT(IDC) + NMODES(4)=NMODES(4)+1 + IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 + IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 + ENDIF + 310 CONTINUE + ENDIF +C...CHARGINO DECAYS + IF (KFSM.EQ.24.OR.KFSM.EQ.37) THEN + NRVDC=5 + DO 320 I=1,NRVDC + PBRAT(I)=0D0 + NMODES(I)=0 + 320 CONTINUE + CALL PYNAME(KFSUSY,CHTMP) + CHD0=CHTMP//' ' + CHDC(1)=DNAME(3) // ' + ' // DNAME(3) // ' + ' // DNAME(2) + CHDC(2)=DNAME(2) // ' + ' // DNAME(2) // ' + ' // DNAME(2) + CHDC(3)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1) + CHDC(4)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1) + CHDC(5)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1) + KC=PYCOMP(KFSUSY) + DO 330 J=1,MDCY(KC,3) + IDC=J+MDCY(KC,2)-1 + ID1=IABS(KFDP(IDC,1)) + ID2=IABS(KFDP(IDC,2)) + ID3=IABS(KFDP(IDC,3)) + IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2 + & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ.12.OR + & .ID3.EQ.14.OR.ID3.EQ.16)) THEN + PBRAT(1)=PBRAT(1)+BRAT(IDC) + NMODES(1)=NMODES(1)+1 + IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 + IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 + ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND + & .(ID2.EQ.12.OR.ID2.EQ.14.OR.ID2.EQ.16).AND.(ID3.EQ + & .11.OR.ID3.EQ.13.OR.ID3.EQ.15)) THEN + PBRAT(1)=PBRAT(1)+BRAT(IDC) + NMODES(1)=NMODES(1)+1 + IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 + IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 + ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND + & .(ID2.EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ + & .11.OR.ID3.EQ.13.OR.ID3.EQ.15)) THEN + PBRAT(2)=PBRAT(2)+BRAT(IDC) + NMODES(2)=NMODES(2)+1 + IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 + IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 + ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND + & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ + & .2.OR.ID3.EQ.4.OR.ID3.EQ.6)) THEN + PBRAT(3)=PBRAT(3)+BRAT(IDC) + NMODES(3)=NMODES(3)+1 + IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 + IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 + ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND + & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ + & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN + PBRAT(3)=PBRAT(3)+BRAT(IDC) + NMODES(3)=NMODES(3)+1 + IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 + IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 + ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND + & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ + & .2.OR.ID3.EQ.4.OR.ID3.EQ.6)) THEN + PBRAT(4)=PBRAT(4)+BRAT(IDC) + NMODES(4)=NMODES(4)+1 + IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 + IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 + ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND + & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ + & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN + PBRAT(4)=PBRAT(4)+BRAT(IDC) + NMODES(4)=NMODES(4)+1 + IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 + IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 + ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND + & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ + & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN + PBRAT(5)=PBRAT(5)+BRAT(IDC) + NMODES(5)=NMODES(5)+1 + IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 + IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 + ELSE IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND + & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ + & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN + PBRAT(5)=PBRAT(5)+BRAT(IDC) + NMODES(5)=NMODES(5)+1 + IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 + IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 + ENDIF + 330 CONTINUE + ENDIF +C...GLUINO DECAYS + IF (KFSM.EQ.21) THEN + NRVDC=3 + DO 340 I=1,NRVDC + PBRAT(I)=0D0 + NMODES(I)=0 + 340 CONTINUE + CALL PYNAME(KFSUSY,CHTMP) + CHD0=CHTMP//' ' + CHDC(1)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1) + CHDC(2)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1) + CHDC(3)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1) + KC=PYCOMP(KFSUSY) + DO 350 J=1,MDCY(KC,3) + IDC=J+MDCY(KC,2)-1 + ID1=IABS(KFDP(IDC,1)) + ID2=IABS(KFDP(IDC,2)) + ID3=IABS(KFDP(IDC,3)) + IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2 + & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1.OR + & .ID3.EQ.3.OR.ID3.EQ.5)) THEN + PBRAT(1)=PBRAT(1)+BRAT(IDC) + NMODES(1)=NMODES(1)+1 + IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 + IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 + ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND + & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ.1 + & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN + PBRAT(2)=PBRAT(2)+BRAT(IDC) + NMODES(2)=NMODES(2)+1 + IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 + IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 + ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND + & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1 + & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN + PBRAT(3)=PBRAT(3)+BRAT(IDC) + NMODES(3)=NMODES(3)+1 + IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 + IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 + ENDIF + 350 CONTINUE + ENDIF + + IF (NRVDC.NE.0) THEN + DO 360 I=1,NRVDC + WRITE (MSTU(11),8200) CHD0, CHDC(I), PBRAT(I), NMODES(I) + NMODES(0)=NMODES(0)+NMODES(I) + 360 CONTINUE + ENDIF + 370 CONTINUE + WRITE (MSTU(11),8100) NMODES(0), NMODES(10), NMODES(9) + + IF (IMSS(51).GE.1.OR.IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN + WRITE (MSTU(11),8500) + DO 400 IRV=1,3 + DO 390 JRV=1,3 + DO 380 KRV=1,3 + WRITE (MSTU(11),8700) IRV,JRV,KRV,RVLAM(IRV,JRV,KRV) + & ,RVLAMP(IRV,JRV,KRV),RVLAMB(IRV,JRV,KRV) + 380 CONTINUE + 390 CONTINUE + 400 CONTINUE + WRITE (MSTU(11),8600) + ENDIF + ENDIF + +C...Formats for printouts. + 5000 FORMAT('1',9('*'),1X,'PYSTAT: Statistics on Number of ', + &'Events and Cross-sections',1X,9('*')) + 5100 FORMAT(/1X,78('=')/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',12X, + &'Subprocess',12X,'I',6X,'Number of points',6X,'I',4X,'Sigma',3X, + &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',34('-'),'I',28('-'), + &'I',4X,'(mb)',4X,'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',1X, + &'N:o',1X,'Type',25X,'I',4X,'Generated',9X,'Tried',1X,'I',12X, + &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/1X,'I',34X,'I',28X, + &'I',12X,'I') + 5200 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I12,1X,I13,1X,'I',1X,1P, + &D10.3,1X,'I') + 5300 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/ + &1X,'I',34X,'I',28X,'I',12X,'I') + 5400 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')// + &1X,'********* Total number of errors, excluding junctions =', + &1X,I8,' *************'/ + &1X,'********* Total number of errors, including junctions =', + &1X,I8,' *************'/ + &1X,'********* Total number of warnings = ', + &1X,I8,' *************'/ + &1X,'********* Fraction of events that fail fragmentation ', + &'cuts =',1X,F8.5,' *********'/) + 5500 FORMAT('1',27('*'),1X,'PYSTAT: Decay Widths and Branching ', + &'Ratios',1X,27('*')) + 5600 FORMAT(/1X,98('=')/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/ + &1X,'I',5X,'Mother --> Branching/Decay Channel',8X,'I',1X, + &'Width (GeV)',1X,'I',7X,'B.R.',1X,'I',1X,'Stat',1X,'I',2X, + &'Eff. B.R.',1X,'I'/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/ + &1X,98('=')) + 5700 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,'I',1X, + &I8,2X,A10,3X,'(m =',F10.3,')',2X,'-->',5X,'I',2X,1P,D10.3,0P,1X, + &'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,1P,D10.3,0P,1X,'I') + 5800 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,15X,'I',2X, + &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X, + &1P,D10.3,0P,1X,'I') + 5900 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,1X,'+',1X,A10,2X,'I',2X, + &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X, + &1P,D10.3,0P,1X,'I') + 6000 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,98('=')) + 6100 FORMAT('1',7('*'),1X,'PYSTAT: Allowed Incoming Partons/', + &'Particles at Hard Interaction',1X,7('*')) + 6200 FORMAT(/1X,78('=')/1X,'I',38X,'I',37X,'I'/1X,'I',1X, + &'Beam particle:',1X,A12,10X,'I',1X,'Target particle:',1X,A12,7X, + &'I'/1X,'I',38X,'I',37X,'I'/1X,'I',1X,'Content',6X,'State',19X, + &'I',1X,'Content',6X,'State',18X,'I'/1X,'I',38X,'I',37X,'I'/1X, + &78('=')/1X,'I',38X,'I',37X,'I') + 6300 FORMAT(1X,'I',1X,A9,5X,A4,19X,'I',1X,A9,5X,A4,18X,'I') + 6400 FORMAT(1X,'I',38X,'I',37X,'I'/1X,78('=')) + 6500 FORMAT('1',12('*'),1X,'PYSTAT: User-Defined Limits on ', + &'Kinematical Variables',1X,12('*')) + 6600 FORMAT(/1X,78('=')/1X,'I',76X,'I') + 6700 FORMAT(1X,'I',16X,1P,D10.3,0P,1X,'<',1X,A,1X,'<',1X,1P,D10.3,0P, + &16X,'I') + 6800 FORMAT(1X,'I',3X,1P,D10.3,0P,1X,'(',1P,D10.3,0P,')',1X,'<',1X,A, + &1X,'<',1X,1P,D10.3,0P,16X,'I') + 6900 FORMAT(1X,'I',29X,A,1X,'=',1X,1P,D10.3,0P,16X,'I') + 7000 FORMAT(1X,'I',76X,'I'/1X,78('=')) + 7100 FORMAT('1',12('*'),1X,'PYSTAT: Summary of Status Codes and ', + &'Parameter Values',1X,12('*')) + 7200 FORMAT(/3X,'I',4X,'MSTP(I)',9X,'PARP(I)',20X,'I',4X,'MSTP(I)',9X, + &'PARP(I)'/) + 7300 FORMAT(1X,I3,5X,I6,6X,1P,D10.3,0P,18X,I3,5X,I6,6X,1P,D10.3) + 7400 FORMAT('1',13('*'),1X,'PYSTAT: List of implemented processes', + &1X,13('*')) + 7500 FORMAT(/1X,65('=')/1X,'I',34X,'I',28X,'I'/1X,'I',12X, + &'Subprocess',12X,'I',1X,'ISET',2X,'KFPR(I,1)',2X,'KFPR(I,2)',1X, + &'I'/1X,'I',34X,'I',28X,'I'/1X,65('=')/1X,'I',34X,'I',28X,'I') + 7600 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I4,1X,I10,1X,I10,1X,'I') + 7700 FORMAT(1X,'I',34X,'I',28X,'I'/1X,65('=')) + 8000 FORMAT(1X/ 1X/ + & 17X,'Sums over R-Violating branching ratios',1X/ 1X + & /1X,70('=')/1X,'I',50X,'I',11X,'I',5X,'I'/1X,'I',4X + & ,'Mother --> Sum over final state flavours',4X,'I',2X + & ,'BR(sum)',2X,'I',2X,'N',2X,'I'/1X,'I',50X,'I',11X,'I',5X,'I' + & /1X,70('=')/1X,'I',50X,'I',11X,'I',5X,'I') + 8100 FORMAT(1X,'I',50X,'I',11X,'I',5X,'I'/1X,70('=')/1X,'I',1X + & ,'Total number of R-Violating modes :',3X,I5,24X,'I'/ + & 1X,'I',1X,'Total number with non-vanishing BR :',2X,I5,24X + & ,'I'/1X,'I',1X,'Total number with BR > 0.001 :',8X,I5,24X,'I' + & /1X,70('=')) + 8200 FORMAT(1X,'I',1X,A9,1X,'-->',1X,A24,11X, + & 'I',2X,1P,D8.2,0P,1X,'I',2X,I2,1X,'I') + 8300 FORMAT(1X,'I',50X,'I',11X,'I',5X,'I') + 8500 FORMAT(1X/ 1X/ + & 1X,'R-Violating couplings',1X/ 1X / + & 1X,55('=')/ + & 1X,'I',1X,'IJK',1X,'I',2X,'LAMBDA(IJK)',2X,'I',2X + & ,'LAMBDA''(IJK)',1X,'I',1X,"LAMBDA''(IJK)",1X,'I'/1X,'I',5X + & ,'I',15X,'I',15X,'I',15X,'I') + 8600 FORMAT(1X,55('=')) + 8700 FORMAT(1X,'I',1X,I1,I1,I1,1X,'I',1X,1P,D13.3,0P,1X,'I',1X,1P + & ,D13.3,0P,1X,'I',1X,1P,D13.3,0P,1X,'I') + + RETURN + END + +C********************************************************************* + +C...PYUPEV +C...Administers the hard-process generation required for output to the +C...Les Houches event record. + + SUBROUTINE PYUPEV + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP + +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYCTAG/NCT,MCT(4000,2) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) + COMMON/PYINT4/MWID(500),WIDS(500,5) + SAVE /PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/, + &/PYINT1/,/PYINT2/,/PYINT4/ + +C...HEPEUP for output. + INTEGER MAXNUP + PARAMETER (MAXNUP=500) + INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP + DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP + COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP), + &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP), + &VTIMUP(MAXNUP),SPINUP(MAXNUP) + SAVE /HEPEUP/ + +C...Stop if no subprocesses on. + IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN + WRITE(MSTU(11),5100) + STOP + ENDIF + +C...Special flags for hard-process generation only. + MSTP71=MSTP(71) + MSTP(71)=0 + MST128=MSTP(128) + MSTP(128)=1 + +C...Initial values for some counters. + N=0 + MINT(5)=MINT(5)+1 + MINT(7)=0 + MINT(8)=0 + MINT(30)=0 + MINT(83)=0 + MINT(84)=MSTP(126) + MSTU(24)=0 + MSTU70=0 + MSTJ14=MSTJ(14) +C...Normally, use K(I,4:5) colour info rather than /PYCTAG/. + MINT(33)=0 + +C...If variable energies: redo incoming kinematics and cross-section. + MSTI(61)=0 + IF(MSTP(171).EQ.1) THEN + CALL PYINKI(1) + IF(MSTI(61).EQ.1) THEN + MINT(5)=MINT(5)-1 + RETURN + ENDIF + IF(MINT(121).GT.1) CALL PYSAVE(3,1) + CALL PYXTOT + ENDIF + +C...Do not allow pileup events. + MINT(82)=1 + +C...Generate variables of hard scattering. + MINT(51)=0 + MSTI(52)=0 + 100 CONTINUE + IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1 + MINT(31)=0 + MINT(51)=0 + MINT(57)=0 + CALL PYRAND + IF(MSTI(61).EQ.1) THEN + MINT(5)=MINT(5)-1 + RETURN + ENDIF + IF(MINT(51).EQ.2) RETURN + ISUB=MINT(1) + + IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN +C...Hard scattering (including low-pT): +C...reconstruct kinematics and colour flow of hard scattering. + MINT31=MINT(31) + 110 MINT(31)=MINT31 + MINT(51)=0 + CALL PYSCAT + IF(MINT(51).EQ.1) GOTO 100 + IPU1=MINT(84)+1 + IPU2=MINT(84)+2 + +C...Decay of final state resonances. + MINT(32)=0 + IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10.AND.ISUB.NE.95) + & CALL PYRESD(0) + IF(MINT(51).EQ.1) GOTO 100 + MINT(52)=N + +C...Longitudinal boost of hard scattering. + BETAZ=(VINT(41)-VINT(42))/(VINT(41)+VINT(42)) + CALL PYROBO(MINT(84)+1,N,0D0,0D0,0D0,0D0,BETAZ) + + ELSEIF(ISUB.NE.99) THEN +C...Diffractive and elastic scattering. + CALL PYDIFF + + ELSE +C...DIS scattering (photon flux external). + CALL PYDISG + IF(MINT(51).EQ.1) GOTO 100 + ENDIF + +C...Check that no odd resonance left undecayed. + MINT(54)=N + NFIX=N + DO 120 I=MINT(84)+1,NFIX + IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND. + & K(I,2).NE.22) THEN + KCA=PYCOMP(K(I,2)) + IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN + CALL PYRESD(I) + IF(MINT(51).EQ.1) GOTO 100 + ENDIF + ENDIF + 120 CONTINUE + +C...Boost hadronic subsystem to overall rest frame. +C..(Only relevant when photon inside lepton beam.) + IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA) + +C...Store event information and calculate Monte Carlo estimates of +C...subprocess cross-sections. + 130 CALL PYDOCU + +C...Transform to the desired coordinate frame. + 140 CALL PYFRAM(MSTP(124)) + MSTU(70)=MSTU70 + PARU(21)=VINT(1) + +C...Restore special flags for hard-process generation only. + MSTP(71)=MSTP71 + MSTP(128)=MST128 + +C...Trace colour tags; convert to LHA style labels. + NCT=100 + DO 150 I=MINT(84)+1,N + MCT(I,1)=0 + MCT(I,2)=0 + 150 CONTINUE + DO 160 I=MINT(84)+1,N + KQ=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2)) + IF(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.K(I,1).EQ.14) THEN + IF(K(I,4).NE.0.AND.(KQ.EQ.1.OR.KQ.EQ.2).AND.MCT(I,1).EQ.0) + & THEN + IMO=MOD(K(I,4)/MSTU(5),MSTU(5)) + IDA=MOD(K(I,4),MSTU(5)) + IF(IMO.NE.0.AND.MOD(K(IMO,5)/MSTU(5),MSTU(5)).EQ.I.AND. + & MCT(IMO,2).NE.0) THEN + MCT(I,1)=MCT(IMO,2) + ELSEIF(IMO.NE.0.AND.MOD(K(IMO,4),MSTU(5)).EQ.I.AND. + & MCT(IMO,1).NE.0) THEN + MCT(I,1)=MCT(IMO,1) + ELSEIF(IDA.NE.0.AND.MOD(K(IDA,5),MSTU(5)).EQ.I.AND. + & MCT(IDA,2).NE.0) THEN + MCT(I,1)=MCT(IDA,2) + ELSE + NCT=NCT+1 + MCT(I,1)=NCT + ENDIF + ENDIF + IF(K(I,5).NE.0.AND.(KQ.EQ.-1.OR.KQ.EQ.2).AND.MCT(I,2).EQ.0) + & THEN + IMO=MOD(K(I,5)/MSTU(5),MSTU(5)) + IDA=MOD(K(I,5),MSTU(5)) + IF(IMO.NE.0.AND.MOD(K(IMO,4)/MSTU(5),MSTU(5)).EQ.I.AND. + & MCT(IMO,1).NE.0) THEN + MCT(I,2)=MCT(IMO,1) + ELSEIF(IMO.NE.0.AND.MOD(K(IMO,5),MSTU(5)).EQ.I.AND. + & MCT(IMO,2).NE.0) THEN + MCT(I,2)=MCT(IMO,2) + ELSEIF(IDA.NE.0.AND.MOD(K(IDA,4),MSTU(5)).EQ.I.AND. + & MCT(IDA,1).NE.0) THEN + MCT(I,2)=MCT(IDA,1) + ELSE + NCT=NCT+1 + MCT(I,2)=NCT + ENDIF + ENDIF + ENDIF + 160 CONTINUE + +C...Put event in HEPEUP commonblock. + NUP=N-MINT(84) + IDPRUP=MINT(1) + XWGTUP=1D0 + SCALUP=VINT(53) + AQEDUP=VINT(57) + AQCDUP=VINT(58) + DO 180 I=1,NUP + IDUP(I)=K(I+MINT(84),2) + IF(I.LE.2) THEN + ISTUP(I)=-1 + MOTHUP(1,I)=0 + MOTHUP(2,I)=0 + ELSEIF(K(I+4,3).EQ.0) THEN + ISTUP(I)=1 + MOTHUP(1,I)=1 + MOTHUP(2,I)=2 + ELSE + ISTUP(I)=1 + MOTHUP(1,I)=K(I+MINT(84),3)-MINT(84) + MOTHUP(2,I)=0 + ENDIF + IF(I.GE.3.AND.K(I+MINT(84),3).GT.0) + & ISTUP(K(I+MINT(84),3)-MINT(84))=2 + ICOLUP(1,I)=MCT(I+MINT(84),1) + ICOLUP(2,I)=MCT(I+MINT(84),2) + DO 170 J=1,5 + PUP(J,I)=P(I+MINT(84),J) + 170 CONTINUE + VTIMUP(I)=V(I,5) + SPINUP(I)=9D0 + 180 CONTINUE + +C...Optionally write out event to disk. Minimal size for time/spin fields. + IF(MSTP(162).GT.0) THEN + WRITE(MSTP(162),5200) NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP + DO 190 I=1,NUP + IF(VTIMUP(I).EQ.0D0) THEN + WRITE(MSTP(162),5300) IDUP(I),ISTUP(I),MOTHUP(1,I), + & MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5), + & ' 0. 9.' + ELSE + WRITE(MSTP(162),5400) IDUP(I),ISTUP(I),MOTHUP(1,I), + & MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5), + & VTIMUP(I),' 9.' + ENDIF + 190 CONTINUE + +C...Optional extra line with parton-density information. + IF(MSTP(165).GE.1) WRITE(MSTP(162),5500) MSTI(15),MSTI(16), + & PARI(33),PARI(34),PARI(23),PARI(29),PARI(30) + ENDIF + +C...Error messages and other print formats. + 5100 FORMAT(1X,'Error: no subprocess switched on.'/ + &1X,'Execution stopped.') + 5200 FORMAT(1P,2I6,4E14.6) + 5300 FORMAT(1P,I8,5I5,5E18.10,A6) + 5400 FORMAT(1P,I8,5I5,5E18.10,E12.4,A3) + 5500 FORMAT(1P,'#pdf ',2I5,5E18.10) + + RETURN + END + +C********************************************************************* + +C...PYUPIN +C...Fills the HEPRUP commonblock with info on incoming beams and allowed +C...processes, and optionally stores that information on file. + + SUBROUTINE PYUPIN + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) + SAVE /PYJETS/,/PYSUBS/,/PYPARS/,/PYINT5/ + +C...User process initialization commonblock. + INTEGER MAXPUP + PARAMETER (MAXPUP=100) + INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP + DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP + COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2), + &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP), + &LPRUP(MAXPUP) + SAVE /HEPRUP/ + +C...Store info on incoming beams. + IDBMUP(1)=K(1,2) + IDBMUP(2)=K(2,2) + EBMUP(1)=P(1,4) + EBMUP(2)=P(2,4) + PDFGUP(1)=0 + PDFGUP(2)=0 + PDFSUP(1)=MSTP(51) + PDFSUP(2)=MSTP(51) + +C...Event weighting strategy. + IDWTUP=3 + +C...Info on individual processes. + NPRUP=0 + DO 100 ISUB=1,500 + IF(MSUB(ISUB).EQ.1) THEN + NPRUP=NPRUP+1 + XSECUP(NPRUP)=1D9*XSEC(ISUB,3) + XERRUP(NPRUP)=XSECUP(NPRUP)/SQRT(MAX(1D0,DBLE(NGEN(ISUB,3)))) + XMAXUP(NPRUP)=1D0 + LPRUP(NPRUP)=ISUB + ENDIF + 100 CONTINUE + +C...Write info to file. + IF(MSTP(161).GT.0) THEN + WRITE(MSTP(161),5100) IDBMUP(1),IDBMUP(2),EBMUP(1),EBMUP(2), + & PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP + DO 110 IPR=1,NPRUP + WRITE(MSTP(161),5200) XSECUP(IPR),XERRUP(IPR),XMAXUP(IPR), + & LPRUP(IPR) + 110 CONTINUE + ENDIF + +C...Formats for printout. + 5100 FORMAT(1P,2I8,2E14.6,6I6) + 5200 FORMAT(1P,3E14.6,I6) + + RETURN + END + + +C********************************************************************* + +C...Combine the two old-style Pythia initialization and event files +C...into a single Les Houches Event File. + + SUBROUTINE PYLHEF + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + +C...PYTHIA commonblock: only used to provide read/write units and version. + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + SAVE /PYPARS/ + +C...User process initialization commonblock. + INTEGER MAXPUP + PARAMETER (MAXPUP=100) + INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP + DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP + COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2), + &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP), + &LPRUP(MAXPUP) + SAVE /HEPRUP/ + +C...User process event common block. + INTEGER MAXNUP + PARAMETER (MAXNUP=500) + INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP + DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP + COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP), + &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP), + &VTIMUP(MAXNUP),SPINUP(MAXNUP) + SAVE /HEPEUP/ + +C...Lines to read in assumed never longer than 200 characters. + PARAMETER (MAXLEN=200) + CHARACTER*(MAXLEN) STRING + +C...Format for reading lines. + CHARACTER*6 STRFMT + STRFMT='(A000)' + WRITE(STRFMT(3:5),'(I3)') MAXLEN + +C...Rewind initialization and event files. + REWIND MSTP(161) + REWIND MSTP(162) + +C...Write header info. + WRITE(MSTP(163),'(A)') '' + WRITE(MSTP(163),'(A)') '' + +C...Read first line of initialization info and get number of processes. + READ(MSTP(161),'(A)',END=400,ERR=400) STRING + READ(STRING,*,ERR=400) IDBMUP(1),IDBMUP(2),EBMUP(1), + &EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP + +C...Copy initialization lines, omitting trailing blanks. +C...Embed in ... block. + WRITE(MSTP(163),'(A)') '' + DO 140 IPR=0,NPRUP + IF(IPR.GT.0) READ(MSTP(161),'(A)',END=400,ERR=400) STRING + LEN=MAXLEN+1 + 120 LEN=LEN-1 + IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 120 + WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN) + 140 CONTINUE + WRITE(MSTP(163),'(A)') '' + +C...Begin event loop. Read first line of event info or already done. + READ(MSTP(162),'(A)',END=320,ERR=400) STRING + 200 CONTINUE + +C...Look at first line to know number of particles in event. + READ(STRING,*,ERR=400) NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP + +C...Begin an block. Copy event lines, omitting trailing blanks. + WRITE(MSTP(163),'(A)') '' + DO 240 I=0,NUP + IF(I.GT.0) READ(MSTP(162),'(A)',END=400,ERR=400) STRING + LEN=MAXLEN+1 + 220 LEN=LEN-1 + IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 220 + WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN) + 240 CONTINUE + +C...Copy trailing comment lines - with a # in the first column - as is. + 260 READ(MSTP(162),'(A)',END=300,ERR=400) STRING + IF(STRING(1:1).EQ.'#') THEN + LEN=MAXLEN+1 + 280 LEN=LEN-1 + IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 280 + WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN) + GOTO 260 + ENDIF + +C..End the block. Loop back to look for next event. + WRITE(MSTP(163),'(A)') '' + GOTO 200 + +C...Successfully reached end of event loop: write closing tag +C...and remove temporary intermediate files (unless asked not to). + 300 WRITE(MSTP(163),'(A)') '' + 320 WRITE(MSTP(163),'(A)') '' + IF(MSTP(164).EQ.1) RETURN + CLOSE(MSTP(161),ERR=400,STATUS='DELETE') + CLOSE(MSTP(162),ERR=400,STATUS='DELETE') + RETURN + +C...Error exit. + 400 WRITE(*,*) ' PYLHEF file joining failed!' + + RETURN + END + +C********************************************************************* + +C...PYINRE +C...Calculates full and effective widths of gauge bosons, stores +C...masses and widths, rescales coefficients to be used for +C...resonance production generation. + + SUBROUTINE PYINRE + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + COMMON/PYDAT4/CHAF(500,2) + CHARACTER CHAF*16 + COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) + COMMON/PYINT4/MWID(500),WIDS(500,5) + COMMON/PYINT6/PROC(0:500) + CHARACTER PROC*28 + COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) + SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/, + &/PYINT1/,/PYINT2/,/PYINT4/,/PYINT6/,/PYMSSM/ +C...Local arrays and data. + CHARACTER PRTMP*9 + DIMENSION WDTP(0:400),WDTE(0:400,0:5),WDTPM(0:400), + &WDTEM(0:400,0:5),KCORD(500),PMORD(500) + +C...Born level couplings in MSSM Higgs doublet sector. + XW=PARU(102) + XWV=XW + IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2 + XW1=1D0-XW + IF(MSTP(4).EQ.2) THEN + TANBE=PARU(141) + RATBE=((1D0-TANBE**2)/(1D0+TANBE**2))**2 + SQMZ=PMAS(23,1)**2 + SQMW=PMAS(24,1)**2 + SQMH=PMAS(25,1)**2 + SQMA=SQMH*(SQMZ-SQMH)/(SQMZ*RATBE-SQMH) + SQMHP=0.5D0*(SQMA+SQMZ+SQRT((SQMA+SQMZ)**2-4D0*SQMA*SQMZ*RATBE)) + SQMHC=SQMA+SQMW + IF(SQMH.GE.SQMZ.OR.MIN(SQMA,SQMHP,SQMHC).LE.0D0) THEN + WRITE(MSTU(11),5000) + CALL PYSTOP(101) + ENDIF + PMAS(35,1)=SQRT(SQMHP) + PMAS(36,1)=SQRT(SQMA) + PMAS(37,1)=SQRT(SQMHC) + ALSU=0.5D0*ATAN(2D0*TANBE*(SQMA+SQMZ)/((1D0-TANBE**2)* + & (SQMA-SQMZ))) + BESU=ATAN(TANBE) + PARU(142)=1D0 + PARU(143)=1D0 + PARU(161)=-SIN(ALSU)/COS(BESU) + PARU(162)=COS(ALSU)/SIN(BESU) + PARU(163)=PARU(161) + PARU(164)=SIN(BESU-ALSU) + PARU(165)=PARU(164) + PARU(168)=SIN(BESU-ALSU)+0.5D0*COS(2D0*BESU)*SIN(BESU+ALSU)/XW + PARU(171)=COS(ALSU)/COS(BESU) + PARU(172)=SIN(ALSU)/SIN(BESU) + PARU(173)=PARU(171) + PARU(174)=COS(BESU-ALSU) + PARU(175)=PARU(174) + PARU(176)=COS(2D0*ALSU)*COS(BESU+ALSU)-2D0*SIN(2D0*ALSU)* + & SIN(BESU+ALSU) + PARU(177)=COS(2D0*BESU)*COS(BESU+ALSU) + PARU(178)=COS(BESU-ALSU)-0.5D0*COS(2D0*BESU)*COS(BESU+ALSU)/XW + PARU(181)=TANBE + PARU(182)=1D0/TANBE + PARU(183)=PARU(181) + PARU(184)=0D0 + PARU(185)=PARU(184) + PARU(186)=COS(BESU-ALSU) + PARU(187)=SIN(BESU-ALSU) + PARU(188)=PARU(186) + PARU(189)=PARU(187) + PARU(190)=0D0 + PARU(195)=COS(BESU-ALSU) + ENDIF + +C...Reset effective widths of gauge bosons. + DO 110 I=1,500 + DO 100 J=1,5 + WIDS(I,J)=1D0 + 100 CONTINUE + 110 CONTINUE + +C...Order resonances by increasing mass (except Z0 and W+/-). + NRES=0 + DO 140 KC=1,500 + KF=KCHG(KC,4) + IF(KF.EQ.0) GOTO 140 + IF(MWID(KC).EQ.0) GOTO 140 + IF(KC.EQ.7.OR.KC.EQ.8.OR.KC.EQ.17.OR.KC.EQ.18) THEN + IF(MSTP(1).LE.3) GOTO 140 + ENDIF + IF(KF/KSUSY1.EQ.1.OR.KF/KSUSY1.EQ.2) THEN + IF(IMSS(1).LE.0) GOTO 140 + ENDIF + NRES=NRES+1 + PMRES=PMAS(KC,1) + IF(KC.EQ.23.OR.KC.EQ.24) PMRES=0D0 + DO 120 I1=NRES-1,1,-1 + IF(PMRES.GE.PMORD(I1)) GOTO 130 + KCORD(I1+1)=KCORD(I1) + PMORD(I1+1)=PMORD(I1) + 120 CONTINUE + 130 KCORD(I1+1)=KC + PMORD(I1+1)=PMRES + 140 CONTINUE + +C...Loop over possible resonances. + DO 180 I=1,NRES + KC=KCORD(I) + KF=KCHG(KC,4) + +C...Check that no fourth generation channels on by mistake. + IF(MSTP(1).LE.3) THEN + DO 150 J=1,MDCY(KC,3) + IDC=J+MDCY(KC,2)-1 + KFA1=IABS(KFDP(IDC,1)) + KFA2=IABS(KFDP(IDC,2)) + IF(KFA1.EQ.7.OR.KFA1.EQ.8.OR.KFA1.EQ.17.OR.KFA1.EQ.18.OR. + & KFA2.EQ.7.OR.KFA2.EQ.8.OR.KFA2.EQ.17.OR.KFA2.EQ.18) + & MDME(IDC,1)=-1 + 150 CONTINUE + ENDIF + +C...Check that no supersymmetric channels on by mistake. + IF(IMSS(1).LE.0) THEN + DO 160 J=1,MDCY(KC,3) + IDC=J+MDCY(KC,2)-1 + KFA1S=IABS(KFDP(IDC,1))/KSUSY1 + KFA2S=IABS(KFDP(IDC,2))/KSUSY1 + IF(KFA1S.EQ.1.OR.KFA1S.EQ.2.OR.KFA2S.EQ.1.OR.KFA2S.EQ.2) + & MDME(IDC,1)=-1 + 160 CONTINUE + ENDIF + +C...Find mass and evaluate width. + PMR=PMAS(KC,1) + IF(KF.EQ.25.OR.KF.EQ.35.OR.KF.EQ.36) MINT(62)=1 + IF(MWID(KC).EQ.3) MINT(63)=1 + CALL PYWIDT(KF,PMR**2,WDTP,WDTE) + MINT(51)=0 + +C...Evaluate suppression factors due to non-simulated channels. + IF(KCHG(KC,3).EQ.0) THEN + WDTP0I=0D0 + IF(WDTP(0).GT.0D0) WDTP0I=1D0/WDTP(0) + WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))**2+ + & 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+ + & 2D0*WDTE(0,4)*WDTE(0,5))*WDTP0I**2 + WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*WDTP0I + WIDS(KC,3)=0D0 + WIDS(KC,4)=0D0 + WIDS(KC,5)=0D0 + ELSE + IF(MWID(KC).EQ.3) MINT(63)=1 + CALL PYWIDT(-KF,PMR**2,WDTPM,WDTEM) + MINT(51)=0 + WDTP0I=0D0 + IF(WDTP(0).GT.0D0) WDTP0I=1D0/WDTP(0) + WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))*(WDTEM(0,1)+WDTEM(0,3))+ + & (WDTE(0,1)+WDTE(0,2))*(WDTEM(0,4)+WDTEM(0,5))+ + & (WDTE(0,4)+WDTE(0,5))*(WDTEM(0,1)+WDTEM(0,3))+ + & WDTE(0,4)*WDTEM(0,5)+WDTE(0,5)*WDTEM(0,4))*WDTP0I**2 + WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*WDTP0I + WIDS(KC,3)=(WDTEM(0,1)+WDTEM(0,3)+WDTEM(0,4))*WDTP0I + WIDS(KC,4)=((WDTE(0,1)+WDTE(0,2))**2+ + & 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+ + & 2D0*WDTE(0,4)*WDTE(0,5))*WDTP0I**2 + WIDS(KC,5)=((WDTEM(0,1)+WDTEM(0,3))**2+ + & 2D0*(WDTEM(0,1)+WDTEM(0,3))*(WDTEM(0,4)+WDTEM(0,5))+ + & 2D0*WDTEM(0,4)*WDTEM(0,5))*WDTP0I**2 + ENDIF + +C...Set resonance widths and branching ratios; +C...also on/off switch for decays. + IF(MWID(KC).EQ.1.OR.MWID(KC).EQ.3) THEN + PMAS(KC,2)=WDTP(0) + PMAS(KC,3)=MIN(0.9D0*PMAS(KC,1),10D0*PMAS(KC,2)) + IF(MSTP(41).EQ.0.OR.MSTP(41).EQ.1) MDCY(KC,1)=MSTP(41) + DO 170 J=1,MDCY(KC,3) + IDC=J+MDCY(KC,2)-1 + BRAT(IDC)=0D0 + IF(WDTP(0).GT.0D0) BRAT(IDC)=WDTP(J)/WDTP(0) + 170 CONTINUE + ENDIF + 180 CONTINUE + +C...Flavours of leptoquark: redefine charge and name. + KFLQQ=KFDP(MDCY(42,2),1) + KFLQL=KFDP(MDCY(42,2),2) + KCHG(42,1)=KCHG(PYCOMP(KFLQQ),1)*ISIGN(1,KFLQQ)+ + &KCHG(PYCOMP(KFLQL),1)*ISIGN(1,KFLQL) + LL=1 + IF(IABS(KFLQL).EQ.13) LL=2 + IF(IABS(KFLQL).EQ.15) LL=3 + CHAF(42,1)='LQ_'//CHAF(IABS(KFLQQ),1)(1:1)// + &CHAF(IABS(KFLQL),1)(1:LL)//' ' + CHAF(42,2)=CHAF(42,2)(1:4+LL)//'bar ' + +C...Special cases in treatment of gamma*/Z0: redefine process name. + IF(MSTP(43).EQ.1) THEN + PROC(1)='f + fbar -> gamma*' + PROC(15)='f + fbar -> g + gamma*' + PROC(19)='f + fbar -> gamma + gamma*' + PROC(30)='f + g -> f + gamma*' + PROC(35)='f + gamma -> f + gamma*' + ELSEIF(MSTP(43).EQ.2) THEN + PROC(1)='f + fbar -> Z0' + PROC(15)='f + fbar -> g + Z0' + PROC(19)='f + fbar -> gamma + Z0' + PROC(30)='f + g -> f + Z0' + PROC(35)='f + gamma -> f + Z0' + ELSEIF(MSTP(43).EQ.3) THEN + PROC(1)='f + fbar -> gamma*/Z0' + PROC(15)='f + fbar -> g + gamma*/Z0' + PROC(19)='f+ fbar -> gamma + gamma*/Z0' + PROC(30)='f + g -> f + gamma*/Z0' + PROC(35)='f + gamma -> f + gamma*/Z0' + ENDIF + +C...Special cases in treatment of gamma*/Z0/Z'0: redefine process name. + IF(MSTP(44).EQ.1) THEN + PROC(141)='f + fbar -> gamma*' + ELSEIF(MSTP(44).EQ.2) THEN + PROC(141)='f + fbar -> Z0' + ELSEIF(MSTP(44).EQ.3) THEN + PROC(141)='f + fbar -> Z''0' + ELSEIF(MSTP(44).EQ.4) THEN + PROC(141)='f + fbar -> gamma*/Z0' + ELSEIF(MSTP(44).EQ.5) THEN + PROC(141)='f + fbar -> gamma*/Z''0' + ELSEIF(MSTP(44).EQ.6) THEN + PROC(141)='f + fbar -> Z0/Z''0' + ELSEIF(MSTP(44).EQ.7) THEN + PROC(141)='f + fbar -> gamma*/Z0/Z''0' + ENDIF + +C...Special cases in treatment of WW -> WW: redefine process name. + IF(MSTP(45).EQ.1) THEN + PROC(77)='W+ + W+ -> W+ + W+' + ELSEIF(MSTP(45).EQ.2) THEN + PROC(77)='W+ + W- -> W+ + W-' + ELSEIF(MSTP(45).EQ.3) THEN + PROC(77)='W+/- + W+/- -> W+/- + W+/-' + ENDIF + +C...Initialize Generic Processes + KFGEN=9900001 + KCGEN=PYCOMP(KFGEN) + IF(KCGEN.GT.0) THEN + IDCY=MDCY(KCGEN,2) + IF(IDCY.GT.0) THEN + KFF1=KFDP(IDCY+1,1) + KFF2=KFDP(IDCY+1,2) + KCF1=PYCOMP(KFF1) + KCF2=PYCOMP(KFF2) + IJ1=1 + IJ2=1 + KCI1=PYCOMP(KFDP(IDCY,1)) + IF(KFDP(IDCY,1).LT.0) IJ1=2 + KCI2=PYCOMP(KFDP(IDCY,2)) + IF(KFDP(IDCY,2).LT.0) IJ2=2 + ITMP1=0 + 190 ITMP1=ITMP1+1 + IF(CHAF(KCI1,IJ1)(ITMP1+1:ITMP1+1).NE.' '.AND.ITMP1.LT.4) + & GOTO 190 + ITMP2=0 + 200 ITMP2=ITMP2+1 + IF(CHAF(KCI2,IJ2)(ITMP2+1:ITMP2+1).NE.' '.AND.ITMP2.LT.4) + & GOTO 200 + PRTMP=CHAF(KCI1,IJ1)(1:ITMP1)//'+'//CHAF(KCI2,IJ2)(1:ITMP2) + ITMP3=0 + 205 ITMP3=ITMP3+1 + IF(PRTMP(ITMP3+1:ITMP3+1).NE.' '.AND.ITMP3.LT.9) + & GOTO 205 + PROC(481)=PRTMP(1:ITMP3)//' -> '//CHAF(KCGEN,1) + IJ1=1 + IJ2=1 + IF(KFF1.LT.0) IJ1=2 + IF(KFF2.LT.0) IJ2=2 + ITMP1=0 + 210 ITMP1=ITMP1+1 + IF(CHAF(KCF1,IJ1)(ITMP1+1:ITMP1+1).NE.' '.AND.ITMP1.LT.8) + & GOTO 210 + ITMP2=0 + 220 ITMP2=ITMP2+1 + IF(CHAF(KCF2,IJ2)(ITMP2+1:ITMP2+1).NE.' '.AND.ITMP2.LT.8) + & GOTO 220 + PROC(482)=PRTMP(1:ITMP3)//' -> '//CHAF(KCF1,IJ1)(1:ITMP1)// + & '+'//CHAF(KCF2,IJ2)(1:ITMP2) + ENDIF + ENDIF + + + +C...Format for error information. + 5000 FORMAT(1X,'Error: unphysical input tan^2(beta) and m_H ', + &'combination'/1X,'Execution stopped!') + + RETURN + END + +C********************************************************************* + +C...PYINBM +C...Identifies the two incoming particles and the choice of frame. + + SUBROUTINE PYINBM(CHFRAM,CHBEAM,CHTARG,WIN) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP + +C...User process initialization commonblock. + INTEGER MAXPUP + PARAMETER (MAXPUP=100) + INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP + DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP + COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2), + &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP), + &LPRUP(MAXPUP) + SAVE /HEPRUP/ + +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/ + +C...Local arrays, character variables and data. + CHARACTER CHFRAM*12,CHBEAM*12,CHTARG*12,CHCOM(3)*12,CHALP(2)*26, + &CHIDNT(3)*12,CHTEMP*12,CHCDE(39)*12,CHINIT*76,CHNAME*16 + DIMENSION LEN(3),KCDE(39),PM(2) + DATA CHALP/'abcdefghijklmnopqrstuvwxyz', + &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/ + DATA CHCDE/ 'e- ','e+ ','nu_e ', + &'nu_ebar ','mu- ','mu+ ','nu_mu ', + &'nu_mubar ','tau- ','tau+ ','nu_tau ', + &'nu_taubar ','pi+ ','pi- ','n0 ', + &'nbar0 ','p+ ','pbar- ','gamma ', + &'lambda0 ','sigma- ','sigma0 ','sigma+ ', + &'xi- ','xi0 ','omega- ','pi0 ', + &'reggeon ','pomeron ','gamma/e- ','gamma/e+ ', + &'gamma/mu- ','gamma/mu+ ','gamma/tau- ','gamma/tau+ ', + &'k+ ','k- ','ks0 ','kl0 '/ + DATA KCDE/11,-11,12,-12,13,-13,14,-14,15,-15,16,-16, + &211,-211,2112,-2112,2212,-2212,22,3122,3112,3212,3222, + &3312,3322,3334,111,110,990,6*22,321,-321,310,130/ + +C...Store initial energy. Default frame. + VINT(290)=WIN + MINT(111)=0 + +C...Special user process initialization; convert to normal input. + IF(CHFRAM(1:1).EQ.'u'.OR.CHFRAM(1:1).EQ.'U') THEN + MINT(111)=11 + IF(PDFGUP(1).EQ.-9.OR.PDFGUP(2).EQ.-9) MINT(111)=12 + CALL PYNAME(IDBMUP(1),CHNAME) + CHBEAM=CHNAME(1:12) + CALL PYNAME(IDBMUP(2),CHNAME) + CHTARG=CHNAME(1:12) + ENDIF + +C...Convert character variables to lowercase and find their length. + CHCOM(1)=CHFRAM + CHCOM(2)=CHBEAM + CHCOM(3)=CHTARG + DO 130 I=1,3 + LEN(I)=12 + DO 110 LL=12,1,-1 + IF(LEN(I).EQ.LL.AND.CHCOM(I)(LL:LL).EQ.' ') LEN(I)=LL-1 + DO 100 LA=1,26 + IF(CHCOM(I)(LL:LL).EQ.CHALP(2)(LA:LA)) CHCOM(I)(LL:LL)= + & CHALP(1)(LA:LA) + 100 CONTINUE + 110 CONTINUE + CHIDNT(I)=CHCOM(I) + +C...Fix up bar, underscore and charge in particle name (if needed). + DO 120 LL=1,10 + IF(CHIDNT(I)(LL:LL).EQ.'~') THEN + CHTEMP=CHIDNT(I) + CHIDNT(I)=CHTEMP(1:LL-1)//'bar'//CHTEMP(LL+1:10)//' ' + ENDIF + 120 CONTINUE + IF(CHIDNT(I)(1:2).EQ.'nu'.AND.CHIDNT(I)(3:3).NE.'_') THEN + CHTEMP=CHIDNT(I) + CHIDNT(I)='nu_'//CHTEMP(3:7) + ELSEIF(CHIDNT(I)(1:2).EQ.'n ') THEN + CHIDNT(I)(1:3)='n0 ' + ELSEIF(CHIDNT(I)(1:4).EQ.'nbar') THEN + CHIDNT(I)(1:5)='nbar0' + ELSEIF(CHIDNT(I)(1:2).EQ.'p ') THEN + CHIDNT(I)(1:3)='p+ ' + ELSEIF(CHIDNT(I)(1:4).EQ.'pbar'.OR. + & CHIDNT(I)(1:2).EQ.'p-') THEN + CHIDNT(I)(1:5)='pbar-' + ELSEIF(CHIDNT(I)(1:6).EQ.'lambda') THEN + CHIDNT(I)(7:7)='0' + ELSEIF(CHIDNT(I)(1:3).EQ.'reg') THEN + CHIDNT(I)(1:7)='reggeon' + ELSEIF(CHIDNT(I)(1:3).EQ.'pom') THEN + CHIDNT(I)(1:7)='pomeron' + ENDIF + 130 CONTINUE + +C...Identify free initialization. + IF(CHCOM(1)(1:2).EQ.'no') THEN + MINT(65)=1 + RETURN + ENDIF + +C...Identify incoming beam and target particles. + DO 160 I=1,2 + DO 140 J=1,39 + IF(CHIDNT(I+1).EQ.CHCDE(J)) MINT(10+I)=KCDE(J) + 140 CONTINUE + PM(I)=PYMASS(MINT(10+I)) + VINT(2+I)=PM(I) + MINT(140+I)=0 + IF(MINT(10+I).EQ.22.AND.CHIDNT(I+1)(6:6).EQ.'/') THEN + CHTEMP=CHIDNT(I+1)(7:12)//' ' + DO 150 J=1,12 + IF(CHTEMP.EQ.CHCDE(J)) MINT(140+I)=KCDE(J) + 150 CONTINUE + PM(I)=PYMASS(MINT(140+I)) + VINT(302+I)=PM(I) + ENDIF + 160 CONTINUE + IF(MINT(11).EQ.0) WRITE(MSTU(11),5000) CHBEAM(1:LEN(2)) + IF(MINT(12).EQ.0) WRITE(MSTU(11),5100) CHTARG(1:LEN(3)) + IF(MINT(11).EQ.0.OR.MINT(12).EQ.0) CALL PYSTOP(7) + +C...Identify choice of frame and input energies. + CHINIT=' ' + +C...Events defined in the CM frame. + IF(CHCOM(1)(1:2).EQ.'cm') THEN + MINT(111)=1 + S=WIN**2 + IF(MSTP(122).GE.1) THEN + IF(CHCOM(2)(1:1).NE.'e') THEN + LOFFS=(31-(LEN(2)+LEN(3)))/2 + CHINIT(LOFFS+1:76)='PYTHIA will be initialized for a '// + & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))// + & ' collider'//' ' + ELSE + LOFFS=(30-(LEN(2)+LEN(3)))/2 + CHINIT(LOFFS+1:76)='PYTHIA will be initialized for an '// + & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))// + & ' collider'//' ' + ENDIF + WRITE(MSTU(11),5200) CHINIT + WRITE(MSTU(11),5300) WIN + ENDIF + +C...Events defined in fixed target frame. + ELSEIF(CHCOM(1)(1:3).EQ.'fix') THEN + MINT(111)=2 + S=PM(1)**2+PM(2)**2+2D0*PM(2)*SQRT(PM(1)**2+WIN**2) + IF(MSTP(122).GE.1) THEN + LOFFS=(29-(LEN(2)+LEN(3)))/2 + CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '// + & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))// + & ' fixed target'//' ' + WRITE(MSTU(11),5200) CHINIT + WRITE(MSTU(11),5400) WIN + WRITE(MSTU(11),5500) SQRT(S) + ENDIF + +C...Frame defined by user three-vectors. + ELSEIF(CHCOM(1)(1:1).EQ.'3') THEN + MINT(111)=3 + P(1,5)=PM(1) + P(2,5)=PM(2) + P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2) + P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2) + S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2- + & (P(1,3)+P(2,3))**2 + IF(MSTP(122).GE.1) THEN + LOFFS=(22-(LEN(2)+LEN(3)))/2 + CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '// + & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))// + & ' user configuration'//' ' + WRITE(MSTU(11),5200) CHINIT + WRITE(MSTU(11),5600) + WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4) + WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4) + WRITE(MSTU(11),5500) SQRT(MAX(0D0,S)) + ENDIF + +C...Frame defined by user four-vectors. + ELSEIF(CHCOM(1)(1:1).EQ.'4') THEN + MINT(111)=4 + PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2 + P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1) + PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2 + P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2) + S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2- + & (P(1,3)+P(2,3))**2 + IF(MSTP(122).GE.1) THEN + LOFFS=(22-(LEN(2)+LEN(3)))/2 + CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '// + & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))// + & ' user configuration'//' ' + WRITE(MSTU(11),5200) CHINIT + WRITE(MSTU(11),5600) + WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4) + WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4) + WRITE(MSTU(11),5500) SQRT(MAX(0D0,S)) + ENDIF + +C...Frame defined by user five-vectors. + ELSEIF(CHCOM(1)(1:1).EQ.'5') THEN + MINT(111)=5 + S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2- + & (P(1,3)+P(2,3))**2 + IF(MSTP(122).GE.1) THEN + LOFFS=(22-(LEN(2)+LEN(3)))/2 + CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '// + & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))// + & ' user configuration'//' ' + WRITE(MSTU(11),5200) CHINIT + WRITE(MSTU(11),5600) + WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4) + WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4) + WRITE(MSTU(11),5500) SQRT(MAX(0D0,S)) + ENDIF + +C...Frame defined by HEPRUP common block. + ELSEIF(MINT(111).GE.11) THEN + S=(EBMUP(1)+EBMUP(2))**2-(SQRT(MAX(0D0,EBMUP(1)**2-PM(1)**2))- + & SQRT(MAX(0D0,EBMUP(2)**2-PM(2)**2)))**2 + IF(MSTP(122).GE.1) THEN + LOFFS=(22-(LEN(2)+LEN(3)))/2 + CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '// + & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))// + & ' user configuration'//' ' + WRITE(MSTU(11),5200) CHINIT + WRITE(MSTU(11),6000) EBMUP(1),EBMUP(2) + WRITE(MSTU(11),5500) SQRT(MAX(0D0,S)) + ENDIF + +C...Unknown frame. Error for too low CM energy. + ELSE + WRITE(MSTU(11),5800) CHFRAM(1:LEN(1)) + CALL PYSTOP(7) + ENDIF + IF(S.LT.PARP(2)**2) THEN + WRITE(MSTU(11),5900) SQRT(S) + CALL PYSTOP(7) + ENDIF + +C...Formats for initialization and error information. + 5000 FORMAT(1X,'Error: unrecognized beam particle ''',A,'''D0'/ + &1X,'Execution stopped!') + 5100 FORMAT(1X,'Error: unrecognized target particle ''',A,'''D0'/ + &1X,'Execution stopped!') + 5200 FORMAT(/1X,78('=')/1X,'I',76X,'I'/1X,'I',A76,'I') + 5300 FORMAT(1X,'I',18X,'at',1X,F10.3,1X,'GeV center-of-mass energy', + &19X,'I'/1X,'I',76X,'I'/1X,78('=')) + 5400 FORMAT(1X,'I',22X,'at',1X,F10.3,1X,'GeV/c lab-momentum',22X,'I') + 5500 FORMAT(1X,'I',76X,'I'/1X,'I',11X,'corresponding to',1X,F10.3,1X, + &'GeV center-of-mass energy',12X,'I'/1X,'I',76X,'I'/1X,78('=')) + 5600 FORMAT(1X,'I',76X,'I'/1X,'I',18X,'px (GeV/c)',3X,'py (GeV/c)',3X, + &'pz (GeV/c)',6X,'E (GeV)',9X,'I') + 5700 FORMAT(1X,'I',8X,A8,4(2X,F10.3,1X),8X,'I') + 5800 FORMAT(1X,'Error: unrecognized coordinate frame ''',A,'''D0'/ + &1X,'Execution stopped!') + 5900 FORMAT(1X,'Error: too low CM energy,',F8.3,' GeV for event ', + &'generation.'/1X,'Execution stopped!') + 6000 FORMAT(1X,'I',12X,'with',1X,F10.3,1X,'GeV on',1X,F10.3,1X, + &'GeV beam energies',13X,'I') + + RETURN + END + +C********************************************************************* + +C...PYINKI +C...Sets up kinematics, including rotations and boosts to/from CM frame. + + SUBROUTINE PYINKI(MODKI) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP + +C...User process initialization commonblock. + INTEGER MAXPUP + PARAMETER (MAXPUP=100) + INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP + DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP + COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2), + &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP), + &LPRUP(MAXPUP) + SAVE /HEPRUP/ + +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/ + +C...Set initial flavour state. + N=2 + DO 100 I=1,2 + K(I,1)=1 + K(I,2)=MINT(10+I) + IF(MINT(140+I).NE.0) K(I,2)=MINT(140+I) + 100 CONTINUE + +C...Reset boost. Do kinematics for various cases. + DO 110 J=6,10 + VINT(J)=0D0 + 110 CONTINUE + +C...Set up kinematics for events defined in CM frame. + IF(MINT(111).EQ.1) THEN + WIN=VINT(290) + IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290) + S=WIN**2 + P(1,5)=VINT(3) + P(2,5)=VINT(4) + IF(MINT(141).NE.0) P(1,5)=VINT(303) + IF(MINT(142).NE.0) P(2,5)=VINT(304) + P(1,1)=0D0 + P(1,2)=0D0 + P(2,1)=0D0 + P(2,2)=0D0 + P(1,3)=SQRT(((S-P(1,5)**2-P(2,5)**2)**2-(2D0*P(1,5)*P(2,5))**2)/ + & (4D0*S)) + P(2,3)=-P(1,3) + P(1,4)=SQRT(P(1,3)**2+P(1,5)**2) + P(2,4)=SQRT(P(2,3)**2+P(2,5)**2) + +C...Set up kinematics for fixed target events. + ELSEIF(MINT(111).EQ.2) THEN + WIN=VINT(290) + IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290) + P(1,5)=VINT(3) + P(2,5)=VINT(4) + IF(MINT(141).NE.0) P(1,5)=VINT(303) + IF(MINT(142).NE.0) P(2,5)=VINT(304) + P(1,1)=0D0 + P(1,2)=0D0 + P(2,1)=0D0 + P(2,2)=0D0 + P(1,3)=WIN + P(1,4)=SQRT(P(1,3)**2+P(1,5)**2) + P(2,3)=0D0 + P(2,4)=P(2,5) + S=P(1,5)**2+P(2,5)**2+2D0*P(2,4)*P(1,4) + VINT(10)=P(1,3)/(P(1,4)+P(2,4)) + CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10)) + +C...Set up kinematics for events in user-defined frame. + ELSEIF(MINT(111).EQ.3) THEN + P(1,5)=VINT(3) + P(2,5)=VINT(4) + IF(MINT(141).NE.0) P(1,5)=VINT(303) + IF(MINT(142).NE.0) P(2,5)=VINT(304) + P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2) + P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2) + DO 120 J=1,3 + VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4)) + 120 CONTINUE + CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10)) + VINT(7)=PYANGL(P(1,1),P(1,2)) + CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0) + VINT(6)=PYANGL(P(1,3),P(1,1)) + CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0) + S=P(1,5)**2+P(2,5)**2+2D0*(P(1,4)*P(2,4)-P(1,3)*P(2,3)) + +C...Set up kinematics for events with user-defined four-vectors. + ELSEIF(MINT(111).EQ.4) THEN + PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2 + P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1) + PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2 + P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2) + DO 130 J=1,3 + VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4)) + 130 CONTINUE + CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10)) + VINT(7)=PYANGL(P(1,1),P(1,2)) + CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0) + VINT(6)=PYANGL(P(1,3),P(1,1)) + CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0) + S=(P(1,4)+P(2,4))**2 + +C...Set up kinematics for events with user-defined five-vectors. + ELSEIF(MINT(111).EQ.5) THEN + DO 140 J=1,3 + VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4)) + 140 CONTINUE + CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10)) + VINT(7)=PYANGL(P(1,1),P(1,2)) + CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0) + VINT(6)=PYANGL(P(1,3),P(1,1)) + CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0) + S=(P(1,4)+P(2,4))**2 + +C...Set up kinematics for events with external user processes. + ELSEIF(MINT(111).GE.11) THEN + P(1,5)=VINT(3) + P(2,5)=VINT(4) + IF(MINT(141).NE.0) P(1,5)=VINT(303) + IF(MINT(142).NE.0) P(2,5)=VINT(304) + P(1,1)=0D0 + P(1,2)=0D0 + P(2,1)=0D0 + P(2,2)=0D0 + P(1,3)=SQRT(MAX(0D0,EBMUP(1)**2-P(1,5)**2)) + P(2,3)=-SQRT(MAX(0D0,EBMUP(2)**2-P(2,5)**2)) + P(1,4)=EBMUP(1) + P(2,4)=EBMUP(2) + VINT(10)=(P(1,3)+P(2,3))/(P(1,4)+P(2,4)) + CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10)) + S=(P(1,4)+P(2,4))**2 + ENDIF + +C...Return or error for too low CM energy. + IF(MODKI.EQ.1.AND.S.LT.PARP(2)**2) THEN + IF(MSTP(172).LE.1) THEN + CALL PYERRM(23, + & '(PYINKI:) too low invariant mass in this event') + ELSE + MSTI(61)=1 + RETURN + ENDIF + ENDIF + +C...Save information on incoming particles. + VINT(1)=SQRT(S) + VINT(2)=S + IF(MINT(111).GE.4) THEN + IF(MINT(141).EQ.0) THEN + VINT(3)=P(1,5) + IF(MINT(11).EQ.22.AND.P(1,5).LT.0) VINT(307)=P(1,5)**2 + ELSE + VINT(303)=P(1,5) + ENDIF + IF(MINT(142).EQ.0) THEN + VINT(4)=P(2,5) + IF(MINT(12).EQ.22.AND.P(2,5).LT.0) VINT(308)=P(2,5)**2 + ELSE + VINT(304)=P(2,5) + ENDIF + ENDIF + VINT(5)=P(1,3) + IF(MODKI.EQ.0) VINT(289)=S + DO 150 J=1,5 + V(1,J)=0D0 + V(2,J)=0D0 + VINT(290+J)=P(1,J) + VINT(295+J)=P(2,J) + 150 CONTINUE + +C...Store pT cut-off and related constants to be used in generation. + IF(MODKI.EQ.0) VINT(285)=CKIN(3) + IF(MSTP(82).LE.1) THEN + PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90) + ELSE + PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90) + ENDIF + VINT(149)=4D0*PTMN**2/S + VINT(154)=PTMN + + RETURN + END + +C********************************************************************* + +C...PYINPR +C...Selects partonic subprocesses to be included in the simulation. + + SUBROUTINE PYINPR + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP + +C...User process initialization commonblock. + INTEGER MAXPUP + PARAMETER (MAXPUP=100) + INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP + DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP + COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2), + &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP), + &LPRUP(MAXPUP) + SAVE /HEPRUP/ + +C...Commonblocks and character variables. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) + COMMON/PYINT6/PROC(0:500) + CHARACTER PROC*28 + SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/, + &/PYINT2/,/PYINT6/ + CHARACTER CHIPR*10 + + +C...Reset processes to be included. + IF(MSEL.NE.0) THEN + DO 100 I=1,500 + MSUB(I)=0 + 100 CONTINUE + ENDIF + +C...Set running pTmin scale. + IF(MSTP(82).LE.1) THEN + PTMRUN=PARP(81)*(VINT(1)/PARP(89))**PARP(90) + ELSE + PTMRUN=PARP(82)*(VINT(1)/PARP(89))**PARP(90) + ENDIF + +C...Begin by assuming incoming photon to enter subprocess. + IF(MINT(11).EQ.22) MINT(15)=22 + IF(MINT(12).EQ.22) MINT(16)=22 + +C...For e-gamma with MSTP(14)=10 allow mixture of VMD and anomalous. + IF(MINT(121).EQ.2.AND.MSTP(14).EQ.10) THEN + MSUB(10)=1 + MINT(123)=MINT(122)+1 + +C...For gamma-p or gamma-gamma with MSTP(14) = 10, 20, 25 or 30 +C...allow mixture. +C...Here also set a few parameters otherwise normally not touched. + ELSEIF(MINT(121).GT.1) THEN + +C...Parton distributions dampened at small Q2; go to low energies, +C...alpha_s <1; no minimum pT cut-off a priori. + IF(MSTP(18).EQ.2) THEN + MSTP(57)=3 + PARP(2)=2D0 + PARU(115)=1D0 + CKIN(5)=0.2D0 + CKIN(6)=0.2D0 + ENDIF + +C...Define pT cut-off parameters and whether run involves low-pT. + PTMVMD=PTMRUN + VINT(154)=PTMVMD + PTMDIR=PTMVMD + IF(MSTP(18).EQ.2) PTMDIR=PARP(15) + PTMANO=PTMVMD + IF(MSTP(15).EQ.5) PTMANO=0.60D0+ + & 0.125D0*LOG(1D0+0.10D0*VINT(1))**2 + IPTL=1 + IF(VINT(285).GT.MAX(PTMVMD,PTMDIR,PTMANO)) IPTL=0 + IF(MSEL.EQ.2) IPTL=1 + +C...Set up for p/gamma * gamma; real or virtual photons. + IF(MINT(121).EQ.3.OR.MINT(121).EQ.6.OR.(MINT(121).EQ.4.AND. + & MSTP(14).EQ.30)) THEN + +C...Set up for p/VMD * VMD. + IF(MINT(122).EQ.1) THEN + MINT(123)=2 + MSUB(11)=1 + MSUB(12)=1 + MSUB(13)=1 + MSUB(28)=1 + MSUB(53)=1 + MSUB(68)=1 + IF(IPTL.EQ.1) MSUB(95)=1 + IF(MSEL.EQ.2) THEN + MSUB(91)=1 + MSUB(92)=1 + MSUB(93)=1 + MSUB(94)=1 + ENDIF + IF(IPTL.EQ.1) CKIN(3)=0D0 + +C...Set up for p/VMD * direct gamma. + ELSEIF(MINT(122).EQ.2) THEN + MINT(123)=0 + IF(MINT(121).EQ.6) MINT(123)=5 + MSUB(131)=1 + MSUB(132)=1 + MSUB(135)=1 + MSUB(136)=1 + IF(IPTL.EQ.1) CKIN(3)=PTMDIR + +C...Set up for p/VMD * anomalous gamma. + ELSEIF(MINT(122).EQ.3) THEN + MINT(123)=3 + IF(MINT(121).EQ.6) MINT(123)=7 + MSUB(11)=1 + MSUB(12)=1 + MSUB(13)=1 + MSUB(28)=1 + MSUB(53)=1 + MSUB(68)=1 + IF(IPTL.EQ.1) MSUB(95)=1 + IF(MSEL.EQ.2) THEN + MSUB(91)=1 + MSUB(92)=1 + MSUB(93)=1 + MSUB(94)=1 + ENDIF + IF(IPTL.EQ.1) CKIN(3)=0D0 + +C...Set up for DIS * p. + ELSEIF(MINT(122).EQ.4.AND.(IABS(MINT(11)).GT.100.OR. + & IABS(MINT(12)).GT.100)) THEN + MINT(123)=8 + IF(IPTL.EQ.1) MSUB(99)=1 + +C...Set up for direct * direct gamma (switch off leptons). + ELSEIF(MINT(122).EQ.4) THEN + MINT(123)=0 + MSUB(137)=1 + MSUB(138)=1 + MSUB(139)=1 + MSUB(140)=1 + DO 110 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1 + IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1)) + 110 CONTINUE + IF(IPTL.EQ.1) CKIN(3)=PTMDIR + +C...Set up for direct * anomalous gamma. + ELSEIF(MINT(122).EQ.5) THEN + MINT(123)=6 + MSUB(131)=1 + MSUB(132)=1 + MSUB(135)=1 + MSUB(136)=1 + IF(IPTL.EQ.1) CKIN(3)=PTMANO + +C...Set up for anomalous * anomalous gamma. + ELSEIF(MINT(122).EQ.6) THEN + MINT(123)=3 + MSUB(11)=1 + MSUB(12)=1 + MSUB(13)=1 + MSUB(28)=1 + MSUB(53)=1 + MSUB(68)=1 + IF(IPTL.EQ.1) MSUB(95)=1 + IF(MSEL.EQ.2) THEN + MSUB(91)=1 + MSUB(92)=1 + MSUB(93)=1 + MSUB(94)=1 + ENDIF + IF(IPTL.EQ.1) CKIN(3)=0D0 + ENDIF + +C...Set up for gamma* * gamma*; virtual photons = dir, VMD, anom. + ELSEIF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN + +C...Set up for direct * direct gamma (switch off leptons). + IF(MINT(122).EQ.1) THEN + MINT(123)=0 + MSUB(137)=1 + MSUB(138)=1 + MSUB(139)=1 + MSUB(140)=1 + DO 120 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1 + IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1)) + 120 CONTINUE + IF(IPTL.EQ.1) CKIN(3)=PTMDIR + +C...Set up for direct * VMD and VMD * direct gamma. + ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.4) THEN + MINT(123)=5 + MSUB(131)=1 + MSUB(132)=1 + MSUB(135)=1 + MSUB(136)=1 + IF(IPTL.EQ.1) CKIN(3)=PTMDIR + +C...Set up for direct * anomalous and anomalous * direct gamma. + ELSEIF(MINT(122).EQ.3.OR.MINT(122).EQ.7) THEN + MINT(123)=6 + MSUB(131)=1 + MSUB(132)=1 + MSUB(135)=1 + MSUB(136)=1 + IF(IPTL.EQ.1) CKIN(3)=PTMANO + +C...Set up for VMD*VMD. + ELSEIF(MINT(122).EQ.5) THEN + MINT(123)=2 + MSUB(11)=1 + MSUB(12)=1 + MSUB(13)=1 + MSUB(28)=1 + MSUB(53)=1 + MSUB(68)=1 + IF(IPTL.EQ.1) MSUB(95)=1 + IF(MSEL.EQ.2) THEN + MSUB(91)=1 + MSUB(92)=1 + MSUB(93)=1 + MSUB(94)=1 + ENDIF + IF(IPTL.EQ.1) CKIN(3)=0D0 + +C...Set up for VMD * anomalous and anomalous * VMD gamma. + ELSEIF(MINT(122).EQ.6.OR.MINT(122).EQ.8) THEN + MINT(123)=7 + MSUB(11)=1 + MSUB(12)=1 + MSUB(13)=1 + MSUB(28)=1 + MSUB(53)=1 + MSUB(68)=1 + IF(IPTL.EQ.1) MSUB(95)=1 + IF(MSEL.EQ.2) THEN + MSUB(91)=1 + MSUB(92)=1 + MSUB(93)=1 + MSUB(94)=1 + ENDIF + IF(IPTL.EQ.1) CKIN(3)=0D0 + +C...Set up for anomalous * anomalous gamma. + ELSEIF(MINT(122).EQ.9) THEN + MINT(123)=3 + MSUB(11)=1 + MSUB(12)=1 + MSUB(13)=1 + MSUB(28)=1 + MSUB(53)=1 + MSUB(68)=1 + IF(IPTL.EQ.1) MSUB(95)=1 + IF(MSEL.EQ.2) THEN + MSUB(91)=1 + MSUB(92)=1 + MSUB(93)=1 + MSUB(94)=1 + ENDIF + IF(IPTL.EQ.1) CKIN(3)=0D0 + +C...Set up for DIS * VMD and VMD * DIS gamma. + ELSEIF(MINT(122).EQ.10.OR.MINT(122).EQ.12) THEN + MINT(123)=8 + IF(IPTL.EQ.1) MSUB(99)=1 + +C...Set up for DIS * anomalous and anomalous * DIS gamma. + ELSEIF(MINT(122).EQ.11.OR.MINT(122).EQ.13) THEN + MINT(123)=9 + IF(IPTL.EQ.1) MSUB(99)=1 + ENDIF + +C...Set up for gamma* * p; virtual photons = dir, res. + ELSEIF(MINT(121).EQ.2) THEN + +C...Set up for direct * p. + IF(MINT(122).EQ.1) THEN + MINT(123)=0 + MSUB(131)=1 + MSUB(132)=1 + MSUB(135)=1 + MSUB(136)=1 + IF(IPTL.EQ.1) CKIN(3)=PTMDIR + +C...Set up for resolved * p. + ELSEIF(MINT(122).EQ.2) THEN + MINT(123)=1 + MSUB(11)=1 + MSUB(12)=1 + MSUB(13)=1 + MSUB(28)=1 + MSUB(53)=1 + MSUB(68)=1 + IF(IPTL.EQ.1) MSUB(95)=1 + IF(MSEL.EQ.2) THEN + MSUB(91)=1 + MSUB(92)=1 + MSUB(93)=1 + MSUB(94)=1 + ENDIF + IF(IPTL.EQ.1) CKIN(3)=0D0 + ENDIF + +C...Set up for gamma* * gamma*; virtual photons = dir, res. + ELSEIF(MINT(121).EQ.4) THEN + +C...Set up for direct * direct gamma (switch off leptons). + IF(MINT(122).EQ.1) THEN + MINT(123)=0 + MSUB(137)=1 + MSUB(138)=1 + MSUB(139)=1 + MSUB(140)=1 + DO 130 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1 + IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1)) + 130 CONTINUE + IF(IPTL.EQ.1) CKIN(3)=PTMDIR + +C...Set up for direct * resolved and resolved * direct gamma. + ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.3) THEN + MINT(123)=5 + MSUB(131)=1 + MSUB(132)=1 + MSUB(135)=1 + MSUB(136)=1 + IF(IPTL.EQ.1) CKIN(3)=PTMDIR + +C...Set up for resolved * resolved gamma. + ELSEIF(MINT(122).EQ.4) THEN + MINT(123)=2 + MSUB(11)=1 + MSUB(12)=1 + MSUB(13)=1 + MSUB(28)=1 + MSUB(53)=1 + MSUB(68)=1 + IF(IPTL.EQ.1) MSUB(95)=1 + IF(MSEL.EQ.2) THEN + MSUB(91)=1 + MSUB(92)=1 + MSUB(93)=1 + MSUB(94)=1 + ENDIF + IF(IPTL.EQ.1) CKIN(3)=0D0 + ENDIF + +C...End of special set up for gamma-p and gamma-gamma. + ENDIF + CKIN(1)=2D0*CKIN(3) + ENDIF + +C...Flavour information for individual beams. + DO 140 I=1,2 + MINT(40+I)=1 + IF(MINT(123).GE.1.AND.MINT(10+I).EQ.22) MINT(40+I)=2 + IF(IABS(MINT(10+I)).GT.100) MINT(40+I)=2 + MINT(44+I)=MINT(40+I) + IF(MSTP(11).GE.1.AND.(IABS(MINT(10+I)).EQ.11.OR. + & IABS(MINT(10+I)).EQ.13.OR.IABS(MINT(10+I)).EQ.15)) MINT(44+I)=3 + 140 CONTINUE + +C...If two real gammas, whereof one direct, pick the first. +C...For two virtual photons, keep requested order. + IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN + IF(MSTP(14).LE.10.AND.MINT(123).GE.4.AND.MINT(123).LE.6) THEN + MINT(41)=1 + MINT(45)=1 + ELSEIF(MSTP(14).EQ.12.OR.MSTP(14).EQ.13.OR.MSTP(14).EQ.22.OR. + & MSTP(14).EQ.26.OR.MSTP(14).EQ.27) THEN + MINT(41)=1 + MINT(45)=1 + ELSEIF(MSTP(14).EQ.14.OR.MSTP(14).EQ.17.OR.MSTP(14).EQ.23.OR. + & MSTP(14).EQ.28.OR.MSTP(14).EQ.29) THEN + MINT(42)=1 + MINT(46)=1 + ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.2 + & .OR.MINT(122).EQ.3.OR.MINT(122).EQ.10.OR.MINT(122).EQ.11)) THEN + MINT(41)=1 + MINT(45)=1 + ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.4 + & .OR.MINT(122).EQ.7.OR.MINT(122).EQ.12.OR.MINT(122).EQ.13)) THEN + MINT(42)=1 + MINT(46)=1 + ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.2) THEN + MINT(41)=1 + MINT(45)=1 + ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.3) THEN + MINT(42)=1 + MINT(46)=1 + ENDIF + ELSEIF(MINT(11).EQ.22.OR.MINT(12).EQ.22) THEN + IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.28.OR.MINT(122).EQ.4) THEN + IF(MINT(11).EQ.22) THEN + MINT(41)=1 + MINT(45)=1 + ELSE + MINT(42)=1 + MINT(46)=1 + ENDIF + ENDIF + IF(MINT(123).GE.4.AND.MINT(123).LE.7) CALL PYERRM(26, + & '(PYINPR:) unallowed MSTP(14) code for single photon') + ENDIF + +C...Flavour information on combination of incoming particles. + MINT(43)=2*MINT(41)+MINT(42)-2 + MINT(44)=MINT(43) + IF(MINT(123).LE.0) THEN + IF(MINT(11).EQ.22) MINT(43)=MINT(43)+2 + IF(MINT(12).EQ.22) MINT(43)=MINT(43)+1 + ELSEIF(MINT(123).LE.3) THEN + IF(MINT(11).EQ.22) MINT(44)=MINT(44)-2 + IF(MINT(12).EQ.22) MINT(44)=MINT(44)-1 + ELSEIF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN + MINT(43)=4 + MINT(44)=1 + ENDIF + MINT(47)=2*MIN(2,MINT(45))+MIN(2,MINT(46))-2 + IF(MIN(MINT(45),MINT(46)).EQ.3) MINT(47)=5 + IF(MINT(45).EQ.1.AND.MINT(46).EQ.3) MINT(47)=6 + IF(MINT(45).EQ.3.AND.MINT(46).EQ.1) MINT(47)=7 + MINT(50)=0 + IF(MINT(41).EQ.2.AND.MINT(42).EQ.2.AND.MINT(111).NE.12) MINT(50)=1 + MINT(107)=0 + MINT(108)=0 + IF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN + IF((MINT(122).GE.4.AND.MINT(122).LE.6).OR.MINT(122).EQ.12) + & MINT(107)=2 + IF((MINT(122).GE.7.AND.MINT(122).LE.9).OR.MINT(122).EQ.13) + & MINT(107)=3 + IF(MINT(122).EQ.10.OR.MINT(122).EQ.11) MINT(107)=4 + IF(MINT(122).EQ.2.OR.MINT(122).EQ.5.OR.MINT(122).EQ.8.OR. + & MINT(122).EQ.10) MINT(108)=2 + IF(MINT(122).EQ.3.OR.MINT(122).EQ.6.OR.MINT(122).EQ.9.OR. + & MINT(122).EQ.11) MINT(108)=3 + IF(MINT(122).EQ.12.OR.MINT(122).EQ.13) MINT(108)=4 + ELSEIF(MINT(121).EQ.4.AND.MSTP(14).EQ.25) THEN + IF(MINT(122).GE.3) MINT(107)=1 + IF(MINT(122).EQ.2.OR.MINT(122).EQ.4) MINT(108)=1 + ELSEIF(MINT(121).EQ.2) THEN + IF(MINT(122).EQ.2.AND.MINT(11).EQ.22) MINT(107)=1 + IF(MINT(122).EQ.2.AND.MINT(12).EQ.22) MINT(108)=1 + ELSE + IF(MINT(11).EQ.22) THEN + MINT(107)=MINT(123) + IF(MINT(123).GE.4) MINT(107)=0 + IF(MINT(123).EQ.7) MINT(107)=2 + IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.27) MINT(107)=4 + IF(MSTP(14).EQ.28) MINT(107)=2 + IF(MSTP(14).EQ.29) MINT(107)=3 + IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4) + & MINT(107)=4 + ENDIF + IF(MINT(12).EQ.22) THEN + MINT(108)=MINT(123) + IF(MINT(123).GE.4) MINT(108)=MINT(123)-3 + IF(MINT(123).EQ.7) MINT(108)=3 + IF(MSTP(14).EQ.26) MINT(108)=2 + IF(MSTP(14).EQ.27) MINT(108)=3 + IF(MSTP(14).EQ.28.OR.MSTP(14).EQ.29) MINT(108)=4 + IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4) + & MINT(108)=4 + ENDIF + IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.(MSTP(14).EQ.14.OR. + & MSTP(14).EQ.17.OR.MSTP(14).EQ.18.OR.MSTP(14).EQ.23)) THEN + MINTTP=MINT(107) + MINT(107)=MINT(108) + MINT(108)=MINTTP + ENDIF + ENDIF + IF(MINT(15).EQ.22.AND.MINT(41).EQ.2) MINT(15)=0 + IF(MINT(16).EQ.22.AND.MINT(42).EQ.2) MINT(16)=0 + +C...Select default processes according to incoming beams +C...(already done for gamma-p and gamma-gamma with +C...MSTP(14) = 10, 20, 25 or 30). + IF(MINT(121).GT.1) THEN + ELSEIF(MSEL.EQ.1.OR.MSEL.EQ.2) THEN + + IF(MINT(43).EQ.1) THEN +C...Lepton + lepton -> gamma/Z0 or W. + IF(MINT(11)+MINT(12).EQ.0) MSUB(1)=1 + IF(MINT(11)+MINT(12).NE.0) MSUB(2)=1 + + ELSEIF(MINT(43).LE.3.AND.MINT(123).EQ.0.AND. + & (MINT(11).EQ.22.OR.MINT(12).EQ.22)) THEN +C...Unresolved photon + lepton: Compton scattering. + MSUB(133)=1 + MSUB(134)=1 + + ELSEIF((MINT(123).EQ.8.OR.MINT(123).EQ.9).AND.(MINT(11).EQ.22 + & .OR.MINT(12).EQ.22)) THEN +C...DIS as pure gamma* + f -> f process. + MSUB(99)=1 + + ELSEIF(MINT(43).LE.3) THEN +C...Lepton + hadron: deep inelastic scattering. + MSUB(10)=1 + + ELSEIF(MINT(123).EQ.0.AND.MINT(11).EQ.22.AND. + & MINT(12).EQ.22) THEN +C...Two unresolved photons: fermion pair production, +C...exclude lepton pairs. + DO 150 ISUB=137,140 + MSUB(ISUB)=1 + 150 CONTINUE + DO 160 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1 + IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1)) + 160 CONTINUE + PTMDIR=PTMRUN + IF(MSTP(18).EQ.2) PTMDIR=PARP(15) + IF(CKIN(3).LT.PTMRUN.OR.MSEL.EQ.2) CKIN(3)=PTMDIR + CKIN(1)=MAX(CKIN(1),2D0*CKIN(3)) + + ELSEIF((MINT(123).EQ.0.AND.(MINT(11).EQ.22.OR.MINT(12).EQ.22)) + & .OR.(MINT(123).GE.4.AND.MINT(123).LE.6.AND.MINT(11).EQ.22.AND. + & MINT(12).EQ.22)) THEN +C...Unresolved photon + hadron: photon-parton scattering. + DO 170 ISUB=131,136 + MSUB(ISUB)=1 + 170 CONTINUE + + ELSEIF(MSEL.EQ.1) THEN +C...High-pT QCD processes: + MSUB(11)=1 + MSUB(12)=1 + MSUB(13)=1 + MSUB(28)=1 + MSUB(53)=1 + MSUB(68)=1 + PTMN=PTMRUN + VINT(154)=PTMN + IF(CKIN(3).LT.PTMN) MSUB(95)=1 + IF(MSUB(95).EQ.1.AND.MINT(50).EQ.0) MSUB(95)=0 + + ELSE +C...All QCD processes: + MSUB(11)=1 + MSUB(12)=1 + MSUB(13)=1 + MSUB(28)=1 + MSUB(53)=1 + MSUB(68)=1 + MSUB(91)=1 + MSUB(92)=1 + MSUB(93)=1 + MSUB(94)=1 + MSUB(95)=1 + ENDIF + + ELSEIF(MSEL.GE.4.AND.MSEL.LE.8) THEN +C...Heavy quark production. + MSUB(81)=1 + MSUB(82)=1 + MSUB(84)=1 + DO 180 J=1,MIN(8,MDCY(21,3)) + MDME(MDCY(21,2)+J-1,1)=0 + 180 CONTINUE + MDME(MDCY(21,2)+MSEL-1,1)=1 + MSUB(85)=1 + DO 190 J=1,MIN(12,MDCY(22,3)) + MDME(MDCY(22,2)+J-1,1)=0 + 190 CONTINUE + MDME(MDCY(22,2)+MSEL-1,1)=1 + + ELSEIF(MSEL.EQ.10) THEN +C...Prompt photon production: + MSUB(14)=1 + MSUB(18)=1 + MSUB(29)=1 + + ELSEIF(MSEL.EQ.11) THEN +C...Z0/gamma* production: + MSUB(1)=1 + + ELSEIF(MSEL.EQ.12) THEN +C...W+/- production: + MSUB(2)=1 + + ELSEIF(MSEL.EQ.13) THEN +C...Z0 + jet: + MSUB(15)=1 + MSUB(30)=1 + + ELSEIF(MSEL.EQ.14) THEN +C...W+/- + jet: + MSUB(16)=1 + MSUB(31)=1 + + ELSEIF(MSEL.EQ.15) THEN +C...Z0 & W+/- pair production: + MSUB(19)=1 + MSUB(20)=1 + MSUB(22)=1 + MSUB(23)=1 + MSUB(25)=1 + + ELSEIF(MSEL.EQ.16) THEN +C...h0 production: + MSUB(3)=1 + MSUB(102)=1 + MSUB(103)=1 + MSUB(123)=1 + MSUB(124)=1 + + ELSEIF(MSEL.EQ.17) THEN +C...h0 & Z0 or W+/- pair production: + MSUB(24)=1 + MSUB(26)=1 + + ELSEIF(MSEL.EQ.18) THEN +C...h0 production; interesting processes in e+e-. + MSUB(24)=1 + MSUB(103)=1 + MSUB(123)=1 + MSUB(124)=1 + + ELSEIF(MSEL.EQ.19) THEN +C...h0, H0 and A0 production; interesting processes in e+e-. + MSUB(24)=1 + MSUB(103)=1 + MSUB(123)=1 + MSUB(124)=1 + MSUB(153)=1 + MSUB(171)=1 + MSUB(173)=1 + MSUB(174)=1 + MSUB(158)=1 + MSUB(176)=1 + MSUB(178)=1 + MSUB(179)=1 + + ELSEIF(MSEL.EQ.21) THEN +C...Z'0 production: + MSUB(141)=1 + + ELSEIF(MSEL.EQ.22) THEN +C...W'+/- production: + MSUB(142)=1 + + ELSEIF(MSEL.EQ.23) THEN +C...H+/- production: + MSUB(143)=1 + + ELSEIF(MSEL.EQ.24) THEN +C...R production: + MSUB(144)=1 + + ELSEIF(MSEL.EQ.25) THEN +C...LQ (leptoquark) production. + MSUB(145)=1 + MSUB(162)=1 + MSUB(163)=1 + MSUB(164)=1 + + ELSEIF(MSEL.GE.35.AND.MSEL.LE.38) THEN +C...Production of one heavy quark (W exchange): + MSUB(83)=1 + DO 200 J=1,MIN(8,MDCY(21,3)) + MDME(MDCY(21,2)+J-1,1)=0 + 200 CONTINUE + MDME(MDCY(21,2)+MSEL-31,1)=1 + +CMRENNA++Define SUSY alternatives. + ELSEIF(MSEL.EQ.39) THEN +C...Turn on all SUSY processes. + IF(MINT(43).EQ.4) THEN +C...Hadron-hadron processes. + DO 210 I=201,296 + IF(ISET(I).GE.0) MSUB(I)=1 + 210 CONTINUE + ELSEIF(MINT(43).EQ.1) THEN +C...Lepton-lepton processes: QED production of squarks. + DO 220 I=201,214 + MSUB(I)=1 + 220 CONTINUE + MSUB(210)=0 + MSUB(211)=0 + MSUB(212)=0 + DO 230 I=216,228 + MSUB(I)=1 + 230 CONTINUE + DO 240 I=261,263 + MSUB(I)=1 + 240 CONTINUE + MSUB(277)=1 + MSUB(278)=1 + ENDIF + + ELSEIF(MSEL.EQ.40) THEN +C...Gluinos and squarks. + IF(MINT(43).EQ.4) THEN + MSUB(243)=1 + MSUB(244)=1 + MSUB(258)=1 + MSUB(259)=1 + MSUB(261)=1 + MSUB(262)=1 + MSUB(264)=1 + MSUB(265)=1 + DO 250 I=271,296 + MSUB(I)=1 + 250 CONTINUE + ELSEIF(MINT(43).EQ.1) THEN + MSUB(277)=1 + MSUB(278)=1 + ENDIF + + ELSEIF(MSEL.EQ.41) THEN +C...Stop production. + MSUB(261)=1 + MSUB(262)=1 + MSUB(263)=1 + IF(MINT(43).EQ.4) THEN + MSUB(264)=1 + MSUB(265)=1 + ENDIF + + ELSEIF(MSEL.EQ.42) THEN +C...Slepton production. + DO 260 I=201,214 + MSUB(I)=1 + 260 CONTINUE + IF(MINT(43).NE.4) THEN + MSUB(210)=0 + MSUB(211)=0 + MSUB(212)=0 + ENDIF + + ELSEIF(MSEL.EQ.43) THEN +C...Neutralino/Chargino + Gluino/Squark. + IF(MINT(43).EQ.4) THEN + DO 270 I=237,242 + MSUB(I)=1 + 270 CONTINUE + DO 280 I=246,254 + MSUB(I)=1 + 280 CONTINUE + MSUB(256)=1 + ENDIF + + ELSEIF(MSEL.EQ.44) THEN +C...Neutralino/Chargino pair production. + IF(MINT(43).EQ.4) THEN + DO 290 I=216,236 + MSUB(I)=1 + 290 CONTINUE + ELSEIF(MINT(43).EQ.1) THEN + DO 300 I=216,228 + MSUB(I)=1 + 300 CONTINUE + ENDIF + + ELSEIF(MSEL.EQ.45) THEN +C...Sbottom production. + MSUB(287)=1 + MSUB(288)=1 + IF(MINT(43).EQ.4) THEN + DO 310 I=281,296 + MSUB(I)=1 + 310 CONTINUE + ENDIF + + ELSEIF(MSEL.EQ.50) THEN +C...Pair production of technipions and gauge bosons. + DO 320 I=361,368 + MSUB(I)=1 + 320 CONTINUE + IF(MINT(43).EQ.4) THEN + DO 330 I=370,377 + MSUB(I)=1 + 330 CONTINUE + ENDIF + + ELSEIF(MSEL.EQ.51) THEN +C...QCD 2 -> 2 processes with compositeness/technicolor modifications. + DO 340 I=381,386 + MSUB(I)=1 + 340 CONTINUE + + ELSEIF(MSEL.EQ.61) THEN +C...Charmonium production in colour octet model, with recoiling parton. + DO 342 I=421,439 + MSUB(I)=1 + 342 CONTINUE + + ELSEIF(MSEL.EQ.62) THEN +C...Bottomonium production in colour octet model, with recoiling parton. + DO 344 I=461,479 + MSUB(I)=1 + 344 CONTINUE + + ELSEIF(MSEL.EQ.63) THEN +C...Charmonium and bottomonium production in colour octet model. + DO 346 I=421,439 + MSUB(I)=1 + MSUB(I+40)=1 + 346 CONTINUE + ENDIF + +C...Find heaviest new quark flavour allowed in processes 81-84. + KFLQM=1 + DO 350 I=1,MIN(8,MDCY(21,3)) + IDC=I+MDCY(21,2)-1 + IF(MDME(IDC,1).LE.0) GOTO 350 + KFLQM=I + 350 CONTINUE + IF(MSTP(7).GE.1.AND.MSTP(7).LE.8.AND.(MSEL.LE.3.OR.MSEL.GE.9)) + &KFLQM=MSTP(7) + MINT(55)=KFLQM + KFPR(81,1)=KFLQM + KFPR(81,2)=KFLQM + KFPR(82,1)=KFLQM + KFPR(82,2)=KFLQM + KFPR(83,1)=KFLQM + KFPR(84,1)=KFLQM + KFPR(84,2)=KFLQM + +C...Find heaviest new fermion flavour allowed in process 85. + KFLFM=1 + DO 360 I=1,MIN(12,MDCY(22,3)) + IDC=I+MDCY(22,2)-1 + IF(MDME(IDC,1).LE.0) GOTO 360 + KFLFM=KFDP(IDC,1) + 360 CONTINUE + IF(((MSTP(7).GE.1.AND.MSTP(7).LE.8).OR.(MSTP(7).GE.11.AND. + &MSTP(7).LE.18)).AND.(MSEL.LE.3.OR.MSEL.GE.9)) KFLFM=MSTP(7) + MINT(56)=KFLFM + KFPR(85,1)=KFLFM + KFPR(85,2)=KFLFM + +C...Initialize Generic Processes + KFGEN=9900001 + KCGEN=PYCOMP(KFGEN) + IF(KCGEN.GT.0) THEN + IDCY=MDCY(KCGEN,2) + IF(IDCY.GT.0) THEN + KFF1=KFDP(IDCY+1,1) + KFF2=KFDP(IDCY+1,2) + KCF1=PYCOMP(KFF1) + KCF2=PYCOMP(KFF2) + JCOL1=IABS(KCHG(KCF1,2)) + IF(JCOL1.EQ.1) THEN + KF1=KFF1 + KF2=KFF2 + ELSE + KF1=KFF2 + KF2=KFF1 + ENDIF + KFPR(481,1)=KF1 + KFPR(481,2)=KF2 + KFPR(482,1)=KF1 + KFPR(482,2)=KF2 + ENDIF + IF(KFDP(IDCY,1).EQ.21.OR.KFDP(IDCY,2).EQ.21) THEN + KFIN(1,0)=1 + KFIN(2,0)=1 + ENDIF + ENDIF + +C...Import relevant information on external user processes. + IF(MINT(111).GE.11) THEN + IPYPR=0 + DO 390 IUP=1,NPRUP +C...Find next empty PYTHIA process number slot and enable it. + 370 IPYPR=IPYPR+1 + IF(IPYPR.GT.500) CALL PYERRM(26, + & '(PYINPR.) no more empty slots for user processes') + IF(ISET(IPYPR).GE.0.AND.ISET(IPYPR).LE.9) GOTO 370 + IF(IPYPR.GE.91.AND.IPYPR.LE.100) GOTO 370 + ISET(IPYPR)=11 +C...Overwrite KFPR with references back to process number and ID. + KFPR(IPYPR,1)=IUP + KFPR(IPYPR,2)=LPRUP(IUP) +C...Process title. + WRITE(CHIPR,'(I10)') LPRUP(IUP) + ICHIN=1 + DO 380 ICH=1,9 + IF(CHIPR(ICH:ICH).EQ.' ') ICHIN=ICH+1 + 380 CONTINUE + PROC(IPYPR)='User process '//CHIPR(ICHIN:10)//' ' +C...Switch on process. + MSUB(IPYPR)=1 + 390 CONTINUE + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYXTOT +C...Parametrizes total, elastic and diffractive cross-sections +C...for different energies and beams. Donnachie-Landshoff for +C...total and Schuler-Sjostrand for elastic and diffractive. +C...Process code IPROC: +C...= 1 : p + p; +C...= 2 : pbar + p; +C...= 3 : pi+ + p; +C...= 4 : pi- + p; +C...= 5 : pi0 + p; +C...= 6 : phi + p; +C...= 7 : J/psi + p; +C...= 11 : rho + rho; +C...= 12 : rho + phi; +C...= 13 : rho + J/psi; +C...= 14 : phi + phi; +C...= 15 : phi + J/psi; +C...= 16 : J/psi + J/psi; +C...= 21 : gamma + p (DL); +C...= 22 : gamma + p (VDM). +C...= 23 : gamma + pi (DL); +C...= 24 : gamma + pi (VDM); +C...= 25 : gamma + gamma (DL); +C...= 26 : gamma + gamma (VDM). + + SUBROUTINE PYXTOT + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) + COMMON/PYINT7/SIGT(0:6,0:6,0:5) + SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT5/,/PYINT7/ +C...Local arrays. + DIMENSION NPROC(30),XPAR(30),YPAR(30),IHADA(20),IHADB(20), + &PMHAD(4),BHAD(4),BETP(4),IFITSD(20),IFITDD(20),CEFFS(10,8), + &CEFFD(10,9),SIGTMP(6,0:5) + +C...Common constants. + DATA EPS/0.0808D0/, ETA/-0.4525D0/, ALP/0.25D0/, CRES/2D0/, + &PMRC/1.062D0/, SMP/0.880D0/, FACEL/0.0511D0/, FACSD/0.0336D0/, + &FACDD/0.0084D0/ + +C...Number of multiple processes to be evaluated (= 0 : undefined). + DATA NPROC/7*1,3*0,6*1,4*0,4*3,2*6,4*0/ +C...X and Y parameters of sigmatot = X * s**epsilon + Y * s**(-eta). + DATA XPAR/2*21.70D0,3*13.63D0,10.01D0,0.970D0,3*0D0, + &8.56D0,6.29D0,0.609D0,4.62D0,0.447D0,0.0434D0,4*0D0, + &0.0677D0,0.0534D0,0.0425D0,0.0335D0,2.11D-4,1.31D-4,4*0D0/ + DATA YPAR/ + &56.08D0,98.39D0,27.56D0,36.02D0,31.79D0,-1.51D0,-0.146D0,3*0D0, + &13.08D0,-0.62D0,-0.060D0,0.030D0,-0.0028D0,0.00028D0,4*0D0, + &0.129D0,0.115D0,0.081D0,0.072D0,2.15D-4,1.70D-4,4*0D0/ + +C...Beam and target hadron class: +C...= 1 : p/n ; = 2 : pi/rho/omega; = 3 : phi; = 4 : J/psi. + DATA IHADA/2*1,3*2,3,4,3*0,3*2,2*3,4,4*0/ + DATA IHADB/7*1,3*0,2,3,4,3,2*4,4*0/ +C...Characteristic class masses, slope parameters, beta = sqrt(X). + DATA PMHAD/0.938D0,0.770D0,1.020D0,3.097D0/ + DATA BHAD/2.3D0,1.4D0,1.4D0,0.23D0/ + DATA BETP/4.658D0,2.926D0,2.149D0,0.208D0/ + +C...Fitting constants used in parametrizations of diffractive results. + DATA IFITSD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/ + DATA IFITDD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/ + DATA ((CEFFS(J1,J2),J2=1,8),J1=1,10)/ + &0.213D0, 0.0D0, -0.47D0, 150D0, 0.213D0, 0.0D0, -0.47D0, 150D0, + &0.213D0, 0.0D0, -0.47D0, 150D0, 0.267D0, 0.0D0, -0.47D0, 100D0, + &0.213D0, 0.0D0, -0.47D0, 150D0, 0.232D0, 0.0D0, -0.47D0, 110D0, + &0.213D0, 7.0D0, -0.55D0, 800D0, 0.115D0, 0.0D0, -0.47D0, 110D0, + &0.267D0, 0.0D0, -0.46D0, 75D0, 0.267D0, 0.0D0, -0.46D0, 75D0, + &0.232D0, 0.0D0, -0.46D0, 85D0, 0.267D0, 0.0D0, -0.48D0, 100D0, + &0.115D0, 0.0D0, -0.50D0, 90D0, 0.267D0, 6.0D0, -0.56D0, 420D0, + &0.232D0, 0.0D0, -0.48D0, 110D0, 0.232D0, 0.0D0, -0.48D0, 110D0, + &0.115D0, 0.0D0, -0.52D0, 120D0, 0.232D0, 6.0D0, -0.56D0, 470D0, + &0.115D0, 5.5D0, -0.58D0, 570D0, 0.115D0, 5.5D0, -0.58D0, 570D0/ + DATA ((CEFFD(J1,J2),J2=1,9),J1=1,10)/ + &3.11D0, -7.34D0, 9.71D0, 0.068D0, -0.42D0, 1.31D0, + &-1.37D0, 35.0D0, 118D0, 3.11D0, -7.10D0, 10.6D0, + &0.073D0, -0.41D0, 1.17D0, -1.41D0, 31.6D0, 95D0, + &3.12D0, -7.43D0, 9.21D0, 0.067D0, -0.44D0, 1.41D0, + &-1.35D0, 36.5D0, 132D0, 3.13D0, -8.18D0, -4.20D0, + &0.056D0, -0.71D0, 3.12D0, -1.12D0, 55.2D0, 1298D0, + &3.11D0, -6.90D0, 11.4D0, 0.078D0, -0.40D0, 1.05D0, + &-1.40D0, 28.4D0, 78D0, 3.11D0, -7.13D0, 10.0D0, + &0.071D0, -0.41D0, 1.23D0, -1.34D0, 33.1D0, 105D0, + &3.12D0, -7.90D0, -1.49D0, 0.054D0, -0.64D0, 2.72D0, + &-1.13D0, 53.1D0, 995D0, 3.11D0, -7.39D0, 8.22D0, + &0.065D0, -0.44D0, 1.45D0, -1.36D0, 38.1D0, 148D0, + &3.18D0, -8.95D0, -3.37D0, 0.057D0, -0.76D0, 3.32D0, + &-1.12D0, 55.6D0, 1472D0, 4.18D0, -29.2D0, 56.2D0, + &0.074D0, -1.36D0, 6.67D0, -1.14D0, 116.2D0, 6532D0/ + +C...Parameters. Combinations of the energy. + AEM=PARU(101) + PMTH=PARP(102) + S=VINT(2) + SRT=VINT(1) + SEPS=S**EPS + SETA=S**ETA + SLOG=LOG(S) + +C...Ratio of gamma/pi (for rescaling in parton distributions). + VINT(281)=(XPAR(22)*SEPS+YPAR(22)*SETA)/ + &(XPAR(5)*SEPS+YPAR(5)*SETA) + VINT(317)=1D0 + IF(MINT(50).NE.1) RETURN + +C...Order flavours of incoming particles: KF1 < KF2. + IF(IABS(MINT(11)).LE.IABS(MINT(12))) THEN + KF1=IABS(MINT(11)) + KF2=IABS(MINT(12)) + IORD=1 + ELSE + KF1=IABS(MINT(12)) + KF2=IABS(MINT(11)) + IORD=2 + ENDIF + ISGN12=ISIGN(1,MINT(11)*MINT(12)) + +C...Find process number (for lookup tables). + IF(KF1.GT.1000) THEN + IPROC=1 + IF(ISGN12.LT.0) IPROC=2 + ELSEIF(KF1.GT.100.AND.KF2.GT.1000) THEN + IPROC=3 + IF(ISGN12.LT.0) IPROC=4 + IF(KF1.EQ.111) IPROC=5 + ELSEIF(KF1.GT.100) THEN + IPROC=11 + ELSEIF(KF2.GT.1000) THEN + IPROC=21 + IF(MINT(123).EQ.2.OR.MINT(123).EQ.3) IPROC=22 + ELSEIF(KF2.GT.100) THEN + IPROC=23 + IF(MINT(123).EQ.2.OR.MINT(123).EQ.3) IPROC=24 + ELSE + IPROC=25 + IF(MINT(123).EQ.2.OR.MINT(123).EQ.3.OR.MINT(123).EQ.7) IPROC=26 + ENDIF + +C... Number of multiple processes to be stored; beam/target side. + NPR=NPROC(IPROC) + MINT(101)=1 + MINT(102)=1 + IF(NPR.EQ.3) THEN + MINT(100+IORD)=4 + ELSEIF(NPR.EQ.6) THEN + MINT(101)=4 + MINT(102)=4 + ENDIF + N1=0 + IF(MINT(101).EQ.4) N1=4 + N2=0 + IF(MINT(102).EQ.4) N2=4 + +C...Do not do any more for user-set or undefined cross-sections. + IF(MSTP(31).LE.0) RETURN + IF(NPR.EQ.0) CALL PYERRM(26, + &'(PYXTOT:) cross section for this process not yet implemented') + +C...Parameters. Combinations of the energy. + AEM=PARU(101) + PMTH=PARP(102) + S=VINT(2) + SRT=VINT(1) + SEPS=S**EPS + SETA=S**ETA + SLOG=LOG(S) + +C...Loop over multiple processes (for VDM). + DO 110 I=1,NPR + IF(NPR.EQ.1) THEN + IPR=IPROC + ELSEIF(NPR.EQ.3) THEN + IPR=I+4 + IF(KF2.LT.1000) IPR=I+10 + ELSEIF(NPR.EQ.6) THEN + IPR=I+10 + ENDIF + +C...Evaluate hadron species, mass, slope contribution and fit number. + IHA=IHADA(IPR) + IHB=IHADB(IPR) + PMA=PMHAD(IHA) + PMB=PMHAD(IHB) + BHA=BHAD(IHA) + BHB=BHAD(IHB) + ISD=IFITSD(IPR) + IDD=IFITDD(IPR) + +C...Skip if energy too low relative to masses. + DO 100 J=0,5 + SIGTMP(I,J)=0D0 + 100 CONTINUE + IF(SRT.LT.PMA+PMB+PARP(104)) GOTO 110 + +C...Total cross-section. Elastic slope parameter and cross-section. + SIGTMP(I,0)=XPAR(IPR)*SEPS+YPAR(IPR)*SETA + BEL=2D0*BHA+2D0*BHB+4D0*SEPS-4.2D0 + SIGTMP(I,1)=FACEL*SIGTMP(I,0)**2/BEL + +C...Diffractive scattering A + B -> X + B. + BSD=2D0*BHB + SQML=(PMA+PMTH)**2 + SQMU=S*CEFFS(ISD,1)+CEFFS(ISD,2) + SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/ + & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP) + BXB=CEFFS(ISD,3)+CEFFS(ISD,4)/S + SUM2=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)/ + & (BSD+2D0*ALP*LOG(S/((PMA+PMTH)*(PMA+PMRC)))+BXB) + SIGTMP(I,2)=FACSD*XPAR(IPR)*BETP(IHB)*MAX(0D0,SUM1+SUM2) + +C...Diffractive scattering A + B -> A + X. + BSD=2D0*BHA + SQML=(PMB+PMTH)**2 + SQMU=S*CEFFS(ISD,5)+CEFFS(ISD,6) + SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/ + & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP) + BAX=CEFFS(ISD,7)+CEFFS(ISD,8)/S + SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/ + & (BSD+2D0*ALP*LOG(S/((PMB+PMTH)*(PMB+PMRC)))+BAX) + SIGTMP(I,3)=FACSD*XPAR(IPR)*BETP(IHA)*MAX(0D0,SUM1+SUM2) + +C...Order single diffractive correctly. + IF(IORD.EQ.2) THEN + SIGSAV=SIGTMP(I,2) + SIGTMP(I,2)=SIGTMP(I,3) + SIGTMP(I,3)=SIGSAV + ENDIF + +C...Double diffractive scattering A + B -> X1 + X2. + YEFF=LOG(S*SMP/((PMA+PMTH)*(PMB+PMTH))**2) + DEFF=CEFFD(IDD,1)+CEFFD(IDD,2)/SLOG+CEFFD(IDD,3)/SLOG**2 + SUM1=(DEFF+YEFF*(LOG(MAX(1D-10,YEFF/DEFF))-1D0))/(2D0*ALP) + IF(YEFF.LE.0) SUM1=0D0 + SQMU=S*(CEFFD(IDD,4)+CEFFD(IDD,5)/SLOG+CEFFD(IDD,6)/SLOG**2) + SLUP=LOG(MAX(1.1D0,S/(ALP*(PMA+PMTH)**2*(PMB+PMTH)*(PMB+PMRC)))) + SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMB+PMTH)*(PMB+PMRC)))) + SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)*LOG(SLUP/SLDN)/ + & (2D0*ALP) + SLUP=LOG(MAX(1.1D0,S/(ALP*(PMB+PMTH)**2*(PMA+PMTH)*(PMA+PMRC)))) + SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMA+PMTH)*(PMA+PMRC)))) + SUM3=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*LOG(SLUP/SLDN)/ + & (2D0*ALP) + BXX=CEFFD(IDD,7)+CEFFD(IDD,8)/SRT+CEFFD(IDD,9)/S + SLRR=LOG(S/(ALP*(PMA+PMTH)*(PMA+PMRC)*(PMB+PMTH)*(PMB+PMRC))) + SUM4=CRES**2*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)* + & LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/MAX(0.1D0,2D0*ALP*SLRR+BXX) + SIGTMP(I,4)=FACDD*XPAR(IPR)*MAX(0D0,SUM1+SUM2+SUM3+SUM4) + +C...Non-diffractive by unitarity. + SIGTMP(I,5)=SIGTMP(I,0)-SIGTMP(I,1)-SIGTMP(I,2)-SIGTMP(I,3)- + & SIGTMP(I,4) + 110 CONTINUE + +C...Put temporary results in output array: only one process. + IF(MINT(101).EQ.1.AND.MINT(102).EQ.1) THEN + DO 120 J=0,5 + SIGT(0,0,J)=SIGTMP(1,J) + 120 CONTINUE + +C...Beam multiple processes. + ELSEIF(MINT(101).EQ.4.AND.MINT(102).EQ.1) THEN + IF(MINT(107).EQ.2) THEN + VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(307)))**2 + ELSE + VINT(317)=16D0*PARP(15)**2*VINT(154)**2/ + & ((4D0*PARP(15)**2+VINT(307))*(4D0*VINT(154)**2+VINT(307))) + ENDIF + IF(MSTP(20).GT.0) THEN + VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(307)))**MSTP(20) + ENDIF + DO 140 I=1,4 + IF(MINT(107).EQ.2) THEN + CONV=(AEM/PARP(160+I))*VINT(317) + ELSEIF(VINT(154).GT.PARP(15)) THEN + CONV=(AEM/PARU(1))*(KCHG(I,1)/3D0)**2*PARP(18)**2* + & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317) + ELSE + CONV=0D0 + ENDIF + I1=MAX(1,I-1) + DO 130 J=0,5 + SIGT(I,0,J)=CONV*SIGTMP(I1,J) + 130 CONTINUE + 140 CONTINUE + DO 150 J=0,5 + SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J) + 150 CONTINUE + +C...Target multiple processes. + ELSEIF(MINT(101).EQ.1.AND.MINT(102).EQ.4) THEN + IF(MINT(108).EQ.2) THEN + VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(308)))**2 + ELSE + VINT(317)=16D0*PARP(15)**2*VINT(154)**2/ + & ((4D0*PARP(15)**2+VINT(308))*(4D0*VINT(154)**2+VINT(308))) + ENDIF + IF(MSTP(20).GT.0) THEN + VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(308)))**MSTP(20) + ENDIF + DO 170 I=1,4 + IF(MINT(108).EQ.2) THEN + CONV=(AEM/PARP(160+I))*VINT(317) + ELSEIF(VINT(154).GT.PARP(15)) THEN + CONV=(AEM/PARU(1))*(KCHG(I,1)/3D0)**2*PARP(18)**2* + & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317) + ELSE + CONV=0D0 + ENDIF + IV=MAX(1,I-1) + DO 160 J=0,5 + SIGT(0,I,J)=CONV*SIGTMP(IV,J) + 160 CONTINUE + 170 CONTINUE + DO 180 J=0,5 + SIGT(0,0,J)=SIGT(0,1,J)+SIGT(0,2,J)+SIGT(0,3,J)+SIGT(0,4,J) + 180 CONTINUE + +C...Both beam and target multiple processes. + ELSE + IF(MINT(107).EQ.2) THEN + VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(307)))**2 + ELSE + VINT(317)=16D0*PARP(15)**2*VINT(154)**2/ + & ((4D0*PARP(15)**2+VINT(307))*(4D0*VINT(154)**2+VINT(307))) + ENDIF + IF(MINT(108).EQ.2) THEN + VINT(317)=VINT(317)*(PMHAD(2)**2/(PMHAD(2)**2+VINT(308)))**2 + ELSE + VINT(317)=VINT(317)*16D0*PARP(15)**2*VINT(154)**2/ + & ((4D0*PARP(15)**2+VINT(308))*(4D0*VINT(154)**2+VINT(308))) + ENDIF + IF(MSTP(20).GT.0) THEN + VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(307)+ + & VINT(308)))**MSTP(20) + ENDIF + DO 210 I1=1,4 + DO 200 I2=1,4 + IF(MINT(107).EQ.2) THEN + CONV=(AEM/PARP(160+I1))*VINT(317) + ELSEIF(VINT(154).GT.PARP(15)) THEN + CONV=(AEM/PARU(1))*(KCHG(I1,1)/3D0)**2*PARP(18)**2* + & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317) + ELSE + CONV=0D0 + ENDIF + IF(MINT(108).EQ.2) THEN + CONV=CONV*(AEM/PARP(160+I2)) + ELSEIF(VINT(154).GT.PARP(15)) THEN + CONV=CONV*(AEM/PARU(1))*(KCHG(I2,1)/3D0)**2*PARP(18)**2* + & (1D0/PARP(15)**2-1D0/VINT(154)**2) + ELSE + CONV=0D0 + ENDIF + IF(I1.LE.2) THEN + IV=MAX(1,I2-1) + ELSEIF(I2.LE.2) THEN + IV=MAX(1,I1-1) + ELSEIF(I1.EQ.I2) THEN + IV=2*I1-2 + ELSE + IV=5 + ENDIF + DO 190 J=0,5 + JV=J + IF(I2.GT.I1.AND.(J.EQ.2.OR.J.EQ.3)) JV=5-J + SIGT(I1,I2,J)=CONV*SIGTMP(IV,JV) + 190 CONTINUE + 200 CONTINUE + 210 CONTINUE + DO 230 J=0,5 + DO 220 I=1,4 + SIGT(I,0,J)=SIGT(I,1,J)+SIGT(I,2,J)+SIGT(I,3,J)+SIGT(I,4,J) + SIGT(0,I,J)=SIGT(1,I,J)+SIGT(2,I,J)+SIGT(3,I,J)+SIGT(4,I,J) + 220 CONTINUE + SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J) + 230 CONTINUE + ENDIF + +C...Scale up uniformly for Donnachie-Landshoff parametrization. + IF(IPROC.EQ.21.OR.IPROC.EQ.23.OR.IPROC.EQ.25) THEN + RFAC=(XPAR(IPROC)*SEPS+YPAR(IPROC)*SETA)/SIGT(0,0,0) + DO 260 I1=0,N1 + DO 250 I2=0,N2 + DO 240 J=0,5 + SIGT(I1,I2,J)=RFAC*SIGT(I1,I2,J) + 240 CONTINUE + 250 CONTINUE + 260 CONTINUE + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYMAXI +C...Finds optimal set of coefficients for kinematical variable selection +C...and the maximum of the part of the differential cross-section used +C...in the event weighting. + + SUBROUTINE PYMAXI + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) + +C...User process initialization commonblock. + INTEGER MAXPUP + PARAMETER (MAXPUP=100) + INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP + DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP + COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2), + &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP), + &LPRUP(MAXPUP) + SAVE /HEPRUP/ + +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) + COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000) + COMMON/PYINT4/MWID(500),WIDS(500,5) + COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) + COMMON/PYINT6/PROC(0:500) + CHARACTER PROC*28 + COMMON/PYINT7/SIGT(0:6,0:6,0:5) + COMMON/PYTCSM/ITCM(0:99),RTCM(0:99) + COMMON/PYTCCO/COEFX(194:380,2) + COMMON/TCPARA/IRES,JRES,XMAS(3),XWID(3),YMAS(2),YWID(2) + SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/, + &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT6/,/PYINT7/,/PYTCCO/, + &/PYTCSM/,/TCPARA/ +C...Local arrays, character variables and data. + LOGICAL IOK + CHARACTER CVAR(4)*4 + DIMENSION NPTS(4),MVARPT(500,4),VINTPT(500,30),SIGSPT(500), + &NAREL(9),WTREL(9),WTMAT(9,9),WTRELN(9),COEFU(9),COEFO(9), + &IACCMX(4),SIGSMX(4),SIGSSM(3),PMMN(2),WTRSAV(9),TEMPC(9), + &IQ(9),IP(9) + DATA CVAR/'tau ','tau''','y* ','cth '/ + DATA SIGSSM/3*0D0/ + +C...Initial values and loop over subprocesses. + NPOSI=0 + VINT(143)=1D0 + VINT(144)=1D0 + XSEC(0,1)=0D0 + ITECH=0 + DO 460 ISUB=1,500 + MINT(1)=ISUB + MINT(51)=0 + +C...Find maximum weight factors for photon flux. + IF(MSUB(ISUB).EQ.1.OR.(ISUB.GE.91.AND.ISUB.LE.100)) THEN + IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(2,WTGAGA) + ENDIF + +C...Select subprocess to study: skip cases not applicable. + IF(ISET(ISUB).EQ.11) THEN + IF(MSUB(ISUB).NE.1) GOTO 460 +C...User process intialization: cross section model dependent. + IF(IABS(IDWTUP).EQ.1) THEN + IF(IDWTUP.GT.0.AND.XMAXUP(KFPR(ISUB,1)).LT.0D0) CALL + & PYERRM(26,'(PYMAXI:) Negative XMAXUP for user process') + XSEC(ISUB,1)=1.00000001D-9*ABS(XMAXUP(KFPR(ISUB,1))) + ELSE + IF((IDWTUP.EQ.2.OR.IDWTUP.EQ.3).AND. + & XSECUP(KFPR(ISUB,1)).LT.0D0) CALL + & PYERRM(26,'(PYMAXI:) Negative XSECUP for user process') + IF(IDWTUP.EQ.2.AND.XMAXUP(KFPR(ISUB,1)).LT.0D0) CALL + & PYERRM(26,'(PYMAXI:) Negative XMAXUP for user process') + XSEC(ISUB,1)=1.00000001D-9*ABS(XSECUP(KFPR(ISUB,1))) + ENDIF + IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)= + & WTGAGA*XSEC(ISUB,1) + NPOSI=NPOSI+1 + GOTO 450 + ELSEIF(ISUB.GE.91.AND.ISUB.LE.95) THEN + CALL PYSIGH(NCHN,SIGS) + XSEC(ISUB,1)=SIGS + IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)= + & WTGAGA*XSEC(ISUB,1) + IF(MSUB(ISUB).NE.1) GOTO 460 + NPOSI=NPOSI+1 + GOTO 450 + ELSEIF(ISUB.EQ.99.AND.MSUB(ISUB).EQ.1) THEN + CALL PYSIGH(NCHN,SIGS) + XSEC(ISUB,1)=SIGS + IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)= + & WTGAGA*XSEC(ISUB,1) + IF(XSEC(ISUB,1).EQ.0D0) THEN + MSUB(ISUB)=0 + ELSE + NPOSI=NPOSI+1 + ENDIF + GOTO 450 + ELSEIF(ISUB.EQ.96) THEN + IF(MINT(50).EQ.0) GOTO 460 + IF(MSUB(95).NE.1.AND.MOD(MSTP(81),10).LE.0.AND.MSTP(131).LE.0) + & GOTO 460 + IF(MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 460 + ELSEIF(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13.OR.ISUB.EQ.28.OR. + & ISUB.EQ.53.OR.ISUB.EQ.68) THEN + IF(MSUB(ISUB).NE.1.OR.MSUB(95).EQ.1) GOTO 460 + ELSEIF(ISUB.GE.381.AND.ISUB.LE.386) THEN + IF(MSUB(ISUB).NE.1.OR.MSUB(95).EQ.1) GOTO 460 + ELSE + IF(MSUB(ISUB).NE.1) GOTO 460 + ENDIF + ISTSB=ISET(ISUB) + IF(ISUB.EQ.96) ISTSB=2 + IF(MSTP(122).GE.2) WRITE(MSTU(11),5000) ISUB + MWTXS=0 + IF(MSTP(142).GE.1.AND.ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+ + & MSUB(94)+MSUB(95).EQ.0) MWTXS=1 + +C...Find resonances (explicit or implicit in cross-section). + MINT(72)=0 + KFR1=0 + IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN + KFR1=KFPR(ISUB,1) + ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165 + & .OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN + KFR1=23 + ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172 + & .OR.ISUB.EQ.177) THEN + KFR1=24 + ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN + KFR1=25 + IF(MSTP(46).EQ.5) THEN + KFR1=89 + PMAS(89,1)=PARP(45) + PMAS(89,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2) + ENDIF + ELSEIF(ISUB.EQ.481) THEN + KFR1=9900001 + ENDIF + CKMX=CKIN(2) + IF(CKMX.LE.0D0) CKMX=VINT(1) + KCR1=PYCOMP(KFR1) + IF(KCR1.EQ.0) KFR1=0 + IF(KFR1.NE.0) THEN + IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR. + & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0 + ENDIF + IF(KFR1.NE.0) THEN + TAUR1=PMAS(KCR1,1)**2/VINT(2) + GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2) + MINT(72)=1 + MINT(73)=KFR1 + VINT(73)=TAUR1 + VINT(74)=GAMR1 + ENDIF + KFR2=0 + KFR3=0 + IF(ISUB.EQ.141.OR.ISUB.EQ.194.OR.ISUB.EQ.195.OR. + $ (ISUB.GE.361.AND.ISUB.LE.380)) + $ THEN + KFR2=23 + IF(ISUB.EQ.141) THEN + KCR2=PYCOMP(KFR2) + IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR. + & CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) THEN + KFR2=0 + ELSE + TAUR2=PMAS(KCR2,1)**2/VINT(2) + GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2) + MINT(72)=2 + MINT(74)=KFR2 + VINT(75)=TAUR2 + VINT(76)=GAMR2 + ENDIF + ELSEIF(ITECH.EQ.0) THEN + ALPRHT=2.16D0*(3D0/DBLE(ITCM(1))) + ITECH=1 + KFR1=KTECHN+113 + KCR1=PYCOMP(KFR1) + KFR2=KTECHN+223 + KCR2=PYCOMP(KFR2) + KFR3=KTECHN+115 + KCR3=PYCOMP(KFR3) + IRES=0 +C...Order the resonances + IF(PMAS(KCR3,1).LT.PMAS(KCR2,1)) THEN + KCT=KCR3 + KCR3=KCR2 + KCR2=KCT + ENDIF + IF(PMAS(KCR3,1).LT.PMAS(KCR1,1)) THEN + KCT=KCR3 + KCR3=KCR1 + KCR1=KCT + ENDIF + IF(PMAS(KCR2,1).LT.PMAS(KCR1,1)) THEN + KCT=KCR2 + KCR2=KCR1 + KCR1=KCT + ENDIF + DO 101 I=1,3 + IF(I.EQ.1) THEN + SHN0=PMAS(KCR1,1)**2 + ELSEIF(I.EQ.2) THEN + IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LE.1D-6) GOTO 101 + SHN0=PMAS(KCR2,1)**2 + ELSEIF(I.EQ.3) THEN + IF(ABS(PMAS(KCR3,1)-PMAS(KCR3,1)).LE.1D-6) GOTO 101 + SHN0=PMAS(KCR3,1)**2 + ENDIF + AEM=PYALEM(SHN0) + FAR=SQRT(AEM/ALPRHT) + SHN=SHN0*(1D0-FAR) + CALL PYTECM(SHN,S1,WIDO,1) + RES=SHN-S1 + SHN=S1*.99D0 + SHSTEP=2D0 + 102 SHN=SHN+SHSTEP + CALL PYTECM(SHN,S1,WIDO,1) + IF(RES.LT.0D0.AND.SHN-S1.GE.0D0) THEN + IOK=.FALSE. + IF(IRES.GT.0) THEN + IF(ABS(SQRT(S1)-XMAS(IRES)).GT.1D-6) IOK=.TRUE. + ELSEIF(IRES.EQ.0) THEN + IOK=.TRUE. + ENDIF + IF(IOK) THEN + IRES=IRES+1 + XMAS(IRES)=SQRT(S1) + XWID(IRES)=WIDO + ENDIF + ENDIF + RES=SHN-S1 + IF(IRES.LT.3.AND.SHN.LT.SHN0*(1D0+FAR)) GOTO 102 + 101 CONTINUE + JRES=0 + KFR1=KTECHN+213 + KCR1=PYCOMP(KFR1) + KFR2=KTECHN+215 + KCR2=PYCOMP(KFR2) + IF(PMAS(KCR2,1).LT.PMAS(KCR1,1)) THEN + KCT=KCR2 + KCR2=KCR1 + KCR1=KCT + ENDIF + DO 103 I=1,2 + IF(I.EQ.1) THEN + SHN0=PMAS(KCR1,1)**2 + ELSEIF(I.EQ.2) THEN + IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LE.1D-6) GOTO 103 + SHN0=PMAS(KCR2,1)**2 + ENDIF + AEM=PYALEM(SHN0) + FAR=SQRT(AEM/ALPRHT) + SHN=SHN0*(1D0-FAR) + CALL PYTECM(SHN,S1,WIDO,2) + RES=SHN-S1 + SHN=S1*.99D0 + SHSTEP=2D0 + 104 SHN=SHN+SHSTEP + CALL PYTECM(SHN,S1,WIDO,2) + IF(RES.LT.0D0.AND.SHN-S1.GE.0D0) THEN + IOK=.FALSE. + IF(JRES.GT.0) THEN + IF(ABS(SQRT(S1)-XMAS(IRES)).GT.1D-6) IOK=.TRUE. + ELSEIF(JRES.EQ.0) THEN + IOK=.TRUE. + ENDIF + IF(IOK) THEN + JRES=JRES+1 + YMAS(JRES)=SQRT(S1) + YWID(JRES)=WIDO + ENDIF + ENDIF + RES=SHN-S1 + IF(JRES.LT.2.AND.SHN.LT.SHN0*(1D0+FAR)) GOTO 104 + 103 CONTINUE + ENDIF + IF(ISUB.EQ.194.OR.(ISUB.GE.361.AND.ISUB.LE.368).OR. + & ISUB.EQ.379.OR.ISUB.EQ.380) THEN + MINT(72)=IRES + IF(IRES.GE.1) THEN + VINT(73)=XMAS(1)**2/VINT(2) + VINT(74)=XMAS(1)*XWID(1)/VINT(2) + TAUR1=VINT(73) + GAMR1=VINT(74) + XM1=XMAS(1) + XG1=XWID(1) + KFR1=1 + ENDIF + IF(IRES.GE.2) THEN + VINT(75)=XMAS(2)**2/VINT(2) + VINT(76)=XMAS(2)*XWID(2)/VINT(2) + TAUR2=VINT(75) + GAMR2=VINT(76) + XM2=XMAS(2) + XG2=XWID(2) + KFR2=2 + ENDIF + IF(IRES.EQ.3) THEN + VINT(77)=XMAS(3)**2/VINT(2) + VINT(78)=XMAS(3)*XWID(3)/VINT(2) + TAUR3=VINT(77) + GAMR3=VINT(78) + XM3=XMAS(3) + XG3=XWID(3) + KFR3=3 + ENDIF +C...Charged current: rho+- and a+- + ELSEIF(ISUB.EQ.195.OR.ISUB.GE.370.AND.ISUB.LE.378) THEN + MINT(72)=IRES + IF(JRES.GE.1) THEN + VINT(73)=YMAS(1)**2/VINT(2) + VINT(74)=YMAS(1)*YWID(1)/VINT(2) + KFR1=1 + TAUR1=VINT(73) + GAMR1=VINT(74) + XM1=YMAS(1) + XG1=YWID(1) + ENDIF + IF(JRES.GE.2) THEN + VINT(75)=YMAS(2)**2/VINT(2) + VINT(76)=YMAS(2)*YWID(2)/VINT(2) + KFR2=2 + TAUR2=VINT(73) + GAMR2=VINT(74) + XM2=YMAS(2) + XG2=YWID(2) + ENDIF + KFR3=0 + ENDIF + IF(ISUB.NE.141) THEN + IF(KFR1.NE.0.AND.(CKIN(1).GT.(XM1+20D0*XG1) + & .OR.CKMX.LT.(XM1-20D0*XG1))) KFR1=0 + IF(KFR2.NE.0.AND.(CKIN(1).GT.(XM2+20D0*XG2) + & .OR.CKMX.LT.(XM2-20D0*XG2))) KFR2=0 + IF(KFR3.NE.0.AND.(CKIN(1).GT.(XM3+20D0*XG3) + & .OR.CKMX.LT.(XM3-20D0*XG3))) KFR3=0 + IF(KFR3.NE.0.AND.KFR2.NE.0.AND.KFR1.NE.0) THEN + + ELSEIF(KFR1.NE.0.AND.KFR2.NE.0) THEN + MINT(72)=2 + ELSEIF(KFR1.NE.0.AND.KFR3.NE.0) THEN + MINT(72)=2 + MINT(74)=KFR3 + VINT(75)=TAUR3 + VINT(76)=GAMR3 + ELSEIF(KFR2.NE.0.AND.KFR3.NE.0) THEN + MINT(72)=2 + MINT(73)=KFR2 + VINT(73)=TAUR2 + VINT(74)=GAMR2 + MINT(74)=KFR3 + VINT(75)=TAUR3 + VINT(76)=GAMR3 + ELSEIF(KFR1.NE.0) THEN + MINT(72)=1 + ELSEIF(KFR2.NE.0) THEN + MINT(72)=1 + MINT(73)=KFR2 + VINT(73)=TAUR2 + VINT(74)=GAMR2 + ELSEIF(KFR3.NE.0) THEN + MINT(72)=1 + MINT(73)=KFR3 + VINT(73)=TAUR3 + VINT(74)=GAMR3 + ELSE + MINT(72)=0 + ENDIF + ELSE + IF(KFR2.NE.0.AND.KFR1.NE.0) THEN + + ELSEIF(KFR2.NE.0) THEN + KFR1=KFR2 + TAUR1=TAUR2 + GAMR1=GAMR2 + MINT(72)=1 + MINT(73)=KFR1 + VINT(73)=TAUR1 + VINT(74)=GAMR1 + KFR2=0 + ELSE + MINT(72)=0 + ENDIF + ENDIF + ENDIF + +C...Find product masses and minimum pT of process. + SQM3=0D0 + SQM4=0D0 + MINT(71)=0 + VINT(71)=CKIN(3) + VINT(80)=1D0 + IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN + NBW=0 + DO 110 I=1,2 + PMMN(I)=0D0 + IF(KFPR(ISUB,I).EQ.0) THEN + ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT. + & PARP(41)) THEN + IF(I.EQ.1) SQM3=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2 + IF(I.EQ.2) SQM4=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2 + ELSE + NBW=NBW+1 +C...This prevents SUSY/t particles from becoming too light. + KFLW=KFPR(ISUB,I) + IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN + KCW=PYCOMP(KFLW) + PMMN(I)=PMAS(KCW,1) + DO 100 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1 + IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN + PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+ + & PMAS(PYCOMP(KFDP(IDC,2)),1) + IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+ + & PMAS(PYCOMP(KFDP(IDC,3)),1) + PMMN(I)=MIN(PMMN(I),PMSUM) + ENDIF + 100 CONTINUE + ELSEIF(KFLW.EQ.6) THEN + PMMN(I)=PMAS(24,1)+PMAS(5,1) + ENDIF + ENDIF + 110 CONTINUE + IF(NBW.GE.1) THEN + CKIN41=CKIN(41) + CKIN43=CKIN(43) + CKIN(41)=MAX(PMMN(1),CKIN(41)) + CKIN(43)=MAX(PMMN(2),CKIN(43)) + CALL PYOFSH(3,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4) + CKIN(41)=CKIN41 + CKIN(43)=CKIN43 + IF(MINT(51).EQ.1) THEN + WRITE(MSTU(11),5100) ISUB + MSUB(ISUB)=0 + GOTO 460 + ENDIF + SQM3=PQM3**2 + SQM4=PQM4**2 + ENDIF + IF(MIN(SQM3,SQM4).LT.CKIN(6)**2) MINT(71)=1 + IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5)) + IF(ISUB.EQ.96.AND.MSTP(82).LE.1) THEN + VINT(71)=PARP(81)*(VINT(1)/PARP(89))**PARP(90) + ELSEIF(ISUB.EQ.96) THEN + VINT(71)=0.08D0*PARP(82)*(VINT(1)/PARP(89))**PARP(90) + ENDIF + ENDIF + VINT(63)=SQM3 + VINT(64)=SQM4 + +C...Prepare for additional variable choices in 2 -> 3. + IF(ISTSB.EQ.5) THEN + VINT(201)=0D0 + IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1) + VINT(206)=VINT(201) + IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(206)=PMAS(5,1) + VINT(204)=PMAS(23,1) + IF(ISUB.EQ.124.OR.ISUB.EQ.351) VINT(204)=PMAS(24,1) + IF(ISUB.EQ.352) VINT(204)=PMAS(PYCOMP(9900024),1) + IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182 + & .OR.ISUB.EQ.186.OR.ISUB.EQ.187.OR.ISUB.EQ.401.OR.ISUB.EQ.402) + & VINT(204)=VINT(201) + VINT(209)=VINT(204) + IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(209)=VINT(206) + ENDIF + +C...Number of points for each variable: tau, tau', y*, cos(theta-hat). + IPEAK7=0 + NPTS(1)=2+2*MINT(72) + IF(MINT(47).EQ.1) THEN + IF(ISTSB.EQ.1.OR.ISTSB.EQ.2) NPTS(1)=1 + ELSEIF(MINT(47).GE.5) THEN + IF(ISTSB.LE.2.OR.ISTSB.GT.5) THEN + NPTS(1)=NPTS(1)+1 + IPEAK7=1 + ENDIF + ENDIF + NPTS(2)=1 + IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN + IF(MINT(47).GE.2) NPTS(2)=2 + IF(MINT(47).GE.5) NPTS(2)=3 + ENDIF + NPTS(3)=1 + IF(MINT(47).EQ.4.OR.MINT(47).EQ.5) THEN + NPTS(3)=3 + IF(MINT(45).EQ.3) NPTS(3)=NPTS(3)+1 + IF(MINT(46).EQ.3) NPTS(3)=NPTS(3)+1 + ENDIF + NPTS(4)=1 + IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) NPTS(4)=5 + NTRY=NPTS(1)*NPTS(2)*NPTS(3)*NPTS(4) + +C...Reset coefficients of cross-section weighting. + DO 120 J=1,20 + COEF(ISUB,J)=0D0 + 120 CONTINUE + IF(ISUB.EQ.194.OR.ISUB.EQ.195.OR.(ISUB.GE.361 + & .AND.ISUB.LE.380)) THEN + DO 125 J=1,2 + COEFX(ISUB,J)=0D0 + 125 CONTINUE + ENDIF + COEF(ISUB,1)=1D0 + COEF(ISUB,8)=0.5D0 + COEF(ISUB,9)=0.5D0 + COEF(ISUB,13)=1D0 + COEF(ISUB,18)=1D0 + MCTH=0 + MTAUP=0 + METAUP=0 + VINT(23)=0D0 + VINT(26)=0D0 + SIGSAM=0D0 + +C...Find limits and select tau, y*, cos(theta-hat) and tau' values, +C...in grid of phase space points. + CALL PYKLIM(1) + METAU=MINT(51) + NACC=0 + DO 150 ITRY=1,NTRY + MINT(51)=0 + IF(METAU.EQ.1) GOTO 150 + IF(MOD(ITRY-1,NPTS(2)*NPTS(3)*NPTS(4)).EQ.0) THEN + MTAU=1+(ITRY-1)/(NPTS(2)*NPTS(3)*NPTS(4)) + IF(MINT(72).LE.2.AND.MTAU.GT.2+2*MINT(72)) THEN + MTAU=7 + ELSEIF(MINT(72).EQ.3.AND.IPEAK7.EQ.0.AND.MTAU.GE.7) THEN + MTAU=MTAU+1 + ENDIF + RTAU=0.5D0 +C...Special case when both resonances have same mass, +C...as is often the case in process 194. +c IF(MINT(72).GE.2) THEN +c IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LT. +c & 0.01D0*(PMAS(KCR2,1)+PMAS(KCR1,1))) THEN +c IF(MTAU.EQ.3.OR.MTAU.EQ.4) THEN +c RTAU=0.4D0 +c ELSEIF(MTAU.EQ.5.OR.MTAU.EQ.6) THEN +c RTAU=0.6D0 +c ENDIF +c ENDIF +c ENDIF + CALL PYKMAP(1,MTAU,RTAU) + IF(ISTSB.GE.3.AND.ISTSB.LE.5) CALL PYKLIM(4) + METAUP=MINT(51) + ENDIF + IF(METAUP.EQ.1) GOTO 150 + IF(ISTSB.GE.3.AND.ISTSB.LE.5.AND.MOD(ITRY-1,NPTS(3)*NPTS(4)) + & .EQ.0) THEN + MTAUP=1+MOD((ITRY-1)/(NPTS(3)*NPTS(4)),NPTS(2)) + CALL PYKMAP(4,MTAUP,0.5D0) + ENDIF + IF(MOD(ITRY-1,NPTS(3)*NPTS(4)).EQ.0) THEN + CALL PYKLIM(2) + MEYST=MINT(51) + ENDIF + IF(MEYST.EQ.1) GOTO 150 + IF(MOD(ITRY-1,NPTS(4)).EQ.0) THEN + MYST=1+MOD((ITRY-1)/NPTS(4),NPTS(3)) + IF(MYST.EQ.4.AND.MINT(45).NE.3) MYST=5 + CALL PYKMAP(2,MYST,0.5D0) + CALL PYKLIM(3) + MECTH=MINT(51) + ENDIF + IF(MECTH.EQ.1) GOTO 150 + IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN + MCTH=1+MOD(ITRY-1,NPTS(4)) + CALL PYKMAP(3,MCTH,0.5D0) + ENDIF + IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1D0-VINT(23)**2) + +C...Store position and limits. + MINT(51)=0 + CALL PYKLIM(0) + IF(MINT(51).EQ.1) GOTO 150 + NACC=NACC+1 + MVARPT(NACC,1)=MTAU + MVARPT(NACC,2)=MTAUP + MVARPT(NACC,3)=MYST + MVARPT(NACC,4)=MCTH + DO 130 J=1,30 + VINTPT(NACC,J)=VINT(10+J) + 130 CONTINUE + +C...Normal case: calculate cross-section. + IF(ISTSB.NE.5) THEN + CALL PYSIGH(NCHN,SIGS) + IF(MWTXS.EQ.1) THEN + CALL PYEVWT(WTXS) + SIGS=WTXS*SIGS + ENDIF + +C..2 -> 3: find highest value out of a number of tries. + ELSE + SIGS=0D0 + DO 140 IKIN3=1,MSTP(129) + CALL PYKMAP(5,0,0D0) + IF(MINT(51).EQ.1) GOTO 140 + CALL PYSIGH(NCHN,SIGTMP) + IF(MWTXS.EQ.1) THEN + CALL PYEVWT(WTXS) + SIGTMP=WTXS*SIGTMP + ENDIF + IF(SIGTMP.GT.SIGS) SIGS=SIGTMP + 140 CONTINUE + ENDIF + +C...Store cross-section. + SIGSPT(NACC)=SIGS + IF(SIGS.GT.SIGSAM) SIGSAM=SIGS + IF(MSTP(122).GE.2) WRITE(MSTU(11),5200) MTAU,MYST,MCTH,MTAUP, + & VINT(21),VINT(22),VINT(23),VINT(26),SIGS + 150 CONTINUE + IF(NACC.EQ.0) THEN + WRITE(MSTU(11),5100) ISUB + MSUB(ISUB)=0 + GOTO 460 + ELSEIF(SIGSAM.EQ.0D0) THEN + WRITE(MSTU(11),5300) ISUB + MSUB(ISUB)=0 + GOTO 460 + ENDIF + IF(ISUB.NE.96) NPOSI=NPOSI+1 + +C...Calculate integrals in tau over maximal phase space limits. + TAUMIN=VINT(11) + TAUMAX=VINT(31) + ATAU1=LOG(TAUMAX/TAUMIN) + IF(NPTS(1).GE.2) THEN + ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN) + ENDIF + IF(NPTS(1).GE.4) THEN + ATAU3=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))/TAUR1 + ATAU4=(ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1))/ + & GAMR1 + ENDIF + IF(NPTS(1).GE.6) THEN + ATAU5=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))/TAUR2 + ATAU6=(ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2))/ + & GAMR2 + ENDIF + IF(NPTS(1).GE.8) THEN + ATAU8=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR3)/(TAUMAX+TAUR3))/TAUR3 + ATAU9=(ATAN((TAUMAX-TAUR3)/GAMR3)-ATAN((TAUMIN-TAUR3)/GAMR3))/ + & GAMR3 + ENDIF + IF(IPEAK7.EQ.1) THEN + ATAU7=LOG(MAX(2D-10,1D0-TAUMIN)/MAX(2D-10,1D0-TAUMAX)) + ENDIF + +C...Reset. Sum up cross-sections in points calculated. + DO 320 IVAR=1,4 + IF(NPTS(IVAR).EQ.1) GOTO 320 + IF(ISUB.EQ.96.AND.IVAR.EQ.4) GOTO 320 + NBIN=NPTS(IVAR) + DO 170 J1=1,NBIN + NAREL(J1)=0 + WTREL(J1)=0D0 + COEFU(J1)=0D0 + DO 160 J2=1,NBIN + WTMAT(J1,J2)=0D0 + 160 CONTINUE + 170 CONTINUE + DO 180 IACC=1,NACC + IBIN=MVARPT(IACC,IVAR) + IF(IVAR.EQ.1) THEN + IF(IBIN.GT.7.AND.IPEAK7.EQ.0) THEN + IBIN=IBIN-1 + ELSEIF(IBIN.EQ.7.AND.IPEAK7.EQ.1.AND.MSTP(72).LT.3) THEN + IBIN=3+2*MINT(72) + ENDIF + ENDIF + IF(IVAR.EQ.3.AND.IBIN.EQ.5.AND.MINT(45).NE.3) IBIN=4 + NAREL(IBIN)=NAREL(IBIN)+1 + WTREL(IBIN)=WTREL(IBIN)+SIGSPT(IACC) + +C...Sum up tau cross-section pieces in points used. + IF(IVAR.EQ.1) THEN + TAU=VINTPT(IACC,11) + WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0 + WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAU1/ATAU2)/TAU + IF(NBIN.GE.4) THEN + WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAU1/ATAU3)/(TAU+TAUR1) + WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ATAU1/ATAU4)*TAU/ + & ((TAU-TAUR1)**2+GAMR1**2) + ENDIF + IF(NBIN.GE.6) THEN + WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ATAU1/ATAU5)/(TAU+TAUR2) + WTMAT(IBIN,6)=WTMAT(IBIN,6)+(ATAU1/ATAU6)*TAU/ + & ((TAU-TAUR2)**2+GAMR2**2) + ENDIF + IF(MINT(72).LE.2.AND.IPEAK7.EQ.1) THEN + WTMAT(IBIN,3+2*MINT(72))=WTMAT(IBIN,3+2*MINT(72)) + & +(ATAU1/ATAU7)*TAU/MAX(2D-10,1D0-TAU) + ELSEIF(MINT(72).EQ.3.AND.IPEAK7.EQ.1) THEN + WTMAT(IBIN,7)=WTMAT(IBIN,7) + & +(ATAU1/ATAU7)*TAU/MAX(2D-10,1D0-TAU) + ENDIF + IF(MINT(72).EQ.3) THEN + WTMAT(IBIN,7+IPEAK7)=WTMAT(IBIN,7+IPEAK7) + & +(ATAU1/ATAU8)/(TAU+TAUR3) + WTMAT(IBIN,8+IPEAK7)=WTMAT(IBIN,8+IPEAK7) + & +(ATAU1/ATAU9)*TAU/((TAU-TAUR3)**2+GAMR3**2) + ENDIF +C...Sum up tau' cross-section pieces in points used. + ELSEIF(IVAR.EQ.2) THEN + TAU=VINTPT(IACC,11) + TAUP=VINTPT(IACC,16) + TAUPMN=VINTPT(IACC,6) + TAUPMX=VINTPT(IACC,26) + ATAUP1=LOG(TAUPMX/TAUPMN) + ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU) + WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0 + WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAUP1/ATAUP2)* + & (1D0-TAU/TAUP)**3/TAUP + IF(NBIN.GE.3) THEN + ATAUP3=LOG(MAX(2D-10,1D0-TAUPMN)/MAX(2D-10,1D0-TAUPMX)) + WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAUP1/ATAUP3)* + & TAUP/MAX(2D-10,1D0-TAUP) + ENDIF + +C...Sum up y* cross-section pieces in points used. + ELSEIF(IVAR.EQ.3) THEN + YST=VINTPT(IACC,12) + YSTMIN=VINTPT(IACC,2) + YSTMAX=VINTPT(IACC,22) + AYST0=YSTMAX-YSTMIN + AYST1=0.5D0*(YSTMAX-YSTMIN)**2 + AYST2=AYST1 + AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN))) + WTMAT(IBIN,1)=WTMAT(IBIN,1)+(AYST0/AYST1)*(YST-YSTMIN) + WTMAT(IBIN,2)=WTMAT(IBIN,2)+(AYST0/AYST2)*(YSTMAX-YST) + WTMAT(IBIN,3)=WTMAT(IBIN,3)+(AYST0/AYST3)/COSH(YST) + IF(MINT(45).EQ.3) THEN + TAUE=VINTPT(IACC,11) + IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16) + YST0=-0.5D0*LOG(TAUE) + AYST4=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0)/ + & MAX(1D-10,EXP(YST0-YSTMAX)-1D0)) + WTMAT(IBIN,4)=WTMAT(IBIN,4)+(AYST0/AYST4)/ + & MAX(1D-10,1D0-EXP(YST-YST0)) + ENDIF + IF(MINT(46).EQ.3) THEN + TAUE=VINTPT(IACC,11) + IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16) + YST0=-0.5D0*LOG(TAUE) + AYST5=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0)/ + & MAX(1D-10,EXP(YST0+YSTMIN)-1D0)) + WTMAT(IBIN,NBIN)=WTMAT(IBIN,NBIN)+(AYST0/AYST5)/ + & MAX(1D-10,1D0-EXP(-YST-YST0)) + ENDIF + +C...Sum up cos(theta-hat) cross-section pieces in points used. + ELSE + RM34=MAX(1D-20,2D0*SQM3*SQM4/(VINTPT(IACC,11)*VINT(2))**2) + RSQM=1D0+RM34 + CTHMAX=SQRT(1D0-4D0*VINT(71)**2/(TAUMAX*VINT(2))) + CTHMIN=-CTHMAX + IF(CTHMAX.GT.0.9999D0) RM34=MAX(RM34,2D0*VINT(71)**2/ + & (TAUMAX*VINT(2))) + ACTH1=CTHMAX-CTHMIN + ACTH2=LOG(MAX(RM34,RSQM-CTHMIN)/MAX(RM34,RSQM-CTHMAX)) + ACTH3=LOG(MAX(RM34,RSQM+CTHMAX)/MAX(RM34,RSQM+CTHMIN)) + ACTH4=1D0/MAX(RM34,RSQM-CTHMAX)-1D0/MAX(RM34,RSQM-CTHMIN) + ACTH5=1D0/MAX(RM34,RSQM+CTHMIN)-1D0/MAX(RM34,RSQM+CTHMAX) + CTH=VINTPT(IACC,13) + WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0 + WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ACTH1/ACTH2)/ + & MAX(RM34,RSQM-CTH) + WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ACTH1/ACTH3)/ + & MAX(RM34,RSQM+CTH) + WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ACTH1/ACTH4)/ + & MAX(RM34,RSQM-CTH)**2 + WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ACTH1/ACTH5)/ + & MAX(RM34,RSQM+CTH)**2 + ENDIF + 180 CONTINUE + +C...Check that equation system solvable. + IF(MSTP(122).GE.2) WRITE(MSTU(11),5400) CVAR(IVAR) + MSOLV=1 + WTRELS=0D0 + DO 190 IBIN=1,NBIN + IF(MSTP(122).GE.2) WRITE(MSTU(11),5500) (WTMAT(IBIN,IRED), + & IRED=1,NBIN),WTREL(IBIN) + IF(NAREL(IBIN).EQ.0) MSOLV=0 + WTRELS=WTRELS+WTREL(IBIN) + 190 CONTINUE + IF(ABS(WTRELS).LT.1D-20) MSOLV=0 + +C...Solve to find relative importance of cross-section pieces. + IF(MSOLV.EQ.1) THEN + DO 200 IBIN=1,NBIN + WTRELN(IBIN)=MAX(0.1D0,WTREL(IBIN)/WTRELS) + WTRSAV(IBIN)=WTREL(IBIN) + 200 CONTINUE +C...Auxiliary vectors to record order of permutations + DO I=1,NBIN + IP(I) = I + IQ(I) = I + ENDDO + DO 230 IRED=1,NBIN-1 + MROW=IRED + RESMAX=ABS(WTREL(MROW)) +C...Find row with largest residual + DO JBIN=IRED+1,NBIN + IF(RESMAX.LT.ABS(WTREL(JBIN))) THEN + MROW=JBIN + RESMAX=ABS(WTREL(MROW)) + ENDIF + ENDDO + IF(RESMAX.LT.1D-20) THEN + MSOLV=0 + GOTO 260 + ENDIF + MCOL = IRED + AMAX = ABS(WTMAT(MROW,MCOL)) +C...Find column with largest entry + DO JBIN=IRED+1,NBIN + IF (AMAX.LT.ABS(WTMAT(MROW,JBIN))) THEN + MCOL = JBIN + AMAX = ABS(WTMAT(MROW,MCOL)) + ENDIF + ENDDO +C...Swap rows if necessary + IF(MROW.NE.IRED) THEN + DO JBIN=1,NBIN + TMPE=WTMAT(IRED,JBIN) + WTMAT(IRED,JBIN)=WTMAT(MROW,JBIN) + WTMAT(MROW,JBIN)=TMPE + ENDDO + TMPE=WTREL(IRED) + WTREL(IRED)=WTREL(MROW) + WTREL(MROW)=TMPE + MTMP=IQ(IRED) + IQ(IRED)=IQ(MROW) + IQ(MROW)=MTMP + ENDIF +C...Swap columns if necessary + IF(MCOL.NE.IRED) THEN + DO JBIN=1,NBIN + TMPE=WTMAT(JBIN,IRED) + WTMAT(JBIN,IRED)=WTMAT(JBIN,MCOL) + WTMAT(JBIN,MCOL)=TMPE + ENDDO + MTMP=IP(IRED) + IP(IRED)=IP(MCOL) + IP(MCOL)=MTMP + ENDIF +C...Begin eliminating equations + DO 220 IBIN=IRED+1,NBIN + IF(ABS(WTMAT(IRED,IRED)).LT.1D-20) THEN + MSOLV=0 + GOTO 260 + ENDIF +C RQT=WTMAT(IBIN,IRED)/WTMAT(IRED,IRED) + RQTU=WTMAT(IBIN,IRED) + RQTL=WTMAT(IRED,IRED) +C...Switch order of operations + WTREL(IBIN)=WTREL(IBIN)-RQTU* + $ (WTREL(IRED)/RQTL) + DO 210 ICOE=IRED,NBIN + WTMAT(IBIN,ICOE)=WTMAT(IBIN,ICOE)- + $ RQTU*(WTMAT(IRED,ICOE)/RQTL) + 210 CONTINUE + 220 CONTINUE + 230 CONTINUE + DO 250 IRED=NBIN,1,-1 + DO 240 ICOE=IRED+1,NBIN + WTREL(IRED)=WTREL(IRED)-WTMAT(IRED,ICOE)*COEFU(ICOE) + 240 CONTINUE + IF(ABS(WTMAT(IRED,IRED)).LT.1D-20) THEN + MSOLV=0 + GOTO 260 + ENDIF + COEFU(IRED)=WTREL(IRED)/WTMAT(IRED,IRED) + TEMPC(IRED)=COEFU(IRED) + 250 CONTINUE +C...Return to original order + DO IBIN=1,NBIN + MTMP=IP(IBIN) + COEFU(MTMP)=TEMPC(IBIN) + ENDDO + ENDIF + +C...Share evenly if failure. + 260 IF(MSOLV.EQ.0) THEN + DO 270 IBIN=1,NBIN + COEFU(IBIN)=1D0 + WTRELN(IBIN)=0.1D0 + IF(WTRELS.GT.0D0) WTRELN(IBIN)=MAX(0.1D0, + & WTRSAV(IBIN)/WTRELS) + 270 CONTINUE + ENDIF + +C...Normalize coefficients, with piece shared democratically. + COEFSU=0D0 + WTRELS=0D0 + DO 280 IBIN=1,NBIN + COEFU(IBIN)=MAX(0D0,COEFU(IBIN)) + COEFSU=COEFSU+COEFU(IBIN) + WTRELS=WTRELS+WTRELN(IBIN) + 280 CONTINUE + IF(COEFSU.GT.0D0) THEN + DO 290 IBIN=1,NBIN + COEFO(IBIN)=PARP(122)/NBIN+(1D0-PARP(122))*0.5D0* + & (COEFU(IBIN)/COEFSU+WTRELN(IBIN)/WTRELS) + 290 CONTINUE + ELSE + DO 300 IBIN=1,NBIN + COEFO(IBIN)=1D0/NBIN + 300 CONTINUE + ENDIF + IF(IVAR.EQ.1) IOFF=0 + IF(IVAR.EQ.2) IOFF=17 + IF(IVAR.EQ.3) IOFF=7 + IF(IVAR.EQ.4) IOFF=12 + DO 310 IBIN=1,NBIN + ICOF=IOFF+IBIN + IF(IVAR.EQ.1) THEN + IF(IBIN.EQ.NBIN.AND.(MINT(72).LE.2.AND.IPEAK7.EQ.1)) THEN + ICOF=7 + ENDIF + ENDIF + IF(IVAR.EQ.3.AND.IBIN.EQ.4.AND.MINT(45).NE.3) ICOF=ICOF+1 + IF(IVAR.EQ.1.AND.IBIN.GE.7+IPEAK7.AND.MINT(72).EQ.3) THEN + COEFX(ISUB,IBIN-6-IPEAK7)=COEFO(IBIN) + ELSE + COEF(ISUB,ICOF)=COEFO(IBIN) + ENDIF + 310 CONTINUE + + IF(MSTP(122).GE.2) WRITE(MSTU(11),5600) CVAR(IVAR), + & (COEFO(IBIN),IBIN=1,NBIN) + + 320 CONTINUE + +C...Find two most promising maxima among points previously determined. + DO 330 J=1,4 + IACCMX(J)=0 + SIGSMX(J)=0D0 + 330 CONTINUE + NMAX=0 + DO 390 IACC=1,NACC + DO 340 J=1,30 + VINT(10+J)=VINTPT(IACC,J) + 340 CONTINUE + IF(ISTSB.NE.5) THEN + CALL PYSIGH(NCHN,SIGS) + IF(MWTXS.EQ.1) THEN + CALL PYEVWT(WTXS) + SIGS=WTXS*SIGS + ENDIF + ELSE + SIGS=0D0 + DO 350 IKIN3=1,MSTP(129) + CALL PYKMAP(5,0,0D0) + IF(MINT(51).EQ.1) GOTO 350 + CALL PYSIGH(NCHN,SIGTMP) + IF(MWTXS.EQ.1) THEN + CALL PYEVWT(WTXS) + SIGTMP=WTXS*SIGTMP + ENDIF + IF(SIGTMP.GT.SIGS) SIGS=SIGTMP + 350 CONTINUE + ENDIF + IEQ=0 + DO 360 IMV=1,NMAX + IF(ABS(SIGS-SIGSMX(IMV)).LT.1D-4*(SIGS+SIGSMX(IMV))) IEQ=IMV + 360 CONTINUE + IF(IEQ.EQ.0) THEN + DO 370 IMV=NMAX,1,-1 + IIN=IMV+1 + IF(SIGS.LE.SIGSMX(IMV)) GOTO 380 + IACCMX(IMV+1)=IACCMX(IMV) + SIGSMX(IMV+1)=SIGSMX(IMV) + 370 CONTINUE + IIN=1 + 380 IACCMX(IIN)=IACC + SIGSMX(IIN)=SIGS + IF(NMAX.LE.1) NMAX=NMAX+1 + ENDIF + 390 CONTINUE + +C...Read out starting position for search. + IF(MSTP(122).GE.2) WRITE(MSTU(11),5700) + SIGSAM=SIGSMX(1) + DO 440 IMAX=1,NMAX + IACC=IACCMX(IMAX) + MTAU=MVARPT(IACC,1) + MTAUP=MVARPT(IACC,2) + MYST=MVARPT(IACC,3) + MCTH=MVARPT(IACC,4) + VTAU=0.5D0 + VYST=0.5D0 + VCTH=0.5D0 + VTAUP=0.5D0 + +C...Starting point and step size in parameter space. + DO 430 IRPT=1,2 + DO 420 IVAR=1,4 + IF(NPTS(IVAR).EQ.1) GOTO 420 + IF(IVAR.EQ.1) VVAR=VTAU + IF(IVAR.EQ.2) VVAR=VTAUP + IF(IVAR.EQ.3) VVAR=VYST + IF(IVAR.EQ.4) VVAR=VCTH + IF(IVAR.EQ.1) MVAR=MTAU + IF(IVAR.EQ.2) MVAR=MTAUP + IF(IVAR.EQ.3) MVAR=MYST + IF(IVAR.EQ.4) MVAR=MCTH + IF(IRPT.EQ.1) VDEL=0.1D0 + IF(IRPT.EQ.2) VDEL=MAX(0.01D0,MIN(0.05D0,VVAR-0.02D0, + & 0.98D0-VVAR)) + IF(IRPT.EQ.1) VMAR=0.02D0 + IF(IRPT.EQ.2) VMAR=0.002D0 + IMOV0=1 + IF(IRPT.EQ.1.AND.IVAR.EQ.1) IMOV0=0 + DO 410 IMOV=IMOV0,8 + +C...Define new point in parameter space. + IF(IMOV.EQ.0) THEN + INEW=2 + VNEW=VVAR + ELSEIF(IMOV.EQ.1) THEN + INEW=3 + VNEW=VVAR+VDEL + ELSEIF(IMOV.EQ.2) THEN + INEW=1 + VNEW=VVAR-VDEL + ELSEIF(SIGSSM(3).GE.MAX(SIGSSM(1),SIGSSM(2)).AND. + & VVAR+2D0*VDEL.LT.1D0-VMAR) THEN + VVAR=VVAR+VDEL + SIGSSM(1)=SIGSSM(2) + SIGSSM(2)=SIGSSM(3) + INEW=3 + VNEW=VVAR+VDEL + ELSEIF(SIGSSM(1).GE.MAX(SIGSSM(2),SIGSSM(3)).AND. + & VVAR-2D0*VDEL.GT.VMAR) THEN + VVAR=VVAR-VDEL + SIGSSM(3)=SIGSSM(2) + SIGSSM(2)=SIGSSM(1) + INEW=1 + VNEW=VVAR-VDEL + ELSEIF(SIGSSM(3).GE.SIGSSM(1)) THEN + VDEL=0.5D0*VDEL + VVAR=VVAR+VDEL + SIGSSM(1)=SIGSSM(2) + INEW=2 + VNEW=VVAR + ELSE + VDEL=0.5D0*VDEL + VVAR=VVAR-VDEL + SIGSSM(3)=SIGSSM(2) + INEW=2 + VNEW=VVAR + ENDIF + +C...Convert to relevant variables and find derived new limits. + ILERR=0 + IF(IVAR.EQ.1) THEN + VTAU=VNEW + CALL PYKMAP(1,MTAU,VTAU) + IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN + CALL PYKLIM(4) + IF(MINT(51).EQ.1) ILERR=1 + ENDIF + ENDIF + IF(IVAR.LE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5.AND. + & ILERR.EQ.0) THEN + IF(IVAR.EQ.2) VTAUP=VNEW + CALL PYKMAP(4,MTAUP,VTAUP) + ENDIF + IF(IVAR.LE.2.AND.ILERR.EQ.0) THEN + CALL PYKLIM(2) + IF(MINT(51).EQ.1) ILERR=1 + ENDIF + IF(IVAR.LE.3.AND.ILERR.EQ.0) THEN + IF(IVAR.EQ.3) VYST=VNEW + CALL PYKMAP(2,MYST,VYST) + CALL PYKLIM(3) + IF(MINT(51).EQ.1) ILERR=1 + ENDIF + IF((ISTSB.EQ.2.OR.ISTSB.EQ.4.OR.ISTSB.EQ.6).AND. + & ILERR.EQ.0) THEN + IF(IVAR.EQ.4) VCTH=VNEW + CALL PYKMAP(3,MCTH,VCTH) + ENDIF + IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1.-VINT(23)**2) + +C...Evaluate cross-section. Save new maximum. Final maximum. + IF(ILERR.NE.0) THEN + SIGS=0. + ELSEIF(ISTSB.NE.5) THEN + CALL PYSIGH(NCHN,SIGS) + IF(MWTXS.EQ.1) THEN + CALL PYEVWT(WTXS) + SIGS=WTXS*SIGS + ENDIF + ELSE + SIGS=0D0 + DO 400 IKIN3=1,MSTP(129) + CALL PYKMAP(5,0,0D0) + IF(MINT(51).EQ.1) GOTO 400 + CALL PYSIGH(NCHN,SIGTMP) + IF(MWTXS.EQ.1) THEN + CALL PYEVWT(WTXS) + SIGTMP=WTXS*SIGTMP + ENDIF + IF(SIGTMP.GT.SIGS) SIGS=SIGTMP + 400 CONTINUE + ENDIF + SIGSSM(INEW)=SIGS + IF(SIGS.GT.SIGSAM) SIGSAM=SIGS + IF(MSTP(122).GE.2) WRITE(MSTU(11),5800) IMAX,IVAR,MVAR, + & IMOV,VNEW,VINT(21),VINT(22),VINT(23),VINT(26),SIGS + 410 CONTINUE + 420 CONTINUE + 430 CONTINUE + 440 CONTINUE + IF(MSTP(121).EQ.1) SIGSAM=PARP(121)*SIGSAM + XSEC(ISUB,1)=1.05D0*SIGSAM +C...Add extra headroom for UED + IF(ISUB.GT.310.AND.ISUB.LT.320) XSEC(ISUB,1)=XSEC(ISUB,1)*1.1D0 + IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)= + & WTGAGA*XSEC(ISUB,1) + 450 CONTINUE + IF(MSTP(173).EQ.1.AND.ISUB.NE.96) XSEC(ISUB,1)= + & PARP(174)*XSEC(ISUB,1) + IF(ISUB.NE.96) XSEC(0,1)=XSEC(0,1)+XSEC(ISUB,1) + 460 CONTINUE + MINT(51)=0 + +C...Print summary table. + IF(MINT(121).EQ.1.AND.NPOSI.EQ.0) THEN + IF(MSTP(127).NE.1) THEN + WRITE(MSTU(11),5900) + CALL PYSTOP(1) + ELSE + WRITE(MSTU(11),6400) + MSTI(53)=1 + ENDIF + ENDIF + IF(MSTP(122).GE.1) THEN + WRITE(MSTU(11),6000) + WRITE(MSTU(11),6100) + DO 470 ISUB=1,500 + IF(MSUB(ISUB).NE.1.AND.ISUB.NE.96) GOTO 470 + IF(ISUB.EQ.96.AND.MINT(50).EQ.0) GOTO 470 + IF(ISUB.EQ.96.AND.MSUB(95).NE.1.AND.MOD(MSTP(81),10).LE.0) + & GOTO 470 + IF(ISUB.EQ.96.AND.MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 470 + IF(MSUB(95).EQ.1.AND.(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13 + & .OR.ISUB.EQ.28.OR.ISUB.EQ.53.OR.ISUB.EQ.68)) GOTO 470 + IF(MSUB(95).EQ.1.AND.ISUB.GE.381.AND.ISUB.LE.386) GOTO 470 + WRITE(MSTU(11),6200) ISUB,PROC(ISUB),XSEC(ISUB,1) + 470 CONTINUE + WRITE(MSTU(11),6300) + ENDIF + +C...Format statements for maximization results. + 5000 FORMAT(/1X,'Coefficient optimization and maximum search for ', + &'subprocess no',I4/1X,'Coefficient modes tau',10X,'y*',9X, + &'cth',9X,'tau''',7X,'sigma') + 5100 FORMAT(1X,'Warning: requested subprocess ',I3,' has no allowed ', + &'phase space.'/1X,'Process switched off!') + 5200 FORMAT(1X,4I4,F12.8,F12.6,F12.7,F12.8,1P,D12.4) + 5300 FORMAT(1X,'Warning: requested subprocess ',I3,' has vanishing ', + &'cross-section.'/1X,'Process switched off!') + 5400 FORMAT(1X,'Coefficients of equation system to be solved for ',A4) + 5500 FORMAT(1X,1P,10D11.3) + 5600 FORMAT(1X,'Result for ',A4,':',9F9.4) + 5700 FORMAT(1X,'Maximum search for given coefficients'/2X,'MAX VAR ', + &'MOD MOV VNEW',7X,'tau',7X,'y*',8X,'cth',7X,'tau''',7X,'sigma') + 5800 FORMAT(1X,4I4,F8.4,F11.7,F9.3,F11.6,F11.7,1P,D12.4) + 5900 FORMAT(1X,'Error: no requested process has non-vanishing ', + &'cross-section.'/1X,'Execution stopped!') + 6000 FORMAT(/1X,8('*'),1X,'PYMAXI: summary of differential ', + &'cross-section maximum search',1X,8('*')) + 6100 FORMAT(/11X,58('=')/11X,'I',38X,'I',17X,'I'/11X,'I ISUB ', + &'Subprocess name',15X,'I Maximum value I'/11X,'I',38X,'I', + &17X,'I'/11X,58('=')/11X,'I',38X,'I',17X,'I') + 6200 FORMAT(11X,'I',2X,I3,3X,A28,2X,'I',2X,1P,D12.4,3X,'I') + 6300 FORMAT(11X,'I',38X,'I',17X,'I'/11X,58('=')) + 6400 FORMAT(1X,'Error: no requested process has non-vanishing ', + &'cross-section.'/ + &1X,'Execution will stop if you try to generate events.') + + RETURN + END + +C********************************************************************* + +C...PYPILE +C...Initializes multiplicity distribution and selects mutliplicity +C...of pileup events, i.e. several events occuring at the same +C...beam crossing. + + SUBROUTINE PYPILE(MPILE) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT7/SIGT(0:6,0:6,0:5) + SAVE /PYDAT1/,/PYPARS/,/PYINT1/,/PYINT7/ +C...Local arrays and saved variables. + DIMENSION WTI(0:200) + SAVE IMIN,IMAX,WTI,WTS + +C...Sum of allowed cross-sections for pileup events. + IF(MPILE.EQ.1) THEN + VINT(131)=SIGT(0,0,5) + IF(MSTP(132).GE.2) VINT(131)=VINT(131)+SIGT(0,0,4) + IF(MSTP(132).GE.3) VINT(131)=VINT(131)+SIGT(0,0,2)+SIGT(0,0,3) + IF(MSTP(132).GE.4) VINT(131)=VINT(131)+SIGT(0,0,1) + IF(MSTP(133).LE.0) RETURN + +C...Initialize multiplicity distribution at maximum. + XNAVE=VINT(131)*PARP(131) + IF(XNAVE.GT.120D0) WRITE(MSTU(11),5000) XNAVE + INAVE=MAX(1,MIN(200,NINT(XNAVE))) + WTI(INAVE)=1D0 + WTS=WTI(INAVE) + WTN=WTI(INAVE)*INAVE + +C...Find shape of multiplicity distribution below maximum. + IMIN=INAVE + DO 100 I=INAVE-1,1,-1 + IF(MSTP(133).EQ.1) WTI(I)=WTI(I+1)*(I+1)/XNAVE + IF(MSTP(133).GE.2) WTI(I)=WTI(I+1)*I/XNAVE + IF(WTI(I).LT.1D-6) GOTO 110 + WTS=WTS+WTI(I) + WTN=WTN+WTI(I)*I + IMIN=I + 100 CONTINUE + +C...Find shape of multiplicity distribution above maximum. + 110 IMAX=INAVE + DO 120 I=INAVE+1,200 + IF(MSTP(133).EQ.1) WTI(I)=WTI(I-1)*XNAVE/I + IF(MSTP(133).GE.2) WTI(I)=WTI(I-1)*XNAVE/(I-1) + IF(WTI(I).LT.1D-6) GOTO 130 + WTS=WTS+WTI(I) + WTN=WTN+WTI(I)*I + IMAX=I + 120 CONTINUE + 130 VINT(132)=XNAVE + VINT(133)=WTN/WTS + IF(MSTP(133).EQ.1.AND.IMIN.EQ.1) VINT(134)= + & WTS/(WTS+WTI(1)/XNAVE) + IF(MSTP(133).EQ.1.AND.IMIN.GT.1) VINT(134)=1D0 + IF(MSTP(133).GE.2) VINT(134)=XNAVE + +C...Pick multiplicity of pileup events. + ELSE + IF(MSTP(133).LE.0) THEN + MINT(81)=MAX(1,MSTP(134)) + ELSE + WTR=WTS*PYR(0) + DO 140 I=IMIN,IMAX + MINT(81)=I + WTR=WTR-WTI(I) + IF(WTR.LE.0D0) GOTO 150 + 140 CONTINUE + 150 CONTINUE + ENDIF + ENDIF + +C...Format statement for error message. + 5000 FORMAT(1X,'Warning: requested average number of events per bunch', + &'crossing too large, ',1P,D12.4) + + RETURN + END + +C********************************************************************* + +C...PYSAVE +C...Saves and restores parameter and cross section values for the +C...3 gamma-p and 6 (or 4, or 9, or 13) gamma-gamma alternatives. +C...Also makes random choice between alternatives. + + SUBROUTINE PYSAVE(ISAVE,IGA) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) + COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) + COMMON/PYINT7/SIGT(0:6,0:6,0:5) + SAVE /PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT5/,/PYINT7/ +C...Local arrays and saved variables. + DIMENSION NCP(15),NSUBCP(15,20),MSUBCP(15,20),COEFCP(15,20,20), + &NGENCP(15,0:20,3),XSECCP(15,0:20,3),SIGTCP(15,0:6,0:6,0:5), + &INTCP(15,20),RECP(15,20) + SAVE NCP,NSUBCP,MSUBCP,COEFCP,NGENCP,XSECCP,SIGTCP,INTCP,RECP + +C...Save list of subprocesses and cross-section information. + IF(ISAVE.EQ.1) THEN + ICP=0 + DO 120 I=1,500 + IF(MSUB(I).EQ.0.AND.I.NE.96.AND.I.NE.97) GOTO 120 + ICP=ICP+1 + NSUBCP(IGA,ICP)=I + MSUBCP(IGA,ICP)=MSUB(I) + DO 100 J=1,20 + COEFCP(IGA,ICP,J)=COEF(I,J) + 100 CONTINUE + DO 110 J=1,3 + NGENCP(IGA,ICP,J)=NGEN(I,J) + XSECCP(IGA,ICP,J)=XSEC(I,J) + 110 CONTINUE + 120 CONTINUE + NCP(IGA)=ICP + DO 130 J=1,3 + NGENCP(IGA,0,J)=NGEN(0,J) + XSECCP(IGA,0,J)=XSEC(0,J) + 130 CONTINUE + DO 160 I1=0,6 + DO 150 I2=0,6 + DO 140 J=0,5 + SIGTCP(IGA,I1,I2,J)=SIGT(I1,I2,J) + 140 CONTINUE + 150 CONTINUE + 160 CONTINUE + +C...Save various common process variables. + DO 170 J=1,10 + INTCP(IGA,J)=MINT(40+J) + 170 CONTINUE + INTCP(IGA,11)=MINT(101) + INTCP(IGA,12)=MINT(102) + INTCP(IGA,13)=MINT(107) + INTCP(IGA,14)=MINT(108) + INTCP(IGA,15)=MINT(123) + RECP(IGA,1)=CKIN(3) + RECP(IGA,2)=VINT(318) + +C...Save cross-section information only. + ELSEIF(ISAVE.EQ.2) THEN + DO 190 ICP=1,NCP(IGA) + I=NSUBCP(IGA,ICP) + DO 180 J=1,3 + NGENCP(IGA,ICP,J)=NGEN(I,J) + XSECCP(IGA,ICP,J)=XSEC(I,J) + 180 CONTINUE + 190 CONTINUE + DO 200 J=1,3 + NGENCP(IGA,0,J)=NGEN(0,J) + XSECCP(IGA,0,J)=XSEC(0,J) + 200 CONTINUE + +C...Choose between allowed alternatives. + ELSEIF(ISAVE.EQ.3.OR.ISAVE.EQ.4) THEN + IF(ISAVE.EQ.4) THEN + XSUMCP=0D0 + DO 210 IG=1,MINT(121) + XSUMCP=XSUMCP+XSECCP(IG,0,1) + 210 CONTINUE + XSUMCP=XSUMCP*PYR(0) + DO 220 IG=1,MINT(121) + IGA=IG + XSUMCP=XSUMCP-XSECCP(IG,0,1) + IF(XSUMCP.LE.0D0) GOTO 230 + 220 CONTINUE + 230 CONTINUE + ENDIF + +C...Restore cross-section information. + DO 240 I=1,500 + MSUB(I)=0 + 240 CONTINUE + DO 270 ICP=1,NCP(IGA) + I=NSUBCP(IGA,ICP) + MSUB(I)=MSUBCP(IGA,ICP) + DO 250 J=1,20 + COEF(I,J)=COEFCP(IGA,ICP,J) + 250 CONTINUE + DO 260 J=1,3 + NGEN(I,J)=NGENCP(IGA,ICP,J) + XSEC(I,J)=XSECCP(IGA,ICP,J) + 260 CONTINUE + 270 CONTINUE + DO 280 J=1,3 + NGEN(0,J)=NGENCP(IGA,0,J) + XSEC(0,J)=XSECCP(IGA,0,J) + 280 CONTINUE + DO 310 I1=0,6 + DO 300 I2=0,6 + DO 290 J=0,5 + SIGT(I1,I2,J)=SIGTCP(IGA,I1,I2,J) + 290 CONTINUE + 300 CONTINUE + 310 CONTINUE + +C...Restore various common process variables. + DO 320 J=1,10 + MINT(40+J)=INTCP(IGA,J) + 320 CONTINUE + MINT(101)=INTCP(IGA,11) + MINT(102)=INTCP(IGA,12) + MINT(107)=INTCP(IGA,13) + MINT(108)=INTCP(IGA,14) + MINT(123)=INTCP(IGA,15) + CKIN(3)=RECP(IGA,1) + CKIN(1)=2D0*CKIN(3) + VINT(318)=RECP(IGA,2) + +C...Sum up cross-section info (for PYSTAT). + ELSEIF(ISAVE.EQ.5) THEN + DO 330 I=1,500 + MSUB(I)=0 + NGEN(I,1)=0 + NGEN(I,3)=0 + XSEC(I,3)=0D0 + 330 CONTINUE + NGEN(0,1)=0 + NGEN(0,2)=0 + NGEN(0,3)=0 + XSEC(0,3)=0 + DO 350 IG=1,MINT(121) + DO 340 ICP=1,NCP(IG) + I=NSUBCP(IG,ICP) + IF(MSUBCP(IG,ICP).EQ.1) MSUB(I)=1 + NGEN(I,1)=NGEN(I,1)+NGENCP(IG,ICP,1) + NGEN(I,3)=NGEN(I,3)+NGENCP(IG,ICP,3) + XSEC(I,3)=XSEC(I,3)+XSECCP(IG,ICP,3) + 340 CONTINUE + NGEN(0,1)=NGEN(0,1)+NGENCP(IG,0,1) + NGEN(0,2)=NGEN(0,2)+NGENCP(IG,0,2) + NGEN(0,3)=NGEN(0,3)+NGENCP(IG,0,3) + XSEC(0,3)=XSEC(0,3)+XSECCP(IG,0,3) + 350 CONTINUE + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYGAGA +C...For lepton beams it gives photon-hadron or photon-photon systems +C...to be treated with the ordinary machinery and combines this with a +C...description of the lepton -> lepton + photon branching. + + SUBROUTINE PYGAGA(IGAGA,WTGAGA) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/, + &/PYINT5/ +C...Local variables and data statement. + DIMENSION PMS(2),XMIN(2),XMAX(2),Q2MIN(2),Q2MAX(2),PMC(3), + &X(2),Q2(2),Y(2),THETA(2),PHI(2),PT(2),BETA(3) + SAVE PMS,XMIN,XMAX,Q2MIN,Q2MAX,PMC,X,Q2,THETA,PHI,PT,W2MIN + DATA EPS/1D-4/ + +C...Initialize generation of photons inside leptons. + IF(IGAGA.EQ.1) THEN + +C...Save quantities on incoming lepton system. + VINT(301)=VINT(1) + VINT(302)=VINT(2) + PMS(1)=VINT(303)**2 + IF(MINT(141).EQ.0) PMS(1)=SIGN(VINT(3)**2,VINT(3)) + PMS(2)=VINT(304)**2 + IF(MINT(142).EQ.0) PMS(2)=SIGN(VINT(4)**2,VINT(4)) + PMC(3)=VINT(302)-PMS(1)-PMS(2) + W2MIN=MAX(CKIN(77),2D0*CKIN(3),2D0*CKIN(5))**2 + +C...Calculate range of x and Q2 values allowed in generation. + DO 100 I=1,2 + PMC(I)=VINT(302)+PMS(I)-PMS(3-I) + IF(MINT(140+I).NE.0) THEN + XMIN(I)=MAX(CKIN(59+2*I),EPS) + XMAX(I)=MIN(CKIN(60+2*I),1D0-2D0*VINT(301)*SQRT(PMS(I))/ + & PMC(I),1D0-EPS) + YMIN=MAX(CKIN(71+2*I),EPS) + YMAX=MIN(CKIN(72+2*I),1D0-EPS) + IF(CKIN(64+2*I).GT.0D0) XMIN(I)=MAX(XMIN(I), + & (YMIN*PMC(3)-CKIN(64+2*I))/PMC(I)) + XMAX(I)=MIN(XMAX(I),(YMAX*PMC(3)-CKIN(63+2*I))/PMC(I)) + THEMIN=MAX(CKIN(67+2*I),0D0) + THEMAX=MIN(CKIN(68+2*I),PARU(1)) + IF(CKIN(68+2*I).LT.0D0) THEMAX=PARU(1) + Q2MIN(I)=MAX(CKIN(63+2*I),XMIN(I)**2*PMS(I)/(1D0-XMIN(I))+ + & ((1D0-XMAX(I))*(VINT(302)-2D0*PMS(3-I))- + & 2D0*PMS(I)/(1D0-XMAX(I)))*SIN(THEMIN/2D0)**2,0D0) + Q2MAX(I)=XMAX(I)**2*PMS(I)/(1D0-XMAX(I))+ + & ((1D0-XMIN(I))*(VINT(302)-2D0*PMS(3-I))- + & 2D0*PMS(I)/(1D0-XMIN(I)))*SIN(THEMAX/2D0)**2 + IF(CKIN(64+2*I).GT.0D0) Q2MAX(I)=MIN(CKIN(64+2*I),Q2MAX(I)) +C...W limits when lepton on one side only. + IF(MINT(143-I).EQ.0) THEN + XMIN(I)=MAX(XMIN(I),(W2MIN-PMS(3-I))/PMC(I)) + IF(CKIN(78).GT.0D0) XMAX(I)=MIN(XMAX(I), + & (CKIN(78)**2-PMS(3-I))/PMC(I)) + ENDIF + ENDIF + 100 CONTINUE + +C...W limits when lepton on both sides. + IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN + IF(CKIN(78).GT.0D0) XMAX(1)=MIN(XMAX(1), + & (CKIN(78)**2+PMC(3)-PMC(2)*XMIN(2))/PMC(1)) + IF(CKIN(78).GT.0D0) XMAX(2)=MIN(XMAX(2), + & (CKIN(78)**2+PMC(3)-PMC(1)*XMIN(1))/PMC(2)) + IF(IABS(MINT(141)).NE.IABS(MINT(142))) THEN + XMIN(1)=MAX(XMIN(1),(PMS(1)-PMS(2)+VINT(302)*(W2MIN- + & PMS(1)-PMS(2))/(PMC(2)*XMAX(2)+PMS(1)-PMS(2)))/PMC(1)) + XMIN(2)=MAX(XMIN(2),(PMS(2)-PMS(1)+VINT(302)*(W2MIN- + & PMS(1)-PMS(2))/(PMC(1)*XMAX(1)+PMS(2)-PMS(1)))/PMC(2)) + ELSE + XMIN(1)=MAX(XMIN(1),W2MIN/(VINT(302)*XMAX(2))) + XMIN(2)=MAX(XMIN(2),W2MIN/(VINT(302)*XMAX(1))) + ENDIF + ENDIF + +C...Q2 and W values and photon flux weight factors for initialization. + ELSEIF(IGAGA.EQ.2) THEN + ISUB=MINT(1) + MINT(15)=0 + MINT(16)=0 + +C...W value for photon on one or both sides, and for processes +C...with gamma-gamma cross section peaked at small shat. + IF(MINT(141).NE.0.AND.MINT(142).EQ.0) THEN + VINT(2)=VINT(302)+PMS(1)-PMC(1)*(1D0-XMAX(1)) + ELSEIF(MINT(141).EQ.0.AND.MINT(142).NE.0) THEN + VINT(2)=VINT(302)+PMS(2)-PMC(2)*(1D0-XMAX(2)) + ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN + VINT(2)=MAX(CKIN(77)**2,12D0*MAX(CKIN(3),CKIN(5))**2) + IF(CKIN(78).GT.0D0) VINT(2)=MIN(VINT(2),CKIN(78)**2) + ELSE + VINT(2)=XMAX(1)*XMAX(2)*VINT(302) + IF(CKIN(78).GT.0D0) VINT(2)=MIN(VINT(2),CKIN(78)**2) + ENDIF + VINT(1)=SQRT(MAX(0D0,VINT(2))) + +C...Upper estimate of photon flux weight factor. +C...Initialization Q2 scale. Flag incoming unresolved photon. + WTGAGA=1D0 + DO 110 I=1,2 + IF(MINT(140+I).NE.0) THEN + WTGAGA=WTGAGA*2D0*(PARU(101)/PARU(2))* + & LOG(XMAX(I)/XMIN(I))*LOG(Q2MAX(I)/Q2MIN(I)) + IF(ISUB.EQ.99.AND.MINT(106+I).EQ.4.AND.MINT(109-I).EQ.3) + & THEN + Q2INIT=5D0+Q2MIN(3-I) + ELSEIF(ISUB.EQ.99.AND.MINT(106+I).EQ.4) THEN + Q2INIT=PMAS(PYCOMP(113),1)**2+Q2MIN(3-I) + ELSEIF(ISUB.EQ.132.OR.ISUB.EQ.134.OR.ISUB.EQ.136) THEN + Q2INIT=MAX(CKIN(1),2D0*CKIN(3),2D0*CKIN(5))**2/3D0 + ELSEIF((ISUB.EQ.138.AND.I.EQ.2).OR. + & (ISUB.EQ.139.AND.I.EQ.1)) THEN + Q2INIT=VINT(2)/3D0 + ELSEIF(ISUB.EQ.140) THEN + Q2INIT=VINT(2)/2D0 + ELSE + Q2INIT=Q2MIN(I) + ENDIF + VINT(2+I)=-SQRT(MAX(Q2MIN(I),MIN(Q2MAX(I),Q2INIT))) + IF(MSTP(14).EQ.0.OR.(ISUB.GE.131.AND.ISUB.LE.140)) + & MINT(14+I)=22 + VINT(306+I)=VINT(2+I)**2 + ENDIF + 110 CONTINUE + VINT(320)=WTGAGA + +C...Update pTmin and cross section information. + IF(MSTP(82).LE.1) THEN + PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90) + ELSE + PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90) + ENDIF + VINT(149)=4D0*PTMN**2/VINT(2) + VINT(154)=PTMN + CALL PYXTOT + VINT(318)=VINT(317) + +C...Generate photons inside leptons and +C...calculate photon flux weight factors. + ELSEIF(IGAGA.EQ.3) THEN + ISUB=MINT(1) + MINT(15)=0 + MINT(16)=0 + +C...Generate phase space point and check against cuts. + LOOP=0 + 120 LOOP=LOOP+1 + DO 130 I=1,2 + IF(MINT(140+I).NE.0) THEN +C...Pick x and Q2 + X(I)=XMIN(I)*(XMAX(I)/XMIN(I))**PYR(0) + Q2(I)=Q2MIN(I)*(Q2MAX(I)/Q2MIN(I))**PYR(0) +C...Cuts on internal consistency in x and Q2. + IF(Q2(I).LT.X(I)**2*PMS(I)/(1D0-X(I))) GOTO 120 + IF(Q2(I).GT.(1D0-X(I))*(VINT(302)-2D0*PMS(3-I))- + & (2D0-X(I)**2)*PMS(I)/(1D0-X(I))) GOTO 120 +C...Cuts on y and theta. + Y(I)=(PMC(I)*X(I)+Q2(I))/PMC(3) + IF(Y(I).LT.CKIN(71+2*I).OR.Y(I).GT.CKIN(72+2*I)) GOTO 120 + RAT=((1D0-X(I))*Q2(I)-X(I)**2*PMS(I))/ + & ((1D0-X(I))**2*(VINT(302)-2D0*PMS(3-I)-2D0*PMS(I))) + THETA(I)=2D0*ASIN(SQRT(MAX(0D0,MIN(1D0,RAT)))) + IF(THETA(I).LT.CKIN(67+2*I)) GOTO 120 + IF(CKIN(68+2*I).GT.0D0.AND.THETA(I).GT.CKIN(68+2*I)) + & GOTO 120 + +C...Phi angle isotropic. Reconstruct pT. + PHI(I)=PARU(2)*PYR(0) + PT(I)=SQRT(((1D0-X(I))*PMC(I))**2/(4D0*VINT(302))- + & PMS(I))*SIN(THETA(I)) + +C...Store info on variables selected, for documentation purposes. + VINT(2+I)=-SQRT(Q2(I)) + VINT(304+I)=X(I) + VINT(306+I)=Q2(I) + VINT(308+I)=Y(I) + VINT(310+I)=THETA(I) + VINT(312+I)=PHI(I) + ELSE + VINT(304+I)=1D0 + VINT(306+I)=0D0 + VINT(308+I)=1D0 + VINT(310+I)=0D0 + VINT(312+I)=0D0 + ENDIF + 130 CONTINUE + +C...Cut on W combines info from two sides. + IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN + W2=-Q2(1)-Q2(2)+0.5D0*X(1)*PMC(1)*X(2)*PMC(2)/VINT(302)- + & 2D0*PT(1)*PT(2)*COS(PHI(1)-PHI(2))+2D0* + & SQRT((0.5D0*X(1)*PMC(1)/VINT(301))**2+Q2(1)-PT(1)**2)* + & SQRT((0.5D0*X(2)*PMC(2)/VINT(301))**2+Q2(2)-PT(2)**2) + IF(W2.LT.W2MIN) GOTO 120 + IF(CKIN(78).GT.0D0.AND.W2.GT.CKIN(78)**2) GOTO 120 + PMS1=-Q2(1) + PMS2=-Q2(2) + ELSEIF(MINT(141).NE.0) THEN + W2=(VINT(302)+PMS(1))*X(1)+PMS(2)*(1D0-X(1)) + PMS1=-Q2(1) + PMS2=PMS(2) + ELSEIF(MINT(142).NE.0) THEN + W2=(VINT(302)+PMS(2))*X(2)+PMS(1)*(1D0-X(2)) + PMS1=PMS(1) + PMS2=-Q2(2) + ENDIF + +C...Store kinematics info for photon(s) in subsystem cm frame. + VINT(2)=W2 + VINT(1)=SQRT(W2) + VINT(291)=0D0 + VINT(292)=0D0 + VINT(293)=0.5D0*SQRT((W2-PMS1-PMS2)**2-4D0*PMS1*PMS2)/VINT(1) + VINT(294)=0.5D0*(W2+PMS1-PMS2)/VINT(1) + VINT(295)=SIGN(SQRT(ABS(PMS1)),PMS1) + VINT(296)=0D0 + VINT(297)=0D0 + VINT(298)=-VINT(293) + VINT(299)=0.5D0*(W2+PMS2-PMS1)/VINT(1) + VINT(300)=SIGN(SQRT(ABS(PMS2)),PMS2) + +C...Assign weight for photon flux; different for transverse and +C...longitudinal photons. Flag incoming unresolved photon. + WTGAGA=1D0 + DO 140 I=1,2 + IF(MINT(140+I).NE.0) THEN + WTGAGA=WTGAGA*2D0*(PARU(101)/PARU(2))* + & LOG(XMAX(I)/XMIN(I))*LOG(Q2MAX(I)/Q2MIN(I)) + IF(MSTP(16).EQ.0) THEN + XY=X(I) + ELSE + WTGAGA=WTGAGA*X(I)/Y(I) + XY=Y(I) + ENDIF + IF(ISUB.EQ.132.OR.ISUB.EQ.134.OR.ISUB.EQ.136) THEN + WTGAGA=WTGAGA*(1D0-XY) + ELSEIF(I.EQ.1.AND.(ISUB.EQ.139.OR.ISUB.EQ.140)) THEN + WTGAGA=WTGAGA*(1D0-XY) + ELSEIF(I.EQ.2.AND.(ISUB.EQ.138.OR.ISUB.EQ.140)) THEN + WTGAGA=WTGAGA*(1D0-XY) + ELSE + WTGAGA=WTGAGA*(0.5D0*(1D0+(1D0-XY)**2)- + & PMS(I)*XY**2/Q2(I)) + ENDIF + IF(MINT(106+I).EQ.0) MINT(14+I)=22 + ENDIF + 140 CONTINUE + VINT(319)=WTGAGA + MINT(143)=LOOP + +C...Update pTmin and cross section information. + IF(MSTP(82).LE.1) THEN + PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90) + ELSE + PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90) + ENDIF + VINT(149)=4D0*PTMN**2/VINT(2) + VINT(154)=PTMN + CALL PYXTOT + +C...Reconstruct kinematics of photons inside leptons. + ELSEIF(IGAGA.EQ.4) THEN + +C...Make place for incoming particles and scattered leptons. + MOVE=3 + IF(MINT(141).NE.0.AND.MINT(142).NE.0) MOVE=4 + MINT(4)=MINT(4)+MOVE + DO 160 I=MINT(84)-MOVE,MINT(83)+1,-1 + IF(K(I,1).EQ.21) THEN + DO 150 J=1,5 + K(I+MOVE,J)=K(I,J) + P(I+MOVE,J)=P(I,J) + V(I+MOVE,J)=V(I,J) + 150 CONTINUE + IF(K(I,3).GT.MINT(83).AND.K(I,3).LE.MINT(84)) + & K(I+MOVE,3)=K(I,3)+MOVE + IF(K(I,4).GT.MINT(83).AND.K(I,4).LE.MINT(84)) + & K(I+MOVE,4)=K(I,4)+MOVE + IF(K(I,5).GT.MINT(83).AND.K(I,5).LE.MINT(84)) + & K(I+MOVE,5)=K(I,5)+MOVE + ENDIF + 160 CONTINUE + DO 170 I=MINT(84)+1,N + IF(K(I,3).GT.MINT(83).AND.K(I,3).LE.MINT(84)) + & K(I,3)=K(I,3)+MOVE + 170 CONTINUE + +C...Fill in incoming particles. + DO 190 I=MINT(83)+1,MINT(83)+MOVE + DO 180 J=1,5 + K(I,J)=0 + P(I,J)=0D0 + V(I,J)=0D0 + 180 CONTINUE + 190 CONTINUE + DO 200 I=1,2 + K(MINT(83)+I,1)=21 + IF(MINT(140+I).NE.0) THEN + K(MINT(83)+I,2)=MINT(140+I) + P(MINT(83)+I,5)=VINT(302+I) + ELSE + K(MINT(83)+I,2)=MINT(10+I) + P(MINT(83)+I,5)=VINT(2+I) + ENDIF + P(MINT(83)+I,3)=0.5D0*SQRT((PMC(3)**2-4D0*PMS(1)*PMS(2))/ + & VINT(302))*(-1D0)**(I+1) + P(MINT(83)+I,4)=0.5D0*PMC(I)/VINT(301) + 200 CONTINUE + +C...New mother-daughter relations in documentation section. + IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN + K(MINT(83)+1,4)=MINT(83)+3 + K(MINT(83)+1,5)=MINT(83)+5 + K(MINT(83)+2,4)=MINT(83)+4 + K(MINT(83)+2,5)=MINT(83)+6 + K(MINT(83)+3,3)=MINT(83)+1 + K(MINT(83)+5,3)=MINT(83)+1 + K(MINT(83)+4,3)=MINT(83)+2 + K(MINT(83)+6,3)=MINT(83)+2 + ELSEIF(MINT(141).NE.0) THEN + K(MINT(83)+1,4)=MINT(83)+3 + K(MINT(83)+1,5)=MINT(83)+4 + K(MINT(83)+2,4)=MINT(83)+5 + K(MINT(83)+3,3)=MINT(83)+1 + K(MINT(83)+4,3)=MINT(83)+1 + K(MINT(83)+5,3)=MINT(83)+2 + ELSEIF(MINT(142).NE.0) THEN + K(MINT(83)+1,4)=MINT(83)+4 + K(MINT(83)+2,4)=MINT(83)+3 + K(MINT(83)+2,5)=MINT(83)+5 + K(MINT(83)+3,3)=MINT(83)+2 + K(MINT(83)+4,3)=MINT(83)+1 + K(MINT(83)+5,3)=MINT(83)+2 + ENDIF + +C...Fill scattered lepton(s). + DO 210 I=1,2 + IF(MINT(140+I).NE.0) THEN + LSC=MINT(83)+MIN(I+2,MOVE) + K(LSC,1)=21 + K(LSC,2)=MINT(140+I) + P(LSC,1)=PT(I)*COS(PHI(I)) + P(LSC,2)=PT(I)*SIN(PHI(I)) + P(LSC,4)=(1D0-X(I))*P(MINT(83)+I,4) + P(LSC,3)=SQRT(P(LSC,4)**2-PMS(I))*COS(THETA(I))* + & (-1D0)**(I-1) + P(LSC,5)=VINT(302+I) + ENDIF + 210 CONTINUE + +C...Find incoming four-vectors to subprocess. + K(N+1,1)=21 + IF(MINT(141).NE.0) THEN + DO 220 J=1,4 + P(N+1,J)=P(MINT(83)+1,J)-P(MINT(83)+3,J) + 220 CONTINUE + ELSE + DO 230 J=1,4 + P(N+1,J)=P(MINT(83)+1,J) + 230 CONTINUE + ENDIF + K(N+2,1)=21 + IF(MINT(142).NE.0) THEN + DO 240 J=1,4 + P(N+2,J)=P(MINT(83)+2,J)-P(MINT(83)+MOVE,J) + 240 CONTINUE + ELSE + DO 250 J=1,4 + P(N+2,J)=P(MINT(83)+2,J) + 250 CONTINUE + ENDIF + +C...Define boost and rotation between hadronic subsystem and +C...collision rest frame; boost hadronic subsystem to this frame. + DO 260 J=1,3 + BETA(J)=(P(N+1,J)+P(N+2,J))/(P(N+1,4)+P(N+2,4)) + 260 CONTINUE + CALL PYROBO(N+1,N+2,0D0,0D0,-BETA(1),-BETA(2),-BETA(3)) + BPHI=PYANGL(P(N+1,1),P(N+1,2)) + CALL PYROBO(N+1,N+2,0D0,-BPHI,0D0,0D0,0D0) + BTHETA=PYANGL(P(N+1,3),P(N+1,1)) + CALL PYROBO(MINT(83)+MOVE+1,N,BTHETA,BPHI,BETA(1),BETA(2), + & BETA(3)) + +C...Add on scattered leptons to final state. + DO 280 I=1,2 + IF(MINT(140+I).NE.0) THEN + LSC=MINT(83)+MIN(I+2,MOVE) + N=N+1 + DO 270 J=1,5 + K(N,J)=K(LSC,J) + P(N,J)=P(LSC,J) + V(N,J)=V(LSC,J) + 270 CONTINUE + K(N,1)=1 + K(N,3)=LSC + ENDIF + 280 CONTINUE + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYRAND +C...Generates quantities characterizing the high-pT scattering at the +C...parton level according to the matrix elements. Chooses incoming, +C...reacting partons, their momentum fractions and one of the possible +C...subprocesses. + + SUBROUTINE PYRAND + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) + +C...User process initialization and event commonblocks. + INTEGER MAXPUP + PARAMETER (MAXPUP=100) + INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP + DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP + COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2), + &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP), + &LPRUP(MAXPUP) + INTEGER MAXNUP + PARAMETER (MAXNUP=500) + INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP + DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP + COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP), + &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP), + &VTIMUP(MAXNUP),SPINUP(MAXNUP) + SAVE /HEPRUP/,/HEPEUP/ + +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) + COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000) + COMMON/PYINT4/MWID(500),WIDS(500,5) + COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) + COMMON/PYINT7/SIGT(0:6,0:6,0:5) + COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) + COMMON/PYTCCO/COEFX(194:380,2) + COMMON/TCPARA/IRES,JRES,XMAS(3),XWID(3),YMAS(2),YWID(2) + SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/, + &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,/PYMSSM/,/PYTCCO/, + &/TCPARA/ +C...Local arrays. + DIMENSION XPQ(-25:25),PMM(2),PDIF(4),BHAD(4),PMMN(2) + +C...Parameters and data used in elastic/diffractive treatment. + DATA EPS/0.0808D0/, ALP/0.25D0/, CRES/2D0/, PMRC/1.062D0/, + &SMP/0.880D0/, BHAD/2.3D0,1.4D0,1.4D0,0.23D0/ + +C...Initial values, specifically for (first) semihard interaction. + MINT(10)=0 + MINT(17)=0 + MINT(18)=0 + VINT(143)=1D0 + VINT(144)=1D0 + VINT(157)=0D0 + VINT(158)=0D0 + MFAIL=0 + IF(MSTP(171).EQ.1.AND.MSTP(172).EQ.2) MFAIL=1 + ISUB=0 + ISTSB=0 + LOOP=0 + 100 LOOP=LOOP+1 + MINT(51)=0 + MINT(143)=1 + VINT(97)=1D0 + +C...Start by assuming incoming photon is entering subprocess. + IF(MINT(11).EQ.22) THEN + MINT(15)=22 + VINT(307)=VINT(3)**2 + ENDIF + IF(MINT(12).EQ.22) THEN + MINT(16)=22 + VINT(308)=VINT(4)**2 + ENDIF + MINT(103)=MINT(11) + MINT(104)=MINT(12) + +C...Choice of process type - first event of pileup. + INMULT=0 + IF(MINT(82).EQ.1.AND.ISUB.GE.91.AND.ISUB.LE.96) THEN + ELSEIF(MINT(82).EQ.1) THEN + +C...For gamma-p or gamma-gamma first pick between alternatives. + IGA=0 + IF(MINT(121).GT.1) CALL PYSAVE(4,IGA) + MINT(122)=IGA + +C...For real gamma + gamma with different nature, flip at random. + IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND. + & MSTP(14).LE.10.AND.PYR(0).GT.0.5D0) THEN + MINTSV=MINT(41) + MINT(41)=MINT(42) + MINT(42)=MINTSV + MINTSV=MINT(45) + MINT(45)=MINT(46) + MINT(46)=MINTSV + MINTSV=MINT(107) + MINT(107)=MINT(108) + MINT(108)=MINTSV + IF(MINT(47).EQ.2.OR.MINT(47).EQ.3) MINT(47)=5-MINT(47) + ENDIF + +C...Pick process type, possibly by user process machinery. +C...(If the latter, also event will be picked here.) + IF(MINT(111).GE.11.AND.IABS(IDWTUP).EQ.2.AND.LOOP.GE.2) THEN + CALL UPEVNT + CALL PYUPRE + ELSEIF(MINT(111).GE.11.AND.IABS(IDWTUP).GE.3) THEN + CALL UPEVNT + CALL PYUPRE + ISUB=0 + 110 ISUB=ISUB+1 + IF((ISET(ISUB).NE.11.OR.KFPR(ISUB,2).NE.IDPRUP).AND. + & ISUB.LT.500) GOTO 110 + ELSE + RSUB=XSEC(0,1)*PYR(0) + DO 120 I=1,500 + IF(MSUB(I).NE.1.OR.I.EQ.96) GOTO 120 + ISUB=I + RSUB=RSUB-XSEC(I,1) + IF(RSUB.LE.0D0) GOTO 130 + 120 CONTINUE + 130 IF(ISUB.EQ.95) ISUB=96 + IF(ISUB.EQ.96) INMULT=1 + IF(ISET(ISUB).EQ.11) THEN + IDPRUP=KFPR(ISUB,2) + CALL UPEVNT + CALL PYUPRE + ENDIF + ENDIF + +C...Choice of inclusive process type - pileup events. + ELSEIF(MINT(82).GE.2.AND.ISUB.EQ.0) THEN + RSUB=VINT(131)*PYR(0) + ISUB=96 + IF(RSUB.GT.SIGT(0,0,5)) ISUB=94 + IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)) ISUB=93 + IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)) ISUB=92 + IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)+SIGT(0,0,2)) + & ISUB=91 + IF(ISUB.EQ.96) INMULT=1 + ENDIF + +C...Choice of photon energy and flux factor inside lepton. + IF(MINT(141).NE.0.OR.MINT(142).NE.0) THEN + CALL PYGAGA(3,WTGAGA) + IF(ISUB.GE.131.AND.ISUB.LE.140) THEN + CKIN(3)=MAX(VINT(285),VINT(154)) + CKIN(1)=2D0*CKIN(3) + ENDIF +C...When necessary set direct/resolved photon by hand. + ELSEIF(MINT(15).EQ.22.OR.MINT(16).EQ.22) THEN + IF(MINT(15).EQ.22.AND.MINT(41).EQ.2) MINT(15)=0 + IF(MINT(16).EQ.22.AND.MINT(42).EQ.2) MINT(16)=0 + ENDIF + +C...Restrict direct*resolved processes to pTmin >= Q, +C...to avoid doublecounting with DIS. + IF(MSTP(18).EQ.3.AND.ISUB.GE.131.AND.ISUB.LE.136) THEN + IF(MINT(15).EQ.22) THEN + CKIN(3)=MAX(VINT(285),VINT(154),ABS(VINT(3))) + ELSE + CKIN(3)=MAX(VINT(285),VINT(154),ABS(VINT(4))) + ENDIF + CKIN(1)=2D0*CKIN(3) + ENDIF + +C...Set up for multiple interactions (may include impact parameter). + IF(INMULT.EQ.1) THEN + IF(MINT(35).LE.1) CALL PYMULT(2) + IF(MINT(35).GE.2) CALL PYMIGN(2) + ENDIF + +C...Loopback point for minimum bias in photon physics. + LOOP2=0 + 140 LOOP2=LOOP2+1 + IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)+MINT(143) + IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)+MINT(143) + IF(ISUB.EQ.96.AND.LOOP2.EQ.1.AND.MINT(82).EQ.1) + &NGEN(97,1)=NGEN(97,1)+MINT(143) + MINT(1)=ISUB + ISTSB=ISET(ISUB) + +C...Random choice of flavour for some SUSY processes. + IF(ISUB.GE.201.AND.ISUB.LE.301) THEN +C...~e_L ~nu_e or ~mu_L ~nu_mu. + IF(ISUB.EQ.210) THEN + KFPR(ISUB,1)=KSUSY1+11+2*INT(0.5D0+PYR(0)) + KFPR(ISUB,2)=KFPR(ISUB,1)+1 +C...~nu_e ~nu_e(bar) or ~nu_mu ~nu_mu(bar). + ELSEIF(ISUB.EQ.213) THEN + KFPR(ISUB,1)=KSUSY1+12+2*INT(0.5D0+PYR(0)) + KFPR(ISUB,2)=KFPR(ISUB,1) +C...~q ~chi/~g; ~q = ~d, ~u, ~s, ~c or ~b. + ELSEIF(ISUB.GE.246.AND.ISUB.LE.259.AND.ISUB.NE.255.AND. + & ISUB.NE.257) THEN + IF(ISUB.GE.258) THEN + RKF=4D0 + ELSE + RKF=5D0 + ENDIF + IF(MOD(ISUB,2).EQ.0) THEN + KFPR(ISUB,1)=KSUSY1+1+INT(RKF*PYR(0)) + ELSE + KFPR(ISUB,1)=KSUSY2+1+INT(RKF*PYR(0)) + ENDIF +C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c. + ELSEIF(ISUB.GE.271.AND.ISUB.LE.276) THEN + IF(ISUB.EQ.271.OR.ISUB.EQ.274) THEN + KSU1=KSUSY1 + KSU2=KSUSY1 + ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.275) THEN + KSU1=KSUSY2 + KSU2=KSUSY2 + ELSEIF(PYR(0).LT.0.5D0) THEN + KSU1=KSUSY1 + KSU2=KSUSY2 + ELSE + KSU1=KSUSY2 + KSU2=KSUSY1 + ENDIF + KFPR(ISUB,1)=KSU1+1+INT(4D0*PYR(0)) + KFPR(ISUB,2)=KSU2+1+INT(4D0*PYR(0)) +C...~q ~q(bar); ~q = ~d, ~u, ~s, or ~c. + ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.279) THEN + KFPR(ISUB,1)=KSUSY1+1+INT(4D0*PYR(0)) + KFPR(ISUB,2)=KFPR(ISUB,1) + ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.280) THEN + KFPR(ISUB,1)=KSUSY2+1+INT(4D0*PYR(0)) + KFPR(ISUB,2)=KFPR(ISUB,1) +C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c. + ELSEIF(ISUB.GE.281.AND.ISUB.LE.286) THEN + IF(ISUB.EQ.281.OR.ISUB.EQ.284) THEN + KSU1=KSUSY1 + KSU2=KSUSY1 + ELSEIF(ISUB.EQ.282.OR.ISUB.EQ.285) THEN + KSU1=KSUSY2 + KSU2=KSUSY2 + ELSEIF(PYR(0).LT.0.5D0) THEN + KSU1=KSUSY1 + KSU2=KSUSY2 + ELSE + KSU1=KSUSY2 + KSU2=KSUSY1 + ENDIF + IF(ISUB.EQ.281.OR.ISUB.LE.283) THEN + RKF=5D0 + ELSE + RKF=4D0 + ENDIF + KFPR(ISUB,2)=KSU2+1+INT(RKF*PYR(0)) + ENDIF + ENDIF + +C...Random choice of flavours for some UED processes +c...The production processes can generate a doublet pair, +c...a singlet pair, or a doublet + singlet. + IF(ISUB.EQ.313)THEN +C...q + q -> q*_Di + q*_Dj, q*_Si + q*_Sj + IF(PYR(0).LE.0.1)THEN + KFPR(ISUB,1)=5100001 + ELSE + KFPR(ISUB,1)=5100002 + ENDIF + KFPR(ISUB,2)=KFPR(ISUB,1) + ELSEIF(ISUB.EQ.314.OR.ISUB.EQ.315)THEN +C...g + g -> q*_D + q*_Dbar, q*_S + q*_Sbar +C...q + qbar -> q*_D + q*_Dbar, q*_S + q*_Sbar + IF(PYR(0).LE.0.1)THEN + KFPR(ISUB,1)=5100001 + ELSE + KFPR(ISUB,1)=5100002 + ENDIF + KFPR(ISUB,2)=-KFPR(ISUB,1) + ELSEIF(ISUB.EQ.316)THEN +C...qi + qbarj -> q*_Di + q*_Sbarj + IF(PYR(0).LE.0.5)THEN + KFPR(ISUB,1)=5100001 +c Changed from private pythia6410_ued code +c KFPR(ISUB,2)=-5010001 + KFPR(ISUB,2)=-6100002 + ELSE + KFPR(ISUB,1)=5100002 +c Changed from private pythia6410_ued code +c KFPR(ISUB,2)=-5010002 + KFPR(ISUB,2)=-6100001 + ENDIF + ELSEIF(ISUB.EQ.317)THEN +C...qi + qbarj -> q*_Di + q*_Dbarj, q*_Si + q*_Dbarj + IF(PYR(0).LE.0.5)THEN + KFPR(ISUB,1)=5100001 + KFPR(ISUB,2)=-5100002 + ELSE + KFPR(ISUB,1)=5100002 + KFPR(ISUB,2)=-5100001 + ENDIF + ELSEIF(ISUB.EQ.318)THEN +C...qi + qj -> q*_Di + q*_Sj + IF(PYR(0).LE.0.5)THEN + KFPR(ISUB,1)=5100001 + KFPR(ISUB,2)=6100002 + ELSE + KFPR(ISUB,1)=5100002 + KFPR(ISUB,2)=6100001 + ENDIF + ENDIF + +C...Find resonances (explicit or implicit in cross-section). + MINT(72)=0 + KFR1=0 + IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN + KFR1=KFPR(ISUB,1) + ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165.OR. + & ISUB.EQ.171.OR.ISUB.EQ.176) THEN + KFR1=23 + ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172.OR. + & ISUB.EQ.177) THEN + KFR1=24 + ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN + KFR1=25 + IF(MSTP(46).EQ.5) THEN + KFR1=89 + PMAS(89,1)=PARP(45) + PMAS(89,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2) + ENDIF + ELSEIF(ISUB.EQ.481) THEN + KFR1=9900001 + ENDIF + CKMX=CKIN(2) + IF(CKMX.LE.0D0) CKMX=VINT(1) + KCR1=PYCOMP(KFR1) + IF(KCR1.EQ.0) KFR1=0 + IF(KFR1.NE.0) THEN + IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR. + & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0 + ENDIF + IF(KFR1.NE.0) THEN + TAUR1=PMAS(KCR1,1)**2/VINT(2) + GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2) + MINT(72)=1 + MINT(73)=KFR1 + VINT(73)=TAUR1 + VINT(74)=GAMR1 + ENDIF + KFR2=0 + KFR3=0 + IF(ISUB.EQ.141.OR.ISUB.EQ.194.OR.ISUB.EQ.195.OR. + $(ISUB.GE.361.AND.ISUB.LE.380)) + $THEN + KFR2=23 + IF(ISUB.EQ.141) THEN + KCR2=PYCOMP(KFR2) + IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR. + & CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) THEN + KFR2=0 + ELSE + TAUR2=PMAS(KCR2,1)**2/VINT(2) + GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2) + MINT(72)=2 + MINT(74)=KFR2 + VINT(75)=TAUR2 + VINT(76)=GAMR2 + ENDIF +C...3 resonances at work: rho, omega, a + ELSEIF(ISUB.EQ.194.OR.(ISUB.GE.361.AND.ISUB.LE.368) + & .OR.ISUB.EQ.379.OR.ISUB.EQ.380) THEN + MINT(72)=IRES + IF(IRES.GE.1) THEN + VINT(73)=XMAS(1)**2/VINT(2) + VINT(74)=XMAS(1)*XWID(1)/VINT(2) + TAUR1=VINT(73) + GAMR1=VINT(74) + KFR1=1 + ENDIF + IF(IRES.GE.2) THEN + VINT(75)=XMAS(2)**2/VINT(2) + VINT(76)=XMAS(2)*XWID(2)/VINT(2) + TAUR2=VINT(75) + GAMR2=VINT(76) + KFR2=2 + ENDIF + IF(IRES.EQ.3) THEN + VINT(77)=XMAS(3)**2/VINT(2) + VINT(78)=XMAS(3)*XWID(3)/VINT(2) + TAUR3=VINT(77) + GAMR3=VINT(78) + KFR3=3 + ENDIF +C...Charged current: rho+- and a+- + ELSEIF(ISUB.EQ.195.OR.ISUB.GE.370.AND.ISUB.LE.378) THEN + MINT(72)=IRES + IF(JRES.GE.1) THEN + VINT(73)=YMAS(1)**2/VINT(2) + VINT(74)=YMAS(1)*YWID(1)/VINT(2) + KFR1=1 + TAUR1=VINT(73) + GAMR1=VINT(74) + ENDIF + IF(JRES.GE.2) THEN + VINT(75)=YMAS(2)**2/VINT(2) + VINT(76)=YMAS(2)*YWID(2)/VINT(2) + KFR2=2 + TAUR2=VINT(73) + GAMR2=VINT(74) + ENDIF + KFR3=0 + ENDIF + IF(ISUB.NE.141) THEN + IF(KFR3.NE.0.AND.KFR2.NE.0.AND.KFR1.NE.0) THEN + + ELSEIF(KFR1.NE.0.AND.KFR2.NE.0) THEN + MINT(72)=2 + ELSEIF(KFR1.NE.0.AND.KFR3.NE.0) THEN + MINT(72)=2 + MINT(74)=KFR3 + VINT(75)=TAUR3 + VINT(76)=GAMR3 + ELSEIF(KFR2.NE.0.AND.KFR3.NE.0) THEN + MINT(72)=2 + MINT(73)=KFR2 + VINT(73)=TAUR2 + VINT(74)=GAMR2 + MINT(74)=KFR3 + VINT(75)=TAUR3 + VINT(76)=GAMR3 + ELSEIF(KFR1.NE.0) THEN + MINT(72)=1 + ELSEIF(KFR2.NE.0) THEN + MINT(72)=1 + MINT(73)=KFR2 + VINT(73)=TAUR2 + VINT(74)=GAMR2 + ELSEIF(KFR3.NE.0) THEN + MINT(72)=1 + MINT(73)=KFR3 + VINT(73)=TAUR3 + VINT(74)=GAMR3 + ELSE + MINT(72)=0 + ENDIF + ELSE + IF(KFR2.NE.0.AND.KFR1.NE.0) THEN + + ELSEIF(KFR2.NE.0) THEN + KFR1=KFR2 + TAUR1=TAUR2 + GAMR1=GAMR2 + MINT(72)=1 + MINT(73)=KFR1 + VINT(73)=TAUR1 + VINT(74)=GAMR1 + KFR2=0 + ELSE + MINT(72)=0 + ENDIF + ENDIF + ENDIF + +C...Find product masses and minimum pT of process, +C...optionally with broadening according to a truncated Breit-Wigner. + VINT(63)=0D0 + VINT(64)=0D0 + MINT(71)=0 + VINT(71)=CKIN(3) + IF(MINT(82).GE.2) VINT(71)=0D0 + VINT(80)=1D0 + IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN + NBW=0 + DO 160 I=1,2 + PMMN(I)=0D0 + IF(KFPR(ISUB,I).EQ.0) THEN + ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT. + & PARP(41)) THEN + VINT(62+I)=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2 + ELSE + NBW=NBW+1 +C...This prevents SUSY/t particles from becoming too light. + KFLW=KFPR(ISUB,I) + IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN + KCW=PYCOMP(KFLW) + PMMN(I)=PMAS(KCW,1) + DO 150 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1 + IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN + PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+ + & PMAS(PYCOMP(KFDP(IDC,2)),1) + IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+ + & PMAS(PYCOMP(KFDP(IDC,3)),1) + PMMN(I)=MIN(PMMN(I),PMSUM) + ENDIF + 150 CONTINUE + ELSEIF(KFLW.EQ.6) THEN + PMMN(I)=PMAS(24,1)+PMAS(5,1) + ENDIF + ENDIF + 160 CONTINUE + IF(NBW.GE.1) THEN + CKIN41=CKIN(41) + CKIN43=CKIN(43) + CKIN(41)=MAX(PMMN(1),CKIN(41)) + CKIN(43)=MAX(PMMN(2),CKIN(43)) + CALL PYOFSH(4,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4) + CKIN(41)=CKIN41 + CKIN(43)=CKIN43 + IF(MINT(51).EQ.1) THEN + IF(MINT(121).GT.1) CALL PYSAVE(2,IGA) + IF(MFAIL.EQ.1) THEN + MSTI(61)=1 + RETURN + ENDIF + GOTO 100 + ENDIF + VINT(63)=PQM3**2 + VINT(64)=PQM4**2 + ENDIF + IF(MIN(VINT(63),VINT(64)).LT.CKIN(6)**2) MINT(71)=1 + IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5)) + ENDIF + +C...Prepare for additional variable choices in 2 -> 3. + IF(ISTSB.EQ.5) THEN + VINT(201)=0D0 + IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1) + VINT(206)=VINT(201) + IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(206)=PMAS(5,1) + VINT(204)=PMAS(23,1) + IF(ISUB.EQ.124.OR.ISUB.EQ.174.OR.ISUB.EQ.179.OR.ISUB.EQ.351) + & VINT(204)=PMAS(24,1) + IF(ISUB.EQ.352) VINT(204)=PMAS(PYCOMP(9900024),1) + IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182.OR. + & ISUB.EQ.186.OR.ISUB.EQ.187.OR.ISUB.EQ.401.OR.ISUB.EQ.402) + & VINT(204)=VINT(201) + VINT(209)=VINT(204) + IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(209)=VINT(206) + ENDIF + +C...Select incoming VDM particle (rho/omega/phi/J/psi). + IF(ISTSB.NE.0.AND.(MINT(101).GE.2.OR.MINT(102).GE.2).AND. + &(MINT(123).EQ.2.OR.MINT(123).EQ.3.OR.MINT(123).EQ.7)) THEN + VRN=PYR(0)*SIGT(0,0,5) + IF(MINT(101).LE.1) THEN + I1MN=0 + I1MX=0 + ELSE + I1MN=1 + I1MX=MINT(101) + ENDIF + IF(MINT(102).LE.1) THEN + I2MN=0 + I2MX=0 + ELSE + I2MN=1 + I2MX=MINT(102) + ENDIF + DO 180 I1=I1MN,I1MX + KFV1=110*I1+3 + DO 170 I2=I2MN,I2MX + KFV2=110*I2+3 + VRN=VRN-SIGT(I1,I2,5) + IF(VRN.LE.0D0) GOTO 190 + 170 CONTINUE + 180 CONTINUE + 190 IF(MINT(101).GE.2) MINT(103)=KFV1 + IF(MINT(102).GE.2) MINT(104)=KFV2 + ENDIF + + IF(ISTSB.EQ.0) THEN +C...Elastic scattering or single or double diffractive scattering. + +C...Select incoming particle (rho/omega/phi/J/psi for VDM) and mass. + MINT(103)=MINT(11) + MINT(104)=MINT(12) + PMM(1)=VINT(3) + PMM(2)=VINT(4) + IF(MINT(101).GE.2.OR.MINT(102).GE.2) THEN + JJ=ISUB-90 + VRN=PYR(0)*SIGT(0,0,JJ) + IF(MINT(101).LE.1) THEN + I1MN=0 + I1MX=0 + ELSE + I1MN=1 + I1MX=MINT(101) + ENDIF + IF(MINT(102).LE.1) THEN + I2MN=0 + I2MX=0 + ELSE + I2MN=1 + I2MX=MINT(102) + ENDIF + DO 210 I1=I1MN,I1MX + KFV1=110*I1+3 + DO 200 I2=I2MN,I2MX + KFV2=110*I2+3 + VRN=VRN-SIGT(I1,I2,JJ) + IF(VRN.LE.0D0) GOTO 220 + 200 CONTINUE + 210 CONTINUE + 220 IF(MINT(101).GE.2) THEN + MINT(103)=KFV1 + PMM(1)=PYMASS(KFV1) + ENDIF + IF(MINT(102).GE.2) THEN + MINT(104)=KFV2 + PMM(2)=PYMASS(KFV2) + ENDIF + ENDIF + VINT(67)=PMM(1) + VINT(68)=PMM(2) + +C...Select mass for GVMD states (rejecting previous assignment). + Q0S=4D0*PARP(15)**2 + Q1S=4D0*VINT(154)**2 + LOOP3=0 + 230 LOOP3=LOOP3+1 + DO 240 JT=1,2 + IF(MINT(106+JT).EQ.3) THEN + PS=VINT(2+JT)**2 + PMM(JT)=SQRT((Q0S+PS)*(Q1S+PS)/ + & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS) + IF(MINT(102+JT).GE.333) PMM(JT)=PMM(JT)- + & PMAS(PYCOMP(113),1)+PMAS(PYCOMP(MINT(102+JT)),1) + ENDIF + 240 CONTINUE + IF(PMM(1)+PMM(2)+PARP(104).GE.VINT(1)) THEN + IF(LOOP3.LT.100.AND.(MINT(107).EQ.3.OR.MINT(108).EQ.3)) + & GOTO 230 + GOTO 100 + ENDIF + +C...Side/sides of diffractive system. + MINT(17)=0 + MINT(18)=0 + IF(ISUB.EQ.92.OR.ISUB.EQ.94) MINT(17)=1 + IF(ISUB.EQ.93.OR.ISUB.EQ.94) MINT(18)=1 + +C...Find masses of particles and minimal masses of diffractive states. + DO 250 JT=1,2 + PDIF(JT)=PMM(JT) + VINT(68+JT)=PDIF(JT) + IF(MINT(16+JT).EQ.1) PDIF(JT)=PDIF(JT)+PARP(102) + 250 CONTINUE + SH=VINT(2) + SQM1=PMM(1)**2 + SQM2=PMM(2)**2 + SQM3=PDIF(1)**2 + SQM4=PDIF(2)**2 + SMRES1=(PMM(1)+PMRC)**2 + SMRES2=(PMM(2)+PMRC)**2 + +C...Find elastic slope and lower limit diffractive slope. + IHA=MAX(2,IABS(MINT(103))/110) + IF(IHA.GE.5) IHA=1 + IHB=MAX(2,IABS(MINT(104))/110) + IF(IHB.GE.5) IHB=1 + IF(ISUB.EQ.91) THEN + BMN=2D0*BHAD(IHA)+2D0*BHAD(IHB)+4D0*SH**EPS-4.2D0 + ELSEIF(ISUB.EQ.92) THEN + BMN=MAX(2D0,2D0*BHAD(IHB)) + ELSEIF(ISUB.EQ.93) THEN + BMN=MAX(2D0,2D0*BHAD(IHA)) + ELSEIF(ISUB.EQ.94) THEN + BMN=2D0*ALP*4D0 + ENDIF + +C...Determine maximum possible t range and coefficient of generation. + SQLA12=(SH-SQM1-SQM2)**2-4D0*SQM1*SQM2 + SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4 + THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH + THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH + THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)* + & (SQM1*SQM4-SQM2*SQM3)/SH + THL=-0.5D0*(THA+THB) + THU=THC/THL + THRND=EXP(MAX(-50D0,BMN*(THL-THU)))-1D0 + +C...Select diffractive mass/masses according to dm^2/m^2. + LOOP3=0 + 260 LOOP3=LOOP3+1 + DO 270 JT=1,2 + IF(MINT(16+JT).EQ.0) THEN + PDIF(2+JT)=PDIF(JT) + ELSE + PMMIN=PDIF(JT) + PMMAX=MAX(VINT(2+JT),VINT(1)-PDIF(3-JT)) + PDIF(2+JT)=PMMIN*(PMMAX/PMMIN)**PYR(0) + ENDIF + 270 CONTINUE + SQM3=PDIF(3)**2 + SQM4=PDIF(4)**2 + +C..Additional mass factors, including resonance enhancement. + IF(PDIF(3)+PDIF(4).GE.VINT(1)) THEN + IF(LOOP3.LT.100) GOTO 260 + GOTO 100 + ENDIF + IF(ISUB.EQ.92) THEN + FSD=(1D0-SQM3/SH)*(1D0+CRES*SMRES1/(SMRES1+SQM3)) + IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 260 + ELSEIF(ISUB.EQ.93) THEN + FSD=(1D0-SQM4/SH)*(1D0+CRES*SMRES2/(SMRES2+SQM4)) + IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 260 + ELSEIF(ISUB.EQ.94) THEN + FDD=(1D0-(PDIF(3)+PDIF(4))**2/SH)*(SH*SMP/ + & (SH*SMP+SQM3*SQM4))*(1D0+CRES*SMRES1/(SMRES1+SQM3))* + & (1D0+CRES*SMRES2/(SMRES2+SQM4)) + IF(FDD.LT.PYR(0)*(1D0+CRES)**2) GOTO 260 + ENDIF + +C...Select t according to exp(Bmn*t) and correct to right slope. + TH=THU+LOG(1D0+THRND*PYR(0))/BMN + IF(ISUB.GE.92) THEN + IF(ISUB.EQ.92) THEN + BADD=2D0*ALP*LOG(SH/SQM3) + IF(BHAD(IHB).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHB)-2D0) + ELSEIF(ISUB.EQ.93) THEN + BADD=2D0*ALP*LOG(SH/SQM4) + IF(BHAD(IHA).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHA)-2D0) + ELSEIF(ISUB.EQ.94) THEN + BADD=2D0*ALP*(LOG(EXP(4D0)+SH/(ALP*SQM3*SQM4))-4D0) + ENDIF + IF(EXP(MAX(-50D0,BADD*(TH-THU))).LT.PYR(0)) GOTO 260 + ENDIF + +C...Check whether m^2 and t choices are consistent. + SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4 + THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH + THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH + IF(THB.LE.1D-8) GOTO 260 + THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)* + & (SQM1*SQM4-SQM2*SQM3)/SH + THLM=-0.5D0*(THA+THB) + THUM=THC/THLM + IF(TH.LT.THLM.OR.TH.GT.THUM) GOTO 260 + +C...Information to output. + VINT(21)=1D0 + VINT(22)=0D0 + VINT(23)=MIN(1D0,MAX(-1D0,(THA+2D0*TH)/THB)) + VINT(45)=TH + VINT(59)=2D0*SQRT(MAX(0D0,-(THC+THA*TH+TH**2)))/THB + VINT(63)=PDIF(3)**2 + VINT(64)=PDIF(4)**2 + VINT(283)=PMM(1)**2/4D0 + VINT(284)=PMM(2)**2/4D0 + +C...Note: in the following, by In is meant the integral over the +C...quantity multiplying coefficient cn. +C...Choose tau according to h1(tau)/tau, where +C...h1(tau) = c1 + I1/I2*c2*1/tau + I1/I3*c3*1/(tau+tau_R) + +C...I1/I4*c4*tau/((s*tau-m^2)^2+(m*Gamma)^2) + +C...I1/I5*c5*1/(tau+tau_R') + +C...I1/I6*c6*tau/((s*tau-m'^2)^2+(m'*Gamma')^2) + +C...I1/I7*c7*tau/(1.-tau), and +C...c1 + c2 + c3 + c4 + c5 + c6 + c7 = 1. + ELSEIF(ISTSB.GE.1.AND.ISTSB.LE.5) THEN + CALL PYKLIM(1) + IF(MINT(51).NE.0) THEN + IF(MINT(121).GT.1) CALL PYSAVE(2,IGA) + IF(MFAIL.EQ.1) THEN + MSTI(61)=1 + RETURN + ENDIF + GOTO 100 + ENDIF + RTAU=PYR(0) + MTAU=1 + IF(RTAU.GT.COEF(ISUB,1)) MTAU=2 + IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)) MTAU=3 + IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)) MTAU=4 + IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)) + & MTAU=5 + IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+ + & COEF(ISUB,5)) MTAU=6 + IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+ + & COEF(ISUB,5)+COEF(ISUB,6)) MTAU=7 +C...Additional check to handle techni-processes with extra resonance +C....Only modify tau treatment + IF(ISUB.EQ.194.OR.ISUB.EQ.195.OR.(ISUB.GE.361.AND.ISUB.LE.380)) + & THEN + IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3) + & +COEF(ISUB,4)+COEF(ISUB,5)+COEF(ISUB,6)+COEF(ISUB,7)) MTAU=8 + IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3) + & +COEF(ISUB,4)+COEF(ISUB,5)+COEF(ISUB,6)+COEF(ISUB,7) + & +COEFX(ISUB,1)) MTAU=9 + ENDIF + CALL PYKMAP(1,MTAU,PYR(0)) + +C...2 -> 3, 4 processes: +C...Choose tau' according to h4(tau,tau')/tau', where +C...h4(tau,tau') = c1 + I1/I2*c2*(1 - tau/tau')^3/tau' + +C...I1/I3*c3*1/(1 - tau'), and c1 + c2 + c3 = 1. + IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN + CALL PYKLIM(4) + IF(MINT(51).NE.0) THEN + IF(MINT(121).GT.1) CALL PYSAVE(2,IGA) + IF(MFAIL.EQ.1) THEN + MSTI(61)=1 + RETURN + ENDIF + GOTO 100 + ENDIF + RTAUP=PYR(0) + MTAUP=1 + IF(RTAUP.GT.COEF(ISUB,18)) MTAUP=2 + IF(RTAUP.GT.COEF(ISUB,18)+COEF(ISUB,19)) MTAUP=3 + CALL PYKMAP(4,MTAUP,PYR(0)) + ENDIF + +C...Choose y* according to h2(y*), where +C...h2(y*) = I0/I1*c1*(y*-y*min) + I0/I2*c2*(y*max-y*) + +C...I0/I3*c3*1/cosh(y*) + I0/I4*c4*1/(1-exp(y*-y*max)) + +C...I0/I5*c5*1/(1-exp(-y*-y*min)), I0 = y*max-y*min, +C...and c1 + c2 + c3 + c4 + c5 = 1. + CALL PYKLIM(2) + IF(MINT(51).NE.0) THEN + IF(MINT(121).GT.1) CALL PYSAVE(2,IGA) + IF(MFAIL.EQ.1) THEN + MSTI(61)=1 + RETURN + ENDIF + GOTO 100 + ENDIF + RYST=PYR(0) + MYST=1 + IF(RYST.GT.COEF(ISUB,8)) MYST=2 + IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3 + IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)) MYST=4 + IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)+ + & COEF(ISUB,11)) MYST=5 + CALL PYKMAP(2,MYST,PYR(0)) + +C...2 -> 2 processes: +C...Choose cos(theta-hat) (cth) according to h3(cth), where +C...h3(cth) = c0 + I0/I1*c1*1/(A - cth) + I0/I2*c2*1/(A + cth) + +C...I0/I3*c3*1/(A - cth)^2 + I0/I4*c4*1/(A + cth)^2, +C...A = 1 + 2*(m3*m4/sh)^2 (= 1 for massless products), +C...and c0 + c1 + c2 + c3 + c4 = 1. + CALL PYKLIM(3) + IF(MINT(51).NE.0) THEN + IF(MINT(121).GT.1) CALL PYSAVE(2,IGA) + IF(MFAIL.EQ.1) THEN + MSTI(61)=1 + RETURN + ENDIF + GOTO 100 + ENDIF + IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN + RCTH=PYR(0) + MCTH=1 + IF(RCTH.GT.COEF(ISUB,13)) MCTH=2 + IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)) MCTH=3 + IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)) MCTH=4 + IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)+ + & COEF(ISUB,16)) MCTH=5 + CALL PYKMAP(3,MCTH,PYR(0)) + ENDIF + +C...2 -> 3 : select pT1, phi1, pT2, phi2, y3 for 3 outgoing. + IF(ISTSB.EQ.5) THEN + CALL PYKMAP(5,0,0D0) + IF(MINT(51).NE.0) THEN + IF(MINT(121).GT.1) CALL PYSAVE(2,IGA) + IF(MFAIL.EQ.1) THEN + MSTI(61)=1 + RETURN + ENDIF + GOTO 100 + ENDIF + ENDIF + +C...DIS as f + gamma* -> f process: set dummy values. + ELSEIF(ISTSB.EQ.8) THEN + VINT(21)=0.9D0 + VINT(22)=0D0 + VINT(23)=0D0 + VINT(47)=0D0 + VINT(48)=0D0 + +C...Low-pT or multiple interactions (first semihard interaction). + ELSEIF(ISTSB.EQ.9) THEN + IF(MINT(35).LE.1) CALL PYMULT(3) + IF(MINT(35).GE.2) CALL PYMIGN(3) + ISUB=MINT(1) + +C...Study user-defined process: kinematics plus weight. + ELSEIF(ISTSB.EQ.11) THEN + IF(IDWTUP.GT.0.AND.XWGTUP.LT.0D0) CALL + & PYERRM(26,'(PYRAND:) Negative XWGTUP for user process') + MSTI(51)=0 + IF(NUP.LE.0) THEN + MINT(51)=2 + MSTI(51)=1 + IF(MINT(82).EQ.1) THEN + NGEN(0,1)=NGEN(0,1)-1 + NGEN(ISUB,1)=NGEN(ISUB,1)-1 + ENDIF + IF(MINT(121).GT.1) CALL PYSAVE(2,IGA) + RETURN + ENDIF + +C...Extract cross section event weight. + IF(IABS(IDWTUP).EQ.1.OR.IABS(IDWTUP).EQ.4) THEN + SIGS=1D-9*XWGTUP + ELSE + SIGS=1D-9*XSECUP(KFPR(ISUB,1)) + ENDIF + IF(IABS(IDWTUP).GE.1.AND.IABS(IDWTUP).LE.3) THEN + VINT(97)=SIGN(1D0,XWGTUP) + ELSE + VINT(97)=1D-9*XWGTUP + ENDIF + +C...Construct 'trivial' kinematical variables needed. + KFL1=IDUP(1) + KFL2=IDUP(2) + VINT(41)=PUP(4,1)/EBMUP(1) + VINT(42)=PUP(4,2)/EBMUP(2) + IF (VINT(41).GT.1.000001.OR.VINT(42).GT.1.000001) THEN + CALL PYERRM(9,'(PYRAND:) x > 1 in external event '// + & '(listing follows):') + CALL PYLIST(7) + ENDIF + VINT(21)=VINT(41)*VINT(42) + VINT(22)=0.5D0*LOG(VINT(41)/VINT(42)) + VINT(44)=VINT(21)*VINT(2) + VINT(43)=SQRT(MAX(0D0,VINT(44))) + VINT(55)=SCALUP + IF(SCALUP.LE.0D0) VINT(55)=VINT(43) + VINT(56)=VINT(55)**2 + VINT(57)=AQEDUP + VINT(58)=AQCDUP + +C...Construct other kinematical variables needed (approximately). + VINT(23)=0D0 + VINT(26)=VINT(21) + VINT(45)=-0.5D0*VINT(44) + VINT(46)=-0.5D0*VINT(44) + VINT(49)=VINT(43) + VINT(50)=VINT(44) + VINT(51)=VINT(55) + VINT(52)=VINT(56) + VINT(53)=VINT(55) + VINT(54)=VINT(56) + VINT(25)=0D0 + VINT(48)=0D0 + IF(ISTUP(1).NE.-1.OR.ISTUP(2).NE.-1) CALL PYERRM(26, + & '(PYRAND:) unacceptable ISTUP code for incoming particles') + DO 280 IUP=3,NUP + IF(ISTUP(IUP).LT.1.OR.ISTUP(IUP).GT.3) CALL PYERRM(26, + & '(PYRAND:) unacceptable ISTUP code for particles') + IF(ISTUP(IUP).EQ.1) VINT(25)=VINT(25)+2D0*(PUP(5,IUP)**2+ + & PUP(1,IUP)**2+PUP(2,IUP)**2)/VINT(2) + IF(ISTUP(IUP).EQ.1) VINT(48)=VINT(48)+0.5D0*(PUP(1,IUP)**2+ + & PUP(2,IUP)**2) + 280 CONTINUE + VINT(47)=SQRT(VINT(48)) + ENDIF + +C...Choose azimuthal angle. + VINT(24)=0D0 + IF(ISTSB.NE.11) VINT(24)=PARU(2)*PYR(0) + +C...Check against user cuts on kinematics at parton level. + MINT(51)=0 + IF((ISUB.LE.90.OR.ISUB.GT.100).AND.ISTSB.LE.10) CALL PYKLIM(0) + IF(MINT(51).NE.0) THEN + IF(MINT(121).GT.1) CALL PYSAVE(2,IGA) + IF(MFAIL.EQ.1) THEN + MSTI(61)=1 + RETURN + ENDIF + GOTO 100 + ENDIF + IF(MINT(82).EQ.1.AND.MSTP(141).GE.1.AND.ISTSB.LE.10) THEN + MCUT=0 + IF(MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+MSUB(95).EQ.0) + & CALL PYKCUT(MCUT) + IF(MCUT.NE.0) THEN + IF(MINT(121).GT.1) CALL PYSAVE(2,IGA) + IF(MFAIL.EQ.1) THEN + MSTI(61)=1 + RETURN + ENDIF + GOTO 100 + ENDIF + ENDIF + + IF(ISTSB.LE.10) THEN +C... If internal process, call PYSIGH + CALL PYSIGH(NCHN,SIGS) + ELSE +C... If external process, still have to set MI starting scale + IF (MSTP(86).EQ.1) THEN +C... Limit phase space by xT2 of hard interaction +C... (gives undercounting of MI when ext proc != dijets) + XT2GMX = VINT(25) + ELSE +C... All accessible phase space allowed +C... (gives double counting of MI when ext proc = dijets) + XT2GMX = (1D0-VINT(41))*(1D0-VINT(42)) + ENDIF + VINT(62)=0.25D0*XT2GMX*VINT(2) + VINT(61)=SQRT(MAX(0D0,VINT(62))) + ENDIF + + SIGSOR=SIGS + SIGLPT=SIGT(0,0,5)*VINT(315)*VINT(316) + +C...Multiply cross section by lepton -> photon flux factor. + IF(MINT(141).NE.0.OR.MINT(142).NE.0) THEN + SIGS=WTGAGA*SIGS + DO 290 ICHN=1,NCHN + SIGH(ICHN)=WTGAGA*SIGH(ICHN) + 290 CONTINUE + SIGLPT=WTGAGA*SIGLPT + ENDIF + +C...Multiply cross-section by user-defined weights. + IF(MSTP(173).EQ.1) THEN + SIGS=PARP(173)*SIGS + DO 300 ICHN=1,NCHN + SIGH(ICHN)=PARP(173)*SIGH(ICHN) + 300 CONTINUE + SIGLPT=PARP(173)*SIGLPT + ENDIF + WTXS=1D0 + SIGSWT=SIGS + VINT(99)=1D0 + VINT(100)=1D0 + IF(MINT(82).EQ.1.AND.MSTP(142).GE.1) THEN + IF(ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+ + & MSUB(95).EQ.0) CALL PYEVWT(WTXS) + SIGSWT=WTXS*SIGS + VINT(99)=WTXS + IF(MSTP(142).EQ.1) VINT(100)=1D0/WTXS + ENDIF + +C...Calculations for Monte Carlo estimate of all cross-sections. + IF(MINT(82).EQ.1.AND.ISUB.LE.90.OR.ISUB.GE.96) THEN + IF(MSTP(142).LE.1) THEN + XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS + ELSE + XSEC(ISUB,2)=XSEC(ISUB,2)+SIGSWT + ENDIF + ELSEIF(MINT(82).EQ.1) THEN + XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS + ENDIF + IF((ISUB.EQ.95.OR.ISUB.EQ.96).AND.LOOP2.EQ.1.AND. + &MINT(82).EQ.1) XSEC(97,2)=XSEC(97,2)+SIGLPT + +C...Multiple interactions: store results of cross-section calculation. + IF(MINT(50).EQ.1.AND.MSTP(82).GE.3) THEN + VINT(153)=SIGSOR + IF(MINT(35).LE.1) CALL PYMULT(4) + IF(MINT(35).GE.2) CALL PYMIGN(4) + ENDIF + +C...Ratio of actual to maximum cross section. + IF(ISTSB.NE.11) THEN + VIOL=SIGSWT/XSEC(ISUB,1) + IF(ISUB.EQ.96.AND.MSTP(173).EQ.1) VIOL=VIOL/PARP(174) + ELSEIF(IDWTUP.EQ.1.OR.IDWTUP.EQ.2) THEN + VIOL=XWGTUP/XMAXUP(KFPR(ISUB,1)) + ELSEIF(IDWTUP.EQ.-1.OR.IDWTUP.EQ.-2) THEN + VIOL=ABS(XWGTUP)/ABS(XMAXUP(KFPR(ISUB,1))) + ELSE + VIOL=1D0 + ENDIF + +C...Check that weight not negative. + IF(MSTP(123).LE.0) THEN + IF(VIOL.LT.-1D-3) THEN + WRITE(MSTU(11),5000) VIOL,NGEN(0,3)+1 + IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21), + & VINT(22),VINT(23),VINT(26) + CALL PYSTOP(2) + ENDIF + ELSE + IF(VIOL.LT.MIN(-1D-3,VINT(109))) THEN + VINT(109)=VIOL + IF(MSTP(123).LE.2) WRITE(MSTU(11),5200) VIOL,NGEN(0,3)+1 + IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21), + & VINT(22),VINT(23),VINT(26) + ENDIF + ENDIF + +C...Weighting using estimate of maximum of differential cross-section. + RATND=1D0 + IF(MFAIL.EQ.0.AND.ISUB.NE.95.AND.ISUB.NE.96) THEN + IF(VIOL.LT.PYR(0)) THEN + IF(MINT(121).GT.1) CALL PYSAVE(2,IGA) + IF(ISUB.GE.91.AND.ISUB.LE.94) ISUB=0 + GOTO 100 + ENDIF + ELSEIF(MFAIL.EQ.0) THEN + RATND=SIGLPT/XSEC(95,1) + VIOL=VIOL/RATND + IF(LOOP2.EQ.1.AND.RATND.LT.PYR(0)) THEN + IF(VIOL.GT.PYR(0).AND.MINT(82).EQ.1.AND.MSUB(95).EQ.1.AND. + & (ISUB.LE.90.OR.ISUB.GE.95)) NGEN(95,1)=NGEN(95,1)+MINT(143) + IF(MINT(121).GT.1) CALL PYSAVE(2,IGA) + ISUB=0 + GOTO 100 + ENDIF + IF(VIOL.LT.PYR(0)) THEN + GOTO 140 + ENDIF + ELSEIF(ISUB.NE.95.AND.ISUB.NE.96) THEN + IF(VIOL.LT.PYR(0)) THEN + MSTI(61)=1 + IF(MINT(121).GT.1) CALL PYSAVE(2,IGA) + RETURN + ENDIF + ELSE + RATND=SIGLPT/XSEC(95,1) + IF(LOOP.EQ.1.AND.RATND.LT.PYR(0)) THEN + MSTI(61)=1 + IF(MINT(121).GT.1) CALL PYSAVE(2,IGA) + RETURN + ENDIF + VIOL=VIOL/RATND + IF(VIOL.LT.PYR(0)) THEN + IF(MINT(121).GT.1) CALL PYSAVE(2,IGA) + GOTO 100 + ENDIF + ENDIF + +C...Check for possible violation of estimated maximum of differential +C...cross-section used in weighting. + IF(MSTP(123).LE.0) THEN + IF(VIOL.GT.1D0) THEN + WRITE(MSTU(11),5300) VIOL,NGEN(0,3)+1 + IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21), + & VINT(22),VINT(23),VINT(26) + CALL PYSTOP(2) + ENDIF + ELSEIF(MSTP(123).EQ.1) THEN + IF(VIOL.GT.VINT(108)) THEN + VINT(108)=VIOL + IF(VIOL.GT.1.0001D0) THEN + MINT(10)=1 + WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1 + IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21), + & VINT(22),VINT(23),VINT(26) + ENDIF + ENDIF + ELSEIF(VIOL.GT.VINT(108)) THEN + VINT(108)=VIOL + IF(VIOL.GT.1D0) THEN + MINT(10)=1 + IF(MSTP(123).EQ.2) WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1 + IF(ISTSB.EQ.11.AND.(IABS(IDWTUP).EQ.1.OR.IABS(IDWTUP).EQ.2)) + & THEN + XMAXUP(KFPR(ISUB,1))=VIOL*XMAXUP(KFPR(ISUB,1)) + IF(KFPR(ISUB,1).LE.9) THEN + IF(MSTP(123).EQ.2) WRITE(MSTU(11),5800) KFPR(ISUB,1), + & XMAXUP(KFPR(ISUB,1)) + ELSEIF(KFPR(ISUB,1).LE.99) THEN + IF(MSTP(123).EQ.2) WRITE(MSTU(11),5900) KFPR(ISUB,1), + & XMAXUP(KFPR(ISUB,1)) + ELSE + IF(MSTP(123).EQ.2) WRITE(MSTU(11),6000) KFPR(ISUB,1), + & XMAXUP(KFPR(ISUB,1)) + ENDIF + ENDIF + IF(ISTSB.NE.11.OR.IABS(IDWTUP).EQ.1) THEN + XDIF=XSEC(ISUB,1)*(VIOL-1D0) + XSEC(ISUB,1)=XSEC(ISUB,1)+XDIF + IF(MSUB(ISUB).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GT.96)) + & XSEC(0,1)=XSEC(0,1)+XDIF + IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21), + & VINT(22),VINT(23),VINT(26) + IF(ISUB.LE.9) THEN + IF(MSTP(123).EQ.2) WRITE(MSTU(11),5500) ISUB,XSEC(ISUB,1) + ELSEIF(ISUB.LE.99) THEN + IF(MSTP(123).EQ.2) WRITE(MSTU(11),5600) ISUB,XSEC(ISUB,1) + ELSE + IF(MSTP(123).EQ.2) WRITE(MSTU(11),5700) ISUB,XSEC(ISUB,1) + ENDIF + ENDIF + VINT(108)=1D0 + ENDIF + ENDIF + +C...Multiple interactions: choose impact parameter (if not already done). + IF(MINT(39).EQ.0) VINT(148)=1D0 + IF(MINT(50).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GE.96).AND. + &MSTP(82).GE.3) THEN + IF(MINT(35).LE.1) CALL PYMULT(5) + IF(MINT(35).GE.2) CALL PYMIGN(5) + IF(VINT(150).LT.PYR(0)) THEN + IF(MINT(121).GT.1) CALL PYSAVE(2,IGA) + IF(MFAIL.EQ.1) THEN + MSTI(61)=1 + RETURN + ENDIF + GOTO 100 + ENDIF + ENDIF + IF(MINT(82).EQ.1) NGEN(0,2)=NGEN(0,2)+1 + IF(MINT(82).EQ.1.AND.MSUB(95).EQ.1) THEN + IF(ISUB.LE.90.OR.ISUB.GE.95) NGEN(95,1)=NGEN(95,1)+MINT(143) + IF(ISUB.LE.90.OR.ISUB.GE.96) NGEN(96,2)=NGEN(96,2)+1 + ENDIF + IF(ISUB.LE.90.OR.ISUB.GE.96) MINT(31)=MINT(31)+1 + +C...Choose flavour of reacting partons (and subprocess). + IF(ISTSB.GE.11) GOTO 320 + RSIGS=SIGS*PYR(0) + QT2=VINT(48) + RQQBAR=PARP(87)*(1D0-(QT2/(QT2+(PARP(88)*PARP(82)* + &(VINT(1)/PARP(89))**PARP(90))**2))**2) + IF(ISUB.NE.95.AND.(ISUB.NE.96.OR.MSTP(82).LE.1.OR. + &PYR(0).GT.RQQBAR)) THEN + DO 310 ICHN=1,NCHN + KFL1=ISIG(ICHN,1) + KFL2=ISIG(ICHN,2) + MINT(2)=ISIG(ICHN,3) + RSIGS=RSIGS-SIGH(ICHN) + IF(RSIGS.LE.0D0) GOTO 320 + 310 CONTINUE + +C...Multiple interactions: choose qqbar preferentially at small pT. + ELSEIF(ISUB.EQ.96) THEN + MINT(105)=MINT(103) + MINT(109)=MINT(107) + CALL PYSPLI(MINT(11),21,KFL1,KFLDUM) + MINT(105)=MINT(104) + MINT(109)=MINT(108) + CALL PYSPLI(MINT(12),21,KFL2,KFLDUM) + MINT(1)=11 + MINT(2)=1 + IF(KFL1.EQ.KFL2.AND.PYR(0).LT.0.5D0) MINT(2)=2 + +C...Low-pT: choose string drawing configuration. + ELSE + KFL1=21 + KFL2=21 + RSIGS=6D0*PYR(0) + MINT(2)=1 + IF(RSIGS.GT.1D0) MINT(2)=2 + IF(RSIGS.GT.2D0) MINT(2)=3 + ENDIF + +C...Reassign QCD process. Partons before initial state radiation. + 320 IF(MINT(2).GT.10) THEN + MINT(1)=MINT(2)/10 + MINT(2)=MOD(MINT(2),10) + ENDIF + IF(MINT(82).EQ.1.AND.MSTP(111).GE.0) NGEN(MINT(1),2)= + &NGEN(MINT(1),2)+1 + MINT(15)=KFL1 + MINT(16)=KFL2 + MINT(13)=MINT(15) + MINT(14)=MINT(16) + VINT(141)=VINT(41) + VINT(142)=VINT(42) + VINT(151)=0D0 + VINT(152)=0D0 + +C...Calculate x value of photon for parton inside photon inside e. + DO 350 JT=1,2 + MINT(18+JT)=0 + VINT(154+JT)=0D0 + MSPLI=0 + IF(JT.EQ.1.AND.MINT(43).LE.2) MSPLI=1 + IF(JT.EQ.2.AND.MOD(MINT(43),2).EQ.1) MSPLI=1 + IF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) MSPLI=MSPLI+1 + IF(MSPLI.EQ.2) THEN + KFLH=MINT(14+JT) + XHRD=VINT(140+JT) + Q2HRD=VINT(54) + MINT(105)=MINT(102+JT) + MINT(109)=MINT(106+JT) + VINT(120)=VINT(2+JT) + IF(MSTP(57).LE.1) THEN + CALL PYPDFU(22,XHRD,Q2HRD,XPQ) + ELSE + CALL PYPDFL(22,XHRD,Q2HRD,XPQ) + ENDIF + WTMX=4D0*XPQ(KFLH) + IF(MSTP(13).EQ.2) THEN + Q2PMS=Q2HRD/PMAS(11,1)**2 + WTMX=WTMX*LOG(MAX(2D0,Q2PMS*(1D0-XHRD)/XHRD**2)) + ENDIF + 330 XE=XHRD**PYR(0) + XG=MIN(1D0-1D-10,XHRD/XE) + IF(MSTP(57).LE.1) THEN + CALL PYPDFU(22,XG,Q2HRD,XPQ) + ELSE + CALL PYPDFL(22,XG,Q2HRD,XPQ) + ENDIF + WT=(1D0+(1D0-XE)**2)*XPQ(KFLH) + IF(MSTP(13).EQ.2) WT=WT*LOG(MAX(2D0,Q2PMS*(1D0-XE)/XE**2)) + IF(WT.LT.PYR(0)*WTMX) GOTO 330 + MINT(18+JT)=1 + VINT(154+JT)=XE + DO 340 KFLS=-25,25 + XSFX(JT,KFLS)=XPQ(KFLS) + 340 CONTINUE + ENDIF + 350 CONTINUE + +C...Pick scale where photon is resolved. + Q0S=PARP(15)**2 + Q1S=VINT(154)**2 + VINT(283)=0D0 + IF(MINT(107).EQ.3) THEN + IF(MSTP(66).EQ.1) THEN + VINT(283)=Q0S*(VINT(54)/Q0S)**PYR(0) + ELSEIF(MSTP(66).EQ.2) THEN + PS=VINT(3)**2 + Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))* + & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS))) + Q2INT=SQRT(Q0S*Q2EFF) + VINT(283)=Q2INT*(VINT(54)/Q2INT)**PYR(0) + ELSEIF(MSTP(66).EQ.3) THEN + VINT(283)=Q0S*(Q1S/Q0S)**PYR(0) + ELSEIF(MSTP(66).GE.4) THEN + PS=0.25D0*VINT(3)**2 + VINT(283)=(Q0S+PS)*(Q1S+PS)/ + & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS + ENDIF + ENDIF + VINT(284)=0D0 + IF(MINT(108).EQ.3) THEN + IF(MSTP(66).EQ.1) THEN + VINT(284)=Q0S*(VINT(54)/Q0S)**PYR(0) + ELSEIF(MSTP(66).EQ.2) THEN + PS=VINT(4)**2 + Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))* + & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS))) + Q2INT=SQRT(Q0S*Q2EFF) + VINT(284)=Q2INT*(VINT(54)/Q2INT)**PYR(0) + ELSEIF(MSTP(66).EQ.3) THEN + VINT(284)=Q0S*(Q1S/Q0S)**PYR(0) + ELSEIF(MSTP(66).GE.4) THEN + PS=0.25D0*VINT(4)**2 + VINT(284)=(Q0S+PS)*(Q1S+PS)/ + & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS + ENDIF + ENDIF + IF(MINT(121).GT.1) CALL PYSAVE(2,IGA) + +C...Format statements for differential cross-section maximum violations. + 5000 FORMAT(/1X,'Error: negative cross-section fraction',1P,D11.3,1X, + &'in event',1X,I7,'D0'/1X,'Execution stopped!') + 5100 FORMAT(1X,'ISUB = ',I3,'; Point of violation:'/1X,'tau =',1P, + &D11.3,', y* =',D11.3,', cthe = ',0P,F11.7,', tau'' =',1P,D11.3) + 5200 FORMAT(/1X,'Warning: negative cross-section fraction',1P,D11.3,1X, + &'in event',1X,I7) + 5300 FORMAT(/1X,'Error: maximum violated by',1P,D11.3,1X, + &'in event',1X,I7,'D0'/1X,'Execution stopped!') + 5400 FORMAT(/1X,'Advisory warning: maximum violated by',1P,D11.3,1X, + &'in event',1X,I7) + 5500 FORMAT(1X,'XSEC(',I1,',1) increased to',1P,D11.3) + 5600 FORMAT(1X,'XSEC(',I2,',1) increased to',1P,D11.3) + 5700 FORMAT(1X,'XSEC(',I3,',1) increased to',1P,D11.3) + 5800 FORMAT(1X,'XMAXUP(',I1,') increased to',1P,D11.3) + 5900 FORMAT(1X,'XMAXUP(',I2,') increased to',1P,D11.3) + 6000 FORMAT(1X,'XMAXUP(',I3,') increased to',1P,D11.3) + + RETURN + END + +C********************************************************************* + +C...PYSCAT +C...Finds outgoing flavours and event type; sets up the kinematics +C...and colour flow of the hard scattering + + SUBROUTINE PYSCAT + +C...Double precision and integer declarations + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Parameter statement for maximum size of showers. + PARAMETER (MAXNUR=1000) + +C...User process event common block. + INTEGER MAXNUP + PARAMETER (MAXNUP=500) + INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP + DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP + COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP), + &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP), + &VTIMUP(MAXNUP),SPINUP(MAXNUP) + SAVE /HEPEUP/ + +C...Commonblocks. + COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR) + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) + COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000) + COMMON/PYINT4/MWID(500),WIDS(500,5) + COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) + COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), + &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) + COMMON/PYTCSM/ITCM(0:99),RTCM(0:99) + COMMON/PYPUED/IUED(0:99),RUED(0:99) + SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/, + &/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYSSMT/, + &/PYTCSM/,/PYPUED/ +C...Local arrays and saved variables + DIMENSION WDTP(0:400),WDTE(0:400,0:5),PMQ(2),Z(2),CTHE(2), + &PHI(2),KUPPO(100),VINTSV(41:66),ILAB(100) + INTEGER IOKFLA(6),IIFLAV +C...UED related declarations: +C...equivalences between ordered particles (451->475) +C...and UED particle code (5 000 000 + id) + DIMENSION IUEDEQ(475),MUED(2) + DATA (IUEDEQ(I),I=451,475)/ + & 6100001,6100002,6100003,6100004,6100005,6100006, + & 5100001,5100002,5100003,5100004,5100005,5100006, + & 6100011,6100013,6100015, + & 5100012,5100011,5100014,5100013,5100016,5100015, + & 5100021,5100022,5100023,5100024/ + SAVE VINTSV + +C...Read out process + ISUB=MINT(1) + ISUBSV=ISUB + +C...Restore information for low-pT processes + IF(ISUB.EQ.95.AND.MINT(57).GE.1) THEN + DO 100 J=41,66 + 100 VINT(J)=VINTSV(J) + ENDIF + +C...Convert H' or A process into equivalent H one + IHIGG=1 + KFHIGG=25 + IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND. + &ISUB.LE.190)) THEN + IHIGG=2 + IF(MOD(ISUB-1,10).GE.5) IHIGG=3 + KFHIGG=33+IHIGG + IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3 + IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102 + IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103 + IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24 + IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26 + IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123 + IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124 + IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121 + IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122 + IF(ISUB.EQ.183.OR.ISUB.EQ.188) ISUB=111 + IF(ISUB.EQ.184.OR.ISUB.EQ.189) ISUB=112 + IF(ISUB.EQ.185.OR.ISUB.EQ.190) ISUB=113 + ENDIF + + IF(ISUB.EQ.401.OR.ISUB.EQ.402) KFHIGG=KFPR(ISUB,1) + +C...Convert bottomonium process into equivalent charmonium ones. + IF(ISUB.GE.461.AND.ISUB.LE.479) ISUB=ISUB-40 + +C...Choice of subprocess, number of documentation lines + IDOC=6+ISET(ISUB) + IF(ISUB.EQ.95) IDOC=8 + IF(ISET(ISUB).EQ.5) IDOC=9 + IF(ISET(ISUB).EQ.11) IDOC=4+NUP + MINT(3)=IDOC-6 + IF(IDOC.GE.9.AND.ISET(ISUB).LE.4) IDOC=IDOC+2 + MINT(4)=IDOC + IPU1=MINT(84)+1 + IPU2=MINT(84)+2 + IPU3=MINT(84)+3 + IPU4=MINT(84)+4 + IPU5=MINT(84)+5 + IPU6=MINT(84)+6 + +C...Reset K, P and V vectors. Store incoming particles + DO 120 JT=1,MSTP(126)+100 + I=MINT(83)+JT + IF(I.GT.MSTU(4)) GOTO 120 + DO 110 J=1,5 + K(I,J)=0 + P(I,J)=0D0 + V(I,J)=0D0 + 110 CONTINUE + 120 CONTINUE + DO 140 JT=1,2 + I=MINT(83)+JT + K(I,1)=21 + K(I,2)=MINT(10+JT) + DO 130 J=1,5 + P(I,J)=VINT(285+5*JT+J) + 130 CONTINUE + 140 CONTINUE + MINT(6)=2 + KFRES=0 + +C...Store incoming partons in their CM-frame. Save pdf value. + SH=VINT(44) + SHR=SQRT(SH) + SHP=VINT(26)*VINT(2) + SHPR=SQRT(SHP) + SHUSER=SHR + IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) SHUSER=SHPR + DO 150 JT=1,2 + I=MINT(84)+JT + K(I,1)=14 + K(I,2)=MINT(14+JT) + K(I,3)=MINT(83)+2+JT + P(I,3)=0.5D0*SHUSER*(-1D0)**(JT-1) + P(I,4)=0.5D0*SHUSER + IF(MINT(14+JT).GE.-40.AND.MINT(14+JT).LE.40) THEN + VINT(38+JT)=XSFX(JT,MINT(14+JT)) + ELSE + VINT(38+JT)=1D0 + ENDIF + 150 CONTINUE + +C...Copy incoming partons to documentation lines + DO 170 JT=1,2 + I1=MINT(83)+4+JT + I2=MINT(84)+JT + K(I1,1)=21 + K(I1,2)=K(I2,2) + K(I1,3)=I1-2 + DO 160 J=1,5 + P(I1,J)=P(I2,J) + 160 CONTINUE + 170 CONTINUE + +C...Choose new quark/lepton flavour for relevant annihilation graphs + IF(ISUB.EQ.12.OR.ISUB.EQ.53.OR.ISUB.EQ.54.OR.ISUB.EQ.58.OR. + &ISUB.EQ.314.OR.ISUB.EQ.319.OR.ISUB.EQ.316.OR. + &(ISUB.GE.135.AND.ISUB.LE.140).OR.ISUB.EQ.382.OR.ISUB.EQ.385) THEN + IGLGA=21 + IF(ISUB.EQ.58.OR.(ISUB.GE.137.AND.ISUB.LE.140)) IGLGA=22 + CALL PYWIDT(IGLGA,SH,WDTP,WDTE) + 180 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0) + DO 190 I=1,MDCY(IGLGA,3) + KFLF=KFDP(I+MDCY(IGLGA,2)-1,1) + RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4)) + IF(RKFL.LE.0D0) GOTO 200 + 190 CONTINUE + 200 CONTINUE + IF((ISUB.EQ.53.OR.ISUB.EQ.385.OR.ISUB.EQ.314.OR.ISUB.EQ.319 + & .OR.ISUB.EQ.316).AND.MINT(2).LE.2) THEN + IF(KFLF.GE.4) GOTO 180 + ELSEIF((ISUB.EQ.53.OR.ISUB.EQ.385.OR.ISUB.EQ.314.OR.ISUB.EQ.319. + & OR.ISUB.EQ.316).AND.MINT(2).LE.4) THEN + KFLF=4 + MINT(2)=MINT(2)-2 + ELSEIF(ISUB.EQ.53.OR.ISUB.EQ.385.OR.ISUB.EQ.314.OR.ISUB.EQ.319. + & OR.ISUB.EQ.316) THEN + KFLF=5 + MINT(2)=MINT(2)-4 + ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.1.AND.IABS(MINT(15)).LE.2 + & .AND.IABS(KFLF).GE.3) THEN + FACQQB=VINT(58)**2*4D0/9D0*(VINT(45)**2+VINT(46)**2)/ + & VINT(44)**2 + FACCIB=VINT(46)**2/RTCM(41)**4 + IF(FACQQB/(FACQQB+FACCIB).LT.PYR(0)) GOTO 180 + ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.5.AND.MINT(2).EQ.2) THEN + KFLF=5 + MINT(2)=1 + ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.5.AND.MINT(2).EQ.1) THEN + IF(KFLF.EQ.5) GOTO 180 + ELSEIF(ISUB.EQ.54.OR.ISUB.EQ.135.OR.ISUB.EQ.136) THEN + IF((KCHG(PYCOMP(KFLF),1)/2D0)**2.LT.PYR(0)) GOTO 180 + ELSEIF(ISUB.EQ.58.OR.(ISUB.GE.137.AND.ISUB.LE.140)) THEN + IF((KCHG(PYCOMP(KFLF),1)/3D0)**2.LT.PYR(0)) GOTO 180 + ENDIF + ENDIF + +C...Final state flavours and colour flow: default values + JS=1 + MINT(21)=MINT(15) + MINT(22)=MINT(16) + MINT(23)=0 + MINT(24)=0 + KCC=20 + KCS=ISIGN(1,MINT(15)) + + IF(ISET(ISUB).EQ.11) THEN +C...User-defined processes: find products + MINT(3)=0 + DO 210 IUP=3,NUP + IF(ISTUP(IUP).LT.1.OR.ISTUP(IUP).GT.3) THEN + ELSEIF(NUP.EQ.5.AND.IUP.GE.4.AND.MOTHUP(1,4).EQ.3) THEN + MINT(21+IUP)=IDUP(IUP) + ELSEIF(ISTUP(IUP).EQ.1.AND.(ISTUP(MOTHUP(1,IUP)).EQ.2.OR. + & ISTUP(MOTHUP(1,IUP)).EQ.3).AND.IDUP(MOTHUP(1,IUP)).NE.0) THEN + ELSEIF(IDUP(IUP).EQ.0) THEN + ELSE + MINT(3)=MINT(3)+1 + IF(MINT(3).LE.6) MINT(20+MINT(3))=IDUP(IUP) + ENDIF + 210 CONTINUE + + ELSEIF(ISUB.LE.10) THEN + IF(ISUB.EQ.1) THEN +C...f + fbar -> gamma*/Z0 + KFRES=23 + + ELSEIF(ISUB.EQ.2) THEN +C...f + fbar' -> W+/- + KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) + KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) + KFRES=ISIGN(24,KCH1+KCH2) + + ELSEIF(ISUB.EQ.3) THEN +C...f + fbar -> h0 (or H0, or A0) + KFRES=KFHIGG + + ELSEIF(ISUB.EQ.4) THEN +C...gamma + W+/- -> W+/- + + ELSEIF(ISUB.EQ.5) THEN +C...Z0 + Z0 -> h0 + XH=SH/SHP + MINT(21)=MINT(15) + MINT(22)=MINT(16) + PMQ(1)=PYMASS(MINT(21)) + PMQ(2)=PYMASS(MINT(22)) + 220 JT=INT(1.5D0+PYR(0)) + ZMIN=2D0*PMQ(JT)/SHPR + ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/ + & (SHPR*(SHPR-PMQ(3-JT))) + ZMAX=MIN(1D0-XH,ZMAX) + Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0) + IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT. + & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 220 + SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP) + IF(SQC1.LT.1D-8) GOTO 220 + C1=SQRT(SQC1) + C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP) + CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1 + CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT))) + Z(3-JT)=1D0-XH/(1D0-Z(JT)) + SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP) + IF(SQC1.LT.1D-8) GOTO 220 + C1=SQRT(SQC1) + C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP) + CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1 + CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT))) + PHIR=PARU(2)*PYR(0) + CPHI=COS(PHIR) + ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)* + & SQRT(1D0-CTHE(2)**2)*CPHI + Z1=2D0-Z(JT) + Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP) + Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP + Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)* + & PMQ(3-JT)**2/SHP)) + ZMIN=2D0*PMQ(3-JT)/SHPR + ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT))) + ZMAX=MIN(1D0-XH,ZMAX) + IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 220 + KCC=22 + KFRES=25 + + ELSEIF(ISUB.EQ.6) THEN +C...Z0 + W+/- -> W+/- + + ELSEIF(ISUB.EQ.7) THEN +C...W+ + W- -> Z0 + + ELSEIF(ISUB.EQ.8) THEN +C...W+ + W- -> h0 + XH=SH/SHP + 230 DO 260 JT=1,2 + I=MINT(14+JT) + IA=IABS(I) + IF(IA.LE.10) THEN + RVCKM=VINT(180+I)*PYR(0) + DO 240 J=1,MSTP(1) + IB=2*J-1+MOD(IA,2) + IPM=(5-ISIGN(1,I))/2 + IDC=J+MDCY(IA,2)+2 + IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 240 + MINT(20+JT)=ISIGN(IB,I) + RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2) + IF(RVCKM.LE.0D0) GOTO 250 + 240 CONTINUE + ELSE + IB=2*((IA+1)/2)-1+MOD(IA,2) + MINT(20+JT)=ISIGN(IB,I) + ENDIF + 250 PMQ(JT)=PYMASS(MINT(20+JT)) + 260 CONTINUE + JT=INT(1.5D0+PYR(0)) + ZMIN=2D0*PMQ(JT)/SHPR + ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/ + & (SHPR*(SHPR-PMQ(3-JT))) + ZMAX=MIN(1D0-XH,ZMAX) + IF(ZMIN.GE.ZMAX) GOTO 230 + Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0) + IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT. + & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 230 + SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP) + IF(SQC1.LT.1D-8) GOTO 230 + C1=SQRT(SQC1) + C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP) + CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1 + CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT))) + Z(3-JT)=1D0-XH/(1D0-Z(JT)) + SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP) + IF(SQC1.LT.1D-8) GOTO 230 + C1=SQRT(SQC1) + C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP) + CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1 + CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT))) + PHIR=PARU(2)*PYR(0) + CPHI=COS(PHIR) + ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)* + & SQRT(1D0-CTHE(2)**2)*CPHI + Z1=2D0-Z(JT) + Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP) + Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP + Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)* + & PMQ(3-JT)**2/SHP)) + ZMIN=2D0*PMQ(3-JT)/SHPR + ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT))) + ZMAX=MIN(1D0-XH,ZMAX) + IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 230 + KCC=22 + KFRES=25 + + ELSEIF(ISUB.EQ.10) THEN +C...f + f' -> f + f' (gamma/Z/W exchange); th = (p(f)-p(f))**2 + IF(MINT(2).EQ.1) THEN + KCC=22 + ELSE +C...W exchange: need to mix flavours according to CKM matrix + DO 280 JT=1,2 + I=MINT(14+JT) + IA=IABS(I) + IF(IA.LE.10) THEN + RVCKM=VINT(180+I)*PYR(0) + DO 270 J=1,MSTP(1) + IB=2*J-1+MOD(IA,2) + IPM=(5-ISIGN(1,I))/2 + IDC=J+MDCY(IA,2)+2 + IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 270 + MINT(20+JT)=ISIGN(IB,I) + RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2) + IF(RVCKM.LE.0D0) GOTO 280 + 270 CONTINUE + ELSE + IB=2*((IA+1)/2)-1+MOD(IA,2) + MINT(20+JT)=ISIGN(IB,I) + ENDIF + 280 CONTINUE + KCC=22 + ENDIF + ENDIF + + ELSEIF(ISUB.LE.20) THEN + IF(ISUB.EQ.11) THEN +C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2 + KCC=MINT(2) + IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2 + + ELSEIF(ISUB.EQ.12) THEN +C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2 + MINT(21)=ISIGN(KFLF,MINT(15)) + MINT(22)=-MINT(21) + KCC=4 + + ELSEIF(ISUB.EQ.13) THEN +C...f + fbar -> g + g; th arbitrary + MINT(21)=21 + MINT(22)=21 + KCC=MINT(2)+4 + + ELSEIF(ISUB.EQ.14) THEN +C...f + fbar -> g + gamma; th arbitrary + IF(PYR(0).GT.0.5D0) JS=2 + MINT(20+JS)=21 + MINT(23-JS)=22 + KCC=17+JS + + ELSEIF(ISUB.EQ.15) THEN +C...f + fbar -> g + Z0; th arbitrary + IF(PYR(0).GT.0.5D0) JS=2 + MINT(20+JS)=21 + MINT(23-JS)=23 + KCC=17+JS + + ELSEIF(ISUB.EQ.16) THEN +C...f + fbar' -> g + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2 + KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) + KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) + IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2 + MINT(20+JS)=21 + MINT(23-JS)=ISIGN(24,KCH1+KCH2) + KCC=17+JS + + ELSEIF(ISUB.EQ.17) THEN +C...f + fbar -> g + h0; th arbitrary + IF(PYR(0).GT.0.5D0) JS=2 + MINT(20+JS)=21 + MINT(23-JS)=25 + KCC=17+JS + + ELSEIF(ISUB.EQ.18) THEN +C...f + fbar -> gamma + gamma; th arbitrary + MINT(21)=22 + MINT(22)=22 + + ELSEIF(ISUB.EQ.19) THEN +C...f + fbar -> gamma + Z0; th arbitrary + IF(PYR(0).GT.0.5D0) JS=2 + MINT(20+JS)=22 + MINT(23-JS)=23 + + ELSEIF(ISUB.EQ.20) THEN +C...f + fbar' -> gamma + W+/-; th = (p(f)-p(W-))**2 or +C...(p(fbar')-p(W+))**2 + KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) + KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) + IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2 + MINT(20+JS)=22 + MINT(23-JS)=ISIGN(24,KCH1+KCH2) + ENDIF + + ELSEIF(ISUB.LE.30) THEN + IF(ISUB.EQ.21) THEN +C...f + fbar -> gamma + h0; th arbitrary + IF(PYR(0).GT.0.5D0) JS=2 + MINT(20+JS)=22 + MINT(23-JS)=25 + + ELSEIF(ISUB.EQ.22) THEN +C...f + fbar -> Z0 + Z0; th arbitrary + MINT(21)=23 + MINT(22)=23 + + ELSEIF(ISUB.EQ.23) THEN +C...f + fbar' -> Z0 + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2 + KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) + KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) + IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2 + MINT(20+JS)=23 + MINT(23-JS)=ISIGN(24,KCH1+KCH2) + + ELSEIF(ISUB.EQ.24) THEN +C...f + fbar -> Z0 + h0 (or H0, or A0); th arbitrary + IF(PYR(0).GT.0.5D0) JS=2 + MINT(20+JS)=23 + MINT(23-JS)=KFHIGG + + ELSEIF(ISUB.EQ.25) THEN +C...f + fbar -> W+ + W-; th = (p(f)-p(W-))**2 + MINT(21)=-ISIGN(24,MINT(15)) + MINT(22)=-MINT(21) + + ELSEIF(ISUB.EQ.26) THEN +C...f + fbar' -> W+/- + h0 (or H0, or A0); +C...th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2 + KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) + KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) + IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2 + MINT(20+JS)=ISIGN(24,KCH1+KCH2) + MINT(23-JS)=KFHIGG + + ELSEIF(ISUB.EQ.27) THEN +C...f + fbar -> h0 + h0 + + ELSEIF(ISUB.EQ.28) THEN +C...f + g -> f + g; th = (p(f)-p(f))**2 + IF(MINT(15).EQ.21) JS=2 + KCC=MINT(2)+6 + IF(MINT(15).EQ.21) KCC=KCC+2 + IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15)) + IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16)) + + ELSEIF(ISUB.EQ.29) THEN +C...f + g -> f + gamma; th = (p(f)-p(f))**2 + IF(MINT(15).EQ.21) JS=2 + MINT(23-JS)=22 + KCC=15+JS + KCS=ISIGN(1,MINT(14+JS)) + + ELSEIF(ISUB.EQ.30) THEN +C...f + g -> f + Z0; th = (p(f)-p(f))**2 + IF(MINT(15).EQ.21) JS=2 + MINT(23-JS)=23 + KCC=15+JS + KCS=ISIGN(1,MINT(14+JS)) + ENDIF + + ELSEIF(ISUB.LE.40) THEN + IF(ISUB.EQ.31) THEN +C...f + g -> f' + W+/-; th = (p(f)-p(f'))**2; choose flavour f' + IF(MINT(15).EQ.21) JS=2 + I=MINT(14+JS) + IA=IABS(I) + MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I) + RVCKM=VINT(180+I)*PYR(0) + DO 290 J=1,MSTP(1) + IB=2*J-1+MOD(IA,2) + IPM=(5-ISIGN(1,I))/2 + IDC=J+MDCY(IA,2)+2 + IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 290 + MINT(20+JS)=ISIGN(IB,I) + RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2) + IF(RVCKM.LE.0D0) GOTO 300 + 290 CONTINUE + 300 KCC=15+JS + KCS=ISIGN(1,MINT(14+JS)) + + ELSEIF(ISUB.EQ.32) THEN +C...f + g -> f + h0; th = (p(f)-p(f))**2 + IF(MINT(15).EQ.21) JS=2 + MINT(23-JS)=25 + KCC=15+JS + KCS=ISIGN(1,MINT(14+JS)) + + ELSEIF(ISUB.EQ.33) THEN +C...f + gamma -> f + g; th=(p(f)-p(f))**2 + IF(MINT(15).EQ.22) JS=2 + MINT(23-JS)=21 + KCC=24+JS + KCS=ISIGN(1,MINT(14+JS)) + + ELSEIF(ISUB.EQ.34) THEN +C...f + gamma -> f + gamma; th=(p(f)-p(f))**2 + IF(MINT(15).EQ.22) JS=2 + KCC=22 + KCS=ISIGN(1,MINT(14+JS)) + + ELSEIF(ISUB.EQ.35) THEN +C...f + gamma -> f + Z0; th=(p(f)-p(f))**2 + IF(MINT(15).EQ.22) JS=2 + MINT(23-JS)=23 + KCC=22 + + ELSEIF(ISUB.EQ.36) THEN +C...f + gamma -> f' + W+/-; th=(p(f)-p(f'))**2 + IF(MINT(15).EQ.22) JS=2 + I=MINT(14+JS) + IA=IABS(I) + MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I) + IF(IA.LE.10) THEN + RVCKM=VINT(180+I)*PYR(0) + DO 310 J=1,MSTP(1) + IB=2*J-1+MOD(IA,2) + IPM=(5-ISIGN(1,I))/2 + IDC=J+MDCY(IA,2)+2 + IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 310 + MINT(20+JS)=ISIGN(IB,I) + RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2) + IF(RVCKM.LE.0D0) GOTO 320 + 310 CONTINUE + ELSE + IB=2*((IA+1)/2)-1+MOD(IA,2) + MINT(20+JS)=ISIGN(IB,I) + ENDIF + 320 KCC=22 + + ELSEIF(ISUB.EQ.37) THEN +C...f + gamma -> f + h0 + + ELSEIF(ISUB.EQ.38) THEN +C...f + Z0 -> f + g + + ELSEIF(ISUB.EQ.39) THEN +C...f + Z0 -> f + gamma + + ELSEIF(ISUB.EQ.40) THEN +C...f + Z0 -> f + Z0 + ENDIF + + ELSEIF(ISUB.LE.50) THEN + IF(ISUB.EQ.41) THEN +C...f + Z0 -> f' + W+/- + + ELSEIF(ISUB.EQ.42) THEN +C...f + Z0 -> f + h0 + + ELSEIF(ISUB.EQ.43) THEN +C...f + W+/- -> f' + g + + ELSEIF(ISUB.EQ.44) THEN +C...f + W+/- -> f' + gamma + + ELSEIF(ISUB.EQ.45) THEN +C...f + W+/- -> f' + Z0 + + ELSEIF(ISUB.EQ.46) THEN +C...f + W+/- -> f' + W+/- + + ELSEIF(ISUB.EQ.47) THEN +C...f + W+/- -> f' + h0 + + ELSEIF(ISUB.EQ.48) THEN +C...f + h0 -> f + g + + ELSEIF(ISUB.EQ.49) THEN +C...f + h0 -> f + gamma + + ELSEIF(ISUB.EQ.50) THEN +C...f + h0 -> f + Z0 + ENDIF + + ELSEIF(ISUB.LE.60) THEN + IF(ISUB.EQ.51) THEN +C...f + h0 -> f' + W+/- + + ELSEIF(ISUB.EQ.52) THEN +C...f + h0 -> f + h0 + + ELSEIF(ISUB.EQ.53) THEN +C...g + g -> f + fbar; th arbitrary + KCS=(-1)**INT(1.5D0+PYR(0)) + MINT(21)=ISIGN(KFLF,KCS) + MINT(22)=-MINT(21) + KCC=MINT(2)+10 + + ELSEIF(ISUB.EQ.54) THEN +C...g + gamma -> f + fbar; th arbitrary + KCS=(-1)**INT(1.5D0+PYR(0)) + MINT(21)=ISIGN(KFLF,KCS) + MINT(22)=-MINT(21) + KCC=27 + IF(MINT(16).EQ.21) KCC=28 + + ELSEIF(ISUB.EQ.55) THEN +C...g + Z0 -> f + fbar + + ELSEIF(ISUB.EQ.56) THEN +C...g + W+/- -> f + fbar' + + ELSEIF(ISUB.EQ.57) THEN +C...g + h0 -> f + fbar + + ELSEIF(ISUB.EQ.58) THEN +C...gamma + gamma -> f + fbar; th arbitrary + KCS=(-1)**INT(1.5D0+PYR(0)) + MINT(21)=ISIGN(KFLF,KCS) + MINT(22)=-MINT(21) + KCC=21 + + ELSEIF(ISUB.EQ.59) THEN +C...gamma + Z0 -> f + fbar + + ELSEIF(ISUB.EQ.60) THEN +C...gamma + W+/- -> f + fbar' + ENDIF + + ELSEIF(ISUB.LE.70) THEN + IF(ISUB.EQ.61) THEN +C...gamma + h0 -> f + fbar + + ELSEIF(ISUB.EQ.62) THEN +C...Z0 + Z0 -> f + fbar + + ELSEIF(ISUB.EQ.63) THEN +C...Z0 + W+/- -> f + fbar' + + ELSEIF(ISUB.EQ.64) THEN +C...Z0 + h0 -> f + fbar + + ELSEIF(ISUB.EQ.65) THEN +C...W+ + W- -> f + fbar + + ELSEIF(ISUB.EQ.66) THEN +C...W+/- + h0 -> f + fbar' + + ELSEIF(ISUB.EQ.67) THEN +C...h0 + h0 -> f + fbar + + ELSEIF(ISUB.EQ.68) THEN +C...g + g -> g + g; th arbitrary + KCC=MINT(2)+12 + KCS=(-1)**INT(1.5D0+PYR(0)) + + ELSEIF(ISUB.EQ.69) THEN +C...gamma + gamma -> W+ + W-; th arbitrary + MINT(21)=24 + MINT(22)=-24 + KCC=21 + + ELSEIF(ISUB.EQ.70) THEN +C...gamma + W+/- -> Z0 + W+/-; th=(p(W)-p(W))**2 + IF(MINT(15).EQ.22) MINT(21)=23 + IF(MINT(16).EQ.22) MINT(22)=23 + KCC=21 + ENDIF + + ELSEIF(ISUB.LE.80) THEN + IF(ISUB.EQ.71.OR.ISUB.EQ.72) THEN +C...Z0 + Z0 -> Z0 + Z0; Z0 + Z0 -> W+ + W- + XH=SH/SHP + MINT(21)=MINT(15) + MINT(22)=MINT(16) + PMQ(1)=PYMASS(MINT(21)) + PMQ(2)=PYMASS(MINT(22)) + 330 JT=INT(1.5D0+PYR(0)) + ZMIN=2D0*PMQ(JT)/SHPR + ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/ + & (SHPR*(SHPR-PMQ(3-JT))) + ZMAX=MIN(1D0-XH,ZMAX) + Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0) + IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT. + & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 330 + SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP) + IF(SQC1.LT.1D-8) GOTO 330 + C1=SQRT(SQC1) + C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP) + CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1 + CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT))) + Z(3-JT)=1D0-XH/(1D0-Z(JT)) + SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP) + IF(SQC1.LT.1D-8) GOTO 330 + C1=SQRT(SQC1) + C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP) + CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1 + CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT))) + PHIR=PARU(2)*PYR(0) + CPHI=COS(PHIR) + ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)* + & SQRT(1D0-CTHE(2)**2)*CPHI + Z1=2D0-Z(JT) + Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP) + Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP + Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)* + & PMQ(3-JT)**2/SHP)) + ZMIN=2D0*PMQ(3-JT)/SHPR + ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT))) + ZMAX=MIN(1D0-XH,ZMAX) + IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 330 + KCC=22 + + ELSEIF(ISUB.EQ.73) THEN +C...Z0 + W+/- -> Z0 + W+/- + JS=MINT(2) + XH=SH/SHP + 340 JT=3-MINT(2) + I=MINT(14+JT) + IA=IABS(I) + IF(IA.LE.10) THEN + RVCKM=VINT(180+I)*PYR(0) + DO 350 J=1,MSTP(1) + IB=2*J-1+MOD(IA,2) + IPM=(5-ISIGN(1,I))/2 + IDC=J+MDCY(IA,2)+2 + IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 350 + MINT(20+JT)=ISIGN(IB,I) + RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2) + IF(RVCKM.LE.0D0) GOTO 360 + 350 CONTINUE + ELSE + IB=2*((IA+1)/2)-1+MOD(IA,2) + MINT(20+JT)=ISIGN(IB,I) + ENDIF + 360 PMQ(JT)=PYMASS(MINT(20+JT)) + MINT(23-JT)=MINT(17-JT) + PMQ(3-JT)=PYMASS(MINT(23-JT)) + JT=INT(1.5D0+PYR(0)) + ZMIN=2D0*PMQ(JT)/SHPR + ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/ + & (SHPR*(SHPR-PMQ(3-JT))) + ZMAX=MIN(1D0-XH,ZMAX) + IF(ZMIN.GE.ZMAX) GOTO 340 + Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0) + IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT. + & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 340 + SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP) + IF(SQC1.LT.1D-8) GOTO 340 + C1=SQRT(SQC1) + C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP) + CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1 + CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT))) + Z(3-JT)=1D0-XH/(1D0-Z(JT)) + SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP) + IF(SQC1.LT.1D-8) GOTO 340 + C1=SQRT(SQC1) + C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP) + CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1 + CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT))) + PHIR=PARU(2)*PYR(0) + CPHI=COS(PHIR) + ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)* + & SQRT(1D0-CTHE(2)**2)*CPHI + Z1=2D0-Z(JT) + Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP) + Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP + Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)* + & PMQ(3-JT)**2/SHP)) + ZMIN=2D0*PMQ(3-JT)/SHPR + ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT))) + ZMAX=MIN(1D0-XH,ZMAX) + IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 340 + KCC=22 + + ELSEIF(ISUB.EQ.74) THEN +C...Z0 + h0 -> Z0 + h0 + + ELSEIF(ISUB.EQ.75) THEN +C...W+ + W- -> gamma + gamma + + ELSEIF(ISUB.EQ.76.OR.ISUB.EQ.77) THEN +C...W+ + W- -> Z0 + Z0; W+ + W- -> W+ + W- + XH=SH/SHP + 370 DO 400 JT=1,2 + I=MINT(14+JT) + IA=IABS(I) + IF(IA.LE.10) THEN + RVCKM=VINT(180+I)*PYR(0) + DO 380 J=1,MSTP(1) + IB=2*J-1+MOD(IA,2) + IPM=(5-ISIGN(1,I))/2 + IDC=J+MDCY(IA,2)+2 + IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 380 + MINT(20+JT)=ISIGN(IB,I) + RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2) + IF(RVCKM.LE.0D0) GOTO 390 + 380 CONTINUE + ELSE + IB=2*((IA+1)/2)-1+MOD(IA,2) + MINT(20+JT)=ISIGN(IB,I) + ENDIF + 390 PMQ(JT)=PYMASS(MINT(20+JT)) + 400 CONTINUE + JT=INT(1.5D0+PYR(0)) + ZMIN=2D0*PMQ(JT)/SHPR + ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/ + & (SHPR*(SHPR-PMQ(3-JT))) + ZMAX=MIN(1D0-XH,ZMAX) + IF(ZMIN.GE.ZMAX) GOTO 370 + Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0) + IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT. + & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 370 + SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP) + IF(SQC1.LT.1D-8) GOTO 370 + C1=SQRT(SQC1) + C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP) + CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1 + CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT))) + Z(3-JT)=1D0-XH/(1D0-Z(JT)) + SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP) + IF(SQC1.LT.1D-8) GOTO 370 + C1=SQRT(SQC1) + C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP) + CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1 + CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT))) + PHIR=PARU(2)*PYR(0) + CPHI=COS(PHIR) + ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)* + & SQRT(1D0-CTHE(2)**2)*CPHI + Z1=2D0-Z(JT) + Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP) + Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP + Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)* + & PMQ(3-JT)**2/SHP)) + ZMIN=2D0*PMQ(3-JT)/SHPR + ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT))) + ZMAX=MIN(1D0-XH,ZMAX) + IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 370 + KCC=22 + + ELSEIF(ISUB.EQ.78) THEN +C...W+/- + h0 -> W+/- + h0 + + ELSEIF(ISUB.EQ.79) THEN +C...h0 + h0 -> h0 + h0 + + ELSEIF(ISUB.EQ.80) THEN +C...q + gamma -> q' + pi+/-; th=(p(q)-p(q'))**2 + IF(MINT(15).EQ.22) JS=2 + I=MINT(14+JS) + IA=IABS(I) + MINT(23-JS)=ISIGN(211,KCHG(IA,1)*I) + IB=3-IA + MINT(20+JS)=ISIGN(IB,I) + KCC=22 + ENDIF + + ELSEIF(ISUB.LE.90) THEN + IF(ISUB.EQ.81) THEN +C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2 + MINT(21)=ISIGN(MINT(55),MINT(15)) + MINT(22)=-MINT(21) + KCC=4 + + ELSEIF(ISUB.EQ.82) THEN +C...g + g -> Q + Qbar; th arbitrary + KCS=(-1)**INT(1.5D0+PYR(0)) + MINT(21)=ISIGN(MINT(55),KCS) + MINT(22)=-MINT(21) + KCC=MINT(2)+10 + + ELSEIF(ISUB.EQ.83) THEN +C...f + q -> f' + Q; th = (p(f) - p(f'))**2 + KFOLD=MINT(16) + IF(MINT(2).EQ.2) KFOLD=MINT(15) + KFAOLD=IABS(KFOLD) + IF(KFAOLD.GT.10) THEN + KFANEW=KFAOLD+2*MOD(KFAOLD,2)-1 + ELSE + RCKM=VINT(180+KFOLD)*PYR(0) + IPM=(5-ISIGN(1,KFOLD))/2 + KFANEW=-MOD(KFAOLD+1,2) + 410 KFANEW=KFANEW+2 + IDC=MDCY(KFAOLD,2)+(KFANEW+1)/2+2 + IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) THEN + IF(MOD(KFAOLD,2).EQ.0) RCKM=RCKM- + & VCKM(KFAOLD/2,(KFANEW+1)/2) + IF(MOD(KFAOLD,2).EQ.1) RCKM=RCKM- + & VCKM(KFANEW/2,(KFAOLD+1)/2) + ENDIF + IF(KFANEW.LE.6.AND.RCKM.GT.0D0) GOTO 410 + ENDIF + IF(MINT(2).EQ.1) THEN + MINT(21)=ISIGN(MINT(55),MINT(15)) + MINT(22)=ISIGN(KFANEW,MINT(16)) + ELSE + MINT(21)=ISIGN(KFANEW,MINT(15)) + MINT(22)=ISIGN(MINT(55),MINT(16)) + JS=2 + ENDIF + KCC=22 + + ELSEIF(ISUB.EQ.84) THEN +C...g + gamma -> Q + Qbar; th arbitary + KCS=(-1)**INT(1.5D0+PYR(0)) + MINT(21)=ISIGN(MINT(55),KCS) + MINT(22)=-MINT(21) + KCC=27 + IF(MINT(16).EQ.21) KCC=28 + + ELSEIF(ISUB.EQ.85) THEN +C...gamma + gamma -> F + Fbar; th arbitary + KCS=(-1)**INT(1.5D0+PYR(0)) + MINT(21)=ISIGN(MINT(56),KCS) + MINT(22)=-MINT(21) + KCC=21 + + ELSEIF(ISUB.GE.86.AND.ISUB.LE.89) THEN +C...g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g + MINT(21)=KFPR(ISUB,1) + MINT(22)=KFPR(ISUB,2) + KCC=24 + KCS=(-1)**INT(1.5D0+PYR(0)) + ENDIF + + ELSEIF(ISUB.LE.100) THEN + IF(ISUB.EQ.95) THEN +C...Low-pT ( = energyless g + g -> g + g) + KCC=MINT(2)+12 + KCS=(-1)**INT(1.5D0+PYR(0)) + + ELSEIF(ISUB.EQ.96) THEN +C...Multiple interactions (should be reassigned to QCD process) + ENDIF + + ELSEIF(ISUB.LE.110) THEN + IF(ISUB.EQ.101) THEN +C...g + g -> gamma*/Z0 + KCC=21 + KFRES=22 + + ELSEIF(ISUB.EQ.102) THEN +C...g + g -> h0 (or H0, or A0) + KCC=21 + KFRES=KFHIGG + + ELSEIF(ISUB.EQ.103) THEN +C...gamma + gamma -> h0 (or H0, or A0) + KCC=21 + KFRES=KFHIGG + + ELSEIF(ISUB.EQ.104.OR.ISUB.EQ.105) THEN +C...g + g -> chi_0c or chi_2c. + KCC=21 + KFRES=KFPR(ISUB,1) + + ELSEIF(ISUB.EQ.106) THEN +C...g + g -> J/Psi + gamma + MINT(21)=KFPR(ISUB,1) + MINT(22)=KFPR(ISUB,2) + KCC=21 + + ELSEIF(ISUB.EQ.107) THEN +C...g + gamma -> J/Psi + g + MINT(21)=KFPR(ISUB,1) + MINT(22)=KFPR(ISUB,2) + KCC=22 + IF(MINT(16).EQ.22) KCC=33 + + ELSEIF(ISUB.EQ.108) THEN +C...gamma + gamma -> J/Psi + gamma + MINT(21)=KFPR(ISUB,1) + MINT(22)=KFPR(ISUB,2) + + ELSEIF(ISUB.EQ.110) THEN +C...f + fbar -> gamma + h0; th arbitrary + IF(PYR(0).GT.0.5D0) JS=2 + MINT(20+JS)=22 + MINT(23-JS)=KFHIGG + ENDIF + + ELSEIF(ISUB.LE.120) THEN + IF(ISUB.EQ.111) THEN +C...f + fbar -> g + h0; th arbitrary + IF(PYR(0).GT.0.5D0) JS=2 + MINT(20+JS)=21 + MINT(23-JS)=KFHIGG + KCC=17+JS + + ELSEIF(ISUB.EQ.112) THEN +C...f + g -> f + h0; th = (p(f) - p(f))**2 + IF(MINT(15).EQ.21) JS=2 + MINT(23-JS)=KFHIGG + KCC=15+JS + KCS=ISIGN(1,MINT(14+JS)) + + ELSEIF(ISUB.EQ.113) THEN +C...g + g -> g + h0; th arbitrary + IF(PYR(0).GT.0.5D0) JS=2 + MINT(23-JS)=KFHIGG + KCC=22+JS + KCS=(-1)**INT(1.5D0+PYR(0)) + + ELSEIF(ISUB.EQ.114) THEN +C...g + g -> gamma + gamma; th arbitrary + IF(PYR(0).GT.0.5D0) JS=2 + MINT(21)=22 + MINT(22)=22 + KCC=21 + + ELSEIF(ISUB.EQ.115) THEN +C...g + g -> g + gamma; th arbitrary + IF(PYR(0).GT.0.5D0) JS=2 + MINT(23-JS)=22 + KCC=22+JS + KCS=(-1)**INT(1.5D0+PYR(0)) + + ELSEIF(ISUB.EQ.116) THEN +C...g + g -> gamma + Z0 + + ELSEIF(ISUB.EQ.117) THEN +C...g + g -> Z0 + Z0 + + ELSEIF(ISUB.EQ.118) THEN +C...g + g -> W+ + W- + ENDIF + + ELSEIF(ISUB.LE.140) THEN + IF(ISUB.EQ.121) THEN +C...g + g -> Q + Qbar + h0 + KCS=(-1)**INT(1.5D0+PYR(0)) + MINT(21)=ISIGN(KFPR(ISUBSV,2),KCS) + MINT(22)=-MINT(21) + KCC=11+INT(0.5D0+PYR(0)) + KFRES=KFHIGG + + ELSEIF(ISUB.EQ.122) THEN +C...q + qbar -> Q + Qbar + h0 + MINT(21)=ISIGN(KFPR(ISUBSV,2),MINT(15)) + MINT(22)=-MINT(21) + KCC=4 + KFRES=KFHIGG + + ELSEIF(ISUB.EQ.123) THEN +C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as +C...inner process) + KCC=22 + KFRES=KFHIGG + + ELSEIF(ISUB.EQ.124) THEN +C...f + f' -> f" + f"' + h0 (or H0, or A) (W+ + W- -> h0 as +C...inner process) + DO 430 JT=1,2 + I=MINT(14+JT) + IA=IABS(I) + IF(IA.LE.10) THEN + RVCKM=VINT(180+I)*PYR(0) + DO 420 J=1,MSTP(1) + IB=2*J-1+MOD(IA,2) + IPM=(5-ISIGN(1,I))/2 + IDC=J+MDCY(IA,2)+2 + IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 420 + MINT(20+JT)=ISIGN(IB,I) + RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2) + IF(RVCKM.LE.0D0) GOTO 430 + 420 CONTINUE + ELSE + IB=2*((IA+1)/2)-1+MOD(IA,2) + MINT(20+JT)=ISIGN(IB,I) + ENDIF + 430 CONTINUE + KCC=22 + KFRES=KFHIGG + + ELSEIF(ISUB.EQ.131.OR.ISUB.EQ.132) THEN +C...f + gamma*_(T,L) -> f + g; th=(p(f)-p(f))**2 + IF(MINT(15).EQ.22) JS=2 + MINT(23-JS)=21 + KCC=24+JS + KCS=ISIGN(1,MINT(14+JS)) + + ELSEIF(ISUB.EQ.133.OR.ISUB.EQ.134) THEN +C...f + gamma*_(T,L) -> f + gamma; th=(p(f)-p(f))**2 + IF(MINT(15).EQ.22) JS=2 + KCC=22 + KCS=ISIGN(1,MINT(14+JS)) + + ELSEIF(ISUB.EQ.135.OR.ISUB.EQ.136) THEN +C...g + gamma*_(T,L) -> f + fbar; th arbitrary + KCS=(-1)**INT(1.5D0+PYR(0)) + MINT(21)=ISIGN(KFLF,KCS) + MINT(22)=-MINT(21) + KCC=27 + IF(MINT(16).EQ.21) KCC=28 + + ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN +C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar; th arbitrary + KCS=(-1)**INT(1.5D0+PYR(0)) + MINT(21)=ISIGN(KFLF,KCS) + MINT(22)=-MINT(21) + KCC=21 + + ENDIF + + ELSEIF(ISUB.LE.160) THEN + IF(ISUB.EQ.141) THEN +C...f + fbar -> gamma*/Z0/Z'0 + KFRES=32 + + ELSEIF(ISUB.EQ.142) THEN +C...f + fbar' -> W'+/- + KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) + KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) + KFRES=ISIGN(34,KCH1+KCH2) + + ELSEIF(ISUB.EQ.143) THEN +C...f + fbar' -> H+/- + KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) + KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) + KFRES=ISIGN(37,KCH1+KCH2) + + ELSEIF(ISUB.EQ.144) THEN +C...f + fbar' -> R + KFRES=ISIGN(41,MINT(15)+MINT(16)) + + ELSEIF(ISUB.EQ.145) THEN +C...q + l -> LQ (leptoquark) + IF(IABS(MINT(16)).LE.8) JS=2 + KFRES=ISIGN(42,MINT(14+JS)) + KCC=28+JS + KCS=ISIGN(1,MINT(14+JS)) + + ELSEIF(ISUB.EQ.146) THEN +C...e + gamma -> e* (excited lepton) + IF(MINT(15).EQ.22) JS=2 + KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS)) + KCC=22 + + ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN +C...q + g -> q* (excited quark) + IF(MINT(15).EQ.21) JS=2 + KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS)) + KCC=30+JS + KCS=ISIGN(1,MINT(14+JS)) + + ELSEIF(ISUB.EQ.149) THEN +C...g + g -> eta_tc + KFRES=KTECHN+331 + KCC=23 + KCS=(-1)**INT(1.5D0+PYR(0)) + ENDIF + + ELSEIF(ISUB.LE.200) THEN + IF(ISUB.EQ.161) THEN +C...f + g -> f' + H+/-; th = (p(f)-p(f'))**2 + IF(MINT(15).EQ.21) JS=2 + I=MINT(14+JS) + IA=IABS(I) + MINT(23-JS)=ISIGN(37,KCHG(IA,1)*I) + IB=IA+MOD(IA,2)-MOD(IA+1,2) + MINT(20+JS)=ISIGN(IB,I) + KCC=15+JS + KCS=ISIGN(1,MINT(14+JS)) + + ELSEIF(ISUB.EQ.162) THEN +C...q + g -> LQ + lbar; LQ=leptoquark; th=(p(q)-p(LQ))^2 + IF(MINT(15).EQ.21) JS=2 + MINT(20+JS)=ISIGN(42,MINT(14+JS)) + KFLQL=KFDP(MDCY(42,2),2) + MINT(23-JS)=-ISIGN(KFLQL,MINT(14+JS)) + KCC=15+JS + KCS=ISIGN(1,MINT(14+JS)) + + ELSEIF(ISUB.EQ.163) THEN +C...g + g -> LQ + LQbar; LQ=leptoquark; th arbitrary + KCS=(-1)**INT(1.5D0+PYR(0)) + MINT(21)=ISIGN(42,KCS) + MINT(22)=-MINT(21) + KCC=MINT(2)+10 + + ELSEIF(ISUB.EQ.164) THEN +C...q + qbar -> LQ + LQbar; LQ=leptoquark; th=(p(q)-p(LQ))**2 + MINT(21)=ISIGN(42,MINT(15)) + MINT(22)=-MINT(21) + KCC=4 + + ELSEIF(ISUB.EQ.165) THEN +C...q + qbar -> l- + l+; th=(p(q)-p(l-))**2 + MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15)) + MINT(22)=-MINT(21) + + ELSEIF(ISUB.EQ.166) THEN +C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2 + IF(MOD(MINT(15),2).EQ.0) THEN + MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15)) + MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16)) + ELSE + MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15)) + MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16)) + ENDIF + + ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN +C...q + q' -> q" + q* (excited quark) + KFQSTR=KFPR(ISUB,2) + KFQEXC=MOD(KFQSTR,KEXCIT) + JS=MINT(2) + MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS)) + IF(IABS(MINT(15)).NE.KFQEXC.AND.IABS(MINT(16)).NE.KFQEXC) + & MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS)) + KCC=22 + JS=3-JS + + ELSEIF(ISUB.EQ.169) THEN +C...q + qbar -> e + e* (excited lepton) + KFQSTR=KFPR(ISUB,2) + KFQEXC=MOD(KFQSTR,KEXCIT) + JS=MINT(2) + MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS)) + MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS)) + JS=3-JS + + ELSEIF(ISUB.EQ.191) THEN +C...f + fbar -> rho_tc0. + KFRES=KTECHN+113 + + ELSEIF(ISUB.EQ.192) THEN +C...f + fbar' -> rho_tc+/- + KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) + KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) + KFRES=ISIGN(KTECHN+213,KCH1+KCH2) + + ELSEIF(ISUB.EQ.193) THEN +C...f + fbar -> omega_tc0. + KFRES=KTECHN+223 + + ELSEIF(ISUB.EQ.194) THEN +C...f + fbar -> f' + fbar' via mixture of s-channel +C...rho_tc and omega_tc; th=(p(f)-p(f'))**2 + MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15)) + MINT(22)=-MINT(21) + + ELSEIF(ISUB.EQ.195) THEN +C...f + fbar' -> f'' + fbar''' via s-channel +C...rho_tc+ th=(p(f)-p(f'))**2 +C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2 + IF(MOD(MINT(15),2).EQ.0) THEN + MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15)) + MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16)) + ELSE + MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15)) + MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16)) + ENDIF + ENDIF + +CMRENNA++ + ELSEIF(ISUB.LE.215) THEN + IF(ISUB.EQ.201) THEN +C...f + fbar -> ~e_L + ~e_Lbar + MINT(21)=ISIGN(KSUSY1+11,KCS) + MINT(22)=-MINT(21) + + ELSEIF(ISUB.EQ.202) THEN +C...f + fbar -> ~e_R + ~e_Rbar + MINT(21)=ISIGN(KSUSY2+11,KCS) + MINT(22)=-MINT(21) + + ELSEIF(ISUB.EQ.203) THEN +C...f + fbar -> ~e_L + ~e_Rbar + IF(MINT(15).LT.0) JS=2 + IF(MINT(2).EQ.1) THEN + MINT(20+JS)=KFPR(ISUB,1) + MINT(23-JS)=-KFPR(ISUB,2) + ELSE + MINT(20+JS)=-KFPR(ISUB,1) + MINT(23-JS)=KFPR(ISUB,2) + ENDIF + + ELSEIF(ISUB.EQ.204) THEN +C...f + fbar -> ~mu_L + ~mu_Lbar + MINT(21)=ISIGN(KSUSY1+13,KCS) + MINT(22)=-MINT(21) + + ELSEIF(ISUB.EQ.205) THEN +C...f + fbar -> ~mu_R + ~mu_Rbar + MINT(21)=ISIGN(KSUSY2+13,KCS) + MINT(22)=-MINT(21) + + ELSEIF(ISUB.EQ.206) THEN +C...f + fbar -> ~mu_L + ~mu_Rbar + IF(MINT(15).LT.0) JS=2 + IF(MINT(2).EQ.1) THEN + MINT(20+JS)=KFPR(ISUB,1) + MINT(23-JS)=-KFPR(ISUB,2) + ELSE + MINT(20+JS)=-KFPR(ISUB,1) + MINT(23-JS)=KFPR(ISUB,2) + ENDIF + + ELSEIF(ISUB.EQ.207) THEN +C...f + fbar -> ~tau_1 + ~tau_1bar + MINT(21)=ISIGN(KSUSY1+15,KCS) + MINT(22)=-MINT(21) + + ELSEIF(ISUB.EQ.208) THEN +C...f + fbar -> ~tau_2 + ~tau_2bar + MINT(21)=ISIGN(KSUSY2+15,KCS) + MINT(22)=-MINT(21) + + ELSEIF(ISUB.EQ.209) THEN +C...f + fbar -> ~tau_1 + ~tau_2bar + IF(MINT(15).LT.0) JS=2 + IF(MINT(2).EQ.1) THEN + MINT(20+JS)=KFPR(ISUB,1) + MINT(23-JS)=-KFPR(ISUB,2) + ELSE + MINT(20+JS)=-KFPR(ISUB,1) + MINT(23-JS)=KFPR(ISUB,2) + ENDIF + + ELSEIF(ISUB.EQ.210) THEN +C...q + qbar' -> ~l_L + ~nulbar; th arbitrary + KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) + KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) + MINT(21)=-ISIGN(KFPR(ISUB,1),KCH1+KCH2) + MINT(22)=ISIGN(KFPR(ISUB,2),KCH1+KCH2) + + ELSEIF(ISUB.EQ.211) THEN +C...q + qbar'-> ~tau_1 + ~nutaubar; th arbitrary + KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) + KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) + MINT(21)=-ISIGN(KSUSY1+15,KCH1+KCH2) + MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2) + + ELSEIF(ISUB.EQ.212) THEN +C...q + qbar'-> ~tau_2 + ~nutaubar; th arbitrary + KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) + KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) + MINT(21)=-ISIGN(KSUSY2+15,KCH1+KCH2) + MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2) + + ELSEIF(ISUB.EQ.213) THEN +C...f + fbar -> ~nul + ~nulbar + MINT(21)=ISIGN(KFPR(ISUB,1),KCS) + MINT(22)=-MINT(21) + + ELSEIF(ISUB.EQ.214) THEN +C...f + fbar -> ~nutau + ~nutaubar + MINT(21)=ISIGN(KSUSY1+16,KCS) + MINT(22)=-MINT(21) + ENDIF + + ELSEIF(ISUB.LE.225) THEN + IF(ISUB.EQ.216) THEN +C...f + fbar -> ~chi01 + ~chi01 + MINT(21)=KSUSY1+22 + MINT(22)=KSUSY1+22 + + ELSEIF(ISUB.EQ.217) THEN +C...f + fbar -> ~chi02 + ~chi02 + MINT(21)=KSUSY1+23 + MINT(22)=KSUSY1+23 + + ELSEIF(ISUB.EQ.218 ) THEN +C...f + fbar -> ~chi03 + ~chi03 + MINT(21)=KSUSY1+25 + MINT(22)=KSUSY1+25 + + ELSEIF(ISUB.EQ.219 ) THEN +C...f + fbar -> ~chi04 + ~chi04 + MINT(21)=KSUSY1+35 + MINT(22)=KSUSY1+35 + + ELSEIF(ISUB.EQ.220 ) THEN +C...f + fbar -> ~chi01 + ~chi02 + IF(MINT(15).LT.0) JS=2 +C IF(PYR(0).GT.0.5D0) JS=2 + MINT(20+JS)=KSUSY1+22 + MINT(23-JS)=KSUSY1+23 + + ELSEIF(ISUB.EQ.221 ) THEN +C...f + fbar -> ~chi01 + ~chi03 + IF(MINT(15).LT.0) JS=2 +C IF(PYR(0).GT.0.5D0) JS=2 + MINT(20+JS)=KSUSY1+22 + MINT(23-JS)=KSUSY1+25 + + ELSEIF(ISUB.EQ.222) THEN +C...f + fbar -> ~chi01 + ~chi04 + IF(MINT(15).LT.0) JS=2 +C IF(PYR(0).GT.0.5D0) JS=2 + MINT(20+JS)=KSUSY1+22 + MINT(23-JS)=KSUSY1+35 + + ELSEIF(ISUB.EQ.223) THEN +C...f + fbar -> ~chi02 + ~chi03 + IF(MINT(15).LT.0) JS=2 +C IF(PYR(0).GT.0.5D0) JS=2 + MINT(20+JS)=KSUSY1+23 + MINT(23-JS)=KSUSY1+25 + + ELSEIF(ISUB.EQ.224) THEN +C...f + fbar -> ~chi02 + ~chi04 + IF(MINT(15).LT.0) JS=2 +C IF(PYR(0).GT.0.5D0) JS=2 + MINT(20+JS)=KSUSY1+23 + MINT(23-JS)=KSUSY1+35 + + ELSEIF(ISUB.EQ.225) THEN +C...f + fbar -> ~chi03 + ~chi04 + IF(MINT(15).LT.0) JS=2 +C IF(PYR(0).GT.0.5D0) JS=2 + MINT(20+JS)=KSUSY1+25 + MINT(23-JS)=KSUSY1+35 + ENDIF + + ELSEIF(ISUB.LE.236) THEN + IF(ISUB.EQ.226) THEN +C...f + fbar -> ~chi+-1 + ~chi-+1 +C...th=(p(q)-p(chi+))**2 or (p(qbar)-p(chi-))**2 + KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) + MINT(21)=ISIGN(KSUSY1+24,KCH1) + MINT(22)=-MINT(21) + + ELSEIF(ISUB.EQ.227) THEN +C...f + fbar -> ~chi+-2 + ~chi-+2 + KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) + MINT(21)=ISIGN(KSUSY1+37,KCH1) + MINT(22)=-MINT(21) + + ELSEIF(ISUB.EQ.228) THEN +C...f + fbar -> ~chi+-1 + ~chi-+2 +C...th=(p(q)-p(chi1+))**2 or th=(p(qbar)-p(chi1-))**2 +C...js=1 if pyr<.5, js=2 if pyr>.5 +C...if 15=q, 16=qbar and js=1, chi1+ + chi2-, th=(q-chi1+)**2 +C...if 15=qbar, 16=q and js=1, chi2- + chi1+, th=(q-chi1+)**2 +C...if 15=q, 16=qbar and js=2, chi1- + chi2+, th=(qbar-chi1-)**2 +C...if 15=qbar, 16=q and js=2, chi2+ + chi1-, th=(q-chi1-)**2 + KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) + KCH2=INT(1-KCH1)/2 + IF(MINT(2).EQ.1) THEN + MINT(21)= ISIGN(KSUSY1+24,KCH1) + MINT(22)= -ISIGN(KSUSY1+37,KCH1) +c IF(KCH2.EQ.0) JS=2 + ELSE + MINT(21)= ISIGN(KSUSY1+37,KCH1) + MINT(22)= -ISIGN(KSUSY1+24,KCH1) + JS=2 +c IF(KCH2.EQ.1) JS=2 + ENDIF + + ELSEIF(ISUB.EQ.229) THEN +C...q + qbar' -> ~chi01 + ~chi+-1 +C...th=(p(u)-p(chi+))**2 or (p(ubar)-p(chi-))**2 + KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) + KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) +C...CHECK THIS + IF(MOD(MINT(15),2).EQ.0) JS=2 + MINT(20+JS)=KSUSY1+22 + MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2) + + ELSEIF(ISUB.EQ.230) THEN +C...q + qbar' -> ~chi02 + ~chi+-1 + KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) + KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) + IF(MOD(MINT(15),2).EQ.0) JS=2 + MINT(20+JS)=KSUSY1+23 + MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2) + + ELSEIF(ISUB.EQ.231) THEN +C...q + qbar' -> ~chi03 + ~chi+-1 + KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) + KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) + IF(MOD(MINT(15),2).EQ.0) JS=2 + MINT(20+JS)=KSUSY1+25 + MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2) + + ELSEIF(ISUB.EQ.232) THEN +C...q + qbar' -> ~chi04 + ~chi+-1 + KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) + KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) + IF(MOD(MINT(15),2).EQ.0) JS=2 + MINT(20+JS)=KSUSY1+35 + MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2) + + ELSEIF(ISUB.EQ.233) THEN +C...q + qbar' -> ~chi01 + ~chi+-2 + KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) + KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) + IF(MOD(MINT(15),2).EQ.0) JS=2 + MINT(20+JS)=KSUSY1+22 + MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2) + + ELSEIF(ISUB.EQ.234) THEN +C...q + qbar' -> ~chi02 + ~chi+-2 + KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) + KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) + IF(MOD(MINT(15),2).EQ.0) JS=2 + MINT(20+JS)=KSUSY1+23 + MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2) + + ELSEIF(ISUB.EQ.235) THEN +C...q + qbar' -> ~chi03 + ~chi+-2 + KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) + KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) + IF(MOD(MINT(15),2).EQ.0) JS=2 + MINT(20+JS)=KSUSY1+25 + MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2) + + ELSEIF(ISUB.EQ.236) THEN +C...q + qbar' -> ~chi04 + ~chi+-2 + KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) + KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) + IF(MOD(MINT(15),2).EQ.0) JS=2 + MINT(20+JS)=KSUSY1+35 + MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2) + ENDIF + + ELSEIF(ISUB.LE.245) THEN + IF(ISUB.EQ.237) THEN +C...q + qbar -> ~chi01 + ~g +C...th arbitrary + IF(PYR(0).GT.0.5D0) JS=2 + MINT(20+JS)=KSUSY1+21 + MINT(23-JS)=KSUSY1+22 + KCC=17+JS + + ELSEIF(ISUB.EQ.238) THEN +C...q + qbar -> ~chi02 + ~g +C...th arbitrary + IF(PYR(0).GT.0.5D0) JS=2 + MINT(20+JS)=KSUSY1+21 + MINT(23-JS)=KSUSY1+23 + KCC=17+JS + + ELSEIF(ISUB.EQ.239) THEN +C...q + qbar -> ~chi03 + ~g +C...th arbitrary + IF(PYR(0).GT.0.5D0) JS=2 + MINT(20+JS)=KSUSY1+21 + MINT(23-JS)=KSUSY1+25 + KCC=17+JS + + ELSEIF(ISUB.EQ.240) THEN +C...q + qbar -> ~chi04 + ~g +C...th arbitrary + IF(PYR(0).GT.0.5D0) JS=2 + MINT(20+JS)=KSUSY1+21 + MINT(23-JS)=KSUSY1+35 + KCC=17+JS + + ELSEIF(ISUB.EQ.241) THEN +C...q + qbar' -> ~chi+-1 + ~g +C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+ +C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi- +C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi- +C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+ +C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2 + KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) + KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) + JS=1 + IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2 + MINT(20+JS)=KSUSY1+21 + MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2) + KCC=17+JS + + ELSEIF(ISUB.EQ.242) THEN +C...q + qbar' -> ~chi+-2 + ~g +C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+ +C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi- +C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi- +C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+ +C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2 + KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) + KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) + JS=1 + IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2 + MINT(20+JS)=KSUSY1+21 + MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2) + KCC=17+JS + + ELSEIF(ISUB.EQ.243) THEN +C...q + qbar -> ~g + ~g ; th arbitrary + MINT(21)=KSUSY1+21 + MINT(22)=KSUSY1+21 + KCC=MINT(2)+4 + + ELSEIF(ISUB.EQ.244) THEN +C...g + g -> ~g + ~g ; th arbitrary + KCC=MINT(2)+12 + KCS=(-1)**INT(1.5D0+PYR(0)) + MINT(21)=KSUSY1+21 + MINT(22)=KSUSY1+21 + ENDIF + + ELSEIF(ISUB.LE.260) THEN + IF(ISUB.EQ.246) THEN +C...qj + g -> ~qj_L + ~chi01 + IF(MINT(15).EQ.21) JS=2 + I=MINT(14+JS) + IA=IABS(I) + MINT(20+JS)=ISIGN(KSUSY1+IA,I) + MINT(23-JS)=KSUSY1+22 + KCC=15+JS + KCS=ISIGN(1,MINT(14+JS)) + + ELSEIF(ISUB.EQ.247) THEN +C...qj + g -> ~qj_R + ~chi01 + IF(MINT(15).EQ.21) JS=2 + I=MINT(14+JS) + IA=IABS(I) + MINT(20+JS)=ISIGN(KSUSY2+IA,I) + MINT(23-JS)=KSUSY1+22 + KCC=15+JS + KCS=ISIGN(1,MINT(14+JS)) + + ELSEIF(ISUB.EQ.248) THEN +C...qj + g -> ~qj_L + ~chi02 + IF(MINT(15).EQ.21) JS=2 + I=MINT(14+JS) + IA=IABS(I) + MINT(20+JS)=ISIGN(KSUSY1+IA,I) + MINT(23-JS)=KSUSY1+23 + KCC=15+JS + KCS=ISIGN(1,MINT(14+JS)) + + ELSEIF(ISUB.EQ.249) THEN +C...qj + g -> ~qj_R + ~chi02 + IF(MINT(15).EQ.21) JS=2 + I=MINT(14+JS) + IA=IABS(I) + MINT(20+JS)=ISIGN(KSUSY2+IA,I) + MINT(23-JS)=KSUSY1+23 + KCC=15+JS + KCS=ISIGN(1,MINT(14+JS)) + + ELSEIF(ISUB.EQ.250) THEN +C...qj + g -> ~qj_L + ~chi03 + IF(MINT(15).EQ.21) JS=2 + I=MINT(14+JS) + IA=IABS(I) + MINT(20+JS)=ISIGN(KSUSY1+IA,I) + MINT(23-JS)=KSUSY1+25 + KCC=15+JS + KCS=ISIGN(1,MINT(14+JS)) + + ELSEIF(ISUB.EQ.251) THEN +C...qj + g -> ~qj_R + ~chi03 + IF(MINT(15).EQ.21) JS=2 + I=MINT(14+JS) + IA=IABS(I) + MINT(20+JS)=ISIGN(KSUSY2+IA,I) + MINT(23-JS)=KSUSY1+25 + KCC=15+JS + KCS=ISIGN(1,MINT(14+JS)) + + ELSEIF(ISUB.EQ.252) THEN +C...qj + g -> ~qj_L + ~chi04 + IF(MINT(15).EQ.21) JS=2 + I=MINT(14+JS) + IA=IABS(I) + MINT(20+JS)=ISIGN(KSUSY1+IA,I) + MINT(23-JS)=KSUSY1+35 + KCC=15+JS + KCS=ISIGN(1,MINT(14+JS)) + + ELSEIF(ISUB.EQ.253) THEN +C...qj + g -> ~qj_R + ~chi04 + IF(MINT(15).EQ.21) JS=2 + I=MINT(14+JS) + IA=IABS(I) + MINT(20+JS)=ISIGN(KSUSY2+IA,I) + MINT(23-JS)=KSUSY1+35 + KCC=15+JS + KCS=ISIGN(1,MINT(14+JS)) + + ELSEIF(ISUB.EQ.254) THEN +C...qj + g -> ~qk_L + ~chi+-1 + IF(MINT(15).EQ.21) JS=2 + I=MINT(14+JS) + IA=IABS(I) + MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I) + IB=-IA+INT((IA+1)/2)*4-1 + MINT(20+JS)=ISIGN(KSUSY1+IB,I) + KCC=15+JS + KCS=ISIGN(1,MINT(14+JS)) + + ELSEIF(ISUB.EQ.255) THEN +C...qj + g -> ~qk_L + ~chi+-1 + IF(MINT(15).EQ.21) JS=2 + I=MINT(14+JS) + IA=IABS(I) + MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I) + IB=-IA+INT((IA+1)/2)*4-1 + MINT(20+JS)=ISIGN(KSUSY2+IB,I) + KCC=15+JS + KCS=ISIGN(1,MINT(14+JS)) + + ELSEIF(ISUB.EQ.256) THEN +C...qj + g -> ~qk_L + ~chi+-2 + IF(MINT(15).EQ.21) JS=2 + I=MINT(14+JS) + IA=IABS(I) + IB=-IA+INT((IA+1)/2)*4-1 + MINT(20+JS)=ISIGN(KSUSY1+IB,I) + MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I) + KCC=15+JS + KCS=ISIGN(1,MINT(14+JS)) + + ELSEIF(ISUB.EQ.257) THEN +C...qj + g -> ~qk_R + ~chi+-2 + IF(MINT(15).EQ.21) JS=2 + I=MINT(14+JS) + IA=IABS(I) + IB=-IA+INT((IA+1)/2)*4-1 + MINT(20+JS)=ISIGN(KSUSY2+IB,I) + MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I) + KCC=15+JS + KCS=ISIGN(1,MINT(14+JS)) + + ELSEIF(ISUB.EQ.258) THEN +C...qj + g -> ~qj_L + ~g + IF(MINT(15).EQ.21) JS=2 + I=MINT(14+JS) + IA=IABS(I) + MINT(20+JS)=ISIGN(KSUSY1+IA,I) + MINT(23-JS)=KSUSY1+21 + KCC=MINT(2)+6 + IF(JS.EQ.2) KCC=KCC+2 + KCS=ISIGN(1,I) + + ELSEIF(ISUB.EQ.259) THEN +C...qj + g -> ~qj_R + ~g + IF(MINT(15).EQ.21) JS=2 + I=MINT(14+JS) + IA=IABS(I) + MINT(20+JS)=ISIGN(KSUSY2+IA,I) + MINT(23-JS)=KSUSY1+21 + KCC=MINT(2)+6 + IF(JS.EQ.2) KCC=KCC+2 + KCS=ISIGN(1,I) + ENDIF + + ELSEIF(ISUB.LE.270) THEN + IF(ISUB.EQ.261) THEN +C...f + fbar -> ~t_1 + ~t_1bar; th = (p(q)-p(sq))**2 + ISGN=1 + IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1 + MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS) + MINT(22)=-MINT(21) +C...Correct color combination + IF(MINT(43).EQ.4) KCC=4 + + ELSEIF(ISUB.EQ.262) THEN +C...f + fbar -> ~t_2 + ~t_2bar; th = (p(q)-p(sq))**2 + ISGN=1 + IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1 + MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS) + MINT(22)=-MINT(21) +C...Correct color combination + IF(MINT(43).EQ.4) KCC=4 + + ELSEIF(ISUB.EQ.263) THEN +C...f + fbar -> ~t_1 + ~t_2bar; th = (p(q)-p(sq))**2 + IF((KCS.GT.0.AND.MINT(2).EQ.1).OR. + & (KCS.LT.0.AND.MINT(2).EQ.2)) THEN + MINT(21)=ISIGN(KFPR(ISUB,1),KCS) + MINT(22)=-ISIGN(KFPR(ISUB,2),KCS) + ELSE + JS=2 + MINT(21)=ISIGN(KFPR(ISUB,2),KCS) + MINT(22)=-ISIGN(KFPR(ISUB,1),KCS) + ENDIF +C...Correct color combination + IF(MINT(43).EQ.4) KCC=4 + + ELSEIF(ISUB.EQ.264) THEN +C...g + g -> ~t_1 + ~t_1bar; th arbitrary + KCS=(-1)**INT(1.5D0+PYR(0)) + MINT(21)=ISIGN(KFPR(ISUB,1),KCS) + MINT(22)=-MINT(21) + KCC=MINT(2)+10 + + ELSEIF(ISUB.EQ.265) THEN +C...g + g -> ~t_2 + ~t_2bar; th arbitrary + KCS=(-1)**INT(1.5D0+PYR(0)) + MINT(21)=ISIGN(KFPR(ISUB,1),KCS) + MINT(22)=-MINT(21) + KCC=MINT(2)+10 + ENDIF + + ELSEIF(ISUB.LE.301) THEN + IF(ISUB.EQ.271.OR.ISUB.EQ.281.OR.ISUB.EQ.291) THEN +C...qi + qj -> ~qi_L + ~qj_L + KCC=MINT(2) + IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2 + MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15)) + MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16)) + + ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.282.OR.ISUB.EQ.292) THEN +C...qi + qj -> ~qi_R + ~qj_R + KCC=MINT(2) + IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2 + MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15)) + MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16)) + + ELSEIF(ISUB.EQ.273.OR.ISUB.EQ.283.OR.ISUB.EQ.293) THEN +C...qi + qj -> ~qi_L + ~qj_R + MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15)) + MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16)) + KCC=MINT(2) + IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2 + + ELSEIF(ISUB.EQ.274.OR.ISUB.EQ.284) THEN +C...qi + qjbar -> ~qi_L + ~qj_Lbar; th = (p(f)-p(sf'))**2 + MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15)) + MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16)) + KCC=MINT(2) + IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2 + + ELSEIF(ISUB.EQ.275.OR.ISUB.EQ.285) THEN +C...qi + qjbar -> ~qi_R + ~qj_Rbar ; th = (p(f)-p(sf'))**2 + MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15)) + MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16)) + KCC=MINT(2) + IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2 + + ELSEIF(ISUB.EQ.276.OR.ISUB.EQ.286.OR.ISUB.EQ.296) THEN +C...qi + qjbar -> ~qi_L + ~qj_Rbar ; th = (p(f)-p(sf'))**2 + MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15)) + MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16)) + KCC=MINT(2) + IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2 + + ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.287) THEN +C...f + fbar -> ~qi_L + ~qi_Lbar ; th = (p(q)-p(sq))**2 + ISGN=1 + IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1 + MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS) + MINT(22)=-MINT(21) + IF(MINT(43).EQ.4) KCC=4 + + ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.288) THEN +C...f + fbar -> ~qi_R + ~qi_Rbar; th = (p(q)-p(sq))**2 + ISGN=1 + IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1 + MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS) + MINT(22)=-MINT(21) + IF(MINT(43).EQ.4) KCC=4 + + ELSEIF(ISUB.EQ.279.OR.ISUB.EQ.289) THEN +C...g + g -> ~qi_L + ~qi_Lbar ; th arbitrary +C...pure LL + RR + KCS=(-1)**INT(1.5D0+PYR(0)) + MINT(21)=ISIGN(KFPR(ISUB,1),KCS) + MINT(22)=-MINT(21) + KCC=MINT(2)+10 + + ELSEIF(ISUB.EQ.280.OR.ISUB.EQ.290) THEN +C...g + g -> ~qi_R + ~qi_Rbar ; th arbitrary + KCS=(-1)**INT(1.5D0+PYR(0)) + MINT(21)=ISIGN(KFPR(ISUB,1),KCS) + MINT(22)=-MINT(21) + KCC=MINT(2)+10 + + ELSEIF(ISUB.EQ.294) THEN +C...qj + g -> ~qj_L + ~g + IF(MINT(15).EQ.21) JS=2 + I=MINT(14+JS) + IA=IABS(I) + MINT(20+JS)=ISIGN(KSUSY1+IA,I) + MINT(23-JS)=KSUSY1+21 + KCC=MINT(2)+6 + IF(JS.EQ.2) KCC=KCC+2 + KCS=ISIGN(1,I) + + ELSEIF(ISUB.EQ.295) THEN +C...qj + g -> ~qj_R + ~g + IF(MINT(15).EQ.21) JS=2 + I=MINT(14+JS) + IA=IABS(I) + MINT(20+JS)=ISIGN(KSUSY2+IA,I) + MINT(23-JS)=KSUSY1+21 + KCC=MINT(2)+6 + IF(JS.EQ.2) KCC=KCC+2 + KCS=ISIGN(1,I) + + ELSEIF(ISUB.EQ.297.OR.ISUB.EQ.298) THEN +C...q + qbar' -> H+ + H0 + KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) + KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) + IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2 + MINT(20+JS)=ISIGN(37,KCH1+KCH2) + MINT(23-JS)=KFPR(ISUB,2) + ELSEIF(ISUB.EQ.299.OR.ISUB.EQ.300) THEN +C...f + fbar -> A0 + H0; th arbitrary + IF(PYR(0).GT.0.5D0) JS=2 + MINT(20+JS)=KFPR(ISUB,1) + MINT(23-JS)=KFPR(ISUB,2) + ELSEIF(ISUB.EQ.301) THEN +C...f + fbar -> H+ H- + MINT(21)=ISIGN(KFPR(ISUB,1),KCS) + MINT(22)=-MINT(21) + ENDIF +CMRENNA-- + ELSEIF(ISUB.LE.330) THEN + IF(ISUB.EQ.311)THEN +C...g + g -> g* + g* (UED) + KCC=MINT(2)+12 + KCS=(-1)**INT(1.5D0+PYR(0)) + MUED(1)=472 + MUED(2)=472 + MINT(21)=IUEDEQ(472) + MINT(22)=IUEDEQ(472) + ELSEIF(ISUB.EQ.312)THEN +C...q + g -> q*_D + g*, q*_S + g* +C...The two channels have the same cross section + KKFLMI=450 + IF(PYR(0).GT.0.5)KKFLMI=456 + IF(MINT(15).EQ.21) JS=2 + KCC=MINT(2)+6 + IF(MINT(15).EQ.21)KCC=KCC+2 + IF(MINT(15).NE.21)THEN + KCS=ISIGN(1,MINT(15)) + MUED(2)=472 + MUED(1)=KCS*(KKFLMI+IABS(MINT(15))) + MINT(22)=IUEDEQ(472) + MINT(21)=KCS*IUEDEQ(KKFLMI+IABS(MINT(15))) + ENDIF + IF(MINT(16).NE.21)THEN + KCS=ISIGN(1,MINT(16)) + MUED(2)=KCS*(KKFLMI+IABS(MINT(16))) + MUED(1)=472 + MINT(22)=KCS*IUEDEQ(KKFLMI+IABS(MINT(16))) + MINT(21)=IUEDEQ(472) + ENDIF + ELSEIF(ISUB.EQ.313)THEN +C...q + q' -> q*_D + q*_D',q*_S+q*_S' +C...The two channels have the same cross section + KKFLMI=450 + IF(PYR(0).GT.0.5)KKFLMI=456 + KCC=MINT(2) + IF(MINT(15).EQ.MINT(16))THEN + MUED(1)=SIGN(1,MINT(15))*(KKFLMI+IABS(MINT(15))) + MUED(2)=MINT(21) + MINT(21)=SIGN(1,MINT(15))*IUEDEQ(KKFLMI+IABS(MINT(15))) + MINT(22)=MINT(21) + ELSE + MUED(1)=SIGN(1,MINT(15))*(KKFLMI+IABS(MINT(15))) + MUED(2)=SIGN(1,MINT(16))*(KKFLMI+IABS(MINT(16))) + MINT(21)=SIGN(1,MINT(15))*IUEDEQ(KKFLMI+IABS(MINT(15))) + MINT(22)=SIGN(1,MINT(16))*IUEDEQ(KKFLMI+IABS(MINT(16))) + ENDIF + IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2 + ELSEIF(ISUB.EQ.314)THEN +C...g + g -> q*_D + q*_D_bar, q*_S + q*_S_bar +C...The two channels have the same cross section + KKFLMI=450 + IF(PYR(0).GT.0.5)KKFLMI=456 + KCS=(-1)**INT(1.5D0+PYR(0)) + XFLAOUT=PYR(0) + IF(XFLAOUT.LE.0.2)THEN + MUED(1)=ISIGN(1,KCS)*(KKFLMI+1) + MINT(21)=ISIGN(1,KCS)*IUEDEQ(KKFLMI+1) + ELSEIF(XFLAOUT.LE.0.4)THEN + MUED(1)=ISIGN(1,KCS)*(KKFLMI+2) + MINT(21)=ISIGN(1,KCS)*IUEDEQ(KKFLMI+2) + ELSEIF(XFLAOUT.LE.0.6)THEN + MUED(1)=ISIGN(1,KCS)*(KKFLMI+3) + MINT(21)=ISIGN(1,KCS)*IUEDEQ(KKFLMI+3) + ELSEIF(XFLAOUT.LE.0.8)THEN + MUED(1)=ISIGN(1,KCS)*(KKFLMI+4) + MINT(21)=ISIGN(1,KCS)*IUEDEQ(KKFLMI+4) + ELSE + MUED(1)=ISIGN(1,KCS)*(KKFLMI+5) + MINT(21)=ISIGN(1,KCS)*IUEDEQ(KKFLMI+5) + ENDIF + MINT(22)=-MINT(21) + MUED(2)=-MUED(1) + KCC=MINT(2)+10 + ELSEIF(ISUB.EQ.315)THEN +C...q + qbar -> q*_D + q*_D_bar, q*_S + q*_S_bar +C...The two channels have the same cross section + KKFLMI=450 + IF(PYR(0).GT.0.5)KKFLMI=456 + MUED(1)=ISIGN(1,MINT(15))*(KKFLMI+IABS(MINT(15))) + MUED(2)=-MINT(21) + MINT(21)=ISIGN(1,MINT(15))*IUEDEQ(KKFLMI+IABS(MINT(15))) + MINT(22)=-MINT(21) + KCC=4 + ELSEIF(ISUB.EQ.316)THEN +C...q + qbar' -> q*_D + q*_S_bar' + MUED(1)=ISIGN(1,MINT(15))*(456+IABS(MINT(15))) + MUED(2)=ISIGN(1,MINT(16))*(450+IABS(MINT(16))) + MINT(21)=ISIGN(1,MINT(15))*IUEDEQ(456+IABS(MINT(15))) + MINT(22)=ISIGN(1,MINT(16))*IUEDEQ(450+IABS(MINT(16))) + KCC=MINT(2)+2 + ELSEIF(ISUB.EQ.317)THEN +C...q + qbar' -> q*_D + q*_D_bar', q*_S + q*_S_bar +C...The two channels have the same cross section + KKFLMI=450 + IF(PYR(0).GT.0.5)KKFLMI=456 + MUED(1)=ISIGN(1,MINT(15))*(KKFLMI+IABS(MINT(15))) + MUED(2)=ISIGN(1,MINT(16))*(KKFLMI+IABS(MINT(16))) + MINT(21)=ISIGN(1,MINT(15))*IUEDEQ(KKFLMI+IABS(MINT(15))) + MINT(22)=ISIGN(1,MINT(16))*IUEDEQ(KKFLMI+IABS(MINT(16))) + KCC=MINT(2)+2 + ELSEIF(ISUB.EQ.318)THEN +C...q + q' -> q*_D + q*_S' + KCC=MINT(2) + MUED(1)=SIGN(1,MINT(15))*(456+IABS(MINT(15))) + MUED(2)=SIGN(1,MINT(16))*(450+IABS(MINT(16))) + MINT(21)=SIGN(1,MINT(15))*IUEDEQ(456+IABS(MINT(15))) + MINT(22)=SIGN(1,MINT(16))*IUEDEQ(450+IABS(MINT(16))) + ELSEIF(ISUB.EQ.319)THEN +C...q + qbar -> q*_D' + q*_D_bar', q*_S' + q*_S_bar' +C...The two channels have the same cross section + KKFLMI=450 + IF(PYR(0).GT.0.5)KKFLMI=456 + XFLAOUT=PYR(0) + IIFLAV=0 +C...N.B. NFLAVOURS=IUED(3) +C DO I=1,NFLAVOURS + DO 433 I=1,IUED(3) + IF(I.NE.IABS(MINT(15)))THEN + IIFLAV=IIFLAV+1 + IOKFLA(IIFLAV)=I + ENDIF + 433 CONTINUE + FLASTEP=1./(IUED(3)-1) + DO I=1,IUED(3)-1 + FLAVV=FLASTEP*I + IF(XFLAOUT.LE.FLAVV)THEN + MUED(1)=ISIGN(1,MINT(15))*(KKFLMI+IOKFLA(I)) + MINT(21)=ISIGN(1,MINT(15))*IUEDEQ(KKFLMI+IOKFLA(I)) + GOTO 435 + ENDIF + ENDDO + 435 CONTINUE + IF(IABS(MUED(1)).LT.451.AND.IABS(MUED(1)).GT.462)THEN + WRITE(MSTU(11),*) 'IN PYSCAT: KK FLAVORS PROBLEM !!!' + CALL PYSTOP(5000000) + ENDIF + MINT(22)=-MINT(21) + KCC=4 + ENDIF + + ELSEIF(ISUB.LE.360) THEN + + IF(ISUB.EQ.341.OR.ISUB.EQ.342) THEN +C...l + l -> H_L++/--, H_R++/-- + KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) + KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) + KFRES=ISIGN(KFPR(ISUB,1),KCH1+KCH2) + + ELSEIF(ISUB.GE.343.AND.ISUB.LE.348) THEN +C...l + gamma -> l' + H++/--; th=(p(l)-p(H))**2 + IF(MINT(15).EQ.22) JS=2 + MINT(20+JS)=ISIGN(KFPR(ISUB,1),-MINT(14+JS)) + MINT(23-JS)=ISIGN(KFPR(ISUB,2),-MINT(14+JS)) + KCC=22 + + ELSEIF(ISUB.EQ.349.OR.ISUB.EQ.350) THEN +C...f + fbar -> H++ + H--; th = (p(f)-p(H--))**2 + MINT(21)=-ISIGN(KFPR(ISUB,1),MINT(15)) + MINT(22)=-MINT(21) + + ELSEIF(ISUB.EQ.351.OR.ISUB.EQ.352) THEN +C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/-- +C...as inner process). + DO 450 JT=1,2 + I=MINT(14+JT) + IA=IABS(I) + IF(IA.LE.10) THEN + RVCKM=VINT(180+I)*PYR(0) + DO 440 J=1,MSTP(1) + IB=2*J-1+MOD(IA,2) + IPM=(5-ISIGN(1,I))/2 + IDC=J+MDCY(IA,2)+2 + IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 440 + MINT(20+JT)=ISIGN(IB,I) + RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2) + IF(RVCKM.LE.0D0) GOTO 450 + 440 CONTINUE + ELSE + IB=2*((IA+1)/2)-1+MOD(IA,2) + MINT(20+JT)=ISIGN(IB,I) + ENDIF + 450 CONTINUE + KCC=22 + KFRES=ISIGN(KFPR(ISUB,1),MINT(15)) + IF(MOD(MINT(15),2).EQ.1) KFRES=-KFRES + + ELSEIF(ISUB.EQ.353) THEN +C...f + fbar -> Z_R0 + KFRES=KFPR(ISUB,1) + + ELSEIF(ISUB.EQ.354) THEN +C...f + fbar' -> W+/- + KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) + KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) + KFRES=ISIGN(KFPR(ISUB,1),KCH1+KCH2) + + ENDIF + + ELSEIF(ISUB.LE.380) THEN + + IF(ISUB.LE.363.OR.ISUB.EQ.368) THEN +C...f + fbar -> charged+ charged- technicolor + KSW=(-1)**INT(1.5D0+PYR(0)) + MINT(21)=ISIGN(KFPR(ISUB,1),KSW) + MINT(22)=-ISIGN(KFPR(ISUB,2),KSW) + + ELSEIF(ISUB.LE.367.OR.ISUB.EQ.379.OR.ISUB.EQ.380) THEN +C...f + fbar -> neutral neutral technicolor + MINT(21)=KFPR(ISUB,1) + MINT(22)=KFPR(ISUB,2) + + ELSEIF(ISUB.EQ.374.OR.ISUB.EQ.375.OR.ISUB.EQ.378) THEN +C...f + fbar' -> neutral charged technicolor + IN=1 + IC=2 + KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) + KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) + IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2 + MINT(23-JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2) + MINT(20+JS)=KFPR(ISUB,IN) + + ELSEIF(ISUB.GE.370.AND.ISUB.LE.377) THEN +C...f + fbar' -> charged neutral technicolor + IN=2 + IC=1 + KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) + KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) + IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2 + MINT(20+JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2) + MINT(23-JS)=KFPR(ISUB,IN) + ENDIF + + ELSEIF(ISUB.LE.400) THEN + IF(ISUB.EQ.381) THEN +C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2, TC extensions + KCC=MINT(2) + IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2 + + ELSEIF(ISUB.EQ.382) THEN +C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2, TC extensions + MINT(21)=ISIGN(KFLF,MINT(15)) + MINT(22)=-MINT(21) + KCC=4 + + ELSEIF(ISUB.EQ.383) THEN +C...f + fbar -> g + g; th arbitrary, TC extensions + MINT(21)=21 + MINT(22)=21 + KCC=MINT(2)+4 + + ELSEIF(ISUB.EQ.384) THEN +C...f + g -> f + g; th = (p(f)-p(f))**2, TC extensions + IF(MINT(15).EQ.21) JS=2 + KCC=MINT(2)+6 + IF(MINT(15).EQ.21) KCC=KCC+2 + IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15)) + IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16)) + + ELSEIF(ISUB.EQ.385) THEN +C...g + g -> f + fbar; th arbitrary, TC extensions + KCS=(-1)**INT(1.5D0+PYR(0)) + MINT(21)=ISIGN(KFLF,KCS) + MINT(22)=-MINT(21) + KCC=MINT(2)+10 + + ELSEIF(ISUB.EQ.386) THEN +C...g + g -> g + g; th arbitrary, TC extensions + KCC=MINT(2)+12 + KCS=(-1)**INT(1.5D0+PYR(0)) + + ELSEIF(ISUB.EQ.387) THEN +C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2, TC extensions + MINT(21)=ISIGN(MINT(55),MINT(15)) + MINT(22)=-MINT(21) + KCC=4 + + ELSEIF(ISUB.EQ.388) THEN +C...g + g -> Q + Qbar; th arbitrary, TC extensions + KCS=(-1)**INT(1.5D0+PYR(0)) + MINT(21)=ISIGN(MINT(55),KCS) + MINT(22)=-MINT(21) + KCC=MINT(2)+10 + + ELSEIF(ISUB.EQ.391) THEN +C...f + fbar -> G*. + KFRES=KFPR(ISUB,1) + + ELSEIF(ISUB.EQ.392) THEN +C...g + g -> G*. + KCC=21 + KFRES=KFPR(ISUB,1) + + ELSEIF(ISUB.EQ.393) THEN +C...q + qbar -> g + G*; th arbitrary. + IF(PYR(0).GT.0.5D0) JS=2 + MINT(20+JS)=KFPR(ISUB,1) + MINT(23-JS)=KFPR(ISUB,2) + KCC=17+JS + + ELSEIF(ISUB.EQ.394) THEN +C...q + g -> q + G*; th = (p(f) - p(f))**2 + IF(MINT(15).EQ.21) JS=2 + MINT(23-JS)=KFPR(ISUB,2) + KCC=15+JS + KCS=ISIGN(1,MINT(14+JS)) + + ELSEIF(ISUB.EQ.395) THEN +C...g + g -> G* + g; th arbitrary. + IF(PYR(0).GT.0.5D0) JS=2 + MINT(23-JS)=KFPR(ISUB,2) + KCC=22+JS + ENDIF + + ELSEIF(ISUB.LE.420) THEN + IF(ISUB.EQ.401) THEN +C...g + g -> t + b + H+/- + KCS=(-1)**INT(1.5D0+PYR(0)) + MINT(21)=ISIGN(KFPR(ISUBSV,2),KCS) + MINT(22)=ISIGN(5,-KCS) + KCC=11+INT(0.5D0+PYR(0)) + KFRES=ISIGN(KFHIGG,-KCS) + + ELSEIF(ISUB.EQ.402) THEN +C...q + qbar -> t + b + H+/- + KFL=(-1)**INT(1.5D0+PYR(0)) + MINT(21)=ISIGN(INT(6.+.5*KFL),KCS) + MINT(22)=ISIGN(INT(6.-.5*KFL),-KCS) + KCC=4 + KFRES=ISIGN(KFHIGG,-KFL*KCS) + ENDIF + +C...QUARKONIA+++ +C...Additional code by Stefan Wolf + ELSEIF(ISUB.LE.430) THEN + IF(ISUB.GE.421.AND.ISUB.LE.424) THEN +C...g + g -> QQ~[n] + g +C...MINT(21), MINT(22) copied from ISUB.EQ.86-89 +C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g] +C...KCC and KCS copied from ISUB.EQ.86-89 (for ISUB.EQ.421) +C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g] +C...or from ISUB.EQ.68 (for ISUB.NE.421) +C...[g + g -> g + g; th arbitrary] + MINT(21)=KFPR(ISUBSV,1) + MINT(22)=KFPR(ISUBSV,2) + IF(ISUB.EQ.421) THEN + KCC=24 + KCS=(-1)**INT(1.5D0+PYR(0)) + ELSE + KCC=MINT(2)+12 + KCS=(-1)**INT(1.5D0+PYR(0)) + ENDIF + + ELSEIF(ISUB.GE.425.AND.ISUB.LE.427) THEN +C...q + g -> q + QQ~[n] +C...MINT(21), MINT(22) "copied" from ISUB.EQ.112 +C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)] +C...KCC copied from ISUB.EQ.28 +C...[f + g -> f + g; th = (p(f)-p(f))**2; (q + g -> q + g only)] + IF(MINT(15).EQ.21) JS=2 + MINT(23-JS)=KFPR(ISUBSV,2) + KCC=MINT(2)+6 + IF(MINT(15).EQ.21) KCC=KCC+2 + IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15)) + IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16)) + + ELSEIF(ISUB.GE.428.AND.ISUB.LE.430) THEN +C...q + q~ -> g + QQ~[n] +C...MINT(21), MINT(22) "copied" from ISUB.EQ.111 +C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)] +C...KCC copied from ISUB.EQ.13 +C...[f + fbar -> g + g; th arbitrary; (q + qbar -> g + g only)] + IF(PYR(0).GT.0.5) JS=2 + MINT(20+JS)=21 + MINT(23-JS)=KFPR(ISUBSV,2) + KCC=MINT(2)+4 + ENDIF + + ELSEIF(ISUB.LE.440) THEN + IF(ISUB.GE.431.AND.ISUB.LE.433) THEN +C...g + g -> QQ~[n] + g +C...MINT(21), MINT(22) copied from ISUB.EQ.86-89 +C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g] +C...KCC and KCS copied from ISUB.EQ.86-89 +C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g] + MINT(21)=KFPR(ISUBSV,1) + MINT(22)=KFPR(ISUBSV,2) + KCC=24 + KCS=(-1)**INT(1.5D0+PYR(0)) + + ELSEIF(ISUB.GE.434.AND.ISUB.LE.436) THEN +C...q + g -> q + QQ~[n] +C...MINT(21), MINT(22) "copied" from ISUB.EQ.112 +C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)] +C...KCC and KCS copied from ISUB.EQ.112 +C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)] + IF(MINT(15).EQ.21) JS=2 + MINT(23-JS)=KFPR(ISUBSV,2) + KCC=15+JS + KCS=ISIGN(1,MINT(14+JS)) + + ELSEIF(ISUB.GE.437.AND.ISUB.LE.439) THEN +C...q + q~ -> g + QQ~[n] +C...MINT(21), MINT(22) "copied" from ISUB.EQ.111 +C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)] +C...KCC copied from ISUB.EQ.111 +C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)] + IF(PYR(0).GT.0.5) JS=2 + MINT(20+JS)=21 + MINT(23-JS)=KFPR(ISUBSV,2) + KCC=17+JS +C...QUARKONIA--- + ENDIF + ELSEIF(ISUB.LE.500) THEN + IF(ISUB.EQ.481.OR.ISUB.EQ.482) THEN + KFRES=9900001 + KCRES=PYCOMP(KFRES) + MCOL=KCHG(KCRES,2) + MCHG=KCHG(KCRES,1) + IF(KCRES.EQ.0) + $ CALL PYERRM(21,"No resonance for Generic 2-> 2 Process") + IDCY=MDCY(KCRES,2) + IF(IDCY.EQ.0) + $ CALL PYERRM(21,"No decays for resonance in Generic 2->2") + KCI1=PYCOMP(MINT(15)) + KCI2=PYCOMP(MINT(16)) + ICOL1=ISIGN(KCHG(KCI1,2),MINT(15)) + ICOL2=ISIGN(KCHG(KCI2,2),MINT(16)) + KFF1=KFPR(ISUB,1) + KFF2=KFPR(ISUB,2) + KCF1=PYCOMP(KFF1) + KCF2=PYCOMP(KFF2) + JCOL1=SIGN(KCHG(KCF1,2),KFF1) + IF(JCOL1.EQ.-2) JCOL1=2 + JCOL2=SIGN(KCHG(KCF2,2),KFF2) + IF(JCOL2.EQ.-2) JCOL2=2 + KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) + KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) + KCHW=KCH1+KCH2 + KREL=1 + IF(MCHG.NE.0.AND.KCHW.EQ.-MCHG) KREL=-1 + IF(KCHG(KCF1,3).NE.0) KFF1=KFF1*KREL + IF(KCHG(KCF2,3).NE.0) KFF2=KFF2*KREL + IF(JCOL1.EQ.1.OR.JCOL1.EQ.-1) JCOL1=JCOL1*KREL + IF(JCOL2.EQ.1.OR.JCOL2.EQ.-1) JCOL2=JCOL2*KREL + IF((ICOL1.EQ.1.AND.ICOL2.EQ.-1).OR. + $ (ICOL2.EQ.1.AND.ICOL1.EQ.-1)) THEN + IF(PYR(0).GT.0.5D0) JS=2 + MINT(20+JS)=KFF1 + MINT(23-JS)=KFF2 + IF(JCOL1.EQ.0.AND.JCOL2.EQ.0) THEN + + ELSEIF(JCOL1.EQ.0.AND.JCOL2.EQ.2) THEN + KCC=17+JS + MINT(20+JS)=KFF2 + MINT(23-JS)=KFF1 + ELSEIF(JCOL1.EQ.2.AND.JCOL2.EQ.0) THEN + KCC=17+JS + MINT(20+JS)=KFF1 + MINT(23-JS)=KFF2 + ELSEIF(JCOL1.EQ.2.AND.JCOL2.EQ.2.AND.MCOL.EQ.0) THEN + + ELSEIF(JCOL1.EQ.2.AND.JCOL2.EQ.2) THEN + KCC=MINT(2)+4 + ELSEIF((JCOL1.EQ.1.AND.JCOL2.EQ.-1).OR. + $ (JCOL1.EQ.-1.AND.JCOL2.EQ.1)) THEN + IF(ICOL1.EQ.JCOL1) THEN + JS=1 + MINT(21)=KFF1 + MINT(22)=KFF2 + ELSE + JS=2 + MINT(21)=KFF2 + MINT(22)=KFF1 + ENDIF + IF(MCOL.EQ.0) THEN + + ELSE + KCC=4 + ENDIF + ENDIF + ELSEIF((ICOL1.EQ.2.AND.(ICOL2.EQ.1.OR.ICOL2.EQ.-1)).OR. + $ (ICOL2.EQ.2.AND.(ICOL1.EQ.1.OR.ICOL1.EQ.-1))) THEN + IF((JCOL1.EQ.2.AND.ABS(JCOL2).EQ.1).OR. + $ (JCOL2.EQ.2.AND.ABS(JCOL1).EQ.1)) THEN + IF(MINT(15).EQ.21) JS=2 + KCC=MINT(2)+6 + IF(MINT(15).EQ.21) KCC=KCC+2 + IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15)) + IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16)) + IF(JCOL1.EQ.2) THEN + MINT(20+JS)=KFF2 + MINT(23-JS)=KFF1 + ELSE + MINT(20+JS)=KFF1 + MINT(23-JS)=KFF2 + ENDIF + ELSEIF((ABS(JCOL1).EQ.1.AND.JCOL2.EQ.0).OR. + $ (ABS(JCOL2).EQ.1.AND.JCOL1.EQ.0)) THEN + IF(MINT(15).EQ.21) JS=2 + KCC=15+JS + KCS=ISIGN(1,MINT(14+JS)) + IF(JCOL1.EQ.0) THEN + MINT(23-JS)=KFF1 + MINT(20+JS)=KFF2 + ELSE + MINT(23-JS)=KFF2 + MINT(20+JS)=KFF1 + ENDIF + ENDIF + ELSEIF(ICOL1.EQ.2.AND.ICOL2.EQ.2.AND. + $ JCOL1.EQ.0.AND.JCOL2.EQ.0) THEN + IF(PYR(0).GT.0.5D0) JS=2 + KCC=21 + MINT(20+JS)=KFF1 + MINT(23-JS)=KFF2 + ELSEIF(ICOL1.EQ.2.AND.ICOL2.EQ.2.AND. + $ ((JCOL1.EQ.0.AND.JCOL2.EQ.2).OR. + $ ((JCOL2.EQ.0.AND.JCOL1.EQ.2)))) THEN + IF(PYR(0).GT.0.5D0) JS=2 + KCC=22+JS + KCS=(-1)**INT(1.5D0+PYR(0)) + IF(JCOL1.EQ.0) THEN + MINT(23-JS)=KFF1 + MINT(20+JS)=KFF2 + ELSE + MINT(23-JS)=KFF2 + MINT(20+JS)=KFF1 + ENDIF + ELSEIF(ICOL1.EQ.2.AND.ICOL2.EQ.2.AND. + $ ((JCOL1.EQ.1.AND.JCOL2.EQ.-1).OR. + $ ((JCOL2.EQ.1.AND.JCOL1.EQ.-1)))) THEN +C....two choices, 0 or 2 depending upon mother properties + IF(MCOL.EQ.2) THEN + KCS=(-1)**INT(1.5D0+PYR(0)) + KCC=MINT(2)+10 + IF(JCOL1.EQ.1) THEN + MINT(21)=KFF1*KCS + MINT(22)=KFF2*KCS + ELSE + MINT(22)=KFF1*KCS + MINT(21)=KFF2*KCS + ENDIF +c MINT(20+JS)=KFF1*KCS +c MINT(23-JS)=KFF2*KCS + ELSEIF(MCOL.EQ.0) THEN + KCC=21 + MINT(20+JS)=KFF1*KCS + MINT(23-JS)=KFF2*KCS + ENDIF + + ELSEIF(ICOL1.EQ.2.AND.ICOL2.EQ.2.AND. + $ JCOL1.EQ.2.AND.JCOL2.EQ.2) THEN +C....two choices, 0 or 2 depending upon mother properties + IF(MCOL.EQ.0) THEN + KCC=21 + IF(PYR(0).GT.0.5D0) JS=2 + MINT(20+JS)=KFF1 + MINT(23-JS)=KFF2 + ELSEIF(MCOL.EQ.2) THEN + IF(PYR(0).GT.0.5D0) JS=2 + KCC=MINT(2)+12 + KCS=(-1)**INT(1.5D0+PYR(0)) + MINT(20+JS)=KFF1 + MINT(23-JS)=KFF2 + ENDIF + ELSEIF((ICOL1.EQ.1.AND.ICOL2.EQ.1).OR. + $ (ICOL1.EQ.-1.AND.ICOL2.EQ.-1)) THEN + KCC=MINT(2) + IF(PYR(0).GT.0.5D0) JS=2 + MINT(20+JS)=KFF1 + MINT(23-JS)=KFF2 + ELSEIF(ICOL1.EQ.0.AND.ICOL2.EQ.0.AND.MCOL.EQ.0) THEN + KCC=20 + IF(PYR(0).GT.0.5D0) JS=2 + MINT(20+JS)=KFF1 + MINT(23-JS)=KFF2 + ELSE + CALL PYERRM(21,"PYSCAT: No recognized Generic Process") + ENDIF + IF(ISUBSV.EQ.482) KFRES=0 + ENDIF + ENDIF + + IF(ISET(ISUB).EQ.11) THEN +C...Store documentation for user-defined processes + BEZUP=(PUP(3,1)+PUP(3,2))/(PUP(4,1)+PUP(4,2)) + KUPPO(1)=MINT(83)+5 + KUPPO(2)=MINT(83)+6 + I=MINT(83)+6 + DO 470 IUP=3,NUP + KUPPO(IUP)=0 + IF(MSTP(128).GE.2.AND.MOTHUP(1,IUP).GE.3) THEN + IDOC=IDOC-1 + MINT(4)=MINT(4)-1 + GOTO 470 + ENDIF + I=I+1 + KUPPO(IUP)=I + K(I,1)=21 + K(I,2)=IDUP(IUP) + IF(IDUP(IUP).EQ.0) K(I,2)=90 + K(I,3)=0 + IF(MOTHUP(1,IUP).GE.3) K(I,3)=KUPPO(MOTHUP(1,IUP)) + K(I,4)=0 + K(I,5)=0 + DO 460 J=1,5 + P(I,J)=PUP(J,IUP) + 460 CONTINUE + V(I,5)=VTIMUP(IUP) + 470 CONTINUE + CALL PYROBO(MINT(83)+7,MINT(83)+4+NUP,0D0,VINT(24),0D0,0D0, + & -BEZUP) + +C...Store final state partons for user-defined processes + N=IPU2 + DO 490 IUP=3,NUP + N=N+1 + K(N,1)=1 + IF(ISTUP(IUP).EQ.2.OR.ISTUP(IUP).EQ.3) K(N,1)=11 + K(N,2)=IDUP(IUP) + IF(IDUP(IUP).EQ.0) K(N,2)=90 + IF(MSTP(128).LE.0.OR.MOTHUP(1,IUP).EQ.0) THEN + K(N,3)=KUPPO(IUP) + ELSE + K(N,3)=MINT(84)+MOTHUP(1,IUP) + ENDIF + K(N,4)=0 + K(N,5)=0 +C...Search for daughters of intermediate colourless particles. + IF(K(N,1).EQ.11.AND.KCHG(PYCOMP(K(N,2)),2).EQ.0) THEN + DO 475 IUPDAU=IUP+1,NUP + IF(MOTHUP(1,IUPDAU).EQ.IUP.AND.K(N,4).EQ.0) K(N,4)= + & N+IUPDAU-IUP + IF(MOTHUP(1,IUPDAU).EQ.IUP) K(N,5)=N+IUPDAU-IUP + 475 CONTINUE + ENDIF + DO 480 J=1,5 + P(N,J)=PUP(J,IUP) + 480 CONTINUE + V(N,5)=VTIMUP(IUP) + 490 CONTINUE + CALL PYROBO(IPU3,N,0D0,VINT(24),0D0,0D0,-BEZUP) + +C...Arrange colour flow for user-defined processes + NLBL=0 + DO 540 IUP1=1,NUP + I1=MINT(84)+IUP1 + IF(KCHG(PYCOMP(K(I1,2)),2).EQ.0) GOTO 540 + IF(K(I1,1).EQ.1) K(I1,1)=3 + IF(K(I1,1).EQ.11) K(I1,1)=14 +C...Find a not yet considered colour/anticolour line. + DO 530 ISDE1=1,2 + IF(ICOLUP(ISDE1,IUP1).EQ.0) GOTO 530 + NMAT=0 + DO 500 ILBL=1,NLBL + IF(ICOLUP(ISDE1,IUP1).EQ.ILAB(ILBL)) NMAT=1 + 500 CONTINUE + IF(NMAT.EQ.0) THEN + NLBL=NLBL+1 + ILAB(NLBL)=ICOLUP(ISDE1,IUP1) +C...Find all others belonging to same line. + I3=I1 + I4=0 + DO 520 IUP2=IUP1+1,NUP + I2=MINT(84)+IUP2 + DO 510 ISDE2=1,2 + IF(ICOLUP(ISDE2,IUP2).EQ.ICOLUP(ISDE1,IUP1)) THEN + IF(ISDE2.EQ.ISDE1) THEN + K(I3,3+ISDE2)=K(I3,3+ISDE2)+I2 + K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I3 + I3=I2 + ELSEIF(I4.NE.0) THEN + K(I4,3+ISDE2)=K(I4,3+ISDE2)+I2 + K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I4 + I4=I2 + ELSEIF(IUP2.LE.2) THEN + K(I1,3+ISDE1)=K(I1,3+ISDE1)+I2 + K(I2,3+ISDE2)=K(I2,3+ISDE2)+I1 + I4=I2 + ELSE + K(I1,3+ISDE1)=K(I1,3+ISDE1)+MSTU(5)*I2 + K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I1 + I4=I2 + ENDIF + ENDIF + 510 CONTINUE + 520 CONTINUE + ENDIF + 530 CONTINUE + 540 CONTINUE + + ELSEIF(IDOC.EQ.7) THEN +C...Resonance not decaying; store kinematics + I=MINT(83)+7 + K(IPU3,1)=1 + K(IPU3,2)=KFRES + K(IPU3,3)=I + P(IPU3,4)=SHUSER + P(IPU3,5)=SHUSER + K(I,1)=21 + K(I,2)=KFRES + P(I,4)=SHUSER + P(I,5)=SHUSER + N=IPU3 + MINT(21)=KFRES + MINT(22)=0 + +C...Special cases: colour flow in coloured resonances + KCRES=PYCOMP(KFRES) + IF(KCHG(KCRES,2).NE.0) THEN + K(IPU3,1)=3 + DO 550 J=1,2 + JC=J + IF(KCS.EQ.-1) JC=3-J + IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)= + & MINT(84)+ICOL(KCC,1,JC) + IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)= + & MINT(84)+ICOL(KCC,2,JC) + IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)= + & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC)) + 550 CONTINUE + ELSE + K(IPU1,4)=IPU2 + K(IPU1,5)=IPU2 + K(IPU2,4)=IPU1 + K(IPU2,5)=IPU1 + ENDIF + + ELSEIF(IDOC.EQ.8) THEN +C...2 -> 2 processes: store outgoing partons in their CM-frame + DO 560 JT=1,2 + I=MINT(84)+2+JT + KCA=PYCOMP(MINT(20+JT)) + K(I,1)=1 + IF(KCHG(KCA,2).NE.0) K(I,1)=3 + K(I,2)=MINT(20+JT) + K(I,3)=MINT(83)+IDOC+JT-2 + KFAA=IABS(K(I,2)) + IF(KFPR(ISUBSV,1+MOD(JS+JT,2)).NE.0) THEN + P(I,5)=SQRT(VINT(63+MOD(JS+JT,2))) + ELSE + P(I,5)=PYMASS(K(I,2)) + ENDIF + IF((KFAA.EQ.6.OR.KFAA.EQ.7.OR.KFAA.EQ.8).AND. + & P(I,5).LT.PARP(42)) P(I,5)=PYMASS(K(I,2)) + 560 CONTINUE + IF(P(IPU3,5)+P(IPU4,5).GE.SHR) THEN + KFA1=IABS(MINT(21)) + KFA2=IABS(MINT(22)) + IF((KFA1.GT.3.AND.KFA1.NE.21).OR.(KFA2.GT.3.AND.KFA2.NE.21)) + & THEN + MINT(51)=1 + RETURN + ENDIF + P(IPU3,5)=0D0 + P(IPU4,5)=0D0 + ENDIF + P(IPU3,4)=0.5D0*(SHR+(P(IPU3,5)**2-P(IPU4,5)**2)/SHR) + P(IPU3,3)=SQRT(MAX(0D0,P(IPU3,4)**2-P(IPU3,5)**2)) + P(IPU4,4)=SHR-P(IPU3,4) + P(IPU4,3)=-P(IPU3,3) + N=IPU4 + MINT(7)=MINT(83)+7 + MINT(8)=MINT(83)+8 + +C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4) + CALL PYROBO(IPU3,IPU4,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0) + + ELSEIF(IDOC.EQ.9) THEN +C...2 -> 3 processes: store outgoing partons in their CM frame + DO 570 JT=1,2 + I=MINT(84)+2+JT + KCA=PYCOMP(MINT(20+JT)) + K(I,1)=1 + IF(KCHG(KCA,2).NE.0) K(I,1)=3 + K(I,2)=MINT(20+JT) + K(I,3)=MINT(83)+IDOC+JT-3 + JTA=JT +C...t and b in opposide order in event list as compared to +C...matrix element? + IF(ISUB.EQ.402.AND.IABS(MINT(21)).EQ.5) JTA=3-JT + IF(IABS(K(I,2)).LE.22) THEN + P(I,5)=PYMASS(K(I,2)) + ELSE + P(I,5)=SQRT(VINT(63+MOD(JS+JTA,2))) + ENDIF + PT=SQRT(MAX(0D0,VINT(197+5*JTA)-P(I,5)**2+VINT(196+5*JTA)**2)) + P(I,1)=PT*COS(VINT(198+5*JTA)) + P(I,2)=PT*SIN(VINT(198+5*JTA)) + 570 CONTINUE + K(IPU5,1)=1 + K(IPU5,2)=KFRES + K(IPU5,3)=MINT(83)+IDOC + P(IPU5,5)=SHR + P(IPU5,1)=-P(IPU3,1)-P(IPU4,1) + P(IPU5,2)=-P(IPU3,2)-P(IPU4,2) + PMS1=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2 + PMS2=P(IPU4,5)**2+P(IPU4,1)**2+P(IPU4,2)**2 + PMS3=P(IPU5,5)**2+P(IPU5,1)**2+P(IPU5,2)**2 + PMT3=SQRT(PMS3) + P(IPU5,3)=PMT3*SINH(VINT(211)) + P(IPU5,4)=PMT3*COSH(VINT(211)) + PMS12=(SHPR-P(IPU5,4))**2-P(IPU5,3)**2 + SQL12=(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2 + IF(SQL12.LE.0D0) THEN + MINT(51)=1 + RETURN + ENDIF + P(IPU3,3)=(-P(IPU5,3)*(PMS12+PMS1-PMS2)+ + & VINT(213)*(SHPR-P(IPU5,4))*SQRT(SQL12))/(2D0*PMS12) + P(IPU4,3)=-P(IPU3,3)-P(IPU5,3) + IF(ISUB.EQ.402.AND.IABS(MINT(21)).EQ.5) THEN +C...t and b in opposide order in event list as compared to +C...matrix element + P(IPU4,3)=(-P(IPU5,3)*(PMS12+PMS2-PMS1)+ + & VINT(213)*(SHPR-P(IPU5,4))*SQRT(SQL12))/(2D0*PMS12) + P(IPU3,3)=-P(IPU4,3)-P(IPU5,3) + END IF + P(IPU3,4)=SQRT(PMS1+P(IPU3,3)**2) + P(IPU4,4)=SQRT(PMS2+P(IPU4,3)**2) + MINT(23)=KFRES + N=IPU5 + MINT(7)=MINT(83)+7 + MINT(8)=MINT(83)+8 + + ELSEIF(IDOC.EQ.11) THEN +C...Z0 + Z0 -> h0, W+ + W- -> h0: store Higgs and outgoing partons + PHI(1)=PARU(2)*PYR(0) + PHI(2)=PHI(1)-PHIR + DO 580 JT=1,2 + I=MINT(84)+2+JT + K(I,1)=1 + IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3 + K(I,2)=MINT(20+JT) + K(I,3)=MINT(83)+IDOC+JT-2 + P(I,5)=PYMASS(K(I,2)) + IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) THEN + MINT(51)=1 + RETURN + ENDIF + PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2)) + PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2)) + P(I,1)=PTABS*COS(PHI(JT)) + P(I,2)=PTABS*SIN(PHI(JT)) + P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1) + P(I,4)=0.5D0*SHPR*Z(JT) + IZW=MINT(83)+6+JT + K(IZW,1)=21 + K(IZW,2)=23 + IF(ISUB.EQ.8) K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT))) + K(IZW,3)=IZW-2 + P(IZW,1)=-P(I,1) + P(IZW,2)=-P(I,2) + P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1) + P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT)) + P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2)) + 580 CONTINUE + I=MINT(83)+9 + K(IPU5,1)=1 + K(IPU5,2)=KFRES + K(IPU5,3)=I + P(IPU5,5)=SHR + P(IPU5,1)=-P(IPU3,1)-P(IPU4,1) + P(IPU5,2)=-P(IPU3,2)-P(IPU4,2) + P(IPU5,3)=-P(IPU3,3)-P(IPU4,3) + P(IPU5,4)=SHPR-P(IPU3,4)-P(IPU4,4) + K(I,1)=21 + K(I,2)=KFRES + DO 590 J=1,5 + P(I,J)=P(IPU5,J) + 590 CONTINUE + N=IPU5 + MINT(23)=KFRES + + ELSEIF(IDOC.EQ.12) THEN +C...Z0 and W+/- scattering: store bosons and outgoing partons + PHI(1)=PARU(2)*PYR(0) + PHI(2)=PHI(1)-PHIR + JTRAN=INT(1.5D0+PYR(0)) + DO 600 JT=1,2 + I=MINT(84)+2+JT + K(I,1)=1 + IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3 + K(I,2)=MINT(20+JT) + K(I,3)=MINT(83)+IDOC+JT-2 + P(I,5)=PYMASS(K(I,2)) + IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) P(I,5)=0D0 + PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2)) + PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2)) + P(I,1)=PTABS*COS(PHI(JT)) + P(I,2)=PTABS*SIN(PHI(JT)) + P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1) + P(I,4)=0.5D0*SHPR*Z(JT) + IZW=MINT(83)+6+JT + K(IZW,1)=21 + IF(MINT(14+JT).EQ.MINT(20+JT)) THEN + K(IZW,2)=23 + ELSE + K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT))-PYCHGE(MINT(20+JT))) + ENDIF + K(IZW,3)=IZW-2 + P(IZW,1)=-P(I,1) + P(IZW,2)=-P(I,2) + P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1) + P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT)) + P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2)) + IPU=MINT(84)+4+JT + K(IPU,1)=3 + K(IPU,2)=KFPR(ISUB,JT) + IF(ISUB.EQ.72.AND.JT.EQ.JTRAN) K(IPU,2)=-K(IPU,2) + IF(ISUB.EQ.73.OR.ISUB.EQ.77) K(IPU,2)=K(IZW,2) + K(IPU,3)=MINT(83)+8+JT + IF(IABS(K(IPU,2)).LE.10.OR.K(IPU,2).EQ.21) THEN + P(IPU,5)=PYMASS(K(IPU,2)) + ELSE + P(IPU,5)=SQRT(VINT(63+MOD(JS+JT,2))) + ENDIF + MINT(22+JT)=K(IPU,2) + 600 CONTINUE +C...Find rotation and boost for hard scattering subsystem + I1=MINT(83)+7 + I2=MINT(83)+8 + BEXCM=(P(I1,1)+P(I2,1))/(P(I1,4)+P(I2,4)) + BEYCM=(P(I1,2)+P(I2,2))/(P(I1,4)+P(I2,4)) + BEZCM=(P(I1,3)+P(I2,3))/(P(I1,4)+P(I2,4)) + GAMCM=(P(I1,4)+P(I2,4))/SHR + BEPCM=BEXCM*P(I1,1)+BEYCM*P(I1,2)+BEZCM*P(I1,3) + PX=P(I1,1)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEXCM + PY=P(I1,2)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEYCM + PZ=P(I1,3)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEZCM + THECM=PYANGL(PZ,SQRT(PX**2+PY**2)) + PHICM=PYANGL(PX,PY) +C...Store hard scattering subsystem. Rotate and boost it + SQLAM=(SH-P(IPU5,5)**2-P(IPU6,5)**2)**2-4D0*P(IPU5,5)**2* + & P(IPU6,5)**2 + PABS=SQRT(MAX(0D0,SQLAM/(4D0*SH))) + CTHWZ=VINT(23) + STHWZ=SQRT(MAX(0D0,1D0-CTHWZ**2)) + PHIWZ=VINT(24)-PHICM + P(IPU5,1)=PABS*STHWZ*COS(PHIWZ) + P(IPU5,2)=PABS*STHWZ*SIN(PHIWZ) + P(IPU5,3)=PABS*CTHWZ + P(IPU5,4)=SQRT(PABS**2+P(IPU5,5)**2) + P(IPU6,1)=-P(IPU5,1) + P(IPU6,2)=-P(IPU5,2) + P(IPU6,3)=-P(IPU5,3) + P(IPU6,4)=SQRT(PABS**2+P(IPU6,5)**2) + CALL PYROBO(IPU5,IPU6,THECM,PHICM,BEXCM,BEYCM,BEZCM) + DO 620 JT=1,2 + I1=MINT(83)+8+JT + I2=MINT(84)+4+JT + K(I1,1)=21 + K(I1,2)=K(I2,2) + DO 610 J=1,5 + P(I1,J)=P(I2,J) + 610 CONTINUE + 620 CONTINUE + N=IPU6 + MINT(7)=MINT(83)+9 + MINT(8)=MINT(83)+10 + ENDIF + + IF(ISET(ISUB).EQ.11) THEN + ELSEIF(IDOC.GE.8) THEN +C...Store colour connection indices + DO 630 J=1,2 + JC=J + IF(KCS.EQ.-1) JC=3-J + IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)= + & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC) + IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)= + & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC) + IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)= + & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC)) + IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)= + & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC)) + 630 CONTINUE + +C...Copy outgoing partons to documentation lines + IMAX=2 + IF(IDOC.EQ.9) IMAX=3 + DO 650 I=1,IMAX + I1=MINT(83)+IDOC-IMAX+I + I2=MINT(84)+2+I + K(I1,1)=21 + K(I1,2)=K(I2,2) + IF(IDOC.LE.9) K(I1,3)=0 + IF(IDOC.GE.11) K(I1,3)=MINT(83)+2+I + DO 640 J=1,5 + P(I1,J)=P(I2,J) + 640 CONTINUE + 650 CONTINUE + + ELSEIF(IDOC.EQ.9) THEN +C...Store colour connection indices + DO 660 J=1,2 + JC=J + IF(KCS.EQ.-1) JC=3-J + IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)= + & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)+ + & MAX(0,MIN(1,ICOL(KCC,1,JC)-2)) + IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)= + & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)+ + & MAX(0,MIN(1,ICOL(KCC,2,JC)-2)) + IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)= + & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC)) + IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU5,1).EQ.3) K(IPU5,J+3)= + & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC)) + 660 CONTINUE + +C...Copy outgoing partons to documentation lines + DO 680 I=1,3 + I1=MINT(83)+IDOC-3+I + I2=MINT(84)+2+I + K(I1,1)=21 + K(I1,2)=K(I2,2) + K(I1,3)=0 + DO 670 J=1,5 + P(I1,J)=P(I2,J) + 670 CONTINUE + 680 CONTINUE + ENDIF + +C...Copy outgoing partons to list of allowed radiators. + NPART=0 + IF(MINT(35).GE.2.AND.ISET(ISUB).NE.0) THEN + DO 690 I=MINT(84)+3,N + NPART=NPART+1 + IPART(NPART)=I + PTPART(NPART)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2) + 690 CONTINUE + ENDIF + +C...Low-pT events: remove gluons used for string drawing purposes + IF(ISUB.EQ.95) THEN + IF(MINT(35).LE.1) THEN + K(IPU3,1)=K(IPU3,1)+10 + K(IPU4,1)=K(IPU4,1)+10 + ENDIF + DO 700 J=41,66 + VINTSV(J)=VINT(J) + VINT(J)=0D0 + 700 CONTINUE + DO 720 I=MINT(83)+5,MINT(83)+8 + DO 710 J=1,5 + P(I,J)=0D0 + 710 CONTINUE + 720 CONTINUE + ENDIF + + RETURN + END + +C*********************************************************************** + +C...PYEVOL +C...Handles intertwined pT-ordered spacelike initial-state parton +C...and multiple interactions. + + SUBROUTINE PYEVOL(MODE,PT2MAX,PT2MIN) +C...Mode = -1 : Initialize first time. Determine MAX and MIN scales. +C...MODE = 0 : (Re-)initialize ISR/MI evolution. +C...Mode = 1 : Evolve event from PT2MAX to PT2MIN. + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...External + EXTERNAL PYALPS + DOUBLE PRECISION PYALPS +C...Parameter statement for maximum size of showers. + PARAMETER (MAXNUR=1000) +C...Commonblocks. + COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR) + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) + COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000) + COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6), + & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1), + & XMI(2,240),PT2MI(240),IMISEP(0:240) + COMMON/PYCTAG/NCT,MCT(4000,2) + COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240), + & PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX + COMMON/PYISJN/MJN1MX,MJN2MX,MJOIND(2,240) +C...Local arrays and saved variables. + DIMENSION VINTSV(11:80),KSAV(4,5),PSAV(4,5),VSAV(4,5),SHAT(240) + SAVE NSAV,NPARTS,M15SV,M16SV,M21SV,M22SV,VINTSV,SHAT,ISUBHD,ALAM3 + & ,PSAV,KSAV,VSAV + + SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/, + & /PYINT2/,/PYINT3/,/PYINTM/,/PYCTAG/,/PYISMX/,/PYISJN/ + +C---------------------------------------------------------------------- +C...MODE=-1: Pre-initialization. Store info on hard scattering etc, +C...done only once per event, while MODE=0 is repeated each time the +C...evolution needs to be restarted. + IF (MODE.EQ.-1) THEN + ISUBHD=MINT(1) + NSAV=N + NPARTS=NPART +C...Store hard scattering variables + M15SV=MINT(15) + M16SV=MINT(16) + M21SV=MINT(21) + M22SV=MINT(22) + DO 100 J=11,80 + VINTSV(J)=VINT(J) + 100 CONTINUE + DO 120 J=1,5 + DO 110 IS=1,4 + I=IS+MINT(84) + PSAV(IS,J)=P(I,J) + KSAV(IS,J)=K(I,J) + VSAV(IS,J)=V(I,J) + 110 CONTINUE + 120 CONTINUE + +C...Set shat for hardest scattering + SHAT(1)=VINT(44) + IF(ISET(ISUBHD).GE.3.AND.ISET(ISUBHD).LE.5) SHAT(1)=VINT(26) + & *VINT(2) + +C...Compute 3-Flavour Lambda_QCD (sets absolute lowest PT scale below) + RMC=PMAS(4,1) + RMB=PMAS(5,1) + ALAM4=PARP(61) + IF(MSTU(112).LT.4) ALAM4=PARP(61)*(PARP(61)/RMC)**(2D0/25D0) + IF(MSTU(112).GT.4) ALAM4=PARP(61)*(RMB/PARP(61))**(2D0/25D0) + ALAM3=ALAM4*(RMC/ALAM4)**(2D0/27D0) + +C---------------------------------------------------------------------- +C...MODE= 0: Initialize ISR/MI evolution, i.e. begin from hardest +C...interaction initiators, with no previous evolution. Check the input +C...PT2MAX and PT2MIN and impose extra constraints on minimum PT2 (e.g. +C...must be larger than Lambda_QCD) and maximum PT2 (e.g. must be +C...smaller than the CM energy / 2.) + ELSEIF (MODE.EQ.0) THEN +C...Reset counters and switches + N=NSAV + NPART=NPARTS + MINT(30)=0 + MINT(31)=1 + MINT(36)=1 +C...Reset hard scattering variables + MINT(1)=ISUBHD + DO 130 J=11,80 + VINT(J)=VINTSV(J) + 130 CONTINUE + DO 150 J=1,5 + DO 140 IS=1,4 + I=IS+MINT(84) + P(I,J)=PSAV(IS,J) + K(I,J)=KSAV(IS,J) + V(I,J)=VSAV(IS,J) + P(MINT(83)+4+IS,J)=PSAV(IS,J) + V(MINT(83)+4+IS,J)=VSAV(IS,J) + 140 CONTINUE + 150 CONTINUE +C...Reset statistics on activity in event. + DO 160 J=351,359 + MINT(J)=0 + VINT(J)=0D0 + 160 CONTINUE +C...Reset extra companion reweighting factor + VINT(140)=1D0 + +C...We do not generate MI for soft process (ISUB=95), but the +C...initialization must be done regardless, for later purposes. + MINT(36)=1 + +C...Initialize multiple interactions. + CALL PYPTMI(-1,PTDUM1,PTDUM2,PTDUM3,IDUM) + IF(MINT(51).NE.0) RETURN + +C...Decide whether quarks in hard scattering were valence or sea + PT2HD=VINT(54) + DO 170 JS=1,2 + MINT(30)=JS + CALL PYPTMI(2,PT2HD,PTDUM2,PTDUM3,IDUM) + IF(MINT(51).NE.0) RETURN + 170 CONTINUE + +C...Set lower cutoff for PT2 iteration and colour interference PT2 scale + VINT(18)=0D0 + PT2MIN=MAX(PT2MIN,(1.1D0*ALAM3)**2) + IF (MSTP(70).EQ.2) THEN +C...VINT(18) is freezeout scale of alpha_s: alpha_eff(0) = alpha_s(VINT(18)) + VINT(18)=(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2 + ELSEIF (MSTP(70).EQ.3) THEN +C...MSTP(70) = 3 : Derive VINT(18) from alpha_eff(Lambda3) = PARP(73) + ALPHA0 = MAX(1D-6,PARP(73)) + Q20 = ALAM3**2/PARP(64) + IF (MSTP(64).EQ.3) Q20 = Q20 * 1.661**2 + VINT(18) = Q20 * (EXP(12*PARU(1)/27D0/ALPHA0)-1D0) + ENDIF +C...Also store PT2MIN in VINT(17). + 180 VINT(17)=PT2MIN + +C...Set FS masses zero now. + VINT(63)=0D0 + VINT(64)=0D0 + +C...Initialize IS showers with VINT(56) as max scale. + PT2ISR=VINT(56) + PT20=PT2MIN + IF (MSTP(70).EQ.0) THEN + PT20=MAX(PT2MIN,PARP(62)**2) + ELSEIF (MSTP(70).EQ.1) THEN + PT20=MAX(PT2MIN,(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2) + ENDIF + CALL PYPTIS(-1,PT2ISR,PT20,PT2DUM,IFAIL) + IF(MINT(51).NE.0) RETURN + + RETURN + +C---------------------------------------------------------------------- +C...MODE= 1: Evolve event from PTMAX to PTMIN. + ELSEIF (MODE.EQ.1) THEN + +C...Skip if no phase space. + 190 IF (PT2MAX.LE.PT2MIN) GOTO 330 + +C...Starting pT2 max scale (to be udpated successively). + PT2CMX=PT2MAX + +C...Evolve two sides of the event to find which branches at highest pT. + 200 JSMX=-1 + MIMX=0 + PT2MX=0D0 + +C...Loop over current shower initiators. + IF (MSTP(61).GE.1) THEN + DO 230 MI=1,MINT(31) + IF (MI.GE.2.AND.MSTP(84).LE.0) GOTO 230 + ISUB=96 + IF (MI.EQ.1) ISUB=ISUBHD + MINT(1)=ISUB + MINT(36)=MI +C...Set up shat, initiator x values, and x remaining in BR. + VINT(44)=SHAT(MI) + VINT(141)=XMI(1,MI) + VINT(142)=XMI(2,MI) + VINT(143)=1D0 + VINT(144)=1D0 + DO 210 JI=1,MINT(31) + IF (JI.EQ.MINT(36)) GOTO 210 + VINT(143)=VINT(143)-XMI(1,JI) + VINT(144)=VINT(144)-XMI(2,JI) + 210 CONTINUE +C...Loop over sides. +C...Generate trial branchings for this interaction. The hardest +C...branching so far is automatically updated if necessary in /PYISMX/. + DO 220 JS=1,2 + MINT(30)=JS + PT20=PT2MIN + IF (MSTP(70).EQ.0) THEN + PT20=MAX(PT2MIN,PARP(62)**2) + ELSEIF (MSTP(70).EQ.1) THEN + PT20=MAX(PT2MIN, + & (PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2) + ENDIF + CALL PYPTIS(0,PT2CMX,PT20,PT2NEW,IFAIL) + IF (MINT(51).NE.0) RETURN + 220 CONTINUE + 230 CONTINUE + ENDIF + +C...Generate trial additional interaction. + MINT(36)=MINT(31)+1 + 240 IF (MOD(MSTP(81),10).GE.1) THEN + MINT(1)=96 +C...Set up X remaining in BR. + VINT(143)=1D0 + VINT(144)=1D0 + DO 250 JI=1,MINT(31) + VINT(143)=VINT(143)-XMI(1,JI) + VINT(144)=VINT(144)-XMI(2,JI) + 250 CONTINUE +C...Generate trial interaction + 260 CALL PYPTMI(0,PT2CMX,PT2MIN,PT2NEW,IFAIL) + IF (MINT(51).EQ.1) RETURN + ENDIF + +C...And the winner is: + IF (PT2MX.LT.PT2MIN) THEN + GOTO 330 + ELSEIF (JSMX.EQ.0) THEN +C...Accept additional interaction (may still fail). + CALL PYPTMI(1,PT2NEW,PT2MIN,PT2DUM,IFAIL) + IF(MINT(51).NE.0) RETURN + IF (IFAIL.EQ.0) THEN + SHAT(MINT(36))=VINT(44) +C...Decide on flavours (valence/sea/companion). + DO 270 JS=1,2 + MINT(30)=JS + CALL PYPTMI(2,PT2NEW,PT2MIN,PT2DUM,IFAIL) + IF(MINT(51).NE.0) RETURN + 270 CONTINUE + ENDIF + ELSEIF (JSMX.EQ.1.OR.JSMX.EQ.2) THEN +C...Reconstruct kinematics of acceptable ISR branching. +C...Set up shat, initiator x values, and x remaining in BR. + MINT(30)=JSMX + MINT(36)=MIMX + VINT(44)=SHAT(MINT(36)) + VINT(141)=XMI(1,MINT(36)) + VINT(142)=XMI(2,MINT(36)) + VINT(143)=1D0 + VINT(144)=1D0 + DO 280 JI=1,MINT(31) + IF (JI.EQ.MINT(36)) GOTO 280 + VINT(143)=VINT(143)-XMI(1,JI) + VINT(144)=VINT(144)-XMI(2,JI) + 280 CONTINUE + PT2NEW=PT2MX + CALL PYPTIS(1,PT2NEW,PT2DM1,PT2DM2,IFAIL) + IF (MINT(51).EQ.1) RETURN + ELSEIF (JSMX.EQ.3.OR.JSMX.EQ.4) THEN +C...Bookeep joining. Cannot (yet) be constructed kinematically. + MINT(354)=MINT(354)+1 + VINT(354)=VINT(354)+SQRT(PT2MX) + IF (MINT(354).EQ.1) VINT(359)=SQRT(PT2MX) + MJOIND(JSMX-2,MJN1MX)=MJN2MX + MJOIND(JSMX-2,MJN2MX)=MJN1MX + ENDIF + +C...Update PT2 iteration scale. + PT2CMX=PT2MX + +C...Loop back to continue evolution. + IF(N.GT.MSTU(4)-MSTU(32)-10) THEN + CALL PYERRM(11,'(PYEVOL:) no more memory left in PYJETS') + ELSE + IF (JSMX.GE.0.AND.PT2CMX.GE.PT2MIN) GOTO 200 + ENDIF + +C---------------------------------------------------------------------- +C...MODE= 2: (Re-)store user information on hardest interaction etc. + ELSEIF (MODE.EQ.2) THEN + +C...Revert to "ordinary" meanings of some parameters. + 290 DO 310 JS=1,2 + MINT(12+JS)=K(IMI(JS,1,1),2) + VINT(140+JS)=XMI(JS,1) + IF(MINT(18+JS).EQ.1) VINT(140+JS)=VINT(154+JS)*XMI(JS,1) + VINT(142+JS)=1D0 + DO 300 MI=1,MINT(31) + VINT(142+JS)=VINT(142+JS)-XMI(JS,MI) + 300 CONTINUE + 310 CONTINUE + +C...Restore saved quantities for hardest interaction. + MINT(1)=ISUBHD + MINT(15)=M15SV + MINT(16)=M16SV + MINT(21)=M21SV + MINT(22)=M22SV + DO 320 J=11,80 + VINT(J)=VINTSV(J) + 320 CONTINUE + + ENDIF + + 330 RETURN + END + +C********************************************************************* + +C...PYSSPA +C...Generates spacelike parton showers. + + SUBROUTINE PYSSPA(IPU1,IPU2) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP + PARAMETER (MAXNUR=1000) +C...Commonblocks. + COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR) + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) + COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000) + COMMON/PYCTAG/NCT,MCT(4000,2) + SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/, + &/PYINT1/,/PYINT2/,/PYINT3/,/PYCTAG/ +C...Local arrays and data. + DIMENSION KFLS(4),IS(2),XS(2),ZS(2),Q2S(2),TEVCSV(2),TEVESV(2), + &XFS(2,-25:25),XFA(-25:25),XFB(-25:25),XFN(-25:25),WTAPC(-25:25), + &WTAPE(-25:25),WTSF(-25:25),THE2(2),ALAM(2),DQ2(3),DPC(3),DPD(4), + &DPB(4),ROBO(5),MORE(2),KFBEAM(2),Q2MNCS(2),KCFI(2),NFIS(2), + &THEFIS(2,2),ISFI(2),DPHI(2),MCESV(2) + DATA IS/2*0/ + +C...Read out basic information; set global Q^2 scale. + IPUS1=IPU1 + IPUS2=IPU2 + ISUB=MINT(1) + Q2MX=VINT(56) + VINT2R=VINT(2)*VINT(143)*VINT(144) + IF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.9.OR.ISET(ISUB).EQ.11) Q2MX= + &MIN(VINT2R,PARP(67)*VINT(56)) + FCQ2MX=1D0 + +C...Define which processes ME corrections have been implemented for. + MECOR=0 + IF(MSTP(68).EQ.1.OR.MSTP(68).EQ.3) THEN + IF(ISUB.EQ.1.OR.ISUB.EQ.2.OR.ISUB.EQ.141.OR.ISUB.EQ.142.OR. + & ISUB.EQ.144) MECOR=1 + IF(ISUB.EQ.102.OR.ISUB.EQ.152.OR.ISUB.EQ.157) MECOR=2 + IF(ISUB.EQ.3.OR.ISUB.EQ.151.OR.ISUB.EQ.156) MECOR=3 + ENDIF + +C...Initialize QCD evolution and check phase space. + Q2MNC=PARP(62)**2 + Q2MNCS(1)=Q2MNC + Q2MNCS(2)=Q2MNC + IF(MINT(107).EQ.2.AND.MSTP(66).EQ.2) THEN + Q0S=PARP(15)**2 + PS=VINT(3)**2 + Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))* + & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS))) + Q2INT=SQRT(Q0S*Q2EFF) + Q2MNCS(1)=MAX(Q2MNC,Q2INT) + ELSEIF(MINT(107).EQ.3.AND.MSTP(66).GE.1) THEN + Q2MNCS(1)=MAX(Q2MNC,VINT(283)) + ENDIF + IF(MINT(108).EQ.2.AND.MSTP(66).EQ.2) THEN + Q0S=PARP(15)**2 + PS=VINT(4)**2 + Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))* + & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS))) + Q2INT=SQRT(Q0S*Q2EFF) + Q2MNCS(2)=MAX(Q2MNC,Q2INT) + ELSEIF(MINT(108).EQ.3.AND.MSTP(66).GE.1) THEN + Q2MNCS(2)=MAX(Q2MNC,VINT(284)) + ENDIF + MCEV=0 + ALAMS=PARU(112) + PARU(112)=PARP(61) + FQ2C=1D0 + TCMX=0D0 + IF(MINT(47).GE.2.AND.(MINT(47).LT.5.OR.MSTP(12).GE.1)) THEN + MCEV=1 + IF(MSTP(64).EQ.1) FQ2C=PARP(63) + IF(MSTP(64).EQ.2) FQ2C=PARP(64) + TCMX=LOG(FQ2C*Q2MX/PARP(61)**2) + IF(Q2MX.LT.MAX(Q2MNC,2D0*PARP(61)**2).OR.TCMX.LT.0.2D0) + & MCEV=0 + ENDIF + +C...Initialize QED evolution and check phase space. + MEEV=0 + XEE=1D-10 + SPME=PMAS(11,1)**2 + IF(IABS(MINT(11)).EQ.13.OR.IABS(MINT(12)).EQ.13) + &SPME=PMAS(13,1)**2 + IF(IABS(MINT(11)).EQ.15.OR.IABS(MINT(12)).EQ.15) + &SPME=PMAS(15,1)**2 + Q2MNE=MAX(PARP(68)**2,2D0*SPME) + TEMX=0D0 + FWTE=10D0 + IF(MINT(45).EQ.3.OR.MINT(46).EQ.3) THEN + MEEV=1 + TEMX=LOG(Q2MX/SPME) + IF(Q2MX.LE.Q2MNE.OR.TEMX.LT.0.2D0) MEEV=0 + ENDIF + IF(MSTP(61).GE.2.AND.MCEV.EQ.1.AND.MEEV.EQ.0) THEN + MEEV=2 + TEMX=TCMX + FWTE=1D0 + ENDIF + IF(MCEV.EQ.0.AND.MEEV.EQ.0) RETURN + +C...Loopback point in case of failure to reconstruct kinematics. + NS=N + NPARTS=NPART + LOOP=0 + MNT352=MINT(352) + MNT353=MINT(353) + VNT352=VINT(352) + VNT353=VINT(353) + 100 LOOP=LOOP+1 + IF(LOOP.GT.100) THEN + MINT(51)=1 + RETURN + ENDIF + N=NS + NPART=NPARTS + MINT(352)=MNT352 + MINT(353)=MNT353 + VINT(352)=VNT352 + VINT(353)=VNT353 + +C...Initial values: flavours, momenta, virtualities. + DO 120 JT=1,2 + MORE(JT)=1 + KFBEAM(JT)=MINT(10+JT) + IF(MINT(18+JT).EQ.1)KFBEAM(JT)=22 + KFLS(JT)=MINT(14+JT) + KFLS(JT+2)=KFLS(JT) + XS(JT)=VINT(40+JT) + IF(MINT(18+JT).EQ.1) XS(JT)=VINT(40+JT)/VINT(154+JT) + IF(MINT(31).GE.2) XS(JT)=XS(JT)/VINT(142+JT) + ZS(JT)=1D0 + Q2S(JT)=FCQ2MX*Q2MX + DQ2(JT)=0D0 + TEVCSV(JT)=TCMX + ALAM(JT)=PARP(61) + THE2(JT)=1D0 + TEVESV(JT)=TEMX + MCESV(JT)=0 +C...Calculate initial parton distribution weights. + MINT(105)=MINT(102+JT) + MINT(109)=MINT(106+JT) + VINT(120)=VINT(2+JT) + IF(XS(JT).LT.1D0-XEE) THEN + IF(MINT(31).GE.2) MINT(30)=JT + IF(MSTP(57).LE.1) THEN + CALL PYPDFU(KFBEAM(JT),XS(JT),Q2S(JT),XFB) + ELSE + CALL PYPDFL(KFBEAM(JT),XS(JT),Q2S(JT),XFB) + ENDIF + ENDIF + DO 110 KFL=-25,25 + XFS(JT,KFL)=XFB(KFL) + 110 CONTINUE +C...Special kinematics check for c/b quarks (that g -> c cbar or +C...b bbar kinematically possible). + KFLCB=IABS(KFLS(JT)) + IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5)) THEN + IF(XS(JT).GT.0.9D0*Q2S(JT)/(PMAS(KFLCB,1)**2+Q2S(JT))) THEN + MINT(51)=1 + RETURN + ENDIF + ENDIF + 120 CONTINUE + DSH=VINT(44) + IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) DSH=VINT(26)*VINT(2) + +C...Find if interference with final state partons. + MFIS=0 + IF(MSTP(67).GE.1.AND.MSTP(67).LE.3) MFIS=MSTP(67) + IF(MFIS.NE.0) THEN + DO 140 I=1,2 + KCFI(I)=0 + KCA=PYCOMP(IABS(KFLS(I))) + IF(KCA.NE.0) KCFI(I)=KCHG(KCA,2)*ISIGN(1,KFLS(I)) + NFIS(I)=0 + IF(KCFI(I).NE.0) THEN + IF(I.EQ.1) IPFS=IPUS1 + IF(I.EQ.2) IPFS=IPUS2 + DO 130 J=1,2 + ICSI=MOD(K(IPFS,3+J),MSTU(5)) + IF(ICSI.GT.0.AND.ICSI.NE.IPUS1.AND.ICSI.NE.IPUS2.AND. + & (KCFI(I).EQ.(-1)**(J+1).OR.KCFI(I).EQ.2)) THEN + NFIS(I)=NFIS(I)+1 + THEFIS(I,NFIS(I))=PYANGL(P(ICSI,3),SQRT(P(ICSI,1)**2+ + & P(ICSI,2)**2)) + IF(I.EQ.2) THEFIS(I,NFIS(I))=PARU(1)-THEFIS(I,NFIS(I)) + ENDIF + 130 CONTINUE + ENDIF + 140 CONTINUE + IF(NFIS(1)+NFIS(2).EQ.0) MFIS=0 + ENDIF + +C...Pick up leg with highest virtuality. + JTOLD=1 + 150 N=N+1 + JT=1 + IF(N.GT.NS+1.AND.Q2S(2).GT.Q2S(1)) JT=2 + IF(N.EQ.NS+2.AND.JT.EQ.JTOLD) JT=3-JT + IF(MORE(JT).EQ.0) JT=3-JT + JTOLD=JT + KFLB=KFLS(JT) + XB=XS(JT) + DO 160 KFL=-25,25 + XFB(KFL)=XFS(JT,KFL) + 160 CONTINUE + DSHR=2D0*SQRT(DSH) + DSHZ=DSH/ZS(JT) + +C...Check if allowed to branch. + MCEV=0 + IF(IABS(KFLB).LE.10.OR.KFLB.EQ.21) THEN + MCEV=1 + XEC=MAX(PARP(65)*DSHR/VINT2R,XB*(1D0/(1D0-PARP(66))-1D0)) + IF(XB.GE.1D0-2D0*XEC) MCEV=0 + ENDIF + MEEV=0 + IF(MINT(44+JT).EQ.3) THEN + MEEV=1 + IF(XB.GE.1D0-2D0*XEE) MEEV=0 + IF((IABS(KFLB).LE.10.OR.KFLB.EQ.21).AND.XB.GE.1D0-2D0*XEC) + & MEEV=0 +C***Currently kill QED shower for resolved photoproduction. + IF(MINT(18+JT).EQ.1) MEEV=0 +C***Currently kill shower for W inside electron. + IF(IABS(KFLB).EQ.24) THEN + MCEV=0 + MEEV=0 + ENDIF + ENDIF + IF(MSTP(61).GE.2.AND.MCEV.EQ.1.AND.MEEV.EQ.0.AND.IABS(KFLB).LE.10) + &MEEV=2 + IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN + Q2B=0D0 + GOTO 260 + ENDIF + +C...Maximum Q2 with or without Q2 ordering. Effective Lambda and n_f. + Q2B=Q2S(JT) + TEVCB=TEVCSV(JT) + TEVEB=TEVESV(JT) + IF(MSTP(62).LE.1) THEN + IF(ZS(JT).GT.0.99999D0) THEN + Q2B=Q2S(JT) + ELSE + Q2B=0.5D0*(1D0/ZS(JT)+1D0)*Q2S(JT)+0.5D0*(1D0/ZS(JT)-1D0)* + & (Q2S(3-JT)-DSH+SQRT((DSH+Q2S(1)+Q2S(2))**2+ + & 8D0*Q2S(1)*Q2S(2)*ZS(JT)/(1D0-ZS(JT)))) + ENDIF + IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2) + IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME) + ENDIF + IF(MCEV.EQ.1) THEN + ALSDUM=PYALPS(FQ2C*Q2B) + TEVCB=TEVCB+2D0*LOG(ALAM(JT)/PARU(117)) + ALAM(JT)=PARU(117) + B0=(33D0-2D0*MSTU(118))/6D0 + ENDIF + IF(MEEV.EQ.2) TEVEB=TEVCB + TEVCBS=TEVCB + TEVEBS=TEVEB + +C...Select side for interference with final state partons. + IF(MFIS.GE.1.AND.N.LE.NS+2) THEN + IFI=N-NS + ISFI(IFI)=0 + IF(IABS(KCFI(IFI)).EQ.1.AND.NFIS(IFI).EQ.1) THEN + ISFI(IFI)=1 + ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.1) THEN + IF(PYR(0).GT.0.5D0) ISFI(IFI)=1 + ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.2) THEN + ISFI(IFI)=1 + IF(PYR(0).GT.0.5D0) ISFI(IFI)=2 + ENDIF + ENDIF + +C...Calculate preweighting factor for ME-corrected processes. + IF(MECOR.GE.1) CALL PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG) + +C...Calculate Altarelli-Parisi weights. + DO 170 KFL=-25,25 + WTAPC(KFL)=0D0 + WTAPE(KFL)=0D0 + WTSF(KFL)=0D0 + 170 CONTINUE +C...q -> q (g or gamma emission), g -> q. + IF(IABS(KFLB).LE.10) THEN + WTAPC(KFLB)=(8D0/3D0)*LOG((1D0-XEC-XB)*(XB+XEC)/(XEC*(1D0-XEC))) + WTAPC(21)=0.5D0*(XB/(XB+XEC)-XB/(1D0-XEC)) + EQ2=1D0/9D0 + IF(MOD(IABS(KFLB),2).EQ.0) EQ2=4D0*EQ2 + IF(MEEV.EQ.2) WTAPE(KFLB)=2.*EQ2*LOG((1D0-XEC-XB)*(XB+XEC)/ + & (XEC*(1D0-XEC))) + IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN + WTAPC(KFLB)=WTFF*WTAPC(KFLB) + WTAPC(21)=WTGF*WTAPC(21) + WTAPE(KFLB)=WTFF*WTAPE(KFLB) + ENDIF +C...f -> f, gamma -> f. + ELSEIF(IABS(KFLB).LE.20) THEN + WTAPF1=LOG((1D0-XEE-XB)*(XB+XEE)/(XEE*(1D0-XEE))) + WTAPF2=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE))) + WTAPE(KFLB)=2D0*(WTAPF1+WTAPF2) + IF(MSTP(12).GE.1) WTAPE(22)=XB/(XB+XEE)-XB/(1D0-XEE) + IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN + WTAPE(KFLB)=WTFF*WTAPE(KFLB) + WTAPE(22)=WTGF*WTAPE(22) + ENDIF +C...f -> g, g -> g. + ELSEIF(KFLB.EQ.21) THEN + WTAPQ=(16D0/3D0)*(SQRT((1D0-XEC)/XB)-SQRT((XB+XEC)/XB)) + DO 180 KFL=1,MSTP(58) + WTAPC(KFL)=WTAPQ + WTAPC(-KFL)=WTAPQ + 180 CONTINUE + WTAPC(21)=6D0*LOG((1D0-XEC-XB)/XEC) + IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN + DO 190 KFL=1,MSTP(58) + WTAPC(KFL)=WTFG*WTAPC(KFL) + WTAPC(-KFL)=WTFG*WTAPC(-KFL) + 190 CONTINUE + WTAPC(21)=WTGG*WTAPC(21) + ENDIF +C...f -> gamma, W+, W-. + ELSEIF(KFLB.EQ.22) THEN + WTAPF=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))/XB + WTAPE(11)=WTAPF + WTAPE(-11)=WTAPF + IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN + WTAPE(11)=WTFG*WTAPE(11) + WTAPE(-11)=WTFG*WTAPE(-11) + ENDIF + ELSEIF(KFLB.EQ.24) THEN + WTAPE(-11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/ + & (XEE*(XB+XEE)))/XB + ELSEIF(KFLB.EQ.-24) THEN + WTAPE(11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/ + & (XEE*(XB+XEE)))/XB + ENDIF + +C...Calculate parton distribution weights and sum. + NTRY=0 + 200 NTRY=NTRY+1 + IF(NTRY.GT.500) THEN + MINT(51)=1 + RETURN + ENDIF + WTSUMC=0D0 + WTSUME=0D0 + XFBO=MAX(1D-10,XFB(KFLB)) + DO 210 KFL=-25,25 + WTSF(KFL)=XFB(KFL)/XFBO + WTSUMC=WTSUMC+WTAPC(KFL)*WTSF(KFL) + WTSUME=WTSUME+WTAPE(KFL)*WTSF(KFL) + 210 CONTINUE + WTSUMC=MAX(0.0001D0,WTSUMC) + WTSUME=MAX(0.0001D0/FWTE,WTSUME) + +C...Choose new t: fix alpha_s, alpha_s(Q^2), alpha_s(k_T^2). + NTRY2=0 + 220 NTRY2=NTRY2+1 + IF(NTRY2.GT.500) THEN + MINT(51)=1 + RETURN + ENDIF + IF(MCEV.EQ.1) THEN + IF(MSTP(64).LE.0) THEN + TEVCB=TEVCB+LOG(PYR(0))*PARU(2)/(PARU(111)*WTSUMC) + ELSEIF(MSTP(64).EQ.1) THEN + TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/WTSUMC)) + ELSE + TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/(5D0*WTSUMC))) + ENDIF + ENDIF + IF(MEEV.EQ.1) THEN + TEVEB=TEVEB*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/ + & (PARU(101)*FWTE*WTSUME*TEMX))) + ELSEIF(MEEV.EQ.2) THEN + TEVEB=TEVEB+LOG(PYR(0))*PARU(2)/(PARU(101)*WTSUME) + ENDIF + +C...Translate t into Q2 scale; choose between QCD and QED evolution. + 230 IF(MCEV.EQ.1) Q2CB=ALAM(JT)**2*EXP(MAX(-50D0,TEVCB))/FQ2C + IF(MEEV.EQ.1) Q2EB=SPME*EXP(MAX(-50D0,TEVEB)) + IF(MEEV.EQ.2) Q2EB=ALAM(JT)**2*EXP(MAX(-50D0,TEVEB))/FQ2C +C...Ensure that Q2 is above threshold for charm/bottom. + KFLCB=IABS(KFLB) + IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5).AND. + &MCEV.EQ.1) THEN + IF(Q2CB.LT.PMAS(KFLCB,1)**2) THEN + Q2CB=1.1D0*PMAS(KFLCB,1)**2 + TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2) + FCQ2MX=MIN(2D0,1.05D0*FCQ2MX) + ENDIF + ENDIF + IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5).AND. + &MEEV.EQ.2) THEN + IF(Q2EB.LT.PMAS(KFLCB,1)**2) MEEV=0 + ENDIF + MCE=0 + IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN + ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.0) THEN + IF(Q2CB.GT.Q2MNCS(JT)) MCE=1 + ELSEIF(MCEV.EQ.0.AND.MEEV.EQ.1) THEN + IF(Q2EB.GT.Q2MNE) MCE=2 + ELSEIF(MCEV.EQ.0.AND.MEEV.EQ.2) THEN + IF(Q2EB.GT.Q2MNCS(JT)) MCE=2 + ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.2) THEN + IF(Q2CB.GT.Q2EB.AND.Q2CB.GT.Q2MNCS(JT)) MCE=1 + IF(Q2EB.GT.Q2CB.AND.Q2EB.GT.Q2MNCS(JT)) MCE=2 + ELSEIF(Q2MNCS(JT).GT.Q2MNE) THEN + MCE=1 + IF(Q2EB.GT.Q2CB.OR.Q2CB.LE.Q2MNCS(JT)) MCE=2 + IF(MCE.EQ.2.AND.Q2EB.LE.Q2MNE) MCE=0 + ELSE + MCE=2 + IF(Q2CB.GT.Q2EB.OR.Q2EB.LE.Q2MNE) MCE=1 + IF(MCE.EQ.1.AND.Q2CB.LE.Q2MNCS(JT)) MCE=0 + ENDIF + +C...Evolution possibly ended. Update t values. + IF(MCE.EQ.0) THEN + Q2B=0D0 + GOTO 260 + ELSEIF(MCE.EQ.1) THEN + Q2B=Q2CB + Q2REF=FQ2C*Q2B + IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME) + IF(MEEV.EQ.2) TEVEB=LOG(FQ2C*Q2B/ALAM(JT)**2) + ELSE + Q2B=Q2EB + Q2REF=Q2B + IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2) + ENDIF + +C...Select flavour for branching parton. + IF(MCE.EQ.1) WTRAN=PYR(0)*WTSUMC + IF(MCE.EQ.2) WTRAN=PYR(0)*WTSUME + KFLA=-25 + 240 KFLA=KFLA+1 + IF(MCE.EQ.1) WTRAN=WTRAN-WTAPC(KFLA)*WTSF(KFLA) + IF(MCE.EQ.2) WTRAN=WTRAN-WTAPE(KFLA)*WTSF(KFLA) + IF(KFLA.LE.24.AND.WTRAN.GT.0D0) GOTO 240 + IF(KFLA.EQ.25) THEN + Q2B=0D0 + GOTO 260 + ENDIF + +C...Choose z value and corrective weight. + WTZ=0D0 +C...q -> q + g or q -> q + gamma. + IF(IABS(KFLA).LE.10.AND.IABS(KFLB).LE.10) THEN + Z=1D0-((1D0-XB-XEC)/(1D0-XEC))* + & (XEC*(1D0-XEC)/((XB+XEC)*(1D0-XB-XEC)))**PYR(0) + WTZ=0.5D0*(1D0+Z**2) +C...q -> g + q. + ELSEIF(IABS(KFLA).LE.10.AND.KFLB.EQ.21) THEN + Z=XB/(SQRT(XB+XEC)+PYR(0)*(SQRT(1D0-XEC)-SQRT(XB+XEC)))**2 + WTZ=0.5D0*(1D0+(1D0-Z)**2)*SQRT(Z) +C...f -> f + gamma. + ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN + IF(WTAPF1.GT.PYR(0)*(WTAPF1+WTAPF2)) THEN + Z=1D0-((1D0-XB-XEE)/(1D0-XEE))* + & (XEE*(1D0-XEE)/((XB+XEE)*(1D0-XB-XEE)))**PYR(0) + ELSE + Z=XB+XB*(XEE/(1D0-XEE))* + & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0) + ENDIF + WTZ=0.5D0*(1D0+Z**2)*(Z-XB)/(1D0-XB) +C...f -> gamma + f. + ELSEIF(IABS(KFLA).LE.20.AND.KFLB.EQ.22) THEN + Z=XB+XB*(XEE/(1D0-XEE))* + & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0) + WTZ=0.5D0*(1D0+(1D0-Z)**2)*XB*(Z-XB)/Z +C...f -> W+- + f. + ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).EQ.24) THEN + Z=XB+XB*(XEE/(1D0-XEE))* + & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0) + WTZ=0.5D0*(1D0+(1D0-Z)**2)*(XB*(Z-XB)/Z)* + & (Q2B/(Q2B+PMAS(24,1)**2)) +C...g -> q + qbar. + ELSEIF(KFLA.EQ.21.AND.IABS(KFLB).LE.10) THEN + Z=XB/(1D0-XEC)+PYR(0)*(XB/(XB+XEC)-XB/(1D0-XEC)) + WTZ=1D0-2D0*Z*(1D0-Z) +C...g -> g + g. + ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN + Z=1D0/(1D0+((1D0-XEC-XB)/XB)*(XEC/(1D0-XEC-XB))**PYR(0)) + WTZ=(1D0-Z*(1D0-Z))**2 +C...gamma -> f + fbar. + ELSEIF(KFLA.EQ.22.AND.IABS(KFLB).LE.20) THEN + Z=XB/(1D0-XEE)+PYR(0)*(XB/(XB+XEE)-XB/(1D0-XEE)) + WTZ=1D0-2D0*Z*(1D0-Z) + ENDIF + IF(MCE.EQ.2.AND.MEEV.EQ.1) WTZ=(WTZ/FWTE)*(TEVEB/TEMX) + +C...Option with resummation of soft gluon emission as effective z shift. + IF(MCE.EQ.1) THEN + IF(MSTP(65).GE.1) THEN + RSOFT=6D0 + IF(KFLB.NE.21) RSOFT=8D0/3D0 + Z=Z*(TEVCB/TEVCSV(JT))**(RSOFT*XEC/((XB+XEC)*B0)) + IF(Z.LE.XB) GOTO 220 + ENDIF + +C...Option with alpha_s(k_T^2): demand k_T^2 > cutoff, reweight. + IF(MSTP(64).GE.2) THEN + IF((1D0-Z)*Q2B.LT.Q2MNCS(JT)) GOTO 220 + ALPRAT=TEVCB/(TEVCB+LOG(1D0-Z)) + IF(ALPRAT.LT.5D0*PYR(0)) GOTO 220 + IF(ALPRAT.GT.5D0) WTZ=WTZ*ALPRAT/5D0 + ENDIF + ENDIF + +C...Remove kinematically impossible branchings. + UHAT=Q2B-DSH*(1D0-Z)/Z + IF(MSTP(68).GE.0.AND.UHAT.GT.0D0) GOTO 220 + +C...Select phi angle of branching at random. + PHIBR=PARU(2)*PYR(0) + +C...Matrix-element corrections for some processes. + IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN + IF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN + CALL PYMEWT(MECOR,1,Q2B,Z,PHIBR,WTME) + WTZ=WTZ*WTME/WTFF + ELSEIF((KFLA.EQ.21.OR.KFLA.EQ.22).AND.IABS(KFLB).LE.20) THEN + CALL PYMEWT(MECOR,2,Q2B,Z,PHIBR,WTME) + WTZ=WTZ*WTME/WTGF + ELSEIF(IABS(KFLA).LE.20.AND.(KFLB.EQ.21.OR.KFLB.EQ.22)) THEN + CALL PYMEWT(MECOR,3,Q2B,Z,PHIBR,WTME) + WTZ=WTZ*WTME/WTFG + ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN + CALL PYMEWT(MECOR,4,Q2B,Z,PHIBR,WTME) + WTZ=WTZ*WTME/WTGG + ENDIF + ENDIF + +C...Impose angular constraint in first branching from interference +C...with final state partons. + IF(MCE.EQ.1) THEN + IF(MFIS.GE.1.AND.N.LE.NS+2.AND.NTRY2.LT.200) THEN + THE2D=(4D0*Q2B)/(DSH*(1D0-Z)) + IF(N.EQ.NS+1.AND.ISFI(1).GE.1) THEN + IF(THE2D.GT.THEFIS(1,ISFI(1))**2) GOTO 220 + ELSEIF(N.EQ.NS+2.AND.ISFI(2).GE.1) THEN + IF(THE2D.GT.THEFIS(2,ISFI(2))**2) GOTO 220 + ENDIF + ENDIF + +C...Option with angular ordering requirement. + IF(MSTP(62).GE.3.AND.NTRY2.LT.200) THEN + THE2T=(4D0*Z**2*Q2B)/(4D0*Z**2*Q2B+(1D0-Z)*XB**2*VINT2R) + IF(THE2T.GT.THE2(JT)) GOTO 220 + ENDIF + ENDIF + +C...Weighting with new parton distributions. + MINT(105)=MINT(102+JT) + MINT(109)=MINT(106+JT) + VINT(120)=VINT(2+JT) + IF(MINT(31).GE.2) MINT(30)=JT + IF(MSTP(57).LE.1) THEN + CALL PYPDFU(KFBEAM(JT),XB,Q2REF,XFN) + ELSE + CALL PYPDFL(KFBEAM(JT),XB,Q2REF,XFN) + ENDIF + XFBN=XFN(KFLB) + IF(XFBN.LT.1D-20) THEN + IF(KFLA.EQ.KFLB) THEN + TEVCB=TEVCBS + TEVEB=TEVEBS + WTAPC(KFLB)=0D0 + WTAPE(KFLB)=0D0 + GOTO 200 + ELSEIF(MCE.EQ.1.AND.TEVCBS-TEVCB.GT.0.2D0) THEN + TEVCB=0.5D0*(TEVCBS+TEVCB) + GOTO 230 + ELSEIF(MCE.EQ.2.AND.TEVEBS-TEVEB.GT.0.2D0) THEN + TEVEB=0.5D0*(TEVEBS+TEVEB) + GOTO 230 + ELSE + XFBN=1D-10 + XFN(KFLB)=XFBN + ENDIF + ENDIF + DO 250 KFL=-25,25 + XFB(KFL)=XFN(KFL) + 250 CONTINUE + XA=XB/Z + IF(MINT(31).GE.2) MINT(30)=JT + IF(MSTP(57).LE.1) THEN + CALL PYPDFU(KFBEAM(JT),XA,Q2REF,XFA) + ELSE + CALL PYPDFL(KFBEAM(JT),XA,Q2REF,XFA) + ENDIF + XFAN=XFA(KFLA) + IF(XFAN.LT.1D-20) GOTO 200 + WTSFA=WTSF(KFLA) + IF(WTZ*XFAN/XFBN.LT.PYR(0)*WTSFA) GOTO 200 + +C...Define two hard scatterers in their CM-frame. + 260 IF(N.EQ.NS+2) THEN + DQ2(JT)=Q2B + DPLCM=SQRT((DSH+DQ2(1)+DQ2(2))**2-4D0*DQ2(1)*DQ2(2))/DSHR + DO 280 JR=1,2 + I=NS+JR + IF(JR.EQ.1) IPO=IPUS1 + IF(JR.EQ.2) IPO=IPUS2 + DO 270 J=1,5 + K(I,J)=0 + P(I,J)=0D0 + V(I,J)=0D0 + 270 CONTINUE + K(I,1)=14 + K(I,2)=KFLS(JR+2) + K(I,4)=IPO + K(I,5)=IPO + P(I,3)=DPLCM*(-1)**(JR+1) + P(I,4)=(DSH+DQ2(3-JR)-DQ2(JR))/DSHR + P(I,5)=-SQRT(DQ2(JR)) + K(IPO,1)=14 + K(IPO,3)=I + K(IPO,4)=MOD(K(IPO,4),MSTU(5))+MSTU(5)*I + K(IPO,5)=MOD(K(IPO,5),MSTU(5))+MSTU(5)*I + MCT(I,1)=MCT(IPO,1) + MCT(I,2)=MCT(IPO,2) + 280 CONTINUE + +C...Find maximum allowed mass of timelike parton. + ELSEIF(N.GT.NS+2) THEN + JR=3-JT + DQ2(3)=Q2B + DPC(1)=P(IS(1),4) + DPC(2)=P(IS(2),4) + DPC(3)=0.5D0*(ABS(P(IS(1),3))+ABS(P(IS(2),3))) + DPD(1)=DSH+DQ2(JR)+DQ2(JT) + DPD(2)=DSHZ+DQ2(JR)+DQ2(3) + DPD(3)=SQRT(DPD(1)**2-4D0*DQ2(JR)*DQ2(JT)) + DPD(4)=SQRT(DPD(2)**2-4D0*DQ2(JR)*DQ2(3)) + IKIN=0 + IF(Q2S(JR).GE.0.25D0*Q2MNC.AND.DPD(1)-DPD(3).GE. + & 1D-10*DPD(1)) IKIN=1 + IF(IKIN.EQ.0) DMSMA=(DQ2(JT)/ZS(JT)-DQ2(3))* + & (DSH/(DSH+DQ2(JT))-DSH/(DSHZ+DQ2(3))) + IF(IKIN.EQ.1) DMSMA=(DPD(1)*DPD(2)-DPD(3)*DPD(4))/ + & (2D0*DQ2(JR))-DQ2(JT)-DQ2(3) + +C...Generate timelike parton shower (if required). + IT=N + DO 290 J=1,5 + K(IT,J)=0 + P(IT,J)=0D0 + V(IT,J)=0D0 + 290 CONTINUE +C...f -> f + g (gamma). + IF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).LE.20) THEN + K(IT,2)=21 + IF(MCESV(JT).EQ.2.OR.IABS(KFLB).GE.11) K(IT,2)=22 +C...f -> g (gamma, W+-) + f. + ELSEIF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).GT.20) THEN + K(IT,2)=KFLB + IF(KFLS(JT+2).EQ.24) THEN + K(IT,2)=-12 + ELSEIF(KFLS(JT+2).EQ.-24) THEN + K(IT,2)=12 + ENDIF +C...g (gamma) -> f + fbar, g + g. + ELSE + K(IT,2)=-KFLS(JT+2) + IF(KFLS(JT+2).GT.20) K(IT,2)=KFLS(JT+2) + ENDIF + K(IT,1)=3 + IF((IABS(K(IT,2)).GE.11.AND.IABS(K(IT,2)).LE.18).OR. + & IABS(K(IT,2)).EQ.22) K(IT,1)=1 + P(IT,5)=PYMASS(K(IT,2)) + IF(DMSMA.LE.P(IT,5)**2) GOTO 100 + IF(MSTP(63).GE.1.AND.MCESV(JT).EQ.1) THEN + MSTJ48=MSTJ(48) + PARJ85=PARJ(85) + P(IT,4)=(DSHZ-DSH-P(IT,5)**2)/DSHR + P(IT,3)=SQRT(P(IT,4)**2-P(IT,5)**2) + IF(MSTP(63).EQ.1) THEN + Q2TIM=DMSMA + ELSEIF(MSTP(63).EQ.2) THEN + Q2TIM=MIN(DMSMA,PARP(71)*Q2S(JT)) + ELSE + Q2TIM=DMSMA + MSTJ(48)=1 + IF(IKIN.EQ.0) DPT2=DMSMA*(DSHZ+DQ2(3))/(DSH+DQ2(JT)) + IF(IKIN.EQ.1) DPT2=DMSMA*(0.5D0*DPD(1)*DPD(2)+0.5D0*DPD(3)* + & DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)))/(4D0*DSH*DPC(3)**2) + PARJ(85)=SQRT(MAX(0D0,DPT2))* + & (1D0/P(IT,4)+1D0/P(IS(JT),4)) + ENDIF +C...Only do timelike shower here if using PYSHOW + IF (MSTJ(41).NE.11.AND.MSTJ(41).NE.12) THEN + CALL PYSHOW(IT,0,SQRT(Q2TIM)) + ENDIF + MSTJ(48)=MSTJ48 + PARJ(85)=PARJ85 + IF(N.GE.IT+1) P(IT,5)=P(IT+1,5) + ENDIF + +C...Reconstruct kinematics of branching: timelike parton shower. + DMS=P(IT,5)**2 + IF(IKIN.EQ.0) DPT2=(DMSMA-DMS)*(DSHZ+DQ2(3))/(DSH+DQ2(JT)) + IF(IKIN.EQ.1) DPT2=(DMSMA-DMS)*(0.5D0*DPD(1)*DPD(2)+ + & 0.5D0*DPD(3)*DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)+DMS))/ + & (4D0*DSH*DPC(3)**2) + IF(DPT2.LT.0D0) GOTO 100 + DPB(1)=(0.5D0*DPD(2)-DPC(JR)*(DSHZ+DQ2(JR)-DQ2(JT)-DMS)/ + & DSHR)/DPC(3)-DPC(3) + P(IT,1)=SQRT(DPT2) + P(IT,3)=DPB(1)*(-1)**(JT+1) + P(IT,4)=SQRT(DPT2+DPB(1)**2+DMS) + IF(N.GE.IT+1) THEN + DPB(1)=SQRT(DPB(1)**2+DPT2) + DPB(2)=SQRT(DPB(1)**2+DMS) + DPB(3)=P(IT+1,3) + DPB(4)=SQRT(DPB(3)**2+DMS) + DBEZ=(DPB(4)*DPB(1)-DPB(3)*DPB(2))/(DPB(4)*DPB(2)-DPB(3)* + & DPB(1)) + CALL PYROBO(IT+1,N,0D0,0D0,0D0,0D0,DBEZ) + THE=PYANGL(P(IT,3),P(IT,1)) + CALL PYROBO(IT+1,N,THE,0D0,0D0,0D0,0D0) + ENDIF + +C...Reconstruct kinematics of branching: spacelike parton. + DO 300 J=1,5 + K(N+1,J)=0 + P(N+1,J)=0D0 + V(N+1,J)=0D0 + 300 CONTINUE + K(N+1,1)=14 + K(N+1,2)=KFLB + P(N+1,1)=P(IT,1) + P(N+1,3)=P(IT,3)+P(IS(JT),3) + P(N+1,4)=P(IT,4)+P(IS(JT),4) + P(N+1,5)=-SQRT(DQ2(3)) + MCT(N+1,1)=0 + MCT(N+1,2)=0 + +C...Define colour flow of branching. + K(IS(JT),3)=N+1 + K(IT,3)=N+1 + IM1=N+1 + IM2=N+1 +C...f -> f + gamma (Z, W). + IF(IABS(K(IT,2)).GE.22) THEN + K(IT,1)=1 + ID1=IS(JT) + ID2=IS(JT) +C...f -> gamma (Z, W) + f. + ELSEIF(IABS(K(IS(JT),2)).GE.22) THEN + ID1=IT + ID2=IT +C...gamma -> q + qbar, g + g. + ELSEIF(K(N+1,2).EQ.22) THEN + ID1=IS(JT) + ID2=IT + IM1=ID2 + IM2=ID1 +C...q -> q + g. + ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21.AND.K(IT,2).EQ.21) THEN + ID1=IT + ID2=IS(JT) +C...q -> g + q. + ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21) THEN + ID1=IS(JT) + ID2=IT +C...qbar -> qbar + g. + ELSEIF(K(N+1,2).LT.0.AND.K(IT,2).EQ.21) THEN + ID1=IS(JT) + ID2=IT +C...qbar -> g + qbar. + ELSEIF(K(N+1,2).LT.0) THEN + ID1=IT + ID2=IS(JT) +C...g -> g + g; g -> q + qbar. + ELSEIF((K(IT,2).EQ.21.AND.PYR(0).GT.0.5D0).OR.K(IT,2).LT.0) THEN + ID1=IS(JT) + ID2=IT + ELSE + ID1=IT + ID2=IS(JT) + ENDIF + IF(IM1.EQ.N+1) K(IM1,4)=K(IM1,4)+ID1 + IF(IM2.EQ.N+1) K(IM2,5)=K(IM2,5)+ID2 + K(ID1,4)=K(ID1,4)+MSTU(5)*IM1 + K(ID2,5)=K(ID2,5)+MSTU(5)*IM2 + IF(ID1.NE.ID2) THEN + K(ID1,5)=K(ID1,5)+MSTU(5)*ID2 + K(ID2,4)=K(ID2,4)+MSTU(5)*ID1 + ENDIF + N=N+1 + IF(K(IT,1).EQ.1) THEN + K(IT,4)=0 + K(IT,5)=0 + ENDIF + +C...Boost to new CM-frame. + DBSVX=(P(N,1)+P(IS(JR),1))/(P(N,4)+P(IS(JR),4)) + DBSVZ=(P(N,3)+P(IS(JR),3))/(P(N,4)+P(IS(JR),4)) + IF(DBSVX**2+DBSVZ**2.GE.1D0) GOTO 100 + CALL PYROBO(NS+1,N,0D0,0D0,-DBSVX,0D0,-DBSVZ) + IR=N+(JT-1)*(IS(1)-N) + CALL PYROBO(NS+1,N,-PYANGL(P(IR,3),P(IR,1)),DPHI(JT), + & 0D0,0D0,0D0) + +C...Save timelike parton in PYPART if doing pT-ordered FSR off ISR + IF (MSTJ(41).EQ.11.OR.MSTJ(41).EQ.12) THEN + NPART=NPART+1 + IPART(NPART)=IT + PTPART(NPART)=SQRT(PARP(71)*DPT2) + ENDIF + +C...Global statistics. + MINT(352)=MINT(352)+1 + VINT(352)=VINT(352)+SQRT(P(IT,1)**2+P(IT,2)**2) + IF (MINT(352).EQ.1) VINT(357)=SQRT(P(IT,1)**2+P(IT,2)**2) + + ENDIF + +C...Update kinematics variables. + IS(JT)=N + DQ2(JT)=Q2B + IF(MSTP(62).GE.3.AND.NTRY2.LT.200.AND.MCE.EQ.1) THE2(JT)=THE2T + DSH=DSHZ + +C...Save quantities; loop back. + Q2S(JT)=Q2B + DPHI(JT)=PHIBR + MCESV(JT)=MCE + IF((MCEV.EQ.1.AND.Q2B.GE.0.25D0*Q2MNC).OR. + &(MEEV.EQ.1.AND.Q2B.GE.Q2MNE)) THEN + KFLS(JT+2)=KFLS(JT) + KFLS(JT)=KFLA + XS(JT)=XA + ZS(JT)=Z + DO 310 KFL=-25,25 + XFS(JT,KFL)=XFA(KFL) + 310 CONTINUE + TEVCSV(JT)=TEVCB + TEVESV(JT)=TEVEB + ELSE + MORE(JT)=0 + IF(JT.EQ.1) IPU1=N + IF(JT.EQ.2) IPU2=N + ENDIF + IF(N.GT.MSTU(4)-MSTU(32)-10) THEN + CALL PYERRM(11,'(PYSSPA:) no more memory left in PYJETS') + IF(MSTU(21).GE.1) N=NS + IF(MSTU(21).GE.1) RETURN + ENDIF + IF(MORE(1).EQ.1.OR.MORE(2).EQ.1) GOTO 150 + +C...Boost hard scattering partons to frame of shower initiators. + DO 320 J=1,3 + ROBO(J+2)=(P(NS+1,J)+P(NS+2,J))/(P(NS+1,4)+P(NS+2,4)) + 320 CONTINUE + K(N+2,1)=1 + DO 330 J=1,5 + P(N+2,J)=P(NS+1,J) + 330 CONTINUE + CALL PYROBO(N+2,N+2,0D0,0D0,-ROBO(3),-ROBO(4),-ROBO(5)) + ROBO(2)=PYANGL(P(N+2,1),P(N+2,2)) + ROBO(1)=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2)) + IMIN=MINT(83)+5 + IF(MINT(31).GE.2) IMIN=MIN(IPUS1,IPUS2) + CALL PYROBO(IMIN,NS,0D0,-ROBO(2),0D0,0D0,0D0) + CALL PYROBO(IMIN,NS,ROBO(1),ROBO(2),ROBO(3),ROBO(4),ROBO(5)) + +C...Store user information. Reset Lambda value. + IF(MINT(31).LE.1) THEN + K(IPU1,3)=MINT(83)+3 + K(IPU2,3)=MINT(83)+4 + ELSE + K(IPU1,3)=MINT(83)+1 + K(IPU2,3)=MINT(83)+2 + ENDIF + DO 340 JT=1,2 + MINT(12+JT)=KFLS(JT) + VINT(140+JT)=XS(JT) + IF(MINT(18+JT).EQ.1) VINT(140+JT)=VINT(154+JT)*XS(JT) + IF(MINT(31).GE.2) VINT(140+JT)=VINT(140+JT)*VINT(142+JT) + 340 CONTINUE + PARU(112)=ALAMS + + RETURN + END + +C********************************************************************* + +C...PYPTIS +C...Generates pT-ordered spacelike initial-state parton showers and +C...trial joinings. +C...MODE=-1: Initialize ISR from scratch, starting from the hardest +C... interaction initiators at PT2NOW. +C...MODE= 0: Generate a trial branching on interaction MINT(36), side +C... MINT(30). Start evolution at PT2NOW, solve Sudakov for PT2. +C... Store in /PYISMX/ if PT2 is largest so far. Abort if PT2 +C... is below PT2CUT. +C... (Also generate test joinings if MSTP(96)=1.) +C...MODE= 1: Accept stored shower branching. Update event record etc. +C...PT2NOW : Starting (max) PT2 scale for evolution. +C...PT2CUT : Lower limit for evolution. +C...PT2 : Result of evolution. Generated PT2 for trial emission. +C...IFAIL : Status return code. IFAIL=0 when all is well. + + SUBROUTINE PYPTIS(MODE,PT2NOW,PT2CUT,PT2,IFAIL) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement for maximum size of showers. + PARAMETER (MAXNUR=1000) +C...Commonblocks. + COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR) + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) + COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6), + & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1), + & XMI(2,240),PT2MI(240),IMISEP(0:240) + COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240), + & PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX + COMMON/PYCTAG/NCT,MCT(4000,2) + COMMON/PYISJN/MJN1MX,MJN2MX,MJOIND(2,240) + SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/, + & /PYINT2/,/PYINTM/,/PYISMX/,/PYCTAG/,/PYISJN/ +C...Local variables + DIMENSION ZSAV(2,240),PT2SAV(2,240), + & XFB(-25:25),XFA(-25:25),XFN(-25:25),XFJ(-25:25), + & WTAP(-25:25),WTPDF(-25:25),SHTNOW(240), + & WTAPJ(240),WTPDFJ(240),X1(240),Y(240) + SAVE ZSAV,PT2SAV,XFB,XFA,XFN,WTAP,WTPDF,XMXC,SHTNOW, + & RMB2,RMC2,ALAM3,ALAM4,ALAM5,TMIN,PTEMAX,WTEMAX,AEM2PI +C...For check on excessive weights. + CHARACTER CHWT*12 + +C...Only give errors for very large weights, otherwise just warnings + DATA WTEMAX /1.5D0/ +C...Only give errors for large pT, otherwise just warnings + DATA PTEMAX /5D0/ + + IFAIL=-1 + +C---------------------------------------------------------------------- +C...MODE=-1: Initialize initial state showers from scratch, i.e. +C...starting from the hardest interaction initiators. + IF (MODE.EQ.-1) THEN +C...Set hard scattering SHAT. + SHTNOW(1)=VINT(44) +C...Mass thresholds and Lambda for QCD evolution. + AEM2PI=PARU(101)/PARU(2) + RMB=PMAS(5,1) + RMC=PMAS(4,1) + ALAM4=PARP(61) + IF(MSTU(112).LT.4) ALAM4=PARP(61)*(PARP(61)/RMC)**(2D0/25D0) + IF(MSTU(112).GT.4) ALAM4=PARP(61)*(RMB/PARP(61))**(2D0/25D0) + ALAM5=ALAM4*(ALAM4/RMB)**(2D0/23D0) + ALAM3=ALAM4*(RMC/ALAM4)**(2D0/27D0) +C...Optionally use Lambda_MC = Lambda_CMW + IF (MSTP(64).EQ.3) THEN + ALAM5 = ALAM5 * 1.569 + ALAM4 = ALAM4 * 1.618 + ALAM3 = ALAM3 * 1.661 + ENDIF + RMB2=RMB**2 + RMC2=RMC**2 +C...Massive quark forced creation threshold (in M**2). + TMIN=1.01D0 +C...Set upper limit for X (ensures some X left for beam remnant). + XMXC=1D0-2D0*PARP(111)/VINT(1) + + IF (MSTP(61).GE.1) THEN +C...Initial values: flavours, momenta, virtualities. + DO 100 JS=1,2 + NISGEN(JS,1)=0 + +C...Special kinematics check for c/b quarks (that g -> c cbar or +C...b bbar kinematically possible). + KFLB=K(IMI(JS,1,1),2) + KFLCB=IABS(KFLB) + IF(KFBEAM(JS).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5)) THEN +C...Check PT2MAX > mQ^2 + IF (VINT(56).LT.1.05D0*PMAS(PYCOMP(KFLCB),1)**2) THEN + CALL PYERRM(9,'(PYPTIS:) PT2MAX < 1.05 * MQ**2. '// + & 'No Q creation possible.') + MINT(51)=1 + RETURN + ELSE +C...Check for physical z values (m == MQ / sqrt(s)) +C...For creation diagram, x < z < (1-m)/(1+m(1-m)) + FMQ=PMAS(KFLCB,1)/SQRT(SHTNOW(1)) + ZMXCR=(1D0-FMQ)/(1D0+FMQ*(1D0-FMQ)) + IF (XMI(JS,1).GT.0.9D0*ZMXCR) THEN + CALL PYERRM(9,'(PYPTIS:) No physical z value for '// + & 'Q creation.') + MINT(51)=1 + RETURN + ENDIF + ENDIF + ENDIF + 100 CONTINUE + ENDIF + + MINT(354)=0 +C...Zero joining array + DO 110 MJ=1,240 + MJOIND(1,MJ)=0 + MJOIND(2,MJ)=0 + 110 CONTINUE + +C---------------------------------------------------------------------- +C...MODE= 0: Generate a trial branching on interaction MINT(36) side +C...MINT(30). Store if emission PT2 scale is largest so far. +C...Also generate test joinings if MSTP(96)=1. + ELSEIF(MODE.EQ.0) THEN + IFAIL=-1 + MECOR=0 + ISUB=MINT(1) + JS=MINT(30) +C...No shower for structureless beam + IF (MINT(44+JS).EQ.1) RETURN + MI=MINT(36) + SHAT=VINT(44) +C...Absolute shower max scale = VINT(56) + IF (MSTP(67).NE.0) THEN + PT2 = MIN(PT2NOW,VINT(56)) + ELSE +C...For MSTP(67)=0, adjust starting scale by PARP(67) + PT2=MIN(PT2NOW,PARP(67)*VINT(56)) + ENDIF + IF (NISGEN(1,MI).EQ.0.AND.NISGEN(2,MI).EQ.0) SHTNOW(MI)=SHAT +C...Define for which processes ME corrections have been implemented. + IF(MSTP(68).EQ.1.OR.MSTP(68).EQ.3) THEN + IF(ISUB.EQ.1.OR.ISUB.EQ.2.OR.ISUB.EQ.141.OR.ISUB.EQ + & .142.OR.ISUB.EQ.144) MECOR=1 + IF(ISUB.EQ.102.OR.ISUB.EQ.152.OR.ISUB.EQ.157) MECOR=2 + IF(ISUB.EQ.3.OR.ISUB.EQ.151.OR.ISUB.EQ.156) MECOR=3 +C...Calculate preweighting factor for ME-corrected processes. + IF(MECOR.GE.1) CALL PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG) + ENDIF +C...Basic info on daughter for which to find mother. + KFLB=K(IMI(JS,MI,1),2) + KFLBA=IABS(KFLB) +C...KSVCB: -1 for sea or first companion, 0 for valence or gluon, >1 for +C...second companion. + KSVCB=MAX(-1,IMI(JS,MI,2)) +C...Treat "first" companion of a pair like an ordinary sea quark +C...(except that creation diagram is not allowed) + IF(IMI(JS,MI,2).GT.IMISEP(MI)) KSVCB=-1 +C...X (rescaled to [0,1]) + XB=XMI(JS,MI)/VINT(142+JS) +C...Massive quarks (use physical masses.) + RMQ2=0D0 + MQMASS=0 + IF (KFLBA.EQ.4.OR.KFLBA.EQ.5) THEN + RMQ2=RMC2 + IF (KFLBA.EQ.5) RMQ2=RMB2 +C...Special threshold treatment for non-photon beams + IF (KFBEAM(JS).NE.22) MQMASS=KFLBA +C...Check that not below mass threshold. + IF(MQMASS.GT.0.AND.PT2.LT.TMIN*RMQ2) THEN + CALL PYERRM(9,'(PYPTIS:) PT2 < 1.01 * MQ**2. '// + & 'No Q creation possible.') + MINT(51)=1 +C...Special return code if failing before any evolution at all: bad event + IF (NISGEN(1,MI).EQ.0.AND.NISGEN(2,MI).EQ.0) MINT(51)=2 + RETURN + ENDIF + + ENDIF + +C...Flags for parton distribution calls. + MINT(105)=MINT(102+JS) + MINT(109)=MINT(106+JS) + VINT(120)=VINT(2+JS) + +C...Calculate initial parton distribution weights. + IF(XB.GE.XMXC) THEN + RETURN + ELSEIF(MQMASS.EQ.0) THEN + CALL PYPDFU(KFBEAM(JS),XB,PT2,XFB) + ELSE +C...Initialize massive quark PT2 dependent pdf underestimate. + PT20=PT2 + CALL PYPDFU(KFBEAM(JS),XB,PT20,XFB) +C.!.Tentative treatment of massive valence quarks. + XQ0=MAX(1D-10,XPSVC(KFLB,KSVCB)) + XG0=XFB(21) + TPM0=LOG(PT20/RMQ2) + WPDF0=TPM0*XG0/XQ0 + ENDIF + IF (KFLBA.LE.6) THEN +C...For quarks, only include respective sea, val, or cmp part. + IF (KSVCB.LE.0) THEN + XFB(KFLB)=XPSVC(KFLB,KSVCB) + ELSE +C...Find companion's companion + MISEA=0 + 120 MISEA=MISEA+1 + IF (IMI(JS,MISEA,2).NE.IMI(JS,MI,1)) GOTO 120 + XS=XMI(JS,MISEA) + XREM=VINT(142+JS) + YS=XS/(XREM+XS) +C...Momentum fraction of the companion quark. +C...Rescale from XB = x/XREM to YB = x/(1-Sum_rest) -> factor (1-YS). + YB=XB*(1D0-YS) + XFB(KFLB)=PYFCMP(YB/VINT(140),YS/VINT(140),MSTP(87)) + ENDIF + ENDIF + +C...Determine overestimated z range: switch at c and b masses. + 130 IF (PT2.GT.TMIN*RMB2) THEN + IZRG=3 + PT2MNE=MAX(TMIN*RMB2,PT2CUT) + B0=23D0/6D0 + ALAM2=ALAM5**2 + ELSEIF(PT2.GT.TMIN*RMC2) THEN + IZRG=2 + PT2MNE=MAX(TMIN*RMC2,PT2CUT) + B0=25D0/6D0 + ALAM2=ALAM4**2 + ELSE + IZRG=1 + PT2MNE=PT2CUT + B0=27D0/6D0 + ALAM2=ALAM3**2 + ENDIF +C...Divide Lambda by PARP(64) (equivalent to mult pT2 by PARP(64)) + ALAM2=ALAM2/PARP(64) +C...Overestimated ZMAX: + IF (MQMASS.EQ.0) THEN +C...Massless + ZMAX=1D0-0.5D0*(PT2MNE/SHTNOW(MI))*(SQRT(1D0+4D0*SHTNOW(MI) + & /PT2MNE)-1D0) + ELSE +C...Massive (limit for bremsstrahlung diagram > creation) + FMQ=SQRT(RMQ2/SHTNOW(MI)) + ZMAX=1D0/(1D0+FMQ) + ENDIF + ZMIN=XB/XMXC + +C...If kinematically impossible then do not evolve. + IF(PT2.LT.PT2CUT.OR.ZMAX.LE.ZMIN) RETURN + +C...Reset Altarelli-Parisi and PDF weights. + DO 140 KFL=-5,5 + WTAP(KFL)=0D0 + WTPDF(KFL)=0D0 + 140 CONTINUE + WTAP(21)=0D0 + WTPDF(21)=0D0 +C...Zero joining weights and compute X(partner) and X(mother) values. + NJN=0 + IF (MSTP(96).NE.0) THEN + DO 150 MJ=1,MINT(31) + WTAPJ(MJ)=0D0 + WTPDFJ(MJ)=0D0 + X1(MJ)=XMI(JS,MJ)/(VINT(142+JS)+XMI(JS,MJ)) + Y(MJ)=(XMI(JS,MI)+XMI(JS,MJ))/(VINT(142+JS)+XMI(JS,MJ) + & +XMI(JS,MI)) + 150 CONTINUE + ENDIF + +C...Approximate Altarelli-Parisi weights (integrated AP dz). +C...q -> q, g -> q or q -> q + gamma (already set which). + IF(KFLBA.LE.5) THEN +C...Val and cmp quarks get an extra sqrt(z) to smooth their bumps. + IF (KSVCB.LT.0) THEN + WTAP(KFLB)=(8D0/3D0)*LOG((1D0-ZMIN)/(1D0-ZMAX)) + ELSE + RMIN=(1+SQRT(ZMIN))/(1-SQRT(ZMIN)) + RMAX=(1+SQRT(ZMAX))/(1-SQRT(ZMAX)) + WTAP(KFLB)=(8D0/3D0)*LOG(RMAX/RMIN) + ENDIF + WTAP(21)=0.5D0*(ZMAX-ZMIN) + WTAPE=(2D0/9D0)*LOG((1D0-ZMIN)/(1D0-ZMAX)) + IF(MOD(KFLBA,2).EQ.0) WTAPE=4D0*WTAPE + IF(MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN + WTAP(KFLB)=WTFF*WTAP(KFLB) + WTAP(21)=WTGF*WTAP(21) + WTAPE=WTFF*WTAPE + ENDIF + IF(MSTP(61).EQ.1) WTAPE=0D0 + IF (KSVCB.GE.1) THEN +C...Kill normal creation but add joining diagrams for cmp quark. + WTAP(21)=0D0 + IF (KFLBA.EQ.4.OR.KFLBA.EQ.5) THEN + CALL PYERRM(9,'(PYPTIS:) Sorry, I got a heavy companion'// + & " quark here. Not handled yet, giving up!") + PT2=0D0 + MINT(51)=1 + RETURN + ENDIF +C...Check for possible joinings + IF (MSTP(96).NE.0.AND.MJOIND(JS,MI).EQ.0) THEN +C...Find companion's companion. + MJ=0 + 160 MJ=MJ+1 + IF (IMI(JS,MJ,2).NE.IMI(JS,MI,1)) GOTO 160 + IF (MJOIND(JS,MJ).EQ.0) THEN + Y(MI)=YB+YS + Z=YB/Y(MI) + WTAPJ(MJ)=Z*(1D0-Z)*0.5D0*(Z**2+(1D0-Z)**2) + IF (WTAPJ(MJ).GT.1D-6) THEN + NJN=1 + ELSE + WTAPJ(MJ)=0D0 + ENDIF + ENDIF +C...Add trial gluon joinings. + DO 170 MJ=1,MINT(31) + KFLC=K(IMI(JS,MJ,1),2) + IF (KFLC.NE.21.OR.MJOIND(JS,MJ).NE.0) GOTO 170 + Z=XMI(JS,MJ)/(XMI(JS,MI)+XMI(JS,MJ)) + WTAPJ(MJ)=6D0*(Z**2+(1D0-Z)**2) + IF (WTAPJ(MJ).GT.1D-6) THEN + NJN=NJN+1 + ELSE + WTAPJ(MJ)=0D0 + ENDIF + 170 CONTINUE + ENDIF + ELSEIF (IMI(JS,MI,2).GE.0) THEN +C...Kill creation diagram for val quarks and sea quarks with companions. + WTAP(21)=0D0 + ELSEIF (MQMASS.EQ.0) THEN +C...Extra safety factor for massless sea quark creation. + WTAP(21)=WTAP(21)*1.25D0 + ENDIF + +C... q -> g, g -> g. + ELSEIF(KFLB.EQ.21) THEN +C...Here we decide later whether a quark picked up is valence or +C...sea, so we maintain the extra factor sqrt(z) since we deal +C...with the *sum* of sea and valence in this context. + WTAPQ=(16D0/3D0)*(SQRT(1D0/ZMIN)-SQRT(1D0/ZMAX)) +C...new: do not allow backwards evol to pick up heavy flavour. + DO 180 KFL=1,MIN(3,MSTP(58)) + WTAP(KFL)=WTAPQ + WTAP(-KFL)=WTAPQ + 180 CONTINUE + WTAP(21)=6D0*LOG(ZMAX*(1D0-ZMIN)/(ZMIN*(1D0-ZMAX))) + IF(MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN + WTAPQ=WTFG*WTAPQ + WTAP(21)=WTGG*WTAP(21) + ENDIF +C...Check for possible joinings (companions handled separately above) + IF (MSTP(96).NE.0.AND.MINT(31).GE.2.AND.MJOIND(JS,MI).EQ.0) + & THEN + DO 190 MJ=1,MINT(31) + IF (MJ.EQ.MI.OR.MJOIND(JS,MJ).NE.0) GOTO 190 + KSVCC=IMI(JS,MJ,2) + IF (IMI(JS,MJ,2).GT.IMISEP(MJ)) KSVCC=-1 + IF (KSVCC.GE.1) GOTO 190 + KFLC=K(IMI(JS,MJ,1),2) +C...Only try g -> g + g once. + IF (MJ.GT.MI.AND.KFLC.EQ.21) GOTO 190 + Z=XMI(JS,MJ)/(XMI(JS,MI)+XMI(JS,MJ)) + IF (KFLC.EQ.21) THEN + WTAPJ(MJ)=6D0*(Z**2+(1D0-Z)**2) + ELSE + WTAPJ(MJ)=Z*4D0/3D0*(1D0+Z**2) + ENDIF + IF (WTAPJ(MJ).GT.1D-6) THEN + NJN=NJN+1 + ELSE + WTAPJ(MJ)=0D0 + ENDIF + 190 CONTINUE + ENDIF + ENDIF + +C...Initialize massive quark evolution + IF (MQMASS.NE.0) THEN + RML=(RMQ2+VINT(18))/ALAM2 + TML=LOG(RML) + TPL=LOG((PT2+VINT(18))/ALAM2) + TPM=LOG((PT2+VINT(18))/RMQ2) + WN=WTAP(21)*WPDF0/B0 + ENDIF + + +C...Loopback point for iteration + NTRY=0 + NTHRES=0 + 200 NTRY=NTRY+1 + IF(NTRY.GT.500) THEN + CALL PYERRM(9,'(PYPTIS:) failed to evolve shower.') + MINT(51)=1 + RETURN + ENDIF + +C... Calculate PDF weights and sum for evolution rate. + WTSUM=0D0 + XFBO=MAX(1D-10,XFB(KFLB)) + DO 210 KFL=-5,5 + WTPDF(KFL)=XFB(KFL)/XFBO + WTSUM=WTSUM+WTAP(KFL)*WTPDF(KFL) + 210 CONTINUE +C...Only add gluon mother diagram for massless KFLB. + IF(MQMASS.EQ.0) THEN + WTPDF(21)=XFB(21)/XFBO + WTSUM=WTSUM+WTAP(21)*WTPDF(21) + ENDIF + WTSUM=MAX(0.0001D0,WTSUM) + WTSUMS=WTSUM +C...Add joining diagrams where applicable. + WTJOIN=0D0 + IF (MSTP(96).NE.0.AND.NJN.NE.0) THEN + DO 220 MJ=1,MINT(31) + IF (WTAPJ(MJ).LT.1D-3) GOTO 220 + WTPDFJ(MJ)=1D0/XFBO +C...x and x*pdf (+ sea/val) for parton C. + KFLC=K(IMI(JS,MJ,1),2) + KFLCA=IABS(KFLC) + KSVCC=MAX(-1,IMI(JS,MJ,2)) + IF (IMI(JS,MJ,2).GT.IMISEP(MJ)) KSVCC=-1 + MINT(30)=JS + MINT(36)=MJ + CALL PYPDFU(KFBEAM(JS),X1(MJ),PT2,XFJ) + MINT(36)=MI + IF (KFLCA.LE.6.AND.KSVCC.LE.0) THEN + XFJ(KFLC)=XPSVC(KFLC,KSVCC) + ELSEIF (KSVCC.GE.1) THEN + print*, 'error! parton C is companion!' + ENDIF + WTPDFJ(MJ)=WTPDFJ(MJ)/XFJ(KFLC) +C...x and x*pdf (+ sea/val) for parton A. + KFLA=21 + KSVCA=0 + IF (KFLCA.EQ.21.AND.KFLBA.LE.5) THEN + KFLA=KFLB + KSVCA=KSVCB + ELSEIF (KFLBA.EQ.21.AND.KFLCA.LE.5) THEN + KFLA=KFLC + KSVCA=KSVCC + ENDIF + MINT(30)=JS + IF (KSVCA.LE.0) THEN +C...Consider C the "evolved" parton if B is gluon. Val/sea +C...counting will then be done correctly in PYPDFU. + IF (KFLBA.EQ.21) MINT(36)=MJ + CALL PYPDFU(KFBEAM(JS),Y(MJ),PT2,XFJ) + MINT(36)=MI + IF (IABS(KFLA).LE.6) XFJ(KFLA)=XPSVC(KFLA,KSVCA) + ELSE +C...If parton A is companion, use Y(MI) and YS in call to PYFCMP. + XFJ(KFLA)=PYFCMP(Y(MI)/VINT(140),YS/VINT(140),MSTP(87)) + ENDIF + WTPDFJ(MJ)=XFJ(KFLA)*WTPDFJ(MJ) + WTJOIN=WTJOIN+WTAPJ(MJ)*WTPDFJ(MJ) + 220 CONTINUE + ENDIF + +C...Pick normal pT2 (in overestimated z range). + 230 PT2OLD=PT2 + WTSUM=WTSUMS + PT2=ALAM2*((PT2+VINT(18))/ALAM2)**(PYR(0)**(B0/WTSUM))-VINT(18) + KFLC=21 + +C...Evolve q -> q gamma separately, pick it if larger pT. + IF(KFLBA.LE.5.AND.MSTP(61).GE.2) THEN + PT2QED=(PT2OLD+VINT(18))*PYR(0)**(1D0/(AEM2PI*WTAPE))-VINT(18) + IF(PT2QED.GT.PT2) THEN + PT2=PT2QED + KFLC=22 + KFLA=KFLB + ENDIF + ENDIF + +C... Evolve massive quark creation separately. + MCRQQ=0 + IF (MQMASS.NE.0) THEN + PT2CR=(RMQ2+VINT(18))*(RML**(TPM/(TPL*PYR(0)**(-TML/WN)-TPM))) + & -VINT(18) +C...If massive quark also on opposite side, ensure sufficient remaining +C...phase space also for creation of that quark + TMINQQ = TMIN + KFLOPP = K(IMI(3-JS,MI,1),2) + IF (ABS(KFLOPP).EQ.4.OR.ABS(KFLOPP).EQ.5) TMINQQ = 1.05 +C...Ensure mininimum PT2CR and force creation near threshold. + IF (PT2CR.LT.TMINQQ*RMQ2) THEN + NTHRES=NTHRES+1 + IF (NTHRES.GT.50) THEN + CALL PYERRM(9,'(PYPTIS:) no phase space left for '// + & 'massive quark creation. Gave up trying.') + MINT(51)=1 +C...Special return code if failing before any evolution at all: bad event + IF (NISGEN(1,MI).EQ.0.AND.NISGEN(2,MI).EQ.0) MINT(51)=2 + RETURN + ENDIF + PT2=0D0 + PT2CR=TMINQQ*RMQ2 +C...Signal that massive quark creation is being forced + MCRQQ=2 + ENDIF +C... Select largest PT2 (brems or creation): + IF (PT2CR.GT.PT2) THEN + MCRQQ=MAX(MCRQQ,1) + WTSUM=0D0 + PT2=PT2CR + KFLA=21 + ELSE + MCRQQ=0 + KFLA=KFLB + ENDIF +C... Compute logarithms for this PT2 + TPL=LOG((PT2+VINT(18))/ALAM2) + TPM=LOG((PT2+VINT(18))/(RMQ2+VINT(18))) + WTCRQQ=TPM/LOG(PT2/RMQ2) + ENDIF + +C...Evolve joining separately + MJOIN=0 + IF (MSTP(96).NE.0.AND.NJN.NE.0) THEN + PT2JN=ALAM2*((PT2OLD+VINT(18))/ALAM2)**(PYR(0)**(B0/WTJOIN)) + & -VINT(18) + IF (PT2JN.GE.PT2) THEN + MJOIN=1 + PT2=PT2JN + ENDIF + ENDIF + +C...Loopback if crossed c/b mass thresholds. + IF(IZRG.EQ.3.AND.PT2.LT.RMB2) THEN + PT2=RMB2 + GOTO 130 + ELSEIF(IZRG.EQ.2.AND.PT2.LT.RMC2) THEN + PT2=RMC2 + GOTO 130 + ENDIF + +C...Speed up shower. Skip if higher-PT acceptable branching +C...already found somewhere else. +C...Also finish if below lower cutoff. + + IF ((PT2-PT2MX).LT.-0.001.OR.PT2.LT.PT2CUT) RETURN + +C...Select parton A flavour (massive Q handled above.) + IF (MQMASS.EQ.0.AND.KFLC.NE.22.AND.MJOIN.EQ.0) THEN + WTRAN=PYR(0)*WTSUM + KFLA=-6 + 240 KFLA=KFLA+1 + WTRAN=WTRAN-WTAP(KFLA)*WTPDF(KFLA) + IF(KFLA.LE.5.AND.WTRAN.GT.0D0) GOTO 240 + IF(KFLA.EQ.6) KFLA=21 + ELSEIF (MJOIN.EQ.1) THEN +C...Tentative joining accept/reject. + WTRAN=PYR(0)*WTJOIN + MJ=0 + 250 MJ=MJ+1 + WTRAN=WTRAN-WTAPJ(MJ)*WTPDFJ(MJ) + IF(MJ.LE.MINT(31)-1.AND.WTRAN.GT.0D0) GOTO 250 + IF(MJOIND(JS,MJ).NE.0.OR.MJOIND(JS,MI).NE.0) THEN + CALL PYERRM(9,'(PYPTIS:) Attempted double joining.'// + & ' Rejected.') + GOTO 230 + ENDIF +C...x*pdf (+ sea/val) at new pT2 for parton B. + IF (KSVCB.LE.0) THEN + MINT(30)=JS + CALL PYPDFU(KFBEAM(JS),XB,PT2,XFB) + IF (KFLBA.LE.6) XFB(KFLB)=XPSVC(KFLB,KSVCB) + ELSE +C...Companion distributions do not evolve. + XFB(KFLB)=XFBO + ENDIF + WTVETO=1D0/WTPDFJ(MJ)/XFB(KFLB) + KFLC=K(IMI(JS,MJ,1),2) + KFLCA=IABS(KFLC) + KSVCC=MAX(-1,IMI(JS,MJ,2)) + IF (KSVCB.GE.1) KSVCC=-1 +C...x*pdf (+ sea/val) at new pT2 for parton C. + MINT(30)=JS + MINT(36)=MJ + CALL PYPDFU(KFBEAM(JS),X1(MJ),PT2,XFJ) + MINT(36)=MI + IF (KFLCA.LE.6.AND.KSVCC.LE.0) XFJ(KFLC)=XPSVC(KFLC,KSVCC) + WTVETO=WTVETO/XFJ(KFLC) +C...x and x*pdf (+ sea/val) at new pT2 for parton A. + KFLA=21 + KSVCA=0 + IF (KFLCA.EQ.21.AND.KFLBA.LE.5) THEN + KFLA=KFLB + KSVCA=KSVCB + ELSEIF (KFLBA.EQ.21.AND.KFLCA.LE.5) THEN + KFLA=KFLC + KSVCA=KSVCC + ENDIF + IF (KSVCA.LE.0) THEN + MINT(30)=JS + IF (KFLB.EQ.21) MINT(36)=MJ + CALL PYPDFU(KFBEAM(JS),Y(MJ),PT2,XFJ) + MINT(36)=MI + IF (IABS(KFLA).LE.6) XFJ(KFLA)=XPSVC(KFLA,KSVCA) + ELSE + XFJ(KFLA)=PYFCMP(Y(MJ)/VINT(140),YS/VINT(140),MSTP(87)) + ENDIF + WTVETO=WTVETO*XFJ(KFLA) +C...Monte Carlo veto. + IF (WTVETO.LT.PYR(0)) GOTO 200 +C...If accept, save PT2 of this joining. + IF (PT2.GT.PT2MX) THEN + PT2MX=PT2 + JSMX=2+JS + MJN1MX=MJ + MJN2MX=MI + WTAPJ(MJ)=0D0 + NJN=0 + ENDIF +C...Exit and continue evolution. + GOTO 390 + ENDIF + KFLAA=IABS(KFLA) + +C...Choose z value (still in overestimated range) and corrective weight. +C...Unphysical z will be rejected below when Q2 has is computed. + WTZ=0D0 + +C...Note: ME and MQ>0 give corrections to overall weights, not shapes. +C...q -> q + g or q -> q + gamma (already set which). + IF (KFLAA.LE.5.AND.KFLBA.LE.5) THEN + IF (KSVCB.LT.0) THEN + Z=1D0-(1D0-ZMIN)*((1D0-ZMAX)/(1D0-ZMIN))**PYR(0) + ELSE + ZFAC=RMIN*(RMAX/RMIN)**PYR(0) + Z=((1-ZFAC)/(1+ZFAC))**2 + ENDIF + WTZ=0.5D0*(1D0+Z**2) +C...Massive weight correction. + IF (KFLBA.GE.4) WTZ=WTZ-Z*(1D0-Z)**2*RMQ2/PT2 +C...Valence quark weight correction (extra sqrt) + IF (KSVCB.GE.0) WTZ=WTZ*SQRT(Z) + +C...q -> g + q. +C...NB: MQ>0 not yet implemented. Forced absent above. + ELSEIF (KFLAA.LE.5.AND.KFLB.EQ.21) THEN + KFLC=KFLA + Z=ZMAX/(1D0+PYR(0)*(SQRT(ZMAX/ZMIN)-1D0))**2 + WTZ=0.5D0*(1D0+(1D0-Z)**2)*SQRT(Z) + +C...g -> q + qbar. + ELSEIF (KFLA.EQ.21.AND.KFLBA.LE.5) THEN + KFLC=-KFLB + Z=ZMIN+PYR(0)*(ZMAX-ZMIN) + WTZ=Z**2+(1D0-Z)**2 +C...Massive correction + IF (MQMASS.NE.0) THEN + WTZ=WTZ+2D0*Z*(1D0-Z)*RMQ2/PT2 +C...Extra safety margin for light sea quark creation + ELSEIF (KSVCB.LT.0) THEN + WTZ=WTZ/1.25D0 + ENDIF + +C...g -> g + g. + ELSEIF (KFLA.EQ.21.AND.KFLB.EQ.21) THEN + KFLC=21 + Z=1D0/(1D0+((1D0-ZMIN)/ZMIN)*((1D0-ZMAX)*ZMIN/ + & (ZMAX*(1D0-ZMIN)))**PYR(0)) + WTZ=(1D0-Z*(1D0-Z))**2 + ENDIF + +C...Derive Q2 from pT2. + Q2B=PT2/(1D0-Z) + IF (KFLBA.GE.4) Q2B=Q2B-RMQ2 + +C...Loopback if outside allowed z range for given pT2. + RM2C=PYMASS(KFLC)**2 + PT2ADJ=Q2B-Z*(SHTNOW(MI)+Q2B)*(Q2B+RM2C)/SHTNOW(MI) + IF (PT2ADJ.LT.1D-6) GOTO 230 + +C...Size of phase space and coherence suppression: MSTP(67) and MSTP(62) +C...No modification for very first emission if using ME correction + MSTP67 = MSTP(67) + IF (MECOR.GE.1.AND.NISGEN(1,MI).EQ.0.AND.NISGEN(2,MI).EQ.0) THEN + MSTP67 = 0 + ENDIF + +C...For 1st branching, limit phase space by s-hat with color-partner + IF (MSTP67.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN + MSIDE=1 + IDIP=IMI(JS,MI,1) +C...Use anticolor tag for antiquark, or for gluon half the time + IF ((KFLB.LT.0.AND.KFLBA.LT.10).OR.( + & KFLB.EQ.21.AND.PYR(0).GT.0.5)) MSIDE=2 +C...Tag + MCTAG=MCT(IDIP,MSIDE) +C...Default is to set up phase space using the opposite incoming parton + JDIP=IMI(3-JS,MI,1) + NDIP=0 +C...Alternatively, look for final-state color partner (pick first if several) + DO 260 IFS=1,NPART + IF (MCT(IPART(IFS),MSIDE).EQ.MCTAG.AND.NDIP.EQ.0) THEN + JDIP=IPART(IFS) + NDIP=NDIP+1 + ENDIF + 260 CONTINUE +C...Compute momentum transfer: sdip = -t = - (p1 - p2)^2 +C...(also works for annihilation since incoming massless, so shat = -(p1 - p2)^2) + SDIP=ABS(((P(IDIP,4)-P(JDIP,4))**2-(P(IDIP,3)-P(JDIP,3))**2 + & -(P(IDIP,2)-P(JDIP,2))**2-(P(IDIP,1)-P(JDIP,1))**2)) + IF (MSTP67.EQ.1) THEN +C...1 Option to completely kill radiation above s_dip * PARP(67) + IF (4D0*PT2.GT.PARP(67)*SDIP) GOTO 230 + ELSE IF (MSTP67.EQ.2) THEN +C...2 Option to allow suppressed unordered radiation above s_dip * PARP(67) +C... (-> improved power showers?) + IF (4D0*PT2*PYR(0).GT.PARP(67)*SDIP) GOTO 230 + ENDIF + +C...For subsequent branchings, loopback if nonordered in angle/rapidity + ELSE IF (MSTP(62).GE.3.AND.NISGEN(JS,MI).GE.1) THEN + IF(PT2.GT.((1D0-Z)/(Z*(1D0-ZSAV(JS,MI))))**2*PT2SAV(JS,MI)) + & GOTO 230 + ENDIF + +C...Select phi angle of branching at random. + PHI=PARU(2)*PYR(0) + +C...Matrix-element corrections for some processes. + IF (MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN + IF (KFLAA.LE.20.AND.KFLBA.LE.20) THEN + CALL PYMEWT(MECOR,1,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME) + WTZ=WTZ*WTME/WTFF + ELSEIF((KFLA.EQ.21.OR.KFLA.EQ.22).AND.KFLBA.LE.20) THEN + CALL PYMEWT(MECOR,2,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME) + WTZ=WTZ*WTME/WTGF + ELSEIF(KFLAA.LE.20.AND.(KFLB.EQ.21.OR.KFLB.EQ.22)) THEN + CALL PYMEWT(MECOR,3,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME) + WTZ=WTZ*WTME/WTFG + ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN + CALL PYMEWT(MECOR,4,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME) + WTZ=WTZ*WTME/WTGG + ENDIF + ENDIF + +C...Parton distributions at new pT2 but old x. + MINT(30)=JS + CALL PYPDFU(KFBEAM(JS),XB,PT2,XFN) +C...Treat val and cmp separately + IF (KFLBA.LE.6.AND.KSVCB.LE.0) XFN(KFLB)=XPSVC(KFLB,KSVCB) + IF (KSVCB.GE.1) + & XFN(KFLB)=PYFCMP(YB/VINT(140),YS/VINT(140),MSTP(87)) + XFBN=XFN(KFLB) + IF(XFBN.LT.1D-20) THEN + IF(KFLA.EQ.KFLB) THEN + WTAP(KFLB)=0D0 + GOTO 200 + ELSE + XFBN=1D-10 + XFN(KFLB)=XFBN + ENDIF + ENDIF + DO 270 KFL=-5,5 + XFB(KFL)=XFN(KFL) + 270 CONTINUE + XFB(21)=XFN(21) + +C...Parton distributions at new pT2 and new x. + XA=XB/Z + MINT(30)=JS + CALL PYPDFU(KFBEAM(JS),XA,PT2,XFA) + IF (KFLBA.LE.5.AND.KFLAA.LE.5) THEN +C...q -> q + g: only consider respective sea, val, or cmp content. + IF (KSVCB.LE.0) THEN + XFA(KFLA)=XPSVC(KFLA,KSVCB) + ELSE + YA=XA*(1D0-YS) + XFA(KFLB)=PYFCMP(YA/VINT(140),YS/VINT(140),MSTP(87)) + ENDIF + ENDIF + XFAN=XFA(KFLA) + IF(XFAN.LT.1D-20) THEN + GOTO 200 + ENDIF + +C...If weighting fails continue evolution. + WTTOT=0D0 + IF (MCRQQ.EQ.0) THEN + WTPDFA=1D0/WTPDF(KFLA) + WTTOT=WTZ*XFAN/XFBN*WTPDFA + ELSEIF(MCRQQ.EQ.1) THEN + WTPDFA=TPM/WPDF0 + WTTOT=WTCRQQ*WTZ*XFAN/XFBN*WTPDFA + XBEST=TPM/TPM0*XQ0 + ELSEIF(MCRQQ.EQ.2) THEN +C...Force massive quark creation. + WTTOT=1D0 + ENDIF + +C...Loop back if trial emission fails. + IF(WTTOT.GE.0D0.AND.WTTOT.LT.PYR(0)) GOTO 200 + WTACC=((1D0+PT2)/(0.25D0+PT2))**2 + IF(WTTOT.LT.0D0) THEN + WRITE(CHWT,'(1P,E12.4)') WTTOT + CALL PYERRM(19,'(PYPTIS:) Weight '//CHWT//' negative') + ELSEIF(WTTOT.GT.WTACC) THEN + WRITE(CHWT,'(1P,E12.4)') WTTOT + IF (PT2.GT.PTEMAX.OR.WTTOT.GE.WTEMAX) THEN +C...Too high weight: write out as error, but do not update error counter + IF(MSTU(29).EQ.0) MSTU(23)=MSTU(23)-1 + CALL PYERRM(19, + & '(PYPTIS:) Weight '//CHWT//' above unity') + IF (PT2.GT.PTEMAX) PTEMAX=PT2 + IF (WTTOT.GT.WTEMAX) WTEMAX=WTTOT + ELSE + CALL PYERRM(9, + & '(PYPTIS:) Weight '//CHWT//' above unity') + ENDIF +C...Useful for debugging but commented out for distribution: +C print*, 'JS, MI',JS, MI +C print*, 'PT:',SQRT(PT2), ' MCRQQ',MCRQQ +C print*, 'A -> B C',KFLA, KFLB, KFLC +C XFAO=XFBO/WTPDFA +C print*, 'WT(Z,XFA,XFB)',WTZ, XFAN/XFAO, XFBO/XFBN + ENDIF + +C...Special for PT2 = PT2MX (e.g., if two incoming massive quarks +C...simultaneously reached their creation thresholds) + IF (ABS(PT2-PT2MX).LT.0.001) THEN + IF (PYR(0).GT.0.5) PT2=1.0001*PT2MX + ENDIF + +C...Save acceptable branching. + IF(PT2.GT.PT2MX) THEN + MIMX=MINT(36) + JSMX=JS + PT2MX=PT2 + KFLAMX=KFLA + KFLCMX=KFLC + RM2CMX=RM2C + Q2BMX=Q2B + ZMX=Z + PT2AMX=PT2ADJ + PHIMX=PHI + ENDIF + +C---------------------------------------------------------------------- +C...MODE= 1: Accept stored shower branching. Update event record etc. + ELSEIF (MODE.EQ.1) THEN + MI=MIMX + JS=JSMX + SHAT=SHTNOW(MI) + SIDE=3D0-2D0*JS +C...Shift down rest of event record to make room for insertion. + IT=IMISEP(MI)+1 + IM=IT+1 + IS=IMI(JS,MI,1) + DO 290 I=N,IT,-1 + IF (K(I,3).GE.IT) K(I,3)=K(I,3)+2 + KT1=K(I,4)/MSTU(5)**2 + KT2=K(I,5)/MSTU(5)**2 + ID1=MOD(K(I,4),MSTU(5)) + ID2=MOD(K(I,5),MSTU(5)) + IM1=MOD(K(I,4)/MSTU(5),MSTU(5)) + IM2=MOD(K(I,5)/MSTU(5),MSTU(5)) + IF (ID1.GE.IT) ID1=ID1+2 + IF (ID2.GE.IT) ID2=ID2+2 + IF (IM1.GE.IT) IM1=IM1+2 + IF (IM2.GE.IT) IM2=IM2+2 + K(I,4)=KT1*MSTU(5)**2+IM1*MSTU(5)+ID1 + K(I,5)=KT2*MSTU(5)**2+IM2*MSTU(5)+ID2 + DO 280 IX=1,5 + K(I+2,IX)=K(I,IX) + P(I+2,IX)=P(I,IX) + V(I+2,IX)=V(I,IX) + 280 CONTINUE + MCT(I+2,1)=MCT(I,1) + MCT(I+2,2)=MCT(I,2) + 290 CONTINUE + N=N+2 +C...Also update shifted-down pointers in IMI, IMISEP, and IPART. + DO 300 JI=1,MINT(31) + IF (IMI(1,JI,1).GE.IT) IMI(1,JI,1)=IMI(1,JI,1)+2 + IF (IMI(1,JI,2).GE.IT) IMI(1,JI,2)=IMI(1,JI,2)+2 + IF (IMI(2,JI,1).GE.IT) IMI(2,JI,1)=IMI(2,JI,1)+2 + IF (IMI(2,JI,2).GE.IT) IMI(2,JI,2)=IMI(2,JI,2)+2 + IF (JI.GE.MI) IMISEP(JI)=IMISEP(JI)+2 +C...Also update companion pointers to the present mother. + IF (IMI(JS,JI,2).EQ.IS) IMI(JS,JI,2)=IM + 300 CONTINUE + DO 310 IFS=1,NPART + IF (IPART(IFS).GE.IT) IPART(IFS)=IPART(IFS)+2 + 310 CONTINUE +C...Zero entries dedicated for new timelike and mother partons. + DO 330 I=IT,IT+1 + DO 320 J=1,5 + K(I,J)=0 + P(I,J)=0D0 + V(I,J)=0D0 + 320 CONTINUE + MCT(I,1)=0 + MCT(I,2)=0 + 330 CONTINUE + +C...Define timelike and new mother partons. History. + K(IT,1)=3 + K(IT,2)=KFLCMX + K(IM,1)=14 + K(IM,2)=KFLAMX + K(IS,3)=IM + K(IT,3)=IM +C...Set mother origin = side. + K(IM,3)=MINT(83)+JS+2 + IF(MI.GE.2) K(IM,3)=MINT(83)+JS + +C...Define colour flow of branching. + IM1=IM + IM2=IM +C...q -> q + gamma. + IF(K(IT,2).EQ.22) THEN + K(IT,1)=1 + ID1=IS + ID2=IS +C...q -> q + g. + ELSEIF(K(IM,2).GT.0.AND.K(IM,2).LE.5.AND.K(IT,2).EQ.21) THEN + ID1=IT + ID2=IS +C...q -> g + q. + ELSEIF(K(IM,2).GT.0.AND.K(IM,2).LE.5) THEN + ID1=IS + ID2=IT +C...qbar -> qbar + g. + ELSEIF(K(IM,2).LT.0.AND.K(IM,2).GE.-5.AND.K(IT,2).EQ.21) THEN + ID1=IS + ID2=IT +C...qbar -> g + qbar. + ELSEIF(K(IM,2).LT.0.AND.K(IM,2).GE.-5) THEN + ID1=IT + ID2=IS +C...g -> g + g; g -> q + qbar.. + ELSEIF((K(IT,2).EQ.21.AND.PYR(0).GT.0.5D0).OR.K(IT,2).LT.0) THEN + ID1=IS + ID2=IT + ELSE + ID1=IT + ID2=IS + ENDIF + IF(IM1.EQ.IM) K(IM1,4)=K(IM1,4)+ID1 + IF(IM2.EQ.IM) K(IM2,5)=K(IM2,5)+ID2 + K(ID1,4)=K(ID1,4)+MSTU(5)*IM1 + K(ID2,5)=K(ID2,5)+MSTU(5)*IM2 + IF(ID1.NE.ID2) THEN + K(ID1,5)=K(ID1,5)+MSTU(5)*ID2 + K(ID2,4)=K(ID2,4)+MSTU(5)*ID1 + ENDIF + IF(K(IT,1).EQ.1) THEN + K(IT,4)=0 + K(IT,5)=0 + ENDIF +C...Update IMI and colour tag arrays. + IMI(JS,MI,1)=IM + DO 340 MC=1,2 + MCT(IT,MC)=0 + MCT(IM,MC)=0 + 340 CONTINUE + DO 350 JCS=4,5 + KCS=JCS +C...If mother flag not yet set for spacelike parton, trace it. + IF (K(IS,KCS)/MSTU(5)**2.LE.1) CALL PYCTTR(IS,-KCS,IM) + IF(MINT(51).NE.0) RETURN + 350 CONTINUE + DO 360 JCS=4,5 + KCS=JCS +C...If mother flag not yet set for timelike parton, trace it. + IF (K(IT,KCS)/MSTU(5)**2.LE.1) CALL PYCTTR(IT,KCS,IM) + IF(MINT(51).NE.0) RETURN + 360 CONTINUE + +C...Boost recoiling parton to compensate for Q2 scale. + BETAZ=SIDE*(1D0-(1D0+Q2BMX/SHAT)**2)/ + & (1D0+(1D0+Q2BMX/SHAT)**2) + IR=IMI(3-JS,MI,1) + CALL PYROBO(IR,IR,0D0,0D0,0D0,0D0,BETAZ) + +C...Define system to be rotated and boosted +C...(not including the 2 just added partons) +C...(but including the docu lines for first interaction) + IMIN=IMISEP(MI-1)+1 + IF (MI.EQ.1) IMIN=MINT(83)+5 + IMAX=IMISEP(MI)-2 + +C...Rotate back system in phi to compensate for subsequent rotation. + CALL PYROBO(IMIN,IMAX,0D0,-PHIMX,0D0,0D0,0D0) + +C...Define kinematics of new partons in old frame. + IMAX=IMISEP(MI) + P(IM,1)=SQRT(PT2AMX)*SHAT/(ZMX*(SHAT+Q2BMX)) + P(IM,3)=0.5D0*SQRT(SHAT)*((SHAT-Q2BMX)/((SHAT + & +Q2BMX)*ZMX)+(Q2BMX+RM2CMX)/SHAT)*SIDE + P(IM,4)=SQRT(P(IM,1)**2+P(IM,3)**2) + P(IT,1)=P(IM,1) + P(IT,3)=P(IM,3)-0.5D0*(SHAT+Q2BMX)/SQRT(SHAT)*SIDE + P(IT,4)=SQRT(P(IT,1)**2+P(IT,3)**2+RM2CMX) + P(IT,5)=SQRT(RM2CMX) + +C...Update internal line, now spacelike + P(IS,1)=P(IM,1)-P(IT,1) + P(IS,2)=P(IM,2)-P(IT,2) + P(IS,3)=P(IM,3)-P(IT,3) + P(IS,4)=P(IM,4)-P(IT,4) + P(IS,5)=P(IS,4)**2-P(IS,1)**2-P(IS,2)**2-P(IS,3)**2 +C...Represent spacelike virtualities as -sqrt(abs(Q2)) . + IF (P(IS,5).LT.0D0) THEN + P(IS,5)=-SQRT(ABS(P(IS,5))) + ELSE + P(IS,5)=SQRT(P(IS,5)) + ENDIF + +C...Boost entire system and rotate to new frame. +C...(including docu lines) + BETAX=(P(IM,1)+P(IR,1))/(P(IM,4)+P(IR,4)) + BETAZ=(P(IM,3)+P(IR,3))/(P(IM,4)+P(IR,4)) + IF(BETAX**2+BETAZ**2.GE.1D0) THEN + CALL PYERRM(1,'(PYPTIS:) boost bigger than unity') + MINT(51)=1 + IFAIL=-1 + RETURN + ENDIF + CALL PYROBO(IMIN,IMAX,0D0,0D0,-BETAX,0D0,-BETAZ) + I1=IMI(1,MI,1) + THETA=PYANGL(P(I1,3),P(I1,1)) + CALL PYROBO(IMIN,IMAX,-THETA,PHIMX,0D0,0D0,0D0) + +C...Global statistics. + MINT(352)=MINT(352)+1 + VINT(352)=VINT(352)+SQRT(P(IT,1)**2+P(IT,2)**2) + IF (MINT(352).EQ.1) VINT(357)=SQRT(P(IT,1)**2+P(IT,2)**2) + +C...Add parton with relevant pT scale for timelike shower. + IF (K(IT,2).NE.22) THEN + NPART=NPART+1 + IPART(NPART)=IT + PTPART(NPART)=SQRT(PT2AMX) + ENDIF + +C...Update saved variables. + SHTNOW(MIMX)=SHTNOW(MIMX)/ZMX + NISGEN(JSMX,MIMX)=NISGEN(JSMX,MIMX)+1 + XMI(JSMX,MIMX)=XMI(JSMX,MIMX)/ZMX + PT2SAV(JSMX,MIMX)=PT2MX + ZSAV(JS,MIMX)=ZMX + + KSA=IABS(K(IS,2)) + KMA=IABS(K(IM,2)) + IF (KSA.EQ.21.AND.KMA.GE.1.AND.KMA.LE.5) THEN +C...Gluon reconstructs to quark. +C...Decide whether newly created quark is valence or sea: + MINT(30)=JS + CALL PYPTMI(2,PT2NOW,PTDUM1,PTDUM2,IFAIL) + IF(MINT(51).NE.0) RETURN + ENDIF + IF(KSA.GE.1.AND.KSA.LE.5.AND.KMA.EQ.21) THEN +C...Quark reconstructs to gluon. +C...Now some guy may have lost his companion. Check. + ICMP=IMI(JS,MI,2) + IF (ICMP.GT.0) THEN + CALL PYERRM(9,'(PYPTIS:) Sorry, companion quark radiated' + & //' away. Cannot handle that yet. Giving up.') + MINT(51)=1 + RETURN + ELSEIF(ICMP.LT.0) THEN +C...A sea quark with companion still in BR was reconstructed to a gluon. +C...Companion should now be removed from the beam remnant. +C...(Momentum integral is automatically updated in next call to PYPDFU.) + ICMP=-ICMP + IFL=-K(IS,2) + DO 380 JCMP=ICMP,NVC(JS,IFL)-1 + XASSOC(JS,IFL,JCMP)=XASSOC(JS,IFL,JCMP+1) + DO 370 JI=1,MINT(31) + KMI=-IMI(JS,JI,2) + JFL=-K(IMI(JS,JI,1),2) + IF (KMI.EQ.JCMP+1.AND.JFL.EQ.IFL) IMI(JS,JI,2)=IMI(JS,JI + & ,2)+1 + 370 CONTINUE + 380 CONTINUE + NVC(JS,IFL)=NVC(JS,IFL)-1 + ENDIF +C...Set gluon IMI(JS,MI,2) = 0. + IMI(JS,MI,2)=0 + ELSEIF(KSA.GE.1.AND.KSA.LE.5.AND.KMA.NE.21) THEN +C...Quark reconstructing to quark. If sea with companion still in BR +C...then update associated x value. +C...(Momentum integral is automatically updated in next call to PYPDFU.) + IF (IMI(JS,MI,2).LT.0) THEN + ICMP=-IMI(JS,MI,2) + IFL=-K(IS,2) + XASSOC(JS,IFL,ICMP)=XMI(JSMX,MIMX) + ENDIF + ENDIF + + ENDIF + +C...If reached this point, normal exit. + 390 IFAIL=0 + + RETURN + END + +C********************************************************************* + +C...PYMEMX +C...Generates maximum ME weight in some initial-state showers. +C...Inparameter MECOR: kind of hard scattering process +C...Outparameter WTFF: maximum weight for fermion -> fermion +C... WTGF: maximum weight for gluon/photon -> fermion +C... WTFG: maximum weight for fermion -> gluon/photon +C... WTGG: maximum weight for gluon -> gluon + + SUBROUTINE PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) + SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINT2/ + +C...Default maximum weight. + WTFF=1D0 + WTGF=1D0 + WTFG=1D0 + WTGG=1D0 + +C...Select maximum weight by process. + IF(MECOR.EQ.1) THEN + WTFF=1D0 + WTGF=3D0 + ELSEIF(MECOR.EQ.2) THEN + WTFG=1D0 + WTGG=1D0 + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYMEWT +C...Calculates actual ME weight in some initial-state showers. +C...Inparameter MECOR: kind of hard scattering process +C... IFLCB: flavour combination of branching, +C... 1 for fermion -> fermion, +C... 2 for gluon/photon -> fermion +C... 3 for fermion -> gluon/photon, +C... 4 for gluon -> gluon +C... Q2: Q2 value of shower branching +C... Z: Z value of branching +C...In+outparameter PHIBR: azimuthal angle of branching +C...Outparameter WTME: actual ME weight + + SUBROUTINE PYMEWT(MECOR,IFLCB,Q2,Z,PHIBR,WTME) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) + SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINT2/ + +C...Default output. + WTME=1D0 + +C...Define kinematics of shower branching in Mandelstam variables. + SQM=VINT(44) + SH=SQM/Z + TH=-Q2 + UH=Q2-SQM*(1D0-Z)/Z + +C...Matrix-element corrections for f + fbar -> s-channel vector boson. + IF(MECOR.EQ.1) THEN + IF(IFLCB.EQ.1) THEN + WTME=(TH**2+UH**2+2D0*SQM*SH)/(SH**2+SQM**2) + ELSEIF(IFLCB.EQ.2) THEN + WTME=(SH**2+TH**2+2D0*SQM*UH)/((SH-SQM)**2+SQM**2) + ENDIF + +C...Matrix-element corrections for g + g -> Higgs (h0, H0, A0). + ELSEIF(MECOR.EQ.2) THEN + IF(IFLCB.EQ.3) THEN + WTME=(SH**2+UH**2)/(SH**2+(SH-SQM)**2) + ELSEIF(IFLCB.EQ.4) THEN + WTME=0.5D0*(SH**4+UH**4+TH**4+SQM**4)/(SH**2-SQM*(SH-SQM))**2 + ENDIF + +C...Matrix-element corrections for q + qbar -> Higgs (h0) + ELSEIF(MECOR.EQ.3) THEN + IF(IFLCB.EQ.2) THEN + WTME=(SH**2+TH**2+2D0*(SQM-TH)*(SQM-SH))/ + 1 (SH**2+2D0*SQM*(SQM-SH)) + ENDIF + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYPTMI +C...Handles the generation of additional interactions in the new +C...multiple interactions framework. +C...MODE=-1 : Initalize MI from scratch. +C...MODE= 0 : Generate trial interaction. Start at PT2NOW, solve +C... Sudakov for PT2, abort if below PT2CUT. +C...MODE= 1 : Accept interaction at PT2NOW and store variables. +C...MODE= 2 : Decide sea/val/cmp for kicked-out quark at PT2NOW +C...PT2NOW : Starting (max) PT2 scale for evolution. +C...PT2CUT : Lower limit for evolution. +C...PT2 : Result of evolution. Generated PT2 for trial interaction. +C...IFAIL : Status return code. +C... = 0: All is well. +C... < 0: Phase space exhausted, generation to be terminated. +C... > 0: Additional interaction vetoed, but continue evolution. + + SUBROUTINE PYPTMI(MODE,PT2NOW,PT2CUT,PT2,IFAIL) +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement for maximum size of showers. + PARAMETER (MAXNUR=1000) +C...Commonblocks. + COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR) + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) + COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000) + COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) + COMMON/PYINT7/SIGT(0:6,0:6,0:5) + COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6), + & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1), + & XMI(2,240),PT2MI(240),IMISEP(0:240) + COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240), + & PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX + COMMON/PYCTAG/NCT,MCT(4000,2) +C...Local arrays and saved variables. + DIMENSION WDTP(0:400),WDTE(0:400,0:5),XPQ(-25:25) + + SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/, + & /PYINT1/,/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/,/PYINTM/, + & /PYISMX/,/PYCTAG/ + SAVE NCHN,XT2FAC,SIGS + + IFAIL=0 +C...Set MI subprocess = QCD 2 -> 2. + ISUB=96 + +C---------------------------------------------------------------------- +C...MODE=-1: Initialize from scratch + IF (MODE.EQ.-1) THEN +C...Initialize PT2 array. + PT2MI(1)=VINT(54) +C...Initialize list of incoming beams and partons from two sides. + DO 110 JS=1,2 + DO 100 MI=1,240 + IMI(JS,MI,1)=0 + IMI(JS,MI,2)=0 + 100 CONTINUE + NMI(JS)=1 + IMI(JS,1,1)=MINT(84)+JS + IMI(JS,1,2)=0 + XMI(JS,1)=VINT(40+JS) +C...Rescale x values to fractions of photon energy. + IF(MINT(18+JS).EQ.1) XMI(JS,1)=VINT(40+JS)/VINT(154+JS) +C...Hard reset: hard interaction initiators motherless by definition. + K(MINT(84)+JS,3)=2+JS + K(MINT(84)+JS,4)=MOD(K(MINT(84)+JS,4),MSTU(5)) + K(MINT(84)+JS,5)=MOD(K(MINT(84)+JS,5),MSTU(5)) + 110 CONTINUE + IMISEP(0)=MINT(84) + IMISEP(1)=N + IF (MOD(MSTP(81),10).GE.1) THEN + IF(MSTP(82).LE.1) THEN + SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0 + & ,5)) + IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT* + & VINT(317)/(VINT(318)*VINT(320)) + XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149)) + ELSE + XT2FAC=VINT(146)*VINT(148)*XSEC(ISUB,1)/ + & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149)) + ENDIF + ENDIF +C...Zero entries relating to scatterings beyond the first. + DO 120 MI=2,240 + IMI(1,MI,1)=0 + IMI(2,MI,1)=0 + IMI(1,MI,2)=0 + IMI(2,MI,2)=0 + IMISEP(MI)=IMISEP(1) + PT2MI(MI)=0D0 + XMI(1,MI)=0D0 + XMI(2,MI)=0D0 + 120 CONTINUE +C...Initialize factors for PDF reshaping. + DO 140 JS=1,2 + KFBEAM(JS)=MINT(10+JS) + IF(MINT(18+JS).EQ.1) KFBEAM(JS)=22 + KFABM=IABS(KFBEAM(JS)) + KFSBM=ISIGN(1,KFBEAM(JS)) + +C...Zero flavour content of incoming beam particle. + KFIVAL(JS,1)=0 + KFIVAL(JS,2)=0 + KFIVAL(JS,3)=0 +C... Flavour content of baryon. + IF(KFABM.GT.1000) THEN + KFIVAL(JS,1)=KFSBM*MOD(KFABM/1000,10) + KFIVAL(JS,2)=KFSBM*MOD(KFABM/100,10) + KFIVAL(JS,3)=KFSBM*MOD(KFABM/10,10) +C... Flavour content of pi+-, K+-. + ELSEIF(KFABM.EQ.211) THEN + KFIVAL(JS,1)=KFSBM*2 + KFIVAL(JS,2)=-KFSBM + ELSEIF(KFABM.EQ.321) THEN + KFIVAL(JS,1)=-KFSBM*3 + KFIVAL(JS,2)=KFSBM*2 +C... Flavour content of pi0, gamma, K0S, K0L not defined yet. + ENDIF + +C...Zero initial valence and companion content. + DO 130 IFL=-6,6 + NVC(JS,IFL)=0 + 130 CONTINUE + 140 CONTINUE +C...Set up colour line tags starting from hard interaction initiators. + NCT=0 +C...Reset colour tag array and colour processing flags. + DO 150 I=IMISEP(0)+1,N + MCT(I,1)=0 + MCT(I,2)=0 + K(I,4)=MOD(K(I,4),MSTU(5)**2) + K(I,5)=MOD(K(I,5),MSTU(5)**2) + 150 CONTINUE +C... Consider each side in turn. + DO 170 JS=1,2 + I1=IMI(JS,1,1) + I2=IMI(3-JS,1,1) + DO 160 JCS=4,5 + IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2))) + & GOTO 160 + IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 160 + KCS=JCS + CALL PYCTTR(I1,KCS,I2) + IF(MINT(51).NE.0) RETURN + 160 CONTINUE + 170 CONTINUE + +C...Range checking for companion quark pdf large-x param. + IF (MSTP(87).LT.0) THEN + CALL PYERRM(19,'(PYPTMI:) MSTP(87) out of range. Forced'// + & ' MSTP(87)=0') + MSTP(87)=0 + ELSEIF (MSTP(87).GT.4) THEN + CALL PYERRM(19,'(PYPTMI:) MSTP(87) out of range. Forced'// + & ' MSTP(87)=4') + MSTP(87)=4 + ENDIF + +C---------------------------------------------------------------------- +C...MODE=0: Generate trial interaction. Return codes: +C...IFAIL < 0: Phase space exhausted, generation to be terminated. +C...IFAIL = 0: Additional interaction generated at PT2. +C...IFAIL > 0: Additional interaction vetoed, but continue evolution. + ELSEIF (MODE.EQ.0) THEN +C...Abolute MI max scale = VINT(62) + XT2=4D0*MIN(PT2NOW,VINT(62))/VINT(2) + 180 IF(MSTP(82).LE.1) THEN + XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0))) + IF(XT2.LT.VINT(149)) IFAIL=-2 + ELSE + IF(XT2.LE.0.01001D0*VINT(149)) THEN + IFAIL=-3 + ELSE + XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))* + & LOG(PYR(0)))-VINT(149) + ENDIF + ENDIF +C...Also exit if below lower limit or if higher trial branching +C...already found. + PT2=0.25D0*VINT(2)*XT2 + IF (PT2.LE.PT2CUT) IFAIL=-4 + IF (PT2.LE.PT2MX) IFAIL=-5 + IF (IFAIL.NE.0) THEN + PT2=0D0 + RETURN + ENDIF + IF(MSTP(82).GE.2) PT2=MAX(0.25D0*VINT(2)*0.01D0*VINT(149),PT2) + VINT(25)=4D0*PT2/VINT(2) + XT2=VINT(25) + +C...Choose tau and y*. Calculate cos(theta-hat). + IF(PYR(0).LE.COEF(ISUB,1)) THEN + TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0) + TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT) + ELSE + TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2) + ENDIF + VINT(21)=TAU +C...New: require shat > 1. + IF(TAU*VINT(2).LT.1D0) GOTO 180 + CALL PYKLIM(2) + RYST=PYR(0) + MYST=1 + IF(RYST.GT.COEF(ISUB,8)) MYST=2 + IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3 + CALL PYKMAP(2,MYST,PYR(0)) + VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0)) + +C...Check that x not used up. Accept or reject kinematical variables. + X1M=SQRT(TAU)*EXP(VINT(22)) + X2M=SQRT(TAU)*EXP(-VINT(22)) + IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 180 + VINT(71)=0.5D0*VINT(1)*SQRT(XT2) + NCHN=0 + CALL PYSIGH(NCHN,SIGS) + IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320) + IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 180 + IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS/VINT(320) + +C...Save if highest PT so far. + IF (PT2.GT.PT2MX) THEN + JSMX=0 + MIMX=MINT(31)+1 + PT2MX=PT2 + ENDIF + +C---------------------------------------------------------------------- +C...MODE=1: Generate and save accepted scattering. + ELSEIF (MODE.EQ.1) THEN + PT2=PT2NOW +C...Reset K, P, V, and MCT vectors. + DO 200 I=N+1,N+4 + DO 190 J=1,5 + K(I,J)=0 + P(I,J)=0D0 + V(I,J)=0D0 + 190 CONTINUE + MCT(I,1)=0 + MCT(I,2)=0 + 200 CONTINUE + + NTRY=0 +C...Choose flavour of reacting partons (and subprocess). + 210 NTRY=NTRY+1 + IF (NTRY.GT.50) THEN + CALL PYERRM(9,'(PYPTMI:) Unable to generate additional ' + & //'interaction. Giving up!') + MINT(51)=1 + RETURN + ENDIF + RSIGS=SIGS*PYR(0) + DO 220 ICHN=1,NCHN + KFL1=ISIG(ICHN,1) + KFL2=ISIG(ICHN,2) + ICONMI=ISIG(ICHN,3) + RSIGS=RSIGS-SIGH(ICHN) + IF(RSIGS.LE.0D0) GOTO 230 + 220 CONTINUE + +C...Reassign to appropriate process codes. + 230 ISUBMI=ICONMI/10 + ICONMI=MOD(ICONMI,10) + +C...Choose new quark flavour for annihilation graphs + IF(ISUBMI.EQ.12.OR.ISUBMI.EQ.53) THEN + SH=VINT(21)*VINT(2) + CALL PYWIDT(21,SH,WDTP,WDTE) + 240 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0) + DO 250 I=1,MDCY(21,3) + KFLF=KFDP(I+MDCY(21,2)-1,1) + RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4)) + IF(RKFL.LE.0D0) GOTO 260 + 250 CONTINUE + 260 IF(ISUBMI.EQ.53.AND.ICONMI.LE.2) THEN + IF(KFLF.GE.4) GOTO 240 + ELSEIF(ISUBMI.EQ.53.AND.ICONMI.LE.4) THEN + KFLF=4 + ICONMI=ICONMI-2 + ELSEIF(ISUBMI.EQ.53) THEN + KFLF=5 + ICONMI=ICONMI-4 + ENDIF + ENDIF + +C...Final state flavours and colour flow: default values + JS=1 + KFL3=KFL1 + KFL4=KFL2 + KCC=20 + KCS=ISIGN(1,KFL1) + + IF(ISUBMI.EQ.11) THEN +C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2 + KCC=ICONMI + IF(KFL1*KFL2.LT.0) KCC=KCC+2 + + ELSEIF(ISUBMI.EQ.12) THEN +C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2 + KFL3=ISIGN(KFLF,KFL1) + KFL4=-KFL3 + KCC=4 + + ELSEIF(ISUBMI.EQ.13) THEN +C...f + fbar -> g + g; th arbitrary + KFL3=21 + KFL4=21 + KCC=ICONMI+4 + + ELSEIF(ISUBMI.EQ.28) THEN +C...f + g -> f + g; th = (p(f)-p(f))**2 + IF(KFL1.EQ.21) JS=2 + KCC=ICONMI+6 + IF(KFL1.EQ.21) KCC=KCC+2 + IF(KFL1.NE.21) KCS=ISIGN(1,KFL1) + IF(KFL2.NE.21) KCS=ISIGN(1,KFL2) + + ELSEIF(ISUBMI.EQ.53) THEN +C...g + g -> f + fbar; th arbitrary + KCS=(-1)**INT(1.5D0+PYR(0)) + KFL3=ISIGN(KFLF,KCS) + KFL4=-KFL3 + KCC=ICONMI+10 + + ELSEIF(ISUBMI.EQ.68) THEN +C...g + g -> g + g; th arbitrary + KCC=ICONMI+12 + KCS=(-1)**INT(1.5D0+PYR(0)) + ENDIF + +C...Check that massive sea quarks have non-zero phase space for g -> Q Q + IF (IABS(KFL3).EQ.4.OR.IABS(KFL4).EQ.4.OR.IABS(KFL3).EQ.5 + & .OR.IABS(KFL4).EQ.5) THEN + RMMAX2=MAX(PMAS(PYCOMP(KFL3),1),PMAS(PYCOMP(KFL4),1))**2 + IF (PT2.LE.1.05*RMMAX2) THEN + IF (NTRY.EQ.2) CALL PYERRM(9,'(PYPTMI:) Heavy quarks' + & //' too close to threshold (2nd try).') + GOTO 210 + ENDIF + ENDIF + +C...Store flavours of scattering. + MINT(13)=KFL1 + MINT(14)=KFL2 + MINT(15)=KFL1 + MINT(16)=KFL2 + MINT(21)=KFL3 + MINT(22)=KFL4 + +C...Set flavours and mothers of scattering partons. + K(N+1,1)=14 + K(N+2,1)=14 + K(N+3,1)=3 + K(N+4,1)=3 + K(N+1,2)=KFL1 + K(N+2,2)=KFL2 + K(N+3,2)=KFL3 + K(N+4,2)=KFL4 + K(N+1,3)=MINT(83)+1 + K(N+2,3)=MINT(83)+2 + K(N+3,3)=N+1 + K(N+4,3)=N+2 + +C...Store colour connection indices. + DO 270 J=1,2 + JC=J + IF(KCS.EQ.-1) JC=3-J + IF(ICOL(KCC,1,JC).NE.0) K(N+1,J+3)=N+ICOL(KCC,1,JC) + IF(ICOL(KCC,2,JC).NE.0) K(N+2,J+3)=N+ICOL(KCC,2,JC) + IF(ICOL(KCC,3,JC).NE.0) K(N+3,J+3)=MSTU(5)*(N+ICOL(KCC,3,JC)) + IF(ICOL(KCC,4,JC).NE.0) K(N+4,J+3)=MSTU(5)*(N+ICOL(KCC,4,JC)) + 270 CONTINUE + +C...Store incoming and outgoing partons in their CM-frame. + SHR=SQRT(VINT(21))*VINT(1) + P(N+1,3)=0.5D0*SHR + P(N+1,4)=0.5D0*SHR + P(N+2,3)=-0.5D0*SHR + P(N+2,4)=0.5D0*SHR + P(N+3,5)=PYMASS(K(N+3,2)) + P(N+4,5)=PYMASS(K(N+4,2)) + IF(P(N+3,5)+P(N+4,5).GE.SHR) THEN + IFAIL=1 + RETURN + ENDIF + P(N+3,4)=0.5D0*(SHR+(P(N+3,5)**2-P(N+4,5)**2)/SHR) + P(N+3,3)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,5)**2)) + P(N+4,4)=SHR-P(N+3,4) + P(N+4,3)=-P(N+3,3) + +C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4) + PHI=PARU(2)*PYR(0) + CALL PYROBO(N+3,N+4,ACOS(VINT(23)),PHI,0D0,0D0,0D0) + +C...Global statistics. + MINT(351)=MINT(351)+1 + VINT(351)=VINT(351)+SQRT(P(N+3,1)**2+P(N+3,2)**2) + IF (MINT(351).EQ.1) VINT(356)=SQRT(P(N+3,1)**2+P(N+3,2)**2) + +C...Keep track of loose colour ends and information on scattering. + MINT(31)=MINT(31)+1 + MINT(36)=MINT(31) + PT2MI(MINT(36))=PT2 + IMISEP(MINT(31))=N+4 + DO 280 JS=1,2 + IMI(JS,MINT(31),1)=N+JS + IMI(JS,MINT(31),2)=0 + XMI(JS,MINT(31))=VINT(40+JS) + NMI(JS)=NMI(JS)+1 +C...Update cumulative counters + VINT(142+JS)=VINT(142+JS)-VINT(40+JS) + VINT(150+JS)=VINT(150+JS)+VINT(40+JS) + 280 CONTINUE + +C...Add to list of final state partons + IPART(NPART+1)=N+3 + IPART(NPART+2)=N+4 + PTPART(NPART+1)=SQRT(PT2) + PTPART(NPART+2)=SQRT(PT2) + NPART=NPART+2 + +C...Initialize ISR + NISGEN(1,MINT(31))=0 + NISGEN(2,MINT(31))=0 + +C...Update ER + N=N+4 + IF(N.GT.MSTU(4)-MSTU(32)-10) THEN + CALL PYERRM(11,'(PYMIGN:) no more memory left in PYJETS') + MINT(51)=1 + RETURN + ENDIF + +C...Finally, assign colour tags to new partons + DO 300 JS=1,2 + I1=IMI(JS,MINT(31),1) + I2=IMI(3-JS,MINT(31),1) + DO 290 JCS=4,5 + IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2))) + & GOTO 290 + IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 290 + KCS=JCS + CALL PYCTTR(I1,KCS,I2) + IF(MINT(51).NE.0) RETURN + 290 CONTINUE + 300 CONTINUE + +C---------------------------------------------------------------------- +C...MODE=2: Decide whether quarks in last scattering were valence, +C...companion, or sea. + ELSEIF (MODE.EQ.2) THEN + JS=MINT(30) + MI=MINT(36) + PT2=PT2NOW + KFSBM=ISIGN(1,MINT(10+JS)) + IFL=K(IMI(JS,MI,1),2) + IMI(JS,MI,2)=0 + IF (IABS(IFL).GE.6) THEN + IF (IABS(IFL).EQ.6) THEN + CALL PYERRM(29,'(PYPTMI:) top in initial state!') + ENDIF + RETURN + ENDIF +C...Get PDFs at X(rescaled) and PT2 of the current initiator. +C...(Do not include the parton itself in the X rescaling.) + X=XMI(JS,MI) + XRSC=X/(VINT(142+JS)+X) +C...Note: XPSVC = x*pdf. + MINT(30)=JS + CALL PYPDFU(KFBEAM(JS),XRSC,PT2,XPQ) + SEA=XPSVC(IFL,-1) + VAL=XPSVC(IFL,0) +C...Ensure that pdfs are positive definite + IF (SEA.LT.0D0) THEN + CALL PYERRM(9,'(PYPTMI:) Sea distribution negative.') + SEA=MAX(0D0,SEA) + ELSEIF (VAL.LT.0D0) THEN + CALL PYERRM(9,'(PYPTMI:) Val distribution negative.') + VAL=MAX(0D0,VAL) + ENDIF + CMP=0D0 + DO 310 IVC=1,NVC(JS,IFL) + CMP=CMP+XPSVC(IFL,IVC) + 310 CONTINUE + + NTRY=0 +C...Decide (Extra factor x cancels in the dvision). + 320 RVCS=PYR(0)*(SEA+VAL+CMP) + IVNOW=1 + NTRY=NTRY+1 + 330 IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN +C...Safety check that valence present; pi0/gamma/K0S/K0L special cases. + IVNOW=0 + IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1 + IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1 + IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1 + IF(KFIVAL(JS,1).EQ.0) THEN + IF(KFBEAM(JS).EQ.111.AND.IABS(IFL).LE.2) IVNOW=1 + IF(KFBEAM(JS).EQ.22.AND.IABS(IFL).LE.5) IVNOW=1 + IF((KFBEAM(JS).EQ.130.OR.KFBEAM(JS).EQ.310).AND. + & (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1 + ELSE +C...Count down valence remaining. Do not count current scattering. + DO 340 I1=1,NMI(JS) + IF (I1.EQ.MINT(36)) GOTO 340 + IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0) + & IVNOW=IVNOW-1 + 340 CONTINUE + ENDIF + IF(IVNOW.EQ.0) GOTO 330 +C...Mark valence. + IMI(JS,MI,2)=0 +C...Sets valence content of gamma, pi0, K0S, K0L if not done. + IF(KFIVAL(JS,1).EQ.0) THEN + IF(KFBEAM(JS).EQ.111.OR.KFBEAM(JS).EQ.22) THEN + KFIVAL(JS,1)=IFL + KFIVAL(JS,2)=-IFL + ELSEIF(KFBEAM(JS).EQ.130.OR.KFBEAM(JS).EQ.310) THEN + KFIVAL(JS,1)=IFL + IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL) + IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL) + ENDIF + ENDIF + + ELSEIF (RVCS.LE.VAL+SEA) THEN +C...If sea, add opposite sign companion parton. Store X and I. + NVC(JS,-IFL)=NVC(JS,-IFL)+1 + XASSOC(JS,-IFL,NVC(JS,-IFL))=XMI(JS,MI) +C...Set pointer to companion + IMI(JS,MI,2)=-NVC(JS,-IFL) + + ELSE +C...If companion, check whether we've got any in the books + IF (NVC(JS,IFL).EQ.0) THEN + CMP=0D0 +C...Only report error first time for this event + IF (NTRY.EQ.1) + & CALL PYERRM(9,'(PYPTMI:) No cmp quark, but pdf != 0!') +C...Try a few times + IF (NTRY.LE.10) THEN + GOTO 320 +C... But if it stil fails, abort this event + ELSE + MINT(51)=1 + RETURN + ENDIF + ENDIF +C...If several possibilities, decide which one + CMPSUM=VAL+SEA + ISEL=0 + 350 ISEL=ISEL+1 + CMPSUM=CMPSUM+XPSVC(IFL,ISEL) + IF (RVCS.GT.CMPSUM.AND.ISEL.LT.NVC(JS,IFL)) GOTO 350 +C...Find original sea (anti-)quark. Do not consider current scattering. + IASSOC=0 + DO 360 I1=1,NMI(JS) + IF (I1.EQ.MINT(36)) GOTO 360 + IF (K(IMI(JS,I1,1),2).NE.-IFL) GOTO 360 + IF (-IMI(JS,I1,2).EQ.ISEL) THEN + IMI(JS,MI,2)=IMI(JS,I1,1) + IMI(JS,I1,2)=IMI(JS,MI,1) + ENDIF + 360 CONTINUE +C...Mark companion "out-kicked". + XASSOC(JS,IFL,ISEL)=-XASSOC(JS,IFL,ISEL) + ENDIF + + ENDIF + RETURN + END + +C********************************************************************* + +C...PYFCMP: Auxiliary to PYPDFU and PYPTIS. +C...Giving the x*f pdf of a companion quark, with its partner at XS, +C...using an approximate gluon density like (1-X)^NPOW/X. The value +C...corresponds to an unrescaled range between 0 and 1-X. + + FUNCTION PYFCMP(XC,XS,NPOW) + IMPLICIT NONE + DOUBLE PRECISION XC, XS, Y, PYFCMP,FAC + INTEGER NPOW + + PYFCMP=0D0 +C...Parent gluon momentum fraction + Y=XC+XS + IF (Y.GE.1D0) RETURN +C...Common factor (includes factor XC, since PYFCMP=x*f) + FAC=3D0*XC*XS*(XC**2+XS**2)/(Y**4) +C...Store normalized companion x*f distribution. + IF (NPOW.LE.0) THEN + PYFCMP=FAC/(2D0-XS*(3D0-XS*(3D0-2D0*XS))) + ELSEIF (NPOW.EQ.1) THEN + PYFCMP=FAC*(1D0-Y)/(2D0+XS**2*(-3D0+XS)+3D0*XS*LOG(XS)) + ELSEIF (NPOW.EQ.2) THEN + PYFCMP=FAC*(1D0-Y)**2/(2D0*((1D0-XS)*(1D0+XS*(4D0+XS)) + & +3D0*XS*(1D0+XS)*LOG(XS))) + ELSEIF (NPOW.EQ.3) THEN + PYFCMP=FAC*(1D0-Y)**3*2D0/(4D0+27D0*XS-31D0*XS**3 + & +6D0*XS*LOG(XS)*(3D0+2D0*XS*(3D0+XS))) + ELSEIF (NPOW.GE.4) THEN + PYFCMP=FAC*(1D0-Y)**4/(2D0*(1D0+2D0*XS)*((1D0-XS)*(1D0+ + & XS*(10D0+XS))+6D0*XS*LOG(XS)*(1D0+XS))) + ENDIF + RETURN + END + +C********************************************************************* + +C...PYPCMP: Auxiliary to PYPDFU. +C...Giving the momentum integral of a companion quark, with its +C...partner at XS, using an approximate gluon density like (1-x)^NPOW/x. +C...The value corresponds to an unrescaled range between 0 and 1-XS. + + FUNCTION PYPCMP(XS,NPOW) + IMPLICIT NONE + DOUBLE PRECISION XS, PYPCMP + INTEGER NPOW + IF (XS.GE.1D0.OR.XS.LE.0D0) THEN + PYPCMP=0D0 + ELSEIF (NPOW.LE.0) THEN + PYPCMP=XS*(5D0+XS*(-9D0-2D0*XS*(-3D0+XS))+3D0*LOG(XS)) + PYPCMP=PYPCMP/((-1D0+XS)*(2D0+XS*(-1D0+2D0*XS))) + ELSEIF (NPOW.EQ.1) THEN + PYPCMP=-1D0-3D0*XS+(2D0*(-1D0+XS)**2*(1D0+XS+XS**2)) + & /(2D0+XS**2*(XS-3D0)+3D0*XS*LOG(XS)) + ELSEIF (NPOW.EQ.2) THEN + PYPCMP=XS*((1D0-XS)*(19D0+XS*(43D0+4D0*XS)) + & +6D0*LOG(XS)*(1D0+6D0*XS+4D0*XS**2)) + PYPCMP=PYPCMP/(4D0*((XS-1D0)*(1D0+XS*(4D0+XS)) + & -3D0*XS*LOG(XS)*(1+XS))) + ELSEIF (NPOW.EQ.3) THEN + PYPCMP=3D0*XS*((XS-1)*(7D0+XS*(28D0+13D0*XS)) + & -2D0*LOG(XS)*(1D0+XS*(9D0+2D0*XS*(6D0+XS)))) + PYPCMP=PYPCMP/(4D0+27D0*XS-31D0*XS**3 + & +6D0*XS*LOG(XS)*(3D0+2D0*XS*(3D0+XS))) + ELSE + PYPCMP=(-9D0*XS*(XS**2-1D0)*(5D0+XS*(24D0+XS))+12D0*XS*LOG(XS) + & *(1D0+2D0*XS)*(1D0+2D0*XS*(5D0+2D0*XS))) + PYPCMP=PYPCMP/(8D0*(1D0+2D0*XS)*((XS-1D0)*(1D0+XS*(10D0+XS)) + & -6D0*XS*LOG(XS)*(1D0+XS))) + ENDIF + RETURN + END + +C********************************************************************* + +C...PYUPRE +C...Rearranges contents of the HEPEUP commonblock so that +C...mothers precede daughters and daughters of a decay are +C...listed consecutively. + + SUBROUTINE PYUPRE + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + +C...User process event common block. + INTEGER MAXNUP + PARAMETER (MAXNUP=500) + INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP + DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP + COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP), + &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP), + &VTIMUP(MAXNUP),SPINUP(MAXNUP) + SAVE /HEPEUP/ + +C...Local arrays. + DIMENSION NEWPOS(0:MAXNUP),IDUPT(MAXNUP),ISTUPT(MAXNUP), + &MOTUPT(2,MAXNUP),ICOUPT(2,MAXNUP),PUPT(5,MAXNUP), + &VTIUPT(MAXNUP),SPIUPT(MAXNUP) + +C...Check whether a rearrangement is required. + NEED=0 + DO 100 IUP=1,NUP + IF(MOTHUP(1,IUP).GT.IUP) NEED=NEED+1 + 100 CONTINUE + DO 110 IUP=2,NUP + IF(MOTHUP(1,IUP).LT.MOTHUP(1,IUP-1)) NEED=NEED+1 + 110 CONTINUE + + IF(NEED.NE.0) THEN +C...Find the new order that particles should have. + NEWPOS(0)=0 + NNEW=0 + INEW=-1 + 120 INEW=INEW+1 + DO 130 IUP=1,NUP + IF(MOTHUP(1,IUP).EQ.NEWPOS(INEW)) THEN + NNEW=NNEW+1 + NEWPOS(NNEW)=IUP + ENDIF + 130 CONTINUE + IF(INEW.LT.NNEW.AND.INEW.LT.NUP) GOTO 120 + IF(NNEW.NE.NUP) THEN + CALL PYERRM(2, + & '(PYUPRE:) failed to make sense of mother pointers in HEPEUP') + RETURN + ENDIF + +C...Copy old info into temporary storage. + DO 150 I=1,NUP + IDUPT(I)=IDUP(I) + ISTUPT(I)=ISTUP(I) + MOTUPT(1,I)=MOTHUP(1,I) + MOTUPT(2,I)=MOTHUP(2,I) + ICOUPT(1,I)=ICOLUP(1,I) + ICOUPT(2,I)=ICOLUP(2,I) + DO 140 J=1,5 + PUPT(J,I)=PUP(J,I) + 140 CONTINUE + VTIUPT(I)=VTIMUP(I) + SPIUPT(I)=SPINUP(I) + 150 CONTINUE + +C...Copy info back into HEPEUP in right order. + DO 180 I=1,NUP + IOLD=NEWPOS(I) + IDUP(I)=IDUPT(IOLD) + ISTUP(I)=ISTUPT(IOLD) + MOTHUP(1,I)=0 + MOTHUP(2,I)=0 + DO 160 IMOT=1,I-1 + IF(MOTUPT(1,IOLD).EQ.NEWPOS(IMOT)) MOTHUP(1,I)=IMOT + IF(MOTUPT(2,IOLD).EQ.NEWPOS(IMOT)) MOTHUP(2,I)=IMOT + 160 CONTINUE + IF(MOTHUP(2,I).GT.0.AND.MOTHUP(2,I).LT.MOTHUP(1,I)) THEN + MOTHSW=MOTHUP(1,I) + MOTHUP(1,I)=MOTHUP(2,I) + MOTHUP(2,I)=MOTHSW + ENDIF + ICOLUP(1,I)=ICOUPT(1,IOLD) + ICOLUP(2,I)=ICOUPT(2,IOLD) + DO 170 J=1,5 + PUP(J,I)=PUPT(J,IOLD) + 170 CONTINUE + VTIMUP(I)=VTIUPT(IOLD) + SPINUP(I)=SPIUPT(IOLD) + 180 CONTINUE + ENDIF + +c...If incoming particles are massive recalculate to put them massless. + IF(PUP(5,1).NE.0D0.OR.PUP(5,2).NE.0D0) THEN + PPLUS=(PUP(4,1)+PUP(3,1))+(PUP(4,2)+PUP(3,2)) + PMINUS=(PUP(4,1)-PUP(3,1))+(PUP(4,2)-PUP(3,2)) + PUP(4,1)=0.5D0*PPLUS + PUP(3,1)=PUP(4,1) + PUP(5,1)=0D0 + PUP(4,2)=0.5D0*PMINUS + PUP(3,2)=-PUP(4,2) + PUP(5,2)=0D0 + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYADSH +C...Administers the generation of successive final-state showers +C...in external processes. + + SUBROUTINE PYADSH(NFIN) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement for maximum size of showers. + PARAMETER (MAXNUR=1000) +C...Commonblocks. + COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR) + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYCTAG/NCT,MCT(4000,2) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYPARS/,/PYINT1/ +C...Local array. + DIMENSION IBEG(100),KSAV(100,5),PSUM(4),BETA(3) + +C...Set primary vertex. + DO 100 J=1,5 + V(MINT(83)+5,J)=0D0 + V(MINT(83)+6,J)=0D0 + V(MINT(84)+1,J)=0D0 + V(MINT(84)+2,J)=0D0 + 100 CONTINUE + +C...Isolate systems of particles with the same mother. + NSYS=0 + IMS=-1 + DO 140 I=MINT(84)+3,NFIN + IM=K(I,3) + IF(IM.GT.0.AND.IM.LE.MINT(84)) IM=K(IM,3) + IF(IM.NE.IMS) THEN + NSYS=NSYS+1 + IBEG(NSYS)=I + IMS=IM + ENDIF + +C...Set production vertices. + IF(IM.LE.MINT(83)+6.OR.(IM.GT.MINT(84).AND.IM.LE.MINT(84)+2)) + & THEN + DO 110 J=1,4 + V(I,J)=0D0 + 110 CONTINUE + ELSE + DO 120 J=1,4 + V(I,J)=V(IM,J)+V(IM,5)*P(IM,J)/P(IM,5) + 120 CONTINUE + ENDIF + IF(MSTP(125).GE.1) THEN + IDOC=I-MSTP(126)+4 + DO 130 J=1,5 + V(IDOC,J)=V(I,J) + 130 CONTINUE + ENDIF + 140 CONTINUE + +C...End loop over systems. Return if no showers to be performed. + IBEG(NSYS+1)=NFIN+1 + IF(MSTP(71).LE.0) RETURN + +C...Loop through systems of particles; check that sensible size. + DO 270 ISYS=1,NSYS + NSIZ=IBEG(ISYS+1)-IBEG(ISYS) + IF(MINT(35).LE.2) THEN + IF(NSIZ.EQ.1.AND.ISYS.EQ.1) THEN + GOTO 270 + ELSEIF(NSIZ.LE.1) THEN + CALL PYERRM(2,'(PYADSH:) only one particle in system') + GOTO 270 + ELSEIF(NSIZ.GT.80) THEN + CALL PYERRM(2,'(PYADSH:) more than 80 particles in system') + GOTO 270 + ENDIF + ENDIF + +C...Save status codes and daughters of showering particles; reset them. + DO 150 J=1,4 + PSUM(J)=0D0 + 150 CONTINUE + DO 170 II=1,NSIZ + I=IBEG(ISYS)-1+II + KSAV(II,1)=K(I,1) + IF(K(I,1).GT.10) THEN + K(I,1)=1 + IF(KSAV(II,1).EQ.14) K(I,1)=3 + ENDIF + IF(KSAV(II,1).LE.10) THEN + ELSEIF(K(I,1).EQ.1) THEN + KSAV(II,4)=K(I,4) + KSAV(II,5)=K(I,5) + K(I,4)=0 + K(I,5)=0 + ELSE + KSAV(II,4)=MOD(K(I,4),MSTU(5)) + KSAV(II,5)=MOD(K(I,5),MSTU(5)) + K(I,4)=K(I,4)-KSAV(II,4) + K(I,5)=K(I,5)-KSAV(II,5) + ENDIF + DO 160 J=1,4 + PSUM(J)=PSUM(J)+P(I,J) + 160 CONTINUE + 170 CONTINUE + +C...Perform shower. + QMAX=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2- + & PSUM(3)**2)) + IF(ISYS.EQ.1) QMAX=MIN(QMAX,SQRT(PARP(71))*VINT(55)) + NSAV=N + IF(MINT(35).LE.2) THEN + IF(NSIZ.EQ.2) THEN + CALL PYSHOW(IBEG(ISYS),IBEG(ISYS)+1,QMAX) + ELSE + CALL PYSHOW(IBEG(ISYS),-NSIZ,QMAX) + ENDIF + +C...For external processes, first call, also ISR partons radiate. +C...Can use existing PYPART list, removing partons that radiate later. + ELSEIF(ISYS.EQ.1) THEN + NPARTN=0 + DO 175 II=1,NPART + IF(IPART(II).LT.IBEG(2).OR.IPART(II).GE.IBEG(NSYS+1)) THEN + NPARTN=NPARTN+1 + IPART(NPARTN)=IPART(II) + PTPART(NPARTN)=PTPART(II) + ENDIF + 175 CONTINUE + NPART=NPARTN + CALL PYPTFS(1,0.5D0*QMAX,0D0,PTGEN) + ELSE +C...For subsequent calls use the systems excluded above. + NPART=NSIZ + NPARTD=0 + DO 180 II=1,NSIZ + I=IBEG(ISYS)-1+II + IPART(II)=I + PTPART(II)=0.5D0*QMAX + 180 CONTINUE + CALL PYPTFS(2,0.5D0*QMAX,0D0,PTGEN) + ENDIF + +C...Look up showered copies of original showering particles. + DO 260 II=1,NSIZ + I=IBEG(ISYS)-1+II + IMV=I +C...Particles without daughters need not be studied. + IF(KSAV(II,1).LE.10) GOTO 260 + IF(N.EQ.NSAV.OR.K(I,1).LE.10) THEN + ELSEIF(K(I,1).EQ.11) THEN + 190 IMV=MOD(K(IMV,4),MSTU(5)) + IF(K(IMV,1).EQ.11) GOTO 190 + ELSE + KDA1=MOD(K(I,4),MSTU(5)) + IF(KDA1.GT.0) THEN + IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5) + ENDIF + KDA2=MOD(K(I,5),MSTU(5)) + IF(KDA2.GT.0) THEN + IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5) + ENDIF + DO 200 I3=I+1,N + IF(K(I3,2).EQ.K(I,2).AND.(I3.EQ.KDA1.OR.I3.EQ.KDA2)) + & THEN + IMV=I3 + KDA1=MOD(K(I3,4),MSTU(5)) + IF(KDA1.GT.0) THEN + IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5) + ENDIF + KDA2=MOD(K(I3,5),MSTU(5)) + IF(KDA2.GT.0) THEN + IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5) + ENDIF + ENDIF + 200 CONTINUE + ENDIF + +C...Restore daughter info of original partons to showered copies. + IF(KSAV(II,1).GT.10) K(IMV,1)=KSAV(II,1) + IF(KSAV(II,1).LE.10) THEN + ELSEIF(K(I,1).EQ.1) THEN + K(IMV,4)=KSAV(II,4) + K(IMV,5)=KSAV(II,5) + ELSE + K(IMV,4)=K(IMV,4)+KSAV(II,4) + K(IMV,5)=K(IMV,5)+KSAV(II,5) + ENDIF + +C...Reset mother info of existing daughters to showered copies. + DO 210 I3=IBEG(ISYS+1),NFIN + IF(K(I3,3).EQ.I) K(I3,3)=IMV + IF(K(I3,1).EQ.3.OR.K(I3,1).EQ.14) THEN + IF(K(I3,4)/MSTU(5).EQ.I) K(I3,4)=K(I3,4)+MSTU(5)*(IMV-I) + IF(K(I3,5)/MSTU(5).EQ.I) K(I3,5)=K(I3,5)+MSTU(5)*(IMV-I) + ENDIF + 210 CONTINUE + +C...Boost all original daughters to new frame of showered copy. +C...Also update their colour tags. + IF(IMV.NE.I) THEN + DO 220 J=1,3 + BETA(J)=(P(IMV,J)-P(I,J))/(P(IMV,4)+P(I,4)) + 220 CONTINUE + FAC=2D0/(1D0+BETA(1)**2+BETA(2)**2+BETA(3)**2) + DO 230 J=1,3 + BETA(J)=FAC*BETA(J) + 230 CONTINUE + DO 250 I3=IBEG(ISYS+1),NFIN + IMO=I3 + 240 IMO=K(IMO,3) + IF(MSTP(128).LE.0) THEN + IF(IMO.GT.0.AND.IMO.NE.I.AND.IMO.NE.K(I,3)) GOTO 240 + IF(IMO.EQ.I.OR.(K(I,3).LE.MINT(84).AND.IMO.EQ.K(I,3))) + & THEN + CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3)) + IF(MCT(I3,1).EQ.MCT(I,1)) MCT(I3,1)=MCT(IMV,1) + IF(MCT(I3,2).EQ.MCT(I,2)) MCT(I3,2)=MCT(IMV,2) + ENDIF + ELSE + IF(IMO.EQ.IMV) THEN + CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3)) + IF(MCT(I3,1).EQ.MCT(I,1)) MCT(I3,1)=MCT(IMV,1) + IF(MCT(I3,2).EQ.MCT(I,2)) MCT(I3,2)=MCT(IMV,2) + ELSEIF(IMO.GT.0.AND.IMO.NE.I.AND.IMO.NE.K(I,3)) THEN + GOTO 240 + ENDIF + ENDIF + 250 CONTINUE + ENDIF + 260 CONTINUE + +C...End of loop over showering systems + 270 CONTINUE + + RETURN + END + +C********************************************************************* + +C...PYVETO +C...Interface to UPVETO, which allows user to veto event generation +C...on the parton level, after parton showers but before multiple +C...interactions, beam remnants and hadronization is added. + + SUBROUTINE PYVETO(IVETO) + +C...All real arithmetic in double precision. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) +C...Three Pythia functions return integers, so need declaring. + INTEGER PYK,PYCHGE,PYCOMP + +C...PYTHIA commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYINT1/MINT(400),VINT(400) + SAVE /PYJETS/,/PYPARS/,/PYINT1/ +C...HEPEVT commonblock. + PARAMETER (NMXHEP=4000) + COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP), + &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP) + DOUBLE PRECISION PHEP,VHEP + SAVE /HEPEVT/ +C...Local array. + DIMENSION IRESO(100) + +C...Define longitudinal boost from initiator rest frame to cm frame. + GAMMA=0.5D0*(VINT(141)+VINT(142))/SQRT(VINT(141)*VINT(142)) + GABEZ=0.5D0*(VINT(141)-VINT(142))/SQRT(VINT(141)*VINT(142)) + +C...Presentation is different if using pT-ordered shower + IF(MINT(35).EQ.3) THEN + GAMMA=1D0 + GABEZ=0D0 + ENDIF + +C... Reset counters. + NEVHEP=0 + NHEP=0 + NRESO=0 + +C...Oth pass: identify beam and incoming partons + DO 140 I=MINT(83)+1,MINT(83)+6 + ISTORE=0 + IF(K(I,2).EQ.94) THEN + + ELSE + NRESO=NRESO+1 + IRESO(NRESO)=I + IMOTH=K(I,3) + ENDIF + 140 CONTINUE + +C...First pass: identify final locations of resonances +C...and of their daughters before showering. + DO 150 I=MINT(84)+3,N + ISTORE=0 + IMOTH=0 + +C...Skip shower CM frame documentation lines. + IF(K(I,2).EQ.94) THEN + +C... Store a new intermediate product, when mother in documentation. + ELSEIF(MSTP(128).EQ.0.AND.K(I,3).GT.MINT(83)+6.AND. + & K(I,3).LE.MINT(84)) THEN + ISTORE=1 + NHEP=NHEP+1 + II=NHEP + NRESO=NRESO+1 + IRESO(NRESO)=I + IMOTH=MAX(0,K(K(I,3),3)-(MINT(83)+6)) + +C... Store a new intermediate product, when mother in main section. + ELSEIF(MSTP(128).EQ.1.AND.K(I-MINT(84)+MINT(83)+4,1).EQ.21.AND. + & K(I-MINT(84)+MINT(83)+4,2).EQ.K(I,2)) THEN + ISTORE=1 + NHEP=NHEP+1 + II=NHEP + NRESO=NRESO+1 + IRESO(NRESO)=I + IMOTH=MAX(0,K(I-MINT(84)+MINT(83)+4,3)-(MINT(83)+6)) + ENDIF + + IF(ISTORE.EQ.1) THEN +C...Copy parton info, boosting momenta along z axis to cm frame. + ISTHEP(II)=2 + IDHEP(II)=K(I,2) + PHEP(1,II)=P(I,1) + PHEP(2,II)=P(I,2) + PHEP(3,II)=GAMMA*P(I,3)+GABEZ*P(I,4) + PHEP(4,II)=GAMMA*P(I,4)+GABEZ*P(I,3) + PHEP(5,II)=P(I,5) +C...Store one mother. Rest of history and vertex info zeroed. + JMOHEP(1,II)=IMOTH + JMOHEP(2,II)=0 + JDAHEP(1,II)=0 + JDAHEP(2,II)=0 + VHEP(1,II)=0D0 + VHEP(2,II)=0D0 + VHEP(3,II)=0D0 + VHEP(4,II)=0D0 + ENDIF + 150 CONTINUE + +C...Second pass: identify current set of "final" partons. + DO 200 I=MINT(84)+3,N + ISTORE=0 + IMOTH=0 + +C...Store a final parton. + IF(K(I,1).GE.1.AND.K(I,1).LE.10) THEN + ISTORE=1 + NHEP=NHEP+1 + II=NHEP +C..Trace it back through shower, to check if from documented particle. + IHIST=I + ISAVE=IHIST + 160 CONTINUE + IF(IHIST.GT.MINT(84)) THEN + IF(K(IHIST,2).EQ.94) IHIST=K(IHIST,3)+(ISAVE-1-IHIST) + DO 170 IRI=1,NRESO + IF(IHIST.EQ.IRESO(IRI)) IMOTH=IRI + 170 CONTINUE + ISAVE=IHIST + IHIST=K(IHIST,3) + IF(IMOTH.EQ.0) GOTO 160 + IMOTH=MAX(0,IMOTH-6) + ELSEIF(IHIST.LE.4) THEN + IF(IHIST.EQ.1.OR.IHIST.EQ.2) THEN + ISTORE=0 + NHEP=NHEP-1 + ELSE + IMOTH=0 + ENDIF + ENDIF + ENDIF + + IF(ISTORE.EQ.1) THEN +C...Copy parton info, boosting momenta along z axis to cm frame. + ISTHEP(II)=1 + IDHEP(II)=K(I,2) + PHEP(1,II)=P(I,1) + PHEP(2,II)=P(I,2) + PHEP(3,II)=GAMMA*P(I,3)+GABEZ*P(I,4) + PHEP(4,II)=GAMMA*P(I,4)+GABEZ*P(I,3) + PHEP(5,II)=P(I,5) +C...Store one mother. Rest of history and vertex info zeroed. + JMOHEP(1,II)=IMOTH + JMOHEP(2,II)=0 + JDAHEP(1,II)=0 + JDAHEP(2,II)=0 + VHEP(1,II)=0D0 + VHEP(2,II)=0D0 + VHEP(3,II)=0D0 + VHEP(4,II)=0D0 + ENDIF + 200 CONTINUE +C...Call user-written routine to decide whether to keep events. + CALL UPVETO(IVETO) + RETURN + END +C********************************************************************* + +C...PYRESD +C...Allows resonances to decay (including parton showers for hadronic +C...channels). + + SUBROUTINE PYRESD(IRES) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Parameter statement for maximum size of showers. + PARAMETER (MAXNUR=1000) +C...Commonblocks. + COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR) + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYCTAG/NCT,MCT(4000,2) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) + COMMON/PYINT4/MWID(500),WIDS(500,5) + COMMON/PYPUED/IUED(0:99),RUED(0:99) + SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/, + &/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT4/,/PYPUED/ +C...Local arrays and complex and character variables. + DIMENSION IREF(50,8),KDCY(3),KFL1(3),KFL2(3),KFL3(3),KEQL(3), + &KCQM(3),KCQ1(3),KCQ2(3),KCQ3(3),NSD(3),PMMN(4),ILIN(6), + &HGZ(3,3),COUP(6,4),CORL(2,2,2),PK(6,4),PKK(6,6),CTHE(3), + &PHI(3),WDTP(0:400),WDTE(0:400,0:5),DPMO(5),VDCY(4), + &ITJUNC(3),CTM2(3),KCQ(0:10),IANT(4),ITRI(4),IOCT(4),KCQ4(3), + &KFL4(3) + COMPLEX FGK,HA(6,6),HC(6,6) + REAL TIR,UIR + CHARACTER CODE*9,MASS*9 +C...Local arrays. + DIMENSION PV(10,5),RORD(10),UE(3),BE(3),WTCOR(10) + DATA WTCOR/2D0,5D0,15D0,60D0,250D0,1500D0,1.2D4,1.2D5,150D0,16D0/ + +C...Functions: momentum in two-particle decays and four-product. + PAWT(A,B,C)=SQRT((A**2-(B+C)**2)*(A**2-(B-C)**2))/(2D0*A) + +C...The F, Xi and Xj functions of Gunion and Kunszt +C...(Phys. Rev. D33, 665, plus errata from the authors). + FGK(I1,I2,I3,I4,I5,I6)=4.*HA(I1,I3)*HC(I2,I6)*(HA(I1,I5)* + &HC(I1,I4)+HA(I3,I5)*HC(I3,I4)) + DIGK(DT,DU)=-4D0*D34*D56+DT*(3D0*DT+4D0*DU)+DT**2*(DT*DU/ + &(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+2D0*(D34/D56+D56/D34)) + DJGK(DT,DU)=8D0*(D34+D56)**2-8D0*(D34+D56)*(DT+DU)-6D0*DT*DU- + &2D0*DT*DU*(DT*DU/(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+ + &2D0*(D34/D56+D56/D34)) + +C...Some general constants. + XW=PARU(102) + XWV=XW + IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2 + XW1=1D0-XW + SQMZ=PMAS(23,1)**2 + + GMMZ=PMAS(23,1)*PMAS(23,2) + SQMW=PMAS(24,1)**2 + GMMW=PMAS(24,1)*PMAS(24,2) + SH=VINT(44) + +C...Boost and rotate to rest frame of incoming partons, +C...to get proper amount of smearing of decay angles. + IBST=0 + IF(IRES.EQ.0) THEN + IBST=1 + IIN1=MINT(84)+1 + IIN2=MINT(84)+2 +C...Bug fix 09 OCT 2008 (PS) at 6.4.18: in new shower, the incoming partons +C...(101,102) are off shell and can have inconsistent momenta, resulting +C...in boosts larger than unity. However, the corresponding docu partons +C...(5,6) are kept on shell, and have consistent momenta that can be used +C...to derive this boost instead. Ultimately, should change the way the new +C...shower stores intermediate partons, but just using partons (5,6) for now +C...does define the boost and furnishes a quick and much needed solution. + IF (MINT(35).EQ.3) THEN + IIN1=MINT(83)+5 + IIN2=MINT(83)+6 + ENDIF + ETOTIN=P(IIN1,4)+P(IIN2,4) + BEXIN=(P(IIN1,1)+P(IIN2,1))/ETOTIN + BEYIN=(P(IIN1,2)+P(IIN2,2))/ETOTIN + BEZIN=(P(IIN1,3)+P(IIN2,3))/ETOTIN + CALL PYROBO(MINT(83)+7,N,0D0,0D0,-BEXIN,-BEYIN,-BEZIN) + PHIIN=PYANGL(P(MINT(84)+1,1),P(MINT(84)+1,2)) + CALL PYROBO(MINT(83)+7,N,0D0,-PHIIN,0D0,0D0,0D0) + THEIN=PYANGL(P(MINT(84)+1,3),P(MINT(84)+1,1)) + CALL PYROBO(MINT(83)+7,N,-THEIN,0D0,0D0,0D0,0D0) + ENDIF + +C...Reset original resonance configuration. + DO 100 JT=1,8 + IREF(1,JT)=0 + 100 CONTINUE + +C...Define initial one, two or three objects for subprocess. + IHDEC=0 + IF(IRES.EQ.0) THEN + ISUB=MINT(1) + IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN + IREF(1,1)=MINT(84)+2+ISET(ISUB) + IREF(1,4)=MINT(83)+6+ISET(ISUB) + JTMAX=1 + ELSEIF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN + IREF(1,1)=MINT(84)+1+ISET(ISUB) + IREF(1,2)=MINT(84)+2+ISET(ISUB) + IREF(1,4)=MINT(83)+5+ISET(ISUB) + IREF(1,5)=MINT(83)+6+ISET(ISUB) + JTMAX=2 + ELSEIF(ISET(ISUB).EQ.5) THEN + IREF(1,1)=MINT(84)+3 + IREF(1,2)=MINT(84)+4 + IREF(1,3)=MINT(84)+5 + IREF(1,4)=MINT(83)+7 + IREF(1,5)=MINT(83)+8 + IREF(1,6)=MINT(83)+9 + JTMAX=3 + ENDIF + +C...Define original resonance for odd cases. + ELSE + ISUB=0 + IF(K(IRES,2).EQ.25.OR.K(IRES,2).EQ.35.OR.K(IRES,2).EQ.36) + & IHDEC=1 + IF(IHDEC.EQ.1) ISUB=3 + IREF(1,1)=IRES + IREF(1,4)=K(IRES,3) + IRESTM=IRES + IF(IREF(1,4).GT.MINT(84)) THEN + 110 ITMPMO=IREF(1,4) + IF(K(ITMPMO,2).EQ.94) THEN + IREF(1,4)=K(ITMPMO,3)+(IRESTM-ITMPMO-1) + IF(K(IREF(1,4),3).LE.MINT(84)) IREF(1,4)=K(IREF(1,4),3) + ELSEIF(K(ITMPMO,2).EQ.K(IRES,2)) THEN + IRESTM=ITMPMO +C...Explicitly check that reference particle exists, otherwise stop recursion + IF(ITMPMO.GT.0.AND.K(ITMPMO,3).GT.0) THEN + IREF(1,4)=K(ITMPMO,3) + GOTO 110 + ENDIF + ENDIF + ENDIF + IF(IREF(1,4).GT.MINT(84)) THEN + EMATCH=1D10 + IREF14=IREF(1,4) + DO 120 II=MINT(83)+7,MINT(83)+MINT(4) + IF(K(II,2).EQ.K(IRES,2).AND.ABS(P(II,4)-P(IREF14,4)).LT. + & EMATCH) THEN + IREF(1,4)=II + EMATCH=ABS(P(II,4)-P(IREF14,4)) + ENDIF + 120 CONTINUE + ENDIF + JTMAX=1 + ENDIF + +C...Check if initial resonance has been moved (in resonance + jet). + DO 140 JT=1,3 + IF(IREF(1,JT).GT.0) THEN + IF(K(IREF(1,JT),1).GT.10) THEN + KFA=IABS(K(IREF(1,JT),2)) + IF(KFA.GE.6.AND.KCHG(PYCOMP(KFA),2).NE.0) THEN + KDA1=MOD(K(IREF(1,JT),4),MSTU(5)) + KDA2=MOD(K(IREF(1,JT),5),MSTU(5)) + IF(KDA1.GT.IREF(1,JT).AND.KDA1.LE.N) THEN + IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5) + ENDIF + IF(KDA2.GT.IREF(1,JT).AND.KDA2.LE.N) THEN + IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5) + ENDIF + DO 130 I=IREF(1,JT)+1,N + IF(K(I,2).EQ.K(IREF(1,JT),2).AND.(I.EQ.KDA1.OR. + & I.EQ.KDA2)) THEN + IREF(1,JT)=I + KDA1=MOD(K(IREF(1,JT),4),MSTU(5)) + KDA2=MOD(K(IREF(1,JT),5),MSTU(5)) + IF(KDA1.GT.IREF(1,JT).AND.KDA1.LE.N) THEN + IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5) + ENDIF + IF(KDA2.GT.IREF(1,JT).AND.KDA2.LE.N) THEN + IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5) + ENDIF + ENDIF + 130 CONTINUE + ELSE + KDA=MOD(K(IREF(1,JT),4),MSTU(5)) + IF(MWID(PYCOMP(KFA)).NE.0.AND.KDA.GT.1) IREF(1,JT)=KDA + ENDIF + ENDIF + ENDIF + 140 CONTINUE + +C...Set decay vertex for initial resonances + DO 160 JT=1,JTMAX + DO 150 I=1,4 + V(IREF(1,JT),I)=0D0 + 150 CONTINUE + 160 CONTINUE + +C...Loop over decay history. + NP=1 + IP=0 + 170 IP=IP+1 + NINH=0 + JTMAX=2 + IF(IREF(IP,2).EQ.0) JTMAX=1 + IF(IREF(IP,3).NE.0) JTMAX=3 + IT4=0 + NSAV=N + +C...Check for Higgs which appears as decay product of user-process. + IF(ISUB.EQ.0) THEN + IHDEC=0 + IF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.IREF(IP,7) + & .EQ.36) IHDEC=1 + IF(IHDEC.EQ.1) ISUB=3 + ENDIF + +C...Start treatment of one, two or three resonances in parallel. + 180 N=NSAV + DO 340 JT=1,JTMAX + ID=IREF(IP,JT) + KDCY(JT)=0 + KFL1(JT)=0 + KFL2(JT)=0 + KFL3(JT)=0 + KFL4(JT)=0 + KEQL(JT)=0 + NSD(JT)=ID + ITJUNC(JT)=0 + +C...Check whether particle can/is allowed to decay. + IF(ID.EQ.0) GOTO 330 + KFA=IABS(K(ID,2)) + KCA=PYCOMP(KFA) + IF(MWID(KCA).EQ.0) GOTO 330 + IF(K(ID,1).GT.10.OR.MDCY(KCA,1).EQ.0) GOTO 330 + IF(KFA.EQ.6.OR.KFA.EQ.7.OR.KFA.EQ.8.OR.KFA.EQ.17.OR. + & KFA.EQ.18) IT4=IT4+1 + K(ID,4)=MSTU(5)*(K(ID,4)/MSTU(5)) + K(ID,5)=MSTU(5)*(K(ID,5)/MSTU(5)) + +C...Choose lifetime and determine decay vertex. + IF(K(ID,1).EQ.5) THEN + V(ID,5)=0D0 + ELSEIF(K(ID,1).NE.4) THEN + V(ID,5)=-PMAS(KCA,4)*LOG(PYR(0)) + ENDIF + DO 190 J=1,4 + VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5) + 190 CONTINUE + +C...Determine whether decay allowed or not. + MOUT=0 + IF(MSTJ(22).EQ.2) THEN + IF(PMAS(KCA,4).GT.PARJ(71)) MOUT=1 + ELSEIF(MSTJ(22).EQ.3) THEN + IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1 + ELSEIF(MSTJ(22).EQ.4) THEN + IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1 + IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1 + ENDIF + IF(MOUT.EQ.1.AND.K(ID,1).NE.5) THEN + K(ID,1)=4 + GOTO 330 + ENDIF + +C...Info for selection of decay channel: sign, pairings. + IF(KCHG(KCA,3).EQ.0) THEN + IPM=2 + ELSE + IPM=(5-ISIGN(1,K(ID,2)))/2 + ENDIF + KFB=0 + IF(JTMAX.EQ.2) THEN + KFB=IABS(K(IREF(IP,3-JT),2)) + ELSEIF(JTMAX.EQ.3) THEN + JT2=JT+1-3*(JT/3) + KFB=IABS(K(IREF(IP,JT2),2)) + IF(KFB.NE.KFA) THEN + JT2=JT+2-3*((JT+1)/3) + KFB=IABS(K(IREF(IP,JT2),2)) + ENDIF + ENDIF + +C...Select decay channel. + IF(ISUB.EQ.1.OR.ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR. + & ISUB.EQ.30.OR.ISUB.EQ.35.OR.ISUB.EQ.141) MINT(61)=1 + CALL PYWIDT(KFA,P(ID,5)**2,WDTP,WDTE) + WDTE0S=WDTE(0,1)+WDTE(0,IPM)+WDTE(0,4) + IF(KFB.EQ.KFA) WDTE0S=WDTE0S+WDTE(0,5) + IF(WDTE0S.LE.0D0) GOTO 330 + RKFL=WDTE0S*PYR(0) + IDL=0 + 200 IDL=IDL+1 + IDC=IDL+MDCY(KCA,2)-1 + RKFL=RKFL-(WDTE(IDL,1)+WDTE(IDL,IPM)+WDTE(IDL,4)) + IF(KFB.EQ.KFA) RKFL=RKFL-WDTE(IDL,5) + IF(IDL.LT.MDCY(KCA,3).AND.RKFL.GT.0D0) GOTO 200 + + NPROD=0 +C...Read out flavours and colour charges of decay channel chosen. + KCQM(JT)=KCHG(KCA,2)*ISIGN(1,K(ID,2)) + IF(KCQM(JT).EQ.-2) KCQM(JT)=2 + KFL1(JT)=KFDP(IDC,1)*ISIGN(1,K(ID,2)) + KFC1A=PYCOMP(IABS(KFL1(JT))) + IF(KCHG(KFC1A,3).EQ.0) KFL1(JT)=IABS(KFL1(JT)) + NPROD=NPROD+1 + KCQ1(JT)=KCHG(KFC1A,2)*ISIGN(1,KFL1(JT)) + IF(KCQ1(JT).EQ.-2) KCQ1(JT)=2 + KFL2(JT)=KFDP(IDC,2)*ISIGN(1,K(ID,2)) + KFC2A=PYCOMP(IABS(KFL2(JT))) + IF(KCHG(KFC2A,3).EQ.0) KFL2(JT)=IABS(KFL2(JT)) + KCQ2(JT)=KCHG(KFC2A,2)*ISIGN(1,KFL2(JT)) + IF(KCQ2(JT).EQ.-2) KCQ2(JT)=2 + NPROD=NPROD+1 + KFL3(JT)=KFDP(IDC,3)*ISIGN(1,K(ID,2)) + KCQ3(JT)=0 + KFL4(JT)=KFDP(IDC,4)*ISIGN(1,K(ID,2)) + KCQ4(JT)=0 + IF(KFL3(JT).NE.0) THEN + KFC3A=PYCOMP(IABS(KFL3(JT))) + IF(KCHG(KFC3A,3).EQ.0) KFL3(JT)=IABS(KFL3(JT)) + KCQ3(JT)=KCHG(KFC3A,2)*ISIGN(1,KFL3(JT)) + IF(KCQ3(JT).EQ.-2) KCQ3(JT)=2 + NPROD=NPROD+1 + IF(KFL4(JT).NE.0) THEN + KFC4A=PYCOMP(IABS(KFL4(JT))) + IF(KCHG(KFC4A,3).EQ.0) KFL4(JT)=IABS(KFL4(JT)) + KCQ4(JT)=KCHG(KFC4A,2)*ISIGN(1,KFL4(JT)) + IF(KCQ4(JT).EQ.-2) KCQ4(JT)=2 + NPROD=NPROD+1 + ENDIF + ENDIF + +C...Set/save further info on channel. + KDCY(JT)=1 + IF(KFB.EQ.KFA) KEQL(JT)=MDME(IDC,1) + NSD(JT)=N + HGZ(JT,1)=VINT(111) + HGZ(JT,2)=VINT(112) + HGZ(JT,3)=VINT(114) + JTZ=JT + + PXSUM=0D0 +C...Select masses; to begin with assume resonances narrow. + DO 220 I=1,4 + P(N+I,5)=0D0 + PMMN(I)=0D0 + IF(I.EQ.1) THEN + KFLW=IABS(KFL1(JT)) + KCW=KFC1A + ELSEIF(I.EQ.2) THEN + KFLW=IABS(KFL2(JT)) + KCW=KFC2A + ELSEIF(I.EQ.3) THEN + IF(KFL3(JT).EQ.0) GOTO 220 + KFLW=IABS(KFL3(JT)) + KCW=KFC3A + ELSEIF(I.EQ.4) THEN + IF(KFL4(JT).EQ.0) GOTO 220 + KFLW=IABS(KFL4(JT)) + KCW=KFC4A + ENDIF + P(N+I,5)=PMAS(KCW,1) + PXSUM=PXSUM+P(N+I,5) +CMRENNA++ +C...This prevents SUSY/t particles from becoming too light. + IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN + PMMN(I)=PMAS(KCW,1) + DO 210 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1 + IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN + PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+ + & PMAS(PYCOMP(KFDP(IDC,2)),1) + IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+ + & PMAS(PYCOMP(KFDP(IDC,3)),1) + IF(KFDP(IDC,4).NE.0) PMSUM=PMSUM+ + & PMAS(PYCOMP(KFDP(IDC,4)),1) + PMMN(I)=MIN(PMMN(I),PMSUM) + ENDIF + 210 CONTINUE +C MRENNA-- + ELSEIF(KFLW.EQ.6) THEN + PMMN(I)=PMAS(24,1)+PMAS(5,1) + ENDIF +C...UED: select a graviton mass from continuous distribution +C...(stored in PMAS(39,1) so no value returned) + IF (IUED(1).EQ.1.AND.IUED(2).EQ.1.AND.KFLW.EQ.39) + & CALL PYGRAM(1) + 220 CONTINUE + +C...Check which two out of three are widest. + IWID1=1 + IWID2=2 + PWID1=PMAS(KFC1A,2) + PWID2=PMAS(KFC2A,2) + KFLW1=IABS(KFL1(JT)) + KFLW2=IABS(KFL2(JT)) + IF(KFL3(JT).NE.0) THEN + PWID3=PMAS(KFC3A,2) + IF(PWID3.GT.PWID1.AND.PWID2.GE.PWID1) THEN + IWID1=3 + PWID1=PWID3 + KFLW1=IABS(KFL3(JT)) + ELSEIF(PWID3.GT.PWID2) THEN + IWID2=3 + PWID2=PWID3 + KFLW2=IABS(KFL3(JT)) + ENDIF + ENDIF + IF(KFL4(JT).NE.0) THEN + PWID4=PMAS(KFC4A,2) + IF(PWID4.GT.PWID1.AND.PWID2.GE.PWID1) THEN + IWID1=4 + PWID1=PWID4 + KFLW1=IABS(KFL4(JT)) + ELSEIF(PWID4.GT.PWID2) THEN + IWID2=4 + PWID2=PWID4 + KFLW2=IABS(KFL4(JT)) + ENDIF + ENDIF + +C...If all narrow then only check that masses consistent. + IF(MSTP(42).LE.0.OR.(PWID1.LT.PARP(41).AND. + & PWID2.LT.PARP(41))) THEN +CMRENNA++ +C....Handle near degeneracy cases. + IF(KFA/KSUSY1.EQ.1.OR.KFA/KSUSY1.EQ.2) THEN + IF(P(N+1,5)+P(N+2,5)+P(N+3,5).GT.P(ID,5)) THEN + P(N+1,5)=P(ID,5)-P(N+2,5)-0.5D0 + IF(P(N+1,5).LT.0D0) P(N+1,5)=0D0 + ENDIF + ENDIF +CMRENNA-- + IF(PXSUM.GT.P(ID,5)) THEN + CALL PYERRM(13,'(PYRESD:) daughter masses too large') + MINT(51)=1 + GOTO 720 + ELSEIF(PXSUM+PARJ(64).GT.P(ID,5)) THEN + CALL PYERRM(3,'(PYRESD:) masses+PARJ(64) too large') + MINT(51)=1 + GOTO 720 + ENDIF + +C...For three wide resonances select narrower of three +C...according to BW decoupled from rest. + ELSE + PMTOT=P(ID,5) + IF(KFL3(JT).NE.0) THEN + IWID3=6-IWID1-IWID2 + KFLW3=IABS(KFL1(JT))+IABS(KFL2(JT))+IABS(KFL3(JT))- + & KFLW1-KFLW2 + LOOP=0 + 230 LOOP=LOOP+1 + P(N+IWID3,5)=PYMASS(KFLW3) + IF(LOOP.LE.10.AND. P(N+IWID3,5).LE.PMMN(IWID3)) GOTO 230 + PMTOT=PMTOT-P(N+IWID3,5) + ENDIF +C...Select other two correlated within remaining phase space. + IF(IP.EQ.1) THEN + CKIN45=CKIN(45) + CKIN47=CKIN(47) + CKIN(45)=MAX(PMMN(IWID1),CKIN(45)) + CKIN(47)=MAX(PMMN(IWID2),CKIN(47)) + CALL PYOFSH(2,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5), + & P(N+IWID2,5)) + CKIN(45)=CKIN45 + CKIN(47)=CKIN47 + ELSE + CKIN(49)=PMMN(IWID1) + CKIN(50)=PMMN(IWID2) + CALL PYOFSH(5,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5), + & P(N+IWID2,5)) + CKIN(49)=0D0 + CKIN(50)=0D0 + ENDIF + IF(MINT(51).EQ.1) GOTO 720 + ENDIF + +C...Begin fill decay products, with colour flow for coloured objects. + MSTU10=MSTU(10) + MSTU(10)=1 + MSTU(19)=1 + + +C...Three-body decays + IF(KFL3(JT).NE.0.OR.KFL4(JT).NE.0) THEN + DO 250 I=N+1,N+NPROD + DO 240 J=1,5 + K(I,J)=0 + V(I,J)=0D0 + 240 CONTINUE + MCT(I,1)=0 + MCT(I,2)=0 + 250 CONTINUE + K(N+1,1)=1 + K(N+1,2)=KFL1(JT) + K(N+2,1)=1 + K(N+2,2)=KFL2(JT) + K(N+3,1)=1 + K(N+3,2)=KFL3(JT) + IF(KFL4(JT).NE.0) THEN + K(N+4,1)=1 + K(N+4,2)=KFL4(JT) + ENDIF + IDIN=ID + +C...Generate kinematics (default is flat) + IF(KFL4(JT).EQ.0) THEN + CALL PYTBDY(IDIN) + ELSE + PS=P(N+1,5)+P(N+2,5)+P(N+3,5)+P(N+4,5) + ND=4 + PV(1,1)=0D0 + PV(1,2)=0D0 + PV(1,3)=0D0 + PV(1,4)=P(IDIN,5) + PV(1,5)=P(IDIN,5) +C...Calculate maximum weight ND-particle decay. + PV(ND,5)=P(N+ND,5) + WTMAX=1D0/WTCOR(ND-2) + PMAX=PV(1,5)-PS+P(N+ND,5) + PMIN=0D0 + DO 381 IL=ND-1,1,-1 + PMAX=PMAX+P(N+IL,5) + PMIN=PMIN+P(N+IL+1,5) + WTMAX=WTMAX*PAWT(PMAX,PMIN,P(N+IL,5)) + 381 CONTINUE + +C...M-generator gives weight. If rejected, try again. + + 411 RORD(1)=1D0 + DO 441 IL1=2,ND-1 + RSAV=PYR(0) + DO 421 IL2=IL1-1,1,-1 + IF(RSAV.LE.RORD(IL2)) GOTO 431 + RORD(IL2+1)=RORD(IL2) + 421 CONTINUE + 431 RORD(IL2+1)=RSAV + 441 CONTINUE + RORD(ND)=0D0 + WT=1D0 + DO 451 IL=ND-1,1,-1 + PV(IL,5)=PV(IL+1,5)+P(N+IL,5)+(RORD(IL)-RORD(IL+1))* + & (PV(1,5)-PS) + WT=WT*PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5)) + 451 CONTINUE + IF(WT.LT.PYR(0)*WTMAX) GOTO 411 + +C...Perform two-particle decays in respective CM frame. + DO 481 IL=1,ND-1 + PA=PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5)) + UE(3)=2D0*PYR(0)-1D0 + PHIX=PARU(2)*PYR(0) + UE(1)=SQRT(1D0-UE(3)**2)*COS(PHIX) + UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHIX) + DO 471 J=1,3 + P(N+IL,J)=PA*UE(J) + PV(IL+1,J)=-PA*UE(J) + 471 CONTINUE + P(N+IL,4)=SQRT(PA**2+P(N+IL,5)**2) + PV(IL+1,4)=SQRT(PA**2+PV(IL+1,5)**2) + 481 CONTINUE + +C...Lorentz transform decay products to lab frame. + DO 491 J=1,4 + P(N+ND,J)=PV(ND,J) + 491 CONTINUE + DO 531 IL=ND-1,1,-1 + DO 501 J=1,3 + BE(J)=PV(IL,J)/PV(IL,4) + 501 CONTINUE + GA=PV(IL,4)/PV(IL,5) + DO 521 I=N+IL,N+ND + BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3) + DO 511 J=1,3 + P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J) + 511 CONTINUE + P(I,4)=GA*(P(I,4)+BEP) + 521 CONTINUE + 531 CONTINUE + + ENDIF + +C...Set generic colour flows whenever unambiguous, +C...(independently of the order of the decay products) +C...Sum up total colour content + NANT=0 + NTRI=0 + NOCT=0 + KCQ(0)=KCQM(JT) + KCQ(1)=KCQ1(JT) + KCQ(2)=KCQ2(JT) + KCQ(3)=KCQ3(JT) + KCQ(4)=KCQ4(JT) + DO 255 J=0,NPROD + IF (KCQ(J).EQ.-1) THEN + NANT=NANT+1 + IANT(NANT)=N+J + ELSEIF (KCQ(J).EQ.1) THEN + NTRI=NTRI+1 + ITRI(NTRI)=N+J + ELSEIF (KCQ(J).EQ.2) THEN + NOCT=NOCT+1 + IOCT(NOCT)=N+J + ENDIF + 255 CONTINUE + +C...Set color flow for generic 1 -> N processes (N arbitrary) + IF (NTRI.EQ.0.AND.NANT.EQ.0.AND.NOCT.EQ.0) THEN +C...All singlets: do nothing + + ELSEIF (NOCT.EQ.2.AND.NTRI.EQ.0.AND.NANT.EQ.0) THEN +C...Two octets, zero triplets, n singlets: + IF (KCQ(0).EQ.2) THEN +C...8 -> 8 + n(1) + K(ID,4)=K(ID,4)+IOCT(2) + K(ID,5)=K(ID,5)+IOCT(2) + K(IOCT(2),1)=3 + K(IOCT(2),4)=MSTU(5)*ID + K(IOCT(2),5)=MSTU(5)*ID + MCT(IOCT(2),1)=MCT(ID,1) + MCT(IOCT(2),2)=MCT(ID,2) + ELSE +C...1 -> 8 + 8 + n(1) + K(IOCT(1),1)=3 + K(IOCT(1),4)=MSTU(5)*IOCT(2) + K(IOCT(1),5)=MSTU(5)*IOCT(2) + K(IOCT(2),1)=3 + K(IOCT(2),4)=MSTU(5)*IOCT(1) + K(IOCT(2),5)=MSTU(5)*IOCT(1) + NCT=NCT+1 + MCT(IOCT(1),1)=NCT + MCT(IOCT(2),2)=NCT + NCT=NCT+1 + MCT(IOCT(2),1)=NCT + MCT(IOCT(1),2)=NCT + ENDIF + + ELSEIF (NTRI+NANT.EQ.2.AND.NOCT.EQ.0) THEN +C...Two triplets, zero octets, n singlets. + IF (KCQ(0).EQ.1) THEN +C...3 -> 3 + n(1) + K(ID,4)=K(ID,4)+ITRI(2) + K(ITRI(2),1)=3 + K(ITRI(2),4)=MSTU(5)*ID + MCT(ITRI(2),1)=MCT(ID,1) + ELSEIF (KCQ(0).EQ.-1) THEN +C...3bar -> 3bar + n(1) + K(ID,5)=K(ID,5)+IANT(2) + K(IANT(2),1)=3 + K(IANT(2),5)=MSTU(5)*ID + MCT(IANT(2),2)=MCT(ID,2) + ELSE +C...1 -> 3 + 3bar + n(1) + K(ITRI(1),1)=3 + K(ITRI(1),4)=MSTU(5)*IANT(1) + K(IANT(1),1)=3 + K(IANT(1),5)=MSTU(5)*ITRI(1) + NCT=NCT+1 + MCT(ITRI(1),1)=NCT + MCT(IANT(1),2)=NCT + ENDIF + + ELSEIF(NTRI+NANT.EQ.2.AND.NOCT.EQ.1) THEN +C...Two triplets, one octet, n singlets. + IF (KCQ(0).EQ.2) THEN +C...8 -> 3 + 3bar + n(1) + K(ID,4)=K(ID,4)+ITRI(1) + K(ID,5)=K(ID,5)+IANT(1) + K(ITRI(1),1)=3 + K(ITRI(1),4)=MSTU(5)*ID + K(IANT(1),1)=3 + K(IANT(1),5)=MSTU(5)*ID + MCT(ITRI(1),1)=MCT(ID,1) + MCT(IANT(1),2)=MCT(ID,2) + ELSEIF (KCQ(0).EQ.1) THEN +C...3 -> 8 + 3 + n(1) + K(ID,4)=K(ID,4)+IOCT(1) + K(IOCT(1),1)=3 + K(IOCT(1),4)=MSTU(5)*ID + K(IOCT(1),5)=MSTU(5)*ITRI(2) + K(ITRI(2),1)=3 + K(ITRI(2),4)=MSTU(5)*IOCT(1) + MCT(IOCT(1),1)=MCT(ID,1) + NCT=NCT+1 + MCT(IOCT(1),2)=NCT + MCT(ITRI(2),1)=NCT + ELSEIF (KCQ(0).EQ.-1) THEN +C...3bar -> 8 + 3bar + n(1) + K(ID,5)=K(ID,5)+IOCT(1) + K(IOCT(1),1)=3 + K(IOCT(1),5)=MSTU(5)*ID + K(IOCT(1),4)=MSTU(5)*IANT(2) + K(IANT(2),1)=3 + K(IANT(2),5)=MSTU(5)*IOCT(1) + MCT(IOCT(1),2)=MCT(ID,2) + NCT=NCT+1 + MCT(IOCT(1),1)=NCT + MCT(IANT(2),2)=NCT + ELSE +C...1 -> 3 + 3bar + 8 + n(1) + K(ITRI(1),1)=3 + K(ITRI(1),4)=MSTU(5)*IOCT(1) + K(IOCT(1),1)=3 + K(IOCT(1),5)=MSTU(5)*ITRI(1) + K(IOCT(1),4)=MSTU(5)*IANT(1) + K(IANT(1),1)=3 + K(IANT(1),5)=MSTU(5)*IOCT(1) + NCT=NCT+1 + MCT(ITRI(1),1)=NCT + MCT(IOCT(1),2)=NCT + NCT=NCT+1 + MCT(IOCT(1),1)=NCT + MCT(IANT(1),2)=NCT + ENDIF + ELSEIF(NTRI+NANT.EQ.4) THEN +C... + IF (KCQ(0).EQ.1) THEN +C...3 -> 3 + n(1) -> 3 + 3bar + K(ID,4)=K(ID,4)+ITRI(2) + K(ITRI(2),1)=3 + K(ITRI(2),4)=MSTU(5)*ID + MCT(ITRI(2),1)=MCT(ID,1) + K(ITRI(3),1)=3 + K(ITRI(3),4)=MSTU(5)*IANT(1) + K(IANT(1),1)=3 + K(IANT(1),5)=MSTU(5)*ITRI(3) + NCT=NCT+1 + MCT(ITRI(3),1)=NCT + MCT(IANT(1),2)=NCT + ELSEIF (KCQ(0).EQ.-1) THEN +C...3bar -> 3bar + n(1) -> 3 + 3bar + K(ID,5)=K(ID,5)+IANT(2) + K(IANT(2),1)=3 + K(IANT(2),5)=MSTU(5)*ID + MCT(IANT(2),2)=MCT(ID,2) + K(ITRI(1),1)=3 + K(ITRI(1),4)=MSTU(5)*IANT(3) + K(IANT(3),1)=3 + K(IANT(3),5)=MSTU(5)*ITRI(1) + NCT=NCT+1 + MCT(ITRI(1),1)=NCT + MCT(IANT(3),2)=NCT + ENDIF + ELSEIF(KFL4(JT).NE.0) THEN + CALL PYERRM(21,'(PYRESD:) unknown 4-bdy decay') +CPS-- End of generic cases +C...(could three octets also be handled?) +C...(could (some of) the RPV cases be made generic as well?) + +C...Special cases (= old treatment) +C...Set colour flow for t -> W + b + Z. + ELSEIF(KFA.EQ.6) THEN + K(N+2,1)=3 + ISID=4 + IF(KCQM(JT).EQ.-1) ISID=5 + IDAU=N+2 + K(ID,ISID)=K(ID,ISID)+IDAU + K(IDAU,ISID)=MSTU(5)*ID + +C...Set colour flow in three-body decays - programmed as special cases. + + ELSEIF(KFC2A.LE.6) THEN + K(N+2,1)=3 + K(N+3,1)=3 + ISID=4 + IF(KFL2(JT).LT.0) ISID=5 + K(N+2,ISID)=MSTU(5)*(N+3) + K(N+3,9-ISID)=MSTU(5)*(N+2) +C...PS++: Bugfix 16 MAR 2006 for 3-body squark decays (e.g. via SLHA) + ELSEIF(KFA.GT.KSUSY1.AND.MOD(KFA,KSUSY1).LT.10 + & .AND.KFL3(JT).NE.0) THEN + KQSUMA=IABS(KCQ1(JT))+IABS(KCQ2(JT))+IABS(KCQ3(JT)) +C...3-body decays of squarks to colour singlets plus one quark + IF (KQSUMA.EQ.1) THEN +C...Find quark + IQ=0 + IF (KCQ1(JT).NE.0) IQ=1 + IF (KCQ2(JT).NE.0) IQ=2 + IF (KCQ3(JT).NE.0) IQ=3 + ISID=4 + IF (K(N+IQ,2).LT.0) ISID=5 + K(N+IQ,1)=3 + K(ID,ISID)=K(ID,ISID)+(N+IQ) + K(N+IQ,ISID)=MSTU(5)*ID + ENDIF +C...PS-- + ELSEIF(KFL1(JT).EQ.KSUSY1+21) THEN + K(N+1,1)=3 + K(N+2,1)=3 + K(N+3,1)=3 + ISID=4 + IF(KFL2(JT).LT.0) ISID=5 + K(N+1,ISID)=MSTU(5)*(N+2) + K(N+1,9-ISID)=MSTU(5)*(N+3) + K(N+2,ISID)=MSTU(5)*(N+1) + K(N+3,9-ISID)=MSTU(5)*(N+1) + ELSEIF(KFA.EQ.KSUSY1+21) THEN + K(N+2,1)=3 + K(N+3,1)=3 + ISID=4 + IF(KFL2(JT).LT.0) ISID=5 + K(ID,ISID)=K(ID,ISID)+(N+2) + K(ID,9-ISID)=K(ID,9-ISID)+(N+3) + K(N+2,ISID)=MSTU(5)*ID + K(N+3,9-ISID)=MSTU(5)*ID +CMRENNA-- + + ELSEIF(KFA.GE.KSUSY1+22.AND.KFA.LE.KSUSY1+37.AND. + & IABS(KCQ2(JT)).EQ.1) THEN + K(N+2,1)=3 + K(N+3,1)=3 + ISID=4 + IF(KFL2(JT).LT.0) ISID=5 + K(N+2,ISID)=MSTU(5)*(N+3) + K(N+3,9-ISID)=MSTU(5)*(N+2) + ENDIF + + NSAV=N + +C...Set colour flow in three-body decays with baryon number violation. +C...Neutralino and chargino decays first. + KCQSUM=KCQ1(JT)+KCQ2(JT)+KCQ3(JT) + IF(KCQM(JT).EQ.0.AND.IABS(KCQSUM).EQ.3) THEN + ITJUNC(JT)=(1+(1-KCQ1(JT))/2) + K(N+4,4)=ITJUNC(JT)*MSTU(5) +C...Insert junction to keep track of colours. + IF(KCQ1(JT).NE.0) K(N+1,1)=3 + IF(KCQ2(JT).NE.0) K(N+2,1)=3 + IF(KCQ3(JT).NE.0) K(N+3,1)=3 +C...Set special junction codes: + K(N+4,1)=42 + K(N+4,2)=88 + +C...Order decay products by invariant mass. (will be used in PYSTRF). + PM12=P(N+1,4)*P(N+2,4)-P(N+1,1)*P(N+2,1)-P(N+1,2)*P(N+2,2)- + & P(N+1,3)*P(N+2,3) + PM13=P(N+1,4)*P(N+3,4)-P(N+1,1)*P(N+3,1)-P(N+1,2)*P(N+3,2)- + & P(N+1,3)*P(N+3,3) + PM23=P(N+2,4)*P(N+3,4)-P(N+2,1)*P(N+3,1)-P(N+2,2)*P(N+3,2)- + & P(N+2,3)*P(N+3,3) + IF(PM12.LT.PM13.AND.PM12.LT.PM23) THEN + K(N+4,4)=N+3+K(N+4,4) + K(N+4,5)=N+1+MSTU(5)*(N+2) + ELSEIF(PM13.LT.PM23) THEN + K(N+4,4)=N+2+K(N+4,4) + K(N+4,5)=N+1+MSTU(5)*(N+3) + ELSE + K(N+4,4)=N+1+K(N+4,4) + K(N+4,5)=N+2+MSTU(5)*(N+3) + ENDIF + DO 260 J=1,5 + P(N+4,J)=0D0 + V(N+4,J)=0D0 + 260 CONTINUE +C...Connect daughters to junction. + DO 270 II=N+1,N+3 + K(II,4)=0 + K(II,5)=0 + K(II,ITJUNC(JT)+3)=MSTU(5)*(N+4) + 270 CONTINUE +C...Particle counter should be stepped up one extra for junction. + N=N+1 + +C...Gluino decays. + ELSEIF (KCQM(JT).EQ.2.AND.IABS(KCQSUM).EQ.3) THEN + ITJUNC(JT)=(5+(1-KCQ1(JT))/2) + K(N+4,4)=ITJUNC(JT)*MSTU(5) +C...Insert junction to keep track of colours. + IF(KCQ1(JT).NE.0) K(N+1,1)=3 + IF(KCQ2(JT).NE.0) K(N+2,1)=3 + IF(KCQ3(JT).NE.0) K(N+3,1)=3 + K(N+4,1)=42 + K(N+4,2)=88 + DO 280 J=1,5 + P(N+4,J)=0D0 + V(N+4,J)=0D0 + 280 CONTINUE + CTMSUM=0D0 + DO 290 II=N+1,N+3 + K(II,4)=0 + K(II,5)=0 +C...Start by connecting all daughters to junction. + K(II,ITJUNC(JT)-1)=MSTU(5)*(N+4) +C...Only consider colour topologies with off shell resonances. + RMQ1=PMAS(PYCOMP(K(II,2)),1) + RMRES=PMAS(PYCOMP(KSUSY1+IABS(K(II,2))),1) + RMGLU=PMAS(PYCOMP(KSUSY1+21),1) + IF (RMGLU-RMQ1.LT.RMRES) THEN +C...Calculate propagators for each colour topology. + RM2Q23=RMGLU**2+RMQ1**2-2D0*(P(II,4)*P(ID,4)+P(II,1) + & *P(ID,1)+P(II,2)*P(ID,2)+P(II,3)*P(ID,3)) + CTM2(II-N)=1D0/(RM2Q23-RMRES**2)**2 + ELSE + CTM2(II-N)=0D0 + ENDIF + CTMSUM=CTMSUM+CTM2(II-N) + 290 CONTINUE + CTMSUM=PYR(0)*CTMSUM +C...Select colour topology J, with most off shell least likely. + J=0 + 300 J=J+1 + CTMSUM=CTMSUM-CTM2(J) + IF (CTMSUM.GT.0D0) GOTO 300 +C...The lucky winner gets its colour (anti-colour) directly from gluino. + K(N+J,ITJUNC(JT)-1)=MSTU(5)*ID + K(ID,ITJUNC(JT)-1)=N+J+(K(ID,ITJUNC(JT)-1)/MSTU(5))*MSTU(5) +C...The other gluino colour is connected to junction + K(ID,10-ITJUNC(JT))=N+4+(K(ID,10-ITJUNC(JT))/MSTU(5))* + & MSTU(5) + K(N+4,4)=K(N+4,4)+ID +C...Lastly, connect junction to remaining daughters. + K(N+4,5)=N+1+MOD(J,3)+MSTU(5)*(N+1+MOD(J+1,3)) +C...Particle counter should be stepped up one extra for junction. + N=N+1 + ENDIF + +C...Update particle counter. + N=N+NPROD + +C...2) Everything else two-body decay. + ELSE + CALL PY2ENT(N+1,KFL1(JT),KFL2(JT),P(ID,5)) + MCT(N-1,1)=0 + MCT(N-1,2)=0 + MCT(N,1)=0 + MCT(N,2)=0 +C...First set colour flow as if mother colour singlet. + IF(KCQ1(JT).NE.0) THEN + K(N-1,1)=3 + IF(KCQ1(JT).NE.-1) K(N-1,4)=MSTU(5)*N + IF(KCQ1(JT).NE.1) K(N-1,5)=MSTU(5)*N + ENDIF + IF(KCQ2(JT).NE.0) THEN + K(N,1)=3 + IF(KCQ2(JT).NE.-1) K(N,4)=MSTU(5)*(N-1) + IF(KCQ2(JT).NE.1) K(N,5)=MSTU(5)*(N-1) + ENDIF +C...Then redirect colour flow if mother (anti)triplet. + IF(KCQM(JT).EQ.0) THEN + ELSEIF(KCQM(JT).NE.2) THEN + ISID=4 + IF(KCQM(JT).EQ.-1) ISID=5 + IDAU=N-1 + IF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.2) IDAU=N + K(ID,ISID)=K(ID,ISID)+IDAU + K(IDAU,ISID)=MSTU(5)*ID +C...Then redirect colour flow if mother octet. + ELSEIF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.0) THEN + IDAU=N-1 + IF(KCQ1(JT).EQ.0) IDAU=N + K(ID,4)=K(ID,4)+IDAU + K(ID,5)=K(ID,5)+IDAU + K(IDAU,4)=MSTU(5)*ID + K(IDAU,5)=MSTU(5)*ID + ELSE + ISID=4 + IF(KCQ1(JT).EQ.-1) ISID=5 + IF(KCQ1(JT).EQ.2) ISID=INT(4.5D0+PYR(0)) + K(ID,ISID)=K(ID,ISID)+(N-1) + K(ID,9-ISID)=K(ID,9-ISID)+N + K(N-1,ISID)=MSTU(5)*ID + K(N,9-ISID)=MSTU(5)*ID + ENDIF + +C...Insert junction + IF(IABS(KCQ1(JT)+KCQ2(JT)-KCQM(JT)).EQ.3) THEN + N=N+1 +C...~q* mother: type 3 junction. ~q mother: type 4. + ITJUNC(JT)=(7+KCQM(JT))/2 +C...Specify junction KF and set colour flow from junction + K(N,1)=42 + K(N,2)=88 + K(N,3)=ID +C...Junction type encoded together with mother: + K(N,4)=ID+ITJUNC(JT)*MSTU(5) + K(N,5)=N-1+MSTU(5)*(N-2) +C...Zero P and V for junction (V filled later) + DO 310 J=1,5 + P(N,J)=0D0 + V(N,J)=0D0 + 310 CONTINUE +C...Set colour flow from mother to junction + K(ID,8-ITJUNC(JT))= N + MSTU(5)*(K(ID,8-ITJUNC(JT))/MSTU(5)) +C...Set colour flow from daughters to junction + DO 320 II=N-2,N-1 + K(II,4) = 0 + K(II,5) = 0 +C...(Anti-)colour mother is junction. + K(II,1+ITJUNC(JT)) = MSTU(5)*N + 320 CONTINUE + ENDIF + ENDIF + +C...End loop over resonances for daughter flavour and mass selection. + MSTU(10)=MSTU10 + 330 IF(MWID(KCA).NE.0.AND.(KFL1(JT).EQ.0.OR.KFL3(JT).NE.0)) + & NINH=NINH+1 + IF(IRES.GT.0.AND.MWID(KCA).NE.0.AND.MDCY(KCA,1).NE.0.AND. + & KFL1(JT).EQ.0) THEN + WRITE(CODE,'(I9)') K(ID,2) + WRITE(MASS,'(F9.3)') P(ID,5) + CALL PYERRM(3,'(PYRESD:) Failed to decay particle'// + & CODE//' with mass'//MASS) + MINT(51)=1 + GOTO 720 + ENDIF + 340 CONTINUE + +C...Check for allowed combinations. Skip if no decays. + IF(JTMAX.EQ.1) THEN + IF(KDCY(1).EQ.0) GOTO 710 + ELSEIF(JTMAX.EQ.2) THEN + IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0) GOTO 710 + IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 180 + IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 180 + ELSEIF(JTMAX.EQ.3) THEN + IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0.AND.KDCY(3).EQ.0) GOTO 710 + IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 180 + IF(KEQL(1).EQ.4.AND.KEQL(3).EQ.4) GOTO 180 + IF(KEQL(2).EQ.4.AND.KEQL(3).EQ.4) GOTO 180 + IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 180 + IF(KEQL(1).EQ.5.AND.KEQL(3).EQ.5) GOTO 180 + IF(KEQL(2).EQ.5.AND.KEQL(3).EQ.5) GOTO 180 + ENDIF + +C...Special case: matrix element option for Z0 decay to quarks. + IF(MSTP(48).EQ.1.AND.ISUB.EQ.1.AND.JTMAX.EQ.1.AND. + &IABS(MINT(11)).EQ.11.AND.IABS(KFL1(1)).LE.5) THEN + +C...Check consistency of MSTJ options set. + IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN + CALL PYERRM(6, + & '(PYRESD:) MSTJ(109) value requires MSTJ(110) = 1') + MSTJ(110)=1 + ENDIF + IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN + CALL PYERRM(6, + & '(PYRESD:) MSTJ(109) value requires MSTJ(111) = 0') + + MSTJ(111)=0 + ENDIF + +C...Select alpha_strong behaviour. + MST111=MSTU(111) + PAR112=PARU(112) + MSTU(111)=MSTJ(108) + IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1)) + & MSTU(111)=1 + PARU(112)=PARJ(121) + IF(MSTU(111).EQ.2) PARU(112)=PARJ(122) + +C...Find axial fraction in total cross section for scalar gluon model. + PARJ(171)=0D0 + IF((IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.1).OR. + & (MSTJ(101).EQ.5.AND.MSTJ(49).EQ.1)) THEN + POLL=1D0-PARJ(131)*PARJ(132) + SFF=1D0/(16D0*XW*XW1) + SFW=P(ID,5)**4/((P(ID,5)**2-PARJ(123)**2)**2+ + & (PARJ(123)*PARJ(124))**2) + SFI=SFW*(1D0-(PARJ(123)/P(ID,5))**2) + VE=4D0*XW-1D0 + HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131)) + HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE* + & (PARJ(132)-PARJ(131))) + KFLC=IABS(KFL1(1)) + PMQ=PYMASS(KFLC) + QF=KCHG(KFLC,1)/3D0 + VQ=1D0 + IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0, + & 1D0-(2D0*PMQ/P(ID,5))**2)) + VF=SIGN(1D0,QF)-4D0*QF*XW + RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+ + & VF**2*HF1W)+VQ**3*HF1W + IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV) + ENDIF + +C...Choice of jet configuration. + CALL PYXJET(P(ID,5),NJET,CUT) + KFLC=IABS(KFL1(1)) + KFLN=21 + IF(NJET.EQ.4) THEN + CALL PYX4JT(NJET,CUT,KFLC,P(ID,5),KFLN,X1,X2,X4,X12,X14) + ELSEIF(NJET.EQ.3) THEN + CALL PYX3JT(NJET,CUT,KFLC,P(ID,5),X1,X3) + ELSE + MSTJ(120)=1 + ENDIF + +C...Fill jet configuration; return if incorrect kinematics. + NC=N-2 + IF(NJET.EQ.2.AND.MSTJ(101).NE.5) THEN + CALL PY2ENT(NC+1,KFLC,-KFLC,P(ID,5)) + ELSEIF(NJET.EQ.2) THEN + CALL PY2ENT(-(NC+1),KFLC,-KFLC,P(ID,5)) + ELSEIF(NJET.EQ.3) THEN + CALL PY3ENT(NC+1,KFLC,21,-KFLC,P(ID,5),X1,X3) + ELSEIF(KFLN.EQ.21) THEN + CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4, + & X12,X14) + ELSE + CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4, + & X12,X14) + ENDIF + IF(MSTU(24).NE.0) THEN + MINT(51)=1 + MSTU(111)=MST111 + PARU(112)=PAR112 + GOTO 720 + ENDIF + +C...Angular orientation according to matrix element. + IF(MSTJ(106).EQ.1) THEN + CALL PYXDIF(NC,NJET,KFLC,P(ID,5),CHIZ,THEZ,PHIZ) + IF(MINT(11).LT.0) THEZ=PARU(1)-THEZ + CTHE(1)=COS(THEZ) + CALL PYROBO(NC+1,N,0D0,CHIZ,0D0,0D0,0D0) + CALL PYROBO(NC+1,N,THEZ,PHIZ,0D0,0D0,0D0) + ENDIF + +C...Boost partons to Z0 rest frame. + CALL PYROBO(NC+1,N,0D0,0D0,P(ID,1)/P(ID,4), + & P(ID,2)/P(ID,4),P(ID,3)/P(ID,4)) + +C...Mark decayed resonance and add documentation lines, + K(ID,1)=K(ID,1)+10 + IDOC=MINT(83)+MINT(4) + DO 360 I=NC+1,N + I1=MINT(83)+MINT(4)+1 + K(I,3)=I1 + IF(MSTP(128).GE.1) K(I,3)=ID + IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN + MINT(4)=MINT(4)+1 + K(I1,1)=21 + K(I1,2)=K(I,2) + K(I1,3)=IREF(IP,4) + DO 350 J=1,5 + P(I1,J)=P(I,J) + 350 CONTINUE + ENDIF + 360 CONTINUE + +C...Generate parton shower. + IF(MSTJ(101).EQ.5.AND.MINT(35).LE.1) THEN + CALL PYSHOW(N-1,N,P(ID,5)) + ELSEIF(MSTJ(101).EQ.5.AND.MINT(35).GE.2) THEN + NPART=2 + IPART(1)=N-1 + IPART(2)=N + PTPART(1)=0.5D0*P(ID,5) + PTPART(2)=PTPART(1) + NCT=NCT+1 + IF(K(N-1,2).GT.0) THEN + MCT(N-1,1)=NCT + MCT(N,2)=NCT + ELSE + MCT(N-1,2)=NCT + MCT(N,1)=NCT + ENDIF + CALL PYPTFS(2,0.5D0*P(ID,5),0D0,PTGEN) + ENDIF + +C... End special case for Z0: skip ahead. + MSTU(111)=MST111 + PARU(112)=PAR112 + GOTO 700 + ENDIF + +C...Order incoming partons and outgoing resonances. + IF(JTMAX.EQ.2.AND.ISUB.NE.0.AND.MSTP(47).GE.1.AND. + &NINH.EQ.0) THEN + ILIN(1)=MINT(84)+1 + IF(K(MINT(84)+1,2).GT.0) ILIN(1)=MINT(84)+2 + IF(K(ILIN(1),2).EQ.21.OR.K(ILIN(1),2).EQ.22) + & ILIN(1)=2*MINT(84)+3-ILIN(1) + ILIN(2)=2*MINT(84)+3-ILIN(1) + IMIN=1 + IF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.IREF(IP,7) + & .EQ.36) IMIN=3 + IMAX=2 + IORD=1 + IF(K(IREF(IP,1),2).EQ.23) IORD=2 + IF(K(IREF(IP,1),2).EQ.24.AND.K(IREF(IP,2),2).EQ.-24) IORD=2 + IAKIPD=IABS(K(IREF(IP,IORD),2)) + IF(IAKIPD.EQ.25.OR.IAKIPD.EQ.35.OR.IAKIPD.EQ.36) IORD=3-IORD + IF(KDCY(IORD).EQ.0) IORD=3-IORD + +C...Order decay products of resonances. + DO 370 JT=IORD,3-IORD,3-2*IORD + IF(KDCY(JT).EQ.0) THEN + ILIN(IMAX+1)=NSD(JT) + IMAX=IMAX+1 + ELSEIF(K(NSD(JT)+1,2).GT.0) THEN + ILIN(IMAX+1)=N+2*JT-1 + ILIN(IMAX+2)=N+2*JT + IMAX=IMAX+2 + K(N+2*JT-1,2)=K(NSD(JT)+1,2) + K(N+2*JT,2)=K(NSD(JT)+2,2) + ELSE + ILIN(IMAX+1)=N+2*JT + + ILIN(IMAX+2)=N+2*JT-1 + IMAX=IMAX+2 + K(N+2*JT-1,2)=K(NSD(JT)+1,2) + K(N+2*JT,2)=K(NSD(JT)+2,2) + ENDIF + 370 CONTINUE + +C...Find charge, isospin, left- and righthanded couplings. + DO 390 I=IMIN,IMAX + DO 380 J=1,4 + COUP(I,J)=0D0 + 380 CONTINUE + KFA=IABS(K(ILIN(I),2)) + IF(KFA.EQ.0.OR.KFA.GT.20) GOTO 390 + COUP(I,1)=KCHG(KFA,1)/3D0 + COUP(I,2)=(-1)**MOD(KFA,2) + COUP(I,4)=-2D0*COUP(I,1)*XWV + COUP(I,3)=COUP(I,2)+COUP(I,4) + 390 CONTINUE + +C...Full propagator dependence and flavour correlations for 2 gamma*/Z. + IF(ISUB.EQ.22) THEN + DO 420 I=3,5,2 + I1=IORD + IF(I.EQ.5) I1=3-IORD + DO 410 J1=1,2 + DO 400 J2=1,2 + CORL(I/2,J1,J2)=COUP(1,1)**2*HGZ(I1,1)*COUP(I,1)**2/ + & 16D0+COUP(1,1)*COUP(1,J1+2)*HGZ(I1,2)*COUP(I,1)* + & COUP(I,J2+2)/4D0+COUP(1,J1+2)**2*HGZ(I1,3)* + & COUP(I,J2+2)**2 + 400 CONTINUE + 410 CONTINUE + 420 CONTINUE + COWT12=(CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+ + & (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2)) + COMX12=(CORL(1,1,1)+CORL(1,1,2)+CORL(1,2,1)+CORL(1,2,2))* + & (CORL(2,1,1)+CORL(2,1,2)+CORL(2,2,1)+CORL(2,2,2)) + + IF(COWT12.LT.PYR(0)*COMX12) GOTO 180 + ENDIF + ENDIF + +C...Select angular orientation type - Z'/W' only. + MZPWP=0 + IF(ISUB.EQ.141) THEN + IF(PYR(0).LT.PARU(130)) MZPWP=1 + IF(IP.EQ.2) THEN + IF(IABS(K(IREF(2,1),2)).EQ.37) MZPWP=2 + IAKIR=IABS(K(IREF(2,2),2)) + IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2 + IF(IAKIR.LE.20) MZPWP=2 + ENDIF + IF(IP.GE.3) MZPWP=2 + ELSEIF(ISUB.EQ.142) THEN + IF(PYR(0).LT.PARU(136)) MZPWP=1 + IF(IP.EQ.2) THEN + IAKIR=IABS(K(IREF(2,2),2)) + IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2 + IF(IAKIR.LE.20) MZPWP=2 + ENDIF + IF(IP.GE.3) MZPWP=2 + ENDIF + +C...Select random angles (begin of weighting procedure). + 430 DO 440 JT=1,JTMAX + IF(KDCY(JT).EQ.0) GOTO 440 + IF(JTMAX.EQ.1.AND.ISUB.NE.0.AND.IHDEC.EQ.0) THEN + CTHE(JT)=VINT(13)+(VINT(33)-VINT(13)+VINT(34)-VINT(14))*PYR(0) + IF(CTHE(JT).GT.VINT(33)) CTHE(JT)=CTHE(JT)+VINT(14)-VINT(33) + PHI(JT)=VINT(24) + ELSE + CTHE(JT)=2D0*PYR(0)-1D0 + PHI(JT)=PARU(2)*PYR(0) + ENDIF + 440 CONTINUE + + IF(JTMAX.EQ.2.AND.MSTP(47).GE.1.AND.NINH.EQ.0) THEN +C...Construct massless four-vectors. + DO 460 I=N+1,N+4 + K(I,1)=1 + DO 450 J=1,5 + P(I,J)=0D0 + V(I,J)=0D0 + 450 CONTINUE + 460 CONTINUE + DO 470 JT=1,JTMAX + IF(KDCY(JT).EQ.0) GOTO 470 + ID=IREF(IP,JT) + P(N+2*JT-1,3)=0.5D0*P(ID,5) + P(N+2*JT-1,4)=0.5D0*P(ID,5) + P(N+2*JT,3)=-0.5D0*P(ID,5) + P(N+2*JT,4)=0.5D0*P(ID,5) + CALL PYROBO(N+2*JT-1,N+2*JT,ACOS(CTHE(JT)),PHI(JT), + & P(ID,1)/P(ID,4),P(ID,2)/P(ID,4),P(ID,3)/P(ID,4)) + 470 CONTINUE + +C...Store incoming and outgoing momenta, with random rotation to +C...avoid accidental zeroes in HA expressions. + IF(ISUB.NE.0) THEN + DO 490 I=IMIN,IMAX + K(N+4+I,1)=1 + P(N+4+I,4)=SQRT(P(ILIN(I),1)**2+P(ILIN(I),2)**2+ + & P(ILIN(I),3)**2+P(ILIN(I),5)**2) + P(N+4+I,5)=P(ILIN(I),5) + DO 480 J=1,3 + P(N+4+I,J)=P(ILIN(I),J) + 480 CONTINUE + 490 CONTINUE + 500 THERR=ACOS(2D0*PYR(0)-1D0) + PHIRR=PARU(2)*PYR(0) + CALL PYROBO(N+4+IMIN,N+4+IMAX,THERR,PHIRR,0D0,0D0,0D0) + DO 520 I=IMIN,IMAX + IF(P(N+4+I,1)**2+P(N+4+I,2)**2.LT.1D-4*(P(N+4+I,1)**2+ + & P(N+4+I,2)**2+P(N+4+I,3)**2)) GOTO 500 + DO 510 J=1,4 + PK(I,J)=P(N+4+I,J) + 510 CONTINUE + 520 CONTINUE + ENDIF + +C...Calculate internal products. + IF(ISUB.EQ.22.OR.ISUB.EQ.23.OR.ISUB.EQ.25.OR.ISUB.EQ.141.OR. + & ISUB.EQ.142) THEN + DO 540 I1=IMIN,IMAX-1 + DO 530 I2=I1+1,IMAX + HA(I1,I2)=SNGL(SQRT((PK(I1,4)-PK(I1,3))*(PK(I2,4)+ + & PK(I2,3))/(1D-20+PK(I1,1)**2+PK(I1,2)**2)))* + & CMPLX(SNGL(PK(I1,1)),SNGL(PK(I1,2)))- + & SNGL(SQRT((PK(I1,4)+PK(I1,3))*(PK(I2,4)-PK(I2,3))/ + & (1D-20+PK(I2,1)**2+PK(I2,2)**2)))* + & CMPLX(SNGL(PK(I2,1)),SNGL(PK(I2,2))) + HC(I1,I2)=CONJG(HA(I1,I2)) + IF(I1.LE.2) HA(I1,I2)=CMPLX(0.,1.)*HA(I1,I2) + IF(I1.LE.2) HC(I1,I2)=CMPLX(0.,1.)*HC(I1,I2) + HA(I2,I1)=-HA(I1,I2) + HC(I2,I1)=-HC(I1,I2) + 530 CONTINUE + 540 CONTINUE + ENDIF + +C...Calculate four-products. + IF(ISUB.NE.0) THEN + DO 560 I=1,2 + DO 550 J=1,4 + PK(I,J)=-PK(I,J) + 550 CONTINUE + 560 CONTINUE + DO 580 I1=IMIN,IMAX-1 + DO 570 I2=I1+1,IMAX + PKK(I1,I2)=2D0*(PK(I1,4)*PK(I2,4)-PK(I1,1)*PK(I2,1)- + & PK(I1,2)*PK(I2,2)-PK(I1,3)*PK(I2,3)) + PKK(I2,I1)=PKK(I1,I2) + 570 CONTINUE + 580 CONTINUE + ENDIF + ENDIF + + KFAGM=IABS(IREF(IP,7)) + IF(MSTP(47).LE.0.OR.NINH.NE.0) THEN +C...Isotropic decay selected by user. + WT=1D0 + WTMAX=1D0 + + ELSEIF(JTMAX.EQ.3) THEN +C...Isotropic decay when three mother particles. + WT=1D0 + WTMAX=1D0 + + ELSEIF(IT4.GE.1) THEN +C... Isotropic decay t -> b + W etc for 4th generation q and l. + WT=1D0 + WTMAX=1D0 + + ELSEIF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR. + & IREF(IP,7).EQ.36) THEN +C...Angular weight for h0/A0 -> Z0 + Z0 or W+ + W- -> 4 quarks/leptons. +C...CP-odd case added by Kari Ertresvag Myklevoll. +C...Now also with mixed Higgs CP-states + ETA=PARP(25) + IF(IP.EQ.1) WTMAX=SH**2 + IF(IP.GE.2) WTMAX=P(IREF(IP,8),5)**4 + KFA=IABS(K(IREF(IP,1),2)) + KFT=IABS(K(IREF(IP,2),2)) + + IF((KFA.EQ.KFT).AND.(KFA.EQ.23.OR.KFA.EQ.24).AND. + & MSTP(25).GE.3) THEN +C...For mixed CP states need epsilon product. + P10=PK(3,4) + P20=PK(4,4) + P30=PK(5,4) + P40=PK(6,4) + P11=PK(3,1) + P21=PK(4,1) + P31=PK(5,1) + P41=PK(6,1) + P12=PK(3,2) + P22=PK(4,2) + P32=PK(5,2) + P42=PK(6,2) + P13=PK(3,3) + P23=PK(4,3) + P33=PK(5,3) + P43=PK(6,3) + EPSI=P10*P21*P32*P43-P10*P21*P33*P42-P10*P22*P31*P43+P10*P22* + & P33*P41+P10*P23*P31*P42-P10*P23*P32*P41-P11*P20*P32*P43+P11* + & P20*P33*P42+P11*P22*P30*P43-P11*P22*P33*P40-P11*P23*P30*P42+ + & P11*P23*P32*P40+P12*P20*P31*P43-P12*P20*P33*P41-P12*P21*P30* + & P43+P12*P21*P33*P40+P12*P23*P30*P41-P12*P23*P31*P40-P13*P20* + & P31*P42+P13*P20*P32*P41+P13*P21*P30*P42-P13*P21*P32*P40-P13* + & P22*P30*P41+P13*P22*P31*P40 +C...For mixed CP states need gauge boson masses. + XMA=SQRT(MAX(0D0,(PK(3,4)+PK(4,4))**2-(PK(3,1)+PK(4,1))**2- + & (PK(3,2)+PK(4,2))**2-(PK(3,3)+PK(4,3))**2)) + XMB=SQRT(MAX(0D0,(PK(5,4)+PK(6,4))**2-(PK(5,1)+PK(6,1))**2- + & (PK(5,2)+PK(6,2))**2-(PK(5,3)+PK(6,3))**2)) + XMV=PMAS(KFA,1) + ENDIF + +C...Z decay + IF(KFA.EQ.23.AND.KFA.EQ.KFT) THEN + KFLF1A=IABS(KFL1(1)) + EF1=KCHG(KFLF1A,1)/3D0 + AF1=SIGN(1D0,EF1+0.1D0) + VF1=AF1-4D0*EF1*XWV + KFLF2A=IABS(KFL1(2)) + EF2=KCHG(KFLF2A,1)/3D0 + AF2=SIGN(1D0,EF2+0.1D0) + VF2=AF2-4D0*EF2*XWV + VA12AS=4D0*VF1*AF1*VF2*AF2/((VF1**2+AF1**2)*(VF2**2+AF2**2)) + IF((MSTP(25).EQ.0.AND.IREF(IP,7).NE.36).OR.MSTP(25).EQ.1) + & THEN +C...CP-even decay + WT=8D0*(1D0+VA12AS)*PKK(3,5)*PKK(4,6)+ + & 8D0*(1D0-VA12AS)*PKK(3,6)*PKK(4,5) + ELSEIF(MSTP(25).LE.2) THEN +C...CP-odd decay + WT=((PKK(3,5)+PKK(4,6))**2 +(PKK(3,6)+PKK(4,5))**2 + & -2*PKK(3,4)*PKK(5,6) + & -2*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2/ + & (PKK(3,4)*PKK(5,6)) + & +VA12AS*(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))* + & (PKK(3,5)+PKK(4,5)-PKK(3,6)-PKK(4,6)))/(1+VA12AS) + ELSE +C...Mixed CP states. + WT=32D0*(0.25D0*((1D0+VA12AS)*PKK(3,5)*PKK(4,6) + & +(1D0-VA12AS)*PKK(3,6)*PKK(4,5)) + & -0.5D0*ETA/XMV**2*EPSI*((1D0+VA12AS)*(PKK(3,5)+PKK(4,6)) + & -(1D0-VA12AS)*(PKK(3,6)+PKK(4,5))) + & +6.25D-2*ETA**2/XMV**4*(-2D0*PKK(3,4)**2*PKK(5,6)**2 + & -2D0*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2 + & +PKK(3,4)*PKK(5,6) + & *((PKK(3,5)+PKK(4,6))**2+(PKK(3,6)+PKK(4,5))**2) + & +VA12AS*PKK(3,4)*PKK(5,6) + & *(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6)) + & *(PKK(3,5)-PKK(3,6)+PKK(4,5)-PKK(4,6)))) + & /(1D0 +2D0*ETA*XMA*XMB/XMV**2 + & +2D0*(ETA*XMA*XMB/XMV**2)**2*(1D0+VA12AS)) + ENDIF + +C...W decay + ELSEIF(KFA.EQ.24.AND.KFA.EQ.KFT) THEN + IF((MSTP(25).EQ.0.AND.IREF(IP,7).NE.36).OR.MSTP(25).EQ.1) + & THEN +C...CP-even decay + WT=16D0*PKK(3,5)*PKK(4,6) + ELSEIF(MSTP(25).LE.2) THEN +C...CP-odd decay + WT=0.5D0*((PKK(3,5)+PKK(4,6))**2 +(PKK(3,6)+PKK(4,5))**2 + & -2*PKK(3,4)*PKK(5,6) + & -2*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2/ + & (PKK(3,4)*PKK(5,6)) + & +(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))* + & (PKK(3,5)+PKK(4,5)-PKK(3,6)-PKK(4,6))) + ELSE +C...Mixed CP states. + WT=32D0*(0.25D0*2D0*PKK(3,5)*PKK(4,6) + & -0.5D0*ETA/XMV**2*EPSI*2D0*(PKK(3,5)+PKK(4,6)) + & +6.25D-2*ETA**2/XMV**4*(-2D0*PKK(3,4)**2*PKK(5,6)**2 + & -2D0*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2 + & +PKK(3,4)*PKK(5,6) + & *((PKK(3,5)+PKK(4,6))**2+(PKK(3,6)+PKK(4,5))**2) + & +PKK(3,4)*PKK(5,6) + & *(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6)) + & *(PKK(3,5)-PKK(3,6)+PKK(4,5)-PKK(4,6)))) + & /(1D0 +2D0*ETA*XMA*XMB/XMV**2 + & +(2D0*ETA*XMA*XMB/XMV**2)**2) + ENDIF + +C...No angular correlations in other Higgs decays. + ELSE + WT=WTMAX + ENDIF + + ELSEIF((KFAGM.EQ.6.OR.KFAGM.EQ.7.OR.KFAGM.EQ.8.OR. + & KFAGM.EQ.17.OR.KFAGM.EQ.18).AND.IABS(K(IREF(IP,1),2)).EQ.24) + & THEN +C...Angular correlation in f -> f' + W -> f' + 2 quarks/leptons. + I1=IREF(IP,8) + IF(MOD(KFAGM,2).EQ.0) THEN + I2=N+1 + I3=N+2 + ELSE + I2=N+2 + I3=N+1 + ENDIF + I4=IREF(IP,2) + WT=(P(I1,4)*P(I2,4)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)- + & P(I1,3)*P(I2,3))*(P(I3,4)*P(I4,4)-P(I3,1)*P(I4,1)- + & P(I3,2)*P(I4,2)-P(I3,3)*P(I4,3)) + WTMAX=(P(I1,5)**4-P(IREF(IP,1),5)**4)/8D0 + + ELSEIF(ISUB.EQ.1) THEN +C...Angular weight for gamma*/Z0 -> 2 quarks/leptons. + EI=KCHG(IABS(MINT(15)),1)/3D0 + AI=SIGN(1D0,EI+0.1D0) + VI=AI-4D0*EI*XWV + EF=KCHG(IABS(KFL1(1)),1)/3D0 + AF=SIGN(1D0,EF+0.1D0) + + VF=AF-4D0*EF*XWV + RMF=MIN(1D0,4D0*PMAS(IABS(KFL1(1)),1)**2/SH) + WT1=EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+ + & (VI**2+AI**2)*VINT(114)*(VF**2+(1D0-RMF)*AF**2) + WT2=RMF*(EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+ + & (VI**2+AI**2)*VINT(114)*VF**2) + WT3=SQRT(1D0-RMF)*(EI*AI*VINT(112)*EF*AF+ + & 4D0*VI*AI*VINT(114)*VF*AF) + WT=WT1*(1D0+CTHE(1)**2)+WT2*(1D0-CTHE(1)**2)+ + & 2D0*WT3*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)) + WTMAX=2D0*(WT1+ABS(WT3)) + + ELSEIF(ISUB.EQ.2) THEN +C...Angular weight for W+/- -> 2 quarks/leptons. + RM3=PMAS(IABS(KFL1(1)),1)**2/SH + RM4=PMAS(IABS(KFL2(1)),1)**2/SH + BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4)) + WT=(1D0+BE34*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2-(RM3-RM4)**2 + WTMAX=4D0 + + ELSEIF(ISUB.EQ.15.OR.ISUB.EQ.19) THEN +C...Angular weight for f + fbar -> gluon/gamma + (gamma*/Z0) -> +C...-> gluon/gamma + 2 quarks/leptons. + CLILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+ + & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+ + & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,3)**2 + CLIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+ + & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+ + & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,4)**2 + CRILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+ + & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+ + & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,3)**2 + CRIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+ + & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+ + & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,4)**2 + WT=(CLILF+CRIRF)*(PKK(1,3)**2+PKK(2,4)**2)+ + & (CLIRF+CRILF)*(PKK(1,4)**2+PKK(2,3)**2) + WTMAX=(CLILF+CLIRF+CRILF+CRIRF)* + & ((PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2) + + ELSEIF(ISUB.EQ.16.OR.ISUB.EQ.20) THEN +C...Angular weight for f + fbar' -> gluon/gamma + W+/- -> +C...-> gluon/gamma + 2 quarks/leptons. + WT=PKK(1,3)**2+PKK(2,4)**2 + WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2 + + ELSEIF(ISUB.EQ.22) THEN +C...Angular weight for f + fbar -> Z0 + Z0 -> 4 quarks/leptons. + S34=P(IREF(IP,IORD),5)**2 + S56=P(IREF(IP,3-IORD),5)**2 + TI=PKK(1,3)+PKK(1,4)+S34 + UI=PKK(1,5)+PKK(1,6)+S56 + TIR=REAL(TI) + UIR=REAL(UI) + FGK135=ABS(FGK(1,2,3,4,5,6)/TIR+FGK(1,2,5,6,3,4)/UIR)**2 + FGK145=ABS(FGK(1,2,4,3,5,6)/TIR+FGK(1,2,5,6,4,3)/UIR)**2 + FGK136=ABS(FGK(1,2,3,4,6,5)/TIR+FGK(1,2,6,5,3,4)/UIR)**2 + FGK146=ABS(FGK(1,2,4,3,6,5)/TIR+FGK(1,2,6,5,4,3)/UIR)**2 + FGK253=ABS(FGK(2,1,5,6,3,4)/TIR+FGK(2,1,3,4,5,6)/UIR)**2 + FGK263=ABS(FGK(2,1,6,5,3,4)/TIR+FGK(2,1,3,4,6,5)/UIR)**2 + FGK254=ABS(FGK(2,1,5,6,4,3)/TIR+FGK(2,1,4,3,5,6)/UIR)**2 + FGK264=ABS(FGK(2,1,6,5,4,3)/TIR+FGK(2,1,4,3,6,5)/UIR)**2 + + WT= + & CORL(1,1,1)*CORL(2,1,1)*FGK135+CORL(1,1,2)*CORL(2,1,1)*FGK145+ + & CORL(1,1,1)*CORL(2,1,2)*FGK136+CORL(1,1,2)*CORL(2,1,2)*FGK146+ + & CORL(1,2,1)*CORL(2,2,1)*FGK253+CORL(1,2,2)*CORL(2,2,1)*FGK263+ + & CORL(1,2,1)*CORL(2,2,2)*FGK254+CORL(1,2,2)*CORL(2,2,2)*FGK264 + WTMAX=16D0*((CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+ + & (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2)))*S34*S56* + & ((TI**2+UI**2+2D0*SH*(S34+S56))/(TI*UI)-S34*S56*(1D0/TI**2+ + & 1D0/UI**2)) + + ELSEIF(ISUB.EQ.23) THEN +C...Angular weight for f + fbar' -> Z0 + W+/- -> 4 quarks/leptons. + D34=P(IREF(IP,IORD),5)**2 + D56=P(IREF(IP,3-IORD),5)**2 + DT=PKK(1,3)+PKK(1,4)+D34 + DU=PKK(1,5)+PKK(1,6)+D56 + FACBW=1D0/((SH-SQMW)**2+GMMW**2) + CAWZ=COUP(2,3)/DT-2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW + CBWZ=COUP(1,3)/DU+2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW + FGK135=ABS(REAL(CAWZ)*FGK(1,2,3,4,5,6)+ + + & REAL(CBWZ)*FGK(1,2,5,6,3,4)) + FGK136=ABS(REAL(CAWZ)*FGK(1,2,3,4,6,5)+ + & REAL(CBWZ)*FGK(1,2,6,5,3,4)) + WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2 + WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*(CAWZ**2* + & DIGK(DT,DU)+CBWZ**2*DIGK(DU,DT)+CAWZ*CBWZ*DJGK(DT,DU)) + + ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN +C...Angular weight for f + fbar -> Z0 + h0 -> 2 quarks/leptons + h0 +C...(or H0, or A0). + WT=((COUP(1,3)*COUP(3,3))**2+(COUP(1,4)*COUP(3,4))**2)* + & PKK(1,3)*PKK(2,4)+((COUP(1,3)*COUP(3,4))**2+(COUP(1,4)* + & COUP(3,3))**2)*PKK(1,4)*PKK(2,3) + WTMAX=(COUP(1,3)**2+COUP(1,4)**2)*(COUP(3,3)**2+COUP(3,4)**2)* + & (PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4)) + + ELSEIF(ISUB.EQ.25) THEN +C...Angular weight for f + fbar -> W+ + W- -> 4 quarks/leptons. + POLR=(1D0+PARJ(132))*(1D0-PARJ(131)) + POLL=(1D0-PARJ(132))*(1D0+PARJ(131)) + D34=P(IREF(IP,IORD),5)**2 + D56=P(IREF(IP,3-IORD),5)**2 + DT=PKK(1,3)+PKK(1,4)+D34 + DU=PKK(1,5)+PKK(1,6)+D56 + FACBW=1D0/((SH-SQMZ)**2+SQMZ*PMAS(23,2)**2) + CDWW=(COUP(1,3)*SQMZ*(SH-SQMZ)*FACBW+COUP(1,2))/SH + CAWW=CDWW+0.5D0*(COUP(1,2)+1D0)/DT + CBWW=CDWW+0.5D0*(COUP(1,2)-1D0)/DU + CCWW=COUP(1,4)*SQMZ*(SH-SQMZ)*FACBW/SH + FGK135=ABS(REAL(CAWW)*FGK(1,2,3,4,5,6)- + & REAL(CBWW)*FGK(1,2,5,6,3,4)) + FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6)) + IF(MSTP(50).LE.0) THEN + WT=FGK135**2+(CCWW*FGK253)**2 + WTMAX=4D0*D34*D56*(CAWW**2*DIGK(DT,DU)+CBWW**2*DIGK(DU,DT)- + & CAWW*CBWW*DJGK(DT,DU)+CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)- + & DJGK(DT,DU))) + ELSE + WT=POLL*FGK135**2+POLR*(CCWW*FGK253)**2 + WTMAX=4D0*D34*D56*(POLL*(CAWW**2*DIGK(DT,DU)+ + & CBWW**2*DIGK(DU,DT)-CAWW*CBWW*DJGK(DT,DU))+ + & POLR*CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))) + ENDIF + + ELSEIF(ISUB.EQ.26.OR.ISUB.EQ.172.OR.ISUB.EQ.177) THEN +C...Angular weight for f + fbar' -> W+/- + h0 -> 2 quarks/leptons + h0 +C...(or H0, or A0). + WT=PKK(1,3)*PKK(2,4) + WTMAX=(PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4)) + + ELSEIF(ISUB.EQ.30.OR.ISUB.EQ.35) THEN +C...Angular weight for f + g/gamma -> f + (gamma*/Z0) +C...-> f + 2 quarks/leptons. + CLILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+ + & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+ + & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,3)**2 + CLIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+ + & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+ + & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,4)**2 + CRILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+ + & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+ + & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,3)**2 + CRIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+ + & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+ + & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,4)**2 + IF(K(ILIN(1),2).GT.0) WT=(CLILF+CRIRF)*(PKK(1,4)**2+ + & PKK(3,5)**2)+(CLIRF+CRILF)*(PKK(1,3)**2+PKK(4,5)**2) + IF(K(ILIN(1),2).LT.0) WT=(CLILF+CRIRF)*(PKK(1,3)**2+ + & PKK(4,5)**2)+(CLIRF+CRILF)*(PKK(1,4)**2+PKK(3,5)**2) + WTMAX=(CLILF+CLIRF+CRILF+CRIRF)* + & ((PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2) + + ELSEIF(ISUB.EQ.31.OR.ISUB.EQ.36) THEN +C...Angular weight for f + g/gamma -> f' + W+/- -> f' + 2 fermions. + IF(K(ILIN(1),2).GT.0) WT=PKK(1,4)**2+PKK(3,5)**2 + IF(K(ILIN(1),2).LT.0) WT=PKK(1,3)**2+PKK(4,5)**2 + WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2 + + ELSEIF(ISUB.EQ.71.OR.ISUB.EQ.72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR. + & ISUB.EQ.77) THEN +C...Angular weight for V_L1 + V_L2 -> V_L3 + V_L4 (V = Z/W). + WT=16D0*PKK(3,5)*PKK(4,6) + WTMAX=SH**2 + + ELSEIF(ISUB.EQ.110) THEN +C...Angular weight for f + fbar -> gamma + h0 -> gamma + X is isotropic. + WT=1D0 + WTMAX=1D0 + + ELSEIF(ISUB.EQ.141) THEN +C...Special case: if only branching ratios known then isotropic decay. + IF(MWID(32).EQ.2) THEN + WT=1D0 + WTMAX=1D0 + ELSEIF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN +C...Angular weight for f + fbar -> gamma*/Z0/Z'0 -> 2 quarks/leptons. +C...Couplings of incoming flavour. + KFAI=IABS(MINT(15)) + EI=KCHG(KFAI,1)/3D0 + AI=SIGN(1D0,EI+0.1D0) + VI=AI-4D0*EI*XWV + KFAIC=1 + IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2 + IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3 + IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4 + IF(KFAI.LE.2.OR.KFAI.EQ.11.OR.KFAI.EQ.12) THEN + VPI=PARU(119+2*KFAIC) + API=PARU(120+2*KFAIC) + ELSEIF(KFAI.LE.4.OR.KFAI.EQ.13.OR.KFAI.EQ.14) THEN + VPI=PARJ(178+2*KFAIC) + API=PARJ(179+2*KFAIC) + ELSE + VPI=PARJ(186+2*KFAIC) + API=PARJ(187+2*KFAIC) + ENDIF +C...Couplings of final flavour. + KFAF=IABS(KFL1(1)) + EF=KCHG(KFAF,1)/3D0 + AF=SIGN(1D0,EF+0.1D0) + VF=AF-4D0*EF*XWV + KFAFC=1 + IF(KFAF.LE.10.AND.MOD(KFAF,2).EQ.0) KFAFC=2 + IF(KFAF.GT.10.AND.MOD(KFAF,2).NE.0) KFAFC=3 + IF(KFAF.GT.10.AND.MOD(KFAF,2).EQ.0) KFAFC=4 + IF(KFAF.LE.2.OR.KFAF.EQ.11.OR.KFAF.EQ.12) THEN + VPF=PARU(119+2*KFAFC) + APF=PARU(120+2*KFAFC) + ELSEIF(KFAF.LE.4.OR.KFAF.EQ.13.OR.KFAF.EQ.14) THEN + VPF=PARJ(178+2*KFAFC) + APF=PARJ(179+2*KFAFC) + ELSE + VPF=PARJ(186+2*KFAFC) + APF=PARJ(187+2*KFAFC) + ENDIF +C...Asymmetry and weight. + ASYM=2D0*(EI*AI*VINT(112)*EF*AF+EI*API*VINT(113)*EF*APF+ + & 4D0*VI*AI*VINT(114)*VF*AF+(VI*API+VPI*AI)*VINT(115)* + & (VF*APF+VPF*AF)+4D0*VPI*API*VINT(116)*VPF*APF)/ + & (EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+ + & EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)* + & (VF**2+AF**2)+(VI*VPI+AI*API)*VINT(115)*(VF*VPF+AF*APF)+ + & (VPI**2+API**2)*VINT(116)*(VPF**2+APF**2)) + WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2 + WTMAX=2D0+ABS(ASYM) + ELSEIF(IP.EQ.1.AND.IABS(KFL1(1)).EQ.24) THEN +C...Angular weight for f + fbar -> Z' -> W+ + W-. + RM1=P(NSD(1)+1,5)**2/SH + RM2=P(NSD(1)+2,5)**2/SH + CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)* + & (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2) + CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+ + & (RM2-RM1)**2) + WT=CFLAT+CCOS2*CTHE(1)**2 + WTMAX=CFLAT+MAX(0D0,CCOS2) + ELSEIF(IP.EQ.1.AND.(KFL1(1).EQ.25.OR.KFL1(1).EQ.35.OR. + & IABS(KFL1(1)).EQ.37)) THEN +C...Angular weight for f + fbar -> Z' -> h0 + A0, H0 + A0, H+ + H-. + WT=1D0-CTHE(1)**2 + WTMAX=1D0 + ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN +C...Angular weight for f + fbar -> Z' -> Z0 + h0. + RM1=P(NSD(1)+1,5)**2/SH + RM2=P(NSD(1)+2,5)**2/SH + FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2) + WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1) + WTMAX=1D0+FLAM2/(8D0*RM1) + ELSEIF(MZPWP.EQ.0) THEN +C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons +C...(W:s like if intermediate Z). + D34=P(IREF(IP,IORD),5)**2 + D56=P(IREF(IP,3-IORD),5)**2 + DT=PKK(1,3)+PKK(1,4)+D34 + DU=PKK(1,5)+PKK(1,6)+D56 + FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4)) + FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6)) + WT=(COUP(1,3)*FGK135)**2+(COUP(1,4)*FGK253)**2 + WTMAX=4D0*D34*D56*(COUP(1,3)**2+COUP(1,4)**2)* + & (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU)) + ELSEIF(MZPWP.EQ.1) THEN +C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons +C...(W:s approximately longitudinal, like if intermediate H). + WT=16D0*PKK(3,5)*PKK(4,6) + WTMAX=SH**2 + ELSE +C...Angular weight for f + fbar -> Z' -> H+ + H-, Z0 + h0, h0 + A0, +C...H0 + A0 -> 4 quarks/leptons, t + tbar -> b + W+ + bbar + W- . + WT=1D0 + WTMAX=1D0 + ENDIF + + ELSEIF(ISUB.EQ.142) THEN +C...Special case: if only branching ratios known then isotropic decay. + IF(MWID(34).EQ.2) THEN + WT=1D0 + WTMAX=1D0 + ELSEIF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN +C...Angular weight for f + fbar' -> W'+/- -> 2 quarks/leptons. + KFAI=IABS(MINT(15)) + KFAIC=1 + IF(KFAI.GT.10) KFAIC=2 + VI=PARU(129+2*KFAIC) + AI=PARU(130+2*KFAIC) + KFAF=IABS(KFL1(1)) + KFAFC=1 + IF(KFAF.GT.10) KFAFC=2 + VF=PARU(129+2*KFAFC) + AF=PARU(130+2*KFAFC) + ASYM=8D0*VI*AI*VF*AF/((VI**2+AI**2)*(VF**2+AF**2)) + WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2 + WTMAX=2D0+ABS(ASYM) + ELSEIF(IP.EQ.1.AND.IABS(KFL2(1)).EQ.23) THEN +C...Angular weight for f + fbar' -> W'+/- -> W+/- + Z0. + RM1=P(NSD(1)+1,5)**2/SH + RM2=P(NSD(1)+2,5)**2/SH + CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)* + & (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2) + CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+ + & (RM2-RM1)**2) + WT=CFLAT+CCOS2*CTHE(1)**2 + WTMAX=CFLAT+MAX(0D0,CCOS2) + ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN +C...Angular weight for f + fbar -> W'+/- -> W+/- + h0. + RM1=P(NSD(1)+1,5)**2/SH + RM2=P(NSD(1)+2,5)**2/SH + FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2) + WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1) + WTMAX=1D0+FLAM2/(8D0*RM1) + ELSEIF(MZPWP.EQ.0) THEN +C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons +C...(W/Z like if intermediate W). + D34=P(IREF(IP,IORD),5)**2 + D56=P(IREF(IP,3-IORD),5)**2 + DT=PKK(1,3)+PKK(1,4)+D34 + DU=PKK(1,5)+PKK(1,6)+D56 + FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4)) + FGK136=ABS(FGK(1,2,3,4,6,5)-FGK(1,2,6,5,3,4)) + WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2 + WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)* + & (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU)) + ELSEIF(MZPWP.EQ.1) THEN +C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons +C...(W/Z approximately longitudinal, like if intermediate H). + WT=16D0*PKK(3,5)*PKK(4,6) + WTMAX=SH**2 + ELSE +C...Angular weight for f + fbar -> W' -> W + h0 -> whatever, +C...t + bbar -> t + W + bbar. + WT=1D0 + WTMAX=1D0 + ENDIF + + ELSEIF(ISUB.EQ.145.OR.ISUB.EQ.162.OR.ISUB.EQ.163.OR.ISUB.EQ.164) + & THEN +C...Isotropic decay of leptoquarks (assumed spin 0). + WT=1D0 + WTMAX=1D0 + + ELSEIF(ISUB.GE.146.AND.ISUB.LE.148) THEN +C...Decays of (spin 1/2) q*/e* -> q/e + (g,gamma) or (Z0,W+-). + SIDE=1D0 + IF(MINT(16).EQ.21.OR.MINT(16).EQ.22) SIDE=-1D0 + IF(IP.EQ.1.AND.(KFL1(1).EQ.21.OR.KFL1(1).EQ.22)) THEN + WT=1D0+SIDE*CTHE(1) + WTMAX=2D0 + ELSEIF(IP.EQ.1) THEN + + RM1=P(NSD(1)+1,5)**2/SH + WT=1D0+SIDE*CTHE(1)*(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1) + WTMAX=1D0+(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1) + ELSE +C...W/Z decay assumed isotropic, since not known. + WT=1D0 + WTMAX=1D0 + ENDIF + + ELSEIF(ISUB.EQ.149) THEN +C...Isotropic decay of techni-eta. + WT=1D0 + WTMAX=1D0 + + ELSEIF(ISUB.EQ.191) THEN + IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN +C...Angular weight for f + fbar -> rho_tc0 -> W+ W-, +C...W+ pi_tc-, pi_tc+ W- or pi_tc+ pi_tc-. + WT=1D0-CTHE(1)**2 + WTMAX=1D0 + ELSEIF(IP.EQ.1) THEN +C...Angular weight for f + fbar -> rho_tc0 -> f fbar. + CTHESG=CTHE(1)*ISIGN(1,MINT(15)) + XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW)) + BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2) + BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2) + KFAI=IABS(MINT(15)) + EI=KCHG(KFAI,1)/3D0 + AI=SIGN(1D0,EI+0.1D0) + VI=AI-4D0*EI*XWV + VALI=0.5D0*(VI+AI) + VARI=0.5D0*(VI-AI) + ALEFTI=(EI+VALI*BWZR)**2+(VALI*BWZI)**2 + ARIGHI=(EI+VARI*BWZR)**2+(VARI*BWZI)**2 + KFAF=IABS(KFL1(1)) + EF=KCHG(KFAF,1)/3D0 + AF=SIGN(1D0,EF+0.1D0) + VF=AF-4D0*EF*XWV + VALF=0.5D0*(VF+AF) + VARF=0.5D0*(VF-AF) + ALEFTF=(EF+VALF*BWZR)**2+(VALF*BWZI)**2 + ARIGHF=(EF+VARF*BWZR)**2+(VARF*BWZI)**2 + ASAME=ALEFTI*ALEFTF+ARIGHI*ARIGHF + AFLIP=ALEFTI*ARIGHF+ARIGHI*ALEFTF + WT=ASAME*(1D0+CTHESG)**2+AFLIP*(1D0-CTHESG)**2 + WTMAX=4D0*MAX(ASAME,AFLIP) + ELSE +C...Isotropic decay of W/pi_tc produced in rho_tc decay. + WT=1D0 + WTMAX=1D0 + ENDIF + + ELSEIF(ISUB.EQ.192) THEN + IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN +C...Angular weight for f + fbar' -> rho_tc+ -> W+ Z0, +C...W+ pi_tc0, pi_tc+ Z0 or pi_tc+ pi_tc0. + WT=1D0-CTHE(1)**2 + WTMAX=1D0 + ELSEIF(IP.EQ.1) THEN +C...Angular weight for f + fbar' -> rho_tc+ -> f fbar'. + CTHESG=CTHE(1)*ISIGN(1,MINT(15)) + WT=(1D0+CTHESG)**2 + WTMAX=4D0 + ELSE +C...Isotropic decay of W/Z/pi_tc produced in rho_tc+ decay. + WT=1D0 + WTMAX=1D0 + ENDIF + + ELSEIF(ISUB.EQ.193) THEN + IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN +C...Angular weight for f + fbar -> omega_tc0 -> +C...gamma pi_tc0 or Z0 pi_tc0. + WT=1D0+CTHE(1)**2 + WTMAX=2D0 + ELSEIF(IP.EQ.1) THEN +C...Angular weight for f + fbar -> omega_tc0 -> f fbar. + CTHESG=CTHE(1)*ISIGN(1,MINT(15)) + BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2) + BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2) + KFAI=IABS(MINT(15)) + EI=KCHG(KFAI,1)/3D0 + AI=SIGN(1D0,EI+0.1D0) + VI=AI-4D0*EI*XWV + VALI=0.5D0*(VI+AI) + VARI=0.5D0*(VI-AI) + BLEFTI=(EI-VALI*BWZR)**2+(VALI*BWZI)**2 + BRIGHI=(EI-VARI*BWZR)**2+(VARI*BWZI)**2 + KFAF=IABS(KFL1(1)) + EF=KCHG(KFAF,1)/3D0 + AF=SIGN(1D0,EF+0.1D0) + VF=AF-4D0*EF*XWV + VALF=0.5D0*(VF+AF) + VARF=0.5D0*(VF-AF) + BLEFTF=(EF-VALF*BWZR)**2+(VALF*BWZI)**2 + BRIGHF=(EF-VARF*BWZR)**2+(VARF*BWZI)**2 + BSAME=BLEFTI*BLEFTF+BRIGHI*BRIGHF + BFLIP=BLEFTI*BRIGHF+BRIGHI*BLEFTF + WT=BSAME*(1D0+CTHESG)**2+BFLIP*(1D0-CTHESG)**2 + WTMAX=4D0*MAX(BSAME,BFLIP) + ELSE +C...Isotropic decay of Z/pi_tc produced in omega_tc decay. + WT=1D0 + WTMAX=1D0 + ENDIF + + ELSEIF(ISUB.EQ.353) THEN +C...Angular weight for Z_R0 -> 2 quarks/leptons. + EI=KCHG(IABS(MINT(15)),1)/3D0 + AI=SIGN(1D0,EI+0.1D0) + VI=AI-4D0*EI*XWV + EF=KCHG(PYCOMP(KFL1(1)),1)/3D0 + AF=SIGN(1D0,EF+0.1D0) + VF=AF-4D0*EF*XWV + RMF=MIN(1D0,4D0*PMAS(PYCOMP(KFL1(1)),1)**2/SH) + WT1=(VI**2+AI**2)*(VF**2+(1D0-RMF)*AF**2) + WT2=RMF*(VI**2+AI**2)*VF**2 + WT3=SQRT(1D0-RMF)*4D0*VI*AI*VF*AF + WT=WT1*(1D0+CTHE(1)**2)+WT2*(1D0-CTHE(1)**2)+ + & 2D0*WT3*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)) + WTMAX=2D0*(WT1+ABS(WT3)) + + ELSEIF(ISUB.EQ.354) THEN +C...Angular weight for W_R+/- -> 2 quarks/leptons. + RM3=PMAS(PYCOMP(KFL1(1)),1)**2/SH + RM4=PMAS(PYCOMP(KFL2(1)),1)**2/SH + BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4)) + WT=(1D0+BE34*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2-(RM3-RM4)**2 + WTMAX=4D0 + + ELSEIF(ISUB.EQ.391) THEN +C...Angular weight for f + fbar -> G* -> f + fbar + IF(IP.EQ.1.AND.IABS(KFL1(1)).LE.18) THEN + WT=1D0-3D0*CTHE(1)**2+4D0*CTHE(1)**4 + WTMAX=2D0 +C...Angular weight for f + fbar -> G* -> gamma + gamma or g + g +C...implemented by M.-C. Lemaire + ELSEIF(IP.EQ.1.AND.(IABS(KFL1(1)).EQ.21.OR. + & IABS(KFL1(1)).EQ.22)) THEN + WT=1D0-CTHE(1)**4 + WTMAX=1D0 +C...Other G* decays not yet implemented angular distributions. + ELSE + WT=1D0 + WTMAX=1D0 + ENDIF + + ELSEIF(ISUB.EQ.392) THEN +C...Angular weight for g + g -> G* -> f + fbar + IF(IP.EQ.1.AND.IABS(KFL1(1)).LE.18) THEN + WT=1D0-CTHE(1)**4 + WTMAX=1D0 +C...Angular weight for g + g -> G* -> gamma +gamma or g + g +C...implemented by M.-C. Lemaire + ELSEIF(IP.EQ.1.AND.(IABS(KFL1(1)).EQ.21.OR. + & IABS(KFL1(1)).EQ.22)) THEN + WT=1D0+6D0*CTHE(1)**2+CTHE(1)**4 + WTMAX=8D0 +C...Other G* decays not yet implemented angular distributions. + ELSE + WT=1D0 + WTMAX=1D0 + ENDIF + +C...Obtain correct angular distribution by rejection techniques. + ELSE + WT=1D0 + WTMAX=1D0 + ENDIF + IF(WT.LT.PYR(0)*WTMAX) GOTO 430 + +C...Construct massive four-vectors using angles chosen. + 590 DO 690 JT=1,JTMAX + IF(KDCY(JT).EQ.0) GOTO 690 + ID=IREF(IP,JT) + DO 600 J=1,5 + DPMO(J)=P(ID,J) + 600 CONTINUE + DPMO(4)=SQRT(DPMO(1)**2+DPMO(2)**2+DPMO(3)**2+DPMO(5)**2) +CMRENNA++ + NPROD=2 + IF(KFL3(JT).NE.0) NPROD=3 + IF(KFL4(JT).NE.0) NPROD=4 + CALL PYROBO(NSD(JT)+1,NSD(JT)+NPROD,ACOS(CTHE(JT)),PHI(JT), + & DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4)) + N0=NSD(JT)+NPROD + + DO 610 J=1,4 + VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5) + 610 CONTINUE +C...Fill in position of decay vertex. + DO 630 I=NSD(JT)+1,N0 + DO 620 J=1,4 + V(I,J)=VDCY(J) + 620 CONTINUE + V(I,5)=0D0 + + 630 CONTINUE +CMRENNA-- + +C...Mark decayed resonances; trace history. + K(ID,1)=K(ID,1)+10 + KFA=IABS(K(ID,2)) + KCA=PYCOMP(KFA) + IF(KCQM(JT).NE.0) THEN +C...Do not kill colour flow through coloured resonance! + ELSE + K(ID,4)=NSD(JT)+1 + K(ID,5)=NSD(JT)+NPROD + IF(ITJUNC(JT).NE.0) K(ID,5)=K(ID,5)+1 +C...If 3-body or 2-body with junction: +c IF(KFL3(JT).NE.0.OR.ITJUNC(JT).NE.0) K(ID,5)=NSD(JT)+3 +C...If 3-body with junction: +c IF(ITJUNC(JT).NE.0.AND.KFL3(JT).NE.0) K(ID,5)=NSD(JT)+4 + ENDIF + +C...Add documentation lines. + ISUBRG=MAX(1,MIN(500,MINT(1))) + IF(IRES.EQ.0.OR.ISET(ISUBRG).EQ.11) THEN + IDOC=MINT(83)+MINT(4) +CMRENNA+++ + IHI=NSD(JT)+NPROD +c IF(KFL3(JT).NE.0) IHI=IHI+1 + DO 650 I=NSD(JT)+1,IHI +CMRENNA--- + I1=MINT(83)+MINT(4)+1 + K(I,3)=I1 + IF(MSTP(128).GE.1) K(I,3)=ID + IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN + MINT(4)=MINT(4)+1 + K(I1,1)=21 + K(I1,2)=K(I,2) + K(I1,3)=IREF(IP,JT+3) + DO 640 J=1,5 + P(I1,J)=P(I,J) + 640 CONTINUE + ENDIF + 650 CONTINUE + ELSE + K(NSD(JT)+1,3)=ID + K(NSD(JT)+2,3)=ID +C...If 3-body or 2-body with junction: + IF(KFL3(JT).NE.0.OR.ITJUNC(JT).GT.0) K(NSD(JT)+3,3)=ID +C...If 3-body with junction: + IF(KFL3(JT).NE.0.AND.ITJUNC(JT).GT.0) K(NSD(JT)+4,3)=ID +C...If 4-body or 3-body with junction: + IF(KFL4(JT).NE.0.OR.ITJUNC(JT).GT.0) K(NSD(JT)+4,3)=ID +C...If 4-body with junction: + IF(KFL4(JT).NE.0.AND.ITJUNC(JT).GT.0) K(NSD(JT)+5,3)=ID + ENDIF + +C...Do showering of two or three objects. + NSHBEF=N + IF(MSTP(71).GE.1.AND.MINT(35).LE.1) THEN + IF(KFL3(JT).EQ.0) THEN + CALL PYSHOW(NSD(JT)+1,NSD(JT)+2,P(ID,5)) + ELSE + CALL PYSHOW(NSD(JT)+1,-NPROD,P(ID,5)) + ENDIF + +c...For pT-ordered shower need set up first, especially colour tags. +C...(Need to set up colour tags even if MSTP(71) = 0) + ELSEIF(MINT(35).GE.2) THEN + NPART=NPROD +c IF(KFL3(JT).NE.0) NPART=3 + IPART(1)=NSD(JT)+1 + IPART(2)=NSD(JT)+2 + IPART(3)=NSD(JT)+3 + IPART(4)=NSD(JT)+4 + PTPART(1)=0.5D0*P(ID,5) + PTPART(2)=PTPART(1) + PTPART(3)=PTPART(1) + PTPART(4)=PTPART(1) + IF(KCQ1(JT).EQ.1.OR.KCQ1(JT).EQ.2) THEN + MOTHER=K(NSD(JT)+1,4)/MSTU(5) + IF(MOTHER.LE.NSD(JT)) THEN + MCT(NSD(JT)+1,1)=MCT(MOTHER,1) + ELSE + NCT=NCT+1 + MCT(NSD(JT)+1,1)=NCT + MCT(MOTHER,2)=NCT + ENDIF + ENDIF + IF(KCQ1(JT).EQ.-1.OR.KCQ1(JT).EQ.2) THEN + MOTHER=K(NSD(JT)+1,5)/MSTU(5) + IF(MOTHER.LE.NSD(JT)) THEN + MCT(NSD(JT)+1,2)=MCT(MOTHER,2) + ELSE + NCT=NCT+1 + MCT(NSD(JT)+1,2)=NCT + MCT(MOTHER,1)=NCT + ENDIF + ENDIF + IF(MCT(NSD(JT)+2,1).EQ.0.AND.(KCQ2(JT).EQ.1.OR. + & KCQ2(JT).EQ.2)) THEN + MOTHER=K(NSD(JT)+2,4)/MSTU(5) + IF(MOTHER.LE.NSD(JT)) THEN + MCT(NSD(JT)+2,1)=MCT(MOTHER,1) + ELSE + NCT=NCT+1 + MCT(NSD(JT)+2,1)=NCT + MCT(MOTHER,2)=NCT + ENDIF + ENDIF + IF(MCT(NSD(JT)+2,2).EQ.0.AND.(KCQ2(JT).EQ.-1.OR. + & KCQ2(JT).EQ.2)) THEN + MOTHER=K(NSD(JT)+2,5)/MSTU(5) + IF(MOTHER.LE.NSD(JT)) THEN + MCT(NSD(JT)+2,2)=MCT(MOTHER,2) + ELSE + NCT=NCT+1 + MCT(NSD(JT)+2,2)=NCT + MCT(MOTHER,1)=NCT + ENDIF + ENDIF + IF(NPART.EQ.3.AND.MCT(NSD(JT)+3,1).EQ.0.AND. + & (KCQ3(JT).EQ.1.OR. KCQ3(JT).EQ.2)) THEN + MOTHER=K(NSD(JT)+3,4)/MSTU(5) + MCT(NSD(JT)+3,1)=MCT(MOTHER,1) + ENDIF + IF(NPART.EQ.3.AND.MCT(NSD(JT)+3,2).EQ.0.AND. + & (KCQ3(JT).EQ.-1.OR.KCQ3(JT).EQ.2)) THEN + MOTHER=K(NSD(JT)+3,5)/MSTU(5) + MCT(NSD(JT)+2,2)=MCT(MOTHER,2) + ENDIF + IF(NPART.EQ.4.AND.MCT(NSD(JT)+4,1).EQ.0.AND. + & (KCQ4(JT).EQ.1.OR. KCQ4(JT).EQ.2)) THEN + MOTHER=K(NSD(JT)+4,4)/MSTU(5) + MCT(NSD(JT)+4,1)=MCT(MOTHER,1) + ENDIF + IF(NPART.EQ.4.AND.MCT(NSD(JT)+4,2).EQ.0.AND. + & (KCQ4(JT).EQ.-1.OR.KCQ4(JT).EQ.2)) THEN + MOTHER=K(NSD(JT)+4,5)/MSTU(5) + MCT(NSD(JT)+4,2)=MCT(MOTHER,2) + ENDIF + + IF (MSTP(71).GE.1) CALL PYPTFS(2,0.5D0*P(ID,5),0D0,PTGEN) + ENDIF + NSHAFT=N + IF(JT.EQ.1) NAFT1=N + +C...Check if decay products moved by shower. + NSD1=NSD(JT)+1 + NSD2=NSD(JT)+2 + NSD3=NSD(JT)+3 + NSD4=NSD(JT)+4 +C...4-body decays will only work if one of the products is "inert" + IF(NSHAFT.GT.NSHBEF) THEN + IF(K(NSD1,1).GT.10) THEN + DO 660 I=NSHBEF+1,NSHAFT + IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD1,2)) NSD1=I + 660 CONTINUE + ENDIF + IF(K(NSD2,1).GT.10) THEN + DO 670 I=NSHBEF+1,NSHAFT + IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD2,2).AND. + & I.NE.NSD1) NSD2=I + 670 CONTINUE + ENDIF + IF(KFL3(JT).NE.0.AND.K(NSD3,1).GT.10) THEN + DO 680 I=NSHBEF+1,NSHAFT + IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD3,2).AND. + & I.NE.NSD1.AND.I.NE.NSD2) NSD3=I + 680 CONTINUE + ENDIF + IF(KFL4(JT).NE.0.AND.K(NSD4,1).GT.10) THEN + DO 685 I=NSHBEF+1,NSHAFT + IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD4,2).AND. + & I.NE.NSD1.AND.I.NE.NSD2.AND.I.NE.NSD3) NSD4=I + 685 CONTINUE + ENDIF + ENDIF + +C...Store decay products for further treatment. + IF(KFL4(JT).EQ.0) THEN + NP=NP+1 + IREF(NP,1)=NSD1 + IREF(NP,2)=NSD2 + IREF(NP,3)=0 + IF(KFL3(JT).NE.0) IREF(NP,3)=NSD3 + IREF(NP,4)=IDOC+1 + IREF(NP,5)=IDOC+2 + IREF(NP,6)=0 + IF(KFL3(JT).NE.0) IREF(NP,6)=IDOC+3 + IREF(NP,7)=K(IREF(IP,JT),2) + IREF(NP,8)=IREF(IP,JT) + ELSE + NSDA=NSD1 + NSDB=NSD2 + NSDC=NSD3 + NP=NP+1 + IREF(NP,4)=IDOC+1 + IREF(NP,5)=IDOC+2 + IREF(NP,6)=IDOC+3 + IF(K(NSD1,1).EQ.1) THEN + NSDA=NSD4 + IREF(NP,4)=IDOC+4 + ELSEIF(K(NSD2,1).EQ.1) THEN + NSDB=NSD4 + IREF(NP,5)=IDOC+4 + ELSEIF(K(NSD3,1).EQ.1) THEN + NSDC=NSD4 + IREF(NP,6)=IDOC+4 + ENDIF + IREF(NP,1)=NSDA + IREF(NP,2)=NSDB + IREF(NP,3)=NSDC + IREF(NP,7)=K(IREF(IP,JT),2) + IREF(NP,8)=IREF(IP,JT) + ENDIF + 690 CONTINUE + + +C...Fill information for 2 -> 1 -> 2. + 700 IF(JTMAX.EQ.1.AND.KDCY(1).NE.0.AND.ISUB.NE.0) THEN + MINT(7)=MINT(83)+6+2*ISET(ISUB) + MINT(8)=MINT(83)+7+2*ISET(ISUB) + MINT(25)=KFL1(1) + MINT(26)=KFL2(1) + VINT(23)=CTHE(1) + RM3=P(N-1,5)**2/SH + RM4=P(N,5)**2/SH + BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4)) + VINT(45)=-0.5D0*SH*(1D0-RM3-RM4-BE34*CTHE(1)) + VINT(46)=-0.5D0*SH*(1D0-RM3-RM4+BE34*CTHE(1)) + VINT(48)=0.25D0*SH*BE34**2*MAX(0D0,1D0-CTHE(1)**2) + VINT(47)=SQRT(VINT(48)) + ENDIF + +C...Possibility of colour rearrangement in W+W- events. + IF((ISUB.EQ.25.OR.ISUB.EQ.22).AND.MSTP(115).GE.1) THEN + IAKF1=IABS(KFL1(1)) + IAKF2=IABS(KFL1(2)) + IAKF3=IABS(KFL2(1)) + IAKF4=IABS(KFL2(2)) + IF(MIN(IAKF1,IAKF2,IAKF3,IAKF4).GE.1.AND. + & MAX(IAKF1,IAKF2,IAKF3,IAKF4).LE.5) CALL + & PYRECO(IREF(1,1),IREF(1,2),NSD(1),NAFT1) + IF(MINT(51).NE.0) RETURN + ENDIF + +C...Loop back if needed. + 710 IF(IP.LT.NP) GOTO 170 + +C...Boost back to standard frame. + 720 IF(IBST.EQ.1) CALL PYROBO(MINT(83)+7,N,THEIN,PHIIN,BEXIN,BEYIN, + &BEZIN) + + + RETURN + END + +C********************************************************************* + +C...PYMULT +C...Initializes treatment of multiple interactions, selects kinematics +C...of hardest interaction if low-pT physics included in run, and +C...generates all non-hardest interactions. + + SUBROUTINE PYMULT(MMUL) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) + COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000) + COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) + COMMON/PYINT7/SIGT(0:6,0:6,0:5) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/, + &/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/ +C...Local arrays and saved variables. + DIMENSION NMUL(20),SIGM(20),KSTR(500,2),VINTSV(80) + SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM,P83A,P83B,P83C, + &CQ2I,CQ2R,PIK,BDIV,B,PLOWB,PHIGHB,PALLB,S4A,S4B,S4C,POWIP, + &RPWIP,B2RPDV,B2RPMX,BAVG,VNT145,VNT146,VNT147 + +C...Initialization of multiple interaction treatment. + IF(MMUL.EQ.1) THEN + IF(MSTP(122).GE.1) WRITE(MSTU(11),5000) MSTP(82) + ISUB=96 + MINT(1)=96 + VINT(63)=0D0 + VINT(64)=0D0 + VINT(143)=1D0 + VINT(144)=1D0 + +C...Loop over phase space points: xT2 choice in 20 bins. + 100 SIGSUM=0D0 + DO 120 IXT2=1,20 + NMUL(IXT2)=MSTP(83) + SIGM(IXT2)=0D0 + DO 110 ITRY=1,MSTP(83) + RSCA=0.05D0*((21-IXT2)-PYR(0)) + XT2=VINT(149)*(1D0+VINT(149))/(VINT(149)+RSCA)-VINT(149) + XT2=MAX(0.01D0*VINT(149),XT2) + VINT(25)=XT2 + +C...Choose tau and y*. Calculate cos(theta-hat). + IF(PYR(0).LE.COEF(ISUB,1)) THEN + TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0) + TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT) + ELSE + TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2) + ENDIF + VINT(21)=TAU + CALL PYKLIM(2) + RYST=PYR(0) + MYST=1 + IF(RYST.GT.COEF(ISUB,8)) MYST=2 + IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3 + CALL PYKMAP(2,MYST,PYR(0)) + VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0)) + +C...Calculate differential cross-section. + VINT(71)=0.5D0*VINT(1)*SQRT(XT2) + CALL PYSIGH(NCHN,SIGS) + SIGM(IXT2)=SIGM(IXT2)+SIGS + 110 CONTINUE + SIGSUM=SIGSUM+SIGM(IXT2) + 120 CONTINUE + SIGSUM=SIGSUM/(20D0*MSTP(83)) + +C...Reject result if sigma(parton-parton) is smaller than hadronic one. + IF(SIGSUM.LT.1.1D0*SIGT(0,0,5)) THEN + IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) + & PARP(82)*(VINT(1)/PARP(89))**PARP(90),SIGSUM + PARP(82)=0.9D0*PARP(82) + VINT(149)=4D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/ + & VINT(2) + GOTO 100 + ENDIF + IF(MSTP(122).GE.1) WRITE(MSTU(11),5200) + & PARP(82)*(VINT(1)/PARP(89))**PARP(90), SIGSUM + +C...Start iteration to find k factor. + YKE=SIGSUM/MAX(1D-10,SIGT(0,0,5)) + P83A=(1D0-PARP(83))**2 + P83B=2D0*PARP(83)*(1D0-PARP(83)) + P83C=PARP(83)**2 + CQ2I=1D0/PARP(84)**2 + CQ2R=2D0/(1D0+PARP(84)**2) + SO=0.5D0 + XI=0D0 + YI=0D0 + XF=0D0 + YF=0D0 + XK=0.5D0 + IIT=0 + 130 IF(IIT.EQ.0) THEN + XK=2D0*XK + ELSEIF(IIT.EQ.1) THEN + XK=0.5D0*XK + ELSE + XK=XI+(YKE-YI)*(XF-XI)/(YF-YI) + ENDIF + +C...Evaluate overlap integrals. Find where to divide the b range. + IF(MSTP(82).EQ.2) THEN + SP=0.5D0*PARU(1)*(1D0-EXP(-XK)) + SOP=SP/PARU(1) + ELSE + IF(MSTP(82).EQ.3) THEN + DELTAB=0.02D0 + ELSEIF(MSTP(82).EQ.4) THEN + DELTAB=MIN(0.01D0,0.05D0*PARP(84)) + ELSE + POWIP=MAX(0.4D0,PARP(83)) + RPWIP=2D0/POWIP-1D0 + DELTAB=MAX(0.02D0,0.02D0*(2D0/POWIP)**(1D0/POWIP)) + SO=0D0 + ENDIF + SP=0D0 + SOP=0D0 + BSP=0D0 + SOHIGH=0D0 + IBDIV=0 + B=-0.5D0*DELTAB + 140 B=B+DELTAB + IF(MSTP(82).EQ.3) THEN + OV=EXP(-B**2)/PARU(2) + ELSEIF(MSTP(82).EQ.4) THEN + OV=(P83A*EXP(-MIN(50D0,B**2))+ + & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+ + & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2) + ELSE + OV=EXP(-B**POWIP)/PARU(2) + SO=SO+PARU(2)*B*DELTAB*OV + ENDIF + IF(IBDIV.EQ.1) SOHIGH=SOHIGH+PARU(2)*B*DELTAB*OV + PACC=1D0-EXP(-MIN(50D0,PARU(1)*XK*OV)) + SP=SP+PARU(2)*B*DELTAB*PACC + SOP=SOP+PARU(2)*B*DELTAB*OV*PACC + BSP=BSP+B*PARU(2)*B*DELTAB*PACC + IF(IBDIV.EQ.0.AND.PARU(1)*XK*OV.LT.1D0) THEN + IBDIV=1 + BDIV=B+0.5D0*DELTAB + ENDIF + IF(B.LT.1D0.OR.B*PACC.GT.1D-6) GOTO 140 + ENDIF + YK=PARU(1)*XK*SO/SP + +C...Continue iteration until convergence. + IF(YK.LT.YKE) THEN + XI=XK + YI=YK + IF(IIT.EQ.1) IIT=2 + ELSE + XF=XK + YF=YK + IF(IIT.EQ.0) IIT=1 + ENDIF + IF(ABS(YK-YKE).GE.1D-5*YKE) GOTO 130 + +C...Store some results for subsequent use. + BAVG=BSP/SP + VINT(145)=SIGSUM + VINT(146)=SOP/SO + VINT(147)=SOP/SP + VNT145=VINT(145) + VNT146=VINT(146) + VNT147=VINT(147) +C...PIK = PARU(1)*XK = (VINT(146)/VINT(147))*sigma_jet/sigma_nondiffr. + PIK=(VNT146/VNT147)*YKE + +C...Find relative weight for low and high impact parameter. + PLOWB=PARU(1)*BDIV**2 + IF(MSTP(82).EQ.3) THEN + PHIGHB=PIK*0.5*EXP(-BDIV**2) + ELSEIF(MSTP(82).EQ.4) THEN + S4A=P83A*EXP(-BDIV**2) + S4B=P83B*EXP(-BDIV**2*CQ2R) + S4C=P83C*EXP(-BDIV**2*CQ2I) + PHIGHB=PIK*0.5*(S4A+S4B+S4C) + ELSEIF(PARP(83).GE.1.999D0) THEN + PHIGHB=PIK*SOHIGH + B2RPDV=BDIV**POWIP + ELSE + PHIGHB=PIK*SOHIGH + B2RPDV=BDIV**POWIP + B2RPMX=MAX(2D0*RPWIP,B2RPDV) + ENDIF + PALLB=PLOWB+PHIGHB + +C...Initialize iteration in xT2 for hardest interaction. + ELSEIF(MMUL.EQ.2) THEN + VINT(145)=VNT145 + VINT(146)=VNT146 + VINT(147)=VNT147 + IF(MSTP(82).LE.0) THEN + ELSEIF(MSTP(82).EQ.1) THEN + XT2=1D0 + SIGRAT=XSEC(96,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5)) + IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT* + & VINT(317)/(VINT(318)*VINT(320)) + XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149)) + ELSEIF(MSTP(82).EQ.2) THEN + XT2=1D0 + XT2FAC=VNT146*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))* + & VINT(149)*(1D0+VINT(149)) + ELSE + XC2=4D0*CKIN(3)**2/VINT(2) + IF(CKIN(3).LE.CKIN(5).OR.MINT(82).GE.2) XC2=0D0 + ENDIF + +C...Select impact parameter for hardest interaction. + IF(MSTP(82).LE.2) RETURN + 142 IF(PYR(0)*PALLB.LT.PLOWB) THEN +C...Treatment in low b region. + MINT(39)=1 + B=BDIV*SQRT(PYR(0)) + IF(MSTP(82).EQ.3) THEN + OV=EXP(-B**2)/PARU(2) + ELSEIF(MSTP(82).EQ.4) THEN + OV=(P83A*EXP(-MIN(50D0,B**2))+ + & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+ + & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2) + ELSE + OV=EXP(-B**POWIP)/PARU(2) + ENDIF + VINT(148)=OV/VNT147 + PACC=1D0-EXP(-MIN(50D0,PIK*OV)) + XT2=1D0 + XT2FAC=VNT146*VINT(148)*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))* + & VINT(149)*(1D0+VINT(149)) + ELSE +C...Treatment in high b region. + MINT(39)=2 + IF(MSTP(82).EQ.3) THEN + B=SQRT(BDIV**2-LOG(PYR(0))) + OV=EXP(-B**2)/PARU(2) + ELSEIF(MSTP(82).EQ.4) THEN + S4RNDM=PYR(0)*(S4A+S4B+S4C) + IF(S4RNDM.LT.S4A) THEN + B=SQRT(BDIV**2-LOG(PYR(0))) + ELSEIF(S4RNDM.LT.S4A+S4B) THEN + B=SQRT(BDIV**2-LOG(PYR(0))/CQ2R) + ELSE + B=SQRT(BDIV**2-LOG(PYR(0))/CQ2I) + ENDIF + OV=(P83A*EXP(-MIN(50D0,B**2))+ + & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+ + & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2) + ELSEIF(PARP(83).GE.1.999D0) THEN + 144 B2RPW=B2RPDV-LOG(PYR(0)) + ACCIP=(B2RPW/B2RPDV)**RPWIP + IF(ACCIP.LT.PYR(0)) GOTO 144 + OV=EXP(-B2RPW)/PARU(2) + B=B2RPW**(1D0/POWIP) + ELSE + 146 B2RPW=B2RPDV-2D0*LOG(PYR(0)) + ACCIP=(B2RPW/B2RPMX)**RPWIP*EXP(-0.5D0*(B2RPW-B2RPMX)) + IF(ACCIP.LT.PYR(0)) GOTO 146 + OV=EXP(-B2RPW)/PARU(2) + B=B2RPW**(1D0/POWIP) + ENDIF + VINT(148)=OV/VNT147 + PACC=(1D0-EXP(-MIN(50D0,PIK*OV)))/(PIK*OV) + ENDIF + IF(PACC.LT.PYR(0)) GOTO 142 + VINT(139)=B/BAVG + + ELSEIF(MMUL.EQ.3) THEN +C...Low-pT or multiple interactions (first semihard interaction): +C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm) +C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....). + ISUB=MINT(1) + VINT(145)=VNT145 + VINT(146)=VNT146 + VINT(147)=VNT147 + IF(MSTP(82).LE.0) THEN + XT2=0D0 + ELSEIF(MSTP(82).EQ.1) THEN + XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0))) +C...Use with "Sudakov" for low b values when impact parameter dependence. + ELSEIF(MSTP(82).EQ.2.OR.MINT(39).EQ.1) THEN + IF(XT2.LT.1D0.AND.EXP(-XT2FAC*XT2/(VINT(149)*(XT2+ + & VINT(149)))).GT.PYR(0)) XT2=1D0 + IF(XT2.GE.1D0) THEN + XT2=(1D0+VINT(149))*XT2FAC/(XT2FAC-(1D0+VINT(149))*LOG(1D0- + & PYR(0)*(1D0-EXP(-XT2FAC/(VINT(149)*(1D0+VINT(149)))))))- + & VINT(149) + ELSE + XT2=-XT2FAC/LOG(EXP(-XT2FAC/(XT2+VINT(149)))+PYR(0)* + & (EXP(-XT2FAC/VINT(149))-EXP(-XT2FAC/(XT2+VINT(149)))))- + & VINT(149) + ENDIF + XT2=MAX(0.01D0*VINT(149),XT2) +C...Use without "Sudakov" for high b values when impact parameter dep. + ELSE + XT2=(XC2+VINT(149))*(1D0+VINT(149))/(1D0+VINT(149)- + & PYR(0)*(1D0-XC2))-VINT(149) + XT2=MAX(0.01D0*VINT(149),XT2) + ENDIF + VINT(25)=XT2 + +C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed. + IF(MSTP(82).LE.1.AND.XT2.LT.VINT(149)) THEN + IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)-MINT(143) + IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)-MINT(143) + ISUB=95 + MINT(1)=ISUB + VINT(21)=0.01D0*VINT(149) + VINT(22)=0D0 + VINT(23)=0D0 + VINT(25)=0.01D0*VINT(149) + + ELSE +C...Multiple interactions (first semihard interaction). +C...Choose tau and y*. Calculate cos(theta-hat). + IF(PYR(0).LE.COEF(ISUB,1)) THEN + TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0) + TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT) + ELSE + TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2) + ENDIF + VINT(21)=TAU + CALL PYKLIM(2) + RYST=PYR(0) + MYST=1 + IF(RYST.GT.COEF(ISUB,8)) MYST=2 + IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3 + CALL PYKMAP(2,MYST,PYR(0)) + VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0)) + ENDIF + VINT(71)=0.5D0*VINT(1)*SQRT(VINT(25)) + +C...Store results of cross-section calculation. + ELSEIF(MMUL.EQ.4) THEN + ISUB=MINT(1) + VINT(145)=VNT145 + VINT(146)=VNT146 + VINT(147)=VNT147 + XTS=VINT(25) + IF(ISET(ISUB).EQ.1) XTS=VINT(21) + IF(ISET(ISUB).EQ.2) + & XTS=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2) + IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) XTS=VINT(26) + RBIN=MAX(0.000001D0,MIN(0.999999D0,XTS*(1D0+VINT(149))/ + & (XTS+VINT(149)))) + IRBIN=INT(1D0+20D0*RBIN) + IF(ISUB.EQ.96.AND.MSTP(171).EQ.0) THEN + NMUL(IRBIN)=NMUL(IRBIN)+1 + SIGM(IRBIN)=SIGM(IRBIN)+VINT(153) + ENDIF + +C...Choose impact parameter if not already done. + ELSEIF(MMUL.EQ.5) THEN + ISUB=MINT(1) + VINT(145)=VNT145 + VINT(146)=VNT146 + VINT(147)=VNT147 + 150 IF(MINT(39).GT.0) THEN + ELSEIF(MSTP(82).EQ.3) THEN + EXPB2=PYR(0) + B2=-LOG(PYR(0)) + VINT(148)=EXPB2/(PARU(2)*VNT147) + VINT(139)=SQRT(B2)/BAVG + ELSEIF(MSTP(82).EQ.4) THEN + RTYPE=PYR(0) + IF(RTYPE.LT.P83A) THEN + B2=-LOG(PYR(0)) + ELSEIF(RTYPE.LT.P83A+P83B) THEN + B2=-LOG(PYR(0))/CQ2R + ELSE + B2=-LOG(PYR(0))/CQ2I + ENDIF + VINT(148)=(P83A*EXP(-MIN(50D0,B2))+ + & P83B*CQ2R*EXP(-MIN(50D0,B2*CQ2R))+ + & P83C*CQ2I*EXP(-MIN(50D0,B2*CQ2I)))/(PARU(2)*VNT147) + VINT(139)=SQRT(B2)/BAVG + ELSEIF(PARP(83).GE.1.999D0) THEN + POWIP=MAX(2D0,PARP(83)) + RPWIP=2D0/POWIP-1D0 + PROB1=POWIP/(2D0*EXP(-1D0)+POWIP) + 160 IF(PYR(0).LT.PROB1) THEN + B2RPW=PYR(0)**(0.5D0*POWIP) + ACCIP=EXP(-B2RPW) + ELSE + B2RPW=1D0-LOG(PYR(0)) + ACCIP=B2RPW**RPWIP + ENDIF + IF(ACCIP.LT.PYR(0)) GOTO 160 + VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147) + VINT(139)=B2RPW**(1D0/POWIP)/BAVG + ELSE + POWIP=MAX(0.4D0,PARP(83)) + RPWIP=2D0/POWIP-1D0 + PROB1=RPWIP/(RPWIP+2D0**RPWIP*EXP(-RPWIP)) + 170 IF(PYR(0).LT.PROB1) THEN + B2RPW=2D0*RPWIP*PYR(0) + ACCIP=(B2RPW/RPWIP)**RPWIP*EXP(RPWIP-B2RPW) + ELSE + B2RPW=2D0*(RPWIP-LOG(PYR(0))) + ACCIP=(0.5D0*B2RPW/RPWIP)**RPWIP*EXP(RPWIP-0.5D0*B2RPW) + ENDIF + IF(ACCIP.LT .PYR(0)) GOTO 170 + VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147) + VINT(139)=B2RPW**(1D0/POWIP)/BAVG + ENDIF + +C...Multiple interactions (variable impact parameter) : reject with +C...probability exp(-overlap*cross-section above pT/normalization). +C...Does not apply to low-b region, where "Sudakov" already included. + VINT(150)=1D0 + IF(MINT(39).NE.1) THEN + RNCOR=(IRBIN-20D0*RBIN)*NMUL(IRBIN) + SIGCOR=(IRBIN-20D0*RBIN)*SIGM(IRBIN) + DO 180 IBIN=IRBIN+1,20 + RNCOR=RNCOR+NMUL(IBIN) + SIGCOR=SIGCOR+SIGM(IBIN) + 180 CONTINUE + SIGABV=(SIGCOR/RNCOR)*VINT(149)*(1D0-XTS)/(XTS+VINT(149)) + IF(MSTP(171).EQ.1) SIGABV=SIGABV*VINT(2)/VINT(289) + VINT(150)=EXP(-MIN(50D0,VNT146*VINT(148)* + & SIGABV/MAX(1D-10,SIGT(0,0,5)))) + ENDIF + IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUB.NE.11.AND. + & ISUB.NE.12.AND.ISUB.NE.13.AND.ISUB.NE.28.AND.ISUB.NE.53 + & .AND.ISUB.NE.68.AND.ISUB.NE.95.AND.ISUB.NE.96)) THEN + IF(VINT(150).LT.PYR(0)) GOTO 150 + VINT(150)=1D0 + ENDIF + +C...Generate additional multiple semihard interactions. + ELSEIF(MMUL.EQ.6) THEN + ISUBSV=MINT(1) + VINT(145)=VNT145 + VINT(146)=VNT146 + VINT(147)=VNT147 + DO 190 J=11,80 + VINTSV(J)=VINT(J) + 190 CONTINUE + ISUB=96 + MINT(1)=96 + VINT(151)=0D0 + VINT(152)=0D0 + +C...Reconstruct strings in hard scattering. + NMAX=MINT(84)+4 + IF(ISET(ISUBSV).EQ.1) NMAX=MINT(84)+2 + IF(ISET(ISUBSV).EQ.11) NMAX=MINT(84)+2+MINT(3) + NSTR=0 + DO 210 I=MINT(84)+1,NMAX + KCS=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2)) + IF(KCS.EQ.0) GOTO 210 + DO 200 J=1,4 + IF(KCS.EQ.1.AND.(J.EQ.2.OR.J.EQ.4)) GOTO 200 + IF(KCS.EQ.-1.AND.(J.EQ.1.OR.J.EQ.3)) GOTO 200 + IF(J.LE.2) THEN + IST=MOD(K(I,J+3)/MSTU(5),MSTU(5)) + ELSE + IST=MOD(K(I,J+1),MSTU(5)) + ENDIF + IF(IST.LT.MINT(84).OR.IST.GT.I) GOTO 200 + IF(KCHG(PYCOMP(K(IST,2)),2).EQ.0) GOTO 200 + NSTR=NSTR+1 + IF(J.EQ.1.OR.J.EQ.4) THEN + KSTR(NSTR,1)=I + KSTR(NSTR,2)=IST + ELSE + KSTR(NSTR,1)=IST + KSTR(NSTR,2)=I + ENDIF + 200 CONTINUE + 210 CONTINUE + +C...Set up starting values for iteration in xT2. + XT2=4D0*VINT(62)/VINT(2) + IF(MSTP(82).LE.1) THEN + SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5)) + IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT* + & VINT(317)/(VINT(318)*VINT(320)) + XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149)) + ELSE + XT2FAC=VNT146*VINT(148)*XSEC(ISUB,1)/ + & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149)) + ENDIF + VINT(63)=0D0 + VINT(64)=0D0 + VINT(143)=1D0-VINT(141) + VINT(144)=1D0-VINT(142) + +C...Iterate downwards in xT2. + 220 IF(MSTP(82).LE.1) THEN + XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0))) + IF(XT2.LT.VINT(149)) GOTO 270 + ELSE + IF(XT2.LE.0.01001D0*VINT(149)) GOTO 270 + XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))* + & LOG(PYR(0)))-VINT(149) + IF(XT2.LE.0D0) GOTO 270 + XT2=MAX(0.01D0*VINT(149),XT2) + ENDIF + VINT(25)=XT2 + +C...Choose tau and y*. Calculate cos(theta-hat). + IF(PYR(0).LE.COEF(ISUB,1)) THEN + TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0) + TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT) + ELSE + TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2) + ENDIF + VINT(21)=TAU + CALL PYKLIM(2) + RYST=PYR(0) + MYST=1 + IF(RYST.GT.COEF(ISUB,8)) MYST=2 + IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3 + CALL PYKMAP(2,MYST,PYR(0)) + VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0)) + +C...Check that x not used up. Accept or reject kinematical variables. + X1M=SQRT(TAU)*EXP(VINT(22)) + X2M=SQRT(TAU)*EXP(-VINT(22)) + IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 220 + VINT(71)=0.5D0*VINT(1)*SQRT(XT2) + CALL PYSIGH(NCHN,SIGS) + IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320) + IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 220 + +C...Reset K, P and V vectors. Select some variables. + DO 240 I=N+1,N+2 + DO 230 J=1,5 + K(I,J)=0 + P(I,J)=0D0 + V(I,J)=0D0 + 230 CONTINUE + 240 CONTINUE + RFLAV=PYR(0) + PT=0.5D0*VINT(1)*SQRT(XT2) + PHI=PARU(2)*PYR(0) + CTH=VINT(23) + +C...Add first parton to event record. + K(N+1,1)=3 + K(N+1,2)=21 + IF(RFLAV.GE.MAX(PARP(85),PARP(86))) K(N+1,2)= + & 1+INT((2D0+PARJ(2))*PYR(0)) + P(N+1,1)=PT*COS(PHI) + P(N+1,2)=PT*SIN(PHI) + P(N+1,3)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)-VINT(42)*(1D0-CTH)) + P(N+1,4)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)+VINT(42)*(1D0-CTH)) + P(N+1,5)=0D0 + +C...Add second parton to event record. + K(N+2,1)=3 + K(N+2,2)=21 + IF(K(N+1,2).NE.21) K(N+2,2)=-K(N+1,2) + P(N+2,1)=-P(N+1,1) + P(N+2,2)=-P(N+1,2) + P(N+2,3)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)-VINT(42)*(1D0+CTH)) + P(N+2,4)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)+VINT(42)*(1D0+CTH)) + P(N+2,5)=0D0 + + IF(RFLAV.LT.PARP(85).AND.NSTR.GE.1) THEN +C....Choose relevant string pieces to place gluons on. + DO 260 I=N+1,N+2 + DMIN=1D8 + DO 250 ISTR=1,NSTR + I1=KSTR(ISTR,1) + I2=KSTR(ISTR,2) + DIST=(P(I,4)*P(I1,4)-P(I,1)*P(I1,1)-P(I,2)*P(I1,2)- + & P(I,3)*P(I1,3))*(P(I,4)*P(I2,4)-P(I,1)*P(I2,1)- + & P(I,2)*P(I2,2)-P(I,3)*P(I2,3))/MAX(1D0,P(I1,4)*P(I2,4)- + & P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-P(I1,3)*P(I2,3)) + IF(ISTR.EQ.1.OR.DIST.LT.DMIN) THEN + DMIN=DIST + IST1=I1 + IST2=I2 + ISTM=ISTR + ENDIF + 250 CONTINUE + +C....Colour flow adjustments, new string pieces. + IF(K(IST1,4)/MSTU(5).EQ.IST2) K(IST1,4)=MSTU(5)*I+ + & MOD(K(IST1,4),MSTU(5)) + IF(MOD(K(IST1,5),MSTU(5)).EQ.IST2) K(IST1,5)= + & MSTU(5)*(K(IST1,5)/MSTU(5))+I + K(I,5)=MSTU(5)*IST1 + K(I,4)=MSTU(5)*IST2 + IF(K(IST2,5)/MSTU(5).EQ.IST1) K(IST2,5)=MSTU(5)*I+ + & MOD(K(IST2,5),MSTU(5)) + IF(MOD(K(IST2,4),MSTU(5)).EQ.IST1) K(IST2,4)= + & MSTU(5)*(K(IST2,4)/MSTU(5))+I + KSTR(ISTM,2)=I + KSTR(NSTR+1,1)=I + KSTR(NSTR+1,2)=IST2 + NSTR=NSTR+1 + 260 CONTINUE + +C...String drawing and colour flow for gluon loop. + ELSEIF(K(N+1,2).EQ.21) THEN + K(N+1,4)=MSTU(5)*(N+2) + K(N+1,5)=MSTU(5)*(N+2) + K(N+2,4)=MSTU(5)*(N+1) + K(N+2,5)=MSTU(5)*(N+1) + KSTR(NSTR+1,1)=N+1 + KSTR(NSTR+1,2)=N+2 + KSTR(NSTR+2,1)=N+2 + KSTR(NSTR+2,2)=N+1 + NSTR=NSTR+2 + +C...String drawing and colour flow for qqbar pair. + ELSE + K(N+1,4)=MSTU(5)*(N+2) + K(N+2,5)=MSTU(5)*(N+1) + KSTR(NSTR+1,1)=N+1 + KSTR(NSTR+1,2)=N+2 + NSTR=NSTR+1 + ENDIF + +C...Global statistics. + MINT(351)=MINT(351)+1 + VINT(351)=VINT(351)+PT + IF (MINT(351).EQ.1) VINT(356)=PT + +C...Update remaining energy; iterate. + N=N+2 + IF(N.GT.MSTU(4)-MSTU(32)-10) THEN + CALL PYERRM(11,'(PYMULT:) no more memory left in PYJETS') + MINT(51)=1 + RETURN + ENDIF + MINT(31)=MINT(31)+1 + VINT(151)=VINT(151)+VINT(41) + VINT(152)=VINT(152)+VINT(42) + VINT(143)=VINT(143)-VINT(41) + VINT(144)=VINT(144)-VINT(42) +C...Allow FSR for UE (always handle with old showers) + IF(MSTP(152).EQ.1) THEN + M41SAV=MSTJ(41) + IF (MSTJ(41).EQ.10) MSTJ(41)=2 + MSTJ(41)=MOD(MSTJ(41),10) + CALL PYSHOW(N-1,N,SQRT(PARP(71))*PT) + MSTJ(41)=M41SAV + ENDIF + IF(MINT(31).LT.240) GOTO 220 + 270 CONTINUE + MINT(1)=ISUBSV + DO 280 J=11,80 + VINT(J)=VINTSV(J) + 280 CONTINUE + ENDIF + +C...Format statements for printout. + 5000 FORMAT(/1X,'****** PYMULT: initialization of multiple inter', + &'actions for MSTP(82) =',I2,' ******') + 5100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P, + &D9.2,' mb: rejected') + 5200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P, + &D9.2,' mb: accepted') + + RETURN + END + +C********************************************************************* + +C...PYREMN +C...Adds on target remnants (one or two from each side) and +C...includes primordial kT for hadron beams. + + SUBROUTINE PYREMN(IPU1,IPU2) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/ +C...Local arrays. + DIMENSION KFLCH(2),KFLSP(2),CHI(2),PMS(0:6),IS(2),ISN(2),ROBO(5), + &PSYS(0:2,5),PMIN(0:2),QOLD(4),QNEW(4),DBE(3),PSUM(4) + +C...Find event type and remaining energy. + ISUB=MINT(1) + NS=N + IF(MINT(50).EQ.0.OR.MOD(MSTP(81),10).LE.0) THEN + VINT(143)=1D0-VINT(141) + VINT(144)=1D0-VINT(142) + ENDIF + +C...Define initial partons. + NTRY=0 + 100 NTRY=NTRY+1 + DO 130 JT=1,2 + I=MINT(83)+JT+2 + IF(JT.EQ.1) IPU=IPU1 + IF(JT.EQ.2) IPU=IPU2 + K(I,1)=21 + K(I,2)=K(IPU,2) + K(I,3)=I-2 + PMS(JT)=0D0 + VINT(156+JT)=0D0 + VINT(158+JT)=0D0 + IF(MINT(47).EQ.1) THEN + DO 110 J=1,5 + P(I,J)=P(I-2,J) + 110 CONTINUE + ELSEIF(ISUB.EQ.95) THEN + K(I,2)=21 + ELSE + P(I,5)=P(IPU,5) + +C...No primordial kT, or chosen according to truncated Gaussian or +C...exponential, or (for photon) predetermined or power law. + 120 IF(MINT(40+JT).EQ.2.AND.MINT(10+JT).NE.22) THEN + IF(MSTP(91).LE.0) THEN + PT=0D0 + ELSEIF(MSTP(91).EQ.1) THEN + PT=PARP(91)*SQRT(-LOG(PYR(0))) + ELSE + RPT1=PYR(0) + RPT2=PYR(0) + PT=-PARP(92)*LOG(RPT1*RPT2) + ENDIF + IF(PT.GT.PARP(93)) GOTO 120 + ELSEIF(MINT(106+JT).EQ.3) THEN + PTA=SQRT(VINT(282+JT)) + PTB=0D0 + IF(MSTP(66).EQ.5.AND.MSTP(93).EQ.1) THEN + PTB=PARP(99)*SQRT(-LOG(PYR(0))) + ELSEIF(MSTP(66).EQ.5.AND.MSTP(93).EQ.2) THEN + RPT1=PYR(0) + RPT2=PYR(0) + PTB=-PARP(99)*LOG(RPT1*RPT2) + ENDIF + IF(PTB.GT.PARP(100)) GOTO 120 + PT=SQRT(PTA**2+PTB**2+2D0*PTA*PTB*COS(PARU(2)*PYR(0))) + PT=PT*0.8D0**MINT(57) + IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10) + ELSEIF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) THEN + IF(MSTP(93).LE.0) THEN + PT=0D0 + ELSEIF(MSTP(93).EQ.1) THEN + PT=PARP(99)*SQRT(-LOG(PYR(0))) + ELSEIF(MSTP(93).EQ.2) THEN + RPT1=PYR(0) + RPT2=PYR(0) + PT=-PARP(99)*LOG(RPT1*RPT2) + ELSEIF(MSTP(93).EQ.3) THEN + HA=PARP(99)**2 + HB=PARP(100)**2 + PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA)) + ELSE + HA=PARP(99)**2 + HB=PARP(100)**2 + IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2) + PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA)) + ENDIF + IF(PT.GT.PARP(100)) GOTO 120 + ELSE + PT=0D0 + ENDIF + VINT(156+JT)=PT + PHI=PARU(2)*PYR(0) + P(I,1)=PT*COS(PHI) + P(I,2)=PT*SIN(PHI) + PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2 + ENDIF + 130 CONTINUE + IF(MINT(47).EQ.1) RETURN + +C...Kinematics construction for initial partons. + I1=MINT(83)+3 + I2=MINT(83)+4 + IF(ISUB.EQ.95) THEN + SHS=0D0 + SHR=0D0 + ELSE + SHS=VINT(141)*VINT(142)*VINT(2)+(P(I1,1)+P(I2,1))**2+ + & (P(I1,2)+P(I2,2))**2 + SHR=SQRT(MAX(0D0,SHS)) + IF((SHS-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2).LE.0D0) GOTO 100 + P(I1,4)=0.5D0*(SHR+(PMS(1)-PMS(2))/SHR) + P(I1,3)=SQRT(MAX(0D0,P(I1,4)**2-PMS(1))) + P(I2,4)=SHR-P(I1,4) + P(I2,3)=-P(I1,3) + +C...Transform partons to overall CM-frame. + ROBO(3)=(P(I1,1)+P(I2,1))/SHR + ROBO(4)=(P(I1,2)+P(I2,2))/SHR + CALL PYROBO(I1,I2,0D0,0D0,-ROBO(3),-ROBO(4),0D0) + ROBO(2)=PYANGL(P(I1,1),P(I1,2)) + CALL PYROBO(I1,I2,0D0,-ROBO(2),0D0,0D0,0D0) + ROBO(1)=PYANGL(P(I1,3),P(I1,1)) + CALL PYROBO(I1,I2,-ROBO(1),0D0,0D0,0D0,0D0) + CALL PYROBO(I2+1,MINT(52),0D0,-ROBO(2),0D0,0D0,0D0) + CALL PYROBO(I1,MINT(52),ROBO(1),ROBO(2),ROBO(3),ROBO(4),0D0) + ROBO(5)=(VINT(141)-VINT(142))/(VINT(141)+VINT(142)) + CALL PYROBO(I1,MINT(52),0D0,0D0,0D0,0D0,ROBO(5)) + ENDIF + +C...Optionally fix up x and Q2 definitions for leptoproduction. + IDISXQ=0 + IF((MINT(43).EQ.2.OR.MINT(43).EQ.3).AND.((ISUB.EQ.10.AND. + &MSTP(23).GE.1).OR.(ISUB.EQ.83.AND.MSTP(23).GE.2))) IDISXQ=1 + IF(IDISXQ.EQ.1) THEN + +C...Find where incoming and outgoing leptons/partons are sitting. + LESD=1 + IF(MINT(42).EQ.1) LESD=2 + LPIN=MINT(83)+3-LESD + LEIN=MINT(84)+LESD + LQIN=MINT(84)+3-LESD + LEOUT=MINT(84)+2+LESD + LQOUT=MINT(84)+5-LESD + IF(K(LEIN,3).GT.LEIN) LEIN=K(LEIN,3) + IF(K(LQIN,3).GT.LQIN) LQIN=K(LQIN,3) + LSCMS=0 + DO 140 I=MINT(84)+5,N + IF(K(I,2).EQ.94) THEN + LSCMS=I + LEOUT=I+LESD + LQOUT=I+3-LESD + ENDIF + 140 CONTINUE + LQBG=IPU1 + IF(LESD.EQ.1) LQBG=IPU2 + +C...Calculate actual and wanted momentum transfer. + XNOM=VINT(43-LESD) + Q2NOM=-VINT(45) + HPK=2D0*(P(LPIN,4)*P(LEIN,4)-P(LPIN,1)*P(LEIN,1)- + & P(LPIN,2)*P(LEIN,2)-P(LPIN,3)*P(LEIN,3))* + & (P(MINT(83)+LESD,4)*VINT(40+LESD)/P(LEIN,4)) + HPT2=MAX(0D0,Q2NOM*(1D0-Q2NOM/(XNOM*HPK))) + FAC=SQRT(HPT2/(P(LEOUT,1)**2+P(LEOUT,2)**2)) + P(N+1,1)=FAC*P(LEOUT,1) + P(N+1,2)=FAC*P(LEOUT,2) + P(N+1,3)=0.25D0*((HPK-Q2NOM/XNOM)/P(LPIN,4)- + & Q2NOM/(P(MINT(83)+LESD,4)*VINT(40+LESD)))*(-1)**(LESD+1) + P(N+1,4)=SQRT(P(LEOUT,5)**2+P(N+1,1)**2+P(N+1,2)**2+ + & P(N+1,3)**2) + DO 150 J=1,4 + QOLD(J)=P(LEIN,J)-P(LEOUT,J) + QNEW(J)=P(LEIN,J)-P(N+1,J) + 150 CONTINUE + +C...Boost outgoing electron and daughters. + IF(LSCMS.EQ.0) THEN + DO 160 J=1,4 + P(LEOUT,J)=P(N+1,J) + 160 CONTINUE + ELSE + DO 170 J=1,3 + P(N+2,J)=(P(N+1,J)-P(LEOUT,J))/(P(N+1,4)+P(LEOUT,4)) + 170 CONTINUE + PINV=2D0/(1D0+P(N+2,1)**2+P(N+2,2)**2+P(N+2,3)**2) + DO 180 J=1,3 + DBE(J)=PINV*P(N+2,J) + 180 CONTINUE + DO 200 I=LSCMS+1,N + IORIG=I + 190 IORIG=K(IORIG,3) + IF(IORIG.GT.LEOUT) GOTO 190 + IF(I.EQ.LEOUT.OR.IORIG.EQ.LEOUT) + & CALL PYROBO(I,I,0D0,0D0,DBE(1),DBE(2),DBE(3)) + 200 CONTINUE + ENDIF + +C...Copy shower initiator and all outgoing partons. + NCOP=N+1 + K(NCOP,3)=LQBG + DO 210 J=1,5 + P(NCOP,J)=P(LQBG,J) + 210 CONTINUE + DO 240 I=MINT(84)+1,N + ICOP=0 + IF(K(I,1).GT.10) GOTO 240 + IF(I.EQ.LQBG.OR.I.EQ.LQOUT) THEN + ICOP=I + ELSE + IORIG=I + 220 IORIG=K(IORIG,3) + IF(IORIG.EQ.LQBG.OR.IORIG.EQ.LQOUT) THEN + ICOP=IORIG + ELSEIF(IORIG.GT.MINT(84).AND.IORIG.LE.N) THEN + GOTO 220 + ENDIF + ENDIF + IF(ICOP.NE.0) THEN + NCOP=NCOP+1 + K(NCOP,3)=I + DO 230 J=1,5 + P(NCOP,J)=P(I,J) + 230 CONTINUE + ENDIF + 240 CONTINUE + +C...Calculate relative rescaling factors. + SLC=3-2*LESD + PLCSUM=0D0 + DO 250 I=N+2,NCOP + PLCSUM=PLCSUM+(P(I,4)+SLC*P(I,3)) + 250 CONTINUE + DO 260 I=N+2,NCOP + V(I,1)=(P(I,4)+SLC*P(I,3))/PLCSUM + 260 CONTINUE + +C...Transfer extra three-momentum of current. + DO 280 I=N+2,NCOP + DO 270 J=1,3 + P(I,J)=P(I,J)+V(I,1)*(QNEW(J)-QOLD(J)) + 270 CONTINUE + P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2) + 280 CONTINUE + +C...Iterate change of initiator momentum to get energy right. + ITER=0 + 290 ITER=ITER+1 + PEEX=-P(N+1,4)-QNEW(4) + PEMV=-P(N+1,3)/P(N+1,4) + DO 300 I=N+2,NCOP + PEEX=PEEX+P(I,4) + PEMV=PEMV+V(I,1)*P(I,3)/P(I,4) + 300 CONTINUE + IF(ABS(PEMV).LT.1D-10) THEN + MINT(51)=1 + MINT(57)=MINT(57)+1 + RETURN + ENDIF + PZCH=-PEEX/PEMV + P(N+1,3)=P(N+1,3)+PZCH + P(N+1,4)=SQRT(P(N+1,5)**2+P(N+1,1)**2+P(N+1,2)**2+P(N+1,3)**2) + DO 310 I=N+2,NCOP + P(I,3)=P(I,3)+V(I,1)*PZCH + P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2) + 310 CONTINUE + IF(ITER.LT.10.AND.ABS(PEEX).GT.1D-6*P(N+1,4)) GOTO 290 + +C...Modify momenta in event record. + HBE=2D0*(P(N+1,4)+P(LQBG,4))*(P(N+1,3)-P(LQBG,3))/ + & ((P(N+1,4)+P(LQBG,4))**2+(P(N+1,3)-P(LQBG,3))**2) + IF(ABS(HBE).GE.1D0) THEN + MINT(51)=1 + MINT(57)=MINT(57)+1 + RETURN + ENDIF + I=MINT(83)+5-LESD + CALL PYROBO(I,I,0D0,0D0,0D0,0D0,HBE) + DO 330 I=N+1,NCOP + ICOP=K(I,3) + DO 320 J=1,4 + P(ICOP,J)=P(I,J) + 320 CONTINUE + 330 CONTINUE + ENDIF + +C...Check minimum invariant mass of remnant system(s). + PSYS(0,4)=P(I1,4)+P(I2,4)+0.5D0*VINT(1)*(VINT(151)+VINT(152)) + PSYS(0,3)=P(I1,3)+P(I2,3)+0.5D0*VINT(1)*(VINT(151)-VINT(152)) + PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2) + PMIN(0)=SQRT(PMS(0)) + DO 340 JT=1,2 + PSYS(JT,4)=0.5D0*VINT(1)*VINT(142+JT) + PSYS(JT,3)=PSYS(JT,4)*(-1)**(JT-1) + PMIN(JT)=0D0 + IF(MINT(44+JT).EQ.1) GOTO 340 + MINT(105)=MINT(102+JT) + MINT(109)=MINT(106+JT) + CALL PYSPLI(MINT(10+JT),MINT(12+JT),KFLCH(JT),KFLSP(JT)) + IF(MINT(51).NE.0) THEN + MINT(57)=MINT(57)+1 + RETURN + ENDIF + IF(KFLCH(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLCH(JT)) + IF(KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLSP(JT)) + IF(KFLCH(JT)*KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+0.5D0*PARP(111) + PMIN(JT)=SQRT(PMIN(JT)**2+P(MINT(83)+JT+2,1)**2+ + & P(MINT(83)+JT+2,2)**2) + 340 CONTINUE + IF(PMIN(0)+PMIN(1)+PMIN(2).GT.VINT(1).OR.(MINT(45).GE.2.AND. + &PMIN(1).GT.PSYS(1,4)).OR.(MINT(46).GE.2.AND.PMIN(2).GT. + &PSYS(2,4))) THEN + MINT(51)=1 + MINT(57)=MINT(57)+1 + RETURN + ENDIF + +C...Loop over two remnants; skip if none there. + I=NS + DO 410 JT=1,2 + ISN(JT)=0 + IF(MINT(44+JT).EQ.1) GOTO 410 + IF(JT.EQ.1) IPU=IPU1 + IF(JT.EQ.2) IPU=IPU2 + +C...Store first remnant parton. + I=I+1 + IS(JT)=I + ISN(JT)=1 + DO 350 J=1,5 + K(I,J)=0 + P(I,J)=0D0 + V(I,J)=0D0 + 350 CONTINUE + K(I,1)=1 + K(I,2)=KFLSP(JT) + K(I,3)=MINT(83)+JT + P(I,5)=PYMASS(K(I,2)) + +C...First parton colour connections and kinematics. + KCOL=KCHG(PYCOMP(KFLSP(JT)),2) + IF(KCOL.EQ.2) THEN + K(I,1)=3 + K(I,4)=MSTU(5)*IPU+IPU + K(I,5)=MSTU(5)*IPU+IPU + K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I + K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I + ELSEIF(KCOL.NE.0) THEN + K(I,1)=3 + KFLS=(3-KCOL*ISIGN(1,KFLSP(JT)))/2 + K(I,KFLS+3)=IPU + K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I + ENDIF + IF(KFLCH(JT).EQ.0) THEN + P(I,1)=-P(MINT(83)+JT+2,1) + P(I,2)=-P(MINT(83)+JT+2,2) + PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2 + PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1) + P(I,3)=PSYS(JT,3) + P(I,4)=PSYS(JT,4) + +C...When extra remnant parton or hadron: store extra remnant. + ELSE + I=I+1 + ISN(JT)=2 + DO 360 J=1,5 + K(I,J)=0 + P(I,J)=0D0 + V(I,J)=0D0 + 360 CONTINUE + K(I,1)=1 + K(I,2)=KFLCH(JT) + K(I,3)=MINT(83)+JT + P(I,5)=PYMASS(K(I,2)) + +C...Find parton colour connections of extra remnant. + KCOL=KCHG(PYCOMP(KFLCH(JT)),2) + IF(KCOL.EQ.2) THEN + K(I,1)=3 + K(I,4)=MSTU(5)*IPU+IPU + K(I,5)=MSTU(5)*IPU+IPU + K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I + K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I + ELSEIF(KCOL.NE.0) THEN + K(I,1)=3 + KFLS=(3-KCOL*ISIGN(1,KFLCH(JT)))/2 + K(I,KFLS+3)=IPU + K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I + ENDIF + +C...Relative transverse momentum when two remnants. + LOOP=0 + 370 LOOP=LOOP+1 + CALL PYPTDI(1,P(I-1,1),P(I-1,2)) + IF(IABS(MINT(10+JT)).LT.20) THEN + P(I-1,1)=0D0 + P(I-1,2)=0D0 + ELSE + P(I-1,1)=P(I-1,1)-0.5D0*P(MINT(83)+JT+2,1) + P(I-1,2)=P(I-1,2)-0.5D0*P(MINT(83)+JT+2,2) + ENDIF + PMS(JT+2)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2 + P(I,1)=-P(MINT(83)+JT+2,1)-P(I-1,1) + P(I,2)=-P(MINT(83)+JT+2,2)-P(I-1,2) + PMS(JT+4)=P(I,5)**2+P(I,1)**2+P(I,2)**2 + +C...Meson or baryon; photon as meson. For splitup below. + IMB=1 + IF(MOD(MINT(10+JT)/1000,10).NE.0) IMB=2 + +C***Relative distribution for electron into two electrons. Temporary! + IF(IABS(MINT(10+JT)).LT.20.AND.MINT(14+JT).EQ.-MINT(10+JT)) + & THEN + CHI(JT)=PYR(0) + +C...Relative distribution of electron energy into electron plus parton. + ELSEIF(IABS(MINT(10+JT)).LT.20) THEN + XHRD=VINT(140+JT) + XE=VINT(154+JT) + CHI(JT)=(XE-XHRD)/(1D0-XHRD) + +C...Relative distribution of energy for particle into two jets. + ELSEIF(IABS(KFLCH(JT)).LE.10.OR.KFLCH(JT).EQ.21) THEN + CHIK=PARP(92+2*IMB) + IF(MSTP(92).LE.1) THEN + IF(IMB.EQ.1) CHI(JT)=PYR(0) + IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0)) + ELSEIF(MSTP(92).EQ.2) THEN + CHI(JT)=1D0-PYR(0)**(1D0/(1D0+CHIK)) + ELSEIF(MSTP(92).EQ.3) THEN + CUT=2D0*0.3D0/VINT(1) + 380 CHI(JT)=PYR(0)**2 + IF((CHI(JT)**2/(CHI(JT)**2+CUT**2))**0.25D0* + & (1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 380 + ELSEIF(MSTP(92).EQ.4) THEN + CUT=2D0*0.3D0/VINT(1) + CUTR=(1D0+SQRT(1D0+CUT**2))/CUT + 390 CHIR=CUT*CUTR**PYR(0) + CHI(JT)=(CHIR**2-CUT**2)/(2D0*CHIR) + IF((1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 390 + ELSE + CUT=2D0*0.3D0/VINT(1) + CUTA=CUT**(1D0-PARP(98)) + CUTB=(1D0+CUT)**(1D0-PARP(98)) + 400 CHI(JT)=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98))) + IF(((CHI(JT)+CUT)**2/(2D0*(CHI(JT)**2+CUT**2)))** + & (0.5D0*PARP(98))*(1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 400 + ENDIF + +C...Relative distribution of energy for particle into jet plus particle. + ELSE + IF(MSTP(94).LE.1) THEN + IF(IMB.EQ.1) CHI(JT)=PYR(0) + IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0)) + IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT) + ELSEIF(MSTP(94).EQ.2) THEN + CHI(JT)=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB))) + IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT) + ELSEIF(MSTP(94).EQ.3) THEN + CALL PYZDIS(1,0,PMS(JT+4),ZZ) + CHI(JT)=ZZ + ELSE + CALL PYZDIS(1000,0,PMS(JT+4),ZZ) + CHI(JT)=ZZ + ENDIF + ENDIF + +C...Construct total transverse mass; reject if too large. + CHI(JT)=MAX(1D-8,MIN(1D0-1D-8,CHI(JT))) + PMS(JT)=PMS(JT+4)/CHI(JT)+PMS(JT+2)/(1D0-CHI(JT)) + IF(PMS(JT).GT.PSYS(JT,4)**2) THEN + IF(LOOP.LT.100) THEN + GOTO 370 + ELSE + MINT(51)=1 + MINT(57)=MINT(57)+1 + RETURN + ENDIF + ENDIF + PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1) + VINT(158+JT)=CHI(JT) + +C...Subdivide longitudinal momentum according to value selected above. + PW1=CHI(JT)*(PSYS(JT,4)+ABS(PSYS(JT,3))) + P(IS(JT)+1,4)=0.5D0*(PW1+PMS(JT+4)/PW1) + P(IS(JT)+1,3)=0.5D0*(PW1-PMS(JT+4)/PW1)*(-1)**(JT-1) + P(IS(JT),4)=PSYS(JT,4)-P(IS(JT)+1,4) + P(IS(JT),3)=PSYS(JT,3)-P(IS(JT)+1,3) + ENDIF + 410 CONTINUE + N=I + +C...Check if longitudinal boosts needed - if so pick two systems. + PDEV=ABS(PSYS(0,4)+PSYS(1,4)+PSYS(2,4)-VINT(1))+ + &ABS(PSYS(0,3)+PSYS(1,3)+PSYS(2,3)) + IF(PDEV.LE.1D-6*VINT(1)) RETURN + IF(ISN(1).EQ.0) THEN + IR=0 + IL=2 + ELSEIF(ISN(2).EQ.0) THEN + IR=1 + IL=0 + ELSEIF(VINT(143).GT.0.2D0.AND.VINT(144).GT.0.2D0) THEN + IR=1 + IL=2 + ELSEIF(VINT(143).GT.0.2D0) THEN + IR=1 + IL=0 + ELSEIF(VINT(144).GT.0.2D0) THEN + IR=0 + IL=2 + ELSEIF(PMS(1)/PSYS(1,4)**2.GT.PMS(2)/PSYS(2,4)**2) THEN + IR=1 + IL=0 + ELSE + IR=0 + IL=2 + ENDIF + IG=3-IR-IL + +C...E+-pL wanted for system to be modified. + IF((IG.EQ.1.AND.ISN(1).EQ.0).OR.(IG.EQ.2.AND.ISN(2).EQ.0)) THEN + PPB=VINT(1) + PNB=VINT(1) + ELSE + PPB=VINT(1)-(PSYS(IG,4)+PSYS(IG,3)) + PNB=VINT(1)-(PSYS(IG,4)-PSYS(IG,3)) + ENDIF + +C...To keep x and Q2 in leptoproduction: do not count scattered lepton. + IF(IDISXQ.EQ.1.AND.IG.NE.0) THEN + PPB=PPB-(PSYS(0,4)+PSYS(0,3)) + PNB=PNB-(PSYS(0,4)-PSYS(0,3)) + DO 420 J=1,4 + PSYS(0,J)=0D0 + 420 CONTINUE + DO 450 I=MINT(84)+1,NS + IF(K(I,1).GT.10) GOTO 450 + INCL=0 + IORIG=I + 430 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1 + IORIG=K(IORIG,3) + IF(IORIG.GT.LPIN) GOTO 430 + IF(INCL.EQ.0) GOTO 450 + DO 440 J=1,4 + PSYS(0,J)=PSYS(0,J)+P(I,J) + 440 CONTINUE + 450 CONTINUE + PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2) + PPB=PPB+(PSYS(0,4)+PSYS(0,3)) + PNB=PNB+(PSYS(0,4)-PSYS(0,3)) + ENDIF + +C...Construct longitudinal boosts. + DPMTB=PPB*PNB + DPMTR=PMS(IR) + DPMTL=PMS(IL) + DSQLAM=SQRT(MAX(0D0,(DPMTB-DPMTR-DPMTL)**2-4D0*DPMTR*DPMTL)) + IF(DSQLAM.LE.1D-6*DPMTB) THEN + MINT(51)=1 + MINT(57)=MINT(57)+1 + RETURN + ENDIF + DSQSGN=SIGN(1D0,PSYS(IR,3)*PSYS(IL,4)-PSYS(IL,3)*PSYS(IR,4)) + DRKR=(DPMTB+DPMTR-DPMTL+DSQLAM*DSQSGN)/ + &(2D0*(PSYS(IR,4)+PSYS(IR,3))*PNB) + DRKL=(DPMTB+DPMTL-DPMTR+DSQLAM*DSQSGN)/ + &(2D0*(PSYS(IL,4)-PSYS(IL,3))*PPB) + DBER=(DRKR**2-1D0)/(DRKR**2+1D0) + DBEL=-(DRKL**2-1D0)/(DRKL**2+1D0) + +C...Perform longitudinal boosts. + IF(IR.EQ.1.AND.ISN(1).EQ.1.AND.DBER.LE.-0.99999999D0) THEN + P(IS(1),3)=0D0 + P(IS(1),4)=SQRT(P(IS(1),5)**2+P(IS(1),1)**2+P(IS(1),2)**2) + ELSEIF(IR.EQ.1) THEN + CALL PYROBO(IS(1),IS(1)+ISN(1)-1,0D0,0D0,0D0,0D0,DBER) + ELSEIF(IDISXQ.EQ.1) THEN + DO 470 I=I1,NS + INCL=0 + IORIG=I + 460 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1 + IORIG=K(IORIG,3) + IF(IORIG.GT.LPIN) GOTO 460 + IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBER) + 470 CONTINUE + ELSE + CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBER) + ENDIF + IF(IL.EQ.2.AND.ISN(2).EQ.1.AND.DBEL.GE.0.99999999D0) THEN + P(IS(2),3)=0D0 + P(IS(2),4)=SQRT(P(IS(2),5)**2+P(IS(2),1)**2+P(IS(2),2)**2) + ELSEIF(IL.EQ.2) THEN + CALL PYROBO(IS(2),IS(2)+ISN(2)-1,0D0,0D0,0D0,0D0,DBEL) + ELSEIF(IDISXQ.EQ.1) THEN + DO 490 I=I1,NS + INCL=0 + IORIG=I + 480 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1 + IORIG=K(IORIG,3) + IF(IORIG.GT.LPIN) GOTO 480 + IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBEL) + 490 CONTINUE + ELSE + CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBEL) + ENDIF + +C...Final check that energy-momentum conservation worked. + PESUM=0D0 + PZSUM=0D0 + DO 500 I=MINT(84)+1,N + IF(K(I,1).GT.10) GOTO 500 + PESUM=PESUM+P(I,4) + PZSUM=PZSUM+P(I,3) + 500 CONTINUE + PDEV=ABS(PESUM-VINT(1))+ABS(PZSUM) + IF(PDEV.GT.1D-4*VINT(1)) THEN + MINT(51)=1 + MINT(57)=MINT(57)+1 + RETURN + ENDIF + +C...Calculate rotation and boost from overall CM frame to +C...hadronic CM frame in leptoproduction. + MINT(91)=0 + IF(MINT(82).EQ.1.AND.(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN + MINT(91)=1 + LESD=1 + IF(MINT(42).EQ.1) LESD=2 + LPIN=MINT(83)+3-LESD + +C...Sum upp momenta of everything not lepton or photon to define boost. + DO 510 J=1,4 + PSUM(J)=0D0 + 510 CONTINUE + DO 530 I=1,N + IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 530 + IF(IABS(K(I,2)).GE.11.AND.IABS(K(I,2)).LE.20) GOTO 530 + IF(K(I,2).EQ.22) GOTO 530 + DO 520 J=1,4 + PSUM(J)=PSUM(J)+P(I,J) + 520 CONTINUE + 530 CONTINUE + VINT(223)=-PSUM(1)/PSUM(4) + VINT(224)=-PSUM(2)/PSUM(4) + VINT(225)=-PSUM(3)/PSUM(4) + +C...Boost incoming hadron to hadronic CM frame to determine rotations. + K(N+1,1)=1 + DO 540 J=1,5 + P(N+1,J)=P(LPIN,J) + V(N+1,J)=V(LPIN,J) + 540 CONTINUE + CALL PYROBO(N+1,N+1,0D0,0D0,VINT(223),VINT(224),VINT(225)) + VINT(222)=-PYANGL(P(N+1,1),P(N+1,2)) + CALL PYROBO(N+1,N+1,0D0,VINT(222),0D0,0D0,0D0) + IF(LESD.EQ.2) THEN + VINT(221)=-PYANGL(P(N+1,3),P(N+1,1)) + ELSE + VINT(221)=PYANGL(-P(N+1,3),P(N+1,1)) + ENDIF + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYMIGN +C...Initializes treatment of new multiple interactions scenario, +C...selects kinematics of hardest interaction if low-pT physics +C...included in run, and generates all non-hardest interactions. + + SUBROUTINE PYMIGN(MMUL) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP + EXTERNAL PYALPS + DOUBLE PRECISION PYALPS +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) + COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000) + COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) + COMMON/PYINT7/SIGT(0:6,0:6,0:5) + COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6), + & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1), + & XMI(2,240),PT2MI(240),IMISEP(0:240) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/, + &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/,/PYINTM/ +C...Local arrays and saved variables. + DIMENSION NMUL(20),SIGM(20),KSTR(500,2),VINTSV(80), + &WDTP(0:400),WDTE(0:400,0:5),XPQ(-25:25),KSAV(4,5),PSAV(4,5) + SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM,P83A,P83B,P83C, + &CQ2I,CQ2R,PIK,BDIV,B,PLOWB,PHIGHB,PALLB,S4A,S4B,S4C,POWIP, + &RPWIP,B2RPDV,B2RPMX,BAVG,VNT145,VNT146,VNT147 + +C...Initialization of multiple interaction treatment. + IF(MMUL.EQ.1) THEN + IF(MSTP(122).GE.1) WRITE(MSTU(11),5000) MSTP(82) + ISUB=96 + MINT(1)=96 + VINT(63)=0D0 + VINT(64)=0D0 + VINT(143)=1D0 + VINT(144)=1D0 + +C...Loop over phase space points: xT2 choice in 20 bins. + 100 SIGSUM=0D0 + DO 120 IXT2=1,20 + NMUL(IXT2)=MSTP(83) + SIGM(IXT2)=0D0 + DO 110 ITRY=1,MSTP(83) + RSCA=0.05D0*((21-IXT2)-PYR(0)) + XT2=VINT(149)*(1D0+VINT(149))/(VINT(149)+RSCA)-VINT(149) + XT2=MAX(0.01D0*VINT(149),XT2) + VINT(25)=XT2 + +C...Choose tau and y*. Calculate cos(theta-hat). + IF(PYR(0).LE.COEF(ISUB,1)) THEN + TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0) + TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT) + ELSE + TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2) + ENDIF + VINT(21)=TAU + CALL PYKLIM(2) + RYST=PYR(0) + MYST=1 + IF(RYST.GT.COEF(ISUB,8)) MYST=2 + IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3 + CALL PYKMAP(2,MYST,PYR(0)) + VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0)) + +C...Calculate differential cross-section. + VINT(71)=0.5D0*VINT(1)*SQRT(XT2) + CALL PYSIGH(NCHN,SIGS) + SIGM(IXT2)=SIGM(IXT2)+SIGS + 110 CONTINUE + SIGSUM=SIGSUM+SIGM(IXT2) + 120 CONTINUE + SIGSUM=SIGSUM/(20D0*MSTP(83)) + +C...Reject result if sigma(parton-parton) is smaller than hadronic one. + IF(SIGSUM.LT.1.1D0*SIGT(0,0,5)) THEN + IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) + & PARP(82)*(VINT(1)/PARP(89))**PARP(90),SIGSUM + PARP(82)=0.9D0*PARP(82) + VINT(149)=4D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/ + & VINT(2) + GOTO 100 + ENDIF + IF(MSTP(122).GE.1) WRITE(MSTU(11),5200) + & PARP(82)*(VINT(1)/PARP(89))**PARP(90), SIGSUM + +C...Start iteration to find k factor. + YKE=SIGSUM/MAX(1D-10,SIGT(0,0,5)) + P83A=(1D0-PARP(83))**2 + P83B=2D0*PARP(83)*(1D0-PARP(83)) + P83C=PARP(83)**2 + CQ2I=1D0/PARP(84)**2 + CQ2R=2D0/(1D0+PARP(84)**2) + SO=0.5D0 + XI=0D0 + YI=0D0 + XF=0D0 + YF=0D0 + XK=0.5D0 + IIT=0 + 130 IF(IIT.EQ.0) THEN + XK=2D0*XK + ELSEIF(IIT.EQ.1) THEN + XK=0.5D0*XK + ELSE + XK=XI+(YKE-YI)*(XF-XI)/(YF-YI) + ENDIF + +C...Evaluate overlap integrals. Find where to divide the b range. + IF(MSTP(82).EQ.2) THEN + SP=0.5D0*PARU(1)*(1D0-EXP(-XK)) + SOP=SP/PARU(1) + ELSE + IF(MSTP(82).EQ.3) THEN + DELTAB=0.02D0 + ELSEIF(MSTP(82).EQ.4) THEN + DELTAB=MIN(0.01D0,0.05D0*PARP(84)) + ELSE + POWIP=MAX(0.4D0,PARP(83)) + RPWIP=2D0/POWIP-1D0 + DELTAB=MAX(0.02D0,0.02D0*(2D0/POWIP)**(1D0/POWIP)) + SO=0D0 + ENDIF + SP=0D0 + SOP=0D0 + BSP=0D0 + SOHIGH=0D0 + IBDIV=0 + B=-0.5D0*DELTAB + 140 B=B+DELTAB + IF(MSTP(82).EQ.3) THEN + OV=EXP(-B**2)/PARU(2) + ELSEIF(MSTP(82).EQ.4) THEN + OV=(P83A*EXP(-MIN(50D0,B**2))+ + & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+ + & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2) + ELSE + OV=EXP(-B**POWIP)/PARU(2) + SO=SO+PARU(2)*B*DELTAB*OV + ENDIF + IF(IBDIV.EQ.1) SOHIGH=SOHIGH+PARU(2)*B*DELTAB*OV + PACC=1D0-EXP(-MIN(50D0,PARU(1)*XK*OV)) + SP=SP+PARU(2)*B*DELTAB*PACC + SOP=SOP+PARU(2)*B*DELTAB*OV*PACC + BSP=BSP+B*PARU(2)*B*DELTAB*PACC + IF(IBDIV.EQ.0.AND.PARU(1)*XK*OV.LT.1D0) THEN + IBDIV=1 + BDIV=B+0.5D0*DELTAB + ENDIF + IF(B.LT.1D0.OR.B*PACC.GT.1D-6) GOTO 140 + ENDIF + YK=PARU(1)*XK*SO/SP + +C...Continue iteration until convergence. + IF(YK.LT.YKE) THEN + XI=XK + YI=YK + IF(IIT.EQ.1) IIT=2 + ELSE + XF=XK + YF=YK + IF(IIT.EQ.0) IIT=1 + ENDIF + IF(ABS(YK-YKE).GE.1D-5*YKE) GOTO 130 + +C...Store some results for subsequent use. + BAVG=BSP/SP + VINT(145)=SIGSUM + VINT(146)=SOP/SO + VINT(147)=SOP/SP + VNT145=VINT(145) + VNT146=VINT(146) + VNT147=VINT(147) +C...PIK = PARU(1)*XK = (VINT(146)/VINT(147))*sigma_jet/sigma_nondiffr. + PIK=(VNT146/VNT147)*YKE + +C...Find relative weight for low and high impact parameter.. + PLOWB=PARU(1)*BDIV**2 + IF(MSTP(82).EQ.3) THEN + PHIGHB=PIK*0.5*EXP(-BDIV**2) + ELSEIF(MSTP(82).EQ.4) THEN + S4A=P83A*EXP(-BDIV**2) + S4B=P83B*EXP(-BDIV**2*CQ2R) + S4C=P83C*EXP(-BDIV**2*CQ2I) + PHIGHB=PIK*0.5*(S4A+S4B+S4C) + ELSEIF(PARP(83).GE.1.999D0) THEN + PHIGHB=PIK*SOHIGH + B2RPDV=BDIV**POWIP + ELSE + PHIGHB=PIK*SOHIGH + B2RPDV=BDIV**POWIP + B2RPMX=MAX(2D0*RPWIP,B2RPDV) + ENDIF + PALLB=PLOWB+PHIGHB + +C...Initialize iteration in xT2 for hardest interaction. + ELSEIF(MMUL.EQ.2) THEN + VINT(145)=VNT145 + VINT(146)=VNT146 + VINT(147)=VNT147 + IF(MSTP(82).LE.0) THEN + ELSEIF(MSTP(82).EQ.1) THEN + XT2=1D0 + SIGRAT=XSEC(96,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5)) + IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT* + & VINT(317)/(VINT(318)*VINT(320)) + XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149)) + ELSEIF(MSTP(82).EQ.2) THEN + XT2=1D0 + XT2FAC=VNT146*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))* + & VINT(149)*(1D0+VINT(149)) + ELSE + XC2=4D0*CKIN(3)**2/VINT(2) + IF(CKIN(3).LE.CKIN(5).OR.MINT(82).GE.2) XC2=0D0 + ENDIF + +C...Select impact parameter for hardest interaction. + IF(MSTP(82).LE.2) RETURN + 142 IF(PYR(0)*PALLB.LT.PLOWB) THEN +C...Treatment in low b region. + MINT(39)=1 + B=BDIV*SQRT(PYR(0)) + IF(MSTP(82).EQ.3) THEN + OV=EXP(-B**2)/PARU(2) + ELSEIF(MSTP(82).EQ.4) THEN + OV=(P83A*EXP(-MIN(50D0,B**2))+ + & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+ + & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2) + ELSE + OV=EXP(-B**POWIP)/PARU(2) + ENDIF + VINT(148)=OV/VNT147 + PACC=1D0-EXP(-MIN(50D0,PIK*OV)) + XT2=1D0 + XT2FAC=VNT146*VINT(148)*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))* + & VINT(149)*(1D0+VINT(149)) + ELSE +C...Treatment in high b region. + MINT(39)=2 + IF(MSTP(82).EQ.3) THEN + B=SQRT(BDIV**2-LOG(PYR(0))) + OV=EXP(-B**2)/PARU(2) + ELSEIF(MSTP(82).EQ.4) THEN + S4RNDM=PYR(0)*(S4A+S4B+S4C) + IF(S4RNDM.LT.S4A) THEN + B=SQRT(BDIV**2-LOG(PYR(0))) + ELSEIF(S4RNDM.LT.S4A+S4B) THEN + B=SQRT(BDIV**2-LOG(PYR(0))/CQ2R) + ELSE + B=SQRT(BDIV**2-LOG(PYR(0))/CQ2I) + ENDIF + OV=(P83A*EXP(-MIN(50D0,B**2))+ + & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+ + & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2) + ELSEIF(PARP(83).GE.1.999D0) THEN + 144 B2RPW=B2RPDV-LOG(PYR(0)) + ACCIP=(B2RPW/B2RPDV)**RPWIP + IF(ACCIP.LT.PYR(0)) GOTO 144 + OV=EXP(-B2RPW)/PARU(2) + B=B2RPW**(1D0/POWIP) + ELSE + 146 B2RPW=B2RPDV-2D0*LOG(PYR(0)) + ACCIP=(B2RPW/B2RPMX)**RPWIP*EXP(-0.5D0*(B2RPW-B2RPMX)) + IF(ACCIP.LT.PYR(0)) GOTO 146 + OV=EXP(-B2RPW)/PARU(2) + B=B2RPW**(1D0/POWIP) + ENDIF + VINT(148)=OV/VNT147 + PACC=(1D0-EXP(-MIN(50D0,PIK*OV)))/(PIK*OV) + ENDIF + IF(PACC.LT.PYR(0)) GOTO 142 + VINT(139)=B/BAVG + + ELSEIF(MMUL.EQ.3) THEN +C...Low-pT or multiple interactions (first semihard interaction): +C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm) +C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....). + ISUB=MINT(1) + VINT(145)=VNT145 + VINT(146)=VNT146 + VINT(147)=VNT147 + IF(MSTP(82).LE.0) THEN + XT2=0D0 + ELSEIF(MSTP(82).EQ.1) THEN + XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0))) +C...Use with "Sudakov" for low b values when impact parameter dependence. + ELSEIF(MSTP(82).EQ.2.OR.MINT(39).EQ.1) THEN + IF(XT2.LT.1D0.AND.EXP(-XT2FAC*XT2/(VINT(149)*(XT2+ + & VINT(149)))).GT.PYR(0)) XT2=1D0 + IF(XT2.GE.1D0) THEN + XT2=(1D0+VINT(149))*XT2FAC/(XT2FAC-(1D0+VINT(149))*LOG(1D0- + & PYR(0)*(1D0-EXP(-XT2FAC/(VINT(149)*(1D0+VINT(149)))))))- + & VINT(149) + ELSE + XT2=-XT2FAC/LOG(EXP(-XT2FAC/(XT2+VINT(149)))+PYR(0)* + & (EXP(-XT2FAC/VINT(149))-EXP(-XT2FAC/(XT2+VINT(149)))))- + & VINT(149) + ENDIF + XT2=MAX(0.01D0*VINT(149),XT2) +C...Use without "Sudakov" for high b values when impact parameter dep. + ELSE + XT2=(XC2+VINT(149))*(1D0+VINT(149))/(1D0+VINT(149)- + & PYR(0)*(1D0-XC2))-VINT(149) + XT2=MAX(0.01D0*VINT(149),XT2) + ENDIF + VINT(25)=XT2 + +C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed. + IF(MSTP(82).LE.1.AND.XT2.LT.VINT(149)) THEN + IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)-MINT(143) + IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)-MINT(143) + ISUB=95 + MINT(1)=ISUB + VINT(21)=1D-12*VINT(149) + VINT(22)=0D0 + VINT(23)=0D0 + VINT(25)=1D-12*VINT(149) + + ELSE +C...Multiple interactions (first semihard interaction). +C...Choose tau and y*. Calculate cos(theta-hat). + IF(PYR(0).LE.COEF(ISUB,1)) THEN + TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0) + TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT) + ELSE + TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2) + ENDIF + VINT(21)=TAU + CALL PYKLIM(2) + RYST=PYR(0) + MYST=1 + IF(RYST.GT.COEF(ISUB,8)) MYST=2 + IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3 + CALL PYKMAP(2,MYST,PYR(0)) + VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0)) + ENDIF + VINT(71)=0.5D0*VINT(1)*SQRT(VINT(25)) + +C...Store results of cross-section calculation. + ELSEIF(MMUL.EQ.4) THEN + ISUB=MINT(1) + VINT(145)=VNT145 + VINT(146)=VNT146 + VINT(147)=VNT147 + XTS=VINT(25) + IF(ISET(ISUB).EQ.1) XTS=VINT(21) + IF(ISET(ISUB).EQ.2) + & XTS=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2) + IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) XTS=VINT(26) + RBIN=MAX(0.000001D0,MIN(0.999999D0,XTS*(1D0+VINT(149))/ + & (XTS+VINT(149)))) + IRBIN=INT(1D0+20D0*RBIN) + IF(ISUB.EQ.96.AND.MSTP(171).EQ.0) THEN + NMUL(IRBIN)=NMUL(IRBIN)+1 + SIGM(IRBIN)=SIGM(IRBIN)+VINT(153) + ENDIF + +C...Choose impact parameter if not already done. + ELSEIF(MMUL.EQ.5) THEN + ISUB=MINT(1) + VINT(145)=VNT145 + VINT(146)=VNT146 + VINT(147)=VNT147 + 150 IF(MINT(39).GT.0) THEN + ELSEIF(MSTP(82).EQ.3) THEN + EXPB2=PYR(0) + B2=-LOG(PYR(0)) + VINT(148)=EXPB2/(PARU(2)*VNT147) + VINT(139)=SQRT(B2)/BAVG + ELSEIF(MSTP(82).EQ.4) THEN + RTYPE=PYR(0) + IF(RTYPE.LT.P83A) THEN + B2=-LOG(PYR(0)) + ELSEIF(RTYPE.LT.P83A+P83B) THEN + B2=-LOG(PYR(0))/CQ2R + ELSE + B2=-LOG(PYR(0))/CQ2I + ENDIF + VINT(148)=(P83A*EXP(-MIN(50D0,B2))+ + & P83B*CQ2R*EXP(-MIN(50D0,B2*CQ2R))+ + & P83C*CQ2I*EXP(-MIN(50D0,B2*CQ2I)))/(PARU(2)*VNT147) + VINT(139)=SQRT(B2)/BAVG + ELSEIF(PARP(83).GE.1.999D0) THEN + POWIP=MAX(2D0,PARP(83)) + RPWIP=2D0/POWIP-1D0 + PROB1=POWIP/(2D0*EXP(-1D0)+POWIP) + 160 IF(PYR(0).LT.PROB1) THEN + B2RPW=PYR(0)**(0.5D0*POWIP) + ACCIP=EXP(-B2RPW) + ELSE + B2RPW=1D0-LOG(PYR(0)) + ACCIP=B2RPW**RPWIP + ENDIF + IF(ACCIP.LT.PYR(0)) GOTO 160 + VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147) + VINT(139)=B2RPW**(1D0/POWIP)/BAVG + ELSE + POWIP=MAX(0.4D0,PARP(83)) + RPWIP=2D0/POWIP-1D0 + PROB1=RPWIP/(RPWIP+2D0**RPWIP*EXP(-RPWIP)) + 170 IF(PYR(0).LT.PROB1) THEN + B2RPW=2D0*RPWIP*PYR(0) + ACCIP=(B2RPW/RPWIP)**RPWIP*EXP(RPWIP-B2RPW) + ELSE + B2RPW=2D0*(RPWIP-LOG(PYR(0))) + ACCIP=(0.5D0*B2RPW/RPWIP)**RPWIP*EXP(RPWIP-0.5D0*B2RPW) + ENDIF + IF(ACCIP.LT .PYR(0)) GOTO 170 + VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147) + VINT(139)=B2RPW**(1D0/POWIP)/BAVG + ENDIF + +C...Multiple interactions (variable impact parameter) : reject with +C...probability exp(-overlap*cross-section above pT/normalization). +C...Does not apply to low-b region, where "Sudakov" already included. + VINT(150)=1D0 + IF(MINT(39).NE.1) THEN + RNCOR=(IRBIN-20D0*RBIN)*NMUL(IRBIN) + SIGCOR=(IRBIN-20D0*RBIN)*SIGM(IRBIN) + DO 180 IBIN=IRBIN+1,20 + RNCOR=RNCOR+NMUL(IBIN) + SIGCOR=SIGCOR+SIGM(IBIN) + 180 CONTINUE + SIGABV=(SIGCOR/RNCOR)*VINT(149)*(1D0-XTS)/(XTS+VINT(149)) + IF(MSTP(171).EQ.1) SIGABV=SIGABV*VINT(2)/VINT(289) + VINT(150)=EXP(-MIN(50D0,VNT146*VINT(148)* + & SIGABV/MAX(1D-10,SIGT(0,0,5)))) + ENDIF + IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUB.NE.11.AND. + & ISUB.NE.12.AND.ISUB.NE.13.AND.ISUB.NE.28.AND.ISUB.NE.53 + & .AND.ISUB.NE.68.AND.ISUB.NE.95.AND.ISUB.NE.96)) THEN + IF(VINT(150).LT.PYR(0)) GOTO 150 + VINT(150)=1D0 + ENDIF + +C...Generate additional multiple semihard interactions. + ELSEIF(MMUL.EQ.6) THEN + +C...Save data for hardest initeraction, to be restored. + ISUBSV=MINT(1) + VINT(145)=VNT145 + VINT(146)=VNT146 + VINT(147)=VNT147 + M13SV=MINT(13) + M14SV=MINT(14) + M15SV=MINT(15) + M16SV=MINT(16) + M21SV=MINT(21) + M22SV=MINT(22) + DO 190 J=11,80 + VINTSV(J)=VINT(J) + 190 CONTINUE + V141SV=VINT(141) + V142SV=VINT(142) + +C...Store data on hardest interaction. + XMI(1,1)=VINT(141) + XMI(2,1)=VINT(142) + PT2MI(1)=VINT(54) + IMISEP(0)=MINT(84) + IMISEP(1)=N + +C...Change process to generate; sum of x values so far. + ISUB=96 + MINT(1)=96 + VINT(143)=1D0-VINT(141) + VINT(144)=1D0-VINT(142) + VINT(151)=0D0 + VINT(152)=0D0 + +C...Initialize factors for PDF reshaping. + DO 230 JS=1,2 + KFBEAM=MINT(10+JS) + KFABM=IABS(KFBEAM) + KFSBM=ISIGN(1,KFBEAM) + +C...Zero flavour content of incoming beam particle. + KFIVAL(JS,1)=0 + KFIVAL(JS,2)=0 + KFIVAL(JS,3)=0 +C...Flavour content of baryon. + IF(KFABM.GT.1000) THEN + KFIVAL(JS,1)=KFSBM*MOD(KFABM/1000,10) + KFIVAL(JS,2)=KFSBM*MOD(KFABM/100,10) + KFIVAL(JS,3)=KFSBM*MOD(KFABM/10,10) +C...Flavour content of pi+-, K+-. + ELSEIF(KFABM.EQ.211) THEN + KFIVAL(JS,1)=KFSBM*2 + KFIVAL(JS,2)=-KFSBM + ELSEIF(KFABM.EQ.321) THEN + KFIVAL(JS,1)=-KFSBM*3 + KFIVAL(JS,2)=KFSBM*2 +C...Flavour content of pi0, gamma, K0S, K0L not defined yet. + ENDIF + +C...Zero initial valence and companion content. + DO 200 IFL=-6,6 + NVC(JS,IFL)=0 + 200 CONTINUE + +C...Initiate listing of all incoming partons from two sides. + NMI(JS)=0 + DO 210 I=MINT(84)+1,N + IF(K(I,3).EQ.MINT(83)+2+JS) THEN + IMI(JS,1,1)=I + IMI(JS,1,2)=0 + ENDIF + 210 CONTINUE + +C...Decide whether quarks in hard scattering were valence or sea. + IFL=K(IMI(JS,1,1),2) + IF (IABS(IFL).GT.6) GOTO 230 + +C...Get PDFs at X and Q2 of the parton shower initiator for the +C...hard scattering. + X=VINT(140+JS) + IF(MSTP(61).GE.1) THEN + Q2=PARP(62)**2 + ELSE + Q2=VINT(54) + ENDIF +C...Note: XPSVC = x*pdf. + MINT(30)=JS + CALL PYPDFU(KFBEAM,X,Q2,XPQ) + SEA=XPSVC(IFL,-1) + VAL=XPSVC(IFL,0) + +C...Decide (Extra factor x cancels in the division). + RVCS=PYR(0)*(SEA+VAL) + IVNOW=1 + 220 IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN +C...Safety check that valence present; pi0/gamma/K0S/K0L special cases. + IVNOW=0 + IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1 + IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1 + IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1 + IF(KFIVAL(JS,1).EQ.0) THEN + IF(KFBEAM.EQ.111.AND.IABS(IFL).LE.2) IVNOW=1 + IF(KFBEAM.EQ.22.AND.IABS(IFL).LE.5) IVNOW=1 + IF((KFBEAM.EQ.130.OR.KFBEAM.EQ.310).AND. + & (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1 + ENDIF + IF(IVNOW.EQ.0) GOTO 220 +C...Mark valence. + IMI(JS,1,2)=0 +C...Sets valence content of gamma, pi0, K0S, K0L if not done. + IF(KFIVAL(JS,1).EQ.0) THEN + IF(KFBEAM.EQ.111.OR.KFBEAM.EQ.22) THEN + KFIVAL(JS,1)=IFL + KFIVAL(JS,2)=-IFL + ELSEIF(KFBEAM.EQ.130.OR.KFBEAM.EQ.310) THEN + KFIVAL(JS,1)=IFL + IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL) + IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL) + ENDIF + ENDIF + +C...If sea, add opposite sign companion parton. Store X and I. + ELSE + NVC(JS,-IFL)=NVC(JS,-IFL)+1 + XASSOC(JS,-IFL,NVC(JS,-IFL))=X +C...Set pointer to companion + IMI(JS,1,2)=-NVC(JS,-IFL) + ENDIF + 230 CONTINUE + +C...Update counter number of multiple interactions. + NMI(1)=1 + NMI(2)=1 + +C...Set up starting values for iteration in xT2. + IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUBSV.NE.11.AND. + & ISUBSV.NE.12.AND.ISUBSV.NE.13.AND.ISUBSV.NE.28.AND. + & ISUBSV.NE.53.AND.ISUBSV.NE.68.AND.ISUBSV.NE.95.AND. + & ISUBSV.NE.96)) THEN + XT2=(1D0-VINT(141))*(1D0-VINT(142)) + ELSE + XT2=VINT(25) + IF(ISET(ISUBSV).EQ.1) XT2=VINT(21) + IF(ISET(ISUBSV).EQ.2) + & XT2=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2) + IF(ISET(ISUBSV).GE.3.AND.ISET(ISUBSV).LE.5) XT2=VINT(26) + ENDIF + IF(MSTP(82).LE.1) THEN + SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5)) + IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT* + & VINT(317)/(VINT(318)*VINT(320)) + XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149)) + ELSE + XT2FAC=VNT146*VINT(148)*XSEC(ISUB,1)/ + & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149)) + ENDIF + VINT(63)=0D0 + VINT(64)=0D0 + +C...Iterate downwards in xT2. + 240 IF((MINT(35).EQ.2.AND.MSTP(81).EQ.10).OR.ISUBSV.EQ.95) THEN + XT2=0D0 + GOTO 440 + ELSEIF(MSTP(82).LE.1) THEN + XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0))) + IF(XT2.LT.VINT(149)) GOTO 440 + ELSE + IF(XT2.LE.0.01001D0*VINT(149)) GOTO 440 + XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))* + & LOG(PYR(0)))-VINT(149) + IF(XT2.LE.0D0) GOTO 440 + XT2=MAX(0.01D0*VINT(149),XT2) + ENDIF + VINT(25)=XT2 + +C...Choose tau and y*. Calculate cos(theta-hat). + IF(PYR(0).LE.COEF(ISUB,1)) THEN + TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0) + TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT) + ELSE + TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2) + ENDIF + VINT(21)=TAU +C...New: require shat > 1. + IF(TAU*VINT(2).LT.1D0) GOTO 240 + CALL PYKLIM(2) + RYST=PYR(0) + MYST=1 + IF(RYST.GT.COEF(ISUB,8)) MYST=2 + IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3 + CALL PYKMAP(2,MYST,PYR(0)) + VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0)) + +C...Check that x not used up. Accept or reject kinematical variables. + X1M=SQRT(TAU)*EXP(VINT(22)) + X2M=SQRT(TAU)*EXP(-VINT(22)) + IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 240 + VINT(71)=0.5D0*VINT(1)*SQRT(XT2) + CALL PYSIGH(NCHN,SIGS) + IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320) + IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 240 + IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS/VINT(320) + +C...Reset K, P and V vectors. + DO 260 I=N+1,N+4 + DO 250 J=1,5 + K(I,J)=0 + P(I,J)=0D0 + V(I,J)=0D0 + 250 CONTINUE + 260 CONTINUE + PT=0.5D0*VINT(1)*SQRT(XT2) + +C...Choose flavour of reacting partons (and subprocess). + RSIGS=SIGS*PYR(0) + DO 270 ICHN=1,NCHN + KFL1=ISIG(ICHN,1) + KFL2=ISIG(ICHN,2) + ICONMI=ISIG(ICHN,3) + RSIGS=RSIGS-SIGH(ICHN) + IF(RSIGS.LE.0D0) GOTO 280 + 270 CONTINUE + +C...Reassign to appropriate process codes. + 280 ISUBMI=ICONMI/10 + ICONMI=MOD(ICONMI,10) + +C...Choose new quark flavour for annihilation graphs + IF(ISUBMI.EQ.12.OR.ISUBMI.EQ.53) THEN + SH=TAU*VINT(2) + CALL PYWIDT(21,SH,WDTP,WDTE) + 290 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0) + DO 300 I=1,MDCY(21,3) + KFLF=KFDP(I+MDCY(21,2)-1,1) + RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4)) + IF(RKFL.LE.0D0) GOTO 310 + 300 CONTINUE + 310 IF(ISUBMI.EQ.53.AND.ICONMI.LE.2) THEN + IF(KFLF.GE.4) GOTO 290 + ELSEIF(ISUBMI.EQ.53.AND.ICONMI.LE.4) THEN + KFLF=4 + ICONMI=ICONMI-2 + ELSEIF(ISUBMI.EQ.53) THEN + KFLF=5 + ICONMI=ICONMI-4 + ENDIF + ENDIF + +C...Final state flavours and colour flow: default values + JS=1 + KFL3=KFL1 + KFL4=KFL2 + KCC=20 + KCS=ISIGN(1,KFL1) + + IF(ISUBMI.EQ.11) THEN +C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2 + KCC=ICONMI + IF(KFL1*KFL2.LT.0) KCC=KCC+2 + + ELSEIF(ISUBMI.EQ.12) THEN +C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2 + KFL3=ISIGN(KFLF,KFL1) + KFL4=-KFL3 + KCC=4 + + ELSEIF(ISUBMI.EQ.13) THEN +C...f + fbar -> g + g; th arbitrary + KFL3=21 + KFL4=21 + KCC=ICONMI+4 + + ELSEIF(ISUBMI.EQ.28) THEN +C...f + g -> f + g; th = (p(f)-p(f))**2 + IF(KFL1.EQ.21) JS=2 + KCC=ICONMI+6 + IF(KFL1.EQ.21) KCC=KCC+2 + IF(KFL1.NE.21) KCS=ISIGN(1,KFL1) + IF(KFL2.NE.21) KCS=ISIGN(1,KFL2) + + ELSEIF(ISUBMI.EQ.53) THEN +C...g + g -> f + fbar; th arbitrary + KCS=(-1)**INT(1.5D0+PYR(0)) + KFL3=ISIGN(KFLF,KCS) + KFL4=-KFL3 + KCC=ICONMI+10 + + ELSEIF(ISUBMI.EQ.68) THEN +C...g + g -> g + g; th arbitrary + KCC=ICONMI+12 + KCS=(-1)**INT(1.5D0+PYR(0)) + ENDIF + +C...Store flavours of scattering. + MINT(13)=KFL1 + MINT(14)=KFL2 + MINT(15)=KFL1 + MINT(16)=KFL2 + MINT(21)=KFL3 + MINT(22)=KFL4 + +C...Set flavours and mothers of scattering partons. + K(N+1,1)=14 + K(N+2,1)=14 + K(N+3,1)=3 + K(N+4,1)=3 + K(N+1,2)=KFL1 + K(N+2,2)=KFL2 + K(N+3,2)=KFL3 + K(N+4,2)=KFL4 + K(N+1,3)=MINT(83)+1 + K(N+2,3)=MINT(83)+2 + K(N+3,3)=N+1 + K(N+4,3)=N+2 + +C...Store colour connection indices. + DO 320 J=1,2 + JC=J + IF(KCS.EQ.-1) JC=3-J + IF(ICOL(KCC,1,JC).NE.0) K(N+1,J+3)=N+ICOL(KCC,1,JC) + IF(ICOL(KCC,2,JC).NE.0) K(N+2,J+3)=N+ICOL(KCC,2,JC) + IF(ICOL(KCC,3,JC).NE.0) K(N+3,J+3)=MSTU(5)*(N+ICOL(KCC,3,JC)) + IF(ICOL(KCC,4,JC).NE.0) K(N+4,J+3)=MSTU(5)*(N+ICOL(KCC,4,JC)) + 320 CONTINUE + +C...Store incoming and outgoing partons in their CM-frame. + SHR=SQRT(TAU)*VINT(1) + P(N+1,3)=0.5D0*SHR + P(N+1,4)=0.5D0*SHR + P(N+2,3)=-0.5D0*SHR + P(N+2,4)=0.5D0*SHR + P(N+3,5)=PYMASS(K(N+3,2)) + P(N+4,5)=PYMASS(K(N+4,2)) + IF(P(N+3,5)+P(N+4,5).GE.SHR) GOTO 240 + P(N+3,4)=0.5D0*(SHR+(P(N+3,5)**2-P(N+4,5)**2)/SHR) + P(N+3,3)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,5)**2)) + P(N+4,4)=SHR-P(N+3,4) + P(N+4,3)=-P(N+3,3) + +C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4) + PHI=PARU(2)*PYR(0) + CALL PYROBO(N+3,N+4,ACOS(VINT(23)),PHI,0D0,0D0,0D0) + +C...Set up default values before showers. + MINT(31)=MINT(31)+1 + IPU1=N+1 + IPU2=N+2 + IPU3=N+3 + IPU4=N+4 + VINT(141)=VINT(41) + VINT(142)=VINT(42) + N=N+4 + +C...Showering of initial state partons (optional). +C...Note: no showering of final state partons here; it comes later. + IF(MSTP(84).GE.1.AND.MSTP(61).GE.1) THEN + MINT(51)=0 + ALAMSV=PARJ(81) + PARJ(81)=PARP(72) + NSAV=N + DO 340 I=1,4 + DO 330 J=1,5 + KSAV(I,J)=K(N-4+I,J) + PSAV(I,J)=P(N-4+I,J) + 330 CONTINUE + 340 CONTINUE + CALL PYSSPA(IPU1,IPU2) + PARJ(81)=ALAMSV +C...If shower failed then restore to situation before shower. + IF(MINT(51).GE.1) THEN + N=NSAV + DO 360 I=1,4 + DO 350 J=1,5 + K(N-4+I,J)=KSAV(I,J) + P(N-4+I,J)=PSAV(I,J) + 350 CONTINUE + 360 CONTINUE + IPU1=N-3 + IPU2=N-2 + VINT(141)=VINT(41) + VINT(142)=VINT(42) + ENDIF + ENDIF + +C...Keep track of loose colour ends and information on scattering. + 370 IMI(1,MINT(31),1)=IPU1 + IMI(2,MINT(31),1)=IPU2 + IMI(1,MINT(31),2)=0 + IMI(2,MINT(31),2)=0 + XMI(1,MINT(31))=VINT(141) + XMI(2,MINT(31))=VINT(142) + PT2MI(MINT(31))=VINT(54) + IMISEP(MINT(31))=N + +C...Decide whether quarks in last scattering were valence, companion or +C...sea. + DO 430 JS=1,2 + KFBEAM=MINT(10+JS) + KFSBM=ISIGN(1,MINT(10+JS)) + IFL=K(IMI(JS,MINT(31),1),2) + IMI(JS,MINT(31),2)=0 + IF (IABS(IFL).GT.6) GOTO 430 + +C...Get PDFs at X and Q2 of the parton shower initiator for the +C...last scattering. At this point VINT(143:144) do not yet +C...include the scattered x values VINT(141:142). + X=VINT(140+JS)/VINT(142+JS) + IF(MSTP(84).GE.1.AND.MSTP(61).GE.1) THEN + Q2=PARP(62)**2 + ELSE + Q2=VINT(54) + ENDIF +C...Note: XPSVC = x*pdf. + MINT(30)=JS + CALL PYPDFU(KFBEAM,X,Q2,XPQ) + SEA=XPSVC(IFL,-1) + VAL=XPSVC(IFL,0) + CMP=0D0 + DO 380 IVC=1,NVC(JS,IFL) + CMP=CMP+XPSVC(IFL,IVC) + 380 CONTINUE + +C...Decide (Extra factor x cancels in the dvision). + RVCS=PYR(0)*(SEA+VAL+CMP) + IVNOW=1 + 390 IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN +C...Safety check that valence present; pi0/gamma/K0S/K0L special cases. + IVNOW=0 + IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1 + IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1 + IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1 + IF(KFIVAL(JS,1).EQ.0) THEN + IF(KFBEAM.EQ.111.AND.IABS(IFL).LE.2) IVNOW=1 + IF(KFBEAM.EQ.22.AND.IABS(IFL).LE.5) IVNOW=1 + IF((KFBEAM.EQ.130.OR.KFBEAM.EQ.310).AND. + & (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1 + ELSE + DO 400 I1=1,NMI(JS) + IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0) + & IVNOW=IVNOW-1 + 400 CONTINUE + ENDIF + IF(IVNOW.EQ.0) GOTO 390 +C...Mark valence. + IMI(JS,MINT(31),2)=0 +C...Sets valence content of gamma, pi0, K0S, K0L if not done. + IF(KFIVAL(JS,1).EQ.0) THEN + IF(KFBEAM.EQ.111.OR.KFBEAM.EQ.22) THEN + KFIVAL(JS,1)=IFL + KFIVAL(JS,2)=-IFL + ELSEIF(KFBEAM.EQ.130.OR.KFBEAM.EQ.310) THEN + KFIVAL(JS,1)=IFL + IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL) + IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL) + ENDIF + ENDIF + + ELSEIF (RVCS.LE.VAL+SEA.OR.NVC(JS,IFL).EQ.0) THEN +C...If sea, add opposite sign companion parton. Store X and I. + NVC(JS,-IFL)=NVC(JS,-IFL)+1 + XASSOC(JS,-IFL,NVC(JS,-IFL))=X +C...Set pointer to companion + IMI(JS,MINT(31),2)=-NVC(JS,-IFL) + ELSE +C...If companion, decide which one. + CMPSUM=VAL+SEA + ISEL=0 + 410 ISEL=ISEL+1 + CMPSUM=CMPSUM+XPSVC(IFL,ISEL) + IF (RVCS.GT.CMPSUM.AND.ISEL.LT.NVC(JS,IFL)) GOTO 410 +C...Find original sea (anti-)quark: + IASSOC=0 + DO 420 I1=1,NMI(JS) + IF (K(IMI(JS,I1,1),2).NE.-IFL) GOTO 420 + IF (-IMI(JS,I1,2).EQ.ISEL) THEN + IMI(JS,MINT(31),2)=IMI(JS,I1,1) + IMI(JS,I1,2)=IMI(JS,MINT(31),1) + ENDIF + 420 CONTINUE +C...Change X to what associated companion had, so that the correct +C...amount of momentum can be subtracted from the companion sum below. + X=XASSOC(JS,IFL,ISEL) +C...Mark companion read. + XASSOC(JS,IFL,ISEL)=0D0 + ENDIF + 430 CONTINUE + +C...Global statistics. + MINT(351)=MINT(351)+1 + VINT(351)=VINT(351)+PT + IF (MINT(351).EQ.1) VINT(356)=PT + +C...Update remaining energy and other counters. + IF(N.GT.MSTU(4)-MSTU(32)-10) THEN + CALL PYERRM(11,'(PYMIGN:) no more memory left in PYJETS') + MINT(51)=1 + RETURN + ENDIF + NMI(1)=NMI(1)+1 + NMI(2)=NMI(2)+1 + VINT(151)=VINT(151)+VINT(41) + VINT(152)=VINT(152)+VINT(42) + VINT(143)=VINT(143)-VINT(141) + VINT(144)=VINT(144)-VINT(142) + +C...Iterate, with more interactions allowed. + IF(MINT(31).LT.240) GOTO 240 + 440 CONTINUE + +C...Restore saved quantities for hardest interaction. + MINT(1)=ISUBSV + MINT(13)=M13SV + MINT(14)=M14SV + MINT(15)=M15SV + MINT(16)=M16SV + MINT(21)=M21SV + MINT(22)=M22SV + DO 450 J=11,80 + VINT(J)=VINTSV(J) + 450 CONTINUE + VINT(141)=V141SV + VINT(142)=V142SV + + ENDIF + +C...Format statements for printout. + 5000 FORMAT(/1X,'****** PYMIGN: initialization of multiple inter', + &'actions for MSTP(82) =',I2,' ******') + 5100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P, + &D9.2,' mb: rejected') + 5200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P, + &D9.2,' mb: accepted') + + RETURN + END + +C********************************************************************* + +C...PYMIHK +C...Finds left-behind remnant flavour content and hooks up +C...the colour flow between the hard scattering and remnants + + SUBROUTINE PYMIHK + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...The event record + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) +C...Parameters + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) +C...The common block of dangling ends + COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6), + & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1), + & XMI(2,240),PT2MI(240),IMISEP(0:240) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINTM/ +C...Local variables + PARAMETER (NERSIZ=4000) + COMMON /PYCBLS/MCO(NERSIZ,2),NCC,JCCO(NERSIZ,2),JCCN(NERSIZ,2) + & ,MACCPT + COMMON /PYCTAG/NCT,MCT(NERSIZ,2) + SAVE /PYCBLS/,/PYCTAG/ + DIMENSION JST(2,3),IV(2,3),IDQ(3),NVSUM(2),NBRTOT(2),NG(2) + & ,ITJUNC(2),MOUT(2),INSR(1000,3),ISTR(6),YMI(240) + DATA NERRPR/0/ + SAVE NERRPR + FOUR(I,J)=P(I,4)*P(J,4)-P(I,3)*P(J,3)-P(I,2)*P(J,2)-P(I,1)*P(J,1) + +C...Set up error checkers + IBOOST=0 + +C...Initialize colour arrays: MCO (Original) and MCT (New) + DO 110 I=MINT(84)+1,NERSIZ + DO 100 JC=1,2 + MCT(I,JC)=0 + MCO(I,JC)=0 + 100 CONTINUE +C...Also zero colour tracing information, if existed. + IF (I.LE.N) THEN + K(I,4)=MOD(K(I,4),MSTU(5)**2) + K(I,5)=MOD(K(I,5),MSTU(5)**2) + ENDIF + 110 CONTINUE + +C...Initialize colour tag collapse arrays: +C...JCCO (Original) and JCCN (New). + DO 130 MG=MINT(84)+1,NERSIZ + DO 120 JC=1,2 + JCCO(MG,JC)=0 + JCCN(MG,JC)=0 + 120 CONTINUE + 130 CONTINUE + +C...Zero gluon insertion array + DO 150 IM=1,1000 + DO 140 J=1,3 + INSR(IM,J)=0 + 140 CONTINUE + 150 CONTINUE + +C...Compute hard scattering system rapidities + IF (MSTP(89).EQ.1) THEN + DO 160 IM=1,240 + IF (IM.LE.MINT(31)) THEN + YMI(IM)=LOG(XMI(1,IM)/XMI(2,IM)) + ELSE +C...Set (unsigned) rapidity = 100 for beam remnant systems. + YMI(IM)=100D0 + ENDIF + 160 CONTINUE + ENDIF + +C...Treat each side separately + DO 290 JS=1,2 + +C...Initialize side. + NG(JS)=0 + JV=0 + KFS=ISIGN(1,MINT(10+JS)) + +C...Set valence content of pi0, gamma, K0S, K0L if not yet done. + IF(KFIVAL(JS,1).EQ.0) THEN + IF(MINT(10+JS).EQ.111) THEN + KFIVAL(JS,1)=INT(1.5D0+PYR(0)) + KFIVAL(JS,2)=-KFIVAL(JS,1) + ELSEIF(MINT(10+JS).EQ.22) THEN + PYRKF=PYR(0) + KFIVAL(JS,1)=1 + IF(PYRKF.GT.0.1D0) KFIVAL(JS,1)=2 + IF(PYRKF.GT.0.5D0) KFIVAL(JS,1)=3 + IF(PYRKF.GT.0.6D0) KFIVAL(JS,1)=4 + KFIVAL(JS,2)=-KFIVAL(JS,1) + ELSEIF(MINT(10+JS).EQ.130.OR.MINT(10+JS).EQ.310) THEN + IF(PYR(0).GT.0.5D0) THEN + KFIVAL(JS,1)=1 + KFIVAL(JS,2)=-3 + ELSE + KFIVAL(JS,1)=3 + KFIVAL(JS,2)=-1 + ENDIF + ENDIF + ENDIF + +C...Initialize beam remnant sea and valence content flavour by flavour. + NVSUM(JS)=0 + NBRTOT(JS)=0 + DO 210 JFA=1,6 +C...Count up original number of JFA valence quarks and antiquarks. + NVALQ=0 + NVALQB=0 + NSEA=0 + DO 170 J=1,3 + IF(KFIVAL(JS,J).EQ.JFA) NVALQ=NVALQ+1 + IF(KFIVAL(JS,J).EQ.-JFA) NVALQB=NVALQB+1 + 170 CONTINUE + NVSUM(JS)=NVSUM(JS)+NVALQ+NVALQB +C...Subtract kicked out valence and determine sea from flavour cons. + DO 180 IM=1,NMI(JS) + IFL = K(IMI(JS,IM,1),2) + IFA = IABS(IFL) + IFS = ISIGN(1,IFL) + IF (IFL.EQ.JFA.AND.IMI(JS,IM,2).EQ.0) THEN +C...Subtract K.O. valence quark from remainder. + NVALQ=NVALQ-1 + JV=NVSUM(JS)-NVALQ-NVALQB + IV(JS,JV)=IMI(JS,IM,1) + ELSEIF (IFL.EQ.-JFA.AND.IMI(JS,IM,2).EQ.0) THEN +C...Subtract K.O. valence antiquark from remainder. + NVALQB=NVALQB-1 + JV=NVSUM(JS)-NVALQ-NVALQB + IV(JS,JV)=IMI(JS,IM,1) + ELSEIF (IFA.EQ.JFA) THEN +C...Outside sea without companion: add opposite sea flavour inside. + IF (IMI(JS,IM,2).LT.0) NSEA=NSEA-IFS + ENDIF + 180 CONTINUE +C...Check if space left in PYJETS for additional BR flavours + NFLSUM=IABS(NSEA)+NVALQ+NVALQB + NBRTOT(JS)=NBRTOT(JS)+NFLSUM + IF (N+NFLSUM+1.GT.MSTU(4)) THEN + CALL PYERRM(11,'(PYMIHK:) no more memory left in PYJETS') + MINT(51)=1 + RETURN + ENDIF +C...Add required val+sea content to beam remnant. + IF (NFLSUM.GT.0) THEN + DO 200 IA=1,NFLSUM +C...Insert beam remnant quark as p.t. symbolic parton in ER. + N=N+1 + DO 190 IX=1,5 + K(N,IX)=0 + P(N,IX)=0D0 + V(N,IX)=0D0 + 190 CONTINUE + K(N,1)=3 + K(N,2)=ISIGN(JFA,NSEA) + IF (IA.LE.NVALQ) K(N,2)=JFA + IF (IA.GT.NVALQ.AND.IA.LE.NVALQ+NVALQB) K(N,2)=-JFA + K(N,3)=MINT(83)+JS +C...Also update NMI, IMI, and IV arrays. + NMI(JS)=NMI(JS)+1 + IMI(JS,NMI(JS),1)=N + IMI(JS,NMI(JS),2)=-1 + IF (IA.LE.NVALQ+NVALQB) THEN + IMI(JS,NMI(JS),2)=0 + JV=JV+1 + IV(JS,JV)=IMI(JS,NMI(JS),1) + ENDIF + 200 CONTINUE + ENDIF + 210 CONTINUE + + IM=0 + 220 IM=IM+1 + IF (IM.LE.NMI(JS)) THEN + IF (K(IMI(JS,IM,1),2).EQ.21) THEN + NG(JS)=NG(JS)+1 +C...Add fictitious parent gluons for companion pairs. + ELSEIF (IMI(JS,IM,2).NE.0.AND.K(IMI(JS,IM,1),2).GT.0) THEN +C...Randomly assign companions to sea quarks which have none. + IF (IMI(JS,IM,2).LT.0) THEN + IMC=PYR(0)*NMI(JS) + 230 IMC=MOD(IMC,NMI(JS))+1 + IF (K(IMI(JS,IMC,1),2).NE.-K(IMI(JS,IM,1),2)) GOTO 230 + IF (IMI(JS,IMC,2).GE.0) GOTO 230 + IMI(JS, IM,2) = IMI(JS,IMC,1) + IMI(JS,IMC,2) = IMI(JS, IM,1) + ENDIF +C...Add fictitious parent gluon + N=N+1 + DO 240 IX=1,5 + K(N,IX)=0 + P(N,IX)=0D0 + V(N,IX)=0D0 + 240 CONTINUE + K(N,1)=14 + K(N,2)=21 + K(N,3)=MINT(83)+JS +C...Set gluon (anti-)colour daughter pointers + K(N,4)=IMI(JS, IM,1) + K(N,5)=IMI(JS, IM,2) +C...Set quark (anti-)colour parent pointers + K(IMI(JS, IM,2),5)=K(IMI(JS, IM,2),5)+MSTU(5)*N + K(IMI(JS, IM,1),4)=K(IMI(JS, IM,1),4)+MSTU(5)*N +C...Add gluon to IMI + NMI(JS)=NMI(JS)+1 + IMI(JS,NMI(JS),1)=N + IMI(JS,NMI(JS),2)=0 + ENDIF + GOTO 220 + ENDIF + +C...If incoming (anti-)baryon, insert inside (anti-)junction. +C...Set up initial v-v-j-v configuration. Otherwise set up +C...mesonic v-vbar configuration + IF (IABS(MINT(10+JS)).GT.1000) THEN +C...Determine junction type (1: B=1 2: B=-1) + ITJUNC(JS) = (3-KFS)/2 +C...Insert junction. + N=N+1 + DO 250 IX=1,5 + K(N,IX)=0 + P(N,IX)=0D0 + V(N,IX)=0D0 + 250 CONTINUE +C...Set special junction codes: + K(N,1)=42 + K(N,2)=88 +C...Set parent to side. + K(N,3)=MINT(83)+JS + K(N,4)=ITJUNC(JS)*MSTU(5) + K(N,5)=0 +C...Connect valence quarks to junction. + MOUT(JS)=0 + MANTI=ITJUNC(JS)-1 +C...Set (anti)colour mother = junction. + DO 260 JV=1,3 + K(IV(JS,JV),4+MANTI)=MOD(K(IV(JS,JV),4+MANTI),MSTU(5)) + & +MSTU(5)*N +C...Keep track of partons adjacent to junction: + JST(JS,JV)=IV(JS,JV) + 260 CONTINUE + ELSE +C...Mesons: set up initial q-qbar topology + ITJUNC(JS)=0 + IF (K(IV(JS,1),2).GT.0) THEN + IQ=IV(JS,1) + IQBAR=IV(JS,2) + ELSE + IQ=IV(JS,2) + IQBAR=IV(JS,1) + ENDIF + IV(JS,3)=0 + JST(JS,1)=IQ + JST(JS,2)=IQBAR + JST(JS,3)=0 + K(IQ,4)=MOD(K(IQ,4),MSTU(5))+MSTU(5)*IQBAR + K(IQBAR,5)=MOD(K(IQBAR,5),MSTU(5))+MSTU(5)*IQ +C...Special for mesons. Insert gluon if BR empty. + IF (NBRTOT(JS).EQ.0) THEN + N=N+1 + DO 270 IX=1,5 + K(N,IX)=0 + P(N,IX)=0D0 + V(N,IX)=0D0 + 270 CONTINUE + K(N,1)=3 + K(N,2)=21 + K(N,3)=MINT(83)+JS + K(N,4)=0 + K(N,5)=0 + NBRTOT(JS)=1 + NG(JS)=NG(JS)+1 +C...Add gluon to IMI + NMI(JS)=NMI(JS)+1 + IMI(JS,NMI(JS),1)=N + IMI(JS,NMI(JS),2)=0 + ENDIF + MOUT(JS)=0 + ENDIF + +C...Count up number of valence quarks outside BR. + DO 280 JV=1,3 + IF (JST(JS,JV).LE.MINT(53).AND.JST(JS,JV).GT.0) + & MOUT(JS)=MOUT(JS)+1 + 280 CONTINUE + + 290 CONTINUE + +C...Now both sides have been prepared in an initial vvjv (baryonic) or +C...v(g)vbar (mesonic) configuration. + +C...Create colour line tags starting from initiators. + NCT=0 + DO 320 IM=1,MINT(31) +C...Consider each side in turn. + DO 310 JS=1,2 + I1=IMI(JS,IM,1) + I2=IMI(3-JS,IM,1) + DO 300 JCS=4,5 + IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2))) + & GOTO 300 + IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 300 + + KCS=JCS + CALL PYCTTR(I1,KCS,I2) + IF(MINT(51).NE.0) RETURN + + 300 CONTINUE + 310 CONTINUE + 320 CONTINUE + + DO 340 JS=1,2 +C...Create colour tags for beam remnant partons. + DO 330 IM=MINT(31)+1,NMI(JS) + IP=IMI(JS,IM,1) + IF (K(IP,2).NE.21) THEN + JC=(3-ISIGN(1,K(IP,2)))/2 + IF (MCT(IP,JC).EQ.0) THEN + NCT=NCT+1 + MCT(IP,JC)=NCT + ENDIF + ELSE +C...Gluons + ICD=K(IP,4) + IAD=K(IP,5) + IF (ICD.NE.0) THEN +C...Fictituous gluons just inherit from their quark daughters. + ICC=MCT(ICD,1) + IAC=MCT(IAD,2) + ELSE +C...Real beam remnant gluons get their own colours + ICC=NCT+1 + IAC=NCT+2 + NCT=NCT+2 + ENDIF + MCT(IP,1)=ICC + MCT(IP,2)=IAC + ENDIF + 330 CONTINUE + 340 CONTINUE + +C...Create colour tags for colour lines which are detached from the +C...initial state. + + DO 360 MQGST=1,2 + DO 350 I=MINT(84)+1,N + +C...Look for coloured string endpoint, or (later) leftover gluon. + IF (K(I,1).NE.3) GOTO 350 + KC=PYCOMP(K(I,2)) + IF(KC.EQ.0) GOTO 350 + KQ=KCHG(KC,2) + IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 350 + +C...Pick up loose string end with no previous tag. + KCS=4 + IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5 + IF(MCT(I,KCS-3).NE.0) GOTO 350 + + CALL PYCTTR(I,KCS,I) + IF(MINT(51).NE.0) RETURN + + 350 CONTINUE + 360 CONTINUE + +C...Store original colour tags + DO 370 I=MINT(84)+1,N + MCO(I,1)=MCT(I,1) + MCO(I,2)=MCT(I,2) + 370 CONTINUE + +C...Iteratively add gluons to already existing string pieces, enforcing +C...various possible orderings, and rejecting insertions that would give +C...rise to singlet gluons. +C... normalization. + RM0=1.5D0 + MRETRY=0 + PARP80=PARP(80) + +C...Set up simplified kinematics. +C...Boost hard interaction systems. + IBOOST=IBOOST+1 + DO 380 IM=1,MINT(31) + BETA=(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM)) + CALL PYROBO(IMISEP(IM-1)+1,IMISEP(IM),0D0,0D0,0D0,0D0,BETA) + 380 CONTINUE +C...Assign preliminary beam remnant momenta. + DO 390 I=MINT(53)+1,N + JS=K(I,3) + P(I,1)=0D0 + P(I,2)=0D0 + IF (K(I,2).NE.88) THEN + P(I,4)=0.5D0*VINT(142+JS)*VINT(1)/MAX(1,NMI(JS)-MINT(31)) + P(I,3)=P(I,4) + IF (JS.EQ.2) P(I,3)=-P(I,3) + ELSE +C...Junctions are wildcards for the present. + P(I,4)=0D0 + P(I,3)=0D0 + ENDIF + 390 CONTINUE + +C...Reset colour processing information. + 400 DO 410 I=MINT(84)+1,N + K(I,4)=MOD(K(I,4),MSTU(5)**2) + K(I,5)=MOD(K(I,5),MSTU(5)**2) + 410 CONTINUE + + NCC=0 + DO 430 JS=1,2 +C...If meson, without gluon in BR, collapse q-qbar colour tags: + IF (ITJUNC(JS).EQ.0) THEN + JC1=MCT(JST(JS,1),1) + JC2=MCT(JST(JS,2),2) + NCC=NCC+1 + JCCO(NCC,1)=MAX(JC1,JC2) + JCCO(NCC,2)=MIN(JC1,JC2) +C...Collapse colour tags in event record + DO 420 I=MINT(84)+1,N + IF (MCT(I,1).EQ.JCCO(NCC,1)) MCT(I,1)=JCCO(NCC,2) + IF (MCT(I,2).EQ.JCCO(NCC,1)) MCT(I,2)=JCCO(NCC,2) + 420 CONTINUE + ENDIF + 430 CONTINUE + + 440 JS=1 + IF (PYR(0).GT.0.5D0.OR.NG(1).EQ.0) JS=2 + IF (NG(JS).GT.0) THEN + NOPT=0 + RLOPT=1D9 +C...Start at random gluon (optimizes speed for random attachments) + NMGL=0 + IMGL=PYR(0)*NMI(JS)+1 + 450 IMGL=MOD(IMGL,NMI(JS))+1 + NMGL=NMGL+1 +C...Only loop through NMI once (with upper limit to save time) + IF (NMGL.LE.NMI(JS).AND.NOPT.LE.3) THEN + IGL = IMI(JS,IMGL,1) +C...If not gluon or if already connected, try next. + IF (K(IGL,2).NE.21.OR.K(IGL,4)/MSTU(5).NE.0 + & .OR.K(IGL,5)/MSTU(5).NE.0) GOTO 450 +C...Now loop through all possible insertions of this gluon. + NMP1=0 + IMP1=PYR(0)*NMI(JS)+1 + 460 IMP1=MOD(IMP1,NMI(JS))+1 + NMP1=NMP1+1 + IF (IMP1.EQ.IMGL) GOTO 460 +C...Only loop through NMI once (with upper limit to save time). + IF (NMP1.LE.NMI(JS).AND.NOPT.LE.3) THEN + IP1 = IMI(JS,IMP1,1) +C...Try both colour mother and colour anti-mother. +C...Randomly select which one to try first. + NANTI=0 + MANTI=PYR(0)*2 + 470 MANTI=MOD(MANTI+1,2) + NANTI=NANTI+1 + IF (NANTI.LE.2) THEN + IP2 =MOD(K(IP1,4+MANTI)/MSTU(5),MSTU(5)) +C...Reject if no appropriate mother (or if mother is fictitious +C...parent gluon.) + IF (IP2.LE.0) GOTO 470 + IF (K(IP2,2).EQ.21.AND.IP2.GT.MINT(53)) GOTO 470 +C...Also reject if this link has already been tried. + IF (K(IP1,4+MANTI)/MSTU(5)**2.EQ.2) GOTO 470 + IF (K(IP2,5-MANTI)/MSTU(5)**2.EQ.2) GOTO 470 +C...Set flag to indicate that this link has now been tried for this +C...gluon. IP2 may be junction, which has several mothers. + K(IP1,4+MANTI)=K(IP1,4+MANTI)+2*MSTU(5)**2 + IF (K(IP2,2).NE.88) THEN + K(IP2,5-MANTI)=K(IP2,5-MANTI)+2*MSTU(5)**2 + ENDIF + +C...JCG1: Original colour tag of gluon on IP1 side +C...JCG2: Original colour tag of gluon on IP2 side +C...JCP1: Original colour tag of IP1 on gluon side +C...JCP2: Original colour tag of IP2 on gluon side. + JCG1=MCO(IGL,2-MANTI) + JCG2=MCO(IGL,1+MANTI) + JCP1=MCO(IP1,1+MANTI) + JCP2=MCO(IP2,2-MANTI) + + CALL PYMIHG(JCP1,JCG1,JCP2,JCG2) +C...Reject gluon attachments that give rise to singlet gluons. + IF (MACCPT.EQ.0) GOTO 470 + +C...Update colours + JCG1=MCT(IGL,2-MANTI) + JCG2=MCT(IGL,1+MANTI) + JCP1=MCT(IP1,1+MANTI) + JCP2=MCT(IP2,2-MANTI) + +C...Select whether to accept this insertion + IF (MSTP(89).EQ.0) THEN +C...Random insertions: no measure. + RL=1D0 +C...For random ordering, we want to suppress beam remnant breakups +C...already at this point. + IF (IP1.GT.MINT(53).AND.IP2.GT.MINT(53) + & .AND.MOUT(JS).NE.0.AND.PYR(0).GT.PARP80) THEN + NMP1=0 + NMGL=0 + GOTO 470 + ENDIF + ELSEIF (MSTP(89).EQ.1) THEN +C...Rapidity ordering: +C...YGL = Rapidity of gluon. + YGL=YMI(IMGL) +C...If fictitious gluon + IF (YGL.EQ.100D0) THEN + YGL=(3-2*JS)*100D0 + IDA1=MOD(K(IGL,4),MSTU(5)) + IDA2=MOD(K(IGL,5),MSTU(5)) + DO 480 IMT=1,NMI(JS) +C...Select (arbitrarily) the most central daughter. + IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2) + & THEN + IF (ABS(YGL).GT.ABS(YMI(IMT))) YGL=YMI(IMT) + ENDIF + 480 CONTINUE + ENDIF +C...YP1 = Rapidity IP1 + YP1=YMI(IMP1) +C...If fictitious gluon + IF (YP1.EQ.100D0) THEN + YP1=(3-2*JS)*YP1 + IDA1=MOD(K(IP1,4),MSTU(5)) + IDA2=MOD(K(IP1,5),MSTU(5)) + DO 490 IMT=1,NMI(JS) +C...Select (arbitrarily) the most central daughter. + IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2) + & THEN + IF (ABS(YP1).GT.ABS(YMI(IMT))) YP1=YMI(IMT) + ENDIF + 490 CONTINUE + ENDIF +C...YP2 = Rapidity of mother system + IF (K(IP2,2).NE.88) THEN + DO 500 IMT=1,NMI(JS) + IF (IMI(JS,IMT,1).EQ.IP2) YP2=YMI(IMT) + 500 CONTINUE +C...If fictitious gluon + IF (YP2.EQ.100D0) THEN + YP2=(3-2*JS)*YP2 + IDA1=MOD(K(IP2,4),MSTU(5)) + IDA2=MOD(K(IP2,5),MSTU(5)) + DO 510 IMT=1,NMI(JS) +C...Select (arbitrarily) the most central daughter. + IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2 + & ) THEN + IF (ABS(YP2).GT.ABS(YMI(IMT))) YP2=YMI(IMT) + ENDIF + 510 CONTINUE + ENDIF +C...Assign (arbitrarily) 100D0 to junction also + ELSE + YP2=(3-2*JS)*100D0 + ENDIF + RL=ABS(YGL-YP1)+ABS(YGL-YP2) + ELSEIF (MSTP(89).EQ.2) THEN +C...Lambda ordering: +C...Compute lambda measure for this insertion. + RL=1D0 + DO 520 IST=1,6 + ISTR(IST)=0 + 520 CONTINUE +C...If IP2 is junction, not caught below. + IF (JCP2.EQ.0) THEN + ITJU=MOD(K(IP2,4)/MSTU(5),MSTU(5)) +C...Anti-junction is colour endpoint et vv., always on JCG2. + ISTR(5-ITJU)=IP2 + ENDIF + DO 530 I=MINT(84)+1,N + IF (K(I,1).LT.10) THEN +C...The new string pieces + IF (MCT(I,1).EQ.JCG1) ISTR(1)=I + IF (MCT(I,2).EQ.JCG1) ISTR(2)=I + IF (MCT(I,1).EQ.JCG2) ISTR(3)=I + IF (MCT(I,2).EQ.JCG2) ISTR(4)=I + ENDIF + 530 CONTINUE +C...Also identify junctions as string endpoints. + DO 540 I=MINT(84)+1,N + ICMO=MOD(K(I,4)/MSTU(5),MSTU(5)) + IAMO=MOD(K(I,5)/MSTU(5),MSTU(5)) +C...Find partons adjacent to junctions. + IF (ICMO.GT.0.AND.ICMO.LE.N) THEN + IF (K(ICMO,1).EQ.42.AND.MCT(I,1).EQ.JCG1.AND.ISTR(2) + & .EQ.0) ISTR(2) = ICMO + IF (K(ICMO,1).EQ.42.AND.MCT(I,1).EQ.JCG2.AND.ISTR(4) + & .EQ.0) ISTR(4) = ICMO + ENDIF + IF (IAMO.GT.0.AND.IAMO.LE.N) THEN + IF (K(IAMO,1).EQ.42.AND.MCT(I,2).EQ.JCG1.AND.ISTR(1) + & .EQ.0) ISTR(1) = IAMO + IF (K(IAMO,1).EQ.42.AND.MCT(I,2).EQ.JCG2.AND.ISTR(3) + & .EQ.0) ISTR(3) = IAMO + ENDIF + 540 CONTINUE +C...The old string piece + ISTR(5)=ISTR(1+2*MANTI) + ISTR(6)=ISTR(4-2*MANTI) + IF (ISTR(1).EQ.0.OR.ISTR(2).EQ.0.OR.ISTR(3).EQ.0.OR. + & ISTR(4).EQ.0.OR.ISTR(5).EQ.0.OR.ISTR(6).EQ.0) THEN +C...If one or more of the colour tags for this connection is/are still +C...dangling, skip this attempt for the time being. + RL=1D6 + ELSE + RL=MAX(1D0,FOUR(ISTR(1),ISTR(2)))*MAX(1D0,FOUR(ISTR(3) + & ,ISTR(4)))/MAX(1D0,FOUR(ISTR(5),ISTR(6))) + RL=LOG(RL) + ENDIF + ENDIF +C...Allow some breadth to speed things up. + IF (ABS(1D0-RL/RLOPT).LT.0.05D0) THEN + NOPT=NOPT+1 + ELSEIF (RL.GT.RLOPT) THEN + GOTO 470 + ELSE + NOPT=1 + RLOPT=RL + ENDIF +C...INSR(NOPT,1)=Gluon colour mother +C...INSR(NOPT,2)=Gluon +C...INSR(NOPT,3)=Gluon anticolour mother + IF (NOPT.GT.1000) GOTO 470 + INSR(NOPT,1+2*MANTI)=IP2 + INSR(NOPT,2)=IGL + INSR(NOPT,3-2*MANTI)=IP1 + IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 470 + ENDIF + IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 460 + ENDIF +C...Reset link test information. + DO 550 I=MINT(84)+1,N + K(I,4)=MOD(K(I,4),MSTU(5)**2) + K(I,5)=MOD(K(I,5),MSTU(5)**2) + 550 CONTINUE + IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 450 + ENDIF +C...Now we have a list of best gluon insertions, none of which cause +C...singlets to arise. If list is empty, try again a few times. Note: +C...this should never happen if we have a meson with a gluon inserted +C...in the beam remnant, since that breaks up the colour line. + IF (NOPT.EQ.0) THEN +C...Abandon BR-g-BR suppression for retries. This is not serious, it +C...just means we happened to start with trying a bad sequence. + PARP80=1D0 + IF (MRETRY.LE.10.AND.(ITJUNC(1).NE.0.OR.JST(1,3).EQ.0).AND + & .(ITJUNC(2).NE.0.OR.JST(2,3).EQ.0)) THEN + MRETRY=MRETRY+1 + DO 590 JS=1,2 + IF (ITJUNC(JS).NE.0) THEN + JST(JS,1)=IV(JS,1) + JST(JS,2)=IV(JS,2) + JST(JS,3)=IV(JS,3) +C...Reset valence quark parent pointers + DO 560 I=MINT(53)+1,N + IF (K(I,2).EQ.88.AND.K(I,3).EQ.JS) IJU=I + 560 CONTINUE + MANTI=ITJUNC(JS)-1 +C...Set (anti)colour mother = junction. + DO 570 JV=1,3 + K(IV(JS,JV),4+MANTI)=MOD(K(IV(JS,JV),4+MANTI),MSTU(5)) + & +MSTU(5)*IJU + 570 CONTINUE + ELSE +C...Same for mesons. JST unchanged, so needn't be restored. + IQ=JST(JS,1) + IQBAR=JST(JS,2) + K(IQ,4)=MOD(K(IQ,4),MSTU(5))+MSTU(5)*IQBAR + K(IQBAR,5)=MOD(K(IQBAR,5),MSTU(5))+MSTU(5)*IQ + ENDIF +C...Also reset gluon parent pointers. + NG(JS)=0 + DO 580 IM=1,NMI(JS) + I=IMI(JS,IM,1) + IF (K(I,2).EQ.21) THEN + K(I,4)=MOD(K(I,4),MSTU(5)) + K(I,5)=MOD(K(I,5),MSTU(5)) + NG(JS)=NG(JS)+1 + ENDIF + 580 CONTINUE + 590 CONTINUE +C...Reset colour tags + DO 600 I=MINT(84)+1,N + MCT(I,1)=MCO(I,1) + MCT(I,2)=MCO(I,2) + 600 CONTINUE + GOTO 400 + ELSE + IF(NERRPR.LT.5) THEN + NERRPR=NERRPR+1 + CALL PYLIST(4) + CALL PYERRM(19,'(PYMIHK:) No physical colour flow found!') + WRITE(MSTU(11),*) 'NG:', NG,' MOUT:', MOUT(JS) + ENDIF +C...Kill event and start another. + MINT(51)=1 + RETURN + ENDIF + ELSE +C...Select between insertions, suppressing insertions wholly in the BR. + IIN=PYR(0)*NOPT+1 + 610 IIN=MOD(IIN,NOPT)+1 + IF (INSR(IIN,1).GT.MINT(53).AND.INSR(IIN,3).GT.MINT(53) + & .AND.MOUT(JS).NE.0.AND.PYR(0).GT.PARP80) GOTO 610 + ENDIF + +C...Now we know which gluon to insert where. Colour tags in JCCO and +C...colour connection information should be updated, NG(JS) should be +C...counted down, and a new loop performed if there are still gluons +C...left on any side. + ICM=INSR(IIN,1) + IACM=INSR(IIN,3) + IGL=INSR(IIN,2) +C...JCG : Original gluon colour tag +C...JCAG: Original gluon anticolour tag. +C...JCM : Original anticolour tag of gluon colour mother +C...JACM: Original colour tag of gluon anticolour mother + JCG=MCO(IGL,1) + JCM=MCO(ICM,2) + JACG=MCO(IGL,2) + JACM=MCO(IACM,1) + + CALL PYMIHG(JACM,JACG,JCM,JCG) + IF (MACCPT.EQ.0) THEN + IF(NERRPR.LT.5) THEN + NERRPR=NERRPR+1 + CALL PYLIST(4) + CALL PYERRM(11,'(PYMIHK:) Unphysical colour flow!') + WRITE(MSTU(11),*) 'attaching', IGL,' between', ICM, IACM + ENDIF +C...Kill event and start another. + MINT(51)=1 + RETURN + ELSE +C...If everything went fine, store new JCCN in JCCO. + NCC=NCC+1 + DO 620 ICC=1,NCC + JCCO(ICC,1)=JCCN(ICC,1) + JCCO(ICC,2)=JCCN(ICC,2) + 620 CONTINUE + ENDIF + +C...One gluon attached is counted as equivalent to one end outside. + MOUT(JS)=1 +C...Set IGL colour mother = ICM. + K(IGL,4)=MOD(K(IGL,4),MSTU(5))+MSTU(5)*ICM +C...Set ICM anticolour mother = IGL colour. + IF (K(ICM,2).NE.88) THEN + K(ICM,5)=MOD(K(ICM,5),MSTU(5))+MSTU(5)*IGL + ELSE +C...If ICM is junction, just update JST array for now. + DO 630 MSJ=1,3 + IF (JST(JS,MSJ).EQ.IACM) JST(JS,MSJ)=IGL + 630 CONTINUE + ENDIF +C...Set IGL anticolour mother = IACM. + K(IGL,5)=MOD(K(IGL,5),MSTU(5))+MSTU(5)*IACM +C...Set IACM anticolour mother = IGL anticolour. + IF (K(IACM,2).NE.88) THEN + K(IACM,4)=MOD(K(IACM,4),MSTU(5))+MSTU(5)*IGL + ELSE +C...If IACM is junction, just update JST array for now. + DO 640 MSJ=1,3 + IF (JST(JS,MSJ).EQ.ICM) JST(JS,MSJ)=IGL + 640 CONTINUE + ENDIF +C...Count down # unconnected gluons. + NG(JS)=NG(JS)-1 + ENDIF + IF (NG(1).GT.0.OR.NG(2).GT.0) GOTO 440 + + DO 840 JS=1,2 +C...Collapse fictitious gluons. + DO 670 IGL=MINT(53)+1,N + IF (K(IGL,2).EQ.21.AND.K(IGL,3).EQ.MINT(83)+JS.AND. + & K(IGL,1).EQ.14) THEN + ICM=K(IGL,4)/MSTU(5) + IAM=K(IGL,5)/MSTU(5) + ICD=MOD(K(IGL,4),MSTU(5)) + IAD=MOD(K(IGL,5),MSTU(5)) +C...Set gluon daughters pointing to gluon mothers + K(IAD,5)=MOD(K(IAD,5),MSTU(5))+MSTU(5)*IAM + K(ICD,4)=MOD(K(ICD,4),MSTU(5))+MSTU(5)*ICM +C...Set gluon mothers pointing to gluon daughters. + IF (K(ICM,2).NE.88) THEN + K(ICM,5)=MOD(K(ICM,5),MSTU(5))+MSTU(5)*ICD + ELSE +C...Special case: mother=junction. Just update JST array for now. + DO 650 MSJ=1,3 + IF (JST(JS,MSJ).EQ.IGL) JST(JS,MSJ)=ICD + 650 CONTINUE + ENDIF + IF (K(IAM,2).NE.88) THEN + K(IAM,4)=MOD(K(IAM,4),MSTU(5))+MSTU(5)*IAD + ELSE + DO 660 MSJ=1,3 + IF (JST(JS,MSJ).EQ.IGL) JST(JS,MSJ)=IAD + 660 CONTINUE + ENDIF + ENDIF + 670 CONTINUE + +C...Erase collapsed gluons from NMI and IMI (but keep them in ER) + IM=NMI(JS)+1 + 680 IM=IM-1 + IF (IM.GT.MINT(31).AND.K(IMI(JS,IM,1),2).NE.21) GOTO 680 + IF (IM.GT.MINT(31)) THEN + NMI(JS)=NMI(JS)-1 + DO 690 IMR=IM,NMI(JS) + IMI(JS,IMR,1)=IMI(JS,IMR+1,1) + IMI(JS,IMR,2)=IMI(JS,IMR+1,2) + 690 CONTINUE + GOTO 680 + ENDIF + +C...Finally, connect junction. + IF (ITJUNC(JS).NE.0) THEN + DO 700 I=MINT(53)+1,N + IF (K(I,2).EQ.88.AND.K(I,3).EQ.MINT(83)+JS) IJU=I + 700 CONTINUE +C...NBRJQ counts # of jq, NBRVQ # of jv, inside BR. + NBRJQ =0 + NBRVQ =0 + DO 720 MSJ=1,3 + IDQ(MSJ)=0 +C...Find jq with no glue inbetween inside beam remnant. + IF (JST(JS,MSJ).GT.MINT(53).AND.IABS(K(JST(JS,MSJ),2)).LE.5) + & THEN + NBRJQ=NBRJQ+1 +C...Set IDQ = -I if q non-valence and = +I if q valence. + IDQ(NBRJQ)=-JST(JS,MSJ) + DO 710 JV=1,3 + IF (IV(JS,JV).EQ.JST(JS,MSJ)) THEN + IDQ(NBRJQ)=JST(JS,MSJ) + NBRVQ=NBRVQ+1 + ENDIF + 710 CONTINUE + ENDIF + I12=MOD(MSJ+1,2) + I45=5 + IF (MSJ.EQ.3) I45=4 + K(IJU,I45)=K(IJU,I45)+(MSTU(5)**I12)*JST(JS,MSJ) + 720 CONTINUE + +C...Check if diquark can be formed. + IF ((MSTP(88).GE.0.AND.NBRVQ.GE.2).OR.(NBRJQ.GE.2.AND.MSTP(88) + & .GE.1)) THEN +C...If there is less than 2 valence quarks connected to junction +C...and MSTP(88)>1, use random non-valence quarks to fill up. + IF (NBRVQ.LE.1) THEN + NDIQ=NBRVQ + 730 JFLIP=NBRJQ*PYR(0)+1 + IF (IDQ(JFLIP).LT.0) THEN + IDQ(JFLIP)=-IDQ(JFLIP) + NDIQ=NDIQ+1 + ENDIF + IF (NDIQ.LE.1) GOTO 730 + ENDIF +C...Place selected quarks first in IDQ, ordered in flavour. + DO 740 JDQ=1,3 + IF (IDQ(JDQ).LE.0) THEN + ITEMP1 = IDQ(JDQ) + IDQ(JDQ)= IDQ(3) + IDQ(3) = -ITEMP1 + IF (IABS(K(IDQ(1),2)).LT.IABS(K(IDQ(2),2))) THEN + ITEMP1 = IDQ(1) + IDQ(1) = IDQ(2) + IDQ(2) = ITEMP1 + ENDIF + ENDIF + 740 CONTINUE +C...Choose diquark spin. + IF (NBRVQ.EQ.2) THEN +C...If the selected quarks are both valence, we may use SU(6) rules +C...to figure out which spin the diquark has, by a subdivision of the +C...original beam hadron into the selected diquark system plus a kicked +C...out quark, IKO. + JKO=6 + DO 760 JDQ=1,2 + DO 750 JV=1,3 + IF (IDQ(JDQ).EQ.IV(JS,JV)) JKO=JKO-JV + 750 CONTINUE + 760 CONTINUE + IKO=IV(JS,JKO) + CALL PYSPLI(MINT(10+JS),K(IKO,2),KFDUM,KFDQ) + ELSE +C...If one or more of the selected quarks are not valence, we cannot use +C...SU(6) subdivisions of the original beam hadron. Instead, with the +C...flavours of the diquark already selected, we assume for now +C...50:50 spin-1:spin-0 (where spin-0 possible). + KFDQ=1000*K(IDQ(1),2)+100*K(IDQ(2),2) + IS=3 + IF (K(IDQ(1),2).NE.K(IDQ(2),2).AND. + & (1D0+3D0*PARJ(4))*PYR(0).LT.1D0) IS=1 + KFDQ=KFDQ+ISIGN(IS,KFDQ) + ENDIF + +C...Collapse diquark-j-quark system to baryon, if allowed and possible. +C...Note: third quark can per definition not also be valence, +C...therefore we can only do this if we are allowed to use sea quarks. + 770 IF (IDQ(3).NE.0.AND.MSTP(88).GE.2) THEN + NTRY=0 + 780 NTRY=NTRY+1 + CALL PYKFDI(KFDQ,K(IABS(IDQ(3)),2),KFDUM,KFBAR) + IF (KFBAR.EQ.0.AND.NTRY.LE.100) THEN + GOTO 780 + ELSEIF(NTRY.GT.100) THEN +C...If no baryon can be found, give up and form diquark. + IDQ(3)=0 + GOTO 770 + ELSE +C...Replace junction by baryon. + K(IJU,1)=1 + K(IJU,2)=KFBAR + K(IJU,3)=MINT(83)+JS + K(IJU,4)=0 + K(IJU,5)=0 + P(IJU,5)=PYMASS(KFBAR) + DO 790 MSJ=1,3 +C...Prepare removal of participating quarks from ER. + K(JST(JS,MSJ),1)=-1 + 790 CONTINUE + ENDIF + ELSE +C...If collapse to baryon not possible or not allowed, replace junction +C...by diquark. This way, collapsed gluons that were pointing at the +C...junction will now point (correctly) at diquark. + MANTI=ITJUNC(JS)-1 + K(IJU,1)=3 + K(IJU,2)=KFDQ + K(IJU,3)=MINT(83)+JS + K(IJU,4)=0 + K(IJU,5)=0 + DO 800 MSJ=1,3 + IP=JST(JS,MSJ) + IF (IP.NE.IDQ(1).AND.IP.NE.IDQ(2)) THEN + K(IJU,4+MANTI)=0 + K(IJU,5-MANTI)=IP*MSTU(5) + K(IP,4+MANTI)=MOD(K(IP,4+MANTI),MSTU(5))+ + & MSTU(5)*IJU + MCT(IJU,2-MANTI)=MCT(IP,1+MANTI) + ELSE +C...Prepare removal of participating quarks from ER. + K(IP,1)=-1 + ENDIF + 800 CONTINUE + ENDIF + +C...Update so ER pointers to collapsed quarks +C...now go to collapsed object. + DO 820 I=MINT(84)+1,N + IF ((K(I,3).EQ.MINT(83)+JS.OR.K(I,3).EQ.MINT(83)+2+JS).AND + & .K(I,1).GT.0) THEN + DO 810 ISID=4,5 + IMO=K(I,ISID)/MSTU(5) + IDA=MOD(K(I,ISID),MSTU(5)) + IF (IMO.GT.0) THEN + IF (K(IMO,1).EQ.-1) IMO=IJU + ENDIF + IF (IDA.GT.0) THEN + IF (K(IDA,1).EQ.-1) IDA=IJU + ENDIF + K(I,ISID)=IDA+MSTU(5)*IMO + 810 CONTINUE + ENDIF + 820 CONTINUE + ENDIF + ENDIF + +C...Finally, if beam remnant is empty, insert a gluon in beam remnant. +C...(this only happens for baryons, where we want to force the gluon +C...to sit next to the junction. Mesons handled above.) + IF (NBRTOT(JS).EQ.0) THEN + N=N+1 + DO 830 IX=1,5 + K(N,IX)=0 + P(N,IX)=0D0 + V(N,IX)=0D0 + 830 CONTINUE + IGL=N + K(IGL,1)=3 + K(IGL,2)=21 + K(IGL,3)=MINT(83)+JS + IF (ITJUNC(JS).NE.0) THEN +C...Incoming baryons. Pick random leg in JST (NVSUM = 3 for baryons) + JLEG=PYR(0)*NVSUM(JS)+1 + I1=JST(JS,JLEG) + JST(JS,JLEG)=IGL + JCT=MCT(I1,ITJUNC(JS)) + MCT(IGL,3-ITJUNC(JS))=JCT + NCT=NCT+1 + MCT(IGL,ITJUNC(JS))=NCT + MANTI=ITJUNC(JS)-1 + ELSE +C...Meson. Should not happen. + CALL PYERRM(19,'(PYMIHK:) Empty meson beam remnant') + IF(NERRPR.LT.5) THEN + WRITE(MSTU(11),*) 'This should not have been possible!' + CALL PYLIST(4) + NERRPR=NERRPR+1 + ENDIF + MINT(51)=1 + RETURN + ENDIF + I2=MOD(K(I1,4+MANTI)/MSTU(5),MSTU(5)) + K(I1,4+MANTI)=MOD(K(I1,4+MANTI),MSTU(5))+MSTU(5)*IGL + K(IGL,5-MANTI)=MOD(K(IGL,5-MANTI),MSTU(5))+MSTU(5)*I1 + K(IGL,4+MANTI)=MOD(K(IGL,4+MANTI),MSTU(5))+MSTU(5)*I2 + IF (K(I2,2).NE.88) THEN + K(I2,5-MANTI)=MOD(K(I2,5-MANTI),MSTU(5))+MSTU(5)*IGL + ELSE + IF (MOD(K(I2,4),MSTU(5)).EQ.I1) THEN + K(I2,4)=(K(I2,4)/MSTU(5))*MSTU(5)+IGL + ELSEIF(MOD(K(I2,5)/MSTU(5),MSTU(5)).EQ.I1) THEN + K(I2,5)=MOD(K(I2,5),MSTU(5))+MSTU(5)*IGL + ELSE + K(I2,5)=(K(I2,5)/MSTU(5))*MSTU(5)+IGL + ENDIF + ENDIF + ENDIF + 840 CONTINUE + +C...Remove collapsed quarks and junctions from ER and update IMI. + CALL PYEDIT(11) + +C...Also update beam remnant part of IMI. + NMI(1)=MINT(31) + NMI(2)=MINT(31) + DO 850 I=MINT(53)+1,N + IF (K(I,1).LE.0) GOTO 850 +C...Restore BR quark/diquark/baryon pointers in IMI. + IF ((K(I,2).NE.21.OR.K(I,1).NE.14).AND.K(I,2).NE.88) THEN + JS=K(I,3)-MINT(83) + NMI(JS)=NMI(JS)+1 + IMI(JS,NMI(JS),1)=I + IMI(JS,NMI(JS),2)=0 + ENDIF + 850 CONTINUE + +C...Restore companion information from collapsed gluons. + DO 870 I=MINT(53)+1,N + IF (K(I,2).EQ.21.AND.K(I,1).EQ.14) THEN + JS=K(I,3)-MINT(83) + JCD=MOD(K(I,4),MSTU(5)) + JAD=MOD(K(I,5),MSTU(5)) + DO 860 IM=1,NMI(JS) + IF (IMI(JS,IM,1).EQ.JCD) IMC=IM + IF (IMI(JS,IM,1).EQ.JAD) IMA=IM + 860 CONTINUE + IMI(JS,IMC,2)=IMI(JS,IMA,1) + IMI(JS,IMA,2)=IMI(JS,IMC,1) + ENDIF + 870 CONTINUE + +C...Renumber colour lines (since some have disappeared) + JCT=0 + JCD=0 + 880 JCT=JCT+1 + MFOUND=0 + I=MINT(84) + 890 I=I+1 + IF (I.EQ.N+1) THEN + IF (MFOUND.EQ.0) JCD=JCD+1 + ELSEIF (MCT(I,1).EQ.JCT.AND.K(I,1).GE.1) THEN + MCT(I,1)=JCT-JCD + MFOUND=1 + ELSEIF (MCT(I,2).EQ.JCT.AND.K(I,1).GE.1) THEN + MCT(I,2)=JCT-JCD + MFOUND=1 + ENDIF + IF (I.LE.N) GOTO 890 + IF (JCT.LT.NCT) GOTO 880 + NCT=JCT-JCD + +C...Reset hard interaction subsystems to their CM frames. + IF (IBOOST.EQ.1) THEN + DO 900 IM=1,MINT(31) + BETA=-(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM)) + CALL PYROBO(IMISEP(IM-1)+1,IMISEP(IM),0D0,0D0,0D0,0D0,BETA) + 900 CONTINUE +C...Zero beam remnant longitudinal momenta and energies + DO 910 I=MINT(53)+1,N + P(I,3)=0D0 + P(I,4)=0D0 + 910 CONTINUE + ELSE + CALL PYERRM(9 + & ,'(PYMIHK:) Inconsistent kinematics. Too many boosts.') +C...Kill event and start another. + MINT(51)=1 + RETURN + ENDIF + + 9999 RETURN + END +C********************************************************************* + +C...PYCTTR +C...Adapted from PYPREP. +C...Assigns LHA1 colour tags to coloured partons based on +C...K(I,4) and K(I,5) colour connection record. +C...KCS negative signifies that a previous tracing should be continued. +C...(in case the tag to be continued is empty, the routine exits) +C...Starts at I and ends at I or IEND. +C...Special considerations for systems with junctions. +C...Special: if IEND=-1, means trace this parton to its color partner, +C... then exit. If no partner found, exit with 0. + + SUBROUTINE PYCTTR(I,KCS,IEND) +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYINT1/MINT(400),VINT(400) +C...The common block of colour tags. + COMMON/PYCTAG/NCT,MCT(4000,2) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/,/PYCTAG/ + DATA NERRPR/0/ + SAVE NERRPR + +C...Skip if parton not existing or does not have KCS + IF (K(I,1).LE.0) GOTO 120 + KC=PYCOMP(K(I,2)) + IF (KC.EQ.0) GOTO 120 + KQ=KCHG(KC,2) + IF (KQ.EQ.0) GOTO 120 + IF (IABS(KQ).EQ.1.AND.KQ*(9-2*ABS(KCS)).NE.ISIGN(1,K(I,2))) + & GOTO 120 + + IF (KCS.GT.0) THEN + NCT=NCT+1 +C...Set colour tag of first parton. + MCT(I,KCS-3)=NCT + NCS=NCT + ELSE + KCS=-KCS + NCS=MCT(I,KCS-3) + IF (NCS.EQ.0) GOTO 120 + ENDIF + + IA=I + NSTP=0 + 100 NSTP=NSTP+1 + IF(NSTP.GT.4*N) THEN + CALL PYERRM(14,'(PYCTTR:) caught in infinite loop') + GOTO 120 + ENDIF + +C...Finished if reached final-state triplet. + IF(K(IA,1).EQ.3) THEN + IF(NSTP.GE.2.AND.KCHG(PYCOMP(K(IA,2)),2).NE.2) GOTO 120 + ENDIF + +C...Also finished if reached junction. + IF(K(IA,1).EQ.42) THEN + GOTO 120 + ENDIF + +C...GOTO next parton in colour space. + 110 IB=IA +C...If IB's KCS daughter not traced and exists, goto KCS daughter. + IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5)) + & .NE.0) THEN + IA=MOD(K(IB,KCS),MSTU(5)) + K(IB,KCS)=K(IB,KCS)+MSTU(5)**2 + MREV=0 + ELSE +C...If KCS mother traced or KCS mother nonexistent, switch colour. + IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5), + & MSTU(5)).EQ.0) THEN + KCS=9-KCS + NCT=NCT+1 + NCS=NCT +C...Assign new colour tag on other side of old parton. + MCT(IB,KCS-3)=NCT + ENDIF +C...Goto (new) KCS mother, set mother traced tag + IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5)) + K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2 + MREV=1 + ENDIF + IF(IA.LE.0.OR.IA.GT.N) THEN + IF (IEND.EQ.-1) THEN + IEND=0 + GOTO 120 + ENDIF + CALL PYERRM(12,'(PYCTTR:) colour tag tracing failed') + IF(NERRPR.LT.5) THEN + write(*,*) 'began at ',I + write(*,*) 'ended going from', IB, ' to', IA, ' KCS=',KCS, + & ' NCS=',NCS,' MREV=',MREV + CALL PYLIST(4) + NERRPR=NERRPR+1 + ENDIF + MINT(51)=1 + RETURN + ENDIF + IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5), + & MSTU(5)).EQ.IB) THEN + IF(MREV.EQ.1) KCS=9-KCS + IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS +C...Set KSC mother traced tag for IA + K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2 + ELSE + IF(MREV.EQ.0) KCS=9-KCS + IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS +C...Set KCS daughter traced tag for IA + K(IA,KCS)=K(IA,KCS)+MSTU(5)**2 + ENDIF +C...Assign new colour tag + MCT(IA,KCS-3)=NCS +C...Finish if IEND=-1 and found final-state color partner + IF (IEND.EQ.-1.AND.K(IA,1).LT.10) THEN + IEND=IA + GOTO 120 + ENDIF + IF (IA.NE.I.AND.IA.NE.IEND) GOTO 100 + + 120 RETURN + END + +********************************************************************* + +C...PYMIHG +C...Collapse JCP1 and connecting tags to JCG1. +C...Collapse JCP2 and connecting tags to JCG2. + + SUBROUTINE PYMIHG(JCP1,JCG1,JCP2,JCG2) +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...The event record + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) +C...Parameters + COMMON/PYINT1/MINT(400),VINT(400) + SAVE /PYJETS/,/PYINT1/ +C...Local variables + COMMON /PYCBLS/MCO(4000,2),NCC,JCCO(4000,2),JCCN(4000,2),MACCPT + COMMON /PYCTAG/NCT,MCT(4000,2) + SAVE /PYCBLS/,/PYCTAG/ + +C...Break up JCP1<->JCP2 tag and create JCP1<->JCG1 and JCP2<->JCG2 tags +C...in temporary tag collapse array JCCN. Only break up one connection. + MACCPT=1 + MCLPS=0 + DO 100 ICC=1,NCC + JCCN(ICC,1)=JCCO(ICC,1) + JCCN(ICC,2)=JCCO(ICC,2) +C...If there was a mother, it was previously connected to JCP1. +C...Should be changed to JCP2. + IF (MCLPS.EQ.0) THEN + IF (JCCN(ICC,1).EQ.MAX(JCP1,JCP2).AND.JCCN(ICC,2).EQ.MIN(JCP1 + & ,JCP2)) THEN + JCCN(ICC,1)=MAX(JCG2,JCP2) + JCCN(ICC,2)=MIN(JCG2,JCP2) + MCLPS=1 + ENDIF + ENDIF + 100 CONTINUE +C...Also collapse colours on JCP1 side of JCG1 + IF (JCP1.NE.0) THEN + JCCN(NCC+1,1)=MAX(JCP1,JCG1) + JCCN(NCC+1,2)=MIN(JCP1,JCG1) + ELSE + JCCN(NCC+1,1)=MAX(JCP2,JCG2) + JCCN(NCC+1,2)=MIN(JCP2,JCG2) + ENDIF + +C...Initialize event record colour tag array MCT array to MCO. + DO 110 I=MINT(84)+1,N + MCT(I,1)=MCO(I,1) + MCT(I,2)=MCO(I,2) + 110 CONTINUE + +C...Collapse tags: +C...IS = 1 : All tags connecting to JCG1 on JCG1 side -> JCG1 +C...IS = 2 : All tags connecting to JCG2 on JCG2 side -> JCG2 +C...IS = 3 : All tags connecting to JCG1 on JCP1 side -> JCG1 +C...IS = 4 : All tags connecting to JCG2 on JCP2 side -> JCG2 + DO 160 IS=1,4 +C...Skip if junction. + IF ((IS.EQ.4.AND.JCP2.EQ.0).OR.(IS.EQ.3).AND.JCP1.EQ.0) GOTO 160 +C...Define starting point in tag space. +C...JCA = previous tag +C...JCO = present tag +C...JCN = new tag + IF (MOD(IS,2).EQ.1) THEN + JCO=JCP1 + JCN=JCG1 + JCALL=JCG1 + ELSEIF (MOD(IS,2).EQ.0) THEN + JCO=JCP2 + JCN=JCG2 + JCALL=JCG2 + ENDIF + ITRACE=0 + 120 ITRACE=ITRACE+1 + IF (ITRACE.GT.1000) THEN +C...NB: Proper error message should be defined here. + CALL PYERRM(14 + & ,'(PYMIHG:) Inf loop when collapsing colours.') + MINT(57)=MINT(57)+1 + MINT(51)=1 + RETURN + ENDIF +C...Collapse all JCN tags to JCALL + DO 130 I=MINT(84)+1,N + IF (MCO(I,1).EQ.JCN) MCT(I,1)=JCALL + IF (MCO(I,2).EQ.JCN) MCT(I,2)=JCALL + 130 CONTINUE +C...IS = 1,2: first step forward. IS = 3,4: first step backward. + IF (IS.GT.2.AND.(JCN.EQ.JCALL)) THEN + JCA=JCN + JCN=JCO + ELSE + JCA=JCO + JCO=JCN + ENDIF +C...If possible, step from JCO to new tag JCN not equal to JCA. + DO 140 ICC=1,NCC+1 + IF (JCCN(ICC,1).EQ.JCO.AND.JCCN(ICC,2).NE.JCA) JCN= + & JCCN(ICC,2) + IF (JCCN(ICC,2).EQ.JCO.AND.JCCN(ICC,1).NE.JCA) JCN= + & JCCN(ICC,1) + 140 CONTINUE +C...Iterate if new colour was arrived at, but don't go in circles. + IF (JCN.NE.JCO.AND.JCN.NE.JCALL) GOTO 120 +C...Change all JCN tags in MCO to JCALL in MCT. + DO 150 I=MINT(84)+1,N + IF (MCO(I,1).EQ.JCN) MCT(I,1)=JCALL + IF (MCO(I,2).EQ.JCN) MCT(I,2)=JCALL +C...If gluon and colour tag = anticolour tag (and not = 0) try again. + IF (K(I,2).EQ.21.AND.MCT(I,1).EQ.MCT(I,2).AND.MCT(I,1) + & .NE.0) MACCPT=0 + 150 CONTINUE + 160 CONTINUE + + DO 200 JCL=NCT,1,-1 + JCA=0 + JCN=JCL + 170 JCO=JCN + DO 180 ICC=1,NCC+1 + IF (JCCN(ICC,1).EQ.JCO.AND.JCCN(ICC,2).NE.JCA) JCN + & =JCCN(ICC,2) + IF (JCCN(ICC,2).EQ.JCO.AND.JCCN(ICC,1).NE.JCA) JCN + & =JCCN(ICC,1) + 180 CONTINUE +C...Overpaint all JCN with JCL + IF (JCN.NE.JCO.AND.JCN.NE.JCL) THEN + DO 190 I=MINT(84)+1,N + IF (MCT(I,1).EQ.JCN) MCT(I,1)=JCL + IF (MCT(I,2).EQ.JCN) MCT(I,2)=JCL +C...If gluon and colour tag = anticolour tag (and not = 0) try again. + IF (K(I,2).EQ.21.AND.MCT(I,1).EQ.MCT(I,2).AND.MCT(I,1) + & .NE.0) MACCPT=0 + 190 CONTINUE + JCA=JCO + GOTO 170 + ENDIF + 200 CONTINUE + + RETURN + END + +C********************************************************************* + +C...PYMIRM +C...Picks primordial kT and shares longitudinal momentum among +C...beam remnants. + + SUBROUTINE PYMIRM + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...The event record + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) +C...Parameters + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) +C...The common block of colour tags. + COMMON/PYCTAG/NCT,MCT(4000,2) +C...The common block of dangling ends + COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6), + & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1), + & XMI(2,240),PT2MI(240),IMISEP(0:240) + SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINTM/,/PYCTAG/ +C...Local variables + DIMENSION W(0:2,0:2),VB(3),NNXT(2),IVALQ(2),ICOMQ(2) +C...W(I,J)| J=0 | 1 | 2 | +C... I=0 | Wrem**2 | W+ | W- | +C... 1 | W1**2 | W1+ | W1- | +C... 2 | W2**2 | W2+ | W2- | +C...4-product + FOUR(I,J)=P(I,4)*P(J,4)-P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3) +C...Tentative parametrization of as a function of Q. + SIGPT(Q)=MAX(PARJ(21),2.1D0*Q/(7D0+Q)) +C SIGPT(Q)=MAX(0.36D0,4D0*SQRT(Q)/(10D0+SQRT(Q)) +C SIGPT(Q)=MAX(PARJ(21),3D0*SQRT(Q)/(5D0+SQRT(Q)) + GETPT(Q,SIGMA)=MIN(SIGMA*SQRT(-LOG(PYR(0))),PARP(93)) +C...Lambda kinematic function. + FLAM(A,B,C)=A**2+B**2+C**2-2D0*(A*B+B*C+C*A) + +C...Beginning and end of beam remnant partons + NOUT=MINT(53) + ISUB=MINT(1) + +C...Loopback point if kinematic choices gives impossible configuration. + NTRY=0 + 100 NTRY=NTRY+1 + +C...Assign kT values on each side separately. + DO 180 JS=1,2 + +C...First zero all kT on this side. Skip if no kT to generate. + DO 110 IM=1,NMI(JS) + P(IMI(JS,IM,1),1)=0D0 + P(IMI(JS,IM,1),2)=0D0 + 110 CONTINUE + IF(MSTP(91).LE.0) GOTO 180 + +C...Now assign kT to each (non-collapsed) parton in IMI. + DO 170 IM=1,NMI(JS) + I=IMI(JS,IM,1) +C...Select kT according to truncated gaussian or 1/kt6 tails. +C...For first interaction, either use rms width = PARP(91) or fitted. + IF (IM.EQ.1) THEN + SIGMA=PARP(91) + IF (MSTP(91).GE.11.AND.MSTP(91).LE.20) THEN + Q=SQRT(PT2MI(IM)) + SIGMA=SIGPT(Q) + ENDIF + ELSE +C...For subsequent interactions and BR partons use fragmentation width. + SIGMA=PARJ(21) + ENDIF + PHI=PARU(2)*PYR(0) + PT=0D0 + IF(NTRY.LE.100) THEN + 111 IF (MSTP(91).EQ.1.OR.MSTP(91).EQ.11) THEN + PT=GETPT(Q,SIGMA) + PTX=PT*COS(PHI) + PTY=PT*SIN(PHI) + ELSEIF (MSTP(91).EQ.2) THEN + CALL PYERRM(1,'(PYMIRM:) Sorry, MSTP(91)=2 not '// + & 'available, using MSTP(91)=1.') + CALL PYGIVE('MSTP(91)=1') + GOTO 111 + ELSEIF(MSTP(91).EQ.3.OR.MSTP(91).EQ.13) THEN +C...Use distribution with kt**6 tails, rms width = PARP(91). + EPS=SQRT(3D0/2D0)*SIGMA +C...Generate PTX and PTY separately, each propto 1/KT**6 + DO 119 IXY=1,2 +C...Decide which interval to try + 112 P12=1D0/(1D0+27D0/40D0*SIGMA**6/EPS**6) + IF (PYR(0).LT.P12) THEN +C...Use flat approx with accept/reject up to EPS. + PT=PYR(0)*EPS + WT=(3D0/2D0*SIGMA**2/(PT**2+3D0/2D0*SIGMA**2))**3 + IF (PYR(0).GT.WT) GOTO 112 + ELSE +C...Above EPS, use 1/kt**6 approx with accept/reject. + PT=EPS/(PYR(0)**(1D0/5D0)) + WT=PT**6/(PT**2+3D0/2D0*SIGMA**2)**3 + IF (PYR(0).GT.WT) GOTO 112 + ENDIF + MSIGN=1 + IF (PYR(0).GT.0.5D0) MSIGN=-1 + IF (IXY.EQ.1) PTX=MSIGN*PT + IF (IXY.EQ.2) PTY=MSIGN*PT + 119 CONTINUE + ELSEIF (MSTP(91).EQ.4.OR.MSTP(91).EQ.14) THEN + PTX=SIGMA*(SQRT(6D0)*PYR(0)-SQRT(3D0/2D0)) + PTY=SIGMA*(SQRT(6D0)*PYR(0)-SQRT(3D0/2D0)) + ENDIF +C...Adjust final PT. Impose upper cutoff, or zero for soft evts. + PT=SQRT(PTX**2+PTY**2) + WT=1D0 + IF (PT.GT.PARP(93)) WT=SQRT(PARP(93)/PT) + IF(ISUB.EQ.95.AND.IM.EQ.1) WT=0D0 + PTX=PTX*WT + PTY=PTY*WT + PT=SQRT(PTX**2+PTY**2) + ENDIF + + P(I,1)=P(I,1)+PTX + P(I,2)=P(I,2)+PTY + +C...Compensation kicks, with varying degree of local anticorrelations. + MCORR=MSTP(90) + IF (MCORR.EQ.0.OR.ISUB.EQ.95) THEN + PTCX=-PTX/(NMI(JS)-1) + PTCY=-PTY/(NMI(JS)-1) + IF(ISUB.EQ.95) THEN + PTCX=-PTX/(NMI(JS)-2) + PTCY=-PTY/(NMI(JS)-2) + ENDIF + DO 120 IMC=1,NMI(JS) + IF (IMC.EQ.IM) GOTO 120 + IF(ISUB.EQ.95.AND.IMC.EQ.1) GOTO 120 + P(IMI(JS,IMC,1),1)=P(IMI(JS,IMC,1),1)+PTCX + P(IMI(JS,IMC,1),2)=P(IMI(JS,IMC,1),2)+PTCY + 120 CONTINUE + ELSEIF (MCORR.GE.1) THEN + DO 140 MSID=4,5 + NNXT(MSID-3)=0 +C...Count up # of neighbours on either side + IMO=I + 130 IMO=K(IMO,MSID)/MSTU(5) + IF (IMO.EQ.0) GOTO 140 + NNXT(MSID-3)=NNXT(MSID-3)+1 +C...Stop at quarks and junctions + IF (MCORR.EQ.1.AND.K(IMO,2).EQ.21) GOTO 130 + 140 CONTINUE +C...How should compensation be shared when unequal numbers on the +C...two sides? 50/50 regardless? N1:N2? Assume latter for now. + NSUM=NNXT(1)+NNXT(2) + T1=0 + DO 160 MSID=4,5 +C...Total momentum to be compensated on this side + IF (NNXT(MSID-3).EQ.0) GOTO 160 + PTCX=-(NNXT(MSID-3)*PTX)/NSUM + PTCY=-(NNXT(MSID-3)*PTY)/NSUM +C...RS: compensation supression factor as we go out from parton I. +C...Hardcoded behaviour RS=0.5, i.e. 1/2**n falloff, +C...since (for now) MSTP(90) provides enough variability. + RS=0.5D0 + FAC=(1D0-RS)/(RS*(1-RS**NNXT(MSID-3))) + IMO=I + 150 IDA=IMO + IMO=K(IMO,MSID)/MSTU(5) + IF (IMO.EQ.0) GOTO 160 + FAC=FAC*RS + IF (K(IMO,2).NE.88) THEN + P(IMO,1)=P(IMO,1)+FAC*PTCX + P(IMO,2)=P(IMO,2)+FAC*PTCY + IF (MCORR.EQ.1.AND.K(IMO,2).EQ.21) GOTO 150 +C...If we reach junction, divide out the kT that would have been +C...assigned to the junction on each of its other legs. + ELSE + L1=MOD(K(IMO,4),MSTU(5)) + L2=K(IMO,5)/MSTU(5) + L3=MOD(K(IMO,5),MSTU(5)) + P(L1,1)=P(L1,1)+0.5D0*FAC*PTCX + P(L1,2)=P(L1,2)+0.5D0*FAC*PTCY + P(L2,1)=P(L2,1)+0.5D0*FAC*PTCX + P(L2,2)=P(L2,2)+0.5D0*FAC*PTCY + P(L3,1)=P(L3,1)+0.5D0*FAC*PTCX + P(L3,2)=P(L3,2)+0.5D0*FAC*PTCY + P(IDA,1)=P(IDA,1)-0.5D0*FAC*PTCX + P(IDA,2)=P(IDA,2)-0.5D0*FAC*PTCY + ENDIF + + 160 CONTINUE + ENDIF + 170 CONTINUE +C...End assignment of kT values to initiators and remnants. + 180 CONTINUE + +C...Check kinematics constraints for non-BR partons. + DO 190 IM=1,MINT(31) + SHAT=XMI(1,IM)*XMI(2,IM)*VINT(2) + PT1=SQRT(P(IMI(1,IM,1),1)**2+P(IMI(1,IM,1),2)**2) + PT2=SQRT(P(IMI(2,IM,1),1)**2+P(IMI(2,IM,1),2)**2) + PT1PT2=P(IMI(1,IM,1),1)*P(IMI(2,IM,1),1) + & +P(IMI(1,IM,1),2)*P(IMI(2,IM,1),2) + IF (SHAT.LT.2D0*(PT1*PT2-PT1PT2).AND.NTRY.LE.100) THEN + IF(NTRY.GE.100) THEN +C...Kill this event and start another. + CALL PYERRM(1, + & '(PYMIRM:) No consistent (x,kT) sets found') + MINT(51)=1 + RETURN + ENDIF + GOTO 100 + ENDIF + 190 CONTINUE + +C...Calculate W+ and W- available for combined remnant system. + W(0,1)=VINT(1) + W(0,2)=VINT(1) + DO 200 IM=1,MINT(31) + PT2 = (P(IMI(1,IM,1),1)+P(IMI(2,IM,1),1))**2 + & +(P(IMI(1,IM,1),2)+P(IMI(2,IM,1),2))**2 + ST=XMI(1,IM)*XMI(2,IM)*VINT(2)+PT2 + W(0,1)=W(0,1)-SQRT(XMI(1,IM)/XMI(2,IM)*ST) + W(0,2)=W(0,2)-SQRT(XMI(2,IM)/XMI(1,IM)*ST) + 200 CONTINUE +C...Also store Wrem**2 = W+ * W- + W(0,0)=W(0,1)*W(0,2) + + IF ((W(0,0).LT.0D0.OR.W(0,1)+W(0,2).LT.0D0).AND.NTRY.LE.100) THEN + IF(NTRY.GE.100) THEN +C...Kill this event and start another. + CALL PYERRM(1, + & '(PYMIRM:) Negative beam remnant mass squared unavoidable') + MINT(51)=1 + RETURN + ENDIF + GOTO 100 + ENDIF + +C...Assign unscaled x values to partons/hadrons in each of the +C...beam remnants and calculate unscaled W+ and W- from them. + NTRYX=0 + 210 NTRYX=NTRYX+1 + DO 280 JS=1,2 + W(JS,1)=0D0 + W(JS,2)=0D0 + DO 270 IM=MINT(31)+1,NMI(JS) + I=IMI(JS,IM,1) + KF=K(I,2) + KFA=IABS(KF) + ICOMP=IMI(JS,IM,2) + +C...Skip collapsed gluons and junctions. Reset. + IF (KFA.EQ.21.AND.K(I,1).EQ.14) GOTO 270 + IF (KFA.EQ.88) GOTO 270 + X=0D0 + IVALQ(1)=0 + IVALQ(2)=0 + ICOMQ(1)=0 + ICOMQ(2)=0 + +C...If gluon then only beam remnant, so takes all. + IF(KFA.EQ.21) THEN + X=1D0 +C...If valence quark then use parametrized valence distribution. + ELSEIF(KFA.LE.6.AND.ICOMP.EQ.0) THEN + IVALQ(1)=KF +C...If companion quark then derive from companion x. + ELSEIF(KFA.LE.6) THEN + ICOMQ(1)=ICOMP +C...If valence diquark then use two parametrized valence distributions. + ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0.AND. + & ICOMP.EQ.0) THEN + IVALQ(1)=ISIGN(KFA/1000,KF) + IVALQ(2)=ISIGN(MOD(KFA/100,10),KF) +C...If valence+sea diquark then combine valence + companion choices. + ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0.AND. + & ICOMP.LT.MSTU(5)) THEN + IF(KFA/1000.EQ.IABS(K(ICOMP,2))) THEN + IVALQ(1)=ISIGN(MOD(KFA/100,10),KF) + ELSE + IVALQ(1)=ISIGN(KFA/1000,KF) + ENDIF + ICOMQ(1)=ICOMP +C...Extra code: workaround for diquark made out of two sea +C...quarks, but where not (yet) ICOMP > MSTU(5). + DO 220 IM1=1,MINT(31) + IF(IMI(JS,IM1,2).EQ.I.AND.IMI(JS,IM1,1).NE.ICOMP) THEN + ICOMQ(2)=IMI(JS,IM1,1) + IVALQ(1)=0 + ENDIF + 220 CONTINUE +C...If sea diquark then sum of two derived from companion x. + ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0) THEN + ICOMQ(1)=MOD(ICOMP,MSTU(5)) + ICOMQ(2)=ICOMP/MSTU(5) +C...If meson or baryon then use fragmentation function. +C...Somewhat arbitrary split into old and new flavour, but OK normally. + ELSE + KFL3=MOD(KFA/10,10) + IF(MOD(KFA/1000,10).EQ.0) THEN + KFL1=MOD(KFA/100,10) + ELSE + KFL1=MOD(KFA,10000)-10*KFL3-1 + IF(MOD(KFA/1000,10).EQ.MOD(KFA/100,10).AND. + & MOD(KFA,10).EQ.2) KFL1=KFL1+2 + ENDIF + PR=P(I,5)**2+P(I,1)**2+P(I,2)**2 + CALL PYZDIS(KFL1,KFL3,PR,X) + ENDIF + + DO 260 IQ=1,2 +C...Calculation of x of valence quark: assume form (1-x)^a/sqrt(x), +C...where a=3.5 for u in proton, =2 for d in proton and =0.8 for meson. +C...In other baryons combine u and d from proton appropriately. + IF(IVALQ(IQ).NE.0) THEN + NVAL=0 + IF(KFIVAL(JS,1).EQ.IVALQ(IQ)) NVAL=NVAL+1 + IF(KFIVAL(JS,2).EQ.IVALQ(IQ)) NVAL=NVAL+1 + IF(KFIVAL(JS,3).EQ.IVALQ(IQ)) NVAL=NVAL+1 +C...Meson. + IF(KFIVAL(JS,3).EQ.0) THEN + MDU=0 +C...Baryon with three identical quarks: mix u and d forms. + ELSEIF(NVAL.EQ.3) THEN + MDU=INT(PYR(0)+5D0/3D0) +C...Baryon, one of two identical quarks: u form. + ELSEIF(NVAL.EQ.2) THEN + MDU=2 +C...Baryon with two identical quarks, but not the one picked: d form. + ELSEIF(KFIVAL(JS,1).EQ.KFIVAL(JS,2).OR.KFIVAL(JS,2).EQ. + & KFIVAL(JS,3).OR.KFIVAL(JS,1).EQ.KFIVAL(JS,3)) THEN + MDU=1 +C...Baryon with three nonidentical quarks: mix u and d forms. + ELSE + MDU=INT(PYR(0)+5D0/3D0) + ENDIF + XPOW=0.8D0 + IF(MDU.EQ.1) XPOW=3.5D0 + IF(MDU.EQ.2) XPOW=2D0 + 230 XX=PYR(0)**2 + IF((1D0-XX)**XPOW.LT.PYR(0)) GOTO 230 + X=X+XX + ENDIF + +C...Calculation of x of companion quark. + IF(ICOMQ(IQ).NE.0) THEN + XCOMP=1D-4 + DO 240 IM1=1,MINT(31) + IF(IMI(JS,IM1,1).EQ.ICOMQ(IQ)) XCOMP=XMI(JS,IM1) + 240 CONTINUE + NPOW=MAX(0,MIN(4,MSTP(87))) + 250 XX=XCOMP*(1D0/(1D0-PYR(0)*(1D0-XCOMP))-1D0) + CORR=((1D0-XCOMP-XX)/(1D0-XCOMP))**NPOW* + & (XCOMP**2+XX**2)/(XCOMP+XX)**2 + IF(CORR.LT.PYR(0)) GOTO 250 + X=X+XX + ENDIF + 260 CONTINUE + +C...Optionally enchance x of composite systems (e.g. diquarks) + IF (KFA.GT.100) X=PARP(79)*X + +C...Store x. Also calculate light cone energies of each system. + XMI(JS,IM)=X + W(JS,JS)=W(JS,JS)+X + W(JS,3-JS)=W(JS,3-JS)+(P(I,5)**2+P(I,1)**2+P(I,2)**2)/X + 270 CONTINUE + W(JS,JS)=W(JS,JS)*W(0,JS) + W(JS,3-JS)=W(JS,3-JS)/W(0,JS) + W(JS,0)=W(JS,1)*W(JS,2) + 280 CONTINUE + +C...Check W1 W2 < Wrem (can be done before rescaling, since W +C...insensitive to global rescalings of the BR x values). + IF (SQRT(W(1,0))+SQRT(W(2,0)).GT.SQRT(W(0,0)).AND.NTRYX.LE.100) + & THEN + GOTO 210 + ELSEIF (NTRYX.GT.100.AND.NTRY.LE.100) THEN + GOTO 100 + ELSEIF (NTRYX.GT.100) THEN + CALL PYERRM(1,'(PYMIRM:) No consistent (x,kT) sets found') + MINT(57)=MINT(57)+1 + MINT(51)=1 + RETURN + ENDIF + +C...Compute x rescaling factors + COMTRM=W(0,0)+SQRT(FLAM(W(0,0),W(1,0),W(2,0))) + R1=(COMTRM+W(1,0)-W(2,0))/(2D0*W(1,1)*W(0,2)) + R2=(COMTRM+W(2,0)-W(1,0))/(2D0*W(2,2)*W(0,1)) + + IF (R1.LT.0.OR.R2.LT.0) THEN + CALL PYERRM(19,'(PYMIRM:) negative rescaling factors !') + MINT(57)=MINT(57)+1 + MINT(51)=1 + ENDIF + +C...Rescale W(1,*) and W(2,*) (not really necessary, but consistent). + W(1,1)=W(1,1)*R1 + W(1,2)=W(1,2)/R1 + W(2,1)=W(2,1)/R2 + W(2,2)=W(2,2)*R2 + +C...Rescale BR x values. + DO 290 IM=MINT(31)+1,MAX(NMI(1),NMI(2)) + XMI(1,IM)=XMI(1,IM)*R1 + XMI(2,IM)=XMI(2,IM)*R2 + 290 CONTINUE + +C...Now we have a consistent set of x and kT values. +C...First set up the initiators and their daughters correctly. + DO 300 IM=1,MINT(31) + I1=IMI(1,IM,1) + I2=IMI(2,IM,1) + ST=XMI(1,IM)*XMI(2,IM)*VINT(2)+(P(I1,1)+P(I2,1))**2+ + & (P(I1,2)+P(I2,2))**2 + PT12=P(I1,1)**2+P(I1,2)**2 + PT22=P(I2,1)**2+P(I2,2)**2 +C...p_z + P(I1,3)=SQRT(FLAM(ST,PT12,PT22)/(4D0*ST)) + P(I2,3)=-P(I1,3) +C...Energies (masses should be zero at this stage) + P(I1,4)=SQRT(PT12+P(I1,3)**2) + P(I2,4)=SQRT(PT22+P(I2,3)**2) + +C...Transverse 12 system initiator velocity: + VB(1)=(P(I1,1)+P(I2,1))/SQRT(ST) + VB(2)=(P(I1,2)+P(I2,2))/SQRT(ST) +C...Boost to overall initiator system rest frame + CALL PYROBO(I1,I1,0D0,0D0,-VB(1),-VB(2),0D0) + CALL PYROBO(I2,I2,0D0,0D0,-VB(1),-VB(2),0D0) + +C...Compute phi,theta coordinates of I1 and rotate z axis. + PHI=PYANGL(P(I1,1),P(I1,2)) + THE=PYANGL(P(I1,3),SQRT(P(I1,1)**2+P(I1,2)**2)) + IMIN=IMISEP(IM-1)+1 +C...(include documentation lines if MI = 1) + IF (IM.EQ.1) IMIN=MINT(83)+5 + IMAX=IMISEP(IM) +C...Rotate entire system in phi + CALL PYROBO(IMIN,IMAX,0D0,-PHI,0D0,0D0,0D0) +C...Only rotate 12 system in theta + CALL PYROBO(I1,I1,-THE,0D0,0D0,0D0,0D0) + CALL PYROBO(I2,I2,-THE,0D0,0D0,0D0,0D0) + +C...Now boost entire system back to LAB + VB(3)=(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM)) + CALL PYROBO(IMIN,IMAX,THE,PHI,VB(1),VB(2),0D0) + CALL PYROBO(IMIN,IMAX,0D0,0D0,0D0,0D0,VB(3)) + + 300 CONTINUE + + +C...For the beam remnant partons/hadrons, we only need to set pz and E. + DO 320 JS=1,2 + DO 310 IM=MINT(31)+1,NMI(JS) + I=IMI(JS,IM,1) +C...Skip collapsed gluons and junctions. + IF (K(I,2).EQ.21.AND.K(I,1).EQ.14) GOTO 310 + IF (KFA.EQ.88) GOTO 310 + RMT2=P(I,5)**2+P(I,1)**2+P(I,2)**2 + P(I,4)=0.5D0*(XMI(JS,IM)*W(0,JS)+RMT2/(XMI(JS,IM)*W(0,JS))) + P(I,3)=0.5D0*(XMI(JS,IM)*W(0,JS)-RMT2/(XMI(JS,IM)*W(0,JS))) + IF (JS.EQ.2) P(I,3)=-P(I,3) + 310 CONTINUE + 320 CONTINUE + + +C...Documentation lines + DO 340 JS=1,2 + IN=MINT(83)+JS+2 + IO=IMI(JS,1,1) + K(IN,1)=21 + K(IN,2)=K(IO,2) + K(IN,3)=MINT(83)+JS + K(IN,4)=0 + K(IN,5)=0 + DO 330 J=1,5 + P(IN,J)=P(IO,J) + V(IN,J)=V(IO,J) + 330 CONTINUE + MCT(IN,1)=MCT(IO,1) + MCT(IN,2)=MCT(IO,2) + 340 CONTINUE + +C...Final state colour reconnections. + IF (MSTP(95).NE.1.OR.MINT(31).LE.1) GOTO 380 + +C...Number of colour tags for which a recoupling will be tried. + NTOT=NCT +C...Number of recouplings to try + MINT(34)=0 + NRECP=0 + NITER=0 + 350 NRECP=MINT(34) + NITER=NITER+1 + IITER=0 + 360 IITER=IITER+1 + IF (IITER.LE.PARP(78)*NTOT) THEN +C...Select two colour tags at random +C...NB: jj strings do not have colour tags assigned to them, +C...thus they are as yet not affected by anything done here. + JCT=PYR(0)*NCT+1 + KCT=MOD(INT(JCT+PYR(0)*NCT),NCT)+1 + IJ1=0 + IJ2=0 + IK1=0 + IK2=0 +C...Find final state partons with this (anti)colour + DO 370 I=MINT(84)+1,N + IF (K(I,1).EQ.3) THEN + IF (MCT(I,1).EQ.JCT) IJ1=I + IF (MCT(I,2).EQ.JCT) IJ2=I + IF (MCT(I,1).EQ.KCT) IK1=I + IF (MCT(I,2).EQ.KCT) IK2=I + ENDIF + 370 CONTINUE +C...Only consider recouplings not involving junctions for now. + IF (IJ1.EQ.0.OR.IJ2.EQ.0.OR.IK1.EQ.0.OR.IK2.EQ.0) GOTO 360 + + RLO=2D0*FOUR(IJ1,IJ2)*2D0*FOUR(IK1,IK2) + RLN=2D0*FOUR(IJ1,IK2)*2D0*FOUR(IK1,IJ2) + IF (RLN.LT.RLO.AND.MCT(IJ2,1).NE.KCT.AND.MCT(IK2,1).NE.JCT) THEN + MCT(IJ2,2)=KCT + MCT(IK2,2)=JCT +C...Count up number of reconnections + MINT(34)=MINT(34)+1 + ENDIF + IF (MINT(34).LE.1000) THEN + GOTO 360 + ELSE + CALL PYERRM(4,'(PYMIRM:) caught in infinite loop') + GOTO 380 + ENDIF + ENDIF + IF (NRECP.LT.MINT(34)) GOTO 350 + +C...Signal PYPREP to use /PYCTAG/ information rather than K(I,KCS). + 380 MINT(33)=1 + + RETURN + END + +C********************************************************************* + +C...PYFSCR +C...Performs colour annealing. +C...MSTP(95) : CR Type +C... = 1 : old cut-and-paste reconnections, handled in PYMIHK +C... = 2 : Type I(no gg loops); hadron-hadron only +C... = 3 : Type I(no gg loops); all beams +C... = 4 : Type II(gg loops) ; hadron-hadron only +C... = 5 : Type II(gg loops) ; all beams +C... = 6 : Type S ; hadron-hadron only +C... = 7 : Type S ; all beams +C... = 8 : Type P ; hadron-hadron only +C... = 9 : Type P ; all beams +C...Types I and II are described in Sandhoff+Skands, in hep-ph/0604120. +C...Type S is driven by starting only from free triplets, not octets. +C...Type P is also driven by free triplets, but the reconnect probability +C...is computed from the string density per unit rapidity, where the axis +C...with respect to which the rapidity is computed is the Thrust axis of the +C...event. +C...A string piece remains unchanged with probability +C... PKEEP = (1-PARP(78))**N +C...This scaling corresponds to each string piece having to go through +C...N other ones, each with probability PARP(78) for reconnection. +C...For types I, II, and S, N is chosen simply as the number of multiple +C...interactions, for a rough scaling with the general level of activity. +C...For type P, N is chosen to be the number of string pieces in a given +C...interval of rapidity (minus one, since the string doesn't reconnect +C...with itself), and the reconnect probability is interpreted as the +C...probability per unit rapidity. +C...It also also possible to apply a dampening factor to the CR strength, +C...using PARP(77), which will cause reconnections among high-pT string +C...pieces to be suppressed. + + SUBROUTINE PYFSCR(IP) +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYINT1/MINT(400),VINT(400) +C...The common block of colour tags. + COMMON/PYCTAG/NCT,MCT(4000,2) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/,/PYCTAG/, + &/PYPARS/ +C...MCN: Temporary storage of new colour tags + INTEGER MCN(4000,2) +C...Arrays for storing color strings + PARAMETER (NBINY=100) + INTEGER ICR(4000),MSCR(4000) + INTEGER IOPT(4000), NSTRY(NBINY) + DOUBLE PRECISION RLOPTC(4000) + +C...Function to give four-product. + FOUR(I,J)=P(I,4)*P(J,4) + & -P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3) + +C...Check valid range of MSTP(95), local copy + IF (MSTP(95).LE.1.OR.MSTP(95).GE.10) RETURN + MSTP95=MOD(MSTP(95),10) +C...Set whether CR allowed inside resonance systems or not +C...(not implemented yet) +C MRESCR=1 +C IF (MSTP(95).GE.10) MRESCR=0 + +C...Check whether colour tags already defined + IF (MINT(33).EQ.0) THEN +C...Erase any existing colour tags for this event + DO 100 I=1,N + MCT(I,1)=0 + MCT(I,2)=0 + 100 CONTINUE +C...Create colour tags for this event + DO 120 I=1,N + IF (K(I,1).EQ.3) THEN + DO 110 KCS=4,5 + KCSIN=KCS + IF (MCT(I,KCSIN-3).EQ.0) THEN + CALL PYCTTR(I,KCSIN,I) + ENDIF + 110 CONTINUE + ENDIF + 120 CONTINUE +C...Instruct PYPREP to use colour tags + MINT(33)=1 + ENDIF + +C...For MSTP(95) even, only apply to hadron-hadron + KA1=IABS(MINT(11)) + KA2=IABS(MINT(12)) + IF (MOD(MSTP(95),2).EQ.0.AND.(KA1.LT.100.OR.KA2.LT.100)) GOTO 9999 + +C...Initialize new tag array (but do not delete old yet) + LCT=NCT + DO 130 I=MAX(1,IP),N + MCN(I,1)=0 + MCN(I,2)=0 + 130 CONTINUE + +C...For Paquis type, determine thrust axis (default along Z axis) + TX=0D0 + TY=0D0 + TZ=1D0 + IF (MSTP95.GE.8) THEN + CALL PYTHRU(THRDUM,OBLDUM) + TX = P(N+1,1) + TY = P(N+1,2) + TZ = P(N+1,3) + ENDIF + +C...For each final-state dipole, check whether string should be +C...preserved. + NCR=0 + IA=0 + IC=0 + RAPMAX=0.0 + + ICTMIN=NCT + DO 150 ICT=1,NCT + IA=0 + IC=0 + DO 140 I=MAX(1,IP),N + IF (K(I,1).EQ.3.AND.MCT(I,1).EQ.ICT) IC=I + IF (K(I,1).EQ.3.AND.MCT(I,2).EQ.ICT) IA=I + 140 CONTINUE + IF (IC.NE.0.AND.IA.NE.0) THEN +C...Save smallest NCT value so far + ICTMIN = MIN(ICTMIN,ICT) +C...For Paquis algorithm, just store all string pieces for now + IF (MSTP95.GE.8) THEN +C... Add coloured parton + NCR=NCR+1 + ICR(NCR)=IC + MSCR(NCR)=1 + IOPT(NCR)=0 +C... Store rapidity (along Thrust axis) in RLOPT for the time being +C... Add pion mass headroom to energy for this calculation + EET = P(IC,4)*SQRT(1D0+(0.135D0/P(IC,4))**2) + PZT = P(IC,1)*TX+P(IC,2)*TY+P(IC,3)*TZ + RLOPTC(NCR)=LOG((EET+PZT)/(EET-PZT)) +C... Add anti-coloured parton + NCR = NCR+1 + ICR(NCR) = IA + MSCR(NCR) = 2 + IOPT(NCR) = 0 +C... Store rapidity (along Thrust axis) in RLOPT for the time being + EET = P(IA,4)*SQRT(1D0+(0.135D0/P(IA,4))**2) + PZT = P(IA,1)*TX+P(IA,2)*TY+P(IA,3)*TZ + RLOPTC(NCR)=LOG((EET+PZT)/(EET-PZT)) +C... Keep track of largest endpoint "rapidity" + RAPMAX = MAX(RAPMAX,ABS(RLOPTC(NCR))) + RAPMAX = MAX(RAPMAX,ABS(RLOPTC(NCR-1))) + ELSE + CRMODF=1D0 +C... Opt: suppress breakup of high-boost string pieces (i.e., let them escape) +C... (so far ignores the possibility that the whole "muck" may be moving.) + IF (PARP(77).GT.0D0) THEN + PT2STR=(P(IA,1)+P(IC,1))**2+(P(IA,2)+P(IC,2))**2 +C... For lepton-lepton, use actual p2/m2, otherwise approximate p2 ~ 3/2 pT2 + IF (KA1.LT.100.AND.KA2.LT.100) THEN + P2STR = PT2STR + (P(IA,3)+P(IC,3))**2 + ELSE + P2STR = 3D0/2D0 * PT2STR + ENDIF + RM2STR=(P(IA,4)+P(IC,4))**2-(P(IA,3)+P(IC,3))**2-PT2STR + RM2STR=MAX(RM2STR,PMAS(PYCOMP(111),1)**2) +C... Estimate number of particles ~ log(M2), cut off at 1. + RLOGM2=MAX(1D0,LOG(RM2STR)) + P2AVG=P2STR/RLOGM2 +C... Supress reconnection probability by 1/(1+P77*P2AVG) + CRMODF=1D0/(1D0+PARP(77)**2*P2AVG) + ENDIF + PKEEP=(1D0-PARP(78)*CRMODF)**MINT(31) + IF (PYR(0).LE.PKEEP) THEN + LCT=LCT+1 + MCN(IC,1)=LCT + MCN(IA,2)=LCT + ELSE +C... Add coloured parton + NCR=NCR+1 + ICR(NCR)=IC + MSCR(NCR)=1 + IOPT(NCR)=0 + RLOPTC(NCR)=1D19 +C... Add anti-coloured parton + NCR=NCR+1 + ICR(NCR)=IA + MSCR(NCR)=2 + IOPT(NCR)=0 + RLOPTC(NCR)=1D19 + ENDIF + ENDIF + ENDIF + 150 CONTINUE + +C...PAQUIS TYPE + IF (MSTP95.GE.8) THEN +C... For Paquis type, make "histogram" of string densities along thrust axis + RAPMIN = -RAPMAX + DRAP = 2*RAPMAX/(1D0*NBINY) +C... Explicitly zero histogram bin content + DO 147 IBINY=1,NBINY + NSTRY(IBINY)=0 + 147 CONTINUE + DO 152 ISTR=1,NCR-1,2 + IC = ICR(ISTR) + IA = ICR(ISTR+1) + Y1 = MIN(RLOPTC(ISTR),RLOPTC(ISTR+1)) + Y2 = MAX(RLOPTC(ISTR),RLOPTC(ISTR+1)) + DO 153 IBINY=1,NBINY + YBINLO = RAPMIN + (IBINY-1)*DRAP +C... If bin inside string piece, add 1 in this bin +C... (Strictly speaking: if it starts before midpoint and ends after midpoint) + IF (Y1.LE.YBINLO+0.5*DRAP.AND.Y2.GE.YBINLO+0.5*DRAP) + & NSTRY(IBINY) = NSTRY(IBINY) + 1 + 153 CONTINUE + 152 CONTINUE +C... Loop over pieces to find individual reconnect probability + DO 167 IS=1,NCR-1,2 + DNSUM = 0D0 + DNAVG = 0D0 +C...Beginning at Y = RAPMIN = -RAPMAX, ending at Y = RAPMAX + RBINLO = (MIN(RLOPTC(IS),RLOPTC(IS+1))-RAPMIN)/DRAP + 0.5 + RBINHI = (MAX(RLOPTC(IS),RLOPTC(IS+1))-RAPMIN)/DRAP + 0.5 +C...Make sure integer bin numbers lie inside proper range + IBINLO = MAX(1,MIN(NBINY,NINT(RBINLO))) + IBINHI = MAX(1,MIN(NBINY,NINT(RBINHI))) +C...Size of rapidity bins (is < DRAP if piece smaller than one bin) +C...(also smaller than DRAP if a one-unit wide piece is stretched +C... over 2 bins, thus making the computation more accurate) + DRAPAV = (RBINHI-RBINLO)/(IBINHI-IBINLO+1)*DRAP +C... Decide whether to suppress reconnections in high-pT string pieces + CRMODF = 1D0 + IF (PARP(77).GT.0D0) THEN +C... Total string piece energy, momentum squared, and components + EES = P(ICR(IS),4) + P(ICR(IS+1),4) + PPS2 = (P(ICR(IS),1)+ P(ICR(IS+1),1))**2 + & + (P(ICR(IS),2)+ P(ICR(IS+1),2))**2 + & + (P(ICR(IS),3)+ P(ICR(IS+1),3))**2 + PZTS = P(ICR(IS),1)*TX+P(ICR(IS),2)*TY+P(ICR(IS),3)*TZ + & + P(ICR(IS+1),1)*TX+P(ICR(IS+1),2)*TY+P(ICR(IS+1),3)*TZ + PTTS = SQRT(PPS2 - PZTS**2) +C... Mass of string piece in units of mpi (at least 1) + RMPI2 = 0.135D0 + RM2STR = MAX(RMPI2,EES**2 - PPS2) +C... Estimate number of pions ~ log(M2) (at least 1) + RNPI = LOG(RM2STR/RMPI2)+1D0 + PT2AVG = (PTTS / RNPI)**2 +C... Supress reconnection probability by 1/(1+P77*P2AVG) + CRMODF=1D0/(1D0+PARP(77)**2*PT2AVG) + ENDIF + PKEEP = 1.0 + DO 178 IBINY=IBINLO,IBINHI +C DNSUM = DNSUM + 1D0 + DNOVL = MAX(0,NSTRY(IBINY)-1) + PKEEP = PKEEP * (1D0-CRMODF*PARP(78))**(DRAPAV*DNOVL) +C DNAVG = DNAVG + MAX(1,NSTRY(IBINY)) + 178 CONTINUE +C DNAVG = DNAVG / DNSUM +C... If keeping string piece, save + IF (PYR(0).LE.PKEEP) THEN + LCT = LCT+1 + MCN(ICR(IS),1)=LCT + MCN(ICR(IS+1),2)=LCT + ENDIF + 167 CONTINUE + ENDIF + +C...Skip if there is only one possibility + IF (NCR.LE.2) THEN + GOTO 9999 + ENDIF + +C...Reorder, so ordered in I (in order to correspond to old algorithm) + NLOOP=0 + 151 NLOOP=NLOOP+1 + MORD=1 + DO 155 IC1=1,NCR-1 + I1=ICR(IC1) + I2=ICR(IC1+1) + IF (I1.GT.I2) THEN + IT=I1 + MST=MSCR(IC1) + ICR(IC1)=I2 + MSCR(IC1)=MSCR(IC1+1) + ICR(IC1+1)=IT + MSCR(IC1+1)=MST + MORD=0 + ENDIF + 155 CONTINUE +C...Max do 1000 reordering loops + IF (MORD.EQ.0.AND.NLOOP.LE.1000) GOTO 151 + +C...PS: 03 May 2010 +C...For Seattle and Paquis types, check if there is a dangling tag +C...Needed for special case when entire reconnected state was one or +C...more gluon loops in original topology in which case these CR +C...algorithms need to be told they shouldn't look for a dangling tag. + M3FREE=0 + IF (MSTP95.GE.6.AND.MSTP95.LE.9) THEN + DO 157 IC1=1,NCR + I1=ICR(IC1) +C...Color charge + MCI=KCHG(PYCOMP(K(I1,2)),2)*ISIGN(1,K(I1,2)) + IF (MCI.EQ.1.AND.MCN(I1,1).EQ.0) M3FREE=1 + IF (MCI.EQ.-1.AND.MCN(I1,2).EQ.0) M3FREE=1 + IF (MCI.EQ.2) THEN + IF (MCN(I1,1).NE.0.AND.MCN(I1,2).EQ.0) M3FREE=1 + IF (MCN(I1,2).NE.0.AND.MCN(I1,1).EQ.0) M3FREE=1 + ENDIF + 157 CONTINUE + ENDIF + +C...Loop over CR partons +C...(Ignore junctions for now.) + NLOOP=0 + 160 NLOOP=NLOOP+1 + RLMAX=0D0 + ICRMAX=0 +C...Loop over coloured partons + DO 230 IC1=1,NCR +C...Retrieve parton Event Record index and Colour Side + I=ICR(IC1) + MSI=MSCR(IC1) +C...Skip already connected partons + IF (MCN(I,MSI).NE.0) GOTO 230 +C...Shorthand for colour charge + MCI=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2)) +C...For Seattle algorithm, only start from partons with one dangling +C...colour tag (unless there aren't any, cf. M3FREE above.) + IF (MSTP(95).GE.6.AND.MSTP(95).LE.9) THEN + IF (MCI.EQ.2.AND.MCN(I,1).EQ.0.AND.MCN(I,2).EQ.0 + & .AND.M3FREE.EQ.1) THEN + GOTO 230 + ENDIF + ENDIF +C...Retrieve saved optimal partner + IO=IOPT(IC1) + IF (IO.NE.0) THEN +C...Reject saved optimal partner if latter is now connected +C...(Also reject if using model S1, since saved partner may +C...now give rise to gg loop.) + IF (MCN(IO,3-MSI).NE.0.OR.MSTP(95).LE.3) THEN + IOPT(IC1)=0 + RLOPTC(IC1)=1D19 + ENDIF + ENDIF + RLOPT=RLOPTC(IC1) +C...Search for new optimal partner if necessary + IF (IOPT(IC1).EQ.0) THEN + MBROPT=0 + MGGOPT=0 + RLOPT=1D19 +C...Loop over partons you can connect to + DO 210 IC2=1,NCR + J=ICR(IC2) + MSJ=MSCR(IC2) +C...Skip if already connected + IF (MCN(J,MSJ).NE.0) GOTO 210 +C...Skip if this not colour-anticolour pair + IF (MSI.EQ.MSJ) GOTO 210 +C...And do not let gluons connect to themselves + IF (I.EQ.J) GOTO 210 +C...Suppress direct connections between partons in same Beam Remnant + MBRSTR=0 + IF (K(I,3).LE.2.AND.K(I,3).GE.1.AND.K(I,3).EQ.K(J,3)) + & MBRSTR=1 +C...Shorthand for colour charge + MCJ=KCHG(PYCOMP(K(J,2)),2)*ISIGN(1,K(J,2)) +C...Check for gluon loops + MGGSTR=0 + IF (MCJ.EQ.2.AND.MCI.EQ.2) THEN + IF (MCN(I,2).EQ.MCN(J,1).AND.MSTP(95).LE.3.AND. + & MCN(I,2).NE.0) MGGSTR=1 + ENDIF +C...Save connection with smallest lambda measure + RL=FOUR(I,J) +C...If best so far was a BR string and this is not, also save. +C...If best so far was a gg string and this is not, also save. +C...NB: this is not fool-proof. If the algorithm finds a BR or gg +C...string with a small Lambda measure as the last step, this connection +C...will be saved regardless of whether other possibilities existed. +C...I.e., there should really be a check whether another possibility has +C...already been found, but since these models are now actively in use +C...and uncertainties are anyway large, the algorithm is left as it is. +C...(correction --> Pythia 8 ?) + IF (RL.LT.RLOPT.OR.(RL.EQ.RLOPT.AND.PYR(0).LE.0.5D0) + & .OR.(MBROPT.EQ.1.AND.MBRSTR.EQ.0) + & .OR.(MGGOPT.EQ.1.AND.MGGSTR.EQ.0)) THEN +C...Paquis type: fix problem above + MPAQ = 0 + IF (MSTP95.GE.8.AND.RLOPT.LE.1D18) THEN + IF (MBRSTR.EQ.1.AND.MBROPT.EQ.0) MPAQ=1 + IF (MGGSTR.EQ.1.AND.MGGOPT.EQ.0) MPAQ=1 + ENDIF + IF (MPAQ.EQ.0) THEN + RLOPT=RL + RLOPTC(IC1)=RLOPT + IOPT(IC1)=J + MBROPT=MBRSTR + MGGOPT=MGGSTR + ENDIF + ENDIF + 210 CONTINUE + ENDIF + IF (IOPT(IC1).NE.0) THEN +C...Save pair with largest RLOPT so far + IF (RLOPT.GE.RLMAX) THEN + ICRMAX=IC1 + RLMAX=RLOPT + ENDIF + ENDIF + 230 CONTINUE +C...Save and iterate + ICMAX=0 + IF (ICRMAX.GT.0) THEN + LCT=LCT+1 + ILMAX=ICR(ICRMAX) + JLMAX=IOPT(ICRMAX) + ICMAX=MSCR(ICRMAX) + JCMAX=3-ICMAX + MCN(ILMAX,ICMAX)=LCT + MCN(JLMAX,JCMAX)=LCT + IF (NLOOP.LE.2*(N-IP)) THEN + GOTO 160 + ELSE + CALL PYERRM(31,' PYFSCR: infinite loop in color annealing') + CALL PYSTOP(11) + ENDIF + ELSE +C...Save and exit. First check for leftover gluon(s) + DO 260 I=MAX(1,IP),N +C...Check colour charge + MCI=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2)) + IF (K(I,1).NE.3.OR.MCI.NE.2) GOTO 260 + IF(MCN(I,1).EQ.0.AND.MCN(I,2).EQ.0) THEN +C...Decide where to put left-over gluon (minimal insertion) + ICMAX=0 + RLMAX=1D19 +C...PS: Bug fix 30 Apr 2010: try all lines, not just reconnected ones + DO 250 KCT=ICTMIN,LCT + IC=0 + IA=0 + DO 240 IT=MAX(1,IP),N + IF (IT.EQ.I.OR.K(IT,1).NE.3) GOTO 240 + IF (MCN(IT,1).EQ.KCT) IC=IT + IF (MCN(IT,2).EQ.KCT) IA=IT + 240 CONTINUE +C...Skip if this color tag no longer present in event record + IF (IC.EQ.0.OR.IA.EQ.0) GOTO 250 + RL=FOUR(IC,I)*FOUR(IA,I) + IF (RL.LT.RLMAX) THEN + RLMAX=RL + ICMAX=IC + IAMAX=IA + ENDIF + 250 CONTINUE + LCT=LCT+1 + MCN(I,1)=MCN(ICMAX,1) + MCN(I,2)=LCT + MCN(ICMAX,1)=LCT + ENDIF + 260 CONTINUE +C...Here we need to loop over entire event. + DO 270 IZ=MAX(1,IP),N +C...Do not erase parton shower colour history + IF (K(IZ,1).NE.3) GOTO 270 +C...Check colour charge + MCI=KCHG(PYCOMP(K(IZ,2)),2)*ISIGN(1,K(IZ,2)) + IF (MCI.EQ.0) GOTO 270 + IF (MCN(IZ,1).NE.0) MCT(IZ,1)=MCN(IZ,1) + IF (MCN(IZ,2).NE.0) MCT(IZ,2)=MCN(IZ,2) + 270 CONTINUE + ENDIF + + 9999 RETURN + END + +C********************************************************************* + +C...PYDIFF +C...Handles diffractive and elastic scattering. + + SUBROUTINE PYDIFF + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/ + +C...Reset K, P and V vectors. Store incoming particles. + DO 110 JT=1,MSTP(126)+10 + I=MINT(83)+JT + DO 100 J=1,5 + K(I,J)=0 + P(I,J)=0D0 + V(I,J)=0D0 + 100 CONTINUE + 110 CONTINUE + N=MINT(84) + MINT(3)=0 + MINT(21)=0 + MINT(22)=0 + MINT(23)=0 + MINT(24)=0 + MINT(4)=4 + DO 130 JT=1,2 + I=MINT(83)+JT + K(I,1)=21 + K(I,2)=MINT(10+JT) + DO 120 J=1,5 + P(I,J)=VINT(285+5*JT+J) + 120 CONTINUE + 130 CONTINUE + MINT(6)=2 + +C...Subprocess; kinematics. + SQLAM=(VINT(2)-VINT(63)-VINT(64))**2-4D0*VINT(63)*VINT(64) + PZ=SQRT(SQLAM)/(2D0*VINT(1)) + DO 200 JT=1,2 + I=MINT(83)+JT + PE=(VINT(2)+VINT(62+JT)-VINT(65-JT))/(2D0*VINT(1)) + KFH=MINT(102+JT) + +C...Elastically scattered particle. (Except elastic GVMD states.) + IF(MINT(16+JT).LE.0.AND.(MINT(10+JT).NE.22.OR. + & MINT(106+JT).NE.3)) THEN + N=N+1 + K(N,1)=1 + K(N,2)=KFH + K(N,3)=I+2 + P(N,3)=PZ*(-1)**(JT+1) + P(N,4)=PE + P(N,5)=SQRT(VINT(62+JT)) + +C...Decay rho from elastic scattering of gamma with sin**2(theta) +C...distribution of decay products (in rho rest frame). + IF(KFH.EQ.113.AND.MINT(10+JT).EQ.22.AND.MSTP(102).EQ.1) THEN + NSAV=N + DBETAZ=P(N,3)/SQRT(P(N,3)**2+P(N,5)**2) + P(N,3)=0D0 + P(N,4)=P(N,5) + CALL PYDECY(NSAV) + IF(N.EQ.NSAV+2.AND.IABS(K(NSAV+1,2)).EQ.211) THEN + PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2)) + CALL PYROBO(NSAV+1,NSAV+2,0D0,-PHI,0D0,0D0,0D0) + THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1)) + CALL PYROBO(NSAV+1,NSAV+2,-THE,0D0,0D0,0D0,0D0) + 140 CTHE=2D0*PYR(0)-1D0 + IF(1D0-CTHE**2.LT.PYR(0)) GOTO 140 + CALL PYROBO(NSAV+1,NSAV+2,ACOS(CTHE),PHI,0D0,0D0,0D0) + ENDIF + CALL PYROBO(NSAV,NSAV+2,0D0,0D0,0D0,0D0,DBETAZ) + ENDIF + +C...Diffracted particle: low-mass system to two particles. + ELSEIF(VINT(62+JT).LT.(VINT(66+JT)+PARP(103))**2) THEN + N=N+2 + K(N-1,1)=1 + K(N,1)=1 + K(N-1,3)=I+2 + K(N,3)=I+2 + PMMAS=SQRT(VINT(62+JT)) + NTRY=0 + 150 NTRY=NTRY+1 + IF(NTRY.LT.20) THEN + MINT(105)=MINT(102+JT) + MINT(109)=MINT(106+JT) + CALL PYSPLI(KFH,21,KFL1,KFL2) + CALL PYKFDI(KFL1,0,KFL3,KF1) + IF(KF1.EQ.0) GOTO 150 + CALL PYKFDI(KFL2,-KFL3,KFLDUM,KF2) + IF(KF2.EQ.0) GOTO 150 + ELSE + KF1=KFH + KF2=111 + ENDIF + PM1=PYMASS(KF1) + PM2=PYMASS(KF2) + IF(PM1+PM2+PARJ(64).GT.PMMAS) GOTO 150 + K(N-1,2)=KF1 + K(N,2)=KF2 + P(N-1,5)=PM1 + P(N,5)=PM2 + PZP=SQRT(MAX(0D0,(PMMAS**2-PM1**2-PM2**2)**2- + & 4D0*PM1**2*PM2**2))/(2D0*PMMAS) + P(N-1,3)=PZP + P(N,3)=-PZP + P(N-1,4)=SQRT(PM1**2+PZP**2) + P(N,4)=SQRT(PM2**2+PZP**2) + CALL PYROBO(N-1,N,ACOS(2D0*PYR(0)-1D0),PARU(2)*PYR(0), + & 0D0,0D0,0D0) + DBETAZ=PZ*(-1)**(JT+1)/SQRT(PZ**2+PMMAS**2) + CALL PYROBO(N-1,N,0D0,0D0,0D0,0D0,DBETAZ) + +C...Diffracted particle: valence quark kicked out. + ELSEIF(MSTP(101).EQ.1.OR.(MSTP(101).EQ.3.AND.PYR(0).LT. + & PARP(101))) THEN + N=N+2 + K(N-1,1)=2 + K(N,1)=1 + K(N-1,3)=I+2 + K(N,3)=I+2 + MINT(105)=MINT(102+JT) + MINT(109)=MINT(106+JT) + CALL PYSPLI(KFH,21,K(N,2),K(N-1,2)) + P(N-1,5)=PYMASS(K(N-1,2)) + P(N,5)=PYMASS(K(N,2)) + SQLAM=(VINT(62+JT)-P(N-1,5)**2-P(N,5)**2)**2- + & 4D0*P(N-1,5)**2*P(N,5)**2 + P(N-1,3)=(PE*SQRT(SQLAM)+PZ*(VINT(62+JT)+P(N-1,5)**2- + & P(N,5)**2))/(2D0*VINT(62+JT))*(-1)**(JT+1) + P(N-1,4)=SQRT(P(N-1,3)**2+P(N-1,5)**2) + P(N,3)=PZ*(-1)**(JT+1)-P(N-1,3) + P(N,4)=SQRT(P(N,3)**2+P(N,5)**2) + +C...Diffracted particle: gluon kicked out. + ELSE + N=N+3 + K(N-2,1)=2 + K(N-1,1)=2 + K(N,1)=1 + K(N-2,3)=I+2 + K(N-1,3)=I+2 + K(N,3)=I+2 + MINT(105)=MINT(102+JT) + MINT(109)=MINT(106+JT) + CALL PYSPLI(KFH,21,K(N,2),K(N-2,2)) + K(N-1,2)=21 + P(N-2,5)=PYMASS(K(N-2,2)) + P(N-1,5)=0D0 + P(N,5)=PYMASS(K(N,2)) +C...Energy distribution for particle into two jets. + 160 IMB=1 + IF(MOD(KFH/1000,10).NE.0) IMB=2 + CHIK=PARP(92+2*IMB) + IF(MSTP(92).LE.1) THEN + IF(IMB.EQ.1) CHI=PYR(0) + IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0)) + ELSEIF(MSTP(92).EQ.2) THEN + CHI=1D0-PYR(0)**(1D0/(1D0+CHIK)) + ELSEIF(MSTP(92).EQ.3) THEN + CUT=2D0*0.3D0/VINT(1) + 170 CHI=PYR(0)**2 + IF((CHI**2/(CHI**2+CUT**2))**0.25D0*(1D0-CHI)**CHIK.LT. + & PYR(0)) GOTO 170 + ELSEIF(MSTP(92).EQ.4) THEN + CUT=2D0*0.3D0/VINT(1) + CUTR=(1D0+SQRT(1D0+CUT**2))/CUT + 180 CHIR=CUT*CUTR**PYR(0) + CHI=(CHIR**2-CUT**2)/(2D0*CHIR) + IF((1D0-CHI)**CHIK.LT.PYR(0)) GOTO 180 + ELSE + CUT=2D0*0.3D0/VINT(1) + CUTA=CUT**(1D0-PARP(98)) + CUTB=(1D0+CUT)**(1D0-PARP(98)) + 190 CHI=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98))) + IF(((CHI+CUT)**2/(2D0*(CHI**2+CUT**2)))** + & (0.5D0*PARP(98))*(1D0-CHI)**CHIK.LT.PYR(0)) GOTO 190 + ENDIF + IF(CHI.LT.P(N,5)**2/VINT(62+JT).OR.CHI.GT.1D0-P(N-2,5)**2/ + & VINT(62+JT)) GOTO 160 + SQM=P(N-2,5)**2/(1D0-CHI)+P(N,5)**2/CHI + PZI=(PE*(VINT(62+JT)-SQM)+PZ*(VINT(62+JT)+SQM))/ + & (2D0*VINT(62+JT)) + PEI=SQRT(PZI**2+SQM) + PQQP=(1D0-CHI)*(PEI+PZI) + P(N-2,3)=0.5D0*(PQQP-P(N-2,5)**2/PQQP)*(-1)**(JT+1) + P(N-2,4)=SQRT(P(N-2,3)**2+P(N-2,5)**2) + P(N-1,4)=0.5D0*(VINT(62+JT)-SQM)/(PEI+PZI) + P(N-1,3)=P(N-1,4)*(-1)**JT + P(N,3)=PZI*(-1)**(JT+1)-P(N-2,3) + P(N,4)=SQRT(P(N,3)**2+P(N,5)**2) + ENDIF + +C...Documentation lines. + K(I+2,1)=21 + IF(MINT(16+JT).EQ.0) K(I+2,2)=KFH + IF(MINT(16+JT).NE.0.OR.(MINT(10+JT).EQ.22.AND. + & MINT(106+JT).EQ.3)) K(I+2,2)=ISIGN(9900000,KFH)+10*(KFH/10) + K(I+2,3)=I + P(I+2,3)=PZ*(-1)**(JT+1) + P(I+2,4)=PE + P(I+2,5)=SQRT(VINT(62+JT)) + 200 CONTINUE + +C...Rotate outgoing partons/particles using cos(theta). + IF(VINT(23).LT.0.9D0) THEN + CALL PYROBO(MINT(83)+3,N,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0) + ELSE + CALL PYROBO(MINT(83)+3,N,ASIN(VINT(59)),VINT(24),0D0,0D0,0D0) + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYDISG +C...Set up a DIS process as gamma* + f -> f, with beam remnant +C...and showering added consecutively. Photon flux by the PYGAGA +C...routine (if at all). + + SUBROUTINE PYDISG + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/ +C...Local arrays. + DIMENSION PMS(4) + +C...Choice of subprocess, number of documentation lines + IDOC=7 + MINT(3)=IDOC-6 + MINT(4)=IDOC + IPU1=MINT(84)+1 + IPU2=MINT(84)+2 + IPU3=MINT(84)+3 + ISIDE=1 + IF(MINT(107).EQ.4) ISIDE=2 + +C...Reset K, P and V vectors. Store incoming particles + DO 110 JT=1,MSTP(126)+20 + I=MINT(83)+JT + DO 100 J=1,5 + K(I,J)=0 + P(I,J)=0D0 + V(I,J)=0D0 + 100 CONTINUE + 110 CONTINUE + DO 130 JT=1,2 + I=MINT(83)+JT + K(I,1)=21 + K(I,2)=MINT(10+JT) + DO 120 J=1,5 + P(I,J)=VINT(285+5*JT+J) + 120 CONTINUE + 130 CONTINUE + MINT(6)=2 + +C...Store incoming partons in hadronic CM-frame + DO 140 JT=1,2 + I=MINT(84)+JT + K(I,1)=14 + K(I,2)=MINT(14+JT) + K(I,3)=MINT(83)+2+JT + 140 CONTINUE + IF(MINT(15).EQ.22) THEN + P(MINT(84)+1,3)=0.5D0*(VINT(1)+VINT(307)/VINT(1)) + P(MINT(84)+1,4)=0.5D0*(VINT(1)-VINT(307)/VINT(1)) + P(MINT(84)+1,5)=-SQRT(VINT(307)) + P(MINT(84)+2,3)=-0.5D0*VINT(307)/VINT(1) + P(MINT(84)+2,4)=0.5D0*VINT(307)/VINT(1) + KFRES=MINT(16) + ISIDE=2 + ELSE + P(MINT(84)+1,3)=0.5D0*VINT(308)/VINT(1) + P(MINT(84)+1,4)=0.5D0*VINT(308)/VINT(1) + P(MINT(84)+2,3)=-0.5D0*(VINT(1)+VINT(308)/VINT(1)) + P(MINT(84)+2,4)=0.5D0*(VINT(1)-VINT(308)/VINT(1)) + P(MINT(84)+1,5)=-SQRT(VINT(308)) + KFRES=MINT(15) + ISIDE=1 + ENDIF + SIDESG=(-1D0)**(ISIDE-1) + +C...Copy incoming partons to documentation lines. + DO 170 JT=1,2 + I1=MINT(83)+4+JT + I2=MINT(84)+JT + K(I1,1)=21 + K(I1,2)=K(I2,2) + K(I1,3)=I1-2 + DO 150 J=1,5 + P(I1,J)=P(I2,J) + 150 CONTINUE + +C...Second copy for partons before ISR shower, since no such. + I1=MINT(83)+2+JT + K(I1,1)=21 + K(I1,2)=K(I2,2) + K(I1,3)=I1-2 + DO 160 J=1,5 + P(I1,J)=P(I2,J) + 160 CONTINUE + 170 CONTINUE + +C...Define initial partons. + NTRY=0 + 180 NTRY=NTRY+1 + IF(NTRY.GT.100) THEN + MINT(51)=1 + RETURN + ENDIF + +C...Scattered quark in hadronic CM frame. + I=MINT(83)+7 + K(IPU3,1)=3 + K(IPU3,2)=KFRES + K(IPU3,3)=I + P(IPU3,5)=PYMASS(KFRES) + P(IPU3,3)=P(IPU1,3)+P(IPU2,3) + P(IPU3,4)=P(IPU1,4)+P(IPU2,4) + P(IPU3,5)=0D0 + K(I,1)=21 + K(I,2)=KFRES + K(I,3)=MINT(83)+4+ISIDE + P(I,3)=P(IPU3,3) + P(I,4)=P(IPU3,4) + P(I,5)=P(IPU3,5) + N=IPU3 + MINT(21)=KFRES + MINT(22)=0 + +C...No primordial kT, or chosen according to truncated Gaussian or +C...exponential, or (for photon) predetermined or power law. + 190 IF(MINT(40+ISIDE).EQ.2.AND.MINT(10+ISIDE).NE.22) THEN + IF(MSTP(91).LE.0) THEN + PT=0D0 + ELSEIF(MSTP(91).EQ.1) THEN + PT=PARP(91)*SQRT(-LOG(PYR(0))) + ELSE + RPT1=PYR(0) + RPT2=PYR(0) + PT=-PARP(92)*LOG(RPT1*RPT2) + ENDIF + IF(PT.GT.PARP(93)) GOTO 190 + ELSEIF(MINT(106+ISIDE).EQ.3) THEN + PTA=SQRT(VINT(282+ISIDE)) + PTB=0D0 + IF(MSTP(66).EQ.5.AND.MSTP(93).EQ.1) THEN + PTB=PARP(99)*SQRT(-LOG(PYR(0))) + ELSEIF(MSTP(66).EQ.5.AND.MSTP(93).EQ.2) THEN + RPT1=PYR(0) + RPT2=PYR(0) + PTB=-PARP(99)*LOG(RPT1*RPT2) + ENDIF + IF(PTB.GT.PARP(100)) GOTO 190 + PT=SQRT(PTA**2+PTB**2+2D0*PTA*PTB*COS(PARU(2)*PYR(0))) + IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10) + ELSEIF(IABS(MINT(14+ISIDE)).LE.8.OR.MINT(14+ISIDE).EQ.21) THEN + IF(MSTP(93).LE.0) THEN + PT=0D0 + ELSEIF(MSTP(93).EQ.1) THEN + PT=PARP(99)*SQRT(-LOG(PYR(0))) + ELSEIF(MSTP(93).EQ.2) THEN + RPT1=PYR(0) + RPT2=PYR(0) + PT=-PARP(99)*LOG(RPT1*RPT2) + ELSEIF(MSTP(93).EQ.3) THEN + HA=PARP(99)**2 + HB=PARP(100)**2 + PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA)) + ELSE + HA=PARP(99)**2 + HB=PARP(100)**2 + IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2) + PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA)) + ENDIF + IF(PT.GT.PARP(100)) GOTO 190 + ELSE + PT=0D0 + ENDIF + VINT(156+ISIDE)=PT + PHI=PARU(2)*PYR(0) + P(IPU3,1)=PT*COS(PHI) + P(IPU3,2)=PT*SIN(PHI) + P(IPU3,4)=SQRT(P(IPU3,5)**2+PT**2+P(IPU3,3)**2) + PMS(3-ISIDE)=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2 + PCP=P(IPU3,4)+ABS(P(IPU3,3)) + +C...Find one or two beam remnants. + MINT(105)=MINT(102+ISIDE) + MINT(109)=MINT(106+ISIDE) + CALL PYSPLI(MINT(10+ISIDE),MINT(12+ISIDE),KFLCH,KFLSP) + IF(MINT(51).NE.0) THEN + MINT(51)=0 + GOTO 180 + ENDIF + +C...Store first remnant parton, with colour info and kinematics. + I=N+1 + K(I,1)=1 + K(I,2)=KFLSP + K(I,3)=MINT(83)+ISIDE + P(I,5)=PYMASS(K(I,2)) + KCOL=KCHG(PYCOMP(KFLSP),2) + IF(KCOL.NE.0) THEN + K(I,1)=3 + KFLS=(3-KCOL*ISIGN(1,KFLSP))/2 + K(I,KFLS+3)=MSTU(5)*IPU3 + K(IPU3,6-KFLS)=MSTU(5)*I + ICOLR=I + ENDIF + IF(KFLCH.EQ.0) THEN + P(I,1)=-P(IPU3,1) + P(I,2)=-P(IPU3,2) + PMS(ISIDE)=P(I,5)**2+P(I,1)**2+P(I,2)**2 + P(I,3)=-P(IPU3,3) + P(I,4)=SQRT(PMS(ISIDE)+P(I,3)**2) + PRP=P(I,4)+ABS(P(I,3)) + +C...When extra remnant parton or hadron: store extra remnant. + ELSE + I=I+1 + K(I,1)=1 + K(I,2)=KFLCH + K(I,3)=MINT(83)+ISIDE + P(I,5)=PYMASS(K(I,2)) + KCOL=KCHG(PYCOMP(KFLCH),2) + IF(KCOL.NE.0) THEN + K(I,1)=3 + KFLS=(3-KCOL*ISIGN(1,KFLCH))/2 + K(I,KFLS+3)=MSTU(5)*IPU3 + K(IPU3,6-KFLS)=MSTU(5)*I + ICOLR=I + ENDIF + +C...Relative transverse momentum when two remnants. + LOOP=0 + 200 LOOP=LOOP+1 + CALL PYPTDI(1,P(I-1,1),P(I-1,2)) + P(I-1,1)=P(I-1,1)-0.5D0*P(IPU3,1) + P(I-1,2)=P(I-1,2)-0.5D0*P(IPU3,2) + PMS(3)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2 + P(I,1)=-P(IPU3,1)-P(I-1,1) + P(I,2)=-P(IPU3,2)-P(I-1,2) + PMS(4)=P(I,5)**2+P(I,1)**2+P(I,2)**2 + +C...Relative distribution of energy for particle into jet plus particle. + IMB=1 + IF(MOD(MINT(10+ISIDE)/1000,10).NE.0) IMB=2 + IF(MSTP(94).LE.1) THEN + IF(IMB.EQ.1) CHI=PYR(0) + IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0)) + IF(MOD(KFLCH/1000,10).NE.0) CHI=1D0-CHI + ELSEIF(MSTP(94).EQ.2) THEN + CHI=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB))) + IF(MOD(KFLCH/1000,10).NE.0) CHI=1D0-CHI + ELSEIF(MSTP(94).EQ.3) THEN + CALL PYZDIS(1,0,PMS(4),ZZ) + CHI=ZZ + ELSE + CALL PYZDIS(1000,0,PMS(4),ZZ) + CHI=ZZ + ENDIF + +C...Construct total transverse mass; reject if too large. + CHI=MAX(1D-8,MIN(1D0-1D-8,CHI)) + PMS(ISIDE)=PMS(4)/CHI+PMS(3)/(1D0-CHI) + IF(PMS(ISIDE).GT.P(IPU3,4)**2) THEN + IF(LOOP.LT.10) GOTO 200 + GOTO 180 + ENDIF + VINT(158+ISIDE)=CHI + +C...Subdivide longitudinal momentum according to value selected above. + PRP=SQRT(PMS(ISIDE)+P(IPU3,3)**2)+ABS(P(IPU3,3)) + PW1=(1D0-CHI)*PRP + P(I-1,4)=0.5D0*(PW1+PMS(3)/PW1) + P(I-1,3)=0.5D0*(PW1-PMS(3)/PW1)*SIDESG + PW2=CHI*PRP + P(I,4)=0.5D0*(PW2+PMS(4)/PW2) + P(I,3)=0.5D0*(PW2-PMS(4)/PW2)*SIDESG + ENDIF + N=I + +C...Boost current and remnant systems to correct frame. + IF(SQRT(PMS(1))+SQRT(PMS(2)).GT.0.99D0*VINT(1)) GOTO 180 + DSQLAM=SQRT(MAX(0D0,(VINT(2)-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2))) + DRKC=(VINT(2)+PMS(3-ISIDE)-PMS(ISIDE)+DSQLAM)/ + &(2D0*VINT(1)*PCP) + DRKR=(VINT(2)+PMS(ISIDE)-PMS(3-ISIDE)+DSQLAM)/ + &(2D0*VINT(1)*PRP) + DBEC=-SIDESG*(DRKC**2-1D0)/(DRKC**2+1D0) + DBER=SIDESG*(DRKR**2-1D0)/(DRKR**2+1D0) + CALL PYROBO(IPU3,IPU3,0D0,0D0,0D0,0D0,DBEC) + CALL PYROBO(IPU3+1,N,0D0,0D0,0D0,0D0,DBER) + +C...Let current quark shower; recoil but no showering by colour partner. + QMAX=2D0*SQRT(VINT(309-ISIDE)) + MSTJ48=MSTJ(48) + MSTJ(48)=1 + PARJ86=PARJ(86) + PARJ(86)=0D0 + IF(MSTP(71).EQ.1) CALL PYSHOW(IPU3,ICOLR,QMAX) + MSTJ(48)=MSTJ48 + PARJ(86)=PARJ86 + + RETURN + END + +C********************************************************************* + +C...PYDOCU +C...Handles the documentation of the process in MSTI and PARI, +C...and also computes cross-sections based on accumulated statistics. + + SUBROUTINE PYDOCU + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) + COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) + SAVE /PYJETS/,/PYDAT1/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/, + &/PYINT5/ + +C...Calculate Monte Carlo estimates of cross-sections. + ISUB=MINT(1) + IF(MSTP(111).NE.-1) NGEN(ISUB,3)=NGEN(ISUB,3)+1 + NGEN(0,3)=NGEN(0,3)+1 + XSEC(0,3)=0D0 + DO 100 I=1,500 + IF(I.EQ.96.OR.I.EQ.97) THEN + XSEC(I,3)=0D0 + ELSEIF(MSUB(95).EQ.1.AND.(I.EQ.11.OR.I.EQ.12.OR.I.EQ.13.OR. + & I.EQ.28.OR.I.EQ.53.OR.I.EQ.68)) THEN + XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))* + & DBLE(NGEN(96,2))) + ELSEIF(MSUB(95).EQ.1.AND.I.GE.381.AND.I.LE.386) THEN + XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))* + & DBLE(NGEN(96,2))) + ELSEIF(MSUB(I).EQ.0.OR.NGEN(I,1).EQ.0) THEN + XSEC(I,3)=0D0 + ELSEIF(NGEN(I,2).EQ.0) THEN + XSEC(I,3)=XSEC(I,2)*NGEN(0,3)/(DBLE(NGEN(I,1))* + & DBLE(NGEN(0,2))) + ELSE + XSEC(I,3)=XSEC(I,2)*NGEN(I,3)/(DBLE(NGEN(I,1))* + & DBLE(NGEN(I,2))) + ENDIF + XSEC(0,3)=XSEC(0,3)+XSEC(I,3) + 100 CONTINUE + +C...Rescale to known low-pT cross-section for standard QCD processes. + IF(MSUB(95).EQ.1) THEN + XSECH=XSEC(11,3)+XSEC(12,3)+XSEC(13,3)+XSEC(28,3)+XSEC(53,3)+ + & XSEC(68,3)+XSEC(95,3) + XSECW=XSEC(97,2)/MAX(1D0,DBLE(NGEN(97,1))) + IF(XSECH.GT.1D-20.AND.XSECW.GT.1D-20) THEN + FAC=XSECW/XSECH + XSEC(11,3)=FAC*XSEC(11,3) + XSEC(12,3)=FAC*XSEC(12,3) + XSEC(13,3)=FAC*XSEC(13,3) + XSEC(28,3)=FAC*XSEC(28,3) + XSEC(53,3)=FAC*XSEC(53,3) + XSEC(68,3)=FAC*XSEC(68,3) + XSEC(95,3)=FAC*XSEC(95,3) + XSEC(0,3)=XSEC(0,3)-XSECH+XSECW + ENDIF + ENDIF + +C...Save information for gamma-p and gamma-gamma. + IF(MINT(121).GT.1) THEN + IGA=MINT(122) + CALL PYSAVE(2,IGA) + CALL PYSAVE(5,0) + ENDIF + +C...Reset information on hard interaction. + DO 110 J=1,200 + MSTI(J)=0 + PARI(J)=0D0 + 110 CONTINUE + +C...Copy integer valued information from MINT into MSTI. + DO 120 J=1,32 + MSTI(J)=MINT(J) + 120 CONTINUE + IF(MINT(121).GT.1) MSTI(9)=MINT(122) + +C...Store cross-section variables in PARI. + PARI(1)=XSEC(0,3) + PARI(2)=XSEC(0,3)/MINT(5) + PARI(7)=VINT(97) + PARI(9)=VINT(99) + PARI(10)=VINT(100) + VINT(98)=VINT(98)+VINT(100) + IF(MSTP(142).EQ.1) PARI(2)=XSEC(0,3)/VINT(98) + +C...Store kinematics variables in PARI. + PARI(11)=VINT(1) + PARI(12)=VINT(2) + IF(ISUB.NE.95) THEN + DO 130 J=13,26 + PARI(J)=VINT(30+J) + 130 CONTINUE + PARI(29)=VINT(39) + PARI(30)=VINT(40) + PARI(31)=VINT(141) + PARI(32)=VINT(142) + PARI(33)=VINT(41) + PARI(34)=VINT(42) + PARI(35)=PARI(33)-PARI(34) + PARI(36)=VINT(21) + PARI(37)=VINT(22) + PARI(38)=VINT(26) + PARI(39)=VINT(157) + PARI(40)=VINT(158) + PARI(41)=VINT(23) + PARI(42)=2D0*VINT(47)/VINT(1) + ENDIF + +C...Store information on scattered partons in PARI. + IF(ISUB.NE.95.AND.MINT(7)*MINT(8).NE.0) THEN + DO 140 IS=7,8 + I=MINT(IS) + PARI(36+IS)=P(I,3)/VINT(1) + PARI(38+IS)=P(I,4)/VINT(1) + PR=MAX(1D-20,P(I,5)**2+P(I,1)**2+P(I,2)**2) + PARI(40+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/ + & SQRT(PR),1D20)),P(I,3)) + PR=MAX(1D-20,P(I,1)**2+P(I,2)**2) + PARI(42+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/ + & SQRT(PR),1D20)),P(I,3)) + PARI(44+IS)=P(I,3)/SQRT(1D-20+P(I,1)**2+P(I,2)**2+P(I,3)**2) + PARI(46+IS)=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2)) + PARI(48+IS)=PYANGL(P(I,1),P(I,2)) + 140 CONTINUE + ENDIF + +C...Store sum up transverse and longitudinal momenta. + PARI(65)=2D0*PARI(17) + IF(ISUB.LE.90.OR.ISUB.GE.95) THEN + DO 150 I=MSTP(126)+1,N + IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 150 + PT=SQRT(P(I,1)**2+P(I,2)**2) + PARI(69)=PARI(69)+PT + IF(I.LE.MINT(52)) PARI(66)=PARI(66)+PT + IF(I.GT.MINT(52).AND.I.LE.MINT(53)) PARI(68)=PARI(68)+PT + 150 CONTINUE + PARI(67)=PARI(68) + PARI(71)=VINT(151) + PARI(72)=VINT(152) + PARI(73)=VINT(151) + PARI(74)=VINT(152) + ELSE + PARI(66)=PARI(65) + PARI(69)=PARI(65) + ENDIF + +C...Store various other pieces of information into PARI. + PARI(61)=VINT(148) + PARI(75)=VINT(155) + PARI(76)=VINT(156) + PARI(77)=VINT(159) + PARI(78)=VINT(160) + PARI(81)=VINT(138) + +C...Store information on lepton -> lepton + gamma in PYGAGA. + MSTI(71)=MINT(141) + MSTI(72)=MINT(142) + PARI(101)=VINT(301) + PARI(102)=VINT(302) + DO 160 I=103,114 + PARI(I)=VINT(I+202) + 160 CONTINUE + +C...Set information for PYTABU. + IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN + MSTU(161)=MINT(21) + MSTU(162)=0 + ELSEIF(ISET(ISUB).EQ.5) THEN + MSTU(161)=MINT(23) + MSTU(162)=0 + ELSE + MSTU(161)=MINT(21) + MSTU(162)=MINT(22) + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYFRAM +C...Performs transformations between different coordinate frames. + + SUBROUTINE PYFRAM(IFRAME) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + SAVE /PYDAT1/,/PYPARS/,/PYINT1/ + +C...Check that transformation can and should be done. + IF(IFRAME.EQ.1.OR.IFRAME.EQ.2.OR.(IFRAME.EQ.3.AND. + &MINT(91).EQ.1)) THEN + IF(IFRAME.EQ.MINT(6)) RETURN + ELSE + WRITE(MSTU(11),5000) IFRAME,MINT(6) + RETURN + ENDIF + + IF(MINT(6).EQ.1) THEN +C...Transform from fixed target or user specified frame to +C...overall CM frame. + CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10)) + CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0) + CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0) + ELSEIF(MINT(6).EQ.3) THEN +C...Transform from hadronic CM frame in DIS to overall CM frame. + CALL PYROBO(0,0,-VINT(221),-VINT(222),-VINT(223),-VINT(224), + & -VINT(225)) + ENDIF + + IF(IFRAME.EQ.1) THEN +C...Transform from overall CM frame to fixed target or user specified +C...frame. + CALL PYROBO(0,0,VINT(6),VINT(7),VINT(8),VINT(9),VINT(10)) + ELSEIF(IFRAME.EQ.3) THEN +C...Transform from overall CM frame to hadronic CM frame in DIS. + CALL PYROBO(0,0,0D0,0D0,VINT(223),VINT(224),VINT(225)) + CALL PYROBO(0,0,0D0,VINT(222),0D0,0D0,0D0) + CALL PYROBO(0,0,VINT(221),0D0,0D0,0D0,0D0) + ENDIF + +C...Set information about new frame. + MINT(6)=IFRAME + MSTI(6)=IFRAME + + 5000 FORMAT(1X,'Error: illegal values in subroutine PYFRAM.',1X, + &'No transformation performed.'/1X,'IFRAME =',1X,I5,'; MINT(6) =', + &1X,I5) + + RETURN + END + +C********************************************************************* + +C...PYWIDT +C...Calculates full and partial widths of resonances. + + SUBROUTINE PYWIDT(KFLR,SH,WDTP,WDTE) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT4/MWID(500),WIDS(500,5) + COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) + COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), + &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) + COMMON/PYTCSM/ITCM(0:99),RTCM(0:99) + COMMON/PYPUED/IUED(0:99),RUED(0:99) + SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/, + &/PYINT4/,/PYMSSM/,/PYSSMT/,/PYTCSM/,/PYPUED/ +C...Local arrays and saved variables. + COMPLEX*16 ZMIXC(4,4),AL,BL,AR,BR,FL,FR + DIMENSION WDTP(0:400),WDTE(0:400,0:5),MOFSV(3,2),WIDWSV(3,2), + &WID2SV(3,2),WDTPP(0:400),WDTEP(0:400,0:5) +C...UED: equivalences between ordered particles (451->475) +C...and UED particle code (5 000 000 + id) + PARAMETER(KKFLMI=451,KKFLMA=475) + DIMENSION CHIDEL(3), IUEDPR(25) + DIMENSION IUEDEQ(KKFLMA),MUED(2) + COMMON/SW1/SW21,CW21 + DATA (IUEDEQ(I),I=KKFLMI,KKFLMA)/ + & 6100001,6100002,6100003,6100004,6100005,6100006, + & 5100001,5100002,5100003,5100004,5100005,5100006, + & 6100011,6100013,6100015, + & 5100012,5100011,5100014,5100013,5100016,5100015, + & 5100021,5100022,5100023,5100024/ +C...Save local variables + SAVE MOFSV,WIDWSV,WID2SV +C...Initial values + DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/ + DATA CHIDEL/1.1D-03,1.D0,7.4D+2/ + DATA IUEDPR/25*0/ +C...UED: inline functions used in kk width calculus + FKAC1(X,Y)=1.-X**2/Y**2 + FKAC2(X,Y)=2.+X**2/Y**2 + +C...Compressed code and sign; mass. + KFLA=IABS(KFLR) + KFLS=ISIGN(1,KFLR) + KC=PYCOMP(KFLA) + SHR=SQRT(SH) + PMR=PMAS(KC,1) + +C...Reset width information. + DO 110 I=0,MDCY(KC,3) + WDTP(I)=0D0 + DO 100 J=0,5 + WDTE(I,J)=0D0 + 100 CONTINUE + 110 CONTINUE + +C...Allow for fudge factor to rescale resonance width. + FUDGE=1D0 + IF(MSTP(110).NE.0.AND.(MWID(KC).EQ.1.OR.MWID(KC).EQ.2.OR. + &(MWID(KC).EQ.3.AND.MINT(63).EQ.1))) THEN + IF(MSTP(110).EQ.KFLA) THEN + FUDGE=PARP(110) + ELSEIF(MSTP(110).EQ.-1) THEN + IF(KFLA.NE.6.AND.KFLA.NE.23.AND.KFLA.NE.24) FUDGE=PARP(110) + ELSEIF(MSTP(110).EQ.-2) THEN + FUDGE=PARP(110) + ENDIF + ENDIF + +C...Not to be treated as a resonance: return. + IF((MWID(KC).LE.0.OR.MWID(KC).GE.4).AND.KFLA.NE.21.AND. + &KFLA.NE.22) THEN + WDTP(0)=1D0 + WDTE(0,0)=1D0 + MINT(61)=0 + MINT(62)=0 + MINT(63)=0 + RETURN + +C...Treatment as a resonance based on tabulated branching ratios. + ELSEIF(MWID(KC).EQ.2.OR.(MWID(KC).EQ.3.AND.MINT(63).EQ.0)) THEN +C...Loop over possible decay channels; skip irrelevant ones. + DO 120 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 120 + +C...Read out decay products and nominal masses. + KFD1=KFDP(IDC,1) + KFC1=PYCOMP(KFD1) +C...Skip dummy modes or unrecognized particles + IF (KFD1.EQ.0.OR.KFC1.EQ.0) GOTO 120 + IF(KCHG(KFC1,3).EQ.1) KFD1=KFLS*KFD1 + PM1=PMAS(KFC1,1) + KFD2=KFDP(IDC,2) + KFC2=PYCOMP(KFD2) + IF(KCHG(KFC2,3).EQ.1) KFD2=KFLS*KFD2 + PM2=PMAS(KFC2,1) + KFD3=KFDP(IDC,3) + PM3=0D0 + IF(KFD3.NE.0) THEN + KFC3=PYCOMP(KFD3) + IF(KCHG(KFC3,3).EQ.1) KFD3=KFLS*KFD3 + PM3=PMAS(KFC3,1) + ENDIF + +C...Naive partial width and alternative threshold factors. + WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR) + IF(MDME(IDC,2).GE.51.AND.MDME(IDC,2).LE.53.AND. + & PM1+PM2+PM3.GE.SHR) THEN + WDTP(I)=0D0 + ELSEIF(MDME(IDC,2).EQ.52.AND.KFD3.EQ.0) THEN + WDTP(I)=WDTP(I)*SQRT(MAX(0D0,(SH-PM1**2-PM2**2)**2- + & 4D0*PM1**2*PM2**2))/SH + ELSEIF(MDME(IDC,2).EQ.52) THEN + PMA=MAX(PM1,PM2,PM3) + PMC=MIN(PM1,PM2,PM3) + PMB=PM1+PM2+PM3-PMA-PMC + PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMC-PMC) + PMAN=PMA**2/SH + PMBN=PMB**2/SH + PMCN=PMC**2/SH + PMBCN=PMBC**2/SH + WDTP(I)=WDTP(I)*SQRT(MAX(0D0, + & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)* + & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))* + & ((SHR-PMA)**2-(PMB+PMC)**2)* + & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/ + & ((1D0-PMBCN)*PMBCN*SH) + ELSEIF(MDME(IDC,2).EQ.53.AND.KFD3.EQ.0) THEN + WDTP(I)=WDTP(I)*SQRT( + & MAX(0D0,(SH-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2)/ + & MAX(1D-4,(PMR**2-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2)) + ELSEIF(MDME(IDC,2).EQ.53) THEN + PMA=MAX(PM1,PM2,PM3) + PMC=MIN(PM1,PM2,PM3) + PMB=PM1+PM2+PM3-PMA-PMC + PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMB-PMC) + PMAN=PMA**2/SH + PMBN=PMB**2/SH + PMCN=PMC**2/SH + PMBCN=PMBC**2/SH + FACACT=SQRT(MAX(0D0, + & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)* + & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))* + & ((SHR-PMA)**2-(PMB+PMC)**2)* + & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/ + & ((1D0-PMBCN)*PMBCN*SH) + PMBC=PMB+PMC+0.5D0*(PMR-PMA-PMB-PMC) + PMAN=PMA**2/PMR**2 + PMBN=PMB**2/PMR**2 + PMCN=PMC**2/PMR**2 + PMBCN=PMBC**2/PMR**2 + FACNOM=SQRT(MAX(0D0, + & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)* + & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))* + & ((PMR-PMA)**2-(PMB+PMC)**2)* + & (1D0+0.25D0*(PMA+PMB+PMC)/PMR)/ + & ((1D0-PMBCN)*PMBCN*PMR**2) + WDTP(I)=WDTP(I)*FACACT/MAX(1D-6,FACNOM) + ENDIF + WDTP(I)=FUDGE*WDTP(I) + WDTP(0)=WDTP(0)+WDTP(I) + +C...Calculate secondary width (at most two identical/opposite). + WID2=1D0 + IF(MDME(IDC,1).GT.0) THEN + IF(KFD2.EQ.KFD1) THEN + IF(KCHG(KFC1,3).EQ.0) THEN + WID2=WIDS(KFC1,1) + ELSEIF(KFD1.GT.0) THEN + WID2=WIDS(KFC1,4) + ELSE + WID2=WIDS(KFC1,5) + ENDIF + IF(KFD3.GT.0) THEN + WID2=WID2*WIDS(KFC3,2) + ELSEIF(KFD3.LT.0) THEN + WID2=WID2*WIDS(KFC3,3) + ENDIF + ELSEIF(KFD2.EQ.-KFD1) THEN + WID2=WIDS(KFC1,1) + IF(KFD3.GT.0) THEN + WID2=WID2*WIDS(KFC3,2) + ELSEIF(KFD3.LT.0) THEN + WID2=WID2*WIDS(KFC3,3) + ENDIF + ELSEIF(KFD3.EQ.KFD1) THEN + IF(KCHG(KFC1,3).EQ.0) THEN + WID2=WIDS(KFC1,1) + ELSEIF(KFD1.GT.0) THEN + WID2=WIDS(KFC1,4) + ELSE + WID2=WIDS(KFC1,5) + ENDIF + IF(KFD2.GT.0) THEN + WID2=WID2*WIDS(KFC2,2) + ELSEIF(KFD2.LT.0) THEN + WID2=WID2*WIDS(KFC2,3) + ENDIF + ELSEIF(KFD3.EQ.-KFD1) THEN + WID2=WIDS(KFC1,1) + IF(KFD2.GT.0) THEN + WID2=WID2*WIDS(KFC2,2) + ELSEIF(KFD2.LT.0) THEN + WID2=WID2*WIDS(KFC2,3) + ENDIF + ELSEIF(KFD3.EQ.KFD2) THEN + IF(KCHG(KFC2,3).EQ.0) THEN + WID2=WIDS(KFC2,1) + ELSEIF(KFD2.GT.0) THEN + WID2=WIDS(KFC2,4) + ELSE + WID2=WIDS(KFC2,5) + ENDIF + IF(KFD1.GT.0) THEN + WID2=WID2*WIDS(KFC1,2) + ELSEIF(KFD1.LT.0) THEN + WID2=WID2*WIDS(KFC1,3) + ENDIF + ELSEIF(KFD3.EQ.-KFD2) THEN + WID2=WIDS(KFC2,1) + IF(KFD1.GT.0) THEN + WID2=WID2*WIDS(KFC1,2) + ELSEIF(KFD1.LT.0) THEN + WID2=WID2*WIDS(KFC1,3) + ENDIF + ELSE + IF(KFD1.GT.0) THEN + WID2=WIDS(KFC1,2) + ELSE + WID2=WIDS(KFC1,3) + ENDIF + IF(KFD2.GT.0) THEN + WID2=WID2*WIDS(KFC2,2) + ELSE + WID2=WID2*WIDS(KFC2,3) + ENDIF + IF(KFD3.GT.0) THEN + WID2=WID2*WIDS(KFC3,2) + ELSEIF(KFD3.LT.0) THEN + WID2=WID2*WIDS(KFC3,3) + ENDIF + ENDIF + +C...Store effective widths according to case. + WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 + WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) + WDTE(I,0)=WDTE(I,MDME(IDC,1)) + WDTE(0,0)=WDTE(0,0)+WDTE(I,0) + ENDIF + 120 CONTINUE +C...Return. + MINT(61)=0 + MINT(62)=0 + MINT(63)=0 + RETURN + ENDIF + +C...Here begins detailed dynamical calculation of resonance widths. +C...Shared treatment of Higgs states. + KFHIGG=25 + IHIGG=1 + IF(KFLA.EQ.35.OR.KFLA.EQ.36) THEN + KFHIGG=KFLA + IHIGG=KFLA-33 + ENDIF + +C...Common electroweak and strong constants. + XW=PARU(102) + XWV=XW + IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2 + XW1=1D0-XW + AEM=PYALEM(SH) + IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1) + AS=PYALPS(SH) + RADC=1D0+AS/PARU(1) + + IF(KFLA.EQ.6) THEN +C...t quark. + FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR + RADCT=1D0-2.5D0*AS/PARU(1) + DO 140 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 140 + RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH + RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH + IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 140 + WID2=1D0 + IF(I.GE.4.AND.I.LE.7) THEN +C...t -> W + q; including approximate QCD correction factor. + WDTP(I)=FAC*VCKM(3,I-3)*RADCT* + & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))* + & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2) + IF(KFLR.GT.0) THEN + WID2=WIDS(24,2) + IF(I.EQ.7) WID2=WID2*WIDS(7,2) + ELSE + WID2=WIDS(24,3) + IF(I.EQ.7) WID2=WID2*WIDS(7,3) + ENDIF + ELSEIF(I.EQ.9) THEN +C...t -> H + b. + RM2R=PYMRUN(KFDP(IDC,2),SH)**2/SH + WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))* + & ((1D0+RM2-RM1)*(RM2R*PARU(141)**2+1D0/PARU(141)**2)+ + & 4D0*SQRT(RM2R*RM2)) + WID2=WIDS(37,2) + IF(KFLR.LT.0) WID2=WIDS(37,3) +CMRENNA++ + ELSEIF(I.GE.10.AND.I.LE.13.AND.IMSS(1).NE.0) THEN +C...t -> ~t + ~chi_i0, i = 1, 2, 3 or 4. + BETA=ATAN(RMSS(5)) + SINB=SIN(BETA) + TANW=SQRT(PARU(102)/(1D0-PARU(102))) + ET=KCHG(6,1)/3D0 + T3L=SIGN(0.5D0,ET) + KFC1=PYCOMP(KFDP(IDC,1)) + KFC2=PYCOMP(KFDP(IDC,2)) + PMNCHI=PMAS(KFC1,1) + PMSTOP=PMAS(KFC2,1) + IF(SHR.GT.PMNCHI+PMSTOP) THEN + IZ=I-9 + DO 130 IK=1,4 + ZMIXC(IZ,IK)=DCMPLX(ZMIX(IZ,IK),ZMIXI(IZ,IK)) + 130 CONTINUE + AL=SHR*DCONJG(ZMIXC(IZ,4))/(2.0D0*PMAS(24,1)*SINB) + AR=-ET*ZMIXC(IZ,1)*TANW + BL=T3L*(ZMIXC(IZ,2)-ZMIXC(IZ,1)*TANW)-AR + BR=AL + FL=SFMIX(6,1)*AL+SFMIX(6,2)*AR + FR=SFMIX(6,1)*BL+SFMIX(6,2)*BR + PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)* + & (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR) + WDTP(I)=(0.5D0*PYALEM(SH)/PARU(102))*PCM* + & ((ABS(FL)**2+ABS(FR)**2)*(SH+PMNCHI**2-PMSTOP**2)+ + & SMZ(IZ)*4D0*SHR*DBLE(FL*DCONJG(FR)))/SH + IF(KFLR.GT.0) THEN + WID2=WIDS(KFC1,2)*WIDS(KFC2,2) + ELSE + WID2=WIDS(KFC1,2)*WIDS(KFC2,3) + ENDIF + ENDIF + ELSEIF(I.EQ.14.AND.IMSS(1).NE.0) THEN +C...t -> ~g + ~t + KFC1=PYCOMP(KFDP(IDC,1)) + KFC2=PYCOMP(KFDP(IDC,2)) + PMNCHI=PMAS(KFC1,1) + PMSTOP=PMAS(KFC2,1) + IF(SHR.GT.PMNCHI+PMSTOP) THEN + RL=SFMIX(6,1) + RR=-SFMIX(6,2) + PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)* + & (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR) + WDTP(I)=4D0/3D0*0.5D0*PYALPS(SH)*PCM*((RL**2+RR**2)* + & (SH+PMNCHI**2-PMSTOP**2)+PMNCHI*4D0*SHR*RL*RR)/SH + IF(KFLR.GT.0) THEN + WID2=WIDS(KFC1,2)*WIDS(KFC2,2) + ELSE + WID2=WIDS(KFC1,2)*WIDS(KFC2,3) + ENDIF + ENDIF + ELSEIF(I.EQ.15.AND.IMSS(1).NE.0) THEN +C...t -> ~gravitino + ~t + XMP2=RMSS(29)**2 + KFC1=PYCOMP(KFDP(IDC,1)) + XMGR2=PMAS(KFC1,1)**2 + WDTP(I)=SH**2*SHR/(96D0*PARU(1)*XMP2*XMGR2)*(1D0-RM2)**4 + KFC2=PYCOMP(KFDP(IDC,2)) + WID2=WIDS(KFC2,2) + IF(KFLR.LT.0) WID2=WIDS(KFC2,3) +CMRENNA-- + ENDIF + WDTP(I)=FUDGE*WDTP(I) + WDTP(0)=WDTP(0)+WDTP(I) + IF(MDME(IDC,1).GT.0) THEN + WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 + WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) + WDTE(I,0)=WDTE(I,MDME(IDC,1)) + WDTE(0,0)=WDTE(0,0)+WDTE(I,0) + ENDIF + 140 CONTINUE + + ELSEIF(KFLA.EQ.7) THEN +C...b' quark. + FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR + DO 150 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 150 + RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH + RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH + IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 150 + WID2=1D0 + IF(I.GE.4.AND.I.LE.7) THEN +C...b' -> W + q. + WDTP(I)=FAC*VCKM(I-3,4)* + & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))* + & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2) + IF(KFLR.GT.0) THEN + WID2=WIDS(24,3) + IF(I.EQ.6) WID2=WID2*WIDS(6,2) + IF(I.EQ.7) WID2=WID2*WIDS(8,2) + ELSE + WID2=WIDS(24,2) + IF(I.EQ.6) WID2=WID2*WIDS(6,3) + IF(I.EQ.7) WID2=WID2*WIDS(8,3) + ENDIF + WID2=WIDS(24,3) + IF(KFLR.LT.0) WID2=WIDS(24,2) + ELSEIF(I.EQ.9.OR.I.EQ.10) THEN +C...b' -> H + q. + WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))* + & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2) + IF(KFLR.GT.0) THEN + WID2=WIDS(37,3) + IF(I.EQ.10) WID2=WID2*WIDS(6,2) + ELSE + WID2=WIDS(37,2) + IF(I.EQ.10) WID2=WID2*WIDS(6,3) + ENDIF + ENDIF + WDTP(I)=FUDGE*WDTP(I) + WDTP(0)=WDTP(0)+WDTP(I) + IF(MDME(IDC,1).GT.0) THEN + WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 + WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) + WDTE(I,0)=WDTE(I,MDME(IDC,1)) + WDTE(0,0)=WDTE(0,0)+WDTE(I,0) + ENDIF + 150 CONTINUE + + ELSEIF(KFLA.EQ.8) THEN +C...t' quark. + FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR + DO 160 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 160 + RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH + RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH + IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 160 + WID2=1D0 + IF(I.GE.4.AND.I.LE.7) THEN +C...t' -> W + q. + WDTP(I)=FAC*VCKM(4,I-3)* + & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))* + & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2) + IF(KFLR.GT.0) THEN + WID2=WIDS(24,2) + IF(I.EQ.7) WID2=WID2*WIDS(7,2) + ELSE + WID2=WIDS(24,3) + IF(I.EQ.7) WID2=WID2*WIDS(7,3) + ENDIF + ELSEIF(I.EQ.9.OR.I.EQ.10) THEN +C...t' -> H + q. + WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))* + & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2) + IF(KFLR.GT.0) THEN + WID2=WIDS(37,2) + IF(I.EQ.10) WID2=WID2*WIDS(7,2) + ELSE + WID2=WIDS(37,3) + IF(I.EQ.10) WID2=WID2*WIDS(7,3) + ENDIF + ENDIF + WDTP(I)=FUDGE*WDTP(I) + WDTP(0)=WDTP(0)+WDTP(I) + IF(MDME(IDC,1).GT.0) THEN + WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 + WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) + WDTE(I,0)=WDTE(I,MDME(IDC,1)) + WDTE(0,0)=WDTE(0,0)+WDTE(I,0) + ENDIF + 160 CONTINUE + + ELSEIF(KFLA.EQ.17) THEN +C...tau' lepton. + FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR + DO 170 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 170 + RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH + RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH + IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 170 + WID2=1D0 + IF(I.EQ.3) THEN +C...tau' -> W + nu'_tau. + WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))* + & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2) + IF(KFLR.GT.0) THEN + WID2=WIDS(24,3) + WID2=WID2*WIDS(18,2) + ELSE + WID2=WIDS(24,2) + WID2=WID2*WIDS(18,3) + ENDIF + ELSEIF(I.EQ.5) THEN +C...tau' -> H + nu'_tau. + WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))* + & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2) + IF(KFLR.GT.0) THEN + WID2=WIDS(37,3) + WID2=WID2*WIDS(18,2) + ELSE + WID2=WIDS(37,2) + WID2=WID2*WIDS(18,3) + ENDIF + ENDIF + WDTP(I)=FUDGE*WDTP(I) + WDTP(0)=WDTP(0)+WDTP(I) + IF(MDME(IDC,1).GT.0) THEN + WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 + WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) + WDTE(I,0)=WDTE(I,MDME(IDC,1)) + WDTE(0,0)=WDTE(0,0)+WDTE(I,0) + ENDIF + 170 CONTINUE + + ELSEIF(KFLA.EQ.18) THEN +C...nu'_tau neutrino. + FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR + DO 180 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 180 + RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH + RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH + IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 180 + WID2=1D0 + IF(I.EQ.2) THEN +C...nu'_tau -> W + tau'. + WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))* + & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2) + IF(KFLR.GT.0) THEN + WID2=WIDS(24,2) + WID2=WID2*WIDS(17,2) + ELSE + WID2=WIDS(24,3) + WID2=WID2*WIDS(17,3) + ENDIF + ELSEIF(I.EQ.3) THEN +C...nu'_tau -> H + tau'. + WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))* + & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2) + IF(KFLR.GT.0) THEN + WID2=WIDS(37,2) + WID2=WID2*WIDS(17,2) + ELSE + WID2=WIDS(37,3) + WID2=WID2*WIDS(17,3) + ENDIF + ENDIF + WDTP(I)=FUDGE*WDTP(I) + WDTP(0)=WDTP(0)+WDTP(I) + IF(MDME(IDC,1).GT.0) THEN + WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 + WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) + WDTE(I,0)=WDTE(I,MDME(IDC,1)) + WDTE(0,0)=WDTE(0,0)+WDTE(I,0) + ENDIF + 180 CONTINUE + + ELSEIF(KFLA.EQ.21) THEN +C...QCD: +C***Note that widths are not given in dimensional quantities here. + DO 190 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 190 + RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH + RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH + IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 190 + WID2=1D0 + IF(I.LE.8) THEN +C...QCD -> q + qbar + WDTP(I)=(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1)) + IF(I.EQ.6) WID2=WIDS(6,1) + IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1) + ENDIF + WDTP(I)=FUDGE*WDTP(I) + WDTP(0)=WDTP(0)+WDTP(I) + IF(MDME(IDC,1).GT.0) THEN + WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 + WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) + WDTE(I,0)=WDTE(I,MDME(IDC,1)) + WDTE(0,0)=WDTE(0,0)+WDTE(I,0) + ENDIF + 190 CONTINUE + + ELSEIF(KFLA.EQ.22) THEN +C...QED photon. +C***Note that widths are not given in dimensional quantities here. + DO 200 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 200 + RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH + RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH + IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 200 + WID2=1D0 + IF(I.LE.8) THEN +C...QED -> q + qbar. + EF=KCHG(I,1)/3D0 + FCOF=3D0*RADC + IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0) + WDTP(I)=FCOF*EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1)) + IF(I.EQ.6) WID2=WIDS(6,1) + IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1) + ELSEIF(I.LE.12) THEN +C...QED -> l+ + l-. + EF=KCHG(9+2*(I-8),1)/3D0 + WDTP(I)=EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1)) + IF(I.EQ.12) WID2=WIDS(17,1) + ENDIF + WDTP(I)=FUDGE*WDTP(I) + WDTP(0)=WDTP(0)+WDTP(I) + IF(MDME(IDC,1).GT.0) THEN + WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 + WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) + WDTE(I,0)=WDTE(I,MDME(IDC,1)) + WDTE(0,0)=WDTE(0,0)+WDTE(I,0) + ENDIF + 200 CONTINUE + + ELSEIF(KFLA.EQ.23) THEN +C...Z0: + ICASE=1 + XWC=1D0/(16D0*XW*XW1) + FAC=(AEM*XWC/3D0)*SHR + 210 CONTINUE + IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN + VINT(111)=0D0 + VINT(112)=0D0 + VINT(114)=0D0 + ENDIF + IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN + KFI=IABS(MINT(15)) + IF(KFI.GT.20) KFI=IABS(MINT(16)) + EI=KCHG(KFI,1)/3D0 + AI=SIGN(1D0,EI) + VI=AI-4D0*EI*XWV + SQMZ=PMAS(23,1)**2 + HZ=SHR*WDTP(0) + IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=1D0 + IF(MSTP(43).EQ.3) VINT(112)= + & 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2) + IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)= + & XWC**2*SH**2/((SH-SQMZ)**2+HZ**2) + ENDIF + DO 220 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 220 + RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH + RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH + IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 220 + WID2=1D0 + IF(I.LE.8) THEN +C...Z0 -> q + qbar + EF=KCHG(I,1)/3D0 + AF=SIGN(1D0,EF+0.1D0) + VF=AF-4D0*EF*XWV + FCOF=3D0*RADC + IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0) + IF(I.EQ.6) WID2=WIDS(6,1) + IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1) + ELSEIF(I.LE.16) THEN +C...Z0 -> l+ + l-, nu + nubar + EF=KCHG(I+2,1)/3D0 + AF=SIGN(1D0,EF+0.1D0) + VF=AF-4D0*EF*XWV + FCOF=1D0 + IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1) + ENDIF + BE34=SQRT(MAX(0D0,1D0-4D0*RM1)) + IF(ICASE.EQ.1) THEN + WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))* + & BE34 + ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN + WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)* + & EF*VF+(VI**2+AI**2)*VINT(114)*VF**2)*(1D0+2D0*RM1)+ + & (VI**2+AI**2)*VINT(114)*AF**2*(1D0-4D0*RM1))*BE34 + ELSEIF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN + FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34 + FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34 + FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34 + ENDIF + IF(ICASE.EQ.1) WDTP(I)=FUDGE*WDTP(I) + IF(ICASE.EQ.1) WDTP(0)=WDTP(0)+WDTP(I) + IF(MDME(IDC,1).GT.0) THEN + IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR. + & (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN + WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 + WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+ + & WDTE(I,MDME(IDC,1)) + WDTE(I,0)=WDTE(I,MDME(IDC,1)) + WDTE(0,0)=WDTE(0,0)+WDTE(I,0) + ENDIF + IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN + IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)= + & VINT(111)+FGGF*WID2 + IF(MSTP(43).EQ.3) VINT(112)=VINT(112)+FGZF*WID2 + IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)= + & VINT(114)+FZZF*WID2 + ENDIF + ENDIF + 220 CONTINUE + IF(MINT(61).GE.1) ICASE=3-ICASE + IF(ICASE.EQ.2) GOTO 210 + + ELSEIF(KFLA.EQ.24) THEN +C...W+/-: + FAC=(AEM/(24D0*XW))*SHR + DO 230 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 230 + RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH + RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH + IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 230 + WID2=1D0 + IF(I.LE.16) THEN +C...W+/- -> q + qbar' + FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1) + IF(KFLR.GT.0) THEN + IF(MOD(I,4).EQ.3) WID2=WIDS(6,2) + IF(MOD(I,4).EQ.0) WID2=WIDS(8,2) + IF(I.GE.13) WID2=WID2*WIDS(7,3) + ELSE + IF(MOD(I,4).EQ.3) WID2=WIDS(6,3) + IF(MOD(I,4).EQ.0) WID2=WIDS(8,3) + IF(I.GE.13) WID2=WID2*WIDS(7,2) + ENDIF + ELSEIF(I.LE.20) THEN +C...W+/- -> l+/- + nu + FCOF=1D0 + IF(KFLR.GT.0) THEN + IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2) + ELSE + IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3) + ENDIF + ENDIF + WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)* + & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)) + WDTP(I)=FUDGE*WDTP(I) + WDTP(0)=WDTP(0)+WDTP(I) + IF(MDME(IDC,1).GT.0) THEN + WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 + WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) + WDTE(I,0)=WDTE(I,MDME(IDC,1)) + WDTE(0,0)=WDTE(0,0)+WDTE(I,0) + ENDIF + 230 CONTINUE + + ELSEIF(KFLA.EQ.25.OR.KFLA.EQ.35.OR.KFLA.EQ.36) THEN +C...h0 (or H0, or A0): + SHFS=SH + FAC=(AEM/(8D0*XW))*(SHFS/PMAS(24,1)**2)*SHR + DO 270 I=1,MDCY(KFHIGG,3) + IDC=I+MDCY(KFHIGG,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 270 + KFC1=PYCOMP(KFDP(IDC,1)) + KFC2=PYCOMP(KFDP(IDC,2)) + RM1=PMAS(KFC1,1)**2/SH + RM2=PMAS(KFC2,1)**2/SH + IF(I.NE.16.AND.I.NE.17.AND.SQRT(RM1)+SQRT(RM2).GT.1D0) + & GOTO 270 + WID2=1D0 + + IF(I.LE.8) THEN +C...h0 -> q + qbar + WDTP(I)=FAC*3D0*(PYMRUN(KFDP(IDC,1),SH)**2/SHFS)* + & SQRT(MAX(0D0,1D0-4D0*RM1))*RADC +C...A0 behaves like beta, ho and H0 like beta**3. + IF(IHIGG.NE.3) WDTP(I)=WDTP(I)*(1D0-4D0*RM1) + IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN + IF(MOD(I,2).EQ.1) WDTP(I)=WDTP(I)*PARU(151+10*IHIGG)**2 + IF(MOD(I,2).EQ.0) WDTP(I)=WDTP(I)*PARU(152+10*IHIGG)**2 + IF(IMSS(1).NE.0.AND.KFC1.EQ.5) THEN + WDTP(I)=WDTP(I)/(1D0+RMSS(41))**2 + IF(IHIGG.NE.3) THEN + WDTP(I)=WDTP(I)*(1D0+RMSS(41)*PARU(152+10*IHIGG)/ + & PARU(151+10*IHIGG))**2 + ENDIF + ENDIF + ENDIF + IF(I.EQ.6) WID2=WIDS(6,1) + IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1) + ELSEIF(I.LE.12) THEN +C...h0 -> l+ + l- + WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))*(SH/SHFS) +C...A0 behaves like beta, ho and H0 like beta**3. + IF(IHIGG.NE.3) WDTP(I)=WDTP(I)*(1D0-4D0*RM1) + IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)* + & PARU(153+10*IHIGG)**2 + IF(I.EQ.12) WID2=WIDS(17,1) + + ELSEIF(I.EQ.13) THEN +C...h0 -> g + g; quark loop contribution only + ETARE=0D0 + ETAIM=0D0 + DO 240 J=1,2*MSTP(1) + EPS=(2D0*PMAS(J,1))**2/SH +C...Loop integral; function of eps=4m^2/shat; different for A0. + IF(EPS.LE.1D0) THEN + IF(EPS.GT.1D-4) THEN + ROOT=SQRT(1D0-EPS) + RLN=LOG((1D0+ROOT)/(1D0-ROOT)) + ELSE + RLN=LOG(4D0/EPS-2D0) + ENDIF + PHIRE=-0.25D0*(RLN**2-PARU(1)**2) + PHIIM=0.5D0*PARU(1)*RLN + ELSE + PHIRE=(ASIN(1D0/SQRT(EPS)))**2 + PHIIM=0D0 + ENDIF + IF(IHIGG.LE.2) THEN + ETAREJ=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE) + ETAIMJ=-0.5D0*EPS*(1D0-EPS)*PHIIM + ELSE + ETAREJ=-0.5D0*EPS*PHIRE + ETAIMJ=-0.5D0*EPS*PHIIM + ENDIF +C...Couplings (=1 for standard model Higgs). + IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN + IF(MOD(J,2).EQ.1) THEN + ETAREJ=ETAREJ*PARU(151+10*IHIGG) + ETAIMJ=ETAIMJ*PARU(151+10*IHIGG) + ELSE + ETAREJ=ETAREJ*PARU(152+10*IHIGG) + ETAIMJ=ETAIMJ*PARU(152+10*IHIGG) + ENDIF + ENDIF + ETARE=ETARE+ETAREJ + ETAIM=ETAIM+ETAIMJ + 240 CONTINUE + ETA2=ETARE**2+ETAIM**2 + WDTP(I)=FAC*(AS/PARU(1))**2*ETA2 + + ELSEIF(I.EQ.14) THEN +C...h0 -> gamma + gamma; quark, lepton, W+- and H+- loop contributions + ETARE=0D0 + ETAIM=0D0 + JMAX=3*MSTP(1)+1 + IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1 + DO 250 J=1,JMAX + IF(J.LE.2*MSTP(1)) THEN + EJ=KCHG(J,1)/3D0 + EPS=(2D0*PMAS(J,1))**2/SH + ELSEIF(J.LE.3*MSTP(1)) THEN + JL=2*(J-2*MSTP(1))-1 + EJ=KCHG(10+JL,1)/3D0 + EPS=(2D0*PMAS(10+JL,1))**2/SH + ELSEIF(J.EQ.3*MSTP(1)+1) THEN + EPS=(2D0*PMAS(24,1))**2/SH + ELSE + EPS=(2D0*PMAS(37,1))**2/SH + ENDIF +C...Loop integral; function of eps=4m^2/shat. + IF(EPS.LE.1D0) THEN + IF(EPS.GT.1D-4) THEN + ROOT=SQRT(1D0-EPS) + RLN=LOG((1D0+ROOT)/(1D0-ROOT)) + ELSE + RLN=LOG(4D0/EPS-2D0) + ENDIF + PHIRE=-0.25D0*(RLN**2-PARU(1)**2) + PHIIM=0.5D0*PARU(1)*RLN + ELSE + PHIRE=(ASIN(1D0/SQRT(EPS)))**2 + PHIIM=0D0 + ENDIF + IF(J.LE.3*MSTP(1)) THEN +C...Fermion loops: loop integral different for A0; charges. + IF(IHIGG.LE.2) THEN + PHIPRE=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE) + PHIPIM=-0.5D0*EPS*(1D0-EPS)*PHIIM + ELSE + PHIPRE=-0.5D0*EPS*PHIRE + PHIPIM=-0.5D0*EPS*PHIIM + ENDIF + IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN + EJC=3D0*EJ**2 + EJH=PARU(151+10*IHIGG) + ELSEIF(J.LE.2*MSTP(1)) THEN + EJC=3D0*EJ**2 + EJH=PARU(152+10*IHIGG) + ELSE + EJC=EJ**2 + EJH=PARU(153+10*IHIGG) + ENDIF + IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0 + ETAREJ=EJC*EJH*PHIPRE + ETAIMJ=EJC*EJH*PHIPIM + ELSEIF(J.EQ.3*MSTP(1)+1) THEN +C...W loops: loop integral and charges. + ETAREJ=0.5D0+0.75D0*EPS*(1D0+(2D0-EPS)*PHIRE) + ETAIMJ=0.75D0*EPS*(2D0-EPS)*PHIIM + IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN + ETAREJ=ETAREJ*PARU(155+10*IHIGG) + ETAIMJ=ETAIMJ*PARU(155+10*IHIGG) + ENDIF + ELSE +C...Charged H loops: loop integral and charges. + FACHHH=(PMAS(24,1)/PMAS(37,1))**2* + & PARU(158+10*IHIGG+2*(IHIGG/3)) + ETAREJ=EPS*(1D0-EPS*PHIRE)*FACHHH + ETAIMJ=-EPS**2*PHIIM*FACHHH + ENDIF + ETARE=ETARE+ETAREJ + ETAIM=ETAIM+ETAIMJ + 250 CONTINUE + ETA2=ETARE**2+ETAIM**2 + WDTP(I)=FAC*(AEM/PARU(1))**2*0.5D0*ETA2 + + ELSEIF(I.EQ.15) THEN +C...h0 -> gamma + Z0; quark, lepton, W and H+- loop contributions + ETARE=0D0 + ETAIM=0D0 + JMAX=3*MSTP(1)+1 + IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1 + DO 260 J=1,JMAX + IF(J.LE.2*MSTP(1)) THEN + EJ=KCHG(J,1)/3D0 + AJ=SIGN(1D0,EJ+0.1D0) + VJ=AJ-4D0*EJ*XWV + EPS=(2D0*PMAS(J,1))**2/SH + EPSP=(2D0*PMAS(J,1)/PMAS(23,1))**2 + ELSEIF(J.LE.3*MSTP(1)) THEN + JL=2*(J-2*MSTP(1))-1 + EJ=KCHG(10+JL,1)/3D0 + AJ=SIGN(1D0,EJ+0.1D0) + VJ=AJ-4D0*EJ*XWV + EPS=(2D0*PMAS(10+JL,1))**2/SH + EPSP=(2D0*PMAS(10+JL,1)/PMAS(23,1))**2 + ELSE + EPS=(2D0*PMAS(24,1))**2/SH + EPSP=(2D0*PMAS(24,1)/PMAS(23,1))**2 + ENDIF +C...Loop integrals; functions of eps=4m^2/shat and eps'=4m^2/m_Z^2. + IF(EPS.LE.1D0) THEN + ROOT=SQRT(1D0-EPS) + IF(EPS.GT.1D-4) THEN + RLN=LOG((1D0+ROOT)/(1D0-ROOT)) + ELSE + RLN=LOG(4D0/EPS-2D0) + ENDIF + PHIRE=-0.25D0*(RLN**2-PARU(1)**2) + PHIIM=0.5D0*PARU(1)*RLN + PSIRE=0.5D0*ROOT*RLN + PSIIM=-0.5D0*ROOT*PARU(1) + ELSE + PHIRE=(ASIN(1D0/SQRT(EPS)))**2 + PHIIM=0D0 + PSIRE=SQRT(EPS-1D0)*ASIN(1D0/SQRT(EPS)) + PSIIM=0D0 + ENDIF + IF(EPSP.LE.1D0) THEN + ROOT=SQRT(1D0-EPSP) + IF(EPSP.GT.1D-4) THEN + RLN=LOG((1D0+ROOT)/(1D0-ROOT)) + ELSE + RLN=LOG(4D0/EPSP-2D0) + ENDIF + PHIREP=-0.25D0*(RLN**2-PARU(1)**2) + PHIIMP=0.5D0*PARU(1)*RLN + PSIREP=0.5D0*ROOT*RLN + PSIIMP=-0.5D0*ROOT*PARU(1) + ELSE + PHIREP=(ASIN(1D0/SQRT(EPSP)))**2 + PHIIMP=0D0 + PSIREP=SQRT(EPSP-1D0)*ASIN(1D0/SQRT(EPSP)) + PSIIMP=0D0 + ENDIF + FXYRE=EPS*EPSP/(8D0*(EPS-EPSP))*(1D0+EPS*EPSP/(EPS-EPSP)* + & (PHIRE-PHIREP)+2D0*EPS/(EPS-EPSP)*(PSIRE-PSIREP)) + FXYIM=EPS**2*EPSP/(8D0*(EPS-EPSP)**2)* + & (EPSP*(PHIIM-PHIIMP)+2D0*(PSIIM-PSIIMP)) + F1RE=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIRE-PHIREP) + F1IM=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIIM-PHIIMP) + IF(J.LE.3*MSTP(1)) THEN +C...Fermion loops: loop integral different for A0; charges. + IF(IHIGG.EQ.3) FXYRE=0D0 + IF(IHIGG.EQ.3) FXYIM=0D0 + IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN + EJC=-3D0*EJ*VJ + EJH=PARU(151+10*IHIGG) + ELSEIF(J.LE.2*MSTP(1)) THEN + EJC=-3D0*EJ*VJ + EJH=PARU(152+10*IHIGG) + ELSE + EJC=-EJ*VJ + EJH=PARU(153+10*IHIGG) + ENDIF + IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0 + ETAREJ=EJC*EJH*(FXYRE-0.25D0*F1RE) + ETAIMJ=EJC*EJH*(FXYIM-0.25D0*F1IM) + ELSEIF(J.EQ.3*MSTP(1)+1) THEN +C...W loops: loop integral and charges. + HEPS=(1D0+2D0/EPS)*XW/XW1-(5D0+2D0/EPS) + ETAREJ=-XW1*((3D0-XW/XW1)*F1RE+HEPS*FXYRE) + ETAIMJ=-XW1*((3D0-XW/XW1)*F1IM+HEPS*FXYIM) + IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN + ETAREJ=ETAREJ*PARU(155+10*IHIGG) + ETAIMJ=ETAIMJ*PARU(155+10*IHIGG) + ENDIF + ELSE +C...Charged H loops: loop integral and charges. + FACHHH=(PMAS(24,1)/PMAS(37,1))**2*(1D0-2D0*XW)* + & PARU(158+10*IHIGG+2*(IHIGG/3)) + ETAREJ=FACHHH*FXYRE + ETAIMJ=FACHHH*FXYIM + ENDIF + ETARE=ETARE+ETAREJ + ETAIM=ETAIM+ETAIMJ + 260 CONTINUE + ETA2=(ETARE**2+ETAIM**2)/(XW*XW1) + WDTP(I)=FAC*(AEM/PARU(1))**2*(1D0-PMAS(23,1)**2/SH)**3*ETA2 + WID2=WIDS(23,2) + + ELSEIF(I.LE.17) THEN +C...h0 -> Z0 + Z0, W+ + W- + PM1=PMAS(IABS(KFDP(IDC,1)),1) + PG1=PMAS(IABS(KFDP(IDC,1)),2) + IF(MINT(62).GE.1) THEN + IF(MSTP(42).EQ.0.OR.(4D0*(PM1+10D0*PG1)**2.LT.SH.AND. + & CKIN(46).LT.CKIN(45).AND.CKIN(48).LT.CKIN(47).AND. + & MAX(CKIN(45),CKIN(47)).LT.PM1-10D0*PG1)) THEN + MOFSV(IHIGG,I-15)=0 + WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0, + & 1D0-4D0*RM1)) + WID2=1D0 + ELSE + MOFSV(IHIGG,I-15)=1 + RMAS=SQRT(MAX(0D0,SH)) + CALL PYOFSH(1,KFLA,KFDP(IDC,1),KFDP(IDC,2),RMAS,WIDW, + & WID2) + WIDWSV(IHIGG,I-15)=WIDW + WID2SV(IHIGG,I-15)=WID2 + ENDIF + ELSE + IF(MOFSV(IHIGG,I-15).EQ.0) THEN + WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0, + & 1D0-4D0*RM1)) + WID2=1D0 + ELSE + WIDW=WIDWSV(IHIGG,I-15) + WID2=WID2SV(IHIGG,I-15) + ENDIF + ENDIF + WDTP(I)=FAC*WIDW/(2D0*(18-I)) + IF(MSTP(49).NE.0) WDTP(I)=WDTP(I)*PMAS(KFHIGG,1)**2/SHFS + IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)* + & PARU(138+I+10*IHIGG)**2 + WID2=WID2*WIDS(7+I,1) + + ELSEIF(I.EQ.18.AND.IHIGG.GE.2) THEN +C...H0 -> Z0 + h0, A0-> Z0 + h0 + WDTP(I)=FAC*0.5D0*SQRT(MAX(0D0, + & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3 + IF(IHIGG.EQ.2) THEN + WDTP(I)=WDTP(I)*PARU(179)**2 + ELSEIF(IHIGG.EQ.3) THEN + WDTP(I)=WDTP(I)*PARU(186)**2 + ENDIF + WID2=WIDS(23,2)*WIDS(25,2) + + ELSEIF(I.EQ.19.AND.IHIGG.GE.2) THEN +C...H0 -> h0 + h0, A0-> h0 + h0 + WDTP(I)=FAC*0.25D0* + & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1)) + IF(IHIGG.EQ.2) THEN + WDTP(I)=WDTP(I)*PARU(176)**2 + ELSEIF(IHIGG.EQ.3) THEN + WDTP(I)=WDTP(I)*PARU(169)**2 + ENDIF + WID2=WIDS(25,1) + ELSEIF((I.EQ.20.OR.I.EQ.21).AND.IHIGG.GE.2) THEN +C...H0 -> W+/- + H-/+, A0 -> W+/- + H-/+ + WDTP(I)=FAC*0.5D0*SQRT(MAX(0D0, + & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3 + & *PARU(195+IHIGG)**2 + IF(I.EQ.20) THEN + WID2=WIDS(24,2)*WIDS(37,3) + ELSEIF(I.EQ.21) THEN + WID2=WIDS(24,3)*WIDS(37,2) + ENDIF + + ELSEIF(I.EQ.22.AND.IHIGG.EQ.2) THEN +C...H0 -> Z0 + A0. + WDTP(I)=FAC*0.5D0*PARU(187)**2*SQRT(MAX(0D0, + & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3 + WID2=WIDS(36,2)*WIDS(23,2) + + ELSEIF(I.EQ.23.AND.IHIGG.EQ.2) THEN +C...H0 -> h0 + A0. + WDTP(I)=FAC*0.5D0*PARU(180)**2* + & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1)) + WID2=WIDS(25,2)*WIDS(36,2) + + ELSEIF(I.EQ.24.AND.IHIGG.EQ.2) THEN +C...H0 -> A0 + A0 + WDTP(I)=FAC*0.25D0*PARU(177)**2* + & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1)) + WID2=WIDS(36,1) + +CMRENNA++ + ELSE +C...Add in SUSY decays (two-body) by rescaling by phase space factor. + RM10=RM1*SH/PMR**2 + RM20=RM2*SH/PMR**2 + WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20) + WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2) + IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN + WFAC=0D0 + ELSE + WFAC=WFAC/WFAC0 + ENDIF + WDTP(I)=PMAS(KFLA,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC) +CMRENNA-- + IF(KFC2.EQ.KFC1) THEN + WID2=WIDS(KFC1,1) + ELSE + KSGN1=2 + IF(KFDP(IDC,1).LT.0) KSGN1=3 + KSGN2=2 + IF(KFDP(IDC,2).LT.0) KSGN2=3 + WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2) + ENDIF + ENDIF + WDTP(I)=FUDGE*WDTP(I) + WDTP(0)=WDTP(0)+WDTP(I) + IF(MDME(IDC,1).GT.0) THEN + WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 + WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) + WDTE(I,0)=WDTE(I,MDME(IDC,1)) + WDTE(0,0)=WDTE(0,0)+WDTE(I,0) + ENDIF + 270 CONTINUE + + ELSEIF(KFLA.EQ.32) THEN +C...Z'0: + ICASE=1 + XWC=1D0/(16D0*XW*XW1) + FAC=(AEM*XWC/3D0)*SHR + VINT(117)=0D0 + 280 CONTINUE + IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN + VINT(111)=0D0 + VINT(112)=0D0 + VINT(113)=0D0 + VINT(114)=0D0 + VINT(115)=0D0 + VINT(116)=0D0 + ENDIF + IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN + KFAI=IABS(MINT(15)) + EI=KCHG(KFAI,1)/3D0 + AI=SIGN(1D0,EI+0.1D0) + VI=AI-4D0*EI*XWV + KFAIC=1 + IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2 + IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3 + IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4 + IF(KFAI.LE.2.OR.KFAI.EQ.11.OR.KFAI.EQ.12) THEN + VPI=PARU(119+2*KFAIC) + API=PARU(120+2*KFAIC) + ELSEIF(KFAI.LE.4.OR.KFAI.EQ.13.OR.KFAI.EQ.14) THEN + VPI=PARJ(178+2*KFAIC) + API=PARJ(179+2*KFAIC) + ELSE + VPI=PARJ(186+2*KFAIC) + API=PARJ(187+2*KFAIC) + ENDIF + SQMZ=PMAS(23,1)**2 + HZ=SHR*VINT(117) + SQMZP=PMAS(32,1)**2 + HZP=SHR*WDTP(0) + IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR. + & MSTP(44).EQ.7) VINT(111)=1D0 + IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)= + & 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2) + IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)= + & 2D0*XWC*SH*(SH-SQMZP)/((SH-SQMZP)**2+HZP**2) + IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR. + & MSTP(44).EQ.7) VINT(114)=XWC**2*SH**2/((SH-SQMZ)**2+HZ**2) + IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)= + & 2D0*XWC**2*SH**2*((SH-SQMZ)*(SH-SQMZP)+HZ*HZP)/ + & (((SH-SQMZ)**2+HZ**2)*((SH-SQMZP)**2+HZP**2)) + IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR. + & MSTP(44).EQ.7) VINT(116)=XWC**2*SH**2/((SH-SQMZP)**2+HZP**2) + ENDIF + DO 290 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 290 + RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH + RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH + IF(SQRT(RM1)+SQRT(RM2).GT.1D0.OR.MDME(IDC,1).LT.0) GOTO 290 + WID2=1D0 + IF(I.LE.16) THEN + IF(I.LE.8) THEN +C...Z'0 -> q + qbar + EF=KCHG(I,1)/3D0 + AF=SIGN(1D0,EF+0.1D0) + VF=AF-4D0*EF*XWV + IF(I.LE.2) THEN + VPF=PARU(123-2*MOD(I,2)) + APF=PARU(124-2*MOD(I,2)) + ELSEIF(I.LE.4) THEN + VPF=PARJ(182-2*MOD(I,2)) + APF=PARJ(183-2*MOD(I,2)) + ELSE + VPF=PARJ(190-2*MOD(I,2)) + APF=PARJ(191-2*MOD(I,2)) + ENDIF + FCOF=3D0*RADC + IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF* + & PYHFTH(SH,SH*RM1,1D0) + IF(I.EQ.6) WID2=WIDS(6,1) + IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1) + ELSEIF(I.LE.16) THEN +C...Z'0 -> l+ + l-, nu + nubar + EF=KCHG(I+2,1)/3D0 + AF=SIGN(1D0,EF+0.1D0) + VF=AF-4D0*EF*XWV + IF(I.LE.10) THEN + VPF=PARU(127-2*MOD(I,2)) + APF=PARU(128-2*MOD(I,2)) + ELSEIF(I.LE.12) THEN + VPF=PARJ(186-2*MOD(I,2)) + APF=PARJ(187-2*MOD(I,2)) + ELSE + VPF=PARJ(194-2*MOD(I,2)) + APF=PARJ(195-2*MOD(I,2)) + ENDIF + FCOF=1D0 + IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1) + ENDIF + BE34=SQRT(MAX(0D0,1D0-4D0*RM1)) + IF(ICASE.EQ.1) THEN + WDTPZ=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34 + WDTP(I)=FAC*FCOF*(VPF**2*(1D0+2D0*RM1)+ + & APF**2*(1D0-4D0*RM1))*BE34 + ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN + WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)* + & EF*VF+EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)* + & VF**2+(VI*VPI+AI*API)*VINT(115)*VF*VPF+(VPI**2+API**2)* + & VINT(116)*VPF**2)*(1D0+2D0*RM1)+((VI**2+AI**2)*VINT(114)* + & AF**2+(VI*VPI+AI*API)*VINT(115)*AF*APF+(VPI**2+API**2)* + & VINT(116)*APF**2)*(1D0-4D0*RM1))*BE34 + ELSEIF(MINT(61).EQ.2) THEN + FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34 + FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34 + FGZPF=FCOF*EF*VPF*(1D0+2D0*RM1)*BE34 + FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34 + FZZPF=FCOF*(VF*VPF*(1D0+2D0*RM1)+AF*APF*(1D0-4D0*RM1))* + & BE34 + FZPZPF=FCOF*(VPF**2*(1D0+2D0*RM1)+APF**2*(1D0-4D0*RM1))* + & BE34 + ENDIF + ELSEIF(I.EQ.17) THEN +C...Z'0 -> W+ + W- + WDTPZP=PARU(129)**2*XW1**2* + & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3* + & (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2) + IF(ICASE.EQ.1) THEN + WDTPZ=0D0 + WDTP(I)=FAC*WDTPZP + ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN + WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP + ELSEIF(MINT(61).EQ.2) THEN + FGGF=0D0 + FGZF=0D0 + FGZPF=0D0 + FZZF=0D0 + FZZPF=0D0 + FZPZPF=WDTPZP + ENDIF + WID2=WIDS(24,1) + ELSEIF(I.EQ.18) THEN +C...Z'0 -> H+ + H- + CZC=2D0*(1D0-2D0*XW) + BE34C=(1D0-4D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1)) + IF(ICASE.EQ.1) THEN + WDTPZ=0.25D0*PARU(142)**2*CZC**2*BE34C + WDTP(I)=FAC*0.25D0*PARU(143)**2*CZC**2*BE34C + ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN + WDTP(I)=FAC*0.25D0*(EI**2*VINT(111)+PARU(142)*EI*VI* + & VINT(112)*CZC+PARU(143)*EI*VPI*VINT(113)*CZC+PARU(142)**2* + & (VI**2+AI**2)*VINT(114)*CZC**2+PARU(142)*PARU(143)* + & (VI*VPI+AI*API)*VINT(115)*CZC**2+PARU(143)**2* + & (VPI**2+API**2)*VINT(116)*CZC**2)*BE34C + ELSEIF(MINT(61).EQ.2) THEN + FGGF=0.25D0*BE34C + FGZF=0.25D0*PARU(142)*CZC*BE34C + FGZPF=0.25D0*PARU(143)*CZC*BE34C + FZZF=0.25D0*PARU(142)**2*CZC**2*BE34C + FZZPF=0.25D0*PARU(142)*PARU(143)*CZC**2*BE34C + FZPZPF=0.25D0*PARU(143)**2*CZC**2*BE34C + ENDIF + WID2=WIDS(37,1) + ELSEIF(I.EQ.19) THEN +C...Z'0 -> Z0 + gamma. + ELSEIF(I.EQ.20) THEN +C...Z'0 -> Z0 + h0 + FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)) + WDTPZP=PARU(145)**2*4D0*ABS(1D0-2D0*XW)* + & (3D0*RM1+0.25D0*FLAM**2)*FLAM + IF(ICASE.EQ.1) THEN + WDTPZ=0D0 + WDTP(I)=FAC*WDTPZP + ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN + WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP + ELSEIF(MINT(61).EQ.2) THEN + FGGF=0D0 + FGZF=0D0 + FGZPF=0D0 + FZZF=0D0 + FZZPF=0D0 + FZPZPF=WDTPZP + ENDIF + WID2=WIDS(23,2)*WIDS(25,2) + ELSEIF(I.EQ.21.OR.I.EQ.22) THEN +C...Z' -> h0 + A0 or H0 + A0. + BE34C=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3 + IF(I.EQ.21) THEN + CZAH=PARU(186) + CZPAH=PARU(188) + ELSE + CZAH=PARU(187) + CZPAH=PARU(189) + ENDIF + IF(ICASE.EQ.1) THEN + WDTPZ=CZAH**2*BE34C + WDTP(I)=FAC*CZPAH**2*BE34C + ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN + WDTP(I)=FAC*(CZAH**2*(VI**2+AI**2)*VINT(114)+CZAH*CZPAH* + & (VI*VPI+AI*API)*VINT(115)+CZPAH**2*(VPI**2+API**2)* + & VINT(116))*BE34C + ELSEIF(MINT(61).EQ.2) THEN + FGGF=0D0 + FGZF=0D0 + FGZPF=0D0 + FZZF=CZAH**2*BE34C + FZZPF=CZAH*CZPAH*BE34C + FZPZPF=CZPAH**2*BE34C + ENDIF + IF(I.EQ.21) WID2=WIDS(25,2)*WIDS(36,2) + IF(I.EQ.22) WID2=WIDS(35,2)*WIDS(36,2) + ENDIF + IF(ICASE.EQ.1) THEN + VINT(117)=VINT(117)+FAC*WDTPZ + WDTP(I)=FUDGE*WDTP(I) + WDTP(0)=WDTP(0)+WDTP(I) + ENDIF + IF(MDME(IDC,1).GT.0) THEN + IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR. + & (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN + WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 + WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+ + & WDTE(I,MDME(IDC,1)) + WDTE(I,0)=WDTE(I,MDME(IDC,1)) + WDTE(0,0)=WDTE(0,0)+WDTE(I,0) + ENDIF + IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN + IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR. + & MSTP(44).EQ.7) VINT(111)=VINT(111)+FGGF*WID2 + IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=VINT(112)+ + & FGZF*WID2 + IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=VINT(113)+ + & FGZPF*WID2 + IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR. + & MSTP(44).EQ.7) VINT(114)=VINT(114)+FZZF*WID2 + IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=VINT(115)+ + & FZZPF*WID2 + IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR. + & MSTP(44).EQ.7) VINT(116)=VINT(116)+FZPZPF*WID2 + ENDIF + ENDIF + 290 CONTINUE + IF(MINT(61).GE.1) ICASE=3-ICASE + IF(ICASE.EQ.2) GOTO 280 + + ELSEIF(KFLA.EQ.34) THEN +C...W'+/-: + FAC=(AEM/(24D0*XW))*SHR + DO 300 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 300 + RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH + RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH + IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 300 + WID2=1D0 + IF(I.LE.20) THEN + IF(I.LE.16) THEN +C...W'+/- -> q + qbar' + CKMFAC = VCKM((I-1)/4+1,MOD(I-1,4)+1) + FCOF=3D0*CKMFAC*RADC*(PARU(131)**2+PARU(132)**2) + FCOF2=3D0*CKMFAC*RADC*(PARU(131)**2-PARU(132)**2) + IF(KFLR.GT.0) THEN + IF(MOD(I,4).EQ.3) WID2=WIDS(6,2) + IF(MOD(I,4).EQ.0) WID2=WIDS(8,2) + IF(I.GE.13) WID2=WID2*WIDS(7,3) + ELSE + IF(MOD(I,4).EQ.3) WID2=WIDS(6,3) + IF(MOD(I,4).EQ.0) WID2=WIDS(8,3) + IF(I.GE.13) WID2=WID2*WIDS(7,2) + ENDIF + ELSEIF(I.LE.20) THEN +C...W'+/- -> l+/- + nu + FCOF=PARU(133)**2+PARU(134)**2 + FCOF2=PARU(133)**2-PARU(134)**2 + IF(KFLR.GT.0) THEN + IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2) + ELSE + IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3) + ENDIF + ENDIF + WDTP(I)=FAC*0.5*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2) + & *SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)) + IF (RM1.GT.0D0.AND.RM2.GT.0D0) THEN +C...PS 28/06/2010 +C...Inserted (gV2-gA2)*sqrt(m1*m2) term (FCOF2), following M. Chizhov + WDTP(I)=WDTP(I) + FAC*0.5*6D0*FCOF2*SQRT(RM1*RM2) + & *SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)) + ENDIF + ELSEIF(I.EQ.21) THEN +C...W'+/- -> W+/- + Z0 + WDTP(I)=FAC*PARU(135)**2*0.5D0*XW1*(RM1/RM2)* + & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3* + & (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2) + IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(23,2) + IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(23,2) + ELSEIF(I.EQ.23) THEN +C...W'+/- -> W+/- + h0 + FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)) + WDTP(I)=FAC*PARU(146)**2*2D0*(3D0*RM1+0.25D0*FLAM**2)*FLAM + IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2) + IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2) + ENDIF + WDTP(I)=FUDGE*WDTP(I) + WDTP(0)=WDTP(0)+WDTP(I) + IF(MDME(IDC,1).GT.0) THEN + WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 + WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) + WDTE(I,0)=WDTE(I,MDME(IDC,1)) + WDTE(0,0)=WDTE(0,0)+WDTE(I,0) + ENDIF + 300 CONTINUE + + ELSEIF(KFLA.EQ.37) THEN +C...H+/-: +C IF(MSTP(49).EQ.0) THEN + SHFS=SH +C ELSE +C SHFS=PMAS(37,1)**2 +C ENDIF + FAC=(AEM/(8D0*XW))*(SHFS/PMAS(24,1)**2)*SHR + DO 310 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 310 + KFC1=PYCOMP(KFDP(IDC,1)) + KFC2=PYCOMP(KFDP(IDC,2)) + RM1=PMAS(KFC1,1)**2/SH + RM2=PMAS(KFC2,1)**2/SH + IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 310 + WID2=1D0 + IF(I.LE.4) THEN +C...H+/- -> q + qbar' + RM1R=PYMRUN(KFDP(IDC,1),SH)**2/SH + RM2R=PYMRUN(KFDP(IDC,2),SH)**2/SH + WDTP(I)=FAC*3D0*RADC*MAX(0D0,(RM1R*PARU(141)**2+ + & RM2R/PARU(141)**2)*(1D0-RM1R-RM2R)-4D0*RM1R*RM2R)* + & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*(SH/SHFS) + IF(KFLR.GT.0) THEN + IF(I.EQ.3) WID2=WIDS(6,2) + IF(I.EQ.4) WID2=WIDS(7,3)*WIDS(8,2) + ELSE + IF(I.EQ.3) WID2=WIDS(6,3) + IF(I.EQ.4) WID2=WIDS(7,2)*WIDS(8,3) + ENDIF + ELSEIF(I.LE.8) THEN +C...H+/- -> l+/- + nu + WDTP(I)=FAC*((RM1*PARU(141)**2+RM2/PARU(141)**2)* + & (1D0-RM1-RM2)-4D0*RM1*RM2)*SQRT(MAX(0D0, + & (1D0-RM1-RM2)**2-4D0*RM1*RM2))*(SH/SHFS) + IF(KFLR.GT.0) THEN + IF(I.EQ.8) WID2=WIDS(17,3)*WIDS(18,2) + ELSE + IF(I.EQ.8) WID2=WIDS(17,2)*WIDS(18,3) + ENDIF + ELSEIF(I.EQ.9) THEN +C...H+/- -> W+/- + h0. + WDTP(I)=FAC*PARU(195)**2*0.5D0*SQRT(MAX(0D0, + & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3 + IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2) + IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2) + +CMRENNA++ + ELSE +C...Add in SUSY decays (two-body) by rescaling by phase space factor. + RM10=RM1*SH/PMR**2 + RM20=RM2*SH/PMR**2 + WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20) + WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2) + IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN + WFAC=0D0 + ELSE + WFAC=WFAC/WFAC0 + ENDIF + WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC) +CMRENNA-- + KSGN1=2 + IF(KFLS*KFDP(IDC,1).LT.0.AND.KCHG(KFC1,3).EQ.1) KSGN1=3 + KSGN2=2 + IF(KFLS*KFDP(IDC,2).LT.0.AND.KCHG(KFC2,3).EQ.1) KSGN2=3 + WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2) + ENDIF + WDTP(I)=FUDGE*WDTP(I) + WDTP(0)=WDTP(0)+WDTP(I) + IF(MDME(IDC,1).GT.0) THEN + WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 + WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) + WDTE(I,0)=WDTE(I,MDME(IDC,1)) + WDTE(0,0)=WDTE(0,0)+WDTE(I,0) + ENDIF + 310 CONTINUE + + ELSEIF(KFLA.EQ.41) THEN +C...R: + FAC=(AEM/(12D0*XW))*SHR + DO 320 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 320 + RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH + RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH + IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 320 + WID2=1D0 + IF(I.LE.6) THEN +C...R -> q + qbar' + FCOF=3D0*RADC + ELSEIF(I.LE.9) THEN +C...R -> l+ + l'- + FCOF=1D0 + ENDIF + WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)* + & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)) + IF(KFLR.GT.0) THEN + IF(I.EQ.4) WID2=WIDS(6,3) + IF(I.EQ.5) WID2=WIDS(7,3) + IF(I.EQ.6) WID2=WIDS(6,2)*WIDS(8,3) + IF(I.EQ.9) WID2=WIDS(17,3) + ELSE + IF(I.EQ.4) WID2=WIDS(6,2) + IF(I.EQ.5) WID2=WIDS(7,2) + IF(I.EQ.6) WID2=WIDS(6,3)*WIDS(8,2) + IF(I.EQ.9) WID2=WIDS(17,2) + ENDIF + WDTP(I)=FUDGE*WDTP(I) + WDTP(0)=WDTP(0)+WDTP(I) + IF(MDME(IDC,1).GT.0) THEN + WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 + WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) + WDTE(I,0)=WDTE(I,MDME(IDC,1)) + WDTE(0,0)=WDTE(0,0)+WDTE(I,0) + ENDIF + 320 CONTINUE + + ELSEIF(KFLA.EQ.42) THEN +C...LQ (leptoquark). + FAC=(AEM/4D0)*PARU(151)*SHR + DO 330 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 330 + RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH + RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH + IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 330 + WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3 + WID2=1D0 + ILQQ=KFDP(IDC,1)*ISIGN(1,KFLR) + IF(ILQQ.GE.6) WID2=WIDS(ILQQ,2) + IF(ILQQ.LE.-6) WID2=WIDS(-ILQQ,3) + ILQL=KFDP(IDC,2)*ISIGN(1,KFLR) + IF(ILQL.GE.17) WID2=WID2*WIDS(ILQL,2) + IF(ILQL.LE.-17) WID2=WID2*WIDS(-ILQL,3) + WDTP(I)=FUDGE*WDTP(I) + WDTP(0)=WDTP(0)+WDTP(I) + IF(MDME(IDC,1).GT.0) THEN + WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 + WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) + WDTE(I,0)=WDTE(I,MDME(IDC,1)) + WDTE(0,0)=WDTE(0,0)+WDTE(I,0) + ENDIF + 330 CONTINUE + +C...UED: kk state width decays : flav: 451 476 + ELSEIF(IUED(1).EQ.1.AND. + & PYCOMP(ABS(KFLA)).GE.KKFLMI.AND. + & PYCOMP(ABS(KFLA)).LE.KKFLMA) THEN + KCLA=PYCOMP(KFLA) +C...q*_S,q*_D,l*_S,l*_D,gamma*,g*,Z*,W* + RMFLAS=PMAS(KCLA,1) + FACSH=SH/PMAS(KCLA,1)**2 + ALPHEM=PYALEM(RMFLAS**2) + ALPHS=PYALPS(RMFLAS**2) + +C...uedcor parameters (alpha_s is calculated at mkk scale) +C...alpha_em is calculated at z pole ! + ALPHEM=PARU(101) + FACSH=1. + + DO 1070 I=1,MDCY(KCLA,3) + IDC=I+MDCY(KCLA,2)-1 + + IF(MDME(IDC,1).LT.0) GOTO 1070 + KFC1=PYCOMP(ABS(KFDP(IDC,1))) + KFC2=PYCOMP(ABS(KFDP(IDC,2))) + RM1=PMAS(KFC1,1)**2/SH + RM2=PMAS(KFC2,1)**2/SH + IF(SQRT(RM1)+SQRT(RM2).GT.1D0) + & GOTO 1070 + WID2=1D0 + +C...N.B. RINV=RUED(1) + RMKK=RUED(1) + RMWKK=PMAS(475,1) + RMZKK=PMAS(474,1) + SW2=PARU(102) + CW2=1.-SW2 + KKCLA=KCLA-KKFLMI+1 + IF(ABS(KFC1).GE.KKFLMI)KKPART=KFC1 + IF(ABS(KFC2).GE.KKFLMI)KKPART=KFC2 + IF(KKCLA.LE.6) THEN +C...q*_S -> q + gamma* (in first time sw21=0) + FAC=0.25*ALPHEM*RMFLAS*0.5*CW21/CW2*KCHG(KCLA,1)**2/9. +C...Eventually change the following by enabling a choice of open or closed. +C...Only the gamma_kk channel is open. + IF(MOD(I,2).EQ.0) + + WDTP(I)=FAC*FKAC2(RMFLAS,RMKK)*FKAC1(RMKK,RMFLAS)**2 + WDTP(I)=FACSH*WDTP(I) + WID2=WIDS(473,2) + ELSEIF(KKCLA.GT.6.AND.KKCLA.LE.12)THEN +C...q*_D -> q + Z*/W* + FAC=0.25*ALPHEM*RMFLAS/(4.*SW2) + GAMMAW=FAC*FKAC2(RMFLAS,RMWKK)*FKAC1(RMWKK,RMFLAS)**2 + IF(I.EQ.1)THEN +C...q*_D -> q + Z* + WDTP(I)=0.5*GAMMAW + WID2=WIDS(474,2) + ELSEIF(I.EQ.2)THEN +C...q*_D -> q + W* + WDTP(I)=GAMMAW + WID2=WIDS(475,2) + ENDIF + WDTP(I)=FACSH*WDTP(I) +C...q*_D -> q + gamma* is closed + ELSEIF(KKCLA.GT.12.AND.KKCLA.LE.21)THEN +C...l*_S,l*_D -> gamma* + l*_S/l*_D(=nu_l,l) + FAC=ALPHEM/4.*RMFLAS/CW2/8. + RMGAKK=PMAS(473,1) + WDTP(I)=FAC*FKAC2(RMFLAS,RMGAKK)* + + FKAC1(RMGAKK,RMFLAS)**2 + WDTP(I)=FACSH*WDTP(I) + WID2=WIDS(473,2) + ELSEIF(KKCLA.EQ.22)THEN + RMQST=PMAS(KKPART,1) + WID2=WIDS(KKPART,2) +C...g* -> q*_S/q*_D + q + FAC=10.*ALPHS/12.*RMFLAS + WDTP(I)=FAC*FKAC1(RMQST,RMFLAS)**2*FKAC2(RMQST,RMFLAS) + WDTP(I)=FACSH*WDTP(I) + ELSEIF(KKCLA.EQ.23)THEN +C...gamma* decays to graviton + gamma : initial value is used + ICHI=IUED(4)/2 + WDTP(I)=RMFLAS*(RMFLAS/RUED(2))**(IUED(4)+2) + & *CHIDEL(ICHI) + ELSEIF(KKCLA.EQ.24)THEN +C...Z* -> l*_S + l is closed +C... Z* -> l*_D + l + IF(I.LE.3)GOTO 1070 +c... After closing the channels for a Z* decaying into positively charged +C... KK lepton singlets, close the channels for a Z* decaying into negatively +C... charged KK lepton singlets + positively charged SM particles + IF(I.GE.10.AND.I.LE.12)GOTO 1070 + FAC=3./2.*ALPHEM/24./SW2*RMZKK + RMLST=PMAS(KKPART,1) + WDTP(I)=FAC*FKAC1(RMLST,RMZKK)**2*FKAC2(RMLST,RMZKK) + WDTP(I)=FACSH*WDTP(I) + WID2=WIDS(KKPART,2) + ELSEIF(KKCLA.EQ.25)THEN +C...W* -> l*_D lbar + FAC=3.*ALPHEM/12./SW2*RMWKK + RMLST=PMAS(KKPART,1) + WDTP(I)=FAC*FKAC1(RMLST,RMWKK)**2*FKAC2(RMLST,RMWKK) + WDTP(I)=FACSH*WDTP(I) + WID2=WIDS(KKPART,2) + ENDIF + WDTP(0)=WDTP(0)+WDTP(I) + IF(MDME(IDC,1).GT.0) THEN + WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 + WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) + WDTE(I,0)=WDTE(I,MDME(IDC,1)) + WDTE(0,0)=WDTE(0,0)+WDTE(I,0) + ENDIF + 1070 CONTINUE + IUEDPR(KKCLA)=1 + + ELSEIF(KFLA.EQ.KTECHN+111.OR.KFLA.EQ.KTECHN+221) THEN +C...Techni-pi0 and techni-pi0': + FAC=(1D0/(32D0*PARU(1)*RTCM(1)**2))*SHR + DO 340 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 340 + PM1=PMAS(PYCOMP(KFDP(IDC,1)),1) + PM2=PMAS(PYCOMP(KFDP(IDC,2)),1) + RM1=PM1**2/SH + RM2=PM2**2/SH + IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 340 + WID2=1D0 +C...pi_tc -> g + g + IF(I.EQ.8) THEN + FACP=(AS/(4D0*PARU(1))*ITCM(1)/RTCM(1))**2 + & /(8D0*PARU(1))*SH*SHR + IF(KFLA.EQ.KTECHN+111) THEN + FACP=FACP*RTCM(9) + ELSE + FACP=FACP*RTCM(10) + ENDIF + WDTP(I)=FACP + ELSE +C...pi_tc -> f + fbar. + FCOF=1D0 + IKA=IABS(KFDP(IDC,1)) + IF(IKA.LT.10) FCOF=3D0*RADC + HM1=PM1 + HM2=PM2 + IF(IKA.GE.4.AND.IKA.LE.6) THEN + FCOF=FCOF*RTCM(1+IKA)**2 + HM1=PYMRUN(KFDP(IDC,1),SH) + HM2=PYMRUN(KFDP(IDC,2),SH) + ELSEIF(IKA.EQ.15) THEN + FCOF=FCOF*RTCM(8)**2 + ENDIF + WDTP(I)=FAC*FCOF*(HM1+HM2)**2* + & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)) + ENDIF + WDTP(I)=FUDGE*WDTP(I) + WDTP(0)=WDTP(0)+WDTP(I) + IF(MDME(IDC,1).GT.0) THEN + WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 + WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) + WDTE(I,0)=WDTE(I,MDME(IDC,1)) + WDTE(0,0)=WDTE(0,0)+WDTE(I,0) + ENDIF + 340 CONTINUE + + ELSEIF(KFLA.EQ.KTECHN+211) THEN +C...pi+_tc + FAC=(1D0/(32D0*PARU(1)*RTCM(1)**2))*SHR + DO 350 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 350 + PM1=PMAS(PYCOMP(KFDP(IDC,1)),1) + PM2=PMAS(PYCOMP(KFDP(IDC,2)),1) + PM3=0D0 + IF(I.EQ.5) PM3=PMAS(PYCOMP(KFDP(IDC,3)),1) + RM1=PM1**2/SH + RM2=PM2**2/SH + RM3=PM3**2/SH + IF(SQRT(RM1)+SQRT(RM2)+SQRT(RM3).GT.1D0) GOTO 350 + WID2=1D0 +C...pi_tc -> f + f'. + FCOF=1D0 + IF(IABS(KFDP(IDC,1)).LT.10) FCOF=3D0*RADC +C...pi_tc+ -> W b b~ + IF(I.EQ.5.AND.SHR.LT.PMAS(6,1)+PMAS(5,1)) THEN + FCOF=3D0*RADC + XMT2=PMAS(6,1)**2/SH + FACP=FAC/(4D0*PARU(1))*FCOF*XMT2*RTCM(7)**2 + KFC3=PYCOMP(KFDP(IDC,3)) + CHECK = SQRT(RM1)+SQRT(RM2)+SQRT(RM3) + CHECK = SQRT(RM1) + T0 = (1D0-CHECK**2)* + & (XMT2*(6D0*XMT2**2+3D0*XMT2*RM1-4D0*RM1**2)- + & (5D0*XMT2**2+2D0*XMT2*RM1-8D0*RM1**2))/(4D0*XMT2**2) + T1 = (1D0-XMT2)*(RM1-XMT2)*((XMT2**2+XMT2*RM1+4D0*RM1**2) + & -3D0*XMT2**2*(XMT2+RM1))/(2D0*XMT2**3) + T3 = RM1**2/XMT2**3*(3D0*XMT2-4D0*RM1+4D0*XMT2*RM1) + WDTP(I)=FACP*(T0 + T1*LOG((XMT2-CHECK**2)/(XMT2-1D0)) + & +T3*LOG(CHECK)) + IF(KFLR.GT.0) THEN + WID2=WIDS(24,2) + ELSE + WID2=WIDS(24,3) + ENDIF + ELSE + FCOF=1D0 + IKA=IABS(KFDP(IDC,1)) + IF(IKA.LT.10) FCOF=3D0*RADC + HM1=PM1 + HM2=PM2 + IF(I.GE.1.AND.I.LE.5) THEN + IF(I.LE.2) THEN + FCOF=FCOF*RTCM(5)**2 + ELSEIF(I.LE.4) THEN + FCOF=FCOF*RTCM(6)**2 + ELSEIF(I.EQ.5) THEN + FCOF=FCOF*RTCM(7)**2 + ENDIF + HM1=PYMRUN(KFDP(IDC,1),SH) + HM2=PYMRUN(KFDP(IDC,2),SH) + ELSEIF(I.EQ.8) THEN + FCOF=FCOF*RTCM(8)**2 + ENDIF + WDTP(I)=FAC*FCOF*(HM1+HM2)**2* + & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)) + ENDIF + WDTP(I)=FUDGE*WDTP(I) + WDTP(0)=WDTP(0)+WDTP(I) + IF(MDME(IDC,1).GT.0) THEN + WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 + WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) + WDTE(I,0)=WDTE(I,MDME(IDC,1)) + WDTE(0,0)=WDTE(0,0)+WDTE(I,0) + ENDIF + 350 CONTINUE + + ELSEIF(KFLA.EQ.KTECHN+331) THEN +C...Techni-eta. + FAC=(SH/PARP(46)**2)*SHR + DO 360 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 360 + RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH + RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH + IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 360 + WID2=1D0 + IF(I.LE.2) THEN + WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))/(4D0*PARU(1)) + IF(I.EQ.2) WID2=WIDS(6,1) + ELSE + WDTP(I)=FAC*5D0*AS**2/(96D0*PARU(1)**3) + ENDIF + WDTP(I)=FUDGE*WDTP(I) + WDTP(0)=WDTP(0)+WDTP(I) + IF(MDME(IDC,1).GT.0) THEN + WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 + WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) + WDTE(I,0)=WDTE(I,MDME(IDC,1)) + WDTE(0,0)=WDTE(0,0)+WDTE(I,0) + ENDIF + 360 CONTINUE + + ELSEIF(KFLA.EQ.KTECHN+113) THEN +C...Techni-rho0: + ALPRHT=2.16D0*(3D0/ITCM(1)) + FAC=(ALPRHT/12D0)*SHR + FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR + SQMZ=PMAS(23,1)**2 + SQMW=PMAS(24,1)**2 + SHP=SH + CALL PYWIDX(23,SHP,WDTPP,WDTEP) + GMMZ=SHR*WDTPP(0) + XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW)) + BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2) + BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2) + DO 370 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 370 + RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH + RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH + IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 370 + WID2=1D0 + IF(I.EQ.1) THEN +C...rho_tc0 -> W+ + W-. +C... Multiplied by 2 for W^+_T W^-_L + W^+_L W^-_T + WDTP(I)=FAC*RTCM(3)**4* + & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+ + & 2D0*AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))* + & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)* + & RTCM(3)**2/4D0/XW/24D0/RTCM(13)**2*SHR**3 + WID2=WIDS(24,1) + ELSEIF(I.EQ.2) THEN +C...rho_tc0 -> W+ + pi_tc-. +C... Multiplied by 2 for pi_T^+ W^-_T + pi_T^- W^+_T + WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)* + & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+ + & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))* + & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*RM1)* + & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3 + WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3) + ELSEIF(I.EQ.3) THEN +C...rho_tc0 -> pi_tc+ + W-. + WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)* + & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+ + & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))* + & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*RM2)* + & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3 + WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(24,3) + ELSEIF(I.EQ.4) THEN +C...rho_tc0 -> pi_tc+ + pi_tc-. + WDTP(I)=FAC*(1D0-RTCM(3)**2)**2* + & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3 + WID2=WIDS(PYCOMP(KTECHN+211),1) + ELSEIF(I.EQ.5) THEN +C...rho_tc0 -> gamma + pi_tc0 + WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3* + & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2* + & SHR**3 + WID2=WIDS(PYCOMP(KTECHN+111),2) + ELSEIF(I.EQ.6) THEN +C...rho_tc0 -> gamma + pi_tc0' + WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3* + & (1D0-RTCM(4)**2)/24D0/RTCM(12)**2*SHR**3 + WID2=WIDS(PYCOMP(KTECHN+221),2) + ELSEIF(I.EQ.7) THEN +C...rho_tc0 -> Z0 + pi_tc0 + WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3* + & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2* + & XW/XW1*SHR**3 + WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+111),2) + ELSEIF(I.EQ.8) THEN +C...rho_tc0 -> Z0 + pi_tc0' + WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3* + & (1D0-RTCM(4)**2)/24D0/RTCM(12)**2*(1D0-2D0*XW)**2/4D0/ + & XW/XW1*SHR**3 + WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2) + ELSEIF(I.EQ.9) THEN +C...rho_tc0 -> gamma + Z0 + WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3* + & (2D0*RTCM(2)-1D0)**2*RTCM(3)**2/24D0/RTCM(12)**2*SHR**3 + WID2=WIDS(23,2) + ELSEIF(I.EQ.10) THEN +C...rho_tc0 -> Z0 + Z0 + WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3* + & (2D0*RTCM(2)-1D0)**2*RTCM(3)**2*XW/XW1/24D0/RTCM(12)**2* + & SHR**3 + WID2=WIDS(23,1) + ELSE +C...rho_tc0 -> f + fbar. + WID2=1D0 + IF(I.LE.18) THEN + IA=I-10 + FCOF=3D0*RADC + IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1) + ELSE + IA=I-6 + FCOF=1D0 + IF(IA.GE.17) WID2=WIDS(IA,1) + ENDIF + EI=KCHG(IA,1)/3D0 + AI=SIGN(1D0,EI+0.1D0) + VI=AI-4D0*EI*XWV + VALI=0.5D0*(VI+AI) + VARI=0.5D0*(VI-AI) + WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)* + & ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+ + & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*( + & (EI+VALI*BWZR)*(EI+VARI*BWZR)+VALI*VARI*BWZI**2)) + ENDIF + WDTP(I)=FUDGE*WDTP(I) + WDTP(0)=WDTP(0)+WDTP(I) + IF(MDME(IDC,1).GT.0) THEN + WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 + WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) + WDTE(I,0)=WDTE(I,MDME(IDC,1)) + WDTE(0,0)=WDTE(0,0)+WDTE(I,0) + ENDIF + 370 CONTINUE + + ELSEIF(KFLA.EQ.KTECHN+213) THEN +C...Techni-rho+/-: + ALPRHT=2.16D0*(3D0/ITCM(1)) + FAC=(ALPRHT/12D0)*SHR + SQMZ=PMAS(23,1)**2 + SQMW=PMAS(24,1)**2 + SHP=SH + CALL PYWIDX(24,SHP,WDTPP,WDTEP) + GMMW=SHR*WDTPP(0) + FACF=(1D0/12D0)*(AEM**2/ALPRHT)*SHR* + & (0.125D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2) + DO 380 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 380 + RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH + RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH + IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 380 + WID2=1D0 + PCM=.5D0*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)) +c WDTP(I)=AEM*PCM*(AA2*(PCM**2+1.5D0*RM1)+PCM**2*VA2) +c & /3D0*SHR**3 + IF(I.EQ.1) THEN +C...rho_tc+ -> W+ + Z0. +C......Goldstone + WDTP(I)=FAC*RTCM(3)**4* + & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3 + VA2=RTCM(3)**2*(2D0*RTCM(2)-1D0)**2*XW/XW1/RTCM(12)**2 + AA2=RTCM(3)**2/RTCM(13)**2/4D0/XW/XW1 +C......W_L Z_T + WDTP(I)=WDTP(I)+AEM*PCM*(AA2*(PCM**2+1.5D0*RM2)+PCM**2*VA2) + & /3D0*SHR**3 + VA2=0D0 + AA2=RTCM(3)**2/RTCM(13)**2/4D0/XW +C......W_T Z_L + WDTP(I)=WDTP(I)+AEM*PCM*(AA2*(PCM**2+1.5D0*RM1)+PCM**2*VA2) + & /3D0*SHR**3 + IF(KFLR.GT.0) THEN + WID2=WIDS(24,2)*WIDS(23,2) + ELSE + WID2=WIDS(24,3)*WIDS(23,2) + ENDIF + ELSEIF(I.EQ.2) THEN +C...rho_tc+ -> W+ + pi_tc0. + WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)* + & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+ + & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))* + & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)* + & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3 + IF(KFLR.GT.0) THEN + WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+111),2) + ELSE + WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+111),2) + ENDIF + ELSEIF(I.EQ.3) THEN +C...rho_tc+ -> pi_tc+ + Z0. + WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)* + & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+ + & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))* + & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMZ/SH)* + & (1D0-RTCM(3)**2)/4D0/XW/XW1/24D0/RTCM(13)**2*SHR**3+ + & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3* + & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2* + & SHR**3*XW/XW1 + IF(KFLR.GT.0) THEN + WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(23,2) + ELSE + WID2=WIDS(PYCOMP(KTECHN+211),3)*WIDS(23,2) + ENDIF + ELSEIF(I.EQ.4) THEN +C...rho_tc+ -> pi_tc+ + pi_tc0. + WDTP(I)=FAC*(1D0-RTCM(3)**2)**2* + & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3 + IF(KFLR.GT.0) THEN + WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(PYCOMP(KTECHN+111),2) + ELSE + WID2=WIDS(PYCOMP(KTECHN+211),3)*WIDS(PYCOMP(KTECHN+111),2) + ENDIF + ELSEIF(I.EQ.5) THEN +C...rho_tc+ -> pi_tc+ + gamma + WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3* + & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2* + & SHR**3 + IF(KFLR.GT.0) THEN + WID2=WIDS(PYCOMP(KTECHN+211),2) + ELSE + WID2=WIDS(PYCOMP(KTECHN+211),3) + ENDIF + ELSEIF(I.EQ.6) THEN +C...rho_tc+ -> W+ + pi_tc0' + WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3* + & (1D0-RTCM(4)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3 + IF(KFLR.GT.0) THEN + WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+221),2) + ELSE + WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+221),2) + ENDIF + ELSEIF(I.EQ.7) THEN +C...rho_tc+ -> W+ + gamma + WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3* + & (2D0*RTCM(2)-1D0)**2*RTCM(3)**2/24D0/RTCM(12)**2*SHR**3 + IF(KFLR.GT.0) THEN + WID2=WIDS(24,2) + ELSE + WID2=WIDS(24,3) + ENDIF + ELSE +C...rho_tc+ -> f + fbar'. + IA=I-7 + WID2=1D0 + IF(IA.LE.16) THEN + FCOF=3D0*RADC*VCKM((IA-1)/4+1,MOD(IA-1,4)+1) + IF(KFLR.GT.0) THEN + IF(MOD(IA,4).EQ.3) WID2=WIDS(6,2) + IF(MOD(IA,4).EQ.0) WID2=WIDS(8,2) + IF(IA.GE.13) WID2=WID2*WIDS(7,3) + ELSE + IF(MOD(IA,4).EQ.3) WID2=WIDS(6,3) + IF(MOD(IA,4).EQ.0) WID2=WIDS(8,3) + IF(IA.GE.13) WID2=WID2*WIDS(7,2) + ENDIF + ELSE + FCOF=1D0 + IF(KFLR.GT.0) THEN + IF(IA.EQ.20) WID2=WIDS(17,3)*WIDS(18,2) + ELSE + IF(IA.EQ.20) WID2=WIDS(17,2)*WIDS(18,3) + ENDIF + ENDIF + WDTP(I)=FACF*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)* + & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)) + ENDIF + WDTP(I)=FUDGE*WDTP(I) + WDTP(0)=WDTP(0)+WDTP(I) + IF(MDME(IDC,1).GT.0) THEN + WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 + WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) + WDTE(I,0)=WDTE(I,MDME(IDC,1)) + WDTE(0,0)=WDTE(0,0)+WDTE(I,0) + ENDIF + 380 CONTINUE + + ELSEIF(KFLA.EQ.KTECHN+223) THEN +C...Techni-omega: + ALPRHT=2.16D0*(3D0/ITCM(1)) + FAC=(ALPRHT/12D0)*SHR + FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR*(2D0*RTCM(2)-1D0)**2 + SQMZ=PMAS(23,1)**2 + SHP=SH + CALL PYWIDX(23,SHP,WDTPP,WDTEP) + GMMZ=SHR*WDTPP(0) + BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2) + BWZI=-(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2) + DO 390 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 390 + RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH + RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH + IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 390 + WID2=1D0 + IF(I.EQ.1) THEN +C...omega_tc0 -> gamma + pi_tc0. + WDTP(I)=AEM/24D0/RTCM(12)**2*(1D0-RTCM(3)**2)* + & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*SHR**3 + WID2=WIDS(PYCOMP(KTECHN+111),2) + ELSEIF(I.EQ.2) THEN +C...omega_tc0 -> Z0 + pi_tc0 + WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3* + & (1D0-RTCM(3)**2)/24D0/RTCM(12)**2*(1D0-2D0*XW)**2/4D0/ + & XW/XW1*SHR**3 + WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+111),2) + ELSEIF(I.EQ.3) THEN +C...omega_tc0 -> gamma + pi_tc0' + WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3* + & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(4)**2)/24D0/RTCM(12)**2* + & SHR**3 + WID2=WIDS(PYCOMP(KTECHN+221),2) + ELSEIF(I.EQ.4) THEN +C...omega_tc0 -> Z0 + pi_tc0' + WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3* + & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(4)**2)/24D0/RTCM(12)**2* + & XW/XW1*SHR**3 + WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2) + ELSEIF(I.EQ.5) THEN +C...omega_tc0 -> W+ + pi_tc- + WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3* + & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3+ + & FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*RTCM(11)**2* + & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3 + WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3) + ELSEIF(I.EQ.6) THEN +C...omega_tc0 -> pi_tc+ + W- + WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3* + & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3+ + & FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*RTCM(11)**2* + & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3 + WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+211),2) + ELSEIF(I.EQ.7) THEN +C...omega_tc0 -> W+ + W-. +C... Multiplied by 2 for W^+_T W^-_L + W^+_L W^-_T + WDTP(I)=FAC*RTCM(3)**4*RTCM(11)**2* + & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+ + & 2D0*AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3* + & RTCM(3)**2/4D0/XW/24D0/RTCM(12)**2*SHR**3 + WID2=WIDS(24,1) + ELSEIF(I.EQ.8) THEN +C...omega_tc0 -> pi_tc+ + pi_tc-. + WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*RTCM(11)**2* + & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3 + WID2=WIDS(PYCOMP(KTECHN+211),1) +C...omega_tc0 -> gamma + Z0 + ELSEIF(I.EQ.9) THEN + WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3* + & RTCM(3)**2/24D0/RTCM(12)**2*SHR**3 + WID2=WIDS(23,2) +C...omega_tc0 -> Z0 + Z0 + ELSEIF(I.EQ.10) THEN + WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3* + & RTCM(3)**2*(XW1-XW)**2/XW/XW1/4D0 + & /24D0/RTCM(12)**2*SHR**3 + WID2=WIDS(23,1) + ELSE +C...omega_tc0 -> f + fbar. + WID2=1D0 + IF(I.LE.18) THEN + IA=I-10 + FCOF=3D0*RADC + IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1) + ELSE + IA=I-8 + FCOF=1D0 + IF(IA.GE.17) WID2=WIDS(IA,1) + ENDIF + EI=KCHG(IA,1)/3D0 + AI=SIGN(1D0,EI+0.1D0) + VI=AI-4D0*EI*XWV + VALI=-0.5D0*(VI+AI) + VARI=-0.5D0*(VI-AI) + WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)* + & ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+ + & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*( + & (EI+VALI*BWZR)*(EI+VARI*BWZR)+VALI*VARI*BWZI**2)) + ENDIF + WDTP(I)=FUDGE*WDTP(I) + WDTP(0)=WDTP(0)+WDTP(I) + IF(MDME(IDC,1).GT.0) THEN + WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 + WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) + WDTE(I,0)=WDTE(I,MDME(IDC,1)) + WDTE(0,0)=WDTE(0,0)+WDTE(I,0) + ENDIF + 390 CONTINUE + +C.....V8 -> quark anti-quark + ELSEIF(KFLA.EQ.KTECHN+100021) THEN + FAC=AS/6D0*SHR + TANT3=RTCM(21) + IF(ITCM(2).EQ.0) THEN + IMDL=1 + ELSEIF(ITCM(2).EQ.1) THEN + IMDL=2 + ENDIF + DO 400 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 400 + PM1=PMAS(PYCOMP(KFDP(IDC,1)),1) + RM1=PM1**2/SH + IF(RM1.GT.0.25D0) GOTO 400 + WID2=1D0 + IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN + FMIX=1D0/TANT3**2 + ELSE + FMIX=TANT3**2 + ENDIF + WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*FMIX + IF(I.EQ.6) WID2=WIDS(6,1) + WDTP(I)=FUDGE*WDTP(I) + WDTP(0)=WDTP(0)+WDTP(I) + IF(MDME(IDC,1).GT.0) THEN + WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 + WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) + WDTE(I,0)=WDTE(I,MDME(IDC,1)) + WDTE(0,0)=WDTE(0,0)+WDTE(I,0) + ENDIF + 400 CONTINUE + + ELSEIF(KFLA.EQ.KTECHN+100111.OR.KFLA.EQ.KTECHN+200111) THEN + FAC=(1D0/(4D0*PARU(1)*RTCM(1)**2))*SHR + CLEBF=0D0 + DO 410 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 410 + RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH + RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH + IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 410 + WID2=1D0 +C...pi_tc -> g + g + IF(I.EQ.7) THEN + IF(KFLA.EQ.KTECHN+100111) THEN + CLEBG=4D0/3D0 + ELSE + CLEBG=5D0/3D0 + ENDIF + FACP=(AS/(8D0*PARU(1))*ITCM(1)/RTCM(1))**2 + & /(2D0*PARU(1))*SH*SHR*CLEBG + WDTP(I)=FACP + ELSE +C...pi_tc -> f + fbar. + IF(I.EQ.6) WID2=WIDS(6,1) + FCOF=1D0 + IKA=IABS(KFDP(IDC,1)) + IF(IKA.LT.10) FCOF=3D0*RADC + HM1=PYMRUN(KFDP(IDC,1),SH) + WDTP(I)=FAC*FCOF*HM1**2*CLEBF* + & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)) + ENDIF + WDTP(I)=FUDGE*WDTP(I) + WDTP(0)=WDTP(0)+WDTP(I) + IF(MDME(IDC,1).GT.0) THEN + WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 + WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) + WDTE(I,0)=WDTE(I,MDME(IDC,1)) + WDTE(0,0)=WDTE(0,0)+WDTE(I,0) + ENDIF + 410 CONTINUE + + ELSEIF(KFLA.GE.KTECHN+100113.AND.KFLA.LE.KTECHN+400113) THEN + FAC=AS/6D0*SHR + ALPRHT=2.16D0*(3D0/ITCM(1)) + TANT3=RTCM(21) + SIN2T=2D0*TANT3/(TANT3**2+1D0) + SINT3=TANT3/SQRT(TANT3**2+1D0) + CSXPP=RTCM(22) + RM82=RTCM(27)**2 + X12=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*COS(RTCM(30))+ + & RTCM(31)*SQRT(1D0-RTCM(31)**2)*COS(RTCM(32)))/SQRT(2D0) + X21=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*SIN(RTCM(30))+ + & RTCM(31)*SQRT(1D0-RTCM(31)**2)*SIN(RTCM(32)))/SQRT(2D0) + X11=(.25D0*(RTCM(29)**2+RTCM(31)**2+2D0)- + & SINT3**2)*2D0 + X22=(.25D0*(2D0-RTCM(29)**2-RTCM(31)**2)- + & SINT3**2)*2D0 + CALL PYWIDX(KTECHN+100021,SH,WDTPP,WDTEP) + + IF(WDTPP(0).GT.RTCM(33)*SHR) WDTPP(0)=RTCM(33)*SHR + GMV8=SHR*WDTPP(0) + RMV8=PMAS(PYCOMP(KTECHN+100021),1) + FV8RE=SH*(SH-RMV8**2)/((SH-RMV8**2)**2+GMV8**2) + FV8IM=SH*GMV8/((SH-RMV8**2)**2+GMV8**2) + IF(ITCM(2).EQ.0) THEN + IMDL=1 + ELSE + IMDL=2 + ENDIF + DO 420 I=1,MDCY(KC,3) + IF(I.EQ.7.AND.(KFLA.EQ.KTECHN+200113.OR. + & KFLA.EQ.KTECHN+300113)) GOTO 420 + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 420 + RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH + RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH + IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 420 + WID2=1D0 + IF(I.LE.6) THEN + IF(I.EQ.6) WID2=WIDS(6,1) + XIG=1D0 + IF(KFLA.EQ.KTECHN+200113) THEN + XIG=0D0 + XIJ=X12 + ELSEIF(KFLA.EQ.KTECHN+300113) THEN + XIG=0D0 + XIJ=X21 + ELSEIF(KFLA.EQ.KTECHN+100113) THEN + XIJ=X11 + ELSE + XIJ=X22 + ENDIF + IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN + FMIX=1D0/TANT3/SIN2T + ELSE + FMIX=-TANT3/SIN2T + ENDIF + XFAC=(XIG+FMIX*XIJ*FV8RE)**2+(FMIX*XIJ*FV8IM)**2 + WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*AS/ALPRHT*XFAC + ELSEIF(I.EQ.7) THEN + WDTP(I)=SHR*AS**2/(4D0*ALPRHT) + ELSEIF(KFLA.EQ.KTECHN+400113.AND.I.LE.9) THEN + PSH=SHR*(1D0-RM1)/2D0 + WDTP(I)=AS/9D0*PSH**3/RM82 + IF(I.EQ.8) THEN + WDTP(I)=2D0*WDTP(I)*CSXPP**2 + WID2=WIDS(PYCOMP(KFDP(IDC,1)),2) + ELSE + WDTP(I)=5D0*WDTP(I) + WID2=WIDS(PYCOMP(KFDP(IDC,1)),2) + ENDIF + ENDIF + WDTP(I)=FUDGE*WDTP(I) + WDTP(0)=WDTP(0)+WDTP(I) + IF(MDME(IDC,1).GT.0) THEN + WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 + WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) + WDTE(I,0)=WDTE(I,MDME(IDC,1)) + WDTE(0,0)=WDTE(0,0)+WDTE(I,0) + ENDIF + 420 CONTINUE + + ELSEIF(KFLA.EQ.KEXCIT+1) THEN +C...d* excited quark. + FAC=(SH/RTCM(41)**2)*SHR + DO 430 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 430 + RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH + RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH + IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 430 + WID2=1D0 + IF(I.EQ.1) THEN +C...d* -> g + d. + WDTP(I)=FAC*AS*RTCM(45)**2/3D0 + WID2=1D0 + ELSEIF(I.EQ.2) THEN +C...d* -> gamma + d. + QF=-RTCM(43)/2D0+RTCM(44)/6D0 + WDTP(I)=FAC*AEM*QF**2/4D0 + WID2=1D0 + ELSEIF(I.EQ.3) THEN +C...d* -> Z0 + d. + QF=-RTCM(43)*XW1/2D0-RTCM(44)*XW/6D0 + WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)* + & (1D0-RM1)**2*(2D0+RM1) + WID2=WIDS(23,2) + ELSEIF(I.EQ.4) THEN +C...d* -> W- + u. + WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)* + & (1D0-RM1)**2*(2D0+RM1) + IF(KFLR.GT.0) WID2=WIDS(24,3) + IF(KFLR.LT.0) WID2=WIDS(24,2) + ENDIF + WDTP(I)=FUDGE*WDTP(I) + WDTP(0)=WDTP(0)+WDTP(I) + IF(MDME(IDC,1).GT.0) THEN + WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 + WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) + WDTE(I,0)=WDTE(I,MDME(IDC,1)) + WDTE(0,0)=WDTE(0,0)+WDTE(I,0) + ENDIF + 430 CONTINUE + + ELSEIF(KFLA.EQ.KEXCIT+2) THEN +C...u* excited quark. + FAC=(SH/RTCM(41)**2)*SHR + DO 440 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 440 + RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH + RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH + IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 440 + WID2=1D0 + IF(I.EQ.1) THEN +C...u* -> g + u. + WDTP(I)=FAC*AS*RTCM(45)**2/3D0 + WID2=1D0 + ELSEIF(I.EQ.2) THEN +C...u* -> gamma + u. + QF=RTCM(43)/2D0+RTCM(44)/6D0 + WDTP(I)=FAC*AEM*QF**2/4D0 + WID2=1D0 + ELSEIF(I.EQ.3) THEN +C...u* -> Z0 + u. + QF=RTCM(43)*XW1/2D0-RTCM(44)*XW/6D0 + WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)* + & (1D0-RM1)**2*(2D0+RM1) + WID2=WIDS(23,2) + ELSEIF(I.EQ.4) THEN +C...u* -> W+ + d. + WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)* + & (1D0-RM1)**2*(2D0+RM1) + IF(KFLR.GT.0) WID2=WIDS(24,2) + IF(KFLR.LT.0) WID2=WIDS(24,3) + ENDIF + WDTP(I)=FUDGE*WDTP(I) + WDTP(0)=WDTP(0)+WDTP(I) + IF(MDME(IDC,1).GT.0) THEN + WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 + WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) + WDTE(I,0)=WDTE(I,MDME(IDC,1)) + WDTE(0,0)=WDTE(0,0)+WDTE(I,0) + ENDIF + 440 CONTINUE + + ELSEIF(KFLA.EQ.KEXCIT+11) THEN +C...e* excited lepton. + FAC=(SH/RTCM(41)**2)*SHR + DO 450 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 450 + RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH + RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH + IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 450 + WID2=1D0 + IF(I.EQ.1) THEN +C...e* -> gamma + e. + QF=-RTCM(43)/2D0-RTCM(44)/2D0 + WDTP(I)=FAC*AEM*QF**2/4D0 + WID2=1D0 + ELSEIF(I.EQ.2) THEN +C...e* -> Z0 + e. + QF=-RTCM(43)*XW1/2D0+RTCM(44)*XW/2D0 + WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)* + & (1D0-RM1)**2*(2D0+RM1) + WID2=WIDS(23,2) + ELSEIF(I.EQ.3) THEN +C...e* -> W- + nu. + WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)* + & (1D0-RM1)**2*(2D0+RM1) + IF(KFLR.GT.0) WID2=WIDS(24,3) + IF(KFLR.LT.0) WID2=WIDS(24,2) + ENDIF + WDTP(I)=FUDGE*WDTP(I) + WDTP(0)=WDTP(0)+WDTP(I) + IF(MDME(IDC,1).GT.0) THEN + WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 + WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) + WDTE(I,0)=WDTE(I,MDME(IDC,1)) + WDTE(0,0)=WDTE(0,0)+WDTE(I,0) + ENDIF + 450 CONTINUE + + ELSEIF(KFLA.EQ.KEXCIT+12) THEN +C...nu*_e excited neutrino. + FAC=(SH/RTCM(41)**2)*SHR + DO 460 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 460 + RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH + RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH + IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 460 + WID2=1D0 + IF(I.EQ.1) THEN +C...nu*_e -> Z0 + nu*_e. + QF=RTCM(43)*XW1/2D0+RTCM(44)*XW/2D0 + WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)* + & (1D0-RM1)**2*(2D0+RM1) + WID2=WIDS(23,2) + ELSEIF(I.EQ.2) THEN +C...nu*_e -> W+ + e. + WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)* + & (1D0-RM1)**2*(2D0+RM1) + IF(KFLR.GT.0) WID2=WIDS(24,2) + IF(KFLR.LT.0) WID2=WIDS(24,3) + ENDIF + WDTP(I)=FUDGE*WDTP(I) + WDTP(0)=WDTP(0)+WDTP(I) + IF(MDME(IDC,1).GT.0) THEN + WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 + WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) + WDTE(I,0)=WDTE(I,MDME(IDC,1)) + WDTE(0,0)=WDTE(0,0)+WDTE(I,0) + ENDIF + 460 CONTINUE + + ELSEIF(KFLA.EQ.KDIMEN+39) THEN +C...G* (graviton resonance): + FAC=(PARP(50)**2/PARU(1))*SHR + DO 470 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 470 + RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH + RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH + IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 470 + WID2=1D0 + IF(I.LE.8) THEN +C...G* -> q + qbar + FCOF=3D0*RADC + IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF* + & PYHFTH(SH,SH*RM1,1D0) + WDTP(I)=FAC*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))**3* + & (1D0+8D0*RM1/3D0)/320D0 + IF(I.EQ.6) WID2=WIDS(6,1) + IF(I.EQ.7.OR.I.EQ.8) WID2=WIDS(I,1) + ELSEIF(I.LE.16) THEN +C...G* -> l+ + l-, nu + nubar + FCOF=1D0 + WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))**3* + & (1D0+8D0*RM1/3D0)/320D0 + IF(I.EQ.15.OR.I.EQ.16) WID2=WIDS(2+I,1) + ELSEIF(I.EQ.17) THEN +C...G* -> g + g. + WDTP(I)=FAC/20D0 + ELSEIF(I.EQ.18) THEN +C...G* -> gamma + gamma. + WDTP(I)=FAC/160D0 + ELSEIF(I.EQ.19) THEN +C...G* -> Z0 + Z0. + WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))*(13D0/12D0+ + & 14D0*RM1/3D0+4D0*RM1**2)/160D0 + WID2=WIDS(23,1) + ELSEIF(I.EQ.20) THEN +C...G* -> W+ + W-. + WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))*(13D0/12D0+ + & 14D0*RM1/3D0+4D0*RM1**2)/80D0 + WID2=WIDS(24,1) + ENDIF + WDTP(I)=FUDGE*WDTP(I) + WDTP(0)=WDTP(0)+WDTP(I) + IF(MDME(IDC,1).GT.0) THEN + WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 + WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) + WDTE(I,0)=WDTE(I,MDME(IDC,1)) + WDTE(0,0)=WDTE(0,0)+WDTE(I,0) + ENDIF + 470 CONTINUE + + ELSEIF(KFLA.EQ.9900012.OR.KFLA.EQ.9900014.OR.KFLA.EQ.9900016) THEN +C...nu_eR, nu_muR, nu_tauR: righthanded Majorana neutrinos. + PMWR=MAX(1.001D0*SHR,PMAS(PYCOMP(9900024),1)) + FAC=(AEM**2/(768D0*PARU(1)*XW**2))*SHR**5/PMWR**4 + DO 480 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 480 + PM1=PMAS(PYCOMP(KFDP(IDC,1)),1) + PM2=PMAS(PYCOMP(KFDP(IDC,2)),1) + PM3=PMAS(PYCOMP(KFDP(IDC,3)),1) + IF(PM1+PM2+PM3.GE.SHR) GOTO 480 + WID2=1D0 + IF(I.LE.9) THEN +C...nu_lR -> l- qbar q' + FCOF=3D0*RADC*VCKM((I-1)/3+1,MOD(I-1,3)+1) + IF(MOD(I,3).EQ.0) WID2=WIDS(6,2) + ELSEIF(I.LE.18) THEN +C...nu_lR -> l+ q qbar' + FCOF=3D0*RADC*VCKM((I-10)/3+1,MOD(I-10,3)+1) + IF(MOD(I-9,3).EQ.0) WID2=WIDS(6,3) + ELSE +C...nu_lR -> l- l'+ nu_lR' + charge conjugate. + FCOF=1D0 + WID2=WIDS(PYCOMP(KFDP(IDC,3)),2) + ENDIF + X=(PM1+PM2+PM3)/SHR + FX=1D0-8D0*X**2+8D0*X**6-X**8-24D0*X**4*LOG(X) + Y=(SHR/PMWR)**2 + FY=(12D0*(1D0-Y)*LOG(1D0-Y)+12D0*Y-6D0*Y**2-2D0*Y**3)/Y**4 + WDTP(I)=FAC*FCOF*FX*FY + WDTP(I)=FUDGE*WDTP(I) + WDTP(0)=WDTP(0)+WDTP(I) + IF(MDME(IDC,1).GT.0) THEN + WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 + WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) + WDTE(I,0)=WDTE(I,MDME(IDC,1)) + WDTE(0,0)=WDTE(0,0)+WDTE(I,0) + ENDIF + 480 CONTINUE + + ELSEIF(KFLA.EQ.9900023) THEN +C...Z_R0: + FAC=(AEM/(48D0*XW*XW1*(1D0-2D0*XW)))*SHR + DO 490 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 490 + RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH + RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH + IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 490 + WID2=1D0 + SYMMET=1D0 + IF(I.LE.6) THEN +C...Z_R0 -> q + qbar + EF=KCHG(I,1)/3D0 + AF=SIGN(1D0,EF+0.1D0)*(1D0-2D0*XW) + VF=SIGN(1D0,EF+0.1D0)-4D0*EF*XW + FCOF=3D0*RADC + IF(I.EQ.6) WID2=WIDS(6,1) + ELSEIF(I.EQ.7.OR.I.EQ.10.OR.I.EQ.13) THEN +C...Z_R0 -> l+ + l- + AF=-(1D0-2D0*XW) + VF=-1D0+4D0*XW + FCOF=1D0 + ELSEIF(I.EQ.8.OR.I.EQ.11.OR.I.EQ.14) THEN +C...Z0 -> nu_L + nu_Lbar, assumed Majorana. + AF=-2D0*XW + VF=0D0 + FCOF=1D0 + SYMMET=0.5D0 + ELSEIF(I.LE.15) THEN +C...Z0 -> nu_R + nu_R, assumed Majorana. + AF=2D0*XW1 + VF=0D0 + FCOF=1D0 + WID2=WIDS(PYCOMP(KFDP(IDC,1)),1) + SYMMET=0.5D0 + ENDIF + WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))* + & SQRT(MAX(0D0,1D0-4D0*RM1))*SYMMET + WDTP(I)=FUDGE*WDTP(I) + WDTP(0)=WDTP(0)+WDTP(I) + IF(MDME(IDC,1).GT.0) THEN + WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 + WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) + WDTE(I,0)=WDTE(I,MDME(IDC,1)) + WDTE(0,0)=WDTE(0,0)+WDTE(I,0) + ENDIF + 490 CONTINUE + + ELSEIF(KFLA.EQ.9900024) THEN +C...W_R+/-: + FAC=(AEM/(24D0*XW))*SHR + DO 500 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 500 + RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH + RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH + IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 500 + WID2=1D0 + IF(I.LE.9) THEN +C...W_R+/- -> q + qbar' + FCOF=3D0*RADC*VCKM((I-1)/3+1,MOD(I-1,3)+1) + IF(KFLR.GT.0) THEN + IF(MOD(I,3).EQ.0) WID2=WIDS(6,2) + ELSE + IF(MOD(I,3).EQ.0) WID2=WIDS(6,3) + ENDIF + ELSEIF(I.LE.12) THEN +C...W_R+/- -> l+/- + nu_R + FCOF=1D0 + ENDIF + WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)* + & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)) + WDTP(I)=FUDGE*WDTP(I) + WDTP(0)=WDTP(0)+WDTP(I) + IF(MDME(IDC,1).GT.0) THEN + WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 + WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) + WDTE(I,0)=WDTE(I,MDME(IDC,1)) + WDTE(0,0)=WDTE(0,0)+WDTE(I,0) + ENDIF + 500 CONTINUE + + ELSEIF(KFLA.EQ.9900041) THEN +C...H_L++/--: + FAC=(1D0/(8D0*PARU(1)))*SHR + DO 510 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 510 + RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH + RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH + IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 510 + WID2=1D0 + IF(I.LE.6) THEN +C...H_L++/-- -> l+/- + l'+/- + FCOF=PARP(180+3*((IABS(KFDP(IDC,1))-11)/2)+ + & (IABS(KFDP(IDC,2))-9)/2)**2 + IF(KFDP(IDC,1).NE.KFDP(IDC,2)) FCOF=2D0*FCOF + ELSEIF(I.EQ.7) THEN +C...H_L++/-- -> W_L+/- + W_L+/- + FCOF=0.5D0*PARP(190)**4*PARP(192)**2/PMAS(24,1)**2* + & (3D0*RM1+0.25D0/RM1-1D0) + WID2=WIDS(24,4+(1-KFLS)/2) + ENDIF + WDTP(I)=FAC*FCOF* + & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)) + WDTP(I)=FUDGE*WDTP(I) + WDTP(0)=WDTP(0)+WDTP(I) + IF(MDME(IDC,1).GT.0) THEN + WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 + WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) + WDTE(I,0)=WDTE(I,MDME(IDC,1)) + WDTE(0,0)=WDTE(0,0)+WDTE(I,0) + ENDIF + 510 CONTINUE + + ELSEIF(KFLA.EQ.9900042) THEN +C...H_R++/--: + FAC=(1D0/(8D0*PARU(1)))*SHR + DO 520 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 520 + RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH + RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH + IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 520 + WID2=1D0 + IF(I.LE.6) THEN +C...H_R++/-- -> l+/- + l'+/- + FCOF=PARP(180+3*((IABS(KFDP(IDC,1))-11)/2)+ + & (IABS(KFDP(IDC,2))-9)/2)**2 + IF(KFDP(IDC,1).NE.KFDP(IDC,2)) FCOF=2D0*FCOF + ELSEIF(I.EQ.7) THEN +C...H_R++/-- -> W_R+/- + W_R+/- + FCOF=PARP(191)**2*(3D0*RM1+0.25D0/RM1-1D0) + WID2=WIDS(PYCOMP(9900024),4+(1-KFLS)/2) + ENDIF + WDTP(I)=FAC*FCOF* + & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)) + WDTP(I)=FUDGE*WDTP(I) + WDTP(0)=WDTP(0)+WDTP(I) + IF(MDME(IDC,1).GT.0) THEN + WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 + WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) + WDTE(I,0)=WDTE(I,MDME(IDC,1)) + WDTE(0,0)=WDTE(0,0)+WDTE(I,0) + ENDIF + 520 CONTINUE + + ELSEIF(KFLA.EQ.KTECHN+115) THEN +C...Techni-a2: +C...Need to update to alpha_rho + ALPRHT=2.16D0*(3D0/ITCM(1))*RTCM(47)**2 + FAC=(ALPRHT/12D0)*SHR + FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR + SQMZ=PMAS(23,1)**2 + SQMW=PMAS(24,1)**2 + SHP=SH + CALL PYWIDX(23,SHP,WDTPP,WDTEP) + GMMZ=SHR*WDTPP(0) + XWRHT=1D0/(4D0*XW*(1D0-XW)) + BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2) + BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2) + DO 530 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 530 + RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH + RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH + IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 530 + WID2=1D0 + PCM=.5D0*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)) + IF(I.LE.4) THEN + FACPV=PCM**2 + FACPA=PCM**2+1.5D0*RM1 + VA2=0D0 + AA2=0D0 +C...a2_tc0 -> W+ + W- + IF(I.EQ.1) THEN + AA2=2D0*RTCM(3)**2/4D0/XW/RTCM(49)**2 +C...Multiplied by 2 for W^+_T W^-_L + W^+_L W^-_T.(KL) + WID2=WIDS(24,1) +C...a2_tc0 -> W+ + pi_tc- + c.c. + ELSEIF(I.EQ.2.OR.I.EQ.3) THEN + AA2=(1D0-RTCM(3)**2)/4D0/XW/RTCM(49)**2 + IF(I.EQ.6) THEN + WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3) + ELSE + WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+211),2) + ENDIF + ELSEIF(I.EQ.4) THEN +C...a2_tc0 -> Z0 + pi_tc0' + VA2=(1D0-RTCM(4)**2)/4D0/XW/XW1/RTCM(48)**2 + WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2) + ENDIF + WDTP(I)=AEM*SHR**3*PCM/3D0*(VA2*FACPV+AA2*FACPA) + ELSEIF(I.GE.5.AND.I.LE.10) THEN + FACPV=PCM**2*(1D0+RM1+RM2)+3D0*RM1*RM2 + FACPA=PCM**2*(1D0+RM1+RM2) + VA2=0D0 + AA2=0D0 + IF(I.EQ.5) THEN +C...a_T^0 -> gamma rho_T^0 + VA2=(2D0*RTCM(2)-1D0)**2/RTCM(50)**4 + WID2=WIDS(PYCOMP(KTECHN+113),2) + ELSEIF(I.EQ.6) THEN +C...a_T^0 -> gamma omega_T + VA2=1D0/RTCM(50)**4 + WID2=WIDS(PYCOMP(KTECHN+223),2) + ELSEIF(I.EQ.7.OR.I.EQ.8) THEN +C...a_T^0 -> W^+- rho_T^-+ + AA2=.25D0/XW/RTCM(51)**4 + IF(I.EQ.7) THEN + WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+213),3) + ELSE + WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+213),2) + ENDIF + ELSEIF(I.EQ.9) THEN +C...a_T^0 -> Z^0 rho_T^0 + VA2=(2D0*RTCM(2)-1D0)**2*XW/XW1/RTCM(50)**4 + WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+113),2) + ELSEIF(I.EQ.10) THEN +C...a_T^0 -> Z^0 omega_T + VA2=.25D0*(1D0-2D0*XW)**2/XW/XW1/RTCM(50)**4 + WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+223),2) + ENDIF + WDTP(I)=AEM*SHR**5*PCM/12D0*(VA2*FACPV+AA2*FACPA) + ELSE +C...a2_tc0 -> f + fbar. + WID2=1D0 + IF(I.LE.18) THEN + IA=I-10 + FCOF=3D0*RADC + IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1) + ELSE + IA=I-8 + FCOF=1D0 + IF(IA.GE.17) WID2=WIDS(IA,1) + ENDIF + EI=KCHG(IA,1)/3D0 + AI=SIGN(1D0,EI+0.1D0) + VI=AI-4D0*EI*XWV + VALI=0.5D0*(VI+AI) + VARI=0.5D0*(VI-AI) + WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)* + & ((VALI*BWZR)**2+(VALI*BWZI)**2+ + & (VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*( + & (VALI*BWZR)*(VARI*BWZR)+VALI*VARI*BWZI**2)) + ENDIF + WDTP(I)=FUDGE*WDTP(I) + WDTP(0)=WDTP(0)+WDTP(I) + IF(MDME(IDC,1).GT.0) THEN + WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 + WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) + WDTE(I,0)=WDTE(I,MDME(IDC,1)) + WDTE(0,0)=WDTE(0,0)+WDTE(I,0) + ENDIF + 530 CONTINUE + + ELSEIF(KFLA.EQ.KTECHN+215) THEN +C...Techni-a2+/-: + ALPRHT=2.16D0*(3D0/ITCM(1))*RTCM(47)**2 + FAC=(ALPRHT/12D0)*SHR + SQMZ=PMAS(23,1)**2 + SQMW=PMAS(24,1)**2 + SHP=SH + CALL PYWIDX(24,SHP,WDTPP,WDTEP) + GMMW=SHR*WDTPP(0) + FACF=(1D0/12D0)*(AEM**2/ALPRHT)*SHR* + & (0.125D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2) + DO 540 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 540 + RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH + RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH + IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 540 + WID2=1D0 + PCM=.5D0*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)) + IF(KFLR.GT.0) THEN + ICHANN=2 + ELSE + ICHANN=3 + ENDIF + IF(I.LE.7) THEN + AA2=0 + VA2=0 +C...a2_tc+ -> gamma + W+. + IF(I.EQ.1) THEN + AA2=RTCM(3)**2/RTCM(49)**2 + WID2=WIDS(24,ICHANN) +C...a2_tc+ -> gamma + pi_tc+. + ELSEIF(I.EQ.2) THEN + AA2=(1D0-RTCM(3)**2)/RTCM(49)**2 + WID2=WIDS(PYCOMP(KTECHN+211),ICHANN) +C...a2_tc+ -> W+ + Z + ELSEIF(I.EQ.3) THEN + AA2=RTCM(3)**2*(1D0/4D0/XW1 + + & (XW-XW1)**2/4./XW/XW1)/RTCM(49)**2 + WID2=WIDS(24,ICHANN)*WIDS(23,2) +C...a2_tc+ -> W+ + pi_tc0. + ELSEIF(I.EQ.4) THEN + AA2=(1D0-RTCM(3)**2)/4D0/XW/RTCM(49)**2 + WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+111),2) +C...a2_tc+ -> W+ + pi_tc'0. + ELSEIF(I.EQ.5) THEN + VA2=(1D0-RTCM(4)**2)/4D0/XW/RTCM(48)**2 + WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+221),2) +C...a2_tc+ -> Z0 + pi_tc+. + ELSEIF(I.EQ.6) THEN + AA2=(1D0-RTCM(3)**2)/4D0/XW/XW1*(1D0-2D0*XW)**2/ + & RTCM(49)**2 + WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+211),ICHANN) + ENDIF + WDTP(I)=AEM*PCM*(AA2*(PCM**2+1.5D0*RM1)+PCM**2*VA2) + & /3D0*SHR**3 + ELSEIF(I.LE.10) THEN + FACPV=PCM**2*(1D0+RM1+RM2)+3D0*RM1*RM2 + FACPA=PCM**2*(1D0+RM1+RM2) + VA2=0D0 + AA2=0D0 +C...a2_tc+ -> gamma + rho_tc+ + IF(I.EQ.7) THEN + VA2=(2D0*RTCM(2)-1D0)**2/RTCM(50)**4 + WID2=WIDS(PYCOMP(KTECHN+213),ICHANN) +C...a2_tc+ -> W+ + rho_T^0 + ELSEIF(I.EQ.8) THEN + AA2=1D0/(4D0*XW)/RTCM(51)**4 + WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+113),2) +C...a2_tc+ -> W+ + omega_T + ELSEIF(I.EQ.9) THEN + VA2=.25D0/XW/RTCM(50)**4 + WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+223),2) +C...a2_tc+ -> Z^0 + rho_T^+ + ELSEIF(I.EQ.10) THEN + VA2=(2D0*RTCM(2)-1D0)**2*XW/XW1/RTCM(50)**4 + AA2=1D0/(4D0*XW*XW1)/RTCM(51)**4 + WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+213),ICHANN) + ENDIF + WDTP(I)=AEM*SHR**5*PCM/12D0*(VA2*FACPV+AA2*FACPA) + ELSE +C...a2_tc+ -> f + fbar'. + IA=I-10 + WID2=1D0 + IF(IA.LE.16) THEN + FCOF=3D0*RADC*VCKM((IA-1)/4+1,MOD(IA-1,4)+1) + IF(KFLR.GT.0) THEN + IF(MOD(IA,4).EQ.3) WID2=WIDS(6,2) + IF(MOD(IA,4).EQ.0) WID2=WIDS(8,2) + IF(IA.GE.13) WID2=WID2*WIDS(7,3) + ELSE + IF(MOD(IA,4).EQ.3) WID2=WIDS(6,3) + IF(MOD(IA,4).EQ.0) WID2=WIDS(8,3) + IF(IA.GE.13) WID2=WID2*WIDS(7,2) + ENDIF + ELSE + FCOF=1D0 + IF(KFLR.GT.0) THEN + IF(IA.EQ.20) WID2=WIDS(17,3)*WIDS(18,2) + ELSE + IF(IA.EQ.20) WID2=WIDS(17,2)*WIDS(18,3) + ENDIF + ENDIF + WDTP(I)=FACF*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)* + & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)) + ENDIF + WDTP(I)=FUDGE*WDTP(I) + WDTP(0)=WDTP(0)+WDTP(I) + IF(MDME(IDC,1).GT.0) THEN + WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 + WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) + WDTE(I,0)=WDTE(I,MDME(IDC,1)) + WDTE(0,0)=WDTE(0,0)+WDTE(I,0) + ENDIF + 540 CONTINUE + + ENDIF + MINT(61)=0 + MINT(62)=0 + MINT(63)=0 + RETURN + END + +C*********************************************************************** + +C...PYOFSH +C...Calculates partial width and differential cross-section maxima +C...of channels/processes not allowed on mass-shell, and selects +C...masses in such channels/processes. + + SUBROUTINE PYOFSH(MOFSH,KFMO,KFD1,KFD2,PMMO,RET1,RET2) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) + COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) + SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/, + &/PYINT2/,/PYINT5/ +C...Local arrays. + DIMENSION KFD(2),MBW(2),PMD(2),PGD(2),PMG(2),PML(2),PMU(2), + &PMH(2),ATL(2),ATU(2),ATH(2),RMG(2),INX1(100),XPT1(100), + &FPT1(100),INX2(100),XPT2(100),FPT2(100),WDTP(0:400), + &WDTE(0:400,0:5) + +C...Find if particles equal, maximum mass, matrix elements, etc. + MINT(51)=0 + ISUB=MINT(1) + KFD(1)=IABS(KFD1) + KFD(2)=IABS(KFD2) + MEQL=0 + IF(KFD(1).EQ.KFD(2)) MEQL=1 + MLM=0 + IF(MOFSH.GE.2.AND.MEQL.EQ.1) MLM=INT(1.5D0+PYR(0)) + IF(MOFSH.LE.2.OR.MOFSH.EQ.5) THEN + NOFF=44 + PMMX=PMMO + ELSE + NOFF=40 + PMMX=VINT(1) + IF(CKIN(2).GT.CKIN(1)) PMMX=MIN(CKIN(2),VINT(1)) + ENDIF + MMED=0 + IF((KFMO.EQ.25.OR.KFMO.EQ.35.OR.KFMO.EQ.36).AND.MEQL.EQ.1.AND. + &(KFD(1).EQ.23.OR.KFD(1).EQ.24)) MMED=1 + IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(1).EQ.23.OR. + &KFD(1).EQ.24).AND.(KFD(2).EQ.23.OR.KFD(2).EQ.24)) MMED=2 + IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(2).EQ.25.OR. + &KFD(2).EQ.35.OR.KFD(2).EQ.36)) MMED=3 + LOOP=1 + +C...Find where Breit-Wigners are required, else select discrete masses. + 100 DO 110 I=1,2 + KFCA=PYCOMP(KFD(I)) + IF(KFCA.GT.0) THEN + PMD(I)=PMAS(KFCA,1) + PGD(I)=PMAS(KFCA,2) + ELSE + PMD(I)=0D0 + PGD(I)=0D0 + ENDIF + IF(MSTP(42).LE.0.OR.PGD(I).LT.PARP(41)) THEN + MBW(I)=0 + PMG(I)=PMD(I) + RMG(I)=(PMG(I)/PMMX)**2 + ELSE + MBW(I)=1 + ENDIF + 110 CONTINUE + +C...Find allowed mass range and Breit-Wigner parameters. + DO 120 I=1,2 + IF(MOFSH.EQ.1.AND.LOOP.EQ.1.AND.MBW(I).EQ.1) THEN + PML(I)=PARP(42) + PMU(I)=PMMX-PARP(42) + IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I)) + IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1 + ELSEIF(MBW(I).EQ.1.AND.MOFSH.NE.5) THEN + ILM=I + IF(MLM.EQ.2) ILM=3-I + PML(I)=MAX(CKIN(NOFF+2*ILM-1),PARP(42)) + IF(MBW(3-I).EQ.0) THEN + PMU(I)=PMMX-PMD(3-I) + ELSE + PMU(I)=PMMX-MAX(CKIN(NOFF+5-2*ILM),PARP(42)) + ENDIF + IF(CKIN(NOFF+2*ILM).GT.CKIN(NOFF+2*ILM-1)) PMU(I)= + & MIN(PMU(I),CKIN(NOFF+2*ILM)) + IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX) + IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX) + IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1 + IF(MBW(I).EQ.1) THEN + ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I))) + ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I))) + IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)* + & PGD(I))) + ENDIF + ELSEIF(MBW(I).EQ.1.AND.MOFSH.EQ.5) THEN + ILM=I + IF(MLM.EQ.2) ILM=3-I + PML(I)=MAX(CKIN(48+I),PARP(42)) + PMU(I)=PMMX-MAX(CKIN(51-I),PARP(42)) + IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I)) + IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX) + IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX) + IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1 + IF(MBW(I).EQ.1) THEN + ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I))) + ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I))) + IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)* + & PGD(I))) + ENDIF + ENDIF + 120 CONTINUE + IF(MBW(1).LT.0.OR.MBW(2).LT.0.OR.(MBW(1).EQ.0.AND.MBW(2).EQ.0)) + &THEN + CALL PYERRM(3,'(PYOFSH:) no allowed decay product masses') + MINT(51)=1 + RETURN + ENDIF + +C...Calculation of partial width of resonance. + IF(MOFSH.EQ.1) THEN + +C..If only one integration, pick that to be the inner. + IF(MBW(1).EQ.0) THEN + PM2=PMD(1) + PMD(1)=PMD(2) + PGD(1)=PGD(2) + PML(1)=PML(2) + PMU(1)=PMU(2) + ELSEIF(MBW(2).EQ.0) THEN + PM2=PMD(2) + ENDIF + +C...Start outer loop of integration. + IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN + ATL2=ATAN((PML(2)**2-PMD(2)**2)/(PMD(2)*PGD(2))) + ATU2=ATAN((PMU(2)**2-PMD(2)**2)/(PMD(2)*PGD(2))) + NPT2=1 + XPT2(1)=1D0 + INX2(1)=0 + FMAX2=0D0 + ENDIF + 130 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN + PM2S=PMD(2)**2+PMD(2)*PGD(2)*TAN(ATL2+XPT2(NPT2)*(ATU2-ATL2)) + PM2=MIN(PMU(2),MAX(PML(2),SQRT(MAX(0D0,PM2S)))) + ENDIF + RM2=(PM2/PMMX)**2 + +C...Start inner loop of integration. + PML1=PML(1) + PMU1=MIN(PMU(1),PMMX-PM2) + IF(MEQL.EQ.1) PMU1=MIN(PMU1,PM2) + ATL1=ATAN((PML1**2-PMD(1)**2)/(PMD(1)*PGD(1))) + ATU1=ATAN((PMU1**2-PMD(1)**2)/(PMD(1)*PGD(1))) + IF(PML1+PARJ(64).GE.PMU1.OR.ATL1+1D-7.GE.ATU1) THEN + FUNC2=0D0 + GOTO 180 + ENDIF + NPT1=1 + XPT1(1)=1D0 + INX1(1)=0 + FMAX1=0D0 + 140 PM1S=PMD(1)**2+PMD(1)*PGD(1)*TAN(ATL1+XPT1(NPT1)*(ATU1-ATL1)) + PM1=MIN(PMU1,MAX(PML1,SQRT(MAX(0D0,PM1S)))) + RM1=(PM1/PMMX)**2 + +C...Evaluate function value - inner loop. + FUNC1=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)) + IF(MMED.EQ.1) FUNC1=FUNC1*((1D0-RM1-RM2)**2+8D0*RM1*RM2) + IF(MMED.EQ.2) FUNC1=FUNC1**3*(1D0+10D0*RM1+10D0*RM2+RM1**2+ + & RM2**2+10D0*RM1*RM2) + IF(FUNC1.GT.FMAX1) FMAX1=FUNC1 + FPT1(NPT1)=FUNC1 + +C...Go to next position in inner loop. + IF(NPT1.EQ.1) THEN + NPT1=NPT1+1 + XPT1(NPT1)=0D0 + INX1(NPT1)=1 + GOTO 140 + ELSEIF(NPT1.LE.8) THEN + NPT1=NPT1+1 + IF(NPT1.LE.4.OR.NPT1.EQ.6) ISH1=1 + ISH1=ISH1+1 + XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1))) + INX1(NPT1)=INX1(ISH1) + INX1(ISH1)=NPT1 + GOTO 140 + ELSEIF(NPT1.LT.100) THEN + ISN1=ISH1 + 150 ISH1=ISH1+1 + IF(ISH1.GT.NPT1) ISH1=2 + IF(ISH1.EQ.ISN1) GOTO 160 + DFPT1=ABS(FPT1(ISH1)-FPT1(INX1(ISH1))) + IF(DFPT1.LT.PARP(43)*FMAX1) GOTO 150 + NPT1=NPT1+1 + XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1))) + INX1(NPT1)=INX1(ISH1) + INX1(ISH1)=NPT1 + GOTO 140 + ENDIF + +C...Calculate integral over inner loop. + 160 FSUM1=0D0 + DO 170 IPT1=2,NPT1 + FSUM1=FSUM1+0.5D0*(FPT1(IPT1)+FPT1(INX1(IPT1)))* + & (XPT1(INX1(IPT1))-XPT1(IPT1)) + 170 CONTINUE + FUNC2=FSUM1*(ATU1-ATL1)/PARU(1) + 180 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN + IF(FUNC2.GT.FMAX2) FMAX2=FUNC2 + FPT2(NPT2)=FUNC2 + +C...Go to next position in outer loop. + IF(NPT2.EQ.1) THEN + NPT2=NPT2+1 + XPT2(NPT2)=0D0 + INX2(NPT2)=1 + GOTO 130 + ELSEIF(NPT2.LE.8) THEN + NPT2=NPT2+1 + IF(NPT2.LE.4.OR.NPT2.EQ.6) ISH2=1 + ISH2=ISH2+1 + XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2))) + INX2(NPT2)=INX2(ISH2) + INX2(ISH2)=NPT2 + GOTO 130 + ELSEIF(NPT2.LT.100) THEN + ISN2=ISH2 + 190 ISH2=ISH2+1 + IF(ISH2.GT.NPT2) ISH2=2 + IF(ISH2.EQ.ISN2) GOTO 200 + DFPT2=ABS(FPT2(ISH2)-FPT2(INX2(ISH2))) + IF(DFPT2.LT.PARP(43)*FMAX2) GOTO 190 + NPT2=NPT2+1 + XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2))) + INX2(NPT2)=INX2(ISH2) + INX2(ISH2)=NPT2 + GOTO 130 + ENDIF + +C...Calculate integral over outer loop. + 200 FSUM2=0D0 + DO 210 IPT2=2,NPT2 + FSUM2=FSUM2+0.5D0*(FPT2(IPT2)+FPT2(INX2(IPT2)))* + & (XPT2(INX2(IPT2))-XPT2(IPT2)) + 210 CONTINUE + FSUM2=FSUM2*(ATU2-ATL2)/PARU(1) + IF(MEQL.EQ.1) FSUM2=2D0*FSUM2 + ELSE + FSUM2=FUNC2 + ENDIF + +C...Save result; second integration for user-selected mass range. + IF(LOOP.EQ.1) WIDW=FSUM2 + WID2=FSUM2 + IF(LOOP.EQ.1.AND.(CKIN(46).GE.CKIN(45).OR.CKIN(48).GE.CKIN(47) + & .OR.MAX(CKIN(45),CKIN(47)).GE.1.01D0*PARP(42))) THEN + LOOP=2 + GOTO 100 + ENDIF + RET1=WIDW + RET2=WID2/WIDW + +C...Select two decay product masses of a resonance. + ELSEIF(MOFSH.EQ.2.OR.MOFSH.EQ.5) THEN + 220 DO 230 I=1,2 + IF(MBW(I).EQ.0) GOTO 230 + PMBW=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)* + & (ATU(I)-ATL(I))) + PMG(I)=MIN(PMU(I),MAX(PML(I),SQRT(MAX(0D0,PMBW)))) + RMG(I)=(PMG(I)/PMMX)**2 + 230 CONTINUE + IF((MEQL.EQ.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR. + & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) GOTO 220 + +C...Weight with matrix element (if none known, use beta factor). + FLAM=SQRT(MAX(0D0,(1D0-RMG(1)-RMG(2))**2-4D0*RMG(1)*RMG(2))) + IF(MMED.EQ.1) THEN + WTBE=FLAM*((1D0-RMG(1)-RMG(2))**2+8D0*RMG(1)*RMG(2)) + ELSEIF(MMED.EQ.2) THEN + WTBE=FLAM**3*(1D0+10D0*RMG(1)+10D0*RMG(2)+RMG(1)**2+ + & RMG(2)**2+10D0*RMG(1)*RMG(2)) + ELSEIF(MMED.EQ.3) THEN + WTBE=FLAM*(RMG(1)+FLAM**2/12D0) + ELSE + WTBE=FLAM + ENDIF + IF(WTBE.LT.PYR(0)) GOTO 220 + RET1=PMG(1) + RET2=PMG(2) + +C...Find suitable set of masses for initialization of 2 -> 2 processes. + ELSEIF(MOFSH.EQ.3) THEN + IF(MBW(1).NE.0.AND.MBW(2).EQ.0) THEN + PMG(1)=MIN(PMD(1),0.5D0*(PML(1)+PMU(1))) + PMG(2)=PMD(2) + ELSEIF(MBW(2).NE.0.AND.MBW(1).EQ.0) THEN + PMG(1)=PMD(1) + PMG(2)=MIN(PMD(2),0.5D0*(PML(2)+PMU(2))) + ELSE + IDIV=-1 + 240 IDIV=IDIV+1 + PMG(1)=MIN(PMD(1),0.1D0*(IDIV*PML(1)+(10-IDIV)*PMU(1))) + PMG(2)=MIN(PMD(2),0.1D0*(IDIV*PML(2)+(10-IDIV)*PMU(2))) + IF(IDIV.LE.9.AND.PMG(1)+PMG(2).GT.0.9D0*PMMX) GOTO 240 + ENDIF + RET1=PMG(1) + RET2=PMG(2) + +C...Evaluate importance of excluded tails of Breit-Wigners. + IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2) + & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2 + IF(MEQL.LE.1) THEN + VINT(80)=1D0 + DO 250 I=1,2 + IF(MBW(I).NE.0) VINT(80)=VINT(80)*1.25D0*(ATU(I)-ATL(I))/ + & PARU(1) + 250 CONTINUE + ELSE + VINT(80)=(1.25D0/PARU(1))**2*MAX((ATU(1)-ATL(1))* + & (ATH(2)-ATL(2)),(ATH(1)-ATL(1))*(ATU(2)-ATL(2))) + ENDIF + IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.30.OR.ISUB.EQ.35).AND. + & MSTP(43).NE.2) VINT(80)=2D0*VINT(80) + IF(ISUB.EQ.22.AND.MSTP(43).NE.2) VINT(80)=4D0*VINT(80) + IF(MEQL.GE.1) VINT(80)=2D0*VINT(80) + +C...Pick one particle to be the lighter (if improves efficiency). + ELSEIF(MOFSH.EQ.4) THEN + IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2) + & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2 + 260 IF(MEQL.EQ.2) MLM=INT(1.5D0+PYR(0)) + +C...Select two masses according to Breit-Wigner + flat in s + 1/s. + DO 270 I=1,2 + IF(MBW(I).EQ.0) GOTO 270 + PMV=PMU(I) + IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I) + ATV=ATU(I) + IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I) + RBR=PYR(0) + IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR. + & ISUB.EQ.35).AND.MSTP(43).NE.2) RBR=2D0*RBR + IF(RBR.LT.0.8D0) THEN + PMSR=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*(ATV-ATL(I))) + PMG(I)=MIN(PMV,MAX(PML(I),SQRT(MAX(0D0,PMSR)))) + ELSEIF(RBR.LT.0.9D0) THEN + PMG(I)=SQRT(MAX(0D0,PML(I)**2+PYR(0)*(PMV**2-PML(I)**2))) + ELSEIF(RBR.LT.1.5D0) THEN + PMG(I)=PML(I)*(PMV/PML(I))**PYR(0) + ELSE + PMG(I)=SQRT(MAX(0D0,PML(I)**2*PMV**2/(PML(I)**2+PYR(0)* + & (PMV**2-PML(I)**2)))) + ENDIF + 270 CONTINUE + IF((MEQL.GE.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR. + & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) THEN + IF(MINT(48).EQ.1.AND.MSTP(171).EQ.0) THEN + NGEN(0,1)=NGEN(0,1)+1 + NGEN(MINT(1),1)=NGEN(MINT(1),1)+1 + GOTO 260 + ELSE + MINT(51)=1 + RETURN + ENDIF + ENDIF + RET1=PMG(1) + RET2=PMG(2) + +C...Give weight for selected mass distribution. + VINT(80)=1D0 + DO 280 I=1,2 + IF(MBW(I).EQ.0) GOTO 280 + PMV=PMU(I) + IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I) + ATV=ATU(I) + IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I) + F0=PMD(I)*PGD(I)/((PMG(I)**2-PMD(I)**2)**2+ + & (PMD(I)*PGD(I))**2)/PARU(1) + F1=1D0 + F2=1D0/PMG(I)**2 + F3=1D0/PMG(I)**4 + FI0=(ATV-ATL(I))/PARU(1) + FI1=PMV**2-PML(I)**2 + FI2=2D0*LOG(PMV/PML(I)) + FI3=1D0/PML(I)**2-1D0/PMV**2 + IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR. + & ISUB.EQ.35).AND.MSTP(43).NE.2) THEN + VINT(80)=VINT(80)*20D0/(8D0+(FI0/F0)*(F1/FI1+6D0*F2/FI2+ + & 5D0*F3/FI3)) + ELSE + VINT(80)=VINT(80)*10D0/(8D0+(FI0/F0)*(F1/FI1+F2/FI2)) + ENDIF + VINT(80)=VINT(80)*FI0 + 280 CONTINUE + IF(MEQL.GE.1) VINT(80)=2D0*VINT(80) + ENDIF + + RETURN + END + +C*********************************************************************** + +C...PYRECO +C...Handles the possibility of colour reconnection in W+W- events, +C...Based on the main scenarios of the Sjostrand and Khoze study: +C...I, II, II', intermediate and instantaneous; plus one model +C...along the lines of the Gustafson and Hakkinen: GH. +C...Note: also handles Z0 Z0 and W-W+ events, but notation below +C...is as if first resonance is W+ and second W-. + + SUBROUTINE PYRECO(IW1,IW2,NSD1,NAFT1) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter value; number of points in MC integration. + PARAMETER (NPT=100) +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/ +C...Local arrays. + DIMENSION NBEG(2),NEND(2),INP(50),INM(50),BEWW(3),XP(3),XM(3), + &V1(3),V2(3),BETP(50,4),DIRP(50,3),BETM(50,4),DIRM(50,3), + &XD(4),XB(4),IAP(NPT),IAM(NPT),WTA(NPT),V1P(3),V2P(3),V1M(3), + &V2M(3),Q(4,3),XPP(3),XMM(3),IPC(20),IMC(20),TC(0:20),TPC(20), + &TMC(20),IJOIN(100) + +C...Functions to give four-product and to do determinants. + FOUR(I,J)=P(I,4)*P(J,4)-P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3) + DETER(I,J,L)=Q(I,1)*Q(J,2)*Q(L,3)-Q(I,1)*Q(L,2)*Q(J,3)+ + &Q(J,1)*Q(L,2)*Q(I,3)-Q(J,1)*Q(I,2)*Q(L,3)+ + &Q(L,1)*Q(I,2)*Q(J,3)-Q(L,1)*Q(J,2)*Q(I,3) + +C...Only allow fraction of recoupling for GH, intermediate and +C...instantaneous. + IF(MSTP(115).EQ.5.OR.MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN + IF(PYR(0).GT.PARP(120)) RETURN + ENDIF + ISUB=MINT(1) + +C...Common part for scenarios I, II, II', and GH. + IF(MSTP(115).EQ.1.OR.MSTP(115).EQ.2.OR.MSTP(115).EQ.3.OR. + &MSTP(115).EQ.5) THEN + +C...Read out frequently-used parameters. + PI=PARU(1) + HBAR=PARU(3) + PMW=PMAS(24,1) + IF(ISUB.EQ.22) PMW=PMAS(23,1) + PGW=PMAS(24,2) + IF(ISUB.EQ.22) PGW=PMAS(23,2) + TFRAG=PARP(115) + RHAD=PARP(116) + FACT=PARP(117) + BLOWR=PARP(118) + BLOWT=PARP(119) + +C...Find range of decay products of the W's. +C...Background: the W's are stored in IW1 and IW2. +C...Their direct decay products in NSD1+1 through NSD1+4. +C...Products after shower (if any) in NSD1+5 through NAFT1 +C...for first W and in NAFT1+1 through N for the second. + IF(NAFT1.GT.NSD1+4) THEN + NBEG(1)=NSD1+5 + NEND(1)=NAFT1 + ELSE + NBEG(1)=NSD1+1 + NEND(1)=NSD1+2 + ENDIF + IF(N.GT.NAFT1) THEN + NBEG(2)=NAFT1+1 + NEND(2)=N + ELSE + NBEG(2)=NSD1+3 + NEND(2)=NSD1+4 + ENDIF + +C...Rearrange parton shower products along strings. + NOLD=N + CALL PYPREP(NSD1+1) + IF(MINT(51).NE.0) RETURN + +C...Find partons pointing back to W+ and W-; store them with quark +C...end of string first. + NNP=0 + NNM=0 + ISGP=0 + ISGM=0 + DO 120 I=NOLD+1,N + IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 120 + IF(IABS(K(I,2)).GE.22) GOTO 120 + IF(K(I,3).GE.NBEG(1).AND.K(I,3).LE.NEND(1)) THEN + IF(ISGP.EQ.0) ISGP=ISIGN(1,K(I,2)) + NNP=NNP+1 + IF(ISGP.EQ.1) THEN + INP(NNP)=I + ELSE + DO 100 I1=NNP,2,-1 + INP(I1)=INP(I1-1) + 100 CONTINUE + INP(1)=I + ENDIF + IF(K(I,1).EQ.1) ISGP=0 + ELSEIF(K(I,3).GE.NBEG(2).AND.K(I,3).LE.NEND(2)) THEN + IF(ISGM.EQ.0) ISGM=ISIGN(1,K(I,2)) + NNM=NNM+1 + IF(ISGM.EQ.1) THEN + INM(NNM)=I + ELSE + DO 110 I1=NNM,2,-1 + INM(I1)=INM(I1-1) + 110 CONTINUE + INM(1)=I + ENDIF + IF(K(I,1).EQ.1) ISGM=0 + ENDIF + 120 CONTINUE + +C...Boost to W+W- rest frame (not strictly needed). + DO 130 J=1,3 + BEWW(J)=(P(IW1,J)+P(IW2,J))/(P(IW1,4)+P(IW2,4)) + 130 CONTINUE + CALL PYROBO(IW1,IW1,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3)) + CALL PYROBO(IW2,IW2,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3)) + CALL PYROBO(NOLD+1,N,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3)) + +C...Select decay vertices of W+ and W-. + TP=HBAR*(-LOG(PYR(0)))*P(IW1,4)/ + & SQRT((P(IW1,5)**2-PMW**2)**2+(P(IW1,5)**2*PGW/PMW)**2) + TM=HBAR*(-LOG(PYR(0)))*P(IW2,4)/ + & SQRT((P(IW2,5)**2-PMW**2)**2+(P(IW2,5)**2*PGW/PMW)**2) + GTMAX=MAX(TP,TM) + DO 140 J=1,3 + XP(J)=TP*P(IW1,J)/P(IW1,4) + XM(J)=TM*P(IW2,J)/P(IW2,4) + 140 CONTINUE + +C...Begin scenario I specifics. + IF(MSTP(115).EQ.1) THEN + +C...Reconstruct velocity and direction of W+ string pieces. + DO 170 IIP=1,NNP-1 + IF(K(INP(IIP),2).LT.0) GOTO 170 + I1=INP(IIP) + I2=INP(IIP+1) + P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2) + P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2) + DO 150 J=1,3 + V1(J)=P(I1,J)/P1A + V2(J)=P(I2,J)/P2A + BETP(IIP,J)=0.5D0*(V1(J)+V2(J)) + DIRP(IIP,J)=V1(J)-V2(J) + 150 CONTINUE + BETP(IIP,4)=1D0/SQRT(1D0-BETP(IIP,1)**2-BETP(IIP,2)**2- + & BETP(IIP,3)**2) + DIRL=SQRT(DIRP(IIP,1)**2+DIRP(IIP,2)**2+DIRP(IIP,3)**2) + DO 160 J=1,3 + DIRP(IIP,J)=DIRP(IIP,J)/DIRL + 160 CONTINUE + 170 CONTINUE + +C...Reconstruct velocity and direction of W- string pieces. + DO 200 IIM=1,NNM-1 + IF(K(INM(IIM),2).LT.0) GOTO 200 + I1=INM(IIM) + I2=INM(IIM+1) + P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2) + P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2) + DO 180 J=1,3 + V1(J)=P(I1,J)/P1A + V2(J)=P(I2,J)/P2A + BETM(IIM,J)=0.5D0*(V1(J)+V2(J)) + DIRM(IIM,J)=V1(J)-V2(J) + 180 CONTINUE + BETM(IIM,4)=1D0/SQRT(1D0-BETM(IIM,1)**2-BETM(IIM,2)**2- + & BETM(IIM,3)**2) + DIRL=SQRT(DIRM(IIM,1)**2+DIRM(IIM,2)**2+DIRM(IIM,3)**2) + DO 190 J=1,3 + DIRM(IIM,J)=DIRM(IIM,J)/DIRL + 190 CONTINUE + 200 CONTINUE + +C...Loop over number of space-time points. + NACC=0 + SUM=0D0 + DO 250 IPT=1,NPT + +C...Pick x,y,z,t Gaussian (width RHAD and TFRAG, respectively). + R=SQRT(-LOG(PYR(0))) + PHI=2D0*PI*PYR(0) + X=BLOWR*RHAD*R*COS(PHI) + Y=BLOWR*RHAD*R*SIN(PHI) + R=SQRT(-LOG(PYR(0))) + PHI=2D0*PI*PYR(0) + Z=BLOWR*RHAD*R*COS(PHI) + T=GTMAX+BLOWT*SQRT(0.5D0)*TFRAG*R*ABS(SIN(PHI)) + +C...Reject impossible points. Weight for sample distribution. + IF(T**2-X**2-Y**2-Z**2.LT.0D0) GOTO 250 + WTSMP=EXP(-(X**2+Y**2+Z**2)/(BLOWR*RHAD)**2)* + & EXP(-2D0*(T-GTMAX)**2/(BLOWT*TFRAG)**2) + +C...Loop over W+ string pieces and find one with largest weight. + IMAXP=0 + WTMAXP=1D-10 + XD(1)=X-XP(1) + XD(2)=Y-XP(2) + XD(3)=Z-XP(3) + XD(4)=T-TP + DO 220 IIP=1,NNP-1 + IF(K(INP(IIP),2).LT.0) GOTO 220 + BED=BETP(IIP,1)*XD(1)+BETP(IIP,2)*XD(2)+BETP(IIP,3)*XD(3) + BEDG=BETP(IIP,4)*(BETP(IIP,4)*BED/(1D0+BETP(IIP,4))-XD(4)) + DO 210 J=1,3 + XB(J)=XD(J)+BEDG*BETP(IIP,J) + 210 CONTINUE + XB(4)=BETP(IIP,4)*(XD(4)-BED) + SR2=XB(1)**2+XB(2)**2+XB(3)**2 + SZ2=(DIRP(IIP,1)*XB(1)+DIRP(IIP,2)*XB(2)+ + & DIRP(IIP,3)*XB(3))**2 + WTP=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/ + & TFRAG**2) + IF(XB(4)-SQRT(SR2).LT.0D0) WTP=0D0 + IF(WTP.GT.WTMAXP) THEN + IMAXP=IIP + WTMAXP=WTP + ENDIF + 220 CONTINUE + +C...Loop over W- string pieces and find one with largest weight. + IMAXM=0 + WTMAXM=1D-10 + XD(1)=X-XM(1) + XD(2)=Y-XM(2) + XD(3)=Z-XM(3) + XD(4)=T-TM + DO 240 IIM=1,NNM-1 + IF(K(INM(IIM),2).LT.0) GOTO 240 + BED=BETM(IIM,1)*XD(1)+BETM(IIM,2)*XD(2)+BETM(IIM,3)*XD(3) + BEDG=BETM(IIM,4)*(BETM(IIM,4)*BED/(1D0+BETM(IIM,4))-XD(4)) + DO 230 J=1,3 + XB(J)=XD(J)+BEDG*BETM(IIM,J) + 230 CONTINUE + XB(4)=BETM(IIM,4)*(XD(4)-BED) + SR2=XB(1)**2+XB(2)**2+XB(3)**2 + SZ2=(DIRM(IIM,1)*XB(1)+DIRM(IIM,2)*XB(2)+ + & DIRM(IIM,3)*XB(3))**2 + WTM=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/ + & TFRAG**2) + IF(XB(4)-SQRT(SR2).LT.0D0) WTM=0D0 + IF(WTM.GT.WTMAXM) THEN + IMAXM=IIM + WTMAXM=WTM + ENDIF + 240 CONTINUE + +C...Result of integration. + WT=0D0 + IF(IMAXP.NE.0.AND.IMAXM.NE.0) THEN + WT=WTMAXP*WTMAXM/WTSMP + SUM=SUM+WT + NACC=NACC+1 + IAP(NACC)=IMAXP + IAM(NACC)=IMAXM + WTA(NACC)=WT + ENDIF + 250 CONTINUE + RES=BLOWR**3*BLOWT*SUM/NPT + +C...Decide whether to reconnect and, if so, where. + IACC=0 + PREC=1D0-EXP(-FACT*RES) + IF(PREC.GT.PYR(0)) THEN + RSUM=PYR(0)*SUM + DO 260 IA=1,NACC + IACC=IA + RSUM=RSUM-WTA(IA) + IF(RSUM.LE.0D0) GOTO 270 + 260 CONTINUE + 270 IIP=IAP(IACC) + IIM=IAM(IACC) + ENDIF + +C...Begin scenario II and II' specifics. + ELSEIF(MSTP(115).EQ.2.OR.MSTP(115).EQ.3) THEN + +C...Loop through all string pieces, one from W+ and one from W-. + NCROSS=0 + TC(0)=0D0 + DO 340 IIP=1,NNP-1 + IF(K(INP(IIP),2).LT.0) GOTO 340 + I1P=INP(IIP) + I2P=INP(IIP+1) + DO 330 IIM=1,NNM-1 + IF(K(INM(IIM),2).LT.0) GOTO 330 + I1M=INM(IIM) + I2M=INM(IIM+1) + +C...Find endpoint velocity vectors. + DO 280 J=1,3 + V1P(J)=P(I1P,J)/P(I1P,4) + V2P(J)=P(I2P,J)/P(I2P,4) + V1M(J)=P(I1M,J)/P(I1M,4) + V2M(J)=P(I2M,J)/P(I2M,4) + 280 CONTINUE + +C...Define q matrix and find t. + DO 290 J=1,3 + Q(1,J)=V2P(J)-V1P(J) + Q(2,J)=-(V2M(J)-V1M(J)) + Q(3,J)=XP(J)-XM(J)-TP*V1P(J)+TM*V1M(J) + Q(4,J)=V1P(J)-V1M(J) + 290 CONTINUE + T=-DETER(1,2,3)/DETER(1,2,4) + +C...Find alpha and beta; i.e. coordinates of crossing point. + S11=Q(1,1)*(T-TP) + S12=Q(2,1)*(T-TM) + S13=Q(3,1)+Q(4,1)*T + S21=Q(1,2)*(T-TP) + S22=Q(2,2)*(T-TM) + S23=Q(3,2)+Q(4,2)*T + DEN=S11*S22-S12*S21 + ALP=(S12*S23-S22*S13)/DEN + BET=(S21*S13-S11*S23)/DEN + +C...Check if solution acceptable. + IANSW=1 + IF(T.LT.GTMAX) IANSW=0 + IF(ALP.LT.0D0.OR.ALP.GT.1D0) IANSW=0 + IF(BET.LT.0D0.OR.BET.GT.1D0) IANSW=0 + +C...Find point of crossing and check that not inconsistent. + DO 300 J=1,3 + XPP(J)=XP(J)+(V1P(J)+ALP*(V2P(J)-V1P(J)))*(T-TP) + XMM(J)=XM(J)+(V1M(J)+BET*(V2M(J)-V1M(J)))*(T-TM) + 300 CONTINUE + D2PM=(XPP(1)-XMM(1))**2+(XPP(2)-XMM(2))**2+ + & (XPP(3)-XMM(3))**2 + D2P=XPP(1)**2+XPP(2)**2+XPP(3)**2 + D2M=XMM(1)**2+XMM(2)**2+XMM(3)**2 + IF(D2PM.GT.1D-4*(D2P+D2M)) IANSW=-1 + +C...Find string eigentimes at crossing. + IF(IANSW.EQ.1) THEN + TAUP=SQRT(MAX(0D0,(T-TP)**2-(XPP(1)-XP(1))**2- + & (XPP(2)-XP(2))**2-(XPP(3)-XP(3))**2)) + TAUM=SQRT(MAX(0D0,(T-TM)**2-(XMM(1)-XM(1))**2- + & (XMM(2)-XM(2))**2-(XMM(3)-XM(3))**2)) + ELSE + TAUP=0D0 + TAUM=0D0 + ENDIF + +C...Order crossings by time. End loop over crossings. + IF(IANSW.EQ.1.AND.NCROSS.LT.20) THEN + NCROSS=NCROSS+1 + DO 310 I1=NCROSS,1,-1 + IF(T.GT.TC(I1-1).OR.I1.EQ.1) THEN + IPC(I1)=IIP + IMC(I1)=IIM + TC(I1)=T + TPC(I1)=TAUP + TMC(I1)=TAUM + GOTO 320 + ELSE + IPC(I1)=IPC(I1-1) + IMC(I1)=IMC(I1-1) + TC(I1)=TC(I1-1) + TPC(I1)=TPC(I1-1) + TMC(I1)=TMC(I1-1) + ENDIF + 310 CONTINUE + 320 CONTINUE + ENDIF + 330 CONTINUE + 340 CONTINUE + +C...Loop over crossings; find first (if any) acceptable one. + IACC=0 + IF(NCROSS.GE.1) THEN + DO 350 IC=1,NCROSS + PNFRAG=EXP(-(TPC(IC)**2+TMC(IC)**2)/TFRAG**2) + IF(PNFRAG.GT.PYR(0)) THEN +C...Scenario II: only compare with fragmentation time. + IF(MSTP(115).EQ.2) THEN + IACC=IC + IIP=IPC(IACC) + IIM=IMC(IACC) + GOTO 360 +C...Scenario II': also require that string length decreases. + ELSE + IIP=IPC(IC) + IIM=IMC(IC) + I1P=INP(IIP) + I2P=INP(IIP+1) + I1M=INM(IIM) + I2M=INM(IIM+1) + ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M) + ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P) + IF(ELNEW.LT.ELOLD) THEN + IACC=IC + IIP=IPC(IACC) + IIM=IMC(IACC) + GOTO 360 + ENDIF + ENDIF + ENDIF + 350 CONTINUE + 360 CONTINUE + ENDIF + +C...Begin scenario GH specifics. + ELSEIF(MSTP(115).EQ.5) THEN + +C...Loop through all string pieces, one from W+ and one from W-. + IACC=0 + ELMIN=1D0 + DO 380 IIP=1,NNP-1 + IF(K(INP(IIP),2).LT.0) GOTO 380 + I1P=INP(IIP) + I2P=INP(IIP+1) + DO 370 IIM=1,NNM-1 + IF(K(INM(IIM),2).LT.0) GOTO 370 + I1M=INM(IIM) + I2M=INM(IIM+1) + +C...Look for largest decrease of (exponent of) Lambda measure. + ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M) + ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P) + ELDIF=ELNEW/MAX(1D-10,ELOLD) + IF(ELDIF.LT.ELMIN) THEN + IACC=IIP+IIM + ELMIN=ELDIF + IPC(1)=IIP + IMC(1)=IIM + ENDIF + 370 CONTINUE + 380 CONTINUE + IIP=IPC(1) + IIM=IMC(1) + ENDIF + +C...Common for scenarios I, II, II' and GH: reconnect strings. + IF(IACC.NE.0) THEN + MINT(32)=1 + NJOIN=0 + DO 390 IS=1,NNP+NNM + NJOIN=NJOIN+1 + IF(IS.LE.IIP) THEN + I=INP(IS) + ELSEIF(IS.LE.IIP+NNM-IIM) THEN + I=INM(IS-IIP+IIM) + ELSEIF(IS.LE.IIP+NNM) THEN + I=INM(IS-IIP-NNM+IIM) + ELSE + I=INP(IS-NNM) + ENDIF + IJOIN(NJOIN)=I + IF(K(I,2).LT.0) THEN + CALL PYJOIN(NJOIN,IJOIN) + NJOIN=0 + ENDIF + 390 CONTINUE + +C...Restore original event record if no reconnection. + ELSE + DO 400 I=NSD1+1,NOLD + IF(K(I,1).EQ.13.OR.K(I,1).EQ.14) THEN + K(I,4)=MOD(K(I,4),MSTU(5)**2) + K(I,5)=MOD(K(I,5),MSTU(5)**2) + ENDIF + 400 CONTINUE + DO 410 I=NOLD+1,N + K(K(I,3),1)=3 + 410 CONTINUE + N=NOLD + ENDIF + +C...Boost back system. + CALL PYROBO(IW1,IW1,0D0,0D0,BEWW(1),BEWW(2),BEWW(3)) + CALL PYROBO(IW2,IW2,0D0,0D0,BEWW(1),BEWW(2),BEWW(3)) + IF(N.GT.NOLD) CALL PYROBO(NOLD+1,N,0D0,0D0, + & BEWW(1),BEWW(2),BEWW(3)) + +C...Common part for intermediate and instantaneous scenarios. + ELSEIF(MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN + MINT(32)=1 + +C...Remove old shower products and reset showering ones. + N=NSD1+4 + DO 420 I=NSD1+1,NSD1+4 + K(I,1)=3 + K(I,4)=MOD(K(I,4),MSTU(5)**2) + K(I,5)=MOD(K(I,5),MSTU(5)**2) + 420 CONTINUE + +C...Identify quark-antiquark pairs. + IQ1=NSD1+1 + IQ2=NSD1+2 + IQ3=NSD1+3 + IF(K(IQ1,2)*K(IQ3,2).LT.0) IQ3=NSD1+4 + IQ4=2*NSD1+7-IQ3 + +C...Reconnect strings. + IJOIN(1)=IQ1 + IJOIN(2)=IQ4 + CALL PYJOIN(2,IJOIN) + IJOIN(1)=IQ3 + IJOIN(2)=IQ2 + CALL PYJOIN(2,IJOIN) + +C...Do new parton showers in intermediate scenario. + IF(MSTP(71).GE.1.AND.MSTP(115).EQ.11) THEN + MSTJ50=MSTJ(50) + MSTJ(50)=0 + CALL PYSHOW(IQ1,IQ2,P(IW1,5)) + CALL PYSHOW(IQ3,IQ4,P(IW2,5)) + MSTJ(50)=MSTJ50 + +C...Do new parton showers in instantaneous scenario. + ELSEIF(MSTP(71).GE.1.AND.MSTP(115).EQ.12) THEN + PPM2=(P(IQ1,4)+P(IQ4,4))**2-(P(IQ1,1)+P(IQ4,1))**2- + & (P(IQ1,2)+P(IQ4,2))**2-(P(IQ1,3)+P(IQ4,3))**2 + PPM=SQRT(MAX(0D0,PPM2)) + CALL PYSHOW(IQ1,IQ4,PPM) + PPM2=(P(IQ3,4)+P(IQ2,4))**2-(P(IQ3,1)+P(IQ2,1))**2- + & (P(IQ3,2)+P(IQ2,2))**2-(P(IQ3,3)+P(IQ2,3))**2 + PPM=SQRT(MAX(0D0,PPM2)) + CALL PYSHOW(IQ3,IQ2,PPM) + ENDIF + ENDIF + + RETURN + END + +C*********************************************************************** + +C...PYKLIM +C...Checks generated variables against pre-set kinematical limits; +C...also calculates limits on variables used in generation. + + SUBROUTINE PYKLIM(ILIM) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/, + &/PYINT1/,/PYINT2/ + +C...Common kinematical expressions. + MINT(51)=0 + ISUB=MINT(1) + ISTSB=ISET(ISUB) + IF(ISUB.EQ.96) GOTO 100 + SQM3=VINT(63) + SQM4=VINT(64) + IF(ILIM.NE.0) THEN + IF(ABS(SQM3).LT.1D-4.AND.ABS(SQM4).LT.1D-4) THEN + CKIN09=MAX(CKIN(9),CKIN(13)) + CKIN10=MIN(CKIN(10),CKIN(14)) + CKIN11=MAX(CKIN(11),CKIN(15)) + CKIN12=MIN(CKIN(12),CKIN(16)) + ELSE + CKIN09=MAX(CKIN(9),MIN(0D0,CKIN(13))) + CKIN10=MIN(CKIN(10),MAX(0D0,CKIN(14))) + CKIN11=MAX(CKIN(11),MIN(0D0,CKIN(15))) + CKIN12=MIN(CKIN(12),MAX(0D0,CKIN(16))) + ENDIF + ENDIF + IF(ILIM.NE.1) THEN + TAU=VINT(21) + RM3=SQM3/(TAU*VINT(2)) + RM4=SQM4/(TAU*VINT(2)) + BE34=SQRT(MAX(1D-20,(1D0-RM3-RM4)**2-4D0*RM3*RM4)) + ENDIF + PTHMIN=CKIN(3) + IF(MIN(SQM3,SQM4).LT.CKIN(6)**2.AND.ISTSB.NE.1.AND.ISTSB.NE.3) + &PTHMIN=MAX(CKIN(3),CKIN(5)) + + IF(ILIM.EQ.0) THEN +C...Check generated values of tau, y*, cos(theta-hat), and tau' against +C...pre-set kinematical limits. + YST=VINT(22) + CTH=VINT(23) + TAUP=VINT(26) + TAUE=TAU + IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP + X1=SQRT(TAUE)*EXP(YST) + X2=SQRT(TAUE)*EXP(-YST) + XF=X1-X2 + IF(MINT(47).NE.1) THEN + IF(TAU*VINT(2).LT.CKIN(1)**2) MINT(51)=1 + IF(CKIN(2).GE.0D0.AND.TAU*VINT(2).GT.CKIN(2)**2) MINT(51)=1 + IF(YST.LT.CKIN(7).OR.YST.GT.CKIN(8)) MINT(51)=1 + IF(XF.LT.CKIN(25).OR.XF.GT.CKIN(26)) MINT(51)=1 + ENDIF + IF(MINT(45).NE.1) THEN + IF(X1.LT.CKIN(21).OR.X1.GT.CKIN(22)) MINT(51)=1 + ENDIF + IF(MINT(46).NE.1) THEN + IF(X2.LT.CKIN(23).OR.X2.GT.CKIN(24)) MINT(51)=1 + ENDIF + IF(MINT(45).EQ.2) THEN + IF(X1.GT.1D0-2D0*PARP(111)/VINT(1)) MINT(51)=1 + ENDIF + IF(MINT(46).EQ.2) THEN + IF(X2.GT.1D0-2D0*PARP(111)/VINT(1)) MINT(51)=1 + ENDIF + IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN + PTH=0.5D0*BE34*SQRT(TAU*VINT(2)*MAX(0D0,1D0-CTH**2)) + EXPY3=MAX(1D-20,(1D0+RM3-RM4+BE34*CTH)/ + & MAX(1D-20,(1D0+RM3-RM4-BE34*CTH))) + EXPY4=MAX(1D-20,(1D0-RM3+RM4-BE34*CTH)/ + & MAX(1D-20,(1D0-RM3+RM4+BE34*CTH))) + Y3=YST+0.5D0*LOG(EXPY3) + Y4=YST+0.5D0*LOG(EXPY4) + YLARGE=MAX(Y3,Y4) + YSMALL=MIN(Y3,Y4) + ETALAR=20D0 + ETASMA=-20D0 + STH=SQRT(MAX(0D0,1D0-CTH**2)) + EXSQ3=SQRT(MAX(1D-20,((1D0+RM3-RM4)*COSH(YST)+BE34*SINH(YST)* + & CTH)**2-4D0*RM3)) + EXSQ4=SQRT(MAX(1D-20,((1D0-RM3+RM4)*COSH(YST)-BE34*SINH(YST)* + & CTH)**2-4D0*RM4)) + IF(STH.GE.1D-10) THEN + EXPET3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH+EXSQ3)/ + & (BE34*STH) + EXPET4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH+EXSQ4)/ + & (BE34*STH) + ETA3=LOG(MIN(1D10,MAX(1D-10,EXPET3))) + ETA4=LOG(MIN(1D10,MAX(1D-10,EXPET4))) + ETALAR=MAX(ETA3,ETA4) + ETASMA=MIN(ETA3,ETA4) + ENDIF + CTS3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH)/EXSQ3 + CTS4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH)/EXSQ4 + CTSLAR=MIN(1D0,MAX(-1D0,CTS3,CTS4)) + CTSSMA=MAX(-1D0,MIN(1D0,CTS3,CTS4)) + SH=TAU*VINT(2) + RPTS=4D0*VINT(71)**2/SH + BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS)) + RM34=MAX(1D-20,2D0*RM3*RM4) + IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0) + & RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2))) + RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L) + THA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4-BE34*CTH) + UHA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH) + IF(PTH.LT.PTHMIN) MINT(51)=1 + IF(CKIN(4).GE.0D0.AND.PTH.GT.CKIN(4)) MINT(51)=1 + IF(YLARGE.LT.CKIN(9).OR.YLARGE.GT.CKIN(10)) MINT(51)=1 + IF(YSMALL.LT.CKIN(11).OR.YSMALL.GT.CKIN(12)) MINT(51)=1 + IF(ETALAR.LT.CKIN(13).OR.ETALAR.GT.CKIN(14)) MINT(51)=1 + IF(ETASMA.LT.CKIN(15).OR.ETASMA.GT.CKIN(16)) MINT(51)=1 + IF(CTSLAR.LT.CKIN(17).OR.CTSLAR.GT.CKIN(18)) MINT(51)=1 + IF(CTSSMA.LT.CKIN(19).OR.CTSSMA.GT.CKIN(20)) MINT(51)=1 + IF(CTH.LT.CKIN(27).OR.CTH.GT.CKIN(28)) MINT(51)=1 + IF(THA.LT.CKIN(35)) MINT(51)=1 + IF(CKIN(36).GE.0D0.AND.THA.GT.CKIN(36)) MINT(51)=1 + IF(UHA.LT.CKIN(37)) MINT(51)=1 + IF(CKIN(38).GE.0D0.AND.UHA.GT.CKIN(38)) MINT(51)=1 + ENDIF + IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN + IF(TAUP*VINT(2).LT.CKIN(31)**2) MINT(51)=1 + IF(CKIN(32).GE.0D0.AND.TAUP*VINT(2).GT.CKIN(32)**2) MINT(51)=1 + ENDIF + +C...Additional cuts on W2 (approximately) in DIS. + IF(ISUB.EQ.10.AND.MINT(43).GE.2) THEN + XBJ=X2 + IF(IABS(MINT(12)).LT.20) XBJ=X1 + Q2BJ=THA + W2BJ=Q2BJ*(1D0-XBJ)/XBJ + IF(W2BJ.LT.CKIN(39)) MINT(51)=1 + IF(CKIN(40).GT.0D0.AND.W2BJ.GT.CKIN(40)) MINT(51)=1 + ENDIF + + ELSEIF(ILIM.EQ.1) THEN +C...Calculate limits on tau +C...0) due to definition + TAUMN0=0D0 + TAUMX0=1D0 +C...1) due to limits on subsystem mass + TAUMN1=CKIN(1)**2/VINT(2) + TAUMX1=1D0 + IF(CKIN(2).GE.0D0) TAUMX1=CKIN(2)**2/VINT(2) +C...2) due to limits on pT-hat (and non-overlapping rapidity intervals) + TM3=SQRT(SQM3+PTHMIN**2) + TM4=SQRT(SQM4+PTHMIN**2) + YDCOSH=1D0 + IF(CKIN09.GT.CKIN12) YDCOSH=COSH(CKIN09-CKIN12) + TAUMN2=(TM3**2+2D0*TM3*TM4*YDCOSH+TM4**2)/VINT(2) + TAUMX2=1D0 +C...3) due to limits on pT-hat and cos(theta-hat) + CTH2MN=MIN(CKIN(27)**2,CKIN(28)**2) + CTH2MX=MAX(CKIN(27)**2,CKIN(28)**2) + TAUMN3=0D0 + IF(CKIN(27)*CKIN(28).GT.0D0) TAUMN3= + & (SQRT(SQM3+PTHMIN**2/(1D0-CTH2MN))+ + & SQRT(SQM4+PTHMIN**2/(1D0-CTH2MN)))**2/VINT(2) + TAUMX3=1D0 + IF(CKIN(4).GE.0D0.AND.CTH2MX.LT.1D0) TAUMX3= + & (SQRT(SQM3+CKIN(4)**2/(1D0-CTH2MX))+ + & SQRT(SQM4+CKIN(4)**2/(1D0-CTH2MX)))**2/VINT(2) +C...4) due to limits on x1 and x2 + TAUMN4=CKIN(21)*CKIN(23) + TAUMX4=CKIN(22)*CKIN(24) +C...5) due to limits on xF + TAUMN5=0D0 + TAUMX5=MAX(1D0-CKIN(25),1D0+CKIN(26)) +C...6) due to limits on that and uhat + TAUMN6=(SQM3+SQM4+CKIN(35)+CKIN(37))/VINT(2) + TAUMX6=1D0 + IF(CKIN(36).GT.0D0.AND.CKIN(38).GT.0D0) TAUMX6= + & (SQM3+SQM4+CKIN(36)+CKIN(38))/VINT(2) + +C...Net effect of all separate limits. + VINT(11)=MAX(TAUMN0,TAUMN1,TAUMN2,TAUMN3,TAUMN4,TAUMN5,TAUMN6) + VINT(31)=MIN(TAUMX0,TAUMX1,TAUMX2,TAUMX3,TAUMX4,TAUMX5,TAUMX6) + IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN + VINT(11)=1D0-1D-9 + VINT(31)=1D0+1D-9 + ELSEIF(MINT(47).EQ.5) THEN + VINT(31)=MIN(VINT(31),1D0-2D-10) + ELSEIF(MINT(47).GE.6) THEN + VINT(31)=MIN(VINT(31),1D0-1D-10) + ENDIF + IF(VINT(31).LE.VINT(11)) MINT(51)=1 + + ELSEIF(ILIM.EQ.2) THEN +C...Calculate limits on y* + TAUE=TAU + IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26) + TAURT=SQRT(TAUE) +C...0) due to kinematics + YSTMN0=LOG(TAURT) + YSTMX0=-YSTMN0 +C...1) due to explicit limits + YSTMN1=CKIN(7) + YSTMX1=CKIN(8) +C...2) due to limits on x1 + YSTMN2=LOG(MAX(TAUE,CKIN(21))/TAURT) + YSTMX2=LOG(MAX(TAUE,CKIN(22))/TAURT) +C...3) due to limits on x2 + YSTMN3=-LOG(MAX(TAUE,CKIN(24))/TAURT) + YSTMX3=-LOG(MAX(TAUE,CKIN(23))/TAURT) +C...4) due to limits on xF + YEPMN4=0.5D0*ABS(CKIN(25))/TAURT + YSTMN4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMN4**2)+YEPMN4)),CKIN(25)) + YEPMX4=0.5D0*ABS(CKIN(26))/TAURT + YSTMX4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMX4**2)+YEPMX4)),CKIN(26)) +C...5) due to simultaneous limits on y-large and y-small + YEPSMN=(RM3-RM4)*SINH(CKIN09-CKIN11) + YEPSMX=(RM3-RM4)*SINH(CKIN10-CKIN12) + YDIFMN=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMN**2)-YEPSMN))) + YDIFMX=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMX**2)-YEPSMX))) + YSTMN5=0.5D0*(CKIN09+CKIN11-YDIFMN) + YSTMX5=0.5D0*(CKIN10+CKIN12+YDIFMX) +C...6) due to simultaneous limits on cos(theta-hat) and y-large or +C... y-small + CTHLIM=SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAUE*VINT(2)))) + RZMN=BE34*MAX(CKIN(27),-CTHLIM) + RZMX=BE34*MIN(CKIN(28),CTHLIM) + YEX3MX=(1D0+RM3-RM4+RZMX)/MAX(1D-10,1D0+RM3-RM4-RZMX) + YEX4MX=(1D0+RM4-RM3-RZMN)/MAX(1D-10,1D0+RM4-RM3+RZMN) + YEX3MN=MAX(1D-10,1D0+RM3-RM4+RZMN)/(1D0+RM3-RM4-RZMN) + YEX4MN=MAX(1D-10,1D0+RM4-RM3-RZMX)/(1D0+RM4-RM3+RZMX) + YSTMN6=CKIN09-0.5D0*LOG(MAX(YEX3MX,YEX4MX)) + YSTMX6=CKIN12-0.5D0*LOG(MIN(YEX3MN,YEX4MN)) + +C...Net effect of all separate limits. + VINT(12)=MAX(YSTMN0,YSTMN1,YSTMN2,YSTMN3,YSTMN4,YSTMN5,YSTMN6) + VINT(32)=MIN(YSTMX0,YSTMX1,YSTMX2,YSTMX3,YSTMX4,YSTMX5,YSTMX6) + IF(MINT(47).EQ.1) THEN + VINT(12)=-1D-9 + VINT(32)=1D-9 + ELSEIF(MINT(47).EQ.2.OR.MINT(47).EQ.6) THEN + VINT(12)=(1D0-1D-9)*YSTMX0 + VINT(32)=(1D0+1D-9)*YSTMX0 + ELSEIF(MINT(47).EQ.3.OR.MINT(47).EQ.7) THEN + VINT(12)=-(1D0+1D-9)*YSTMX0 + VINT(32)=-(1D0-1D-9)*YSTMX0 + ELSEIF(MINT(47).EQ.5) THEN + YSTEE=LOG((1D0-1D-10)/TAURT) + VINT(12)=MAX(VINT(12),-YSTEE) + VINT(32)=MIN(VINT(32),YSTEE) + ENDIF + IF(VINT(32).LE.VINT(12)) MINT(51)=1 + + ELSEIF(ILIM.EQ.3) THEN +C...Calculate limits on cos(theta-hat) + YST=VINT(22) +C...0) due to definition + CTNMN0=-1D0 + CTNMX0=0D0 + CTPMN0=0D0 + CTPMX0=1D0 +C...1) due to explicit limits + CTNMN1=MIN(0D0,CKIN(27)) + CTNMX1=MIN(0D0,CKIN(28)) + CTPMN1=MAX(0D0,CKIN(27)) + CTPMX1=MAX(0D0,CKIN(28)) +C...2) due to limits on pT-hat + CTNMN2=-SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAU*VINT(2)))) + CTPMX2=-CTNMN2 + CTNMX2=0D0 + CTPMN2=0D0 + IF(CKIN(4).GE.0D0) THEN + CTNMX2=-SQRT(MAX(0D0,1D0-4D0*CKIN(4)**2/ + & (BE34**2*TAU*VINT(2)))) + CTPMN2=-CTNMX2 + ENDIF +C...3) due to limits on y-large and y-small + CTNMN3=MIN(0D0,MAX((1D0+RM3-RM4)/BE34*TANH(CKIN11-YST), + & -(1D0-RM3+RM4)/BE34*TANH(CKIN10-YST))) + CTNMX3=MIN(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN12-YST), + & -(1D0-RM3+RM4)/BE34*TANH(CKIN09-YST)) + CTPMN3=MAX(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN09-YST), + & -(1D0-RM3+RM4)/BE34*TANH(CKIN12-YST)) + CTPMX3=MAX(0D0,MIN((1D0+RM3-RM4)/BE34*TANH(CKIN10-YST), + & -(1D0-RM3+RM4)/BE34*TANH(CKIN11-YST))) +C...4) due to limits on that + CTNMN4=-1D0 + CTNMX4=0D0 + CTPMN4=0D0 + CTPMX4=1D0 + SH=TAU*VINT(2) + IF(CKIN(35).GT.0D0) THEN + CTLIM=(1D0-RM3-RM4-2D0*CKIN(35)/SH)/BE34 + IF(CTLIM.GT.0D0) THEN + CTPMX4=CTLIM + ELSE + CTPMX4=0D0 + CTNMX4=CTLIM + ENDIF + ENDIF + IF(CKIN(36).GT.0D0) THEN + CTLIM=(1D0-RM3-RM4-2D0*CKIN(36)/SH)/BE34 + IF(CTLIM.LT.0D0) THEN + CTNMN4=CTLIM + ELSE + CTNMN4=0D0 + CTPMN4=CTLIM + ENDIF + ENDIF +C...5) due to limits on uhat + CTNMN5=-1D0 + CTNMX5=0D0 + CTPMN5=0D0 + CTPMX5=1D0 + IF(CKIN(37).GT.0D0) THEN + CTLIM=(2D0*CKIN(37)/SH-(1D0-RM3-RM4))/BE34 + IF(CTLIM.LT.0D0) THEN + CTNMN5=CTLIM + ELSE + CTNMN5=0D0 + CTPMN5=CTLIM + ENDIF + ENDIF + IF(CKIN(38).GT.0D0) THEN + CTLIM=(2D0*CKIN(38)/SH-(1D0-RM3-RM4))/BE34 + IF(CTLIM.GT.0D0) THEN + CTPMX5=CTLIM + ELSE + CTPMX5=0D0 + CTNMX5=CTLIM + ENDIF + ENDIF + +C...Net effect of all separate limits. + VINT(13)=MAX(CTNMN0,CTNMN1,CTNMN2,CTNMN3,CTNMN4,CTNMN5) + VINT(33)=MIN(CTNMX0,CTNMX1,CTNMX2,CTNMX3,CTNMX4,CTNMX5) + VINT(14)=MAX(CTPMN0,CTPMN1,CTPMN2,CTPMN3,CTPMN4,CTPMN5) + VINT(34)=MIN(CTPMX0,CTPMX1,CTPMX2,CTPMX3,CTPMX4,CTPMX5) + IF(VINT(33).LE.VINT(13).AND.VINT(34).LE.VINT(14)) MINT(51)=1 + + IF(VINT(14).GT.VINT(34)) VINT(34)=VINT(14) + IF(VINT(13).GT.VINT(33)) VINT(33)=VINT(13) + + ELSEIF(ILIM.EQ.4) THEN +C...Calculate limits on tau' +C...0) due to kinematics + TAPMN0=TAU + IF(ISTSB.EQ.5.AND.VINT(201).GT.0D0) THEN + PQRAT=(VINT(201)+VINT(206))/VINT(1) + TAPMN0=(SQRT(TAU)+PQRAT)**2 + ENDIF + TAPMX0=1D0 +C...1) due to explicit limits + TAPMN1=CKIN(31)**2/VINT(2) + TAPMX1=1D0 + IF(CKIN(32).GE.0D0) TAPMX1=CKIN(32)**2/VINT(2) + +C...Net effect of all separate limits. + VINT(16)=MAX(TAPMN0,TAPMN1) + VINT(36)=MIN(TAPMX0,TAPMX1) + IF(MINT(47).EQ.1) THEN + VINT(16)=1D0-1D-9 + VINT(36)=1D0+1D-9 + ELSEIF(MINT(47).EQ.5) THEN + VINT(36)=MIN(VINT(36),1D0-2D-10) + ELSEIF(MINT(47).EQ.6.OR.MINT(47).EQ.7) THEN + VINT(36)=MIN(VINT(36),1D0-1D-10) + ENDIF + IF(VINT(36).LE.VINT(16)) MINT(51)=1 + + ENDIF + RETURN + +C...Special case for low-pT and multiple interactions: +C...effective kinematical limits for tau, y*, cos(theta-hat). + 100 IF(ILIM.EQ.0) THEN + ELSEIF(ILIM.EQ.1) THEN + IF(MSTP(82).LE.1) THEN + VINT(11)=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/ + & VINT(2) + ELSE + VINT(11)=(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/VINT(2) + ENDIF + VINT(31)=1D0 + ELSEIF(ILIM.EQ.2) THEN + VINT(12)=0.5D0*LOG(VINT(21)) + VINT(32)=-VINT(12) + ELSEIF(ILIM.EQ.3) THEN + IF(MSTP(82).LE.1) THEN + ST2EFF=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/ + & (VINT(21)*VINT(2)) + ELSE + ST2EFF=0.01D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/ + & (VINT(21)*VINT(2)) + ENDIF + VINT(13)=-SQRT(MAX(0D0,1D0-ST2EFF)) + VINT(33)=0D0 + VINT(14)=0D0 + VINT(34)=-VINT(13) + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYKMAP +C...Maps a uniform distribution into a distribution of a kinematical +C...variable according to one of the possibilities allowed. It is +C...assumed that kinematical limits have been set by a PYKLIM call. + + SUBROUTINE PYKMAP(IVAR,MVAR,VVAR) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) + SAVE /PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/ + +C...Convert VVAR to tau variable. + ISUB=MINT(1) + ISTSB=ISET(ISUB) + IF(IVAR.EQ.1) THEN + TAUMIN=VINT(11) + TAUMAX=VINT(31) + IF(MVAR.EQ.3.OR.MVAR.EQ.4) THEN + TAURE=VINT(73) + GAMRE=VINT(74) + ELSEIF(MVAR.EQ.5.OR.MVAR.EQ.6) THEN + TAURE=VINT(75) + GAMRE=VINT(76) + ELSEIF(MVAR.EQ.8.OR.MVAR.EQ.9) THEN + TAURE=VINT(77) + GAMRE=VINT(78) + ENDIF + IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN + TAU=1D0 + ELSEIF(MVAR.EQ.1) THEN + TAU=TAUMIN*(TAUMAX/TAUMIN)**VVAR + ELSEIF(MVAR.EQ.2) THEN + TAU=TAUMAX*TAUMIN/(TAUMIN+(TAUMAX-TAUMIN)*VVAR) + ELSEIF(MVAR.EQ.3.OR.MVAR.EQ.5.OR.MVAR.EQ.8) THEN + RATGEN=(TAURE+TAUMAX)/(TAURE+TAUMIN)*TAUMIN/TAUMAX + TAU=TAURE*TAUMIN/((TAURE+TAUMIN)*RATGEN**VVAR-TAUMIN) + ELSEIF(MVAR.EQ.4.OR.MVAR.EQ.6.OR.MVAR.EQ.9) THEN + AUPP=ATAN((TAUMAX-TAURE)/GAMRE) + ALOW=ATAN((TAUMIN-TAURE)/GAMRE) + TAU=TAURE+GAMRE*TAN(ALOW+(AUPP-ALOW)*VVAR) + ELSEIF(MINT(47).EQ.5) THEN + AUPP=LOG(MAX(2D-10,1D0-TAUMAX)) + ALOW=LOG(MAX(2D-10,1D0-TAUMIN)) + TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP)) + ELSE + AUPP=LOG(MAX(1D-10,1D0-TAUMAX)) + ALOW=LOG(MAX(1D-10,1D0-TAUMIN)) + TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP)) + ENDIF + VINT(21)=MIN(TAUMAX,MAX(TAUMIN,TAU)) + +C...Convert VVAR to y* variable. + ELSEIF(IVAR.EQ.2) THEN + YSTMIN=VINT(12) + YSTMAX=VINT(32) + TAUE=VINT(21) + IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26) + IF(MINT(47).EQ.1) THEN + YST=0D0 + ELSEIF(MINT(47).EQ.2.OR.MINT(47).EQ.6) THEN + YST=-0.5D0*LOG(TAUE) + ELSEIF(MINT(47).EQ.3.OR.MINT(47).EQ.7) THEN + YST=0.5D0*LOG(TAUE) + ELSEIF(MVAR.EQ.1) THEN + YST=YSTMIN+(YSTMAX-YSTMIN)*SQRT(VVAR) + ELSEIF(MVAR.EQ.2) THEN + YST=YSTMAX-(YSTMAX-YSTMIN)*SQRT(1D0-VVAR) + ELSEIF(MVAR.EQ.3) THEN + AUPP=ATAN(EXP(YSTMAX)) + ALOW=ATAN(EXP(YSTMIN)) + YST=LOG(TAN(ALOW+(AUPP-ALOW)*VVAR)) + ELSEIF(MVAR.EQ.4) THEN + YST0=-0.5D0*LOG(TAUE) + AUPP=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0)) + ALOW=LOG(MAX(1D-10,EXP(YST0-YSTMAX)-1D0)) + YST=YST0-LOG(1D0+EXP(ALOW+VVAR*(AUPP-ALOW))) + ELSE + YST0=-0.5D0*LOG(TAUE) + AUPP=LOG(MAX(1D-10,EXP(YST0+YSTMIN)-1D0)) + ALOW=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0)) + YST=LOG(1D0+EXP(AUPP+VVAR*(ALOW-AUPP)))-YST0 + ENDIF + VINT(22)=MIN(YSTMAX,MAX(YSTMIN,YST)) + +C...Convert VVAR to cos(theta-hat) variable. + ELSEIF(IVAR.EQ.3) THEN + RM34=MAX(1D-20,2D0*VINT(63)*VINT(64)/(VINT(21)*VINT(2))**2) + RSQM=1D0+RM34 + IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0) + & RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2))) + CTNMIN=VINT(13) + CTNMAX=VINT(33) + CTPMIN=VINT(14) + CTPMAX=VINT(34) + IF(MVAR.EQ.1) THEN + ANEG=CTNMAX-CTNMIN + APOS=CTPMAX-CTPMIN + IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN + VCTN=VVAR*(ANEG+APOS)/ANEG + CTH=CTNMIN+(CTNMAX-CTNMIN)*VCTN + ELSE + VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS + CTH=CTPMIN+(CTPMAX-CTPMIN)*VCTP + ENDIF + ELSEIF(MVAR.EQ.2) THEN + RMNMIN=MAX(RM34,RSQM-CTNMIN) + RMNMAX=MAX(RM34,RSQM-CTNMAX) + RMPMIN=MAX(RM34,RSQM-CTPMIN) + RMPMAX=MAX(RM34,RSQM-CTPMAX) + ANEG=LOG(RMNMIN/RMNMAX) + APOS=LOG(RMPMIN/RMPMAX) + IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN + VCTN=VVAR*(ANEG+APOS)/ANEG + CTH=RSQM-RMNMIN*(RMNMAX/RMNMIN)**VCTN + ELSE + VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS + CTH=RSQM-RMPMIN*(RMPMAX/RMPMIN)**VCTP + ENDIF + ELSEIF(MVAR.EQ.3) THEN + RMNMIN=MAX(RM34,RSQM+CTNMIN) + RMNMAX=MAX(RM34,RSQM+CTNMAX) + RMPMIN=MAX(RM34,RSQM+CTPMIN) + RMPMAX=MAX(RM34,RSQM+CTPMAX) + ANEG=LOG(RMNMAX/RMNMIN) + APOS=LOG(RMPMAX/RMPMIN) + IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN + VCTN=VVAR*(ANEG+APOS)/ANEG + CTH=RMNMIN*(RMNMAX/RMNMIN)**VCTN-RSQM + ELSE + VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS + CTH=RMPMIN*(RMPMAX/RMPMIN)**VCTP-RSQM + ENDIF + ELSEIF(MVAR.EQ.4) THEN + RMNMIN=MAX(RM34,RSQM-CTNMIN) + RMNMAX=MAX(RM34,RSQM-CTNMAX) + RMPMIN=MAX(RM34,RSQM-CTPMIN) + RMPMAX=MAX(RM34,RSQM-CTPMAX) + ANEG=1D0/RMNMAX-1D0/RMNMIN + APOS=1D0/RMPMAX-1D0/RMPMIN + IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN + VCTN=VVAR*(ANEG+APOS)/ANEG + CTH=RSQM-1D0/(1D0/RMNMIN+ANEG*VCTN) + ELSE + VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS + CTH=RSQM-1D0/(1D0/RMPMIN+APOS*VCTP) + ENDIF + ELSEIF(MVAR.EQ.5) THEN + RMNMIN=MAX(RM34,RSQM+CTNMIN) + RMNMAX=MAX(RM34,RSQM+CTNMAX) + RMPMIN=MAX(RM34,RSQM+CTPMIN) + RMPMAX=MAX(RM34,RSQM+CTPMAX) + ANEG=1D0/RMNMIN-1D0/RMNMAX + APOS=1D0/RMPMIN-1D0/RMPMAX + IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN + VCTN=VVAR*(ANEG+APOS)/ANEG + CTH=1D0/(1D0/RMNMIN-ANEG*VCTN)-RSQM + ELSE + VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS + CTH=1D0/(1D0/RMPMIN-APOS*VCTP)-RSQM + ENDIF + ENDIF + IF(CTH.LT.0D0) CTH=MIN(CTNMAX,MAX(CTNMIN,CTH)) + IF(CTH.GT.0D0) CTH=MIN(CTPMAX,MAX(CTPMIN,CTH)) + VINT(23)=CTH + +C...Convert VVAR to tau' variable. + ELSEIF(IVAR.EQ.4) THEN + TAU=VINT(21) + TAUPMN=VINT(16) + TAUPMX=VINT(36) + IF(MINT(47).EQ.1) THEN + TAUP=1D0 + ELSEIF(MVAR.EQ.1) THEN + TAUP=TAUPMN*(TAUPMX/TAUPMN)**VVAR + ELSEIF(MVAR.EQ.2) THEN + AUPP=(1D0-TAU/TAUPMX)**4 + ALOW=(1D0-TAU/TAUPMN)**4 + TAUP=TAU/MAX(1D-10,1D0-(ALOW+(AUPP-ALOW)*VVAR)**0.25D0) + ELSEIF(MINT(47).EQ.5) THEN + AUPP=LOG(MAX(2D-10,1D0-TAUPMX)) + ALOW=LOG(MAX(2D-10,1D0-TAUPMN)) + TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP)) + ELSE + AUPP=LOG(MAX(1D-10,1D0-TAUPMX)) + ALOW=LOG(MAX(1D-10,1D0-TAUPMN)) + TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP)) + ENDIF + VINT(26)=MIN(TAUPMX,MAX(TAUPMN,TAUP)) + +C...Selection of extra variables needed in 2 -> 3 process: +C...pT1, pT2, phi1, phi2, y3 for three outgoing particles. +C...Since no options are available, the functions of PYKLIM +C...and PYKMAP are joint for these choices. + ELSEIF(IVAR.EQ.5) THEN + +C...Read out total energy and particle masses. + MINT(51)=0 + MPTPK=1 + IF(ISUB.EQ.123.OR.ISUB.EQ.124.OR.ISUB.EQ.173.OR.ISUB.EQ.174 + & .OR.ISUB.EQ.178.OR.ISUB.EQ.179.OR.ISUB.EQ.351.OR.ISUB.EQ.352) + & MPTPK=2 + SHP=VINT(26)*VINT(2) + SHPR=SQRT(SHP) + PM1=VINT(201) + PM2=VINT(206) + PM3=SQRT(VINT(21))*VINT(1) + IF(PM1+PM2+PM3.GT.0.9999D0*SHPR) THEN + MINT(51)=1 + RETURN + ENDIF + PMRS1=VINT(204)**2 + PMRS2=VINT(209)**2 + +C...Specify coefficients of pT choice; upper and lower limits. + IF(MPTPK.EQ.1) THEN + HWT1=0.4D0 + HWT2=0.4D0 + ELSE + HWT1=0.05D0 + HWT2=0.05D0 + ENDIF + HWT3=1D0-HWT1-HWT2 + PTSMX1=((SHP-PM1**2-(PM2+PM3)**2)**2-(2D0*PM1*(PM2+PM3))**2)/ + & (4D0*SHP) + IF(CKIN(52).GT.0D0) PTSMX1=MIN(PTSMX1,CKIN(52)**2) + PTSMN1=CKIN(51)**2 + PTSMX2=((SHP-PM2**2-(PM1+PM3)**2)**2-(2D0*PM2*(PM1+PM3))**2)/ + & (4D0*SHP) + IF(CKIN(54).GT.0D0) PTSMX2=MIN(PTSMX2,CKIN(54)**2) + PTSMN2=CKIN(53)**2 + +C...Select transverse momenta according to +C...dp_T^2 * (a + b/(M^2 + p_T^2) + c/(M^2 + p_T^2)^2). + HMX=PMRS1+PTSMX1 + HMN=PMRS1+PTSMN1 + IF(HMX.LT.1.0001D0*HMN) THEN + MINT(51)=1 + RETURN + ENDIF + HDE=PTSMX1-PTSMN1 + RPT=PYR(0) + IF(RPT.LT.HWT1) THEN + PTS1=PTSMN1+PYR(0)*HDE + ELSEIF(RPT.LT.HWT1+HWT2) THEN + PTS1=MAX(PTSMN1,HMN*(HMX/HMN)**PYR(0)-PMRS1) + ELSE + PTS1=MAX(PTSMN1,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS1) + ENDIF + WTPTS1=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS1+PTS1))+ + & HWT3*HMN*HMX/(PMRS1+PTS1)**2) + HMX=PMRS2+PTSMX2 + HMN=PMRS2+PTSMN2 + IF(HMX.LT.1.0001D0*HMN) THEN + MINT(51)=1 + RETURN + ENDIF + HDE=PTSMX2-PTSMN2 + RPT=PYR(0) + IF(RPT.LT.HWT1) THEN + PTS2=PTSMN2+PYR(0)*HDE + ELSEIF(RPT.LT.HWT1+HWT2) THEN + PTS2=MAX(PTSMN2,HMN*(HMX/HMN)**PYR(0)-PMRS2) + ELSE + PTS2=MAX(PTSMN2,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS2) + ENDIF + WTPTS2=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS2+PTS2))+ + & HWT3*HMN*HMX/(PMRS2+PTS2)**2) + +C...Select azimuthal angles and check pT choice. + PHI1=PARU(2)*PYR(0) + PHI2=PARU(2)*PYR(0) + PHIR=PHI2-PHI1 + PTS3=MAX(0D0,PTS1+PTS2+2D0*SQRT(PTS1*PTS2)*COS(PHIR)) + IF(PTS3.LT.CKIN(55)**2.OR.(CKIN(56).GT.0D0.AND.PTS3.GT. + & CKIN(56)**2)) THEN + MINT(51)=1 + RETURN + ENDIF + +C...Calculate transverse masses and check phase space not closed. + PMS1=PM1**2+PTS1 + PMS2=PM2**2+PTS2 + PMS3=PM3**2+PTS3 + PMT1=SQRT(PMS1) + PMT2=SQRT(PMS2) + PMT3=SQRT(PMS3) + PM12=(PMT1+PMT2)**2 + IF(PMT1+PMT2+PMT3.GT.0.9999D0*SHPR) THEN + MINT(51)=1 + RETURN + ENDIF + +C...Select rapidity for particle 3 and check phase space not closed. + Y3MAX=LOG((SHP+PMS3-PM12+SQRT(MAX(0D0,(SHP-PMS3-PM12)**2- + & 4D0*PMS3*PM12)))/(2D0*SHPR*PMT3)) + IF(Y3MAX.LT.1D-6) THEN + MINT(51)=1 + RETURN + ENDIF + Y3=(2D0*PYR(0)-1D0)*0.999999D0*Y3MAX + PZ3=PMT3*SINH(Y3) + PE3=PMT3*COSH(Y3) + +C...Find momentum transfers in two mirror solutions (in 1-2 frame). + PZ12=-PZ3 + PE12=SHPR-PE3 + PMS12=PE12**2-PZ12**2 + SQL12=SQRT(MAX(0D0,(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2)) + IF(SQL12.LT.1D-6*SHP) THEN + MINT(51)=1 + RETURN + ENDIF + PMM1=PMS12+PMS1-PMS2 + PMM2=PMS12+PMS2-PMS1 + TFAC=-SHPR/(2D0*PMS12) + T1P=TFAC*(PE12-PZ12)*(PMM1-SQL12) + T1N=TFAC*(PE12-PZ12)*(PMM1+SQL12) + T2P=TFAC*(PE12+PZ12)*(PMM2-SQL12) + T2N=TFAC*(PE12+PZ12)*(PMM2+SQL12) + +C...Construct relative mirror weights and make choice. + IF(MPTPK.EQ.1.OR.ISUB.EQ.351.OR.ISUB.EQ.352) THEN + WTPU=1D0 + WTNU=1D0 + ELSE + WTPU=1D0/((T1P-PMRS1)*(T2P-PMRS2))**2 + WTNU=1D0/((T1N-PMRS1)*(T2N-PMRS2))**2 + ENDIF + WTP=WTPU/(WTPU+WTNU) + WTN=WTNU/(WTPU+WTNU) + EPS=1D0 + IF(WTN.GT.PYR(0)) EPS=-1D0 + +C...Store result of variable choice and associated weights. + VINT(202)=PTS1 + VINT(207)=PTS2 + VINT(203)=PHI1 + VINT(208)=PHI2 + VINT(205)=WTPTS1 + VINT(210)=WTPTS2 + VINT(211)=Y3 + VINT(212)=Y3MAX + VINT(213)=EPS + IF(EPS.GT.0D0) THEN + VINT(214)=1D0/WTP + VINT(215)=T1P + VINT(216)=T2P + ELSE + VINT(214)=1D0/WTN + VINT(215)=T1N + VINT(216)=T2N + ENDIF + VINT(217)=-0.5D0*TFAC*(PE12-PZ12)*(PMM2+EPS*SQL12) + VINT(218)=-0.5D0*TFAC*(PE12+PZ12)*(PMM1+EPS*SQL12) + VINT(219)=0.5D0*(PMS12-PTS3) + VINT(220)=SQL12 + ENDIF + + RETURN + END + +C*********************************************************************** + +C...PYSIGH +C...Differential matrix elements for all included subprocesses +C...Note that what is coded is (disregarding the COMFAC factor) +C...1) for 2 -> 1 processes: s-hat/pi*d(sigma-hat), where, +C...when d(sigma-hat) is given in the zero-width limit, the delta +C...function in tau is replaced by a (modified) Breit-Wigner: +C...1/pi*s*H_res/((s*tau-m_res^2)^2+H_res^2), +C...where H_res = s-hat/m_res*Gamma_res(s-hat); +C...2) for 2 -> 2 processes: (s-hat)**2/pi*d(sigma-hat)/d(t-hat); +C...i.e., dimensionless quantities +C...3) for 2 -> 3 processes: abs(M)^2, where the total cross-section is +C...Integral abs(M)^2/(2shat') * (prod_(i=1)^3 d^3p_i/((2pi)^3*2E_i)) * +C...(2pi)^4 delta^4(P - sum p_i) +C...COMFAC contains the factor pi/s (or equivalent) and +C...the conversion factor from GeV^-2 to mb + + SUBROUTINE PYSIGH(NCHN,SIGS) + +C...Double precision and integer declarations + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) + COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000) + COMMON/PYINT4/MWID(500),WIDS(500,5) + COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) + COMMON/PYINT7/SIGT(0:6,0:6,0:5) + COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) + COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), + &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) + COMMON/PYTCSM/ITCM(0:99),RTCM(0:99) + COMMON/PYPUED/IUED(0:99),RUED(0:99) + COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA, + &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4, + &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW, + &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR + COMMON/PYTCCO/COEFX(194:380,2) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/, + &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/, + &/PYMSSM/,/PYSSMT/,/PYTCSM/,/PYPUED/,/PYSGCM/,/PYTCCO/ +C...Local arrays and complex variables + DIMENSION XPQ(-25:25) + +C...Map of processes onto which routine to call +C...in order to evaluate cross section: +C...0 = not implemented; +C...1 = standard QCD (including photons); +C...2 = heavy flavours; +C...3 = W/Z; +C...4 = Higgs (2 doublets; including longitudinal W/Z scattering); +C...5 = SUSY; +C...6 = Technicolor; +C...7 = exotics (Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*). +C...8 = Universal Extra Dimensions + DIMENSION MAPPR(500) + DATA (MAPPR(I),I=1,180)/ + & 3, 3, 4, 0, 4, 0, 0, 4, 0, 1, + 1 1, 1, 1, 1, 3, 3, 0, 1, 3, 3, + 2 0, 3, 3, 4, 3, 4, 0, 1, 1, 3, + 3 3, 4, 1, 1, 3, 3, 0, 0, 0, 0, + 4 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 5 0, 0, 1, 1, 0, 0, 0, 1, 0, 0, + 6 0, 0, 0, 0, 0, 0, 0, 1, 3, 3, + 7 4, 4, 4, 0, 0, 4, 4, 0, 0, 1, + 8 2, 2, 2, 2, 2, 2, 2, 2, 2, 0, + 9 1, 1, 1, 1, 1, 1, 0, 0, 1, 0, + & 0, 4, 4, 2, 2, 2, 2, 2, 0, 4, + 1 4, 4, 4, 1, 1, 0, 0, 0, 0, 0, + 2 4, 4, 4, 4, 0, 0, 0, 0, 0, 0, + 3 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 4 7, 7, 4, 7, 7, 7, 7, 7, 6, 0, + 5 4, 4, 4, 0, 0, 4, 4, 4, 0, 0, + 6 4, 7, 7, 7, 6, 6, 7, 7, 7, 0, + 7 4, 4, 4, 4, 0, 4, 4, 4, 4, 0/ + DATA (MAPPR(I),I=181,500)/ + 8 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, + 9 6, 6, 6, 6, 6, 0, 0, 0, 0, 0, + & 100*5, + & 5, 0, 0, 0, 0, 0, 0, 0, 0, 0, + & 8, 8, 8, 8, 8, 8, 8, 8, 8, 0, + 1 20*0, + 4 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, + 5 7, 7, 7, 7, 0, 0, 0, 0, 0, 0, + 6 6, 6, 6, 6, 6, 6, 6, 6, 0, 6, + 7 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, + 8 6, 6, 6, 6, 6, 6, 6, 6, 0, 0, + 9 7, 7, 7, 7, 7, 0, 0, 0, 0, 0, + & 4, 4, 18*0, + 2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 0, + 4 20*0, + 6 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 0, + 8 7, 7, 18*0/ + +C...Reset number of channels and cross-section + NCHN=0 + SIGS=0D0 + +C...Read process to consider. + ISUB=MINT(1) + ISUBSV=ISUB + MAP=MAPPR(ISUB) + +C...Read kinematical variables and limits + ISTSB=ISET(ISUBSV) + TAUMIN=VINT(11) + YSTMIN=VINT(12) + CTNMIN=VINT(13) + CTPMIN=VINT(14) + TAUPMN=VINT(16) + TAU=VINT(21) + YST=VINT(22) + CTH=VINT(23) + XT2=VINT(25) + TAUP=VINT(26) + TAUMAX=VINT(31) + YSTMAX=VINT(32) + CTNMAX=VINT(33) + CTPMAX=VINT(34) + TAUPMX=VINT(36) + +C...Derive kinematical quantities + TAUE=TAU + IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP + X(1)=SQRT(TAUE)*EXP(YST) + X(2)=SQRT(TAUE)*EXP(-YST) + IF(MINT(45).EQ.2.AND.ISTSB.GE.1) THEN + IF(X(1).GT.1D0-1D-7) RETURN + ELSEIF(MINT(45).EQ.3) THEN + X(1)=MIN(1D0-1.1D-10,X(1)) + ENDIF + IF(MINT(46).EQ.2.AND.ISTSB.GE.1) THEN + IF(X(2).GT.1D0-1D-7) RETURN + ELSEIF(MINT(46).EQ.3) THEN + X(2)=MIN(1D0-1.1D-10,X(2)) + ENDIF + SH=MAX(1D0,TAU*VINT(2)) + SQM3=VINT(63) + SQM4=VINT(64) + RM3=SQM3/SH + RM4=SQM4/SH + BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4)) + RPTS=4D0*VINT(71)**2/SH + BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS)) + RM34=MAX(1D-20,2D0*RM3*RM4) + RSQM=1D0+RM34 + IF(2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2)).LT.0.0001D0) + &RM34=MAX(RM34,2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2))) + RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L) + IF(ISTSB.EQ.0) THEN + TH=VINT(45) + UH=-0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH) + SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*VINT(59)**2) + ELSE +C...Kinematics with incoming masses tricky: now depends on how +C...subprocess has been set up w.r.t. order of incoming partons. + RM1=0D0 + IF(MINT(15).EQ.22.AND.VINT(3).LT.0D0) RM1=-VINT(3)**2/SH + RM2=0D0 + IF(MINT(16).EQ.22.AND.VINT(4).LT.0D0) RM2=-VINT(4)**2/SH + IF(ISUB.EQ.35) THEN + RM2=MIN(RM1,RM2) + RM1=0D0 + ENDIF + BE12=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)) + TUCOM=(1D0-RM1-RM2)*(1D0-RM3-RM4) + TH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM4-2D0*RM2*RM3- + & BE12*BE34*CTH) + UH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM3-2D0*RM2*RM4+ + & BE12*BE34*CTH) + SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*(1D0-CTH**2)) + ENDIF + SHR=SQRT(SH) + SH2=SH**2 + TH2=TH**2 + UH2=UH**2 + +C...Choice of Q2 scale for hard process (e.g. alpha_s). + IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN + Q2=SH + ELSEIF(ISTSB.EQ.8) THEN + IF(MINT(107).EQ.4) Q2=VINT(307) + IF(MINT(108).EQ.4) Q2=VINT(308) + ELSEIF(MOD(ISTSB,2).EQ.0.OR.ISTSB.EQ.9) THEN + Q2IN1=0D0 + IF(MINT(11).EQ.22.AND.VINT(3).LT.0D0) Q2IN1=VINT(3)**2 + Q2IN2=0D0 + IF(MINT(12).EQ.22.AND.VINT(4).LT.0D0) Q2IN2=VINT(4)**2 + IF(MSTP(32).EQ.1) THEN + Q2=2D0*SH*TH*UH/(SH**2+TH**2+UH**2) + ELSEIF(MSTP(32).EQ.2) THEN + Q2=SQPTH+0.5D0*(SQM3+SQM4) + ELSEIF(MSTP(32).EQ.3) THEN + Q2=MIN(-TH,-UH) + ELSEIF(MSTP(32).EQ.4) THEN + Q2=SH + ELSEIF(MSTP(32).EQ.5) THEN + Q2=-TH + ELSEIF(MSTP(32).EQ.6) THEN + XSF1=X(1) + IF(ISTSB.EQ.9) XSF1=X(1)/VINT(143) + XSF2=X(2) + IF(ISTSB.EQ.9) XSF2=X(2)/VINT(144) + Q2=(1D0+XSF1*Q2IN1/SH+XSF2*Q2IN2/SH)* + & (SQPTH+0.5D0*(SQM3+SQM4)) + ELSEIF(MSTP(32).EQ.7) THEN + Q2=(1D0+Q2IN1/SH+Q2IN2/SH)*(SQPTH+0.5D0*(SQM3+SQM4)) + ELSEIF(MSTP(32).EQ.8) THEN + Q2=SQPTH+0.5D0*(Q2IN1+Q2IN2+SQM3+SQM4) + ELSEIF(MSTP(32).EQ.9) THEN + Q2=SQPTH+Q2IN1+Q2IN2+SQM3+SQM4 + ELSEIF(MSTP(32).EQ.10) THEN + Q2=VINT(2) +C..Begin JA 040914 + ELSEIF(MSTP(32).EQ.11) THEN + Q2=0.25*(SQM3+SQM4+2*SQRT(SQM3*SQM4)) + ELSEIF(MSTP(32).EQ.12) THEN + Q2=PARP(193) +C..End JA + ELSEIF(MSTP(32).EQ.13) THEN + Q2=SQPTH + ENDIF + IF(MINT(35).LE.2.AND.ISTSB.EQ.9) Q2=SQPTH + IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2=Q2+ + & (PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2 + ENDIF + +C...Choice of Q2 scale for parton densities. + Q2SF=Q2 +C..Begin JA 040914 + IF(MSTP(32).EQ.12.AND.(MOD(ISTSB,2).EQ.0.OR.ISTSB.EQ.9) + & .OR.MSTP(39).EQ.8.AND.(ISTSB.GE.3.AND.ISTSB.LE.5)) + & Q2=PARP(194) +C..End JA + IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN + Q2SF=PMAS(23,1)**2 + IF(ISUB.EQ.8.OR.ISUB.EQ.76.OR.ISUB.EQ.77.OR.ISUB.EQ.124.OR. + & ISUB.EQ.174.OR.ISUB.EQ.179.OR.ISUB.EQ.351) Q2SF=PMAS(24,1)**2 + IF(ISUB.EQ.352) Q2SF=PMAS(PYCOMP(9900024),1)**2 + IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182.OR. + & ISUB.EQ.186.OR.ISUB.EQ.187.OR.ISUB.EQ.401.OR.ISUB.EQ.402) THEN + Q2SF=PMAS(PYCOMP(KFPR(ISUBSV,2)),1)**2 + IF(MSTP(39).EQ.2) Q2SF= + & MAX(VINT(201)**2+VINT(202),VINT(206)**2+VINT(207)) + IF(MSTP(39).EQ.3) Q2SF=SH + IF(MSTP(39).EQ.4) Q2SF=VINT(26)*VINT(2) + IF(MSTP(39).EQ.5) Q2SF=PMAS(PYCOMP(KFPR(ISUBSV,1)),1)**2 +C..Begin JA 040914 + IF(MSTP(39).EQ.6) Q2SF=0.25*(VINT(201)+SQRT(SH))**2 + IF(MSTP(39).EQ.7) Q2SF= + & (VINT(201)**2+VINT(202)+VINT(206)**2+VINT(207))/2d0 + IF(MSTP(39).EQ.8) Q2SF=PARP(193) +C..End JA + ENDIF + ENDIF + IF(MINT(35).GE.3.AND.ISTSB.EQ.9) Q2SF=SQPTH + + Q2PS=Q2SF + Q2SF=Q2SF*PARP(34) + IF(MSTP(69).GE.1.AND.MINT(47).EQ.5) Q2SF=VINT(2) + IF(MSTP(69).GE.2) Q2SF=VINT(2) + +C...Identify to which class(es) subprocess belongs + ISMECR=0 + ISQCD=0 + ISJETS=0 + IF (ISUBSV.EQ.1.OR.ISUBSV.EQ.2.OR.ISUBSV.EQ.3.OR. + & ISUBSV.EQ.102.OR.ISUBSV.EQ.141.OR.ISUBSV.EQ.142.OR. + & ISUBSV.EQ.144.OR.ISUBSV.EQ.151.OR.ISUBSV.EQ.152.OR. + & ISUBSV.EQ.156.OR.ISUBSV.EQ.157) ISMECR=1 + IF (ISUBSV.EQ.11.OR.ISUBSV.EQ.12.OR.ISUBSV.EQ.13.OR. + & ISUBSV.EQ.28.OR.ISUBSV.EQ.53.OR.ISUBSV.EQ.68) ISQCD=1 + IF ((ISUBSV.EQ.81.OR.ISUBSV.EQ.82).AND.MINT(55).LE.5) ISQCD=1 + IF (ISUBSV.GE.381.AND.ISUBSV.LE.386) ISQCD=1 + IF ((ISUBSV.EQ.387.OR.ISUBSV.EQ.388).AND.MINT(55).LE.5) ISQCD=1 + IF (ISTSB.EQ.9) ISQCD=1 + IF ((ISUBSV.GE.86.AND.ISUBSV.LE.89).OR.ISUBSV.EQ.107.OR. + & (ISUBSV.GE.14.AND.ISUBSV.LE.16).OR.(ISUBSV.GE.29.AND. + & ISUBSV.LE.32).OR.(ISUBSV.GE.111.AND.ISUBSV.LE.113).OR. + & ISUBSV.EQ.115.OR.(ISUBSV.GE.183.AND.ISUBSV.LE.185).OR. + & (ISUBSV.GE.188.AND.ISUBSV.LE.190).OR.ISUBSV.EQ.161.OR. + & ISUBSV.EQ.167.OR.ISUBSV.EQ.168.OR.(ISUBSV.GE.393.AND. + & ISUBSV.LE.395).OR.(ISUBSV.GE.421.AND.ISUBSV.LE.439).OR. + & (ISUBSV.GE.461.AND.ISUBSV.LE.479)) ISJETS=1 +C...WBF is special case of ISJETS + IF (ISUBSV.EQ.5.OR.ISUBSV.EQ.8.OR. + & (ISUBSV.GE.71.AND.ISUBSV.LE.73).OR. + & ISUBSV.EQ.76.OR.ISUBSV.EQ.77.OR. + & (ISUBSV.GE.121.AND.ISUBSV.LE.124).OR. + & ISUBSV.EQ.173.OR.ISUBSV.EQ.174.OR. + & ISUBSV.EQ.178.OR.ISUBSV.EQ.179.OR. + & ISUBSV.EQ.181.OR.ISUBSV.EQ.182.OR. + & ISUBSV.EQ.186.OR.ISUBSV.EQ.187.OR. + & ISUBSV.EQ.351.OR.ISUBSV.EQ.352) ISJETS=2 +C...Some processes with photons also belong here. + IF (ISUBSV.EQ.10.OR.(ISUBSV.GE.18.AND.ISUBSV.LE.20).OR. + & (ISUBSV.GE.33.AND.ISUBSV.LE.36).OR.ISUBSV.EQ.54.OR. + & ISUBSV.EQ.58.OR.ISUBSV.EQ.69.OR.ISUBSV.EQ.70.OR. + & ISUBSV.EQ.80.OR.(ISUBSV.GE.83.AND.ISUBSV.LE.85).OR. + & (ISUBSV.GE.106.AND.ISUBSV.LE.110).OR.ISUBSV.EQ.114.OR. + & (ISUBSV.GE.131.AND.ISUBSV.LE.140)) ISJETS=3 + +C...Choice of Q2 scale for parton-shower activity. + IF(MSTP(22).GE.1.AND.(ISUB.EQ.10.OR.ISUB.EQ.83).AND. + &(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN + XBJ=X(2) + IF(MINT(43).EQ.3) XBJ=X(1) + IF(MSTP(22).EQ.1) THEN + Q2PS=-TH + ELSEIF(MSTP(22).EQ.2) THEN + Q2PS=((1D0-XBJ)/XBJ)*(-TH) + ELSEIF(MSTP(22).EQ.3) THEN + Q2PS=SQRT((1D0-XBJ)/XBJ)*(-TH) + ELSE + Q2PS=(1D0-XBJ)*MAX(1D0,-LOG(XBJ))*(-TH) + ENDIF + ENDIF +C...For multiple interactions, start from scale defined above +C...For all other QCD or "+jets"-type events, start shower from pThard. + IF (ISJETS.EQ.1.OR.ISQCD.EQ.1.AND.ISTSB.NE.9) Q2PS=SQPTH + IF((MSTP(68).EQ.1.OR.MSTP(68).EQ.3).AND.ISMECR.EQ.1) THEN +C...Max shower scale = s for ME corrected processes. +C...(pT-ordering: max pT2 is s/4) + Q2PS=VINT(2) + IF (MINT(35).GE.3) Q2PS=Q2PS*0.25D0 + ELSEIF(MSTP(68).GE.2.AND.ISQCD.EQ.0.AND.ISJETS.EQ.0) THEN +C...Max shower scale = s for all non-QCD, non-"+ jet" type processes. +C...(pT-ordering: max pT2 is s/4) + Q2PS=VINT(2) + IF (MINT(35).GE.3) Q2PS=Q2PS*0.25D0 + ENDIF + IF(MINT(35).EQ.2.AND.ISTSB.EQ.9) Q2PS=SQPTH + +C...Elastic and diffractive events not associated with scales so set 0. + IF(ISUBSV.GE.91.AND.ISUBSV.LE.94) THEN + Q2SF=0D0 + Q2PS=0D0 + ENDIF + +C...Store derived kinematical quantities + VINT(41)=X(1) + VINT(42)=X(2) + VINT(44)=SH + VINT(43)=SQRT(SH) + VINT(45)=TH + VINT(46)=UH + IF(ISTSB.NE.8) VINT(48)=SQPTH + IF(ISTSB.NE.8) VINT(47)=SQRT(SQPTH) + VINT(50)=TAUP*VINT(2) + VINT(49)=SQRT(MAX(0D0,VINT(50))) + VINT(52)=Q2 + VINT(51)=SQRT(Q2) + VINT(54)=Q2SF + VINT(53)=SQRT(Q2SF) + VINT(56)=Q2PS + VINT(55)=SQRT(Q2PS) + +C...Set starting scale for multiple interactions + IF (ISUBSV.EQ.95) THEN + XT2GMX=0D0 + ELSEIF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUBSV.NE.11.AND. + & ISUBSV.NE.12.AND.ISUBSV.NE.13.AND.ISUBSV.NE.28.AND. + & ISUBSV.NE.53.AND.ISUBSV.NE.68.AND.ISUBSV.NE.95.AND. + & ISUBSV.NE.96)) THEN +C...All accessible phase space allowed. + XT2GMX=(1D0-VINT(41))*(1D0-VINT(42)) + ELSE +C...Scale of hard process sets limit. +C...2 -> 1. Limit is tau = x1*x2. +C...2 -> 2. Limit is XT2 for hard process + FS masses. +C...2 -> n > 2. Limit is tau' = tau of outer process. + XT2GMX=VINT(25) + IF(ISTSB.EQ.1) XT2GMX=VINT(21) + IF(ISTSB.EQ.2) + & XT2GMX=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2) + IF(ISTSB.GE.3.AND.ISTSB.LE.5) XT2GMX=VINT(26) + ENDIF + VINT(62)=0.25D0*XT2GMX*VINT(2) + VINT(61)=SQRT(MAX(0D0,VINT(62))) + +C...Calculate parton distributions + IF(ISTSB.LE.0) GOTO 160 + IF(MINT(47).GE.2) THEN + DO 110 I=3-MIN(2,MINT(45)),MIN(2,MINT(46)) + XSF=X(I) + IF(ISTSB.EQ.9) XSF=X(I)/VINT(142+I) + IF(ISUB.EQ.99) THEN + IF(MINT(140+I).EQ.0) THEN + XSF=VINT(309-I)/(VINT(2)+VINT(309-I)-VINT(I+2)**2) + ELSE + XSF=VINT(309-I)/(VINT(2)+VINT(307)+VINT(308)) + ENDIF + VINT(40+I)=XSF + Q2SF=VINT(309-I) + ENDIF + MINT(105)=MINT(102+I) + MINT(109)=MINT(106+I) + VINT(120)=VINT(2+I) +C...Default is to use standard PDFs, but for interactions after the first +C...in the new multiple-parton-interactions framework, set which side to +C...evaluate the MPI-modified PDFs on. + MINT(30)=0 + IF (MINT(31).GE.1) MINT(30)=I + IF(MSTP(57).LE.1) THEN + CALL PYPDFU(MINT(10+I),XSF,Q2SF,XPQ) + ELSE + CALL PYPDFL(MINT(10+I),XSF,Q2SF,XPQ) + ENDIF +C...Safety margin against heavy flavour very close to threshold, +C...e.g. caused by mismatch in c and b masses. + IF(Q2SF.LT.1.1*PMAS(4,1)**2) THEN + XPQ(4)=0D0 + XPQ(-4)=0D0 + ENDIF + IF(Q2SF.LT.1.1*PMAS(5,1)**2) THEN + XPQ(5)=0D0 + XPQ(-5)=0D0 + ENDIF + DO 100 KFL=-25,25 + XSFX(I,KFL)=XPQ(KFL) + 100 CONTINUE + 110 CONTINUE + ENDIF + +C...Calculate alpha_em, alpha_strong and K-factor + XW=PARU(102) + XWV=XW + IF(MSTP(8).GE.2.OR.(ISUB.GE.71.AND.ISUB.LE.77)) XW= + &1D0-(PMAS(24,1)/PMAS(23,1))**2 + XW1=1D0-XW + XWC=1D0/(16D0*XW*XW1) + AEM=PYALEM(Q2) + IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1) + IF(MSTP(33).NE.3) AS=PYALPS(PARP(34)*Q2) + FACK=1D0 + FACA=1D0 + IF(MSTP(33).EQ.1) THEN + FACK=PARP(31) + ELSEIF(MSTP(33).EQ.2) THEN + FACK=PARP(31) + FACA=PARP(32)/PARP(31) + ELSEIF(MSTP(33).EQ.3) THEN + Q2AS=PARP(33)*Q2 + IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2AS=Q2AS+ + & PARU(112)*PARP(82)*(VINT(1)/PARP(89))**PARP(90) + AS=PYALPS(Q2AS) +C...PS (12 Feb 2010) +C...New options MSTP(33) = 10 and 11 +C... 10: use K-factor = PARP(32) only for process 96 (MPI) +C... 11: as for 10, but also use K-factor = PARP(31) for other procs + ELSEIF(MSTP(33).GE.10) THEN + IF (ISUB.EQ.96) THEN + FACK = PARP(32) + ELSEIF (ISUB.NE.96.AND.MSTP(33).EQ.11) THEN + FACK = PARP(31) + ENDIF + ENDIF + VINT(138)=1D0 + VINT(57)=AEM + VINT(58)=AS + +C...Set flags for allowed reacting partons/leptons + DO 140 I=1,2 + DO 120 J=-25,25 + KFAC(I,J)=0 + 120 CONTINUE + IF(MINT(44+I).EQ.1) THEN + KFAC(I,MINT(10+I))=1 + ELSEIF(MINT(40+I).EQ.1.AND.MSTP(12).EQ.0) THEN + KFAC(I,MINT(10+I))=1 + KFAC(I,22)=1 + KFAC(I,24)=1 + KFAC(I,-24)=1 + ELSE + DO 130 J=-25,25 + KFAC(I,J)=KFIN(I,J) + IF(IABS(J).GT.MSTP(58).AND.IABS(J).LE.10) KFAC(I,J)=0 + IF(XSFX(I,J).LT.1D-10) KFAC(I,J)=0 + 130 CONTINUE + ENDIF + 140 CONTINUE + +C...Lower and upper limit for fermion flavour loops + MMIN1=0 + MMAX1=0 + MMIN2=0 + MMAX2=0 + DO 150 J=-20,20 + IF(KFAC(1,-J).EQ.1) MMIN1=-J + IF(KFAC(1,J).EQ.1) MMAX1=J + IF(KFAC(2,-J).EQ.1) MMIN2=-J + IF(KFAC(2,J).EQ.1) MMAX2=J + 150 CONTINUE + MMINA=MIN(MMIN1,MMIN2) + MMAXA=MAX(MMAX1,MMAX2) + +C...Common resonance mass and width combinations + SQMZ=PMAS(23,1)**2 + SQMW=PMAS(24,1)**2 + GMMZ=PMAS(23,1)*PMAS(23,2) + GMMW=PMAS(24,1)*PMAS(24,2) + +C...Polarization factors...implemented so far for W+W-(25) + POLR=(1D0+PARJ(132))*(1D0-PARJ(131)) + POLL=(1D0-PARJ(132))*(1D0+PARJ(131)) + POLRR=(1D0+PARJ(132))*(1D0+PARJ(131)) + POLLL=(1D0-PARJ(132))*(1D0-PARJ(131)) + +C...Phase space integral in tau + COMFAC=PARU(1)*PARU(5)/VINT(2) + IF(MINT(41).EQ.2.AND.MINT(42).EQ.2) COMFAC=COMFAC*FACK + IF((MINT(47).GE.2.OR.(ISTSB.GE.3.AND.ISTSB.LE.5)).AND. + &ISTSB.NE.8.AND.ISTSB.NE.9) THEN + ATAU1=LOG(TAUMAX/TAUMIN) + ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN) + H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/TAU + IF(MINT(72).GE.1) THEN + TAUR1=VINT(73) + GAMR1=VINT(74) + ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1)) + ATAU3=ATAUD/TAUR1 + IF(ATAUD.GT.1D-10) H1=H1+ + & (ATAU1/ATAU3)*COEF(ISUBSV,3)/(TAU+TAUR1) + ATAUD=ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1) + ATAU4=ATAUD/GAMR1 + IF(ATAUD.GT.1D-10) H1=H1+ + & (ATAU1/ATAU4)*COEF(ISUBSV,4)*TAU/((TAU-TAUR1)**2+GAMR1**2) + ENDIF + IF(MINT(72).GE.2) THEN + TAUR2=VINT(75) + GAMR2=VINT(76) + ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2)) + ATAU5=ATAUD/TAUR2 + IF(ATAUD.GT.1D-10) H1=H1+ + & (ATAU1/ATAU5)*COEF(ISUBSV,5)/(TAU+TAUR2) + ATAUD=ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2) + ATAU6=ATAUD/GAMR2 + IF(ATAUD.GT.1D-10) H1=H1+ + & (ATAU1/ATAU6)*COEF(ISUBSV,6)*TAU/((TAU-TAUR2)**2+GAMR2**2) + ENDIF + IF(MINT(72).EQ.3) THEN + TAUR3=VINT(77) + GAMR3=VINT(78) + ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR3)/(TAUMAX+TAUR3)) + ATAU50=ATAUD/TAUR3 + IF(ATAUD.GT.1D-10) H1=H1+ + & (ATAU1/ATAU50)*COEFX(ISUBSV,1)/(TAU+TAUR3) + ATAUD=ATAN((TAUMAX-TAUR3)/GAMR3)-ATAN((TAUMIN-TAUR3)/GAMR3) + ATAU60=ATAUD/GAMR3 + IF(ATAUD.GT.1D-10) H1=H1+ + & (ATAU1/ATAU60)*COEFX(ISUBSV,2)*TAU/((TAU-TAUR3)**2+GAMR3**2) + ENDIF + IF(MINT(47).EQ.5.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN + ATAU7=LOG(MAX(2D-10,1D0-TAUMIN)/MAX(2D-10,1D0-TAUMAX)) + IF(ATAU7.GT.1D-10) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/ + & MAX(2D-10,1D0-TAU) + ELSEIF(MINT(47).GE.6.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN + ATAU7=LOG(MAX(1D-10,1D0-TAUMIN)/MAX(1D-10,1D0-TAUMAX)) + IF(ATAU7.GT.1D-10) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/ + & MAX(1D-10,1D0-TAU) + ENDIF + COMFAC=COMFAC*ATAU1/(TAU*H1) + ENDIF + +C...Phase space integral in y* + IF((MINT(47).EQ.4.OR.MINT(47).EQ.5).AND.ISTSB.NE.8.AND.ISTSB.NE.9) + &THEN + AYST0=YSTMAX-YSTMIN + IF(AYST0.LT.1D-10) THEN + COMFAC=0D0 + ELSE + AYST1=0.5D0*(YSTMAX-YSTMIN)**2 + AYST2=AYST1 + AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN))) + H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+ + & (AYST0/AYST2)*COEF(ISUBSV,9)*(YSTMAX-YST)+ + & (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST) + IF(MINT(45).EQ.3) THEN + YST0=-0.5D0*LOG(TAUE) + AYST4=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0)/ + & MAX(1D-10,EXP(YST0-YSTMAX)-1D0)) + IF(AYST4.GT.1D-10) H2=H2+(AYST0/AYST4)*COEF(ISUBSV,11)/ + & MAX(1D-10,1D0-EXP(YST-YST0)) + ENDIF + IF(MINT(46).EQ.3) THEN + YST0=-0.5D0*LOG(TAUE) + AYST5=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0)/ + & MAX(1D-10,EXP(YST0+YSTMIN)-1D0)) + IF(AYST5.GT.1D-10) H2=H2+(AYST0/AYST5)*COEF(ISUBSV,12)/ + & MAX(1D-10,1D0-EXP(-YST-YST0)) + ENDIF + COMFAC=COMFAC*AYST0/H2 + ENDIF + ENDIF + +C...2 -> 1 processes: reduction in angular part of phase space integral +C...for case of decaying resonance + ACTH0=CTNMAX-CTNMIN+CTPMAX-CTPMIN + IF((ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5)) THEN + IF(MDCY(PYCOMP(KFPR(ISUBSV,1)),1).EQ.1) THEN + IF(KFPR(ISUB,1).EQ.25.OR.KFPR(ISUB,1).EQ.37.OR. + & KFPR(ISUB,1).EQ.39) THEN + COMFAC=COMFAC*0.5D0*ACTH0 + ELSE + COMFAC=COMFAC*0.125D0*(3D0*ACTH0+CTNMAX**3-CTNMIN**3+ + & CTPMAX**3-CTPMIN**3) + ENDIF + ENDIF + +C...2 -> 2 processes: angular part of phase space integral + ELSEIF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN + ACTH1=LOG((MAX(RM34,RSQM-CTNMIN)*MAX(RM34,RSQM-CTPMIN))/ + & (MAX(RM34,RSQM-CTNMAX)*MAX(RM34,RSQM-CTPMAX))) + ACTH2=LOG((MAX(RM34,RSQM+CTNMAX)*MAX(RM34,RSQM+CTPMAX))/ + & (MAX(RM34,RSQM+CTNMIN)*MAX(RM34,RSQM+CTPMIN))) + ACTH3=1D0/MAX(RM34,RSQM-CTNMAX)-1D0/MAX(RM34,RSQM-CTNMIN)+ + & 1D0/MAX(RM34,RSQM-CTPMAX)-1D0/MAX(RM34,RSQM-CTPMIN) + ACTH4=1D0/MAX(RM34,RSQM+CTNMIN)-1D0/MAX(RM34,RSQM+CTNMAX)+ + & 1D0/MAX(RM34,RSQM+CTPMIN)-1D0/MAX(RM34,RSQM+CTPMAX) + H3=COEF(ISUBSV,13)+ + & (ACTH0/ACTH1)*COEF(ISUBSV,14)/MAX(RM34,RSQM-CTH)+ + & (ACTH0/ACTH2)*COEF(ISUBSV,15)/MAX(RM34,RSQM+CTH)+ + & (ACTH0/ACTH3)*COEF(ISUBSV,16)/MAX(RM34,RSQM-CTH)**2+ + & (ACTH0/ACTH4)*COEF(ISUBSV,17)/MAX(RM34,RSQM+CTH)**2 + COMFAC=COMFAC*ACTH0*0.5D0*BE34/H3 + +C...2 -> 2 processes: take into account final state Breit-Wigners + COMFAC=COMFAC*VINT(80) + ENDIF + +C...2 -> 3, 4 processes: phace space integral in tau' + IF(MINT(47).GE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5) THEN + ATAUP1=LOG(TAUPMX/TAUPMN) + ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU) + H4=COEF(ISUBSV,18)+ + & (ATAUP1/ATAUP2)*COEF(ISUBSV,19)*(1D0-TAU/TAUP)**3/TAUP + IF(MINT(47).EQ.5) THEN + ATAUP3=LOG(MAX(2D-10,1D0-TAUPMN)/MAX(2D-10,1D0-TAUPMX)) + H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(2D-10,1D0-TAUP) + ELSEIF(MINT(47).GE.6) THEN + ATAUP3=LOG(MAX(1D-10,1D0-TAUPMN)/MAX(1D-10,1D0-TAUPMX)) + H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(1D-10,1D0-TAUP) + ENDIF + COMFAC=COMFAC*ATAUP1/H4 + ENDIF + +C...2 -> 3, 4 processes: effective W/Z parton distributions + IF(ISTSB.EQ.3.OR.ISTSB.EQ.4) THEN + IF(1D0-TAU/TAUP.GT.1D-4) THEN + FZW=(1D0+TAU/TAUP)*LOG(TAUP/TAU)-2D0*(1D0-TAU/TAUP) + ELSE + FZW=1D0/6D0*(1D0-TAU/TAUP)**3*TAU/TAUP + ENDIF + COMFAC=COMFAC*FZW + ENDIF + +C...2 -> 3 processes: phase space integrals for pT1, pT2, y3, mirror + IF(ISTSB.EQ.5) THEN + COMFAC=COMFAC*VINT(205)*VINT(210)*VINT(212)*VINT(214)/ + & (128D0*PARU(1)**4*VINT(220))*(TAU**2/TAUP) + ENDIF + +C...Phase space integral for low-pT and multiple interactions + IF(ISTSB.EQ.9) THEN + COMFAC=PARU(1)*PARU(5)*FACK*0.5D0*VINT(2)/SH2 + ATAU1=LOG(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0) + ATAU2=2D0*ATAN(1D0/XT2-1D0)/SQRT(XT2) + H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/SQRT(TAU) + COMFAC=COMFAC*ATAU1/H1 + AYST0=YSTMAX-YSTMIN + AYST1=0.5D0*(YSTMAX-YSTMIN)**2 + AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN))) + H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+ + & (AYST0/AYST1)*COEF(ISUBSV,9)*(YSTMAX-YST)+ + & (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST) + COMFAC=COMFAC*AYST0/H2 + IF(MSTP(82).LE.1) COMFAC=COMFAC*XT2**2*(1D0/VINT(149)-1D0) +C...For MSTP(82)>=2 an additional factor (xT2/(xT2+VINT(149))**2 is +C...introduced to make cross-section finite for xT2 -> 0 + IF(MSTP(82).GE.2) COMFAC=COMFAC*XT2**2/(VINT(149)* + & (1D0+VINT(149))) + ENDIF + +C...Real gamma + gamma: include factor 2 when different nature + 160 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND. + &MSTP(14).LE.10) COMFAC=2D0*COMFAC + +C...Extra factors to include the effects of +C...longitudinal resolved photons (but not direct or DIS ones). + DO 170 ISDE=1,2 + IF(MINT(10+ISDE).EQ.22.AND.MINT(106+ISDE).GE.1.AND. + & MINT(106+ISDE).LE.3) THEN + VINT(314+ISDE)=1D0 + XY=PARP(166+ISDE) + IF(MSTP(16).EQ.0) THEN + IF(VINT(304+ISDE).GT.0D0.AND.VINT(304+ISDE).LT.1D0) + & XY=VINT(304+ISDE) + ELSE + IF(VINT(308+ISDE).GT.0D0.AND.VINT(308+ISDE).LT.1D0) + & XY=VINT(308+ISDE) + ENDIF + Q2GA=VINT(306+ISDE) + IF(MSTP(17).GT.0.AND.XY.GT.0D0.AND.XY.LT.1D0.AND. + & Q2GA.GT.0D0) THEN + REDUCE=0D0 + IF(MSTP(17).EQ.1) THEN + REDUCE=4D0*Q2*Q2GA/(Q2+Q2GA)**2 + ELSEIF(MSTP(17).EQ.2) THEN + REDUCE=4D0*Q2GA/(Q2+Q2GA) + ELSEIF(MSTP(17).EQ.3) THEN + PMVIRT=PMAS(PYCOMP(113),1) + REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA) + ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.1) THEN + PMVIRT=PMAS(PYCOMP(113),1) + REDUCE=4D0*PMVIRT**2*Q2GA/(PMVIRT**2+Q2GA)**2 + ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.2) THEN + PMVIRT=PMAS(PYCOMP(113),1) + REDUCE=4D0*PMVIRT**2*Q2GA/(PMVIRT**2+Q2GA)**2 + ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.3) THEN + PMVSMN=4D0*PARP(15)**2 + PMVSMX=4D0*VINT(154)**2 + REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA) + REDLON=(3D0*PMVSMN+Q2GA)/(PMVSMN+Q2GA)**3- + & (3D0*PMVSMX+Q2GA)/(PMVSMX+Q2GA)**3 + REDUCE=4D0*(Q2GA/6D0)*REDLON/REDTRA + ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.1) THEN + PMVIRT=PMAS(PYCOMP(113),1) + REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA) + ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.2) THEN + PMVIRT=PMAS(PYCOMP(113),1) + REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA) + ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.3) THEN + PMVSMN=4D0*PARP(15)**2 + PMVSMX=4D0*VINT(154)**2 + REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA) + REDLON=1D0/(PMVSMN+Q2GA)**2-1D0/(PMVSMX+Q2GA)**2 + REDUCE=4D0*(Q2GA/2D0)*REDLON/REDTRA + ENDIF + BEAMAS=PYMASS(11) + IF(VINT(302+ISDE).GT.0D0) BEAMAS=VINT(302+ISDE) + FRACLT=1D0/(1D0+XY**2/2D0/(1D0-XY)* + & (1D0-2D0*BEAMAS**2/Q2GA)) + VINT(314+ISDE)=1D0+PARP(165)*REDUCE*FRACLT + ENDIF + ELSE + VINT(314+ISDE)=1D0 + ENDIF + COMFAC=COMFAC*VINT(314+ISDE) + 170 CONTINUE + +C...Evaluate cross sections - done in separate routines by kind +C...of physics, to keep PYSIGH of sensible size. + IF(MAP.EQ.1) THEN +C...Standard QCD (including photons). + CALL PYSGQC(NCHN,SIGS) + ELSEIF(MAP.EQ.2) THEN +C...Heavy flavours. + CALL PYSGHF(NCHN,SIGS) + ELSEIF(MAP.EQ.3) THEN +C...W/Z. + CALL PYSGWZ(NCHN,SIGS) + ELSEIF(MAP.EQ.4) THEN +C...Higgs (2 doublets; including longitudinal W/Z scattering). + CALL PYSGHG(NCHN,SIGS) + ELSEIF(MAP.EQ.5) THEN +C...SUSY. + CALL PYSGSU(NCHN,SIGS) + ELSEIF(MAP.EQ.6) THEN +C...Technicolor. + CALL PYSGTC(NCHN,SIGS) + ELSEIF(MAP.EQ.7) THEN +C...Exotics (Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*). + CALL PYSGEX(NCHN,SIGS) + ELSEIF(MAP.EQ.8) THEN +C... Universal Extra Dimensions + CALL PYXUED(NCHN,SIGS) + ENDIF + +C...Multiply with parton distributions + IF(ISUB.LE.90.OR.ISUB.GE.96) THEN + DO 180 ICHN=1,NCHN + IF(MINT(45).GE.2) THEN + KFL1=ISIG(ICHN,1) + SIGH(ICHN)=SIGH(ICHN)*XSFX(1,KFL1) + ENDIF + IF(MINT(46).GE.2) THEN + KFL2=ISIG(ICHN,2) + SIGH(ICHN)=SIGH(ICHN)*XSFX(2,KFL2) + ENDIF + SIGS=SIGS+SIGH(ICHN) + 180 CONTINUE + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYSGQC +C...Subprocess cross sections for QCD processes, +C...including photons. +C...Auxiliary to PYSIGH. + + SUBROUTINE PYSGQC(NCHN,SIGS) + +C...Double precision and integer declarations + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) + COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000) + COMMON/PYINT4/MWID(500),WIDS(500,5) + COMMON/PYINT7/SIGT(0:6,0:6,0:5) + COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA, + &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4, + &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW, + &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR + SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/, + &/PYINT3/,/PYINT4/,/PYINT7/,/PYSGCM/ +C...Local arrays + DIMENSION WDTP(0:400),WDTE(0:400,0:5) + +C...Differential cross section expressions. + + IF(ISUB.LE.20) THEN + IF(ISUB.EQ.10) THEN +C...f + f' -> f + f' (gamma/Z/W exchange) + FACGGF=COMFAC*AEM**2*2D0*(SH2+UH2)/TH2 + FACGZF=COMFAC*AEM**2*XWC*4D0*SH2/(TH*(TH-SQMZ)) + FACZZF=COMFAC*(AEM*XWC)**2*2D0*SH2/(TH-SQMZ)**2 + FACWWF=COMFAC*(0.5D0*AEM/XW)**2*SH2/(TH-SQMW)**2 + DO 110 I=MMIN1,MMAX1 + IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 110 + IA=IABS(I) + DO 100 J=MMIN2,MMAX2 + IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 100 + JA=IABS(J) +C...Electroweak couplings + EI=KCHG(IA,1)*ISIGN(1,I)/3D0 + AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I) + VI=AI-4D0*EI*XWV + EJ=KCHG(JA,1)*ISIGN(1,J)/3D0 + AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J) + VJ=AJ-4D0*EJ*XWV + EPSIJ=ISIGN(1,I*J) +C...gamma/Z exchange, only gamma exchange, or only Z exchange + IF(MSTP(21).GE.1.AND.MSTP(21).LE.4) THEN + IF(MSTP(21).EQ.1.OR.MSTP(21).EQ.4) THEN + FACNCF=FACGGF*EI**2*EJ**2+FACGZF*EI*EJ* + & (VI*VJ*(1D0+UH2/SH2)+AI*AJ*EPSIJ*(1D0-UH2/SH2))+ + & FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*(1D0+UH2/SH2)+ + & 4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2)) + ELSEIF(MSTP(21).EQ.2) THEN + FACNCF=FACGGF*EI**2*EJ**2 + ELSE + FACNCF=FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)* + & (1D0+UH2/SH2)+4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2)) + ENDIF +C...Extrafactor 2 for only one incoming neutrino spin state. + IF(IA.GT.10.AND.MOD(IA,2).EQ.0) FACNCF=2D0*FACNCF + IF(JA.GT.10.AND.MOD(JA,2).EQ.0) FACNCF=2D0*FACNCF + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACNCF + ENDIF +C...W exchange + IF((MSTP(21).EQ.1.OR.MSTP(21).EQ.5).AND.AI*AJ.LT.0D0) THEN + FACCCF=FACWWF*VINT(180+I)*VINT(180+J) + IF(EPSIJ.LT.0D0) FACCCF=FACCCF*UH2/SH2 + IF(IA.GT.10.AND.MOD(IA,2).EQ.0) FACCCF=2D0*FACCCF + IF(JA.GT.10.AND.MOD(JA,2).EQ.0) FACCCF=2D0*FACCCF + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=2 + SIGH(NCHN)=FACCCF + ENDIF + 100 CONTINUE + 110 CONTINUE + + ELSEIF(ISUB.EQ.11) THEN +C...f + f' -> f + f' (g exchange) + FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2 + FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA- + & MSTP(34)*2D0/3D0*UH2/(SH*TH)) + FACQQ2=COMFAC*AS**2*4D0/9D0*((SH2+TH2)/UH2- + & MSTP(34)*2D0/3D0*SH2/(TH*UH)) + DO 130 I=MMIN1,MMAX1 + IA=IABS(I) + IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 130 + DO 120 J=MMIN2,MMAX2 + JA=IABS(J) + IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 120 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQ1 + IF(I.EQ.-J) SIGH(NCHN)=FACQQB + IF(I.EQ.J) THEN + SIGH(NCHN)=0.5D0*SIGH(NCHN) + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=2 + SIGH(NCHN)=0.5D0*FACQQ2 + ENDIF + 120 CONTINUE + 130 CONTINUE + + ELSEIF(ISUB.EQ.12) THEN +C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only) + CALL PYWIDT(21,SH,WDTP,WDTE) + FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2* + & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) + DO 140 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR. + & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 140 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQB + 140 CONTINUE + + ELSEIF(ISUB.EQ.13) THEN +C...f + fbar -> g + g (q + qbar -> g + g only) + FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)* + & UH2/SH2) + FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)* + & TH2/SH2) + DO 150 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR. + & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 150 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=0.5D0*FACGG1 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=2 + SIGH(NCHN)=0.5D0*FACGG2 + 150 CONTINUE + + ELSEIF(ISUB.EQ.14) THEN +C...f + fbar -> g + gamma (q + qbar -> g + gamma only) + FACGG=COMFAC*AS*AEM*8D0/9D0*(TH2+UH2)/(TH*UH) + DO 160 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR. + & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 160 + EI=KCHG(IABS(I),1)/3D0 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACGG*EI**2 + 160 CONTINUE + + ELSEIF(ISUB.EQ.18) THEN +C...f + fbar -> gamma + gamma + FACGG=COMFAC*AEM**2*2D0*(TH2+UH2)/(TH*UH) + DO 170 I=MMINA,MMAXA + IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 170 + EI=KCHG(IABS(I),1)/3D0 + FCOI=1D0 + IF(IABS(I).LE.10) FCOI=FACA/3D0 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=0.5D0*FACGG*FCOI*EI**4 + 170 CONTINUE + ENDIF + + ELSEIF(ISUB.LE.40) THEN + IF(ISUB.EQ.28) THEN +C...f + g -> f + g (q + g -> q + g only) + FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2- + & UH/SH)*FACA + FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2- + & SH/UH) + DO 190 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 190 + DO 180 ISDE=1,2 + IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 180 + IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 180 + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQG1 + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=21 + ISIG(NCHN,3)=2 + SIGH(NCHN)=FACQG2 + 180 CONTINUE + 190 CONTINUE + + ELSEIF(ISUB.EQ.29) THEN +C...f + g -> f + gamma (q + g -> q + gamma only) + FGQ=COMFAC*FACA*AS*AEM*1D0/3D0*(SH2+UH2)/(-SH*UH) + DO 210 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 210 + EI=KCHG(IABS(I),1)/3D0 + FACGQ=FGQ*EI**2 + DO 200 ISDE=1,2 + IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 200 + IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 200 + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACGQ + 200 CONTINUE + 210 CONTINUE + + ELSEIF(ISUB.EQ.33) THEN +C...f + gamma -> f + g (q + gamma -> q + g only) + FGQ=COMFAC*AS*AEM*8D0/3D0*(SH2+UH2)/(-SH*UH) + DO 230 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 230 + EI=KCHG(IABS(I),1)/3D0 + FACGQ=FGQ*EI**2 + DO 220 ISDE=1,2 + IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 220 + IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 220 + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=22 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACGQ + 220 CONTINUE + 230 CONTINUE + + ELSEIF(ISUB.EQ.34) THEN +C...f + gamma -> f + gamma + FGQ=COMFAC*AEM**2*2D0*(SH2+UH2)/(-SH*UH) + DO 250 I=MMINA,MMAXA + IF(I.EQ.0) GOTO 250 + EI=KCHG(IABS(I),1)/3D0 + FACGQ=FGQ*EI**4 + DO 240 ISDE=1,2 + IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 240 + IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 240 + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=22 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACGQ + 240 CONTINUE + 250 CONTINUE + ENDIF + + ELSEIF(ISUB.LE.80) THEN + IF(ISUB.EQ.53) THEN +C...g + g -> f + fbar (g + g -> q + qbar only) + IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 270 + IDC0=MDCY(21,2)-1 +C...Begin by d, u, s flavours. + FLAVWT=0D0 + IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+ + & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH)) + IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+ + & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH)) + IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+ + & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH)) + FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)* + & UH2/SH2)*FLAVWT*FACA + FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)* + & TH2/SH2)*FLAVWT*FACA + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQ1 + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=2 + SIGH(NCHN)=FACQQ2 +C...Next c and b flavours: modified that and uhat for fixed +C...cos(theta-hat). + DO 260 IFL=4,5 + SQMAVG=PMAS(IFL,1)**2 + IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN + BE34=SQRT(1D0-4D0*SQMAVG/SH) + THQ=-0.5D0*SH*(1D0-BE34*CTH) + UHQ=-0.5D0*SH*(1D0+BE34*CTH) + THUHQ=THQ*UHQ-SQMAVG*SH + IF(MSTP(34).EQ.0) THEN + FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2 + FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2 + ELSE + FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/ + & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ) + FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/ + & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ) + ENDIF + FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34 + FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34 + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1+2*(IFL-3) + SIGH(NCHN)=FACQQ1 + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=2+2*(IFL-3) + SIGH(NCHN)=FACQQ2 + ENDIF + 260 CONTINUE + 270 CONTINUE + + ELSEIF(ISUB.EQ.54) THEN +C...g + gamma -> f + fbar (g + gamma -> q + qbar only) + CALL PYWIDT(21,SH,WDTP,WDTE) + WDTESU=0D0 + DO 280 I=1,MIN(8,MDCY(21,3)) + EF=KCHG(I,1)/3D0 + WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+ + & WDTE(I,4)) + 280 CONTINUE + FACQQ=COMFAC*AEM*AS*WDTESU*(TH2+UH2)/(TH*UH) + IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=22 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQ + ENDIF + IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=22 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQ + ENDIF + + ELSEIF(ISUB.EQ.58) THEN +C...gamma + gamma -> f + fbar + CALL PYWIDT(22,SH,WDTP,WDTE) + WDTESU=0D0 + DO 290 I=1,MIN(12,MDCY(22,3)) + IF(I.LE.8) EF= KCHG(I,1)/3D0 + IF(I.GE.9) EF= KCHG(9+2*(I-8),1)/3D0 + WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+ + & WDTE(I,4)) + 290 CONTINUE + FACFF=COMFAC*AEM**2*WDTESU*2D0*(TH2+UH2)/(TH*UH) + IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=22 + ISIG(NCHN,2)=22 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACFF + ENDIF + + ELSEIF(ISUB.EQ.68) THEN +C...g + g -> g + g + IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 300 + FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+2D0*TH/SH+ + & TH2/SH2)*FACA + FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+2D0*SH/UH+ + & SH2/UH2)*FACA + FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3D0+2D0*UH/TH+ + & UH2/TH2) + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=0.5D0*FACGG1 + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=2 + SIGH(NCHN)=0.5D0*FACGG2 + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=3 + SIGH(NCHN)=0.5D0*FACGG3 + 300 CONTINUE + + ELSEIF(ISUB.EQ.80) THEN +C...q + gamma -> q' + pi+/- + FQPI=COMFAC*(2D0*AEM/9D0)*(-SH/TH)*(1D0/SH2+1D0/TH2) + ASSH=PYALPS(MAX(0.5D0,0.5D0*SH)) + Q2FPSH=0.55D0/LOG(MAX(2D0,2D0*SH)) + DELSH=UH*SQRT(ASSH*Q2FPSH) + ASUH=PYALPS(MAX(0.5D0,-0.5D0*UH)) + Q2FPUH=0.55D0/LOG(MAX(2D0,-2D0*UH)) + DELUH=SH*SQRT(ASUH*Q2FPUH) + DO 320 I=MAX(-2,MMINA),MIN(2,MMAXA) + IF(I.EQ.0) GOTO 320 + EI=KCHG(IABS(I),1)/3D0 + EJ=SIGN(1D0-ABS(EI),EI) + DO 310 ISDE=1,2 + IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 310 + IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 310 + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=22 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FQPI*(EI*DELSH+EJ*DELUH)**2 + 310 CONTINUE + 320 CONTINUE + ENDIF + + ELSEIF(ISUB.LE.100) THEN + IF(ISUB.EQ.91) THEN +C...Elastic scattering + SIGS=VINT(315)*VINT(316)*SIGT(0,0,1) + + ELSEIF(ISUB.EQ.92) THEN +C...Single diffractive scattering (first side, i.e. XB) + SIGS=VINT(315)*VINT(316)*SIGT(0,0,2) + + ELSEIF(ISUB.EQ.93) THEN +C...Single diffractive scattering (second side, i.e. AX) + SIGS=VINT(315)*VINT(316)*SIGT(0,0,3) + + ELSEIF(ISUB.EQ.94) THEN +C...Double diffractive scattering + SIGS=VINT(315)*VINT(316)*SIGT(0,0,4) + + ELSEIF(ISUB.EQ.95) THEN +C...Low-pT scattering + SIGS=VINT(315)*VINT(316)*SIGT(0,0,5) + + ELSEIF(ISUB.EQ.96) THEN +C...Multiple interactions: sum of QCD processes + CALL PYWIDT(21,SH,WDTP,WDTE) + +C...q + q' -> q + q' + FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2 + FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA- + & MSTP(34)*2D0/3D0*UH2/(SH*TH)) + FACQQ2=COMFAC*AS**2*4D0/9D0*(SH2+TH2)/UH2 + FACQQI=-COMFAC*AS**2*4D0/9D0*MSTP(34)*2D0/3D0*SH2/(TH*UH) + RATQQI=(FACQQ1+FACQQ2+FACQQI)/(FACQQ1+FACQQ2) + DO 340 I=-5,5 + IF(I.EQ.0) GOTO 340 + DO 330 J=-5,5 + IF(J.EQ.0) GOTO 330 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=111 + SIGH(NCHN)=FACQQ1 + IF(I.EQ.-J) SIGH(NCHN)=FACQQB + IF(I.EQ.J) THEN + SIGH(NCHN)=0.5D0*FACQQ1*RATQQI + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=112 + SIGH(NCHN)=0.5D0*FACQQ2*RATQQI + ENDIF + 330 CONTINUE + 340 CONTINUE + +C...q + qbar -> q' + qbar' or g + g + FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2* + & (WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4)) + FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)* + & UH2/SH2) + FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)* + & TH2/SH2) + DO 350 I=-5,5 + IF(I.EQ.0) GOTO 350 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=121 + SIGH(NCHN)=FACQQB + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=131 + SIGH(NCHN)=0.5D0*FACGG1 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=132 + SIGH(NCHN)=0.5D0*FACGG2 + 350 CONTINUE + +C...q + g -> q + g + FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2- + & UH/SH)*FACA + FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2- + & SH/UH) + DO 370 I=-5,5 + IF(I.EQ.0) GOTO 370 + DO 360 ISDE=1,2 + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=21 + ISIG(NCHN,3)=281 + SIGH(NCHN)=FACQG1 + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=21 + ISIG(NCHN,3)=282 + SIGH(NCHN)=FACQG2 + 360 CONTINUE + 370 CONTINUE + +C...g + g -> q + qbar (only d, u, s) + IDC0=MDCY(21,2)-1 + FLAVWT=0D0 + IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+ + & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH)) + IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+ + & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH)) + IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+ + & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH)) + FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)* + & UH2/SH2)*FLAVWT*FACA + FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)* + & TH2/SH2)*FLAVWT*FACA + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=531 + SIGH(NCHN)=FACQQ1 + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=532 + SIGH(NCHN)=FACQQ2 + +C...g + g -> c + cbar, b + bbar: modified that/uhat for fixed +C...cos(theta-hat) + DO 380 IFL=4,5 + SQMAVG=PMAS(IFL,1)**2 + IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN + BE34=SQRT(1D0-4D0*SQMAVG/SH) + THQ=-0.5D0*SH*(1D0-BE34*CTH) + UHQ=-0.5D0*SH*(1D0+BE34*CTH) + THUHQ=THQ*UHQ-SQMAVG*SH + IF(MSTP(34).EQ.0) THEN + FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2 + FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2 + ELSE + FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/ + & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ) + FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/ + & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ) + ENDIF + FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34 + FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34 + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=531+2*(IFL-3) + SIGH(NCHN)=FACQQ1 + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=532+2*(IFL-3) + SIGH(NCHN)=FACQQ2 + ENDIF + 380 CONTINUE + +C...g + g -> g + g + FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+ + & 2D0*TH/SH+TH2/SH2)*FACA + FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+ + & 2D0*SH/UH+SH2/UH2)*FACA + FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3+ + & 2D0*UH/TH+UH2/TH2) + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=681 + SIGH(NCHN)=0.5D0*FACGG1 + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=682 + SIGH(NCHN)=0.5D0*FACGG2 + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=683 + SIGH(NCHN)=0.5D0*FACGG3 + + ELSEIF(ISUB.EQ.99) THEN +C...f + gamma* -> f. + IF(MINT(107).EQ.4) THEN + Q2GA=VINT(307) + P2GA=VINT(308) + ISDE=2 + ELSE + Q2GA=VINT(308) + P2GA=VINT(307) + ISDE=1 + ENDIF + COMFAC=PARU(5)*4D0*PARU(1)**2*PARU(101)*VINT(315)*VINT(316) + PM2RHO=PMAS(PYCOMP(113),1)**2 + IF(MSTP(19).EQ.0) THEN + COMFAC=COMFAC/Q2GA + ELSEIF(MSTP(19).EQ.1) THEN + COMFAC=COMFAC/(Q2GA+PM2RHO) + ELSEIF(MSTP(19).EQ.2) THEN + COMFAC=COMFAC*Q2GA/(Q2GA+PM2RHO)**2 + ELSE + COMFAC=COMFAC*Q2GA/(Q2GA+PM2RHO)**2 + W2GA=VINT(2) + IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN + RDRDS=4.1D-3*W2GA**2.167D0/((Q2GA+0.15D0*W2GA)**2* + & Q2GA**0.75D0)*(1D0+0.11D0*Q2GA*P2GA/(1D0+0.02D0*P2GA**2)) + XGA=Q2GA/(W2GA+VINT(307)+VINT(308)) + ELSE + RDRDS=1.5D-4*W2GA**2.167D0/((Q2GA+0.041D0*W2GA)**2* + & Q2GA**0.57D0) + XGA=Q2GA/(W2GA+Q2GA-PMAS(PYCOMP(MINT(10+ISDE)),1)**2) + ENDIF + COMFAC=COMFAC*EXP(-MAX(1D-10,RDRDS)) + IF(MSTP(19).EQ.4) COMFAC=COMFAC/MAX(1D-2,1D0-XGA) + ENDIF + DO 390 I=MMINA,MMAXA + IF(I.EQ.0.OR.KFAC(ISDE,I).EQ.0) GOTO 390 + IF(IABS(I).LT.10.AND.IABS(I).GT.MSTP(58)) GOTO 390 + EI=KCHG(IABS(I),1)/3D0 + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=22 + ISIG(NCHN,3)=1 + SIGH(NCHN)=COMFAC*EI**2 + 390 CONTINUE + ENDIF + + ELSE + IF(ISUB.EQ.114.OR.ISUB.EQ.115) THEN +C...g + g -> gamma + gamma or g + g -> g + gamma + A0STUR=0D0 + A0STUI=0D0 + A0TSUR=0D0 + A0TSUI=0D0 + A0UTSR=0D0 + A0UTSI=0D0 + A1STUR=0D0 + A1STUI=0D0 + A2STUR=0D0 + A2STUI=0D0 + ALST=LOG(-SH/TH) + ALSU=LOG(-SH/UH) + ALTU=LOG(TH/UH) + IMAX=2*MSTP(1) + IF(MSTP(38).GE.1.AND.MSTP(38).LE.8) IMAX=MSTP(38) + DO 400 I=1,IMAX + EI=KCHG(IABS(I),1)/3D0 + EIWT=EI**2 + IF(ISUB.EQ.115) EIWT=EI + SQMQ=PMAS(I,1)**2 + EPSS=4D0*SQMQ/SH + EPST=4D0*SQMQ/TH + EPSU=4D0*SQMQ/UH + IF((MSTP(38).GE.1.AND.MSTP(38).LE.8).OR.EPSS.LT.1D-4) THEN + B0STUR=1D0+(TH-UH)/SH*ALTU+0.5D0*(TH2+UH2)/SH2*(ALTU**2+ + & PARU(1)**2) + B0STUI=0D0 + B0TSUR=1D0+(SH-UH)/TH*ALSU+0.5D0*(SH2+UH2)/TH2*ALSU**2 + B0TSUI=-PARU(1)*((SH-UH)/TH+(SH2+UH2)/TH2*ALSU) + B0UTSR=1D0+(SH-TH)/UH*ALST+0.5D0*(SH2+TH2)/UH2*ALST**2 + B0UTSI=-PARU(1)*((SH-TH)/UH+(SH2+TH2)/UH2*ALST) + B1STUR=-1D0 + B1STUI=0D0 + B2STUR=-1D0 + B2STUI=0D0 + ELSE + CALL PYWAUX(1,EPSS,W1SR,W1SI) + CALL PYWAUX(1,EPST,W1TR,W1TI) + CALL PYWAUX(1,EPSU,W1UR,W1UI) + CALL PYWAUX(2,EPSS,W2SR,W2SI) + CALL PYWAUX(2,EPST,W2TR,W2TI) + CALL PYWAUX(2,EPSU,W2UR,W2UI) + CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI) + CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI) + CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI) + CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI) + CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI) + CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI) + B0STUR=1D0+(1D0+2D0*TH/SH)*W1TR+(1D0+2D0*UH/SH)*W1UR+ + & 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TR+W2UR)- + & 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTR+Y3TUSR)- + & 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUR+Y3UTSR)+ + & 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+ + & 0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR) + B0STUI=(1D0+2D0*TH/SH)*W1TI+(1D0+2D0*UH/SH)*W1UI+ + & 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TI+W2UI)- + & 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTI+Y3TUSI)- + & 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUI+Y3UTSI)+ + & 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+ + & 0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI) + B0TSUR=1D0+(1D0+2D0*SH/TH)*W1SR+(1D0+2D0*UH/TH)*W1UR+ + & 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SR+W2UR)- + & 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSR+Y3SUTR)- + & 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUR+Y3USTR)+ + & 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+ + & 0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR) + B0TSUI=(1D0+2D0*SH/TH)*W1SI+(1D0+2D0*UH/TH)*W1UI+ + & 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SI+W2UI)- + & 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSI+Y3SUTI)- + & 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUI+Y3USTI)+ + & 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+ + & 0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI) + B0UTSR=1D0+(1D0+2D0*TH/UH)*W1TR+(1D0+2D0*SH/UH)*W1SR+ + & 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TR+W2SR)- + & 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTR+Y3TSUR)- + & 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSR+Y3STUR)+ + & 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+ + & 0.5D0*EPST*EPSS)*(Y3TUSR+Y3SUTR) + B0UTSI=(1D0+2D0*TH/UH)*W1TI+(1D0+2D0*SH/UH)*W1SI+ + & 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TI+W2SI)- + & 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTI+Y3TSUI)- + & 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSI+Y3STUI)+ + & 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+ + & 0.5D0*EPST*EPSS)*(Y3TUSI+Y3SUTI) + B1STUR=-1D0-0.25D0*(EPSS+EPST+EPSU)*(W2SR+W2TR+W2UR)+ + & 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTR+Y3TUSR)+ + & 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)+ + & 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR) + B1STUI=-0.25D0*(EPSS+EPST+EPSU)*(W2SI+W2TI+W2UI)+ + & 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTI+Y3TUSI)+ + & 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)+ + & 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI) + B2STUR=-1D0+0.125D0*EPSS*EPST*(Y3SUTR+Y3TUSR)+ + & 0.125D0*EPSS*EPSU*(Y3STUR+Y3UTSR)+ + & 0.125D0*EPST*EPSU*(Y3TSUR+Y3USTR) + B2STUI=0.125D0*EPSS*EPST*(Y3SUTI+Y3TUSI)+ + & 0.125D0*EPSS*EPSU*(Y3STUI+Y3UTSI)+ + & 0.125D0*EPST*EPSU*(Y3TSUI+Y3USTI) + ENDIF + A0STUR=A0STUR+EIWT*B0STUR + A0STUI=A0STUI+EIWT*B0STUI + A0TSUR=A0TSUR+EIWT*B0TSUR + A0TSUI=A0TSUI+EIWT*B0TSUI + A0UTSR=A0UTSR+EIWT*B0UTSR + A0UTSI=A0UTSI+EIWT*B0UTSI + A1STUR=A1STUR+EIWT*B1STUR + A1STUI=A1STUI+EIWT*B1STUI + A2STUR=A2STUR+EIWT*B2STUR + A2STUI=A2STUI+EIWT*B2STUI + 400 CONTINUE + ASQSUM=A0STUR**2+A0STUI**2+A0TSUR**2+A0TSUI**2+A0UTSR**2+ + & A0UTSI**2+4D0*A1STUR**2+4D0*A1STUI**2+A2STUR**2+A2STUI**2 + FACGG=COMFAC*FACA/(16D0*PARU(1)**2)*AS**2*AEM**2*ASQSUM + FACGP=COMFAC*FACA*5D0/(192D0*PARU(1)**2)*AS**3*AEM*ASQSUM + IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 410 + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1 + IF(ISUB.EQ.114) SIGH(NCHN)=0.5D0*FACGG + IF(ISUB.EQ.115) SIGH(NCHN)=FACGP + 410 CONTINUE + + ELSEIF(ISUB.EQ.131.OR.ISUB.EQ.132) THEN +C...f + gamma*_(T,L) -> f + g (q + gamma*_(T,L) -> q + g only) + PH=0D0 + IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0) + & PH=VINT(3)**2 + IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0) + & PH=VINT(4)**2 + IF(ISUB.EQ.131) THEN + FGQ=COMFAC*AS*AEM*8D0/3D0*SH**2/(SH+PH)**2* + & ((SH2+UH2-2D0*PH*TH)/(-SH*UH)-2D0*PH*TH/(SH+PH)**2) + ELSE + FGQ=COMFAC*AS*AEM*8D0/3D0*SH**2/(SH+PH)**4*(-4D0*PH*TH) + ENDIF + DO 430 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 430 + EI=KCHG(IABS(I),1)/3D0 + FACGQ=FGQ*EI**2 + DO 420 ISDE=1,2 + IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 420 + IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 420 + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=22 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACGQ + 420 CONTINUE + 430 CONTINUE + + ELSEIF(ISUB.EQ.133.OR.ISUB.EQ.134) THEN +C...f + gamma*_(T,L) -> f + gamma + PH=0D0 + IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0) + & PH=VINT(3)**2 + IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0) + & PH=VINT(4)**2 + IF(ISUB.EQ.133) THEN + FGQ=COMFAC*AEM**2*2D0*SH**2/(SH+PH)**2* + & ((SH2+UH2-2D0*PH*TH)/(-SH*UH)-2D0*PH*TH/(SH+PH)**2) + ELSE + FGQ=COMFAC*AEM**2*2D0*SH**2/(SH+PH)**4*(-4D0*PH*TH) + ENDIF + DO 450 I=MMINA,MMAXA + IF(I.EQ.0) GOTO 450 + EI=KCHG(IABS(I),1)/3D0 + FACGQ=FGQ*EI**4 + DO 440 ISDE=1,2 + IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 440 + IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 440 + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=22 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACGQ + 440 CONTINUE + 450 CONTINUE + + ELSEIF(ISUB.EQ.135.OR.ISUB.EQ.136) THEN +C...g + gamma*_(T,L) -> f + fbar (g + gamma*_(T,L) -> q + qbar only) + PH=0D0 + IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0) + & PH=VINT(3)**2 + IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0) + & PH=VINT(4)**2 + CALL PYWIDT(21,SH,WDTP,WDTE) + WDTESU=0D0 + DO 460 I=1,MIN(8,MDCY(21,3)) + EF=KCHG(I,1)/3D0 + WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+ + & WDTE(I,4)) + 460 CONTINUE + IF(ISUB.EQ.135) THEN + FACQQ=COMFAC*AEM*AS*WDTESU*SH**2/(SH+PH)**2* + & ((TH2+UH2-2D0*PH*SH)/(TH*UH)+4D0*PH*SH/(SH+PH)**2) + ELSE + FACQQ=COMFAC*AEM*AS*WDTESU*SH**2/(SH+PH)**4*8D0*PH*SH + ENDIF + IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=22 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQ + ENDIF + IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=22 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQ + ENDIF + + ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN +C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar + PH1=0D0 + IF(VINT(3).LT.0D0) PH1=VINT(3)**2 + PH2=0D0 + IF(VINT(4).LT.0D0) PH2=VINT(4)**2 + CALL PYWIDT(22,SH,WDTP,WDTE) + WDTESU=0D0 + DO 470 I=1,MIN(12,MDCY(22,3)) + IF(I.LE.8) EF= KCHG(I,1)/3D0 + IF(I.GE.9) EF= KCHG(9+2*(I-8),1)/3D0 + WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+ + & WDTE(I,4)) + 470 CONTINUE + DLAMB2=(TH+UH)**2-4D0*PH1*PH2 + IF(ISUB.EQ.137) THEN + FPARAM=-SH*(TH+UH)/DLAMB2 + FACFF=COMFAC*AEM**2*WDTESU*2D0*SH2/(DLAMB2*TH2*UH2)* + & (TH*UH-PH1*PH2)*((TH2+UH2)*(1D0-2D0*FPARAM*(1D0-FPARAM))- + & 2D0*PH1*PH2*FPARAM**2) + ELSEIF(ISUB.EQ.138) THEN + FACFF=COMFAC*AEM**2*WDTESU*4D0*SH2*SH/(DLAMB2**2*TH2*UH2)* + & PH2*(4D0*(TH*UH-PH1*PH2)*(TH*UH+PH1*SH*(TH-UH)**2/DLAMB2)+ + & 2D0*PH1**2*(TH-UH)**2) + ELSEIF(ISUB.EQ.139) THEN + FACFF=COMFAC*AEM**2*WDTESU*4D0*SH2*SH/(DLAMB2**2*TH2*UH2)* + & PH1*(4D0*(TH*UH-PH1*PH2)*(TH*UH+PH2*SH*(TH-UH)**2/DLAMB2)+ + & 2D0*PH2**2*(TH-UH)**2) + ELSE + FACFF=COMFAC*AEM**2*WDTESU*32D0*SH2**2/(DLAMB2**3*TH2*UH2)* + & PH1*PH2*(TH*UH-PH1*PH2)*(TH-UH)**2 + ENDIF + IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=22 + ISIG(NCHN,2)=22 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACFF + ENDIF + + ENDIF + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYSGHF +C...Subprocess cross sections for heavy flavour production, +C...open and closed. +C...Auxiliary to PYSIGH. + + SUBROUTINE PYSGHF(NCHN,SIGS) + +C...Double precision and integer declarations + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) + COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000) + COMMON/PYINT4/MWID(500),WIDS(500,5) + COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA, + &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4, + &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW, + &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR + SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/, + &/PYINT4/,/PYSGCM/ +C...Local arrays + DIMENSION WDTP(0:400),WDTE(0:400,0:5) + +C...Determine where are charmonium/bottomonium wave function parameters. + IONIUM=140 + IF(ISUB.GE.461.AND.ISUB.LE.479) IONIUM=145 + +C...Convert bottomonium process into equivalent charmonium ones. + IF(ISUB.GE.461.AND.ISUB.LE.479) ISUB=ISUB-40 + +C...Differential cross section expressions. + + IF(ISUB.LE.100) THEN + IF(ISUB.EQ.81) THEN +C...q + qbar -> Q + Qbar + SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH + THQ=-0.5D0*SH*(1D0-BE34*CTH) + UHQ=-0.5D0*SH*(1D0+BE34*CTH) + FACQQB=COMFAC*AS**2*4D0/9D0*((THQ**2+UHQ**2)/SH2+ + & 2D0*SQMAVG/SH) + IF(MSTP(35).GE.1) FACQQB=FACQQB*PYHFTH(SH,SQMAVG,0D0) + WID2=1D0 + IF(MINT(55).EQ.6) WID2=WIDS(6,1) + IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1) + FACQQB=FACQQB*WID2 + DO 100 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR. + & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQB + 100 CONTINUE + + ELSEIF(ISUB.EQ.82) THEN +C...g + g -> Q + Qbar + SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH + THQ=-0.5D0*SH*(1D0-BE34*CTH) + UHQ=-0.5D0*SH*(1D0+BE34*CTH) + THUHQ=THQ*UHQ-SQMAVG*SH + IF(MSTP(34).EQ.0) THEN + FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2 + FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2 + ELSE + FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/ + & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ) + FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/ + & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ) + ENDIF + FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1 + FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2 + IF(MSTP(35).GE.1) THEN + FATRE=PYHFTH(SH,SQMAVG,2D0/7D0) + FACQQ1=FACQQ1*FATRE + FACQQ2=FACQQ2*FATRE + ENDIF + WID2=1D0 + IF(MINT(55).EQ.6) WID2=WIDS(6,1) + IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1) + FACQQ1=FACQQ1*WID2 + FACQQ2=FACQQ2*WID2 + IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 110 + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQ1 + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=2 + SIGH(NCHN)=FACQQ2 + 110 CONTINUE + + ELSEIF(ISUB.EQ.83) THEN +C...f + q -> f' + Q + FACQQS=COMFAC*(0.5D0*AEM/XW)**2*SH*(SH-SQM3)/(SQMW-TH)**2 + FACQQU=COMFAC*(0.5D0*AEM/XW)**2*UH*(UH-SQM3)/(SQMW-TH)**2 + DO 130 I=MMIN1,MMAX1 + IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 130 + DO 120 J=MMIN2,MMAX2 + IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 120 + IF(I*J.GT.0.AND.MOD(IABS(I+J),2).EQ.0) GOTO 120 + IF(I*J.LT.0.AND.MOD(IABS(I+J),2).EQ.1) GOTO 120 + IF(IABS(I).LT.MINT(55).AND.MOD(IABS(I+MINT(55)),2).EQ.1) + & THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2, + & (IABS(I)+1)/2)*VINT(180+J) + IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(I)/2, + & (MINT(55)+1)/2)*VINT(180+J) + WID2=1D0 + IF(I.GT.0) THEN + IF(MINT(55).EQ.6) WID2=WIDS(6,2) + IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2= + & WIDS(MINT(55),2) + ELSE + IF(MINT(55).EQ.6) WID2=WIDS(6,3) + IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2= + & WIDS(MINT(55),3) + ENDIF + IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2 + IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2 + ENDIF + IF(IABS(J).LT.MINT(55).AND.MOD(IABS(J+MINT(55)),2).EQ.1) + & THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=2 + IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2, + & (IABS(J)+1)/2)*VINT(180+I) + IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(J)/2, + & (MINT(55)+1)/2)*VINT(180+I) + WID2=1D0 + IF(J.GT.0) THEN + IF(MINT(55).EQ.6) WID2=WIDS(6,2) + IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2= + & WIDS(MINT(55),2) + ELSE + IF(MINT(55).EQ.6) WID2=WIDS(6,3) + IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2= + & WIDS(MINT(55),3) + ENDIF + IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2 + IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2 + ENDIF + 120 CONTINUE + 130 CONTINUE + + ELSEIF(ISUB.EQ.84) THEN +C...g + gamma -> Q + Qbar + SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH + THQ=-0.5D0*SH*(1D0-BE34*CTH) + UHQ=-0.5D0*SH*(1D0+BE34*CTH) + FACQQ=COMFAC*AS*AEM*(KCHG(IABS(MINT(55)),1)/3D0)**2* + & (THQ**2+UHQ**2+4D0*SQMAVG*SH*(1D0-SQMAVG*SH/(THQ*UHQ)))/ + & (THQ*UHQ) + IF(MSTP(35).GE.1) FACQQ=FACQQ*PYHFTH(SH,SQMAVG,0D0) + WID2=1D0 + IF(MINT(55).EQ.6) WID2=WIDS(6,1) + IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1) + FACQQ=FACQQ*WID2 + IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=22 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQ + ENDIF + IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=22 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQ + ENDIF + + ELSEIF(ISUB.EQ.85) THEN +C...gamma + gamma -> F + Fbar (heavy fermion, quark or lepton) + SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH + THQ=-0.5D0*SH*(1D0-BE34*CTH) + UHQ=-0.5D0*SH*(1D0+BE34*CTH) + FACFF=COMFAC*AEM**2*(KCHG(IABS(MINT(56)),1)/3D0)**4*2D0* + & ((1D0-PARJ(131)*PARJ(132))*(THQ*UHQ-SQMAVG*SH)* + & (UHQ**2+THQ**2+2D0*SQMAVG*SH)+(1D0+PARJ(131)*PARJ(132))* + & SQMAVG*SH**2*(SH-2D0*SQMAVG))/(THQ*UHQ)**2 + IF(IABS(MINT(56)).LT.10) FACFF=3D0*FACFF + IF(IABS(MINT(56)).LT.10.AND.MSTP(35).GE.1) + & FACFF=FACFF*PYHFTH(SH,SQMAVG,1D0) + WID2=1D0 + IF(MINT(56).EQ.6) WID2=WIDS(6,1) + IF(MINT(56).EQ.7.OR.MINT(56).EQ.8) WID2=WIDS(MINT(56),1) + IF(MINT(56).EQ.17) WID2=WIDS(17,1) + FACFF=FACFF*WID2 + IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=22 + ISIG(NCHN,2)=22 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACFF + ENDIF + + ELSEIF(ISUB.EQ.86) THEN +C...g + g -> J/Psi + g + FACQQG=COMFAC*AS**3*(5D0/9D0)*PARP(38)*SQRT(SQM3)* + & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/ + & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2 + IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQG + ENDIF + + ELSEIF(ISUB.EQ.87) THEN +C...g + g -> chi_0c + g + PGTW=(SH*TH+TH*UH+UH*SH)/SH2 + QGTW=(SH*TH*UH)/SH**3 + RGTW=SQM3/SH + FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)* + & (9D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)- + & 6D0*RGTW*PGTW**3*QGTW*(2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)- + & PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)+ + & 2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)+6D0*RGTW**2*QGTW**4)/ + & (QGTW*(QGTW-RGTW*PGTW)**4) + IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQG + ENDIF + + ELSEIF(ISUB.EQ.88) THEN +C...g + g -> chi_1c + g + PGTW=(SH*TH+TH*UH+UH*SH)/SH2 + QGTW=(SH*TH*UH)/SH**3 + RGTW=SQM3/SH + FACQQG=COMFAC*AS**3*12D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)* + & PGTW**2*(RGTW*PGTW**2*(RGTW**2-4D0*PGTW)+2D0*QGTW*(-RGTW**4+ + & 5D0*RGTW**2*PGTW+PGTW**2)-15D0*RGTW*QGTW**2)/ + & (QGTW-RGTW*PGTW)**4 + IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQG + ENDIF + + ELSEIF(ISUB.EQ.89) THEN +C...g + g -> chi_2c + g + PGTW=(SH*TH+TH*UH+UH*SH)/SH2 + QGTW=(SH*TH*UH)/SH**3 + RGTW=SQM3/SH + FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)* + & (12D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)- + & 3D0*RGTW*PGTW**3*QGTW*(8D0*RGTW**4-RGTW**2*PGTW+4D0*PGTW**2)+ + & 2D0*PGTW**2*QGTW**2*(-7D0*RGTW**4+43D0*RGTW**2*PGTW+PGTW**2)+ + & RGTW*PGTW*QGTW**3*(16D0*RGTW**2-61D0*PGTW)+12D0*RGTW**2* + & QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4) + IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQG + ENDIF + ENDIF + + ELSEIF(ISUB.LE.200) THEN + IF(ISUB.EQ.104) THEN +C...g + g -> chi_c0. + KC=PYCOMP(10441) + FACBW=COMFAC*12D0*AS**2*PARP(39)*PMAS(KC,2)/ + & ((SH-PMAS(KC,1)**2)**2+(PMAS(KC,1)*PMAS(KC,2))**2) + IF(ABS(SQRT(SH)-PMAS(KC,1)).GT.50D0*PMAS(KC,2)) FACBW=0D0 + IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACBW + ENDIF + + ELSEIF(ISUB.EQ.105) THEN +C...g + g -> chi_c2. + KC=PYCOMP(445) + FACBW=COMFAC*16D0*AS**2*PARP(39)*PMAS(KC,2)/ + & ((SH-PMAS(KC,1)**2)**2+(PMAS(KC,1)*PMAS(KC,2))**2) + IF(ABS(SQRT(SH)-PMAS(KC,1)).GT.50D0*PMAS(KC,2)) FACBW=0D0 + IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACBW + ENDIF + + ELSEIF(ISUB.EQ.106) THEN +C...g + g -> J/Psi + gamma. + EQ=KCHG(MOD(KFPR(ISUB,1)/10,10),1)/3D0 + FACQQG=COMFAC*AEM*EQ**2*AS**2*(4D0/3D0)*PARP(38)*SQRT(SQM3)* + & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/ + & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2 + IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQG + ENDIF + + ELSEIF(ISUB.EQ.107) THEN +C...g + gamma -> J/Psi + g. + EQ=KCHG(MOD(KFPR(ISUB,1)/10,10),1)/3D0 + FACQQG=COMFAC*AEM*EQ**2*AS**2*(32D0/3D0)*PARP(38)*SQRT(SQM3)* + & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/ + & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2 + IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=22 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQG + ENDIF + IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=22 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQG + ENDIF + + ELSEIF(ISUB.EQ.108) THEN +C...gamma + gamma -> J/Psi + gamma. + EQ=KCHG(MOD(KFPR(ISUB,1)/10,10),1)/3D0 + FACQQG=COMFAC*AEM**3*EQ**6*384D0*PARP(38)*SQRT(SQM3)* + & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/ + & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2 + IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=22 + ISIG(NCHN,2)=22 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQG + ENDIF + ENDIF + +C...QUARKONIA+++ +C...Additional code by Stefan Wolf + ELSE + +C...Common code for quarkonium production. + SHTH=SH+TH + THUH=TH+UH + UHSH=UH+SH + SHTH2=SHTH**2 + THUH2=THUH**2 + UHSH2=UHSH**2 + IF ( (ISUB.GE.421.AND.ISUB.LE.424).OR. + & (ISUB.GE.431.AND.ISUB.LE.433)) THEN + SQMQQ=SQM3 + ELSEIF((ISUB.GE.425.AND.ISUB.LE.430).OR. + & (ISUB.GE.434.AND.ISUB.LE.439)) THEN + SQMQQ=SQM4 + ENDIF + SQMQQR=SQRT(SQMQQ) + IF(MSTP(145).EQ.1) THEN + IF ( (ISUB.GE.421.AND.ISUB.LE.427).OR. + & (ISUB.GE.431.AND.ISUB.LE.436)) THEN + AQ=UHSH/(2D0*X(1)) + SHTH/(2D0*X(2)) + BQ=UHSH/(2D0*X(1)) - SHTH/(2D0*X(2)) + ATILK1=X(1)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*AQ + ATILK2=X(2)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*AQ + BTILK1=-X(1)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*BQ + BTILK2=X(2)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*BQ + ELSEIF( (ISUB.GE.428.AND.ISUB.LE.430).OR. + & ISUB.GE.437) THEN + AQ=SHTH/(2D0*X(1)) + UHSH/(2D0*X(2)) + BQ=SHTH/(2D0*X(1)) - UHSH/(2D0*X(2)) + ATILK1=X(1)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*AQ + ATILK2=X(2)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*AQ + BTILK1=-X(1)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*BQ + BTILK2=X(2)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*BQ + ENDIF + AQ2=AQ**2 + BQ2=BQ**2 + SMQQ2=SQMQQ*VINT(2) +C...Polarisation frames + IF(MSTP(146).EQ.1) THEN +C...Recoil frame + POLH1=SQRT(AQ2-SMQQ2) + POLH2=SQRT(VINT(2)*(AQ2-BQ2-SMQQ2)) + AZ=-SQMQQR/POLH1 + BZ=0D0 + AX=AQ*BQ/(POLH1*POLH2) + BX=-POLH1/POLH2 + ELSEIF(MSTP(146).EQ.2) THEN +C...Gottfried Jackson frame + POLH1=AQ+BQ + POLH2=POLH1*SQRT(VINT(2)*(AQ2-BQ2-SMQQ2)) + AZ=SQMQQR/POLH1 + BZ=AZ + AX=-(BQ2+AQ*BQ+SMQQ2)/POLH2 + BX=(AQ2+AQ*BQ-SMQQ2)/POLH2 + ELSEIF(MSTP(146).EQ.3) THEN +C...Target frame + POLH1=AQ-BQ + POLH2=POLH1*SQRT(VINT(2)*(AQ2-BQ2-SMQQ2)) + AZ=-SQMQQR/POLH1 + BZ=-AZ + AX=-(BQ2-AQ*BQ+SMQQ2)/POLH2 + BX=-(AQ2-AQ*BQ-SMQQ2)/POLH2 + ELSEIF(MSTP(146).EQ.4) THEN +C...Collins Soper frame + POLH1=AQ2-BQ2 + POLH2=SQRT(VINT(2)*POLH1) + AZ=-BQ/POLH2 + BZ=AQ/POLH2 + AX=-SQMQQR*AQ/SQRT(POLH1*(POLH1-SMQQ2)) + BX=SQMQQR*BQ/SQRT(POLH1*(POLH1-SMQQ2)) + ENDIF +C...Contract EL1(lam) EL2(lam') with K1 and K2 (initial parton momenta) + EL1K10=AZ*ATILK1+BZ*BTILK1 + EL1K20=AZ*ATILK2+BZ*BTILK2 + EL2K10=EL1K10 + EL2K20=EL1K20 + EL1K11=1D0/SQRT(2D0)*(AX*ATILK1+BX*BTILK1) + EL1K21=1D0/SQRT(2D0)*(AX*ATILK2+BX*BTILK2) + EL2K11=EL1K11 + EL2K21=EL1K21 + ENDIF + + IF(ISUB.EQ.421) THEN +C...g + g -> QQ~[3S11] + g + IF(MSTP(145).EQ.0) THEN +* FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR* +* & (SH2*THUH2+TH2*UHSH2+UH2*SHTH2)/(SHTH2*THUH2*UHSH2) + FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR* + & (SH2*THUH2+TH2*UHSH2+UH2*SHTH2)/SHTH2/THUH2/UHSH2 +* FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR* +* & (SH2/(SHTH2*UHSH2)+TH2/(SHTH2*THUH2)+UH2/(THUH2*UHSH2)) + ELSE + FF=-PARU(1)*AS**3*(10D0/81D0)*SQMQQR/THUH2/SHTH2/UHSH2 + AA=(SHTH2*UH2+UHSH2*TH2+THUH2*SH2)/2D0 + BB=2D0*(SH2+TH2) + CC=2D0*(SH2+UH2) + DD=2D0*SH2 + IF(MSTP(147).EQ.0) THEN + FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20 + & +DD*(EL1K10*EL2K20+EL1K20*EL2K10)) + ELSEIF(MSTP(147).EQ.1) THEN + FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21 + & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))) + ELSEIF(MSTP(147).EQ.3) THEN + FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20 + & +DD*(EL1K10*EL2K20+EL1K20*EL2K10)) + ELSEIF(MSTP(147).EQ.4) THEN + FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21 + & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)) + ELSEIF(MSTP(147).EQ.5) THEN + FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20 + & +DD*(EL1K11*EL2K20+EL1K21*EL2K10)) + ELSEIF(MSTP(147).EQ.6) THEN + FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21 + & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)) + ENDIF + FACQQG=COMFAC*FF*FACQQG + ENDIF + IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQG*PARP(IONIUM+1) + ENDIF + + ELSEIF(ISUB.EQ.422) THEN +C...g + g -> QQ~[3S18] + g + IF(MSTP(145).EQ.0) THEN + FACQQG=-COMFAC*PARU(1)*AS**3*(1D0/72D0)* + & (16D0*SQMQQ**2-27D0*(SHTH2+THUH2+UHSH2))/ + & (SQMQQ*SQMQQR)* + & ((SH2*THUH2+TH2*UHSH2+UH2*SHTH2)/SHTH2/THUH2/UHSH2) + ELSE + FF=PARU(1)*AS**3*(16D0*SQMQQ**2-27D0*(SHTH2+THUH2+UHSH2))/ + & (72D0*SQMQQ*SQMQQR*SHTH2*THUH2*UHSH2) + AA=(SHTH2*UH2+UHSH2*TH2+THUH2*SH2)/2D0 + BB=2D0*(SH2+TH2) + CC=2D0*(SH2+UH2) + DD=2D0*SH2 + IF(MSTP(147).EQ.0) THEN + FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20 + & +DD*(EL1K10*EL2K20+EL1K20*EL2K10)) + ELSEIF(MSTP(147).EQ.1) THEN + FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21 + & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))) + ELSEIF(MSTP(147).EQ.3) THEN + FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20 + & +DD*(EL1K10*EL2K20+EL1K20*EL2K10)) + ELSEIF(MSTP(147).EQ.4) THEN + FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21 + & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)) + ELSEIF(MSTP(147).EQ.5) THEN + FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20 + & +DD*(EL1K11*EL2K20+EL1K21*EL2K10)) + ELSEIF(MSTP(147).EQ.6) THEN + FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21 + & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)) + ENDIF + FACQQG=COMFAC*FF*FACQQG + ENDIF +C...Split total contribution into different colour flows just like +C...in g g -> g g (recalculate kinematics for massless partons). + THP=-0.5D0*SH*(1D0-CTH) + UHP=-0.5D0*SH*(1D0+CTH) + FACGG1=(SH/THP)**2+2D0*SH/THP+3D0+2D0*THP/SH+(THP/SH)**2 + FACGG2=(UHP/SH)**2+2D0*UHP/SH+3D0+2D0*SH/UHP+(SH/UHP)**2 + FACGG3=(THP/UHP)**2+2D0*THP/UHP+3D0+2D0*UHP/THP+(UHP/THP)**2 + FACGGS=FACGG1+FACGG2+FACGG3 + IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG1/FACGGS + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=2 + SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG2/FACGGS + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=3 + SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG3/FACGGS + ENDIF + + ELSEIF(ISUB.EQ.423) THEN +C...g + g -> QQ~[1S08] + g + IF(MSTP(145).EQ.0) THEN +* FACQQG=COMFAC*PARU(1)*AS**3*(5D0/16D0)* +* & (SHTH2*UH2+THUH2*SH2+UHSH2*TH2)/(SQMQQR*SH*TH*UH)* +* & (12D0*SQMQQ*SH*TH*UH+SHTH2**2+THUH2**2+UHSH2**2)/ +* & (SHTH2*THUH2*UHSH2) + FACQQG=COMFAC*PARU(1)*AS**3*(5D0/16D0)*SQMQQR* + & (UH2/(THUH2*UHSH2)+SH2/(SHTH2*UHSH2)+ + & TH2/(SHTH2*THUH2))* + & (12D0+(SHTH2**2+THUH2**2+UHSH2**2)/(SQMQQ*SH*TH*UH)) + ELSE + FA=PARU(1)*AS**3*(5D0/48D0)*SQMQQR* + & (UH2/(THUH2*UHSH2)+SH2/(SHTH2*UHSH2)+ + & TH2/(SHTH2*THUH2))* + & (12D0+(SHTH2**2+THUH2**2+UHSH2**2)/(SQMQQ*SH*TH*UH)) + IF(MSTP(147).EQ.0) THEN + FACQQG=COMFAC*FA + ELSEIF(MSTP(147).EQ.1) THEN + FACQQG=COMFAC*2D0*FA + ELSEIF(MSTP(147).EQ.3) THEN + FACQQG=COMFAC*FA + ELSEIF(MSTP(147).EQ.4) THEN + FACQQG=COMFAC*FA + ELSEIF(MSTP(147).EQ.5) THEN + FACQQG=0D0 + ELSEIF(MSTP(147).EQ.6) THEN + FACQQG=0D0 + ENDIF + ENDIF +C...Split total contribution into different colour flows just like +C...in g g -> g g (recalculate kinematics for massless partons). + THP=-0.5D0*SH*(1D0-CTH) + UHP=-0.5D0*SH*(1D0+CTH) + FACGG1=(SH/THP)**2+2D0*SH/THP+3D0+2D0*THP/SH+(THP/SH)**2 + FACGG2=(UHP/SH)**2+2D0*UHP/SH+3D0+2D0*SH/UHP+(SH/UHP)**2 + FACGG3=(THP/UHP)**2+2D0*THP/UHP+3D0+2D0*UHP/THP+(UHP/THP)**2 + FACGGS=FACGG1+FACGG2+FACGG3 + IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG1/FACGGS + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=2 + SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG2/FACGGS + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=3 + SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG3/FACGGS + ENDIF + + ELSEIF(ISUB.EQ.424) THEN +C...g + g -> QQ~[3PJ8] + g + POLY=SH2+SH*TH+TH2 + IF(MSTP(145).EQ.0) THEN + FACQQG=COMFAC*5D0*PARU(1)*AS**3*(3D0*SH*TH*SHTH*POLY**4 + & -SQMQQ*POLY**2*(7D0*SH**6+36D0*SH**5*TH+45D0*SH**4*TH2 + & +28D0*SH**3*TH**3+45D0*SH2*TH**4+36D0*SH*TH**5 + & +7D0*TH**6) + & +SQMQQ**2*SHTH*(35D0*SH**8+169D0*SH**7*TH + & +299D0*SH**6*TH2+401D0*SH**5*TH**3+418D0*SH**4*TH**4 + & +401D0*SH**3*TH**5+299D0*SH2*TH**6+169D0*SH*TH**7 + & +35D0*TH**8) + & -SQMQQ**3*(84D0*SH**8+432D0*SH**7*TH+905D0*SH**6*TH2 + & +1287D0*SH**5*TH**3+1436D0*SH**4*TH**4 + & +1287D0*SH**3*TH**5+905D0*SH2*TH**6+432D0*SH*TH**7 + & +84D0*TH**8) + & +SQMQQ**4*SHTH*(126D0*SH**6+451D0*SH**5*TH + & +677D0*SH**4*TH2+836D0*SH**3*TH**3+677D0*SH2*TH**4 + & +451D0*SH*TH**5+126D0*TH**6) + & -3D0*SQMQQ**5*(42D0*SH**6+171D0*SH**5*TH + & +304D0*SH**4*TH2+362D0*SH**3*TH**3+304D0*SH2*TH**4 + & +171D0*SH*TH**5+42D0*TH**6) + & +2D0*SQMQQ**6*SHTH*(42D0*SH**4+106D0*SH**3*TH + & +119D0*SH2*TH2+106D0*SH*TH**3+42D0*TH**4) + & -SQMQQ**7*(35D0*SH**4+99D0*SH**3*TH+120D0*SH2*TH2 + & +99D0*SH*TH**3+35D0*TH**4) + & +7D0*SQMQQ**8*SHTH*POLY)/ + & (SH*TH*UH*SQMQQR*SQMQQ* + & SHTH*SHTH2*THUH*THUH2*UHSH*UHSH2) + ELSE + FF=-5D0*PARU(1)*AS**3/(SH2*TH2*UH2 + & *SQMQQR*SQMQQ*SHTH*SHTH2*THUH*THUH2*UHSH*UHSH2) + AA=SH*TH*UH*(SH*TH*SHTH*POLY**4 + & -SQMQQ*SHTH2*POLY**2* + & (SH**4+6D0*SH**3*TH-6D0*SH2*TH2+6D0*SH*TH**3+TH**4) + & +SQMQQ**2*SHTH*(5D0*SH**8+35D0*SH**7*TH+49D0*SH**6*TH2 + & +57D0*SH**5*TH**3+46D0*SH**4*TH**4+57D0*SH**3*TH**5 + & +49D0*SH2*TH**6+35D0*SH*TH**7+5D0*TH**8) + & -SQMQQ**3*(16D0*SH**8+104D0*SH**7*TH+215D0*SH**6*TH2 + & +291D0*SH**5*TH**3+316D0*SH**4*TH**4+291D0*SH**3*TH**5 + & +215D0*SH2*TH**6+104D0*SH*TH**7+16D0*TH**8) + & +SQMQQ**4*SHTH*(34D0*SH**6+145D0*SH**5*TH + & +211D0*SH**4*TH2+262D0*SH**3*TH**3+211D0*SH2*TH**4 + & +145D0*SH*TH**5+34D0*TH**6) + & -SQMQQ**5*(44D0*SH**6+193D0*SH**5*TH+346D0*SH**4*TH2 + & +410D0*SH**3*TH**3+346D0*SH2*TH**4+193D0*SH*TH**5 + & +44D0*TH**6) + & +2D0*SQMQQ**6*SHTH*(17D0*SH**4+45D0*SH**3*TH + & +49D0*SH2*TH2+45D0*SH*TH**3+17D0*TH**4) + & -SQMQQ**7*(3D0*SH2+2D0*SH*TH+3D0*TH2) + & *(5D0*SH2+11D0*SH*TH+5D0*TH2) + & +3D0*SQMQQ**8*SHTH*POLY) + BB=4D0*SHTH2*POLY**3 + & *(SH**4+SH**3*TH-SH2*TH2+SH*TH**3+TH**4) + & -SQMQQ*SHTH*(20D0*SH**10+84D0*SH**9*TH+166D0*SH**8*TH2 + & +231D0*SH**7*TH**3+250D0*SH**6*TH**4+250D0*SH**5*TH**5 + & +250D0*SH**4*TH**6+231D0*SH**3*TH**7+166D0*SH2*TH**8 + & +84D0*SH*TH**9+20D0*TH**10) + & +SQMQQ**2*SHTH2*(40D0*SH**8+86D0*SH**7*TH + & +66D0*SH**6*TH2+67D0*SH**5*TH**3+6D0*SH**4*TH**4 + & +67D0*SH**3*TH**5+66D0*SH2*TH**6+86D0*SH*TH**7 + & +40D0*TH**8) + & -SQMQQ**3*SHTH*(40D0*SH**8+57D0*SH**7*TH + & -110D0*SH**6*TH2-263D0*SH**5*TH**3-384D0*SH**4*TH**4 + & -263D0*SH**3*TH**5-110D0*SH2*TH**6+57D0*SH*TH**7 + & +40D0*TH**8) + & +SQMQQ**4*(20D0*SH**8-33D0*SH**7*TH-368D0*SH**6*TH2 + & -751D0*SH**5*TH**3-920D0*SH**4*TH**4-751D0*SH**3*TH**5 + & -368D0*SH2*TH**6-33D0*SH*TH**7+20D0*TH**8) + & -SQMQQ**5*SHTH*(4D0*SH**6-81D0*SH**5*TH-242D0*SH**4*TH2 + & -250D0*SH**3*TH**3-242D0*SH2*TH**4-81D0*SH*TH**5 + & +4D0*TH**6) + & -SQMQQ**6*SH*TH*(41D0*SH**4+120D0*SH**3*TH + & +142D0*SH2*TH2+120D0*SH*TH**3+41D0*TH**4) + & +8D0*SQMQQ**7*SH*TH*SHTH*POLY + CC=4D0*TH2*POLY**3 + & *(-SH**4-2D0*SH**3*TH+2D0*SH2*TH2+3D0*SH*TH**3+TH**4) + & -SQMQQ*TH2*(-20D0*SH**9-56D0*SH**8*TH-24D0*SH**7*TH2 + & +147D0*SH**6*TH**3+409D0*SH**5*TH**4+599D0*SH**4*TH**5 + & +571D0*SH**3*TH**6+370D0*SH2*TH**7+148D0*SH*TH**8 + & +28D0*TH**9) + & +SQMQQ**2*(4D0*SH**10+20D0*SH**9*TH-16D0*SH**8*TH2 + & -48D0*SH**7*TH**3+150D0*SH**6*TH**4+611D0*SH**5*TH**5 + & +1060D0*SH**4*TH**6+1155D0*SH**3*TH**7+854D0*SH2*TH**8 + & +394D0*SH*TH**9+84D0*TH**10) + & -SQMQQ**3*SHTH*(20D0*SH**8+68D0*SH**7*TH-20D0*SH**6*TH2 + & +32D0*SH**5*TH**3+286D0*SH**4*TH**4+577D0*SH**3*TH**5 + & +618D0*SH2*TH**6+443D0*SH*TH**7+140D0*TH**8) + & +SQMQQ**4*(40D0*SH**8+152D0*SH**7*TH+94D0*SH**6*TH2 + & +38D0*SH**5*TH**3+290D0*SH**4*TH**4+631D0*SH**3*TH**5 + & +738D0*SH2*TH**6+513D0*SH*TH**7+140D0*TH**8) + & -SQMQQ**5*(40D0*SH**7+129D0*SH**6*TH+53D0*SH**5*TH2 + & +7D0*SH**4*TH**3+129D0*SH**3*TH**4+264D0*SH2*TH**5 + & +266D0*SH*TH**6+84D0*TH**7) + & +SQMQQ**6*(20D0*SH**6+55D0*SH**5*TH+2D0*SH**4*TH2 + & -15D0*SH**3*TH**3+30D0*SH2*TH**4+76D0*SH*TH**5 + & +28D0*TH**6) + & -SQMQQ**7*SHTH*(4D0*SH**4+7D0*SH**3*TH-14D0*SH2*TH2 + & +7D0*SH*TH**3+4*TH**4) + & +SQMQQ**8*SH*(SH-TH)**2*TH + DD=2D0*TH2*SHTH2*POLY**3 + & *(-SH2+2*SH*TH+2*TH2) + & +SQMQQ*(4D0*SH**11+22D0*SH**10*TH+70D0*SH**9*TH2 + & +115D0*SH**8*TH**3+71D0*SH**7*TH**4-119D0*SH**6*TH**5 + & -381D0*SH**5*TH**6-552D0*SH**4*TH**7-512D0*SH**3*TH**8 + & -320D0*SH2*TH**9-126D0*SH*TH**10-24D0*TH**11) + & -SQMQQ**2*SHTH*(20D0*SH**9+84D0*SH**8*TH + & +212D0*SH**7*TH2+247D0*SH**6*TH**3+105D0*SH**5*TH**4 + & -178D0*SH**4*TH**5-380D0*SH**3*TH**6-364D0*SH2*TH**7 + & -210D0*SH*TH**8-60D0*TH**9) + & +SQMQQ**3*SHTH*(40D0*SH**8+159D0*SH**7*TH + & +374D0*SH**6*TH2+404D0*SH**5*TH**3+192D0*SH**4*TH**4 + & -141D0*SH**3*TH**5-264D0*SH2*TH**6-216D0*SH*TH**7 + & -80D0*TH**8) + & -SQMQQ**4*(40D0*SH**8+197D0*SH**7*TH+506D0*SH**6*TH2 + & +672D0*SH**5*TH**3+460D0*SH**4*TH**4+79D0*SH**3*TH**5 + & -138D0*SH2*TH**6-164D0*SH*TH**7-60D0*TH**8) + & +SQMQQ**5*(20D0*SH**7+107D0*SH**6*TH+267D0*SH**5*TH2 + & +307D0*SH**4*TH**3+185D0*SH**3*TH**4+56D0*SH2*TH**5 + & -30D0*SH*TH**6-24D0*TH**7) + & -SQMQQ**6*(4D0*SH**6+31D0*SH**5*TH+74D0*SH**4*TH2 + & +71D0*SH**3*TH**3+46D0*SH2*TH**4+10D0*SH*TH**5 + & -4D0*TH**6) + & +4D0*SQMQQ**7*SH*TH*SHTH*POLY + IF(MSTP(147).EQ.0) THEN + FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20 + & +DD*(EL1K10*EL2K20+EL1K20*EL2K10)) + ELSEIF(MSTP(147).EQ.1) THEN + FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21 + & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))) + ELSEIF(MSTP(147).EQ.3) THEN + FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20 + & +DD*(EL1K10*EL2K20+EL1K20*EL2K10)) + ELSEIF(MSTP(147).EQ.4) THEN + FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21 + & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)) + ELSEIF(MSTP(147).EQ.5) THEN + FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20 + & +DD*(EL1K11*EL2K20+EL1K21*EL2K10)) + ELSEIF(MSTP(147).EQ.6) THEN + FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21 + & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)) + ENDIF + FACQQG=COMFAC*FF*FACQQG + ENDIF +C...Split total contribution into different colour flows just like +C...in g g -> g g (recalculate kinematics for massless partons). + THP=-0.5D0*SH*(1D0-CTH) + UHP=-0.5D0*SH*(1D0+CTH) + FACGG1=(SH/THP)**2+2D0*SH/THP+3D0+2D0*THP/SH+(THP/SH)**2 + FACGG2=(UHP/SH)**2+2D0*UHP/SH+3D0+2D0*SH/UHP+(SH/UHP)**2 + FACGG3=(THP/UHP)**2+2D0*THP/UHP+3D0+2D0*UHP/THP+(UHP/THP)**2 + FACGGS=FACGG1+FACGG2+FACGG3 + IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG1/FACGGS + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=2 + SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG2/FACGGS + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=3 + SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG3/FACGGS + ENDIF + + ELSEIF(ISUB.EQ.425) THEN +C...q + g -> q + QQ~[3S18] + IF(MSTP(145).EQ.0) THEN + FACQQG=-COMFAC*PARU(1)*AS**3*(1D0/27D0)* + & (4D0*(SH2+UH2)-SH*UH)*(SHTH2+THUH2)/ + & (SQMQQ*SQMQQR*SH*UH*UHSH2) + ELSE + FF=PARU(1)*AS**3*(4D0*(SH2+UH2)-SH*UH)/ + & (54D0*SQMQQ*SQMQQR*SH*UH*UHSH2) + AA=SHTH2+THUH2 + BB=4D0 + CC=8D0 + DD=4D0 + IF(MSTP(147).EQ.0) THEN + FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20 + & +DD*(EL1K10*EL2K20+EL1K20*EL2K10)) + ELSEIF(MSTP(147).EQ.1) THEN + FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21 + & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))) + ELSEIF(MSTP(147).EQ.3) THEN + FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20 + & +DD*(EL1K10*EL2K20+EL1K20*EL2K10)) + ELSEIF(MSTP(147).EQ.4) THEN + FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21 + & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)) + ELSEIF(MSTP(147).EQ.5) THEN + FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20 + & +DD*(EL1K11*EL2K20+EL1K21*EL2K10)) + ELSEIF(MSTP(147).EQ.6) THEN + FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21 + & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)) + ENDIF + FACQQG=COMFAC*FF*FACQQG + ENDIF +C...Split total contribution into different colour flows just like +C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)] +C...(recalculate kinematics for massless partons). + THP=-0.5D0*SH*(1D0-CTH) + UHP=-0.5D0*SH*(1D0+CTH) + FACQG1=9D0/4D0*(UHP/THP)**2-UHP/SH + FACQG2=9D0/4D0*(SH/THP)**2-SH/UHP + FACQGS=FACQG1+FACQG2 + DO 2442 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2442 + DO 2441 ISDE=1,2 + IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2441 + IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2441 + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACQG1/FACQGS + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=21 + ISIG(NCHN,3)=2 + SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACQG2/FACQGS + 2441 CONTINUE + 2442 CONTINUE + + ELSEIF(ISUB.EQ.426) THEN +C...q + g -> q + QQ~[1S08] + IF(MSTP(145).EQ.0) THEN + FACQQG=-COMFAC*PARU(1)*AS**3*(5D0/18D0)* + & (SH2+UH2)/(SQMQQR*TH*UHSH2) + ELSE + FA=-PARU(1)*AS**3*(5D0/54D0)*(SH2+UH2)/(SQMQQR*TH*UHSH2) + IF(MSTP(147).EQ.0) THEN + FACQQG=COMFAC*FA + ELSEIF(MSTP(147).EQ.1) THEN + FACQQG=COMFAC*2D0*FA + ELSEIF(MSTP(147).EQ.3) THEN + FACQQG=COMFAC*FA + ELSEIF(MSTP(147).EQ.4) THEN + FACQQG=COMFAC*FA + ELSEIF(MSTP(147).EQ.5) THEN + FACQQG=0D0 + ELSEIF(MSTP(147).EQ.6) THEN + FACQQG=0D0 + ENDIF + ENDIF +C...Split total contribution into different colour flows just like +C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)] +C...(recalculate kinematics for massless partons). + THP=-0.5D0*SH*(1D0-CTH) + UHP=-0.5D0*SH*(1D0+CTH) + FACQG1=9D0/4D0*(UHP/THP)**2-UHP/SH + FACQG2=9D0/4D0*(SH/THP)**2-SH/UHP + FACQGS=FACQG1+FACQG2 + DO 2444 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2444 + DO 2443 ISDE=1,2 + IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2443 + IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2443 + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACQG1/FACQGS + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=21 + ISIG(NCHN,3)=2 + SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACQG2/FACQGS + 2443 CONTINUE + 2444 CONTINUE + + ELSEIF(ISUB.EQ.427) THEN +C...q + g -> q + QQ~[3PJ8] + IF(MSTP(145).EQ.0) THEN + FACQQG=-COMFAC*PARU(1)*AS**3*(10D0/9D0)* + & ((7D0*UHSH+8D0*TH)*(SH2+UH2) + & +4D0*TH*(2D0*SQMQQ**2-SHTH2-THUH2))/ + & (SQMQQ*SQMQQR*TH*UHSH2*UHSH) + ELSE + FF=10D0*PARU(1)*AS**3/ + & (9D0*SQMQQ*SQMQQR*TH2*UHSH2*UHSH) + AA=TH*UHSH*(2D0*SQMQQ**2+SHTH2+THUH2) + BB=8D0*(SHTH2+TH*UH) + CC=8D0*UHSH*(SHTH+THUH) + DD=4D0*(2D0*SQMQQ*SH+TH*UHSH) + IF(MSTP(147).EQ.0) THEN + FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20 + & +DD*(EL1K10*EL2K20+EL1K20*EL2K10)) + ELSEIF(MSTP(147).EQ.1) THEN + FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21 + & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))) + ELSEIF(MSTP(147).EQ.3) THEN + FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20 + & +DD*(EL1K10*EL2K20+EL1K20*EL2K10)) + ELSEIF(MSTP(147).EQ.4) THEN + FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21 + & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)) + ELSEIF(MSTP(147).EQ.5) THEN + FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20 + & +DD*(EL1K11*EL2K20+EL1K21*EL2K10)) + ELSEIF(MSTP(147).EQ.6) THEN + FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21 + & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)) + ENDIF + FACQQG=COMFAC*FF*FACQQG + ENDIF +C...Split total contribution into different colour flows just like +C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)] +C...(recalculate kinematics for massless partons). + THP=-0.5D0*SH*(1D0-CTH) + UHP=-0.5D0*SH*(1D0+CTH) + FACQG1=9D0/4D0*(UHP/THP)**2-UHP/SH + FACQG2=9D0/4D0*(SH/THP)**2-SH/UHP + FACQGS=FACQG1+FACQG2 + DO 2446 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2446 + DO 2445 ISDE=1,2 + IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2445 + IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2445 + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACQG1/FACQGS + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=21 + ISIG(NCHN,3)=2 + SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACQG2/FACQGS + 2445 CONTINUE + 2446 CONTINUE + + ELSEIF(ISUB.EQ.428) THEN +C...q + q~ -> g + QQ~[3S18] + IF(MSTP(145).EQ.0) THEN + FACQQG=COMFAC*PARU(1)*AS**3*(8D0/81D0)* + & (4D0*(TH2+UH2)-TH*UH)*(SHTH2+UHSH2)/ + & (SQMQQ*SQMQQR*TH*UH*THUH2) + ELSE + FF=-4D0*PARU(1)*AS**3*(4D0*(TH2+UH2)-TH*UH)/ + & (81D0*SQMQQ*SQMQQR*TH*UH*THUH2) + AA=SHTH2+UHSH2 + BB=4D0 + CC=4D0 + DD=0D0 + IF(MSTP(147).EQ.0) THEN + FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20 + & +DD*(EL1K10*EL2K20+EL1K20*EL2K10)) + ELSEIF(MSTP(147).EQ.1) THEN + FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21 + & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))) + ELSEIF(MSTP(147).EQ.3) THEN + FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20 + & +DD*(EL1K10*EL2K20+EL1K20*EL2K10)) + ELSEIF(MSTP(147).EQ.4) THEN + FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21 + & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)) + ELSEIF(MSTP(147).EQ.5) THEN + FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20 + & +DD*(EL1K11*EL2K20+EL1K21*EL2K10)) + ELSEIF(MSTP(147).EQ.6) THEN + FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21 + & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)) + ENDIF + FACQQG=COMFAC*FF*FACQQG + ENDIF +C...Split total contribution into different colour flows just like +C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)] +C...(recalculate kinematics for massless partons). + THP=-0.5D0*SH*(1D0-CTH) + UHP=-0.5D0*SH*(1D0+CTH) + FACGG1=UH/TH-9D0/4D0*UH2/SH2 + FACGG2=TH/UH-9D0/4D0*TH2/SH2 + FACGGS=FACGG1+FACGG2 + DO 2447 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR. + & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2447 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG1/FACGGS + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=2 + SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG2/FACGGS + 2447 CONTINUE + + ELSEIF(ISUB.EQ.429) THEN +C...q + q~ -> g + QQ~[1S08] + IF(MSTP(145).EQ.0) THEN + FACQQG=COMFAC*PARU(1)*AS**3*(20D0/27D0)* + & (TH2+UH2)/(SQMQQR*SH*THUH2) + ELSE + FA=PARU(1)*AS**3*(20D0/81D0)*(TH2+UH2)/(SQMQQR*SH*THUH2) + IF(MSTP(147).EQ.0) THEN + FACQQG=COMFAC*FA + ELSEIF(MSTP(147).EQ.1) THEN + FACQQG=COMFAC*2D0*FA + ELSEIF(MSTP(147).EQ.3) THEN + FACQQG=COMFAC*FA + ELSEIF(MSTP(147).EQ.4) THEN + FACQQG=COMFAC*FA + ELSEIF(MSTP(147).EQ.5) THEN + FACQQG=0D0 + ELSEIF(MSTP(147).EQ.6) THEN + FACQQG=0D0 + ENDIF + ENDIF +C...Split total contribution into different colour flows just like +C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)] +C...(recalculate kinematics for massless partons). + THP=-0.5D0*SH*(1D0-CTH) + UHP=-0.5D0*SH*(1D0+CTH) + FACGG1=UH/TH-9D0/4D0*UH2/SH2 + FACGG2=TH/UH-9D0/4D0*TH2/SH2 + FACGGS=FACGG1+FACGG2 + DO 2448 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR. + & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2448 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG1/FACGGS + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=2 + SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG2/FACGGS + 2448 CONTINUE + + ELSEIF(ISUB.EQ.430) THEN +C...q + q~ -> g + QQ~[3PJ8] + IF(MSTP(145).EQ.0) THEN + FACQQG=COMFAC*PARU(1)*AS**3*(80D0/27D0)* + & ((7D0*THUH+8D0*SH)*(TH2+UH2) + & +4D0*SH*(2D0*SQMQQ**2-SHTH2-UHSH2))/ + & (SQMQQ*SQMQQR*SH*THUH2*THUH) + ELSE + FF=-80D0*PARU(1)*AS**3/(27D0*SQMQQ*SQMQQR*SH2*THUH2*THUH) + AA=SH*THUH*(2D0*SQMQQ**2+SHTH2+UHSH2) + BB=8D0*(UHSH2+SH*TH) + CC=8D0*(SHTH2+SH*UH) + DD=4D0*(SHTH2+UHSH2+SH*SQMQQ-SQMQQ**2) + IF(MSTP(147).EQ.0) THEN + FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20 + & +DD*(EL1K10*EL2K20+EL1K20*EL2K10)) + ELSEIF(MSTP(147).EQ.1) THEN + FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21 + & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))) + ELSEIF(MSTP(147).EQ.3) THEN + FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20 + & +DD*(EL1K10*EL2K20+EL1K20*EL2K10)) + ELSEIF(MSTP(147).EQ.4) THEN + FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21 + & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)) + ELSEIF(MSTP(147).EQ.5) THEN + FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20 + & +DD*(EL1K11*EL2K20+EL1K21*EL2K10)) + ELSEIF(MSTP(147).EQ.6) THEN + FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21 + & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)) + ENDIF + FACQQG=COMFAC*FF*FACQQG + ENDIF +C...Split total contribution into different colour flows just like +C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)] +C...(recalculate kinematics for massless partons). + THP=-0.5D0*SH*(1D0-CTH) + UHP=-0.5D0*SH*(1D0+CTH) + FACGG1=UH/TH-9D0/4D0*UH2/SH2 + FACGG2=TH/UH-9D0/4D0*TH2/SH2 + FACGGS=FACGG1+FACGG2 + DO 2449 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR. + & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2449 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG1/FACGGS + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=2 + SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG2/FACGGS + 2449 CONTINUE + + ELSEIF(ISUB.EQ.431) THEN +C...g + g -> QQ~[3P01] + g + PGTW=(SH*TH+TH*UH+UH*SH)/SH2 + QGTW=(SH*TH*UH)/SH**3 + RGTW=SQMQQ/SH + IF(MSTP(145).EQ.0) THEN + FACQQG=COMFAC*PARU(1)*AS**3*8D0/(9D0*SQMQQR*SH)* + & (9D0*RGTW**2*PGTW**4* + & (RGTW**4-2D0*RGTW**2*PGTW+PGTW**2) + & -6D0*RGTW*PGTW**3*QGTW* + & (2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2) + & -PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2) + & +2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW) + & +6D0*RGTW**2*QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4) + ELSE + FC1=PARU(1)*AS**3*8D0/(27D0*SQMQQR*SH)* + & (9D0*RGTW**2*PGTW**4* + & (RGTW**4-2D0*RGTW**2*PGTW+PGTW**2) + & -6D0*RGTW*PGTW**3*QGTW* + & (2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2) + & -PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2) + & +2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW) + & +6D0*RGTW**2*QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4) + IF(MSTP(147).EQ.0) THEN + FACQQG=COMFAC*FC1 + ELSEIF(MSTP(147).EQ.1) THEN + FACQQG=COMFAC*2D0*FC1 + ELSEIF(MSTP(147).EQ.3) THEN + FACQQG=COMFAC*FC1 + ELSEIF(MSTP(147).EQ.4) THEN + FACQQG=COMFAC*FC1 + ELSEIF(MSTP(147).EQ.5) THEN + FACQQG=0D0 + ELSEIF(MSTP(147).EQ.6) THEN + FACQQG=0D0 + ENDIF + ENDIF + IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQG*PARP(IONIUM+5) + ENDIF + + ELSEIF(ISUB.EQ.432) THEN +C...g + g -> QQ~[3P11] + g + PGTW=(SH*TH+TH*UH+UH*SH)/SH2 + QGTW=(SH*TH*UH)/SH**3 + RGTW=SQMQQ/SH + IF(MSTP(145).EQ.0) THEN + FACQQG=COMFAC*PARU(1)*AS**3*8D0/(3D0*SQMQQR*SH)* + & PGTW**2*(RGTW*PGTW**2*(RGTW**2-4D0*PGTW) + & +2D0*QGTW*(-RGTW**4+5D0*RGTW**2*PGTW+PGTW**2) + & -15D0*RGTW*QGTW**2)/(QGTW-RGTW*PGTW)**4 + ELSE + FF=4D0/3D0*PARU(1)*AS**3*SQMQQR/SHTH2**2/THUH2**2/UHSH2**2 + C1=(4D0*PGTW**5+23D0*PGTW**2*QGTW**2 + & +(-14D0*PGTW**3*QGTW+3D0*QGTW**3)*RGTW + & -(PGTW**4+2D0*PGTW*QGTW**2)*RGTW**2 + & +3D0*PGTW**2*QGTW*RGTW**3)*SH2**5 + C2=2D0*SHTH2*(SH2*THUH*(SH*THUH*(SH-TH)*(SH-UH) + & -TH*UH*(TH-UH)**2)+SH2**2*(TH-UH)*(TH2+UH2-SH*THUH) + & *(PGTW**2-QGTW*(SH+2D0*UH)/SH)) + C3=2D0*UHSH2*(SH2*THUH*(SH*THUH*(SH-TH)*(SH-UH) + & -TH*UH*(TH-UH)**2)-SH2**2*(TH-UH)*(TH2+UH2-SH*THUH) + & *(PGTW**2-QGTW*(SH+2D0*TH)/SH)) + C4=-4D0*THUH*(TH-UH)**2* + & (TH**3*UH**3+SH2**2*(2D0*TH+UH)*(TH+2D0*UH) + & -SH2*TH*UH*(TH2+UH2)) + & +4D0*THUH2*(SH**3*(SH2**2+TH2**2+UH2**2) + & -SH*TH*UH*(SH2**2+TH*UH*(TH2-3D0*TH*UH+UH2) + & +SH2*(5D0*THUH2-17D0*TH*UH))) + IF(MSTP(147).EQ.0) THEN + FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20 + & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0 + ELSEIF(MSTP(147).EQ.1) THEN + FACQQG=2D0*(-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21 + & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0) + ELSEIF(MSTP(147).EQ.3) THEN + FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20 + & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0 + ELSEIF(MSTP(147).EQ.4) THEN + FACQQG=-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21 + & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0 + ELSEIF(MSTP(147).EQ.5) THEN + FACQQG=C2*EL1K11*EL2K10+C3*EL1K21*EL2K20 + & +C4*(EL1K11*EL2K20+EL1K21*EL2K10)/2D0 + ELSEIF(MSTP(147).EQ.6) THEN + FACQQG=C2*EL1K11*EL2K11+C3*EL1K21*EL2K21 + & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0 + ENDIF + FACQQG=COMFAC*FF*FACQQG + ENDIF + IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQG*PARP(IONIUM+5) + ENDIF + + ELSEIF(ISUB.EQ.433) THEN +C...g + g -> QQ~[3P21] + g + PGTW=(SH*TH+TH*UH+UH*SH)/SH2 + QGTW=(SH*TH*UH)/SH**3 + RGTW=SQMQQ/SH + IF(MSTP(145).EQ.0) THEN + FACQQG=COMFAC*PARU(1)*AS**3*8D0/(9D0*SQMQQR*SH)* + & (12D0*RGTW**2*PGTW**4* + & (RGTW**4-2D0*RGTW**2*PGTW+PGTW**2) + & -3D0*RGTW*PGTW**3*QGTW* + & (8D0*RGTW**4-RGTW**2*PGTW+4D0*PGTW**2) + & +2D0*PGTW**2*QGTW**2* + & (-7D0*RGTW**4+43D0*RGTW**2*PGTW+PGTW**2) + & +RGTW*PGTW*QGTW**3*(16D0*RGTW**2-61D0*PGTW) + & +12D0*RGTW**2*QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4) + ELSE + FF=(16D0*PARU(1)*AS**3*SQMQQ*SQMQQR)/ + & (3D0*SH2*TH2*UH2*SHTH2**2*THUH2**2*UHSH2**2) + C1=PGTW**2*QGTW*(PGTW*RGTW-QGTW)**2*(RGTW**2-2D0*PGTW) + & *SH*SH2**7 + C2=2D0*SHTH2*(-SH2**3*TH2**3-SH**5*TH**5*UH*SHTH + & +SH2**2*TH2**2*UH2*(8D0*SHTH2-5D0*SH*TH) + & +SH**3*TH**3*UH**3*SHTH*(17D0*SHTH2-2D0*SH*TH) + & +SH2*TH2*UH2**2*(105D0*SH2*TH2+64D0*SH*TH*(SH2+TH2) + & +10D0*(SH2**2+TH2**2)) + & +SH2*TH2*UH**5*SHTH*(32D0*SHTH2+7D0*SH*TH) + & -UH2**3*(SH2**3-87D0*SH**3*TH**3+TH2**3 + & -45D0*SH2*TH2*(SH2+TH2)-5D0*SH*TH*(SH2**2+TH2**2)) + & +SH*TH*UH**7*SHTH*(7D0*SHTH2+12D0*SH*TH) + & +4D0*SH*TH*UH2**4*SHTH2) + C3=2D0*UHSH2*(-SH2**3*UH2**3-SH**5*UH**5*TH*UHSH + & +SH2**2*UH2**2*TH2*(8D0*UHSH2-5D0*SH*UH) + & +SH**3*UH**3*TH**3*UHSH*(17D0*UHSH2-2D0*SH*UH) + & +SH2*UH2*TH2**2*(105D0*SH2*UH2+64D0*SH*UH*(SH2+UH2) + & +10D0*(SH2**2+UH2**2)) + & +SH2*UH2*TH**5*UHSH*(32D0*UHSH2+7D0*SH*UH) + & -TH2**3*(SH2**3-87D0*SH**3*UH**3+UH2**3 + & -45D0*SH2*UH2*(SH2+UH2)-5D0*SH*UH*(SH2**2+UH2**2)) + & +SH*UH*TH**7*UHSH*(7D0*UHSH2+12D0*SH*UH) + & +4D0*SH*UH*TH2**4*UHSH2) + C4=-2D0*SHTH*UHSH*(-2D0*TH2**3*UH2**3 + & -SH**5*TH2*UH2*THUH*(5D0*TH+3D0*UH)*(3D0*TH+5D0*UH) + & +SH2**3*(2D0*TH+UH)*(TH+2D0*UH)*(TH2-UH2)**2 + & -SH*TH2**2*UH2**2*THUH*(5D0*THUH2-4D0*TH*UH) + & -SH2*TH**3*UH**3*THUH2*(13D0*THUH2-16D0*TH*UH) + & -SH**3*TH2*UH2*(92D0*TH2*UH2*THUH + & +53D0*TH*UH*(TH**3+UH**3)+11D0*(TH**5+UH**5)) + & -SH2**2*TH*UH*(114D0*TH**3*UH**3 + & +83D0*TH2*UH2*(TH2+UH2)+28D0*TH*UH*(TH2**2+UH2**2) + & +3D0*(TH2**3+UH2**3))) + C5=4D0*SH*TH*UH2*SHTH2*(2D0*SH*TH+SH*UH+TH*UH)**2 + & *(2D0*UH*SQMQQ**2+SHTH*(SH*TH-UH2)) + C6=4D0*SH*UH*TH2*UHSH2*(2D0*SH*UH+SH*TH+TH*UH)**2 + & *(2D0*TH*SQMQQ**2+UHSH*(SH*UH-TH2)) + C7=4D0*SH*TH*UH2*SHTH*(SH2**2*TH**3*(11D0*SH+16D0*TH) + & +SH**3*TH2*UH*(31D0*SH2+83D0*SH*TH+61D0*TH2) + & +SH2*TH*UH2*(19D0*SH**3+110D0*SH2*TH+156D0*SH*TH2+ + & 82D0*TH**3) + & +SH*TH*UH**3*(43D0*SH**3+132D0*SH2*TH+124D0*SH*TH2 + & +45D0*TH**3) + & +TH*UH2**2*(37D0*SH**3+68D0*SH2*TH+43D0*SH*TH2+ + & 8D0*TH**3) + & +TH*UH**5*(11D0*SH2+13D0*SH*TH+5D0*TH2) + & +SH**3*UH**3*(3D0*UHSH2-2D0*SH*UH) + & +TH**5*UHSH*(5D0*UHSH2+2D0*SH*UH)) + C8=4D0*SH*UH*TH2*UHSH*(SH2**2*UH**3*(11D0*SH+16D0*UH) + & +SH**3*UH2*TH*(31D0*SH2+83D0*SH*UH+61D0*UH2) + & +SH2*UH*TH2*(19D0*SH**3+110D0*SH2*UH+156D0*SH*UH2+ + & 82D0*UH**3) + & +SH*UH*TH**3*(43D0*SH**3+132D0*SH2*UH+124D0*SH*UH2 + & +45D0*UH**3) + & +UH*TH2**2*(37D0*SH**3+68D0*SH2*UH+43D0*SH*UH2+ + & 8D0*UH**3) + & +UH*TH**5*(11D0*SH2+13D0*SH*UH+5D0*UH2) + & +SH**3*TH**3*(3D0*SHTH2-2D0*SH*TH) + & +UH**5*SHTH*(5D0*SHTH2+2D0*SH*TH)) + C9=4D0*SHTH*UHSH*(2D0*TH**5*UH**5*THUH + & +4D0*SH*TH2**2*UH2**2*THUH2 + & -SH2*TH**3*UH**3*THUH*(TH2+UH2) + & -2D0*SH**3*TH2*UH2*(THUH2**2+2D0*TH*UH*THUH2-TH2*UH2) + & +SH2**2*TH*UH*THUH*(-TH*UH*THUH2+3D0*(TH2**2+UH2**2)) + & +SH**5*(4D0*TH2*UH2*(THUH2-TH*UH) + & +5D0*TH*UH*(TH2**2+UH2**2)+2D0*(TH2**3+UH2**3))) + C0=-4D0*(2D0*TH2**3*UH2**3*SQMQQ + & -SH2*TH2**2*UH2**2*THUH*(19D0*THUH2-4D0*TH*UH) + & -SH**3*TH**3*UH**3*THUH2*(32D0*THUH2+29D0*TH*UH) + & -SH2**2*TH2*UH2*THUH*(264D0*TH2*UH2 + & +136D0*TH*UH*(TH2+UH2)+15D0*(TH2**2+UH2**2)) + & +SH**5*TH*UH*(-428D0*TH**3*UH**3 + & -256D0*TH2*UH2*(TH2+UH2)-43D0*TH*UH*(TH2**2+UH2**2) + & +2D0*(TH2**3+UH2**3)) + & +SH**7*(-46D0*TH**3*UH**3-21D0*TH2*UH2*(TH2+UH2) + & +2D0*TH*UH*(TH2**2+UH2**2)+2D0*(TH2**3+UH2**3)) + & +SH2**3*THUH*(-134*TH**3*UH**3-53D0*TH2*UH2*(TH2+UH2) + & +4D0*TH*UH*(TH2**2+UH2**2)+2D0*(TH2**3+UH2**3))) + IF(MSTP(147).EQ.0) THEN + FACQQG=1D0/3D0*(C1*3D0 + & -C2*(2D0*EL1K10*EL2K10+EL1K11*EL2K11) + & -C3*(2D0*EL1K20*EL2K20+EL1K21*EL2K21) + & -C4*(2D0*EL1K10*EL2K20+EL1K11*EL2K21) + & +C5*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)**2 + & +C6*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)**2 + & +C7*2D0*(EL1K10*EL2K10-EL1K11*EL2K11) + & *(EL1K10*EL2K20-EL1K11*EL2K21) + & +C8*2D0*(EL1K20*EL2K20-EL1K21*EL2K21) + & *(EL1K10*EL2K20-EL1K11*EL2K21) + & +C9*2D0*(EL1K10*EL2K10-EL1K11*EL2K11) + & *(EL1K20*EL2K20-EL1K21*EL2K21) + & +C0*2D0*(EL1K10*EL2K20-EL1K11*EL2K21)**2) + ELSEIF(MSTP(147).EQ.1) THEN + FACQQG=C1*2D0 + & -C2*(EL1K10*EL2K10+EL1K11*EL2K11) + & -C3*(EL1K20*EL2K20+EL1K21*EL2K21) + & -C4*(EL1K10*EL2K20+EL1K11*EL2K21) + & +C5*4D0*EL1K10*EL2K10*EL1K11*EL2K11 + & +C6*4D0*EL1K20*EL2K20*EL1K21*EL2K21 + & +C7*2D0*(EL1K10*EL2K10*EL1K11*EL2K21 + & +EL1K10*EL2K20*EL1K11*EL2K11) + & +C8*2D0*(EL1K20*EL2K20*EL1K11*EL2K21 + & +EL1K10*EL2K20*EL1K21*EL2K21) + & +C9*4D0*EL1K10*EL2K20*EL1K11*EL2K21 + & +C0*(EL1K10*EL2K10*EL1K21*EL2K21 + & +2D0*EL1K10*EL2K20*EL1K11*EL2K21 + & +EL1K20*EL2K20*EL1K11*EL2K11) + ELSEIF(MSTP(147).EQ.2) THEN + FACQQG=2D0*(C1 + & -C2*EL1K11*EL2K11 + & -C3*EL1K21*EL2K21 + & -C4*EL1K11*EL2K21 + & +C5*(EL1K11*EL2K11)**2 + & +C6*(EL1K21*EL2K21)**2 + & +C7*EL1K11*EL2K11*EL1K11*EL2K21 + & +C8*EL1K21*EL2K21*EL1K11*EL2K21 + & +(C9+C0)*(EL1K11*EL2K21)**2) + ENDIF + FACQQG=COMFAC*FF*FACQQG + ENDIF + IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQG*PARP(IONIUM+5) + ENDIF + + ELSEIF(ISUB.EQ.434) THEN +C...q + g -> q + QQ~[3P01] + IF(MSTP(145).EQ.0) THEN + FACQQG=-COMFAC*PARU(1)*AS**3*(16D0/81D0)* + & (TH-3D0*SQMQQ)**2*(SH2+UH2)/(SQMQQR*TH*UHSH2**2) + ELSE + FA=-PARU(1)*AS**3*(16D0/243D0)* + & (TH-3D0*SQMQQ)**2*(SH2+UH2)/(SQMQQR*TH*UHSH2**2) + IF(MSTP(147).EQ.0) THEN + FACQQG=COMFAC*FA + ELSEIF(MSTP(147).EQ.1) THEN + FACQQG=COMFAC*2D0*FA + ELSEIF(MSTP(147).EQ.3) THEN + FACQQG=COMFAC*FA + ELSEIF(MSTP(147).EQ.4) THEN + FACQQG=COMFAC*FA + ELSEIF(MSTP(147).EQ.5) THEN + FACQQG=0D0 + ELSEIF(MSTP(147).EQ.6) THEN + FACQQG=0D0 + ENDIF + ENDIF + DO 2452 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2452 + DO 2451 ISDE=1,2 + IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2451 + IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2451 + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQG*PARP(IONIUM+5) + 2451 CONTINUE + 2452 CONTINUE + + ELSEIF(ISUB.EQ.435) THEN +C...q + g -> q + QQ~[3P11] + IF(MSTP(145).EQ.0) THEN + FACQQG=-COMFAC*PARU(1)*AS**3*(32D0/27D0)* + & (4D0*SQMQQ*SH*UH+TH*(SH2+UH2))/(SQMQQR*UHSH2**2) + ELSE + FF=(64D0*PARU(1)*AS**3*SQMQQR)/(27D0*UHSH2**2) + C1=SH*UH + C2=2D0*SH + C3=0D0 + C4=2D0*(SH-UH) + IF(MSTP(147).EQ.0) THEN + FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20 + & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0 + ELSEIF(MSTP(147).EQ.1) THEN + FACQQG=2D0*(-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21 + & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0) + ELSEIF(MSTP(147).EQ.3) THEN + FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20 + & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0 + ELSEIF(MSTP(147).EQ.4) THEN + FACQQG=-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21 + & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0 + ELSEIF(MSTP(147).EQ.5) THEN + FACQQG=C2*EL1K11*EL2K10+C3*EL1K21*EL2K20 + & +C4*(EL1K11*EL2K20+EL1K21*EL2K10)/2D0 + ELSEIF(MSTP(147).EQ.6) THEN + FACQQG=C2*EL1K11*EL2K11+C3*EL1K21*EL2K21 + & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0 + ENDIF + FACQQG=COMFAC*FF*FACQQG + ENDIF + DO 2454 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2454 + DO 2453 ISDE=1,2 + IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2453 + IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2453 + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQG*PARP(IONIUM+5) + 2453 CONTINUE + 2454 CONTINUE + + ELSEIF(ISUB.EQ.436) THEN +C...q + g -> q + QQ~[3P21] + IF(MSTP(145).EQ.0) THEN + FACQQG=-COMFAC*PARU(1)*AS**3*(32D0/81D0)* + & ((6D0*SQMQQ**2+TH2)*UHSH2 + & -2D0*SH*UH*(TH2+6D0*SQMQQ*UHSH))/ + & (SQMQQR*TH*UHSH2**2) + ELSE + FF=-(32D0*PARU(1)*AS**3*SQMQQ*SQMQQR)/(27D0*TH2*UHSH2**2) + C1=TH*UHSH2 + C2=4D0*(SH2+TH2+2D0*TH*UHSH) + C3=4D0*UHSH2 + C4=8D0*SH*UHSH + C5=8D0*TH + C6=0D0 + C7=16D0*TH + C8=0D0 + C9=-16D0*UHSH + C0=16D0*SQMQQ + IF(MSTP(147).EQ.0) THEN + FACQQG=1D0/3D0*(C1*3D0 + & -C2*(2D0*EL1K10*EL2K10+EL1K11*EL2K11) + & -C3*(2D0*EL1K20*EL2K20+EL1K21*EL2K21) + & -C4*(2D0*EL1K10*EL2K20+EL1K11*EL2K21) + & +C5*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)**2 + & +C6*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)**2 + & +C7*2D0*(EL1K10*EL2K10-EL1K11*EL2K11) + & *(EL1K10*EL2K20-EL1K11*EL2K21) + & +C8*2D0*(EL1K20*EL2K20-EL1K21*EL2K21) + & *(EL1K10*EL2K20-EL1K11*EL2K21) + & +C9*2D0*(EL1K10*EL2K10-EL1K11*EL2K11) + & *(EL1K20*EL2K20-EL1K21*EL2K21) + & +C0*2D0*(EL1K10*EL2K20-EL1K11*EL2K21)**2) + ELSEIF(MSTP(147).EQ.1) THEN + FACQQG=C1*2D0 + & -C2*(EL1K10*EL2K10+EL1K11*EL2K11) + & -C3*(EL1K20*EL2K20+EL1K21*EL2K21) + & -C4*(EL1K10*EL2K20+EL1K11*EL2K21) + & +C5*4D0*EL1K10*EL2K10*EL1K11*EL2K11 + & +C6*4D0*EL1K20*EL2K20*EL1K21*EL2K21 + & +C7*2D0*(EL1K10*EL2K10*EL1K11*EL2K21 + & +EL1K10*EL2K20*EL1K11*EL2K11) + & +C8*2D0*(EL1K20*EL2K20*EL1K11*EL2K21 + & +EL1K10*EL2K20*EL1K21*EL2K21) + & +C9*4D0*EL1K10*EL2K20*EL1K11*EL2K21 + & +C0*(EL1K10*EL2K10*EL1K21*EL2K21 + & +2D0*EL1K10*EL2K20*EL1K11*EL2K21 + & +EL1K20*EL2K20*EL1K11*EL2K11) + ELSEIF(MSTP(147).EQ.2) THEN + FACQQG=2D0*(C1 + & -C2*EL1K11*EL2K11 + & -C3*EL1K21*EL2K21 + & -C4*EL1K11*EL2K21 + & +C5*(EL1K11*EL2K11)**2 + & +C6*(EL1K21*EL2K21)**2 + & +C7*EL1K11*EL2K11*EL1K11*EL2K21 + & +C8*EL1K21*EL2K21*EL1K11*EL2K21 + & +(C9+C0)*(EL1K11*EL2K21)**2) + ENDIF + FACQQG=COMFAC*FF*FACQQG + ENDIF + DO 2456 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2456 + DO 2455 ISDE=1,2 + IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2455 + IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2455 + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQG*PARP(IONIUM+5) + 2455 CONTINUE + 2456 CONTINUE + + ELSEIF(ISUB.EQ.437) THEN +C...q + q~ -> g + QQ~[3P01] + IF(MSTP(145).EQ.0) THEN + FACQQG=COMFAC*PARU(1)*AS**3*(128D0/243D0)* + & (SH-3D0*SQMQQ)**2*(TH2+UH2)/(SQMQQR*SH*THUH2**2) + ELSE + FA=PARU(1)*AS**3*(128D0/729D0)* + & (SH-3D0*SQMQQ)**2*(TH2+UH2)/(SQMQQR*SH*THUH2**2) + IF(MSTP(147).EQ.0) THEN + FACQQG=COMFAC*FA + ELSEIF(MSTP(147).EQ.1) THEN + FACQQG=COMFAC*2D0*FA + ELSEIF(MSTP(147).EQ.3) THEN + FACQQG=COMFAC*FA + ELSEIF(MSTP(147).EQ.4) THEN + FACQQG=COMFAC*FA + ELSEIF(MSTP(147).EQ.5) THEN + FACQQG=0D0 + ELSEIF(MSTP(147).EQ.6) THEN + FACQQG=0D0 + ENDIF + ENDIF + DO 2457 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR. + & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2457 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQG*PARP(IONIUM+5) + 2457 CONTINUE + + ELSEIF(ISUB.EQ.438) THEN +C...q + q~ -> g + QQ~[3P11] + IF(MSTP(145).EQ.0) THEN + FACQQG=COMFAC*PARU(1)*AS**3*256D0/81D0* + & (4D0*SQMQQ*TH*UH+SH*(TH2+UH2))/(SQMQQR*THUH2**2) + ELSE + FF=-(512D0*PARU(1)*AS**3*SQMQQR)/(81D0*THUH2**2) + C1=TH*UH + C2=2D0*UH + C3=2D0*TH + C4=2D0*THUH + IF(MSTP(147).EQ.0) THEN + FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20 + & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0 + ELSEIF(MSTP(147).EQ.1) THEN + FACQQG=2D0*(-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21 + & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0) + ELSEIF(MSTP(147).EQ.3) THEN + FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20 + & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0 + ELSEIF(MSTP(147).EQ.4) THEN + FACQQG=-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21 + & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0 + ELSEIF(MSTP(147).EQ.5) THEN + FACQQG=C2*EL1K11*EL2K10+C3*EL1K21*EL2K20 + & +C4*(EL1K11*EL2K20+EL1K21*EL2K10)/2D0 + ELSEIF(MSTP(147).EQ.6) THEN + FACQQG=C2*EL1K11*EL2K11+C3*EL1K21*EL2K21 + & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0 + ENDIF + FACQQG=COMFAC*FF*FACQQG + ENDIF + DO 2458 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR. + & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2458 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQG*PARP(IONIUM+5) + 2458 CONTINUE + + ELSEIF(ISUB.EQ.439) THEN +C...q + q~ -> g + QQ~[3P21] + IF(MSTP(145).EQ.0) THEN + FACQQG=COMFAC*PARU(1)*AS**3*(256D0/243D0)* + & ((6D0*SQMQQ**2+SH2)*THUH2 + & -2D0*TH*UH*(SH2+6D0*SQMQQ*THUH))/ + & (SQMQQR*SH*THUH2**2) + ELSE + FF=(256D0*PARU(1)*AS**3*SQMQQ*SQMQQR)/(81D0*SH2*THUH2**2) + C1=SH*THUH2 + C2=4D0*(SH2+UH2+2D0*SH*THUH) + C3=4D0*(SH2+TH2+2D0*SH*THUH) + C4=8D0*(SH2-TH*UH+2D0*SH*THUH) + C5=8D0*SH + C6=C5 + C7=16D0*SH + C8=C7 + C9=-16D0*THUH + C0=16D0*SQMQQ + IF(MSTP(147).EQ.0) THEN + FACQQG=1D0/3D0*(C1*3D0 + & -C2*(2D0*EL1K10*EL2K10+EL1K11*EL2K11) + & -C3*(2D0*EL1K20*EL2K20+EL1K21*EL2K21) + & -C4*(2D0*EL1K10*EL2K20+EL1K11*EL2K21) + & +C5*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)**2 + & +C6*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)**2 + & +C7*2D0*(EL1K10*EL2K10-EL1K11*EL2K11) + & *(EL1K10*EL2K20-EL1K11*EL2K21) + & +C8*2D0*(EL1K20*EL2K20-EL1K21*EL2K21) + & *(EL1K10*EL2K20-EL1K11*EL2K21) + & +C9*2D0*(EL1K10*EL2K10-EL1K11*EL2K11) + & *(EL1K20*EL2K20-EL1K21*EL2K21) + & +C0*2D0*(EL1K10*EL2K20-EL1K11*EL2K21)**2) + ELSEIF(MSTP(147).EQ.1) THEN + FACQQG=C1*2D0 + & -C2*(EL1K10*EL2K10+EL1K11*EL2K11) + & -C3*(EL1K20*EL2K20+EL1K21*EL2K21) + & -C4*(EL1K10*EL2K20+EL1K11*EL2K21) + & +C5*4D0*EL1K10*EL2K10*EL1K11*EL2K11 + & +C6*4D0*EL1K20*EL2K20*EL1K21*EL2K21 + & +C7*2D0*(EL1K10*EL2K10*EL1K11*EL2K21 + & +EL1K10*EL2K20*EL1K11*EL2K11) + & +C8*2D0*(EL1K20*EL2K20*EL1K11*EL2K21 + & +EL1K10*EL2K20*EL1K21*EL2K21) + & +C9*4D0*EL1K10*EL2K20*EL1K11*EL2K21 + & +C0*(EL1K10*EL2K10*EL1K21*EL2K21 + & +2D0*EL1K10*EL2K20*EL1K11*EL2K21 + & +EL1K20*EL2K20*EL1K11*EL2K11) + ELSEIF(MSTP(147).EQ.2) THEN + FACQQG=2D0*(C1 + & -C2*EL1K11*EL2K11 + & -C3*EL1K21*EL2K21 + & -C4*EL1K11*EL2K21 + & +C5*(EL1K11*EL2K11)**2 + & +C6*(EL1K21*EL2K21)**2 + & +C7*EL1K11*EL2K11*EL1K11*EL2K21 + & +C8*EL1K21*EL2K21*EL1K11*EL2K21 + & +(C9+C0)*(EL1K11*EL2K21)**2) + ENDIF + FACQQG=COMFAC*FF*FACQQG + ENDIF + DO 2459 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR. + & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2459 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQG*PARP(IONIUM+5) + 2459 CONTINUE + ENDIF +C...QUARKONIA--- + + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYSGWZ +C...Subprocess cross sections for W/Z processes, +C...except that longitudinal WW scattering is in Higgs sector. +C...Auxiliary to PYSIGH. + + SUBROUTINE PYSGWZ(NCHN,SIGS) + +C...Double precision and integer declarations + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) + COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000) + COMMON/PYINT4/MWID(500),WIDS(500,5) + COMMON/PYTCSM/ITCM(0:99),RTCM(0:99) + COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA, + &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4, + &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW, + &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR + SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/, + &/PYINT2/,/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/ +C...Local arrays and complex numbers + DIMENSION WDTP(0:400),WDTE(0:400,0:5),HGZ(6,3),HL3(3),HR3(3), + &HL4(3),HR4(3) + COMPLEX*16 COULCK,COULCP,COULCD,COULCR,COULCS + +C...Differential cross section expressions. + + IF(ISUB.LE.20) THEN + IF(ISUB.EQ.1) THEN +C...f + fbar -> gamma*/Z0 + MINT(61)=2 + CALL PYWIDT(23,SH,WDTP,WDTE) + HS=SHR*WDTP(0) + FACZ=4D0*COMFAC*3D0 + HP0=AEM/3D0*SH + HP1=AEM/3D0*XWC*SH + DO 100 I=MMINA,MMAXA + IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100 + EI=KCHG(IABS(I),1)/3D0 + AI=SIGN(1D0,EI) + VI=AI-4D0*EI*XWV + HI0=HP0 + IF(IABS(I).LE.10) HI0=HI0*FACA/3D0 + HI1=HP1 + IF(IABS(I).LE.10) HI1=HI1*FACA/3D0 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACZ*(EI**2/SH2*HI0*HP0*VINT(111)+ + & EI*VI*(1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)* + & (HI0*HP1+HI1*HP0)*VINT(112)+(VI**2+AI**2)/ + & ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114)) + 100 CONTINUE + + ELSEIF(ISUB.EQ.2) THEN +C...f + fbar' -> W+/- + CALL PYWIDT(24,SH,WDTP,WDTE) + HS=SHR*WDTP(0) + FACBW=4D0*COMFAC/((SH-SQMW)**2+HS**2)*3D0 + HP=AEM/(24D0*XW)*SH + DO 120 I=MMIN1,MMAX1 + IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120 + IA=IABS(I) + DO 110 J=MMIN2,MMAX2 + IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110 + JA=IABS(J) + IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 110 + IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10)) + & GOTO 110 + KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3 + HI=HP*2D0 + IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4)) + SIGH(NCHN)=HI*FACBW*HF + 110 CONTINUE + 120 CONTINUE + + ELSEIF(ISUB.EQ.15) THEN +C...f + fbar -> g + (gamma*/Z0) (q + qbar -> g + (gamma*/Z0) only) + FACZG=COMFAC*AS*AEM*(8D0/9D0)*(TH2+UH2+2D0*SQM4*SH)/(TH*UH) +C...gamma, gamma/Z interference and Z couplings to final fermion pairs + HFGG=0D0 + HFGZ=0D0 + HFZZ=0D0 + RADC4=1D0+PYALPS(SQM4)/PARU(1) + DO 130 I=1,MIN(16,MDCY(23,3)) + IDC=I+MDCY(23,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 130 + IMDM=0 + IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4) + & IMDM=1 + IF(I.LE.8) THEN + EF=KCHG(I,1)/3D0 + AF=SIGN(1D0,EF+0.1D0) + VF=AF-4D0*EF*XWV + ELSEIF(I.LE.16) THEN + EF=KCHG(I+2,1)/3D0 + AF=SIGN(1D0,EF+0.1D0) + VF=AF-4D0*EF*XWV + ENDIF + RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4 + IF(4D0*RM1.LT.1D0) THEN + FCOF=1D0 + IF(I.LE.8) FCOF=3D0*RADC4 + BE34=SQRT(MAX(0D0,1D0-4D0*RM1)) + IF(IMDM.EQ.1) THEN + HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34 + HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34 + HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+ + & AF**2*(1D0-4D0*RM1))*BE34 + ENDIF + ENDIF + 130 CONTINUE +C...Propagators: as simulated in PYOFSH and as desired + HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2) + MINT15=MINT(15) + MINT(15)=1 + MINT(61)=1 + CALL PYWIDT(23,SQM4,WDTP,WDTE) + MINT(15)=MINT15 + HFAEM=(PARU(108)/PARU(2))*(2D0/3D0) + HFGG=HFGG*HFAEM*VINT(111)/SQM4 + HFGZ=HFGZ*HFAEM*VINT(112)/SQM4 + HFZZ=HFZZ*HFAEM*VINT(114)/SQM4 +C...Loop over flavours; consider full gamma/Z structure + DO 140 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR. + & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 140 + EI=KCHG(IABS(I),1)/3D0 + AI=SIGN(1D0,EI) + VI=AI-4D0*EI*XWV + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACZG*(EI**2*HFGG+EI*VI*HFGZ+ + & (VI**2+AI**2)*HFZZ)/HBW4 + 140 CONTINUE + + ELSEIF(ISUB.EQ.16) THEN +C...f + fbar' -> g + W+/- (q + qbar' -> g + W+/- only) + FACWG=COMFAC*AS*AEM/XW*2D0/9D0*(TH2+UH2+2D0*SQM4*SH)/(TH*UH) +C...Propagators: as simulated in PYOFSH and as desired + HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2) + CALL PYWIDT(24,SQM4,WDTP,WDTE) + GMMWC=SQRT(SQM4)*WDTP(0) + HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2) + FACWG=FACWG*HBW4C/HBW4 + DO 160 I=MMIN1,MMAX1 + IA=IABS(I) + IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 160 + DO 150 J=MMIN2,MMAX2 + JA=IABS(J) + IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 150 + IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 150 + KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3 + WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0) + FCKM=VCKM((IA+1)/2,(JA+1)/2) + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACWG*FCKM*WIDSC + 150 CONTINUE + 160 CONTINUE + + ELSEIF(ISUB.EQ.19) THEN +C...f + fbar -> gamma + (gamma*/Z0) + FACGZ=COMFAC*2D0*AEM**2*(TH2+UH2+2D0*SQM4*SH)/(TH*UH) +C...gamma, gamma/Z interference and Z couplings to final fermion pairs + HFGG=0D0 + HFGZ=0D0 + HFZZ=0D0 + RADC4=1D0+PYALPS(SQM4)/PARU(1) + DO 170 I=1,MIN(16,MDCY(23,3)) + IDC=I+MDCY(23,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 170 + IMDM=0 + IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4) + & IMDM=1 + IF(I.LE.8) THEN + EF=KCHG(I,1)/3D0 + AF=SIGN(1D0,EF+0.1D0) + VF=AF-4D0*EF*XWV + ELSEIF(I.LE.16) THEN + EF=KCHG(I+2,1)/3D0 + AF=SIGN(1D0,EF+0.1D0) + VF=AF-4D0*EF*XWV + ENDIF + RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4 + IF(4D0*RM1.LT.1D0) THEN + FCOF=1D0 + IF(I.LE.8) FCOF=3D0*RADC4 + BE34=SQRT(MAX(0D0,1D0-4D0*RM1)) + IF(IMDM.EQ.1) THEN + HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34 + HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34 + HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+ + & AF**2*(1D0-4D0*RM1))*BE34 + ENDIF + ENDIF + 170 CONTINUE +C...Propagators: as simulated in PYOFSH and as desired + HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2) + MINT15=MINT(15) + MINT(15)=1 + MINT(61)=1 + CALL PYWIDT(23,SQM4,WDTP,WDTE) + MINT(15)=MINT15 + HFAEM=(PARU(108)/PARU(2))*(2D0/3D0) + HFGG=HFGG*HFAEM*VINT(111)/SQM4 + HFGZ=HFGZ*HFAEM*VINT(112)/SQM4 + HFZZ=HFZZ*HFAEM*VINT(114)/SQM4 +C...Loop over flavours; consider full gamma/Z structure + DO 180 I=MMINA,MMAXA + IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 180 + EI=KCHG(IABS(I),1)/3D0 + AI=SIGN(1D0,EI) + VI=AI-4D0*EI*XWV + FCOI=1D0 + IF(IABS(I).LE.10) FCOI=FACA/3D0 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACGZ*FCOI*EI**2*(EI**2*HFGG+EI*VI*HFGZ+ + & (VI**2+AI**2)*HFZZ)/HBW4 + 180 CONTINUE + + ELSEIF(ISUB.EQ.20) THEN +C...f + fbar' -> gamma + W+/- + FACGW=COMFAC*0.5D0*AEM**2/XW +C...Propagators: as simulated in PYOFSH and as desired + HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2) + CALL PYWIDT(24,SQM4,WDTP,WDTE) + GMMWC=SQRT(SQM4)*WDTP(0) + HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2) + FACGW=FACGW*HBW4C/HBW4 +C...Anomalous couplings + TERM1=(TH2+UH2+2D0*SQM4*SH)/(TH*UH) + TERM2=0D0 + TERM3=0D0 + IF(ITCM(5).GE.1.AND.ITCM(5).LE.4) THEN + TERM2=RTCM(46)*(TH-UH)/(TH+UH) + TERM3=0.5D0*RTCM(46)**2*(TH*UH+(TH2+UH2)*SH/ + & (4D0*SQMW))/(TH+UH)**2 + ENDIF + DO 200 I=MMIN1,MMAX1 + IA=IABS(I) + IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 200 + DO 190 J=MMIN2,MMAX2 + JA=IABS(J) + IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 190 + IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 190 + IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10)) + & GOTO 190 + KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3 + WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0) + IF(IA.LE.10) THEN + FACWR=UH/(TH+UH)-1D0/3D0 + FCKM=VCKM((IA+1)/2,(JA+1)/2) + FCOI=FACA/3D0 + ELSE + FACWR=-TH/(TH+UH) + FCKM=1D0 + FCOI=1D0 + ENDIF + FACWK=TERM1*FACWR**2+TERM2*FACWR+TERM3 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACGW*FACWK*FCOI*FCKM*WIDSC + 190 CONTINUE + 200 CONTINUE + ENDIF + + ELSEIF(ISUB.LE.40) THEN + IF(ISUB.EQ.22) THEN +C...f + fbar -> (gamma*/Z0) + (gamma*/Z0) +C...Kinematics dependence + FACZZ=COMFAC*AEM**2*((TH2+UH2+2D0*(SQM3+SQM4)*SH)/(TH*UH)- + & SQM3*SQM4*(1D0/TH2+1D0/UH2)) +C...gamma, gamma/Z interference and Z couplings to final fermion pairs + DO 220 I=1,6 + DO 210 J=1,3 + HGZ(I,J)=0D0 + 210 CONTINUE + 220 CONTINUE + RADC3=1D0+PYALPS(SQM3)/PARU(1) + RADC4=1D0+PYALPS(SQM4)/PARU(1) + DO 230 I=1,MIN(16,MDCY(23,3)) + IDC=I+MDCY(23,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 230 + IMDM=0 + IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2) IMDM=1 + IF(MDME(IDC,1).EQ.4.OR.MDME(IDC,1).EQ.5) IMDM=MDME(IDC,1)-2 + IF(I.LE.8) THEN + EF=KCHG(I,1)/3D0 + AF=SIGN(1D0,EF+0.1D0) + VF=AF-4D0*EF*XWV + ELSEIF(I.LE.16) THEN + EF=KCHG(I+2,1)/3D0 + AF=SIGN(1D0,EF+0.1D0) + VF=AF-4D0*EF*XWV + ENDIF + RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM3 + IF(4D0*RM1.LT.1D0) THEN + FCOF=1D0 + IF(I.LE.8) FCOF=3D0*RADC3 + BE34=SQRT(MAX(0D0,1D0-4D0*RM1)) + IF(IMDM.GE.1) THEN + HGZ(1,IMDM)=HGZ(1,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34 + HGZ(2,IMDM)=HGZ(2,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34 + HGZ(3,IMDM)=HGZ(3,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+ + & AF**2*(1D0-4D0*RM1))*BE34 + ENDIF + ENDIF + RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4 + IF(4D0*RM1.LT.1D0) THEN + FCOF=1D0 + IF(I.LE.8) FCOF=3D0*RADC4 + BE34=SQRT(MAX(0D0,1D0-4D0*RM1)) + IF(IMDM.GE.1) THEN + HGZ(4,IMDM)=HGZ(4,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34 + HGZ(5,IMDM)=HGZ(5,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34 + HGZ(6,IMDM)=HGZ(6,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+ + & AF**2*(1D0-4D0*RM1))*BE34 + ENDIF + ENDIF + 230 CONTINUE +C...Propagators: as simulated in PYOFSH and as desired + HBW3=(1D0/PARU(1))*GMMZ/((SQM3-SQMZ)**2+GMMZ**2) + HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2) + MINT15=MINT(15) + MINT(15)=1 + MINT(61)=1 + CALL PYWIDT(23,SQM3,WDTP,WDTE) + MINT(15)=MINT15 + HFAEM=(PARU(108)/PARU(2))*(2D0/3D0) + DO 240 J=1,3 + HGZ(1,J)=HGZ(1,J)*HFAEM*VINT(111)/SQM3 + HGZ(2,J)=HGZ(2,J)*HFAEM*VINT(112)/SQM3 + HGZ(3,J)=HGZ(3,J)*HFAEM*VINT(114)/SQM3 + 240 CONTINUE + MINT15=MINT(15) + MINT(15)=1 + MINT(61)=1 + CALL PYWIDT(23,SQM4,WDTP,WDTE) + MINT(15)=MINT15 + HFAEM=(PARU(108)/PARU(2))*(2D0/3D0) + DO 250 J=1,3 + HGZ(4,J)=HGZ(4,J)*HFAEM*VINT(111)/SQM4 + HGZ(5,J)=HGZ(5,J)*HFAEM*VINT(112)/SQM4 + HGZ(6,J)=HGZ(6,J)*HFAEM*VINT(114)/SQM4 + 250 CONTINUE +C...Loop over flavours; separate left- and right-handed couplings + DO 270 I=MMINA,MMAXA + IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 270 + EI=KCHG(IABS(I),1)/3D0 + AI=SIGN(1D0,EI) + VI=AI-4D0*EI*XWV + VALI=VI-AI + VARI=VI+AI + FCOI=1D0 + IF(IABS(I).LE.10) FCOI=FACA/3D0 + DO 260 J=1,3 + HL3(J)=EI**2*HGZ(1,J)+EI*VALI*HGZ(2,J)+VALI**2*HGZ(3,J) + HR3(J)=EI**2*HGZ(1,J)+EI*VARI*HGZ(2,J)+VARI**2*HGZ(3,J) + HL4(J)=EI**2*HGZ(4,J)+EI*VALI*HGZ(5,J)+VALI**2*HGZ(6,J) + HR4(J)=EI**2*HGZ(4,J)+EI*VARI*HGZ(5,J)+VARI**2*HGZ(6,J) + 260 CONTINUE + FACLR=HL3(1)*HL4(1)+HL3(1)*(HL4(2)+HL4(3))+ + & HL4(1)*(HL3(2)+HL3(3))+HL3(2)*HL4(3)+HL4(2)*HL3(3)+ + & HR3(1)*HR4(1)+HR3(1)*(HR4(2)+HR4(3))+ + & HR4(1)*(HR3(2)+HR3(3))+HR3(2)*HR4(3)+HR4(2)*HR3(3) + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=0.5D0*FACZZ*FCOI*FACLR/(HBW3*HBW4) + 270 CONTINUE + + ELSEIF(ISUB.EQ.23) THEN +C...f + fbar' -> Z0 + W+/- (Z0 only, i.e. no gamma* admixture.) + FACZW=COMFAC*0.5D0*(AEM/XW)**2 + FACZW=FACZW*WIDS(23,2) + THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2) + FACBW=1D0/((SH-SQMW)**2+GMMW**2) + DO 290 I=MMIN1,MMAX1 + IA=IABS(I) + IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 290 + DO 280 J=MMIN2,MMAX2 + JA=IABS(J) + IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 280 + IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 280 + IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10)) + & GOTO 280 + KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3 + EI=KCHG(IA,1)/3D0 + AI=SIGN(1D0,EI+0.1D0) + VI=AI-4D0*EI*XWV + EJ=KCHG(JA,1)/3D0 + AJ=SIGN(1D0,EJ+0.1D0) + VJ=AJ-4D0*EJ*XWV + IF(VI+AI.GT.0) THEN + VISAV=VI + AISAV=AI + VI=VJ + AI=AJ + VJ=VISAV + AJ=AISAV + ENDIF + FCKM=1D0 + IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2) + FCOI=1D0 + IF(IA.LE.10) FCOI=FACA/3D0 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACZW*FCOI*FCKM*(FACBW*((9D0-8D0*XW)/4D0*THUH+ + & (8D0*XW-6D0)/4D0*SH*(SQM3+SQM4))+(THUH-SH*(SQM3+SQM4))* + & (SH-SQMW)*FACBW*0.5D0*((VJ+AJ)/TH-(VI+AI)/UH)+ + & THUH/(16D0*XW1)*((VJ+AJ)**2/TH2+(VI+AI)**2/UH2)+ + & SH*(SQM3+SQM4)/(8D0*XW1)*(VI+AI)*(VJ+AJ)/(TH*UH))* + & WIDS(24,(5-KCHW)/2) +C***Protect against slightly negative cross sections. (Reason yet to be +C***sorted out. One possibility: addition of width to the W propagator.) + SIGH(NCHN)=MAX(0D0,SIGH(NCHN)) + 280 CONTINUE + 290 CONTINUE + + ELSEIF(ISUB.EQ.25) THEN +C...f + fbar -> W+ + W- +C...Propagators: Z0, W+- as simulated in PYOFSH and as desired + GMMZC=GMMZ + HBWZC=SH**2/((SH-SQMZ)**2+GMMZC**2) + HBW3=GMMW/((SQM3-SQMW)**2+GMMW**2) + CALL PYWIDT(24,SQM3,WDTP,WDTE) + GMMW3=SQRT(SQM3)*WDTP(0) + HBW3C=GMMW3/((SQM3-SQMW)**2+GMMW3**2) + HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2) + CALL PYWIDT(24,SQM4,WDTP,WDTE) + GMMW4=SQRT(SQM4)*WDTP(0) + HBW4C=GMMW4/((SQM4-SQMW)**2+GMMW4**2) +C...Kinematical functions + THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2) + THUH34=(2D0*SH*(SQM3+SQM4)+THUH)/(SQM3*SQM4) + GS=(((SH-SQM3-SQM4)**2-4D0*SQM3*SQM4)*THUH34+12D0*THUH)/SH2 + GT=THUH34+4D0*THUH/TH2 + GST=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/TH)/SH + GU=THUH34+4D0*THUH/UH2 + GSU=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/UH)/SH +C...Common factors and couplings + FACWW=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4) + FACWW=FACWW*WIDS(24,1) + CGG=AEM**2/2D0 + CGZ=AEM**2/(4D0*XW)*HBWZC*(1D0-SQMZ/SH) + CZZ=AEM**2/(32D0*XW**2)*HBWZC + CNG=AEM**2/(4D0*XW) + CNZ=AEM**2/(16D0*XW**2)*HBWZC*(1D0-SQMZ/SH) + CNN=AEM**2/(16D0*XW**2) +C...Coulomb factor for W+W- pair + IF(MSTP(40).GE.1.AND.MSTP(40).LE.3) THEN + COULE=(SH-4D0*SQMW)/(4D0*PMAS(24,1)) + COULP=MAX(1D-10,0.5D0*BE34*SQRT(SH)) + IF(COULE.LT.100D0*PMAS(24,2)) THEN + COULP1=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+ + & PMAS(24,2)**2)-COULE)) + ELSE + COULP1=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/COULE)) + ENDIF + IF(COULE.GT.-100D0*PMAS(24,2)) THEN + COULP2=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+ + & PMAS(24,2)**2)+COULE)) + ELSE + COULP2=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/ + & ABS(COULE))) + ENDIF + IF(MSTP(40).EQ.1) THEN + COULDC=PARU(1)-2D0*ATAN((COULP1**2+COULP2**2-COULP**2)/ + & MAX(1D-10,2D0*COULP*COULP1)) + FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34) + ELSEIF(MSTP(40).EQ.2) THEN + COULCK=DCMPLX(DBLE(COULP1),DBLE(COULP2)) + COULCP=DCMPLX(0D0,DBLE(COULP)) + COULCD=(COULCK+COULCP)/(COULCK-COULCP) + COULCR=1D0+DBLE(PARU(101)*SQRT(SH))/ + & (4D0*COULCP)*LOG(COULCD) + COULCS=DCMPLX(0D0,0D0) + NSTP=100 + DO 300 ISTP=1,NSTP + COULXX=(ISTP-0.5)/NSTP + COULCS=COULCS+(1D0/COULXX)*LOG((1D0+COULXX*COULCD)/ + & (1D0+COULXX/COULCD)) + 300 CONTINUE + COULCR=COULCR+DBLE(PARU(101)**2*SH)/(16D0*COULCP*COULCK)* + & (COULCS/NSTP) + FACCOU=ABS(COULCR)**2 + ELSEIF(MSTP(40).EQ.3) THEN + COULDC=PARU(1)-2D0*(1D0-BE34)**2*ATAN((COULP1**2+ + & COULP2**2-COULP**2)/MAX(1D-10,2D0*COULP*COULP1)) + FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34) + ENDIF + ELSEIF(MSTP(40).EQ.4) THEN + FACCOU=1D0+0.5D0*PARU(101)*PARU(1)/MAX(1D-5,BE34) + ELSE + FACCOU=1D0 + ENDIF + VINT(95)=FACCOU + FACWW=FACWW*FACCOU +C...Loop over allowed flavours + DO 310 I=MMINA,MMAXA + IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 310 + EI=KCHG(IABS(I),1)/3D0 + AI=SIGN(1D0,EI+0.1D0) + VI=AI-4D0*EI*XWV + FCOI=1D0 + IF(IABS(I).LE.10) FCOI=FACA/3D0 + IF(MSTP(50).LE.0.OR.IABS(I).LE.10) THEN + IF(AI.LT.0D0) THEN + DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS+ + & (CNG*EI+CNZ*(VI+AI))*GST+CNN*GT + ELSE + DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS- + & (CNG*EI+CNZ*(VI+AI))*GSU+CNN*GU + ENDIF + ELSE + XMW02=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH + BET=SQRT(1D0-4D0*XMW02/SH) + GAT=1D0/SQRT(1D0-BET**2) + STHE2=1D0-CTH**2 + AMPZG=BET**3*(16D0+(4D0*BET**2*GAT**2+3D0/GAT**2)*STHE2) + AMPNU=BET*(2D0+BET**2*GAT**2*STHE2/2D0+ + & 2D0*BET**2*(1D0-BET**2)*STHE2/(1D0-2D0*BET*CTH+BET**2)**2) + AMPNG=BET*((1D0+BET**2)*(4D0+BET**2*GAT**2*STHE2)+ + & 2D0*(1D0-BET**2)*(BET**2*STHE2-2D0*(1D0-BET**2))/ + & (1D0-2D0*BET*CTH+BET**2)) + PROPI1=(0.25D0*SQMZ/XMW02)*HBWZC*(1D0-SQMZ/SH) + PROPI2=(0.25D0*SQMZ/XMW02)**2*HBWZC + A0=(2D0*(XMW02/SQMZ)-(1D0-BET**2)*XW)*POLL + A1=(2D0*(XMW02/SQMZ)**2-2*XMW02/SQMZ*(1D0-BET**2)*XW)*POLL + A2=(1D0-BET**2)**2*XW**2*(POLR+POLL)/2D0 + ATOT=AMPNU*POLL+(A1+A2)*PROPI2*AMPZG-A0*PROPI1*AMPNG + ATOT=ATOT*CNN/SQMW*SH/BET*2D0 + DSIGWW=ATOT + ENDIF + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACWW*FCOI*DSIGWW + 310 CONTINUE + + ELSEIF(ISUB.EQ.30) THEN +C...f + g -> f + (gamma*/Z0) (q + g -> q + (gamma*/Z0) only) + FZQ=COMFAC*FACA*AS*AEM*(1D0/3D0)*(SH2+UH2+2D0*SQM4*TH)/ + & (-SH*UH) +C...gamma, gamma/Z interference and Z couplings to final fermion pairs + HFGG=0D0 + HFGZ=0D0 + HFZZ=0D0 + RADC4=1D0+PYALPS(SQM4)/PARU(1) + DO 320 I=1,MIN(16,MDCY(23,3)) + IDC=I+MDCY(23,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 320 + IMDM=0 + IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4) + & IMDM=1 + IF(I.LE.8) THEN + EF=KCHG(I,1)/3D0 + AF=SIGN(1D0,EF+0.1D0) + VF=AF-4D0*EF*XWV + ELSEIF(I.LE.16) THEN + EF=KCHG(I+2,1)/3D0 + AF=SIGN(1D0,EF+0.1D0) + VF=AF-4D0*EF*XWV + ENDIF + RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4 + IF(4D0*RM1.LT.1D0) THEN + FCOF=1D0 + IF(I.LE.8) FCOF=3D0*RADC4 + BE34=SQRT(MAX(0D0,1D0-4D0*RM1)) + IF(IMDM.EQ.1) THEN + HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34 + HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34 + HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+ + & AF**2*(1D0-4D0*RM1))*BE34 + ENDIF + ENDIF + 320 CONTINUE +C...Propagators: as simulated in PYOFSH and as desired + HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2) + MINT15=MINT(15) + MINT(15)=1 + MINT(61)=1 + CALL PYWIDT(23,SQM4,WDTP,WDTE) + MINT(15)=MINT15 + HFAEM=(PARU(108)/PARU(2))*(2D0/3D0) + HFGG=HFGG*HFAEM*VINT(111)/SQM4 + HFGZ=HFGZ*HFAEM*VINT(112)/SQM4 + HFZZ=HFZZ*HFAEM*VINT(114)/SQM4 +C...Loop over flavours; consider full gamma/Z structure + DO 340 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 340 + EI=KCHG(IABS(I),1)/3D0 + AI=SIGN(1D0,EI) + VI=AI-4D0*EI*XWV + FACZQ=FZQ*(EI**2*HFGG+EI*VI*HFGZ+ + & (VI**2+AI**2)*HFZZ)/HBW4 + DO 330 ISDE=1,2 + IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 330 + IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 330 + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACZQ + 330 CONTINUE + 340 CONTINUE + + ELSEIF(ISUB.EQ.31) THEN +C...f + g -> f' + W+/- (q + g -> q' + W+/- only) + FACWQ=COMFAC*FACA*AS*AEM/XW*1D0/12D0* + & (SH2+UH2+2D0*SQM4*TH)/(-SH*UH) +C...Propagators: as simulated in PYOFSH and as desired + HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2) + CALL PYWIDT(24,SQM4,WDTP,WDTE) + GMMWC=SQRT(SQM4)*WDTP(0) + HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2) + FACWQ=FACWQ*HBW4C/HBW4 + DO 360 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 360 + IA=IABS(I) + KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I)) + WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0) + DO 350 ISDE=1,2 + IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 350 + IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 350 + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC + 350 CONTINUE + 360 CONTINUE + + ELSEIF(ISUB.EQ.35) THEN +C...f + gamma -> f + (gamma*/Z0) + IF(MINT(15).EQ.22.AND.VINT(3).LT.0D0) THEN + FZQN=SH2+UH2+2D0*(SQM4-VINT(3)**2)*TH + FZQDTM=VINT(3)**2*SQM4-SH*(UH-VINT(4)**2) + ELSEIF(MINT(16).EQ.22.AND.VINT(4).LT.0D0) THEN + FZQN=SH2+UH2+2D0*(SQM4-VINT(4)**2)*TH + FZQDTM=VINT(4)**2*SQM4-SH*(UH-VINT(3)**2) + ELSE + FZQN=SH2+UH2+2D0*SQM4*TH + FZQDTM=-SH*UH + ENDIF + FZQN=COMFAC*2D0*AEM**2*MAX(0D0,FZQN) +C...gamma, gamma/Z interference and Z couplings to final fermion pairs + HFGG=0D0 + HFGZ=0D0 + HFZZ=0D0 + RADC4=1D0+PYALPS(SQM4)/PARU(1) + DO 370 I=1,MIN(16,MDCY(23,3)) + IDC=I+MDCY(23,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 370 + IMDM=0 + IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4) + & IMDM=1 + IF(I.LE.8) THEN + EF=KCHG(I,1)/3D0 + AF=SIGN(1D0,EF+0.1D0) + VF=AF-4D0*EF*XWV + ELSEIF(I.LE.16) THEN + EF=KCHG(I+2,1)/3D0 + AF=SIGN(1D0,EF+0.1D0) + VF=AF-4D0*EF*XWV + ENDIF + RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4 + IF(4D0*RM1.LT.1D0) THEN + FCOF=1D0 + IF(I.LE.8) FCOF=3D0*RADC4 + BE34=SQRT(MAX(0D0,1D0-4D0*RM1)) + IF(IMDM.EQ.1) THEN + HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34 + HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34 + HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+ + & AF**2*(1D0-4D0*RM1))*BE34 + ENDIF + ENDIF + 370 CONTINUE +C...Propagators: as simulated in PYOFSH and as desired + HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2) + MINT15=MINT(15) + MINT(15)=1 + MINT(61)=1 + CALL PYWIDT(23,SQM4,WDTP,WDTE) + MINT(15)=MINT15 + HFAEM=(PARU(108)/PARU(2))*(2D0/3D0) + HFGG=HFGG*HFAEM*VINT(111)/SQM4 + HFGZ=HFGZ*HFAEM*VINT(112)/SQM4 + HFZZ=HFZZ*HFAEM*VINT(114)/SQM4 +C...Loop over flavours; consider full gamma/Z structure + DO 390 I=MMINA,MMAXA + IF(I.EQ.0) GOTO 390 + EI=KCHG(IABS(I),1)/3D0 + AI=SIGN(1D0,EI) + VI=AI-4D0*EI*XWV + FACZQ=EI**2*(EI**2*HFGG+EI*VI*HFGZ+ + & (VI**2+AI**2)*HFZZ)/HBW4 + FZQD=MAX(PMAS(IABS(I),1)**2*SQM4,FZQDTM) + DO 380 ISDE=1,2 + IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 380 + IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 380 + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=22 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACZQ*FZQN/FZQD + 380 CONTINUE + 390 CONTINUE + + ELSEIF(ISUB.EQ.36) THEN +C...f + gamma -> f' + W+/- + FWQ=COMFAC*AEM**2/(2D0*XW)* + & (SH2+UH2+2D0*SQM4*TH)/(SQPTH*SQM4-SH*UH) +C...Propagators: as simulated in PYOFSH and as desired + HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2) + CALL PYWIDT(24,SQM4,WDTP,WDTE) + GMMWC=SQRT(SQM4)*WDTP(0) + HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2) + FWQ=FWQ*HBW4C/HBW4 + DO 410 I=MMINA,MMAXA + IF(I.EQ.0) GOTO 410 + IA=IABS(I) + EIA=ABS(KCHG(IABS(I),1)/3D0) + FACWQ=FWQ*(EIA-SH/(SH+UH))**2 + KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I)) + WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0) + DO 400 ISDE=1,2 + IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 400 + IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 400 + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=22 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC + 400 CONTINUE + 410 CONTINUE + ENDIF + + ELSEIF(ISUB.LE.100) THEN + IF(ISUB.EQ.69) THEN +C...gamma + gamma -> W+ + W- + SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4)) + FPROP=SH2/((SQMWE-TH)*(SQMWE-UH)) + FACWW=COMFAC*6D0*AEM**2*(1D0-FPROP*(4D0/3D0+2D0*SQMWE/SH)+ + & FPROP**2*(2D0/3D0+2D0*(SQMWE/SH)**2))*WIDS(24,1) + IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 420 + NCHN=NCHN+1 + ISIG(NCHN,1)=22 + ISIG(NCHN,2)=22 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACWW + 420 CONTINUE + + ELSEIF(ISUB.EQ.70) THEN +C...gamma + W+/- -> Z0 + W+/- + SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4)) + FPROP=(TH-SQMWE)**2/(-SH*(SQMWE-UH)) + FACZW=COMFAC*6D0*AEM**2*(XW1/XW)* + & (1D0-FPROP*(4D0/3D0+2D0*SQMWE/(TH-SQMWE))+ + & FPROP**2*(2D0/3D0+2D0*(SQMWE/(TH-SQMWE))**2))*WIDS(23,2) + DO 440 KCHW=1,-1,-2 + DO 430 ISDE=1,2 + IF(KFAC(ISDE,22)*KFAC(3-ISDE,24*KCHW).EQ.0) GOTO 430 + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=22 + ISIG(NCHN,3-ISDE)=24*KCHW + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACZW*WIDS(24,(5-KCHW)/2) + 430 CONTINUE + 440 CONTINUE + ENDIF + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYSGHG +C...Subprocess cross sections for Higgs processes, +C...except Higgs pairs in PYSGSU, but including WW scattering. +C...Auxiliary to PYSIGH. + + SUBROUTINE PYSGHG(NCHN,SIGS) + +C...Double precision and integer declarations + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) + COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000) + COMMON/PYINT4/MWID(500),WIDS(500,5) + COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) + COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) + COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA, + &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4, + &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW, + &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR + SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/, + &/PYINT3/,/PYINT4/,/PYSUBS/,/PYMSSM/,/PYSGCM/ +C...Local arrays and complex variables + DIMENSION WDTP(0:400),WDTE(0:400,0:5) + COMPLEX*16 A004,A204,A114,A00U,A20U,A11U + COMPLEX*16 CIGTOT,CIZTOT,F0ALP,F1ALP,F2ALP,F0BET,F1BET,F2BET,FIF + +C...Convert H or A process into equivalent h one + IHIGG=1 + KFHIGG=25 + IF(ISUB.EQ.401.OR.ISUB.EQ.402) THEN + KFHIGG=KFPR(ISUB,1) + END IF + IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND. + &ISUB.LE.190)) THEN + IHIGG=2 + IF(MOD(ISUB-1,10).GE.5) IHIGG=3 + KFHIGG=33+IHIGG + IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3 + IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102 + IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103 + IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24 + IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26 + IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123 + IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124 + IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121 + IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122 + IF(ISUB.EQ.183.OR.ISUB.EQ.188) ISUB=111 + IF(ISUB.EQ.184.OR.ISUB.EQ.189) ISUB=112 + IF(ISUB.EQ.185.OR.ISUB.EQ.190) ISUB=113 + ENDIF + SQMH=PMAS(KFHIGG,1)**2 + GMMH=PMAS(KFHIGG,1)*PMAS(KFHIGG,2) + +C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron + IF((MSTP(46).GE.3.AND.MSTP(46).LE.6).AND.(ISUB.EQ.71.OR.ISUB.EQ. + &72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.ISUB.EQ.77)) THEN +C...Calculate M_R and N_R functions for Higgs-like and QCD-like models + IF(MSTP(46).LE.4) THEN + HDTLH=LOG(PMAS(25,1)/PARP(44)) + HDTMR=(4.5D0*PARU(1)/SQRT(3D0)-74D0/9D0)/8D0+HDTLH/12D0 + HDTNR=-1D0/18D0+HDTLH/6D0 + ELSE + HDTNM=0.125D0*(1D0/(288D0*PARU(1)**2)+(PARP(47)/PARP(45))**2) + HDTLQ=LOG(PARP(45)/PARP(44)) + HDTMR=-(4D0*PARU(1))**2*0.5D0*HDTNM+HDTLQ/12D0 + HDTNR=(4D0*PARU(1))**2*HDTNM+HDTLQ/6D0 + ENDIF + +C...Calculate lowest and next-to-lowest order partial wave amplitudes + HDTV=1D0/(16D0*PARU(1)*PARP(47)**2) + A00L=DBLE(HDTV*SH) + A20L=-0.5D0*A00L + A11L=A00L/6D0 + HDTLS=LOG(SH/PARP(44)**2) + A004=DBLE((HDTV*SH)**2/(4D0*PARU(1)))* + & CMPLX(DBLE((176D0*HDTMR+112D0*HDTNR)/3D0+11D0/27D0- + & (50D0/9D0)*HDTLS),DBLE(4D0*PARU(1))) + A204=DBLE((HDTV*SH)**2/(4D0*PARU(1)))* + & CMPLX(DBLE(32D0*(HDTMR+2D0*HDTNR)/3D0+25D0/54D0- + & (20D0/9D0)*HDTLS),DBLE(PARU(1))) + A114=DBLE((HDTV*SH)**2/(6D0*PARU(1)))* + & CMPLX(DBLE(4D0*(-2D0*HDTMR+HDTNR)-1D0/18D0),DBLE(PARU(1)/6D0)) + +C...Unitarize partial wave amplitudes with Pade or K-matrix method + IF(MSTP(46).EQ.3.OR.MSTP(46).EQ.5) THEN + A00U=A00L/(1D0-A004/A00L) + A20U=A20L/(1D0-A204/A20L) + A11U=A11L/(1D0-A114/A11L) + ELSE + A00U=(A00L+DBLE(A004))/(1D0-DCMPLX(0.D0,A00L+DBLE(A004))) + A20U=(A20L+DBLE(A204))/(1D0-DCMPLX(0.D0,A20L+DBLE(A204))) + A11U=(A11L+DBLE(A114))/(1D0-DCMPLX(0.D0,A11L+DBLE(A114))) + ENDIF + ENDIF + +C...Differential cross section expressions. + + IF(ISUB.LE.60) THEN + IF(ISUB.EQ.3) THEN +C...f + fbar -> h0 (or H0, or A0) + CALL PYWIDT(KFHIGG,SH,WDTP,WDTE) + HS=SHR*WDTP(0) + FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2) + IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2)) + & FACBW=0D0 + HP=AEM/(8D0*XW)*SH/SQMW*SH + HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) + DO 100 I=MMINA,MMAXA + IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100 + IA=IABS(I) + RMQ=PYMRUN(IA,SH)**2/SH + HI=HP*RMQ + IF(IA.LE.10) HI=HP*RMQ*FACA/3D0 + IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN + IKFI=1 + IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2 + IF(IA.GT.10) IKFI=3 + HI=HI*PARU(150+10*IHIGG+IKFI)**2 + IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN + HI=HI/(1D0+RMSS(41))**2 + IF(IHIGG.NE.3) THEN + HI=HI*(1D0+RMSS(41)*PARU(152+10*IHIGG)/ + & PARU(151+10*IHIGG))**2 + ENDIF + ENDIF + ENDIF + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=HI*FACBW*HF + 100 CONTINUE + + ELSEIF(ISUB.EQ.5) THEN +C...Z0 + Z0 -> h0 + CALL PYWIDT(25,SH,WDTP,WDTE) + HS=SHR*WDTP(0) + FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2) + IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0 + HP=AEM/(8D0*XW)*SH/SQMW*SH + HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) + HI=HP/4D0 + FACI=8D0/(PARU(1)**2*XW1)*(AEM*XWC)**2 + DO 120 I=MMIN1,MMAX1 + IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120 + DO 110 J=MMIN2,MMAX2 + IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110 + EI=KCHG(IABS(I),1)/3D0 + AI=SIGN(1D0,EI) + VI=AI-4D0*EI*XWV + EJ=KCHG(IABS(J),1)/3D0 + AJ=SIGN(1D0,EJ) + VJ=AJ-4D0*EJ*XWV + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACI*(VI**2+AI**2)*(VJ**2+AJ**2)*HI*FACBW*HF + 110 CONTINUE + 120 CONTINUE + + ELSEIF(ISUB.EQ.8) THEN +C...W+ + W- -> h0 + CALL PYWIDT(25,SH,WDTP,WDTE) + HS=SHR*WDTP(0) + FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2) + IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0 + HP=AEM/(8D0*XW)*SH/SQMW*SH + HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) + HI=HP/2D0 + FACI=1D0/(4D0*PARU(1)**2)*(AEM/XW)**2 + DO 140 I=MMIN1,MMAX1 + IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 140 + EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1) + DO 130 J=MMIN2,MMAX2 + IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 130 + EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1) + IF(EI*EJ.GT.0D0) GOTO 130 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACI*VINT(180+I)*VINT(180+J)*HI*FACBW*HF + 130 CONTINUE + 140 CONTINUE + + ELSEIF(ISUB.EQ.24) THEN +C...f + fbar -> Z0 + h0 (or H0, or A0) +C...Propagators: Z0, h0 as simulated in PYOFSH and as desired + HBW3=GMMZ/((SQM3-SQMZ)**2+GMMZ**2) + CALL PYWIDT(23,SQM3,WDTP,WDTE) + GMMZ3=SQRT(SQM3)*WDTP(0) + HBW3C=GMMZ3/((SQM3-SQMZ)**2+GMMZ3**2) + HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2) + CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE) + GMMH4=SQRT(SQM4)*WDTP(0) + HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2) + THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2) + FACHZ=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)*8D0*(AEM*XWC)**2* + & (THUH+2D0*SH*SQM3)/((SH-SQMZ)**2+GMMZ**2) + FACHZ=FACHZ*WIDS(23,2)*WIDS(KFHIGG,2) + IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHZ=FACHZ* + & PARU(154+10*IHIGG)**2 + DO 150 I=MMINA,MMAXA + IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 150 + EI=KCHG(IABS(I),1)/3D0 + AI=SIGN(1D0,EI) + VI=AI-4D0*EI*XWV + FCOI=1D0 + IF(IABS(I).LE.10) FCOI=FACA/3D0 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACHZ*FCOI*(VI**2+AI**2) + 150 CONTINUE + + ELSEIF(ISUB.EQ.26) THEN +C...f + fbar' -> W+/- + h0 (or H0, or A0) +C...Propagators: W+-, h0 as simulated in PYOFSH and as desired + HBW3=GMMW/((SQM3-SQMW)**2+GMMW**2) + CALL PYWIDT(24,SQM3,WDTP,WDTE) + GMMW3=SQRT(SQM3)*WDTP(0) + HBW3C=GMMW3/((SQM3-SQMW)**2+GMMW3**2) + HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2) + CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE) + GMMH4=SQRT(SQM4)*WDTP(0) + HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2) + THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2) + FACHW=COMFAC*0.125D0*(AEM/XW)**2*(THUH+2D0*SH*SQM3)/ + & ((SH-SQMW)**2+GMMW**2)*(HBW3C/HBW3)*(HBW4C/HBW4) + FACHW=FACHW*WIDS(KFHIGG,2) + IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHW=FACHW* + & PARU(155+10*IHIGG)**2 + DO 170 I=MMIN1,MMAX1 + IA=IABS(I) + IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 170 + DO 160 J=MMIN2,MMAX2 + JA=IABS(J) + IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(1,J).EQ.0) GOTO 160 + IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 160 + IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10)) + & GOTO 160 + KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3 + FCKM=1D0 + IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2) + FCOI=1D0 + IF(IA.LE.10) FCOI=FACA/3D0 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACHW*FCOI*FCKM*WIDS(24,(5-KCHW)/2) + 160 CONTINUE + 170 CONTINUE + + ELSEIF(ISUB.EQ.32) THEN +C...f + g -> f + h0 (q + g -> q + h0 only) + FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24D0 +C...H propagator: as simulated in PYOFSH and as desired + SQMHC=PMAS(25,1)**2 + GMMHC=PMAS(25,1)*PMAS(25,2) + HBW4=GMMHC/((SQM4-SQMHC)**2+GMMHC**2) + CALL PYWIDT(25,SQM4,WDTP,WDTE) + GMMHCC=SQRT(SQM4)*WDTP(0) + HBW4C=GMMHCC/((SQM4-SQMHC)**2+GMMHCC**2) + FHCQ=FHCQ*HBW4C/HBW4 + DO 190 I=MMINA,MMAXA + IA=IABS(I) + IF(IA.NE.5) GOTO 190 + SQML=PYMRUN(IA,SH)**2 + SQMQ=PMAS(IA,1)**2 + FACHCQ=FHCQ*SQML/SQMW* + & (SH/(SQMQ-UH)+2D0*SQMQ*(SQM4-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH- + & 2D0*SQMQ/(SQMQ-UH)+2D0*(SQM4-UH)/(SQMQ-UH)* + & (SQM4-SQMQ-SH)/SH) + DO 180 ISDE=1,2 + IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 180 + IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 180 + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACHCQ*WIDS(25,2) + 180 CONTINUE + 190 CONTINUE + ENDIF + + ELSEIF(ISUB.LE.80) THEN + IF(ISUB.EQ.71) THEN +C...Z0 + Z0 -> Z0 + Z0 + IF(SH.LE.4.01D0*SQMZ) GOTO 220 + + IF(MSTP(46).LE.2) THEN +C...Exact scattering ME:s for on-mass-shell gauge bosons + BE2=1D0-4D0*SQMZ/SH + TH=-0.5D0*SH*BE2*(1D0-CTH) + UH=-0.5D0*SH*BE2*(1D0+CTH) + IF(MAX(TH,UH).GT.-1D0) GOTO 220 + SHANG=1D0/XW1*SQMW/SQMZ*(1D0+BE2)**2 + ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG + ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG + THANG=1D0/XW1*SQMW/SQMZ*(BE2-CTH)**2 + ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG + ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG + UHANG=1D0/XW1*SQMW/SQMZ*(BE2+CTH)**2 + AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG + AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG + FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)* + & (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2 + IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2) + IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATHRE+AUHRE)**2+ + & (ASHIM+ATHIM+AUHIM)**2) + IF(MSTP(46).EQ.2) FACZZ=0D0 + + ELSE +C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron + FACZZ=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)* + & ABS(A00U+2D0*A20U)**2 + ENDIF + FACZZ=FACZZ*WIDS(23,1) + + DO 210 I=MMIN1,MMAX1 + IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 210 + EI=KCHG(IABS(I),1)/3D0 + AI=SIGN(1D0,EI) + VI=AI-4D0*EI*XWV + AVI=AI**2+VI**2 + DO 200 J=MMIN2,MMAX2 + IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 200 + EJ=KCHG(IABS(J),1)/3D0 + AJ=SIGN(1D0,EJ) + VJ=AJ-4D0*EJ*XWV + AVJ=AJ**2+VJ**2 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + SIGH(NCHN)=0.5D0*FACZZ*AVI*AVJ + 200 CONTINUE + 210 CONTINUE + 220 CONTINUE + + ELSEIF(ISUB.EQ.72) THEN +C...Z0 + Z0 -> W+ + W- + IF(SH.LE.4.01D0*SQMZ) GOTO 250 + + IF(MSTP(46).LE.2) THEN +C...Exact scattering ME:s for on-mass-shell gauge bosons + BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH)) + CTH2=CTH**2 + TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH) + UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH) + IF(MAX(TH,UH).GT.-1D0) GOTO 250 + SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)* + & (1D0-2D0*SQMZ/SH) + ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG + ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG + ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0* + & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0* + & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2* + & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+ + & 2D0*(SQMW+SQMZ)/SH*BE2*CTH)) + ATWIM=0D0 + AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0* + & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0* + & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2* + & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2- + & 2D0*(SQMW+SQMZ)/SH*BE2*CTH)) + AUWIM=0D0 + A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH) + A4IM=0D0 + FACWW=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)* + & (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2 + IF(MSTP(46).LE.0) FACWW=FACWW*(ASHRE**2+ASHIM**2) + IF(MSTP(46).EQ.1) FACWW=FACWW*((ASHRE+ATWRE+AUWRE+A4RE)**2+ + & (ASHIM+ATWIM+AUWIM+A4IM)**2) + IF(MSTP(46).EQ.2) FACWW=FACWW*((ATWRE+AUWRE+A4RE)**2+ + & (ATWIM+AUWIM+A4IM)**2) + + ELSE +C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron + FACWW=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)* + & ABS(A00U-A20U)**2 + ENDIF + FACWW=FACWW*WIDS(24,1) + + DO 240 I=MMIN1,MMAX1 + IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 240 + EI=KCHG(IABS(I),1)/3D0 + AI=SIGN(1D0,EI) + VI=AI-4D0*EI*XWV + AVI=AI**2+VI**2 + DO 230 J=MMIN2,MMAX2 + IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 230 + EJ=KCHG(IABS(J),1)/3D0 + AJ=SIGN(1D0,EJ) + VJ=AJ-4D0*EJ*XWV + AVJ=AJ**2+VJ**2 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACWW*AVI*AVJ + 230 CONTINUE + 240 CONTINUE + 250 CONTINUE + + ELSEIF(ISUB.EQ.73) THEN +C...Z0 + W+/- -> Z0 + W+/- + IF(SH.LE.2D0*SQMZ+2D0*SQMW) GOTO 280 + + IF(MSTP(46).LE.2) THEN +C...Exact scattering ME:s for on-mass-shell gauge bosons + BE2=1D0-2D0*(SQMZ+SQMW)/SH+((SQMZ-SQMW)/SH)**2 + EP1=1D0-(SQMZ-SQMW)/SH + EP2=1D0+(SQMZ-SQMW)/SH + TH=-0.5D0*SH*BE2*(1D0-CTH) + UH=(SQMZ-SQMW)**2/SH-0.5D0*SH*BE2*(1D0+CTH) + IF(MAX(TH,UH).GT.-1D0) GOTO 280 + THANG=(BE2-EP1*CTH)*(BE2-EP2*CTH) + ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG + ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG + ASWRE=-XW1/SQMZ*SH/(SH-SQMW)*(-BE2*(EP1+EP2)**4*CTH+ + & 1D0/4D0*(BE2+EP1*EP2)**2*((EP1-EP2)**2-4D0*BE2*CTH)+ + & 2D0*BE2*(BE2+EP1*EP2)*(EP1+EP2)**2*CTH- + & 1D0/16D0*SH/SQMW*(EP1**2-EP2**2)**2*(BE2+EP1*EP2)**2) + ASWIM=0D0 + AUWRE=XW1/SQMZ*SH/(UH-SQMW)*(-BE2*(EP2+EP1*CTH)* + & (EP1+EP2*CTH)*(BE2+EP1*EP2)+BE2*(EP2+EP1*CTH)* + & (BE2+EP1*EP2*CTH)*(2D0*EP2-EP2*CTH+EP1)- + & BE2*(EP2+EP1*CTH)**2*(BE2-EP2**2*CTH)-1D0/8D0* + & (BE2+EP1*EP2*CTH)**2*((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+ + & 1D0/32D0*SH/SQMW*(BE2+EP1*EP2*CTH)**2* + & (EP1**2-EP2**2)**2-BE2*(EP1+EP2*CTH)*(EP2+EP1*CTH)* + & (BE2+EP1*EP2)+BE2*(EP1+EP2*CTH)*(BE2+EP1*EP2*CTH)* + & (2D0*EP1-EP1*CTH+EP2)-BE2*(EP1+EP2*CTH)**2* + & (BE2-EP1**2*CTH)-1D0/8D0*(BE2+EP1*EP2*CTH)**2* + & ((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+1D0/32D0*SH/SQMW* + & (BE2+EP1*EP2*CTH)**2*(EP1**2-EP2**2)**2) + AUWIM=0D0 + A4RE=XW1/SQMZ*(EP1**2*EP2**2*(CTH**2-1D0)- + & 2D0*BE2*(EP1**2+EP2**2+EP1*EP2)*CTH-2D0*BE2*EP1*EP2) + A4IM=0D0 + FACZW=COMFAC*1D0/(4096D0*PARU(1)**2*4D0*XW1)*(AEM/XW)**4* + & (SH/SQMW)**2*SQRT(SQMZ/SQMW)*SH2 + IF(MSTP(46).LE.0) FACZW=0D0 + IF(MSTP(46).EQ.1) FACZW=FACZW*((ATHRE+ASWRE+AUWRE+A4RE)**2+ + & (ATHIM+ASWIM+AUWIM+A4IM)**2) + IF(MSTP(46).EQ.2) FACZW=FACZW*((ASWRE+AUWRE+A4RE)**2+ + & (ASWIM+AUWIM+A4IM)**2) + + ELSE +C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron + FACZW=COMFAC*AEM**2/(64D0*PARU(1)**2*XW**2*XW1)*16D0* + & ABS(A20U+3D0*A11U*DBLE(CTH))**2 + ENDIF + FACZW=FACZW*WIDS(23,2) + + DO 270 I=MMIN1,MMAX1 + IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 270 + EI=KCHG(IABS(I),1)/3D0 + AI=SIGN(1D0,EI) + VI=AI-4D0*EI*XWV + AVI=AI**2+VI**2 + KCHWI=ISIGN(1,KCHG(IABS(I),1)*ISIGN(1,I)) + DO 260 J=MMIN2,MMAX2 + IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 260 + EJ=KCHG(IABS(J),1)/3D0 + AJ=SIGN(1D0,EJ) + VJ=AI-4D0*EJ*XWV + AVJ=AJ**2+VJ**2 + KCHWJ=ISIGN(1,KCHG(IABS(J),1)*ISIGN(1,J)) + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACZW*AVI*VINT(180+J)*WIDS(24,(5-KCHWJ)/2) + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=2 + SIGH(NCHN)=FACZW*VINT(180+I)*WIDS(24,(5-KCHWI)/2)*AVJ + 260 CONTINUE + 270 CONTINUE + 280 CONTINUE + + ELSEIF(ISUB.EQ.75) THEN +C...W+ + W- -> gamma + gamma + + ELSEIF(ISUB.EQ.76) THEN +C...W+ + W- -> Z0 + Z0 + IF(SH.LE.4.01D0*SQMZ) GOTO 310 + + IF(MSTP(46).LE.2) THEN +C...Exact scattering ME:s for on-mass-shell gauge bosons + BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH)) + CTH2=CTH**2 + TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH) + UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH) + IF(MAX(TH,UH).GT.-1D0) GOTO 310 + SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)* + & (1D0-2D0*SQMZ/SH) + ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG + ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG + ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0* + & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0* + & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2* + & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+ + & 2D0*(SQMW+SQMZ)/SH*BE2*CTH)) + ATWIM=0D0 + AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0* + & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0* + & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2* + & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2- + & 2D0*(SQMW+SQMZ)/SH*BE2*CTH)) + AUWIM=0D0 + A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH) + A4IM=0D0 + FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4* + & (SH/SQMW)**2*SH2 + IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2) + IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATWRE+AUWRE+A4RE)**2+ + & (ASHIM+ATWIM+AUWIM+A4IM)**2) + IF(MSTP(46).EQ.2) FACZZ=FACZZ*((ATWRE+AUWRE+A4RE)**2+ + & (ATWIM+AUWIM+A4IM)**2) + + ELSE +C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron + FACZZ=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)* + & ABS(A00U-A20U)**2 + ENDIF + FACZZ=FACZZ*WIDS(23,1) + + DO 300 I=MMIN1,MMAX1 + IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 300 + EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1) + DO 290 J=MMIN2,MMAX2 + IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 290 + EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1) + IF(EI*EJ.GT.0D0) GOTO 290 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + SIGH(NCHN)=0.5D0*FACZZ*VINT(180+I)*VINT(180+J) + 290 CONTINUE + 300 CONTINUE + 310 CONTINUE + + ELSEIF(ISUB.EQ.77) THEN +C...W+/- + W+/- -> W+/- + W+/- + IF(SH.LE.4.01D0*SQMW) GOTO 340 + + IF(MSTP(46).LE.2) THEN +C...Exact scattering ME:s for on-mass-shell gauge bosons + BE2=1D0-4D0*SQMW/SH + BE4=BE2**2 + CTH2=CTH**2 + CTH3=CTH**3 + TH=-0.5D0*SH*BE2*(1D0-CTH) + UH=-0.5D0*SH*BE2*(1D0+CTH) + IF(MAX(TH,UH).GT.-1D0) GOTO 340 + SHANG=(1D0+BE2)**2 + ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG + ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG + THANG=(BE2-CTH)**2 + ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG + ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG + UHANG=(BE2+CTH)**2 + AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG + AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG + SGZANG=1D0/SQMW*BE2*(3D0-BE2)**2*CTH + ASGRE=XW*SGZANG + ASGIM=0D0 + ASZRE=XW1*SH/(SH-SQMZ)*SGZANG + ASZIM=0D0 + TGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)+BE2*(4D0-10D0*BE2+ + & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2+BE2*CTH3) + ATGRE=0.5D0*XW*SH/TH*TGZANG + ATGIM=0D0 + ATZRE=0.5D0*XW1*SH/(TH-SQMZ)*TGZANG + ATZIM=0D0 + UGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)-BE2*(4D0-10D0*BE2+ + & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2-BE2*CTH3) + AUGRE=0.5D0*XW*SH/UH*UGZANG + AUGIM=0D0 + AUZRE=0.5D0*XW1*SH/(UH-SQMZ)*UGZANG + AUZIM=0D0 + A4ARE=1D0/SQMW*(1D0+2D0*BE2-6D0*BE2*CTH-CTH2) + A4AIM=0D0 + A4SRE=2D0/SQMW*(1D0+2D0*BE2-CTH2) + A4SIM=0D0 + FWW=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4* + & (SH/SQMW)**2*SH2 + IF(MSTP(46).LE.0) THEN + AWWARE=ASHRE + AWWAIM=ASHIM + AWWSRE=0D0 + AWWSIM=0D0 + ELSEIF(MSTP(46).EQ.1) THEN + AWWARE=ASHRE+ATHRE+ASGRE+ASZRE+ATGRE+ATZRE+A4ARE + AWWAIM=ASHIM+ATHIM+ASGIM+ASZIM+ATGIM+ATZIM+A4AIM + AWWSRE=-ATHRE-AUHRE+ATGRE+ATZRE+AUGRE+AUZRE+A4SRE + AWWSIM=-ATHIM-AUHIM+ATGIM+ATZIM+AUGIM+AUZIM+A4SIM + ELSE + AWWARE=ASGRE+ASZRE+ATGRE+ATZRE+A4ARE + AWWAIM=ASGIM+ASZIM+ATGIM+ATZIM+A4AIM + AWWSRE=ATGRE+ATZRE+AUGRE+AUZRE+A4SRE + AWWSIM=ATGIM+ATZIM+AUGIM+AUZIM+A4SIM + ENDIF + AWWA2=AWWARE**2+AWWAIM**2 + AWWS2=AWWSRE**2+AWWSIM**2 + + ELSE +C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron + FWWA=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)* + & ABS(A00U+0.5D0*A20U+4.5D0*A11U*DBLE(CTH))**2 + FWWS=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*64D0*ABS(A20U)**2 + ENDIF + + DO 330 I=MMIN1,MMAX1 + IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 330 + EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1) + DO 320 J=MMIN2,MMAX2 + IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 320 + EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1) + IF(EI*EJ.LT.0D0) THEN +C...W+W- + IF(MSTP(45).EQ.1) GOTO 320 + IF(MSTP(46).LE.2) FACWW=FWW*AWWA2*WIDS(24,1) + IF(MSTP(46).GE.3) FACWW=FWWA*WIDS(24,1) + ELSE +C...W+W+/W-W- + IF(MSTP(45).EQ.2) GOTO 320 + IF(MSTP(46).LE.2) FACWW=FWW*AWWS2 + IF(MSTP(46).GE.3) FACWW=FWWS + IF(EI.GT.0D0) FACWW=FACWW*WIDS(24,4) + IF(EI.LT.0D0) FACWW=FACWW*WIDS(24,5) + ENDIF + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACWW*VINT(180+I)*VINT(180+J) + IF(EI*EJ.GT.0D0) SIGH(NCHN)=0.5D0*SIGH(NCHN) + 320 CONTINUE + 330 CONTINUE + 340 CONTINUE + ENDIF + + ELSEIF(ISUB.LE.120) THEN + IF(ISUB.EQ.102) THEN +C...g + g -> h0 (or H0, or A0) + CALL PYWIDT(KFHIGG,SH,WDTP,WDTE) + HS=SHR*WDTP(0) + HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) + FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2) + IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2)) + & FACBW=0D0 +C...PS: Only use fixed-width when using SLHA decay table for this Higgs + IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN + WDTP13=0D0 + DO 345 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1 + IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND. + & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC) + 345 CONTINUE + IF(WDTP13.EQ.0D0) CALL PYERRM(26, + & '(PYSGHG:) did not find Higgs -> g g channel') + HI=SHR*WDTP13/32D0 + ELSE + HI=SHR*WDTP(13)/32D0 + ENDIF + IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 350 + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=HI*FACBW*HF + 350 CONTINUE + + ELSEIF(ISUB.EQ.103) THEN +C...gamma + gamma -> h0 (or H0, or A0) + CALL PYWIDT(KFHIGG,SH,WDTP,WDTE) + HS=SHR*WDTP(0) + HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) + FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2) + IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2)) + & FACBW=0D0 +C...PS: Only use fixed-width when using SLHA decay table for this Higgs + IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN + WDTP14=0D0 + DO 355 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1 + IF(KFDP(IDC,1).EQ.22.AND.KFDP(IDC,2).EQ.22.AND. + & KFDP(IDC,3).EQ.0) WDTP14=PMAS(KFHIGG,2)*BRAT(IDC) + 355 CONTINUE + IF(WDTP14.EQ.0D0) CALL PYERRM(26, + & '(PYSGHG:) did not find Higgs -> gamma gamma channel') + HI=SHR*WDTP14*2D0 + ELSE + HI=SHR*WDTP(14)*2D0 + ENDIF + IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 360 + NCHN=NCHN+1 + ISIG(NCHN,1)=22 + ISIG(NCHN,2)=22 + ISIG(NCHN,3)=1 + SIGH(NCHN)=HI*FACBW*HF + 360 CONTINUE + + ELSEIF(ISUB.EQ.110) THEN +C...f + fbar -> gamma + h0 + THUH=MAX(TH*UH,SH*CKIN(3)**2) + FACHG=COMFAC*(3D0*AEM**4)/(2D0*PARU(1)**2*XW*SQMW)*SH*THUH + FACHG=FACHG*WIDS(KFHIGG,2) +C...Calculate loop contributions for intermediate gamma* and Z0 + CIGTOT=DCMPLX(0D0,0D0) + CIZTOT=DCMPLX(0D0,0D0) + JMAX=3*MSTP(1)+1 + DO 370 J=1,JMAX + IF(J.LE.2*MSTP(1)) THEN + FNC=1D0 + EJ=KCHG(J,1)/3D0 + AJ=SIGN(1D0,EJ+0.1D0) + VJ=AJ-4D0*EJ*XWV + BALP=SQM4/(2D0*PMAS(J,1))**2 + BBET=SH/(2D0*PMAS(J,1))**2 + ELSEIF(J.LE.3*MSTP(1)) THEN + FNC=3D0 + JL=2*(J-2*MSTP(1))-1 + EJ=KCHG(10+JL,1)/3D0 + AJ=SIGN(1D0,EJ+0.1D0) + VJ=AJ-4D0*EJ*XWV + BALP=SQM4/(2D0*PMAS(10+JL,1))**2 + BBET=SH/(2D0*PMAS(10+JL,1))**2 + ELSE + BALP=SQM4/(2D0*PMAS(24,1))**2 + BBET=SH/(2D0*PMAS(24,1))**2 + ENDIF + BABI=1D0/(BALP-BBET) + IF(BALP.LT.1D0) THEN + F0ALP=DCMPLX(DBLE(ASIN(SQRT(BALP))),0D0) + F1ALP=F0ALP**2 + ELSE + F0ALP=DCMPLX(DBLE(LOG(SQRT(BALP)+SQRT(BALP-1D0))), + & -DBLE(0.5D0*PARU(1))) + F1ALP=-F0ALP**2 + ENDIF + F2ALP=DBLE(SQRT(ABS(BALP-1D0)/BALP))*F0ALP + IF(BBET.LT.1D0) THEN + F0BET=DCMPLX(DBLE(ASIN(SQRT(BBET))),0D0) + F1BET=F0BET**2 + ELSE + F0BET=DCMPLX(DBLE(LOG(SQRT(BBET)+SQRT(BBET-1D0))), + & -DBLE(0.5D0*PARU(1))) + F1BET=-F0BET**2 + ENDIF + F2BET=DBLE(SQRT(ABS(BBET-1D0)/BBET))*F0BET + IF(J.LE.3*MSTP(1)) THEN + FIF=DBLE(0.5D0*BABI)+DBLE(BABI**2)*(DBLE(0.5D0*(1D0-BALP+ + & BBET))*(F1BET-F1ALP)+DBLE(BBET)*(F2BET-F2ALP)) + CIGTOT=CIGTOT+DBLE(FNC*EJ**2)*FIF + CIZTOT=CIZTOT+DBLE(FNC*EJ*VJ)*FIF + ELSE + TXW=XW/XW1 + CIGTOT=CIGTOT-0.5*(DBLE(BABI*(1.5D0+BALP))+DBLE(BABI**2)* + & (DBLE(1.5D0-3D0*BALP+4D0*BBET)*(F1BET-F1ALP)+ + & DBLE(BBET*(2D0*BALP+3D0))*(F2BET-F2ALP))) + CIZTOT=CIZTOT-DBLE(0.5D0*BABI*XW1)*(DBLE(5D0-TXW+2D0*BALP* + & (1D0-TXW))*(1D0+DBLE(2D0*BABI*BBET)*(F2BET-F2ALP))+ + & DBLE(BABI*(4D0*BBET*(3D0-TXW)-(2D0*BALP-1D0)*(5D0-TXW)))* + & (F1BET-F1ALP)) + ENDIF + 370 CONTINUE + CIGTOT=CIGTOT/DBLE(SH) + CIZTOT=CIZTOT*DBLE(XWC)/DCMPLX(DBLE(SH-SQMZ),DBLE(GMMZ)) +C...Loop over initial flavours + DO 380 I=MMINA,MMAXA + IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 380 + EI=KCHG(IABS(I),1)/3D0 + AI=SIGN(1D0,EI) + VI=AI-4D0*EI*XWV + FCOI=1D0 + IF(IABS(I).LE.10) FCOI=FACA/3D0 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACHG*FCOI*(ABS(DBLE(EI)*CIGTOT+DBLE(VI)* + & CIZTOT)**2+AI**2*ABS(CIZTOT)**2) + 380 CONTINUE + + ELSEIF(ISUB.EQ.111) THEN +C...f + fbar -> g + h0 (q + qbar -> g + h0 only) + IF(MSTP(38).NE.0) THEN +C...Simple case: only do gg <-> h exactly. + CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE) +C...PS: Only use fixed-width when using SLHA decay table for this Higgs + IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN + WDTP13=0D0 + DO 385 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1 + IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND. + & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC) + 385 CONTINUE + IF(WDTP13.EQ.0D0) CALL PYERRM(26, + & '(PYSGHG:) did not find Higgs -> g g channel') + FACGH=COMFAC*FACA*(2D0/9D0)*AS*(WDTP13/SQRT(SQM4))* + & (TH**2+UH**2)/(SH*SQM4) + ELSE + FACGH=COMFAC*FACA*(2D0/9D0)*AS*(WDTP(13)/SQRT(SQM4))* + & (TH**2+UH**2)/(SH*SQM4) + ENDIF +C...Propagators: as simulated in PYOFSH and as desired + HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2) + GMMHC=SQRT(SQM4)*WDTP(0) + HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/ + & ((SQM4-SQMH)**2+GMMHC**2) + FACGH=FACGH*HBW4C/HBW4 + ELSE +C...Messy case: do full loop integrals + A5STUR=0D0 + A5STUI=0D0 + DO 390 I=1,2*MSTP(1) + SQMQ=PMAS(I,1)**2 + EPSS=4D0*SQMQ/SH + EPSH=4D0*SQMQ/SQMH + CALL PYWAUX(1,EPSS,W1SR,W1SI) + CALL PYWAUX(1,EPSH,W1HR,W1HI) + CALL PYWAUX(2,EPSS,W2SR,W2SI) + CALL PYWAUX(2,EPSH,W2HR,W2HI) + A5STUR=A5STUR+EPSH*(1D0+SH/(TH+UH)*(W1SR-W1HR)+ + & (0.25D0-SQMQ/(TH+UH))*(W2SR-W2HR)) + A5STUI=A5STUI+EPSH*(SH/(TH+UH)*(W1SI-W1HI)+ + & (0.25D0-SQMQ/(TH+UH))*(W2SI-W2HI)) + 390 CONTINUE + FACGH=COMFAC*FACA/(144D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW* + & SQMH/SH*(UH**2+TH**2)/(UH+TH)**2*(A5STUR**2+A5STUI**2) + FACGH=FACGH*WIDS(25,2) + ENDIF + DO 400 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR. + & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACGH + 400 CONTINUE + + ELSEIF(ISUB.EQ.112) THEN +C...f + g -> f + h0 (q + g -> q + h0 only) + IF(MSTP(38).NE.0) THEN +C...Simple case: only do gg <-> h exactly. + CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE) +C...PS: Only use fixed-width when using SLHA decay table for this Higgs + IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN + WDTP13=0D0 + DO 405 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1 + IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND. + & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC) + 405 CONTINUE + IF(WDTP13.EQ.0D0) CALL PYERRM(26, + & '(PYSGHG:) did not find Higgs -> g g channel') + FACQH=COMFAC*FACA*(1D0/12D0)*AS*(WDTP13/SQRT(SQM4))* + & (SH**2+UH**2)/(-TH*SQM4) + ELSE + FACQH=COMFAC*FACA*(1D0/12D0)*AS*(WDTP(13)/SQRT(SQM4))* + & (SH**2+UH**2)/(-TH*SQM4) + ENDIF +C...Propagators: as simulated in PYOFSH and as desired + HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2) + GMMHC=SQRT(SQM4)*WDTP(0) + HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/ + & ((SQM4-SQMH)**2+GMMHC**2) + FACQH=FACQH*HBW4C/HBW4 + ELSE +C...Messy case: do full loop integrals + A5TSUR=0D0 + A5TSUI=0D0 + DO 410 I=1,2*MSTP(1) + SQMQ=PMAS(I,1)**2 + EPST=4D0*SQMQ/TH + EPSH=4D0*SQMQ/SQMH + CALL PYWAUX(1,EPST,W1TR,W1TI) + CALL PYWAUX(1,EPSH,W1HR,W1HI) + CALL PYWAUX(2,EPST,W2TR,W2TI) + CALL PYWAUX(2,EPSH,W2HR,W2HI) + A5TSUR=A5TSUR+EPSH*(1D0+TH/(SH+UH)*(W1TR-W1HR)+ + & (0.25D0-SQMQ/(SH+UH))*(W2TR-W2HR)) + A5TSUI=A5TSUI+EPSH*(TH/(SH+UH)*(W1TI-W1HI)+ + & (0.25D0-SQMQ/(SH+UH))*(W2TI-W2HI)) + 410 CONTINUE + FACQH=COMFAC*FACA/(384D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW* + & SQMH/(-TH)*(UH**2+SH**2)/(UH+SH)**2*(A5TSUR**2+A5TSUI**2) + FACQH=FACQH*WIDS(25,2) + ENDIF + DO 430 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 430 + DO 420 ISDE=1,2 + IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 420 + IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 420 + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQH + 420 CONTINUE + 430 CONTINUE + + ELSEIF(ISUB.EQ.113) THEN +C...g + g -> g + h0 + IF(MSTP(38).NE.0) THEN +C...Simple case: only do gg <-> h exactly. + CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE) +C...PS: Only use fixed-width when using SLHA decay table for this Higgs + IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN + WDTP13=0D0 + DO 435 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1 + IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND. + & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC) + 435 CONTINUE + IF(WDTP13.EQ.0D0) CALL PYERRM(26, + & '(PYSGHG:) did not find Higgs -> g g channel') + FACGH=COMFAC*FACA*(3D0/16D0)*AS*(WDTP13/SQRT(SQM4))* + & (SH**4+TH**4+UH**4+SQM4**4)/(SH*TH*UH*SQM4) + ELSE + FACGH=COMFAC*FACA*(3D0/16D0)*AS*(WDTP(13)/SQRT(SQM4))* + & (SH**4+TH**4+UH**4+SQM4**4)/(SH*TH*UH*SQM4) + ENDIF +C...Propagators: as simulated in PYOFSH and as desired + HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2) + GMMHC=SQRT(SQM4)*WDTP(0) + HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/ + & ((SQM4-SQMH)**2+GMMHC**2) + FACGH=FACGH*HBW4C/HBW4 + ELSE +C...Messy case: do full loop integrals + A2STUR=0D0 + A2STUI=0D0 + A2USTR=0D0 + A2USTI=0D0 + A2TUSR=0D0 + A2TUSI=0D0 + A4STUR=0D0 + A4STUI=0D0 + DO 440 I=1,2*MSTP(1) + SQMQ=PMAS(I,1)**2 + EPSS=4D0*SQMQ/SH + EPST=4D0*SQMQ/TH + EPSU=4D0*SQMQ/UH + EPSH=4D0*SQMQ/SQMH + IF(EPSH.LT.1D-6) GOTO 440 + CALL PYWAUX(1,EPSS,W1SR,W1SI) + CALL PYWAUX(1,EPST,W1TR,W1TI) + CALL PYWAUX(1,EPSU,W1UR,W1UI) + CALL PYWAUX(1,EPSH,W1HR,W1HI) + CALL PYWAUX(2,EPSS,W2SR,W2SI) + CALL PYWAUX(2,EPST,W2TR,W2TI) + CALL PYWAUX(2,EPSU,W2UR,W2UI) + CALL PYWAUX(2,EPSH,W2HR,W2HI) + CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI) + CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI) + CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI) + CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI) + CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI) + CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI) + CALL PYI3AU(EPSH,SQMH/SH*TH/UH,YHSTUR,YHSTUI) + CALL PYI3AU(EPSH,SQMH/SH*UH/TH,YHSUTR,YHSUTI) + CALL PYI3AU(EPSH,SQMH/TH*SH/UH,YHTSUR,YHTSUI) + CALL PYI3AU(EPSH,SQMH/TH*UH/SH,YHTUSR,YHTUSI) + CALL PYI3AU(EPSH,SQMH/UH*SH/TH,YHUSTR,YHUSTI) + CALL PYI3AU(EPSH,SQMH/UH*TH/SH,YHUTSR,YHUTSI) + W3STUR=YHSTUR-Y3STUR-Y3UTSR + W3STUI=YHSTUI-Y3STUI-Y3UTSI + W3SUTR=YHSUTR-Y3SUTR-Y3TUSR + W3SUTI=YHSUTI-Y3SUTI-Y3TUSI + W3TSUR=YHTSUR-Y3TSUR-Y3USTR + W3TSUI=YHTSUI-Y3TSUI-Y3USTI + W3TUSR=YHTUSR-Y3TUSR-Y3SUTR + W3TUSI=YHTUSI-Y3TUSI-Y3SUTI + W3USTR=YHUSTR-Y3USTR-Y3TSUR + W3USTI=YHUSTI-Y3USTI-Y3TSUI + W3UTSR=YHUTSR-Y3UTSR-Y3STUR + W3UTSI=YHUTSI-Y3UTSI-Y3STUI + B2STUR=SQMQ/SQMH**2*(SH*(UH-SH)/(SH+UH)+2D0*TH*UH* + & (UH+2D0*SH)/(SH+UH)**2*(W1TR-W1HR)+(SQMQ-SH/4D0)* + & (0.5D0*W2SR+0.5D0*W2HR-W2TR+W3STUR)+SH2*(2D0*SQMQ/ + & (SH+UH)**2-0.5D0/(SH+UH))*(W2TR-W2HR)+0.5D0*TH*UH/SH* + & (W2HR-2D0*W2TR)+0.125D0*(SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUR) + B2STUI=SQMQ/SQMH**2*(2D0*TH*UH*(UH+2D0*SH)/(SH+UH)**2* + & (W1TI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2TI+ + & W3STUI)+SH2*(2D0*SQMQ/(SH+UH)**2-0.5D0/(SH+UH))* + & (W2TI-W2HI)+0.5D0*TH*UH/SH*(W2HI-2D0*W2TI)+0.125D0* + & (SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUI) + B2SUTR=SQMQ/SQMH**2*(SH*(TH-SH)/(SH+TH)+2D0*UH*TH* + & (TH+2D0*SH)/(SH+TH)**2*(W1UR-W1HR)+(SQMQ-SH/4D0)* + & (0.5D0*W2SR+0.5D0*W2HR-W2UR+W3SUTR)+SH2*(2D0*SQMQ/ + & (SH+TH)**2-0.5D0/(SH+TH))*(W2UR-W2HR)+0.5D0*UH*TH/SH* + & (W2HR-2D0*W2UR)+0.125D0*(SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTR) + B2SUTI=SQMQ/SQMH**2*(2D0*UH*TH*(TH+2D0*SH)/(SH+TH)**2* + & (W1UI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2UI+ + & W3SUTI)+SH2*(2D0*SQMQ/(SH+TH)**2-0.5D0/(SH+TH))* + & (W2UI-W2HI)+0.5D0*UH*TH/SH*(W2HI-2D0*W2UI)+0.125D0* + & (SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTI) + B2TSUR=SQMQ/SQMH**2*(TH*(UH-TH)/(TH+UH)+2D0*SH*UH* + & (UH+2D0*TH)/(TH+UH)**2*(W1SR-W1HR)+(SQMQ-TH/4D0)* + & (0.5D0*W2TR+0.5D0*W2HR-W2SR+W3TSUR)+TH2*(2D0*SQMQ/ + & (TH+UH)**2-0.5D0/(TH+UH))*(W2SR-W2HR)+0.5D0*SH*UH/TH* + & (W2HR-2D0*W2SR)+0.125D0*(TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUR) + B2TSUI=SQMQ/SQMH**2*(2D0*SH*UH*(UH+2D0*TH)/(TH+UH)**2* + & (W1SI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2SI+ + & W3TSUI)+TH2*(2D0*SQMQ/(TH+UH)**2-0.5D0/(TH+UH))* + & (W2SI-W2HI)+0.5D0*SH*UH/TH*(W2HI-2D0*W2SI)+0.125D0* + & (TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUI) + B2TUSR=SQMQ/SQMH**2*(TH*(SH-TH)/(TH+SH)+2D0*UH*SH* + & (SH+2D0*TH)/(TH+SH)**2*(W1UR-W1HR)+(SQMQ-TH/4D0)* + & (0.5D0*W2TR+0.5D0*W2HR-W2UR+W3TUSR)+TH2*(2D0*SQMQ/ + & (TH+SH)**2-0.5D0/(TH+SH))*(W2UR-W2HR)+0.5D0*UH*SH/TH* + & (W2HR-2D0*W2UR)+0.125D0*(TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSR) + B2TUSI=SQMQ/SQMH**2*(2D0*UH*SH*(SH+2D0*TH)/(TH+SH)**2* + & (W1UI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2UI+ + & W3TUSI)+TH2*(2D0*SQMQ/(TH+SH)**2-0.5D0/(TH+SH))* + & (W2UI-W2HI)+0.5D0*UH*SH/TH*(W2HI-2D0*W2UI)+0.125D0* + & (TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSI) + B2USTR=SQMQ/SQMH**2*(UH*(TH-UH)/(UH+TH)+2D0*SH*TH* + & (TH+2D0*UH)/(UH+TH)**2*(W1SR-W1HR)+(SQMQ-UH/4D0)* + & (0.5D0*W2UR+0.5D0*W2HR-W2SR+W3USTR)+UH2*(2D0*SQMQ/ + & (UH+TH)**2-0.5D0/(UH+TH))*(W2SR-W2HR)+0.5D0*SH*TH/UH* + & (W2HR-2D0*W2SR)+0.125D0*(UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTR) + B2USTI=SQMQ/SQMH**2*(2D0*SH*TH*(TH+2D0*UH)/(UH+TH)**2* + & (W1SI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2SI+ + & W3USTI)+UH2*(2D0*SQMQ/(UH+TH)**2-0.5D0/(UH+TH))* + & (W2SI-W2HI)+0.5D0*SH*TH/UH*(W2HI-2D0*W2SI)+0.125D0* + & (UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTI) + B2UTSR=SQMQ/SQMH**2*(UH*(SH-UH)/(UH+SH)+2D0*TH*SH* + & (SH+2D0*UH)/(UH+SH)**2*(W1TR-W1HR)+(SQMQ-UH/4D0)* + & (0.5D0*W2UR+0.5D0*W2HR-W2TR+W3UTSR)+UH2*(2D0*SQMQ/ + & (UH+SH)**2-0.5D0/(UH+SH))*(W2TR-W2HR)+0.5D0*TH*SH/UH* + & (W2HR-2D0*W2TR)+0.125D0*(UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSR) + B2UTSI=SQMQ/SQMH**2*(2D0*TH*SH*(SH+2D0*UH)/(UH+SH)**2* + & (W1TI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2TI+ + & W3UTSI)+UH2*(2D0*SQMQ/(UH+SH)**2-0.5D0/(UH+SH))* + & (W2TI-W2HI)+0.5D0*TH*SH/UH*(W2HI-2D0*W2TI)+0.125D0* + & (UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSI) + B4STUR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)* + & (W2SR-W2HR+W3STUR)) + B4STUI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2SI-W2HI+W3STUI) + B4TUSR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)* + & (W2TR-W2HR+W3TUSR)) + B4TUSI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2TI-W2HI+W3TUSI) + B4USTR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)* + & (W2UR-W2HR+W3USTR)) + B4USTI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2UI-W2HI+W3USTI) + A2STUR=A2STUR+B2STUR+B2SUTR + A2STUI=A2STUI+B2STUI+B2SUTI + A2USTR=A2USTR+B2USTR+B2UTSR + A2USTI=A2USTI+B2USTI+B2UTSI + A2TUSR=A2TUSR+B2TUSR+B2TSUR + A2TUSI=A2TUSI+B2TUSI+B2TSUI + A4STUR=A4STUR+B4STUR+B4USTR+B4TUSR + A4STUI=A4STUI+B4STUI+B4USTI+B4TUSI + 440 CONTINUE + FACGH=COMFAC*FACA*3D0/(128D0*PARU(1)**2)*AEM/XW*AS**3* + & SQMH/SQMW*SQMH**3/(SH*TH*UH)*(A2STUR**2+A2STUI**2+A2USTR**2+ + & A2USTI**2+A2TUSR**2+A2TUSI**2+A4STUR**2+A4STUI**2) + FACGH=FACGH*WIDS(25,2) + ENDIF + IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 450 + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACGH + 450 CONTINUE + ENDIF + + ELSEIF(ISUB.LE.170) THEN + IF(ISUB.EQ.121) THEN +C...g + g -> Q + Qbar + h0 + IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 460 + IA=KFPR(ISUBSV,2) + PMF=PYMRUN(IA,SH) + FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2* + & (0.5D0*PMF/PMAS(24,1))**2 + WID2=1D0 + IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1) + FACQQH=FACQQH*WID2 + IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN + IKFI=1 + IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2 + IF(IA.GT.10) IKFI=3 + FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2 + IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN + FACQQH=FACQQH/(1D0+RMSS(41))**2 + IF(IHIGG.NE.3) THEN + FACQQH=FACQQH*(1D0+RMSS(41)*PARU(152+10*IHIGG)/ + & PARU(151+10*IHIGG))**2 + ENDIF + ENDIF + ENDIF + CALL PYQQBH(WTQQBH) + CALL PYWIDT(KFHIGG,SH,WDTP,WDTE) + HS=SHR*WDTP(0) + HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) + FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2) + IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2)) + & FACBW=0D0 + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQH*WTQQBH*FACBW + 460 CONTINUE + + ELSEIF(ISUB.EQ.122) THEN +C...q + qbar -> Q + Qbar + h0 + IA=KFPR(ISUBSV,2) + PMF=PYMRUN(IA,SH) + FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2* + & (0.5D0*PMF/PMAS(24,1))**2 + WID2=1D0 + IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1) + FACQQH=FACQQH*WID2 + IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN + IKFI=1 + IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2 + IF(IA.GT.10) IKFI=3 + FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2 + IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN + FACQQH=FACQQH/(1D0+RMSS(41))**2 + IF(IHIGG.NE.3) THEN + FACQQH=FACQQH*(1D0+RMSS(41)*PARU(152+10*IHIGG)/ + & PARU(151+10*IHIGG))**2 + ENDIF + ENDIF + ENDIF + CALL PYQQBH(WTQQBH) + CALL PYWIDT(KFHIGG,SH,WDTP,WDTE) + HS=SHR*WDTP(0) + HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) + FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2) + IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2)) + & FACBW=0D0 + DO 470 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR. + & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 470 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQH*WTQQBH*FACBW + 470 CONTINUE + + ELSEIF(ISUB.EQ.123) THEN +C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as +C...inner process) + FACNOR=COMFAC*(4D0*PARU(1)*AEM/(XW*XW1))**3*SQMZ/32D0 + IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR* + & PARU(154+10*IHIGG)**2 + FACPRP=1D0/((VINT(215)-VINT(204)**2)* + & (VINT(216)-VINT(209)**2))**2 + FACZZ1=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219) + FACZZ2=FACNOR*FACPRP*VINT(217)*VINT(218) + CALL PYWIDT(KFHIGG,SH,WDTP,WDTE) + HS=SHR*WDTP(0) + HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) + FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2) + IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2)) + & FACBW=0D0 + DO 490 I=MMIN1,MMAX1 + IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 490 + IA=IABS(I) + DO 480 J=MMIN2,MMAX2 + IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 480 + JA=IABS(J) + EI=KCHG(IA,1)*ISIGN(1,I)/3D0 + AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I) + VI=AI-4D0*EI*XWV + EJ=KCHG(JA,1)*ISIGN(1,J)/3D0 + AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J) + VJ=AJ-4D0*EJ*XWV + FACLR1=(VI**2+AI**2)*(VJ**2+AJ**2)+4D0*VI*AI*VJ*AJ + FACLR2=(VI**2+AI**2)*(VJ**2+AJ**2)-4D0*VI*AI*VJ*AJ + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + SIGH(NCHN)=(FACLR1*FACZZ1+FACLR2*FACZZ2)*FACBW + 480 CONTINUE + 490 CONTINUE + + ELSEIF(ISUB.EQ.124) THEN +C...f + f' -> f" + f"' + h0 (or H0, or A0) (W+ + W- -> h0 as +C...inner process) + FACNOR=COMFAC*(4D0*PARU(1)*AEM/XW)**3*SQMW + IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR* + & PARU(155+10*IHIGG)**2 + FACPRP=1D0/((VINT(215)-VINT(204)**2)* + & (VINT(216)-VINT(209)**2))**2 + FACWW=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219) + CALL PYWIDT(KFHIGG,SH,WDTP,WDTE) + HS=SHR*WDTP(0) + HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) + FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2) + IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2)) + & FACBW=0D0 + DO 510 I=MMIN1,MMAX1 + IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 510 + EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1) + DO 500 J=MMIN2,MMAX2 + IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 500 + EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1) + IF(EI*EJ.GT.0D0) GOTO 500 + FACLR=VINT(180+I)*VINT(180+J) + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACLR*FACWW*FACBW + 500 CONTINUE + 510 CONTINUE + + ELSEIF(ISUB.EQ.143) THEN +C...f + fbar' -> H+/- + SQMHC=PMAS(37,1)**2 + CALL PYWIDT(37,SH,WDTP,WDTE) + HS=SHR*WDTP(0) + FACBW=4D0*COMFAC/((SH-SQMHC)**2+HS**2) + HP=AEM/(8D0*XW)*SH/SQMW*SH + DO 530 I=MMIN1,MMAX1 + IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 530 + IA=IABS(I) + IM=(MOD(IA,10)+1)/2 + DO 520 J=MMIN2,MMAX2 + IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 520 + JA=IABS(J) + JM=(MOD(JA,10)+1)/2 + IF(I*J.GT.0.OR.IA.EQ.JA.OR.IM.NE.JM) GOTO 520 + IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10)) + & GOTO 520 + IF(MOD(IA,2).EQ.0) THEN + IU=IA + IL=JA + ELSE + IU=JA + IL=IA + ENDIF + RML=PYMRUN(IL,SH)**2/SH + RMU=PYMRUN(IU,SH)**2/SH + HI=HP*(RML*PARU(141)**2+RMU/PARU(141)**2) + IF(IA.LE.10) HI=HI*FACA/3D0 + KCHHC=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3 + HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4)) + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + SIGH(NCHN)=HI*FACBW*HF + 520 CONTINUE + 530 CONTINUE + + ELSEIF(ISUB.EQ.161) THEN +C...f + g -> f' + H+/- (b + g -> t + H+/- only) +C...(choice of only b and t to avoid kinematics problems) + FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24 +C...H propagator: as simulated in PYOFSH and as desired + SQMHC=PMAS(37,1)**2 + GMMHC=PMAS(37,1)*PMAS(37,2) + HBW4=GMMHC/((SQM4-SQMHC)**2+GMMHC**2) + CALL PYWIDT(37,SQM4,WDTP,WDTE) + GMMHCC=SQRT(SQM4)*WDTP(0) + HBW4C=GMMHCC/((SQM4-SQMHC)**2+GMMHCC**2) + FHCQ=FHCQ*HBW4C/HBW4 + Q2RM=SH + IF(MSTP(32).EQ.12) Q2RM=PARP(194) + DO 550 I=MMINA,MMAXA + IA=IABS(I) + IF(IA.NE.5) GOTO 550 + SQML=PYMRUN(IA,Q2RM)**2 + IUA=IA+MOD(IA,2) + SQMQ=PYMRUN(IUA,Q2RM)**2 + FACHCQ=FHCQ*(SQML*PARU(141)**2+SQMQ/PARU(141)**2)/SQMW* + & (SH/(SQMQ-UH)+2D0*SQMQ*(SQMHC-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH- + & 2D0*SQMQ/(SQMQ-UH)+2D0*(SQMHC-UH)/(SQMQ-UH)* + & (SQMHC-SQMQ-SH)/SH) + KCHHC=ISIGN(1,KCHG(IA,1)*ISIGN(1,I)) + DO 540 ISDE=1,2 + IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 540 + IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 540 + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACHCQ*WIDS(37,(5-KCHHC)/2) + IF(IUA.EQ.6) SIGH(NCHN)=SIGH(NCHN)*WIDS(6,(5+KCHHC)/2) + 540 CONTINUE + 550 CONTINUE + ENDIF + + ELSEIF(ISUB.LE.402) THEN + IF(ISUB.EQ.401) THEN +C... g + g -> t + bbar + H- + IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 560 + IA=KFPR(ISUBSV,2) + CALL PYSTBH(WTTBH) + CALL PYWIDT(KFHIGG,SH,WDTP,WDTE) + HS=SHR*WDTP(0) + FACBW=(1D0/PARU(1))*VINT(2)*HS/((SH-SQMH)**2+HS**2) + IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2)) + & FACBW=0D0 + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=2d0*COMFAC*WTTBH*FACBW +c Since we don't know yet if H+ or H-, assume H+ +c when calculating suppression due to closed channels. + SIGH(NCHN)=SIGH(NCHN)*WIDS(37,2)*WIDS(6,3) + IF(ABS(WIDS(37,2)-WIDS(37,3)) + & .GE.1D-6*(WIDS(37,2)+WIDS(37,3)).OR. + & ABS(WIDS(6,2)-WIDS(6,3)) + & .GE.1D-6*(WIDS(6,2)+WIDS(6,3))) THEN + WRITE(*,*)'Error: Process 401 cannot handle different' + WRITE(*,*)'decays for H+ and H- or t and tbar.' + WRITE(*,*)'Execution stopped.' + CALL PYSTOP(108) + END IF + 560 CONTINUE + + ELSEIF(ISUB.EQ.402) THEN +C... q + qbar -> t + bbar + H- + IA=KFPR(ISUBSV,2) + CALL PYSTBH(WTTBH) + CALL PYWIDT(KFHIGG,SH,WDTP,WDTE) + HS=SHR*WDTP(0) + FACBW=(1D0/PARU(1))*VINT(2)*HS/((SH-SQMH)**2+HS**2) + IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2)) + & FACBW=0D0 + DO 570 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR. + & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 570 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=2d0*COMFAC*WTTBH*FACBW +c Since we don't know yet if H+ or H-, assume H+ +c when calculating suppression due to closed channels. + SIGH(NCHN)=SIGH(NCHN)*WIDS(37,2)*WIDS(6,3) + IF(ABS(WIDS(37,2)-WIDS(37,3))/(WIDS(37,2)+WIDS(37,3)) + & .GE.1D-6.OR. + & ABS(WIDS(6,2)-WIDS(6,3))/(WIDS(6,2)+WIDS(6,3)) + & .GE.1D-6) THEN + WRITE(*,*)'Error: Process 402 cannot handle different' + WRITE(*,*)'decays for H+ and H- or t and tbar.' + WRITE(*,*)'Execution stopped.' + CALL PYSTOP(108) + END IF + 570 CONTINUE + ENDIF + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYSGSU +C...Subprocess cross sections for SUSY processes, +C...including Higgs pair production. +C...Auxiliary to PYSIGH. + + SUBROUTINE PYSGSU(NCHN,SIGS) + +C...Double precision and integer declarations + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) + COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000) + COMMON/PYINT4/MWID(500),WIDS(500,5) + COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) + COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), + &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) + COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA, + &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4, + &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW, + &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR + SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/, + &/PYINT4/,/PYMSSM/,/PYSSMT/,/PYSGCM/ +C...Local arrays and complex variables + DIMENSION WDTP(0:400),WDTE(0:400,0:5) + COMPLEX*16 OLPP,ORPP,OLP,ORP,OL,OR,QLL,QLR + COMPLEX*16 QRR,QRL,GLIJ,GRIJ,PROPW,PROPZ + COMPLEX*16 ZMIXC(4,4),UMIXC(2,2),VMIXC(2,2) + +CMRENNA++ +C...Z and W width, combinations of weak mixing angle + ZWID=PMAS(23,2) + WWID=PMAS(24,2) + TANW=SQRT(XW/XW1) + CT2W=(1D0-2D0*XW)/(2D0*XW/TANW) + +C...Convert almost equivalent SUSY processes into each other +C...Extract differences in flavours and couplings + +C...Sleptons and sneutrinos + IF(ISUB.EQ.201.OR.ISUB.EQ.204.OR.ISUB.EQ.207) THEN + KFID=MOD(KFPR(ISUB,1),KSUSY1) + ISUB=201 + ILR=0 + ELSEIF(ISUB.EQ.202.OR.ISUB.EQ.205.OR.ISUB.EQ.208) THEN + KFID=MOD(KFPR(ISUB,1),KSUSY1) + ISUB=201 + ILR=1 + ELSEIF(ISUB.EQ.203.OR.ISUB.EQ.206.OR.ISUB.EQ.209) THEN + KFID=MOD(KFPR(ISUB,1),KSUSY1) + ISUB=203 + ELSEIF(ISUB.GE.210.AND.ISUB.LE.212) THEN + IF(ISUB.EQ.210) THEN + RKF=2.0D0 + ELSEIF(ISUB.EQ.211) THEN + RKF=SFMIX(15,1)**2 + ELSEIF(ISUB.EQ.212) THEN + RKF=SFMIX(15,2)**2 + ENDIF + ISUB=210 + ELSEIF(ISUB.EQ.213.OR.ISUB.EQ.214) THEN + IF(ISUB.EQ.213) THEN + KFID=MOD(KFPR(ISUB,1),KSUSY1) + RKF=2.0D0 + ELSEIF(ISUB.EQ.214) THEN + KFID=16 + RKF=1.0D0 + ENDIF + ISUB=213 + +C...Neutralinos + ELSEIF(ISUB.GE.216.AND.ISUB.LE.225) THEN + IF(ISUB.EQ.216) THEN + IZID1=1 + IZID2=1 + ELSEIF(ISUB.EQ.217) THEN + IZID1=2 + IZID2=2 + ELSEIF(ISUB.EQ.218) THEN + IZID1=3 + IZID2=3 + ELSEIF(ISUB.EQ.219) THEN + IZID1=4 + IZID2=4 + ELSEIF(ISUB.EQ.220) THEN + IZID1=1 + IZID2=2 + ELSEIF(ISUB.EQ.221) THEN + IZID1=1 + IZID2=3 + ELSEIF(ISUB.EQ.222) THEN + IZID1=1 + IZID2=4 + ELSEIF(ISUB.EQ.223) THEN + IZID1=2 + IZID2=3 + ELSEIF(ISUB.EQ.224) THEN + IZID1=2 + IZID2=4 + ELSEIF(ISUB.EQ.225) THEN + IZID1=3 + IZID2=4 + ENDIF + ISUB=216 + +C...Charginos + ELSEIF(ISUB.GE.226.AND.ISUB.LE.228) THEN + IF(ISUB.EQ.226) THEN + IZID1=1 + IZID2=1 + ELSEIF(ISUB.EQ.227) THEN + IZID1=2 + IZID2=2 + ELSEIF(ISUB.EQ.228) THEN + IZID1=1 + IZID2=2 + ENDIF + ISUB=226 + +C...Neutralino + chargino + ELSEIF(ISUB.GE.229.AND.ISUB.LE.236) THEN + IF(ISUB.EQ.229) THEN + IZID1=1 + IZID2=1 + ELSEIF(ISUB.EQ.230) THEN + IZID1=1 + IZID2=2 + ELSEIF(ISUB.EQ.231) THEN + IZID1=1 + IZID2=3 + ELSEIF(ISUB.EQ.232) THEN + IZID1=1 + IZID2=4 + ELSEIF(ISUB.EQ.233) THEN + IZID1=2 + IZID2=1 + ELSEIF(ISUB.EQ.234) THEN + IZID1=2 + IZID2=2 + ELSEIF(ISUB.EQ.235) THEN + IZID1=2 + IZID2=3 + ELSEIF(ISUB.EQ.236) THEN + IZID1=2 + IZID2=4 + ENDIF + ISUB=229 + +C...Gluino + neutralino + ELSEIF(ISUB.GE.237.AND.ISUB.LE.240) THEN + IF(ISUB.EQ.237) THEN + IZID=1 + ELSEIF(ISUB.EQ.238) THEN + IZID=2 + ELSEIF(ISUB.EQ.239) THEN + IZID=3 + ELSEIF(ISUB.EQ.240) THEN + IZID=4 + ENDIF + ISUB=237 + +C...Gluino + chargino + ELSEIF(ISUB.GE.241.AND.ISUB.LE.242) THEN + IF(ISUB.EQ.241) THEN + IZID=1 + ELSEIF(ISUB.EQ.242) THEN + IZID=2 + ENDIF + ISUB=241 + +C...Squark + neutralino + ELSEIF(ISUB.GE.246.AND.ISUB.LE.253) THEN + ILR=0 + IF(MOD(ISUB,2).NE.0) ILR=1 + IF(ISUB.LE.247) THEN + IZID=1 + ELSEIF(ISUB.LE.249) THEN + IZID=2 + ELSEIF(ISUB.LE.251) THEN + IZID=3 + ELSEIF(ISUB.LE.253) THEN + IZID=4 + ENDIF + ISUB=246 + RKF=5D0 + +C...Squark + chargino + ELSEIF(ISUB.GE.254.AND.ISUB.LE.257) THEN + IF(ISUB.LE.255) THEN + IZID=1 + ELSEIF(ISUB.LE.257) THEN + IZID=2 + ENDIF + IF(MOD(ISUB,2).EQ.0) THEN + ILR=0 + ELSE + ILR=1 + ENDIF + ISUB=254 + RKF=5D0 + +C...Squark + gluino + ELSEIF(ISUB.EQ.258.OR.ISUB.EQ.259) THEN + ISUB=258 + RKF=4D0 + +C...Stops + ELSEIF(ISUB.EQ.261.OR.ISUB.EQ.262) THEN + ILR=0 + IF(ISUB.EQ.262) ILR=1 + ISUB=261 + ELSEIF(ISUB.EQ.265) THEN + ISUB=264 + +C...Squarks + ELSEIF(ISUB.GE.271.AND.ISUB.LE.280) THEN + ILR=0 + IF(ISUB.LE.273) THEN + IF(ISUB.EQ.273) ILR=1 + ISUB=271 + RKF=16D0 + ELSEIF(ISUB.LE.276) THEN + IF(ISUB.EQ.276) ILR=1 + ISUB=274 + RKF=16D0 + ELSEIF(ISUB.LE.278) THEN + IF(ISUB.EQ.278) ILR=1 + ISUB=277 + RKF=4D0 + ELSE + IF(ISUB.EQ.280) ILR=1 + ISUB=279 + RKF=4D0 + ENDIF +C...Sbottoms + ELSEIF(ISUB.GE.281.AND.ISUB.LE.296) THEN + ILR=0 + IF(ISUB.LE.283) THEN + IF(ISUB.EQ.283) ILR=1 + ISUB=271 + RKF=4D0 + ELSEIF(ISUB.LE.286) THEN + IF(ISUB.EQ.286) ILR=1 + ISUB=274 + RKF=4D0 + ELSEIF(ISUB.LE.288) THEN + IF(ISUB.EQ.288) ILR=1 + ISUB=277 + RKF=1D0 + ELSEIF(ISUB.LE.290) THEN + IF(ISUB.EQ.290) ILR=1 + ISUB=279 + RKF=1D0 + ELSEIF(ISUB.LE.293) THEN + IF(ISUB.EQ.293) ILR=1 + ISUB=271 + RKF=1D0 + ELSEIF(ISUB.EQ.296) THEN + ILR=1 + ISUB=274 + RKF=1D0 +C...Squark + gluino + ELSEIF(ISUB.EQ.294.OR.ISUB.EQ.295) THEN + ISUB=258 + RKF=1D0 + ENDIF +C...H+/- + H0 + ELSEIF(ISUB.EQ.297.OR.ISUB.EQ.298) THEN + IF(ISUB.EQ.297) THEN + RKF=.5D0*PARU(195)**2 + ELSEIF(ISUB.EQ.298) THEN + RKF=.5D0*(1D0-PARU(195)**2) + ENDIF + ISUB=210 +C...A0 + H0 + ELSEIF(ISUB.EQ.299.OR.ISUB.EQ.300) THEN + IF(ISUB.EQ.299) THEN + RKF=PARU(186)**2 + KFID=25 + ELSEIF(ISUB.EQ.300) THEN + RKF=PARU(187)**2 + KFID=35 + ENDIF + ISUB=213 +C...H+ + H- + ELSEIF(ISUB.EQ.301) THEN + KFID=37 + RKF=1D0 + ISUB=201 + ENDIF + +C...Supersymmetric processes - all of type 2 -> 2 : +C...correct final-state Breit-Wigners from fixed to running width. + IF(MSTP(42).GT.0) THEN + DO 100 I=1,2 + KFLW=KFPR(ISUBSV,I) + KCW=PYCOMP(KFLW) + IF(PMAS(KCW,2).LT.PARP(41)) GOTO 100 + IF(I.EQ.1) SQMI=SQM3 + IF(I.EQ.2) SQMI=SQM4 + SQMS=PMAS(KCW,1)**2 + GMMS=PMAS(KCW,1)*PMAS(KCW,2) + HBWS=GMMS/((SQMI-SQMS)**2+GMMS**2) + CALL PYWIDT(KFLW,SQMI,WDTP,WDTE) + GMMI=SQRT(SQMI)*WDTP(0) + HBWI=GMMI/((SQMI-SQMS)**2+GMMI**2) + COMFAC=COMFAC*(HBWI/HBWS) + 100 CONTINUE + ENDIF + +C...Differential cross section expressions. + + IF(ISUB.LE.210) THEN + IF(ISUB.EQ.201) THEN +C...f + fbar -> e_L + e_Lbar + COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1) + DO 130 I=MMIN1,MMAX1 + IA=IABS(I) + IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 130 + EI=KCHG(IA,1)/3D0 + TT3I=SIGN(1D0,EI+1D-6)/2D0 + EJ=-1D0 + TT3J=-1D0/2D0 + FCOL=1D0 +C...Color factor for e+ e- + IF(IA.GE.11) FCOL=3D0 + IF(ISUBSV.EQ.301) THEN + A1=1D0 + A2=0D0 + ELSEIF(ILR.EQ.1) THEN + A1=SFMIX(KFID,3)**2 + A2=SFMIX(KFID,4)**2 + ELSEIF(ILR.EQ.0) THEN + A1=SFMIX(KFID,1)**2 + A2=SFMIX(KFID,2)**2 + ENDIF + XLQ=(TT3J-EJ*XW)*A1 + XRQ=(-EJ*XW)*A2 + XLF=(TT3I-EI*XW) + XRF=(-EI*XW) + TAA=(EI*EJ)**2*(POLL+POLR) + TZZ=(XLF**2*POLL+XRF**2*POLR)*(XLQ+XRQ)**2/XW**2/XW1**2 + TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*ZWID/SH**2) + TAZ=2D0*EI*EJ*(XLQ+XRQ)*(XLF*POLL+XRF*POLR)/XW/XW1 + TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH) + TNN=0.0D0 + TAN=0.0D0 + TZN=0.0D0 + IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN + FAC2=SQRT(2D0) + TNN1=0D0 + TNN2=0D0 + TNN3=0D0 + DO 120 II=1,4 + DK=1D0/(TH-SMZ(II)**2) + FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)* + & ZMIX(II,1)) + FREK=FAC2*TANW*EI*ZMIX(II,1) + TNN1=TNN1+FLEK**2*DK + TNN2=TNN2+FREK**2*DK + DO 110 JJ=1,4 + DL=1D0/(TH-SMZ(JJ)**2) + FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)* + & ZMIX(JJ,1)) + FREL=FAC2*TANW*EJ*ZMIX(JJ,1) + TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ) + 110 CONTINUE + 120 CONTINUE + TNN=(UH*TH-SQM3*SQM4)*(A1**2*TNN1**2*POLL+ + & A2**2*TNN2**2*POLR) + TNN=(TNN+SH*A1*A2*TNN3*((1D0-PARJ(131))*(1D0-PARJ(132))+ + & (1D0+PARJ(131))*(1D0+PARJ(132))))/4D0/XW**2 + TZN=(UH*TH-SQM3*SQM4)*(XLQ+XRQ)* + & (TNN1*XLF*A1*POLL+TNN2*XRF*A2*POLR) + TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)* + & (1D0-SQMZ/SH)/SH + TZN=TZN/XW**2/XW1 + TAN=EI*EJ*(UH*TH-SQM3*SQM4)/SH*(A1*TNN1*POLL+ + & A2*TNN2*POLR)/XW + ENDIF + FACQQ1=COMFAC*AEM**2*(TAA+TZZ+TAZ)*FCOL/3D0 + FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH**2 + FACQQ2=COMFAC*AEM**2*(TNN+TZN+TAN)*FCOL/3D0 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQ1+FACQQ2 + 130 CONTINUE + + ELSEIF(ISUB.EQ.203) THEN +C...f + fbar -> e_L + e_Rbar + DO 160 I=MMIN1,MMAX1 + IA=IABS(I) + IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 160 + EI=KCHG(IABS(I),1)/3D0 + TT3I=SIGN(1D0,EI)/2D0 + EJ=-1 + TT3J=-1D0/2D0 + FCOL=1D0 +C...Color factor for e+ e- + IF(IA.GE.11) FCOL=3D0 + A1=SFMIX(KFID,1)**2 + A2=SFMIX(KFID,2)**2 + XLQ=(TT3J-EJ*XW) + XRQ=(-EJ*XW) + XLF=(TT3I-EI*XW) + XRF=(-EI*XW) + TZZ=(XLF**2*POLL+XRF**2*POLR)*(XLQ-XRQ)**2 + & /XW**2/XW1**2*A1*A2 + TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2) + TNN=0.0D0 + TZN=0.0D0 + TNNA=0D0 + TNNB=0D0 + IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN + FAC2=SQRT(2D0) + TNN1=0D0 + TNN2=0D0 + TNN3=0D0 + DO 150 II=1,4 + DK=1D0/(TH-SMZ(II)**2) + FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)* + & ZMIX(II,1)) + FREK=FAC2*TANW*EI*ZMIX(II,1) + TNN1=TNN1+FLEK**2*DK + TNN2=TNN2+FREK**2*DK + DO 140 JJ=1,4 + DL=1D0/(TH-SMZ(JJ)**2) + FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)* + & ZMIX(JJ,1)) + FREL=FAC2*TANW*EJ*ZMIX(JJ,1) + TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ) + 140 CONTINUE + 150 CONTINUE + TNN=(UH*TH-SQM3*SQM4)*A1*A2*(TNN2**2*POLR+TNN1**2*POLL) + TNNA=(TNN+SH*(A1**2*POLLL+A2**2*POLRR)*TNN3)/4D0 + TNNB=(TNN+SH*(A1**2*POLRR+A2**2*POLLL)*TNN3)/4D0 + TZN=(UH*TH-SQM3*SQM4)*A1*A2 + TZN=TZN*(XLQ-XRQ)*(XLF*TNN1*POLL-XRF*TNN2*POLR)/XW1 + TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)* + & (1D0-SQMZ/SH)/SH + ENDIF + FACQQ0=COMFAC*AEM**2*TZZ*FCOL/3D0*(UH*TH-SQM3*SQM4)/SH2 + FACQQ2=COMFAC*AEM**2/XW**2*(TNNA+TZN)*FCOL/3D0 + FACQQ1=COMFAC*AEM**2/XW**2*(TNNB+TZN)*FCOL/3D0 +C%%%%%%%%%%% + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=(FACQQ0+FACQQ1)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)* + & WIDS(PYCOMP(KFPR(ISUBSV,2)),3) + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=2 + SIGH(NCHN)=(FACQQ0+FACQQ2)*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)* + & WIDS(PYCOMP(KFPR(ISUBSV,2)),2) + 160 CONTINUE + + ELSEIF(ISUB.EQ.210) THEN +C...q + qbar' -> W*- > ~l_L + ~nu_L + FAC0=RKF*COMFAC*AEM**2/XW**2/12D0 + FAC1=(TH*UH-SQM3*SQM4)/((SH-SQMW)**2+WWID**2*SQMW) + DO 180 I=MMIN1,MMAX1 + IA=IABS(I) + IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 180 + DO 170 J=MMIN2,MMAX2 + JA=IABS(J) + IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 170 + IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 170 + FCKM=3D0 + IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2) + KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J) + KCHW=2 + IF(KCHSUM.LT.0) KCHW=3 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + IF(ISUBSV.EQ.297.OR.ISUBSV.EQ.298) THEN + FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),5-KCHW)* + & WIDS(PYCOMP(KFPR(ISUBSV,2)),2) + ELSE + FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),5-KCHW)* + & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW) + ENDIF + SIGH(NCHN)=FAC0*FAC1*FCKM*FACR + 170 CONTINUE + 180 CONTINUE + ENDIF + + ELSEIF(ISUB.LE.220) THEN + IF(ISUB.EQ.213) THEN +C...f + fbar -> ~nu_L + ~nu_Lbar + IF(ISUBSV.EQ.299.OR.ISUBSV.EQ.300) THEN + FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),2)* + & WIDS(PYCOMP(KFPR(ISUBSV,2)),2) + ELSE + FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),1) + ENDIF + COMFAC=COMFAC*FACR + PROPZ2=(SH-SQMZ)**2+ZWID**2*SQMZ + XLL=0.5D0 + XLR=0.0D0 + DO 190 I=MMIN1,MMAX1 + IA=IABS(I) + IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 190 + EI=KCHG(IA,1)/3D0 + FCOL=1D0 +C...Color factor for e+ e- + IF(IA.GE.11) FCOL=3D0 + XLQ=(SIGN(1D0,EI)-2D0*EI*XW)/2D0 + XRQ=-EI*XW + TZC=0.0D0 + TCC=0.0D0 + IF(IA.GE.11.AND.KFID.EQ.IA+1) THEN + TZC=VMIX(1,1)**2/(TH-SMW(1)**2)+VMIX(2,1)**2/ + & (TH-SMW(2)**2) + TCC=TZC**2 + TZC=TZC/XW1*(SH-SQMZ)/PROPZ2*XLQ*XLL + ENDIF + FACQQ1=(XLQ**2+XRQ**2)*(XLL+XLR)**2/XW1**2/PROPZ2 + FACQQ2=TZC+TCC/4D0 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=(FACQQ1+FACQQ2)*RKF*(UH*TH-SQM3*SQM4)*COMFAC + & *AEM**2*FCOL/3D0/XW**2 + 190 CONTINUE + + ELSEIF(ISUB.EQ.216) THEN +C...q + qbar -> ~chi0_1 + ~chi0_1 + IF(IZID1.EQ.IZID2) THEN + COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1) + ELSE + COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)* + & WIDS(PYCOMP(KFPR(ISUBSV,2)),2) + ENDIF + FACXX=COMFAC*AEM**2/3D0/XW**2 + IF(IZID1.EQ.IZID2) FACXX=FACXX/2D0 + ZM12=SQM3 + ZM22=SQM4 + WU2 = (UH-ZM12)*(UH-ZM22) + WT2 = (TH-ZM12)*(TH-ZM22) + WS2 = SMZ(IZID1)*SMZ(IZID2)*SH + PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2 + PROPZ=DCMPLX(SH-SQMZ,-ZWID*PMAS(23,1))/DCMPLX(PROPZ2) + DO 200 I=1,4 + ZMIXC(IZID1,I)=DCMPLX(ZMIX(IZID1,I),ZMIXI(IZID1,I)) + IF(IZID2.NE.IZID1) THEN + ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I)) + ENDIF + 200 CONTINUE + OLPP=(ZMIXC(IZID1,3)*DCONJG(ZMIXC(IZID2,3))- + & ZMIXC(IZID1,4)*DCONJG(ZMIXC(IZID2,4)))/2D0 + ORPP=DCONJG(OLPP) + DO 210 I=MMINA,MMAXA + IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 210 + EI=KCHG(IABS(I),1)/3D0 + T3I=SIGN(1D0,EI+1D-6)/2D0 + XML2=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2 + XMR2=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2 + GLIJ=(T3I*ZMIXC(IZID1,2)-TANW*(T3I-EI)*ZMIXC(IZID1,1))* + & DCONJG(T3I*ZMIXC(IZID2,2)-TANW*(T3I-EI)*ZMIXC(IZID2,1)) + GRIJ=ZMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1))*(EI*TANW)**2 + QLL=DCMPLX((T3I-EI*XW)/XW1)*OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2) + QLR=-DCMPLX((T3I-EI*XW)/XW1)*ORPP*PROPZ+DCONJG(GLIJ) + & /DCMPLX(TH-XML2) + QRL=-DCMPLX((EI*XW)/XW1)*OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2) + QRR=DCMPLX((EI*XW)/XW1)*ORPP*PROPZ + & -DCONJG(GRIJ)/DCMPLX(UH-XMR2) + FCOL=1D0 + IF(IABS(I).GE.11) FCOL=3D0 + FACGG1=(ABS(QLL)**2*POLL+ABS(QRR)**2*POLR)*WU2+ + & (ABS(QRL)**2*POLR+ABS(QLR)**2*POLL)*WT2+ + & 2D0*DBLE(QLR*DCONJG(QLL)*POLL+ + & QRL*DCONJG(QRR)*POLR)*WS2 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACXX*FACGG1*FCOL + 210 CONTINUE + ENDIF + + ELSEIF(ISUB.LE.230) THEN + IF(ISUB.EQ.226) THEN +C...f + fbar -> ~chi+_1 + ~chi-_1 + FACXX=COMFAC*AEM**2/3D0 + ZM12=SQM3 + ZM22=SQM4 + WU2 = (UH-ZM12)*(UH-ZM22) + WT2 = (TH-ZM12)*(TH-ZM22) + WS2 = SMW(IZID1)*SMW(IZID2)*SH + PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2 + PROPZ=DCMPLX(SH-SQMZ,-ZWID*PMAS(23,1))/DCMPLX(PROPZ2) + DIFF=0D0 + IF(IZID1.EQ.IZID2) DIFF=1D0 + DO 220 I=1,2 + VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I)) + UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I)) + IF(IZID2.NE.IZID1) THEN + VMIXC(IZID2,I)=DCMPLX(VMIX(IZID2,I),VMIXI(IZID2,I)) + UMIXC(IZID2,I)=DCMPLX(UMIX(IZID2,I),UMIXI(IZID2,I)) + ENDIF + 220 CONTINUE + OLP=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))- + & VMIXC(IZID2,2)*DCONJG(VMIXC(IZID1,2))/2D0+DCMPLX(XW*DIFF) + ORP=-UMIXC(IZID1,1)*DCONJG(UMIXC(IZID2,1))- + & UMIXC(IZID1,2)*DCONJG(UMIXC(IZID2,2))/2D0+DCMPLX(XW*DIFF) + DO 230 I=MMINA,MMAXA + IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 230 + EI=KCHG(IABS(I),1)/3D0 + T3I=SIGN(1D0,EI+1D-6)/2D0 + QRL=DCMPLX(-EI/SH*DIFF)-DCMPLX(EI/XW1)*PROPZ*ORP + QLL=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*PROPZ*ORP + QRR=DCMPLX(-EI/SH*DIFF)-DCMPLX(EI/XW1)*PROPZ*OLP + IF(MOD(I,2).EQ.0) THEN + XML2=PMAS(PYCOMP(KSUSY1+IABS(I)-1),1)**2 + QLR=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)* + & PROPZ*OLP-UMIXC(IZID2,1)*DCONJG(UMIXC(IZID1,1))* + & DCMPLX(T3I/XW/(TH-XML2)) + ELSE + XML2=PMAS(PYCOMP(KSUSY1+IABS(I)+1),1)**2 + QLR=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)* + & PROPZ*OLP-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))* + & DCMPLX(T3I/XW/(TH-XML2)) + ENDIF + FCOL=1D0 + IF(IABS(I).GE.11) FCOL=3D0 + FACSUM=((ABS(QLL)**2*POLL+ABS(QRR)**2*POLR)*WU2+ + & (ABS(QRL)**2*POLR+ABS(QLR)**2*POLL)*WT2+ + & 2D0*DBLE(QLR*DCONJG(QLL)*POLL+ + & QRL*DCONJG(QRR)*POLR)*WS2)*FACXX*FCOL + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + IF(IZID1.EQ.IZID2) THEN + SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),1) + ELSE + SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)* + & WIDS(PYCOMP(KFPR(ISUBSV,2)),2) + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=2 + SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)* + & WIDS(PYCOMP(KFPR(ISUBSV,2)),3) + ENDIF + 230 CONTINUE + + ELSEIF(ISUB.EQ.229) THEN +C...q + qbar' -> ~chi0_1 + ~chi+-_1 + FACXX=COMFAC*AEM**2/6D0/XW**2 + ZM12=SQM3 + ZM22=SQM4 + WU2 = (UH-ZM12)*(UH-ZM22) + WT2 = (TH-ZM12)*(TH-ZM22) + WS2 = SMW(IZID1)*SMZ(IZID2)*SH + RT2I = 1D0/SQRT(2D0) + PROPW = DCMPLX(SH-SQMW,-WWID*PMAS(24,1))/ + & DCMPLX((SH-SQMW)**2+WWID**2*SQMW,0D0) + DO 240 I=1,2 + VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I)) + UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I)) + 240 CONTINUE + DO 250 I=1,4 + ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I)) + 250 CONTINUE + OL=(DCONJG(ZMIXC(IZID2,2))*VMIXC(IZID1,1)- + & DCONJG(ZMIXC(IZID2,4))*VMIXC(IZID1,2)*RT2I)*PROPW + OR=(ZMIXC(IZID2,2)*DCONJG(UMIXC(IZID1,1))+ + & ZMIXC(IZID2,3)*DCONJG(UMIXC(IZID1,2))*RT2I)*PROPW + + DO 270 I=MMIN1,MMAX1 + IA=IABS(I) + IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 270 + EI=KCHG(IA,1)/3D0 + T3I=SIGN(1D0,EI+1D-6)/2D0 + DO 260 J=MMIN2,MMAX2 + JA=IABS(J) + IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 260 + IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 260 + EJ=KCHG(JA,1)/3D0 + T3J=SIGN(1D0,EJ+1D-6)/2D0 + FCKM=3D0 + IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2) + KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J) + KCHW=2 + IF(KCHSUM.LT.0) KCHW=3 + IF(MOD(IA,2).EQ.0) THEN + ZMI2 = PMAS(PYCOMP(KSUSY1+IA),1)**2 + ZMJ2 = PMAS(PYCOMP(KSUSY1+JA),1)**2 + QLL=OL+VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EI-T3I)* + & TANW+ZMIXC(IZID2,2)*T3I)/DCMPLX(UH-ZMI2) + QLR=OR-DCONJG(UMIXC(IZID1,1))*( + & ZMIXC(IZID2,1)*(EJ-T3J)*TANW+ZMIXC(IZID2,2)*T3J) + & /DCMPLX(TH-ZMJ2) + ELSE + ZMI2 = PMAS(PYCOMP(KSUSY1+JA),1)**2 + ZMJ2 = PMAS(PYCOMP(KSUSY1+IA),1)**2 + QLL=OL+VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EJ-T3J)* + & TANW+ZMIXC(IZID2,2)*T3J)/DCMPLX(UH-ZMJ2) + QLR=OR-DCONJG(UMIXC(IZID1,1))*( + & ZMIXC(IZID2,1)*(EI-T3I)*TANW+ZMIXC(IZID2,2)*T3I) + & /DCMPLX(TH-ZMI2) + ENDIF + ZINTR=DBLE(QLR*DCONJG(QLL)) + FACGG1=FACXX*(ABS(QLL)**2*WU2+ABS(QLR)**2*WT2+ + & 2D0*ZINTR*WS2) + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACGG1*FCKM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)* + & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW) + 260 CONTINUE + 270 CONTINUE + ENDIF + + ELSEIF(ISUB.LE.240) THEN + IF(ISUB.EQ.237) THEN +C...q + qbar -> gluino + ~chi0_1 + COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)* + & WIDS(PYCOMP(KFPR(ISUBSV,2)),2) + ASYUK=RMSS(42)*AS + FAC0=COMFAC*ASYUK*AEM*4D0/9D0/XW + GM2=SQM3 + ZM2=SQM4 + DO 280 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR. + & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 280 + EI=KCHG(IABS(I),1)/3D0 + IA=IABS(I) + XLQC = -TANW*EI*ZMIX(IZID,1) + XRQC =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW* + & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0 + XLQ2=XLQC**2 + XRQ2=XRQC**2 + XML2=PMAS(PYCOMP(KSUSY1+IA),1)**2 + XMR2=PMAS(PYCOMP(KSUSY2+IA),1)**2 + ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XML2)**2 + AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XML2)**2 + ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XML2)/(UH-XML2) + SGCHIL=XLQ2*(ATKIN+AUKIN-2D0*ATUKIN) + ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMR2)**2 + AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMR2)**2 + ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XMR2)/(UH-XMR2) + SGCHIR=XRQ2*(ATKIN+AUKIN-2D0*ATUKIN) + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=FAC0*(SGCHIL+SGCHIR) + 280 CONTINUE + ENDIF + + ELSEIF(ISUB.LE.250) THEN + IF(ISUB.EQ.241) THEN +C...q + qbar' -> ~chi+-_1 + gluino + FACWG=COMFAC*AS*AEM/XW*2D0/9D0 + GM2=SQM3 + ZM2=SQM4 + FAC01=2D0*UMIX(IZID,1)*VMIX(IZID,1) + FAC0=UMIX(IZID,1)**2 + FAC1=VMIX(IZID,1)**2 + DO 300 I=MMIN1,MMAX1 + IA=IABS(I) + IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 300 + DO 290 J=MMIN2,MMAX2 + JA=IABS(J) + IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 290 + IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 290 + FCKM=1D0 + IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2) + KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J) + KCHW=2 + IF(KCHSUM.LT.0) KCHW=3 + XMU2=PMAS(PYCOMP(KSUSY1+2),1)**2 + XMD2=PMAS(PYCOMP(KSUSY1+1),1)**2 + ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2 + AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2 + ATUKIN=SMW(IZID)*SQRT(GM2)*SH/(TH-XMU2)/(UH-XMD2) + XMU2=PMAS(PYCOMP(KSUSY2+2),1)**2 + XMD2=PMAS(PYCOMP(KSUSY2+1),1)**2 + ATKIN=(ATKIN+(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2)/2D0 + AUKIN=(AUKIN+(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2)/2D0 + ATUKIN=(ATUKIN+SMW(IZID)*SQRT(GM2)* + & SH/(TH-XMU2)/(UH-XMD2))/2D0 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACWG*FCKM*(FAC0*ATKIN+FAC1*AUKIN- + & FAC01*ATUKIN)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)* + & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW) + 290 CONTINUE + 300 CONTINUE + + ELSEIF(ISUB.EQ.243) THEN +C...q + qbar -> gluino + gluino + COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1) + XMT=SQM3-TH + XMU=SQM3-UH + DO 310 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR. + & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 310 + NCHN=NCHN+1 + XSU=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-UH + XST=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-TH + FACGG1=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+ + & 2D0*SQM3*SH)/SH2 + RMSS(42)**2*(4D0/9D0*(XMT**2/XST**2+ + & XMU**2/XSU**2) + SQM3*SH/XST/XSU/9D0) - RMSS(42)*( + & (XMT**2+SH*SQM3)/SH/XST + (XMU**2+SH*SQM3)/SH/XSU )) + XSU=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-UH + XST=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-TH + FACGG2=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+ + & 2D0*SQM3*SH)/SH2 + RMSS(42)**2*(4D0/9D0*(XMT**2/XST**2+ + & XMU**2/XSU**2) + SQM3*SH/XST/XSU/9D0) - RMSS(42)*( + & (XMT**2+SH*SQM3)/SH/XST + (XMU**2+SH*SQM3)/SH/XSU )) + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 +C...1/2 for identical particles + SIGH(NCHN)=0.25D0*(FACGG1+FACGG2) + 310 CONTINUE + + ELSEIF(ISUB.EQ.244) THEN +C...g + g -> gluino + gluino + COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1) + XMT=SQM3-TH + XMU=SQM3-UH + FACQQ1=COMFAC*AS**2*9D0/4D0*( + & (XMT*XMU-2D0*SQM3*(TH+SQM3))/XMT**2 - + & (XMT*XMU+SQM3*(UH-TH))/SH/XMT ) + FACQQ2=COMFAC*AS**2*9D0/4D0*( + & (XMU*XMT-2D0*SQM3*(UH+SQM3))/XMU**2 - + & (XMU*XMT+SQM3*(TH-UH))/SH/XMU ) + FACQQ3=COMFAC*AS**2*9D0/4D0*(2D0*XMT*XMU/SH2 + + & SQM3*(SH-4D0*SQM3)/XMT/XMU) + IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 320 + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQ1/2D0 + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=2 + SIGH(NCHN)=FACQQ2/2D0 + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=3 + SIGH(NCHN)=FACQQ3/2D0 + 320 CONTINUE + + ELSEIF(ISUB.EQ.246) THEN +C...g + q_j -> ~chi0_1 + ~q_j + FAC0=COMFAC*AS*AEM/6D0/XW + ZM2=SQM4 + QM2=SQM3 + FACZQ0=FAC0*( (ZM2-TH)/SH + + & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 - + & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) ) + KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1) + DO 340 I=-KFNSQ,KFNSQ,2*KFNSQ + IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 340 + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 340 + EI=KCHG(IABS(I),1)/3D0 + IA=IABS(I) + XRQZ = -TANW*EI*ZMIX(IZID,1) + XLQZ =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW* + & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0 + IF(ILR.EQ.0) THEN + BS=XLQZ**2*SFMIX(IA,1)**2+XRQZ**2*SFMIX(IA,2)**2 + ELSE + BS=XLQZ**2*SFMIX(IA,3)**2+XRQZ**2*SFMIX(IA,4)**2 + ENDIF + FACZQ=FACZQ0*BS + KCHQ=2 + IF(I.LT.0) KCHQ=3 + DO 330 ISDE=1,2 + IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 330 + IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 330 + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)* + & WIDS(PYCOMP(KFPR(ISUBSV,2)),2) + 330 CONTINUE + 340 CONTINUE + ENDIF + + ELSEIF(ISUB.LE.260) THEN + IF(ISUB.EQ.254) THEN +C...g + q_j -> ~chi1_1 + ~q_i + FAC0=COMFAC*AS*AEM/12D0/XW + ZM2=SQM4 + QM2=SQM3 + AU=UMIX(IZID,1)**2 + AD=VMIX(IZID,1)**2 + FACZQ0=FAC0*( (ZM2-TH)/SH + + & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 - + & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) ) + KFNSQ1=MOD(KFPR(ISUBSV,1),KSUSY1) + IF(MOD(KFNSQ1,2).EQ.0) THEN + KFNSQ=KFNSQ1-1 + KCHW=2 + ELSE + KFNSQ=KFNSQ1+1 + KCHW=3 + ENDIF + DO 360 I=-KFNSQ,KFNSQ,2*KFNSQ + IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 360 + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 360 + IA=IABS(I) + IF(MOD(IA,2).EQ.0) THEN + FACZQ=FACZQ0*AU + ELSE + FACZQ=FACZQ0*AD + ENDIF + FACZQ=FACZQ*SFMIX(KFNSQ1,1+2*ILR)**2 + KCHQ=2 + IF(I.LT.0) KCHQ=3 + KCHWQ=KCHW + IF(I.LT.0) KCHWQ=5-KCHW + DO 350 ISDE=1,2 + IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 350 + IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 350 + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)* + & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHWQ) + 350 CONTINUE + 360 CONTINUE + + ELSEIF(ISUB.EQ.258) THEN +C...g + q_j -> gluino + ~q_i + XG2=SQM4 + XQ2=SQM3 + XMT=XG2-TH + XMU=XG2-UH + XST=XQ2-TH + XSU=XQ2-UH + FACQG1=0.5D0*4D0/9D0*XMT/SH + (XMT*SH+2D0*XG2*XST)/XMT**2 - + & ( (SH-XQ2+XG2)*(-XST)-SH*XG2 )/SH/(-XMT) + + & 0.5D0*1D0/2D0*( XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST) + + & (-XMU)*(TH+XG2+2D0*XQ2) )/2D0/XMT/XSU + FACQG2= 4D0/9D0*(-XMU)*(UH+XQ2)/XSU**2 + 1D0/18D0* + & (SH*(UH+XG2) + & +2D0*(XQ2-XG2)*XMU)/SH/(-XSU) + 0.5D0*4D0/9D0*XMT/SH + + & 0.5D0*1D0/2D0*(XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST)+ + & (-XMU)*(TH+XG2+2D0*XQ2))/2D0/XMT/XSU + ASYUK=RMSS(42)*AS + FACQG1=COMFAC*AS*ASYUK*FACQG1/2D0 + FACQG2=COMFAC*AS*ASYUK*FACQG2/2D0 + KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1) + DO 380 I=-KFNSQ,KFNSQ,2*KFNSQ + IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 380 + IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 380 + KCHQ=2 + IF(I.LT.0) KCHQ=3 + FACSEL=RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)* + & WIDS(PYCOMP(KFPR(ISUBSV,2)),2) + DO 370 ISDE=1,2 + IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 370 + IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 370 + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQG1*FACSEL + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=21 + ISIG(NCHN,3)=2 + SIGH(NCHN)=FACQG2*FACSEL + 370 CONTINUE + 380 CONTINUE + ENDIF + + ELSEIF(ISUB.LE.270) THEN + IF(ISUB.EQ.261) THEN +C...q_i + q_ibar -> ~t_1 + ~t_1bar + FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )* + & WIDS(PYCOMP(KFPR(ISUBSV,1)),1) + KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1) + FAC0=AS**2*4D0/9D0 + DO 390 I=MMIN1,MMAX1 + IA=IABS(I) + IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 390 + IF(IA.GE.11.AND.IA.LE.18) THEN + EI=KCHG(IA,1)/3D0 + EJ=KCHG(KFNSQ,1)/3D0 + T3I=SIGN(1D0,EI)/2D0 + T3J=SIGN(1D0,EJ)/2D0 + XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,2*ILR+1)**2 + XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2*ILR+2)**2 + XLF=2D0*(T3I-EI*XW) + XRF=2D0*(-EI*XW) + TAA=0.5D0*(EI*EJ)**2 + TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2 + TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2) + TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1 + TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH) + FAC0=AEM**2*12D0*(TAA+TZZ+TAZ) + ENDIF + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQ1*FAC0 + 390 CONTINUE + + ELSEIF(ISUB.EQ.263) THEN +C...f + fbar -> ~t1 + ~t2bar + DO 400 I=MMIN1,MMAX1 + IA=IABS(I) + IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400 + EI=KCHG(IABS(I),1)/3D0 + TT3I=SIGN(1D0,EI)/2D0 + EJ=2D0/3D0 + TT3J=1D0/2D0 + FCOL=1D0 +C...Color factor for e+ e- + IF(IA.GE.11) FCOL=3D0 + XLQ=2D0*(TT3J-EJ*XW) + XRQ=2D0*(-EJ*XW) + XLF=2D0*(TT3I-EI*XW) + XRF=2D0*(-EI*XW) + TZZ=(XLF**2+XRF**2)*(XLQ-XRQ)**2/64D0/XW**2/XW1**2 + TZZ=TZZ*(SFMIX(6,1)*SFMIX(6,2))**2 + TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2) +C...Factor of 2 for t1 t2bar + t2 t1bar +C...PS: bug fix 24 Aug 2010. Factor 2 accounted for by the 2 channels. + FACQQ1=COMFAC*AEM**2*TZZ*FCOL*4D0 + FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH2 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)* + & WIDS(PYCOMP(KFPR(ISUBSV,2)),3) + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=2 + SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)* + & WIDS(PYCOMP(KFPR(ISUBSV,2)),2) + 400 CONTINUE + + ELSEIF(ISUB.EQ.264) THEN +C...g + g -> ~t_1 + ~t_1bar + XSU=SQM3-UH + XST=SQM3-TH + FAC0=COMFAC*AS**2*(7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )*0.5D0* + & WIDS(PYCOMP(KFPR(ISUBSV,1)),1) + FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST) + FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST) + IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 410 + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQ1 + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=2 + SIGH(NCHN)=FACQQ2 + 410 CONTINUE + ENDIF + + ELSEIF(ISUB.LE.280) THEN + IF(ISUB.EQ.271) THEN +C...q + q' -> ~q + ~q' (~g exchange) + XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2 + XMT=XMG2-TH + XMU=XMG2-UH + XSU1=SQM3-UH + XSU2=SQM4-UH + XST1=SQM3-TH + XST2=SQM4-TH + ASYUK=RMSS(42)*AS + IF(ILR.EQ.1) THEN + FACQQ1=COMFAC*ASYUK**2*4D0/9D0*( -(XST1*XST2+SH*TH)/XMT**2 ) + FACQQ2=COMFAC*ASYUK**2*4D0/9D0*( -(XSU1*XSU2+SH*UH)/XMU**2 ) + FACQQB=0.0D0 + ELSE + FACQQ1=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( SH*XMG2/XMT**2 ) + FACQQ2=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( SH*XMG2/XMU**2 ) + FACQQB=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( -2D0*SH*XMG2/3D0/ + & XMT/XMU ) + ENDIF + KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1) + KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1) + DO 430 I=-KFNSQI,KFNSQI,2*KFNSQI + IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 430 + IA=IABS(I) + IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 430 + KCHQ=2 + IF(I.LT.0) KCHQ=3 + DO 420 J=-KFNSQJ,KFNSQJ,2*KFNSQJ + IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 420 + JA=IABS(J) + IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 420 + IF(I*J.LT.0) GOTO 420 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)* + & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ) + IF(I.EQ.J) THEN + IF(ILR.EQ.0) THEN + SIGH(NCHN)=0.5D0*(FACQQ1+0.5D0*FACQQB)*RKF* + & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2) + ELSE + SIGH(NCHN)=0.5D0*FACQQ1*RKF* + & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)* + & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ) + ENDIF + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=2 + IF(ILR.EQ.0) THEN + SIGH(NCHN)=0.5D0*(FACQQ2+0.5D0*FACQQB)*RKF* + & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2) + ELSE + SIGH(NCHN)=0.5D0*FACQQ2*RKF* + & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)* + & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ) + ENDIF + ENDIF + 420 CONTINUE + 430 CONTINUE + + ELSEIF(ISUB.EQ.274) THEN +C...q + qbar' -> ~q + ~qbar' + XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2 + XMT=XMG2-TH + XMU=XMG2-UH + IF(ILR.EQ.0) THEN +C...Mrenna...Normalization.and.1/XMT + FACQQ1=COMFAC*AS**2*2D0/9D0*( + & (UH*TH-SQM3*SQM4)/XMT**2 )*RMSS(42)**2 + FACQQB=COMFAC*AS**2*4D0/9D0*( + & (UH*TH-SQM3*SQM4)/SH2 ) + FACQQI=-COMFAC*AS**2*4D0/27D0*( + & (UH*TH-SQM3*SQM4)/SH/XMT )*RMSS(42) + FACQQB=FACQQB+FACQQ1+FACQQI + ELSE + FACQQ1=COMFAC*AS**2*4D0/9D0*( XMG2*SH/XMT**2 )*RMSS(42)**2 + FACQQB=FACQQ1 + ENDIF + KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1) + KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1) + DO 450 I=-KFNSQI,KFNSQI,2*KFNSQI + IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 450 + IA=IABS(I) + IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 450 + KCHQ=2 + IF(I.LT.0) KCHQ=3 + DO 440 J=-KFNSQJ,KFNSQJ,2*KFNSQJ + IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 440 + JA=IABS(J) + IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 440 + IF(I*J.GT.0) GOTO 440 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)* + & WIDS(PYCOMP(KFPR(ISUBSV,2)),5-KCHQ) + IF(ILR.EQ.0.AND.I.EQ.-J) SIGH(NCHN)=FACQQB*RKF* + & WIDS(PYCOMP(KFPR(ISUBSV,1)),1) + 440 CONTINUE + 450 CONTINUE + + ELSEIF(ISUB.EQ.277) THEN +C...q_i + q_ibar -> ~q_j + ~q_jbar ,i .ne. j +C...if i .eq. j covered in 274 + FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 ) + KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1) + FAC0=0D0 + DO 460 I=MMIN1,MMAX1 + IA=IABS(I) + IF(I.EQ.0.OR.(IA.GT.MSTP(58).AND.IA.LE.10).OR. + & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 460 + IF(IA.EQ.KFNSQ) GOTO 460 + IF(IA.EQ.11.OR.IA.EQ.13.OR.IA.EQ.15) THEN + EI=KCHG(IA,1)/3D0 + EJ=KCHG(KFNSQ,1)/3D0 + T3J=SIGN(0.5D0,EJ) + T3I=SIGN(1D0,EI)/2D0 + IF(ILR.EQ.0) THEN + XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,1) + XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2) + ELSE + XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,3) + XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,4) + ENDIF + XLF=2D0*(T3I-EI*XW) + XRF=2D0*(-EI*XW) + IF(ILR.EQ.0) THEN + XRQ=0D0 + ELSE + XLQ=0D0 + ENDIF + TAA=0.5D0*(EI*EJ)**2 + TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2 + TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2) + TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1 + TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH) + FAC0=AEM**2*12D0*(TAA+TZZ+TAZ) + ELSEIF(IA.LE.6) THEN + FAC0=AS**2*8D0/9D0/2D0 + ENDIF + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQ1*FAC0*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),1) + 460 CONTINUE + + ELSEIF(ISUB.EQ.279) THEN +C...g + g -> ~q_j + ~q_jbar + XSU=SQM3-UH + XST=SQM3-TH +C...4=RKF because ~t ~tbar and ~b ~bbar treated separately + FAC0=RKF*COMFAC*AS**2*( 7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 ) + FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST) + FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST) + IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 470 + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQ1/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1) + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=2 + SIGH(NCHN)=FACQQ2/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1) + 470 CONTINUE + + ENDIF + ENDIF +CMRENNA-- + + RETURN + END + +C********************************************************************* + +C...PYSGTC +C...Subprocess cross sections for Technicolor processes. +C...Auxiliary to PYSIGH. + + SUBROUTINE PYSGTC(NCHN,SIGS) + +C...Double precision and integer declarations + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) + COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000) + COMMON/PYINT4/MWID(500),WIDS(500,5) + COMMON/PYTCSM/ITCM(0:99),RTCM(0:99) + COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA, + &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4, + &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW, + &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR + SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/, + &/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/ +C...Local arrays and complex variables + DIMENSION WDTP(0:400),WDTE(0:400,0:5) + COMPLEX*16 SSMZ,SSMR,SSMO,DETD,F2L,F2R,DARHO,DZRHO,DAOME,DZOME + COMPLEX*16 SSMX,DAAST,DZAST,DWAST + COMPLEX*16 DAA,DZZ,DAZ,DWW,DWRHO + COMPLEX*16 ZTC(6,6),YTC(6,6),DGGS,DGGT,DGGU,DGVS,DGVT,DGVU + COMPLEX*16 DQQS,DQQT,DQQU,DQTS,DQGS,DTGS + COMPLEX*16 DVVS,DVVT,DVVU + INTEGER INDX(6) + +C...Combinations of weak mixing angle. + TANW=SQRT(XW/XW1) + CT2W=(1D0-2D0*XW)/(2D0*XW/TANW) + +C...Convert almost equivalent technicolor processes into +C...a few basic processes, and set distinguishing parameters. + IF(ISUB.GE.361.AND.ISUB.LE.380) THEN + SQTV=RTCM(12)**2 + SQTA=RTCM(13)**2 + SN2W=2D0*SQRT(XW*XW1) + CS2W=1D0-2D0*XW + CT2W=CS2W/SN2W + CSXI=COS(ASIN(RTCM(3))) + CSXIP=COS(ASIN(RTCM(4))) + QUPD=2D0*RTCM(2)-1D0 + Q2UD=RTCM(2)**2+(RTCM(2)-1D0)**2 + CAB2=0D0 + VOGP=0D0 + VRGP=0D0 + AOGP=0D0 + ARGP=0D0 + VXGP=0D0 + AXGP=0D0 + VAGP=0D0 + VZGP=0D0 + VWGP=0D0 +C... rho_tc0, etc. -> W_L W_L, W_L W_T + IF(ISUB.EQ.361) THEN + KFA=24 + KFB=24 + CAB2=RTCM(3)**4 + AXGP=-RTCM(3)/(2D0*SQRT(XW))/RTCM(49) + ARGP=RTCM(3)/(2D0*SQRT(XW))/RTCM(13) + VOGP=RTCM(3)/(2D0*SQRT(XW))/RTCM(12) +C...Multiply by sqrt(2) to account for W^+_T W^-_L + W^+_L W^-_T. + AXGP = SQRT(2D0)*AXGP + ARGP = SQRT(2D0)*ARGP + VOGP = SQRT(2D0)*VOGP +C... rho_tc0 -> W_L pi_tc- + ELSEIF(ISUB.EQ.362) THEN + KFA=24 + KFB=KTECHN+211 + ISUB=361 + CAB2=RTCM(3)**2*(1D0-RTCM(3)**2) +C... pi_tc pi_tc + ELSEIF(ISUB.EQ.363) THEN + KFA=KTECHN+211 + KFB=KTECHN+211 + ISUB=361 + CAB2=(1D0-RTCM(3)**2)**2 +C... rho_tc0/omega_tc -> gamma pi_tc + ELSEIF(ISUB.EQ.364) THEN + KFA=22 + KFB=KTECHN+111 + ISUB=361 + VOGP=CSXI/RTCM(12) + VRGP=VOGP*QUPD + VAGP=2D0*QUPD*CSXI + VZGP=QUPD*CSXI*(1D0-4D0*XW)/SN2W +C... gamma pi_tc' + ELSEIF(ISUB.EQ.365) THEN + KFA=22 + KFB=KTECHN+221 + ISUB=361 + VRGP=CSXIP/RTCM(12) + VOGP=VRGP*QUPD + VAGP=2D0*Q2UD*CSXIP + VZGP=CSXIP/SN2W*(1D0-4D0*XW*Q2UD) +C... Z pi_tc + ELSEIF(ISUB.EQ.366) THEN + KFA=23 + KFB=KTECHN+111 + ISUB=361 + VOGP=CSXI*CT2W/RTCM(12) + VRGP=-QUPD*CSXI*TANW/RTCM(12) + VAGP=QUPD*CSXI*(1D0-4D0*XW)/SN2W + VZGP=-QUPD*CSXI*CS2W/XW1 +C... Z pi_tc' + ELSEIF(ISUB.EQ.367) THEN + KFA=23 + KFB=KTECHN+221 + ISUB=361 +C...RTCM(48) is the M_V for the techni-a + VXGP=-CSXIP/SN2W/RTCM(48) + VRGP=CSXIP*CT2W/RTCM(12) + VOGP=-QUPD*CSXIP*TANW/RTCM(12) + VAGP=CSXIP*(1D0-4D0*Q2UD*XW)/SN2W + VZGP=2D0*CSXIP*(CS2W+4D0*Q2UD*XW**2)/SN2W**2 +C... W_T pi_tc + ELSEIF(ISUB.EQ.368) THEN + KFA=24 + KFB=KTECHN+211 + ISUB=361 +C...RTCM(49) is the M_A for the techni-a + AXGP=-CSXI/(2D0*SQRT(XW))/RTCM(49) + VOGP=CSXI/(2D0*SQRT(XW))/RTCM(12) + ARGP=CSXI/(2D0*SQRT(XW))/RTCM(13) + VAGP=QUPD*CSXI/(2D0*SQRT(XW)) + VZGP=-QUPD*CSXI/(2D0*SQRT(XW1)) +C... rho_tc+, a_T+ -> W_L Z_L, W_T Z_L + ELSEIF(ISUB.EQ.370) THEN + KFA=24 + KFB=23 + CAB2=RTCM(3)**4 + ARGP=-RTCM(3)/(2D0*SQRT(XW))/RTCM(13) + AXGP=RTCM(3)/(2D0*SQRT(XW))/RTCM(49) +C... W_L pi_tc0 + ELSEIF(ISUB.EQ.371) THEN + KFA=24 + KFB=KTECHN+111 + ISUB=370 + CAB2=RTCM(3)**2*(1D0-RTCM(3)**2) +C... Z_L pi_tc+ + ELSEIF(ISUB.EQ.372) THEN + KFA=KTECHN+211 + KFB=23 + ISUB=370 + CAB2=RTCM(3)**2*(1D0-RTCM(3)**2) +C... pi_tc+ pi_tc0 + ELSEIF(ISUB.EQ.373) THEN + KFA=KTECHN+211 + KFB=KTECHN+111 + ISUB=370 + CAB2=(1D0-RTCM(3)**2)**2 +C... gamma pi_tc+ + ELSEIF(ISUB.EQ.374) THEN + KFA=KTECHN+211 + KFB=22 + ISUB=370 + VRGP=QUPD*CSXI/RTCM(12) + VWGP=QUPD*CSXI/(2D0*SQRT(XW)) + AXGP=-CSXI/RTCM(49) +C... Z_T pi_tc+ + ELSEIF(ISUB.EQ.375) THEN + KFA=KTECHN+211 + KFB=23 + ISUB=370 + VRGP=-QUPD*CSXI*TANW/RTCM(12) + ARGP=CSXI/(2D0*SQRT(XW*XW1))/RTCM(13) + VWGP=-QUPD*CSXI/(2D0*SQRT(XW1)) + AXGP=-CSXI*CT2W/RTCM(49) +C... W_T pi_tc0 + ELSEIF(ISUB.EQ.376) THEN + KFA=24 + KFB=KTECHN+111 + ISUB=370 + VRGP=0D0 + ARGP=-CSXI/(2D0*SQRT(XW))/RTCM(13) + AXGP=CSXI/(2D0*SQRT(XW))/RTCM(49) +C... W_T pi_tc0' + ELSEIF(ISUB.EQ.377) THEN + KFA=24 + KFB=KTECHN+221 + ISUB=370 + VRGP=CSXIP/(2D0*SQRT(XW))/RTCM(12) + VWGP=CSXIP/(2D0*XW) + VXGP=-CSXIP/(2D0*SQRT(XW))/RTCM(48) +C... gamma W+ + ELSEIF(ISUB.EQ.378) THEN + KFA=24 + KFB=22 + ISUB=370 + VRGP=QUPD*RTCM(3)/RTCM(12) + AXGP=-RTCM(3)/RTCM(49) +C... gamma Z + ELSEIF(ISUB.EQ.379) THEN + KFA=23 + KFB=22 + ISUB=361 + VOGP=RTCM(3)/RTCM(12) + VRGP=QUPD*RTCM(3)/RTCM(12) + ELSEIF(ISUB.EQ.380) THEN + KFA=23 + KFB=23 + ISUB=361 + VOGP=RTCM(3)*CT2W/RTCM(12) + VRGP=-QUPD*RTCM(3)*TANW/RTCM(12) + ENDIF + ENDIF + +C...QCD 2 -> 2 processes: corrections from virtual technicolor exchange. + IF(ISUB.GE.381.AND.ISUB.LE.388) THEN + IF(ITCM(5).LE.4) THEN + SQDQQS=1D0/SH2 + SQDQQT=1D0/TH2 + SQDQQU=1D0/UH2 + SQDGGS=SQDQQS + SQDGGT=SQDQQT + SQDGGU=SQDQQU + REDGGS=1D0/SH + REDGGT=1D0/TH + REDGGU=1D0/UH + REDGTU=1D0/UH/TH + REDGSU=1D0/SH/UH + REDGST=1D0/SH/TH + REDQST=1D0/SH/TH + REDQTU=1D0/UH/TH + SQDLGS=0D0 + SQDLGT=0D0 + SQDQTS=SQDQQS + ELSEIF(ITCM(5).EQ.5) THEN + TANT3=RTCM(21) + IF(ITCM(2).EQ.0) THEN + IMDL=1 + ELSE + IMDL=2 + ENDIF + ALPRHT=2.16D0*(3D0/ITCM(1)) + SIN2T=2D0*TANT3/(TANT3**2+1D0) + SINT3=TANT3/SQRT(TANT3**2+1D0) + XIG=SQRT(PYALPS(SH)/ALPRHT) + X12=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*COS(RTCM(30))+ + & RTCM(31)*SQRT(1D0-RTCM(31)**2)*COS(RTCM(32)))/SQRT(2D0)/SIN2T + X21=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*SIN(RTCM(30))+ + & RTCM(31)*SQRT(1D0-RTCM(31)**2)*SIN(RTCM(32)))/SQRT(2D0)/SIN2T + X11=(.25D0*(RTCM(29)**2+RTCM(31)**2+2D0)- + & SINT3**2)*2D0/SIN2T + X22=(.25D0*(2D0-RTCM(29)**2-RTCM(31)**2)- + & SINT3**2)*2D0/SIN2T + + SM1122=.5D0*(2D0-RTCM(29)**2-RTCM(31)**2)*RTCM(28)**2 + SM1112=X12*RTCM(28)**2*SIN2T + SM1121=-X21*RTCM(28)**2*SIN2T + SM2212=-SM1112 + SM2221=-SM1121 + SM1221=-.5D0*((1D0-RTCM(29)**2)*SIN(2D0*RTCM(30))+ + & (1D0-RTCM(31)**2)*SIN(2D0*RTCM(32)))*RTCM(28)**2 + +C.........SH LOOP + ZTC(1,1)=DCMPLX(SH,0D0) + CALL PYWIDT(3100021,SH,WDTP,WDTE) + IF(WDTP(0).GT.RTCM(33)*SHR) WDTP(0)=RTCM(33)*SHR + ZTC(2,2)=DCMPLX(SH-PMAS(PYCOMP(3100021),1)**2,-SHR*WDTP(0)) + CALL PYWIDT(3100113,SH,WDTP,WDTE) + ZTC(3,3)=DCMPLX(SH-PMAS(PYCOMP(3100113),1)**2,-SHR*WDTP(0)) + CALL PYWIDT(3400113,SH,WDTP,WDTE) + ZTC(4,4)=DCMPLX(SH-PMAS(PYCOMP(3400113),1)**2,-SHR*WDTP(0)) + CALL PYWIDT(3200113,SH,WDTP,WDTE) + ZTC(5,5)=DCMPLX(SH-PMAS(PYCOMP(3200113),1)**2,-SHR*WDTP(0)) + CALL PYWIDT(3300113,SH,WDTP,WDTE) + ZTC(6,6)=DCMPLX(SH-PMAS(PYCOMP(3300113),1)**2,-SHR*WDTP(0)) + ZTC(1,2)=(0D0,0D0) + ZTC(1,3)=DCMPLX(SH*XIG,0D0) + ZTC(1,4)=ZTC(1,3) + ZTC(1,5)=ZTC(1,2) + ZTC(1,6)=ZTC(1,2) + ZTC(2,3)=DCMPLX(SH*XIG*X11,0D0) + ZTC(2,4)=DCMPLX(SH*XIG*X22,0D0) + ZTC(2,5)=DCMPLX(SH*XIG*X12,0D0) + ZTC(2,6)=DCMPLX(SH*XIG*X21,0D0) + ZTC(3,4)=-SM1122 + ZTC(3,5)=-SM1112 + ZTC(3,6)=-SM1121 + ZTC(4,5)=-SM2212 + ZTC(4,6)=-SM2221 + ZTC(5,6)=-SM1221 + + DO 110 I=1,5 + DO 100 J=I+1,6 + ZTC(J,I)=ZTC(I,J) + 100 CONTINUE + 110 CONTINUE + CALL PYLDCM(ZTC,6,6,INDX,D) + DO 130 I=1,6 + DO 120 J=1,6 + YTC(I,J)=(0D0,0D0) + IF(I.EQ.J) YTC(I,J)=(1D0,0D0) + 120 CONTINUE + 130 CONTINUE + + DO 140 I=1,6 + CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I)) + 140 CONTINUE + DGGS=YTC(1,1) + DVVS=YTC(2,2) + DGVS=YTC(1,2) + + XIG=SQRT(PYALPS(-TH)/ALPRHT) +C.........TH LOOP + ZTC(1,1)=DCMPLX(TH) + ZTC(2,2)=DCMPLX(TH-PMAS(PYCOMP(3100021),1)**2) + ZTC(3,3)=DCMPLX(TH-PMAS(PYCOMP(3100113),1)**2) + ZTC(4,4)=DCMPLX(TH-PMAS(PYCOMP(3400113),1)**2) + ZTC(5,5)=DCMPLX(TH-PMAS(PYCOMP(3200113),1)**2) + ZTC(6,6)=DCMPLX(TH-PMAS(PYCOMP(3300113),1)**2) + ZTC(1,2)=(0D0,0D0) + ZTC(1,3)=DCMPLX(TH*XIG,0D0) + ZTC(1,4)=ZTC(1,3) + ZTC(1,5)=ZTC(1,2) + ZTC(1,6)=ZTC(1,2) + ZTC(2,3)=DCMPLX(TH*XIG*X11,0D0) + ZTC(2,4)=DCMPLX(TH*XIG*X22,0D0) + ZTC(2,5)=DCMPLX(TH*XIG*X12,0D0) + ZTC(2,6)=DCMPLX(TH*XIG*X21,0D0) + ZTC(3,4)=-SM1122 + ZTC(3,5)=-SM1112 + ZTC(3,6)=-SM1121 + ZTC(4,5)=-SM2212 + ZTC(4,6)=-SM2221 + ZTC(5,6)=-SM1221 + DO 160 I=1,5 + DO 150 J=I+1,6 + ZTC(J,I)=ZTC(I,J) + 150 CONTINUE + 160 CONTINUE + CALL PYLDCM(ZTC,6,6,INDX,D) + DO 180 I=1,6 + DO 170 J=1,6 + YTC(I,J)=(0D0,0D0) + IF(I.EQ.J) YTC(I,J)=(1D0,0D0) + 170 CONTINUE + 180 CONTINUE + DO 190 I=1,6 + CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I)) + 190 CONTINUE + DGGT=YTC(1,1) + DVVT=YTC(2,2) + DGVT=YTC(1,2) + + XIG=SQRT(PYALPS(-UH)/ALPRHT) +C.........UH LOOP + ZTC(1,1)=DCMPLX(UH,0D0) + ZTC(2,2)=DCMPLX(UH-PMAS(PYCOMP(3100021),1)**2) + ZTC(3,3)=DCMPLX(UH-PMAS(PYCOMP(3100113),1)**2) + ZTC(4,4)=DCMPLX(UH-PMAS(PYCOMP(3400113),1)**2) + ZTC(5,5)=DCMPLX(UH-PMAS(PYCOMP(3200113),1)**2) + ZTC(6,6)=DCMPLX(UH-PMAS(PYCOMP(3300113),1)**2) + ZTC(1,2)=(0D0,0D0) + ZTC(1,3)=DCMPLX(UH*XIG,0D0) + ZTC(1,4)=ZTC(1,3) + ZTC(1,5)=ZTC(1,2) + ZTC(1,6)=ZTC(1,2) + ZTC(2,3)=DCMPLX(UH*XIG*X11,0D0) + ZTC(2,4)=DCMPLX(UH*XIG*X22,0D0) + ZTC(2,5)=DCMPLX(UH*XIG*X12,0D0) + ZTC(2,6)=DCMPLX(UH*XIG*X21,0D0) + ZTC(3,4)=-SM1122 + ZTC(3,5)=-SM1112 + ZTC(3,6)=-SM1121 + ZTC(4,5)=-SM2212 + ZTC(4,6)=-SM2221 + ZTC(5,6)=-SM1221 + DO 210 I=1,5 + DO 200 J=I+1,6 + ZTC(J,I)=ZTC(I,J) + 200 CONTINUE + 210 CONTINUE + CALL PYLDCM(ZTC,6,6,INDX,D) + DO 230 I=1,6 + DO 220 J=1,6 + YTC(I,J)=(0D0,0D0) + IF(I.EQ.J) YTC(I,J)=(1D0,0D0) + 220 CONTINUE + 230 CONTINUE + DO 240 I=1,6 + CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I)) + 240 CONTINUE + DGGU=YTC(1,1) + DVVU=YTC(2,2) + DGVU=YTC(1,2) + + IF(IMDL.EQ.1) THEN + DQQS=DGGS+DVVS*DCMPLX(TANT3**2)-DGVS*DCMPLX(2D0*TANT3) + DQQT=DGGT+DVVT*DCMPLX(TANT3**2)-DGVT*DCMPLX(2D0*TANT3) + DQQU=DGGU+DVVU*DCMPLX(TANT3**2)-DGVU*DCMPLX(2D0*TANT3) + DQTS=DGGS-DVVS-DGVS*DCMPLX(TANT3-1D0/TANT3) + DQGS=DGGS-DGVS*DCMPLX(TANT3) + DTGS=DGGS+DGVS*DCMPLX(1D0/TANT3) + ELSE + DQQS=DGGS+DVVS*DCMPLX(1D0/TANT3**2)+DGVS*DCMPLX(2D0/TANT3) + DQQT=DGGT+DVVT*DCMPLX(1D0/TANT3**2)+DGVT*DCMPLX(2D0/TANT3) + DQQU=DGGU+DVVU*DCMPLX(1D0/TANT3**2)+DGVU*DCMPLX(2D0/TANT3) + DQTS=DGGS+DVVS*DCMPLX(1D0/TANT3**2)+DGVS*DCMPLX(2D0/TANT3) + DQGS=DGGS+DGVS*DCMPLX(1D0/TANT3) + DTGS=DGGS+DGVS*DCMPLX(1D0/TANT3) + ENDIF + + SQDQTS=ABS(DQTS)**2 + SQDQQS=ABS(DQQS)**2 + SQDQQT=ABS(DQQT)**2 + SQDQQU=ABS(DQQU)**2 + SQDLGS=ABS(DCMPLX(SH)*DQGS-DCMPLX(1D0))**2 + REDLGS=DBLE(DQGS) + SQDHGS=ABS(DCMPLX(SH)*DTGS-DCMPLX(1D0))**2 + REDHGS=DBLE(DTGS) + SQDLGT=ABS(DCMPLX(TH)*DGGT-DCMPLX(1D0))**2 + + SQDGGS=ABS(DGGS)**2 + SQDGGT=ABS(DGGT)**2 + SQDGGU=ABS(DGGU)**2 + REDGGS=DBLE(DGGS) + REDGGT=DBLE(DGGT) + REDGGU=DBLE(DGGU) + REDGTU=DBLE(DGGU*DCONJG(DGGT)) + REDGSU=DBLE(DGGU*DCONJG(DGGS)) + REDGST=DBLE(DGGS*DCONJG(DGGT)) + REDQST=DBLE(DQQS*DCONJG(DQQT)) + REDQTU=DBLE(DQQT*DCONJG(DQQU)) + ENDIF + ENDIF + + +C...Differential cross section expressions. + + IF(ISUB.LE.190) THEN + IF(ISUB.EQ.149) THEN +C...g + g -> eta_tc + KCTC=PYCOMP(KTECHN+331) + CALL PYWIDT(KTECHN+331,SH,WDTP,WDTE) + HS=SHR*WDTP(0) + FACBW=COMFAC*0.5D0/((SH-PMAS(KCTC,1)**2)**2+HS**2) + IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0 + HP=SH + IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 250 + HI=HP*WDTP(3) + HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=HI*FACBW*HF + 250 CONTINUE + + ELSEIF(ISUB.EQ.165) THEN +C...q + qbar -> l+ + l- (including contact term for compositeness) + ZRATR=XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2) + ZRATI=XWC*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2) + KFF=IABS(KFPR(ISUB,1)) + EF=KCHG(KFF,1)/3D0 + AF=SIGN(1D0,EF+0.1D0) + VF=AF-4D0*EF*XWV + VALF=VF+AF + VARF=VF-AF + FCOF=1D0 + IF(KFF.LE.10) FCOF=3D0 + WID2=1D0 + IF(KFF.EQ.6) WID2=WIDS(6,1) + IF(KFF.EQ.7.OR.KFF.EQ.8) WID2=WIDS(KFF,1) + IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1) + DO 260 I=MMINA,MMAXA + IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 260 + EI=KCHG(IABS(I),1)/3D0 + AI=SIGN(1D0,EI+0.1D0) + VI=AI-4D0*EI*XWV + VALI=VI+AI + VARI=VI-AI + FCOI=1D0 + IF(IABS(I).LE.10) FCOI=FACA/3D0 + IF((ITCM(5).EQ.1.AND.IABS(I).LE.2).OR.ITCM(5).EQ.2) THEN + FGZA=(EI*EF+VALI*VALF*ZRATR+RTCM(42)*SH/ + & (AEM*RTCM(41)**2))**2+(VALI*VALF*ZRATI)**2+ + & (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2 + ELSE + FGZA=(EI*EF+VALI*VALF*ZRATR)**2+(VALI*VALF*ZRATI)**2+ + & (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2 + ENDIF + FGZB=(EI*EF+VALI*VARF*ZRATR)**2+(VALI*VARF*ZRATI)**2+ + & (EI*EF+VARI*VALF*ZRATR)**2+(VARI*VALF*ZRATI)**2 + FGZAB=AEM**2*(FGZA*UH2/SH2+FGZB*TH2/SH2) + IF((ITCM(5).EQ.3.AND.IABS(I).EQ.2).OR.(ITCM(5).EQ.4.AND. + & MOD(IABS(I),2).EQ.0)) FGZAB=FGZAB+SH2/(2D0*RTCM(41)**4) + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=COMFAC*FCOI*FCOF*FGZAB*WID2 + 260 CONTINUE + + ELSEIF(ISUB.EQ.166) THEN +C...q + q'bar -> l + nu_l (including contact term for compositeness) + WFAC=(1D0/4D0)*(AEM/XW)**2*UH2/((SH-SQMW)**2+GMMW**2) + WCIFAC=WFAC+SH2/(4D0*RTCM(41)**4) + KFF=IABS(KFPR(ISUB,1)) + FCOF=1D0 + IF(KFF.LE.10) FCOF=3D0 + DO 280 I=MMIN1,MMAX1 + IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 280 + IA=IABS(I) + DO 270 J=MMIN2,MMAX2 + IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 270 + JA=IABS(J) + IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 270 + IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10)) + & GOTO 270 + FCOI=1D0 + IF(IA.LE.10) FCOI=VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0 + WID2=1D0 + IF((I.GT.0.AND.MOD(I,2).EQ.0).OR.(J.GT.0.AND. + & MOD(J,2).EQ.0)) THEN + IF(KFF.EQ.5) WID2=WIDS(6,2) + IF(KFF.EQ.7) WID2=WIDS(8,2)*WIDS(7,3) + IF(KFF.EQ.17) WID2=WIDS(18,2)*WIDS(17,3) + ELSE + IF(KFF.EQ.5) WID2=WIDS(6,3) + IF(KFF.EQ.7) WID2=WIDS(8,3)*WIDS(7,2) + IF(KFF.EQ.17) WID2=WIDS(18,3)*WIDS(17,2) + ENDIF + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + SIGH(NCHN)=COMFAC*FCOI*FCOF*WFAC*WID2 + IF((ITCM(5).EQ.3.AND.IA.LE.2.AND.JA.LE.2).OR.ITCM(5).EQ.4) + & SIGH(NCHN)=COMFAC*FCOI*FCOF*WCIFAC*WID2 + 270 CONTINUE + 280 CONTINUE + ENDIF + + ELSEIF(ISUB.LE.200) THEN + IF(ISUB.EQ.191) THEN +C...q + qbar -> rho_tc0. + KCTC=PYCOMP(KTECHN+113) + SQMRHT=PMAS(KCTC,1)**2 + CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE) + HS=SHR*WDTP(0) + FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2) + IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0 + HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) + ALPRHT=2.16D0*(3D0/ITCM(1)) + HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH) + XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW)) + BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2) + BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2) + DO 290 I=MMINA,MMAXA + IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 290 + IA=IABS(I) + EI=KCHG(IABS(I),1)/3D0 + AI=SIGN(1D0,EI+0.1D0) + VI=AI-4D0*EI*XWV + VALI=0.5D0*(VI+AI) + VARI=0.5D0*(VI-AI) + HI=HP*((EI+VALI*BWZR)**2+(VALI*BWZI)**2+ + & (EI+VARI*BWZR)**2+(VARI*BWZI)**2) + IF(IA.LE.10) HI=HI*FACA/3D0 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=HI*FACBW*HF + 290 CONTINUE + + ELSEIF(ISUB.EQ.192) THEN +C...q + qbar' -> rho_tc+/-. + KCTC=PYCOMP(KTECHN+213) + SQMRHT=PMAS(KCTC,1)**2 + CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE) + HS=SHR*WDTP(0) + FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2) + IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0 + ALPRHT=2.16D0*(3D0/ITCM(1)) + HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)* + & (0.25D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2) + DO 310 I=MMIN1,MMAX1 + IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 310 + IA=IABS(I) + DO 300 J=MMIN2,MMAX2 + IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 300 + JA=IABS(J) + IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 300 + IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10)) + & GOTO 300 + KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3 + HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHR)/2)+WDTE(0,4)) + HI=HP + IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + SIGH(NCHN)=HI*FACBW*HF + 300 CONTINUE + 310 CONTINUE + + ELSEIF(ISUB.EQ.193) THEN +C...q + qbar -> omega_tc0. + KCTC=PYCOMP(KTECHN+223) + SQMOMT=PMAS(KCTC,1)**2 + CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE) + HS=SHR*WDTP(0) + FACBW=12D0*COMFAC/((SH-SQMOMT)**2+HS**2) + IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0 + HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) + ALPRHT=2.16D0*(3D0/ITCM(1)) + HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMOMT**2/SH)* + & (2D0*RTCM(2)-1D0)**2 + BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2) + BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2) + DO 320 I=MMINA,MMAXA + IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 320 + IA=IABS(I) + EI=KCHG(IABS(I),1)/3D0 + AI=SIGN(1D0,EI+0.1D0) + VI=AI-4D0*EI*XWV + VALI=0.5D0*(VI+AI) + VARI=0.5D0*(VI-AI) + HI=HP*((EI-VALI*BWZR)**2+(VALI*BWZI)**2+ + & (EI-VARI*BWZR)**2+(VARI*BWZI)**2) + IF(IA.LE.10) HI=HI*FACA/3D0 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=HI*FACBW*HF + 320 CONTINUE + + ELSEIF(ISUB.EQ.194) THEN +C...f + fbar -> f' + fbar' via s-channel rho_tc, omega_tc a_T0. +C...Default final state is e+e- + KFA=KFPR(ISUBSV,1) + ALPRHT=2.16D0*(3D0/ITCM(1)) + HP=AEM**2*COMFAC + + SN2W=2D0*SQRT(XW*XW1) +C TANW=SQRT(PARU(102)/(1D0-PARU(102))) +C CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW) + + QUPD=2D0*RTCM(2)-1D0 + FAR=SQRT(AEM/ALPRHT) + FAO=FAR*QUPD + FZR=FAR*CT2W + FZO=-FAO*TANW +C...RTCM(47) is the ratio g_{rho_T}/g_{a_T} + FZX=-FAR/SN2W*RTCM(47) + SFAR=FAR**2 + SFAO=FAO**2 + SFZR=FZR**2 + SFZO=FZO**2 + SFZX=FZX**2 + CALL PYWIDT(23,SH,WDTP,WDTE) + SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR) + CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE) + SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR) + CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE) + SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR) + CALL PYWIDT(KTECHN+115,SH,WDTP,WDTE) + SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+115),1)**2/SH,WDTP(0)/SHR) +C...Propagator including a_T^0 + DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO- + $ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ +C...Add in techni-a contribution + DETD=SSMX*DETD-SFZX*(SSMR*SSMO-SFAO*SSMR-SFAR*SSMO) + DAA=(-SSMX*(SFZO*SSMR+SFZR*SSMO-SSMO*SSMR*SSMZ)- + $ SFZX*SSMR*SSMO)/DETD/SH + DZZ=-(SFAO*SSMR+SFAR*SSMO-SSMO*SSMR)/DETD/SH*SSMX + DAZ=(FAR*FZR*SSMO+FAO*FZO*SSMR)/DETD/SH*SSMX + + XWRHT=1D0/(4D0*XW*(1D0-XW)) + KFF=IABS(KFPR(ISUB,1)) + EF=KCHG(KFF,1)/3D0 + AF=SIGN(1D0,EF+0.1D0) + VF=AF-4D0*EF*XWV + VALF=0.5D0*(VF+AF) + VARF=0.5D0*(VF-AF) + FCOF=1D0 + IF(KFF.LE.10) FCOF=3D0 + + WID2=1D0 + IF(KFF.GE.6.AND.KFF.LE.8) WID2=WIDS(KFF,1) + IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1) + DZZ=DZZ*DCMPLX(XWRHT,0D0) + DAZ=DAZ*DCMPLX(SQRT(XWRHT),0D0) + + DO 330 I=MMINA,MMAXA + IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 330 + EI=KCHG(IABS(I),1)/3D0 + AI=SIGN(1D0,EI+0.1D0) + VI=AI-4D0*EI*XWV + VALI=0.5D0*(VI+AI) + VARI=0.5D0*(VI-AI) + FCOI=FCOF + IF(IABS(I).LE.10) FCOI=FCOI/3D0 + DIFLL=ABS(EI*EF*DAA+VALI*VALF*DZZ+DAZ*(EI*VALF+EF*VALI))**2 + DIFRR=ABS(EI*EF*DAA+VARI*VARF*DZZ+DAZ*(EI*VARF+EF*VARI))**2 + DIFLR=ABS(EI*EF*DAA+VALI*VARF*DZZ+DAZ*(EI*VARF+EF*VALI))**2 + DIFRL=ABS(EI*EF*DAA+VARI*VALF*DZZ+DAZ*(EI*VALF+EF*VARI))**2 + FACSIG=(DIFLL+DIFRR)*((UH-SQM4)**2+SH*SQM4)+ + & (DIFLR+DIFRL)*((TH-SQM3)**2+SH*SQM3) + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=HP*FCOI*FACSIG*WID2 + 330 CONTINUE + + ELSEIF(ISUB.EQ.195) THEN +C...f + fbar' -> f'' + fbar''' via s-channel rho_tc+, a_T+ + KFA=KFPR(ISUBSV,1) + KFB=KFA+1 + ALPRHT=2.16D0*(3D0/ITCM(1)) + FACTC=COMFAC*(AEM**2/12D0/XW**2)*(UH-SQM3)*(UH-SQM4)*3D0 + + FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW)) +C...RTCM(47) is the ratio g_{rho_T}/g_{a_T} +C +C...Propagator including a_T^+ + FWX=-FWR*RTCM(47) + CALL PYWIDT(24,SH,WDTP,WDTE) + SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR) + CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE) + SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR) + CALL PYWIDT(KTECHN+215,SH,WDTP,WDTE) + SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+215),1)**2/SH,WDTP(0)/SHR) + DETD=SSMX*(SSMZ*SSMR-DCMPLX(FWR**2,0D0))- + & DCMPLX(FWX**2,0D0)*SSMR + DWW=SSMR*SSMX/DETD/SH + FCOF=1D0 + IF(KFA.LE.8) FCOF=3D0 + HP=FACTC*ABS(DWW)**2*FCOF + + DO 350 I=MMIN1,MMAX1 + IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 350 + IA=IABS(I) + DO 340 J=MMIN2,MMAX2 + IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 340 + JA=IABS(J) + IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 340 + IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10)) + & GOTO 340 + KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3 + HI=HP + IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + SIGH(NCHN)=HI*WIDS(KFA,(5-KCHR)/2)*WIDS(KFB,(5+KCHR)/2) + 340 CONTINUE + 350 CONTINUE + ENDIF + + ELSEIF(ISUB.LE.380) THEN + ALPRHT=2.16D0*(3D0/ITCM(1)) + IF(ISUB.EQ.361) THEN + FAR=SQRT(AEM/ALPRHT) + FAO=FAR*QUPD + FZR=FAR*CT2W + FZO=-FAO*TANW +C...RTCM(47) is the ratio g_{rho_T}/g_{a_T} + FZX=-FAR/SN2W*RTCM(47) + SFAR=FAR**2 + SFAO=FAO**2 + SFZR=FZR**2 + SFZO=FZO**2 + SFZX=FZX**2 + CALL PYWIDT(23,SH,WDTP,WDTE) + SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR) + CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE) + SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR) + CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE) + SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR) + CALL PYWIDT(KTECHN+115,SH,WDTP,WDTE) + SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+115),1)**2/SH,WDTP(0)/SHR) + DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO- + $ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ +C...Add in techni-a contribution + DETD=SSMX*DETD-SFZX*(SSMR*SSMO-SFAO*SSMR-SFAR*SSMO) + DARHO=-(SSMX*(-FAR*SFZO+FAO*FZO*FZR+FAR*SSMO*SSMZ)- + $ SFZX*FAR*SSMO)/DETD/SH + DZRHO=-(-FZR*SFAO+FAO*FZO*FAR+FZR*SSMO)/DETD/SH*SSMX + DAOME=-(SSMX*(-FAO*SFZR+FAR*FZO*FZR+FAO*SSMR*SSMZ)- + $ SFZX*FAO*SSMR)/DETD/SH + DZOME=-(-FZO*SFAR+FAR*FAO*FZR+FZO*SSMR)/DETD/SH*SSMX + DAAST=-FZX*(FAO*FZO*SSMR+FAR*FZR*SSMO)/DETD/SH + DZAST=-FZX*(SSMR*SSMO-SFAO*SSMR-SFAR*SSMO)/DETD/SH + DAA=(-SSMX*(SFZO*SSMR+SFZR*SSMO-SSMO*SSMR*SSMZ)- + $ SFZX*SSMR*SSMO)/DETD/SH + DZZ=-(SFAO*SSMR+SFAR*SSMO-SSMO*SSMR)/DETD/SH*SSMX + DAZ=(FAR*FZR*SSMO+FAO*FZO*SSMR)/DETD/SH*SSMX + +C...f + fbar -> gamma pi_tc, gamma pi_tc', Z pi_tc, Z pi_tc', +C...W+W-, W pi_tc, pi_T pi_T, etc. + FACA=(SH**2*BE34**2-(TH-UH)**2) + VFAC=(TH**2+UH**2-2D0*SQM3*SQM4) + AFAC=(TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM3) + FANOM=SQRT(PARU(1)*AEM)*ITCM(1)/PARU(2)**2/RTCM(1) + HP=(1D0/24D0)*AEM**2*COMFAC*3D0*SH + DO 370 I=MMINA,MMAXA + IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 370 + IA=IABS(I) + EI=KCHG(IABS(I),1)/3D0 + AI=SIGN(1D0,EI+0.1D0) + VI=AI-4D0*EI*XWV + VALI=0.25D0*(VI+AI) ! = \zeta_{iL} in PRD67-115011 + VARI=0.25D0*(VI-AI) ! = \zeta_{iR} in PRD67-115011 +C...........Eqs. (5) and (6) in LSTC-rates.pdf + F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*VRGP + F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*VOGP + F2L=F2L+(EI*DAAST+VALI*DZAST/SQRT(XW*XW1))*VXGP + F2L=F2L+FANOM*(VAGP*(EI*DAA+VALI*DAZ/SQRT(XW*XW1))+ + $ VZGP*(EI*DAZ+VALI*DZZ/SQRT(XW*XW1))) + F2R=(EI*DARHO+VARI*DZRHO/SQRT(XW*XW1))*VRGP + F2R=F2R+(EI*DAOME+VARI*DZOME/SQRT(XW*XW1))*VOGP + F2R=F2R+(EI*DAAST+VARI*DZAST/SQRT(XW*XW1))*VXGP + F2R=F2R+FANOM*(VAGP*(EI*DAA+VARI*DAZ/SQRT(XW*XW1))+ + $ VZGP*(EI*DAZ+VARI*DZZ/SQRT(XW*XW1))) + HI=(ABS(F2L)**2+ABS(F2R)**2)*VFAC +C...........Eqs. (5) and (7) in LSTC-rates.pdf + F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*ARGP + F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*AOGP + F2L=F2L+(EI*DAAST+VALI*DZAST/SQRT(XW*XW1))*AXGP + F2R=(EI*DARHO+VARI*DZRHO/SQRT(XW*XW1))*ARGP + F2R=F2R+(EI*DAOME+VARI*DZOME/SQRT(XW*XW1))*AOGP + F2R=F2R+(EI*DAAST+VARI*DZAST/SQRT(XW*XW1))*AXGP + HJ=(ABS(F2L)**2+ABS(F2R)**2)*AFAC +C +C...........Eqs. (24) in PRD67-115011 with DAA, etc.terms dropped. +C +c$$$ F2L=EI*(DARHO/FAR+(DAA+CT2W*DAZ))+ +c$$$ $ VALI*(CT2W*DZRHO/FZR+(CT2W*DZZ+DAZ))/SQRT(XW*XW1) +c$$$ F2R=EI*(DARHO/FAR+(DAA+CT2W*DAZ))+ +c$$$ $ VARI*(CT2W*DZRHO/FZR+(CT2W*DZZ+DAZ))/SQRT(XW*XW1) + F2L=EI*DARHO/FAR + VALI*CT2W*DZRHO/FZR/SQRT(XW*XW1) + F2R=EI*DARHO/FAR + VARI*CT2W*DZRHO/FZR/SQRT(XW*XW1) + HK=(ABS(F2L)**2+ABS(F2R)**2)*2D0*FACA*CAB2/SH + HI=HI+HJ+HK + IF(IA.LE.10) HI=HI/3D0 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + IF(KFA.EQ.KFB) THEN + SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),1) + ELSEIF(ISUBSV.EQ.362.OR.ISUBSV.EQ.368) THEN + SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),3) + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=2 + SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),3)*WIDS(PYCOMP(KFB),2) + ELSE + SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),2) + ENDIF + 370 CONTINUE + + ELSEIF(ISUB.EQ.370) THEN +C...f + fbar' -> W_L Z_L, W_L Z_T, W_T, Z_L, W_L pi_tc, Z_L pi_tc, pi_tc pi_tc +C...f + fbar' -> gamma pi_tc, etc. + FACA=(SH**2*BE34**2-(TH-UH)**2) + FANOM=SQRT(PARU(1)*AEM)*ITCM(1)/PARU(2)**2/RTCM(1) + VFAC=(TH**2+UH**2-2D0*SQM3*SQM4) + AFAC=(TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM3) + ALPRHT=2.16D0*(3D0/ITCM(1)) + FACHP=(1D0/48D0)*AEM**2/XW*COMFAC*3D0*SH + FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW)) +C...RTCM(47) is the ratio g_{rho_T}/g_{a_T} + FWX=-FWR*RTCM(47) + CALL PYWIDT(24,SH,WDTP,WDTE) + SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR) + CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE) + SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR) + CALL PYWIDT(KTECHN+215,SH,WDTP,WDTE) + SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+215),1)**2/SH,WDTP(0)/SHR) + DETD=SSMX*(SSMZ*SSMR-DCMPLX(FWR**2,0D0))- + & DCMPLX(FWX**2,0D0)*SSMR + DWW=SSMR*SSMX/DETD/SH + DWRHO=-DCMPLX(FWR,0D0)*SSMX/DETD/SH + DWAST=-DCMPLX(FWX,0D0)*SSMR/DETD/SH + HP=FACHP*(AFAC*ABS(DWRHO*ARGP+DWAST*AXGP)**2+ + $ VFAC*ABS(FANOM*DWW*VWGP+DWRHO*VRGP+DWAST*VXGP)**2) +C +C...........Eq. (25) in PRD67-115011 with DWW term dropped. +C +c$$$ HP=HP+.5D0*FACHP*CAB2*FACA/XW/SH*ABS(DWW + DWRHO/FWR)**2 + HP=HP+.5D0*FACHP*CAB2*FACA/XW/SH*ABS(DWRHO/FWR)**2 +C...Add in W_L Z_T axial and vector contributions. + IF(ISUBSV.EQ.370) HP=HP+FACHP*RTCM(3)**2*( + $ (TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM4)* !AFAC w/ switched masses. + $ ABS(DWRHO/RTCM(13)-DWAST/RTCM(49)*CS2W)**2/SN2W**2+ + $ VFAC*QUPD**2*XW/XW1*ABS(DWRHO)**2/RTCM(12)**2) + DO 410 I=MMIN1,MMAX1 + IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 410 + IA=IABS(I) + DO 400 J=MMIN2,MMAX2 + IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 400 + JA=IABS(J) + IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 400 + IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10)) + & GOTO 400 + KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3 + HI=HP + IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + IF(ISUBSV.EQ.374.OR.ISUBSV.EQ.378) THEN + SIGH(NCHN)=HI*WIDS(PYCOMP(KFA),(5-KCHR)/2) + ELSE + SIGH(NCHN)=HI*WIDS(PYCOMP(KFA),(5-KCHR)/2)* + & WIDS(PYCOMP(KFB),2) + ENDIF + 400 CONTINUE + 410 CONTINUE + ENDIF + + ELSEIF(ISUB.LE.390) THEN + IF(ISUB.EQ.381) THEN +C...f + f' -> f + f' (g exchange) + FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)*SQDQQT + FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)*SQDQQT*FACA- + & MSTP(34)*2D0/3D0*UH2*REDQST) + FACQQ2=COMFAC*AS**2*4D0/9D0*(SH2+TH2)*SQDQQU + FACQQI=-COMFAC*AS**2*4D0/9D0*MSTP(34)*2D0/3D0*SH2/(TH*UH) + RATQQI=(FACQQ1+FACQQ2+FACQQI)/(FACQQ1+FACQQ2) + IF(ITCM(5).GE.1.AND.ITCM(5).LE.4) THEN +C...Modifications from contact interactions (compositeness) + FACCI1=FACQQ1+COMFAC*(SH2/RTCM(41)**4) + FACCIB=FACQQB+COMFAC*(8D0/9D0)*(AS*RTCM(42)/RTCM(41)**2)* + & (UH2/TH+UH2/SH)+COMFAC*(5D0/3D0)*(UH2/RTCM(41)**4) + FACCI2=FACQQ2+COMFAC*(8D0/9D0)*(AS*RTCM(42)/RTCM(41)**2)* + & (SH2/TH+SH2/UH)+COMFAC*(5D0/3D0)*(SH2/RTCM(41)**4) + FACCI3=FACQQ1+COMFAC*(UH2/RTCM(41)**4) + RATCII=(FACCI1+FACCI2+FACQQI)/(FACCI1+FACCI2) + ELSEIF(ITCM(5).EQ.5) THEN + FACCI1=FACQQ1 + FACCIB=FACQQB + FACCI2=FACQQ2 + FACCI3=FACQQ1 +CSM.......Check this change from +CSM RATCII=1D0 + RATCII=RATQQI + ENDIF + DO 430 I=MMIN1,MMAX1 + IA=IABS(I) + IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 430 + DO 420 J=MMIN2,MMAX2 + JA=IABS(J) + IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 420 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.(IA.GE.3.OR. + & JA.GE.3))) THEN + SIGH(NCHN)=FACQQ1 + IF(I.EQ.-J) SIGH(NCHN)=FACQQB + ELSE + SIGH(NCHN)=FACCI1 + IF(I*J.LT.0) SIGH(NCHN)=FACCI3 + IF(I.EQ.-J) SIGH(NCHN)=FACCIB + ENDIF + IF(I.EQ.J) THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=2 + IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.IA.GE.3)) THEN + SIGH(NCHN-1)=0.5D0*FACQQ1*RATQQI + SIGH(NCHN)=0.5D0*FACQQ2*RATQQI + ELSE + SIGH(NCHN-1)=0.5D0*FACCI1*RATCII + SIGH(NCHN)=0.5D0*FACCI2*RATCII + ENDIF + ENDIF + 420 CONTINUE + 430 CONTINUE + + ELSEIF(ISUB.EQ.382) THEN +C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only) + CALL PYWIDT(21,SH,WDTP,WDTE) + FACQQF=COMFAC*AS**2*4D0/9D0*(TH2+UH2) + FACQQB=FACQQF*SQDQQS*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) + IF(ITCM(5).EQ.1) THEN +C...Modifications from contact interactions (compositeness) + FACCIB=FACQQB + DO 440 I=1,2 + FACCIB=FACCIB+COMFAC*(UH2/RTCM(41)**4)*(WDTE(I,1)+ + & WDTE(I,2)+WDTE(I,4)) + 440 CONTINUE + ELSEIF(ITCM(5).GE.2.AND.ITCM(5).LE.4) THEN + FACCIB=FACQQB+COMFAC*(UH2/RTCM(41)**4)* + & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) + ELSEIF(ITCM(5).EQ.5) THEN + FACQQB=FACQQF*SQDQQS*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)- + & WDTE(5,1)-WDTE(5,2)-WDTE(5,4)) + FACCIB=FACQQF*SQDQTS*(WDTE(5,1)+WDTE(5,2)+WDTE(5,4)) + ENDIF + DO 450 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR. + & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 450 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.IABS(I).GE.3)) THEN + SIGH(NCHN)=FACQQB + ELSEIF(ITCM(5).EQ.5) THEN + SIGH(NCHN)=FACQQB + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=2 + SIGH(NCHN)=FACCIB + ELSE + SIGH(NCHN)=FACCIB + ENDIF + 450 CONTINUE + + ELSEIF(ISUB.EQ.383) THEN +C...f + fbar -> g + g (q + qbar -> g + g only) + FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)* + & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS) + FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)* + & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS) + IF(ITCM(5).EQ.5) THEN + FACGG3=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)* + & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDHGS) + FACGG4=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)* + & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDHGS) + ENDIF + DO 460 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR. + & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 460 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=0.5D0*FACGG1 + IF(ITCM(5).EQ.5.AND.IABS(I).EQ.5) SIGH(NCHN)=0.5D0*FACGG3 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=2 + SIGH(NCHN)=0.5D0*FACGG2 + IF(ITCM(5).EQ.5.AND.IABS(I).EQ.5) SIGH(NCHN)=0.5D0*FACGG4 + 460 CONTINUE + + ELSEIF(ISUB.EQ.384) THEN +C...f + g -> f + g (q + g -> q + g only) + FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2- + & UH/SH-9D0/4D0*SH*UH/TH2*SQDLGT)*FACA + FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2- + & SH/UH-9D0/4D0*SH*UH/TH2*SQDLGT) + DO 480 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 480 + DO 470 ISDE=1,2 + IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 470 + IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 470 + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQG1 + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=21 + ISIG(NCHN,3)=2 + SIGH(NCHN)=FACQG2 + 470 CONTINUE + 480 CONTINUE + + ELSEIF(ISUB.EQ.385) THEN +C...g + g -> f + fbar (g + g -> q + qbar only) + IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 500 + IDC0=MDCY(21,2)-1 +C...Begin by d, u, s flavours. + FLAVWT=0D0 + IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+ + & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH)) + IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+ + & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH)) + IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+ + & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH)) + FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)* + & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)*FLAVWT*FACA + FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)* + & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)*FLAVWT*FACA + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQ1 + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=2 + SIGH(NCHN)=FACQQ2 +C...Next c and b flavours: modified that and uhat for fixed +C...cos(theta-hat). + DO 490 IFL=4,5 + SQMAVG=PMAS(IFL,1)**2 + IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN + BE34=SQRT(1D0-4D0*SQMAVG/SH) + THQ=-0.5D0*SH*(1D0-BE34*CTH) + UHQ=-0.5D0*SH*(1D0+BE34*CTH) + THUHQ=THQ*UHQ-SQMAVG*SH + IF(MSTP(34).EQ.0) THEN + FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2 + FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2 + ELSE + FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/ + & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ) + FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/ + & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ) + ENDIF + IF(ITCM(5).GE.5) THEN + IF(IFL.EQ.4) THEN + FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDLGS+ + & 2.25D0*THQ*UHQ/SH2*SQDLGS + FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDLGS+ + & 2.25D0*THQ*UHQ/SH2*SQDLGS + ELSE + FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDHGS+ + & 2.25D0*THQ*UHQ/SH2*SQDHGS + FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDHGS+ + & 2.25D0*THQ*UHQ/SH2*SQDHGS + ENDIF + ENDIF + FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34 + FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34 + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1+2*(IFL-3) + SIGH(NCHN)=FACQQ1 + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=2+2*(IFL-3) + SIGH(NCHN)=FACQQ2 + ENDIF + 490 CONTINUE + 500 CONTINUE + + ELSEIF(ISUB.EQ.386) THEN +C...g + g -> g + g + IF(ITCM(5).LE.4) THEN + FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+ + & 2D0*TH/SH+TH2/SH2)*FACA + FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+ + & 2D0*SH/UH+SH2/UH2)*FACA + FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3D0+ + & 2D0*UH/TH+UH2/TH2) + ELSE + GST= (12D0 + 40D0*TH/SH + 56D0*TH2/SH2 + 32D0*TH**3/SH**3 + + & 16D0*TH**4/SH**4 + SQDGGS*(4D0*SH2 + 16D0*SH*TH + 16D0*TH2)+ + & 4D0*REDGST*(SH + 2D0*TH)* + & (2D0*SH**3 - 3D0*SH2*TH - 2D0*SH*TH2 + 2D0*TH**3)/SH2 + + & 2D0*REDGGS*(2D0*SH - 12D0*TH2/SH - 8D0*TH**3/SH2) + + & 2D0*REDGGT*(4D0*SH - 22D0*TH - 68D0*TH2/SH - 60D0*TH**3/SH2- + & 32D0*TH**4/SH**3 - 16D0*TH**5/SH**4) + + & SQDGGT*(16D0*SH2 + 16D0*SH*TH + 68D0*TH2 + 144D0*TH**3/SH + + & 96D0*TH**4/SH2 + 32D0*TH**5/SH**3 + 16D0*TH**6/SH**4))/16D0 + GSU= (12D0 + 40D0*UH/SH + 56D0*UH2/SH2 + 32D0*UH**3/SH**3 + + & 16D0*UH**4/SH**4 + SQDGGS*(4D0*SH2 + 16D0*SH*UH + 16D0*UH2)+ + & 4D0*REDGSU*(SH + 2D0*UH)* + & (2D0*SH**3 - 3D0*SH2*UH - 2D0*SH*UH2 + 2D0*UH**3)/SH2 + + & 2D0*REDGGS*(2D0*SH - 12D0*UH2/SH - 8D0*UH**3/SH2) + + & 2D0*REDGGU*(4D0*SH - 22D0*UH - 68D0*UH2/SH - 60D0*UH**3/SH2- + & 32D0*UH**4/SH**3 - 16D0*UH**5/SH**4) + + & SQDGGU*(16D0*SH2 + 16D0*SH*UH + 68D0*UH2 + 144D0*UH**3/SH + + & 96D0*UH**4/SH2 + 32D0*UH**5/SH**3 + 16D0*UH**6/SH**4))/16D0 + GUT= (12D0 - 16D0*TH*(TH - UH)**2*UH/SH**4 + + & 4D0*REDGGU*(2D0*TH**5 - 15D0*TH**4*UH - 48D0*TH**3*UH2 - + & 58D0*TH2*UH**3 - 10D0*TH*UH**4 + UH**5)/SH**4 + + & 4D0*REDGGT*(TH**5 - 10D0*TH**4*UH - 58D0*TH**3*UH2 - + & 48D0*TH2*UH**3 - 15D0*TH*UH**4 + 2D0*UH**5)/SH**4 + + & 4D0*SQDGGU*(4D0*TH**6 + 20D0*TH**5*UH + 57D0*TH**4*UH2 + + & 72D0*TH**3*UH**3+ 38D0*TH2*UH**4+4D0*TH*UH**5 +UH**6)/SH**4+ + & 4D0*SQDGGT*(4D0*UH**6 + 4D0*TH**5*UH + 38D0*TH**4*UH2 + + & 72D0*TH**3*UH**3 +57D0*TH2*UH**4+20D0*TH*UH**5+TH**6)/SH**4+ + & 2D0*REDGTU*((TH - UH)**2* (TH**4 + 20D0*TH**3*UH + + & 30D0*TH2*UH2 + 20D0*TH*UH**3 + UH**4) + + & SH2*(7D0*TH**4 + 52D0*TH**3*UH + 274D0*TH2*UH2 + + & 52D0*TH*UH**3 + 7D0*UH**4))/(2D0*SH**4))/16D0 + FACGG1=COMFAC*AS**2*9D0/4D0*GST*FACA + FACGG2=COMFAC*AS**2*9D0/4D0*GSU*FACA + FACGG3=COMFAC*AS**2*9D0/4D0*GUT + ENDIF + IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 510 + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=0.5D0*FACGG1 + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=2 + SIGH(NCHN)=0.5D0*FACGG2 + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=3 + SIGH(NCHN)=0.5D0*FACGG3 + 510 CONTINUE + + ELSEIF(ISUB.EQ.387) THEN +C...q + qbar -> Q + Qbar + SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH + THQ=-0.5D0*SH*(1D0-BE34*CTH) + UHQ=-0.5D0*SH*(1D0+BE34*CTH) + FACQQB=COMFAC*AS**2*4D0/9D0*((THQ**2+UHQ**2)/SH2+ + & 2D0*SQMAVG/SH) + IF(ITCM(5).GE.5) THEN + IF(MINT(55).EQ.5.OR.MINT(55).EQ.6) THEN + FACQQB=FACQQB*SH2*SQDQTS + ELSE + FACQQB=FACQQB*SH2*SQDQQS + ENDIF + ENDIF + IF(MSTP(35).GE.1) FACQQB=FACQQB*PYHFTH(SH,SQMAVG,0D0) + WID2=1D0 + IF(MINT(55).EQ.6) WID2=WIDS(6,1) + IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1) + FACQQB=FACQQB*WID2 + DO 520 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR. + & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 520 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQB + 520 CONTINUE + + ELSEIF(ISUB.EQ.388) THEN +C...g + g -> Q + Qbar + SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH + THQ=-0.5D0*SH*(1D0-BE34*CTH) + UHQ=-0.5D0*SH*(1D0+BE34*CTH) + THUHQ=THQ*UHQ-SQMAVG*SH + IF(MSTP(34).EQ.0) THEN + FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2 + FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2 + ELSE + FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/ + & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ) + FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/ + & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ) + ENDIF + IF(ITCM(5).GE.5) THEN + IF(MINT(55).EQ.5.OR.MINT(55).EQ.6) THEN + FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDHGS+ + & 2.25D0*THQ*UHQ/SH2*SQDHGS + FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDHGS+ + & 2.25D0*THQ*UHQ/SH2*SQDHGS + ELSE + FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDLGS+ + & 2.25D0*THQ*UHQ/SH2*SQDLGS + FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDLGS+ + & 2.25D0*THQ*UHQ/SH2*SQDLGS + ENDIF + ENDIF + FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1 + FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2 + IF(MSTP(35).GE.1) THEN + FATRE=PYHFTH(SH,SQMAVG,2D0/7D0) + FACQQ1=FACQQ1*FATRE + FACQQ2=FACQQ2*FATRE + ENDIF + WID2=1D0 + IF(MINT(55).EQ.6) WID2=WIDS(6,1) + IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1) + FACQQ1=FACQQ1*WID2 + FACQQ2=FACQQ2*WID2 + IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 530 + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQ1 + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=2 + SIGH(NCHN)=FACQQ2 + 530 CONTINUE + ENDIF + ENDIF + +CMRENNA-- + + RETURN + END + +C********************************************************************* + +C...PYSGEX +C...Subprocess cross sections for assorted exotic processes, +C...including Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*. +C...Auxiliary to PYSIGH. + + SUBROUTINE PYSGEX(NCHN,SIGS) + +C...Double precision and integer declarations + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) + COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000) + COMMON/PYINT4/MWID(500),WIDS(500,5) + COMMON/PYTCSM/ITCM(0:99),RTCM(0:99) + COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA, + &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4, + &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW, + &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR + SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/, + &/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/ +C...Local arrays + DIMENSION WDTP(0:400),WDTE(0:400,0:5) + +C...Differential cross section expressions. + + IF(ISUB.LE.160) THEN + IF(ISUB.EQ.141) THEN +C...f + fbar -> gamma*/Z0/Z'0 + SQMZP=PMAS(32,1)**2 + MINT(61)=2 + CALL PYWIDT(32,SH,WDTP,WDTE) + HP0=AEM/3D0*SH + HP1=AEM/3D0*XWC*SH + HP2=HP1 + HS=SHR*VINT(117) + HSP=SHR*WDTP(0) + FACZP=4D0*COMFAC*3D0 + DO 100 I=MMINA,MMAXA + IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100 + EI=KCHG(IABS(I),1)/3D0 + AI=SIGN(1D0,EI) + VI=AI-4D0*EI*XWV + IA=IABS(I) + IF(IA.LT.10) THEN + IF(IA.LE.2) THEN + VPI=PARU(123-2*MOD(IABS(I),2)) + API=PARU(124-2*MOD(IABS(I),2)) + ELSEIF(IA.LE.4) THEN + VPI=PARJ(182-2*MOD(IABS(I),2)) + API=PARJ(183-2*MOD(IABS(I),2)) + ELSE + VPI=PARJ(190-2*MOD(IABS(I),2)) + API=PARJ(191-2*MOD(IABS(I),2)) + ENDIF + ELSE + IF(IA.LE.12) THEN + VPI=PARU(127-2*MOD(IABS(I),2)) + API=PARU(128-2*MOD(IABS(I),2)) + ELSEIF(IA.LE.14) THEN + VPI=PARJ(186-2*MOD(IABS(I),2)) + API=PARJ(187-2*MOD(IABS(I),2)) + ELSE + VPI=PARJ(194-2*MOD(IABS(I),2)) + API=PARJ(195-2*MOD(IABS(I),2)) + ENDIF + ENDIF + HI0=HP0 + IF(IABS(I).LE.10) HI0=HI0*FACA/3D0 + HI1=HP1 + IF(IABS(I).LE.10) HI1=HI1*FACA/3D0 + HI2=HP2 + IF(IABS(I).LE.10) HI2=HI2*FACA/3D0 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 +C...Special case: if only branching ratios known then use them. + IF(MWID(32).EQ.2.AND.MSTP(44).EQ.3) THEN + HI=0D0 + IF(IA.LT.10) THEN + HI=SHR*WDTP(IA)*FACA/9D0 + ELSEIF(IA.LT.20) THEN + HI=SHR*WDTP(IA-2) + ENDIF + HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) + SIGH(NCHN)=HI*FACZP*HF/((SH-SQMZP)**2+HSP**2) + ELSE +C...Normal cross section. + SIGH(NCHN)=FACZP*(EI**2/SH2*HI0*HP0*VINT(111)+EI*VI* + & (1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*(HI0*HP1+HI1*HP0)* + & VINT(112)+EI*VPI*(1D0-SQMZP/SH)/((SH-SQMZP)**2+HSP**2)* + & (HI0*HP2+HI2*HP0)*VINT(113)+(VI**2+AI**2)/ + & ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114)+(VI*VPI+AI*API)* + & ((SH-SQMZ)*(SH-SQMZP)+HS*HSP)/(((SH-SQMZ)**2+HS**2)* + & ((SH-SQMZP)**2+HSP**2))*(HI1*HP2+HI2*HP1)*VINT(115)+ + & (VPI**2+API**2)/((SH-SQMZP)**2+HSP**2)*HI2*HP2*VINT(116)) + ENDIF + 100 CONTINUE + + ELSEIF(ISUB.EQ.142) THEN +C...f + fbar' -> W'+/- + SQMWP=PMAS(34,1)**2 + CALL PYWIDT(34,SH,WDTP,WDTE) + HS=SHR*WDTP(0) + FACBW=4D0*COMFAC/((SH-SQMWP)**2+HS**2)*3D0 + HP=AEM/(24D0*XW)*SH + DO 120 I=MMIN1,MMAX1 + IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120 + IA=IABS(I) + DO 110 J=MMIN2,MMAX2 + IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110 + JA=IABS(J) + IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 110 + IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10)) + & GOTO 110 + KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3 +C...Special case: if only branching ratios known then use them. + IF(MWID(34).EQ.2) THEN + HI=0D0 + DO 105 IDC=MDCY(34,2),MDCY(34,2)+MDCY(34,3)-1 + IF((IA.EQ.IABS(KFDP(IDC,1)).AND.JA.EQ. + & IABS(KFDP(IDC,2))).OR.(IA.EQ.IABS(KFDP(IDC,2)) + & .AND.JA.EQ.IABS(KFDP(IDC,1)))) + & HI=SHR*WDTP(IDC+1-MDCY(34,2)) + 105 CONTINUE + IF(IA.LT.10) HI=HI*FACA/9D0 + ELSE +C...Normal cross section. + HI=HP*(PARU(133)**2+PARU(134)**2) + IF(IA.LE.10) HI=HP*(PARU(131)**2+PARU(132)**2)* + & VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0 + ENDIF + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4)) + SIGH(NCHN)=HI*FACBW*HF + 110 CONTINUE + 120 CONTINUE + + ELSEIF(ISUB.EQ.144) THEN +C...f + fbar' -> R + SQMR=PMAS(41,1)**2 + CALL PYWIDT(41,SH,WDTP,WDTE) + HS=SHR*WDTP(0) + FACBW=4D0*COMFAC/((SH-SQMR)**2+HS**2)*3D0 + HP=AEM/(12D0*XW)*SH + DO 140 I=MMIN1,MMAX1 + IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 140 + IA=IABS(I) + DO 130 J=MMIN2,MMAX2 + IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 130 + JA=IABS(J) + IF(I*J.GT.0.OR.IABS(IA-JA).NE.2) GOTO 130 + HI=HP + IF(IA.LE.10) HI=HI*FACA/3D0 + HF=SHR*(WDTE(0,1)+WDTE(0,(10-(I+J))/4)+WDTE(0,4)) + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + SIGH(NCHN)=HI*FACBW*HF + 130 CONTINUE + 140 CONTINUE + + ELSEIF(ISUB.EQ.145) THEN +C...q + l -> LQ (leptoquark) + SQMLQ=PMAS(42,1)**2 + CALL PYWIDT(42,SH,WDTP,WDTE) + HS=SHR*WDTP(0) + FACBW=4D0*COMFAC/((SH-SQMLQ)**2+HS**2) + IF(ABS(SHR-PMAS(42,1)).GT.PARP(48)*PMAS(42,2)) FACBW=0D0 + HP=AEM/4D0*SH + KFLQQ=KFDP(MDCY(42,2),1) + KFLQL=KFDP(MDCY(42,2),2) + DO 160 I=MMIN1,MMAX1 + IF(KFAC(1,I).EQ.0) GOTO 160 + IA=IABS(I) + IF(IA.NE.KFLQQ.AND.IA.NE.IABS(KFLQL)) GOTO 160 + DO 150 J=MMIN2,MMAX2 + IF(KFAC(2,J).EQ.0) GOTO 150 + JA=IABS(J) + IF(JA.NE.KFLQQ.AND.JA.NE.IABS(KFLQL)) GOTO 150 + IF(I*J.NE.KFLQQ*KFLQL) GOTO 150 + IF(JA.EQ.IA) GOTO 150 + IF(IA.EQ.KFLQQ) KCHLQ=ISIGN(1,I) + IF(JA.EQ.KFLQQ) KCHLQ=ISIGN(1,J) + HI=HP*PARU(151) + HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHLQ)/2)+WDTE(0,4)) + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + SIGH(NCHN)=HI*FACBW*HF + 150 CONTINUE + 160 CONTINUE + + ELSEIF(ISUB.EQ.146) THEN +C...e + gamma* -> e* (excited lepton) + KFQSTR=KFPR(ISUB,1) + KCQSTR=PYCOMP(KFQSTR) + KFQEXC=MOD(KFQSTR,KEXCIT) + CALL PYWIDT(KFQSTR,SH,WDTP,WDTE) + HS=SHR*WDTP(0) + FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2) + QF=-RTCM(43)/2D0-RTCM(44)/2D0 + FACBW=FACBW*AEM*QF**2*SH/RTCM(41)**2 + IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2)) + & FACBW=0D0 + HP=SH + DO 180 I=-KFQEXC,KFQEXC,2*KFQEXC + DO 170 ISDE=1,2 + IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 170 + IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 170 + HI=HP + IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) + IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4)) + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=22 + ISIG(NCHN,3)=1 + SIGH(NCHN)=HI*FACBW*HF + 170 CONTINUE + 180 CONTINUE + + ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN +C...d + g -> d* and u + g -> u* (excited quarks) + KFQSTR=KFPR(ISUB,1) + KCQSTR=PYCOMP(KFQSTR) + KFQEXC=MOD(KFQSTR,KEXCIT) + CALL PYWIDT(KFQSTR,SH,WDTP,WDTE) + HS=SHR*WDTP(0) + FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2) + FACBW=FACBW*AS*RTCM(45)**2*SH/(3D0*RTCM(41)**2) + IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2)) + & FACBW=0D0 + HP=SH + DO 200 I=-KFQEXC,KFQEXC,2*KFQEXC + DO 190 ISDE=1,2 + IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 190 + IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 190 + HI=HP + IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) + IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4)) + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=HI*FACBW*HF + 190 CONTINUE + 200 CONTINUE + ENDIF + + ELSEIF(ISUB.LE.190) THEN + IF(ISUB.EQ.162) THEN +C...q + g -> LQ + lbar; LQ=leptoquark + SQMLQ=PMAS(42,1)**2 + FACLQ=COMFAC*FACA*PARU(151)*(AS*AEM/6D0)*(-TH/SH)* + & (UH2+SQMLQ**2)/(UH-SQMLQ)**2 + KFLQQ=KFDP(MDCY(42,2),1) + DO 220 I=MMINA,MMAXA + IF(IABS(I).NE.KFLQQ) GOTO 220 + KCHLQ=ISIGN(1,I) + DO 210 ISDE=1,2 + IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 210 + IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 210 + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACLQ*WIDS(42,(5-KCHLQ)/2) + 210 CONTINUE + 220 CONTINUE + + ELSEIF(ISUB.EQ.163) THEN +C...g + g -> LQ + LQbar; LQ=leptoquark + SQMLQ=PMAS(42,1)**2 + FACLQ=COMFAC*FACA*WIDS(42,1)*(AS**2/2D0)* + & (7D0/48D0+3D0*(UH-TH)**2/(16D0*SH2))*(1D0+2D0*SQMLQ*TH/ + & (TH-SQMLQ)**2+2D0*SQMLQ*UH/(UH-SQMLQ)**2+4D0*SQMLQ**2/ + & ((TH-SQMLQ)*(UH-SQMLQ))) + IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 230 + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 +C...Since don't know proper colour flow, randomize between alternatives + ISIG(NCHN,3)=INT(1.5D0+PYR(0)) + SIGH(NCHN)=FACLQ + 230 CONTINUE + + ELSEIF(ISUB.EQ.164) THEN +C...q + qbar -> LQ + LQbar; LQ=leptoquark + DELTA=0.25D0*(SQM3-SQM4)**2/SH + SQMLQ=0.5D0*(SQM3+SQM4)-DELTA + TH=TH-DELTA + UH=UH-DELTA +C SQMLQ=PMAS(42,1)**2 + FACLQA=COMFAC*WIDS(42,1)*(AS**2/9D0)* + & (SH*(SH-4D0*SQMLQ)-(UH-TH)**2)/SH2 + FACLQS=COMFAC*WIDS(42,1)*((PARU(151)**2*AEM**2/8D0)* + & (-SH*TH-(SQMLQ-TH)**2)/TH2+(PARU(151)*AEM*AS/18D0)* + & ((SQMLQ-TH)*(UH-TH)+SH*(SQMLQ+TH))/(SH*TH)) + KFLQQ=KFDP(MDCY(42,2),1) + DO 240 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR. + & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 240 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACLQA + IF(IABS(I).EQ.KFLQQ) SIGH(NCHN)=FACLQA+FACLQS + 240 CONTINUE + + ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN +C...q + q' -> q" + d* and q + q' -> q" + u* (excited quarks) + KFQSTR=KFPR(ISUB,2) + KCQSTR=PYCOMP(KFQSTR) + KFQEXC=MOD(KFQSTR,KEXCIT) + FACQSA=COMFAC*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH) + FACQSB=COMFAC*0.25D0*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)* + & (1D0+SQM4/SH)*(1D0+CTH)*(1D0+((SH-SQM4)/(SH+SQM4))*CTH) +C...Propagators: as simulated in PYOFSH and as desired + GMMQ=PMAS(KCQSTR,1)*PMAS(KCQSTR,2) + HBW4=GMMQ/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQ**2) + CALL PYWIDT(KFQSTR,SQM4,WDTP,WDTE) + GMMQC=SQRT(SQM4)*WDTP(0) + HBW4C=GMMQC/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQC**2) + FACQSA=FACQSA*HBW4C/HBW4 + FACQSB=FACQSB*HBW4C/HBW4 +C...Branching ratios. + BRPOS=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0) + BRNEG=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0) + DO 260 I=MMIN1,MMAX1 + IA=IABS(I) + IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 260 + DO 250 J=MMIN2,MMAX2 + JA=IABS(J) + IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 250 + IF(IA.EQ.KFQEXC.AND.I.EQ.J) THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + IF(I.GT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRPOS + IF(I.LT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRNEG + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=2 + IF(J.GT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRPOS + IF(J.LT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRNEG + ELSEIF((IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC).AND.I*J.GT.0) THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2 + IF(ISIG(NCHN,ISIG(NCHN,3)).GT.0) SIGH(NCHN)=FACQSA*BRPOS + IF(ISIG(NCHN,ISIG(NCHN,3)).LT.0) SIGH(NCHN)=FACQSA*BRNEG + ELSEIF(IA.EQ.KFQEXC.AND.I.EQ.-J) THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + IF(I.GT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRPOS + IF(I.LT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRNEG + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=2 + IF(J.GT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRPOS + IF(J.LT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRNEG + ELSEIF(I.EQ.-J) THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + IF(I.GT.0) SIGH(NCHN)=FACQSB*BRPOS + IF(I.LT.0) SIGH(NCHN)=FACQSB*BRNEG + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=2 + IF(J.GT.0) SIGH(NCHN)=FACQSB*BRPOS + IF(J.LT.0) SIGH(NCHN)=FACQSB*BRNEG + ELSEIF(IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC) THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2 + IF(ISIG(NCHN,ISIG(NCHN,3)).GT.0) SIGH(NCHN)=FACQSB*BRPOS + IF(ISIG(NCHN,ISIG(NCHN,3)).LT.0) SIGH(NCHN)=FACQSB*BRNEG + ENDIF + 250 CONTINUE + 260 CONTINUE + + ELSEIF(ISUB.EQ.169) THEN +C...q + qbar -> e + e* (excited lepton) + KFQSTR=KFPR(ISUB,2) + KCQSTR=PYCOMP(KFQSTR) + KFQEXC=MOD(KFQSTR,KEXCIT) + FACQSB=(COMFAC/12D0)*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)* + & (1D0+SQM4/SH)*(1D0+CTH)*(1D0+((SH-SQM4)/(SH+SQM4))*CTH) +C...Propagators: as simulated in PYOFSH and as desired + GMMQ=PMAS(KCQSTR,1)*PMAS(KCQSTR,2) + HBW4=GMMQ/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQ**2) + CALL PYWIDT(KFQSTR,SQM4,WDTP,WDTE) + GMMQC=SQRT(SQM4)*WDTP(0) + HBW4C=GMMQC/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQC**2) + FACQSB=FACQSB*HBW4C/HBW4 +C...Branching ratios. + BRPOS=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0) + BRNEG=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0) + DO 270 I=MMIN1,MMAX1 + IA=IABS(I) + IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 270 + J=-I + JA=IABS(J) + IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 270 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + IF(I.GT.0) SIGH(NCHN)=FACQSB*BRPOS + IF(I.LT.0) SIGH(NCHN)=FACQSB*BRNEG + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=2 + IF(J.GT.0) SIGH(NCHN)=FACQSB*BRPOS + IF(J.LT.0) SIGH(NCHN)=FACQSB*BRNEG + 270 CONTINUE + ENDIF + + ELSEIF(ISUB.LE.360) THEN + IF(ISUB.EQ.341.OR.ISUB.EQ.342) THEN +C...l + l -> H_L++/-- or H_R++/--. + KFRES=KFPR(ISUB,1) + KFREC=PYCOMP(KFRES) + CALL PYWIDT(KFRES,SH,WDTP,WDTE) + HS=SHR*WDTP(0) + FACBW=8D0*COMFAC/((SH-PMAS(KFREC,1)**2)**2+HS**2) + DO 290 I=MMIN1,MMAX1 + IA=IABS(I) + IF((IA.NE.11.AND.IA.NE.13.AND.IA.NE.15).OR.KFAC(1,I).EQ.0) + & GOTO 290 + DO 280 J=MMIN2,MMAX2 + JA=IABS(J) + IF((JA.NE.11.AND.JA.NE.13.AND.JA.NE.15).OR.KFAC(2,J).EQ.0) + & GOTO 280 + IF(I*J.LT.0) GOTO 280 + KCHH=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + HI=SH*PARP(181+3*((IA-11)/2)+(JA-11)/2)**2/(8D0*PARU(1)) + HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4)) + SIGH(NCHN)=HI*FACBW*HF + 280 CONTINUE + 290 CONTINUE + + ELSEIF(ISUB.GE.343.AND.ISUB.LE.348) THEN +C...l + gamma -> H_L++/-- l' or l + gamma -> H_R++/-- l'. + KFRES=KFPR(ISUB,1) + KFREC=PYCOMP(KFRES) +C...Propagators: as simulated in PYOFSH and as desired + HBW3=PMAS(KFREC,1)*PMAS(KFREC,2)/((SQM3-PMAS(KFREC,1)**2)**2+ + & (PMAS(KFREC,1)*PMAS(KFREC,2))**2) + CALL PYWIDT(KFRES,SQM3,WDTP,WDTE) + GMMC=SQRT(SQM3)*WDTP(0) + HBW3C=GMMC/((SQM3-PMAS(KFREC,1)**2)**2+GMMC**2) + FHCC=COMFAC*AEM*HBW3C/HBW3 + DO 310 I=MMINA,MMAXA + IA=IABS(I) + IF(IA.NE.11.AND.IA.NE.13.AND.IA.NE.15) GOTO 310 + SQML=PMAS(IA,1)**2 + J=ISIGN(KFPR(ISUB,2),-I) + KCHH=ISIGN(2,KCHG(IA,1)*ISIGN(1,I)) + WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))/WDTP(0) + SMM1=8D0*(SH+TH-SQM3)*(SH+TH-2D0*SQM3-SQML-SQM4)/ + & (UH-SQM3)**2 + SMM2=2D0*((2D0*SQM3-3D0*SQML)*SQM4+(SQML-2D0*SQM4)*TH- + & (TH-SQM4)*SH)/(TH-SQM4)**2 + SMM3=2D0*((2D0*SQM3-3D0*SQM4+TH)*SQML-(2D0*SQML-SQM4+TH)* + & SH)/(SH-SQML)**2 + SMM12=4D0*((2D0*SQML-SQM4-2D0*SQM3+TH)*SH+(TH-3D0*SQM3- + & 3D0*SQM4)*TH+(2D0*SQM3-2D0*SQML+3D0*SQM4)*SQM3)/ + & ((UH-SQM3)*(TH-SQM4)) + SMM13=-4D0*((TH+SQML-2D0*SQM4)*TH-(SQM3+3D0*SQML-2D0*SQM4)* + & SQM3+(SQM3+3D0*SQML+TH)*SH-(TH-SQM3+SH)**2)/ + & ((UH-SQM3)*(SH-SQML)) + SMM23=-4D0*((SQML-SQM4+SQM3)*TH-SQM3**2+SQM3*(SQML+SQM4)- + & 3D0*SQML*SQM4-(SQML-SQM4-SQM3+TH)*SH)/ + & ((SH-SQML)*(TH-SQM4)) + SMM=(SH/(SH-SQML))**2*(SMM1+SMM2+SMM3+SMM12+SMM13+SMM23)* + & PARP(181+3*((IA-11)/2)+(IABS(J)-11)/2)**2/(4D0*PARU(1)) + DO 300 ISDE=1,2 + IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 300 + IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 300 + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=22 + ISIG(NCHN,3)=0 + SIGH(NCHN)=FHCC*SMM*WIDSC + 300 CONTINUE + 310 CONTINUE + + ELSEIF(ISUB.EQ.349.OR.ISUB.EQ.350) THEN +C...f + fbar -> H_L++ + H_L-- or H_R++ + H_R-- + KFRES=KFPR(ISUB,1) + KFREC=PYCOMP(KFRES) + SQMH=PMAS(KFREC,1)**2 + GMMH=PMAS(KFREC,1)*PMAS(KFREC,2) +C...Propagators: H++/-- as simulated in PYOFSH and as desired + HBW3=GMMH/((SQM3-SQMH)**2+GMMH**2) + CALL PYWIDT(KFRES,SQM3,WDTP,WDTE) + GMMH3=SQRT(SQM3)*WDTP(0) + HBW3C=GMMH3/((SQM3-SQMH)**2+GMMH3**2) + HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2) + CALL PYWIDT(KFRES,SQM4,WDTP,WDTE) + GMMH4=SQRT(SQM4)*WDTP(0) + HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2) +C...Kinematical and coupling functions + FACHH=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)*(TH*UH-SQM3*SQM4) + XWHH=(1D0-2D0*XWV)/(8D0*XWV*(1D0-XWV)) +C...Loop over allowed flavours + DO 320 I=MMINA,MMAXA + IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 320 + EI=KCHG(IABS(I),1)/3D0 + AI=SIGN(1D0,EI+0.1D0) + VI=AI-4D0*EI*XWV + FCOI=1D0 + IF(IABS(I).LE.10) FCOI=FACA/3D0 + IF(ISUB.EQ.349) THEN + HBWZ=1D0/((SH-SQMZ)**2+GMMZ**2) + IF(IABS(I).LT.10) THEN + DSIGHH=8D0*AEM**2*(EI**2/SH2+ + & 2D0*EI*VI*XWHH*(SH-SQMZ)*HBWZ/SH+ + & (VI**2+AI**2)*XWHH**2*HBWZ) + ELSE + IAOFF=181+3*((IABS(I)-11)/2) + HSUM=(PARP(IAOFF)**2+PARP(IAOFF+1)**2+PARP(IAOFF+2)**2)/ + & (4D0*PARU(1)) + DSIGHH=8D0*AEM**2*(EI**2/SH2+ + & 2D0*EI*VI*XWHH*(SH-SQMZ)*HBWZ/SH+ + & (VI**2+AI**2)*XWHH**2*HBWZ)+ + & 8D0*AEM*(EI*HSUM/(SH*TH)+ + & (VI+AI)*XWHH*HSUM*(SH-SQMZ)*HBWZ/TH)+ + & 4D0*HSUM**2/TH2 + ENDIF + ELSE + IF(IABS(I).LT.10) THEN + DSIGHH=8D0*AEM**2*EI**2/SH2 + ELSE + IAOFF=181+3*((IABS(I)-11)/2) + HSUM=(PARP(IAOFF)**2+PARP(IAOFF+1)**2+PARP(IAOFF+2)**2)/ + & (4D0*PARU(1)) + DSIGHH=8D0*AEM**2*EI**2/SH2+8D0*AEM*EI*HSUM/(SH*TH)+ + & 4D0*HSUM**2/TH2 + ENDIF + ENDIF + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACHH*FCOI*DSIGHH + 320 CONTINUE + + ELSEIF(ISUB.EQ.351.OR.ISUB.EQ.352) THEN +C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/-- as inner process) + KFRES=KFPR(ISUB,1) + KFREC=PYCOMP(KFRES) + SQMH=PMAS(KFREC,1)**2 + IF(ISUB.EQ.351) FACNOR=PARP(190)**8*PARP(192)**2 + IF(ISUB.EQ.352) FACNOR=PARP(191)**6*2D0* + & PMAS(PYCOMP(9900024),1)**2 + FACWW=COMFAC*FACNOR*TAUP*VINT(2)*VINT(219) + FACPRT=1D0/((VINT(204)**2-VINT(215))* + & (VINT(209)**2-VINT(216))) + FACPRU=1D0/((VINT(204)**2+2D0*VINT(217))* + & (VINT(209)**2+2D0*VINT(218))) + CALL PYWIDT(KFRES,SH,WDTP,WDTE) + HS=SHR*WDTP(0) + FACBW=(1D0/PARU(1))*VINT(2)/((SH-SQMH)**2+HS**2) + IF(ABS(SHR-PMAS(KFREC,1)).GT.PARP(48)*PMAS(KFREC,2)) + & FACBW=0D0 + DO 340 I=MMIN1,MMAX1 + IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 340 + IF(ISUB.EQ.352.AND.IABS(I).GT.10) GOTO 340 + KCHWI=(1-2*MOD(IABS(I),2))*ISIGN(1,I) + DO 330 J=MMIN2,MMAX2 + IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 330 + IF(ISUB.EQ.352.AND.IABS(J).GT.10) GOTO 330 + KCHWJ=(1-2*MOD(IABS(J),2))*ISIGN(1,J) + KCHH=KCHWI+KCHWJ + IF(IABS(KCHH).NE.2) GOTO 330 + FACLR=VINT(180+I)*VINT(180+J) + HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4)) + IF(I.EQ.J.AND.IABS(I).GT.10) THEN + FACPRP=0.5D0*(FACPRT+FACPRU)**2 + ELSE + FACPRP=FACPRT**2 + ENDIF + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACLR*FACWW*FACPRP*FACBW*HF + 330 CONTINUE + 340 CONTINUE + + ELSEIF(ISUB.EQ.353) THEN +C...f + fbar -> Z_R0 + SQMZR=PMAS(PYCOMP(KFPR(ISUB,1)),1)**2 + CALL PYWIDT(KFPR(ISUB,1),SH,WDTP,WDTE) + HS=SHR*WDTP(0) + FACBW=4D0*COMFAC/((SH-SQMZR)**2+HS**2)*3D0 + HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) + HP=(AEM/(3D0*(1D0-2D0*XW)))*XWC*SH + DO 350 I=MMINA,MMAXA + IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 350 + IF(IABS(I).LE.8) THEN + EI=KCHG(IABS(I),1)/3D0 + AI=SIGN(1D0,EI+0.1D0)*(1D0-2D0*XW) + VI=SIGN(1D0,EI+0.1D0)-4D0*EI*XW + ELSE + AI=-(1D0-2D0*XW) + VI=-1D0+4D0*XW + ENDIF + HI=HP*(VI**2+AI**2) + IF(IABS(I).LE.10) HI=HI*FACA/3D0 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=HI*FACBW*HF + 350 CONTINUE + + ELSEIF(ISUB.EQ.354) THEN +C...f + fbar' -> W_R+/- + SQMWR=PMAS(PYCOMP(KFPR(ISUB,1)),1)**2 + CALL PYWIDT(KFPR(ISUB,1),SH,WDTP,WDTE) + HS=SHR*WDTP(0) + FACBW=4D0*COMFAC/((SH-SQMWR)**2+HS**2)*3D0 + HP=AEM/(24D0*XW)*SH + DO 370 I=MMIN1,MMAX1 + IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 370 + IA=IABS(I) + DO 360 J=MMIN2,MMAX2 + IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 360 + JA=IABS(J) + IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 360 + IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10)) + & GOTO 360 + KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3 + HI=HP*2D0 + IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4)) + SIGH(NCHN)=HI*FACBW*HF + 360 CONTINUE + 370 CONTINUE + ENDIF + + ELSEIF(ISUB.LE.400) THEN + IF(ISUB.EQ.391) THEN +C...f + fbar -> G*. + KFGSTR=KFPR(ISUB,1) + KCGSTR=PYCOMP(KFGSTR) + CALL PYWIDT(KFGSTR,SH,WDTP,WDTE) + HS=SHR*WDTP(0) + HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) + FACG=COMFAC*PARP(50)**2/(16D0*PARU(1))*SH*HF/ + & ((SH-PMAS(KCGSTR,1)**2)**2+HS**2) +C...Modify cross section in wings of peak. + FACG = FACG * SH**2 / PMAS(KCGSTR,1)**4 + DO 380 I=MMINA,MMAXA + IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 380 + HI=1D0 + IF(IABS(I).LE.10) HI=HI*FACA/3D0 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACG*HI + 380 CONTINUE + + ELSEIF(ISUB.EQ.392) THEN +C...g + g -> G*. + KFGSTR=KFPR(ISUB,1) + KCGSTR=PYCOMP(KFGSTR) + CALL PYWIDT(KFGSTR,SH,WDTP,WDTE) + HS=SHR*WDTP(0) + HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) + FACG=COMFAC*PARP(50)**2/(32D0*PARU(1))*SH*HF/ + & ((SH-PMAS(KCGSTR,1)**2)**2+HS**2) +C...Modify cross section in wings of peak. + FACG = FACG * SH**2 / PMAS(KCGSTR,1)**4 + IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 390 + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACG + 390 CONTINUE + + ELSEIF(ISUB.EQ.393) THEN +C...q + qbar -> g + G*. + KFGSTR=KFPR(ISUB,2) + KCGSTR=PYCOMP(KFGSTR) + FACG=COMFAC*PARP(50)**2*AS*SH/(72D0*PARU(1)*SQM4)* + & (4D0*(TH2+UH2)/SH2+9D0*(TH+UH)/SH+(TH2/UH+UH2/TH)/SH+ + & 3D0*(4D0+TH/UH+UH/TH)+4D0*(SH/UH+SH/TH)+ + & 2D0*SH2/(TH*UH)) +C...Propagators: as simulated in PYOFSH and as desired + GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2) + HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2) + CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE) + HS=SQRT(SQM4)*WDTP(0) + HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) + HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2) + FACG=FACG*HBW4C/HBW4 + DO 400 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR. + & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACG + 400 CONTINUE + + ELSEIF(ISUB.EQ.394) THEN +C...q + g -> q + G*. + KFGSTR=KFPR(ISUB,2) + KCGSTR=PYCOMP(KFGSTR) + FACG=-COMFAC*PARP(50)**2*AS*SH/(192D0*PARU(1)*SQM4)* + & (4D0*(SH2+UH2)/(TH*SH)+9D0*(SH+UH)/SH+SH/UH+UH2/SH2+ + & 3D0*TH*(4D0+SH/UH+UH/SH)/SH+4D0*TH2*(1D0/UH+1D0/SH)/SH+ + & 2D0*TH2*TH/(UH*SH2)) +C...Propagators: as simulated in PYOFSH and as desired + GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2) + HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2) + CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE) + HS=SQRT(SQM4)*WDTP(0) + HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) + HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2) + FACG=FACG*HBW4C/HBW4 + DO 420 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 420 + DO 410 ISDE=1,2 + IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 410 + IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 410 + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACG + 410 CONTINUE + 420 CONTINUE + + ELSEIF(ISUB.EQ.395) THEN +C...g + g -> g + G*. + KFGSTR=KFPR(ISUB,2) + KCGSTR=PYCOMP(KFGSTR) + FACG=COMFAC*3D0*PARP(50)**2*AS*SH/(32D0*PARU(1)*SQM4)* + & ((TH2+TH*UH+UH2)**2/(SH2*TH*UH)+2D0*(TH2/UH+UH2/TH)/SH+ + & 3D0*(TH/UH+UH/TH)+2D0*(SH/UH+SH/TH)+SH2/(TH*UH)) +C...Propagators: as simulated in PYOFSH and as desired + GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2) + HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2) + CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE) + HS=SQRT(SQM4)*WDTP(0) + HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) + HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2) + FACG=FACG*HBW4C/HBW4 + IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACG + ENDIF + ENDIF + ELSEIF(ISUB.LE.500) THEN + IF(ISUBSV.EQ.481) ISUB=482 +c... GENERIC 2->(1)->2 + IF(ISUB.EQ.482) THEN + KFRES=9900001 + KCRES=PYCOMP(KFRES) + IF(KCRES.EQ.0) RETURN + IDCY=MDCY(KCRES,2) + KCOL=KCHG(KCRES,2) + KCEM=KCHG(KCRES,1) + FACT=COMFAC + KCF1=PYCOMP(KFPR(ISUB,1)) + KCF2=PYCOMP(KFPR(ISUB,2)) + IF(ISUBSV.EQ.481) THEN + SQMZR=PMAS(KCRES,1)**2 + CALL PYWIDT(KFRES,SH,WDTP,WDTE) + HS=SHR*WDTP(0) + FACBW=SH2/((SH-SQMZR)**2+HS**2) + FACT=FACT*FACBW + ELSE + SQMH=PMAS(KCF1,1)**2 + GMMH=PMAS(KCF1,1)*PMAS(KCF1,2) +C...Propagators: as simulated in PYOFSH and as desired + HBW3=GMMH/((SQM3-SQMH)**2+GMMH**2) + CALL PYWIDT(KFPR(ISUB,1),SQM3,WDTP,WDTE) + GMMH3=SQRT(SQM3)*WDTP(0) + HBW3C=GMMH3/((SQM3-SQMH)**2+GMMH3**2) + SQMH=PMAS(KCF2,1)**2 + GMMH=PMAS(KCF2,1)*PMAS(KCF2,2) + HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2) + CALL PYWIDT(KFPR(ISUB,2),SQM4,WDTP,WDTE) + GMMH4=SQRT(SQM4)*WDTP(0) + HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2) + FACT=FACT*(HBW3C/HBW3)*(HBW4C/HBW4) + ENDIF + + KCI1=ABS(PYCOMP(KFDP(IDCY,1))) + KCI2=ABS(PYCOMP(KFDP(IDCY,2))) + JCOL1=SIGN(KCHG(KCF1,2),KFPR(ISUB,1)) + JCOL2=SIGN(KCHG(KCF2,2),KFPR(ISUB,2)) + IF(KCOL.EQ.0) THEN + NCOL=1 + ELSEIF(KCI1.EQ.21.AND.KCI2.EQ.21.AND.KCOL.EQ.2) THEN + IF(JCOL1.EQ.2.AND.JCOL2.EQ.2) THEN + NCOL=3 + ELSE + NCOL=2 + ENDIF + ELSEIF(KCOL.EQ.-1.OR.KCOL.EQ.1) THEN + NCOL=2 + ELSEIF(KCI1.EQ.21.AND.KCI2.EQ.21.AND.JCOL1.EQ.0.AND. + $ JCOL2.EQ.0) THEN + NCOL=1 + ELSEIF(KCOL.EQ.2.AND.((JCOL1.EQ.0.AND.JCOL2.EQ.2).OR. + $ (JCOL1.EQ.2.AND.JCOL2.EQ.0))) THEN + NCOL=1 + ELSE + NCOL=2 + ENDIF + DO 440 I=MMIN1,MMAX1 + IF(KFAC(1,I).EQ.0) GOTO 440 + IP=I + IF(IP.EQ.0) IP=21 + IA=ABS(IP) + DO 430 J=MMIN2,MMAX2 + IF(KFAC(2,J).EQ.0) GOTO 430 + JP=J + IF(JP.EQ.0) JP=21 + JA=ABS(JP) + IF((IA.EQ.KCI1.AND.JA.EQ.KCI2).OR. + $ (JA.EQ.KCI1.AND.IA.EQ.KCI2)) THEN + KCHW=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J) + IF(ABS(KCHW).EQ.ABS(KCEM)) THEN + DO II=1,NCOL + NCHN=NCHN+1 + ISIG(NCHN,1)=IP + ISIG(NCHN,2)=JP + ISIG(NCHN,3)=II + SIGH(NCHN)=FACT/NCOL + ENDDO + ENDIF + ENDIF + 430 CONTINUE + 440 CONTINUE + ENDIF + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYPDFU +C...Gives electron, muon, tau, photon, pi+, neutron, proton and hyperon +C...parton distributions according to a few different parametrizations. +C...Note that what is coded is x times the probability distribution, +C...i.e. xq(x,Q2) etc. + + SUBROUTINE PYPDFU(KF,X,Q2,XPQ) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6), + &XPDIR(-6:6) + COMMON/PYINT9/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6) + COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6), + & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1), + & XMI(2,240),PT2MI(240),IMISEP(0:240) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT8/, + &/PYINT9/,/PYINTM/ +C...Local arrays. + DIMENSION XPQ(-25:25),XPEL(-25:25),XPGA(-6:6),VXPGA(-6:6), + &XPPI(-6:6),XPPR(-6:6),XPVAL(-6:6),PPAR(6,2) + SAVE PPAR + +C...Interface to PDFLIB. + COMMON/W50513/XMIN,XMAX,Q2MIN,Q2MAX + SAVE /W50513/ + DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU, + &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX + CHARACTER*20 PARM(20) + DATA VALUE/20*0D0/,PARM/20*' '/ +C--use nuclear pdf? + COMMON/NPDF/MASS,NSET,EPS09,INITSTR + INTEGER NSET + DOUBLE PRECISION MASS + LOGICAL EPS09 + CHARACTER*10 INITSTR + +C...Data related to Schuler-Sjostrand photon distributions. + DATA ALAMGA/0.2D0/, PMCGA/1.3D0/, PMBGA/4.6D0/ + +C...Valence PDF momentum integral parametrizations PER PARTON! + DATA (PPAR(1,IPAR),IPAR=1,2) /0.385D0,1.60D0/ + DATA (PPAR(2,IPAR),IPAR=1,2) /0.480D0,1.56D0/ + PAVG(IFL,Q2)=PPAR(IFL,1)/(1D0+PPAR(IFL,2)* + &LOG(LOG(MAX(Q2,1D0)/0.04D0))) + +C...Reset parton distributions. + MINT(92)=0 + DO 100 KFL=-25,25 + XPQ(KFL)=0D0 + 100 CONTINUE + DO 110 KFL=-6,6 + XPVAL(KFL)=0D0 + 110 CONTINUE + +C...Check x and particle species. + IF(X.LE.0D0.OR.X.GE.1D0) THEN + WRITE(MSTU(11),5000) X + GOTO 9999 + ENDIF + KFA=IABS(KF) + IF(KFA.NE.11.AND.KFA.NE.13.AND.KFA.NE.15.AND.KFA.NE.22.AND. + &KFA.NE.211.AND.KFA.NE.2112.AND.KFA.NE.2212.AND.KFA.NE.3122.AND. + &KFA.NE.3112.AND.KFA.NE.3212.AND.KFA.NE.3222.AND.KFA.NE.3312.AND. + &KFA.NE.3322.AND.KFA.NE.3334.AND.KFA.NE.111.AND.KFA.NE.321.AND. + &KFA.NE.310.AND.KFA.NE.130) THEN + WRITE(MSTU(11),5100) KF + GOTO 9999 + ENDIF + +C...Electron (or muon or tau) parton distribution call. + IF(KFA.EQ.11.OR.KFA.EQ.13.OR.KFA.EQ.15) THEN + CALL PYPDEL(KFA,X,Q2,XPEL) + DO 120 KFL=-25,25 + XPQ(KFL)=XPEL(KFL) + 120 CONTINUE + +C...Photon parton distribution call (VDM+anomalous). + ELSEIF(KFA.EQ.22.AND.MINT(109).LE.1) THEN + IF(MSTP(56).EQ.1.AND.MSTP(55).EQ.1) THEN + CALL PYPDGA(X,Q2,XPGA) + DO 130 KFL=-6,6 + XPQ(KFL)=XPGA(KFL) + 130 CONTINUE + XPVU=4D0*(XPQ(2)-XPQ(1))/3D0 + XPVAL(1)=XPVU/4D0 + XPVAL(2)=XPVU + XPVAL(3)=MIN(XPQ(3),XPVU/4D0) + XPVAL(4)=MIN(XPQ(4),XPVU) + XPVAL(5)=MIN(XPQ(5),XPVU/4D0) + XPVAL(-1)=XPVAL(1) + XPVAL(-2)=XPVAL(2) + XPVAL(-3)=XPVAL(3) + XPVAL(-4)=XPVAL(4) + XPVAL(-5)=XPVAL(5) + ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.MSTP(55).LE.8) THEN + Q2MX=Q2 + P2MX=0.36D0 + IF(MSTP(55).GE.7) P2MX=4.0D0 + IF(MSTP(57).EQ.0) Q2MX=P2MX + P2=0D0 + IF(VINT(120).LT.0D0) P2=VINT(120)**2 + CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,MSTP(60),F2GAM,XPGA) + DO 140 KFL=-6,6 + XPQ(KFL)=XPGA(KFL) + XPVAL(KFL)=VXPDGM(KFL) + 140 CONTINUE + VINT(231)=P2MX + ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.9.AND.MSTP(55).LE.12) THEN + Q2MX=Q2 + P2MX=0.36D0 + IF(MSTP(55).GE.11) P2MX=4.0D0 + IF(MSTP(57).EQ.0) Q2MX=P2MX + P2=0D0 + IF(VINT(120).LT.0D0) P2=VINT(120)**2 + CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,MSTP(60),F2GAM,XPGA) + DO 150 KFL=-6,6 + XPQ(KFL)=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL) + XPVAL(KFL)=VXPVMD(KFL)+VXPANL(KFL)+XPBEH(KFL)+XPDIR(KFL) + 150 CONTINUE + VINT(231)=P2MX + ELSEIF(MSTP(56).EQ.2) THEN +C...Call PDFLIB parton distributions. + PARM(1)='NPTYPE' + VALUE(1)=3 + PARM(2)='NGROUP' + VALUE(2)=MSTP(55)/1000 + PARM(3)='NSET' + VALUE(3)=MOD(MSTP(55),1000) + IF(MINT(93).NE.3000000+MSTP(55)) THEN + CALL PDFSET(PARM,VALUE) + MINT(93)=3000000+MSTP(55) + ENDIF + XX=X + QQ2=MAX(0D0,Q2MIN,Q2) + IF(MSTP(57).EQ.0) QQ2=Q2MIN + P2=0D0 + IF(VINT(120).LT.0D0) P2=VINT(120)**2 + IP2=MSTP(60) + IF(MSTP(55).EQ.5004) THEN + IF(5D0*P2.LT.QQ2.AND. + & QQ2.GT.0.6D0.AND.QQ2.LT.5D4.AND. + & P2.GE.0D0.AND.P2.LT.10D0.AND. + & XX.GT.1D-4.AND.XX.LT.1D0) THEN + CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM, + & BOT,TOP,GLU) + ELSE + UPV=0D0 + DNV=0D0 + USEA=0D0 + DSEA=0D0 + STR=0D0 + CHM=0D0 + BOT=0D0 + TOP=0D0 + GLU=0D0 + ENDIF + ELSE + IF(P2.LT.QQ2) THEN + CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM, + & BOT,TOP,GLU) + ELSE + UPV=0D0 + DNV=0D0 + USEA=0D0 + DSEA=0D0 + STR=0D0 + CHM=0D0 + BOT=0D0 + TOP=0D0 + GLU=0D0 + ENDIF + ENDIF + VINT(231)=Q2MIN + XPQ(0)=GLU + XPQ(1)=DNV + XPQ(-1)=DNV + XPQ(2)=UPV + XPQ(-2)=UPV + XPQ(3)=STR + XPQ(-3)=STR + XPQ(4)=CHM + XPQ(-4)=CHM + XPQ(5)=BOT + XPQ(-5)=BOT + XPQ(6)=TOP + XPQ(-6)=TOP + XPVU=4D0*(XPQ(2)-XPQ(1))/3D0 + XPVAL(1)=XPVU/4D0 + XPVAL(2)=XPVU + XPVAL(3)=MIN(XPQ(3),XPVU/4D0) + XPVAL(4)=MIN(XPQ(4),XPVU) + XPVAL(5)=MIN(XPQ(5),XPVU/4D0) + XPVAL(-1)=XPVAL(1) + XPVAL(-2)=XPVAL(2) + XPVAL(-3)=XPVAL(3) + XPVAL(-4)=XPVAL(4) + XPVAL(-5)=XPVAL(5) + ELSE + WRITE(MSTU(11),5200) KF,MSTP(56),MSTP(55) + ENDIF + +C...Pion/gammaVDM parton distribution call. + ELSEIF(KFA.EQ.211.OR.KFA.EQ.111.OR.KFA.EQ.321.OR.KFA.EQ.130.OR. + &KFA.EQ.310.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN + IF(KFA.EQ.22.AND.MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND. + & MSTP(55).LE.12) THEN + ISET=1+MOD(MSTP(55)-1,4) + Q2MX=Q2 + P2MX=0.36D0 + IF(ISET.GE.3) P2MX=4.0D0 + IF(MSTP(57).EQ.0) Q2MX=P2MX + P2=0D0 + IF(VINT(120).LT.0D0) P2=VINT(120)**2 + CALL PYGGAM(ISET,X,Q2MX,P2,MSTP(60),F2GAM,XPGA) + DO 160 KFL=-6,6 + XPQ(KFL)=XPVMD(KFL) + XPVAL(KFL)=VXPVMD(KFL) + 160 CONTINUE + VINT(231)=P2MX + ELSEIF(MSTP(54).EQ.1.AND.MSTP(53).GE.1.AND.MSTP(53).LE.3) THEN + CALL PYPDPI(X,Q2,XPPI) + DO 170 KFL=-6,6 + XPQ(KFL)=XPPI(KFL) + 170 CONTINUE + XPVAL(2)=XPQ(2)-XPQ(-2) + XPVAL(-1)=XPQ(-1)-XPQ(1) + ELSEIF(MSTP(54).EQ.2) THEN +C...Call PDFLIB parton distributions. + PARM(1)='NPTYPE' + VALUE(1)=2 + PARM(2)='NGROUP' + VALUE(2)=MSTP(53)/1000 + PARM(3)='NSET' + VALUE(3)=MOD(MSTP(53),1000) + IF(MINT(93).NE.2000000+MSTP(53)) THEN + CALL PDFSET(PARM,VALUE) + MINT(93)=2000000+MSTP(53) + ENDIF + XX=X + QQ=SQRT(MAX(0D0,Q2MIN,Q2)) + IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN) + CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU) + VINT(231)=Q2MIN + XPQ(0)=GLU + XPQ(1)=DSEA + XPQ(-1)=UPV+DSEA + XPQ(2)=UPV+USEA + XPQ(-2)=USEA + XPQ(3)=STR + XPQ(-3)=STR + XPQ(4)=CHM + XPQ(-4)=CHM + XPQ(5)=BOT + XPQ(-5)=BOT + XPQ(6)=TOP + XPQ(-6)=TOP + XPVAL(2)=UPV + XPVAL(-1)=UPV + ELSE + WRITE(MSTU(11),5200) KF,MSTP(54),MSTP(53) + ENDIF + +C...Anomalous photon parton distribution call. + ELSEIF(KFA.EQ.22.AND.MINT(109).EQ.3) THEN + Q2MX=Q2 + P2MX=PARP(15)**2 + IF(MSTP(56).EQ.1.AND.MSTP(55).LE.8) THEN + IF(MSTP(55).EQ.5.OR.MSTP(55).EQ.6) P2MX=0.36D0 + IF(MSTP(55).EQ.7.OR.MSTP(55).EQ.8) P2MX=4.0D0 + IF(MSTP(57).EQ.0) Q2MX=P2MX + P2=0D0 + IF(VINT(120).LT.0D0) P2=VINT(120)**2 + CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,MSTP(60),F2GM,XPGA) + DO 180 KFL=-6,6 + XPQ(KFL)=XPANL(KFL)+XPANH(KFL) + XPVAL(KFL)=VXPANL(KFL)+VXPANH(KFL) + 180 CONTINUE + VINT(231)=P2MX + ELSEIF(MSTP(56).EQ.1) THEN + IF(MSTP(55).EQ.9.OR.MSTP(55).EQ.10) P2MX=0.36D0 + IF(MSTP(55).EQ.11.OR.MSTP(55).EQ.12) P2MX=4.0D0 + IF(MSTP(57).EQ.0) Q2MX=P2MX + P2=0D0 + IF(VINT(120).LT.0D0) P2=VINT(120)**2 + CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,MSTP(60),F2GM,XPGA) + DO 190 KFL=-6,6 + XPQ(KFL)=MAX(0D0,XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)) + XPVAL(KFL)=MAX(0D0,VXPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)) + 190 CONTINUE + VINT(231)=P2MX + ELSEIF(MSTP(56).EQ.2) THEN + IF(MSTP(57).EQ.0) Q2MX=P2MX + CALL PYGANO(0,X,Q2MX,P2MX,ALAMGA,XPGA,VXPGA) + DO 200 KFL=-6,6 + XPQ(KFL)=XPGA(KFL) + XPVAL(KFL)=VXPGA(KFL) + 200 CONTINUE + VINT(231)=P2MX + ELSEIF(MSTP(55).GE.1.AND.MSTP(55).LE.5) THEN + IF(MSTP(57).EQ.0) Q2MX=P2MX + CALL PYGVMD(0,MSTP(55),X,Q2MX,P2MX,PARP(1),XPGA,VXPGA) + DO 210 KFL=-6,6 + XPQ(KFL)=XPGA(KFL) + XPVAL(KFL)=VXPGA(KFL) + 210 CONTINUE + VINT(231)=P2MX + ELSE + 220 RKF=11D0*PYR(0) + KFR=1 + IF(RKF.GT.1D0) KFR=2 + IF(RKF.GT.5D0) KFR=3 + IF(RKF.GT.6D0) KFR=4 + IF(RKF.GT.10D0) KFR=5 + IF(KFR.EQ.4.AND.Q2.LT.PMCGA**2) GOTO 220 + IF(KFR.EQ.5.AND.Q2.LT.PMBGA**2) GOTO 220 + IF(MSTP(57).EQ.0) Q2MX=P2MX + CALL PYGVMD(0,KFR,X,Q2MX,P2MX,PARP(1),XPGA,VXPGA) + DO 230 KFL=-6,6 + XPQ(KFL)=XPGA(KFL) + XPVAL(KFL)=VXPGA(KFL) + 230 CONTINUE + VINT(231)=P2MX + ENDIF + +C...Proton parton distribution call. + ELSE + IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.20) THEN + CALL PYPDPR(X,Q2,XPPR) + DO 240 KFL=-6,6 + XPQ(KFL)=XPPR(KFL) + 240 CONTINUE +C...Force VAL > 0 (can be < 0 at very small Q2 and small x apparently) + XPVAL(1)=MAX(0D0,XPQ(1)-XPQ(-1)) + XPVAL(2)=MAX(0D0,XPQ(2)-XPQ(-2)) + ELSEIF(MSTP(52).EQ.2) THEN +C...Call PDFLIB parton distributions. + PARM(1)='NPTYPE' + VALUE(1)=1 + PARM(2)='NGROUP' + VALUE(2)=MSTP(51)/1000 + PARM(3)='NSET' + VALUE(3)=MOD(MSTP(51),1000) + IF(MINT(93).NE.1000000+MSTP(51)) THEN + call setlhaparm('SILENT') + CALL PDFSET(PARM,VALUE) + MINT(93)=1000000+MSTP(51) + ENDIF + XX=X + QQ=SQRT(MAX(0D0,Q2MIN,Q2)) + IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN) + IF(EPS09)THEN + call setlhaparm(INITSTR) + CALL STRUCTA(XX,QQ,MASS,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP, + & GLU) + ELSE + CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU) + ENDIF + VINT(231)=Q2MIN + XPQ(0)=GLU + XPQ(1)=DNV+DSEA + XPQ(-1)=DSEA + XPQ(2)=UPV+USEA + XPQ(-2)=USEA + XPQ(3)=STR + XPQ(-3)=STR + XPQ(4)=CHM + XPQ(-4)=CHM + XPQ(5)=BOT + XPQ(-5)=BOT + XPQ(6)=TOP + XPQ(-6)=TOP + XPVAL(1)=DNV + XPVAL(2)=UPV + ELSE + WRITE(MSTU(11),5200) KF,MSTP(52),MSTP(51) + ENDIF + ENDIF + +C...Isospin average for pi0/gammaVDM. + IF(KFA.EQ.111.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN + IF(KFA.EQ.22.AND.MSTP(55).GE.5.AND.MSTP(55).LE.12) THEN + XPV=XPQ(2)-XPQ(1) + XPQ(2)=XPQ(1) + XPQ(-2)=XPQ(-1) + ELSE + XPS=0.5D0*(XPQ(1)+XPQ(-2)) + XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS + XPQ(2)=XPS + XPQ(-1)=XPS + ENDIF + XPVL=0.5D0*(XPVAL(1)+XPVAL(2)+XPVAL(-1)+XPVAL(-2))+ + & XPVAL(3)+XPVAL(4)+XPVAL(5) + DO 250 KFL=-6,6 + XPVAL(KFL)=0D0 + 250 CONTINUE + IF(KFA.EQ.22.AND.MINT(105).LE.223) THEN + XPQ(1)=XPQ(1)+0.2D0*XPV + XPQ(2)=XPQ(2)+0.8D0*XPV + XPVAL(1)=0.2D0*XPVL + XPVAL(2)=0.8D0*XPVL + ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.333) THEN + XPQ(3)=XPQ(3)+XPV + XPVAL(3)=XPVL + ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.443) THEN + XPQ(4)=XPQ(4)+XPV + XPVAL(4)=XPVL + IF(MSTP(55).GE.9) THEN + DO 260 KFL=-6,6 + XPQ(KFL)=0D0 + 260 CONTINUE + ENDIF + ELSE + XPQ(1)=XPQ(1)+0.5D0*XPV + XPQ(2)=XPQ(2)+0.5D0*XPV + XPVAL(1)=0.5D0*XPVL + XPVAL(2)=0.5D0*XPVL + ENDIF + DO 270 KFL=1,6 + XPQ(-KFL)=XPQ(KFL) + XPVAL(-KFL)=XPVAL(KFL) + 270 CONTINUE + +C...Rescale for gammaVDM by effective gamma -> rho coupling. +C+++Do not rescale? + IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND..NOT.(MSTP(56).EQ.1 + & .AND.MSTP(55).GE.5.AND.MSTP(55).LE.12)) THEN + DO 280 KFL=-6,6 + XPQ(KFL)=VINT(281)*XPQ(KFL) + XPVAL(KFL)=VINT(281)*XPVAL(KFL) + 280 CONTINUE + VINT(232)=VINT(281)*XPV + ENDIF + +C...Simple recipes for kaons. + ELSEIF(KFA.EQ.321) THEN + XPQ(-3)=XPQ(-3)+XPQ(-1)-XPQ(1) + XPQ(-1)=XPQ(1) + XPVAL(-3)=XPVAL(-1) + XPVAL(-1)=0D0 + ELSEIF(KFA.EQ.130.OR.KFA.EQ.310) THEN + XPS=0.5D0*(XPQ(1)+XPQ(-2)) + XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS + XPQ(2)=XPS + XPQ(-1)=XPS + XPQ(1)=XPQ(1)+0.5D0*XPV + XPQ(-1)=XPQ(-1)+0.5D0*XPV + XPQ(3)=XPQ(3)+0.5D0*XPV + XPQ(-3)=XPQ(-3)+0.5D0*XPV + XPV=0.5D0*(XPVAL(2)+XPVAL(-1)) + XPVAL(2)=0D0 + XPVAL(-1)=0D0 + XPVAL(1)=0.5D0*XPV + XPVAL(-1)=0.5D0*XPV + XPVAL(3)=0.5D0*XPV + XPVAL(-3)=0.5D0*XPV + +C...Isospin conjugation for neutron. + ELSEIF(KFA.EQ.2112) THEN + XPSV=XPQ(1) + XPQ(1)=XPQ(2) + XPQ(2)=XPSV + XPSV=XPQ(-1) + XPQ(-1)=XPQ(-2) + XPQ(-2)=XPSV + XPSV=XPVAL(1) + XPVAL(1)=XPVAL(2) + XPVAL(2)=XPSV + +C...Simple recipes for hyperon (average valence parton distribution). + ELSEIF(KFA.EQ.3122.OR.KFA.EQ.3112.OR.KFA.EQ.3212.OR.KFA.EQ.3222 + & .OR.KFA.EQ.3312.OR.KFA.EQ.3322.OR.KFA.EQ.3334) THEN + XPV=(XPQ(1)+XPQ(2)-XPQ(-1)-XPQ(-2))/3D0 + XPS=0.5D0*(XPQ(-1)+XPQ(-2)) + XPQ(1)=XPS + XPQ(2)=XPS + XPQ(-1)=XPS + XPQ(-2)=XPS + XPQ(KFA/1000)=XPQ(KFA/1000)+XPV + XPQ(MOD(KFA/100,10))=XPQ(MOD(KFA/100,10))+XPV + XPQ(MOD(KFA/10,10))=XPQ(MOD(KFA/10,10))+XPV + XPV=(XPVAL(1)+XPVAL(2))/3D0 + XPVAL(1)=0D0 + XPVAL(2)=0D0 + XPVAL(KFA/1000)=XPVAL(KFA/1000)+XPV + XPVAL(MOD(KFA/100,10))=XPVAL(MOD(KFA/100,10))+XPV + XPVAL(MOD(KFA/10,10))=XPVAL(MOD(KFA/10,10))+XPV + ENDIF + +C...Charge conjugation for antiparticle. + IF(KF.LT.0) THEN + DO 290 KFL=1,25 + IF(KFL.EQ.21.OR.KFL.EQ.22.OR.KFL.EQ.23.OR.KFL.EQ.25) GOTO 290 + XPSV=XPQ(KFL) + XPQ(KFL)=XPQ(-KFL) + XPQ(-KFL)=XPSV + 290 CONTINUE + DO 300 KFL=1,6 + XPSV=XPVAL(KFL) + XPVAL(KFL)=XPVAL(-KFL) + XPVAL(-KFL)=XPSV + 300 CONTINUE + ENDIF + +C...MULTIPLE INTERACTIONS - PDF RESHAPING. +C...Set side. + JS=MINT(30) +C...Only reshape PDFs for the non-first interactions; +C...But need valence/sea separation already from first interaction. + IF ((JS.EQ.1.OR.JS.EQ.2).AND.MINT(35).GE.2) THEN + KFVSEL=KFIVAL(JS,1) +C...If valence quark kicked out of pi0 or gamma then that decides +C...whether we should consider state as d dbar, u ubar, s sbar, etc. + IF(KFVSEL.NE.0.AND.(KFA.EQ.111.OR.KFA.EQ.22)) THEN + XPVL=0D0 + DO 310 KFL=1,6 + XPVL=XPVL+XPVAL(KFL) + XPQ(KFL)=MAX(0D0,XPQ(KFL)-XPVAL(KFL)) + XPVAL(KFL)=0D0 + 310 CONTINUE + XPQ(IABS(KFVSEL))=XPQ(IABS(KFVSEL))+XPVL + XPVAL(IABS(KFVSEL))=XPVL + DO 320 KFL=1,6 + XPQ(-KFL)=XPQ(KFL) + XPVAL(-KFL)=XPVAL(KFL) + 320 CONTINUE + +C...If valence quark kicked out of K0S or K0S then that decides whether +C...we should consider state as d sbar or s dbar. + ELSEIF(KFVSEL.NE.0.AND.(KFA.EQ.130.OR.KFA.EQ.310)) THEN + KFS=1 + IF(KFVSEL.EQ.-1.OR.KFVSEL.EQ.3) KFS=-1 + XPQ(KFS)=XPQ(KFS)+XPVAL(-KFS) + XPVAL(KFS)=XPVAL(KFS)+XPVAL(-KFS) + XPQ(-KFS)=MAX(0D0,XPQ(-KFS)-XPVAL(-KFS)) + XPVAL(-KFS)=0D0 + KFS=-3*KFS + XPQ(KFS)=XPQ(KFS)+XPVAL(-KFS) + XPVAL(KFS)=XPVAL(KFS)+XPVAL(-KFS) + XPQ(-KFS)=MAX(0D0,XPQ(-KFS)-XPVAL(-KFS)) + XPVAL(-KFS)=0D0 + ENDIF + +C...XPQ distributions are nominal for a (signed) beam particle +C...of KF type, with 1-Sum(x_prev) rescaled to 1. + CMPFAC=1D0 + NRESC=0 + 345 NRESC=NRESC+1 + PVCTOT(JS,-1)=0D0 + PVCTOT(JS, 0)=0D0 + PVCTOT(JS, 1)=0D0 + DO 350 IFL=-6,6 + IF(IFL.EQ.0) GOTO 350 + +C...Count up number of original IFL valence quarks. + IVORG=0 + IF(KFIVAL(JS,1).EQ.IFL) IVORG=IVORG+1 + IF(KFIVAL(JS,2).EQ.IFL) IVORG=IVORG+1 + IF(KFIVAL(JS,3).EQ.IFL) IVORG=IVORG+1 +C...For pi0/gamma/K0S/K0L without valence flavour decided yet, here +C...bookkeep as if d dbar (for total momentum sum in valence sector). + IF(KFIVAL(JS,1).EQ.0.AND.IABS(IFL).EQ.1) IVORG=1 +C...Count down number of remaining IFL valence quarks. Skip current +C...interaction initiator. + IVREM=IVORG + DO 330 I1=1,NMI(JS) + IF (I1.EQ.MINT(36)) GOTO 330 + IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0) + & IVREM=IVREM-1 + 330 CONTINUE + +C...Separate out original VALENCE and SEA content. + VAL=XPVAL(IFL) + SEA=MAX(0D0,XPQ(IFL)-VAL) + XPSVC(IFL,0)=VAL + XPSVC(IFL,-1)=SEA + +C...Rescale valence content if changed. + IF (IVORG.NE.0.AND.IVREM.NE.IVORG) XPSVC(IFL,0)= + & (VAL*IVREM)/IVORG + +C...Momentum integrals of original and removed valence quarks. + IF(IVORG.NE.0) THEN +C...For p/n/pbar/nbar beams can split into d_val and u_val. +C...Isospin conjugation for neutrons + IF(KFA.EQ.2212.OR.KFA.EQ.2112) THEN + IAFLP=IABS(IFL) + IF (KFA.EQ.2112) IAFLP=3-IAFLP + VPAVG=PAVG(IAFLP,Q2) +C...For other baryons average d_val and u_val, like for PDFs. + ELSEIF(KFA.GT.1000) THEN + VPAVG=(PAVG(1,Q2)+2D0*PAVG(2,Q2))/3D0 +C...For mesons and photon average d_val and u_val and scale by 3/2. +C...Very crude, especially for photon. + ELSE + VPAVG=0.5D0*(PAVG(1,Q2)+2D0*PAVG(2,Q2)) + ENDIF + PVCTOT(JS,-1)=PVCTOT(JS,-1)+IVORG*VPAVG + PVCTOT(JS, 0)=PVCTOT(JS, 0)+(IVORG-IVREM)*VPAVG + ENDIF + +C...Now add companions (at X with partner having been at Z=XASSOC). +C...NOTE: due to the assumed simple x scaling, the partner was at what +C...corresponds to a higher Z than XASSOC, if there were intermediate +C...scatterings. Nothing done about that for the moment. + DO 340 IVC=1,NVC(JS,IFL) +C...Skip companions that have been kicked out + IF (XASSOC(JS,IFL,IVC).LE.0D0) THEN + XPSVC(IFL,IVC)=0D0 + GOTO 340 + ELSE +C...Momentum fraction of the partner quark. +C...Use rescaled YS = XS/(1-Sum_rest) where X and XS are not in "rest". + XS=XASSOC(JS,IFL,IVC) + XREM=VINT(142+JS) + YS=XS/(XREM+XS) +C...Momentum fraction of the companion quark. +C...Rescale from X = x/XREM to Y = x/(1-Sum_rest) -> factor (1-YS). + Y=X*(1D0-YS) + XPSVC(IFL,IVC)=PYFCMP(Y/CMPFAC,YS/CMPFAC,MSTP(87)) +C...Add to momentum sum, with rescaling compensation factor. + XCFAC=(XREM+XS)/XREM*CMPFAC + PVCTOT(JS,1)=PVCTOT(JS,1)+XCFAC*PYPCMP(YS/CMPFAC,MSTP(87)) + ENDIF + 340 CONTINUE + 350 CONTINUE + +C...Wait until all flavours treated, then rescale seas and gluon. + XPSVC(0,-1)=XPQ(0) + XPSVC(0,0)=0D0 + RSFAC=1D0+(PVCTOT(JS,0)-PVCTOT(JS,1))/(1D0-PVCTOT(JS,-1)) + IF (RSFAC.LE.0D0) THEN +C...First calculate factor needed to exactly restore pz cons. + IF (NRESC.EQ.1) CMPFAC = + & (1D0-(PVCTOT(JS,-1)-PVCTOT(JS,0)))/PVCTOT(JS,1) +C...Add a bit of headroom + CMPFAC=0.99*CMPFAC +C...Try a few times if more headroom is needed, then print error message. + IF (NRESC.LE.10) GOTO 345 + CALL PYERRM(15, + & '(PYPDFU:) Negative reshaping factor persists!') + WRITE(MSTU(11),5300) (PVCTOT(JS,ITMP),ITMP=-1,1), RSFAC + RSFAC=0D0 + ENDIF + DO 370 IFL=-6,6 + XPSVC(IFL,-1)=RSFAC*XPSVC(IFL,-1) +C...Also store resulting distributions in XPQ + XPQ(IFL)=0D0 + DO 360 ISVC=-1,NVC(JS,IFL) + XPQ(IFL)=XPQ(IFL)+XPSVC(IFL,ISVC) + 360 CONTINUE + 370 CONTINUE +C...Save companion reweighting factor for PYPTIS. + VINT(140)=CMPFAC + ENDIF + + +C...Allow gluon also in position 21. + XPQ(21)=XPQ(0) + +C...Check positivity and reset above maximum allowed flavour. + DO 380 KFL=-25,25 + XPQ(KFL)=MAX(0D0,XPQ(KFL)) + IF(IABS(KFL).GT.MSTP(58).AND.IABS(KFL).LE.8) XPQ(KFL)=0D0 + 380 CONTINUE + +C...Formats for error printouts. + 5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3) + 5100 FORMAT(' Error: illegal particle code for parton distribution;', + &' KF =',I5) + 5200 FORMAT(' Error: unknown parton distribution; KF, library, set =', + &3I5) + 5300 FORMAT(' Original valence momentum fraction : ',F6.3/ + & ' Removed valence momentum fraction : ',F6.3/ + & ' Added companion momentum fraction : ',F6.3/ + & ' Resulting rescale factor : ',F6.3) + +C...Reset side pointer and return + 9999 MINT(30)=0 + + RETURN + END + +C********************************************************************* + +C...PYPDFL +C...Gives proton parton distribution at small x and/or Q^2 according to +C...correct limiting behaviour. + + SUBROUTINE PYPDFL(KF,X,Q2,XPQ) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/ +C...Local arrays. + DIMENSION XPQ(-25:25),XPA(-25:25),XPB(-25:25),WTSB(-3:3) + DATA RMR/0.92D0/,RMP/0.38D0/,WTSB/0.5D0,1D0,1D0,5D0,1D0,1D0,0.5D0/ + +C...Send everything but protons/neutrons/VMD pions directly to PYPDFU. + MINT(92)=0 + KFA=IABS(KF) + IACC=0 + IF((KFA.EQ.2212.OR.KFA.EQ.2112).AND.MSTP(57).GE.2) IACC=1 + IF(KFA.EQ.211.AND.MSTP(57).GE.3) IACC=1 + IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND.MSTP(57).GE.3) IACC=1 + IF(IACC.EQ.0) THEN + CALL PYPDFU(KF,X,Q2,XPQ) + RETURN + ENDIF + +C...Reset. Check x. + DO 100 KFL=-25,25 + XPQ(KFL)=0D0 + 100 CONTINUE + IF(X.LE.0D0.OR.X.GE.1D0) THEN + WRITE(MSTU(11),5000) X + RETURN + ENDIF + +C...Define valence content. + KFC=KF + NV1=2 + NV2=1 + IF(KF.EQ.2212) THEN + KFV1=2 + KFV2=1 + ELSEIF(KF.EQ.-2212) THEN + KFV1=-2 + KFV2=-1 + ELSEIF(KF.EQ.2112) THEN + KFV1=1 + KFV2=2 + ELSEIF(KF.EQ.-2112) THEN + KFV1=-1 + KFV2=-2 + ELSEIF(KF.EQ.211) THEN + NV1=1 + KFV1=2 + KFV2=-1 + ELSEIF(KF.EQ.-211) THEN + NV1=1 + KFV1=-2 + KFV2=1 + ELSEIF(MINT(105).LE.223) THEN + KFV1=1 + WTV1=0.2D0 + KFV2=2 + WTV2=0.8D0 + ELSEIF(MINT(105).EQ.333) THEN + KFV1=3 + WTV1=1.0D0 + KFV2=1 + WTV2=0.0D0 + ELSEIF(MINT(105).EQ.443) THEN + KFV1=4 + WTV1=1.0D0 + KFV2=1 + WTV2=0.0D0 + ENDIF + +C...Do naive evaluation and find min Q^2, boundary Q^2 and x_0. + MINT30=MINT(30) + CALL PYPDFU(KFC,X,Q2,XPA) + Q2MN=MAX(3D0,VINT(231)) + Q2B=2D0+0.052D0**2*EXP(3.56D0*SQRT(MAX(0D0,-LOG(3D0*X)))) + XMN=EXP(-(LOG((Q2MN-2D0)/0.052D0**2)/3.56D0)**2)/3D0 + +C...Large Q2 and large x: naive call is enough. + IF(Q2.GT.Q2MN.AND.Q2.GT.Q2B) THEN + DO 110 KFL=-25,25 + XPQ(KFL)=XPA(KFL) + 110 CONTINUE + MINT(92)=1 + +C...Small Q2 and large x: dampen boundary value. + ELSEIF(X.GT.XMN) THEN + +C...Evaluate at boundary and define dampening factors. + MINT(30)=MINT30 + CALL PYPDFU(KFC,X,Q2MN,XPA) + FV=(Q2*(Q2MN+RMR)/(Q2MN*(Q2+RMR)))**(0.55D0*(1D0-X)/(1D0-XMN)) + FS=(Q2*(Q2MN+RMP)/(Q2MN*(Q2+RMP)))**1.08D0 + +C...Separate valence and sea parts of parton distribution. + IF(KFA.NE.22) THEN + XFV1=XPA(KFV1)-XPA(-KFV1) + XPA(KFV1)=XPA(-KFV1) + XFV2=XPA(KFV2)-XPA(-KFV2) + XPA(KFV2)=XPA(-KFV2) + ELSE + XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232) + XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232) + XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232) + XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232) + ENDIF + +C...Dampen valence and sea separately. Put back together. + DO 120 KFL=-25,25 + XPQ(KFL)=FS*XPA(KFL) + 120 CONTINUE + IF(KFA.NE.22) THEN + XPQ(KFV1)=XPQ(KFV1)+FV*XFV1 + XPQ(KFV2)=XPQ(KFV2)+FV*XFV2 + ELSE + XPQ(KFV1)=XPQ(KFV1)+FV*WTV1*VINT(232) + XPQ(-KFV1)=XPQ(-KFV1)+FV*WTV1*VINT(232) + XPQ(KFV2)=XPQ(KFV2)+FV*WTV2*VINT(232) + XPQ(-KFV2)=XPQ(-KFV2)+FV*WTV2*VINT(232) + ENDIF + MINT(92)=2 + +C...Large Q2 and small x: interpolate behaviour. + ELSEIF(Q2.GT.Q2MN) THEN + +C...Evaluate at extremes and define coefficients for interpolation. + MINT(30)=MINT30 + CALL PYPDFU(KFC,XMN,Q2MN,XPA) + VI232A=VINT(232) + MINT(30)=MINT30 + CALL PYPDFU(KFC,X,Q2B,XPB) + VI232B=VINT(232) + FLA=LOG(Q2B/Q2)/LOG(Q2B/Q2MN) + FVA=(X/XMN)**0.45D0*FLA + FSA=(X/XMN)**(-0.08D0)*FLA + FB=1D0-FLA + +C...Separate valence and sea parts of parton distribution. + IF(KFA.NE.22) THEN + XFVA1=XPA(KFV1)-XPA(-KFV1) + XPA(KFV1)=XPA(-KFV1) + XFVA2=XPA(KFV2)-XPA(-KFV2) + XPA(KFV2)=XPA(-KFV2) + XFVB1=XPB(KFV1)-XPB(-KFV1) + XPB(KFV1)=XPB(-KFV1) + XFVB2=XPB(KFV2)-XPB(-KFV2) + XPB(KFV2)=XPB(-KFV2) + ELSE + XPA(KFV1)=XPA(KFV1)-WTV1*VI232A + XPA(-KFV1)=XPA(-KFV1)-WTV1*VI232A + XPA(KFV2)=XPA(KFV2)-WTV2*VI232A + XPA(-KFV2)=XPA(-KFV2)-WTV2*VI232A + XPB(KFV1)=XPB(KFV1)-WTV1*VI232B + XPB(-KFV1)=XPB(-KFV1)-WTV1*VI232B + XPB(KFV2)=XPB(KFV2)-WTV2*VI232B + XPB(-KFV2)=XPB(-KFV2)-WTV2*VI232B + ENDIF + +C...Interpolate for valence and sea. Put back together. + DO 130 KFL=-25,25 + XPQ(KFL)=FSA*XPA(KFL)+FB*XPB(KFL) + 130 CONTINUE + IF(KFA.NE.22) THEN + XPQ(KFV1)=XPQ(KFV1)+(FVA*XFVA1+FB*XFVB1) + XPQ(KFV2)=XPQ(KFV2)+(FVA*XFVA2+FB*XFVB2) + ELSE + XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VI232A+FB*VI232B) + XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VI232A+FB*VI232B) + XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VI232A+FB*VI232B) + XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VI232A+FB*VI232B) + ENDIF + MINT(92)=3 + +C...Small Q2 and small x: dampen boundary value and add term. + ELSE + +C...Evaluate at boundary and define dampening factors. + MINT(30)=MINT30 + CALL PYPDFU(KFC,XMN,Q2MN,XPA) + FB=(XMN-X)*(Q2MN-Q2)/(XMN*Q2MN) + FA=1D0-FB + FVC=(X/XMN)**0.45D0*(Q2/(Q2+RMR))**0.55D0 + FVA=FVC*FA*((Q2MN+RMR)/Q2MN)**0.55D0 + FVB=FVC*FB*1.10D0*XMN**0.45D0*0.11D0 + FSC=(X/XMN)**(-0.08D0)*(Q2/(Q2+RMP))**1.08D0 + FSA=FSC*FA*((Q2MN+RMP)/Q2MN)**1.08D0 + FSB=FSC*FB*0.21D0*XMN**(-0.08D0)*0.21D0 + +C...Separate valence and sea parts of parton distribution. + IF(KFA.NE.22) THEN + XFV1=XPA(KFV1)-XPA(-KFV1) + XPA(KFV1)=XPA(-KFV1) + XFV2=XPA(KFV2)-XPA(-KFV2) + XPA(KFV2)=XPA(-KFV2) + ELSE + XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232) + XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232) + XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232) + XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232) + ENDIF + +C...Dampen valence and sea separately. Add constant terms. +C...Put back together. + DO 140 KFL=-25,25 + XPQ(KFL)=FSA*XPA(KFL) + 140 CONTINUE + IF(KFA.NE.22) THEN + DO 150 KFL=-3,3 + XPQ(KFL)=XPQ(KFL)+FSB*WTSB(KFL) + 150 CONTINUE + XPQ(KFV1)=XPQ(KFV1)+(FVA*XFV1+FVB*NV1) + XPQ(KFV2)=XPQ(KFV2)+(FVA*XFV2+FVB*NV2) + ELSE + DO 160 KFL=-3,3 + XPQ(KFL)=XPQ(KFL)+VINT(281)*FSB*WTSB(KFL) + 160 CONTINUE + XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281)) + XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281)) + XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281)) + XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281)) + ENDIF + XPQ(21)=XPQ(0) + MINT(92)=4 + ENDIF + +C...Format for error printout. + 5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3) + + RETURN + END + +C********************************************************************* + +C...PYPDEL +C...Gives electron (or muon, or tau) parton distribution. + + SUBROUTINE PYPDEL(KFA,X,Q2,XPEL) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/ +C...Local arrays. + DIMENSION XPEL(-25:25),XPGA(-6:6),SXP(0:6) + +C...Interface to PDFLIB. + COMMON/W50513/XMIN,XMAX,Q2MIN,Q2MAX + SAVE /W50513/ + DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU, + &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX + CHARACTER*20 PARM(20) + DATA VALUE/20*0D0/,PARM/20*' '/ + +C...Some common constants. + DO 100 KFL=-25,25 + XPEL(KFL)=0D0 + 100 CONTINUE + AEM=PARU(101) + PME=PMAS(11,1) + IF(KFA.EQ.13) PME=PMAS(13,1) + IF(KFA.EQ.15) PME=PMAS(15,1) + XL=LOG(MAX(1D-10,X)) + X1L=LOG(MAX(1D-10,1D0-X)) + HLE=LOG(MAX(3D0,Q2/PME**2)) + HBE2=(AEM/PARU(1))*(HLE-1D0) + +C...Electron inside electron, see R. Kleiss et al., in Z physics at +C...LEP 1, CERN 89-08, p. 34 + IF(MSTP(59).LE.1) THEN + HDE=1D0+(AEM/PARU(1))*(1.5D0*HLE+1.289868D0)+(AEM/PARU(1))**2* + & (-2.164868D0*HLE**2+9.840808D0*HLE-10.130464D0) + HEE=HBE2*(1D0-X)**(HBE2-1D0)*SQRT(MAX(0D0,HDE))- + & 0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*(-4D0*X1L+3D0*XL)- + & 4D0*XL/(1D0-X)-5D0-X) + ELSE + HEE=HBE2*(1D0-X)**(HBE2-1D0)*EXP(0.172784D0*HBE2)/ + & PYGAMM(1D0+HBE2)-0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)* + & (-4D0*X1L+3D0*XL)-4D0*XL/(1D0-X)-5D0-X) + ENDIF +C...Zero distribution for very large x and rescale it for intermediate. + IF(X.GT.1D0-1D-10) THEN + HEE=0D0 + ELSEIF(X.GT.1D0-1D-7) THEN + HEE=HEE*1000D0**HBE2/(1000D0**HBE2-1D0) + ENDIF + XPEL(KFA)=X*HEE + +C...Photon and (transverse) W- inside electron. + AEMP=PYALEM(PME*SQRT(MAX(0D0,Q2)))/PARU(2) + IF(MSTP(13).LE.1) THEN + HLG=HLE + ELSE + HLG=LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-X)/X**2)) + ENDIF + XPEL(22)=AEMP*HLG*(1D0+(1D0-X)**2) + HLW=LOG(1D0+Q2/PMAS(24,1)**2)/(4D0*PARU(102)) + XPEL(-24)=AEMP*HLW*(1D0+(1D0-X)**2) + +C...Electron or positron inside photon inside electron. + IF(KFA.EQ.11.AND.MSTP(12).EQ.1) THEN + XFSEA=0.5D0*(AEMP*(HLE-1D0))**2*(4D0/3D0+X-X**2-4D0*X**3/3D0+ + & 2D0*X*(1D0+X)*XL) + XPEL(11)=XPEL(11)+XFSEA + XPEL(-11)=XFSEA + +C...Initialize PDFLIB photon parton distributions. + IF(MSTP(56).EQ.2) THEN + PARM(1)='NPTYPE' + VALUE(1)=3 + PARM(2)='NGROUP' + VALUE(2)=MSTP(55)/1000 + PARM(3)='NSET' + VALUE(3)=MOD(MSTP(55),1000) + IF(MINT(93).NE.3000000+MSTP(55)) THEN + CALL PDFSET(PARM,VALUE) + MINT(93)=3000000+MSTP(55) + ENDIF + ENDIF + +C...Quarks and gluons inside photon inside electron: +C...numerical convolution required. + DO 110 KFL=0,6 + SXP(KFL)=0D0 + 110 CONTINUE + SUMXPP=0D0 + ITER=-1 + 120 ITER=ITER+1 + SUMXP=SUMXPP + NSTP=2**(ITER-1) + IF(ITER.EQ.0) NSTP=2 + DO 130 KFL=0,6 + SXP(KFL)=0.5D0*SXP(KFL) + 130 CONTINUE + WTSTP=0.5D0/NSTP + IF(ITER.EQ.0) WTSTP=0.5D0 +C...Pick grid of x_{gamma} values logarithmically even. + DO 150 ISTP=1,NSTP + IF(ITER.EQ.0) THEN + XLE=XL*(ISTP-1) + ELSE + XLE=XL*(ISTP-0.5D0)/NSTP + ENDIF + XE=MIN(1D0-1D-10,EXP(XLE)) + XG=MIN(1D0-1D-10,X/XE) +C...Evaluate photon inside electron parton distribution for convolution. + XPGP=1D0+(1D0-XE)**2 + IF(MSTP(13).LE.1) THEN + XPGP=XPGP*HLE + ELSE + XPGP=XPGP*LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-XE)/XE**2)) + ENDIF +C...Evaluate photon parton distributions for convolution. + IF(MSTP(56).EQ.1) THEN + IF(MSTP(55).EQ.1) THEN + CALL PYPDGA(XG,Q2,XPGA) + ELSEIF(MSTP(55).GE.5.AND.MSTP(55).LE.8) THEN + Q2MX=Q2 + P2MX=0.36D0 + IF(MSTP(55).GE.7) P2MX=4.0D0 + IF(MSTP(57).EQ.0) Q2MX=P2MX + P2=0D0 + IF(VINT(120).LT.0D0) P2=VINT(120)**2 + CALL PYGGAM(MSTP(55)-4,XG,Q2MX,P2,MSTP(60),F2GAM,XPGA) + VINT(231)=P2MX + ELSEIF(MSTP(55).GE.9.AND.MSTP(55).LE.12) THEN + Q2MX=Q2 + P2MX=0.36D0 + IF(MSTP(55).GE.11) P2MX=4.0D0 + IF(MSTP(57).EQ.0) Q2MX=P2MX + P2=0D0 + IF(VINT(120).LT.0D0) P2=VINT(120)**2 + CALL PYGGAM(MSTP(55)-8,XG,Q2MX,P2,MSTP(60),F2GAM,XPGA) + VINT(231)=P2MX + ENDIF + DO 140 KFL=0,5 + SXP(KFL)=SXP(KFL)+WTSTP*XPGP*XPGA(KFL) + 140 CONTINUE + ELSEIF(MSTP(56).EQ.2) THEN +C...Call PDFLIB parton distributions. + XX=XG + QQ=SQRT(MAX(0D0,Q2MIN,Q2)) + IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN) + CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU) + SXP(0)=SXP(0)+WTSTP*XPGP*GLU + SXP(1)=SXP(1)+WTSTP*XPGP*DNV + SXP(2)=SXP(2)+WTSTP*XPGP*UPV + SXP(3)=SXP(3)+WTSTP*XPGP*STR + SXP(4)=SXP(4)+WTSTP*XPGP*CHM + SXP(5)=SXP(5)+WTSTP*XPGP*BOT + SXP(6)=SXP(6)+WTSTP*XPGP*TOP + ENDIF + 150 CONTINUE + SUMXPP=SXP(0)+2D0*SXP(1)+2D0*SXP(2) + IF(ITER.LE.2.OR.(ITER.LE.7.AND.ABS(SUMXPP-SUMXP).GT. + & PARP(14)*(SUMXPP+SUMXP))) GOTO 120 + +C...Put convolution into output arrays. + FCONV=AEMP*(-XL) + XPEL(0)=FCONV*SXP(0) + DO 160 KFL=1,6 + XPEL(KFL)=FCONV*SXP(KFL) + XPEL(-KFL)=XPEL(KFL) + 160 CONTINUE + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYPDGA +C...Gives photon parton distribution. + + SUBROUTINE PYPDGA(X,Q2,XPGA) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + SAVE /PYDAT1/,/PYPARS/,/PYINT1/ +C...Local arrays. + DIMENSION XPGA(-6:6),DGAG(4,3),DGBG(4,3),DGCG(4,3),DGAN(4,3), + &DGBN(4,3),DGCN(4,3),DGDN(4,3),DGEN(4,3),DGAS(4,3),DGBS(4,3), + &DGCS(4,3),DGDS(4,3),DGES(4,3) + +C...The following data lines are coefficients needed in the +C...Drees and Grassie photon parton distribution parametrization. + DATA DGAG/-.207D0,.6158D0,1.074D0,0.D0,.8926D-2,.6594D0, + &.4766D0,.1975D-1,.03197D0,1.018D0,.2461D0,.2707D-1/ + DATA DGBG/-.1987D0,.6257D0,8.352D0,5.024D0,.5085D-1,.2774D0, + &-.3906D0,-.3212D0,-.618D-2,.9476D0,-.6094D0,-.1067D-1/ + DATA DGCG/5.119D0,-.2752D0,-6.993D0,2.298D0,-.2313D0,.1382D0, + &6.542D0,.5162D0,-.1216D0,.9047D0,2.653D0,.2003D-2/ + DATA DGAN/2.285D0,-.1526D-1,1330.D0,4.219D0,-.3711D0,1.061D0, + &4.758D0,-.1503D-1,15.8D0,-.9464D0,-.5D0,-.2118D0/ + DATA DGBN/6.073D0,-.8132D0,-41.31D0,3.165D0,-.1717D0,.7815D0, + &1.535D0,.7067D-2,2.742D0,-.7332D0,.7148D0,3.287D0/ + DATA DGCN/-.4202D0,.1778D-1,.9216D0,.18D0,.8766D-1,.2197D-1, + &.1096D0,.204D0,.2917D-1,.4657D-1,.1785D0,.4811D-1/ + DATA DGDN/-.8083D-1,.6346D0,1.208D0,.203D0,-.8915D0,.2857D0, + &2.973D0,.1185D0,-.342D-1,.7196D0,.7338D0,.8139D-1/ + DATA DGEN/.5526D-1,1.136D0,.9512D0,.1163D-1,-.1816D0,.5866D0, + &2.421D0,.4059D0,-.2302D-1,.9229D0,.5873D0,-.79D-4/ + DATA DGAS/16.69D0,-.7916D0,1099.D0,4.428D0,-.1207D0,1.071D0, + &1.977D0,-.8625D-2,6.734D0,-1.008D0,-.8594D-1,.7625D-1/ + DATA DGBS/.176D0,.4794D-1,1.047D0,.25D-1,25.D0,-1.648D0, + &-.1563D-1,6.438D0,59.88D0,-2.983D0,4.48D0,.9686D0/ + DATA DGCS/-.208D-1,.3386D-2,4.853D0,.8404D0,-.123D-1,1.162D0, + &.4824D0,-.11D-1,-.3226D-2,.8432D0,.3616D0,.1383D-2/ + DATA DGDS/-.1685D-1,1.353D0,1.426D0,1.239D0,-.9194D-1,.7912D0, + &.6397D0,2.327D0,-.3321D-1,.9475D0,-.3198D0,.2132D-1/ + DATA DGES/-.1986D0,1.1D0,1.136D0,-.2779D0,.2015D-1,.9869D0, + &-.7036D-1,.1694D-1,.1059D0,.6954D0,-.6663D0,.3683D0/ + +C...Photon parton distribution from Drees and Grassie. +C...Allowed variable range: 1 GeV^2 < Q^2 < 10000 GeV^2. + DO 100 KFL=-6,6 + XPGA(KFL)=0D0 + 100 CONTINUE + VINT(231)=1D0 + IF(MSTP(57).LE.0) THEN + T=LOG(1D0/0.16D0) + ELSE + T=LOG(MIN(1D4,MAX(1D0,Q2))/0.16D0) + ENDIF + X1=1D0-X + NF=3 + IF(Q2.GT.25D0) NF=4 + IF(Q2.GT.300D0) NF=5 + NFE=NF-2 + AEM=PARU(101) + +C...Evaluate gluon content. + DGA=DGAG(1,NFE)*T**DGAG(2,NFE)+DGAG(3,NFE)*T**(-DGAG(4,NFE)) + DGB=DGBG(1,NFE)*T**DGBG(2,NFE)+DGBG(3,NFE)*T**(-DGBG(4,NFE)) + DGC=DGCG(1,NFE)*T**DGCG(2,NFE)+DGCG(3,NFE)*T**(-DGCG(4,NFE)) + XPGL=DGA*X**DGB*X1**DGC + +C...Evaluate up- and down-type quark content. + DGA=DGAN(1,NFE)*T**DGAN(2,NFE)+DGAN(3,NFE)*T**(-DGAN(4,NFE)) + DGB=DGBN(1,NFE)*T**DGBN(2,NFE)+DGBN(3,NFE)*T**(-DGBN(4,NFE)) + DGC=DGCN(1,NFE)*T**DGCN(2,NFE)+DGCN(3,NFE)*T**(-DGCN(4,NFE)) + DGD=DGDN(1,NFE)*T**DGDN(2,NFE)+DGDN(3,NFE)*T**(-DGDN(4,NFE)) + DGE=DGEN(1,NFE)*T**DGEN(2,NFE)+DGEN(3,NFE)*T**(-DGEN(4,NFE)) + XPQN=X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE + DGA=DGAS(1,NFE)*T**DGAS(2,NFE)+DGAS(3,NFE)*T**(-DGAS(4,NFE)) + DGB=DGBS(1,NFE)*T**DGBS(2,NFE)+DGBS(3,NFE)*T**(-DGBS(4,NFE)) + DGC=DGCS(1,NFE)*T**DGCS(2,NFE)+DGCS(3,NFE)*T**(-DGCS(4,NFE)) + DGD=DGDS(1,NFE)*T**DGDS(2,NFE)+DGDS(3,NFE)*T**(-DGDS(4,NFE)) + DGE=DGES(1,NFE)*T**DGES(2,NFE)+DGES(3,NFE)*T**(-DGES(4,NFE)) + DGF=9D0 + IF(NF.EQ.4) DGF=10D0 + IF(NF.EQ.5) DGF=55D0/6D0 + XPQS=DGF*X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE + IF(NF.LE.3) THEN + XPQU=(XPQS+9D0*XPQN)/6D0 + XPQD=(XPQS-4.5D0*XPQN)/6D0 + ELSEIF(NF.EQ.4) THEN + XPQU=(XPQS+6D0*XPQN)/8D0 + XPQD=(XPQS-6D0*XPQN)/8D0 + ELSE + XPQU=(XPQS+7.5D0*XPQN)/10D0 + XPQD=(XPQS-5D0*XPQN)/10D0 + ENDIF + +C...Put into output arrays. + XPGA(0)=AEM*XPGL + XPGA(1)=AEM*XPQD + XPGA(2)=AEM*XPQU + XPGA(3)=AEM*XPQD + IF(NF.GE.4) XPGA(4)=AEM*XPQU + IF(NF.GE.5) XPGA(5)=AEM*XPQD + DO 110 KFL=1,6 + XPGA(-KFL)=XPGA(KFL) + 110 CONTINUE + + RETURN + END + +C********************************************************************* + +C...PYGGAM +C...Constructs the F2 and parton distributions of the photon +C...by summing homogeneous (VMD) and inhomogeneous (anomalous) terms. +C...For F2, c and b are included by the Bethe-Heitler formula; +C...in the 'MSbar' scheme additionally a Cgamma term is added. +C...Contains the SaS sets 1D, 1M, 2D and 2M. +C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand. + + SUBROUTINE PYGGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6), + &XPDIR(-6:6) + COMMON/PYINT9/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6) + SAVE /PYINT8/,/PYINT9/ +C...Local arrays. + DIMENSION XPDFGM(-6:6),XPGA(-6:6), VXPGA(-6:6) +C...Charm and bottom masses (low to compensate for J/psi etc.). + DATA PMC/1.3D0/, PMB/4.6D0/ +C...alpha_em and alpha_em/(2*pi). + DATA AEM/0.007297D0/, AEM2PI/0.0011614D0/ +C...Lambda value for 4 flavours. + DATA ALAM/0.20D0/ +C...Mixture u/(u+d), = 0.5 for incoherent and = 0.8 for coherent sum. + DATA FRACU/0.8D0/ +C...VMD couplings f_V**2/(4*pi). + DATA FRHO/2.20D0/, FOMEGA/23.6D0/, FPHI/18.4D0/ +C...Masses for rho (=omega) and phi. + DATA PMRHO/0.770D0/, PMPHI/1.020D0/ +C...Number of points in integration for IP2=1. + DATA NSTEP/100/ + +C...Reset output. + F2GM=0D0 + DO 100 KFL=-6,6 + XPDFGM(KFL)=0D0 + XPVMD(KFL)=0D0 + XPANL(KFL)=0D0 + XPANH(KFL)=0D0 + XPBEH(KFL)=0D0 + XPDIR(KFL)=0D0 + VXPVMD(KFL)=0D0 + VXPANL(KFL)=0D0 + VXPANH(KFL)=0D0 + VXPDGM(KFL)=0D0 + 100 CONTINUE + +C...Set Q0 cut-off parameter as function of set used. + IF(ISET.LE.2) THEN + Q0=0.6D0 + ELSE + Q0=2D0 + ENDIF + Q02=Q0**2 + +C...Scale choice for off-shell photon; common factors. + Q2A=Q2 + FACNOR=1D0 + IF(IP2.EQ.1) THEN + P2MX=P2+Q02 + Q2A=Q2+P2*Q02/MAX(Q02,Q2) + FACNOR=LOG(Q2/Q02)/NSTEP + ELSEIF(IP2.EQ.2) THEN + P2MX=MAX(P2,Q02) + ELSEIF(IP2.EQ.3) THEN + P2MX=P2+Q02 + Q2A=Q2+P2*Q02/MAX(Q02,Q2) + ELSEIF(IP2.EQ.4) THEN + P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/ + & ((Q2+P2)*(Q02+P2))) + ELSEIF(IP2.EQ.5) THEN + P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/ + & ((Q2+P2)*(Q02+P2))) + P2MX=Q0*SQRT(P2MXA) + FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MX) + ELSEIF(IP2.EQ.6) THEN + P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/ + & ((Q2+P2)*(Q02+P2))) + P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02) + ELSE + P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/ + & ((Q2+P2)*(Q02+P2))) + P2MX=Q0*SQRT(P2MXA) + P2MXB=P2MX + P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02) + P2MXB=MAX(0D0,1D0-P2/Q2)*P2MXB+MIN(1D0,P2/Q2)*P2MXA + IF(ABS(Q2-Q02).GT.1D-6) THEN + FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MXB) + ELSEIF(P2.LT.Q02) THEN + FACNOR=Q02**3/(Q02+P2)/(Q02**2-P2**2/2D0) + ELSE + FACNOR=1D0 + ENDIF + ENDIF + +C...Call VMD parametrization for d quark and use to give rho, omega, +C...phi. Note dipole dampening for off-shell photon. + CALL PYGVMD(ISET,1,X,Q2A,P2MX,ALAM,XPGA,VXPGA) + XFVAL=VXPGA(1) + XPGA(1)=XPGA(2) + XPGA(-1)=XPGA(-2) + FACUD=AEM*(1D0/FRHO+1D0/FOMEGA)*(PMRHO**2/(PMRHO**2+P2))**2 + FACS=AEM*(1D0/FPHI)*(PMPHI**2/(PMPHI**2+P2))**2 + DO 110 KFL=-5,5 + XPVMD(KFL)=(FACUD+FACS)*XPGA(KFL) + 110 CONTINUE + XPVMD(1)=XPVMD(1)+(1D0-FRACU)*FACUD*XFVAL + XPVMD(2)=XPVMD(2)+FRACU*FACUD*XFVAL + XPVMD(3)=XPVMD(3)+FACS*XFVAL + XPVMD(-1)=XPVMD(-1)+(1D0-FRACU)*FACUD*XFVAL + XPVMD(-2)=XPVMD(-2)+FRACU*FACUD*XFVAL + XPVMD(-3)=XPVMD(-3)+FACS*XFVAL + VXPVMD(1)=(1D0-FRACU)*FACUD*XFVAL + VXPVMD(2)=FRACU*FACUD*XFVAL + VXPVMD(3)=FACS*XFVAL + VXPVMD(-1)=(1D0-FRACU)*FACUD*XFVAL + VXPVMD(-2)=FRACU*FACUD*XFVAL + VXPVMD(-3)=FACS*XFVAL + + IF(IP2.NE.1) THEN +C...Anomalous parametrizations for different strategies +C...for off-shell photons; except full integration. + +C...Call anomalous parametrization for d + u + s. + CALL PYGANO(-3,X,Q2A,P2MX,ALAM,XPGA,VXPGA) + DO 120 KFL=-5,5 + XPANL(KFL)=FACNOR*XPGA(KFL) + VXPANL(KFL)=FACNOR*VXPGA(KFL) + 120 CONTINUE + +C...Call anomalous parametrization for c and b. + CALL PYGANO(4,X,Q2A,P2MX,ALAM,XPGA,VXPGA) + DO 130 KFL=-5,5 + XPANH(KFL)=FACNOR*XPGA(KFL) + VXPANH(KFL)=FACNOR*VXPGA(KFL) + 130 CONTINUE + CALL PYGANO(5,X,Q2A,P2MX,ALAM,XPGA,VXPGA) + DO 140 KFL=-5,5 + XPANH(KFL)=XPANH(KFL)+FACNOR*XPGA(KFL) + VXPANH(KFL)=VXPANH(KFL)+FACNOR*VXPGA(KFL) + 140 CONTINUE + + ELSE +C...Special option: loop over flavours and integrate over k2. + DO 170 KF=1,5 + DO 160 ISTEP=1,NSTEP + Q2STEP=Q02*(Q2/Q02)**((ISTEP-0.5D0)/NSTEP) + IF((KF.EQ.4.AND.Q2STEP.LT.PMC**2).OR. + & (KF.EQ.5.AND.Q2STEP.LT.PMB**2)) GOTO 160 + CALL PYGVMD(0,KF,X,Q2,Q2STEP,ALAM,XPGA,VXPGA) + FACQ=AEM2PI*(Q2STEP/(Q2STEP+P2))**2*FACNOR + IF(MOD(KF,2).EQ.0) FACQ=FACQ*(8D0/9D0) + IF(MOD(KF,2).EQ.1) FACQ=FACQ*(2D0/9D0) + DO 150 KFL=-5,5 + IF(KF.LE.3) XPANL(KFL)=XPANL(KFL)+FACQ*XPGA(KFL) + IF(KF.GE.4) XPANH(KFL)=XPANH(KFL)+FACQ*XPGA(KFL) + IF(KF.LE.3) VXPANL(KFL)=VXPANL(KFL)+FACQ*VXPGA(KFL) + IF(KF.GE.4) VXPANH(KFL)=VXPANH(KFL)+FACQ*VXPGA(KFL) + 150 CONTINUE + 160 CONTINUE + 170 CONTINUE + ENDIF + +C...Call Bethe-Heitler term expression for charm and bottom. + CALL PYGBEH(4,X,Q2,P2,PMC**2,XPBH) + XPBEH(4)=XPBH + XPBEH(-4)=XPBH + CALL PYGBEH(5,X,Q2,P2,PMB**2,XPBH) + XPBEH(5)=XPBH + XPBEH(-5)=XPBH + +C...For MSbar subtraction call C^gamma term expression for d, u, s. + IF(ISET.EQ.2.OR.ISET.EQ.4) THEN + CALL PYGDIR(X,Q2,P2,Q02,XPGA) + DO 180 KFL=-5,5 + XPDIR(KFL)=XPGA(KFL) + 180 CONTINUE + ENDIF + +C...Store result in output array. + DO 190 KFL=-5,5 + CHSQ=1D0/9D0 + IF(IABS(KFL).EQ.2.OR.IABS(KFL).EQ.4) CHSQ=4D0/9D0 + XPF2=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL) + IF(KFL.NE.0) F2GM=F2GM+CHSQ*XPF2 + XPDFGM(KFL)=XPVMD(KFL)+XPANL(KFL)+XPANH(KFL) + VXPDGM(KFL)=VXPVMD(KFL)+VXPANL(KFL)+VXPANH(KFL) + 190 CONTINUE + + RETURN + END + +C********************************************************************* + +C...PYGVMD +C...Evaluates the VMD parton distributions of a photon, +C...evolved homogeneously from an initial scale P2 to Q2. +C...Does not include dipole suppression factor. +C...ISET is parton distribution set, see above; +C...additionally ISET=0 is used for the evolution of an anomalous photon +C...which branched at a scale P2 and then evolved homogeneously to Q2. +C...ALAM is the 4-flavour Lambda, which is automatically converted +C...to 3- and 5-flavour equivalents as needed. +C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand. + + SUBROUTINE PYGVMD(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Local arrays and data. + DIMENSION XPGA(-6:6), VXPGA(-6:6) + DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/ + +C...Reset output. + DO 100 KFL=-6,6 + XPGA(KFL)=0D0 + VXPGA(KFL)=0D0 + 100 CONTINUE + KFA=IABS(KF) + +C...Calculate Lambda; protect against unphysical Q2 and P2 input. + ALAM3=ALAM*(PMC/ALAM)**(2D0/27D0) + ALAM5=ALAM*(ALAM/PMB)**(2D0/23D0) + P2EFF=MAX(P2,1.2D0*ALAM3**2) + IF(KFA.EQ.4) P2EFF=MAX(P2EFF,PMC**2) + IF(KFA.EQ.5) P2EFF=MAX(P2EFF,PMB**2) + Q2EFF=MAX(Q2,P2EFF) + +C...Find number of flavours at lower and upper scale. + NFP=4 + IF(P2EFF.LT.PMC**2) NFP=3 + IF(P2EFF.GT.PMB**2) NFP=5 + NFQ=4 + IF(Q2EFF.LT.PMC**2) NFQ=3 + IF(Q2EFF.GT.PMB**2) NFQ=5 + +C...Find s as sum of 3-, 4- and 5-flavour parts. + S=0D0 + IF(NFP.EQ.3) THEN + Q2DIV=PMC**2 + IF(NFQ.EQ.3) Q2DIV=Q2EFF + S=S+(6D0/27D0)*LOG(LOG(Q2DIV/ALAM3**2)/LOG(P2EFF/ALAM3**2)) + ENDIF + IF(NFP.LE.4.AND.NFQ.GE.4) THEN + P2DIV=P2EFF + IF(NFP.EQ.3) P2DIV=PMC**2 + Q2DIV=Q2EFF + IF(NFQ.EQ.5) Q2DIV=PMB**2 + S=S+(6D0/25D0)*LOG(LOG(Q2DIV/ALAM**2)/LOG(P2DIV/ALAM**2)) + ENDIF + IF(NFQ.EQ.5) THEN + P2DIV=PMB**2 + IF(NFP.EQ.5) P2DIV=P2EFF + S=S+(6D0/23D0)*LOG(LOG(Q2EFF/ALAM5**2)/LOG(P2DIV/ALAM5**2)) + ENDIF + +C...Calculate frequent combinations of x and s. + X1=1D0-X + XL=-LOG(X) + S2=S**2 + S3=S**3 + S4=S**4 + +C...Evaluate homogeneous anomalous parton distributions below or +C...above threshold. + IF(ISET.EQ.0) THEN + IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR. + & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN + XVAL = X * 1.5D0 * (X**2+X1**2) + XGLU = 0D0 + XSEA = 0D0 + ELSE + XVAL = (1.5D0/(1D0-0.197D0*S+4.33D0*S2)*X**2 + + & (1.5D0+2.10D0*S)/(1D0+3.29D0*S)*X1**2 + + & 5.23D0*S/(1D0+1.17D0*S+19.9D0*S3)*X*X1) * + & X**(1D0/(1D0+1.5D0*S)) * (1D0-X**2)**(2.667D0*S) + XGLU = 4D0*S/(1D0+4.76D0*S+15.2D0*S2+29.3D0*S4) * + & X**(-2.03D0*S/(1D0+2.44D0*S)) * (X1*XL)**(1.333D0*S) * + & ((4D0*X**2+7D0*X+4D0)*X1/3D0 - 2D0*X*(1D0+X)*XL) + XSEA = S2/(1D0+4.54D0*S+8.19D0*S2+8.05D0*S3) * + & X**(-1.54D0*S/(1D0+1.29D0*S)) * X1**(2.667D0*S) * + & ((8D0-73D0*X+62D0*X**2)*X1/9D0 + (3D0-8D0*X**2/3D0)*X*XL + + & (2D0*X-1D0)*X*XL**2) + ENDIF + +C...Evaluate set 1D parton distributions below or above threshold. + ELSEIF(ISET.EQ.1) THEN + IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR. + & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN + XVAL = 1.294D0 * X**0.80D0 * X1**0.76D0 + XGLU = 1.273D0 * X**0.40D0 * X1**1.76D0 + XSEA = 0.100D0 * X1**3.76D0 + ELSE + XVAL = 1.294D0/(1D0+0.252D0*S+3.079D0*S2) * + & X**(0.80D0-0.13D0*S) * X1**(0.76D0+0.667D0*S) * XL**(2D0*S) + XGLU = 7.90D0*S/(1D0+5.50D0*S) * EXP(-5.16D0*S) * + & X**(-1.90D0*S/(1D0+3.60D0*S)) * X1**1.30D0 * + & XL**(0.50D0+3D0*S) + 1.273D0 * EXP(-10D0*S) * + & X**0.40D0 * X1**(1.76D0+3D0*S) + XSEA = (0.1D0-0.397D0*S2+1.121D0*S3)/ + & (1D0+5.61D0*S2+5.26D0*S3) * X**(-7.32D0*S2/(1D0+10.3D0*S2)) * + & X1**((3.76D0+15D0*S+12D0*S2)/(1D0+4D0*S)) + XSEA0 = 0.100D0 * X1**3.76D0 + ENDIF + +C...Evaluate set 1M parton distributions below or above threshold. + ELSEIF(ISET.EQ.2) THEN + IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR. + & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN + XVAL = 0.8477D0 * X**0.51D0 * X1**1.37D0 + XGLU = 3.42D0 * X**0.255D0 * X1**2.37D0 + XSEA = 0D0 + ELSE + XVAL = 0.8477D0/(1D0+1.37D0*S+2.18D0*S2+3.73D0*S3) * + & X**(0.51D0+0.21D0*S) * X1**1.37D0 * XL**(2.667D0*S) + XGLU = 24D0*S/(1D0+9.6D0*S+0.92D0*S2+14.34D0*S3) * + & EXP(-5.94D0*S) * X**((-0.013D0-1.80D0*S)/(1D0+3.14D0*S)) * + & X1**(2.37D0+0.4D0*S) * XL**(0.32D0+3.6D0*S) + 3.42D0 * + & EXP(-12D0*S) * X**0.255D0 * X1**(2.37D0+3D0*S) + XSEA = 0.842D0*S/(1D0+21.3D0*S-33.2D0*S2+229D0*S3) * + & X**((0.13D0-2.90D0*S)/(1D0+5.44D0*S)) * X1**(3.45D0+0.5D0*S) * + & XL**(2.8D0*S) + XSEA0 = 0D0 + ENDIF + +C...Evaluate set 2D parton distributions below or above threshold. + ELSEIF(ISET.EQ.3) THEN + IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR. + & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN + XVAL = X**0.46D0 * X1**0.64D0 + 0.76D0 * X + XGLU = 1.925D0 * X1**2 + XSEA = 0.242D0 * X1**4 + ELSE + XVAL = (1D0+0.186D0*S)/(1D0-0.209D0*S+1.495D0*S2) * + & X**(0.46D0+0.25D0*S) * + & X1**((0.64D0+0.14D0*S+5D0*S2)/(1D0+S)) * XL**(1.9D0*S) + + & (0.76D0+0.4D0*S) * X * X1**(2.667D0*S) + XGLU = (1.925D0+5.55D0*S+147D0*S2)/(1D0-3.59D0*S+3.32D0*S2) * + & EXP(-18.67D0*S) * + & X**((-5.81D0*S-5.34D0*S2)/(1D0+29D0*S-4.26D0*S2)) + & * X1**((2D0-5.9D0*S)/(1D0+1.7D0*S)) * + & XL**(9.3D0*S/(1D0+1.7D0*S)) + XSEA = (0.242D0-0.252D0*S+1.19D0*S2)/ + & (1D0-0.607D0*S+21.95D0*S2) * + & X**(-12.1D0*S2/(1D0+2.62D0*S+16.7D0*S2)) * X1**4 * XL**S + XSEA0 = 0.242D0 * X1**4 + ENDIF + +C...Evaluate set 2M parton distributions below or above threshold. + ELSEIF(ISET.EQ.4) THEN + IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR. + & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN + XVAL = 1.168D0 * X**0.50D0 * X1**2.60D0 + 0.965D0 * X + XGLU = 1.808D0 * X1**2 + XSEA = 0.209D0 * X1**4 + ELSE + XVAL = (1.168D0+1.771D0*S+29.35D0*S2) * EXP(-5.776D0*S) * + & X**((0.5D0+0.208D0*S)/(1D0-0.794D0*S+1.516D0*S2)) * + & X1**((2.6D0+7.6D0*S)/(1D0+5D0*S)) * + & XL**(5.15D0*S/(1D0+2D0*S)) + + & (0.965D0+22.35D0*S)/(1D0+18.4D0*S) * X * X1**(2.667D0*S) + XGLU = (1.808D0+29.9D0*S)/(1D0+26.4D0*S) * EXP(-5.28D0*S) * + & X**((-5.35D0*S-10.11D0*S2)/(1D0+31.71D0*S)) * + & X1**((2D0-7.3D0*S+4D0*S2)/(1D0+2.5D0*S)) * + & XL**(10.9D0*S/(1D0+2.5D0*S)) + XSEA = (0.209D0+0.644D0*S2)/(1D0+0.319D0*S+17.6D0*S2) * + & X**((-0.373D0*S-7.71D0*S2)/(1D0+0.815D0*S+11.0D0*S2)) * + & X1**(4D0+S) * XL**(0.45D0*S) + XSEA0 = 0.209D0 * X1**4 + ENDIF + ENDIF + +C...Threshold factors for c and b sea. + SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2)) + XCHM=0D0 + IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN + SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2))) + IF(ISET.EQ.0) THEN + XCHM=XSEA*(1D0-(SCH/SLL)**2) + ELSE + XCHM=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SCH/SLL) + ENDIF + ENDIF + XBOT=0D0 + IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN + SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2))) + IF(ISET.EQ.0) THEN + XBOT=XSEA*(1D0-(SBT/SLL)**2) + ELSE + XBOT=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SBT/SLL) + ENDIF + ENDIF + +C...Fill parton distributions. + XPGA(0)=XGLU + XPGA(1)=XSEA + XPGA(2)=XSEA + XPGA(3)=XSEA + XPGA(4)=XCHM + XPGA(5)=XBOT + XPGA(KFA)=XPGA(KFA)+XVAL + DO 110 KFL=1,5 + XPGA(-KFL)=XPGA(KFL) + 110 CONTINUE + VXPGA(KFA)=XVAL + VXPGA(-KFA)=XVAL + + RETURN + END + +C********************************************************************* + +C...PYGANO +C...Evaluates the parton distributions of the anomalous photon, +C...inhomogeneously evolved from a scale P2 (where it vanishes) to Q2. +C...KF=0 gives the sum over (up to) 5 flavours, +C...KF<0 limits to flavours up to abs(KF), +C...KF>0 is for flavour KF only. +C...ALAM is the 4-flavour Lambda, which is automatically converted +C...to 3- and 5-flavour equivalents as needed. +C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand. + + SUBROUTINE PYGANO(KF,X,Q2,P2,ALAM,XPGA,VXPGA) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Local arrays and data. + DIMENSION XPGA(-6:6), VXPGA(-6:6), ALAMSQ(3:5) + DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/ + +C...Reset output. + DO 100 KFL=-6,6 + XPGA(KFL)=0D0 + VXPGA(KFL)=0D0 + 100 CONTINUE + IF(Q2.LE.P2) RETURN + KFA=IABS(KF) + +C...Calculate Lambda; protect against unphysical Q2 and P2 input. + ALAMSQ(3)=(ALAM*(PMC/ALAM)**(2D0/27D0))**2 + ALAMSQ(4)=ALAM**2 + ALAMSQ(5)=(ALAM*(ALAM/PMB)**(2D0/23D0))**2 + P2EFF=MAX(P2,1.2D0*ALAMSQ(3)) + IF(KF.EQ.4) P2EFF=MAX(P2EFF,PMC**2) + IF(KF.EQ.5) P2EFF=MAX(P2EFF,PMB**2) + Q2EFF=MAX(Q2,P2EFF) + XL=-LOG(X) + +C...Find number of flavours at lower and upper scale. + NFP=4 + IF(P2EFF.LT.PMC**2) NFP=3 + IF(P2EFF.GT.PMB**2) NFP=5 + NFQ=4 + IF(Q2EFF.LT.PMC**2) NFQ=3 + IF(Q2EFF.GT.PMB**2) NFQ=5 + +C...Define range of flavour loop. + IF(KF.EQ.0) THEN + KFLMN=1 + KFLMX=5 + ELSEIF(KF.LT.0) THEN + KFLMN=1 + KFLMX=KFA + ELSE + KFLMN=KFA + KFLMX=KFA + ENDIF + +C...Loop over flavours the photon can branch into. + DO 110 KFL=KFLMN,KFLMX + +C...Light flavours: calculate t range and (approximate) s range. + IF(KFL.LE.3.AND.(KFL.EQ.1.OR.KFL.EQ.KF)) THEN + TDIFF=LOG(Q2EFF/P2EFF) + S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/ + & LOG(P2EFF/ALAMSQ(NFQ))) + IF(NFQ.GT.NFP) THEN + Q2DIV=PMB**2 + IF(NFQ.EQ.4) Q2DIV=PMC**2 + SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/ + & LOG(P2EFF/ALAMSQ(NFQ))) + SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/ + & LOG(P2EFF/ALAMSQ(NFQ-1))) + S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ) + ENDIF + IF(NFQ.EQ.5.AND.NFP.EQ.3) THEN + Q2DIV=PMC**2 + SNF4=(6D0/(33D0-2D0*4))*LOG(LOG(Q2DIV/ALAMSQ(4))/ + & LOG(P2EFF/ALAMSQ(4))) + SNF3=(6D0/(33D0-2D0*3))*LOG(LOG(Q2DIV/ALAMSQ(3))/ + & LOG(P2EFF/ALAMSQ(3))) + S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNF3-SNF4) + ENDIF + +C...u and s quark do not need a separate treatment when d has been done. + ELSEIF(KFL.EQ.2.OR.KFL.EQ.3) THEN + +C...Charm: as above, but only include range above c threshold. + ELSEIF(KFL.EQ.4) THEN + IF(Q2.LE.PMC**2) GOTO 110 + P2EFF=MAX(P2EFF,PMC**2) + Q2EFF=MAX(Q2EFF,P2EFF) + TDIFF=LOG(Q2EFF/P2EFF) + S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/ + & LOG(P2EFF/ALAMSQ(NFQ))) + IF(NFQ.EQ.5.AND.NFP.EQ.4) THEN + Q2DIV=PMB**2 + SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/ + & LOG(P2EFF/ALAMSQ(NFQ))) + SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/ + & LOG(P2EFF/ALAMSQ(NFQ-1))) + S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ) + ENDIF + +C...Bottom: as above, but only include range above b threshold. + ELSEIF(KFL.EQ.5) THEN + IF(Q2.LE.PMB**2) GOTO 110 + P2EFF=MAX(P2EFF,PMB**2) + Q2EFF=MAX(Q2,P2EFF) + TDIFF=LOG(Q2EFF/P2EFF) + S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/ + & LOG(P2EFF/ALAMSQ(NFQ))) + ENDIF + +C...Evaluate flavour-dependent prefactor (charge^2 etc.). + CHSQ=1D0/9D0 + IF(KFL.EQ.2.OR.KFL.EQ.4) CHSQ=4D0/9D0 + FAC=AEM2PI*2D0*CHSQ*TDIFF + +C...Evaluate parton distributions (normalized to unit momentum sum). + IF(KFL.EQ.1.OR.KFL.EQ.4.OR.KFL.EQ.5.OR.KFL.EQ.KF) THEN + XVAL= ((1.5D0+2.49D0*S+26.9D0*S**2)/(1D0+32.3D0*S**2)*X**2 + + & (1.5D0-0.49D0*S+7.83D0*S**2)/(1D0+7.68D0*S**2)*(1D0-X)**2 + + & 1.5D0*S/(1D0-3.2D0*S+7D0*S**2)*X*(1D0-X)) * + & X**(1D0/(1D0+0.58D0*S)) * (1D0-X**2)**(2.5D0*S/(1D0+10D0*S)) + XGLU= 2D0*S/(1D0+4D0*S+7D0*S**2) * + & X**(-1.67D0*S/(1D0+2D0*S)) * (1D0-X**2)**(1.2D0*S) * + & ((4D0*X**2+7D0*X+4D0)*(1D0-X)/3D0 - 2D0*X*(1D0+X)*XL) + XSEA= 0.333D0*S**2/(1D0+4.90D0*S+4.69D0*S**2+21.4D0*S**3) * + & X**(-1.18D0*S/(1D0+1.22D0*S)) * (1D0-X)**(1.2D0*S) * + & ((8D0-73D0*X+62D0*X**2)*(1D0-X)/9D0 + + & (3D0-8D0*X**2/3D0)*X*XL + (2D0*X-1D0)*X*XL**2) + +C...Threshold factors for c and b sea. + SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2)) + XCHM=0D0 + IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN + SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2))) + XCHM=XSEA*(1D0-(SCH/SLL)**3) + ENDIF + XBOT=0D0 + IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN + SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2))) + XBOT=XSEA*(1D0-(SBT/SLL)**3) + ENDIF + ENDIF + +C...Add contribution of each valence flavour. + XPGA(0)=XPGA(0)+FAC*XGLU + XPGA(1)=XPGA(1)+FAC*XSEA + XPGA(2)=XPGA(2)+FAC*XSEA + XPGA(3)=XPGA(3)+FAC*XSEA + XPGA(4)=XPGA(4)+FAC*XCHM + XPGA(5)=XPGA(5)+FAC*XBOT + XPGA(KFL)=XPGA(KFL)+FAC*XVAL + VXPGA(KFL)=VXPGA(KFL)+FAC*XVAL + 110 CONTINUE + DO 120 KFL=1,5 + XPGA(-KFL)=XPGA(KFL) + VXPGA(-KFL)=VXPGA(KFL) + 120 CONTINUE + + RETURN + END + + +C********************************************************************* + +C...PYGBEH +C...Evaluates the Bethe-Heitler cross section for heavy flavour +C...production. +C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand. + + SUBROUTINE PYGBEH(KF,X,Q2,P2,PM2,XPBH) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP + +C...Local data. + DATA AEM2PI/0.0011614D0/ + +C...Reset output. + XPBH=0D0 + SIGBH=0D0 + +C...Check kinematics limits. + IF(X.GE.Q2/(4D0*PM2+Q2+P2)) RETURN + W2=Q2*(1D0-X)/X-P2 + BETA2=1D0-4D0*PM2/W2 + IF(BETA2.LT.1D-10) RETURN + BETA=SQRT(BETA2) + RMQ=4D0*PM2/Q2 + +C...Simple case: P2 = 0. + IF(P2.LT.1D-4) THEN + IF(BETA.LT.0.99D0) THEN + XBL=LOG((1D0+BETA)/(1D0-BETA)) + ELSE + XBL=LOG((1D0+BETA)**2*W2/(4D0*PM2)) + ENDIF + SIGBH=BETA*(8D0*X*(1D0-X)-1D0-RMQ*X*(1D0-X))+ + & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2) + +C...Complicated case: P2 > 0, based on approximation of +C...C.T. Hill and G.G. Ross, Nucl. Phys. B148 (1979) 373 + ELSE + RPQ=1D0-4D0*X**2*P2/Q2 + IF(RPQ.GT.1D-10) THEN + RPBE=SQRT(RPQ*BETA2) + IF(RPBE.LT.0.99D0) THEN + XBL=LOG((1D0+RPBE)/(1D0-RPBE)) + XBI=2D0*RPBE/(1D0-RPBE**2) + ELSE + RPBESN=4D0*PM2/W2+(4D0*X**2*P2/Q2)*BETA2 + XBL=LOG((1D0+RPBE)**2/RPBESN) + XBI=2D0*RPBE/RPBESN + ENDIF + SIGBH=BETA*(6D0*X*(1D0-X)-1D0)+ + & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)+ + & XBI*(2D0*X/Q2)*(PM2*X*(2D0-RMQ)-P2*X) + ENDIF + ENDIF + +C...Multiply by charge-squared etc. to get parton distribution. + CHSQ=1D0/9D0 + IF(IABS(KF).EQ.2.OR.IABS(KF).EQ.4) CHSQ=4D0/9D0 + XPBH=3D0*CHSQ*AEM2PI*X*SIGBH + + RETURN + END + +C********************************************************************* + +C...PYGDIR +C...Evaluates the direct contribution, i.e. the C^gamma term, +C...as needed in MSbar parametrizations. +C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand. + + SUBROUTINE PYGDIR(X,Q2,P2,Q02,XPGA) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Local array and data. + DIMENSION XPGA(-6:6) + DATA PMC/1.3D0/, PMB/4.6D0/, AEM2PI/0.0011614D0/ + +C...Reset output. + DO 100 KFL=-6,6 + XPGA(KFL)=0D0 + 100 CONTINUE + +C...Evaluate common x-dependent expression. + XTMP = (X**2+(1D0-X)**2) * (-LOG(X)) - 1D0 + CGAM = 3D0*AEM2PI*X * (XTMP*(1D0+P2/(P2+Q02)) + 6D0*X*(1D0-X)) + +C...d, u, s part by simple charge factor. + XPGA(1)=(1D0/9D0)*CGAM + XPGA(2)=(4D0/9D0)*CGAM + XPGA(3)=(1D0/9D0)*CGAM + +C...Also fill for antiquarks. + DO 110 KF=1,5 + XPGA(-KF)=XPGA(KF) + 110 CONTINUE + + RETURN + END + +C********************************************************************* + +C...PYPDPI +C...Gives pi+ parton distribution according to two different +C...parametrizations. + + SUBROUTINE PYPDPI(X,Q2,XPPI) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + SAVE /PYDAT1/,/PYPARS/,/PYINT1/ +C...Local arrays. + DIMENSION XPPI(-6:6),COW(3,5,4,2),XQ(9),TS(6) + +C...The following data lines are coefficients needed in the +C...Owens pion parton distribution parametrizations, see below. +C...Expansion coefficients for up and down valence quark distributions. + DATA ((COW(IP,IS,1,1),IS=1,5),IP=1,3)/ + &4.0000D-01, 7.0000D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00, + &-6.2120D-02, 6.4780D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00, + &-7.1090D-03, 1.3350D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/ + DATA ((COW(IP,IS,1,2),IS=1,5),IP=1,3)/ + &4.0000D-01, 6.2800D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00, + &-5.9090D-02, 6.4360D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00, + &-6.5240D-03, 1.4510D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/ +C...Expansion coefficients for gluon distribution. + DATA ((COW(IP,IS,2,1),IS=1,5),IP=1,3)/ + &8.8800D-01, 0.0000D+00, 3.1100D+00, 6.0000D+00, 0.0000D+00, + &-1.8020D+00, -1.5760D+00, -1.3170D-01, 2.8010D+00, -1.7280D+01, + &1.8120D+00, 1.2000D+00, 5.0680D-01, -1.2160D+01, 2.0490D+01/ + DATA ((COW(IP,IS,2,2),IS=1,5),IP=1,3)/ + &7.9400D-01, 0.0000D+00, 2.8900D+00, 6.0000D+00, 0.0000D+00, + &-9.1440D-01, -1.2370D+00, 5.9660D-01, -3.6710D+00, -8.1910D+00, + &5.9660D-01, 6.5820D-01, -2.5500D-01, -2.3040D+00, 7.7580D+00/ +C...Expansion coefficients for (up+down+strange) quark sea distribution. + DATA ((COW(IP,IS,3,1),IS=1,5),IP=1,3)/ + &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00, + &-2.4280D-01, -2.1200D-01, 8.6730D-01, 1.2660D+00, 2.3820D+00, + &1.3860D-01, 3.6710D-03, 4.7470D-02, -2.2150D+00, 3.4820D-01/ + DATA ((COW(IP,IS,3,2),IS=1,5),IP=1,3)/ + &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00, + &-1.4170D-01, -1.6970D-01, -2.4740D+00, -2.5340D+00, 5.6210D-01, + &-1.7400D-01, -9.6230D-02, 1.5750D+00, 1.3780D+00, -2.7010D-01/ +C...Expansion coefficients for charm quark sea distribution. + DATA ((COW(IP,IS,4,1),IS=1,5),IP=1,3)/ + &0.0000D+00, -2.2120D-02, 2.8940D+00, 0.0000D+00, 0.0000D+00, + &7.9280D-02, -3.7850D-01, 9.4330D+00, 5.2480D+00, 8.3880D+00, + &-6.1340D-02, -1.0880D-01, -1.0852D+01, -7.1870D+00, -1.1610D+01/ + DATA ((COW(IP,IS,4,2),IS=1,5),IP=1,3)/ + &0.0000D+00, -8.8200D-02, 1.9240D+00, 0.0000D+00, 0.0000D+00, + &6.2290D-02, -2.8920D-01, 2.4240D-01, -4.4630D+00, -8.3670D-01, + &-4.0990D-02, -1.0820D-01, 2.0360D+00, 5.2090D+00, -4.8400D-02/ + +C...Euler's beta function, requires ordinary Gamma function + EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y) + +C...Reset output array. + DO 100 KFL=-6,6 + XPPI(KFL)=0D0 + 100 CONTINUE + + IF(MSTP(53).LE.2) THEN +C...Pion parton distributions from Owens. +C...Allowed variable range: 4 GeV^2 < Q^2 < approx 2000 GeV^2. + +C...Determine set, Lambda and s expansion variable. + NSET=MSTP(53) + IF(NSET.EQ.1) ALAM=0.2D0 + IF(NSET.EQ.2) ALAM=0.4D0 + VINT(231)=4D0 + IF(MSTP(57).LE.0) THEN + SD=0D0 + ELSE + Q2IN=MIN(2D3,MAX(4D0,Q2)) + SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2)) + ENDIF + +C...Calculate parton distributions. + DO 120 KFL=1,4 + DO 110 IS=1,5 + TS(IS)=COW(1,IS,KFL,NSET)+COW(2,IS,KFL,NSET)*SD+ + & COW(3,IS,KFL,NSET)*SD**2 + 110 CONTINUE + IF(KFL.EQ.1) THEN + XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)/EULBET(TS(1),TS(2)+1D0) + ELSE + XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+ + & TS(5)*X**2) + ENDIF + 120 CONTINUE + +C...Put into output array. + XPPI(0)=XQ(2) + XPPI(1)=XQ(3)/6D0 + XPPI(2)=XQ(1)+XQ(3)/6D0 + XPPI(3)=XQ(3)/6D0 + XPPI(4)=XQ(4) + XPPI(-1)=XQ(1)+XQ(3)/6D0 + XPPI(-2)=XQ(3)/6D0 + XPPI(-3)=XQ(3)/6D0 + XPPI(-4)=XQ(4) + +C...Leading order pion parton distributions from Glueck, Reya and Vogt. +C...Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and +C...10^-5 < x < 1. + ELSE + +C...Determine s expansion variable and some x expressions. + VINT(231)=0.25D0 + IF(MSTP(57).LE.0) THEN + SD=0D0 + ELSE + Q2IN=MIN(1D8,MAX(0.25D0,Q2)) + SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2)) + ENDIF + SD2=SD**2 + XL=-LOG(X) + XS=SQRT(X) + +C...Evaluate valence, gluon and sea distributions. + XFVAL=(0.519D0+0.180D0*SD-0.011D0*SD2)*X**(0.499D0-0.027D0*SD)* + & (1D0+(0.381D0-0.419D0*SD)*XS)*(1D0-X)**(0.367D0+0.563D0*SD) + XFGLU=(X**(0.482D0+0.341D0*SQRT(SD))*((0.678D0+0.877D0* + & SD-0.175D0*SD2)+ + & (0.338D0-1.597D0*SD)*XS+(-0.233D0*SD+0.406D0*SD2)*X)+ + & SD**0.599D0*EXP(-(0.618D0+2.070D0*SD)+SQRT(3.676D0*SD**1.263D0* + & XL)))* + & (1D0-X)**(0.390D0+1.053D0*SD) + XFSEA=SD**0.55D0*(1D0-0.748D0*XS+(0.313D0+0.935D0*SD)*X)*(1D0- + & X)**3.359D0* + & EXP(-(4.433D0+1.301D0*SD)+SQRT((9.30D0-0.887D0*SD)*SD**0.56D0* + & XL))/ + & XL**(2.538D0-0.763D0*SD) + IF(SD.LE.0.888D0) THEN + XFCHM=0D0 + ELSE + XFCHM=(SD-0.888D0)**1.02D0*(1D0+1.008D0*X)*(1D0-X)**(1.208D0+ + & 0.771D0*SD)* + & EXP(-(4.40D0+1.493D0*SD)+SQRT((2.032D0+1.901D0*SD)*SD**0.39D0* + & XL)) + ENDIF + IF(SD.LE.1.351D0) THEN + XFBOT=0D0 + ELSE + XFBOT=(SD-1.351D0)**1.03D0*(1D0-X)**(0.697D0+0.855D0*SD)* + & EXP(-(4.51D0+1.490D0*SD)+SQRT((3.056D0+1.694D0*SD)*SD**0.39D0* + & XL)) + ENDIF + +C...Put into output array. + XPPI(0)=XFGLU + XPPI(1)=XFSEA + XPPI(2)=XFSEA + XPPI(3)=XFSEA + XPPI(4)=XFCHM + XPPI(5)=XFBOT + DO 130 KFL=1,5 + XPPI(-KFL)=XPPI(KFL) + 130 CONTINUE + XPPI(2)=XPPI(2)+XFVAL + XPPI(-1)=XPPI(-1)+XFVAL + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYPDPR +C...Gives proton parton distributions according to a few different +C...parametrizations. + + SUBROUTINE PYPDPR(X,Q2,XPPR) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/ +C...Arrays and data. + DIMENSION XPPR(-6:6),Q2MIN(16) + DATA Q2MIN/ 2.56D0, 2.56D0, 2.56D0, 0.4D0, 0.4D0, 0.4D0, + &1.0D0, 1.0D0, 2*0D0, 0.25D0, 5D0, 5D0, 4D0, 4D0, 0D0/ + +C...Reset output array. + DO 100 KFL=-6,6 + XPPR(KFL)=0D0 + 100 CONTINUE + +C...Common preliminaries. + NSET=MAX(1,MIN(16,MSTP(51))) + IF(NSET.EQ.9.OR.NSET.EQ.10) NSET=6 + VINT(231)=Q2MIN(NSET) + IF(MSTP(57).EQ.0) THEN + Q2L=Q2MIN(NSET) + ELSE + Q2L=MAX(Q2MIN(NSET),Q2) + ENDIF + + IF(NSET.GE.1.AND.NSET.LE.3) THEN +C...Interface to the CTEQ 3 parton distributions. + QRT=SQRT(MAX(1D0,Q2L)) + +C...Loop over flavours. + DO 110 I=-6,6 + IF(I.LE.0) THEN + XPPR(I)=PYCTEQ(NSET,I,X,QRT) + ELSEIF(I.LE.2) THEN + XPPR(I)=PYCTEQ(NSET,I,X,QRT)+XPPR(-I) + ELSE + XPPR(I)=XPPR(-I) + ENDIF + 110 CONTINUE + + ELSEIF(NSET.GE.4.AND.NSET.LE.6) THEN +C...Interface to the GRV 94 distributions. + IF(NSET.EQ.4) THEN + CALL PYGRVL (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL) + ELSEIF(NSET.EQ.5) THEN + CALL PYGRVM (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL) + ELSE + CALL PYGRVD (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL) + ENDIF + +C...Put into output array. + XPPR(0)=GL + XPPR(-1)=0.5D0*(UDB+DEL) + XPPR(-2)=0.5D0*(UDB-DEL) + XPPR(-3)=SB + XPPR(-4)=CHM + XPPR(-5)=BOT + XPPR(1)=DV+XPPR(-1) + XPPR(2)=UV+XPPR(-2) + XPPR(3)=SB + XPPR(4)=CHM + XPPR(5)=BOT + + ELSEIF(NSET.EQ.7) THEN +C...Interface to the CTEQ 5L parton distributions. +C...Range of validity 10^-6 < x < 1, 1 < Q < 10^4 extended by +C...freezing x*f(x,Q2) at borders. + QRT=SQRT(MAX(1D0,MIN(1D8,Q2L))) + XIN=MAX(1D-6,MIN(1D0,X)) + +C...Loop over flavours (with u <-> d notation mismatch). + SUMUDB=PYCT5L(-1,XIN,QRT) + RATUDB=PYCT5L(-2,XIN,QRT) + DO 120 I=-5,2 + IF(I.EQ.1) THEN + XPPR(I)=XIN*PYCT5L(2,XIN,QRT) + ELSEIF(I.EQ.2) THEN + XPPR(I)=XIN*PYCT5L(1,XIN,QRT) + ELSEIF(I.EQ.-1) THEN + XPPR(I)=XIN*SUMUDB*RATUDB/(1D0+RATUDB) + ELSEIF(I.EQ.-2) THEN + XPPR(I)=XIN*SUMUDB/(1D0+RATUDB) + ELSE + XPPR(I)=XIN*PYCT5L(I,XIN,QRT) + IF(I.LT.0) XPPR(-I)=XPPR(I) + ENDIF + 120 CONTINUE + + ELSEIF(NSET.EQ.8) THEN +C...Interface to the CTEQ 5M1 parton distributions. + QRT=SQRT(MAX(1D0,MIN(1D8,Q2L))) + XIN=MAX(1D-6,MIN(1D0,X)) + +C...Loop over flavours (with u <-> d notation mismatch). + SUMUDB=PYCT5M(-1,XIN,QRT) + RATUDB=PYCT5M(-2,XIN,QRT) + DO 130 I=-5,2 + IF(I.EQ.1) THEN + XPPR(I)=XIN*PYCT5M(2,XIN,QRT) + ELSEIF(I.EQ.2) THEN + XPPR(I)=XIN*PYCT5M(1,XIN,QRT) + ELSEIF(I.EQ.-1) THEN + XPPR(I)=XIN*SUMUDB*RATUDB/(1D0+RATUDB) + ELSEIF(I.EQ.-2) THEN + XPPR(I)=XIN*SUMUDB/(1D0+RATUDB) + ELSE + XPPR(I)=XIN*PYCT5M(I,XIN,QRT) + IF(I.LT.0) XPPR(-I)=XPPR(I) + ENDIF + 130 CONTINUE + + ELSEIF(NSET.GE.11.AND.NSET.LE.15) THEN +C...GRV92LO, EHLQ1, EHLQ2, DO1 AND DO2 distributions: +C...obsolete but offers backwards compatibility. + CALL PYPDPO(X,Q2L,XPPR) + +C...Symmetric choice for debugging only + ELSEIF(NSET.EQ.16) THEN + XPPR(0)=.5D0/X + XPPR(1)=.05D0/X + XPPR(2)=.05D0/X + XPPR(3)=.05D0/X + XPPR(4)=.05D0/X + XPPR(5)=.05D0/X + XPPR(-1)=.05D0/X + XPPR(-2)=.05D0/X + XPPR(-3)=.05D0/X + XPPR(-4)=.05D0/X + XPPR(-5)=.05D0/X + + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYCTEQ +C...Gives the CTEQ 3 parton distribution function sets in +C...parametrized form, of October 24, 1994. +C...Authors: H.L. Lai, J. Botts, J. Huston, J.G. Morfin, J.F. Owens, +C...J. Qiu, W.K. Tung and H. Weerts. + + FUNCTION PYCTEQ (ISET, IPRT, X, Q) + +C...Double precision declaration. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + +C...Data on Lambda values of fits, minimum Q and quark masses. + DIMENSION ALM(3), QMS(4:6) + DATA ALM / 0.177D0, 0.239D0, 0.247D0 / + DATA QMN / 1.60D0 /, (QMS(I), I=4,6) / 1.60D0, 5.00D0, 180.0D0 / + +C....Check flavour thresholds. Set up QI for SB. + IP = IABS(IPRT) + IF(IP .GE. 4) THEN + IF(Q .LE. QMS(IP)) THEN + PYCTEQ = 0D0 + RETURN + ENDIF + QI = QMS(IP) + ELSE + QI = QMN + ENDIF + +C...Use "standard lambda" of parametrization program for expansion. + ALAM = ALM (ISET) + SBL = LOG(Q/ALAM) / LOG(QI/ALAM) + SB = LOG (SBL) + SB2 = SB*SB + SB3 = SB2*SB + +C...Expansion for CTEQ3L. + IF(ISET .EQ. 1) THEN + IF(IPRT .EQ. 2) THEN + A0=Exp( 0.1907D+00+0.4205D-01*SB +0.2752D+00*SB2- + & 0.3171D+00*SB3) + A1= 0.4611D+00+0.2331D-01*SB -0.3403D-01*SB2+0.3174D-01*SB3 + A2= 0.3504D+01+0.5739D+00*SB +0.2676D+00*SB2-0.1553D+00*SB3 + A3= 0.7452D+01-0.6742D+01*SB +0.2849D+01*SB2-0.1964D+00*SB3 + A4= 0.1116D+01-0.3435D+00*SB +0.2865D+00*SB2-0.1288D+00*SB3 + A5= 0.6659D-01+0.2714D+00*SB -0.2688D+00*SB2+0.2763D+00*SB3 + ELSEIF(IPRT .EQ. 1) THEN + A0=Exp( 0.1141D+00+0.4764D+00*SB -0.1745D+01*SB2+ + & 0.7728D+00*SB3) + A1= 0.4275D+00-0.1290D+00*SB +0.3609D+00*SB2-0.1689D+00*SB3 + A2= 0.3000D+01+0.2946D+01*SB -0.4117D+01*SB2+0.1989D+01*SB3 + A3=-0.1302D+01+0.2322D+01*SB -0.4258D+01*SB2+0.2109D+01*SB3 + A4= 0.2586D+01-0.1920D+00*SB -0.3754D+00*SB2+0.2731D+00*SB3 + A5=-0.2251D+00-0.5374D+00*SB +0.2245D+01*SB2-0.1034D+01*SB3 + ELSEIF(IPRT .EQ. 0) THEN + A0=Exp(-0.7631D+00-0.7241D+00*SB -0.1170D+01*SB2+ + & 0.5343D+00*SB3) + A1=-0.3573D+00+0.3469D+00*SB -0.3396D+00*SB2+0.9188D-01*SB3 + A2= 0.5604D+01+0.7458D+00*SB -0.5082D+00*SB2+0.1844D+00*SB3 + A3= 0.1549D+02-0.1809D+02*SB +0.1162D+02*SB2-0.3483D+01*SB3 + A4= 0.9881D+00+0.1364D+00*SB -0.4421D+00*SB2+0.2051D+00*SB3 + A5=-0.9505D-01+0.3259D+01*SB -0.1547D+01*SB2+0.2918D+00*SB3 + ELSEIF(IPRT .EQ. -1) THEN + A0=Exp(-0.2449D+01-0.3513D+01*SB +0.4529D+01*SB2- + & 0.2031D+01*SB3) + A1=-0.4050D+00+0.3411D+00*SB -0.3669D+00*SB2+0.1109D+00*SB3 + A2= 0.7470D+01-0.2982D+01*SB +0.5503D+01*SB2-0.2419D+01*SB3 + A3= 0.1503D+02+0.1638D+01*SB -0.8772D+01*SB2+0.3852D+01*SB3 + A4= 0.1137D+01-0.1006D+01*SB +0.1485D+01*SB2-0.6389D+00*SB3 + A5=-0.5299D+00+0.3160D+01*SB -0.3104D+01*SB2+0.1219D+01*SB3 + ELSEIF(IPRT .EQ. -2) THEN + A0=Exp(-0.2740D+01-0.7987D-01*SB -0.9015D+00*SB2- + & 0.9872D-01*SB3) + A1=-0.3909D+00+0.1244D+00*SB -0.4487D-01*SB2+0.1277D-01*SB3 + A2= 0.9163D+01+0.2823D+00*SB -0.7720D+00*SB2-0.9360D-02*SB3 + A3= 0.1080D+02-0.3915D+01*SB -0.1153D+01*SB2+0.2649D+01*SB3 + A4= 0.9894D+00-0.1647D+00*SB -0.9426D-02*SB2+0.2945D-02*SB3 + A5=-0.3395D+00+0.6998D+00*SB +0.7000D+00*SB2-0.6730D-01*SB3 + ELSEIF(IPRT .EQ. -3) THEN + A0=Exp(-0.3640D+01+0.1250D+01*SB -0.2914D+01*SB2+ + & 0.8390D+00*SB3) + A1=-0.3595D+00-0.5259D-01*SB +0.3122D+00*SB2-0.1642D+00*SB3 + A2= 0.7305D+01+0.9727D+00*SB -0.9788D+00*SB2-0.5193D-01*SB3 + A3= 0.1198D+02-0.1799D+02*SB +0.2614D+02*SB2-0.1091D+02*SB3 + A4= 0.9882D+00-0.6101D+00*SB +0.9737D+00*SB2-0.4935D+00*SB3 + A5=-0.1186D+00-0.3231D+00*SB +0.3074D+01*SB2-0.1274D+01*SB3 + ELSEIF(IPRT .EQ. -4) THEN + A0=SB** 0.1122D+01*Exp(-0.3718D+01-0.1335D+01*SB + + & 0.1651D-01*SB2) + A1=-0.4719D+00+0.7509D+00*SB -0.8420D+00*SB2+0.2901D+00*SB3 + A2= 0.6194D+01-0.1641D+01*SB +0.4907D+01*SB2-0.2523D+01*SB3 + A3= 0.4426D+01-0.4270D+01*SB +0.6581D+01*SB2-0.3474D+01*SB3 + A4= 0.2683D+00+0.9876D+00*SB -0.7612D+00*SB2+0.1780D+00*SB3 + A5=-0.4547D+00+0.4410D+01*SB -0.3712D+01*SB2+0.1245D+01*SB3 + ELSEIF(IPRT .EQ. -5) THEN + A0=SB** 0.9838D+00*Exp(-0.2548D+01-0.7660D+01*SB + + & 0.3702D+01*SB2) + A1=-0.3122D+00-0.2120D+00*SB +0.5716D+00*SB2-0.3773D+00*SB3 + A2= 0.6257D+01-0.8214D-01*SB -0.2537D+01*SB2+0.2981D+01*SB3 + A3=-0.6723D+00+0.2131D+01*SB +0.9599D+01*SB2-0.7910D+01*SB3 + A4= 0.9169D-01+0.4295D-01*SB -0.5017D+00*SB2+0.3811D+00*SB3 + A5= 0.2402D+00+0.2656D+01*SB -0.1586D+01*SB2+0.2880D+00*SB3 + ELSEIF(IPRT .EQ. -6) THEN + A0=SB** 0.1001D+01*Exp(-0.6934D+01+0.3050D+01*SB - + & 0.6943D+00*SB2) + A1=-0.1713D+00-0.5167D+00*SB +0.1241D+01*SB2-0.1703D+01*SB3 + A2= 0.6169D+01+0.3023D+01*SB -0.1972D+02*SB2+0.1069D+02*SB3 + A3= 0.4439D+01-0.1746D+02*SB +0.1225D+02*SB2+0.8350D+00*SB3 + A4= 0.5458D+00-0.4586D+00*SB +0.9089D+00*SB2-0.4049D+00*SB3 + A5= 0.3207D+01-0.3362D+01*SB +0.5877D+01*SB2-0.7659D+01*SB3 + ENDIF + +C...Expansion for CTEQ3M. + ELSEIF(ISET .EQ. 2) THEN + IF(IPRT .EQ. 2) THEN + A0=Exp( 0.2259D+00+0.1237D+00*SB +0.3035D+00*SB2- + & 0.2935D+00*SB3) + A1= 0.5085D+00+0.1651D-01*SB -0.3592D-01*SB2+0.2782D-01*SB3 + A2= 0.3732D+01+0.4901D+00*SB +0.2218D+00*SB2-0.1116D+00*SB3 + A3= 0.7011D+01-0.6620D+01*SB +0.2557D+01*SB2-0.1360D+00*SB3 + A4= 0.8969D+00-0.2429D+00*SB +0.1811D+00*SB2-0.6888D-01*SB3 + A5= 0.8636D-01+0.2558D+00*SB -0.3082D+00*SB2+0.2535D+00*SB3 + ELSEIF(IPRT .EQ. 1) THEN + A0=Exp(-0.7266D+00-0.1584D+01*SB +0.1259D+01*SB2- + & 0.4305D-01*SB3) + A1= 0.5285D+00-0.3721D+00*SB +0.5150D+00*SB2-0.1697D+00*SB3 + A2= 0.4075D+01+0.8282D+00*SB -0.4496D+00*SB2+0.2107D+00*SB3 + A3= 0.3279D+01+0.5066D+01*SB -0.9134D+01*SB2+0.2897D+01*SB3 + A4= 0.4399D+00-0.5888D+00*SB +0.4802D+00*SB2-0.1664D+00*SB3 + A5= 0.3678D+00-0.8929D+00*SB +0.1592D+01*SB2-0.5713D+00*SB3 + ELSEIF(IPRT .EQ. 0) THEN + A0=Exp(-0.2318D+00-0.9779D+00*SB -0.3783D+00*SB2+ + & 0.1037D-01*SB3) + A1=-0.2916D+00+0.1754D+00*SB -0.1884D+00*SB2+0.6116D-01*SB3 + A2= 0.5349D+01+0.7460D+00*SB +0.2319D+00*SB2-0.2622D+00*SB3 + A3= 0.6920D+01-0.3454D+01*SB +0.2027D+01*SB2-0.7626D+00*SB3 + A4= 0.1013D+01+0.1423D+00*SB -0.1798D+00*SB2+0.1872D-01*SB3 + A5=-0.5465D-01+0.2303D+01*SB -0.9584D+00*SB2+0.3098D+00*SB3 + ELSEIF(IPRT .EQ. -1) THEN + A0=Exp(-0.2328D+01-0.3061D+01*SB +0.3620D+01*SB2- + & 0.1602D+01*SB3) + A1=-0.3358D+00+0.3198D+00*SB -0.4210D+00*SB2+0.1571D+00*SB3 + A2= 0.8478D+01-0.3112D+01*SB +0.5243D+01*SB2-0.2255D+01*SB3 + A3= 0.1971D+02+0.3389D+00*SB -0.5268D+01*SB2+0.2099D+01*SB3 + A4= 0.1128D+01-0.4701D+00*SB +0.7779D+00*SB2-0.3506D+00*SB3 + A5=-0.4708D+00+0.3341D+01*SB -0.3375D+01*SB2+0.1353D+01*SB3 + ELSEIF(IPRT .EQ. -2) THEN + A0=Exp(-0.2906D+01-0.1069D+00*SB -0.1055D+01*SB2+ + & 0.2496D+00*SB3) + A1=-0.2875D+00+0.6571D-01*SB -0.1987D-01*SB2-0.1800D-02*SB3 + A2= 0.9854D+01-0.2715D+00*SB -0.7407D+00*SB2+0.2888D+00*SB3 + A3= 0.1583D+02-0.7687D+01*SB +0.3428D+01*SB2-0.3327D+00*SB3 + A4= 0.9763D+00+0.7599D-01*SB -0.2128D+00*SB2+0.6852D-01*SB3 + A5=-0.8444D-02+0.9434D+00*SB +0.4152D+00*SB2-0.1481D+00*SB3 + ELSEIF(IPRT .EQ. -3) THEN + A0=Exp(-0.3780D+01+0.2499D+01*SB -0.4962D+01*SB2+ + & 0.1936D+01*SB3) + A1=-0.2639D+00-0.1575D+00*SB +0.3584D+00*SB2-0.1646D+00*SB3 + A2= 0.8082D+01+0.2794D+01*SB -0.5438D+01*SB2+0.2321D+01*SB3 + A3= 0.1811D+02-0.2000D+02*SB +0.1951D+02*SB2-0.6904D+01*SB3 + A4= 0.9822D+00+0.4972D+00*SB -0.8690D+00*SB2+0.3415D+00*SB3 + A5= 0.1772D+00-0.6078D+00*SB +0.3341D+01*SB2-0.1473D+01*SB3 + ELSEIF(IPRT .EQ. -4) THEN + A0=SB** 0.1122D+01*Exp(-0.4232D+01-0.1808D+01*SB + + & 0.5348D+00*SB2) + A1=-0.2824D+00+0.5846D+00*SB -0.7230D+00*SB2+0.2419D+00*SB3 + A2= 0.5683D+01-0.2948D+01*SB +0.5916D+01*SB2-0.2560D+01*SB3 + A3= 0.2051D+01+0.4795D+01*SB -0.4271D+01*SB2+0.4174D+00*SB3 + A4= 0.1737D+00+0.1717D+01*SB -0.1978D+01*SB2+0.6643D+00*SB3 + A5= 0.8689D+00+0.3500D+01*SB -0.3283D+01*SB2+0.1026D+01*SB3 + ELSEIF(IPRT .EQ. -5) THEN + A0=SB** 0.9906D+00*Exp(-0.1496D+01-0.6576D+01*SB + + & 0.1569D+01*SB2) + A1=-0.2140D+00-0.6419D-01*SB -0.2741D-02*SB2+0.3185D-02*SB3 + A2= 0.5781D+01+0.1049D+00*SB -0.3930D+00*SB2+0.5174D+00*SB3 + A3=-0.9420D+00+0.5511D+00*SB +0.8817D+00*SB2+0.1903D+01*SB3 + A4= 0.2418D-01+0.4232D-01*SB -0.1244D-01*SB2-0.2365D-01*SB3 + A5= 0.7664D+00+0.1794D+01*SB -0.4917D+00*SB2-0.1284D+00*SB3 + ELSEIF(IPRT .EQ. -6) THEN + A0=SB** 0.1000D+01*Exp(-0.8460D+01+0.1154D+01*SB + + & 0.8838D+01*SB2) + A1=-0.4316D-01-0.2976D+00*SB +0.3174D+00*SB2-0.1429D+01*SB3 + A2= 0.4910D+01+0.2273D+01*SB +0.5631D+01*SB2-0.1994D+02*SB3 + A3= 0.1190D+02-0.2000D+02*SB -0.2000D+02*SB2+0.1292D+02*SB3 + A4= 0.5771D+00-0.2552D+00*SB +0.7510D+00*SB2+0.6923D+00*SB3 + A5= 0.4402D+01-0.1627D+01*SB -0.2085D+01*SB2-0.6737D+01*SB3 + ENDIF + +C...Expansion for CTEQ3D. + ELSEIF(ISET .EQ. 3) THEN + IF(IPRT .EQ. 2) THEN + A0=Exp( 0.2148D+00+0.5814D-01*SB +0.2734D+00*SB2- + & 0.2902D+00*SB3) + A1= 0.4810D+00+0.1657D-01*SB -0.3800D-01*SB2+0.3125D-01*SB3 + A2= 0.3509D+01+0.3923D+00*SB +0.4010D+00*SB2-0.1932D+00*SB3 + A3= 0.7055D+01-0.6552D+01*SB +0.3466D+01*SB2-0.5657D+00*SB3 + A4= 0.1061D+01-0.3453D+00*SB +0.4089D+00*SB2-0.1817D+00*SB3 + A5= 0.8687D-01+0.2548D+00*SB -0.2967D+00*SB2+0.2647D+00*SB3 + ELSEIF(IPRT .EQ. 1) THEN + A0=Exp( 0.3961D+00+0.4914D+00*SB -0.1728D+01*SB2+ + & 0.7257D+00*SB3) + A1= 0.4162D+00-0.1419D+00*SB +0.3680D+00*SB2-0.1618D+00*SB3 + A2= 0.3248D+01+0.3028D+01*SB -0.4307D+01*SB2+0.1920D+01*SB3 + A3=-0.1100D+01+0.2184D+01*SB -0.3820D+01*SB2+0.1717D+01*SB3 + A4= 0.2082D+01-0.2756D+00*SB +0.3043D+00*SB2-0.1260D+00*SB3 + A5=-0.4822D+00-0.5706D+00*SB +0.2243D+01*SB2-0.9760D+00*SB3 + ELSEIF(IPRT .EQ. 0) THEN + A0=Exp(-0.4665D+00-0.7554D+00*SB -0.3323D+00*SB2- + & 0.2734D-04*SB3) + A1=-0.3359D+00+0.2395D+00*SB -0.2377D+00*SB2+0.7059D-01*SB3 + A2= 0.5451D+01+0.6086D+00*SB +0.8606D-01*SB2-0.1425D+00*SB3 + A3= 0.1026D+02-0.9352D+01*SB +0.4879D+01*SB2-0.1150D+01*SB3 + A4= 0.9935D+00-0.5017D-01*SB -0.1707D-01*SB2-0.1464D-02*SB3 + A5=-0.4160D-01+0.2305D+01*SB -0.1063D+01*SB2+0.3211D+00*SB3 + ELSEIF(IPRT .EQ. -1) THEN + A0=Exp(-0.2714D+01-0.2868D+01*SB +0.3700D+01*SB2- + & 0.1671D+01*SB3) + A1=-0.3893D+00+0.3341D+00*SB -0.3897D+00*SB2+0.1420D+00*SB3 + A2= 0.8359D+01-0.3267D+01*SB +0.5327D+01*SB2-0.2245D+01*SB3 + A3= 0.2359D+02-0.5669D+01*SB -0.4602D+01*SB2+0.3153D+01*SB3 + A4= 0.1106D+01-0.4745D+00*SB +0.7739D+00*SB2-0.3417D+00*SB3 + A5=-0.5557D+00+0.3433D+01*SB -0.3390D+01*SB2+0.1354D+01*SB3 + ELSEIF(IPRT .EQ. -2) THEN + A0=Exp(-0.3323D+01+0.2296D+00*SB -0.1109D+01*SB2+ + & 0.2223D+00*SB3) + A1=-0.3410D+00+0.8847D-01*SB -0.1111D-01*SB2-0.5927D-02*SB3 + A2= 0.9753D+01-0.5182D+00*SB -0.4670D+00*SB2+0.1921D+00*SB3 + A3= 0.1977D+02-0.1600D+02*SB +0.9481D+01*SB2-0.1864D+01*SB3 + A4= 0.9818D+00+0.2839D-02*SB -0.1188D+00*SB2+0.3584D-01*SB3 + A5=-0.7934D-01+0.1004D+01*SB +0.3704D+00*SB2-0.1220D+00*SB3 + ELSEIF(IPRT .EQ. -3) THEN + A0=Exp(-0.3985D+01+0.2855D+01*SB -0.5208D+01*SB2+ + & 0.1937D+01*SB3) + A1=-0.3337D+00-0.1150D+00*SB +0.3691D+00*SB2-0.1709D+00*SB3 + A2= 0.7968D+01+0.3641D+01*SB -0.6599D+01*SB2+0.2642D+01*SB3 + A3= 0.1873D+02-0.1999D+02*SB +0.1734D+02*SB2-0.5813D+01*SB3 + A4= 0.9731D+00+0.5082D+00*SB -0.8780D+00*SB2+0.3231D+00*SB3 + A5=-0.5542D-01-0.4189D+00*SB +0.3309D+01*SB2-0.1439D+01*SB3 + ELSEIF(IPRT .EQ. -4) THEN + A0=SB** 0.1105D+01*Exp(-0.3952D+01-0.1901D+01*SB + + & 0.5137D+00*SB2) + A1=-0.3543D+00+0.6055D+00*SB -0.6941D+00*SB2+0.2278D+00*SB3 + A2= 0.5955D+01-0.2629D+01*SB +0.5337D+01*SB2-0.2300D+01*SB3 + A3= 0.1933D+01+0.4882D+01*SB -0.3810D+01*SB2+0.2290D+00*SB3 + A4= 0.1806D+00+0.1655D+01*SB -0.1893D+01*SB2+0.6395D+00*SB3 + A5= 0.4790D+00+0.3612D+01*SB -0.3152D+01*SB2+0.9684D+00*SB3 + ELSEIF(IPRT .EQ. -5) THEN + A0=SB** 0.9818D+00*Exp(-0.1825D+01-0.7464D+01*SB + + & 0.2143D+01*SB2) + A1=-0.2604D+00-0.1400D+00*SB +0.1702D+00*SB2-0.8476D-01*SB3 + A2= 0.6005D+01+0.6275D+00*SB -0.2535D+01*SB2+0.2219D+01*SB3 + A3=-0.9067D+00+0.1149D+01*SB +0.1974D+01*SB2+0.4716D+01*SB3 + A4= 0.3915D-01+0.5945D-01*SB -0.9844D-01*SB2+0.2783D-01*SB3 + A5= 0.5500D+00+0.1994D+01*SB -0.6727D+00*SB2-0.1510D+00*SB3 + ELSEIF(IPRT .EQ. -6) THEN + A0=SB** 0.1002D+01*Exp(-0.8553D+01+0.3793D+00*SB + + & 0.9998D+01*SB2) + A1=-0.5870D-01-0.2792D+00*SB +0.6526D+00*SB2-0.1984D+01*SB3 + A2= 0.4716D+01+0.4473D+00*SB +0.1128D+02*SB2-0.1937D+02*SB3 + A3= 0.1289D+02-0.1742D+02*SB -0.1983D+02*SB2-0.9274D+00*SB3 + A4= 0.5647D+00-0.2732D+00*SB +0.1074D+01*SB2+0.5981D+00*SB3 + A5= 0.4390D+01-0.1262D+01*SB -0.9026D+00*SB2-0.9394D+01*SB3 + ENDIF + ENDIF + +C...Calculation of x * f(x, Q). + PYCTEQ = MAX(0D0, A0 *(X**A1) *((1D0-X)**A2) *(1D0+A3*(X**A4)) + & *(LOG(1D0+1D0/X))**A5 ) + + RETURN + END + +C********************************************************************* + +C...PYGRVL +C...Gives the GRV 94 L (leading order) parton distribution function set +C...in parametrized form. +C...Authors: M. Glueck, E. Reya and A. Vogt. + + SUBROUTINE PYGRVL (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL) + +C...Double precision declaration. + IMPLICIT DOUBLE PRECISION (A - Z) + +C...Common expressions. + MU2 = 0.23D0 + LAM2 = 0.2322D0 * 0.2322D0 + S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2)) + DS = SQRT (S) + S2 = S * S + S3 = S2 * S + +C...uv : + NU = 2.284D0 + 0.802D0 * S + 0.055D0 * S2 + AKU = 0.590D0 - 0.024D0 * S + BKU = 0.131D0 + 0.063D0 * S + AU = -0.449D0 - 0.138D0 * S - 0.076D0 * S2 + BU = 0.213D0 + 2.669D0 * S - 0.728D0 * S2 + CU = 8.854D0 - 9.135D0 * S + 1.979D0 * S2 + DU = 2.997D0 + 0.753D0 * S - 0.076D0 * S2 + UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU) + +C...dv : + ND = 0.371D0 + 0.083D0 * S + 0.039D0 * S2 + AKD = 0.376D0 + BKD = 0.486D0 + 0.062D0 * S + AD = -0.509D0 + 3.310D0 * S - 1.248D0 * S2 + BD = 12.41D0 - 10.52D0 * S + 2.267D0 * S2 + CD = 6.373D0 - 6.208D0 * S + 1.418D0 * S2 + DD = 3.691D0 + 0.799D0 * S - 0.071D0 * S2 + DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD) + +C...del : + NE = 0.082D0 + 0.014D0 * S + 0.008D0 * S2 + AKE = 0.409D0 - 0.005D0 * S + BKE = 0.799D0 + 0.071D0 * S + AE = -38.07D0 + 36.13D0 * S - 0.656D0 * S2 + BE = 90.31D0 - 74.15D0 * S + 7.645D0 * S2 + CE = 0.0D0 + DE = 7.486D0 + 1.217D0 * S - 0.159D0 * S2 + DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE) + +C...udb : + ALX = 1.451D0 + BEX = 0.271D0 + AKX = 0.410D0 - 0.232D0 * S + BKX = 0.534D0 - 0.457D0 * S + AGX = 0.890D0 - 0.140D0 * S + BGX = -0.981D0 + CX = 0.320D0 + 0.683D0 * S + DX = 4.752D0 + 1.164D0 * S + 0.286D0 * S2 + EX = 4.119D0 + 1.713D0 * S + ESX = 0.682D0 + 2.978D0 * S + UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX, + & DX, EX, ESX) + +C...sb : + STS = 0D0 + ALS = 0.914D0 + BES = 0.577D0 + AKS = 1.798D0 - 0.596D0 * S + AS = -5.548D0 + 3.669D0 * DS - 0.616D0 * S + BS = 18.92D0 - 16.73D0 * DS + 5.168D0 * S + DST = 6.379D0 - 0.350D0 * S + 0.142D0 * S2 + EST = 3.981D0 + 1.638D0 * S + ESS = 6.402D0 + SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS) + +C...cb : + STC = 0.888D0 + ALC = 1.01D0 + BEC = 0.37D0 + AKC = 0D0 + AC = 0D0 + BC = 4.24D0 - 0.804D0 * S + DCT = 3.46D0 - 1.076D0 * S + ECT = 4.61D0 + 1.49D0 * S + ESC = 2.555D0 + 1.961D0 * S + CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC) + +C...bb : + STB = 1.351D0 + ALB = 1.00D0 + BEB = 0.51D0 + AKB = 0D0 + AB = 0D0 + BB = 1.848D0 + DBT = 2.929D0 + 1.396D0 * S + EBT = 4.71D0 + 1.514D0 * S + ESB = 4.02D0 + 1.239D0 * S + BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB) + +C...gl : + ALG = 0.524D0 + BEG = 1.088D0 + AKG = 1.742D0 - 0.930D0 * S + BKG = - 0.399D0 * S2 + AG = 7.486D0 - 2.185D0 * S + BG = 16.69D0 - 22.74D0 * S + 5.779D0 * S2 + CG = -25.59D0 + 29.71D0 * S - 7.296D0 * S2 + DG = 2.792D0 + 2.215D0 * S + 0.422D0 * S2 - 0.104D0 * S3 + EG = 0.807D0 + 2.005D0 * S + ESG = 3.841D0 + 0.316D0 * S + GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, + & DG, EG, ESG) + + RETURN + END + +C********************************************************************* + +C...PYGRVM +C...Gives the GRV 94 M (MSbar) parton distribution function set +C...in parametrized form. +C...Authors: M. Glueck, E. Reya and A. Vogt. + + SUBROUTINE PYGRVM (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL) + +C...Double precision declaration. + IMPLICIT DOUBLE PRECISION (A - Z) + +C...Common expressions. + MU2 = 0.34D0 + LAM2 = 0.248D0 * 0.248D0 + S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2)) + DS = SQRT (S) + S2 = S * S + S3 = S2 * S + +C...uv : + NU = 1.304D0 + 0.863D0 * S + AKU = 0.558D0 - 0.020D0 * S + BKU = 0.183D0 * S + AU = -0.113D0 + 0.283D0 * S - 0.321D0 * S2 + BU = 6.843D0 - 5.089D0 * S + 2.647D0 * S2 - 0.527D0 * S3 + CU = 7.771D0 - 10.09D0 * S + 2.630D0 * S2 + DU = 3.315D0 + 1.145D0 * S - 0.583D0 * S2 + 0.154D0 * S3 + UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU) + +C...dv : + ND = 0.102D0 - 0.017D0 * S + 0.005D0 * S2 + AKD = 0.270D0 - 0.019D0 * S + BKD = 0.260D0 + AD = 2.393D0 + 6.228D0 * S - 0.881D0 * S2 + BD = 46.06D0 + 4.673D0 * S - 14.98D0 * S2 + 1.331D0 * S3 + CD = 17.83D0 - 53.47D0 * S + 21.24D0 * S2 + DD = 4.081D0 + 0.976D0 * S - 0.485D0 * S2 + 0.152D0 * S3 + DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD) + +C...del : + NE = 0.070D0 + 0.042D0 * S - 0.011D0 * S2 + 0.004D0 * S3 + AKE = 0.409D0 - 0.007D0 * S + BKE = 0.782D0 + 0.082D0 * S + AE = -29.65D0 + 26.49D0 * S + 5.429D0 * S2 + BE = 90.20D0 - 74.97D0 * S + 4.526D0 * S2 + CE = 0.0D0 + DE = 8.122D0 + 2.120D0 * S - 1.088D0 * S2 + 0.231D0 * S3 + DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE) + +C...udb : + ALX = 0.877D0 + BEX = 0.561D0 + AKX = 0.275D0 + BKX = 0.0D0 + AGX = 0.997D0 + BGX = 3.210D0 - 1.866D0 * S + CX = 7.300D0 + DX = 9.010D0 + 0.896D0 * DS + 0.222D0 * S2 + EX = 3.077D0 + 1.446D0 * S + ESX = 3.173D0 - 2.445D0 * DS + 2.207D0 * S + UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX, + & DX, EX, ESX) + +C...sb : + STS = 0D0 + ALS = 0.756D0 + BES = 0.216D0 + AKS = 1.690D0 + 0.650D0 * DS - 0.922D0 * S + AS = -4.329D0 + 1.131D0 * S + BS = 9.568D0 - 1.744D0 * S + DST = 9.377D0 + 1.088D0 * DS - 1.320D0 * S + 0.130D0 * S2 + EST = 3.031D0 + 1.639D0 * S + ESS = 5.837D0 + 0.815D0 * S + SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS) + +C...cb : + STC = 0.820D0 + ALC = 0.98D0 + BEC = 0D0 + AKC = -0.625D0 - 0.523D0 * S + AC = 0D0 + BC = 1.896D0 + 1.616D0 * S + DCT = 4.12D0 + 0.683D0 * S + ECT = 4.36D0 + 1.328D0 * S + ESC = 0.677D0 + 0.679D0 * S + CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC) + +C...bb : + STB = 1.297D0 + ALB = 0.99D0 + BEB = 0D0 + AKB = - 0.193D0 * S + AB = 0D0 + BB = 0D0 + DBT = 3.447D0 + 0.927D0 * S + EBT = 4.68D0 + 1.259D0 * S + ESB = 1.892D0 + 2.199D0 * S + BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB) + +C...gl : + ALG = 1.014D0 + BEG = 1.738D0 + AKG = 1.724D0 + 0.157D0 * S + BKG = 0.800D0 + 1.016D0 * S + AG = 7.517D0 - 2.547D0 * S + BG = 34.09D0 - 52.21D0 * DS + 17.47D0 * S + CG = 4.039D0 + 1.491D0 * S + DG = 3.404D0 + 0.830D0 * S + EG = -1.112D0 + 3.438D0 * S - 0.302D0 * S2 + ESG = 3.256D0 - 0.436D0 * S + GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG) + + RETURN + END + +C********************************************************************* + +C...PYGRVD +C...Gives the GRV 94 D (DIS) parton distribution function set +C...in parametrized form. +C...Authors: M. Glueck, E. Reya and A. Vogt. + + SUBROUTINE PYGRVD (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL) + +C...Double precision declaration. + IMPLICIT DOUBLE PRECISION (A - Z) + +C...Common expressions. + MU2 = 0.34D0 + LAM2 = 0.248D0 * 0.248D0 + S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2)) + DS = SQRT (S) + S2 = S * S + S3 = S2 * S + +C...uv : + NU = 2.484D0 + 0.116D0 * S + 0.093D0 * S2 + AKU = 0.563D0 - 0.025D0 * S + BKU = 0.054D0 + 0.154D0 * S + AU = -0.326D0 - 0.058D0 * S - 0.135D0 * S2 + BU = -3.322D0 + 8.259D0 * S - 3.119D0 * S2 + 0.291D0 * S3 + CU = 11.52D0 - 12.99D0 * S + 3.161D0 * S2 + DU = 2.808D0 + 1.400D0 * S - 0.557D0 * S2 + 0.119D0 * S3 + UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU) + +C...dv : + ND = 0.156D0 - 0.017D0 * S + AKD = 0.299D0 - 0.022D0 * S + BKD = 0.259D0 - 0.015D0 * S + AD = 3.445D0 + 1.278D0 * S + 0.326D0 * S2 + BD = -6.934D0 + 37.45D0 * S - 18.95D0 * S2 + 1.463D0 * S3 + CD = 55.45D0 - 69.92D0 * S + 20.78D0 * S2 + DD = 3.577D0 + 1.441D0 * S - 0.683D0 * S2 + 0.179D0 * S3 + DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD) + +C...del : + NE = 0.099D0 + 0.019D0 * S + 0.002D0 * S2 + AKE = 0.419D0 - 0.013D0 * S + BKE = 1.064D0 - 0.038D0 * S + AE = -44.00D0 + 98.70D0 * S - 14.79D0 * S2 + BE = 28.59D0 - 40.94D0 * S - 13.66D0 * S2 + 2.523D0 * S3 + CE = 84.57D0 - 108.8D0 * S + 31.52D0 * S2 + DE = 7.469D0 + 2.480D0 * S - 0.866D0 * S2 + DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE) + +C...udb : + ALX = 1.215D0 + BEX = 0.466D0 + AKX = 0.326D0 + 0.150D0 * S + BKX = 0.956D0 + 0.405D0 * S + AGX = 0.272D0 + BGX = 3.794D0 - 2.359D0 * DS + CX = 2.014D0 + DX = 7.941D0 + 0.534D0 * DS - 0.940D0 * S + 0.410D0 * S2 + EX = 3.049D0 + 1.597D0 * S + ESX = 4.396D0 - 4.594D0 * DS + 3.268D0 * S + UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX, + & DX, EX, ESX) + +C...sb : + STS = 0D0 + ALS = 0.175D0 + BES = 0.344D0 + AKS = 1.415D0 - 0.641D0 * DS + AS = 0.580D0 - 9.763D0 * DS + 6.795D0 * S - 0.558D0 * S2 + BS = 5.617D0 + 5.709D0 * DS - 3.972D0 * S + DST = 13.78D0 - 9.581D0 * S + 5.370D0 * S2 - 0.996D0 * S3 + EST = 4.546D0 + 0.372D0 * S2 + ESS = 5.053D0 - 1.070D0 * S + 0.805D0 * S2 + SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS) + +C...cb : + STC = 0.820D0 + ALC = 0.98D0 + BEC = 0D0 + AKC = -0.625D0 - 0.523D0 * S + AC = 0D0 + BC = 1.896D0 + 1.616D0 * S + DCT = 4.12D0 + 0.683D0 * S + ECT = 4.36D0 + 1.328D0 * S + ESC = 0.677D0 + 0.679D0 * S + CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC) + +C...bb : + STB = 1.297D0 + ALB = 0.99D0 + BEB = 0D0 + AKB = - 0.193D0 * S + AB = 0D0 + BB = 0D0 + DBT = 3.447D0 + 0.927D0 * S + EBT = 4.68D0 + 1.259D0 * S + ESB = 1.892D0 + 2.199D0 * S + BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB) + +C...gl : + ALG = 1.258D0 + BEG = 1.846D0 + AKG = 2.423D0 + BKG = 2.427D0 + 1.311D0 * S - 0.153D0 * S2 + AG = 25.09D0 - 7.935D0 * S + BG = -14.84D0 - 124.3D0 * DS + 72.18D0 * S + CG = 590.3D0 - 173.8D0 * S + DG = 5.196D0 + 1.857D0 * S + EG = -1.648D0 + 3.988D0 * S - 0.432D0 * S2 + ESG = 3.232D0 - 0.542D0 * S + GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG) + + RETURN + END + +C********************************************************************* + +C...PYGRVV +C...Auxiliary for the GRV 94 parton distribution functions +C...for u and d valence and d-u sea. +C...Authors: M. Glueck, E. Reya and A. Vogt. + + FUNCTION PYGRVV (X, N, AK, BK, A, B, C, D) + +C...Double precision declaration. + IMPLICIT DOUBLE PRECISION (A - Z) + +C...Evaluation. + DX = SQRT (X) + PYGRVV = N * X**AK * (1D0+ A*X**BK + X * (B + C*DX)) * + & (1D0- X)**D + + RETURN + END + +C********************************************************************* + +C...PYGRVW +C...Auxiliary for the GRV 94 parton distribution functions +C...for d+u sea and gluon. +C...Authors: M. Glueck, E. Reya and A. Vogt. + + FUNCTION PYGRVW (X, S, AL, BE, AK, BK, A, B, C, D, E, ES) + +C...Double precision declaration. + IMPLICIT DOUBLE PRECISION (A - Z) + +C...Evaluation. + LX = LOG (1D0/X) + PYGRVW = (X**AK * (A + X * (B + X*C)) * LX**BK + S**AL + & * EXP (-E + SQRT (ES * S**BE * LX))) * (1D0- X)**D + + RETURN + END + +C********************************************************************* + +C...PYGRVS +C...Auxiliary for the GRV 94 parton distribution functions +C...for s, c and b sea. +C...Authors: M. Glueck, E. Reya and A. Vogt. + + FUNCTION PYGRVS (X, S, STH, AL, BE, AK, AG, B, D, E, ES) + +C...Double precision declaration. + IMPLICIT DOUBLE PRECISION (A - Z) + +C...Evaluation. + IF(S.LE.STH) THEN + PYGRVS = 0D0 + ELSE + DX = SQRT (X) + LX = LOG (1D0/X) + PYGRVS = (S - STH)**AL / LX**AK * (1D0+ AG*DX + B*X) * + & (1D0- X)**D * EXP (-E + SQRT (ES * S**BE * LX)) + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYCT5L +C...Auxiliary function for parametrization of CTEQ5L. +C...Author: J. Pumplin 9/99. + +C...CTEQ5M1 and CTEQ5L Parton Distribution Functions +C...in Parametrized Form +C... September 15, 1999 +C +C...Ref: "GLOBAL QCD ANALYSIS OF PARTON STRUCTURE OF THE NUCLEON: +C... CTEQ5 PPARTON DISTRIBUTIONS" +C...hep-ph/9903282 + +C...The CTEQ5M1 set given here is an updated version of the original +C...CTEQ5M set posted, in the table version, on the Web page of CTEQ. +C...The differences between CTEQ5M and CTEQ5M1 are insignificant for +C...almost all applications. +C...The improvement is in the QCD evolution which is now more +C...accurate, and which agrees completely with the benchmark work +C...of the HERA 96/97 Workshop. +C...The differences between the parametrized and the corresponding +C...table versions (on which it is based) are of similar order as +C...between the two version. + +C...!! Because accurate parametrizations over a wide range of (x,Q) +C...is hard to obtain, only the most widely used sets CTEQ5M and +C...CTEQ5L are available in parametrized form for now. + +C...These parametrizations were obtained by Jon Pumplin. + +C Iset PDF Description Alpha_s(Mz) Lam4 Lam5 +C ------------------------------------------------------------------- +C 1 CTEQ5M1 Standard NLO MSbar scheme 0.118 326 226 +C 3 CTEQ5L Leading Order 0.127 192 146 +C ------------------------------------------------------------------- +C...Note the Qcd-lambda values given for CTEQ5L is for the leading +C...order form of Alpha_s!! Alpha_s(Mz) gives the absolute +C...calibration. + +C...The two Iset value are adopted to agree with the standard table +C...versions. + +C...Range of validity: +C...The range of (x, Q) covered by this parametrization of the QCD +C...evolved parton distributions is 1E-6 < x < 1 ; +C...1.1 GeV < Q < 10 TeV. Of course, the PDFs are constrained by +C...data only in a subset of that region; and the assumed DGLAP +C...evolution is unlikely to be valid for all of it either. + +C...The range of (x, Q) used in the CTEQ5 round of global analysis is +C...approximately 0.01 < x < 0.75 ; and 4 GeV^2 < Q^2 < 400 GeV^2 for +C...fixed target experiments; 0.0001 < x < 0.3 from HERA data; and +C...Q^2 up to 40,000 GeV^2 from Tevatron inclusive Jet data. + + FUNCTION PYCT5L(IFL,X,Q) + +C...Double precision declaration. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + + PARAMETER (NEX=8, NLF=2) + DIMENSION AM(0:NEX,0:NLF,-5:2) + DIMENSION ALFVEC(-5:2), QMAVEC(-5:2) + DIMENSION MEXVEC(-5:2), MLFVEC(-5:2) + DIMENSION UT1VEC(-5:2), UT2VEC(-5:2) + DIMENSION AF(0:NEX) + + DATA MEXVEC( 2) / 8 / + DATA MLFVEC( 2) / 2 / + DATA UT1VEC( 2) / 0.4971265E+01 / + DATA UT2VEC( 2) / -0.1105128E+01 / + DATA ALFVEC( 2) / 0.2987216E+00 / + DATA QMAVEC( 2) / 0.0000000E+00 / + DATA (AM( 0,K, 2),K=0, 2) + & / 0.5292616E+01, -0.2751910E+01, -0.2488990E+01 / + DATA (AM( 1,K, 2),K=0, 2) + & / 0.9714424E+00, 0.1011827E-01, -0.1023660E-01 / + DATA (AM( 2,K, 2),K=0, 2) + & / -0.1651006E+02, 0.7959721E+01, 0.8810563E+01 / + DATA (AM( 3,K, 2),K=0, 2) + & / -0.1643394E+02, 0.5892854E+01, 0.9348874E+01 / + DATA (AM( 4,K, 2),K=0, 2) + & / 0.3067422E+02, 0.4235796E+01, -0.5112136E+00 / + DATA (AM( 5,K, 2),K=0, 2) + & / 0.2352526E+02, -0.5305168E+01, -0.1169174E+02 / + DATA (AM( 6,K, 2),K=0, 2) + & / -0.1095451E+02, 0.3006577E+01, 0.5638136E+01 / + DATA (AM( 7,K, 2),K=0, 2) + & / -0.1172251E+02, -0.2183624E+01, 0.4955794E+01 / + DATA (AM( 8,K, 2),K=0, 2) + & / 0.1662533E-01, 0.7622870E-02, -0.4895887E-03 / + + DATA MEXVEC( 1) / 8 / + DATA MLFVEC( 1) / 2 / + DATA UT1VEC( 1) / 0.2612618E+01 / + DATA UT2VEC( 1) / -0.1258304E+06 / + DATA ALFVEC( 1) / 0.3407552E+00 / + DATA QMAVEC( 1) / 0.0000000E+00 / + DATA (AM( 0,K, 1),K=0, 2) + & / 0.9905300E+00, -0.4502235E+00, 0.1624441E+00 / + DATA (AM( 1,K, 1),K=0, 2) + & / 0.8867534E+00, 0.1630829E-01, -0.4049085E-01 / + DATA (AM( 2,K, 1),K=0, 2) + & / 0.8547974E+00, 0.3336301E+00, 0.1371388E+00 / + DATA (AM( 3,K, 1),K=0, 2) + & / 0.2941113E+00, -0.1527905E+01, 0.2331879E+00 / + DATA (AM( 4,K, 1),K=0, 2) + & / 0.3384235E+02, 0.3715315E+01, 0.8276930E+00 / + DATA (AM( 5,K, 1),K=0, 2) + & / 0.6230115E+01, 0.3134639E+01, -0.1729099E+01 / + DATA (AM( 6,K, 1),K=0, 2) + & / -0.1186928E+01, -0.3282460E+00, 0.1052020E+00 / + DATA (AM( 7,K, 1),K=0, 2) + & / -0.8545702E+01, -0.6247947E+01, 0.3692561E+01 / + DATA (AM( 8,K, 1),K=0, 2) + & / 0.1724598E-01, 0.7120465E-02, 0.4003646E-04 / + + DATA MEXVEC( 0) / 8 / + DATA MLFVEC( 0) / 2 / + DATA UT1VEC( 0) / -0.4656819E+00 / + DATA UT2VEC( 0) / -0.2742390E+03 / + DATA ALFVEC( 0) / 0.4491863E+00 / + DATA QMAVEC( 0) / 0.0000000E+00 / + DATA (AM( 0,K, 0),K=0, 2) + & / 0.1193572E+03, -0.3886845E+01, -0.1133965E+01 / + DATA (AM( 1,K, 0),K=0, 2) + & / -0.9421449E+02, 0.3995885E+01, 0.1607363E+01 / + DATA (AM( 2,K, 0),K=0, 2) + & / 0.4206383E+01, 0.2485954E+00, 0.2497468E+00 / + DATA (AM( 3,K, 0),K=0, 2) + & / 0.1210557E+03, -0.3015765E+01, -0.1423651E+01 / + DATA (AM( 4,K, 0),K=0, 2) + & / -0.1013897E+03, -0.7113478E+00, 0.2621865E+00 / + DATA (AM( 5,K, 0),K=0, 2) + & / -0.1312404E+01, -0.9297691E+00, -0.1562531E+00 / + DATA (AM( 6,K, 0),K=0, 2) + & / 0.1627137E+01, 0.4954111E+00, -0.6387009E+00 / + DATA (AM( 7,K, 0),K=0, 2) + & / 0.1537698E+00, -0.2487878E+00, 0.8305947E+00 / + DATA (AM( 8,K, 0),K=0, 2) + & / 0.2496448E-01, 0.2457823E-02, 0.8234276E-03 / + + DATA MEXVEC(-1) / 8 / + DATA MLFVEC(-1) / 2 / + DATA UT1VEC(-1) / 0.3862583E+01 / + DATA UT2VEC(-1) / -0.1265969E+01 / + DATA ALFVEC(-1) / 0.2457668E+00 / + DATA QMAVEC(-1) / 0.0000000E+00 / + DATA (AM( 0,K,-1),K=0, 2) + & / 0.2647441E+02, 0.1059277E+02, -0.9176654E+00 / + DATA (AM( 1,K,-1),K=0, 2) + & / 0.1990636E+01, 0.8558918E-01, 0.4248667E-01 / + DATA (AM( 2,K,-1),K=0, 2) + & / -0.1476095E+02, -0.3276255E+02, 0.1558110E+01 / + DATA (AM( 3,K,-1),K=0, 2) + & / -0.2966889E+01, -0.3649037E+02, 0.1195914E+01 / + DATA (AM( 4,K,-1),K=0, 2) + & / -0.1000519E+03, -0.2464635E+01, 0.1964849E+00 / + DATA (AM( 5,K,-1),K=0, 2) + & / 0.3718331E+02, 0.4700389E+02, -0.2772142E+01 / + DATA (AM( 6,K,-1),K=0, 2) + & / -0.1872722E+02, -0.2291189E+02, 0.1089052E+01 / + DATA (AM( 7,K,-1),K=0, 2) + & / -0.1628146E+02, -0.1823993E+02, 0.2537369E+01 / + DATA (AM( 8,K,-1),K=0, 2) + & / -0.1156300E+01, -0.1280495E+00, 0.5153245E-01 / + + DATA MEXVEC(-2) / 7 / + DATA MLFVEC(-2) / 2 / + DATA UT1VEC(-2) / 0.1895615E+00 / + DATA UT2VEC(-2) / -0.3069097E+01 / + DATA ALFVEC(-2) / 0.5293999E+00 / + DATA QMAVEC(-2) / 0.0000000E+00 / + DATA (AM( 0,K,-2),K=0, 2) + & / -0.6556775E+00, 0.2490190E+00, 0.3966485E-01 / + DATA (AM( 1,K,-2),K=0, 2) + & / 0.1305102E+01, -0.1188925E+00, -0.4600870E-02 / + DATA (AM( 2,K,-2),K=0, 2) + & / -0.2371436E+01, 0.3566814E+00, -0.2834683E+00 / + DATA (AM( 3,K,-2),K=0, 2) + & / -0.6152826E+01, 0.8339877E+00, -0.7233230E+00 / + DATA (AM( 4,K,-2),K=0, 2) + & / -0.8346558E+01, 0.2892168E+01, 0.2137099E+00 / + DATA (AM( 5,K,-2),K=0, 2) + & / 0.1279530E+02, 0.1021114E+00, 0.5787439E+00 / + DATA (AM( 6,K,-2),K=0, 2) + & / 0.5858816E+00, -0.1940375E+01, -0.4029269E+00 / + DATA (AM( 7,K,-2),K=0, 2) + & / -0.2795725E+02, -0.5263392E+00, 0.1290229E+01 / + + DATA MEXVEC(-3) / 7 / + DATA MLFVEC(-3) / 2 / + DATA UT1VEC(-3) / 0.3753257E+01 / + DATA UT2VEC(-3) / -0.1113085E+01 / + DATA ALFVEC(-3) / 0.3713141E+00 / + DATA QMAVEC(-3) / 0.0000000E+00 / + DATA (AM( 0,K,-3),K=0, 2) + & / 0.1580931E+01, -0.2273826E+01, -0.1822245E+01 / + DATA (AM( 1,K,-3),K=0, 2) + & / 0.2702644E+01, 0.6763243E+00, 0.7231586E-02 / + DATA (AM( 2,K,-3),K=0, 2) + & / -0.1857924E+02, 0.3907500E+01, 0.5850109E+01 / + DATA (AM( 3,K,-3),K=0, 2) + & / -0.3044793E+02, 0.2639332E+01, 0.5566644E+01 / + DATA (AM( 4,K,-3),K=0, 2) + & / -0.4258011E+01, -0.5429244E+01, 0.4418946E+00 / + DATA (AM( 5,K,-3),K=0, 2) + & / 0.3465259E+02, -0.5532604E+01, -0.4904153E+01 / + DATA (AM( 6,K,-3),K=0, 2) + & / -0.1658858E+02, 0.2923275E+01, 0.2266286E+01 / + DATA (AM( 7,K,-3),K=0, 2) + & / -0.1149263E+02, 0.2877475E+01, -0.7999105E+00 / + + DATA MEXVEC(-4) / 7 / + DATA MLFVEC(-4) / 2 / + DATA UT1VEC(-4) / 0.4400772E+01 / + DATA UT2VEC(-4) / -0.1356116E+01 / + DATA ALFVEC(-4) / 0.3712017E-01 / + DATA QMAVEC(-4) / 0.1300000E+01 / + DATA (AM( 0,K,-4),K=0, 2) + & / -0.8293661E+00, -0.3982375E+01, -0.6494283E-01 / + DATA (AM( 1,K,-4),K=0, 2) + & / 0.2754618E+01, 0.8338636E+00, -0.6885160E-01 / + DATA (AM( 2,K,-4),K=0, 2) + & / -0.1657987E+02, 0.1439143E+02, -0.6887240E+00 / + DATA (AM( 3,K,-4),K=0, 2) + & / -0.2800703E+02, 0.1535966E+02, -0.7377693E+00 / + DATA (AM( 4,K,-4),K=0, 2) + & / -0.6460216E+01, -0.4783019E+01, 0.4913297E+00 / + DATA (AM( 5,K,-4),K=0, 2) + & / 0.3141830E+02, -0.3178031E+02, 0.7136013E+01 / + DATA (AM( 6,K,-4),K=0, 2) + & / -0.1802509E+02, 0.1862163E+02, -0.4632843E+01 / + DATA (AM( 7,K,-4),K=0, 2) + & / -0.1240412E+02, 0.2565386E+02, -0.1066570E+02 / + + DATA MEXVEC(-5) / 6 / + DATA MLFVEC(-5) / 2 / + DATA UT1VEC(-5) / 0.5562568E+01 / + DATA UT2VEC(-5) / -0.1801317E+01 / + DATA ALFVEC(-5) / 0.4952010E-02 / + DATA QMAVEC(-5) / 0.4500000E+01 / + DATA (AM( 0,K,-5),K=0, 2) + & / -0.6031237E+01, 0.1992727E+01, -0.1076331E+01 / + DATA (AM( 1,K,-5),K=0, 2) + & / 0.2933912E+01, 0.5839674E+00, 0.7509435E-01 / + DATA (AM( 2,K,-5),K=0, 2) + & / -0.8284919E+01, 0.1488593E+01, -0.8251678E+00 / + DATA (AM( 3,K,-5),K=0, 2) + & / -0.1925986E+02, 0.2805753E+01, -0.3015446E+01 / + DATA (AM( 4,K,-5),K=0, 2) + & / -0.9480483E+01, -0.9767837E+00, -0.1165544E+01 / + DATA (AM( 5,K,-5),K=0, 2) + & / 0.2193195E+02, -0.1788518E+02, 0.9460908E+01 / + DATA (AM( 6,K,-5),K=0, 2) + & / -0.1327377E+02, 0.1201754E+02, -0.6277844E+01 / + + IF(Q .LE. QMAVEC(IFL)) THEN + PYCT5L = 0.D0 + RETURN + ENDIF + + IF(X .GE. 1.D0) THEN + PYCT5L = 0.D0 + RETURN + ENDIF + + TMP = LOG(Q/ALFVEC(IFL)) + IF(TMP .LE. 0.D0) THEN + PYCT5L = 0.D0 + RETURN + ENDIF + + SB = LOG(TMP) + SB1 = SB - 1.2D0 + SB2 = SB1*SB1 + + DO 110 I = 0, NEX + AF(I) = 0.D0 + SBX = 1.D0 + DO 100 K = 0, MLFVEC(IFL) + AF(I) = AF(I) + SBX*AM(I,K,IFL) + SBX = SB1*SBX + 100 CONTINUE + 110 CONTINUE + + Y = -LOG(X) + U = LOG(X/0.00001D0) + + PART1 = AF(1)*Y**(1.D0+0.01D0*AF(4))*(1.D0+ AF(8)*U) + PART2 = AF(0)*(1.D0 - X) + AF(3)*X + PART3 = X*(1.D0-X)*(AF(5)+AF(6)*(1.D0-X)+AF(7)*X*(1.D0-X)) + PART4 = UT1VEC(IFL)*LOG(1.D0-X) + + & AF(2)*LOG(1.D0+EXP(UT2VEC(IFL))-X) + + PYCT5L = EXP(LOG(X) + PART1 + PART2 + PART3 + PART4) + +C...Include threshold factor. + PYCT5L = PYCT5L * (1.D0 - QMAVEC(IFL)/Q) + + RETURN + END + +C********************************************************************* + +C...PYCT5M +C...Auxiliary function for parametrization of CTEQ5M1. +C...Author: J. Pumplin 9/99. + + FUNCTION PYCT5M(IFL,X,Q) + +C...Double precision declaration. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + + PARAMETER (NEX=8, NLF=2) + DIMENSION AM(0:NEX,0:NLF,-5:2) + DIMENSION ALFVEC(-5:2), QMAVEC(-5:2) + DIMENSION MEXVEC(-5:2), MLFVEC(-5:2) + DIMENSION UT1VEC(-5:2), UT2VEC(-5:2) + DIMENSION AF(0:NEX) + + DATA MEXVEC( 2) / 8 / + DATA MLFVEC( 2) / 2 / + DATA UT1VEC( 2) / 0.5141718E+01 / + DATA UT2VEC( 2) / -0.1346944E+01 / + DATA ALFVEC( 2) / 0.5260555E+00 / + DATA QMAVEC( 2) / 0.0000000E+00 / + DATA (AM( 0,K, 2),K=0, 2) + & / 0.4289071E+01, -0.2536870E+01, -0.1259948E+01 / + DATA (AM( 1,K, 2),K=0, 2) + & / 0.9839410E+00, 0.4168426E-01, -0.5018952E-01 / + DATA (AM( 2,K, 2),K=0, 2) + & / -0.1651961E+02, 0.9246261E+01, 0.5996400E+01 / + DATA (AM( 3,K, 2),K=0, 2) + & / -0.2077936E+02, 0.9786469E+01, 0.7656465E+01 / + DATA (AM( 4,K, 2),K=0, 2) + & / 0.3054926E+02, 0.1889536E+01, 0.1380541E+01 / + DATA (AM( 5,K, 2),K=0, 2) + & / 0.3084695E+02, -0.1212303E+02, -0.1053551E+02 / + DATA (AM( 6,K, 2),K=0, 2) + & / -0.1426778E+02, 0.6239537E+01, 0.5254819E+01 / + DATA (AM( 7,K, 2),K=0, 2) + & / -0.1909811E+02, 0.3695678E+01, 0.5495729E+01 / + DATA (AM( 8,K, 2),K=0, 2) + & / 0.1889751E-01, 0.5027193E-02, 0.6624896E-03 / + + DATA MEXVEC( 1) / 8 / + DATA MLFVEC( 1) / 2 / + DATA UT1VEC( 1) / 0.4138426E+01 / + DATA UT2VEC( 1) / -0.3221374E+01 / + DATA ALFVEC( 1) / 0.4960962E+00 / + DATA QMAVEC( 1) / 0.0000000E+00 / + DATA (AM( 0,K, 1),K=0, 2) + & / 0.1332497E+01, -0.3703718E+00, 0.1288638E+00 / + DATA (AM( 1,K, 1),K=0, 2) + & / 0.7544687E+00, 0.3255075E-01, -0.4706680E-01 / + DATA (AM( 2,K, 1),K=0, 2) + & / -0.7638814E+00, 0.5008313E+00, -0.9237374E-01 / + DATA (AM( 3,K, 1),K=0, 2) + & / -0.3689889E+00, -0.1055098E+01, -0.4645065E+00 / + DATA (AM( 4,K, 1),K=0, 2) + & / 0.3991610E+02, 0.1979881E+01, 0.1775814E+01 / + DATA (AM( 5,K, 1),K=0, 2) + & / 0.6201080E+01, 0.2046288E+01, 0.3804571E+00 / + DATA (AM( 6,K, 1),K=0, 2) + & / -0.8027900E+00, -0.7011688E+00, -0.8049612E+00 / + DATA (AM( 7,K, 1),K=0, 2) + & / -0.8631305E+01, -0.3981200E+01, 0.6970153E+00 / + DATA (AM( 8,K, 1),K=0, 2) + & / 0.2371230E-01, 0.5372683E-02, 0.1118701E-02 / + + DATA MEXVEC( 0) / 8 / + DATA MLFVEC( 0) / 2 / + DATA UT1VEC( 0) / -0.1026789E+01 / + DATA UT2VEC( 0) / -0.9051707E+01 / + DATA ALFVEC( 0) / 0.9462977E+00 / + DATA QMAVEC( 0) / 0.0000000E+00 / + DATA (AM( 0,K, 0),K=0, 2) + & / 0.1191990E+03, -0.8548739E+00, -0.1963040E+01 / + DATA (AM( 1,K, 0),K=0, 2) + & / -0.9449972E+02, 0.1074771E+01, 0.2056055E+01 / + DATA (AM( 2,K, 0),K=0, 2) + & / 0.3701064E+01, -0.1167947E-02, 0.1933573E+00 / + DATA (AM( 3,K, 0),K=0, 2) + & / 0.1171345E+03, -0.1064540E+01, -0.1875312E+01 / + DATA (AM( 4,K, 0),K=0, 2) + & / -0.1014453E+03, -0.5707427E+00, 0.4511242E-01 / + DATA (AM( 5,K, 0),K=0, 2) + & / 0.6365168E+01, 0.1275354E+01, -0.4964081E+00 / + DATA (AM( 6,K, 0),K=0, 2) + & / -0.3370693E+01, -0.1122020E+01, 0.5947751E-01 / + DATA (AM( 7,K, 0),K=0, 2) + & / -0.5327270E+01, -0.9293556E+00, 0.6629940E+00 / + DATA (AM( 8,K, 0),K=0, 2) + & / 0.2437513E-01, 0.1600939E-02, 0.6855336E-03 / + + DATA MEXVEC(-1) / 8 / + DATA MLFVEC(-1) / 2 / + DATA UT1VEC(-1) / 0.5243571E+01 / + DATA UT2VEC(-1) / -0.2870513E+01 / + DATA ALFVEC(-1) / 0.6701448E+00 / + DATA QMAVEC(-1) / 0.0000000E+00 / + DATA (AM( 0,K,-1),K=0, 2) + & / 0.2428863E+02, 0.1907035E+01, -0.4606457E+00 / + DATA (AM( 1,K,-1),K=0, 2) + & / 0.2006810E+01, -0.1265915E+00, 0.7153556E-02 / + DATA (AM( 2,K,-1),K=0, 2) + & / -0.1884546E+02, -0.2339471E+01, 0.5740679E+01 / + DATA (AM( 3,K,-1),K=0, 2) + & / -0.2527892E+02, -0.2044124E+01, 0.1280470E+02 / + DATA (AM( 4,K,-1),K=0, 2) + & / -0.1013824E+03, -0.1594199E+01, 0.2216401E+00 / + DATA (AM( 5,K,-1),K=0, 2) + & / 0.8070930E+02, 0.1792072E+01, -0.2164364E+02 / + DATA (AM( 6,K,-1),K=0, 2) + & / -0.4641050E+02, 0.1977338E+00, 0.1273014E+02 / + DATA (AM( 7,K,-1),K=0, 2) + & / -0.3910568E+02, 0.1719632E+01, 0.1086525E+02 / + DATA (AM( 8,K,-1),K=0, 2) + & / -0.1185496E+01, -0.1905847E+00, -0.8744118E-03 / + + DATA MEXVEC(-2) / 7 / + DATA MLFVEC(-2) / 2 / + DATA UT1VEC(-2) / 0.4782210E+01 / + DATA UT2VEC(-2) / -0.1976856E+02 / + DATA ALFVEC(-2) / 0.7558374E+00 / + DATA QMAVEC(-2) / 0.0000000E+00 / + DATA (AM( 0,K,-2),K=0, 2) + & / -0.6216935E+00, 0.2369963E+00, -0.7909949E-02 / + DATA (AM( 1,K,-2),K=0, 2) + & / 0.1245440E+01, -0.1031510E+00, 0.4916523E-02 / + DATA (AM( 2,K,-2),K=0, 2) + & / -0.7060824E+01, -0.3875283E-01, 0.1784981E+00 / + DATA (AM( 3,K,-2),K=0, 2) + & / -0.7430595E+01, 0.1964572E+00, -0.1284999E+00 / + DATA (AM( 4,K,-2),K=0, 2) + & / -0.6897810E+01, 0.2620543E+01, 0.8012553E-02 / + DATA (AM( 5,K,-2),K=0, 2) + & / 0.1507713E+02, 0.2340307E-01, 0.2482535E+01 / + DATA (AM( 6,K,-2),K=0, 2) + & / -0.1815341E+01, -0.1538698E+01, -0.2014208E+01 / + DATA (AM( 7,K,-2),K=0, 2) + & / -0.2571932E+02, 0.2903941E+00, -0.2848206E+01 / + + DATA MEXVEC(-3) / 7 / + DATA MLFVEC(-3) / 2 / + DATA UT1VEC(-3) / 0.4518239E+01 / + DATA UT2VEC(-3) / -0.2690590E+01 / + DATA ALFVEC(-3) / 0.6124079E+00 / + DATA QMAVEC(-3) / 0.0000000E+00 / + DATA (AM( 0,K,-3),K=0, 2) + & / -0.2734458E+01, -0.7245673E+00, -0.6351374E+00 / + DATA (AM( 1,K,-3),K=0, 2) + & / 0.2927174E+01, 0.4822709E+00, -0.1088787E-01 / + DATA (AM( 2,K,-3),K=0, 2) + & / -0.1771017E+02, -0.1416635E+01, 0.8467622E+01 / + DATA (AM( 3,K,-3),K=0, 2) + & / -0.4972782E+02, -0.3348547E+01, 0.1767061E+02 / + DATA (AM( 4,K,-3),K=0, 2) + & / -0.7102770E+01, -0.3205337E+01, 0.4101704E+00 / + DATA (AM( 5,K,-3),K=0, 2) + & / 0.7169698E+02, -0.2205985E+01, -0.2463931E+02 / + DATA (AM( 6,K,-3),K=0, 2) + & / -0.4090347E+02, 0.2103486E+01, 0.1416507E+02 / + DATA (AM( 7,K,-3),K=0, 2) + & / -0.2952639E+02, 0.5376136E+01, 0.7825585E+01 / + + DATA MEXVEC(-4) / 7 / + DATA MLFVEC(-4) / 2 / + DATA UT1VEC(-4) / 0.2783230E+01 / + DATA UT2VEC(-4) / -0.1746328E+01 / + DATA ALFVEC(-4) / 0.1115653E+01 / + DATA QMAVEC(-4) / 0.1300000E+01 / + DATA (AM( 0,K,-4),K=0, 2) + & / -0.1743872E+01, -0.1128921E+01, -0.2841969E+00 / + DATA (AM( 1,K,-4),K=0, 2) + & / 0.3345755E+01, 0.3187765E+00, 0.1378124E+00 / + DATA (AM( 2,K,-4),K=0, 2) + & / -0.2037615E+02, 0.4121687E+01, 0.2236520E+00 / + DATA (AM( 3,K,-4),K=0, 2) + & / -0.4703104E+02, 0.5353087E+01, -0.1455347E+01 / + DATA (AM( 4,K,-4),K=0, 2) + & / -0.1060230E+02, -0.1551122E+01, -0.1078863E+01 / + DATA (AM( 5,K,-4),K=0, 2) + & / 0.5088892E+02, -0.8197304E+01, 0.8083451E+01 / + DATA (AM( 6,K,-4),K=0, 2) + & / -0.2819070E+02, 0.4554086E+01, -0.5890995E+01 / + DATA (AM( 7,K,-4),K=0, 2) + & / -0.1098238E+02, 0.2590096E+01, -0.8062879E+01 / + + DATA MEXVEC(-5) / 6 / + DATA MLFVEC(-5) / 2 / + DATA UT1VEC(-5) / 0.1619654E+02 / + DATA UT2VEC(-5) / -0.3367346E+01 / + DATA ALFVEC(-5) / 0.5109891E-02 / + DATA QMAVEC(-5) / 0.4500000E+01 / + DATA (AM( 0,K,-5),K=0, 2) + & / -0.6800138E+01, 0.2493627E+01, -0.1075724E+01 / + DATA (AM( 1,K,-5),K=0, 2) + & / 0.3036555E+01, 0.3324733E+00, 0.2008298E+00 / + DATA (AM( 2,K,-5),K=0, 2) + & / -0.5203879E+01, -0.8493476E+01, -0.4523208E+01 / + DATA (AM( 3,K,-5),K=0, 2) + & / -0.1524239E+01, -0.3411912E+01, -0.1771867E+02 / + DATA (AM( 4,K,-5),K=0, 2) + & / -0.1099444E+02, 0.1320930E+01, -0.2353831E+01 / + DATA (AM( 5,K,-5),K=0, 2) + & / 0.1699299E+02, -0.3565802E+02, 0.3566872E+02 / + DATA (AM( 6,K,-5),K=0, 2) + & / -0.1465793E+02, 0.2703365E+02, -0.2176372E+02 / + + IF(Q .LE. QMAVEC(IFL)) THEN + PYCT5M = 0.D0 + RETURN + ENDIF + + IF(X .GE. 1.D0) THEN + PYCT5M = 0.D0 + RETURN + ENDIF + + TMP = LOG(Q/ALFVEC(IFL)) + IF(TMP .LE. 0.D0) THEN + PYCT5M = 0.D0 + RETURN + ENDIF + + SB = LOG(TMP) + SB1 = SB - 1.2D0 + SB2 = SB1*SB1 + + DO 110 I = 0, NEX + AF(I) = 0.D0 + SBX = 1.D0 + DO 100 K = 0, MLFVEC(IFL) + AF(I) = AF(I) + SBX*AM(I,K,IFL) + SBX = SB1*SBX + 100 CONTINUE + 110 CONTINUE + + Y = -LOG(X) + U = LOG(X/0.00001D0) + + PART1 = AF(1)*Y**(1.D0+0.01D0*AF(4))*(1.D0+ AF(8)*U) + PART2 = AF(0)*(1.D0 - X) + AF(3)*X + PART3 = X*(1.D0-X)*(AF(5)+AF(6)*(1.D0-X)+AF(7)*X*(1.D0-X)) + PART4 = UT1VEC(IFL)*LOG(1.D0-X) + + & AF(2)*LOG(1.D0+EXP(UT2VEC(IFL))-X) + + PYCT5M = EXP(LOG(X) + PART1 + PART2 + PART3 + PART4) + +C...Include threshold factor. + PYCT5M = PYCT5M * (1.D0 - QMAVEC(IFL)/Q) + + RETURN + END + +C********************************************************************* + +C...PYPDPO +C...Auxiliary to PYPDPR. Gives proton parton distributions according to +C...a few older parametrizations, now obsolete but convenient for +C...backwards checks. + + SUBROUTINE PYPDPO(X,Q2,XPPR) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/ + DIMENSION XPPR(-6:6),XQ(9),TX(6),TT(6),TS(6),NEHLQ(8,2), + &CEHLQ(6,6,2,8,2),CDO(3,6,5,2) + + +C...The following data lines are coefficients needed in the +C...Eichten, Hinchliffe, Lane, Quigg proton structure function +C...parametrizations, see below. +C...Powers of 1-x in different cases. + DATA NEHLQ/3,4,7,5,7,7,7,7,3,4,7,6,7,7,7,7/ +C...Expansion coefficients for up valence quark distribution. + DATA (((CEHLQ(IX,IT,NX,1,1),IX=1,6),IT=1,6),NX=1,2)/ + 1 7.677D-01,-2.087D-01,-3.303D-01,-2.517D-02,-1.570D-02,-1.000D-04, + 2-5.326D-01,-2.661D-01, 3.201D-01, 1.192D-01, 2.434D-02, 7.620D-03, + 3 2.162D-01, 1.881D-01,-8.375D-02,-6.515D-02,-1.743D-02,-5.040D-03, + 4-9.211D-02,-9.952D-02, 1.373D-02, 2.506D-02, 8.770D-03, 2.550D-03, + 5 3.670D-02, 4.409D-02, 9.600D-04,-7.960D-03,-3.420D-03,-1.050D-03, + 6-1.549D-02,-2.026D-02,-3.060D-03, 2.220D-03, 1.240D-03, 4.100D-04, + 1 2.395D-01, 2.905D-01, 9.778D-02, 2.149D-02, 3.440D-03, 5.000D-04, + 2 1.751D-02,-6.090D-03,-2.687D-02,-1.916D-02,-7.970D-03,-2.750D-03, + 3-5.760D-03,-5.040D-03, 1.080D-03, 2.490D-03, 1.530D-03, 7.500D-04, + 4 1.740D-03, 1.960D-03, 3.000D-04,-3.400D-04,-2.900D-04,-1.800D-04, + 5-5.300D-04,-6.400D-04,-1.700D-04, 4.000D-05, 6.000D-05, 4.000D-05, + 6 1.700D-04, 2.200D-04, 8.000D-05, 1.000D-05,-1.000D-05,-1.000D-05/ + DATA (((CEHLQ(IX,IT,NX,1,2),IX=1,6),IT=1,6),NX=1,2)/ + 1 7.237D-01,-2.189D-01,-2.995D-01,-1.909D-02,-1.477D-02, 2.500D-04, + 2-5.314D-01,-2.425D-01, 3.283D-01, 1.119D-01, 2.223D-02, 7.070D-03, + 3 2.289D-01, 1.890D-01,-9.859D-02,-6.900D-02,-1.747D-02,-5.080D-03, + 4-1.041D-01,-1.084D-01, 2.108D-02, 2.975D-02, 9.830D-03, 2.830D-03, + 5 4.394D-02, 5.116D-02,-1.410D-03,-1.055D-02,-4.230D-03,-1.270D-03, + 6-1.991D-02,-2.539D-02,-2.780D-03, 3.430D-03, 1.720D-03, 5.500D-04, + 1 2.410D-01, 2.884D-01, 9.369D-02, 1.900D-02, 2.530D-03, 2.400D-04, + 2 1.765D-02,-9.220D-03,-3.037D-02,-2.085D-02,-8.440D-03,-2.810D-03, + 3-6.450D-03,-5.260D-03, 1.720D-03, 3.110D-03, 1.830D-03, 8.700D-04, + 4 2.120D-03, 2.320D-03, 2.600D-04,-4.900D-04,-3.900D-04,-2.300D-04, + 5-6.900D-04,-8.200D-04,-2.000D-04, 7.000D-05, 9.000D-05, 6.000D-05, + 6 2.400D-04, 3.100D-04, 1.100D-04, 0.000D+00,-2.000D-05,-2.000D-05/ +C...Expansion coefficients for down valence quark distribution. + DATA (((CEHLQ(IX,IT,NX,2,1),IX=1,6),IT=1,6),NX=1,2)/ + 1 3.813D-01,-8.090D-02,-1.634D-01,-2.185D-02,-8.430D-03,-6.200D-04, + 2-2.948D-01,-1.435D-01, 1.665D-01, 6.638D-02, 1.473D-02, 4.080D-03, + 3 1.252D-01, 1.042D-01,-4.722D-02,-3.683D-02,-1.038D-02,-2.860D-03, + 4-5.478D-02,-5.678D-02, 8.900D-03, 1.484D-02, 5.340D-03, 1.520D-03, + 5 2.220D-02, 2.567D-02,-3.000D-05,-4.970D-03,-2.160D-03,-6.500D-04, + 6-9.530D-03,-1.204D-02,-1.510D-03, 1.510D-03, 8.300D-04, 2.700D-04, + 1 1.261D-01, 1.354D-01, 3.958D-02, 8.240D-03, 1.660D-03, 4.500D-04, + 2 3.890D-03,-1.159D-02,-1.625D-02,-9.610D-03,-3.710D-03,-1.260D-03, + 3-1.910D-03,-5.600D-04, 1.590D-03, 1.590D-03, 8.400D-04, 3.900D-04, + 4 6.400D-04, 4.900D-04,-1.500D-04,-2.900D-04,-1.800D-04,-1.000D-04, + 5-2.000D-04,-1.900D-04, 0.000D+00, 6.000D-05, 4.000D-05, 3.000D-05, + 6 7.000D-05, 8.000D-05, 2.000D-05,-1.000D-05,-1.000D-05,-1.000D-05/ + DATA (((CEHLQ(IX,IT,NX,2,2),IX=1,6),IT=1,6),NX=1,2)/ + 1 3.578D-01,-8.622D-02,-1.480D-01,-1.840D-02,-7.820D-03,-4.500D-04, + 2-2.925D-01,-1.304D-01, 1.696D-01, 6.243D-02, 1.353D-02, 3.750D-03, + 3 1.318D-01, 1.041D-01,-5.486D-02,-3.872D-02,-1.038D-02,-2.850D-03, + 4-6.162D-02,-6.143D-02, 1.303D-02, 1.740D-02, 5.940D-03, 1.670D-03, + 5 2.643D-02, 2.957D-02,-1.490D-03,-6.450D-03,-2.630D-03,-7.700D-04, + 6-1.218D-02,-1.497D-02,-1.260D-03, 2.240D-03, 1.120D-03, 3.500D-04, + 1 1.263D-01, 1.334D-01, 3.732D-02, 7.070D-03, 1.260D-03, 3.400D-04, + 2 3.660D-03,-1.357D-02,-1.795D-02,-1.031D-02,-3.880D-03,-1.280D-03, + 3-2.100D-03,-3.600D-04, 2.050D-03, 1.920D-03, 9.800D-04, 4.400D-04, + 4 7.700D-04, 5.400D-04,-2.400D-04,-3.900D-04,-2.400D-04,-1.300D-04, + 5-2.600D-04,-2.300D-04, 2.000D-05, 9.000D-05, 6.000D-05, 4.000D-05, + 6 9.000D-05, 1.000D-04, 2.000D-05,-2.000D-05,-2.000D-05,-1.000D-05/ +C...Expansion coefficients for up and down sea quark distributions. + DATA (((CEHLQ(IX,IT,NX,3,1),IX=1,6),IT=1,6),NX=1,2)/ + 1 6.870D-02,-6.861D-02, 2.973D-02,-5.400D-03, 3.780D-03,-9.700D-04, + 2-1.802D-02, 1.400D-04, 6.490D-03,-8.540D-03, 1.220D-03,-1.750D-03, + 3-4.650D-03, 1.480D-03,-5.930D-03, 6.000D-04,-1.030D-03,-8.000D-05, + 4 6.440D-03, 2.570D-03, 2.830D-03, 1.150D-03, 7.100D-04, 3.300D-04, + 5-3.930D-03,-2.540D-03,-1.160D-03,-7.700D-04,-3.600D-04,-1.900D-04, + 6 2.340D-03, 1.930D-03, 5.300D-04, 3.700D-04, 1.600D-04, 9.000D-05, + 1 1.014D+00,-1.106D+00, 3.374D-01,-7.444D-02, 8.850D-03,-8.700D-04, + 2 9.233D-01,-1.285D+00, 4.475D-01,-9.786D-02, 1.419D-02,-1.120D-03, + 3 4.888D-02,-1.271D-01, 8.606D-02,-2.608D-02, 4.780D-03,-6.000D-04, + 4-2.691D-02, 4.887D-02,-1.771D-02, 1.620D-03, 2.500D-04,-6.000D-05, + 5 7.040D-03,-1.113D-02, 1.590D-03, 7.000D-04,-2.000D-04, 0.000D+00, + 6-1.710D-03, 2.290D-03, 3.800D-04,-3.500D-04, 4.000D-05, 1.000D-05/ + DATA (((CEHLQ(IX,IT,NX,3,2),IX=1,6),IT=1,6),NX=1,2)/ + 1 1.008D-01,-7.100D-02, 1.973D-02,-5.710D-03, 2.930D-03,-9.900D-04, + 2-5.271D-02,-1.823D-02, 1.792D-02,-6.580D-03, 1.750D-03,-1.550D-03, + 3 1.220D-02, 1.763D-02,-8.690D-03,-8.800D-04,-1.160D-03,-2.100D-04, + 4-1.190D-03,-7.180D-03, 2.360D-03, 1.890D-03, 7.700D-04, 4.100D-04, + 5-9.100D-04, 2.040D-03,-3.100D-04,-1.050D-03,-4.000D-04,-2.400D-04, + 6 1.190D-03,-1.700D-04,-2.000D-04, 4.200D-04, 1.700D-04, 1.000D-04, + 1 1.081D+00,-1.189D+00, 3.868D-01,-8.617D-02, 1.115D-02,-1.180D-03, + 2 9.917D-01,-1.396D+00, 4.998D-01,-1.159D-01, 1.674D-02,-1.720D-03, + 3 5.099D-02,-1.338D-01, 9.173D-02,-2.885D-02, 5.890D-03,-6.500D-04, + 4-3.178D-02, 5.703D-02,-2.070D-02, 2.440D-03, 1.100D-04,-9.000D-05, + 5 8.970D-03,-1.392D-02, 2.050D-03, 6.500D-04,-2.300D-04, 2.000D-05, + 6-2.340D-03, 3.010D-03, 5.000D-04,-3.900D-04, 6.000D-05, 1.000D-05/ +C...Expansion coefficients for gluon distribution. + DATA (((CEHLQ(IX,IT,NX,4,1),IX=1,6),IT=1,6),NX=1,2)/ + 1 9.482D-01,-9.578D-01, 1.009D-01,-1.051D-01, 3.456D-02,-3.054D-02, + 2-9.627D-01, 5.379D-01, 3.368D-01,-9.525D-02, 1.488D-02,-2.051D-02, + 3 4.300D-01,-8.306D-02,-3.372D-01, 4.902D-02,-9.160D-03, 1.041D-02, + 4-1.925D-01,-1.790D-02, 2.183D-01, 7.490D-03, 4.140D-03,-1.860D-03, + 5 8.183D-02, 1.926D-02,-1.072D-01,-1.944D-02,-2.770D-03,-5.200D-04, + 6-3.884D-02,-1.234D-02, 5.410D-02, 1.879D-02, 3.350D-03, 1.040D-03, + 1 2.948D+01,-3.902D+01, 1.464D+01,-3.335D+00, 5.054D-01,-5.915D-02, + 2 2.559D+01,-3.955D+01, 1.661D+01,-4.299D+00, 6.904D-01,-8.243D-02, + 3-1.663D+00, 1.176D+00, 1.118D+00,-7.099D-01, 1.948D-01,-2.404D-02, + 4-2.168D-01, 8.170D-01,-7.169D-01, 1.851D-01,-1.924D-02,-3.250D-03, + 5 2.088D-01,-4.355D-01, 2.239D-01,-2.446D-02,-3.620D-03, 1.910D-03, + 6-9.097D-02, 1.601D-01,-5.681D-02,-2.500D-03, 2.580D-03,-4.700D-04/ + DATA (((CEHLQ(IX,IT,NX,4,2),IX=1,6),IT=1,6),NX=1,2)/ + 1 2.367D+00, 4.453D-01, 3.660D-01, 9.467D-02, 1.341D-01, 1.661D-02, + 2-3.170D+00,-1.795D+00, 3.313D-02,-2.874D-01,-9.827D-02,-7.119D-02, + 3 1.823D+00, 1.457D+00,-2.465D-01, 3.739D-02, 6.090D-03, 1.814D-02, + 4-1.033D+00,-9.827D-01, 2.136D-01, 1.169D-01, 5.001D-02, 1.684D-02, + 5 5.133D-01, 5.259D-01,-1.173D-01,-1.139D-01,-4.988D-02,-2.021D-02, + 6-2.881D-01,-3.145D-01, 5.667D-02, 9.161D-02, 4.568D-02, 1.951D-02, + 1 3.036D+01,-4.062D+01, 1.578D+01,-3.699D+00, 6.020D-01,-7.031D-02, + 2 2.700D+01,-4.167D+01, 1.770D+01,-4.804D+00, 7.862D-01,-1.060D-01, + 3-1.909D+00, 1.357D+00, 1.127D+00,-7.181D-01, 2.232D-01,-2.481D-02, + 4-2.488D-01, 9.781D-01,-8.127D-01, 2.094D-01,-2.997D-02,-4.710D-03, + 5 2.506D-01,-5.427D-01, 2.672D-01,-3.103D-02,-1.800D-03, 2.870D-03, + 6-1.128D-01, 2.087D-01,-6.972D-02,-2.480D-03, 2.630D-03,-8.400D-04/ +C...Expansion coefficients for strange sea quark distribution. + DATA (((CEHLQ(IX,IT,NX,5,1),IX=1,6),IT=1,6),NX=1,2)/ + 1 4.968D-02,-4.173D-02, 2.102D-02,-3.270D-03, 3.240D-03,-6.700D-04, + 2-6.150D-03,-1.294D-02, 6.740D-03,-6.890D-03, 9.000D-04,-1.510D-03, + 3-8.580D-03, 5.050D-03,-4.900D-03,-1.600D-04,-9.400D-04,-1.500D-04, + 4 7.840D-03, 1.510D-03, 2.220D-03, 1.400D-03, 7.000D-04, 3.500D-04, + 5-4.410D-03,-2.220D-03,-8.900D-04,-8.500D-04,-3.600D-04,-2.000D-04, + 6 2.520D-03, 1.840D-03, 4.100D-04, 3.900D-04, 1.600D-04, 9.000D-05, + 1 9.235D-01,-1.085D+00, 3.464D-01,-7.210D-02, 9.140D-03,-9.100D-04, + 2 9.315D-01,-1.274D+00, 4.512D-01,-9.775D-02, 1.380D-02,-1.310D-03, + 3 4.739D-02,-1.296D-01, 8.482D-02,-2.642D-02, 4.760D-03,-5.700D-04, + 4-2.653D-02, 4.953D-02,-1.735D-02, 1.750D-03, 2.800D-04,-6.000D-05, + 5 6.940D-03,-1.132D-02, 1.480D-03, 6.500D-04,-2.100D-04, 0.000D+00, + 6-1.680D-03, 2.340D-03, 4.200D-04,-3.400D-04, 5.000D-05, 1.000D-05/ + DATA (((CEHLQ(IX,IT,NX,5,2),IX=1,6),IT=1,6),NX=1,2)/ + 1 6.478D-02,-4.537D-02, 1.643D-02,-3.490D-03, 2.710D-03,-6.700D-04, + 2-2.223D-02,-2.126D-02, 1.247D-02,-6.290D-03, 1.120D-03,-1.440D-03, + 3-1.340D-03, 1.362D-02,-6.130D-03,-7.900D-04,-9.000D-04,-2.000D-04, + 4 5.080D-03,-3.610D-03, 1.700D-03, 1.830D-03, 6.800D-04, 4.000D-04, + 5-3.580D-03, 6.000D-05,-2.600D-04,-1.050D-03,-3.800D-04,-2.300D-04, + 6 2.420D-03, 9.300D-04,-1.000D-04, 4.500D-04, 1.700D-04, 1.100D-04, + 1 9.868D-01,-1.171D+00, 3.940D-01,-8.459D-02, 1.124D-02,-1.250D-03, + 2 1.001D+00,-1.383D+00, 5.044D-01,-1.152D-01, 1.658D-02,-1.830D-03, + 3 4.928D-02,-1.368D-01, 9.021D-02,-2.935D-02, 5.800D-03,-6.600D-04, + 4-3.133D-02, 5.785D-02,-2.023D-02, 2.630D-03, 1.600D-04,-8.000D-05, + 5 8.840D-03,-1.416D-02, 1.900D-03, 5.800D-04,-2.500D-04, 1.000D-05, + 6-2.300D-03, 3.080D-03, 5.500D-04,-3.700D-04, 7.000D-05, 1.000D-05/ +C...Expansion coefficients for charm sea quark distribution. + DATA (((CEHLQ(IX,IT,NX,6,1),IX=1,6),IT=1,6),NX=1,2)/ + 1 9.270D-03,-1.817D-02, 9.590D-03,-6.390D-03, 1.690D-03,-1.540D-03, + 2 5.710D-03,-1.188D-02, 6.090D-03,-4.650D-03, 1.240D-03,-1.310D-03, + 3-3.960D-03, 7.100D-03,-3.590D-03, 1.840D-03,-3.900D-04, 3.400D-04, + 4 1.120D-03,-1.960D-03, 1.120D-03,-4.800D-04, 1.000D-04,-4.000D-05, + 5 4.000D-05,-3.000D-05,-1.800D-04, 9.000D-05,-5.000D-05,-2.000D-05, + 6-4.200D-04, 7.300D-04,-1.600D-04, 5.000D-05, 5.000D-05, 5.000D-05, + 1 8.098D-01,-1.042D+00, 3.398D-01,-6.824D-02, 8.760D-03,-9.000D-04, + 2 8.961D-01,-1.217D+00, 4.339D-01,-9.287D-02, 1.304D-02,-1.290D-03, + 3 3.058D-02,-1.040D-01, 7.604D-02,-2.415D-02, 4.600D-03,-5.000D-04, + 4-2.451D-02, 4.432D-02,-1.651D-02, 1.430D-03, 1.200D-04,-1.000D-04, + 5 1.122D-02,-1.457D-02, 2.680D-03, 5.800D-04,-1.200D-04, 3.000D-05, + 6-7.730D-03, 7.330D-03,-7.600D-04,-2.400D-04, 1.000D-05, 0.000D+00/ + DATA (((CEHLQ(IX,IT,NX,6,2),IX=1,6),IT=1,6),NX=1,2)/ + 1 9.980D-03,-1.945D-02, 1.055D-02,-6.870D-03, 1.860D-03,-1.560D-03, + 2 5.700D-03,-1.203D-02, 6.250D-03,-4.860D-03, 1.310D-03,-1.370D-03, + 3-4.490D-03, 7.990D-03,-4.170D-03, 2.050D-03,-4.400D-04, 3.300D-04, + 4 1.470D-03,-2.480D-03, 1.460D-03,-5.700D-04, 1.200D-04,-1.000D-05, + 5-9.000D-05, 1.500D-04,-3.200D-04, 1.200D-04,-6.000D-05,-4.000D-05, + 6-4.200D-04, 7.600D-04,-1.400D-04, 4.000D-05, 7.000D-05, 5.000D-05, + 1 8.698D-01,-1.131D+00, 3.836D-01,-8.111D-02, 1.048D-02,-1.300D-03, + 2 9.626D-01,-1.321D+00, 4.854D-01,-1.091D-01, 1.583D-02,-1.700D-03, + 3 3.057D-02,-1.088D-01, 8.022D-02,-2.676D-02, 5.590D-03,-5.600D-04, + 4-2.845D-02, 5.164D-02,-1.918D-02, 2.210D-03,-4.000D-05,-1.500D-04, + 5 1.311D-02,-1.751D-02, 3.310D-03, 5.100D-04,-1.200D-04, 5.000D-05, + 6-8.590D-03, 8.380D-03,-9.200D-04,-2.600D-04, 1.000D-05,-1.000D-05/ +C...Expansion coefficients for bottom sea quark distribution. + DATA (((CEHLQ(IX,IT,NX,7,1),IX=1,6),IT=1,6),NX=1,2)/ + 1 9.010D-03,-1.401D-02, 7.150D-03,-4.130D-03, 1.260D-03,-1.040D-03, + 2 6.280D-03,-9.320D-03, 4.780D-03,-2.890D-03, 9.100D-04,-8.200D-04, + 3-2.930D-03, 4.090D-03,-1.890D-03, 7.600D-04,-2.300D-04, 1.400D-04, + 4 3.900D-04,-1.200D-03, 4.400D-04,-2.500D-04, 2.000D-05,-2.000D-05, + 5 2.600D-04, 1.400D-04,-8.000D-05, 1.000D-04, 1.000D-05, 1.000D-05, + 6-2.600D-04, 3.200D-04, 1.000D-05,-1.000D-05, 1.000D-05,-1.000D-05, + 1 8.029D-01,-1.075D+00, 3.792D-01,-7.843D-02, 1.007D-02,-1.090D-03, + 2 7.903D-01,-1.099D+00, 4.153D-01,-9.301D-02, 1.317D-02,-1.410D-03, + 3-1.704D-02,-1.130D-02, 2.882D-02,-1.341D-02, 3.040D-03,-3.600D-04, + 4-7.200D-04, 7.230D-03,-5.160D-03, 1.080D-03,-5.000D-05,-4.000D-05, + 5 3.050D-03,-4.610D-03, 1.660D-03,-1.300D-04,-1.000D-05, 1.000D-05, + 6-4.360D-03, 5.230D-03,-1.610D-03, 2.000D-04,-2.000D-05, 0.000D+00/ + DATA (((CEHLQ(IX,IT,NX,7,2),IX=1,6),IT=1,6),NX=1,2)/ + 1 8.980D-03,-1.459D-02, 7.510D-03,-4.410D-03, 1.310D-03,-1.070D-03, + 2 5.970D-03,-9.440D-03, 4.800D-03,-3.020D-03, 9.100D-04,-8.500D-04, + 3-3.050D-03, 4.440D-03,-2.100D-03, 8.500D-04,-2.400D-04, 1.400D-04, + 4 5.300D-04,-1.300D-03, 5.600D-04,-2.700D-04, 3.000D-05,-2.000D-05, + 5 2.000D-04, 1.400D-04,-1.100D-04, 1.000D-04, 0.000D+00, 0.000D+00, + 6-2.600D-04, 3.200D-04, 0.000D+00,-3.000D-05, 1.000D-05,-1.000D-05, + 1 8.672D-01,-1.174D+00, 4.265D-01,-9.252D-02, 1.244D-02,-1.460D-03, + 2 8.500D-01,-1.194D+00, 4.630D-01,-1.083D-01, 1.614D-02,-1.830D-03, + 3-2.241D-02,-5.630D-03, 2.815D-02,-1.425D-02, 3.520D-03,-4.300D-04, + 4-7.300D-04, 8.030D-03,-5.780D-03, 1.380D-03,-1.300D-04,-4.000D-05, + 5 3.460D-03,-5.380D-03, 1.960D-03,-2.100D-04, 1.000D-05, 1.000D-05, + 6-4.850D-03, 5.950D-03,-1.890D-03, 2.600D-04,-3.000D-05, 0.000D+00/ +C...Expansion coefficients for top sea quark distribution. + DATA (((CEHLQ(IX,IT,NX,8,1),IX=1,6),IT=1,6),NX=1,2)/ + 1 4.410D-03,-7.480D-03, 3.770D-03,-2.580D-03, 7.300D-04,-7.100D-04, + 2 3.840D-03,-6.050D-03, 3.030D-03,-2.030D-03, 5.800D-04,-5.900D-04, + 3-8.800D-04, 1.660D-03,-7.500D-04, 4.700D-04,-1.000D-04, 1.000D-04, + 4-8.000D-05,-1.500D-04, 1.200D-04,-9.000D-05, 3.000D-05, 0.000D+00, + 5 1.300D-04,-2.200D-04,-2.000D-05,-2.000D-05,-2.000D-05,-2.000D-05, + 6-7.000D-05, 1.900D-04,-4.000D-05, 2.000D-05, 0.000D+00, 0.000D+00, + 1 6.623D-01,-9.248D-01, 3.519D-01,-7.930D-02, 1.110D-02,-1.180D-03, + 2 6.380D-01,-9.062D-01, 3.582D-01,-8.479D-02, 1.265D-02,-1.390D-03, + 3-2.581D-02, 2.125D-02, 4.190D-03,-4.980D-03, 1.490D-03,-2.100D-04, + 4 7.100D-04, 5.300D-04,-1.270D-03, 3.900D-04,-5.000D-05,-1.000D-05, + 5 3.850D-03,-5.060D-03, 1.860D-03,-3.500D-04, 4.000D-05, 0.000D+00, + 6-3.530D-03, 4.460D-03,-1.500D-03, 2.700D-04,-3.000D-05, 0.000D+00/ + DATA (((CEHLQ(IX,IT,NX,8,2),IX=1,6),IT=1,6),NX=1,2)/ + 1 4.260D-03,-7.530D-03, 3.830D-03,-2.680D-03, 7.600D-04,-7.300D-04, + 2 3.640D-03,-6.050D-03, 3.030D-03,-2.090D-03, 5.900D-04,-6.000D-04, + 3-9.200D-04, 1.710D-03,-8.200D-04, 5.000D-04,-1.200D-04, 1.000D-04, + 4-5.000D-05,-1.600D-04, 1.300D-04,-9.000D-05, 3.000D-05, 0.000D+00, + 5 1.300D-04,-2.100D-04,-1.000D-05,-2.000D-05,-2.000D-05,-1.000D-05, + 6-8.000D-05, 1.800D-04,-5.000D-05, 2.000D-05, 0.000D+00, 0.000D+00, + 1 7.146D-01,-1.007D+00, 3.932D-01,-9.246D-02, 1.366D-02,-1.540D-03, + 2 6.856D-01,-9.828D-01, 3.977D-01,-9.795D-02, 1.540D-02,-1.790D-03, + 3-3.053D-02, 2.758D-02, 2.150D-03,-4.880D-03, 1.640D-03,-2.500D-04, + 4 9.200D-04, 4.200D-04,-1.340D-03, 4.600D-04,-8.000D-05,-1.000D-05, + 5 4.230D-03,-5.660D-03, 2.140D-03,-4.300D-04, 6.000D-05, 0.000D+00, + 6-3.890D-03, 5.000D-03,-1.740D-03, 3.300D-04,-4.000D-05, 0.000D+00/ + +C...The following data lines are coefficients needed in the +C...Duke, Owens proton structure function parametrizations, see below. +C...Expansion coefficients for (up+down) valence quark distribution. + DATA ((CDO(IP,IS,1,1),IS=1,6),IP=1,3)/ + 1 4.190D-01, 3.460D+00, 4.400D+00, 0.000D+00, 0.000D+00, 0.000D+00, + 2 4.000D-03, 7.240D-01,-4.860D+00, 0.000D+00, 0.000D+00, 0.000D+00, + 3-7.000D-03,-6.600D-02, 1.330D+00, 0.000D+00, 0.000D+00, 0.000D+00/ + DATA ((CDO(IP,IS,1,2),IS=1,6),IP=1,3)/ + 1 3.740D-01, 3.330D+00, 6.030D+00, 0.000D+00, 0.000D+00, 0.000D+00, + 2 1.400D-02, 7.530D-01,-6.220D+00, 0.000D+00, 0.000D+00, 0.000D+00, + 3 0.000D+00,-7.600D-02, 1.560D+00, 0.000D+00, 0.000D+00, 0.000D+00/ +C...Expansion coefficients for down valence quark distribution. + DATA ((CDO(IP,IS,2,1),IS=1,6),IP=1,3)/ + 1 7.630D-01, 4.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, + 2-2.370D-01, 6.270D-01,-4.210D-01, 0.000D+00, 0.000D+00, 0.000D+00, + 3 2.600D-02,-1.900D-02, 3.300D-02, 0.000D+00, 0.000D+00, 0.000D+00/ + DATA ((CDO(IP,IS,2,2),IS=1,6),IP=1,3)/ + 1 7.610D-01, 3.830D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, + 2-2.320D-01, 6.270D-01,-4.180D-01, 0.000D+00, 0.000D+00, 0.000D+00, + 3 2.300D-02,-1.900D-02, 3.600D-02, 0.000D+00, 0.000D+00, 0.000D+00/ +C...Expansion coefficients for (up+down+strange) sea quark distribution. + DATA ((CDO(IP,IS,3,1),IS=1,6),IP=1,3)/ + 1 1.265D+00, 0.000D+00, 8.050D+00, 0.000D+00, 0.000D+00, 0.000D+00, + 2-1.132D+00,-3.720D-01, 1.590D+00, 6.310D+00,-1.050D+01, 1.470D+01, + 3 2.930D-01,-2.900D-02,-1.530D-01,-2.730D-01,-3.170D+00, 9.800D+00/ + DATA ((CDO(IP,IS,3,2),IS=1,6),IP=1,3)/ + 1 1.670D+00, 0.000D+00, 9.150D+00, 0.000D+00, 0.000D+00, 0.000D+00, + 2-1.920D+00,-2.730D-01, 5.300D-01, 1.570D+01,-1.010D+02, 2.230D+02, + 3 5.820D-01,-1.640D-01,-7.630D-01,-2.830D+00, 4.470D+01,-1.170D+02/ +C...Expansion coefficients for charm sea quark distribution. + DATA ((CDO(IP,IS,4,1),IS=1,6),IP=1,3)/ + 1 0.000D+00,-3.600D-02, 6.350D+00, 0.000D+00, 0.000D+00, 0.000D+00, + 2 1.350D-01,-2.220D-01, 3.260D+00,-3.030D+00, 1.740D+01,-1.790D+01, + 3-7.500D-02,-5.800D-02,-9.090D-01, 1.500D+00,-1.130D+01, 1.560D+01/ + DATA ((CDO(IP,IS,4,2),IS=1,6),IP=1,3)/ + 1 0.000D+00,-1.200D-01, 3.510D+00, 0.000D+00, 0.000D+00, 0.000D+00, + 2 6.700D-02,-2.330D-01, 3.660D+00,-4.740D-01, 9.500D+00,-1.660D+01, + 3-3.100D-02,-2.300D-02,-4.530D-01, 3.580D-01,-5.430D+00, 1.550D+01/ +C...Expansion coefficients for gluon distribution. + DATA ((CDO(IP,IS,5,1),IS=1,6),IP=1,3)/ + 1 1.560D+00, 0.000D+00, 6.000D+00, 9.000D+00, 0.000D+00, 0.000D+00, + 2-1.710D+00,-9.490D-01, 1.440D+00,-7.190D+00,-1.650D+01, 1.530D+01, + 3 6.380D-01, 3.250D-01,-1.050D+00, 2.550D-01, 1.090D+01,-1.010D+01/ + DATA ((CDO(IP,IS,5,2),IS=1,6),IP=1,3)/ + 1 8.790D-01, 0.000D+00, 4.000D+00, 9.000D+00, 0.000D+00, 0.000D+00, + 2-9.710D-01,-1.160D+00, 1.230D+00,-5.640D+00,-7.540D+00,-5.960D-01, + 3 4.340D-01, 4.760D-01,-2.540D-01,-8.170D-01, 5.500D+00, 1.260D-01/ + +C...Euler's beta function, requires ordinary Gamma function + EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y) + +C...Leading order proton parton distributions from Glueck, Reya and +C...Vogt. Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and +C...10^-5 < x < 1. + IF(MSTP(51).EQ.11) THEN + +C...Determine s expansion variable and some x expressions. + Q2IN=MIN(1D8,MAX(0.25D0,Q2)) + SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2)) + SD2=SD**2 + XL=-LOG(X) + XS=SQRT(X) + +C...Evaluate valence, gluon and sea distributions. + XFVUD=(0.663D0+0.191D0*SD-0.041D0*SD2+0.031D0*SD**3)* + & X**0.326D0*(1D0+(-1.97D0+6.74D0*SD-1.96D0*SD2)*XS+ + & (24.4D0-20.7D0*SD+4.08D0*SD2)*X)* + & (1D0-X)**(2.86D0+0.70D0*SD-0.02D0*SD2) + XFVDD=(0.579D0+0.283D0*SD+0.047D0*SD2)*X**(0.523D0-0.015D0*SD)* + & (1D0+(2.22D0-0.59D0*SD-0.27D0*SD2)*XS+(5.95D0-6.19D0*SD+ + & 1.55D0*SD2)*X)*(1D0-X)**(3.57D0+0.94D0*SD-0.16D0*SD2) + XFGLU=(X**(1.00D0-0.17D0*SD)*((4.879D0*SD-1.383D0*SD2)+ + & (25.92D0-28.97D0*SD+5.596D0*SD2)*X+(-25.69D0+23.68D0*SD- + & 1.975D0*SD2)*X**2)+SD**0.558D0*EXP(-(0.595D0+2.138D0*SD)+ + & SQRT(4.066D0*SD**1.218D0*XL)))* + & (1D0-X)**(2.537D0+1.718D0*SD+0.353D0*SD2) + XFSEA=(X**(0.412D0-0.171D0*SD)*(0.363D0-1.196D0*X+(1.029D0+ + & 1.785D0*SD-0.459D0*SD2)*X**2)*XL**(0.566D0-0.496D0*SD)+ + & SD**1.396D0*EXP(-(3.838D0+1.944D0*SD)+SQRT(2.845D0*SD**1.331D0* + & XL)))*(1D0-X)**(4.696D0+2.109D0*SD) + XFSTR=SD**0.803D0*(1D0+(-3.055D0+1.024D0*SD**0.67D0)*XS+ + & (27.4D0-20.0D0*SD**0.154D0)*X)*(1D0-X)**6.22D0* + & EXP(-(4.33D0+1.408D0*SD)+SQRT((8.27D0-0.437D0*SD)* + & SD**0.563D0*XL))/XL**(2.082D0-0.577D0*SD) + IF(SD.LE.0.888D0) THEN + XFCHM=0D0 + ELSE + XFCHM=(SD-0.888D0)**1.01D0*(1.+(4.24D0-0.804D0*SD)*X)* + & (1D0-X)**(3.46D0+1.076D0*SD)*EXP(-(4.61D0+1.49D0*SD)+ + & SQRT((2.555D0+1.961D0*SD)*SD**0.37D0*XL)) + ENDIF + IF(SD.LE.1.351D0) THEN + XFBOT=0D0 + ELSE + XFBOT=(SD-1.351D0)*(1D0+1.848D0*X)*(1D0-X)**(2.929D0+ + & 1.396D0*SD)*EXP(-(4.71D0+1.514D0*SD)+ + & SQRT((4.02D0+1.239D0*SD)*SD**0.51D0*XL)) + ENDIF + +C...Put into output array. + XPPR(0)=XFGLU + XPPR(1)=XFVDD+XFSEA + XPPR(2)=XFVUD-XFVDD+XFSEA + XPPR(3)=XFSTR + XPPR(4)=XFCHM + XPPR(5)=XFBOT + XPPR(-1)=XFSEA + XPPR(-2)=XFSEA + XPPR(-3)=XFSTR + XPPR(-4)=XFCHM + XPPR(-5)=XFBOT + +C...Proton parton distributions from Eichten, Hinchliffe, Lane, Quigg. +C...Allowed variable range: 5 GeV^2 < Q^2 < 1E8 GeV^2; 1E-4 < x < 1 + ELSEIF(MSTP(51).EQ.12.OR.MSTP(51).EQ.13) THEN + +C...Determine set, Lambda and x and t expansion variables. + NSET=MSTP(51)-11 + IF(NSET.EQ.1) ALAM=0.2D0 + IF(NSET.EQ.2) ALAM=0.29D0 + TMIN=LOG(5D0/ALAM**2) + TMAX=LOG(1D8/ALAM**2) + T=LOG(MAX(1D0,Q2/ALAM**2)) + VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN))) + NX=1 + IF(X.LE.0.1D0) NX=2 + IF(NX.EQ.1) VX=(2D0*X-1.1D0)/0.9D0 + IF(NX.EQ.2) VX=MAX(-1D0,(2D0*LOG(X)+11.51293D0)/6.90776D0) + +C...Chebyshev polynomials for x and t expansion. + TX(1)=1D0 + TX(2)=VX + TX(3)=2D0*VX**2-1D0 + TX(4)=4D0*VX**3-3D0*VX + TX(5)=8D0*VX**4-8D0*VX**2+1D0 + TX(6)=16D0*VX**5-20D0*VX**3+5D0*VX + TT(1)=1D0 + TT(2)=VT + TT(3)=2D0*VT**2-1D0 + TT(4)=4D0*VT**3-3D0*VT + TT(5)=8D0*VT**4-8D0*VT**2+1D0 + TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT + +C...Calculate structure functions. + DO 120 KFL=1,6 + XQSUM=0D0 + DO 110 IT=1,6 + DO 100 IX=1,6 + XQSUM=XQSUM+CEHLQ(IX,IT,NX,KFL,NSET)*TX(IX)*TT(IT) + 100 CONTINUE + 110 CONTINUE + XQ(KFL)=XQSUM*(1D0-X)**NEHLQ(KFL,NSET) + 120 CONTINUE + +C...Put into output array. + XPPR(0)=XQ(4) + XPPR(1)=XQ(2)+XQ(3) + XPPR(2)=XQ(1)+XQ(3) + XPPR(3)=XQ(5) + XPPR(4)=XQ(6) + XPPR(-1)=XQ(3) + XPPR(-2)=XQ(3) + XPPR(-3)=XQ(5) + XPPR(-4)=XQ(6) + +C...Special expansion for bottom (threshold effects). + IF(MSTP(58).GE.5) THEN + IF(NSET.EQ.1) TMIN=8.1905D0 + IF(NSET.EQ.2) TMIN=7.4474D0 + IF(T.GT.TMIN) THEN + VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN))) + TT(1)=1D0 + TT(2)=VT + TT(3)=2D0*VT**2-1D0 + TT(4)=4D0*VT**3-3D0*VT + TT(5)=8D0*VT**4-8D0*VT**2+1D0 + TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT + XQSUM=0D0 + DO 140 IT=1,6 + DO 130 IX=1,6 + XQSUM=XQSUM+CEHLQ(IX,IT,NX,7,NSET)*TX(IX)*TT(IT) + 130 CONTINUE + 140 CONTINUE + XPPR(5)=XQSUM*(1D0-X)**NEHLQ(7,NSET) + XPPR(-5)=XPPR(5) + ENDIF + ENDIF + +C...Special expansion for top (threshold effects). + IF(MSTP(58).GE.6) THEN + IF(NSET.EQ.1) TMIN=11.5528D0 + IF(NSET.EQ.2) TMIN=10.8097D0 + TMIN=TMIN+2D0*LOG(PMAS(6,1)/30D0) + TMAX=TMAX+2D0*LOG(PMAS(6,1)/30D0) + IF(T.GT.TMIN) THEN + VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN))) + TT(1)=1D0 + TT(2)=VT + TT(3)=2D0*VT**2-1D0 + TT(4)=4D0*VT**3-3D0*VT + TT(5)=8D0*VT**4-8D0*VT**2+1D0 + TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT + XQSUM=0D0 + DO 160 IT=1,6 + DO 150 IX=1,6 + XQSUM=XQSUM+CEHLQ(IX,IT,NX,8,NSET)*TX(IX)*TT(IT) + 150 CONTINUE + 160 CONTINUE + XPPR(6)=XQSUM*(1D0-X)**NEHLQ(8,NSET) + XPPR(-6)=XPPR(6) + ENDIF + ENDIF + +C...Proton parton distributions from Duke, Owens. +C...Allowed variable range: 4 GeV^2 < Q^2 < approx 1E6 GeV^2. + ELSEIF(MSTP(51).EQ.14.OR.MSTP(51).EQ.15) THEN + +C...Determine set, Lambda and s expansion parameter. + NSET=MSTP(51)-13 + IF(NSET.EQ.1) ALAM=0.2D0 + IF(NSET.EQ.2) ALAM=0.4D0 + Q2IN=MIN(1D6,MAX(4D0,Q2)) + SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2)) + +C...Calculate structure functions. + DO 180 KFL=1,5 + DO 170 IS=1,6 + TS(IS)=CDO(1,IS,KFL,NSET)+CDO(2,IS,KFL,NSET)*SD+ + & CDO(3,IS,KFL,NSET)*SD**2 + 170 CONTINUE + IF(KFL.LE.2) THEN + XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)*(1D0+TS(3)*X)/(EULBET(TS(1), + & TS(2)+1D0)*(1D0+TS(3)*TS(1)/(TS(1)+TS(2)+1D0))) + ELSE + XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+ + & TS(5)*X**2+TS(6)*X**3) + ENDIF + 180 CONTINUE + +C...Put into output arrays. + XPPR(0)=XQ(5) + XPPR(1)=XQ(2)+XQ(3)/6D0 + XPPR(2)=3D0*XQ(1)-XQ(2)+XQ(3)/6D0 + XPPR(3)=XQ(3)/6D0 + XPPR(4)=XQ(4) + XPPR(-1)=XQ(3)/6D0 + XPPR(-2)=XQ(3)/6D0 + XPPR(-3)=XQ(3)/6D0 + XPPR(-4)=XQ(4) + + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYHFTH +C...Gives threshold attractive/repulsive factor for heavy flavour +C...production. + + FUNCTION PYHFTH(SH,SQM,FRATT) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + SAVE /PYDAT1/,/PYPARS/,/PYINT1/ + +C...Value for alpha_strong. + IF(MSTP(35).LE.1) THEN + ALSSG=PARP(35) + ELSE + MST115=MSTU(115) + MSTU(115)=MSTP(36) + Q2BN=SQRT(MAX(1D0,SQM*((SQRT(SH)-2D0*SQRT(SQM))**2+ + & PARP(36)**2))) + ALSSG=PYALPS(Q2BN) + MSTU(115)=MST115 + ENDIF + +C...Evaluate attractive and repulsive factors. + XATTR=4D0*PARU(1)*ALSSG/(3D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH))) + FATTR=XATTR/(1D0-EXP(-MIN(50D0,XATTR))) + XREPU=PARU(1)*ALSSG/(6D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH))) + FREPU=XREPU/(EXP(MIN(50D0,XREPU))-1D0) + PYHFTH=FRATT*FATTR+(1D0-FRATT)*FREPU + VINT(138)=PYHFTH + + RETURN + END + +C********************************************************************* + +C...PYSPLI +C...Splits a hadron remnant into two (partons or hadron + parton) +C...in case it is more complicated than just a quark or a diquark. + + SUBROUTINE PYSPLI(KF,KFLIN,KFLCH,KFLSP) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. PYDAT1 temporary + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + SAVE /PYPARS/,/PYINT1/,/PYDAT1/ +C...Local array. + DIMENSION KFL(3) + +C...Preliminaries. Parton composition. + KFA=IABS(KF) + KFS=ISIGN(1,KF) + KFL(1)=MOD(KFA/1000,10) + KFL(2)=MOD(KFA/100,10) + KFL(3)=MOD(KFA/10,10) + IF(KFA.EQ.22.AND.MINT(109).EQ.2) THEN + KFL(2)=INT(1.5D0+PYR(0)) + IF(MINT(105).EQ.333) KFL(2)=3 + IF(MINT(105).EQ.443) KFL(2)=4 + KFL(3)=KFL(2) + ELSEIF((KFA.EQ.111.OR.KFA.EQ.113).AND.PYR(0).GT.0.5D0) THEN + KFL(2)=2 + KFL(3)=2 + ELSEIF(KFA.EQ.223.AND.PYR(0).GT.0.5D0) THEN + KFL(2)=1 + KFL(3)=1 + ELSEIF((KFA.EQ.130.OR.KFA.EQ.310).AND.PYR(0).GT.0.5D0) THEN + KFL(2)=MOD(KFA/10,10) + KFL(3)=MOD(KFA/100,10) + ENDIF + IF(KFLIN.NE.21.AND.KFLIN.NE.22.AND.KFLIN.NE.23) THEN + KFLR=KFLIN*KFS + ELSE + KFLR=KFLIN + ENDIF + KFLCH=0 + +C...Subdivide lepton. + IF(KFA.GE.11.AND.KFA.LE.18) THEN + IF(KFLR.EQ.KFA) THEN + KFLSP=KFS*22 + ELSEIF(KFLR.EQ.22) THEN + KFLSP=KFA + ELSEIF(KFLR.EQ.-24.AND.MOD(KFA,2).EQ.1) THEN + KFLSP=KFA+1 + ELSEIF(KFLR.EQ.24.AND.MOD(KFA,2).EQ.0) THEN + KFLSP=KFA-1 + ELSEIF(KFLR.EQ.21) THEN + KFLSP=KFA + KFLCH=KFS*21 + ELSE + KFLSP=KFA + KFLCH=-KFLR + ENDIF + +C...Subdivide photon. + ELSEIF(KFA.EQ.22.AND.MINT(109).NE.2) THEN + IF(KFLR.NE.21) THEN + KFLSP=-KFLR + ELSE + RAGR=0.75D0*PYR(0) + KFLSP=1 + IF(RAGR.GT.0.125D0) KFLSP=2 + IF(RAGR.GT.0.625D0) KFLSP=3 + IF(PYR(0).GT.0.5D0) KFLSP=-KFLSP + KFLCH=-KFLSP + ENDIF + +C...Subdivide Reggeon or Pomeron. + ELSEIF(KFA.EQ.110.OR.KFA.EQ.990) THEN + IF(KFLIN.EQ.21) THEN + KFLSP=KFS*21 + ELSE + KFLSP=-KFLIN + ENDIF + +C...Subdivide meson. + ELSEIF(KFL(1).EQ.0) THEN + KFL(2)=KFL(2)*(-1)**KFL(2) + KFL(3)=-KFL(3)*(-1)**IABS(KFL(2)) + IF(KFLR.EQ.KFL(2)) THEN + KFLSP=KFL(3) + ELSEIF(KFLR.EQ.KFL(3)) THEN + KFLSP=KFL(2) + ELSEIF(KFLR.EQ.21.AND.PYR(0).GT.0.5D0) THEN + KFLSP=KFL(2) + KFLCH=KFL(3) + ELSEIF(KFLR.EQ.21) THEN + KFLSP=KFL(3) + KFLCH=KFL(2) + ELSEIF(KFLR*KFL(2).GT.0) THEN + NTRY=0 + 100 NTRY=NTRY+1 + CALL PYKFDI(-KFLR,KFL(2),KFDUMP,KFLCH) + IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN + GOTO 100 + ELSEIF(KFLCH.EQ.0) THEN + CALL PYERRM(14,'(PYSPLI:) caught in infinite loop') + MINT(51)=1 + RETURN + ENDIF + KFLSP=KFL(3) + ELSE + NTRY=0 + 110 NTRY=NTRY+1 + CALL PYKFDI(-KFLR,KFL(3),KFDUMP,KFLCH) + IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN + GOTO 110 + ELSEIF(KFLCH.EQ.0) THEN + CALL PYERRM(14,'(PYSPLI:) caught in infinite loop') + MINT(51)=1 + RETURN + ENDIF + KFLSP=KFL(2) + ENDIF + +C...Special case for extracting photon from baryon without splitting +C...the latter. (Currently only used by external programs.) + ELSEIF(KFLIN.EQ.22.AND.MSTP(98).EQ.1) then + KFLSP=KFA + KFLCH=0 + +C...Subdivide baryon. + ELSE + NAGR=0 + DO 120 J=1,3 + IF(KFLR.EQ.KFL(J)) NAGR=NAGR+1 + 120 CONTINUE + IF(NAGR.GE.1) THEN + RAGR=0.00001D0+(NAGR-0.00002D0)*PYR(0) + IAGR=0 + DO 130 J=1,3 + IF(KFLR.EQ.KFL(J)) RAGR=RAGR-1D0 + IF(IAGR.EQ.0.AND.RAGR.LE.0D0) IAGR=J + 130 CONTINUE + ELSE + IAGR=1.00001D0+2.99998D0*PYR(0) + ENDIF + ID1=1 + IF(IAGR.EQ.1) ID1=2 + IF(IAGR.EQ.1.AND.KFL(3).GT.KFL(2)) ID1=3 + ID2=6-IAGR-ID1 + KSP=3 + IF(MOD(KFA,10).EQ.2.AND.KFL(1).EQ.KFL(2)) THEN + IF(IAGR.NE.3.AND.PYR(0).GT.0.25D0) KSP=1 + ELSEIF(MOD(KFA,10).EQ.2.AND.KFL(2).GE.KFL(3)) THEN + IF(IAGR.NE.1.AND.PYR(0).GT.0.25D0) KSP=1 + ELSEIF(MOD(KFA,10).EQ.2) THEN + IF(IAGR.EQ.1) KSP=1 + IF(IAGR.NE.1.AND.PYR(0).GT.0.75D0) KSP=1 + ENDIF + KFLSP=1000*KFL(ID1)+100*KFL(ID2)+KSP + IF(KFLR.EQ.21) THEN + KFLCH=KFL(IAGR) + ELSEIF(NAGR.EQ.0.AND.KFLR.GT.0) THEN + NTRY=0 + 140 NTRY=NTRY+1 + CALL PYKFDI(-KFLR,KFL(IAGR),KFDUMP,KFLCH) + IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN + GOTO 140 + ELSEIF(KFLCH.EQ.0) THEN + CALL PYERRM(14,'(PYSPLI:) caught in infinite loop') + MINT(51)=1 + RETURN + ENDIF + ELSEIF(NAGR.EQ.0) THEN + NTRY=0 + 150 NTRY=NTRY+1 + CALL PYKFDI(10000*KFL(ID1)+KFLSP,-KFLR,KFDUMP,KFLCH) + IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN + GOTO 150 + ELSEIF(KFLCH.EQ.0) THEN + CALL PYERRM(14,'(PYSPLI:) caught in infinite loop') + MINT(51)=1 + RETURN + ENDIF + KFLSP=KFL(IAGR) + ENDIF + ENDIF + +C...Add on correct sign for result. + KFLCH=KFLCH*KFS + KFLSP=KFLSP*KFS + + RETURN + END + +C********************************************************************* + +C...PYGAMM +C...Gives ordinary Gamma function Gamma(x) for positive, real arguments; +C...see M. Abramowitz, I. A. Stegun: Handbook of Mathematical Functions +C...(Dover, 1965) 6.1.36. + + FUNCTION PYGAMM(X) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Local array and data. + DIMENSION B(8) + DATA B/-0.577191652D0,0.988205891D0,-0.897056937D0,0.918206857D0, + &-0.756704078D0,0.482199394D0,-0.193527818D0,0.035868343D0/ + + NX=INT(X) + DX=X-NX + + PYGAMM=1D0 + DXP=1D0 + DO 100 I=1,8 + DXP=DXP*DX + PYGAMM=PYGAMM+B(I)*DXP + 100 CONTINUE + IF(X.LT.1D0) THEN + PYGAMM=PYGAMM/X + ELSE + DO 110 IX=1,NX-1 + PYGAMM=(X-IX)*PYGAMM + 110 CONTINUE + ENDIF + + RETURN + END + +C*********************************************************************** + +C...PYWAUX +C...Calculates real and imaginary parts of the auxiliary functions W1 +C...and W2; see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van +C...der Bij, Nucl. Phys. B297 (1988) 221. + + SUBROUTINE PYWAUX(IAUX,EPS,WRE,WIM) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + SAVE /PYDAT1/ + + ASINH(X)=LOG(X+SQRT(X**2+1D0)) + ACOSH(X)=LOG(X+SQRT(X**2-1D0)) + + IF(EPS.LT.0D0) THEN + IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ASINH(SQRT(-1D0/EPS)) + IF(IAUX.EQ.2) WRE=4D0*(ASINH(SQRT(-1D0/EPS)))**2 + WIM=0D0 + ELSEIF(EPS.LT.1D0) THEN + IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ACOSH(SQRT(1D0/EPS)) + IF(IAUX.EQ.2) WRE=4D0*(ACOSH(SQRT(1D0/EPS)))**2-PARU(1)**2 + IF(IAUX.EQ.1) WIM=-PARU(1)*SQRT(1D0-EPS) + IF(IAUX.EQ.2) WIM=-4D0*PARU(1)*ACOSH(SQRT(1D0/EPS)) + ELSE + IF(IAUX.EQ.1) WRE=2D0*SQRT(EPS-1D0)*ASIN(SQRT(1D0/EPS)) + IF(IAUX.EQ.2) WRE=-4D0*(ASIN(SQRT(1D0/EPS)))**2 + WIM=0D0 + ENDIF + + RETURN + END + +C*********************************************************************** + +C...PYI3AU +C...Calculates real and imaginary parts of the auxiliary function I3; +C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij, +C...Nucl. Phys. B297 (1988) 221. + + SUBROUTINE PYI3AU(EPS,RAT,Y3RE,Y3IM) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + SAVE /PYDAT1/ + + BE=0.5D0*(1D0+SQRT(1D0+RAT*EPS)) + IF(EPS.LT.1D0) GA=0.5D0*(1D0+SQRT(1D0-EPS)) + + IF(EPS.LT.0D0) THEN + IF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN + F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)- + & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+ + & PYSPEN(0.25D0*(RAT+1D0)*EPS/(1D0+0.25D0*RAT*EPS),0D0,1)- + & PYSPEN((RAT+1D0)/RAT,0D0,1)+0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2- + & LOG(0.25D0*RAT*EPS)**2)+LOG(1D0-0.25D0*EPS)* + & LOG((1D0+0.25D0*(RAT-1D0)*EPS)/(1D0+0.25D0*RAT*EPS))+ + & LOG(-0.25D0*EPS)*LOG(0.25D0*RAT*EPS/(1D0+0.25D0*(RAT-1D0)* + & EPS)) + ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN + F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)- + & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+ + & PYSPEN((BE-1D0+0.25D0*EPS)/BE,0D0,1)- + & PYSPEN((BE-1D0+0.25D0*EPS)/(BE-1D0),0D0,1)+ + & 0.5D0*(LOG(BE)**2-LOG(BE-1D0)**2)+ + & LOG(1D0-0.25D0*EPS)*LOG((BE-0.25D0*EPS)/BE)+ + & LOG(-0.25D0*EPS)*LOG((BE-1D0)/(BE-0.25D0*EPS)) + ELSEIF(ABS(EPS).GE.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN + F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)- + & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+ + & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(1D0+0.25D0*RAT*EPS),0D0,1)- + & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(0.25D0*RAT*EPS),0D0,1)+ + & 0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-LOG(0.25D0*RAT*EPS)**2)+ + & LOG(GA)*LOG((GA+0.25D0*RAT*EPS)/(1D0+0.25D0*RAT*EPS))+ + & LOG(GA-1D0)*LOG(0.25D0*RAT*EPS/(GA+0.25D0*RAT*EPS)) + ELSE + F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)- + & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN((BE-GA)/BE,0D0,1)- + & PYSPEN((BE-GA)/(BE-1D0),0D0,1)+0.5D0*(LOG(BE)**2- + & LOG(BE-1D0)**2)+LOG(GA)*LOG((GA+BE-1D0)/BE)+ + & LOG(GA-1D0)*LOG((BE-1D0)/(GA+BE-1D0)) + ENDIF + F3IM=0D0 + ELSEIF(EPS.LT.1D0) THEN + IF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN + F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)- + & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+ + & PYSPEN((1D0-0.25D0*EPS)/(-0.25D0*(RAT+1D0)*EPS),0D0,1)- + & PYSPEN(1D0/(RAT+1D0),0D0,1)+LOG((1D0-0.25D0*EPS)/ + & (0.25D0*EPS))*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/ + & (0.25D0*(RAT+1D0)*EPS)) + F3IM=-PARU(1)*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/ + & (0.25D0*(RAT+1D0)*EPS)) + ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN + F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)- + & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+ + & PYSPEN((1D0-0.25D0*EPS)/(1D0-0.25D0*EPS-BE),0D0,1)- + & PYSPEN(-0.25D0*EPS/(1D0-0.25D0*EPS-BE),0D0,1)+ + & LOG((1D0-0.25D0*EPS)/(0.25D0*EPS))* + & LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS)) + F3IM=-PARU(1)*LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS)) + ELSEIF(ABS(EPS).GE.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN + F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)- + & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+ + & PYSPEN(GA/(GA-1D0-0.25D0*RAT*EPS),0D0,1)- + & PYSPEN((GA-1D0)/(GA-1D0-0.25D0*RAT*EPS),0D0,1)+ + & LOG(GA/(1D0-GA))*LOG((GA+0.25D0*RAT*EPS)/ + & (1D0+0.25D0*RAT*EPS-GA)) + F3IM=-PARU(1)*LOG((GA+0.25D0*RAT*EPS)/ + & (1D0+0.25D0*RAT*EPS-GA)) + ELSE + F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)- + & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN(GA/(GA-BE),0D0,1)- + & PYSPEN((GA-1D0)/(GA-BE),0D0,1)+LOG(GA/(1D0-GA))* + & LOG((GA+BE-1D0)/(BE-GA)) + F3IM=-PARU(1)*LOG((GA+BE-1D0)/(BE-GA)) + ENDIF + ELSE + RSQ=EPS/(EPS-1D0+(2D0*BE-1D0)**2) + RCTHE=RSQ*(1D0-2D0*BE/EPS) + RSTHE=SQRT(MAX(0D0,RSQ-RCTHE**2)) + RCPHI=RSQ*(1D0+2D0*(BE-1D0)/EPS) + RSPHI=SQRT(MAX(0D0,RSQ-RCPHI**2)) + R=SQRT(RSQ) + THE=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCTHE/R))) + PHI=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCPHI/R))) + F3RE=PYSPEN(RCTHE,RSTHE,1)+PYSPEN(RCTHE,-RSTHE,1)- + & PYSPEN(RCPHI,RSPHI,1)-PYSPEN(RCPHI,-RSPHI,1)+ + & (PHI-THE)*(PHI+THE-PARU(1)) + F3IM=PYSPEN(RCTHE,RSTHE,2)+PYSPEN(RCTHE,-RSTHE,2)- + & PYSPEN(RCPHI,RSPHI,2)-PYSPEN(RCPHI,-RSPHI,2) + ENDIF + + Y3RE=2D0/(2D0*BE-1D0)*F3RE + Y3IM=2D0/(2D0*BE-1D0)*F3IM + + RETURN + END + +C*********************************************************************** + +C...PYSPEN +C...Calculates real and imaginary part of Spence function; see +C...G. 't Hooft and M. Veltman, Nucl. Phys. B153 (1979) 365. + + FUNCTION PYSPEN(XREIN,XIMIN,IREIM) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + SAVE /PYDAT1/ +C...Local array and data. + DIMENSION B(0:14) + DATA B/ + &1.000000D+00, -5.000000D-01, 1.666667D-01, + &0.000000D+00, -3.333333D-02, 0.000000D+00, + &2.380952D-02, 0.000000D+00, -3.333333D-02, + &0.000000D+00, 7.575757D-02, 0.000000D+00, + &-2.531135D-01, 0.000000D+00, 1.166667D+00/ + + XRE=XREIN + XIM=XIMIN + IF(ABS(1D0-XRE).LT.1D-6.AND.ABS(XIM).LT.1D-6) THEN + IF(IREIM.EQ.1) PYSPEN=PARU(1)**2/6D0 + IF(IREIM.EQ.2) PYSPEN=0D0 + RETURN + ENDIF + + XMOD=SQRT(XRE**2+XIM**2) + IF(XMOD.LT.1D-6) THEN + IF(IREIM.EQ.1) PYSPEN=0D0 + IF(IREIM.EQ.2) PYSPEN=0D0 + RETURN + ENDIF + + XARG=SIGN(ACOS(XRE/XMOD),XIM) + SP0RE=0D0 + SP0IM=0D0 + SGN=1D0 + IF(XMOD.GT.1D0) THEN + ALGXRE=LOG(XMOD) + ALGXIM=XARG-SIGN(PARU(1),XARG) + SP0RE=-PARU(1)**2/6D0-(ALGXRE**2-ALGXIM**2)/2D0 + SP0IM=-ALGXRE*ALGXIM + SGN=-1D0 + XMOD=1D0/XMOD + XARG=-XARG + XRE=XMOD*COS(XARG) + XIM=XMOD*SIN(XARG) + ENDIF + IF(XRE.GT.0.5D0) THEN + ALGXRE=LOG(XMOD) + ALGXIM=XARG + XRE=1D0-XRE + XIM=-XIM + XMOD=SQRT(XRE**2+XIM**2) + XARG=SIGN(ACOS(XRE/XMOD),XIM) + ALGYRE=LOG(XMOD) + ALGYIM=XARG + SP0RE=SP0RE+SGN*(PARU(1)**2/6D0-(ALGXRE*ALGYRE-ALGXIM*ALGYIM)) + SP0IM=SP0IM-SGN*(ALGXRE*ALGYIM+ALGXIM*ALGYRE) + SGN=-SGN + ENDIF + + XRE=1D0-XRE + XIM=-XIM + XMOD=SQRT(XRE**2+XIM**2) + XARG=SIGN(ACOS(XRE/XMOD),XIM) + ZRE=-LOG(XMOD) + ZIM=-XARG + + SPRE=0D0 + SPIM=0D0 + SAVERE=1D0 + SAVEIM=0D0 + DO 100 I=0,14 + IF(MAX(ABS(SAVERE),ABS(SAVEIM)).LT.1D-30) GOTO 110 + TERMRE=(SAVERE*ZRE-SAVEIM*ZIM)/DBLE(I+1) + TERMIM=(SAVERE*ZIM+SAVEIM*ZRE)/DBLE(I+1) + SAVERE=TERMRE + SAVEIM=TERMIM + SPRE=SPRE+B(I)*TERMRE + SPIM=SPIM+B(I)*TERMIM + 100 CONTINUE + + 110 IF(IREIM.EQ.1) PYSPEN=SP0RE+SGN*SPRE + IF(IREIM.EQ.2) PYSPEN=SP0IM+SGN*SPIM + + RETURN + END + +C*********************************************************************** + +C...PYQQBH +C...Calculates the matrix element for the processes +C...g + g or q + qbar -> Q + Qbar + H (normally with Q = t). +C...REDUCE output and part of the rest courtesy Z. Kunszt, see +C...Z. Kunszt, Nucl. Phys. B247 (1984) 339. + + SUBROUTINE PYQQBH(WTQQBH) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) + SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/ +C...Local arrays and function. + DIMENSION PP(15,4),CLR(8,8),FM(10,10),RM(8,8),DX(8) + DOT(I,J)=PP(I,4)*PP(J,4)-PP(I,1)*PP(J,1)-PP(I,2)*PP(J,2)- + &PP(I,3)*PP(J,3) + +C...Mass parameters. + WTQQBH=0D0 + ISUB=MINT(1) + SHPR=SQRT(VINT(26))*VINT(1) + PQ=PMAS(PYCOMP(KFPR(ISUB,2)),1) + PH=SQRT(VINT(21))*VINT(1) + SPQ=PQ**2 + SPH=PH**2 + +C...Set up outgoing kinematics: 1=t, 2=tbar, 3=H. + DO 100 I=1,2 + PT=SQRT(MAX(0D0,VINT(197+5*I))) + PP(I,1)=PT*COS(VINT(198+5*I)) + PP(I,2)=PT*SIN(VINT(198+5*I)) + 100 CONTINUE + PP(3,1)=-PP(1,1)-PP(2,1) + PP(3,2)=-PP(1,2)-PP(2,2) + PMS1=SPQ+PP(1,1)**2+PP(1,2)**2 + PMS2=SPQ+PP(2,1)**2+PP(2,2)**2 + PMS3=SPH+PP(3,1)**2+PP(3,2)**2 + PMT3=SQRT(PMS3) + PP(3,3)=PMT3*SINH(VINT(211)) + PP(3,4)=PMT3*COSH(VINT(211)) + PMS12=(SHPR-PP(3,4))**2-PP(3,3)**2 + PP(1,3)=(-PP(3,3)*(PMS12+PMS1-PMS2)+ + &VINT(213)*(SHPR-PP(3,4))*VINT(220))/(2D0*PMS12) + PP(2,3)=-PP(1,3)-PP(3,3) + PP(1,4)=SQRT(PMS1+PP(1,3)**2) + PP(2,4)=SQRT(PMS2+PP(2,3)**2) + +C...Set up incoming kinematics and derived momentum combinations. + DO 110 I=4,5 + PP(I,1)=0D0 + PP(I,2)=0D0 + PP(I,3)=-0.5D0*SHPR*(-1)**I + PP(I,4)=-0.5D0*SHPR + 110 CONTINUE + DO 120 J=1,4 + PP(6,J)=PP(1,J)+PP(2,J) + PP(7,J)=PP(1,J)+PP(3,J) + PP(8,J)=PP(1,J)+PP(4,J) + PP(9,J)=PP(1,J)+PP(5,J) + PP(10,J)=-PP(2,J)-PP(3,J) + PP(11,J)=-PP(2,J)-PP(4,J) + PP(12,J)=-PP(2,J)-PP(5,J) + PP(13,J)=-PP(4,J)-PP(5,J) + 120 CONTINUE + +C...Derived kinematics invariants. + X1=DOT(1,2) + X2=DOT(1,3) + X3=DOT(1,4) + X4=DOT(1,5) + X5=DOT(2,3) + X6=DOT(2,4) + X7=DOT(2,5) + X8=DOT(3,4) + X9=DOT(3,5) + X10=DOT(4,5) + +C...Propagators. + SS1=DOT(7,7)-SPQ + SS2=DOT(8,8)-SPQ + SS3=DOT(9,9)-SPQ + SS4=DOT(10,10)-SPQ + SS5=DOT(11,11)-SPQ + SS6=DOT(12,12)-SPQ + SS7=DOT(13,13) + DX(1)=SS1*SS6 + DX(2)=SS2*SS6 + DX(3)=SS2*SS4 + DX(4)=SS1*SS5 + DX(5)=SS3*SS5 + DX(6)=SS3*SS4 + DX(7)=SS7*SS1 + DX(8)=SS7*SS4 + +C...Define colour coefficients for g + g -> Q + Qbar + H. + IF(ISUB.EQ.121.OR.ISUB.EQ.181.OR.ISUB.EQ.186) THEN + DO 140 I=1,3 + DO 130 J=1,3 + CLR(I,J)=16D0/3D0 + CLR(I+3,J+3)=16D0/3D0 + CLR(I,J+3)=-2D0/3D0 + CLR(I+3,J)=-2D0/3D0 + 130 CONTINUE + 140 CONTINUE + DO 160 L=1,2 + DO 150 I=1,3 + CLR(I,6+L)=-6D0 + CLR(I+3,6+L)=6D0 + CLR(6+L,I)=-6D0 + CLR(6+L,I+3)=6D0 + 150 CONTINUE + 160 CONTINUE + DO 180 K1=1,2 + DO 170 K2=1,2 + CLR(6+K1,6+K2)=12D0 + 170 CONTINUE + 180 CONTINUE + +C...Evaluate matrix elements for g + g -> Q + Qbar + H. + FM(1,1)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X4+X9+2* + & X7+X5)+8*PQ**2*PH**2*(-X1-X4+2*X7)+16*PQ**2*(X2*X9+4*X2* + & X7+X2*X5-2*X4*X7-2*X9*X7)+8*PH**2*X4*X7-16*X2*X9*X7 + FM(1,2)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10+X9-X8+2 + & *X7-4*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X4-2*X2*X10+X2*X7-2* + & X2*X6-2*X3*X7+2*X4*X7+4*X10*X7-X9*X7-X8*X7)+16*X2*X7*(X4+ + & X10) + FM(1,3)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-2*X3-4* + & X4-8*X10+X9+X8-2*X7-4*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X4+X10 + & +X6)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2 + & -4*X2*X4-5*X2*X10+X2*X8-X2*X7-3*X2*X6+X2*X5+X3*X9+2*X3*X7 + & -X3*X5+X4*X8+2*X4*X6-3*X4*X5-5*X10*X5+X9*X8+X9*X6+X9*X5+ + & X8*X7-4*X6*X5+X5**2)-(16*X2*X5)*(X1+X4+X10+X6) + FM(1,4)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1+X2-X3-X4+X10- + & X9-X8+2*X7+2*X6-X5)+4*PQ**2*PH**2*(X1+X3+X4+X10+2*X7+2*X6 + & )+8*PQ**2*(4*X1*X10+4*X1*X7+4*X1*X6+2*X2*X10-X2*X9-X2*X8+ + & 4*X2*X7+4*X2*X6-X2*X5+4*X10*X5+4*X7*X5+4*X6*X5)-(8*PH**2* + & X1)*(X10+X7+X6)+16*X2*X5*(X10+X7+X6) + FM(1,5)=8*PQ**4*(-2*X1-2*X4+X10-X9)+4*PQ**2*(4*X1**2-2*X1* + & X2+8*X1*X3+6*X1*X10-2*X1*X9+4*X1*X8+4*X1*X7+4*X1*X6+2*X1* + & X5+X2*X10+4*X3*X4-X3*X9+2*X3*X7+3*X4*X8-2*X4*X6+2*X4*X5-4 + & *X10*X7+3*X10*X5-3*X9*X6+3*X8*X7-4*X7**2+4*X7*X5)+8*(X1** + & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5-X1*X4* + & X8-X1*X4*X5+X1*X10*X9+X1*X9*X7+X1*X9*X6-X1*X8*X7-X2*X3*X7 + & +X2*X4*X6-X2*X10*X7-X2*X7**2+X3*X7*X5-X4*X10*X5-X4*X7*X5- + & X4*X6*X5) + FM(1,6)=16*PQ**4*(-4*X1-X4+X9-X7)+4*PQ**2*PH**2*(-2*X1-X4- + & X7)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X4-3*X1*X9-2*X1*X7-3* + & X1*X5-2*X2*X4-2*X7*X5)-8*PH**2*X4*X7+8*(-X1*X2*X9-2*X1*X2 + & *X5-X1*X9**2-X1*X9*X5+X2**2*X7-X2*X4*X5+X2*X9*X7-X2*X7*X5 + & +X4*X9*X5+X4*X5**2) + FM(1,7)=8*PQ**4*(2*X3+X4+3*X10+X9+2*X8+3*X7+6*X6)+2*PQ**2* + & PH**2*(-2*X3-X4+3*X10+3*X7+6*X6)+4*PQ**2*(4*X1*X10+4*X1* + & X7+8*X1*X6+6*X2*X10+X2*X9+2*X2*X8+6*X2*X7+12*X2*X6-8*X3* + & X7+4*X4*X7+4*X4*X6+4*X10*X5+4*X9*X7+4*X9*X6-8*X8*X7+4*X7* + & X5+8*X6*X5)+4*PH**2*(-X1*X10-X1*X7-2*X1*X6+2*X3*X7-X4*X7- + & X4*X6)+8*X2*(X10*X5+X9*X7+X9*X6-2*X8*X7+X7*X5+2*X6*X5) + FM(1,8)=8*PQ**4*(2*X3+X4+3*X10+2*X9+X8+3*X7+6*X6)+2*PQ**2* + & PH**2*(-2*X3-X4+2*X10+X7+2*X6)+4*PQ**2*(4*X1*X10-2*X1*X9+ + & 2*X1*X8+4*X1*X7+8*X1*X6+5*X2*X10+2*X2*X9+X2*X8+4*X2*X7+8* + & X2*X6-X3*X9-8*X3*X7+2*X3*X5+2*X4*X9-X4*X8+4*X4*X7+4*X4*X6 + & +4*X4*X5+5*X10*X5+X9**2-X9*X8+2*X9*X7+5*X9*X6+X9*X5-7*X8* + & X7+2*X8*X5+2*X7*X5+10*X6*X5)+2*PH**2*(-X1*X10+X3*X7-2*X4* + & X7+X4*X6)+4*(-X1*X9**2+X1*X9*X8-2*X1*X9*X5-X1*X8*X5+2*X2* + & X10*X5+X2*X9*X7+X2*X9*X6-2*X2*X8*X7+3*X2*X6*X5+X3*X9*X5+ + & X3*X5**2+X4*X9*X5-2*X4*X8*X5+2*X4*X5**2) + FM(2,2)=16*PQ**6+16*PQ**4*(-X1+X3-X4-X10+X7-X6)+16*PQ**2*( + & X3*X10+X3*X7+X3*X6+X4*X7+X10*X7)-16*X3*X10*X7 + FM(2,3)=16*PQ**6+8*PQ**4*(-2*X1+X2+2*X3-4*X4-4*X10-X9+X8-2 + & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5+4*X3*X10-X3*X9-X3*X8-2*X3* + & X7+2*X3*X6+X3*X5-2*X4*X5-2*X10*X5-2*X6*X5)+16*X3*X5*(X10+ + & X6) + FM(2,4)=8*PQ**4*(-2*X1-2*X3+X10-X8)+4*PQ**2*(4*X1**2-2*X1* + & X2+8*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+4*X1*X7+4*X1*X6+2*X1* + & X5+X2*X10+4*X3*X4+3*X3*X9-2*X3*X7+2*X3*X5-X4*X8+2*X4*X6-4 + & *X10*X6+3*X10*X5+3*X9*X6-3*X8*X7-4*X6**2+4*X6*X5)+8*(-X1 + & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9-X1*X3*X5+X1*X4 + & *X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X1*X8*X6+X2*X3* + & X7-X2*X4*X6-X2*X10*X6-X2*X6**2-X3*X10*X5-X3*X7*X5-X3*X6* + & X5+X4*X6*X5) + FM(2,5)=16*PQ**4*X10+8*PQ**2*(2*X1**2+2*X1*X3+2*X1*X4+2*X1 + & *X10+2*X1*X7+2*X1*X6+X3*X7+X4*X6)+8*(-2*X1**3-2*X1**2*X3- + & 2*X1**2*X4-2*X1**2*X10-2*X1**2*X7-2*X1**2*X6-2*X1*X3*X4- + & X1*X3*X10-2*X1*X3*X6-X1*X4*X10-2*X1*X4*X7-X1*X10**2-X1* + & X10*X7-X1*X10*X6-2*X1*X7*X6+X3**2*X7-X3*X4*X7-X3*X4*X6+X3 + & *X10*X7+X3*X7**2-X3*X7*X6+X4**2*X6+X4*X10*X6-X4*X7*X6+X4* + & X6**2) + FM(2,6)=8*PQ**4*(-2*X1+X10-X9-2*X7)+4*PQ**2*(4*X1**2+2*X1* + & X2+4*X1*X3+4*X1*X4+6*X1*X10-2*X1*X9+4*X1*X8+8*X1*X6-2*X1* + & X5+4*X2*X4+3*X2*X10+2*X2*X7-3*X3*X9-2*X3*X7-4*X4**2-4*X4* + & X10+3*X4*X8+2*X4*X6+X10*X5-X9*X6+3*X8*X7+4*X7*X6)+8*(X1** + & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5+X1*X4* + & X9-X1*X4*X8-X1*X4*X5+X1*X10*X9+X1*X9*X6-X1*X8*X7-X2*X3*X7 + & -X2*X4*X7+X2*X4*X6-X2*X10*X7+X3*X7*X5-X4**2*X5-X4*X10*X5- + & X4*X6*X5) + FM(2,7)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3- + & 2*X1*X4-2*X1*X10+X1*X9-X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2* + & X4+3*X2*X10+X2*X7+2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9-2*X3* + & X7-4*X3*X6-X3*X5-6*X4**2-6*X4*X10-3*X4*X9-X4*X8-4*X4*X7-2 + & *X4*X6-2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+X10*X5 + & +X9*X7-2*X8*X7-2*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*( + & -X1**2*X9+X1**2*X8-2*X1*X2*X10-3*X1*X2*X7-3*X1*X2*X6+X1* + & X3*X9-X1*X3*X5+X1*X4*X9+X1*X4*X8+X1*X4*X5+X1*X10*X9+X1* + & X10*X8-X1*X9*X6+X1*X8*X6+X2*X3*X7-3*X2*X4*X7-X2*X4*X6-3* + & X2*X10*X7-3*X2*X10*X6-3*X2*X7*X6-3*X2*X6**2-2*X3*X4*X5-X3 + & *X10*X5-X3*X6*X5-X4**2*X5-X4*X10*X5+X4*X6*X5) + FM(2,8)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3- + & 2*X1*X4-2*X1*X10-X1*X9+X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2* + & X4+X2*X10-X2*X7-2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9+X3*X8-2* + & X3*X7-4*X3*X6+X3*X5-6*X4**2-6*X4*X10-2*X4*X9-4*X4*X7-2*X4 + & *X6+2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+3*X10*X5- + & X9*X6-2*X8*X7-3*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*( + & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6-3*X1*X3*X5+X1*X4*X9- + & X1*X4*X8-3*X1*X4*X5+X1*X10*X9+X1*X10*X8-2*X1*X10*X5+X1*X9 + & *X6+X1*X8*X7+X1*X8*X6-X2*X4*X7+X2*X4*X6-X2*X10*X7-X2*X10* + & X6-2*X2*X7*X6-X2*X6**2-3*X3*X4*X5-3*X3*X10*X5+X3*X7*X5-3* + & X3*X6*X5-3*X4**2*X5-3*X4*X10*X5-X4*X6*X5) + FM(3,3)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X3+X8+X6 + & +2*X5)+8*PQ**2*PH**2*(-X1+2*X3-X6)+16*PQ**2*(X2*X5-2*X3* + & X8-2*X3*X6+4*X3*X5+X8*X5)+8*PH**2*X3*X6-16*X3*X8*X5 + FM(3,4)=16*PQ**4*(-4*X1-X3+X8-X6)+4*PQ**2*PH**2*(-2*X1-X3- + & X6)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X3-3*X1*X8-2*X1*X6-3* + & X1*X5-2*X2*X3-2*X6*X5)-8*PH**2*X3*X6+8*(-X1*X2*X8-2*X1*X2 + & *X5-X1*X8**2-X1*X8*X5+X2**2*X6-X2*X3*X5+X2*X8*X6-X2*X6*X5 + & +X3*X8*X5+X3*X5**2) + FM(3,5)=8*PQ**4*(-2*X1+X10-X8-2*X6)+4*PQ**2*(4*X1**2+2*X1* + & X2+4*X1*X3+4*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+8*X1*X7-2*X1* + & X5+4*X2*X3+3*X2*X10+2*X2*X6-4*X3**2-4*X3*X10+3*X3*X9+2*X3 + & *X7-3*X4*X8-2*X4*X6+X10*X5+3*X9*X6-X8*X7+4*X7*X6)+8*(-X1 + & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9+X1*X3*X8-X1*X3 + & *X5+X1*X4*X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X2*X3* + & X7-X2*X3*X6-X2*X4*X6-X2*X10*X6-X3**2*X5-X3*X10*X5-X3*X7* + & X5+X4*X6*X5) + FM(3,6)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1-X2+2*X3+2*X4+ + & X10-X9-X8-X7-X6+X5)+4*PQ**2*PH**2*(X1+2*X3+2*X4+X10+X7+X6 + & )+8*PQ**2*(4*X1*X3+4*X1*X4+4*X1*X10+4*X2*X3+4*X2*X4+4*X2* + & X10-X2*X5+4*X3*X5+4*X4*X5+2*X10*X5-X9*X5-X8*X5)-(8*PH**2* + & X1)*(X3+X4+X10)+16*X2*X5*(X3+X4+X10) + FM(3,7)=8*PQ**4*(3*X3+6*X4+3*X10+X9+2*X8+2*X7+X6)+2*PQ**2* + & PH**2*(X3+2*X4+2*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+4* + & X1*X10+2*X1*X9-2*X1*X8+2*X2*X3+10*X2*X4+5*X2*X10+2*X2*X9+ + & X2*X8+2*X2*X7+4*X2*X6-7*X3*X9+2*X3*X8-8*X3*X7+4*X3*X6+4* + & X3*X5+5*X4*X8+4*X4*X6+8*X4*X5+5*X10*X5-X9*X8-X9*X6+X9*X5+ + & X8**2-X8*X7+2*X8*X6+2*X8*X5)+2*PH**2*(-X1*X10+X3*X7-2*X3* + & X6+X4*X6)+4*(-X1*X2*X9-2*X1*X2*X8+X1*X9*X8-X1*X8**2+X2**2 + & *X7+2*X2**2*X6+3*X2*X4*X5+2*X2*X10*X5-2*X2*X9*X6+X2*X8*X7 + & +X2*X8*X6-2*X3*X9*X5+X3*X8*X5+X4*X8*X5) + FM(3,8)=8*PQ**4*(3*X3+6*X4+3*X10+2*X9+X8+2*X7+X6)+2*PQ**2* + & PH**2*(3*X3+6*X4+3*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+ + & 4*X1*X10+4*X2*X3+8*X2*X4+4*X2*X10-8*X3*X9+4*X3*X8-8*X3*X7 + & +4*X3*X6+6*X3*X5+4*X4*X8+4*X4*X6+12*X4*X5+6*X10*X5+2*X9* + & X5+X8*X5)+4*PH**2*(-X1*X3-2*X1*X4-X1*X10+2*X3*X7-X3*X6-X4 + & *X6)+8*X5*(X2*X3+2*X2*X4+X2*X10-2*X3*X9+X3*X8+X4*X8) + FM(4,4)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X3+X8+2* + & X6+X5)+8*PQ**2*PH**2*(-X1-X3+2*X6)+16*PQ**2*(X2*X8+4*X2* + & X6+X2*X5-2*X3*X6-2*X8*X6)+8*PH**2*X3*X6-16*X2*X8*X6 + FM(4,5)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10-X9+X8-4 + & *X7+2*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X3-2*X2*X10-2*X2*X7+ + & X2*X6+2*X3*X6-2*X4*X6+4*X10*X6-X9*X6-X8*X6)+16*X2*X6*(X3+ + & X10) + FM(4,6)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-4*X3-2* + & X4-8*X10+X9+X8-4*X7-2*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X3+X10 + & +X7)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2 + & -4*X2*X3-5*X2*X10+X2*X9-3*X2*X7-X2*X6+X2*X5+X3*X9+2*X3*X7 + & -3*X3*X5+X4*X8+2*X4*X6-X4*X5-5*X10*X5+X9*X8+X9*X6+X8*X7+ + & X8*X5-4*X7*X5+X5**2)-(16*X2*X5)*(X1+X3+X10+X7) + FM(4,7)=8*PQ**4*(-X3-2*X4-3*X10-2*X9-X8-6*X7-3*X6)+2*PQ**2 + & *PH**2*(X3+2*X4-3*X10-6*X7-3*X6)+4*PQ**2*(-4*X1*X10-8*X1* + & X7-4*X1*X6-6*X2*X10-2*X2*X9-X2*X8-12*X2*X7-6*X2*X6-4*X3* + & X7-4*X3*X6+8*X4*X6-4*X10*X5+8*X9*X6-4*X8*X7-4*X8*X6-8*X7* + & X5-4*X6*X5)+4*PH**2*(X1*X10+2*X1*X7+X1*X6+X3*X7+X3*X6-2* + & X4*X6)+8*X2*(-X10*X5+2*X9*X6-X8*X7-X8*X6-2*X7*X5-X6*X5) + FM(4,8)=8*PQ**4*(-X3-2*X4-3*X10-X9-2*X8-6*X7-3*X6)+2*PQ**2 + & *PH**2*(X3+2*X4-2*X10-2*X7-X6)+4*PQ**2*(-4*X1*X10-2*X1*X9 + & +2*X1*X8-8*X1*X7-4*X1*X6-5*X2*X10-X2*X9-2*X2*X8-8*X2*X7-4 + & *X2*X6+X3*X9-2*X3*X8-4*X3*X7-4*X3*X6-4*X3*X5+X4*X8+8*X4* + & X6-2*X4*X5-5*X10*X5+X9*X8+7*X9*X6-2*X9*X5-X8**2-5*X8*X7-2 + & *X8*X6-X8*X5-10*X7*X5-2*X6*X5)+2*PH**2*(X1*X10-X3*X7+2*X3 + & *X6-X4*X6)+4*(-X1*X9*X8+X1*X9*X5+X1*X8**2+2*X1*X8*X5-2*X2 + & *X10*X5+2*X2*X9*X6-X2*X8*X7-X2*X8*X6-3*X2*X7*X5+2*X3*X9* + & X5-X3*X8*X5-2*X3*X5**2-X4*X8*X5-X4*X5**2) + FM(5,5)=16*PQ**6+16*PQ**4*(-X1-X3+X4-X10-X7+X6)+16*PQ**2*( + & X3*X6+X4*X10+X4*X7+X4*X6+X10*X6)-16*X4*X10*X6 + FM(5,6)=16*PQ**6+8*PQ**4*(-2*X1+X2-4*X3+2*X4-4*X10+X9-X8-2 + & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5-2*X3*X5+4*X4*X10-X4*X9-X4* + & X8+2*X4*X7-2*X4*X6+X4*X5-2*X10*X5-2*X7*X5)+16*X4*X5*(X10+ + & X7) + FM(5,7)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+ + & 4*X1*X4+2*X1*X10+X1*X9-X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2* + & X4-3*X2*X10-2*X2*X7-X2*X6+6*X3**2+6*X3*X4+6*X3*X10+X3*X9+ + & 3*X3*X8+2*X3*X7+4*X3*X6+2*X3*X5+6*X4*X10+2*X4*X8+4*X4*X7+ + & 2*X4*X6+X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-X10*X5+ + & 2*X9*X7+2*X9*X6-X8*X6+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(- + & X1**2*X9+X1**2*X8+2*X1*X2*X10+3*X1*X2*X7+3*X1*X2*X6-X1*X3 + & *X9-X1*X3*X8-X1*X3*X5-X1*X4*X8+X1*X4*X5-X1*X10*X9-X1*X10* + & X8-X1*X9*X7+X1*X8*X7+X2*X3*X7+3*X2*X3*X6-X2*X4*X6+3*X2* + & X10*X7+3*X2*X10*X6+3*X2*X7**2+3*X2*X7*X6+X3**2*X5+2*X3*X4 + & *X5+X3*X10*X5-X3*X7*X5+X4*X10*X5+X4*X7*X5) + FM(5,8)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+ + & 4*X1*X4+2*X1*X10-X1*X9+X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2* + & X4-X2*X10+2*X2*X7+X2*X6+6*X3**2+6*X3*X4+6*X3*X10+2*X3*X8+ + & 2*X3*X7+4*X3*X6-2*X3*X5+6*X4*X10-X4*X9+2*X4*X8+4*X4*X7+2* + & X4*X6-X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-3*X10*X5+ + & 3*X9*X7+2*X9*X6+X8*X7+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*( + & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9-X1*X3*X8+3* + & X1*X3*X5+3*X1*X4*X5-X1*X10*X9-X1*X10*X8+2*X1*X10*X5-X1*X9 + & *X7-X1*X9*X6-X1*X8*X7-X2*X3*X7+X2*X3*X6+X2*X10*X7+X2*X10* + & X6+X2*X7**2+2*X2*X7*X6+3*X3**2*X5+3*X3*X4*X5+3*X3*X10*X5+ + & X3*X7*X5+3*X4*X10*X5+3*X4*X7*X5-X4*X6*X5) + FM(6,6)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X4+X9+X7 + & +2*X5)+8*PQ**2*PH**2*(-X1+2*X4-X7)+16*PQ**2*(X2*X5-2*X4* + & X9-2*X4*X7+4*X4*X5+X9*X5)+8*PH**2*X4*X7-16*X4*X9*X5 + FM(6,7)=8*PQ**4*(-6*X3-3*X4-3*X10-2*X9-X8-X7-2*X6)+2*PQ**2 + & *PH**2*(-2*X3-X4-2*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*X4 + & -4*X1*X10+2*X1*X9-2*X1*X8-10*X2*X3-2*X2*X4-5*X2*X10-X2*X9 + & -2*X2*X8-4*X2*X7-2*X2*X6-5*X3*X9-4*X3*X7-8*X3*X5-2*X4*X9+ + & 7*X4*X8-4*X4*X7+8*X4*X6-4*X4*X5-5*X10*X5-X9**2+X9*X8-2*X9 + & *X7+X9*X6-2*X9*X5+X8*X7-X8*X5)+2*PH**2*(X1*X10-X3*X7+2*X4 + & *X7-X4*X6)+4*(2*X1*X2*X9+X1*X2*X8+X1*X9**2-X1*X9*X8-2*X2 + & **2*X7-X2**2*X6-3*X2*X3*X5-2*X2*X10*X5-X2*X9*X7-X2*X9*X6+ + & 2*X2*X8*X7-X3*X9*X5-X4*X9*X5+2*X4*X8*X5) + FM(6,8)=8*PQ**4*(-6*X3-3*X4-3*X10-X9-2*X8-X7-2*X6)+2*PQ**2 + & *PH**2*(-6*X3-3*X4-3*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1* + & X4-4*X1*X10-8*X2*X3-4*X2*X4-4*X2*X10-4*X3*X9-4*X3*X7-12* + & X3*X5-4*X4*X9+8*X4*X8-4*X4*X7+8*X4*X6-6*X4*X5-6*X10*X5-X9 + & *X5-2*X8*X5)+4*PH**2*(2*X1*X3+X1*X4+X1*X10+X3*X7+X4*X7-2* + & X4*X6)+8*X5*(-2*X2*X3-X2*X4-X2*X10-X3*X9-X4*X9+2*X4*X8) + FM(7,7)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+9* + & X2*X10+7*X3*X7+2*X3*X6+2*X4*X7+7*X4*X6+X10*X5+2*X9*X7+7* + & X9*X6+7*X8*X7+2*X8*X6)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2 + & *X4*X7-7*X4*X6)+4*X2*(X10*X5+2*X9*X7+7*X9*X6+7*X8*X7+2*X8 + & *X6) + FM(7,8)=72*PQ**4*X10+2*PQ**2*PH**2*X10+4*PQ**2*(2*X1*X10+ + & 10*X2*X10+7*X3*X9+2*X3*X8+14*X3*X7+4*X3*X6+2*X4*X9+7*X4* + & X8+4*X4*X7+14*X4*X6+10*X10*X5+X9**2+7*X9*X8+2*X9*X7+7*X9* + & X6+X8**2+7*X8*X7+2*X8*X6)+2*PH**2*(7*X1*X10-7*X3*X7-2*X3* + & X6-2*X4*X7-7*X4*X6)+2*(-2*X1*X9**2-14*X1*X9*X8-2*X1*X8**2 + & +2*X2*X10*X5+2*X2*X9*X7+7*X2*X9*X6+7*X2*X8*X7+2*X2*X8*X6+ + & 7*X3*X9*X5+2*X3*X8*X5+2*X4*X9*X5+7*X4*X8*X5) + FM(8,8)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+X2 + & *X10+7*X3*X9+2*X3*X8+7*X3*X7+2*X3*X6+2*X4*X9+7*X4*X8+2*X4 + & *X7+7*X4*X6+9*X10*X5)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2* + & X4*X7-7*X4*X6)+4*X5*(X2*X10+7*X3*X9+2*X3*X8+2*X4*X9+7*X4* + & X8) + FM(9,9)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+ + & X3*X7+X4*X6-X10*X5+X9*X6+X8*X7)+PH**2*(X1*X10-X3*X7-X4*X6 + & )+2*X2*(-X10*X5+X9*X6+X8*X7) + FM(9,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2* + & X10+2*X3*X9+2*X3*X7+2*X4*X6-2*X10*X5+X9*X8+2*X8*X7)+PH**2 + & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X8*X7+X3* + & X9*X5) + FMXX=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2* + & X10+2*X4*X8+2*X4*X6+2*X3*X7-2*X10*X5+X9*X8+2*X9*X6)+PH**2 + & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X9*X6+X4* + & X8*X5) + FM(9,10)=0.5D0*(FMXX+FM(9,10)) + FM(10,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+ + & X3*X7+X4*X6-X10*X5+X9*X3+X8*X4)+PH**2*(X1*X10-X3*X7-X4*X6 + & )+2*X5*(-X10*X2+X9*X3+X8*X4) + +C...Repackage matrix elements. + DO 200 I=1,8 + DO 190 J=I,8 + RM(I,J)=FM(I,J) + 190 CONTINUE + 200 CONTINUE + RM(7,7)=FM(7,7)-2D0*FM(9,9) + RM(7,8)=FM(7,8)-2D0*FM(9,10) + RM(8,8)=FM(8,8)-2D0*FM(10,10) + +C...Produce final result: matrix elements * colours * propagators. + DO 220 I=1,8 + DO 210 J=I,8 + FAC=8D0 + IF(I.EQ.J)FAC=4D0 + WTQQBH=WTQQBH+RM(I,J)*FAC*CLR(I,J)/(DX(I)*DX(J)) + 210 CONTINUE + 220 CONTINUE + WTQQBH=-WTQQBH/256D0 + + ELSE +C...Evaluate matrix elements for q + qbar -> Q + Qbar + H. + A11=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X2*X10+X3 + & *X7+X4*X6+X9*X6+X8*X7)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X2)*(X9 + & *X6+X8*X7) + A12=-8D0*PQ**4*X10+4D0*PQ**2*(-X2*X10-X3*X9-2D0*X3*X7-X4*X8- + & 2D0*X4*X6-X10*X5-X9*X8-X9*X6-X8*X7)+2D0*PH**2*(-X1*X10+X3*X7 + & +X4*X6)+2D0*(2D0*X1*X9*X8-X2*X9*X6-X2*X8*X7-X3*X9*X5-X4*X8* + & X5) + A22=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X3*X9+X3* + & X7+X4*X8+X4*X6+X10*X5)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X5)*(X3 + & *X9+X4*X8) + +C...Produce final result: matrix elements * propagators. + A11=A11/DX(7)**2 + A12=A12/(DX(7)*DX(8)) + A22=A22/DX(8)**2 + WTQQBH=-(A11+A22+2D0*A12)*8D0/9D0 + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYSTBH (and auxiliaries) +C.. Evaluates the matrix elements for t + b + H production. + + SUBROUTINE PYSTBH(WTTBH) + +C...DOUBLE PRECISION AND INTEGER DECLARATIONS + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP + +C...COMMONBLOCKS + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) + COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000) + COMMON/PYINT4/MWID(500),WIDS(500,5) + COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) + COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) + COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA, + &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4, + &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW, + &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR + COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A + DOUBLE PRECISION MW2 + SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/, + &/PYINT4/,/PYSUBS/,/PYMSSM/,/PYSGCM/,/PYCTBH/ + +C...LOCAL ARRAYS AND COMPLEX VARIABLES + DIMENSION QQ(4,2),PP(4,3) + DATA QQ/8*0D0/ + + WTTBH=0D0 + +C...KINEMATIC PARAMETERS. + SHPR=SQRT(VINT(26))*VINT(1) + PH=SQRT(VINT(21))*VINT(1) + SPH=PH**2 + +C...SET UP OUTGOING KINEMATICS: 1=T, 2=TBAR, 3=H. + DO 100 I=1,2 + PT=SQRT(MAX(0D0,VINT(197+5*I))) + PP(1,I)=PT*COS(VINT(198+5*I)) + PP(2,I)=PT*SIN(VINT(198+5*I)) + 100 CONTINUE + PP(1,3)=-PP(1,1)-PP(1,2) + PP(2,3)=-PP(2,1)-PP(2,2) + PMS1=VINT(201)**2+PP(1,1)**2+PP(2,1)**2 + PMS2=VINT(206)**2+PP(1,2)**2+PP(2,2)**2 + PMS3=SPH+PP(1,3)**2+PP(2,3)**2 + PMT3=SQRT(PMS3) + PP(3,3)=PMT3*SINH(VINT(211)) + PP(4,3)=PMT3*COSH(VINT(211)) + PMS12=(SHPR-PP(4,3))**2-PP(3,3)**2 + PP(3,1)=(-PP(3,3)*(PMS12+PMS1-PMS2)+ + &VINT(213)*(SHPR-PP(4,3))*VINT(220))/(2D0*PMS12) + PP(3,2)=-PP(3,1)-PP(3,3) + PP(4,1)=SQRT(PMS1+PP(3,1)**2) + PP(4,2)=SQRT(PMS2+PP(3,2)**2) + +C...CM SYSTEM, INGOING QUARKS/GLUONS + QQ(3,1) = SHPR/2.D0 + QQ(4,1) = QQ(3,1) + QQ(3,2) = -QQ(3,1) + QQ(4,2) = QQ(4,1) + +C...PARAMETERS FOR AMPLITUDE METHOD + ALPHA = AEM + ALPHAS = AS + SW2 = PARU(102) + MW2 = PMAS(24,1)**2 + TANB = PARU(141) + VTB = VCKM(3,3) + RMB=PYMRUN(5,VINT(52)) + + ISUB=MINT(1) + + IF (ISUB.EQ.401) THEN + CALL PYTBHG(QQ(1,1),QQ(1,2),PP(1,1),PP(1,2),PP(1,3), + & VINT(201),VINT(206),RMB,VINT(43),WTTBH) + ELSE IF (ISUB.EQ.402) THEN + CALL PYTBHQ(QQ(1,1),QQ(1,2),PP(1,1),PP(1,2),PP(1,3), + & VINT(201),VINT(206),RMB,VINT(43),WTTBH) + END IF + + RETURN + END +C------------------------------------------------------------------ + SUBROUTINE PYTBHB(MT,MB,MHP,BR,GAMT) +C WIDTH AND BRANCHING RATIO FOR (ON-SHELL) T-> B W+, T->B H+ + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + DOUBLE PRECISION MW2,MT,MB,MHP,MW,KFUN + COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A + SAVE /PYCTBH/ + +C TOP WIDTH CALCULATION +C VTB = 0.99 + MW=DSQRT(MW2) + XB=(MB/MT)**2 + XW=(MW/MT)**2 + XH =(MHP/MT)**2 + GAMTBH = 0D0 + IF (MT .LT. (MHP+MB)) THEN +C T ->B W ONLY + BETW = DSQRT(1.D0-2*(XB+XW)+(XW-XB)**2) + GAMTBW = VTB**2*ALPHA/(16*SW2)*MT/XW*BETW* + & (2*(1.D0-XB-XW)-(1.D0+XB-XW)*(1.D0-XB -2*XW) ) + GAMT = GAMTBW + ELSE +C T ->BW +T ->B H^+ + BETW = DSQRT(1.D0-2*(XB+XW)+(XW-XB)**2) + GAMTBW = VTB**2*ALPHA/(16*SW2)*MT/XW*BETW* + & (2*(1.D0-XB-XW)-(1.D0+XB-XW)*(1.D0-XB -2*XW) ) +C + KFUN = DSQRT( (1.D0-(MHP/MT)**2-(MB/MT)**2)**2 + & -4.D0*(MHP*MB/MT**2)**2 ) + GAMTBH= ALPHA/SW2/8.D0*VTB**2*KFUN/MT * + & (V**2*((MT+MB)**2-MHP**2)+A**2*((MT-MB)**2-MHP**2)) + GAMT = GAMTBW+GAMTBH + ENDIF +C THUS BR IS + BR=GAMTBH/GAMT + RETURN + END + +C AMPLITUDE SQUARED (MATRIX ELEMENTS) FOR THE PROCESSES: +C GG->TBH^+, QQBAR->TBH^+ +C AS A FUNCTION OF 4-MOMENTA FOR SUITABLE INTERFACE +C (FOR INSTANCE WITH PYTHIA) +C------------------------------------------------------------ +C BASED ON F. BORZUMATI, J.-L. KNEUR, N. POLONSKY HEP-PH/9905443, +C PHYS REV. D 60 (1999) 115011 +C (THESE FILES PREPARED BY J.-L. KNEUR) +C------------------------------------------------------------ +C 1) GG->TBH^+ + SUBROUTINE PYTBHG(Q1,Q2,P1,P2,P3,MT,MB,RMB,MHP,AMP2) +C +C CONVENTIONS AND INPUT/OUTPUT DEFINITIONS: +C +C INPUT: Q1,Q2 ARE ENTERING 4-MOMENTA OF INITIAL GLUONS OR QUARKS; +C P1, P2 ARE THE TOP AND BOTTOM OUTGOING 4-MOMENTA; +C P3 IS OUTGOING CHARGED HIGGS 4-MOMENTA. +C (NB FOR ALL 4-MOMENTA P(4) IS TIME-COMPONENT) +C "PHYSICAL PARAMETERS" INPUT: +C MT,MB TOP AND BOTTOM MASSES; +C MHP CHARGED HIGGS MASS +C FURTHER PARAMETERS INPUT IS NEEDED FROM COMMON/PARAM/ (SEE BELOW) +C +C OUTPUT: AMP2 IS MATRIX ELEMENT (AMPLITUDE**2) FOR GG->TB H^+ +C (NB AMP2 IS TRULY AMPLITUDE SQUARRED, I.E. WITHOUT ANY +C PHASE SPACE FACTORS INCLUDED. IT INCLUDES COLOUR AND COUPLING +C FACTORS, AS EXPLICIT BELOW. ACCORDINGLY, FOR EXAMPLE THE TOTAL +C CROSS-SECTION SHOULD BE (SYMBOLICALLY): +C SIGMA = INTEGRATE [PARTON DENSITY FUNCTIONS * 3-PARTICLE FINAL +C STATE PHASE-SPACE (STANDARDLY NORMALIZED) * AMP2 ] +C + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + DOUBLE PRECISION MW2,MT,MB,MHP,MW + DIMENSION Q1(4),Q2(4),P1(4),P2(4),P3(4) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) + + COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A + SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYCTBH/ +C !THE RELEVANT INPUT PARAMETERS ABOVE ARE NEEDED FOR CALCULATION +C BUT ARE NOT DEFINED HERE SO THAT ONE MAY CHOOSE/VARY THEIR VALUES: +C ACCORDINGLY, WHEN CALLING THESE SUBROUTINES, PLEASE SUPPLY VIA +C THIS COMMON/PARAM/ YOUR PREFERRED ALPHA, ALPHAS,..AND TANB +C (TAN BETA) VALUES +C +C THE NORMALIZED V,A COUPLINGS ARE DEFINED BELOW AND USED BOTH +C IN THIS ROUTINE AND IN THE TOP WIDTH CALCULATION PYTBHB(..). + + PI = 4*DATAN(1.D0) + MW = DSQRT(MW2) +C +C COLLECTING THE RELEVANT OVERALL FACTORS: +C 8X8 INITIAL GLUON COLOR AVERAGE, 2X2 GLUON SPIN AVERAGE + PS=1.D0/(8.D0*8.D0 *2.D0*2.D0) +C COUPLING CONSTANT (OVERALL NORMALIZATION) + FACT=(4.D0*PI*ALPHA)*(4.D0*PI*ALPHAS)**2/SW2/2.D0 +C NB ALPHA IS E^2/4/PI, BUT BETTER DEFINED IN TERMS OF G_FERMI: +C ALPHA= DSQRT(2.D0)*GF*SW2*MW**2/PI +C ALPHAS IS ALPHA_STRONG; +C SW2 IS SIN(THETA_W)**2. +C +C VTB=.998D0 +C VTB IS TOP-BOTTOM CKM MATRIX ELEMENT (APPROXIMATE VALUE HERE) +C + V = ( MT/MW/TANB +RMB/MW*TANB)/2.D0 + A = (-MT/MW/TANB +RMB/MW*TANB)/2.D0 +C V AND A ARE (NORMALIZED) VECTOR AND AXIAL TBH^+ COUPLINGS +C +C REDEFINING P2 INGOING FROM OVERALL MOMENTUM CONSERVATION +C (BECAUSE P2 INGOING WAS USED IN OUR GRAPH CALCULATION CONVENTIONS) + DO 100 KK=1,4 + P2(KK)=P3(KK)-Q1(KK)-Q2(KK)+P1(KK) + 100 CONTINUE +C DEFINING VARIOUS RELEVANT 4-SCALAR PRODUCTS: + S = 2*PYTBHS(Q1,Q2) + P1Q1=PYTBHS(Q1,P1) + P1Q2=PYTBHS(P1,Q2) + P2Q1=PYTBHS(P2,Q1) + P2Q2=PYTBHS(P2,Q2) + P1P2=PYTBHS(P1,P2) +C +C TOP WIDTH CALCULATION + CALL PYTBHB(MT,MB,MHP,BR,GAMT) +C GAMT IS THE TOP WIDTH: T->BH^+ AND/OR T->B W^+ +C THEN DEFINE TOP (RESONANT) PROPAGATOR: + A1INV= S -2*P1Q1 -2*P1Q2 + A1 =A1INV/(A1INV**2+ (GAMT*MT)**2) +C (I.E. INTRODUCE THE TOP WIDTH IN A1 TO REGULARISE THE POLE) +C NB: A12 = A1*A1 BUT CORRECT EXPRESSION BELOW BECAUSE OF +C THE TOP WIDTH + A12 = 1.D0/(A1INV**2+ (GAMT*MT)**2) + A2 =1.D0/(S +2*P2Q1 +2*P2Q2) +C NOTE A2 IS B PROPAGATOR, DOES NOT NEED A WIDTH +C NOW COMES THE AMP**2: +C NB COLOR FACTOR (COMING FROM GRAPHS) ALREADY INCLUDED IN +C THE EXPRESSIONS BELOW + V18=0.D0 + A18=0.D0 + V18= 640*A1/3+640*A2/3+32*A1*A2*MB**2-368*A12*MB*MT- + &512*A1*A2*MB*MT/3- + &368*A2**2*MB*MT+32*A1*A2*MT**2+496*A12*P1P2/3+ + &320*A1*A2*P1P2+496*A2**2*P1P2/3+128*A1*MB*MT**3/(3*P1Q1**2)+ + &128*A1*MT**4/(3*P1Q1**2)-256*A12*MB*MT**5/(3*P1Q1**2)+ + &256*A1*MT**2*P1P2/(3*P1Q1**2)-256*A12*MT**4*P1P2/(3*P1Q1**2)+ + &8/(3*P1Q1)-32*A1*MB*MT/P1Q1-56*A2*MB*MT/(3*P1Q1)+ + &88*A1*MT**2/(3*P1Q1)+72*A2*MT**2/P1Q1+ + &704*A12*MB*MT**3/(3*P1Q1)-224*A1*A2*MB*MT**3/(3*P1Q1)+ + &104*A1*P1P2/(3*P1Q1)+48*A2*P1P2/P1Q1+ + &128*A1*A2*MB*MT*P1P2/(3*P1Q1)+512*A12*MT**2*P1P2/(3*P1Q1)- + &448*A1*A2*MT**2*P1P2/(3*P1Q1)-32*A1*A2*P1P2**2/P1Q1- + &656*A1*A2*P1Q1/3-224*A2**2*P1Q1+128*A1*MB*MT**3/(3*P1Q2**2)+ + &128*A1*MT**4/(3*P1Q2**2)-256*A12*MB*MT**5/(3*P1Q2**2)+ + &256*A1*MT**2*P1P2/(3*P1Q2**2)-256*A12*MT**4*P1P2/(3*P1Q2**2)+ + &256*A1*MT**2*P1Q1/(3*P1Q2**2)+256*A12*MB*MT**3*P1Q1/(3*P1Q2**2)+ + &8/(3*P1Q2)-32*A1*MB*MT/P1Q2-56*A2*MB*MT/(3*P1Q2) + V18=V18+88*A1*MT**2/(3*P1Q2)+72*A2*MT**2/P1Q2+ + &704*A12*MB*MT**3/(3*P1Q2)-224*A1*A2*MB*MT**3/(3*P1Q2)+ + &104*A1*P1P2/(3*P1Q2)+48*A2*P1P2/P1Q2+ + &128*A1*A2*MB*MT*P1P2/(3*P1Q2)+512*A12*MT**2*P1P2/(3*P1Q2)- + &448*A1*A2*MT**2*P1P2/(3*P1Q2)-32*A1*A2*P1P2**2/P1Q2- + &32*A1*MB*MT**3/(3*P1Q1*P1Q2)-32*A1*MT**4/(3*P1Q1*P1Q2)+ + &64*A12*MB*MT**5/(3*P1Q1*P1Q2)+16*P1P2/(3*P1Q1*P1Q2)- + &64*A1*MT**2*P1P2/(3*P1Q1*P1Q2)+64*A12*MT**4*P1P2/(3*P1Q1*P1Q2)+ + &112*A1*P1Q1/P1Q2+272*A2*P1Q1/(3*P1Q2)- + &272*A1*A2*MB**2*P1Q1/(3*P1Q2)+208*A12*MB*MT*P1Q1/(3*P1Q2)- + &400*A1*A2*MB*MT*P1Q1/(3*P1Q2)-80*A1*A2*MT**2*P1Q1/P1Q2+ + &96*A12*P1P2*P1Q1/P1Q2-320*A1*A2*P1P2*P1Q1/P1Q2- + &544*A1*A2*P1Q1**2/(3*P1Q2)-656*A1*A2*P1Q2/3-224*A2**2*P1Q2+ + &256*A1*MT**2*P1Q2/(3*P1Q1**2)+256*A12*MB*MT**3*P1Q2/(3*P1Q1**2)+ + &112*A1*P1Q2/P1Q1+272*A2*P1Q2/(3*P1Q1)- + &272*A1*A2*MB**2*P1Q2/(3*P1Q1)+208*A12*MB*MT*P1Q2/(3*P1Q1)- + &400*A1*A2*MB*MT*P1Q2/(3*P1Q1)-80*A1*A2*MT**2*P1Q2/P1Q1 + V18=V18+96*A12*P1P2*P1Q2/P1Q1-320*A1*A2*P1P2*P1Q2/P1Q1- + &544*A1*A2*P1Q2**2/(3*P1Q1)+128*A2*MB**4/(3*P2Q1**2)+ + &128*A2*MB**3*MT/(3*P2Q1**2)-256*A2**2*MB**5*MT/(3*P2Q1**2)+ + &256*A2*MB**2*P1P2/(3*P2Q1**2)-256*A2**2*MB**4*P1P2/(3*P2Q1**2)+ + &256*A2*MB**2*P1Q1/(3*P2Q1**2)-256*A2**2*MB**4*P1Q1/(3*P2Q1**2)- + &64*MB**3*MT**3/(3*P1Q2**2*P2Q1**2)- + &64*MB**2*MT**2*P1P2/(3*P1Q2**2*P2Q1**2)- + &64*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1**2)+ + &64*MB**3*MT/(3*P1Q2*P2Q1**2)+ + &256*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1**2)+ + &256*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1**2)+ + &256*A2*MB**3*MT*P1Q1/(3*P1Q2*P2Q1**2)+ + &512*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1**2)+ + &256*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1**2)- + &256*A2**2*MB**4*P1Q2/(3*P2Q1**2)-8/(3*P2Q1)-72*A1*MB**2/P2Q1- + &88*A2*MB**2/(3*P2Q1)+56*A1*MB*MT/(3*P2Q1)+32*A2*MB*MT/P2Q1+ + &224*A1*A2*MB**3*MT/(3*P2Q1)-704*A2**2*MB**3*MT/(3*P2Q1) + V18=V18-48*A1*P1P2/P2Q1-104*A2*P1P2/(3*P2Q1)+ + &448*A1*A2*MB**2*P1P2/(3*P2Q1)-512*A2**2*MB**2*P1P2/(3*P2Q1)- + &128*A1*A2*MB*MT*P1P2/(3*P2Q1)+32*A1*A2*P1P2**2/P2Q1- + &16*P1P2/(3*P1Q1*P2Q1)-32*A1*MB*MT*P1P2/(3*P1Q1*P2Q1)- + &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q1)- + &64*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q1)- + &64*A1*A2*P1P2**3/(3*P1Q1*P2Q1)-256*A2*P1Q1/(3*P2Q1)+ + &448*A1*A2*MB**2*P1Q1/(3*P2Q1)-368*A2**2*MB**2*P1Q1/(3*P2Q1)+ + &224*A1*A2*MB*MT*P1Q1/(3*P2Q1)+304*A1*A2*P1P2*P1Q1/(3*P2Q1)- + &64*MB*MT**3/(3*P1Q2**2*P2Q1)- + &256*A1*MB*MT**3*P1P2/(3*P1Q2**2*P2Q1)- + &256*A1*MT**2*P1P2**2/(3*P1Q2**2*P2Q1)+ + &64*MT**2*P1Q1/(3*P1Q2**2*P2Q1)- + &128*A1*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1)- + &128*A1*MB*MT**3*P1Q1/(3*P1Q2**2*P2Q1)- + &256*A1*MT**2*P1P2*P1Q1/(3*P1Q2**2*P2Q1)-4*MB**2/(3*P1Q2*P2Q1)+ + &64*MB*MT/(3*P1Q2*P2Q1)-128*A2*MB**3*MT/(3*P1Q2*P2Q1) + V18=V18-4*MT**2/(3*P1Q2*P2Q1)-128*A1*MB**2*MT**2/(3*P1Q2*P2Q1)- + &128*A2*MB**2*MT**2/(3*P1Q2*P2Q1)-128*A1*MB*MT**3/(3*P1Q2*P2Q1)- + &112*A2*MB**2*P1P2/(3*P1Q2*P2Q1)-32*A1*MB*MT*P1P2/(3*P1Q2*P2Q1)- + &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q1)-112*A1*MT**2*P1P2/(3*P1Q2*P2Q1)- + &48*A1*P1P2**2/(P1Q2*P2Q1)-48*A2*P1P2**2/(P1Q2*P2Q1)+ + &512*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q1)+ + &512*A1*A2*P1P2**3/(3*P1Q2*P2Q1)-8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q1)- + &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q1)+ + &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q1)- + &16*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+ + &32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+8*P1Q1/(3*P1Q2*P2Q1)- + &160*A1*MB**2*P1Q1/(3*P1Q2*P2Q1)-272*A2*MB**2*P1Q1/(3*P1Q2*P2Q1)+ + &56*A1*MB*MT*P1Q1/(3*P1Q2*P2Q1)+200*A2*MB*MT*P1Q1/(3*P1Q2*P2Q1)- + &48*A1*P1P2*P1Q1/(P1Q2*P2Q1)-256*A2*P1P2*P1Q1/(3*P1Q2*P2Q1)+ + &256*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1)+ + &256*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1)+ + &1024*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q1) + V18=V18-272*A2*P1Q1**2/(3*P1Q2*P2Q1)+ + &256*A1*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1)+ + &256*A1*A2*MB*MT*P1Q1**2/(3*P1Q2*P2Q1)+ + &512*A1*A2*P1P2*P1Q1**2/(3*P1Q2*P2Q1)+16*A2*P1Q2/(3*P2Q1)+ + &64*A1*A2*MB**2*P1Q2/P2Q1+32*A2**2*MB**2*P1Q2/(3*P2Q1)+ + &112*A1*A2*MB*MT*P1Q2/(3*P2Q1)+368*A1*A2*P1P2*P1Q2/(3*P2Q1)+ + &32*A2*P1P2*P1Q2/(3*P1Q1*P2Q1)- + &32*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1)- + &32*A1*A2*MB*MT*P1P2*P1Q2/(3*P1Q1*P2Q1)- + &64*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q1)+224*A12*P2Q1+ + &656*A1*A2*P2Q1/3-256*A1*MT**2*P2Q1/(3*P1Q1**2)+ + &256*A12*MT**4*P2Q1/(3*P1Q1**2)-256*A1*P2Q1/(3*P1Q1)+ + &224*A1*A2*MB*MT*P2Q1/(3*P1Q1)-368*A12*MT**2*P2Q1/(3*P1Q1)+ + &448*A1*A2*MT**2*P2Q1/(3*P1Q1)+304*A1*A2*P1P2*P2Q1/(3*P1Q1)+ + &256*A12*MT**4*P2Q1/(3*P1Q2**2)+ + &256*A12*MT**2*P1Q1*P2Q1/(3*P1Q2**2)+16*A1*P2Q1/(3*P1Q2)+ + &112*A1*A2*MB*MT*P2Q1/(3*P1Q2)+32*A12*MT**2*P2Q1/(3*P1Q2) + V18=V18+64*A1*A2*MT**2*P2Q1/P1Q2+368*A1*A2*P1P2*P2Q1/(3*P1Q2)+ + &16*A1*MT**2*P2Q1/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q1/(3*P1Q1*P1Q2)+ + &640*A12*P1Q1*P2Q1/(3*P1Q2)+544*A1*A2*P1Q1*P2Q1/(3*P1Q2)+ + &32*A12*P1Q2*P2Q1/P1Q1+944*A1*A2*P1Q2*P2Q1/(3*P1Q1)+ + &128*A2*MB**4/(3*P2Q2**2)+128*A2*MB**3*MT/(3*P2Q2**2)- + &256*A2**2*MB**5*MT/(3*P2Q2**2)+256*A2*MB**2*P1P2/(3*P2Q2**2)- + &256*A2**2*MB**4*P1P2/(3*P2Q2**2)- + &64*MB**3*MT**3/(3*P1Q1**2*P2Q2**2)- + &64*MB**2*MT**2*P1P2/(3*P1Q1**2*P2Q2**2)+ + &64*MB**3*MT/(3*P1Q1*P2Q2**2)+ + &256*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q2**2)+ + &256*A2*MB**2*P1P2**2/(3*P1Q1*P2Q2**2)- + &256*A2**2*MB**4*P1Q1/(3*P2Q2**2)+256*A2*MB**2*P1Q2/(3*P2Q2**2)- + &256*A2**2*MB**4*P1Q2/(3*P2Q2**2)- + &64*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2**2)+ + &256*A2*MB**3*MT*P1Q2/(3*P1Q1*P2Q2**2)+ + &512*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2**2) + V18=V18+256*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2**2)- + &256*A2*MB**2*P2Q1/(3*P2Q2**2)-256*A2**2*MB**3*MT*P2Q1/(3*P2Q2**2)+ + &64*MB**2*MT**2*P2Q1/(3*P1Q1**2*P2Q2**2)+ + &64*MB**2*P2Q1/(3*P1Q1*P2Q2**2)- + &128*A2*MB**3*MT*P2Q1/(3*P1Q1*P2Q2**2)- + &128*A2*MB**2*MT**2*P2Q1/(3*P1Q1*P2Q2**2)- + &256*A2*MB**2*P1P2*P2Q1/(3*P1Q1*P2Q2**2)+ + &256*A2**2*MB**2*P1Q1*P2Q1/(3*P2Q2**2)- + &256*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2**2)-8/(3*P2Q2)- + &72*A1*MB**2/P2Q2-88*A2*MB**2/(3*P2Q2)+56*A1*MB*MT/(3*P2Q2)+ + &32*A2*MB*MT/P2Q2+224*A1*A2*MB**3*MT/(3*P2Q2)- + &704*A2**2*MB**3*MT/(3*P2Q2)-48*A1*P1P2/P2Q2- + &104*A2*P1P2/(3*P2Q2)+448*A1*A2*MB**2*P1P2/(3*P2Q2)- + &512*A2**2*MB**2*P1P2/(3*P2Q2)-128*A1*A2*MB*MT*P1P2/(3*P2Q2)+ + &32*A1*A2*P1P2**2/P2Q2-64*MB*MT**3/(3*P1Q1**2*P2Q2)- + &256*A1*MB*MT**3*P1P2/(3*P1Q1**2*P2Q2)- + &256*A1*MT**2*P1P2**2/(3*P1Q1**2*P2Q2)-4*MB**2/(3*P1Q1*P2Q2) + V18=V18+64*MB*MT/(3*P1Q1*P2Q2)-128*A2*MB**3*MT/(3*P1Q1*P2Q2)- + &4*MT**2/(3*P1Q1*P2Q2)-128*A1*MB**2*MT**2/(3*P1Q1*P2Q2)- + &128*A2*MB**2*MT**2/(3*P1Q1*P2Q2)-128*A1*MB*MT**3/(3*P1Q1*P2Q2)- + &112*A2*MB**2*P1P2/(3*P1Q1*P2Q2)-32*A1*MB*MT*P1P2/(3*P1Q1*P2Q2)- + &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q2)-112*A1*MT**2*P1P2/(3*P1Q1*P2Q2)- + &48*A1*P1P2**2/(P1Q1*P2Q2)-48*A2*P1P2**2/(P1Q1*P2Q2)+ + &512*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q2)+ + &512*A1*A2*P1P2**3/(3*P1Q1*P2Q2)+16*A2*P1Q1/(3*P2Q2)+ + &64*A1*A2*MB**2*P1Q1/P2Q2+32*A2**2*MB**2*P1Q1/(3*P2Q2)+ + &112*A1*A2*MB*MT*P1Q1/(3*P2Q2)+368*A1*A2*P1P2*P1Q1/(3*P2Q2)- + &16*P1P2/(3*P1Q2*P2Q2)-32*A1*MB*MT*P1P2/(3*P1Q2*P2Q2)- + &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q2)- + &64*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q2)- + &64*A1*A2*P1P2**3/(3*P1Q2*P2Q2)-8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q2)- + &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q2)+ + &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q2)- + &16*P1P2**2/(3*P1Q1*P1Q2*P2Q2) + V18=V18+32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q2)+ + &32*A2*P1P2*P1Q1/(3*P1Q2*P2Q2)- + &32*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q2)- + &32*A1*A2*MB*MT*P1P2*P1Q1/(3*P1Q2*P2Q2)- + &64*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q2)-256*A2*P1Q2/(3*P2Q2)+ + &448*A1*A2*MB**2*P1Q2/(3*P2Q2)-368*A2**2*MB**2*P1Q2/(3*P2Q2)+ + &224*A1*A2*MB*MT*P1Q2/(3*P2Q2)+304*A1*A2*P1P2*P1Q2/(3*P2Q2)+ + &64*MT**2*P1Q2/(3*P1Q1**2*P2Q2)- + &128*A1*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2)- + &128*A1*MB*MT**3*P1Q2/(3*P1Q1**2*P2Q2)- + &256*A1*MT**2*P1P2*P1Q2/(3*P1Q1**2*P2Q2)+8*P1Q2/(3*P1Q1*P2Q2)- + &160*A1*MB**2*P1Q2/(3*P1Q1*P2Q2)-272*A2*MB**2*P1Q2/(3*P1Q1*P2Q2)+ + &56*A1*MB*MT*P1Q2/(3*P1Q1*P2Q2)+200*A2*MB*MT*P1Q2/(3*P1Q1*P2Q2)- + &48*A1*P1P2*P1Q2/(P1Q1*P2Q2)-256*A2*P1P2*P1Q2/(3*P1Q1*P2Q2)+ + &256*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2)+ + &256*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2)+ + &1024*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q2) + V18=V18-272*A2*P1Q2**2/(3*P1Q1*P2Q2)+ + &256*A1*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2)+ + &256*A1*A2*MB*MT*P1Q2**2/(3*P1Q1*P2Q2)+ + &512*A1*A2*P1P2*P1Q2**2/(3*P1Q1*P2Q2)-32*A2*MB**4/(3*P2Q1*P2Q2)- + &32*A2*MB**3*MT/(3*P2Q1*P2Q2)+64*A2**2*MB**5*MT/(3*P2Q1*P2Q2)+ + &16*P1P2/(3*P2Q1*P2Q2)-64*A2*MB**2*P1P2/(3*P2Q1*P2Q2)+ + &64*A2**2*MB**4*P1P2/(3*P2Q1*P2Q2)+8*MB**2*P1P2/(3*P1Q1*P2Q1*P2Q2)+ + &8*MB*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)- + &32*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+ + &16*P1P2**2/(3*P1Q1*P2Q1*P2Q2)- + &32*A2*MB**2*P1P2**2/(3*P1Q1*P2Q1*P2Q2)- + &16*A2*MB**2*P1Q1/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q1/(3*P2Q1*P2Q2)+ + &8*MB**2*P1P2/(3*P1Q2*P2Q1*P2Q2)+8*MB*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)- + &32*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+ + &16*P1P2**2/(3*P1Q2*P2Q1*P2Q2)- + &32*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1*P2Q2)+ + &16*MB*MT*P1P2**2/(3*P1Q1*P1Q2*P2Q1*P2Q2) + V18=V18+16*P1P2**3/(3*P1Q1*P1Q2*P2Q1*P2Q2)- + &32*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1*P2Q2)- + &16*A2*MB**2*P1Q2/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q2/(3*P2Q1*P2Q2)- + &32*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1*P2Q2)+272*A1*P2Q1/(3*P2Q2)+ + &112*A2*P2Q1/P2Q2-80*A1*A2*MB**2*P2Q1/P2Q2- + &400*A1*A2*MB*MT*P2Q1/(3*P2Q2)+208*A2**2*MB*MT*P2Q1/(3*P2Q2)- + &272*A1*A2*MT**2*P2Q1/(3*P2Q2)-320*A1*A2*P1P2*P2Q1/P2Q2+ + &96*A2**2*P1P2*P2Q1/P2Q2+256*A1*MB*MT**3*P2Q1/(3*P1Q1**2*P2Q2)+ + &512*A1*MT**2*P1P2*P2Q1/(3*P1Q1**2*P2Q2)-8*P2Q1/(3*P1Q1*P2Q2)- + &200*A1*MB*MT*P2Q1/(3*P1Q1*P2Q2)-56*A2*MB*MT*P2Q1/(3*P1Q1*P2Q2)+ + &272*A1*MT**2*P2Q1/(3*P1Q1*P2Q2)+160*A2*MT**2*P2Q1/(3*P1Q1*P2Q2)+ + &256*A1*P1P2*P2Q1/(3*P1Q1*P2Q2)+48*A2*P1P2*P2Q1/(P1Q1*P2Q2)- + &256*A1*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2)- + &256*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q1*P2Q2)- + &1024*A1*A2*P1P2**2*P2Q1/(3*P1Q1*P2Q2)- + &544*A1*A2*P1Q1*P2Q1/(3*P2Q2)-640*A2**2*P1Q1*P2Q1/(3*P2Q2)- + &32*A1*P1P2*P2Q1/(3*P1Q2*P2Q2) + V18=V18+32*A1*A2*MB*MT*P1P2*P2Q1/(3*P1Q2*P2Q2)+ + &32*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q2*P2Q2)+ + &64*A1*A2*P1P2**2*P2Q1/(3*P1Q2*P2Q2)- + &32*A1*MT**2*P1P2*P2Q1/(3*P1Q1*P1Q2*P2Q2)+ + &64*A1*A2*P1P2*P1Q1*P2Q1/(3*P1Q2*P2Q2)- + &944*A1*A2*P1Q2*P2Q1/(3*P2Q2)-32*A2**2*P1Q2*P2Q1/P2Q2+ + &256*A1*MT**2*P1Q2*P2Q1/(3*P1Q1**2*P2Q2)+ + &96*A1*P1Q2*P2Q1/(P1Q1*P2Q2)+96*A2*P1Q2*P2Q1/(P1Q1*P2Q2)- + &128*A1*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)- + &256*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2)- + &128*A1*A2*MT**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)- + &512*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2)- + &512*A1*A2*P1Q2**2*P2Q1/(3*P1Q1*P2Q2)+544*A1*A2*P2Q1**2/(3*P2Q2)- + &256*A1*MT**2*P2Q1**2/(3*P1Q1**2*P2Q2)- + &272*A1*P2Q1**2/(3*P1Q1*P2Q2)+ + &256*A1*A2*MB*MT*P2Q1**2/(3*P1Q1*P2Q2)+ + &256*A1*A2*MT**2*P2Q1**2/(3*P1Q1*P2Q2) + V18=V18+512*A1*A2*P1P2*P2Q1**2/(3*P1Q1*P2Q2)+ + &512*A1*A2*P1Q2*P2Q1**2/(3*P1Q1*P2Q2)+224*A12*P2Q2+ + &656*A1*A2*P2Q2/3+256*A12*MT**4*P2Q2/(3*P1Q1**2)+ + &16*A1*P2Q2/(3*P1Q1)+112*A1*A2*MB*MT*P2Q2/(3*P1Q1)+ + &32*A12*MT**2*P2Q2/(3*P1Q1)+64*A1*A2*MT**2*P2Q2/P1Q1+ + &368*A1*A2*P1P2*P2Q2/(3*P1Q1)-256*A1*MT**2*P2Q2/(3*P1Q2**2)+ + &256*A12*MT**4*P2Q2/(3*P1Q2**2)-256*A1*P2Q2/(3*P1Q2)+ + &224*A1*A2*MB*MT*P2Q2/(3*P1Q2)-368*A12*MT**2*P2Q2/(3*P1Q2)+ + &448*A1*A2*MT**2*P2Q2/(3*P1Q2)+304*A1*A2*P1P2*P2Q2/(3*P1Q2)+ + &16*A1*MT**2*P2Q2/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q2/(3*P1Q1*P1Q2)+ + &32*A12*P1Q1*P2Q2/P1Q2+944*A1*A2*P1Q1*P2Q2/(3*P1Q2)+ + &256*A12*MT**2*P1Q2*P2Q2/(3*P1Q1**2)+ + &640*A12*P1Q2*P2Q2/(3*P1Q1)+544*A1*A2*P1Q2*P2Q2/(3*P1Q1)- + &256*A2*MB**2*P2Q2/(3*P2Q1**2)-256*A2**2*MB**3*MT*P2Q2/(3*P2Q1**2)+ + &64*MB**2*MT**2*P2Q2/(3*P1Q2**2*P2Q1**2)+ + &64*MB**2*P2Q2/(3*P1Q2*P2Q1**2)- + &128*A2*MB**3*MT*P2Q2/(3*P1Q2*P2Q1**2) + V18=V18-128*A2*MB**2*MT**2*P2Q2/(3*P1Q2*P2Q1**2)- + &256*A2*MB**2*P1P2*P2Q2/(3*P1Q2*P2Q1**2)- + &256*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1**2)+ + &256*A2**2*MB**2*P1Q2*P2Q2/(3*P2Q1**2)+272*A1*P2Q2/(3*P2Q1)+ + &112*A2*P2Q2/P2Q1-80*A1*A2*MB**2*P2Q2/P2Q1- + &400*A1*A2*MB*MT*P2Q2/(3*P2Q1)+208*A2**2*MB*MT*P2Q2/(3*P2Q1)- + &272*A1*A2*MT**2*P2Q2/(3*P2Q1)-320*A1*A2*P1P2*P2Q2/P2Q1+ + &96*A2**2*P1P2*P2Q2/P2Q1-32*A1*P1P2*P2Q2/(3*P1Q1*P2Q1)+ + &32*A1*A2*MB*MT*P1P2*P2Q2/(3*P1Q1*P2Q1)+ + &32*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q1*P2Q1)+ + &64*A1*A2*P1P2**2*P2Q2/(3*P1Q1*P2Q1)-944*A1*A2*P1Q1*P2Q2/(3*P2Q1)- + &32*A2**2*P1Q1*P2Q2/P2Q1+256*A1*MB*MT**3*P2Q2/(3*P1Q2**2*P2Q1)+ + &512*A1*MT**2*P1P2*P2Q2/(3*P1Q2**2*P2Q1)+ + &256*A1*MT**2*P1Q1*P2Q2/(3*P1Q2**2*P2Q1)-8*P2Q2/(3*P1Q2*P2Q1)- + &200*A1*MB*MT*P2Q2/(3*P1Q2*P2Q1)-56*A2*MB*MT*P2Q2/(3*P1Q2*P2Q1)+ + &272*A1*MT**2*P2Q2/(3*P1Q2*P2Q1)+160*A2*MT**2*P2Q2/(3*P1Q2*P2Q1)+ + &256*A1*P1P2*P2Q2/(3*P1Q2*P2Q1)+48*A2*P1P2*P2Q2/(P1Q2*P2Q1) + V18=V18-256*A1*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1)- + &256*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q2*P2Q1)- + &1024*A1*A2*P1P2**2*P2Q2/(3*P1Q2*P2Q1)- + &32*A1*MT**2*P1P2*P2Q2/(3*P1Q1*P1Q2*P2Q1)+ + &96*A1*P1Q1*P2Q2/(P1Q2*P2Q1)+96*A2*P1Q1*P2Q2/(P1Q2*P2Q1)- + &128*A1*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)- + &256*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1)- + &128*A1*A2*MT**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)- + &512*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1)- + &512*A1*A2*P1Q1**2*P2Q2/(3*P1Q2*P2Q1)-544*A1*A2*P1Q2*P2Q2/(3*P2Q1)- + &640*A2**2*P1Q2*P2Q2/(3*P2Q1)+ + &64*A1*A2*P1P2*P1Q2*P2Q2/(3*P1Q1*P2Q1)+544*A1*A2*P2Q2**2/(3*P2Q1)- + &256*A1*MT**2*P2Q2**2/(3*P1Q2**2*P2Q1)- + &272*A1*P2Q2**2/(3*P1Q2*P2Q1)+ + &256*A1*A2*MB*MT*P2Q2**2/(3*P1Q2*P2Q1)+ + &256*A1*A2*MT**2*P2Q2**2/(3*P1Q2*P2Q1)+ + &512*A1*A2*P1P2*P2Q2**2/(3*P1Q2*P2Q1) + V18=V18+512*A1*A2*P1Q1*P2Q2**2/(3*P1Q2*P2Q1)+ + &384*A12*MB*MT*P1Q1**2/S**2+ + &384*A12*P1P2*P1Q1**2/S**2+2688*A12*MB*MT*P1Q1*P1Q2/S**2+ + &2688*A12*P1P2*P1Q1*P1Q2/S**2+384*A12*MB*MT*P1Q2**2/S**2+ + &384*A12*P1P2*P1Q2**2/S**2+768*A1*A2*MB*MT*P1Q1*P2Q1/S**2+ + &768*A1*A2*P1P2*P1Q1*P2Q1/S**2+2688*A1*A2*MB*MT*P1Q2*P2Q1/S**2+ + &2688*A1*A2*P1P2*P1Q2*P2Q1/S**2-960*A12*P1Q1*P1Q2*P2Q1/S**2- + &960*A1*A2*P1Q1*P1Q2*P2Q1/S**2+960*A12*P1Q2**2*P2Q1/S**2+ + &960*A1*A2*P1Q2**2*P2Q1/S**2+384*A2**2*MB*MT*P2Q1**2/S**2+ + &384*A2**2*P1P2*P2Q1**2/S**2-960*A1*A2*P1Q2*P2Q1**2/S**2- + &960*A2**2*P1Q2*P2Q1**2/S**2+2688*A1*A2*MB*MT*P1Q1*P2Q2/S**2+ + &2688*A1*A2*P1P2*P1Q1*P2Q2/S**2+960*A12*P1Q1**2*P2Q2/S**2+ + &960*A1*A2*P1Q1**2*P2Q2/S**2+768*A1*A2*MB*MT*P1Q2*P2Q2/S**2+ + &768*A1*A2*P1P2*P1Q2*P2Q2/S**2-960*A12*P1Q1*P1Q2*P2Q2/S**2- + &960*A1*A2*P1Q1*P1Q2*P2Q2/S**2+2688*A2**2*MB*MT*P2Q1*P2Q2/S**2+ + &2688*A2**2*P1P2*P2Q1*P2Q2/S**2+960*A1*A2*P1Q1*P2Q1*P2Q2/S**2+ + &960*A2**2*P1Q1*P2Q1*P2Q2/S**2+960*A1*A2*P1Q2*P2Q1*P2Q2/S**2+ + &960*A2**2*P1Q2*P2Q1*P2Q2/S**2+384*A2**2*MB*MT*P2Q2**2/S**2 + V18=V18+384*A2**2*P1P2*P2Q2**2/S**2-960*A1*A2*P1Q1*P2Q2**2/S**2- + &960*A2**2*P1Q1*P2Q2**2/S**2+96*A1*MB*MT/S+96*A2*MB*MT/S- + &768*A2**2*MB**3*MT/S-768*A12*MB*MT**3/S-192*A1*P1P2/S- + &192*A2*P1P2/S-768*A2**2*MB**2*P1P2/S-2304*A1*A2*MB*MT*P1P2/S- + &768*A12*MT**2*P1P2/S-2304*A1*A2*P1P2**2/S- + &96*A1*MB*MT**3/(P1Q1*S)-192*A2*MB*MT*P1P2/(P1Q1*S)- + &96*A1*MT**2*P1P2/(P1Q1*S)-192*A2*P1P2**2/(P1Q1*S)-192*A1*P1Q1/S- + &144*A2*P1Q1/S-384*A1*A2*MB**2*P1Q1/S-480*A2**2*MB**2*P1Q1/S- + &480*A12*MB*MT*P1Q1/S+96*A1*A2*MB*MT*P1Q1/S- + &864*A12*P1P2*P1Q1/S-672*A1*A2*P1P2*P1Q1/S-96*A1*A2*P1Q1**2/S- + &96*A1*MB*MT**3/(P1Q2*S)-192*A2*MB*MT*P1P2/(P1Q2*S)- + &96*A1*MT**2*P1P2/(P1Q2*S)-192*A2*P1P2**2/(P1Q2*S)- + &48*A1*MB*MT*P1Q1/(P1Q2*S)+96*A2*MB*MT*P1Q1/(P1Q2*S)- + &48*A1*MT**2*P1Q1/(P1Q2*S)-192*A1*P1P2*P1Q1/(P1Q2*S)- + &192*A2*P1P2*P1Q1/(P1Q2*S)+192*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*S)+ + &192*A1*A2*P1P2**2*P1Q1/(P1Q2*S)-192*A1*P1Q1**2/(P1Q2*S)- + &192*A2*P1Q1**2/(P1Q2*S)+192*A1*A2*MB**2*P1Q1**2/(P1Q2*S) + V18=V18-192*A12*MB*MT*P1Q1**2/(P1Q2*S)+ + &96*A1*A2*MB*MT*P1Q1**2/(P1Q2*S)+ + &192*A1*A2*P1P2*P1Q1**2/(P1Q2*S)-192*A1*P1Q2/S-144*A2*P1Q2/S- + &384*A1*A2*MB**2*P1Q2/S-480*A2**2*MB**2*P1Q2/S- + &480*A12*MB*MT*P1Q2/S+96*A1*A2*MB*MT*P1Q2/S- + &864*A12*P1P2*P1Q2/S-672*A1*A2*P1P2*P1Q2/S- + &48*A1*MB*MT*P1Q2/(P1Q1*S)+96*A2*MB*MT*P1Q2/(P1Q1*S)- + &48*A1*MT**2*P1Q2/(P1Q1*S)-192*A1*P1P2*P1Q2/(P1Q1*S)- + &192*A2*P1P2*P1Q2/(P1Q1*S)+192*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*S)+ + &192*A1*A2*P1P2**2*P1Q2/(P1Q1*S)-576*A1*A2*P1Q1*P1Q2/S- + &96*A1*A2*P1Q2**2/S-192*A1*P1Q2**2/(P1Q1*S)- + &192*A2*P1Q2**2/(P1Q1*S)+192*A1*A2*MB**2*P1Q2**2/(P1Q1*S)- + &192*A12*MB*MT*P1Q2**2/(P1Q1*S)+96*A1*A2*MB*MT*P1Q2**2/(P1Q1*S)+ + &192*A1*A2*P1P2*P1Q2**2/(P1Q1*S)+96*A2*MB**3*MT/(P2Q1*S)+ + &96*A2*MB**2*P1P2/(P2Q1*S)+192*A1*MB*MT*P1P2/(P2Q1*S)+ + &192*A1*P1P2**2/(P2Q1*S)+96*A1*MB**2*P1Q1/(P2Q1*S)+ + &192*A2*MB**2*P1Q1/(P2Q1*S)+96*A1*MB*MT*P1Q1/(P2Q1*S)+ + &192*A1*A2*MB**3*MT*P1Q1/(P2Q1*S)+192*A1*P1P2*P1Q1/(P2Q1*S) + V18=V18+192*A1*A2*MB**2*P1P2*P1Q1/(P2Q1*S)+ + &96*A1*A2*MB**2*P1Q1**2/(P2Q1*S)+ + &192*A2*MB**3*MT*P1Q1/(P1Q2*P2Q1*S)+ + &192*A2*MB**2*P1P2*P1Q1/(P1Q2*P2Q1*S)+ + &96*A1*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1*S)+ + &96*A1*P1P2**2*P1Q1/(P1Q2*P2Q1*S)+ + &96*A1*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+ + &192*A2*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+ + &48*A1*MB*MT*P1Q1**2/(P1Q2*P2Q1*S)+ + &96*A1*P1P2*P1Q1**2/(P1Q2*P2Q1*S)+96*A1*MB**2*P1Q2/(P2Q1*S)+ + &48*A2*MB**2*P1Q2/(P2Q1*S)-192*A1*A2*MB**3*MT*P1Q2/(P2Q1*S)- + &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q1*S)- + &96*A1*A2*MB**2*P1Q2**2/(P2Q1*S)+144*A1*P2Q1/S+192*A2*P2Q1/S- + &96*A1*A2*MB*MT*P2Q1/S+480*A2**2*MB*MT*P2Q1/S+ + &480*A12*MT**2*P2Q1/S+384*A1*A2*MT**2*P2Q1/S+ + &672*A1*A2*P1P2*P2Q1/S+864*A2**2*P1P2*P2Q1/S+ + &96*A2*MB*MT*P2Q1/(P1Q1*S)+192*A1*MT**2*P2Q1/(P1Q1*S) + V18=V18+96*A2*MT**2*P2Q1/(P1Q1*S)+ + &192*A1*A2*MB*MT**3*P2Q1/(P1Q1*S)+ + &192*A2*P1P2*P2Q1/(P1Q1*S)+192*A1*A2*MT**2*P1P2*P2Q1/(P1Q1*S)- + &192*A12*P1Q1*P2Q1/S-192*A2**2*P1Q1*P2Q1/S+ + &48*A1*MT**2*P2Q1/(P1Q2*S)+96*A2*MT**2*P2Q1/(P1Q2*S)- + &192*A1*A2*MB*MT**3*P2Q1/(P1Q2*S)- + &192*A1*A2*MT**2*P1P2*P2Q1/(P1Q2*S)- + &96*A1*A2*MB*MT*P1Q1*P2Q1/(P1Q2*S)- + &192*A12*MT**2*P1Q1*P2Q1/(P1Q2*S)- + &96*A1*A2*MT**2*P1Q1*P2Q1/(P1Q2*S)- + &384*A1*A2*P1P2*P1Q1*P2Q1/(P1Q2*S)-384*A12*P1Q1**2*P2Q1/(P1Q2*S)- + &384*A1*A2*P1Q1**2*P2Q1/(P1Q2*S)-480*A12*P1Q2*P2Q1/S- + &960*A1*A2*P1Q2*P2Q1/S-480*A2**2*P1Q2*P2Q1/S+ + &144*A1*P1Q2*P2Q1/(P1Q1*S)+96*A2*P1Q2*P2Q1/(P1Q1*S)- + &384*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*S)- + &96*A12*MT**2*P1Q2*P2Q1/(P1Q1*S)+ + &96*A1*A2*MT**2*P1Q2*P2Q1/(P1Q1*S)- + &576*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*S)-192*A12*P1Q2**2*P2Q1/(P1Q1*S) + V18=V18-384*A1*A2*P1Q2**2*P2Q1/(P1Q1*S)-96*A1*A2*P2Q1**2/S- + &96*A1*A2*MT**2*P2Q1**2/(P1Q1*S)+96*A1*A2*MT**2*P2Q1**2/(P1Q2*S)+ + &288*A1*A2*P1Q2*P2Q1**2/(P1Q1*S)+96*A2*MB**3*MT/(P2Q2*S)+ + &96*A2*MB**2*P1P2/(P2Q2*S)+192*A1*MB*MT*P1P2/(P2Q2*S)+ + &192*A1*P1P2**2/(P2Q2*S)+96*A1*MB**2*P1Q1/(P2Q2*S)+ + &48*A2*MB**2*P1Q1/(P2Q2*S)-192*A1*A2*MB**3*MT*P1Q1/(P2Q2*S)- + &192*A1*A2*MB**2*P1P2*P1Q1/(P2Q2*S)- + &96*A1*A2*MB**2*P1Q1**2/(P2Q2*S)+96*A1*MB**2*P1Q2/(P2Q2*S)+ + &192*A2*MB**2*P1Q2/(P2Q2*S)+96*A1*MB*MT*P1Q2/(P2Q2*S)+ + &192*A1*A2*MB**3*MT*P1Q2/(P2Q2*S)+192*A1*P1P2*P1Q2/(P2Q2*S)+ + &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q2*S)+ + &192*A2*MB**3*MT*P1Q2/(P1Q1*P2Q2*S)+ + &192*A2*MB**2*P1P2*P1Q2/(P1Q1*P2Q2*S)+ + &96*A1*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2*S)+ + &96*A1*P1P2**2*P1Q2/(P1Q1*P2Q2*S)+96*A1*A2*MB**2*P1Q2**2/(P2Q2*S)+ + &96*A1*MB**2*P1Q2**2/(P1Q1*P2Q2*S)+ + &192*A2*MB**2*P1Q2**2/(P1Q1*P2Q2*S) + V18=V18+48*A1*MB*MT*P1Q2**2/(P1Q1*P2Q2*S)+ + &96*A1*P1P2*P1Q2**2/(P1Q1*P2Q2*S)-48*A2*MB**2*P2Q1/(P2Q2*S)+ + &96*A1*MB*MT*P2Q1/(P2Q2*S)-48*A2*MB*MT*P2Q1/(P2Q2*S)- + &192*A1*P1P2*P2Q1/(P2Q2*S)-192*A2*P1P2*P2Q1/(P2Q2*S)+ + &192*A1*A2*MB*MT*P1P2*P2Q1/(P2Q2*S)+ + &192*A1*A2*P1P2**2*P2Q1/(P2Q2*S)- + &192*A1*MB*MT**3*P2Q1/(P1Q1*P2Q2*S)- + &96*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2*S)- + &192*A1*MT**2*P1P2*P2Q1/(P1Q1*P2Q2*S)- + &96*A2*P1P2**2*P2Q1/(P1Q1*P2Q2*S)+ + &96*A1*A2*MB**2*P1Q1*P2Q1/(P2Q2*S)+ + &192*A2**2*MB**2*P1Q1*P2Q1/(P2Q2*S)+ + &96*A1*A2*MB*MT*P1Q1*P2Q1/(P2Q2*S)+ + &384*A1*A2*P1P2*P1Q1*P2Q1/(P2Q2*S)-96*A1*P1Q2*P2Q1/(P2Q2*S)- + &144*A2*P1Q2*P2Q1/(P2Q2*S)-96*A1*A2*MB**2*P1Q2*P2Q1/(P2Q2*S)+ + &96*A2**2*MB**2*P1Q2*P2Q1/(P2Q2*S)+ + &384*A1*A2*MB*MT*P1Q2*P2Q1/(P2Q2*S) + V18=V18+576*A1*A2*P1P2*P1Q2*P2Q1/(P2Q2*S)- + &96*A2*MB**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+ + &48*A1*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)+ + &48*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)- + &96*A1*MT**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)- + &96*A1*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)- + &96*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+ + &96*A1*A2*P1Q1*P1Q2*P2Q1/(P2Q2*S)+288*A1*A2*P1Q2**2*P2Q1/(P2Q2*S)- + &96*A1*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)-96*A2*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)+ + &192*A1*P2Q1**2/(P2Q2*S)+192*A2*P2Q1**2/(P2Q2*S)- + &96*A1*A2*MB*MT*P2Q1**2/(P2Q2*S)+192*A2**2*MB*MT*P2Q1**2/(P2Q2*S)- + &192*A1*A2*MT**2*P2Q1**2/(P2Q2*S)-192*A1*A2*P1P2*P2Q1**2/(P2Q2*S)+ + &48*A2*MB*MT*P2Q1**2/(P1Q1*P2Q2*S)+ + &192*A1*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+ + &96*A2*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+ + &96*A2*P1P2*P2Q1**2/(P1Q1*P2Q2*S)-384*A1*A2*P1Q1*P2Q1**2/(P2Q2*S)- + &384*A2**2*P1Q1*P2Q1**2/(P2Q2*S)-384*A1*A2*P1Q2*P2Q1**2/(P2Q2*S) + V18=V18-192*A2**2*P1Q2*P2Q1**2/(P2Q2*S)+ + &96*A1*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+ + &96*A2*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+144*A1*P2Q2/S+192*A2*P2Q2/S- + &96*A1*A2*MB*MT*P2Q2/S+480*A2**2*MB*MT*P2Q2/S+ + &480*A12*MT**2*P2Q2/S+384*A1*A2*MT**2*P2Q2/S+ + &672*A1*A2*P1P2*P2Q2/S+864*A2**2*P1P2*P2Q2/S+ + &48*A1*MT**2*P2Q2/(P1Q1*S)+96*A2*MT**2*P2Q2/(P1Q1*S)- + &192*A1*A2*MB*MT**3*P2Q2/(P1Q1*S)- + &192*A1*A2*MT**2*P1P2*P2Q2/(P1Q1*S)-480*A12*P1Q1*P2Q2/S- + &960*A1*A2*P1Q1*P2Q2/S-480*A2**2*P1Q1*P2Q2/S+ + &96*A2*MB*MT*P2Q2/(P1Q2*S)+192*A1*MT**2*P2Q2/(P1Q2*S)+ + &96*A2*MT**2*P2Q2/(P1Q2*S)+192*A1*A2*MB*MT**3*P2Q2/(P1Q2*S)+ + &192*A2*P1P2*P2Q2/(P1Q2*S)+192*A1*A2*MT**2*P1P2*P2Q2/(P1Q2*S)+ + &144*A1*P1Q1*P2Q2/(P1Q2*S)+96*A2*P1Q1*P2Q2/(P1Q2*S)- + &384*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*S)- + &96*A12*MT**2*P1Q1*P2Q2/(P1Q2*S)+ + &96*A1*A2*MT**2*P1Q1*P2Q2/(P1Q2*S) + V18=V18-576*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*S)- + &192*A12*P1Q1**2*P2Q2/(P1Q2*S)- + &384*A1*A2*P1Q1**2*P2Q2/(P1Q2*S)-192*A12*P1Q2*P2Q2/S- + &192*A2**2*P1Q2*P2Q2/S-96*A1*A2*MB*MT*P1Q2*P2Q2/(P1Q1*S)- + &192*A12*MT**2*P1Q2*P2Q2/(P1Q1*S)- + &96*A1*A2*MT**2*P1Q2*P2Q2/(P1Q1*S)- + &384*A1*A2*P1P2*P1Q2*P2Q2/(P1Q1*S)-384*A12*P1Q2**2*P2Q2/(P1Q1*S)- + &384*A1*A2*P1Q2**2*P2Q2/(P1Q1*S)-48*A2*MB**2*P2Q2/(P2Q1*S)+ + &96*A1*MB*MT*P2Q2/(P2Q1*S)-48*A2*MB*MT*P2Q2/(P2Q1*S)- + &192*A1*P1P2*P2Q2/(P2Q1*S)-192*A2*P1P2*P2Q2/(P2Q1*S)+ + &192*A1*A2*MB*MT*P1P2*P2Q2/(P2Q1*S)+ + &192*A1*A2*P1P2**2*P2Q2/(P2Q1*S)-96*A1*P1Q1*P2Q2/(P2Q1*S)- + &144*A2*P1Q1*P2Q2/(P2Q1*S)-96*A1*A2*MB**2*P1Q1*P2Q2/(P2Q1*S)+ + &96*A2**2*MB**2*P1Q1*P2Q2/(P2Q1*S)+ + &384*A1*A2*MB*MT*P1Q1*P2Q2/(P2Q1*S)+ + &576*A1*A2*P1P2*P1Q1*P2Q2/(P2Q1*S)+288*A1*A2*P1Q1**2*P2Q2/(P2Q1*S)- + &192*A1*MB*MT**3*P2Q2/(P1Q2*P2Q1*S) + V18=V18-96*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1*S)- + &192*A1*MT**2*P1P2*P2Q2/(P1Q2*P2Q1*S)- + &96*A2*P1P2**2*P2Q2/(P1Q2*P2Q1*S)- + &96*A2*MB**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)+ + &48*A1*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S) + + V18BIS= + &48*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)- + &96*A1*MT**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)- + &96*A1*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)- + &96*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)- + &96*A1*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)-96*A2*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)+ + &96*A1*A2*MB**2*P1Q2*P2Q2/(P2Q1*S)+ + &192*A2**2*MB**2*P1Q2*P2Q2/(P2Q1*S)+ + &96*A1*A2*MB*MT*P1Q2*P2Q2/(P2Q1*S)+ + &384*A1*A2*P1P2*P1Q2*P2Q2/(P2Q1*S)+ + &96*A1*A2*P1Q1*P1Q2*P2Q2/(P2Q1*S)-576*A1*A2*P2Q1*P2Q2/S+ + &96*A1*A2*P1Q1*P2Q1*P2Q2/(P1Q2*S)+96*A1*A2*P1Q2*P2Q1*P2Q2/(P1Q1*S)- + &96*A1*A2*P2Q2**2/S+96*A1*A2*MT**2*P2Q2**2/(P1Q1*S)- + &96*A1*A2*MT**2*P2Q2**2/(P1Q2*S)+288*A1*A2*P1Q1*P2Q2**2/(P1Q2*S)+ + &192*A1*P2Q2**2/(P2Q1*S)+192*A2*P2Q2**2/(P2Q1*S)- + &96*A1*A2*MB*MT*P2Q2**2/(P2Q1*S)+192*A2**2*MB*MT*P2Q2**2/(P2Q1*S)- + &192*A1*A2*MT**2*P2Q2**2/(P2Q1*S)-192*A1*A2*P1P2*P2Q2**2/(P2Q1*S) + V18BIS=V18BIS-384*A1*A2*P1Q1*P2Q2**2/(P2Q1*S)- + &192*A2**2*P1Q1*P2Q2**2/(P2Q1*S)+ + &48*A2*MB*MT*P2Q2**2/(P1Q2*P2Q1*S)+ + &192*A1*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+ + &96*A2*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+ + &96*A2*P1P2*P2Q2**2/(P1Q2*P2Q1*S)+96*A1*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)+ + &96*A2*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)-384*A1*A2*P1Q2*P2Q2**2/(P2Q1*S)- + &384*A2**2*P1Q2*P2Q2**2/(P2Q1*S)+512*A1*A2*S/3- + &128*A1*MT**2*S/(3*P1Q1**2)-128*A12*MB*MT**3*S/(3*P1Q1**2)- + &152*A1*S/(3*P1Q1)+152*A12*MB*MT*S/(3*P1Q1)+ + &128*A1*A2*MB*MT*S/(3*P1Q1)+112*A1*A2*MT**2*S/(3*P1Q1)- + &16*A12*P1P2*S/P1Q1+152*A1*A2*P1P2*S/(3*P1Q1)- + &128*A1*MT**2*S/(3*P1Q2**2)-128*A12*MB*MT**3*S/(3*P1Q2**2)- + &152*A1*S/(3*P1Q2)+152*A12*MB*MT*S/(3*P1Q2)+ + &128*A1*A2*MB*MT*S/(3*P1Q2)+112*A1*A2*MT**2*S/(3*P1Q2)- + &16*A12*P1P2*S/P1Q2+152*A1*A2*P1P2*S/(3*P1Q2)- + &16*A1*MB*MT*S/(3*P1Q1*P1Q2)+32*A12*MB*MT**3*S/(3*P1Q1*P1Q2) + V18BIS=V18BIS-16*A1*P1P2*S/(3*P1Q1*P1Q2)+ + &272*A1*A2*P1Q1*S/(3*P1Q2)+ + &272*A1*A2*P1Q2*S/(3*P1Q1)-128*A2*MB**2*S/(3*P2Q1**2)- + &128*A2**2*MB**3*MT*S/(3*P2Q1**2)+ + &32*MB**2*MT**2*S/(3*P1Q2**2*P2Q1**2)+32*MB**2*S/(3*P1Q2*P2Q1**2)- + &64*A2*MB**3*MT*S/(3*P1Q2*P2Q1**2)- + &64*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1**2)- + &128*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1**2)- + &128*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1**2)+ + &128*A2**2*MB**2*P1Q2*S/(3*P2Q1**2)+152*A2*S/(3*P2Q1)- + &112*A1*A2*MB**2*S/(3*P2Q1)-128*A1*A2*MB*MT*S/(3*P2Q1)- + &152*A2**2*MB*MT*S/(3*P2Q1)-152*A1*A2*P1P2*S/(3*P2Q1)+ + &16*A2**2*P1P2*S/P2Q1+8*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q1)+ + &16*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q1)+ + &8*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q1)-8*A1*P1P2*S/(3*P1Q1*P2Q1)- + &8*A2*P1P2*S/(3*P1Q1*P2Q1)+8*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1)+ + &16*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1) + V18BIS=V18BIS+8*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q1)+ + &32*A1*A2*P1P2**2*S/(3*P1Q1*P2Q1)-32*A2**2*P1Q1*S/(3*P2Q1)- + &32*MT**2*S/(3*P1Q2**2*P2Q1)+64*A1*MB**2*MT**2*S/(3*P1Q2**2*P2Q1)+ + &64*A1*MB*MT**3*S/(3*P1Q2**2*P2Q1)+ + &128*A1*MT**2*P1P2*S/(3*P1Q2**2*P2Q1)-12*S/(P1Q2*P2Q1)+ + &24*A1*MB**2*S/(P1Q2*P2Q1)-64*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q1)+ + &24*A2*MT**2*S/(P1Q2*P2Q1)-128*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1)- + &64*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q1)+56*A1*P1P2*S/(3*P1Q2*P2Q1)+ + &56*A2*P1P2*S/(3*P1Q2*P2Q1)-64*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1)- + &128*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1)- + &64*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q1)- + &256*A1*A2*P1P2**2*S/(3*P1Q2*P2Q1)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+ + &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1)- + &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+136*A2*P1Q1*S/(3*P1Q2*P2Q1)- + &128*A1*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1)- + &128*A1*A2*MB*MT*P1Q1*S/(3*P1Q2*P2Q1)- + &256*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1)-160*A2**2*P1Q2*S/(3*P2Q1) + V18BIS=V18BIS+16*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1)- + &32*A12*P2Q1*S/(3*P1Q1)- + &128*A12*MT**2*P2Q1*S/(3*P1Q2**2)-160*A12*P2Q1*S/(3*P1Q2)- + &128*A2*MB**2*S/(3*P2Q2**2)-128*A2**2*MB**3*MT*S/(3*P2Q2**2)+ + &32*MB**2*MT**2*S/(3*P1Q1**2*P2Q2**2)+32*MB**2*S/(3*P1Q1*P2Q2**2)- + &64*A2*MB**3*MT*S/(3*P1Q1*P2Q2**2)- + &64*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2**2)- + &128*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2**2)+ + &128*A2**2*MB**2*P1Q1*S/(3*P2Q2**2)- + &128*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2**2)+152*A2*S/(3*P2Q2)- + &112*A1*A2*MB**2*S/(3*P2Q2)-128*A1*A2*MB*MT*S/(3*P2Q2)- + &152*A2**2*MB*MT*S/(3*P2Q2)-152*A1*A2*P1P2*S/(3*P2Q2)+ + &16*A2**2*P1P2*S/P2Q2-32*MT**2*S/(3*P1Q1**2*P2Q2)+ + &64*A1*MB**2*MT**2*S/(3*P1Q1**2*P2Q2)+ + &64*A1*MB*MT**3*S/(3*P1Q1**2*P2Q2)+ + &128*A1*MT**2*P1P2*S/(3*P1Q1**2*P2Q2)-12*S/(P1Q1*P2Q2)+ + &24*A1*MB**2*S/(P1Q1*P2Q2)-64*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q2) + V18BIS=V18BIS+24*A2*MT**2*S/(P1Q1*P2Q2)- + &128*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2)- + &64*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q2)+56*A1*P1P2*S/(3*P1Q1*P2Q2)+ + &56*A2*P1P2*S/(3*P1Q1*P2Q2)-64*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2)- + &128*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q2)- + &64*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q2)- + &256*A1*A2*P1P2**2*S/(3*P1Q1*P2Q2)-160*A2**2*P1Q1*S/(3*P2Q2)+ + &8*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q2)+ + &16*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q2)+ + &8*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q2)-8*A1*P1P2*S/(3*P1Q2*P2Q2)- + &8*A2*P1P2*S/(3*P1Q2*P2Q2)+8*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q2)+ + &16*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q2)+ + &8*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q2)+ + &32*A1*A2*P1P2**2*S/(3*P1Q2*P2Q2)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+ + &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q2)- + &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+ + &16*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q2)-32*A2**2*P1Q2*S/(3*P2Q2) + V18BIS=V18BIS+136*A2*P1Q2*S/(3*P1Q1*P2Q2)- + &128*A1*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2)- + &128*A1*A2*MB*MT*P1Q2*S/(3*P1Q1*P2Q2)- + &256*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q2)-16*A2*MB*MT*S/(3*P2Q1*P2Q2)+ + &32*A2**2*MB**3*MT*S/(3*P2Q1*P2Q2)-16*A2*P1P2*S/(3*P2Q1*P2Q2)- + &4*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+8*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1*P2Q2)- + &8*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1*P2Q2)-4*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+ + &8*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1*P2Q2)- + &8*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+ + &2*MB**3*MT*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+ + &4*MB**2*MT**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+ + &2*MB*MT**3*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)- + &2*MB**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)- + &4*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)- + &2*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)- + &8*P1P2**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+ + &8*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1*P2Q2) + V18BIS=V18BIS+8*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1*P2Q2)+ + &272*A1*A2*P2Q1*S/(3*P2Q2)- + &128*A1*MT**2*P2Q1*S/(3*P1Q1**2*P2Q2)-136*A1*P2Q1*S/(3*P1Q1*P2Q2)+ + &128*A1*A2*MB*MT*P2Q1*S/(3*P1Q1*P2Q2)+ + &128*A1*A2*MT**2*P2Q1*S/(3*P1Q1*P2Q2)+ + &256*A1*A2*P1P2*P2Q1*S/(3*P1Q1*P2Q2)- + &16*A1*A2*P1P2*P2Q1*S/(3*P1Q2*P2Q2)+ + &8*A1*P1P2*P2Q1*S/(3*P1Q1*P1Q2*P2Q2)+ + &256*A1*A2*P1Q2*P2Q1*S/(3*P1Q1*P2Q2)- + &128*A12*MT**2*P2Q2*S/(3*P1Q1**2)-160*A12*P2Q2*S/(3*P1Q1)- + &32*A12*P2Q2*S/(3*P1Q2)+272*A1*A2*P2Q2*S/(3*P2Q1)- + &16*A1*A2*P1P2*P2Q2*S/(3*P1Q1*P2Q1)- + &128*A1*MT**2*P2Q2*S/(3*P1Q2**2*P2Q1)-136*A1*P2Q2*S/(3*P1Q2*P2Q1)+ + &128*A1*A2*MB*MT*P2Q2*S/(3*P1Q2*P2Q1)+ + &128*A1*A2*MT**2*P2Q2*S/(3*P1Q2*P2Q1)+ + &256*A1*A2*P1P2*P2Q2*S/(3*P1Q2*P2Q1)+ + &8*A1*P1P2*P2Q2*S/(3*P1Q1*P1Q2*P2Q1) + V18BIS=V18BIS+256*A1*A2*P1Q1*P2Q2*S/(3*P1Q2*P2Q1)+ + &8*A12*MB*MT*S**2/(3*P1Q1*P1Q2)+16*A12*P1P2*S**2/(3*P1Q1*P1Q2)- + &8*A1*A2*P1P2*S**2/(3*P1Q1*P2Q1)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1)- + &8*A1*A2*P1P2*S**2/(3*P1Q2*P2Q2)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q2)+ + &8*A2**2*MB*MT*S**2/(3*P2Q1*P2Q2)+16*A2**2*P1P2*S**2/(3*P2Q1*P2Q2)- + &4*A2*P1P2*S**2/(3*P1Q1*P2Q1*P2Q2)- + &4*A2*P1P2*S**2/(3*P1Q2*P2Q1*P2Q2)+ + &2*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1*P2Q2) +C + + A18 = 640*A1/3+640*A2/3+32*A1*A2*MB**2+368*A12*MB*MT+ + &512*A1*A2*MB*MT/3+ + &368*A2**2*MB*MT+32*A1*A2*MT**2+496*A12*P1P2/3+ + &320*A1*A2*P1P2+496*A2**2*P1P2/3-128*A1*MB*MT**3/(3*P1Q1**2)+ + &128*A1*MT**4/(3*P1Q1**2)+256*A12*MB*MT**5/(3*P1Q1**2)+ + &256*A1*MT**2*P1P2/(3*P1Q1**2)-256*A12*MT**4*P1P2/(3*P1Q1**2)+ + &8/(3*P1Q1)+32*A1*MB*MT/P1Q1+56*A2*MB*MT/(3*P1Q1)+ + &88*A1*MT**2/(3*P1Q1)+72*A2*MT**2/P1Q1- + &704*A12*MB*MT**3/(3*P1Q1)+224*A1*A2*MB*MT**3/(3*P1Q1)+ + &104*A1*P1P2/(3*P1Q1)+48*A2*P1P2/P1Q1- + &128*A1*A2*MB*MT*P1P2/(3*P1Q1)+512*A12*MT**2*P1P2/(3*P1Q1)- + &448*A1*A2*MT**2*P1P2/(3*P1Q1)-32*A1*A2*P1P2**2/P1Q1- + &656*A1*A2*P1Q1/3-224*A2**2*P1Q1-128*A1*MB*MT**3/(3*P1Q2**2)+ + &128*A1*MT**4/(3*P1Q2**2)+256*A12*MB*MT**5/(3*P1Q2**2)+ + &256*A1*MT**2*P1P2/(3*P1Q2**2)-256*A12*MT**4*P1P2/(3*P1Q2**2)+ + &256*A1*MT**2*P1Q1/(3*P1Q2**2)-256*A12*MB*MT**3*P1Q1/(3*P1Q2**2)+ + &8/(3*P1Q2)+32*A1*MB*MT/P1Q2+56*A2*MB*MT/(3*P1Q2) + A18=A18+88*A1*MT**2/(3*P1Q2)+72*A2*MT**2/P1Q2- + &704*A12*MB*MT**3/(3*P1Q2)+224*A1*A2*MB*MT**3/(3*P1Q2)+ + &104*A1*P1P2/(3*P1Q2)+48*A2*P1P2/P1Q2- + &128*A1*A2*MB*MT*P1P2/(3*P1Q2)+512*A12*MT**2*P1P2/(3*P1Q2)- + &448*A1*A2*MT**2*P1P2/(3*P1Q2)-32*A1*A2*P1P2**2/P1Q2+ + &32*A1*MB*MT**3/(3*P1Q1*P1Q2)-32*A1*MT**4/(3*P1Q1*P1Q2)- + &64*A12*MB*MT**5/(3*P1Q1*P1Q2)+16*P1P2/(3*P1Q1*P1Q2)- + &64*A1*MT**2*P1P2/(3*P1Q1*P1Q2)+64*A12*MT**4*P1P2/(3*P1Q1*P1Q2)+ + &112*A1*P1Q1/P1Q2+272*A2*P1Q1/(3*P1Q2)- + &272*A1*A2*MB**2*P1Q1/(3*P1Q2)-208*A12*MB*MT*P1Q1/(3*P1Q2)+ + &400*A1*A2*MB*MT*P1Q1/(3*P1Q2)-80*A1*A2*MT**2*P1Q1/P1Q2+ + &96*A12*P1P2*P1Q1/P1Q2-320*A1*A2*P1P2*P1Q1/P1Q2- + &544*A1*A2*P1Q1**2/(3*P1Q2)-656*A1*A2*P1Q2/3-224*A2**2*P1Q2+ + &256*A1*MT**2*P1Q2/(3*P1Q1**2)-256*A12*MB*MT**3*P1Q2/(3*P1Q1**2)+ + &112*A1*P1Q2/P1Q1+272*A2*P1Q2/(3*P1Q1)- + &272*A1*A2*MB**2*P1Q2/(3*P1Q1)-208*A12*MB*MT*P1Q2/(3*P1Q1)+ + &400*A1*A2*MB*MT*P1Q2/(3*P1Q1)-80*A1*A2*MT**2*P1Q2/P1Q1 + A18=A18+96*A12*P1P2*P1Q2/P1Q1-320*A1*A2*P1P2*P1Q2/P1Q1- + &544*A1*A2*P1Q2**2/(3*P1Q1)+128*A2*MB**4/(3*P2Q1**2)- + &128*A2*MB**3*MT/(3*P2Q1**2)+256*A2**2*MB**5*MT/(3*P2Q1**2)+ + &256*A2*MB**2*P1P2/(3*P2Q1**2)-256*A2**2*MB**4*P1P2/(3*P2Q1**2)+ + &256*A2*MB**2*P1Q1/(3*P2Q1**2)-256*A2**2*MB**4*P1Q1/(3*P2Q1**2)+ + &64*MB**3*MT**3/(3*P1Q2**2*P2Q1**2)- + &64*MB**2*MT**2*P1P2/(3*P1Q2**2*P2Q1**2)- + &64*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1**2)- + &64*MB**3*MT/(3*P1Q2*P2Q1**2)- + &256*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1**2)+ + &256*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1**2)- + &256*A2*MB**3*MT*P1Q1/(3*P1Q2*P2Q1**2)+ + &512*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1**2)+ + &256*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1**2)- + &256*A2**2*MB**4*P1Q2/(3*P2Q1**2)-8/(3*P2Q1)-72*A1*MB**2/P2Q1- + &88*A2*MB**2/(3*P2Q1)-56*A1*MB*MT/(3*P2Q1)-32*A2*MB*MT/P2Q1- + &224*A1*A2*MB**3*MT/(3*P2Q1)+704*A2**2*MB**3*MT/(3*P2Q1) + A18=A18-48*A1*P1P2/P2Q1-104*A2*P1P2/(3*P2Q1)+ + &448*A1*A2*MB**2*P1P2/(3*P2Q1)-512*A2**2*MB**2*P1P2/(3*P2Q1)+ + &128*A1*A2*MB*MT*P1P2/(3*P2Q1)+32*A1*A2*P1P2**2/P2Q1- + &16*P1P2/(3*P1Q1*P2Q1)+32*A1*MB*MT*P1P2/(3*P1Q1*P2Q1)+ + &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q1)+ + &64*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q1)- + &64*A1*A2*P1P2**3/(3*P1Q1*P2Q1)-256*A2*P1Q1/(3*P2Q1)+ + &448*A1*A2*MB**2*P1Q1/(3*P2Q1)-368*A2**2*MB**2*P1Q1/(3*P2Q1)- + &224*A1*A2*MB*MT*P1Q1/(3*P2Q1)+304*A1*A2*P1P2*P1Q1/(3*P2Q1)+ + &64*MB*MT**3/(3*P1Q2**2*P2Q1)+ + &256*A1*MB*MT**3*P1P2/(3*P1Q2**2*P2Q1)- + &256*A1*MT**2*P1P2**2/(3*P1Q2**2*P2Q1)+ + &64*MT**2*P1Q1/(3*P1Q2**2*P2Q1)- + &128*A1*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1)+ + &128*A1*MB*MT**3*P1Q1/(3*P1Q2**2*P2Q1)- + &256*A1*MT**2*P1P2*P1Q1/(3*P1Q2**2*P2Q1)-4*MB**2/(3*P1Q2*P2Q1)- + &64*MB*MT/(3*P1Q2*P2Q1)+128*A2*MB**3*MT/(3*P1Q2*P2Q1) + A18=A18-4*MT**2/(3*P1Q2*P2Q1)-128*A1*MB**2*MT**2/(3*P1Q2*P2Q1)- + &128*A2*MB**2*MT**2/(3*P1Q2*P2Q1)+128*A1*MB*MT**3/(3*P1Q2*P2Q1)- + &112*A2*MB**2*P1P2/(3*P1Q2*P2Q1)+32*A1*MB*MT*P1P2/(3*P1Q2*P2Q1)+ + &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q1)-112*A1*MT**2*P1P2/(3*P1Q2*P2Q1)- + &48*A1*P1P2**2/(P1Q2*P2Q1)-48*A2*P1P2**2/(P1Q2*P2Q1)- + &512*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q1)+ + &512*A1*A2*P1P2**3/(3*P1Q2*P2Q1)+8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q1)- + &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q1)- + &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q1)- + &16*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+ + &32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+8*P1Q1/(3*P1Q2*P2Q1)- + &160*A1*MB**2*P1Q1/(3*P1Q2*P2Q1)-272*A2*MB**2*P1Q1/(3*P1Q2*P2Q1)- + &56*A1*MB*MT*P1Q1/(3*P1Q2*P2Q1)-200*A2*MB*MT*P1Q1/(3*P1Q2*P2Q1)- + &48*A1*P1P2*P1Q1/(P1Q2*P2Q1)-256*A2*P1P2*P1Q1/(3*P1Q2*P2Q1)+ + &256*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1)- + &256*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1)+ + &1024*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q1) + A18=A18-272*A2*P1Q1**2/(3*P1Q2*P2Q1)+ + &256*A1*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1)- + &256*A1*A2*MB*MT*P1Q1**2/(3*P1Q2*P2Q1)+ + &512*A1*A2*P1P2*P1Q1**2/(3*P1Q2*P2Q1)+16*A2*P1Q2/(3*P2Q1)+ + &64*A1*A2*MB**2*P1Q2/P2Q1+32*A2**2*MB**2*P1Q2/(3*P2Q1)- + &112*A1*A2*MB*MT*P1Q2/(3*P2Q1)+368*A1*A2*P1P2*P1Q2/(3*P2Q1)+ + &32*A2*P1P2*P1Q2/(3*P1Q1*P2Q1)- + &32*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1)+ + &32*A1*A2*MB*MT*P1P2*P1Q2/(3*P1Q1*P2Q1)- + &64*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q1)+224*A12*P2Q1+ + &656*A1*A2*P2Q1/3-256*A1*MT**2*P2Q1/(3*P1Q1**2)+ + &256*A12*MT**4*P2Q1/(3*P1Q1**2)-256*A1*P2Q1/(3*P1Q1)- + &224*A1*A2*MB*MT*P2Q1/(3*P1Q1)-368*A12*MT**2*P2Q1/(3*P1Q1)+ + &448*A1*A2*MT**2*P2Q1/(3*P1Q1)+304*A1*A2*P1P2*P2Q1/(3*P1Q1)+ + &256*A12*MT**4*P2Q1/(3*P1Q2**2)+ + &256*A12*MT**2*P1Q1*P2Q1/(3*P1Q2**2)+16*A1*P2Q1/(3*P1Q2)- + &112*A1*A2*MB*MT*P2Q1/(3*P1Q2)+32*A12*MT**2*P2Q1/(3*P1Q2) + A18=A18+64*A1*A2*MT**2*P2Q1/P1Q2+368*A1*A2*P1P2*P2Q1/(3*P1Q2)+ + &16*A1*MT**2*P2Q1/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q1/(3*P1Q1*P1Q2)+ + &640*A12*P1Q1*P2Q1/(3*P1Q2)+544*A1*A2*P1Q1*P2Q1/(3*P1Q2)+ + &32*A12*P1Q2*P2Q1/P1Q1+944*A1*A2*P1Q2*P2Q1/(3*P1Q1)+ + &128*A2*MB**4/(3*P2Q2**2)-128*A2*MB**3*MT/(3*P2Q2**2)+ + &256*A2**2*MB**5*MT/(3*P2Q2**2)+256*A2*MB**2*P1P2/(3*P2Q2**2)- + &256*A2**2*MB**4*P1P2/(3*P2Q2**2)+ + &64*MB**3*MT**3/(3*P1Q1**2*P2Q2**2)- + &64*MB**2*MT**2*P1P2/(3*P1Q1**2*P2Q2**2)- + &64*MB**3*MT/(3*P1Q1*P2Q2**2)- + &256*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q2**2)+ + &256*A2*MB**2*P1P2**2/(3*P1Q1*P2Q2**2)- + &256*A2**2*MB**4*P1Q1/(3*P2Q2**2)+256*A2*MB**2*P1Q2/(3*P2Q2**2)- + &256*A2**2*MB**4*P1Q2/(3*P2Q2**2)- + &64*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2**2)- + &256*A2*MB**3*MT*P1Q2/(3*P1Q1*P2Q2**2)+ + &512*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2**2) + A18=A18+256*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2**2)- + &256*A2*MB**2*P2Q1/(3*P2Q2**2)+256*A2**2*MB**3*MT*P2Q1/(3*P2Q2**2)+ + &64*MB**2*MT**2*P2Q1/(3*P1Q1**2*P2Q2**2)+ + &64*MB**2*P2Q1/(3*P1Q1*P2Q2**2)+ + &128*A2*MB**3*MT*P2Q1/(3*P1Q1*P2Q2**2)- + &128*A2*MB**2*MT**2*P2Q1/(3*P1Q1*P2Q2**2)- + &256*A2*MB**2*P1P2*P2Q1/(3*P1Q1*P2Q2**2)+ + &256*A2**2*MB**2*P1Q1*P2Q1/(3*P2Q2**2)- + &256*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2**2)-8/(3*P2Q2)- + &72*A1*MB**2/P2Q2-88*A2*MB**2/(3*P2Q2)-56*A1*MB*MT/(3*P2Q2)- + &32*A2*MB*MT/P2Q2-224*A1*A2*MB**3*MT/(3*P2Q2)+ + &704*A2**2*MB**3*MT/(3*P2Q2)-48*A1*P1P2/P2Q2- + &104*A2*P1P2/(3*P2Q2)+448*A1*A2*MB**2*P1P2/(3*P2Q2)- + &512*A2**2*MB**2*P1P2/(3*P2Q2)+128*A1*A2*MB*MT*P1P2/(3*P2Q2)+ + &32*A1*A2*P1P2**2/P2Q2+64*MB*MT**3/(3*P1Q1**2*P2Q2)+ + &256*A1*MB*MT**3*P1P2/(3*P1Q1**2*P2Q2)- + &256*A1*MT**2*P1P2**2/(3*P1Q1**2*P2Q2)-4*MB**2/(3*P1Q1*P2Q2) + A18=A18-64*MB*MT/(3*P1Q1*P2Q2)+128*A2*MB**3*MT/(3*P1Q1*P2Q2)- + &4*MT**2/(3*P1Q1*P2Q2)-128*A1*MB**2*MT**2/(3*P1Q1*P2Q2)- + &128*A2*MB**2*MT**2/(3*P1Q1*P2Q2)+128*A1*MB*MT**3/(3*P1Q1*P2Q2)- + &112*A2*MB**2*P1P2/(3*P1Q1*P2Q2)+32*A1*MB*MT*P1P2/(3*P1Q1*P2Q2)+ + &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q2)-112*A1*MT**2*P1P2/(3*P1Q1*P2Q2)- + &48*A1*P1P2**2/(P1Q1*P2Q2)-48*A2*P1P2**2/(P1Q1*P2Q2)- + &512*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q2)+ + &512*A1*A2*P1P2**3/(3*P1Q1*P2Q2)+16*A2*P1Q1/(3*P2Q2)+ + &64*A1*A2*MB**2*P1Q1/P2Q2+32*A2**2*MB**2*P1Q1/(3*P2Q2)- + &112*A1*A2*MB*MT*P1Q1/(3*P2Q2)+368*A1*A2*P1P2*P1Q1/(3*P2Q2)- + &16*P1P2/(3*P1Q2*P2Q2)+32*A1*MB*MT*P1P2/(3*P1Q2*P2Q2)+ + &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q2)+ + &64*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q2)- + &64*A1*A2*P1P2**3/(3*P1Q2*P2Q2)+8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q2)- + &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q2)- + &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q2)- + &16*P1P2**2/(3*P1Q1*P1Q2*P2Q2) + A18=A18+32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q2)+ + &32*A2*P1P2*P1Q1/(3*P1Q2*P2Q2)- + &32*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q2)+ + &32*A1*A2*MB*MT*P1P2*P1Q1/(3*P1Q2*P2Q2)- + &64*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q2)-256*A2*P1Q2/(3*P2Q2)+ + &448*A1*A2*MB**2*P1Q2/(3*P2Q2)-368*A2**2*MB**2*P1Q2/(3*P2Q2)- + &224*A1*A2*MB*MT*P1Q2/(3*P2Q2)+304*A1*A2*P1P2*P1Q2/(3*P2Q2)+ + &64*MT**2*P1Q2/(3*P1Q1**2*P2Q2)- + &128*A1*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2)+ + &128*A1*MB*MT**3*P1Q2/(3*P1Q1**2*P2Q2)- + &256*A1*MT**2*P1P2*P1Q2/(3*P1Q1**2*P2Q2)+8*P1Q2/(3*P1Q1*P2Q2)- + &160*A1*MB**2*P1Q2/(3*P1Q1*P2Q2)-272*A2*MB**2*P1Q2/(3*P1Q1*P2Q2)- + &56*A1*MB*MT*P1Q2/(3*P1Q1*P2Q2)-200*A2*MB*MT*P1Q2/(3*P1Q1*P2Q2)- + &48*A1*P1P2*P1Q2/(P1Q1*P2Q2)-256*A2*P1P2*P1Q2/(3*P1Q1*P2Q2)+ + &256*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2)- + &256*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2)+ + &1024*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q2) + A18=A18-272*A2*P1Q2**2/(3*P1Q1*P2Q2)+ + &256*A1*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2)- + &256*A1*A2*MB*MT*P1Q2**2/(3*P1Q1*P2Q2)+ + &512*A1*A2*P1P2*P1Q2**2/(3*P1Q1*P2Q2)-32*A2*MB**4/(3*P2Q1*P2Q2)+ + &32*A2*MB**3*MT/(3*P2Q1*P2Q2)-64*A2**2*MB**5*MT/(3*P2Q1*P2Q2)+ + &16*P1P2/(3*P2Q1*P2Q2)-64*A2*MB**2*P1P2/(3*P2Q1*P2Q2)+ + &64*A2**2*MB**4*P1P2/(3*P2Q1*P2Q2)+8*MB**2*P1P2/(3*P1Q1*P2Q1*P2Q2)- + &8*MB*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+ + &32*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+ + &16*P1P2**2/(3*P1Q1*P2Q1*P2Q2)- + &32*A2*MB**2*P1P2**2/(3*P1Q1*P2Q1*P2Q2)- + &16*A2*MB**2*P1Q1/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q1/(3*P2Q1*P2Q2)+ + &8*MB**2*P1P2/(3*P1Q2*P2Q1*P2Q2)-8*MB*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+ + &32*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+ + &16*P1P2**2/(3*P1Q2*P2Q1*P2Q2)- + &32*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1*P2Q2)- + &16*MB*MT*P1P2**2/(3*P1Q1*P1Q2*P2Q1*P2Q2) + A18=A18+16*P1P2**3/(3*P1Q1*P1Q2*P2Q1*P2Q2)- + &32*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1*P2Q2)- + &16*A2*MB**2*P1Q2/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q2/(3*P2Q1*P2Q2)- + &32*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1*P2Q2)+272*A1*P2Q1/(3*P2Q2)+ + &112*A2*P2Q1/P2Q2-80*A1*A2*MB**2*P2Q1/P2Q2+ + &400*A1*A2*MB*MT*P2Q1/(3*P2Q2)-208*A2**2*MB*MT*P2Q1/(3*P2Q2)- + &272*A1*A2*MT**2*P2Q1/(3*P2Q2)-320*A1*A2*P1P2*P2Q1/P2Q2+ + &96*A2**2*P1P2*P2Q1/P2Q2-256*A1*MB*MT**3*P2Q1/(3*P1Q1**2*P2Q2)+ + &512*A1*MT**2*P1P2*P2Q1/(3*P1Q1**2*P2Q2)-8*P2Q1/(3*P1Q1*P2Q2)+ + &200*A1*MB*MT*P2Q1/(3*P1Q1*P2Q2)+56*A2*MB*MT*P2Q1/(3*P1Q1*P2Q2)+ + &272*A1*MT**2*P2Q1/(3*P1Q1*P2Q2)+160*A2*MT**2*P2Q1/(3*P1Q1*P2Q2)+ + &256*A1*P1P2*P2Q1/(3*P1Q1*P2Q2)+48*A2*P1P2*P2Q1/(P1Q1*P2Q2)+ + &256*A1*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2)- + &256*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q1*P2Q2)- + &1024*A1*A2*P1P2**2*P2Q1/(3*P1Q1*P2Q2)- + &544*A1*A2*P1Q1*P2Q1/(3*P2Q2)-640*A2**2*P1Q1*P2Q1/(3*P2Q2)- + &32*A1*P1P2*P2Q1/(3*P1Q2*P2Q2) + A18=A18-32*A1*A2*MB*MT*P1P2*P2Q1/(3*P1Q2*P2Q2)+ + &32*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q2*P2Q2)+ + &64*A1*A2*P1P2**2*P2Q1/(3*P1Q2*P2Q2)- + &32*A1*MT**2*P1P2*P2Q1/(3*P1Q1*P1Q2*P2Q2)+ + &64*A1*A2*P1P2*P1Q1*P2Q1/(3*P1Q2*P2Q2)- + &944*A1*A2*P1Q2*P2Q1/(3*P2Q2)-32*A2**2*P1Q2*P2Q1/P2Q2+ + &256*A1*MT**2*P1Q2*P2Q1/(3*P1Q1**2*P2Q2)+ + &96*A1*P1Q2*P2Q1/(P1Q1*P2Q2)+96*A2*P1Q2*P2Q1/(P1Q1*P2Q2)- + &128*A1*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)+ + &256*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2)- + &128*A1*A2*MT**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)- + &512*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2)- + &512*A1*A2*P1Q2**2*P2Q1/(3*P1Q1*P2Q2)+544*A1*A2*P2Q1**2/(3*P2Q2)- + &256*A1*MT**2*P2Q1**2/(3*P1Q1**2*P2Q2)- + &272*A1*P2Q1**2/(3*P1Q1*P2Q2)- + &256*A1*A2*MB*MT*P2Q1**2/(3*P1Q1*P2Q2)+ + &256*A1*A2*MT**2*P2Q1**2/(3*P1Q1*P2Q2) + A18=A18+512*A1*A2*P1P2*P2Q1**2/(3*P1Q1*P2Q2)+ + &512*A1*A2*P1Q2*P2Q1**2/(3*P1Q1*P2Q2)+224*A12*P2Q2+ + &656*A1*A2*P2Q2/3+256*A12*MT**4*P2Q2/(3*P1Q1**2)+ + &16*A1*P2Q2/(3*P1Q1)-112*A1*A2*MB*MT*P2Q2/(3*P1Q1)+ + &32*A12*MT**2*P2Q2/(3*P1Q1)+64*A1*A2*MT**2*P2Q2/P1Q1+ + &368*A1*A2*P1P2*P2Q2/(3*P1Q1)-256*A1*MT**2*P2Q2/(3*P1Q2**2)+ + &256*A12*MT**4*P2Q2/(3*P1Q2**2)-256*A1*P2Q2/(3*P1Q2)- + &224*A1*A2*MB*MT*P2Q2/(3*P1Q2)-368*A12*MT**2*P2Q2/(3*P1Q2)+ + &448*A1*A2*MT**2*P2Q2/(3*P1Q2)+304*A1*A2*P1P2*P2Q2/(3*P1Q2)+ + &16*A1*MT**2*P2Q2/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q2/(3*P1Q1*P1Q2)+ + &32*A12*P1Q1*P2Q2/P1Q2+944*A1*A2*P1Q1*P2Q2/(3*P1Q2)+ + &256*A12*MT**2*P1Q2*P2Q2/(3*P1Q1**2)+ + &640*A12*P1Q2*P2Q2/(3*P1Q1)+544*A1*A2*P1Q2*P2Q2/(3*P1Q1)- + &256*A2*MB**2*P2Q2/(3*P2Q1**2)+256*A2**2*MB**3*MT*P2Q2/(3*P2Q1**2)+ + &64*MB**2*MT**2*P2Q2/(3*P1Q2**2*P2Q1**2)+ + &64*MB**2*P2Q2/(3*P1Q2*P2Q1**2)+ + &128*A2*MB**3*MT*P2Q2/(3*P1Q2*P2Q1**2) + A18=A18-128*A2*MB**2*MT**2*P2Q2/(3*P1Q2*P2Q1**2)- + &256*A2*MB**2*P1P2*P2Q2/(3*P1Q2*P2Q1**2)- + &256*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1**2)+ + &256*A2**2*MB**2*P1Q2*P2Q2/(3*P2Q1**2)+272*A1*P2Q2/(3*P2Q1)+ + &112*A2*P2Q2/P2Q1-80*A1*A2*MB**2*P2Q2/P2Q1+ + &400*A1*A2*MB*MT*P2Q2/(3*P2Q1)-208*A2**2*MB*MT*P2Q2/(3*P2Q1)- + &272*A1*A2*MT**2*P2Q2/(3*P2Q1)-320*A1*A2*P1P2*P2Q2/P2Q1+ + &96*A2**2*P1P2*P2Q2/P2Q1-32*A1*P1P2*P2Q2/(3*P1Q1*P2Q1)- + &32*A1*A2*MB*MT*P1P2*P2Q2/(3*P1Q1*P2Q1)+ + &32*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q1*P2Q1)+ + &64*A1*A2*P1P2**2*P2Q2/(3*P1Q1*P2Q1)-944*A1*A2*P1Q1*P2Q2/(3*P2Q1)- + &32*A2**2*P1Q1*P2Q2/P2Q1-256*A1*MB*MT**3*P2Q2/(3*P1Q2**2*P2Q1)+ + &512*A1*MT**2*P1P2*P2Q2/(3*P1Q2**2*P2Q1)+ + &256*A1*MT**2*P1Q1*P2Q2/(3*P1Q2**2*P2Q1)-8*P2Q2/(3*P1Q2*P2Q1)+ + &200*A1*MB*MT*P2Q2/(3*P1Q2*P2Q1)+56*A2*MB*MT*P2Q2/(3*P1Q2*P2Q1)+ + &272*A1*MT**2*P2Q2/(3*P1Q2*P2Q1)+160*A2*MT**2*P2Q2/(3*P1Q2*P2Q1)+ + &256*A1*P1P2*P2Q2/(3*P1Q2*P2Q1)+48*A2*P1P2*P2Q2/(P1Q2*P2Q1) + A18=A18+256*A1*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1)- + &256*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q2*P2Q1)- + &1024*A1*A2*P1P2**2*P2Q2/(3*P1Q2*P2Q1)- + &32*A1*MT**2*P1P2*P2Q2/(3*P1Q1*P1Q2*P2Q1)+ + &96*A1*P1Q1*P2Q2/(P1Q2*P2Q1)+96*A2*P1Q1*P2Q2/(P1Q2*P2Q1)- + &128*A1*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)+ + &256*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1)- + &128*A1*A2*MT**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)- + &512*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1)- + &512*A1*A2*P1Q1**2*P2Q2/(3*P1Q2*P2Q1)-544*A1*A2*P1Q2*P2Q2/(3*P2Q1)- + &640*A2**2*P1Q2*P2Q2/(3*P2Q1)+ + &64*A1*A2*P1P2*P1Q2*P2Q2/(3*P1Q1*P2Q1)+544*A1*A2*P2Q2**2/(3*P2Q1)- + &256*A1*MT**2*P2Q2**2/(3*P1Q2**2*P2Q1)- + &272*A1*P2Q2**2/(3*P1Q2*P2Q1)- + &256*A1*A2*MB*MT*P2Q2**2/(3*P1Q2*P2Q1)+ + &256*A1*A2*MT**2*P2Q2**2/(3*P1Q2*P2Q1)+ + &512*A1*A2*P1P2*P2Q2**2/(3*P1Q2*P2Q1) + A18=A18+512*A1*A2*P1Q1*P2Q2**2/(3*P1Q2*P2Q1)- + &384*A12*MB*MT*P1Q1**2/S**2+ + &384*A12*P1P2*P1Q1**2/S**2-2688*A12*MB*MT*P1Q1*P1Q2/S**2+ + &2688*A12*P1P2*P1Q1*P1Q2/S**2-384*A12*MB*MT*P1Q2**2/S**2+ + &384*A12*P1P2*P1Q2**2/S**2-768*A1*A2*MB*MT*P1Q1*P2Q1/S**2+ + &768*A1*A2*P1P2*P1Q1*P2Q1/S**2-2688*A1*A2*MB*MT*P1Q2*P2Q1/S**2+ + &2688*A1*A2*P1P2*P1Q2*P2Q1/S**2-960*A12*P1Q1*P1Q2*P2Q1/S**2- + &960*A1*A2*P1Q1*P1Q2*P2Q1/S**2+960*A12*P1Q2**2*P2Q1/S**2+ + &960*A1*A2*P1Q2**2*P2Q1/S**2-384*A2**2*MB*MT*P2Q1**2/S**2+ + &384*A2**2*P1P2*P2Q1**2/S**2-960*A1*A2*P1Q2*P2Q1**2/S**2- + &960*A2**2*P1Q2*P2Q1**2/S**2-2688*A1*A2*MB*MT*P1Q1*P2Q2/S**2+ + &2688*A1*A2*P1P2*P1Q1*P2Q2/S**2+960*A12*P1Q1**2*P2Q2/S**2+ + &960*A1*A2*P1Q1**2*P2Q2/S**2-768*A1*A2*MB*MT*P1Q2*P2Q2/S**2+ + &768*A1*A2*P1P2*P1Q2*P2Q2/S**2-960*A12*P1Q1*P1Q2*P2Q2/S**2- + &960*A1*A2*P1Q1*P1Q2*P2Q2/S**2-2688*A2**2*MB*MT*P2Q1*P2Q2/S**2+ + &2688*A2**2*P1P2*P2Q1*P2Q2/S**2+960*A1*A2*P1Q1*P2Q1*P2Q2/S**2+ + &960*A2**2*P1Q1*P2Q1*P2Q2/S**2+960*A1*A2*P1Q2*P2Q1*P2Q2/S**2 + A18=A18+960*A2**2*P1Q2*P2Q1*P2Q2/S**2- + &384*A2**2*MB*MT*P2Q2**2/S**2+ + &384*A2**2*P1P2*P2Q2**2/S**2-960*A1*A2*P1Q1*P2Q2**2/S**2- + &960*A2**2*P1Q1*P2Q2**2/S**2-96*A1*MB*MT/S-96*A2*MB*MT/S+ + &768*A2**2*MB**3*MT/S+768*A12*MB*MT**3/S-192*A1*P1P2/S- + &192*A2*P1P2/S-768*A2**2*MB**2*P1P2/S+2304*A1*A2*MB*MT*P1P2/S- + &768*A12*MT**2*P1P2/S-2304*A1*A2*P1P2**2/S+ + &96*A1*MB*MT**3/(P1Q1*S)+192*A2*MB*MT*P1P2/(P1Q1*S)- + &96*A1*MT**2*P1P2/(P1Q1*S)-192*A2*P1P2**2/(P1Q1*S)-192*A1*P1Q1/S- + &144*A2*P1Q1/S-384*A1*A2*MB**2*P1Q1/S-480*A2**2*MB**2*P1Q1/S+ + &480*A12*MB*MT*P1Q1/S-96*A1*A2*MB*MT*P1Q1/S- + &864*A12*P1P2*P1Q1/S-672*A1*A2*P1P2*P1Q1/S-96*A1*A2*P1Q1**2/S+ + &96*A1*MB*MT**3/(P1Q2*S)+192*A2*MB*MT*P1P2/(P1Q2*S)- + &96*A1*MT**2*P1P2/(P1Q2*S)-192*A2*P1P2**2/(P1Q2*S)+ + &48*A1*MB*MT*P1Q1/(P1Q2*S)-96*A2*MB*MT*P1Q1/(P1Q2*S)- + &48*A1*MT**2*P1Q1/(P1Q2*S)-192*A1*P1P2*P1Q1/(P1Q2*S)- + &192*A2*P1P2*P1Q1/(P1Q2*S)-192*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*S) + A18=A18+192*A1*A2*P1P2**2*P1Q1/(P1Q2*S)-192*A1*P1Q1**2/(P1Q2*S)- + &192*A2*P1Q1**2/(P1Q2*S)+192*A1*A2*MB**2*P1Q1**2/(P1Q2*S)+ + &192*A12*MB*MT*P1Q1**2/(P1Q2*S)-96*A1*A2*MB*MT*P1Q1**2/(P1Q2*S)+ + &192*A1*A2*P1P2*P1Q1**2/(P1Q2*S)-192*A1*P1Q2/S-144*A2*P1Q2/S- + &384*A1*A2*MB**2*P1Q2/S-480*A2**2*MB**2*P1Q2/S+ + &480*A12*MB*MT*P1Q2/S-96*A1*A2*MB*MT*P1Q2/S- + &864*A12*P1P2*P1Q2/S-672*A1*A2*P1P2*P1Q2/S+ + &48*A1*MB*MT*P1Q2/(P1Q1*S)-96*A2*MB*MT*P1Q2/(P1Q1*S)- + &48*A1*MT**2*P1Q2/(P1Q1*S)-192*A1*P1P2*P1Q2/(P1Q1*S)- + &192*A2*P1P2*P1Q2/(P1Q1*S)-192*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*S)+ + &192*A1*A2*P1P2**2*P1Q2/(P1Q1*S)-576*A1*A2*P1Q1*P1Q2/S- + &96*A1*A2*P1Q2**2/S-192*A1*P1Q2**2/(P1Q1*S)- + &192*A2*P1Q2**2/(P1Q1*S)+192*A1*A2*MB**2*P1Q2**2/(P1Q1*S)+ + &192*A12*MB*MT*P1Q2**2/(P1Q1*S)-96*A1*A2*MB*MT*P1Q2**2/(P1Q1*S)+ + &192*A1*A2*P1P2*P1Q2**2/(P1Q1*S)-96*A2*MB**3*MT/(P2Q1*S)+ + &96*A2*MB**2*P1P2/(P2Q1*S)-192*A1*MB*MT*P1P2/(P2Q1*S)+ + &192*A1*P1P2**2/(P2Q1*S)+96*A1*MB**2*P1Q1/(P2Q1*S) + A18=A18+192*A2*MB**2*P1Q1/(P2Q1*S)-96*A1*MB*MT*P1Q1/(P2Q1*S)- + &192*A1*A2*MB**3*MT*P1Q1/(P2Q1*S)+192*A1*P1P2*P1Q1/(P2Q1*S)+ + &192*A1*A2*MB**2*P1P2*P1Q1/(P2Q1*S)+ + &96*A1*A2*MB**2*P1Q1**2/(P2Q1*S)- + &192*A2*MB**3*MT*P1Q1/(P1Q2*P2Q1*S)+ + &192*A2*MB**2*P1P2*P1Q1/(P1Q2*P2Q1*S)- + &96*A1*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1*S)+ + &96*A1*P1P2**2*P1Q1/(P1Q2*P2Q1*S)+ + &96*A1*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+ + &192*A2*MB**2*P1Q1**2/(P1Q2*P2Q1*S)- + &48*A1*MB*MT*P1Q1**2/(P1Q2*P2Q1*S)+ + &96*A1*P1P2*P1Q1**2/(P1Q2*P2Q1*S)+96*A1*MB**2*P1Q2/(P2Q1*S)+ + &48*A2*MB**2*P1Q2/(P2Q1*S)+192*A1*A2*MB**3*MT*P1Q2/(P2Q1*S)- + &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q1*S)- + &96*A1*A2*MB**2*P1Q2**2/(P2Q1*S)+144*A1*P2Q1/S+192*A2*P2Q1/S+ + &96*A1*A2*MB*MT*P2Q1/S-480*A2**2*MB*MT*P2Q1/S+ + &480*A12*MT**2*P2Q1/S+384*A1*A2*MT**2*P2Q1/S + A18=A18+672*A1*A2*P1P2*P2Q1/S+864*A2**2*P1P2*P2Q1/S- + &96*A2*MB*MT*P2Q1/(P1Q1*S)+192*A1*MT**2*P2Q1/(P1Q1*S)+ + &96*A2*MT**2*P2Q1/(P1Q1*S)-192*A1*A2*MB*MT**3*P2Q1/(P1Q1*S)+ + &192*A2*P1P2*P2Q1/(P1Q1*S)+192*A1*A2*MT**2*P1P2*P2Q1/(P1Q1*S)- + &192*A12*P1Q1*P2Q1/S-192*A2**2*P1Q1*P2Q1/S+ + &48*A1*MT**2*P2Q1/(P1Q2*S)+96*A2*MT**2*P2Q1/(P1Q2*S)+ + &192*A1*A2*MB*MT**3*P2Q1/(P1Q2*S)- + &192*A1*A2*MT**2*P1P2*P2Q1/(P1Q2*S)+ + &96*A1*A2*MB*MT*P1Q1*P2Q1/(P1Q2*S)- + &192*A12*MT**2*P1Q1*P2Q1/(P1Q2*S)- + &96*A1*A2*MT**2*P1Q1*P2Q1/(P1Q2*S)- + &384*A1*A2*P1P2*P1Q1*P2Q1/(P1Q2*S)-384*A12*P1Q1**2*P2Q1/(P1Q2*S)- + &384*A1*A2*P1Q1**2*P2Q1/(P1Q2*S)-480*A12*P1Q2*P2Q1/S- + &960*A1*A2*P1Q2*P2Q1/S-480*A2**2*P1Q2*P2Q1/S+ + &144*A1*P1Q2*P2Q1/(P1Q1*S)+96*A2*P1Q2*P2Q1/(P1Q1*S)+ + &384*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*S)- + &96*A12*MT**2*P1Q2*P2Q1/(P1Q1*S) + A18=A18+96*A1*A2*MT**2*P1Q2*P2Q1/(P1Q1*S)- + &576*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*S)-192*A12*P1Q2**2*P2Q1/(P1Q1*S)- + &384*A1*A2*P1Q2**2*P2Q1/(P1Q1*S)-96*A1*A2*P2Q1**2/S- + &96*A1*A2*MT**2*P2Q1**2/(P1Q1*S)+96*A1*A2*MT**2*P2Q1**2/(P1Q2*S)+ + &288*A1*A2*P1Q2*P2Q1**2/(P1Q1*S)-96*A2*MB**3*MT/(P2Q2*S)+ + &96*A2*MB**2*P1P2/(P2Q2*S)-192*A1*MB*MT*P1P2/(P2Q2*S)+ + &192*A1*P1P2**2/(P2Q2*S)+96*A1*MB**2*P1Q1/(P2Q2*S)+ + &48*A2*MB**2*P1Q1/(P2Q2*S)+192*A1*A2*MB**3*MT*P1Q1/(P2Q2*S)- + &192*A1*A2*MB**2*P1P2*P1Q1/(P2Q2*S)- + &96*A1*A2*MB**2*P1Q1**2/(P2Q2*S)+96*A1*MB**2*P1Q2/(P2Q2*S)+ + &192*A2*MB**2*P1Q2/(P2Q2*S)-96*A1*MB*MT*P1Q2/(P2Q2*S)- + &192*A1*A2*MB**3*MT*P1Q2/(P2Q2*S)+192*A1*P1P2*P1Q2/(P2Q2*S)+ + &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q2*S)- + &192*A2*MB**3*MT*P1Q2/(P1Q1*P2Q2*S)+ + &192*A2*MB**2*P1P2*P1Q2/(P1Q1*P2Q2*S)- + &96*A1*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2*S)+ + &96*A1*P1P2**2*P1Q2/(P1Q1*P2Q2*S)+96*A1*A2*MB**2*P1Q2**2/(P2Q2*S) + A18=A18+96*A1*MB**2*P1Q2**2/(P1Q1*P2Q2*S)+ + &192*A2*MB**2*P1Q2**2/(P1Q1*P2Q2*S)- + &48*A1*MB*MT*P1Q2**2/(P1Q1*P2Q2*S)+ + &96*A1*P1P2*P1Q2**2/(P1Q1*P2Q2*S)-48*A2*MB**2*P2Q1/(P2Q2*S)- + &96*A1*MB*MT*P2Q1/(P2Q2*S)+48*A2*MB*MT*P2Q1/(P2Q2*S)- + &192*A1*P1P2*P2Q1/(P2Q2*S)-192*A2*P1P2*P2Q1/(P2Q2*S)- + &192*A1*A2*MB*MT*P1P2*P2Q1/(P2Q2*S)+ + &192*A1*A2*P1P2**2*P2Q1/(P2Q2*S)+ + &192*A1*MB*MT**3*P2Q1/(P1Q1*P2Q2*S)+ + &96*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2*S)- + &192*A1*MT**2*P1P2*P2Q1/(P1Q1*P2Q2*S)- + &96*A2*P1P2**2*P2Q1/(P1Q1*P2Q2*S)+ + &96*A1*A2*MB**2*P1Q1*P2Q1/(P2Q2*S)+ + &192*A2**2*MB**2*P1Q1*P2Q1/(P2Q2*S)- + &96*A1*A2*MB*MT*P1Q1*P2Q1/(P2Q2*S)+ + &384*A1*A2*P1P2*P1Q1*P2Q1/(P2Q2*S)-96*A1*P1Q2*P2Q1/(P2Q2*S)- + &144*A2*P1Q2*P2Q1/(P2Q2*S)-96*A1*A2*MB**2*P1Q2*P2Q1/(P2Q2*S) + A18=A18+96*A2**2*MB**2*P1Q2*P2Q1/(P2Q2*S)- + &384*A1*A2*MB*MT*P1Q2*P2Q1/(P2Q2*S)+ + &576*A1*A2*P1P2*P1Q2*P2Q1/(P2Q2*S)- + &96*A2*MB**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)- + &48*A1*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)- + &48*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)- + &96*A1*MT**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)- + &96*A1*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)- + &96*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+ + &96*A1*A2*P1Q1*P1Q2*P2Q1/(P2Q2*S)+288*A1*A2*P1Q2**2*P2Q1/(P2Q2*S)- + &96*A1*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)-96*A2*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)+ + &192*A1*P2Q1**2/(P2Q2*S)+192*A2*P2Q1**2/(P2Q2*S)+ + &96*A1*A2*MB*MT*P2Q1**2/(P2Q2*S)-192*A2**2*MB*MT*P2Q1**2/(P2Q2*S)- + &192*A1*A2*MT**2*P2Q1**2/(P2Q2*S)-192*A1*A2*P1P2*P2Q1**2/(P2Q2*S)- + &48*A2*MB*MT*P2Q1**2/(P1Q1*P2Q2*S)+ + &192*A1*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+ + &96*A2*MT**2*P2Q1**2/(P1Q1*P2Q2*S) + A18=A18+96*A2*P1P2*P2Q1**2/(P1Q1*P2Q2*S)- + &384*A1*A2*P1Q1*P2Q1**2/(P2Q2*S)- + &384*A2**2*P1Q1*P2Q1**2/(P2Q2*S)-384*A1*A2*P1Q2*P2Q1**2/(P2Q2*S)- + &192*A2**2*P1Q2*P2Q1**2/(P2Q2*S)+96*A1*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+ + &96*A2*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+144*A1*P2Q2/S+192*A2*P2Q2/S+ + &96*A1*A2*MB*MT*P2Q2/S-480*A2**2*MB*MT*P2Q2/S+ + &480*A12*MT**2*P2Q2/S+384*A1*A2*MT**2*P2Q2/S+ + &672*A1*A2*P1P2*P2Q2/S+864*A2**2*P1P2*P2Q2/S+ + &48*A1*MT**2*P2Q2/(P1Q1*S)+96*A2*MT**2*P2Q2/(P1Q1*S)+ + &192*A1*A2*MB*MT**3*P2Q2/(P1Q1*S)- + &192*A1*A2*MT**2*P1P2*P2Q2/(P1Q1*S)-480*A12*P1Q1*P2Q2/S- + &960*A1*A2*P1Q1*P2Q2/S-480*A2**2*P1Q1*P2Q2/S- + &96*A2*MB*MT*P2Q2/(P1Q2*S)+192*A1*MT**2*P2Q2/(P1Q2*S)+ + &96*A2*MT**2*P2Q2/(P1Q2*S)-192*A1*A2*MB*MT**3*P2Q2/(P1Q2*S)+ + &192*A2*P1P2*P2Q2/(P1Q2*S)+192*A1*A2*MT**2*P1P2*P2Q2/(P1Q2*S)+ + &144*A1*P1Q1*P2Q2/(P1Q2*S)+96*A2*P1Q1*P2Q2/(P1Q2*S)+ + &384*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*S) + A18=A18-96*A12*MT**2*P1Q1*P2Q2/(P1Q2*S)+ + &96*A1*A2*MT**2*P1Q1*P2Q2/(P1Q2*S)- + &576*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*S)-192*A12*P1Q1**2*P2Q2/(P1Q2*S)- + &384*A1*A2*P1Q1**2*P2Q2/(P1Q2*S)-192*A12*P1Q2*P2Q2/S- + &192*A2**2*P1Q2*P2Q2/S+96*A1*A2*MB*MT*P1Q2*P2Q2/(P1Q1*S)- + &192*A12*MT**2*P1Q2*P2Q2/(P1Q1*S)- + &96*A1*A2*MT**2*P1Q2*P2Q2/(P1Q1*S)- + &384*A1*A2*P1P2*P1Q2*P2Q2/(P1Q1*S)-384*A12*P1Q2**2*P2Q2/(P1Q1*S)- + &384*A1*A2*P1Q2**2*P2Q2/(P1Q1*S)-48*A2*MB**2*P2Q2/(P2Q1*S)- + &96*A1*MB*MT*P2Q2/(P2Q1*S)+48*A2*MB*MT*P2Q2/(P2Q1*S)- + &192*A1*P1P2*P2Q2/(P2Q1*S)-192*A2*P1P2*P2Q2/(P2Q1*S)- + &192*A1*A2*MB*MT*P1P2*P2Q2/(P2Q1*S)+ + &192*A1*A2*P1P2**2*P2Q2/(P2Q1*S)-96*A1*P1Q1*P2Q2/(P2Q1*S)- + &144*A2*P1Q1*P2Q2/(P2Q1*S)-96*A1*A2*MB**2*P1Q1*P2Q2/(P2Q1*S)+ + &96*A2**2*MB**2*P1Q1*P2Q2/(P2Q1*S)- + &384*A1*A2*MB*MT*P1Q1*P2Q2/(P2Q1*S)+ + &576*A1*A2*P1P2*P1Q1*P2Q2/(P2Q1*S)+288*A1*A2*P1Q1**2*P2Q2/(P2Q1*S) + A18=A18+192*A1*MB*MT**3*P2Q2/(P1Q2*P2Q1*S)+ + &96*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1*S)- + &192*A1*MT**2*P1P2*P2Q2/(P1Q2*P2Q1*S)- + &96*A2*P1P2**2*P2Q2/(P1Q2*P2Q1*S)- + &96*A2*MB**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)- + &48*A1*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)- + &48*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)- + &96*A1*MT**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)- + &96*A1*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)- + &96*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)- + &96*A1*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)-96*A2*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)+ + &96*A1*A2*MB**2*P1Q2*P2Q2/(P2Q1*S)+ + &192*A2**2*MB**2*P1Q2*P2Q2/(P2Q1*S)- + &96*A1*A2*MB*MT*P1Q2*P2Q2/(P2Q1*S)+ + &384*A1*A2*P1P2*P1Q2*P2Q2/(P2Q1*S)+ + &96*A1*A2*P1Q1*P1Q2*P2Q2/(P2Q1*S)-576*A1*A2*P2Q1*P2Q2/S+ + &96*A1*A2*P1Q1*P2Q1*P2Q2/(P1Q2*S)+96*A1*A2*P1Q2*P2Q1*P2Q2/(P1Q1*S) + A18=A18-96*A1*A2*P2Q2**2/S+96*A1*A2*MT**2*P2Q2**2/(P1Q1*S)- + &96*A1*A2*MT**2*P2Q2**2/(P1Q2*S)+288*A1*A2*P1Q1*P2Q2**2/(P1Q2*S)+ + &192*A1*P2Q2**2/(P2Q1*S)+192*A2*P2Q2**2/(P2Q1*S)+ + &96*A1*A2*MB*MT*P2Q2**2/(P2Q1*S)-192*A2**2*MB*MT*P2Q2**2/(P2Q1*S)- + &192*A1*A2*MT**2*P2Q2**2/(P2Q1*S)-192*A1*A2*P1P2*P2Q2**2/(P2Q1*S)- + &384*A1*A2*P1Q1*P2Q2**2/(P2Q1*S)-192*A2**2*P1Q1*P2Q2**2/(P2Q1*S)- + &48*A2*MB*MT*P2Q2**2/(P1Q2*P2Q1*S)+ + &192*A1*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+ + &96*A2*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+ + &96*A2*P1P2*P2Q2**2/(P1Q2*P2Q1*S)+96*A1*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)+ + &96*A2*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)-384*A1*A2*P1Q2*P2Q2**2/(P2Q1*S)- + &384*A2**2*P1Q2*P2Q2**2/(P2Q1*S)+512*A1*A2*S/3- + &128*A1*MT**2*S/(3*P1Q1**2)+128*A12*MB*MT**3*S/(3*P1Q1**2)- + &152*A1*S/(3*P1Q1)-152*A12*MB*MT*S/(3*P1Q1)- + &128*A1*A2*MB*MT*S/(3*P1Q1)+112*A1*A2*MT**2*S/(3*P1Q1)- + &16*A12*P1P2*S/P1Q1+152*A1*A2*P1P2*S/(3*P1Q1)- + &128*A1*MT**2*S/(3*P1Q2**2)+128*A12*MB*MT**3*S/(3*P1Q2**2) + A18=A18-152*A1*S/(3*P1Q2)-152*A12*MB*MT*S/(3*P1Q2)- + &128*A1*A2*MB*MT*S/(3*P1Q2)+112*A1*A2*MT**2*S/(3*P1Q2)- + &16*A12*P1P2*S/P1Q2+152*A1*A2*P1P2*S/(3*P1Q2)+ + &16*A1*MB*MT*S/(3*P1Q1*P1Q2)-32*A12*MB*MT**3*S/(3*P1Q1*P1Q2)- + &16*A1*P1P2*S/(3*P1Q1*P1Q2)+272*A1*A2*P1Q1*S/(3*P1Q2)+ + &272*A1*A2*P1Q2*S/(3*P1Q1)-128*A2*MB**2*S/(3*P2Q1**2)+ + &128*A2**2*MB**3*MT*S/(3*P2Q1**2)+ + &32*MB**2*MT**2*S/(3*P1Q2**2*P2Q1**2)+32*MB**2*S/(3*P1Q2*P2Q1**2) + + A18BIS= + &64*A2*MB**3*MT*S/(3*P1Q2*P2Q1**2)- + &64*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1**2)- + &128*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1**2)- + &128*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1**2)+ + &128*A2**2*MB**2*P1Q2*S/(3*P2Q1**2)+152*A2*S/(3*P2Q1)- + &112*A1*A2*MB**2*S/(3*P2Q1)+128*A1*A2*MB*MT*S/(3*P2Q1)+ + &152*A2**2*MB*MT*S/(3*P2Q1)-152*A1*A2*P1P2*S/(3*P2Q1)+ + &16*A2**2*P1P2*S/P2Q1-8*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q1)+ + &16*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q1)- + &8*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q1)-8*A1*P1P2*S/(3*P1Q1*P2Q1)- + &8*A2*P1P2*S/(3*P1Q1*P2Q1)+8*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1)- + &16*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1)+ + &8*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q1)+ + &32*A1*A2*P1P2**2*S/(3*P1Q1*P2Q1)-32*A2**2*P1Q1*S/(3*P2Q1)- + &32*MT**2*S/(3*P1Q2**2*P2Q1)+64*A1*MB**2*MT**2*S/(3*P1Q2**2*P2Q1)- + &64*A1*MB*MT**3*S/(3*P1Q2**2*P2Q1) + A18BIS=A18BIS+128*A1*MT**2*P1P2*S/(3*P1Q2**2*P2Q1)- + &12*S/(P1Q2*P2Q1)+ + &24*A1*MB**2*S/(P1Q2*P2Q1)+64*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q1)+ + &24*A2*MT**2*S/(P1Q2*P2Q1)-128*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1)+ + &64*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q1)+56*A1*P1P2*S/(3*P1Q2*P2Q1)+ + &56*A2*P1P2*S/(3*P1Q2*P2Q1)-64*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1)+ + &128*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1)- + &64*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q1)- + &256*A1*A2*P1P2**2*S/(3*P1Q2*P2Q1)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q1)- + &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1)- + &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+136*A2*P1Q1*S/(3*P1Q2*P2Q1)- + &128*A1*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1)+ + &128*A1*A2*MB*MT*P1Q1*S/(3*P1Q2*P2Q1)- + &256*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1)-160*A2**2*P1Q2*S/(3*P2Q1)+ + &16*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1)-32*A12*P2Q1*S/(3*P1Q1)- + &128*A12*MT**2*P2Q1*S/(3*P1Q2**2)-160*A12*P2Q1*S/(3*P1Q2)- + &128*A2*MB**2*S/(3*P2Q2**2)+128*A2**2*MB**3*MT*S/(3*P2Q2**2) + A18BIS=A18BIS+32*MB**2*MT**2*S/(3*P1Q1**2*P2Q2**2)+ + &32*MB**2*S/(3*P1Q1*P2Q2**2)+ + &64*A2*MB**3*MT*S/(3*P1Q1*P2Q2**2)- + &64*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2**2)- + &128*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2**2)+ + &128*A2**2*MB**2*P1Q1*S/(3*P2Q2**2)- + &128*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2**2)+152*A2*S/(3*P2Q2)- + &112*A1*A2*MB**2*S/(3*P2Q2)+128*A1*A2*MB*MT*S/(3*P2Q2)+ + &152*A2**2*MB*MT*S/(3*P2Q2)-152*A1*A2*P1P2*S/(3*P2Q2)+ + &16*A2**2*P1P2*S/P2Q2-32*MT**2*S/(3*P1Q1**2*P2Q2)+ + &64*A1*MB**2*MT**2*S/(3*P1Q1**2*P2Q2)- + &64*A1*MB*MT**3*S/(3*P1Q1**2*P2Q2)+ + &128*A1*MT**2*P1P2*S/(3*P1Q1**2*P2Q2)-12*S/(P1Q1*P2Q2)+ + &24*A1*MB**2*S/(P1Q1*P2Q2)+64*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q2)+ + &24*A2*MT**2*S/(P1Q1*P2Q2)-128*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2)+ + &64*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q2)+56*A1*P1P2*S/(3*P1Q1*P2Q2)+ + &56*A2*P1P2*S/(3*P1Q1*P2Q2)-64*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2) + A18BIS=A18BIS+128*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q2)- + &64*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q2)- + &256*A1*A2*P1P2**2*S/(3*P1Q1*P2Q2)-160*A2**2*P1Q1*S/(3*P2Q2)- + &8*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q2)+ + &16*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q2)- + &8*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q2)-8*A1*P1P2*S/(3*P1Q2*P2Q2)- + &8*A2*P1P2*S/(3*P1Q2*P2Q2)+8*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q2)- + &16*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q2)+ + &8*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q2)+ + &32*A1*A2*P1P2**2*S/(3*P1Q2*P2Q2)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q2)- + &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q2)- + &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+ + &16*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q2)-32*A2**2*P1Q2*S/(3*P2Q2)+ + &136*A2*P1Q2*S/(3*P1Q1*P2Q2)-128*A1*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2)+ + &128*A1*A2*MB*MT*P1Q2*S/(3*P1Q1*P2Q2)- + &256*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q2)+16*A2*MB*MT*S/(3*P2Q1*P2Q2)- + &32*A2**2*MB**3*MT*S/(3*P2Q1*P2Q2)-16*A2*P1P2*S/(3*P2Q1*P2Q2) + A18BIS=A18BIS-4*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+ + &8*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+ + &8*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1*P2Q2)-4*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+ + &8*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+ + &8*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1*P2Q2)- + &2*MB**3*MT*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+ + &4*MB**2*MT**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)- + &2*MB*MT**3*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)- + &2*MB**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+ + &4*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)- + &2*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)- + &8*P1P2**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+ + &8*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1*P2Q2)+ + &8*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1*P2Q2)+272*A1*A2*P2Q1*S/(3*P2Q2)- + &128*A1*MT**2*P2Q1*S/(3*P1Q1**2*P2Q2)-136*A1*P2Q1*S/(3*P1Q1*P2Q2)- + &128*A1*A2*MB*MT*P2Q1*S/(3*P1Q1*P2Q2)+ + &128*A1*A2*MT**2*P2Q1*S/(3*P1Q1*P2Q2) + A18BIS=A18BIS+256*A1*A2*P1P2*P2Q1*S/(3*P1Q1*P2Q2)- + &16*A1*A2*P1P2*P2Q1*S/(3*P1Q2*P2Q2)+ + &8*A1*P1P2*P2Q1*S/(3*P1Q1*P1Q2*P2Q2)+ + &256*A1*A2*P1Q2*P2Q1*S/(3*P1Q1*P2Q2)- + &128*A12*MT**2*P2Q2*S/(3*P1Q1**2)-160*A12*P2Q2*S/(3*P1Q1)- + &32*A12*P2Q2*S/(3*P1Q2)+272*A1*A2*P2Q2*S/(3*P2Q1)- + &16*A1*A2*P1P2*P2Q2*S/(3*P1Q1*P2Q1)- + &128*A1*MT**2*P2Q2*S/(3*P1Q2**2*P2Q1)-136*A1*P2Q2*S/(3*P1Q2*P2Q1)- + &128*A1*A2*MB*MT*P2Q2*S/(3*P1Q2*P2Q1)+ + &128*A1*A2*MT**2*P2Q2*S/(3*P1Q2*P2Q1)+ + &256*A1*A2*P1P2*P2Q2*S/(3*P1Q2*P2Q1)+ + &8*A1*P1P2*P2Q2*S/(3*P1Q1*P1Q2*P2Q1)+ + &256*A1*A2*P1Q1*P2Q2*S/(3*P1Q2*P2Q1)- + &8*A12*MB*MT*S**2/(3*P1Q1*P1Q2)+16*A12*P1P2*S**2/(3*P1Q1*P1Q2)- + &8*A1*A2*P1P2*S**2/(3*P1Q1*P2Q1)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1)- + &8*A1*A2*P1P2*S**2/(3*P1Q2*P2Q2)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q2)- + &8*A2**2*MB*MT*S**2/(3*P2Q1*P2Q2)+16*A2**2*P1P2*S**2/(3*P2Q1*P2Q2) + A18BIS=A18BIS-4*A2*P1P2*S**2/(3*P1Q1*P2Q1*P2Q2)- + &4*A2*P1P2*S**2/(3*P1Q2*P2Q1*P2Q2)+ + &2*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1*P2Q2) +C + V18=V18+V18BIS + A18=A18+A18BIS + V910 =-48*A12*MB*MT-48*A2**2*MB*MT-48*A12*P1P2-48*A2**2*P1P2- + &384*A12*MB*MT*P1Q1*P1Q2/S**2-384*A12*P1P2*P1Q1*P1Q2/S**2- + &384*A1*A2*MB*MT*P1Q2*P2Q1/S**2-384*A1*A2*P1P2*P1Q2*P2Q1/S**2+ + &192*A12*P1Q1*P1Q2*P2Q1/S**2+192*A1*A2*P1Q1*P1Q2*P2Q1/S**2- + &192*A12*P1Q2**2*P2Q1/S**2-192*A1*A2*P1Q2**2*P2Q1/S**2+ + &192*A1*A2*P1Q2*P2Q1**2/S**2+192*A2**2*P1Q2*P2Q1**2/S**2- + &384*A1*A2*MB*MT*P1Q1*P2Q2/S**2-384*A1*A2*P1P2*P1Q1*P2Q2/S**2- + &192*A12*P1Q1**2*P2Q2/S**2-192*A1*A2*P1Q1**2*P2Q2/S**2+ + &192*A12*P1Q1*P1Q2*P2Q2/S**2+192*A1*A2*P1Q1*P1Q2*P2Q2/S**2- + &384*A2**2*MB*MT*P2Q1*P2Q2/S**2-384*A2**2*P1P2*P2Q1*P2Q2/S**2- + &192*A1*A2*P1Q1*P2Q1*P2Q2/S**2-192*A2**2*P1Q1*P2Q1*P2Q2/S**2- + &192*A1*A2*P1Q2*P2Q1*P2Q2/S**2-192*A2**2*P1Q2*P2Q1*P2Q2/S**2+ + &192*A1*A2*P1Q1*P2Q2**2/S**2+192*A2**2*P1Q1*P2Q2**2/S**2+ + &96*A12*MB*MT*P1Q1/S-96*A1*A2*MB*MT*P1Q1/S+ + &96*A12*P1P2*P1Q1/S-96*A1*A2*P1P2*P1Q1/S+96*A12*MB*MT*P1Q2/S- + &96*A1*A2*MB*MT*P1Q2/S+96*A12*P1P2*P1Q2/S-96*A1*A2*P1P2*P1Q2/S+ + &96*A1*A2*MB*MT*P2Q1/S-96*A2**2*MB*MT*P2Q1/S + V910=V910+96*A1*A2*P1P2*P2Q1/S- + &96*A2**2*P1P2*P2Q1/S+96*A12*P1Q2*P2Q1/S+ + &192*A1*A2*P1Q2*P2Q1/S+96*A2**2*P1Q2*P2Q1/S+ + &96*A1*A2*MB*MT*P2Q2/S-96*A2**2*MB*MT*P2Q2/S+ + &96*A1*A2*P1P2*P2Q2/S-96*A2**2*P1P2*P2Q2/S+96*A12*P1Q1*P2Q2/S+ + &192*A1*A2*P1Q1*P2Q2/S+96*A2**2*P1Q1*P2Q2/S +C + A910 = 48*A12*MB*MT+48*A2**2*MB*MT-48*A12*P1P2-48*A2**2*P1P2+ + &384*A12*MB*MT*P1Q1*P1Q2/S**2-384*A12*P1P2*P1Q1*P1Q2/S**2+ + &384*A1*A2*MB*MT*P1Q2*P2Q1/S**2-384*A1*A2*P1P2*P1Q2*P2Q1/S**2+ + &192*A12*P1Q1*P1Q2*P2Q1/S**2+192*A1*A2*P1Q1*P1Q2*P2Q1/S**2- + &192*A12*P1Q2**2*P2Q1/S**2-192*A1*A2*P1Q2**2*P2Q1/S**2+ + &192*A1*A2*P1Q2*P2Q1**2/S**2+192*A2**2*P1Q2*P2Q1**2/S**2+ + &384*A1*A2*MB*MT*P1Q1*P2Q2/S**2-384*A1*A2*P1P2*P1Q1*P2Q2/S**2- + &192*A12*P1Q1**2*P2Q2/S**2-192*A1*A2*P1Q1**2*P2Q2/S**2+ + &192*A12*P1Q1*P1Q2*P2Q2/S**2+192*A1*A2*P1Q1*P1Q2*P2Q2/S**2+ + &384*A2**2*MB*MT*P2Q1*P2Q2/S**2-384*A2**2*P1P2*P2Q1*P2Q2/S**2- + &192*A1*A2*P1Q1*P2Q1*P2Q2/S**2-192*A2**2*P1Q1*P2Q1*P2Q2/S**2- + &192*A1*A2*P1Q2*P2Q1*P2Q2/S**2-192*A2**2*P1Q2*P2Q1*P2Q2/S**2+ + &192*A1*A2*P1Q1*P2Q2**2/S**2+192*A2**2*P1Q1*P2Q2**2/S**2- + &96*A12*MB*MT*P1Q1/S+96*A1*A2*MB*MT*P1Q1/S+ + &96*A12*P1P2*P1Q1/S-96*A1*A2*P1P2*P1Q1/S-96*A12*MB*MT*P1Q2/S+ + &96*A1*A2*MB*MT*P1Q2/S+96*A12*P1P2*P1Q2/S-96*A1*A2*P1P2*P1Q2/S- + &96*A1*A2*MB*MT*P2Q1/S+96*A2**2*MB*MT*P2Q1/S + A910=A910+96*A1*A2*P1P2*P2Q1/S- + &96*A2**2*P1P2*P2Q1/S+96*A12*P1Q2*P2Q1/S+ + &192*A1*A2*P1Q2*P2Q1/S+96*A2**2*P1Q2*P2Q1/S- + &96*A1*A2*MB*MT*P2Q2/S+96*A2**2*MB*MT*P2Q2/S+ + &96*A1*A2*P1P2*P2Q2/S-96*A2**2*P1P2*P2Q2/S+96*A12*P1Q1*P2Q2/S+ + &192*A1*A2*P1Q1*P2Q2/S+96*A2**2*P1Q1*P2Q2/S +C +C FINAL RESULT; +C + AMP2= FACT*PS*VTB**2*(V**2 *(V18 +V910)+A**2 *(A18+A910) ) + + END +C--------------------------------------------------------- +C 2) Q QBAR ->TBH^+ + SUBROUTINE PYTBHQ(Q1,Q2,P1,P2,P3,MT,MB,RMB,MHP,AMP2) +C +C AMP2(OUTPUT) =MATRIX ELEMENT (AMPLITUDE**2) FOR Q QBAR->TB H^+ +C (NB SAME STRUCTURE AS FOR PYTBHG ROUTINE ABOVE) + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + DOUBLE PRECISION MW2,MT,MB,MHP,MW + DIMENSION Q1(4),Q2(4),P1(4),P2(4),P3(4) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) + COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A + SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYCTBH/ +C !THE RELEVANT INPUT PARAMETERS ABOVE ARE NEEDED FOR CALCULATION +C BUT ARE NOT DEFINED HERE SO THAT ONE MAY CHOOSE/VARY THEIR VALUES: +C ACCORDINGLY, WHEN CALLING THESE SUBROUTINES, PLEASE SUPPLY VIA +C THIS COMMON/PARAM/ YOUR PREFERRED ALPHA, ALPHAS,..AND TANB VALUES +C +C THE NORMALIZED V,A COUPLINGS ARE DEFINED BELOW AND USED BOTH +C IN THIS ROUTINE AND IN THE TOP WIDTH CALCULATION PYTBHB(..). +C + DIMENSION YY(2,2) + + PI = 4*DATAN(1.D0) + MW = DSQRT(MW2) + +C COLLECTING THE RELEVANT OVERALL FACTORS: +C 3X3 INITIAL QUARK COLOR AVERAGE, 2X2 QUARK SPIN AVERAGE + PS=1.D0/(3.D0*3.D0 *2.D0*2.D0) +C COUPLING CONSTANT (OVERALL NORMALIZATION) + FACT=(4.D0*PI*ALPHA)*(4.D0*PI*ALPHAS)**2/SW2/2.D0 +C NB ALPHA IS E^2/4/PI, BUT BETTER DEFINED IN TERMS OF G_FERMI: +C ALPHA= DSQRT(2.D0)*GF*SW2*MW**2/PI +C ALPHAS IS ALPHA_STRONG; +C SW2 IS SIN(THETA_W)**2. +C +C VTB=.998D0 +C VTB IS TOP-BOTTOM CKM MATRIX ELEMENT (APPROXIMATE VALUE HERE) +C + V = ( MT/MW/TANB +RMB/MW*TANB)/2.D0 + A = (-MT/MW/TANB +RMB/MW*TANB)/2.D0 +C V AND A ARE (NORMALIZED) VECTOR AND AXIAL TBH^+ COUPLINGS +C +C REDEFINING P2 INGOING FROM OVERALL MOMENTUM CONSERVATION +C (BECAUSE P2 INGOING WAS USED IN OUR GRAPH CALCULATION CONVENTIONS) + DO 100 KK=1,4 + P2(KK)=P3(KK)-Q1(KK)-Q2(KK)+P1(KK) + 100 CONTINUE +C DEFINING VARIOUS RELEVANT 4-SCALAR PRODUCTS: + S = 2*PYTBHS(Q1,Q2) + P1Q1=PYTBHS(Q1,P1) + P1Q2=PYTBHS(P1,Q2) + P2Q1=PYTBHS(P2,Q1) + P2Q2=PYTBHS(P2,Q2) + P1P2=PYTBHS(P1,P2) +C +C TOP WIDTH CALCULATION + CALL PYTBHB(MT,MB,MHP,BR,GAMT) +C GAMT IS THE TOP WIDTH: T->BH^+ AND/OR T->B W^+ +C THEN DEFINE TOP (RESONANT) PROPAGATOR: + A1INV= S -2*P1Q1 -2*P1Q2 + A1 =A1INV/(A1INV**2+ (GAMT*MT)**2) +C (I.E. INTRODUCE THE TOP WIDTH IN A1 TO REGULARISE THE POLE) +C NB A12 = A1*A1 BUT WITH CORRECT WIDTH TREATMENT + A12 = 1.D0/(A1INV**2+ (GAMT*MT)**2) + A2 =1.D0/(S +2*P2Q1 +2*P2Q2) +C NOTE A2 IS B PROPAGATOR, DOES NOT NEED A WIDTH +C NOW COMES THE AMP**2: +C NB COLOR FACTOR (COMING FORM GRAPHS) ALREADY INCLUDED IN +C THE EXPRESSIONS BELOW + YY(1, 1) = -16*A**2*A2**2*MB*MT+ + &64*A**2*A2**2*P1Q2*P2Q1**2/S**2+ + &128*A**2*A2**2*MB*MT*P2Q1*P2Q2/S**2- + &128*A**2*A2**2*P1P2*P2Q1*P2Q2/S**2- + &64*A**2*A2**2*P1Q1*P2Q1*P2Q2/S**2- + &64*A**2*A2**2*P1Q2*P2Q1*P2Q2/S**2+ + &64*A**2*A2**2*P1Q1*P2Q2**2/S**2- + &32*A**2*A2**2*MB**3*MT/S+32*A**2*A2**2*MB**2*P1P2/S+ + &32*A**2*A2**2*MB**2*P1Q1/S+32*A**2*A2**2*MB**2*P1Q2/S- + &32*A**2*A2**2*P1P2*P2Q1/S-32*A**2*A2**2*P1Q1*P2Q1/S- + &32*A**2*A2**2*P1P2*P2Q2/S-32*A**2*A2**2*P1Q2*P2Q2/S+ + &16*A2**2*MB*MT*V**2+64*A2**2*P1Q2*P2Q1**2*V**2/S**2- + &128*A2**2*MB*MT*P2Q1*P2Q2*V**2/S**2- + &128*A2**2*P1P2*P2Q1*P2Q2*V**2/S**2- + &64*A2**2*P1Q1*P2Q1*P2Q2*V**2/S**2- + &64*A2**2*P1Q2*P2Q1*P2Q2*V**2/S**2+ + &64*A2**2*P1Q1*P2Q2**2*V**2/S**2 + YY(1, 1)=YY(1, 1)+32*A2**2*MB**3*MT*V**2/S+ + &32*A2**2*MB**2*P1P2*V**2/S+ + &32*A2**2*MB**2*P1Q1*V**2/S+32*A2**2*MB**2*P1Q2*V**2/S- + &32*A2**2*P1P2*P2Q1*V**2/S-32*A2**2*P1Q1*P2Q1*V**2/S- + &32*A2**2*P1P2*P2Q2*V**2/S-32*A2**2*P1Q2*P2Q2*V**2/S + YY(1, 1)=2*YY(1, 1) + + YY(1, 2) = -32*A**2*A1*A2*MB*MT+ + &128*A**2*A1*A2*MB*MT*P1Q2*P2Q1/S**2- + &128*A**2*A1*A2*P1P2*P1Q2*P2Q1/S**2+ + &64*A**2*A1*A2*P1Q1*P1Q2*P2Q1/S**2- + &64*A**2*A1*A2*P1Q2**2*P2Q1/S**2+ + &64*A**2*A1*A2*P1Q2*P2Q1**2/S**2+ + &128*A**2*A1*A2*MB*MT*P1Q1*P2Q2/S**2- + &128*A**2*A1*A2*P1P2*P1Q1*P2Q2/S**2- + &64*A**2*A1*A2*P1Q1**2*P2Q2/S**2+ + &64*A**2*A1*A2*P1Q1*P1Q2*P2Q2/S**2- + &64*A**2*A1*A2*P1Q1*P2Q1*P2Q2/S**2- + &64*A**2*A1*A2*P1Q2*P2Q1*P2Q2/S**2+ + &64*A**2*A1*A2*P1Q1*P2Q2**2/S**2- + &64*A**2*A1*A2*MB*MT*P1P2/S+ + &64*A**2*A1*A2*P1P2**2/S+32*A**2*A1*A2*MB**2*P1Q1/S+ + &32*A**2*A1*A2*P1P2*P1Q1/S+32*A**2*A1*A2*MB**2*P1Q2/S+ + &32*A**2*A1*A2*P1P2*P1Q2/S-32*A**2*A1*A2*MT**2*P2Q1/S + YY(1, 2)=YY(1, 2)-32*A**2*A1*A2*P1P2*P2Q1/S- + &64*A**2*A1*A2*P1Q1*P2Q1/S- + &32*A**2*A1*A2*MT**2*P2Q2/S-32*A**2*A1*A2*P1P2*P2Q2/S- + &64*A**2*A1*A2*P1Q2*P2Q2/S+32*A1*A2*MB*MT*V**2- + &128*A1*A2*MB*MT*P1Q2*P2Q1*V**2/S**2 - + &128*A1*A2*P1P2*P1Q2*P2Q1*V**2/S**2+ + &64*A1*A2*P1Q1*P1Q2*P2Q1*V**2/S**2- + &64*A1*A2*P1Q2**2*P2Q1*V**2/S**2+ + &64*A1*A2*P1Q2*P2Q1**2*V**2/S**2- + &128*A1*A2*MB*MT*P1Q1*P2Q2*V**2/S**2- + &128*A1*A2*P1P2*P1Q1*P2Q2*V**2/S**2- + &64*A1*A2*P1Q1**2*P2Q2*V**2/S**2+ + &64*A1*A2*P1Q1*P1Q2*P2Q2*V**2/S**2- + &64*A1*A2*P1Q1*P2Q1*P2Q2*V**2/S**2- + &64*A1*A2*P1Q2*P2Q1*P2Q2*V**2/S**2+ + &64*A1*A2*P1Q1*P2Q2**2*V**2/S**2+ + &64*A1*A2*MB*MT*P1P2*V**2/S+64*A1*A2*P1P2**2*V**2/S + YY(1, 2)=YY(1, 2)+32*A1*A2*MB**2*P1Q1*V**2/S+ + &32*A1*A2*P1P2*P1Q1*V**2/S+ + &32*A1*A2*MB**2*P1Q2*V**2/S+32*A1*A2*P1P2*P1Q2*V**2/S- + &32*A1*A2*MT**2*P2Q1*V**2/S-32*A1*A2*P1P2*P2Q1*V**2/S- + &64*A1*A2*P1Q1*P2Q1*V**2/S-32*A1*A2*MT**2*P2Q2*V**2/S- + &32*A1*A2*P1P2*P2Q2*V**2/S-64*A1*A2*P1Q2*P2Q2*V**2/S + + + YY(2, 2) =-16*A**2*A12*MB*MT+ + &128*A**2*A12*MB*MT*P1Q1*P1Q2/S**2- + &128*A**2*A12*P1P2*P1Q1*P1Q2/S**2+ + &64*A**2*A12*P1Q1*P1Q2*P2Q1/S**2- + &64*A**2*A12*P1Q2**2*P2Q1/S**2-64*A**2*A12*P1Q1**2*P2Q2/S**2+ + &64*A**2*A12*P1Q1*P1Q2*P2Q2/S**2-32*A**2*A12*MB*MT**3/S+ + &32*A**2*A12*MT**2*P1P2/S+32*A**2*A12*P1P2*P1Q1/S+ + &32*A**2*A12*P1P2*P1Q2/S-32*A**2*A12*MT**2*P2Q1/S- + &32*A**2*A12*P1Q1*P2Q1/S-32*A**2*A12*MT**2*P2Q2/S- + &32*A**2*A12*P1Q2*P2Q2/S+16*A12*MB*MT*V**2- + &128*A12*MB*MT*P1Q1*P1Q2*V**2/S**2- + &128*A12*P1P2*P1Q1*P1Q2*V**2/S**2+ + &64*A12*P1Q1*P1Q2*P2Q1*V**2/S**2- + &64*A12*P1Q2**2*P2Q1*V**2/S**2-64*A12*P1Q1**2*P2Q2*V**2/S**2+ + &64*A12*P1Q1*P1Q2*P2Q2*V**2/S**2+32*A12*MB*MT**3*V**2/S+ + &32*A12*MT**2*P1P2*V**2/S+32*A12*P1P2*P1Q1*V**2/S+ + &32*A12*P1P2*P1Q2*V**2/S-32*A12*MT**2*P2Q1*V**2/S + YY(2, 2)=YY(2, 2)-32*A12*P1Q1*P2Q1*V**2/S- + &32*A12*MT**2*P2Q2*V**2/S- + &32*A12*P1Q2*P2Q2*V**2/S + YY(2, 2)=2*YY(2, 2) + + RES=YY(1,1)+2*YY(1,2)+YY(2,2) + AMP2= FACT*PS*VTB**2*RES + + END +C===================================================================== +C ************* FUNCTION SCALAR PRODUCTS ************************* + DOUBLE PRECISION FUNCTION PYTBHS(A,B) + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + DIMENSION A(4),B(4) + DUM=A(4)*B(4) + DO 100 ID=1,3 + DUM=DUM-A(ID)*B(ID) + 100 CONTINUE + PYTBHS=DUM + RETURN + END + +C********************************************************************* + +C...PYMSIN +C...Initializes supersymmetry: finds sparticle masses and +C...branching ratios and stores this information. +C...AUTHOR: STEPHEN MRENNA +C...Author: P. Skands (SLHA + RPV + ISASUSY Interface, NMSSM) + + SUBROUTINE PYMSIN + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + COMMON/PYDAT4/CHAF(500,2) + CHARACTER CHAF*16 + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT4/MWID(500),WIDS(500,5) + COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) + COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3) + COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), + &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) + COMMON/PYHTRI/HHH(7) + COMMON/PYQNUM/NQNUM,NQDUM,KQNUM(500,0:9) + SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYPARS/,/PYINT4/, + &/PYMSSM/,/PYMSRV/,/PYSSMT/ + +C...Local variables. + DOUBLE PRECISION ALFA,BETA + DOUBLE PRECISION TANB,AL,BE,COSA,COSB,SINA,SINB,XW + INTEGER I,J,J1,I1,K1 + INTEGER KC,LKNT,IDLAM(400,3) + DOUBLE PRECISION XLAM(0:400) + DOUBLE PRECISION WDTP(0:400),WDTE(0:400,0:5) + DOUBLE PRECISION XARG,COS2B,XMW2,XMZ2 + DOUBLE PRECISION DELM,XMDIF + DOUBLE PRECISION DX,DY,DS,DMU2,DMA2,DQ2,DU2,DD2,DL2,DE2,DHU2,DHD2 + DOUBLE PRECISION ARG,SGNMU,R + INTEGER IMSSM + INTEGER IRPRTY + INTEGER KFSUSY(50),MWIDSU(36),MDCYSU(36) + SAVE MWIDSU,MDCYSU + DATA KFSUSY/ + &1000001,2000001,1000002,2000002,1000003,2000003, + &1000004,2000004,1000005,2000005,1000006,2000006, + &1000011,2000011,1000012,2000012,1000013,2000013, + &1000014,2000014,1000015,2000015,1000016,2000016, + &1000021,1000022,1000023,1000025,1000035,1000024, + &1000037,1000039, 25, 35, 36, 37, + & 6, 24, 45, 46,1000045, 9*0/ + DATA INIT/0/ + +C...Automatically read QNUMBERS, MASS, and DECAY tables + IF (IMSS(21).NE.0.OR.MSTP(161).NE.0) THEN + NQNUM=0 + CALL PYSLHA(0,0,IFAIL) + CALL PYSLHA(5,0,IFAIL) + ENDIF + IF (IMSS(22).NE.0.OR.MSTP(161).NE.0) CALL PYSLHA(2,0,IFAIL) + +C...Do nothing further if SUSY not requested + IMSSM=IMSS(1) + IF(IMSSM.EQ.0) RETURN + +C...Save copy of MWID(KC) and MDCY(KC,1) values before +C...they are set to zero for the LSP. + IF(INIT.EQ.0) THEN + INIT=1 + DO 100 I=1,36 + KF=KFSUSY(I) + KC=PYCOMP(KF) + MWIDSU(I)=MWID(KC) + MDCYSU(I)=MDCY(KC,1) + 100 CONTINUE + ENDIF + +C...Restore MWID(KC) and MDCY(KC,1) values previously zeroed for LSP. + DO 110 I=1,36 + KF=KFSUSY(I) + KC=PYCOMP(KF) + IF(MDCY(KC,1).EQ.0.AND.MDCYSU(I).NE.0) THEN + MWID(KC)=MWIDSU(I) + MDCY(KC,1)=MDCYSU(I) + ENDIF + 110 CONTINUE + +C...First part of routine: set masses and couplings. + +C...Reset mixing values in sfermion sector to pure left/right. + DO 120 I=1,16 + SFMIX(I,1)=1D0 + SFMIX(I,4)=1D0 + SFMIX(I,2)=0D0 + SFMIX(I,3)=0D0 + 120 CONTINUE + +C...Add NMSSM states if NMSSM switched on, and change old names. + IF (IMSS(13).NE.0.AND.PYCOMP(1000045).EQ.0) THEN +C... Switch on NMSSM + WRITE(MSTU(11),*) '(PYMSIN:) switching on NMSSM' + + KFN=25 + KCN=KFN + CHAF(KCN,1)='h_10' + CHAF(KCN,2)=' ' + + KFN=35 + KCN=KFN + CHAF(KCN,1)='h_20' + CHAF(KCN,2)=' ' + + KFN=45 + KCN=KFN + CHAF(KCN,1)='h_30' + CHAF(KCN,2)=' ' + + KFN=36 + KCN=KFN + CHAF(KCN,1)='A_10' + CHAF(KCN,2)=' ' + + KFN=46 + KCN=KFN + CHAF(KCN,1)='A_20' + CHAF(KCN,2)=' ' + + KFN=1000045 + KCN=PYCOMP(KFN) + IF (KCN.EQ.0) THEN + DO 123 KCT=100,MSTU(6) + IF(KCHG(KCT,4).GT.100) KCN=KCT + 123 CONTINUE + KCN=KCN+1 + KCHG(KCN,4)=KFN + MSTU(20)=0 + ENDIF +C... Set stable for now + PMAS(KCN,2)=1D-6 + MWID(KCN)=0 + MDCY(KCN,1)=0 + MDCY(KCN,2)=0 + MDCY(KCN,3)=0 + CHAF(KCN,1)='~chi_50' + CHAF(KCN,2)=' ' + ENDIF + +C...Read spectrum from SLHA file. + IF (IMSSM.EQ.11) THEN + CALL PYSLHA(1,0,IFAIL) + ENDIF + +C...Common couplings. + TANB=RMSS(5) + BETA=ATAN(TANB) + COSB=COS(BETA) + SINB=TANB*COSB + COS2B=COS(2D0*BETA) + ALFA=RMSS(18) + XMW2=PMAS(24,1)**2 + XMZ2=PMAS(23,1)**2 + XW=PARU(102) + +C...Define sparticle masses for a general MSSM simulation. + IF(IMSSM.EQ.1) THEN + IF(IMSS(9).EQ.0) RMSS(22)=RMSS(9) + DO 130 I=1,5,2 + KC=PYCOMP(KSUSY1+I) + PMAS(KC,1)=SQRT(RMSS(8)**2-(2D0*XMW2+XMZ2)*COS2B/6D0) + KC=PYCOMP(KSUSY2+I) + PMAS(KC,1)=SQRT(RMSS(9)**2+(XMW2-XMZ2)*COS2B/3D0) + KC=PYCOMP(KSUSY1+I+1) + PMAS(KC,1)=SQRT(RMSS(8)**2+(4D0*XMW2-XMZ2)*COS2B/6D0) + KC=PYCOMP(KSUSY2+I+1) + PMAS(KC,1)=SQRT(RMSS(22)**2-(XMW2-XMZ2)*COS2B*2D0/3D0) + 130 CONTINUE + XARG=RMSS(6)**2-PMAS(24,1)**2*ABS(COS(2D0*BETA)) + IF(XARG.LT.0D0) THEN + WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'// + & ' FROM THE SUM RULE. ' + WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). ' + RETURN + ELSE + XARG=SQRT(XARG) + ENDIF + DO 140 I=11,15,2 + PMAS(PYCOMP(KSUSY1+I),1)=RMSS(6) + PMAS(PYCOMP(KSUSY2+I),1)=RMSS(7) + PMAS(PYCOMP(KSUSY1+I+1),1)=XARG + PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0 + 140 CONTINUE + IF(IMSS(8).EQ.1) THEN + RMSS(13)=RMSS(6) + RMSS(14)=RMSS(7) + ENDIF + +C...Alternatively derive masses from SUGRA relations. + ELSEIF(IMSSM.EQ.2) THEN + RMSS(36)=RMSS(16) + CALL PYAPPS +C...Or use ISASUSY + ELSEIF(IMSSM.EQ.12.OR.IMSSM.EQ.13) THEN + RMSS(36)=RMSS(16) + CALL PYSUGI + ALFA=RMSS(18) + GOTO 170 + ELSE + GOTO 170 + ENDIF + +C...Add in extra D-term contributions. + IF(IMSS(7).EQ.1) THEN + R=0.43D0 + DX=RMSS(23) + DY=RMSS(24) + DS=RMSS(25) + WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC' + WRITE(MSTU(11),*) 'C NEW DTERMS ADDED TO SCALAR MASSES ' + WRITE(MSTU(11),*) 'C IN A U(B-L) THEORY ' + WRITE(MSTU(11),*) 'C DX = ',DX + WRITE(MSTU(11),*) 'C DY = ',DY + WRITE(MSTU(11),*) 'C DS = ',DS + WRITE(MSTU(11),*) 'C ' + DY=R*DY-4D0/33D0*(1D0-R)*DX+(1D0-R)/33D0*DS + WRITE(MSTU(11),*) 'C DY AT THE WEAK SCALE = ',DY + WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC' + DQ2=DY/6D0-DX/3D0-DS/3D0 + DU2=-2D0*DY/3D0-DX/3D0-DS/3D0 + DD2=DY/3D0+DX-2D0*DS/3D0 + DL2=-DY/2D0+DX-2D0*DS/3D0 + DE2=DY-DX/3D0-DS/3D0 + DHU2=DY/2D0+2D0*DX/3D0+2D0*DS/3D0 + DHD2=-DY/2D0-2D0*DX/3D0+DS + DMU2=(-DY/2D0-2D0/3D0*DX+(COSB**2-2D0*SINB**2/3D0)*DS) + & /ABS(COS2B) + DMA2 = 2D0*DMU2+DHU2+DHD2 + DO 150 I=1,5,2 + KC=PYCOMP(KSUSY1+I) + PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2) + KC=PYCOMP(KSUSY2+I) + PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DD2) + KC=PYCOMP(KSUSY1+I+1) + PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2) + KC=PYCOMP(KSUSY2+I+1) + PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DU2) + 150 CONTINUE + DO 160 I=11,15,2 + KC=PYCOMP(KSUSY1+I) + PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2) + KC=PYCOMP(KSUSY2+I) + PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DE2) + KC=PYCOMP(KSUSY1+I+1) + PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2) + 160 CONTINUE + IF(RMSS(4)**2+DMU2.LT.0D0) THEN + WRITE(MSTU(11),*) ' MU2 DRIVEN NEGATIVE ' + CALL PYSTOP(104) + ENDIF + SGNMU=SIGN(1D0,RMSS(4)) + RMSS(4)=SGNMU*SQRT(RMSS(4)**2+DMU2) + ARG=RMSS(10)**2*SIGN(1D0,RMSS(10))+DQ2 + RMSS(10)=SIGN(SQRT(ABS(ARG)),ARG) + ARG=RMSS(11)**2*SIGN(1D0,RMSS(11))+DD2 + RMSS(11)=SIGN(SQRT(ABS(ARG)),ARG) + ARG=RMSS(12)**2*SIGN(1D0,RMSS(12))+DU2 + RMSS(12)=SIGN(SQRT(ABS(ARG)),ARG) + ARG=RMSS(13)**2*SIGN(1D0,RMSS(13))+DL2 + RMSS(13)=SIGN(SQRT(ABS(ARG)),ARG) + ARG=RMSS(14)**2*SIGN(1D0,RMSS(14))+DE2 + RMSS(14)=SIGN(SQRT(ABS(ARG)),ARG) + IF( RMSS(19)**2 + DMA2 .LE. 50D0 ) THEN + WRITE(MSTU(11),*) ' MA DRIVEN TOO LOW ' + CALL PYSTOP(104) + ENDIF + RMSS(19)=SQRT(RMSS(19)**2+DMA2) + RMSS(6)=SQRT(RMSS(6)**2+DL2) + RMSS(7)=SQRT(RMSS(7)**2+DE2) + WRITE(MSTU(11),*) ' MTL = ',RMSS(10) + WRITE(MSTU(11),*) ' MBR = ',RMSS(11) + WRITE(MSTU(11),*) ' MTR = ',RMSS(12) + WRITE(MSTU(11),*) ' SEL = ',RMSS(6),RMSS(13) + WRITE(MSTU(11),*) ' SER = ',RMSS(7),RMSS(14) + ENDIF + +C...Fix the third generation sfermions. + CALL PYTHRG + +C...Fix the neutralino--chargino--gluino sector. + CALL PYINOM + +C...Fix the Higgs sector. + CALL PYHGGM(ALFA) + +C...Choose the Gunion-Haber convention. + ALFA=-ALFA + RMSS(18)=ALFA + +C...Print information on mass parameters. + IF(IMSSM.EQ.2.AND.MSTP(122).GT.0) THEN + WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC' + WRITE(MSTU(11),*) ' USING APPROXIMATE SUGRA RELATIONS ' + WRITE(MSTU(11),*) ' M0 = ',RMSS(8) + WRITE(MSTU(11),*) ' M1/2=',RMSS(1) + WRITE(MSTU(11),*) ' TANB=',RMSS(5) + WRITE(MSTU(11),*) ' MU = ',RMSS(4) + WRITE(MSTU(11),*) ' AT = ',RMSS(16) + WRITE(MSTU(11),*) ' MA = ',RMSS(19) + WRITE(MSTU(11),*) ' MTOP=',PMAS(6,1) + WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC' + ENDIF + IF(IMSS(20).EQ.1) THEN + WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC' + WRITE(MSTU(11),*) ' DEBUG MODE ' + WRITE(MSTU(11),*) ' UMIX = ',UMIX(1,1),UMIX(1,2), + & UMIX(2,1),UMIX(2,2) + WRITE(MSTU(11),*) ' UMIXI = ',UMIXI(1,1),UMIXI(1,2), + & UMIXI(2,1),UMIXI(2,2) + WRITE(MSTU(11),*) ' VMIX = ',VMIX(1,1),VMIX(1,2), + & VMIX(2,1),VMIX(2,2) + WRITE(MSTU(11),*) ' VMIXI = ',VMIXI(1,1),VMIXI(1,2), + & VMIXI(2,1),VMIXI(2,2) + WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(1,I),I=1,4) + WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(1,I),I=1,4) + WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(2,I),I=1,4) + WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(2,I),I=1,4) + WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(3,I),I=1,4) + WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(3,I),I=1,4) + WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(4,I),I=1,4) + WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(4,I),I=1,4) + WRITE(MSTU(11),*) ' ALFA = ',ALFA + WRITE(MSTU(11),*) ' BETA = ',BETA + WRITE(MSTU(11),*) ' STOP = ',(SFMIX(6,I),I=1,4) + WRITE(MSTU(11),*) ' SBOT = ',(SFMIX(5,I),I=1,4) + WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC' + ENDIF + +C...Set up the Higgs couplings - needed here since initialization +C...in PYINRE did not yet occur when PYWIDT is called below. + 170 AL=ALFA + BE=BETA + SINA=SIN(AL) + COSA=COS(AL) + COSB=COS(BE) + SINB=TANB*COSB + SBMA=SIN(BE-AL) + SAPB=SIN(AL+BE) + CAPB=COS(AL+BE) + CBMA=COS(BE-AL) + C2A=COS(2D0*AL) + C2B=COSB**2-SINB**2 +C...tanb (used for H+) + PARU(141)=TANB + +C...Firstly: h +C...Coupling to d-type quarks + PARU(161)=SINA/COSB +C...Coupling to u-type quarks + PARU(162)=-COSA/SINB +C...Coupling to leptons + PARU(163)=PARU(161) +C...Coupling to Z + PARU(164)=SBMA +C...Coupling to W + PARU(165)=PARU(164) + +C...Secondly: H +C...Coupling to d-type quarks + PARU(171)=-COSA/COSB +C...Coupling to u-type quarks + PARU(172)=-SINA/SINB +C...Coupling to leptons + PARU(173)=PARU(171) +C...Coupling to Z + PARU(174)=CBMA +C...Coupling to W + PARU(175)=PARU(174) +C...Coupling to h + IF(IMSS(4).GE.2) THEN + PARU(176)=COS(2D0*AL)*COS(BE+AL)-2D0*SIN(2D0*AL)*SIN(BE+AL) + ELSE + HHH(3)=HHH(3)+HHH(4)+HHH(5) + PARU(176)=-3D0/HHH(1)*(HHH(1)*SINA**2*COSB*COSA+ + 1 HHH(2)*COSA**2*SINB*SINA+HHH(3)*(SINA**3*SINB+COSA**3*COSB- + 2 2D0/3D0*CBMA)-HHH(6)*SINA*(COSB*C2A+COSA*CAPB)+ + 3 HHH(7)*COSA*(SINB*C2A+SINA*CAPB)) + ENDIF +C...Coupling to H+ +C...Define later + IF(IMSS(4).GE.2) THEN + PARU(168)=-SBMA-COS(2D0*BE)*SAPB/2D0/(1D0-XW) + ELSE + PARU(168)=1D0/HHH(1)*(HHH(1)*SINB**2*COSB*SINA- + 1 HHH(2)*COSB**2*SINB*COSA-HHH(3)*(SINB**3*COSA-COSB**3*SINA)+ + 2 2D0*HHH(5)*SBMA-HHH(6)*SINB*(COSB*SAPB+SINA*C2B)- + 3 HHH(7)*COSB*(COSA*C2B-SINB*SAPB)-(HHH(5)-HHH(4))*SBMA) + ENDIF +C...Coupling to A + IF(IMSS(4).GE.2) THEN + PARU(177)=COS(2D0*BE)*COS(BE+AL) + ELSE + PARU(177)=-1D0/HHH(1)*(HHH(1)*SINB**2*COSB*COSA+ + 1 HHH(2)*COSB**2*SINB*SINA+HHH(3)*(SINB**3*SINA+COSB**3*COSA)- + 2 2D0*HHH(5)*CBMA-HHH(6)*SINB*(COSB*CAPB+COSA*C2B)+ + 3 HHH(7)*COSB*(SINB*CAPB+SINA*C2B)) + ENDIF +C...Coupling to H+ + IF(IMSS(4).GE.2) THEN + PARU(178)=PARU(177) + ELSE + PARU(178)=PARU(177)-(HHH(5)-HHH(4))/HHH(1)*CBMA + ENDIF +C...Thirdly, A +C...Coupling to d-type quarks + PARU(181)=TANB +C...Coupling to u-type quarks + PARU(182)=1D0/PARU(181) +C...Coupling to leptons + PARU(183)=PARU(181) + PARU(184)=0D0 + PARU(185)=0D0 +C...Coupling to Z h + PARU(186)=COS(BE-AL) +C...Coupling to Z H + PARU(187)=SIN(BE-AL) + PARU(188)=0D0 + PARU(189)=0D0 + PARU(190)=0D0 + +C...Finally: H+ +C...Coupling to W h + PARU(195)=COS(BE-AL) + +C...Tell that all Higgs couplings have been set. + MSTP(4)=1 + +C...Set R-Violating couplings. +C...Set lambda couplings to common value or "natural values". + IF ((IMSS(51).NE.3).AND.(IMSS(51).NE.0)) THEN + VIR3=1D0/(126D0)**3 + DO 200 IRK=1,3 + DO 190 IRI=1,3 + DO 180 IRJ=1,3 + IF (IRI.NE.IRJ) THEN + IF (IRI.LT.IRJ) THEN + RVLAM(IRI,IRJ,IRK)=RMSS(51) + IF (IMSS(51).EQ.2) RVLAM(IRI,IRJ,IRK)=RMSS(51)* + & SQRT(PMAS(9+2*IRI,1)*PMAS(9+2*IRJ,1)* + & PMAS(9+2*IRK,1)*VIR3) + ELSE + RVLAM(IRI,IRJ,IRK)=-RVLAM(IRJ,IRI,IRK) + ENDIF + ELSE + RVLAM(IRI,IRJ,IRK)=0D0 + ENDIF + 180 CONTINUE + 190 CONTINUE + 200 CONTINUE + ENDIF +C...Set lambda' couplings to common value or "natural values". + IF ((IMSS(52).NE.3).AND.(IMSS(52).NE.0)) THEN + VIR3=1D0/(126D0)**3 + DO 230 IRI=1,3 + DO 220 IRJ=1,3 + DO 210 IRK=1,3 + RVLAMP(IRI,IRJ,IRK)=RMSS(52) + IF (IMSS(52).EQ.2) RVLAMP(IRI,IRJ,IRK)=RMSS(52)* + & SQRT(PMAS(9+2*IRI,1)*0.5D0*(PMAS(2*IRJ,1)+ + & PMAS(2*IRJ-1,1))*PMAS(2*IRK-1,1)*VIR3) + 210 CONTINUE + 220 CONTINUE + 230 CONTINUE + ENDIF +C...Set lambda'' couplings to common value or "natural values". + IF ((IMSS(53).NE.3).AND.(IMSS(53).NE.0)) THEN + VIR3=1D0/(126D0)**3 + DO 260 IRI=1,3 + DO 250 IRJ=1,3 + DO 240 IRK=1,3 + IF (IRJ.NE.IRK) THEN + IF (IRJ.LT.IRK) THEN + RVLAMB(IRI,IRJ,IRK)=RMSS(53) + IF (IMSS(53).EQ.2) RVLAMB(IRI,IRJ,IRK)= + & RMSS(53)*SQRT(PMAS(2*IRI,1)*PMAS(2*IRJ-1,1)* + & PMAS(2*IRK-1,1)*VIR3) + ELSE + RVLAMB(IRI,IRJ,IRK)=-RVLAMB(IRI,IRK,IRJ) + ENDIF + ELSE + RVLAMB(IRI,IRJ,IRK) = 0D0 + ENDIF + 240 CONTINUE + 250 CONTINUE + 260 CONTINUE + ENDIF + +C...Antisymmetrize couplings set by user + IF (IMSS(51).EQ.3.OR.IMSS(53).EQ.3) THEN + DO 290 IRI=1,3 + DO 280 IRJ=1,3 + DO 270 IRK=1,3 + IF (RVLAM(IRI,IRJ,IRK).NE.-RVLAM(IRJ,IRI,IRK)) THEN + RVLAM(IRJ,IRI,IRK)=-RVLAM(IRI,IRJ,IRK) + IF (IRI.EQ.IRJ) RVLAM(IRI,IRJ,IRK)=0D0 + ENDIF + IF (RVLAMB(IRI,IRJ,IRK).NE.-RVLAMB(IRI,IRK,IRJ)) THEN + RVLAMB(IRI,IRK,IRJ)=-RVLAMB(IRI,IRJ,IRK) + IF (IRJ.EQ.IRK) RVLAMB(IRI,IRJ,IRK)=0D0 + ENDIF + 270 CONTINUE + 280 CONTINUE + 290 CONTINUE + ENDIF + +C...Write spectrum to SLHA file + IF (IMSS(23).NE.0) THEN + IFAIL=0 + CALL PYSLHA(3,0,IFAIL) + ENDIF + +C...Second part of routine: set decay modes and branching ratios. + +C...Allow chi10 -> gravitino + gamma or not. + KC=PYCOMP(KSUSY1+39) + IF( IMSS(11) .NE. 0 ) THEN + PMAS(KC,1)=RMSS(21)/1D9 + PMAS(KC,2)=0D0 + IRPRTY=0 + WRITE(MSTU(11),*) ' ALLOWING DECAYS TO GRAVITINOS ' + ELSE IF (IMSS(51).GE.1.OR.IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN + IRPRTY=0 + IF (IMSS(51).GE.1) WRITE(MSTU(11),*) + & ' ALLOWING SUSY LLE DECAYS' + IF (IMSS(52).GE.1) WRITE(MSTU(11),*) + & ' ALLOWING SUSY LQD DECAYS' + IF (IMSS(53).GE.1) WRITE(MSTU(11),*) + & ' ALLOWING SUSY UDD DECAYS' + IF (IMSS(53).GE.1.AND.IMSS(52).GE.1) WRITE(MSTU(11),*) + & ' --- Warning: R-Violating couplings possibly', + & ' incompatible with proton decay' + ELSE + PMAS(KC,1)=9999D0 + IRPRTY=1 + ENDIF + +C...Loop over sparticle and Higgs species. + PMCHI1=PMAS(PYCOMP(KSUSY1+22),1) +C...Find the LSP or NLSP for a gravitino LSP + ILSP=0 + PMLSP=1D20 + DO 300 I=1,36 + KF=KFSUSY(I) + IF(KF.EQ.1000039) GOTO 300 + KC=PYCOMP(KF) + IF(PMAS(KC,1).LT.PMLSP) THEN + ILSP=I + PMLSP=PMAS(KC,1) + ENDIF + 300 CONTINUE + DO 370 I=1,50 + IF (I.GT.39.AND.IMSS(13).NE.1) GOTO 370 + KF=KFSUSY(I) + IF (KF.EQ.0) GOTO 370 + KC=PYCOMP(KF) + LKNT=0 + +C...Check if there are any decays listed for this sparticle +C...in a file + IF (IMSS(22).NE.0.OR.MSTP(161).NE.0) THEN + IFAIL=0 + CALL PYSLHA(2,KF,IFAIL) + IF (IFAIL.EQ.0.OR.KF.EQ.6.OR.KF.EQ.24) GOTO 370 + ELSEIF (I.GE.37) THEN + GOTO 370 + ENDIF + +C...Sfermion decays. + IF(I.LE.24) THEN +C...First check to see if sneutrino is lighter than chi10. + IF((I.EQ.15.OR.I.EQ.19.OR.I.EQ.23).AND. + & PMAS(KC,1).LT.PMCHI1) THEN + ELSE + CALL PYSFDC(KF,XLAM,IDLAM,LKNT) + ENDIF + +C...Gluino decays. + ELSEIF(I.EQ.25) THEN + CALL PYGLUI(KF,XLAM,IDLAM,LKNT) + IF(I.EQ.ILSP.AND.IRPRTY.EQ.1) LKNT=0 + +C...Neutralino decays. + ELSEIF(I.GE.26.AND.I.LE.29) THEN + CALL PYNJDC(KF,XLAM,IDLAM,LKNT) +C...chi10 stable or chi10 -> gravitino + gamma. + IF(I.EQ.26.AND.IRPRTY.EQ.1) THEN + PMAS(KC,2)=1D-6 + MDCY(KC,1)=0 + MWID(KC)=0 + ENDIF + +C...Chargino decays. + ELSEIF(I.GE.30.AND.I.LE.31) THEN + CALL PYCJDC(KF,XLAM,IDLAM,LKNT) + +C...Gravitino is stable. + ELSEIF(I.EQ.32) THEN + MDCY(KC,1)=0 + MWID(KC)=0 + +C...Higgs decays. + ELSEIF(I.GE.33.AND.I.LE.36) THEN +C...Calculate decays to non-SUSY particles. + CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE) + LKNT=0 + DO 310 I1=0,100 + XLAM(I1)=0D0 + 310 CONTINUE + DO 330 I1=1,MDCY(KC,3) + K1=MDCY(KC,2)+I1-1 + IF(IABS(KFDP(K1,1)).GT.KSUSY1.OR. + & IABS(KFDP(K1,2)).GT.KSUSY1) GOTO 330 + XLAM(I1)=WDTP(I1) + XLAM(0)=XLAM(0)+XLAM(I1) + DO 320 J1=1,3 + IDLAM(I1,J1)=KFDP(K1,J1) + 320 CONTINUE + LKNT=LKNT+1 + 330 CONTINUE +C...Add the decays to SUSY particles. + CALL PYHEXT(KF,XLAM,IDLAM,LKNT) + ENDIF +C...Zero the branching ratios for use in loop mode +C...thanks to K. Matchev (FNAL) + DO 340 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1 + BRAT(IDC)=0D0 + 340 CONTINUE + +C...Set stable particles. + IF(LKNT.EQ.0) THEN + MDCY(KC,1)=0 + MWID(KC)=0 + PMAS(KC,2)=1D-6 + PMAS(KC,3)=1D-5 + PMAS(KC,4)=0D0 + +C...Store branching ratios in the standard tables. + ELSE + IDC=MDCY(KC,2)+MDCY(KC,3)-1 + DELM=1D6 + DO 360 IL=1,LKNT + IDCSV=IDC + 350 IDC=IDC+1 + BRAT(IDC)=0D0 + IF(IDC.EQ.MDCY(KC,2)+MDCY(KC,3)) IDC=MDCY(KC,2) + IF(IDLAM(IL,1).EQ.KFDP(IDC,1).AND.IDLAM(IL,2).EQ. + & KFDP(IDC,2).AND.IDLAM(IL,3).EQ.KFDP(IDC,3)) THEN + BRAT(IDC)=XLAM(IL)/XLAM(0) + XMDIF=PMAS(KC,1) + IF(MDME(IDC,1).GE.1) THEN + XMDIF=XMDIF-PMAS(PYCOMP(KFDP(IDC,1)),1)- + & PMAS(PYCOMP(KFDP(IDC,2)),1) + IF(KFDP(IDC,3).NE.0) XMDIF=XMDIF- + & PMAS(PYCOMP(KFDP(IDC,3)),1) + ENDIF + IF(I.LE.32) THEN + IF(XMDIF.GE.0D0) THEN + DELM=MIN(DELM,XMDIF) + ELSE + WRITE(MSTU(11),*) ' ERROR WITH DELM ',DELM,XMDIF + WRITE(MSTU(11),*) ' KF = ',KF + WRITE(MSTU(11),*) ' KF(decay) = ',(KFDP(IDC,J),J=1,3) + ENDIF + ENDIF + GOTO 360 + ELSEIF(IDC.EQ.IDCSV) THEN + WRITE(MSTU(11),*) ' Error in PYMSIN: SUSY decay ', + & 'channel not recognized:' + WRITE(MSTU(11),*) KF,' -> ',(IDLAM(IL,J),J=1,3) + GOTO 360 + ELSE + GOTO 350 + ENDIF + 360 CONTINUE + +C...Store width, cutoff and lifetime. + PMAS(KC,2)=XLAM(0) + IF(PMAS(KC,2).LT.0.1D0*DELM) THEN + PMAS(KC,3)=PMAS(KC,2)*10D0 + ELSE + PMAS(KC,3)=0.95D0*DELM + ENDIF + IF(PMAS(KC,2).NE.0D0) THEN + PMAS(KC,4)=PARU(3)/PMAS(KC,2)*1D-12 + ENDIF +C...Write decays to SLHA file + IF (IMSS(24).NE.0) THEN + IFAIL=0 + CALL PYSLHA(4,KF,IFAIL) + ENDIF + + ENDIF + 370 CONTINUE + + RETURN + END +C********************************************************************* + +C...PYSLHA +C...Read/write spectrum or decay data from SLHA standard file(s). +C...P. Skands +C...DECAY TABLE writeout by Nils-Erik Bomark (2010) + +C...MUPDA=0 : READ QNUMBERS/PARTICLE ON LUN=IMSS(21) +C...MUPDA=1 : READ SLHA SPECTRUM ON LUN=IMSS(21) +C...MUPDA=2 : LOOK FOR DECAY TABLE FOR KF=KFORIG ON LUN=IMSS(22) +C... (KFORIG=0 : read all decay tables) +C...MUPDA=3 : WRITE SPECTRUM ON LUN=IMSS(23) +C...MUPDA=4 : WRITE DECAY TABLE FOR KF=KFORIG ON LUN=IMSS(24) +C...MUPDA=5 : READ MASS FOR KF=KFORIG ONLY +C... (KFORIG=0 : read all MASS entries) + + SUBROUTINE PYSLHA(MUPDA,KFORIG,IRETRN) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + COMMON/PYDAT4/CHAF(500,2) + CHARACTER CHAF*16 + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + CHARACTER*40 ISAVER,VISAJE + COMMON/PYINT4/MWID(500),WIDS(500,5) + SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYPARS/,/PYINT4/ +C...SUSY blocks + COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) + COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), + &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) + COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3) + SAVE /PYMSSM/,/PYSSMT/,/PYMSRV/ + +C...Local arrays, character variables and data. + COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100), + & AU(3,3),AD(3,3),AE(3,3) + COMMON/PYLH3C/CPRO(2),CVER(2) +C...The common block of new states (QNUMBERS / PARTICLE) + COMMON/PYQNUM/NQNUM,NQDUM,KQNUM(500,0:9) +C...- NQNUM : Number of QNUMBERS blocks that have been read in +C...- KQNUM(I,0) : KF of new state +C...- KQNUM(I,1) : 3 times electric charge +C...- KQNUM(I,2) : Number of spin states: (2S + 1) +C...- KQNUM(I,3) : Colour rep (1: singlet, 3: triplet, 8: octet) +C...- KQNUM(I,4) : Particle/Antiparticle distinction (0=own anti) +C...- KQNUM(I,5:9) : space available for further quantum numbers + DIMENSION MMOD(100),MSPC(100),KFDEC(100) + SAVE /PYLH3P/,/PYLH3C/,/PYQNUM/,MMOD,MSPC,KFDEC +C...MMOD: flags to set for each block read in. +C... 1: MODSEL 2: MINPAR 3: EXTPAR 4: SMINPUTS +C...MSPC: Flags to set for each block read in. +C... 1: MASS 2: NMIX 3: UMIX 4: VMIX 5: SBOTMIX +C... 6: STOPMIX 7: STAUMIX 8: HMIX 9: GAUGE 10: AU +C...11: AD 12: AE 13: YU 14: YD 15: YE +C...16: SPINFO 17: ALPHA 18: MSOFT 19: QNUMBERS + CHARACTER CPRO*12,CVER*12,CHNLIN*6 + CHARACTER DOC*11, CHDUM*120, CHBLCK*60 + CHARACTER CHINL*120,CHKF*9,CHTMP*16 + INTEGER VERBOS + SAVE VERBOS +C...Date of last Change + PARAMETER (DOC='10 Jun 2010') +C...Local arrays and initial values + DIMENSION IDC(5),KFSUSY(50) + SAVE KFSUSY + DATA NQNUM /0/ + DATA NDECAY /0/ + DATA VERBOS /1/ + DATA NHELLO /0/ + DATA MLHEF /0/ + DATA MLHEFD /0/ + DATA KFSUSY/ + &1000001,1000002,1000003,1000004,1000005,1000006, + &2000001,2000002,2000003,2000004,2000005,2000006, + &1000011,1000012,1000013,1000014,1000015,1000016, + &2000011,2000012,2000013,2000014,2000015,2000016, + &1000021,1000022,1000023,1000025,1000035,1000024, + &1000037,1000039, 25, 35, 36, 37, + & 6, 24, 45, 46,1000045, 9*0/ + DATA KFDEC/100*0/ + RMFUN(IP)=PMAS(PYCOMP(IP),1) + +C...Shorthand for spectrum and decay table unit numbers + IMSS21=IMSS(21) + IMSS22=IMSS(22) + +C...Default for LHEF input: read header information + IF (IMSS21.EQ.0.AND.MSTP(161).NE.0) IMSS21=MSTP(161) + IF (IMSS22.EQ.0.AND.MSTP(161).NE.0) IMSS22=MSTP(161) + IF (IMSS21.EQ.MSTP(161).AND.IMSS21.NE.0) MLHEF=1 + IF (IMSS22.EQ.MSTP(161).AND.IMSS22.NE.0) MLHEFD=1 + +C...Hello World + IF (NHELLO.EQ.0) THEN + IF ((MLHEF.NE.1.AND.MLHEFD.NE.1).OR.(IMSS(1).NE.0)) THEN + WRITE(MSTU(11),5000) DOC + NHELLO=1 + ENDIF + ENDIF + +C...SLHA file assumed opened by user on unit LFN, stored in IMSS(20 +C...+MUPDA). + LFN=IMSS21 + IF (MUPDA.EQ.2) LFN=IMSS22 + IF (MUPDA.EQ.3) LFN=IMSS(23) + IF (MUPDA.EQ.4) LFN=IMSS(24) +C...Flag that we have not yet found whatever we were asked to find. + IRETRN=1 +C...Flag that we are skipping until tag found (if LHEF) + ISKIP=0 + IF (MLHEF.EQ.1.OR.MLHEFD.EQ.1) ISKIP=1 + +C...STOP IF LFN IS ZERO (i.e. if no LFN was given). + IF (LFN.EQ.0) THEN + WRITE(MSTU(11),*) '* (PYSLHA:) No valid unit given in IMSS' + GOTO 9999 + ENDIF + +C...If reading LHEF header, start by rewinding file + IF (MLHEF.EQ.1.OR.MLHEFD.EQ.1) REWIND(LFN) + +C...If told to read spectrum, first zero all previous information. + IF (MUPDA.EQ.1) THEN +C...Zero all block read flags + DO 100 M=1,100 + MMOD(M)=0 + MSPC(M)=0 + 100 CONTINUE +C...Zero all (MSSM) masses, widths, and lifetimes in PYTHIA + DO 110 ISUSY=1,36 + KC=PYCOMP(KFSUSY(ISUSY)) + PMAS(KC,1)=0D0 + 110 CONTINUE +C...Zero all (3rd gen sfermion + gaugino/higgsino) mixing matrices. + DO 130 J=1,4 + SFMIX(5,J) =0D0 + SFMIX(6,J) =0D0 + SFMIX(15,J)=0D0 + DO 120 L=1,4 + ZMIX(L,J) =0D0 + ZMIXI(L,J)=0D0 + IF (J.LE.2.AND.L.LE.2) THEN + UMIX(L,J) =0D0 + UMIXI(L,J)=0D0 + VMIX(L,J) =0D0 + VMIXI(L,J)=0D0 + ENDIF + 120 CONTINUE +C...Zero signed masses. + SMZ(J)=0D0 + IF (J.LE.2) SMW(J)=0D0 + 130 CONTINUE + +C...If reading decays, reset PYTHIA decay counters. + ELSEIF (MUPDA.EQ.2) THEN +C...Check if DECAY for this KF already read + IF (KFORIG.NE.0) THEN + DO 140 IDEC=1,NDECAY + IF (KFORIG.EQ.KFDEC(IDEC)) THEN + IRETRN=0 + RETURN + ENDIF + 140 CONTINUE + ENDIF + KCC=100 + NDC=0 + BRSUM=0D0 + DO 150 KC=1,MSTU(6) + IF(KC.GT.100.AND.KCHG(KC,4).GT.100) KCC=KC + NDC=MAX(NDC,MDCY(KC,2)+MDCY(KC,3)-1) + 150 CONTINUE + ELSEIF (MUPDA.EQ.5) THEN +C...Zero block read flags + DO 160 M=1,100 + MSPC(M)=0 + 160 CONTINUE + ENDIF + +C............READ +C...(QNUMBERS, spectrum, or decays of KF=KFORIG or MASS of KF=KFORIG) + IF(MUPDA.EQ.0.OR.MUPDA.EQ.1.OR.MUPDA.EQ.2.OR.MUPDA.EQ.5) THEN +C...Initialize program and version strings + IF(MUPDA.EQ.1.OR.MUPDA.EQ.2) THEN + CPRO(MUPDA)=' ' + CVER(MUPDA)=' ' + ENDIF + +C...Initialize read loop + MERR=0 + NLINE=0 + CHBLCK=' ' +C...READ NEW LINE INTO CHINL. GOTO 300 AT END-OF-FILE. + 170 CHINL=' ' + READ(LFN,'(A120)',END=400) CHINL +C...Count which line number we're at. + NLINE=NLINE+1 + WRITE(CHNLIN,'(I6)') NLINE + +C...Skip comment and empty lines without processing. + IF (CHINL(1:1).EQ.'#'.OR.CHINL.EQ.' ') GOTO 170 + +C...We assume all upper case below. Rewrite CHINL to all upper case. + INL=0 + IGOOD=0 + 180 INL=INL+1 + IF (CHINL(INL:INL).NE.'#') THEN + DO 190 ICH=97,122 + IF (CHAR(ICH).EQ.CHINL(INL:INL)) CHINL(INL:INL)=CHAR(ICH-32) + 190 CONTINUE +C...Extra safety. Chek for sensible input on line + IF (IGOOD.EQ.0) THEN + DO 200 ICH=48,90 + IF (CHAR(ICH).EQ.CHINL(INL:INL)) IGOOD=1 + 200 CONTINUE + ENDIF + IF (INL.LT.120) GOTO 180 + ENDIF + IF (IGOOD.EQ.0) GOTO 170 + +C...If reading from LHEF file, skip until begin tag found + IF (ISKIP.NE.0) THEN + DO 205 I1=1,10 + IF (CHINL(I1:I1+4).EQ.', , or first tag reached in LHEF file + DO 210 I1=1,10 + IF (CHINL(I1:I1+5).EQ.'h/H/A cross section'// + & ' is proportional to the h/H/A->gg width' + ELSEIF (KF.EQ.23.OR.KF.EQ.24.OR.KF.EQ.6.OR.KF.EQ.32 + & .OR.KF.EQ.33.OR.KF.EQ.34) THEN + WRITE(MSTU(11),'(1x,A,A16)') + & '* Warning: will use DECAY table (fixed-width,'// + & ' flat PS) for ',CHAF(KC,1)(1:16) + ENDIF + PMAS(KC,3)=0D0 + PMAS(KC,4)=PARU(3)*1D-12/WIDTH + MWID(KC)=2 + MDCY(KC,1)=1 + MDCY(KC,2)=NDC + MDCY(KC,3)=0 +C...Add to list of DECAY blocks currently read + NDECAY=NDECAY+1 + KFDEC(NDECAY)=KF +C...Return ok + IRETRN=0 + ENDIF +C... Count up number of decay modes for this particle + MDCY(KC,3)=MDCY(KC,3)+1 +C... Read in decay daughters. + READ(CHINL(4:120),*,ERR=610) DUM,IDM, (IDC(IDA),IDA=1,NDA) +C... Flip sign if reading antiparticle decays (if antipartner exists) + DO 340 IDA=1,NDA + IF (KCHG(PYCOMP(IDC(IDA)),3).NE.0) + & IDC(IDA)=MPSIGN*IDC(IDA) + 340 CONTINUE +C...Switch on decay channel, with products ordered in decreasing ABS(KF) + MDME(NDC,1)=1 + IF (BRAT(NDC).LE.0D0) MDME(NDC,1)=0 + BRSUM=BRSUM+ABS(BRAT(NDC)) + BRAT(NDC)=ABS(BRAT(NDC)) + 350 IFLIP=0 + DO 360 IDA=1,NDA-1 + IF (IABS(IDC(IDA+1)).GT.IABS(IDC(IDA))) THEN + ITMP=IDC(IDA) + IDC(IDA)=IDC(IDA+1) + IDC(IDA+1)=ITMP + IFLIP=IFLIP+1 + ENDIF + 360 CONTINUE + IF (IFLIP.GT.0) GOTO 350 +C...Treat as ordinary decay, no fancy stuff. + MDME(NDC,2)=0 + DO 370 IDA=1,5 + IF (IDA.LE.NDA) THEN + KFDP(NDC,IDA)=IDC(IDA) + ELSE + KFDP(NDC,IDA)=0 + ENDIF + 370 CONTINUE +C WRITE(MSTU(11),7510) NDC, BRAT(NDC), NDA, +C & (KFDP(NDC,J),J=1,NDA) + ELSE + CALL PYERRM(7,'(PYSLHA:) Too many daughters on line '// + & CHNLIN) + MERR=11 + NDC=NDC-1 + ENDIF + ELSEIF(CHINL(1:1).EQ.'+') THEN + MERR=11 + ELSEIF(CHBLCK(1:6).EQ.'DCINFO') THEN + MERR=16 + ELSE + MERR=16 + ENDIF + ENDIF +C... Error check. + 380 IF (MOD(MERR,10).EQ.1.AND.(MUPDA.EQ.1.OR.MUPDA.EQ.2)) THEN + WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring line '//CHNLIN//': ' + & //CHINL(1:40) + MERR=0 + ELSEIF (MERR.EQ.6.AND.MUPDA.EQ.1) THEN + WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring BLOCK '// + & CHBLCK(1:MIN(INL,40))//'... on line '//CHNLIN + ELSEIF (MERR.EQ.8.AND.MUPDA.EQ.1) THEN + WRITE(MSTU(11),*) '* (PYSLHA:) PYTHIA will not use BLOCK ' + & //CHBLCK(1:INL)//'... on line'//CHNLIN + ELSEIF (MERR.EQ.16.AND.MUPDA.EQ.2.AND.IMSS21.EQ.0.AND. + & CHBLCK(1:1).NE.'D'.AND.VERBOS.EQ.1) THEN + WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring BLOCK '//CHBLCK(1:INL) + & //'... on line'//CHNLIN + ELSEIF (MERR.EQ.7.AND.MUPDA.EQ.1) THEN + WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring extra BLOCK '/ + & /CHBLCK(1:INL)//'... on line'//CHNLIN + ELSEIF (MERR.EQ.2.AND.MUPDA.EQ.1) THEN + WRITE (CHTMP,*) KF + WRITE(MSTU(11),*) + & '* (PYSLHA:) Ignoring extra MASS entry for KF='// + & CHTMP(1:9)//' on line'//CHNLIN + ENDIF +C...Iterate read loop + GOTO 170 +C...Error catching + 390 WRITE(*,*) '* (PYSLHA:) read BR error on line',NLINE, + & ', ignoring subsequent lines.' + WRITE(*,*) '* (PYSLHA:) Offending line:',CHINL(1:46) + CHBLCK=' ' + GOTO 170 +C...End of read loop + 400 CONTINUE +C...Set flag that KC codes have been rearranged. + MSTU(20)=0 + VERBOS=0 + +C...Perform possible tests that new information is consistent. + IF (MUPDA.EQ.1) THEN + MSTU23=MSTU(23) + MSTU27=MSTU(27) +C...Check masses + DO 410 ISUSY=1,37 + KF=KFSUSY(ISUSY) +C...Don't complain about right-handed neutrinos + IF (KF.EQ.KSUSY2+12.OR.KF.EQ.KSUSY2+14.OR.KF.EQ.KSUSY2 + & +16) GOTO 410 +C...Only check gravitino in GMSB scenarios + IF (MODSEL(1).NE.2.AND.KF.EQ.KSUSY1+39) GOTO 410 + KC=PYCOMP(KF) + IF (PMAS(KC,1).EQ.0D0) THEN + WRITE(CHTMP,*) KF + CALL PYERRM(9 + & ,'(PYSLHA:) No mass information found for KF =' + & //CHTMP) + ENDIF + 410 CONTINUE +C...Check mixing matrices (MSSM only) + IF (IMSS(13).EQ.0) THEN + IF (MSPC(2).NE.16.AND.MSPC(2).NE.32) CALL PYERRM(9 + & ,'(PYSLHA:) Inconsistent # of elements in NMIX') + IF (MSPC(3).NE.4.AND.MSPC(3).NE.8) CALL PYERRM(9 + & ,'(PYSLHA:) Inconsistent # of elements in UMIX') + IF (MSPC(4).NE.4.AND.MSPC(4).NE.8) CALL PYERRM(9 + & ,'(PYSLHA:) Inconsistent # of elements in VMIX') + IF (MSPC(5).NE.4) CALL PYERRM(9 + & ,'(PYSLHA:) Inconsistent # of elements in SBOTMIX') + IF (MSPC(6).NE.4) CALL PYERRM(9 + & ,'(PYSLHA:) Inconsistent # of elements in STOPMIX') + IF (MSPC(7).NE.4) CALL PYERRM(9 + & ,'(PYSLHA:) Inconsistent # of elements in STAUMIX') + IF (MSPC(8).LT.1) CALL PYERRM(9 + & ,'(PYSLHA:) Too few elements in HMIX') + IF (MSPC(10).EQ.0) CALL PYERRM(9 + & ,'(PYSLHA:) Missing A_b trilinear coupling') + IF (MSPC(11).EQ.0) CALL PYERRM(9 + & ,'(PYSLHA:) Missing A_t trilinear coupling') + IF (MSPC(12).EQ.0) CALL PYERRM(9 + & ,'(PYSLHA:) Missing A_tau trilinear coupling') + IF (MSPC(17).LT.1) CALL PYERRM(9 + & ,'(PYSLHA:) Missing Higgs mixing angle alpha') + ENDIF +C...Check wavefunction normalizations. +C...Sfermions + DO 420 ISPC=5,7 + IF (MSPC(ISPC).EQ.4) THEN + KFSM=ISPC + IF (ISPC.EQ.7) KFSM=15 + CHECK=ABS(SFMIX(KFSM,1)*SFMIX(KFSM,4)-SFMIX(KFSM,2) + & *SFMIX(KFSM,3)) + IF (ABS(1D0-CHECK).GT.1D-3) THEN + KCSM=PYCOMP(KFSM) + CALL PYERRM(17 + & ,'(PYSLHA:) Non-orthonormal mixing matrix for ~' + & //CHAF(KCSM,1)) + ENDIF +C...Bug fix 30/09 2008: PS +C...Translate to Pythia's internal convention: (1,1) same sign as (2,2) + IF (SFMIX(KFSM,1)*SFMIX(KFSM,4).LT.0D0) THEN + SFMIX(KFSM,3) = -SFMIX(KFSM,3) + SFMIX(KFSM,4) = -SFMIX(KFSM,4) + ENDIF + ENDIF + 420 CONTINUE +C...Neutralinos + charginos + DO 440 J=1,4 + CN1=0D0 + CN2=0D0 + CU1=0D0 + CU2=0D0 + CV1=0D0 + CV2=0D0 + DO 430 L=1,4 + CN1=CN1+ZMIX(J,L)**2 + CN2=CN2+ZMIX(L,J)**2 + IF (J.LE.2.AND.L.LE.2) THEN + CU1=CU1+UMIX(J,L)**2 + CU2=CU2+UMIX(L,J)**2 + CV1=CV1+VMIX(J,L)**2 + CV2=CV2+VMIX(L,J)**2 + ENDIF + 430 CONTINUE +C...NMIX normalization + IF (MSPC(2).EQ.16.AND.(ABS(1D0-CN1).GT.1D-3.OR.ABS(1D0-CN2) + & .GT.1D-3).AND.IMSS(13).EQ.0) THEN + CALL PYERRM(19, + & '(PYSLHA:) NMIX: Inconsistent normalization.') + WRITE(MSTU(11),'(7x,I2,1x,":",2(1x,F7.4))') J, CN1, CN2 + ENDIF +C...UMIX, VMIX normalizations + IF (MSPC(3).EQ.4.OR.MSPC(4).EQ.4.AND.IMSS(13).EQ.0) THEN + IF (J.LE.2) THEN + IF (ABS(1D0-CU1).GT.1D-3.OR.ABS(1D0-CU2).GT.1D-3) THEN + CALL PYERRM(19 + & ,'(PYSLHA:) UMIX: Inconsistent normalization.') + WRITE(MSTU(11),'(7x,I2,1x,":",2(1x,F6.2))') J, CU1, + & CU2 + ENDIF + IF (ABS(1D0-CV1).GT.1D-3.OR.ABS(1D0-CV2).GT.1D-3) THEN + CALL PYERRM(19, + & '(PYSLHA:) VMIX: Inconsistent normalization.') + WRITE(MSTU(11),'(7x,I2,1x,":",2(1x,F6.2))') J, CV1, + & CV2 + ENDIF + ENDIF + ENDIF + 440 CONTINUE + IF (MSTU(27).EQ.MSTU27.AND.MSTU(23).EQ.MSTU23) THEN + WRITE(MSTU(11),'(1x,"*"/1x,A/1x,"*")') + & '* (PYSLHA:) No spectrum inconsistencies were found.' + ELSE + WRITE(MSTU(11),'(1x,"*"/1x,A/1x,"*",A/1x,"*",A/)') + & '* (PYSLHA:) INCONSISTENT SPECTRUM WARNING.' + & ,' Warning: one or more (serious)'// + & ' inconsistencies were found in the spectrum !' + & ,' Read the error messages above and check your'// + & ' input file.' + ENDIF +C...Increase precision in Higgs sector using FeynHiggs + IF (IMSS(4).EQ.3) THEN +C...FeynHiggs needs MSOFT. + IERR=0 + IF (MSPC(18).EQ.0) THEN + WRITE(MSTU(11),'(1x,"*"/1x,A/)') + & '* (PYSLHA:) BLOCK MSOFT not found in SLHA file.'// + & ' Cannot call FeynHiggs.' + IERR=-1 + ELSE + WRITE(MSTU(11),'(1x,/1x,A/)') + & '* (PYSLHA:) Now calling FeynHiggs.' + CALL PYFEYN(IERR) + IF (IERR.NE.0) IMSS(4)=2 + ENDIF + ENDIF + ELSEIF (MUPDA.EQ.2.AND.IRETRN.EQ.0.AND.MERR.NE.16) THEN + IBEG=1 + IF (KFORIG.NE.0) IBEG=NDECAY + DO 490 IDECAY=IBEG,NDECAY + KF = KFDEC(IDECAY) + KC = PYCOMP(KF) + WRITE(CHKF,8300) KF + IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3 + $ ),PMAS(KC,4)).LT.0D0.OR.MDCY(KC,3).LT.0.OR.(MDCY(KC,3) + $ .EQ.0.AND.MDCY(KC,1).GE.1)) CALL PYERRM(17 + $ ,'(PYSLHA:) Mass/width/life/(# channels) wrong for KF=' + $ //CHKF) + BRSUM=0D0 + BROPN=0D0 + DO 460 IDA=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1 + IF(MDME(IDA,2).GT.80) GOTO 460 + KQ=KCHG(KC,1) + PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64) + MERR=0 + DO 450 J=1,5 + KP=KFDP(IDA,J) + IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN + IF(KP.EQ.81) KQ=0 + ELSEIF(PYCOMP(KP).EQ.0) THEN + MERR=3 + ELSE + KQ=KQ-PYCHGE(KP) + KPC=PYCOMP(KP) + PMS=PMS-PMAS(KPC,1) + IF(MSTJ(24).GT.0) PMS=PMS+0.5D0*MIN(PMAS(KPC,2), + & PMAS(KPC,3)) + ENDIF + 450 CONTINUE + IF(KQ.NE.0) MERR=MAX(2,MERR) + IF(MWID(KC).EQ.0.AND.KF.NE.311.AND.PMS.LT.0D0) + & MERR=MAX(1,MERR) + IF(MERR.EQ.3) CALL PYERRM(17, + & '(PYSLHA:) Unknown particle code in decay of KF =' + $ //CHKF) + IF(MERR.EQ.2) CALL PYERRM(17, + & '(PYSLHA:) Charge not conserved in decay of KF =' + $ //CHKF) + IF(MERR.EQ.1) CALL PYERRM(7, + & '(PYSLHA:) Kinematically unallowed decay of KF =' + $ //CHKF) + BRSUM=BRSUM+BRAT(IDA) + IF (MDME(IDA,1).GT.0) BROPN=BROPN+BRAT(IDA) + 460 CONTINUE +C...Check branching ratio sum. + IF (BROPN.LE.0D0) THEN +C...If zero, set stable. + WRITE(CHTMP,8500) BROPN + CALL PYERRM(7 + & ,"(PYSLHA:) Effective BR sum for KF="//CHKF//' is '// + & CHTMP(9:16)//'. Changed to stable.') + PMAS(KC,2)=1D-6 + MWID(KC)=0 +C...If BR's > 1, rescale. + ELSEIF (BRSUM.GT.(1D0+1D-6)) THEN + WRITE(CHTMP,8500) BRSUM + IF (BRSUM.GT.(1D0+1D-3)) CALL PYERRM(7 + & ,"(PYSLHA:) Forced rescaling of BR's for KF="//CHKF// + & ' ; sum was'//CHTMP(9:16)//'.') + FAC=1D0/BRSUM + DO 470 IDA=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1 + IF(MDME(IDA,2).GT.80) GOTO 470 + BRAT(IDA)=FAC*BRAT(IDA) + 470 CONTINUE + ELSEIF (BRSUM.LT.(1D0-1D-6)) THEN +C...If BR's < 1, insert dummy mode for proper cross section rescaling. + WRITE(CHTMP,8500) BRSUM + IF (BRSUM.LT.(1D0-1D-3)) CALL PYERRM(7 + & ,"(PYSLHA:) Sum of BR's for KF="//CHKF//' is '// + & CHTMP(9:16)//'. Dummy mode will be inserted.') +C...Move table and insert dummy mode + DO 480 IDA=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1 + NDC=NDC+1 + BRAT(NDC)=BRAT(IDA) + KFDP(NDC,1)=KFDP(IDA,1) + KFDP(NDC,2)=KFDP(IDA,2) + KFDP(NDC,3)=KFDP(IDA,3) + KFDP(NDC,4)=KFDP(IDA,4) + KFDP(NDC,5)=KFDP(IDA,5) + MDME(NDC,1)=MDME(IDA,1) + 480 CONTINUE + NDC=NDC+1 + BRAT(NDC)=1D0-BRSUM + KFDP(NDC,1)=0 + KFDP(NDC,2)=0 + KFDP(NDC,3)=0 + KFDP(NDC,4)=0 + KFDP(NDC,5)=0 + MDME(NDC,1)=0 + BRSUM=1D0 +C...Update MDCY + MDCY(KC,3)=MDCY(KC,3)+1 + MDCY(KC,2)=NDC-MDCY(KC,3)+1 + ENDIF + 490 CONTINUE + ENDIF + + +C...WRITE SPECTRUM ON SLHA FILE + ELSEIF(MUPDA.EQ.3) THEN +C...If SPYTHIA or ISASUSY runtime was called for SUGRA, update PARMIN. + IF (IMSS(1).EQ.2.OR.IMSS(1).EQ.12) THEN + MODSEL(1)=1 + PARMIN(1)=RMSS(8) + PARMIN(2)=RMSS(1) + PARMIN(3)=RMSS(5) + PARMIN(4)=SIGN(1D0,RMSS(4)) + PARMIN(5)=RMSS(36) + ENDIF +C...Write spectrum + WRITE(LFN,7000) 'SLHA MSSM spectrum' + WRITE(LFN,7000) 'Pythia 6.4: T. Sjostrand, S. Mrenna,' + & // ' P. Skands.' + WRITE(LFN,7010) 'MODSEL', 'Model selection' + WRITE(LFN,7110) 1, MODSEL(1) + WRITE(LFN,7010) 'MINPAR', 'Parameters for minimal model.' + IF (MODSEL(1).EQ.1) THEN + WRITE(LFN,7210) 1, PARMIN(1), 'm0' + WRITE(LFN,7210) 2, PARMIN(2), 'm12' + WRITE(LFN,7210) 3, PARMIN(3), 'tan(beta)' + WRITE(LFN,7210) 4, PARMIN(4), 'sign(mu)' + WRITE(LFN,7210) 5, PARMIN(5), 'a0' + ELSEIF(MODSEL(2).EQ.2) THEN + WRITE(LFN,7210) 1, PARMIN(1), 'Lambda' + WRITE(LFN,7210) 2, PARMIN(2), 'M' + WRITE(LFN,7210) 3, PARMIN(3), 'tan(beta)' + WRITE(LFN,7210) 4, PARMIN(4), 'sign(mu)' + WRITE(LFN,7210) 5, PARMIN(5), 'N5' + WRITE(LFN,7210) 6, PARMIN(6), 'c_grav' + ENDIF + WRITE(LFN,7000) ' ' + WRITE(LFN,7010) 'MASS', 'Mass spectrum' + DO 500 I=1,36 + KF=KFSUSY(I) + KC=PYCOMP(KF) + IF (KF.EQ.1000039.AND.MODSEL(1).NE.2) GOTO 500 + KFSM=KF-KSUSY1 + IF (KFSM.GE.22.AND.KFSM.LE.37) THEN + IF (KFSM.EQ.22) WRITE(LFN,7220) KF, SMZ(1), CHAF(KC,1) + IF (KFSM.EQ.23) WRITE(LFN,7220) KF, SMZ(2), CHAF(KC,1) + IF (KFSM.EQ.25) WRITE(LFN,7220) KF, SMZ(3), CHAF(KC,1) + IF (KFSM.EQ.35) WRITE(LFN,7220) KF, SMZ(4), CHAF(KC,1) + IF (KFSM.EQ.24) WRITE(LFN,7220) KF, SMW(1), CHAF(KC,1) + IF (KFSM.EQ.37) WRITE(LFN,7220) KF, SMW(2), CHAF(KC,1) + ELSE + WRITE(LFN,7220) KF, PMAS(KC,1), CHAF(KC,1) + ENDIF + 500 CONTINUE +C...SUSY scale + RMSUSY=SQRT(PMAS(PYCOMP(KSUSY1+6),1)*PMAS(PYCOMP(KSUSY2+6),1)) + WRITE(LFN,7020) 'HMIX',RMSUSY,'Higgs parameters' + WRITE(LFN,7210) 1, RMSS(4),'mu' + WRITE(LFN,7010) 'ALPHA',' ' +C WRITE(LFN,7210) 1, RMSS(18), 'alpha' + WRITE(LFN,7200) RMSS(18), 'alpha' + WRITE(LFN,7020) 'AU',RMSUSY + WRITE(LFN,7410) 3, 3, RMSS(16), 'A_t' + WRITE(LFN,7020) 'AD',RMSUSY + WRITE(LFN,7410) 3, 3, RMSS(15), 'A_b' + WRITE(LFN,7020) 'AE',RMSUSY + WRITE(LFN,7410) 3, 3, RMSS(17), 'A_tau' + WRITE(LFN,7010) 'STOPMIX','~t mixing matrix' + WRITE(LFN,7410) 1, 1, SFMIX(6,1) + WRITE(LFN,7410) 1, 2, SFMIX(6,2) + WRITE(LFN,7410) 2, 1, SFMIX(6,3) + WRITE(LFN,7410) 2, 2, SFMIX(6,4) + WRITE(LFN,7010) 'SBOTMIX','~b mixing matrix' + WRITE(LFN,7410) 1, 1, SFMIX(5,1) + WRITE(LFN,7410) 1, 2, SFMIX(5,2) + WRITE(LFN,7410) 2, 1, SFMIX(5,3) + WRITE(LFN,7410) 2, 2, SFMIX(5,4) + WRITE(LFN,7010) 'STAUMIX','~tau mixing matrix' + WRITE(LFN,7410) 1, 1, SFMIX(15,1) + WRITE(LFN,7410) 1, 2, SFMIX(15,2) + WRITE(LFN,7410) 2, 1, SFMIX(15,3) + WRITE(LFN,7410) 2, 2, SFMIX(15,4) + WRITE(LFN,7010) 'NMIX','~chi0 mixing matrix' + DO 520 I1=1,4 + DO 510 I2=1,4 + WRITE(LFN,7410) I1, I2, ZMIX(I1,I2) + 510 CONTINUE + 520 CONTINUE + WRITE(LFN,7010) 'UMIX','~chi^+ U mixing matrix' + DO 540 I1=1,2 + DO 530 I2=1,2 + WRITE(LFN,7410) I1, I2, UMIX(I1,I2) + 530 CONTINUE + 540 CONTINUE + WRITE(LFN,7010) 'VMIX','~chi^+ V mixing matrix' + DO 560 I1=1,2 + DO 550 I2=1,2 + WRITE(LFN,7410) I1, I2, VMIX(I1,I2) + 550 CONTINUE + 560 CONTINUE + WRITE(LFN,7010) 'SPINFO' + IF (IMSS(1).EQ.2) THEN + CPRO(1)='PYTHIA' + CVER(1)='6.4' + ELSEIF (IMSS(1).EQ.12) THEN + ISAVER=VISAJE() + CPRO(1)='ISASUSY' + CVER(1)=ISAVER(1:12) + ENDIF + WRITE(LFN,7310) 1, CPRO(1), 'Spectrum Calculator' + WRITE(LFN,7310) 2, CVER(1), 'Version number' + ENDIF + +C...Print user information about spectrum + IF (MUPDA.EQ.1.OR.MUPDA.EQ.3) THEN + IF (CPRO(MOD(MUPDA,2)).NE.' '.AND.CVER(MOD(MUPDA,2)).NE.' ') + & WRITE(MSTU(11),5030) CPRO(1), CVER(1) + IF (IMSS(4).EQ.3) WRITE(MSTU(11),5040) + IF (MUPDA.EQ.1) THEN + WRITE(MSTU(11),5020) LFN + ELSE + WRITE(MSTU(11),5010) LFN + ENDIF + + WRITE(MSTU(11),5400) + WRITE(MSTU(11),5500) 'Pole masses' + WRITE(MSTU(11),5700) (RMFUN(KSUSY1+IP),IP=1,6) + $ ,(RMFUN(KSUSY2+IP),IP=1,6) + WRITE(MSTU(11),5800) (RMFUN(KSUSY1+IP),IP=11,16) + $ ,(RMFUN(KSUSY2+IP),IP=11,16) + IF (IMSS(13).EQ.0) THEN + WRITE(MSTU(11),5900) RMFUN(KSUSY1+21),RMFUN(KSUSY1+22) + $ ,RMFUN(KSUSY1+23),RMFUN(KSUSY1+25),RMFUN(KSUSY1+35), + $ RMFUN(KSUSY1+24),RMFUN(KSUSY1+37) + WRITE(MSTU(11),6000) CHAF(25,1),CHAF(35,1),CHAF(36,1), + & CHAF(37,1), ' ', ' ',' ',' ', + & RMFUN(25), RMFUN(35), RMFUN(36), RMFUN(37) + ELSEIF (IMSS(13).EQ.1) THEN + KF1=KSUSY1+21 + KF2=KSUSY1+22 + KF3=KSUSY1+23 + KF4=KSUSY1+25 + KF5=KSUSY1+35 + KF6=KSUSY1+45 + KF7=KSUSY1+24 + KF8=KSUSY1+37 + WRITE(MSTU(11),6000) CHAF(PYCOMP(KF1),1),CHAF(PYCOMP(KF2),1), + & CHAF(PYCOMP(KF3),1),CHAF(PYCOMP(KF4),1), + & CHAF(PYCOMP(KF5),1),CHAF(PYCOMP(KF6),1), + & CHAF(PYCOMP(KF7),1),CHAF(PYCOMP(KF8),1), + & RMFUN(KF1),RMFUN(KF2),RMFUN(KF3),RMFUN(KF4), + & RMFUN(KF5),RMFUN(KF6),RMFUN(KF7),RMFUN(KF8) + WRITE(MSTU(11),6000) CHAF(25,1), CHAF(35,1), CHAF(45,1), + & CHAF(36,1), CHAF(46,1), CHAF(37,1),' ',' ', + & RMFUN(25), RMFUN(35), RMFUN(45), RMFUN(36), RMFUN(46), + & RMFUN(37) + ENDIF + WRITE(MSTU(11),5400) + WRITE(MSTU(11),5500) 'Mixing structure' + WRITE(MSTU(11),6100) ((ZMIX(I,J), J=1,4),I=1,4) + WRITE(MSTU(11),6200) (UMIX(1,J), J=1,2),(VMIX(1,J),J=1,2) + & ,(UMIX(2,J), J=1,2),(VMIX(2,J),J=1,2) + WRITE(MSTU(11),6300) (SFMIX(5,J), J=1,2),(SFMIX(6,J),J=1,2) + & ,(SFMIX(15,J), J=1,2),(SFMIX(5,J),J=3,4),(SFMIX(6,J), J=3,4 + & ),(SFMIX(15,J),J=3,4) + WRITE(MSTU(11),5400) + WRITE(MSTU(11),5500) 'Couplings' + WRITE(MSTU(11),6400) RMSS(15),RMSS(16),RMSS(17) + WRITE(MSTU(11),6450) RMSS(18), RMSS(5), RMSS(4) + WRITE(MSTU(11),5400) + WRITE(MSTU(11),6500) + +C...DECAY TABLES writeout +C...Write decay information by Nils-Erik Bomark 3/29/2010 + ELSEIF (MUPDA.EQ.4) THEN + KF = KFORIG + KC = PYCOMP(KF) + IF (KC.NE.0) THEN + WRITE(LFN,7000) '' + WRITE(LFN,7000) ' PDG Width' + WRITE(LFN,7500) KF,PMAS(KC,2), CHAF(KC,1) + WRITE(LFN,7000) + & ' BR NDA ID1 ID2 ID3' + DO 575 I=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1 + NDA = 0 + DO 570 J=1,5 + IF (KFDP(I,J).NE.0) NDA = NDA+1 + 570 CONTINUE + IF (NDA.EQ.2) + & WRITE(LFN,7512) BRAT(I),NDA,(KFDP(I,K),K=1,NDA), + & CHAF(KC,1),(CHAF(PYCOMP(KFDP(I,K)), + & (3-KFDP(I,K)/ABS(KFDP(I,K)))/2),K=1,NDA) + IF (NDA.EQ.3) + & WRITE(LFN,7513) BRAT(I),NDA,(KFDP(I,K),K=1,NDA), + & CHAF(KC,1),(CHAF(PYCOMP(KFDP(I,K)), + & (3-KFDP(I,K)/ABS(KFDP(I,K)))/2),K=1,NDA) + IF (NDA.EQ.4) + & WRITE(LFN,7514) BRAT(I),NDA,(KFDP(I,K),K=1,NDA), + & CHAF(KC,1),(CHAF(PYCOMP(KFDP(I,K)), + & (3-KFDP(I,K)/ABS(KFDP(I,K)))/2),K=1,NDA) + IF (NDA.EQ.5) + & WRITE(LFN,7515) BRAT(I),NDA,(KFDP(I,K),K=1,NDA), + & CHAF(KC,1),(CHAF(PYCOMP(KFDP(I,K)), + & (3-KFDP(I,K)/ABS(KFDP(I,K)))/2),K=1,NDA) + 575 CONTINUE + ENDIF +C....End of DECAY TABLES writeout + + ENDIF + +C...Only rewind when reading + IF (MUPDA.LE.2.OR.MUPDA.EQ.5) REWIND(LFN) + + 9999 RETURN + +C...Serious error catching + 580 write(*,*) '* (PYSLHA:) read BLOCK error on line',NLINE + write(*,*) CHINL(1:80) + CALL PYSTOP(106) + 590 WRITE(*,*) '* (PYSLHA:) read DECAY error on line',NLINE + WRITE(*,*) CHINL(1:72) + CALL PYSTOP(106) + 600 WRITE(*,*) '* (PYSLHA:) read NDA error on line',NLINE + WRITE(*,*) CHINL(1:80) + CALL PYSTOP(106) + 610 WRITE(*,*) '* (PYSLHA:) decay daughter read error on line',NLINE + WRITE(*,*) CHINL(1:80) + 620 WRITE(*,*) '* (PYSLHA:) read Q error in BLOCK ',CHBLCK + CALL PYSTOP(106) + 630 WRITE(*,*) '* (PYSLHA:) read error in line ',NLINE,':' + WRITE(*,*) CHINL(1:80) + CALL PYSTOP(106) + + 8300 FORMAT(I9) + 8500 FORMAT(F16.5) + +C...Formats for user information printout. + 5000 FORMAT(1x,18('*'),1x,'PYSLHA v1.14: SUSY/BSM SPECTRUM ' + & ,'INTERFACE',1x,17('*')/1x,'*',1x + & ,'(PYSLHA:) Last Change',1x,A,1x,'-',1x,'P.Z. Skands') + 5010 FORMAT(1x,'*',3x,'Wrote spectrum file on unit: ',I3) + 5020 FORMAT(1x,'*',3x,'Read spectrum file on unit: ',I3) + 5030 FORMAT(1x,'*',3x,'Spectrum Calculator was: ',A,' version ',A) + 5040 FORMAT(1x,'*',3x,'Higgs sector corrected with FeynHiggs') + 5100 FORMAT(1x,'*',1x,'Model parameters:'/1x,'*',1x,'----------------') + 5200 FORMAT(1x,'*',1x,3x,'M_0',6x,'M_1/2',5x,'A_0',3x,'Tan(beta)', + & 3x,'Sgn(mu)',3x,'M_t'/1x,'*',1x,4(F8.2,1x),I8,2x,F8.2) + 5300 FORMAT(1x,'*'/1x,'*',1x,'Model spectrum :'/1x,'*',1x + & ,'----------------') + 5400 FORMAT(1x,'*',1x,A) + 5500 FORMAT(1x,'*',1x,A,':') + 5600 FORMAT(1x,'*',2x,2x,'M_GUT',2x,2x,'g_GUT',2x,1x,'alpha_GUT'/ + & 1x,'*',2x,1P,2(1x,E8.2),2x,E8.2) + 5700 FORMAT(1x,'*',4x,1x,'~d',2x,1x,4x,'~u',2x,1x,4x,'~s',2x,1x, + & 4x,'~c',2x,1x,4x,'~b(12)',1x,1x,1x,'~t(12)'/1x,'*',2x,'L',1x + & ,6(F8.2,1x)/1x,'*',2x,'R',1x,6(F8.2,1x)) + 5800 FORMAT(1x,'*'/1x,'*',4x,1x,'~e',2x,1x,4x,'~nu_e',2x,1x,1x,'~mu',2x + & ,1x,3x,'~nu_mu',2x,1x,'~tau(12)',1x,'~nu_tau'/1x,'*',2x + & ,'L',1x,6(F8.2,1x)/1x,'*',2x,'R',1x,6(F8.2,1x)) + 5900 FORMAT(1x,'*'/1x,'*',4x,4x,'~g',2x,1x,1x,'~chi_10',1x,1x,'~chi_20' + & ,1x,1x,'~chi_30',1x,1x,'~chi_40',1x,1x,'~chi_1+',1x + & ,1x,'~chi_2+'/1x,'*',3x,1x,7(F8.2,1x)) + 6000 FORMAT(1x,'*'/1x,'*',3x,1x,8(1x,A7,1x)/1x,'*',3x,1x,8(F8.2,1x)) + 6100 FORMAT(1x,'*',11x,'|',3x,'~B',3x,'|',2x,'~W_3',2x,'|',2x + & ,'~H_1',2x,'|',2x,'~H_2',2x,'|'/1x,'*',3x,'~chi_10',1x,4('|' + & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_20',1x,4('|' + & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_30',1x,4('|' + & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_40',1x,4('|' + & ,1x,F6.3,1x),'|') + 6200 FORMAT(1x,'*'/1x,'*',6x,'L',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|' + & ,12x,'R',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'/1x,'*',3x + & ,'~chi_1+',1x,2('|',1x,F6.3,1x),'|',9x,'~chi_1+',1x,2('|',1x + & ,F6.3,1x),'|'/1x,'*',3x,'~chi_2+',1x,2('|',1x,F6.3,1x),'|',9x + & ,'~chi_2+',1x,2('|',1x,F6.3,1x),'|') + 6300 FORMAT(1x,'*'/1x,'*',8x,'|',2x,'~b_L',2x,'|',2x,'~b_R',2x,'|',8x + & ,'|',2x,'~t_L',2x,'|',2x,'~t_R',2x,'|',10x + & ,'|',1x,'~tau_L',1x,'|',1x,'~tau_R',1x,'|'/ + & 1x,'*',3x,'~b_1',1x,2('|',1x,F6.3,1x),'|',3x,'~t_1',1x,2('|' + & ,1x,F6.3,1x),'|',3x,'~tau_1',1x,2('|',1x,F6.3,1x),'|'/ + & 1x,'*',3x,'~b_2',1x,2('|',1x,F6.3,1x),'|',3x,'~t_2',1x,2('|' + & ,1x,F6.3,1x),'|',3x,'~tau_2',1x,2('|',1x,F6.3,1x),'|') + 6400 FORMAT(1x,'*',3x,' A_b = ',F8.2,4x,' A_t = ',F8.2,4x + & ,'A_tau = ',F8.2) + 6450 FORMAT(1x,'*',3x,'alpha = ',F8.2,4x,'tan(beta) = ',F8.2,4x + & ,' mu = ',F8.2) + 6500 FORMAT(1x,32('*'),1x,'END OF PYSLHA',1x,31('*')) + +C...Format to use for comments + 7000 FORMAT('# ',A) +C...Format to use for block statements + 7010 FORMAT('Block',1x,A,3x,'#',1x,A) + 7020 FORMAT('Block',1x,A,1x,'Q=',1P,E16.8,0P,3x,'#',1x,A) +C...Indexed Int + 7110 FORMAT(1x,I4,1x,I4,3x,'#') +C...Non-Indexed Double + 7200 FORMAT(9x,1P,E16.8,0P,3x,'#',1x,A) +C...Indexed Double + 7210 FORMAT(1x,I4,3x,1P,E16.8,0P,3x,'#',1x,A) +C...Long Indexed Double (PDG + double) + 7220 FORMAT(1x,I9,3x,1P,E16.8,0P,3x,'#',1x,A) +C...Indexed Char(12) + 7310 FORMAT(1x,I4,3x,A12,3x,'#',1x,A) +C...Single matrix + 7410 FORMAT(1x,I2,1x,I2,3x,1P,E16.8,0P,3x,'#',1x,A) +C...Double Matrix + 7420 FORMAT(1x,I2,1x,I2,3x,1P,E16.8,3x,E16.8,0P,3x,'#',1x,A) +C...Write Decay Table + 7500 FORMAT('Decay',1x,I9,1x,1P,E16.8,0P,3x,'#',1x,A) + 7510 FORMAT(4x,1P,E16.8,0P,3x,I2,3x,'IDA=',1x,5(1x,I9),3x,'#',1x,A) + 7512 FORMAT(4x,1P,E16.8,0P,3x,I2,3x,1x,2(1x,I9),13x, + & '#',1x,'BR(',A10,1x,'->',2(1x,A10),')') + 7513 FORMAT(4x,1P,E16.8,0P,3x,I2,3x,1x,3(1x,I9),3x, + & '#',1x,'BR(',A10,1x,'->',3(1x,A10),')') + 7514 FORMAT(4x,1P,E16.8,0P,3x,I2,3x,1x,4(1x,I9),3x, + & '#',1x,'BR(',A10,1x,'->',4(1x,A10),')') + 7515 FORMAT(4x,1P,E16.8,0P,3x,I2,3x,1x,5(1x,I9),3x, + & '#',1x,'BR(',A10,1x,'->',5(1x,A10),')') + + END + + +C********************************************************************* + +C...PYAPPS +C...Uses approximate analytical formulae to determine the full set of +C...MSSM parameters from SUGRA input. +C...See M. Drees and S.P. Martin, hep-ph/9504124 + + SUBROUTINE PYAPPS + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) + SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/ + + WRITE(MSTU(11),*) '(PYAPPS:) approximate mSUGRA relations'// + &' not intended for serious physics studies' + IMSS(5)=0 + IMSS(8)=0 + XMT=PMAS(6,1) + XMZ2=PMAS(23,1)**2 + XMW2=PMAS(24,1)**2 + TANB=RMSS(5) + BETA=ATAN(TANB) + XW=PARU(102) + XMG=RMSS(1) + XMG2=XMG*XMG + XM0=RMSS(8) + XM02=XM0*XM0 +C...Temporary sign change for AT. Others unchanged. + AT=-RMSS(16) + RMSS(15)=RMSS(16) + RMSS(17)=RMSS(16) + SINB=TANB/SQRT(TANB**2+1D0) + COSB=SINB/TANB + + DTERM=XMZ2*COS(2D0*BETA) + XMER=SQRT(XM02+0.15D0*XMG2-XW*DTERM) + XMEL=SQRT(XM02+0.52D0*XMG2-(0.5D0-XW)*DTERM) + RMSS(6)=XMEL + RMSS(7)=XMER + XMUR=SQRT(PYRNMQ(2,2D0/3D0*XW*DTERM)) + XMDR=SQRT(PYRNMQ(3,-1D0/3D0*XW*DTERM)) + XMUL=SQRT(PYRNMQ(1,(0.5D0-2D0/3D0*XW)*DTERM)) + XMDL=SQRT(PYRNMQ(1,-(0.5D0-1D0/3D0*XW)*DTERM)) + DO 100 I=1,5,2 + PMAS(PYCOMP(KSUSY1+I),1)=XMDL + PMAS(PYCOMP(KSUSY2+I),1)=XMDR + PMAS(PYCOMP(KSUSY1+I+1),1)=XMUL + PMAS(PYCOMP(KSUSY2+I+1),1)=XMUR + 100 CONTINUE + XARG=XMEL**2-XMW2*ABS(COS(2D0*BETA)) + IF(XARG.LT.0D0) THEN + WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'// + & ' FROM THE SUM RULE. ' + WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). ' + RETURN + ELSE + XARG=SQRT(XARG) + ENDIF + DO 110 I=11,15,2 + PMAS(PYCOMP(KSUSY1+I),1)=XMEL + PMAS(PYCOMP(KSUSY2+I),1)=XMER + PMAS(PYCOMP(KSUSY1+I+1),1)=XARG + PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0 + 110 CONTINUE + RMT=PYMRUN(6,PMAS(6,1)**2) + XTOP=(RMT/150D0/SINB)**2*(.9D0*XM02+2.1D0*XMG2+ + &(1D0-(RMT/190D0/SINB)**3)*(.24D0*AT**2+AT*XMG)) + RMB=PYMRUN(5,PMAS(6,1)**2) + XBOT=(RMB/150D0/COSB)**2*(.9D0*XM02+2.1D0*XMG2+ + &(1D0-(RMB/190D0/COSB)**3)*(.24D0*AT**2+AT*XMG)) + XTAU=1D-4/COSB**2*(XM02+0.15D0*XMG2+AT**2/3D0) + ATP=AT*(1D0-(RMT/190D0/SINB)**2)+XMG*(3.47D0-1.9D0*(RMT/190D0/ + &SINB)**2) + RMSS(16)=-ATP + XMU2=-.5D0*XMZ2+(SINB**2*(XM02+.52D0*XMG2-XTOP)- + &COSB**2*(XM02+.52D0*XMG2-XBOT-XTAU/3D0))/(COSB**2-SINB**2) + XMA2=2D0*(XM02+.52D0*XMG2+XMU2)-XTOP-XBOT-XTAU/3D0 + XMU=SIGN(SQRT(XMU2),RMSS(4)) + RMSS(4)=XMU + IF(XMA2.GT.0D0) THEN + RMSS(19)=SQRT(XMA2) + ELSE + WRITE(MSTU(11),*) ' PYAPPS:: PSEUDOSCALAR MASS**2 < 0 ' + CALL PYSTOP(102) + ENDIF + ARG=XM02+0.15D0*XMG2-2D0*XTAU/3D0-XW*DTERM + IF(ARG.GT.0D0) THEN + RMSS(14)=SQRT(ARG) + ELSE + WRITE(MSTU(11),*) ' PYAPPS:: RIGHT STAU MASS**2 < 0 ' + CALL PYSTOP(102) + ENDIF + ARG=XM02+0.52D0*XMG2-XTAU/3D0-(0.5D0-XW)*DTERM + IF(ARG.GT.0D0) THEN + RMSS(13)=SQRT(ARG) + ELSE + WRITE(MSTU(11),*) ' PYAPPS:: LEFT STAU MASS**2 < 0 ' + CALL PYSTOP(102) + ENDIF + ARG=PYRNMQ(1,-(XBOT+XTOP)/3D0) + IF(ARG.GT.0D0) THEN + RMSS(10)=SQRT(ARG) + ELSE + RMSS(10)=-SQRT(-ARG) + ENDIF + ARG=PYRNMQ(2,-2D0*XTOP/3D0) + IF(ARG.GT.0D0) THEN + RMSS(12)=SQRT(ARG) + ELSE + RMSS(12)=-SQRT(-ARG) + ENDIF + ARG=PYRNMQ(3,-2D0*XBOT/3D0) + IF(ARG.GT.0D0) THEN + RMSS(11)=SQRT(ARG) + ELSE + RMSS(11)=-SQRT(-ARG) + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYSUGI +C...Interface to ISASUSY version 7.71. +C...Warning: this interface should not be used with earlier versions +C...of ISASUSY, since common block incompatibilities may then arise. +C...Calls SUGRA (in ISAJET) to perform RGE evolution. +C...Then converts to Gunion-Haber conventions. + + SUBROUTINE PYSUGI + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + + INTEGER PYK,PYCHGE,PYCOMP + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) + +C...Date of Change + CHARACTER DOC*11 + PARAMETER (DOC='01 May 2006') + +C...ISASUGRA Input: + REAL MZERO,MHLF,AZERO,TANB,SGNMU,MTOP +C...XISAIN contains the MSSMi inputs in natural order. + COMMON /SUGXIN/ XISAIN(24),XSUGIN(7),XGMIN(14),XNRIN(4), + $XAMIN(7) + REAL XISAIN,XSUGIN,XGMIN,XNRIN,XAMIN + SAVE /SUGXIN/ +C...ISASUGRA Output + CHARACTER*40 ISAVER,VISAJE + REAL SUPER + COMMON /SSPAR/ SUPER(72) + COMMON /SUGMG/ MSS(32),GSS(31),MGUTSS,GGUTSS,AGUTSS,FTGUT, + $FBGUT,FTAGUT,FNGUT + REAL MSS,GSS,MGUTSS,GGUTSS,AGUTSS,FTGUT,FBGUT,FTAGUT,FNGUT + COMMON /SUGPAS/ XTANB,MSUSY,AMT,MGUT,MU,G2,GP,V,VP,XW, + $A1MZ,A2MZ,ASMZ,FTAMZ,FBMZ,B,SIN2B,FTMT,G3MT,VEV,HIGFRZ, + $FNMZ,AMNRMJ,NOGOOD,IAL3UN,ITACHY,MHPNEG,ASM3, + $VUMT,VDMT,ASMTP,ASMSS,M3Q + REAL XTANB,MSUSY,AMT,MGUT,MU,G2,GP,V,VP,XW, + $A1MZ,A2MZ,ASMZ,FTAMZ,FBMZ,B,SIN2B,FTMT,G3MT,VEV,HIGFRZ, + $FNMZ,AMNRMJ,ASM3,VUMT,VDMT,ASMTP,ASMSS,M3Q + INTEGER NOGOOD,IAL3UN,ITACHY,MHPNEG + INTEGER IALLOW + SAVE /SUGMG/,/SSPAR/ +C SUPER: Filled by ISASUGRA. +C SUPER(1) = mass of ~g +C SUPER(2:17) = mass of ~u_L,~u_R,~d_L,~d_R,~s_L,~s_R,~c_L,~c_R,~b_L +C ,~b_R,~b_1,~b_2,~t_L,~t_R,~t_1,~t_2 +C SUPER(18:25) = mass of ~e_L,~e_R,~mu_L,~mu_R,~tau_L,~tau_R,~tau_1 +C ,~tau_2 +C SUPER(26:28) = mass of ~nu_e,~nu_mu,~nu_tau +C SUPER(29) = Higgsino mass = - mu +C SUPER(30) = ratio v2/v1 of vev's +C SUPER(31:34) = Signed neutralino masses +C SUPER(35:50) = Neutralino mixing matrix +C SUPER(51:52) = Signed chargino masses +C SUPER(53:54) = Chargino left, right mixing angles +C SUPER(55:58) = mass of h0, H0, A0, H+ +C SUPER(59) = Higgs mixing angle alpha +C SUPER(60:65) = A_t, theta_t, A_b, theta_b, A_tau, theta_tau +C SUPER(66) = Gravitino mass +C SUPER(67:69) = Top,Bottom, and Tau masses at MSUSY (not used) +C SUPER(70) = b-Yukawa at mA scale (not used) +C SUPER(71:72) = H_u, H_d vev's at MSUSY (not used) +C GSS: Filled by ISASUGRA +C GSS( 1) = g_1 GSS( 2) = g_2 GSS( 3) = g_3 +C GSS( 4) = y_tau GSS( 5) = y_b GSS( 6) = y_t +C GSS( 7) = M_1 GSS( 8) = M_2 GSS( 9) = M_3 +C GSS(10) = A_tau GSS(11) = A_b GSS(12) = A_t +C GSS(13) = M_h12 GSS(14) = M_h22 GSS(15) = M_er2 +C GSS(16) = M_el2 GSS(17) = M_dnr2 GSS(18) = M_upr2 +C GSS(19) = M_upl2 GSS(20) = M_taur2 GSS(21) = M_taul2 +C GSS(22) = M_btr2 GSS(23) = M_tpr2 GSS(24) = M_tpl2 +C GSS(25) = mu GSS(26) = B GSS(27) = Y_N +C GSS(28) = M_nr GSS(29) = A_n GSS(30) = log(vdq) +C GSS(31) = log(vuq) +C MSS: Filled by ISASUGRA +C MSS( 1) = glss MSS( 2) = upl MSS( 3) = upr +C MSS( 4) = dnl MSS( 5) = dnr MSS( 6) = stl +C MSS( 7) = str MSS( 8) = chl MSS( 9) = chr +C MSS(10) = b1 MSS(11) = b2 MSS(12) = t1 +C MSS(13) = t2 MSS(14) = nuel MSS(15) = numl +C MSS(16) = nutl MSS(17) = el- MSS(18) = er- +C MSS(19) = mul- MSS(20) = mur- MSS(21) = tau1 +C MSS(22) = tau2 MSS(23) = z1ss MSS(24) = z2ss +C MSS(25) = z3ss MSS(26) = z4ss MSS(27) = w1ss +C MSS(28) = w2ss MSS(29) = hl0 MSS(30) = hh0 +C MSS(31) = ha0 MSS(32) = h+ +C Unification, filled by ISASUGRA if applicable. +C MGUTSS = M_GUT GGUTSS = g_GUT AGUTSS = alpha_GUTC + +C...SPYTHIA Input/Output + INTEGER IMSS + DOUBLE PRECISION RMSS + COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) + COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), + &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) +C...SLHA Input/Output + COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100), + & AU(3,3),AD(3,3),AE(3,3) +C...PYTHIA common blocks + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + + SAVE /PYMSSM/,/PYSSMT/,/PYLH3P/,/PYDAT1/,/PYPARS/,/PYDAT2/ +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + INTEGER IMODEL + REAL M0,MHF,A0,MT + CHARACTER*20 CHMOD(5) + CHARACTER*32 FNAME + + COMMON /SUGNU/ XNUSUG(18) + REAL XNUSUG + SAVE /SUGNU/ + + DATA CHMOD/'mSUGRA','mGMSB','non-universal SUGRA', + & 'truly unified SUGRA', 'non-minimal GMSB'/ + +C...Start by checking for incompatibilities/inconsistencies: + DO 100 ICHK=2,9 + IF (ICHK.NE.8.AND.ICHK.NE.4.AND.IMSS(ICHK).NE.0) THEN + WRITE (MSTU(11),*) '(PYSUGI:) IMSS(',ICHK,')=',IMSS(ICHK) + & ,' option not used by PYSUGI' + ENDIF + 100 CONTINUE +C...ISAJET works with REAL numbers. + MZERO=REAL(RMSS(8)) + MHLF=REAL(RMSS(1)) + AZERO=REAL(RMSS(16)) + TANB=REAL(RMSS(5)) + SGNMU=REAL(RMSS(4)) + MTOP=REAL(PMAS(6,1)) + IMODEL=0 + IF (IMSS(1).EQ.12) THEN + IMODEL=1 + GOTO 130 + ELSEIF(IMSS(1).EQ.13) THEN +C...Read from isajet par file in IMSS(20) + LFN=IMSS(20) +C...STOP IF LFN IS ZERO (i.e. if no LFN was given). + IF (LFN.EQ.0) THEN + WRITE(MSTU(11),*) '(PYSUGI:) No valid unit given in IMSS(20)' + GOTO 9999 + ENDIF + WRITE(MSTU(11),*) 'READING SUSY MODEL FROM FILE...' +CMrenna change to allow any susy model + WRITE(MSTU(11),*) 'ENTER 1 for mSUGRA:' + WRITE(MSTU(11),*) 'ENTER 2 for mGMSB:' + WRITE(MSTU(11),*) 'ENTER 3 for non-universal SUGRA:' + WRITE(MSTU(11),*) 'ENTER 4 for SUGRA with truly unified'// + & ' gauge couplings:' + WRITE(MSTU(11),*) 'ENTER 5 for non-minimal GMSB:' + READ(LFN,*) IMODEL + IF (IMODEL.EQ.4) THEN + IAL3UN=1 + IMODEL=1 + ENDIF + IF (IMODEL.EQ.1.OR.IMODEL.EQ.3) THEN + WRITE(MSTU(11),*) 'ENTER M_0, M_(1/2), A_0, tan(beta),' + & //' sgn(mu), M_t:' + READ(LFN,*) M0,MHF,A0,TANB,SGNMU,MT + IF (IMODEL.EQ.3) THEN + IMODEL=1 + 110 WRITE(MSTU(11),*) ' ENTER 1,...,5 for NUSUGx keyword;' + & //' 0 to continue:' + WRITE(MSTU(11),*) ' NUSUG1 = GUT scale gaugino masses' + WRITE(MSTU(11),*) ' NUSUG2 = GUT scale A terms' + WRITE(MSTU(11),*) ' NUSUG3 = GUT scale Higgs masses' + WRITE(MSTU(11),*) ' NUSUG4 = GUT scale 1st/2nd' + & //' generation masses' + WRITE(MSTU(11),*) + & ' NUSUG5 = GUT scale 3rd generation masses' + READ(LFN,*) INUSUG + IF (INUSUG.EQ.0) THEN + GOTO 120 + ELSEIF (INUSUG.EQ.1) THEN + WRITE(MSTU(11),*) 'Enter GUT scale M_1, M_2, M_3:' + READ(LFN,*) XNUSUG(1),XNUSUG(2),XNUSUG(3) + IF (XNUSUG(3).LE.0.) THEN + WRITE(MSTU(11),*) ' NEGATIVE M_3 IS NOT ALLOWED' + CALL PYSTOP(109) + END IF + ELSEIF (INUSUG.EQ.2) THEN + WRITE(MSTU(11),*) 'Enter GUT scale A_t, A_b, A_tau:' + READ(LFN,*) XNUSUG(6),XNUSUG(5),XNUSUG(4) + ELSEIF (INUSUG.EQ.3) THEN + WRITE(MSTU(11),*) 'Enter GUT scale m_Hd, m_Hu:' + READ(LFN,*) XNUSUG(7),XNUSUG(8) + ELSEIF (INUSUG.EQ.4) THEN + WRITE(MSTU(11),*) 'Enter GUT scale M(ul), M(dr),' + & //' M(ur), M(el), M(er):' + READ(LFN,*) XNUSUG(13),XNUSUG(11),XNUSUG(12), + & XNUSUG(10),XNUSUG(9) + ELSEIF (INUSUG.EQ.5) THEN + WRITE(MSTU(11),*) 'Enter GUT scale M(tl), M(br), M(tr),' + & //' M(Ll), M(Lr):' + READ(LFN,*) XNUSUG(18),XNUSUG(16),XNUSUG(17), + & XNUSUG(15),XNUSUG(14) + ENDIF + GOTO 110 + ENDIF + ELSEIF (IMODEL.EQ.2.OR.IMODEL.EQ.5) THEN + IMSS(11)=1 + WRITE(MSTU(11),*) 'ENTER Lambda, M_mes, N_5, tan(beta),' + & ,' sgn(mu), M_t, C_gv:' + READ(LFN,*) M0,MHF,A0,TANB,SGNMU,MT,XCMGV + XGMIN(7)=XCMGV + XGMIN(8)=1. +C...Planck scale: AMPL = 2.4 E18 GeV = {8 pi G_newton}^{1/2} + AMPL=2.4D18 + AMGVSS=M0*MHF*XCMGV/SQRT(3D0)/AMPL + IF (IMODEL.EQ.5) THEN + IMODEL=2 + WRITE(MSTU(11),*) 'Rsl = factor multiplying gaugino' + & ,' masses at M_mes' + WRITE(MSTU(11),*) 'dmH_d2, dmH_u2 = Higgs mass**2' + & ,' shifts at M_mes' + WRITE(MSTU(11),*) 'd_Y = mass**2 shifts proportional to', + & ' Y at M_mes' + WRITE(MSTU(11),*) 'n5_1,n5_2,n5_3 = n5 values for U(1),' + & ,'SU(2),SU(3)' + WRITE(MSTU(11),*) 'ENTER Rsl, dmH_d2, dmH_u2, d_Y, n5_1,' + & ,' n5_2, n5_3' + READ(LFN,*) XGMIN(8),XGMIN(9),XGMIN(10),XGMIN(11),XGMIN(12), + $ XGMIN(13),XGMIN(14) + ENDIF + ELSE + WRITE(MSTU(11),*) 'Invalid model choice.' + GOTO 9999 + ENDIF + ENDIF + + 120 MZERO=M0 + MHLF=MHF + AZERO=A0 +C TANB=REAL(RMSS(5)) +C SGNMU=REAL(RMSS(4)) + MTOP=MT + +C...Initialize MSSM parameter array + 130 DO 140 IPAR=1,72 + SUPER(IPAR)=0.0 + 140 CONTINUE +C...Call ISASUGRA + CALL SUGRA(MZERO,MHLF,AZERO,TANB,SGNMU,MTOP,IMODEL) +C...Check whether ISASUSY thought the model was OK. + IF (NOGOOD.NE.0) THEN + IF (NOGOOD.EQ.1) CALL PYERRM(26 + & ,'(PYSUGI:) SUSY parameters give tachyonic particles.') + IF (NOGOOD.EQ.2) CALL PYERRM(26 + & ,'(PYSUGI:) SUSY parameters give no EWSB.') + IF (NOGOOD.EQ.3) CALL PYERRM(26 + & ,'(PYSUGI:) SUSY parameters give m(A0) < 0.') + IF (NOGOOD.EQ.4) CALL PYERRM(26 + & ,'(PYSUGI:) SUSY parameters give Yukawa > 100.') + IF (NOGOOD.EQ.7) CALL PYERRM(26 + & ,'(PYSUGI:) SUSY parameters give x_T EWSB bad.') + IF (NOGOOD.EQ.8) CALL PYERRM(26 + & ,'(PYSUGI:) SUSY parameters give m(h0)2 < 0.') +C...Give warning, but don't stop, if LSP not ~chi_10. + IF (NOGOOD.EQ.5) CALL PYERRM(16 + & ,'(PYSUGI:) SUSY parameters give ~chi_10 not LSP.') + ENDIF +C...Warn about possible GUT scale tachyons. + IF (ITACHY.NE.0) CALL PYERRM(16, + & '(PYSUGI:) Tachyonic sleptons at GUT scale.') +C...Finalize spectrum (last iteration) +C...(Thanks to A. Raklev for pointing this out.) +C...NB: SSMSSM also calculates decays, but these are not used by Pythia. + CALL SSMSSM(XISAIN(1),XISAIN(2),XISAIN(3), + $ XISAIN(4),XISAIN(5),XISAIN(6),XISAIN(7),XISAIN(8),XISAIN(9), + $ XISAIN(10),XISAIN(11),XISAIN(12),XISAIN(13),XISAIN(14), + $ XISAIN(15),XISAIN(16),XISAIN(17),XISAIN(18),XISAIN(19), + $ XISAIN(20),XISAIN(21),XISAIN(22),XISAIN(23),XISAIN(24), + $ MTOP,IALLOW,1) + +C...M1, M2, M3. + RMSS(1)=dble(GSS(7)) + RMSS(2)=dble(GSS(8)) + RMSS(3)=dble(GSS(9)) + RMSOFT(1)=dble(GSS(7)) + RMSOFT(2)=dble(GSS(8)) + RMSOFT(3)=dble(GSS(9)) +C...Mu = - Higgsino mass. + RMSS(4)=-SUPER(29) + RMSS(5)=TANB +C...Slepton and squark masses. 2 first generations. + RMSS(6)=0.5*(SUPER(18)+SUPER(20)) + RMSS(7)=0.5*(SUPER(19)+SUPER(21)) + RMSS(8)=0.25*(SUPER(2)+SUPER(4)+SUPER(6)+SUPER(8)) + RMSS(9)=0.25*(SUPER(3)+SUPER(5)+SUPER(7)+SUPER(9)) +C...Third generation. + RMSS(10)=0.5*(SUPER(14)+SUPER(10)) + RMSS(11)=SUPER(11) + RMSS(12)=SUPER(15) + RMSS(13)=SUPER(22) + RMSS(14)=SUPER(23) +C...SLHA: store exact soft spectrum in RMSOFT + RMSOFT(31)=SUPER(18) + RMSOFT(32)=SUPER(20) + RMSOFT(33)=SUPER(22) + RMSOFT(34)=SUPER(19) + RMSOFT(35)=SUPER(21) + RMSOFT(36)=SUPER(23) + RMSOFT(41)=0.5D0*(SUPER(2)+SUPER(4)) + RMSOFT(42)=0.5D0*(SUPER(6)+SUPER(8)) + RMSOFT(43)=0.5D0*(SUPER(10)+SUPER(14)) + RMSOFT(44)=SUPER(3) + RMSOFT(45)=SUPER(9) + RMSOFT(46)=SUPER(15) + RMSOFT(47)=SUPER(5) + RMSOFT(48)=SUPER(7) + RMSOFT(49)=SUPER(11) + +C...~b, ~t, and ~tau trilinear couplings and mixing angles. + RMSS(15)=SUPER(62) + RMSS(16)=SUPER(60) + RMSS(17)=SUPER(64) + RMSS(26)=SUPER(63) + RMSS(27)=SUPER(61) + RMSS(28)=SUPER(65) +C...SLHA trilinears + DO 142 K1=1,3 + DO 141 K2=1,3 + AE(K1,K2)=0D0 + AU(K1,K2)=0D0 + AD(K1,K2)=0D0 + 141 CONTINUE + 142 CONTINUE + AE(3,3)=SUPER(64) + AU(3,3)=SUPER(60) + AD(3,3)=SUPER(62) +C...Higgs mixing angle alpha (Gunion-Haber convention). + RMSS(18)=-SUPER(59) +C...A0 mass. + RMSS(19)=SUPER(57) +C...GUT scale coupling + RMSS(20)=AGUTSS +C...Gravitino mass (for future compatibility) + RMSS(21)=MAX(RMSS(21),DBLE(SUPER(66))) + +C...Now we're done with RMSS. Time to fill PMAS (m > 0 required). +C...Higgs sector. + PMAS(PYCOMP(25),1)=ABS(SUPER(55)) + PMAS(PYCOMP(35),1)=ABS(SUPER(56)) + PMAS(PYCOMP(36),1)=ABS(SUPER(57)) + PMAS(PYCOMP(37),1)=ABS(SUPER(58)) +C...Gluino. + PMAS(PYCOMP(KSUSY1+21),1)=ABS(SUPER(1)) +C...Squarks and Sleptons. + DO 150 ILR=1,2 + ILRM=ILR-1 + PMAS(PYCOMP(ILR*KSUSY1+1),1)=ABS(SUPER(4+ILRM)) + PMAS(PYCOMP(ILR*KSUSY1+2),1)=ABS(SUPER(2+ILRM)) + PMAS(PYCOMP(ILR*KSUSY1+3),1)=ABS(SUPER(6+ILRM)) + PMAS(PYCOMP(ILR*KSUSY1+4),1)=ABS(SUPER(8+ILRM)) + PMAS(PYCOMP(ILR*KSUSY1+5),1)=ABS(SUPER(12+ILRM)) + PMAS(PYCOMP(ILR*KSUSY1+6),1)=ABS(SUPER(16+ILRM)) + PMAS(PYCOMP(ILR*KSUSY1+11),1)=ABS(SUPER(18+ILRM)) + PMAS(PYCOMP(ILR*KSUSY1+13),1)=ABS(SUPER(20+ILRM)) + PMAS(PYCOMP(ILR*KSUSY1+15),1)=ABS(SUPER(24+ILRM)) + 150 CONTINUE + PMAS(PYCOMP(KSUSY1+12),1)=ABS(SUPER(26)) + PMAS(PYCOMP(KSUSY1+14),1)=ABS(SUPER(27)) + PMAS(PYCOMP(KSUSY1+16),1)=ABS(SUPER(28)) +C...Neutralinos. + PMAS(PYCOMP(KSUSY1+22),1)=ABS(SUPER(31)) + PMAS(PYCOMP(KSUSY1+23),1)=ABS(SUPER(32)) + PMAS(PYCOMP(KSUSY1+25),1)=ABS(SUPER(33)) + PMAS(PYCOMP(KSUSY1+35),1)=ABS(SUPER(34)) +C...Signed masses (extra minus from going to G-H convention). + SMZ(1)=-SUPER(31) + SMZ(2)=-SUPER(32) + SMZ(3)=-SUPER(33) + SMZ(4)=-SUPER(34) +C...Charginos + PMAS(PYCOMP(KSUSY1+24),1)=ABS(SUPER(51)) + PMAS(PYCOMP(KSUSY1+37),1)=ABS(SUPER(52)) +C...Signed masses (extra minus from going to G-H convention). + SMW(1)=-SUPER(51) + SMW(2)=-SUPER(52) + +C... Neutralino Mixing. + DO 160 IN=1,4 + ZMIX(IN,1)= SUPER(38+4*(IN-1)) + ZMIX(IN,2)= SUPER(37+4*(IN-1)) + ZMIX(IN,3)=-SUPER(36+4*(IN-1)) + ZMIX(IN,4)=-SUPER(35+4*(IN-1)) + 160 CONTINUE +C...Chargino Mixing (PYTHIA same angle as HERWIG). + THX=1D0 + THY=1D0 + IF (SUPER(53).GT.0) THX=-1D0 + IF (SUPER(54).GT.0) THY=-1D0 + UMIX(1,1) = -SIN(SUPER(53)) + UMIX(1,2) = -COS(SUPER(53)) + UMIX(2,1) = -THX*COS(SUPER(53)) + UMIX(2,2) = THX*SIN(SUPER(53)) + VMIX(1,1) = -SIN(SUPER(54)) + VMIX(1,2) = -COS(SUPER(54)) + VMIX(2,1) = -THY*COS(SUPER(54)) + VMIX(2,2) = THY*SIN(SUPER(54)) +C...Sfermion mixing (PYTHIA same angle as ISAJET) + SFMIX(5,1)=COS(SUPER(63)) + SFMIX(5,2)=SIN(SUPER(63)) + SFMIX(5,3)=-SIN(SUPER(63)) + SFMIX(5,4)=COS(SUPER(63)) + SFMIX(6,1)=COS(SUPER(61)) + SFMIX(6,2)=SIN(SUPER(61)) + SFMIX(6,3)=-SIN(SUPER(61)) + SFMIX(6,4)=COS(SUPER(61)) + SFMIX(15,1)=COS(SUPER(65)) + SFMIX(15,2)=SIN(SUPER(65)) + SFMIX(15,3)=-SIN(SUPER(65)) + SFMIX(15,4)=COS(SUPER(65)) + + IF (MSTP(122).NE.0) THEN +C...Print a few lines to make the user know what's happening + ISAVER=VISAJE() + WRITE(MSTU(11),5000) DOC, ISAVER + WRITE(MSTU(11),5100) + IF (IMODEL.EQ.1) THEN + WRITE(MSTU(11),5200) MZERO, MHLF, AZERO, TANB, NINT(SGNMU), + & MTOP + WRITE(MSTU(11),5300) + ENDIF + WRITE(MSTU(11),5500) 'Pole masses' + WRITE(MSTU(11),5700) (SUPER(IP),IP=2,16,2),(SUPER(IP),IP=3,17,2) + WRITE(MSTU(11),5800) (SUPER(IP),IP=18,24,2),(SUPER(IP),IP=26,28) + & ,(SUPER(IP),IP=19,25,2) + WRITE(MSTU(11),5900) SUPER(1),(SMZ(IP),IP=1,4), (SMW(IP) + & ,IP=1,2) + WRITE(MSTU(11),5400) + WRITE(MSTU(11),6000) (SUPER(IP),IP=55,58) + WRITE(MSTU(11),5400) + WRITE(MSTU(11),5500) 'EW scale mixing structure' + WRITE(MSTU(11),6100) ((ZMIX(I,J), J=1,4),I=1,4) + WRITE(MSTU(11),6200) (UMIX(1,J), J=1,2),(VMIX(1,J),J=1,2) + & ,(UMIX(2,J), J=1,2),(VMIX(2,J),J=1,2) + WRITE(MSTU(11),6300) (SFMIX(5,J), J=1,2),(SFMIX(6,J),J=1,2) + & ,(SFMIX(15,J), J=1,2),(SFMIX(5,J),J=3,4),(SFMIX(6,J), J=3,4 + & ),(SFMIX(15,J),J=3,4) + WRITE(MSTU(11),5400) + WRITE(MSTU(11),6450) RMSS(18) + WRITE(MSTU(11),5400) + WRITE(MSTU(11),5500) 'Couplings' + WRITE(MSTU(11),6400) RMSS(15),RMSS(16),RMSS(17),RMSS(20) + WRITE(MSTU(11),5400) + ENDIF + +C...Call FeynHiggs to improve Higgs sector if requested + IF (IMSS(4).EQ.3) THEN + IF (MSTP(122).NE.0) WRITE(MSTU(11),'(1x,"*"/1x,"*",A)') + & ' (PYSUGI:) Now calling FeynHiggs.' + CALL PYFEYN(IERR) + IF (IERR.EQ.0) THEN + IMSS(4)=2 + IF (MSTP(122).NE.0) THEN + WRITE(MSTU(11),5400) + WRITE(MSTU(11),5500) + & 'Corrected Higgs masses and mixing' + WRITE(MSTU(11),6000) PMAS(25,1),PMAS(35,1),PMAS(36,1), + & PMAS(37,1) + WRITE(MSTU(11),6450) RMSS(18) + WRITE(MSTU(11),5400) + ENDIF + ENDIF + ENDIF + + IF (MSTP(122).NE.0) WRITE(MSTU(11),6500) + +C...Fix the higgs sector (in PYMSIN) using the masses and mixing angle +C...output by ISASUSY. + IMSS(4)=MAX(2,IMSS(4)) + + 5000 FORMAT(1x,19('*'),1x,'PYSUGI v1.52: PYTHIA/ISASUSY ' + & ,'INTERFACE',1x,19('*')/1x,'*',3x,'PYSUGI: Last Change',1x,A + & ,1x,'-',1x,'P. Skands / S. Mrenna'/1x,'*',2x,A/1x,'*') + 5100 FORMAT(1x,'*',1x,'ISASUSY Input:'/1x,'*',1x,'----------------') + 5200 FORMAT(1x,'*',1x,3x,'M_0',6x,'M_1/2',5x,'A_0',3x,'Tan(beta)', + & 3x,'Sgn(mu)',3x,'M_t'/1x,'*',1x,4(F8.2,1x),I8,2x,F8.2) + 5300 FORMAT(1x,'*'/1x,'*',1x,'ISASUSY Output:'/1x,'*',1x + & ,'----------------') + 5400 FORMAT(1x,'*',1x,A) + 5500 FORMAT(1x,'*',1x,A,':') + 5600 FORMAT(1x,'*',2x,2x,'M_GUT',2x,2x,'g_GUT',2x,1x,'alpha_GUT'/ + & 1x,'*',2x,1P,2(1x,E8.2),2x,E8.2) + 5700 FORMAT(1x,'*',4x,4x,'~u',2x,1x,4x,'~d',2x,1x,4x,'~s',2x,1x, + & 4x,'~c',2x,1x,4x,'~b',2x,1x,2x,'~b(12)',1x,4x,'~t',2x,1x, 2x, + & '~t(12)'/1x,'*',2x,'L',1x,8(F8.2,1x)/1x,'*',2x,'R',1x,8(F8.2 + & ,1x)) + 5800 FORMAT(1x,'*'/1x,'*',4x,4x,'~e',2x,1x,3x,'~mu',2x,1x,3x,'~tau',1x + & ,1x,'~tau(12)',1x,2x,'~nu_e',1x,1x,1x,'~nu_mu',1x,1x,1x + & ,'~nu_tau'/1x,'*',2x,'L',1x,7(F8.2,1x)/1x,'*',2x,'R',1x,4(F8 + & .2,1x)) + 5900 FORMAT(1x,'*'/1x,'*',4x,4x,'~g',2x,1x,1x,'~chi_10',1x,1x,'~chi_20' + & ,1x,1x,'~chi_30',1x,1x,'~chi_40',1x,1x,'~chi_1+',1x + & ,1x,'~chi_2+'/1x,'*',3x,1x,7(F8.2,1x)) + 6000 FORMAT(1x,'*',4x,4x,'h0',2x,1x,4x,'H0',2x,1x,4x,'A0',2x + & ,1x,4x,'H+'/1x,'*',3x,1x,5(F8.2,1x)) + 6050 FORMAT(1x,'*'/1x,'*',4x,4x,'h0',2x,1x,4x,'H0',2x,1x,4x,'A0',2x + & ,1x,4x,'H+'/1x,'*',3x,1x,5(F8.2,1x),3x,'(Before FeynHiggs)') + 6100 FORMAT(1x,'*',11x,'|',3x,'~B',3x,'|',2x,'~W_3',2x,'|',2x + & ,'~H_1',2x,'|',2x,'~H_2',2x,'|'/1x,'*',3x,'~chi_10',1x,4('|' + & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_20',1x,4('|' + & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_30',1x,4('|' + & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_40',1x,4('|' + & ,1x,F6.3,1x),'|') + 6200 FORMAT(1x,'*'/1x,'*',6x,'L',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|' + & ,12x,'R',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'/1x,'*',3x + & ,'~chi_1+',1x,2('|',1x,F6.3,1x),'|',9x,'~chi_1+',1x,2('|',1x + & ,F6.3,1x),'|'/1x,'*',3x,'~chi_2+',1x,2('|',1x,F6.3,1x),'|',9x + & ,'~chi_2+',1x,2('|',1x,F6.3,1x),'|') + 6300 FORMAT(1x,'*'/1x,'*',8x,'|',2x,'~b_L',2x,'|',2x,'~b_R',2x,'|',8x + & ,'|',2x,'~t_L',2x,'|',2x,'~t_R',2x,'|',10x + & ,'|',1x,'~tau_L',1x,'|',1x,'~tau_R',1x,'|'/ + & 1x,'*',3x,'~b_1',1x,2('|',1x,F6.3,1x),'|',3x,'~t_1',1x,2('|' + & ,1x,F6.3,1x),'|',3x,'~tau_1',1x,2('|',1x,F6.3,1x),'|'/ + & 1x,'*',3x,'~b_2',1x,2('|',1x,F6.3,1x),'|',3x,'~t_2',1x,2('|' + & ,1x,F6.3,1x),'|',3x,'~tau_2',1x,2('|',1x,F6.3,1x),'|') + 6400 FORMAT(1x,'*',3x,'A_b = ',F8.2,4x,'A_t = ',F8.2,4x,'A_tau = ',F8.2 + & ,4x,'Alpha_GUT = ',F8.2) + 6450 FORMAT(1x,'*',3x,'Alpha_Higgs = ',F8.4) + 6500 FORMAT(1x,32('*'),1x,'END OF PYSUGI',1x,31('*')) + + 9999 RETURN + END + +C********************************************************************* + +C...PYFEYN +C...Interface to FeynHiggs for MSSM Higgs sector. +C...Pythia6.402: Updated to FeynHiggs v.2.3.0+ w/ DOUBLE COMPLEX +C...P. Skands + + SUBROUTINE PYFEYN(IERR) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) +C...SUSY blocks + COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) +C...FeynHiggs variables + DOUBLE PRECISION RMHIGG(4) + DOUBLE COMPLEX SAEFF, UHIGGS(3,3) + DOUBLE COMPLEX DMU, + & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11, + & DM1, DM2, DM3 +C...SLHA Common Block + COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100), + & AU(3,3),AD(3,3),AE(3,3) + SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYLH3P/ + + IERR=0 + CALL FHSETFLAGS(IERR,4,0,0,2,0,2,1,1) + IF (IERR.NE.0) THEN + CALL PYERRM(11,'(PYHGGM:) Caught error from FHSETFLAGS.' + & //'Will not use FeynHiggs for this run.') + RETURN + ENDIF + Q=RMSOFT(0) + DMB=PMAS(5,1) + DMT=PMAS(6,1) + DMZ=PMAS(23,1) + DMW=PMAS(24,1) + DMA=PMAS(36,1) + DM1=RMSOFT(1) + DM2=RMSOFT(2) + DM3=RMSOFT(3) + DTANB=RMSS(5) + DMU=RMSS(4) + DM3SL=RMSOFT(33) + DM3SE=RMSOFT(36) + DM3SQ=RMSOFT(43) + DM3SU=RMSOFT(46) + DM3SD=RMSOFT(49) + DM2SL=RMSOFT(32) + DM2SE=RMSOFT(35) + DM2SQ=RMSOFT(42) + DM2SU=RMSOFT(45) + DM2SD=RMSOFT(48) + DM1SL=RMSOFT(31) + DM1SE=RMSOFT(34) + DM1SQ=RMSOFT(41) + DM1SU=RMSOFT(44) + DM1SD=RMSOFT(47) + AE33=AE(3,3) + AE22=AE(2,2) + AE11=AE(1,1) + AU33=AU(3,3) + AU22=AU(2,2) + AU11=AU(1,1) + AD33=AD(3,3) + AD22=AD(2,2) + AD11=AD(1,1) + CALL FHSETPARA(IERR, 1D0, DMT, DMB, DMW, DMZ, DTANB, + & DMA,0D0, DM3SL, DM3SE, DM3SQ, DM3SU, DM3SD, + & DM2SL, DM2SE, DM2SQ, DM2SU, DM2SD, + & DM1SL, DM1SE, DM1SQ, DM1SU, DM1SD,DMU, + & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11, + & DM1, DM2, DM3, 0D0, 0D0,Q,Q,Q) + IF (IERR.NE.0) THEN + CALL PYERRM(11,'(PYHGGM:) Caught error from FHSETPARA.' + & //' Will not use FeynHiggs for this run.') + RETURN + ENDIF +C... Get Higgs masses & alpha_eff. (UHIGGS redundant here, only for CPV) + SAEFF=0D0 + CALL FHHIGGSCORR(IERR, RMHIGG, SAEFF, UHIGGS) + IF (IERR.NE.0) THEN + CALL PYERRM(11,'(PYFEYN:) Caught error from FHHIG'// + & 'GSCORR. Will not use FeynHiggs for this run.') + RETURN + ENDIF + ALPHA = ASIN(DBLE(SAEFF)) + R=RMSS(18)/ALPHA + IF (R.LT.0D0.OR.ABS(R).GT.1.2D0.OR.ABS(R).LT.0.8D0) THEN + CALL PYERRM(1,'(PYFEYN:) Large corrections in Higgs sector.') + WRITE(MSTU(11),*) ' Old Alpha:', RMSS(18) + WRITE(MSTU(11),*) ' New Alpha:', ALPHA + ENDIF + IF (RMHIGG(1).LT.0.85D0*PMAS(25,1).OR.RMHIGG(1).GT. + & 1.15D0*PMAS(25,1)) THEN + CALL PYERRM(1,'(PYFEYN:) Large corrections in Higgs sector.') + WRITE(MSTU(11),*) ' Old m(h0):', PMAS(25,1) + WRITE(MSTU(11),*) ' New m(h0):', RMHIGG(1) + ENDIF + RMSS(18)=ALPHA + PMAS(25,1)=RMHIGG(1) + PMAS(35,1)=RMHIGG(2) + PMAS(36,1)=RMHIGG(3) + PMAS(37,1)=RMHIGG(4) + + RETURN + END + +C********************************************************************* + +C...PYRNMQ +C...Determines the running mass of Squarks. + + FUNCTION PYRNMQ(ID,DTERM) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblock. + COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) + SAVE /PYMSSM/ + +C...Local variables. + DOUBLE PRECISION PI,R + DOUBLE PRECISION TOL + DOUBLE PRECISION CI(3) + EXTERNAL PYALPS + DOUBLE PRECISION PYALPS + DATA TOL/0.001D0/ + DATA PI,R/3.141592654D0,.61803399D0/ + DATA CI/0.47D0,0.07D0,0.02D0/ + + C=1D0-R + CA=CI(ID) + AG=(0.71D0)**2/4D0/PI + AG=RMSS(20) + XM0=RMSS(8) + XMG=RMSS(1) + XM02=XM0*XM0 + XMG2=XMG*XMG + + AS=PYALPS(XM02+6D0*XMG2) + CG=8D0/9D0*((AS/AG)**2-1D0) + BX=XM02+(CA+CG)*XMG2+DTERM + AX=MIN(50D0**2,0.5D0*BX) + CX=MAX(2000D0**2,2D0*BX) + + X0=AX + X3=CX + IF(ABS(CX-BX).GT.ABS(BX-AX))THEN + X1=BX + X2=BX+C*(CX-BX) + ELSE + X2=BX + X1=BX-C*(BX-AX) + ENDIF + AS1=PYALPS(X1) + CG=8D0/9D0*((AS1/AG)**2-1D0) + F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1) + AS2=PYALPS(X2) + CG=8D0/9D0*((AS2/AG)**2-1D0) + F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2) + 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN + IF(F2.LT.F1) THEN + X0=X1 + X1=X2 + X2=R*X1+C*X3 + F1=F2 + AS2=PYALPS(X2) + CG=8D0/9D0*((AS2/AG)**2-1D0) + F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2) + ELSE + X3=X2 + X2=X1 + X1=R*X2+C*X0 + F2=F1 + AS1=PYALPS(X1) + CG=8D0/9D0*((AS1/AG)**2-1D0) + F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1) + ENDIF + GOTO 100 + ENDIF + IF(F1.LT.F2) THEN + PYRNMQ=X1 + XMIN=X1 + ELSE + PYRNMQ=X2 + XMIN=X2 + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYTHRG +C...Calculates the mass eigenstates of the third generation sfermions. +C...Created: 5-31-96 + + SUBROUTINE PYTHRG + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) + COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), + &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) + SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/ + +C...Local variables. + DOUBLE PRECISION BETA + DOUBLE PRECISION AM2(2,2),RT(2,2),DI(2,2) + DOUBLE PRECISION XMZ2,XMW2,TANB,XMU,COS2B,XMQL2,XMQR2 + DOUBLE PRECISION XMF,XMF2,DIFF,SAME,XMF12,XMF22,SMALL + DOUBLE PRECISION ATR,AMQR,AMQL + INTEGER ID1(3),ID2(3),ID3(3),ID4(3) + INTEGER IF,I,J,II,JJ,IT,L + LOGICAL DTERM + DATA SMALL/1D-3/ + DATA ID1/10,10,13/ + DATA ID2/5,6,15/ + DATA ID3/15,16,17/ + DATA ID4/11,12,14/ + DATA DTERM/.TRUE./ + + XMZ2=PMAS(23,1)**2 + XMW2=PMAS(24,1)**2 + TANB=RMSS(5) + XMU=-RMSS(4) + BETA=ATAN(TANB) + COS2B=COS(2D0*BETA) + +C...OPTION TO FIX T1, T2, B1 MASSES AND MIXINGS + + IOPT=IMSS(5) + IF(IOPT.EQ.1) THEN + CTT=DCOS(RMSS(27)) + CTT2=CTT**2 + STT=DSIN(RMSS(27)) + STT2=STT**2 + XM12=RMSS(10)**2 + XM22=RMSS(12)**2 + XMQL2=CTT2*XM12+STT2*XM22 + XMQR2=STT2*XM12+CTT2*XM22 + XMF2=PYMRUN(6,PMAS(6,1)**2)**2 + ATOP=-XMU/TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2) + RMSS(16)=ATOP +C......SUBTRACT OUT D-TERM AND FERMION MASS + XMQL2=XMQL2-XMF2-(4D0*XMW2-XMZ2)*COS2B/6D0 + XMQR2=XMQR2-XMF2+(XMW2-XMZ2)*COS2B*2D0/3D0 + IF(XMQL2.GE.0D0) THEN + RMSS(10)=SQRT(XMQL2) + ELSE + RMSS(10)=-SQRT(-XMQL2) + ENDIF + IF(XMQR2.GE.0D0) THEN + RMSS(12)=SQRT(XMQR2) + ELSE + RMSS(12)=-SQRT(-XMQR2) + ENDIF + +C SAME FOR BOTTOM SQUARK + CTT=DCOS(RMSS(26)) + CTT2=CTT**2 + STT=DSIN(RMSS(26)) + STT2=STT**2 + XM22=RMSS(11)**2 + XMF2=PYMRUN(5,PMAS(6,1)**2)**2 + XMQL2=SIGN(RMSS(10)**2,RMSS(10))-(2D0*XMW2+XMZ2)*COS2B/6D0+XMF2 + IF(ABS(CTT).GE..9999D0) THEN + ABOT=-XMU*TANB + XMQR2=RMSS(11)**2 + ELSEIF(ABS(CTT).LE.1D-4) THEN + ABOT=-XMU*TANB + XMQR2=RMSS(11)**2 + ELSE + XM12=(XMQL2-STT2*XM22)/CTT2 + XMQR2=STT2*XM12+CTT2*XM22 + ABOT=-XMU*TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2) + ENDIF + RMSS(15)=ABOT +C......SUBTRACT OUT D-TERM AND FERMION MASS + XMQR2=XMQR2-(XMW2-XMZ2)*COS2B/3D0-XMF2 + IF(XMQR2.GE.0D0) THEN + RMSS(11)=SQRT(XMQR2) + ELSE + RMSS(11)=-SQRT(-XMQR2) + ENDIF +C SAME FOR TAU SLEPTON + CTT=DCOS(RMSS(28)) + CTT2=CTT**2 + STT=DSIN(RMSS(28)) + STT2=STT**2 + XM12=RMSS(13)**2 + XM22=RMSS(14)**2 + XMQL2=CTT2*XM12+STT2*XM22 + XMQR2=STT2*XM12+CTT2*XM22 + XMFR=PMAS(15,1) + XMF2=XMFR**2 + ATAU=-XMU*TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2) + RMSS(17)=ATAU +C......SUBTRACT OUT D-TERM AND FERMION MASS + XMQL2=XMQL2-XMF2+(-.5D0*XMZ2+XMW2)*COS2B + XMQR2=XMQR2-XMF2+(XMZ2-XMW2)*COS2B + IF(XMQL2.GE.0D0) THEN + RMSS(13)=SQRT(XMQL2) + ELSE + RMSS(13)=-SQRT(-XMQL2) + ENDIF + IF(XMQR2.GE.0D0) THEN + RMSS(14)=SQRT(XMQR2) + ELSE + RMSS(14)=-SQRT(-XMQR2) + ENDIF + ENDIF + DO 170 L=1,3 + AMQL=RMSS(ID1(L)) + IF(AMQL.LT.0D0) THEN + XMQL2=-AMQL**2 + ELSE + XMQL2=AMQL**2 + ENDIF + ATR=RMSS(ID3(L)) + AMQR=RMSS(ID4(L)) + IF(AMQR.LT.0D0) THEN + XMQR2=-AMQR**2 + ELSE + XMQR2=AMQR**2 + ENDIF + IF=ID2(L) + XMF=PYMRUN(IF,PMAS(6,1)**2) + XMF2=XMF**2 + AM2(1,1)=XMQL2+XMF2 + AM2(2,2)=XMQR2+XMF2 + IF(AM2(1,1).EQ.AM2(2,2)) AM2(2,2)=AM2(2,2)*1.00001D0 + IF(DTERM) THEN + IF(L.EQ.1) THEN + AM2(1,1)=AM2(1,1)-(2D0*XMW2+XMZ2)*COS2B/6D0 + AM2(2,2)=AM2(2,2)+(XMW2-XMZ2)*COS2B/3D0 + AM2(1,2)=XMF*(ATR+XMU*TANB) + ELSEIF(L.EQ.2) THEN + AM2(1,1)=AM2(1,1)+(4D0*XMW2-XMZ2)*COS2B/6D0 + AM2(2,2)=AM2(2,2)-(XMW2-XMZ2)*COS2B*2D0/3D0 + AM2(1,2)=XMF*(ATR+XMU/TANB) + ELSEIF(L.EQ.3) THEN + IF(IMSS(8).EQ.1) THEN + AM2(1,1)=RMSS(6)**2 + AM2(2,2)=RMSS(7)**2 + AM2(1,2)=0D0 + RMSS(13)=RMSS(6) + RMSS(14)=RMSS(7) + ELSE + AM2(1,1)=AM2(1,1)-(-.5D0*XMZ2+XMW2)*COS2B + AM2(2,2)=AM2(2,2)-(XMZ2-XMW2)*COS2B + AM2(1,2)=XMF*(ATR+XMU*TANB) + ENDIF + ENDIF + ENDIF + AM2(2,1)=AM2(1,2) + DETM=AM2(1,1)*AM2(2,2)-AM2(2,1)**2 + IF(DETM.LT.0D0) THEN + WRITE(MSTU(11),*) ID2(L),DETM,AM2 + CALL PYERRM(30,' NEGATIVE**2 MASS FOR SFERMION IN PYTHRG ') + ENDIF + SAME=0.5D0*(AM2(1,1)+AM2(2,2)) + DIFF=0.5D0*SQRT((AM2(1,1)-AM2(2,2))**2+4D0*AM2(1,2)*AM2(2,1)) + XMF12=SAME-DIFF + XMF22=SAME+DIFF + IT=0 + IF(XMF22-XMF12.GT.0D0) THEN + RT(1,1) = SQRT(MAX(0D0,(XMF22-AM2(1,1))/(XMF22-XMF12))) + RT(2,2) = RT(1,1) + RT(1,2) = -SIGN(SQRT(MAX(0D0,1D0-RT(1,1)**2)), + & AM2(1,2)/(XMF22-XMF12)) + RT(2,1) = -RT(1,2) + ELSE + RT(1,1) = 1D0 + RT(2,2) = RT(1,1) + RT(1,2) = 0D0 + RT(2,1) = -RT(1,2) + ENDIF + 100 CONTINUE + IT=IT+1 + + DO 140 I=1,2 + DO 130 JJ=1,2 + DI(I,JJ)=0D0 + DO 120 II=1,2 + DO 110 J=1,2 + DI(I,JJ)=DI(I,JJ)+RT(I,J)*AM2(J,II)*RT(JJ,II) + 110 CONTINUE + 120 CONTINUE + 130 CONTINUE + 140 CONTINUE + + IF(DI(1,1).GT.DI(2,2)) THEN + WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION ' + WRITE(MSTU(11),*) L,SQRT(XMF12),SQRT(XMF22) + WRITE(MSTU(11),*) AM2 + WRITE(MSTU(11),*) DI + WRITE(MSTU(11),*) RT + DI(1,1)=-RT(2,1) + DI(2,2)=RT(1,2) + DI(1,2)=-RT(2,2) + DI(2,1)=RT(1,1) + DO 160 I=1,2 + DO 150 J=1,2 + RT(I,J)=DI(I,J) + 150 CONTINUE + 160 CONTINUE + GOTO 100 + ELSEIF(ABS(DI(1,2)*DI(2,1)/DI(1,1)/DI(2,2)).GT.SMALL) THEN + WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'// + & ' OFF DIAGONAL ELEMENTS ' + WRITE(MSTU(11),*) 'MASSES = ',L,SQRT(XMF12),SQRT(XMF22) + WRITE(MSTU(11),*) DI + WRITE(MSTU(11),*) ' ROTATION = ',RT +C...STOP + ELSEIF(DI(1,1).LT.0D0.OR.DI(2,2).LT.0D0) THEN + WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'// + & ' NEGATIVE MASSES ' + CALL PYSTOP(111) + ENDIF + PMAS(PYCOMP(KSUSY1+IF),1)=SQRT(XMF12) + PMAS(PYCOMP(KSUSY2+IF),1)=SQRT(XMF22) + SFMIX(IF,1)=RT(1,1) + SFMIX(IF,2)=RT(1,2) + SFMIX(IF,3)=RT(2,1) + SFMIX(IF,4)=RT(2,2) + 170 CONTINUE + +C.....TAU SNEUTRINO MASS...L=3 + + XARG=AM2(1,1)+XMW2*COS2B + IF(XARG.LT.0D0) THEN + WRITE(MSTU(11),*) ' PYTHRG:: TAU SNEUTRINO MASS IS NEGATIVE'// + & ' FROM THE SUM RULE. ' + WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). ' + RETURN + ELSE + PMAS(PYCOMP(KSUSY1+16),1)=SQRT(XARG) + ENDIF + + RETURN + END +C********************************************************************* + +C...PYINOM +C...Finds the mass eigenstates and mixing matrices for neutralinos +C...and charginos. + + SUBROUTINE PYINOM + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) + COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), + &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) + SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/ + +C...Local variables. + DOUBLE PRECISION XMW,XMZ,XM(4) + DOUBLE PRECISION AR(5,5),WR(5),ZR(5,5),ZI(5,5),AI(5,5) + DOUBLE PRECISION WI(5),FV1(5),FV2(5),FV3(5) + DOUBLE PRECISION COSW,SINW + DOUBLE PRECISION XMU + DOUBLE PRECISION TANB,COSB,SINB + DOUBLE PRECISION XM1,XM2,XM3,BETA + DOUBLE PRECISION Q2,AEM,A1,A2,AQ,RM1,RM2 + DOUBLE PRECISION ARG,X0,X1,AX0,AX1,AT,BT + DOUBLE PRECISION Y0,Y1,AMGX0,AM1X0,AMGX1,AM1X1 + DOUBLE PRECISION ARGX0,AR1X0,ARGX1,AR1X1 + DOUBLE PRECISION PYALPS,PYALEM + DOUBLE PRECISION PYRNM3 + COMPLEX*16 CAR(4,4),CAI(4,4),CA1,CA2 + INTEGER IERR,INDEX(4),I,J,K,IOPT,ILR,KFNCHI(4) + DATA KFNCHI/1000022,1000023,1000025,1000035/ + + IOPT=IMSS(2) + IF(IMSS(1).EQ.2) THEN + IOPT=1 + ENDIF +C...M1, M2, AND M3 ARE INDEPENDENT + IF(IOPT.EQ.0) THEN + XM1=RMSS(1) + XM2=RMSS(2) + XM3=RMSS(3) + ELSEIF(IOPT.GE.1) THEN + Q2=PMAS(23,1)**2 + AEM=PYALEM(Q2) + A2=AEM/PARU(102) + A1=AEM/(1D0-PARU(102)) + XM1=RMSS(1) + XM2=RMSS(2) + IF(IMSS(1).EQ.2) XM1=RMSS(1)/RMSS(20)*A1*5D0/3D0 + IF(IOPT.EQ.1) THEN + XM2=XM1*A2/A1*3D0/5D0 + RMSS(2)=XM2 + ELSEIF(IOPT.EQ.3) THEN + XM1=XM2*5D0/3D0*A1/A2 + RMSS(1)=XM1 + ENDIF + XM3=PYRNM3(XM2/A2) + RMSS(3)=XM3 + IF(XM3.LE.0D0) THEN + WRITE(MSTU(11),*) ' ERROR WITH M3 = ',XM3 + CALL PYSTOP(105) + ENDIF + ENDIF + +C...GLUINO MASS + IF(IMSS(3).EQ.1) THEN + PMAS(PYCOMP(KSUSY1+21),1)=ABS(XM3) + ELSE + AQ=0D0 + DO 110 I=1,4 + DO 100 ILR=1,2 + RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2 + AQ=AQ+0.5D0*((2D0-RM1)*(RM1*LOG(RM1)-1D0) + & +(1D0-RM1)**2*LOG(ABS(1D0-RM1))) + 100 CONTINUE + 110 CONTINUE + + DO 130 I=5,6 + DO 120 ILR=1,2 + RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2 + RM2=PMAS(I,1)**2/XM3**2 + ARG=(RM1-RM2-1D0)**2-4D0*RM2**2 + IF(ARG.GE.0D0) THEN + X0=0.5D0*(1D0+RM2-RM1-SQRT(ARG)) + AX0=ABS(X0) + X1=0.5D0*(1D0+RM2-RM1+SQRT(ARG)) + AX1=ABS(X1) + IF(X0.EQ.1D0) THEN + AT=-1D0 + BT=0.25D0 + ELSEIF(X0.EQ.0D0) THEN + AT=0D0 + BT=-0.25D0 + ELSE + AT=0.5D0*LOG(ABS(1D0-X0))*(1D0-X0**2)+ + & 0.5D0*X0**2*LOG(AX0) + BT=(-1D0-2D0*X0)/4D0 + ENDIF + IF(X1.EQ.1D0) THEN + AT=-1D0+AT + BT=0.25D0+BT + ELSEIF(X1.EQ.0D0) THEN + AT=0D0+AT + BT=-0.25D0+BT + ELSE + AT=0.5D0*LOG(ABS(1D0-X1))*(1D0-X1**2)+0.5D0* + & X1**2*LOG(AX1)+AT + BT=(-1D0-2D0*X1)/4D0+BT + ENDIF + AQ=AQ+AT+BT + ELSE + X0=0.5D0*(1D0+RM2-RM1) + Y0=-0.5D0*SQRT(-ARG) + AMGX0=SQRT(X0**2+Y0**2) + AM1X0=SQRT((1D0-X0)**2+Y0**2) + ARGX0=ATAN2(-X0,-Y0) + AR1X0=ATAN2(1D0-X0,Y0) + X1=X0 + Y1=-Y0 + AMGX1=AMGX0 + AM1X1=AM1X0 + ARGX1=ATAN2(-X1,-Y1) + AR1X1=ATAN2(1D0-X1,Y1) + AT=0.5D0*LOG(AM1X0)*(1D0-X0**2+3D0*Y0**2) + & +0.5D0*(X0**2-Y0**2)*LOG(AMGX0) + BT=(-1D0-2D0*X0)/4D0+X0*Y0*( AR1X0-ARGX0 ) + AT=AT+0.5D0*LOG(AM1X1)*(1D0-X1**2+3D0*Y1**2) + & +0.5D0*(X1**2-Y1**2)*LOG(AMGX1) + BT=BT+(-1D0-2D0*X1)/4D0+X1*Y1*( AR1X1-ARGX1 ) + AQ=AQ+AT+BT + ENDIF + 120 CONTINUE + 130 CONTINUE + PMAS(PYCOMP(KSUSY1+21),1)=ABS(XM3)*(1D0+PYALPS(XM3**2) + & /(2D0*PARU(2))*(15D0+AQ)) + ENDIF + +C...NEUTRALINO MASSES + DO 150 I=1,4 + DO 140 J=1,4 + AI(I,J)=0D0 + 140 CONTINUE + 150 CONTINUE + XMZ=PMAS(23,1)/100D0 + XMW=PMAS(24,1)/100D0 + XMU=RMSS(4)/100D0 + SINW=SQRT(PARU(102)) + COSW=SQRT(1D0-PARU(102)) + TANB=RMSS(5) + BETA=ATAN(TANB) + COSB=COS(BETA) + SINB=TANB*COSB + + XM2=XM2/100D0 + XM1=XM1/100D0 + + +C... Definitions: +C... psi^0 =(-i bino^0, -i wino^0, h_d^0(=H_1^0), h_u^0(=H_2^0)) +C... => L_neutralino = -1/2*(psi^0)^T * [AR] * psi^0 + h.c. + AR(1,1) = XM1*COS(RMSS(30)) + AI(1,1) = XM1*SIN(RMSS(30)) + AR(2,2) = XM2*COS(RMSS(31)) + AI(2,2) = XM2*SIN(RMSS(31)) + AR(3,3) = 0D0 + AR(4,4) = 0D0 + AR(1,2) = 0D0 + AR(2,1) = 0D0 + AR(1,3) = -XMZ*SINW*COSB + AR(3,1) = AR(1,3) + AR(1,4) = XMZ*SINW*SINB + AR(4,1) = AR(1,4) + AR(2,3) = XMZ*COSW*COSB + AR(3,2) = AR(2,3) + AR(2,4) = -XMZ*COSW*SINB + AR(4,2) = AR(2,4) + AR(3,4) = -XMU*COS(RMSS(33)) + AI(3,4) = -XMU*SIN(RMSS(33)) + AR(4,3) = -XMU*COS(RMSS(33)) + AI(4,3) = -XMU*SIN(RMSS(33)) +C CALL PYEIG4(AR,WR,ZR) + CALL PYEICG(5,4,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR) + IF(IERR.NE.0) CALL PYERRM(18,'(PYINOM:) '// + & 'PROBLEM WITH PYEICG IN PYINOM ') + DO 160 I=1,4 + INDEX(I)=I + XM(I)=ABS(WR(I)) + 160 CONTINUE + DO 180 I=2,4 + K=I + DO 170 J=I-1,1,-1 + IF(XM(K).LT.XM(J)) THEN + ITMP=INDEX(J) + XTMP=XM(J) + INDEX(J)=INDEX(K) + XM(J)=XM(K) + INDEX(K)=ITMP + XM(K)=XTMP + K=K-1 + ELSE + GOTO 180 + ENDIF + 170 CONTINUE + 180 CONTINUE + + + DO 210 I=1,4 + K=INDEX(I) + SMZ(I)=WR(K)*100D0 + PMAS(PYCOMP(KFNCHI(I)),1)=ABS(SMZ(I)) + S=0D0 + DO 190 J=1,4 + S=S+ZR(J,K)**2+ZI(J,K)**2 + 190 CONTINUE + DO 200 J=1,4 + ZMIX(I,J)=ZR(J,K)/SQRT(S) + ZMIXI(I,J)=ZI(J,K)/SQRT(S) + IF(ABS(ZMIX(I,J)).LT.1D-6) ZMIX(I,J)=0D0 + IF(ABS(ZMIXI(I,J)).LT.1D-6) ZMIXI(I,J)=0D0 + 200 CONTINUE + 210 CONTINUE + +C...CHARGINO MASSES +C.....Find eigenvectors of X X^* + DO I=1,4 + DO J=1,4 + AR(I,J)=0D0 + AI(I,J)=0D0 + ENDDO + ENDDO + AI(1,1) = 0D0 + AI(2,2) = 0D0 + AR(1,1) = XM2**2+2D0*XMW**2*SINB**2 + AR(2,2) = XMU**2+2D0*XMW**2*COSB**2 + AR(1,2) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*COSB+ + &XMU*COS(RMSS(33))*SINB) + AI(1,2) = SQRT(2D0)*XMW*(XM2*SIN(RMSS(31))*COSB- + &XMU*SIN(RMSS(33))*SINB) + AR(2,1) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*COSB+ + &XMU*COS(RMSS(33))*SINB) + AI(2,1) = SQRT(2D0)*XMW*(-XM2*SIN(RMSS(31))*COSB+ + &XMU*SIN(RMSS(33))*SINB) + CALL PYEICG(5,2,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR) + IF(IERR.NE.0) CALL PYERRM(18,'(PYINOM:) '// + & 'PROBLEM WITH PYEICG IN PYINOM ') + INDEX(1)=1 + INDEX(2)=2 + IF(WR(2).LT.WR(1)) THEN + INDEX(1)=2 + INDEX(2)=1 + ENDIF + + + DO 240 I=1,2 + K=INDEX(I) + SMW(I)=SQRT(WR(K))*100D0 + S=0D0 + DO 220 J=1,2 + S=S+ZR(J,K)**2+ZI(J,K)**2 + 220 CONTINUE + DO 230 J=1,2 + UMIX(I,J)=ZR(J,K)/SQRT(S) + UMIXI(I,J)=-ZI(J,K)/SQRT(S) + IF(ABS(UMIX(I,J)).LT.1D-6) UMIX(I,J)=0D0 + IF(ABS(UMIXI(I,J)).LT.1D-6) UMIXI(I,J)=0D0 + 230 CONTINUE + 240 CONTINUE +C...Force chargino mass > neutralino mass + IFRC=0 + IF(ABS(SMW(1)).LT.ABS(SMZ(1))+2D0*PMAS(PYCOMP(111),1)) THEN + CALL PYERRM(8,'(PYINOM:) '// + & 'forcing m(~chi+_1) > m(~chi0_1) + 2m(pi0)') + SMW(1)=SIGN(ABS(SMZ(1))+2D0*PMAS(PYCOMP(111),1),SMW(1)) + IFRC=1 + ENDIF + PMAS(PYCOMP(KSUSY1+24),1)=SMW(1) + PMAS(PYCOMP(KSUSY1+37),1)=SMW(2) + +C.....Find eigenvectors of X^* X + DO I=1,4 + DO J=1,4 + AR(I,J)=0D0 + AI(I,J)=0D0 + ZR(I,J)=0D0 + ZI(I,J)=0D0 + ENDDO + ENDDO + AI(1,1) = 0D0 + AI(2,2) = 0D0 + AR(1,1) = XM2**2+2D0*XMW**2*COSB**2 + AR(2,2) = XMU**2+2D0*XMW**2*SINB**2 + AR(1,2) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*SINB+ + &XMU*COS(RMSS(33))*COSB) + AI(1,2) = SQRT(2D0)*XMW*(-XM2*SIN(RMSS(31))*SINB+ + &XMU*SIN(RMSS(33))*COSB) + AR(2,1) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*SINB+ + &XMU*COS(RMSS(33))*COSB) + AI(2,1) = SQRT(2D0)*XMW*(XM2*SIN(RMSS(31))*SINB- + &XMU*SIN(RMSS(33))*COSB) + CALL PYEICG(5,2,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR) + IF(IERR.NE.0) CALL PYERRM(18,'(PYINOM:) '// + & 'PROBLEM WITH PYEICG IN PYINOM ') + INDEX(1)=1 + INDEX(2)=2 + IF(WR(2).LT.WR(1)) THEN + INDEX(1)=2 + INDEX(2)=1 + ENDIF + + SIMAG=0D0 + DO 270 I=1,2 + K=INDEX(I) + S=0D0 + DO 250 J=1,2 + S=S+ZR(J,K)**2+ZI(J,K)**2 + SIMAG=SIMAG+ZI(J,K)**2 + 250 CONTINUE + DO 260 J=1,2 + VMIX(I,J)=ZR(J,K)/SQRT(S) + VMIXI(I,J)=-ZI(J,K)/SQRT(S) + IF(ABS(VMIX(I,J)).LT.1D-6) VMIX(I,J)=0D0 + IF(ABS(VMIXI(I,J)).LT.1D-6) VMIXI(I,J)=0D0 + 260 CONTINUE + 270 CONTINUE + +C.....Simplify if no phases + IF(SIMAG.LT.1D-6) THEN + AR(1,1) = XM2*COS(RMSS(31)) + AR(2,2) = XMU*COS(RMSS(33)) + AR(1,2) = SQRT(2D0)*XMW*SINB + AR(2,1) = SQRT(2D0)*XMW*COSB + IKNT=0 + 300 CONTINUE + DO I=1,2 + DO J=1,2 + ZR(I,J)=0D0 + ENDDO + ENDDO + + DO I=1,2 + DO J=1,2 + DO K=1,2 + DO L=1,2 + ZR(I,J)=ZR(I,J)+UMIX(I,K)*AR(K,L)*VMIX(J,L) + ENDDO + ENDDO + ENDDO + ENDDO + VMIX(1,1)=VMIX(1,1)*SMW(1)/ZR(1,1)/100D0 + VMIX(1,2)=VMIX(1,2)*SMW(1)/ZR(1,1)/100D0 + VMIX(2,1)=VMIX(2,1)*SMW(2)/ZR(2,2)/100D0 + VMIX(2,2)=VMIX(2,2)*SMW(2)/ZR(2,2)/100D0 + IF(IKNT.EQ.2.AND.IFRC.EQ.0) THEN + CALL PYERRM(18,'(PYINOM:) Problem with Charginos') + ELSEIF(ZR(1,1).LT.0D0.OR.ZR(2,2).LT.0D0) THEN + IKNT=IKNT+1 + GOTO 300 + ENDIF +C.....Must deal with phases + ELSE + CAR(1,1) = XM2*CMPLX(COS(RMSS(31)),SIN(RMSS(31))) + CAR(2,2) = XMU*CMPLX(COS(RMSS(33)),SIN(RMSS(33))) + CAR(1,2) = SQRT(2D0)*XMW*SINB*CMPLX(1D0,0D0) + CAR(2,1) = SQRT(2D0)*XMW*COSB*CMPLX(1D0,0D0) + + IKNT=0 + 310 CONTINUE + DO I=1,2 + DO J=1,2 + CAI(I,J)=CMPLX(0D0,0D0) + ENDDO + ENDDO + + DO I=1,2 + DO J=1,2 + DO K=1,2 + DO L=1,2 + CAI(I,J)=CAI(I,J)+CMPLX(UMIX(I,K),-UMIXI(I,K))*CAR(K,L)* + & CMPLX(VMIX(J,L),VMIXI(J,L)) + ENDDO + ENDDO + ENDDO + ENDDO + + CA1=SMW(1)*CAI(1,1)/ABS(CAI(1,1))**2/100D0 + CA2=SMW(2)*CAI(2,2)/ABS(CAI(2,2))**2/100D0 + TEMPR=VMIX(1,1) + TEMPI=VMIXI(1,1) + VMIX(1,1)=TEMPR*DBLE(CA1)-TEMPI*DIMAG(CA1) + VMIXI(1,1)=TEMPI*DBLE(CA1)+TEMPR*DIMAG(CA1) + TEMPR=VMIX(1,2) + TEMPI=VMIXI(1,2) + VMIX(1,2)=TEMPR*DBLE(CA1)-TEMPI*DIMAG(CA1) + VMIXI(1,2)=TEMPI*DBLE(CA1)+TEMPR*DIMAG(CA1) + TEMPR=VMIX(2,1) + TEMPI=VMIXI(2,1) + VMIX(2,1)=TEMPR*DBLE(CA2)-TEMPI*DIMAG(CA2) + VMIXI(2,1)=TEMPI*DBLE(CA2)+TEMPR*DIMAG(CA2) + TEMPR=VMIX(2,2) + TEMPI=VMIXI(2,2) + VMIX(2,2)=TEMPR*DBLE(CA2)-TEMPI*DIMAG(CA2) + VMIXI(2,2)=TEMPI*DBLE(CA2)+TEMPR*DIMAG(CA2) + IF(IKNT.EQ.2.AND.IFRC.EQ.0) THEN + CALL PYERRM(18,'(PYINOM:) Problem with Charginos') + ELSEIF(DBLE(CA1).LT.0D0.OR.DBLE(CA2).LT.0D0.OR. + & ABS(IMAG(CA1)).GT.1D-3.OR.ABS(IMAG(CA2)).GT.1D-3) THEN + IKNT=IKNT+1 + GOTO 310 + ENDIF + ENDIF + RETURN + END + +C********************************************************************* + +C...PYRNM3 +C...Calculates the running of M3, the SU(3) gluino mass parameter. + + FUNCTION PYRNM3(RGUT) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP + +C...Local variables. + DOUBLE PRECISION R + DOUBLE PRECISION TOL + EXTERNAL PYALPS + DOUBLE PRECISION PYALPS + DATA TOL/0.001D0/ + DATA R/0.61803399D0/ + + C=1D0-R + + BX=RGUT*PYALPS(RGUT**2) + AX=MIN(50D0,BX*0.5D0) + CX=MAX(2000D0,2D0*BX) + + X0=AX + X3=CX + IF(ABS(CX-BX).GT.ABS(BX-AX))THEN + X1=BX + X2=BX+C*(CX-BX) + ELSE + X2=BX + X1=BX-C*(BX-AX) + ENDIF + AS1=PYALPS(X1**2) + F1=ABS(X1-RGUT*AS1) + AS2=PYALPS(X2**2) + F2=ABS(X2-RGUT*AS2) + 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN + IF(F2.LT.F1) THEN + X0=X1 + X1=X2 + X2=R*X1+C*X3 + F1=F2 + AS2=PYALPS(X2**2) + F2=ABS(X2-RGUT*AS2) + ELSE + X3=X2 + X2=X1 + X1=R*X2+C*X0 + F2=F1 + AS1=PYALPS(X1**2) + F1=ABS(X1-RGUT*AS1) + ENDIF + GOTO 100 + ENDIF + IF(F1.LT.F2) THEN + PYRNM3=X1 + XMIN=X1 + ELSE + PYRNM3=X2 + XMIN=X2 + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYEIG4 +C...Finds eigenvalues and eigenvectors to a 4 * 4 matrix. +C...Specific application: mixing in neutralino sector. + + SUBROUTINE PYEIG4(A,W,Z) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP + +C...Arrays: in call and local. + DIMENSION A(4,4),W(4),Z(4,4),X(4),D(4,4),E(4) + +C...Coefficients of fourth-degree equation from matrix. +C...x**4 + b3 * x**3 + b2 * x**2 + b1 * x + b0 = 0. + B3=-(A(1,1)+A(2,2)+A(3,3)+A(4,4)) + B2=0D0 + DO 110 I=1,3 + DO 100 J=I+1,4 + B2=B2+A(I,I)*A(J,J)-A(I,J)*A(J,I) + 100 CONTINUE + 110 CONTINUE + B1=0D0 + B0=0D0 + DO 120 I=1,4 + I1=MOD(I,4)+1 + I2=MOD(I+1,4)+1 + I3=MOD(I+2,4)+1 + B1=B1+A(I,I)*(-A(I1,I1)*A(I2,I2)+A(I1,I2)*A(I2,I1)+ + & A(I1,I3)*A(I3,I1)+A(I2,I3)*A(I3,I2))- + & A(I,I1)*A(I1,I2)*A(I2,I)-A(I,I2)*A(I2,I1)*A(I1,I) + B0=B0+(-1D0)**(I+1)*A(1,I)*( + & A(2,I1)*(A(3,I2)*A(4,I3)-A(3,I3)*A(4,I2))+ + & A(2,I2)*(A(3,I3)*A(4,I1)-A(3,I1)*A(4,I3))+ + & A(2,I3)*(A(3,I1)*A(4,I2)-A(3,I2)*A(4,I1))) + 120 CONTINUE + +C...Coefficients of third-degree equation needed for +C...separation into two second-degree equations. +C...u**3 + c2 * u**2 + c1 * u + c0 = 0. + C2=-B2 + C1=B1*B3-4D0*B0 + C0=-B1**2-B0*B3**2+4D0*B0*B2 + CQ=C1/3D0-C2**2/9D0 + CR=C1*C2/6D0-C0/2D0-C2**3/27D0 + CQR=CQ**3+CR**2 + +C...Cases with one or three real roots. + IF(CQR.GE.0D0) THEN + S1=(CR+SQRT(CQR))**(1D0/3D0) + S2=(CR-SQRT(CQR))**(1D0/3D0) + U=S1+S2-C2/3D0 + ELSE + SABS=SQRT(-CQ) + THE=ACOS(CR/SABS**3)/3D0 + SRE=SABS*COS(THE) + U=2D0*SRE-C2/3D0 + ENDIF + +C...Find and solve two second-degree equations. + P1=B3/2D0-SQRT(B3**2/4D0+U-B2) + P2=B3/2D0+SQRT(B3**2/4D0+U-B2) + Q1=U/2D0+SQRT(U**2/4D0-B0) + Q2=U/2D0-SQRT(U**2/4D0-B0) + IF(ABS(P1*Q1+P2*Q2-B1).LT.ABS(P1*Q2+P2*Q1-B1)) THEN + QSAV=Q1 + Q1=Q2 + Q2=QSAV + ENDIF + X(1)=-P1/2D0+SQRT(P1**2/4D0-Q1) + X(2)=-P1/2D0-SQRT(P1**2/4D0-Q1) + X(3)=-P2/2D0+SQRT(P2**2/4D0-Q2) + X(4)=-P2/2D0-SQRT(P2**2/4D0-Q2) + +C...Order eigenvalues in asceding mass. + W(1)=X(1) + DO 150 I1=2,4 + DO 130 I2=I1-1,1,-1 + IF(ABS(X(I1)).GE.ABS(W(I2))) GOTO 140 + W(I2+1)=W(I2) + 130 CONTINUE + 140 W(I2+1)=X(I1) + 150 CONTINUE + +C...Find equation system for eigenvectors. + DO 250 I=1,4 + DO 170 J1=1,4 + D(J1,J1)=A(J1,J1)-W(I) + DO 160 J2=J1+1,4 + D(J1,J2)=A(J1,J2) + D(J2,J1)=A(J2,J1) + 160 CONTINUE + 170 CONTINUE + +C...Find largest element in matrix. + DAMAX=0D0 + DO 190 J1=1,4 + DO 180 J2=1,4 + IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 180 + JA=J1 + JB=J2 + DAMAX=ABS(D(J1,J2)) + 180 CONTINUE + 190 CONTINUE + +C...Subtract others by multiple of row selected above. + DAMAX=0D0 + DO 210 J3=JA+1,JA+3 + J1=J3-4*((J3-1)/4) + RL=D(J1,JB)/D(JA,JB) + DO 200 J2=1,4 + D(J1,J2)=D(J1,J2)-RL*D(JA,J2) + IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 200 + JC=J1 + JD=J2 + DAMAX=ABS(D(J1,J2)) + 200 CONTINUE + 210 CONTINUE + +C...Do one more subtraction of a row. + DAMAX=0D0 + DO 230 J3=JC+1,JC+3 + J1=J3-4*((J3-1)/4) + IF(J1.EQ.JA) GOTO 230 + RL=D(J1,JD)/D(JC,JD) + DO 220 J2=1,4 + IF(J2.EQ.JB) GOTO 220 + D(J1,J2)=D(J1,J2)-RL*D(JC,J2) + IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 220 + JE=J1 + DAMAX=ABS(D(J1,J2)) + 220 CONTINUE + 230 CONTINUE + +C...Construct unnormalized eigenvector. + JF1=JD+1-4*(JD/4) + JF2=JD+2-4*((JD+1)/4) + IF(JF1.EQ.JB) JF1=JD+3-4*((JD+2)/4) + IF(JF2.EQ.JB) JF2=JD+3-4*((JD+2)/4) + E(JF1)=-D(JE,JF2) + E(JF2)=D(JE,JF1) + E(JD)=-(D(JC,JF1)*E(JF1)+D(JC,JF2)*E(JF2))/D(JC,JD) + E(JB)=-(D(JA,JF1)*E(JF1)+D(JA,JF2)*E(JF2)+D(JA,JD)*E(JD))/ + & D(JA,JB) + +C...Normalize and fill in final array. + EA=SQRT(E(1)**2+E(2)**2+E(3)**2+E(4)**2) + SGN=(-1D0)**INT(PYR(0)+0.5D0) + DO 240 J=1,4 + Z(I,J)=SGN*E(J)/EA + 240 CONTINUE + 250 CONTINUE + + RETURN + END + +C********************************************************************* + +C...PYHGGM +C...Determines the Higgs boson mass spectrum using several inputs. + + SUBROUTINE PYHGGM(ALPHA) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) + SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/ + +C...Local variables. + DOUBLE PRECISION AT,AB,XMU,TANB + DOUBLE PRECISION ALPHA + INTEGER IHOPT + DOUBLE PRECISION DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD + DOUBLE PRECISION DMU,DMH,DHM,DMHCH,DSA,DCA,DTANBA + DOUBLE PRECISION DMC,DMDR,DMHP,DHMP,DAMP + DOUBLE PRECISION DSTOP1,DSTOP2,DSBOT1,DSBOT2 + + IHOPT=IMSS(4) + IF(IHOPT.EQ.2) THEN + ALPHA=RMSS(18) + RETURN + ENDIF + AT=RMSS(16) + AB=RMSS(15) + DMGL=RMSS(3) + XMU=RMSS(4) + TANB=RMSS(5) + + DMA=RMSS(19) + DTANB=TANB + DMQ=RMSS(10) + DMUR=RMSS(12) + DMDR=RMSS(11) + DMTOP=PMAS(6,1) + DMC=PMAS(PYCOMP(KSUSY1+37),1) + DAU=AT + DAD=AB + DMU=XMU + RMSS(40)=0D0 + RMSS(41)=0D0 + + IF(IHOPT.EQ.0) THEN + CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM, + & DMHCH,DSA,DCA,DTANBA) + ELSEIF(IHOPT.EQ.1) THEN + CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM, + & DMHCH,DSA,DCA,DTANBA) + CALL PYPOLE(3,DMC,DMA,DTANB,DMQ,DMUR,DMDR,DMTOP,DAU,DAD,DMU, + & DMH,DMHP,DHM,DHMP,DAMP,DSA,DCA, + & DSTOP1,DSTOP2,DSBOT1,DSBOT2,DTANBA,DMGL,DDT,DDB) + RMSS(40)=DDT + RMSS(41)=DDB + DMH=DMHP + DHM=DHMP + DMA=DAMP + IF(ABS(PMAS(PYCOMP(1000006),1)-DSTOP2).GT.5D-1) THEN + WRITE(MSTU(11),*) ' STOP1 MASS DOES NOT MATCH IN PYHGGM ' + WRITE(MSTU(11),*) ' STOP1 MASSES = ', + & PMAS(PYCOMP(1000006),1),DSTOP2 + ENDIF + IF(ABS(PMAS(PYCOMP(2000006),1)-DSTOP1).GT.5D-1) THEN + WRITE(MSTU(11),*) ' STOP2 MASS DOES NOT MATCH IN PYHGGM ' + WRITE(MSTU(11),*) ' STOP2 MASSES = ', + & PMAS(PYCOMP(2000006),1),DSTOP1 + ENDIF + IF(ABS(PMAS(PYCOMP(1000005),1)-DSBOT2).GT.5D-1) THEN + WRITE(MSTU(11),*) ' SBOT1 MASS DOES NOT MATCH IN PYHGGM ' + WRITE(MSTU(11),*) ' SBOT1 MASSES = ', + & PMAS(PYCOMP(1000005),1),DSBOT2 + ENDIF + IF(ABS(PMAS(PYCOMP(2000005),1)-DSBOT1).GT.5D-1) THEN + WRITE(MSTU(11),*) ' SBOT2 MASS DOES NOT MATCH IN PYHGGM ' + WRITE(MSTU(11),*) ' SBOT2 MASSES = ', + & PMAS(PYCOMP(2000005),1),DSBOT1 + ENDIF + + ELSEIF (IHOPT.EQ.3) THEN +c...Use FeynHiggs to fix Higgs sector (cf feynhiggs.de) +C...Currently only available for SLHA spectrum read-in. + IF (IMSS(1).NE.11.AND.IMSS(1).NE.12.AND.IMSS(1).NE.13) THEN + CALL PYERRM(11,'(PYHGGM:) FeynHiggs needs SLHA or ISASUSY' + & //' spectrum, change IMSS(1) or IMSS(4) option.') + ENDIF + ALPHA=RMSS(18) + RETURN + ENDIF + + ALPHA=ACOS(DCA) + + PMAS(25,1)=DMH + PMAS(35,1)=DHM + PMAS(36,1)=DMA + PMAS(37,1)=DMHCH + + RETURN + END + +C********************************************************************* + +C...PYSUBH +C...This routine computes the renormalization group improved +C...values of Higgs masses and couplings in the MSSM. + +C...Program based on the work by M. Carena, J.R. Espinosa, +c...M. Quiros and C.E.M. Wagner, CERN-preprint CERN-TH/95-45 + +C...Input: MA,TANB = TAN(BETA),MQ,MUR,MTOP,AU,AD,MU +C...All masses in GeV units. MA is the CP-odd Higgs mass, +C...MTOP is the physical top mass, MQ and MUR are the soft +C...supersymmetry breaking mass parameters of left handed +C...and right handed stops respectively, AU and AD are the +C...stop and sbottom trilinear soft breaking terms, +C...respectively, and MU is the supersymmetric +C...Higgs mass parameter. We use the conventions from +C...the physics report of Haber and Kane: left right +C...stop mixing term proportional to (AU - MU/TANB) +C...We use as input TANB defined at the scale MTOP + +C...Output: MH,HM,MHCH, SA = SIN(ALPHA), CA= COS(ALPHA), TANBA +C...where MH and HM are the lightest and heaviest CP-even +C...Higgs masses, MHCH is the charged Higgs mass and +C...ALPHA is the Higgs mixing angle +C...TANBA is the angle TANB at the CP-odd Higgs mass scale + +C...Range of validity: +C...(STOP1**2 - STOP2**2)/(STOP2**2 + STOP1**2) < 0.5 +C...(SBOT1**2 - SBOT2**2)/(SBOT2**2 + SBOT2**2) < 0.5 +C...where STOP1, STOP2, SBOT1 and SBOT2 are the stop and +C...are the sbottom mass eigenvalues, respectively. This +C...range automatically excludes the existence of tachyons. +C...For the charged Higgs mass computation, the method is +C...valid if +C...2 * |MB * AD* TANB| < M_SUSY**2, 2 * |MTOP * AU| < M_SUSY**2 +C...2 * |MB * MU * TANB| < M_SUSY**2, 2 * |MTOP * MU| < M_SUSY**2 +C...where M_SUSY**2 is the average of the squared stop mass +C...eigenvalues, M_SUSY**2 = (STOP1**2 + STOP2**2)/2. The sbottom +C...masses have been assumed to be of order of the stop ones +C...M_SUSY**2 = (MQ**2 + MUR**2)*0.5 + MTOP**2 + + SUBROUTINE PYSUBH (XMA,TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM, + &XMHCH,SA,CA,TANBA) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYHTRI/HHH(7) + SAVE /PYDAT1/,/PYDAT2/ + +C...Local variables. + DOUBLE PRECISION PYALEM,PYALPS + DOUBLE PRECISION TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM + DOUBLE PRECISION XMHCH,SA,CA + DOUBLE PRECISION XMA,AEM,ALP1,ALP2,ALPH3Z,V,PI + DOUBLE PRECISION Q02 + DOUBLE PRECISION TANBA,TANBT,XMB,ALP3 + DOUBLE PRECISION RMTOP,XMS,T,SINB,COSB + DOUBLE PRECISION XLAM1,XLAM2,XLAM3,XLAM4,XLAM5,XLAM6 + DOUBLE PRECISION XLAM7,XAU,XAD,G1,G2,G3,HU,HD,HU2 + DOUBLE PRECISION HD2,HU4,HD4,SINBT,COSBT + DOUBLE PRECISION TRM2,DETM2,XMH2,XHM2,XMHCH2 + DOUBLE PRECISION SINALP,COSALP,AUD,PI2,XMS2,XMS4,AD2 + DOUBLE PRECISION AU2,XMU2,XMZ,XMS3 + + XMZ = PMAS(23,1) + Q02=XMZ**2 + AEM=PYALEM(Q02) + ALP1=AEM/(1D0-PARU(102)) + ALP2=AEM/PARU(102) + ALPH3Z=PYALPS(Q02) + + ALP1 = 0.0101D0 + ALP2 = 0.0337D0 + ALPH3Z = 0.12D0 + + V = 174.1D0 + PI = PARU(1) + TANBA = TANB + TANBT = TANB + +C...MBOTTOM(MTOP) = 3. GEV + XMB = PYMRUN(5,XMTOP**2) + ALP3 = ALPH3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPH3Z* + &LOG(XMTOP**2/XMZ**2)) + +C...RMTOP= RUNNING TOP QUARK MASS + RMTOP = XMTOP/(1D0+4D0*ALP3/3D0/PI) + XMS = ((XMQ**2 + XMUR**2)/2D0 + XMTOP**2)**0.5D0 + T = LOG(XMS**2/XMTOP**2) + SINB = TANB/((1D0 + TANB**2)**0.5D0) + COSB = SINB/TANB +C...IF(MA.LE.XMTOP) TANBA = TANBT + IF(XMA.GT.XMTOP) + &TANBA = TANBT*(1D0-3D0/32D0/PI**2* + &(RMTOP**2/V**2/SINB**2-XMB**2/V**2/COSB**2)* + &LOG(XMA**2/XMTOP**2)) + + SINBT = TANBT/SQRT(1D0 + TANBT**2) + COSBT = 1D0/SQRT(1D0 + TANBT**2) +C COS2BT = (TANBT**2 - 1D0)/(TANBT**2 + 1D0) + G1 = SQRT(ALP1*4D0*PI) + G2 = SQRT(ALP2*4D0*PI) + G3 = SQRT(ALP3*4D0*PI) + HU = RMTOP/V/SINBT + HD = XMB/V/COSBT + HU2=HU*HU + HD2=HD*HD + HU4=HU2*HU2 + HD4=HD2*HD2 + AU2=AU**2 + AD2=AD**2 + XMS2=XMS**2 + XMS3=XMS**3 + XMS4=XMS2*XMS2 + XMU2=XMU*XMU + PI2=PI*PI + + XAU = (2D0*AU2/XMS2)*(1D0 - AU2/12D0/XMS2) + XAD = (2D0*AD2/XMS2)*(1D0 - AD2/12D0/XMS2) + AUD = (-6D0*XMU2/XMS2 - ( XMU2- AD*AU)**2/XMS4 + &+ 3D0*(AU + AD)**2/XMS2)/6D0 + XLAM1 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HD2*T/8D0/PI2) + &+(3D0*HD4/8D0/PI2) * (T + XAD/2D0 + (3D0*HD2/2D0 + HU2/2D0 + &- 8D0*G3**2) * (XAD*T + T**2)/16D0/PI2) + &-(3D0*HU4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HU2 -5D0* HD2 + &- 16D0*G3**2) *T/16D0/PI2) + XLAM2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU2*T/8D0/PI2) + &+(3D0*HU4/8D0/PI2) * (T + XAU/2D0 + (3D0*HU2/2D0 + HD2/2D0 + &- 8D0*G3**2) * (XAU*T + T**2)/16D0/PI2) + &-(3D0*HD4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HD2 -5D0* HU2 + &- 16D0*G3**2) *T/16D0/PI2) + XLAM3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0* + &(HU2 + HD2)*T/16D0/PI2) + &+(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2 + &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2) + &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/ + &XMS4)* (1D0+ (6D0*HU2 -2D0* HD2/2D0 + &- 16D0*G3**2) *T/16D0/PI2) + &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/ + &XMS4)*(1D0+ (6D0*HD2 -2D0* HU2 + &- 16D0*G3**2) *T/16D0/PI2) + XLAM4 = (- G2**2/2D0)*(1D0-3D0*(HU2 + HD2)*T/16D0/PI2) + &-(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2 + &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2) + &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/ + &XMS4)* + &(1+ (6D0*HU2 -2D0* HD2 + &- 16D0*G3**2) *T/16D0/PI2) + &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/ + &XMS4)* + &(1+ (6D0*HD2 -2D0* HU2/2D0 + &- 16D0*G3**2) *T/16D0/PI2) + XLAM5 = -(3D0*HU4* XMU2*AU2/96D0/PI2/XMS4) * + &(1- (2D0*HD2 -6D0* HU2 + 16D0*G3**2) *T/16D0/PI2) + &-(3D0*HD4* XMU2*AD2/96D0/PI2/XMS4) * + &(1- (2D0*HU2 -6D0* HD2 + 16D0*G3**2) *T/16D0/PI2) + XLAM6 = (3D0*HU4* XMU**3*AU/96D0/PI2/XMS4) * + &(1- (7D0*HD2/2D0 -15D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2) + &+(3D0*HD4* XMU *(AD**3/XMS3 - 6D0*AD/XMS )/96D0/PI2/XMS) * + &(1- (HU2/2D0 -9D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2) + XLAM7 = (3D0*HD4* XMU**3*AD/96D0/PI2/XMS4) * + &(1- (7D0*HU2/2D0 -15D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2) + &+(3D0*HU4* XMU *(AU**3/XMS3 - 6D0*AU/XMS )/96D0/PI2/XMS) * + &(1- (HD2/2D0 -9D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2) + HHH(1)=XLAM1 + HHH(2)=XLAM2 + HHH(3)=XLAM3 + HHH(4)=XLAM4 + HHH(5)=XLAM5 + HHH(6)=XLAM6 + HHH(7)=XLAM7 + TRM2 = XMA**2 + 2D0*V**2* (XLAM1* COSBT**2 + + &2D0* XLAM6*SINBT*COSBT + &+ XLAM5*SINBT**2 + XLAM2* SINBT**2 + 2D0* XLAM7*SINBT*COSBT + &+ XLAM5*COSBT**2) + DETM2 = 4D0*V**4*(-(SINBT*COSBT*(XLAM3 + XLAM4) + + &XLAM6*COSBT**2 + &+ XLAM7* SINBT**2)**2 + (XLAM1* COSBT**2 + + &2D0* XLAM6* COSBT*SINBT + &+ XLAM5*SINBT**2)*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT + &+ XLAM5*COSBT**2)) + XMA**2*2D0*V**2 * + &((XLAM1* COSBT**2 +2D0* + &XLAM6* COSBT*SINBT + XLAM5*SINBT**2)*COSBT**2 + + &(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT + XLAM5*COSBT**2) + &*SINBT**2 + &+2D0*SINBT*COSBT* (SINBT*COSBT*(XLAM3 + &+ XLAM4) + XLAM6*COSBT**2 + &+ XLAM7* SINBT**2)) + + XMH2 = (TRM2 - SQRT(TRM2**2 - 4D0* DETM2))/2D0 + XHM2 = (TRM2 + SQRT(TRM2**2 - 4D0* DETM2))/2D0 + XHM = SQRT(XHM2) + XMH = SQRT(XMH2) + XMHCH2 = XMA**2 + (XLAM5 - XLAM4)* V**2 + XMHCH = SQRT(XMHCH2) + + SINALP = SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0) - + &((2D0*V**2*(XLAM1* COSBT**2 + 2D0* + &XLAM6* COSBT*SINBT + &+ XLAM5*SINBT**2) + XMA**2*SINBT**2) + &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT + &+ XLAM5*COSBT**2) + XMA**2*COSBT**2)))/ + &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0))/2D0**0.5D0 + + COSALP = (2D0*(2D0*V**2*(SINBT*COSBT*(XLAM3 + XLAM4) + + &XLAM6*COSBT**2 + XLAM7* SINBT**2) - + &XMA**2*SINBT*COSBT))/2D0**0.5D0/ + &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0)* + &(((TRM2**2 - 4D0* DETM2)**0.5D0) - + &((2D0*V**2*(XLAM1* COSBT**2 + 2D0* + &XLAM6* COSBT*SINBT + &+ XLAM5*SINBT**2) + XMA**2*SINBT**2) + &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT + &+ XLAM5*COSBT**2) + XMA**2*COSBT**2)))) + + SA = -SINALP + CA = -COSALP + + 100 CONTINUE + + RETURN + END + +C********************************************************************* + +C...PYPOLE +C...This subroutine computes the CP-even higgs and CP-odd pole +c...Higgs masses and mixing angles. + +C...Program based on the work by M. Carena, M. Quiros +C...and C.E.M. Wagner, "Effective potential methods and +C...the Higgs mass spectrum in the MSSM", CERN-TH/95-157 + +C...Inputs: IHIGGS(explained below),MCHI,MA,TANB,MQ,MUR,MDR,MTOP, +C...AT,AB,MU +C...where MCHI is the largest chargino mass, MA is the running +C...CP-odd higgs mass, TANB is the value of the ratio of vacuum +C...expectaion values at the scale MTOP, MQ is the third generation +C...left handed squark mass parameter, MUR is the third generation +C...right handed stop mass parameter, MDR is the third generation +C...right handed sbottom mass parameter, MTOP is the pole top quark +C...mass; AT,AB are the soft supersymmetry breaking trilinear +C...couplings of the stop and sbottoms, respectively, and MU is the +C...supersymmetric mass parameter + +C...The parameter IHIGGS=0,1,2,3 corresponds to the number of +C...Higgses whose pole mass is computed. If IHIGGS=0 only running +C...masses are given, what makes the running of the program +c...much faster and it is quite generally a good approximation +c...(for a theoretical discussion see ref. above). If IHIGGS=1, +C...only the pole mass for H is computed. If IHIGGS=2, then h and H, +c...and if IHIGGS=3, then h,H,A polarizations are computed + +C...Output: MH and MHP which are the lightest CP-even Higgs running +C...and pole masses, respectively; HM and HMP are the heaviest CP-even +C...Higgs running and pole masses, repectively; SA and CA are the +C...SIN(ALPHA) and COS(ALPHA) where ALPHA is the Higgs mixing angle +C...AMP is the CP-odd Higgs pole mass. STOP1,STOP2,SBOT1 and SBOT2 +C...are the stop and sbottom mass eigenvalues. Finally, TANBA is +C...the value of TANB at the CP-odd Higgs mass scale + +C...This subroutine makes use of CERN library subroutine +C...integration package, which makes the computation of the +C...pole Higgs masses somewhat faster. We thank P. Janot for this +C...improvement. Those who are not able to call the CERN +C...libraries, please use the subroutine SUBHPOLE2.F, which +C...although somewhat slower, gives identical results + + SUBROUTINE PYPOLE(IHIGGS,XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,XMU, + &XMH,XMHP,HM,HMP,AMP,SA,CA,STOP1,STOP2,SBOT1,SBOT2,TANBA,XMG,DT,DB) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + +C...Parameters. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + SAVE /PYDAT1/ + INTEGER PYK,PYCHGE,PYCOMP + +C...Local variables. + DIMENSION DELTA(2,2),COUPT(2,2),T(2,2),SSTOP2(2), + &SSBOT2(2),B(2,2),COUPB(2,2), + &HCOUPT(2,2),HCOUPB(2,2), + &ACOUPT(2,2),ACOUPB(2,2),PR(3), POLAR(3) + + DELTA(1,1) = 1D0 + DELTA(2,2) = 1D0 + DELTA(1,2) = 0D0 + DELTA(2,1) = 0D0 + V = 174.1D0 + XMZ=91.18D0 + PI=PARU(1) + RXMT=PYMRUN(6,XMT**2) + CALL PYRGHM(XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB, + &XMU,XMH,HM,XMCH,SA,CA,SAB,CAB,TANBA,XMG,DT,DB) + + SINB = TANB/(TANB**2+1D0)**0.5D0 + COSB = 1D0/(TANB**2+1D0)**0.5D0 + COS2B = SINB**2 - COSB**2 + SINBPA = SINB*CA + COSB*SA + COSBPA = COSB*CA - SINB*SA + RMBOT = PYMRUN(5,XMT**2) + XMQ2 = XMQ**2 + XMUR2 = XMUR**2 + IF(XMUR.LT.0D0) XMUR2=-XMUR2 + XMDR2 = XMDR**2 + XMST11 = RXMT**2 + XMQ2 - 0.35D0*XMZ**2*COS2B + XMST22 = RXMT**2 + XMUR2 - 0.15D0*XMZ**2*COS2B + IF(XMST11.LT.0D0) GOTO 500 + IF(XMST22.LT.0D0) GOTO 500 + XMSB11 = RMBOT**2 + XMQ2 + 0.42D0*XMZ**2*COS2B + XMSB22 = RMBOT**2 + XMDR2 + 0.08D0*XMZ**2*COS2B + IF(XMSB11.LT.0D0) GOTO 500 + IF(XMSB22.LT.0D0) GOTO 500 +C WMST11 = RXMT**2 + XMQ2 +C WMST22 = RXMT**2 + XMUR2 + XMST12 = RXMT*(AT - XMU/TANB) + XMSB12 = RMBOT*(AB - XMU*TANB) + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C...STOP EIGENVALUES CALCULATION +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + + STOP12 = 0.5D0*(XMST11+XMST22) + + &0.5D0*((XMST11+XMST22)**2 - + &4D0*(XMST11*XMST22 - XMST12**2))**0.5D0 + STOP22 = 0.5D0*(XMST11+XMST22) - + &0.5D0*((XMST11+XMST22)**2 - 4D0*(XMST11*XMST22 - + &XMST12**2))**0.5D0 + + IF(STOP22.LT.0D0) GOTO 500 + SSTOP2(1) = STOP12 + SSTOP2(2) = STOP22 + STOP1 = STOP12**0.5D0 + STOP2 = STOP22**0.5D0 +C STOP1W = STOP1 +C STOP2W = STOP2 + + IF(XMST12.EQ.0D0) XST11 = 1D0 + IF(XMST12.EQ.0D0) XST12 = 0D0 + IF(XMST12.EQ.0D0) XST21 = 0D0 + IF(XMST12.EQ.0D0) XST22 = 1D0 + + IF(XMST12.EQ.0D0) GOTO 110 + + 100 XST11 = XMST12/(XMST12**2+(XMST11-STOP12)**2)**0.5D0 + XST12 = - (XMST11-STOP12)/(XMST12**2+(XMST11-STOP12)**2)**0.5D0 + XST21 = XMST12/(XMST12**2+(XMST11-STOP22)**2)**0.5D0 + XST22 = - (XMST11-STOP22)/(XMST12**2+(XMST11-STOP22)**2)**0.5D0 + + 110 T(1,1) = XST11 + T(2,2) = XST22 + T(1,2) = XST12 + T(2,1) = XST21 + + SBOT12 = 0.5D0*(XMSB11+XMSB22) + + &0.5D0*((XMSB11+XMSB22)**2 - + &4D0*(XMSB11*XMSB22 - XMSB12**2))**0.5D0 + SBOT22 = 0.5D0*(XMSB11+XMSB22) - + &0.5D0*((XMSB11+XMSB22)**2 - 4D0*(XMSB11*XMSB22 - + &XMSB12**2))**0.5D0 + IF(SBOT22.LT.0D0) GOTO 500 + SBOT1 = SBOT12**0.5D0 + SBOT2 = SBOT22**0.5D0 + + SSBOT2(1) = SBOT12 + SSBOT2(2) = SBOT22 + + IF(XMSB12.EQ.0D0) XSB11 = 1D0 + IF(XMSB12.EQ.0D0) XSB12 = 0D0 + IF(XMSB12.EQ.0D0) XSB21 = 0D0 + IF(XMSB12.EQ.0D0) XSB22 = 1D0 + + IF(XMSB12.EQ.0D0) GOTO 130 + + 120 XSB11 = XMSB12/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0 + XSB12 = - (XMSB11-SBOT12)/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0 + XSB21 = XMSB12/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0 + XSB22 = - (XMSB11-SBOT22)/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0 + + 130 B(1,1) = XSB11 + B(2,2) = XSB22 + B(1,2) = XSB12 + B(2,1) = XSB21 + + + SINT = 0.2320D0 + SQR = DSQRT(2D0) + VP = 174.1D0*SQR + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C...STARTING OF LIGHT HIGGS +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + + IF(IHIGGS.EQ.0) GOTO 490 + + DO 150 I = 1,2 + DO 140 J = 1,2 + COUPT(I,J) = + & SINT*XMZ**2*2D0*SQR/174.1D0/3D0*SINBPA*(DELTA(I,J) + + & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J)) + & -RXMT**2/174.1D0**2*VP/SINB*CA*DELTA(I,J) + & -RXMT/VP/SINB*(AT*CA + XMU*SA)*(T(1,I)*T(2,J) + + & T(1,J)*T(2,I)) + 140 CONTINUE + 150 CONTINUE + + + DO 170 I = 1,2 + DO 160 J = 1,2 + COUPB(I,J) = + & -SINT*XMZ**2*2D0*SQR/174.1D0/6D0*SINBPA*(DELTA(I,J) + + & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J)) + & +RMBOT**2/174.1D0**2*VP/COSB*SA*DELTA(I,J) + & +RMBOT/VP/COSB*(AB*SA + XMU*CA)*(B(1,I)*B(2,J) + + & B(1,J)*B(2,I)) + 160 CONTINUE + 170 CONTINUE + + PRUN = XMH + EPS = 1D-4*PRUN + ITER = 0 + 180 ITER = ITER + 1 + DO 230 I3 = 1,3 + + PR(I3)=PRUN+(I3-2)*EPS/2 + P2=PR(I3)**2 + POLT = 0D0 + DO 200 I = 1,2 + DO 190 J = 1,2 + POLT = POLT + COUPT(I,J)**2*3D0* + & PYFINT(P2,SSTOP2(I),SSTOP2(J))/16D0/PI**2 + 190 CONTINUE + 200 CONTINUE + + POLB = 0D0 + DO 220 I = 1,2 + DO 210 J = 1,2 + POLB = POLB + COUPB(I,J)**2*3D0* + & PYFINT(P2,SSBOT2(I),SSBOT2(J))/16D0/PI**2 + 210 CONTINUE + 220 CONTINUE +C RXMT2 = RXMT**2 + XMT2=XMT**2 + + POLTT = + & 3D0*RXMT**2/8D0/PI**2/ V **2* + & CA**2/SINB**2 * + & (-2D0*XMT**2+0.5D0*P2)* + & PYFINT(P2,XMT2,XMT2) + + POL = POLT + POLB + POLTT + POLAR(I3) = P2 - XMH**2 - POL + 230 CONTINUE + DERIV = (POLAR(3)-POLAR(1))/EPS + DRUN = - POLAR(2)/DERIV + PRUN = PRUN + DRUN + P2 = PRUN**2 + IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 240 + GOTO 180 + 240 CONTINUE + + XMHP = DSQRT(P2) + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C...END OF LIGHT HIGGS +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + + 250 IF(IHIGGS.EQ.1) GOTO 490 + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C... STARTING OF HEAVY HIGGS +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + + DO 270 I = 1,2 + DO 260 J = 1,2 + HCOUPT(I,J) = + & -SINT*XMZ**2*2D0*SQR/174.1D0/3D0*COSBPA*(DELTA(I,J) + + & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J)) + & -RXMT**2/174.1D0**2*VP/SINB*SA*DELTA(I,J) + & -RXMT/VP/SINB*(AT*SA - XMU*CA)*(T(1,I)*T(2,J) + + & T(1,J)*T(2,I)) + 260 CONTINUE + 270 CONTINUE + + DO 290 I = 1,2 + DO 280 J = 1,2 + HCOUPB(I,J) = + & SINT*XMZ**2*2D0*SQR/174.1D0/6D0*COSBPA*(DELTA(I,J) + + & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J)) + & -RMBOT**2/174.1D0**2*VP/COSB*CA*DELTA(I,J) + & -RMBOT/VP/COSB*(AB*CA - XMU*SA)*(B(1,I)*B(2,J) + + & B(1,J)*B(2,I)) + HCOUPB(I,J)=0D0 + 280 CONTINUE + 290 CONTINUE + + PRUN = HM + EPS = 1D-4*PRUN + ITER = 0 + 300 ITER = ITER + 1 + DO 350 I3 = 1,3 + PR(I3)=PRUN+(I3-2)*EPS/2 + HP2=PR(I3)**2 + + HPOLT = 0D0 + DO 320 I = 1,2 + DO 310 J = 1,2 + HPOLT = HPOLT + HCOUPT(I,J)**2*3D0* + & PYFINT(HP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2 + 310 CONTINUE + 320 CONTINUE + + HPOLB = 0D0 + DO 340 I = 1,2 + DO 330 J = 1,2 + HPOLB = HPOLB + HCOUPB(I,J)**2*3D0* + & PYFINT(HP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2 + 330 CONTINUE + 340 CONTINUE + +C RXMT2 = RXMT**2 + XMT2 = XMT**2 + + HPOLTT = + & 3D0*RXMT**2/8D0/PI**2/ V **2* + & SA**2/SINB**2 * + & (-2D0*XMT**2+0.5D0*HP2)* + & PYFINT(HP2,XMT2,XMT2) + + HPOL = HPOLT + HPOLB + HPOLTT + POLAR(I3) =HP2-HM**2-HPOL + 350 CONTINUE + DERIV = (POLAR(3)-POLAR(1))/EPS + DRUN = - POLAR(2)/DERIV + PRUN = PRUN + DRUN + HP2 = PRUN**2 + IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 360 + GOTO 300 + 360 CONTINUE + + + 370 CONTINUE + HMP = HP2**0.5D0 + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C... END OF HEAVY HIGGS +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + + IF(IHIGGS.EQ.2) GOTO 490 + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C...BEGINNING OF PSEUDOSCALAR HIGGS +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + + DO 390 I = 1,2 + DO 380 J = 1,2 + ACOUPT(I,J) = + & -RXMT/VP/SINB*(AT*COSB + XMU*SINB)* + & (T(1,I)*T(2,J) -T(1,J)*T(2,I)) + 380 CONTINUE + 390 CONTINUE + DO 410 I = 1,2 + DO 400 J = 1,2 + ACOUPB(I,J) = + & RMBOT/VP/COSB*(AB*SINB + XMU*COSB)* + & (B(1,I)*B(2,J) -B(1,J)*B(2,I)) + 400 CONTINUE + 410 CONTINUE + + PRUN = XMA + EPS = 1D-4*PRUN + ITER = 0 + 420 ITER = ITER + 1 + DO 470 I3 = 1,3 + PR(I3)=PRUN+(I3-2)*EPS/2 + AP2=PR(I3)**2 + APOLT = 0D0 + DO 440 I = 1,2 + DO 430 J = 1,2 + APOLT = APOLT + ACOUPT(I,J)**2*3D0* + & PYFINT(AP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2 + 430 CONTINUE + 440 CONTINUE + APOLB = 0D0 + DO 460 I = 1,2 + DO 450 J = 1,2 + APOLB = APOLB + ACOUPB(I,J)**2*3D0* + & PYFINT(AP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2 + 450 CONTINUE + 460 CONTINUE +C RXMT2 = RXMT**2 + XMT2=XMT**2 + APOLTT = + & 3D0*RXMT**2/8D0/PI**2/ V **2* + & COSB**2/SINB**2 * + & (-0.5D0*AP2)* + & PYFINT(AP2,XMT2,XMT2) + APOL = APOLT + APOLB + APOLTT + POLAR(I3) = AP2 - XMA**2 -APOL + 470 CONTINUE + DERIV = (POLAR(3)-POLAR(1))/EPS + DRUN = - POLAR(2)/DERIV + PRUN = PRUN + DRUN + AP2 = PRUN**2 + IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 480 + GOTO 420 + 480 CONTINUE + + AMP = DSQRT(AP2) + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C...END OF PSEUDOSCALAR HIGGS +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + + IF(IHIGGS.EQ.3) GOTO 490 + + 490 CONTINUE + RETURN + 500 CONTINUE + WRITE(MSTU(11),*) ' EXITING IN PYPOLE ' + WRITE(MSTU(11),*) ' XMST11,XMST22 = ',XMST11,XMST22 + WRITE(MSTU(11),*) ' XMSB11,XMSB22 = ',XMSB11,XMSB22 + WRITE(MSTU(11),*) ' STOP22,SBOT22 = ',STOP22,SBOT22 + CALL PYSTOP(107) + END + +C********************************************************************* + +C...PYRGHM +C...Auxiliary to PYPOLE. + + SUBROUTINE PYRGHM(MCHI,MA,TANB,MQ,MUR,MD,MTOP,AU,AD,MU, + * MHP,HMP,MCH,SA,CA,SAB,CAB,TANBA,MGLU,DELTAMT,DELTAMB) + IMPLICIT DOUBLE PRECISION(A-H,L,M,O-Z) + DIMENSION VH(2,2),M2(2,2),M2P(2,2) +C...Parameters. + INTEGER MSTU,MSTJ + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + SAVE /PYDAT1/ + + MZ = 91.18D0 + PI = PARU(1) + V = 174.1D0 + ALPHA1 = 0.0101D0 + ALPHA2 = 0.0337D0 + ALPHA3Z = 0.12D0 + TANBA = TANB + TANBT = TANB +C MBOTTOM(MTOP) = 3. GEV + MB = PYMRUN(5,MTOP**2) + ALPHA3 = ALPHA3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPHA3Z* + *LOG(MTOP**2/MZ**2)) +C RMTOP= RUNNING TOP QUARK MASS + RMTOP = MTOP/(1D0+4D0*ALPHA3/3D0/PI) + TQ = LOG((MQ**2+MTOP**2)/MTOP**2) + TU = LOG((MUR**2 + MTOP**2)/MTOP**2) + TD = LOG((MD**2 + MTOP**2)/MTOP**2) +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C NEW DEFINITION, TGLU. +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + TGLU = LOG(MGLU**2/MTOP**2) + SINB = TANB/DSQRT(1D0 + TANB**2) + COSB = SINB/TANB + IF(MA.GT.MTOP) + *TANBA = TANB*(1D0-3D0/32D0/PI**2* + *(RMTOP**2/V**2/SINB**2-MB**2/V**2/COSB**2)* + *LOG(MA**2/MTOP**2)) + IF(MA.LT.MTOP.OR.MA.EQ.MTOP) TANBT = TANBA + SINB = TANBT/SQRT(1D0 + TANBT**2) + COSB = 1D0/DSQRT(1D0 + TANBT**2) + G1 = SQRT(ALPHA1*4D0*PI) + G2 = SQRT(ALPHA2*4D0*PI) + G3 = SQRT(ALPHA3*4D0*PI) + HU = RMTOP/V/SINB + HD = MB/V/COSB + CALL PYGFXX(MA,TANBA,MQ,MUR,MD,MTOP,AU,AD,MU,MGLU,VH,STOP1,STOP2, + *SBOT1,SBOT2,DELTAMT,DELTAMB) + IF(MQ.GT.MUR) TP = TQ - TU + IF(MQ.LT.MUR.OR.MQ.EQ.MUR) TP = TU - TQ + IF(MQ.GT.MUR) TDP = TU + IF(MQ.LT.MUR.OR.MQ.EQ.MUR) TDP = TQ + IF(MQ.GT.MD) TPD = TQ - TD + IF(MQ.LT.MD.OR.MQ.EQ.MD) TPD = TD - TQ + IF(MQ.GT.MD) TDPD = TD + IF(MQ.LT.MD.OR.MQ.EQ.MD) TDPD = TQ + + IF(MQ.GT.MD) DLAMBDA1 = 6D0/96D0/PI**2*G1**2*HD**2*TPD + IF(MQ.LT.MD.OR.MQ.EQ.MD) DLAMBDA1 = 3D0/32D0/PI**2* + * HD**2*(G1**2/3D0+G2**2)*TPD + + IF(MQ.GT.MUR) DLAMBDA2 =12D0/96D0/PI**2*G1**2*HU**2*TP + IF(MQ.LT.MUR.OR.MQ.EQ.MUR) DLAMBDA2 = 3D0/32D0/PI**2* + * HU**2*(-G1**2/3D0+G2**2)*TP + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C DLAMBDAP1 AND DLAMBDAP2 ARE THE NEW LOG CORRECTIONS DUE TO +C THE PRESENCE OF THE GLUINO MASS. THEY ARE IN GENERAL VERY SMALL, +C AND ONLY PRESENT IF THERE IS A HIERARCHY OF MASSES BETWEEN THE +C TWO STOPS. +C +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + + DLAMBDAP2 = 0D0 + IF(MGLU.LT.MUR.OR.MGLU.LT.MQ) THEN + IF(MQ.GT.MUR.AND.MGLU.GT.MUR) THEN + DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TGLU**2) + ENDIF + + IF(MQ.GT.MUR.AND.MGLU.LT.MUR) THEN + DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TU**2) + ENDIF + + IF(MQ.GT.MUR.AND.MGLU.EQ.MUR) THEN + DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TU**2) + ENDIF + + IF(MUR.GT.MQ.AND.MGLU.GT.MQ) THEN + DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TGLU**2) + ENDIF + + IF(MUR.GT.MQ.AND.MGLU.LT.MQ) THEN + DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TQ**2) + ENDIF + + IF(MUR.GT.MQ.AND.MGLU.EQ.MQ) THEN + DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TQ**2) + ENDIF + ENDIF + DLAMBDA3 = 0D0 + DLAMBDA4 = 0D0 + IF(MQ.GT.MD) DLAMBDA3 = -1D0/32D0/PI**2*G1**2*HD**2*TPD + IF(MQ.LT.MD.OR.MQ.EQ.MD) DLAMBDA3 = 3D0/64D0/PI**2*HD**2* + *(G2**2-G1**2/3D0)*TPD + IF(MQ.GT.MUR) DLAMBDA3 = DLAMBDA3 - + *1D0/16D0/PI**2*G1**2*HU**2*TP + IF(MQ.LT.MUR.OR.MQ.EQ.MUR) DLAMBDA3 = DLAMBDA3 + + * 3D0/64D0/PI**2*HU**2*(G2**2+G1**2/3D0)*TP + IF(MQ.LT.MUR) DLAMBDA4 = -3D0/32D0/PI**2*G2**2*HU**2*TP + IF(MQ.LT.MD) DLAMBDA4 = DLAMBDA4 - 3D0/32D0/PI**2*G2**2* + *HD**2*TPD + LAMBDA1 = ((G1**2 + G2**2)/4D0)* + * (1D0-3D0*HD**2*(TPD + TDPD)/8D0/PI**2) + *+(3D0*HD**4D0/16D0/PI**2) *TPD*(1D0 + *+ (3D0*HD**2/2D0 + HU**2/2D0 + *- 8D0*G3**2) * (TPD + 2D0*TDPD)/16D0/PI**2) + *+(3D0*HD**4D0/8D0/PI**2) *TDPD*(1D0 + (3D0*HD**2/2D0 + HU**2/2D0 + *- 8D0*G3**2) * TDPD/16D0/PI**2) + DLAMBDA1 + LAMBDA2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU**2* + *(TP + TDP)/8D0/PI**2) + *+(3D0*HU**4D0/16D0/PI**2) *TP*(1D0 + *+ (3D0*HU**2/2D0 + HD**2/2D0 + *- 8D0*G3**2) * (TP + 2D0*TDP)/16D0/PI**2) + *+(3D0*HU**4D0/8D0/PI**2) *TDP*(1D0 + (3D0*HU**2/2D0 + HD**2/2D0 + *- 8D0*G3**2) * TDP/16D0/PI**2) + DLAMBDA2 + DLAMBDAP2 + LAMBDA3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0* + *(HU**2)*(TP + TDP)/16D0/PI**2 -3D0* + *(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAMBDA3 + LAMBDA4 = (- G2**2/2D0)*(1D0 + *-3D0*(HU**2)*(TP + TDP)/16D0/PI**2 + *-3D0*(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAMBDA4 + + LAMBDA5 = 0D0 + LAMBDA6 = 0D0 + LAMBDA7 = 0D0 + + M2(1,1) = 2D0*V**2*(LAMBDA1*COSB**2+2D0*LAMBDA6* + *COSB*SINB + LAMBDA5*SINB**2) + MA**2*SINB**2 + + M2(2,2) = 2D0*V**2*(LAMBDA5*COSB**2+2D0*LAMBDA7* + *COSB*SINB + LAMBDA2*SINB**2) + MA**2*COSB**2 + M2(1,2) = 2D0*V**2*(LAMBDA6*COSB**2+(LAMBDA3+LAMBDA4)* + *COSB*SINB + LAMBDA7*SINB**2) - MA**2*SINB*COSB + + M2(2,1) = M2(1,2) +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +CCC THIS IS THE CONTRIBUTION FROM LIGHT CHARGINOS/NEUTRALINOS +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + + MSSUSY=DSQRT(.5D0*(MQ**2+MUR**2)+MTOP**2) + + IF(MCHI.GT.MSSUSY) GOTO 100 + IF(MCHI.LT.MTOP) MCHI=MTOP + + TCHAR=LOG(MSSUSY**2/MCHI**2) + + DELTAL12=(9D0/64D0/PI**2*G2**4+5D0/192D0/PI**2*G1**4)*TCHAR + DELTAL3P4=(3D0/64D0/PI**2*G2**4+7D0/192D0/PI**2*G1**4 + *+4D0/32D0/PI**2*G1**2*G2**2)*TCHAR + + DELTAM112=2D0*DELTAL12*V**2*COSB**2 + DELTAM222=2D0*DELTAL12*V**2*SINB**2 + DELTAM122=2D0*DELTAL3P4*V**2*SINB*COSB + + M2(1,1)=M2(1,1)+DELTAM112 + M2(2,2)=M2(2,2)+DELTAM222 + M2(1,2)=M2(1,2)+DELTAM122 + M2(2,1)=M2(2,1)+DELTAM122 + + 100 CONTINUE + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +CCC END OF CHARGINOS/NEUTRALINOS +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + + DO 120 I = 1,2 + DO 110 J = 1,2 + M2P(I,J) = M2(I,J) + VH(I,J) + 110 CONTINUE + 120 CONTINUE + TRM2P = M2P(1,1) + M2P(2,2) + DETM2P = M2P(1,1)*M2P(2,2) - M2P(1,2)*M2P(2,1) + MH2P = (TRM2P - DSQRT(TRM2P**2 - 4D0* DETM2P))/2D0 + HM2P = (TRM2P + DSQRT(TRM2P**2 - 4D0* DETM2P))/2D0 + HMP = DSQRT(HM2P) + MCH2=MA**2+(LAMBDA5-LAMBDA4)*V**2 + MCH=DSQRT(MCH2) + IF(MH2P.LT.0.) GOTO 130 + MHP = SQRT(MH2P) + SIN2ALPHA = 2D0*M2P(1,2)/SQRT(TRM2P**2-4D0*DETM2P) + COS2ALPHA = (M2P(1,1)-M2P(2,2))/SQRT(TRM2P**2-4D0*DETM2P) + IF(COS2ALPHA.GE.0.) THEN + ALPHA = ASIN(SIN2ALPHA)/2D0 + ELSE + ALPHA = -PI/2D0-ASIN(SIN2ALPHA)/2D0 + ENDIF + SA = SIN(ALPHA) + CA = COS(ALPHA) +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C HERE THE VALUES OF SAB AND CAB ARE DEFINED, IN ORDER +C TO DEFINE THE NEW COUPLINGS OF THE LIGHTEST AND +C HEAVY CP-EVEN HIGGS TO THE BOTTOM QUARK. +C +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + SAB = SA*(1D0-DELTAMB/(1D0+DELTAMB)*(1D0+CA/SA/TANB)) + CAB = CA*(1D0-DELTAMB/(1D0+DELTAMB)*(1D0-SA/CA/TANB)) + 130 CONTINUE + RETURN + END + +C********************************************************************* + +C...PYGFXX +C...Auxiliary to PYRGHM. + + SUBROUTINE PYGFXX(MA,TANB,MQ,MUR,MD,MTOP,AT,AB,XMU,XMGL,VH, + * STOP1,STOP2,SBOT1,SBOT2,DELTAMT,DELTAMB) + IMPLICIT DOUBLE PRECISION(A-H,M,O-Z) + DIMENSION VH(2,2),VH3T(2,2),VH3B(2,2),AL(2,2) +C...Commonblocks. + INTEGER MSTU,MSTJ,KCHG + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /PYDAT1/,/PYDAT2/ + + G(X,Y) = 2.D0 - (X+Y)/(X-Y)*DLOG(X/Y) + + T(X,Y,Z) = (X**2*Y**2*LOG(X**2/Y**2) + X**2*Z**2*LOG(Z**2/X**2) + * + Y**2*Z**2*LOG(Y**2/Z**2))/((X**2-Y**2)*(Y**2-Z**2)*(X**2-Z**2)) + + IF(DABS(XMU).LT.0.000001D0) XMU = 0.000001D0 + MQ2 = MQ**2 + MUR2 = MUR**2 + MD2 = MD**2 + TANBA = TANB + SINBA = TANBA/DSQRT(TANBA**2+1D0) + COSBA = SINBA/TANBA + + SINB = TANB/DSQRT(TANB**2+1D0) + COSB = SINB/TANB + + PI = PARU(1) + MZ = PMAS(23,1) + MW = PMAS(24,1) + SW = 1D0-MW**2/MZ**2 + V = 174.1D0 + + ALPHA3 = 0.12D0/(1D0+23/12D0/PI*0.12D0*LOG(MTOP**2/MZ**2)) + G2 = DSQRT(0.0336D0*4D0*PI) + G1 = DSQRT(0.0101D0*4D0*PI) + + IF(MQ.GT.MUR) MST = MQ + IF(MUR.GT.MQ.OR.MUR.EQ.MQ) MST = MUR + + MSUSYT = DSQRT(MST**2 + MTOP**2) + + IF(MQ.GT.MD) MSB = MQ + IF(MD.GT.MQ.OR.MD.EQ.MQ) MSB = MD + + MB = PYMRUN(5,MSB**2) + MSUSYB = DSQRT(MSB**2 + MB**2) + TT = LOG(MSUSYT**2/MTOP**2) + TB = LOG(MSUSYB**2/MTOP**2) + + RMTOP = MTOP/(1D0+4D0*ALPHA3/3D0/PI) + HT = RMTOP/(V*SINB) + HTST = RMTOP/V + HB = MB/V/COSB + G32 = ALPHA3*4D0*PI + BT2 = -(8D0*G32 - 9D0*HT**2/2D0 - HB**2/2D0)/(4D0*PI)**2 + BB2 = -(8D0*G32 - 9D0*HB**2/2D0 - HT**2/2D0)/(4D0*PI)**2 + AL2 = 3D0/8D0/PI**2*HT**2 +C BT2ST = -(8.*G32 - 9.*HTST**2/2.)/(4.*PI)**2 +C ALST = 3./8./PI**2*HTST**2 + AL1 = 3D0/8D0/PI**2*HB**2 + + AL(1,1) = AL1 + AL(1,2) = (AL2+AL1)/2D0 + AL(2,1) = (AL2+AL1)/2D0 + AL(2,2) = AL2 + + IF(MA.GT.MTOP) THEN + VI = V*(1D0 + 3D0/32D0/PI**2*HTST**2* + * LOG(MTOP**2/MA**2)) + H1I = VI* COSBA + H2I = VI*SINBA + H1T = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MA**2/MSUSYT**2))**.25D0 + H2T = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MA**2/MSUSYT**2))**.25D0 + H1B = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MA**2/MSUSYB**2))**.25D0 + H2B = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MA**2/MSUSYB**2))**.25D0 + ELSE + VI = V + H1I = VI*COSB + H2I = VI*SINB + H1T=H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MTOP**2/MSUSYT**2))**.25D0 + H2T=H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MTOP**2/MSUSYT**2))**.25D0 + H1B=H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MTOP**2/MSUSYB**2))**.25D0 + H2B=H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MTOP**2/MSUSYB**2))**.25D0 + ENDIF + + TANBST = H2T/H1T + SINBT = TANBST/DSQRT(1D0+TANBST**2) + + TANBSB = H2B/H1B + SINBB = TANBSB/DSQRT(1D0+TANBSB**2) + COSBB = SINBB/TANBSB + + DELTAMT = 0D0 + DELTAMB = 0D0 + + MTOP4 = RMTOP**4*(1D0+2D0*BT2*TT- AL2*TT - 4D0*DELTAMT) + MTOP2 = DSQRT(MTOP4) + MBOT4 = MB**4*(1D0+2D0*BB2*TB - AL1*TB) + * /(1D0+DELTAMB)**4 + MBOT2 = DSQRT(MBOT4) + + STOP12 = (MQ2 + MUR2)*.5D0 + MTOP2 + * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2) + * +SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) + + * MQ2 - MUR2)**2*0.25D0 + MTOP2*(AT-XMU/TANBST)**2) + STOP22 = (MQ2 + MUR2)*.5D0 + MTOP2 + * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2) + * - SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) + + * MQ2 - MUR2)**2*0.25D0 + * + MTOP2*(AT-XMU/TANBST)**2) + IF(STOP22.LT.0.) GOTO 120 + SBOT12 = (MQ2 + MD2)*.5D0 + * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2) + * + SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) + + * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2) + SBOT22 = (MQ2 + MD2)*.5D0 + * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2) + * - SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) + + * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2) + IF(SBOT22.LT.0.) SBOT22 = 10000D0 + + STOP1 = DSQRT(STOP12) + STOP2 = DSQRT(STOP22) + SBOT1 = DSQRT(SBOT12) + SBOT2 = DSQRT(SBOT22) + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C HERE IS THE DEFINITION OF DELTAMB AND DELTAMT, WHICH +C ARE THE VERTEX CORRECTIONS TO THE BOTTOM AND TOP QUARK +C MASS, KEEPING THE DOMINANT QCD AND TOP YUKAWA COUPLING +C INDUCED CORRECTIONS. +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + + X=SBOT1 + Y=SBOT2 + Z=XMGL + IF(X.EQ.Y) X = X - 0.00001D0 + IF(X.EQ.Z) X = X - 0.00002D0 + IF(Y.EQ.Z) Y = Y - 0.00003D0 + + T1=T(X,Y,Z) + X=STOP1 + Y=STOP2 + Z=XMU + IF(X.EQ.Y) X = X - 0.00001D0 + IF(X.EQ.Z) X = X - 0.00002D0 + IF(Y.EQ.Z) Y = Y - 0.00003D0 + T2=T(X,Y,Z) + DELTAMB = -2*ALPHA3/3D0/PI*XMGL*(AB-XMU*TANB)*T1 + * + HT**2/(4D0*PI)**2*(AT-XMU/TANB)*XMU*TANB*T2 + X=STOP1 + Y=STOP2 + Z=XMGL + IF(X.EQ.Y) X = X - 0.00001D0 + IF(X.EQ.Z) X = X - 0.00002D0 + IF(Y.EQ.Z) Y = Y - 0.00003D0 + T3=T(X,Y,Z) + DELTAMT = -2D0*ALPHA3/3D0/PI*(AT-XMU/TANB)*XMGL*T3 + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C HERE THE NEW VALUES OF THE TOP AND BOTTOM QUARK MASSES AT +C THE SCALE MS ARE DEFINED, TO BE USED IN THE EFFECTIVE +C POTENTIAL APPROXIMATION. THEY ARE JUST THE OLD ONES, BUT +C INCLUDING THE FINITE CORRECTIONS DELTAMT AND DELTAMB. +C THE DELTAMB CORRECTIONS CAN BECOME LARGE AND ARE RESUMMED +C TO ALL ORDERS, AS SUGGESTED IN THE TWO RECENT WORKS BY M. CARENA, +C S. MRENNA AND C.E.M. WAGNER, AS WELL AS IN THE WORK BY M. CARENA, +C D. GARCIA, U. NIERSTE AND C.E.M. WAGNER, TO APPEAR. THE TOP +C QUARK MASS CORRECTIONS ARE SMALL AND ARE KEPT IN THE PERTURBATIVE +C FORMULATION. THE FUNCTION T(X,Y,Z) IS NECESSARY FOR THE +C CALCULATION. THE ENTRIES ARE MASSES AND NOT THEIR SQUARES ! +C +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + + MTOP4 = RMTOP**4*(1D0+2D0*BT2*TT- AL2*TT - 4D0*DELTAMT) + MTOP2 = DSQRT(MTOP4) + MBOT4 = MB**4*(1D0+2D0*BB2*TB - AL1*TB) + * /(1D0+DELTAMB)**4 + MBOT2 = DSQRT(MBOT4) + + STOP12 = (MQ2 + MUR2)*.5D0 + MTOP2 + * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2) + * +SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) + + * MQ2 - MUR2)**2*0.25D0 + MTOP2*(AT-XMU/TANBST)**2) + STOP22 = (MQ2 + MUR2)*.5D0 + MTOP2 + * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2) + * - SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) + + * MQ2 - MUR2)**2*0.25D0 + * + MTOP2*(AT-XMU/TANBST)**2) + + IF(STOP22.LT.0.) GOTO 120 + SBOT12 = (MQ2 + MD2)*.5D0 + * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2) + * + SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) + + * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2) + SBOT22 = (MQ2 + MD2)*.5D0 + * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2) + * - SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) + + * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2) + IF(SBOT22.LT.0.) GOTO 120 + + + STOP1 = DSQRT(STOP12) + STOP2 = DSQRT(STOP22) + SBOT1 = DSQRT(SBOT12) + SBOT2 = DSQRT(SBOT22) + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +CCC D-TERMS +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + STW=SW + + F1T=(MQ2-MUR2)/(STOP12-STOP22)*(.5D0-4D0/3D0*STW)* + * LOG(STOP1/STOP2) + * +(.5D0-2D0/3D0*STW)*LOG(STOP1*STOP2/(MQ2+MTOP2)) + * + 2D0/3D0*STW*LOG(STOP1*STOP2/(MUR2+MTOP2)) + + F1B=(MQ2-MD2)/(SBOT12-SBOT22)*(-.5D0+2D0/3D0*STW)* + * LOG(SBOT1/SBOT2) + * +(-.5D0+1D0/3D0*STW)*LOG(SBOT1*SBOT2/(MQ2+MBOT2)) + * - 1D0/3D0*STW*LOG(SBOT1*SBOT2/(MD2+MBOT2)) + + F2T=DSQRT(MTOP2)*(AT-XMU/TANBST)/(STOP12-STOP22)* + * (-.5D0*LOG(STOP12/STOP22) + * +(4D0/3D0*STW-.5D0)*(MQ2-MUR2)/(STOP12-STOP22)* + * G(STOP12,STOP22)) + + F2B=DSQRT(MBOT2)*(AB-XMU*TANBSB)/(SBOT12-SBOT22)* + * (.5D0*LOG(SBOT12/SBOT22) + * +(-2D0/3D0*STW+.5D0)*(MQ2-MD2)/(SBOT12-SBOT22)* + * G(SBOT12,SBOT22)) + + VH3B(1,1) = MBOT4/(COSBB**2)*(LOG(SBOT1**2*SBOT2**2/ + * (MQ2+MBOT2)/(MD2+MBOT2)) + * + 2D0*(AB*(AB-XMU*TANBSB)/(SBOT1**2-SBOT2**2))* + * LOG(SBOT1**2/SBOT2**2)) + + * MBOT4/(COSBB**2)*(AB*(AB-XMU*TANBSB)/ + * (SBOT1**2-SBOT2**2))**2*G(SBOT12,SBOT22) + + VH3T(1,1) = + * MTOP4/(SINBT**2)*(XMU*(-AT+XMU/TANBST)/(STOP1**2 + * -STOP2**2))**2*G(STOP12,STOP22) + + VH3B(1,1)=VH3B(1,1)+ + * MZ**2*(2*MBOT2*F1B-DSQRT(MBOT2)*AB*F2B) + + VH3T(1,1) = VH3T(1,1) + + * MZ**2*(DSQRT(MTOP2)*XMU/TANBST*F2T) + + VH3T(2,2) = MTOP4/(SINBT**2)*(LOG(STOP1**2*STOP2**2/ + * (MQ2+MTOP2)/(MUR2+MTOP2)) + * + 2D0*(AT*(AT-XMU/TANBST)/(STOP1**2-STOP2**2))* + * LOG(STOP1**2/STOP2**2)) + + * MTOP4/(SINBT**2)*(AT*(AT-XMU/TANBST)/ + * (STOP1**2-STOP2**2))**2*G(STOP12,STOP22) + + VH3B(2,2) = + * MBOT4/(COSBB**2)*(XMU*(-AB+XMU*TANBSB)/(SBOT1**2 + * -SBOT2**2))**2*G(SBOT12,SBOT22) + + VH3T(2,2)=VH3T(2,2)+ + * MZ**2*(-2*MTOP2*F1T+DSQRT(MTOP2)*AT*F2T) + VH3B(2,2) = VH3B(2,2) -MZ**2*DSQRT(MBOT2)*XMU*TANBSB*F2B + VH3T(1,2) = - + * MTOP4/(SINBT**2)*XMU*(AT-XMU/TANBST)/ + * (STOP1**2-STOP2**2)*(LOG(STOP1**2/STOP2**2) + AT* + * (AT - XMU/TANBST)/(STOP1**2-STOP2**2)*G(STOP12,STOP22)) + + VH3B(1,2) = + * - MBOT4/(COSBB**2)*XMU*(AB-XMU*TANBSB)/ + * (SBOT1**2-SBOT2**2)*(LOG(SBOT1**2/SBOT2**2) + AB* + * (AB - XMU*TANBSB)/(SBOT1**2-SBOT2**2)*G(SBOT12,SBOT22)) + + + VH3T(1,2)=VH3T(1,2) + + *MZ**2*(MTOP2/TANBST*F1T-DSQRT(MTOP2)*(AT/TANBST+XMU)/2D0*F2T) + + VH3B(1,2)=VH3B(1,2) + + *MZ**2*(-MBOT2*TANBSB*F1B+DSQRT(MBOT2)*(AB*TANBSB+XMU)/2D0*F2B) + + VH3T(2,1) = VH3T(1,2) + VH3B(2,1) = VH3B(1,2) + +C TQ = LOG((MQ2 + MTOP2)/MTOP2) +C TU = LOG((MUR2+MTOP2)/MTOP2) +C TQD = LOG((MQ2 + MB**2)/MB**2) +C TD = LOG((MD2+MB**2)/MB**2) + + DO 110 I = 1,2 + DO 100 J = 1,2 + VH(I,J) = + * 6D0/(8D0*PI**2*(H1T**2+H2T**2)) + * *VH3T(I,J)*0.5D0*(1D0-AL(I,J)*TT/2D0) + + * 6D0/(8D0*PI**2*(H1B**2+H2B**2)) + * *VH3B(I,J)*0.5D0*(1D0-AL(I,J)*TB/2D0) + 100 CONTINUE + 110 CONTINUE + + GOTO 150 + 120 DO 140 I =1,2 + DO 130 J = 1,2 + VH(I,J) = -1D15 + 130 CONTINUE + 140 CONTINUE + + + 150 RETURN + END + + + + + +C********************************************************************* + +C...PYFINT +C...Auxiliary routine to PYPOLE for SUSY Higgs calculations. + + FUNCTION PYFINT(A,B,C) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblock. + COMMON/PYINTS/XXM(20) + SAVE/PYINTS/ + +C...Local variables. + EXTERNAL PYFISB + DOUBLE PRECISION PYFISB + + XXM(1)=A + XXM(2)=B + XXM(3)=C + XLO=0D0 + XHI=1D0 + PYFINT = PYGAUS(PYFISB,XLO,XHI,1D-3) + + RETURN + END + +C********************************************************************* + +C...PYFISB +C...Auxiliary routine to PYFINT for SUSY Higgs calculations. + + FUNCTION PYFISB(X) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblock. + COMMON/PYINTS/XXM(20) + SAVE/PYINTS/ + + PYFISB = LOG(ABS(X*XXM(2)+(1-X)*XXM(3)-X*(1-X)*XXM(1))/ + &(X*(XXM(2)-XXM(3))+XXM(3))) + + RETURN + END + +C********************************************************************* + +C...PYSFDC +C...Calculates decays of sfermions. + + SUBROUTINE PYSFDC(KFIN,XLAM,IDLAM,IKNT) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) + COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), + &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) + SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/ + +C...Local variables. + COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2) + COMPLEX*16 CAL,CAR,CBL,CBR,CALP,CARP,CBLP,CBRP,CA,CB + INTEGER KFIN,KCIN + DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,XMZ,AXMJ + DOUBLE PRECISION XMI2,XMI3,XMA2,XMB2,XMFP + DOUBLE PRECISION PYLAMF,XL + DOUBLE PRECISION TANW,XW,AEM,C1,AS + DOUBLE PRECISION AL,AR,BL,BR + DOUBLE PRECISION CH1,CH2,CH3,CH4 + DOUBLE PRECISION XMBOT,XMTOP + DOUBLE PRECISION XLAM(0:400) + INTEGER IDLAM(400,3) + INTEGER LKNT,IX,ILR,IDU,J,I,IKNT,IFL,II + DOUBLE PRECISION SR2 + DOUBLE PRECISION CBETA,SBETA + DOUBLE PRECISION CW + DOUBLE PRECISION BETA,ALFA,XMU,AT,AB,ATRIT,ATRIB,ATRIL + DOUBLE PRECISION COSA,SINA,TANB + DOUBLE PRECISION PYALEM,PI,PYALPS,EI + DOUBLE PRECISION GHRR,GHLL,GHLR,XMB,BLR + INTEGER IG,KF1,KF2 + INTEGER IGG(4),KFNCHI(4),KFCCHI(2) + DATA IGG/23,25,35,36/ + DATA PI/3.141592654D0/ + DATA SR2/1.4142136D0/ + DATA KFNCHI/1000022,1000023,1000025,1000035/ + DATA KFCCHI/1000024,1000037/ + +C...COUNT THE NUMBER OF DECAY MODES + LKNT=0 + +C...NO NU_R DECAYS + IF(KFIN.EQ.KSUSY2+12.OR.KFIN.EQ.KSUSY2+14.OR. + &KFIN.EQ.KSUSY2+16) RETURN + + XMW=PMAS(24,1) + XMW2=XMW**2 + XMZ=PMAS(23,1) + XW=PARU(102) + TANW = SQRT(XW/(1D0-XW)) + CW=SQRT(1D0-XW) + + DO 110 I=1,4 + DO 100 J=1,4 + ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I)) + 100 CONTINUE + 110 CONTINUE + DO 130 I=1,2 + DO 120 J=1,2 + VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I)) + UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I)) + 120 CONTINUE + 130 CONTINUE + +C...KCIN + KCIN=PYCOMP(KFIN) +C...ILR is 1 for left and 2 for right. + ILR=KFIN/KSUSY1 +C...IFL is matching non-SUSY flavour. + IFL=MOD(KFIN,KSUSY1) +C...IDU is weak isospin, 1 for down and 2 for up. + IDU=2-MOD(IFL,2) + + XMI=PMAS(KCIN,1) + XMI2=XMI**2 + AEM=PYALEM(XMI2) + AS =PYALPS(XMI2) + C1=AEM/XW + XMI3=XMI**3 + EI=KCHG(IFL,1)/3D0 + + XMBOT=PYMRUN(5,XMI2) + XMTOP=PYMRUN(6,XMI2) + + TANB=RMSS(5) + BETA=ATAN(TANB) + ALFA=RMSS(18) + CBETA=COS(BETA) + SBETA=TANB*CBETA + SINA=SIN(ALFA) + COSA=COS(ALFA) + XMU=-RMSS(4) + ATRIT=RMSS(16) + ATRIB=RMSS(15) + ATRIL=RMSS(17) + +C...2-BODY DECAYS OF SFERMION -> GRAVITINO + FERMION + + IF(IMSS(11).EQ.1) THEN + XMP=RMSS(29) + IDG=39+KSUSY1 + XMGR=PMAS(PYCOMP(IDG),1) + XFAC=(XMI2/(XMP*XMGR))**2*XMI/48D0/PI + IF(IFL.EQ.5) THEN + XMF=XMBOT + ELSEIF(IFL.EQ.6) THEN + XMF=XMTOP + ELSE + XMF=PMAS(IFL,1) + ENDIF + IF(XMI.GT.XMGR+XMF) THEN + LKNT=LKNT+1 + IDLAM(LKNT,1)=IDG + IDLAM(LKNT,2)=IFL + IDLAM(LKNT,3)=0 + XLAM(LKNT)=XFAC*(1D0-XMF**2/XMI2)**4 + ENDIF + ENDIF + +C...2-BODY DECAYS OF SFERMION -> FERMION + GAUGE/GAUGINO + +C...CHARGED DECAYS: + DO 140 IX=1,2 +C...DI -> U CHI1-,CHI2- + IF(IDU.EQ.1) THEN + XMFP=PMAS(IFL+1,1) + XMF =PMAS(IFL,1) +C...UI -> D CHI1+,CHI2+ + ELSE + XMFP=PMAS(IFL-1,1) + XMF =PMAS(IFL,1) + ENDIF + XMJ=SMW(IX) + AXMJ=ABS(XMJ) + IF(XMI.GE.AXMJ+XMFP) THEN + XMA2=XMJ**2 + XMB2=XMFP**2 + IF(IDU.EQ.2) THEN + IF(IFL.EQ.6) THEN + XMFP=XMBOT + XMF =XMTOP + ELSEIF(IFL.LT.6) THEN + XMF=0D0 + XMFP=0D0 + ENDIF + CBL=VMIXC(IX,1) + CAL=-XMFP*UMIXC(IX,2)/SR2/XMW/CBETA + CBR=-XMF*VMIXC(IX,2)/SR2/XMW/SBETA + CAR=0D0 + ELSE + IF(IFL.EQ.5) THEN + XMF =XMBOT + XMFP=XMTOP + ELSEIF(IFL.LT.5) THEN + XMF=0D0 + XMFP=0D0 + ENDIF + CBL=UMIXC(IX,1) + CAL=-XMFP*VMIXC(IX,2)/SR2/XMW/SBETA + CBR=-XMF*UMIXC(IX,2)/SR2/XMW/CBETA + CAR=0D0 + ENDIF + + CALP=SFMIX(IFL,1)*CAL + SFMIX(IFL,2)*CAR + CBLP=SFMIX(IFL,1)*CBL + SFMIX(IFL,2)*CBR + CARP=SFMIX(IFL,4)*CAR + SFMIX(IFL,3)*CAL + CBRP=SFMIX(IFL,4)*CBR + SFMIX(IFL,3)*CBL + CAL=CALP + CBL=CBLP + CAR=CARP + CBR=CBRP + +C...F1 -> F` CHI + IF(ILR.EQ.1) THEN + CA=CAL + CB=CBL +C...F2 -> F` CHI + ELSE + CA=CAR + CB=CBR + ENDIF + LKNT=LKNT+1 + XL=PYLAMF(XMI2,XMA2,XMB2) +C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT + XLAM(LKNT)=2D0*C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)* + & (ABS(CA)**2+ABS(CB)**2)-4D0*DBLE(CA*DCONJG(CB))*XMJ*XMFP) + IDLAM(LKNT,3)=0 + IF(IDU.EQ.1) THEN + IDLAM(LKNT,1)=-KFCCHI(IX) + IDLAM(LKNT,2)=IFL+1 + ELSE + IDLAM(LKNT,1)=KFCCHI(IX) + IDLAM(LKNT,2)=IFL-1 + ENDIF + ENDIF + 140 CONTINUE + +C...NEUTRAL DECAYS + DO 150 IX=1,4 +C...DI -> D CHI10 + XMF=PMAS(IFL,1) + XMJ=SMZ(IX) + AXMJ=ABS(XMJ) + IF(XMI.GE.AXMJ+XMF) THEN + XMA2=XMJ**2 + XMB2=XMF**2 + IF(IDU.EQ.1) THEN + IF(IFL.EQ.5) THEN + XMF=XMBOT + ELSEIF(IFL.LT.5) THEN + XMF=0D0 + ENDIF + CBL=-ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI+1) + CAL=XMF*ZMIXC(IX,3)/XMW/CBETA + CAR=-2D0*EI*TANW*ZMIXC(IX,1) + CBR=CAL + ELSE + IF(IFL.EQ.6) THEN + XMF=XMTOP + ELSEIF(IFL.LT.5) THEN + XMF=0D0 + ENDIF + CBL=ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-1) + CAL=XMF*ZMIXC(IX,4)/XMW/SBETA + CAR=-2D0*EI*TANW*ZMIXC(IX,1) + CBR=CAL + ENDIF + + CALP=SFMIX(IFL,1)*CAL + SFMIX(IFL,2)*CAR + CBLP=SFMIX(IFL,1)*CBL + SFMIX(IFL,2)*CBR + CARP=SFMIX(IFL,4)*CAR + SFMIX(IFL,3)*CAL + CBRP=SFMIX(IFL,4)*CBR + SFMIX(IFL,3)*CBL + CAL=CALP + CBL=CBLP + CAR=CARP + CBR=CBRP + +C...F1 -> F CHI + IF(ILR.EQ.1) THEN + CA=CAL + CB=CBL +C...F2 -> F CHI + ELSE + CA=CAR + CB=CBR + ENDIF + LKNT=LKNT+1 + XL=PYLAMF(XMI2,XMA2,XMB2) +C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT + XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)* + & (ABS(CA)**2+ABS(CB)**2)-4D0*DBLE(CA*DCONJG(CB))*XMJ*XMF) + IDLAM(LKNT,1)=KFNCHI(IX) + IDLAM(LKNT,2)=IFL + IDLAM(LKNT,3)=0 + ENDIF + 150 CONTINUE + +C...2-BODY DECAYS TO SM GAUGE AND HIGGS BOSONS +C...IG=23,25,35,36 + DO 160 II=1,4 + IG=IGG(II) + IF(ILR.EQ.1) GOTO 160 + XMB=PMAS(IG,1) + XMSF1=PMAS(PYCOMP(KFIN-KSUSY1),1) + IF(XMI.LT.XMSF1+XMB) GOTO 160 + IF(IG.EQ.23) THEN + BL=-SIGN(.5D0,EI)/CW+EI*XW/CW + BR=EI*XW/CW + BLR=0D0 + ELSEIF(IG.EQ.25) THEN + IF(IFL.EQ.5) THEN + XMF=XMBOT + ELSEIF(IFL.EQ.6) THEN + XMF=XMTOP + ELSEIF(IFL.LT.5) THEN + XMF=0D0 + ELSE + XMF=PMAS(IFL,1) + ENDIF + IF(IDU.EQ.2) THEN + GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+ + & XMF**2/XMW*COSA/SBETA + GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+ + & XMF**2/XMW*COSA/SBETA + ELSE + GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+ + & XMF**2/XMW*(-SINA)/CBETA + GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+ + & XMF**2/XMW*(-SINA)/CBETA + ENDIF + IF(IFL.EQ.5) THEN + AT=ATRIB + ELSEIF(IFL.EQ.6) THEN + AT=ATRIT + ELSEIF(IFL.EQ.15) THEN + AT=ATRIL + ELSE + AT=0D0 + ENDIF +C.........need to complexify + IF(IDU.EQ.2) THEN + GHLR=XMF/2D0/XMW/SBETA*(-XMU*SINA+ + & AT*COSA) + ELSE + GHLR=XMF/2D0/XMW/CBETA*(XMU*COSA- + & AT*SINA) + ENDIF + BL=GHLL + BR=GHRR + BLR=-GHLR + ELSEIF(IG.EQ.35) THEN + IF(IFL.EQ.5) THEN + XMF=XMBOT + ELSEIF(IFL.EQ.6) THEN + XMF=XMTOP + ELSEIF(IFL.LT.5) THEN + XMF=0D0 + ELSE + XMF=PMAS(IFL,1) + ENDIF + IF(IDU.EQ.2) THEN + GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+ + & XMF**2/XMW*SINA/SBETA + GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+ + & XMF**2/XMW*SINA/SBETA + ELSE + GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+ + & XMF**2/XMW*COSA/CBETA + GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+ + & XMF**2/XMW*COSA/CBETA + ENDIF + IF(IFL.EQ.5) THEN + AT=ATRIB + ELSEIF(IFL.EQ.6) THEN + AT=ATRIT + ELSEIF(IFL.EQ.15) THEN + AT=ATRIL + ELSE + AT=0D0 + ENDIF +C.........Need to complexify + IF(IDU.EQ.2) THEN + GHLR=XMF/2D0/XMW/SBETA*(XMU*COSA+ + & AT*SINA) + ELSE + GHLR=XMF/2D0/XMW/CBETA*(XMU*SINA+ + & AT*COSA) + ENDIF + BL=GHLL + BR=GHRR + BLR=GHLR + ELSEIF(IG.EQ.36) THEN + GHLL=0D0 + GHRR=0D0 + IF(IFL.EQ.5) THEN + XMF=XMBOT + ELSEIF(IFL.EQ.6) THEN + XMF=XMTOP + ELSEIF(IFL.LT.5) THEN + XMF=0D0 + ELSE + XMF=PMAS(IFL,1) + ENDIF + IF(IFL.EQ.5) THEN + AT=ATRIB + ELSEIF(IFL.EQ.6) THEN + AT=ATRIT + ELSEIF(IFL.EQ.15) THEN + AT=ATRIL + ELSE + AT=0D0 + ENDIF +C.........Need to complexify + IF(IDU.EQ.2) THEN + GHLR=XMF/2D0/XMW*(-XMU+AT/TANB) + ELSE + GHLR=XMF/2D0/XMW/(-XMU+AT*TANB) + ENDIF + BL=GHLL + BR=GHRR + BLR=GHLR + ENDIF + AL=SFMIX(IFL,1)*SFMIX(IFL,3)*BL+ + & SFMIX(IFL,2)*SFMIX(IFL,4)*BR+ + & (SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,3)*SFMIX(IFL,2))*BLR + XL=PYLAMF(XMI2,XMSF1**2,XMB**2) + LKNT=LKNT+1 + IF(IG.EQ.23) THEN + XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2 + ELSE + XLAM(LKNT)=C1/4D0/XMI3*SQRT(XL)*AL**2 + ENDIF + IDLAM(LKNT,3)=0 + IDLAM(LKNT,1)=KFIN-KSUSY1 + IDLAM(LKNT,2)=IG + 160 CONTINUE + +C...SF -> SF' + W + XMB=PMAS(24,1) + IF(MOD(IFL,2).EQ.0) THEN + KF1=KSUSY1+IFL-1 + ELSE + KF1=KSUSY1+IFL+1 + ENDIF + KF2=KF1+KSUSY1 + XMSF1=PMAS(PYCOMP(KF1),1) + XMSF2=PMAS(PYCOMP(KF2),1) + IF(XMI.GT.XMB+XMSF1) THEN + IF(MOD(IFL,2).EQ.0) THEN + IF(ILR.EQ.1) THEN + AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,1) + ELSE + AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,1) + ENDIF + ELSE + IF(ILR.EQ.1) THEN + AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,1) + ELSE + AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,1) + ENDIF + ENDIF + XL=PYLAMF(XMI2,XMSF1**2,XMB**2) + LKNT=LKNT+1 + XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2 + IDLAM(LKNT,3)=0 + IDLAM(LKNT,1)=KF1 + IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1)) + ENDIF + IF(XMI.GT.XMB+XMSF2) THEN + IF(MOD(IFL,2).EQ.0) THEN + IF(ILR.EQ.1) THEN + AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,3) + ELSE + AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,3) + ENDIF + ELSE + IF(ILR.EQ.1) THEN + AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,3) + ELSE + AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,3) + ENDIF + ENDIF + XL=PYLAMF(XMI2,XMSF2**2,XMB**2) + LKNT=LKNT+1 + XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2 + IDLAM(LKNT,3)=0 + IDLAM(LKNT,1)=KF2 + IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1)) + ENDIF + +C...SF -> SF' + HC + XMB=PMAS(37,1) + IF(MOD(IFL,2).EQ.0) THEN + KF1=KSUSY1+IFL-1 + ELSE + KF1=KSUSY1+IFL+1 + ENDIF + KF2=KF1+KSUSY1 + XMSF1=PMAS(PYCOMP(KF1),1) + XMSF2=PMAS(PYCOMP(KF2),1) + IF(XMI.GT.XMB+XMSF1) THEN + XMF=0D0 + XMFP=0D0 + AT=0D0 + AB=0D0 + IF(MOD(IFL,2).EQ.0) THEN +C...T1-> B1 HC + IF(ILR.EQ.1) THEN + CH1=-SFMIX(IFL,1)*SFMIX(IFL-1,1) + CH2= SFMIX(IFL,2)*SFMIX(IFL-1,2) + CH3=-SFMIX(IFL,1)*SFMIX(IFL-1,2) + CH4=-SFMIX(IFL,2)*SFMIX(IFL-1,1) +C...T2-> B1 HC + ELSE + CH1= SFMIX(IFL,3)*SFMIX(IFL-1,1) + CH2=-SFMIX(IFL,4)*SFMIX(IFL-1,2) + CH3= SFMIX(IFL,3)*SFMIX(IFL-1,2) + CH4= SFMIX(IFL,4)*SFMIX(IFL-1,1) + ENDIF + IF(IFL.EQ.6) THEN + XMF=XMTOP + XMFP=XMBOT + AT=ATRIT + AB=ATRIB + ENDIF + ELSE +C...B1 -> T1 HC + IF(ILR.EQ.1) THEN + CH1=-SFMIX(IFL+1,1)*SFMIX(IFL,1) + CH2= SFMIX(IFL+1,2)*SFMIX(IFL,2) + CH3=-SFMIX(IFL+1,1)*SFMIX(IFL,2) + CH4=-SFMIX(IFL+1,2)*SFMIX(IFL,1) +C...B2-> T1 HC + ELSE + CH1= SFMIX(IFL,3)*SFMIX(IFL+1,1) + CH2=-SFMIX(IFL,4)*SFMIX(IFL+1,2) + CH3= SFMIX(IFL,4)*SFMIX(IFL+1,1) + CH4= SFMIX(IFL,3)*SFMIX(IFL+1,2) + ENDIF + IF(IFL.EQ.5) THEN + XMF=XMTOP + XMFP=XMBOT + AT=ATRIT + AB=ATRIB + ENDIF + ENDIF + XL=PYLAMF(XMI2,XMSF1**2,XMB**2) + LKNT=LKNT+1 +C.......Need to complexify + AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+ + & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+ + & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB) + XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2 + IDLAM(LKNT,3)=0 + IDLAM(LKNT,1)=KF1 + IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1)) + ENDIF + IF(XMI.GT.XMB+XMSF2) THEN + XMF=0D0 + XMFP=0D0 + AT=0D0 + AB=0D0 + IF(MOD(IFL,2).EQ.0) THEN +C...T1-> B2 HC + IF(ILR.EQ.1) THEN + CH1= SFMIX(IFL-1,3)*SFMIX(IFL,1) + CH2=-SFMIX(IFL-1,4)*SFMIX(IFL,2) + CH3= SFMIX(IFL-1,4)*SFMIX(IFL,1) + CH4= SFMIX(IFL-1,3)*SFMIX(IFL,2) +C...T2-> B2 HC + ELSE + CH1= -SFMIX(IFL,3)*SFMIX(IFL-1,3) + CH2= SFMIX(IFL,4)*SFMIX(IFL-1,4) + CH3= -SFMIX(IFL,3)*SFMIX(IFL-1,4) + CH4= -SFMIX(IFL,4)*SFMIX(IFL-1,3) + ENDIF + IF(IFL.EQ.6) THEN + XMF=XMTOP + XMFP=XMBOT + AT=ATRIT + AB=ATRIB + ENDIF + ELSE +C...B1 -> T2 HC + IF(ILR.EQ.1) THEN + CH1= SFMIX(IFL+1,3)*SFMIX(IFL,1) + CH2=-SFMIX(IFL+1,4)*SFMIX(IFL,2) + CH3= SFMIX(IFL+1,3)*SFMIX(IFL,2) + CH4= SFMIX(IFL+1,4)*SFMIX(IFL,1) +C...B2-> T2 HC + ELSE + CH1= -SFMIX(IFL+1,3)*SFMIX(IFL,3) + CH2= SFMIX(IFL+1,4)*SFMIX(IFL,4) + CH3= -SFMIX(IFL+1,3)*SFMIX(IFL,4) + CH4= -SFMIX(IFL+1,4)*SFMIX(IFL,3) + ENDIF + IF(IFL.EQ.5) THEN + XMF=XMTOP + XMFP=XMBOT + AT=ATRIT + AB=ATRIB + ENDIF + ENDIF + XL=PYLAMF(XMI2,XMSF1**2,XMB**2) + LKNT=LKNT+1 +C.......Need to complexify + AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+ + & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+ + & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB) + XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2 + IDLAM(LKNT,3)=0 + IDLAM(LKNT,1)=KF2 + IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1)) + ENDIF + +C...2-BODY DECAYS OF SQUARK -> QUARK GLUINO + + IF(IFL.LE.6) THEN + XMFP=0D0 + XMF=0D0 + IF(IFL.EQ.6) XMF=PMAS(6,1) + IF(IFL.EQ.5) XMF=PMAS(5,1) + XMJ=PMAS(PYCOMP(KSUSY1+21),1) + AXMJ=ABS(XMJ) + IF(XMI.GE.AXMJ+XMF) THEN + AL=-SFMIX(IFL,3) + BL=SFMIX(IFL,1) + AR=-SFMIX(IFL,4) + BR=SFMIX(IFL,2) +C...F1 -> F CHI + IF(ILR.EQ.1) THEN + XCA=AL + XCB=BL +C...F2 -> F CHI + ELSE + XCA=AR + XCB=BR + ENDIF + LKNT=LKNT+1 + XMA2=XMJ**2 + XMB2=XMF**2 + XL=PYLAMF(XMI2,XMA2,XMB2) + XLAM(LKNT)=4D0/3D0*AS/2D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)* + & (XCA**2+XCB**2)+4D0*XCA*XCB*XMJ*XMF) + IDLAM(LKNT,1)=KSUSY1+21 + IDLAM(LKNT,2)=IFL + IDLAM(LKNT,3)=0 + ENDIF + ENDIF + +C...IF NOTHING ELSE FOR T1, THEN T1* -> C+CHI0 + IF(KFIN.EQ.KSUSY1+6.AND.PMAS(KCIN,1).GT. + &PMAS(PYCOMP(KSUSY1+22),1)+PMAS(4,1)) THEN +C...THIS IS A BACK-OF-THE-ENVELOPE ESTIMATE +C...M = 1/(16PI**2)G**3 = G*2/(4PI) G/(4PI) = C1 * G/(4PI) +C...M*M = C1**2 * G**2/(16PI**2) +C...G = 1/(8PI)P/MI**2 * M*M = C1**3/(32PI**2)*LAM/(2*MI**3) + LKNT=LKNT+1 + XL=PYLAMF(XMI2,0D0,PMAS(PYCOMP(KSUSY1+22),1)**2) + XLAM(LKNT)=C1**3/64D0/PI**2/XMI3*SQRT(XL) + IF(XLAM(LKNT).EQ.0) XLAM(LKNT)=1D-3 + IDLAM(LKNT,1)=KSUSY1+22 + IDLAM(LKNT,2)=4 + IDLAM(LKNT,3)=0 + ENDIF + +C...R-violating sfermion decays (SKANDS). + CALL PYRVSF(KFIN,XLAM,IDLAM,LKNT) + + IKNT=LKNT + XLAM(0)=0D0 + DO 170 I=1,IKNT + IF(XLAM(I).LT.0D0) XLAM(I)=0D0 + XLAM(0)=XLAM(0)+XLAM(I) + 170 CONTINUE + IF(XLAM(0).EQ.0D0) XLAM(0)=1D-3 + + RETURN + END + +C********************************************************************* + +C...PYGLUI +C...Calculates gluino decay modes. + + SUBROUTINE PYGLUI(KFIN,XLAM,IDLAM,IKNT) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) + COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), + &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) +CC &SFMIX(16,4), +C COMMON/PYINTS/XXM(20) + COMPLEX*16 CXC + COMMON/PYINTC/XXC(10),CXC(8) + SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/ + +C...Local variables + COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP,GLIJ,GRIJ + DOUBLE PRECISION XMI,XMJ,XMF,AXMJ,AXMI + DOUBLE PRECISION XMI2,XMI3,XMA2,XMB2,XMFP + DOUBLE PRECISION PYLAMF,XL + DOUBLE PRECISION TANW,XW,AEM,C1,AS,S12MAX,S12MIN + DOUBLE PRECISION CA,CB,AL,AR,BL,BR + DOUBLE PRECISION XLAM(0:400) + INTEGER IDLAM(400,3) + INTEGER LKNT,IX,ILR,I,IKNT,IFL + DOUBLE PRECISION SR2 + DOUBLE PRECISION GAM + DOUBLE PRECISION PYALEM,PI,PYALPS,EI,T3I + EXTERNAL PYGAUS,PYXXZ6 + DOUBLE PRECISION PYGAUS,PYXXZ6 + DOUBLE PRECISION PREC + INTEGER KFNCHI(4),KFCCHI(2) + DATA PI/3.141592654D0/ + DATA SR2/1.4142136D0/ + DATA PREC/1D-2/ + DATA KFNCHI/1000022,1000023,1000025,1000035/ + DATA KFCCHI/1000024,1000037/ + +C...COUNT THE NUMBER OF DECAY MODES + LKNT=0 + IF(KFIN.NE.KSUSY1+21) RETURN + KCIN=PYCOMP(KFIN) + + XW=PARU(102) + TANW = SQRT(XW/(1D0-XW)) + + XMI=PMAS(KCIN,1) + AXMI=ABS(XMI) + XMI2=XMI**2 + AEM=PYALEM(XMI2) + AS =PYALPS(XMI2) + C1=AEM/XW + XMI3=AXMI**3 + + XMI=SIGN(XMI,RMSS(3)) + +C...2-BODY DECAYS OF GLUINO -> GRAVITINO GLUON + + IF(IMSS(11).EQ.1) THEN + XMP=RMSS(29) + IDG=39+KSUSY1 + XMGR=PMAS(PYCOMP(IDG),1) + XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI + IF(AXMI.GT.XMGR) THEN + LKNT=LKNT+1 + IDLAM(LKNT,1)=IDG + IDLAM(LKNT,2)=21 + IDLAM(LKNT,3)=0 + XLAM(LKNT)=XFAC + ENDIF + ENDIF + +C...2-BODY DECAYS OF GLUINO -> QUARK SQUARK + + DO 110 IFL=1,6 + DO 100 ILR=1,2 + XMJ=PMAS(PYCOMP(ILR*KSUSY1+IFL),1) + AXMJ=ABS(XMJ) + XMF=PMAS(IFL,1) + IF(AXMI.GE.AXMJ+XMF) THEN +C...Minus sign difference from gluino-quark-squark feynman rules + AL=SFMIX(IFL,1) + BL=-SFMIX(IFL,3) + AR=SFMIX(IFL,2) + BR=-SFMIX(IFL,4) +C...F1 -> F CHI + IF(ILR.EQ.1) THEN + CA=AL + CB=BL +C...F2 -> F CHI + ELSE + CA=AR + CB=BR + ENDIF + LKNT=LKNT+1 + XMA2=XMJ**2 + XMB2=XMF**2 + XL=PYLAMF(XMI2,XMA2,XMB2) + XLAM(LKNT)=4D0/8D0*AS/4D0/XMI3*SQRT(XL)*((XMI2+XMB2-XMA2)* + & (CA**2+CB**2)-4D0*CA*CB*XMI*XMF) + IDLAM(LKNT,1)=ILR*KSUSY1+IFL + IDLAM(LKNT,2)=-IFL + IDLAM(LKNT,3)=0 + LKNT=LKNT+1 + XLAM(LKNT)=XLAM(LKNT-1) + IDLAM(LKNT,1)=-IDLAM(LKNT-1,1) + IDLAM(LKNT,2)=-IDLAM(LKNT-1,2) + IDLAM(LKNT,3)=0 + ENDIF + 100 CONTINUE + 110 CONTINUE + +C...3-BODY DECAYS TO GAUGINO FERMION-FERMION +C...GLUINO -> NI Q QBAR + DO 170 IX=1,4 + XMJ=SMZ(IX) + AXMJ=ABS(XMJ) + IF(AXMI.GE.AXMJ) THEN + DO 120 I=1,4 + ZMIXC(IX,I)=DCMPLX(ZMIX(IX,I),ZMIXI(IX,I)) + 120 CONTINUE + OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))/SR2 + ORPP=DCONJG(OLPP) + XXC(1)=0D0 + XXC(2)=XMJ + XXC(3)=0D0 + XXC(4)=XMI + IA=1 + XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1) + XXC(6)=PMAS(PYCOMP(KSUSY2+IA),1) + XXC(7)=XXC(5) + XXC(8)=XXC(6) + XXC(9)=1D6 + XXC(10)=0D0 + EI=KCHG(IA,1)/3D0 + T3I=SIGN(1D0,EI+1D-6)/2D0 + GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP + GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP + CXC(1)=0D0 + CXC(2)=-GLIJ + CXC(3)=0D0 + CXC(4)=DCONJG(GLIJ) + CXC(5)=0D0 + CXC(6)=GRIJ + CXC(7)=0D0 + CXC(8)=-DCONJG(GRIJ) + S12MIN=0D0 + S12MAX=(AXMI-AXMJ)**2 + IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 130 + IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)* + & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-2) + IDLAM(LKNT,1)=KFNCHI(IX) + IDLAM(LKNT,2)=1 + IDLAM(LKNT,3)=-1 + ENDIF + IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=XLAM(LKNT-1) + IDLAM(LKNT,1)=KFNCHI(IX) + IDLAM(LKNT,2)=3 + IDLAM(LKNT,3)=-3 + ENDIF + 130 CONTINUE + IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN + PMOLD=PMAS(PYCOMP(KSUSY1+5),1) + IF(AXMI.GT.PMAS(PYCOMP(KSUSY2+5),1)+PMAS(5,1)) THEN + GOTO 140 + ELSEIF(AXMI.GT.PMAS(PYCOMP(KSUSY1+5),1)+PMAS(5,1)) THEN + PMAS(PYCOMP(KSUSY1+5),1)=100D0*XMI + ENDIF + CALL PYTBBN(IX,100,-1D0/3D0,XMI,GAM) + LKNT=LKNT+1 + XLAM(LKNT)=GAM + IDLAM(LKNT,1)=KFNCHI(IX) + IDLAM(LKNT,2)=5 + IDLAM(LKNT,3)=-5 + PMAS(PYCOMP(KSUSY1+5),1)=PMOLD + ENDIF +C...U-TYPE QUARKS + 140 CONTINUE + IA=2 + XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1) + XXC(6)=PMAS(PYCOMP(KSUSY2+IA),1) +C IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 290 + XXC(7)=XXC(5) + XXC(8)=XXC(6) + EI=KCHG(IA,1)/3D0 + T3I=SIGN(1D0,EI+1D-6)/2D0 + GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP + GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP + CXC(2)=-GLIJ + CXC(4)=DCONJG(GLIJ) + CXC(6)=GRIJ + CXC(8)=-DCONJG(GRIJ) + IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 150 + IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)* + & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-2) + IDLAM(LKNT,1)=KFNCHI(IX) + IDLAM(LKNT,2)=2 + IDLAM(LKNT,3)=-2 + ENDIF + IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=XLAM(LKNT-1) + IDLAM(LKNT,1)=KFNCHI(IX) + IDLAM(LKNT,2)=4 + IDLAM(LKNT,3)=-4 + ENDIF + 150 CONTINUE +C...INCLUDE THE DECAY GLUINO -> NJ + T + T~ +C...IF THE DECAY GLUINO -> ST + T CANNOT OCCUR + XMF=PMAS(6,1) + IF(AXMI.GE.AXMJ+2D0*XMF) THEN + PMOLD=PMAS(PYCOMP(KSUSY1+6),1) + IF(AXMI.GT.PMAS(PYCOMP(KSUSY2+6),1)+XMF) THEN + GOTO 160 + ELSEIF(AXMI.GT.PMAS(PYCOMP(KSUSY1+6),1)+XMF) THEN + PMAS(PYCOMP(KSUSY1+6),1)=100D0*XMI + ENDIF + CALL PYTBBN(IX,100,2D0/3D0,XMI,GAM) + LKNT=LKNT+1 + XLAM(LKNT)=GAM + IDLAM(LKNT,1)=KFNCHI(IX) + IDLAM(LKNT,2)=6 + IDLAM(LKNT,3)=-6 + PMAS(PYCOMP(KSUSY1+6),1)=PMOLD + ENDIF + 160 CONTINUE + ENDIF + 170 CONTINUE + +C...GLUINO -> CI Q QBAR' + DO 210 IX=1,2 + XMJ=SMW(IX) + AXMJ=ABS(XMJ) + IF(AXMI.GE.AXMJ) THEN + DO 180 I=1,2 + VMIXC(IX,I)=DCMPLX(VMIX(IX,I),VMIXI(IX,I)) + UMIXC(IX,I)=DCMPLX(UMIX(IX,I),UMIXI(IX,I)) + 180 CONTINUE + S12MIN=0D0 + S12MAX=(AXMI-AXMJ)**2 + XXC(1)=0D0 + XXC(2)=XMJ + XXC(3)=0D0 + XXC(4)=XMI + XXC(5)=PMAS(PYCOMP(KSUSY1+1),1) + XXC(6)=PMAS(PYCOMP(KSUSY1+2),1) + XXC(9)=1D6 + XXC(10)=0D0 + OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32))) + ORPP=DCONJG(OLPP) + CXC(1)=DCMPLX(0D0,0D0) + CXC(3)=DCMPLX(0D0,0D0) + CXC(5)=DCMPLX(0D0,0D0) + CXC(7)=DCMPLX(0D0,0D0) + CXC(2)=UMIXC(IX,1)*OLPP/SR2 + CXC(4)=-DCONJG(VMIXC(IX,1))*ORPP/SR2 + CXC(6)=DCMPLX(0D0,0D0) + CXC(8)=DCMPLX(0D0,0D0) + IF(XXC(5).LT.AXMI) THEN + XXC(5)=1D6 + ELSEIF(XXC(6).LT.AXMI) THEN + XXC(6)=1D6 + ENDIF + XXC(7)=XXC(6) + XXC(8)=XXC(5) + IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 190 + IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)* + & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC) + IDLAM(LKNT,1)=KFCCHI(IX) + IDLAM(LKNT,2)=1 + IDLAM(LKNT,3)=-2 + LKNT=LKNT+1 + XLAM(LKNT)=XLAM(LKNT-1) + IDLAM(LKNT,1)=-IDLAM(LKNT-1,1) + IDLAM(LKNT,2)=-IDLAM(LKNT-1,2) + IDLAM(LKNT,3)=-IDLAM(LKNT-1,3) + ENDIF + IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=XLAM(LKNT-1) + IDLAM(LKNT,1)=KFCCHI(IX) + IDLAM(LKNT,2)=3 + IDLAM(LKNT,3)=-4 + LKNT=LKNT+1 + XLAM(LKNT)=XLAM(LKNT-1) + IDLAM(LKNT,1)=-IDLAM(LKNT-1,1) + IDLAM(LKNT,2)=-IDLAM(LKNT-1,2) + IDLAM(LKNT,3)=-IDLAM(LKNT-1,3) + ENDIF + 190 CONTINUE + + XMF=PMAS(6,1) + XMFP=PMAS(5,1) + IF(AXMI.GE.AXMJ+XMF+XMFP) THEN + IF(XMI.GT.MIN(PMAS(PYCOMP(KSUSY1+5),1)+XMFP, + $ PMAS(PYCOMP(KSUSY2+6),1)+XMF)) GOTO 200 + PMOLT2=PMAS(PYCOMP(KSUSY2+6),1) + PMOLB2=PMAS(PYCOMP(KSUSY2+5),1) + PMOLT1=PMAS(PYCOMP(KSUSY1+6),1) + PMOLB1=PMAS(PYCOMP(KSUSY1+5),1) + IF(XMI.GT.PMOLT2+XMF) PMAS(PYCOMP(KSUSY2+6),1)=100D0*AXMI + IF(XMI.GT.PMOLT1+XMF) PMAS(PYCOMP(KSUSY1+6),1)=100D0*AXMI + IF(XMI.GT.PMOLB2+XMFP) PMAS(PYCOMP(KSUSY2+5),1)=100D0*AXMI + IF(XMI.GT.PMOLB1+XMFP) PMAS(PYCOMP(KSUSY1+5),1)=100D0*AXMI + CALL PYTBBC(IX,100,XMI,GAM) + LKNT=LKNT+1 + XLAM(LKNT)=GAM + IDLAM(LKNT,1)=KFCCHI(IX) + IDLAM(LKNT,2)=5 + IDLAM(LKNT,3)=-6 + LKNT=LKNT+1 + XLAM(LKNT)=XLAM(LKNT-1) + IDLAM(LKNT,1)=-IDLAM(LKNT-1,1) + IDLAM(LKNT,2)=-IDLAM(LKNT-1,2) + IDLAM(LKNT,3)=-IDLAM(LKNT-1,3) + PMAS(PYCOMP(KSUSY2+6),1)=PMOLT2 + PMAS(PYCOMP(KSUSY2+5),1)=PMOLB2 + PMAS(PYCOMP(KSUSY1+6),1)=PMOLT1 + PMAS(PYCOMP(KSUSY1+5),1)=PMOLB1 + ENDIF + 200 CONTINUE + ENDIF + 210 CONTINUE + +C...R-parity violating (3-body) decays. + CALL PYRVGL(KFIN,XLAM,IDLAM,LKNT) + + IKNT=LKNT + XLAM(0)=0D0 + DO 220 I=1,IKNT + IF(XLAM(I).LT.0D0) XLAM(I)=0D0 + XLAM(0)=XLAM(0)+XLAM(I) + 220 CONTINUE + IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6 + + RETURN + END + + +C********************************************************************* + +C...PYTBBN +C...Calculates the three-body decay of gluinos into +C...neutralinos and third generation fermions. + + SUBROUTINE PYTBBN(I,NN,E,XMGLU,GAM) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) + COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), + &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) + SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/ + +C...Local variables. + EXTERNAL PYSIMP,PYLAMF + DOUBLE PRECISION PYSIMP,PYLAMF + INTEGER LIN,NN + DOUBLE PRECISION COSD,SIND,COSD2,SIND2,COS2D,SIN2D + DOUBLE PRECISION HL,HR,FL,FR,HL2,HR2,FL2,FR2 + DOUBLE PRECISION XMS2(2),XM,XM2,XMG,XMG2,XMR,XMR2 + DOUBLE PRECISION SBAR,SMIN,SMAX,XMQA,W,GRS,G(0:6),SUMME(0:100) + DOUBLE PRECISION FF,HH,HFL,HFR,HRFL,HLFR,XMQ4,XM24 + DOUBLE PRECISION XLN1,XLN2,B1,B2 + DOUBLE PRECISION E,XMGLU,GAM + DOUBLE PRECISION HRB(4),HLB(4),FLB(4),FRB(4) + SAVE HRB,HLB,FLB,FRB + DOUBLE PRECISION ALPHAW,ALPHAS + DOUBLE PRECISION HLT(4),HRT(4),FLT(4),FRT(4) + SAVE HLT,HRT,FLT,FRT + DOUBLE PRECISION AMN(4),AN(4,4),ZN(3) + SAVE AMN,AN,ZN + DOUBLE PRECISION AMBOT,SINC,COSC + DOUBLE PRECISION AMTOP,SINA,COSA + DOUBLE PRECISION SINW,COSW,TANW + DOUBLE PRECISION ROT1(4,4) + LOGICAL IFIRST + SAVE IFIRST + DATA IFIRST/.TRUE./ + + TANB=RMSS(5) + SINB=TANB/SQRT(1D0+TANB**2) + COSB=SINB/TANB + XW=PARU(102) + SINW=SQRT(XW) + COSW=SQRT(1D0-XW) + TANW=SINW/COSW + AMW=PMAS(24,1) + COSC=SFMIX(5,1) + SINC=SFMIX(5,3) + COSA=SFMIX(6,1) + SINA=SFMIX(6,3) + AMBOT=PYMRUN(5,XMGLU**2) + AMTOP=PYMRUN(6,XMGLU**2) + W2=SQRT(2D0) + FAKT1=AMBOT/W2/AMW/COSB + FAKT2=AMTOP/W2/AMW/SINB + IF(IFIRST) THEN + DO 110 II=1,4 + AMN(II)=SMZ(II) + DO 100 J=1,4 + ROT1(II,J)=0D0 + AN(II,J)=0D0 + 100 CONTINUE + 110 CONTINUE + ROT1(1,1)=COSW + ROT1(1,2)=-SINW + ROT1(2,1)=-ROT1(1,2) + ROT1(2,2)=ROT1(1,1) + ROT1(3,3)=COSB + ROT1(3,4)=SINB + ROT1(4,3)=-ROT1(3,4) + ROT1(4,4)=ROT1(3,3) + DO 140 II=1,4 + DO 130 J=1,4 + DO 120 JJ=1,4 + AN(II,J)=AN(II,J)+ZMIX(II,JJ)*ROT1(JJ,J) + 120 CONTINUE + 130 CONTINUE + 140 CONTINUE + DO 150 J=1,4 + ZN(1)=-FAKT2*(-SINB*AN(J,3)+COSB*AN(J,4)) + ZN(2)=-2D0*W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1)) + ZN(3)=-2*W2/3D0*SINW*AN(J,1)-W2*(0.5D0-2D0/3D0* + & XW)*AN(J,2)/COSW + HRT(J)=ZN(1)*COSA-ZN(3)*SINA + HLT(J)=ZN(1)*COSA+ZN(2)*SINA + FLT(J)=ZN(3)*COSA+ZN(1)*SINA + FRT(J)=ZN(2)*COSA-ZN(1)*SINA +C FLU(J)=ZN(3) +C FRU(J)=ZN(2) + ZN(1)=-FAKT1*(COSB*AN(J,3)+SINB*AN(J,4)) + ZN(2)=W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1)) + ZN(3)=W2/3D0*SINW*AN(J,1)+W2*(0.5D0-XW/3D0)*AN(J,2)/COSW + HRB(J)=ZN(1)*COSC-ZN(3)*SINC + HLB(J)=ZN(1)*COSC+ZN(2)*SINC + FLB(J)=ZN(3)*COSC+ZN(1)*SINC + FRB(J)=ZN(2)*COSC-ZN(1)*SINC +C FLD(J)=ZN(3) +C FRD(J)=ZN(2) + 150 CONTINUE +C AMST(1)=PMAS(PYCOMP(KSUSY1+6),1) +C AMST(2)=PMAS(PYCOMP(KSUSY2+6),1) +C AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1) +C AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1) + IFIRST=.FALSE. + ENDIF + + IF(NINT(3D0*E).EQ.2) THEN + HL=HLT(I) + HR=HRT(I) + FL=FLT(I) + FR=FRT(I) + COSD=SFMIX(6,1) + SIND=SFMIX(6,3) + XMS2(1)=PMAS(PYCOMP(KSUSY1+6),1)**2 + XMS2(2)=PMAS(PYCOMP(KSUSY2+6),1)**2 + XM=PMAS(6,1) + ELSE + HL=HLB(I) + HR=HRB(I) + FL=FLB(I) + FR=FRB(I) + COSD=SFMIX(5,1) + SIND=SFMIX(5,3) + XMS2(1)=PMAS(PYCOMP(KSUSY1+5),1)**2 + XMS2(2)=PMAS(PYCOMP(KSUSY2+5),1)**2 + XM=PMAS(5,1) + ENDIF + COSD2=COSD*COSD + SIND2=SIND*SIND + COS2D=COSD2-SIND2 + SIN2D=SIND*COSD*2D0 + HL2=HL*HL + HR2=HR*HR + FL2=FL*FL + FR2=FR*FR + FF=FL*FR + HH=HL*HR + HFL=HL*FL + HFR=HR*FR + HRFL=HR*FL + HLFR=HL*FR + XM2=XM*XM + XMG=XMGLU + XMG2=XMG*XMG + ALPHAW=PYALEM(XMG2) + ALPHAS=PYALPS(XMG2) + XMR=AMN(I) + XMR2=XMR*XMR + XMQ4=XMG*XM2*XMR + XM24=(XMG2+XM2)*(XM2+XMR2) + SMIN=4D0*XM2 + SMAX=(XMG-ABS(XMR))**2 + XMQA=XMG2+2D0*XM2+XMR2 + DO 170 LIN=1,NN-1 + SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN) + GRS=SBAR-XMQA + W=PYLAMF(XMG2,XMR2,SBAR)*(0.25D0-XM2/SBAR) + W=DSQRT(W) + XLN1=LOG(ABS((GRS/2D0+XMS2(1)-W)/(GRS/2D0+XMS2(1)+W))) + XLN2=LOG(ABS((GRS/2D0+XMS2(2)-W)/(GRS/2D0+XMS2(2)+W))) + B1=1D0/(GRS/2D0+XMS2(1)-W)-1D0/(GRS/2D0+XMS2(1)+W) + B2=1D0/(GRS/2D0+XMS2(2)-W)-1D0/(GRS/2D0+XMS2(2)+W) + G(0)=-2D0*(HL2+FL2+HR2+FR2+(HFR-HFL)*SIN2D + & +2D0*(FF*SIND2-HH*COSD2))*W + G(1)=((HL2+FL2)*(XMQA-2D0*XMS2(1)-2D0*XM*XMG*SIN2D) + & +4D0*HFL*XM*XMR)*XLN1 + & +((HL2+FL2)*((XMQA-XMS2(1))*XMS2(1)-XM24 + & +2D0*XM*XMG*(XM2+XMR2-XMS2(1))*SIN2D) + & -4D0*HFL*XMR*XM*(XMG2+XM2-XMS2(1)) + & +8D0*HFL*XMQ4*SIN2D)*B1 + G(2)=((HR2+FR2)*(XMQA-2D0*XMS2(2)+2D0*XM*XMG*SIN2D) + & +4D0*HFR*XMR*XM)*XLN2 + & +((HR2+FR2)*((XMQA-XMS2(2))*XMS2(2)-XM24 + & +2D0*XMG*XM*SIN2D*(XMS2(2)-XM2-XMR2)) + & +4D0*HFR*XM*XMR*(XMS2(2)-XMG2-XM2) + & -8D0*HFR*XMQ4*SIN2D)*B2 + G(3)=(2D0*HFL*SIN2D*(XMS2(1)*(GRS+XMS2(1))+XM2*(SBAR-XMG2-XMR2) + & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HL2*SIND2+FL2*COSD2)*SBAR + & -2D0*XMG*XM*HFL*(SBAR+XMR2-XMG2) + & +XMR*XM*(HL2+FL2)*SIN2D*(SBAR+XMG2-XMR2) + & -4D0*XMQ4*(HL2-FL2)*COS2D)/(GRS+2D0*XMS2(1))*XLN1 + G(4)=4D0*COS2D*XM*XMG/(XMS2(1)-XMS2(2))* + & (((HLFR+HRFL)*(XM2+XMR2)+2D0*XM*XMR*(HH+FF))*(XLN1-XLN2) + & +(HLFR+HRFL)*(XMS2(2)*XLN2-XMS2(1)*XLN1)) + G(5)=(2D0*(HH*COSD2-FF*SIND2) + & *((XMS2(2)*(XMS2(2)+GRS)+XM2*XM2+XMG2*XMR2)*XLN2 + & +(XMS2(1)*(XMS2(1)+GRS)+XM2*XM2+XMG2*XMR2)*XLN1) + & +XM*((HH-FF)*SIN2D*XMG-(HRFL-HLFR)*XMR) + & *((GRS+XMS2(1)*2D0)*XLN1-(GRS+XMS2(2)*2D0)*XLN2) + & +((HRFL-HLFR)*XMR*(SIN2D*XMG*(SBAR-4D0*XM2) + & +COS2D*XM*(SBAR+XMG2-XMR2)) + & +2D0*(FF*COSD2-HH*SIND2)*XM2*(SBAR-XMG2-XMR2)) + & *(XLN1+XLN2))/(GRS+XMS2(1)+XMS2(2)) + G(6)=(-2D0*HFR*SIN2D*(XMS2(2)*(GRS+XMS2(2))+XM2*(SBAR-XMG2-XMR2) + & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HR2*SIND2+FR2*COSD2)*SBAR + & -2D0*XMG*XM*HFR*(SBAR+XMR2-XMG2) + & -XMR*XM*(HR2+FR2)*SIN2D*(SBAR+XMG2-XMR2) + & -4D0*XMQ4*(HR2-FR2)*COS2D)/(GRS+2D0*XMS2(2))*XLN2 + SUMME(LIN)=0D0 + DO 160 J=0,6 + SUMME(LIN)=SUMME(LIN)+G(J) + 160 CONTINUE + 170 CONTINUE + SUMME(0)=0D0 + SUMME(NN)=0D0 + GAM = ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN) + &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3) + + RETURN + END + +C********************************************************************* + +C...PYTBBC +C...Calculates the three-body decay of gluinos into +C...charginos and third generation fermions. + + SUBROUTINE PYTBBC(I,NN,XMGLU,GAM) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) + COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), + &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) + SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/ + +C...Local variables. + EXTERNAL PYSIMP,PYLAMF + DOUBLE PRECISION PYSIMP,PYLAMF + INTEGER I,NN,LIN + DOUBLE PRECISION XMG,XMG2,XMB,XMB2,XMR,XMR2 + DOUBLE PRECISION XMT,XMT2,XMST(4),XMSB(4) + DOUBLE PRECISION ULR(2),VLR(2),XMQ2,XMQ4,AM,W,SBAR,SMIN,SMAX + DOUBLE PRECISION SUMME(0:100),A(4,8) + DOUBLE PRECISION COS2A,SIN2A,COS2C,SIN2C + DOUBLE PRECISION GRS,XMQ3,XMGBTR,XMGTBR,ANT1,ANT2,ANB1,ANB2 + DOUBLE PRECISION XMGLU,GAM + DOUBLE PRECISION XX1(2),XX2(2),AAA(2),BBB(2),CCC(2), + &DDD(2),EEE(2),FFF(2) + SAVE XX1,XX2,AAA,BBB,CCC,DDD,EEE,FFF + DOUBLE PRECISION ALPHAW,ALPHAS + DOUBLE PRECISION AMC(2) + SAVE AMC + DOUBLE PRECISION AMBOT,AMSB(2),SINC,COSC + DOUBLE PRECISION AMTOP,AMST(2),SINA,COSA + SAVE AMSB,AMST + LOGICAL IFIRST + SAVE IFIRST + DATA IFIRST/.TRUE./ + + TANB=RMSS(5) + SINB=TANB/SQRT(1D0+TANB**2) + COSB=SINB/TANB + XW=PARU(102) + AMW=PMAS(24,1) + COSC=SFMIX(5,1) + SINC=SFMIX(5,3) + COSA=SFMIX(6,1) + SINA=SFMIX(6,3) + AMBOT=PYMRUN(5,XMGLU**2) + AMTOP=PYMRUN(6,XMGLU**2) + W2=SQRT(2D0) + AMW=PMAS(24,1) + FAKT1=AMBOT/W2/AMW/COSB + FAKT2=AMTOP/W2/AMW/SINB + IF(IFIRST) THEN + AMC(1)=SMW(1) + AMC(2)=SMW(2) + DO 100 JJ=1,2 + CCC(JJ)=FAKT1*UMIX(JJ,2)*SINC-UMIX(JJ,1)*COSC + EEE(JJ)=FAKT2*VMIX(JJ,2)*COSC + DDD(JJ)=FAKT1*UMIX(JJ,2)*COSC+UMIX(JJ,1)*SINC + FFF(JJ)=FAKT2*VMIX(JJ,2)*SINC + XX1(JJ)=FAKT2*VMIX(JJ,2)*SINA-VMIX(JJ,1)*COSA + AAA(JJ)=FAKT1*UMIX(JJ,2)*COSA + XX2(JJ)=FAKT2*VMIX(JJ,2)*COSA+VMIX(JJ,1)*SINA + BBB(JJ)=FAKT1*UMIX(JJ,2)*SINA + 100 CONTINUE + AMST(1)=PMAS(PYCOMP(KSUSY1+6),1) + AMST(2)=PMAS(PYCOMP(KSUSY2+6),1) + AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1) + AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1) + IFIRST=.FALSE. + ENDIF + + ULR(1)=XX1(I)*XX1(I)+AAA(I)*AAA(I) + ULR(2)=XX2(I)*XX2(I)+BBB(I)*BBB(I) + VLR(1)=CCC(I)*CCC(I)+EEE(I)*EEE(I) + VLR(2)=DDD(I)*DDD(I)+FFF(I)*FFF(I) + + COS2A=COSA**2-SINA**2 + SIN2A=SINA*COSA*2D0 + COS2C=COSC**2-SINC**2 + SIN2C=SINC*COSC*2D0 + + XMG=XMGLU + XMT=PMAS(6,1) + XMB=PMAS(5,1) + XMR=AMC(I) + XMG2=XMG*XMG + ALPHAW=PYALEM(XMG2) + ALPHAS=PYALPS(XMG2) + XMT2=XMT*XMT + XMB2=XMB*XMB + XMR2=XMR*XMR + XMQ2=XMG2+XMT2+XMB2+XMR2 + XMQ4=XMG*XMT*XMB*XMR + XMQ3=XMG2*XMR2+XMT2*XMB2 + XMGBTR=(XMG2+XMB2)*(XMT2+XMR2) + XMGTBR=(XMG2+XMT2)*(XMB2+XMR2) + + XMST(1)=AMST(1)*AMST(1) + XMST(2)=AMST(1)*AMST(1) + XMST(3)=AMST(2)*AMST(2) + XMST(4)=AMST(2)*AMST(2) + XMSB(1)=AMSB(1)*AMSB(1) + XMSB(2)=AMSB(2)*AMSB(2) + XMSB(3)=AMSB(1)*AMSB(1) + XMSB(4)=AMSB(2)*AMSB(2) + + A(1,1)=-COSA*SINC*CCC(I)*AAA(I)-SINA*COSC*EEE(I)*XX1(I) + A(1,2)=XMG*XMB*(COSA*COSC*CCC(I)*AAA(I)+SINA*SINC*EEE(I)*XX1(I)) + A(1,3)=-XMG*XMR*(COSA*COSC*CCC(I)*XX1(I)+SINA*SINC*EEE(I)*AAA(I)) + A(1,4)=XMB*XMR*(COSA*SINC*CCC(I)*XX1(I)+SINA*COSC*EEE(I)*AAA(I)) + A(1,5)=XMG*XMT*(COSA*COSC*EEE(I)*XX1(I)+SINA*SINC*CCC(I)*AAA(I)) + A(1,6)=-XMT*XMB*(COSA*SINC*EEE(I)*XX1(I)+SINA*COSC*CCC(I)*AAA(I)) + A(1,7)=XMT*XMR*(COSA*SINC*EEE(I)*AAA(I)+SINA*COSC*CCC(I)*XX1(I)) + A(1,8)=-XMQ4*(COSA*COSC*EEE(I)*AAA(I)+SINA*SINC*CCC(I)*XX1(I)) + + A(2,1)=-COSA*COSC*DDD(I)*AAA(I)-SINA*SINC*FFF(I)*XX1(I) + A(2,2)=-XMG*XMB*(COSA*SINC*DDD(I)*AAA(I)+SINA*COSC*FFF(I)*XX1(I)) + A(2,3)=XMG*XMR*(COSA*SINC*DDD(I)*XX1(I)+SINA*COSC*FFF(I)*AAA(I)) + A(2,4)=XMB*XMR*(COSA*COSC*DDD(I)*XX1(I)+SINA*SINC*FFF(I)*AAA(I)) + A(2,5)=XMG*XMT*(COSA*SINC*FFF(I)*XX1(I)+SINA*COSC*DDD(I)*AAA(I)) + A(2,6)=XMT*XMB*(COSA*COSC*FFF(I)*XX1(I)+SINA*SINC*DDD(I)*AAA(I)) + A(2,7)=-XMT*XMR*(COSA*COSC*FFF(I)*AAA(I)+SINA*SINC*DDD(I)*XX1(I)) + A(2,8)=-XMQ4*(COSA*SINC*FFF(I)*AAA(I)+SINA*COSC*DDD(I)*XX1(I)) + + A(3,1)=-COSA*COSC*EEE(I)*XX2(I)-SINA*SINC*CCC(I)*BBB(I) + A(3,2)=XMG*XMB*(COSA*SINC*EEE(I)*XX2(I)+SINA*COSC*CCC(I)*BBB(I)) + A(3,3)=XMG*XMR*(COSA*SINC*EEE(I)*BBB(I)+SINA*COSC*CCC(I)*XX2(I)) + A(3,4)=-XMB*XMR*(COSA*COSC*EEE(I)*BBB(I)+SINA*SINC*CCC(I)*XX2(I)) + A(3,5)=-XMG*XMT*(COSA*SINC*CCC(I)*BBB(I)+SINA*COSC*EEE(I)*XX2(I)) + A(3,6)=XMT*XMB*(COSA*COSC*CCC(I)*BBB(I)+SINA*SINC*EEE(I)*XX2(I)) + A(3,7)=XMT*XMR*(COSA*COSC*CCC(I)*XX2(I)+SINA*SINC*EEE(I)*BBB(I)) + A(3,8)=-XMQ4*(COSA*SINC*CCC(I)*XX2(I)+SINA*COSC*EEE(I)*BBB(I)) + + A(4,1)=-COSA*SINC*FFF(I)*XX2(I)-SINA*COSC*DDD(I)*BBB(I) + A(4,2)=-XMG*XMB*(COSA*COSC*FFF(I)*XX2(I)+SINA*SINC*DDD(I)*BBB(I)) + A(4,3)=-XMG*XMR*(COSA*COSC*FFF(I)*BBB(I)+SINA*SINC*DDD(I)*XX2(I)) + A(4,4)=-XMB*XMR*(COSA*SINC*FFF(I)*BBB(I)+SINA*COSC*DDD(I)*XX2(I)) + A(4,5)=-XMG*XMT*(COSA*COSC*DDD(I)*BBB(I)+SINA*SINC*FFF(I)*XX2(I)) + A(4,6)=-XMT*XMB*(COSA*SINC*DDD(I)*BBB(I)+SINA*COSC*FFF(I)*XX2(I)) + A(4,7)=-XMT*XMR*(COSA*SINC*DDD(I)*XX2(I)+SINA*COSC*FFF(I)*BBB(I)) + A(4,8)=-XMQ4*(COSA*COSC*DDD(I)*XX2(I)+SINA*SINC*FFF(I)*BBB(I)) + + SMAX=(XMG-ABS(XMR))**2 + SMIN=(XMB+XMT)**2+0.1D0 + + DO 120 LIN=0,NN-1 + SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN) + AM=(XMG2-XMR2)*(XMT2-XMB2)/2D0/SBAR + GRS=SBAR-XMQ2 + W=PYLAMF(SBAR,XMB2,XMT2)*PYLAMF(SBAR,XMG2,XMR2) + W=DSQRT(W)/2D0/SBAR + ANT1=LOG(ABS((GRS/2D0+AM+XMST(1)-W)/(GRS/2D0+AM+XMST(1)+W))) + ANT2=LOG(ABS((GRS/2D0+AM+XMST(3)-W)/(GRS/2D0+AM+XMST(3)+W))) + ANB1=LOG(ABS((GRS/2D0-AM+XMSB(1)-W)/(GRS/2D0-AM+XMSB(1)+W))) + ANB2=LOG(ABS((GRS/2D0-AM+XMSB(2)-W)/(GRS/2D0-AM+XMSB(2)+W))) + SUMME(LIN)=-ULR(1)*W+(ULR(1)*(XMQ2/2D0-XMST(1)-XMG*XMT*SIN2A) + & +2D0*XX1(I)*AAA(I)*XMR*XMB)*ANT1 + & +(ULR(1)/2D0*(XMST(1)*(XMQ2-XMST(1))-XMGTBR + & -2D0*XMG*XMT*SIN2A*(XMST(1)-XMB2-XMR2)) + & +2D0*XX1(I)*AAA(I)*XMR*XMB*(XMST(1)-XMG2-XMT2) + & +4D0*SIN2A*XX1(I)*AAA(I)*XMQ4) + & *(1D0/(GRS/2D0+AM+XMST(1)-W)-1D0/(GRS/2D0+AM+XMST(1)+W)) + SUMME(LIN)=SUMME(LIN)-ULR(2)*W + & +(ULR(2)*(XMQ2/2D0-XMST(3)+XMG*XMT*SIN2A) + & -2D0*XX2(I)*BBB(I)*XMR*XMB)*ANT2 + & +(ULR(2)/2D0*(XMST(3)*(XMQ2-XMST(3))-XMGTBR + & +2D0*XMG*XMT*SIN2A*(XMST(3)-XMB2-XMR2)) + & -2D0*XX2(I)*BBB(I)*XMR*XMB*(XMST(3)-XMG2-XMT2) + & +4D0*SIN2A*XX2(I)*BBB(I)*XMQ4) + & *(1D0/(GRS/2D0+AM+XMST(3)-W)-1D0/(GRS/2D0+AM+XMST(3)+W)) + SUMME(LIN)=SUMME(LIN)-VLR(1)*W + & +(VLR(1)*(XMQ2/2D0-XMSB(1)-XMG*XMB*SIN2C) + & +2D0*CCC(I)*EEE(I)*XMR*XMT)*ANB1 + & +(VLR(1)/2D0*(XMSB(1)*(XMQ2-XMSB(1))-XMGBTR + & -2D0*XMG*XMB*SIN2C*(XMSB(1)-XMT2-XMR2)) + & +2D0*CCC(I)*EEE(I)*XMR*XMT*(XMSB(1)-XMG2-XMB2) + & +4D0*SIN2C*CCC(I)*EEE(I)*XMQ4) + & *(1D0/(GRS/2D0-AM+XMSB(1)-W)-1D0/(GRS/2D0-AM+XMSB(1)+W)) + SUMME(LIN)=SUMME(LIN)-VLR(2)*W + & +(VLR(2)*(XMQ2/2D0-XMSB(2)+XMG*XMB*SIN2C) + & -2D0*DDD(I)*FFF(I)*XMR*XMT)*ANB2 + & +(VLR(2)/2D0*(XMSB(2)*(XMQ2-XMSB(2))-XMGBTR + & +2D0*XMG*XMB*SIN2C*(XMSB(2)-XMT2-XMR2)) + & -2D0*DDD(I)*FFF(I)*XMR*XMT*(XMSB(2)-XMG2-XMB2) + & +4D0*SIN2C*DDD(I)*FFF(I)*XMQ4) + & *(1D0/(GRS/2D0-AM+XMSB(2)-W)-1D0/(GRS/2D0-AM+XMSB(2)+W)) + SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMT*COS2A/(XMST(3)-XMST(1)) + & *((AAA(I)*BBB(I)-XX1(I)*XX2(I)) + & *((XMST(3)-XMB2-XMR2)*ANT2-(XMST(1)-XMB2-XMR2)*ANT1) + & +2D0*(AAA(I)*XX2(I)-XX1(I)*BBB(I))*XMB*XMR*(ANT2-ANT1)) + SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMB*COS2C/(XMSB(2)-XMSB(1)) + & *((EEE(I)*FFF(I)-CCC(I)*DDD(I)) + & *((XMSB(2)-XMT2-XMR2)*ANB2-(XMSB(1)-XMT2-XMR2)*ANB1) + & +2D0*(EEE(I)*DDD(I)-CCC(I)*FFF(I))*XMT*XMR*(ANB2-ANB1)) + DO 110 J=1,4 + SUMME(LIN)=SUMME(LIN)-2D0*A(J,1)*W + & +((-A(J,1)*(XMSB(J)*(GRS+XMSB(J))+XMQ3) + & +A(J,2)*(XMSB(J)-XMT2-XMR2)+A(J,3)*(SBAR-XMB2-XMT2) + & +A(J,4)*(XMSB(J)+SBAR-XMB2-XMR2) + & -A(J,5)*(XMSB(J)+SBAR-XMG2-XMT2)+A(J,6)*(XMG2+XMR2-SBAR) + & -A(J,7)*(XMSB(J)-XMG2-XMB2)+2D0*A(J,8)) + & *LOG(ABS((GRS/2D0+XMSB(J)-AM-W)/(GRS/2D0+XMSB(J)-AM+W))) + & -(A(J,1)*(XMST(J)*(GRS+XMST(J))+XMQ3) + & +A(J,2)*(XMST(J)+SBAR-XMG2-XMB2)-A(J,3)*(SBAR-XMB2-XMT2) + & +A(J,4)*(XMST(J)-XMG2-XMT2)-A(J,5)*(XMST(J)-XMR2-XMB2) + & -A(J,6)*(XMG2+XMR2-SBAR) + & -A(J,7)*(XMST(J)+SBAR-XMT2-XMR2)-2D0*A(J,8)) + & *LOG(ABS((GRS/2D0+XMST(J)+AM-W)/(GRS/2D0+XMST(J)+AM+W)))) + & /(GRS+XMSB(J)+XMST(J)) + 110 CONTINUE + 120 CONTINUE + SUMME(NN)=0D0 + GAM= ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN) + &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3) + + RETURN + END + +C********************************************************************* + +C...PYNJDC +C...Calculates decay widths for the neutralinos (admixtures of +C...Bino, W3-ino, Higgs1-ino, Higgs2-ino) + +C...Input: KCIN = KF code for particle +C...Output: XLAM = widths +C... IDLAM = KF codes for decay particles +C... IKNT = number of decay channels defined +C...AUTHOR: STEPHEN MRENNA +C...Last change: +C...10-15-95: force decay chi^0_2 -> chi^0_1 + gamma +C...when CHIGAMMA .NE. 0 +C...10 FEB 96: Calculate this decay for small tan(beta) + + SUBROUTINE PYNJDC(KFIN,XLAM,IDLAM,IKNT) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) +c COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), +c &SFMIX(16,4) + COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), + &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) +C COMMON/PYINTS/XXM(20) + COMPLEX*16 CXC + COMMON/PYINTC/XXC(10),CXC(8) + SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/ + +C...Local variables. + COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP,GLIJ,GRIJ + COMPLEX*16 QIJ,RIJ,F21K,F12K,CAL,CAR,CBL,CBR,CA,CB + INTEGER KFIN + DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2, + &XMZ,XMZ2,AXMJ,AXMI + DOUBLE PRECISION S12MIN,S12MAX + DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMA2,XMB2 + DOUBLE PRECISION PYLAMF,XL + DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3I + DOUBLE PRECISION PYX2XH,PYX2XG + DOUBLE PRECISION XLAM(0:400) + INTEGER IDLAM(400,3) + INTEGER LKNT,IX,IH,J,IJ,I,IKNT,FID + INTEGER ITH(3),KF1,KF2 + INTEGER ITHC + DOUBLE PRECISION DH(3),EH(3) + DOUBLE PRECISION SR2 + DOUBLE PRECISION CBETA,SBETA + DOUBLE PRECISION GAMCON,XMT1,XMT2 + DOUBLE PRECISION PYALEM,PI,PYALPS + DOUBLE PRECISION RAT1,RAT2 + DOUBLE PRECISION T3T,FCOL + DOUBLE PRECISION ALFA,BETA,TANB + DOUBLE PRECISION PYXXGA + EXTERNAL PYGAUS,PYXXZ6 + DOUBLE PRECISION PYGAUS,PYXXZ6 + DOUBLE PRECISION PREC + INTEGER KFNCHI(4),KFCCHI(2) + DATA ITH/25,35,36/ + DATA ITHC/37/ + DATA PREC/1D-2/ + DATA PI/3.141592654D0/ + DATA SR2/1.4142136D0/ + DATA KFNCHI/1000022,1000023,1000025,1000035/ + DATA KFCCHI/1000024,1000037/ + +C...COUNT THE NUMBER OF DECAY MODES + LKNT=0 + + XMW=PMAS(24,1) + XMW2=XMW**2 + XMZ=PMAS(23,1) + XMZ2=XMZ**2 + XW=1D0-XMW2/XMZ2 + XW1=1D0-XW + TANW = SQRT(XW/XW1) + +C...IX IS 1 - 4 DEPENDING ON SEQUENCE NUMBER + IX=1 + IF(KFIN.EQ.KFNCHI(2)) IX=2 + IF(KFIN.EQ.KFNCHI(3)) IX=3 + IF(KFIN.EQ.KFNCHI(4)) IX=4 + + XMI=SMZ(IX) + XMI2=XMI**2 + AXMI=ABS(XMI) + AEM=PYALEM(XMI2) + AS =PYALPS(XMI2) + C1=AEM/XW + XMI3=ABS(XMI**3) + + TANB=RMSS(5) + BETA=ATAN(TANB) + ALFA=RMSS(18) + CBETA=COS(BETA) + SBETA=TANB*CBETA + CALFA=COS(ALFA) + SALFA=SIN(ALFA) + + DO 110 I=1,4 + DO 100 J=1,4 + ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I)) + 100 CONTINUE + 110 CONTINUE + DO 130 I=1,2 + DO 120 J=1,2 + VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I)) + UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I)) + 120 CONTINUE + 130 CONTINUE + +C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS + IF(IX.EQ.1.AND.IMSS(11).EQ.0) GOTO 300 + +C...FORCE CHI0_2 -> CHI0_1 + GAMMA + IF(IX.EQ.2 .AND. IMSS(10).NE.0 ) THEN + XMJ=SMZ(1) + AXMJ=ABS(XMJ) + LKNT=LKNT+1 + GAMCON=AEM**3/8D0/PI/XMW2/XW + XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2 + XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2 + XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2) + IDLAM(LKNT,1)=KSUSY1+22 + IDLAM(LKNT,2)=22 + IDLAM(LKNT,3)=0 + WRITE(MSTU(11),*) 'FORCED N2 -> N1 + GAMMA ',XLAM(LKNT) + GOTO 340 + ENDIF + +C...GRAVITINO DECAY MODES + + IF(IMSS(11).EQ.1) THEN + XMP=RMSS(29) + IDG=39+KSUSY1 + XMGR=PMAS(PYCOMP(IDG),1) + SINW=SQRT(XW) + COSW=SQRT(1D0-XW) + XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI + IF(AXMI.GT.XMGR+PMAS(22,1)) THEN + LKNT=LKNT+1 + IDLAM(LKNT,1)=IDG + IDLAM(LKNT,2)=22 + IDLAM(LKNT,3)=0 + XLAM(LKNT)=XFAC*ABS(ZMIXC(IX,1)*COSW+ZMIXC(IX,2)*SINW)**2 + ENDIF + IF(AXMI.GT.XMGR+XMZ) THEN + LKNT=LKNT+1 + IDLAM(LKNT,1)=IDG + IDLAM(LKNT,2)=23 + IDLAM(LKNT,3)=0 + XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,1)*SINW-ZMIXC(IX,2)*COSW)**2 + + $ .5D0*ABS(ZMIXC(IX,3)*CBETA-ZMIXC(IX,4)*SBETA)**2)* + & (1D0-XMZ2/XMI2)**4 + ENDIF + IF(AXMI.GT.XMGR+PMAS(25,1)) THEN + LKNT=LKNT+1 + IDLAM(LKNT,1)=IDG + IDLAM(LKNT,2)=25 + IDLAM(LKNT,3)=0 + XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*SALFA-ZMIXC(IX,4)*CALFA)**2)* + $ .5D0*(1D0-PMAS(25,1)**2/XMI2)**4 + ENDIF + IF(AXMI.GT.XMGR+PMAS(35,1)) THEN + LKNT=LKNT+1 + IDLAM(LKNT,1)=IDG + IDLAM(LKNT,2)=35 + IDLAM(LKNT,3)=0 + XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*CALFA+ZMIXC(IX,4)*SALFA)**2)* + $ .5D0*(1D0-PMAS(35,1)**2/XMI2)**4 + ENDIF + IF(AXMI.GT.XMGR+PMAS(36,1)) THEN + LKNT=LKNT+1 + IDLAM(LKNT,1)=IDG + IDLAM(LKNT,2)=36 + IDLAM(LKNT,3)=0 + XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*SBETA+ZMIXC(IX,4)*CBETA)**2)* + $ .5D0*(1D0-PMAS(36,1)**2/XMI2)**4 + ENDIF + IF(IX.EQ.1) GOTO 300 + ENDIF + + DO 220 IJ=1,IX-1 + XMJ=SMZ(IJ) + AXMJ=ABS(XMJ) + XMJ2=XMJ**2 + +C...CHI0_I -> CHI0_J + GAMMA + IF(AXMI.GE.AXMJ.AND.SBETA/CBETA.LE.2D0) THEN + RAT1=ABS(ZMIXC(IJ,1))**2+ABS(ZMIXC(IJ,2))**2 + RAT1=RAT1/( 1D-6+ABS(ZMIXC(IX,3))**2+ABS(ZMIXC(IX,4))**2 ) + RAT2=ABS(ZMIXC(IX,1))**2+ABS(ZMIXC(IX,2))**2 + RAT2=RAT2/( 1D-6+ABS(ZMIXC(IJ,3))**2+ABS(ZMIXC(IJ,4))**2 ) + IF((RAT1.GT. 0.90D0 .AND. RAT1.LT. 1.10D0) .OR. + & (RAT2.GT. 0.90D0 .AND. RAT2.LT. 1.10D0)) THEN + LKNT=LKNT+1 + IDLAM(LKNT,1)=KFNCHI(IJ) + IDLAM(LKNT,2)=22 + IDLAM(LKNT,3)=0 + GAMCON=AEM**3/8D0/PI/XMW2/XW + XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2 + XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2 + XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2) + ENDIF + ENDIF + +C...CHI0_I -> CHI0_J + Z0 + IF(AXMI.GE.AXMJ+XMZ) THEN + LKNT=LKNT+1 + OLPP=(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,3))- + & ZMIXC(IX,4)*DCONJG(ZMIXC(IJ,4)))/2D0 + ORPP=-DCONJG(OLPP) + GX2=ABS(OLPP)**2+ABS(ORPP)**2 + GLR=DBLE(OLPP*DCONJG(ORPP)) + XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GX2,GLR) + IDLAM(LKNT,1)=KFNCHI(IJ) + IDLAM(LKNT,2)=23 + IDLAM(LKNT,3)=0 + ELSEIF(AXMI.GE.AXMJ) THEN + XXC(1)=0D0 + XXC(2)=XMJ + XXC(3)=0D0 + XXC(4)=XMI + XXC(9)=XMZ + XXC(10)=PMAS(23,2) + OLPP=(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,3))- + & ZMIXC(IX,4)*DCONJG(ZMIXC(IJ,4)))/2D0 + ORPP=DCONJG(OLPP) +C...CHARGED LEPTONS + FID=11 + XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1) + XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1) + EI=KCHG(FID,1)/3D0 + T3I=SIGN(1D0,EI+1D-6)/2D0 + GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))* + & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1)) + GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2 + CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP + CXC(2)=-GLIJ + CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP + CXC(4)=DCONJG(GLIJ) + CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP + CXC(6)=GRIJ + CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP + CXC(8)=-DCONJG(GRIJ) + S12MIN=0D0 + S12MAX=(AXMI-AXMJ)**2 + IF( XXC(5).LT.AXMI ) THEN + XXC(5)=1D6 + ENDIF + IF(XXC(6).LT.AXMI ) THEN + XXC(6)=1D6 + ENDIF + XXC(7)=XXC(5) + XXC(8)=XXC(6) + + IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=C1**2/XMI3/(16D0*PI)* + & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3) + IDLAM(LKNT,1)=KFNCHI(IJ) + IDLAM(LKNT,2)=FID + IDLAM(LKNT,3)=-FID + IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=XLAM(LKNT-1) + IDLAM(LKNT,1)=KFNCHI(IJ) + IDLAM(LKNT,2)=13 + IDLAM(LKNT,3)=-13 + ENDIF + ENDIF + 140 CONTINUE + IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN + XXC(5)=PMAS(PYCOMP(KSUSY1+15),1) + XXC(6)=PMAS(PYCOMP(KSUSY2+15),1) + ELSE + XXC(6)=PMAS(PYCOMP(KSUSY1+15),1) + XXC(5)=PMAS(PYCOMP(KSUSY2+15),1) + ENDIF + IF( XXC(5).LT.AXMI ) THEN + XXC(5)=1D6 + ENDIF + IF(XXC(6).LT.AXMI ) THEN + XXC(6)=1D6 + ENDIF + XXC(7)=XXC(5) + XXC(8)=XXC(6) + + IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=C1**2/XMI3/(16D0*PI)* + & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3) + IDLAM(LKNT,1)=KFNCHI(IJ) + IDLAM(LKNT,2)=15 + IDLAM(LKNT,3)=-15 + ENDIF + +C...NEUTRINOS + 150 CONTINUE + FID=12 + XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1) + XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1) + EI=KCHG(FID,1)/3D0 + T3I=SIGN(1D0,EI+1D-6)/2D0 + GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))* + & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1)) + GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2 + CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP + CXC(2)=-GLIJ + CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP + CXC(4)=DCONJG(GLIJ) + CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP + CXC(6)=GRIJ + CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP + CXC(8)=-DCONJG(GRIJ) + S12MIN=0D0 + S12MAX=(AXMI-AXMJ)**2 + IF( XXC(5).LT.AXMI ) THEN + XXC(5)=1D6 + ENDIF + IF( XXC(6).LT.AXMI ) THEN + XXC(6)=1D6 + ENDIF + XXC(7)=XXC(5) + XXC(8)=XXC(6) + + LKNT=LKNT+1 + XLAM(LKNT)=C1**2/XMI3/(16D0*PI)* + & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3) + IDLAM(LKNT,1)=KFNCHI(IJ) + IDLAM(LKNT,2)=12 + IDLAM(LKNT,3)=-12 + LKNT=LKNT+1 + XLAM(LKNT)=XLAM(LKNT-1) + IDLAM(LKNT,1)=KFNCHI(IJ) + IDLAM(LKNT,2)=14 + IDLAM(LKNT,3)=-14 + 160 CONTINUE + + IF(PMAS(PYCOMP(KSUSY1+16),1).NE.PMAS(PYCOMP(KSUSY1+12),1)) + & THEN + XXC(5)=PMAS(PYCOMP(KSUSY1+16),1) + IF( XXC(5).LT.AXMI ) THEN + XXC(5)=1D6 + ENDIF + XXC(7)=XXC(5) + LKNT=LKNT+1 + XLAM(LKNT)=C1**2/XMI3/(16D0*PI)* + & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3) + ELSE + LKNT=LKNT+1 + XLAM(LKNT)=XLAM(LKNT-1) + ENDIF + IDLAM(LKNT,1)=KFNCHI(IJ) + IDLAM(LKNT,2)=16 + IDLAM(LKNT,3)=-16 +C...D-TYPE QUARKS + 170 CONTINUE + FID=1 + XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1) + XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1) + EI=KCHG(FID,1)/3D0 + T3I=SIGN(1D0,EI+1D-6)/2D0 + GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))* + & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1)) + GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2 + CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP + CXC(2)=-GLIJ + CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP + CXC(4)=DCONJG(GLIJ) + CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP + CXC(6)=GRIJ + CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP + CXC(8)=-DCONJG(GRIJ) + S12MIN=0D0 + S12MAX=(AXMI-AXMJ)**2 + IF( XXC(5).LT.AXMI ) THEN + XXC(5)=1D6 + ENDIF + IF( XXC(6).LT.AXMI ) THEN + XXC(6)=1D6 + ENDIF + XXC(7)=XXC(5) + XXC(8)=XXC(6) + + IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=C1**2/XMI3/(16D0*PI)* + & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0 + IDLAM(LKNT,1)=KFNCHI(IJ) + IDLAM(LKNT,2)=1 + IDLAM(LKNT,3)=-1 + IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=XLAM(LKNT-1) + IDLAM(LKNT,1)=KFNCHI(IJ) + IDLAM(LKNT,2)=3 + IDLAM(LKNT,3)=-3 + ENDIF + ENDIF + 180 CONTINUE + IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN + XXC(5)=PMAS(PYCOMP(KSUSY1+5),1) + XXC(6)=PMAS(PYCOMP(KSUSY2+5),1) + ELSE + XXC(6)=PMAS(PYCOMP(KSUSY1+5),1) + XXC(5)=PMAS(PYCOMP(KSUSY2+5),1) + ENDIF + IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 190 + IF(XXC(5).LT.AXMI) THEN + XXC(5)=1D6 + ELSEIF(XXC(6).LT.AXMI) THEN + XXC(6)=1D6 + ENDIF + XXC(7)=XXC(5) + XXC(8)=XXC(6) + IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=C1**2/XMI3/(16D0*PI)* + & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0 + IDLAM(LKNT,1)=KFNCHI(IJ) + IDLAM(LKNT,2)=5 + IDLAM(LKNT,3)=-5 + ENDIF + +C...U-TYPE QUARKS + 190 CONTINUE + FID=2 + XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1) + XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1) + EI=KCHG(FID,1)/3D0 + T3I=SIGN(1D0,EI+1D-6)/2D0 + GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))* + & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1)) + GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2 + CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP + CXC(2)=-GLIJ + CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP + CXC(4)=DCONJG(GLIJ) + CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP + CXC(6)=GRIJ + CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP + CXC(8)=-DCONJG(GRIJ) + + IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 200 + IF(XXC(5).LT.AXMI) THEN + XXC(5)=1D6 + ELSEIF(XXC(6).LT.AXMI) THEN + XXC(6)=1D6 + ENDIF + XXC(7)=XXC(5) + XXC(8)=XXC(6) + + IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=C1**2/XMI3/(16D0*PI)* + & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0 + IDLAM(LKNT,1)=KFNCHI(IJ) + IDLAM(LKNT,2)=2 + IDLAM(LKNT,3)=-2 + IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=XLAM(LKNT-1) + IDLAM(LKNT,1)=KFNCHI(IJ) + IDLAM(LKNT,2)=4 + IDLAM(LKNT,3)=-4 + ENDIF + ENDIF + 200 CONTINUE + ENDIF + +C...CHI0_I -> CHI0_J + H0_K + EH(1)=SIN(ALFA) + EH(2)=COS(ALFA) + EH(3)=-SIN(BETA) + DH(1)=COS(ALFA) + DH(2)=-SIN(ALFA) + DH(3)=COS(BETA) + QIJ=ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,2))+ + & DCONJG(ZMIXC(IJ,3))*ZMIXC(IX,2)- + & TANW*(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,1))+ + & DCONJG(ZMIXC(IJ,3))*ZMIXC(IX,1)) + RIJ=DCONJG(ZMIXC(IX,4))*ZMIXC(IJ,2)+ + & ZMIXC(IJ,4)*DCONJG(ZMIXC(IX,2))- + & TANW*(DCONJG(ZMIXC(IX,4))*ZMIXC(IJ,1)+ + & ZMIXC(IJ,4)*DCONJG(ZMIXC(IX,1))) + DO 210 IH=1,3 + XMH=PMAS(ITH(IH),1) + XMH2=XMH**2 + IF(AXMI.GE.AXMJ+XMH) THEN + LKNT=LKNT+1 + XL=PYLAMF(XMI2,XMJ2,XMH2) + F21K=0.5D0*(QIJ*EH(IH)+RIJ*DH(IH)) + F12K=F21K +C...SIGN OF MASSES I,J + XMK=XMJ + IF(IH.EQ.3) XMK=-XMK + GX2=ABS(F21K)**2+ABS(F12K)**2 + GLR=DBLE(F21K*DCONJG(F12K)) + XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,GX2,GLR) + IDLAM(LKNT,1)=KFNCHI(IJ) + IDLAM(LKNT,2)=ITH(IH) + IDLAM(LKNT,3)=0 + ENDIF + 210 CONTINUE + 220 CONTINUE + +C...CHI0_I -> CHI+_J + W- + DO 260 IJ=1,2 + XMJ=SMW(IJ) + AXMJ=ABS(XMJ) + XMJ2=XMJ**2 + IF(AXMI.GE.AXMJ+XMW) THEN + LKNT=LKNT+1 + CXC(1)=(DCONJG(ZMIXC(IX,2))*VMIXC(IJ,1)- + & DCONJG(ZMIXC(IX,4))*VMIXC(IJ,2)/SR2) + CXC(3)=(ZMIXC(IX,2)*DCONJG(UMIXC(IJ,1))+ + & ZMIXC(IX,3)*DCONJG(UMIXC(IJ,2))/SR2) + GX2=ABS(CXC(1))**2+ABS(CXC(3))**2 + GLR=DBLE(CXC(1)*DCONJG(CXC(3))) + XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GX2,GLR) + IDLAM(LKNT,1)=KFCCHI(IJ) + IDLAM(LKNT,2)=-24 + IDLAM(LKNT,3)=0 + LKNT=LKNT+1 + XLAM(LKNT)=XLAM(LKNT-1) + IDLAM(LKNT,1)=-KFCCHI(IJ) + IDLAM(LKNT,2)=24 + IDLAM(LKNT,3)=0 + ELSEIF(AXMI.GE.AXMJ) THEN + S12MIN=0D0 + S12MAX=(AXMI-AXMJ)**2 + RT2I = 1D0/SQRT(2D0) + CXC(1)=(DCONJG(ZMIXC(IX,2))*VMIXC(IJ,1)- + & DCONJG(ZMIXC(IX,4))*VMIXC(IJ,2)*RT2I)*RT2I + CXC(3)=(ZMIXC(IX,2)*DCONJG(UMIXC(IJ,1))+ + & ZMIXC(IX,3)*DCONJG(UMIXC(IJ,2))*RT2I)*RT2I + CXC(5)=DCMPLX(0D0,0D0) + CXC(7)=DCMPLX(0D0,0D0) + IA=11 + JA=12 + EI=KCHG(IA,1)/3D0 + T3I=SIGN(1D0,EI+1D-6)/2D0 + EJ=KCHG(JA,1)/3D0 + T3J=SIGN(1D0,EJ+1D-6)/2D0 + CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)* + & TANW+ZMIXC(IX,2)*T3J)*RT2I + CXC(4)=-DCONJG(UMIXC(IJ,1))*( + & ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I)*RT2I + CXC(6)=DCMPLX(0D0,0D0) + CXC(8)=DCMPLX(0D0,0D0) + XXC(1)=0D0 + XXC(2)=XMJ + XXC(3)=0D0 + XXC(4)=XMI + XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1) + XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1) + XXC(9)=PMAS(24,1) + XXC(10)=PMAS(24,2) + IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 230 + IF(XXC(5).LT.AXMI) THEN + XXC(5)=1D6 + ELSEIF(XXC(6).LT.AXMI) THEN + XXC(6)=1D6 + ENDIF + XXC(7)=XXC(6) + XXC(8)=XXC(5) + IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=C1**2/XMI3/(16D0*PI)* + & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC) + IDLAM(LKNT,1)=KFCCHI(IJ) + IDLAM(LKNT,2)=11 + IDLAM(LKNT,3)=-12 + LKNT=LKNT+1 + XLAM(LKNT)=XLAM(LKNT-1) + IDLAM(LKNT,1)=-IDLAM(LKNT-1,1) + IDLAM(LKNT,2)=-IDLAM(LKNT-1,2) + IDLAM(LKNT,3)=-IDLAM(LKNT-1,3) + IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=XLAM(LKNT-1) + IDLAM(LKNT,1)=KFCCHI(IJ) + IDLAM(LKNT,2)=13 + IDLAM(LKNT,3)=-14 + LKNT=LKNT+1 + XLAM(LKNT)=XLAM(LKNT-1) + IDLAM(LKNT,1)=-IDLAM(LKNT-1,1) + IDLAM(LKNT,2)=-IDLAM(LKNT-1,2) + IDLAM(LKNT,3)=-IDLAM(LKNT-1,3) + ENDIF + ENDIF + 230 CONTINUE + IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN + XXC(5)=PMAS(PYCOMP(KSUSY1+15),1) + XXC(6)=PMAS(PYCOMP(KSUSY1+16),1) + ELSE + XXC(5)=PMAS(PYCOMP(KSUSY2+15),1) + XXC(6)=PMAS(PYCOMP(KSUSY1+16),1) + ENDIF + IF(XXC(5).LT.AXMI) THEN + XXC(5)=1D6 + ENDIF + IF(XXC(6).LT.AXMI) THEN + XXC(6)=1D6 + ENDIF + XXC(7)=XXC(6) + XXC(8)=XXC(5) + IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=C1**2/XMI3/(16D0*PI)* + & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC) + XLAM(LKNT)=XLAM(LKNT-1) + IDLAM(LKNT,1)=KFCCHI(IJ) + IDLAM(LKNT,2)=15 + IDLAM(LKNT,3)=-16 + LKNT=LKNT+1 + XLAM(LKNT)=XLAM(LKNT-1) + IDLAM(LKNT,1)=-IDLAM(LKNT-1,1) + IDLAM(LKNT,2)=-IDLAM(LKNT-1,2) + IDLAM(LKNT,3)=-IDLAM(LKNT-1,3) + ENDIF + +C...NOW, DO THE QUARKS + 240 CONTINUE + IA=1 + JA=2 + EI=KCHG(IA,1)/3D0 + T3I=SIGN(1D0,EI+1D-6)/2D0 + EJ=KCHG(JA,1)/3D0 + T3J=SIGN(1D0,EJ+1D-6)/2D0 + CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)* + & TANW+ZMIXC(IX,2)*T3J) + CXC(4)=-DCONJG(UMIXC(IJ,1))*( + & ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I) + XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1) + XXC(6)=PMAS(PYCOMP(KSUSY1+JA),1) + IF(XXC(5).LT.AXMI) THEN + XXC(5)=1D6 + ENDIF + IF(XXC(6).LT.AXMI) THEN + XXC(6)=1D6 + ENDIF + XXC(7)=XXC(6) + XXC(8)=XXC(5) + IF(AXMI.GE.AXMJ+PMAS(2,1)+PMAS(1,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)* + & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC) + IDLAM(LKNT,1)=KFCCHI(IJ) + IDLAM(LKNT,2)=1 + IDLAM(LKNT,3)=-2 + LKNT=LKNT+1 + XLAM(LKNT)=XLAM(LKNT-1) + IDLAM(LKNT,1)=-IDLAM(LKNT-1,1) + IDLAM(LKNT,2)=-IDLAM(LKNT-1,2) + IDLAM(LKNT,3)=-IDLAM(LKNT-1,3) + IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=XLAM(LKNT-1) + IDLAM(LKNT,1)=KFCCHI(IJ) + IDLAM(LKNT,2)=3 + IDLAM(LKNT,3)=-4 + LKNT=LKNT+1 + XLAM(LKNT)=XLAM(LKNT-1) + IDLAM(LKNT,1)=-IDLAM(LKNT-1,1) + IDLAM(LKNT,2)=-IDLAM(LKNT-1,2) + IDLAM(LKNT,3)=-IDLAM(LKNT-1,3) + ENDIF + ENDIF + 250 CONTINUE + ENDIF + 260 CONTINUE + 270 CONTINUE + +C...CHI0_I -> CHI+_I + H- + DO 280 IJ=1,2 + XMJ=SMW(IJ) + AXMJ=ABS(XMJ) + XMJ2=XMJ**2 + XMHP=PMAS(ITHC,1) + IF(AXMI.GE.AXMJ+XMHP) THEN + LKNT=LKNT+1 + OLPP=CBETA*(ZMIXC(IX,4)*DCONJG(VMIXC(IJ,1))+(ZMIXC(IX,2)+ + & ZMIXC(IX,1)*TANW)*DCONJG(VMIXC(IJ,2))/SR2) + ORPP=SBETA*(DCONJG(ZMIXC(IX,3))*UMIXC(IJ,1)- + & (DCONJG(ZMIXC(IX,2))+DCONJG(ZMIXC(IX,1))*TANW)* + & UMIXC(IJ,2)/SR2) + GX2=ABS(OLPP)**2+ABS(ORPP)**2 + GLR=DBLE(OLPP*DCONJG(ORPP)) + XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GX2,GLR) + IDLAM(LKNT,1)=KFCCHI(IJ) + IDLAM(LKNT,2)=-ITHC + IDLAM(LKNT,3)=0 + LKNT=LKNT+1 + XLAM(LKNT)=XLAM(LKNT-1) + IDLAM(LKNT,1)=-IDLAM(LKNT-1,1) + IDLAM(LKNT,2)=-IDLAM(LKNT-1,2) + IDLAM(LKNT,3)=-IDLAM(LKNT-1,3) + ELSE + + ENDIF + 280 CONTINUE + +C...2-BODY DECAYS TO FERMION SFERMION + DO 290 J=1,16 + IF(J.GE.7.AND.J.LE.10) GOTO 290 + KF1=KSUSY1+J + KF2=KSUSY2+J + XMSF1=PMAS(PYCOMP(KF1),1) + XMSF2=PMAS(PYCOMP(KF2),1) + XMF=PMAS(J,1) + IF(J.LE.6) THEN + FCOL=3D0 + ELSE + FCOL=1D0 + ENDIF + + EI=KCHG(J,1)/3D0 + T3T=SIGN(1D0,EI) + IF(J.EQ.12.OR.J.EQ.14.OR.J.EQ.16) T3T=1D0 + IF(MOD(J,2).EQ.0) THEN + CBL=T3T*ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-T3T) + CAL=XMF*ZMIXC(IX,4)/XMW/SBETA + CAR=-2D0*EI*TANW*ZMIXC(IX,1) + CBR=CAL + ELSE + CBL=T3T*ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-T3T) + CAL=XMF*ZMIXC(IX,3)/XMW/CBETA + CAR=-2D0*EI*TANW*ZMIXC(IX,1) + CBR=CAL + ENDIF + +C...D~ D_L + IF(AXMI.GE.XMF+XMSF1) THEN + LKNT=LKNT+1 + XMA2=XMSF1**2 + XMB2=XMF**2 + XL=PYLAMF(XMI2,XMA2,XMB2) + CA=CAL*SFMIX(J,1)+CAR*SFMIX(J,2) + CB=CBL*SFMIX(J,1)+CBR*SFMIX(J,2) + XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)* + & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI) + IDLAM(LKNT,1)=KF1 + IDLAM(LKNT,2)=-J + IDLAM(LKNT,3)=0 + LKNT=LKNT+1 + XLAM(LKNT)=XLAM(LKNT-1) + IDLAM(LKNT,1)=-IDLAM(LKNT-1,1) + IDLAM(LKNT,2)=-IDLAM(LKNT-1,2) + IDLAM(LKNT,3)=0 + ENDIF + +C...D~ D_R + IF(AXMI.GE.XMF+XMSF2) THEN + LKNT=LKNT+1 + XMA2=XMSF2**2 + XMB2=XMF**2 + CA=CAL*SFMIX(J,3)+CAR*SFMIX(J,4) + CB=CBL*SFMIX(J,3)+CBR*SFMIX(J,4) + XL=PYLAMF(XMI2,XMA2,XMB2) + XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)* + & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI) + IDLAM(LKNT,1)=KF2 + IDLAM(LKNT,2)=-J + IDLAM(LKNT,3)=0 + LKNT=LKNT+1 + XLAM(LKNT)=XLAM(LKNT-1) + IDLAM(LKNT,1)=-IDLAM(LKNT-1,1) + IDLAM(LKNT,2)=-IDLAM(LKNT-1,2) + IDLAM(LKNT,3)=0 + ENDIF + 290 CONTINUE + 300 CONTINUE +C...3-BODY DECAY TO Q Q~ GLUINO + XMJ=PMAS(PYCOMP(KSUSY1+21),1) + IF(AXMI.GE.XMJ) THEN + RT2I = 1D0/SQRT(2D0) + OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))*RT2I + ORPP=DCONJG(OLPP) + AXMJ=ABS(XMJ) + XXC(1)=0D0 + XXC(2)=XMJ + XXC(3)=0D0 + XXC(4)=XMI + FID=1 + XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1) + XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1) + XXC(7)=XXC(5) + XXC(8)=XXC(6) + XXC(9)=1D6 + XXC(10)=0D0 + EI=KCHG(FID,1)/3D0 + T3I=SIGN(1D0,EI+1D-6)/2D0 + GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP + GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP + CXC(1)=0D0 + CXC(2)=-GLIJ + CXC(3)=0D0 + CXC(4)=DCONJG(GLIJ) + CXC(5)=0D0 + CXC(6)=GRIJ + CXC(7)=0D0 + CXC(8)=-DCONJG(GRIJ) + S12MIN=0D0 + S12MAX=(AXMI-AXMJ)**2 +CMRENNA.This statement must be here to define S12MAX + IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 310 +C...ALL QUARKS BUT T + IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)* + & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3) + IDLAM(LKNT,1)=KSUSY1+21 + IDLAM(LKNT,2)=1 + IDLAM(LKNT,3)=-1 + IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=XLAM(LKNT-1) + IDLAM(LKNT,1)=KSUSY1+21 + IDLAM(LKNT,2)=3 + IDLAM(LKNT,3)=-3 + ENDIF + ENDIF + 310 CONTINUE + IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN + XXC(5)=PMAS(PYCOMP(KSUSY1+5),1) + XXC(6)=PMAS(PYCOMP(KSUSY2+5),1) + ELSE + XXC(6)=PMAS(PYCOMP(KSUSY1+5),1) + XXC(5)=PMAS(PYCOMP(KSUSY2+5),1) + ENDIF + IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 320 + XXC(7)=XXC(5) + XXC(8)=XXC(6) + IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)* + & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3) + IDLAM(LKNT,1)=KSUSY1+21 + IDLAM(LKNT,2)=5 + IDLAM(LKNT,3)=-5 + ENDIF +C...U-TYPE QUARKS + 320 CONTINUE + FID=2 + XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1) + XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1) + IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 330 + XXC(7)=XXC(5) + XXC(8)=XXC(6) + EI=KCHG(FID,1)/3D0 + T3I=SIGN(1D0,EI+1D-6)/2D0 + GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP + GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP + CXC(2)=-GLIJ + CXC(4)=DCONJG(GLIJ) + CXC(6)=GRIJ + CXC(8)=-DCONJG(GRIJ) + IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)* + & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3) + IDLAM(LKNT,1)=KSUSY1+21 + IDLAM(LKNT,2)=2 + IDLAM(LKNT,3)=-2 + IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=XLAM(LKNT-1) + IDLAM(LKNT,1)=KSUSY1+21 + IDLAM(LKNT,2)=4 + IDLAM(LKNT,3)=-4 + ENDIF + ENDIF + 330 CONTINUE + ENDIF + +C...R-violating decay modes (SKANDS). + CALL PYRVNE(KFIN,XLAM,IDLAM,LKNT) + + 340 IKNT=LKNT + XLAM(0)=0D0 + DO 350 I=1,IKNT + IF(XLAM(I).LT.0D0) XLAM(I)=0D0 + XLAM(0)=XLAM(0)+XLAM(I) + 350 CONTINUE + IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6 + + RETURN + END + +C********************************************************************* + +C...PYCJDC +C...Calculate decay widths for the charginos (admixtures of +C...charged Wino and charged Higgsino. + +C...Input: KCIN = KF code for particle +C...Output: XLAM = widths +C... IDLAM = KF codes for decay particles +C... IKNT = number of decay channels defined +C...AUTHOR: STEPHEN MRENNA +C...Last change: +C...10-16-95: force decay chi^+_1 -> chi^0_1 e+ nu_e +C...when CHIENU .NE. 0 + + SUBROUTINE PYCJDC(KFIN,XLAM,IDLAM,IKNT) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) + COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), + &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) +CC &SFMIX(16,4), +C COMMON/PYINTS/XXM(20) + COMPLEX*16 CXC + COMMON/PYINTC/XXC(10),CXC(8) + SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/ + +C...Local variables + COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP + COMPLEX*16 CAL,CBL,CAR,CBR,CA,CB + INTEGER KFIN,KCIN + DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2, + &XMZ,XMZ2,AXMJ,AXMI + DOUBLE PRECISION S12MIN,S12MAX + DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMA2,XMB2,XMK + DOUBLE PRECISION PYLAMF,XL + DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3I,BETA,ALFA + DOUBLE PRECISION PYX2XH,PYX2XG + DOUBLE PRECISION XLAM(0:400) + INTEGER IDLAM(400,3) + INTEGER LKNT,IX,IH,J,IJ,I,IKNT + INTEGER ITH(3) + INTEGER ITHC + DOUBLE PRECISION ETAH(3),DH(3),EH(3) + DOUBLE PRECISION SR2 + DOUBLE PRECISION CBETA,SBETA,TANB + + DOUBLE PRECISION PYALEM,PI,PYALPS + DOUBLE PRECISION FCOL + INTEGER KF1,KF2,ISF + INTEGER KFNCHI(4),KFCCHI(2) + + DOUBLE PRECISION TEMP + EXTERNAL PYGAUS,PYXXZ6 + DOUBLE PRECISION PYGAUS,PYXXZ6 + DOUBLE PRECISION PREC + DATA ITH/25,35,36/ + DATA ITHC/37/ + DATA ETAH/1D0,1D0,-1D0/ + DATA SR2/1.4142136D0/ + DATA PI/3.141592654D0/ + DATA PREC/1D-2/ + DATA KFNCHI/1000022,1000023,1000025,1000035/ + DATA KFCCHI/1000024,1000037/ + +C...COUNT THE NUMBER OF DECAY MODES + LKNT=0 + XMW=PMAS(24,1) + XMW2=XMW**2 + XMZ=PMAS(23,1) + XMZ2=XMZ**2 + XW=1D0-XMW2/XMZ2 + XW1=1D0-XW + TANW = SQRT(XW/XW1) + +C...1 OR 2 DEPENDING ON CHARGINO TYPE + IX=1 + IF(KFIN.EQ.KFCCHI(2)) IX=2 + KCIN=PYCOMP(KFIN) + + XMI=SMW(IX) + XMI2=XMI**2 + AXMI=ABS(XMI) + AEM=PYALEM(XMI2) + AS =PYALPS(XMI2) + C1=AEM/XW + XMI3=ABS(XMI**3) + TANB=RMSS(5) + BETA=ATAN(TANB) + CBETA=COS(BETA) + SBETA=TANB*CBETA + ALFA=RMSS(18) + + DO 110 I=1,2 + DO 100 J=1,2 + VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I)) + UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I)) + 100 CONTINUE + 110 CONTINUE + +C...GRAVITINO DECAY MODES + + IF(IMSS(11).EQ.1) THEN + XMP=RMSS(29) + IDG=39+KSUSY1 + XMGR=PMAS(PYCOMP(IDG),1) +C SINW=SQRT(XW) +C COSW=SQRT(1D0-XW) + XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI + IF(AXMI.GT.XMGR+XMW) THEN + LKNT=LKNT+1 + IDLAM(LKNT,1)=IDG + IDLAM(LKNT,2)=24 + IDLAM(LKNT,3)=0 + XLAM(LKNT)=XFAC*( + & .5D0*(ABS(VMIXC(IX,1))**2+ABS(UMIXC(IX,1))**2)+ + & .5D0*((ABS(VMIXC(IX,2))*SBETA)**2+(ABS(UMIXC(IX,2))*CBETA)**2))* + & (1D0-XMW2/XMI2)**4 + ENDIF + IF(AXMI.GT.XMGR+PMAS(37,1)) THEN + LKNT=LKNT+1 + IDLAM(LKNT,1)=IDG + IDLAM(LKNT,2)=37 + IDLAM(LKNT,3)=0 + XLAM(LKNT)=XFAC*(.5D0*((ABS(VMIXC(IX,2))*CBETA)**2+ + & (ABS(UMIXC(IX,2))*SBETA)**2)) + & *(1D0-PMAS(37,1)**2/XMI2)**4 + ENDIF + ENDIF + +C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS + IF(IX.EQ.1) GOTO 170 + XMJ=SMW(1) + AXMJ=ABS(XMJ) + XMJ2=XMJ**2 + +C...CHI_2+ -> CHI_1+ + Z0 + IF(AXMI.GE.AXMJ+XMZ) THEN + LKNT=LKNT+1 + IJ=1 + OLPP=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))- + & VMIXC(IJ,2)*DCONJG(VMIXC(IX,2))/2D0 + ORPP=-UMIXC(IX,1)*DCONJG(UMIXC(IJ,1))- + & UMIXC(IX,2)*DCONJG(UMIXC(IJ,2))/2D0 + GX2=ABS(OLPP)**2+ABS(ORPP)**2 + GLR=DBLE(OLPP*DCONJG(ORPP)) + XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GX2,GLR) + IDLAM(LKNT,1)=KFCCHI(1) + IDLAM(LKNT,2)=23 + IDLAM(LKNT,3)=0 + +C...CHARGED LEPTONS + ELSEIF(AXMI.GE.AXMJ) THEN + S12MIN=0D0 + S12MAX=(AXMI-AXMJ)**2 + IA=11 + JA=12 + EI=KCHG(IABS(IA),1)/3D0 + T3I=SIGN(1D0,EI+1D-6)/2D0 + XXC(1)=0D0 + XXC(2)=XMJ + XXC(3)=0D0 + XXC(4)=XMI + XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1) + XXC(6)=1D6 + XXC(9)=PMAS(23,1) + XXC(10)=PMAS(23,2) + IJ=1 + OLPP=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))- + & VMIXC(IJ,2)*DCONJG(VMIXC(IX,2))/2D0 + ORPP=-UMIXC(IX,1)*DCONJG(UMIXC(IJ,1))- + & UMIXC(IX,2)*DCONJG(UMIXC(IJ,2))/2D0 + CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP + CXC(2)=DCMPLX(0D0,0D0) + CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP + CXC(4)=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))*DCMPLX(T3I/XW) + CXC(5)=-DCMPLX(EI/XW1)*ORPP + CXC(6)=DCMPLX(0D0,0D0) + CXC(7)=-DCMPLX(EI/XW1)*OLPP + CXC(8)=DCMPLX(0D0,0D0) + IF( XXC(5).LT.AXMI ) THEN + XXC(5)=1D6 + ENDIF + XXC(7)=XXC(5) + XXC(8)=XXC(6) + IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=C1**2/XMI3/(16D0*PI)* + & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC) + IDLAM(LKNT,1)=KFCCHI(1) + IDLAM(LKNT,2)=11 + IDLAM(LKNT,3)=-11 + IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=XLAM(LKNT-1) + IDLAM(LKNT,1)=KFCCHI(1) + IDLAM(LKNT,2)=13 + IDLAM(LKNT,3)=-13 + ENDIF + IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=XLAM(LKNT-1) + IDLAM(LKNT,1)=KFCCHI(1) + IDLAM(LKNT,2)=15 + IDLAM(LKNT,3)=-15 + ENDIF + ENDIF + +C...NEUTRINOS + 120 CONTINUE + IA=12 + JA=11 + EI=KCHG(IABS(IA),1)/3D0 + T3I=SIGN(1D0,EI+1D-6)/2D0 + XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1) + XXC(6)=1D6 + CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP + CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP + CXC(4)=-UMIXC(IJ,1)*DCONJG(UMIXC(IX,1))*DCMPLX(T3I/XW) + CXC(5)=-DCMPLX(EI/XW1)*ORPP + CXC(7)=-DCMPLX(EI/XW1)*OLPP + IF( XXC(5).LT.AXMI ) THEN + XXC(5)=1D6 + ENDIF + XXC(7)=XXC(5) + XXC(8)=XXC(6) + IF(AXMI.GE.AXMJ+2D0*PMAS(12,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=C1**2/XMI3/(16D0*PI)* + & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC) + IDLAM(LKNT,1)=KFCCHI(1) + IDLAM(LKNT,2)=12 + IDLAM(LKNT,3)=-12 + LKNT=LKNT+1 + XLAM(LKNT)=XLAM(LKNT-1) + IDLAM(LKNT,1)=KFCCHI(1) + IDLAM(LKNT,2)=14 + IDLAM(LKNT,3)=-14 + ENDIF + IF(AXMI.GE.AXMJ+2D0*PMAS(16,1)) THEN + IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN + XXC(5)=PMAS(PYCOMP(KSUSY1+15),1) + ELSE + XXC(5)=PMAS(PYCOMP(KSUSY2+15),1) + ENDIF + IF( XXC(5).LT.AXMI ) THEN + XXC(5)=1D6 + ENDIF + XXC(7)=XXC(5) + LKNT=LKNT+1 + XLAM(LKNT)=C1**2/XMI3/(16D0*PI)* + & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC) + IDLAM(LKNT,1)=KFCCHI(1) + IDLAM(LKNT,2)=16 + IDLAM(LKNT,3)=-16 + ENDIF + +C...D-TYPE QUARKS + 130 CONTINUE + IA=1 + JA=2 + EI=KCHG(IABS(IA),1)/3D0 + T3I=SIGN(1D0,EI+1D-6)/2D0 + XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1) + XXC(6)=1D6 + CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP + CXC(2)=DCMPLX(0D0,0D0) + CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP + CXC(4)=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))*DCMPLX(T3I/XW) + CXC(5)=-DCMPLX(EI/XW1)*ORPP + CXC(6)=DCMPLX(0D0,0D0) + CXC(7)=-DCMPLX(EI/XW1)*OLPP + CXC(8)=DCMPLX(0D0,0D0) + IF( XXC(5).LT.AXMI ) THEN + XXC(5)=1D6 + ENDIF + XXC(7)=XXC(5) + XXC(8)=XXC(6) + IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)* + & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC) + IDLAM(LKNT,1)=KFCCHI(1) + IDLAM(LKNT,2)=1 + IDLAM(LKNT,3)=-1 + IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=XLAM(LKNT-1) + IDLAM(LKNT,1)=KFCCHI(1) + IDLAM(LKNT,2)=3 + IDLAM(LKNT,3)=-3 + ENDIF + ENDIF + IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN + IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN + XXC(5)=PMAS(PYCOMP(KSUSY1+5),1) + ELSE + XXC(5)=PMAS(PYCOMP(KSUSY2+5),1) + ENDIF + IF( XXC(5).LT.AXMI ) THEN + XXC(5)=1D6 + ENDIF + XXC(7)=XXC(5) + LKNT=LKNT+1 + XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)* + & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC) + IDLAM(LKNT,1)=KFCCHI(1) + IDLAM(LKNT,2)=5 + IDLAM(LKNT,3)=-5 + ENDIF + +C...U-TYPE QUARKS + 140 CONTINUE + IA=2 + JA=1 + EI=KCHG(IABS(IA),1)/3D0 + T3I=SIGN(1D0,EI+1D-6)/2D0 + XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1) + XXC(6)=1D6 + CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP + CXC(2)=DCMPLX(0D0,0D0) + CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP + CXC(4)=-UMIXC(IJ,1)*DCONJG(UMIXC(IX,1))*DCMPLX(T3I/XW) + CXC(5)=-DCMPLX(EI/XW1)*ORPP + CXC(6)=DCMPLX(0D0,0D0) + CXC(7)=-DCMPLX(EI/XW1)*OLPP + CXC(8)=DCMPLX(0D0,0D0) + IF( XXC(5).LT.AXMI ) THEN + XXC(5)=1D6 + ENDIF + XXC(7)=XXC(5) + XXC(8)=XXC(6) + IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)* + & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC) + IDLAM(LKNT,1)=KFCCHI(1) + IDLAM(LKNT,2)=2 + IDLAM(LKNT,3)=-2 + IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=XLAM(LKNT-1) + IDLAM(LKNT,1)=KFCCHI(1) + IDLAM(LKNT,2)=4 + IDLAM(LKNT,3)=-4 + ENDIF + ENDIF + 150 CONTINUE + ENDIF + +C...CHI_2+ -> CHI_1+ + H0_K + EH(2)=COS(ALFA) + EH(1)=SIN(ALFA) + EH(3)=-SBETA + DH(2)=-SIN(ALFA) + DH(1)=COS(ALFA) + DH(3)=COS(BETA) + DO 160 IH=1,3 + XMH=PMAS(ITH(IH),1) + XMH2=XMH**2 +C...NO 3-BODY OPTION + IF(AXMI.GE.AXMJ+XMH) THEN + LKNT=LKNT+1 + XL=PYLAMF(XMI2,XMJ2,XMH2) + OLPP=(VMIXC(2,1)*DCONJG(UMIXC(1,2))*EH(IH) - + & VMIXC(2,2)*DCONJG(UMIXC(1,1))*DH(IH))/SR2 + ORPP=(DCONJG(VMIXC(1,1))*UMIXC(2,2)*EH(IH) - + & DCONJG(VMIXC(1,2))*UMIXC(2,1)*DH(IH))/SR2 + XMK=XMJ*ETAH(IH) + GX2=ABS(OLPP)**2+ABS(ORPP)**2 + GLR=DBLE(OLPP*DCONJG(ORPP)) + XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,GX2,GLR) + IDLAM(LKNT,1)=KFCCHI(1) + IDLAM(LKNT,2)=ITH(IH) + IDLAM(LKNT,3)=0 + ENDIF + 160 CONTINUE + +C...CHI1 JUMPS TO HERE + 170 CONTINUE + +C...CHI+_I -> CHI0_J + W+ + DO 220 IJ=1,4 + XMJ=SMZ(IJ) + AXMJ=ABS(XMJ) + XMJ2=XMJ**2 + IF(AXMI.GE.AXMJ+XMW) THEN + LKNT=LKNT+1 + DO 180 I=1,4 + ZMIXC(IJ,I)=DCMPLX(ZMIX(IJ,I),ZMIXI(IJ,I)) + 180 CONTINUE + CXC(1)=(DCONJG(ZMIXC(IJ,2))*VMIXC(IX,1)- + & DCONJG(ZMIXC(IJ,4))*VMIXC(IX,2)/SR2) + CXC(3)=(ZMIXC(IJ,2)*DCONJG(UMIXC(IX,1))+ + & ZMIXC(IJ,3)*DCONJG(UMIXC(IX,2))/SR2) + GX2=ABS(CXC(1))**2+ABS(CXC(3))**2 + GLR=DBLE(CXC(1)*DCONJG(CXC(3))) + XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GX2,GLR) + IDLAM(LKNT,1)=KFNCHI(IJ) + IDLAM(LKNT,2)=24 + IDLAM(LKNT,3)=0 +C...LEPTONS + ELSEIF(AXMI.GE.AXMJ) THEN + S12MIN=0D0 + S12MAX=(AXMI-AXMJ)**2 + DO 190 I=1,4 + ZMIXC(IJ,I)=DCMPLX(ZMIX(IJ,I),ZMIXI(IJ,I)) + 190 CONTINUE + CXC(1)=(DCONJG(ZMIXC(IJ,2))*VMIXC(IX,1)- + & DCONJG(ZMIXC(IJ,4))*VMIXC(IX,2)/SR2)/SR2 + CXC(3)=(ZMIXC(IJ,2)*DCONJG(UMIXC(IX,1))+ + & ZMIXC(IJ,3)*DCONJG(UMIXC(IX,2))/SR2)/SR2 + CXC(5)=DCMPLX(0D0,0D0) + CXC(7)=DCMPLX(0D0,0D0) + IA=11 + JA=12 + EI=KCHG(IA,1)/3D0 + T3I=SIGN(1D0,EI+1D-6)/2D0 + EJ=KCHG(JA,1)/3D0 + T3J=SIGN(1D0,EJ+1D-6)/2D0 + CXC(2)=VMIXC(IX,1)*DCONJG(ZMIXC(IJ,1)*(EJ-T3J)* + & TANW+ZMIXC(IJ,2)*T3J)/SR2 + CXC(4)=-DCONJG(UMIXC(IX,1))*( + & ZMIXC(IJ,1)*(EI-T3I)*TANW+ZMIXC(IJ,2)*T3I)/SR2 + CXC(6)=DCMPLX(0D0,0D0) + CXC(8)=DCMPLX(0D0,0D0) + XXC(1)=0D0 + XXC(2)=XMJ + XXC(3)=0D0 + XXC(4)=XMI + XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1) + XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1) + XXC(9)=PMAS(24,1) + XXC(10)=PMAS(24,2) +CCC IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 190 + IF(XXC(5).LT.AXMI) THEN + XXC(5)=1D6 + ELSEIF(XXC(6).LT.AXMI) THEN + XXC(6)=1D6 + ENDIF + XXC(7)=XXC(6) + XXC(8)=XXC(5) +C...1/(2PI)**3*/(32*M**3)*G^4, G^2/(4*PI)= AEM/XW, +C...--> 1/(16PI)/M**3*(AEM/XW)**2 + IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN + LKNT=LKNT+1 + TEMP=PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC) + XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP + IDLAM(LKNT,1)=KFNCHI(IJ) + IDLAM(LKNT,2)=-11 + IDLAM(LKNT,3)=12 +C...ONLY DECAY CHI+1 -> E+ NU_E + IF( IMSS(12).NE. 0 ) GOTO 260 + IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=XLAM(LKNT-1) + IDLAM(LKNT,1)=KFNCHI(IJ) + IDLAM(LKNT,2)=-13 + IDLAM(LKNT,3)=14 + ENDIF + ENDIF + IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN + LKNT=LKNT+1 + IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN + XXC(6)=PMAS(PYCOMP(KSUSY1+15),1) + ELSE + XXC(6)=PMAS(PYCOMP(KSUSY2+15),1) + ENDIF + XXC(5)=PMAS(PYCOMP(KSUSY1+16),1) + IF(XXC(5).LT.AXMI) THEN + XXC(5)=1D6 + ELSEIF(XXC(6).LT.AXMI) THEN + XXC(6)=1D6 + ENDIF + XXC(7)=XXC(6) + XXC(8)=XXC(5) + TEMP=PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC) + XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP + IDLAM(LKNT,1)=KFNCHI(IJ) + IDLAM(LKNT,2)=-15 + IDLAM(LKNT,3)=16 + ENDIF + +C...NOW, DO THE QUARKS + 200 CONTINUE + IA=1 + JA=2 + EI=KCHG(IA,1)/3D0 + T3I=SIGN(1D0,EI+1D-6)/2D0 + EJ=KCHG(JA,1)/3D0 + T3J=SIGN(1D0,EJ+1D-6)/2D0 + CXC(2)=VMIXC(IX,1)*DCONJG(ZMIXC(IJ,1)*(EJ-T3J)* + & TANW+ZMIXC(IJ,2)*T3J) + CXC(4)=-DCONJG(UMIXC(IX,1))*( + & ZMIXC(IJ,1)*(EI-T3I)*TANW+ZMIXC(IJ,2)*T3I) + XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1) + XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1) + IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 210 + IF(XXC(5).LT.AXMI) THEN + XXC(5)=1D6 + ENDIF + IF(XXC(6).LT.AXMI) THEN + XXC(6)=1D6 + ENDIF + XXC(7)=XXC(6) + XXC(8)=XXC(5) + IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)* + & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC) + IDLAM(LKNT,1)=KFNCHI(IJ) + IDLAM(LKNT,2)=-1 + IDLAM(LKNT,3)=2 + IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=XLAM(LKNT-1) + IDLAM(LKNT,1)=KFNCHI(IJ) + IDLAM(LKNT,2)=-3 + IDLAM(LKNT,3)=4 + ENDIF + ENDIF + 210 CONTINUE + ENDIF + 220 CONTINUE + +C...CHI+_I -> CHI0_J + H+ + DO 230 IJ=1,4 + XMJ=SMZ(IJ) + AXMJ=ABS(XMJ) + XMJ2=XMJ**2 + XMHP=PMAS(ITHC,1) + IF(AXMI.GE.AXMJ+XMHP) THEN + LKNT=LKNT+1 + OLPP=CBETA*(ZMIXC(IJ,4)*DCONJG(VMIXC(IX,1))+(ZMIXC(IJ,2)+ + & ZMIXC(IJ,1)*TANW)*DCONJG(VMIXC(IX,2))/SR2) + ORPP=SBETA*(DCONJG(ZMIXC(IJ,3))*UMIXC(IX,1)- + & (DCONJG(ZMIXC(IJ,2))+DCONJG(ZMIXC(IJ,1))*TANW)* + & UMIXC(IX,2)/SR2) + GX2=ABS(OLPP)**2+ABS(ORPP)**2 + GLR=DBLE(OLPP*DCONJG(ORPP)) + XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GX2,GLR) + IDLAM(LKNT,1)=KFNCHI(IJ) + IDLAM(LKNT,2)=ITHC + IDLAM(LKNT,3)=0 + ELSE + + ENDIF + 230 CONTINUE + +C...2-BODY DECAYS TO FERMION SFERMION + DO 240 J=1,16 + IF(J.GE.7.AND.J.LE.10) GOTO 240 + IF(MOD(J,2).EQ.0) THEN + KF1=KSUSY1+J-1 + ELSE + KF1=KSUSY1+J+1 + ENDIF + KF2=KF1+KSUSY1 + XMSF1=PMAS(PYCOMP(KF1),1) + XMSF2=PMAS(PYCOMP(KF2),1) + XMF=PMAS(J,1) + IF(J.LE.6) THEN + FCOL=3D0 + ELSE + FCOL=1D0 + ENDIF + +C...U~ D_L + IF(MOD(J,2).EQ.0) THEN + XMFP=PMAS(J-1,1) + CAL=UMIXC(IX,1) + CBL=-XMF*VMIXC(IX,2)/XMW/SBETA/SR2 + CAR=-XMFP*UMIXC(IX,2)/XMW/CBETA/SR2 + CBR=0D0 + ISF=J-1 + ELSE + XMFP=PMAS(J+1,1) + CAL=VMIXC(IX,1) + CBL=-XMF*UMIXC(IX,2)/XMW/CBETA/SR2 + CBR=0D0 + CAR=-XMFP*VMIXC(IX,2)/XMW/SBETA/SR2 + ISF=J+1 + ENDIF + +C...~U_L D + IF(AXMI.GE.XMF+XMSF1) THEN + LKNT=LKNT+1 + XMA2=XMSF1**2 + XMB2=XMF**2 + XL=PYLAMF(XMI2,XMA2,XMB2) + CA=CAL*SFMIX(ISF,1)+CAR*SFMIX(ISF,2) + CB=CBL*SFMIX(ISF,1)+CBR*SFMIX(ISF,2) + XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)* + & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI) + IDLAM(LKNT,3)=0 + IF(MOD(J,2).EQ.0) THEN + IDLAM(LKNT,1)=-KF1 + IDLAM(LKNT,2)=J + ELSE + IDLAM(LKNT,1)=KF1 + IDLAM(LKNT,2)=-J + ENDIF + ENDIF + +C...U~ D_R + IF(AXMI.GE.XMF+XMSF2) THEN + LKNT=LKNT+1 + XMA2=XMSF2**2 + XMB2=XMF**2 + CA=CAL*SFMIX(ISF,3)+CAR*SFMIX(ISF,4) + CB=CBL*SFMIX(ISF,3)+CBR*SFMIX(ISF,4) + XL=PYLAMF(XMI2,XMA2,XMB2) + XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)* + & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI) + IDLAM(LKNT,3)=0 + IF(MOD(J,2).EQ.0) THEN + IDLAM(LKNT,1)=-KF2 + IDLAM(LKNT,2)=J + ELSE + IDLAM(LKNT,1)=KF2 + IDLAM(LKNT,2)=-J + ENDIF + ENDIF + 240 CONTINUE + +C...3-BODY DECAY TO Q Q~' GLUINO, ONLY IF IT CANNOT PROCEED THROUGH +C...A 2-BODY -- 2-BODY CHAIN + XMJ=PMAS(PYCOMP(KSUSY1+21),1) + IF(AXMI.GE.XMJ) THEN + AXMJ=ABS(XMJ) + S12MIN=0D0 + S12MAX=(AXMI-AXMJ)**2 + XXC(1)=0D0 + XXC(2)=XMJ + XXC(3)=0D0 + XXC(4)=XMI + XXC(5)=PMAS(PYCOMP(KSUSY1+1),1) + XXC(6)=PMAS(PYCOMP(KSUSY1+2),1) + XXC(9)=1D6 + XXC(10)=0D0 + OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32))) + ORPP=DCONJG(OLPP) + CXC(1)=DCMPLX(0D0,0D0) + CXC(3)=DCMPLX(0D0,0D0) + CXC(5)=DCMPLX(0D0,0D0) + CXC(7)=DCMPLX(0D0,0D0) + CXC(2)=UMIXC(IX,1)*OLPP/SR2 + CXC(4)=-DCONJG(VMIXC(IX,1))*ORPP/SR2 + CXC(6)=DCMPLX(0D0,0D0) + CXC(8)=DCMPLX(0D0,0D0) + IF(XXC(5).LT.AXMI) THEN + XXC(5)=1D6 + ELSEIF(XXC(6).LT.AXMI) THEN + XXC(6)=1D6 + ENDIF + XXC(7)=XXC(6) + XXC(8)=XXC(5) + IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 250 + IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)* + & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC) + IDLAM(LKNT,1)=KSUSY1+21 + IDLAM(LKNT,2)=-1 + IDLAM(LKNT,3)=2 + IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=XLAM(LKNT-1) + IDLAM(LKNT,1)=KSUSY1+21 + IDLAM(LKNT,2)=-3 + IDLAM(LKNT,3)=4 + ENDIF + ENDIF + 250 CONTINUE + ENDIF + +C...R-violating decay modes (SKANDS). + CALL PYRVCH(KFIN,XLAM,IDLAM,LKNT) + + 260 IKNT=LKNT + XLAM(0)=0D0 + DO 270 I=1,IKNT + XLAM(0)=XLAM(0)+XLAM(I) + IF(XLAM(I).LT.0D0) THEN + WRITE(MSTU(11),*) ' XLAM(I) = ',XLAM(I),KCIN, + & (IDLAM(I,J),J=1,3) + XLAM(I)=0D0 + ENDIF + 270 CONTINUE + IF(XLAM(0).EQ.0D0) THEN + XLAM(0)=1D-6 + WRITE(MSTU(11),*) ' XLAM(0) = ',XLAM(0) + WRITE(MSTU(11),*) LKNT + WRITE(MSTU(11),*) (XLAM(J),J=1,LKNT) + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYXXZ6 +C...Used in the calculation of inoi -> inoj + f + ~f. + + FUNCTION PYXXZ6(X) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) +C COMMON/PYINTS/XXM(20) + COMPLEX*16 CXC + COMMON/PYINTC/XXC(10),CXC(8) + SAVE /PYDAT1/,/PYINTC/ + +C...Local variables. + COMPLEX*16 QLLS,QRRS,QRLS,QLRS,QLLU,QRRU,QLRT,QRLT + DOUBLE PRECISION PYXXZ6,X + DOUBLE PRECISION XM12,XM22,XM32,S,S13,WPROP2 + DOUBLE PRECISION WW,WF1,WF2,WFL1,WFL2 + DOUBLE PRECISION SIJ + DOUBLE PRECISION XMV,XMG,XMSU1,XMSU2,XMSD1,XMSD2 + DOUBLE PRECISION OL2 + DOUBLE PRECISION S23MIN,S23MAX,S23AVE,S23DEL + INTEGER I + +C...Statement functions. +C...Integral from x to y of (t-a)(b-t) dt. + TINT(X,Y,A,B)=(X-Y)*(-(X**2+X*Y+Y**2)/3D0+(B+A)*(X+Y)/2D0-A*B) +C...Integral from x to y of (t-a)(b-t)/(t-c) dt. + TINT2(X,Y,A,B,C)=(X-Y)*(-0.5D0*(X+Y)+(B+A-C))- + &LOG(ABS((X-C)/(Y-C)))*(C-B)*(C-A) +C...Integral from x to y of (t-a)(b-t)/(t-c)**2 dt. + TINT3(X,Y,A,B,C)=-(X-Y)+(C-A)*(C-B)*(Y-X)/(X-C)/(Y-C)+ + &(B+A-2D0*C)*LOG(ABS((X-C)/(Y-C))) +C...Integral from x to y of (t-a)/(b-t) dt. + UTINT(X,Y,A,B)=LOG(ABS((X-A)/(B-X)*(B-Y)/(Y-A)))/(B-A) +C...Integral from x to y of 1/(t-a) dt. + TPROP(X,Y,A)=LOG(ABS((X-A)/(Y-A))) + + XM12=XXC(1)**2 + XM22=XXC(2)**2 + XM32=XXC(3)**2 + S=XXC(4)**2 + S13=X + + S23AVE=XM22+XM32-0.5D0/X*(X+XM32-XM12)*(X+XM22-S) + S23DEL=0.5D0/X*SQRT( ( (X-XM12-XM32)**2-4D0*XM12*XM32)* + &( (X-XM22-S)**2 -4D0*XM22*S ) ) + + S23MIN=(S23AVE-S23DEL) + S23MAX=(S23AVE+S23DEL) + + XMSD1=XXC(5)**2 + XMSD2=XXC(7)**2 + XMSU1=XXC(6)**2 + XMSU2=XXC(8)**2 + + XMV=XXC(9) + XMG=XXC(10) + QLLS=CXC(1) + QLLU=CXC(2) + QLRS=CXC(3) + QLRT=CXC(4) + QRLS=CXC(5) + QRLT=CXC(6) + QRRS=CXC(7) + QRRU=CXC(8) + WPROP2=(S13-XMV**2)**2+(XMV*XMG)**2 + SIJ=2D0*XXC(2)*XXC(4)*S13 + IF(XMV.LE.1000D0) THEN + OL2=ABS(QLLS)**2+ABS(QRRS)**2+ABS(QLRS)**2+ABS(QRLS)**2 + OLR=-2D0*DBLE(QLRS*DCONJG(QLLS)+QRLS*DCONJG(QRRS)) + WW=(OL2*2D0*TINT(S23MAX,S23MIN,XM22,S) + & +OLR*SIJ*(S23MAX-S23MIN))/WPROP2 + IF(XXC(5).LE.10000D0) THEN + WFL1=4D0*(DBLE(QLLS*DCONJG(QLLU))* + & TINT2(S23MAX,S23MIN,XM22,S,XMSD1)- + & .5D0*DBLE(QLLS*DCONJG(QLRT))*SIJ*TPROP(S23MAX,S23MIN,XMSD2)+ + & DBLE(QLRS*DCONJG(QLRT))*TINT2(S23MAX,S23MIN,XM22,S,XMSD2)- + & .5D0*DBLE(QLRS*DCONJG(QLLU))*SIJ*TPROP(S23MAX,S23MIN,XMSD1)) + & *(S13-XMV**2)/WPROP2 + ELSE + WFL1=0D0 + ENDIF + + IF(XXC(6).LE.10000D0) THEN + WFL2=4D0*(DBLE(QRRS*DCONJG(QRRU))* + & TINT2(S23MAX,S23MIN,XM22,S,XMSU1)- + & .5D0*DBLE(QRRS*DCONJG(QRLT))*SIJ*TPROP(S23MAX,S23MIN,XMSU2)+ + & DBLE(QRLS*DCONJG(QRLT))*TINT2(S23MAX,S23MIN,XM22,S,XMSU2)- + & .5D0*DBLE(QRLS*DCONJG(QRRU))*SIJ*TPROP(S23MAX,S23MIN,XMSU1)) + & *(S13-XMV**2)/WPROP2 + ELSE + WFL2=0D0 + ENDIF + ELSE + WW=0D0 + WFL1=0D0 + WFL2=0D0 + ENDIF + IF(XXC(5).LE.10000D0) THEN + WF1=2D0*ABS(QLLU)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD1) + & +2D0*ABS(QLRT)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD2) + & - 2D0*DBLE(QLRT*DCONJG(QLLU))* + & SIJ*UTINT(S23MAX,S23MIN,XMSD1,XM22+S-S13-XMSD2) + ELSE + WF1=0D0 + ENDIF + IF(XXC(6).LE.10000D0) THEN + WF2=2D0*ABS(QRRU)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU1) + & +2D0*ABS(QRLT)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU2) + & - 2D0*DBLE(QRLT*DCONJG(QRRU))* + & SIJ*UTINT(S23MAX,S23MIN,XMSU1,XM22+S-S13-XMSU2) + ELSE + WF2=0D0 + ENDIF + + PYXXZ6=(WW+WF1+WF2+WFL1+WFL2) + + IF(PYXXZ6.LT.0D0) THEN + WRITE(MSTU(11),*) ' NEGATIVE WT IN PYXXZ6 ' + WRITE(MSTU(11),*) (XXC(I),I=1,5) + WRITE(MSTU(11),*) (XXC(I),I=6,10) + WRITE(MSTU(11),*) WW,WF1,WF2,WFL1,WFL2 + WRITE(MSTU(11),*) S23MIN,S23MAX + PYXXZ6=0D0 + ENDIF + + RETURN + END + + +C********************************************************************* + +C...PYXXGA +C...Calculates chi0_i -> chi0_j + gamma. + + FUNCTION PYXXGA(C0,XM1,XM2,XMTR,XMTL) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP + +C...Local variables. + DOUBLE PRECISION PYXXGA,C0,XM1,XM2,XMTR,XMTL + DOUBLE PRECISION F1,F2 + + F1=(1D0+XMTR/(1D0-XMTR)*LOG(XMTR))/(1D0-XMTR) + F2=(1D0+XMTL/(1D0-XMTL)*LOG(XMTL))/(1D0-XMTL) + PYXXGA=C0*((XM1**2-XM2**2)/XM1)**3 + PYXXGA=PYXXGA*(2D0/3D0*(F1+F2)-13D0/12D0)**2 + + RETURN + END + +C********************************************************************* + +C...PYX2XG +C...Calculates the decay rate for ino -> ino + gauge boson. + + FUNCTION PYX2XG(C1,XM1,XM2,XM3,GX2,GLR) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP + +C...Local variables. + DOUBLE PRECISION PYX2XG,XM1,XM2,XM3,GX2,GLR + DOUBLE PRECISION XL,PYLAMF,C1 + DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3 + + XMI2=XM1**2 + XMI3=ABS(XM1**3) + XMJ2=XM2**2 + XMV2=XM3**2 + XL=PYLAMF(XMI2,XMJ2,XMV2) + PYX2XG=C1/8D0/XMI3*SQRT(XL) + &*(GX2*(XL+3D0*XMV2*(XMI2+XMJ2-XMV2))- + &12D0*GLR*XM1*XM2*XMV2) + + RETURN + END + +C********************************************************************* + +C...PYX2XH +C...Calculates the decay rate for ino -> ino + H. + + FUNCTION PYX2XH(C1,XM1,XM2,XM3,GX2,GLR) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP + +C...Local variables. + DOUBLE PRECISION PYX2XH,XM1,XM2,XM3 + DOUBLE PRECISION XL,PYLAMF,C1 + DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3 + + XMI2=XM1**2 + XMI3=ABS(XM1**3) + XMJ2=XM2**2 + XMV2=XM3**2 + XL=PYLAMF(XMI2,XMJ2,XMV2) + PYX2XH=C1/8D0/XMI3*SQRT(XL) + &*(GX2*(XMI2+XMJ2-XMV2)+ + &4D0*GLR*XM1*XM2) + + RETURN + END + +C********************************************************************* + +C...PYHEXT +C...Calculates the non-standard decay modes of the Higgs boson. +C... +C...Author: Stephen Mrenna +C...Last Update: April 2001 +C......Allow complex values for Z,U, and V + + SUBROUTINE PYHEXT(KFIN,XLAM,IDLAM,IKNT) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) + COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), + &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) + SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/,/PYSSMT/ + +C...Local variables. + COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP + COMPLEX*16 QIJ,RIJ,F21K,F12K + INTEGER KFIN + DOUBLE PRECISION XMI,XMJ,XMF,XMW,XMW2,XMZ,AXMJ,AXMI + DOUBLE PRECISION XMI2,XMI3,XMJ2 + DOUBLE PRECISION PYLAMF,XL,CF,EI + INTEGER IDU,IFL + DOUBLE PRECISION TANW,XW,AEM,C1,AS + DOUBLE PRECISION PYH2XX,GHLL,GHRR,GHLR + DOUBLE PRECISION XLAM(0:400) + INTEGER IDLAM(400,3) + INTEGER LKNT,IH,J,IJ,I,IKNT,IK + INTEGER ITH(4) + INTEGER KFNCHI(4),KFCCHI(2) + DOUBLE PRECISION ETAH(3),CH(3),DH(3),EH(3) + DOUBLE PRECISION SR2 + DOUBLE PRECISION BETA,ALFA + DOUBLE PRECISION CBETA,SBETA,GR,GL,TANB + DOUBLE PRECISION PYALEM + DOUBLE PRECISION AL,AR,ALR + DOUBLE PRECISION XMK,AXMK,COSA,SINA,CW,XML + DOUBLE PRECISION XMUZ,ATRIT,ATRIB,ATRIL + DOUBLE PRECISION XMJL,XMJR,XM1,XM2 + DATA ITH/25,35,36,37/ + DATA ETAH/1D0,1D0,-1D0/ + DATA SR2/1.4142136D0/ + DATA KFNCHI/1000022,1000023,1000025,1000035/ + DATA KFCCHI/1000024,1000037/ + +C...COUNT THE NUMBER OF DECAY MODES + LKNT=IKNT + + XMW=PMAS(24,1) + XMW2=XMW**2 + XMZ=PMAS(23,1) + XW=PARU(102) + TANW = SQRT(XW/(1D0-XW)) + CW=SQRT(1D0-XW) + +C...1 - 4 DEPENDING ON Higgs species. + IH=1 + IF(KFIN.EQ.ITH(2)) IH=2 + IF(KFIN.EQ.ITH(3)) IH=3 + IF(KFIN.EQ.ITH(4)) IH=4 + + XMI=PMAS(KFIN,1) + XMI2=XMI**2 + AXMI=ABS(XMI) + AEM=PYALEM(XMI2) + C1=AEM/XW + XMI3=ABS(XMI**3) + + TANB=RMSS(5) + BETA=ATAN(TANB) + CBETA=COS(BETA) + SBETA=TANB*CBETA + ALFA=RMSS(18) + COSA=COS(ALFA) + SINA=SIN(ALFA) + ATRIT=RMSS(16) + ATRIB=RMSS(15) + ATRIL=RMSS(17) + XMUZ=-RMSS(4) + + DO 110 I=1,4 + DO 100 J=1,4 + ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I)) + 100 CONTINUE + 110 CONTINUE + DO 130 I=1,2 + DO 120 J=1,2 + VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I)) + UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I)) + 120 CONTINUE + 130 CONTINUE + + + IF(IH.EQ.4) GOTO 220 + +C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS +C...H0_K -> CHI0_I + CHI0_J + EH(2)=SINA + EH(1)=COSA + EH(3)=CBETA + DH(2)=COSA + DH(1)=-SINA + DH(3)=SBETA + DO 150 IJ=1,4 + XMJ=SMZ(IJ) + AXMJ=ABS(XMJ) + DO 140 IK=1,IJ + XMK=SMZ(IK) + AXMK=ABS(XMK) + IF(AXMI.GE.AXMJ+AXMK) THEN + LKNT=LKNT+1 + QIJ=ZMIXC(IK,3)*ZMIXC(IJ,2)+ + & ZMIXC(IJ,3)*ZMIXC(IK,2)- + & TANW*(ZMIXC(IK,3)*ZMIXC(IJ,1)+ + & ZMIXC(IJ,3)*ZMIXC(IK,1)) + RIJ=ZMIXC(IK,4)*ZMIXC(IJ,2)+ + & ZMIXC(IJ,4)*ZMIXC(IK,2)- + & TANW*(ZMIXC(IK,4)*ZMIXC(IJ,1)+ + & ZMIXC(IJ,4)*ZMIXC(IK,1)) + F21K=0.5D0*DCONJG(QIJ*DH(IH)-RIJ*EH(IH)) + F12K=0.5D0*(QIJ*DH(IH)-RIJ*EH(IH)) +C...SIGN OF MASSES I,J + XML=XMK*ETAH(IH) + GX2=ABS(F12K)**2+ABS(F21K)**2 + GLR=DBLE(F12K*DCONJG(F21K)) + XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,GX2,GLR) + IF(IJ.EQ.IK) XLAM(LKNT)=XLAM(LKNT)*0.5D0 + IDLAM(LKNT,1)=KFNCHI(IJ) + IDLAM(LKNT,2)=KFNCHI(IK) + IDLAM(LKNT,3)=0 + ENDIF + 140 CONTINUE + 150 CONTINUE + +C...H0_K -> CHI+_I CHI-_J + DO 170 IJ=1,2 + XMJ=SMW(IJ) + AXMJ=ABS(XMJ) + DO 160 IK=1,2 + XMK=SMW(IK) + AXMK=ABS(XMK) + IF(AXMI.GE.AXMJ+AXMK) THEN + LKNT=LKNT+1 + OLPP=DCONJG(VMIXC(IJ,1)*UMIXC(IK,2)*DH(IH) + + & VMIXC(IJ,2)*UMIXC(IK,1)*EH(IH))/SR2 + ORPP=(VMIXC(IK,1)*UMIXC(IJ,2)*DH(IH) + + & VMIXC(IK,2)*UMIXC(IJ,1)*EH(IH))/SR2 + GX2=ABS(OLPP)**2+ABS(ORPP)**2 + GLR=DBLE(OLPP*DCONJG(ORPP)) + XML=XMK*ETAH(IH) + XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,GX2,GLR) + IDLAM(LKNT,1)=KFCCHI(IJ) + IDLAM(LKNT,2)=-KFCCHI(IK) + IDLAM(LKNT,3)=0 + ENDIF + 160 CONTINUE + 170 CONTINUE + +C...HIGGS TO SFERMION SFERMION + DO 200 IFL=1,16 + IF(IFL.GE.7.AND.IFL.LE.10) GOTO 200 + IJ=KSUSY1+IFL + XMJL=PMAS(PYCOMP(IJ),1) + XMJR=PMAS(PYCOMP(IJ+KSUSY1),1) + IF(AXMI.GE.2D0*MIN(XMJL,XMJR)) THEN + XMJ=XMJL + XMJ2=XMJ**2 + XL=PYLAMF(XMI2,XMJ2,XMJ2) + XMF=PMAS(IFL,1) + EI=KCHG(IFL,1)/3D0 + IDU=2-MOD(IFL,2) + + IF(IH.EQ.1) THEN + IF(IDU.EQ.1) THEN + GHLL=-XMZ/CW*(0.5D0+EI*XW)*SIN(ALFA+BETA)+ + & XMF**2/XMW*SINA/CBETA + GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)+ + & XMF**2/XMW*SINA/CBETA + IF(IFL.EQ.5) THEN + GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA- + & ATRIB*SINA) + ELSEIF(IFL.EQ.15) THEN + GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA- + & ATRIL*SINA) + ELSE + GHLR=0D0 + ENDIF + ELSE + GHLL=XMZ/CW*(0.5D0-EI*XW)*SIN(ALFA+BETA)- + & XMF**2/XMW*COSA/SBETA + GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)- + & XMF**2/XMW*COSA/SBETA + IF(IFL.EQ.6) THEN + GHLR=XMF/2D0/XMW/SBETA*(XMUZ*SINA- + & ATRIT*COSA) + ELSE + GHLR=0D0 + ENDIF + ENDIF + + ELSEIF(IH.EQ.2) THEN + IF(IDU.EQ.1) THEN + GHLL=XMZ/CW*(0.5D0+EI*XW)*COS(ALFA+BETA)- + & XMF**2/XMW*COSA/CBETA + GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)- + & XMF**2/XMW*COSA/CBETA + IF(IFL.EQ.5) THEN + GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+ + & ATRIB*COSA) + ELSEIF(IFL.EQ.15) THEN + GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+ + & ATRIL*COSA) + ELSE + GHLR=0D0 + ENDIF + ELSE + GHLL=-XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)- + & XMF**2/XMW*SINA/SBETA + GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)- + & XMF**2/XMW*SINA/SBETA + IF(IFL.EQ.6) THEN + GHLR=-XMF/2D0/XMW/SBETA*(XMUZ*COSA+ + & ATRIT*SINA) + ELSE + GHLR=0D0 + ENDIF + ENDIF + + ELSEIF(IH.EQ.3) THEN + GHLL=0D0 + GHRR=0D0 + GHLR=0D0 + IF(IDU.EQ.1) THEN + IF(IFL.EQ.5) THEN + GHLR=XMF/2D0/XMW*(ATRIB*TANB-XMUZ) + ELSEIF(IFL.EQ.15) THEN + GHLR=XMF/2D0/XMW*(ATRIL*TANB-XMUZ) + ENDIF + ELSE + IF(IFL.EQ.6) THEN + GHLR=XMF/2D0/XMW*(ATRIT/TANB-XMUZ) + ENDIF + ENDIF + ENDIF + IF(IH.EQ.3) GOTO 180 + + AL=SFMIX(IFL,1)**2 + AR=SFMIX(IFL,2)**2 + ALR=SFMIX(IFL,1)*SFMIX(IFL,2) + IF(IFL.LE.6) THEN + CF=3D0 + ELSE + CF=1D0 + ENDIF + + IF(AXMI.GE.2D0*XMJ) THEN + LKNT=LKNT+1 + XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3* + & (GHLL*AL+GHRR*AR + & +2D0*GHLR*ALR)**2 + IDLAM(LKNT,1)=IJ + IDLAM(LKNT,2)=-IJ + IDLAM(LKNT,3)=0 + ENDIF + + IF(AXMI.GE.2D0*XMJR) THEN + LKNT=LKNT+1 + AL=SFMIX(IFL,3)**2 + AR=SFMIX(IFL,4)**2 + ALR=SFMIX(IFL,3)*SFMIX(IFL,4) + XMJ=XMJR + XMJ2=XMJ**2 + XL=PYLAMF(XMI2,XMJ2,XMJ2) + XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3* + & (GHLL*AL+GHRR*AR + & +2D0*GHLR*ALR)**2 + IDLAM(LKNT,1)=IJ+KSUSY1 + IDLAM(LKNT,2)=-(IJ+KSUSY1) + IDLAM(LKNT,3)=0 + ENDIF + 180 CONTINUE + + IF(AXMI.GE.XMJL+XMJR) THEN + LKNT=LKNT+1 + AL=SFMIX(IFL,1)*SFMIX(IFL,3) + AR=SFMIX(IFL,2)*SFMIX(IFL,4) + ALR=SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,2)*SFMIX(IFL,3) + XMJ=XMJR + XMJ2=XMJ**2 + XL=PYLAMF(XMI2,XMJ2,XMJL**2) + XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3* + & (GHLL*AL+GHRR*AR)**2 + IDLAM(LKNT,1)=IJ + IDLAM(LKNT,2)=-(IJ+KSUSY1) + IDLAM(LKNT,3)=0 + LKNT=LKNT+1 + IDLAM(LKNT,1)=-IJ + IDLAM(LKNT,2)=IJ+KSUSY1 + IDLAM(LKNT,3)=0 + XLAM(LKNT)=XLAM(LKNT-1) + ENDIF + ENDIF + 190 CONTINUE + 200 CONTINUE + 210 CONTINUE + + GOTO 270 + 220 CONTINUE + +C...H+ -> CHI+_I + CHI0_J + DO 240 IJ=1,4 + XMJ=SMZ(IJ) + AXMJ=ABS(XMJ) + XMJ2=XMJ**2 + DO 230 IK=1,2 + XMK=SMW(IK) + AXMK=ABS(XMK) + IF(AXMI.GE.AXMJ+AXMK) THEN + LKNT=LKNT+1 + OLPP=CBETA*DCONJG(ZMIXC(IJ,4)*VMIXC(IK,1)+(ZMIXC(IJ,2)+ + & ZMIXC(IJ,1)*TANW)*VMIXC(IK,2)/SR2) + ORPP=SBETA*(ZMIXC(IJ,3)*UMIXC(IK,1)- + & (ZMIXC(IJ,2)+ZMIXC(IJ,1)*TANW)*UMIXC(IK,2)/SR2) + GX2=ABS(OLPP)**2+ABS(ORPP)**2 + GLR=DBLE(OLPP*DCONJG(ORPP)) + XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,-XMK,GX2,GLR) + IDLAM(LKNT,1)=KFNCHI(IJ) + IDLAM(LKNT,2)=KFCCHI(IK) + IDLAM(LKNT,3)=0 + ENDIF + 230 CONTINUE + 240 CONTINUE + + GL=-XMW/SR2*(SIN(2D0*BETA)-PMAS(6,1)**2/TANB/XMW2) + GR=-PMAS(6,1)/SR2/XMW*(XMUZ-ATRIT/TANB) + AL=0D0 + AR=0D0 + CF=3D0 + +C...H+ -> T_1 B_1~ + XM1=PMAS(PYCOMP(KSUSY1+6),1) + XM2=PMAS(PYCOMP(KSUSY1+5),1) + IF(XMI.GE.XM1+XM2) THEN + XL=PYLAMF(XMI2,XM1**2,XM2**2) + LKNT=LKNT+1 + XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3* + & (GL*SFMIX(6,1)*SFMIX(5,1)+GR*SFMIX(6,2)*SFMIX(5,1))**2 + IDLAM(LKNT,1)=KSUSY1+6 + IDLAM(LKNT,2)=-(KSUSY1+5) + IDLAM(LKNT,3)=0 + ENDIF + +C...H+ -> T_2 B_1~ + XM1=PMAS(PYCOMP(KSUSY2+6),1) + XM2=PMAS(PYCOMP(KSUSY1+5),1) + IF(XMI.GE.XM1+XM2) THEN + XL=PYLAMF(XMI2,XM1**2,XM2**2) + LKNT=LKNT+1 + XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3* + & (GL*SFMIX(6,3)*SFMIX(5,1)+GR*SFMIX(6,4)*SFMIX(5,1))**2 + IDLAM(LKNT,1)=KSUSY2+6 + IDLAM(LKNT,2)=-(KSUSY1+5) + IDLAM(LKNT,3)=0 + ENDIF + +C...H+ -> T_1 B_2~ + XM1=PMAS(PYCOMP(KSUSY1+6),1) + XM2=PMAS(PYCOMP(KSUSY2+5),1) + IF(XMI.GE.XM1+XM2) THEN + XL=PYLAMF(XMI2,XM1**2,XM2**2) + LKNT=LKNT+1 + XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3* + & (GL*SFMIX(6,1)*SFMIX(5,3)+GR*SFMIX(6,2)*SFMIX(5,3))**2 + IDLAM(LKNT,1)=KSUSY1+6 + IDLAM(LKNT,2)=-(KSUSY2+5) + IDLAM(LKNT,3)=0 + ENDIF + +C...H+ -> T_2 B_2~ + XM1=PMAS(PYCOMP(KSUSY2+6),1) + XM2=PMAS(PYCOMP(KSUSY2+5),1) + IF(XMI.GE.XM1+XM2) THEN + XL=PYLAMF(XMI2,XM1**2,XM2**2) + LKNT=LKNT+1 + XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3* + & (GL*SFMIX(6,3)*SFMIX(5,3)+GR*SFMIX(6,4)*SFMIX(5,3))**2 + IDLAM(LKNT,1)=KSUSY2+6 + IDLAM(LKNT,2)=-(KSUSY2+5) + IDLAM(LKNT,3)=0 + ENDIF + +C...H+ -> UL DL~ + GL=-XMW/SR2*SIN(2D0*BETA) + DO 250 IJ=1,3,2 + XM1=PMAS(PYCOMP(KSUSY1+IJ),1) + XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1) + IF(XMI.GE.XM1+XM2) THEN + XL=PYLAMF(XMI2,XM1**2,XM2**2) + LKNT=LKNT+1 + XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2 + IDLAM(LKNT,1)=-(KSUSY1+IJ) + IDLAM(LKNT,2)=KSUSY1+IJ+1 + IDLAM(LKNT,3)=0 + ENDIF + 250 CONTINUE + +C...H+ -> EL~ NUL + CF=1D0 + DO 260 IJ=11,13,2 + XM1=PMAS(PYCOMP(KSUSY1+IJ),1) + XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1) + IF(XMI.GE.XM1+XM2) THEN + XL=PYLAMF(XMI2,XM1**2,XM2**2) + LKNT=LKNT+1 + XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2 + IDLAM(LKNT,1)=-(KSUSY1+IJ) + IDLAM(LKNT,2)=KSUSY1+IJ+1 + IDLAM(LKNT,3)=0 + ENDIF + 260 CONTINUE + +C...H+ -> TAU1 NUTAUL + XM1=PMAS(PYCOMP(KSUSY1+15),1) + XM2=PMAS(PYCOMP(KSUSY1+16),1) + IF(XMI.GE.XM1+XM2) THEN + XL=PYLAMF(XMI2,XM1**2,XM2**2) + LKNT=LKNT+1 + XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2*SFMIX(15,1)**2 + IDLAM(LKNT,1)=-(KSUSY1+15) + IDLAM(LKNT,2)= KSUSY1+16 + IDLAM(LKNT,3)=0 + ENDIF + +C...H+ -> TAU2 NUTAUL + XM1=PMAS(PYCOMP(KSUSY2+15),1) + XM2=PMAS(PYCOMP(KSUSY1+16),1) + IF(XMI.GE.XM1+XM2) THEN + XL=PYLAMF(XMI2,XM1**2,XM2**2) + LKNT=LKNT+1 + XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2*SFMIX(15,3)**2 + IDLAM(LKNT,1)=-(KSUSY2+15) + IDLAM(LKNT,2)= KSUSY1+16 + IDLAM(LKNT,3)=0 + ENDIF + + 270 CONTINUE + IKNT=LKNT + XLAM(0)=0D0 + DO 280 I=1,IKNT + IF(XLAM(I).LE.0D0) XLAM(I)=0D0 + XLAM(0)=XLAM(0)+XLAM(I) + 280 CONTINUE + IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6 + + RETURN + END + +C********************************************************************* + +C...PYH2XX +C...Calculates the decay rate for a Higgs to an ino pair. + + FUNCTION PYH2XX(C1,XM1,XM2,XM3,GX2,GLR) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + SAVE /PYDAT1/ + +C...Local variables. + DOUBLE PRECISION PYH2XX,XM1,XM2,XM3,GL,GR + DOUBLE PRECISION XL,PYLAMF,C1 + DOUBLE PRECISION XMI2,XMJ2,XMK2,XMI3 + + XMI2=XM1**2 + XMI3=ABS(XM1**3) + XMJ2=XM2**2 + XMK2=XM3**2 + XL=PYLAMF(XMI2,XMJ2,XMK2) + PYH2XX=C1/4D0/XMI3*SQRT(XL) + &*(GX2*(XMI2-XMJ2-XMK2)- + &4D0*GLR*XM3*XM2) + IF(PYH2XX.LT.0D0) PYH2XX=0D0 + + RETURN + END + +C********************************************************************* + +C...PYGAUS +C...Integration by adaptive Gaussian quadrature. +C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig. + + FUNCTION PYGAUS(F, A, B, EPS) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP + +C...Local declarations. + EXTERNAL F + DOUBLE PRECISION F,W(12), X(12) + DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/ + DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/ + DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/ + DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/ + DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/ + DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/ + DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/ + DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/ + DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/ + DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/ + DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/ + DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/ + +C...The Gaussian quadrature algorithm. + H = 0D0 + IF(B .EQ. A) GOTO 140 + CONST = 5D-3 / ABS(B-A) + BB = A + 100 CONTINUE + AA = BB + BB = B + 110 CONTINUE + C1 = 0.5D0*(BB+AA) + C2 = 0.5D0*(BB-AA) + S8 = 0D0 + DO 120 I = 1, 4 + U = C2*X(I) + S8 = S8 + W(I) * (F(C1+U) + F(C1-U)) + 120 CONTINUE + S16 = 0D0 + DO 130 I = 5, 12 + U = C2*X(I) + S16 = S16 + W(I) * (F(C1+U) + F(C1-U)) + 130 CONTINUE + S16 = C2*S16 + IF(DABS(S16-C2*S8) .LE. EPS*(1D0+DABS(S16))) THEN + H = H + S16 + IF(BB .NE. B) GOTO 100 + ELSE + BB = C1 + IF(1D0 + CONST*ABS(C2) .NE. 1D0) GOTO 110 + H = 0D0 + CALL PYERRM(18,'(PYGAUS:) too high accuracy required') + GOTO 140 + ENDIF + 140 CONTINUE + PYGAUS = H + + RETURN + END + +C********************************************************************* + +C...PYGAU2 +C...Integration by adaptive Gaussian quadrature. +C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig. +C...Carbon copy of PYGAUS, but avoids having to use it recursively. + + FUNCTION PYGAU2(F, A, B, EPS) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP + +C...Local declarations. + EXTERNAL F + DOUBLE PRECISION F,W(12), X(12) + DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/ + DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/ + DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/ + DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/ + DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/ + DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/ + DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/ + DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/ + DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/ + DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/ + DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/ + DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/ + +C...The Gaussian quadrature algorithm. + H = 0D0 + IF(B .EQ. A) GOTO 140 + CONST = 5D-3 / ABS(B-A) + BB = A + 100 CONTINUE + AA = BB + BB = B + 110 CONTINUE + C1 = 0.5D0*(BB+AA) + C2 = 0.5D0*(BB-AA) + S8 = 0D0 + DO 120 I = 1, 4 + U = C2*X(I) + S8 = S8 + W(I) * (F(C1+U) + F(C1-U)) + 120 CONTINUE + S16 = 0D0 + DO 130 I = 5, 12 + U = C2*X(I) + S16 = S16 + W(I) * (F(C1+U) + F(C1-U)) + 130 CONTINUE + S16 = C2*S16 + IF(DABS(S16-C2*S8) .LE. EPS*(1D0+DABS(S16))) THEN + H = H + S16 + IF(BB .NE. B) GOTO 100 + ELSE + BB = C1 + IF(1D0 + CONST*ABS(C2) .NE. 1D0) GOTO 110 + H = 0D0 + CALL PYERRM(18,'(PYGAU2:) too high accuracy required') + GOTO 140 + ENDIF + 140 CONTINUE + PYGAU2 = H + + RETURN + END + +C********************************************************************* + +C...PYSIMP +C...Simpson formula for an integral. + + FUNCTION PYSIMP(Y,X0,X1,N) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP + +C...Local variables. + DOUBLE PRECISION Y,X0,X1,H,S + DIMENSION Y(0:N) + + S=0D0 + H=(X1-X0)/N + DO 100 I=0,N-2,2 + S=S+Y(I)+4D0*Y(I+1)+Y(I+2) + 100 CONTINUE + PYSIMP=S*H/3D0 + + RETURN + END + +C********************************************************************* + +C...PYLAMF +C...The standard lambda function. + + FUNCTION PYLAMF(X,Y,Z) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP + +C...Local variables. + DOUBLE PRECISION PYLAMF,X,Y,Z + + PYLAMF=(X-(Y+Z))**2-4D0*Y*Z + IF(PYLAMF.LT.0D0) PYLAMF=0D0 + + RETURN + END + +C********************************************************************* + +C...PYTBDY +C...Generates 3-body decays of gauginos. + + SUBROUTINE PYTBDY(IDIN) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) +C COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), + &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) +C SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYSSMT/ + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYSSMT/ + +C...Local variables. + DOUBLE PRECISION XM(5) + COMPLEX*16 OLPP,ORPP,QLL,QLR,QRR,QRL,GLIJ,GRIJ,PROPZ + COMPLEX*16 QLLS,QRRS,QLRS,QRLS,QLLU,QRRU,QLRT,QRLT + COMPLEX*16 ZMIXC(4,4),UMIXC(2,2),VMIXC(2,2) + DOUBLE PRECISION S12MIN,S12MAX,YJACO1,S23AVE,S23DF1,S23DF2 + DOUBLE PRECISION D1,D2,D3,P1,P2,P3,CTHE1,STHE1,CTHE3,STHE3 + DOUBLE PRECISION CPHI1,SPHI1 + DOUBLE PRECISION S23DEL,EPS + DOUBLE PRECISION GOLDEN,AX,BX,CX,TOL,XMIN,R,C + PARAMETER (R=0.61803399D0,C=1D0-R,TOL=1D-3) + DOUBLE PRECISION F1,F2,X0,X1,X2,X3 + INTEGER INOID(4) + DATA INOID/22,23,25,35/ + DATA EPS/1D-6/ + + ID=IDIN + ISKIP=1 + XM(1)=P(N+1,5) + XM(2)=P(N+2,5) + XM(3)=P(N+3,5) + XM(5)=P(ID,5) + +C...GENERATE S12 + S12MIN=(XM(1)+XM(2))**2 + S12MAX=(XM(5)-XM(3))**2 + YJACO1=S12MAX-S12MIN + +C...Initialize some parameters + XW=PARU(102) + XW1=1D0-XW + TANW=SQRT(XW/XW1) + IZID1=0 + IWID1=0 + IZID2=0 + IWID2=0 + + IA=K(N+2,2) + JA=K(N+3,2) + +C...Mrenna: check that we are indeed decaying a SUSY particle + IF(IABS(K(ID,2)).LT.KSUSY1.OR.IABS(K(ID,2)).GE.3000000) THEN + + ELSE + DO 100 I1=1,4 + IF(MOD(K(N+1,2),KSUSY1).EQ.INOID(I1)) IZID1=I1 + IF(MOD(K(ID,2),KSUSY1).EQ.INOID(I1)) IZID2=I1 + 100 CONTINUE + IF(MOD(K(N+1,2),KSUSY1).EQ.24) IWID1=1 + IF(MOD(K(N+1,2),KSUSY1).EQ.37) IWID1=2 + IF(MOD(K(ID,2),KSUSY1).EQ.24) IWID2=1 + IF(MOD(K(ID,2),KSUSY1).EQ.37) IWID2=2 + ZM12=XM(5)**2 + ZM22=XM(1)**2 + EI=KCHG(PYCOMP(IABS(IA)),1)/3D0 + T3I=SIGN(1D0,EI+1D-6)/2D0 + ENDIF + + IF(MSTP(47).EQ.0) THEN + ISKIP=0 + ELSEIF(MAX(ABS(IA),ABS(JA)).EQ.6) THEN + ISKIP=0 + ELSEIF(IZID1*IZID2.NE.0) THEN + SQMZ=PMAS(23,1)**2 + GMMZ=PMAS(23,1)*PMAS(23,2) + DO 110 I=1,4 + ZMIXC(IZID1,I)=DCMPLX(ZMIX(IZID1,I),ZMIXI(IZID1,I)) + ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I)) + 110 CONTINUE + OLPP=(ZMIXC(IZID1,3)*DCONJG(ZMIXC(IZID2,3))- + & ZMIXC(IZID1,4)*DCONJG(ZMIXC(IZID2,4)))/2D0 + ORPP=DCONJG(OLPP) + XLL2=PMAS(PYCOMP(KSUSY1+IABS(IA)),1)**2 + XLR2=XLL2 + XRR2=PMAS(PYCOMP(KSUSY2+IABS(IA)),1)**2 + XRL2=XRR2 + GLIJ=(T3I*ZMIXC(IZID1,2)-TANW*(T3I-EI)*ZMIXC(IZID1,1))* + & DCONJG(T3I*ZMIXC(IZID2,2)-TANW*(T3I-EI)*ZMIXC(IZID2,1)) + GRIJ=ZMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1))*(EI*TANW)**2 + XM1M2=SMZ(IZID1)*SMZ(IZID2) + QLLS=DCMPLX((T3I-EI*XW)/XW1)*OLPP + QLLU=-GLIJ + QLRS=-DCMPLX((T3I-EI*XW)/XW1)*ORPP + QLRT=DCONJG(GLIJ) + QRLS=-DCMPLX((EI*XW)/XW1)*OLPP + QRLT=GRIJ + QRRS=DCMPLX((EI*XW)/XW1)*ORPP + QRRU=-DCONJG(GRIJ) + ELSEIF(IZID1*IWID2.NE.0.OR.IZID2*IWID1.NE.0) THEN + IF(IZID1.NE.0) THEN + XM1M2=SMZ(IZID1)*SMW(IWID2) + IZID1=IWID2 + IZID2=IZID1 + ELSE + XM1M2=SMZ(IZID2)*SMW(IWID1) + IZID1=IWID1 + ENDIF + RT2I = 1D0/SQRT(2D0) + SQMZ=PMAS(24,1)**2 + GMMZ=PMAS(24,1)*PMAS(24,2) + DO 120 I=1,2 + VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I)) + UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I)) + 120 CONTINUE + DO 130 I=1,4 + ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I)) + 130 CONTINUE + QLLS=(DCONJG(ZMIXC(IZID2,2))*VMIXC(IZID1,1)- + & DCONJG(ZMIXC(IZID2,4))*VMIXC(IZID1,2)*RT2I) + QLRS=(ZMIXC(IZID2,2)*DCONJG(UMIXC(IZID1,1))+ + & ZMIXC(IZID2,3)*DCONJG(UMIXC(IZID1,2))*RT2I) + EJ=KCHG(IABS(JA),1)/3D0 + T3J=SIGN(1D0,EJ+1D-6)/2D0 + QRLS=DCMPLX(0D0,0D0) + QRLT=QRLS + QRRS=QRLS + QRRU=QRLS + XRR2=1D6**2 + XRL2=XRR2 + XLR2 = PMAS(PYCOMP(KSUSY1+IABS(JA)),1)**2 + XLL2 = PMAS(PYCOMP(KSUSY1+IABS(IA)),1)**2 + IF(MOD(IA,2).EQ.0) THEN + QLLU=VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EI-T3I)* + & TANW+ZMIXC(IZID2,2)*T3I) + QLRT=-DCONJG(UMIXC(IZID1,1))*( + & ZMIXC(IZID2,1)*(EJ-T3J)*TANW+ZMIXC(IZID2,2)*T3J) + ELSE + QLLU=VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EJ-T3J)* + & TANW+ZMIXC(IZID2,2)*T3J) + QLRT=-DCONJG(UMIXC(IZID1,1))*( + & ZMIXC(IZID2,1)*(EI-T3I)*TANW+ZMIXC(IZID2,2)*T3I) + ENDIF + ELSEIF(IWID1*IWID2.NE.0) THEN + IZID1=IWID1 + IZID2=IWID2 + XM1M2=SMW(IWID1)*SMW(IWID2) + SQMZ=PMAS(23,1)**2 + GMMZ=PMAS(23,1)*PMAS(23,2) + DO 140 I=1,2 + VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I)) + UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I)) + VMIXC(IZID2,I)=DCMPLX(VMIX(IZID2,I),VMIXI(IZID2,I)) + UMIXC(IZID2,I)=DCMPLX(UMIX(IZID2,I),UMIXI(IZID2,I)) + 140 CONTINUE + OLPP=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))- + & VMIXC(IZID2,2)*DCONJG(VMIXC(IZID1,2))/2D0 + ORPP=-UMIXC(IZID1,1)*DCONJG(UMIXC(IZID2,1))- + & UMIXC(IZID1,2)*DCONJG(UMIXC(IZID2,2))/2D0 + QRLS=-DCMPLX(EI/XW1)*ORPP + QLLS=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP + QRRS=-DCMPLX(EI/XW1)*OLPP + QLRS=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP + IF(MOD(IA,2).EQ.0) THEN + XLR2=PMAS(PYCOMP(KSUSY1+IABS(IA)-1),1)**2 + QLRT=-UMIXC(IZID2,1)*DCONJG(UMIXC(IZID1,1))*DCMPLX(T3I/XW) + ELSE + XLR2=PMAS(PYCOMP(KSUSY1+IABS(IA)+1),1)**2 + QLRT=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))*DCMPLX(T3I/XW) + ENDIF + ELSEIF(MOD(K(N+1,2),KSUSY1).EQ.21.OR.MOD(K(ID,2),KSUSY1).EQ.21) + &THEN + ISKIP=0 + ELSE + ISKIP=0 + ENDIF + + IF(ISKIP.NE.0) THEN + WTMAX=0D0 + DO 160 KT=1,100 + S12=S12MIN+YJACO1*(KT-1)/99 + S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2) + & *(S12+XM(3)**2-XM(5)**2)/(2D0*S12) + S23DF1=(S12-XM(2)**2-XM(1)**2)**2 + & -(2D0*XM(1)*XM(2))**2 + S23DF2=(S12-XM(3)**2-XM(5)**2)**2 + & -(2D0*XM(3)*XM(5))**2 + S23DF1=S23DF1*EPS + S23DF2=S23DF2*EPS + S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*S12) + S23DEL=S23DEL/EPS + S23MIN=S23AVE-S23DEL + S23MAX=S23AVE+S23DEL + YJACO2=S23MAX-S23MIN + TH=S12 + DO 150 KS=1,100 + S23=S23MIN+YJACO2*(KS-1)/99 + SH=S23 + UH=ZM12+ZM22-SH-TH + WU2 = (UH-ZM12)*(UH-ZM22) + WT2 = (TH-ZM12)*(TH-ZM22) + WS2 = XM1M2*SH + PROPZ2 = (SH-SQMZ)**2 + GMMZ**2 + PROPZ=DCMPLX(SH-SQMZ,-GMMZ)/DCMPLX(PROPZ2) + QLL=QLLS*PROPZ+QLLU/DCMPLX(UH-XLL2) + QLR=QLRS*PROPZ+QLRT/DCMPLX(TH-XLR2) + QRL=QRLS*PROPZ+QRLT/DCMPLX(TH-XRL2) + QRR=QRRS*PROPZ+QRRU/DCMPLX(UH-XRR2) + WT0=-((ABS(QLL)**2+ABS(QRR)**2)*WU2+ + & (ABS(QRL)**2+ABS(QLR)**2)*WT2+ + & 2D0*DBLE(QLR*DCONJG(QLL)+QRL*DCONJG(QRR))*WS2) + IF(WT0.GT.WTMAX) WTMAX=WT0 + 150 CONTINUE + 160 CONTINUE + + WTMAX=WTMAX*1.05D0 + ENDIF + +C...FIND S12* + AX=S12MIN + CX=S12MAX + BX=S12MIN+0.5D0*YJACO1 + X0=AX + X3=CX + IF(ABS(CX-BX).GT.ABS(BX-AX))THEN + X1=BX + X2=BX+C*(CX-BX) + ELSE + X2=BX + X1=BX-C*(BX-AX) + ENDIF + +C...SOLVE FOR F1 AND F2 + S23DF1=(X1-XM(2)**2-XM(1)**2)**2 + &-(2D0*XM(1)*XM(2))**2 + S23DF2=(X1-XM(3)**2-XM(5)**2)**2 + &-(2D0*XM(3)*XM(5))**2 + S23DF1=S23DF1*EPS + S23DF2=S23DF2*EPS + S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X1) + F1=-2D0*S23DEL/EPS + S23DF1=(X2-XM(2)**2-XM(1)**2)**2 + &-(2D0*XM(1)*XM(2))**2 + S23DF2=(X2-XM(3)**2-XM(5)**2)**2 + &-(2D0*XM(3)*XM(5))**2 + S23DF1=S23DF1*EPS + S23DF2=S23DF2*EPS + S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X2) + F2=-2D0*S23DEL/EPS + + 170 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2)))THEN +C...Possibility of infinite loop with .LT.; changed to .LE. (SKANDS) + IF(F2.LE.F1)THEN + X0=X1 + X1=X2 + X2=R*X1+C*X3 + F1=F2 + S23DF1=(X2-XM(2)**2-XM(1)**2)**2 + & -(2D0*XM(1)*XM(2))**2 + S23DF2=(X2-XM(3)**2-XM(5)**2)**2 + & -(2D0*XM(3)*XM(5))**2 + S23DF1=S23DF1*EPS + S23DF2=S23DF2*EPS + S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X2) + F2=-2D0*S23DEL/EPS + ELSE + X3=X2 + X2=X1 + X1=R*X2+C*X0 + F2=F1 + S23DF1=(X1-XM(2)**2-XM(1)**2)**2 + & -(2D0*XM(1)*XM(2))**2 + S23DF2=(X1-XM(3)**2-XM(5)**2)**2 + & -(2D0*XM(3)*XM(5))**2 + S23DF1=S23DF1*EPS + S23DF2=S23DF2*EPS + S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X1) + F1=-2D0*S23DEL/EPS + ENDIF + GOTO 170 + ENDIF +C...WE WANT THE MAXIMUM, NOT THE MINIMUM + IF(F1.LT.F2)THEN + GOLDEN=-F1 + XMIN=X1 + ELSE + GOLDEN=-F2 + XMIN=X2 + ENDIF + + IKNT=0 + 180 S12=S12MIN+PYR(0)*YJACO1 + IKNT=IKNT+1 +C...GENERATE S23 + S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2) + &*(S12+XM(3)**2-XM(5)**2)/(2D0*S12) + S23DF1=(S12-XM(2)**2-XM(1)**2)**2 + &-(2D0*XM(1)*XM(2))**2 + S23DF2=(S12-XM(3)**2-XM(5)**2)**2 + &-(2D0*XM(3)*XM(5))**2 + S23DF1=S23DF1*EPS + S23DF2=S23DF2*EPS + S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*S12) + S23DEL=S23DEL/EPS + S23MIN=S23AVE-S23DEL + S23MAX=S23AVE+S23DEL + YJACO2=S23MAX-S23MIN + S23=S23MIN+PYR(0)*YJACO2 + +C...CHECK THE SAMPLING + IF(IKNT.GT.100) THEN + WRITE(MSTU(11),*) ' IKNT > 100 IN PYTBDY ' + GOTO 190 + ENDIF + IF(YJACO2.LT.PYR(0)*GOLDEN) GOTO 180 + + IF(ISKIP.EQ.0) GOTO 190 + + SH=S23 + TH=S12 + UH=ZM12+ZM22-SH-TH + + WU2 = (UH-ZM12)*(UH-ZM22) + WT2 = (TH-ZM12)*(TH-ZM22) + WS2 = XM1M2*SH + PROPZ2 = (SH-SQMZ)**2 + GMMZ**2 + PROPZ=DCMPLX(SH-SQMZ,-GMMZ)/DCMPLX(PROPZ2) + + QLL=QLLS*PROPZ+QLLU/DCMPLX(UH-XLL2) + QLR=QLRS*PROPZ+QLRT/DCMPLX(TH-XLR2) + QRL=QRLS*PROPZ+QRLT/DCMPLX(TH-XRL2) + QRR=QRRS*PROPZ+QRRU/DCMPLX(UH-XRR2) +c QLL=DCMPLX((T3I-EI*XW)/XW1)*OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2) +c QLR=-DCMPLX((T3I-EI*XW)/XW1)*ORPP*PROPZ+DCONJG(GLIJ) +c &/DCMPLX(TH-XML2) +c QRL=-DCMPLX((EI*XW)/XW1)*OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2) +c QRR=DCMPLX((EI*XW)/XW1)*ORPP*PROPZ +c &-DCONJG(GRIJ)/DCMPLX(UH-XMR2) + WT=-((ABS(QLL)**2+ABS(QRR)**2)*WU2+ + &(ABS(QRL)**2+ABS(QLR)**2)*WT2+ + &2D0*DBLE(QLR*DCONJG(QLL)+QRL*DCONJG(QRR))*WS2) + + IF(WT.LT.PYR(0)*WTMAX) GOTO 180 + IF(WT.GT.WTMAX) PRINT*,' WT > WTMAX ',WT,WTMAX + + 190 D3=(XM(5)**2+XM(3)**2-S12)/(2D0*XM(5)) + D1=(XM(5)**2+XM(1)**2-S23)/(2D0*XM(5)) + D2=XM(5)-D1-D3 + P1=SQRT(D1*D1-XM(1)**2) + P2=SQRT(D2*D2-XM(2)**2) + P3=SQRT(D3*D3-XM(3)**2) + CTHE1=2D0*PYR(0)-1D0 + ANG1=2D0*PYR(0)*PARU(1) + CPHI1=COS(ANG1) + SPHI1=SIN(ANG1) + ARG=1D0-CTHE1**2 + IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0 + STHE1=SQRT(ARG) + P(N+1,1)=P1*STHE1*CPHI1 + P(N+1,2)=P1*STHE1*SPHI1 + P(N+1,3)=P1*CTHE1 + P(N+1,4)=D1 + +C...GET CPHI3 + ANG3=2D0*PYR(0)*PARU(1) + CPHI3=COS(ANG3) + SPHI3=SIN(ANG3) + CTHE3=(P2**2-P1**2-P3**2)/2D0/P1/P3 + ARG=1D0-CTHE3**2 + IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0 + STHE3=SQRT(ARG) + P(N+3,1)=-P3*STHE3*CPHI3*CTHE1*CPHI1 + &+P3*STHE3*SPHI3*SPHI1 + &+P3*CTHE3*STHE1*CPHI1 + P(N+3,2)=-P3*STHE3*CPHI3*CTHE1*SPHI1 + &-P3*STHE3*SPHI3*CPHI1 + &+P3*CTHE3*STHE1*SPHI1 + P(N+3,3)=P3*STHE3*CPHI3*STHE1 + &+P3*CTHE3*CTHE1 + P(N+3,4)=D3 + + DO 200 I=1,3 + P(N+2,I)=-P(N+1,I)-P(N+3,I) + 200 CONTINUE + P(N+2,4)=D2 + + RETURN + END + + +C********************************************************************* + +C...PYTECM +C...Finds the s-hat dependent eigenvalues of the inverse propagator +C...matrix for gamma, Z, techni-rho, and techni-omega to optimize the +C...phase space generation. Extended to include techni-a meson, and +C...to return the width. + + SUBROUTINE PYTECM(SMIN,SMOU,WIDO,IOPT) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYTCSM/ITCM(0:99),RTCM(0:99) + SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYTCSM/ + +C...Local variables. + DOUBLE PRECISION AR(5,5),WR(5),ZR(5,5),ZI(5,5),WORK(12,12), + &AT(5,5),WI(5),FV1(5),FV2(5),FV3(5),SH,AEM,TANW,CT2W,QUPD,ALPRHT, + &FAR,FAO,FZR,FZO,SHR,R1,R2,S1,S2,WDTP(0:400),WDTE(0:400,0:5),WX(5) + INTEGER i,j,ierr + + SH=SMIN + SHR=SQRT(SH) + AEM=PYALEM(SH) + + SINW=MIN(SQRT(PARU(102)),1D0) + COSW=SQRT(1D0-SINW**2) + TANW=SINW/COSW + CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW) + QUPD=2D0*RTCM(2)-1D0 + + ALPRHT=2.16D0*(3D0/DBLE(ITCM(1))) + FAR=SQRT(AEM/ALPRHT) + FAO=FAR*QUPD + FZR=FAR*CT2W + FZO=-FAO*TANW + FZX=-FAR/RTCM(47)/(2D0*SINW*COSW) + FWR=FAR/(2D0*SINW) + FWX=-FWR/RTCM(47) + + DO 110 I=1,5 + DO 100 J=1,5 + AT(I,J)=0D0 + 100 CONTINUE + 110 CONTINUE + +C...NC + IF(IOPT.EQ.1) THEN + AR(1,1) = SH + AR(2,2) = SH-PMAS(23,1)**2 + AR(3,3) = SH-PMAS(PYCOMP(KTECHN+113),1)**2 + AR(4,4) = SH-PMAS(PYCOMP(KTECHN+223),1)**2 + AR(5,5) = SH-PMAS(PYCOMP(KTECHN+115),1)**2 + AR(1,2) = 0D0 + AR(2,1) = 0D0 + AR(1,3) = SH*FAR + AR(3,1) = AR(1,3) + AR(1,4) = SH*FAO + AR(4,1) = AR(1,4) + AR(2,3) = SH*FZR + AR(3,2) = AR(2,3) + AR(2,4) = SH*FZO + AR(4,2) = AR(2,4) + AR(3,4) = 0D0 + AR(4,3) = 0D0 + AR(2,5) = SH*FZX + AR(5,2) = AR(2,5) + AR(1,5) = 0D0 + AR(5,1) = AR(1,5) + AR(3,5) = 0D0 + AR(5,3) = AR(3,5) + AR(4,5) = 0D0 + AR(5,4) = AR(4,5) + CALL PYWIDT(23,SH,WDTP,WDTE) + AT(2,2) = WDTP(0)*SHR + CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE) + AT(3,3) = WDTP(0)*SHR + CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE) + AT(4,4) = WDTP(0)*SHR + CALL PYWIDT(KTECHN+115,SH,WDTP,WDTE) + AT(5,5) = WDTP(0)*SHR + IDIM=5 +C...CC + ELSE + AR(1,1) = SH-PMAS(24,1)**2 + AR(2,2) = SH-PMAS(PYCOMP(KTECHN+213),1)**2 + AR(3,3) = SH-PMAS(PYCOMP(KTECHN+215),1)**2 + AR(1,2) = SH*FWR + AR(2,1) = AR(1,2) + AR(1,3) = SH*FWX + AR(3,1) = AR(1,3) + AR(2,3) = 0D0 + AR(3,2) = 0D0 + CALL PYWIDT(24,SH,WDTP,WDTE) + AT(1,1) = WDTP(0)*SHR + CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE) + AT(2,2) = WDTP(0)*SHR + CALL PYWIDT(KTECHN+215,SH,WDTP,WDTE) + AT(3,3) = WDTP(0)*SHR + IDIM=3 + ENDIF + CALL PYEICG(IDIM,IDIM,AR,AT,WR,WI,0,ZR,ZI,FV1,FV2,FV3,IERR) + + IMIN=1 + SXMN=1D20 + DO 120 I=1,IDIM + WX(I)=SQRT(ABS(SH-WR(I))) + WR(I)=ABS(WR(I)) + IF(WR(I).LT.SXMN) THEN + SXMN=WR(I) + IMIN=I + ENDIF + 120 CONTINUE + SMOU=WX(IMIN)**2 + WIDO=WI(IMIN)/SHR + + RETURN + END +C********************************************************************* + +C...PYXDIN +C...Universal Extra Dimensions Model (UED) +C...Initialize the xd masses and widths +C...M. ELKACIMI 4/03/2006 +C...Modified for inclusion in Pythia Apr 2008, H. Przysiezniak, P. Skands + + SUBROUTINE PYXDIN + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) +C...UED Pythia common + COMMON/PYPUED/IUED(0:99),RUED(0:99) + +C...SAVE statements + SAVE /PYDAT1/,/PYDAT3/,/PYSUBS/,/PYPUED/ + +C...Print out some info about the UED model + WRITE(MSTU(11),7000) + & ' ', + & '********** PYXDIN: initialization of UED ******************', + & ' ', + & 'Universal Extra Dimensions (UED) switched on ', + & ' ', + & 'This implementation is courtesy of', + & ' M.Elkacimi, D.Goujdami, H.Przysiezniak, ', + & ' see [hep-ph/0602198] (Les Houches 2005) ', + & ' ', + & 'The model follows [hep-ph/0012100] (Appelquist, Cheng, ', + & 'Dobrescu), with gravity-mediated decay widths calculated in', + & '[hep-ph/0001335] (DeRujula, Donini, Gavela, Rigolin) and ', + & 'radiative corrections to the KK masses from [hep/ph0204342]', + & '(Cheng, Matchev, Schmaltz).' + WRITE(MSTU(11),7000) + & ' ', + & 'SM particles can propagate into one small extra dimension ', + & 'of size 1/R = RUED(1) GeV. For gravity-mediated decays, the', + & 'graviton is further allowed to propagate into N = IUED(4)', + & 'large (eV^-1) extra dimensions.' + WRITE(MSTU(11),7000) + & ' ', + & 'The switches and parameters for UED are:', + & ' IUED(1): (D=0) main UED ON(=1)/OFF(=0) switch ', + & ' IUED(2): (D=0) Grav. med. decays are set ON(=1)/OFF(=0)', + & ' IUED(3): (D=5) number of quark flavours', + & ' IUED(4): (D=6) number of large extra dimensions into', + & ' which the graviton propagates', + & ' IUED(5): (D=0) Lambda (=0) or Lambda*R (=1) is used', + & ' IUED(6): (D=1) With/without rad.corrs. (=1/0)', + & ' ', + & ' RUED(1): (D=1000.) curvature 1/R of the UED (in GeV)', + & ' RUED(2): (D=5000.) gravity mediated (GM) scale (in GeV)', + & ' RUED(3): (D=20000.) Lambda cutoff scale (in GeV). Used', + & ' when IUED(5)=0', + & ' RUED(4): (D=20.) Lambda*R. Used when IUED(5)=1' + WRITE(MSTU(11),7000) + & ' ', + & 'N.B.: the Higgs mass is also a free parameter of the UED ', + & 'model, but is set through pmas(25,1).', + & ' ' + +C...Hardcoded switch, required by current implementation + CALL PYGIVE('MSTP(42)=0') + +C...Turn the gravity mediated decay (for the KK pphoton) ON or OFF + IF(IUED(2).EQ.0) CALL PYGIVE('MDCY(C5100022,1)=0') + +C...Calculated the radiative corrections to the KK particle masses + CALL PYUEDC + +C...Initialize the graviton mass +C...only if the KK particles decays gravitationally + IF(IUED(2).EQ.1) CALL PYGRAM(0) + + WRITE(MSTU(11),7000) + & '********** PYXDIN: UED initialization completed ***********' + +C...Format to use for comments + 7000 FORMAT(' * ',A) + + RETURN + END +C********************************************************************* + +C...PYUEDC +C...Auxiliary to PYXDIN +C...Mass kk states radiative corrections +C...Radiative corrections are included (hep/ph0204342) + + SUBROUTINE PYUEDC + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP + + PARAMETER(KKPART=25,KKFLA=450) + +C...UED Pythia common + COMMON/PYPUED/IUED(0:99),RUED(0:99) +C...Pythia common: particles properties + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) +C...Parameters. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) +C...Decay information. + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) +C...Resonance width and secondary decay treatment. + COMMON/PYINT4/MWID(500),WIDS(500,5) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + +C...Local variables + DOUBLE PRECISION PI,QUP,QDW + DOUBLE PRECISION WDTP,WDTE + DIMENSION WDTP(0:400),WDTE(0:400,0:5) + DOUBLE PRECISION Q2,ALPHEM,ALPHS,SW2,CW2,RMKK,RMKK2,ZETA3 + DOUBLE PRECISION DSMG2,LOGLAM,DBMG2 + DOUBLE PRECISION DBMQU,DBMQD,DBMQDO,DBMLDO,DBMLE + DOUBLE PRECISION DSMA2,DSMB2,DBMA2,DBMB2 + DOUBLE PRECISION RFACT,RMW,RMZ,RMZ2,RMW2,A,B,C,SQRDEL,DMB2,DMA2 + DOUBLE PRECISION SWW1,CWW1 + DOUBLE PRECISION RMGST,RMPHST,RMZST,RMWST + DOUBLE PRECISION RMDQST,RMSQUS,RMSQDS,RMLSLD,RMLSLE + DOUBLE PRECISION SW21,CW21,SW021,CW021 + COMMON/SW1/SW021,CW021 +C...UED related declarations: +C...equivalences between ordered particles (451->475) +C...and UED particle code (5 000 000 + id) + DIMENSION IUEDEQ(475) + DATA (IUEDEQ(I),I=451,475)/ +C...Singlet quarks + & 6100001,6100002,6100003,6100004,6100005,6100006, +C...Doublet quarks + & 5100001,5100002,5100003,5100004,5100005,5100006, +C...Singlet leptons + & 6100011,6100013,6100015, +C...Doublet leptons + & 5100012,5100011,5100014,5100013,5100016,5100015, +C...Gauge boson KK excitations + & 5100021,5100022,5100023,5100024/ + +C...N.B. rinv=rued(1) + IF(RUED(1).LE.0.)THEN + WRITE(MSTU(11),*) 'PYUEDC: RINV < 0 : ',RUED(1) + WRITE(MSTU(11),*) 'DEFAULT KK STATE MASSES ARE TAKEN ' + RETURN + ENDIF + + PI=DACOS(-1.D0) + RMZ = PMAS(23,1) + RMZ2 = RMZ**2 + RMW = PMAS(24,1) + RMW2 = RMW**2 + ALPHEM = PARU(101) + QUP = 2./3. + QDW = -1./3. + +c...qt is q-tilde, qs is q-star +c...strong coupling value + Q2 = RUED(1)**2 + ALPHS=PYALPS(Q2) + +c...weak mixing angle + SW2=PARU(102) + CW2=1D0-PARU(102) + +c...for the mass corrections + RMKK = RUED(1) + RMKK2 = RMKK**2 + ZETA3= 1.2 + +C... Either fix the cutoff scale LAMUED + IF(IUED(5).EQ.0)THEN + LOGLAM = DLOG((RUED(3)*(1./RUED(1)))**2) +C... or the ratio LAMUED/RINV (=product Lambda*R) + ELSEIF(IUED(5).EQ.1)THEN + LOGLAM = DLOG(RUED(4)**2) + ELSE + WRITE(MSTU(11),*) '(PYUEDC:) INVALID VALUE FOR IUED(5)' + CALL PYSTOP(6000) + ENDIF + +C...Calculate the radiative corrections for the UED KK masses + IF(IUED(6).EQ.1)THEN + RFACT=1.D0 +C...or induce a minute mass difference +C...keeping the UED KK mass values nearly equal to 1/R + ELSEIF(IUED(6).EQ.0)THEN + RFACT=0.01D0 + ELSE + WRITE(MSTU(11),*) '(PYUEDC:) INVALID VALUE FOR IUED(6)' + CALL PYSTOP(6001) + ENDIF + +c...Take into account only the strong interactions: + +c...The space bulk corrections : + DSMG2 = RMKK2*(-1.5)*(ALPHS/4./PI)*ZETA3/PI**2 +c...The boundary terms: + DBMG2 = RMKK2*(23./2.)*(ALPHS/4./PI)*LOGLAM + +c...Mass corrections for fermions are extracted from +c...Phys. Rev. D66 036005(2002)9 + DBMQDO=RMKK*(3.*(ALPHS/4./PI)+27./16.*(ALPHEM/4./PI/SW2) + . +1./16.*(ALPHEM/4./PI/CW2))*LOGLAM + DBMQU=RMKK*(3.*(ALPHS/4./PI) + . +(ALPHEM/4./PI/CW2))*LOGLAM + DBMQD=RMKK*(3.*(ALPHS/4./PI) + . +0.25*(ALPHEM/4./PI/CW2))*LOGLAM + + DBMLDO=RMKK *((27./16.)*(ALPHEM/4./PI/SW2)+9./16.* + . (ALPHEM/4./PI/CW2))*LOGLAM + DBMLE=RMKK *(9./4.*(ALPHEM/4./PI/CW2))*LOGLAM + +c...Vector boson masss matrix diagonalization + DBMB2 = RMKK2*(-1./6.)*(ALPHEM/4./PI/CW2)*LOGLAM + DSMB2 = RMKK2*(-39./2.)*(ALPHEM/4./PI**3/CW2)*ZETA3 + DBMA2 = RMKK2*(15./2.)*(ALPHEM/4./PI/SW2)*LOGLAM + DSMA2 = RMKK2*(-5./2.)*(ALPHEM/4./PI**3/SW2)*ZETA3 + +c...Elements of the mass matrix + A = RMZ2*SW2 + DBMB2 + DSMB2 + B = RMZ2*CW2 + DBMA2 + DSMA2 + C = RMZ2*DSQRT(SW2*CW2) + SQRDEL = DSQRT( (A-B)**2 + 4*C**2 ) + +c...Eigenvalues: corrections to X1 and Z1 masses + DMB2 = (A+B-SQRDEL)/2. + DMA2 = (A+B+SQRDEL)/2. + +c...Rotation angles + SWW1 = 2*C + CWW1 = A-B-SQRDEL +C...Weinberg angle + SW21= SWW1**2/(SWW1**2 + CWW1**2) + CW21= 1. - SW21 + + SW021=SW21 + CW021=CW21 + +c...Masses: + RMGST = RMKK+RFACT*(DSQRT(RMKK2 + DSMG2 + DBMG2)-RMKK) + + RMDQST=RMKK+RFACT*DBMQDO + RMSQUS=RMKK+RFACT*DBMQU + RMSQDS=RMKK+RFACT*DBMQD + +C...Note: MZ mass is included in ma2 + RMPHST= RMKK+RFACT*(DSQRT(RMKK2 + DMB2)-RMKK) + RMZST = RMKK+RFACT*(DSQRT(RMKK2 + DMA2)-RMKK) + RMWST = RMKK+RFACT*(DSQRT(RMKK2 + DBMA2 + DSMA2 + RMW**2)-RMKK) + + RMLSLD=RMKK+RFACT*DBMLDO + RMLSLE=RMKK+RFACT*DBMLE + + DO 100 IPART=1,5,2 + PMAS(KKFLA+IPART,1)=RMSQDS + 100 CONTINUE + DO 110 IPART=2,6,2 + PMAS(KKFLA+IPART,1)=RMSQUS + 110 CONTINUE + DO 120 IPART=7,12 + PMAS(KKFLA+IPART,1)=RMDQST + 120 CONTINUE + DO 130 IPART=13,15 + PMAS(KKFLA+IPART,1)=RMLSLE + 130 CONTINUE + DO 140 IPART=16,21 + PMAS(KKFLA+IPART,1)=RMLSLD + 140 CONTINUE + PMAS(KKFLA+22,1)=RMGST + PMAS(KKFLA+23,1)=RMPHST + PMAS(KKFLA+24,1)=RMZST + PMAS(KKFLA+25,1)=RMWST + + WRITE(MSTU(11),7000) ' PYUEDC: ', + & 'UED Mass Spectrum (GeV) :' + WRITE(MSTU(11),7100) ' m(d*_S,s*_S,b*_S) = ',RMSQDS + WRITE(MSTU(11),7100) ' m(u*_S,c*_S,t*_S) = ',RMSQUS + WRITE(MSTU(11),7100) ' m(q*_D) = ',RMDQST + WRITE(MSTU(11),7100) ' m(l*_S) = ',RMLSLE + WRITE(MSTU(11),7100) ' m(l*_D) = ',RMLSLD + WRITE(MSTU(11),7100) ' m(g*) = ',RMGST + WRITE(MSTU(11),7100) ' m(gamma*) = ',RMPHST + WRITE(MSTU(11),7100) ' m(Z*) = ',RMZST + WRITE(MSTU(11),7100) ' m(W*) = ',RMWST + WRITE(MSTU(11),7000) ' ' + +C...Initialize widths, branching ratios and life time + DO 199 IPART=1,25 + KC=KKFLA+IPART + IF(MWID(KC).EQ.1.AND.MDCY(KC,1).EQ.1)THEN + CALL PYWIDT(IUEDEQ(KC),PMAS(KC,1)**2,WDTP,WDTE) + IF(WDTP(0).LE.0)THEN + WRITE(MSTU(11),*) + + 'PYUEDC WARNING: TOTAL WIDTH = 0 --> KC ', KC + WRITE(MSTU(11),*) 'INITIAL VALUE IS TAKEN',PMAS(KC,2) + GOTO 199 + ELSE + DO 180 IDC=1,MDCY(KC,3) + IC=IDC+MDCY(KC,2)-1 + IF(MDME(IC,1).EQ.1.AND.WDTP(IDC).GT.0.)THEN +C...Life time in cm^{-1}. paru(3) gev^{-1} -> fm + PMAS(KC,4)=PARU(3)/WDTP(IDC)*1.D-12 + BRAT(IC)=WDTP(IDC)/WDTP(0) + ENDIF + 180 CONTINUE + ENDIF + ENDIF + 199 CONTINUE + +C...Format to use for comments + 7000 FORMAT(' * ',A) + 7100 FORMAT(' * ',A,F12.3) + + END +C******************************************************************** +C...PYXUED +C... Last change: +C... 13/01/2009 : H. Przysiezniak Frey, P. Skands +C... Original version: +C... M. El Kacimi +C... 05/07/2005 +C Universal Extra Dimensions Subprocess cross sections +C The expressions used are from atl-com-phys-2005-003 +C What is coded here is shat**2/pi * dsigma/dt = |M|**2 +C For each UED subprocess, the color flow used is the same +C as the equivalent QCD subprocess. Different configuration +C color flows are considered to have the same probability. +C +C The Xsection is calculated following ATL-PHYS-PUB-2005-003 +C by G.Azuelos and P.H.Beauchemin. +C +C This routine is called from pysigh. + + SUBROUTINE PYXUED(NCHN,SIGS) + +C...Double precision and integer declarations + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) +C... + INTEGER NGRDEC + COMMON/DECMOD/NGRDEC +C... + PARAMETER(KKPART=25,KKFLA=450) +C...Commonblocks + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000) + COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA, + &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4, + &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW, + &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR + SAVE /PYDAT2/,/PYINT1/,/PYINT3/,/PYPARS/ +C...UED Pythia common + COMMON/PYPUED/IUED(0:99),RUED(0:99) +C...Local arrays and complex variables + DOUBLE PRECISION SHAT,SP,THAT,TP,UHAT,UP,ALPHAS + + ,FAC1,XMNKK,XMUED,SIGS + INTEGER NCHN + +C...Return if UED not switched on + IF (IUED(1).LE.0) THEN + RETURN + ENDIF + +C...Energy scale of the parton processus +C...taken equal to the mass of the final state kk +c Q2=XMNKK**2 + +C...Default Mandlestam variable (u/t)hatp=(u/t)hatp-xmnkk**2 + XMNKK=PMAS(KKFLA+23,1) + +C...To compare the cross section with phys-pub-2005-03 +C...(no radiative corrections), +C...take xmnkk=rinv and q2=rinv**2 +c++lnk +C...n.b. (rinv=rued(1)) +c IF(NGRDEC.EQ.1)XMNKK=RUED(0) + IF(NGRDEC.EQ.1)XMNKK=RUED(1) +c--lnk + + SHAT=VINT(44) + SP=SHAT + THAT=VINT(45) + TP=THAT-XMNKK**2 + UHAT=VINT(46) + UP=UHAT-XMNKK**2 + BETA34=DSQRT(1.D0-4.D0*XMNKK**2/SHAT) + PI=DACOS(-1.D0) +c++lnk +c Q2=RUED(0)**2+(TP*UP-RUED(0)**4)/SP + Q2=RUED(1)**2+(TP*UP-RUED(1)**4)/SP + +c IF(NGRDEC.EQ.1)Q2=RUED(0)**2 + IF(NGRDEC.EQ.1)Q2=RUED(1)**2 +c--lnk + +C...Strong coupling value + ALPHAS=PYALPS(Q2) + + IF(ISUB.EQ.311)THEN +C...gg --> g* g* + FAC1=9./8.*ALPHAS**2/(SP*TP*UP)**2 + XMUED=FAC1*(XMNKK**4*(6.*TP**4+18.*TP**3*UP+ + & 24.*TP**2*UP**2+18.*TP*UP**3+6.*UP**4) + & +XMNKK**2*(6.*TP**4*UP+12.*TP**3*UP**2+ + & 12.*TP**2*UP**3+6*TP*UP**4) + & +2.*TP**6+6*TP**5*UP+13*TP**4*UP**2+ + & 15.*TP**3*UP**3+13*TP**2*UP**4+ + & 6.*TP*UP**5+2.*UP**6) + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 +C...Three color flow configurations (qcd g+g->g+g) + XCOL=PYR(0) + IF(XCOL.LE.1./3.)THEN + ISIG(NCHN,3)=1 + ELSEIF(XCOL.LE.2./3.)THEN + ISIG(NCHN,3)=2 + ELSE + ISIG(NCHN,3)=3 + ENDIF + SIGH(NCHN)=COMFAC*XMUED + ELSEIF(ISUB.EQ.312)THEN +C...q + g -> q*_D + g*, q*_S + g* +C...(the two channels have the same cross section) + FAC1=-1./36.*ALPHAS**2/(SP*TP*UP)**2 + XMUED=FAC1*(12.*SP*UP**5+5.*SP**2*UP**4+22.*SP**3*UP**3+ + & 5.*SP**4*UP**2+12.*SP**5*UP) + XMUED=COMFAC*2.*XMUED + + DO 190 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 190 + DO 180 ISDE=1,2 + + IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 180 + IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 180 + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=XMUED + IF(PYR(0).GT.0.5)ISIG(NCHN,3)=2 + 180 CONTINUE + 190 CONTINUE + + ELSEIF(ISUB.EQ.313)THEN +C...qi + qj -> q*_Di + q*_Dj, q*_Si + q*_Sj +C...(the two channels have the same cross section) +C...qi and qj have the same charge sign + DO 100 I=MMIN1,MMAX1 + IA=IABS(I) + IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 100 + DO 101 J=MMIN2,MMAX2 + JA=IABS(J) + IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J). + & EQ.0) GOTO 101 + IF(J*I.LE.0)GOTO 101 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + IF(J.EQ.I)THEN + FAC1=1./72.*ALPHAS**2/(TP*UP)**2 + XMUED=FAC1* + & (XMNKK**2*(8*TP**3+4./3.*TP**2*UP+4./3.*TP*UP**2 + & +8.*UP**3)+8.*TP**4+56./3.*TP**3*UP+ + & 20.*TP**2*UP**2+56./3.* + & TP*UP**3+8.*UP**4) + SIGH(NCHN)=COMFAC*2.*XMUED + ISIG(NCHN,3)=1 + IF(PYR(0).GT.0.5)ISIG(NCHN,3)=2 + ELSE + FAC1=2./9.*ALPHAS**2/TP**2 + XMUED=FAC1*(-XMNKK**2*SP+SP**2+0.25*TP**2) + SIGH(NCHN)=COMFAC*2.*XMUED + ISIG(NCHN,3)=1 + ENDIF + 101 CONTINUE + 100 CONTINUE + ELSEIF(ISUB.EQ.314)THEN +C...g + g -> q*_D + q*_Dbar, q*_S + q*_Sbar +C...(the two channels have the same cross section) + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=INT(1.5+PYR(0)) + + FAC1=5./6.*ALPHAS**2/(SP*TP*UP)**2 + XMUED=FAC1*(-XMNKK**4*(8.*TP*UP**3+8.*TP**2*UP**2+8.*TP**3*UP + + +4.*UP**4+4*TP**4) + + -XMNKK**2*(0.5*TP*UP**4+4.*TP**2*UP**3+15./2.*TP**3 + + *UP**2+ 4.*TP**4*UP)+TP*UP**5-0.25*TP**2*UP**4+ + + 2.*TP**3*UP**3-0.25*TP**4*UP**2+TP**5*UP) + + SIGH(NCHN)=COMFAC*XMUED +C...has been multiplied by 5: all possible quark flavors in final state + + ELSEIF(ISUB.EQ.315)THEN +C...q + qbar -> q*_D + q*_Dbar, q*_S + q*_Sbar +C...(the two channels have the same cross section) + DO 141 I=MMIN1,MMAX1 + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR. + & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 141 + DO 142 J=MMIN2,MMAX2 + IF(J.EQ.0.OR.ABS(I).NE.ABS(J).OR.I*J.GE.0) GOTO 142 + FAC1=2./9.*ALPHAS**2*1./(SP*TP)**2 + XMUED=FAC1*(XMNKK**2*SP*(4.*TP**2-SP*TP-SP**2)+ + & 4.*TP**4+3.*SP*TP**3+11./12.*TP**2*SP**2- + & 2./3.*SP**3*TP+SP**4) + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=COMFAC*2.*XMUED + 142 CONTINUE + 141 CONTINUE + ELSEIF(ISUB.EQ.316)THEN +C...q + qbar' -> q*_D + q*_Sbar' + FAC1=2./9.*ALPHAS**2 + DO 300 I=MMIN1,MMAX1 + IA=IABS(I) + IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 300 + DO 301 J=MMIN2,MMAX2 + JA=IABS(J) + IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 301 + IF(J*I.GE.0.OR.IA.EQ.JA)GOTO 301 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + FAC1=2./9.*ALPHAS**2/TP**2 + XMUED=FAC1*(-XMNKK**2*SP+SP**2+0.25*TP**2) + SIGH(NCHN)=COMFAC*XMUED + 301 CONTINUE + 300 CONTINUE + + ELSEIF(ISUB.EQ.317)THEN +C...q + qbar' -> q*_D + q*_Dbar' , q*_S + q*_Sbar' +C...(the two channels have the same cross section) + DO 400 I=MMIN1,MMAX1 + IA=IABS(I) + IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 400 + DO 401 J=MMIN1,MMAX1 + JA=IABS(J) + IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 401 + IF(J*I.GE.0.OR.IA.EQ.JA)GOTO 401 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + FAC1=1./18.*ALPHAS**2/TP**2 + XMUED=FAC1*(4.*XMNKK**2*SP+4.*SP**2+8.*SP*TP+5*TP**2) + SIGH(NCHN)=COMFAC*2.*XMUED + 401 CONTINUE + 400 CONTINUE + ELSEIF(ISUB.EQ.318)THEN +C...q + q' -> q*_D + q*_S' + DO 500 I=MMIN1,MMAX1 + IA=IABS(I) + IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 500 + DO 501 J=MMIN2,MMAX2 + JA=IABS(J) + IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 501 + IF(J*I.LE.0)GOTO 501 + IF(IA.EQ.JA)THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=INT(1.5+PYR(0)) + FAC1=1./36.*ALPHAS**2/(TP*UP)**2 + XMUED=FAC1*(-8.*XMNKK**2*(TP**3+TP**2*UP+TP*UP**2+UP**3) + & +8.*TP**4+4.*TP**2*UP**2+8.*UP**4) + SIGH(NCHN)=COMFAC*XMUED + ELSE + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + FAC1=1./18.*ALPHAS**2/TP**2 + XMUED=FAC1*(4.*XMNKK**2*SP+4.*SP**2+8.*SP*TP+5*TP**2) + SIGH(NCHN)=COMFAC*2.*XMUED + ENDIF + 501 CONTINUE + 500 CONTINUE + ELSEIF(ISUB.EQ.319)THEN +C...q + qbar -> q*_D' +q*_Dbar' , q*_S' + q*_Sbar' +C...(the two channels have the same cross section) + DO 741 I=MMIN1,MMAX1 + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR. + & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 741 + DO 742 J=MMIN2,MMAX2 + IF(J.EQ.0.OR.IABS(J).NE.IABS(I).OR.J*I.GT.0) GOTO 742 + FAC1=16./9.*ALPHAS**2*1./(SP)**2 + XMUED=FAC1*(2.*XMNKK**2*SP+SP**2+2.*SP*TP+2.*TP**2) + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=COMFAC*2.*XMUED + 742 CONTINUE + 741 CONTINUE + + ENDIF + + RETURN + END +C********************************************************************* + +C...PYGRAM +C...Universal Extra Dimensions Model (UED) +C...Computation of the Graviton mass. + + SUBROUTINE PYGRAM(IN) + +C...Double precision and integer declarations + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + +C...Pythia commonblocks + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) +C...UED Pythia common + COMMON/PYPUED/IUED(0:99),RUED(0:99) + +C...Local variables + INTEGER KCFLA,NMAX + PARAMETER(KCFLA=450,NMAX=5000) + DIMENSION YVEC(5000),RESVEC(5000) + COMMON/INTSAV/YSAV,YMAX,RESMAX + COMMON/UEDGRA/XMPLNK,XMD,RINV,NDIM + COMMON/KAPPA/XKAPPA + +C...External function (used in call to PYGAUS) + EXTERNAL PYGRAW + +C...SAVE statements + SAVE /PYDAT1/,/PYDAT2/,/PYPUED/,/INTSAV/ + +C...Initialization + NDIM=IUED(4) + RINV=RUED(1) + XMD=RUED(2) + PI=PARU(1) + +C...Initialize for numerical integration + XMPLNK=2.4D+18 + XKAPPA=DSQRT(2.D0)/XMPLNK + +C...For NDIM=2, compute graviton mass distribution numerically + IF(NDIM.EQ.2)THEN + +C... For first event: tabulate distribution of stepwise integrals: +C... int_y1^y2 dy dGamma/dy , with y = MG*/MgammaKK + IF(IN.EQ.0)THEN + RESMAX = 0D0 + YMAX = 0D0 + DO 100 I=1,NMAX + YSAV = (I-0.5)/DBLE(NMAX) + TOL = 1D-6 +C...Integral of PYGRAW from 0 to 1, with precision TOL, for given YSAV + RESINT = PYGAUS(PYGRAW,0D0,1D0,TOL) + YVEC(I) = YSAV + RESVEC(I) = RESINT +C... Save max of distribution (for accept/reject below) + IF(RESINT.GT.RESMAX)THEN + RESMAX = RESINT + YMAX = YVEC(I) + ENDIF + 100 CONTINUE + ENDIF + +C... Generate Mg for each graviton (1D0 ensures a minimal open phase space) + PCUJET=1D0 + KCGAKK=KCFLA+23 + XMGAMK=PMAS(KCGAKK,1) + +C... Pick random graviton mass, accept according to stored integrals + AMMAX=DSQRT(XMGAMK**2-2D0*XMGAMK*PCUJET) + 110 RMG=AMMAX*PYR(0) + X=RMG/XMGAMK + +C... Bin enumeration starts at 1, but make sure always in range + IBIN=INT(NMAX*X)+1 + IBIN=MIN(IBIN,NMAX) + IF(RESVEC(IBIN)/RESMAX.LT.PYR(0)) GOTO 110 + +C... For NDIM=4 and 6, the analytical expression for the +C... graviton mass distribution integral is used. + ELSEIF(NDIM.EQ.4.OR.NDIM.EQ.6)THEN + +C... Ensure minimal open phase space (max(mG*) < m(gamma*)) + PCUJET=1D0 + +C... KK photon (?) compressed code and mass + KCGAKK=KCFLA+23 + XMGAMK=PMAS(KCGAKK,1) + +C... Find maximum of (dGamma/dMg) + IF(IN.EQ.0)THEN + RESMAX=0D0 + YMAX=0D0 + DO 120 I=1,NMAX-1 + Y=I/DBLE(NMAX) + RESINT=Y**(NDIM-3)*(1D0/(1D0-Y**2))*(1D0+DCOS(PI*Y)) + IF(RESINT.GE.RESMAX)THEN + RESMAX=RESINT + YMAX=Y + ENDIF + 120 CONTINUE + ENDIF + +C... Pick random graviton mass, accept/reject + AMMAX=DSQRT(XMGAMK**2-2D0*XMGAMK*PCUJET) + 130 RMG=AMMAX*PYR(0) + X=RMG/XMGAMK + DGADMG=X**(NDIM-3)*(1./(1.-X**2))*(1.+DCOS(PI*X)) + IF(DGADMG/RESMAX.LT.PYR(0)) GOTO 130 + +C... If the user has not chosen N=2,4 or 6, STOP + ELSE + WRITE(MSTU(11),*) '(PYGRAM:) BAD VALUE N(LARGE XD) =',NDIM, + & ' (MUST BE 2, 4, OR 6) ' + CALL PYSTOP(6002) + ENDIF + +C... Now store the sampled Mg + PMAS(39,1)=RMG + + RETURN + END + +C********************************************************************* + +C...PYGRAW +C...Universal Extra Dimensions Model (UED) +C... +C...See Macesanu etal. hep-ph/0201300 eqns.31 and 34. +C... +C...Integrand for the KK boson -> SM boson + graviton +C...graviton mass distribution (and gravity mediated total width), +C...which contains (see 0201300 and below for the full product) +C...the gravity mediated partial decay width Gamma(xx, yy) +C... i.e. GRADEN(YY)*PYWDKK(XXA) +C... where xx is exclusive to gravity +C... yy=m_Graviton/m_bosonKK denotes the Universal extra dimension +C... and xxa=sqrt(xx**2+yy**2) refers to all of the extra dimensions. + + DOUBLE PRECISION FUNCTION PYGRAW(YIN) + +C...Double precision and integer declarations + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + IMPLICIT INTEGER (I-N) + +C...Pythia commonblocks + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + +C...Local UED commonblocks and variables + COMMON/UEDGRA/XMPLNK,XMD,RINV,NDIM + COMMON/INTSAV/YSAV,YMAX,RESMAX + +C...SAVE statements + SAVE /PYDAT1/,/INTSAV/ + +C...External: Pythia's Gamma function + EXTERNAL PYGAMM + +C...Pi + PI=PARU(1) + PI2=PI*PI + + YMIN=1.D-9/RINV + YY=YSAV + XX=DSQRT(1.-YY**2)*YIN + DJAC=(1.-YMIN)*DSQRT(1.-YY**2) + FAC=2.*PI**((NDIM-1.)/2.)*XMPLNK**2*RINV**NDIM/XMD**(NDIM+2) + XND=(NDIM-1.)/2. + GAMMN=PYGAMM(XND) + FAC=FAC/GAMMN + XXA=DSQRT(XX**2+YY**2) + GRADEN=4./PI2 * (YY**2/(1.-YY**2)**2)*(1.+DCOS(PI*YY)) + + PYGRAW=DJAC* + + FAC*XX**(NDIM-2)*GRADEN*PYWDKK(XXA) + + RETURN + END +C********************************************************************* + +C...PYWDKK +C...Universal Extra Dimensions Model (UED) +C... +C...Multiplied by the square modulus of a form factor +C...(see GRADEN in function PYGRAW) +C...PYWDKK is the KK boson -> SM boson + graviton +C...gravity mediated partial decay width Gamma(xx, yy) +C... where xx is exclusive to gravity +C... yy=m_Graviton/m_bosonKK denotes the Universal extra dimension +C... and xxa=sqrt(xx**2+yy**2) refers to all of the extra dimensions +C... +C...N.B. The Feynman rules for the couplings of the graviton fields +C...to the UED fields are related to the corresponding couplings of +C...the graviton fields to the SM fields by the form factor. + + DOUBLE PRECISION FUNCTION PYWDKK(X) + +C...Double precision and integer declarations + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + IMPLICIT INTEGER (I-N) + +C...Pythia commonblocks + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + +C...Local UED commonblocks and variables + COMMON/UEDGRA/XMPLNK,XMD,RINV,NDIM + COMMON/KAPPA/XKAPPA + +C...SAVE statements + SAVE /PYDAT1/,/PYDAT2/,/UEDGRA/,/KAPPA/ + + PI=PARU(1) + +C...gamma* mass 473 + KCQKK=473 + XMNKK=PMAS(KCQKK,1) + +C...Bosons partial width Macesanu hep-ph/0201300 + PYWDKK=XKAPPA**2/(96.*PI)*XMNKK**3/X**4* + + ((1.-X**2)**2*(1.+3.*X**2+6.*X**4)) + + RETURN + END + +C********************************************************************* + +C...PYEIGC +C...Finds eigenvalues of a general complex matrix +C +C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF +C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK) +C TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED) +C OF A COMPLEX GENERAL MATRIX. +C +C ON INPUT +C +C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL +C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM +C DIMENSION STATEMENT. +C +C N IS THE ORDER OF THE MATRIX A=(AR,AI). +C +C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, +C RESPECTIVELY, OF THE COMPLEX GENERAL MATRIX. +C +C MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF +C ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO +C ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS. +C +C ON OUTPUT +C +C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, +C RESPECTIVELY, OF THE EIGENVALUES. +C +C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, +C RESPECTIVELY, OF THE EIGENVECTORS IF MATZ IS NOT ZERO. +C +C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR +C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR COMQR +C AND COMQR2. THE NORMAL COMPLETION CODE IS ZERO. +C +C FV1, FV2, AND FV3 ARE TEMPORARY STORAGE ARRAYS. +C +C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, +C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY +C +C THIS VERSION DATED AUGUST 1983. +C + + SUBROUTINE PYEICG(NM,N,AR,AI,WR,WI,MATZ,ZR,ZI,FV1,FV2,FV3,IERR) + + INTEGER N,NM,IS1,IS2,IERR,MATZ + DOUBLE PRECISION AR(5,5),AI(5,5),WR(5),WI(5),ZR(5,5),ZI(5,5), + X FV1(5),FV2(5),FV3(5) + IF (N .LE. NM) GOTO 100 + IERR = 10 * N + GOTO 120 +C + 100 CALL PYCBAL(NM,N,AR,AI,IS1,IS2,FV1) + CALL PYCRTH(NM,N,IS1,IS2,AR,AI,FV2,FV3) + IF (MATZ .NE. 0) GOTO 110 +C .......... FIND EIGENVALUES ONLY .......... + CALL PYCMQR(NM,N,IS1,IS2,AR,AI,WR,WI,IERR) + GOTO 120 +C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... + 110 CALL PYCMQ2(NM,N,IS1,IS2,FV2,FV3,AR,AI,WR,WI,ZR,ZI,IERR) + IF (IERR .NE. 0) GOTO 120 + CALL PYCBA2(NM,N,IS1,IS2,FV1,N,ZR,ZI) + 120 RETURN + END + +C********************************************************************* + +C...PYCMQR +C...Auxiliary to PYEICG. +C +C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE +C ALGOL PROCEDURE COMLR, NUM. MATH. 12, 369-376(1968) BY MARTIN +C AND WILKINSON. +C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 396-403(1971). +C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS +C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM. +C +C THIS SUBROUTINE FINDS THE EIGENVALUES OF A COMPLEX +C UPPER HESSENBERG MATRIX BY THE QR METHOD. +C +C ON INPUT +C +C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL +C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM +C DIMENSION STATEMENT. +C +C N IS THE ORDER OF THE MATRIX. +C +C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING +C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED, +C SET LOW=1, IGH=N. +C +C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS, +C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX. +C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN +C INFORMATION ABOUT THE UNITARY TRANSFORMATIONS USED IN +C THE REDUCTION BY CORTH, IF PERFORMED. +C +C ON OUTPUT +C +C THE UPPER HESSENBERG PORTIONS OF HR AND HI HAVE BEEN +C DESTROYED. THEREFORE, THEY MUST BE SAVED BEFORE +C CALLING COMQR IF SUBSEQUENT CALCULATION OF +C EIGENVECTORS IS TO BE PERFORMED. +C +C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, +C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR +C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT +C FOR INDICES IERR+1,...,N. +C +C IERR IS SET TO +C ZERO FOR NORMAL RETURN, +C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED +C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT. +C +C CALLS PYCDIV FOR COMPLEX DIVISION. +C CALLS PYCSRT FOR COMPLEX SQUARE ROOT. +C CALLS PYTHAG FOR DSQRT(A*A + B*B) . +C +C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, +C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY +C +C THIS VERSION DATED AUGUST 1983. +C + + SUBROUTINE PYCMQR(NM,N,LOW,IGH,HR,HI,WR,WI,IERR) + + INTEGER I,J,L,N,EN,LL,NM,IGH,ITN,ITS,LOW,LP1,ENM1,IERR + DOUBLE PRECISION HR(5,5),HI(5,5),WR(5),WI(5) + DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2, + X PYTHAG + + IERR = 0 + IF (LOW .EQ. IGH) GOTO 130 +C .......... CREATE REAL SUBDIAGONAL ELEMENTS .......... + L = LOW + 1 +C + DO 120 I = L, IGH + LL = MIN0(I+1,IGH) + IF (HI(I,I-1) .EQ. 0.0D0) GOTO 120 + NORM = PYTHAG(HR(I,I-1),HI(I,I-1)) + YR = HR(I,I-1) / NORM + YI = HI(I,I-1) / NORM + HR(I,I-1) = NORM + HI(I,I-1) = 0.0D0 +C + DO 100 J = I, IGH + SI = YR * HI(I,J) - YI * HR(I,J) + HR(I,J) = YR * HR(I,J) + YI * HI(I,J) + HI(I,J) = SI + 100 CONTINUE +C + DO 110 J = LOW, LL + SI = YR * HI(J,I) + YI * HR(J,I) + HR(J,I) = YR * HR(J,I) - YI * HI(J,I) + HI(J,I) = SI + 110 CONTINUE +C + 120 CONTINUE +C .......... STORE ROOTS ISOLATED BY CBAL .......... + 130 DO 140 I = 1, N + IF (I .GE. LOW .AND. I .LE. IGH) GOTO 140 + WR(I) = HR(I,I) + WI(I) = HI(I,I) + 140 CONTINUE +C + EN = IGH + TR = 0.0D0 + TI = 0.0D0 + ITN = 30*N +C .......... SEARCH FOR NEXT EIGENVALUE .......... + 150 IF (EN .LT. LOW) GOTO 320 + ITS = 0 + ENM1 = EN - 1 +C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT +C FOR L=EN STEP -1 UNTIL LOW D0 -- .......... + 160 DO 170 LL = LOW, EN + L = EN + LOW - LL + IF (L .EQ. LOW) GOTO 180 + TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1)) + X + DABS(HR(L,L)) + DABS(HI(L,L)) + TST2 = TST1 + DABS(HR(L,L-1)) + IF (TST2 .EQ. TST1) GOTO 180 + 170 CONTINUE +C .......... FORM SHIFT .......... + 180 IF (L .EQ. EN) GOTO 300 + IF (ITN .EQ. 0) GOTO 310 + IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GOTO 200 + SR = HR(EN,EN) + SI = HI(EN,EN) + XR = HR(ENM1,EN) * HR(EN,ENM1) + XI = HI(ENM1,EN) * HR(EN,ENM1) + IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GOTO 210 + YR = (HR(ENM1,ENM1) - SR) / 2.0D0 + YI = (HI(ENM1,ENM1) - SI) / 2.0D0 + CALL PYCSRT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI) + IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GOTO 190 + ZZR = -ZZR + ZZI = -ZZI + 190 CALL PYCDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI) + SR = SR - XR + SI = SI - XI + GOTO 210 +C .......... FORM EXCEPTIONAL SHIFT .......... + 200 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2)) + SI = 0.0D0 +C + 210 DO 220 I = LOW, EN + HR(I,I) = HR(I,I) - SR + HI(I,I) = HI(I,I) - SI + 220 CONTINUE +C + TR = TR + SR + TI = TI + SI + ITS = ITS + 1 + ITN = ITN - 1 +C .......... REDUCE TO TRIANGLE (ROWS) .......... + LP1 = L + 1 +C + DO 240 I = LP1, EN + SR = HR(I,I-1) + HR(I,I-1) = 0.0D0 + NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR) + XR = HR(I-1,I-1) / NORM + WR(I-1) = XR + XI = HI(I-1,I-1) / NORM + WI(I-1) = XI + HR(I-1,I-1) = NORM + HI(I-1,I-1) = 0.0D0 + HI(I,I-1) = SR / NORM +C + DO 230 J = I, EN + YR = HR(I-1,J) + YI = HI(I-1,J) + ZZR = HR(I,J) + ZZI = HI(I,J) + HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR + HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI + HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR + HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI + 230 CONTINUE +C + 240 CONTINUE +C + SI = HI(EN,EN) + IF (SI .EQ. 0.0D0) GOTO 250 + NORM = PYTHAG(HR(EN,EN),SI) + SR = HR(EN,EN) / NORM + SI = SI / NORM + HR(EN,EN) = NORM + HI(EN,EN) = 0.0D0 +C .......... INVERSE OPERATION (COLUMNS) .......... + 250 DO 280 J = LP1, EN + XR = WR(J-1) + XI = WI(J-1) +C + DO 270 I = L, J + YR = HR(I,J-1) + YI = 0.0D0 + ZZR = HR(I,J) + ZZI = HI(I,J) + IF (I .EQ. J) GOTO 260 + YI = HI(I,J-1) + HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI + 260 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR + HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR + HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI + 270 CONTINUE +C + 280 CONTINUE +C + IF (SI .EQ. 0.0D0) GOTO 160 +C + DO 290 I = L, EN + YR = HR(I,EN) + YI = HI(I,EN) + HR(I,EN) = SR * YR - SI * YI + HI(I,EN) = SR * YI + SI * YR + 290 CONTINUE +C + GOTO 160 +C .......... A ROOT FOUND .......... + 300 WR(EN) = HR(EN,EN) + TR + WI(EN) = HI(EN,EN) + TI + EN = ENM1 + GOTO 150 +C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT +C CONVERGED AFTER 30*N ITERATIONS .......... + 310 IERR = EN + 320 RETURN + END + +C********************************************************************* + +C...PYCMQ2 +C...Auxiliary to PYEICG. +C +C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE +C ALGOL PROCEDURE COMLR2, NUM. MATH. 16, 181-204(1970) BY PETERS +C AND WILKINSON. +C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971). +C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS +C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM. +C +C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS +C OF A COMPLEX UPPER HESSENBERG MATRIX BY THE QR +C METHOD. THE EIGENVECTORS OF A COMPLEX GENERAL MATRIX +C CAN ALSO BE FOUND IF CORTH HAS BEEN USED TO REDUCE +C THIS GENERAL MATRIX TO HESSENBERG FORM. +C +C ON INPUT +C +C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL +C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM +C DIMENSION STATEMENT. +C +C N IS THE ORDER OF THE MATRIX. +C +C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING +C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED, +C SET LOW=1, IGH=N. +C +C ORTR AND ORTI CONTAIN INFORMATION ABOUT THE UNITARY TRANS- +C FORMATIONS USED IN THE REDUCTION BY CORTH, IF PERFORMED. +C ONLY ELEMENTS LOW THROUGH IGH ARE USED. IF THE EIGENVECTORS +C OF THE HESSENBERG MATRIX ARE DESIRED, SET ORTR(J) AND +C ORTI(J) TO 0.0D0 FOR THESE ELEMENTS. +C +C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS, +C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX. +C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN FURTHER +C INFORMATION ABOUT THE TRANSFORMATIONS WHICH WERE USED IN THE +C REDUCTION BY CORTH, IF PERFORMED. IF THE EIGENVECTORS OF +C THE HESSENBERG MATRIX ARE DESIRED, THESE ELEMENTS MAY BE +C ARBITRARY. +C +C ON OUTPUT +C +C ORTR, ORTI, AND THE UPPER HESSENBERG PORTIONS OF HR AND HI +C HAVE BEEN DESTROYED. +C +C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, +C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR +C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT +C FOR INDICES IERR+1,...,N. +C +C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, +C RESPECTIVELY, OF THE EIGENVECTORS. THE EIGENVECTORS +C ARE UNNORMALIZED. IF AN ERROR EXIT IS MADE, NONE OF +C THE EIGENVECTORS HAS BEEN FOUND. +C +C IERR IS SET TO +C ZERO FOR NORMAL RETURN, +C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED +C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT. +C +C CALLS PYCDIV FOR COMPLEX DIVISION. +C CALLS PYCSRT FOR COMPLEX SQUARE ROOT. +C CALLS PYTHAG FOR DSQRT(A*A + B*B) . +C +C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, +C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY +C +C THIS VERSION DATED OCTOBER 1989. +C +C MESHED OVERFLOW CONTROL WITH VECTORS OF ISOLATED ROOTS (10/19/89 BSG) +C MESHED OVERFLOW CONTROL WITH TRIANGULAR MULTIPLY (10/30/89 BSG) +C + + SUBROUTINE PYCMQ2(NM,N,LOW,IGH,ORTR,ORTI,HR,HI,WR,WI,ZR,ZI,IERR) + + INTEGER I,J,K,L,M,N,EN,II,JJ,LL,NM,NN,IGH,IP1, + X ITN,ITS,LOW,LP1,ENM1,IEND,IERR + DOUBLE PRECISION HR(5,5),HI(5,5),WR(5),WI(5),ZR(5,5),ZI(5,5), + X ORTR(5),ORTI(5) + DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2, + X PYTHAG + + IERR = 0 +C .......... INITIALIZE EIGENVECTOR MATRIX .......... + DO 110 J = 1, N +C + DO 100 I = 1, N + ZR(I,J) = 0.0D0 + ZI(I,J) = 0.0D0 + 100 CONTINUE + ZR(J,J) = 1.0D0 + 110 CONTINUE +C .......... FORM THE MATRIX OF ACCUMULATED TRANSFORMATIONS +C FROM THE INFORMATION LEFT BY CORTH .......... + IEND = IGH - LOW - 1 + IF (IEND.LT.0) GOTO 220 + IF (IEND.EQ.0) GOTO 170 +C .......... FOR I=IGH-1 STEP -1 UNTIL LOW+1 DO -- .......... + DO 160 II = 1, IEND + I = IGH - II + IF (ORTR(I) .EQ. 0.0D0 .AND. ORTI(I) .EQ. 0.0D0) GOTO 160 + IF (HR(I,I-1) .EQ. 0.0D0 .AND. HI(I,I-1) .EQ. 0.0D0) GOTO 160 +C .......... NORM BELOW IS NEGATIVE OF H FORMED IN CORTH .......... + NORM = HR(I,I-1) * ORTR(I) + HI(I,I-1) * ORTI(I) + IP1 = I + 1 +C + DO 120 K = IP1, IGH + ORTR(K) = HR(K,I-1) + ORTI(K) = HI(K,I-1) + 120 CONTINUE +C + DO 150 J = I, IGH + SR = 0.0D0 + SI = 0.0D0 +C + DO 130 K = I, IGH + SR = SR + ORTR(K) * ZR(K,J) + ORTI(K) * ZI(K,J) + SI = SI + ORTR(K) * ZI(K,J) - ORTI(K) * ZR(K,J) + 130 CONTINUE +C + SR = SR / NORM + SI = SI / NORM +C + DO 140 K = I, IGH + ZR(K,J) = ZR(K,J) + SR * ORTR(K) - SI * ORTI(K) + ZI(K,J) = ZI(K,J) + SR * ORTI(K) + SI * ORTR(K) + 140 CONTINUE +C + 150 CONTINUE +C + 160 CONTINUE +C .......... CREATE REAL SUBDIAGONAL ELEMENTS .......... + 170 L = LOW + 1 +C + DO 210 I = L, IGH + LL = MIN0(I+1,IGH) + IF (HI(I,I-1) .EQ. 0.0D0) GOTO 210 + NORM = PYTHAG(HR(I,I-1),HI(I,I-1)) + YR = HR(I,I-1) / NORM + YI = HI(I,I-1) / NORM + HR(I,I-1) = NORM + HI(I,I-1) = 0.0D0 +C + DO 180 J = I, N + SI = YR * HI(I,J) - YI * HR(I,J) + HR(I,J) = YR * HR(I,J) + YI * HI(I,J) + HI(I,J) = SI + 180 CONTINUE +C + DO 190 J = 1, LL + SI = YR * HI(J,I) + YI * HR(J,I) + HR(J,I) = YR * HR(J,I) - YI * HI(J,I) + HI(J,I) = SI + 190 CONTINUE +C + DO 200 J = LOW, IGH + SI = YR * ZI(J,I) + YI * ZR(J,I) + ZR(J,I) = YR * ZR(J,I) - YI * ZI(J,I) + ZI(J,I) = SI + 200 CONTINUE +C + 210 CONTINUE +C .......... STORE ROOTS ISOLATED BY CBAL .......... + 220 DO 230 I = 1, N + IF (I .GE. LOW .AND. I .LE. IGH) GOTO 230 + WR(I) = HR(I,I) + WI(I) = HI(I,I) + 230 CONTINUE +C + EN = IGH + TR = 0.0D0 + TI = 0.0D0 + ITN = 30*N +C .......... SEARCH FOR NEXT EIGENVALUE .......... + 240 IF (EN .LT. LOW) GOTO 430 + ITS = 0 + ENM1 = EN - 1 +C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT +C FOR L=EN STEP -1 UNTIL LOW DO -- .......... + 250 DO 260 LL = LOW, EN + L = EN + LOW - LL + IF (L .EQ. LOW) GOTO 270 + TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1)) + X + DABS(HR(L,L)) + DABS(HI(L,L)) + TST2 = TST1 + DABS(HR(L,L-1)) + IF (TST2 .EQ. TST1) GOTO 270 + 260 CONTINUE +C .......... FORM SHIFT .......... + 270 IF (L .EQ. EN) GOTO 420 + IF (ITN .EQ. 0) GOTO 550 + IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GOTO 290 + SR = HR(EN,EN) + SI = HI(EN,EN) + XR = HR(ENM1,EN) * HR(EN,ENM1) + XI = HI(ENM1,EN) * HR(EN,ENM1) + IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GOTO 300 + YR = (HR(ENM1,ENM1) - SR) / 2.0D0 + YI = (HI(ENM1,ENM1) - SI) / 2.0D0 + CALL PYCSRT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI) + IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GOTO 280 + ZZR = -ZZR + ZZI = -ZZI + 280 CALL PYCDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI) + SR = SR - XR + SI = SI - XI + GOTO 300 +C .......... FORM EXCEPTIONAL SHIFT .......... + 290 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2)) + SI = 0.0D0 +C + 300 DO 310 I = LOW, EN + HR(I,I) = HR(I,I) - SR + HI(I,I) = HI(I,I) - SI + 310 CONTINUE +C + TR = TR + SR + TI = TI + SI + ITS = ITS + 1 + ITN = ITN - 1 +C .......... REDUCE TO TRIANGLE (ROWS) .......... + LP1 = L + 1 +C + DO 330 I = LP1, EN + SR = HR(I,I-1) + HR(I,I-1) = 0.0D0 + NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR) + XR = HR(I-1,I-1) / NORM + WR(I-1) = XR + XI = HI(I-1,I-1) / NORM + WI(I-1) = XI + HR(I-1,I-1) = NORM + HI(I-1,I-1) = 0.0D0 + HI(I,I-1) = SR / NORM +C + DO 320 J = I, N + YR = HR(I-1,J) + YI = HI(I-1,J) + ZZR = HR(I,J) + ZZI = HI(I,J) + HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR + HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI + HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR + HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI + 320 CONTINUE +C + 330 CONTINUE +C + SI = HI(EN,EN) + IF (SI .EQ. 0.0D0) GOTO 350 + NORM = PYTHAG(HR(EN,EN),SI) + SR = HR(EN,EN) / NORM + SI = SI / NORM + HR(EN,EN) = NORM + HI(EN,EN) = 0.0D0 + IF (EN .EQ. N) GOTO 350 + IP1 = EN + 1 +C + DO 340 J = IP1, N + YR = HR(EN,J) + YI = HI(EN,J) + HR(EN,J) = SR * YR + SI * YI + HI(EN,J) = SR * YI - SI * YR + 340 CONTINUE +C .......... INVERSE OPERATION (COLUMNS) .......... + 350 DO 390 J = LP1, EN + XR = WR(J-1) + XI = WI(J-1) +C + DO 370 I = 1, J + YR = HR(I,J-1) + YI = 0.0D0 + ZZR = HR(I,J) + ZZI = HI(I,J) + IF (I .EQ. J) GOTO 360 + YI = HI(I,J-1) + HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI + 360 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR + HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR + HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI + 370 CONTINUE +C + DO 380 I = LOW, IGH + YR = ZR(I,J-1) + YI = ZI(I,J-1) + ZZR = ZR(I,J) + ZZI = ZI(I,J) + ZR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR + ZI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI + ZR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR + ZI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI + 380 CONTINUE +C + 390 CONTINUE +C + IF (SI .EQ. 0.0D0) GOTO 250 +C + DO 400 I = 1, EN + YR = HR(I,EN) + YI = HI(I,EN) + HR(I,EN) = SR * YR - SI * YI + HI(I,EN) = SR * YI + SI * YR + 400 CONTINUE +C + DO 410 I = LOW, IGH + YR = ZR(I,EN) + YI = ZI(I,EN) + ZR(I,EN) = SR * YR - SI * YI + ZI(I,EN) = SR * YI + SI * YR + 410 CONTINUE +C + GOTO 250 +C .......... A ROOT FOUND .......... + 420 HR(EN,EN) = HR(EN,EN) + TR + WR(EN) = HR(EN,EN) + HI(EN,EN) = HI(EN,EN) + TI + WI(EN) = HI(EN,EN) + EN = ENM1 + GOTO 240 +C .......... ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND +C VECTORS OF UPPER TRIANGULAR FORM .......... + 430 NORM = 0.0D0 +C + DO 440 I = 1, N +C + DO 440 J = I, N + TR = DABS(HR(I,J)) + DABS(HI(I,J)) + IF (TR .GT. NORM) NORM = TR + 440 CONTINUE +C + IF (N .EQ. 1 .OR. NORM .EQ. 0.0D0) GOTO 560 +C .......... FOR EN=N STEP -1 UNTIL 2 DO -- .......... + DO 500 NN = 2, N + EN = N + 2 - NN + XR = WR(EN) + XI = WI(EN) + HR(EN,EN) = 1.0D0 + HI(EN,EN) = 0.0D0 + ENM1 = EN - 1 +C .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- .......... + DO 490 II = 1, ENM1 + I = EN - II + ZZR = 0.0D0 + ZZI = 0.0D0 + IP1 = I + 1 +C + DO 450 J = IP1, EN + ZZR = ZZR + HR(I,J) * HR(J,EN) - HI(I,J) * HI(J,EN) + ZZI = ZZI + HR(I,J) * HI(J,EN) + HI(I,J) * HR(J,EN) + 450 CONTINUE +C + YR = XR - WR(I) + YI = XI - WI(I) + IF (YR .NE. 0.0D0 .OR. YI .NE. 0.0D0) GOTO 470 + TST1 = NORM + YR = TST1 + 460 YR = 0.01D0 * YR + TST2 = NORM + YR + IF (TST2 .GT. TST1) GOTO 460 + 470 CONTINUE + CALL PYCDIV(ZZR,ZZI,YR,YI,HR(I,EN),HI(I,EN)) +C .......... OVERFLOW CONTROL .......... + TR = DABS(HR(I,EN)) + DABS(HI(I,EN)) + IF (TR .EQ. 0.0D0) GOTO 490 + TST1 = TR + TST2 = TST1 + 1.0D0/TST1 + IF (TST2 .GT. TST1) GOTO 490 + DO 480 J = I, EN + HR(J,EN) = HR(J,EN)/TR + HI(J,EN) = HI(J,EN)/TR + 480 CONTINUE +C + 490 CONTINUE +C + 500 CONTINUE +C .......... END BACKSUBSTITUTION .......... +C .......... VECTORS OF ISOLATED ROOTS .......... + DO 520 I = 1, N + IF (I .GE. LOW .AND. I .LE. IGH) GOTO 520 +C + DO 510 J = I, N + ZR(I,J) = HR(I,J) + ZI(I,J) = HI(I,J) + 510 CONTINUE +C + 520 CONTINUE +C .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE +C VECTORS OF ORIGINAL FULL MATRIX. +C FOR J=N STEP -1 UNTIL LOW DO -- .......... + DO 540 JJ = LOW, N + J = N + LOW - JJ + M = MIN0(J,IGH) +C + DO 540 I = LOW, IGH + ZZR = 0.0D0 + ZZI = 0.0D0 +C + DO 530 K = LOW, M + ZZR = ZZR + ZR(I,K) * HR(K,J) - ZI(I,K) * HI(K,J) + ZZI = ZZI + ZR(I,K) * HI(K,J) + ZI(I,K) * HR(K,J) + 530 CONTINUE +C + ZR(I,J) = ZZR + ZI(I,J) = ZZI + 540 CONTINUE +C + GOTO 560 +C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT +C CONVERGED AFTER 30*N ITERATIONS .......... + 550 IERR = EN + 560 RETURN + END + +C********************************************************************* + +C...PYCDIV +C...Auxiliary to PYCMQR +C +C COMPLEX DIVISION, (CR,CI) = (AR,AI)/(BR,BI) +C + + SUBROUTINE PYCDIV(AR,AI,BR,BI,CR,CI) + + DOUBLE PRECISION AR,AI,BR,BI,CR,CI + DOUBLE PRECISION S,ARS,AIS,BRS,BIS + + S = DABS(BR) + DABS(BI) + ARS = AR/S + AIS = AI/S + BRS = BR/S + BIS = BI/S + S = BRS**2 + BIS**2 + CR = (ARS*BRS + AIS*BIS)/S + CI = (AIS*BRS - ARS*BIS)/S + RETURN + END + +C********************************************************************* + +C...PYCSRT +C...Auxiliary to PYCMQR +C +C (YR,YI) = COMPLEX DSQRT(XR,XI) +C BRANCH CHOSEN SO THAT YR .GE. 0.0 AND SIGN(YI) .EQ. SIGN(XI) +C + + SUBROUTINE PYCSRT(XR,XI,YR,YI) + + DOUBLE PRECISION XR,XI,YR,YI + DOUBLE PRECISION S,TR,TI,PYTHAG + + TR = XR + TI = XI + S = DSQRT(0.5D0*(PYTHAG(TR,TI) + DABS(TR))) + IF (TR .GE. 0.0D0) YR = S + IF (TI .LT. 0.0D0) S = -S + IF (TR .LE. 0.0D0) YI = S + IF (TR .LT. 0.0D0) YR = 0.5D0*(TI/YI) + IF (TR .GT. 0.0D0) YI = 0.5D0*(TI/YR) + RETURN + END + + DOUBLE PRECISION FUNCTION PYTHAG(A,B) + DOUBLE PRECISION A,B +C +C FINDS DSQRT(A**2+B**2) WITHOUT OVERFLOW OR DESTRUCTIVE UNDERFLOW +C + DOUBLE PRECISION P,R,S,T,U + P = DMAX1(DABS(A),DABS(B)) + IF (P .EQ. 0.0D0) GOTO 110 + R = (DMIN1(DABS(A),DABS(B))/P)**2 + 100 CONTINUE + T = 4.0D0 + R + IF (T .EQ. 4.0D0) GOTO 110 + S = R/T + U = 1.0D0 + 2.0D0*S + P = U*P + R = (S/U)**2 * R + GOTO 100 + 110 PYTHAG = P + RETURN + END + +C********************************************************************* + +C...PYCBAL +C...Auxiliary to PYEICG +C +C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE +C CBALANCE, WHICH IS A COMPLEX VERSION OF BALANCE, +C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH. +C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971). +C +C THIS SUBROUTINE BALANCES A COMPLEX MATRIX AND ISOLATES +C EIGENVALUES WHENEVER POSSIBLE. +C +C ON INPUT +C +C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL +C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM +C DIMENSION STATEMENT. +C +C N IS THE ORDER OF THE MATRIX. +C +C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, +C RESPECTIVELY, OF THE COMPLEX MATRIX TO BE BALANCED. +C +C ON OUTPUT +C +C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, +C RESPECTIVELY, OF THE BALANCED MATRIX. +C +C LOW AND IGH ARE TWO INTEGERS SUCH THAT AR(I,J) AND AI(I,J) +C ARE EQUAL TO ZERO IF +C (1) I IS GREATER THAN J AND +C (2) J=1,...,LOW-1 OR I=IGH+1,...,N. +C +C SCALE CONTAINS INFORMATION DETERMINING THE +C PERMUTATIONS AND SCALING FACTORS USED. +C +C SUPPOSE THAT THE PRINCIPAL SUBMATRIX IN ROWS LOW THROUGH IGH +C HAS BEEN BALANCED, THAT P(J) DENOTES THE INDEX INTERCHANGED +C WITH J DURING THE PERMUTATION STEP, AND THAT THE ELEMENTS +C OF THE DIAGONAL MATRIX USED ARE DENOTED BY D(I,J). THEN +C SCALE(J) = P(J), FOR J = 1,...,LOW-1 +C = D(J,J) J = LOW,...,IGH +C = P(J) J = IGH+1,...,N. +C THE ORDER IN WHICH THE INTERCHANGES ARE MADE IS N TO IGH+1, +C THEN 1 TO LOW-1. +C +C NOTE THAT 1 IS RETURNED FOR IGH IF IGH IS ZERO FORMALLY. +C +C THE ALGOL PROCEDURE EXC CONTAINED IN CBALANCE APPEARS IN +C CBAL IN LINE. (NOTE THAT THE ALGOL ROLES OF IDENTIFIERS +C K,L HAVE BEEN REVERSED.) +C +C ARITHMETIC IS REAL THROUGHOUT. +C +C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, +C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY +C +C THIS VERSION DATED AUGUST 1983. +C + + SUBROUTINE PYCBAL(NM,N,AR,AI,LOW,IGH,SCALE) + + INTEGER I,J,K,L,M,N,JJ,NM,IGH,LOW,IEXC + DOUBLE PRECISION AR(5,5),AI(5,5),SCALE(5) + DOUBLE PRECISION C,F,G,R,S,B2,RADIX + LOGICAL NOCONV + + RADIX = 16.0D0 +C + B2 = RADIX * RADIX + K = 1 + L = N + GOTO 150 +C .......... IN-LINE PROCEDURE FOR ROW AND +C COLUMN EXCHANGE .......... + 100 SCALE(M) = J + IF (J .EQ. M) GOTO 130 +C + DO 110 I = 1, L + F = AR(I,J) + AR(I,J) = AR(I,M) + AR(I,M) = F + F = AI(I,J) + AI(I,J) = AI(I,M) + AI(I,M) = F + 110 CONTINUE +C + DO 120 I = K, N + F = AR(J,I) + AR(J,I) = AR(M,I) + AR(M,I) = F + F = AI(J,I) + AI(J,I) = AI(M,I) + AI(M,I) = F + 120 CONTINUE +C + 130 IF(IEXC.EQ.1) GOTO 140 + IF(IEXC.EQ.2) GOTO 180 +C .......... SEARCH FOR ROWS ISOLATING AN EIGENVALUE +C AND PUSH THEM DOWN .......... + 140 IF (L .EQ. 1) GOTO 320 + L = L - 1 +C .......... FOR J=L STEP -1 UNTIL 1 DO -- .......... + 150 DO 170 JJ = 1, L + J = L + 1 - JJ +C + DO 160 I = 1, L + IF (I .EQ. J) GOTO 160 + IF (AR(J,I) .NE. 0.0D0 .OR. AI(J,I) .NE. 0.0D0) GOTO 170 + 160 CONTINUE +C + M = L + IEXC = 1 + GOTO 100 + 170 CONTINUE +C + GOTO 190 +C .......... SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE +C AND PUSH THEM LEFT .......... + 180 K = K + 1 +C + 190 DO 210 J = K, L +C + DO 200 I = K, L + IF (I .EQ. J) GOTO 200 + IF (AR(I,J) .NE. 0.0D0 .OR. AI(I,J) .NE. 0.0D0) GOTO 210 + 200 CONTINUE +C + M = K + IEXC = 2 + GOTO 100 + 210 CONTINUE +C .......... NOW BALANCE THE SUBMATRIX IN ROWS K TO L .......... + DO 220 I = K, L + 220 SCALE(I) = 1.0D0 +C .......... ITERATIVE LOOP FOR NORM REDUCTION .......... + 230 NOCONV = .FALSE. +C + DO 310 I = K, L + C = 0.0D0 + R = 0.0D0 +C + DO 240 J = K, L + IF (J .EQ. I) GOTO 240 + C = C + DABS(AR(J,I)) + DABS(AI(J,I)) + R = R + DABS(AR(I,J)) + DABS(AI(I,J)) + 240 CONTINUE +C .......... GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW .......... + IF (C .EQ. 0.0D0 .OR. R .EQ. 0.0D0) GOTO 310 + G = R / RADIX + F = 1.0D0 + S = C + R + 250 IF (C .GE. G) GOTO 260 + F = F * RADIX + C = C * B2 + GOTO 250 + 260 G = R * RADIX + 270 IF (C .LT. G) GOTO 280 + F = F / RADIX + C = C / B2 + GOTO 270 +C .......... NOW BALANCE .......... + 280 IF ((C + R) / F .GE. 0.95D0 * S) GOTO 310 + G = 1.0D0 / F + SCALE(I) = SCALE(I) * F + NOCONV = .TRUE. +C + DO 290 J = K, N + AR(I,J) = AR(I,J) * G + AI(I,J) = AI(I,J) * G + 290 CONTINUE +C + DO 300 J = 1, L + AR(J,I) = AR(J,I) * F + AI(J,I) = AI(J,I) * F + 300 CONTINUE +C + 310 CONTINUE +C + IF (NOCONV) GOTO 230 +C + 320 LOW = K + IGH = L + RETURN + END + +C********************************************************************* + +C...PYCBA2 +C...Auxiliary to PYEICG. +C +C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE +C CBABK2, WHICH IS A COMPLEX VERSION OF BALBAK, +C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH. +C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971). +C +C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX GENERAL +C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING +C BALANCED MATRIX DETERMINED BY CBAL. +C +C ON INPUT +C +C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL +C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM +C DIMENSION STATEMENT. +C +C N IS THE ORDER OF THE MATRIX. +C +C LOW AND IGH ARE INTEGERS DETERMINED BY CBAL. +C +C SCALE CONTAINS INFORMATION DETERMINING THE PERMUTATIONS +C AND SCALING FACTORS USED BY CBAL. +C +C M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED. +C +C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, +C RESPECTIVELY, OF THE EIGENVECTORS TO BE +C BACK TRANSFORMED IN THEIR FIRST M COLUMNS. +C +C ON OUTPUT +C +C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, +C RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS +C IN THEIR FIRST M COLUMNS. +C +C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, +C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY +C +C THIS VERSION DATED AUGUST 1983. +C + + SUBROUTINE PYCBA2(NM,N,LOW,IGH,SCALE,M,ZR,ZI) + + INTEGER I,J,K,M,N,II,NM,IGH,LOW + DOUBLE PRECISION SCALE(5),ZR(5,5),ZI(5,5) + DOUBLE PRECISION S + + IF (M .EQ. 0) GOTO 150 + IF (IGH .EQ. LOW) GOTO 120 +C + DO 110 I = LOW, IGH + S = SCALE(I) +C .......... LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED +C IF THE FOREGOING STATEMENT IS REPLACED BY +C S=1.0D0/SCALE(I). .......... + DO 100 J = 1, M + ZR(I,J) = ZR(I,J) * S + ZI(I,J) = ZI(I,J) * S + 100 CONTINUE +C + 110 CONTINUE +C .......... FOR I=LOW-1 STEP -1 UNTIL 1, +C IGH+1 STEP 1 UNTIL N DO -- .......... + 120 DO 140 II = 1, N + I = II + IF (I .GE. LOW .AND. I .LE. IGH) GOTO 140 + IF (I .LT. LOW) I = LOW - II + K = SCALE(I) + IF (K .EQ. I) GOTO 140 +C + DO 130 J = 1, M + S = ZR(I,J) + ZR(I,J) = ZR(K,J) + ZR(K,J) = S + S = ZI(I,J) + ZI(I,J) = ZI(K,J) + ZI(K,J) = S + 130 CONTINUE +C + 140 CONTINUE +C + 150 RETURN + END + +C********************************************************************* + +C...PYCRTH +C...Auxiliary to PYEICG. +C +C THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF +C THE ALGOL PROCEDURE ORTHES, NUM. MATH. 12, 349-368(1968) +C BY MARTIN AND WILKINSON. +C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971). +C +C GIVEN A COMPLEX GENERAL MATRIX, THIS SUBROUTINE +C REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS +C LOW THROUGH IGH TO UPPER HESSENBERG FORM BY +C UNITARY SIMILARITY TRANSFORMATIONS. +C +C ON INPUT +C +C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL +C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM +C DIMENSION STATEMENT. +C +C N IS THE ORDER OF THE MATRIX. +C +C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING +C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED, +C SET LOW=1, IGH=N. +C +C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, +C RESPECTIVELY, OF THE COMPLEX INPUT MATRIX. +C +C ON OUTPUT +C +C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, +C RESPECTIVELY, OF THE HESSENBERG MATRIX. INFORMATION +C ABOUT THE UNITARY TRANSFORMATIONS USED IN THE REDUCTION +C IS STORED IN THE REMAINING TRIANGLES UNDER THE +C HESSENBERG MATRIX. +C +C ORTR AND ORTI CONTAIN FURTHER INFORMATION ABOUT THE +C TRANSFORMATIONS. ONLY ELEMENTS LOW THROUGH IGH ARE USED. +C +C CALLS PYTHAG FOR DSQRT(A*A + B*B) . +C +C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, +C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY +C +C THIS VERSION DATED AUGUST 1983. +C + + SUBROUTINE PYCRTH(NM,N,LOW,IGH,AR,AI,ORTR,ORTI) + + INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW + DOUBLE PRECISION AR(5,5),AI(5,5),ORTR(5),ORTI(5) + DOUBLE PRECISION F,G,H,FI,FR,SCALE,PYTHAG + + LA = IGH - 1 + KP1 = LOW + 1 + IF (LA .LT. KP1) GOTO 210 +C + DO 200 M = KP1, LA + H = 0.0D0 + ORTR(M) = 0.0D0 + ORTI(M) = 0.0D0 + SCALE = 0.0D0 +C .......... SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) .......... + DO 100 I = M, IGH + 100 SCALE = SCALE + DABS(AR(I,M-1)) + DABS(AI(I,M-1)) +C + IF (SCALE .EQ. 0.0D0) GOTO 200 + MP = M + IGH +C .......... FOR I=IGH STEP -1 UNTIL M DO -- .......... + DO 110 II = M, IGH + I = MP - II + ORTR(I) = AR(I,M-1) / SCALE + ORTI(I) = AI(I,M-1) / SCALE + H = H + ORTR(I) * ORTR(I) + ORTI(I) * ORTI(I) + 110 CONTINUE +C + G = DSQRT(H) + F = PYTHAG(ORTR(M),ORTI(M)) + IF (F .EQ. 0.0D0) GOTO 120 + H = H + F * G + G = G / F + ORTR(M) = (1.0D0 + G) * ORTR(M) + ORTI(M) = (1.0D0 + G) * ORTI(M) + GOTO 130 +C + 120 ORTR(M) = G + AR(M,M-1) = SCALE +C .......... FORM (I-(U*UT)/H) * A .......... + 130 DO 160 J = M, N + FR = 0.0D0 + FI = 0.0D0 +C .......... FOR I=IGH STEP -1 UNTIL M DO -- .......... + DO 140 II = M, IGH + I = MP - II + FR = FR + ORTR(I) * AR(I,J) + ORTI(I) * AI(I,J) + FI = FI + ORTR(I) * AI(I,J) - ORTI(I) * AR(I,J) + 140 CONTINUE +C + FR = FR / H + FI = FI / H +C + DO 150 I = M, IGH + AR(I,J) = AR(I,J) - FR * ORTR(I) + FI * ORTI(I) + AI(I,J) = AI(I,J) - FR * ORTI(I) - FI * ORTR(I) + 150 CONTINUE +C + 160 CONTINUE +C .......... FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) .......... + DO 190 I = 1, IGH + FR = 0.0D0 + FI = 0.0D0 +C .......... FOR J=IGH STEP -1 UNTIL M DO -- .......... + DO 170 JJ = M, IGH + J = MP - JJ + FR = FR + ORTR(J) * AR(I,J) - ORTI(J) * AI(I,J) + FI = FI + ORTR(J) * AI(I,J) + ORTI(J) * AR(I,J) + 170 CONTINUE +C + FR = FR / H + FI = FI / H +C + DO 180 J = M, IGH + AR(I,J) = AR(I,J) - FR * ORTR(J) - FI * ORTI(J) + AI(I,J) = AI(I,J) + FR * ORTI(J) - FI * ORTR(J) + 180 CONTINUE +C + 190 CONTINUE +C + ORTR(M) = SCALE * ORTR(M) + ORTI(M) = SCALE * ORTI(M) + AR(M,M-1) = -G * AR(M,M-1) + AI(M,M-1) = -G * AI(M,M-1) + 200 CONTINUE +C + 210 RETURN + END + +C********************************************************************* + +C...PYLDCM +C...Auxiliary to PYSIGH, for technicolor corrections to QCD 2 -> 2 +C...processes. + + SUBROUTINE PYLDCM(A,N,NP,INDX,D) + IMPLICIT NONE + INTEGER N,NP,INDX(N) + REAL*8 D,TINY + COMPLEX*16 A(NP,NP) + PARAMETER (TINY=1.0D-20) + INTEGER I,IMAX,J,K + REAL*8 AAMAX,VV(6),DUM + COMPLEX*16 SUM,DUMC + + D=1D0 + DO 110 I=1,N + AAMAX=0D0 + DO 100 J=1,N + IF (ABS(A(I,J)).GT.AAMAX) AAMAX=ABS(A(I,J)) + 100 CONTINUE + IF (AAMAX.EQ.0D0) CALL PYERRM(28,'(PYLDCM:) singular matrix') + VV(I)=1D0/AAMAX + 110 CONTINUE + DO 180 J=1,N + DO 130 I=1,J-1 + SUM=A(I,J) + DO 120 K=1,I-1 + SUM=SUM-A(I,K)*A(K,J) + 120 CONTINUE + A(I,J)=SUM + 130 CONTINUE + AAMAX=0D0 + DO 150 I=J,N + SUM=A(I,J) + DO 140 K=1,J-1 + SUM=SUM-A(I,K)*A(K,J) + 140 CONTINUE + A(I,J)=SUM + DUM=VV(I)*ABS(SUM) + IF (DUM.GE.AAMAX) THEN + IMAX=I + AAMAX=DUM + ENDIF + 150 CONTINUE + IF (J.NE.IMAX)THEN + DO 160 K=1,N + DUMC=A(IMAX,K) + A(IMAX,K)=A(J,K) + A(J,K)=DUMC + 160 CONTINUE + D=-D + VV(IMAX)=VV(J) + ENDIF + INDX(J)=IMAX + IF(ABS(A(J,J)).EQ.0D0) A(J,J)=DCMPLX(TINY,0D0) + IF(J.NE.N)THEN + DO 170 I=J+1,N + A(I,J)=A(I,J)/A(J,J) + 170 CONTINUE + ENDIF + 180 CONTINUE + + RETURN + END + +C********************************************************************* + +C...PYBKSB +C...Auxiliary to PYSIGH, for technicolor corrections to QCD 2 -> 2 +C...processes. + + SUBROUTINE PYBKSB(A,N,NP,INDX,B) + IMPLICIT NONE + INTEGER N,NP,INDX(N) + COMPLEX*16 A(NP,NP),B(N) + INTEGER I,II,J,LL + COMPLEX*16 SUM + + II=0 + DO 110 I=1,N + LL=INDX(I) + SUM=B(LL) + B(LL)=B(I) + IF (II.NE.0)THEN + DO 100 J=II,I-1 + SUM=SUM-A(I,J)*B(J) + 100 CONTINUE + ELSE IF (ABS(SUM).NE.0D0) THEN + II=I + ENDIF + B(I)=SUM + 110 CONTINUE + DO 130 I=N,1,-1 + SUM=B(I) + DO 120 J=I+1,N + SUM=SUM-A(I,J)*B(J) + 120 CONTINUE + B(I)=SUM/A(I,I) + 130 CONTINUE + RETURN + END + +C*********************************************************************** + +C...PYWIDX +C...Calculates full and partial widths of resonances. +C....copy of PYWIDT, used for techniparticle widths + + SUBROUTINE PYWIDX(KFLR,SH,WDTP,WDTE) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT4/MWID(500),WIDS(500,5) + COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) + COMMON/PYTCSM/ITCM(0:99),RTCM(0:99) + SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/, + &/PYINT4/,/PYMSSM/,/PYTCSM/ +C...Local arrays and saved variables. + DIMENSION WDTP(0:400),WDTE(0:400,0:5),MOFSV(3,2),WIDWSV(3,2), + &WID2SV(3,2) + SAVE MOFSV,WIDWSV,WID2SV + DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/ + +C...Compressed code and sign; mass. + KFLA=IABS(KFLR) + KFLS=ISIGN(1,KFLR) + KC=PYCOMP(KFLA) + SHR=SQRT(SH) + PMR=PMAS(KC,1) + +C...Reset width information. + DO I=0,400 + WDTP(I)=0D0 + ENDDO + +C...Common electroweak and strong constants. + XW=PARU(102) + XWV=XW + IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2 + XW1=1D0-XW + AEM=PYALEM(SH) + IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1) + AS=PYALPS(SH) + RADC=1D0+AS/PARU(1) + + IF(KFLA.EQ.23) THEN +C...Z0: + XWC=1D0/(16D0*XW*XW1) + FAC=(AEM*XWC/3D0)*SHR + 120 CONTINUE + DO 130 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 130 + RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH + RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH + IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 130 + IF(I.LE.8) THEN +C...Z0 -> q + qbar + EF=KCHG(I,1)/3D0 + AF=SIGN(1D0,EF+0.1D0) + VF=AF-4D0*EF*XWV + FCOF=3D0*RADC + IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0) + ELSEIF(I.LE.16) THEN +C...Z0 -> l+ + l-, nu + nubar + EF=KCHG(I+2,1)/3D0 + AF=SIGN(1D0,EF+0.1D0) + VF=AF-4D0*EF*XWV + FCOF=1D0 + ENDIF + BE34=SQRT(MAX(0D0,1D0-4D0*RM1)) + WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))* + & BE34 + WDTP(0)=WDTP(0)+WDTP(I) + 130 CONTINUE + + + ELSEIF(KFLA.EQ.24) THEN +C...W+/-: + FAC=(AEM/(24D0*XW))*SHR + DO 140 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 140 + RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH + RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH + IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 140 + WID2=1D0 + IF(I.LE.16) THEN +C...W+/- -> q + qbar' + FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1) + ELSEIF(I.LE.20) THEN +C...W+/- -> l+/- + nu + FCOF=1D0 + ENDIF + WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)* + & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)) + WDTP(0)=WDTP(0)+WDTP(I) + 140 CONTINUE + +C.....V8 -> quark anti-quark + ELSEIF(KFLA.EQ.KTECHN+100021) THEN + FAC=AS/6D0*SHR + TANT3=RTCM(21) + IF(ITCM(2).EQ.0) THEN + IMDL=1 + ELSEIF(ITCM(2).EQ.1) THEN + IMDL=2 + ENDIF + DO 150 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 150 + PM1=PMAS(PYCOMP(KFDP(IDC,1)),1) + RM1=PM1**2/SH + IF(RM1.GT.0.25D0) GOTO 150 + WID2=1D0 + IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN + FMIX=1D0/TANT3**2 + ELSE + FMIX=TANT3**2 + ENDIF + WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*FMIX + IF(I.EQ.6) WID2=WIDS(6,1) + WDTP(0)=WDTP(0)+WDTP(I) + 150 CONTINUE + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYRVSF +C...Calculates R-violating decays of sfermions. +C...P. Z. Skands + + SUBROUTINE PYRVSF(KFIN,XLAM,IDLAM,LKNT) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks. + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) + COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), + &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) + COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3) +C...Local variables. + DOUBLE PRECISION XLAM(0:400) + INTEGER IDLAM(400,3), PYCOMP + SAVE /PYMSRV/,/PYSSMT/,/PYMSSM/,/PYDAT2/ + +C...IS R-VIOLATION ON ? + IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN +C...Mass eigenstate counter + ICNT=INT(KFIN/KSUSY1) +C...SM KF code of SUSY particle + KFSM=KFIN-ICNT*KSUSY1 +C...Squared Sparticle Mass + SM=PMAS(PYCOMP(KFIN),1)**2 +C... Squared mass of top quark + SMT=PMAS(PYCOMP(6),1)**2 +C...IS L-VIOLATION ON ? + IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1)) THEN +C...SLEPTON -> NU(BAR) + LEPTON and UBAR + D + IF(ICNT.NE.0.AND.(KFSM.EQ.11.OR.KFSM.EQ.13.OR.KFSM.EQ.15)) + & THEN + K=INT((KFSM-9)/2) + DO 110 I=1,3 + DO 100 J=1,3 + IF(I.NE.J) THEN +C...~e,~mu,~tau -> nu_I + lepton-_J + LKNT = LKNT+1 + IDLAM(LKNT,1)= 12 +2*(I-1) + IDLAM(LKNT,2)= 11 +2*(J-1) + IDLAM(LKNT,3)= 0 + XLAM(LKNT)=0D0 + RM2=RVLAM(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM + IF (IMSS(51).NE.0) XLAM(LKNT) = + & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4) +C...KINEMATICS CHECK + IF (XLAM(LKNT).EQ.0D0) THEN + LKNT=LKNT-1 + ENDIF + ENDIF + 100 CONTINUE + 110 CONTINUE +C...~e,~mu,~tau -> nu_Ibar + lepton-_K + J=INT((KFSM-9)/2) + DO 130 I=1,3 + IF(I.NE.J) THEN + DO 120 K=1,3 + LKNT = LKNT+1 + IDLAM(LKNT,1)=-12 -2*(I-1) + IDLAM(LKNT,2)= 11 +2*(K-1) + IDLAM(LKNT,3)= 0 + XLAM(LKNT)=0D0 + RM2=RVLAM(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM + IF (IMSS(51).NE.0) XLAM(LKNT) = + & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4) +C...KINEMATICS CHECK + IF (XLAM(LKNT).EQ.0D0) THEN + LKNT=LKNT-1 + ENDIF + 120 CONTINUE + ENDIF + 130 CONTINUE +C...~e,~mu,~tau -> u_Jbar + d_K + I=INT((KFSM-9)/2) + DO 150 J=1,3 + DO 140 K=1,3 + LKNT = LKNT+1 + IDLAM(LKNT,1)=-2 -2*(J-1) + IDLAM(LKNT,2)= 1 +2*(K-1) + IDLAM(LKNT,3)= 0 + XLAM(LKNT)=0 + IF (IMSS(52).NE.0) THEN +C...Use massive top quark + IF (IDLAM(LKNT,1).EQ.-6) THEN + RM2=3*RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 + & * (SM-SMT) + XLAM(LKNT) = + & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,3) +C...If no top quark, all decay products massless + ELSE + RM2=3*RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM + XLAM(LKNT) = + & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4) + ENDIF +C...KINEMATICS CHECK + IF (XLAM(LKNT).EQ.0D0) THEN + LKNT=LKNT-1 + ENDIF + ENDIF + 140 CONTINUE + 150 CONTINUE + ENDIF +C * SNEUTRINO -> LEPTON+ + LEPTON- and DBAR + D +C...No right-handed neutrinos + IF(ICNT.EQ.1) THEN + IF(KFSM.EQ.12.OR.KFSM.EQ.14.OR.KFSM.EQ.16) THEN + J=INT((KFSM-10)/2) + DO 170 I=1,3 + DO 160 K=1,3 + IF (I.NE.J) THEN +C...~nu_J -> lepton+_I + lepton-_K + LKNT = LKNT+1 + IDLAM(LKNT,1)=-11 -2*(I-1) + IDLAM(LKNT,2)= 11 +2*(K-1) + IDLAM(LKNT,3)= 0 + XLAM(LKNT)=0D0 + RM2=RVLAM(I,J,K)**2 * SM + IF (IMSS(51).NE.0) XLAM(LKNT) = + & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4) +C...KINEMATICS CHECK + IF (XLAM(LKNT).EQ.0D0) THEN + LKNT=LKNT-1 + ENDIF + ENDIF + 160 CONTINUE + 170 CONTINUE +C...~nu_I -> dbar_J + d_K + I=INT((KFSM-10)/2) + DO 190 J=1,3 + DO 180 K=1,3 + LKNT = LKNT+1 + IDLAM(LKNT,1)=-1 -2*(J-1) + IDLAM(LKNT,2)= 1 +2*(K-1) + IDLAM(LKNT,3)= 0 + XLAM(LKNT)=0D0 + RM2=3*RVLAMP(I,J,K)**2 * SM + IF (IMSS(52).NE.0) XLAM(LKNT) = + & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4) +C...KINEMATICS CHECK + IF (XLAM(LKNT).EQ.0D0) THEN + LKNT=LKNT-1 + ENDIF + 180 CONTINUE + 190 CONTINUE + ENDIF + ENDIF +C * SDOWN -> NU(BAR) + D and LEPTON- + U + IF(ICNT.NE.0.AND.(KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5)) THEN + J=INT((KFSM+1)/2) + DO 210 I=1,3 + DO 200 K=1,3 +C...~d_J -> nu_Ibar + d_K + LKNT = LKNT+1 + IDLAM(LKNT,1)=-12 -2*(I-1) + IDLAM(LKNT,2)= 1 +2*(K-1) + IDLAM(LKNT,3)= 0 + XLAM(LKNT)=0D0 + RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM + IF (IMSS(52).NE.0) XLAM(LKNT) = + & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4) +C...KINEMATICS CHECK + IF (XLAM(LKNT).EQ.0D0) THEN + LKNT=LKNT-1 + ENDIF + 200 CONTINUE + 210 CONTINUE + K=INT((KFSM+1)/2) + DO 240 I=1,3 + DO 230 J=1,3 +C...~d_K -> nu_I + d_J + LKNT = LKNT+1 + IDLAM(LKNT,1)= 12 +2*(I-1) + IDLAM(LKNT,2)= 1 +2*(J-1) + IDLAM(LKNT,3)= 0 + XLAM(LKNT)=0D0 + RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM + IF (IMSS(52).NE.0) XLAM(LKNT) = + & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4) +C...KINEMATICS CHECK + IF (XLAM(LKNT).EQ.0D0) THEN + LKNT=LKNT-1 + ENDIF +C...~d_K -> lepton_I- + u_J + 220 LKNT = LKNT+1 + IDLAM(LKNT,1)= 11 +2*(I-1) + IDLAM(LKNT,2)= 2 +2*(J-1) + IDLAM(LKNT,3)= 0 + XLAM(LKNT)=0D0 + IF (IMSS(52).NE.0) THEN +C...Use massive top quark + IF (IDLAM(LKNT,2).EQ.6) THEN + RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2*(SM-SMT) + XLAM(LKNT) = + & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,2) +C...If no top quark, all decay products massless + ELSE + RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM + XLAM(LKNT) = + & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4) + ENDIF +C...KINEMATICS CHECK + IF (XLAM(LKNT).EQ.0D0) THEN + LKNT=LKNT-1 + ENDIF + ENDIF + 230 CONTINUE + 240 CONTINUE + ENDIF +C * SUP -> LEPTON+ + D + IF(ICNT.NE.0.AND.(KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6)) THEN + J=NINT(KFSM/2.) + DO 260 I=1,3 + DO 250 K=1,3 +C...~u_J -> lepton_I+ + d_K + LKNT = LKNT+1 + IDLAM(LKNT,1)=-11 -2*(I-1) + IDLAM(LKNT,2)= 1 +2*(K-1) + IDLAM(LKNT,3)= 0 + XLAM(LKNT)=0D0 + RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM + IF (IMSS(52).NE.0) XLAM(LKNT) = + & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4) +C...KINEMATICS CHECK + IF (XLAM(LKNT).EQ.0D0) THEN + LKNT=LKNT-1 + ENDIF + 250 CONTINUE + 260 CONTINUE + ENDIF + ENDIF +C...BARYON NUMBER VIOLATING DECAYS + IF (IMSS(53).GE.1) THEN +C * SUP -> DBAR + DBAR + IF(ICNT.NE.0.AND.(KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6)) THEN + I = KFSM/2 + DO 280 J=1,3 + DO 270 K=1,3 +C...~u_I -> dbar_J + dbar_K + IF (J.LT.K) THEN +C...(anti-) symmetry J <-> K. + LKNT = LKNT + 1 + IDLAM(LKNT,1) = -1 -2*(J-1) + IDLAM(LKNT,2) = -1 -2*(K-1) + IDLAM(LKNT,3) = 0 + XLAM(LKNT) = 0D0 + RM2 = 2.*(RVLAMB(I,J,K)**2) + & * SFMIX(KFSM,2*ICNT)**2 * SM + XLAM(LKNT) = + & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4) +C...KINEMATICS CHECK + IF (XLAM(LKNT).EQ.0D0) THEN + LKNT = LKNT-1 + ENDIF + ENDIF + 270 CONTINUE + 280 CONTINUE + ENDIF +C * SDOWN -> UBAR + DBAR + IF(ICNT.NE.0.AND.(KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5)) THEN + K=(KFSM+1)/2 + DO 300 I=1,3 + DO 290 J=1,3 +C...LAMB coupling antisymmetric in J and K. + IF (J.NE.K) THEN +C...~d_K -> ubar_I + dbar_K + LKNT = LKNT + 1 + IDLAM(LKNT,1)= -2 -2*(I-1) + IDLAM(LKNT,2)= -1 -2*(J-1) + IDLAM(LKNT,3)= 0 + XLAM(LKNT)=0D0 +C...Use massive top quark + IF (IDLAM(LKNT,1).EQ.-6) THEN + RM2=2*RVLAMB(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2*(SM-SMT + & ) + XLAM(LKNT) = + & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,3) +C...If no top quark, all decay products massless + ELSE + RM2=2*RVLAMB(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM + XLAM(LKNT) = + & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4) + ENDIF +C...KINEMATICS CHECK + IF (XLAM(LKNT).EQ.0D0) THEN + LKNT=LKNT-1 + ENDIF + ENDIF + 290 CONTINUE + 300 CONTINUE + ENDIF + ENDIF + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYRVNE +C...Calculates R-violating neutralino decay widths (pure 1->3 parts). +C...P. Z. Skands + + SUBROUTINE PYRVNE(KFIN,XLAM,IDLAM,LKNT) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) + COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), + &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) + COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3) +C...Local variables. + COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2 + & ,DCMASS,KFR(3) + DOUBLE PRECISION XLAM(0:400) + DOUBLE PRECISION ZPMIX(4,4), NMIX(4,4), RMQ(6) + INTEGER IDLAM(400,3), PYCOMP + LOGICAL DCMASS + SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/ + +C...R-VIOLATING DECAYS + IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN + KFSM=KFIN-KSUSY1 + IF(KFSM.EQ.22.OR.KFSM.EQ.23.OR.KFSM.EQ.25.OR.KFSM.EQ.35) THEN +C...WHICH NEUTRALINO ? + NCHI=1 + IF (KFSM.EQ.23) NCHI=2 + IF (KFSM.EQ.25) NCHI=3 + IF (KFSM.EQ.35) NCHI=4 +C...SIGN OF MASS (Opposite convention as HERWIG) + ISM = 1 + IF (SMZ(NCHI).LT.0D0) ISM = -ISM + +C...Useful parameters for the calculation of the A and B constants. + WMASS = PMAS(PYCOMP(24),1) + ECHG = 2*SQRT(PARU(103)*PARU(1)) + COSB=1/(SQRT(1+RMSS(5)**2)) + SINB=RMSS(5)/SQRT(1+RMSS(5)**2) + COSW=SQRT(1-PARU(102)) + SINW=SQRT(PARU(102)) + GW=2D0*SQRT(PARU(103)*PARU(1))/SINW +C...Run quark masses to neutralino mass squared (for Higgs-type +C...couplings) + SQMCHI=PMAS(PYCOMP(KFIN),1)**2 + DO 100 I=1,6 + RMQ(I)=PYMRUN(I,SQMCHI) + 100 CONTINUE +C...EXPRESS NEUTRALINO MIXING IN (photino,Zino,~H_u,~H_d) BASIS + DO 110 NCHJ=1,4 + ZPMIX(NCHJ,1)= ZMIX(NCHJ,1)*COSW+ZMIX(NCHJ,2)*SINW + ZPMIX(NCHJ,2)=-ZMIX(NCHJ,1)*SINW+ZMIX(NCHJ,2)*COSW + ZPMIX(NCHJ,3)= ZMIX(NCHJ,3) + ZPMIX(NCHJ,4)= ZMIX(NCHJ,4) + 110 CONTINUE + C1=GW*ZPMIX(NCHI,3)/(2D0*COSB*WMASS) + C1U=GW*ZPMIX(NCHI,4)/(2D0*SINB*WMASS) + C2=ECHG*ZPMIX(NCHI,1) + C3=GW*ZPMIX(NCHI,2)/COSW + EU=2D0/3D0 + ED=-1D0/3D0 +C... AB(x,y,z): +C x=1-2 : Select A or B constant (1:A ; 2:B) +C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ; +C 11-16:e,nu_e,mu,...) +C z=1-2 : Mass eigenstate number +C...CALCULATE COUPLINGS + DO 120 I = 11,15,2 + CMS=PMAS(PYCOMP(I),1) +C...Intermediate sleptons + AB(1,I,1)=ISM*(CMS*C1*SFMIX(I,1) + SFMIX(I,2) + & *(C2-C3*SINW**2)) + AB(1,I,2)=ISM*(CMS*C1*SFMIX(I,3) + SFMIX(I,4) + & *(C2-C3*SINW**2)) + AB(2,I,1)= CMS*C1*SFMIX(I,2) - SFMIX(I,1)*(C2+C3*(5D-1-SINW + & **2)) + AB(2,I,2)=CMS*C1*SFMIX(I,4) - SFMIX(I,3)*(C2+C3*(5D-1-SINW + & **2)) +C...Inermediate sneutrinos + AB(1,I+1,1)=0D0 + AB(2,I+1,1)=5D-1*C3 + AB(1,I+1,2)=0D0 + AB(2,I+1,2)=0D0 +C...Inermediate sdown + J=I-10 + CMS=RMQ(J) + AB(1,J,1)=ISM*(CMS*C1*SFMIX(J,1) - SFMIX(J,2) + & *ED*(C2-C3*SINW**2)) + AB(1,J,2)=ISM*(CMS*C1*SFMIX(J,3) - SFMIX(J,4) + & *ED*(C2-C3*SINW**2)) + AB(2,J,1)=CMS*C1*SFMIX(J,2) + SFMIX(J,1) + & *(ED*C2-C3*(1D0/2D0+ED*SINW**2)) + AB(2,J,2)=CMS*C1*SFMIX(J,4) + SFMIX(J,3) + & *(ED*C2-C3*(1D0/2D0+ED*SINW**2)) +C...Inermediate sup + J=J+1 + CMS=RMQ(J) + AB(1,J,1)=ISM*(CMS*C1U*SFMIX(J,1) - SFMIX(J,2) + & *EU*(C2-C3*SINW**2)) + AB(1,J,2)=ISM*(CMS*C1U*SFMIX(J,3) - SFMIX(J,4) + & *EU*(C2-C3*SINW**2)) + AB(2,J,1)=CMS*C1U*SFMIX(J,2) + SFMIX(J,1) + & *(EU*C2+C3*(1D0/2D0-EU*SINW**2)) + AB(2,J,2)=CMS*C1U*SFMIX(J,4) + SFMIX(J,3) + & *(EU*C2+C3*(1D0/2D0-EU*SINW**2)) + 120 CONTINUE + + IF (IMSS(51).GE.1) THEN +C...LAMBDA COUPLINGS (LLE TYPE R-VIOLATION) +C * CHI0_I -> NUBAR_I + LEPTON+_J + lEPTON-_K. +C...STEP IN I,J,K USING SINGLE COUNTER + DO 130 ISC=0,26 +C...LAMBDA COUPLING ASYM IN I,J + IF(MOD(ISC/9,3).NE.MOD(ISC/3,3)) THEN + LKNT = LKNT+1 + IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3) + IDLAM(LKNT,2) =-11 -2*MOD(ISC/3,3) + IDLAM(LKNT,3) = 11 +2*MOD(ISC,3) + XLAM(LKNT) = 0D0 +C...Set coupling, and decay product masses on/off + RVLAMC = RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1 + & ,MOD(ISC,3)+1)**2 + DCMASS=.FALSE. + IF (IDLAM(LKNT,2).EQ.-15.OR.IDLAM(LKNT,3).EQ.15) + & DCMASS = .TRUE. +C...Resonance KF codes (1=I,2=J,3=K) + KFR(1)=-IDLAM(LKNT,1) + KFR(2)=-IDLAM(LKNT,2) + KFR(3)=-IDLAM(LKNT,3) +C...Calculate width. + CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2), + & IDLAM(LKNT,3),XLAM(LKNT)) + XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32) +C...Charge conjugate mode. + LKNT=LKNT+1 + IDLAM(LKNT,1)=-IDLAM(LKNT-1,1) + IDLAM(LKNT,2)=-IDLAM(LKNT-1,2) + IDLAM(LKNT,3)=-IDLAM(LKNT-1,3) + XLAM(LKNT)=XLAM(LKNT-1) +C...KINEMATICS CHECK + IF (XLAM(LKNT).EQ.0D0) THEN + LKNT=LKNT-2 + ENDIF + ENDIF + 130 CONTINUE + ENDIF + + IF (IMSS(52).GE.1) THEN +C...LAMBDA' COUPLINGS. (LQD TYPE R-VIOLATION) +C * CHI0 -> NUBAR_I + DBAR_J + D_K + DO 140 ISC=0,26 + LKNT = LKNT+1 + IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3) + IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3) + IDLAM(LKNT,3) = 1 +2*MOD(ISC,3) + XLAM(LKNT) = 0D0 +C...Set coupling, and decay product masses on/off + RVLAMC = 3 * RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1 + & ,MOD(ISC,3)+1)**2 + DCMASS=.FALSE. + IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.5) + & DCMASS = .TRUE. +C...Resonance KF codes (1=I,2=J,3=K) + KFR(1)=-IDLAM(LKNT,1) + KFR(2)=-IDLAM(LKNT,2) + KFR(3)=-IDLAM(LKNT,3) +C...Calculate width. + CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3) + & ,XLAM(LKNT)) + XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32) +C...Charge conjugate mode. + LKNT=LKNT+1 + IDLAM(LKNT,1)=-IDLAM(LKNT-1,1) + IDLAM(LKNT,2)=-IDLAM(LKNT-1,2) + IDLAM(LKNT,3)=-IDLAM(LKNT-1,3) + XLAM(LKNT)=XLAM(LKNT-1) +C...KINEMATICS CHECK + IF (XLAM(LKNT).EQ.0D0) THEN + LKNT=LKNT-2 + ENDIF + +C * CHI0 -> LEPTON_I+ + UBAR_J + D_K + LKNT = LKNT+1 + IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3) + IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3) + IDLAM(LKNT,3) = 1 +2*MOD(ISC,3) + XLAM(LKNT) = 0D0 +C...Set coupling, and decay product masses on/off + RVLAMC = 3 * RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1 + & ,MOD(ISC,3)+1)**2 + DCMASS=.FALSE. + IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-6 + & .OR.IDLAM(LKNT,3).EQ.5) DCMASS=.TRUE. +C...Resonance KF codes (1=I,2=J,3=K) + KFR(1)=-IDLAM(LKNT,1) + KFR(2)=-IDLAM(LKNT,2) + KFR(3)=-IDLAM(LKNT,3) +C...Calculate width. + CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3) + & ,XLAM(LKNT)) + XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32) +C...Charge conjugate mode. + LKNT=LKNT+1 + IDLAM(LKNT,1)=-IDLAM(LKNT-1,1) + IDLAM(LKNT,2)=-IDLAM(LKNT-1,2) + IDLAM(LKNT,3)=-IDLAM(LKNT-1,3) + XLAM(LKNT)=XLAM(LKNT-1) +C...KINEMATICS CHECK + IF (XLAM(LKNT).EQ.0D0) THEN + LKNT=LKNT-2 + ENDIF + 140 CONTINUE + ENDIF + + IF (IMSS(53).GE.1) THEN +C...LAMBDA'' COUPLINGS. (UDD TYPE R-VIOLATION) +C * CHI0 -> UBAR_I + DBAR_J + DBAR_K + DO 150 ISC=0,26 +C...Symmetry J<->K. Also, LAMB antisymmetric in J and K, so no J=K. + IF (MOD(ISC/3,3).LT.MOD(ISC,3)) THEN + LKNT = LKNT+1 + IDLAM(LKNT,1) = -2 -2*MOD(ISC/9,3) + IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3) + IDLAM(LKNT,3) = -1 -2*MOD(ISC,3) + XLAM(LKNT) = 0D0 +C...Set coupling, and decay product masses on/off + RVLAMC = 6. * RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3) + & +1,MOD(ISC,3)+1)**2 + DCMASS=.FALSE. + IF (IDLAM(LKNT,1).EQ.-6.OR.IDLAM(LKNT,2).EQ.-5 + & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS=.TRUE. +C...Resonance KF codes (1=I,2=J,3=K) + KFR(1) = IDLAM(LKNT,1) + KFR(2) = IDLAM(LKNT,2) + KFR(3) = IDLAM(LKNT,3) +C...Calculate width. + CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2), + & IDLAM(LKNT,3),XLAM(LKNT)) + XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32) +C...Charge conjugate mode. + LKNT=LKNT+1 + IDLAM(LKNT,1)=-IDLAM(LKNT-1,1) + IDLAM(LKNT,2)=-IDLAM(LKNT-1,2) + IDLAM(LKNT,3)=-IDLAM(LKNT-1,3) + XLAM(LKNT)=XLAM(LKNT-1) +C...KINEMATICS CHECK + IF (XLAM(LKNT).EQ.0D0) THEN + LKNT=LKNT-2 + ENDIF + ENDIF + 150 CONTINUE + ENDIF + ENDIF + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYRVCH +C...Calculates R-violating chargino decay widths. +C...P. Z. Skands + + SUBROUTINE PYRVCH(KFIN,XLAM,IDLAM,LKNT) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) + COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), + &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) + COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3) +C...Local variables. + DOUBLE PRECISION XLAM(0:400) + INTEGER IDLAM(400,3), PYCOMP +C...Information from main routine to PYRVGW + COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2 + & ,DCMASS,KFR(3) +C...Auxiliary variables needed for BV (RV Gauge STOre) + COMMON/RVGSTO/XRESI,XRESJ,XRESK,XRESIJ,XRESIK,XRESJK,RVLIJK,RVLKIJ + & ,RVLJKI,RVLJIK +C...Running quark masses + DOUBLE PRECISION RMQ(6) +C...Decay product masses on/off + LOGICAL DCMASS + SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/, + & /RVGSTO/ + + +C...IF R-VIOLATION ON. + IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN + KFSM=KFIN-KSUSY1 + IF(KFSM.EQ.24.OR.KFSM.EQ.37) THEN +C...WHICH CHARGINO ? + NCHI = 1 + IF (KFSM.EQ.37) NCHI = 2 + +C...Useful parameters for calculating the A and B constants. +C...SIGN OF MASS (Opposite convention as HERWIG) + ISM = 1 + IF (SMW(NCHI).LT.0D0) ISM = -1 + WMASS = PMAS(PYCOMP(24),1) + COSB = 1/(SQRT(1+RMSS(5)**2)) + SINB = RMSS(5)/SQRT(1+RMSS(5)**2) + GW2 = 4*PARU(103)*PARU(1)/PARU(102) + C1U = UMIX(NCHI,2)/(SQRT(2D0)*COSB*WMASS) + C1V = VMIX(NCHI,2)/(SQRT(2D0)*SINB*WMASS) + C2 = UMIX(NCHI,1) + C3 = VMIX(NCHI,1) +C...Running masses at Q^2=MCHI^2. + SQMCHI = PMAS(PYCOMP(KFSM),1)**2 + DO 100 I=1,6 + RMQ(I)=PYMRUN(I,SQMCHI) + 100 CONTINUE + +C... AB(x,y,z) coefficients: +C x=1-2 : A or B coefficient (1:A ; 2:B) +C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ; +C 11-16:e,nu_e,mu,...) +C z=1-2 : Mass eigenstate number + DO 110 I = 11,15,2 +C...Intermediate sleptons + AB(1,I,1) = 0D0 + AB(1,I,2) = 0D0 + AB(2,I,1) = -PMAS(PYCOMP(I),1)*C1U*SFMIX(I,2) + + & SFMIX(I,1)*C2 + AB(2,I,2) = -PMAS(PYCOMP(I),1)*C1U*SFMIX(I,4) + + & SFMIX(I,3)*C2 +C...Intermediate sneutrinos + AB(1,I+1,1) = -PMAS(PYCOMP(I),1)*C1U + AB(1,I+1,2) = 0D0 + AB(2,I+1,1) = ISM*C3 + AB(2,I+1,2) = 0D0 +C...Intermediate sdown + J=I-10 + AB(1,J,1) = -RMQ(J+1)*C1V*SFMIX(J,1) + AB(1,J,2) = -RMQ(J+1)*C1V*SFMIX(J,3) + AB(2,J,1) = -ISM*(RMQ(J)*C1U*SFMIX(J,2) - SFMIX(J,1)*C2) + AB(2,J,2) = -ISM*(RMQ(J)*C1U*SFMIX(J,4) - SFMIX(J,3)*C2) +C...Intermediate sup + J=J+1 + AB(1,J,1) = -RMQ(J-1)*C1U*SFMIX(J,1) + AB(1,J,2) = -RMQ(J-1)*C1U*SFMIX(J,3) + AB(2,J,1) = -ISM*(RMQ(J)*C1V*SFMIX(J,2) - SFMIX(J,1)*C3) + AB(2,J,2) = -ISM*(RMQ(J)*C1V*SFMIX(J,4) - SFMIX(J,3)*C3) + 110 CONTINUE + +C...LLE TYPE R-VIOLATION + IF (IMSS(51).GE.1) THEN +C...LOOP OVER DECAY MODES + DO 140 ISC=0,26 + +C...CHI+ -> NUBAR_I + LEPTON+_J + NU_K. + IF(MOD(ISC/9,3).NE.MOD(ISC/3,3)) THEN + LKNT = LKNT+1 + IDLAM(LKNT,1) = -12 -2*MOD(ISC/9,3) + IDLAM(LKNT,2) = -11 -2*MOD(ISC/3,3) + IDLAM(LKNT,3) = 12 +2*MOD(ISC,3) + XLAM(LKNT) = 0D0 +C...Set coupling, and decay product masses on/off + RVLAMC = GW2 * 5D-1 * + & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1) + & **2 + DCMASS=.FALSE. + IF (IDLAM(LKNT,2).EQ.-15) DCMASS = .TRUE. +C...Resonance KF codes (1=I,2=J,3=K). + KFR(1) = 0 + KFR(2) = 0 + KFR(3) = -IDLAM(LKNT,3)+1 +C...Calculate width. + CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2), + & IDLAM(LKNT,3),XLAM(LKNT)) + XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32) +C...KINEMATICS CHECK + IF (XLAM(LKNT).EQ.0D0) THEN + LKNT=LKNT-1 + ENDIF + +C * CHI+ -> NU_I + NU_J + LEPTON+_K. (NOTE: SYMM. IN I AND J) + 120 IF (MOD(ISC/9,3).LT.MOD(ISC/3,3)) THEN + LKNT = LKNT+1 + IDLAM(LKNT,1) = 12 +2*MOD(ISC/9,3) + IDLAM(LKNT,2) = 12 +2*MOD(ISC/3,3) + IDLAM(LKNT,3) =-11 -2*MOD(ISC,3) + XLAM(LKNT) = 0D0 +C...Set coupling, and decay product masses on/off + RVLAMC = GW2 * 5D-1 * + & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2 +C...I,J SYMMETRY => FACTOR 2 + RVLAMC=2*RVLAMC + DCMASS=.FALSE. + IF (IDLAM(LKNT,3).EQ.-15) DCMASS = .TRUE. +C...Resonance KF codes (1=I,2=J,3=K) + KFR(1)=IDLAM(LKNT,1)-1 + KFR(2)=IDLAM(LKNT,2)-1 + KFR(3)=0 +C...Calculate width. + CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2), + & IDLAM(LKNT,3),XLAM(LKNT)) + XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32) +C...KINEMATICS CHECK + IF (XLAM(LKNT).EQ.0D0) THEN + LKNT=LKNT-1 + ENDIF + +C * CHI+ -> LEPTON+_I + LEPTON+_J + LEPTON-_K (NOTE: SYMM. IN I AND J) +C * 19/04 2010: Bug corrected. Moved channel inside the I < J IF statement +C * from above, thanks to N.-E. Bomark. + LKNT = LKNT+1 + IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3) + IDLAM(LKNT,2) =-11 -2*MOD(ISC/3,3) + IDLAM(LKNT,3) = 11 +2*MOD(ISC,3) + XLAM(LKNT) = 0D0 +C...Set coupling, and decay product masses on/off + RVLAMC = GW2 * 5D-1 * + & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2 +C...I,J SYMMETRY => FACTOR 2 + RVLAMC=2*RVLAMC + DCMASS=.FALSE. + IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-15 + & .OR.IDLAM(LKNT,3).EQ.15) DCMASS = .TRUE. +C...Resonance KF codes (1=I,2=J,3=K) + KFR(1) =-IDLAM(LKNT,1)+1 + KFR(2) =-IDLAM(LKNT,2)+1 + KFR(3) = 0 +C...Calculate width. + CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2), + & IDLAM(LKNT,3),XLAM(LKNT)) + XLAM(LKNT)=XLAM(LKNT)*RVLAMC + & /((2*PARU(1)*RMS(0))**3*32) +C...KINEMATICS CHECK + IF (XLAM(LKNT).EQ.0D0) THEN + LKNT=LKNT-1 + ENDIF + ENDIF + ENDIF + 140 CONTINUE + ENDIF + +C...LQD TYPE R-VIOLATION + IF (IMSS(52).GE.1) THEN +C...LOOP OVER DECAY MODES + DO 180 ISC=0,26 + +C...CHI+ -> NUBAR_I + DBAR_J + U_K + LKNT = LKNT+1 + IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3) + IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3) + IDLAM(LKNT,3) = 2 +2*MOD(ISC,3) + XLAM(LKNT) = 0D0 +C...Set coupling, and decay product masses on/off + RVLAMC = 3. * GW2 * 5D-1 * + & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2 + DCMASS=.FALSE. + IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.6) + & DCMASS = .TRUE. +C...Resonance KF codes (1=I,2=J,3=K) + KFR(1)=0 + KFR(2)=0 + KFR(3)=-IDLAM(LKNT,3)+1 +C...Calculate width. + CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3) + & ,XLAM(LKNT)) + XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32) +C...KINEMATICS CHECK + IF (XLAM(LKNT).EQ.0D0) THEN + LKNT=LKNT-1 + ENDIF + +C * CHI+ -> LEPTON+_I + UBAR_J + U_K. + 150 LKNT = LKNT+1 + IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3) + IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3) + IDLAM(LKNT,3) = 2 +2*MOD(ISC,3) + XLAM(LKNT) = 0D0 +C...Set coupling, and decay product masses on/off + RVLAMC = 3. * GW2 * 5D-1 * + & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2 + DCMASS=.FALSE. + IF (IDLAM(LKNT,1).EQ.-11.OR.IDLAM(LKNT,2).EQ.-6 + & .OR.IDLAM(LKNT,3).EQ.6) DCMASS = .TRUE. +C...Resonance KF codes (1=I,2=J,3=K) + KFR(1)=0 + KFR(2)=0 + KFR(3)=-IDLAM(LKNT,3)+1 +C...Calculate width. + CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3) + & ,XLAM(LKNT)) + XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32) +C...KINEMATICS CHECK + IF (XLAM(LKNT).EQ.0D0) THEN + LKNT=LKNT-1 + ENDIF + +C * CHI+ -> LEPTON+_I + DBAR_J + D_K. + 160 LKNT = LKNT+1 + IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3) + IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3) + IDLAM(LKNT,3) = 1 +2*MOD(ISC,3) + XLAM(LKNT) = 0D0 +C...Set coupling, and decay product masses on/off + RVLAMC = 3. * GW2 * 5D-1 * + & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2 + DCMASS = .FALSE. + IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-5 + & .OR.IDLAM(LKNT,3).EQ.5) DCMASS = .TRUE. +C...Resonance KF codes (1=I,2=J,3=K) + KFR(1)=-IDLAM(LKNT,1)+1 + KFR(2)=-IDLAM(LKNT,2)+1 + KFR(3)=0 +C...Calculate width. + CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3) + & ,XLAM(LKNT)) + XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32) +C...KINEMATICS CHECK + IF (XLAM(LKNT).EQ.0D0) THEN + LKNT=LKNT-1 + ENDIF + +C * CHI+ -> NU_I + U_J + DBAR_K. + 170 LKNT = LKNT+1 + IDLAM(LKNT,1) = 12 +2*MOD(ISC/9,3) + IDLAM(LKNT,2) = 2 +2*MOD(ISC/3,3) + IDLAM(LKNT,3) = -1 -2*MOD(ISC,3) + XLAM(LKNT) = 0D0 +C...Set coupling, and decay product masses on/off + DCMASS = .FALSE. + RVLAMC = 3. * GW2 * 5D-1 * + & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2 + IF (IDLAM(LKNT,2).EQ.6.OR.IDLAM(LKNT,3).EQ.-5) + & DCMASS = .TRUE. +C...Resonance KF codes (1=I,2=J,3=K) + KFR(1)=IDLAM(LKNT,1)-1 + KFR(2)=IDLAM(LKNT,2)-1 + KFR(3)=0 +C...Calculate width. + CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3) + & ,XLAM(LKNT)) + XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32) +C...KINEMATICS CHECK + IF (XLAM(LKNT).EQ.0D0) THEN + LKNT=LKNT-1 + ENDIF + + 180 CONTINUE + ENDIF + +C...UDD TYPE R-VIOLATION +C...These decays need special treatment since more than one BV coupling +C...contributes (with interference). Consider e.g. (symbolically) +C |M|^2 = |l''_{ijk}|^2*(PYRVI1(RES_I) + PYRVI2(RES_I)) +C +|l''_{jik}|^2*(PYRVI1(RES_J) + PYRVI2(RES_J)) +C +l''_{ijk}*l''_{jik}*PYRVI3(PYRVI4(RES_I,RES_J)) +C...The problem is that a single call to PYRVGW would evaluate all +C...these terms and sum them, but without the different couplings. The +C...way out is to call PYRVGW three times, once for the first line, once +C...for the second line, and then once for all the lines (it is +C...impossible to get just the last line out) without multiplying by +C...couplings. The last line is then obtained as the result of the third +C...call minus the results of the two first calls. Each term is then +C...multiplied by its respective coupling before the whole thing is +C...summed up in XLAM. +C...Note that with three interfering resonances, this procedure becomes +C...more complicated, as can be seen in the CHI+ -> 3*DBAR mode. + + IF (IMSS(53).GE.1) THEN +C...LOOP OVER DECAY MODES + DO 190 ISC=1,25 + +C...CHI+ -> U_I + U_J + D_K +C...Decay mode I<->J symmetric. + IF (MOD(ISC/9,3).LE.MOD(ISC/3,3).AND.ISC.NE.13) THEN + LKNT = LKNT+1 + IDLAM(LKNT,1) = 2 +2*MOD(ISC/9,3) + IDLAM(LKNT,2) = 2 +2*MOD(ISC/3,3) + IDLAM(LKNT,3) = 1 +2*MOD(ISC,3) + XLAM(LKNT) = 0D0 +C...Set coupling, and decay product masses on/off + RVLAMC= 6. * GW2 * 5D-1 + RVLJIK= RVLAMB(MOD(ISC/3,3)+1,MOD(ISC/9,3)+1,MOD(ISC,3) + & +1) + RVLIJK= RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3) + & +1) + IF (MOD(ISC/9,3).EQ.MOD(ISC/3,3)) RVLAMC = 5D-1 + & * RVLAMC + DCMASS=.FALSE. + IF (IDLAM(LKNT,1).EQ.6.OR.IDLAM(LKNT,2).EQ.6 + & .OR.IDLAM(LKNT,3).EQ.5) DCMASS =.TRUE. +C...Resonance KF codes (1=I,2=J,3=K) + KFR(1) = -IDLAM(LKNT,1)+1 + KFR(2) = 0 + KFR(3) = 0 +C...Calculate width. + CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2), + & IDLAM(LKNT,3),XRESI) +C...Resonance KF codes (1=I,2=J,3=K) + KFR(1) = 0 + KFR(2) = -IDLAM(LKNT,2)+1 + KFR(3) = 0 +C...Calculate width. + CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2), + & IDLAM(LKNT,3),XRESJ) +C...Resonance KF codes (1=I,2=J,3=K) + KFR(1) = -IDLAM(LKNT,1)+1 + KFR(2) = -IDLAM(LKNT,2)+1 + KFR(3) = 0 +C...Calculate width. + CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2), + & IDLAM(LKNT,3),XRESIJ) + IF (ABS(XRESI+XRESJ-XRESIJ).GT.1D-4*XRESIJ) THEN + XRESIJ = XRESIJ-XRESI-XRESJ + ELSE + XRESIJ = 0D0 + ENDIF +C...CALCULATE TOTAL WIDTH + XLAM(LKNT) = RVLJIK**2 * XRESI + RVLIJK**2 * XRESJ + & + RVLJIK*RVLIJK * XRESIJ + XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32) +C...KINEMATICS CHECK + IF (XLAM(LKNT).EQ.0D0) THEN + LKNT=LKNT-1 + ENDIF + ENDIF +C...CHI+ -> DBAR_I + DBAR_J + DBAR_K +C...Symmetry I<->J<->K. + IF ((MOD(ISC/9,3).LE.MOD(ISC/3,3)).AND.(MOD(ISC/3,3).LE + & .MOD(ISC,3)).AND.ISC.NE.13) THEN + LKNT = LKNT+1 + IDLAM(LKNT,1) = -1 -2*MOD(ISC/9,3) + IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3) + IDLAM(LKNT,3) = -1 -2*MOD(ISC,3) + XLAM(LKNT) = 0D0 +C...Set coupling, and decay product masses on/off + RVLAMC = 6. * GW2 * 5D-1 + RVLIJK = RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3) + & +1) + RVLKIJ = RVLAMB(MOD(ISC,3)+1,MOD(ISC/9,3)+1,MOD(ISC/3,3) + & +1) + RVLJKI = RVLAMB(MOD(ISC/3,3)+1,MOD(ISC,3)+1,MOD(ISC/9,3) + & +1) + DCMASS = .FALSE. + IF (IDLAM(LKNT,1).EQ.-5.OR.IDLAM(LKNT,2).EQ.-5 + & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS = .TRUE. +C...Collect symmetry factors + IF (MOD(ISC/9,3).EQ.MOD(ISC/3,3).OR.MOD(ISC/3,3).EQ + & .MOD(ISC,3).OR.MOD(ISC/9,3).EQ.MOD(ISC,3)) + & RVLAMC = 5D-1 * RVLAMC +C...Resonance KF codes (1=I,2=J,3=K) + KFR(1) = IDLAM(LKNT,1)-1 + KFR(2) = 0 + KFR(3) = 0 +C...Calculate width. + CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2), + & IDLAM(LKNT,3),XRESI) +C...Resonance KF codes (1=I,2=J,3=K) + KFR(1) = 0 + KFR(2) = IDLAM(LKNT,2)-1 + KFR(3) = 0 +C...Calculate width. + CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2), + & IDLAM(LKNT,3),XRESJ) +C...Resonance KF codes (1=I,2=J,3=K) + KFR(1) = 0 + KFR(2) = 0 + KFR(3) = IDLAM(LKNT,3)-1 +C...Calculate width. + CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2), + & IDLAM(LKNT,3),XRESK) +C...Resonance KF codes (1=I,2=J,3=K) + KFR(1) = IDLAM(LKNT,1)-1 + KFR(2) = IDLAM(LKNT,2)-1 + KFR(3) = 0 +C...Calculate width. + CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2), + & IDLAM(LKNT,3),XRESIJ) + IF (ABS(XRESI+XRESJ-XRESIJ).GT.1D-4*(XRESI+XRESJ)) THEN + XRESIJ = XRESI+XRESJ-XRESIJ + ELSE + XRESIJ = 0D0 + ENDIF +C...Resonance KF codes (1=I,2=J,3=K) + KFR(1) = 0 + KFR(2) = IDLAM(LKNT,2)-1 + KFR(3) = IDLAM(LKNT,3)-1 +C...Calculate width. + CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2), + & IDLAM(LKNT,3),XRESJK) + IF (ABS(XRESJ+XRESK-XRESJK).GT.1D-4*(XRESJ+XRESK)) THEN + XRESJK = XRESJ+XRESK-XRESJK + ELSE + XRESJK = 0D0 + ENDIF +C...Resonance KF codes (1=I,2=J,3=K) + KFR(1) = IDLAM(LKNT,1)-1 + KFR(2) = 0 + KFR(3) = IDLAM(LKNT,3)-1 +C...Calculate width. + CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2), + & IDLAM(LKNT,3),XRESIK) + IF (ABS(XRESI+XRESK-XRESIK).GT.1D-4*(XRESI+XRESK)) THEN + XRESIK = XRESI+XRESK-XRESIK + ELSE + XRESIK = 0D0 + ENDIF +C...CALCULATE TOTAL WIDTH + XLAM(LKNT) = + & RVLIJK**2 * XRESI + & + RVLJKI**2 * XRESJ + & + RVLKIJ**2 * XRESK + & + RVLIJK*RVLJKI * XRESIJ + & + RVLIJK*RVLKIJ * XRESIK + & + RVLJKI*RVLKIJ * XRESJK + XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2.*PARU(1)*RMS(0))**3*32) +C...KINEMATICS CHECK + IF (XLAM(LKNT).EQ.0D0) THEN + LKNT=LKNT-1 + ENDIF + ENDIF + 190 CONTINUE + ENDIF + ENDIF + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYRVGL +C...Calculates R-violating gluino decay widths. +C...See BV part of PYRVCH for comments about the way the BV decay width +C...is calculated. Same comments apply here. +C...P. Z. Skands + + SUBROUTINE PYRVGL(KFIN,XLAM,IDLAM,LKNT) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) + COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), + &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) + COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3) +C...Local variables. + DOUBLE PRECISION XLAM(0:400) + INTEGER IDLAM(400,3), PYCOMP +C...Information from main routine to PYRVGW + COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2 + & ,DCMASS,KFR(3) +C...Auxiliary variables needed for BV (RV Gauge STOre) + COMMON/RVGSTO/XRESI,XRESJ,XRESK,XRESIJ,XRESIK,XRESJK,RVLIJK,RVLKIJ + & ,RVLJKI,RVLJIK +C...Running quark masses + DOUBLE PRECISION RMQ(6) +C...Decay product masses on/off + LOGICAL DCMASS + SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/, + & /RVGSTO/ + +C...IF LQD OR UDD TYPE R-VIOLATION ON. + IF (IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN + KFSM=KFIN-KSUSY1 + +C... AB(x,y,z): +C x=1-2 : Select A or B coupling (1:A ; 2:B) +C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ; +C 11-16:e,nu_e,mu,... not used here) +C z=1-2 : Mass eigenstate number + DO 100 I = 1,6 +C...A Couplings + AB(1,I,1) = SFMIX(I,2) + AB(1,I,2) = SFMIX(I,4) +C...B Couplings + AB(2,I,1) = -SFMIX(I,1) + AB(2,I,2) = -SFMIX(I,3) + 100 CONTINUE + GSTR2 = 4D0*PARU(1) * PYALPS(PMAS(PYCOMP(KFIN),1)**2) +C...LQD DECAYS. + IF (IMSS(52).GE.1) THEN +C...STEP IN I,J,K USING SINGLE COUNTER + DO 120 ISC=0,26 +C * GLUINO -> NUBAR_I + DBAR_J + D_K. + LKNT = LKNT+1 + IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3) + IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3) + IDLAM(LKNT,3) = 1 +2*MOD(ISC,3) + XLAM(LKNT)=0D0 +C...Set coupling, and decay product masses on/off + RVLAMC=RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2 + & * 5D-1 * GSTR2 + DCMASS = .FALSE. + IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.5) DCMASS=.TRUE. +C...Resonance KF codes (1=I,2=J,3=K) + KFR(1) = 0 + KFR(2) = -IDLAM(LKNT,2) + KFR(3) = -IDLAM(LKNT,3) +C...Calculate width. + CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3) + & ,XLAM(LKNT)) +C...Normalize + XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32) +C...Charge conjugate mode. + 110 LKNT = LKNT+1 + IDLAM(LKNT,1) =-IDLAM(LKNT-1,1) + IDLAM(LKNT,2) =-IDLAM(LKNT-1,2) + IDLAM(LKNT,3) =-IDLAM(LKNT-1,3) + XLAM(LKNT) = XLAM(LKNT-1) +C...KINEMATICS CHECK + IF (XLAM(LKNT).EQ.0D0) THEN + LKNT=LKNT-2 + ENDIF + +C * GLUINO -> LEPTON+_I + UBAR_J + D_K + LKNT = LKNT+1 + IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3) + IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3) + IDLAM(LKNT,3) = 1 +2*MOD(ISC,3) + XLAM(LKNT)=0D0 +C...Set coupling, and decay product masses on/off + RVLAMC = RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1) + & **2* 5D-1 * GSTR2 + DCMASS = .FALSE. + IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-6 + & .OR.IDLAM(LKNT,3).EQ.5) DCMASS = .TRUE. +C...Resonance KF codes (1=I,2=J,3=K) + KFR(1) = 0 + KFR(2) = -IDLAM(LKNT,2) + KFR(3) = -IDLAM(LKNT,3) +C...Calculate width. + CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3) + & ,XLAM(LKNT)) + XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32) +C...Charge conjugate mode. + LKNT=LKNT+1 + IDLAM(LKNT,1) = -IDLAM(LKNT-1,1) + IDLAM(LKNT,2) = -IDLAM(LKNT-1,2) + IDLAM(LKNT,3) = -IDLAM(LKNT-1,3) + XLAM(LKNT) = XLAM(LKNT-1) +C...KINEMATICS CHECK + IF (XLAM(LKNT).EQ.0D0) THEN + LKNT=LKNT-2 + ENDIF + + 120 CONTINUE + ENDIF + +C...UDD DECAYS. + IF (IMSS(53).GE.1) THEN +C...STEP IN I,J,K USING SINGLE COUNTER + DO 130 ISC=0,26 +C * GLUINO -> UBAR_I + DBAR_J + DBAR_K. + IF (MOD(ISC/3,3).LT.MOD(ISC,3)) THEN + LKNT = LKNT+1 + IDLAM(LKNT,1) = -2 -2*MOD(ISC/9,3) + IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3) + IDLAM(LKNT,3) = -1 -2*MOD(ISC,3) + XLAM(LKNT)=0D0 +C...Set coupling, and decay product masses on/off. A factor of 2 for +C...(N_C-1) has been used to cancel a factor 0.5. + RVLAMC=RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1) + & **2 * GSTR2 + DCMASS = .FALSE. + IF (IDLAM(LKNT,1).EQ.-6.OR.IDLAM(LKNT,2).EQ.-5 + & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS=.TRUE. +C...Resonance KF codes (1=I,2=J,3=K) + KFR(1) = IDLAM(LKNT,1) + KFR(2) = 0 + KFR(3) = 0 +C...Calculate width. + CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3) + & ,XRESI) +C...Resonance KF codes (1=I,2=J,3=K) + KFR(1) = 0 + KFR(2) = IDLAM(LKNT,2) + KFR(3) = 0 +C...Calculate width. + CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3) + & ,XRESJ) +C...Resonance KF codes (1=I,2=J,3=K) + KFR(1) = 0 + KFR(2) = 0 + KFR(3) = IDLAM(LKNT,3) +C...Calculate width. + CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3) + & ,XRESK) +C...Resonance KF codes (1=I,2=J,3=K) + KFR(1) = IDLAM(LKNT,1) + KFR(2) = IDLAM(LKNT,2) + KFR(3) = 0 +C...Calculate width. + CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3) + & ,XRESIJ) +C...Calculate interference function. (Factor -1/2 to make up for factor +C...-2 in PYRVGW. + IF (ABS(XRESI+XRESJ-XRESIJ).GT.1D-4*XRESIJ) THEN + XRESIJ = 5D-1 * (XRESI+XRESJ-XRESIJ) + ELSE + XRESIJ = 0D0 + ENDIF +C...Resonance KF codes (1=I,2=J,3=K) + KFR(1) = 0 + KFR(2) = IDLAM(LKNT,2) + KFR(3) = IDLAM(LKNT,3) +C...Calculate width. + CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3) + & ,XRESJK) + IF (ABS(XRESJ+XRESK-XRESJK).GT.1D-4*XRESJK) THEN + XRESJK = 5D-1 * (XRESJ+XRESK-XRESJK) + ELSE + XRESJK = 0D0 + ENDIF +C...Resonance KF codes (1=I,2=J,3=K) + KFR(1) = IDLAM(LKNT,1) + KFR(2) = 0 + KFR(3) = IDLAM(LKNT,3) +C...Calculate width. + CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3) + & ,XRESIK) + IF (ABS(XRESI+XRESK-XRESIK).GT.1D-4*XRESIK) THEN + XRESIK = 5D-1 * (XRESI+XRESK-XRESIK) + ELSE + XRESIK = 0D0 + ENDIF +C...Calculate total width (factor 1/2 from 1/(N_C-1)) + XLAM(LKNT) = XRESI + XRESJ + XRESK + & + 5D-1 * (XRESIJ + XRESIK + XRESJK) +C...Normalize + XLAM(LKNT) = XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32) +C...Charge conjugate mode. + LKNT = LKNT+1 + IDLAM(LKNT,1) =-IDLAM(LKNT-1,1) + IDLAM(LKNT,2) =-IDLAM(LKNT-1,2) + IDLAM(LKNT,3) =-IDLAM(LKNT-1,3) + XLAM(LKNT) = XLAM(LKNT-1) +C...KINEMATICS CHECK + IF (XLAM(LKNT).EQ.0D0) THEN + LKNT=LKNT-2 + ENDIF + ENDIF + 130 CONTINUE + ENDIF + ENDIF + RETURN + END + +C********************************************************************* + +C...PYRVSB +C...Auxiliary function to PYRVSF for calculating R-Violating +C...sfermion widths. Though the decay products are most often treated +C...as massless in the calculation, the kinematical boundary of phase +C...space is tested using the true masses. +C...MODE = 1: All decay products massive +C...MODE = 2: Decay product 1 massless +C...MODE = 3: Decay product 2 massless +C...MODE = 4: All decay products massless + + FUNCTION PYRVSB(KFIN,ID1,ID2,RM2,MODE) + + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + IMPLICIT INTEGER (I-N) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /PYDAT1/,/PYDAT2/ + DOUBLE PRECISION SM(3) + INTEGER PYCOMP, KC(3) + KC(1)=PYCOMP(KFIN) + KC(2)=PYCOMP(ID1) + KC(3)=PYCOMP(ID2) + SM(1)=PMAS(KC(1),1)**2 + SM(2)=PMAS(KC(2),1)**2 + SM(3)=PMAS(KC(3),1)**2 +C...Kinematics check + IF ((SM(1)-(PMAS(KC(2),1)+PMAS(KC(3),1))**2).LE.0D0) THEN + PYRVSB=0D0 + RETURN + ENDIF +C...CM momenta squared + IF (MODE.EQ.1) THEN + P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(2),1)+PMAS(KC(3),1))**2) + & * (SM(1)-(PMAS(KC(2),1)-PMAS(KC(3),1))**2) + ELSE IF (MODE.EQ.2) THEN + P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(3),1))**2)**2 + ELSE IF (MODE.EQ.3) THEN + P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(2),1))**2)**2 + ELSE + P2CM=SM(1)/4. + ENDIF +C...Calculate Width + PYRVSB=RM2*SQRT(MAX(0D0,P2CM))/(8*PARU(1)*SM(1)) + RETURN + END + +C********************************************************************* + +C...PYRVGW +C...Generalized Matrix Element for R-Violating 3-body widths. +C...P. Z. Skands + SUBROUTINE PYRVGW(KFIN,ID1,ID2,ID3,XLAM) + + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + IMPLICIT INTEGER (I-N) + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) + PARAMETER (EPS=1D-4) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2 + & ,DCMASS,KFR(3) + COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), + & SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) + DOUBLE PRECISION XLIM(3,3) + INTEGER KC(0:3), PYCOMP + LOGICAL DCMASS, DCHECK(6) + SAVE /PYDAT2/,/PYRVNV/,/PYSSMT/ + + XLAM = 0D0 + + KC(0) = PYCOMP(KFIN) + KC(1) = PYCOMP(ID1) + KC(2) = PYCOMP(ID2) + KC(3) = PYCOMP(ID3) + RMS(0) = PMAS(KC(0),1) + RMS(1) = PYMRUN(ID1,PMAS(KC(1),1)**2) + RMS(2) = PYMRUN(ID2,PMAS(KC(2),1)**2) + RMS(3) = PYMRUN(ID3,PMAS(KC(3),1)**2) +C...INITIALIZE OUTER INTEGRATION LIMITS AND KINEMATICS CHECK + XLIM(1,1)=(RMS(1)+RMS(2))**2 + XLIM(1,2)=(RMS(0)-RMS(3))**2 + XLIM(1,3)=XLIM(1,2)-XLIM(1,1) + XLIM(2,1)=(RMS(2)+RMS(3))**2 + XLIM(2,2)=(RMS(0)-RMS(1))**2 + XLIM(2,3)=XLIM(2,2)-XLIM(2,1) + XLIM(3,1)=(RMS(1)+RMS(3))**2 + XLIM(3,2)=(RMS(0)-RMS(2))**2 + XLIM(3,3)=XLIM(3,2)-XLIM(3,1) +C...Check Phase Space + IF (XLIM(1,3).LT.0D0.OR.XLIM(2,3).LT.0D0.OR.XLIM(3,3).LT.0D0) THEN + RETURN + ENDIF + +C...INITIALIZE RESONANCE INFORMATION + DO 110 JRES = 1,3 + DO 100 IMASS = 1,2 + IRES = 2*(JRES-1)+IMASS + INTRES(IRES,1) = 0 + DCHECK(IRES) =.FALSE. +C...NO RIGHT-HANDED NEUTRINOS + IF (((IMASS.EQ.2).AND.((IABS(KFR(JRES)).EQ.12).OR + & .(IABS(KFR(JRES)).EQ.14).OR.(IABS(KFR(JRES)).EQ.16))).OR + & .KFR(JRES).EQ.0) GOTO 100 + RES(IRES,1) = PMAS(PYCOMP(IMASS*KSUSY1+IABS(KFR(JRES))),1) + RES(IRES,2) = PMAS(PYCOMP(IMASS*KSUSY1+IABS(KFR(JRES))),2) + INTRES(IRES,1) = IABS(KFR(JRES)) + INTRES(IRES,2) = IMASS + IF (KFR(JRES).LT.0) INTRES(IRES,3) = 1 + IF (KFR(JRES).GT.0) INTRES(IRES,3) = 0 + 100 CONTINUE + 110 CONTINUE + +C...SUM OVER DIAGRAMS AND INTEGRATE OVER PHASE SPACE + +C...RESONANCE CONTRIBUTIONS +C...(Only sum contributions where the resonance is off shell). +C...Store whether diagram on/off in DCHECK. +C...LOOP OVER MASS STATES + DO 120 J=1,2 + IDR=J + IF(INTRES(IDR,1).NE.0) THEN + + TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2 + IF ((RMS(0).LT.(RMS(1)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(2) + & +RMS(3)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN + DCHECK(IDR) =.TRUE. + XLAM = XLAM + TMIX * PYRVI1(2,3,1) + ENDIF + ENDIF + + IDR=J+2 + IF(INTRES(IDR,1).NE.0) THEN + TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2 + IF ((RMS(0).LT.(RMS(2)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(1) + & +RMS(3)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN + DCHECK(IDR) =.TRUE. + XLAM = XLAM + TMIX * PYRVI1(1,3,2) + ENDIF + ENDIF + + IDR=J+4 + IF(INTRES(IDR,1).NE.0) THEN + TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2 + IF ((RMS(0).LT.(RMS(3)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(1) + & +RMS(2)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN + DCHECK(IDR) =.TRUE. + XLAM = XLAM + TMIX * PYRVI1(1,2,3) + ENDIF + ENDIF + 120 CONTINUE +C... L-R INTERFERENCES +C... (Only add contributions where both contributing diagrams +C... are non-resonant). + IDR=1 + IF (DCHECK(1).AND.DCHECK(2)) THEN +C...Bug corrected 11/12 2001. Skands. + XLAM = XLAM + 2D0 * PYRVI2(2,3,1) + & * SFMIX(INTRES(1,1),2+INTRES(1,3)-1) + & * SFMIX(INTRES(2,1),4+INTRES(2,3)-1) + ENDIF + + IDR=3 + IF (DCHECK(3).AND.DCHECK(4)) THEN + XLAM = XLAM + 2D0 * PYRVI2(1,3,2) + & * SFMIX(INTRES(3,1),2+INTRES(3,3)-1) + & * SFMIX(INTRES(4,1),4+INTRES(4,3)-1) + ENDIF + + IDR=5 + IF (DCHECK(5).AND.DCHECK(6)) THEN + XLAM = XLAM + 2D0 * PYRVI2(1,2,3) + & * SFMIX(INTRES(5,1),2+INTRES(5,3)-1) + & * SFMIX(INTRES(6,1),4+INTRES(6,3)-1) + ENDIF +C... TRUE INTERFERENCES +C... (Only add contributions where both contributing diagrams +C... are non-resonant). + PREF=-2D0 + IF ((KFIN-KSUSY1).EQ.24.OR.(KFIN-KSUSY1).EQ.37) PREF=2D0 + DO 140 IKR1 = 1,2 + DO 130 IKR2 = 1,2 + IDR = IKR1+2 + IDR2 = IKR2 + IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN + XLAM = XLAM + PREF*PYRVI3(1,3,2) * + & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1) + & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1) + ENDIF + + IDR = IKR1+4 + IDR2 = IKR2 + IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN + XLAM = XLAM + PREF*PYRVI3(1,2,3) * + & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1) + & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1) + ENDIF + + IDR = IKR1+4 + IDR2 = IKR2+2 + IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN + XLAM = XLAM + PREF*PYRVI3(2,1,3) * + & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1) + & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1) + ENDIF + 130 CONTINUE + 140 CONTINUE + + RETURN + END + +C********************************************************************* + +C...PYRVI1 +C...Function to integrate resonance contributions + + FUNCTION PYRVI1(ID1,ID2,ID3) + + IMPLICIT NONE + DOUBLE PRECISION LO,HI,PYRVI1,PYRVG1,PYGAUS + DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS + INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES + LOGICAL MFLAG,DCMASS + EXTERNAL PYRVG1,PYGAUS + COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2 + & ,DCMASS,KFR(3) + COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG + SAVE/PYRVNV/,/PYRVPM/ +C...Initialize mass and width information + PYRVI1 = 0D0 + RM(0) = RMS(0) + RM(1) = RMS(ID1) + RM(2) = RMS(ID2) + RM(3) = RMS(ID3) + RESM(1)= RES(IDR,1) + RESW(1)= RES(IDR,2) +C...A->B and B->A for antisparticles + A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2)) + B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2)) +C...Integration boundaries and mass flag + LO = (RM(1)+RM(2))**2 + HI = (RM(0)-RM(3))**2 + MFLAG = DCMASS + PYRVI1 = PYGAUS(PYRVG1,LO,HI,1D-3) + RETURN + END + +C********************************************************************* + +C...PYRVI2 +C...Function to integrate L-R interference contributions + + FUNCTION PYRVI2(ID1,ID2,ID3) + + IMPLICIT NONE + DOUBLE PRECISION LO,HI,PYRVI2, PYRVG2, PYGAUS + DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS + INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES + LOGICAL MFLAG,DCMASS + EXTERNAL PYRVG2,PYGAUS + COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2 + & ,DCMASS,KFR(3) + COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG + SAVE/PYRVNV/,/PYRVPM/ +C...Initialize mass and width information + PYRVI2 = 0D0 + RM(0) = RMS(0) + RM(1) = RMS(ID1) + RM(2) = RMS(ID2) + RM(3) = RMS(ID3) + RESM(1)= RES(IDR,1) + RESW(1)= RES(IDR,2) + RESM(2)= RES(IDR+1,1) + RESW(2)= RES(IDR+1,2) +C...A->B and B->A for antisparticles + A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2)) + B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2)) + A(2) = AB(1+INTRES(IDR+1,3),INTRES(IDR+1,1),INTRES(IDR+1,2)) + B(2) = AB(2-INTRES(IDR+1,3),INTRES(IDR+1,1),INTRES(IDR+1,2)) +C...Boundaries and mass flag + LO = (RM(1)+RM(2))**2 + HI = (RM(0)-RM(3))**2 + MFLAG = DCMASS + PYRVI2 = PYGAUS(PYRVG2,LO,HI,1D-3) + RETURN + END + +C********************************************************************* + +C...PYRVI3 +C...Function to integrate true interference contributions + + FUNCTION PYRVI3(ID1,ID2,ID3) + + IMPLICIT NONE + DOUBLE PRECISION LO,HI,PYRVI3, PYRVG3, PYGAUS + DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS + INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES + LOGICAL MFLAG,DCMASS + EXTERNAL PYRVG3,PYGAUS + COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2 + & ,DCMASS,KFR(3) + COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG + SAVE/PYRVNV/,/PYRVPM/ +C...Initialize mass and width information + PYRVI3 = 0D0 + RM(0) = RMS(0) + RM(1) = RMS(ID1) + RM(2) = RMS(ID2) + RM(3) = RMS(ID3) + RESM(1)= RES(IDR,1) + RESW(1)= RES(IDR,2) + RESM(2)= RES(IDR2,1) + RESW(2)= RES(IDR2,2) +C...A -> B and B -> A for antisparticles + A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2)) + B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2)) + A(2) = AB(1+INTRES(IDR2,3),INTRES(IDR2,1),INTRES(IDR2,2)) + B(2) = AB(2-INTRES(IDR2,3),INTRES(IDR2,1),INTRES(IDR2,2)) +C...Boundaries and mass flag + LO = (RM(1)+RM(2))**2 + HI = (RM(0)-RM(3))**2 + MFLAG = DCMASS + PYRVI3 = PYGAUS(PYRVG3,LO,HI,1D-3) + RETURN + END + +C********************************************************************* + +C...PYRVG1 +C...Integrand for resonance contributions + + FUNCTION PYRVG1(X) + + IMPLICIT NONE + COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG + DOUBLE PRECISION X, RM, A, B, RESM, RESW, DELTAY,PYRVR + DOUBLE PRECISION RVR,PYRVG1,E2,E3,C1,SR1,SR2,A1,A2 + LOGICAL MFLAG + SAVE/PYRVPM/ + RVR = PYRVR(X,RESM(1),RESW(1)) + C1 = 2D0*SQRT(MAX(0D0,X)) + IF (.NOT.MFLAG) THEN + E2 = X/C1 + E3 = (RM(0)**2-X)/C1 + DELTAY = 4D0*E2*E3 + PYRVG1 = DELTAY*RVR*X*(A(1)**2+B(1)**2)*(RM(0)**2-X) + ELSE + E2 = (X-RM(1)**2+RM(2)**2)/C1 + E3 = (RM(0)**2-X-RM(3)**2)/C1 + SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2)) + SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2)) + DELTAY = 4D0*SR1*SR2 + A1 = 4.*A(1)*B(1)*RM(3)*RM(0) + A2 = (A(1)**2+B(1)**2)*(RM(0)**2+RM(3)**2-X) + PYRVG1 = DELTAY*RVR*(X-RM(1)**2-RM(2)**2)*(A1+A2) + ENDIF + RETURN + END + +C********************************************************************* + +C...PYRVG2 +C...Integrand for L-R interference contributions + + FUNCTION PYRVG2(X) + + IMPLICIT NONE + COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG + DOUBLE PRECISION X, RM, A, B, RESM, RESW, DELTAY, PYRVS + DOUBLE PRECISION RVS,PYRVG2,E2,E3,C1,SR1,SR2 + LOGICAL MFLAG + SAVE/PYRVPM/ + C1 = 2D0*SQRT(MAX(0D0,X)) + RVS = PYRVS(X,X,RESM(1),RESW(1),RESM(2),RESW(2)) + IF (.NOT.MFLAG) THEN + E2 = X/C1 + E3 = (RM(0)**2-X)/C1 + DELTAY = 4D0*E2*E3 + PYRVG2 = DELTAY*RVS*X*(A(1)*A(2)+B(1)*B(2))*(RM(0)**2-X) + ELSE + E2 = (X-RM(1)**2+RM(2)**2)/C1 + E3 = (RM(0)**2-X-RM(3)**2)/C1 + SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2)) + SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2)) + DELTAY = 4D0*SR1*SR2 + PYRVG2 = DELTAY*RVS*(X-RM(1)**2-RM(2)**2)*((A(1)*A(2) + & + B(1)*B(2))*(RM(0)**2+RM(3)**2-X) + & + 2D0*(A(1)*B(2)+A(2)*B(1))*RM(3)*RM(0)) + ENDIF + RETURN + END + +C********************************************************************* + +C...PYRVG3 +C...Function to do Y integration over true interference contributions + + FUNCTION PYRVG3(X) + + IMPLICIT NONE + COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG +C...Second Dalitz variable for PYRVG4 + COMMON/PYG2DX/X1 + DOUBLE PRECISION RM, A, B, RESM, RESW, X, X1 + DOUBLE PRECISION E2, E3, C1, SQ1, SR1, SR2, YMIN, YMAX + DOUBLE PRECISION PYRVG3, PYRVG4, PYGAU2 + LOGICAL MFLAG + EXTERNAL PYGAU2,PYRVG4 + SAVE/PYRVPM/,/PYG2DX/ + PYRVG3=0D0 + C1=2D0*SQRT(MAX(1D-9,X)) + X1=X + IF (.NOT.MFLAG) THEN + E2 = X/C1 + E3 = (RM(0)**2-X)/C1 + YMIN = 0D0 + YMAX = 4D0*E2*E3 + ELSE + E2 = (X-RM(1)**2+RM(2)**2)/C1 + E3 = (RM(0)**2-X-RM(3)**2)/C1 + SQ1 = (E2+E3)**2 + SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2)) + SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2)) + YMIN = SQ1-(SR1+SR2)**2 + YMAX = SQ1-(SR1-SR2)**2 + ENDIF + PYRVG3 = PYGAU2(PYRVG4,YMIN,YMAX,1D-3) + RETURN + END + +C********************************************************************* + +C...PYRVG4 +C...Integrand for true intereference contributions + + FUNCTION PYRVG4(Y) + + IMPLICIT NONE + COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG + COMMON/PYG2DX/X + DOUBLE PRECISION X, Y, PYRVG4, RM, A, B, RESM, RESW, RVS, PYRVS + LOGICAL MFLAG + SAVE /PYRVPM/,/PYG2DX/ + PYRVG4=0D0 + RVS=PYRVS(X,Y,RESM(1),RESW(1),RESM(2),RESW(2)) + IF (.NOT.MFLAG) THEN + PYRVG4 = RVS*B(1)*B(2)*X*Y + ELSE + PYRVG4 = RVS*(RM(1)*RM(3)*A(1)*A(2)*(X+Y-RM(1)**2-RM(3)**2) + & + RM(1)*RM(0)*B(1)*A(2)*(Y-RM(2)**2-RM(3)**2) + & + RM(3)*RM(0)*A(1)*B(2)*(X-RM(1)**2-RM(2)**2) + & + B(1)*B(2)*(X*Y-(RM(1)*RM(3))**2-(RM(0)*RM(2))**2)) + ENDIF + RETURN + END + +C********************************************************************* + +C...PYRVR +C...Breit-Wigner for resonance contributions + + FUNCTION PYRVR(Mab2,RM,RW) + + IMPLICIT NONE + DOUBLE PRECISION Mab2,RM,RW,PYRVR + PYRVR = 1D0/((Mab2-RM**2)**2+RM**2*RW**2) + RETURN + END + +C********************************************************************* + +C...PYRVS +C...Interference function + + FUNCTION PYRVS(X,Y,M1,W1,M2,W2) + + IMPLICIT NONE + DOUBLE PRECISION X, Y, PYRVS, PYRVR, M1, M2, W1, W2 + PYRVS = PYRVR(X,M1,W1)*PYRVR(Y,M2,W2)*((X-M1**2)*(Y-M2**2) + & +W1*W2*M1*M2) + RETURN + END + +C********************************************************************* + +C...PY1ENT +C...Stores one parton/particle in commonblock PYJETS. + + SUBROUTINE PY1ENT(IP,KF,PE,THE,PHI) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ + +C...Standard checks. + MSTU(28)=0 + IF(MSTU(12).NE.12345) CALL PYLIST(0) + IPA=MAX(1,IABS(IP)) + IF(IPA.GT.MSTU(4)) CALL PYERRM(21, + &'(PY1ENT:) writing outside PYJETS memory') + KC=PYCOMP(KF) + IF(KC.EQ.0) CALL PYERRM(12,'(PY1ENT:) unknown flavour code') + +C...Find mass. Reset K, P and V vectors. + PM=0D0 + IF(MSTU(10).EQ.1) PM=P(IPA,5) + IF(MSTU(10).GE.2) PM=PYMASS(KF) + DO 100 J=1,5 + K(IPA,J)=0 + P(IPA,J)=0D0 + V(IPA,J)=0D0 + 100 CONTINUE + +C...Store parton/particle in K and P vectors. + K(IPA,1)=1 + IF(IP.LT.0) K(IPA,1)=2 + K(IPA,2)=KF + P(IPA,5)=PM + P(IPA,4)=MAX(PE,PM) + PA=SQRT(P(IPA,4)**2-P(IPA,5)**2) + P(IPA,1)=PA*SIN(THE)*COS(PHI) + P(IPA,2)=PA*SIN(THE)*SIN(PHI) + P(IPA,3)=PA*COS(THE) + +C...Set N. Optionally fragment/decay. + N=IPA + IF(IP.EQ.0) CALL PYEXEC + + RETURN + END + +C********************************************************************* + +C...PY2ENT +C...Stores two partons/particles in their CM frame, +C...with the first along the +z axis. + + SUBROUTINE PY2ENT(IP,KF1,KF2,PECM) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ + +C...Standard checks. + MSTU(28)=0 + IF(MSTU(12).NE.12345) CALL PYLIST(0) + IPA=MAX(1,IABS(IP)) + IF(IPA.GT.MSTU(4)-1) CALL PYERRM(21, + &'(PY2ENT:) writing outside PYJETS memory') + KC1=PYCOMP(KF1) + KC2=PYCOMP(KF2) + IF(KC1.EQ.0.OR.KC2.EQ.0) CALL PYERRM(12, + &'(PY2ENT:) unknown flavour code') + +C...Find masses. Reset K, P and V vectors. + PM1=0D0 + IF(MSTU(10).EQ.1) PM1=P(IPA,5) + IF(MSTU(10).GE.2) PM1=PYMASS(KF1) + PM2=0D0 + IF(MSTU(10).EQ.1) PM2=P(IPA+1,5) + IF(MSTU(10).GE.2) PM2=PYMASS(KF2) + DO 110 I=IPA,IPA+1 + DO 100 J=1,5 + K(I,J)=0 + P(I,J)=0D0 + V(I,J)=0D0 + 100 CONTINUE + 110 CONTINUE + +C...Check flavours. + KQ1=KCHG(KC1,2)*ISIGN(1,KF1) + KQ2=KCHG(KC2,2)*ISIGN(1,KF2) + IF(MSTU(19).EQ.1) THEN + MSTU(19)=0 + ELSE + IF(KQ1+KQ2.NE.0.AND.KQ1+KQ2.NE.4) CALL PYERRM(2, + & '(PY2ENT:) unphysical flavour combination') + ENDIF + K(IPA,2)=KF1 + K(IPA+1,2)=KF2 + +C...Store partons/particles in K vectors for normal case. + IF(IP.GE.0) THEN + K(IPA,1)=1 + IF(KQ1.NE.0.AND.KQ2.NE.0) K(IPA,1)=2 + K(IPA+1,1)=1 + +C...Store partons in K vectors for parton shower evolution. + ELSE + K(IPA,1)=3 + K(IPA+1,1)=3 + K(IPA,4)=MSTU(5)*(IPA+1) + K(IPA,5)=K(IPA,4) + K(IPA+1,4)=MSTU(5)*IPA + K(IPA+1,5)=K(IPA+1,4) + ENDIF + +C...Check kinematics and store partons/particles in P vectors. + IF(PECM.LE.PM1+PM2) CALL PYERRM(13, + &'(PY2ENT:) energy smaller than sum of masses') + PA=SQRT(MAX(0D0,(PECM**2-PM1**2-PM2**2)**2-(2D0*PM1*PM2)**2))/ + &(2D0*PECM) + P(IPA,3)=PA + P(IPA,4)=SQRT(PM1**2+PA**2) + P(IPA,5)=PM1 + P(IPA+1,3)=-PA + P(IPA+1,4)=SQRT(PM2**2+PA**2) + P(IPA+1,5)=PM2 + +C...Set N. Optionally fragment/decay. + N=IPA+1 + IF(IP.EQ.0) CALL PYEXEC + + RETURN + END + +C********************************************************************* + +C...PY3ENT +C...Stores three partons or particles in their CM frame, +C...with the first along the +z axis and the third in the (x,z) +C...plane with x > 0. + + SUBROUTINE PY3ENT(IP,KF1,KF2,KF3,PECM,X1,X3) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ + +C...Standard checks. + MSTU(28)=0 + IF(MSTU(12).NE.12345) CALL PYLIST(0) + IPA=MAX(1,IABS(IP)) + IF(IPA.GT.MSTU(4)-2) CALL PYERRM(21, + &'(PY3ENT:) writing outside PYJETS memory') + KC1=PYCOMP(KF1) + KC2=PYCOMP(KF2) + KC3=PYCOMP(KF3) + IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0) CALL PYERRM(12, + &'(PY3ENT:) unknown flavour code') + +C...Find masses. Reset K, P and V vectors. + PM1=0D0 + IF(MSTU(10).EQ.1) PM1=P(IPA,5) + IF(MSTU(10).GE.2) PM1=PYMASS(KF1) + PM2=0D0 + IF(MSTU(10).EQ.1) PM2=P(IPA+1,5) + IF(MSTU(10).GE.2) PM2=PYMASS(KF2) + PM3=0D0 + IF(MSTU(10).EQ.1) PM3=P(IPA+2,5) + IF(MSTU(10).GE.2) PM3=PYMASS(KF3) + DO 110 I=IPA,IPA+2 + DO 100 J=1,5 + K(I,J)=0 + P(I,J)=0D0 + V(I,J)=0D0 + 100 CONTINUE + 110 CONTINUE + +C...Check flavours. + KQ1=KCHG(KC1,2)*ISIGN(1,KF1) + KQ2=KCHG(KC2,2)*ISIGN(1,KF2) + KQ3=KCHG(KC3,2)*ISIGN(1,KF3) + IF(MSTU(19).EQ.1) THEN + MSTU(19)=0 + ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0) THEN + ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.(KQ1+KQ3.EQ.0.OR. + & KQ1+KQ3.EQ.4)) THEN + ELSE + CALL PYERRM(2,'(PY3ENT:) unphysical flavour combination') + ENDIF + K(IPA,2)=KF1 + K(IPA+1,2)=KF2 + K(IPA+2,2)=KF3 + +C...Store partons/particles in K vectors for normal case. + IF(IP.GE.0) THEN + K(IPA,1)=1 + IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0)) K(IPA,1)=2 + K(IPA+1,1)=1 + IF(KQ2.NE.0.AND.KQ3.NE.0) K(IPA+1,1)=2 + K(IPA+2,1)=1 + +C...Store partons in K vectors for parton shower evolution. + ELSE + K(IPA,1)=3 + K(IPA+1,1)=3 + K(IPA+2,1)=3 + KCS=4 + IF(KQ1.EQ.-1) KCS=5 + K(IPA,KCS)=MSTU(5)*(IPA+1) + K(IPA,9-KCS)=MSTU(5)*(IPA+2) + K(IPA+1,KCS)=MSTU(5)*(IPA+2) + K(IPA+1,9-KCS)=MSTU(5)*IPA + K(IPA+2,KCS)=MSTU(5)*IPA + K(IPA+2,9-KCS)=MSTU(5)*(IPA+1) + ENDIF + +C...Check kinematics. + MKERR=0 + IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*(2D0-X1-X3)*PECM.LE.PM2.OR. + &0.5D0*X3*PECM.LE.PM3) MKERR=1 + PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2)) + PA2=SQRT(MAX(1D-10,(0.5D0*(2D0-X1-X3)*PECM)**2-PM2**2)) + PA3=SQRT(MAX(1D-10,(0.5D0*X3*PECM)**2-PM3**2)) + CTHE2=(PA3**2-PA1**2-PA2**2)/(2D0*PA1*PA2) + CTHE3=(PA2**2-PA1**2-PA3**2)/(2D0*PA1*PA3) + IF(ABS(CTHE2).GE.1.001D0.OR.ABS(CTHE3).GE.1.001D0) MKERR=1 + CTHE3=MAX(-1D0,MIN(1D0,CTHE3)) + IF(MKERR.NE.0) CALL PYERRM(13, + &'(PY3ENT:) unphysical kinematical variable setup') + +C...Store partons/particles in P vectors. + P(IPA,3)=PA1 + P(IPA,4)=SQRT(PA1**2+PM1**2) + P(IPA,5)=PM1 + P(IPA+2,1)=PA3*SQRT(1D0-CTHE3**2) + P(IPA+2,3)=PA3*CTHE3 + P(IPA+2,4)=SQRT(PA3**2+PM3**2) + P(IPA+2,5)=PM3 + P(IPA+1,1)=-P(IPA+2,1) + P(IPA+1,3)=-P(IPA,3)-P(IPA+2,3) + P(IPA+1,4)=SQRT(P(IPA+1,1)**2+P(IPA+1,3)**2+PM2**2) + P(IPA+1,5)=PM2 + +C...Set N. Optionally fragment/decay. + N=IPA+2 + IF(IP.EQ.0) CALL PYEXEC + + RETURN + END + +C********************************************************************* + +C...PY4ENT +C...Stores four partons or particles in their CM frame, with +C...the first along the +z axis, the last in the xz plane with x > 0 +C...and the second having y < 0 and y > 0 with equal probability. + + SUBROUTINE PY4ENT(IP,KF1,KF2,KF3,KF4,PECM,X1,X2,X4,X12,X14) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ + +C...Standard checks. + MSTU(28)=0 + IF(MSTU(12).NE.12345) CALL PYLIST(0) + IPA=MAX(1,IABS(IP)) + IF(IPA.GT.MSTU(4)-3) CALL PYERRM(21, + &'(PY4ENT:) writing outside PYJETS momory') + KC1=PYCOMP(KF1) + KC2=PYCOMP(KF2) + KC3=PYCOMP(KF3) + KC4=PYCOMP(KF4) + IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) CALL PYERRM(12, + &'(PY4ENT:) unknown flavour code') + +C...Find masses. Reset K, P and V vectors. + PM1=0D0 + IF(MSTU(10).EQ.1) PM1=P(IPA,5) + IF(MSTU(10).GE.2) PM1=PYMASS(KF1) + PM2=0D0 + IF(MSTU(10).EQ.1) PM2=P(IPA+1,5) + IF(MSTU(10).GE.2) PM2=PYMASS(KF2) + PM3=0D0 + IF(MSTU(10).EQ.1) PM3=P(IPA+2,5) + IF(MSTU(10).GE.2) PM3=PYMASS(KF3) + PM4=0D0 + IF(MSTU(10).EQ.1) PM4=P(IPA+3,5) + IF(MSTU(10).GE.2) PM4=PYMASS(KF4) + DO 110 I=IPA,IPA+3 + DO 100 J=1,5 + K(I,J)=0 + P(I,J)=0D0 + V(I,J)=0D0 + 100 CONTINUE + 110 CONTINUE + +C...Check flavours. + KQ1=KCHG(KC1,2)*ISIGN(1,KF1) + KQ2=KCHG(KC2,2)*ISIGN(1,KF2) + KQ3=KCHG(KC3,2)*ISIGN(1,KF3) + KQ4=KCHG(KC4,2)*ISIGN(1,KF4) + IF(MSTU(19).EQ.1) THEN + MSTU(19)=0 + ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0.AND.KQ4.EQ.0) THEN + ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.KQ3.EQ.2.AND.(KQ1+KQ4.EQ.0.OR. + & KQ1+KQ4.EQ.4)) THEN + ELSEIF(KQ1.NE.0.AND.KQ1+KQ2.EQ.0.AND.KQ3.NE.0.AND.KQ3+KQ4.EQ.0D0) + & THEN + ELSE + CALL PYERRM(2,'(PY4ENT:) unphysical flavour combination') + ENDIF + K(IPA,2)=KF1 + K(IPA+1,2)=KF2 + K(IPA+2,2)=KF3 + K(IPA+3,2)=KF4 + +C...Store partons/particles in K vectors for normal case. + IF(IP.GE.0) THEN + K(IPA,1)=1 + IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0.OR.KQ4.NE.0)) K(IPA,1)=2 + K(IPA+1,1)=1 + IF(KQ2.NE.0.AND.KQ1+KQ2.NE.0.AND.(KQ3.NE.0.OR.KQ4.NE.0)) + & K(IPA+1,1)=2 + K(IPA+2,1)=1 + IF(KQ3.NE.0.AND.KQ4.NE.0) K(IPA+2,1)=2 + K(IPA+3,1)=1 + +C...Store partons for parton shower evolution from q-g-g-qbar or +C...g-g-g-g event. + ELSEIF(KQ1+KQ2.NE.0) THEN + K(IPA,1)=3 + K(IPA+1,1)=3 + K(IPA+2,1)=3 + K(IPA+3,1)=3 + KCS=4 + IF(KQ1.EQ.-1) KCS=5 + K(IPA,KCS)=MSTU(5)*(IPA+1) + K(IPA,9-KCS)=MSTU(5)*(IPA+3) + K(IPA+1,KCS)=MSTU(5)*(IPA+2) + K(IPA+1,9-KCS)=MSTU(5)*IPA + K(IPA+2,KCS)=MSTU(5)*(IPA+3) + K(IPA+2,9-KCS)=MSTU(5)*(IPA+1) + K(IPA+3,KCS)=MSTU(5)*IPA + K(IPA+3,9-KCS)=MSTU(5)*(IPA+2) + +C...Store partons for parton shower evolution from q-qbar-q-qbar event. + ELSE + K(IPA,1)=3 + K(IPA+1,1)=3 + K(IPA+2,1)=3 + K(IPA+3,1)=3 + K(IPA,4)=MSTU(5)*(IPA+1) + K(IPA,5)=K(IPA,4) + K(IPA+1,4)=MSTU(5)*IPA + K(IPA+1,5)=K(IPA+1,4) + K(IPA+2,4)=MSTU(5)*(IPA+3) + K(IPA+2,5)=K(IPA+2,4) + K(IPA+3,4)=MSTU(5)*(IPA+2) + K(IPA+3,5)=K(IPA+3,4) + ENDIF + +C...Check kinematics. + MKERR=0 + IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*X2*PECM.LE.PM2.OR. + &0.5D0*(2D0-X1-X2-X4)*PECM.LE.PM3.OR.0.5D0*X4*PECM.LE.PM4) + &MKERR=1 + PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2)) + PA2=SQRT(MAX(1D-10,(0.5D0*X2*PECM)**2-PM2**2)) + PA4=SQRT(MAX(1D-10,(0.5D0*X4*PECM)**2-PM4**2)) + X24=X1+X2+X4-1D0-X12-X14+(PM3**2-PM1**2-PM2**2-PM4**2)/PECM**2 + CTHE4=(X1*X4-2D0*X14)*PECM**2/(4D0*PA1*PA4) + IF(ABS(CTHE4).GE.1.002D0) MKERR=1 + CTHE4=MAX(-1D0,MIN(1D0,CTHE4)) + STHE4=SQRT(1D0-CTHE4**2) + CTHE2=(X1*X2-2D0*X12)*PECM**2/(4D0*PA1*PA2) + IF(ABS(CTHE2).GE.1.002D0) MKERR=1 + CTHE2=MAX(-1D0,MIN(1D0,CTHE2)) + STHE2=SQRT(1D0-CTHE2**2) + CPHI2=((X2*X4-2D0*X24)*PECM**2-4D0*PA2*CTHE2*PA4*CTHE4)/ + &MAX(1D-8*PECM**2,4D0*PA2*STHE2*PA4*STHE4) + IF(ABS(CPHI2).GE.1.05D0) MKERR=1 + CPHI2=MAX(-1D0,MIN(1D0,CPHI2)) + IF(MKERR.EQ.1) CALL PYERRM(13, + &'(PY4ENT:) unphysical kinematical variable setup') + +C...Store partons/particles in P vectors. + P(IPA,3)=PA1 + P(IPA,4)=SQRT(PA1**2+PM1**2) + P(IPA,5)=PM1 + P(IPA+3,1)=PA4*STHE4 + P(IPA+3,3)=PA4*CTHE4 + P(IPA+3,4)=SQRT(PA4**2+PM4**2) + P(IPA+3,5)=PM4 + P(IPA+1,1)=PA2*STHE2*CPHI2 + P(IPA+1,2)=PA2*STHE2*SQRT(1D0-CPHI2**2)*(-1D0)**INT(PYR(0)+0.5D0) + P(IPA+1,3)=PA2*CTHE2 + P(IPA+1,4)=SQRT(PA2**2+PM2**2) + P(IPA+1,5)=PM2 + P(IPA+2,1)=-P(IPA+1,1)-P(IPA+3,1) + P(IPA+2,2)=-P(IPA+1,2) + P(IPA+2,3)=-P(IPA,3)-P(IPA+1,3)-P(IPA+3,3) + P(IPA+2,4)=SQRT(P(IPA+2,1)**2+P(IPA+2,2)**2+P(IPA+2,3)**2+PM3**2) + P(IPA+2,5)=PM3 + +C...Set N. Optionally fragment/decay. + N=IPA+3 + IF(IP.EQ.0) CALL PYEXEC + + RETURN + END + +C********************************************************************* + +C...PY2FRM +C...An interface from a two-fermion generator to include +C...parton showers and hadronization. + + SUBROUTINE PY2FRM(IRAD,ITAU,ICOM) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + SAVE /PYJETS/,/PYDAT1/ +C...Local arrays. + DIMENSION IJOIN(2),INTAU(2) + +C...Call PYHEPC to convert input from HEPEVT to PYJETS common. + IF(ICOM.EQ.0) THEN + MSTU(28)=0 + CALL PYHEPC(2) + ENDIF + +C...Loop through entries and pick up all final fermions/antifermions. + I1=0 + I2=0 + DO 100 I=1,N + IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100 + KFA=IABS(K(I,2)) + IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN + IF(K(I,2).GT.0) THEN + IF(I1.EQ.0) THEN + I1=I + ELSE + CALL PYERRM(16,'(PY2FRM:) more than one fermion') + ENDIF + ELSE + IF(I2.EQ.0) THEN + I2=I + ELSE + CALL PYERRM(16,'(PY2FRM:) more than one antifermion') + ENDIF + ENDIF + ENDIF + 100 CONTINUE + +C...Check that event is arranged according to conventions. + IF(I1.EQ.0.OR.I2.EQ.0) THEN + CALL PYERRM(16,'(PY2FRM:) event contains too few fermions') + ENDIF + IF(I2.LT.I1) THEN + CALL PYERRM(6,'(PY2FRM:) fermions arranged in wrong order') + ENDIF + +C...Check whether fermion pair is quarks or leptons. + IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN + IQL12=1 + ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN + IQL12=2 + ELSE + CALL PYERRM(16,'(PY2FRM:) fermion pair inconsistent') + ENDIF + +C...Decide whether to allow or not photon radiation in showers. + MSTJ(41)=2 + IF(IRAD.EQ.0) MSTJ(41)=1 + +C...Do colour joining and parton showers. + IP1=I1 + IP2=I2 + IF(IQL12.EQ.1) THEN + IJOIN(1)=IP1 + IJOIN(2)=IP2 + CALL PYJOIN(2,IJOIN) + ENDIF + IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN + PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2- + & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2 + CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S))) + ENDIF + +C...Do fragmentation and decays. Possibly except tau decay. + IF(ITAU.EQ.0) THEN + NTAU=0 + DO 110 I=1,N + IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN + NTAU=NTAU+1 + INTAU(NTAU)=I + K(I,1)=11 + ENDIF + 110 CONTINUE + ENDIF + CALL PYEXEC + IF(ITAU.EQ.0) THEN + DO 120 I=1,NTAU + K(INTAU(I),1)=1 + 120 CONTINUE + ENDIF + +C...Call PYHEPC to convert output from PYJETS to HEPEVT common. + IF(ICOM.EQ.0) THEN + MSTU(28)=0 + CALL PYHEPC(1) + ENDIF + + END + +C********************************************************************* + +C...PY4FRM +C...An interface from a four-fermion generator to include +C...parton showers and hadronization. + + SUBROUTINE PY4FRM(ATOTSQ,A1SQ,A2SQ,ISTRAT,IRAD,ITAU,ICOM) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/ +C...Local arrays. + DIMENSION IJOIN(2),INTAU(4) + +C...Call PYHEPC to convert input from HEPEVT to PYJETS common. + IF(ICOM.EQ.0) THEN + MSTU(28)=0 + CALL PYHEPC(2) + ENDIF + +C...Loop through entries and pick up all final fermions/antifermions. + I1=0 + I2=0 + I3=0 + I4=0 + DO 100 I=1,N + IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100 + KFA=IABS(K(I,2)) + IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN + IF(K(I,2).GT.0) THEN + IF(I1.EQ.0) THEN + I1=I + ELSEIF(I3.EQ.0) THEN + I3=I + ELSE + CALL PYERRM(16,'(PY4FRM:) more than two fermions') + ENDIF + ELSE + IF(I2.EQ.0) THEN + I2=I + ELSEIF(I4.EQ.0) THEN + I4=I + ELSE + CALL PYERRM(16,'(PY4FRM:) more than two antifermions') + ENDIF + ENDIF + ENDIF + 100 CONTINUE + +C...Check that event is arranged according to conventions. + IF(I3.EQ.0.OR.I4.EQ.0) THEN + CALL PYERRM(16,'(PY4FRM:) event contains too few fermions') + ENDIF + IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3) THEN + CALL PYERRM(6,'(PY4FRM:) fermions arranged in wrong order') + ENDIF + +C...Check which fermion pairs are quarks and which leptons. + IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN + IQL12=1 + ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN + IQL12=2 + ELSE + CALL PYERRM(16,'(PY4FRM:) first fermion pair inconsistent') + ENDIF + IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN + IQL34=1 + ELSEIF(IABS(K(I3,2)).GT.10.AND.IABS(K(I4,2)).GT.10) THEN + IQL34=2 + ELSE + CALL PYERRM(16,'(PY4FRM:) second fermion pair inconsistent') + ENDIF + +C...Decide whether to allow or not photon radiation in showers. + MSTJ(41)=2 + IF(IRAD.EQ.0) MSTJ(41)=1 + +C...Decide on dipole pairing. + IP1=I1 + IP2=I2 + IP3=I3 + IP4=I4 + IF(IQL12.EQ.IQL34) THEN + R1SQ=A1SQ + R2SQ=A2SQ + DELTA=ATOTSQ-A1SQ-A2SQ + IF(ISTRAT.EQ.1) THEN + IF(DELTA.GT.0D0) R1SQ=R1SQ+DELTA + IF(DELTA.LT.0D0) R2SQ=MAX(0D0,R2SQ+DELTA) + ELSEIF(ISTRAT.EQ.2) THEN + IF(DELTA.GT.0D0) R2SQ=R2SQ+DELTA + IF(DELTA.LT.0D0) R1SQ=MAX(0D0,R1SQ+DELTA) + ENDIF + IF(R2SQ.GT.PYR(0)*(R1SQ+R2SQ)) THEN + IP2=I4 + IP4=I2 + ENDIF + ENDIF + +C...If colour reconnection then bookkeep W+W- or Z0Z0 +C...and copy q qbar q qbar consecutively. + IF(MSTP(115).GE.1.AND.IQL12.EQ.1.AND.IQL34.EQ.1) THEN + K(N+1,1)=11 + K(N+1,3)=IP1 + K(N+1,4)=N+3 + K(N+1,5)=N+4 + K(N+2,1)=11 + K(N+2,3)=IP3 + K(N+2,4)=N+5 + K(N+2,5)=N+6 + IF(K(IP1,2)+K(IP2,2).EQ.0) THEN + K(N+1,2)=23 + K(N+2,2)=23 + MINT(1)=22 + ELSEIF(PYCHGE(K(IP1,2)).GT.0) THEN + K(N+1,2)=24 + K(N+2,2)=-24 + MINT(1)=25 + ELSE + K(N+1,2)=-24 + K(N+2,2)=24 + MINT(1)=25 + ENDIF + DO 110 J=1,5 + K(N+3,J)=K(IP1,J) + K(N+4,J)=K(IP2,J) + K(N+5,J)=K(IP3,J) + K(N+6,J)=K(IP4,J) + P(N+1,J)=P(IP1,J)+P(IP2,J) + P(N+2,J)=P(IP3,J)+P(IP4,J) + P(N+3,J)=P(IP1,J) + P(N+4,J)=P(IP2,J) + P(N+5,J)=P(IP3,J) + P(N+6,J)=P(IP4,J) + V(N+1,J)=V(IP1,J) + V(N+2,J)=V(IP3,J) + V(N+3,J)=V(IP1,J) + V(N+4,J)=V(IP2,J) + V(N+5,J)=V(IP3,J) + V(N+6,J)=V(IP4,J) + 110 CONTINUE + P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2- + & P(N+1,3)**2)) + P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2- + & P(N+2,3)**2)) + K(N+3,3)=N+1 + K(N+4,3)=N+1 + K(N+5,3)=N+2 + K(N+6,3)=N+2 +C...Remove original q qbar q qbar and update counters. + K(IP1,1)=K(IP1,1)+10 + K(IP2,1)=K(IP2,1)+10 + K(IP3,1)=K(IP3,1)+10 + K(IP4,1)=K(IP4,1)+10 + IW1=N+1 + IW2=N+2 + NSD1=N+2 + IP1=N+3 + IP2=N+4 + IP3=N+5 + IP4=N+6 + N=N+6 + ENDIF + +C...Do colour joinings and parton showers. + IF(IQL12.EQ.1) THEN + IJOIN(1)=IP1 + IJOIN(2)=IP2 + CALL PYJOIN(2,IJOIN) + ENDIF + IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN + PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2- + & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2 + CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S))) + ENDIF + NAFT1=N + IF(IQL34.EQ.1) THEN + IJOIN(1)=IP3 + IJOIN(2)=IP4 + CALL PYJOIN(2,IJOIN) + ENDIF + IF(IQL34.EQ.1.OR.IRAD.EQ.1) THEN + PM34S=(P(IP3,4)+P(IP4,4))**2-(P(IP3,1)+P(IP4,1))**2- + & (P(IP3,2)+P(IP4,2))**2-(P(IP3,3)+P(IP4,3))**2 + CALL PYSHOW(IP3,IP4,SQRT(MAX(0D0,PM34S))) + ENDIF + +C...Optionally do colour reconnection. + MINT(32)=0 + MSTI(32)=0 + IF(MSTP(115).GE.1.AND.IQL12.EQ.1.AND.IQL34.EQ.1) THEN + CALL PYRECO(IW1,IW2,NSD1,NAFT1) + MSTI(32)=MINT(32) + ENDIF + +C...Do fragmentation and decays. Possibly except tau decay. + IF(ITAU.EQ.0) THEN + NTAU=0 + DO 120 I=1,N + IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN + NTAU=NTAU+1 + INTAU(NTAU)=I + K(I,1)=11 + ENDIF + 120 CONTINUE + ENDIF + CALL PYEXEC + IF(ITAU.EQ.0) THEN + DO 130 I=1,NTAU + K(INTAU(I),1)=1 + 130 CONTINUE + ENDIF + +C...Call PYHEPC to convert output from PYJETS to HEPEVT common. + IF(ICOM.EQ.0) THEN + MSTU(28)=0 + CALL PYHEPC(1) + ENDIF + + END + +C********************************************************************* + +C...PY6FRM +C...An interface from a six-fermion generator to include +C...parton showers and hadronization. + + SUBROUTINE PY6FRM(P12,P13,P21,P23,P31,P32,PTOP,IRAD,ITAU,ICOM) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + SAVE /PYJETS/,/PYDAT1/ +C...Local arrays. + DIMENSION IJOIN(2),INTAU(6),BETA(3),BETAO(3),BETAN(3) + +C...Call PYHEPC to convert input from HEPEVT to PYJETS common. + IF(ICOM.EQ.0) THEN + MSTU(28)=0 + CALL PYHEPC(2) + ENDIF + +C...Loop through entries and pick up all final fermions/antifermions. + I1=0 + I2=0 + I3=0 + I4=0 + I5=0 + I6=0 + DO 100 I=1,N + IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100 + KFA=IABS(K(I,2)) + IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN + IF(K(I,2).GT.0) THEN + IF(I1.EQ.0) THEN + I1=I + ELSEIF(I3.EQ.0) THEN + I3=I + ELSEIF(I5.EQ.0) THEN + I5=I + ELSE + CALL PYERRM(16,'(PY6FRM:) more than three fermions') + ENDIF + ELSE + IF(I2.EQ.0) THEN + I2=I + ELSEIF(I4.EQ.0) THEN + I4=I + ELSEIF(I6.EQ.0) THEN + I6=I + ELSE + CALL PYERRM(16,'(PY6FRM:) more than three antifermions') + ENDIF + ENDIF + ENDIF + 100 CONTINUE + +C...Check that event is arranged according to conventions. + IF(I5.EQ.0.OR.I6.EQ.0) THEN + CALL PYERRM(16,'(PY6FRM:) event contains too few fermions') + ENDIF + IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3.OR.I5.LT.I4.OR.I6.LT.I5) THEN + CALL PYERRM(6,'(PY6FRM:) fermions arranged in wrong order') + ENDIF + +C...Check which fermion pairs are quarks and which leptons. + IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN + IQL12=1 + ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN + IQL12=2 + ELSE + CALL PYERRM(16,'(PY6FRM:) first fermion pair inconsistent') + ENDIF + IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN + IQL34=1 + ELSEIF(IABS(K(I3,2)).GT.10.AND.IABS(K(I4,2)).GT.10) THEN + IQL34=2 + ELSE + CALL PYERRM(16,'(PY6FRM:) second fermion pair inconsistent') + ENDIF + IF(IABS(K(I5,2)).LT.10.AND.IABS(K(I6,2)).LT.10) THEN + IQL56=1 + ELSEIF(IABS(K(I5,2)).GT.10.AND.IABS(K(I6,2)).GT.10) THEN + IQL56=2 + ELSE + CALL PYERRM(16,'(PY6FRM:) third fermion pair inconsistent') + ENDIF + +C...Decide whether to allow or not photon radiation in showers. + MSTJ(41)=2 + IF(IRAD.EQ.0) MSTJ(41)=1 + +C...Allow dipole pairings only among leptons and quarks separately. + P12D=P12 + P13D=0D0 + IF(IQL34.EQ.IQL56) P13D=P13 + P21D=0D0 + IF(IQL12.EQ.IQL34) P21D=P21 + P23D=0D0 + IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P23D=P23 + P31D=0D0 + IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P31D=P31 + P32D=0D0 + IF(IQL12.EQ.IQL56) P32D=P32 + +C...Decide whether t+tbar. + ITOP=0 + IF(PYR(0).LT.PTOP) THEN + ITOP=1 + +C...If t+tbar: reconstruct t's. + IT=N+1 + ITB=N+2 + DO 110 J=1,5 + K(IT,J)=0 + K(ITB,J)=0 + P(IT,J)=P(I1,J)+P(I3,J)+P(I4,J) + P(ITB,J)=P(I2,J)+P(I5,J)+P(I6,J) + V(IT,J)=0D0 + V(ITB,J)=0D0 + 110 CONTINUE + K(IT,1)=1 + K(ITB,1)=1 + K(IT,2)=6 + K(ITB,2)=-6 + P(IT,5)=SQRT(MAX(0D0,P(IT,4)**2-P(IT,1)**2-P(IT,2)**2- + & P(IT,3)**2)) + P(ITB,5)=SQRT(MAX(0D0,P(ITB,4)**2-P(ITB,1)**2-P(ITB,2)**2- + & P(ITB,3)**2)) + N=N+2 + +C...If t+tbar: colour join t's and let them shower. + IJOIN(1)=IT + IJOIN(2)=ITB + CALL PYJOIN(2,IJOIN) + PMTTS=(P(IT,4)+P(ITB,4))**2-(P(IT,1)+P(ITB,1))**2- + & (P(IT,2)+P(ITB,2))**2-(P(IT,3)+P(ITB,3))**2 + CALL PYSHOW(IT,ITB,SQRT(MAX(0D0,PMTTS))) + +C...If t+tbar: pick up the t's after shower. + ITNEW=IT + ITBNEW=ITB + DO 120 I=ITB+1,N + IF(K(I,2).EQ.6) ITNEW=I + IF(K(I,2).EQ.-6) ITBNEW=I + 120 CONTINUE + +C...If t+tbar: loop over two top systems. + DO 200 IT1=1,2 + IF(IT1.EQ.1) THEN + ITO=IT + ITN=ITNEW + IBO=I1 + IW1=I3 + IW2=I4 + ELSE + ITO=ITB + ITN=ITBNEW + IBO=I2 + IW1=I5 + IW2=I6 + ENDIF + IF(IABS(K(IBO,2)).NE.5) CALL PYERRM(6, + & '(PY6FRM:) not b in t decay') + +C...If t+tbar: find boost from original to new top frame. + DO 130 J=1,3 + BETAO(J)=P(ITO,J)/P(ITO,4) + BETAN(J)=P(ITN,J)/P(ITN,4) + 130 CONTINUE + +C...If t+tbar: boost copy of b by t shower and connect it in colour. + N=N+1 + IB=N + K(IB,1)=3 + K(IB,2)=K(IBO,2) + K(IB,3)=ITN + DO 140 J=1,5 + P(IB,J)=P(IBO,J) + V(IB,J)=0D0 + 140 CONTINUE + CALL PYROBO(IB,IB,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3)) + CALL PYROBO(IB,IB,0D0,0D0,BETAN(1),BETAN(2),BETAN(3)) + K(IB,4)=MSTU(5)*ITN + K(IB,5)=MSTU(5)*ITN + K(ITN,4)=K(ITN,4)+IB + K(ITN,5)=K(ITN,5)+IB + K(ITN,1)=K(ITN,1)+10 + K(IBO,1)=K(IBO,1)+10 + +C...If t+tbar: construct W recoiling against b. + N=N+1 + IW=N + DO 150 J=1,5 + K(IW,J)=0 + V(IW,J)=0D0 + 150 CONTINUE + K(IW,1)=1 + KCHW=PYCHGE(K(IW1,2))+PYCHGE(K(IW2,2)) + IF(IABS(KCHW).EQ.3) THEN + K(IW,2)=ISIGN(24,KCHW) + ELSE + CALL PYERRM(16,'(PY6FRM:) fermion pair inconsistent with W') + ENDIF + K(IW,3)=IW1 + +C...If t+tbar: construct W momentum, including boost by t shower. + DO 160 J=1,4 + P(IW,J)=P(IW1,J)+P(IW2,J) + 160 CONTINUE + P(IW,5)=SQRT(MAX(0D0,P(IW,4)**2-P(IW,1)**2-P(IW,2)**2- + & P(IW,3)**2)) + CALL PYROBO(IW,IW,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3)) + CALL PYROBO(IW,IW,0D0,0D0,BETAN(1),BETAN(2),BETAN(3)) + +C...If t+tbar: boost b and W to top rest frame. + DO 170 J=1,3 + BETA(J)=(P(IB,J)+P(IW,J))/(P(IB,4)+P(IW,4)) + 170 CONTINUE + CALL PYROBO(IB,IB,0D0,0D0,-BETA(1),-BETA(2),-BETA(3)) + CALL PYROBO(IW,IW,0D0,0D0,-BETA(1),-BETA(2),-BETA(3)) + +C...If t+tbar: let b shower and pick up modified W. + PMTS=(P(IB,4)+P(IW,4))**2-(P(IB,1)+P(IW,1))**2- + & (P(IB,2)+P(IW,2))**2-(P(IB,3)+P(IW,3))**2 + CALL PYSHOW(IB,IW,SQRT(MAX(0D0,PMTS))) + DO 180 I=IW,N + IF(IABS(K(I,2)).EQ.24) IWM=I + 180 CONTINUE + +C...If t+tbar: take copy of W decay products. + DO 190 J=1,5 + K(N+1,J)=K(IW1,J) + P(N+1,J)=P(IW1,J) + V(N+1,J)=V(IW1,J) + K(N+2,J)=K(IW2,J) + P(N+2,J)=P(IW2,J) + V(N+2,J)=V(IW2,J) + 190 CONTINUE + K(IW1,1)=K(IW1,1)+10 + K(IW2,1)=K(IW2,1)+10 + K(IWM,1)=K(IWM,1)+10 + K(IWM,4)=N+1 + K(IWM,5)=N+2 + K(N+1,3)=IWM + K(N+2,3)=IWM + IF(IT1.EQ.1) THEN + I3=N+1 + I4=N+2 + ELSE + I5=N+1 + I6=N+2 + ENDIF + N=N+2 + +C...If t+tbar: boost W decay products, first by effects of t shower, +C...then by those of b shower. b and its shower simple boost back. + CALL PYROBO(N-1,N,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3)) + CALL PYROBO(N-1,N,0D0,0D0,BETAN(1),BETAN(2),BETAN(3)) + CALL PYROBO(N-1,N,0D0,0D0,-BETA(1),-BETA(2),-BETA(3)) + CALL PYROBO(N-1,N,0D0,0D0,-P(IW,1)/P(IW,4), + & -P(IW,2)/P(IW,4),-P(IW,3)/P(IW,4)) + CALL PYROBO(N-1,N,0D0,0D0,P(IWM,1)/P(IWM,4), + & P(IWM,2)/P(IWM,4),P(IWM,3)/P(IWM,4)) + CALL PYROBO(IB,IB,0D0,0D0,BETA(1),BETA(2),BETA(3)) + CALL PYROBO(IW,N,0D0,0D0,BETA(1),BETA(2),BETA(3)) + 200 CONTINUE + ENDIF + +C...Decide on dipole pairing. + IP1=I1 + IP3=I3 + IP5=I5 + PRN=PYR(0)*(P12D+P13D+P21D+P23D+P31D+P32D) + IF(ITOP.EQ.1.OR.PRN.LT.P12D) THEN + IP2=I2 + IP4=I4 + IP6=I6 + ELSEIF(PRN.LT.P12D+P13D) THEN + IP2=I2 + IP4=I6 + IP6=I4 + ELSEIF(PRN.LT.P12D+P13D+P21D) THEN + IP2=I4 + IP4=I2 + IP6=I6 + ELSEIF(PRN.LT.P12D+P13D+P21D+P23D) THEN + IP2=I4 + IP4=I6 + IP6=I2 + ELSEIF(PRN.LT.P12D+P13D+P21D+P23D+P31D) THEN + IP2=I6 + IP4=I2 + IP6=I4 + ELSE + IP2=I6 + IP4=I4 + IP6=I2 + ENDIF + +C...Do colour joinings and parton showers +C...(except ones already made for t+tbar). + IF(ITOP.EQ.0) THEN + IF(IQL12.EQ.1) THEN + IJOIN(1)=IP1 + IJOIN(2)=IP2 + CALL PYJOIN(2,IJOIN) + ENDIF + IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN + PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2- + & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2 + CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S))) + ENDIF + ENDIF + IF(IQL34.EQ.1) THEN + IJOIN(1)=IP3 + IJOIN(2)=IP4 + CALL PYJOIN(2,IJOIN) + ENDIF + IF(IQL34.EQ.1.OR.IRAD.EQ.1) THEN + PM34S=(P(IP3,4)+P(IP4,4))**2-(P(IP3,1)+P(IP4,1))**2- + & (P(IP3,2)+P(IP4,2))**2-(P(IP3,3)+P(IP4,3))**2 + CALL PYSHOW(IP3,IP4,SQRT(MAX(0D0,PM34S))) + ENDIF + IF(IQL56.EQ.1) THEN + IJOIN(1)=IP5 + IJOIN(2)=IP6 + CALL PYJOIN(2,IJOIN) + ENDIF + IF(IQL56.EQ.1.OR.IRAD.EQ.1) THEN + PM56S=(P(IP5,4)+P(IP6,4))**2-(P(IP5,1)+P(IP6,1))**2- + & (P(IP5,2)+P(IP6,2))**2-(P(IP5,3)+P(IP6,3))**2 + CALL PYSHOW(IP5,IP6,SQRT(MAX(0D0,PM56S))) + ENDIF + +C...Do fragmentation and decays. Possibly except tau decay. + IF(ITAU.EQ.0) THEN + NTAU=0 + DO 210 I=1,N + IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN + NTAU=NTAU+1 + INTAU(NTAU)=I + K(I,1)=11 + ENDIF + 210 CONTINUE + ENDIF + CALL PYEXEC + IF(ITAU.EQ.0) THEN + DO 220 I=1,NTAU + K(INTAU(I),1)=1 + 220 CONTINUE + ENDIF + +C...Call PYHEPC to convert output from PYJETS to HEPEVT common. + IF(ICOM.EQ.0) THEN + MSTU(28)=0 + CALL PYHEPC(1) + ENDIF + + END + +C********************************************************************* + +C...PY4JET +C...An interface from a four-parton generator to include +C...parton showers and hadronization. + + SUBROUTINE PY4JET(PMAX,IRAD,ICOM) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + SAVE /PYJETS/,/PYDAT1/ +C...Local arrays. + DIMENSION IJOIN(2),PTOT(4),BETA(3) + +C...Call PYHEPC to convert input from HEPEVT to PYJETS common. + IF(ICOM.EQ.0) THEN + MSTU(28)=0 + CALL PYHEPC(2) + ENDIF + +C...Loop through entries and pick up all final partons. + I1=0 + I2=0 + I3=0 + I4=0 + DO 100 I=1,N + IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100 + KFA=IABS(K(I,2)) + IF((KFA.GE.1.AND.KFA.LE.6).OR.KFA.EQ.21) THEN + IF(K(I,2).GT.0.AND.K(I,2).LE.6) THEN + IF(I1.EQ.0) THEN + I1=I + ELSEIF(I3.EQ.0) THEN + I3=I + ELSE + CALL PYERRM(16,'(PY4JET:) more than two quarks') + ENDIF + ELSEIF(K(I,2).LT.0) THEN + IF(I2.EQ.0) THEN + I2=I + ELSEIF(I4.EQ.0) THEN + I4=I + ELSE + CALL PYERRM(16,'(PY4JET:) more than two antiquarks') + ENDIF + ELSE + IF(I3.EQ.0) THEN + I3=I + ELSEIF(I4.EQ.0) THEN + I4=I + ELSE + CALL PYERRM(16,'(PY4JET:) more than two gluons') + ENDIF + ENDIF + ENDIF + 100 CONTINUE + +C...Check that event is arranged according to conventions. + IF(I1.EQ.0.OR.I2.EQ.0.OR.I3.EQ.0.OR.I4.EQ.0) THEN + CALL PYERRM(16,'(PY4JET:) event contains too few partons') + ENDIF + IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3) THEN + CALL PYERRM(6,'(PY4JET:) partons arranged in wrong order') + ENDIF + +C...Check whether second pair are quarks or gluons. + IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN + IQG34=1 + ELSEIF(K(I3,2).EQ.21.AND.K(I4,2).EQ.21) THEN + IQG34=2 + ELSE + CALL PYERRM(16,'(PY4JET:) second parton pair inconsistent') + ENDIF + +C...Boost partons to their cm frame. + DO 110 J=1,4 + PTOT(J)=P(I1,J)+P(I2,J)+P(I3,J)+P(I4,J) + 110 CONTINUE + ECM=SQRT(MAX(0D0,PTOT(4)**2-PTOT(1)**2-PTOT(2)**2-PTOT(3)**2)) + DO 120 J=1,3 + BETA(J)=PTOT(J)/PTOT(4) + 120 CONTINUE + CALL PYROBO(I1,I1,0D0,0D0,-BETA(1),-BETA(2),-BETA(3)) + CALL PYROBO(I2,I2,0D0,0D0,-BETA(1),-BETA(2),-BETA(3)) + CALL PYROBO(I3,I3,0D0,0D0,-BETA(1),-BETA(2),-BETA(3)) + CALL PYROBO(I4,I4,0D0,0D0,-BETA(1),-BETA(2),-BETA(3)) + NSAV=N + +C...Decide and set up shower history for q qbar q' qbar' events. + IF(IQG34.EQ.1) THEN + W1=PY4JTW(0,I1,I3,I4) + W2=PY4JTW(0,I2,I3,I4) + IF(W1.GT.PYR(0)*(W1+W2)) THEN + CALL PY4JTS(0,I1,I3,I4,I2,QMAX) + ELSE + CALL PY4JTS(0,I2,I3,I4,I1,QMAX) + ENDIF + +C...Decide and set up shower history for q qbar g g events. + ELSE + W1=PY4JTW(I1,I3,I2,I4) + W2=PY4JTW(I1,I4,I2,I3) + W3=PY4JTW(0,I3,I1,I4) + W4=PY4JTW(0,I4,I1,I3) + W5=PY4JTW(0,I3,I2,I4) + W6=PY4JTW(0,I4,I2,I3) + W7=PY4JTW(0,I1,I3,I4) + W8=PY4JTW(0,I2,I3,I4) + WR=(W1+W2+W3+W4+W5+W6+W7+W8)*PYR(0) + IF(W1.GT.WR) THEN + CALL PY4JTS(I1,I3,I2,I4,0,QMAX) + ELSEIF(W1+W2.GT.WR) THEN + CALL PY4JTS(I1,I4,I2,I3,0,QMAX) + ELSEIF(W1+W2+W3.GT.WR) THEN + CALL PY4JTS(0,I3,I1,I4,I2,QMAX) + ELSEIF(W1+W2+W3+W4.GT.WR) THEN + CALL PY4JTS(0,I4,I1,I3,I2,QMAX) + ELSEIF(W1+W2+W3+W4+W5.GT.WR) THEN + CALL PY4JTS(0,I3,I2,I4,I1,QMAX) + ELSEIF(W1+W2+W3+W4+W5+W6.GT.WR) THEN + CALL PY4JTS(0,I4,I2,I3,I1,QMAX) + ELSEIF(W1+W2+W3+W4+W5+W6+W7.GT.WR) THEN + CALL PY4JTS(0,I1,I3,I4,I2,QMAX) + ELSE + CALL PY4JTS(0,I2,I3,I4,I1,QMAX) + ENDIF + ENDIF + +C...Boost back original partons and mark them as deleted. + CALL PYROBO(I1,I1,0D0,0D0,BETA(1),BETA(2),BETA(3)) + CALL PYROBO(I2,I2,0D0,0D0,BETA(1),BETA(2),BETA(3)) + CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3)) + CALL PYROBO(I4,I4,0D0,0D0,BETA(1),BETA(2),BETA(3)) + K(I1,1)=K(I1,1)+10 + K(I2,1)=K(I2,1)+10 + K(I3,1)=K(I3,1)+10 + K(I4,1)=K(I4,1)+10 + +C...Rotate shower initiating partons to be along z axis. + PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2)) + CALL PYROBO(NSAV+1,NSAV+6,0D0,-PHI,0D0,0D0,0D0) + THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1)) + CALL PYROBO(NSAV+1,NSAV+6,-THE,0D0,0D0,0D0,0D0) + +C...Set up copy of shower initiating partons as on mass shell. + DO 140 I=N+1,N+2 + DO 130 J=1,5 + K(I,J)=0 + P(I,J)=0D0 + V(I,J)=V(I1,J) + 130 CONTINUE + K(I,1)=1 + K(I,2)=K(I-6,2) + 140 CONTINUE + IF(K(NSAV+1,2).EQ.K(I1,2)) THEN + K(N+1,3)=I1 + P(N+1,5)=P(I1,5) + K(N+2,3)=I2 + P(N+2,5)=P(I2,5) + ELSE + K(N+1,3)=I2 + P(N+1,5)=P(I2,5) + K(N+2,3)=I1 + P(N+2,5)=P(I1,5) + ENDIF + PABS=SQRT(MAX(0D0,(ECM**2-P(N+1,5)**2-P(N+2,5)**2)**2- + &(2D0*P(N+1,5)*P(N+2,5))**2))/(2D0*ECM) + P(N+1,3)=PABS + P(N+1,4)=SQRT(PABS**2+P(N+1,5)**2) + P(N+2,3)=-PABS + P(N+2,4)=SQRT(PABS**2+P(N+2,5)**2) + N=N+2 + +C...Decide whether to allow or not photon radiation in showers. +C...Connect up colours. + MSTJ(41)=2 + IF(IRAD.EQ.0) MSTJ(41)=1 + IJOIN(1)=N-1 + IJOIN(2)=N + CALL PYJOIN(2,IJOIN) + +C...Decide on maximum virtuality and do parton shower. + IF(PMAX.LT.PARJ(82)) THEN + PQMAX=QMAX + ELSE + PQMAX=PMAX + ENDIF + CALL PYSHOW(NSAV+1,-100,PQMAX) + +C...Rotate and boost back system. + CALL PYROBO(NSAV+1,N,THE,PHI,BETA(1),BETA(2),BETA(3)) + +C...Do fragmentation and decays. + CALL PYEXEC + +C...Call PYHEPC to convert output from PYJETS to HEPEVT common. + IF(ICOM.EQ.0) THEN + MSTU(28)=0 + CALL PYHEPC(1) + ENDIF + + RETURN + END + +C********************************************************************* + +C...PY4JTW +C...Auxiliary to PY4JET, to evaluate weight of configuration. + + FUNCTION PY4JTW(IA1,IA2,IA3,IA4) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + SAVE /PYJETS/ + +C...First case: when both original partons radiate. +C...IA1 /= 0: N+1 -> IA1 + IA2, N+2 -> IA3 + IA4. + IF(IA1.NE.0) THEN + DO 100 J=1,4 + P(N+1,J)=P(IA1,J)+P(IA2,J) + P(N+2,J)=P(IA3,J)+P(IA4,J) + 100 CONTINUE + P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2- + & P(N+1,3)**2)) + P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2- + & P(N+2,3)**2)) + Z1=P(IA1,4)/P(N+1,4) + WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-P(IA1,5)**2) + Z2=P(IA3,4)/P(N+2,4) + WT2=(4D0/3D0)*((1D0+Z2**2)/(1D0-Z2))/(P(N+2,5)**2-P(IA3,5)**2) + +C...Second case: when one original parton radiates to three. +C...IA1 = 0: N+1 -> IA2 + N+2, N+2 -> IA3 + IA4. + ELSE + DO 110 J=1,4 + P(N+2,J)=P(IA3,J)+P(IA4,J) + P(N+1,J)=P(N+2,J)+P(IA2,J) + 110 CONTINUE + P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2- + & P(N+1,3)**2)) + P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2- + & P(N+2,3)**2)) + IF(K(IA2,2).EQ.21) THEN + Z1=P(N+2,4)/P(N+1,4) + WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2- + & P(IA3,5)**2) + ELSE + Z1=P(IA2,4)/P(N+1,4) + WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2- + & P(IA2,5)**2) + ENDIF + Z2=P(IA3,4)/P(N+2,4) + IF(K(IA2,2).EQ.21) THEN + WT2=(4D0/3D0)*((1D0+Z2**2)/(1D0-Z2))/(P(N+2,5)**2- + & P(IA3,5)**2) + ELSEIF(K(IA3,2).EQ.21) THEN + WT2=3D0*((1D0-Z2*(1D0-Z2))**2/(Z2*(1D0-Z2)))/P(N+2,5)**2 + ELSE + WT2=0.5D0*(Z2**2+(1D0-Z2)**2) + ENDIF + ENDIF + +C...Total weight. + PY4JTW=WT1*WT2 + + RETURN + END + +C********************************************************************* + +C...PY4JTS +C...Auxiliary to PY4JET, to set up chosen configuration. + + SUBROUTINE PY4JTS(IA1,IA2,IA3,IA4,IA5,QMAX) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + SAVE /PYJETS/ + +C...Reset info. + DO 110 I=N+1,N+6 + DO 100 J=1,5 + K(I,J)=0 + V(I,J)=V(IA2,J) + 100 CONTINUE + K(I,1)=16 + 110 CONTINUE + +C...First case: when both original partons radiate. +C...N+1 -> (IA1=N+3) + (IA2=N+4), N+2 -> (IA3=N+5) + (IA4=N+6). + IF(IA1.NE.0) THEN + +C...Set up flavour and history pointers for new partons. + K(N+1,2)=K(IA1,2) + K(N+2,2)=K(IA3,2) + K(N+3,2)=K(IA1,2) + K(N+4,2)=K(IA2,2) + K(N+5,2)=K(IA3,2) + K(N+6,2)=K(IA4,2) + K(N+1,3)=IA1 + K(N+1,4)=N+3 + K(N+1,5)=N+4 + K(N+2,3)=IA3 + K(N+2,4)=N+5 + K(N+2,5)=N+6 + K(N+3,3)=N+1 + K(N+4,3)=N+1 + K(N+5,3)=N+2 + K(N+6,3)=N+2 + +C...Set up momenta for new partons. + DO 120 J=1,5 + P(N+1,J)=P(IA1,J)+P(IA2,J) + P(N+2,J)=P(IA3,J)+P(IA4,J) + P(N+3,J)=P(IA1,J) + P(N+4,J)=P(IA2,J) + P(N+5,J)=P(IA3,J) + P(N+6,J)=P(IA4,J) + 120 CONTINUE + P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2- + & P(N+1,3)**2)) + P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2- + & P(N+2,3)**2)) + QMAX=MIN(P(N+1,5),P(N+2,5)) + +C...Second case: q radiates twice. +C...N+1 -> (IA2=N+4) + N+3, N+3 -> (IA3=N+5) + (IA4=N+6), +C...IA5=N+2 does not radiate. + ELSEIF(K(IA2,2).EQ.21) THEN + +C...Set up flavour and history pointers for new partons. + K(N+1,2)=K(IA3,2) + K(N+2,2)=K(IA5,2) + K(N+3,2)=K(IA3,2) + K(N+4,2)=K(IA2,2) + K(N+5,2)=K(IA3,2) + K(N+6,2)=K(IA4,2) + K(N+1,3)=IA3 + K(N+1,4)=N+3 + K(N+1,5)=N+4 + K(N+2,3)=IA5 + K(N+3,3)=N+1 + K(N+3,4)=N+5 + K(N+3,5)=N+6 + K(N+4,3)=N+1 + K(N+5,3)=N+3 + K(N+6,3)=N+3 + +C...Set up momenta for new partons. + DO 130 J=1,5 + P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J) + P(N+2,J)=P(IA5,J) + P(N+3,J)=P(IA3,J)+P(IA4,J) + P(N+4,J)=P(IA2,J) + P(N+5,J)=P(IA3,J) + P(N+6,J)=P(IA4,J) + 130 CONTINUE + P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2- + & P(N+1,3)**2)) + P(N+3,5)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,1)**2-P(N+3,2)**2- + & P(N+3,3)**2)) + QMAX=P(N+3,5) + +C...Third case: q radiates g, g branches. +C...N+1 -> (IA2=N+3) + N+4, N+4 -> (IA3=N+5) + (IA4=N+6), +C...IA5=N+2 does not radiate. + ELSE + +C...Set up flavour and history pointers for new partons. + K(N+1,2)=K(IA2,2) + K(N+2,2)=K(IA5,2) + K(N+3,2)=K(IA2,2) + K(N+4,2)=21 + K(N+5,2)=K(IA3,2) + K(N+6,2)=K(IA4,2) + K(N+1,3)=IA2 + K(N+1,4)=N+3 + K(N+1,5)=N+4 + K(N+2,3)=IA5 + K(N+3,3)=N+1 + K(N+4,3)=N+1 + K(N+4,4)=N+5 + K(N+4,5)=N+6 + K(N+5,3)=N+4 + K(N+6,3)=N+4 + +C...Set up momenta for new partons. + DO 140 J=1,5 + P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J) + P(N+2,J)=P(IA5,J) + P(N+3,J)=P(IA2,J) + P(N+4,J)=P(IA3,J)+P(IA4,J) + P(N+5,J)=P(IA3,J) + P(N+6,J)=P(IA4,J) + 140 CONTINUE + P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2- + & P(N+1,3)**2)) + P(N+4,5)=SQRT(MAX(0D0,P(N+4,4)**2-P(N+4,1)**2-P(N+4,2)**2- + & P(N+4,3)**2)) + QMAX=P(N+4,5) + + ENDIF + N=N+6 + + RETURN + END + +C********************************************************************* + +C...PYJOIN +C...Connects a sequence of partons with colour flow indices, +C...as required for subsequent shower evolution (or other operations). + + SUBROUTINE PYJOIN(NJOIN,IJOIN) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ +C...Local array. + DIMENSION IJOIN(*) + +C...Check that partons are of right types to be connected. + IF(NJOIN.LT.2) GOTO 120 + KQSUM=0 + DO 100 IJN=1,NJOIN + I=IJOIN(IJN) + IF(I.LE.0.OR.I.GT.N) GOTO 120 + IF(K(I,1).LT.1.OR.K(I,1).GT.3) GOTO 120 + KC=PYCOMP(K(I,2)) + IF(KC.EQ.0) GOTO 120 + KQ=KCHG(KC,2)*ISIGN(1,K(I,2)) + IF(KQ.EQ.0) GOTO 120 + IF(IJN.NE.1.AND.IJN.NE.NJOIN.AND.KQ.NE.2) GOTO 120 + IF(KQ.NE.2) KQSUM=KQSUM+KQ + IF(IJN.EQ.1) KQS=KQ + 100 CONTINUE + IF(KQSUM.NE.0) GOTO 120 + +C...Connect the partons sequentially (closing for gluon loop). + KCS=(9-KQS)/2 + IF(KQS.EQ.2) KCS=INT(4.5D0+PYR(0)) + DO 110 IJN=1,NJOIN + I=IJOIN(IJN) + K(I,1)=3 + IF(IJN.NE.1) IP=IJOIN(IJN-1) + IF(IJN.EQ.1) IP=IJOIN(NJOIN) + IF(IJN.NE.NJOIN) IN=IJOIN(IJN+1) + IF(IJN.EQ.NJOIN) IN=IJOIN(1) + K(I,KCS)=MSTU(5)*IN + K(I,9-KCS)=MSTU(5)*IP + IF(IJN.EQ.1.AND.KQS.NE.2) K(I,9-KCS)=0 + IF(IJN.EQ.NJOIN.AND.KQS.NE.2) K(I,KCS)=0 + 110 CONTINUE + +C...Error exit: no action taken. + RETURN + 120 CALL PYERRM(12, + &'(PYJOIN:) given entries can not be joined by one string') + + RETURN + END + +C********************************************************************* + +C...PYGIVE +C...Sets values of commonblock variables. + + SUBROUTINE PYGIVE(CHIN) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + COMMON/PYDAT4/CHAF(500,2) + CHARACTER CHAF*16 + COMMON/PYDATR/MRPY(6),RRPY(100) + COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) + COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000) + COMMON/PYINT4/MWID(500),WIDS(500,5) + COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) + COMMON/PYINT6/PROC(0:500) + CHARACTER PROC*28 + COMMON/PYINT7/SIGT(0:6,0:6,0:5) + COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6), + &XPDIR(-6:6) + COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) + COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3) + COMMON/PYTCSM/ITCM(0:99),RTCM(0:99) + COMMON/PYPUED/IUED(0:99),RUED(0:99) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/, + &/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/, + &/PYINT6/,/PYINT7/,/PYINT8/,/PYMSSM/,/PYMSRV/,/PYTCSM/,/PYPUED/ +C...Local arrays and character variables. + CHARACTER CHIN*(*),CHFIX*104,CHBIT*104,CHOLD*8,CHNEW*8,CHOLD2*28, + &CHNEW2*28,CHNAM*6,CHVAR(56)*6,CHALP(2)*26,CHIND*8,CHINI*10, + &CHINR*16,CHDIG*10 + DIMENSION MSVAR(56,8) + +C...For each variable to be translated give: name, +C...integer/real/character, no. of indices, lower&upper index bounds. + DATA CHVAR/'N','K','P','V','MSTU','PARU','MSTJ','PARJ','KCHG', + &'PMAS','PARF','VCKM','MDCY','MDME','BRAT','KFDP','CHAF','MRPY', + &'RRPY','MSEL','MSUB','KFIN','CKIN','MSTP','PARP','MSTI','PARI', + &'MINT','VINT','ISET','KFPR','COEF','ICOL','XSFX','ISIG','SIGH', + &'MWID','WIDS','NGEN','XSEC','PROC','SIGT','XPVMD','XPANL', + &'XPANH','XPBEH','XPDIR','IMSS','RMSS','RVLAM','RVLAMP','RVLAMB', + &'ITCM','RTCM','IUED','RUED'/ + DATA ((MSVAR(I,J),J=1,8),I=1,56)/ 1,7*0, 1,2,1,4000,1,5,2*0, + &2,2,1,4000,1,5,2*0, 2,2,1,4000,1,5,2*0, 1,1,1,200,4*0, + &2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0, + &1,2,1,500,1,4,2*0, 2,2,1,500,1,4,2*0, 2,1,1,2000,4*0, + &2,2,1,4,1,4,2*0, 1,2,1,500,1,3,2*0, 1,2,1,8000,1,2,2*0, + &2,1,1,8000,4*0, 1,2,1,8000,1,5,2*0, 3,2,1,500,1,2,2*0, + &1,1,1,6,4*0, 2,1,1,100,4*0, + &1,7*0, 1,1,1,500,4*0, 1,2,1,2,-40,40,2*0, 2,1,1,200,4*0, + &1,1,1,200,4*0, 2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0, + &1,1,1,400,4*0, 2,1,1,400,4*0, 1,1,1,500,4*0, + &1,2,1,500,1,2,2*0, 2,2,1,500,1,20,2*0, 1,3,1,40,1,4,1,2, + &2,2,1,2,-40,40,2*0, 1,2,1,1000,1,3,2*0, 2,1,1,1000,4*0, + &1,1,1,500,4*0, 2,2,1,500,1,5,2*0, 1,2,0,500,1,3,2*0, + &2,2,0,500,1,3,2*0, 4,1,0,500,4*0, 2,3,0,6,0,6,0,5, + &2,1,-6,6,4*0, 2,1,-6,6,4*0, 2,1,-6,6,4*0, + &2,1,-6,6,4*0, 2,1,-6,6,4*0, 1,1,0,99,4*0, 2,1,0,99,4*0, + &2,3,1,3,1,3,1,3, 2,3,1,3,1,3,1,3, 2,3,1,3,1,3,1,3, + &1,1,0,99,4*0, 2,1,0,99,4*0, 1,1,0,99,4*0, 2,1,0,99,4*0/ + DATA CHALP/'abcdefghijklmnopqrstuvwxyz', + &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/, CHDIG/'1234567890'/ + +C...Length of character variable. Subdivide it into instructions. + IF(MSTU(12).NE.12345.AND.CHIN.NE.'mstu(12)=12345'.AND. + &CHIN.NE.'MSTU(12)=12345') CALL PYLIST(0) + CHBIT=CHIN//' ' + LBIT=101 + 100 LBIT=LBIT-1 + IF(CHBIT(LBIT:LBIT).EQ.' ') GOTO 100 + LTOT=0 + DO 110 LCOM=1,LBIT + IF(CHBIT(LCOM:LCOM).EQ.' ') GOTO 110 + LTOT=LTOT+1 + CHFIX(LTOT:LTOT)=CHBIT(LCOM:LCOM) + 110 CONTINUE + LLOW=0 + 120 LHIG=LLOW+1 + 130 LHIG=LHIG+1 + IF(LHIG.LE.LTOT.AND.CHFIX(LHIG:LHIG).NE.';') GOTO 130 + LBIT=LHIG-LLOW-1 + CHBIT(1:LBIT)=CHFIX(LLOW+1:LHIG-1) + +C...Send off decay-mode on/off commands to PYONOF. + IONOF=0 + DO 135 LDIG=1,10 + IF(CHBIT(1:1).EQ.CHDIG(LDIG:LDIG)) IONOF=1 + 135 CONTINUE + IF(IONOF.EQ.1) THEN + CALL PYONOF(CHIN) + RETURN + ENDIF + +C...Peel off any text following exclamation mark. + LHIG2=LBIT + DO 140 LLOW2=LHIG2,1,-1 + IF(CHBIT(LLOW2:LLOW2).EQ.'!') LBIT=LLOW2-1 + 140 CONTINUE + IF(LBIT.EQ.0) RETURN + +C...Identify commonblock variable. + LNAM=1 + 150 LNAM=LNAM+1 + IF(CHBIT(LNAM:LNAM).NE.'('.AND.CHBIT(LNAM:LNAM).NE.'='.AND. + &LNAM.LE.6) GOTO 150 + CHNAM=CHBIT(1:LNAM-1)//' ' + DO 170 LCOM=1,LNAM-1 + DO 160 LALP=1,26 + IF(CHNAM(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP)) CHNAM(LCOM:LCOM)= + & CHALP(2)(LALP:LALP) + 160 CONTINUE + 170 CONTINUE + IVAR=0 + DO 180 IV=1,56 + IF(CHNAM.EQ.CHVAR(IV)) IVAR=IV + 180 CONTINUE + IF(IVAR.EQ.0) THEN + CALL PYERRM(18,'(PYGIVE:) do not recognize variable '//CHNAM) + LLOW=LHIG + IF(LLOW.LT.LTOT) GOTO 120 + RETURN + ENDIF + +C...Identify any indices. + I1=0 + I2=0 + I3=0 + NINDX=0 + IF(CHBIT(LNAM:LNAM).EQ.'(') THEN + LIND=LNAM + 190 LIND=LIND+1 + IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 190 + CHIND=' ' + IF((CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.'c') + & .AND.(IVAR.EQ.9.OR.IVAR.EQ.10.OR.IVAR.EQ.13.OR.IVAR.EQ.17.OR. + & IVAR.EQ.37)) THEN + CHIND(LNAM-LIND+11:8)=CHBIT(LNAM+2:LIND-1) + READ(CHIND,'(I8)') KF + I1=PYCOMP(KF) + ELSEIF(CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ. + & 'c') THEN + CALL PYERRM(18,'(PYGIVE:) not allowed to use C index for '// + & CHNAM) + LLOW=LHIG + IF(LLOW.LT.LTOT) GOTO 120 + RETURN + ELSE + CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1) + READ(CHIND,'(I8)') I1 + ENDIF + LNAM=LIND + IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1 + NINDX=1 + ENDIF + IF(CHBIT(LNAM:LNAM).EQ.',') THEN + LIND=LNAM + 200 LIND=LIND+1 + IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 200 + CHIND=' ' + CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1) + READ(CHIND,'(I8)') I2 + LNAM=LIND + IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1 + NINDX=2 + ENDIF + IF(CHBIT(LNAM:LNAM).EQ.',') THEN + LIND=LNAM + 210 LIND=LIND+1 + IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 210 + CHIND=' ' + CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1) + READ(CHIND,'(I8)') I3 + LNAM=LIND+1 + NINDX=3 + ENDIF + +C...Check that indices allowed. + IERR=0 + IF(NINDX.NE.MSVAR(IVAR,2)) IERR=1 + IF(NINDX.GE.1.AND.(I1.LT.MSVAR(IVAR,3).OR.I1.GT.MSVAR(IVAR,4))) + &IERR=2 + IF(NINDX.GE.2.AND.(I2.LT.MSVAR(IVAR,5).OR.I2.GT.MSVAR(IVAR,6))) + &IERR=3 + IF(NINDX.EQ.3.AND.(I3.LT.MSVAR(IVAR,7).OR.I3.GT.MSVAR(IVAR,8))) + &IERR=4 + IF(CHBIT(LNAM:LNAM).NE.'=') IERR=5 + IF(IERR.GE.1) THEN + CALL PYERRM(18,'(PYGIVE:) unallowed indices for '// + & CHBIT(1:LNAM-1)) + LLOW=LHIG + IF(LLOW.LT.LTOT) GOTO 120 + RETURN + ENDIF + +C...Save old value of variable. + IF(IVAR.EQ.1) THEN + IOLD=N + ELSEIF(IVAR.EQ.2) THEN + IOLD=K(I1,I2) + ELSEIF(IVAR.EQ.3) THEN + ROLD=P(I1,I2) + ELSEIF(IVAR.EQ.4) THEN + ROLD=V(I1,I2) + ELSEIF(IVAR.EQ.5) THEN + IOLD=MSTU(I1) + ELSEIF(IVAR.EQ.6) THEN + ROLD=PARU(I1) + ELSEIF(IVAR.EQ.7) THEN + IOLD=MSTJ(I1) + ELSEIF(IVAR.EQ.8) THEN + ROLD=PARJ(I1) + ELSEIF(IVAR.EQ.9) THEN + IOLD=KCHG(I1,I2) + ELSEIF(IVAR.EQ.10) THEN + ROLD=PMAS(I1,I2) + ELSEIF(IVAR.EQ.11) THEN + ROLD=PARF(I1) + ELSEIF(IVAR.EQ.12) THEN + ROLD=VCKM(I1,I2) + ELSEIF(IVAR.EQ.13) THEN + IOLD=MDCY(I1,I2) + ELSEIF(IVAR.EQ.14) THEN + IOLD=MDME(I1,I2) + ELSEIF(IVAR.EQ.15) THEN + ROLD=BRAT(I1) + ELSEIF(IVAR.EQ.16) THEN + IOLD=KFDP(I1,I2) + ELSEIF(IVAR.EQ.17) THEN + CHOLD=CHAF(I1,I2)(1:8) + ELSEIF(IVAR.EQ.18) THEN + IOLD=MRPY(I1) + ELSEIF(IVAR.EQ.19) THEN + ROLD=RRPY(I1) + ELSEIF(IVAR.EQ.20) THEN + IOLD=MSEL + ELSEIF(IVAR.EQ.21) THEN + IOLD=MSUB(I1) + ELSEIF(IVAR.EQ.22) THEN + IOLD=KFIN(I1,I2) + ELSEIF(IVAR.EQ.23) THEN + ROLD=CKIN(I1) + ELSEIF(IVAR.EQ.24) THEN + IOLD=MSTP(I1) + ELSEIF(IVAR.EQ.25) THEN + ROLD=PARP(I1) + ELSEIF(IVAR.EQ.26) THEN + IOLD=MSTI(I1) + ELSEIF(IVAR.EQ.27) THEN + ROLD=PARI(I1) + ELSEIF(IVAR.EQ.28) THEN + IOLD=MINT(I1) + ELSEIF(IVAR.EQ.29) THEN + ROLD=VINT(I1) + ELSEIF(IVAR.EQ.30) THEN + IOLD=ISET(I1) + ELSEIF(IVAR.EQ.31) THEN + IOLD=KFPR(I1,I2) + ELSEIF(IVAR.EQ.32) THEN + ROLD=COEF(I1,I2) + ELSEIF(IVAR.EQ.33) THEN + IOLD=ICOL(I1,I2,I3) + ELSEIF(IVAR.EQ.34) THEN + ROLD=XSFX(I1,I2) + ELSEIF(IVAR.EQ.35) THEN + IOLD=ISIG(I1,I2) + ELSEIF(IVAR.EQ.36) THEN + ROLD=SIGH(I1) + ELSEIF(IVAR.EQ.37) THEN + IOLD=MWID(I1) + ELSEIF(IVAR.EQ.38) THEN + ROLD=WIDS(I1,I2) + ELSEIF(IVAR.EQ.39) THEN + IOLD=NGEN(I1,I2) + ELSEIF(IVAR.EQ.40) THEN + ROLD=XSEC(I1,I2) + ELSEIF(IVAR.EQ.41) THEN + CHOLD2=PROC(I1) + ELSEIF(IVAR.EQ.42) THEN + ROLD=SIGT(I1,I2,I3) + ELSEIF(IVAR.EQ.43) THEN + ROLD=XPVMD(I1) + ELSEIF(IVAR.EQ.44) THEN + ROLD=XPANL(I1) + ELSEIF(IVAR.EQ.45) THEN + ROLD=XPANH(I1) + ELSEIF(IVAR.EQ.46) THEN + ROLD=XPBEH(I1) + ELSEIF(IVAR.EQ.47) THEN + ROLD=XPDIR(I1) + ELSEIF(IVAR.EQ.48) THEN + IOLD=IMSS(I1) + ELSEIF(IVAR.EQ.49) THEN + ROLD=RMSS(I1) + ELSEIF(IVAR.EQ.50) THEN + ROLD=RVLAM(I1,I2,I3) + ELSEIF(IVAR.EQ.51) THEN + ROLD=RVLAMP(I1,I2,I3) + ELSEIF(IVAR.EQ.52) THEN + ROLD=RVLAMB(I1,I2,I3) + ELSEIF(IVAR.EQ.53) THEN + IOLD=ITCM(I1) + ELSEIF(IVAR.EQ.54) THEN + ROLD=RTCM(I1) + ELSEIF(IVAR.EQ.55) THEN + IOLD=IUED(I1) + ELSEIF(IVAR.EQ.56) THEN + ROLD=RUED(I1) + ENDIF + +C...Print current value of variable. Loop back. + IF(LNAM.GE.LBIT) THEN + CHBIT(LNAM:14)=' ' + CHBIT(15:60)=' has the value ' + IF(MSVAR(IVAR,1).EQ.1) THEN + WRITE(CHBIT(51:60),'(I10)') IOLD + ELSEIF(MSVAR(IVAR,1).EQ.2) THEN + WRITE(CHBIT(47:60),'(F14.5)') ROLD + ELSEIF(MSVAR(IVAR,1).EQ.3) THEN + CHBIT(53:60)=CHOLD + ELSE + CHBIT(33:60)=CHOLD + ENDIF + IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60) + LLOW=LHIG + IF(LLOW.LT.LTOT) GOTO 120 + RETURN + ENDIF + +C...Read in new variable value. + IF(MSVAR(IVAR,1).EQ.1) THEN + CHINI=' ' + CHINI(LNAM-LBIT+11:10)=CHBIT(LNAM+1:LBIT) + READ(CHINI,'(I10)') INEW + ELSEIF(MSVAR(IVAR,1).EQ.2) THEN + CHINR=' ' + CHINR(LNAM-LBIT+17:16)=CHBIT(LNAM+1:LBIT) + READ(CHINR,*) RNEW + ELSEIF(MSVAR(IVAR,1).EQ.3) THEN + CHNEW=CHBIT(LNAM+1:LBIT)//' ' + ELSE + CHNEW2=CHBIT(LNAM+1:LBIT)//' ' + ENDIF + +C...Store new variable value. + IF(IVAR.EQ.1) THEN + N=INEW + ELSEIF(IVAR.EQ.2) THEN + K(I1,I2)=INEW + ELSEIF(IVAR.EQ.3) THEN + P(I1,I2)=RNEW + ELSEIF(IVAR.EQ.4) THEN + V(I1,I2)=RNEW + ELSEIF(IVAR.EQ.5) THEN + MSTU(I1)=INEW + ELSEIF(IVAR.EQ.6) THEN + PARU(I1)=RNEW + ELSEIF(IVAR.EQ.7) THEN + MSTJ(I1)=INEW + ELSEIF(IVAR.EQ.8) THEN + PARJ(I1)=RNEW + ELSEIF(IVAR.EQ.9) THEN + KCHG(I1,I2)=INEW + ELSEIF(IVAR.EQ.10) THEN + PMAS(I1,I2)=RNEW + ELSEIF(IVAR.EQ.11) THEN + PARF(I1)=RNEW + ELSEIF(IVAR.EQ.12) THEN + VCKM(I1,I2)=RNEW + ELSEIF(IVAR.EQ.13) THEN + MDCY(I1,I2)=INEW + ELSEIF(IVAR.EQ.14) THEN + MDME(I1,I2)=INEW + ELSEIF(IVAR.EQ.15) THEN + BRAT(I1)=RNEW + ELSEIF(IVAR.EQ.16) THEN + KFDP(I1,I2)=INEW + ELSEIF(IVAR.EQ.17) THEN + CHAF(I1,I2)=CHNEW + ELSEIF(IVAR.EQ.18) THEN + MRPY(I1)=INEW + ELSEIF(IVAR.EQ.19) THEN + RRPY(I1)=RNEW + ELSEIF(IVAR.EQ.20) THEN + MSEL=INEW + ELSEIF(IVAR.EQ.21) THEN + MSUB(I1)=INEW + ELSEIF(IVAR.EQ.22) THEN + KFIN(I1,I2)=INEW + ELSEIF(IVAR.EQ.23) THEN + CKIN(I1)=RNEW + ELSEIF(IVAR.EQ.24) THEN + MSTP(I1)=INEW + ELSEIF(IVAR.EQ.25) THEN + PARP(I1)=RNEW + ELSEIF(IVAR.EQ.26) THEN + MSTI(I1)=INEW + ELSEIF(IVAR.EQ.27) THEN + PARI(I1)=RNEW + ELSEIF(IVAR.EQ.28) THEN + MINT(I1)=INEW + ELSEIF(IVAR.EQ.29) THEN + VINT(I1)=RNEW + ELSEIF(IVAR.EQ.30) THEN + ISET(I1)=INEW + ELSEIF(IVAR.EQ.31) THEN + KFPR(I1,I2)=INEW + ELSEIF(IVAR.EQ.32) THEN + COEF(I1,I2)=RNEW + ELSEIF(IVAR.EQ.33) THEN + ICOL(I1,I2,I3)=INEW + ELSEIF(IVAR.EQ.34) THEN + XSFX(I1,I2)=RNEW + ELSEIF(IVAR.EQ.35) THEN + ISIG(I1,I2)=INEW + ELSEIF(IVAR.EQ.36) THEN + SIGH(I1)=RNEW + ELSEIF(IVAR.EQ.37) THEN + MWID(I1)=INEW + ELSEIF(IVAR.EQ.38) THEN + WIDS(I1,I2)=RNEW + ELSEIF(IVAR.EQ.39) THEN + NGEN(I1,I2)=INEW + ELSEIF(IVAR.EQ.40) THEN + XSEC(I1,I2)=RNEW + ELSEIF(IVAR.EQ.41) THEN + PROC(I1)=CHNEW2 + ELSEIF(IVAR.EQ.42) THEN + SIGT(I1,I2,I3)=RNEW + ELSEIF(IVAR.EQ.43) THEN + XPVMD(I1)=RNEW + ELSEIF(IVAR.EQ.44) THEN + XPANL(I1)=RNEW + ELSEIF(IVAR.EQ.45) THEN + XPANH(I1)=RNEW + ELSEIF(IVAR.EQ.46) THEN + XPBEH(I1)=RNEW + ELSEIF(IVAR.EQ.47) THEN + XPDIR(I1)=RNEW + ELSEIF(IVAR.EQ.48) THEN + IMSS(I1)=INEW + ELSEIF(IVAR.EQ.49) THEN + RMSS(I1)=RNEW + ELSEIF(IVAR.EQ.50) THEN + RVLAM(I1,I2,I3)=RNEW + ELSEIF(IVAR.EQ.51) THEN + RVLAMP(I1,I2,I3)=RNEW + ELSEIF(IVAR.EQ.52) THEN + RVLAMB(I1,I2,I3)=RNEW + ELSEIF(IVAR.EQ.53) THEN + ITCM(I1)=INEW + ELSEIF(IVAR.EQ.54) THEN + RTCM(I1)=RNEW + ELSEIF(IVAR.EQ.55) THEN + IUED(I1)=INEW + ELSEIF(IVAR.EQ.56) THEN + RUED(I1)=RNEW + ENDIF + +C...Write old and new value. Loop back. + CHBIT(LNAM:14)=' ' + CHBIT(15:60)=' changed from to ' + IF(MSVAR(IVAR,1).EQ.1) THEN + WRITE(CHBIT(33:42),'(I10)') IOLD + WRITE(CHBIT(51:60),'(I10)') INEW + IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60) + ELSEIF(MSVAR(IVAR,1).EQ.2) THEN + WRITE(CHBIT(29:42),'(F14.5)') ROLD + WRITE(CHBIT(47:60),'(F14.5)') RNEW + IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60) + ELSEIF(MSVAR(IVAR,1).EQ.3) THEN + CHBIT(35:42)=CHOLD + CHBIT(53:60)=CHNEW + IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60) + ELSE + CHBIT(15:88)=' changed from '//CHOLD2//' to '//CHNEW2 + IF(MSTU(13).GE.1) WRITE(MSTU(11),5100) CHBIT(1:88) + ENDIF + LLOW=LHIG + IF(LLOW.LT.LTOT) GOTO 120 + +C...Format statement for output on unit MSTU(11) (by default 6). + 5000 FORMAT(5X,A60) + 5100 FORMAT(5X,A88) + + RETURN + END + +C********************************************************************* + +C...PYONOF +C...Switches on and off decay channel by search for match. + + SUBROUTINE PYONOF(CHIN) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + SAVE /PYDAT1/,/PYDAT3/ +C...Local arrays and character variables. + INTEGER KFCMP(10),KFTMP(10) + CHARACTER CHIN*(*),CHTMP*104,CHFIX*104,CHMODE*10,CHCODE*8, + &CHALP(2)*26 + DATA CHALP/'abcdefghijklmnopqrstuvwxyz', + &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/ + +C...Determine length of character variable. + CHTMP=CHIN//' ' + LBEG=0 + 100 LBEG=LBEG+1 + IF(CHTMP(LBEG:LBEG).EQ.' ') GOTO 100 + LEND=LBEG-1 + 105 LEND=LEND+1 + IF(LEND.LE.100.AND.CHTMP(LEND:LEND).NE.'!') GOTO 105 + 110 LEND=LEND-1 + IF(CHTMP(LEND:LEND).EQ.' ') GOTO 110 + LEN=1+LEND-LBEG + CHFIX(1:LEN)=CHTMP(LBEG:LEND) + +C...Find colon separator and particle code. + LCOLON=0 + 120 LCOLON=LCOLON+1 + IF(CHFIX(LCOLON:LCOLON).NE.':') GOTO 120 + CHCODE=' ' + CHCODE(10-LCOLON:8)=CHFIX(1:LCOLON-1) + READ(CHCODE,'(I8)',ERR=300) KF + KC=PYCOMP(KF) + +C...Done if unknown code or no decay channels. + IF(KC.EQ.0) THEN + CALL PYERRM(18,'(PYONOF:) unrecognized particle '//CHCODE) + RETURN + ENDIF + IDCBEG=MDCY(KC,2) + IDCLEN=MDCY(KC,3) + IF(IDCBEG.EQ.0.OR.IDCLEN.EQ.0) THEN + CALL PYERRM(18,'(PYONOF:) no decay channels for '//CHCODE) + RETURN + ENDIF + +C...Find command name up to blank or equal sign. + LSEP=LCOLON + 130 LSEP=LSEP+1 + IF(LSEP.LE.LEN.AND.CHFIX(LSEP:LSEP).NE.' '.AND. + &CHFIX(LSEP:LSEP).NE.'=') GOTO 130 + CHMODE=' ' + LMODE=LSEP-LCOLON-1 + CHMODE(1:LMODE)=CHFIX(LCOLON+1:LSEP-1) + +C...Convert to uppercase. + DO 150 LCOM=1,LMODE + DO 140 LALP=1,26 + IF(CHMODE(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP)) + & CHMODE(LCOM:LCOM)=CHALP(2)(LALP:LALP) + 140 CONTINUE + 150 CONTINUE + +C...Identify command. Failed if not identified. + MODE=0 + IF(CHMODE.EQ.'ALLOFF') MODE=1 + IF(CHMODE.EQ.'ALLON') MODE=2 + IF(CHMODE.EQ.'OFFIFANY') MODE=3 + IF(CHMODE.EQ.'ONIFANY') MODE=4 + IF(CHMODE.EQ.'OFFIFALL') MODE=5 + IF(CHMODE.EQ.'ONIFALL') MODE=6 + IF(CHMODE.EQ.'OFFIFMATCH') MODE=7 + IF(CHMODE.EQ.'ONIFMATCH') MODE=8 + IF(MODE.EQ.0) THEN + CALL PYERRM(18,'(PYONOF:) unknown command '//CHMODE) + RETURN + ENDIF + +C...Simple cases when all on or all off. + IF(MODE.EQ.1.OR.MODE.EQ.2) THEN + WRITE(MSTU(11),1000) KF,CHMODE + DO 160 IDC=IDCBEG,IDCBEG+IDCLEN-1 + IF(MDME(IDC,1).LT.0) GOTO 160 + MDME(IDC,1)=MODE-1 + 160 CONTINUE + RETURN + ENDIF + +C...Identify matching list. + NCMP=0 + LBEG=LSEP + 170 LBEG=LBEG+1 + IF(LBEG.GT.LEN) GOTO 190 + IF(LBEG.LT.LEN.AND.(CHFIX(LBEG:LBEG).EQ.' '.OR. + &CHFIX(LBEG:LBEG).EQ.'='.OR.CHFIX(LBEG:LBEG).EQ.',')) GOTO 170 + LEND=LBEG-1 + 180 LEND=LEND+1 + IF(LEND.LT.LEN.AND.CHFIX(LEND:LEND).NE.' '.AND. + &CHFIX(LEND:LEND).NE.'='.AND.CHFIX(LEND:LEND).NE.',') GOTO 180 + IF(LEND.LT.LEN) LEND=LEND-1 + CHCODE=' ' + CHCODE(8-LEND+LBEG:8)=CHFIX(LBEG:LEND) + READ(CHCODE,'(I8)',ERR=300) KFREAD + NCMP=NCMP+1 + KFCMP(NCMP)=IABS(KFREAD) + LBEG=LEND + IF(NCMP.LT.10) GOTO 170 + 190 CONTINUE + WRITE(MSTU(11),1100) KF,CHMODE,(KFCMP(ICMP),ICMP=1,NCMP) + +C...Only one matching required. + IF(MODE.EQ.3.OR.MODE.EQ.4) THEN + DO 220 IDC=IDCBEG,IDCBEG+IDCLEN-1 + IF(MDME(IDC,1).LT.0) GOTO 220 + DO 210 IKF=1,5 + KFNOW=IABS(KFDP(IDC,IKF)) + IF(KFNOW.EQ.0) GOTO 210 + DO 200 ICMP=1,NCMP + IF(KFCMP(ICMP).EQ.KFNOW) THEN + MDME(IDC,1)=MODE-3 + GOTO 220 + ENDIF + 200 CONTINUE + 210 CONTINUE + 220 CONTINUE + RETURN + ENDIF + +C...Multiple matchings required. + DO 260 IDC=IDCBEG,IDCBEG+IDCLEN-1 + IF(MDME(IDC,1).LT.0) GOTO 260 + NTMP=NCMP + DO 230 ITMP=1,NTMP + KFTMP(ITMP)=KFCMP(ITMP) + 230 CONTINUE + NFIN=0 + DO 250 IKF=1,5 + KFNOW=IABS(KFDP(IDC,IKF)) + IF(KFNOW.EQ.0) GOTO 250 + NFIN=NFIN+1 + DO 240 ITMP=1,NTMP + IF(KFTMP(ITMP).EQ.KFNOW) THEN + KFTMP(ITMP)=KFTMP(NTMP) + NTMP=NTMP-1 + GOTO 250 + ENDIF + 240 CONTINUE + 250 CONTINUE + IF(NTMP.EQ.0.AND.MODE.LE.6) MDME(IDC,1)=MODE-5 + IF(NTMP.EQ.0.AND.NFIN.EQ.NCMP.AND.MODE.GE.7) + & MDME(IDC,1)=MODE-7 + 260 CONTINUE + RETURN + +C...Error exit for impossible read of particle code. + 300 CALL PYERRM(18,'(PYONOF:) could not interpret particle code ' + &//CHCODE) + +C...Formats for output. + 1000 FORMAT(' Decays for',I8,' set ',A10) + 1100 FORMAT(' Decays for',I8,' set ',A10,' if match',10I8) + + RETURN + END +C********************************************************************* + +C...PYTUNE +C...Presets for a few specific underlying-event and min-bias tunes +C...Note some tunes require external pdfs to be linked (e.g. 105:QW), +C...others require particular versions of pythia (e.g. the SCI and GAL +C...models). See below for details. + SUBROUTINE PYTUNE(ITUNE) +C +C ITUNE NAME (detailed descriptions below) +C 0 Default : No settings changed => defaults. +C +C ====== Old UE, Q2-ordered showers ==================================== +C 100 A : Rick Field's CDF Tune A (Oct 2002) +C 101 AW : Rick Field's CDF Tune AW (Apr 2006) +C 102 BW : Rick Field's CDF Tune BW (Apr 2006) +C 103 DW : Rick Field's CDF Tune DW (Apr 2006) +C 104 DWT : As DW but with slower UE ECM-scaling (Apr 2006) +C 105 QW : Rick Field's CDF Tune QW using CTEQ6.1M (?) +C 106 ATLAS-DC2: Arthur Moraes' (old) ATLAS tune ("Rome") (?) +C 107 ACR : Tune A modified with new CR model (Mar 2007) +C 108 D6 : Rick Field's CDF Tune D6 using CTEQ6L1 (?) +C 109 D6T : Rick Field's CDF Tune D6T using CTEQ6L1 (?) +C ---- Professor Tunes : 110+ (= 100+ with Professor's tune to LEP) ---- +C 110 A-Pro : Tune A, with LEP tune from Professor (Oct 2008) +C 111 AW-Pro : Tune AW, -"- (Oct 2008) +C 112 BW-Pro : Tune BW, -"- (Oct 2008) +C 113 DW-Pro : Tune DW, -"- (Oct 2008) +C 114 DWT-Pro : Tune DWT, -"- (Oct 2008) +C 115 QW-Pro : Tune QW, -"- (Oct 2008) +C 116 ATLAS-DC2-Pro: ATLAS-DC2 / Rome, -"- (Oct 2008) +C 117 ACR-Pro : Tune ACR, -"- (Oct 2008) +C 118 D6-Pro : Tune D6, -"- (Oct 2008) +C 119 D6T-Pro : Tune D6T, -"- (Oct 2008) +C ---- Professor's Q2-ordered Perugia Tune : 129 ----------------------- +C 129 Pro-Q2O : Professor Q2-ordered tune (Feb 2009) +C +C ====== Intermediate and Hybrid Models ================================ +C 200 IM 1 : Intermediate model: new UE, Q2-ord. showers, new CR +C 201 APT : Tune A w. pT-ordered FSR (Mar 2007) +C 211 APT-Pro : Tune APT, with LEP tune from Professor (Oct 2008) +C 221 Perugia APT : "Perugia" update of APT-Pro (Feb 2009) +C 226 Perugia APT6 : "Perugia" update of APT-Pro w. CTEQ6L1 (Feb 2009) +C +C ====== New UE, interleaved pT-ordered showers, annealing CR ========== +C 300 S0 : Sandhoff-Skands Tune using the S0 CR model (Apr 2006) +C 301 S1 : Sandhoff-Skands Tune using the S1 CR model (Apr 2006) +C 302 S2 : Sandhoff-Skands Tune using the S2 CR model (Apr 2006) +C 303 S0A : S0 with "Tune A" UE energy scaling (Apr 2006) +C 304 NOCR : New UE "best try" without col. rec. (Apr 2006) +C 305 Old : New UE, original (primitive) col. rec. (Aug 2004) +C 306 ATLAS-CSC: Arthur Moraes' (new) ATLAS tune w. CTEQ6L1 (?) +C ---- Professor Tunes : 310+ (= 300+ with Professor's tune to LEP) +C 310 S0-Pro : S0 with updated LEP pars from Professor (Oct 2008) +C 311 S1-Pro : S1 -"- (Oct 2008) +C 312 S2-Pro : S2 -"- (Oct 2008) +C 313 S0A-Pro : S0A -"- (Oct 2008) +C 314 NOCR-Pro : NOCR -"- (Oct 2008) +C 315 Old-Pro : Old -"- (Oct 2008) +C 316 ATLAS MC08 : pT-ordered showers, CTEQ6L1 (2008) +C ---- Peter's Perugia Tunes : 320+ ------------------------------------ +C 320 Perugia 0 : "Perugia" update of S0-Pro (Feb 2009) +C 321 Perugia HARD : More ISR, More FSR, Less MPI, Less BR, Less HAD +C 322 Perugia SOFT : Less ISR, Less FSR, More MPI, More BR, More HAD +C 323 Perugia 3 : Alternative to Perugia 0, with different ISR/MPI +C balance & different scaling to LHC & RHIC (Feb 2009) +C 324 Perugia NOCR : "Perugia" update of NOCR-Pro (Feb 2009) +C 325 Perugia * : "Perugia" Tune w. (external) MRSTLO* PDFs (Feb 2009) +C 326 Perugia 6 : "Perugia" Tune w. (external) CTEQ6L1 PDFs (Feb 2009) +C 327 Perugia 10: Alternative to Perugia 0, with more FSR (May 2010) +C off ISR, more BR breakup, more strangeness +C 328 Perugia K : Alternative to Perugia 2010, with a (May 2010) +C K-factor applied to MPI cross sections +C ---- Professor's pT-ordered Perugia Tune : 329 ----------------------- +C 329 Pro-pTO : Professor pT-ordered tune w. S0 CR model (Feb 2009) +C ---- Tunes introduced in 6.4.23: +C 330 ATLAS MC09 : pT-ordered showers, LO* PDFs (2009) +C 331 ATLAS MC09c : pT-ordered showers, LO* PDFs, better CR (2009) +C 334 Perugia 10 NOCR : Perugia 2010 with no CR, less MPI (Oct 2010) +C 335 Pro-pT* : Professor Tune with LO* (Mar 2009) +C 336 Pro-pT6 : Professor Tune with CTEQ6LL (Mar 2009) +C 339 Pro-pT** : Professor Tune with LO** (Mar 2009) +C 340 AMBT1 : First ATLAS tune including 7 TeV data (May 2010) +C 341 Z1 : First CMS tune including 7 TeV data (Aug 2010) +C 342 Z1-LEP : CMS tune Z1, with improved LEP parameters (Oct 2010) +C 343 Z2 : Retune of Z1 by Field w CTEQ6L1 PDFs (2010) +C 344 Z2-LEP : Retune of Z1 by Skands w CTEQ6L1 PDFs (Feb 2011) +C 350 Perugia 2011 : Retune of Perugia 2010 incl 7-TeV data (Mar 2011) +C 351 P2011 radHi : Variation with alphaS(pT/2) +C 352 P2011 radLo : Variation with alphaS(2pT) +C 353 P2011 mpiHi : Variation with more semi-hard MPI +C 354 P2011 noCR : Variation without color reconnections +C 355 P2011 LO** : Perugia 2011 using MSTW LO** PDFs (Mar 2011) +C 356 P2011 C6 : Perugia 2011 using CTEQ6L1 PDFs (Mar 2011) +C 357 P2011 T16 : Variation with PARP(90)=0.32 away from 7 TeV +C 358 P2011 T32 : Variation with PARP(90)=0.16 awat from 7 TeV +C 359 P2011 TeV : Perugia 2011 optimized for Tevatron (Mar 2011) +C 360 S Global : Schulz-Skands Global fit (Mar 2011) +C 361 S 7000 : Schulz-Skands at 7000 GeV (Mar 2011) +C 362 S 1960 : Schulz-Skands at 1960 GeV (Mar 2011) +C 363 S 1800 : Schulz-Skands at 1800 GeV (Mar 2011) +C 364 S 900 : Schulz-Skands at 900 GeV (Mar 2011) +C 365 S 630 : Schulz-Skands at 630 GeV (Mar 2011) +C +C ======= The Uppsala models =========================================== +C ( NB! must be run with special modified Pythia 6.215 version ) +C ( available from http://www.isv.uu.se/thep/MC/scigal/ ) +C 400 GAL 0 : Generalized area-law model. Org pars (Dec 1998) +C 401 SCI 0 : Soft-Colour-Interaction model. Org pars (Dec 1998) +C 402 GAL 1 : GAL 0. Tevatron MB retuned (Skands) (Oct 2006) +C 403 SCI 1 : SCI 0. Tevatron MB retuned (Skands) (Oct 2006) +C +C More details; +C +C Quick Dictionary: +C BE : Bose-Einstein +C BR : Beam Remnants +C CR : Colour Reconnections +C HAD: Hadronization +C ISR/FSR: Initial-State Radiation / Final-State Radiation +C FSI: Final-State Interactions (=CR+BE) +C MB : Minimum-bias +C MI : Multiple Interactions +C UE : Underlying Event +C +C======================================================================= +C TUNES OF OLD FRAMEWORK (Q2-ORDERED ISR AND FSR, NON-INTERLEAVED UE) +C======================================================================= +C +C A (100) and AW (101). CTEQ5L parton distributions +C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) *** +C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+ +C...Key feature: extensively compared to CDF data (R.D. Field). +C...* Large starting scale for ISR (PARP(67)=4) +C...* AW has even more radiation due to smaller mu_R choice in alpha_s. +C...* See: http://www.phys.ufl.edu/~rfield/cdf/ +C +C BW (102). CTEQ5L parton distributions +C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) *** +C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+ +C...Key feature: extensively compared to CDF data (R.D. Field). +C...NB: Can also be run with Pythia 6.2 or 6.312+ +C...* Small starting scale for ISR (PARP(67)=1) +C...* BW has more radiation due to smaller mu_R choice in alpha_s. +C...* See: http://www.phys.ufl.edu/~rfield/cdf/ +C +C DW (103) and DWT (104). CTEQ5L parton distributions +C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) *** +C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+ +C...Key feature: extensively compared to CDF data (R.D. Field). +C...NB: Can also be run with Pythia 6.2 or 6.312+ +C...* Intermediate starting scale for ISR (PARP(67)=2.5) +C...* DWT has a different reference energy, the same as the "S" models +C... below, leading to more UE activity at the LHC, but less at RHIC. +C...* See: http://www.phys.ufl.edu/~rfield/cdf/ +C +C QW (105). CTEQ61 parton distributions +C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) *** +C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+ +C...Key feature: uses CTEQ61 (external pdf library must be linked) +C +C ATLAS-DC2 (106). CTEQ5L parton distributions +C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) *** +C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+ +C...Key feature: tune used by the ATLAS collaboration. +C +C ACR (107). CTEQ5L parton distributions +C...*** NB : SHOULD BE RUN WITH PYTHIA 6.412+ *** +C...Key feature: Tune A modified to use annealing CR. +C...NB: PARP(85)=0D0 and amount of CR is regulated by PARP(78). +C +C D6 (108) and D6T (109). CTEQ6L parton distributions +C...Key feature: Like DW and DWT but retuned to use CTEQ6L PDFs. +C +C A-Pro, BW-Pro, etc (111, 112, etc). CTEQ5L parton distributions +C Old UE model, Q2-ordered showers. +C...Key feature: Rick Field's family of tunes revamped with the +C...Professor Q2-ordered final-state shower and fragmentation tunes +C...presented by Hendrik Hoeth at the Perugia MPI workshop in Oct 2008. +C...Key feature: improved descriptions of LEP data. +C +C Pro-Q2O (129). CTEQ5L parton distributions +C Old UE model, Q2-ordered showers. +C...Key feature: Complete retune of old model by Professor, including +C...large amounts of both LEP and Tevatron data. +C...Note that PARP(64) (ISR renormalization scale pre-factor) is quite +C...extreme in this tune, corresponding to using mu_R = pT/3 . +C +C======================================================================= +C INTERMEDIATE/HYBRID TUNES (MIX OF NEW AND OLD SHOWER AND UE MODELS) +C======================================================================= +C +C IM1 (200). Intermediate model, Q2-ordered showers, +C CTEQ5L parton distributions +C...Key feature: new UE model w Q2-ordered showers and no interleaving. +C...* "Rap" tune of hep-ph/0402078, modified with new annealing CR. +C...* See: Sjostrand & Skands: JHEP 03(2004)053, hep-ph/0402078. +C +C APT (201). Old UE model, pT-ordered final-state showers, +C CTEQ5L parton distributions +C...Key feature: Rick Field's Tune A, but with new final-state showers +C +C APT-Pro (211). Old UE model, pT-ordered final-state showers, +C CTEQ5L parton distributions +C...Key feature: APT revamped with the Professor pT-ordered final-state +C...shower and fragmentation tunes presented by Hendrik Hoeth at the +C...Perugia MPI workshop in October 2008. +C +C Perugia-APT (221). Old UE model, pT-ordered final-state showers, +C CTEQ5L parton distributions +C...Key feature: APT-Pro with final-state showers off the MPI, +C...lower ISR renormalization scale to improve agreement with the +C...Tevatron Drell-Yan pT measurements and with improved energy scaling +C...to min-bias at 630 GeV. +C +C Perugia-APT6 (226). Old UE model, pT-ordered final-state showers, +C CTEQ6L1 parton distributions. +C...Key feature: uses CTEQ6L1 (external pdf library must be linked), +C...with a slightly lower pT0 (2.0 instead of 2.05) due to the smaller +C...UE activity obtained with CTEQ6L1 relative to CTEQ5L. +C +C======================================================================= +C TUNES OF NEW FRAMEWORK (PT-ORDERED ISR AND FSR, INTERLEAVED UE) +C======================================================================= +C +C S0 (300) and S0A (303). CTEQ5L parton distributions +C...Key feature: large amount of multiple interactions +C...* Somewhat faster than the other colour annealing scenarios. +C...* S0A has a faster energy scaling of the UE IR cutoff, borrowed +C... from Tune A, leading to less UE at the LHC, but more at RHIC. +C...* Small amount of radiation. +C...* Large amount of low-pT MI +C...* Low degree of proton lumpiness (broad matter dist.) +C...* CR Type S (driven by free triplets), of medium strength. +C...* See: Pythia6402 update notes or later. +C +C S1 (301). CTEQ5L parton distributions +C...Key feature: large amount of radiation. +C...* Large amount of low-pT perturbative ISR +C...* Large amount of FSR off ISR partons +C...* Small amount of low-pT multiple interactions +C...* Moderate degree of proton lumpiness +C...* Least aggressive CR type (S+S Type I), but with large strength +C...* See: Sandhoff & Skands: FERMILAB-CONF-05-518-T, in hep-ph/0604120. +C +C S2 (302). CTEQ5L parton distributions +C...Key feature: very lumpy proton + gg string cluster formation allowed +C...* Small amount of radiation +C...* Moderate amount of low-pT MI +C...* High degree of proton lumpiness (more spiky matter distribution) +C...* Most aggressive CR type (S+S Type II), but with small strength +C...* See: Sandhoff & Skands: FERMILAB-CONF-05-518-T, in hep-ph/0604120. +C +C NOCR (304). CTEQ5L parton distributions +C...Key feature: no colour reconnections (NB: "Best fit" only). +C...* NB: (Nch) problematic in this tune. +C...* Small amount of radiation +C...* Small amount of low-pT MI +C...* Low degree of proton lumpiness +C...* Large BR composite x enhancement factor +C...* Most clever colour flow without CR ("Lambda ordering") +C +C ATLAS-CSC (306). CTEQ6L parton distributions +C...Key feature: 11-parameter ATLAS tune of the new framework. +C...* Old (pre-annealing) colour reconnections a la 305. +C...* Uses CTEQ6 Leading Order PDFs (must be interfaced externally) +C +C S0-Pro, S1-Pro, etc (310, 311, etc). CTEQ5L parton distributions. +C...Key feature: the S0 family of tunes revamped with the Professor +C...pT-ordered final-state shower and fragmentation tunes presented by +C...Hendrik Hoeth at the Perugia MPI workshop in October 2008. +C...Key feature: improved descriptions of LEP data. +C +C ATLAS MC08 (316). CTEQ6L1 parton distributions +C...Key feature: ATLAS tune of the new framework using CTEQ6L1 PDFs +C...* Warning: uses Peterson fragmentation function for heavy quarks +C...* Uses CTEQ6 Leading Order PDFs (must be interfaced externally) +C +C Perugia-0 (320). CTEQ5L parton distributions. +C...Key feature: S0-Pro retuned to more Tevatron data. Better Drell-Yan +C...pT spectrum, better (Nch) in min-bias, and better scaling to +C...630 GeV than S0-Pro. Also has a slightly smoother mass profile, more +C...beam-remnant breakup (more baryon number transport), and suppression +C...of CR in high-pT string pieces. +C +C Perugia-HARD (321). CTEQ5L parton distributions. +C...Key feature: More ISR, More FSR, Less MPI, Less BR +C...Uses pT/2 as argument of alpha_s for ISR, and a higher Lambda_FSR. +C...Has higher pT0, less intrinsic kT, less beam remnant breakup (less +C...baryon number transport), and more fragmentation pT. +C...Multiplicity in min-bias is LOW, (Nch) is HIGH, +C...DY pT spectrum is HARD. +C +C Perugia-SOFT (322). CTEQ5L parton distributions. +C...Key feature: Less ISR, Less FSR, More MPI, More BR +C...Uses sqrt(2)*pT as argument of alpha_s for ISR, and a lower +C...Lambda_FSR. Has lower pT0, more beam remnant breakup (more baryon +C...number transport), and less fragmentation pT. +C...Multiplicity in min-bias is HIGH, (Nch) is LOW, +C...DY pT spectrum is SOFT +C +C Perugia-3 (323). CTEQ5L parton distributions. +C...Key feature: variant of Perugia-0 with more extreme energy scaling +C...properties while still agreeing with Tevatron data from 630 to 1960. +C...More ISR and less MPI than Perugia-0 at the Tevatron and above and +C...allows FSR off the active end of dipoles stretched to the remnant. +C +C Perugia-NOCR (324). CTEQ5L parton distributions. +C...Key feature: Retune of NOCR-Pro with better scaling properties to +C...lower energies and somewhat better agreement with Tevatron data +C...at 1800/1960. +C +C Perugia-* (325). MRST LO* parton distributions for generators +C...Key feature: first attempt at using the LO* distributions +C...(external pdf library must be linked). +C +C Perugia-6 (326). CTEQ6L1 parton distributions +C...Key feature: uses CTEQ6L1 (external pdf library must be linked). +C +C Perugia-2010 (327). CTEQ5L parton distributions +C...Key feature: Retune of Perugia 0 to attempt to better describe +C...strangeness yields at RHIC and at LEP. Also increased the amount +C...of FSR off ISR following the conclusions in arXiv:1001.4082. +C...Increased the amount of beam blowup, causing more baryon transport +C...into the detector, to further explore this possibility. Using +C...a new color-reconnection model that relies on determining a thrust +C...axis for the events and then computing reconnection probabilities for +C...the individual string pieces based on the actual string densities +C...per rapidity interval along that thrust direction. +C +C Perugia-K (328). CTEQ5L parton distributions +C...Key feature: uses a ``K'' factor on the MPI cross sections +C...This gives a larger rate of minijets and pushes the underlying-event +C...activity towards higher pT. To compensate for the increased activity +C...at higher pT, the infared regularization scale is larger for this tune. +C +C Pro-pTO (329). CTEQ5L parton distributions +C...Key feature: Complete retune of new model by Professor, including +C...large amounts of both LEP and Tevatron data. Similar to S0A-Pro. +C +C ATLAS MC09 (330). LO* parton distributions +C...Key feature: Good overall agreement with Tevatron and early LHC data. +C...Similar to Perugia *. +C +C ATLAS MC09c (331). LO* parton distributions +C...Key feature: Good overall agreement with Tevatron and 900-GeV LHC data. +C...Similar to Perugia *. Retuned CR model with respect to MC09. +C +C Pro-pT* (335) LO* parton distributions +C...Key feature: Retune of Pro-PTO with MRST LO* PDFs. +C +C Pro-pT6 (336). CTEQ6L1 parton distributions +C...Key feature: Retune of Pro-PTO with CTEQ6L1 PDFs. +C +C Pro-pT** (339). LO** parton distributions +C...Key feature: Retune of Pro-PTO with MRST LO** PDFs. +C +C AMBT1 (340). LO* parton distributions +C...Key feature: First ATLAS tune including 7-TeV LHC data. +C...Mainly retuned CR and mass distribution with respect to MC09c. +C...Note: cannot be run standalone since it uses external PDFs. +C +C CMSZ1 (341). CTEQ5L parton distributions +C...Key feature: First CMS tune including 7-TeV LHC data. +C...Uses many of the features of AMBT1, but uses CTEQ5L PDFs, +C...has a lower pT0 at the Tevatron, which scales faster with energy. +C +C Z1-LEP (342). CTEQ5L parton distributions +C...Key feature: CMS tune Z1 with improved LEP parameters, mostly +C...taken from the Professor/Perugia tunes, with a few minor updates. +C +C======================================================================= +C OTHER TUNES +C======================================================================= +C +C...The GAL and SCI models (400+) are special and *SHOULD NOT* be run +C...with an unmodified Pythia distribution. +C...See http://www.isv.uu.se/thep/MC/scigal/ for more information. +C +C ::: + Future improvements? +C Include also QCD K-factor a la M. Heinz / ATLAS TDR ? RDF's QK? +C (problem: K-factor affects everything so only works as +C intended for min-bias, not for UE ... probably need a +C better long-term solution to handle UE as well. Anyway, +C Mark uses MSTP(33) and PARP(31)-PARP(33).) + +C...Global statements + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + INTEGER PYK,PYCHGE,PYCOMP + +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + +C...SCI and GAL Commonblocks + COMMON /SCIPAR/MSWI(2),PARSCI(2) + +C...SAVE statements + SAVE /PYDAT1/,/PYPARS/ + SAVE /SCIPAR/ + +C...Internal parameters + PARAMETER(MXTUNS=500) + CHARACTER*8 CHDOC + PARAMETER (CHDOC='Mar 2011') + CHARACTER*16 CHNAMS(0:MXTUNS), CHNAME + CHARACTER*42 CHMSTJ(50), CHMSTP(100), CHPARP(100), + & CHPARJ(100), CHMSTU(101:121), CHPARU(101:121), CH40 + CHARACTER*60 CH60 + CHARACTER*70 CH70 + DATA (CHNAMS(I),I=0,1)/'Default',' '/ + DATA (CHNAMS(I),I=100,119)/ + & 'Tune A','Tune AW','Tune BW','Tune DW','Tune DWT','Tune QW', + & 'ATLAS DC2','Tune ACR','Tune D6','Tune D6T', + 1 'Tune A-Pro','Tune AW-Pro','Tune BW-Pro','Tune DW-Pro', + 1 'Tune DWT-Pro','Tune QW-Pro','ATLAS DC2-Pro','Tune ACR-Pro', + 1 'Tune D6-Pro','Tune D6T-Pro'/ + DATA (CHNAMS(I),I=120,129)/ + & 9*' ','Pro-Q2O'/ + DATA (CHNAMS(I),I=300,309)/ + & 'Tune S0','Tune S1','Tune S2','Tune S0A','NOCR','Old', + 5 'ATLAS-CSC Tune','Yale Tune','Yale-K Tune',' '/ + DATA (CHNAMS(I),I=310,316)/ + & 'Tune S0-Pro','Tune S1-Pro','Tune S2-Pro','Tune S0A-Pro', + & 'NOCR-Pro','Old-Pro','ATLAS MC08'/ + DATA (CHNAMS(I),I=320,329)/ + & 'Perugia 0','Perugia HARD','Perugia SOFT', + & 'Perugia 3','Perugia NOCR','Perugia LO*', + & 'Perugia 6','Perugia 10','Perugia K','Pro-pTO'/ + DATA (CHNAMS(I),I=330,349)/ + & 'ATLAS MC09','ATLAS MC09c',2*' ','Perugia 10 NOCR','Pro-PT*', + & 'Pro-PT6',' ',' ','Pro-PT**', + 4 'Tune AMBT1','Tune Z1','Tune Z1-LEP','Tune Z2','Tune Z2-LEP', + 4 5*' '/ + DATA (CHNAMS(I),I=350,359)/ + & 'Perugia 2011','P2011 radHi','P2011 radLo','P2011 mpiHi', + & 'P2011 noCR','P2011 M(LO**)', 'P2011 CTEQ6L1', + & 'P2011 T16','P2011 T32','P2011 Tevatron'/ + DATA (CHNAMS(I),I=360,369)/ + & 'S Global','S 7000','S 1960','S 1800', + & 'S 900','S 630', 4*' '/ + DATA (CHNAMS(I),I=200,229)/ + & 'IM Tune 1','Tune APT',8*' ', + & ' ','Tune APT-Pro',8*' ', + & ' ','Perugia APT',4*' ','Perugia APT6',3*' '/ + DATA (CHNAMS(I),I=400,409)/ + & 'GAL Tune 0','SCI Tune 0','GAL Tune 1','SCI Tune 1',6*' '/ + DATA (CHMSTJ(I),I=11,20)/ + & 'HAD choice of fragmentation function(s)',4*' ', + & 'HAD treatment of small-mass systems',4*' '/ + DATA (CHMSTJ(I),I=41,50)/ + & 'FSR type (Q2 or pT) for old framework',9*' '/ + DATA (CHMSTP(I),I=1,10)/ + & 2*' ','INT switch for choice of LambdaQCD',7*' '/ + DATA (CHMSTP(I),I=31,40)/ + & 2*' ','"K" switch for K-factor on/off & type',7*' '/ + DATA (CHMSTP(I),I=51,100)/ + 5 'PDF set','PDF set internal (=1) or pdflib (=2)',8*' ', + 6 'ISR master switch',2*' ','ISR alphaS type',2*' ', + 6 'ISR coherence option for 1st emission', + 6 'ISR phase space choice & ME corrections',' ', + 7 'ISR IR regularization scheme',' ', + 7 'IFSR scheme for non-decay FSR',8*' ', + 8 'UE model', + 8 'UE hadron transverse mass distribution',5*' ', + 8 'BR composite scheme','BR color scheme', + 9 'BR primordial kT compensation', + 9 'BR primordial kT distribution', + 9 'BR energy partitioning scheme',2*' ', + 9 'FSI color (re-)connection model',5*' '/ + DATA (CHPARP(I),I=1,10)/ + & 'ME/UE LambdaQCD',9*' '/ + DATA (CHPARP(I),I=31,40)/ + & ' ','"K" K-factor',8*' '/ + DATA (CHPARP(I),I=61,100)/ + 6 'ISR LambdaQCD','ISR IR cutoff',' ', + 6 'ISR renormalization scale prefactor', + 6 2*' ','ISR Q2max factor',3*' ', + 7 'IFSR Q2max factor in non-s-channel procs', + 7 'IFSR LambdaQCD (outside resonance decays)',4*' ', + 7 'FSI color reco high-pT damping strength', + 7 'FSI color reconnection strength', + 7 'BR composite x enhancement','BR breakup suppression', + 8 2*'UE IR cutoff at reference ecm', + 8 2*'UE mass distribution parameter', + 8 'UE gg color correlated fraction','UE total gg fraction', + 8 2*' ', + 8 'UE IR cutoff reference ecm', + 8 'UE IR cutoff ecm scaling power', + 9 'BR primordial kT width <|kT|>',' ', + 9 'BR primordial kT UV cutoff',7*' '/ + DATA (CHPARJ(I),I=1,30)/ + & 'HAD diquark suppression','HAD strangeness suppression', + & 'HAD strange diquark suppression', + & 'HAD vector diquark suppression','HAD P(popcorn)', + & 'HAD extra popcorn B(s)-M-B(s) supp', + & 'HAD extra popcorn B-M(s)-B supp', + & 3*' ', + 1 'HAD P(vector meson), u and d only', + 1 'HAD P(vector meson), contains s', + 1 'HAD P(vector meson), heavy quarks',7*' ', + 2 'HAD fragmentation pT',' ',' ',' ', + 2 'HAD eta0 suppression',"HAD eta0' suppression",4*' '/ + DATA (CHPARJ(I),I=41,90)/ + 4 'HAD string parameter a(Meson)','HAD string parameter b', + 4 2*' ','HAD string a(Baryon)-a(Meson)', + 4 'HAD Lund(=0)-Bowler(=1) rQ (rc)', + 4 'HAD Lund(=0)-Bowler(=1) rb',3*' ', + 5 3*' ', 'HAD charm parameter','HAD bottom parameter',5*' ', + 6 10*' ',10*' ', + 8 'FSR LambdaQCD (inside resonance decays)', + & 'FSR IR cutoff',8*' '/ + DATA (CHMSTU(I),I=111,120)/ + 1 ' ','INT n(flavors) for LambdaQCD',8*' '/ + DATA (CHPARU(I),I=111,120)/ + 1 ' ','INT LambdaQCD',8*' '/ + +C...1) Shorthand notation + M13=MSTU(13) + M11=MSTU(11) + IF (ITUNE.LE.MXTUNS.AND.ITUNE.GE.0) THEN + CHNAME=CHNAMS(ITUNE) + IF (ITUNE.EQ.0) GOTO 9999 + ELSE + CALL PYERRM(9,'(PYTUNE:) Tune number > max. Using defaults.') + GOTO 9999 + ENDIF + +C...2) Hello World + IF (M13.GE.1) WRITE(M11,5000) CHDOC + +C...Hardcode some defaults +C...Get Lambda from PDF + MSTP(3) = 2 +C...CTEQ5L1 PDFs + MSTP(52) = 1 + MSTP(51) = 7 +C... No K-factor + MSTP(33) = 0 + +C...3) Tune parameters + +C======================================================================= +C...ATLAS MC08 + + IF (ITUNE.EQ.316) THEN + + IF (M13.GE.1) WRITE(M11,5010) ITUNE, CHNAME + IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN + CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'// + & ' with tune.') + ENDIF + +C...First set some explicit defaults from 6.4.20 +C...# Old defaults + MSTJ(11) = 4 +C...# Old default flavour parameters + PARJ(1) = 0.1 + PARJ(2) = 0.3 + PARJ(3) = 0.40 + PARJ(4) = 0.05 + PARJ(11) = 0.5 + PARJ(12) = 0.6 + PARJ(21) = 0.36 + PARJ(41) = 0.30 + PARJ(42) = 0.58 + PARJ(46) = 1.0 + PARJ(82) = 1.0 + +C...PDFs: CTEQ6L1 for 326 + MSTP(52)=2 + MSTP(51)=10042 + +C...UE and ISR switches + MSTP(81)=21 + MSTP(82)=4 + MSTP(70)=0 + MSTP(72)=1 + +C...CR: + MSTP(95)=2 + PARP(78)=0.3 + PARP(77)=0.0 + PARP(80)=0.1 + +C...Primordial kT + PARP(91)=2.0D0 + PARP(93)=5.0D0 + +C...MPI: + PARP(82)=2.1 + PARP(83)=0.8 + PARP(84)=0.7 + PARP(89)=1800.0 + PARP(90)=0.16 + +C...FSR inside resonance decays + PARJ(81)=0.29 + +C...Fragmentation (warning: uses Peterson) + MSTJ(11)=3 + PARJ(54)=-0.07 + PARJ(55)=-0.006 + MSTJ(22)=2 + + IF (M13.GE.1) THEN + CH60='Tuned by ATLAS, ATL-PHYS-PUB-2010-002' + WRITE(M11,5030) CH60 + CH60='Physics model: '// + & 'T. Sjostrand & P. Skands, hep-ph/0408302' + WRITE(M11,5030) CH60 + CH60='CR by M. Sandhoff & P. Skands, in hep-ph/0604120' + WRITE(M11,5030) CH60 + +C...Output + WRITE(M11,5030) ' ' + WRITE(M11,5040) 51, MSTP(51), CHMSTP(51) + WRITE(M11,5040) 52, MSTP(52), CHMSTP(52) + WRITE(M11,5040) 3, MSTP( 3), CHMSTP( 3) + IF (MSTP(70).EQ.0) THEN + WRITE(M11,5050) 62, PARP(62), CHPARP(62) + ENDIF + WRITE(M11,5040) 64, MSTP(64), CHMSTP(64) + WRITE(M11,5050) 64, PARP(64), CHPARP(64) + WRITE(M11,5040) 67, MSTP(67), CHMSTP(67) + WRITE(M11,5050) 67, PARP(67), CHPARP(67) + WRITE(M11,5040) 68, MSTP(68), CHMSTP(68) + CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)' + WRITE(M11,5030) CH60 + WRITE(M11,5040) 70, MSTP(70), CHMSTP(70) + WRITE(M11,5040) 72, MSTP(72), CHMSTP(72) + WRITE(M11,5050) 71, PARP(71), CHPARP(71) + WRITE(M11,5060) 81, PARJ(81), CHPARJ(81) + WRITE(M11,5060) 82, PARJ(82), CHPARJ(82) + WRITE(M11,5040) 33, MSTP(33), CHMSTP(33) + WRITE(M11,5040) 81, MSTP(81), CHMSTP(81) + WRITE(M11,5050) 82, PARP(82), CHPARP(82) + WRITE(M11,5050) 89, PARP(89), CHPARP(89) + WRITE(M11,5050) 90, PARP(90), CHPARP(90) + WRITE(M11,5040) 82, MSTP(82), CHMSTP(82) + WRITE(M11,5050) 83, PARP(83), CHPARP(83) + WRITE(M11,5050) 84, PARP(84), CHPARP(84) + WRITE(M11,5040) 88, MSTP(88), CHMSTP(88) + WRITE(M11,5040) 89, MSTP(89), CHMSTP(89) + WRITE(M11,5050) 79, PARP(79), CHPARP(79) + WRITE(M11,5050) 80, PARP(80), CHPARP(80) + WRITE(M11,5040) 91, MSTP(91), CHMSTP(91) + WRITE(M11,5050) 91, PARP(91), CHPARP(91) + WRITE(M11,5050) 93, PARP(93), CHPARP(93) + WRITE(M11,5040) 95, MSTP(95), CHMSTP(95) + IF (MSTP(95).GE.1) THEN + WRITE(M11,5050) 78, PARP(78), CHPARP(78) + IF (MSTP(95).GE.2) WRITE(M11,5050) 77, PARP(77), CHPARP(77) + ENDIF + + ENDIF + +C======================================================================= +C...ATLAS MC09, MC09c, AMBT1 +C...CMS Z1 (R. Field), Z1-LEP + + ELSEIF (ITUNE.EQ.330.OR.ITUNE.EQ.331.OR.ITUNE.EQ.340.OR. + & ITUNE.GE.341.AND.ITUNE.LE.344) THEN + + IF (M13.GE.1) WRITE(M11,5010) ITUNE, CHNAME + IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN + CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'// + & ' with tune.') + ENDIF + +C...First set some explicit defaults from 6.4.20 + IF (ITUNE.LE.341.OR.ITUNE.EQ.343) THEN +C... # Old defaults + MSTJ(11) = 4 +C...# Old default flavour parameters + PARJ(1) = 0.1 + PARJ(2) = 0.3 + PARJ(3) = 0.40 + PARJ(4) = 0.05 + PARJ(11) = 0.5 + PARJ(12) = 0.6 + PARJ(21) = 0.36 + PARJ(41) = 0.30 + PARJ(42) = 0.58 + PARJ(46) = 1.0 + PARJ(82) = 1.0 + ELSE +C...# For Zn-LEP tunes, use tuned flavour parameters from Professor/Perugia + PARJ( 1) = 0.08D0 + PARJ( 2) = 0.21D0 + PARJ(3) = 0.94 + PARJ( 4) = 0.04D0 + PARJ(11) = 0.35D0 + PARJ(12) = 0.35D0 + PARJ(13) = 0.54 + PARJ(25) = 0.63 + PARJ(26) = 0.12 +C...# Switch on Bowler: + MSTJ(11) = 5 +C...# Fragmentation + PARJ(21) = 0.34D0 + PARJ(41) = 0.35D0 + PARJ(42) = 0.80D0 + PARJ(47) = 1.0 + PARJ(81) = 0.26D0 + PARJ(82) = 1.0D0 + ENDIF + +C...PDFs: MRST LO* + MSTP(52)=2 + MSTP(51)=20650 + IF (ITUNE.EQ.341.OR.ITUNE.EQ.342) THEN +C...Z1 uses CTEQ5L + MSTP(52)=1 + MSTP(51)=7 + ELSEIF (ITUNE.EQ.343.OR.ITUNE.EQ.344) THEN +C...Z2 uses CTEQ6L + MSTP(52)=2 + MSTP(51)=10042 + ENDIF + +C...UE and ISR switches + MSTP(81)=21 + MSTP(82)=4 + MSTP(70)=0 + MSTP(72)=1 + +C...CR: + MSTP(95)=6 + PARP(78)=0.3 + PARP(77)=0.0 + PARP(80)=0.1 + IF (ITUNE.EQ.331) THEN + PARP(78)=0.224 + ELSEIF (ITUNE.EQ.340) THEN +C...AMBT1 + PARP(77)=1.016D0 + PARP(78)=0.538D0 + ELSEIF (ITUNE.GE.341.AND.ITUNE.LE.344) THEN +C...Z1 and Z2 use the AMBT1 CR values + PARP(77)=1.016D0 + PARP(78)=0.538D0 + ENDIF + +C...MPI: + PARP(82)=2.3 + PARP(83)=0.8 + PARP(84)=0.7 + PARP(89)=1800.0 + PARP(90)=0.25 + IF (ITUNE.EQ.331) THEN + PARP(82)=2.315 + PARP(90)=0.2487 + ELSEIF (ITUNE.EQ.340) THEN + PARP(82)=2.292D0 + PARP(83)=0.356D0 + PARP(84)=0.651 + PARP(90)=0.25D0 + ELSEIF (ITUNE.EQ.341.OR.ITUNE.EQ.342) THEN + PARP(82)=1.932D0 + PARP(83)=0.356D0 + PARP(84)=0.651 + PARP(90)=0.275D0 + ELSEIF (ITUNE.EQ.343.OR.ITUNE.EQ.344) THEN + PARP(82)=1.832D0 + PARP(83)=0.356D0 + PARP(84)=0.651 + PARP(90)=0.275D0 + ENDIF + +C...Primordial kT + PARP(91)=2.0D0 + PARP(93)=5D0 + IF (ITUNE.GE.340) THEN + PARP(93)=10D0 + ENDIF + +C...ISR + IF (ITUNE.GE.340) THEN + PARP(62)=1.025 + ENDIF + +C...FSR inside resonance decays + PARJ(81)=0.29 + +C...Fragmentation (org 6.4 defs hardcoded) + MSTJ(11)=4 + PARJ(41)=0.3 + PARJ(42)=0.58 + MSTJ(22)=2 +C...AMBT1 mentions 46 explicitly, but Z1 doesn't ... + PARJ(46)=0.75 + IF (ITUNE.GE.341.AND.ITUNE.LE.344) THEN +C...Reset PARJ(46) to org def value for Z1 and Z2 + PARJ(46)=1.0 + ENDIF + + IF (M13.GE.1) THEN + IF (ITUNE.LT.340) THEN + CH60='Tuned by ATLAS, ATL-PHYS-PUB-2010-002' + ELSEIF (ITUNE.EQ.340) THEN + CH60='Tuned by ATLAS, ATLAS-CONF-2010-031' + ELSEIF (ITUNE.EQ.341) THEN + CH60='AMBT1 Tuned by ATLAS, ATLAS-CONF-2010-031' + WRITE(M11,5030) CH60 + CH60='Z1 variation tuned by R. D. Field (CMS)' + ELSEIF (ITUNE.EQ.342) THEN + CH60='AMBT1 Tuned by ATLAS, ATLAS-CONF-2010-031' + WRITE(M11,5030) CH60 + CH60='Z1 variation retuned by R. D. Field (CMS)' + WRITE(M11,5030) CH60 + CH60='Z1-LEP variation retuned by Professor / P. Skands' + ELSEIF (ITUNE.EQ.343) THEN + CH60='AMBT1 Tuned by ATLAS, ATLAS-CONF-2010-031' + WRITE(M11,5030) CH60 + CH60='Z2 variation retuned by R. D. Field (CMS)' + ELSEIF (ITUNE.EQ.344) THEN + CH60='AMBT1 Tuned by ATLAS, ATLAS-CONF-2010-031' + WRITE(M11,5030) CH60 + CH60='Z2 variation retuned by R. D. Field (CMS)' + WRITE(M11,5030) CH60 + CH60='Z2-LEP variation retuned by Professor / P. Skands' + ENDIF + WRITE(M11,5030) CH60 + CH60='Physics Model: '// + & 'T. Sjostrand & P. Skands, hep-ph/0408302' + WRITE(M11,5030) CH60 + CH60='CR by M. Sandhoff & P. Skands, in hep-ph/0604120' + WRITE(M11,5030) CH60 + +C...Output + WRITE(M11,5030) ' ' + WRITE(M11,5040) 51, MSTP(51), CHMSTP(51) + WRITE(M11,5040) 52, MSTP(52), CHMSTP(52) + WRITE(M11,5040) 3, MSTP( 3), CHMSTP( 3) + IF (MSTP(70).EQ.0) THEN + WRITE(M11,5050) 62, PARP(62), CHPARP(62) + ENDIF + WRITE(M11,5040) 64, MSTP(64), CHMSTP(64) + WRITE(M11,5050) 64, PARP(64), CHPARP(64) + WRITE(M11,5040) 67, MSTP(67), CHMSTP(67) + WRITE(M11,5050) 67, PARP(67), CHPARP(67) + WRITE(M11,5040) 68, MSTP(68), CHMSTP(68) + CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)' + WRITE(M11,5030) CH60 + WRITE(M11,5040) 70, MSTP(70), CHMSTP(70) + WRITE(M11,5040) 72, MSTP(72), CHMSTP(72) + WRITE(M11,5050) 71, PARP(71), CHPARP(71) + WRITE(M11,5060) 81, PARJ(81), CHPARJ(81) + WRITE(M11,5060) 82, PARJ(82), CHPARJ(82) + WRITE(M11,5040) 33, MSTP(33), CHMSTP(33) + WRITE(M11,5040) 81, MSTP(81), CHMSTP(81) + WRITE(M11,5050) 82, PARP(82), CHPARP(82) + WRITE(M11,5050) 89, PARP(89), CHPARP(89) + WRITE(M11,5050) 90, PARP(90), CHPARP(90) + WRITE(M11,5040) 82, MSTP(82), CHMSTP(82) + WRITE(M11,5050) 83, PARP(83), CHPARP(83) + WRITE(M11,5050) 84, PARP(84), CHPARP(84) + WRITE(M11,5040) 88, MSTP(88), CHMSTP(88) + WRITE(M11,5040) 89, MSTP(89), CHMSTP(89) + WRITE(M11,5050) 79, PARP(79), CHPARP(79) + WRITE(M11,5050) 80, PARP(80), CHPARP(80) + WRITE(M11,5040) 91, MSTP(91), CHMSTP(91) + WRITE(M11,5050) 91, PARP(91), CHPARP(91) + WRITE(M11,5050) 93, PARP(93), CHPARP(93) + WRITE(M11,5040) 95, MSTP(95), CHMSTP(95) + IF (MSTP(95).GE.1) THEN + WRITE(M11,5050) 78, PARP(78), CHPARP(78) + IF (MSTP(95).GE.2) WRITE(M11,5050) 77, PARP(77), CHPARP(77) + ENDIF + + ENDIF + +C======================================================================= +C...S0, S1, S2, S0A, NOCR, Rap, +C...S0-Pro, S1-Pro, S2-Pro, S0A-Pro, NOCR-Pro, Rap-Pro +C...Perugia 0, HARD, SOFT, 3, LO*, 6, 2010, K +C...Pro-pTO, Pro-PT*, Pro-PT6, Pro-PT** +C...Perugia 2011 (incl variations) +C...Schulz-Skands tunes + ELSEIF ((ITUNE.GE.300.AND.ITUNE.LE.305) + & .OR.(ITUNE.GE.310.AND.ITUNE.LE.315) + & .OR.(ITUNE.GE.320.AND.ITUNE.LE.329) + & .OR.(ITUNE.GE.334.AND.ITUNE.LE.336).OR.ITUNE.EQ.339 + & .OR.(ITUNE.GE.350.AND.ITUNE.LE.365)) THEN + IF (M13.GE.1) WRITE(M11,5010) ITUNE, CHNAME + IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN + CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'// + & ' with tune.') + ELSEIF(ITUNE.GE.320.AND.ITUNE.LE.339.AND.ITUNE.NE.324.AND. + & ITUNE.NE.334.AND. + & (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.419))) + & THEN + CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'// + & ' with tune.') + ELSEIF((ITUNE.EQ.327.OR.ITUNE.EQ.328.OR.ITUNE.GE.350).AND. + & (MSTP(181).LE.5.OR. + & (MSTP(181).EQ.6.AND.MSTP(182).LE.422))) + & THEN + CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'// + & ' with tune.') + ENDIF + +C...Use 327 as base tune for 350-359 (Perugia 2011) + ITUNSV = ITUNE + IF (ITUNE.GE.350.AND.ITUNE.LE.359) ITUNE = 327 +C...Use 320 as base tune for 360+ (Schulz-Skands) + IF (ITUNE.GE.360) ITUNE = 320 + +C...HAD: Use Professor's LEP pars if ITUNE >= 310 +C...(i.e., for S0-Pro, S1-Pro etc, and for Perugia tunes) + IF (ITUNE.LT.310) THEN +C...# Old defaults + MSTJ(11) = 4 +C...# Old default flavour parameters + PARJ(1) = 0.1 + PARJ(2) = 0.3 + PARJ(3) = 0.40 + PARJ(4) = 0.05 + PARJ(11) = 0.5 + PARJ(12) = 0.6 + PARJ(21) = 0.36 + PARJ(41) = 0.30 + PARJ(42) = 0.58 + PARJ(46) = 1.0 + PARJ(82) = 1.0 + + ELSEIF (ITUNE.GE.310) THEN +C...# Tuned flavour parameters: + PARJ(1) = 0.073 + PARJ(2) = 0.2 + PARJ(3) = 0.94 + PARJ(4) = 0.032 + PARJ(11) = 0.31 + PARJ(12) = 0.4 + PARJ(13) = 0.54 + PARJ(25) = 0.63 + PARJ(26) = 0.12 +C...# Always use pT-ordered shower: + MSTJ(41) = 12 +C...# Switch on Bowler: + MSTJ(11) = 5 +C...# Fragmentation + PARJ(21) = 0.313 + PARJ(41) = 0.49 + PARJ(42) = 1.2 + PARJ(47) = 1.0 + PARJ(81) = 0.257 + PARJ(82) = 0.8 + +C...HAD: fragmentation pT (only if not using professor) - HARD and SOFT + IF (ITUNE.EQ.321) PARJ(21)=0.34D0 + IF (ITUNE.EQ.322) PARJ(21)=0.28D0 + +C...HAD: P-2010 and P-K use different strangeness parameters +C... indicated by LEP and RHIC yields. +C...(only 5% different from Professor values, so should be within acceptable +C...theoretical uncertainty range) +C...(No attempt made to retune other flavor parameters post facto) + IF (ITUNE.EQ.327.OR.ITUNE.EQ.328.OR.ITUNE.EQ.334) THEN + PARJ( 1) = 0.08D0 + PARJ( 2) = 0.21D0 + PARJ( 4) = 0.04D0 + PARJ(11) = 0.35D0 + PARJ(12) = 0.35D0 + PARJ(21) = 0.36D0 + PARJ(41) = 0.35D0 + PARJ(42) = 0.90D0 + PARJ(81) = 0.26D0 + PARJ(82) = 1.0D0 + ENDIF + ENDIF + +C...Remove middle digit now for Professor variants, since identical pars + ITUNEB=ITUNE + IF (ITUNE.GE.310.AND.ITUNE.LE.319) THEN + ITUNEB=(ITUNE/100)*100+MOD(ITUNE,10) + ENDIF + +C...PDFs: all use CTEQ5L as starting point + MSTP(52)=1 + MSTP(51)=7 + IF (ITUNE.EQ.325.OR.ITUNE.EQ.335) THEN +C...MRST LO* for 325 and 335 + MSTP(52)=2 + MSTP(51)=20650 + ELSEIF (ITUNE.EQ.326.OR.ITUNE.EQ.336) THEN +C...CTEQ6L1 for 326 and 336 + MSTP(52)=2 + MSTP(51)=10042 + ELSEIF (ITUNE.EQ.339) THEN +C...MRST LO** for 339 + MSTP(52)=2 + MSTP(51)=20651 + ENDIF + +C...LambdaQCD choice: 327 and 328 use hardcoded, others get from PDF + MSTP(3)=2 + IF (ITUNE.EQ.327.OR.ITUNE.EQ.328.OR.ITUNE.EQ.334) THEN + MSTP(3) = 1 +C...Hardcode CTEQ5L values for ME and ISR + MSTU(112) = 4 + PARU(112) = 0.192D0 + PARP(61) = 0.192D0 + PARP( 1) = 0.192D0 +C...but use LEP value also for non-res FSR + PARP(72) = 0.260D0 + ENDIF + +C...ISR: use Lambda_MSbar with default scale for S0(A) + MSTP(64)=2 + PARP(64)=1D0 + IF (ITUNE.EQ.320.OR.ITUNE.EQ.323.OR.ITUNE.EQ.324.OR.ITUNE.EQ.334 + & .OR.ITUNE.EQ.326.OR.ITUNE.EQ.327.OR.ITUNE.EQ.328) THEN +C...Use Lambda_MC with muR^2=pT^2 for most central Perugia tunes + MSTP(64)=3 + PARP(64)=1D0 + ELSEIF (ITUNE.EQ.321) THEN +C...Use Lambda_MC with muR^2=(1/2pT)^2 for Perugia HARD + MSTP(64)=3 + PARP(64)=0.25D0 + ELSEIF (ITUNE.EQ.322) THEN +C...Use Lambda_MSbar with muR^2=2pT^2 for Perugia SOFT + MSTP(64)=2 + PARP(64)=2D0 + ELSEIF (ITUNE.EQ.325) THEN +C...Use Lambda_MC with muR^2=2pT^2 for Perugia LO* + MSTP(64)=3 + PARP(64)=2D0 + ELSEIF (ITUNE.EQ.329.OR.ITUNE.EQ.335.OR.ITUNE.EQ.336.OR. + & ITUNE.EQ.339) THEN +C...Use Lambda_MSbar with P64=1.3 for Pro-pT0 + MSTP(64)=2 + PARP(64)=1.3D0 + IF (ITUNE.EQ.335) PARP(64)=0.92D0 + IF (ITUNE.EQ.336) PARP(64)=0.89D0 + IF (ITUNE.EQ.339) PARP(64)=0.97D0 + ENDIF + +C...ISR : power-suppressed power showers above s_color (since 6.4.19) + MSTP(67)=2 + PARP(67)=4D0 +C...Perugia tunes have stronger suppression, except HARD + IF ((ITUNE.GE.320.AND.ITUNE.LE.328).OR.ITUNE.EQ.334) THEN + PARP(67)=1D0 + IF (ITUNE.EQ.321) PARP(67)=4D0 + IF (ITUNE.EQ.322) PARP(67)=0.25D0 + ENDIF + +C...ISR IR cutoff type and FSR off ISR setting: +C...Smooth ISR, low FSR-off-ISR + MSTP(70)=2 + MSTP(72)=0 + IF (ITUNEB.EQ.301) THEN +C...S1, S1-Pro: sharp ISR, high FSR + MSTP(70)=0 + MSTP(72)=1 + ELSEIF (ITUNE.EQ.320.OR.ITUNE.EQ.324.OR.ITUNE.EQ.326 + & .OR.ITUNE.EQ.325) THEN +C...Perugia default is smooth ISR, high FSR-off-ISR + MSTP(70)=2 + MSTP(72)=1 + ELSEIF (ITUNE.EQ.321) THEN +C...Perugia HARD: sharp ISR, high FSR-off-ISR (but no dip-to-BR rad) + MSTP(70)=0 + PARP(62)=1.25D0 + MSTP(72)=1 + ELSEIF (ITUNE.EQ.322) THEN +C...Perugia SOFT: scaling sharp ISR, low FSR-off-ISR + MSTP(70)=1 + PARP(81)=1.5D0 + MSTP(72)=0 + ELSEIF (ITUNE.EQ.323) THEN +C...Perugia 3: sharp ISR, high FSR-off-ISR (with dipole-to-BR radiating) + MSTP(70)=0 + PARP(62)=1.25D0 + MSTP(72)=2 + ELSEIF (ITUNE.EQ.327.OR.ITUNE.EQ.328.OR.ITUNE.EQ.334) THEN +C...Perugia 2010/K: smooth ISR, high FSR-off-ISR (with dipole-to-BR radiating) + MSTP(70)=2 + MSTP(72)=2 + ENDIF + +C...FSR activity: Perugia tunes use a lower PARP(71) as indicated +C...by Professor tunes (with HARD and SOFT variations) + PARP(71)=4D0 + IF ((ITUNE.GE.320.AND.ITUNE.LE.328).OR.ITUNE.EQ.334) THEN + PARP(71)=2D0 + IF (ITUNE.EQ.321) PARP(71)=4D0 + IF (ITUNE.EQ.322) PARP(71)=1D0 + ENDIF + IF (ITUNE.EQ.329) PARP(71)=2D0 + IF (ITUNE.EQ.335) PARP(71)=1.29D0 + IF (ITUNE.EQ.336) PARP(71)=1.72D0 + IF (ITUNE.EQ.339) PARP(71)=1.20D0 + +C...FSR: Lambda_FSR scale (only if not using professor) + IF (ITUNE.LT.310) PARJ(81)=0.23D0 + IF (ITUNE.EQ.321) PARJ(81)=0.30D0 + IF (ITUNE.EQ.322) PARJ(81)=0.20D0 + +C...K-factor : only 328 uses a K-factor on the UE cross sections + MSTP(33)=0 + IF (ITUNE.EQ.328) THEN + MSTP(33)=10 + PARP(32)=1.5 + ENDIF +C...UE on, new model + MSTP(81)=21 + +C...UE: hadron-hadron overlap profile (expOfPow for all) + MSTP(82)=5 +C...UE: Overlap smoothness (1.0 = exponential; 2.0 = gaussian) + PARP(83)=1.6D0 + IF (ITUNEB.EQ.301) PARP(83)=1.4D0 + IF (ITUNEB.EQ.302) PARP(83)=1.2D0 +C...NOCR variants have very smooth distributions + IF (ITUNEB.EQ.304) PARP(83)=1.8D0 + IF (ITUNEB.EQ.305) PARP(83)=2.0D0 + IF ((ITUNE.GE.320.AND.ITUNE.LE.328).OR.ITUNE.EQ.334) THEN +C...Perugia variants have slightly smoother profiles by default +C...(to compensate for more tail by added radiation) +C...Perugia-SOFT has more peaked distribution, NOCR less peaked + PARP(83)=1.7D0 + IF (ITUNE.EQ.322) PARP(83)=1.5D0 + IF (ITUNE.EQ.327) PARP(83)=1.5D0 + IF (ITUNE.EQ.328) PARP(83)=1.5D0 +C...NOCR variants have smoother mass profiles + IF (ITUNE.EQ.324) PARP(83)=1.8D0 + IF (ITUNE.EQ.334) PARP(83)=1.8D0 + ENDIF +C...Professor-pT0 also has very smooth distribution + IF (ITUNE.EQ.329) PARP(83)=1.8 + IF (ITUNE.EQ.335) PARP(83)=1.68 + IF (ITUNE.EQ.336) PARP(83)=1.72 + IF (ITUNE.EQ.339) PARP(83)=1.67 + +C...UE: pT0 = 1.85 for S0, S0A, 2.0 for Perugia version + PARP(82)=1.85D0 + IF (ITUNEB.EQ.301) PARP(82)=2.1D0 + IF (ITUNEB.EQ.302) PARP(82)=1.9D0 + IF (ITUNEB.EQ.304) PARP(82)=2.05D0 + IF (ITUNEB.EQ.305) PARP(82)=1.9D0 + IF ((ITUNE.GE.320.AND.ITUNE.LE.328).OR.ITUNE.EQ.334) THEN +C...Perugia tunes (def is 2.0 GeV, HARD has higher, SOFT has lower, +C...Perugia-3 has more ISR, so higher pT0, NOCR can be slightly lower, +C...CTEQ6L1 slightly lower, due to less activity, and LO* needs to be +C...slightly higher, due to increased activity. + PARP(82)=2.0D0 + IF (ITUNE.EQ.321) PARP(82)=2.3D0 + IF (ITUNE.EQ.322) PARP(82)=1.9D0 + IF (ITUNE.EQ.323) PARP(82)=2.2D0 + IF (ITUNE.EQ.324) PARP(82)=1.95D0 + IF (ITUNE.EQ.325) PARP(82)=2.2D0 + IF (ITUNE.EQ.326) PARP(82)=1.95D0 + IF (ITUNE.EQ.327) PARP(82)=2.05D0 + IF (ITUNE.EQ.328) PARP(82)=2.45D0 + IF (ITUNE.EQ.334) PARP(82)=2.15D0 + ENDIF +C...Professor-pT0 maintains low pT0 vaue + IF (ITUNE.EQ.329) PARP(82)=1.85D0 + IF (ITUNE.EQ.335) PARP(82)=2.10D0 + IF (ITUNE.EQ.336) PARP(82)=1.83D0 + IF (ITUNE.EQ.339) PARP(82)=2.28D0 + +C...UE: IR cutoff reference energy and default energy scaling pace + PARP(89)=1800D0 + PARP(90)=0.16D0 +C...S0A, S0A-Pro have tune A energy scaling + IF (ITUNEB.EQ.303) PARP(90)=0.25D0 + IF ((ITUNE.GE.320.AND.ITUNE.LE.328).OR.ITUNE.EQ.334) THEN +C...Perugia tunes explicitly include MB at 630 to fix energy scaling + PARP(90)=0.26 + IF (ITUNE.EQ.321) PARP(90)=0.30D0 + IF (ITUNE.EQ.322) PARP(90)=0.24D0 + IF (ITUNE.EQ.323) PARP(90)=0.32D0 + IF (ITUNE.EQ.324) PARP(90)=0.24D0 +C...LO* and CTEQ6L1 tunes have slower energy scaling + IF (ITUNE.EQ.325) PARP(90)=0.23D0 + IF (ITUNE.EQ.326) PARP(90)=0.22D0 + ENDIF +C...Professor-pT0 has intermediate scaling + IF (ITUNE.EQ.329) PARP(90)=0.22D0 + IF (ITUNE.EQ.335) PARP(90)=0.20D0 + IF (ITUNE.EQ.336) PARP(90)=0.20D0 + IF (ITUNE.EQ.339) PARP(90)=0.21D0 + +C...BR: MPI initiator color connections rap-ordered by default +C...NOCR variants are Lambda-ordered, Perugia SOFT & 2010 random-ordered + MSTP(89)=1 + IF (ITUNEB.EQ.304.OR.ITUNE.EQ.324) MSTP(89)=2 + IF (ITUNE.EQ.322) MSTP(89)=0 + IF (ITUNE.EQ.327) MSTP(89)=0 + IF (ITUNE.EQ.328) MSTP(89)=0 + +C...BR: BR-g-BR suppression factor (higher values -> more beam blowup) + PARP(80)=0.01D0 + IF (ITUNE.GE.320.AND.ITUNE.LE.328) THEN +C...Perugia tunes have more beam blowup by default + PARP(80)=0.05D0 + IF (ITUNE.EQ.321) PARP(80)=0.01 + IF (ITUNE.EQ.323) PARP(80)=0.03 + IF (ITUNE.EQ.324) PARP(80)=0.01 + IF (ITUNE.EQ.327) PARP(80)=0.1 + IF (ITUNE.EQ.328) PARP(80)=0.1 + ENDIF + +C...BR: diquarks (def = valence qq and moderate diquark x enhancement) + MSTP(88)=0 + PARP(79)=2D0 + IF (ITUNEB.EQ.304) PARP(79)=3D0 + IF (ITUNE.EQ.329) PARP(79)=1.18 + IF (ITUNE.EQ.335) PARP(79)=1.11 + IF (ITUNE.EQ.336) PARP(79)=1.10 + IF (ITUNE.EQ.339) PARP(79)=3.69 + +C...BR: Primordial kT, parametrization and cutoff, default is 2 GeV + MSTP(91)=1 + PARP(91)=2D0 + PARP(93)=10D0 +C...Perugia-HARD only uses 1.0 GeV + IF (ITUNE.EQ.321) PARP(91)=1.0D0 +C...Perugia-3 only uses 1.5 GeV + IF (ITUNE.EQ.323) PARP(91)=1.5D0 +C...Professor-pT0 uses 7-GeV cutoff + IF (ITUNE.EQ.329) PARP(93)=7.0 + IF (ITUNE.EQ.335) THEN + PARP(91)=2.15 + PARP(93)=6.79 + ELSEIF (ITUNE.EQ.336) THEN + PARP(91)=1.85 + PARP(93)=6.86 + ELSEIF (ITUNE.EQ.339) THEN + PARP(91)=2.11 + PARP(93)=5.08 + ENDIF + +C...FSI: Colour Reconnections - Seattle algorithm is default (S0) + MSTP(95)=6 +C...S1, S1-Pro: use S1 + IF (ITUNEB.EQ.301) MSTP(95)=2 +C...S2, S2-Pro: use S2 + IF (ITUNEB.EQ.302) MSTP(95)=4 +C...NOCR, NOCR-Pro, Perugia-NOCR: use no CR + IF (ITUNE.EQ.304.OR.ITUNE.EQ.314.OR.ITUNE.EQ.324.OR. + & ITUNE.EQ.334) MSTP(95)=0 +C..."Old" and "Old"-Pro: use old CR + IF (ITUNEB.EQ.305) MSTP(95)=1 +C...Perugia 2010 and K use Paquis model + IF (ITUNE.EQ.327.OR.ITUNE.EQ.328) MSTP(95)=8 + +C...FSI: CR strength and high-pT dampening, default is S0 + PARP(77)=0D0 + IF (ITUNE.LT.320.OR.ITUNE.EQ.329.OR.ITUNE.GE.335) THEN + PARP(78)=0.2D0 + IF (ITUNEB.EQ.301) PARP(78)=0.35D0 + IF (ITUNEB.EQ.302) PARP(78)=0.15D0 + IF (ITUNEB.EQ.304) PARP(78)=0.0D0 + IF (ITUNEB.EQ.305) PARP(78)=1.0D0 + IF (ITUNE.EQ.329) PARP(78)=0.17D0 + IF (ITUNE.EQ.335) PARP(78)=0.14D0 + IF (ITUNE.EQ.336) PARP(78)=0.17D0 + IF (ITUNE.EQ.339) PARP(78)=0.13D0 + ELSE +C...Perugia tunes also use high-pT dampening : default is Perugia 0,*,6 + PARP(78)=0.33 + PARP(77)=0.9D0 + IF (ITUNE.EQ.321) THEN +C...HARD has HIGH amount of CR + PARP(78)=0.37D0 + PARP(77)=0.4D0 + ELSEIF (ITUNE.EQ.322) THEN +C...SOFT has LOW amount of CR + PARP(78)=0.15D0 + PARP(77)=0.5D0 + ELSEIF (ITUNE.EQ.323) THEN +C...Scaling variant appears to need slightly more than default + PARP(78)=0.35D0 + PARP(77)=0.6D0 + ELSEIF (ITUNE.EQ.324.OR.ITUNE.EQ.334) THEN +C...NOCR has no CR + PARP(78)=0D0 + PARP(77)=0D0 + ELSEIF (ITUNE.EQ.327) THEN +C...2010 + PARP(78)=0.035D0 + PARP(77)=1D0 + ELSEIF (ITUNE.EQ.328) THEN +C...K + PARP(78)=0.033D0 + PARP(77)=1D0 + ENDIF + ENDIF + +C================ +C...Perugia 2011 tunes +C...(written as modifications on top of Perugia 2010) +C================ + IF (ITUNSV.GE.350.AND.ITUNSV.LE.359) THEN + ITUNE = ITUNSV +C... Scale setting for matching applications. +C... Switch to 5-flavor CMW LambdaQCD = 0.26 for all shower activity +C... (equivalent to a 5-flavor MSbar LambdaQCD = 0.26/1.6 = 0.16) + MSTP(64)=2 + MSTU(112)=5 +C... This sets the Lambda scale for ISR, IFSR, and FSR + PARP(61)=0.26D0 + PARP(72)=0.26D0 + PARJ(81)=0.26D0 +C... This sets the Lambda scale for QCD hard interactions (important for the +C... UE dijet cross sections. Here we still use an MSbar value, rather than +C... a CMW one, in order not to hugely increase the UE jettiness. The CTEQ5L +C... value corresponds to a Lambda5 of 0.146 for comparison, so quite close.) + PARP(1)=0.16D0 + PARU(112)=0.16D0 +C... For matching applications, PARP(71) and PARP(67) = 1 + PARP(67) = 1D0 + PARP(71) = 1D0 +C... Primordial kT: only use 1 GeV + MSTP(91)=1 + PARP(91)=1D0 +C... ADDITIONAL LESSONS WRT PERUGIA 2010 +C... ALICE taught us: need less baryon transport than SOFT + MSTP(89)=0 + PARP(80)=0.015 +C... Small adjustments at LEP (slightly softer frag functions, esp for baryons) + PARJ(21)=0.33 + PARJ(41)=0.35 + PARJ(42)=0.8 + PARJ(45)=0.55 +C... Increase Lambda/K ratio and other strange baryon yields + PARJ(1)=0.087D0 + PARJ(3)=0.95D0 + PARJ(4)=0.043D0 + PARJ(6)=1.0D0 + PARJ(7)=1.0D0 +C... Also reduce total strangeness yield a bit, with higher K*/K + PARJ(2)=0.19D0 + PARJ(12)=0.40D0 +C... Perugia 2011 default is sharp ISR, dipoles to BR radiating, pTmax individual + MSTP(70)=0 + MSTP(72)=2 + PARP(62)=1.5D0 +C... Holger taught us a smoother proton is preferred at high energies +C... Just use a simple Gaussian + MSTP(82)=3 +C... Scaling of pt0 cutoff + PARP(90)=0.265 +C... Now retune pT0 to give right UE activity. +C... Low CR strength indicated by LHC tunes +C... (also keep low to get (Nch) a bit down for pT>100MeV samples) + PARP(78)=0.036D0 +C... Choose 7 TeV as new reference scale + PARP(89)=7000.0D0 + PARP(82)=2.93D0 +C================ +C... P2011 Variations +C================ + IF (ITUNE.EQ.351) THEN +C... radHi: high Lambda scale for ISR, IFSR, and FSR +C... ( ca 10% more particles at LEP after retune ) + PARP(61)=0.52D0 + PARP(72)=0.52D0 + PARJ(81)=0.52D0 +C... Retune cutoff scales to compensate partially +C... (though higher cutoff causes faster multiplicity drop at low energies) + PARP(62)=1.75D0 + PARJ(82)=1.75D0 + PARP(82)=3.00D0 +C... Needs faster cutoff scaling than nominal variant for same scaling +C... (since more radiation otherwise generates faster mult growth) + PARP(90)=0.28 + ELSEIF (ITUNE.EQ.352) THEN +C... radLo: low Lambda scale for ISR, IFSR, and FSR +C... ( ca 10% less particles at LEP after retune ) + PARP(61)=0.13D0 + PARP(72)=0.13D0 + PARJ(81)=0.13D0 +C... Retune cutoff scales to compensate partially + PARP(62)=1.00D0 + PARJ(82)=0.75D0 + PARP(82)=2.95D0 +C... Needs slower cutoff scaling than nominal variant for same scaling +C... (since less radiation otherwise generates slower mult growth) + PARP(90)=0.24 + ELSEIF (ITUNE.EQ.353) THEN +C... mpiHi: high Lambda scale for MPI + PARP(1)=0.26D0 + PARU(112)=0.26D0 + PARP(82)=3.35D0 + PARP(90)=0.26D0 + ELSEIF (ITUNE.EQ.354) THEN + MSTP(95)=0 + PARP(82)=3.05D0 + ELSEIF (ITUNE.EQ.355) THEN +C... LO** + MSTP(52)=2 + MSTP(51)=20651 + PARP(62)=1.5D0 +C... Compensate for higher with less CR + PARP(78)=0.034 + PARP(82)=3.40D0 +C... Need slower energy scaling than CTEQ5L + PARP(90)=0.23D0 + ELSEIF (ITUNE.EQ.356) THEN +C... CTEQ6L1 + MSTP(52)=2 + MSTP(51)=10042 + PARP(82)=2.65D0 +C... Need slower cutoff scaling than CTEQ5L + PARP(90)=0.22D0 + ELSEIF (ITUNE.EQ.357) THEN +C... T16 + PARP(90)=0.16 + ELSEIF (ITUNE.EQ.358) THEN +C... T32 + PARP(90)=0.32 + ELSEIF (ITUNE.EQ.359) THEN +C... Tevatron + PARP(89)=1800D0 + PARP(90)=0.28 + PARP(82)=2.10 + PARP(78)=0.05 + ENDIF + +C================ +C...Schulz-Skands 2011 tunes +C...(written as modifications on top of Perugia 0) +C================ + ELSEIF (ITUNSV.GE.360.AND.ITUNSV.LE.365) THEN + ITUNE = ITUNSV + + IF (ITUNE.EQ.360) THEN + PARP(78)=0.40D0 + PARP(82)=2.19D0 + PARP(83)=1.45D0 + PARP(89)=1800.0D0 + PARP(90)=0.27D0 + ELSEIF (ITUNE.EQ.361) THEN + PARP(78)=0.20D0 + PARP(82)=2.75D0 + PARP(83)=1.73D0 + PARP(89)=7000.0D0 + ELSEIF (ITUNE.EQ.362) THEN + PARP(78)=0.31D0 + PARP(82)=1.97D0 + PARP(83)=1.98D0 + PARP(89)=1960.0D0 + ELSEIF (ITUNE.EQ.363) THEN + PARP(78)=0.35D0 + PARP(82)=1.91D0 + PARP(83)=2.02D0 + PARP(89)=1800.0D0 + ELSEIF (ITUNE.EQ.364) THEN + PARP(78)=0.33D0 + PARP(82)=1.69D0 + PARP(83)=1.92D0 + PARP(89)=900.0D0 + ELSEIF (ITUNE.EQ.365) THEN + PARP(78)=0.47D0 + PARP(82)=1.61D0 + PARP(83)=1.50D0 + PARP(89)=630.0D0 + ENDIF + + ENDIF + +C...Switch off trial joinings + MSTP(96)=0 + +C...S0 (300), S0A (303) + IF (ITUNEB.EQ.300.OR.ITUNEB.EQ.303) THEN + IF (M13.GE.1) THEN + CH60='see P. Skands & D. Wicke, hep-ph/0703081' + WRITE(M11,5030) CH60 + CH60='M. Sandhoff & P. Skands, in hep-ph/0604120' + WRITE(M11,5030) CH60 + CH60='and T. Sjostrand & P. Skands, hep-ph/0408302' + WRITE(M11,5030) CH60 + IF (ITUNE.GE.310) THEN + CH60='LEP parameters tuned by Professor,'// + & ' hep-ph/0907.2973' + WRITE(M11,5030) CH60 + ENDIF + ENDIF + +C...S1 (301) + ELSEIF(ITUNEB.EQ.301) THEN + IF (M13.GE.1) THEN + CH60='see M. Sandhoff & P. Skands, in hep-ph/0604120' + WRITE(M11,5030) CH60 + CH60='and T. Sjostrand & P. Skands, hep-ph/0408302' + WRITE(M11,5030) CH60 + IF (ITUNE.GE.310) THEN + CH60='LEP parameters tuned by Professor,'// + & ' hep-ph/0907.2973' + WRITE(M11,5030) CH60 + ENDIF + ENDIF + +C...S2 (302) + ELSEIF(ITUNEB.EQ.302) THEN + IF (M13.GE.1) THEN + CH60='see M. Sandhoff & P. Skands, in hep-ph/0604120' + WRITE(M11,5030) CH60 + CH60='and T. Sjostrand & P. Skands, hep-ph/0408302' + WRITE(M11,5030) CH60 + IF (ITUNE.GE.310) THEN + CH60='LEP parameters tuned by Professor,'// + & ' hep-ph/0907.2973' + WRITE(M11,5030) CH60 + ENDIF + ENDIF + +C...NOCR (304) + ELSEIF(ITUNEB.EQ.304) THEN + IF (M13.GE.1) THEN + CH60='"best try" without colour reconnections' + WRITE(M11,5030) CH60 + CH60='see P. Skands & D. Wicke, hep-ph/0703081' + WRITE(M11,5030) CH60 + CH60='and T. Sjostrand & P. Skands, hep-ph/0408302' + WRITE(M11,5030) CH60 + IF (ITUNE.GE.310) THEN + CH60='LEP parameters tuned by Professor,'// + & ' hep-ph/0907.2973' + WRITE(M11,5030) CH60 + ENDIF + ENDIF + +C..."Lo FSR" retune (305) + ELSEIF(ITUNEB.EQ.305) THEN + IF (M13.GE.1) THEN + CH60='"Lo FSR retune" with primitive colour reconnections' + WRITE(M11,5030) CH60 + CH60='see T. Sjostrand & P. Skands, hep-ph/0408302' + WRITE(M11,5030) CH60 + IF (ITUNE.GE.310) THEN + CH60='LEP parameters tuned by Professor,'// + & ' hep-ph/0907.2973' + WRITE(M11,5030) CH60 + ENDIF + ENDIF + +C...Perugia Tunes (320-328 and 334) + ELSEIF((ITUNE.GE.320.AND.ITUNE.LE.328).OR.ITUNE.EQ.334) THEN + IF (M13.GE.1) THEN + CH60='Tuned by P. Skands, hep-ph/1005.3457' + WRITE(M11,5030) CH60 + CH60='Physics Model: '// + & 'T. Sjostrand & P. Skands, hep-ph/0408302' + WRITE(M11,5030) CH60 + IF (ITUNE.LE.326) THEN + CH60='CR by M. Sandhoff & P. Skands, in hep-ph/0604120' + WRITE(M11,5030) CH60 + CH60='LEP parameters tuned by Professor, hep-ph/0907.2973' + WRITE(M11,5030) CH60 + ENDIF + IF (ITUNE.EQ.325) THEN + CH70='NB! This tune requires MRST LO* pdfs to be '// + & 'externally linked' + WRITE(M11,5035) CH70 + ELSEIF (ITUNE.EQ.326) THEN + CH70='NB! This tune requires CTEQ6L1 pdfs to be '// + & 'externally linked' + WRITE(M11,5035) CH70 + ELSEIF (ITUNE.EQ.321) THEN + CH60='NB! This tune has MORE ISR & FSR / LESS UE & BR' + WRITE(M11,5030) CH60 + ELSEIF (ITUNE.EQ.322) THEN + CH60='NB! This tune has LESS ISR & FSR / MORE UE & BR' + WRITE(M11,5030) CH60 + ENDIF + ENDIF + +C...Professor-pTO (329) + ELSEIF(ITUNE.EQ.329.OR.ITUNE.EQ.335.OR.ITUNE.EQ.336.OR. + & ITUNE.EQ.339) THEN + IF (M13.GE.1) THEN + CH60='Tuned by Professor, hep-ph/0907.2973' + WRITE(M11,5030) CH60 + CH60='Physics Model: '// + & 'T. Sjostrand & P. Skands, hep-ph/0408302' + WRITE(M11,5030) CH60 + CH60='CR by M. Sandhoff & P. Skands, in hep-ph/0604120' + WRITE(M11,5030) CH60 + ENDIF + +C...Perugia 2011 Tunes (350-359) + ELSEIF(ITUNE.GE.350.AND.ITUNE.LE.359) THEN + IF (M13.GE.1) THEN + CH60='Tuned by P. Skands, hep-ph/1005.3457' + WRITE(M11,5030) CH60 + CH60='Physics Model: '// + & 'T. Sjostrand & P. Skands, hep-ph/0408302' + WRITE(M11,5030) CH60 + CH60='CR by M. Sandhoff & P. Skands, in hep-ph/0604120' + WRITE(M11,5030) CH60 + IF (ITUNE.EQ.355) THEN + CH70='NB! This tune requires MRST LO** pdfs to be '// + & 'externally linked' + WRITE(M11,5035) CH70 + ELSEIF (ITUNE.EQ.356) THEN + CH70='NB! This tune requires CTEQ6L1 pdfs to be '// + & 'externally linked' + WRITE(M11,5035) CH70 + ENDIF + ENDIF + +C...Schulz-Skands Tunes (360-365) + ELSEIF(ITUNE.GE.360.AND.ITUNE.LE.365) THEN + IF (M13.GE.1) THEN + CH60='Tuned by H. Schulz & P. Skands, MCNET-11-07' + WRITE(M11,5030) CH60 + CH60='Based on Perugia 0, hep-ph/1005.3457' + WRITE(M11,5030) CH60 + CH60='Physics Model: '// + & 'T. Sjostrand & P. Skands, hep-ph/0408302' + WRITE(M11,5030) CH60 + CH60='CR by M. Sandhoff & P. Skands, in hep-ph/0604120' + WRITE(M11,5030) CH60 + ENDIF + + ENDIF + +C...Output + IF (M13.GE.1) THEN + WRITE(M11,5030) ' ' + WRITE(M11,5040) 51, MSTP(51), CHMSTP(51) + WRITE(M11,5040) 52, MSTP(52), CHMSTP(52) + IF (MSTP(33).GE.10) THEN + WRITE(M11,5050) 32, PARP(32), CHPARP(32) + ENDIF + WRITE(M11,5040) 3, MSTP( 3), CHMSTP( 3) + IF (MSTP(3).EQ.1) THEN + WRITE(M11,6100) 112, MSTU(112), CHMSTU(112) + WRITE(M11,6110) 112, PARU(112), CHPARU(112) + WRITE(M11,5050) 1, PARP(1) , CHPARP( 1) + ENDIF + WRITE(M11,5060) 81, PARJ(81), CHPARJ(81) + IF (MSTP(3).EQ.1) + & WRITE(M11,5050) 72, PARP(72) , CHPARP( 72) + IF (MSTP(3).EQ.1) THEN + WRITE(M11,5050) 61, PARP(61) , CHPARP( 61) + ENDIF + WRITE(M11,5040) 64, MSTP(64), CHMSTP(64) + WRITE(M11,5050) 64, PARP(64), CHPARP(64) + WRITE(M11,5040) 67, MSTP(67), CHMSTP(67) + WRITE(M11,5040) 68, MSTP(68), CHMSTP(68) + CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)' + WRITE(M11,5030) CH60 + WRITE(M11,5050) 67, PARP(67), CHPARP(67) + WRITE(M11,5040) 72, MSTP(72), CHMSTP(72) + WRITE(M11,5050) 71, PARP(71), CHPARP(71) + WRITE(M11,5040) 70, MSTP(70), CHMSTP(70) + IF (MSTP(70).EQ.0) THEN + WRITE(M11,5050) 62, PARP(62), CHPARP(62) + ELSEIF (MSTP(70).EQ.1) THEN + WRITE(M11,5050) 81, PARP(81), CHPARP(62) + CH60='(Note: PARP(81) replaces PARP(62).)' + WRITE(M11,5030) CH60 + ENDIF + WRITE(M11,5060) 82, PARJ(82), CHPARJ(82) + WRITE(M11,5040) 33, MSTP(33), CHMSTP(33) + WRITE(M11,5040) 81, MSTP(81), CHMSTP(81) + WRITE(M11,5050) 82, PARP(82), CHPARP(82) + IF (MSTP(70).EQ.2) THEN + CH60='(Note: PARP(82) replaces PARP(62).)' + WRITE(M11,5030) CH60 + ENDIF + WRITE(M11,5050) 89, PARP(89), CHPARP(89) + WRITE(M11,5050) 90, PARP(90), CHPARP(90) + WRITE(M11,5040) 82, MSTP(82), CHMSTP(82) + IF (MSTP(82).EQ.5) THEN + WRITE(M11,5050) 83, PARP(83), CHPARP(83) + ELSEIF (MSTP(82).EQ.4) THEN + WRITE(M11,5050) 83, PARP(83), CHPARP(83) + WRITE(M11,5050) 84, PARP(84), CHPARP(84) + ENDIF + WRITE(M11,5040) 88, MSTP(88), CHMSTP(88) + WRITE(M11,5040) 89, MSTP(89), CHMSTP(89) + WRITE(M11,5050) 79, PARP(79), CHPARP(79) + WRITE(M11,5050) 80, PARP(80), CHPARP(80) + WRITE(M11,5040) 91, MSTP(91), CHMSTP(91) + WRITE(M11,5050) 91, PARP(91), CHPARP(91) + WRITE(M11,5050) 93, PARP(93), CHPARP(93) + WRITE(M11,5040) 95, MSTP(95), CHMSTP(95) + IF (MSTP(95).GE.1) THEN + WRITE(M11,5050) 78, PARP(78), CHPARP(78) + IF (MSTP(95).GE.2) WRITE(M11,5050) 77, PARP(77), CHPARP(77) + ENDIF + + ENDIF + +C======================================================================= +C...ATLAS-CSC 11-parameter tune (By A. Moraes) + ELSEIF (ITUNE.EQ.306) THEN + IF (M13.GE.1) WRITE(M11,5010) ITUNE, CHNAME + IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN + CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'// + & ' with tune.') + ENDIF + +C...PDFs + MSTP(52)=2 + MSTP(54)=2 + MSTP(51)=10042 + MSTP(53)=10042 +C...ISR +C PARP(64)=1D0 +C...UE on, new model. + MSTP(81)=21 +C...Energy scaling + PARP(89)=1800D0 + PARP(90)=0.22D0 +C...Switch off trial joinings + MSTP(96)=0 +C...Primordial kT cutoff + + IF (M13.GE.1) THEN + CH60='see presentations by A. Moraes (ATLAS),' + WRITE(M11,5030) CH60 + CH60='and T. Sjostrand & P. Skands, hep-ph/0408302' + WRITE(M11,5030) CH60 + WRITE(M11,5030) ' ' + CH70='NB! This tune requires CTEQ6.1 pdfs to be '// + & 'externally linked' + WRITE(M11,5035) CH70 + ENDIF +C...Smooth ISR, low FSR + MSTP(70)=2 + MSTP(72)=0 +C...pT0 + PARP(82)=1.9D0 +C...Transverse density profile. + MSTP(82)=4 + PARP(83)=0.3D0 + PARP(84)=0.5D0 +C...ISR & FSR in interactions after the first (default) + MSTP(84)=1 + MSTP(85)=1 +C...No double-counting (default) + MSTP(86)=2 +C...Companion quark parent gluon (1-x) power + MSTP(87)=4 +C...Primordial kT compensation along chaings (default = 0 : uniform) + MSTP(90)=1 +C...Colour Reconnections + MSTP(95)=1 + PARP(78)=0.2D0 +C...Lambda_FSR scale. + PARJ(81)=0.23D0 +C...Rap order, Valence qq, qq x enhc, BR-g-BR supp + MSTP(89)=1 + MSTP(88)=0 +C PARP(79)=2D0 + PARP(80)=0.01D0 +C...Peterson charm frag, and c and b hadr parameters + MSTJ(11)=3 + PARJ(54)=-0.07 + PARJ(55)=-0.006 +C... Output + IF (M13.GE.1) THEN + WRITE(M11,5030) ' ' + WRITE(M11,5040) 51, MSTP(51), CHMSTP(51) + WRITE(M11,5040) 52, MSTP(52), CHMSTP(52) + WRITE(M11,5040) 3, MSTP( 3), CHMSTP( 3) + WRITE(M11,5050) 64, PARP(64), CHPARP(64) + WRITE(M11,5040) 68, MSTP(68), CHMSTP(68) + CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)' + WRITE(M11,5030) CH60 + WRITE(M11,5040) 70, MSTP(70), CHMSTP(70) + WRITE(M11,5040) 72, MSTP(72), CHMSTP(72) + WRITE(M11,5050) 71, PARP(71), CHPARP(71) + WRITE(M11,5060) 81, PARJ(81), CHPARJ(81) + CH60='(Note: PARJ(81) changed from 0.14! See update notes)' + WRITE(M11,5030) CH60 + WRITE(M11,5040) 33, MSTP(33), CHMSTP(33) + WRITE(M11,5040) 81, MSTP(81), CHMSTP(81) + WRITE(M11,5050) 82, PARP(82), CHPARP(82) + WRITE(M11,5050) 89, PARP(89), CHPARP(89) + WRITE(M11,5050) 90, PARP(90), CHPARP(90) + WRITE(M11,5040) 82, MSTP(82), CHMSTP(82) + WRITE(M11,5050) 83, PARP(83), CHPARP(83) + WRITE(M11,5050) 84, PARP(84), CHPARP(84) + WRITE(M11,5040) 88, MSTP(88), CHMSTP(88) + WRITE(M11,5040) 89, MSTP(89), CHMSTP(89) + WRITE(M11,5040) 90, MSTP(90), CHMSTP(90) + WRITE(M11,5050) 79, PARP(79), CHPARP(79) + WRITE(M11,5050) 80, PARP(80), CHPARP(80) + WRITE(M11,5050) 93, PARP(93), CHPARP(93) + WRITE(M11,5040) 95, MSTP(95), CHMSTP(95) + WRITE(M11,5050) 78, PARP(78), CHPARP(78) + + ENDIF + +C======================================================================= +C...Tunes A, AW, BW, DW, DWT, QW, D6, D6T (by R.D. Field, CDF) +C...(100-105,108-109), ATLAS-DC2 Tune (by A. Moraes, ATLAS) (106) +C...A-Pro, DW-Pro, etc (100-119), and Pro-Q2O (129) + ELSEIF ((ITUNE.GE.100.AND.ITUNE.LE.106).OR.ITUNE.EQ.108.OR. + & ITUNE.EQ.109.OR.(ITUNE.GE.110.AND.ITUNE.LE.116).OR. + & ITUNE.EQ.118.OR.ITUNE.EQ.119.OR.ITUNE.EQ.129) THEN + IF (M13.GE.1.AND.ITUNE.NE.106.AND.ITUNE.NE.129) THEN + WRITE(M11,5010) ITUNE, CHNAME + CH60='see R.D. Field, in hep-ph/0610012' + WRITE(M11,5030) CH60 + CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019' + WRITE(M11,5030) CH60 + IF (ITUNE.GE.110.AND.ITUNE.LE.119) THEN + CH60='LEP parameters tuned by Professor, hep-ph/0907.2973' + WRITE(M11,5030) CH60 + ENDIF + ELSEIF (M13.GE.1.AND.ITUNE.EQ.129) THEN + WRITE(M11,5010) ITUNE, CHNAME + CH60='Tuned by Professor, hep-ph/0907.2973' + WRITE(M11,5030) CH60 + CH60='Physics Model: '// + & 'T. Sjostrand & M. v. Zijl, PRD36(1987)2019' + WRITE(M11,5030) CH60 + ENDIF + +C...Make sure we start from old default fragmentation parameters + PARJ(81) = 0.29 + PARJ(82) = 1.0 + +C...Use Professor's LEP pars if ITUNE >= 110 +C...(i.e., for A-Pro, DW-Pro etc) + IF (ITUNE.LT.110) THEN +C...# Old defaults + MSTJ(11) = 4 + PARJ(1) = 0.1 + PARJ(2) = 0.3 + PARJ(3) = 0.40 + PARJ(4) = 0.05 + PARJ(11) = 0.5 + PARJ(12) = 0.6 + PARJ(21) = 0.36 + PARJ(41) = 0.30 + PARJ(42) = 0.58 + PARJ(46) = 1.0 + PARJ(81) = 0.29 + PARJ(82) = 1.0 + ELSE +C...# Tuned flavour parameters: + PARJ(1) = 0.073 + PARJ(2) = 0.2 + PARJ(3) = 0.94 + PARJ(4) = 0.032 + PARJ(11) = 0.31 + PARJ(12) = 0.4 + PARJ(13) = 0.54 + PARJ(25) = 0.63 + PARJ(26) = 0.12 +C...# Switch on Bowler: + MSTJ(11) = 5 +C...# Fragmentation + PARJ(21) = 0.325 + PARJ(41) = 0.5 + PARJ(42) = 0.6 + PARJ(47) = 0.67 + PARJ(81) = 0.29 + PARJ(82) = 1.65 + ENDIF + +C...Remove middle digit now for Professor variants, since identical pars + ITUNEB=ITUNE + IF (ITUNE.GE.110.AND.ITUNE.LE.119) THEN + ITUNEB=(ITUNE/100)*100+MOD(ITUNE,10) + ENDIF + +C...Multiple interactions on, old framework + MSTP(81)=1 +C...Fast IR cutoff energy scaling by default + PARP(89)=1800D0 + PARP(90)=0.25D0 +C...Default CTEQ5L (internal), except for QW: CTEQ61 (external) + MSTP(51)=7 + MSTP(52)=1 + IF (ITUNEB.EQ.105) THEN + MSTP(51)=10150 + MSTP(52)=2 + ELSEIF(ITUNEB.EQ.108.OR.ITUNEB.EQ.109) THEN + MSTP(52)=2 + MSTP(54)=2 + MSTP(51)=10042 + MSTP(53)=10042 + ENDIF +C...Double Gaussian matter distribution. + MSTP(82)=4 + PARP(83)=0.5D0 + PARP(84)=0.4D0 +C...FSR activity. + PARP(71)=4D0 +C...Fragmentation functions and c and b parameters +C...(only if not using Professor) + IF (ITUNE.LE.109) THEN + MSTJ(11)=4 + PARJ(54)=-0.05 + PARJ(55)=-0.005 + ENDIF + +C...Tune A and AW + IF(ITUNEB.EQ.100.OR.ITUNEB.EQ.101) THEN +C...pT0. + PARP(82)=2.0D0 +c...String drawing almost completely minimizes string length. + PARP(85)=0.9D0 + PARP(86)=0.95D0 +C...ISR cutoff, muR scale factor, and phase space size + PARP(62)=1D0 + PARP(64)=1D0 + PARP(67)=4D0 +C...Intrinsic kT, size, and max + MSTP(91)=1 + PARP(91)=1D0 + PARP(93)=5D0 +C...AW : higher ISR IR cutoff, but also larger alphaS, more intrinsic kT + IF (ITUNEB.EQ.101) THEN + PARP(62)=1.25D0 + PARP(64)=0.2D0 + PARP(91)=2.1D0 + PARP(92)=15.0D0 + ENDIF + +C...Tune BW (larger alphaS, more intrinsic kT. Smaller ISR phase space) + ELSEIF (ITUNEB.EQ.102) THEN +C...pT0. + PARP(82)=1.9D0 +c...String drawing completely minimizes string length. + PARP(85)=1.0D0 + PARP(86)=1.0D0 +C...ISR cutoff, muR scale factor, and phase space size + PARP(62)=1.25D0 + PARP(64)=0.2D0 + PARP(67)=1D0 +C...Intrinsic kT, size, and max + MSTP(91)=1 + PARP(91)=2.1D0 + PARP(93)=15D0 + +C...Tune DW + ELSEIF (ITUNEB.EQ.103) THEN +C...pT0. + PARP(82)=1.9D0 +c...String drawing completely minimizes string length. + PARP(85)=1.0D0 + PARP(86)=1.0D0 +C...ISR cutoff, muR scale factor, and phase space size + PARP(62)=1.25D0 + PARP(64)=0.2D0 + PARP(67)=2.5D0 +C...Intrinsic kT, size, and max + MSTP(91)=1 + PARP(91)=2.1D0 + PARP(93)=15D0 + +C...Tune DWT + ELSEIF (ITUNEB.EQ.104) THEN +C...pT0. + PARP(82)=1.9409D0 +C...Run II ref scale and slow scaling + PARP(89)=1960D0 + PARP(90)=0.16D0 +c...String drawing completely minimizes string length. + PARP(85)=1.0D0 + PARP(86)=1.0D0 +C...ISR cutoff, muR scale factor, and phase space size + PARP(62)=1.25D0 + PARP(64)=0.2D0 + PARP(67)=2.5D0 +C...Intrinsic kT, size, and max + MSTP(91)=1 + PARP(91)=2.1D0 + PARP(93)=15D0 + +C...Tune QW + ELSEIF(ITUNEB.EQ.105) THEN + IF (M13.GE.1) THEN + WRITE(M11,5030) ' ' + CH70='NB! This tune requires CTEQ6.1 pdfs to be '// + & 'externally linked' + WRITE(M11,5035) CH70 + ENDIF +C...pT0. + PARP(82)=1.1D0 +c...String drawing completely minimizes string length. + PARP(85)=1.0D0 + PARP(86)=1.0D0 +C...ISR cutoff, muR scale factor, and phase space size + PARP(62)=1.25D0 + PARP(64)=0.2D0 + PARP(67)=2.5D0 +C...Intrinsic kT, size, and max + MSTP(91)=1 + PARP(91)=2.1D0 + PARP(93)=15D0 + +C...Tune D6 and D6T + ELSEIF(ITUNEB.EQ.108.OR.ITUNEB.EQ.109) THEN + IF (M13.GE.1) THEN + WRITE(M11,5030) ' ' + CH70='NB! This tune requires CTEQ6L pdfs to be '// + & 'externally linked' + WRITE(M11,5035) CH70 + ENDIF +C...The "Rick" proton, double gauss with 0.5/0.4 + MSTP(82)=4 + PARP(83)=0.5D0 + PARP(84)=0.4D0 +c...String drawing completely minimizes string length. + PARP(85)=1.0D0 + PARP(86)=1.0D0 + IF (ITUNEB.EQ.108) THEN +C...D6: pT0, Run I ref scale, and fast energy scaling + PARP(82)=1.8D0 + PARP(89)=1800D0 + PARP(90)=0.25D0 + ELSE +C...D6T: pT0, Run II ref scale, and slow energy scaling + PARP(82)=1.8387D0 + PARP(89)=1960D0 + PARP(90)=0.16D0 + ENDIF +C...ISR cutoff, muR scale factor, and phase space size + PARP(62)=1.25D0 + PARP(64)=0.2D0 + PARP(67)=2.5D0 +C...Intrinsic kT, size, and max + MSTP(91)=1 + PARP(91)=2.1D0 + PARP(93)=15D0 + +C...Old ATLAS-DC2 5-parameter tune + ELSEIF(ITUNEB.EQ.106) THEN + IF (M13.GE.1) THEN + WRITE(M11,5010) ITUNE, CHNAME + CH60='see A. Moraes et al., SN-ATLAS-2006-057,' + WRITE(M11,5030) CH60 + CH60=' R. Field in hep-ph/0610012,' + WRITE(M11,5030) CH60 + CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019' + WRITE(M11,5030) CH60 + ENDIF +C... pT0. + PARP(82)=1.8D0 +C... Different ref and rescaling pacee + PARP(89)=1000D0 + PARP(90)=0.16D0 +C... Parameters of mass distribution + PARP(83)=0.5D0 + PARP(84)=0.5D0 +C... Old default string drawing + PARP(85)=0.33D0 + PARP(86)=0.66D0 +C... ISR, phase space equivalent to Tune B + PARP(62)=1D0 + PARP(64)=1D0 + PARP(67)=1D0 +C... FSR + PARP(71)=4D0 +C... Intrinsic kT + MSTP(91)=1 + PARP(91)=1D0 + PARP(93)=5D0 + +C...Professor's Pro-Q2O Tune + ELSEIF(ITUNE.EQ.129) THEN + PARP(62)=2.9 + PARP(64)=0.14 + PARP(67)=2.65 + PARP(82)=1.9 + PARP(83)=0.83 + PARP(84)=0.6 + PARP(85)=0.86 + PARP(86)=0.93 + PARP(89)=1800D0 + PARP(90)=0.22 + MSTP(91)=1 + PARP(91)=2.1 + PARP(93)=5.0 + + ENDIF + +C... Output + IF (M13.GE.1) THEN + WRITE(M11,5030) ' ' + WRITE(M11,5040) 51, MSTP(51), CHMSTP(51) + WRITE(M11,5040) 52, MSTP(52), CHMSTP(52) + WRITE(M11,5040) 3, MSTP( 3), CHMSTP( 3) + WRITE(M11,5050) 62, PARP(62), CHPARP(62) + WRITE(M11,5050) 64, PARP(64), CHPARP(64) + WRITE(M11,5050) 67, PARP(67), CHPARP(67) + WRITE(M11,5040) 68, MSTP(68), CHMSTP(68) + CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)' + WRITE(M11,5030) CH60 + WRITE(M11,5050) 71, PARP(71), CHPARP(71) + WRITE(M11,5060) 81, PARJ(81), CHPARJ(81) + WRITE(M11,5060) 82, PARJ(82), CHPARJ(82) + WRITE(M11,5040) 33, MSTP(33), CHMSTP(33) + WRITE(M11,5040) 81, MSTP(81), CHMSTP(81) + WRITE(M11,5050) 82, PARP(82), CHPARP(82) + WRITE(M11,5050) 89, PARP(89), CHPARP(89) + WRITE(M11,5050) 90, PARP(90), CHPARP(90) + WRITE(M11,5040) 82, MSTP(82), CHMSTP(82) + WRITE(M11,5050) 83, PARP(83), CHPARP(83) + WRITE(M11,5050) 84, PARP(84), CHPARP(84) + WRITE(M11,5050) 85, PARP(85), CHPARP(85) + WRITE(M11,5050) 86, PARP(86), CHPARP(86) + WRITE(M11,5040) 91, MSTP(91), CHMSTP(91) + WRITE(M11,5050) 91, PARP(91), CHPARP(91) + WRITE(M11,5050) 93, PARP(93), CHPARP(93) + + ENDIF + +C======================================================================= +C... ACR, tune A with new CR (107) + ELSEIF(ITUNE.EQ.107.OR.ITUNE.EQ.117) THEN + IF (M13.GE.1) THEN + WRITE(M11,5010) ITUNE, CHNAME + CH60='Tune A modified with new colour reconnections' + WRITE(M11,5030) CH60 + CH60='PARP(85)=0D0 and amount of CR is regulated by PARP(78)' + WRITE(M11,5030) CH60 + CH60='see P. Skands & D. Wicke, hep-ph/0703081,' + WRITE(M11,5030) CH60 + CH60=' R. Field, in hep-ph/0610012 (Tune A),' + WRITE(M11,5030) CH60 + CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019' + WRITE(M11,5030) CH60 + IF (ITUNE.EQ.117) THEN + CH60='LEP parameters tuned by Professor, hep-ph/0907.2973' + WRITE(M11,5030) CH60 + ENDIF + ENDIF + IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.406))THEN + CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'// + & ' with tune. Using defaults.') + GOTO 100 + ENDIF + +C...Make sure we start from old default fragmentation parameters + PARJ(81) = 0.29 + PARJ(82) = 1.0 + +C...Use Professor's LEP pars if ITUNE >= 110 +C...(i.e., for A-Pro, DW-Pro etc) + IF (ITUNE.LT.110) THEN +C...# Old defaults + MSTJ(11) = 4 +C...# Old default flavour parameters + PARJ(21) = 0.36 + PARJ(41) = 0.30 + PARJ(42) = 0.58 + PARJ(46) = 1.0 + PARJ(82) = 1.0 + ELSE +C...# Tuned flavour parameters: + PARJ(1) = 0.073 + PARJ(2) = 0.2 + PARJ(3) = 0.94 + PARJ(4) = 0.032 + PARJ(11) = 0.31 + PARJ(12) = 0.4 + PARJ(13) = 0.54 + PARJ(25) = 0.63 + PARJ(26) = 0.12 +C...# Switch on Bowler: + MSTJ(11) = 5 +C...# Fragmentation + PARJ(21) = 0.325 + PARJ(41) = 0.5 + PARJ(42) = 0.6 + PARJ(47) = 0.67 + PARJ(81) = 0.29 + PARJ(82) = 1.65 + ENDIF + + MSTP(81)=1 + PARP(89)=1800D0 + PARP(90)=0.25D0 + MSTP(82)=4 + PARP(83)=0.5D0 + PARP(84)=0.4D0 + MSTP(51)=7 + MSTP(52)=1 + PARP(71)=4D0 + PARP(82)=2.0D0 + PARP(85)=0.0D0 + PARP(86)=0.66D0 + PARP(62)=1D0 + PARP(64)=1D0 + PARP(67)=4D0 + MSTP(91)=1 + PARP(91)=1D0 + PARP(93)=5D0 + MSTP(95)=6 +C...P78 changed from 0.12 to 0.09 in 6.4.19 to improve (Nch) + PARP(78)=0.09D0 +C...Frag functions (only if not using Professor) + IF (ITUNE.LE.109) THEN + MSTJ(11)=4 + PARJ(54)=-0.05 + PARJ(55)=-0.005 + ENDIF + +C...Output + IF (M13.GE.1) THEN + WRITE(M11,5030) ' ' + WRITE(M11,5040) 51, MSTP(51), CHMSTP(51) + WRITE(M11,5040) 52, MSTP(52), CHMSTP(52) + WRITE(M11,5040) 3, MSTP( 3), CHMSTP( 3) + WRITE(M11,5050) 62, PARP(62), CHPARP(62) + WRITE(M11,5050) 64, PARP(64), CHPARP(64) + WRITE(M11,5050) 67, PARP(67), CHPARP(67) + WRITE(M11,5040) 68, MSTP(68), CHMSTP(68) + CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)' + WRITE(M11,5030) CH60 + WRITE(M11,5050) 71, PARP(71), CHPARP(71) + WRITE(M11,5060) 81, PARJ(81), CHPARJ(81) + WRITE(M11,5060) 82, PARJ(82), CHPARJ(82) + WRITE(M11,5040) 33, MSTP(33), CHMSTP(33) + WRITE(M11,5040) 81, MSTP(81), CHMSTP(81) + WRITE(M11,5050) 82, PARP(82), CHPARP(82) + WRITE(M11,5050) 89, PARP(89), CHPARP(89) + WRITE(M11,5050) 90, PARP(90), CHPARP(90) + WRITE(M11,5040) 82, MSTP(82), CHMSTP(82) + WRITE(M11,5050) 83, PARP(83), CHPARP(83) + WRITE(M11,5050) 84, PARP(84), CHPARP(84) + WRITE(M11,5050) 85, PARP(85), CHPARP(85) + WRITE(M11,5050) 86, PARP(86), CHPARP(86) + WRITE(M11,5040) 91, MSTP(91), CHMSTP(91) + WRITE(M11,5050) 91, PARP(91), CHPARP(91) + WRITE(M11,5050) 93, PARP(93), CHPARP(93) + WRITE(M11,5040) 95, MSTP(95), CHMSTP(95) + WRITE(M11,5050) 78, PARP(78), CHPARP(78) + + ENDIF + +C======================================================================= +C...Intermediate model. Rap tune +C...(retuned to post-6.406 IR factorization) + ELSEIF(ITUNE.EQ.200) THEN + IF (M13.GE.1) THEN + WRITE(M11,5010) ITUNE, CHNAME + CH60='see T. Sjostrand & P. Skands, JHEP03(2004)053' + WRITE(M11,5030) CH60 + ENDIF + IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN + CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'// + & ' with tune.') + ENDIF +C...PDF + MSTP(51)=7 + MSTP(52)=1 +C...ISR + PARP(62)=1D0 + PARP(64)=1D0 + PARP(67)=4D0 +C...FSR + PARP(71)=4D0 + PARJ(81)=0.29D0 +C...UE + MSTP(81)=11 + PARP(82)=2.25D0 + PARP(89)=1800D0 + PARP(90)=0.25D0 +C... ExpOfPow(1.8) overlap profile + MSTP(82)=5 + PARP(83)=1.8D0 +C... Valence qq + MSTP(88)=0 +C... Rap Tune + MSTP(89)=1 +C... Default diquark, BR-g-BR supp + PARP(79)=2D0 + PARP(80)=0.01D0 +C... Final state reconnect. + MSTP(95)=1 + PARP(78)=0.55D0 +C...Fragmentation functions and c and b parameters + MSTJ(11)=4 + PARJ(54)=-0.05 + PARJ(55)=-0.005 +C... Output + IF (M13.GE.1) THEN + WRITE(M11,5030) ' ' + WRITE(M11,5040) 51, MSTP(51), CHMSTP(51) + WRITE(M11,5040) 52, MSTP(52), CHMSTP(52) + WRITE(M11,5040) 3, MSTP( 3), CHMSTP( 3) + WRITE(M11,5050) 62, PARP(62), CHPARP(62) + WRITE(M11,5050) 64, PARP(64), CHPARP(64) + WRITE(M11,5050) 67, PARP(67), CHPARP(67) + WRITE(M11,5040) 68, MSTP(68), CHMSTP(68) + CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)' + WRITE(M11,5030) CH60 + WRITE(M11,5050) 71, PARP(71), CHPARP(71) + WRITE(M11,5060) 81, PARJ(81), CHPARJ(81) + WRITE(M11,5040) 33, MSTP(33), CHMSTP(33) + WRITE(M11,5040) 81, MSTP(81), CHMSTP(81) + WRITE(M11,5050) 82, PARP(82), CHPARP(82) + WRITE(M11,5050) 89, PARP(89), CHPARP(89) + WRITE(M11,5050) 90, PARP(90), CHPARP(90) + WRITE(M11,5040) 82, MSTP(82), CHMSTP(82) + WRITE(M11,5050) 83, PARP(83), CHPARP(83) + WRITE(M11,5040) 88, MSTP(88), CHMSTP(88) + WRITE(M11,5040) 89, MSTP(89), CHMSTP(89) + WRITE(M11,5050) 79, PARP(79), CHPARP(79) + WRITE(M11,5050) 80, PARP(80), CHPARP(80) + WRITE(M11,5050) 93, PARP(93), CHPARP(93) + WRITE(M11,5040) 95, MSTP(95), CHMSTP(95) + WRITE(M11,5050) 78, PARP(78), CHPARP(78) + + ENDIF + +C...APT(201), APT-Pro (211), Perugia-APT (221), Perugia-APT6 (226). +C...Old model for ISR and UE, new pT-ordered model for FSR + ELSEIF(ITUNE.EQ.201.OR.ITUNE.EQ.211.OR.ITUNE.EQ.221.OR + & .ITUNE.EQ.226) THEN + IF (M13.GE.1) THEN + WRITE(M11,5010) ITUNE, CHNAME + CH60='see P. Skands & D. Wicke, hep-ph/0703081 (Tune APT),' + WRITE(M11,5030) CH60 + CH60=' R.D. Field, in hep-ph/0610012 (Tune A)' + WRITE(M11,5030) CH60 + CH60=' T. Sjostrand & M. v. Zijl, PRD36(1987)2019' + WRITE(M11,5030) CH60 + CH60='and T. Sjostrand & P. Skands, hep-ph/0408302' + WRITE(M11,5030) CH60 + IF (ITUNE.EQ.211.OR.ITUNE.GE.221) THEN + CH60='LEP parameters tuned by Professor, hep-ph/0907.2973' + WRITE(M11,5030) CH60 + ENDIF + ENDIF + IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.411))THEN + CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'// + & ' with tune.') + ENDIF +C...First set as if Pythia tune A +C...Multiple interactions on, old framework + MSTP(81)=1 +C...Fast IR cutoff energy scaling by default + PARP(89)=1800D0 + PARP(90)=0.25D0 +C...Default CTEQ5L (internal) + MSTP(51)=7 + MSTP(52)=1 +C...Double Gaussian matter distribution. + MSTP(82)=4 + PARP(83)=0.5D0 + PARP(84)=0.4D0 +C...FSR activity. + PARP(71)=4D0 +c...String drawing almost completely minimizes string length. + PARP(85)=0.9D0 + PARP(86)=0.95D0 +C...ISR cutoff, muR scale factor, and phase space size + PARP(62)=1D0 + PARP(64)=1D0 + PARP(67)=4D0 +C...Intrinsic kT, size, and max + MSTP(91)=1 + PARP(91)=1D0 + PARP(93)=5D0 +C...Use 2 GeV of primordial kT for "Perugia" version + IF (ITUNE.EQ.221) THEN + PARP(91)=2D0 + PARP(93)=10D0 + ENDIF +C...Use pT-ordered FSR + MSTJ(41)=12 +C...Lambda_FSR scale for pT-ordering + PARJ(81)=0.23D0 +C...Retune pT0 (changed from 2.1 to 2.05 in 6.4.20) + PARP(82)=2.05D0 +C...Fragmentation functions and c and b parameters +C...(overwritten for 211, i.e., if using Professor pars) + PARJ(54)=-0.05 + PARJ(55)=-0.005 + +C...Use Professor's LEP pars if ITUNE == 211, 221, 226 + IF (ITUNE.LT.210) THEN +C...# Old defaults + MSTJ(11) = 4 +C...# Old default flavour parameters + PARJ(21) = 0.36 + PARJ(41) = 0.30 + PARJ(42) = 0.58 + PARJ(46) = 1.0 + PARJ(82) = 1.0 + ELSE +C...# Tuned flavour parameters: + PARJ(1) = 0.073 + PARJ(2) = 0.2 + PARJ(3) = 0.94 + PARJ(4) = 0.032 + PARJ(11) = 0.31 + PARJ(12) = 0.4 + PARJ(13) = 0.54 + PARJ(25) = 0.63 + PARJ(26) = 0.12 +C...# Always use pT-ordered shower: + MSTJ(41) = 12 +C...# Switch on Bowler: + MSTJ(11) = 5 +C...# Fragmentation + PARJ(21) = 3.1327e-01 + PARJ(41) = 4.8989e-01 + PARJ(42) = 1.2018e+00 + PARJ(47) = 1.0000e+00 + PARJ(81) = 2.5696e-01 + PARJ(82) = 8.0000e-01 + ENDIF + +C...221, 226 : Perugia-APT and Perugia-APT6 + IF (ITUNE.EQ.221.OR.ITUNE.EQ.226) THEN + + PARP(64)=0.5D0 + PARP(82)=2.05D0 + PARP(90)=0.26D0 + PARP(91)=2.0D0 +C...The Perugia variants use Steve's showers off the old MPI + MSTP(152)=1 +C...And use a lower PARP(71) as suggested by Professor tunings +C...(although not certain that applies to Q2-pT2 hybrid) + PARP(71)=2.5D0 + +C...Perugia-APT6 uses CTEQ6L1 and a slightly lower pT0 + IF (ITUNE.EQ.226) THEN + CH70='NB! This tune requires CTEQ6L1 pdfs to be '// + & 'externally linked' + WRITE(M11,5035) CH70 + MSTP(52)=2 + MSTP(51)=10042 + PARP(82)=1.95D0 + ENDIF + + ENDIF + +C... Output + IF (M13.GE.1) THEN + WRITE(M11,5030) ' ' + WRITE(M11,5040) 51, MSTP(51), CHMSTP(51) + WRITE(M11,5040) 52, MSTP(52), CHMSTP(52) + WRITE(M11,5040) 3, MSTP( 3), CHMSTP( 3) + WRITE(M11,5050) 62, PARP(62), CHPARP(62) + WRITE(M11,5050) 64, PARP(64), CHPARP(64) + WRITE(M11,5050) 67, PARP(67), CHPARP(67) + WRITE(M11,5040) 68, MSTP(68), CHMSTP(68) + CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)' + WRITE(M11,5030) CH60 + WRITE(M11,5070) 41, MSTJ(41), CHMSTJ(41) + WRITE(M11,5050) 71, PARP(71), CHPARP(71) + WRITE(M11,5060) 81, PARJ(81), CHPARJ(81) + WRITE(M11,5040) 33, MSTP(33), CHMSTP(33) + WRITE(M11,5040) 81, MSTP(81), CHMSTP(81) + WRITE(M11,5050) 82, PARP(82), CHPARP(82) + WRITE(M11,5050) 89, PARP(89), CHPARP(89) + WRITE(M11,5050) 90, PARP(90), CHPARP(90) + WRITE(M11,5040) 82, MSTP(82), CHMSTP(82) + WRITE(M11,5050) 83, PARP(83), CHPARP(83) + WRITE(M11,5050) 84, PARP(84), CHPARP(84) + WRITE(M11,5050) 85, PARP(85), CHPARP(85) + WRITE(M11,5050) 86, PARP(86), CHPARP(86) + WRITE(M11,5040) 91, MSTP(91), CHMSTP(91) + WRITE(M11,5050) 91, PARP(91), CHPARP(91) + WRITE(M11,5050) 93, PARP(93), CHPARP(93) + + ENDIF + +C====================================================================== +C...Uppsala models: Generalized Area Law and Soft Colour Interactions + ELSEIF(CHNAME.EQ.'GAL Tune 0'.OR.CHNAME.EQ.'GAL Tune 1') THEN + IF (M13.GE.1) THEN + WRITE(M11,5010) ITUNE, CHNAME + CH60='see J. Rathsman, PLB452(1999)364' + WRITE(M11,5030) CH60 +C ? CH60='A. Edin, G. Ingelman, J. Rathsman, hep-ph/9912539,' +C ? WRITE(M11,5030) + CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019' + WRITE(M11,5030) CH60 + WRITE(M11,5030) ' ' + CH70='NB! The GAL model must be run with modified '// + & 'Pythia v6.215:' + WRITE(M11,5035) CH70 + CH70='available from http://www.isv.uu.se/thep/MC/scigal/' + WRITE(M11,5035) CH70 + WRITE(M11,5030) ' ' + ENDIF +C...GAL Recommended settings from Uppsala web page (as per 22/08 2006) + MSWI(2) = 3 + PARSCI(2) = 0.10 + MSWI(1) = 2 + PARSCI(1) = 0.44 + MSTJ(16) = 0 + PARJ(42) = 0.45 + PARJ(82) = 2.0 + PARP(62) = 2.0 + MSTP(81) = 1 + MSTP(82) = 1 + PARP(81) = 1.9 + MSTP(92) = 1 + IF(CHNAME.EQ.'GAL Tune 1') THEN +C...GAL retune (P. Skands) to get better min-bias at Tevatron + MSTP(82)=4 + PARP(83)=0.25D0 + PARP(84)=0.5D0 + PARP(82) = 1.75 + IF (M13.GE.1) THEN + WRITE(M11,5040) 81, MSTP(81), CHMSTP(81) + WRITE(M11,5050) 82, PARP(82), CHPARP(82) + WRITE(M11,5040) 82, MSTP(82), CHMSTP(82) + WRITE(M11,5050) 83, PARP(83), CHPARP(83) + WRITE(M11,5050) 84, PARP(84), CHPARP(84) + ENDIF + ELSE + IF (M13.GE.1) THEN + WRITE(M11,5040) 81, MSTP(81), CHMSTP(81) + WRITE(M11,5050) 81, PARP(81), CHPARP(81) + WRITE(M11,5040) 82, MSTP(82), CHMSTP(82) + ENDIF + ENDIF +C...Output + IF (M13.GE.1) THEN + WRITE(M11,5050) 62, PARP(62), CHPARP(62) + WRITE(M11,5060) 82, PARJ(82), CHPARJ(82) + WRITE(M11,5040) 92, MSTP(92), CHMSTP(92) + CH40='FSI SCI/GAL selection' + WRITE(M11,6040) 1, MSWI(1), CH40 + CH40='FSI SCI/GAL sea quark treatment' + WRITE(M11,6040) 2, MSWI(2), CH40 + CH40='FSI SCI/GAL sea quark treatment parm' + WRITE(M11,6050) 1, PARSCI(1), CH40 + CH40='FSI SCI/GAL string reco probability R_0' + WRITE(M11,6050) 2, PARSCI(2), CH40 + WRITE(M11,5060) 42, PARJ(42), CHPARJ(42) + WRITE(M11,5070) 16, MSTJ(16), CHMSTJ(16) + ENDIF + ELSEIF(CHNAME.EQ.'SCI Tune 0'.OR.CHNAME.EQ.'SCI Tune 1') THEN + IF (M13.GE.1) THEN + WRITE(M11,5010) ITUNE, CHNAME + CH60='see A.Edin et al, PLB366(1996)371, Z.Phys.C75(1997)57,' + WRITE(M11,5030) CH60 + CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019' + WRITE(M11,5030) CH60 + WRITE(M11,5030) ' ' + CH70='NB! The SCI model must be run with modified '// + & 'Pythia v6.215:' + WRITE(M11,5035) CH70 + CH70='available from http://www.isv.uu.se/thep/MC/scigal/' + WRITE(M11,5035) CH70 + WRITE(M11,5030) ' ' + ENDIF +C...SCI Recommended settings from Uppsala web page (as per 22/08 2006) + MSTP(81)=1 + MSTP(82)=1 + PARP(81)=2.2 + MSTP(92)=1 + MSWI(2)=2 + PARSCI(2)=0.50 + MSWI(1)=2 + PARSCI(1)=0.44 + MSTJ(16)=0 + IF (CHNAME.EQ.'SCI Tune 1') THEN +C...SCI retune (P. Skands) to get better min-bias at Tevatron + MSTP(81) = 1 + MSTP(82) = 3 + PARP(82) = 2.4 + PARP(83) = 0.5D0 + PARP(62) = 1.5 + PARP(84)=0.25D0 + IF (M13.GE.1) THEN + WRITE(M11,5040) 81, MSTP(81), CHMSTP(81) + WRITE(M11,5050) 82, PARP(82), CHPARP(82) + WRITE(M11,5040) 82, MSTP(82), CHMSTP(82) + WRITE(M11,5050) 83, PARP(83), CHPARP(83) + WRITE(M11,5050) 62, PARP(62), CHPARP(62) + ENDIF + ELSE + IF (M13.GE.1) THEN + WRITE(M11,5040) 81, MSTP(81), CHMSTP(81) + WRITE(M11,5050) 81, PARP(81), CHPARP(81) + WRITE(M11,5040) 82, MSTP(82), CHMSTP(82) + ENDIF + ENDIF +C...Output + IF (M13.GE.1) THEN + WRITE(M11,5040) 92, MSTP(92), CHMSTP(92) + CH40='FSI SCI/GAL selection' + WRITE(M11,6040) 1, MSWI(1), CH40 + CH40='FSI SCI/GAL sea quark treatment' + WRITE(M11,6040) 2, MSWI(2), CH40 + CH40='FSI SCI/GAL sea quark treatment parm' + WRITE(M11,6050) 1, PARSCI(1), CH40 + CH40='FSI SCI/GAL string reco probability R_0' + WRITE(M11,6050) 2, PARSCI(2), CH40 + WRITE(M11,5070) 16, MSTJ(16), CHMSTJ(16) + ENDIF + + ELSE + IF (MSTU(13).GE.1) WRITE(M11,5020) ITUNE + + ENDIF + +C...Output of LEP parameters, common to all models + IF (M13.GE.1) THEN + WRITE(M11,5080) + WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11) + IF (MSTJ(11).EQ.3) THEN + CH60='Warning: using Peterson fragmentation function' + WRITE(M11,5030) CH60 + ENDIF + + WRITE(M11,5060) 1, PARJ( 1), CHPARJ( 1) + WRITE(M11,5060) 2, PARJ( 2), CHPARJ( 2) + WRITE(M11,5060) 3, PARJ( 3), CHPARJ( 3) + WRITE(M11,5060) 4, PARJ( 4), CHPARJ( 4) + WRITE(M11,5060) 5, PARJ( 5), CHPARJ( 5) + WRITE(M11,5060) 6, PARJ( 6), CHPARJ( 6) + WRITE(M11,5060) 7, PARJ( 7), CHPARJ( 7) + + WRITE(M11,5060) 11, PARJ(11), CHPARJ(11) + WRITE(M11,5060) 12, PARJ(12), CHPARJ(12) + WRITE(M11,5060) 13, PARJ(13), CHPARJ(13) + + WRITE(M11,5060) 21, PARJ(21), CHPARJ(21) + + WRITE(M11,5060) 25, PARJ(25), CHPARJ(25) + WRITE(M11,5060) 26, PARJ(26), CHPARJ(26) + + WRITE(M11,5060) 41, PARJ(41), CHPARJ(41) + WRITE(M11,5060) 42, PARJ(42), CHPARJ(42) + WRITE(M11,5060) 45, PARJ(45), CHPARJ(45) + + IF (MSTJ(11).LE.3) THEN + WRITE(M11,5060) 54, PARJ(54), CHPARJ(54) + WRITE(M11,5060) 55, PARJ(55), CHPARJ(55) + ELSE + WRITE(M11,5060) 46, PARJ(46), CHPARJ(46) + ENDIF + IF (MSTJ(11).EQ.5) WRITE(M11,5060) 47, PARJ(47), CHPARJ(47) + ENDIF + + 100 IF (MSTU(13).GE.1) WRITE(M11,6000) + + 9999 RETURN + + 5000 FORMAT(1x,78('*')/' *',76x,'*'/' *',3x,'PYTUNE : ', + & 'Presets for underlying-event (and min-bias)',21x,'*'/' *', + & 12x,'Last Change : ',A8,' - P. Skands',30x,'*'/' *',76x,'*') + 5010 FORMAT(' *',3x,I4,1x,A16,52x,'*') + 5020 FORMAT(' *',3x,'Tune ',I4, ' not recognized. Using defaults.') + 5030 FORMAT(' *',3x,10x,A60,3x,'*') + 5035 FORMAT(' *',3x,A70,3x,'*') + 5040 FORMAT(' *',5x,'MSTP(',I2,') = ',I12,3x,A42,3x,'*') + 5050 FORMAT(' *',5x,'PARP(',I2,') = ',F12.4,3x,A40,5x,'*') + 5060 FORMAT(' *',5x,'PARJ(',I2,') = ',F12.4,3x,A40,5x,'*') + 5070 FORMAT(' *',5x,'MSTJ(',I2,') = ',I12,3x,A40,5x,'*') + 5080 FORMAT(' *',3x,'----------------------------',42('-'),3x,'*') + 6100 FORMAT(' *',5x,'MSTU(',I3,')= ',I12,3x,A42,3x,'*') + 6110 FORMAT(' *',5x,'PARU(',I3,')= ',F12.4,3x,A42,3x,'*') +C 5140 FORMAT(' *',5x,'MSTP(',I3,')= ',I12,3x,A40,5x,'*') +C 5150 FORMAT(' *',5x,'PARP(',I3,')= ',F12.4,3x,A40,5x,'*') + 6000 FORMAT(' *',76x,'*'/1x,32('*'),1x,'END OF PYTUNE',1x,31('*')) + 6040 FORMAT(' *',5x,'MSWI(',I1,') = ',I12,3x,A40,5x,'*') + 6050 FORMAT(' *',5x,'PARSCI(',I1,')= ',F12.4,3x,A40,5x,'*') + + END + +C********************************************************************* + +C...PYEXEC +C...Administrates the fragmentation and decay chain. + + SUBROUTINE PYEXEC + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT4/MWID(500),WIDS(500,5) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYINT1/,/PYINT4/ +C...Local array. + DIMENSION PS(2,6),IJOIN(100) + +C...Initialize and reset. + MSTU(24)=0 + IF(MSTU(12).NE.12345) CALL PYLIST(0) + MSTU(29)=0 + MSTU(31)=MSTU(31)+1 + MSTU(1)=0 + MSTU(2)=0 + MSTU(3)=0 + IF(MSTU(17).LE.0) MSTU(90)=0 + MCONS=1 + +C...Sum up momentum, energy and charge for starting entries. + NSAV=N + DO 110 I=1,2 + DO 100 J=1,6 + PS(I,J)=0D0 + 100 CONTINUE + 110 CONTINUE + DO 130 I=1,N + IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 130 + DO 120 J=1,4 + PS(1,J)=PS(1,J)+P(I,J) + 120 CONTINUE + PS(1,6)=PS(1,6)+PYCHGE(K(I,2)) + 130 CONTINUE + PARU(21)=PS(1,4) + +C...Start by all decays of coloured resonances involved in shower. + NORIG=N + DO 140 I=1,NORIG + IF(K(I,1).EQ.3) THEN + KC=PYCOMP(K(I,2)) + IF(MWID(KC).NE.0.AND.KCHG(KC,2).NE.0) CALL PYRESD(I) + ENDIF + 140 CONTINUE + +C...Prepare system for subsequent fragmentation/decay. + CALL PYPREP(0) + IF(MINT(51).NE.0) RETURN + +C...Loop through jet fragmentation and particle decays. + MBE=0 + 150 MBE=MBE+1 + IP=0 + 160 IP=IP+1 + KC=0 + IF(K(IP,1).GT.0.AND.K(IP,1).LE.10) KC=PYCOMP(K(IP,2)) + IF(KC.EQ.0) THEN + +C...Deal with any remaining undecayed resonance +C...(normally the task of PYEVNT, so seldom used). + ELSEIF(MWID(KC).NE.0) THEN + IBEG=IP + IF(KCHG(KC,2).NE.0.AND.K(I,1).NE.3) THEN + IBEG=IP+1 + 170 IBEG=IBEG-1 + IF(IBEG.GE.2.AND.K(IBEG,1).EQ.2) GOTO 170 + IF(K(IBEG,1).NE.2) IBEG=IBEG+1 + IEND=IP-1 + 180 IEND=IEND+1 + IF(IEND.LT.N.AND.K(IEND,1).EQ.2) GOTO 180 + IF(IEND.LT.N.AND.KCHG(PYCOMP(K(IEND,2)),2).EQ.0) GOTO 180 + NJOIN=0 + DO 190 I=IBEG,IEND + IF(KCHG(PYCOMP(K(IEND,2)),2).NE.0) THEN + NJOIN=NJOIN+1 + IJOIN(NJOIN)=I + ENDIF + 190 CONTINUE + ENDIF + CALL PYRESD(IP) + CALL PYPREP(IBEG) + IF(MINT(51).NE.0) RETURN + +C...Particle decay if unstable and allowed. Save long-lived particle +C...decays until second pass after Bose-Einstein effects. + ELSEIF(KCHG(KC,2).EQ.0) THEN + IF(MSTJ(21).GE.1.AND.MDCY(KC,1).GE.1.AND.(MSTJ(51).LE.0.OR.MBE + & .EQ.2.OR.PMAS(KC,2).GE.PARJ(91).OR.IABS(K(IP,2)).EQ.311)) + & CALL PYDECY(IP) + +C...Decay products may develop a shower. + IF(MSTJ(92).GT.0) THEN + IP1=MSTJ(92) + QMAX=SQRT(MAX(0D0,(P(IP1,4)+P(IP1+1,4))**2-(P(IP1,1)+P(IP1+1, + & 1))**2-(P(IP1,2)+P(IP1+1,2))**2-(P(IP1,3)+P(IP1+1,3))**2)) + MINT(33)=0 + CALL PYSHOW(IP1,IP1+1,QMAX) + CALL PYPREP(IP1) + IF(MINT(51).NE.0) RETURN + MSTJ(92)=0 + ELSEIF(MSTJ(92).LT.0) THEN + IP1=-MSTJ(92) + MINT(33)=0 + CALL PYSHOW(IP1,-3,P(IP,5)) + CALL PYPREP(IP1) + IF(MINT(51).NE.0) RETURN + MSTJ(92)=0 + ENDIF + +C...Jet fragmentation: string or independent fragmentation. + ELSEIF(K(IP,1).EQ.1.OR.K(IP,1).EQ.2) THEN + MFRAG=MSTJ(1) + IF(MFRAG.GE.1.AND.K(IP,1).EQ.1) MFRAG=2 + IF(MSTJ(21).GE.2.AND.K(IP,1).EQ.2.AND.N.GT.IP) THEN + IF(K(IP+1,1).EQ.1.AND.K(IP+1,3).EQ.K(IP,3).AND. + & K(IP,3).GT.0.AND.K(IP,3).LT.IP) THEN + IF(KCHG(PYCOMP(K(K(IP,3),2)),2).EQ.0) MFRAG=MIN(1,MFRAG) + ENDIF + ENDIF + IF(MFRAG.EQ.1) CALL PYSTRF(IP) + IF(MFRAG.EQ.2) CALL PYINDF(IP) + IF(MFRAG.EQ.2.AND.K(IP,1).EQ.1) MCONS=0 + IF(MFRAG.EQ.2.AND.(MSTJ(3).LE.0.OR.MOD(MSTJ(3),5).EQ.0)) MCONS=0 + ENDIF + +C...Loop back if enough space left in PYJETS and no error abort. + IF(MSTU(24).NE.0.AND.MSTU(21).GE.2) THEN + ELSEIF(IP.LT.N.AND.N.LT.MSTU(4)-20-MSTU(32)) THEN + GOTO 160 + ELSEIF(IP.LT.N) THEN + CALL PYERRM(11,'(PYEXEC:) no more memory left in PYJETS') + ENDIF + +C...Include simple Bose-Einstein effect parametrization if desired. + IF(MBE.EQ.1.AND.MSTJ(51).GE.1) THEN + CALL PYBOEI(NSAV) + GOTO 150 + ENDIF + +C...Check that momentum, energy and charge were conserved. + DO 210 I=1,N + IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 210 + DO 200 J=1,4 + PS(2,J)=PS(2,J)+P(I,J) + 200 CONTINUE + PS(2,6)=PS(2,6)+PYCHGE(K(I,2)) + 210 CONTINUE + PDEV=(ABS(PS(2,1)-PS(1,1))+ABS(PS(2,2)-PS(1,2))+ABS(PS(2,3)- + &PS(1,3))+ABS(PS(2,4)-PS(1,4)))/(1D0+ABS(PS(2,4))+ABS(PS(1,4))) + IF(MCONS.EQ.1.AND.PDEV.GT.PARU(11)) CALL PYERRM(15, + &'(PYEXEC:) four-momentum was not conserved') + IF(MCONS.EQ.1.AND.ABS(PS(2,6)-PS(1,6)).GT.0.1D0) CALL PYERRM(15, + &'(PYEXEC:) charge was not conserved') + + RETURN + END + +C********************************************************************* + +C...PYPREP +C...Rearranges partons along strings. +C...Special considerations for systems with junctions, with +C...possibility of junction-antijunction annihilation. +C...Allows small systems to collapse into one or two particles. +C...Checks flavours and colour singlet invariant masses. + + SUBROUTINE PYPREP(IP) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + COMMON/PYINT1/MINT(400),VINT(400) +C...The common block of colour tags. + COMMON/PYCTAG/NCT,MCT(4000,2) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYINT1/,/PYCTAG/, + &/PYPARS/ + DATA NERRPR/0/ + SAVE NERRPR +C...Local arrays. + DIMENSION DPS(5),DPC(5),UE(3),PG(5),E1(3),E2(3),E3(3),E4(3), + &ECL(3),IJUNC(10,0:4),IPIECE(30,0:4),KFEND(4),KFQ(4), + &IJUR(4),PJU(4,6),IRNG(4,2),TJJ(2,5),T(5),PUL(3,5), + &IJCP(0:6),TJUOLD(5) + CHARACTER CHTMP*6 + +C...Function to give four-product. + FOUR(I,J)=P(I,4)*P(J,4)-P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3) + +C...Rearrange parton shower product listing along strings: begin loop. + MSTU(24)=0 + NOLD=N + I1=N + NJUNC=0 + NPIECE=0 + NJJSTR=0 + MSTU32=MSTU(32)+1 + DO 100 I=MAX(1,IP),N +C...First store junction positions. + IF(K(I,1).EQ.42) THEN + NJUNC=NJUNC+1 + IJUNC(NJUNC,0)=I + IJUNC(NJUNC,4)=0 + ENDIF + 100 CONTINUE + + DO 250 MQGST=1,3 + DO 240 I=MAX(1,IP),N +C...Special treatment for junctions + IF (K(I,1).LE.0) GOTO 240 + IF(K(I,1).EQ.42) THEN +C...MQGST=2: Look for junction-junction strings (not detected in the +C...main search below). + IF (MQGST.EQ.2.AND.NPIECE.NE.3*NJUNC) THEN + IF (NJJSTR.EQ.0) THEN + NJJSTR = (3*NJUNC-NPIECE)/2 + ENDIF +C...Check how many already identified strings end on this junction + ILC=0 + DO 110 J=1,NPIECE + IF (IPIECE(J,4).EQ.I) ILC=ILC+1 + 110 CONTINUE +C...If less than 3, remaining must be to another junction + IF (ILC.LT.3) THEN + IF (ILC.NE.2) THEN +C...Multiple j-j connections not handled yet. + CALL PYERRM(2, + & '(PYPREP:) Too many junction-junction strings.') + MINT(51)=1 + RETURN + ENDIF +C...The colour information in the junction is unreadable for the +C...colour space search further down in this routine, so we must +C...start on the colour mother of this junction and then "artificially" +C...prevent the colour mother from connecting here again. + ITJUNC=MOD(K(I,4)/MSTU(5),MSTU(5)) + KCS=4 + IF (MOD(ITJUNC,2).EQ.0) KCS=5 +C...Switch colour if the junction-junction leg is presumably a +C...junction mother leg rather than a junction daughter leg. + IF (ITJUNC.GE.3) KCS=9-KCS + IF (MINT(33).EQ.0) THEN +C...Find the unconnected leg and reorder junction daughter pointers so +C...MOD(K(I,4),MSTU(5)) always points to the junction-junction string +C...piece. + IA=MOD(K(I,4),MSTU(5)) + IF (K(IA,KCS)/MSTU(5)**2.GE.2) THEN + ITMP=MOD(K(I,5),MSTU(5)) + IF (K(ITMP,KCS)/MSTU(5)**2.GE.2) THEN + ITMP=MOD(K(I,5)/MSTU(5),MSTU(5)) + K(I,5)=K(I,5)+(IA-ITMP)*MSTU(5) + ELSE + K(I,5)=K(I,5)+(IA-ITMP) + ENDIF + K(I,4)=K(I,4)+(ITMP-IA) + IA=ITMP + ENDIF + IF (ITJUNC.LE.2) THEN +C...Beam baryon junction + K(IA,KCS) = K(IA,KCS) + 2*MSTU(5)**2 + K(I,KCS) = K(I,KCS) + 1*MSTU(5)**2 +C...Else 1 -> 2 decay junction + ELSE + K(IA,KCS) = K(IA,KCS) + MSTU(5)**2 + K(I,KCS) = K(I,KCS) + 2*MSTU(5)**2 + ENDIF + I1BEG = I1 + NSTP = 0 + GOTO 170 +C...Alternatively use colour tag information. + ELSE +C...Find a final state parton with appropriate dangling colour tag. + JCT=0 + IA=0 + IJUMO=K(I,3) + DO 140 J1=MAX(1,IP),N + IF (K(J1,1).NE.3) GOTO 140 +C...Check for matching final-state colour tag + IMATCH=0 + DO 120 J2=MAX(1,IP),N + IF (K(J2,1).NE.3) GOTO 120 + IF (MCT(J1,KCS-3).EQ.MCT(J2,6-KCS)) IMATCH=1 + 120 CONTINUE + IF (IMATCH.EQ.1) GOTO 140 +C...Check whether this colour tag belongs to the present junction +C...by seeing whether any parton with this colour tag has the same +C...mother as the junction. + JCT=MCT(J1,KCS-3) + IMATCH=0 + DO 130 J2=MINT(84)+1,N + IMO2=K(J2,3) +C...First scattering partons have IMO1 = 3 and 4. + IF (IMO2.EQ.MINT(83)+3.OR.IMO2.EQ.MINT(83)+4) + & IMO2=IMO2-2 + IF (MCT(J2,KCS-3).EQ.JCT.AND.IMO2.EQ.IJUMO) + & IMATCH=1 + 130 CONTINUE + IF (IMATCH.EQ.0) GOTO 140 + IA=J1 + 140 CONTINUE +C...Check for junction-junction strings without intermediate final state +C...glue (not detected above). + IF (IA.EQ.0) THEN + DO 160 MJU=1,NJUNC + IJU2=IJUNC(MJU,0) + IF (IJU2.EQ.I) GOTO 160 + ITJU2=MOD(K(IJU2,4)/MSTU(5),MSTU(5)) +C...Only opposite types of junctions can connect to each other. + IF (MOD(ITJU2,2).EQ.MOD(ITJUNC,2)) GOTO 160 + IS=0 + DO 150 J=1,NPIECE + IF (IPIECE(J,4).EQ.IJU2) IS=IS+1 + 150 CONTINUE + IF (IS.EQ.3) GOTO 160 + IB=I + IA=IJU2 + 160 CONTINUE + ENDIF +C...Switch to other side of adjacent parton and step from there. + KCS=9-KCS + I1BEG = I1 + NSTP = 0 + GOTO 170 + ENDIF + ELSE IF (ILC.NE.3) THEN + ENDIF + ENDIF + ENDIF + +C...Look for coloured string endpoint, or (later) leftover gluon. + IF(K(I,1).NE.3) GOTO 240 + KC=PYCOMP(K(I,2)) + IF(KC.EQ.0) GOTO 240 + KQ=KCHG(KC,2) + IF(KQ.EQ.0.OR.(MQGST.LE.2.AND.KQ.EQ.2)) GOTO 240 + +C...Pick up loose string end. + KCS=4 + IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5 + IA=I + IB=I + I1BEG=I1 + NSTP=0 + 170 NSTP=NSTP+1 + IF(NSTP.GT.4*N) THEN + CALL PYERRM(14,'(PYPREP:) caught in infinite loop') + MINT(51)=1 + RETURN + ENDIF + +C...Copy undecayed parton. Finished if reached string endpoint. + IF(K(IA,1).EQ.3) THEN + IF(I1.GE.MSTU(4)-MSTU32-5) THEN + CALL PYERRM(11,'(PYPREP:) no more memory left in PYJETS') + MINT(51)=1 + MSTU(24)=1 + RETURN + ENDIF + I1=I1+1 + K(I1,1)=2 + IF(NSTP.GE.2.AND.KCHG(PYCOMP(K(IA,2)),2).NE.2) K(I1,1)=1 + K(I1,2)=K(IA,2) + K(I1,3)=IA + K(I1,4)=0 + K(I1,5)=0 + DO 180 J=1,5 + P(I1,J)=P(IA,J) + V(I1,J)=V(IA,J) + 180 CONTINUE + K(IA,1)=K(IA,1)+10 + IF(K(I1,1).EQ.1) GOTO 240 + ENDIF + +C...Also finished (for now) if reached junction; then copy to end. + IF(K(IA,1).EQ.42) THEN + NCOPY=I1-I1BEG + IF(I1.GE.MSTU(4)-MSTU32-NCOPY-5) THEN + CALL PYERRM(11,'(PYPREP:) no more memory left in PYJETS') + MINT(51)=1 + MSTU(24)=1 + RETURN + ENDIF + IF (MQGST.LE.2.AND.NCOPY.NE.0) THEN + DO 200 ICOPY=1,NCOPY + DO 190 J=1,5 + K(MSTU(4)-MSTU32-ICOPY,J)=K(I1BEG+ICOPY,J) + P(MSTU(4)-MSTU32-ICOPY,J)=P(I1BEG+ICOPY,J) + V(MSTU(4)-MSTU32-ICOPY,J)=V(I1BEG+ICOPY,J) + 190 CONTINUE + 200 CONTINUE + ENDIF +C...For junction-junction strings, find end leg and reorder junction +C...daughter pointers so MOD(K(I,4),MSTU(5)) always points to the +C...junction-junction string piece. + IF (K(I,1).EQ.42.AND.MINT(33).EQ.0) THEN + ITMP=MOD(K(IA,4),MSTU(5)) + IF (ITMP.NE.IB) THEN + IF (MOD(K(IA,5),MSTU(5)).EQ.IB) THEN + K(IA,5)=K(IA,5)+(ITMP-IB) + ELSE + K(IA,5)=K(IA,5)+(ITMP-IB)*MSTU(5) + ENDIF + K(IA,4)=K(IA,4)+(IB-ITMP) + ENDIF + ENDIF + NPIECE=NPIECE+1 +C...IPIECE: +C...0: endpoint in original ER +C...1: +C...2: +C...3: Parton immediately next to junction +C...4: Junction + IPIECE(NPIECE,0)=I + IPIECE(NPIECE,1)=MSTU32+1 + IPIECE(NPIECE,2)=MSTU32+NCOPY + IPIECE(NPIECE,3)=IB + IPIECE(NPIECE,4)=IA + MSTU32=MSTU32+NCOPY + I1=I1BEG + GOTO 240 + ENDIF + +C...GOTO next parton in colour space. + IB=IA + IF (MINT(33).EQ.0) THEN + IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5 + & )).NE.0) THEN + IA=MOD(K(IB,KCS),MSTU(5)) + K(IB,KCS)=K(IB,KCS)+MSTU(5)**2 + MREV=0 + ELSE + IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5), + & MSTU(5)).EQ.0) KCS=9-KCS + IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5)) + K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2 + MREV=1 + ENDIF + IF(IA.LE.0.OR.IA.GT.N) THEN + CALL PYERRM(12,'(PYPREP:) colour rearrangement failed') + IF(NERRPR.LT.5) THEN + NERRPR=NERRPR+1 + WRITE(MSTU(11),*) 'started at:', I + WRITE(MSTU(11),*) 'ended going from',IB,' to',IA + WRITE(MSTU(11),*) 'MQGST =',MQGST + CALL PYLIST(4) + ENDIF + MINT(51)=1 + RETURN + ENDIF + IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5) + & ,MSTU(5)).EQ.IB) THEN + IF(MREV.EQ.1) KCS=9-KCS + IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS + K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2 + ELSE + IF(MREV.EQ.0) KCS=9-KCS + IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS + K(IA,KCS)=K(IA,KCS)+MSTU(5)**2 + ENDIF + IF(IA.NE.I) GOTO 170 +C...Use colour tag information + ELSE +C...First create colour tags starting on IB if none already present. + IF (MCT(IB,KCS-3).EQ.0) THEN + CALL PYCTTR(IB,KCS,IB) + IF(MINT(51).NE.0) RETURN + ENDIF + JCT=MCT(IB,KCS-3) + IFOUND=0 +C...Find final state tag partner + DO 210 IT=MAX(1,IP),N + IF (IT.EQ.IB) GOTO 210 + IF (MCT(IT,6-KCS).EQ.JCT.AND.K(IT,1).LT.10.AND.K(IT,1).GT + & .0) THEN + IFOUND=IFOUND+1 + IA=IT + ENDIF + 210 CONTINUE +C...Just copy and goto next if exactly one partner found. + IF (IFOUND.EQ.1) THEN + GOTO 170 +C...When no match found, match is presumably junction. + ELSEIF (IFOUND.EQ.0.AND.MQGST.LE.2) THEN +C...Check whether this colour tag matches a junction +C...by seeing whether any parton with this colour tag has the same +C...mother as a junction. +C...NB: Only type 1 and 2 junctions handled presently. + DO 230 IJU=1,NJUNC + IJUMO=K(IJUNC(IJU,0),3) + ITJUNC=MOD(K(IJUNC(IJU,0),4)/MSTU(5),MSTU(5)) +C...Colours only connect to junctions, anti-colours to antijunctions: + IF (MOD(ITJUNC+1,2)+1.NE.KCS-3) GOTO 230 + IMATCH=0 + DO 220 J1=MAX(1,IP),N + IF (K(J1,1).LE.0) GOTO 220 +C...First scattering partons have IMO1 = 3 and 4. + IMO=K(J1,3) + IF (IMO.EQ.MINT(83)+3.OR.IMO.EQ.MINT(83)+4) + & IMO=IMO-2 + IF (MCT(J1,KCS-3).EQ.JCT.AND.IMO.EQ.IJUMO.AND.MOD(K(J1 + & ,3+ITJUNC)/MSTU(5),MSTU(5)).EQ.IJUNC(IJU,0)) + & IMATCH=1 +C...Attempt at handling type > 3 junctions also. Not tested. + IF (ITJUNC.GE.3.AND.MCT(J1,6-KCS).EQ.JCT.AND.IMO.EQ + & .IJUMO) IMATCH=1 + 220 CONTINUE + IF (IMATCH.EQ.0) GOTO 230 + IA=IJUNC(IJU,0) + IFOUND=IFOUND+1 + 230 CONTINUE + + IF (IFOUND.EQ.1) THEN + GOTO 170 + ELSEIF (IFOUND.EQ.0) THEN + WRITE(CHTMP,'(I6)') JCT + CALL PYERRM(12,'(PYPREP:) no matching colour tag: ' + & //CHTMP) + IF(NERRPR.LT.5) THEN + NERRPR=NERRPR+1 + CALL PYLIST(4) + ENDIF + MINT(51)=1 + RETURN + ENDIF + ELSEIF (IFOUND.GE.2) THEN + WRITE(CHTMP,'(I6)') JCT + CALL PYERRM(12 + & ,'(PYPREP:) too many occurences of colour line: '// + & CHTMP) + IF(NERRPR.LT.5) THEN + NERRPR=NERRPR+1 + CALL PYLIST(4) + ENDIF + MINT(51)=1 + RETURN + ENDIF + ENDIF + K(I1,1)=1 + 240 CONTINUE + 250 CONTINUE + +C...Junction systems remain. + IJU=0 + IJUS=0 + IJUCNT=0 + MREV=0 + IJJSTR=0 + 260 IJUCNT=IJUCNT+1 + IF (IJUCNT.LE.NJUNC) THEN +C...If we are not processing a j-j string, treat this junction as new. + IF (IJJSTR.EQ.0) THEN + IJU=IJUNC(IJUCNT,0) + MREV=0 +C...If junction has already been read, ignore it. + IF (IJUNC(IJUCNT,4).EQ.1) GOTO 260 +C...If we are on a j-j string, goto second j-j junction. + ELSE + IJUCNT=IJUCNT-1 + IJU=IJUS + ENDIF +C...Mark selected junction read. + DO 270 J=1,NJUNC + IF (IJUNC(J,0).EQ.IJU) IJUNC(J,4)=1 + 270 CONTINUE +C...Determine junction type + ITJUNC = MOD(K(IJU,4)/MSTU(5),MSTU(5)) +C...Type 1 and 2 junctions: ~chi -> q q q, ~chi -> qbar,qbar,qbar +C...Type 3 and 4 junctions: ~qbar -> q q , ~q -> qbar qbar +C...Type 5 and 6 junctions: ~g -> q q q, ~g -> qbar qbar qbar + IF (ITJUNC.GE.1.AND.ITJUNC.LE.6) THEN + IHK=0 + 280 IHK=IHK+1 +C...Find which quarks belong to given junction. + IHF=0 + DO 290 IPC=1,NPIECE + IF (IPIECE(IPC,4).EQ.IJU) THEN + IHF=IHF+1 + IF (IHF.EQ.IHK) IEND=IPIECE(IPC,3) + ENDIF + IF (IHK.EQ.3.AND.IPIECE(IPC,0).EQ.IJU) IEND=IPIECE(IPC,3) + 290 CONTINUE +C...IHK = 3 is special. Either normal string piece, or j-j string. + IF(IHK.EQ.3) THEN + IF (MREV.NE.1) THEN + DO 300 IPC=1,NPIECE +C...If there is a j-j string starting on the present junction which has +C...zero length, insert next junction immediately. + IF (IPIECE(IPC,0).EQ.IJU.AND.K(IPIECE(IPC,4),1) + & .EQ.42.AND.IPIECE(IPC,1)-1-IPIECE(IPC,2).EQ.0) THEN + IJJSTR = 1 + GOTO 340 + ENDIF + 300 CONTINUE + MREV = 1 +C...If MREV is 1 and IHK is 3 we are finished with this system. + ELSE + MREV=0 + GOTO 260 + ENDIF + ENDIF + +C...If we've gotten this far, then either IHK < 3, or +C...an interjunction string exists, or just a third normal string. + IJUNC(IJUCNT,IHK)=0 + IJJSTR = 0 +C..Order pieces belonging to this junction. Also look for j-j. + DO 310 IPC=1,NPIECE + IF (IPIECE(IPC,3).EQ.IEND) IJUNC(IJUCNT,IHK)=IPC + IF (IHK.EQ.3.AND.IPIECE(IPC,0).EQ.IJUNC(IJUCNT,0) + & .AND.K(IPIECE(IPC,4),1).EQ.42) THEN + IJUNC(IJUCNT,IHK)=IPC + IJJSTR = 1 + MREV = 0 + ENDIF + 310 CONTINUE +C...Copy back chains in proper order. MREV=0/1 : descending/ascending + IPC=IJUNC(IJUCNT,IHK) +C...Temporary solution to cover for bug. + IF(IPC.LE.0) THEN + CALL PYERRM(12,'(PYPREP:) fails to hook up junctions') + MINT(51)=1 + RETURN + ENDIF + DO 330 ICP=IPIECE(IPC,1+MREV),IPIECE(IPC,2-MREV),1-2*MREV + I1=I1+1 + DO 320 J=1,5 + K(I1,J)=K(MSTU(4)-ICP,J) + P(I1,J)=P(MSTU(4)-ICP,J) + V(I1,J)=V(MSTU(4)-ICP,J) + 320 CONTINUE + 330 CONTINUE + K(I1,1)=2 +C...Mark last quark. + IF (MREV.EQ.1.AND.IHK.GE.2) K(I1,1)=1 +C...Do not insert junctions at wrong places. + IF(IHK.LT.2.OR.MREV.NE.0) GOTO 360 +C...Insert junction. + 340 IJUS = IJU + IF (IHK.EQ.3) THEN +C...Shift to end junction if a j-j string has been processed. + IF (IJJSTR.NE.0) IJUS = IPIECE(IPC,4) + MREV= 1 + ENDIF + I1=I1+1 + DO 350 J=1,5 + K(I1,J)=0 + P(I1,J)=0. + V(I1,J)=0. + 350 CONTINUE + K(I1,1)=41 + K(IJUS,1)=K(IJUS,1)+10 + K(I1,2)=K(IJUS,2) + K(I1,3)=IJUS + 360 IF (IHK.LT.3) GOTO 280 + ELSE + CALL PYERRM(12,'(PYPREP:) Unknown junction type') + MINT(51)=1 + RETURN + ENDIF + IF (IJUCNT.NE.NJUNC) GOTO 260 + ENDIF + N=I1 + +C...Rearrange three strings from junction, e.g. in case one has been +C...shortened by shower, so the last is the largest-energy one. + IF(NJUNC.GE.1) THEN +C...Find systems with exactly one junction. + MJUN1=0 + NBEG=NOLD+1 + DO 470 I=NOLD+1,N + IF(K(I,1).NE.1.AND.K(I,1).NE.41) THEN + ELSEIF(K(I,1).EQ.41) THEN + MJUN1=MJUN1+1 + ELSEIF(K(I,1).EQ.1.AND.MJUN1.NE.1) THEN + MJUN1=0 + NBEG=I+1 + ELSE + NEND=I +C...Sum up energy-momentum in each junction string. + DO 370 J=1,5 + PJU(1,J)=0D0 + PJU(2,J)=0D0 + PJU(3,J)=0D0 + 370 CONTINUE + NJU=0 + DO 390 I1=NBEG,NEND + IF(K(I1,2).NE.21) THEN + NJU=NJU+1 + IJUR(NJU)=I1 + ENDIF + DO 380 J=1,5 + PJU(MIN(NJU,3),J)=PJU(MIN(NJU,3),J)+P(I1,J) + 380 CONTINUE + 390 CONTINUE +C...Find which of them has highest energy (minus mass) in rest frame. + DO 400 J=1,5 + PJU(4,J)=PJU(1,J)+PJU(2,J)+PJU(3,J) + 400 CONTINUE + PMJU=SQRT(MAX(0D0,PJU(4,4)**2-PJU(4,1)**2-PJU(4,2)**2- + & PJU(4,3)**2)) + DO 410 I2=1,3 + PJU(I2,6)=(PJU(4,4)*PJU(I2,4)-PJU(4,1)*PJU(I2,1)- + & PJU(4,2)*PJU(I2,2)-PJU(4,3)*PJU(I2,3))/PMJU-PJU(I2,5) + 410 CONTINUE + IF(PJU(3,6).LT.MIN(PJU(1,6),PJU(2,6))) THEN +C...Decide how to rearrange so that new last has highest energy. + IF(PJU(1,6).LT.PJU(2,6)) THEN + IRNG(1,1)=IJUR(1) + IRNG(1,2)=IJUR(2)-1 + IRNG(2,1)=IJUR(4) + IRNG(2,2)=IJUR(3)+1 + IRNG(4,1)=IJUR(3)-1 + IRNG(4,2)=IJUR(2) + ELSE + IRNG(1,1)=IJUR(4) + IRNG(1,2)=IJUR(3)+1 + IRNG(2,1)=IJUR(2) + IRNG(2,2)=IJUR(3)-1 + IRNG(4,1)=IJUR(2)-1 + IRNG(4,2)=IJUR(1) + ENDIF + IRNG(3,1)=IJUR(3) + IRNG(3,2)=IJUR(3) +C...Copy in correct order below bottom of current event record. + I2=N + DO 440 II=1,4 + DO 430 I1=IRNG(II,1),IRNG(II,2), + & ISIGN(1,IRNG(II,2)-IRNG(II,1)) + I2=I2+1 + IF(I2.GE.MSTU(4)-MSTU32-5) THEN + CALL PYERRM(11, + & '(PYPREP:) no more memory left in PYJETS') + MINT(51)=1 + MSTU(24)=1 + RETURN + ENDIF + DO 420 J=1,5 + K(I2,J)=K(I1,J) + P(I2,J)=P(I1,J) + V(I2,J)=V(I1,J) + 420 CONTINUE + IF(K(I2,1).EQ.1) K(I2,1)=2 + 430 CONTINUE + 440 CONTINUE + K(I2,1)=1 +C...Copy back up, overwriting but now in correct order. + DO 460 I1=NBEG,NEND + I2=I1-NBEG+N+1 + DO 450 J=1,5 + K(I1,J)=K(I2,J) + P(I1,J)=P(I2,J) + V(I1,J)=V(I2,J) + 450 CONTINUE + 460 CONTINUE + ENDIF + MJUN1=0 + NBEG=I+1 + ENDIF + 470 CONTINUE + +C...Check whether q-q-j-j-qbar-qbar systems should be collapsed +C...to two q-qbar systems. +C...(MSTJ(19)=1 forces q-q-j-j-qbar-qbar.) + IF (MSTJ(19).NE.1) THEN + MJUN1 = 0 + JJGLUE = 0 + NBEG = NOLD+1 +C...Force collapse when MSTJ(19)=2. + IF (MSTJ(19).EQ.2) THEN + DELMJJ = 1D9 + DELMQQ = 0D0 + ENDIF +C...Find systems with exactly two junctions. + DO 700 I=NOLD+1,N +C...Count junctions + IF (K(I,1).EQ.41) THEN + MJUN1 = MJUN1+1 +C...Check for interjunction gluons + IF (MJUN1.EQ.2.AND.K(I-1,1).NE.41) THEN + JJGLUE = 1 + ENDIF + ELSEIF(K(I,1).EQ.1.AND.(MJUN1.NE.2)) THEN +C...If end of system reached with either zero or one junction, restart +C...with next system. + MJUN1 = 0 + JJGLUE = 0 + NBEG = I+1 + ELSEIF(K(I,1).EQ.1) THEN +C...If end of system reached with exactly two junctions, compute string +C...length measure for the (q-q-j-j-qbar-qbar) topology and compare with +C...length measure for the (q-qbar)(q-qbar) topology. + NEND=I +C...Loop down through chain. + ISID=0 + DO 480 I1=NBEG,NEND +C...Store string piece division locations in event record + IF (K(I1,2).NE.21) THEN + ISID = ISID+1 + IJCP(ISID) = I1 + ENDIF + 480 CONTINUE +C...Randomly choose between (1,3)(2,4) and (1,4)(2,3) topologies. + ISW=0 + IF (PYR(0).LT.0.5D0) ISW=1 +C...Randomly choose which qqbar string gets the jj gluons. + IGS=1 + IF (PYR(0).GT.0.5D0) IGS=2 +C...Only compute string lengths when no topology forced. + IF (MSTJ(19).EQ.0) THEN +C...Repeat following for each junction + DO 570 IJU=1,2 +C...Initialize iterative procedure for finding JRF + IJRFIT=0 + DO 490 IX=1,3 + TJUOLD(IX)=0D0 + 490 CONTINUE + TJUOLD(4)=1D0 +C...Start iteration. Sum up momenta in string pieces + 500 DO 540 IJS=1,3 +C...JD=-1 for first junction, +1 for second junction. +C...Find out where piece starts and ends and which direction to go. + JD=2*IJU-3 + IF (IJS.LE.2) THEN + IA = IJCP((IJU-1)*7 - JD*(IJS+1)) + JD + IB = IJCP((IJU-1)*7 - JD*IJS) + ELSEIF (IJS.EQ.3) THEN + JD =-JD + IA = IJCP((IJU-1)*7 + JD*(IJS)) + JD + IB = IJCP((IJU-1)*7 + JD*(IJS+3)) + ENDIF +C...Initialize junction pull 4-vector. + DO 510 J=1,5 + PUL(IJS,J)=0D0 + 510 CONTINUE +C...Initialize weight + PWT = 0D0 + PWTOLD = 0D0 +C...Sum up (weighted) momenta along each string piece + DO 530 ISP=IA,IB,JD +C...If present parton not last in chain + IF (ISP.NE.IA.AND.ISP.NE.IB) THEN +C...If last parton was a junction, store present weight + IF (K(ISP-JD,2).EQ.88) THEN + PWTOLD = PWT +C...If last parton was a quark, reset to stored weight. + ELSEIF (K(ISP-JD,2).NE.21) THEN + PWT = PWTOLD + ENDIF + ENDIF +C...Skip next parton if weight already large + IF (PWT.GT.10D0) GOTO 530 +C...Compute momentum in TJUOLD frame: + TDP=TJUOLD(1)*P(ISP,1)+TJUOLD(2)*P(ISP,2)+TJUOLD(3 + & )*P(ISP,3) + BFC=TDP/(1D0+TJUOLD(4))+P(ISP,4) + DO 520 J=1,3 + TMP=P(ISP,J)+TJUOLD(J)*BFC + PUL(IJS,J)=PUL(IJS,J)+TMP*EXP(-PWT) + 520 CONTINUE +C...Boosted energy + TMP=TJUOLD(4)*P(ISP,4)+TDP + PUL(IJS,4)=PUL(IJS,J)+TMP*EXP(-PWT) +C...Update weight + PWT=PWT+TMP/PARJ(48) +C...Put |p| rather than m in 5th slot + PUL(IJS,5)=SQRT(PUL(IJS,1)**2+PUL(IJS,2)**2 + & +PUL(IJS,3)**2) + 530 CONTINUE + 540 CONTINUE +C...Compute boost + IJRFIT=IJRFIT+1 + CALL PYJURF(PUL,T) +C...Combine new boost (T) with old boost (TJUOLD) + TMP=T(1)*TJUOLD(1)+T(2)*TJUOLD(2)+T(3)*TJUOLD(3) + DO 550 IX=1,3 + TJUOLD(IX)=T(IX)+TJUOLD(IX)*(TMP/(1D0+TJUOLD(4))+T(4 + & )) + 550 CONTINUE + TJUOLD(4)=SQRT(1D0+TJUOLD(1)**2+TJUOLD(2)**2+TJUOLD(3) + & **2) +C...If last boost small, accept JRF, else iterate. +C...Also prevent possibility of infinite loop. + IF (ABS((T(4)-1D0)/TJUOLD(4)).GT.0.01D0.AND. + & IJRFIT.LT.MSTJ(18))THEN + GOTO 500 + ELSEIF (IJRFIT.GE.MSTJ(18)) THEN + CALL PYERRM(1,'(PYPREP:) failed to converge on JRF') + ENDIF +C...Store final boost, with change of sign since TJJ motion vector. + DO 560 IX=1,3 + TJJ(IJU,IX)=-TJUOLD(IX) + 560 CONTINUE + TJJ(IJU,4)=SQRT(1D0+TJJ(IJU,1)**2+TJJ(IJU,2)**2 + & +TJJ(IJU,3)**2) + 570 CONTINUE +C...String length measure for (q-qbar)(q-qbar) topology. +C...Note only momenta of nearest partons used (since rest of system +C...identical). + IF (JJGLUE.EQ.0) THEN + DELMQQ=4D0*FOUR(IJCP(2)-1,IJCP(4+ISW)+1)*FOUR(IJCP(3) + & -1,IJCP(5-ISW)+1) + ELSE +C...Put jj gluons on selected string (IGS selected randomly above). + IF (IGS.EQ.1) THEN + DELMQQ=8D0*FOUR(IJCP(2)-1,IJCP(4)-1)*FOUR(IJCP(3)+1 + & ,IJCP(4+ISW)+1)*FOUR(IJCP(3)-1,IJCP(5-ISW)+1) + ELSE + DELMQQ=8D0*FOUR(IJCP(2)-1,IJCP(4+ISW)+1) + & *FOUR(IJCP(3)-1,IJCP(4)-1)*FOUR(IJCP(3)+1 + & ,IJCP(5-ISW)+1) + ENDIF + ENDIF +C...String length measure for q-q-j-j-q-q topology. + T1G1=0D0 + T2G2=0D0 + T1T2=0D0 + T1P1=0D0 + T1P2=0D0 + T2P3=0D0 + T2P4=0D0 + ISGN=-1 +C...Note only momenta of nearest partons used (since rest of system +C...identical). + DO 580 IX=1,4 + IF (IX.EQ.4) ISGN=1 + T1P1=T1P1+ISGN*TJJ(1,IX)*P(IJCP(2)-1,IX) + T1P2=T1P2+ISGN*TJJ(1,IX)*P(IJCP(3)-1,IX) + T2P3=T2P3+ISGN*TJJ(2,IX)*P(IJCP(4)+1,IX) + T2P4=T2P4+ISGN*TJJ(2,IX)*P(IJCP(5)+1,IX) + IF (JJGLUE.EQ.0) THEN +C...Junction motion vector dot product gives length when inter-junction +C...gluons absent. + T1T2=T1T2+ISGN*TJJ(1,IX)*TJJ(2,IX) + ELSE +C...Junction motion vector dot products with gluon momenta give length +C...when inter-junction gluons present. + T1G1=T1G1+ISGN*TJJ(1,IX)*P(IJCP(3)+1,IX) + T2G2=T2G2+ISGN*TJJ(2,IX)*P(IJCP(4)-1,IX) + ENDIF + 580 CONTINUE + DELMJJ=16D0*T1P1*T1P2*T2P3*T2P4 + IF (JJGLUE.EQ.0) THEN + DELMJJ=DELMJJ*(T1T2+SQRT(T1T2**2-1)) + ELSE + DELMJJ=DELMJJ*4D0*T1G1*T2G2 + ENDIF + ENDIF +C...If delmjj > delmqq collapse string system to q-qbar q-qbar +C...(Always the case for MSTJ(19)=2 due to initialization above) + IF (DELMJJ.GT.DELMQQ) THEN +C...Put new system at end of event record + NCOP=N + DO 650 IST=1,2 + DO 600 ICOP=IJCP(IST),IJCP(IST+1)-1 + NCOP=NCOP+1 + DO 590 IX=1,5 + P(NCOP,IX)=P(ICOP,IX) + K(NCOP,IX)=K(ICOP,IX) + 590 CONTINUE + 600 CONTINUE + IF (JJGLUE.NE.0.AND.IST.EQ.IGS) THEN +C...Insert inter-junction gluon string piece (reversed) + NJJGL=0 + DO 620 ICOP=IJCP(4)-1,IJCP(3)+1,-1 + NJJGL=NJJGL+1 + NCOP=NCOP+1 + DO 610 IX=1,5 + P(NCOP,IX)=P(ICOP,IX) + K(NCOP,IX)=K(ICOP,IX) + 610 CONTINUE + 620 CONTINUE + ENDIF + IFC=-2*IST+3 + DO 640 ICOP=IJCP(IST+IFC*ISW+3)+1,IJCP(IST+IFC*ISW+4) + NCOP=NCOP+1 + DO 630 IX=1,5 + P(NCOP,IX)=P(ICOP,IX) + K(NCOP,IX)=K(ICOP,IX) + 630 CONTINUE + 640 CONTINUE + K(NCOP,1)=1 + 650 CONTINUE +C...Copy system back in right order + DO 670 ICOP=NBEG,NEND-2 + DO 660 IX=1,5 + P(ICOP,IX)=P(N+ICOP-NBEG+1,IX) + K(ICOP,IX)=K(N+ICOP-NBEG+1,IX) + 660 CONTINUE + 670 CONTINUE +C...Shift down rest of event record + DO 690 ICOP=NEND+1,N + DO 680 IX=1,5 + P(ICOP-2,IX)=P(ICOP,IX) + K(ICOP-2,IX)=K(ICOP,IX) + 680 CONTINUE + 690 CONTINUE +C...Update length of event record. + N=N-2 + ENDIF + MJUN1=0 + NBEG=I+1 + ENDIF + 700 CONTINUE + ENDIF + ENDIF + +C...Done if no checks on small-mass systems. + IF(MSTJ(14).LT.0) RETURN + IF(MSTJ(14).EQ.0) GOTO 1140 + +C...Find lowest-mass colour singlet jet system. + NS=N + 710 NSIN=N-NS + PDMIN=1D0+PARJ(32) + IC=0 + DO 770 I=MAX(1,IP),N + IF(K(I,1).NE.1.AND.K(I,1).NE.2) THEN + ELSEIF(K(I,1).EQ.2.AND.IC.EQ.0) THEN + NSIN=NSIN+1 + IC=I + DO 720 J=1,4 + DPS(J)=P(I,J) + 720 CONTINUE + MSTJ(93)=1 + DPS(5)=PYMASS(K(I,2)) + ELSEIF(K(I,1).EQ.2.AND.K(I,2).NE.21) THEN + DO 730 J=1,4 + DPS(J)=DPS(J)+P(I,J) + 730 CONTINUE + MSTJ(93)=1 + DPS(5)=DPS(5)+PYMASS(K(I,2)) + ELSEIF(K(I,1).EQ.2) THEN + DO 740 J=1,4 + DPS(J)=DPS(J)+P(I,J) + 740 CONTINUE + ELSEIF(IC.NE.0.AND.KCHG(PYCOMP(K(I,2)),2).NE.0) THEN + DO 750 J=1,4 + DPS(J)=DPS(J)+P(I,J) + 750 CONTINUE + MSTJ(93)=1 + DPS(5)=DPS(5)+PYMASS(K(I,2)) + PD=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))- + & DPS(5) + IF(PD.LT.PDMIN) THEN + PDMIN=PD + DO 760 J=1,5 + DPC(J)=DPS(J) + 760 CONTINUE + IC1=IC + IC2=I + ENDIF + IC=0 + ELSE + NSIN=NSIN+1 + ENDIF + 770 CONTINUE + +C...Done if lowest-mass system above threshold for string frag. + IF(PDMIN.GE.PARJ(32)) GOTO 1140 + +C...Fill small-mass system as cluster. + NSAV=N + PECM=SQRT(MAX(0D0,DPC(4)**2-DPC(1)**2-DPC(2)**2-DPC(3)**2)) + K(N+1,1)=11 + K(N+1,2)=91 + K(N+1,3)=IC1 + P(N+1,1)=DPC(1) + P(N+1,2)=DPC(2) + P(N+1,3)=DPC(3) + P(N+1,4)=DPC(4) + P(N+1,5)=PECM + +C...Set up history, assuming cluster -> 2 hadrons. + NBODY=2 + K(N+1,4)=N+2 + K(N+1,5)=N+3 + K(N+2,1)=1 + K(N+3,1)=1 + IF(MSTU(16).NE.2) THEN + K(N+2,3)=N+1 + K(N+3,3)=N+1 + ELSE + K(N+2,3)=IC1 + K(N+3,3)=IC2 + ENDIF + K(N+2,4)=0 + K(N+3,4)=0 + K(N+2,5)=0 + K(N+3,5)=0 + V(N+1,5)=0D0 + V(N+2,5)=0D0 + V(N+3,5)=0D0 + +C...Find total flavour content - complicated by presence of junctions. + NQ=0 + NDIQ=0 + DO 780 I=IC1,IC2 + IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.K(I,2).NE.21) THEN + NQ=NQ+1 + KFQ(NQ)=K(I,2) + IF(IABS(K(I,2)).GT.1000) NDIQ=NDIQ+1 + ENDIF + 780 CONTINUE + +C...If several diquarks, split up one to give even number of flavours. + IF(NQ.EQ.3.AND.NDIQ.GE.2) THEN + I1=3 + IF(IABS(KFQ(3)).LT.1000) I1=1 + KFQ(4)=ISIGN(MOD(IABS(KFQ(I1))/100,10),KFQ(I1)) + KFQ(I1)=KFQ(I1)/1000 + NQ=4 + NDIQ=NDIQ-1 + ENDIF + +C...If four quark ends, join two to diquark. + IF(NQ.EQ.4.AND.NDIQ.EQ.0) THEN + I1=1 + I2=2 + IF(KFQ(I1)*KFQ(I2).LT.0) I2=3 + IF(I2.EQ.3.AND.KFQ(I1)*KFQ(I2).LT.0) I2=4 + KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1 + IF(KFQ(I1).EQ.KFQ(I2)) KFLS=3 + KFQ(I1)=ISIGN(1000*MAX(IABS(KFQ(I1)),IABS(KFQ(I2)))+ + & 100*MIN(IABS(KFQ(I1)),IABS(KFQ(I2)))+KFLS,KFQ(I1)) + KFQ(I2)=KFQ(4) + NQ=3 + NDIQ=1 + ENDIF + +C...If two quark ends, plus quark or diquark, join quarks to diquark. + IF(NQ.EQ.3) THEN + I1=1 + I2=2 + IF(IABS(KFQ(I1)).GT.1000) I1=3 + IF(IABS(KFQ(I2)).GT.1000) I2=3 + KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1 + IF(KFQ(I1).EQ.KFQ(I2)) KFLS=3 + KFQ(I1)=ISIGN(1000*MAX(IABS(KFQ(I1)),IABS(KFQ(I2)))+ + & 100*MIN(IABS(KFQ(I1)),IABS(KFQ(I2)))+KFLS,KFQ(I1)) + KFQ(I2)=KFQ(3) + NQ=2 + NDIQ=NDIQ+1 + ENDIF + +C...Form two particles from flavours of lowest-mass system, if feasible. + NTRY = 0 + 790 NTRY = NTRY + 1 + +C...Open string with two specified endpoint flavours. + IF(NQ.EQ.2) THEN + KC1=PYCOMP(KFQ(1)) + KC2=PYCOMP(KFQ(2)) + IF(KC1.EQ.0.OR.KC2.EQ.0) GOTO 1140 + KQ1=KCHG(KC1,2)*ISIGN(1,KFQ(1)) + KQ2=KCHG(KC2,2)*ISIGN(1,KFQ(2)) + IF(KQ1+KQ2.NE.0) GOTO 1140 +C...Start with qq, if there is one. Only allow for rank 1 popcorn meson + 800 K1=KFQ(1) + IF(IABS(KFQ(2)).GT.1000) K1=KFQ(2) + MSTU(125)=0 + CALL PYDCYK(K1,0,KFLN,K(N+2,2)) + CALL PYDCYK(KFQ(1)+KFQ(2)-K1,-KFLN,KFLDMP,K(N+3,2)) + IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 800 + +C...Open string with four specified flavours. + ELSEIF(NQ.EQ.4) THEN + KC1=PYCOMP(KFQ(1)) + KC2=PYCOMP(KFQ(2)) + KC3=PYCOMP(KFQ(3)) + KC4=PYCOMP(KFQ(4)) + IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) GOTO 1140 + KQ1=KCHG(KC1,2)*ISIGN(1,KFQ(1)) + KQ2=KCHG(KC2,2)*ISIGN(1,KFQ(2)) + KQ3=KCHG(KC3,2)*ISIGN(1,KFQ(3)) + KQ4=KCHG(KC4,2)*ISIGN(1,KFQ(4)) + IF(KQ1+KQ2+KQ3+KQ4.NE.0) GOTO 1140 +C...Combine flavours pairwise to form two hadrons. + 810 I1=1 + I2=2 + IF(KQ1*KQ2.GT.0.OR.(IABS(KFQ(1)).GT.1000.AND. + & IABS(KFQ(2)).GT.1000)) I2=3 + IF(I2.EQ.3.AND.(KQ1*KQ3.GT.0.OR.(IABS(KFQ(1)).GT.1000.AND. + & IABS(KFQ(3)).GT.1000))) I2=4 + I3=3 + IF(I2.EQ.3) I3=2 + I4=10-I1-I2-I3 + CALL PYDCYK(KFQ(I1),KFQ(I2),KFLDMP,K(N+2,2)) + CALL PYDCYK(KFQ(I3),KFQ(I4),KFLDMP,K(N+3,2)) + IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 810 + +C...Closed string. + ELSE + IF(IABS(K(IC2,2)).NE.21) GOTO 1140 +C...No room for popcorn mesons in closed string -> 2 hadrons. + MSTU(125)=0 + 820 CALL PYDCYK(1+INT((2D0+PARJ(2))*PYR(0)),0,KFLN,KFDMP) + CALL PYDCYK(KFLN,0,KFLM,K(N+2,2)) + CALL PYDCYK(-KFLN,-KFLM,KFLDMP,K(N+3,2)) + IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 820 + ENDIF + P(N+2,5)=PYMASS(K(N+2,2)) + P(N+3,5)=PYMASS(K(N+3,2)) + +C...If it does not work: try again (a number of times), give up (if no +C...place to shuffle momentum or too many flavours), or form one hadron. + IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM) THEN + IF(NTRY.LT.MSTJ(17).OR.(NQ.EQ.4.AND.NTRY.LT.5*MSTJ(17))) THEN + GOTO 790 + ELSEIF(NSIN.EQ.1.OR.NQ.EQ.4) THEN + GOTO 1140 + ELSE + GOTO 890 + END IF + END IF + +C...Perform two-particle decay of jet system. +C...First step: find reference axis in decaying system rest frame. +C...(Borrow slot N+2 for temporary direction.) + DO 830 J=1,4 + P(N+2,J)=P(IC1,J) + 830 CONTINUE + DO 850 I=IC1+1,IC2-1 + IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND. + & KCHG(PYCOMP(K(I,2)),2).NE.0) THEN + FRAC1=FOUR(IC2,I)/(FOUR(IC1,I)+FOUR(IC2,I)) + DO 840 J=1,4 + P(N+2,J)=P(N+2,J)+FRAC1*P(I,J) + 840 CONTINUE + ENDIF + 850 CONTINUE + CALL PYROBO(N+2,N+2,0D0,0D0,-DPC(1)/DPC(4),-DPC(2)/DPC(4), + &-DPC(3)/DPC(4)) + THE1=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2)) + PHI1=PYANGL(P(N+2,1),P(N+2,2)) + +C...Second step: generate isotropic/anisotropic decay. + PA=SQRT((PECM**2-(P(N+2,5)+P(N+3,5))**2)*(PECM**2- + &(P(N+2,5)-P(N+3,5))**2))/(2D0*PECM) + 860 UE(3)=PYR(0) + IF(PARJ(21).LE.0.01D0) UE(3)=1D0 + PT2=(1D0-UE(3)**2)*PA**2 + IF(MSTJ(16).LE.0) THEN + PREV=0.5D0 + ELSE + IF(EXP(-PT2/(2D0*MAX(0.01D0,PARJ(21))**2)).LT.PYR(0)) GOTO 860 + PR1=P(N+2,5)**2+PT2 + PR2=P(N+3,5)**2+PT2 + ALAMBD=SQRT(MAX(0D0,(PECM**2-PR1-PR2)**2-4D0*PR1*PR2)) + PREVCF=PARJ(42) + IF(MSTJ(11).EQ.2) PREVCF=PARJ(39) + PREV=1D0/(1D0+EXP(MIN(50D0,PREVCF*ALAMBD*PARJ(40)))) + ENDIF + IF(PYR(0).LT.PREV) UE(3)=-UE(3) + PHI=PARU(2)*PYR(0) + UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI) + UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI) + DO 870 J=1,3 + P(N+2,J)=PA*UE(J) + P(N+3,J)=-PA*UE(J) + 870 CONTINUE + P(N+2,4)=SQRT(PA**2+P(N+2,5)**2) + P(N+3,4)=SQRT(PA**2+P(N+3,5)**2) + +C...Third step: move back to event frame and set production vertex. + CALL PYROBO(N+2,N+3,THE1,PHI1,DPC(1)/DPC(4),DPC(2)/DPC(4), + &DPC(3)/DPC(4)) + DO 880 J=1,4 + V(N+1,J)=V(IC1,J) + V(N+2,J)=V(IC1,J) + V(N+3,J)=V(IC2,J) + 880 CONTINUE + N=N+3 + GOTO 1120 + +C...Else form one particle, if possible. + 890 NBODY=1 + K(N+1,5)=N+2 + DO 900 J=1,4 + V(N+1,J)=V(IC1,J) + V(N+2,J)=V(IC1,J) + 900 CONTINUE + +C...Select hadron flavour from available quark flavours. + 910 IF(NQ.EQ.2.AND.IABS(KFQ(1)).GT.100.AND.IABS(KFQ(2)).GT.100) THEN + GOTO 1140 + ELSEIF(NQ.EQ.2) THEN + CALL PYKFDI(KFQ(1),KFQ(2),KFLDMP,K(N+2,2)) + ELSE + KFLN=1+INT((2D0+PARJ(2))*PYR(0)) + CALL PYKFDI(KFLN,-KFLN,KFLDMP,K(N+2,2)) + ENDIF + IF(K(N+2,2).EQ.0) GOTO 910 + P(N+2,5)=PYMASS(K(N+2,2)) + +C...Use old algorithm for E/p conservation? (EN) + IF (MSTJ(16).LE.0) GOTO 1080 + +C...Find the string piece closest to the cluster by a loop +C...over the undecayed partons not in present cluster. (EN) + DGLOMI=1D30 + IBEG=0 + I0=0 + NJUNC=0 + DO 940 I1=MAX(1,IP),N-1 + IF(K(I1,1).EQ.1) NJUNC=0 + IF(K(I1,1).EQ.41) NJUNC=NJUNC+1 + IF(K(I1,1).EQ.41) GOTO 940 + IF(I1.GE.IC1-1.AND.I1.LE.IC2) THEN + I0=0 + ELSEIF(K(I1,1).EQ.2) THEN + IF(I0.EQ.0) I0=I1 + I2=I1 + 920 I2=I2+1 + IF(K(I2,1).EQ.41) GOTO 940 + IF(K(I2,1).GT.10) GOTO 920 + IF(KCHG(PYCOMP(K(I2,2)),2).EQ.0) GOTO 920 + IF(K(I1,2).EQ.21.AND.K(I2,2).NE.21.AND.K(I2,1).NE.1.AND. + & NJUNC.EQ.0) GOTO 940 + IF(K(I1,2).NE.21.AND.K(I2,2).EQ.21.AND.NJUNC.NE.0) GOTO 940 + IF(K(I1,2).NE.21.AND.K(I2,2).NE.21.AND.(I1.GT.I0.OR. + & K(I2,1).NE.1)) GOTO 940 + +C...Define velocity vectors e1, e2, ecl and differences e3, e4. + DO 930 J=1,3 + E1(J)=P(I1,J)/P(I1,4) + E2(J)=P(I2,J)/P(I2,4) + ECL(J)=P(N+1,J)/P(N+1,4) + E3(J)=E2(J)-E1(J) + E4(J)=ECL(J)-E1(J) + 930 CONTINUE + +C...Calculate minimal D=(e4-alpha*e3)**2 for 0 0: emit a 'gluon' (EN) + IF (P(N+1,5).GE.P(N+2,5)) THEN + +C...Construct 'gluon' that is needed to put hadron on the mass shell. + FRAC=P(N+2,5)/P(N+1,5) + DO 950 J=1,5 + P(N+2,J)=FRAC*P(N+1,J) + PG(J)=(1D0-FRAC)*P(N+1,J) + 950 CONTINUE + +C... Copy string with new gluon put in. + N=N+2 + I=IBEG-1 + 960 I=I+1 + IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 960 + IF(KCHG(PYCOMP(K(I,2)),2).EQ.0.AND.K(I,1).NE.41) GOTO 960 + N=N+1 + DO 970 J=1,5 + K(N,J)=K(I,J) + P(N,J)=P(I,J) + V(N,J)=V(I,J) + 970 CONTINUE + K(I,1)=K(I,1)+10 + K(I,4)=N + K(I,5)=N + K(N,3)=I + IF(I.EQ.IPCS) THEN + N=N+1 + DO 980 J=1,5 + K(N,J)=K(N-1,J) + P(N,J)=PG(J) + V(N,J)=V(N-1,J) + 980 CONTINUE + K(N,2)=21 + K(N,3)=NSAV+1 + ENDIF + IF(K(I,1).EQ.12.OR.K(I,1).EQ.51) GOTO 960 + GOTO 1120 + +C...Delta_m = m_clus - m_had < 0: have to absorb a 'gluon' instead, +C...from string piece endpoints. + ELSE + +C...Begin by copying string that should give energy to cluster. + N=N+2 + I=IBEG-1 + 990 I=I+1 + IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 990 + IF(KCHG(PYCOMP(K(I,2)),2).EQ.0.AND.K(I,1).NE.41) GOTO 990 + N=N+1 + DO 1000 J=1,5 + K(N,J)=K(I,J) + P(N,J)=P(I,J) + V(N,J)=V(I,J) + 1000 CONTINUE + K(I,1)=K(I,1)+10 + K(I,4)=N + K(I,5)=N + K(N,3)=I + IF(I.EQ.IPCS) I1=N + IF(K(I,1).EQ.12.OR.K(I,1).EQ.51) GOTO 990 + I2=I1+1 + +C...Set initial Phad. + DO 1010 J=1,4 + P(NSAV+2,J)=P(NSAV+1,J) + 1010 CONTINUE + +C...Calculate Pg, a part of which will be added to Phad later. (EN) + 1020 IF(MSTJ(16).EQ.1) THEN + ALPHA=1D0 + BETA=1D0 + ELSE + ALPHA=FOUR(NSAV+1,I2)/FOUR(I1,I2) + BETA=FOUR(NSAV+1,I1)/FOUR(I1,I2) + ENDIF + DO 1030 J=1,4 + PG(J)=ALPHA*P(I1,J)+BETA*P(I2,J) + 1030 CONTINUE + PG(5)=SQRT(MAX(1D-20,PG(4)**2-PG(1)**2-PG(2)**2-PG(3)**2)) + +C..Solve 2nd order equation, use the best (smallest) solution. (EN) + PMSCOL=P(NSAV+2,4)**2-P(NSAV+2,1)**2-P(NSAV+2,2)**2- + & P(NSAV+2,3)**2 + PCLPG=(P(NSAV+2,4)*PG(4)-P(NSAV+2,1)*PG(1)- + & P(NSAV+2,2)*PG(2)-P(NSAV+2,3)*PG(3))/PG(5)**2 + DELTA=SQRT(PCLPG**2+(P(NSAV+2,5)**2-PMSCOL)/PG(5)**2)-PCLPG + +C...If all gluon energy eaten, zero it and take a step back. + ITER=0 + IF(DELTA*ALPHA.GT.1D0.AND.I1.GT.NSAV+3.AND.K(I1,2).EQ.21) THEN + ITER=1 + DO 1040 J=1,4 + P(NSAV+2,J)=P(NSAV+2,J)+P(I1,J) + P(I1,J)=0D0 + 1040 CONTINUE + P(I1,5)=0D0 + K(I1,1)=K(I1,1)+10 + I1=I1-1 + IF(K(I1,1).EQ.41) ITER=-1 + ENDIF + IF(DELTA*BETA.GT.1D0.AND.I2.LT.N.AND.K(I2,2).EQ.21) THEN + ITER=1 + DO 1050 J=1,4 + P(NSAV+2,J)=P(NSAV+2,J)+P(I2,J) + P(I2,J)=0D0 + 1050 CONTINUE + P(I2,5)=0D0 + K(I2,1)=K(I2,1)+10 + I2=I2+1 + IF(K(I2,1).EQ.41) ITER=-1 + ENDIF + IF(ITER.EQ.1) GOTO 1020 + +C...If also all endpoint energy eaten, revert to old procedure. + IF((1D0-DELTA*ALPHA)*P(I1,4).LT.P(I1,5).OR. + & (1D0-DELTA*BETA)*P(I2,4).LT.P(I2,5).OR.ITER.EQ.-1) THEN + DO 1060 I=NSAV+3,N + IM=K(I,3) + K(IM,1)=K(IM,1)-10 + K(IM,4)=0 + K(IM,5)=0 + 1060 CONTINUE + N=NSAV + GOTO 1080 + ENDIF + +C... Construct the collapsed hadron and modified string partons. + DO 1070 J=1,4 + P(NSAV+2,J)=P(NSAV+2,J)+DELTA*PG(J) + P(I1,J)=(1D0-DELTA*ALPHA)*P(I1,J) + P(I2,J)=(1D0-DELTA*BETA)*P(I2,J) + 1070 CONTINUE + P(I1,5)=(1D0-DELTA*ALPHA)*P(I1,5) + P(I2,5)=(1D0-DELTA*BETA)*P(I2,5) + +C...Finished with string collapse in new scheme. + GOTO 1120 + ENDIF + +C... Use old algorithm; by choice or when in trouble. + 1080 CONTINUE +C...Find parton/particle which combines to largest extra mass. + IR=0 + HA=0D0 + HSM=0D0 + DO 1100 MCOMB=1,3 + IF(IR.NE.0) GOTO 1100 + DO 1090 I=MAX(1,IP),N + IF(K(I,1).LE.0.OR.K(I,1).GT.10.OR.(I.GE.IC1.AND.I.LE.IC2 + & .AND.K(I,1).GE.1.AND.K(I,1).LE.2)) GOTO 1090 + IF(MCOMB.EQ.1) KCI=PYCOMP(K(I,2)) + IF(MCOMB.EQ.1.AND.KCI.EQ.0) GOTO 1090 + IF(MCOMB.EQ.1.AND.KCHG(KCI,2).EQ.0.AND.I.LE.NS) GOTO 1090 + IF(MCOMB.EQ.2.AND.IABS(K(I,2)).GT.10.AND.IABS(K(I,2)).LE.100) + & GOTO 1090 + HCR=DPC(4)*P(I,4)-DPC(1)*P(I,1)-DPC(2)*P(I,2)-DPC(3)*P(I,3) + HSR=2D0*HCR+PECM**2-P(N+2,5)**2-2D0*P(N+2,5)*P(I,5) + IF(HSR.GT.HSM) THEN + IR=I + HA=HCR + HSM=HSR + ENDIF + 1090 CONTINUE + 1100 CONTINUE + +C...Shuffle energy and momentum to put new particle on mass shell. + IF(IR.NE.0) THEN + HB=PECM**2+HA + HC=P(N+2,5)**2+HA + HD=P(IR,5)**2+HA + HK2=0.5D0*(HB*SQRT(MAX(0D0,((HB+HC)**2-4D0*(HB+HD)*P(N+2,5)**2)/ + & (HA**2-(PECM*P(IR,5))**2)))-(HB+HC))/(HB+HD) + HK1=(0.5D0*(P(N+2,5)**2-PECM**2)+HD*HK2)/HB + DO 1110 J=1,4 + P(N+2,J)=(1D0+HK1)*DPC(J)-HK2*P(IR,J) + P(IR,J)=(1D0+HK2)*P(IR,J)-HK1*DPC(J) + 1110 CONTINUE + N=N+2 + ELSE + CALL PYERRM(3,'(PYPREP:) no match for collapsing cluster') + RETURN + ENDIF + +C...Mark collapsed system and store daughter pointers. Iterate. + 1120 DO 1130 I=IC1,IC2 + IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND. + & KCHG(PYCOMP(K(I,2)),2).NE.0) THEN + K(I,1)=K(I,1)+10 + IF(MSTU(16).NE.2) THEN + K(I,4)=NSAV+1 + K(I,5)=NSAV+1 + ELSE + K(I,4)=NSAV+2 + K(I,5)=NSAV+1+NBODY + ENDIF + ENDIF + IF(K(I,1).EQ.41) K(I,1)=K(I,1)+10 + 1130 CONTINUE + IF(N.LT.MSTU(4)-MSTU(32)-5) GOTO 710 + +C...Check flavours and invariant masses in parton systems. + 1140 NP=0 + KFN=0 + KQS=0 + NJU=0 + DO 1150 J=1,5 + DPS(J)=0D0 + 1150 CONTINUE + DO 1180 I=MAX(1,IP),N + IF(K(I,1).EQ.41) NJU=NJU+1 + IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 1180 + KC=PYCOMP(K(I,2)) + IF(KC.EQ.0) GOTO 1180 + KQ=KCHG(KC,2)*ISIGN(1,K(I,2)) + IF(KQ.EQ.0) GOTO 1180 + NP=NP+1 + IF(KQ.NE.2) THEN + KFN=KFN+1 + KQS=KQS+KQ + MSTJ(93)=1 + DPS(5)=DPS(5)+PYMASS(K(I,2)) + ENDIF + DO 1160 J=1,4 + DPS(J)=DPS(J)+P(I,J) + 1160 CONTINUE + IF(K(I,1).EQ.1) THEN + NFERR=0 + IF(NJU.EQ.0.AND.NP.NE.1) THEN + IF(KFN.EQ.1.OR.KFN.GE.3.OR.KQS.NE.0) NFERR=1 + ELSEIF(NJU.EQ.1) THEN + IF(KFN.NE.3.OR.IABS(KQS).NE.3) NFERR=1 + ELSEIF(NJU.EQ.2) THEN + IF(KFN.NE.4.OR.KQS.NE.0) NFERR=1 + ELSEIF(NJU.GE.3) THEN + NFERR=1 + ENDIF + IF(NFERR.EQ.1) THEN + CALL PYERRM(2,'(PYPREP:) unphysical flavour combination') + MINT(51)=1 + RETURN + ENDIF + IF(NP.NE.1.AND.DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2.LT. + & (0.9D0*PARJ(32)+DPS(5))**2) CALL PYERRM(3, + & '(PYPREP:) too small mass in jet system') + NP=0 + KFN=0 + KQS=0 + NJU=0 + DO 1170 J=1,5 + DPS(J)=0D0 + 1170 CONTINUE + ENDIF + 1180 CONTINUE + + RETURN + END + +C********************************************************************* + +C...PYSTRF +C...Handles the fragmentation of an arbitrary colour singlet +C...jet system according to the Lund string fragmentation model. + + SUBROUTINE PYSTRF(IP) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ +C...Local arrays. All MOPS variables ends with MO + DIMENSION DPS(5),KFL(3),PMQ(3),PX(3),PY(3),GAM(3),IE(2),PR(2), + &IN(9),DHM(4),DHG(4),DP(5,5),IRANK(2),MJU(4),IJU(6),PJU(5,5), + &TJU(5),KFJH(2),NJS(2),KFJS(2),PJS(4,5),MSTU9T(8),PARU9T(8), + &INMO(9),PM2QMO(2),XTMO(2),EJSTR(2),IJUORI(2),IBARRK(2), + &PBST(3,5),TJUOLD(5) + +C...Function: four-product of two vectors. + FOUR(I,J)=P(I,4)*P(J,4)-P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3) + DFOUR(I,J)=DP(I,4)*DP(J,4)-DP(I,1)*DP(J,1)-DP(I,2)*DP(J,2)- + &DP(I,3)*DP(J,3) + +C...Reset counters. + MSTJ(91)=0 + NSAV=N + MSTU90=MSTU(90) + NP=0 + KQSUM=0 + DO 100 J=1,5 + DPS(J)=0D0 + 100 CONTINUE + MJU(1)=0 + MJU(2)=0 + NTRYFN=0 + IJUORI(1)=0 + IJUORI(2)=0 + +C...Identify parton system. + I=IP-1 + 110 I=I+1 + IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN + CALL PYERRM(12,'(PYSTRF:) failed to reconstruct jet system') + IF(MSTU(21).GE.1) RETURN + ENDIF + IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 110 + KC=PYCOMP(K(I,2)) + IF(KC.EQ.0) GOTO 110 + KQ=KCHG(KC,2)*ISIGN(1,K(I,2)) + IF(KQ.EQ.0.AND.K(I,1).NE.41) GOTO 110 + IF(N+5*NP+11.GT.MSTU(4)-MSTU(32)-5) THEN + CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS') + IF(MSTU(21).GE.1) RETURN + ENDIF + +C...Take copy of partons to be considered. Check flavour sum. + NP=NP+1 + DO 120 J=1,5 + K(N+NP,J)=K(I,J) + P(N+NP,J)=P(I,J) + IF(J.NE.4) DPS(J)=DPS(J)+P(I,J) + 120 CONTINUE + DPS(4)=DPS(4)+SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2) + K(N+NP,3)=I + IF(KQ.NE.2) KQSUM=KQSUM+KQ + IF(K(I,1).EQ.41) THEN + IF(MOD(KQSUM,2).EQ.0.AND.MJU(1).EQ.0) THEN + MJU(1)=N+NP + IJUORI(1)=I + ELSE + MJU(2)=N+NP + IJUORI(2)=I + ENDIF + ENDIF + IF(K(I,1).EQ.2.OR.K(I,1).EQ.41) GOTO 110 + IF(MOD(KQSUM,3).NE.0) THEN + CALL PYERRM(12,'(PYSTRF:) unphysical flavour combination') + IF(MSTU(21).GE.1) RETURN + ENDIF + IF(MJU(1).GT.0.OR.MJU(2).GT.0) MSTU(29)=1 + +C...Boost copied system to CM frame (for better numerical precision). + IF(ABS(DPS(3)).LT.0.99D0*DPS(4)) THEN + MBST=0 + MSTU(33)=1 + CALL PYROBO(N+1,N+NP,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4), + & -DPS(3)/DPS(4)) + ELSE + MBST=1 + HHBZ=SQRT(MAX(1D-6,DPS(4)+DPS(3))/MAX(1D-6,DPS(4)-DPS(3))) + DO 130 I=N+1,N+NP + HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2 + IF(P(I,3).GT.0D0) THEN + HHPEZ=MAX(1D-10,(P(I,4)+P(I,3))/HHBZ) + P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ) + P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ) + ELSE + HHPEZ=MAX(1D-10,(P(I,4)-P(I,3))*HHBZ) + P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ) + P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ) + ENDIF + 130 CONTINUE + ENDIF + +C...Search for very nearby partons that may be recombined. + NTRYR=0 + NTRYWR=0 + PARU12=PARU(12) + PARU13=PARU(13) + MJU(3)=MJU(1) + MJU(4)=MJU(2) + NR=NP + NRMIN=2 + IF(MJU(1).GT.0) NRMIN=NRMIN+2 + IF(MJU(2).GT.0) NRMIN=NRMIN+2 + 140 IF(NR.GT.NRMIN) THEN + PDRMIN=2D0*PARU12 + DO 150 I=N+1,N+NR + IF(I.EQ.N+NR.AND.IABS(K(N+1,2)).NE.21) GOTO 150 + I1=I+1 + IF(I.EQ.N+NR) I1=N+1 + IF(K(I,1).EQ.41.OR.K(I1,1).EQ.41) GOTO 150 + IF(MJU(1).NE.0.AND.I1.LT.MJU(1).AND.IABS(K(I1,2)).NE.21) + & GOTO 150 + IF(MJU(2).NE.0.AND.I.GT.MJU(2).AND.IABS(K(I,2)).NE.21) + & GOTO 150 + PAP=SQRT((P(I,1)**2+P(I,2)**2+P(I,3)**2)*(P(I1,1)**2+ + & P(I1,2)**2+P(I1,3)**2)) + PVP=P(I,1)*P(I1,1)+P(I,2)*P(I1,2)+P(I,3)*P(I1,3) + PDR=4D0*(PAP-PVP)**2/MAX(1D-6,PARU13**2*PAP+2D0*(PAP-PVP)) + IF(PDR.LT.PDRMIN) THEN + IR=I + PDRMIN=PDR + ENDIF + 150 CONTINUE + +C...Recombine very nearby partons to avoid machine precision problems. + IF(PDRMIN.LT.PARU12.AND.IR.EQ.N+NR) THEN + DO 160 J=1,4 + P(N+1,J)=P(N+1,J)+P(N+NR,J) + 160 CONTINUE + P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2- + & P(N+1,3)**2)) + NR=NR-1 + GOTO 140 + ELSEIF(PDRMIN.LT.PARU12) THEN + DO 170 J=1,4 + P(IR,J)=P(IR,J)+P(IR+1,J) + 170 CONTINUE + P(IR,5)=SQRT(MAX(0D0,P(IR,4)**2-P(IR,1)**2-P(IR,2)**2- + & P(IR,3)**2)) + IF(MJU(2).NE.0.AND.IR.GT.MJU(2)) K(IR,2)=K(IR+1,2) + DO 190 I=IR+1,N+NR-1 + K(I,1)=K(I+1,1) + K(I,2)=K(I+1,2) + DO 180 J=1,5 + P(I,J)=P(I+1,J) + 180 CONTINUE + 190 CONTINUE + IF(IR.EQ.N+NR-1) K(IR,2)=K(N+NR,2) + NR=NR-1 + IF(MJU(1).GT.IR) MJU(1)=MJU(1)-1 + IF(MJU(2).GT.IR) MJU(2)=MJU(2)-1 + GOTO 140 + ENDIF + ENDIF + NTRYR=NTRYR+1 + +C...Reset particle counter. Skip ahead if no junctions are present; +C...this is usually the case! + NRS=MAX(5*NR+11,NP) + NTRY=0 + 200 NTRY=NTRY+1 + IF(NTRY.GT.100.AND.NTRYR.LE.8.AND.NR.GT.NRMIN) THEN + PARU12=4D0*PARU12 + PARU13=2D0*PARU13 + GOTO 140 + ELSEIF(NTRY.GT.100.OR.NTRYR.GT.100) THEN + CALL PYERRM(14,'(PYSTRF:) caught in infinite loop') + IF(MSTU(21).GE.1) RETURN + ENDIF + I=N+NRS + MSTU(90)=MSTU90 + IF(MJU(1).EQ.0.AND.MJU(2).EQ.0) GOTO 650 + IF(MSTJ(12).GE.4) CALL PYERRM(29,'(PYSTRF:) sorry,'// + & ' junction strings not handled by MSTJ(12)>3 options') + DO 640 JT=1,2 + NJS(JT)=0 + IF(MJU(JT).EQ.0) GOTO 640 + JS=3-2*JT + +C++SKANDS +C...Find and sum up momentum on three sides of junction. +C...Begin with previous boost = zero. + IJRFIT=0 + DO 210 IX=1,3 + TJUOLD(IX)=0D0 + 210 CONTINUE +C...Prevent IJU (specifically IJU(5)) from containing junk below + DO 215 IU=1,6 + IJU(IU)=0 + 215 CONTINUE + TJUOLD(4)=1D0 + 220 IU=0 +C...Beginning and end of string system in event record. + I1BEG=N+1+(JT-1)*(NR-1) + I1END=N+NR+(JT-1)*(1-NR) +C...Look for junction string piece end points + DO 230 I1=I1BEG,I1END,JS + IF(K(I1,2).NE.21.AND.IU.LE.5.AND.IJRFIT.EQ.0) THEN +C...Store junction string piece end points. +C 1-junction systems 2-junction systems +C IU : 1 2 3 4 1 2 3 4 5 6 +C IJU(IU): q-g-g-q-g-g-j-g-q q-g-g-q-g-j-g-g-j-g-q-g-g-q + IU=IU+1 + IJU(IU)=I1 + ENDIF +C...Sum over momenta, from junction outwards. + 230 CONTINUE + DO 280 IU=1,3 + PWT=0D0 +C...Initialize junction drag and string piece 4-vectors. + DO 240 J=1,5 + PBST(IU,J)=0D0 + PJU(IU,J)=0D0 + 240 CONTINUE +C...First two branches. Inwards out means opposite direction to JS. +C...(JS is 1 for JT=1, -1 for JT=2) + IF (IU.LT.3) THEN + I1A=IJU(IU+1)-JS + I1B=IJU(IU) + IDIR=-JS +C...Last branch (gq or gjgqgq). Direction now reversed. + ELSE + I1A=IJU(IU)+JS + I1B=I1END + IDIR=JS + ENDIF + DO 270 I1=I1A,I1B,IDIR +C...Sum up momentum directions with exponential suppression +C...for use in finding junction rest frame below. + IF (K(I1,2).EQ.88) THEN +C...gjgqgq type system encountered. Use current PWT as start +C...for both strings. + PWTOLD=PWT + ELSE + IF (I1.EQ.IJU(5)+IDIR) PWT=PWTOLD +C...Sum up string piece (boosted) 4-momenta. + DO 250 J=1,4 + PJU(IU,J)=PJU(IU,J)+P(I1,J) + 250 CONTINUE +C...Compute "junction drag" vectors from (boosted) 4-momenta (initial +C...boost is zero, see above). Skip parton if suppression factor large. + IF (PWT.GT.10D0) GOTO 270 +C...Compute momentum in current frame: + TDP=TJUOLD(1)*P(I1,1)+TJUOLD(2)*P(I1,2)+TJUOLD(3)*P(I1,3) + BFC=TDP/(1D0+TJUOLD(4))+P(I1,4) + DO 260 J=1,3 + PTMP=P(I1,J)+TJUOLD(J)*BFC + PBST(IU,J)=PBST(IU,J)+PTMP*EXP(-PWT) + 260 CONTINUE +C...Boosted energy + PTMP=TJUOLD(4)*P(I1,4)+TDP + PBST(IU,4)=PBST(IU,J)+PTMP*EXP(-PWT) + PWT=PWT+PTMP/PARJ(48) + ENDIF + 270 CONTINUE +C...Put |p| rather than m in 5th slot. + PBST(IU,5)=SQRT(PBST(IU,1)**2+PBST(IU,2)**2+PBST(IU,3)**2) + PJU(IU,5)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+PJU(IU,3)**2) + 280 CONTINUE + +C...Calculate boost from present frame to next JRF candidate. + IJRFIT=IJRFIT+1 + CALL PYJURF(PBST,TJU) + +C...After some iterations do not take full step in new direction. + IF(IJRFIT.GT.5) THEN + REDUCE=0.8D0**(IJRFIT-5) + TJU(1)=REDUCE*TJU(1) + TJU(2)=REDUCE*TJU(2) + TJU(3)=REDUCE*TJU(3) + TJU(4)=SQRT(1D0+TJU(1)**2+TJU(2)**2+TJU(3)**2) + ENDIF + +C...Combine new boost (TJU) with old boost (TJUOLD) + TMP=TJU(1)*TJUOLD(1)+TJU(2)*TJUOLD(2)+TJU(3)*TJUOLD(3) + DO 290 IX=1,3 + TJUOLD(IX)=TJU(IX)+TJUOLD(IX)*(TMP/(1D0+TJUOLD(4))+TJU(4)) + 290 CONTINUE + TJUOLD(4)=SQRT(1D0+TJUOLD(1)**2+TJUOLD(2)**2+TJUOLD(3)**2) + +C...If last boost small, accept JRF, else iterate. +C...Also prevent possibility of infinite loop. + IF (ABS((TJU(4)-1D0)/TJUOLD(4)).GT.0.01D0.AND. + & IJRFIT.LT.MSTJ(18)) THEN + GOTO 220 + ELSEIF (IJRFIT.GE.MSTJ(18)) THEN + CALL PYERRM(1,'(PYSTRF:) failed to converge on JRF') + ENDIF + +C...Now store total boost in TJU and change perception. +C...TJUOLD = boost vector from CM of string syst -> JRF. Henceforth, +C...TJU = junction motion vector in string CM, so the sign changes. + DO 300 J=1,3 + TJU(J)=-TJUOLD(J) + 300 CONTINUE + TJU(4)=SQRT(1D0+TJU(1)**2+TJU(2)**2+TJU(3)**2) + +C--SKANDS + +C...Calculate string piece energies in junction rest frame. + DO 310 IU=1,3 + PJU(IU,5)=TJU(4)*PJU(IU,4)-TJU(1)*PJU(IU,1)-TJU(2)*PJU(IU,2)- + & TJU(3)*PJU(IU,3) + PBST(IU,5)=TJU(4)*PBST(IU,4)-TJU(1)*PBST(IU,1)- + & TJU(2)*PBST(IU,2)-TJU(3)*PBST(IU,3) + 310 CONTINUE + +C...Start preparing for fragmentation of two strings from junction. + ISTA=I + NTRYER=0 + 320 NTRYER=NTRYER+1 + I=ISTA + DO 620 IU=1,2 + NS=IABS(IJU(IU+1)-IJU(IU)) + +C...Junction strings: find longitudinal string directions. + DO 350 IS=1,NS + IS1=IJU(IU)+JS*(IS-1) + IS2=IJU(IU)+JS*IS + DO 330 J=1,5 + DP(1,J)=0.5D0*P(IS1,J) + IF(IS.EQ.1) DP(1,J)=P(IS1,J) + DP(2,J)=0.5D0*P(IS2,J) + IF(IS.EQ.NS) DP(2,J)=(-PBST(IU,J)+2D0*PBST(IU,5)*TJU(J))* + & (PJU(IU,5)/PBST(IU,5)) + 330 CONTINUE + IF(IS.EQ.NS) DP(2,5)=SQRT(MAX(0D0,PJU(IU,4)**2- + & PJU(IU,1)**2-PJU(IU,2)**2-PJU(IU,3)**2)) + DP(3,5)=DFOUR(1,1) + DP(4,5)=DFOUR(2,2) + DHKC=DFOUR(1,2) + IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) THEN + DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2) + DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2) + DP(3,5)=0D0 + DP(4,5)=0D0 + DHKC=DFOUR(1,2) + ENDIF + DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5)) + DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0) + DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0) + IN1=N+NR+4*IS-3 + P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5)) + DO 340 J=1,4 + P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J) + P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J) + 340 CONTINUE + 350 CONTINUE + +C...Junction strings: initialize flavour, momentum and starting pos. + ISAV=I + MSTU91=MSTU(90) + 360 NTRY=NTRY+1 + IF(NTRY.GT.100.AND.NTRYR.LE.8.AND.NR.GT.NRMIN) THEN + PARU12=4D0*PARU12 + PARU13=2D0*PARU13 + GOTO 140 + ELSEIF(NTRY.GT.100) THEN + CALL PYERRM(14,'(PYSTRF:) caught in infinite loop') + IF(MSTU(21).GE.1) RETURN + ENDIF + I=ISAV + MSTU(90)=MSTU91 + IRANKJ=0 + IE(1)=K(N+1+(JT/2)*(NP-1),3) + IF (MOD(JT+IU,2).NE.0) THEN + IE(1)=K(IJU(IU),3) + IF (NP-NR.NE.0) THEN +C...If gluons have disappeared. Original IJU must be used. + IT=IP + NE=1 + 370 IT=IT+1 + IF (K(IT,2).NE.21) THEN + NE=NE+1 + ENDIF + IF (NE.EQ.IU+4*(JT-1)) THEN + IE(1)=IT + ELSEIF (IT.LE.IP+NP) THEN + GOTO 370 + ELSE + CALL PYERRM(14,'(PYSTRF:) '// + & 'Original IJU could not be reconstructed!') + ENDIF + ENDIF + ENDIF + IN(4)=N+NR+1 + IN(5)=IN(4)+1 + IN(6)=N+NR+4*NS+1 + DO 390 JQ=1,2 + DO 380 IN1=N+NR+2+JQ,N+NR+4*NS-2+JQ,4 + P(IN1,1)=2-JQ + P(IN1,2)=JQ-1 + P(IN1,3)=1D0 + 380 CONTINUE + 390 CONTINUE + KFL(1)=K(IJU(IU),2) + PX(1)=0D0 + PY(1)=0D0 + GAM(1)=0D0 + DO 400 J=1,5 + PJU(IU+3,J)=0D0 + 400 CONTINUE + +C...Junction strings: find initial transverse directions. + DO 410 J=1,4 + DP(1,J)=P(IN(4),J) + DP(2,J)=P(IN(4)+1,J) + DP(3,J)=0D0 + DP(4,J)=0D0 + 410 CONTINUE + DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2) + DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2) + DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4) + DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4) + DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4) + IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0 + IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0 + IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0 + IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0 + DHC12=DFOUR(1,2) + DHCX1=DFOUR(3,1)/DHC12 + DHCX2=DFOUR(3,2)/DHC12 + DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12) + DHCY1=DFOUR(4,1)/DHC12 + DHCY2=DFOUR(4,2)/DHC12 + DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12 + DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2) + DO 420 J=1,4 + DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J)) + P(IN(6),J)=DP(3,J) + P(IN(6)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)- + & DHCYX*DP(3,J)) + 420 CONTINUE + +C...Junction strings: produce new particle, origin. + 430 I=I+1 + IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN + CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS') + IF(MSTU(21).GE.1) RETURN + ENDIF + IRANKJ=IRANKJ+1 + K(I,1)=1 + K(I,3)=IE(1) + K(I,4)=0 + K(I,5)=0 + +C...Junction strings: generate flavour, hadron, pT, z and Gamma. + 440 CALL PYKFDI(KFL(1),0,KFL(3),K(I,2)) + IF(K(I,2).EQ.0) GOTO 360 + IF(IRANKJ.EQ.1.AND.IABS(KFL(1)).LE.10.AND. + & IABS(KFL(3)).GT.10) THEN + IF(PYR(0).GT.PARJ(19)) GOTO 440 + ENDIF + P(I,5)=PYMASS(K(I,2)) + CALL PYPTDI(KFL(1),PX(3),PY(3)) + PR(1)=P(I,5)**2+(PX(1)+PX(3))**2+(PY(1)+PY(3))**2 + CALL PYZDIS(KFL(1),KFL(3),PR(1),Z) + IF(IABS(KFL(1)).GE.4.AND.IABS(KFL(1)).LE.8.AND. + & MSTU(90).LT.8) THEN + MSTU(90)=MSTU(90)+1 + MSTU(90+MSTU(90))=I + PARU(90+MSTU(90))=Z + ENDIF + GAM(3)=(1D0-Z)*(GAM(1)+PR(1)/Z) + DO 450 J=1,3 + IN(J)=IN(3+J) + 450 CONTINUE + +C...Junction strings: stepping within 'low' string region. + IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)* + & P(IN(1),5)**2.GE.PR(1)) THEN + P(IN(1)+2,4)=Z*P(IN(1)+2,3) + P(IN(2)+2,4)=PR(1)/(P(IN(1)+2,4)*P(IN(1),5)**2) + DO 460 J=1,4 + P(I,J)=(PX(1)+PX(3))*P(IN(3),J)+(PY(1)+PY(3))*P(IN(3)+1,J) + 460 CONTINUE + GOTO 560 +C...Has used up energy of junction string, i.e. no more hadrons in it. + ELSEIF(IN(1)+1.EQ.IN(2).AND.IN(1).EQ.N+NR+4*NS-3) THEN + DO 470 J=1,5 + P(I,J)=0D0 + 470 CONTINUE + GOTO 600 +C...Stepping from 'low' string region + ELSEIF(IN(1)+1.EQ.IN(2)) THEN + P(IN(2)+2,4)=P(IN(2)+2,3) + P(IN(2)+2,1)=1D0 + IN(2)=IN(2)+4 + IF(IN(2).GT.N+NR+4*NS) GOTO 360 + IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN + P(IN(1)+2,4)=P(IN(1)+2,3) + P(IN(1)+2,1)=0D0 + IN(1)=IN(1)+4 + ENDIF + ENDIF + +C...Junction strings: find new transverse directions. + 480 IF(IN(1).GT.N+NR+4*NS.OR.IN(2).GT.N+NR+4*NS.OR. + & IN(1).GT.IN(2)) GOTO 360 + IF(IN(1).NE.IN(4).OR.IN(2).NE.IN(5)) THEN + DO 490 J=1,4 + DP(1,J)=P(IN(1),J) + DP(2,J)=P(IN(2),J) + DP(3,J)=0D0 + DP(4,J)=0D0 + 490 CONTINUE + DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2) + DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2) + DHC12=DFOUR(1,2) + IF(DHC12.LE.1D-2) THEN + P(IN(1)+2,4)=P(IN(1)+2,3) + P(IN(1)+2,1)=0D0 + IN(1)=IN(1)+4 + GOTO 480 + ENDIF + IN(3)=N+NR+4*NS+5 + DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4) + DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4) + DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4) + IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0 + IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0 + IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0 + IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0 + DHCX1=DFOUR(3,1)/DHC12 + DHCX2=DFOUR(3,2)/DHC12 + DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12) + DHCY1=DFOUR(4,1)/DHC12 + DHCY2=DFOUR(4,2)/DHC12 + DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12 + DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2) + DO 500 J=1,4 + DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J)) + P(IN(3),J)=DP(3,J) + P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)- + & DHCYX*DP(3,J)) + 500 CONTINUE +C...Express pT with respect to new axes, if sensible. + PXP=-(PX(3)*FOUR(IN(6),IN(3))+PY(3)*FOUR(IN(6)+1,IN(3))) + PYP=-(PX(3)*FOUR(IN(6),IN(3)+1)+PY(3)*FOUR(IN(6)+1,IN(3)+1)) + IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN + PX(3)=PXP + PY(3)=PYP + ENDIF + ENDIF + +C...Junction strings: sum up known four-momentum, coefficients for m2. + DO 530 J=1,4 + DHG(J)=0D0 + P(I,J)=PX(1)*P(IN(6),J)+PY(1)*P(IN(6)+1,J)+PX(3)*P(IN(3),J)+ + & PY(3)*P(IN(3)+1,J) + DO 510 IN1=IN(4),IN(1)-4,4 + P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J) + 510 CONTINUE + DO 520 IN2=IN(5),IN(2)-4,4 + P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J) + 520 CONTINUE + 530 CONTINUE + DHM(1)=FOUR(I,I) + DHM(2)=2D0*FOUR(I,IN(1)) + DHM(3)=2D0*FOUR(I,IN(2)) + DHM(4)=2D0*FOUR(IN(1),IN(2)) + +C...Junction strings: find coefficients for Gamma expression. + DO 550 IN2=IN(1)+1,IN(2),4 + DO 540 IN1=IN(1),IN2-1,4 + DHC=2D0*FOUR(IN1,IN2) + DHG(1)=DHG(1)+P(IN1+2,1)*P(IN2+2,1)*DHC + IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-P(IN2+2,1)*DHC + IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+P(IN1+2,1)*DHC + IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC + 540 CONTINUE + 550 CONTINUE + +C...Junction strings: solve (m2, Gamma) equation system for energies. + DHS1=DHM(3)*DHG(4)-DHM(4)*DHG(3) + IF(ABS(DHS1).LT.1D-4) GOTO 360 + DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(2)*DHG(3)-DHG(4)* + & (P(I,5)**2-DHM(1))+DHG(2)*DHM(3) + DHS3=DHM(2)*(GAM(3)-DHG(1))-DHG(2)*(P(I,5)**2-DHM(1)) + P(IN(2)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/ + & ABS(DHS1)-DHS2/DHS1) + IF(DHM(2)+DHM(4)*P(IN(2)+2,4).LE.0D0) GOTO 360 + P(IN(1)+2,4)=(P(I,5)**2-DHM(1)-DHM(3)*P(IN(2)+2,4))/ + & (DHM(2)+DHM(4)*P(IN(2)+2,4)) + +C...Junction strings: step to new region if necessary. + IF(P(IN(2)+2,4).GT.P(IN(2)+2,3)) THEN + P(IN(2)+2,4)=P(IN(2)+2,3) + P(IN(2)+2,1)=1D0 + IN(2)=IN(2)+4 + IF(IN(2).GT.N+NR+4*NS) GOTO 360 + IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN + P(IN(1)+2,4)=P(IN(1)+2,3) + P(IN(1)+2,1)=0D0 + IN(1)=IN(1)+4 + ENDIF + GOTO 480 + ELSEIF(P(IN(1)+2,4).GT.P(IN(1)+2,3)) THEN + P(IN(1)+2,4)=P(IN(1)+2,3) + P(IN(1)+2,1)=0D0 + IN(1)=IN(1)+4 + GOTO 480 + ENDIF + +C...Junction strings: particle four-momentum, remainder, loop back. + 560 DO 570 J=1,4 + P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+ + & P(IN(2)+2,4)*P(IN(2),J) + PJU(IU+3,J)=PJU(IU+3,J)+P(I,J) + 570 CONTINUE + IF(P(I,4).LT.P(I,5)) GOTO 360 + PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)- + & TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3) + IF(PJU(IU+3,5).LT.PJU(IU,5)) THEN + KFL(1)=-KFL(3) + PX(1)=-PX(3) + PY(1)=-PY(3) + GAM(1)=GAM(3) + IF(IN(3).NE.IN(6)) THEN + DO 580 J=1,4 + P(IN(6),J)=P(IN(3),J) + P(IN(6)+1,J)=P(IN(3)+1,J) + 580 CONTINUE + ENDIF + DO 590 JQ=1,2 + IN(3+JQ)=IN(JQ) + P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4) + P(IN(JQ)+2,1)=P(IN(JQ)+2,1)-(3-2*JQ)*P(IN(JQ)+2,4) + 590 CONTINUE + GOTO 430 + ENDIF + +C...Junction strings: save quantities left after each string. + IF(IABS(KFL(1)).GT.10) GOTO 360 + 600 I=I-1 + KFJH(IU)=KFL(1) + DO 610 J=1,4 + PJU(IU+3,J)=PJU(IU+3,J)-P(I+1,J) + 610 CONTINUE + +C...Junction strings: loopback if much unused energy in both strings. + PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)- + & TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3) + EJSTR(IU)=PJU(IU,5)-PJU(IU+3,5) + 620 CONTINUE + IF((MIN(EJSTR(1),EJSTR(2)).GT.PARJ(49).OR. + & EJSTR(1).GT.PARJ(49)+PYR(0)*PARJ(50).OR. + & EJSTR(2).GT.PARJ(49)+PYR(0)*PARJ(50)) + & .AND.NTRYER.LT.10) GOTO 320 + +C...Junction strings: put together to new effective string endpoint. + NJS(JT)=I-ISTA + KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1 + IF(KFJH(1).EQ.KFJH(2)) KFLS=3 + KFJS(JT)=ISIGN(1000*MAX(IABS(KFJH(1)),IABS(KFJH(2)))+ + & 100*MIN(IABS(KFJH(1)),IABS(KFJH(2)))+KFLS,KFJH(1)) + DO 630 J=1,4 + PJS(JT,J)=PJU(1,J)+PJU(2,J)+P(MJU(JT),J) + PJS(JT+2,J)=PJU(4,J)+PJU(5,J) + 630 CONTINUE + PJS(JT,5)=SQRT(MAX(0D0,PJS(JT,4)**2-PJS(JT,1)**2-PJS(JT,2)**2- + & PJS(JT,3)**2)) + PJS(JT+2,5)=0D0 + 640 CONTINUE + +C...Open versus closed strings. Choose breakup region for latter. + 650 IF(MJU(1).NE.0.AND.MJU(2).NE.0) THEN + NS=MJU(2)-MJU(1) + NB=MJU(1)-N + ELSEIF(MJU(1).NE.0) THEN + NS=N+NR-MJU(1) + NB=MJU(1)-N + ELSEIF(MJU(2).NE.0) THEN + NS=MJU(2)-N + NB=1 + ELSEIF(IABS(K(N+1,2)).NE.21) THEN + NS=NR-1 + NB=1 + ELSE + NS=NR+1 + W2SUM=0D0 + DO 660 IS=1,NR + P(N+NR+IS,1)=0.5D0*FOUR(N+IS,N+IS+1-NR*(IS/NR)) + W2SUM=W2SUM+P(N+NR+IS,1) + 660 CONTINUE + W2RAN=PYR(0)*W2SUM + NB=0 + 670 NB=NB+1 + W2SUM=W2SUM-P(N+NR+NB,1) + IF(W2SUM.GT.W2RAN.AND.NB.LT.NR) GOTO 670 + ENDIF + +C...Find longitudinal string directions (i.e. lightlike four-vectors). + DO 700 IS=1,NS + IS1=N+IS+NB-1-NR*((IS+NB-2)/NR) + IS2=N+IS+NB-NR*((IS+NB-1)/NR) + DO 680 J=1,5 + DP(1,J)=P(IS1,J) + IF(IABS(K(IS1,2)).EQ.21) DP(1,J)=0.5D0*DP(1,J) + IF(IS1.EQ.MJU(1)) DP(1,J)=PJS(1,J)-PJS(3,J) + DP(2,J)=P(IS2,J) + IF(IABS(K(IS2,2)).EQ.21) DP(2,J)=0.5D0*DP(2,J) + IF(IS2.EQ.MJU(2)) DP(2,J)=PJS(2,J)-PJS(4,J) + 680 CONTINUE + IF(IS1.EQ.MJU(1)) DP(1,5)=SQRT(MAX(0D0,DP(1,4)**2-DP(1,1)**2- + & DP(1,2)**2-DP(1,3)**2)) + IF(IS2.EQ.MJU(2)) DP(2,5)=SQRT(MAX(0D0,DP(2,4)**2-DP(2,1)**2- + & DP(2,2)**2-DP(2,3)**2)) + DP(3,5)=DFOUR(1,1) + DP(4,5)=DFOUR(2,2) + DHKC=DFOUR(1,2) + IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) GOTO 200 + DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5)) + DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0) + DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0) + IN1=N+NR+4*IS-3 + P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5)) + DO 690 J=1,4 + P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J) + P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J) + 690 CONTINUE + 700 CONTINUE + +C...Begin initialization: sum up energy, set starting position. + ISAV=I + MSTU91=MSTU(90) + 710 NTRY=NTRY+1 + IF(NTRY.GT.100.AND.NTRYR.LE.8.AND.NR.GT.NRMIN) THEN + PARU12=4D0*PARU12 + PARU13=2D0*PARU13 + GOTO 140 + ELSEIF(NTRY.GT.100) THEN + CALL PYERRM(14,'(PYSTRF:) caught in infinite loop') + IF(MSTU(21).GE.1) RETURN + ENDIF + I=ISAV + MSTU(90)=MSTU91 + DO 730 J=1,4 + P(N+NRS,J)=0D0 + DO 720 IS=1,NR + P(N+NRS,J)=P(N+NRS,J)+P(N+IS,J) + 720 CONTINUE + 730 CONTINUE + DO 750 JT=1,2 + IRANK(JT)=0 + IF(MJU(JT).NE.0) IRANK(JT)=NJS(JT) + IF(NS.GT.NR) IRANK(JT)=1 + IBARRK(JT)=0 + IE(JT)=K(N+1+(JT/2)*(NP-1),3) + IN(3*JT+1)=N+NR+1+4*(JT/2)*(NS-1) + IN(3*JT+2)=IN(3*JT+1)+1 + IN(3*JT+3)=N+NR+4*NS+2*JT-1 + DO 740 IN1=N+NR+2+JT,N+NR+4*NS-2+JT,4 + P(IN1,1)=2-JT + P(IN1,2)=JT-1 + P(IN1,3)=1D0 + 740 CONTINUE + 750 CONTINUE + +C.. MOPS variables and switches + NRVMO=0 + XBMO=1D0 + MSTU(121)=0 + MSTU(122)=0 + +C...Initialize flavour and pT variables for open string. + IF(NS.LT.NR) THEN + PX(1)=0D0 + PY(1)=0D0 + IF(NS.EQ.1.AND.MJU(1)+MJU(2).EQ.0) CALL PYPTDI(0,PX(1),PY(1)) + PX(2)=-PX(1) + PY(2)=-PY(1) + DO 760 JT=1,2 + KFL(JT)=K(IE(JT),2) + IF(MJU(JT).NE.0) KFL(JT)=KFJS(JT) + IF(MJU(JT).NE.0.AND.IABS(KFL(JT)).GT.1000) IBARRK(JT)=1 + MSTJ(93)=1 + PMQ(JT)=PYMASS(KFL(JT)) + GAM(JT)=0D0 + 760 CONTINUE + +C...Closed string: random initial breakup flavour, pT and vertex. + ELSE + KFL(3)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0) + IBMO=0 + 770 CALL PYKFDI(KFL(3),0,KFL(1),KDUMP) +C.. Closed string: first vertex diq attempt => enforced second +C.. vertex diq + IF(IABS(KFL(1)).GT.10)THEN + IBMO=1 + MSTU(121)=0 + GOTO 770 + ENDIF + IF(IBMO.EQ.1) MSTU(121)=-1 + KFL(2)=-KFL(1) + CALL PYPTDI(KFL(1),PX(1),PY(1)) + PX(2)=-PX(1) + PY(2)=-PY(1) + PR3=MIN(25D0,0.1D0*P(N+NR+1,5)**2) + 780 CALL PYZDIS(KFL(1),KFL(2),PR3,Z) + ZR=PR3/(Z*P(N+NR+1,5)**2) + IF(ZR.GE.1D0) GOTO 780 + DO 790 JT=1,2 + MSTJ(93)=1 + PMQ(JT)=PYMASS(KFL(JT)) + GAM(JT)=PR3*(1D0-Z)/Z + IN1=N+NR+3+4*(JT/2)*(NS-1) + P(IN1,JT)=1D0-Z + P(IN1,3-JT)=JT-1 + P(IN1,3)=(2-JT)*(1D0-Z)+(JT-1)*Z + P(IN1+1,JT)=ZR + P(IN1+1,3-JT)=2-JT + P(IN1+1,3)=(2-JT)*(1D0-ZR)+(JT-1)*ZR + 790 CONTINUE + ENDIF +C.. MOPS variables + DO 800 JT=1,2 + XTMO(JT)=1D0 + PM2QMO(JT)=PMQ(JT)**2 + IF(IABS(KFL(JT)).GT.10) PM2QMO(JT)=0D0 + 800 CONTINUE + +C...Find initial transverse directions (i.e. spacelike four-vectors). + DO 840 JT=1,2 + IF(JT.EQ.1.OR.NS.EQ.NR-1.OR.MJU(1)+MJU(2).NE.0) THEN + IN1=IN(3*JT+1) + IN3=IN(3*JT+3) + DO 810 J=1,4 + DP(1,J)=P(IN1,J) + DP(2,J)=P(IN1+1,J) + DP(3,J)=0D0 + DP(4,J)=0D0 + 810 CONTINUE + DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2) + DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2) + DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4) + DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4) + DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4) + IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0 + IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0 + IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0 + IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0 + DHC12=DFOUR(1,2) + DHCX1=DFOUR(3,1)/DHC12 + DHCX2=DFOUR(3,2)/DHC12 + DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12) + DHCY1=DFOUR(4,1)/DHC12 + DHCY2=DFOUR(4,2)/DHC12 + DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12 + DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2) + DO 820 J=1,4 + DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J)) + P(IN3,J)=DP(3,J) + P(IN3+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)- + & DHCYX*DP(3,J)) + 820 CONTINUE + ELSE + DO 830 J=1,4 + P(IN3+2,J)=P(IN3,J) + P(IN3+3,J)=P(IN3+1,J) + 830 CONTINUE + ENDIF + 840 CONTINUE + +C...Remove energy used up in junction string fragmentation. + IF(MJU(1)+MJU(2).GT.0) THEN + DO 860 JT=1,2 + IF(NJS(JT).EQ.0) GOTO 860 + DO 850 J=1,4 + P(N+NRS,J)=P(N+NRS,J)-PJS(JT+2,J) + 850 CONTINUE + 860 CONTINUE + PARJST=PARJ(33) + IF(MSTJ(11).EQ.2) PARJST=PARJ(34) + WMIN=PARJST+PMQ(1)+PMQ(2) + WREM2=FOUR(N+NRS,N+NRS) + IF(P(N+NRS,4).LT.0D0.OR.WREM2.LT.WMIN**2) THEN + NTRYWR=NTRYWR+1 + IF(MOD(NTRYWR,20).NE.0) NTRYR=NTRYR-1 + GOTO 140 + ENDIF + ENDIF + +C...Produce new particle: side, origin. + 870 I=I+1 + IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN + CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS') + IF(MSTU(21).GE.1) RETURN + ENDIF +C.. New side priority for popcorn systems + IF(MSTU(121).LE.0)THEN + JT=1.5D0+PYR(0) + IF(IABS(KFL(3-JT)).GT.10) JT=3-JT + IF(IABS(KFL(3-JT)).GE.4.AND.IABS(KFL(3-JT)).LE.8) JT=3-JT + ENDIF + JR=3-JT + JS=3-2*JT + IRANK(JT)=IRANK(JT)+1 + K(I,1)=1 + K(I,4)=0 + K(I,5)=0 + +C...Generate flavour, hadron and pT. + 880 K(I,3)=IE(JT) + CALL PYKFDI(KFL(JT),0,KFL(3),K(I,2)) + IF(K(I,2).EQ.0) GOTO 710 + MU90MO=MSTU(90) + IF(MSTU(121).EQ.-1) GOTO 910 + IF(IRANK(JT).EQ.1.AND.IABS(KFL(JT)).LE.10.AND. + &IABS(KFL(3)).GT.10) THEN + IF(PYR(0).GT.PARJ(19)) GOTO 880 + ENDIF + IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000) + &K(I,3)=IJUORI(JT) + P(I,5)=PYMASS(K(I,2)) + CALL PYPTDI(KFL(JT),PX(3),PY(3)) + PR(JT)=P(I,5)**2+(PX(JT)+PX(3))**2+(PY(JT)+PY(3))**2 + +C...Final hadrons for small invariant mass. + MSTJ(93)=1 + PMQ(3)=PYMASS(KFL(3)) + PARJST=PARJ(33) + IF(MSTJ(11).EQ.2) PARJST=PARJ(34) + WMIN=PARJST+PMQ(1)+PMQ(2)+PARJ(36)*PMQ(3) + IF(IABS(KFL(JT)).GT.10.AND.IABS(KFL(3)).GT.10) WMIN= + &WMIN-0.5D0*PARJ(36)*PMQ(3) + WREM2=FOUR(N+NRS,N+NRS) + IF(WREM2.LT.0.10D0) GOTO 710 + IF(WREM2.LT.MAX(WMIN*(1D0+(2D0*PYR(0)-1D0)*PARJ(37)), + &PARJ(32)+PMQ(1)+PMQ(2))**2) GOTO 1080 + +C...Choose z, which gives Gamma. Shift z for heavy flavours. + CALL PYZDIS(KFL(JT),KFL(3),PR(JT),Z) + IF(IABS(KFL(JT)).GE.4.AND.IABS(KFL(JT)).LE.8.AND. + &MSTU(90).LT.8) THEN + MSTU(90)=MSTU(90)+1 + MSTU(90+MSTU(90))=I + PARU(90+MSTU(90))=Z + ENDIF + KFL1A=IABS(KFL(1)) + KFL2A=IABS(KFL(2)) + IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10), + &MOD(KFL2A/1000,10)).GE.4) THEN + PR(JR)=(PMQ(JR)+PMQ(3))**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2 + PW12=SQRT(MAX(0D0,(WREM2-PR(1)-PR(2))**2-4D0*PR(1)*PR(2))) + Z=(WREM2+PR(JT)-PR(JR)+PW12*(2D0*Z-1D0))/(2D0*WREM2) + PR(JR)=(PMQ(JR)+PARJST)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2 + IF((1D0-Z)*(WREM2-PR(JT)/Z).LT.PR(JR)) GOTO 1080 + ENDIF + GAM(3)=(1D0-Z)*(GAM(JT)+PR(JT)/Z) + +C.. MOPS baryon model modification + XTMO3=(1D0-Z)*XTMO(JT) + IF(IABS(KFL(3)).LE.10) NRVMO=0 + IF(IABS(KFL(3)).GT.10.AND.MSTJ(12).GE.4) THEN + GTSTMO=1D0 + PTSTMO=1D0 + RTSTMO=PYR(0) + IF(IABS(KFL(JT)).LE.10)THEN + XBMO=MIN(XTMO3,1D0-(2D-10)) + GBMO=GAM(3) + PMMO=0D0 + PGMO=GBMO+LOG(1D0-XBMO)*PM2QMO(JT) + GTSTMO=1D0-PARF(192)**PGMO + ELSE + IF(IRANK(JT).EQ.1) THEN + GBMO=GAM(JT) + PMMO=0D0 + XBMO=1D0 + ENDIF + IF(XBMO.LT.1D0-(1D-10))THEN + PGNMO=GBMO*XTMO3/XBMO+PM2QMO(JT)*LOG(1D0-XTMO3) + GTSTMO=(1D0-PARF(192)**PGNMO)/(1D0-PARF(192)**PGMO) + PGMO=PGNMO + ENDIF + IF(MSTJ(12).GE.5)THEN + PMNMO=SQRT((XBMO-XTMO3)*(GAM(3)/XTMO3-GBMO/XBMO)) + PMMO=PMMO+PMAS(PYCOMP(K(I,2)),1)-PMAS(PYCOMP(K(I,2)),3) + PTSTMO=EXP((PMMO-PMNMO)*PARF(193)) + PMMO=PMNMO + ENDIF + ENDIF + +C.. MOPS Accepting popcorn system hadron. + IF(PTSTMO*GTSTMO.GT.RTSTMO) THEN + IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) THEN + NRVMO=I-N-NR + IF(I+NRVMO.GT.MSTU(4)-MSTU(32)-5) THEN + CALL PYERRM(11, + & '(PYSTRF:) no more memory left in PYJETS') + IF(MSTU(21).GE.1) RETURN + ENDIF + IMO=I + KFLMO=KFL(JT) + PMQMO=PMQ(JT) + PXMO=PX(JT) + PYMO=PY(JT) + GAMMO=GAM(JT) + IRMO=IRANK(JT) + XMO=XTMO(JT) + DO 900 J=1,9 + IF(J.LE.5) THEN + DO 890 LINE=1,I-N-NR + P(MSTU(4)-MSTU(32)-LINE,J)=P(N+NR+LINE,J) + K(MSTU(4)-MSTU(32)-LINE,J)=K(N+NR+LINE,J) + 890 CONTINUE + ENDIF + INMO(J)=IN(J) + 900 CONTINUE + ENDIF + ELSE +C..Reject popcorn system, flag=-1 if enforcing new one + MSTU(121)=-1 + IF(PTSTMO.GT.RTSTMO) MSTU(121)=-2 + ENDIF + ENDIF + + +C..Lift restoring string outside MOPS block + 910 IF(MSTU(121).LT.0) THEN + IF(MSTU(121).EQ.-2) MSTU(121)=0 + MSTU(90)=MU90MO + NRVMO=0 + IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) GOTO 880 + I=IMO + KFL(JT)=KFLMO + PMQ(JT)=PMQMO + PX(JT)=PXMO + PY(JT)=PYMO + GAM(JT)=GAMMO + IRANK(JT)=IRMO + XTMO(JT)=XMO + DO 930 J=1,9 + IF(J.LE.5) THEN + DO 920 LINE=1,I-N-NR + P(N+NR+LINE,J)=P(MSTU(4)-MSTU(32)-LINE,J) + K(N+NR+LINE,J)=K(MSTU(4)-MSTU(32)-LINE,J) + 920 CONTINUE + ENDIF + IN(J)=INMO(J) + 930 CONTINUE + GOTO 880 + ENDIF + XTMO(JT)=XTMO3 +C.. MOPS end of modification + + DO 940 J=1,3 + IN(J)=IN(3*JT+J) + 940 CONTINUE + +C...Stepping within or from 'low' string region easy. + IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)* + &P(IN(1),5)**2.GE.PR(JT)) THEN + P(IN(JT)+2,4)=Z*P(IN(JT)+2,3) + P(IN(JR)+2,4)=PR(JT)/(P(IN(JT)+2,4)*P(IN(1),5)**2) + DO 950 J=1,4 + P(I,J)=(PX(JT)+PX(3))*P(IN(3),J)+(PY(JT)+PY(3))*P(IN(3)+1,J) + 950 CONTINUE + GOTO 1040 + ELSEIF(IN(1)+1.EQ.IN(2)) THEN + P(IN(JR)+2,4)=P(IN(JR)+2,3) + P(IN(JR)+2,JT)=1D0 + IN(JR)=IN(JR)+4*JS + IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 710 + IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN + P(IN(JT)+2,4)=P(IN(JT)+2,3) + P(IN(JT)+2,JT)=0D0 + IN(JT)=IN(JT)+4*JS + ENDIF + ENDIF + +C...Find new transverse directions (i.e. spacelike string vectors). + 960 IF(JS*IN(1).GT.JS*IN(3*JR+1).OR.JS*IN(2).GT.JS*IN(3*JR+2).OR. + &IN(1).GT.IN(2)) GOTO 710 + IF(IN(1).NE.IN(3*JT+1).OR.IN(2).NE.IN(3*JT+2)) THEN + DO 970 J=1,4 + DP(1,J)=P(IN(1),J) + DP(2,J)=P(IN(2),J) + DP(3,J)=0D0 + DP(4,J)=0D0 + 970 CONTINUE + DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2) + DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2) + DHC12=DFOUR(1,2) + IF(DHC12.LE.1D-2) THEN + P(IN(JT)+2,4)=P(IN(JT)+2,3) + P(IN(JT)+2,JT)=0D0 + IN(JT)=IN(JT)+4*JS + GOTO 960 + ENDIF + IN(3)=N+NR+4*NS+5 + DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4) + DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4) + DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4) + IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0 + IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0 + IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0 + IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0 + DHCX1=DFOUR(3,1)/DHC12 + DHCX2=DFOUR(3,2)/DHC12 + DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12) + DHCY1=DFOUR(4,1)/DHC12 + DHCY2=DFOUR(4,2)/DHC12 + DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12 + DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2) + DO 980 J=1,4 + DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J)) + P(IN(3),J)=DP(3,J) + P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)- + & DHCYX*DP(3,J)) + 980 CONTINUE +C...Express pT with respect to new axes, if sensible. + PXP=-(PX(3)*FOUR(IN(3*JT+3),IN(3))+PY(3)* + & FOUR(IN(3*JT+3)+1,IN(3))) + PYP=-(PX(3)*FOUR(IN(3*JT+3),IN(3)+1)+PY(3)* + & FOUR(IN(3*JT+3)+1,IN(3)+1)) + IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN + PX(3)=PXP + PY(3)=PYP + ENDIF + ENDIF + +C...Sum up known four-momentum. Gives coefficients for m2 expression. + DO 1010 J=1,4 + DHG(J)=0D0 + P(I,J)=PX(JT)*P(IN(3*JT+3),J)+PY(JT)*P(IN(3*JT+3)+1,J)+ + & PX(3)*P(IN(3),J)+PY(3)*P(IN(3)+1,J) + DO 990 IN1=IN(3*JT+1),IN(1)-4*JS,4*JS + P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J) + 990 CONTINUE + DO 1000 IN2=IN(3*JT+2),IN(2)-4*JS,4*JS + P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J) + 1000 CONTINUE + 1010 CONTINUE + DHM(1)=FOUR(I,I) + DHM(2)=2D0*FOUR(I,IN(1)) + DHM(3)=2D0*FOUR(I,IN(2)) + DHM(4)=2D0*FOUR(IN(1),IN(2)) + +C...Find coefficients for Gamma expression. + DO 1030 IN2=IN(1)+1,IN(2),4 + DO 1020 IN1=IN(1),IN2-1,4 + DHC=2D0*FOUR(IN1,IN2) + DHG(1)=DHG(1)+P(IN1+2,JT)*P(IN2+2,JT)*DHC + IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-JS*P(IN2+2,JT)*DHC + IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+JS*P(IN1+2,JT)*DHC + IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC + 1020 CONTINUE + 1030 CONTINUE + +C...Solve (m2, Gamma) equation system for energies taken. + DHS1=DHM(JR+1)*DHG(4)-DHM(4)*DHG(JR+1) + IF(ABS(DHS1).LT.1D-4) GOTO 710 + DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(JT+1)*DHG(JR+1)-DHG(4)* + &(P(I,5)**2-DHM(1))+DHG(JT+1)*DHM(JR+1) + DHS3=DHM(JT+1)*(GAM(3)-DHG(1))-DHG(JT+1)*(P(I,5)**2-DHM(1)) + P(IN(JR)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/ + &ABS(DHS1)-DHS2/DHS1) + IF(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4).LE.0D0) GOTO 710 + P(IN(JT)+2,4)=(P(I,5)**2-DHM(1)-DHM(JR+1)*P(IN(JR)+2,4))/ + &(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4)) + +C...Step to new region if necessary. + IF(P(IN(JR)+2,4).GT.P(IN(JR)+2,3)) THEN + P(IN(JR)+2,4)=P(IN(JR)+2,3) + P(IN(JR)+2,JT)=1D0 + IN(JR)=IN(JR)+4*JS + IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 710 + IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN + P(IN(JT)+2,4)=P(IN(JT)+2,3) + P(IN(JT)+2,JT)=0D0 + IN(JT)=IN(JT)+4*JS + ENDIF + GOTO 960 + ELSEIF(P(IN(JT)+2,4).GT.P(IN(JT)+2,3)) THEN + P(IN(JT)+2,4)=P(IN(JT)+2,3) + P(IN(JT)+2,JT)=0D0 + IN(JT)=IN(JT)+4*JS + GOTO 960 + ENDIF + +C...Four-momentum of particle. Remaining quantities. Loop back. + 1040 DO 1050 J=1,4 + P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+P(IN(2)+2,4)*P(IN(2),J) + P(N+NRS,J)=P(N+NRS,J)-P(I,J) + 1050 CONTINUE + IF(P(IN(1)+2,4).GT.1D0+PARU(14).OR.P(IN(1)+2,4).LT.-PARU(14).OR. + &P(IN(2)+2,4).GT.1D0+PARU(14).OR.P(IN(2)+2,4).LT.-PARU(14)) + &GOTO 200 + IF(P(I,4).LT.P(I,5)) GOTO 710 + KFL(JT)=-KFL(3) + PMQ(JT)=PMQ(3) + PX(JT)=-PX(3) + PY(JT)=-PY(3) + GAM(JT)=GAM(3) + IF(IN(3).NE.IN(3*JT+3)) THEN + DO 1060 J=1,4 + P(IN(3*JT+3),J)=P(IN(3),J) + P(IN(3*JT+3)+1,J)=P(IN(3)+1,J) + 1060 CONTINUE + ENDIF + DO 1070 JQ=1,2 + IN(3*JT+JQ)=IN(JQ) + P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4) + P(IN(JQ)+2,JT)=P(IN(JQ)+2,JT)-JS*(3-2*JQ)*P(IN(JQ)+2,4) + 1070 CONTINUE + IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000) + &IBARRK(JT)=0 + GOTO 870 + +C...Final hadron: side, flavour, hadron, mass. + 1080 I=I+1 + K(I,1)=1 + K(I,3)=IE(JR) + K(I,4)=0 + K(I,5)=0 + CALL PYKFDI(KFL(JR),-KFL(3),KFLDMP,K(I,2)) + IF(K(I,2).EQ.0) GOTO 710 + IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I-1,2)),10000).GT.1000) + &IBARRK(JT)=0 + IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000) + &K(I,3)=IJUORI(JT) + IF(IBARRK(JR).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000) + &K(I,3)=IJUORI(JR) + P(I,5)=PYMASS(K(I,2)) + PR(JR)=P(I,5)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2 + +C...Final two hadrons: find common setup of four-vectors. + JQ=1 + IF(P(IN(4)+2,3)*P(IN(5)+2,3)*FOUR(IN(4),IN(5)).LT. + &P(IN(7)+2,3)*P(IN(8)+2,3)*FOUR(IN(7),IN(8))) JQ=2 + DHC12=FOUR(IN(3*JQ+1),IN(3*JQ+2)) + DHR1=FOUR(N+NRS,IN(3*JQ+2))/DHC12 + DHR2=FOUR(N+NRS,IN(3*JQ+1))/DHC12 + IF(IN(4).NE.IN(7).OR.IN(5).NE.IN(8)) THEN + PX(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3))-PX(JQ) + PY(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3)+1)-PY(JQ) + PR(3-JQ)=P(I+(JT+JQ-3)**2-1,5)**2+(PX(3-JQ)+(2*JQ-3)*JS* + & PX(3))**2+(PY(3-JQ)+(2*JQ-3)*JS*PY(3))**2 + ENDIF + +C...Solve kinematics for final two hadrons, if possible. + WREM2=2D0*DHR1*DHR2*DHC12 + FD=(SQRT(PR(1))+SQRT(PR(2)))/SQRT(WREM2) + IF(MJU(1)+MJU(2).NE.0.AND.I.EQ.ISAV+2.AND.FD.GE.1D0) GOTO 200 + IF(FD.GE.1D0) GOTO 710 + FA=WREM2+PR(JT)-PR(JR) + FB=SQRT(MAX(0D0,FA**2-4D0*WREM2*PR(JT))) + PREVCF=PARJ(42) + IF(MSTJ(11).EQ.2) PREVCF=PARJ(39) + PREV=1D0/(1D0+EXP(MIN(50D0,PREVCF*FB*PARJ(40)))) + FB=SIGN(FB,JS*(PYR(0)-PREV)) + KFL1A=IABS(KFL(1)) + KFL2A=IABS(KFL(2)) + IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10), + &MOD(KFL2A/1000,10)).GE.6) FB=SIGN(SQRT(MAX(0D0,FA**2- + &4D0*WREM2*PR(JT))),DBLE(JS)) + DO 1090 J=1,4 + P(I-1,J)=(PX(JT)+PX(3))*P(IN(3*JQ+3),J)+(PY(JT)+PY(3))* + & P(IN(3*JQ+3)+1,J)+0.5D0*(DHR1*(FA+FB)*P(IN(3*JQ+1),J)+ + & DHR2*(FA-FB)*P(IN(3*JQ+2),J))/WREM2 + P(I,J)=P(N+NRS,J)-P(I-1,J) + 1090 CONTINUE + IF(P(I-1,4).LT.P(I-1,5).OR.P(I,4).LT.P(I,5)) GOTO 710 + DM2F1=P(I-1,4)**2-P(I-1,1)**2-P(I-1,2)**2-P(I-1,3)**2-P(I-1,5)**2 + DM2F2=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2 + IF(DM2F1.GT.1D-10*P(I-1,4)**2.OR.DM2F2.GT.1D-10*P(I,4)**2) THEN + NTRYFN=NTRYFN+1 + IF(NTRYFN.LT.100) GOTO 140 + CALL PYERRM(13,'(PYSTRF:) bad energies for final two hadrons') + ENDIF + +C...Mark jets as fragmented and give daughter pointers. + N=I-NRS+1 + DO 1100 I=NSAV+1,NSAV+NP + IM=K(I,3) + K(IM,1)=K(IM,1)+10 + IF(MSTU(16).NE.2) THEN + K(IM,4)=NSAV+1 + K(IM,5)=NSAV+1 + ELSE + K(IM,4)=NSAV+2 + K(IM,5)=N + ENDIF + 1100 CONTINUE + +C...Document string system. Move up particles. + NSAV=NSAV+1 + K(NSAV,1)=11 + K(NSAV,2)=92 + K(NSAV,3)=IP + K(NSAV,4)=NSAV+1 + K(NSAV,5)=N + DO 1110 J=1,4 + P(NSAV,J)=DPS(J) + V(NSAV,J)=V(IP,J) + 1110 CONTINUE + P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2)) + V(NSAV,5)=0D0 + DO 1130 I=NSAV+1,N + DO 1120 J=1,5 + K(I,J)=K(I+NRS-1,J) + P(I,J)=P(I+NRS-1,J) + V(I,J)=0D0 + 1120 CONTINUE + 1130 CONTINUE + MSTU91=MSTU(90) + DO 1140 IZ=MSTU90+1,MSTU91 + MSTU9T(IZ)=MSTU(90+IZ)-NRS+1-NSAV+N + PARU9T(IZ)=PARU(90+IZ) + 1140 CONTINUE + MSTU(90)=MSTU90 + +C...Order particles in rank along the chain. Update mother pointer. + DO 1160 I=NSAV+1,N + DO 1150 J=1,5 + K(I-NSAV+N,J)=K(I,J) + P(I-NSAV+N,J)=P(I,J) + 1150 CONTINUE + 1160 CONTINUE + I1=NSAV + DO 1190 I=N+1,2*N-NSAV + IF(K(I,3).NE.IE(1).AND.K(I,3).NE.IJUORI(1)) GOTO 1190 + I1=I1+1 + DO 1170 J=1,5 + K(I1,J)=K(I,J) + P(I1,J)=P(I,J) + 1170 CONTINUE + IF(MSTU(16).NE.2) K(I1,3)=NSAV + DO 1180 IZ=MSTU90+1,MSTU91 + IF(MSTU9T(IZ).EQ.I) THEN + MSTU(90)=MSTU(90)+1 + MSTU(90+MSTU(90))=I1 + PARU(90+MSTU(90))=PARU9T(IZ) + ENDIF + 1180 CONTINUE + 1190 CONTINUE + DO 1220 I=2*N-NSAV,N+1,-1 + IF(K(I,3).EQ.IE(1).OR.K(I,3).EQ.IJUORI(1)) GOTO 1220 + I1=I1+1 + DO 1200 J=1,5 + K(I1,J)=K(I,J) + P(I1,J)=P(I,J) + 1200 CONTINUE + IF(MSTU(16).NE.2) K(I1,3)=NSAV + DO 1210 IZ=MSTU90+1,MSTU91 + IF(MSTU9T(IZ).EQ.I) THEN + MSTU(90)=MSTU(90)+1 + MSTU(90+MSTU(90))=I1 + PARU(90+MSTU(90))=PARU9T(IZ) + ENDIF + 1210 CONTINUE + 1220 CONTINUE + +C...Boost back particle system. Set production vertices. + IF(MBST.EQ.0) THEN + MSTU(33)=1 + CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4), + & DPS(3)/DPS(4)) + ELSE + DO 1230 I=NSAV+1,N + HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2 + IF(P(I,3).GT.0D0) THEN + HHPEZ=(P(I,4)+P(I,3))*HHBZ + P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ) + P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ) + ELSE + HHPEZ=(P(I,4)-P(I,3))/HHBZ + P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ) + P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ) + ENDIF + 1230 CONTINUE + ENDIF + DO 1250 I=NSAV+1,N + DO 1240 J=1,4 + V(I,J)=V(IP,J) + 1240 CONTINUE + 1250 CONTINUE + + RETURN + END + +C********************************************************************* + +C...PYJURF +C...From three given input vectors in PJU the boost VJU from +C...the "lab frame" to the junction rest frame is constructed. + + SUBROUTINE PYJURF(PJU,VJU) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + +C...Input, output and local arrays. + DIMENSION PJU(3,5),VJU(5),PSUM(5),A(3,3),PENEW(3),PCM(5,5) + DATA TWOPI/6.283186D0/ + +C...Calculate masses and other invariants. + DO 100 J=1,4 + PSUM(J)=PJU(1,J)+PJU(2,J)+PJU(3,J) + 100 CONTINUE + PSUM2=PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2 + PSUM(5)=SQRT(PSUM2) + DO 120 I=1,3 + DO 110 J=1,3 + A(I,J)=PJU(I,4)*PJU(J,4)-PJU(I,1)*PJU(J,1)- + & PJU(I,2)*PJU(J,2)-PJU(I,3)*PJU(J,3) + 110 CONTINUE + 120 CONTINUE + +C...Pick I to be most massive parton and J to be the one closest to I. + ITRY=0 + I=1 + IF(A(2,2).GT.A(1,1)) I=2 + IF(A(3,3).GT.MAX(A(1,1),A(2,2))) I=3 + 130 ITRY=ITRY+1 + J=1+MOD(I,3) + K=1+MOD(J,3) + IF(A(I,K)**2*A(J,J).LT.A(I,J)**2*A(K,K)) THEN + K=1+MOD(I,3) + J=1+MOD(K,3) + ENDIF + PMI2=A(I,I) + PMJ2=A(J,J) + PMK2=A(K,K) + AIJ=A(I,J) + AIK=A(I,K) + AJK=A(J,K) + +C...Trivial find new parton energies if all three partons are massless. + IF(PMI2.LT.1D-4) THEN + PEI=SQRT(2D0*AIK*AIJ/(3D0*AJK)) + PEJ=SQRT(2D0*AJK*AIJ/(3D0*AIK)) + PEK=SQRT(2D0*AIK*AJK/(3D0*AIJ)) + +C...Else find momentum range for parton I and values at extremes. + ELSE + PAIMIN=0D0 + PEIMIN=SQRT(PMI2) + PEJMIN=AIJ/PEIMIN + PEKMIN=AIK/PEIMIN + PAJMIN=SQRT(MAX(0D0,PEJMIN**2-PMJ2)) + PAKMIN=SQRT(MAX(0D0,PEKMIN**2-PMK2)) + FMIN=PEJMIN*PEKMIN+0.5D0*PAJMIN*PAKMIN-AJK + PEIMAX=(AIJ+AIK)/SQRT(PMJ2+PMK2+2D0*AJK) + IF(PMJ2.GT.1D-4) PEIMAX=AIJ/SQRT(PMJ2) + PAIMAX=SQRT(MAX(0D0,PEIMAX**2-PMI2)) + HI=PEIMAX**2-0.25D0*PAIMAX**2 + PAJMAX=(PEIMAX*SQRT(MAX(0D0,AIJ**2-PMJ2*HI))- + & 0.5D0*PAIMAX*AIJ)/HI + PAKMAX=(PEIMAX*SQRT(MAX(0D0,AIK**2-PMK2*HI))- + & 0.5D0*PAIMAX*AIK)/HI + PEJMAX=SQRT(PAJMAX**2+PMJ2) + PEKMAX=SQRT(PAKMAX**2+PMK2) + FMAX=PEJMAX*PEKMAX+0.5D0*PAJMAX*PAKMAX-AJK + +C...If unexpected values at upper endpoint then pick another parton. + IF(FMAX.GT.0D0.AND.ITRY.LE.2) THEN + I1=1+MOD(I,3) + IF(A(I1,I1).GE.1D-4) THEN + I=I1 + GOTO 130 + ENDIF + ITRY=ITRY+1 + I1=1+MOD(I,3) + IF(ITRY.LE.2.AND.A(I1,I1).GE.1D-4) THEN + I=I1 + GOTO 130 + ENDIF + ENDIF + +C..Start binary + linear search to find solution inside range. + ITER=0 + ITMIN=0 + ITMAX=0 + PAI=0.5D0*(PAIMIN+PAIMAX) + 140 ITER=ITER+1 + +C...Derive momentum of other two partons and distance to root. + PEI=SQRT(PAI**2+PMI2) + HI=PEI**2-0.25D0*PAI**2 + PAJ=(PEI*SQRT(MAX(0D0,AIJ**2-PMJ2*HI))-0.5D0*PAI*AIJ)/HI + PEJ=SQRT(PAJ**2+PMJ2) + PAK=(PEI*SQRT(MAX(0D0,AIK**2-PMK2*HI))-0.5D0*PAI*AIK)/HI + PEK=SQRT(PAK**2+PMK2) + FNOW=PEJ*PEK+0.5D0*PAJ*PAK-AJK + +C...Pick next I momentum to explore, hopefully closer to root. + IF(FNOW.GT.0D0) THEN + PAIMIN=PAI + FMIN=FNOW + ITMIN=ITMIN+1 + ELSE + PAIMAX=PAI + FMAX=FNOW + ITMAX=ITMAX+1 + ENDIF + IF((ITER.LT.10.OR.ITMIN.LE.1.OR.ITMAX.LE.1).AND.ITER.LT.20) + & THEN + PAI=0.5D0*(PAIMIN+PAIMAX) + GOTO 140 + ELSEIF(ITER.LT.40.AND.FMIN.GT.0D0.AND.FMAX.LT.0D0.AND. + & ABS(FNOW).GT.1D-12*PSUM2) THEN + PAI=PAIMIN+(PAIMAX-PAIMIN)*FMIN/(FMIN-FMAX) + GOTO 140 + ENDIF + ENDIF + +C...Now know energies in junction rest frame. + PENEW(I)=PEI + PENEW(J)=PEJ + PENEW(K)=PEK + +C...Boost (copy of) partons to their rest frame. + VXCM=-PSUM(1)/PSUM(5) + VYCM=-PSUM(2)/PSUM(5) + VZCM=-PSUM(3)/PSUM(5) + GAMCM=SQRT(1D0+VXCM**2+VYCM**2+VZCM**2) + DO 150 I=1,3 + FAC1=PJU(I,1)*VXCM+PJU(I,2)*VYCM+PJU(I,3)*VZCM + FAC2=FAC1/(1D0+GAMCM)+PJU(I,4) + PCM(I,1)=PJU(I,1)+FAC2*VXCM + PCM(I,2)=PJU(I,2)+FAC2*VYCM + PCM(I,3)=PJU(I,3)+FAC2*VZCM + PCM(I,4)=PJU(I,4)*GAMCM+FAC1 + PCM(I,5)=SQRT(PCM(I,1)**2+PCM(I,2)**2+PCM(I,3)**2) + 150 CONTINUE + +C...Construct difference vectors and boost to junction rest frame. + DO 160 J=1,3 + PCM(4,J)=PCM(1,J)/PCM(1,4)-PCM(2,J)/PCM(2,4) + PCM(5,J)=PCM(1,J)/PCM(1,4)-PCM(3,J)/PCM(3,4) + 160 CONTINUE + PCM(4,4)=PENEW(1)/PCM(1,4)-PENEW(2)/PCM(2,4) + PCM(5,4)=PENEW(1)/PCM(1,4)-PENEW(3)/PCM(3,4) + PCM4S=PCM(4,1)**2+PCM(4,2)**2+PCM(4,3)**2 + PCM5S=PCM(5,1)**2+PCM(5,2)**2+PCM(5,3)**2 + PCM45=PCM(4,1)*PCM(5,1)+PCM(4,2)*PCM(5,2)+PCM(4,3)*PCM(5,3) + C4=(PCM5S*PCM(4,4)-PCM45*PCM(5,4))/(PCM4S*PCM5S-PCM45**2) + C5=(PCM4S*PCM(5,4)-PCM45*PCM(4,4))/(PCM4S*PCM5S-PCM45**2) + VXJU=C4*PCM(4,1)+C5*PCM(5,1) + VYJU=C4*PCM(4,2)+C5*PCM(5,2) + VZJU=C4*PCM(4,3)+C5*PCM(5,3) + GAMJU=SQRT(1D0+VXJU**2+VYJU**2+VZJU**2) + +C...Add two boosts, giving final result. + FCM=(VXJU*VXCM+VYJU*VYCM+VZJU*VZCM)/(1+GAMCM)+GAMJU + VJU(1)=VXJU+FCM*VXCM + VJU(2)=VYJU+FCM*VYCM + VJU(3)=VZJU+FCM*VZCM + VJU(4)=SQRT(1D0+VJU(1)**2+VJU(2)**2+VJU(3)**2) + VJU(5)=1D0 + +C...In case of error in reconstruction: revert to CM frame of system. + CTH12=(PCM(1,1)*PCM(2,1)+PCM(1,2)*PCM(2,2)+PCM(1,3)*PCM(2,3))/ + &(PCM(1,5)*PCM(2,5)) + CTH13=(PCM(1,1)*PCM(3,1)+PCM(1,2)*PCM(3,2)+PCM(1,3)*PCM(3,3))/ + &(PCM(1,5)*PCM(3,5)) + CTH23=(PCM(2,1)*PCM(3,1)+PCM(2,2)*PCM(3,2)+PCM(2,3)*PCM(3,3))/ + &(PCM(2,5)*PCM(3,5)) + ERRCCM=(CTH12+0.5D0)**2+(CTH13+0.5D0)**2+(CTH23+0.5D0)**2 + ERRTCM=TWOPI-ACOS(CTH12)-ACOS(CTH13)-ACOS(CTH23) + DO 170 I=1,3 + FAC1=PJU(I,1)*VJU(1)+PJU(I,2)*VJU(2)+PJU(I,3)*VJU(3) + FAC2=FAC1/(1D0+VJU(4))+PJU(I,4) + PCM(I,1)=PJU(I,1)+FAC2*VJU(1) + PCM(I,2)=PJU(I,2)+FAC2*VJU(2) + PCM(I,3)=PJU(I,3)+FAC2*VJU(3) + PCM(I,4)=PJU(I,4)*VJU(4)+FAC1 + PCM(I,5)=SQRT(PCM(I,1)**2+PCM(I,2)**2+PCM(I,3)**2) + 170 CONTINUE + CTH12=(PCM(1,1)*PCM(2,1)+PCM(1,2)*PCM(2,2)+PCM(1,3)*PCM(2,3))/ + &(PCM(1,5)*PCM(2,5)) + CTH13=(PCM(1,1)*PCM(3,1)+PCM(1,2)*PCM(3,2)+PCM(1,3)*PCM(3,3))/ + &(PCM(1,5)*PCM(3,5)) + CTH23=(PCM(2,1)*PCM(3,1)+PCM(2,2)*PCM(3,2)+PCM(2,3)*PCM(3,3))/ + &(PCM(2,5)*PCM(3,5)) + ERRCJU=(CTH12+0.5D0)**2+(CTH13+0.5D0)**2+(CTH23+0.5D0)**2 + ERRTJU=TWOPI-ACOS(CTH12)-ACOS(CTH13)-ACOS(CTH23) + IF(ERRCJU+ERRTJU.GT.ERRCCM+ERRTCM) THEN + VJU(1)=VXCM + VJU(2)=VYCM + VJU(3)=VZCM + VJU(4)=GAMCM + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYINDF +C...Handles the fragmentation of a jet system (or a single +C...jet) according to independent fragmentation models. + + SUBROUTINE PYINDF(IP) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ +C...Local arrays. + DIMENSION DPS(5),PSI(4),NFI(3),NFL(3),IFET(3),KFLF(3), + &KFLO(2),PXO(2),PYO(2),WO(2) + +C.. MOPS error message + IF(MSTJ(12).GT.3) CALL PYERRM(9,'(PYINDF:) MSTJ(12)>3 options'// + &' are not treated as expected in independent fragmentation') + +C...Reset counters. Identify parton system and take copy. Check flavour. + NSAV=N + MSTU90=MSTU(90) + NJET=0 + KQSUM=0 + DO 100 J=1,5 + DPS(J)=0D0 + 100 CONTINUE + I=IP-1 + 110 I=I+1 + IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN + CALL PYERRM(12,'(PYINDF:) failed to reconstruct jet system') + IF(MSTU(21).GE.1) RETURN + ENDIF + IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 110 + KC=PYCOMP(K(I,2)) + IF(KC.EQ.0) GOTO 110 + KQ=KCHG(KC,2)*ISIGN(1,K(I,2)) + IF(KQ.EQ.0) GOTO 110 + NJET=NJET+1 + IF(KQ.NE.2) KQSUM=KQSUM+KQ + DO 120 J=1,5 + K(NSAV+NJET,J)=K(I,J) + P(NSAV+NJET,J)=P(I,J) + DPS(J)=DPS(J)+P(I,J) + 120 CONTINUE + K(NSAV+NJET,3)=I + IF(K(I,1).EQ.2.OR.(MSTJ(3).LE.5.AND.N.GT.I.AND. + &K(I+1,1).EQ.2)) GOTO 110 + IF(NJET.NE.1.AND.KQSUM.NE.0) THEN + CALL PYERRM(12,'(PYINDF:) unphysical flavour combination') + IF(MSTU(21).GE.1) RETURN + ENDIF + +C...Boost copied system to CM frame. Find CM energy and sum flavours. + IF(NJET.NE.1) THEN + MSTU(33)=1 + CALL PYROBO(NSAV+1,NSAV+NJET,0D0,0D0,-DPS(1)/DPS(4), + & -DPS(2)/DPS(4),-DPS(3)/DPS(4)) + ENDIF + PECM=0D0 + DO 130 J=1,3 + NFI(J)=0 + 130 CONTINUE + DO 140 I=NSAV+1,NSAV+NJET + PECM=PECM+P(I,4) + KFA=IABS(K(I,2)) + IF(KFA.LE.3) THEN + NFI(KFA)=NFI(KFA)+ISIGN(1,K(I,2)) + ELSEIF(KFA.GT.1000) THEN + KFLA=MOD(KFA/1000,10) + KFLB=MOD(KFA/100,10) + IF(KFLA.LE.3) NFI(KFLA)=NFI(KFLA)+ISIGN(1,K(I,2)) + IF(KFLB.LE.3) NFI(KFLB)=NFI(KFLB)+ISIGN(1,K(I,2)) + ENDIF + 140 CONTINUE + +C...Loop over attempts made. Reset counters. + NTRY=0 + 150 NTRY=NTRY+1 + IF(NTRY.GT.200) THEN + CALL PYERRM(14,'(PYINDF:) caught in infinite loop') + IF(MSTU(21).GE.1) RETURN + ENDIF + N=NSAV+NJET + MSTU(90)=MSTU90 + DO 160 J=1,3 + NFL(J)=NFI(J) + IFET(J)=0 + KFLF(J)=0 + 160 CONTINUE + +C...Loop over jets to be fragmented. + DO 230 IP1=NSAV+1,NSAV+NJET + MSTJ(91)=0 + NSAV1=N + MSTU91=MSTU(90) + +C...Initial flavour and momentum values. Jet along +z axis. + KFLH=IABS(K(IP1,2)) + IF(KFLH.GT.10) KFLH=MOD(KFLH/1000,10) + KFLO(2)=0 + WF=P(IP1,4)+SQRT(P(IP1,1)**2+P(IP1,2)**2+P(IP1,3)**2) + +C...Initial values for quark or diquark jet. + 170 IF(IABS(K(IP1,2)).NE.21) THEN + NSTR=1 + KFLO(1)=K(IP1,2) + CALL PYPTDI(0,PXO(1),PYO(1)) + WO(1)=WF + +C...Initial values for gluon treated like random quark jet. + ELSEIF(MSTJ(2).LE.2) THEN + NSTR=1 + IF(MSTJ(2).EQ.2) MSTJ(91)=1 + KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0) + CALL PYPTDI(0,PXO(1),PYO(1)) + WO(1)=WF + +C...Initial values for gluon treated like quark-antiquark jet pair, +C...sharing energy according to Altarelli-Parisi splitting function. + ELSE + NSTR=2 + IF(MSTJ(2).EQ.4) MSTJ(91)=1 + KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0) + KFLO(2)=-KFLO(1) + CALL PYPTDI(0,PXO(1),PYO(1)) + PXO(2)=-PXO(1) + PYO(2)=-PYO(1) + WO(1)=WF*PYR(0)**(1D0/3D0) + WO(2)=WF-WO(1) + ENDIF + +C...Initial values for rank, flavour, pT and W+. + DO 220 ISTR=1,NSTR + 180 I=N + MSTU(90)=MSTU91 + IRANK=0 + KFL1=KFLO(ISTR) + PX1=PXO(ISTR) + PY1=PYO(ISTR) + W=WO(ISTR) + +C...New hadron. Generate flavour and hadron species. + 190 I=I+1 + IF(I.GE.MSTU(4)-MSTU(32)-NJET-5) THEN + CALL PYERRM(11,'(PYINDF:) no more memory left in PYJETS') + IF(MSTU(21).GE.1) RETURN + ENDIF + IRANK=IRANK+1 + K(I,1)=1 + K(I,3)=IP1 + K(I,4)=0 + K(I,5)=0 + 200 CALL PYKFDI(KFL1,0,KFL2,K(I,2)) + IF(K(I,2).EQ.0) GOTO 180 + IF(IRANK.EQ.1.AND.IABS(KFL1).LE.10.AND.IABS(KFL2).GT.10) THEN + IF(PYR(0).GT.PARJ(19)) GOTO 200 + ENDIF + +C...Find hadron mass. Generate four-momentum. + P(I,5)=PYMASS(K(I,2)) + CALL PYPTDI(KFL1,PX2,PY2) + P(I,1)=PX1+PX2 + P(I,2)=PY1+PY2 + PR=P(I,5)**2+P(I,1)**2+P(I,2)**2 + CALL PYZDIS(KFL1,KFL2,PR,Z) + MZSAV=0 + IF(IABS(KFL1).GE.4.AND.IABS(KFL1).LE.8.AND.MSTU(90).LT.8) THEN + MZSAV=1 + MSTU(90)=MSTU(90)+1 + MSTU(90+MSTU(90))=I + PARU(90+MSTU(90))=Z + ENDIF + P(I,3)=0.5D0*(Z*W-PR/MAX(1D-4,Z*W)) + P(I,4)=0.5D0*(Z*W+PR/MAX(1D-4,Z*W)) + IF(MSTJ(3).GE.1.AND.IRANK.EQ.1.AND.KFLH.GE.4.AND. + & P(I,3).LE.0.001D0) THEN + IF(W.GE.P(I,5)+0.5D0*PARJ(32)) GOTO 180 + P(I,3)=0.0001D0 + P(I,4)=SQRT(PR) + Z=P(I,4)/W + ENDIF + +C...Remaining flavour and momentum. + KFL1=-KFL2 + PX1=-PX2 + PY1=-PY2 + W=(1D0-Z)*W + DO 210 J=1,5 + V(I,J)=0D0 + 210 CONTINUE + +C...Check if pL acceptable. Go back for new hadron if enough energy. + IF(MSTJ(3).GE.0.AND.P(I,3).LT.0D0) THEN + I=I-1 + IF(MZSAV.EQ.1) MSTU(90)=MSTU(90)-1 + ENDIF + IF(W.GT.PARJ(31)) GOTO 190 + N=I + 220 CONTINUE + IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) WF=WF+0.1D0*PARJ(32) + IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) GOTO 170 + +C...Rotate jet to new direction. + THE=PYANGL(P(IP1,3),SQRT(P(IP1,1)**2+P(IP1,2)**2)) + PHI=PYANGL(P(IP1,1),P(IP1,2)) + MSTU(33)=1 + CALL PYROBO(NSAV1+1,N,THE,PHI,0D0,0D0,0D0) + K(K(IP1,3),4)=NSAV1+1 + K(K(IP1,3),5)=N + +C...End of jet generation loop. Skip conservation in some cases. + 230 CONTINUE + IF(NJET.EQ.1.OR.MSTJ(3).LE.0) GOTO 490 + IF(MOD(MSTJ(3),5).NE.0.AND.N-NSAV-NJET.LT.2) GOTO 150 + +C...Subtract off produced hadron flavours, finished if zero. + DO 240 I=NSAV+NJET+1,N + KFA=IABS(K(I,2)) + KFLA=MOD(KFA/1000,10) + KFLB=MOD(KFA/100,10) + KFLC=MOD(KFA/10,10) + IF(KFLA.EQ.0) THEN + IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))*(-1)**KFLB + IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(I,2))*(-1)**KFLB + ELSE + IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)-ISIGN(1,K(I,2)) + IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2)) + IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISIGN(1,K(I,2)) + ENDIF + 240 CONTINUE + NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+ + &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3 + IF(NREQ.EQ.0) GOTO 320 + +C...Take away flavour of low-momentum particles until enough freedom. + NREM=0 + 250 IREM=0 + P2MIN=PECM**2 + DO 260 I=NSAV+NJET+1,N + P2=P(I,1)**2+P(I,2)**2+P(I,3)**2 + IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) IREM=I + IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) P2MIN=P2 + 260 CONTINUE + IF(IREM.EQ.0) GOTO 150 + K(IREM,1)=7 + KFA=IABS(K(IREM,2)) + KFLA=MOD(KFA/1000,10) + KFLB=MOD(KFA/100,10) + KFLC=MOD(KFA/10,10) + IF(KFLA.GE.4.OR.KFLB.GE.4) K(IREM,1)=8 + IF(K(IREM,1).EQ.8) GOTO 250 + IF(KFLA.EQ.0) THEN + ISGN=ISIGN(1,K(IREM,2))*(-1)**KFLB + IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISGN + IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISGN + ELSE + IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)+ISIGN(1,K(IREM,2)) + IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISIGN(1,K(IREM,2)) + IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(IREM,2)) + ENDIF + NREM=NREM+1 + NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+ + &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3 + IF(NREQ.GT.NREM) GOTO 250 + DO 270 I=NSAV+NJET+1,N + IF(K(I,1).EQ.8) K(I,1)=1 + 270 CONTINUE + +C...Find combination of existing and new flavours for hadron. + 280 NFET=2 + IF(NFL(1)+NFL(2)+NFL(3).NE.0) NFET=3 + IF(NREQ.LT.NREM) NFET=1 + IF(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)).EQ.0) NFET=0 + DO 290 J=1,NFET + IFET(J)=1+(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)))*PYR(0) + KFLF(J)=ISIGN(1,NFL(1)) + IF(IFET(J).GT.IABS(NFL(1))) KFLF(J)=ISIGN(2,NFL(2)) + IF(IFET(J).GT.IABS(NFL(1))+IABS(NFL(2))) KFLF(J)=ISIGN(3,NFL(3)) + 290 CONTINUE + IF(NFET.EQ.2.AND.(IFET(1).EQ.IFET(2).OR.KFLF(1)*KFLF(2).GT.0)) + &GOTO 280 + IF(NFET.EQ.3.AND.(IFET(1).EQ.IFET(2).OR.IFET(1).EQ.IFET(3).OR. + &IFET(2).EQ.IFET(3).OR.KFLF(1)*KFLF(2).LT.0.OR.KFLF(1)*KFLF(3) + &.LT.0.OR.KFLF(1)*(NFL(1)+NFL(2)+NFL(3)).LT.0)) GOTO 280 + IF(NFET.EQ.0) KFLF(1)=1+INT((2D0+PARJ(2))*PYR(0)) + IF(NFET.EQ.0) KFLF(2)=-KFLF(1) + IF(NFET.EQ.1) KFLF(2)=ISIGN(1+INT((2D0+PARJ(2))*PYR(0)),-KFLF(1)) + IF(NFET.LE.2) KFLF(3)=0 + IF(KFLF(3).NE.0) THEN + KFLFC=ISIGN(1000*MAX(IABS(KFLF(1)),IABS(KFLF(3)))+ + & 100*MIN(IABS(KFLF(1)),IABS(KFLF(3)))+1,KFLF(1)) + IF(KFLF(1).EQ.KFLF(3).OR.(1D0+3D0*PARJ(4))*PYR(0).GT.1D0) + & KFLFC=KFLFC+ISIGN(2,KFLFC) + ELSE + KFLFC=KFLF(1) + ENDIF + CALL PYKFDI(KFLFC,KFLF(2),KFLDMP,KF) + IF(KF.EQ.0) GOTO 280 + DO 300 J=1,MAX(2,NFET) + NFL(IABS(KFLF(J)))=NFL(IABS(KFLF(J)))-ISIGN(1,KFLF(J)) + 300 CONTINUE + +C...Store hadron at random among free positions. + NPOS=MIN(1+INT(PYR(0)*NREM),NREM) + DO 310 I=NSAV+NJET+1,N + IF(K(I,1).EQ.7) NPOS=NPOS-1 + IF(K(I,1).EQ.1.OR.NPOS.NE.0) GOTO 310 + K(I,1)=1 + K(I,2)=KF + P(I,5)=PYMASS(K(I,2)) + P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2) + 310 CONTINUE + NREM=NREM-1 + NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+ + &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3 + IF(NREM.GT.0) GOTO 280 + +C...Compensate for missing momentum in global scheme (3 options). + 320 IF(MOD(MSTJ(3),5).NE.0.AND.MOD(MSTJ(3),5).NE.4) THEN + DO 340 J=1,3 + PSI(J)=0D0 + DO 330 I=NSAV+NJET+1,N + PSI(J)=PSI(J)+P(I,J) + 330 CONTINUE + 340 CONTINUE + PSI(4)=PSI(1)**2+PSI(2)**2+PSI(3)**2 + PWS=0D0 + DO 350 I=NSAV+NJET+1,N + IF(MOD(MSTJ(3),5).EQ.1) PWS=PWS+P(I,4) + IF(MOD(MSTJ(3),5).EQ.2) PWS=PWS+SQRT(P(I,5)**2+(PSI(1)*P(I,1)+ + & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4)) + IF(MOD(MSTJ(3),5).EQ.3) PWS=PWS+1D0 + 350 CONTINUE + DO 370 I=NSAV+NJET+1,N + IF(MOD(MSTJ(3),5).EQ.1) PW=P(I,4) + IF(MOD(MSTJ(3),5).EQ.2) PW=SQRT(P(I,5)**2+(PSI(1)*P(I,1)+ + & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4)) + IF(MOD(MSTJ(3),5).EQ.3) PW=1D0 + DO 360 J=1,3 + P(I,J)=P(I,J)-PSI(J)*PW/PWS + 360 CONTINUE + P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2) + 370 CONTINUE + +C...Compensate for missing momentum withing each jet separately. + ELSEIF(MOD(MSTJ(3),5).EQ.4) THEN + DO 390 I=N+1,N+NJET + K(I,1)=0 + DO 380 J=1,5 + P(I,J)=0D0 + 380 CONTINUE + 390 CONTINUE + DO 410 I=NSAV+NJET+1,N + IR1=K(I,3) + IR2=N+IR1-NSAV + K(IR2,1)=K(IR2,1)+1 + PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/ + & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2) + DO 400 J=1,3 + P(IR2,J)=P(IR2,J)+P(I,J)-PLS*P(IR1,J) + 400 CONTINUE + P(IR2,4)=P(IR2,4)+P(I,4) + P(IR2,5)=P(IR2,5)+PLS + 410 CONTINUE + PSS=0D0 + DO 420 I=N+1,N+NJET + IF(K(I,1).NE.0) PSS=PSS+P(I,4)/(PECM*(0.8D0*P(I,5)+0.2D0)) + 420 CONTINUE + DO 440 I=NSAV+NJET+1,N + IR1=K(I,3) + IR2=N+IR1-NSAV + PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/ + & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2) + DO 430 J=1,3 + P(I,J)=P(I,J)-P(IR2,J)/K(IR2,1)+(1D0/(P(IR2,5)*PSS)-1D0)* + & PLS*P(IR1,J) + 430 CONTINUE + P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2) + 440 CONTINUE + ENDIF + +C...Scale momenta for energy conservation. + IF(MOD(MSTJ(3),5).NE.0) THEN + PMS=0D0 + PES=0D0 + PQS=0D0 + DO 450 I=NSAV+NJET+1,N + PMS=PMS+P(I,5) + PES=PES+P(I,4) + PQS=PQS+P(I,5)**2/P(I,4) + 450 CONTINUE + IF(PMS.GE.PECM) GOTO 150 + NECO=0 + 460 NECO=NECO+1 + PFAC=(PECM-PQS)/(PES-PQS) + PES=0D0 + PQS=0D0 + DO 480 I=NSAV+NJET+1,N + DO 470 J=1,3 + P(I,J)=PFAC*P(I,J) + 470 CONTINUE + P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2) + PES=PES+P(I,4) + PQS=PQS+P(I,5)**2/P(I,4) + 480 CONTINUE + IF(NECO.LT.10.AND.ABS(PECM-PES).GT.2D-6*PECM) GOTO 460 + ENDIF + +C...Origin of produced particles and parton daughter pointers. + 490 DO 500 I=NSAV+NJET+1,N + IF(MSTU(16).NE.2) K(I,3)=NSAV+1 + IF(MSTU(16).EQ.2) K(I,3)=K(K(I,3),3) + 500 CONTINUE + DO 510 I=NSAV+1,NSAV+NJET + I1=K(I,3) + K(I1,1)=K(I1,1)+10 + IF(MSTU(16).NE.2) THEN + K(I1,4)=NSAV+1 + K(I1,5)=NSAV+1 + ELSE + K(I1,4)=K(I1,4)-NJET+1 + K(I1,5)=K(I1,5)-NJET+1 + IF(K(I1,5).LT.K(I1,4)) THEN + K(I1,4)=0 + K(I1,5)=0 + ENDIF + ENDIF + 510 CONTINUE + +C...Document independent fragmentation system. Remove copy of jets. + NSAV=NSAV+1 + K(NSAV,1)=11 + K(NSAV,2)=93 + K(NSAV,3)=IP + K(NSAV,4)=NSAV+1 + K(NSAV,5)=N-NJET+1 + DO 520 J=1,4 + P(NSAV,J)=DPS(J) + V(NSAV,J)=V(IP,J) + 520 CONTINUE + P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2)) + V(NSAV,5)=0D0 + DO 540 I=NSAV+NJET,N + DO 530 J=1,5 + K(I-NJET+1,J)=K(I,J) + P(I-NJET+1,J)=P(I,J) + V(I-NJET+1,J)=V(I,J) + 530 CONTINUE + 540 CONTINUE + N=N-NJET+1 + DO 550 IZ=MSTU90+1,MSTU(90) + MSTU(90+IZ)=MSTU(90+IZ)-NJET+1 + 550 CONTINUE + +C...Boost back particle system. Set production vertices. + IF(NJET.NE.1) CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4), + &DPS(2)/DPS(4),DPS(3)/DPS(4)) + DO 570 I=NSAV+1,N + DO 560 J=1,4 + V(I,J)=V(IP,J) + 560 CONTINUE + 570 CONTINUE + + RETURN + END + +C********************************************************************* + +C...PYDECY +C...Handles the decay of unstable particles. + + SUBROUTINE PYDECY(IP) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/ +C...Local arrays. + DIMENSION VDCY(4),KFLO(4),KFL1(4),PV(10,5),RORD(10),UE(3),BE(3), + &WTCOR(10),PTAU(4),PCMTAU(4),DBETAU(3) + CHARACTER CIDC*4 + DATA WTCOR/2D0,5D0,15D0,60D0,250D0,1500D0,1.2D4,1.2D5,150D0,16D0/ + +C...Functions: momentum in two-particle decays and four-product. + PAWT(A,B,C)=SQRT((A**2-(B+C)**2)*(A**2-(B-C)**2))/(2D0*A) + FOUR(I,J)=P(I,4)*P(J,4)-P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3) + +C...Initial values. + NTRY=0 + NSAV=N + KFA=IABS(K(IP,2)) + KFS=ISIGN(1,K(IP,2)) + KC=PYCOMP(KFA) + MSTJ(92)=0 + +C...Choose lifetime and determine decay vertex. + IF(K(IP,1).EQ.5) THEN + V(IP,5)=0D0 + ELSEIF(K(IP,1).NE.4) THEN + V(IP,5)=-PMAS(KC,4)*LOG(PYR(0)) + ENDIF + DO 100 J=1,4 + VDCY(J)=V(IP,J)+V(IP,5)*P(IP,J)/P(IP,5) + 100 CONTINUE + +C...Determine whether decay allowed or not. + MOUT=0 + IF(MSTJ(22).EQ.2) THEN + IF(PMAS(KC,4).GT.PARJ(71)) MOUT=1 + ELSEIF(MSTJ(22).EQ.3) THEN + IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1 + ELSEIF(MSTJ(22).EQ.4) THEN + IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1 + IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1 + ENDIF + IF(MOUT.EQ.1.AND.K(IP,1).NE.5) THEN + K(IP,1)=4 + RETURN + ENDIF + +C...Interface to external tau decay library (for tau polarization). + IF(KFA.EQ.15.AND.MSTJ(28).GE.1) THEN + +C...Starting values for pointers and momenta. + ITAU=IP + DO 110 J=1,4 + PTAU(J)=P(ITAU,J) + PCMTAU(J)=P(ITAU,J) + 110 CONTINUE + +C...Iterate to find position and code of mother of tau. + IMTAU=ITAU + 120 IMTAU=K(IMTAU,3) + + IF(IMTAU.EQ.0) THEN +C...If no known origin then impossible to do anything further. + KFORIG=0 + IORIG=0 + + ELSEIF(K(IMTAU,2).EQ.K(ITAU,2)) THEN +C...If tau -> tau + gamma then add gamma energy and loop. + IF(K(K(IMTAU,4),2).EQ.22) THEN + DO 130 J=1,4 + PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,4),J) + 130 CONTINUE + ELSEIF(K(K(IMTAU,5),2).EQ.22) THEN + DO 140 J=1,4 + PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,5),J) + 140 CONTINUE + ENDIF + GOTO 120 + + ELSEIF(IABS(K(IMTAU,2)).GT.100) THEN +C...If coming from weak decay of hadron then W is not stored in record, +C...but can be reconstructed by adding neutrino momentum. + KFORIG=-ISIGN(24,K(ITAU,2)) + IORIG=0 + DO 160 II=K(IMTAU,4),K(IMTAU,5) + IF(K(II,2)*ISIGN(1,K(ITAU,2)).EQ.-16) THEN + DO 150 J=1,4 + PCMTAU(J)=PCMTAU(J)+P(II,J) + 150 CONTINUE + ENDIF + 160 CONTINUE + + ELSE +C...If coming from resonance decay then find latest copy of this +C...resonance (may not completely agree). + KFORIG=K(IMTAU,2) + IORIG=IMTAU + DO 170 II=IMTAU+1,IP-1 + IF(K(II,2).EQ.KFORIG.AND.K(II,3).EQ.IORIG.AND. + & ABS(P(II,5)-P(IORIG,5)).LT.1D-5*P(IORIG,5)) IORIG=II + 170 CONTINUE + DO 180 J=1,4 + PCMTAU(J)=P(IORIG,J) + 180 CONTINUE + ENDIF + +C...Boost tau to rest frame of production process (where known) +C...and rotate it to sit along +z axis. + DO 190 J=1,3 + DBETAU(J)=PCMTAU(J)/PCMTAU(4) + 190 CONTINUE + IF(KFORIG.NE.0) CALL PYROBO(ITAU,ITAU,0D0,0D0,-DBETAU(1), + & -DBETAU(2),-DBETAU(3)) + PHITAU=PYANGL(P(ITAU,1),P(ITAU,2)) + CALL PYROBO(ITAU,ITAU,0D0,-PHITAU,0D0,0D0,0D0) + THETAU=PYANGL(P(ITAU,3),P(ITAU,1)) + CALL PYROBO(ITAU,ITAU,-THETAU,0D0,0D0,0D0,0D0) + +C...Call tau decay routine (if meaningful) and fill extra info. + IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN + CALL PYTAUD(ITAU,IORIG,KFORIG,NDECAY) + DO 200 II=NSAV+1,NSAV+NDECAY + K(II,1)=1 + K(II,3)=IP + K(II,4)=0 + K(II,5)=0 + 200 CONTINUE + N=NSAV+NDECAY + ENDIF + +C...Boost back decay tau and decay products. + DO 210 J=1,4 + P(ITAU,J)=PTAU(J) + 210 CONTINUE + IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN + CALL PYROBO(NSAV+1,N,THETAU,PHITAU,0D0,0D0,0D0) + IF(KFORIG.NE.0) CALL PYROBO(NSAV+1,N,0D0,0D0,DBETAU(1), + & DBETAU(2),DBETAU(3)) + +C...Skip past ordinary tau decay treatment. + MMAT=0 + MBST=0 + ND=0 + GOTO 630 + ENDIF + ENDIF + +C...B-Bbar mixing: flip sign of meson appropriately. + MMIX=0 + IF((KFA.EQ.511.OR.KFA.EQ.531).AND.MSTJ(26).GE.1) THEN + XBBMIX=PARJ(76) + IF(KFA.EQ.531) XBBMIX=PARJ(77) + IF(SIN(0.5D0*XBBMIX*V(IP,5)/PMAS(KC,4))**2.GT.PYR(0)) MMIX=1 + IF(MMIX.EQ.1) KFS=-KFS + ENDIF + +C...Check existence of decay channels. Particle/antiparticle rules. + KCA=KC + IF(MDCY(KC,2).GT.0) THEN + MDMDCY=MDME(MDCY(KC,2),2) + IF(MDMDCY.GT.80.AND.MDMDCY.LE.90) KCA=MDMDCY + ENDIF + IF(MDCY(KCA,2).LE.0.OR.MDCY(KCA,3).LE.0) THEN + CALL PYERRM(9,'(PYDECY:) no decay channel defined') + RETURN + ENDIF + IF(MOD(KFA/1000,10).EQ.0.AND.KCA.EQ.85) KFS=-KFS + IF(KCHG(KC,3).EQ.0) THEN + KFSP=1 + KFSN=0 + IF(PYR(0).GT.0.5D0) KFS=-KFS + ELSEIF(KFS.GT.0) THEN + KFSP=1 + KFSN=0 + ELSE + KFSP=0 + KFSN=1 + ENDIF + +C...Sum branching ratios of allowed decay channels. + 220 NOPE=0 + BRSU=0D0 + DO 230 IDL=MDCY(KCA,2),MDCY(KCA,2)+MDCY(KCA,3)-1 + IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND. + & KFSN*MDME(IDL,1).NE.3) GOTO 230 + IF(MDME(IDL,2).GT.100) GOTO 230 + NOPE=NOPE+1 + BRSU=BRSU+BRAT(IDL) + 230 CONTINUE + IF(NOPE.EQ.0) THEN + CALL PYERRM(2,'(PYDECY:) all decay channels closed by user') + RETURN + ENDIF + +C...Select decay channel among allowed ones. + 240 RBR=BRSU*PYR(0) + IDL=MDCY(KCA,2)-1 + 250 IDL=IDL+1 + IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND. + &KFSN*MDME(IDL,1).NE.3) THEN + IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250 + ELSEIF(MDME(IDL,2).GT.100) THEN + IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250 + ELSE + IDC=IDL + RBR=RBR-BRAT(IDL) + IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1.AND.RBR.GT.0D0) GOTO 250 + ENDIF + +C...Start readout of decay channel: matrix element, reset counters. + MMAT=MDME(IDC,2) + 260 NTRY=NTRY+1 + IF(MOD(NTRY,200).EQ.0) THEN + WRITE(CIDC,'(I4)') IDC +C...Do not print warning for some well-known special cases. + IF(KFA.NE.113.AND.KFA.NE.115.AND.KFA.NE.215) + & CALL PYERRM(4,'(PYDECY:) caught in loop for decay channel'// + & CIDC) + GOTO 240 + ENDIF + IF(NTRY.GT.1000) THEN + CALL PYERRM(14,'(PYDECY:) caught in infinite loop') + IF(MSTU(21).GE.1) RETURN + ENDIF + I=N + NP=0 + NQ=0 + MBST=0 + IF(MMAT.GE.11.AND.P(IP,4).GT.20D0*P(IP,5)) MBST=1 + DO 270 J=1,4 + PV(1,J)=0D0 + IF(MBST.EQ.0) PV(1,J)=P(IP,J) + 270 CONTINUE + IF(MBST.EQ.1) PV(1,4)=P(IP,5) + PV(1,5)=P(IP,5) + PS=0D0 + PSQ=0D0 + MREM=0 + MHADDY=0 + IF(KFA.GT.80) MHADDY=1 +C.. Random flavour and popcorn system memory. + IRNDMO=0 + JTMO=0 + MSTU(121)=0 + MSTU(125)=10 + +C...Read out decay products. Convert to standard flavour code. + JTMAX=5 + IF(MDME(IDC+1,2).EQ.101) JTMAX=10 + DO 280 JT=1,JTMAX + IF(JT.LE.5) KP=KFDP(IDC,JT) + IF(JT.GE.6) KP=KFDP(IDC+1,JT-5) + IF(KP.EQ.0) GOTO 280 + KPA=IABS(KP) + KCP=PYCOMP(KPA) + IF(KPA.GT.80) MHADDY=1 + IF(KCHG(KCP,3).EQ.0.AND.KPA.NE.81.AND.KPA.NE.82) THEN + KFP=KP + ELSEIF(KPA.NE.81.AND.KPA.NE.82) THEN + KFP=KFS*KP + ELSEIF(KPA.EQ.81.AND.MOD(KFA/1000,10).EQ.0) THEN + KFP=-KFS*MOD(KFA/10,10) + ELSEIF(KPA.EQ.81.AND.MOD(KFA/100,10).GE.MOD(KFA/10,10)) THEN + KFP=KFS*(100*MOD(KFA/10,100)+3) + ELSEIF(KPA.EQ.81) THEN + KFP=KFS*(1000*MOD(KFA/10,10)+100*MOD(KFA/100,10)+1) + ELSEIF(KP.EQ.82) THEN + CALL PYDCYK(-KFS*INT(1D0+(2D0+PARJ(2))*PYR(0)),0,KFP,KDUMP) + IF(KFP.EQ.0) GOTO 260 + KFP=-KFP + IRNDMO=1 + MSTJ(93)=1 + IF(PV(1,5).LT.PARJ(32)+2D0*PYMASS(KFP)) GOTO 260 + ELSEIF(KP.EQ.-82) THEN + KFP=MSTU(124) + ENDIF + IF(KPA.EQ.81.OR.KPA.EQ.82) KCP=PYCOMP(KFP) + +C...Add decay product to event record or to quark flavour list. + KFPA=IABS(KFP) + KQP=KCHG(KCP,2) + IF(MMAT.GE.11.AND.MMAT.LE.30.AND.KQP.NE.0) THEN + NQ=NQ+1 + KFLO(NQ)=KFP +C...set rndmflav popcorn system pointer + IF(KP.EQ.82.AND.MSTU(121).GT.0) JTMO=NQ + MSTJ(93)=2 + PSQ=PSQ+PYMASS(KFLO(NQ)) + ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.48).AND.NP.EQ.3.AND. + & MOD(NQ,2).EQ.1) THEN + NQ=NQ-1 + PS=PS-P(I,5) + K(I,1)=1 + KFI=K(I,2) + CALL PYKFDI(KFP,KFI,KFLDMP,K(I,2)) + IF(K(I,2).EQ.0) GOTO 260 + MSTJ(93)=1 + P(I,5)=PYMASS(K(I,2)) + PS=PS+P(I,5) + ELSE + I=I+1 + NP=NP+1 + IF(MMAT.NE.33.AND.KQP.NE.0) NQ=NQ+1 + IF(MMAT.EQ.33.AND.KQP.NE.0.AND.KQP.NE.2) NQ=NQ+1 + K(I,1)=1+MOD(NQ,2) + IF(MMAT.EQ.4.AND.JT.LE.2.AND.KFP.EQ.21) K(I,1)=2 + IF(MMAT.EQ.4.AND.JT.EQ.3) K(I,1)=1 + K(I,2)=KFP + K(I,3)=IP + K(I,4)=0 + K(I,5)=0 + P(I,5)=PYMASS(KFP) + PS=PS+P(I,5) + ENDIF + 280 CONTINUE + +C...Check masses for resonance decays. + IF(MHADDY.EQ.0) THEN + IF(PS+PARJ(64).GT.PV(1,5)) GOTO 240 + ENDIF + +C...Choose decay multiplicity in phase space model. + 290 IF(MMAT.GE.11.AND.MMAT.LE.30) THEN + PSP=PS + CNDE=PARJ(61)*LOG(MAX((PV(1,5)-PS-PSQ)/PARJ(62),1.1D0)) + IF(MMAT.EQ.12) CNDE=CNDE+PARJ(63) + 300 NTRY=NTRY+1 +C...Reset popcorn flags if new attempt. Re-select rndmflav if failed. + IF(IRNDMO.EQ.0) THEN + MSTU(121)=0 + JTMO=0 + ELSEIF(IRNDMO.EQ.1) THEN + IRNDMO=2 + ELSE + GOTO 260 + ENDIF + IF(NTRY.GT.1000) THEN + CALL PYERRM(14,'(PYDECY:) caught in infinite loop') + IF(MSTU(21).GE.1) RETURN + ENDIF + IF(MMAT.LE.20) THEN + GAUSS=SQRT(-2D0*CNDE*LOG(MAX(1D-10,PYR(0))))* + & SIN(PARU(2)*PYR(0)) + ND=0.5D0+0.5D0*NP+0.25D0*NQ+CNDE+GAUSS + IF(ND.LT.NP+NQ/2.OR.ND.LT.2.OR.ND.GT.10) GOTO 300 + IF(MMAT.EQ.13.AND.ND.EQ.2) GOTO 300 + IF(MMAT.EQ.14.AND.ND.LE.3) GOTO 300 + IF(MMAT.EQ.15.AND.ND.LE.4) GOTO 300 + ELSE + ND=MMAT-20 + ENDIF +C.. Set maximum popcorn meson number. Test rndmflav popcorn size. + MSTU(125)=ND-NQ/2 + IF(MSTU(121).GT.MSTU(125)) GOTO 300 + +C...Form hadrons from flavour content. + DO 310 JT=1,NQ + KFL1(JT)=KFLO(JT) + 310 CONTINUE + IF(ND.EQ.NP+NQ/2) GOTO 330 + DO 320 I=N+NP+1,N+ND-NQ/2 +C.. Stick to started popcorn system, else pick side at random + JT=JTMO + IF(JT.EQ.0) JT=1+INT((NQ-1)*PYR(0)) + CALL PYDCYK(KFL1(JT),0,KFL2,K(I,2)) + IF(K(I,2).EQ.0) GOTO 300 + MSTU(125)=MSTU(125)-1 + JTMO=0 + IF(MSTU(121).GT.0) JTMO=JT + KFL1(JT)=-KFL2 + 320 CONTINUE + 330 JT=2 + JT2=3 + JT3=4 + IF(NQ.EQ.4.AND.PYR(0).LT.PARJ(66)) JT=4 + IF(JT.EQ.4.AND.ISIGN(1,KFL1(1)*(10-IABS(KFL1(1))))* + & ISIGN(1,KFL1(JT)*(10-IABS(KFL1(JT)))).GT.0) JT=3 + IF(JT.EQ.3) JT2=2 + IF(JT.EQ.4) JT3=2 + CALL PYDCYK(KFL1(1),KFL1(JT),KFLDMP,K(N+ND-NQ/2+1,2)) + IF(K(N+ND-NQ/2+1,2).EQ.0) GOTO 300 + IF(NQ.EQ.4) CALL PYDCYK(KFL1(JT2),KFL1(JT3),KFLDMP,K(N+ND,2)) + IF(NQ.EQ.4.AND.K(N+ND,2).EQ.0) GOTO 300 + +C...Check that sum of decay product masses not too large. + PS=PSP + DO 340 I=N+NP+1,N+ND + K(I,1)=1 + K(I,3)=IP + K(I,4)=0 + K(I,5)=0 + P(I,5)=PYMASS(K(I,2)) + PS=PS+P(I,5) + 340 CONTINUE + IF(PS+PARJ(64).GT.PV(1,5)) GOTO 300 + +C...Rescale energy to subtract off spectator quark mass. + ELSEIF((MMAT.EQ.31.OR.MMAT.EQ.33.OR.MMAT.EQ.44) + & .AND.NP.GE.3) THEN + PS=PS-P(N+NP,5) + PQT=(P(N+NP,5)+PARJ(65))/PV(1,5) + DO 350 J=1,5 + P(N+NP,J)=PQT*PV(1,J) + PV(1,J)=(1D0-PQT)*PV(1,J) + 350 CONTINUE + IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260 + ND=NP-1 + MREM=1 + +C...Fully specified final state: check mass broadening effects. + ELSE + IF(NP.GE.2.AND.PS+PARJ(64).GT.PV(1,5)) GOTO 260 + ND=NP + ENDIF + +C...Determine position of grandmother, number of sisters. + NM=0 + KFAS=0 + MSGN=0 + IF(MMAT.EQ.3) THEN + IM=K(IP,3) + IF(IM.LT.0.OR.IM.GE.IP) IM=0 + IF(IM.NE.0) KFAM=IABS(K(IM,2)) + IF(IM.NE.0) THEN + DO 360 IL=MAX(IP-2,IM+1),MIN(IP+2,N) + IF(K(IL,3).EQ.IM) NM=NM+1 + IF(K(IL,3).EQ.IM.AND.IL.NE.IP) ISIS=IL + 360 CONTINUE + IF(NM.NE.2.OR.KFAM.LE.100.OR.MOD(KFAM,10).NE.1.OR. + & MOD(KFAM/1000,10).NE.0) NM=0 + IF(NM.EQ.2) THEN + KFAS=IABS(K(ISIS,2)) + IF((KFAS.LE.100.OR.MOD(KFAS,10).NE.1.OR. + & MOD(KFAS/1000,10).NE.0).AND.KFAS.NE.22) NM=0 + ENDIF + ENDIF + ENDIF + +C...Kinematics of one-particle decays. + IF(ND.EQ.1) THEN + DO 370 J=1,4 + P(N+1,J)=P(IP,J) + 370 CONTINUE + GOTO 630 + ENDIF + +C...Calculate maximum weight ND-particle decay. + PV(ND,5)=P(N+ND,5) + IF(ND.GE.3) THEN + WTMAX=1D0/WTCOR(ND-2) + PMAX=PV(1,5)-PS+P(N+ND,5) + PMIN=0D0 + DO 380 IL=ND-1,1,-1 + PMAX=PMAX+P(N+IL,5) + PMIN=PMIN+P(N+IL+1,5) + WTMAX=WTMAX*PAWT(PMAX,PMIN,P(N+IL,5)) + 380 CONTINUE + ENDIF + +C...Find virtual gamma mass in Dalitz decay. + 390 IF(ND.EQ.2) THEN + ELSEIF(MMAT.EQ.2) THEN + PMES=4D0*PMAS(11,1)**2 + PMRHO2=PMAS(131,1)**2 + PGRHO2=PMAS(131,2)**2 + 400 PMST=PMES*(P(IP,5)**2/PMES)**PYR(0) + WT=(1+0.5D0*PMES/PMST)*SQRT(MAX(0D0,1D0-PMES/PMST))* + & (1D0-PMST/P(IP,5)**2)**3*(1D0+PGRHO2/PMRHO2)/ + & ((1D0-PMST/PMRHO2)**2+PGRHO2/PMRHO2) + IF(WT.LT.PYR(0)) GOTO 400 + PV(2,5)=MAX(2.00001D0*PMAS(11,1),SQRT(PMST)) + +C...M-generator gives weight. If rejected, try again. + ELSE + 410 RORD(1)=1D0 + DO 440 IL1=2,ND-1 + RSAV=PYR(0) + DO 420 IL2=IL1-1,1,-1 + IF(RSAV.LE.RORD(IL2)) GOTO 430 + RORD(IL2+1)=RORD(IL2) + 420 CONTINUE + 430 RORD(IL2+1)=RSAV + 440 CONTINUE + RORD(ND)=0D0 + WT=1D0 + DO 450 IL=ND-1,1,-1 + PV(IL,5)=PV(IL+1,5)+P(N+IL,5)+(RORD(IL)-RORD(IL+1))* + & (PV(1,5)-PS) + WT=WT*PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5)) + 450 CONTINUE + IF(WT.LT.PYR(0)*WTMAX) GOTO 410 + ENDIF + +C...Perform two-particle decays in respective CM frame. + 460 DO 480 IL=1,ND-1 + PA=PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5)) + UE(3)=2D0*PYR(0)-1D0 + PHI=PARU(2)*PYR(0) + UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI) + UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI) + DO 470 J=1,3 + P(N+IL,J)=PA*UE(J) + PV(IL+1,J)=-PA*UE(J) + 470 CONTINUE + P(N+IL,4)=SQRT(PA**2+P(N+IL,5)**2) + PV(IL+1,4)=SQRT(PA**2+PV(IL+1,5)**2) + 480 CONTINUE + +C...Lorentz transform decay products to lab frame. + DO 490 J=1,4 + P(N+ND,J)=PV(ND,J) + 490 CONTINUE + DO 530 IL=ND-1,1,-1 + DO 500 J=1,3 + BE(J)=PV(IL,J)/PV(IL,4) + 500 CONTINUE + GA=PV(IL,4)/PV(IL,5) + DO 520 I=N+IL,N+ND + BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3) + DO 510 J=1,3 + P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J) + 510 CONTINUE + P(I,4)=GA*(P(I,4)+BEP) + 520 CONTINUE + 530 CONTINUE + +C...Check that no infinite loop in matrix element weight. + NTRY=NTRY+1 + IF(NTRY.GT.800) GOTO 560 + +C...Matrix elements for omega and phi decays. + IF(MMAT.EQ.1) THEN + WT=(P(N+1,5)*P(N+2,5)*P(N+3,5))**2-(P(N+1,5)*FOUR(N+2,N+3))**2 + & -(P(N+2,5)*FOUR(N+1,N+3))**2-(P(N+3,5)*FOUR(N+1,N+2))**2 + & +2D0*FOUR(N+1,N+2)*FOUR(N+1,N+3)*FOUR(N+2,N+3) + IF(MAX(WT*WTCOR(9)/P(IP,5)**6,0.001D0).LT.PYR(0)) GOTO 390 + +C...Matrix elements for pi0 or eta Dalitz decay to gamma e+ e-. + ELSEIF(MMAT.EQ.2) THEN + FOUR12=FOUR(N+1,N+2) + FOUR13=FOUR(N+1,N+3) + WT=(PMST-0.5D0*PMES)*(FOUR12**2+FOUR13**2)+ + & PMES*(FOUR12*FOUR13+FOUR12**2+FOUR13**2) + IF(WT.LT.PYR(0)*0.25D0*PMST*(P(IP,5)**2-PMST)**2) GOTO 460 + +C...Matrix element for S0 -> S1 + V1 -> S1 + S2 + S3 (S scalar, +C...V vector), of form cos**2(theta02) in V1 rest frame, and for +C...S0 -> gamma + V1 -> gamma + S2 + S3, of form sin**2(theta02). + ELSEIF(MMAT.EQ.3.AND.NM.EQ.2) THEN + FOUR10=FOUR(IP,IM) + FOUR12=FOUR(IP,N+1) + FOUR02=FOUR(IM,N+1) + PMS1=P(IP,5)**2 + PMS0=P(IM,5)**2 + PMS2=P(N+1,5)**2 + IF(KFAS.NE.22) HNUM=(FOUR10*FOUR12-PMS1*FOUR02)**2 + IF(KFAS.EQ.22) HNUM=PMS1*(2D0*FOUR10*FOUR12*FOUR02- + & PMS1*FOUR02**2-PMS0*FOUR12**2-PMS2*FOUR10**2+PMS1*PMS0*PMS2) + HNUM=MAX(1D-6*PMS1**2*PMS0*PMS2,HNUM) + HDEN=(FOUR10**2-PMS1*PMS0)*(FOUR12**2-PMS1*PMS2) + IF(HNUM.LT.PYR(0)*HDEN) GOTO 460 + +C...Matrix element for "onium" -> g + g + g or gamma + g + g. + ELSEIF(MMAT.EQ.4) THEN + HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2 + HX2=2D0*FOUR(IP,N+2)/P(IP,5)**2 + HX3=2D0*FOUR(IP,N+3)/P(IP,5)**2 + WT=((1D0-HX1)/(HX2*HX3))**2+((1D0-HX2)/(HX1*HX3))**2+ + & ((1D0-HX3)/(HX1*HX2))**2 + IF(WT.LT.2D0*PYR(0)) GOTO 390 + IF(K(IP+1,2).EQ.22.AND.(1D0-HX1)*P(IP,5)**2.LT.4D0*PARJ(32)**2) + & GOTO 390 + +C...Effective matrix element for nu spectrum in tau -> nu + hadrons. + ELSEIF(MMAT.EQ.41) THEN + IF(MBST.EQ.0) HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2 + IF(MBST.EQ.1) HX1=2D0*P(N+1,4)/P(IP,5) + HXM=MIN(0.75D0,2D0*(1D0-PS/P(IP,5))) + IF(HX1*(3D0-2D0*HX1).LT.PYR(0)*HXM*(3D0-2D0*HXM)) GOTO 390 + +C...Matrix elements for weak decays (only semileptonic for c and b) + ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48) + & .AND.ND.EQ.3) THEN + IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+3) + IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+3) + IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390 + ELSEIF(MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48) THEN + DO 550 J=1,4 + P(N+NP+1,J)=0D0 + DO 540 IS=N+3,N+NP + P(N+NP+1,J)=P(N+NP+1,J)+P(IS,J) + 540 CONTINUE + 550 CONTINUE + IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+NP+1) + IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+NP+1) + IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390 + ENDIF + +C...Scale back energy and reattach spectator. + 560 IF(MREM.EQ.1) THEN + DO 570 J=1,5 + PV(1,J)=PV(1,J)/(1D0-PQT) + 570 CONTINUE + ND=ND+1 + MREM=0 + ENDIF + +C...Low invariant mass for system with spectator quark gives particle, +C...not two jets. Readjust momenta accordingly. + IF(MMAT.EQ.31.AND.ND.EQ.3) THEN + MSTJ(93)=1 + PM2=PYMASS(K(N+2,2)) + MSTJ(93)=1 + PM3=PYMASS(K(N+3,2)) + IF(P(N+2,5)**2+P(N+3,5)**2+2D0*FOUR(N+2,N+3).GE. + & (PARJ(32)+PM2+PM3)**2) GOTO 630 + K(N+2,1)=1 + KFTEMP=K(N+2,2) + CALL PYKFDI(KFTEMP,K(N+3,2),KFLDMP,K(N+2,2)) + IF(K(N+2,2).EQ.0) GOTO 260 + P(N+2,5)=PYMASS(K(N+2,2)) + PS=P(N+1,5)+P(N+2,5) + PV(2,5)=P(N+2,5) + MMAT=0 + ND=2 + GOTO 460 + ELSEIF(MMAT.EQ.44) THEN + MSTJ(93)=1 + PM3=PYMASS(K(N+3,2)) + MSTJ(93)=1 + PM4=PYMASS(K(N+4,2)) + IF(P(N+3,5)**2+P(N+4,5)**2+2D0*FOUR(N+3,N+4).GE. + & (PARJ(32)+PM3+PM4)**2) GOTO 600 + K(N+3,1)=1 + KFTEMP=K(N+3,2) + CALL PYKFDI(KFTEMP,K(N+4,2),KFLDMP,K(N+3,2)) + IF(K(N+3,2).EQ.0) GOTO 260 + P(N+3,5)=PYMASS(K(N+3,2)) + DO 580 J=1,3 + P(N+3,J)=P(N+3,J)+P(N+4,J) + 580 CONTINUE + P(N+3,4)=SQRT(P(N+3,1)**2+P(N+3,2)**2+P(N+3,3)**2+P(N+3,5)**2) + HA=P(N+1,4)**2-P(N+2,4)**2 + HB=HA-(P(N+1,5)**2-P(N+2,5)**2) + HC=(P(N+1,1)-P(N+2,1))**2+(P(N+1,2)-P(N+2,2))**2+ + & (P(N+1,3)-P(N+2,3))**2 + HD=(PV(1,4)-P(N+3,4))**2 + HE=HA**2-2D0*HD*(P(N+1,4)**2+P(N+2,4)**2)+HD**2 + HF=HD*HC-HB**2 + HG=HD*HC-HA*HB + HH=(SQRT(HG**2+HE*HF)-HG)/(2D0*HF) + DO 590 J=1,3 + PCOR=HH*(P(N+1,J)-P(N+2,J)) + P(N+1,J)=P(N+1,J)+PCOR + P(N+2,J)=P(N+2,J)-PCOR + 590 CONTINUE + P(N+1,4)=SQRT(P(N+1,1)**2+P(N+1,2)**2+P(N+1,3)**2+P(N+1,5)**2) + P(N+2,4)=SQRT(P(N+2,1)**2+P(N+2,2)**2+P(N+2,3)**2+P(N+2,5)**2) + ND=ND-1 + ENDIF + +C...Check invariant mass of W jets. May give one particle or start over. + 600 IF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48) + &.AND.IABS(K(N+1,2)).LT.10) THEN + PMR=SQRT(MAX(0D0,P(N+1,5)**2+P(N+2,5)**2+2D0*FOUR(N+1,N+2))) + MSTJ(93)=1 + PM1=PYMASS(K(N+1,2)) + MSTJ(93)=1 + PM2=PYMASS(K(N+2,2)) + IF(PMR.GT.PARJ(32)+PM1+PM2) GOTO 610 + KFLDUM=INT(1.5D0+PYR(0)) + CALL PYKFDI(K(N+1,2),-ISIGN(KFLDUM,K(N+1,2)),KFLDMP,KF1) + CALL PYKFDI(K(N+2,2),-ISIGN(KFLDUM,K(N+2,2)),KFLDMP,KF2) + IF(KF1.EQ.0.OR.KF2.EQ.0) GOTO 260 + PSM=PYMASS(KF1)+PYMASS(KF2) + IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.PMR.GT.PARJ(64)+PSM) GOTO 610 + IF(MMAT.GE.43.AND.PMR.GT.0.2D0*PARJ(32)+PSM) GOTO 610 + IF(MMAT.EQ.48) GOTO 390 + IF(ND.EQ.4.OR.KFA.EQ.15) GOTO 260 + K(N+1,1)=1 + KFTEMP=K(N+1,2) + CALL PYKFDI(KFTEMP,K(N+2,2),KFLDMP,K(N+1,2)) + IF(K(N+1,2).EQ.0) GOTO 260 + P(N+1,5)=PYMASS(K(N+1,2)) + K(N+2,2)=K(N+3,2) + P(N+2,5)=P(N+3,5) + PS=P(N+1,5)+P(N+2,5) + IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260 + PV(2,5)=P(N+3,5) + MMAT=0 + ND=2 + GOTO 460 + ENDIF + +C...Phase space decay of partons from W decay. + 610 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.IABS(K(N+1,2)).LT.10) THEN + KFLO(1)=K(N+1,2) + KFLO(2)=K(N+2,2) + K(N+1,1)=K(N+3,1) + K(N+1,2)=K(N+3,2) + DO 620 J=1,5 + PV(1,J)=P(N+1,J)+P(N+2,J) + P(N+1,J)=P(N+3,J) + 620 CONTINUE + PV(1,5)=PMR + N=N+1 + NP=0 + NQ=2 + PS=0D0 + MSTJ(93)=2 + PSQ=PYMASS(KFLO(1)) + MSTJ(93)=2 + PSQ=PSQ+PYMASS(KFLO(2)) + MMAT=11 + GOTO 290 + ENDIF + +C...Boost back for rapidly moving particle. + 630 N=N+ND + IF(MBST.EQ.1) THEN + DO 640 J=1,3 + BE(J)=P(IP,J)/P(IP,4) + 640 CONTINUE + GA=P(IP,4)/P(IP,5) + DO 660 I=NSAV+1,N + BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3) + DO 650 J=1,3 + P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J) + 650 CONTINUE + P(I,4)=GA*(P(I,4)+BEP) + 660 CONTINUE + ENDIF + +C...Fill in position of decay vertex. + DO 680 I=NSAV+1,N + DO 670 J=1,4 + V(I,J)=VDCY(J) + 670 CONTINUE + V(I,5)=0D0 + 680 CONTINUE + +C...Set up for parton shower evolution from jets. + IF(MSTJ(23).GE.1.AND.MMAT.EQ.4.AND.K(NSAV+1,2).EQ.21) THEN + K(NSAV+1,1)=3 + K(NSAV+2,1)=3 + K(NSAV+3,1)=3 + K(NSAV+1,4)=MSTU(5)*(NSAV+2) + K(NSAV+1,5)=MSTU(5)*(NSAV+3) + K(NSAV+2,4)=MSTU(5)*(NSAV+3) + K(NSAV+2,5)=MSTU(5)*(NSAV+1) + K(NSAV+3,4)=MSTU(5)*(NSAV+1) + K(NSAV+3,5)=MSTU(5)*(NSAV+2) + MSTJ(92)=-(NSAV+1) + ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.4) THEN + K(NSAV+2,1)=3 + K(NSAV+3,1)=3 + K(NSAV+2,4)=MSTU(5)*(NSAV+3) + K(NSAV+2,5)=MSTU(5)*(NSAV+3) + K(NSAV+3,4)=MSTU(5)*(NSAV+2) + K(NSAV+3,5)=MSTU(5)*(NSAV+2) + MSTJ(92)=NSAV+2 + ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND. + & IABS(K(NSAV+1,2)).LE.10.AND.IABS(K(NSAV+2,2)).LE.10) THEN + K(NSAV+1,1)=3 + K(NSAV+2,1)=3 + K(NSAV+1,4)=MSTU(5)*(NSAV+2) + K(NSAV+1,5)=MSTU(5)*(NSAV+2) + K(NSAV+2,4)=MSTU(5)*(NSAV+1) + K(NSAV+2,5)=MSTU(5)*(NSAV+1) + MSTJ(92)=NSAV+1 + ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND. + & IABS(K(NSAV+1,2)).LE.20.AND.IABS(K(NSAV+2,2)).LE.20) THEN + MSTJ(92)=NSAV+1 + ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33.AND.IABS(K(NSAV+2,2)).EQ.21) + & THEN + K(NSAV+1,1)=3 + K(NSAV+2,1)=3 + K(NSAV+3,1)=3 + KCP=PYCOMP(K(NSAV+1,2)) + KQP=KCHG(KCP,2)*ISIGN(1,K(NSAV+1,2)) + JCON=4 + IF(KQP.LT.0) JCON=5 + K(NSAV+1,JCON)=MSTU(5)*(NSAV+2) + K(NSAV+2,9-JCON)=MSTU(5)*(NSAV+1) + K(NSAV+2,JCON)=MSTU(5)*(NSAV+3) + K(NSAV+3,9-JCON)=MSTU(5)*(NSAV+2) + MSTJ(92)=NSAV+1 + ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33) THEN + K(NSAV+1,1)=3 + K(NSAV+3,1)=3 + K(NSAV+1,4)=MSTU(5)*(NSAV+3) + K(NSAV+1,5)=MSTU(5)*(NSAV+3) + K(NSAV+3,4)=MSTU(5)*(NSAV+1) + K(NSAV+3,5)=MSTU(5)*(NSAV+1) + MSTJ(92)=NSAV+1 + ENDIF + +C...Mark decayed particle; special option for B-Bbar mixing. + IF(K(IP,1).EQ.5) K(IP,1)=15 + IF(K(IP,1).LE.10) K(IP,1)=11 + IF(MMIX.EQ.1.AND.MSTJ(26).EQ.2.AND.K(IP,1).EQ.11) K(IP,1)=12 + K(IP,4)=NSAV+1 + K(IP,5)=N + + RETURN + END + + +C********************************************************************* + +C...PYDCYK +C...Handles flavour production in the decay of unstable particles +C...and small string clusters. + + SUBROUTINE PYDCYK(KFL1,KFL2,KFL3,KF) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /PYDAT1/,/PYDAT2/ + + +C.. Call PYKFDI directly if no popcorn option is on + IF(MSTJ(12).LT.2) THEN + CALL PYKFDI(KFL1,KFL2,KFL3,KF) + MSTU(124)=KFL3 + RETURN + ENDIF + + KFL3=0 + KF=0 + IF(KFL1.EQ.0) RETURN + KF1A=IABS(KFL1) + KF2A=IABS(KFL2) + + NSTO=130 + NMAX=MIN(MSTU(125),10) + +C.. Identify rank 0 cluster qq + IRANK=1 + IF(KF1A.GT.10.AND.KF1A.LT.10000) IRANK=0 + + IF(KF2A.GT.0)THEN +C.. Join jets: Fails if store not empty + IF(MSTU(121).GT.0) THEN + MSTU(121)=0 + RETURN + ENDIF + CALL PYKFDI(KFL1,KFL2,KFL3,KF) + ELSEIF(KF1A.GT.10.AND.MSTU(121).GT.0)THEN +C.. Pick popcorn meson from store, return same qq, decrease store + KF=MSTU(NSTO+MSTU(121)) + KFL3=-KFL1 + MSTU(121)=MSTU(121)-1 + ELSE +C.. Generate new flavour. Then done if no diquark is generated + 100 CALL PYKFDI(KFL1,0,KFL3,KF) + IF(MSTU(121).EQ.-1) GOTO 100 + MSTU(124)=KFL3 + IF(KF.EQ.0.OR.IABS(KFL3).LE.10) RETURN + +C.. Simple case if no dynamical popcorn suppressions are considered + IF(MSTJ(12).LT.4) THEN + IF(MSTU(121).EQ.0) RETURN + NMES=1 + KFPREV=-KFL3 + CALL PYKFDI(KFPREV,0,KFL3,KFM) +C.. Due to eta+eta' suppr., a qq->M+qq attempt might end as qq->B+q + IF(IABS(KFL3).LE.10)THEN + KFL3=-KFPREV + RETURN + ENDIF + GOTO 120 + ENDIF + +C test output qq against fake Gamma, then return if no popcorn. + GB=2D0 + IF(IRANK.NE.0)THEN + CALL PYZDIS(1,2103,5D0,Z) + GB=5D0*(1D0-Z)/Z + IF(1D0-PARF(192)**GB.LT.PYR(0)) THEN + MSTU(121)=0 + GOTO 100 + ENDIF + ENDIF + IF(MSTU(121).EQ.0) RETURN + +C..Set store size memory. Pick fake dynamical variables of qq. + NMES=MSTU(121) + CALL PYPTDI(1,PX3,PY3) + X=1D0 + POPM=0D0 + G=GB + POPG=GB + +C.. Pick next popcorn meson, test with fake dynamical variables + 110 KFPREV=-KFL3 + PX1=-PX3 + PY1=-PY3 + CALL PYKFDI(KFPREV,0,KFL3,KFM) + IF(MSTU(121).EQ.-1) GOTO 100 + CALL PYPTDI(KFL3,PX3,PY3) + PM=PYMASS(KFM)**2+(PX1+PX3)**2+(PY1+PY3)**2 + CALL PYZDIS(KFPREV,KFL3,PM,Z) + G=(1D0-Z)*(G+PM/Z) + X=(1D0-Z)*X + + PTST=1D0 + GTST=1D0 + RTST=PYR(0) + IF(MSTJ(12).GT.4)THEN + POPMN=SQRT((1D0-X)*(G/X-GB)) + POPM=POPM+PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3) + PTST=EXP((POPM-POPMN)*PARF(193)) + POPM=POPMN + ENDIF + IF(IRANK.NE.0)THEN + POPGN=X*GB + GTST=(1D0-PARF(192)**POPGN)/(1D0-PARF(192)**POPG) + POPG=POPGN + ENDIF + IF(RTST.GT.PTST*GTST)THEN + MSTU(121)=0 + IF(RTST.GT.PTST) MSTU(121)=-1 + GOTO 100 + ENDIF + +C.. Store meson + 120 IF(NMES.LE.NMAX) MSTU(NSTO+MSTU(121)+1)=KFM + IF(MSTU(121).GT.0) GOTO 110 + +C.. Test accepted system size. If OK set global popcorn size variable. + IF(NMES.GT.NMAX)THEN + KF=0 + KFL3=0 + RETURN + ENDIF + MSTU(121)=NMES + ENDIF + + RETURN + END + +C******************************************************************** + +C...PYKFDI +C...Generates a new flavour pair and combines off a hadron + + SUBROUTINE PYKFDI(KFL1,KFL2,KFL3,KF) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /PYDAT1/,/PYDAT2/ +C...Local arrays. + DIMENSION PD(7) + + IF(MSTU(123).EQ.0.AND.MSTJ(12).GE.0) CALL PYKFIN + +C...Default flavour values. Input consistency checks. + KF1A=IABS(KFL1) + KF2A=IABS(KFL2) + KFL3=0 + KF=0 + IF(KF1A.EQ.0) RETURN + IF(KF2A.NE.0)THEN + IF(KF1A.LE.10.AND.KF2A.LE.10.AND.KFL1*KFL2.GT.0) RETURN + IF(KF1A.GT.10.AND.KF2A.GT.10) RETURN + IF((KF1A.GT.10.OR.KF2A.GT.10).AND.KFL1*KFL2.LT.0) RETURN + ENDIF + +C...Check if tabulated flavour probabilities are to be used. + IF(MSTJ(15).EQ.1) THEN + IF(MSTJ(12).GE.5) CALL PYERRM(29, + & '(PYKFDI:) Sorry, option MSTJ(15)=1 not available' // + & ' together with MSTJ(12)>=5 modification') + KTAB1=-1 + IF(KF1A.GE.1.AND.KF1A.LE.6) KTAB1=KF1A + KFL1A=MOD(KF1A/1000,10) + KFL1B=MOD(KF1A/100,10) + KFL1S=MOD(KF1A,10) + IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1B.GE.1.AND.KFL1B.LE.4) + & KTAB1=6+KFL1A*(KFL1A-2)+2*KFL1B+(KFL1S-1)/2 + IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1A.EQ.KFL1B) KTAB1=KTAB1-1 + IF(KF1A.GE.1.AND.KF1A.LE.6) KFL1A=KF1A + KTAB2=0 + IF(KF2A.NE.0) THEN + KTAB2=-1 + IF(KF2A.GE.1.AND.KF2A.LE.6) KTAB2=KF2A + KFL2A=MOD(KF2A/1000,10) + KFL2B=MOD(KF2A/100,10) + KFL2S=MOD(KF2A,10) + IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2B.GE.1.AND.KFL2B.LE.4) + & KTAB2=6+KFL2A*(KFL2A-2)+2*KFL2B+(KFL2S-1)/2 + IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2A.EQ.KFL2B) KTAB2=KTAB2-1 + ENDIF + IF(KTAB1.GE.0.AND.KTAB2.GE.0) GOTO 140 + ENDIF + +C.. Recognize rank 0 diquark case + 100 IRANK=1 + KFDIQ=MAX(KF1A,KF2A) + IF(KFDIQ.GT.10.AND.KFDIQ.LT.10000) IRANK=0 + +C.. Join two flavours to meson or baryon. Test for popcorn. + IF(KF2A.GT.0)THEN + MBARY=0 + IF(KFDIQ.GT.10) THEN + IF(IRANK.EQ.0.AND.MSTJ(12).LT.5) + & CALL PYNMES(KFDIQ) + IF(MSTU(121).NE.0) THEN + MSTU(121)=0 + RETURN + ENDIF + MBARY=2 + ENDIF + KFQOLD=KF1A + KFQVER=KF2A + GOTO 130 + ENDIF + +C.. Separate incoming flavours, curtain flavour consistency check + KFIN=KFL1 + KFQOLD=KF1A + KFQPOP=KF1A/10000 + IF(KF1A.GT.10)THEN + KFIN=-KFL1 + KFL1A=MOD(KF1A/1000,10) + KFL1B=MOD(KF1A/100,10) + IF(IRANK.EQ.0)THEN + QAWT=1D0 + IF(KFL1A.GE.3) QAWT=PARF(136+KFL1A/4) + IF(KFL1B.GE.3) QAWT=QAWT/PARF(136+KFL1B/4) + KFQPOP=KFL1A+(KFL1B-KFL1A)*INT(1D0/(QAWT+1D0)+PYR(0)) + ENDIF + IF(KFQPOP.NE.KFL1B.AND.KFQPOP.NE.KFL1A) THEN + MSTU(121)=0 + RETURN + ENDIF + KFQOLD=KFL1A+KFL1B-KFQPOP + ENDIF + +C...Meson/baryon choice. Set number of mesons if starting a popcorn +C...system. + 110 MBARY=0 + IF(KF1A.LE.10.AND.MSTJ(12).GT.0)THEN + IF(MSTU(121).EQ.-1.OR.(1D0+PARJ(1))*PYR(0).GT.1D0)THEN + MBARY=1 + CALL PYNMES(0) + ENDIF + ELSEIF(KF1A.GT.10)THEN + MBARY=2 + IF(IRANK.EQ.0) CALL PYNMES(KF1A) + IF(MSTU(121).GT.0) MBARY=-1 + ENDIF + +C..x->H+q: Choose single vertex quark. Jump to form hadron. + IF(MBARY.EQ.0.OR.MBARY.EQ.2)THEN + KFQVER=1+INT((2D0+PARJ(2))*PYR(0)) + KFL3=ISIGN(KFQVER,-KFIN) + GOTO 130 + ENDIF + +C..x->H+qq: (IDW=proper PARF position for diquark weights) + IDW=160 + IF(MBARY.EQ.1)THEN + IF(MSTU(121).EQ.0) IDW=150 + SQWT=PARF(IDW+1) + IF(MSTU(121).GT.0) SQWT=SQWT*PARF(135)*PARF(138)**MSTU(121) + KFQPOP=1+INT((2D0+SQWT)*PYR(0)) +C.. Shift to s-curtain parameters if needed + IF(KFQPOP.GE.3.AND.MSTJ(12).GE.5)THEN + PARF(194)=PARF(138)*PARF(139) + PARF(193)=PARJ(8)+PARJ(9) + ENDIF + ENDIF + +C.. x->H+qq: Get vertex quark + IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN + IDW=MSTU(122) + MSTU(121)=MSTU(121)-1 + IF(IDW.EQ.170) THEN + IF(MSTU(121).EQ.0)THEN + IPOS=3*MIN(KFQPOP-1,2)+MIN(KFQOLD-1,2) + ELSE + IPOS=3*3+3*MAX(0,MIN(KFQPOP-2,1))+MIN(KFQOLD-1,2) + ENDIF + ELSE + IF(MSTU(121).EQ.0)THEN + IPOS=3*5+5*MIN(KFQPOP-1,3)+MIN(KFQOLD-1,4) + ELSE + IPOS=3*5+5*4+MIN(KFQOLD-1,4) + ENDIF + ENDIF + IPOS=200+30*IPOS+1 + + IMES=-1 + RMES=PYR(0)*PARF(194) + 120 IMES=IMES+1 + RMES=RMES-PARF(IPOS+IMES) + IF(IMES.EQ.30) THEN + MSTU(121)=-1 + KF=-111 + RETURN + ENDIF + IF(RMES.GT.0D0) GOTO 120 + KMUL=IMES/5 + KFJ=2*KMUL+1 + IF(KMUL.EQ.2) KFJ=10003 + IF(KMUL.EQ.3) KFJ=10001 + IF(KMUL.EQ.4) KFJ=20003 + IF(KMUL.EQ.5) KFJ=5 + IDIAG=0 + KFQVER=MOD(IMES,5)+1 + IF(KFQVER.GE.KFQOLD) KFQVER=KFQVER+1 + IF(KFQVER.GT.3)THEN + IDIAG=KFQVER-3 + KFQVER=KFQOLD + ENDIF + ELSE + IF(MBARY.EQ.-1) IDW=170 + SQWT=PARF(IDW+2) + IF(KFQPOP.EQ.3) SQWT=PARF(IDW+3) + IF(KFQPOP.GT.3) SQWT=PARF(IDW+3)*(1D0/PARF(IDW+5)+1D0)/2D0 + KFQVER=MIN(3,1+INT((2D0+SQWT)*PYR(0))) + IF(KFQPOP.LT.3.AND.KFQVER.LT.3)THEN + KFQVER=KFQPOP + IF(PYR(0).GT.PARF(IDW+4)) KFQVER=3-KFQPOP + ENDIF + ENDIF + +C..x->H+qq: form outgoing diquark with KFQPOP flag at 10000-pos + KFLDS=3 + IF(KFQPOP.NE.KFQVER)THEN + SWT=PARF(IDW+7) + IF(KFQVER.EQ.3) SWT=PARF(IDW+6) + IF(KFQPOP.GE.3) SWT=PARF(IDW+5) + IF((1D0+SWT)*PYR(0).LT.1D0) KFLDS=1 + ENDIF + KFDIQ=900*MAX(KFQVER,KFQPOP)+100*(KFQVER+KFQPOP)+KFLDS + & +10000*KFQPOP + KFL3=ISIGN(KFDIQ,KFIN) + +C..x->M+y: flavour for meson. + 130 IF(MBARY.LE.0)THEN + KFLA=MAX(KFQOLD,KFQVER) + KFLB=MIN(KFQOLD,KFQVER) + KFS=ISIGN(1,KFL1) + IF(KFLA.NE.KFQOLD) KFS=-KFS +C... Form meson, with spin and flavour mixing for diagonal states. + IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN + IF(IDIAG.GT.0) KF=110*IDIAG+KFJ + IF(IDIAG.EQ.0) KF=(100*KFLA+10*KFLB+KFJ)*KFS*(-1)**KFLA + RETURN + ENDIF + IF(KFLA.LE.2) KMUL=INT(PARJ(11)+PYR(0)) + IF(KFLA.EQ.3) KMUL=INT(PARJ(12)+PYR(0)) + IF(KFLA.GE.4) KMUL=INT(PARJ(13)+PYR(0)) + IF(KMUL.EQ.0.AND.PARJ(14).GT.0D0)THEN + IF(PYR(0).LT.PARJ(14)) KMUL=2 + ELSEIF(KMUL.EQ.1.AND.PARJ(15)+PARJ(16)+PARJ(17).GT.0D0)THEN + RMUL=PYR(0) + IF(RMUL.LT.PARJ(15)) KMUL=3 + IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)) KMUL=4 + IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)+PARJ(17)) KMUL=5 + ENDIF + KFLS=3 + IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1 + IF(KMUL.EQ.5) KFLS=5 + IF(KFLA.NE.KFLB)THEN + KF=(100*KFLA+10*KFLB+KFLS)*KFS*(-1)**KFLA + ELSE + RMIX=PYR(0) + IMIX=2*KFLA+10*KMUL + IF(KFLA.LE.3) KF=110*(1+INT(RMIX+PARF(IMIX-1))+ + & INT(RMIX+PARF(IMIX)))+KFLS + IF(KFLA.GE.4) KF=110*KFLA+KFLS + ENDIF + IF(KMUL.EQ.2.OR.KMUL.EQ.3) KF=KF+ISIGN(10000,KF) + IF(KMUL.EQ.4) KF=KF+ISIGN(20000,KF) + +C..Optional extra suppression of eta and eta'. +C..Allow shift to qq->B+q in old version (set IRANK to 0) + IF(KF.EQ.221.OR.KF.EQ.331)THEN + IF(PYR(0).GT.PARJ(25+KF/300))THEN + IF(KF2A.GT.0) GOTO 130 + IF(MSTJ(12).LT.4) IRANK=0 + GOTO 110 + ENDIF + ENDIF + MSTU(121)=0 + +C.. x->B+y: Flavour for baryon + ELSE + KFLA=KFQVER + IF(KF1A.LE.10) KFLA=KFQOLD + KFLB=MOD(KFDIQ/1000,10) + KFLC=MOD(KFDIQ/100,10) + KFLDS=MOD(KFDIQ,10) + KFLD=MAX(KFLA,KFLB,KFLC) + KFLF=MIN(KFLA,KFLB,KFLC) + KFLE=KFLA+KFLB+KFLC-KFLD-KFLF + +C... SU(6) factors for formation of baryon. + KBARY=3 + KDMAX=5 + KFLG=KFLB + IF(KFLB.NE.KFLC)THEN + KBARY=2*KFLDS-1 + KDMAX=1+KFLDS/2 + IF(KFLB.GT.2) KDMAX=KDMAX+2 + ENDIF + IF(KFLA.NE.KFLB.AND.KFLA.NE.KFLC)THEN + KBARY=KBARY+1 + KFLG=KFLA + ENDIF + + SU6MAX=PARF(140+KDMAX) + SU6DEC=PARJ(18) + SU6S =PARF(146) + IF(MSTJ(12).GE.5.AND.IRANK.EQ.0) THEN + SU6MAX=1D0 + SU6DEC=1D0 + SU6S =1D0 + ENDIF + SU6OCT=PARF(60+KBARY) + IF(KFLG.GT.MAX(KFLA+KFLB-KFLG,2))THEN + SU6OCT=SU6OCT*4*SU6S/(3*SU6S+1) + IF(KBARY.EQ.2) SU6OCT=PARF(60+KBARY)*4/(3*SU6S+1) + ELSE + IF(KBARY.EQ.6) SU6OCT=SU6OCT*(3+SU6S)/(3*SU6S+1) + ENDIF + SU6WT=SU6OCT+SU6DEC*PARF(70+KBARY) + +C.. SU(6) test. Old options enforce new baryon if q->B+qq is rejected. + IF(SU6WT.LT.PYR(0)*SU6MAX.AND.KF2A.EQ.0)THEN + MSTU(121)=0 + IF(MSTJ(12).LE.2.AND.MBARY.EQ.1) MSTU(121)=-1 + GOTO 110 + ENDIF + +C.. Form baryon. Distinguish Lambda- and Sigmalike baryons. + KSIG=1 + KFLS=2 + IF(SU6WT*PYR(0).GT.SU6OCT) KFLS=4 + IF(KFLS.EQ.2.AND.KFLD.GT.KFLE.AND.KFLE.GT.KFLF)THEN + KSIG=KFLDS/3 + IF(KFLA.NE.KFLD) KSIG=INT(3*SU6S/(3*SU6S+KFLDS**2)+PYR(0)) + ENDIF + KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+KFLS,KFL1) + IF(KSIG.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+KFLS,KFL1) + ENDIF + RETURN + +C...Use tabulated probabilities to select new flavour and hadron. + 140 IF(KTAB2.EQ.0.AND.MSTJ(12).LE.0) THEN + KT3L=1 + KT3U=6 + ELSEIF(KTAB2.EQ.0.AND.KTAB1.GE.7.AND.MSTJ(12).LE.1) THEN + KT3L=1 + KT3U=6 + ELSEIF(KTAB2.EQ.0) THEN + KT3L=1 + KT3U=22 + ELSE + KT3L=KTAB2 + KT3U=KTAB2 + ENDIF + RFL=0D0 + DO 160 KTS=0,2 + DO 150 KT3=KT3L,KT3U + RFL=RFL+PARF(120+80*KTAB1+25*KTS+KT3) + 150 CONTINUE + 160 CONTINUE + RFL=PYR(0)*RFL + DO 180 KTS=0,2 + KTABS=KTS + DO 170 KT3=KT3L,KT3U + KTAB3=KT3 + RFL=RFL-PARF(120+80*KTAB1+25*KTS+KT3) + IF(RFL.LE.0D0) GOTO 190 + 170 CONTINUE + 180 CONTINUE + 190 CONTINUE + +C...Reconstruct flavour of produced quark/diquark. + IF(KTAB3.LE.6) THEN + KFL3A=KTAB3 + KFL3B=0 + KFL3=ISIGN(KFL3A,KFL1*(2*KTAB1-13)) + ELSE + KFL3A=1 + IF(KTAB3.GE.8) KFL3A=2 + IF(KTAB3.GE.11) KFL3A=3 + IF(KTAB3.GE.16) KFL3A=4 + KFL3B=(KTAB3-6-KFL3A*(KFL3A-2))/2 + KFL3=1000*KFL3A+100*KFL3B+1 + IF(KFL3A.EQ.KFL3B.OR.KTAB3.NE.6+KFL3A*(KFL3A-2)+2*KFL3B) KFL3= + & KFL3+2 + KFL3=ISIGN(KFL3,KFL1*(13-2*KTAB1)) + ENDIF + +C...Reconstruct meson code. + IF(KFL3A.EQ.KFL1A.AND.KFL3B.EQ.KFL1B.AND.(KFL3A.LE.3.OR. + &KFL3B.NE.0)) THEN + RFL=PYR(0)*(PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+ + & 25*KTABS)+PARF(145+80*KTAB1+25*KTABS)) + KF=110+2*KTABS+1 + IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)) KF=220+2*KTABS+1 + IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+ + & 25*KTABS)) KF=330+2*KTABS+1 + ELSEIF(KTAB1.LE.6.AND.KTAB3.LE.6) THEN + KFLA=MAX(KTAB1,KTAB3) + KFLB=MIN(KTAB1,KTAB3) + KFS=ISIGN(1,KFL1) + IF(KFLA.NE.KF1A) KFS=-KFS + KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA + ELSEIF(KTAB1.GE.7.AND.KTAB3.GE.7) THEN + KFS=ISIGN(1,KFL1) + IF(KFL1A.EQ.KFL3A) THEN + KFLA=MAX(KFL1B,KFL3B) + KFLB=MIN(KFL1B,KFL3B) + IF(KFLA.NE.KFL1B) KFS=-KFS + ELSEIF(KFL1A.EQ.KFL3B) THEN + KFLA=KFL3A + KFLB=KFL1B + KFS=-KFS + ELSEIF(KFL1B.EQ.KFL3A) THEN + KFLA=KFL1A + KFLB=KFL3B + ELSEIF(KFL1B.EQ.KFL3B) THEN + KFLA=MAX(KFL1A,KFL3A) + KFLB=MIN(KFL1A,KFL3A) + IF(KFLA.NE.KFL1A) KFS=-KFS + ELSE + CALL PYERRM(2,'(PYKFDI:) no matching flavours for qq -> qq') + GOTO 100 + ENDIF + KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA + +C...Reconstruct baryon code. + ELSE + IF(KTAB1.GE.7) THEN + KFLA=KFL3A + KFLB=KFL1A + KFLC=KFL1B + ELSE + KFLA=KFL1A + KFLB=KFL3A + KFLC=KFL3B + ENDIF + KFLD=MAX(KFLA,KFLB,KFLC) + KFLF=MIN(KFLA,KFLB,KFLC) + KFLE=KFLA+KFLB+KFLC-KFLD-KFLF + IF(KTABS.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+2,KFL1) + IF(KTABS.GE.1) KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+2*KTABS,KFL1) + ENDIF + +C...Check that constructed flavour code is an allowed one. + IF(KFL2.NE.0) KFL3=0 + KC=PYCOMP(KF) + IF(KC.EQ.0) THEN + CALL PYERRM(2,'(PYKFDI:) user-defined flavour probabilities '// + & 'failed') + GOTO 100 + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYNMES +C...Generates number of popcorn mesons and stores some relevant +C...parameters. + + SUBROUTINE PYNMES(KFDIQ) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /PYDAT1/,/PYDAT2/ + + MSTU(121)=0 + IF(MSTJ(12).LT.2) RETURN + +C..Old version: Get 1 or 0 popcorn mesons + IF(MSTJ(12).LT.5)THEN + POPWT=PARF(131) + IF(KFDIQ.NE.0) THEN + KFDIQA=IABS(KFDIQ) + KFA=MOD(KFDIQA/1000,10) + KFB=MOD(KFDIQA/100,10) + KFS=MOD(KFDIQA,10) + POPWT=PARF(132) + IF(KFA.EQ.3) POPWT=PARF(133) + IF(KFB.EQ.3) POPWT=PARF(134) + IF(KFS.EQ.1) POPWT=POPWT*SQRT(PARJ(4)) + ENDIF + MSTU(121)=INT(POPWT/(1D0+POPWT)+PYR(0)) + RETURN + ENDIF + +C..New version: Store popcorn- or rank 0 diquark parameters + MSTU(122)=170 + PARF(193)=PARJ(8) + PARF(194)=PARF(139) + IF(KFDIQ.NE.0) THEN + MSTU(122)=180 + PARF(193)=PARJ(10) + PARF(194)=PARF(140) + ENDIF + IF(PARF(194).LT.1D-5.OR.PARF(194).GT.1D0-1D-5) THEN + IF(PARF(194).GT.1D0-1D-5) CALL PYERRM(9, + & '(PYNMES:) Neglecting too large popcorn possibility') + RETURN + ENDIF + +C..New version: Get number of popcorn mesons + 100 RTST=PYR(0) + MSTU(121)=-1 + 110 MSTU(121)=MSTU(121)+1 + RTST=RTST/PARF(194) + IF(RTST.LT.1D0) GOTO 110 + IF(KFDIQ.EQ.0.AND.PYR(0)*(2D0+PARF(135)*PARF(161)).GT. + & (2D0+PARF(135)*PARF(161)*PARF(138)**MSTU(121))) GOTO 100 + RETURN + END + +C*************************************************************** + +C...PYKFIN +C...Precalculates a set of diquark and popcorn weights. + + SUBROUTINE PYKFIN + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /PYDAT1/,/PYDAT2/ + + DIMENSION SU6(12),SU6M(7),QBB(7),QBM(7),DMB(14) + + + MSTU(123)=1 +C..Diquark indices for dimensional variables + IUD1=1 + IUU1=2 + IUS0=3 + ISU0=4 + IUS1=5 + ISU1=6 + ISS1=7 + +C.. *** SU(6) factors ** +C..Modify with decuplet- (and Sigma/Lambda-) suppression. + PARF(146)=1D0 + IF(MSTJ(12).GE.5) PARF(146)=3D0*PARJ(18)/(2D0*PARJ(18)+1D0) + IF(PARJ(18).LT.1D0-1D-5.AND.MSTJ(12).LT.5) CALL PYERRM(9, + & '(PYKFIN:) PARJ(18)<1 combined with 0 B+B+.. + DO 120 I=1,7 + QBB(I)=QBB(I)*QBM(I) + 120 CONTINUE + + IF(MSTJ(12).GE.5)THEN +C..New version: tau for rank 0 diquark. + DMB(7+ISU0)=EXP(-PARJ(10)*PMUS0) + DMB(7+IUS0)=PARJ(2)*DMB(7+ISU0) + DMB(7+ISS1)=6D0*PARJ(2)*EXP(-PARJ(10)*PMSS1)*DMB(7+ISU0) + DMB(7+IUU1)=6D0*EXP(-PARJ(10)*PMUD1) + DMB(7+ISU1)=3D0*EXP(-PARJ(10)*PMUS1)*DMB(7+ISU0) + DMB(7+IUS1)=PARJ(2)*DMB(7+ISU1) + DMB(7+IUD1)=DMB(7+IUU1)/2D0 + +C..New version: curtain flavour ratios. +C.. s/u for q->B+M+... +C.. s/u for rank 0 diquark: su -> ...M+B+... +C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+... + WU=1D0+QBM(IUD1)+QBM(IUS0)+QBM(IUS1)+QBM(IUU1) + PARF(135)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/WU + WU=1D0+DMB(7+IUD1)+DMB(7+IUS0)+DMB(7+IUS1)+DMB(7+IUU1) + PARF(136)=(2D0*(DMB(7+ISU0)+DMB(7+ISU1))+DMB(7+ISS1))/WU + PARF(137)=(DMB(7+ISU0)+DMB(7+ISU1))* + & (2D0+DMB(7+ISS1)/(2D0*DMB(7+ISU1)))/WU + ELSE +C..Old version: reset unused rank 0 diquark weights and +C.. unused diquark SU(6) survival weights + DO 130 I=1,7 + IF(MSTJ(12).LT.3) DMB(I)=1D0 + DMB(7+I)=1D0 + 130 CONTINUE + +C..Old version: Shuffle PARJ(7) into tau + QBM(IUS0)=QBM(IUS0)*PARJ(7) + QBM(ISS1)=QBM(ISS1)*PARJ(7) + QBM(IUS1)=QBM(IUS1)*PARJ(7) + +C..Old version: curtain flavour ratios. +C.. s/u for q->B+M+... +C.. s/u for rank 0 diquark: su -> ...M+B+... +C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+... + WU=1D0+QBM(IUD1)+QBM(IUS0)+QBM(IUS1)+QBM(IUU1) + PARF(135)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/WU + PARF(136)=PARF(135)*PARJ(6)*QBM(ISU0)/QBM(IUS0) + PARF(137)=(1D0+QBM(IUD1))*(2D0+QBM(IUS0))/WU + ENDIF + +C..Combine diquark SU(6) survival, SU(6)max, tau and T into factors for: +C.. rank0 D->M+B+..; D->M+B+..; q->B+M+..; q->B+B.. + DO 140 I=1,7 + DMB(7+I)=DMB(7+I)*DMB(I) + DMB(I)=DMB(I)*QBM(I) + QBM(I)=QBM(I)*SU6M(I)/SU6MUD + QBB(I)=QBB(I)*SU6M(I)/SU6MUD + 140 CONTINUE + +C.. *** Popcorn factors *** + + IF(MSTJ(12).LT.5)THEN +C.. Old version: Resulting popcorn weights. + PARF(138)=PARJ(6) + WS=PARF(135)*PARF(138) + WQ=WU*PARJ(5)/3D0 + PARF(132)=WQ*QBM(IUD1)/QBB(IUD1) + PARF(133)=WQ* + & (QBM(IUS1)/QBB(IUS1)+WS*QBM(ISU1)/QBB(ISU1))/2D0 + PARF(134)=WQ*WS*QBM(ISS1)/QBB(ISS1) + PARF(131)=WQ*(1D0+QBM(IUD1)+QBM(IUU1)+QBM(IUS0)+QBM(IUS1)+ + & WS*(QBM(ISU0)+QBM(ISU1)+QBM(ISS1)/2D0))/ + & (1D0+QBB(IUD1)+QBB(IUU1)+ + & 2D0*(QBB(IUS0)+QBB(IUS1))+QBB(ISS1)/2D0) + ELSE +C..New version: Store weights for popcorn mesons, +C..get prel. popcorn weights. + DO 150 IPOS=201,1400 + PARF(IPOS)=0D0 + 150 CONTINUE + DO 160 I=138,140 + PARF(I)=0D0 + 160 CONTINUE + IPOS=200 + PARF(193)=PARJ(8) + DO 240 MR=0,7,7 + IF(MR.EQ.7) PARF(193)=PARJ(10) + SQWT=2D0*(DMB(MR+IUS0)+DMB(MR+IUS1))/ + & (1D0+DMB(MR+IUD1)+DMB(MR+IUU1)) + QQWT=DMB(MR+IUU1)/(1D0+DMB(MR+IUD1)+DMB(MR+IUU1)) + DO 230 NMES=0,1 + IF(NMES.EQ.1) SQWT=PARJ(2) + DO 220 KFQPOP=1,4 + IF(MR.EQ.0.AND.KFQPOP.GT.3) GOTO 220 + IF(NMES.EQ.0.AND.KFQPOP.GE.3)THEN + SQWT=DMB(MR+ISS1)/(DMB(MR+ISU0)+DMB(MR+ISU1)) + QQWT=0.5D0 + IF(MR.EQ.0) PARF(193)=PARJ(8)+PARJ(9) + IF(KFQPOP.EQ.4) SQWT=SQWT*(1D0/DMB(7+ISU1)+1D0)/2D0 + ENDIF + DO 210 KFQOLD =1,5 + IF(MR.EQ.0.AND.KFQOLD.GT.3) GOTO 210 + IF(NMES.EQ.1) THEN + IF(MR.EQ.0.AND.KFQPOP.EQ.1) GOTO 210 + IF(MR.EQ.7.AND.KFQPOP.NE.1) GOTO 210 + ENDIF + WTTOT=0D0 + WTFAIL=0D0 + DO 190 KMUL=0,5 + PJWT=PARJ(12+KMUL) + IF(KMUL.EQ.0) PJWT=1D0-PARJ(14) + IF(KMUL.EQ.1) PJWT=1D0-PARJ(15)-PARJ(16)-PARJ(17) + IF(PJWT.LE.0D0) GOTO 190 + IF(PJWT.GT.1D0) PJWT=1D0 + IMES=5*KMUL + IMIX=2*KFQOLD+10*KMUL + KFJ=2*KMUL+1 + IF(KMUL.EQ.2) KFJ=10003 + IF(KMUL.EQ.3) KFJ=10001 + IF(KMUL.EQ.4) KFJ=20003 + IF(KMUL.EQ.5) KFJ=5 + DO 180 KFQVER =1,3 + KFLA=MAX(KFQOLD,KFQVER) + KFLB=MIN(KFQOLD,KFQVER) + SWT=PARJ(11+KFLA/3+KFLA/4) + IF(KMUL.EQ.0.OR.KMUL.EQ.2) SWT=1D0-SWT + SWT=SWT*PJWT + QWT=SQWT/(2D0+SQWT) + IF(KFQVER.LT.3)THEN + IF(KFQVER.EQ.KFQPOP) QWT=(1D0-QWT)*QQWT + IF(KFQVER.NE.KFQPOP) QWT=(1D0-QWT)*(1D0-QQWT) + ENDIF + IF(KFQVER.NE.KFQOLD)THEN + IMES=IMES+1 + KFM=100*KFLA+10*KFLB+KFJ + PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3) + PARF(IPOS+IMES)=QWT*SWT*EXP(-PARF(193)*PMM) + WTTOT=WTTOT+PARF(IPOS+IMES) + ELSE + DO 170 ID=3,5 + IF(ID.EQ.3) DWT=1D0-PARF(IMIX-1) + IF(ID.EQ.4) DWT=PARF(IMIX-1)-PARF(IMIX) + IF(ID.EQ.5) DWT=PARF(IMIX) + KFM=110*(ID-2)+KFJ + PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3) + PARF(IPOS+5*KMUL+ID)=QWT*SWT*DWT*EXP(-PARF(193)*PMM) + IF(KMUL.EQ.0.AND.ID.GT.3) THEN + WTFAIL=WTFAIL+QWT*SWT*DWT*(1D0-PARJ(21+ID)) + PARF(IPOS+5*KMUL+ID)= + & PARF(IPOS+5*KMUL+ID)*PARJ(21+ID) + ENDIF + WTTOT=WTTOT+PARF(IPOS+5*KMUL+ID) + 170 CONTINUE + ENDIF + 180 CONTINUE + 190 CONTINUE + DO 200 IMES=1,30 + PARF(IPOS+IMES)=PARF(IPOS+IMES)/(1D0-WTFAIL) + 200 CONTINUE + IF(MR.EQ.7) PARF(140)= + & MAX(PARF(140),WTTOT/(1D0-WTFAIL)) + IF(MR.EQ.0) PARF(139-KFQPOP/3)= + & MAX(PARF(139-KFQPOP/3),WTTOT/(1D0-WTFAIL)) + IPOS=IPOS+30 + 210 CONTINUE + 220 CONTINUE + 230 CONTINUE + 240 CONTINUE + IF(PARF(139).GT.1D-10) PARF(138)=PARF(138)/PARF(139) + MSTU(121)=0 + + ENDIF + +C..Recombine diquark weights to flavour and spin ratios + PARF(151)=(2D0*(QBB(ISU0)+QBB(ISU1))+QBB(ISS1))/ + & (1D0+QBB(IUD1)+QBB(IUU1)+QBB(IUS0)+QBB(IUS1)) + PARF(152)=2D0*(QBB(IUS0)+QBB(IUS1))/(1D0+QBB(IUD1)+QBB(IUU1)) + PARF(153)=QBB(ISS1)/(QBB(ISU0)+QBB(ISU1)) + PARF(154)=QBB(IUU1)/(1D0+QBB(IUD1)+QBB(IUU1)) + PARF(155)=QBB(ISU1)/QBB(ISU0) + PARF(156)=QBB(IUS1)/QBB(IUS0) + PARF(157)=QBB(IUD1) + + PARF(161)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/ + & (1D0+QBM(IUD1)+QBM(IUU1)+QBM(IUS0)+QBM(IUS1)) + PARF(162)=2D0*(QBM(IUS0)+QBM(IUS1))/(1D0+QBM(IUD1)+QBM(IUU1)) + PARF(163)=QBM(ISS1)/(QBM(ISU0)+QBM(ISU1)) + PARF(164)=QBM(IUU1)/(1D0+QBM(IUD1)+QBM(IUU1)) + PARF(165)=QBM(ISU1)/QBM(ISU0) + PARF(166)=QBM(IUS1)/QBM(IUS0) + PARF(167)=QBM(IUD1) + + PARF(171)=(2D0*(DMB(ISU0)+DMB(ISU1))+DMB(ISS1))/ + & (1D0+DMB(IUD1)+DMB(IUU1)+DMB(IUS0)+DMB(IUS1)) + PARF(172)=2D0*(DMB(IUS0)+DMB(IUS1))/(1D0+DMB(IUD1)+DMB(IUU1)) + PARF(173)=DMB(ISS1)/(DMB(ISU0)+DMB(ISU1)) + PARF(174)=DMB(IUU1)/(1D0+DMB(IUD1)+DMB(IUU1)) + PARF(175)=DMB(ISU1)/DMB(ISU0) + PARF(176)=DMB(IUS1)/DMB(IUS0) + PARF(177)=DMB(IUD1) + + PARF(185)=DMB(7+ISU1)/DMB(7+ISU0) + PARF(186)=DMB(7+IUS1)/DMB(7+IUS0) + PARF(187)=DMB(7+IUD1) + + RETURN + END + + +C********************************************************************* + +C...PYPTDI +C...Generates transverse momentum according to a Gaussian. + + SUBROUTINE PYPTDI(KFL,PX,PY) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + SAVE /PYDAT1/ + +C...Generate p_T and azimuthal angle, gives p_x and p_y. + KFLA=IABS(KFL) + PT=PARJ(21)*SQRT(-LOG(MAX(1D-10,PYR(0)))) + IF(PARJ(23).GT.PYR(0)) PT=PARJ(24)*PT + IF(MSTJ(91).EQ.1) PT=PARJ(22)*PT + IF(KFLA.EQ.0.AND.MSTJ(13).LE.0) PT=0D0 + PHI=PARU(2)*PYR(0) + PX=PT*COS(PHI) + PY=PT*SIN(PHI) + + RETURN + END + +C********************************************************************* + +C...PYZDIS +C...Generates the longitudinal splitting variable z. + + SUBROUTINE PYZDIS(KFL1,KFL2,PR,Z) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /PYDAT1/,/PYDAT2/ + +C...Check if heavy flavour fragmentation. + KFLA=IABS(KFL1) + KFLB=IABS(KFL2) + KFLH=KFLA + IF(KFLA.GE.10) KFLH=MOD(KFLA/1000,10) + +C...Lund symmetric scaling function: determine parameters of shape. + IF(MSTJ(11).EQ.1.OR.(MSTJ(11).EQ.3.AND.KFLH.LE.3).OR. + &MSTJ(11).GE.4) THEN + FA=PARJ(41) + IF(MSTJ(91).EQ.1) FA=PARJ(43) + IF(KFLB.GE.10) FA=FA+PARJ(45) + FBB=PARJ(42) + IF(MSTJ(91).EQ.1) FBB=PARJ(44) + FB=FBB*PR + FC=1D0 + IF(KFLA.GE.10) FC=FC-PARJ(45) + IF(KFLB.GE.10) FC=FC+PARJ(45) + IF(MSTJ(11).GE.4.AND.(KFLH.EQ.4.OR.KFLH.EQ.5)) THEN + FRED=PARJ(46) + IF(MSTJ(11).EQ.5.AND.KFLH.EQ.5) FRED=PARJ(47) + FC=FC+FRED*FBB*PARF(100+KFLH)**2 + ENDIF + MC=1 + IF(ABS(FC-1D0).GT.0.01D0) MC=2 + +C...Determine position of maximum. Special cases for a = 0 or a = c. + IF(FA.LT.0.02D0) THEN + MA=1 + ZMAX=1D0 + IF(FC.GT.FB) ZMAX=FB/FC + ELSEIF(ABS(FC-FA).LT.0.01D0) THEN + MA=2 + ZMAX=FB/(FB+FC) + ELSE + MA=3 + ZMAX=0.5D0*(FB+FC-SQRT((FB-FC)**2+4D0*FA*FB))/(FC-FA) + IF(ZMAX.GT.0.9999D0.AND.FB.GT.100D0) ZMAX=MIN(ZMAX,1D0-FA/FB) + ENDIF + +C...Subdivide z range if distribution very peaked near endpoint. + MMAX=2 + IF(ZMAX.LT.0.1D0) THEN + MMAX=1 + ZDIV=2.75D0*ZMAX + IF(MC.EQ.1) THEN + FINT=1D0-LOG(ZDIV) + ELSE + ZDIVC=ZDIV**(1D0-FC) + FINT=1D0+(1D0-1D0/ZDIVC)/(FC-1D0) + ENDIF + ELSEIF(ZMAX.GT.0.85D0.AND.FB.GT.1D0) THEN + MMAX=3 + FSCB=SQRT(4D0+(FC/FB)**2) + ZDIV=FSCB-1D0/ZMAX-(FC/FB)*LOG(ZMAX*0.5D0*(FSCB+FC/FB)) + IF(MA.GE.2) ZDIV=ZDIV+(FA/FB)*LOG(1D0-ZMAX) + ZDIV=MIN(ZMAX,MAX(0D0,ZDIV)) + FINT=1D0+FB*(1D0-ZDIV) + ENDIF + +C...Choice of z, preweighted for peaks at low or high z. + 100 Z=PYR(0) + FPRE=1D0 + IF(MMAX.EQ.1) THEN + IF(FINT*PYR(0).LE.1D0) THEN + Z=ZDIV*Z + ELSEIF(MC.EQ.1) THEN + Z=ZDIV**Z + FPRE=ZDIV/Z + ELSE + Z=(ZDIVC+Z*(1D0-ZDIVC))**(1D0/(1D0-FC)) + FPRE=(ZDIV/Z)**FC + ENDIF + ELSEIF(MMAX.EQ.3) THEN + IF(FINT*PYR(0).LE.1D0) THEN + Z=ZDIV+LOG(Z)/FB + FPRE=EXP(FB*(Z-ZDIV)) + ELSE + Z=ZDIV+Z*(1D0-ZDIV) + ENDIF + ENDIF + +C...Weighting according to correct formula. + IF(Z.LE.0D0.OR.Z.GE.1D0) GOTO 100 + FEXP=FC*LOG(ZMAX/Z)+FB*(1D0/ZMAX-1D0/Z) + IF(MA.GE.2) FEXP=FEXP+FA*LOG((1D0-Z)/(1D0-ZMAX)) + FVAL=EXP(MAX(-50D0,MIN(50D0,FEXP))) + IF(FVAL.LT.PYR(0)*FPRE) GOTO 100 + +C...Generate z according to Field-Feynman, SLAC, (1-z)**c OR z**c. + ELSE + FC=PARJ(50+MAX(1,KFLH)) + IF(MSTJ(91).EQ.1) FC=PARJ(59) + 110 Z=PYR(0) + IF(FC.GE.0D0.AND.FC.LE.1D0) THEN + IF(FC.GT.PYR(0)) Z=1D0-Z**(1D0/3D0) + ELSEIF(FC.GT.-1.AND.FC.LT.0D0) THEN + IF(-4D0*FC*Z*(1D0-Z)**2.LT.PYR(0)*((1D0-Z)**2-FC*Z)**2) + & GOTO 110 + ELSE + IF(FC.GT.0D0) Z=1D0-Z**(1D0/FC) + IF(FC.LT.0D0) Z=Z**(-1D0/FC) + ENDIF + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYSHOW +C...Generates timelike parton showers from given partons. + + SUBROUTINE PYSHOW(IP1,IP2,QMAX) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) + PARAMETER (MAXNUR=1000) +C...Commonblocks. + COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR) + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/ +C...Local arrays. + DIMENSION PMTH(5,140),PS(5),PMA(100),PMSD(100),IEP(100),IPA(100), + &KFLA(100),KFLD(100),KFL(100),ITRY(100),ISI(100),ISL(100),DP(100), + &DPT(5,4),KSH(0:140),KCII(2),NIIS(2),IIIS(2,2),THEIIS(2,2), + &PHIIIS(2,2),ISII(2),ISSET(2),ISCOL(0:140),ISCHG(0:140), + &IREF(1000) + +C...Check that QMAX not too low. + IF(MSTJ(41).LE.0) THEN + RETURN + ELSEIF(MSTJ(41).EQ.1.OR.MSTJ(41).EQ.11) THEN + IF(QMAX.LE.PARJ(82).AND.IP2.GE.-80) RETURN + ELSE + IF(QMAX.LE.MIN(PARJ(82),PARJ(83),PARJ(90)).AND.IP2.GE.-80) + & RETURN + ENDIF + +C...Store positions of shower initiating partons. + MPSPD=0 + IF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.EQ.0) THEN + NPA=1 + IPA(1)=IP1 + ELSEIF(MIN(IP1,IP2).GT.0.AND.MAX(IP1,IP2).LE.MIN(N,MSTU(4)- + & MSTU(32))) THEN + NPA=2 + IPA(1)=IP1 + IPA(2)=IP2 + ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.LT.0 + & .AND.IP2.GE.-80) THEN + NPA=IABS(IP2) + DO 100 I=1,NPA + IPA(I)=IP1+I-1 + 100 CONTINUE + ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND. + &IP2.EQ.-100) THEN + MPSPD=1 + NPA=2 + IPA(1)=IP1+6 + IPA(2)=IP1+7 + ELSE + CALL PYERRM(12, + & '(PYSHOW:) failed to reconstruct showering system') + IF(MSTU(21).GE.1) RETURN + ENDIF + +C...Send off to PYPTFS for pT-ordered evolution if requested, +C...if at least 2 partons, and without predefined shower branchings. + IF((MSTJ(41).EQ.11.OR.MSTJ(41).EQ.12).AND.NPA.GE.2.AND. + &MPSPD.EQ.0) THEN + NPART=NPA + DO 110 II=1,NPART + IPART(II)=IPA(II) + PTPART(II)=0.5D0*QMAX + 110 CONTINUE + CALL PYPTFS(2,0.5D0*QMAX,0D0,PTGEN) + RETURN + ENDIF + +C...Initialization of cutoff masses etc. + DO 120 IFL=0,40 + ISCOL(IFL)=0 + ISCHG(IFL)=0 + KSH(IFL)=0 + 120 CONTINUE + ISCOL(21)=1 + KSH(21)=1 + PMTH(1,21)=PYMASS(21) + PMTH(2,21)=SQRT(PMTH(1,21)**2+0.25D0*PARJ(82)**2) + PMTH(3,21)=2D0*PMTH(2,21) + PMTH(4,21)=PMTH(3,21) + PMTH(5,21)=PMTH(3,21) + PMTH(1,22)=PYMASS(22) + PMTH(2,22)=SQRT(PMTH(1,22)**2+0.25D0*PARJ(83)**2) + PMTH(3,22)=2D0*PMTH(2,22) + PMTH(4,22)=PMTH(3,22) + PMTH(5,22)=PMTH(3,22) + PMQTH1=PARJ(82) + IF(MSTJ(41).GE.2) PMQTH1=MIN(PARJ(82),PARJ(83)) + PMQT1E=MIN(PMQTH1,PARJ(90)) + PMQTH2=PMTH(2,21) + IF(MSTJ(41).GE.2) PMQTH2=MIN(PMTH(2,21),PMTH(2,22)) + PMQT2E=MIN(PMQTH2,0.5D0*PARJ(90)) + DO 130 IFL=1,5 + ISCOL(IFL)=1 + IF(MSTJ(41).GE.2) ISCHG(IFL)=1 + KSH(IFL)=1 + PMTH(1,IFL)=PYMASS(IFL) + PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PMQTH1**2) + PMTH(3,IFL)=PMTH(2,IFL)+PMQTH2 + PMTH(4,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(82)**2)+PMTH(2,21) + PMTH(5,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(83)**2)+PMTH(2,22) + 130 CONTINUE + DO 140 IFL=11,15,2 + IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) ISCHG(IFL)=1 + IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) KSH(IFL)=1 + PMTH(1,IFL)=PYMASS(IFL) + PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(90)**2) + PMTH(3,IFL)=PMTH(2,IFL)+0.5D0*PARJ(90) + PMTH(4,IFL)=PMTH(3,IFL) + PMTH(5,IFL)=PMTH(3,IFL) + 140 CONTINUE + PT2MIN=MAX(0.5D0*PARJ(82),1.1D0*PARJ(81))**2 + ALAMS=PARJ(81)**2 + ALFM=LOG(PT2MIN/ALAMS) + +C...Check on phase space available for emission. + IREJ=0 + DO 150 J=1,5 + PS(J)=0D0 + 150 CONTINUE + PM=0D0 + KFLA(2)=0 + DO 170 I=1,NPA + KFLA(I)=IABS(K(IPA(I),2)) + PMA(I)=P(IPA(I),5) +C...Special cutoff masses for initial partons (may be a heavy quark, +C...squark, ..., and need not be on the mass shell). + IR=30+I + IF(NPA.LE.1) IREF(I)=IR + IF(NPA.GE.2) IREF(I+1)=IR + ISCOL(IR)=0 + ISCHG(IR)=0 + KSH(IR)=0 + IF(KFLA(I).LE.8) THEN + ISCOL(IR)=1 + IF(MSTJ(41).GE.2) ISCHG(IR)=1 + ELSEIF(KFLA(I).EQ.11.OR.KFLA(I).EQ.13.OR.KFLA(I).EQ.15.OR. + & KFLA(I).EQ.17) THEN + IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) ISCHG(IR)=1 + ELSEIF(KFLA(I).EQ.21) THEN + ISCOL(IR)=1 + ELSEIF((KFLA(I).GE.KSUSY1+1.AND.KFLA(I).LE.KSUSY1+8).OR. + & (KFLA(I).GE.KSUSY2+1.AND.KFLA(I).LE.KSUSY2+8)) THEN + ISCOL(IR)=1 + ELSEIF(KFLA(I).EQ.KSUSY1+21) THEN + ISCOL(IR)=1 +C...QUARKONIA+++ +C...same for QQ~[3S18] + ELSEIF(MSTP(148).GE.1.AND.(KFLA(I).EQ.9900443.OR. + & KFLA(I).EQ.9900553)) THEN + ISCOL(IR)=1 +C...QUARKONIA--- + ENDIF + +C...Option to switch off radiation from particle KF = MSTJ(39) entirely +C...(only intended for studying the effects of switching such rad on/off) + IF (MSTJ(39).GT.0.AND.KFLA(I).EQ.MSTJ(39)) THEN + ISCOL(IR)=0 + ISCHG(IR)=0 + ENDIF + + IF(ISCOL(IR).EQ.1.OR.ISCHG(IR).EQ.1) KSH(IR)=1 + PMTH(1,IR)=PMA(I) + IF(ISCOL(IR).EQ.1.AND.ISCHG(IR).EQ.1) THEN + PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PMQTH1**2) + PMTH(3,IR)=PMTH(2,IR)+PMQTH2 + PMTH(4,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(82)**2)+PMTH(2,21) + PMTH(5,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(83)**2)+PMTH(2,22) + ELSEIF(ISCOL(IR).EQ.1) THEN + PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(82)**2) + PMTH(3,IR)=PMTH(2,IR)+0.5D0*PARJ(82) + PMTH(4,IR)=PMTH(3,IR) + PMTH(5,IR)=PMTH(3,IR) + ELSEIF(ISCHG(IR).EQ.1) THEN + PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(90)**2) + PMTH(3,IR)=PMTH(2,IR)+0.5D0*PARJ(90) + PMTH(4,IR)=PMTH(3,IR) + PMTH(5,IR)=PMTH(3,IR) + ENDIF + IF(KSH(IR).EQ.1) PMA(I)=PMTH(3,IR) + PM=PM+PMA(I) + IF(KSH(IR).EQ.0.OR.PMA(I).GT.10D0*QMAX) IREJ=IREJ+1 + DO 160 J=1,4 + PS(J)=PS(J)+P(IPA(I),J) + 160 CONTINUE + 170 CONTINUE + IF(IREJ.EQ.NPA.AND.IP2.GE.-7) RETURN + PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2)) + IF(NPA.EQ.1) PS(5)=PS(4) + IF(PS(5).LE.PM+PMQT1E) RETURN + +C...Identify source: q(1), ~q(2), V(3), S(4), chi(5), ~g(6), unknown(0). + KFSRCE=0 + IF(IP2.LE.0) THEN + ELSEIF(K(IP1,3).EQ.K(IP2,3).AND.K(IP1,3).GT.0) THEN + KFSRCE=IABS(K(K(IP1,3),2)) + ELSE + IPAR1=MAX(1,K(IP1,3)) + IPAR2=MAX(1,K(IP2,3)) + IF(K(IPAR1,3).EQ.K(IPAR2,3).AND.K(IPAR1,3).GT.0) + & KFSRCE=IABS(K(K(IPAR1,3),2)) + ENDIF + ITYPES=0 + IF(KFSRCE.GE.1.AND.KFSRCE.LE.8) ITYPES=1 + IF(KFSRCE.GE.KSUSY1+1.AND.KFSRCE.LE.KSUSY1+8) ITYPES=2 + IF(KFSRCE.GE.KSUSY2+1.AND.KFSRCE.LE.KSUSY2+8) ITYPES=2 + IF(KFSRCE.GE.21.AND.KFSRCE.LE.24) ITYPES=3 + IF(KFSRCE.GE.32.AND.KFSRCE.LE.34) ITYPES=3 + IF(KFSRCE.EQ.25.OR.(KFSRCE.GE.35.AND.KFSRCE.LE.37)) ITYPES=4 + IF(KFSRCE.GE.KSUSY1+22.AND.KFSRCE.LE.KSUSY1+37) ITYPES=5 + IF(KFSRCE.EQ.KSUSY1+21) ITYPES=6 + +C...Identify two primary showerers. + ITYPE1=0 + IF(KFLA(1).GE.1.AND.KFLA(1).LE.8) ITYPE1=1 + IF(KFLA(1).GE.KSUSY1+1.AND.KFLA(1).LE.KSUSY1+8) ITYPE1=2 + IF(KFLA(1).GE.KSUSY2+1.AND.KFLA(1).LE.KSUSY2+8) ITYPE1=2 + IF(KFLA(1).GE.21.AND.KFLA(1).LE.24) ITYPE1=3 + IF(KFLA(1).GE.32.AND.KFLA(1).LE.34) ITYPE1=3 + IF(KFLA(1).EQ.25.OR.(KFLA(1).GE.35.AND.KFLA(1).LE.37)) ITYPE1=4 + IF(KFLA(1).GE.KSUSY1+22.AND.KFLA(1).LE.KSUSY1+37) ITYPE1=5 + IF(KFLA(1).EQ.KSUSY1+21) ITYPE1=6 + ITYPE2=0 + IF(KFLA(2).GE.1.AND.KFLA(2).LE.8) ITYPE2=1 + IF(KFLA(2).GE.KSUSY1+1.AND.KFLA(2).LE.KSUSY1+8) ITYPE2=2 + IF(KFLA(2).GE.KSUSY2+1.AND.KFLA(2).LE.KSUSY2+8) ITYPE2=2 + IF(KFLA(2).GE.21.AND.KFLA(2).LE.24) ITYPE2=3 + IF(KFLA(2).GE.32.AND.KFLA(2).LE.34) ITYPE2=3 + IF(KFLA(2).EQ.25.OR.(KFLA(2).GE.35.AND.KFLA(2).LE.37)) ITYPE2=4 + IF(KFLA(2).GE.KSUSY1+22.AND.KFLA(2).LE.KSUSY1+37) ITYPE2=5 + IF(KFLA(2).EQ.KSUSY1+21) ITYPE2=6 + +C...Order of showerers. Presence of gluino. + ITYPMN=MIN(ITYPE1,ITYPE2) + ITYPMX=MAX(ITYPE1,ITYPE2) + IORD=1 + IF(ITYPE1.GT.ITYPE2) IORD=2 + IGLUI=0 + IF(ITYPE1.EQ.6.OR.ITYPE2.EQ.6) IGLUI=1 + +C...Check if 3-jet matrix elements to be used. + M3JC=0 + ALPHA=0.5D0 + IF(NPA.EQ.2.AND.MSTJ(47).GE.1.AND.MPSPD.EQ.0) THEN + IF(MSTJ(38).NE.0) THEN + M3JC=MSTJ(38) + ALPHA=PARJ(80) + MSTJ(38)=0 + ELSEIF(MSTJ(47).GE.6) THEN + M3JC=MSTJ(47) + ELSE + ICLASS=1 + ICOMBI=4 + +C...Vector/axial vector -> q + qbar; q -> q + V. + IF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.(ITYPES.EQ.0.OR. + & ITYPES.EQ.3)) THEN + ICLASS=2 + IF(KFSRCE.EQ.21.OR.KFSRCE.EQ.22) THEN + ICOMBI=1 + ELSEIF(KFSRCE.EQ.23.OR.(KFSRCE.EQ.0.AND. + & K(IPA(1),2)+K(IPA(2),2).EQ.0)) THEN +C...gamma*/Z0: assume e+e- initial state if unknown. + EI=-1D0 + IF(KFSRCE.EQ.23) THEN + IANNFL=K(K(IP1,3),3) + IF(IANNFL.NE.0) THEN + KANNFL=IABS(K(IANNFL,2)) + IF(KANNFL.GE.1.AND.KANNFL.LE.18) EI=KCHG(KANNFL,1)/3D0 + ENDIF + ENDIF + AI=SIGN(1D0,EI+0.1D0) + VI=AI-4D0*EI*PARU(102) + EF=KCHG(KFLA(1),1)/3D0 + AF=SIGN(1D0,EF+0.1D0) + VF=AF-4D0*EF*PARU(102) + XWC=1D0/(16D0*PARU(102)*(1D0-PARU(102))) + SH=PS(5)**2 + SQMZ=PMAS(23,1)**2 + SQWZ=PS(5)*PMAS(23,2) + SBWZ=1D0/((SH-SQMZ)**2+SQWZ**2) + VECT=EI**2*EF**2+2D0*EI*VI*EF*VF*XWC*SH*(SH-SQMZ)*SBWZ+ + & (VI**2+AI**2)*VF**2*XWC**2*SH**2*SBWZ + AXIV=(VI**2+AI**2)*AF**2*XWC**2*SH**2*SBWZ + ICOMBI=3 + ALPHA=VECT/(VECT+AXIV) + ELSEIF(KFSRCE.EQ.24.OR.KFSRCE.EQ.0) THEN + ICOMBI=4 + ENDIF +C...For chi -> chi q qbar, use V/A -> q qbar as first approximation. + ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.5) THEN + ICLASS=2 + ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR. + & ITYPES.EQ.1)) THEN + ICLASS=3 + +C...Scalar/pseudoscalar -> q + qbar; q -> q + S. + ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.4) THEN + ICLASS=4 + IF(KFSRCE.EQ.25.OR.KFSRCE.EQ.35.OR.KFSRCE.EQ.37) THEN + ICOMBI=1 + ELSEIF(KFSRCE.EQ.36) THEN + ICOMBI=2 + ENDIF + ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR. + & ITYPES.EQ.1)) THEN + ICLASS=5 + +C...V -> ~q + ~qbar; ~q -> ~q + V; S -> ~q + ~qbar; ~q -> ~q + S. + ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR. + & ITYPES.EQ.3)) THEN + ICLASS=6 + ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR. + & ITYPES.EQ.2)) THEN + ICLASS=7 + ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.4) THEN + ICLASS=8 + ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR. + & ITYPES.EQ.2)) THEN + ICLASS=9 + +C...chi -> q + ~qbar; ~q -> q + chi; q -> ~q + chi. + ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR. + & ITYPES.EQ.5)) THEN + ICLASS=10 + ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR. + & ITYPES.EQ.2)) THEN + ICLASS=11 + ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR. + & ITYPES.EQ.1)) THEN + ICLASS=12 + +C...~g -> q + ~qbar; ~q -> q + ~g; q -> ~q + ~g. + ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.6) THEN + ICLASS=13 + ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR. + & ITYPES.EQ.2)) THEN + ICLASS=14 + ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR. + & ITYPES.EQ.1)) THEN + ICLASS=15 + +C...g -> ~g + ~g (eikonal approximation). + ELSEIF(ITYPMN.EQ.6.AND.ITYPMX.EQ.6.AND.ITYPES.EQ.0) THEN + ICLASS=16 + ENDIF + M3JC=5*ICLASS+ICOMBI + ENDIF + ENDIF + +C...Find if interference with initial state partons. + MIIS=0 + IF(MSTJ(50).GE.1.AND.MSTJ(50).LE.3.AND.NPA.EQ.2.AND.KFSRCE.EQ.0 + &.AND.MPSPD.EQ.0) MIIS=MSTJ(50) + IF(MSTJ(50).GE.4.AND.MSTJ(50).LE.6.AND.NPA.EQ.2.AND.MPSPD.EQ.0) + &MIIS=MSTJ(50)-3 + IF(MIIS.NE.0) THEN + DO 190 I=1,2 + KCII(I)=0 + KCA=PYCOMP(KFLA(I)) + IF(KCA.NE.0) KCII(I)=KCHG(KCA,2)*ISIGN(1,K(IPA(I),2)) + NIIS(I)=0 + IF(KCII(I).NE.0) THEN + DO 180 J=1,2 + ICSI=MOD(K(IPA(I),3+J)/MSTU(5),MSTU(5)) + IF(ICSI.GT.0.AND.ICSI.NE.IPA(1).AND.ICSI.NE.IPA(2).AND. + & (KCII(I).EQ.(-1)**(J+1).OR.KCII(I).EQ.2)) THEN + NIIS(I)=NIIS(I)+1 + IIIS(I,NIIS(I))=ICSI + ENDIF + 180 CONTINUE + ENDIF + 190 CONTINUE + IF(NIIS(1)+NIIS(2).EQ.0) MIIS=0 + ENDIF + +C...Boost interfering initial partons to rest frame +C...and reconstruct their polar and azimuthal angles. + IF(MIIS.NE.0) THEN + DO 210 I=1,2 + DO 200 J=1,5 + K(N+I,J)=K(IPA(I),J) + P(N+I,J)=P(IPA(I),J) + V(N+I,J)=0D0 + 200 CONTINUE + 210 CONTINUE + DO 230 I=3,2+NIIS(1) + DO 220 J=1,5 + K(N+I,J)=K(IIIS(1,I-2),J) + P(N+I,J)=P(IIIS(1,I-2),J) + V(N+I,J)=0D0 + 220 CONTINUE + 230 CONTINUE + DO 250 I=3+NIIS(1),2+NIIS(1)+NIIS(2) + DO 240 J=1,5 + K(N+I,J)=K(IIIS(2,I-2-NIIS(1)),J) + P(N+I,J)=P(IIIS(2,I-2-NIIS(1)),J) + V(N+I,J)=0D0 + 240 CONTINUE + 250 CONTINUE + CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,0D0,-PS(1)/PS(4), + & -PS(2)/PS(4),-PS(3)/PS(4)) + PHI=PYANGL(P(N+1,1),P(N+1,2)) + CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,-PHI,0D0,0D0,0D0) + THE=PYANGL(P(N+1,3),P(N+1,1)) + CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),-THE,0D0,0D0,0D0,0D0) + DO 260 I=3,2+NIIS(1) + THEIIS(1,I-2)=PYANGL(P(N+I,3),SQRT(P(N+I,1)**2+P(N+I,2)**2)) + PHIIIS(1,I-2)=PYANGL(P(N+I,1),P(N+I,2)) + 260 CONTINUE + DO 270 I=3+NIIS(1),2+NIIS(1)+NIIS(2) + THEIIS(2,I-2-NIIS(1))=PARU(1)-PYANGL(P(N+I,3), + & SQRT(P(N+I,1)**2+P(N+I,2)**2)) + PHIIIS(2,I-2-NIIS(1))=PYANGL(P(N+I,1),P(N+I,2)) + 270 CONTINUE + ENDIF + +C...Boost 3 or more partons to their rest frame. + IF(NPA.GE.3) CALL PYROBO(IPA(1),IPA(NPA),0D0,0D0,-PS(1)/PS(4), + &-PS(2)/PS(4),-PS(3)/PS(4)) + +C...Define imagined single initiator of shower for parton system. + NS=N + IF(N.GT.MSTU(4)-MSTU(32)-10) THEN + CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS') + IF(MSTU(21).GE.1) RETURN + ENDIF + 280 N=NS + IF(NPA.GE.2) THEN + K(N+1,1)=11 + K(N+1,2)=21 + K(N+1,3)=0 + K(N+1,4)=0 + K(N+1,5)=0 + P(N+1,1)=0D0 + P(N+1,2)=0D0 + P(N+1,3)=0D0 + P(N+1,4)=PS(5) + P(N+1,5)=PS(5) + V(N+1,5)=PS(5)**2 + N=N+1 + IREF(1)=21 + ENDIF + +C...Loop over partons that may branch. + NEP=NPA + IM=NS + IF(NPA.EQ.1) IM=NS-1 + 290 IM=IM+1 + IF(N.GT.NS) THEN + IF(IM.GT.N) GOTO 600 + KFLM=IABS(K(IM,2)) + IR=IREF(IM-NS) + IF(KSH(IR).EQ.0) GOTO 290 + IF(P(IM,5).LT.PMTH(2,IR)) GOTO 290 + IGM=K(IM,3) + ELSE + IGM=-1 + ENDIF + IF(N+NEP.GT.MSTU(4)-MSTU(32)-10) THEN + CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS') + IF(MSTU(21).GE.1) RETURN + ENDIF + +C...Position of aunt (sister to branching parton). +C...Origin and flavour of daughters. + IAU=0 + IF(IGM.GT.0) THEN + IF(K(IM-1,3).EQ.IGM) IAU=IM-1 + IF(N.GE.IM+1.AND.K(IM+1,3).EQ.IGM) IAU=IM+1 + ENDIF + IF(IGM.GE.0) THEN + K(IM,4)=N+1 + DO 300 I=1,NEP + K(N+I,3)=IM + 300 CONTINUE + ELSE + K(N+1,3)=IPA(1) + ENDIF + IF(IGM.LE.0) THEN + DO 310 I=1,NEP + K(N+I,2)=K(IPA(I),2) + 310 CONTINUE + ELSEIF(KFLM.NE.21) THEN + K(N+1,2)=K(IM,2) + K(N+2,2)=K(IM,5) + IREF(N+1-NS)=IREF(IM-NS) + IREF(N+2-NS)=IABS(K(N+2,2)) + ELSEIF(K(IM,5).EQ.21) THEN + K(N+1,2)=21 + K(N+2,2)=21 + IREF(N+1-NS)=21 + IREF(N+2-NS)=21 + ELSE + K(N+1,2)=K(IM,5) + K(N+2,2)=-K(IM,5) + IREF(N+1-NS)=IABS(K(N+1,2)) + IREF(N+2-NS)=IABS(K(N+2,2)) + ENDIF + +C...Reset flags on daughters and tries made. + DO 320 IP=1,NEP + K(N+IP,1)=3 + K(N+IP,4)=0 + K(N+IP,5)=0 + KFLD(IP)=IABS(K(N+IP,2)) + IF(KCHG(PYCOMP(KFLD(IP)),2).EQ.0) K(N+IP,1)=1 + ITRY(IP)=0 + ISL(IP)=0 + ISI(IP)=0 + IF(KSH(IREF(N+IP-NS)).EQ.1) ISI(IP)=1 + 320 CONTINUE + ISLM=0 + +C...Maximum virtuality of daughters. + IF(IGM.LE.0) THEN + DO 330 I=1,NPA + IF(NPA.GE.3) P(N+I,4)=P(IPA(I),4) + P(N+I,5)=MIN(QMAX,PS(5)) + IR=IREF(N+I-NS) + IF(IP2.LE.-8) P(N+I,5)=MAX(P(N+I,5),2D0*PMTH(3,IR)) + IF(ISI(I).EQ.0) P(N+I,5)=P(IPA(I),5) + 330 CONTINUE + ELSE + IF(MSTJ(43).LE.2) PEM=V(IM,2) + IF(MSTJ(43).GE.3) PEM=P(IM,4) + P(N+1,5)=MIN(P(IM,5),V(IM,1)*PEM) + P(N+2,5)=MIN(P(IM,5),(1D0-V(IM,1))*PEM) + IF(K(N+2,2).EQ.22) P(N+2,5)=PMTH(1,22) + ENDIF + DO 340 I=1,NEP + PMSD(I)=P(N+I,5) + IF(ISI(I).EQ.1) THEN + IR=IREF(N+I-NS) + IF(P(N+I,5).LE.PMTH(3,IR)) P(N+I,5)=PMTH(1,IR) + ENDIF + V(N+I,5)=P(N+I,5)**2 + 340 CONTINUE + +C...Choose one of the daughters for evolution. + 350 INUM=0 + IF(NEP.EQ.1) INUM=1 + DO 360 I=1,NEP + IF(INUM.EQ.0.AND.ISL(I).EQ.1) INUM=I + 360 CONTINUE + DO 370 I=1,NEP + IF(INUM.EQ.0.AND.ITRY(I).EQ.0.AND.ISI(I).EQ.1) THEN + IR=IREF(N+I-NS) + IF(P(N+I,5).GE.PMTH(2,IR)) INUM=I + ENDIF + 370 CONTINUE + IF(INUM.EQ.0) THEN + RMAX=0D0 + DO 380 I=1,NEP + IF(ISI(I).EQ.1.AND.PMSD(I).GE.PMQT2E) THEN + RPM=P(N+I,5)/PMSD(I) + IR=IREF(N+I-NS) + IF(RPM.GT.RMAX.AND.P(N+I,5).GE.PMTH(2,IR)) THEN + RMAX=RPM + INUM=I + ENDIF + ENDIF + 380 CONTINUE + ENDIF + +C...Cancel choice of predetermined daughter already treated. + INUM=MAX(1,INUM) + INUMT=INUM + IF(MPSPD.EQ.1.AND.IGM.EQ.0.AND.ITRY(INUMT).GE.1) THEN + IF(K(IP1-1+INUM,4).GT.0) INUM=3-INUM + ELSEIF(MPSPD.EQ.1.AND.IM.EQ.NS+2.AND.ITRY(INUMT).GE.1) THEN + IF(KFLD(INUMT).NE.21.AND.K(IP1+2,4).GT.0) INUM=3-INUM + IF(KFLD(INUMT).EQ.21.AND.K(IP1+3,4).GT.0) INUM=3-INUM + ENDIF + +C...Store information on choice of evolving daughter. + IEP(1)=N+INUM + DO 390 I=2,NEP + IEP(I)=IEP(I-1)+1 + IF(IEP(I).GT.N+NEP) IEP(I)=N+1 + 390 CONTINUE + DO 400 I=1,NEP + KFL(I)=IABS(K(IEP(I),2)) + 400 CONTINUE + ITRY(INUM)=ITRY(INUM)+1 + IF(ITRY(INUM).GT.200) THEN + CALL PYERRM(14,'(PYSHOW:) caught in infinite loop') + IF(MSTU(21).GE.1) RETURN + ENDIF + Z=0.5D0 + IR=IREF(IEP(1)-NS) + IF(KSH(IR).EQ.0) GOTO 450 + IF(P(IEP(1),5).LT.PMTH(2,IR)) GOTO 450 + +C...Check if evolution already predetermined for daughter. + IPSPD=0 + IF(MPSPD.EQ.1.AND.IGM.EQ.0) THEN + IF(K(IP1-1+INUM,4).GT.0) IPSPD=IP1-1+INUM + ELSEIF(MPSPD.EQ.1.AND.IM.EQ.NS+2) THEN + IF(KFL(1).NE.21.AND.K(IP1+2,4).GT.0) IPSPD=IP1+2 + IF(KFL(1).EQ.21.AND.K(IP1+3,4).GT.0) IPSPD=IP1+3 + ENDIF + IF(INUM.EQ.1.OR.INUM.EQ.2) THEN + ISSET(INUM)=0 + IF(IPSPD.NE.0) ISSET(INUM)=1 + ENDIF + +C...Select side for interference with initial state partons. + IF(MIIS.GE.1.AND.IEP(1).LE.NS+3) THEN + III=IEP(1)-NS-1 + ISII(III)=0 + IF(IABS(KCII(III)).EQ.1.AND.NIIS(III).EQ.1) THEN + ISII(III)=1 + ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.1) THEN + IF(PYR(0).GT.0.5D0) ISII(III)=1 + ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.2) THEN + ISII(III)=1 + IF(PYR(0).GT.0.5D0) ISII(III)=2 + ENDIF + ENDIF + +C...Calculate allowed z range. + IF(NEP.EQ.1) THEN + PMED=PS(4) + ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN + PMED=P(IM,5) + ELSE + IF(INUM.EQ.1) PMED=V(IM,1)*PEM + IF(INUM.EQ.2) PMED=(1D0-V(IM,1))*PEM + ENDIF + IF(MOD(MSTJ(43),2).EQ.1) THEN + ZC=PMTH(2,21)/PMED + ZCE=PMTH(2,22)/PMED + IF(ISCOL(IR).EQ.0) ZCE=0.5D0*PARJ(90)/PMED + ELSE + ZC=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTH(2,21)/PMED)**2))) + IF(ZC.LT.1D-6) ZC=(PMTH(2,21)/PMED)**2 + PMTMPE=PMTH(2,22) + IF(ISCOL(IR).EQ.0) PMTMPE=0.5D0*PARJ(90) + ZCE=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTMPE/PMED)**2))) + IF(ZCE.LT.1D-6) ZCE=(PMTMPE/PMED)**2 + ENDIF + ZC=MIN(ZC,0.491D0) + ZCE=MIN(ZCE,0.49991D0) + IF(((MSTJ(41).EQ.1.AND.ZC.GT.0.49D0).OR.(MSTJ(41).GE.2.AND. + &MIN(ZC,ZCE).GT.0.4999D0)).AND.IPSPD.EQ.0) THEN + P(IEP(1),5)=PMTH(1,IR) + V(IEP(1),5)=P(IEP(1),5)**2 + GOTO 450 + ENDIF + +C...Integral of Altarelli-Parisi z kernel for QCD. +C...(Includes squark and gluino; with factor N_C/C_F extra for latter). + IF(MSTJ(49).EQ.0.AND.KFL(1).EQ.21) THEN + FBR=6D0*LOG((1D0-ZC)/ZC)+MSTJ(45)*0.5D0 +C...QUARKONIA+++ +C...Evolution of QQ~[3S18] state if MSTP(148)=1. + ELSEIF(MSTJ(49).EQ.0.AND.MSTP(149).GE.0.AND. + & (KFL(1).EQ.9900443.OR.KFL(1).EQ.9900553)) THEN + FBR=6D0*LOG((1D0-ZC)/ZC) +C...QUARKONIA--- + ELSEIF(MSTJ(49).EQ.0) THEN + FBR=(8D0/3D0)*LOG((1D0-ZC)/ZC) + IF(IGLUI.EQ.1.AND.IR.GE.31) FBR=FBR*(9D0/4D0) + +C...Integral of Altarelli-Parisi z kernel for scalar gluon. + ELSEIF(MSTJ(49).EQ.1.AND.KFL(1).EQ.21) THEN + FBR=(PARJ(87)+MSTJ(45)*PARJ(88))*(1D0-2D0*ZC) + ELSEIF(MSTJ(49).EQ.1) THEN + FBR=(1D0-2D0*ZC)/3D0 + IF(IGM.EQ.0.AND.M3JC.GE.1) FBR=4D0*FBR + +C...Integral of Altarelli-Parisi z kernel for Abelian vector gluon. + ELSEIF(KFL(1).EQ.21) THEN + FBR=6D0*MSTJ(45)*(0.5D0-ZC) + ELSE + FBR=2D0*LOG((1D0-ZC)/ZC) + ENDIF + +C...Reset QCD probability for colourless. + IF(ISCOL(IR).EQ.0) FBR=0D0 + +C...Integral of Altarelli-Parisi kernel for photon emission. + FBRE=0D0 + IF(MSTJ(41).GE.2.AND.ISCHG(IR).EQ.1) THEN + IF(KFL(1).LE.18) THEN + FBRE=(KCHG(KFL(1),1)/3D0)**2*2D0*LOG((1D0-ZCE)/ZCE) + ENDIF + IF(MSTJ(41).EQ.10) FBRE=PARJ(84)*FBRE + ENDIF + +C...Inner veto algorithm starts. Find maximum mass for evolution. + 410 PMS=V(IEP(1),5) + IF(IGM.GE.0) THEN + PM2=0D0 + DO 420 I=2,NEP + PM=P(IEP(I),5) + IRI=IREF(IEP(I)-NS) + IF(KSH(IRI).EQ.1) PM=PMTH(2,IRI) + PM2=PM2+PM + 420 CONTINUE + PMS=MIN(PMS,(P(IM,5)-PM2)**2) + ENDIF + +C...Select mass for daughter in QCD evolution. + B0=27D0/6D0 + DO 430 IFF=4,MSTJ(45) + IF(PMS.GT.4D0*PMTH(2,IFF)**2) B0=(33D0-2D0*IFF)/6D0 + 430 CONTINUE +C...Shift m^2 for evolution in Q^2 = m^2 - m(onshell)^2. + PMSC=MAX(0.5D0*PARJ(82),PMS-PMTH(1,IR)**2) +C...Already predetermined choice. + IF(IPSPD.NE.0) THEN + PMSQCD=P(IPSPD,5)**2 + ELSEIF(FBR.LT.1D-3) THEN + PMSQCD=0D0 + ELSEIF(MSTJ(44).LE.0) THEN + PMSQCD=PMSC*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/(PARU(111)*FBR))) + ELSEIF(MSTJ(44).EQ.1) THEN + PMSQCD=4D0*ALAMS*(0.25D0*PMSC/ALAMS)**(PYR(0)**(B0/FBR)) + ELSE + PMSQCD=PMSC*EXP(MAX(-50D0,ALFM*B0*LOG(PYR(0))/FBR)) + ENDIF +C...Shift back m^2 from evolution in Q^2 = m^2 - m(onshell)^2. + IF(IPSPD.EQ.0) PMSQCD=PMSQCD+PMTH(1,IR)**2 + IF(ZC.GT.0.49D0.OR.PMSQCD.LE.PMTH(4,IR)**2) PMSQCD=PMTH(2,IR)**2 + V(IEP(1),5)=PMSQCD + MCE=1 + +C...Select mass for daughter in QED evolution. + IF(MSTJ(41).GE.2.AND.ISCHG(IR).EQ.1.AND.IPSPD.EQ.0) THEN +C...Shift m^2 for evolution in Q^2 = m^2 - m(onshell)^2. + PMSE=MAX(0.5D0*PARJ(83),PMS-PMTH(1,IR)**2) + IF(FBRE.LT.1D-3) THEN + PMSQED=0D0 + ELSE + PMSQED=PMSE*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/ + & (PARU(101)*FBRE))) + ENDIF +C...Shift back m^2 from evolution in Q^2 = m^2 - m(onshell)^2. + PMSQED=PMSQED+PMTH(1,IR)**2 + IF(ZCE.GT.0.4999D0.OR.PMSQED.LE.PMTH(5,IR)**2) PMSQED= + & PMTH(2,IR)**2 + IF(PMSQED.GT.PMSQCD) THEN + V(IEP(1),5)=PMSQED + MCE=2 + ENDIF + ENDIF + +C...Check whether daughter mass below cutoff. + P(IEP(1),5)=SQRT(V(IEP(1),5)) + IF(P(IEP(1),5).LE.PMTH(3,IR)) THEN + P(IEP(1),5)=PMTH(1,IR) + V(IEP(1),5)=P(IEP(1),5)**2 + GOTO 450 + ENDIF + +C...Already predetermined choice of z, and flavour in g -> qqbar. + IF(IPSPD.NE.0) THEN + IPSGD1=K(IPSPD,4) + IPSGD2=K(IPSPD,5) + PMSGD1=P(IPSGD1,5)**2 + PMSGD2=P(IPSGD2,5)**2 + ALAMPS=SQRT(MAX(1D-10,(PMSQCD-PMSGD1-PMSGD2)**2- + & 4D0*PMSGD1*PMSGD2)) + Z=0.5D0*(PMSQCD*(2D0*P(IPSGD1,4)/P(IPSPD,4)-1D0)+ALAMPS- + & PMSGD1+PMSGD2)/ALAMPS + Z=MAX(0.00001D0,MIN(0.99999D0,Z)) + IF(KFL(1).NE.21) THEN + K(IEP(1),5)=21 + ELSE + K(IEP(1),5)=IABS(K(IPSGD1,2)) + ENDIF + +C...Select z value of branching: q -> qgamma. + ELSEIF(MCE.EQ.2) THEN + Z=1D0-(1D0-ZCE)*(ZCE/(1D0-ZCE))**PYR(0) + IF(1D0+Z**2.LT.2D0*PYR(0)) GOTO 410 + K(IEP(1),5)=22 + +C...QUARKONIA+++ +C...Select z value of branching: QQ~[3S18] -> QQ~[3S18]g. + ELSEIF(MSTJ(49).EQ.0.AND. + & (KFL(1).EQ.9900443.OR.KFL(1).EQ.9900553)) THEN + Z=(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0) +C...Select always the harder 'gluon' if the switch MSTP(149)<=0. + IF(MSTP(149).LE.0.OR.PYR(0).GT.0.5D0) Z=1D0-Z + IF((1D0-Z*(1D0-Z))**2.LT.PYR(0)) GOTO 410 + K(IEP(1),5)=21 +C...QUARKONIA--- + +C...Select z value of branching: q -> qg, g -> gg, g -> qqbar. + ELSEIF(MSTJ(49).NE.1.AND.KFL(1).NE.21) THEN + Z=1D0-(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0) +C...Only do z weighting when no ME correction afterwards. + IF(M3JC.EQ.0.AND.1D0+Z**2.LT.2D0*PYR(0)) GOTO 410 + K(IEP(1),5)=21 + ELSEIF(MSTJ(49).EQ.0.AND.MSTJ(45)*0.5D0.LT.PYR(0)*FBR) THEN + Z=(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0) + IF(PYR(0).GT.0.5D0) Z=1D0-Z + IF((1D0-Z*(1D0-Z))**2.LT.PYR(0)) GOTO 410 + K(IEP(1),5)=21 + ELSEIF(MSTJ(49).NE.1) THEN + Z=PYR(0) + IF(Z**2+(1D0-Z)**2.LT.PYR(0)) GOTO 410 + KFLB=1+INT(MSTJ(45)*PYR(0)) + PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5) + IF(PMQ.GE.1D0) GOTO 410 + IF(MSTJ(44).LE.2.OR.MSTJ(44).EQ.4) THEN + IF(Z.LT.ZC.OR.Z.GT.1D0-ZC) GOTO 410 + PMQ0=4D0*PMTH(2,21)**2/V(IEP(1),5) + IF(MOD(MSTJ(43),2).EQ.0.AND.(1D0+0.5D0*PMQ)*SQRT(1D0-PMQ) + & .LT.PYR(0)*(1D0+0.5D0*PMQ0)*SQRT(1D0-PMQ0)) GOTO 410 + ELSE + IF((1D0+0.5D0*PMQ)*SQRT(1D0-PMQ).LT.PYR(0)) GOTO 410 + ENDIF + K(IEP(1),5)=KFLB + +C...Ditto for scalar gluon model. + ELSEIF(KFL(1).NE.21) THEN + Z=1D0-SQRT(ZC**2+PYR(0)*(1D0-2D0*ZC)) + K(IEP(1),5)=21 + ELSEIF(PYR(0)*(PARJ(87)+MSTJ(45)*PARJ(88)).LE.PARJ(87)) THEN + Z=ZC+(1D0-2D0*ZC)*PYR(0) + K(IEP(1),5)=21 + ELSE + Z=ZC+(1D0-2D0*ZC)*PYR(0) + KFLB=1+INT(MSTJ(45)*PYR(0)) + PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5) + IF(PMQ.GE.1D0) GOTO 410 + K(IEP(1),5)=KFLB + ENDIF + +C...Correct to alpha_s(pT^2) (optionally m^2/4 for g -> q qbar). + IF(MCE.EQ.1.AND.MSTJ(44).GE.2.AND.IPSPD.EQ.0) THEN + IF(KFL(1).EQ.21.AND.K(IEP(1),5).LT.10.AND. + & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN + IF(ALFM/LOG(V(IEP(1),5)*0.25D0/ALAMS).LT.PYR(0)) GOTO 410 + ELSE + PT2APP=Z*(1D0-Z)*V(IEP(1),5) + IF(MSTJ(44).GE.4) PT2APP=PT2APP* + & (1D0-PMTH(1,IR)**2/V(IEP(1),5))**2 + IF(PT2APP.LT.PT2MIN) GOTO 410 + IF(ALFM/LOG(PT2APP/ALAMS).LT.PYR(0)) GOTO 410 + ENDIF + ENDIF + +C...Check if z consistent with chosen m. + IF(KFL(1).EQ.21) THEN + IRGD1=IABS(K(IEP(1),5)) + IRGD2=IRGD1 + ELSE + IRGD1=IR + IRGD2=IABS(K(IEP(1),5)) + ENDIF + IF(NEP.EQ.1) THEN + PED=PS(4) + ELSEIF(NEP.GE.3) THEN + PED=P(IEP(1),4) + ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN + PED=0.5D0*(V(IM,5)+V(IEP(1),5)-PM2**2)/P(IM,5) + ELSE + IF(IEP(1).EQ.N+1) PED=V(IM,1)*PEM + IF(IEP(1).EQ.N+2) PED=(1D0-V(IM,1))*PEM + ENDIF + IF(MOD(MSTJ(43),2).EQ.1) THEN + PMQTH3=0.5D0*PARJ(82) + IF(IRGD2.EQ.22) PMQTH3=0.5D0*PARJ(83) + IF(IRGD2.EQ.22.AND.ISCOL(IR).EQ.0) PMQTH3=0.5D0*PARJ(90) + PMQ1=(PMTH(1,IRGD1)**2+PMQTH3**2)/V(IEP(1),5) + PMQ2=(PMTH(1,IRGD2)**2+PMQTH3**2)/V(IEP(1),5) + ZD=SQRT(MAX(0D0,(1D0-V(IEP(1),5)/PED**2)*((1D0-PMQ1-PMQ2)**2- + & 4D0*PMQ1*PMQ2))) + ZH=1D0+PMQ1-PMQ2 + ELSE + ZD=SQRT(MAX(0D0,1D0-V(IEP(1),5)/PED**2)) + ZH=1D0 + ENDIF + IF(KFL(1).EQ.21.AND.K(IEP(1),5).LT.10.AND. + &(MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN + ELSEIF(IPSPD.NE.0) THEN + ELSE + ZL=0.5D0*(ZH-ZD) + ZU=0.5D0*(ZH+ZD) + IF(Z.LT.ZL.OR.Z.GT.ZU) GOTO 410 + ENDIF + IF(KFL(1).EQ.21) V(IEP(1),3)=LOG(ZU*(1D0-ZL)/MAX(1D-20,ZL* + &(1D0-ZU))) + IF(KFL(1).NE.21) V(IEP(1),3)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU)) + +C...Width suppression for q -> q + g. + IF(MSTJ(40).NE.0.AND.KFL(1).NE.21.AND.IPSPD.EQ.0) THEN + IF(IGM.EQ.0) THEN + EGLU=0.5D0*PS(5)*(1D0-Z)*(1D0+V(IEP(1),5)/V(NS+1,5)) + ELSE + EGLU=PMED*(1D0-Z) + ENDIF + CHI=PARJ(89)**2/(PARJ(89)**2+EGLU**2) + IF(MSTJ(40).EQ.1) THEN + IF(CHI.LT.PYR(0)) GOTO 410 + ELSEIF(MSTJ(40).EQ.2) THEN + IF(1D0-CHI.LT.PYR(0)) GOTO 410 + ENDIF + ENDIF + +C...Three-jet matrix element correction. + IF(M3JC.GE.1) THEN + WME=1D0 + WSHOW=1D0 + +C...QED matrix elements: only for massless case so far. + IF(MCE.EQ.2.AND.IGM.EQ.0) THEN + X1=Z*(1D0+V(IEP(1),5)/V(NS+1,5)) + X2=1D0-V(IEP(1),5)/V(NS+1,5) + X3=(1D0-X1)+(1D0-X2) + KI1=K(IPA(INUM),2) + KI2=K(IPA(3-INUM),2) + QF1=KCHG(PYCOMP(KI1),1)*ISIGN(1,KI1)/3D0 + QF2=KCHG(PYCOMP(KI2),1)*ISIGN(1,KI2)/3D0 + WSHOW=QF1**2*(1D0-X1)/X3*(1D0+(X1/(2D0-X2))**2)+ + & QF2**2*(1D0-X2)/X3*(1D0+(X2/(2D0-X1))**2) + WME=(QF1*(1D0-X1)/X3-QF2*(1D0-X2)/X3)**2*(X1**2+X2**2) + ELSEIF(MCE.EQ.2) THEN + +C...QCD matrix elements, including mass effects. + ELSEIF(MSTJ(49).NE.1.AND.K(IEP(1),2).NE.21) THEN + PS1ME=V(IEP(1),5) + PM1ME=PMTH(1,IR) + M3JCC=M3JC + IF(IR.GE.31.AND.IGM.EQ.0) THEN +C...QCD ME: original parton, first branching. + PM2ME=PMTH(1,63-IR) + ECMME=PS(5) + ELSEIF(IR.GE.31) THEN +C...QCD ME: original parton, subsequent branchings. + PM2ME=PMTH(1,63-IR) + PEDME=PEM*(V(IM,1)+(1D0-V(IM,1))*PS1ME/V(IM,5)) + ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2)) + ELSEIF(K(IM,2).EQ.21) THEN +C...QCD ME: secondary partons, first branching. + PM2ME=PM1ME + ZMME=V(IM,1) + IF(IEP(1).GT.IEP(2)) ZMME=1D0-ZMME + PMLME=SQRT(MAX(0D0,(V(IM,5)-PS1ME-PM2ME**2)**2- + & 4D0*PS1ME*PM2ME**2)) + PEDME=PEM*(0.5D0*(V(IM,5)-PMLME+PS1ME-PM2ME**2)+PMLME*ZMME)/ + & V(IM,5) + ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2)) + M3JCC=66 + ELSE +C...QCD ME: secondary partons, subsequent branchings. + PM2ME=PM1ME + PEDME=PEM*(V(IM,1)+(1D0-V(IM,1))*PS1ME/V(IM,5)) + ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2)) + M3JCC=66 + ENDIF +C...Construct ME variables. + R1ME=PM1ME/ECMME + R2ME=PM2ME/ECMME + X1=(1D0+PS1ME/ECMME**2-R2ME**2)*(Z+(1D0-Z)*PM1ME**2/PS1ME) + X2=1D0+R2ME**2-PS1ME/ECMME**2 +C...Call ME, with right order important for two inequivalent showerers. + IF(IR.EQ.IORD+30) THEN + WME=PYMAEL(M3JCC,X1,X2,R1ME,R2ME,ALPHA) + ELSE + WME=PYMAEL(M3JCC,X2,X1,R2ME,R1ME,ALPHA) + ENDIF +C...Split up total ME when two radiating partons. + ISPRAD=1 + IF((M3JCC.GE.16.AND.M3JCC.LE.19).OR. + & (M3JCC.GE.26.AND.M3JCC.LE.29).OR. + & (M3JCC.GE.36.AND.M3JCC.LE.39).OR. + & (M3JCC.GE.46.AND.M3JCC.LE.49).OR. + & (M3JCC.GE.56.AND.M3JCC.LE.64)) ISPRAD=0 + IF(ISPRAD.EQ.1) WME=WME*MAX(1D-10,1D0+R1ME**2-R2ME**2-X1)/ + & MAX(1D-10,2D0-X1-X2) +C...Evaluate shower rate to be compared with. + WSHOW=2D0/(MAX(1D-10,2D0-X1-X2)* + & MAX(1D-10,1D0+R2ME**2-R1ME**2-X2)) + IF(IGLUI.EQ.1.AND.IR.GE.31) WSHOW=(9D0/4D0)*WSHOW + ELSEIF(MSTJ(49).NE.1) THEN + +C...Toy model scalar theory matrix elements; no mass effects. + ELSE + X1=Z*(1D0+V(IEP(1),5)/V(NS+1,5)) + X2=1D0-V(IEP(1),5)/V(NS+1,5) + X3=(1D0-X1)+(1D0-X2) + WSHOW=4D0*X3*((1D0-X1)/(2D0-X2)**2+(1D0-X2)/(2D0-X1)**2) + WME=X3**2 + IF(MSTJ(102).GE.2) WME=X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)* + & PARJ(171) + ENDIF + + IF(WME.LT.PYR(0)*WSHOW) GOTO 410 + ENDIF + +C...Impose angular ordering by rejection of nonordered emission. + IF(MCE.EQ.1.AND.IGM.GT.0.AND.MSTJ(42).GE.2.AND.IPSPD.EQ.0) THEN + PEMAO=V(IM,1)*P(IM,4) + IF(IEP(1).EQ.N+2) PEMAO=(1D0-V(IM,1))*P(IM,4) + IF(IR.GE.31.AND.MSTJ(42).GE.5) THEN + MAOD=0 + ELSEIF(KFL(1).EQ.21.AND.K(IEP(1),5).LE.10.AND.(MSTJ(42).EQ.4 + & .OR.MSTJ(42).EQ.7)) THEN + MAOD=0 + ELSEIF(KFL(1).EQ.21.AND.K(IEP(1),5).LE.10.AND.(MSTJ(42).EQ.3 + & .OR.MSTJ(42).EQ.6)) THEN + MAOD=1 + PMDAO=PMTH(2,K(IEP(1),5)) + THE2ID=Z*(1D0-Z)*PEMAO**2/(V(IEP(1),5)-4D0*PMDAO**2) + ELSE + MAOD=1 + THE2ID=Z*(1D0-Z)*PEMAO**2/V(IEP(1),5) + IF(MSTJ(42).GE.3.AND.MSTJ(42).NE.5) THE2ID=THE2ID* + & (1D0+PMTH(1,IR)**2*(1D0-Z)/(V(IEP(1),5)*Z))**2 + ENDIF + MAOM=1 + IAOM=IM + 440 IF(K(IAOM,5).EQ.22) THEN + IAOM=K(IAOM,3) + IF(K(IAOM,3).LE.NS) MAOM=0 + IF(MAOM.EQ.1) GOTO 440 + ENDIF + IF(MAOM.EQ.1.AND.MAOD.EQ.1) THEN + THE2IM=V(IAOM,1)*(1D0-V(IAOM,1))*P(IAOM,4)**2/V(IAOM,5) + IF(THE2ID.LT.THE2IM) GOTO 410 + ENDIF + ENDIF + +C...Impose user-defined maximum angle at first branching. + IF(MSTJ(48).EQ.1.AND.IPSPD.EQ.0) THEN + IF(NEP.EQ.1.AND.IM.EQ.NS) THEN + THE2ID=Z*(1D0-Z)*PS(4)**2/V(IEP(1),5) + IF(PARJ(85)**2*THE2ID.LT.1D0) GOTO 410 + ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+2) THEN + THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5) + IF(PARJ(85)**2*THE2ID.LT.1D0) GOTO 410 + ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+3) THEN + THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5) + IF(PARJ(86)**2*THE2ID.LT.1D0) GOTO 410 + ENDIF + ENDIF + +C...Impose angular constraint in first branching from interference +C...with initial state partons. + IF(MIIS.GE.2.AND.IEP(1).LE.NS+3) THEN + THE2D=MAX((1D0-Z)/Z,Z/(1D0-Z))*V(IEP(1),5)/(0.5D0*P(IM,4))**2 + IF(IEP(1).EQ.NS+2.AND.ISII(1).GE.1) THEN + IF(THE2D.GT.THEIIS(1,ISII(1))**2) GOTO 410 + ELSEIF(IEP(1).EQ.NS+3.AND.ISII(2).GE.1) THEN + IF(THE2D.GT.THEIIS(2,ISII(2))**2) GOTO 410 + ENDIF + ENDIF + +C...End of inner veto algorithm. Check if only one leg evolved so far. + 450 V(IEP(1),1)=Z + ISL(1)=0 + ISL(2)=0 + IF(NEP.EQ.1) GOTO 490 + IF(NEP.EQ.2.AND.P(IEP(1),5)+P(IEP(2),5).GE.P(IM,5)) GOTO 350 + DO 460 I=1,NEP + IR=IREF(N+I-NS) + IF(ITRY(I).EQ.0.AND.KSH(IR).EQ.1) THEN + IF(P(N+I,5).GE.PMTH(2,IR)) GOTO 350 + ENDIF + 460 CONTINUE + +C...Check if chosen multiplet m1,m2,z1,z2 is physical. + IF(NEP.GE.3) THEN + PMSUM=0D0 + DO 470 I=1,NEP + PMSUM=PMSUM+P(N+I,5) + 470 CONTINUE + IF(PMSUM.GE.PS(5)) GOTO 350 + ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2.OR.MOD(MSTJ(43),2).EQ.0) THEN + DO 480 I1=N+1,N+2 + IRDA=IREF(I1-NS) + IF(KSH(IRDA).EQ.0) GOTO 480 + IF(P(I1,5).LT.PMTH(2,IRDA)) GOTO 480 + IF(IRDA.EQ.21) THEN + IRGD1=IABS(K(I1,5)) + IRGD2=IRGD1 + ELSE + IRGD1=IRDA + IRGD2=IABS(K(I1,5)) + ENDIF + I2=2*N+3-I1 + IF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN + PED=0.5D0*(V(IM,5)+V(I1,5)-V(I2,5))/P(IM,5) + ELSE + IF(I1.EQ.N+1) ZM=V(IM,1) + IF(I1.EQ.N+2) ZM=1D0-V(IM,1) + PML=SQRT((V(IM,5)-V(N+1,5)-V(N+2,5))**2- + & 4D0*V(N+1,5)*V(N+2,5)) + PED=PEM*(0.5D0*(V(IM,5)-PML+V(I1,5)-V(I2,5))+PML*ZM)/ + & V(IM,5) + ENDIF + IF(MOD(MSTJ(43),2).EQ.1) THEN + PMQTH3=0.5D0*PARJ(82) + IF(IRGD2.EQ.22) PMQTH3=0.5D0*PARJ(83) + IF(IRGD2.EQ.22.AND.ISCOL(IRDA).EQ.0) PMQTH3=0.5D0*PARJ(90) + PMQ1=(PMTH(1,IRGD1)**2+PMQTH3**2)/V(I1,5) + PMQ2=(PMTH(1,IRGD2)**2+PMQTH3**2)/V(I1,5) + ZD=SQRT(MAX(0D0,(1D0-V(I1,5)/PED**2)*((1D0-PMQ1-PMQ2)**2- + & 4D0*PMQ1*PMQ2))) + ZH=1D0+PMQ1-PMQ2 + ELSE + ZD=SQRT(MAX(0D0,1D0-V(I1,5)/PED**2)) + ZH=1D0 + ENDIF + IF(IRDA.EQ.21.AND.IRGD1.LT.10.AND. + & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN + ELSE + ZL=0.5D0*(ZH-ZD) + ZU=0.5D0*(ZH+ZD) + IF(I1.EQ.N+1.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU).AND. + & ISSET(1).EQ.0) THEN + ISL(1)=1 + ELSEIF(I1.EQ.N+2.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU).AND. + & ISSET(2).EQ.0) THEN + ISL(2)=1 + ENDIF + ENDIF + IF(IRDA.EQ.21) V(I1,4)=LOG(ZU*(1D0-ZL)/MAX(1D-20, + & ZL*(1D0-ZU))) + IF(IRDA.NE.21) V(I1,4)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU)) + 480 CONTINUE + IF(ISL(1).EQ.1.AND.ISL(2).EQ.1.AND.ISLM.NE.0) THEN + ISL(3-ISLM)=0 + ISLM=3-ISLM + ELSEIF(ISL(1).EQ.1.AND.ISL(2).EQ.1) THEN + ZDR1=MAX(0D0,V(N+1,3)/MAX(1D-6,V(N+1,4))-1D0) + ZDR2=MAX(0D0,V(N+2,3)/MAX(1D-6,V(N+2,4))-1D0) + IF(ZDR2.GT.PYR(0)*(ZDR1+ZDR2)) ISL(1)=0 + IF(ISL(1).EQ.1) ISL(2)=0 + IF(ISL(1).EQ.0) ISLM=1 + IF(ISL(2).EQ.0) ISLM=2 + ENDIF + IF(ISL(1).EQ.1.OR.ISL(2).EQ.1) GOTO 350 + ENDIF + IRD1=IREF(N+1-NS) + IRD2=IREF(N+2-NS) + IF(IGM.GT.0) THEN + IF(MOD(MSTJ(43),2).EQ.1.AND.(P(N+1,5).GE. + & PMTH(2,IRD1).OR.P(N+2,5).GE.PMTH(2,IRD2))) THEN + PMQ1=V(N+1,5)/V(IM,5) + PMQ2=V(N+2,5)/V(IM,5) + ZD=SQRT(MAX(0D0,(1D0-V(IM,5)/PEM**2)*((1D0-PMQ1-PMQ2)**2- + & 4D0*PMQ1*PMQ2))) + ZH=1D0+PMQ1-PMQ2 + ZL=0.5D0*(ZH-ZD) + ZU=0.5D0*(ZH+ZD) + IF(V(IM,1).LT.ZL.OR.V(IM,1).GT.ZU) GOTO 350 + ENDIF + ENDIF + +C...Accepted branch. Construct four-momentum for initial partons. + 490 MAZIP=0 + MAZIC=0 + IF(NEP.EQ.1) THEN + P(N+1,1)=0D0 + P(N+1,2)=0D0 + P(N+1,3)=SQRT(MAX(0D0,(P(IPA(1),4)+P(N+1,5))*(P(IPA(1),4)- + & P(N+1,5)))) + P(N+1,4)=P(IPA(1),4) + V(N+1,2)=P(N+1,4) + ELSEIF(IGM.EQ.0.AND.NEP.EQ.2) THEN + PED1=0.5D0*(V(IM,5)+V(N+1,5)-V(N+2,5))/P(IM,5) + P(N+1,1)=0D0 + P(N+1,2)=0D0 + P(N+1,3)=SQRT(MAX(0D0,(PED1+P(N+1,5))*(PED1-P(N+1,5)))) + P(N+1,4)=PED1 + P(N+2,1)=0D0 + P(N+2,2)=0D0 + P(N+2,3)=-P(N+1,3) + P(N+2,4)=P(IM,5)-PED1 + V(N+1,2)=P(N+1,4) + V(N+2,2)=P(N+2,4) + ELSEIF(NEP.GE.3) THEN +C...Rescale all momenta for energy conservation. + LOOP=0 + PES=0D0 + PQS=0D0 + DO 510 I=1,NEP + DO 500 J=1,4 + P(N+I,J)=P(IPA(I),J) + 500 CONTINUE + PES=PES+P(N+I,4) + PQS=PQS+P(N+I,5)**2/P(N+I,4) + 510 CONTINUE + 520 LOOP=LOOP+1 + FAC=(PS(5)-PQS)/(PES-PQS) + PES=0D0 + PQS=0D0 + DO 540 I=1,NEP + DO 530 J=1,3 + P(N+I,J)=FAC*P(N+I,J) + 530 CONTINUE + P(N+I,4)=SQRT(P(N+I,5)**2+P(N+I,1)**2+P(N+I,2)**2+P(N+I,3)**2) + V(N+I,2)=P(N+I,4) + PES=PES+P(N+I,4) + PQS=PQS+P(N+I,5)**2/P(N+I,4) + 540 CONTINUE + IF(LOOP.LT.10.AND.ABS(PES-PS(5)).GT.1D-12*PS(5)) GOTO 520 + +C...Construct transverse momentum for ordinary branching in shower. + ELSE + ZM=V(IM,1) + LOOPPT=0 + 550 LOOPPT=LOOPPT+1 + PZM=SQRT(MAX(0D0,(PEM+P(IM,5))*(PEM-P(IM,5)))) + PMLS=(V(IM,5)-V(N+1,5)-V(N+2,5))**2-4D0*V(N+1,5)*V(N+2,5) + IF(PZM.LE.0D0) THEN + PTS=0D0 + ELSEIF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND. + & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN + PTS=PMLS*ZM*(1D0-ZM)/V(IM,5) + ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN + PTS=(PEM**2*(ZM*(1D0-ZM)*V(IM,5)-(1D0-ZM)*V(N+1,5)- + & ZM*V(N+2,5))-0.25D0*PMLS)/PZM**2 + ELSE + PTS=PMLS*(ZM*(1D0-ZM)*PEM**2/V(IM,5)-0.25D0)/PZM**2 + ENDIF + IF(PTS.LT.0D0.AND.LOOPPT.LT.10) THEN + ZM=0.05D0+0.9D0*ZM + GOTO 550 + ELSEIF(PTS.LT.0D0) THEN + GOTO 280 + ENDIF + PT=SQRT(MAX(0D0,PTS)) + +C...Global statistics. + MINT(353)=MINT(353)+1 + VINT(353)=VINT(353)+PT + IF (MINT(353).EQ.1) VINT(358)=PT + +C...Find coefficient of azimuthal asymmetry due to gluon polarization. + HAZIP=0D0 + IF(MSTJ(49).NE.1.AND.MOD(MSTJ(46),2).EQ.1.AND.K(IM,2).EQ.21 + & .AND.IAU.NE.0) THEN + IF(K(IGM,3).NE.0) MAZIP=1 + ZAU=V(IGM,1) + IF(IAU.EQ.IM+1) ZAU=1D0-V(IGM,1) + IF(MAZIP.EQ.0) ZAU=0D0 + IF(K(IGM,2).NE.21) THEN + HAZIP=2D0*ZAU/(1D0+ZAU**2) + ELSE + HAZIP=(ZAU/(1D0-ZAU*(1D0-ZAU)))**2 + ENDIF + IF(K(N+1,2).NE.21) THEN + HAZIP=HAZIP*(-2D0*ZM*(1D0-ZM))/(1D0-2D0*ZM*(1D0-ZM)) + ELSE + HAZIP=HAZIP*(ZM*(1D0-ZM)/(1D0-ZM*(1D0-ZM)))**2 + ENDIF + ENDIF + +C...Find coefficient of azimuthal asymmetry due to soft gluon +C...interference. + HAZIC=0D0 + IF(MSTJ(49).NE.2.AND.MSTJ(46).GE.2.AND.(K(N+1,2).EQ.21.OR. + & K(N+2,2).EQ.21).AND.IAU.NE.0) THEN + IF(K(IGM,3).NE.0) MAZIC=N+1 + IF(K(IGM,3).NE.0.AND.K(N+1,2).NE.21) MAZIC=N+2 + IF(K(IGM,3).NE.0.AND.K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND. + & ZM.GT.0.5D0) MAZIC=N+2 + IF(K(IAU,2).EQ.22) MAZIC=0 + ZS=ZM + IF(MAZIC.EQ.N+2) ZS=1D0-ZM + ZGM=V(IGM,1) + IF(IAU.EQ.IM-1) ZGM=1D0-V(IGM,1) + IF(MAZIC.EQ.0) ZGM=1D0 + IF(MAZIC.NE.0) HAZIC=(P(IM,5)/P(IGM,5))* + & SQRT((1D0-ZS)*(1D0-ZGM)/(ZS*ZGM)) + HAZIC=MIN(0.95D0,HAZIC) + ENDIF + ENDIF + +C...Construct energies for ordinary branching in shower. + 560 IF(NEP.EQ.2.AND.IGM.GT.0) THEN + IF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND. + & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN + P(N+1,4)=0.5D0*(PEM*(V(IM,5)+V(N+1,5)-V(N+2,5))+ + & PZM*SQRT(MAX(0D0,PMLS))*(2D0*ZM-1D0))/V(IM,5) + ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN + P(N+1,4)=PEM*V(IM,1) + ELSE + P(N+1,4)=PEM*(0.5D0*(V(IM,5)-SQRT(PMLS)+V(N+1,5)-V(N+2,5))+ + & SQRT(PMLS)*ZM)/V(IM,5) + ENDIF + +C...Already predetermined choice of phi angle or not + PHI=PARU(2)*PYR(0) + IF(MPSPD.EQ.1.AND.IGM.EQ.NS+1) THEN + IPSPD=IP1+IM-NS-2 + IF(K(IPSPD,4).GT.0) THEN + IPSGD1=K(IPSPD,4) + IF(IM.EQ.NS+2) THEN + PHI=PYANGL(P(IPSGD1,1),P(IPSGD1,2)) + ELSE + PHI=PYANGL(-P(IPSGD1,1),P(IPSGD1,2)) + ENDIF + ENDIF + ELSEIF(MPSPD.EQ.1.AND.IGM.EQ.NS+2) THEN + IPSPD=IP1+IM-NS-2 + IF(K(IPSPD,4).GT.0) THEN + IPSGD1=K(IPSPD,4) + PHIPSM=PYANGL(P(IPSPD,1),P(IPSPD,2)) + THEPSM=PYANGL(P(IPSPD,3),SQRT(P(IPSPD,1)**2+P(IPSPD,2)**2)) + CALL PYROBO(IPSGD1,IPSGD1,0D0,-PHIPSM,0D0,0D0,0D0) + CALL PYROBO(IPSGD1,IPSGD1,-THEPSM,0D0,0D0,0D0,0D0) + PHI=PYANGL(P(IPSGD1,1),P(IPSGD1,2)) + CALL PYROBO(IPSGD1,IPSGD1,THEPSM,PHIPSM,0D0,0D0,0D0) + ENDIF + ENDIF + +C...Construct momenta for ordinary branching in shower. + P(N+1,1)=PT*COS(PHI) + P(N+1,2)=PT*SIN(PHI) + IF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND. + & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN + P(N+1,3)=0.5D0*(PZM*(V(IM,5)+V(N+1,5)-V(N+2,5))+ + & PEM*SQRT(MAX(0D0,PMLS))*(2D0*ZM-1D0))/V(IM,5) + ELSEIF(PZM.GT.0D0) THEN + P(N+1,3)=0.5D0*(V(N+2,5)-V(N+1,5)-V(IM,5)+ + & 2D0*PEM*P(N+1,4))/PZM + ELSE + P(N+1,3)=0D0 + ENDIF + P(N+2,1)=-P(N+1,1) + P(N+2,2)=-P(N+1,2) + P(N+2,3)=PZM-P(N+1,3) + P(N+2,4)=PEM-P(N+1,4) + IF(MSTJ(43).LE.2) THEN + V(N+1,2)=(PEM*P(N+1,4)-PZM*P(N+1,3))/P(IM,5) + V(N+2,2)=(PEM*P(N+2,4)-PZM*P(N+2,3))/P(IM,5) + ENDIF + ENDIF + +C...Rotate and boost daughters. + IF(IGM.GT.0) THEN + IF(MSTJ(43).LE.2) THEN + BEX=P(IGM,1)/P(IGM,4) + BEY=P(IGM,2)/P(IGM,4) + BEZ=P(IGM,3)/P(IGM,4) + GA=P(IGM,4)/P(IGM,5) + GABEP=GA*(GA*(BEX*P(IM,1)+BEY*P(IM,2)+BEZ*P(IM,3))/(1D0+GA)- + & P(IM,4)) + ELSE + BEX=0D0 + BEY=0D0 + BEZ=0D0 + GA=1D0 + GABEP=0D0 + ENDIF + PTIMB=SQRT((P(IM,1)+GABEP*BEX)**2+(P(IM,2)+GABEP*BEY)**2) + THE=PYANGL(P(IM,3)+GABEP*BEZ,PTIMB) + IF(PTIMB.GT.1D-4) THEN + PHI=PYANGL(P(IM,1)+GABEP*BEX,P(IM,2)+GABEP*BEY) + ELSE + PHI=0D0 + ENDIF + DO 570 I=N+1,N+2 + DP(1)=COS(THE)*COS(PHI)*P(I,1)-SIN(PHI)*P(I,2)+ + & SIN(THE)*COS(PHI)*P(I,3) + DP(2)=COS(THE)*SIN(PHI)*P(I,1)+COS(PHI)*P(I,2)+ + & SIN(THE)*SIN(PHI)*P(I,3) + DP(3)=-SIN(THE)*P(I,1)+COS(THE)*P(I,3) + DP(4)=P(I,4) + DBP=BEX*DP(1)+BEY*DP(2)+BEZ*DP(3) + DGABP=GA*(GA*DBP/(1D0+GA)+DP(4)) + P(I,1)=DP(1)+DGABP*BEX + P(I,2)=DP(2)+DGABP*BEY + P(I,3)=DP(3)+DGABP*BEZ + P(I,4)=GA*(DP(4)+DBP) + 570 CONTINUE + ENDIF + +C...Weight with azimuthal distribution, if required. + IF(MAZIP.NE.0.OR.MAZIC.NE.0) THEN + DO 580 J=1,3 + DPT(1,J)=P(IM,J) + DPT(2,J)=P(IAU,J) + DPT(3,J)=P(N+1,J) + 580 CONTINUE + DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3) + DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3) + DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2 + DO 590 J=1,3 + DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/MAX(1D-10,DPMM) + DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/MAX(1D-10,DPMM) + 590 CONTINUE + DPT(4,4)=SQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2) + DPT(5,4)=SQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2) + IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1D0*PARJ(82)) THEN + CAD=(DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+ + & DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4)) + IF(MAZIP.NE.0) THEN + IF(1D0+HAZIP*(2D0*CAD**2-1D0).LT.PYR(0)*(1D0+ABS(HAZIP))) + & GOTO 560 + ENDIF + IF(MAZIC.NE.0) THEN + IF(MAZIC.EQ.N+2) CAD=-CAD + IF((1D0-HAZIC)*(1D0-HAZIC*CAD)/(1D0+HAZIC**2-2D0*HAZIC*CAD) + & .LT.PYR(0)) GOTO 560 + ENDIF + ENDIF + ENDIF + +C...Azimuthal anisotropy due to interference with initial state partons. + IF(MOD(MIIS,2).EQ.1.AND.IGM.EQ.NS+1.AND.(K(N+1,2).EQ.21.OR. + &K(N+2,2).EQ.21)) THEN + III=IM-NS-1 + IF(ISII(III).GE.1) THEN + IAZIID=N+1 + IF(K(N+1,2).NE.21) IAZIID=N+2 + IF(K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND. + & P(N+1,4).GT.P(N+2,4)) IAZIID=N+2 + THEIID=PYANGL(P(IAZIID,3),SQRT(P(IAZIID,1)**2+P(IAZIID,2)**2)) + IF(III.EQ.2) THEIID=PARU(1)-THEIID + PHIIID=PYANGL(P(IAZIID,1),P(IAZIID,2)) + HAZII=MIN(0.95D0,THEIID/THEIIS(III,ISII(III))) + CAD=COS(PHIIID-PHIIIS(III,ISII(III))) + PHIREL=ABS(PHIIID-PHIIIS(III,ISII(III))) + IF(PHIREL.GT.PARU(1)) PHIREL=PARU(2)-PHIREL + IF((1D0-HAZII)*(1D0-HAZII*CAD)/(1D0+HAZII**2-2D0*HAZII*CAD) + & .LT.PYR(0)) GOTO 560 + ENDIF + ENDIF + +C...Continue loop over partons that may branch, until none left. + IF(IGM.GE.0) K(IM,1)=14 + N=N+NEP + NEP=2 + IF(N.GT.MSTU(4)-MSTU(32)-10) THEN + CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS') + IF(MSTU(21).GE.1) N=NS + IF(MSTU(21).GE.1) RETURN + ENDIF + GOTO 290 + +C...Set information on imagined shower initiator. + 600 IF(NPA.GE.2) THEN + K(NS+1,1)=11 + K(NS+1,2)=94 + K(NS+1,3)=IP1 + IF(IP2.GT.0.AND.IP2.LT.IP1) K(NS+1,3)=IP2 + K(NS+1,4)=NS+2 + K(NS+1,5)=NS+1+NPA + IIM=1 + ELSE + IIM=0 + ENDIF + +C...Reconstruct string drawing information. + DO 610 I=NS+1+IIM,N + KQ=KCHG(PYCOMP(K(I,2)),2) + IF(K(I,1).LE.10.AND.K(I,2).EQ.22) THEN + K(I,1)=1 + ELSEIF(K(I,1).LE.10.AND.IABS(K(I,2)).GE.11.AND. + & IABS(K(I,2)).LE.18) THEN + K(I,1)=1 + ELSEIF(K(I,1).LE.10) THEN + K(I,4)=MSTU(5)*(K(I,4)/MSTU(5)) + K(I,5)=MSTU(5)*(K(I,5)/MSTU(5)) + ELSEIF(K(MOD(K(I,4),MSTU(5))+1,2).NE.22) THEN + ID1=MOD(K(I,4),MSTU(5)) + IF(KQ.EQ.1.AND.K(I,2).GT.0) ID1=MOD(K(I,4),MSTU(5))+1 + IF(KQ.EQ.2.AND.(K(ID1,2).EQ.21.OR.K(ID1+1,2).EQ.21).AND. + & PYR(0).GT.0.5D0) ID1=MOD(K(I,4),MSTU(5))+1 + ID2=2*MOD(K(I,4),MSTU(5))+1-ID1 + K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1 + K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID2 + K(ID1,4)=K(ID1,4)+MSTU(5)*I + K(ID1,5)=K(ID1,5)+MSTU(5)*ID2 + K(ID2,4)=K(ID2,4)+MSTU(5)*ID1 + K(ID2,5)=K(ID2,5)+MSTU(5)*I + ELSE + ID1=MOD(K(I,4),MSTU(5)) + ID2=ID1+1 + K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1 + K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID1 + IF(KQ.EQ.1.OR.K(ID1,1).GE.11) THEN + K(ID1,4)=K(ID1,4)+MSTU(5)*I + K(ID1,5)=K(ID1,5)+MSTU(5)*I + ELSE + K(ID1,4)=0 + K(ID1,5)=0 + ENDIF + K(ID2,4)=0 + K(ID2,5)=0 + ENDIF + 610 CONTINUE + +C...Transformation from CM frame. + IF(NPA.EQ.1) THEN + THE=PYANGL(P(IPA(1),3),SQRT(P(IPA(1),1)**2+P(IPA(1),2)**2)) + PHI=PYANGL(P(IPA(1),1),P(IPA(1),2)) + MSTU(33)=1 + CALL PYROBO(NS+1,N,THE,PHI,0D0,0D0,0D0) + ELSEIF(NPA.EQ.2) THEN + BEX=PS(1)/PS(4) + BEY=PS(2)/PS(4) + BEZ=PS(3)/PS(4) + GA=PS(4)/PS(5) + GABEP=GA*(GA*(BEX*P(IPA(1),1)+BEY*P(IPA(1),2)+BEZ*P(IPA(1),3)) + & /(1D0+GA)-P(IPA(1),4)) + THE=PYANGL(P(IPA(1),3)+GABEP*BEZ,SQRT((P(IPA(1),1) + & +GABEP*BEX)**2+(P(IPA(1),2)+GABEP*BEY)**2)) + PHI=PYANGL(P(IPA(1),1)+GABEP*BEX,P(IPA(1),2)+GABEP*BEY) + MSTU(33)=1 + CALL PYROBO(NS+1,N,THE,PHI,BEX,BEY,BEZ) + ELSE + CALL PYROBO(IPA(1),IPA(NPA),0D0,0D0,PS(1)/PS(4),PS(2)/PS(4), + & PS(3)/PS(4)) + MSTU(33)=1 + CALL PYROBO(NS+1,N,0D0,0D0,PS(1)/PS(4),PS(2)/PS(4),PS(3)/PS(4)) + ENDIF + +C...Decay vertex of shower. + DO 630 I=NS+1,N + DO 620 J=1,5 + V(I,J)=V(IP1,J) + 620 CONTINUE + 630 CONTINUE + +C...Delete trivial shower, else connect initiators. + IF(N.LE.NS+NPA+IIM) THEN + N=NS + ELSE + DO 640 IP=1,NPA + K(IPA(IP),1)=14 + K(IPA(IP),4)=K(IPA(IP),4)+NS+IIM+IP + K(IPA(IP),5)=K(IPA(IP),5)+NS+IIM+IP + K(NS+IIM+IP,3)=IPA(IP) + IF(IIM.EQ.1.AND.MSTU(16).NE.2) K(NS+IIM+IP,3)=NS+1 + IF(K(NS+IIM+IP,1).NE.1) THEN + K(NS+IIM+IP,4)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,4) + K(NS+IIM+IP,5)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,5) + ENDIF + 640 CONTINUE + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYPTFS +C...Generates pT-ordered timelike final-state parton showers. + +C...MODE defines how to find radiators and recoilers. +C... = 0 : based on colour flow between undecayed partons. +C... = 1 : for IPART <= NPARTD only consider primary partons, +C... whether decayed or not; else as above. +C... = 2 : based on common history, whether decayed or not. +C... = 3 : use (or create) MCT color information to shower partons + + SUBROUTINE PYPTFS(MODE,PTMAX,PTMIN,PTGEN) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Parameter statement for maximum size of showers. + PARAMETER (MAXNUR=1000) +C...Commonblocks. + COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR) + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYCTAG/NCT,MCT(4000,2) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYPARS/, + &/PYINT1/ +C...Local arrays. + DIMENSION IPOS(2*MAXNUR),IREC(2*MAXNUR),IFLG(2*MAXNUR), + &ISCOL(2*MAXNUR),ISCHG(2*MAXNUR),PTSCA(2*MAXNUR),IMESAV(2*MAXNUR), + &PT2SAV(2*MAXNUR),ZSAV(2*MAXNUR),SHTSAV(2*MAXNUR), + &MESYS(MAXNUR,0:2),PSUM(5),DPT(5,4) +C...Statement functions. + SHAT(L,J)=(P(L,4)+P(J,4))**2-(P(L,1)+P(J,1))**2- + &(P(L,2)+P(J,2))**2-(P(L,3)+P(J,3))**2 + DOTP(L,J)=P(L,4)*P(J,4)-P(L,1)*P(J,1)-P(L,2)*P(J,2)-P(L,3)*P(J,3) + +C...Initial values. Check that valid system. + PTGEN=0D0 + IF(MSTJ(41).NE.1.AND.MSTJ(41).NE.2.AND.MSTJ(41).NE.11.AND. + &MSTJ(41).NE.12) RETURN + IF(NPART.LE.0) THEN + CALL PYERRM(2,'(PYPTFS:) showering system too small') + RETURN + ENDIF + PT2CMX=PTMAX**2 + IORD=1 + +C...Mass thresholds and Lambda for QCD evolution. + PMB=PMAS(5,1) + PMC=PMAS(4,1) + ALAM5=PARJ(81) + ALAM4=ALAM5*(PMB/ALAM5)**(2D0/25D0) + ALAM3=ALAM4*(PMC/ALAM4)**(2D0/27D0) + PMBS=PMB**2 + PMCS=PMC**2 + ALAM5S=ALAM5**2 + ALAM4S=ALAM4**2 + ALAM3S=ALAM3**2 + +C...Cutoff scale for QCD evolution. Starting pT2. + NFLAV=MAX(0,MIN(5,MSTJ(45))) + PT0C=0.5D0*PARJ(82) + PT2CMN=MAX(PTMIN,PT0C,1.1D0*ALAM3)**2 + +C...Parameters for QED evolution. + AEM2PI=PARU(101)/PARU(2) + PT0EQ=0.5D0*PARJ(83) + PT0EL=0.5D0*PARJ(90) + +C...Reset. Remove irrelevant colour tags. + NEVOL=0 + DO 100 J=1,4 + PSUM(J)=0D0 + 100 CONTINUE + DO 110 I=MINT(84)+1,N + IF(K(I,2).GT.0.AND.K(I,2).LT.6) THEN + K(I,5)=0 + MCT(I,2)=0 + ENDIF + IF(K(I,2).LT.0.AND.K(I,2).GT.-6) THEN + K(I,4)=0 + MCT(I,1)=0 + ENDIF + 110 CONTINUE + NPARTS=NPART + +C...Begin loop to set up showering partons. Sum four-momenta. + DO 230 IP=1,NPART + I=IPART(IP) + IF(MODE.NE.1.OR.I.GT.NPARTD) THEN + IF(K(I,1).GT.10) GOTO 230 + ELSEIF(K(I,3).GT.MINT(84)) THEN + IF(K(I,3).GT.MINT(84)+2) GOTO 230 + ELSE + IF(K(K(I,3),3).GT.MINT(83)+6) GOTO 230 + ENDIF + DO 120 J=1,4 + PSUM(J)=PSUM(J)+P(I,J) + 120 CONTINUE + +C...Find colour and charge, but skip diquarks. + IF(IABS(K(I,2)).GT.1000.AND.IABS(K(I,2)).LT.10000) GOTO 230 + KCOL=PYK(I,12) + KCHA=PYK(I,6) + +C...QUARKONIA++ + IF (IABS(K(I,2)).GE.9900101.AND.IABS(K(I,2)).LE.9910555) THEN + IF (MSTP(148).GE.1) THEN +C...Temporary: force no radiation from quarkonia since not yet treated + CALL PYERRM(11,'(PYPTFS:) quarkonia showers not yet in' + & //' PYPTFS, switched off') + CALL PYGIVE('MSTP(148)=0') + ENDIF + IF (MSTP(148).EQ.0) THEN +C...Skip quarkonia if radiation switched off + GOTO 230 + ENDIF + ENDIF +C...QUARKONIA-- + +C...Option to switch off radiation from particle KF = MSTJ(39) entirely +C...(only intended for studying the effects of switching such rad on/off) + IF (MSTJ(39).GT.0.AND.IABS(K(I,2)).EQ.MSTJ(39)) THEN + GOTO 230 + ENDIF + +C...Either colour or anticolour charge radiates; for gluon both. + DO 180 JSGCOL=1,-1,-2 + IF(KCOL.EQ.JSGCOL.OR.KCOL.EQ.2) THEN + JCOL=4+(1-JSGCOL)/2 + JCOLR=9-JCOL + +C...Basic info about radiating parton. + NEVOL=NEVOL+1 + IPOS(NEVOL)=I + IFLG(NEVOL)=0 + ISCOL(NEVOL)=JSGCOL + ISCHG(NEVOL)=0 + PTSCA(NEVOL)=PTPART(IP) + +C...Begin search for colour recoiler when MODE = 0 or 1. + IF(MODE.LE.1) THEN +C...Find sister with matching anticolour to the radiating parton. + IROLD=I + IRNEW=K(IROLD,JCOL)/MSTU(5) + MOVE=1 + +C...Skip radiation off loose colour ends. + 130 IF(IRNEW.EQ.0) THEN + NEVOL=NEVOL-1 + GOTO 180 + +C...Optionally skip radiation on dipole to beam remnant. + ELSEIF(MSTP(72).LE.1.AND.IRNEW.GT.MINT(53)) THEN + NEVOL=NEVOL-1 + GOTO 180 + +C...For now always skip radiation on dipole to junction. + ELSEIF(K(IRNEW,2).EQ.88) THEN + NEVOL=NEVOL-1 + GOTO 180 + +C...For MODE=1: if reached primary then done. + ELSEIF(MODE.EQ.1.AND.IRNEW.GT.MINT(84)+2.AND. + & IRNEW.LE.NPARTD) THEN + +C...If sister stable and points back then done. + ELSEIF(MOVE.EQ.1.AND.K(IRNEW,JCOLR)/MSTU(5).EQ.IROLD) + & THEN + IF(K(IRNEW,1).LT.10) THEN + +C...If sister unstable then go to her daughter. + ELSE + IROLD=IRNEW + IRNEW=MOD(K(IRNEW,JCOLR),MSTU(5)) + MOVE=2 + GOTO 130 + ENDIF + +C...If found mother then look for aunt. + ELSEIF(MOVE.EQ.1.AND.MOD(K(IRNEW,JCOL),MSTU(5)).EQ. + & IROLD) THEN + IROLD=IRNEW + IRNEW=K(IROLD,JCOL)/MSTU(5) + GOTO 130 + +C...If daughter stable then done. + ELSEIF(MOVE.EQ.2.AND.K(IRNEW,JCOLR)/MSTU(5).EQ.IROLD) + & THEN + IF(K(IRNEW,1).LT.10) THEN + +C...If daughter unstable then go to granddaughter. + ELSE + IROLD=IRNEW + IRNEW=MOD(K(IRNEW,JCOLR),MSTU(5)) + MOVE=2 + GOTO 130 + ENDIF + +C...If daughter points to another daughter then done or move up. + ELSEIF(MOVE.EQ.2.AND.MOD(K(IRNEW,JCOL),MSTU(5)).EQ. + & IROLD) THEN + IF(K(IRNEW,1).LT.10) THEN + ELSE + IROLD=IRNEW + IRNEW=K(IRNEW,JCOL)/MSTU(5) + MOVE=1 + GOTO 130 + ENDIF + ENDIF + +C...Begin search for colour recoiler when MODE = 2. + ELSEIF (MODE.EQ.2) THEN + IROLD=I + IRNEW=K(IROLD,JCOL)/MSTU(5) + 140 IF (IRNEW.LE.0.OR.IRNEW.GT.N) THEN +C...If no color partner found, pick at random among other primaries +C...(e.g., when the color line is traced all the way to the beam) + ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0)))) + IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART)) + ELSEIF(K(IRNEW,JCOLR)/MSTU(5).NE.IROLD) THEN +C...Step up to mother if radiating parton already branched. + IF(K(IRNEW,2).EQ.K(IROLD,2)) THEN + IROLD=IRNEW + IRNEW=K(IROLD,JCOL)/MSTU(5) + GOTO 140 +C...Pick sister by history if no anticolour available. + ELSE + IF(IROLD.GT.1.AND.K(IROLD-1,3).EQ.K(IROLD,3)) THEN + IRNEW=IROLD-1 + ELSEIF(IROLD.LT.N.AND.K(IROLD+1,3).EQ.K(IROLD,3)) + & THEN + IRNEW=IROLD+1 +C...Last resort: pick at random among other primaries. + ELSE + ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0)))) + IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART)) + ENDIF + ENDIF + ENDIF +C...Trace down if sister branched. + 150 IF(K(IRNEW,1).GT.10) THEN + IRTMP=MOD(K(IRNEW,JCOLR),MSTU(5)) +C...If no correct color-daughter found, swap. + IF (IRTMP.EQ.0) THEN + JCOL=9-JCOL + JCOLR=9-JCOLR + IRTMP=MOD(K(IRNEW,JCOLR),MSTU(5)) + ENDIF + IRNEW=IRTMP + GOTO 150 + ENDIF + ELSEIF (MODE.EQ.3) THEN +C...The following will add MCT colour tracing for unprepped events +C...If not done, trace Les Houches colour tags for this dipole + JCOLSV=JCOL + IF (MCT(I,JCOL-3).EQ.0) THEN +C...Special end code -1 : trace to color partner or 0, return in IEND + IEND=-1 + CALL PYCTTR(I,JCOL,IEND) +C...Clean up mother/daughter 'read' tags set by PYCTTR + JCOL=JCOLSV + DO 160 IR=1,N + K(IR,4)=MOD(K(IR,4),MSTU(5)**2) + K(IR,5)=MOD(K(IR,5),MSTU(5)**2) + MCT(IR,1)=0 + MCT(IR,2)=0 + 160 CONTINUE + ELSE + IEND=0 + DO 170 IR=1,N + IF (K(IR,1).GT.0.AND.MCT(IR,6-JCOL).EQ.MCT(I,JCOL-3)) + & IEND=IR + 170 CONTINUE + ENDIF +C...If no color partner, then we hit beam + IF (IEND.LE.0) THEN +C...For MSTP(72) <= 1, do not allow dipoles stretched to beam to radiate + IF (MSTP(72).LE.1) THEN + NEVOL=NEVOL-1 + GOTO 180 + ELSE +C...Else try a random partner + ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0)))) + IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART)) + ENDIF + ELSE +C...Else save recoiling colour partner + IRNEW=IEND + ENDIF + + ENDIF + +C...Now found other end of colour dipole. + IREC(NEVOL)=IRNEW + ENDIF + 180 CONTINUE + +C...Also electrical charge may radiate; so far only quarks and leptons. + IF((MSTJ(41).EQ.2.OR.MSTJ(41).EQ.12).AND.KCHA.NE.0.AND. + & IABS(K(I,2)).LE.18) THEN + +C...Basic info about radiating parton. + NEVOL=NEVOL+1 + IPOS(NEVOL)=I + IFLG(NEVOL)=0 + ISCOL(NEVOL)=0 + ISCHG(NEVOL)=KCHA + PTSCA(NEVOL)=PTPART(IP) + +C...Pick nearest (= smallest invariant mass) charged particle +C...as recoiler when MODE = 0 or 1 (but for latter among primaries). + IF(MODE.LE.1) THEN + IRNEW=0 + PM2MIN=VINT(2) + DO 190 IP2=1,NPART+N-MINT(53) + IF(IP2.EQ.IP) GOTO 190 + IF(IP2.LE.NPART) THEN + I2=IPART(IP2) + IF(MODE.NE.1.OR.I2.GT.NPARTD) THEN + IF(K(I2,1).GT.10) GOTO 190 + ELSEIF(K(I2,3).GT.MINT(84)) THEN + IF(K(I2,3).GT.MINT(84)+2) GOTO 190 + ELSE + IF(K(K(I2,3),3).GT.MINT(83)+6) GOTO 190 + ENDIF + ELSE + I2=MINT(53)+IP2-NPART + ENDIF + IF(KCHG(PYCOMP(K(I2,2)),1).EQ.0) GOTO 190 + PM2INV=(P(I,4)+P(I2,4))**2-(P(I,1)+P(I2,1))**2- + & (P(I,2)+P(I2,2))**2-(P(I,3)+P(I2,3))**2 + IF(PM2INV.LT.PM2MIN) THEN + IRNEW=I2 + PM2MIN=PM2INV + ENDIF + 190 CONTINUE + IF(IRNEW.EQ.0) THEN + NEVOL=NEVOL-1 + GOTO 230 + ENDIF + +C...Begin search for charge recoiler when MODE = 2. + ELSE + IROLD=I +C...Pick sister by history; step up if parton already branched. + 200 IF(K(IROLD,3).GT.0.AND.K(K(IROLD,3),2).EQ.K(IROLD,2)) THEN + IROLD=K(IROLD,3) + GOTO 200 + ENDIF + IF(IROLD.GT.1.AND.K(IROLD-1,3).EQ.K(IROLD,3)) THEN + IRNEW=IROLD-1 + ELSEIF(IROLD.LT.N.AND.K(IROLD+1,3).EQ.K(IROLD,3)) THEN + IRNEW=IROLD+1 +C...Last resort: pick at random among other primaries. + ELSE + ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0)))) + IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART)) + ENDIF +C...Trace down if sister branched. + 210 IF(K(IRNEW,1).GT.10) THEN + DO 220 IR=IRNEW+1,N + IF(K(IR,3).EQ.IRNEW.AND.K(IR,2).EQ.K(IRNEW,2)) THEN + IRNEW=IR + GOTO 210 + ENDIF + 220 CONTINUE + ENDIF + ENDIF + IREC(NEVOL)=IRNEW + ENDIF + +C...End loop to set up showering partons. System invariant mass. + 230 CONTINUE + IF(NEVOL.LE.0) RETURN + IF (MODE.EQ.3.AND.NEVOL.LE.1) RETURN + PSUM(5)=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2)) + +C...Check if 3-jet matrix elements to be used. + M3JC=0 + ALPHA=0.5D0 + NMESYS=0 + IF(MSTJ(47).GE.1) THEN + +C...Identify source: q(1), ~q(2), V(3), S(4), chi(5), ~g(6), unknown(0). + KFSRCE=0 + IPART1=K(IPART(1),3) + IPART2=K(IPART(2),3) + 240 IF(IPART1.EQ.IPART2.AND.IPART1.GT.0) THEN + KFSRCE=IABS(K(IPART1,2)) + ELSEIF(IPART1.GT.IPART2.AND.IPART2.GT.0) THEN + IPART1=K(IPART1,3) + GOTO 240 + ELSEIF(IPART2.GT.IPART1.AND.IPART1.GT.0) THEN + IPART2=K(IPART2,3) + GOTO 240 + ENDIF + ITYPES=0 + IF(KFSRCE.GE.1.AND.KFSRCE.LE.8) ITYPES=1 + IF(KFSRCE.GE.KSUSY1+1.AND.KFSRCE.LE.KSUSY1+8) ITYPES=2 + IF(KFSRCE.GE.KSUSY2+1.AND.KFSRCE.LE.KSUSY2+8) ITYPES=2 + IF(KFSRCE.GE.21.AND.KFSRCE.LE.24) ITYPES=3 + IF(KFSRCE.GE.32.AND.KFSRCE.LE.34) ITYPES=3 + IF(KFSRCE.EQ.25.OR.(KFSRCE.GE.35.AND.KFSRCE.LE.37)) ITYPES=4 + IF(KFSRCE.GE.KSUSY1+22.AND.KFSRCE.LE.KSUSY1+37) ITYPES=5 + IF(KFSRCE.EQ.KSUSY1+21) ITYPES=6 + +C...Identify two primary showerers. + KFLA1=IABS(K(IPART(1),2)) + ITYPE1=0 + IF(KFLA1.GE.1.AND.KFLA1.LE.8) ITYPE1=1 + IF(KFLA1.GE.KSUSY1+1.AND.KFLA1.LE.KSUSY1+8) ITYPE1=2 + IF(KFLA1.GE.KSUSY2+1.AND.KFLA1.LE.KSUSY2+8) ITYPE1=2 + IF(KFLA1.GE.21.AND.KFLA1.LE.24) ITYPE1=3 + IF(KFLA1.GE.32.AND.KFLA1.LE.34) ITYPE1=3 + IF(KFLA1.EQ.25.OR.(KFLA1.GE.35.AND.KFLA1.LE.37)) ITYPE1=4 + IF(KFLA1.GE.KSUSY1+22.AND.KFLA1.LE.KSUSY1+37) ITYPE1=5 + IF(KFLA1.EQ.KSUSY1+21) ITYPE1=6 + KFLA2=IABS(K(IPART(2),2)) + ITYPE2=0 + IF(KFLA2.GE.1.AND.KFLA2.LE.8) ITYPE2=1 + IF(KFLA2.GE.KSUSY1+1.AND.KFLA2.LE.KSUSY1+8) ITYPE2=2 + IF(KFLA2.GE.KSUSY2+1.AND.KFLA2.LE.KSUSY2+8) ITYPE2=2 + IF(KFLA2.GE.21.AND.KFLA2.LE.24) ITYPE2=3 + IF(KFLA2.GE.32.AND.KFLA2.LE.34) ITYPE2=3 + IF(KFLA2.EQ.25.OR.(KFLA2.GE.35.AND.KFLA2.LE.37)) ITYPE2=4 + IF(KFLA2.GE.KSUSY1+22.AND.KFLA2.LE.KSUSY1+37) ITYPE2=5 + IF(KFLA2.EQ.KSUSY1+21) ITYPE2=6 + +C...Order of showerers. Presence of gluino. + ITYPMN=MIN(ITYPE1,ITYPE2) + ITYPMX=MAX(ITYPE1,ITYPE2) + IORD=1 + IF(ITYPE1.GT.ITYPE2) IORD=2 + IGLUI=0 + IF(ITYPE1.EQ.6.OR.ITYPE2.EQ.6) IGLUI=1 + +C...Require exactly two primary showerers for ME corrections. + NPRIM=0 + IF(IPART1.GT.0) THEN + DO 250 I=1,N + IF(K(I,3).EQ.IPART1.AND.K(I,2).NE.K(IPART1,2)) NPRIM=NPRIM+1 + 250 CONTINUE + ENDIF + IF(NPRIM.NE.2) THEN + +C...Predetermined and default matrix element kinds. + ELSEIF(MSTJ(38).NE.0) THEN + M3JC=MSTJ(38) + ALPHA=PARJ(80) + MSTJ(38)=0 + ELSEIF(MSTJ(47).GE.6) THEN + M3JC=MSTJ(47) + ELSE + ICLASS=1 + ICOMBI=4 + +C...Vector/axial vector -> q + qbar; q -> q + V. + IF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.(ITYPES.EQ.0.OR. + & ITYPES.EQ.3)) THEN + ICLASS=2 + IF(KFSRCE.EQ.21.OR.KFSRCE.EQ.22) THEN + ICOMBI=1 + ELSEIF(KFSRCE.EQ.23.OR.(KFSRCE.EQ.0.AND. + & K(IPART(1),2)+K(IPART(2),2).EQ.0)) THEN +C...gamma*/Z0: assume e+e- initial state if unknown. + EI=-1D0 + IF(KFSRCE.EQ.23) THEN + IANNFL=IPART1 + IF(K(IANNFL,2).EQ.23) IANNFL=K(IANNFL,3) + IF(IANNFL.GT.0) THEN + IF(K(IANNFL,2).EQ.23) IANNFL=K(IANNFL,3) + ENDIF + IF(IANNFL.NE.0) THEN + KANNFL=IABS(K(IANNFL,2)) + IF(KANNFL.GE.1.AND.KANNFL.LE.18) EI=KCHG(KANNFL,1)/3D0 + ENDIF + ENDIF + AI=SIGN(1D0,EI+0.1D0) + VI=AI-4D0*EI*PARU(102) + EF=KCHG(KFLA1,1)/3D0 + AF=SIGN(1D0,EF+0.1D0) + VF=AF-4D0*EF*PARU(102) + XWC=1D0/(16D0*PARU(102)*(1D0-PARU(102))) + SH=PSUM(5)**2 + SQMZ=PMAS(23,1)**2 + SQWZ=PSUM(5)*PMAS(23,2) + SBWZ=1D0/((SH-SQMZ)**2+SQWZ**2) + VECT=EI**2*EF**2+2D0*EI*VI*EF*VF*XWC*SH*(SH-SQMZ)*SBWZ+ + & (VI**2+AI**2)*VF**2*XWC**2*SH**2*SBWZ + AXIV=(VI**2+AI**2)*AF**2*XWC**2*SH**2*SBWZ + ICOMBI=3 + ALPHA=VECT/(VECT+AXIV) + ELSEIF(KFSRCE.EQ.24.OR.KFSRCE.EQ.0) THEN + ICOMBI=4 + ENDIF +C...For chi -> chi q qbar, use V/A -> q qbar as first approximation. + ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.5) THEN + ICLASS=2 + ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR. + & ITYPES.EQ.1)) THEN + ICLASS=3 + +C...Scalar/pseudoscalar -> q + qbar; q -> q + S. + ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.4) THEN + ICLASS=4 + IF(KFSRCE.EQ.25.OR.KFSRCE.EQ.35.OR.KFSRCE.EQ.37) THEN + ICOMBI=1 + ELSEIF(KFSRCE.EQ.36) THEN + ICOMBI=2 + ENDIF + ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR. + & ITYPES.EQ.1)) THEN + ICLASS=5 + +C...V -> ~q + ~qbar; ~q -> ~q + V; S -> ~q + ~qbar; ~q -> ~q + S. + ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR. + & ITYPES.EQ.3)) THEN + ICLASS=6 + ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR. + & ITYPES.EQ.2)) THEN + ICLASS=7 + ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.4) THEN + ICLASS=8 + ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR. + & ITYPES.EQ.2)) THEN + ICLASS=9 + +C...chi -> q + ~qbar; ~q -> q + chi; q -> ~q + chi. + ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR. + & ITYPES.EQ.5)) THEN + ICLASS=10 + ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR. + & ITYPES.EQ.2)) THEN + ICLASS=11 + ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR. + & ITYPES.EQ.1)) THEN + ICLASS=12 + +C...~g -> q + ~qbar; ~q -> q + ~g; q -> ~q + ~g. + ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.6) THEN + ICLASS=13 + ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR. + & ITYPES.EQ.2)) THEN + ICLASS=14 + ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR. + & ITYPES.EQ.1)) THEN + ICLASS=15 + +C...g -> ~g + ~g (eikonal approximation). + ELSEIF(ITYPMN.EQ.6.AND.ITYPMX.EQ.6.AND.ITYPES.EQ.0) THEN + ICLASS=16 + ENDIF + M3JC=5*ICLASS+ICOMBI + ENDIF + +C...Store pair that together define matrix element treatment. + IF(M3JC.NE.0) THEN + NMESYS=1 + MESYS(NMESYS,0)=M3JC + MESYS(NMESYS,1)=IPART(1) + MESYS(NMESYS,2)=IPART(2) + ENDIF + +C...Store qqbar or l+l- pairs for QED radiation. + IF(KFLA1.LE.18.AND.KFLA2.LE.18) THEN + NMESYS=NMESYS+1 + MESYS(NMESYS,0)=101 + IF(K(IPART(1),2)+K(IPART(2),2).EQ.0) MESYS(NMESYS,0)=102 + MESYS(NMESYS,1)=IPART(1) + MESYS(NMESYS,2)=IPART(2) + ENDIF + +C...Store other qqbar/l+l- pairs from g/gamma branchings. + DO 290 I1=1,N + IF(K(I1,1).GT.10.OR.IABS(K(I1,2)).GT.18) GOTO 290 + I1M=K(I1,3) + 260 IF(I1M.GT.0) THEN + IF(K(I1M,2).EQ.K(I1,2)) THEN + I1M=K(I1M,3) + GOTO 260 + ENDIF + ENDIF +C...Move up this check to avoid out-of-bounds. + IF(I1M.EQ.0) GOTO 290 + IF(K(I1M,2).NE.21.AND.K(I1M,2).NE.22) GOTO 290 + DO 280 I2=I1+1,N + IF(K(I2,1).GT.10.OR.K(I2,2)+K(I1,2).NE.0) GOTO 280 + I2M=K(I2,3) + 270 IF(I2M.GT.0) THEN + IF(K(I2M,2).EQ.K(I2,2)) THEN + I2M=K(I2M,3) + GOTO 270 + ENDIF + ENDIF + IF(I1M.EQ.I2M.AND.I1M.GT.0) THEN + NMESYS=NMESYS+1 + MESYS(NMESYS,0)=66 + MESYS(NMESYS,1)=I1 + MESYS(NMESYS,2)=I2 + NMESYS=NMESYS+1 + MESYS(NMESYS,0)=102 + MESYS(NMESYS,1)=I1 + MESYS(NMESYS,2)=I2 + ENDIF + 280 CONTINUE + 290 CONTINUE + ENDIF + +C..Loopback point for counting number of emissions. + NGEN=0 + 300 NGEN=NGEN+1 + +C...Begin loop to evolve all existing partons, if required. + 310 IMX=0 + PT2MX=0D0 + DO 380 IEVOL=1,NEVOL + IF(IFLG(IEVOL).EQ.0) THEN + +C...Basic info on radiator and recoil. + I=IPOS(IEVOL) + IR=IREC(IEVOL) + SHT=SHAT(I,IR) + PM2I=P(I,5)**2 + PM2R=P(IR,5)**2 + +C...Skip any particles that are "turned off" + IF (MSTJ(39).GT.0.AND.IABS(K(I,2)).EQ.MSTJ(39)) GOTO 380 + +C...Invariant mass of "dipole".Starting value for pT evolution. + SHTCOR=(SQRT(SHT)-P(IR,5))**2-PM2I + PT2=MIN(PT2CMX,0.25D0*SHTCOR,PTSCA(IEVOL)**2) + +C...Case of evolution by QCD branching. + IF(ISCOL(IEVOL).NE.0) THEN + +C...Parton-by-parton maximum scale from initial conditions. + IF(MSTP(72).EQ.0) THEN + DO 320 IPRT=1,NPARTS + IF(IR.EQ.IPART(IPRT)) PT2=MIN(PT2,PTPART(IPRT)**2) + 320 CONTINUE + ENDIF + +C...If kinematically impossible then do not evolve. + IF(PT2.LT.PT2CMN) THEN + IFLG(IEVOL)=-1 + GOTO 380 + ENDIF + +C...Check if part of system for which ME corrections should be applied. + IMESYS=0 + DO 330 IME=1,NMESYS + IF((I.EQ.MESYS(IME,1).OR.I.EQ.MESYS(IME,2)).AND. + & MESYS(IME,0).LT.100) IMESYS=IME + 330 CONTINUE + +C...Special flag for colour octet states. +C...MOCT=1: can do gluon splitting g->qqbar; MOCT=2: cannot. + MOCT=0 + KC = PYCOMP(K(I,2)) + IF(K(I,2).EQ.21) THEN + MOCT=1 + ELSEIF(KCHG(KC,2).EQ.2) THEN + MOCT=2 + ENDIF +C...QUARKONIA++ + IF(MSTP(148).GE.1.AND.IABS(K(I,2)).EQ.9900101.AND. + & IABS(K(I,2)).LE.9910555) MOCT=2 +C...QUARKONIA-- + + +C...Upper estimate for matrix element weighting and colour factor. +C...Note that g->gg and g->qqbar is split on two sides = "dipoles". + WTPSGL=2D0 + COLFAC=4D0/3D0 + IF(MOCT.GE.1) COLFAC=3D0/2D0 + IF(IGLUI.EQ.1.AND.IMESYS.EQ.1.AND.MOCT.EQ.0) COLFAC=3D0 + WTPSQQ=0.5D0*0.5D0*NFLAV + +C...Determine overestimated z range: switch at c and b masses. + 340 IZRG=1 + PT2MNE=PT2CMN + B0=27D0/6D0 + ALAMS=ALAM3S + IF(PT2.GT.1.01D0*PMCS) THEN + IZRG=2 + PT2MNE=PMCS + B0=25D0/6D0 + ALAMS=ALAM4S + ENDIF + IF(PT2.GT.1.01D0*PMBS) THEN + IZRG=3 + PT2MNE=PMBS + B0=23D0/6D0 + ALAMS=ALAM5S + ENDIF + ZMNCUT=0.5D0-SQRT(MAX(0D0,0.25D0-PT2MNE/SHTCOR)) + IF(ZMNCUT.LT.1D-8) ZMNCUT=PT2MNE/SHTCOR + +C...Find evolution coefficients for q->qg/g->gg and g->qqbar. + EVEMGL=WTPSGL*COLFAC*LOG(1D0/ZMNCUT-1D0)/B0 + EVCOEF=EVEMGL + IF(MOCT.EQ.1) THEN + EVEMQQ=WTPSQQ*(1D0-2D0*ZMNCUT)/B0 + EVCOEF=EVCOEF+EVEMQQ + ENDIF + +C...Pick pT2 (in overestimated z range). + 350 PT2=ALAMS*(PT2/ALAMS)**(PYR(0)**(1D0/EVCOEF)) + +C...Loopback if crossed c/b mass thresholds. + IF(IZRG.EQ.3.AND.PT2.LT.PMBS) THEN + PT2=PMBS + GOTO 340 + ENDIF + IF(IZRG.EQ.2.AND.PT2.LT.PMCS) THEN + PT2=PMCS + GOTO 340 + ENDIF + +C...Finish if below lower cutoff. + IF(PT2.LT.PT2CMN) THEN + IFLG(IEVOL)=-1 + GOTO 380 + ENDIF + +C...Pick kind of branching: q->qg/g->gg/X->Xg or g->qqbar. +C...IFLAG=1: gluon emission; IFLAG=2: gluon splitting + IFLAG=1 + IF(MOCT.EQ.1.AND.EVEMGL.LT.PYR(0)*EVCOEF) IFLAG=2 + +C...Pick z: dz/(1-z) or dz. + IF(IFLAG.EQ.1) THEN + Z=1D0-ZMNCUT*(1D0/ZMNCUT-1D0)**PYR(0) + ELSE + Z=ZMNCUT+PYR(0)*(1D0-2D0*ZMNCUT) + ENDIF + +C...Loopback if outside allowed range for given pT2. + ZMNNOW=0.5D0-SQRT(MAX(0D0,0.25D0-PT2/SHTCOR)) + IF(ZMNNOW.LT.1D-8) ZMNNOW=PT2/SHTCOR + IF(Z.LE.ZMNNOW.OR.Z.GE.1D0-ZMNNOW) GOTO 350 + PM2=PM2I+PT2/(Z*(1D0-Z)) + IF(Z*(1D0-Z).LE.PM2*SHT/(SHT+PM2-PM2R)**2) GOTO 350 + +C...No weighting for primary partons; to be done later on. + IF(IMESYS.GT.0) THEN + +C...Weighting of q->qg/X->Xg branching. + ELSEIF(IFLAG.EQ.1.AND.MOCT.NE.1) THEN + IF(1D0+Z**2.LT.WTPSGL*PYR(0)) GOTO 350 + +C...Weighting of g->gg branching. + ELSEIF(IFLAG.EQ.1) THEN + IF(1D0+Z**3.LT.WTPSGL*PYR(0)) GOTO 350 + +C...Flavour choice and weighting of g->qqbar branching. + ELSE + KFQ=MIN(5,1+INT(NFLAV*PYR(0))) + PMQ=PMAS(KFQ,1) + ROOTQQ=SQRT(MAX(0D0,1D0-4D0*PMQ**2/PM2)) + WTME=ROOTQQ*(Z**2+(1D0-Z)**2) + IF(WTME.LT.PYR(0)) GOTO 350 + IFLAG=10+KFQ + ENDIF + +C...Case of evolution by QED branching. + ELSEIF(ISCHG(IEVOL).NE.0) THEN + +C...If kinematically impossible then do not evolve. + PT2EMN=PT0EQ**2 + IF(IABS(K(I,2)).GT.10) PT2EMN=PT0EL**2 + IF(PT2.LT.PT2EMN) THEN + IFLG(IEVOL)=-1 + GOTO 380 + ENDIF + +C...Check if part of system for which ME corrections should be applied. + IMESYS=0 + DO 360 IME=1,NMESYS + IF((I.EQ.MESYS(IME,1).OR.I.EQ.MESYS(IME,2)).AND. + & MESYS(IME,0).GT.100) IMESYS=IME + 360 CONTINUE + +C...Charge. Matrix element weighting factor. + CHG=ISCHG(IEVOL)/3D0 + WTPSGA=2D0 + +C...Determine overestimated z range. Find evolution coefficient. + ZMNCUT=0.5D0-SQRT(MAX(0D0,0.25D0-PT2EMN/SHTCOR)) + IF(ZMNCUT.LT.1D-8) ZMNCUT=PT2EMN/SHTCOR + EVCOEF=AEM2PI*CHG**2*WTPSGA*LOG(1D0/ZMNCUT-1D0) + +C...Pick pT2 (in overestimated z range). + 370 PT2=PT2*PYR(0)**(1D0/EVCOEF) + +C...Finish if below lower cutoff. + IF(PT2.LT.PT2EMN) THEN + IFLG(IEVOL)=-1 + GOTO 380 + ENDIF + +C...Pick z: dz/(1-z). + Z=1D0-ZMNCUT*(1D0/ZMNCUT-1D0)**PYR(0) + +C...Loopback if outside allowed range for given pT2. + ZMNNOW=0.5D0-SQRT(MAX(0D0,0.25D0-PT2/SHTCOR)) + IF(ZMNNOW.LT.1D-8) ZMNNOW=PT2/SHTCOR + IF(Z.LE.ZMNNOW.OR.Z.GE.1D0-ZMNNOW) GOTO 370 + PM2=PM2I+PT2/(Z*(1D0-Z)) + IF(Z*(1D0-Z).LE.PM2*SHT/(SHT+PM2-PM2R)**2) GOTO 370 + +C...Weighting by branching kernel, except if ME weighting later. + IF(IMESYS.EQ.0) THEN + IF(1D0+Z**2.LT.WTPSGA*PYR(0)) GOTO 370 + ENDIF + IFLAG=3 + ENDIF + +C...Save acceptable branching. + IFLG(IEVOL)=IFLAG + IMESAV(IEVOL)=IMESYS + PT2SAV(IEVOL)=PT2 + ZSAV(IEVOL)=Z + SHTSAV(IEVOL)=SHT + ENDIF + +C...Check if branching has highest pT. + IF(IFLG(IEVOL).GE.1.AND.PT2SAV(IEVOL).GT.PT2MX) THEN + IMX=IEVOL + PT2MX=PT2SAV(IEVOL) + ENDIF + 380 CONTINUE + +C...Finished if no more branchings to be done. + IF(IMX.EQ.0) GOTO 520 + +C...Restore info on hardest branching to be processed. + I=IPOS(IMX) + IR=IREC(IMX) + KCOL=ISCOL(IMX) + KCHA=ISCHG(IMX) + IMESYS=IMESAV(IMX) + PT2=PT2SAV(IMX) + Z=ZSAV(IMX) + SHT=SHTSAV(IMX) + PM2I=P(I,5)**2 + PM2R=P(IR,5)**2 + PM2=PM2I+PT2/(Z*(1D0-Z)) + +C...Special flag for colour octet states. + MOCT=0 + KC = PYCOMP(K(I,2)) + IF(K(I,2).EQ.21) THEN + MOCT=1 + ELSEIF(KCHG(KC,2).EQ.2) THEN + MOCT=2 + ENDIF +C...QUARKONIA++ + IF(MSTP(148).GE.1.AND.IABS(K(I,2)).GE.9900101.AND. + & IABS(K(I,2)).LE.9910555) MOCT=2 +C...QUARKONIA-- + +C...Restore further info for g->qqbar branching. + KFQ=0 + IF(IFLG(IMX).GT.10) THEN + KFQ=IFLG(IMX)-10 + PMQ=PMAS(KFQ,1) + ROOTQQ=SQRT(MAX(0D0,1D0-4D0*PMQ**2/PM2)) + ENDIF + +C...For branching g include azimuthal asymmetries from polarization. + ASYPOL=0D0 + IF(MOCT.EQ.1.AND.MOD(MSTJ(46),2).EQ.1) THEN +C...Trace grandmother via intermediate recoil copies. + KFGM=0 + IM=I + 390 IF(K(IM,3).NE.K(IM-1,3).AND.K(IM,3).NE.K(IM+1,3).AND. + & K(IM,3).GT.0) THEN + IM=K(IM,3) + IF(IM.GT.MINT(84)) GOTO 390 + ENDIF + IGM=K(IM,3) + IF(IGM.GT.MINT(84).AND.IGM.LT.IM.AND.IM.LE.I) + & KFGM=IABS(K(IGM,2)) +C...Define approximate energy sharing by identifying aunt. + IAU=IM+1 + IF(IAU.GT.N-3.OR.K(IAU,3).NE.IGM) IAU=IM-1 + IF(KFGM.NE.0.AND.(KFGM.LE.6.OR.KFGM.EQ.21)) THEN + ZOLD=P(IM,4)/(P(IM,4)+P(IAU,4)) +C...Coefficient from gluon production. + IF(KFGM.LE.6) THEN + ASYPOL=2D0*(1D0-ZOLD)/(1D0+(1D0-ZOLD)**2) + ELSE + ASYPOL=((1D0-ZOLD)/(1D0-ZOLD*(1D0-ZOLD)))**2 + ENDIF +C...Coefficient from gluon decay. + IF(KFQ.EQ.0) THEN + ASYPOL=ASYPOL*(Z*(1D0-Z)/(1D0-Z*(1D0-Z)))**2 + ELSE + ASYPOL=-ASYPOL*2D0*Z*(1D0-Z)/(1D0-2D0*Z*(1D0-Z)) + ENDIF + ENDIF + ENDIF + +C...Create new slots for branching products and recoil. + INEW=N+1 + IGNEW=N+2 + IRNEW=N+3 + N=N+3 + +C...Set status, flavour and mother of new ones. + K(INEW,1)=K(I,1) + K(IGNEW,1)=3 + IF(KCHA.NE.0) K(IGNEW,1)=1 + K(IRNEW,1)=K(IR,1) + IF(KFQ.EQ.0) THEN + K(INEW,2)=K(I,2) + K(IGNEW,2)=21 + IF(KCHA.NE.0) K(IGNEW,2)=22 + ELSE + K(INEW,2)=-ISIGN(KFQ,KCOL) + K(IGNEW,2)=-K(INEW,2) + ENDIF + K(IRNEW,2)=K(IR,2) + K(INEW,3)=I + K(IGNEW,3)=I + K(IRNEW,3)=IR + +C...Find rest frame and angles of branching+recoil. + DO 400 J=1,5 + P(INEW,J)=P(I,J) + P(IGNEW,J)=0D0 + P(IRNEW,J)=P(IR,J) + 400 CONTINUE + BETAX=(P(INEW,1)+P(IRNEW,1))/(P(INEW,4)+P(IRNEW,4)) + BETAY=(P(INEW,2)+P(IRNEW,2))/(P(INEW,4)+P(IRNEW,4)) + BETAZ=(P(INEW,3)+P(IRNEW,3))/(P(INEW,4)+P(IRNEW,4)) + CALL PYROBO(INEW,IRNEW,0D0,0D0,-BETAX,-BETAY,-BETAZ) + PHI=PYANGL(P(INEW,1),P(INEW,2)) + THETA=PYANGL(P(INEW,3),SQRT(P(INEW,1)**2+P(INEW,2)**2)) + +C...Derive kinematics of branching: generics (like g->gg). + DO 410 J=1,4 + P(INEW,J)=0D0 + P(IRNEW,J)=0D0 + 410 CONTINUE + PEM=0.5D0*(SHT+PM2-PM2R)/SQRT(SHT) + PZM=0.5D0*SQRT(MAX(0D0,(SHT-PM2-PM2R)**2-4D0*PM2*PM2R)/SHT) + PT2COR=PM2*(PEM**2*Z*(1D0-Z)-0.25D0*PM2)/PZM**2 + PTCOR=SQRT(MAX(0D0,PT2COR)) + PZN=(PEM**2*Z-0.5D0*PM2)/PZM + PZG=(PEM**2*(1D0-Z)-0.5D0*PM2)/PZM +C...Specific kinematics reduction for q->qg with m_q > 0. + IF(MOCT.NE.1) THEN + PTCOR=(1D0-PM2I/PM2)*PTCOR + PZN=PZN+PM2I*PZG/PM2 + PZG=(1D0-PM2I/PM2)*PZG +C...Specific kinematics reduction for g->qqbar with m_q > 0. + ELSEIF(KFQ.NE.0) THEN + P(INEW,5)=PMQ + P(IGNEW,5)=PMQ + PTCOR=ROOTQQ*PTCOR + PZN=0.5D0*((1D0+ROOTQQ)*PZN+(1D0-ROOTQQ)*PZG) + PZG=PZM-PZN + ENDIF + +C...Pick phi and construct kinematics of branching. + 420 PHIROT=PARU(2)*PYR(0) + P(INEW,1)=PTCOR*COS(PHIROT) + P(INEW,2)=PTCOR*SIN(PHIROT) + P(INEW,3)=PZN + P(INEW,4)=SQRT(PTCOR**2+P(INEW,3)**2+P(INEW,5)**2) + P(IGNEW,1)=-P(INEW,1) + P(IGNEW,2)=-P(INEW,2) + P(IGNEW,3)=PZG + P(IGNEW,4)=SQRT(PTCOR**2+P(IGNEW,3)**2+P(IGNEW,5)**2) + P(IRNEW,1)=0D0 + P(IRNEW,2)=0D0 + P(IRNEW,3)=-PZM + P(IRNEW,4)=0.5D0*(SHT+PM2R-PM2)/SQRT(SHT) + +C...Boost branching system to lab frame. + CALL PYROBO(INEW,IRNEW,THETA,PHI,BETAX,BETAY,BETAZ) + +C...Renew choice of phi angle according to polarization asymmetry. + IF(ABS(ASYPOL).GT.1D-3) THEN + DO 430 J=1,3 + DPT(1,J)=P(I,J) + DPT(2,J)=P(IAU,J) + DPT(3,J)=P(INEW,J) + 430 CONTINUE + DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3) + DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3) + DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2 + DO 440 J=1,3 + DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/MAX(1D-10,DPMM) + DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/MAX(1D-10,DPMM) + 440 CONTINUE + DPT(4,4)=SQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2) + DPT(5,4)=SQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2) + IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1D0*PARJ(82)) THEN + CAD=(DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+ + & DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4)) + IF(1D0+ASYPOL*(2D0*CAD**2-1D0).LT.PYR(0)*(1D0+ABS(ASYPOL))) + & GOTO 420 + ENDIF + ENDIF + +C...Matrix element corrections for primary partons when requested. + IF(IMESYS.GT.0) THEN + M3JC=MESYS(IMESYS,0) + +C...Identify recoiling partner and set up three-body kinematics. + IRP=MESYS(IMESYS,1) + IF(IRP.EQ.I) IRP=MESYS(IMESYS,2) + IF(IRP.EQ.IR) IRP=IRNEW + DO 450 J=1,4 + PSUM(J)=P(INEW,J)+P(IRP,J)+P(IGNEW,J) + 450 CONTINUE + PSUM(5)=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2- + & PSUM(3)**2)) + X1=2D0*(PSUM(4)*P(INEW,4)-PSUM(1)*P(INEW,1)-PSUM(2)*P(INEW,2)- + & PSUM(3)*P(INEW,3))/PSUM(5)**2 + X2=2D0*(PSUM(4)*P(IRP,4)-PSUM(1)*P(IRP,1)-PSUM(2)*P(IRP,2)- + & PSUM(3)*P(IRP,3))/PSUM(5)**2 + X3=2D0-X1-X2 + R1ME=P(INEW,5)/PSUM(5) + R2ME=P(IRP,5)/PSUM(5) + +C...Matrix elements for gluon emission. + IF(M3JC.LT.100) THEN + +C...Call ME, with right order important for two inequivalent showerers. + IF(MESYS(IMESYS,IORD).EQ.I) THEN + WME=PYMAEL(M3JC,X1,X2,R1ME,R2ME,ALPHA) + ELSE + WME=PYMAEL(M3JC,X2,X1,R2ME,R1ME,ALPHA) + ENDIF + +C...Split up total ME when two radiating partons. + ISPRAD=1 + IF((M3JC.GE.16.AND.M3JC.LE.19).OR.(M3JC.GE.26.AND.M3JC.LE.29) + & .OR.(M3JC.GE.36.AND.M3JC.LE.39).OR.(M3JC.GE.46.AND.M3JC.LE.49) + & .OR.(M3JC.GE.56.AND.M3JC.LE.64)) ISPRAD=0 + IF(ISPRAD.EQ.1) WME=WME*MAX(1D-10,1D0+R1ME**2-R2ME**2-X1)/ + & MAX(1D-10,2D0-X1-X2) + +C...Evaluate shower rate. + WPS=2D0/(MAX(1D-10,2D0-X1-X2)* + & MAX(1D-10,1D0+R2ME**2-R1ME**2-X2)) + IF(IGLUI.EQ.1) WPS=(9D0/4D0)*WPS + +C...Matrix elements for photon emission: still rather primitive. + ELSE + +C...For generic charge combination currently only massless expression. + IF(M3JC.EQ.101) THEN + CHG1=KCHG(PYCOMP(K(I,2)),1)*ISIGN(1,K(I,2))/3D0 + CHG2=KCHG(PYCOMP(K(IRP,2)),1)*ISIGN(1,K(IRP,2))/3D0 + WME=(CHG1*(1D0-X1)/X3-CHG2*(1D0-X2)/X3)**2*(X1**2+X2**2) + WPS=2D0*(CHG1**2*(1D0-X1)/X3+CHG2**2*(1D0-X2)/X3) + +C...For flavour neutral system assume vector source and include masses. + ELSE + WME=PYMAEL(11,X1,X2,R1ME,R2ME,0D0)*MAX(1D-10, + & 1D0+R1ME**2-R2ME**2-X1)/MAX(1D-10,2D0-X1-X2) + WPS=2D0/(MAX(1D-10,2D0-X1-X2)* + & MAX(1D-10,1D0+R2ME**2-R1ME**2-X2)) + ENDIF + ENDIF + +C...Perform weighting with W_ME/W_PS. + IF(WME.LT.PYR(0)*WPS) THEN + N=N-3 + IFLG(IMX)=0 + PT2CMX=PT2 + GOTO 310 + ENDIF + ENDIF + +C...Now for sure accepted branching. Save highest pT. + IF(NGEN.EQ.1) PTGEN=SQRT(PT2) + +C...Update status for obsolete ones. Bookkkep the moved original parton +C...and new daughter (arbitrary choice for g->gg or g->qqbar). +C...Do not bookkeep radiated photon, since it cannot radiate further. + K(I,1)=K(I,1)+10 + K(IR,1)=K(IR,1)+10 + DO 460 IP=1,NPART + IF(IPART(IP).EQ.I) IPART(IP)=INEW + IF(IPART(IP).EQ.IR) IPART(IP)=IRNEW + 460 CONTINUE + IF(KCHA.EQ.0) THEN + NPART=NPART+1 + IPART(NPART)=IGNEW + ENDIF + +C...Initialize colour flow of branching. +C...Use both old and new style colour tags for flexibility. + K(INEW,4)=0 + K(IGNEW,4)=0 + K(INEW,5)=0 + K(IGNEW,5)=0 + JCOLP=4+(1-KCOL)/2 + JCOLN=9-JCOLP + MCT(INEW,1)=0 + MCT(INEW,2)=0 + MCT(IGNEW,1)=0 + MCT(IGNEW,2)=0 + MCT(IRNEW,1)=0 + MCT(IRNEW,2)=0 + +C...Trivial colour flow for l->lgamma and q->qgamma. + IF(IABS(KCHA).EQ.3) THEN + K(I,4)=INEW + K(I,5)=IGNEW + ELSEIF(KCHA.NE.0) THEN + IF(K(I,4).NE.0) THEN + K(I,4)=K(I,4)+INEW + K(INEW,4)=MSTU(5)*I + MCT(INEW,1)=MCT(I,1) + ENDIF + IF(K(I,5).NE.0) THEN + K(I,5)=K(I,5)+INEW + K(INEW,5)=MSTU(5)*I + MCT(INEW,2)=MCT(I,2) + ENDIF + +C...Set colour flow for q->qg and g->gg. + ELSEIF(KFQ.EQ.0) THEN + K(I,JCOLP)=K(I,JCOLP)+IGNEW + K(IGNEW,JCOLP)=MSTU(5)*I + K(INEW,JCOLP)=MSTU(5)*IGNEW + K(IGNEW,JCOLN)=MSTU(5)*INEW + MCT(IGNEW,JCOLP-3)=MCT(I,JCOLP-3) + NCT=NCT+1 + MCT(INEW,JCOLP-3)=NCT + MCT(IGNEW,JCOLN-3)=NCT + IF(MOCT.GE.1) THEN + K(I,JCOLN)=K(I,JCOLN)+INEW + K(INEW,JCOLN)=MSTU(5)*I + MCT(INEW,JCOLN-3)=MCT(I,JCOLN-3) + ENDIF + +C...Set colour flow for g->qqbar. + ELSE + K(I,JCOLN)=K(I,JCOLN)+INEW + K(INEW,JCOLN)=MSTU(5)*I + K(I,JCOLP)=K(I,JCOLP)+IGNEW + K(IGNEW,JCOLP)=MSTU(5)*I + MCT(INEW,JCOLN-3)=MCT(I,JCOLN-3) + MCT(IGNEW,JCOLP-3)=MCT(I,JCOLP-3) + ENDIF + +C...Daughter info for colourless recoiling parton. + IF(K(IR,4).EQ.0.AND.K(IR,5).EQ.0) THEN + K(IR,4)=IRNEW + K(IR,5)=IRNEW + K(IRNEW,4)=0 + K(IRNEW,5)=0 + +C...Colour of recoiling parton sails through unchanged. + ELSE + IF(K(IR,4).NE.0) THEN + K(IR,4)=K(IR,4)+IRNEW + K(IRNEW,4)=MSTU(5)*IR + MCT(IRNEW,1)=MCT(IR,1) + ENDIF + IF(K(IR,5).NE.0) THEN + K(IR,5)=K(IR,5)+IRNEW + K(IRNEW,5)=MSTU(5)*IR + MCT(IRNEW,2)=MCT(IR,2) + ENDIF + ENDIF + +C...Vertex information trivial. + DO 470 J=1,5 + V(INEW,J)=V(I,J) + V(IGNEW,J)=V(I,J) + V(IRNEW,J)=V(IR,J) + 470 CONTINUE + +C...Update list of old radiators. + DO 480 IEVOL=1,NEVOL +C... A) radiator-recoiler mother pair for this branching + IF(IPOS(IEVOL).EQ.I.AND.IREC(IEVOL).EQ.IR) THEN + IPOS(IEVOL)=INEW +C... A2) QCD branching and color side matches, radiated parton follows recoiler + IF(KCOL.NE.0.AND.ISCOL(IEVOL).EQ.KCOL) IPOS(IEVOL)=IGNEW + IREC(IEVOL)=IRNEW + IFLG(IEVOL)=0 + ELSEIF(IPOS(IEVOL).EQ.I) THEN +C... B) other dipoles with I as radiator simply get INEW as new radiator + IPOS(IEVOL)=INEW + IFLG(IEVOL)=0 + ELSEIF(IPOS(IEVOL).EQ.IR.AND.IREC(IEVOL).EQ.I) THEN +C... C) the "mirror image" of the parent dipole + IPOS(IEVOL)=IRNEW + IREC(IEVOL)=INEW +C... C2) QCD branching and color side matches, radiated parton follows recoiler + IF(KCOL.NE.0.AND.ISCOL(IEVOL).NE.KCOL.AND.ISCOL(IEVOL).NE.0) + & IREC(IEVOL)=IGNEW + IFLG(IEVOL)=0 + ELSEIF(IPOS(IEVOL).EQ.IR) THEN +C... D) other dipoles with IR as radiator simply get IRNEW as new radiator + IPOS(IEVOL)=IRNEW + IFLG(IEVOL)=0 + ENDIF +C... Update links of old connected partons. + IF(IREC(IEVOL).EQ.I) THEN + IREC(IEVOL)=INEW + IFLG(IEVOL)=0 + ELSEIF(IREC(IEVOL).EQ.IR) THEN + IREC(IEVOL)=IRNEW + IFLG(IEVOL)=0 + ENDIF + 480 CONTINUE + +C...q->qg or g->gg: create new gluon radiators. + IF(KCOL.NE.0.AND.KFQ.EQ.0) THEN + NEVOL=NEVOL+1 + IPOS(NEVOL)=INEW + IREC(NEVOL)=IGNEW + IFLG(NEVOL)=0 + ISCOL(NEVOL)=KCOL + ISCHG(NEVOL)=0 + PTSCA(NEVOL)=SQRT(PT2) + NEVOL=NEVOL+1 + IPOS(NEVOL)=IGNEW + IREC(NEVOL)=INEW + IFLG(NEVOL)=0 + ISCOL(NEVOL)=-KCOL + ISCHG(NEVOL)=0 + PTSCA(NEVOL)=PTSCA(NEVOL-1) +C...g->qqbar: create new photon radiators. + ELSEIF(KCOL.EQ.2.AND.KFQ.NE.0) THEN + NEVOL=NEVOL+1 + IPOS(NEVOL)=INEW + IREC(NEVOL)=IGNEW + IFLG(NEVOL)=0 + ISCOL(NEVOL)=0 + ISCHG(NEVOL)=PYK(INEW,6) + PTSCA(NEVOL)=SQRT(PT2) + NEVOL=NEVOL+1 + IPOS(NEVOL)=IGNEW + IREC(NEVOL)=INEW + IFLG(NEVOL)=0 + ISCOL(NEVOL)=0 + ISCHG(NEVOL)=PYK(IGNEW,6) + PTSCA(NEVOL)=SQRT(PT2) + CALL PYLIST(4) + print*, 'created new QED dipole ',INEW,'<->',IGNEW + ENDIF + +C...Check color and charge connections, +C...Rewire if better partners can be found (screening, etc) + DO 500 IEVOL=1,NEVOL + KCOL = ISCOL(IEVOL) + KCHA = ISCHG(IEVOL) + IRTMP = IREC(IEVOL) + ITMP = IPOS(IEVOL) +C...Do not modify QED dipoles + IF (KCHA.NE.0) THEN + GOTO 500 +C...Also skip dipole ends that are switched off + ELSEIF (IFLG(IEVOL).LE.-1) THEN + GOTO 500 + ELSEIF (KCOL.NE.0) THEN +C...QCD dipoles. Check if current recoiler has appropriate color charge + KCOLR = PYK(IRTMP,12) + IF (KCOLR.EQ.2.OR.KCOLR.EQ.-KCOL) GOTO 500 +C...If not, look for closest recoiler with appropriate color charge + RM2MIN = PSUM(5)**2 + JMX = 0 + ISGOOD = 0 + DO 490 JEVOL=1,NEVOL +C...Skip self + IF (JEVOL.EQ.IEVOL) GOTO 490 + JTMP = IPOS(JEVOL) + IF (JTMP.EQ.ITMP) GOTO 490 + JCOL = ISCOL(JEVOL) +C...Skip dipole ends that are switched off + IF (IFLG(JEVOL).LE.-1) GOTO 490 +C...Skip QED dipole ends + IF (ISCHG(JEVOL).NE.0) GOTO 490 +C... Skip wrong-color if at least one correct-color partner already found + IF (ISGOOD.NE.0.AND.JCOL.NE.-KCOL.AND.JCOL.NE.2) GOTO 490 +C...Accept if smallest m2 so far, or if first with correct color + RM2 = DOTP(ITMP,JTMP) + ISGNOW = 0 + IF (JCOL.EQ.-KCOL.OR.JCOL.EQ.2) ISGNOW=1 + IF (RM2.LT.RM2MIN.OR.ISGNOW.GT.ISGOOD) THEN + ISGOOD = ISGNOW + RM2MIN = RM2 + JMX = JEVOL + ENDIF + 490 CONTINUE +C...Update recoiler and reset dipole if new best partner found + IF (JMX.NE.0) THEN + IREC(IEVOL) = IPOS(JMX) + IFLG(IEVOL) = 0 + ENDIF + ENDIF + 500 CONTINUE + +C...TMP! print out list of dipoles +C DO 580 IEVOL=1,NEVOL +C KCHA = ISCHG(IEVOL) +C IF (KCHA.NE.0) THEN +C print*, 'qed dip',IPOS(IEVOL),IREC(IEVOL) +C ELSE +C print*, 'qcd dip',IPOS(IEVOL),IREC(IEVOL) +C ENDIF +C 580 CONTINUE + +C...Update matrix elements parton list and add new for g/gamma->qqbar. + DO 510 IME=1,NMESYS + IF(MESYS(IME,1).EQ.I) MESYS(IME,1)=INEW + IF(MESYS(IME,2).EQ.I) MESYS(IME,2)=INEW + IF(MESYS(IME,1).EQ.IR) MESYS(IME,1)=IRNEW + IF(MESYS(IME,2).EQ.IR) MESYS(IME,2)=IRNEW + 510 CONTINUE + IF(KFQ.NE.0) THEN + NMESYS=NMESYS+1 + MESYS(NMESYS,0)=66 + MESYS(NMESYS,1)=INEW + MESYS(NMESYS,2)=IGNEW + NMESYS=NMESYS+1 + MESYS(NMESYS,0)=102 + MESYS(NMESYS,1)=INEW + MESYS(NMESYS,2)=IGNEW + ENDIF + +C...Global statistics. + MINT(353)=MINT(353)+1 + VINT(353)=VINT(353)+PTCOR + IF (MINT(353).EQ.1) VINT(358)=PTCOR + +C...Loopback for more emissions if enough space. + PT2CMX=PT2 + IF(NPART.LT.MAXNUR-1.AND.NEVOL.LT.2*MAXNUR-2.AND. + &NMESYS.LT.MAXNUR-2.AND.N.LT.MSTU(4)-MSTU(32)-5) THEN + GOTO 300 + ELSE + CALL PYERRM(11,'(PYPTFS:) no more memory left for shower') + ENDIF + +C...Done. + 520 CONTINUE + + RETURN + END + +C********************************************************************* + +C...PYMAEL +C...Auxiliary to PYSHOW and PYPTFS. +C...Matrix elements for gluon (or photon) emission from +C...a two-body state; to be used by the parton shower routine. +C...Here X_i = 2 E_i/E_cm, R_i = m_i/E_cm and +C...1/sigma_0 d(sigma)/d(x_1)d(x_2) = +C... = (alpha-strong/2 pi) * CF * PYMAEL, +C...i.e. normalization is such that one recovers the familiar +C...(X1**2+X2**2)/((1-X1)*(1-X2)) for the massless case. +C...Coupling structure: +C...NI = 6- 9 : eikonal soft-gluon expression (spin-independent) +C... = 11-14 : V -> q qbar (V = vector/axial vector colour singlet) +C... = 16-19 : q -> q V +C... = 21-24 : S -> q qbar (S = scalar/pseudoscalar colour singlet) +C... = 26-29 : q -> q S +C... = 31-34 : V -> ~q ~qbar (~q = squark) +C... = 36-39 : ~q -> ~q V +C... = 41-44 : S -> ~q ~qbar +C... = 46-49 : ~q -> ~q S +C... = 51-54 : chi -> q ~qbar (chi = neutralino/chargino) +C... = 56-59 : ~q -> q chi +C... = 61-64 : q -> ~q chi +C... = 66-69 : ~g -> q ~qbar +C... = 71-74 : ~q -> q ~g +C... = 76-79 : q -> ~q ~g +C... = 81-84 : (9/4)*(eikonal) for gg -> ~g ~g +C...Note that the order of the decay products is important. +C...In each set of four, the variants are ordered as: +C...ICOMBI = 1 : pure non-gamma5, i.e. vector/scalar/... +C... = 2 : pure gamma5, i.e. axial vector/pseudoscalar/.... +C... = 3 : mixture alpha*(ICOMBI=1) + (1-alpha)*(ICOMBI=2) +C... = 4 : mixture (ICOMBI=1) +- (ICOMBI=2) + + FUNCTION PYMAEL(NI,X1,X2,R1,R2,ALPHA) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + +C...Check input values. Return zero outside allowed phase space. + PYMAEL=0D0 + IF(X1.LE.2D0*R1.OR.X1.GE.1D0+R1**2-R2**2) RETURN + IF(X2.LE.2D0*R2.OR.X2.GE.1D0+R2**2-R1**2) RETURN + IF(X1+X2.LE.1D0+(R1+R2)**2) RETURN + IF((2D0-2D0*X1-2D0*X2+X1*X2+2D0*R1**2+2D0*R2**2)**2.GE. + &(X1**2-4D0*R1**2)*(X2**2-4D0*R2**2)) RETURN + ALPCOR=MAX(0D0,MIN(1D0,ALPHA)) + +C...Initial values and flags. + ICLASS=NI/5 + ICOMBI=NI-5*ICLASS + ISSET1=0 + ISSET2=0 + ISSET4=0 + +C... Phase space. + PS=SQRT((1D0-(R1+R2)**2)*(1D0-(R1-R2)**2)) + +C...Eikonal expression; also acts as default. + IF(ICLASS.LE.1.OR.ICLASS.GE.17.OR.ICOMBI.EQ.0) THEN + RLO=PS + IF(ICOMBI.EQ.0.OR.ICOMBI.EQ.1) THEN + ANUM=0D0 + ELSEIF(ICOMBI.EQ.2) THEN + ANUM=(2D0-X1-X2)**2 + ELSEIF(ICOMBI.EQ.3) THEN + ANUM=ALPCOR*(2D0-X1-X2)**2 + ELSE + ANUM=0.5D0*(2D0-X1-X2)**2 + ENDIF + RFO=PS*2D0*((X1+X2-1D0+ANUM-R1**2-R2**2)/ + & ((1D0+R1**2-R2**2-X1)*(1D0+R2**2-R1**2-X2))- + & R1**2/(1D0+R2**2-R1**2-X2)**2- + & R2**2/(1D0+R1**2-R2**2-X1)**2) + ICOMBI=0 + +C...V -> q qbar (V = gamma*/Z0/W+-/...). + ELSEIF(ICLASS.EQ.2) THEN + IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN + RLO1=PS*(2-R1**2-R1**4+6*R1*R2-R2**2+2*R1**2*R2**2-R2**4)/2.D0 + RFO1=-1.D0*(3+6*R1**2+R1**4-6*R1*R2+6*R1**3*R2-2*R2**2 + & -6*R1**2*R2**2+6*R1*R2**3+R2**4-3*X1+6*R1*R2*X1 + & +2*R2**2*X1+X1**2-2*R1**2*X1**2+3*R1**2*(2-X1-X2) + & +6*R1*R2*(2-X1-X2)-R2**2*(2-X1-X2)-2*X1*(2-X1-X2) + & -5*R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2) + & -3*(2-X1-X2)**2-3*R1**2*(2-X1-X2)**2+R2**2*(2-X1-X2)**2 + & +2*X1*(2-X1-X2)**2+(2-X1-X2)**3-X2)/ + & (-1+R1**2-R2**2+X2)**2 + RFO1=RFO1-2*(-3+R1**2-6*R1*R2+6*R1**3*R2+3*R2**2-4*R1**2*R2**2 + & +6*R1*R2**3+2*X1+3*R1**2*X1+R2**2*X1-X1**2-R1**2*X1**2 + & -R2**2*X1**2+4*(2-X1-X2)+2*R1**2*(2-X1-X2)+3*R1*R2*(2-X1 + & -X2)-R2**2*(2-X1-X2)-3*X1*(2-X1-X2)-2*R1**2*X1*(2-X1-X2) + & +X1**2*(2-X1-X2)-(2-X1-X2)**2-R1**2*(2-X1-X2)**2+R1*R2*(2 + & -X1-X2)**2+X1*(2-X1-X2)**2)/ + & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2) + RFO1=RFO1-1.D0*(-1+2*R1**2+R1**4+6*R1*R2+6*R1**3*R2-2*R2**2 + & -6*R1**2*R2**2+6*R1*R2**3+R2**4-X1-2*R1**2*X1-6*R1*R2*X1 + & +8*R2**2*X1+X1**2-2*R2**2*X1**2-R1**2*(2-X1-X2)+R2**2*(2 + & -X1-X2)-R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2* + & (2-X1-X2)+X2)/(-1-R1**2+R2**2+X1)**2 + RFO1=RFO1/2.D0 + ISSET1=1 + ENDIF + IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN + RLO2=PS*(2-R1**2-R1**4-6*R1*R2-R2**2+2*R1**2*R2**2-R2**4)/2.D0 + RFO2=-1*(3+6*R1**2+R1**4+6*R1*R2-6*R1**3*R2-2*R2**2 + & -6*R1**2*R2**2-6*R1*R2**3+R2**4-3*X1-6*R1*R2*X1+2*R2**2*X1 + & +X1**2-2*R1**2*X1**2+3*R1**2*(2-X1-X2)-6*R1*R2*(2-X1-X2) + & -R2**2*(2-X1-X2)-2*X1*(2-X1-X2)-5*R1**2*X1*(2-X1-X2) + & +R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)-3*(2-X1-X2)**2 + & -3*R1**2*(2-X1-X2)**2+R2**2*(2-X1-X2)**2+2*X1*(2-X1-X2)**2 + & +(2-X1-X2)**3-X2)/(-1+R1**2-R2**2+X2)**2 + RFO2=RFO2-2*(-3+R1**2+6*R1*R2-6*R1**3*R2+3*R2**2-4*R1**2*R2**2 + & -6*R1*R2**3+2*X1+3*R1**2*X1+R2**2*X1-X1**2-R1**2*X1**2 + & -R2**2*X1**2+4*(2-X1-X2)+2*R1**2*(2-X1-X2)-3*R1*R2*(2-X1 + & -X2)-R2**2*(2-X1-X2)-3*X1*(2-X1-X2)-2*R1**2*X1*(2-X1-X2) + & +X1**2*(2-X1-X2)-(2-X1-X2)**2-R1**2*(2-X1-X2)**2-R1*R2*(2 + & -X1-X2)**2+X1*(2-X1-X2)**2)/ + & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2) + RFO2=RFO2-1*(-1+2*R1**2+R1**4-6*R1*R2-6*R1**3*R2-2*R2**2 + & -6*R1**2*R2**2-6*R1*R2**3+R2**4-X1-2*R1**2*X1+6*R1*R2*X1 + & +8*R2**2*X1+X1**2-2*R2**2*X1**2-R1**2*(2-X1-X2)+R2**2*(2-X1 + & -X2)-R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2) + & +X2)/(-1-R1**2+R2**2+X1)**2 + RFO2=RFO2/2.D0 + ISSET2=1 + ENDIF + IF(ICOMBI.EQ.4) THEN + RLO4=PS*(2D0-R1**2-R1**4-R2**2+2D0*R1**2*R2**2-R2**4)/2D0 + RFO4=(1-R1**4+6*R1**2*R2**2-R2**4+X1+3*R1**2*X1-9*R2**2*X1 + & -3*X1**2-R1**2*X1**2+3*R2**2*X1**2+X1**3-X2-R1**2*X2 + & +R2**2*X2-R1**2*X1*X2+R2**2*X1*X2+X1**2*X2)/ + & (-1-R1**2+R2**2+X1)**2 + RFO4=RFO4 + & -2*(1+R1**2+R2**2-4*R1**2*R2**2+R1**2*X1+2*R2**2*X1-X1**2 + & -R2**2*X1**2+2*R1**2*X2+R2**2*X2-3*X1*X2+X1**2*X2-X2**2 + & -R1**2*X2**2+X1*X2**2)/ + & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2) + RFO4=RFO4+(1-R1**4+6*R1**2*R2**2-R2**4-X1+R1**2*X1-R2**2*X1+X2 + & -9*R1**2*X2+3*R2**2*X2+R1**2*X1*X2-R2**2*X1*X2-3*X2**2 + & +3*R1**2*X2**2-R2**2*X2**2+X1*X2**2+X2**3)/ + & (-1+R1**2-R2**2+X2)**2 + RFO4=RFO4/2.D0 + ISSET4=1 + ENDIF + +C...q -> q V. + ELSEIF(ICLASS.EQ.3) THEN + IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN + RLO1=PS*(1D0-2D0*R1**2+R1**4+R2**2-6D0*R1*R2**2 + & +R1**2*R2**2-2D0*R2**4) + RFO1=2*(-1+R1-2*R1**2+2*R1**3-R1**4+R1**5-R2**2+R1*R2**2 + & -5*R1**2*R2**2+R1**3*R2**2-2*R1*R2**4+2*X1-2*R1*X1 + & +2*R1**2*X1-2*R1**3*X1+2*R2**2*X1+5*R1*R2**2*X1 + & +R1**2*R2**2*X1+2*R2**4*X1-X1**2+R1*X1**2-R2**2*X1**2+3*X2 + & +4*R1**2*X2+R1**4*X2+2*R2**2*X2+2*R1**2*R2**2*X2-4*X1*X2 + & -2*R1**2*X1*X2-R2**2*X1*X2+X1**2*X2-2*X2**2 + & -2*R1**2*X2**2+X1*X2**2)/(1-R1**2+R2**2-X2)/(-2+X1+X2) + RFO1=RFO1+(2*R2**2+6*R1*R2**2-6*R1**2*R2**2+6*R1**3*R2**2 + & +2*R2**4+6*R1*R2**4-R2**2*X1+R1**2*R2**2*X1-R2**4*X1+X2 + & -R1**4*X2-3*R2**2*X2-6*R1*R2**2*X2+9*R1**2*R2**2*X2 + & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2 + & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2 + RFO1=RFO1+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4 + & +9*X1+10*R1**2*X1+R1**4*X1-3*R2**2*X1+6*R1*R2**2*X1 + & +R1**2*R2**2*X1-2*R2**4*X1-6*X1**2-2*R1**2*X1**2+X1**3 + & +7*X2+8*R1**2*X2+R1**4*X2-7*R2**2*X2+6*R1*R2**2*X2 + & +R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2 + & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2 + & +2*R2**2*X2**2+X1*X2**2)/(-2+X1+X2)**2 + ISSET1=1 + ENDIF + IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN + RLO2=PS*(1D0-2D0*R1**2+R1**4+R2**2+6D0*R1*R2**2 + & +R1**2*R2**2-2D0*R2**4) + RFO2=2*(1+R1+2*R1**2+2*R1**3+R1**4+R1**5+R2**2+R1*R2**2 + & +5*R1**2*R2**2+R1**3*R2**2-2*R1*R2**4-2*X1-2*R1*X1 + & -2*R1**2*X1-2*R1**3*X1-2*R2**2*X1+5*R1*R2**2*X1 + & -R1**2*R2**2*X1-2*R2**4*X1+X1**2+R1*X1**2+R2**2*X1**2-3*X2 + & -4*R1**2*X2-R1**4*X2-2*R2**2*X2-2*R1**2*R2**2*X2+4*X1*X2 + & +2*R1**2*X1*X2+R2**2*X1*X2-X1**2*X2+2*X2**2+2*R1**2*X2**2 + & -X1*X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2) + RFO2=RFO2+(2*R2**2-6*R1*R2**2-6*R1**2*R2**2-6*R1**3*R2**2 + & +2*R2**4-6*R1*R2**4-R2**2*X1+R1**2*R2**2*X1-R2**4*X1+X2 + & -R1**4*X2-3*R2**2*X2+6*R1*R2**2*X2+9*R1**2*R2**2*X2 + & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2 + & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2 + RFO2=RFO2+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4+9*X1 + & +10*R1**2*X1+R1**4*X1-3*R2**2*X1-6*R1*R2**2*X1 + & +R1**2*R2**2*X1-2*R2**4*X1-6*X1**2-2*R1**2*X1**2+X1**3 + & +7*X2+8*R1**2*X2+R1**4*X2-7*R2**2*X2-6*R1*R2**2*X2 + & +R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2 + & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2+2*R2**2*X2**2 + & +X1*X2**2)/(-2+X1+X2)**2 + ISSET2=1 + ENDIF + IF(ICOMBI.EQ.4) THEN + RLO4=PS*(1.D0-2.D0*R1**2+R1**4+R2**2+R1**2*R2**2-2.D0*R2**4) + RFO4=2*(1+2*R1**2+R1**4+R2**2+5*R1**2*R2**2-2*X1-2*R1**2*X1 + & -2*R2**2*X1-R1**2*R2**2*X1-2*R2**4*X1+X1**2+R2**2*X1**2 + & -3*X2-4*R1**2*X2-R1**4*X2-2*R2**2*X2-2*R1**2*R2**2*X2 + & +4*X1*X2+2*R1**2*X1*X2+R2**2*X1*X2-X1**2*X2+2*X2**2 + & +2*R1**2*X2**2-X1*X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2) + RFO4=RFO4+(2*R2**2-6*R1**2*R2**2+2*R2**4-R2**2*X1+R1**2*R2**2*X1 + & -R2**4*X1+X2-R1**4*X2-3*R2**2*X2+9*R1**2*R2**2*X2 + & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2 + & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2 + RFO4=RFO4+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4+9*X1 + & +10*R1**2*X1+R1**4*X1-3*R2**2*X1+R1**2*R2**2*X1-2*R2**4*X1 + & -6*X1**2-2*R1**2*X1**2+X1**3+7*X2+8*R1**2*X2+R1**4*X2 + & -7*R2**2*X2+R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2 + & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2+2*R2**2*X2**2 + & +X1*X2**2)/(2-X1-X2)**2 + ISSET4=1 + ENDIF + +C...S -> q qbar (S = h0/H0/A0/H+-/...). + ELSEIF(ICLASS.EQ.4) THEN + IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN + RLO1=PS*(1D0-R1**2-R2**2-2D0*R1*R2) + RFO1=-(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3 + & +R2**4+X1-R1**2*X1+2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2 + & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2 + & -2*(R1**2+R1**4-2*R1**3*R2+R2**2-6*R1**2*R2**2-2*R1*R2**3 + & +R2**4-R1**2*X1+R1*R2*X1+2*R2**2*X1+2*R1**2*X2+R1*R2*X2 + & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2) + & -(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3 + & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2 + & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2 + ISSET1=1 + ENDIF + IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN + RLO2=PS*(1D0-R1**2-R2**2+2D0*R1*R2) + RFO2=-(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3 + & +R2**4+X1-R1**2*X1-2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2 + & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2 + & -(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3 + & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2 + & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2 + & +2*(-R1**2-R1**4-2*R1**3*R2-R2**2+6*R1**2*R2**2 + & -2*R1*R2**3-R2**4+R1**2*X1+R1*R2*X1-2*R2**2*X1 + & -2*R1**2*X2+R1*R2*X2+R2**2*X2+X1*X2)/ + & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2) + ISSET2=1 + ENDIF + IF(ICOMBI.EQ.4) THEN + RLO4=PS*(1D0-R1**2-R2**2) + RFO4=-(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+3*R2**2*X1+X2 + & +R1**2*X2-R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2 + & -2*(R1**2+R1**4+R2**2-6*R1**2*R2**2+R2**4-R1**2*X1 + & +2*R2**2*X1+2*R1**2*X2-R2**2*X2-X1*X2)/ + & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2) + & -(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1 + & +X2+3*R1**2*X2-R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2 + ISSET4=1 + ENDIF + +C...q -> q S. + ELSEIF(ICLASS.EQ.5) THEN + IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN + RLO1=PS*(1D0+R1**2-R2**2+2D0*R1) + RFO1=(4-4*R1**2+4*R2**2-3*X1-2*R1*X1+R1**2*X1-R2**2*X1-5*X2 + & -2*R1*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2 + & +2*(3-R1-5*R1**2-R1**3+3*R2**2+R1*R2**2-2*X1-R1*X1 + & +R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/ + & (1-R1**2+R2**2-X2)/(-2+X1+X2) + & +(2-2*R1-6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1 + & -R2**2*X1-3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/ + & (-1+R1**2-R2**2+X2)**2 + ISSET1=1 + ENDIF + IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN + RLO2=PS*(1D0+R1**2-R2**2-2D0*R1) + RFO2=(4-4*R1**2+4*R2**2-3*X1+2*R1*X1+R1**2*X1-R2**2*X1-5*X2 + & +2*R1*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2 + & +2*(3+R1-5*R1**2+R1**3+3*R2**2-R1*R2**2-2*X1+R1*X1 + & +R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/ + & (1-R1**2+R2**2-X2)/(-2+X1+X2) + & +(2+2*R1-6*R1**2+2*R1**3+2*R2**2+2*R1*R2**2-X1+R1**2*X1 + & -R2**2*X1-3*X2-2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/ + & (-1+R1**2-R2**2+X2)**2 + ISSET2=1 + ENDIF + IF(ICOMBI.EQ.4) THEN + RLO4=PS*(1D0+R1**2-R2**2) + RFO4=(4-4*R1**2+4*R2**2-3*X1+R1**2*X1-R2**2*X1-5*X2+R1**2*X2 + & -R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2 + & +2*(3-5*R1**2+3*R2**2-2*X1+R1**2*X1-4*X2+2*R1**2*X2 + & -R2**2*X2+X1*X2+X2**2)/(1-R1**2+R2**2-X2)/(-2+X1+X2) + & +(2-6*R1**2+2*R2**2-X1+R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2 + & -R2**2*X2+X1*X2+X2**2)/(-1+R1**2-R2**2+X2)**2 + ISSET4=1 + ENDIF + +C...V -> ~q ~qbar (~q = squark). + ELSEIF(ICLASS.EQ.6) THEN + RLO1=PS*(1D0-2D0*R1**2+R1**4-2D0*R2**2-2D0*R1**2*R2**2+R2**4) + RFO1=2D0*3D0+(1+R1**2+R2**2-X1)*(4*R1**2-X1**2)/ + & (-1-R1**2+R2**2+X1)**2 + & -2D0*(-1-3*R1**2-R2**2+X1+X1**2/2+X2-X1*X2/2)/ + & (-1-R1**2+R2**2+X1) + & +(1+R1**2+R2**2-X2)*(4*R2**2-X2**2) + & /(-1+R1**2-R2**2+X2)**2 + & -2D0*(-1-R1**2-3*R2**2+X1+X2-X1*X2/2+X2**2/2)/ + & (-1+R1**2-R2**2+X2) + & -(-4*R1**2-4*R1**4-4*R2**2-8*R1**2*R2**2-4*R2**4+2*X1 + & +6*R1**2*X1+6*R2**2*X1-2*X1**2+2*X2+6*R1**2*X2+6*R2**2*X2 + & -4*X1*X2-2*R1**2*X1*X2-2*R2**2*X1*X2+X1**2*X2-2*X2**2 + & +X1*X2**2)/(-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2) + ISSET1=1 + +C...~q -> ~q V. + ELSEIF(ICLASS.EQ.7) THEN + RLO1=PS*(1D0-2D0*R1**2+R1**4-2D0*R2**2-2D0*R1**2*R2**2+R2**4) + RFO1=16*R2**2+8*(4*R2**2+2*R2**2*X1+X2+R1**2*X2+R2**2*X2-X1*X2 + & -2*X2**2)/(3*(-1+R1**2-R2**2+X2))+8*(1+R1**2+R2**2-X2)* + & (4*R2**2-X2**2)/(3*(-1+R1**2-R2**2+X2)**2)+8*(X1+X2)* + & (-1-2*R1**2-R1**4-2*R2**2+2*R1**2*R2**2-R2**4+2*X1 + & +2*R1**2*X1+2*R2**2*X1-X1**2+2*X2+2*R1**2*X2+2*R2**2*X2 + & -2*X1*X2-X2**2)/(3*(-2+X1+X2)**2)+8*(-1-R1**2+R2**2-X1)* + & (2*R2**2*X1+X2+R1**2*X2+R2**2*X2-X1*X2-X2**2)/ + & (3*(-1+R1**2-R2**2+X2)*(-2+X1+X2))+8*(1+2*R1**2+R1**4 + & +2*R2**2-2*R1**2*R2**2+R2**4-2*X1-2*R1**2*X1-4*R2**2*X1 + & +X1**2-3*X2-3*R1**2*X2-3*R2**2*X2+3*X1*X2+2*X2**2)/ + & (3*(-2+X1+X2)) + RFO1=3D0*RFO1/8D0 + ISSET1=1 + +C...S -> ~q ~qbar. + ELSEIF(ICLASS.EQ.8) THEN + RLO1=PS + RFO1=(-1-2*R1**2-R1**4-2*R2**2+2*R1**2*R2**2-R2**4+2*X1 + & +2*R1**2*X1+2*R2**2*X1-X1**2-R2**2*X1**2+2*X2+2*R1**2*X2 + & +2*R2**2*X2-3*X1*X2-R1**2*X1*X2-R2**2*X1*X2+X1**2*X2-X2**2 + & -R1**2*X2**2+X1*X2**2)/ + & (1+R1**2-R2**2-X1)**2/(-1+R1**2-R2**2+X2)**2 + RFO1=2D0*RFO1 + ISSET1=1 + +C...~q -> ~q S. + ELSEIF(ICLASS.EQ.9) THEN + RLO1=PS + RFO1=(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2 + & +(1+R1**2-R2**2+X1)/(-1+R1**2-R2**2+X2)/(-2+X1+X2) + & -(X1+X2)/(-2+X1+X2)**2 + ISSET1=1 + +C...chi -> q ~qbar (chi = neutralino/chargino). + ELSEIF(ICLASS.EQ.10) THEN + IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN + RLO1=PS*(1D0+R1**2-R2**2+2D0*R1) + RFO1=(2*R1+X1)*(-1-R1**2-R2**2+X1)/(-1-R1**2+R2**2+X1)**2 + & +2*(-1-R1**2-2*R1**3-R2**2-2*R1*R2**2+3*X1/2+R1*X1 + & -R1**2*X1/2-R2**2*X1/2+X2+R1*X2+R1**2*X2-X1*X2/2)/ + & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2) + & +(2-2*R1-6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1 + & -R2**2*X1-3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/ + & (-1+R1**2-R2**2+X2)**2 + ISSET1=1 + ENDIF + IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN + RLO2=PS*(1D0-2D0*R1+R1**2-R2**2) + RFO2=(2*R1-X1)*(1+R1**2+R2**2-X1)/(-1-R1**2+R2**2+X1)**2 + & +2*(-1-R1**2+2*R1**3-R2**2+2*R1*R2**2+3*X1/2-R1*X1 + & -R1**2*X1/2-R2**2*X1/2+X2-R1*X2+R1**2*X2-X1*X2/2)/ + & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2) + & +(2+2*R1-6*R1**2+2*R1**3+2*R2**2+2*R1*R2**2-X1+R1**2*X1 + & -R2**2*X1-3*X2-2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/ + & (-1+R1**2-R2**2+X2)**2 + ISSET2=1 + ENDIF + IF(ICOMBI.EQ.4) THEN + RLO4=PS*(1+R1**2-R2**2) + RFO4=X1*(-1-R1**2-R2**2+X1)/(-1-R1**2+R2**2+X1)**2 + & +2D0*(-1-R1**2-R2**2+3*X1/2-R1**2*X1/2-R2**2*X1/2 + & +X2+R1**2*X2-X1*X2/2)/ + & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2) + & +(2-6*R1**2+2*R2**2-X1+R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2 + & -R2**2*X2+X1*X2+X2**2)/(-1+R1**2-R2**2+X2)**2 + ISSET4=1 + ENDIF + +C...~q -> q chi. + ELSEIF(ICLASS.EQ.11) THEN + IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN + RLO1=PS*(1D0-(R1+R2)**2) + RFO1=(1+R1**2+2*R1*R2+R2**2-X1-X2)*(X1+X2)/(-2+X1+X2)**2 + & -(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3 + & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2 + & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2 + & +(-1-2*R1**2-R1**4-2*R1*R2-2*R1**3*R2+2*R1*R2**3+R2**4 + & +X1+R1**2*X1-2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2 + & +X1*X2+X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2) + ISSET1=1 + ENDIF + IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN + RLO2=PS*(1D0-(R1-R2)**2) + RFO2=(1+R1**2-2*R1*R2+R2**2-X1-X2)*(X1+X2)/ + & (-2+X1+X2)**2 + & -(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3 + & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2 + & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2 + & +(-1-2*R1**2-R1**4+2*R1*R2+2*R1**3*R2-2*R1*R2**3+R2**4 + & +X1+R1**2*X1+2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2 + & +X1*X2+X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2) + ISSET2=1 + ENDIF + IF(ICOMBI.EQ.4) THEN + RLO4=PS*(1D0-R1**2-R2**2) + RFO4=(1+R1**2+R2**2-X1-X2)*(X1+X2)/(-2+X1+X2)**2 + & -(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1+X2 + & +3*R1**2*X2-R2**2*X2-X1*X2)/ + & (-1+R1**2-R2**2+X2)**2 + & -(-1-2*R1**2-R1**4+R2**4+X1+R1**2*X1-3*R2**2*X1 + & +2*R1**2*X2-2*R2**2*X2+X1*X2+X2**2)/ + & (2-X1-X2)/(-1+R1**2-R2**2+X2) + ISSET4=1 + ENDIF + +C...q -> ~q chi. + ELSEIF(ICLASS.EQ.12) THEN + IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN + RLO1=PS*(1D0-R1**2+R2**2+2D0*R2) + RFO1=(2*R2+X2)*(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2 + & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1-2*R2*X1+R2**2*X1+X1**2 + & -3*X2-R1**2*X2-2*R2*X2+R2**2*X2+X1*X2)/ + & (-2+X1+X2)**2-2*(-1-R1**2+R2+R1**2*R2-R2**2-R2**3+X1 + & +R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/ + & (2-X1-X2)/(-1+R1**2-R2**2+X2) + ISSET1=1 + END IF + IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN + RLO2=PS*(1D0-R1**2+R2**2-2D0*R2) + RFO2=(2*R2-X2)*(1+R1**2+R2**2-X2)/(-1+R1**2-R2**2+X2)**2 + & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+2*R2*X1+R2**2*X1+X1**2 + & -3*X2-R1**2*X2+2*R2*X2+R2**2*X2+X1*X2)/ + & (-2+X1+X2)**2-2*(-1-R1**2-R2-R1**2*R2-R2**2+R2**3+X1 + & -R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/ + & (2-X1-X2)/(-1+R1**2-R2**2+X2) + ISSET2=1 + END IF + IF(ICOMBI.EQ.4) THEN + RLO4=PS*(1D0-R1**2+R2**2) + RFO4=X2*(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2 + & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+R2**2*X1+X1**2 + & -3*X2-R1**2*X2+R2**2*X2+X1*X2)/ + & (-2+X1+X2)**2-2*(-1-R1**2-R2**2+X1+R2**2*X1+2*X2 + & +R1**2*X2-X1*X2/2-X2**2/2)/ + & (2-X1-X2)/(-1+R1**2-R2**2+X2) + ISSET4=1 + END IF + +C...~g -> q ~qbar. + ELSEIF(ICLASS.EQ.13) THEN + IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN + RLO1=PS*(1D0+R1**2-R2**2+2D0*R1) + RFO1=4*(2*R1+X1)*(-1-R1**2-R2**2+X1)/(3*(-1-R1**2+R2**2+X1)**2) + & -(-1-R1**2-2*R1**3-R2**2-2*R1*R2**2+3*X1/2+R1*X1-R1**2*X1/2 + & -R2**2*X1/2+X2+R1*X2+R1**2*X2-X1*X2/2)/(3*(-1-R1**2+R2**2 + & +X1)*(-1+R1**2-R2**2+X2))-3*(-1+R1-R1**2-R1**3-R2**2 + & +R1*R2**2+2*X1+R2**2*X1-X1**2/2+X2+R1*X2+R1**2*X2-X1*X2/2)/ + & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+3*(4-4*R1**2+4*R2**2-3*X1 + & -2*R1*X1+R1**2*X1-R2**2*X1-5*X2-2*R1*X2+R1**2*X2-R2**2*X2 + & +X1*X2+X2**2)/(-2+X1+X2)**2+3*(3-R1-5*R1**2-R1**3+3*R2**2 + & +R1*R2**2-2*X1-R1*X1+R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2 + & +X1*X2+X2**2)/((1-R1**2+R2**2-X2)*(-2+X1+X2))+4*(2-2*R1 + & -6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1-R2**2*X1 + & -3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/ + & (3*(-1+R1**2-R2**2+X2)**2) + RFO1=3D0*RFO1/4D0 + ISSET1=1 + ENDIF + IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN + RLO2=PS*(1D0+R1**2-R2**2-2D0*R1) + RFO2=4*(2*R1-X1)*(1+R1**2+R2**2-X1)/(3*(-1-R1**2+R2**2+X1)**2) + & -3*(-1-R1-R1**2+R1**3-R2**2-R1*R2**2+2*X1+R2**2*X1-X1**2/2 + & +X2-R1*X2+R1**2*X2-X1*X2/2)/((-1-R1**2+R2**2+X1)*(2-X1-X2)) + & +(2+2*R1**2-4*R1**3+2*R2**2-4*R1*R2**2-3*X1+2*R1*X1 + & +R1**2*X1+R2**2*X1-2*X2+2*R1*X2-2*R1**2*X2+X1*X2)/ + & (6*(-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+3*(4-4*R1**2 + & +4*R2**2-3*X1+2*R1*X1+R1**2*X1-R2**2*X1-5*X2+2*R1*X2 + & +R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2+3*(3+R1 + & -5*R1**2+R1**3+3*R2**2-R1*R2**2-2*X1+R1*X1+R1**2*X1-4*X2 + & +2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/ + & ((1-R1**2+R2**2-X2)*(-2+X1+X2))+4*(2+2*R1-6*R1**2+2*R1**3 + & +2*R2**2+2*R1*R2**2-X1+R1**2*X1-R2**2*X1-3*X2-2*R1*X2 + & +3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/ + & (3*(-1+R1**2-R2**2+X2)**2) + RFO2=3D0*RFO2/4D0 + ISSET2=1 + ENDIF + IF(ICOMBI.EQ.4) THEN + RLO4=PS*(1D0+R1**2-R2**2) + RFO4=8*X1*(-1-R1**2-R2**2+X1)/(3*(-1-R1**2+R2**2+X1)**2)-6*(-1 + & -R1**2-R2**2+2*X1+R2**2*X1-X1**2/2+X2+R1**2*X2-X1*X2/2)/ + & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+(2+2*R1**2+2*R2**2-3*X1 + & +R1**2*X1+R2**2*X1-2*X2-2*R1**2*X2+X1*X2)/(3*(-1-R1**2 + & +R2**2+X1)*(-1+R1**2-R2**2+X2))+6*(4-4*R1**2+4*R2**2-3*X1 + & +R1**2*X1-R2**2*X1-5*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/ + & (-2+X1+X2)**2+6*(3-5*R1**2+3*R2**2-2*X1+R1**2*X1-4*X2 + & +2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/ + & ((1-R1**2+R2**2-X2)*(-2+X1+X2))+8*(2-6*R1**2+2*R2**2-X1 + & +R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/ + & (3*(-1+R1**2-R2**2+X2)**2) + RFO4=3D0*RFO4/8D0 + ISSET4=1 + ENDIF + +C...~q -> q ~g. + ELSEIF(ICLASS.EQ.14) THEN + IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN + RLO1=PS*(1-R1**2-R2**2-2D0*R1*R2) + RFO1=64*(1+R1**2+2*R1*R2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2) + & -16*(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3 + & +R2**4+X1-R1**2*X1+2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2 + & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2-16*(R1**2+R1**4 + & -2*R1**3*R2+R2**2-6*R1**2*R2**2-2*R1*R2**3+R2**4 + & -R1**2*X1+R1*R2*X1+2*R2**2*X1+2*R1**2*X2+R1*R2*X2-R2**2*X2 + & -X1*X2)/((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2)) + & -64*(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3 + & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2 + & -R2**2*X2-X1*X2)/(9*(-1+R1**2-R2**2+X2)**2) + & +8*(-1+R1**4-2*R1*R2+2*R1**3*R2-2*R2**2-2*R1*R2**3-R2**4 + & -2*R1**2*X1+2*R2**2*X1+X1**2+X2-3*R1**2*X2-2*R1*R2*X2 + & +R2**2*X2+X1*X2)/((-1-R1**2+R2**2+X1)*(-2+X1+X2)) + RFO1=RFO1 + & +8*(-1-2*R1**2-R1**4-2*R1*R2-2*R1**3*R2+2*R1*R2**3+R2**4 + & +X1+R1**2*X1-2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2 + & +X1*X2+X2**2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2)) + RFO1=9D0*RFO1/64D0 + ISSET1=1 + ENDIF + IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN + RLO2=PS*(1-R1**2-R2**2+2D0*R1*R2) + RFO2=64*(1+R1**2-2*R1*R2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2) + & -16*(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3 + & +R2**4+X1-R1**2*X1-2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2 + & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2-64*(-1+R1**4 + & +2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3+R2**4+X1 + & -R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2-R2**2*X2 + & -X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)+16*(-R1**2-R1**4 + & -2*R1**3*R2-R2**2+6*R1**2*R2**2-2*R1*R2**3-R2**4+R1**2*X1 + & +R1*R2*X1-2*R2**2*X1-2*R1**2*X2+R1*R2*X2+R2**2*X2+X1*X2)/ + & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2)) + RFO2=RFO2 + & +8*(-1+R1**4+2*R1*R2-2*R1**3*R2-2*R2**2+2*R1*R2**3-R2**4 + & -2*R1**2*X1+2*R2**2*X1+X1**2+X2-3*R1**2*X2+2*R1*R2*X2 + & +R2**2*X2+X1*X2)/((-1-R1**2+R2**2+X1)*(-2+X1+X2)) + & +8*(-1-2*R1**2-R1**4+2*R1*R2+2*R1**3*R2-2*R1*R2**3 + & +R2**4+X1+R1**2*X1+2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2 + & -2*R2**2*X2+X1*X2+X2**2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2)) + RFO2=9D0*RFO2/64D0 + ISSET2=1 + ENDIF + IF(ICOMBI.EQ.4) THEN + RLO4=PS*(1-R1**2-R2**2) + RFO4=128*(1+R1**2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)-32*(-1 + & +R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+3*R2**2*X1+X2 + & +R1**2*X2-R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2 + & -32*(R1**2+R1**4+R2**2-6*R1**2*R2**2+R2**4-R1**2*X1 + & +2*R2**2*X1+2*R1**2*X2-R2**2*X2-X1*X2)/ + & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))-128*(-1+R1**4 + & -6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2 + & -R2**2*X2-X1*X2)/(9*(-1+R1**2-R2**2+X2)**2) + & +16*(-1+R1**4-2*R2**2-R2**4-2*R1**2*X1+2*R2**2*X1+X1**2 + & +X2-3*R1**2*X2+R2**2*X2+X1*X2)/ + & ((-1-R1**2+R2**2+X1)*(-2+X1+ X2)) + RFO4=RFO4+16*(-1-2*R1**2-R1**4+R2**4+X1+R1**2*X1-3*R2**2*X1 + & +2*R1**2*X2-2*R2**2*X2+X1*X2+X2**2)/ + & (9*(1-R1**2+R2**2-X2)*(-2+X1+X2)) + RFO4=9D0*RFO4/128D0 + ISSET4=1 + ENDIF + +C...q -> ~q ~g. + ELSEIF(ICLASS.EQ.15) THEN + IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN + RLO1=PS*(1D0-R1**2+R2**2+2D0*R2) + RFO1=32*(2*R2+X2)*(-1-R1**2-R2**2+X2)/(9*(-1+R1**2-R2**2+X2)**2) + & +8*(-1-R1**2-2*R1**2*R2-R2**2-2*R2**3+X1+R2*X1+R2**2*X1 + & +3*X2/2-R1**2*X2/2+R2*X2-R2**2*X2/2-X1*X2/2)/ + & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+8*(2+2*R1**2-2*R2 + & -2*R1**2*R2-6*R2**2-2*R2**3-3*X1-R1**2*X1+2*R2*X1 + & +3*R2**2*X1+X1**2-X2-R1**2*X2+R2**2*X2+X1*X2)/ + & (-1-R1**2+R2**2+X1)**2+32*(4+4*R1**2-4*R2**2-5*X1 + & -R1**2*X1-2*R2*X1+R2**2*X1+X1**2-3*X2-R1**2*X2-2*R2*X2 + & +R2**2*X2+X1*X2)/(9*(-2+X1+X2)**2) + RFO1=RFO1+8*(3+3*R1**2-R2+R1**2*R2-5*R2**2-R2**3-4*X1-R1**2*X1 + & +2*R2**2*X1+X1**2-2*X2-R2*X2+R2**2*X2+X1*X2)/ + & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+8*(-1-R1**2+R2+R1**2*R2 + & -R2**2-R2**3+X1+R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2 + & -X2**2/2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2)) + RFO1=9D0*RFO1/32D0 + ISSET1=1 + END IF + IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN + RLO2=PS*(1D0-R1**2+R2**2-2D0*R2) + RFO2=32*(2*R2-X2)*(1+R1**2+R2**2-X2)/(9*(-1+R1**2-R2**2+X2)**2) + & +8*(-1-R1**2+2*R1**2*R2-R2**2+2*R2**3+X1-R2*X1+R2**2*X1 + & +3*X2/2-R1**2*X2/2-R2*X2-R2**2*X2/2-X1*X2/2)/ + & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+8*(2+2*R1**2+2*R2 + & +2*R1**2*R2-6*R2**2+2*R2**3-3*X1-R1**2*X1-2*R2*X1 + & +3*R2**2*X1+X1**2-X2-R1**2*X2+R2**2*X2+X1*X2)/ + & (-1-R1**2+R2**2+X1)**2+8*(3+3*R1**2+R2-R1**2*R2-5*R2**2 + & +R2**3-4*X1-R1**2*X1+2*R2**2*X1+X1**2-2*X2+R2*X2+R2**2*X2 + & +X1*X2)/((-1-R1**2+R2**2+X1)*(2-X1-X2)) + RFO2=RFO2+32*(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+2*R2*X1+R2**2*X1 + & +X1**2-3*X2-R1**2*X2+2*R2*X2+R2**2*X2+X1*X2)/ + & (9*(-2+X1+X2)**2)+8*(-1-R1**2-R2-R1**2*R2-R2**2+R2**3+X1 + & -R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/ + & (9*(2-X1-X2)*(-1+R1**2-R2**2+X2)) + RFO2=9D0*RFO2/32D0 + ISSET2=1 + END IF + IF(ICOMBI.EQ.4) THEN + RLO4=PS*(1D0-R1**2+R2**2) + RFO4=64*X2*(-1-R1**2-R2**2+X2)/(9*(-1+R1**2-R2**2+X2)**2) + & +16*(-1-R1**2-R2**2+X1+R2**2*X1+3*X2/2-R1**2*X2/2 + & -R2**2*X2/2-X1*X2/2)/ + & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+16*(3+3*R1**2 + & -5*R2**2-4*X1-R1**2*X1+2*R2**2*X1+X1**2-2*X2+R2**2*X2 + & +X1*X2)/((-1-R1**2+R2**2+X1)*(2-X1-X2)) + & +64*(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+R2**2*X1+X1**2-3*X2 + & -R1**2*X2+R2**2*X2+X1*X2)/(9*(-2+X1+X2)**2) + RFO4=RFO4+16*(2+2*R1**2-6*R2**2-3*X1-R1**2*X1+3*R2**2*X1+X1**2 + & -X2-R1**2*X2+R2**2*X2+X1*X2)/(-1-R1**2+R2**2+X1)**2 + & +16*(-1-R1**2-R2**2+X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2 + & -X2**2/2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2)) + RFO4=9D0*RFO4/64D0 + ISSET4=1 + END IF + +C...g -> ~g ~g. Use (9/4)*eikonal. May be changed in the future. + ELSEIF(ICLASS.EQ.16) THEN + RLO=PS + IF(ICOMBI.EQ.0.OR.ICOMBI.EQ.1) THEN + ANUM=0D0 + ELSEIF(ICOMBI.EQ.2) THEN + ANUM=(2D0-X1-X2)**2 + ELSEIF(ICOMBI.EQ.3) THEN + ANUM=ALPCOR*(2D0-X1-X2)**2 + ELSE + ANUM=0.5D0*(2D0-X1-X2)**2 + ENDIF + RFO=PS*2D0*((X1+X2-1D0+ANUM-R1**2-R2**2)/ + & ((1D0+R1**2-R2**2-X1)*(1D0+R2**2-R1**2-X2))- + & R1**2/(1D0+R2**2-R1**2-X2)**2- + & R2**2/(1D0+R1**2-R2**2-X1)**2) + RFO=9D0*RFO/4D0 + ICOMBI=0 + ENDIF + +C...Find relevant LO and FO expression. + IF(ICOMBI.EQ.0) THEN + ELSEIF(ICOMBI.EQ.1.AND.ISSET1.EQ.1) THEN + RLO=RLO1 + RFO=RFO1 + ELSEIF(ICOMBI.EQ.2.AND.ISSET2.EQ.1) THEN + RLO=RLO2 + RFO=RFO2 + ELSEIF(ICOMBI.EQ.3.AND.ISSET1.EQ.1.AND.ISSET2.EQ.1) THEN + RLO=ALPCOR*RLO1+(1D0-ALPCOR)*RLO2 + RFO=ALPCOR*RFO1+(1D0-ALPCOR)*RFO2 + ELSEIF(ISSET4.EQ.1) THEN + RLO=RLO4 + RFO=RFO4 + ELSEIF(ICOMBI.EQ.4.AND.ISSET1.EQ.1.AND.ISSET2.EQ.1) THEN + RLO=0.5D0*(RLO1+RLO2) + RFO=0.5D0*(RFO1+RFO2) + ELSEIF(ISSET1.EQ.1) THEN + RLO=RLO1 + RFO=RFO1 + ELSE + CALL PYERRM(16,'(PYMAEL:) not implemented ME code') + RLO=1D0 + RFO=0D0 + ENDIF + +C...Output. + PYMAEL=RFO/RLO + + RETURN + END + +C********************************************************************* + +C...PYBOEI +C...Modifies an event so as to approximately take into account +C...Bose-Einstein effects according to a simple phenomenological +C...parametrization. + + SUBROUTINE PYBOEI(NSAV) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYINT1/MINT(400),VINT(400) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/ +C...Local arrays and data. + DIMENSION DPS(4),KFBE(9),NBE(0:10),BEI(100),BEI3(100), + &BEIW(100),BEI3W(100) + DATA KFBE/211,-211,111,321,-321,130,310,221,331/ +C...Statement function: squared invariant mass. + SDIP(I,J)=((P(I,4)+P(J,4))**2-(P(I,3)+P(J,3))**2- + &(P(I,2)+P(J,2))**2-(P(I,1)+P(J,1))**2) + +C...Boost event to overall CM frame. Calculate CM energy. + IF((MSTJ(51).NE.1.AND.MSTJ(51).NE.2).OR.N-NSAV.LE.1) RETURN + DO 100 J=1,4 + DPS(J)=0D0 + 100 CONTINUE + DO 120 I=1,N + KFA=IABS(K(I,2)) + IF(K(I,1).LE.10.AND.((KFA.GT.10.AND.KFA.LE.20).OR.KFA.EQ.22) + & .AND.K(I,3).GT.0) THEN + KFMA=IABS(K(K(I,3),2)) + IF(KFMA.GT.10.AND.KFMA.LE.80) K(I,1)=-K(I,1) + ENDIF + IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 120 + DO 110 J=1,4 + DPS(J)=DPS(J)+P(I,J) + 110 CONTINUE + 120 CONTINUE + CALL PYROBO(0,0,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4), + &-DPS(3)/DPS(4)) + PECM=0D0 + DO 130 I=1,N + IF(K(I,1).GE.1.AND.K(I,1).LE.10) PECM=PECM+P(I,4) + 130 CONTINUE + +C...Check if we have separated strings + +C...Reserve copy of particles by species at end of record. + IWP=0 + IWN=0 + NBE(0)=N+MSTU(3) + NMAX=NBE(0) + SMMIN=PECM + DO 190 IBE=1,MIN(10,MSTJ(52)+1) + NBE(IBE)=NBE(IBE-1) + DO 180 I=NSAV+1,N + IF(IBE.EQ.MIN(10,MSTJ(52)+1)) THEN + DO 140 IIBE=1,IBE-1 + IF(K(I,2).EQ.KFBE(IIBE)) GOTO 180 + 140 CONTINUE + ELSE + IF(K(I,2).NE.KFBE(IBE)) GOTO 180 + ENDIF + IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 180 + IF(NBE(IBE).GE.MSTU(4)-MSTU(32)-5) THEN + CALL PYERRM(11,'(PYBOEI:) no more memory left in PYJETS') + RETURN + ENDIF + NBE(IBE)=NBE(IBE)+1 + NMAX=NBE(IBE) + K(NBE(IBE),1)=I + K(NBE(IBE),2)=0 + K(NBE(IBE),3)=0 + K(NBE(IBE),4)=0 + K(NBE(IBE),5)=0 + P(NBE(IBE),1)=0.0D0 + P(NBE(IBE),2)=0.0D0 + P(NBE(IBE),3)=0.0D0 + P(NBE(IBE),4)=0.0D0 + P(NBE(IBE),5)=0.0D0 + SMMIN=MIN(SMMIN,P(I,5)) +C...Check if particles comes from different W's or Z's + IF((MSTJ(53).NE.0.OR.MSTJ(56).GT.0).AND.MINT(32).EQ.0) THEN + IM=I + 150 IF(K(IM,3).GT.0) THEN + IM=K(IM,3) + IF(ABS(K(IM,2)).NE.24.AND.K(IM,2).NE.23) GOTO 150 + K(NBE(IBE),5)=IM + IF(IWP.EQ.0.AND.K(IM,2).EQ.24) IWP=IM + IF(IWN.EQ.0.AND.K(IM,2).EQ.-24) IWN=IM + IF(IWP.EQ.0.AND.K(IM,2).EQ.23) IWP=IM + IF(IWN.EQ.0.AND.K(IM,2).EQ.23.AND.IM.NE.IWP) IWN=IM + ENDIF + ENDIF +C...Check if particles comes from different strings. + IF(PARJ(94).GT.0.0D0) THEN + IM=I + 160 IF(K(IM,3).GT.0) THEN + IM=K(IM,3) + IF(K(IM,2).NE.92.AND.K(IM,2).NE.91) GOTO 160 + K(NBE(IBE),5)=IM + ENDIF + ENDIF + DO 170 J=1,3 + P(NBE(IBE),J)=0D0 + V(NBE(IBE),J)=0D0 + 170 CONTINUE + P(NBE(IBE),5)=-1.0D0 + 180 CONTINUE + 190 CONTINUE + IF(NBE(MIN(9,MSTJ(52)))-NBE(0).LE.1) GOTO 510 + +C...Calculate separation between W+ and W- or between two Z0's. +C...No separation if there has been re-connections. + SIGW=PARJ(93) + IF(IWP.GT.0.AND.IWN.GT.0.AND.MSTJ(56).GT.0.AND.MINT(32).EQ.0) THEN + IF(K(IWP,2).EQ.23) THEN + DMW=PMAS(23,1) + DGW=PMAS(23,2) + ELSE + DMW=PMAS(24,1) + DGW=PMAS(24,2) + ENDIF + DMP=P(IWP,5) + DMN=P(IWN,5) + TAUPD=DMP/SQRT((DMP**2-DMW**2)**2+(DGW*(DMP**2)/DMW)**2) + TAUND=DMN/SQRT((DMN**2-DMW**2)**2+(DGW*(DMN**2)/DMW)**2) + TAUP=-TAUPD*LOG(PYR(IDUM)) + TAUN=-TAUND*LOG(PYR(IDUM)) + DXP=TAUP*PYP(IWP,8)/DMP + DXN=TAUN*PYP(IWN,8)/DMN + DX=DXP+DXN + SIGW=1.0D0/(1.0D0/PARJ(93)+REAL(MSTJ(56))*DX) + IF(PARJ(94).LT.0.0D0) SIGW=1.0D0/(1.0D0/SIGW-1.0D0/PARJ(94)) + ENDIF + +C...Add separation between strings. + IF(PARJ(94).GT.0.0D0) THEN + SIGW=1.0D0/(1.0D0/SIGW+1.0D0/PARJ(94)) + IWP=-1 + IWN=-1 + ENDIF + + IF(MSTJ(57).EQ.1.AND.MSTJ(54).LT.0) THEN + DO 220 IBE=1,MIN(9,MSTJ(52)) + DO 210 I1M=NBE(IBE-1)+1,NBE(IBE) + Q2MIN=PECM**2 + I1=K(I1M,1) + DO 200 I2M=NBE(IBE-1)+1,NBE(IBE) + IF(I2M.EQ.I1M) GOTO 200 + I2=K(I2M,1) + Q2=(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2- + & (P(I1,2)+P(I2,2))**2-(P(I1,3)+P(I2,3))**2- + & (P(I1,5)+P(I2,5))**2 + IF(Q2.GT.0.0D0.AND.Q2.LT.Q2MIN) THEN + Q2MIN=Q2 + ENDIF + 200 CONTINUE + P(I1M,5)=Q2MIN + 210 CONTINUE + 220 CONTINUE + ENDIF + +C...Tabulate integral for subsequent momentum shift. + DO 400 IBE=1,MIN(9,MSTJ(52)) + IF(IBE.NE.1.AND.IBE.NE.4.AND.IBE.LE.7) GOTO 270 + IF(IBE.EQ.1.AND.MAX(NBE(1)-NBE(0),NBE(2)-NBE(1),NBE(3)-NBE(2)) + & .LE.1) GOTO 270 + IF(IBE.EQ.4.AND.MAX(NBE(4)-NBE(3),NBE(5)-NBE(4),NBE(6)-NBE(5), + & NBE(7)-NBE(6)).LE.1) GOTO 270 + IF(IBE.GE.8.AND.NBE(IBE)-NBE(IBE-1).LE.1) GOTO 270 + IF(IBE.EQ.1) PMHQ=2D0*PYMASS(211) + IF(IBE.EQ.4) PMHQ=2D0*PYMASS(321) + IF(IBE.EQ.8) PMHQ=2D0*PYMASS(221) + IF(IBE.EQ.9) PMHQ=2D0*PYMASS(331) + QDEL=0.1D0*MIN(PMHQ,PARJ(93)) + QDEL3=0.1D0*MIN(PMHQ,PARJ(93)*3.0D0) + QDELW=0.1D0*MIN(PMHQ,SIGW) + QDEL3W=0.1D0*MIN(PMHQ,SIGW*3.0D0) + IF(MSTJ(51).EQ.1) THEN + NBIN=MIN(100,NINT(9D0*PARJ(93)/QDEL)) + NBIN3=MIN(100,NINT(27D0*PARJ(93)/QDEL3)) + NBINW=MIN(100,NINT(9D0*SIGW/QDELW)) + NBIN3W=MIN(100,NINT(27D0*SIGW/QDEL3W)) + BEEX=EXP(0.5D0*QDEL/PARJ(93)) + BEEX3=EXP(0.5D0*QDEL3/(3.0D0*PARJ(93))) + BEEXW=EXP(0.5D0*QDELW/SIGW) + BEEX3W=EXP(0.5D0*QDEL3W/(3.0D0*SIGW)) + BERT=EXP(-QDEL/PARJ(93)) + BERT3=EXP(-QDEL3/(3.0D0*PARJ(93))) + BERTW=EXP(-QDELW/SIGW) + BERT3W=EXP(-QDEL3W/(3.0D0*SIGW)) + ELSE + NBIN=MIN(100,NINT(3D0*PARJ(93)/QDEL)) + NBIN3=MIN(100,NINT(9D0*PARJ(93)/QDEL3)) + NBINW=MIN(100,NINT(3D0*SIGW/QDELW)) + NBIN3W=MIN(100,NINT(9D0*SIGW/QDEL3W)) + ENDIF + DO 230 IBIN=1,NBIN + QBIN=QDEL*(IBIN-0.5D0) + BEI(IBIN)=QDEL*(QBIN**2+QDEL**2/12D0)/SQRT(QBIN**2+PMHQ**2) + IF(MSTJ(51).EQ.1) THEN + BEEX=BEEX*BERT + BEI(IBIN)=BEI(IBIN)*BEEX + ELSE + BEI(IBIN)=BEI(IBIN)*EXP(-(QBIN/PARJ(93))**2) + ENDIF + IF(IBIN.GE.2) BEI(IBIN)=BEI(IBIN)+BEI(IBIN-1) + 230 CONTINUE + DO 240 IBIN=1,NBIN3 + QBIN=QDEL3*(IBIN-0.5D0) + BEI3(IBIN)=QDEL3*(QBIN**2+QDEL3**2/12D0)/SQRT(QBIN**2+PMHQ**2) + IF(MSTJ(51).EQ.1) THEN + BEEX3=BEEX3*BERT3 + BEI3(IBIN)=BEI3(IBIN)*BEEX3 + ELSE + BEI3(IBIN)=BEI3(IBIN)*EXP(-(QBIN/(3.0D0*PARJ(93)))**2) + ENDIF + IF(IBIN.GE.2) BEI3(IBIN)=BEI3(IBIN)+BEI3(IBIN-1) + 240 CONTINUE + DO 250 IBIN=1,NBINW + QBIN=QDELW*(IBIN-0.5D0) + BEIW(IBIN)=QDELW*(QBIN**2+QDELW**2/12D0)/SQRT(QBIN**2+PMHQ**2) + IF(MSTJ(51).EQ.1) THEN + BEEXW=BEEXW*BERTW + BEIW(IBIN)=BEIW(IBIN)*BEEXW + ELSE + BEIW(IBIN)=BEIW(IBIN)*EXP(-(QBIN/SIGW)**2) + ENDIF + IF(IBIN.GE.2) BEIW(IBIN)=BEIW(IBIN)+BEIW(IBIN-1) + 250 CONTINUE + DO 260 IBIN=1,NBIN3W + QBIN=QDEL3W*(IBIN-0.5D0) + BEI3W(IBIN)=QDEL3W*(QBIN**2+QDEL3W**2/12D0)/ + & SQRT(QBIN**2+PMHQ**2) + IF(MSTJ(51).EQ.1) THEN + BEEX3W=BEEX3W*BERT3W + BEI3W(IBIN)=BEI3W(IBIN)*BEEX3W + ELSE + BEI3W(IBIN)=BEI3W(IBIN)*EXP(-(QBIN/(3.0D0*SIGW))**2) + ENDIF + IF(IBIN.GE.2) BEI3W(IBIN)=BEI3W(IBIN)+BEI3W(IBIN-1) + 260 CONTINUE + +C...Loop through particle pairs and find old relative momentum. + 270 DO 390 I1M=NBE(IBE-1)+1,NBE(IBE)-1 + I1=K(I1M,1) + DO 380 I2M=I1M+1,NBE(IBE) + IF(MSTJ(53).EQ.1.AND.K(I1M,5).NE.K(I2M,5)) GOTO 380 + IF(MSTJ(53).EQ.2.AND.K(I1M,5).EQ.K(I2M,5)) GOTO 380 + I2=K(I2M,1) + Q2OLD=(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-(P(I1,2)+ + & P(I2,2))**2-(P(I1,3)+P(I2,3))**2-(P(I1,5)+P(I2,5))**2 + IF(Q2OLD.LE.0.0D0) GOTO 380 + QOLD=SQRT(Q2OLD) + +C...Calculate new relative momentum. + QMOV=0.0D0 + QMOV3=0.0D0 + QMOVW=0.0D0 + QMOV3W=0.0D0 + IF(QOLD.LT.1D-3*QDEL) THEN + GOTO 280 + ELSEIF(QOLD.LE.QDEL) THEN + QMOV=QOLD/3D0 + ELSEIF(QOLD.LT.(NBIN-0.1D0)*QDEL) THEN + RBIN=QOLD/QDEL + IBIN=RBIN + RINP=(RBIN**3-IBIN**3)/(3*IBIN*(IBIN+1)+1) + QMOV=(BEI(IBIN)+RINP*(BEI(IBIN+1)-BEI(IBIN)))* + & SQRT(Q2OLD+PMHQ**2)/Q2OLD + ELSE + QMOV=BEI(NBIN)*SQRT(Q2OLD+PMHQ**2)/Q2OLD + ENDIF + 280 Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV))**(2D0/3D0) + IF(QOLD.LT.1D-3*QDEL3) THEN + GOTO 290 + ELSEIF(QOLD.LE.QDEL3) THEN + QMOV3=QOLD/3D0 + ELSEIF(QOLD.LT.(NBIN3-0.1D0)*QDEL3) THEN + RBIN3=QOLD/QDEL3 + IBIN3=RBIN3 + RINP3=(RBIN3**3-IBIN3**3)/(3*IBIN3*(IBIN3+1)+1) + QMOV3=(BEI3(IBIN3)+RINP3*(BEI3(IBIN3+1)-BEI3(IBIN3)))* + & SQRT(Q2OLD+PMHQ**2)/Q2OLD + ELSE + QMOV3=BEI3(NBIN3)*SQRT(Q2OLD+PMHQ**2)/Q2OLD + ENDIF + 290 Q2NEW3=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV3))**(2D0/3D0) + RSCALE=1.0D0 + IF(MSTJ(54).EQ.2) + & RSCALE=1.0D0-EXP(-(QOLD/(2D0*PARJ(93)))**2) + IF((IWP.NE.-1.AND.MSTJ(56).LE.0).OR.IWP.EQ.0.OR.IWN.EQ.0.OR. + & K(I1M,5).EQ.K(I2M,5)) GOTO 320 + + IF(QOLD.LT.1D-3*QDELW) THEN + GOTO 300 + ELSEIF(QOLD.LE.QDELW) THEN + QMOVW=QOLD/3D0 + ELSEIF(QOLD.LT.(NBINW-0.1D0)*QDELW) THEN + RBINW=QOLD/QDELW + IBINW=RBINW + RINPW=(RBINW**3-IBINW**3)/(3*IBINW*(IBINW+1)+1) + QMOVW=(BEIW(IBINW)+RINPW*(BEIW(IBINW+1)-BEIW(IBINW)))* + & SQRT(Q2OLD+PMHQ**2)/Q2OLD + ELSE + QMOVW=BEIW(NBINW)*SQRT(Q2OLD+PMHQ**2)/Q2OLD + ENDIF + 300 Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOVW))**(2D0/3D0) + IF(QOLD.LT.1D-3*QDEL3W) THEN + GOTO 310 + ELSEIF(QOLD.LE.QDEL3W) THEN + QMOV3W=QOLD/3D0 + ELSEIF(QOLD.LT.(NBIN3W-0.1D0)*QDEL3W) THEN + RBIN3W=QOLD/QDEL3W + IBIN3W=RBIN3W + RINP3W=(RBIN3W**3-IBIN3W**3)/(3*IBIN3W*(IBIN3W+1)+1) + QMOV3W=(BEI3W(IBIN3W)+RINP3W*(BEI3W(IBIN3W+1)- + & BEI3W(IBIN3W)))*SQRT(Q2OLD+PMHQ**2)/Q2OLD + ELSE + QMOV3W=BEI3W(NBIN3W)*SQRT(Q2OLD+PMHQ**2)/Q2OLD + ENDIF + 310 Q2NEW3=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV3W))**(2D0/3D0) + IF(MSTJ(54).EQ.2) + & RSCALE=1.0D0-EXP(-(QOLD/(2D0*SIGW))**2) + + 320 CALL PYBESQ(I1,I2,NMAX,Q2OLD,Q2NEW) + DO 330 J=1,3 + P(I1M,J)=P(I1M,J)+P(NMAX+1,J) + P(I2M,J)=P(I2M,J)+P(NMAX+2,J) + 330 CONTINUE + IF(MSTJ(54).GE.1) THEN + CALL PYBESQ(I1,I2,NMAX,Q2OLD,Q2NEW3) + DO 340 J=1,3 + V(I1M,J)=V(I1M,J)+P(NMAX+1,J)*RSCALE + V(I2M,J)=V(I2M,J)+P(NMAX+2,J)*RSCALE + 340 CONTINUE + ELSEIF(MSTJ(54).LE.-1) THEN + EDEL=P(I1,4)+P(I2,4)- + & SQRT(MAX(Q2NEW-Q2OLD+(P(I1,4)+P(I2,4))**2,0.0D0)) + A2=(P(I1,1)-P(I2,1))**2+(P(I1,2)-P(I2,2))**2+ + & (P(I1,3)-P(I2,3))**2 + WMAX=-1.0D20 + MI3=0 + MI4=0 + S12=SDIP(I1,I2) + SM1=(P(I1,5)+SMMIN)**2 + DO 360 I3M=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1)) + IF(I3M.EQ.I1M.OR.I3M.EQ.I2M) GOTO 360 + IF(MSTJ(53).EQ.1.AND.K(I3M,5).NE.K(I1M,5)) GOTO 360 + IF(MSTJ(53).EQ.-2.AND.K(I1M,5).EQ.K(I2M,5).AND. + & K(I3M,5).NE.K(I1M,5)) GOTO 360 + I3=K(I3M,1) + IF(K(I3,2).EQ.K(I1,2)) GOTO 360 + S13=SDIP(I1,I3) + S23=SDIP(I2,I3) + SM3=(P(I3,5)+SMMIN)**2 + IF(MSTJ(54).EQ.-2) THEN + WI=(MIN(S12*SM3,S13*MIN(SM1,SM3), + & S23*MIN(SM1,SM3))*SM1) + ELSE + WI=((P(I1,4)+P(I2,4)+P(I3,4))**2- + & (P(I1,3)+P(I2,3)+P(I3,3))**2- + & (P(I1,2)+P(I2,2)+P(I3,2))**2- + & (P(I1,1)+P(I2,1)+P(I3,1))**2) + ENDIF + IF(MSTJ(57).EQ.1.AND.P(I3M,5).GT.0) THEN + IF (WMAX*WI.GE.(1.0D0-EXP(-P(I3M,5)/(PARJ(93)**2)))) + & GOTO 360 + ELSE + IF(WMAX*WI.GE.1.0) GOTO 360 + ENDIF + DO 350 I4M=I3M+1,NBE(MIN(10,MSTJ(52)+1)) + IF(I4M.EQ.I1M.OR.I4M.EQ.I2M) GOTO 350 + IF(MSTJ(53).EQ.1.AND.K(I4M,5).NE.K(I1M,5)) GOTO 350 + IF(MSTJ(53).EQ.-2.AND.K(I1M,5).EQ.K(I2M,5).AND. + & K(I4M,5).NE.K(I1M,5)) GOTO 350 + I4=K(I4M,1) + IF(K(I3,2).EQ.K(I4,2).OR.K(I4,2).EQ.K(I1,2)) + & GOTO 350 + IF((P(I3,4)+P(I4,4)+EDEL)**2.LT. + & (P(I3,1)+P(I4,1))**2+(P(I3,2)+P(I4,2))**2+ + & (P(I3,3)+P(I4,3))**2+(P(I3,5)+P(I4,5))**2) + & GOTO 350 + IF(MSTJ(54).EQ.-2) THEN + S14=SDIP(I1,I4) + S24=SDIP(I2,I4) + S34=SDIP(I3,I4) + W=S12*MIN(MIN(S23,S24),MIN(S13,S14))*S34 + W=MIN(W,S13*MIN(MIN(S23,S34),S12)*S24) + W=MIN(W,S14*MIN(MIN(S24,S34),S12)*S23) + W=MIN(W,MIN(S23,S24)*S13*S14) + W=1.0D0/W + ELSE +C...weight=1-cos(theta)/mtot2 + S1234=(P(I1,4)+P(I2,4)+P(I3,4)+P(I4,4))**2- + & (P(I1,3)+P(I2,3)+P(I3,3)+P(I4,3))**2- + & (P(I1,2)+P(I2,2)+P(I3,2)+P(I4,2))**2- + & (P(I1,1)+P(I2,1)+P(I3,1)+P(I4,1))**2 + W=1.0D0/S1234 + IF(W.LE.WMAX) GOTO 350 + ENDIF + IF(MSTJ(57).EQ.1.AND.P(I3M,5).GT.0) + & W=W*(1.0D0-EXP(-P(I3M,5)/(PARJ(93)**2))) + IF(MSTJ(57).EQ.1.AND.P(I4M,5).GT.0) + & W=W*(1.0D0-EXP(-P(I4M,5)/(PARJ(93)**2))) + IF(W.LE.WMAX) GOTO 350 + MI3=I3M + MI4=I4M + WMAX=W + 350 CONTINUE + 360 CONTINUE + IF(MI4.EQ.0) GOTO 380 + I3=K(MI3,1) + I4=K(MI4,1) + EOLD=P(I3,4)+P(I4,4) + ENEW=EOLD+EDEL + P2=(P(I3,1)+P(I4,1))**2+(P(I3,2)+P(I4,2))**2+ + & (P(I3,3)+P(I4,3))**2 + Q2NEWP=MAX(0.0D0,ENEW**2-P2-(P(I3,5)+P(I4,5))**2) + Q2OLDP=MAX(0.0D0,EOLD**2-P2-(P(I3,5)+P(I4,5))**2) + CALL PYBESQ(I3,I4,NMAX,Q2OLDP,Q2NEWP) + DO 370 J=1,3 + V(MI3,J)=V(MI3,J)+P(NMAX+1,J) + V(MI4,J)=V(MI4,J)+P(NMAX+2,J) + 370 CONTINUE + ENDIF + 380 CONTINUE + 390 CONTINUE + 400 CONTINUE + +C...Shift momenta and recalculate energies. + ESUMP=0.0D0 + ESUM=0.0D0 + PROD=0.0D0 + DO 430 IM=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1)) + I=K(IM,1) + ESUMP=ESUMP+P(I,4) + DO 410 J=1,3 + P(I,J)=P(I,J)+P(IM,J) + 410 CONTINUE + P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2) + ESUM=ESUM+P(I,4) + DO 420 J=1,3 + PROD=PROD+V(IM,J)*P(I,J)/P(I,4) + 420 CONTINUE + 430 CONTINUE + + PARJ(96)=0.0D0 + IF(MSTJ(54).NE.0.AND.PROD.NE.0.0D0) THEN + 440 ALPHA=(ESUMP-ESUM)/PROD + PARJ(96)=PARJ(96)+ALPHA + PROD=0.0D0 + ESUM=0.0D0 + DO 470 IM=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1)) + I=K(IM,1) + DO 450 J=1,3 + P(I,J)=P(I,J)+ALPHA*V(IM,J) + 450 CONTINUE + P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2) + ESUM=ESUM+P(I,4) + DO 460 J=1,3 + PROD=PROD+V(IM,J)*P(I,J)/P(I,4) + 460 CONTINUE + 470 CONTINUE + IF(PROD.NE.0.0D0.AND.ABS(ESUMP-ESUM)/PECM.GT.0.00001D0) + & GOTO 440 + ENDIF + +C...Rescale all momenta for energy conservation. + PES=0D0 + PQS=0D0 + DO 480 I=1,N + IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 480 + PES=PES+P(I,4) + PQS=PQS+P(I,5)**2/P(I,4) + 480 CONTINUE + PARJ(95)=PES-PECM + FAC=(PECM-PQS)/(PES-PQS) + DO 500 I=1,N + IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 500 + DO 490 J=1,3 + P(I,J)=FAC*P(I,J) + 490 CONTINUE + P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2) + 500 CONTINUE + +C...Boost back to correct reference frame. + 510 CALL PYROBO(0,0,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),DPS(3)/DPS(4)) + DO 520 I=1,N + IF(K(I,1).LT.0) K(I,1)=-K(I,1) + 520 CONTINUE + + RETURN + END + +C********************************************************************* + +C...PYBESQ +C...Calculates the momentum shift in a system of two particles assuming +C...the relative momentum squared should be shifted to Q2NEW. NI is the +C...last position occupied in /PYJETS/. + + SUBROUTINE PYBESQ(I1,I2,NI,Q2OLD,Q2NEW) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + SAVE /PYJETS/,/PYDAT1/ +C...Local arrays and data. + DIMENSION DP(5) + SAVE HC1 + + IF(MSTJ(55).EQ.0) THEN + DQ2=Q2NEW-Q2OLD + DP2=(P(I1,1)-P(I2,1))**2+(P(I1,2)-P(I2,2))**2+ + & (P(I1,3)-P(I2,3))**2 + DP12=P(I1,1)**2+P(I1,2)**2+P(I1,3)**2 + & -P(I2,1)**2-P(I2,2)**2-P(I2,3)**2 + SE=P(I1,4)+P(I2,4) + DE=P(I1,4)-P(I2,4) + DQ2SE=DQ2+SE**2 + DA=SE*DE*DP12-DP2*DQ2SE + DB=DP2*DQ2SE-DP12**2 + HA=(DA+SQRT(MAX(DA**2+DQ2*(DQ2+SE**2-DE**2)*DB,0D0)))/(2D0*DB) + DO 100 J=1,3 + PD=HA*(P(I1,J)-P(I2,J)) + P(NI+1,J)=PD + P(NI+2,J)=-PD + 100 CONTINUE + RETURN + ENDIF + + K(NI+1,1)=1 + K(NI+2,1)=1 + DO 110 J=1,5 + P(NI+1,J)=P(I1,J) + P(NI+2,J)=P(I2,J) + DP(J)=P(I1,J)+P(I2,J) + 110 CONTINUE + +C...Boost to cms and rotate first particle to z-axis + CALL PYROBO(NI+1,NI+2,0.0D0,0.0D0, + &-DP(1)/DP(4),-DP(2)/DP(4),-DP(3)/DP(4)) + PHI=PYANGL(P(NI+1,1),P(NI+1,2)) + THE=PYANGL(P(NI+1,3),SQRT(P(NI+1,1)**2+P(NI+1,2)**2)) + S=Q2NEW+(P(I1,5)+P(I2,5))**2 + PZ=0.5D0*SQRT(Q2NEW*(S-(P(I1,5)-P(I2,5))**2)/S) + P(NI+1,1)=0.0D0 + P(NI+1,2)=0.0D0 + P(NI+1,3)=PZ + P(NI+1,4)=SQRT(PZ**2+P(I1,5)**2) + P(NI+2,1)=0.0D0 + P(NI+2,2)=0.0D0 + P(NI+2,3)=-PZ + P(NI+2,4)=SQRT(PZ**2+P(I2,5)**2) + DP(4)=SQRT(DP(1)**2+DP(2)**2+DP(3)**2+S) + CALL PYROBO(NI+1,NI+2,THE,PHI, + &DP(1)/DP(4),DP(2)/DP(4),DP(3)/DP(4)) + + DO 120 J=1,3 + P(NI+1,J)=P(NI+1,J)-P(I1,J) + P(NI+2,J)=P(NI+2,J)-P(I2,J) + 120 CONTINUE + + RETURN + END + +C********************************************************************* + +C...PYMASS +C...Gives the mass of a particle/parton. + + FUNCTION PYMASS(KF) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /PYDAT1/,/PYDAT2/ + +C...Reset variables. Compressed code. Special case for popcorn diquarks. + PYMASS=0D0 + KFA=IABS(KF) + KC=PYCOMP(KF) + IF(KC.EQ.0) THEN + MSTJ(93)=0 + RETURN + ENDIF + +C...Guarantee use of constituent masses for internal checks. + IF((MSTJ(93).EQ.1.OR.MSTJ(93).EQ.2).AND. + &(KFA.LE.10.OR.MOD(KFA/10,10).EQ.0)) THEN + IF(KFA.LE.5) THEN + PYMASS=PARF(100+KFA) + IF(MSTJ(93).EQ.2) PYMASS=MAX(0D0,PYMASS-PARF(121)) + ELSEIF(KFA.LE.10) THEN + PYMASS=PMAS(KFA,1) + ELSEIF(MSTJ(93).EQ.1) THEN + PYMASS=PARF(100+MOD(KFA/1000,10))+PARF(100+MOD(KFA/100,10)) + ELSE + PYMASS=MAX(0D0,PMAS(KC,1)-PARF(122)-2D0*PARF(112)/3D0) + ENDIF + +C...Other masses can be read directly off table. + ELSE + PYMASS=PMAS(KC,1) + ENDIF + +C...Optional mass broadening according to truncated Breit-Wigner +C...(either in m or in m^2). + IF(MSTJ(24).GE.1.AND.PMAS(KC,2).GT.1D-4) THEN + IF(MSTJ(24).EQ.1.OR.(MSTJ(24).EQ.2.AND.KFA.GT.100)) THEN + PYMASS=PYMASS+0.5D0*PMAS(KC,2)*TAN((2D0*PYR(0)-1D0)* + & ATAN(2D0*PMAS(KC,3)/PMAS(KC,2))) + ELSE + PM0=PYMASS + PMLOW=ATAN((MAX(0D0,PM0-PMAS(KC,3))**2-PM0**2)/ + & (PM0*PMAS(KC,2))) + PMUPP=ATAN(((PM0+PMAS(KC,3))**2-PM0**2)/(PM0*PMAS(KC,2))) + PYMASS=SQRT(MAX(0D0,PM0**2+PM0*PMAS(KC,2)*TAN(PMLOW+ + & (PMUPP-PMLOW)*PYR(0)))) + ENDIF + ENDIF + MSTJ(93)=0 + + RETURN + END + +C********************************************************************* + +C...PYMRUN +C...Gives the running, current-algebra mass of a d, u, s, c or b quark, +C...for Higgs couplings. Everything else sent on to PYMASS. + + FUNCTION PYMRUN(KF,Q2) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + SAVE /PYDAT1/,/PYDAT2/,/PYPARS/ + +C...Most masses not handled here. + KFA=IABS(KF) + IF(KFA.EQ.0.OR.KFA.GT.6) THEN + PYMRUN=PYMASS(KF) + +C...Current-algebra masses, but no Q2 dependence. + ELSEIF(MSTP(37).NE.1.OR.MSTP(2).LE.0) THEN + PYMRUN=PARF(90+KFA) + +C...Running current-algebra masses. + ELSE + AS=PYALPS(Q2) + PYMRUN=PARF(90+KFA)* + & (LOG(MAX(4D0,PARP(37)**2*PARF(90+KFA)**2/PARU(117)**2))/ + & LOG(MAX(4D0,Q2/PARU(117)**2)))**(12D0/(33D0-2D0*MSTU(118))) + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYNAME +C...Gives the particle/parton name as a character string. + + SUBROUTINE PYNAME(KF,CHAU) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYDAT4/CHAF(500,2) + CHARACTER CHAF*16 + SAVE /PYDAT1/,/PYDAT2/,/PYDAT4/ +C...Local character variable. + CHARACTER CHAU*16 + +C...Read out code with distinction particle/antiparticle. + CHAU=' ' + KC=PYCOMP(KF) + IF(KC.NE.0) CHAU=CHAF(KC,(3-ISIGN(1,KF))/2) + + + RETURN + END + +C********************************************************************* + +C...PYCHGE +C...Gives three times the charge for a particle/parton. + + FUNCTION PYCHGE(KF) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /PYDAT2/ + +C...Read out charge and change sign for antiparticle. + PYCHGE=0 + KC=PYCOMP(KF) + IF(KC.NE.0) PYCHGE=KCHG(KC,1)*ISIGN(1,KF) + + RETURN + END + +C********************************************************************* + +C...PYCOMP +C...Compress the standard KF codes for use in mass and decay arrays; +C...also checks whether a given code actually is defined. + + FUNCTION PYCOMP(KF) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /PYDAT1/,/PYDAT2/ +C...Local arrays and saved data. + DIMENSION KFORD(100:500),KCORD(101:500) + SAVE KFORD,KCORD,NFORD,KFLAST,KCLAST + +C...Whenever necessary reorder codes for faster search. + IF(MSTU(20).EQ.0) THEN + NFORD=100 + KFORD(100)=0 + DO 120 I=101,500 + KFA=KCHG(I,4) + IF(KFA.LE.100) GOTO 120 + NFORD=NFORD+1 + DO 100 I1=NFORD-1,0,-1 + IF(KFA.GE.KFORD(I1)) GOTO 110 + KFORD(I1+1)=KFORD(I1) + KCORD(I1+1)=KCORD(I1) + 100 CONTINUE + 110 KFORD(I1+1)=KFA + KCORD(I1+1)=I + 120 CONTINUE + MSTU(20)=1 + KFLAST=0 + KCLAST=0 + ENDIF + +C...Fast action if same code as in latest call. + IF(KF.EQ.KFLAST) THEN + PYCOMP=KCLAST + RETURN + ENDIF + +C...Starting values. Remove internal diquark flags. + PYCOMP=0 + KFA=IABS(KF) + IF(MOD(KFA/10,10).EQ.0.AND.KFA.LT.100000 + & .AND.MOD(KFA/1000,10).GT.0) KFA=MOD(KFA,10000) + +C...Simple cases: direct translation. + IF(KFA.GT.KFORD(NFORD)) THEN + ELSEIF(KFA.LE.100) THEN + PYCOMP=KFA + +C...Else binary search. + ELSE + IMIN=100 + IMAX=NFORD+1 + 130 IAVG=(IMIN+IMAX)/2 + IF(KFORD(IAVG).GT.KFA) THEN + IMAX=IAVG + IF(IMAX.GT.IMIN+1) GOTO 130 + ELSEIF(KFORD(IAVG).LT.KFA) THEN + IMIN=IAVG + IF(IMAX.GT.IMIN+1) GOTO 130 + ELSE + PYCOMP=KCORD(IAVG) + ENDIF + ENDIF + +C...Check if antiparticle allowed. + IF(PYCOMP.NE.0.AND.KF.LT.0) THEN + IF(KCHG(PYCOMP,3).EQ.0) PYCOMP=0 + ENDIF + +C...Save codes for possible future fast action. + KFLAST=KF + KCLAST=PYCOMP + + RETURN + END + +C********************************************************************* + +C...PYERRM +C...Informs user of errors in program execution. + + SUBROUTINE PYERRM(MERR,CHMESS) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + SAVE /PYJETS/,/PYDAT1/ +C...Local character variable. + CHARACTER CHMESS*(*) + +C...Write first few warnings, then be silent. + IF(MERR.LE.10) THEN + MSTU(27)=MSTU(27)+1 + MSTU(28)=MERR + IF(MSTU(25).EQ.1.AND.MSTU(27).LE.MSTU(26)) WRITE(MSTU(11),5000) + & MERR,MSTU(31),CHMESS + +C...Write first few errors, then be silent or stop program. + ELSEIF(MERR.LE.20) THEN + IF(MSTU(29).EQ.0) MSTU(23)=MSTU(23)+1 + MSTU(30)=MSTU(30)+1 + MSTU(24)=MERR-10 + IF(MSTU(21).GE.1.AND.MSTU(23).LE.MSTU(22)) WRITE(MSTU(11),5100) + & MERR-10,MSTU(31),CHMESS + IF(MSTU(21).GE.2.AND.MSTU(23).GT.MSTU(22)) THEN + WRITE(MSTU(11),5100) MERR-10,MSTU(31),CHMESS + WRITE(MSTU(11),5200) + IF(MERR.NE.17) CALL PYLIST(2) + CALL PYSTOP(3) + ENDIF + +C...Stop program in case of irreparable error. + ELSE + WRITE(MSTU(11),5300) MERR-20,MSTU(31),CHMESS + CALL PYSTOP(3) + ENDIF + +C...Formats for output. + 5000 FORMAT(/5X,'Advisory warning type',I2,' given after',I9, + &' PYEXEC calls:'/5X,A) + 5100 FORMAT(/5X,'Error type',I2,' has occured after',I9, + &' PYEXEC calls:'/5X,A) + 5200 FORMAT(5X,'Execution will be stopped after listing of last ', + &'event!') + 5300 FORMAT(/5X,'Fatal error type',I2,' has occured after',I9, + &' PYEXEC calls:'/5X,A/5X,'Execution will now be stopped!') + + RETURN + END + +C********************************************************************* + +C...PYALEM +C...Calculates the running alpha_electromagnetic. + + FUNCTION PYALEM(Q2) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + SAVE /PYDAT1/ + +C...Calculate real part of photon vacuum polarization. +C...For leptons simplify by using asymptotic (Q^2 >> m^2) expressions. +C...For hadrons use parametrization of H. Burkhardt et al. +C...See R. Kleiss et al, CERN 89-08, vol. 3, pp. 129-131. + AEMPI=PARU(101)/(3D0*PARU(1)) + IF(MSTU(101).LE.0.OR.Q2.LT.2D-6) THEN + RPIGG=0D0 + ELSEIF(MSTU(101).EQ.2.AND.Q2.LT.PARU(104)) THEN + RPIGG=0D0 + ELSEIF(MSTU(101).EQ.2) THEN + RPIGG=1D0-PARU(101)/PARU(103) + ELSEIF(Q2.LT.0.09D0) THEN + RPIGG=AEMPI*(13.4916D0+LOG(Q2))+0.00835D0*LOG(1D0+Q2) + ELSEIF(Q2.LT.9D0) THEN + RPIGG=AEMPI*(16.3200D0+2D0*LOG(Q2))+ + & 0.00238D0*LOG(1D0+3.927D0*Q2) + ELSEIF(Q2.LT.1D4) THEN + RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00165D0+ + & 0.00299D0*LOG(1D0+Q2) + ELSE + RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00221D0+ + & 0.00293D0*LOG(1D0+Q2) + ENDIF + +C...Calculate running alpha_em. + PYALEM=PARU(101)/(1D0-RPIGG) + PARU(108)=PYALEM + + RETURN + END + +C********************************************************************* + +C...PYALPS +C...Gives the value of alpha_strong. + + FUNCTION PYALPS(Q2) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /PYDAT1/,/PYDAT2/ +C...Coefficients for second-order threshold matching. +C...From W.J. Marciano, Phys. Rev. D29 (1984) 580. + DIMENSION STEPDN(6),STEPUP(6) +c DATA STEPDN/0D0,0D0,(2D0*107D0/2025D0),(2D0*963D0/14375D0), +c &(2D0*321D0/3703D0),0D0/ +c DATA STEPUP/0D0,0D0,0D0,(-2D0*107D0/1875D0), +c &(-2D0*963D0/13225D0),(-2D0*321D0/3381D0)/ + DATA STEPDN/0D0,0D0,0.10568D0,0.13398D0,0.17337D0,0D0/ + DATA STEPUP/0D0,0D0,0D0,-0.11413D0,-0.14563D0,-0.18988D0/ + +C...Constant alpha_strong trivial. Pick artificial Lambda. + IF(MSTU(111).LE.0) THEN + PYALPS=PARU(111) + MSTU(118)=MSTU(112) + PARU(117)=0.2D0 + IF(Q2.GT.0.04D0) PARU(117)=SQRT(Q2)*EXP(-6D0*PARU(1)/ + & ((33D0-2D0*MSTU(112))*PARU(111))) + PARU(118)=PARU(111) + RETURN + ENDIF + +C...Find effective Q2, number of flavours and Lambda. + Q2EFF=Q2 + IF(MSTU(115).GE.2) Q2EFF=MAX(Q2,PARU(114)) + NF=MSTU(112) + ALAM2=PARU(112)**2 + 100 IF(NF.GT.MAX(3,MSTU(113))) THEN + Q2THR=PARU(113)*PMAS(NF,1)**2 + IF(Q2EFF.LT.Q2THR) THEN + NF=NF-1 + Q2RAT=Q2THR/ALAM2 + ALAM2=ALAM2*Q2RAT**(2D0/(33D0-2D0*NF)) + IF(MSTU(111).EQ.2) ALAM2=ALAM2*LOG(Q2RAT)**STEPDN(NF) + GOTO 100 + ENDIF + ENDIF + 110 IF(NF.LT.MIN(6,MSTU(114))) THEN + Q2THR=PARU(113)*PMAS(NF+1,1)**2 + IF(Q2EFF.GT.Q2THR) THEN + NF=NF+1 + Q2RAT=Q2THR/ALAM2 + ALAM2=ALAM2*Q2RAT**(-2D0/(33D0-2D0*NF)) + IF(MSTU(111).EQ.2) ALAM2=ALAM2*LOG(Q2RAT)**STEPUP(NF) + GOTO 110 + ENDIF + ENDIF + IF(MSTU(115).EQ.1) Q2EFF=Q2EFF+ALAM2 + PARU(117)=SQRT(ALAM2) + +C...Evaluate first or second order alpha_strong. + B0=(33D0-2D0*NF)/6D0 + ALGQ=LOG(MAX(1.0001D0,Q2EFF/ALAM2)) + IF(MSTU(111).EQ.1) THEN + PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ)) + ELSE + B1=(153D0-19D0*NF)/6D0 + PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ)*(1D0-B1*LOG(ALGQ)/ + & (B0**2*ALGQ))) + ENDIF + MSTU(118)=NF + PARU(118)=PYALPS + + RETURN + END + +C********************************************************************* + +C...PYANGL +C...Reconstructs an angle from given x and y coordinates. + + FUNCTION PYANGL(X,Y) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + SAVE /PYDAT1/ + + PYANGL=0D0 + R=SQRT(X**2+Y**2) + IF(R.LT.1D-20) RETURN + IF(ABS(X)/R.LT.0.8D0) THEN + PYANGL=SIGN(ACOS(X/R),Y) + ELSE + PYANGL=ASIN(Y/R) + IF(X.LT.0D0.AND.PYANGL.GE.0D0) THEN + PYANGL=PARU(1)-PYANGL + ELSEIF(X.LT.0D0) THEN + PYANGL=-PARU(1)-PYANGL + ENDIF + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYR +C...Generates random numbers uniformly distributed between +C...0 and 1, excluding the endpoints. + + FUNCTION PYR(IDUMMY) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDATR/MRPY(6),RRPY(100) + SAVE /PYDATR/ +C...Equivalence between commonblock and local variables. + EQUIVALENCE (MRPY1,MRPY(1)),(MRPY2,MRPY(2)),(MRPY3,MRPY(3)), + &(MRPY4,MRPY(4)),(MRPY5,MRPY(5)),(MRPY6,MRPY(6)), + &(RRPY98,RRPY(98)),(RRPY99,RRPY(99)),(RRPY00,RRPY(100)) + +C...Initialize generation from given seed. + IF(MRPY2.EQ.0) THEN + IJ=MOD(MRPY1/30082,31329) + KL=MOD(MRPY1,30082) + I=MOD(IJ/177,177)+2 + J=MOD(IJ,177)+2 + K=MOD(KL/169,178)+1 + L=MOD(KL,169) + DO 110 II=1,97 + S=0D0 + T=0.5D0 + DO 100 JJ=1,48 + M=MOD(MOD(I*J,179)*K,179) + I=J + J=K + K=M + L=MOD(53*L+1,169) + IF(MOD(L*M,64).GE.32) S=S+T + T=0.5D0*T + 100 CONTINUE + RRPY(II)=S + 110 CONTINUE + TWOM24=1D0 + DO 120 I24=1,24 + TWOM24=0.5D0*TWOM24 + 120 CONTINUE + RRPY98=362436D0*TWOM24 + RRPY99=7654321D0*TWOM24 + RRPY00=16777213D0*TWOM24 + MRPY2=1 + MRPY3=0 + MRPY4=97 + MRPY5=33 + ENDIF + +C...Generate next random number. + 130 RUNI=RRPY(MRPY4)-RRPY(MRPY5) + IF(RUNI.LT.0D0) RUNI=RUNI+1D0 + RRPY(MRPY4)=RUNI + MRPY4=MRPY4-1 + IF(MRPY4.EQ.0) MRPY4=97 + MRPY5=MRPY5-1 + IF(MRPY5.EQ.0) MRPY5=97 + RRPY98=RRPY98-RRPY99 + IF(RRPY98.LT.0D0) RRPY98=RRPY98+RRPY00 + RUNI=RUNI-RRPY98 + IF(RUNI.LT.0D0) RUNI=RUNI+1D0 + IF(RUNI.LE.0D0.OR.RUNI.GE.1D0) GOTO 130 + +C...Update counters. Random number to output. + MRPY3=MRPY3+1 + IF(MRPY3.EQ.1000000000) THEN + MRPY2=MRPY2+1 + MRPY3=0 + ENDIF + PYR=RUNI + + RETURN + END + +C********************************************************************* + +C...PYRGET +C...Dumps the state of the random number generator on a file +C...for subsequent startup from this state onwards. + + SUBROUTINE PYRGET(LFN,MOVE) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDATR/MRPY(6),RRPY(100) + SAVE /PYDATR/ +C...Local character variable. + CHARACTER CHERR*8 + +C...Backspace required number of records (or as many as there are). + IF(MOVE.LT.0) THEN + NBCK=MIN(MRPY(6),-MOVE) + DO 100 IBCK=1,NBCK + BACKSPACE(LFN,ERR=110,IOSTAT=IERR) + 100 CONTINUE + MRPY(6)=MRPY(6)-NBCK + ENDIF + +C...Unformatted write on unit LFN. + WRITE(LFN,ERR=110,IOSTAT=IERR) (MRPY(I1),I1=1,5), + &(RRPY(I2),I2=1,100) + MRPY(6)=MRPY(6)+1 + RETURN + +C...Write error. + 110 WRITE(CHERR,'(I8)') IERR + CALL PYERRM(18,'(PYRGET:) error when accessing file, IOSTAT ='// + &CHERR) + + RETURN + END + +C********************************************************************* + +C...PYRSET +C...Reads a state of the random number generator from a file +C...for subsequent generation from this state onwards. + + SUBROUTINE PYRSET(LFN,MOVE) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDATR/MRPY(6),RRPY(100) + SAVE /PYDATR/ +C...Local character variable. + CHARACTER CHERR*8 + +C...Backspace required number of records (or as many as there are). + IF(MOVE.LT.0) THEN + NBCK=MIN(MRPY(6),-MOVE) + DO 100 IBCK=1,NBCK + BACKSPACE(LFN,ERR=120,IOSTAT=IERR) + 100 CONTINUE + MRPY(6)=MRPY(6)-NBCK + ENDIF + +C...Unformatted read from unit LFN. + NFOR=1+MAX(0,MOVE) + DO 110 IFOR=1,NFOR + READ(LFN,ERR=120,IOSTAT=IERR) (MRPY(I1),I1=1,5), + & (RRPY(I2),I2=1,100) + 110 CONTINUE + MRPY(6)=MRPY(6)+NFOR + RETURN + +C...Write error. + 120 WRITE(CHERR,'(I8)') IERR + CALL PYERRM(18,'(PYRSET:) error when accessing file, IOSTAT ='// + &CHERR) + + RETURN + END + +C********************************************************************* + +C...PYROBO +C...Performs rotations and boosts. + + SUBROUTINE PYROBO(IMI,IMA,THE,PHI,BEX,BEY,BEZ) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + SAVE /PYJETS/,/PYDAT1/ +C...Local arrays. + DIMENSION ROT(3,3),PR(3),VR(3),DP(4),DV(4) + +C...Find and check range of rotation/boost. + IMIN=IMI + IF(IMIN.LE.0) IMIN=1 + IF(MSTU(1).GT.0) IMIN=MSTU(1) + IMAX=IMA + IF(IMAX.LE.0) IMAX=N + IF(MSTU(2).GT.0) IMAX=MSTU(2) + IF(IMIN.GT.MSTU(4).OR.IMAX.GT.MSTU(4)) THEN + CALL PYERRM(11,'(PYROBO:) range outside PYJETS memory') + RETURN + ENDIF + +C...Optional resetting of V (when not set before.) + IF(MSTU(33).NE.0) THEN + DO 110 I=MIN(IMIN,MSTU(4)),MIN(IMAX,MSTU(4)) + DO 100 J=1,5 + V(I,J)=0D0 + 100 CONTINUE + 110 CONTINUE + MSTU(33)=0 + ENDIF + +C...Rotate, typically from z axis to direction (theta,phi). + IF(THE**2+PHI**2.GT.1D-20) THEN + ROT(1,1)=COS(THE)*COS(PHI) + ROT(1,2)=-SIN(PHI) + ROT(1,3)=SIN(THE)*COS(PHI) + ROT(2,1)=COS(THE)*SIN(PHI) + ROT(2,2)=COS(PHI) + ROT(2,3)=SIN(THE)*SIN(PHI) + ROT(3,1)=-SIN(THE) + ROT(3,2)=0D0 + ROT(3,3)=COS(THE) + DO 140 I=IMIN,IMAX + IF(K(I,1).LE.0) GOTO 140 + DO 120 J=1,3 + PR(J)=P(I,J) + VR(J)=V(I,J) + 120 CONTINUE + DO 130 J=1,3 + P(I,J)=ROT(J,1)*PR(1)+ROT(J,2)*PR(2)+ROT(J,3)*PR(3) + V(I,J)=ROT(J,1)*VR(1)+ROT(J,2)*VR(2)+ROT(J,3)*VR(3) + 130 CONTINUE + 140 CONTINUE + ENDIF + +C...Boost, typically from rest to momentum/energy=beta. + IF(BEX**2+BEY**2+BEZ**2.GT.1D-20) THEN + DBX=BEX + DBY=BEY + DBZ=BEZ + DB=SQRT(DBX**2+DBY**2+DBZ**2) + EPS1=1D0-1D-12 + IF(DB.GT.EPS1) THEN +C...Rescale boost vector if too close to unity. + CALL PYERRM(3,'(PYROBO:) boost vector too large') + DBX=DBX*(EPS1/DB) + DBY=DBY*(EPS1/DB) + DBZ=DBZ*(EPS1/DB) + DB=EPS1 + ENDIF + DGA=1D0/SQRT(1D0-DB**2) + DO 160 I=IMIN,IMAX + IF(K(I,1).LE.0) GOTO 160 + DO 150 J=1,4 + DP(J)=P(I,J) + DV(J)=V(I,J) + 150 CONTINUE + DBP=DBX*DP(1)+DBY*DP(2)+DBZ*DP(3) + DGABP=DGA*(DGA*DBP/(1D0+DGA)+DP(4)) + P(I,1)=DP(1)+DGABP*DBX + P(I,2)=DP(2)+DGABP*DBY + P(I,3)=DP(3)+DGABP*DBZ + P(I,4)=DGA*(DP(4)+DBP) + DBV=DBX*DV(1)+DBY*DV(2)+DBZ*DV(3) + DGABV=DGA*(DGA*DBV/(1D0+DGA)+DV(4)) + V(I,1)=DV(1)+DGABV*DBX + V(I,2)=DV(2)+DGABV*DBY + V(I,3)=DV(3)+DGABV*DBZ + V(I,4)=DGA*(DV(4)+DBV) + 160 CONTINUE + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYEDIT +C...Performs global manipulations on the event record, in particular +C...to exclude unstable or undetectable partons/particles. + + SUBROUTINE PYEDIT(MEDIT) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYCTAG/NCT,MCT(4000,2) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYCTAG/ +C...Local arrays. + DIMENSION NS(2),PTS(2),PLS(2) + +C...Remove unwanted partons/particles. + IF((MEDIT.GE.0.AND.MEDIT.LE.3).OR.MEDIT.EQ.5) THEN + IMAX=N + IF(MSTU(2).GT.0) IMAX=MSTU(2) + I1=MAX(1,MSTU(1))-1 + DO 110 I=MAX(1,MSTU(1)),IMAX + IF(K(I,1).EQ.0.OR.(K(I,1).GE.21.AND.K(I,1).LE.40)) GOTO 110 + IF(MEDIT.EQ.1) THEN + IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110 + ELSEIF(MEDIT.EQ.2) THEN + IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110 + KC=PYCOMP(K(I,2)) + IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR. + & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR. + & K(I,2).EQ.KSUSY1+39) GOTO 110 + ELSEIF(MEDIT.EQ.3) THEN + IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110 + KC=PYCOMP(K(I,2)) + IF(KC.EQ.0) GOTO 110 + IF(KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0) GOTO 110 + ELSEIF(MEDIT.EQ.5) THEN + IF(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.K(I,1).EQ.52) GOTO 110 + KC=PYCOMP(K(I,2)) + IF(KC.EQ.0) GOTO 110 + IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42.AND. + & KCHG(KC,2).EQ.0) GOTO 110 + ENDIF + +C...Pack remaining partons/particles. Origin no longer known. + I1=I1+1 + DO 100 J=1,5 + K(I1,J)=K(I,J) + P(I1,J)=P(I,J) + V(I1,J)=V(I,J) + 100 CONTINUE + K(I1,3)=0 + 110 CONTINUE + IF(I1.LT.N) MSTU(3)=0 + IF(I1.LT.N) MSTU(70)=0 + N=I1 + +C...Selective removal of class of entries. New position of retained. + ELSEIF(MEDIT.GE.11.AND.MEDIT.LE.15) THEN + I1=0 + DO 120 I=1,N + K(I,3)=MOD(K(I,3),MSTU(5)) + IF(MEDIT.EQ.11.AND.K(I,1).LT.0) GOTO 120 + IF(MEDIT.EQ.12.AND.K(I,1).EQ.0) GOTO 120 + IF(MEDIT.EQ.13.AND.(K(I,1).EQ.11.OR.K(I,1).EQ.12.OR. + & K(I,1).EQ.15.OR.K(I,1).EQ.51).AND.K(I,2).NE.94) GOTO 120 + IF(MEDIT.EQ.14.AND.(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR. + & K(I,1).EQ.52.OR.K(I,2).EQ.94)) GOTO 120 + IF(MEDIT.EQ.15.AND.K(I,1).GE.21.AND.K(I,1).LE.40) GOTO 120 + I1=I1+1 + K(I,3)=K(I,3)+MSTU(5)*I1 + 120 CONTINUE + +C...Find new event history information and replace old. + DO 140 I=1,N + IF(K(I,1).LE.0.OR.(K(I,1).GE.21.AND.K(I,1).LE.40).OR. + & K(I,3)/MSTU(5).EQ.0) GOTO 140 + ID=I + 130 IM=MOD(K(ID,3),MSTU(5)) + IF(MEDIT.EQ.13.AND.IM.GT.0.AND.IM.LE.N) THEN + IF((K(IM,1).EQ.11.OR.K(IM,1).EQ.12.OR.K(IM,1).EQ.15.OR. + & K(IM,1).EQ.51).AND.K(IM,2).NE.94) THEN + ID=IM + GOTO 130 + ENDIF + ELSEIF(MEDIT.EQ.14.AND.IM.GT.0.AND.IM.LE.N) THEN + IF(K(IM,1).EQ.13.OR.K(IM,1).EQ.14.OR.K(IM,1).EQ.52.OR. + & K(IM,2).EQ.94) THEN + ID=IM + GOTO 130 + ENDIF + ENDIF + K(I,3)=MSTU(5)*(K(I,3)/MSTU(5)) + IF(IM.NE.0) K(I,3)=K(I,3)+K(IM,3)/MSTU(5) + IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14.AND. + & K(I,1).NE.42.AND.K(I,1).NE.52) THEN + IF(K(I,4).GT.0.AND.K(I,4).LE.MSTU(4)) K(I,4)= + & K(K(I,4),3)/MSTU(5) + IF(K(I,5).GT.0.AND.K(I,5).LE.MSTU(4)) K(I,5)= + & K(K(I,5),3)/MSTU(5) + ELSE + KCM=MOD(K(I,4)/MSTU(5),MSTU(5)) + IF(KCM.GT.0.AND.KCM.LE.MSTU(4).AND.K(I,1).NE.42.AND. + & K(I,1).NE.52) KCM=K(KCM,3)/MSTU(5) + KCD=MOD(K(I,4),MSTU(5)) + IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5) + K(I,4)=MSTU(5)**2*(K(I,4)/MSTU(5)**2)+MSTU(5)*KCM+KCD + KCM=MOD(K(I,5)/MSTU(5),MSTU(5)) + IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5) + KCD=MOD(K(I,5),MSTU(5)) + IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5) + K(I,5)=MSTU(5)**2*(K(I,5)/MSTU(5)**2)+MSTU(5)*KCM+KCD + ENDIF + 140 CONTINUE + +C...Pack remaining entries. + I1=0 + MSTU90=MSTU(90) + MSTU(90)=0 + DO 170 I=1,N + IF(K(I,3)/MSTU(5).EQ.0) GOTO 170 + I1=I1+1 + DO 150 J=1,5 + K(I1,J)=K(I,J) + P(I1,J)=P(I,J) + V(I1,J)=V(I,J) + 150 CONTINUE +C...Also update LHA1 colour tags + MCT(I1,1)=MCT(I,1) + MCT(I1,2)=MCT(I,2) + K(I1,3)=MOD(K(I1,3),MSTU(5)) + DO 160 IZ=1,MSTU90 + IF(I.EQ.MSTU(90+IZ)) THEN + MSTU(90)=MSTU(90)+1 + MSTU(90+MSTU(90))=I1 + PARU(90+MSTU(90))=PARU(90+IZ) + ENDIF + 160 CONTINUE + 170 CONTINUE + IF(I1.LT.N) MSTU(3)=0 + IF(I1.LT.N) MSTU(70)=0 + N=I1 + +C...Fill in some missing daughter pointers (lost in colour flow). + ELSEIF(MEDIT.EQ.16) THEN + DO 220 I=1,N + IF(K(I,1).LE.10.OR.(K(I,1).GE.21.AND.K(I,1).LE.50)) GOTO 220 + IF(K(I,4).NE.0.OR.K(I,5).NE.0) GOTO 220 +C...Find daughters who point to mother. + DO 180 I1=I+1,N + IF(K(I1,3).NE.I) THEN + ELSEIF(K(I,4).EQ.0) THEN + K(I,4)=I1 + ELSE + K(I,5)=I1 + ENDIF + 180 CONTINUE + IF(K(I,5).EQ.0) K(I,5)=K(I,4) + IF(K(I,4).NE.0) GOTO 220 +C...Find daughters who point to documentation version of mother. + IM=K(I,3) + IF(IM.LE.0.OR.IM.GE.I) GOTO 220 + IF(K(IM,1).LE.20.OR.K(IM,1).GT.30) GOTO 220 + IF(K(IM,2).NE.K(I,2).OR.ABS(P(IM,5)-P(I,5)).GT.1D-2) GOTO 220 + DO 190 I1=I+1,N + IF(K(I1,3).NE.IM) THEN + ELSEIF(K(I,4).EQ.0) THEN + K(I,4)=I1 + ELSE + K(I,5)=I1 + ENDIF + 190 CONTINUE + IF(K(I,5).EQ.0) K(I,5)=K(I,4) + IF(K(I,4).NE.0) GOTO 220 +C...Find daughters who point to documentation daughters who, +C...in their turn, point to documentation mother. + ID1=IM + ID2=IM + DO 200 I1=IM+1,I-1 + IF(K(I1,3).EQ.IM.AND.K(I1,1).GE.21.AND.K(I1,1).LE.30) THEN + ID2=I1 + IF(ID1.EQ.IM) ID1=I1 + ENDIF + 200 CONTINUE + DO 210 I1=I+1,N + IF(K(I1,3).NE.ID1.AND.K(I1,3).NE.ID2) THEN + ELSEIF(K(I,4).EQ.0) THEN + K(I,4)=I1 + ELSE + K(I,5)=I1 + ENDIF + 210 CONTINUE + IF(K(I,5).EQ.0) K(I,5)=K(I,4) + 220 CONTINUE + +C...Save top entries at bottom of PYJETS commonblock. + ELSEIF(MEDIT.EQ.21) THEN + IF(2*N.GE.MSTU(4)) THEN + CALL PYERRM(11,'(PYEDIT:) no more memory left in PYJETS') + RETURN + ENDIF + DO 240 I=1,N + DO 230 J=1,5 + K(MSTU(4)-I,J)=K(I,J) + P(MSTU(4)-I,J)=P(I,J) + V(MSTU(4)-I,J)=V(I,J) + 230 CONTINUE + 240 CONTINUE + MSTU(32)=N + +C...Restore bottom entries of commonblock PYJETS to top. + ELSEIF(MEDIT.EQ.22) THEN + DO 260 I=1,MSTU(32) + DO 250 J=1,5 + K(I,J)=K(MSTU(4)-I,J) + P(I,J)=P(MSTU(4)-I,J) + V(I,J)=V(MSTU(4)-I,J) + 250 CONTINUE + 260 CONTINUE + N=MSTU(32) + +C...Mark primary entries at top of commonblock PYJETS as untreated. + ELSEIF(MEDIT.EQ.23) THEN + I1=0 + DO 270 I=1,N + KH=K(I,3) + IF(KH.GE.1) THEN + IF(K(KH,1).GE.21.AND.K(KH,1).LE.30) KH=0 + ENDIF + IF(KH.NE.0) GOTO 280 + I1=I1+1 + IF(K(I,1).GE.11.AND.K(I,1).LE.20) K(I,1)=K(I,1)-10 + IF(K(I,1).GE.51.AND.K(I,1).LE.60) K(I,1)=K(I,1)-10 + 270 CONTINUE + 280 N=I1 + +C...Place largest axis along z axis and second largest in xy plane. + ELSEIF(MEDIT.EQ.31.OR.MEDIT.EQ.32) THEN + CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61),1), + & P(MSTU(61),2)),0D0,0D0,0D0) + CALL PYROBO(1,N+MSTU(3),-PYANGL(P(MSTU(61),3), + & P(MSTU(61),1)),0D0,0D0,0D0,0D0) + CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61)+1,1), + & P(MSTU(61)+1,2)),0D0,0D0,0D0) + IF(MEDIT.EQ.31) RETURN + +C...Rotate to put slim jet along +z axis. + DO 290 IS=1,2 + NS(IS)=0 + PTS(IS)=0D0 + PLS(IS)=0D0 + 290 CONTINUE + DO 300 I=1,N + IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 300 + IF(MSTU(41).GE.2) THEN + KC=PYCOMP(K(I,2)) + IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR. + & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR. + & K(I,2).EQ.KSUSY1+39) GOTO 300 + IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)) + & .EQ.0) GOTO 300 + ENDIF + IS=2D0-SIGN(0.5D0,P(I,3)) + NS(IS)=NS(IS)+1 + PTS(IS)=PTS(IS)+SQRT(P(I,1)**2+P(I,2)**2) + 300 CONTINUE + IF(NS(1)*PTS(2)**2.LT.NS(2)*PTS(1)**2) + & CALL PYROBO(1,N+MSTU(3),PARU(1),0D0,0D0,0D0,0D0) + +C...Rotate to put second largest jet into -z,+x quadrant. + DO 310 I=1,N + IF(P(I,3).GE.0D0) GOTO 310 + IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 310 + IF(MSTU(41).GE.2) THEN + KC=PYCOMP(K(I,2)) + IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR. + & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR. + & K(I,2).EQ.KSUSY1+39) GOTO 310 + IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)) + & .EQ.0) GOTO 310 + ENDIF + IS=2D0-SIGN(0.5D0,P(I,1)) + PLS(IS)=PLS(IS)-P(I,3) + 310 CONTINUE + IF(PLS(2).GT.PLS(1)) CALL PYROBO(1,N+MSTU(3),0D0,PARU(1), + & 0D0,0D0,0D0) + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYLIST +C...Gives program heading, or lists an event, or particle +C...data, or current parameter values. + + SUBROUTINE PYLIST(MLIST) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) + +C...HEPEVT commonblock. + PARAMETER (NMXHEP=4000) + COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP), + &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP) + DOUBLE PRECISION PHEP,VHEP + SAVE /HEPEVT/ + +C...User process event common block. + INTEGER MAXNUP + PARAMETER (MAXNUP=500) + INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP + DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP + COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP), + &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP), + &VTIMUP(MAXNUP),SPINUP(MAXNUP) + SAVE /HEPEUP/ + +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + COMMON/PYCTAG/NCT,MCT(4000,2) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYCTAG/ +C...Local arrays, character variables and data. + CHARACTER CHAP*16,CHAC*16,CHAN*16,CHAD(5)*16,CHDL(7)*4 + DIMENSION PS(6) + DATA CHDL/'(())',' ','()','!!','<>','==','(==)'/ + +C...Initialization printout: version number and date of last change. + IF(MLIST.EQ.0.OR.MSTU(12).EQ.1) THEN + CALL PYLOGO + MSTU(12)=12345 + IF(MLIST.EQ.0) RETURN + ENDIF + +C...List event data, including additional lines after N. + IF(MLIST.GE.1.AND.MLIST.LE.4) THEN + IF(MLIST.EQ.1) WRITE(MSTU(11),5100) + IF(MLIST.EQ.2) WRITE(MSTU(11),5200) + IF(MLIST.EQ.3) WRITE(MSTU(11),5300) + IF(MLIST.EQ.4) WRITE(MSTU(11),5400) + LMX=12 + IF(MLIST.GE.2) LMX=16 + ISTR=0 + IMAX=N + IF(MSTU(2).GT.0) IMAX=MSTU(2) + DO 120 I=MAX(1,MSTU(1)),MAX(IMAX,N+MAX(0,MSTU(3))) + IF(I.GT.IMAX.AND.I.LE.N) GOTO 120 + IF(MSTU(15).EQ.0.AND.K(I,1).LE.0) GOTO 120 + IF(MSTU(15).EQ.1.AND.K(I,1).LT.0) GOTO 120 + +C...Get particle name, pad it and check it is not too long. + CALL PYNAME(K(I,2),CHAP) + LEN=0 + DO 100 LEM=1,16 + IF(CHAP(LEM:LEM).NE.' ') LEN=LEM + 100 CONTINUE + MDL=(K(I,1)+19)/10 + LDL=0 + IF(MDL.EQ.2.OR.MDL.GE.8) THEN + CHAC=CHAP + IF(LEN.GT.LMX) CHAC(LMX:LMX)='?' + ELSE + LDL=1 + IF(MDL.EQ.1.OR.MDL.EQ.7) LDL=2 + IF(LEN.EQ.0) THEN + CHAC=CHDL(MDL)(1:2*LDL)//' ' + ELSE + CHAC=CHDL(MDL)(1:LDL)//CHAP(1:MIN(LEN,LMX-2*LDL))// + & CHDL(MDL)(LDL+1:2*LDL)//' ' + IF(LEN+2*LDL.GT.LMX) CHAC(LMX:LMX)='?' + ENDIF + ENDIF + +C...Add information on string connection. + IF(K(I,1).EQ.1.OR.K(I,1).EQ.2.OR.K(I,1).EQ.11.OR.K(I,1).EQ.12) + & THEN + KC=PYCOMP(K(I,2)) + KCC=0 + IF(KC.NE.0) KCC=KCHG(KC,2) + IF(IABS(K(I,2)).EQ.39) THEN + IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='X' + ELSEIF(KCC.NE.0.AND.ISTR.EQ.0) THEN + ISTR=1 + IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='A' + ELSEIF(KCC.NE.0.AND.(K(I,1).EQ.2.OR.K(I,1).EQ.12)) THEN + IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='I' + ELSEIF(KCC.NE.0) THEN + ISTR=0 + IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='V' + ENDIF + ENDIF + IF((K(I,1).EQ.41.OR.K(I,1).EQ.51).AND.LEN+2*LDL+3.LE.LMX) + & CHAC(LMX-1:LMX-1)='I' + +C...Write data for particle/jet. + IF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.9999D0) THEN + WRITE(MSTU(11),5500) I,CHAC(1:12),(K(I,J1),J1=1,3), + & (P(I,J2),J2=1,5) + ELSEIF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.99999D0) THEN + WRITE(MSTU(11),5600) I,CHAC(1:12),(K(I,J1),J1=1,3), + & (P(I,J2),J2=1,5) + ELSEIF(MLIST.EQ.1) THEN + WRITE(MSTU(11),5700) I,CHAC(1:12),(K(I,J1),J1=1,3), + & (P(I,J2),J2=1,5) + ELSEIF(MSTU(5).EQ.10000.AND.(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR. + & K(I,1).EQ.14.OR.K(I,1).EQ.42.OR.K(I,1).EQ.52)) THEN + IF(MLIST.NE.4) WRITE(MSTU(11),5800) I,CHAC,(K(I,J1),J1=1,3), + & K(I,4)/100000000,MOD(K(I,4)/10000,10000),MOD(K(I,4),10000), + & K(I,5)/100000000,MOD(K(I,5)/10000,10000),MOD(K(I,5),10000), + & (P(I,J2),J2=1,5) + IF(MLIST.EQ.4) WRITE(MSTU(11),5900) I,CHAC,(K(I,J1),J1=1,3), + & K(I,4)/100000000,MOD(K(I,4)/10000,10000),MOD(K(I,4),10000), + & K(I,5)/100000000,MOD(K(I,5)/10000,10000),MOD(K(I,5) + & ,10000),MCT(I,1),MCT(I,2) + ELSE + IF(MLIST.NE.4) WRITE(MSTU(11),6000) I,CHAC,(K(I,J1),J1=1,5), + & (P(I,J2),J2=1,5) + IF(MLIST.EQ.4) WRITE(MSTU(11),6100) I,CHAC,(K(I,J1),J1=1,5) + & ,MCT(I,1),MCT(I,2) + ENDIF + IF(MLIST.EQ.3) WRITE(MSTU(11),6200) (V(I,J),J=1,5) + +C...Insert extra separator lines specified by user. + IF(MSTU(70).GE.1) THEN + ISEP=0 + DO 110 J=1,MIN(10,MSTU(70)) + IF(I.EQ.MSTU(70+J)) ISEP=1 + 110 CONTINUE + IF(ISEP.EQ.1) THEN + IF(MLIST.EQ.1) WRITE(MSTU(11),6300) + IF(MLIST.EQ.2.OR.MLIST.EQ.3) WRITE(MSTU(11),6400) + IF(MLIST.EQ.4) WRITE(MSTU(11),6500) + ENDIF + ENDIF + 120 CONTINUE + +C...Sum of charges and momenta. + DO 130 J=1,6 + PS(J)=PYP(0,J) + 130 CONTINUE + IF(MLIST.EQ.1.AND.ABS(PS(4)).LT.9999D0) THEN + WRITE(MSTU(11),6600) PS(6),(PS(J),J=1,5) + ELSEIF(MLIST.EQ.1.AND.ABS(PS(4)).LT.99999D0) THEN + WRITE(MSTU(11),6700) PS(6),(PS(J),J=1,5) + ELSEIF(MLIST.EQ.1) THEN + WRITE(MSTU(11),6800) PS(6),(PS(J),J=1,5) + ELSEIF(MLIST.LE.3) THEN + WRITE(MSTU(11),6900) PS(6),(PS(J),J=1,5) + ELSE + WRITE(MSTU(11),7000) PS(6) + ENDIF + +C...Simple listing of HEPEVT entries (mainly for test purposes). + ELSEIF(MLIST.EQ.5) THEN + WRITE(MSTU(11),7100) + DO 140 I=1,NHEP + IF(ISTHEP(I).EQ.0) GOTO 140 + WRITE(MSTU(11),7200) I,ISTHEP(I),IDHEP(I),JMOHEP(1,I), + & JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),(PHEP(J,I),J=1,5) + 140 CONTINUE + + +C...Simple listing of user-process entries (mainly for test purposes). + ELSEIF(MLIST.EQ.7) THEN + WRITE(MSTU(11),7300) + DO 150 I=1,NUP + WRITE(MSTU(11),7400) I,ISTUP(I),IDUP(I),MOTHUP(1,I), + & MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5) + 150 CONTINUE + +C...Give simple list of KF codes defined in program. + ELSEIF(MLIST.EQ.11) THEN + WRITE(MSTU(11),7500) + DO 160 KF=1,80 + CALL PYNAME(KF,CHAP) + CALL PYNAME(-KF,CHAN) + IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),7600) KF,CHAP + IF(CHAN.NE.' ') WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN + 160 CONTINUE + DO 190 KFLS=1,3,2 + DO 180 KFLA=1,5 + DO 170 KFLB=1,KFLA-(3-KFLS)/2 + KF=1000*KFLA+100*KFLB+KFLS + CALL PYNAME(KF,CHAP) + CALL PYNAME(-KF,CHAN) + WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN + 170 CONTINUE + 180 CONTINUE + 190 CONTINUE + DO 220 KMUL=0,5 + KFLS=3 + IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1 + IF(KMUL.EQ.5) KFLS=5 + KFLR=0 + IF(KMUL.EQ.2.OR.KMUL.EQ.3) KFLR=1 + IF(KMUL.EQ.4) KFLR=2 + DO 210 KFLB=1,5 + DO 200 KFLC=1,KFLB-1 + KF=10000*KFLR+100*KFLB+10*KFLC+KFLS + CALL PYNAME(KF,CHAP) + CALL PYNAME(-KF,CHAN) + WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN + IF(KF.EQ.311) THEN + KFK=130 + CALL PYNAME(KFK,CHAP) + WRITE(MSTU(11),7600) KFK,CHAP + KFK=310 + CALL PYNAME(KFK,CHAP) + WRITE(MSTU(11),7600) KFK,CHAP + ENDIF + 200 CONTINUE + KF=10000*KFLR+110*KFLB+KFLS + CALL PYNAME(KF,CHAP) + WRITE(MSTU(11),7600) KF,CHAP + 210 CONTINUE + 220 CONTINUE + KF=100443 + CALL PYNAME(KF,CHAP) + WRITE(MSTU(11),7600) KF,CHAP + KF=100553 + CALL PYNAME(KF,CHAP) + WRITE(MSTU(11),7600) KF,CHAP + DO 260 KFLSP=1,3 + KFLS=2+2*(KFLSP/3) + DO 250 KFLA=1,5 + DO 240 KFLB=1,KFLA + DO 230 KFLC=1,KFLB + IF(KFLSP.EQ.1.AND.(KFLA.EQ.KFLB.OR.KFLB.EQ.KFLC)) + & GOTO 230 + IF(KFLSP.EQ.2.AND.KFLA.EQ.KFLC) GOTO 230 + IF(KFLSP.EQ.1) KF=1000*KFLA+100*KFLC+10*KFLB+KFLS + IF(KFLSP.GE.2) KF=1000*KFLA+100*KFLB+10*KFLC+KFLS + CALL PYNAME(KF,CHAP) + CALL PYNAME(-KF,CHAN) + WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN + 230 CONTINUE + 240 CONTINUE + 250 CONTINUE + 260 CONTINUE + DO 270 KC=1,500 + KF=KCHG(KC,4) + IF(KF.LT.1000000) GOTO 270 + CALL PYNAME(KF,CHAP) + CALL PYNAME(-KF,CHAN) + IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),7600) KF,CHAP + IF(CHAN.NE.' ') WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN + 270 CONTINUE + +C...List parton/particle data table. Check whether to be listed. + ELSEIF(MLIST.EQ.12) THEN + WRITE(MSTU(11),7700) + DO 300 KC=1,MSTU(6) + KF=KCHG(KC,4) + IF(KF.EQ.0) GOTO 300 + IF(KF.LT.MSTU(1).OR.(MSTU(2).GT.0.AND.KF.GT.MSTU(2))) + & GOTO 300 + +C...Find particle name and mass. Print information. + CALL PYNAME(KF,CHAP) + IF(KF.LE.100.AND.CHAP.EQ.' '.AND.MDCY(KC,2).EQ.0) GOTO 300 + CALL PYNAME(-KF,CHAN) + WRITE(MSTU(11),7800) KF,KC,CHAP,CHAN,(KCHG(KC,J1),J1=1,3), + & (PMAS(KC,J2),J2=1,4),MDCY(KC,1) + +C...Particle decay: channel number, branching ratios, matrix element, +C...decay products. + DO 290 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1 + DO 280 J=1,5 + CALL PYNAME(KFDP(IDC,J),CHAD(J)) + 280 CONTINUE + WRITE(MSTU(11),7900) IDC,MDME(IDC,1),MDME(IDC,2),BRAT(IDC), + & (CHAD(J),J=1,5) + 290 CONTINUE + 300 CONTINUE + +C...List parameter value table. + ELSEIF(MLIST.EQ.13) THEN + WRITE(MSTU(11),8000) + DO 310 I=1,200 + WRITE(MSTU(11),8100) I,MSTU(I),PARU(I),MSTJ(I),PARJ(I),PARF(I) + 310 CONTINUE + ENDIF + +C...Format statements for output on unit MSTU(11) (by default 6). + 5100 FORMAT(///28X,'Event listing (summary)'//4X,'I particle/jet KS', + &5X,'KF orig p_x p_y p_z E m'/) + 5200 FORMAT(///28X,'Event listing (standard)'//4X,'I particle/jet', + &' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)', + &' P(I,2) P(I,3) P(I,4) P(I,5)'/) + 5300 FORMAT(///28X,'Event listing (with vertices)'//4X,'I particle/j', + &'et K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)', + &' P(I,2) P(I,3) P(I,4) P(I,5)'/73X, + &'V(I,1) V(I,2) V(I,3) V(I,4) V(I,5)'/) + 5400 FORMAT(///28X,'Event listing (no momenta)'//4X,'I particle/jet', + & ' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5)',1X + & ,' C tag AC tag'/) + 5500 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.3) + 5600 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.2) + 5700 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.1) + 5800 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I1,2I4),5F13.5) + 5900 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I1,2I4),1X,2I8) + 6000 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I9),5F13.5) + 6100 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I9),1X,2I8) + 6200 FORMAT(66X,5(1X,F12.3)) + 6300 FORMAT(1X,78('=')) + 6400 FORMAT(1X,130('=')) + 6500 FORMAT(1X,65('=')) + 6600 FORMAT(19X,'sum:',F6.2,5X,5F9.3) + 6700 FORMAT(19X,'sum:',F6.2,5X,5F9.2) + 6800 FORMAT(19X,'sum:',F6.2,5X,5F9.1) + 6900 FORMAT(19X,'sum charge:',F6.2,3X,'sum momentum and inv. mass:', + &5F13.5) + 7000 FORMAT(19X,'sum charge:',F6.2) + 7100 FORMAT(/10X,'Event listing of HEPEVT common block (simplified)' + &//' I IST ID Mothers Daughters p_x p_y p_z', + &' E m') + 7200 FORMAT(1X,I4,I2,I8,4I5,5F9.3) + 7300 FORMAT(/10X,'Event listing of user process at input (simplified)' + &//' I IST ID Mothers Colours p_x p_y p_z', + &' E m') + 7400 FORMAT(1X,I3,I3,I8,2I4,2I5,5F9.3) + 7500 FORMAT(///20X,'List of KF codes in program'/) + 7600 FORMAT(4X,I9,4X,A16,6X,I9,4X,A16) + 7700 FORMAT(///30X,'Particle/parton data table'//8X,'KF',5X,'KC',4X, + &'particle',8X,'antiparticle',6X,'chg col anti',8X,'mass',7X, + &'width',7X,'w-cut',5X,'lifetime',1X,'decay'/11X,'IDC',1X,'on/off', + &1X,'ME',3X,'Br.rat.',4X,'decay products') + 7800 FORMAT(/1X,I9,3X,I4,4X,A16,A16,3I5,1X,F12.5,2(1X,F11.5), + &1X,1P,E13.5,3X,I2) + 7900 FORMAT(10X,I4,2X,I3,2X,I3,2X,F10.6,4X,5A16) + 8000 FORMAT(///20X,'Parameter value table'//4X,'I',3X,'MSTU(I)', + &8X,'PARU(I)',3X,'MSTJ(I)',8X,'PARJ(I)',8X,'PARF(I)') + 8100 FORMAT(1X,I4,1X,I9,1X,F14.5,1X,I9,1X,F14.5,1X,F14.5) + + RETURN + END + +C********************************************************************* + +C...PYLOGO +C...Writes a logo for the program. + + SUBROUTINE PYLOGO + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter for length of information block. + PARAMETER (IREFER=19) +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + SAVE /PYDAT1/,/PYPARS/ +C...Local arrays and character variables. + INTEGER IDATI(6) + CHARACTER MONTH(12)*3, LOGO(48)*32, REFER(2*IREFER)*36, LINE*79, + &VERS*1, SUBV*3, DATE*2, YEAR*4, HOUR*2, MINU*2, SECO*2 + +C...Data on months, logo, titles, and references. + DATA MONTH/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep', + &'Oct','Nov','Dec'/ + DATA (LOGO(J),J=1,19)/ + &' *......* ', + &' *:::!!:::::::::::* ', + &' *::::::!!::::::::::::::* ', + &' *::::::::!!::::::::::::::::* ', + &' *:::::::::!!:::::::::::::::::* ', + &' *:::::::::!!:::::::::::::::::* ', + &' *::::::::!!::::::::::::::::*! ', + &' *::::::!!::::::::::::::* !! ', + &' !! *:::!!:::::::::::* !! ', + &' !! !* -><- * !! ', + &' !! !! !! ', + &' !! !! !! ', + &' !! !! ', + &' !! lh !! ', + &' !! !! ', + &' !! hh !! ', + &' !! ll !! ', + &' !! !! ', + &' !! '/ + DATA (LOGO(J),J=20,38)/ + &'Welcome to the Lund Monte Carlo!', + &' ', + &'PPP Y Y TTTTT H H III A ', + &'P P Y Y T H H I A A ', + &'PPP Y T HHHHH I AAAAA', + &'P Y T H H I A A', + &'P Y T H H III A A', + &' ', + &'This is PYTHIA version x.xxx ', + &'Last date of change: xx xxx 201x', + &' ', + &'Now is xx xxx 201x at xx:xx:xx ', + &' ', + &'Disclaimer: this program comes ', + &'without any guarantees. Beware ', + &'of errors and use common sense ', + &'when interpreting results. ', + &' ', + &'Copyright T. Sjostrand (2011) '/ + DATA (REFER(J),J=1,14)/ + &'An archive of program versions and d', + &'ocumentation is found on the web: ', + &'http://www.thep.lu.se/~torbjorn/Pyth', + &'ia.html ', + &' ', + &' ', + &'When you cite this program, the offi', + &'cial reference is to the 6.4 manual:', + &'T. Sjostrand, S. Mrenna and P. Skand', + &'s, JHEP05 (2006) 026 ', + &'(LU TP 06-13, FERMILAB-PUB-06-052-CD', + &'-T) [hep-ph/0603175]. ', + &' ', + &' '/ + DATA (REFER(J),J=15,32)/ + &'Also remember that the program, to a', + &' large extent, represents original ', + &'physics research. Other publications', + &' of special relevance to your ', + &'studies may therefore deserve separa', + &'te mention. ', + &' ', + &' ', + &'Main author: Torbjorn Sjostrand; Dep', + &'artment of Theoretical Physics, ', + &' Lund University, Solvegatan 14A, S', + &'-223 62 Lund, Sweden; ', + &' phone: + 46 - 46 - 222 48 16; e-ma', + &'il: torbjorn@thep.lu.se ', + &'Author: Stephen Mrenna; Computing Di', + &'vision, GDS Group, ', + &' Fermi National Accelerator Laborat', + &'ory, MS 234, Batavia, IL 60510, USA;'/ + DATA (REFER(J),J=33,2*IREFER)/ + &' phone: + 1 - 630 - 840 - 2556; e-m', + &'ail: mrenna@fnal.gov ', + &'Author: Peter Skands; CERN/PH-TH, CH', + &'-1211 Geneva, Switzerland ', + &' phone: + 41 - 22 - 767 24 47; e-ma', + &'il: peter.skands@cern.ch '/ + +C...Check that PYDATA linked (check we are in the year 20xx) + IF(MSTP(183)/100.NE.20) THEN + WRITE(*,'(1X,A)') + & 'Error: PYDATA has not been linked.' + WRITE(*,'(1X,A)') 'Execution stopped!' + CALL PYSTOP(8) + +C...Write current version number and current date+time. + ELSE + WRITE(VERS,'(I1)') MSTP(181) + LOGO(28)(24:24)=VERS + WRITE(SUBV,'(I3)') MSTP(182) + LOGO(28)(26:28)=SUBV + IF(MSTP(182).LT.100) LOGO(28)(26:26)='0' + WRITE(DATE,'(I2)') MSTP(185) + LOGO(29)(22:23)=DATE + LOGO(29)(25:27)=MONTH(MSTP(184)) + WRITE(YEAR,'(I4)') MSTP(183) + LOGO(29)(29:32)=YEAR + CALL PYTIME(IDATI) + IF(IDATI(1).LE.0) THEN + LOGO(31)=' ' + ELSE + WRITE(DATE,'(I2)') IDATI(3) + LOGO(31)(8:9)=DATE + LOGO(31)(11:13)=MONTH(MAX(1,MIN(12,IDATI(2)))) + WRITE(YEAR,'(I4)') IDATI(1) + LOGO(31)(15:18)=YEAR + WRITE(HOUR,'(I2)') IDATI(4) + LOGO(31)(23:24)=HOUR + WRITE(MINU,'(I2)') IDATI(5) + LOGO(31)(26:27)=MINU + IF(IDATI(5).LT.10) LOGO(31)(26:26)='0' + WRITE(SECO,'(I2)') IDATI(6) + LOGO(31)(29:30)=SECO + IF(IDATI(6).LT.10) LOGO(31)(29:29)='0' + ENDIF + ENDIF + + + WRITE(MSTU(11),'(A79)') + &'+++++++++++++++++++++++++++++++++++++++++++++++++'// + &'+++++++++++++++++++++++++++++' + WRITE(MSTU(11),'(A79)') + &'++ This is a modified version of PYTHIA that may'// + & ' only be used with JEWEL. ++' + WRITE(MSTU(11),'(A79)') + &'+++++++++++++++++++++++++++++++++++++++++++++++++'// + &'+++++++++++++++++++++++++++++' + +C...Loop over lines in header. Define page feed and side borders. + DO 100 ILIN=1,29+IREFER + LINE=' ' + IF(ILIN.EQ.1) THEN + LINE(1:1)='1' + ELSE + LINE(2:3)='**' + LINE(78:79)='**' + ENDIF + +C...Separator lines and logos. + IF(ILIN.EQ.2.OR.ILIN.EQ.3.OR.ILIN.GE.28+IREFER) THEN + LINE(4:77)='***********************************************'// + & '***************************' + ELSEIF(ILIN.GE.6.AND.ILIN.LE.24) THEN + LINE(6:37)=LOGO(ILIN-5) + LINE(44:75)=LOGO(ILIN+14) + ELSEIF(ILIN.GE.26.AND.ILIN.LE.25+IREFER) THEN + LINE(5:40)=REFER(2*ILIN-51) + LINE(41:76)=REFER(2*ILIN-50) + ENDIF + +C...Write lines to appropriate unit. + WRITE(MSTU(11),'(A79)') LINE + 100 CONTINUE + + RETURN + END + +C********************************************************************* + +C...PYUPDA +C...Facilitates the updating of particle and decay data +C...by allowing it to be done in an external file. + + SUBROUTINE PYUPDA(MUPDA,LFN) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + COMMON/PYDAT4/CHAF(500,2) + CHARACTER CHAF*16 + COMMON/PYINT4/MWID(500),WIDS(500,5) + SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYINT4/ +C...Local arrays, character variables and data. + CHARACTER CHINL*120,CHKF*9,CHVAR(22)*9,CHLIN*72, + &CHBLK(20)*72,CHOLD*16,CHTMP*16,CHNEW*16,CHCOM*24 + DATA CHVAR/ 'KCHG(I,1)','KCHG(I,2)','KCHG(I,3)','KCHG(I,4)', + &'PMAS(I,1)','PMAS(I,2)','PMAS(I,3)','PMAS(I,4)','MDCY(I,1)', + &'MDCY(I,2)','MDCY(I,3)','MDME(I,1)','MDME(I,2)','BRAT(I) ', + &'KFDP(I,1)','KFDP(I,2)','KFDP(I,3)','KFDP(I,4)','KFDP(I,5)', + &'CHAF(I,1)','CHAF(I,2)','MWID(I) '/ + +C...Write header if not yet done. + IF(MSTU(12).NE.12345) CALL PYLIST(0) + +C...Write information on file for editing. + IF(MUPDA.EQ.1) THEN + DO 110 KC=1,500 + WRITE(LFN,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2), + & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4), + & MWID(KC),MDCY(KC,1) + DO 100 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1 + WRITE(LFN,5100) MDME(IDC,1),MDME(IDC,2),BRAT(IDC), + & (KFDP(IDC,J),J=1,5) + 100 CONTINUE + 110 CONTINUE + +C...Read complete set of information from edited file or +C...read partial set of new or updated information from edited file. + ELSEIF(MUPDA.EQ.2.OR.MUPDA.EQ.3) THEN + +C...Reset counters. + KCC=100 + NDC=0 + CHKF=' ' + IF(MUPDA.EQ.2) THEN + DO 120 I=1,MSTU(6) + KCHG(I,4)=0 + 120 CONTINUE + ELSE + DO 130 KC=1,MSTU(6) + IF(KC.GT.100.AND.KCHG(KC,4).GT.100) KCC=KC + NDC=MAX(NDC,MDCY(KC,2)+MDCY(KC,3)-1) + 130 CONTINUE + ENDIF + +C...Begin of loop: read new line; unknown whether particle or +C...decay data. + 140 READ(LFN,5200,END=190) CHINL + +C...Identify particle code and whether already defined (for MUPDA=3). + IF(CHINL(2:10).NE.' ') THEN + CHKF=CHINL(2:10) + READ(CHKF,5300) KF + IF(MUPDA.EQ.2) THEN + IF(KF.LE.100) THEN + KC=KF + ELSE + KCC=KCC+1 + KC=KCC + ENDIF + ELSE + KCREP=0 + IF(KF.LE.100) THEN + KCREP=KF + ELSE + DO 150 KCR=101,KCC + IF(KCHG(KCR,4).EQ.KF) KCREP=KCR + 150 CONTINUE + ENDIF +C...Remove duplicate old decay data. + IF(KCREP.NE.0.AND.MDCY(KCREP,3).GT.0) THEN + IDCREP=MDCY(KCREP,2) + NDCREP=MDCY(KCREP,3) + DO 160 I=1,KCC + IF(MDCY(I,2).GT.IDCREP) MDCY(I,2)=MDCY(I,2)-NDCREP + 160 CONTINUE + DO 180 I=IDCREP,NDC-NDCREP + MDME(I,1)=MDME(I+NDCREP,1) + MDME(I,2)=MDME(I+NDCREP,2) + BRAT(I)=BRAT(I+NDCREP) + DO 170 J=1,5 + KFDP(I,J)=KFDP(I+NDCREP,J) + 170 CONTINUE + 180 CONTINUE + NDC=NDC-NDCREP + KC=KCREP + ELSEIF(KCREP.NE.0) THEN + KC=KCREP + ELSE + KCC=KCC+1 + KC=KCC + ENDIF + ENDIF + +C...Study line with particle data. + IF(KC.GT.MSTU(6)) CALL PYERRM(27, + & '(PYUPDA:) Particle arrays full by KF ='//CHKF) + READ(CHINL,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2), + & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4), + & MWID(KC),MDCY(KC,1) + MDCY(KC,2)=0 + MDCY(KC,3)=0 + +C...Study line with decay data. + ELSE + NDC=NDC+1 + IF(NDC.GT.MSTU(7)) CALL PYERRM(27, + & '(PYUPDA:) Decay data arrays full by KF ='//CHKF) + IF(MDCY(KC,2).EQ.0) MDCY(KC,2)=NDC + MDCY(KC,3)=MDCY(KC,3)+1 + READ(CHINL,5100) MDME(NDC,1),MDME(NDC,2),BRAT(NDC), + & (KFDP(NDC,J),J=1,5) + ENDIF + +C...End of loop; ensure that PYCOMP tables are updated. + GOTO 140 + 190 CONTINUE + MSTU(20)=0 + +C...Perform possible tests that new information is consistent. + DO 220 KC=1,MSTU(6) + KF=KCHG(KC,4) + IF(KF.EQ.0) GOTO 220 + WRITE(CHKF,5300) KF + IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3), + & PMAS(KC,4)).LT.0D0.OR.MDCY(KC,3).LT.0) CALL PYERRM(17, + & '(PYUPDA:) Mass/width/life/(# channels) wrong for KF ='//CHKF) + BRSUM=0D0 + DO 210 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1 + IF(MDME(IDC,2).GT.80) GOTO 210 + KQ=KCHG(KC,1) + PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64) + MERR=0 + DO 200 J=1,5 + KP=KFDP(IDC,J) + IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN + IF(KP.EQ.81) KQ=0 + ELSEIF(PYCOMP(KP).EQ.0) THEN + MERR=3 + ELSE + KQ=KQ-PYCHGE(KP) + KPC=PYCOMP(KP) + PMS=PMS-PMAS(KPC,1) + IF(MSTJ(24).GT.0) PMS=PMS+0.5D0*MIN(PMAS(KPC,2), + & PMAS(KPC,3)) + ENDIF + 200 CONTINUE + IF(KQ.NE.0) MERR=MAX(2,MERR) + IF(MWID(KC).EQ.0.AND.KF.NE.311.AND.PMS.LT.0D0) + & MERR=MAX(1,MERR) + IF(MERR.EQ.3) CALL PYERRM(17, + & '(PYUPDA:) Unknown particle code in decay of KF ='//CHKF) + IF(MERR.EQ.2) CALL PYERRM(17, + & '(PYUPDA:) Charge not conserved in decay of KF ='//CHKF) + IF(MERR.EQ.1) CALL PYERRM(7, + & '(PYUPDA:) Kinematically unallowed decay of KF ='//CHKF) + BRSUM=BRSUM+BRAT(IDC) + 210 CONTINUE + WRITE(CHTMP,5500) BRSUM + IF(ABS(BRSUM).GT.0.0005D0.AND.ABS(BRSUM-1D0).GT.0.0005D0) + & CALL PYERRM(7,'(PYUPDA:) Sum of branching ratios is '// + & CHTMP(9:16)//' for KF ='//CHKF) + 220 CONTINUE + +C...Write DATA statements for inclusion in program. + ELSEIF(MUPDA.EQ.4) THEN + +C...Find out how many codes and decay channels are actually used. + KCC=0 + NDC=0 + DO 230 I=1,MSTU(6) + IF(KCHG(I,4).NE.0) THEN + KCC=I + NDC=MAX(NDC,MDCY(I,2)+MDCY(I,3)-1) + ENDIF + 230 CONTINUE + +C...Initialize writing of DATA statements for inclusion in program. + DO 300 IVAR=1,22 + NDIM=MSTU(6) + IF(IVAR.GE.12.AND.IVAR.LE.19) NDIM=MSTU(7) + NLIN=1 + CHLIN=' ' + CHLIN(7:35)='DATA ('//CHVAR(IVAR)//',I= 1, )/' + LLIN=35 + CHOLD='START' + +C...Loop through variables for conversion to characters. + DO 280 IDIM=1,NDIM + IF(IVAR.EQ.1) WRITE(CHTMP,5400) KCHG(IDIM,1) + IF(IVAR.EQ.2) WRITE(CHTMP,5400) KCHG(IDIM,2) + IF(IVAR.EQ.3) WRITE(CHTMP,5400) KCHG(IDIM,3) + IF(IVAR.EQ.4) WRITE(CHTMP,5400) KCHG(IDIM,4) + IF(IVAR.EQ.5) WRITE(CHTMP,5500) PMAS(IDIM,1) + IF(IVAR.EQ.6) WRITE(CHTMP,5500) PMAS(IDIM,2) + IF(IVAR.EQ.7) WRITE(CHTMP,5500) PMAS(IDIM,3) + IF(IVAR.EQ.8) WRITE(CHTMP,5500) PMAS(IDIM,4) + IF(IVAR.EQ.9) WRITE(CHTMP,5400) MDCY(IDIM,1) + IF(IVAR.EQ.10) WRITE(CHTMP,5400) MDCY(IDIM,2) + IF(IVAR.EQ.11) WRITE(CHTMP,5400) MDCY(IDIM,3) + IF(IVAR.EQ.12) WRITE(CHTMP,5400) MDME(IDIM,1) + IF(IVAR.EQ.13) WRITE(CHTMP,5400) MDME(IDIM,2) + IF(IVAR.EQ.14) WRITE(CHTMP,5600) BRAT(IDIM) + IF(IVAR.EQ.15) WRITE(CHTMP,5400) KFDP(IDIM,1) + IF(IVAR.EQ.16) WRITE(CHTMP,5400) KFDP(IDIM,2) + IF(IVAR.EQ.17) WRITE(CHTMP,5400) KFDP(IDIM,3) + IF(IVAR.EQ.18) WRITE(CHTMP,5400) KFDP(IDIM,4) + IF(IVAR.EQ.19) WRITE(CHTMP,5400) KFDP(IDIM,5) + IF(IVAR.EQ.20) CHTMP=CHAF(IDIM,1) + IF(IVAR.EQ.21) CHTMP=CHAF(IDIM,2) + IF(IVAR.EQ.22) WRITE(CHTMP,5400) MWID(IDIM) + +C...Replace variables beyond what is properly defined. + IF(IVAR.LE.4) THEN + IF(IDIM.GT.KCC) CHTMP=' 0' + ELSEIF(IVAR.LE.8) THEN + IF(IDIM.GT.KCC) CHTMP=' 0.0' + ELSEIF(IVAR.LE.11) THEN + IF(IDIM.GT.KCC) CHTMP=' 0' + ELSEIF(IVAR.LE.13) THEN + IF(IDIM.GT.NDC) CHTMP=' 0' + ELSEIF(IVAR.LE.14) THEN + IF(IDIM.GT.NDC) CHTMP=' 0.0' + ELSEIF(IVAR.LE.19) THEN + IF(IDIM.GT.NDC) CHTMP=' 0' + ELSEIF(IVAR.LE.21) THEN + IF(IDIM.GT.KCC) CHTMP=' ' + ELSE + IF(IDIM.GT.KCC) CHTMP=' 0' + ENDIF + +C...Length of variable, trailing decimal zeros, quotation marks. + LLOW=1 + LHIG=1 + DO 240 LL=1,16 + IF(CHTMP(17-LL:17-LL).NE.' ') LLOW=17-LL + IF(CHTMP(LL:LL).NE.' ') LHIG=LL + 240 CONTINUE + CHNEW=CHTMP(LLOW:LHIG)//' ' + LNEW=1+LHIG-LLOW + IF((IVAR.GE.5.AND.IVAR.LE.8).OR.IVAR.EQ.14) THEN + LNEW=LNEW+1 + 250 LNEW=LNEW-1 + IF(LNEW.GE.2.AND.CHNEW(LNEW:LNEW).EQ.'0') GOTO 250 + IF(CHNEW(LNEW:LNEW).EQ.'.') LNEW=LNEW-1 + IF(LNEW.EQ.0) THEN + CHNEW(1:3)='0D0' + LNEW=3 + ELSE + CHNEW(LNEW+1:LNEW+2)='D0' + LNEW=LNEW+2 + ENDIF + ELSEIF(IVAR.EQ.20.OR.IVAR.EQ.21) THEN + DO 260 LL=LNEW,1,-1 + IF(CHNEW(LL:LL).EQ.'''') THEN + CHTMP=CHNEW + CHNEW=CHTMP(1:LL)//''''//CHTMP(LL+1:11) + LNEW=LNEW+1 + ENDIF + 260 CONTINUE + LNEW=MIN(14,LNEW) + CHTMP=CHNEW + CHNEW(1:LNEW+2)=''''//CHTMP(1:LNEW)//'''' + LNEW=LNEW+2 + ENDIF + +C...Form composite character string, often including repetition counter. + IF(CHNEW.NE.CHOLD) THEN + NRPT=1 + CHOLD=CHNEW + CHCOM=CHNEW + LCOM=LNEW + ELSE + LRPT=LNEW+1 + IF(NRPT.GE.2) LRPT=LNEW+3 + IF(NRPT.GE.10) LRPT=LNEW+4 + IF(NRPT.GE.100) LRPT=LNEW+5 + IF(NRPT.GE.1000) LRPT=LNEW+6 + LLIN=LLIN-LRPT + NRPT=NRPT+1 + WRITE(CHTMP,5400) NRPT + LRPT=1 + IF(NRPT.GE.10) LRPT=2 + IF(NRPT.GE.100) LRPT=3 + IF(NRPT.GE.1000) LRPT=4 + CHCOM(1:LRPT+1+LNEW)=CHTMP(17-LRPT:16)//'*'//CHNEW(1:LNEW) + LCOM=LRPT+1+LNEW + ENDIF + +C...Add characters to end of line, to new line (after storing old line), +C...or to new block of lines (after writing old block). + IF(LLIN+LCOM.LE.70) THEN + CHLIN(LLIN+1:LLIN+LCOM+1)=CHCOM(1:LCOM)//',' + LLIN=LLIN+LCOM+1 + ELSEIF(NLIN.LE.19) THEN + CHLIN(LLIN+1:72)=' ' + CHBLK(NLIN)=CHLIN + NLIN=NLIN+1 + CHLIN(6:6+LCOM+1)='&'//CHCOM(1:LCOM)//',' + LLIN=6+LCOM+1 + ELSE + CHLIN(LLIN:72)='/'//' ' + CHBLK(NLIN)=CHLIN + WRITE(CHTMP,5400) IDIM-NRPT + CHBLK(1)(30:33)=CHTMP(13:16) + DO 270 ILIN=1,NLIN + WRITE(LFN,5700) CHBLK(ILIN) + 270 CONTINUE + NLIN=1 + CHLIN=' ' + CHLIN(7:35+LCOM+1)='DATA ('//CHVAR(IVAR)// + & ',I= , )/'//CHCOM(1:LCOM)//',' + WRITE(CHTMP,5400) IDIM-NRPT+1 + CHLIN(25:28)=CHTMP(13:16) + LLIN=35+LCOM+1 + ENDIF + 280 CONTINUE + +C...Write final block of lines. + CHLIN(LLIN:72)='/'//' ' + CHBLK(NLIN)=CHLIN + WRITE(CHTMP,5400) NDIM + CHBLK(1)(30:33)=CHTMP(13:16) + DO 290 ILIN=1,NLIN + WRITE(LFN,5700) CHBLK(ILIN) + 290 CONTINUE + 300 CONTINUE + ENDIF + +C...Formats for reading and writing particle data. + 5000 FORMAT(1X,I9,2X,A16,2X,A16,3I3,3F12.5,1P,E13.5,2I3) + 5100 FORMAT(10X,2I5,F12.6,5I10) + 5200 FORMAT(A120) + 5300 FORMAT(I9) + 5400 FORMAT(I16) + 5500 FORMAT(F16.5) + 5600 FORMAT(F16.6) + 5700 FORMAT(A72) + + RETURN + END + +C********************************************************************* + +C...PYK +C...Provides various integer-valued event related data. + + FUNCTION PYK(I,J) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ + +C...Default value. For I=0 number of entries, number of stable entries +C...or 3 times total charge. + PYK=0 + IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN + ELSEIF(I.EQ.0.AND.J.EQ.1) THEN + PYK=N + ELSEIF(I.EQ.0.AND.(J.EQ.2.OR.J.EQ.6)) THEN + DO 100 I1=1,N + IF(J.EQ.2.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+1 + IF(J.EQ.6.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+ + & PYCHGE(K(I1,2)) + 100 CONTINUE + ELSEIF(I.EQ.0) THEN + +C...For I > 0 direct readout of K matrix or charge. + ELSEIF(J.LE.5) THEN + PYK=K(I,J) + ELSEIF(J.EQ.6) THEN + PYK=PYCHGE(K(I,2)) + +C...Status (existing/fragmented/decayed), parton/hadron separation. + ELSEIF(J.LE.8) THEN + IF(K(I,1).GE.1.AND.K(I,1).LE.10) PYK=1 + IF(J.EQ.8) PYK=PYK*K(I,2) + ELSEIF(J.LE.12) THEN + KFA=IABS(K(I,2)) + KC=PYCOMP(KFA) + KQ=0 + IF(KC.NE.0) KQ=KCHG(KC,2) + IF(J.EQ.9.AND.KC.NE.0.AND.KQ.NE.0) PYK=K(I,2) + IF(J.EQ.10.AND.KC.NE.0.AND.KQ.EQ.0) PYK=K(I,2) + IF(J.EQ.11) PYK=KC + IF(J.EQ.12) PYK=KQ*ISIGN(1,K(I,2)) + +C...Heaviest flavour in hadron/diquark. + ELSEIF(J.EQ.13) THEN + KFA=IABS(K(I,2)) + PYK=MOD(KFA/100,10)*(-1)**MOD(KFA/100,10) + IF(KFA.LT.10) PYK=KFA + IF(MOD(KFA/1000,10).NE.0) PYK=MOD(KFA/1000,10) + PYK=PYK*ISIGN(1,K(I,2)) + +C...Particle history: generation, ancestor, rank. + ELSEIF(J.LE.15) THEN + I2=I + I1=I + 110 PYK=PYK+1 + I2=I1 + I1=K(I1,3) + IF(I1.GT.0) THEN + IF(K(I1,1).GT.0.AND.K(I1,1).LE.20) GOTO 110 + ENDIF + IF(J.EQ.15) PYK=I2 + ELSEIF(J.EQ.16) THEN + KFA=IABS(K(I,2)) + IF(K(I,1).LE.20.AND.((KFA.GE.11.AND.KFA.LE.20).OR.KFA.EQ.22.OR. + & (KFA.GT.100.AND.MOD(KFA/10,10).NE.0))) THEN + I1=I + 120 I2=I1 + I1=K(I1,3) + IF(I1.GT.0) THEN + KFAM=IABS(K(I1,2)) + ILP=1 + IF(KFAM.NE.0.AND.KFAM.LE.10) ILP=0 + IF(KFAM.EQ.21.OR.KFAM.EQ.91.OR.KFAM.EQ.92.OR.KFAM.EQ.93) + & ILP=0 + IF(KFAM.GT.100.AND.MOD(KFAM/10,10).EQ.0) ILP=0 + IF(ILP.EQ.1) GOTO 120 + ENDIF + IF(K(I1,1).EQ.12) THEN + DO 130 I3=I1+1,I2 + IF(K(I3,3).EQ.K(I2,3).AND.K(I3,2).NE.91.AND.K(I3,2).NE.92 + & .AND.K(I3,2).NE.93) PYK=PYK+1 + 130 CONTINUE + ELSE + I3=I2 + 140 PYK=PYK+1 + I3=I3+1 + IF(I3.LT.N.AND.K(I3,3).EQ.K(I2,3)) GOTO 140 + ENDIF + ENDIF + +C...Particle coming from collapsing jet system or not. + ELSEIF(J.EQ.17) THEN + I1=I + 150 PYK=PYK+1 + I3=I1 + I1=K(I1,3) + I0=MAX(1,I1) + KC=PYCOMP(K(I0,2)) + IF(I1.EQ.0.OR.K(I0,1).LE.0.OR.K(I0,1).GT.20.OR.KC.EQ.0) THEN + IF(PYK.EQ.1) PYK=-1 + IF(PYK.GT.1) PYK=0 + RETURN + ENDIF + IF(KCHG(KC,2).EQ.0) GOTO 150 + IF(K(I1,1).NE.12) PYK=0 + IF(K(I1,1).NE.12) RETURN + I2=I1 + 160 I2=I2+1 + IF(I2.LT.N.AND.K(I2,1).NE.11) GOTO 160 + K3M=K(I3-1,3) + IF(K3M.GE.I1.AND.K3M.LE.I2) PYK=0 + K3P=K(I3+1,3) + IF(I3.LT.N.AND.K3P.GE.I1.AND.K3P.LE.I2) PYK=0 + +C...Number of decay products. Colour flow. + ELSEIF(J.EQ.18) THEN + IF(K(I,1).EQ.11.OR.K(I,1).EQ.12) PYK=MAX(0,K(I,5)-K(I,4)+1) + IF(K(I,4).EQ.0.OR.K(I,5).EQ.0) PYK=0 + ELSEIF(J.LE.22) THEN + IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) RETURN + IF(J.EQ.19) PYK=MOD(K(I,4)/MSTU(5),MSTU(5)) + IF(J.EQ.20) PYK=MOD(K(I,5)/MSTU(5),MSTU(5)) + IF(J.EQ.21) PYK=MOD(K(I,4),MSTU(5)) + IF(J.EQ.22) PYK=MOD(K(I,5),MSTU(5)) + ELSE + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYP +C...Provides various real-valued event related data. + + FUNCTION PYP(I,J) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ +C...Local array. + DIMENSION PSUM(4) + +C...Set default value. For I = 0 sum of momenta or charges, +C...or invariant mass of system. + PYP=0D0 + IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN + ELSEIF(I.EQ.0.AND.J.LE.4) THEN + DO 100 I1=1,N + IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+P(I1,J) + 100 CONTINUE + ELSEIF(I.EQ.0.AND.J.EQ.5) THEN + DO 120 J1=1,4 + PSUM(J1)=0D0 + DO 110 I1=1,N + IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PSUM(J1)=PSUM(J1)+ + & P(I1,J1) + 110 CONTINUE + 120 CONTINUE + PYP=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2)) + ELSEIF(I.EQ.0.AND.J.EQ.6) THEN + DO 130 I1=1,N + IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+PYCHGE(K(I1,2))/3D0 + 130 CONTINUE + ELSEIF(I.EQ.0) THEN + +C...Direct readout of P matrix. + ELSEIF(J.LE.5) THEN + PYP=P(I,J) + +C...Charge, total momentum, transverse momentum, transverse mass. + ELSEIF(J.LE.12) THEN + IF(J.EQ.6) PYP=PYCHGE(K(I,2))/3D0 + IF(J.EQ.7.OR.J.EQ.8) PYP=P(I,1)**2+P(I,2)**2+P(I,3)**2 + IF(J.EQ.9.OR.J.EQ.10) PYP=P(I,1)**2+P(I,2)**2 + IF(J.EQ.11.OR.J.EQ.12) PYP=P(I,5)**2+P(I,1)**2+P(I,2)**2 + IF(J.EQ.8.OR.J.EQ.10.OR.J.EQ.12) PYP=SQRT(PYP) + +C...Theta and phi angle in radians or degrees. + ELSEIF(J.LE.16) THEN + IF(J.LE.14) PYP=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2)) + IF(J.GE.15) PYP=PYANGL(P(I,1),P(I,2)) + IF(J.EQ.14.OR.J.EQ.16) PYP=PYP*180D0/PARU(1) + +C...True rapidity, rapidity with pion mass, pseudorapidity. + ELSEIF(J.LE.19) THEN + PMR=0D0 + IF(J.EQ.17) PMR=P(I,5) + IF(J.EQ.18) PMR=PYMASS(211) + PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2) + PYP=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR), + & 1D20)),P(I,3)) + +C...Energy and momentum fractions (only to be used in CM frame). + ELSEIF(J.LE.25) THEN + IF(J.EQ.20) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)/PARU(21) + IF(J.EQ.21) PYP=2D0*P(I,3)/PARU(21) + IF(J.EQ.22) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2)/PARU(21) + IF(J.EQ.23) PYP=2D0*P(I,4)/PARU(21) + IF(J.EQ.24) PYP=(P(I,4)+P(I,3))/PARU(21) + IF(J.EQ.25) PYP=(P(I,4)-P(I,3))/PARU(21) + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYSPHE +C...Performs sphericity tensor analysis to give sphericity, +C...aplanarity and the related event axes. + + SUBROUTINE PYSPHE(SPH,APL) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ +C...Local arrays. + DIMENSION SM(3,3),SV(3,3) + +C...Calculate matrix to be diagonalized. + NP=0 + DO 110 J1=1,3 + DO 100 J2=J1,3 + SM(J1,J2)=0D0 + 100 CONTINUE + 110 CONTINUE + PS=0D0 + DO 140 I=1,N + IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140 + IF(MSTU(41).GE.2) THEN + KC=PYCOMP(K(I,2)) + IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR. + & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR. + & K(I,2).EQ.KSUSY1+39) GOTO 140 + IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0) + & GOTO 140 + ENDIF + NP=NP+1 + PA=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2) + PWT=1D0 + IF(ABS(PARU(41)-2D0).GT.0.001D0) PWT= + & MAX(1D-10,PA)**(PARU(41)-2D0) + DO 130 J1=1,3 + DO 120 J2=J1,3 + SM(J1,J2)=SM(J1,J2)+PWT*P(I,J1)*P(I,J2) + 120 CONTINUE + 130 CONTINUE + PS=PS+PWT*PA**2 + 140 CONTINUE + +C...Very low multiplicities (0 or 1) not considered. + IF(NP.LE.1) THEN + CALL PYERRM(8,'(PYSPHE:) too few particles for analysis') + SPH=-1D0 + APL=-1D0 + RETURN + ENDIF + DO 160 J1=1,3 + DO 150 J2=J1,3 + SM(J1,J2)=SM(J1,J2)/PS + 150 CONTINUE + 160 CONTINUE + +C...Find eigenvalues to matrix (third degree equation). + SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)- + &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0 + SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+ + &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+ + &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0 + SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0) + P(N+1,4)=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP) + P(N+3,4)=1D0/3D0+SQRT(-SQ)*MIN(2D0*SP,-SQRT(3D0*(1D0-SP**2))-SP) + P(N+2,4)=1D0-P(N+1,4)-P(N+3,4) + IF(P(N+2,4).LT.1D-5) THEN + CALL PYERRM(8,'(PYSPHE:) all particles back-to-back') + SPH=-1D0 + APL=-1D0 + RETURN + ENDIF + +C...Find first and last eigenvector by solving equation system. + DO 240 I=1,3,2 + DO 180 J1=1,3 + SV(J1,J1)=SM(J1,J1)-P(N+I,4) + DO 170 J2=J1+1,3 + SV(J1,J2)=SM(J1,J2) + SV(J2,J1)=SM(J1,J2) + 170 CONTINUE + 180 CONTINUE + SMAX=0D0 + DO 200 J1=1,3 + DO 190 J2=1,3 + IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 190 + JA=J1 + JB=J2 + SMAX=ABS(SV(J1,J2)) + 190 CONTINUE + 200 CONTINUE + SMAX=0D0 + DO 220 J3=JA+1,JA+2 + J1=J3-3*((J3-1)/3) + RL=SV(J1,JB)/SV(JA,JB) + DO 210 J2=1,3 + SV(J1,J2)=SV(J1,J2)-RL*SV(JA,J2) + IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 210 + JC=J1 + SMAX=ABS(SV(J1,J2)) + 210 CONTINUE + 220 CONTINUE + JB1=JB+1-3*(JB/3) + JB2=JB+2-3*((JB+1)/3) + P(N+I,JB1)=-SV(JC,JB2) + P(N+I,JB2)=SV(JC,JB1) + P(N+I,JB)=-(SV(JA,JB1)*P(N+I,JB1)+SV(JA,JB2)*P(N+I,JB2))/ + & SV(JA,JB) + PA=SQRT(P(N+I,1)**2+P(N+I,2)**2+P(N+I,3)**2) + SGN=(-1D0)**INT(PYR(0)+0.5D0) + DO 230 J=1,3 + P(N+I,J)=SGN*P(N+I,J)/PA + 230 CONTINUE + 240 CONTINUE + +C...Middle axis orthogonal to other two. Fill other codes. + SGN=(-1D0)**INT(PYR(0)+0.5D0) + P(N+2,1)=SGN*(P(N+1,2)*P(N+3,3)-P(N+1,3)*P(N+3,2)) + P(N+2,2)=SGN*(P(N+1,3)*P(N+3,1)-P(N+1,1)*P(N+3,3)) + P(N+2,3)=SGN*(P(N+1,1)*P(N+3,2)-P(N+1,2)*P(N+3,1)) + DO 260 I=1,3 + K(N+I,1)=31 + K(N+I,2)=95 + K(N+I,3)=I + K(N+I,4)=0 + K(N+I,5)=0 + P(N+I,5)=0D0 + DO 250 J=1,5 + V(I,J)=0D0 + 250 CONTINUE + 260 CONTINUE + +C...Calculate sphericity and aplanarity. Select storing option. + SPH=1.5D0*(P(N+2,4)+P(N+3,4)) + APL=1.5D0*P(N+3,4) + MSTU(61)=N+1 + MSTU(62)=NP + IF(MSTU(43).LE.1) MSTU(3)=3 + IF(MSTU(43).GE.2) N=N+3 + + RETURN + END + +C********************************************************************* + +C...PYTHRU +C...Performs thrust analysis to give thrust, oblateness +C...and the related event axes. + + SUBROUTINE PYTHRU(THR,OBL) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ +C...Local arrays. + DIMENSION TDI(3),TPR(3) + +C...Take copy of particles that are to be considered in thrust analysis. + NP=0 + PS=0D0 + DO 100 I=1,N + IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100 + IF(MSTU(41).GE.2) THEN + KC=PYCOMP(K(I,2)) + IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR. + & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR. + & K(I,2).EQ.KSUSY1+39) GOTO 100 + IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0) + & GOTO 100 + ENDIF + IF(N+NP+MSTU(44)+15.GE.MSTU(4)-MSTU(32)-5) THEN + CALL PYERRM(11,'(PYTHRU:) no more memory left in PYJETS') + THR=-2D0 + OBL=-2D0 + RETURN + ENDIF + NP=NP+1 + K(N+NP,1)=23 + P(N+NP,1)=P(I,1) + P(N+NP,2)=P(I,2) + P(N+NP,3)=P(I,3) + P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2) + P(N+NP,5)=1D0 + IF(ABS(PARU(42)-1D0).GT.0.001D0) P(N+NP,5)= + & P(N+NP,4)**(PARU(42)-1D0) + PS=PS+P(N+NP,4)*P(N+NP,5) + 100 CONTINUE + +C...Very low multiplicities (0 or 1) not considered. + IF(NP.LE.1) THEN + CALL PYERRM(8,'(PYTHRU:) too few particles for analysis') + THR=-1D0 + OBL=-1D0 + RETURN + ENDIF + +C...Loop over thrust and major. T axis along z direction in latter case. + DO 320 ILD=1,2 + IF(ILD.EQ.2) THEN + K(N+NP+1,1)=31 + PHI=PYANGL(P(N+NP+1,1),P(N+NP+1,2)) + MSTU(33)=1 + CALL PYROBO(N+1,N+NP+1,0D0,-PHI,0D0,0D0,0D0) + THE=PYANGL(P(N+NP+1,3),P(N+NP+1,1)) + CALL PYROBO(N+1,N+NP+1,-THE,0D0,0D0,0D0,0D0) + ENDIF + +C...Find and order particles with highest p (pT for major). + DO 110 ILF=N+NP+4,N+NP+MSTU(44)+4 + P(ILF,4)=0D0 + 110 CONTINUE + DO 160 I=N+1,N+NP + IF(ILD.EQ.2) P(I,4)=SQRT(P(I,1)**2+P(I,2)**2) + DO 130 ILF=N+NP+MSTU(44)+3,N+NP+4,-1 + IF(P(I,4).LE.P(ILF,4)) GOTO 140 + DO 120 J=1,5 + P(ILF+1,J)=P(ILF,J) + 120 CONTINUE + 130 CONTINUE + ILF=N+NP+3 + 140 DO 150 J=1,5 + P(ILF+1,J)=P(I,J) + 150 CONTINUE + 160 CONTINUE + +C...Find and order initial axes with highest thrust (major). + DO 170 ILG=N+NP+MSTU(44)+5,N+NP+MSTU(44)+15 + P(ILG,4)=0D0 + 170 CONTINUE + NC=2**(MIN(MSTU(44),NP)-1) + DO 250 ILC=1,NC + DO 180 J=1,3 + TDI(J)=0D0 + 180 CONTINUE + DO 200 ILF=1,MIN(MSTU(44),NP) + SGN=P(N+NP+ILF+3,5) + IF(2**ILF*((ILC+2**(ILF-1)-1)/2**ILF).GE.ILC) SGN=-SGN + DO 190 J=1,4-ILD + TDI(J)=TDI(J)+SGN*P(N+NP+ILF+3,J) + 190 CONTINUE + 200 CONTINUE + TDS=TDI(1)**2+TDI(2)**2+TDI(3)**2 + DO 220 ILG=N+NP+MSTU(44)+MIN(ILC,10)+4,N+NP+MSTU(44)+5,-1 + IF(TDS.LE.P(ILG,4)) GOTO 230 + DO 210 J=1,4 + P(ILG+1,J)=P(ILG,J) + 210 CONTINUE + 220 CONTINUE + ILG=N+NP+MSTU(44)+4 + 230 DO 240 J=1,3 + P(ILG+1,J)=TDI(J) + 240 CONTINUE + P(ILG+1,4)=TDS + 250 CONTINUE + +C...Iterate direction of axis until stable maximum. + P(N+NP+ILD,4)=0D0 + ILG=0 + 260 ILG=ILG+1 + THP=0D0 + 270 THPS=THP + DO 280 J=1,3 + IF(THP.LE.1D-10) TDI(J)=P(N+NP+MSTU(44)+4+ILG,J) + IF(THP.GT.1D-10) TDI(J)=TPR(J) + TPR(J)=0D0 + 280 CONTINUE + DO 300 I=N+1,N+NP + SGN=SIGN(P(I,5),TDI(1)*P(I,1)+TDI(2)*P(I,2)+TDI(3)*P(I,3)) + DO 290 J=1,4-ILD + TPR(J)=TPR(J)+SGN*P(I,J) + 290 CONTINUE + 300 CONTINUE + THP=SQRT(TPR(1)**2+TPR(2)**2+TPR(3)**2)/PS + IF(THP.GE.THPS+PARU(48)) GOTO 270 + +C...Save good axis. Try new initial axis until a number of tries agree. + IF(THP.LT.P(N+NP+ILD,4)-PARU(48).AND.ILG.LT.MIN(10,NC)) GOTO 260 + IF(THP.GT.P(N+NP+ILD,4)+PARU(48)) THEN + IAGR=0 + SGN=(-1D0)**INT(PYR(0)+0.5D0) + DO 310 J=1,3 + P(N+NP+ILD,J)=SGN*TPR(J)/(PS*THP) + 310 CONTINUE + P(N+NP+ILD,4)=THP + P(N+NP+ILD,5)=0D0 + ENDIF + IAGR=IAGR+1 + IF(IAGR.LT.MSTU(45).AND.ILG.LT.MIN(10,NC)) GOTO 260 + 320 CONTINUE + +C...Find minor axis and value by orthogonality. + SGN=(-1D0)**INT(PYR(0)+0.5D0) + P(N+NP+3,1)=-SGN*P(N+NP+2,2) + P(N+NP+3,2)=SGN*P(N+NP+2,1) + P(N+NP+3,3)=0D0 + THP=0D0 + DO 330 I=N+1,N+NP + THP=THP+P(I,5)*ABS(P(N+NP+3,1)*P(I,1)+P(N+NP+3,2)*P(I,2)) + 330 CONTINUE + P(N+NP+3,4)=THP/PS + P(N+NP+3,5)=0D0 + +C...Fill axis information. Rotate back to original coordinate system. + DO 350 ILD=1,3 + K(N+ILD,1)=31 + K(N+ILD,2)=96 + K(N+ILD,3)=ILD + K(N+ILD,4)=0 + K(N+ILD,5)=0 + DO 340 J=1,5 + P(N+ILD,J)=P(N+NP+ILD,J) + V(N+ILD,J)=0D0 + 340 CONTINUE + 350 CONTINUE + CALL PYROBO(N+1,N+3,THE,PHI,0D0,0D0,0D0) + +C...Calculate thrust and oblateness. Select storing option. + THR=P(N+1,4) + OBL=P(N+2,4)-P(N+3,4) + MSTU(61)=N+1 + MSTU(62)=NP + IF(MSTU(43).LE.1) MSTU(3)=3 + IF(MSTU(43).GE.2) N=N+3 + + RETURN + END + +C********************************************************************* + +C...PYCLUS +C...Subdivides the particle content of an event into jets/clusters. + + SUBROUTINE PYCLUS(NJET) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ +C...Local arrays and saved variables. + DIMENSION PS(5) + SAVE NSAV,NP,PS,PSS,RINIT,NPRE,NREM + +C...Functions: distance measure in pT, (pseudo)mass or Durham pT. + R2T(I1,I2)=(P(I1,5)*P(I2,5)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)- + &P(I1,3)*P(I2,3))*2D0*P(I1,5)*P(I2,5)/(0.0001D0+P(I1,5)+P(I2,5))**2 + R2M(I1,I2)=2D0*P(I1,4)*P(I2,4)*(1D0-(P(I1,1)*P(I2,1)+P(I1,2)* + &P(I2,2)+P(I1,3)*P(I2,3))/MAX(1D-10,P(I1,5)*P(I2,5))) + R2D(I1,I2)=2D0*MIN(P(I1,4),P(I2,4))**2*(1D0-(P(I1,1)*P(I2,1)+ + &P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/MAX(1D-10,P(I1,5)*P(I2,5))) + +C...If first time, reset. If reentering, skip preliminaries. + IF(MSTU(48).LE.0) THEN + NP=0 + DO 100 J=1,5 + PS(J)=0D0 + 100 CONTINUE + PSS=0D0 + PIMASS=PMAS(PYCOMP(211),1) + ELSE + NJET=NSAV + IF(MSTU(43).GE.2) N=N-NJET + DO 110 I=N+1,N+NJET + P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2) + 110 CONTINUE + IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN + R2ACC=PARU(44)**2 + ELSE + R2ACC=PARU(45)*PS(5)**2 + ENDIF + NLOOP=0 + GOTO 300 + ENDIF + +C...Find which particles are to be considered in cluster search. + DO 140 I=1,N + IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140 + IF(MSTU(41).GE.2) THEN + KC=PYCOMP(K(I,2)) + IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR. + & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR. + & K(I,2).EQ.KSUSY1+39) GOTO 140 + IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0) + & GOTO 140 + ENDIF + IF(N+2*NP.GE.MSTU(4)-MSTU(32)-5) THEN + CALL PYERRM(11,'(PYCLUS:) no more memory left in PYJETS') + NJET=-1 + RETURN + ENDIF + +C...Take copy of these particles, with space left for jets later on. + NP=NP+1 + K(N+NP,3)=I + DO 120 J=1,5 + P(N+NP,J)=P(I,J) + 120 CONTINUE + IF(MSTU(42).EQ.0) P(N+NP,5)=0D0 + IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS + P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2) + P(N+NP,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2) + DO 130 J=1,4 + PS(J)=PS(J)+P(N+NP,J) + 130 CONTINUE + PSS=PSS+P(N+NP,5) + 140 CONTINUE + DO 160 I=N+1,N+NP + K(I+NP,3)=K(I,3) + DO 150 J=1,5 + P(I+NP,J)=P(I,J) + 150 CONTINUE + 160 CONTINUE + PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2)) + +C...Very low multiplicities not considered. + IF(NP.LT.MSTU(47)) THEN + CALL PYERRM(8,'(PYCLUS:) too few particles for analysis') + NJET=-1 + RETURN + ENDIF + +C...Find precluster configuration. If too few jets, make harder cuts. + NLOOP=0 + IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN + R2ACC=PARU(44)**2 + ELSE + R2ACC=PARU(45)*PS(5)**2 + ENDIF + RINIT=1.25D0*PARU(43) + IF(NP.LE.MSTU(47)+2) RINIT=0D0 + 170 RINIT=0.8D0*RINIT + NPRE=0 + NREM=NP + DO 180 I=N+NP+1,N+2*NP + K(I,4)=0 + 180 CONTINUE + +C...Sum up small momentum region. Jet if enough absolute momentum. + IF(MSTU(46).LE.2) THEN + DO 190 J=1,4 + P(N+1,J)=0D0 + 190 CONTINUE + DO 210 I=N+NP+1,N+2*NP + IF(P(I,5).GT.2D0*RINIT) GOTO 210 + NREM=NREM-1 + K(I,4)=1 + DO 200 J=1,4 + P(N+1,J)=P(N+1,J)+P(I,J) + 200 CONTINUE + 210 CONTINUE + P(N+1,5)=SQRT(P(N+1,1)**2+P(N+1,2)**2+P(N+1,3)**2) + IF(P(N+1,5).GT.2D0*RINIT) NPRE=1 + IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170 + IF(NREM.EQ.0) GOTO 170 + ENDIF + +C...Find fastest remaining particle. + 220 NPRE=NPRE+1 + PMAX=0D0 + DO 230 I=N+NP+1,N+2*NP + IF(K(I,4).NE.0.OR.P(I,5).LE.PMAX) GOTO 230 + IMAX=I + PMAX=P(I,5) + 230 CONTINUE + DO 240 J=1,5 + P(N+NPRE,J)=P(IMAX,J) + 240 CONTINUE + NREM=NREM-1 + K(IMAX,4)=NPRE + +C...Sum up precluster around it according to pT separation. + IF(MSTU(46).LE.2) THEN + DO 260 I=N+NP+1,N+2*NP + IF(K(I,4).NE.0) GOTO 260 + R2=R2T(I,IMAX) + IF(R2.GT.RINIT**2) GOTO 260 + NREM=NREM-1 + K(I,4)=NPRE + DO 250 J=1,4 + P(N+NPRE,J)=P(N+NPRE,J)+P(I,J) + 250 CONTINUE + 260 CONTINUE + P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2) + +C...Sum up precluster around it according to mass or +C...Durham pT separation. + ELSE + 270 IMIN=0 + R2MIN=RINIT**2 + DO 280 I=N+NP+1,N+2*NP + IF(K(I,4).NE.0) GOTO 280 + IF(MSTU(46).LE.4) THEN + R2=R2M(I,N+NPRE) + ELSE + R2=R2D(I,N+NPRE) + ENDIF + IF(R2.GE.R2MIN) GOTO 280 + IMIN=I + R2MIN=R2 + 280 CONTINUE + IF(IMIN.NE.0) THEN + DO 290 J=1,4 + P(N+NPRE,J)=P(N+NPRE,J)+P(IMIN,J) + 290 CONTINUE + P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2) + NREM=NREM-1 + K(IMIN,4)=NPRE + GOTO 270 + ENDIF + ENDIF + +C...Check if more preclusters to be found. Start over if too few. + IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170 + IF(NREM.GT.0) GOTO 220 + NJET=NPRE + +C...Reassign all particles to nearest jet. Sum up new jet momenta. + 300 TSAV=0D0 + PSJT=0D0 + 310 IF(MSTU(46).LE.1) THEN + DO 330 I=N+1,N+NJET + DO 320 J=1,4 + V(I,J)=0D0 + 320 CONTINUE + 330 CONTINUE + DO 360 I=N+NP+1,N+2*NP + R2MIN=PSS**2 + DO 340 IJET=N+1,N+NJET + IF(P(IJET,5).LT.RINIT) GOTO 340 + R2=R2T(I,IJET) + IF(R2.GE.R2MIN) GOTO 340 + IMIN=IJET + R2MIN=R2 + 340 CONTINUE + K(I,4)=IMIN-N + DO 350 J=1,4 + V(IMIN,J)=V(IMIN,J)+P(I,J) + 350 CONTINUE + 360 CONTINUE + PSJT=0D0 + DO 380 I=N+1,N+NJET + DO 370 J=1,4 + P(I,J)=V(I,J) + 370 CONTINUE + P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2) + PSJT=PSJT+P(I,5) + 380 CONTINUE + ENDIF + +C...Find two closest jets. + R2MIN=2D0*MAX(R2ACC,PS(5)**2) + DO 400 ITRY1=N+1,N+NJET-1 + DO 390 ITRY2=ITRY1+1,N+NJET + IF(MSTU(46).LE.2) THEN + R2=R2T(ITRY1,ITRY2) + ELSEIF(MSTU(46).LE.4) THEN + R2=R2M(ITRY1,ITRY2) + ELSE + R2=R2D(ITRY1,ITRY2) + ENDIF + IF(R2.GE.R2MIN) GOTO 390 + IMIN1=ITRY1 + IMIN2=ITRY2 + R2MIN=R2 + 390 CONTINUE + 400 CONTINUE + +C...If allowed, join two closest jets and start over. + IF(NJET.GT.MSTU(47).AND.R2MIN.LT.R2ACC) THEN + IREC=MIN(IMIN1,IMIN2) + IDEL=MAX(IMIN1,IMIN2) + DO 410 J=1,4 + P(IREC,J)=P(IMIN1,J)+P(IMIN2,J) + 410 CONTINUE + P(IREC,5)=SQRT(P(IREC,1)**2+P(IREC,2)**2+P(IREC,3)**2) + DO 430 I=IDEL+1,N+NJET + DO 420 J=1,5 + P(I-1,J)=P(I,J) + 420 CONTINUE + 430 CONTINUE + IF(MSTU(46).GE.2) THEN + DO 440 I=N+NP+1,N+2*NP + IORI=N+K(I,4) + IF(IORI.EQ.IDEL) K(I,4)=IREC-N + IF(IORI.GT.IDEL) K(I,4)=K(I,4)-1 + 440 CONTINUE + ENDIF + NJET=NJET-1 + GOTO 300 + +C...Divide up broad jet if empty cluster in list of final ones. + ELSEIF(NJET.EQ.MSTU(47).AND.MSTU(46).LE.1.AND.NLOOP.LE.2) THEN + DO 450 I=N+1,N+NJET + K(I,5)=0 + 450 CONTINUE + DO 460 I=N+NP+1,N+2*NP + K(N+K(I,4),5)=K(N+K(I,4),5)+1 + 460 CONTINUE + IEMP=0 + DO 470 I=N+1,N+NJET + IF(K(I,5).EQ.0) IEMP=I + 470 CONTINUE + IF(IEMP.NE.0) THEN + NLOOP=NLOOP+1 + ISPL=0 + R2MAX=0D0 + DO 480 I=N+NP+1,N+2*NP + IF(K(N+K(I,4),5).LE.1.OR.P(I,5).LT.RINIT) GOTO 480 + IJET=N+K(I,4) + R2=R2T(I,IJET) + IF(R2.LE.R2MAX) GOTO 480 + ISPL=I + R2MAX=R2 + 480 CONTINUE + IF(ISPL.NE.0) THEN + IJET=N+K(ISPL,4) + DO 490 J=1,4 + P(IEMP,J)=P(ISPL,J) + P(IJET,J)=P(IJET,J)-P(ISPL,J) + 490 CONTINUE + P(IEMP,5)=P(ISPL,5) + P(IJET,5)=SQRT(P(IJET,1)**2+P(IJET,2)**2+P(IJET,3)**2) + IF(NLOOP.LE.2) GOTO 300 + ENDIF + ENDIF + ENDIF + +C...If generalized thrust has not yet converged, continue iteration. + IF(MSTU(46).LE.1.AND.NLOOP.LE.2.AND.PSJT/PSS.GT.TSAV+PARU(48)) + &THEN + TSAV=PSJT/PSS + GOTO 310 + ENDIF + +C...Reorder jets according to energy. + DO 510 I=N+1,N+NJET + DO 500 J=1,5 + V(I,J)=P(I,J) + 500 CONTINUE + 510 CONTINUE + DO 540 INEW=N+1,N+NJET + PEMAX=0D0 + DO 520 ITRY=N+1,N+NJET + IF(V(ITRY,4).LE.PEMAX) GOTO 520 + IMAX=ITRY + PEMAX=V(ITRY,4) + 520 CONTINUE + K(INEW,1)=31 + K(INEW,2)=97 + K(INEW,3)=INEW-N + K(INEW,4)=0 + DO 530 J=1,5 + P(INEW,J)=V(IMAX,J) + 530 CONTINUE + V(IMAX,4)=-1D0 + K(IMAX,5)=INEW + 540 CONTINUE + +C...Clean up particle-jet assignments and jet information. + DO 550 I=N+NP+1,N+2*NP + IORI=K(N+K(I,4),5) + K(I,4)=IORI-N + IF(K(K(I,3),1).NE.3) K(K(I,3),4)=IORI-N + K(IORI,4)=K(IORI,4)+1 + 550 CONTINUE + IEMP=0 + PSJT=0D0 + DO 570 I=N+1,N+NJET + K(I,5)=0 + PSJT=PSJT+P(I,5) + P(I,5)=SQRT(MAX(P(I,4)**2-P(I,5)**2,0D0)) + DO 560 J=1,5 + V(I,J)=0D0 + 560 CONTINUE + IF(K(I,4).EQ.0) IEMP=I + 570 CONTINUE + +C...Select storing option. Output variables. Check for failure. + MSTU(61)=N+1 + MSTU(62)=NP + MSTU(63)=NPRE + PARU(61)=PS(5) + PARU(62)=PSJT/PSS + PARU(63)=SQRT(R2MIN) + IF(NJET.LE.1) PARU(63)=0D0 + IF(IEMP.NE.0) THEN + CALL PYERRM(8,'(PYCLUS:) failed to reconstruct as requested') + NJET=-1 + RETURN + ENDIF + IF(MSTU(43).LE.1) MSTU(3)=MAX(0,NJET) + IF(MSTU(43).GE.2) N=N+MAX(0,NJET) + NSAV=NJET + + RETURN + END + +C********************************************************************* + +C...PYCELL +C...Provides a simple way of jet finding in eta-phi-ET coordinates, +C...as used for calorimeters at hadron colliders. + + SUBROUTINE PYCELL(NJET) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ + +C...Loop over all particles. Find cell that was hit by given particle. + PTLRAT=1D0/SINH(PARU(51))**2 + NP=0 + NC=N + DO 110 I=1,N + IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110 + IF(P(I,1)**2+P(I,2)**2.LE.PTLRAT*P(I,3)**2) GOTO 110 + IF(MSTU(41).GE.2) THEN + KC=PYCOMP(K(I,2)) + IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR. + & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR. + & K(I,2).EQ.KSUSY1+39) GOTO 110 + IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0) + & GOTO 110 + ENDIF + NP=NP+1 + PT=SQRT(P(I,1)**2+P(I,2)**2) + ETA=SIGN(LOG((SQRT(PT**2+P(I,3)**2)+ABS(P(I,3)))/PT),P(I,3)) + IETA=MAX(1,MIN(MSTU(51),1+INT(MSTU(51)*0.5D0* + & (ETA/PARU(51)+1D0)))) + PHI=PYANGL(P(I,1),P(I,2)) + IPHI=MAX(1,MIN(MSTU(52),1+INT(MSTU(52)*0.5D0* + & (PHI/PARU(1)+1D0)))) + IETPH=MSTU(52)*IETA+IPHI + +C...Add to cell already hit, or book new cell. + DO 100 IC=N+1,NC + IF(IETPH.EQ.K(IC,3)) THEN + K(IC,4)=K(IC,4)+1 + P(IC,5)=P(IC,5)+PT + GOTO 110 + ENDIF + 100 CONTINUE + IF(NC.GE.MSTU(4)-MSTU(32)-5) THEN + CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS') + NJET=-2 + RETURN + ENDIF + NC=NC+1 + K(NC,3)=IETPH + K(NC,4)=1 + K(NC,5)=2 + P(NC,1)=(PARU(51)/MSTU(51))*(2*IETA-1-MSTU(51)) + P(NC,2)=(PARU(1)/MSTU(52))*(2*IPHI-1-MSTU(52)) + P(NC,5)=PT + 110 CONTINUE + +C...Smear true bin content by calorimeter resolution. + IF(MSTU(53).GE.1) THEN + DO 130 IC=N+1,NC + PEI=P(IC,5) + IF(MSTU(53).EQ.2) PEI=P(IC,5)*COSH(P(IC,1)) + 120 PEF=PEI+PARU(55)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0)))*PEI)* + & COS(PARU(2)*PYR(0)) + IF(PEF.LT.0D0.OR.PEF.GT.PARU(56)*PEI) GOTO 120 + P(IC,5)=PEF + IF(MSTU(53).EQ.2) P(IC,5)=PEF/COSH(P(IC,1)) + 130 CONTINUE + ENDIF + +C...Remove cells below threshold. + IF(PARU(58).GT.0D0) THEN + NCC=NC + NC=N + DO 140 IC=N+1,NCC + IF(P(IC,5).GT.PARU(58)) THEN + NC=NC+1 + K(NC,3)=K(IC,3) + K(NC,4)=K(IC,4) + K(NC,5)=K(IC,5) + P(NC,1)=P(IC,1) + P(NC,2)=P(IC,2) + P(NC,5)=P(IC,5) + ENDIF + 140 CONTINUE + ENDIF + +C...Find initiator cell: the one with highest pT of not yet used ones. + NJ=NC + 150 ETMAX=0D0 + DO 160 IC=N+1,NC + IF(K(IC,5).NE.2) GOTO 160 + IF(P(IC,5).LE.ETMAX) GOTO 160 + ICMAX=IC + ETA=P(IC,1) + PHI=P(IC,2) + ETMAX=P(IC,5) + 160 CONTINUE + IF(ETMAX.LT.PARU(52)) GOTO 220 + IF(NJ.GE.MSTU(4)-MSTU(32)-5) THEN + CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS') + NJET=-2 + RETURN + ENDIF + K(ICMAX,5)=1 + NJ=NJ+1 + K(NJ,4)=0 + K(NJ,5)=1 + P(NJ,1)=ETA + P(NJ,2)=PHI + P(NJ,3)=0D0 + P(NJ,4)=0D0 + P(NJ,5)=0D0 + +C...Sum up unused cells within required distance of initiator. + DO 170 IC=N+1,NC + IF(K(IC,5).EQ.0) GOTO 170 + IF(ABS(P(IC,1)-ETA).GT.PARU(54)) GOTO 170 + DPHIA=ABS(P(IC,2)-PHI) + IF(DPHIA.GT.PARU(54).AND.DPHIA.LT.PARU(2)-PARU(54)) GOTO 170 + PHIC=P(IC,2) + IF(DPHIA.GT.PARU(1)) PHIC=PHIC+SIGN(PARU(2),PHI) + IF((P(IC,1)-ETA)**2+(PHIC-PHI)**2.GT.PARU(54)**2) GOTO 170 + K(IC,5)=-K(IC,5) + K(NJ,4)=K(NJ,4)+K(IC,4) + P(NJ,3)=P(NJ,3)+P(IC,5)*P(IC,1) + P(NJ,4)=P(NJ,4)+P(IC,5)*PHIC + P(NJ,5)=P(NJ,5)+P(IC,5) + 170 CONTINUE + +C...Reject cluster below minimum ET, else accept. + IF(P(NJ,5).LT.PARU(53)) THEN + NJ=NJ-1 + DO 180 IC=N+1,NC + IF(K(IC,5).LT.0) K(IC,5)=-K(IC,5) + 180 CONTINUE + ELSEIF(MSTU(54).LE.2) THEN + P(NJ,3)=P(NJ,3)/P(NJ,5) + P(NJ,4)=P(NJ,4)/P(NJ,5) + IF(ABS(P(NJ,4)).GT.PARU(1)) P(NJ,4)=P(NJ,4)-SIGN(PARU(2), + & P(NJ,4)) + DO 190 IC=N+1,NC + IF(K(IC,5).LT.0) K(IC,5)=0 + 190 CONTINUE + ELSE + DO 200 J=1,4 + P(NJ,J)=0D0 + 200 CONTINUE + DO 210 IC=N+1,NC + IF(K(IC,5).GE.0) GOTO 210 + P(NJ,1)=P(NJ,1)+P(IC,5)*COS(P(IC,2)) + P(NJ,2)=P(NJ,2)+P(IC,5)*SIN(P(IC,2)) + P(NJ,3)=P(NJ,3)+P(IC,5)*SINH(P(IC,1)) + P(NJ,4)=P(NJ,4)+P(IC,5)*COSH(P(IC,1)) + K(IC,5)=0 + 210 CONTINUE + ENDIF + GOTO 150 + +C...Arrange clusters in falling ET sequence. + 220 DO 250 I=1,NJ-NC + ETMAX=0D0 + DO 230 IJ=NC+1,NJ + IF(K(IJ,5).EQ.0) GOTO 230 + IF(P(IJ,5).LT.ETMAX) GOTO 230 + IJMAX=IJ + ETMAX=P(IJ,5) + 230 CONTINUE + K(IJMAX,5)=0 + K(N+I,1)=31 + K(N+I,2)=98 + K(N+I,3)=I + K(N+I,4)=K(IJMAX,4) + K(N+I,5)=0 + DO 240 J=1,5 + P(N+I,J)=P(IJMAX,J) + V(N+I,J)=0D0 + 240 CONTINUE + 250 CONTINUE + NJET=NJ-NC + +C...Convert to massless or massive four-vectors. + IF(MSTU(54).EQ.2) THEN + DO 260 I=N+1,N+NJET + ETA=P(I,3) + P(I,1)=P(I,5)*COS(P(I,4)) + P(I,2)=P(I,5)*SIN(P(I,4)) + P(I,3)=P(I,5)*SINH(ETA) + P(I,4)=P(I,5)*COSH(ETA) + P(I,5)=0D0 + 260 CONTINUE + ELSEIF(MSTU(54).GE.3) THEN + DO 270 I=N+1,N+NJET + P(I,5)=SQRT(MAX(0D0,P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2)) + 270 CONTINUE + ENDIF + +C...Information about storage. + MSTU(61)=N+1 + MSTU(62)=NP + MSTU(63)=NC-N + IF(MSTU(43).LE.1) MSTU(3)=MAX(0,NJET) + IF(MSTU(43).GE.2) N=N+MAX(0,NJET) + + RETURN + END + +C********************************************************************* + +C...PYJMAS +C...Determines, approximately, the two jet masses that minimize +C...the sum m_H^2 + m_L^2, a la Clavelli and Wyler. + + SUBROUTINE PYJMAS(PMH,PML) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ +C...Local arrays. + DIMENSION SM(3,3),SAX(3),PS(3,5) + +C...Reset. + NP=0 + DO 120 J1=1,3 + DO 100 J2=J1,3 + SM(J1,J2)=0D0 + 100 CONTINUE + DO 110 J2=1,4 + PS(J1,J2)=0D0 + 110 CONTINUE + 120 CONTINUE + PSS=0D0 + PIMASS=PMAS(PYCOMP(211),1) + +C...Take copy of particles that are to be considered in mass analysis. + DO 170 I=1,N + IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 170 + IF(MSTU(41).GE.2) THEN + KC=PYCOMP(K(I,2)) + IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR. + & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR. + & K(I,2).EQ.KSUSY1+39) GOTO 170 + IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0) + & GOTO 170 + ENDIF + IF(N+NP+1.GE.MSTU(4)-MSTU(32)-5) THEN + CALL PYERRM(11,'(PYJMAS:) no more memory left in PYJETS') + PMH=-2D0 + PML=-2D0 + RETURN + ENDIF + NP=NP+1 + DO 130 J=1,5 + P(N+NP,J)=P(I,J) + 130 CONTINUE + IF(MSTU(42).EQ.0) P(N+NP,5)=0D0 + IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS + P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2) + +C...Fill information in sphericity tensor and total momentum vector. + DO 150 J1=1,3 + DO 140 J2=J1,3 + SM(J1,J2)=SM(J1,J2)+P(I,J1)*P(I,J2) + 140 CONTINUE + 150 CONTINUE + PSS=PSS+(P(I,1)**2+P(I,2)**2+P(I,3)**2) + DO 160 J=1,4 + PS(3,J)=PS(3,J)+P(N+NP,J) + 160 CONTINUE + 170 CONTINUE + +C...Very low multiplicities (0 or 1) not considered. + IF(NP.LE.1) THEN + CALL PYERRM(8,'(PYJMAS:) too few particles for analysis') + PMH=-1D0 + PML=-1D0 + RETURN + ENDIF + PARU(61)=SQRT(MAX(0D0,PS(3,4)**2-PS(3,1)**2-PS(3,2)**2- + &PS(3,3)**2)) + +C...Find largest eigenvalue to matrix (third degree equation). + DO 190 J1=1,3 + DO 180 J2=J1,3 + SM(J1,J2)=SM(J1,J2)/PSS + 180 CONTINUE + 190 CONTINUE + SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)- + &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0 + SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+ + &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+ + &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0 + SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0) + SMA=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP) + +C...Find largest eigenvector by solving equation system. + DO 210 J1=1,3 + SM(J1,J1)=SM(J1,J1)-SMA + DO 200 J2=J1+1,3 + SM(J2,J1)=SM(J1,J2) + 200 CONTINUE + 210 CONTINUE + SMAX=0D0 + DO 230 J1=1,3 + DO 220 J2=1,3 + IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 220 + JA=J1 + JB=J2 + SMAX=ABS(SM(J1,J2)) + 220 CONTINUE + 230 CONTINUE + SMAX=0D0 + DO 250 J3=JA+1,JA+2 + J1=J3-3*((J3-1)/3) + RL=SM(J1,JB)/SM(JA,JB) + DO 240 J2=1,3 + SM(J1,J2)=SM(J1,J2)-RL*SM(JA,J2) + IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 240 + JC=J1 + SMAX=ABS(SM(J1,J2)) + 240 CONTINUE + 250 CONTINUE + JB1=JB+1-3*(JB/3) + JB2=JB+2-3*((JB+1)/3) + SAX(JB1)=-SM(JC,JB2) + SAX(JB2)=SM(JC,JB1) + SAX(JB)=-(SM(JA,JB1)*SAX(JB1)+SM(JA,JB2)*SAX(JB2))/SM(JA,JB) + +C...Divide particles into two initial clusters by hemisphere. + DO 270 I=N+1,N+NP + PSAX=P(I,1)*SAX(1)+P(I,2)*SAX(2)+P(I,3)*SAX(3) + IS=1 + IF(PSAX.LT.0D0) IS=2 + K(I,3)=IS + DO 260 J=1,4 + PS(IS,J)=PS(IS,J)+P(I,J) + 260 CONTINUE + 270 CONTINUE + PMS=MAX(1D-10,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2)+ + &MAX(1D-10,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2) + +C...Reassign one particle at a time; find maximum decrease of m^2 sum. + 280 PMD=0D0 + IM=0 + DO 290 J=1,4 + PS(3,J)=PS(1,J)-PS(2,J) + 290 CONTINUE + DO 300 I=N+1,N+NP + PPS=P(I,4)*PS(3,4)-P(I,1)*PS(3,1)-P(I,2)*PS(3,2)-P(I,3)*PS(3,3) + IF(K(I,3).EQ.1) PMDI=2D0*(P(I,5)**2-PPS) + IF(K(I,3).EQ.2) PMDI=2D0*(P(I,5)**2+PPS) + IF(PMDI.LT.PMD) THEN + PMD=PMDI + IM=I + ENDIF + 300 CONTINUE + +C...Loop back if significant reduction in sum of m^2. + IF(PMD.LT.-PARU(48)*PMS) THEN + PMS=PMS+PMD + IS=K(IM,3) + DO 310 J=1,4 + PS(IS,J)=PS(IS,J)-P(IM,J) + PS(3-IS,J)=PS(3-IS,J)+P(IM,J) + 310 CONTINUE + K(IM,3)=3-IS + GOTO 280 + ENDIF + +C...Final masses and output. + MSTU(61)=N+1 + MSTU(62)=NP + PS(1,5)=SQRT(MAX(0D0,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2)) + PS(2,5)=SQRT(MAX(0D0,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2)) + PMH=MAX(PS(1,5),PS(2,5)) + PML=MIN(PS(1,5),PS(2,5)) + + RETURN + END + +C********************************************************************* + +C...PYFOWO +C...Calculates the first few Fox-Wolfram moments. + + SUBROUTINE PYFOWO(H10,H20,H30,H40) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ + +C...Copy momenta for particles and calculate H0. + NP=0 + H0=0D0 + HD=0D0 + DO 110 I=1,N + IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110 + IF(MSTU(41).GE.2) THEN + KC=PYCOMP(K(I,2)) + IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR. + & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR. + & K(I,2).EQ.KSUSY1+39) GOTO 110 + IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0) + & GOTO 110 + ENDIF + IF(N+NP.GE.MSTU(4)-MSTU(32)-5) THEN + CALL PYERRM(11,'(PYFOWO:) no more memory left in PYJETS') + H10=-1D0 + H20=-1D0 + H30=-1D0 + H40=-1D0 + RETURN + ENDIF + NP=NP+1 + DO 100 J=1,3 + P(N+NP,J)=P(I,J) + 100 CONTINUE + P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2) + H0=H0+P(N+NP,4) + HD=HD+P(N+NP,4)**2 + 110 CONTINUE + H0=H0**2 + +C...Very low multiplicities (0 or 1) not considered. + IF(NP.LE.1) THEN + CALL PYERRM(8,'(PYFOWO:) too few particles for analysis') + H10=-1D0 + H20=-1D0 + H30=-1D0 + H40=-1D0 + RETURN + ENDIF + +C...Calculate H1 - H4. + H10=0D0 + H20=0D0 + H30=0D0 + H40=0D0 + DO 130 I1=N+1,N+NP + DO 120 I2=I1+1,N+NP + CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/ + & (P(I1,4)*P(I2,4)) + H10=H10+P(I1,4)*P(I2,4)*CTHE + H20=H20+P(I1,4)*P(I2,4)*(1.5D0*CTHE**2-0.5D0) + H30=H30+P(I1,4)*P(I2,4)*(2.5D0*CTHE**3-1.5D0*CTHE) + H40=H40+P(I1,4)*P(I2,4)*(4.375D0*CTHE**4-3.75D0*CTHE**2+ + & 0.375D0) + 120 CONTINUE + 130 CONTINUE + +C...Calculate H1/H0 - H4/H0. Output. + MSTU(61)=N+1 + MSTU(62)=NP + H10=(HD+2D0*H10)/H0 + H20=(HD+2D0*H20)/H0 + H30=(HD+2D0*H30)/H0 + H40=(HD+2D0*H40)/H0 + + RETURN + END + +C********************************************************************* + +C...PYTABU +C...Evaluates various properties of an event, with statistics +C...accumulated during the course of the run and +C...printed at the end. + + SUBROUTINE PYTABU(MTABU) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/ +C...Local arrays, character variables, saved variables and data. + DIMENSION KFIS(100,2),NPIS(100,0:10),KFFS(400),NPFS(400,4), + &FEVFM(10,4),FM1FM(3,10,4),FM2FM(3,10,4),FMOMA(4),FMOMS(4), + &FEVEE(50),FE1EC(50),FE2EC(50),FE1EA(25),FE2EA(25), + &KFDM(8),KFDC(200,0:8),NPDC(200) + SAVE NEVIS,NKFIS,KFIS,NPIS,NEVFS,NPRFS,NFIFS,NCHFS,NKFFS, + &KFFS,NPFS,NEVFM,NMUFM,FM1FM,FM2FM,NEVEE,FE1EC,FE2EC,FE1EA, + &FE2EA,NEVDC,NKFDC,NREDC,KFDC,NPDC + CHARACTER CHAU*16,CHIS(2)*12,CHDC(8)*12 + DATA NEVIS/0/,NKFIS/0/,NEVFS/0/,NPRFS/0/,NFIFS/0/,NCHFS/0/, + &NKFFS/0/,NEVFM/0/,NMUFM/0/,FM1FM/120*0D0/,FM2FM/120*0D0/, + &NEVEE/0/,FE1EC/50*0D0/,FE2EC/50*0D0/,FE1EA/25*0D0/,FE2EA/25*0D0/, + &NEVDC/0/,NKFDC/0/,NREDC/0/ + +C...Reset statistics on initial parton state. + IF(MTABU.EQ.10) THEN + NEVIS=0 + NKFIS=0 + +C...Identify and order flavour content of initial state. + ELSEIF(MTABU.EQ.11) THEN + NEVIS=NEVIS+1 + KFM1=2*IABS(MSTU(161)) + IF(MSTU(161).GT.0) KFM1=KFM1-1 + KFM2=2*IABS(MSTU(162)) + IF(MSTU(162).GT.0) KFM2=KFM2-1 + KFMN=MIN(KFM1,KFM2) + KFMX=MAX(KFM1,KFM2) + DO 100 I=1,NKFIS + IF(KFMN.EQ.KFIS(I,1).AND.KFMX.EQ.KFIS(I,2)) THEN + IKFIS=-I + GOTO 110 + ELSEIF(KFMN.LT.KFIS(I,1).OR.(KFMN.EQ.KFIS(I,1).AND. + & KFMX.LT.KFIS(I,2))) THEN + IKFIS=I + GOTO 110 + ENDIF + 100 CONTINUE + IKFIS=NKFIS+1 + 110 IF(IKFIS.LT.0) THEN + IKFIS=-IKFIS + ELSE + IF(NKFIS.GE.100) RETURN + DO 130 I=NKFIS,IKFIS,-1 + KFIS(I+1,1)=KFIS(I,1) + KFIS(I+1,2)=KFIS(I,2) + DO 120 J=0,10 + NPIS(I+1,J)=NPIS(I,J) + 120 CONTINUE + 130 CONTINUE + NKFIS=NKFIS+1 + KFIS(IKFIS,1)=KFMN + KFIS(IKFIS,2)=KFMX + DO 140 J=0,10 + NPIS(IKFIS,J)=0 + 140 CONTINUE + ENDIF + NPIS(IKFIS,0)=NPIS(IKFIS,0)+1 + +C...Count number of partons in initial state. + NP=0 + DO 160 I=1,N + IF(K(I,1).LE.0.OR.K(I,1).GT.12) THEN + ELSEIF(IABS(K(I,2)).GT.80.AND.IABS(K(I,2)).LE.100) THEN + ELSEIF(IABS(K(I,2)).GT.100.AND.MOD(IABS(K(I,2))/10,10).NE.0) + & THEN + ELSE + IM=I + 150 IM=K(IM,3) + IF(IM.LE.0.OR.IM.GT.N) THEN + NP=NP+1 + ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN + NP=NP+1 + ELSEIF(IABS(K(IM,2)).GT.80.AND.IABS(K(IM,2)).LE.100) THEN + ELSEIF(IABS(K(IM,2)).GT.100.AND.MOD(IABS(K(IM,2))/10,10) + & .NE.0) THEN + ELSE + GOTO 150 + ENDIF + ENDIF + 160 CONTINUE + NPCO=MAX(NP,1) + IF(NP.GE.6) NPCO=6 + IF(NP.GE.8) NPCO=7 + IF(NP.GE.11) NPCO=8 + IF(NP.GE.16) NPCO=9 + IF(NP.GE.26) NPCO=10 + NPIS(IKFIS,NPCO)=NPIS(IKFIS,NPCO)+1 + MSTU(62)=NP + +C...Write statistics on initial parton state. + ELSEIF(MTABU.EQ.12) THEN + FAC=1D0/MAX(1,NEVIS) + WRITE(MSTU(11),5000) NEVIS + DO 170 I=1,NKFIS + KFMN=KFIS(I,1) + IF(KFMN.EQ.0) KFMN=KFIS(I,2) + KFM1=(KFMN+1)/2 + IF(2*KFM1.EQ.KFMN) KFM1=-KFM1 + CALL PYNAME(KFM1,CHAU) + CHIS(1)=CHAU(1:12) + IF(CHAU(13:13).NE.' ') CHIS(1)(12:12)='?' + KFMX=KFIS(I,2) + IF(KFIS(I,1).EQ.0) KFMX=0 + KFM2=(KFMX+1)/2 + IF(2*KFM2.EQ.KFMX) KFM2=-KFM2 + CALL PYNAME(KFM2,CHAU) + CHIS(2)=CHAU(1:12) + IF(CHAU(13:13).NE.' ') CHIS(2)(12:12)='?' + WRITE(MSTU(11),5100) CHIS(1),CHIS(2),FAC*NPIS(I,0), + & (NPIS(I,J)/DBLE(NPIS(I,0)),J=1,10) + 170 CONTINUE + +C...Copy statistics on initial parton state into /PYJETS/. + ELSEIF(MTABU.EQ.13) THEN + FAC=1D0/MAX(1,NEVIS) + DO 190 I=1,NKFIS + KFMN=KFIS(I,1) + IF(KFMN.EQ.0) KFMN=KFIS(I,2) + KFM1=(KFMN+1)/2 + IF(2*KFM1.EQ.KFMN) KFM1=-KFM1 + KFMX=KFIS(I,2) + IF(KFIS(I,1).EQ.0) KFMX=0 + KFM2=(KFMX+1)/2 + IF(2*KFM2.EQ.KFMX) KFM2=-KFM2 + K(I,1)=32 + K(I,2)=99 + K(I,3)=KFM1 + K(I,4)=KFM2 + K(I,5)=NPIS(I,0) + DO 180 J=1,5 + P(I,J)=FAC*NPIS(I,J) + V(I,J)=FAC*NPIS(I,J+5) + 180 CONTINUE + 190 CONTINUE + N=NKFIS + DO 200 J=1,5 + K(N+1,J)=0 + P(N+1,J)=0D0 + V(N+1,J)=0D0 + 200 CONTINUE + K(N+1,1)=32 + K(N+1,2)=99 + K(N+1,5)=NEVIS + MSTU(3)=1 + +C...Reset statistics on number of particles/partons. + ELSEIF(MTABU.EQ.20) THEN + NEVFS=0 + NPRFS=0 + NFIFS=0 + NCHFS=0 + NKFFS=0 + +C...Identify whether particle/parton is primary or not. + ELSEIF(MTABU.EQ.21) THEN + NEVFS=NEVFS+1 + MSTU(62)=0 + DO 260 I=1,N + IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,1).EQ.13) GOTO 260 + MSTU(62)=MSTU(62)+1 + KC=PYCOMP(K(I,2)) + MPRI=0 + IF(K(I,3).LE.0.OR.K(I,3).GT.N) THEN + MPRI=1 + ELSEIF(K(K(I,3),1).LE.0.OR.K(K(I,3),1).GT.20) THEN + MPRI=1 + ELSEIF(K(K(I,3),2).GE.91.AND.K(K(I,3),2).LE.93) THEN + MPRI=1 + ELSEIF(KC.EQ.0) THEN + ELSEIF(K(K(I,3),1).EQ.13) THEN + IM=K(K(I,3),3) + IF(IM.LE.0.OR.IM.GT.N) THEN + MPRI=1 + ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN + MPRI=1 + ENDIF + ELSEIF(KCHG(KC,2).EQ.0) THEN + KCM=PYCOMP(K(K(I,3),2)) + IF(KCM.NE.0) THEN + IF(KCHG(KCM,2).NE.0) MPRI=1 + ENDIF + ENDIF + IF(KC.NE.0.AND.MPRI.EQ.1) THEN + IF(KCHG(KC,2).EQ.0) NPRFS=NPRFS+1 + ENDIF + IF(K(I,1).LE.10) THEN + NFIFS=NFIFS+1 + IF(PYCHGE(K(I,2)).NE.0) NCHFS=NCHFS+1 + ENDIF + +C...Fill statistics on number of particles/partons in event. + KFA=IABS(K(I,2)) + KFS=3-ISIGN(1,K(I,2))-MPRI + DO 210 IP=1,NKFFS + IF(KFA.EQ.KFFS(IP)) THEN + IKFFS=-IP + GOTO 220 + ELSEIF(KFA.LT.KFFS(IP)) THEN + IKFFS=IP + GOTO 220 + ENDIF + 210 CONTINUE + IKFFS=NKFFS+1 + 220 IF(IKFFS.LT.0) THEN + IKFFS=-IKFFS + ELSE + IF(NKFFS.GE.400) RETURN + DO 240 IP=NKFFS,IKFFS,-1 + KFFS(IP+1)=KFFS(IP) + DO 230 J=1,4 + NPFS(IP+1,J)=NPFS(IP,J) + 230 CONTINUE + 240 CONTINUE + NKFFS=NKFFS+1 + KFFS(IKFFS)=KFA + DO 250 J=1,4 + NPFS(IKFFS,J)=0 + 250 CONTINUE + ENDIF + NPFS(IKFFS,KFS)=NPFS(IKFFS,KFS)+1 + 260 CONTINUE + +C...Write statistics on particle/parton composition of events. + ELSEIF(MTABU.EQ.22) THEN + FAC=1D0/MAX(1,NEVFS) + WRITE(MSTU(11),5200) NEVFS,FAC*NPRFS,FAC*NFIFS,FAC*NCHFS + DO 270 I=1,NKFFS + CALL PYNAME(KFFS(I),CHAU) + KC=PYCOMP(KFFS(I)) + MDCYF=0 + IF(KC.NE.0) MDCYF=MDCY(KC,1) + WRITE(MSTU(11),5300) KFFS(I),CHAU,MDCYF,(FAC*NPFS(I,J),J=1,4), + & FAC*(NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4)) + 270 CONTINUE + +C...Copy particle/parton composition information into /PYJETS/. + ELSEIF(MTABU.EQ.23) THEN + FAC=1D0/MAX(1,NEVFS) + DO 290 I=1,NKFFS + K(I,1)=32 + K(I,2)=99 + K(I,3)=KFFS(I) + K(I,4)=0 + K(I,5)=NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4) + DO 280 J=1,4 + P(I,J)=FAC*NPFS(I,J) + V(I,J)=0D0 + 280 CONTINUE + P(I,5)=FAC*K(I,5) + V(I,5)=0D0 + 290 CONTINUE + N=NKFFS + DO 300 J=1,5 + K(N+1,J)=0 + P(N+1,J)=0D0 + V(N+1,J)=0D0 + 300 CONTINUE + K(N+1,1)=32 + K(N+1,2)=99 + K(N+1,5)=NEVFS + P(N+1,1)=FAC*NPRFS + P(N+1,2)=FAC*NFIFS + P(N+1,3)=FAC*NCHFS + MSTU(3)=1 + +C...Reset factorial moments statistics. + ELSEIF(MTABU.EQ.30) THEN + NEVFM=0 + NMUFM=0 + DO 330 IM=1,3 + DO 320 IB=1,10 + DO 310 IP=1,4 + FM1FM(IM,IB,IP)=0D0 + FM2FM(IM,IB,IP)=0D0 + 310 CONTINUE + 320 CONTINUE + 330 CONTINUE + +C...Find particles to include, with (pion,pseudo)rapidity and azimuth. + ELSEIF(MTABU.EQ.31) THEN + NEVFM=NEVFM+1 + NLOW=N+MSTU(3) + NUPP=NLOW + DO 410 I=1,N + IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 410 + IF(MSTU(41).GE.2) THEN + KC=PYCOMP(K(I,2)) + IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR. + & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR. + & K(I,2).EQ.KSUSY1+39) GOTO 410 + IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND. + & PYCHGE(K(I,2)).EQ.0) GOTO 410 + ENDIF + PMR=0D0 + IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211) + IF(MSTU(42).GE.2) PMR=P(I,5) + PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2) + YETA=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR), + & 1D20)),P(I,3)) + IF(ABS(YETA).GT.PARU(57)) GOTO 410 + PHI=PYANGL(P(I,1),P(I,2)) + IYETA=512D0*(YETA+PARU(57))/(2D0*PARU(57)) + IYETA=MAX(0,MIN(511,IYETA)) + IPHI=512D0*(PHI+PARU(1))/PARU(2) + IPHI=MAX(0,MIN(511,IPHI)) + IYEP=0 + DO 340 IB=0,9 + IYEP=IYEP+4**IB*(2*MOD(IYETA/2**IB,2)+MOD(IPHI/2**IB,2)) + 340 CONTINUE + +C...Order particles in (pseudo)rapidity and/or azimuth. + IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN + CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS') + RETURN + ENDIF + NUPP=NUPP+1 + IF(NUPP.EQ.NLOW+1) THEN + K(NUPP,1)=IYETA + K(NUPP,2)=IPHI + K(NUPP,3)=IYEP + ELSE + DO 350 I1=NUPP-1,NLOW+1,-1 + IF(IYETA.GE.K(I1,1)) GOTO 360 + K(I1+1,1)=K(I1,1) + 350 CONTINUE + 360 K(I1+1,1)=IYETA + DO 370 I1=NUPP-1,NLOW+1,-1 + IF(IPHI.GE.K(I1,2)) GOTO 380 + K(I1+1,2)=K(I1,2) + 370 CONTINUE + 380 K(I1+1,2)=IPHI + DO 390 I1=NUPP-1,NLOW+1,-1 + IF(IYEP.GE.K(I1,3)) GOTO 400 + K(I1+1,3)=K(I1,3) + 390 CONTINUE + 400 K(I1+1,3)=IYEP + ENDIF + 410 CONTINUE + K(NUPP+1,1)=2**10 + K(NUPP+1,2)=2**10 + K(NUPP+1,3)=4**10 + +C...Calculate sum of factorial moments in event. + DO 480 IM=1,3 + DO 430 IB=1,10 + DO 420 IP=1,4 + FEVFM(IB,IP)=0D0 + 420 CONTINUE + 430 CONTINUE + DO 450 IB=1,10 + IF(IM.LE.2) IBIN=2**(10-IB) + IF(IM.EQ.3) IBIN=4**(10-IB) + IAGR=K(NLOW+1,IM)/IBIN + NAGR=1 + DO 440 I=NLOW+2,NUPP+1 + ICUT=K(I,IM)/IBIN + IF(ICUT.EQ.IAGR) THEN + NAGR=NAGR+1 + ELSE + IF(NAGR.EQ.1) THEN + ELSEIF(NAGR.EQ.2) THEN + FEVFM(IB,1)=FEVFM(IB,1)+2D0 + ELSEIF(NAGR.EQ.3) THEN + FEVFM(IB,1)=FEVFM(IB,1)+6D0 + FEVFM(IB,2)=FEVFM(IB,2)+6D0 + ELSEIF(NAGR.EQ.4) THEN + FEVFM(IB,1)=FEVFM(IB,1)+12D0 + FEVFM(IB,2)=FEVFM(IB,2)+24D0 + FEVFM(IB,3)=FEVFM(IB,3)+24D0 + ELSE + FEVFM(IB,1)=FEVFM(IB,1)+NAGR*(NAGR-1D0) + FEVFM(IB,2)=FEVFM(IB,2)+NAGR*(NAGR-1D0)*(NAGR-2D0) + FEVFM(IB,3)=FEVFM(IB,3)+NAGR*(NAGR-1D0)*(NAGR-2D0)* + & (NAGR-3D0) + FEVFM(IB,4)=FEVFM(IB,4)+NAGR*(NAGR-1D0)*(NAGR-2D0)* + & (NAGR-3D0)*(NAGR-4D0) + ENDIF + IAGR=ICUT + NAGR=1 + ENDIF + 440 CONTINUE + 450 CONTINUE + +C...Add results to total statistics. + DO 470 IB=10,1,-1 + DO 460 IP=1,4 + IF(FEVFM(1,IP).LT.0.5D0) THEN + FEVFM(IB,IP)=0D0 + ELSEIF(IM.LE.2) THEN + FEVFM(IB,IP)=2D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP) + ELSE + FEVFM(IB,IP)=4D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP) + ENDIF + FM1FM(IM,IB,IP)=FM1FM(IM,IB,IP)+FEVFM(IB,IP) + FM2FM(IM,IB,IP)=FM2FM(IM,IB,IP)+FEVFM(IB,IP)**2 + 460 CONTINUE + 470 CONTINUE + 480 CONTINUE + NMUFM=NMUFM+(NUPP-NLOW) + MSTU(62)=NUPP-NLOW + +C...Write accumulated statistics on factorial moments. + ELSEIF(MTABU.EQ.32) THEN + FAC=1D0/MAX(1,NEVFM) + IF(MSTU(42).LE.0) WRITE(MSTU(11),5400) NEVFM,'eta' + IF(MSTU(42).EQ.1) WRITE(MSTU(11),5400) NEVFM,'ypi' + IF(MSTU(42).GE.2) WRITE(MSTU(11),5400) NEVFM,'y ' + DO 510 IM=1,3 + WRITE(MSTU(11),5500) + DO 500 IB=1,10 + BYETA=2D0*PARU(57) + IF(IM.NE.2) BYETA=BYETA/2**(IB-1) + BPHI=PARU(2) + IF(IM.NE.1) BPHI=BPHI/2**(IB-1) + IF(IM.LE.2) BNAVE=FAC*NMUFM/DBLE(2**(IB-1)) + IF(IM.EQ.3) BNAVE=FAC*NMUFM/DBLE(4**(IB-1)) + DO 490 IP=1,4 + FMOMA(IP)=FAC*FM1FM(IM,IB,IP) + FMOMS(IP)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)- + & FMOMA(IP)**2))) + 490 CONTINUE + WRITE(MSTU(11),5600) BYETA,BPHI,BNAVE,(FMOMA(IP),FMOMS(IP), + & IP=1,4) + 500 CONTINUE + 510 CONTINUE + +C...Copy statistics on factorial moments into /PYJETS/. + ELSEIF(MTABU.EQ.33) THEN + FAC=1D0/MAX(1,NEVFM) + DO 540 IM=1,3 + DO 530 IB=1,10 + I=10*(IM-1)+IB + K(I,1)=32 + K(I,2)=99 + K(I,3)=1 + IF(IM.NE.2) K(I,3)=2**(IB-1) + K(I,4)=1 + IF(IM.NE.1) K(I,4)=2**(IB-1) + K(I,5)=0 + P(I,1)=2D0*PARU(57)/K(I,3) + V(I,1)=PARU(2)/K(I,4) + DO 520 IP=1,4 + P(I,IP+1)=FAC*FM1FM(IM,IB,IP) + V(I,IP+1)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)- + & P(I,IP+1)**2))) + 520 CONTINUE + 530 CONTINUE + 540 CONTINUE + N=30 + DO 550 J=1,5 + K(N+1,J)=0 + P(N+1,J)=0D0 + V(N+1,J)=0D0 + 550 CONTINUE + K(N+1,1)=32 + K(N+1,2)=99 + K(N+1,5)=NEVFM + MSTU(3)=1 + +C...Reset statistics on Energy-Energy Correlation. + ELSEIF(MTABU.EQ.40) THEN + NEVEE=0 + DO 560 J=1,25 + FE1EC(J)=0D0 + FE2EC(J)=0D0 + FE1EC(51-J)=0D0 + FE2EC(51-J)=0D0 + FE1EA(J)=0D0 + FE2EA(J)=0D0 + 560 CONTINUE + +C...Find particles to include, with proper assumed mass. + ELSEIF(MTABU.EQ.41) THEN + NEVEE=NEVEE+1 + NLOW=N+MSTU(3) + NUPP=NLOW + ECM=0D0 + DO 570 I=1,N + IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 570 + IF(MSTU(41).GE.2) THEN + KC=PYCOMP(K(I,2)) + IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR. + & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR. + & K(I,2).EQ.KSUSY1+39) GOTO 570 + IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND. + & PYCHGE(K(I,2)).EQ.0) GOTO 570 + ENDIF + PMR=0D0 + IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211) + IF(MSTU(42).GE.2) PMR=P(I,5) + IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN + CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS') + RETURN + ENDIF + NUPP=NUPP+1 + P(NUPP,1)=P(I,1) + P(NUPP,2)=P(I,2) + P(NUPP,3)=P(I,3) + P(NUPP,4)=SQRT(PMR**2+P(I,1)**2+P(I,2)**2+P(I,3)**2) + P(NUPP,5)=MAX(1D-10,SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)) + ECM=ECM+P(NUPP,4) + 570 CONTINUE + IF(NUPP.EQ.NLOW) RETURN + +C...Analyze Energy-Energy Correlation in event. + FAC=(2D0/ECM**2)*50D0/PARU(1) + DO 580 J=1,50 + FEVEE(J)=0D0 + 580 CONTINUE + DO 600 I1=NLOW+2,NUPP + DO 590 I2=NLOW+1,I1-1 + CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/ + & (P(I1,5)*P(I2,5)) + THE=ACOS(MAX(-1D0,MIN(1D0,CTHE))) + ITHE=MAX(1,MIN(50,1+INT(50D0*THE/PARU(1)))) + FEVEE(ITHE)=FEVEE(ITHE)+FAC*P(I1,4)*P(I2,4) + 590 CONTINUE + 600 CONTINUE + DO 610 J=1,25 + FE1EC(J)=FE1EC(J)+FEVEE(J) + FE2EC(J)=FE2EC(J)+FEVEE(J)**2 + FE1EC(51-J)=FE1EC(51-J)+FEVEE(51-J) + FE2EC(51-J)=FE2EC(51-J)+FEVEE(51-J)**2 + FE1EA(J)=FE1EA(J)+(FEVEE(51-J)-FEVEE(J)) + FE2EA(J)=FE2EA(J)+(FEVEE(51-J)-FEVEE(J))**2 + 610 CONTINUE + MSTU(62)=NUPP-NLOW + +C...Write statistics on Energy-Energy Correlation. + ELSEIF(MTABU.EQ.42) THEN + FAC=1D0/MAX(1,NEVEE) + WRITE(MSTU(11),5700) NEVEE + DO 620 J=1,25 + FEEC1=FAC*FE1EC(J) + FEES1=SQRT(MAX(0D0,FAC*(FAC*FE2EC(J)-FEEC1**2))) + FEEC2=FAC*FE1EC(51-J) + FEES2=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-J)-FEEC2**2))) + FEECA=FAC*FE1EA(J) + FEESA=SQRT(MAX(0D0,FAC*(FAC*FE2EA(J)-FEECA**2))) + WRITE(MSTU(11),5800) 3.6D0*(J-1),3.6D0*J,FEEC1,FEES1, + & FEEC2,FEES2,FEECA,FEESA + 620 CONTINUE + +C...Copy statistics on Energy-Energy Correlation into /PYJETS/. + ELSEIF(MTABU.EQ.43) THEN + FAC=1D0/MAX(1,NEVEE) + DO 630 I=1,25 + K(I,1)=32 + K(I,2)=99 + K(I,3)=0 + K(I,4)=0 + K(I,5)=0 + P(I,1)=FAC*FE1EC(I) + V(I,1)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(I)-P(I,1)**2))) + P(I,2)=FAC*FE1EC(51-I) + V(I,2)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-I)-P(I,2)**2))) + P(I,3)=FAC*FE1EA(I) + V(I,3)=SQRT(MAX(0D0,FAC*(FAC*FE2EA(I)-P(I,3)**2))) + P(I,4)=PARU(1)*(I-1)/50D0 + P(I,5)=PARU(1)*I/50D0 + V(I,4)=3.6D0*(I-1) + V(I,5)=3.6D0*I + 630 CONTINUE + N=25 + DO 640 J=1,5 + K(N+1,J)=0 + P(N+1,J)=0D0 + V(N+1,J)=0D0 + 640 CONTINUE + K(N+1,1)=32 + K(N+1,2)=99 + K(N+1,5)=NEVEE + MSTU(3)=1 + +C...Reset statistics on decay channels. + ELSEIF(MTABU.EQ.50) THEN + NEVDC=0 + NKFDC=0 + NREDC=0 + +C...Identify and order flavour content of final state. + ELSEIF(MTABU.EQ.51) THEN + NEVDC=NEVDC+1 + NDS=0 + DO 670 I=1,N + IF(K(I,1).LE.0.OR.K(I,1).GE.6) GOTO 670 + NDS=NDS+1 + IF(NDS.GT.8) THEN + NREDC=NREDC+1 + RETURN + ENDIF + KFM=2*IABS(K(I,2)) + IF(K(I,2).LT.0) KFM=KFM-1 + DO 650 IDS=NDS-1,1,-1 + IIN=IDS+1 + IF(KFM.LT.KFDM(IDS)) GOTO 660 + KFDM(IDS+1)=KFDM(IDS) + 650 CONTINUE + IIN=1 + 660 KFDM(IIN)=KFM + 670 CONTINUE + +C...Find whether old or new final state. + DO 690 IDC=1,NKFDC + IF(NDS.LT.KFDC(IDC,0)) THEN + IKFDC=IDC + GOTO 700 + ELSEIF(NDS.EQ.KFDC(IDC,0)) THEN + DO 680 I=1,NDS + IF(KFDM(I).LT.KFDC(IDC,I)) THEN + IKFDC=IDC + GOTO 700 + ELSEIF(KFDM(I).GT.KFDC(IDC,I)) THEN + GOTO 690 + ENDIF + 680 CONTINUE + IKFDC=-IDC + GOTO 700 + ENDIF + 690 CONTINUE + IKFDC=NKFDC+1 + 700 IF(IKFDC.LT.0) THEN + IKFDC=-IKFDC + ELSEIF(NKFDC.GE.200) THEN + NREDC=NREDC+1 + RETURN + ELSE + DO 720 IDC=NKFDC,IKFDC,-1 + NPDC(IDC+1)=NPDC(IDC) + DO 710 I=0,8 + KFDC(IDC+1,I)=KFDC(IDC,I) + 710 CONTINUE + 720 CONTINUE + NKFDC=NKFDC+1 + KFDC(IKFDC,0)=NDS + DO 730 I=1,NDS + KFDC(IKFDC,I)=KFDM(I) + 730 CONTINUE + NPDC(IKFDC)=0 + ENDIF + NPDC(IKFDC)=NPDC(IKFDC)+1 + +C...Write statistics on decay channels. + ELSEIF(MTABU.EQ.52) THEN + FAC=1D0/MAX(1,NEVDC) + WRITE(MSTU(11),5900) NEVDC + DO 750 IDC=1,NKFDC + DO 740 I=1,KFDC(IDC,0) + KFM=KFDC(IDC,I) + KF=(KFM+1)/2 + IF(2*KF.NE.KFM) KF=-KF + CALL PYNAME(KF,CHAU) + CHDC(I)=CHAU(1:12) + IF(CHAU(13:13).NE.' ') CHDC(I)(12:12)='?' + 740 CONTINUE + WRITE(MSTU(11),6000) FAC*NPDC(IDC),(CHDC(I),I=1,KFDC(IDC,0)) + 750 CONTINUE + IF(NREDC.NE.0) WRITE(MSTU(11),6100) FAC*NREDC + +C...Copy statistics on decay channels into /PYJETS/. + ELSEIF(MTABU.EQ.53) THEN + FAC=1D0/MAX(1,NEVDC) + DO 780 IDC=1,NKFDC + K(IDC,1)=32 + K(IDC,2)=99 + K(IDC,3)=0 + K(IDC,4)=0 + K(IDC,5)=KFDC(IDC,0) + DO 760 J=1,5 + P(IDC,J)=0D0 + V(IDC,J)=0D0 + 760 CONTINUE + DO 770 I=1,KFDC(IDC,0) + KFM=KFDC(IDC,I) + KF=(KFM+1)/2 + IF(2*KF.NE.KFM) KF=-KF + IF(I.LE.5) P(IDC,I)=KF + IF(I.GE.6) V(IDC,I-5)=KF + 770 CONTINUE + V(IDC,5)=FAC*NPDC(IDC) + 780 CONTINUE + N=NKFDC + DO 790 J=1,5 + K(N+1,J)=0 + P(N+1,J)=0D0 + V(N+1,J)=0D0 + 790 CONTINUE + K(N+1,1)=32 + K(N+1,2)=99 + K(N+1,5)=NEVDC + V(N+1,5)=FAC*NREDC + MSTU(3)=1 + ENDIF + +C...Format statements for output on unit MSTU(11) (default 6). + 5000 FORMAT(///20X,'Event statistics - initial state'/ + &20X,'based on an analysis of ',I6,' events'// + &3X,'Main flavours after',8X,'Fraction',4X,'Subfractions ', + &'according to fragmenting system multiplicity'/ + &4X,'hard interaction',24X,'1',7X,'2',7X,'3',7X,'4',7X,'5', + &6X,'6-7',5X,'8-10',3X,'11-15',3X,'16-25',4X,'>25'/) + 5100 FORMAT(3X,A12,1X,A12,F10.5,1X,10F8.4) + 5200 FORMAT(///20X,'Event statistics - final state'/ + &20X,'based on an analysis of ',I7,' events'// + &5X,'Mean primary multiplicity =',F10.4/ + &5X,'Mean final multiplicity =',F10.4/ + &5X,'Mean charged multiplicity =',F10.4// + &5X,'Number of particles produced per event (directly and via ', + &'decays/branchings)'/ + &8X,'KF Particle/jet MDCY',10X,'Particles',13X,'Antiparticles', + &8X,'Total'/35X,'prim seco prim seco'/) + 5300 FORMAT(1X,I9,4X,A16,I2,5(1X,F11.6)) + 5400 FORMAT(///20X,'Factorial moments analysis of multiplicity'/ + &20X,'based on an analysis of ',I6,' events'// + &3X,'delta-',A3,' delta-phi /bin',10X,'',18X,'', + &18X,'',18X,''/35X,4(' value error ')) + 5500 FORMAT(10X) + 5600 FORMAT(2X,2F10.4,F12.4,4(F12.4,F10.4)) + 5700 FORMAT(///20X,'Energy-Energy Correlation and Asymmetry'/ + &20X,'based on an analysis of ',I6,' events'// + &2X,'theta range',8X,'EEC(theta)',8X,'EEC(180-theta)',7X, + &'EECA(theta)'/2X,'in degrees ',3(' value error')/) + 5800 FORMAT(2X,F4.1,' - ',F4.1,3(F11.4,F9.4)) + 5900 FORMAT(///20X,'Decay channel analysis - final state'/ + &20X,'based on an analysis of ',I6,' events'// + &2X,'Probability',10X,'Complete final state'/) + 6000 FORMAT(2X,F9.5,5X,8(A12,1X)) + 6100 FORMAT(2X,F9.5,5X,'into other channels (more than 8 particles ', + &'or table overflow)') + + RETURN + END + +C********************************************************************* + +C...PYEEVT +C...Handles the generation of an e+e- annihilation jet event. + + SUBROUTINE PYEEVT(KFL,ECM) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ + +C...Check input parameters. + IF(MSTU(12).NE.12345) CALL PYLIST(0) + IF(KFL.LT.0.OR.KFL.GT.8) THEN + CALL PYERRM(16,'(PYEEVT:) called with unknown flavour code') + IF(MSTU(21).GE.1) RETURN + ENDIF + IF(KFL.LE.5) ECMMIN=PARJ(127)+2.02D0*PARF(100+MAX(1,KFL)) + IF(KFL.GE.6) ECMMIN=PARJ(127)+2.02D0*PMAS(KFL,1) + IF(ECM.LT.ECMMIN) THEN + CALL PYERRM(16,'(PYEEVT:) called with too small CM energy') + IF(MSTU(21).GE.1) RETURN + ENDIF + +C...Check consistency of MSTJ options set. + IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN + CALL PYERRM(6, + & '(PYEEVT:) MSTJ(109) value requires MSTJ(110) = 1') + MSTJ(110)=1 + ENDIF + IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN + CALL PYERRM(6, + & '(PYEEVT:) MSTJ(109) value requires MSTJ(111) = 0') + MSTJ(111)=0 + ENDIF + +C...Initialize alpha_strong and total cross-section. + MSTU(111)=MSTJ(108) + IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1)) + &MSTU(111)=1 + PARU(112)=PARJ(121) + IF(MSTU(111).EQ.2) PARU(112)=PARJ(122) + IF(MSTJ(116).GT.0.AND.(MSTJ(116).GE.2.OR.ABS(ECM-PARJ(151)).GE. + &PARJ(139).OR.10*MSTJ(102)+KFL.NE.MSTJ(119))) CALL PYXTEE(KFL,ECM, + &XTOT) + IF(MSTJ(116).GE.3) MSTJ(116)=1 + PARJ(171)=0D0 + +C...Add initial e+e- to event record (documentation only). + NTRY=0 + 100 NTRY=NTRY+1 + IF(NTRY.GT.100) THEN + CALL PYERRM(14,'(PYEEVT:) caught in an infinite loop') + RETURN + ENDIF + MSTU(24)=0 + NC=0 + IF(MSTJ(115).GE.2) THEN + NC=NC+2 + CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0) + K(NC-1,1)=21 + CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0) + K(NC,1)=21 + ENDIF + +C...Radiative photon (in initial state). + MK=0 + ECMC=ECM + IF(MSTJ(107).GE.1.AND.MSTJ(116).GE.1) CALL PYRADK(ECM,MK,PAK, + &THEK,PHIK,ALPK) + IF(MK.EQ.1) ECMC=SQRT(ECM*(ECM-2D0*PAK)) + IF(MSTJ(115).GE.1.AND.MK.EQ.1) THEN + NC=NC+1 + CALL PY1ENT(NC,22,PAK,THEK,PHIK) + K(NC,3)=MIN(MSTJ(115)/2,1) + ENDIF + +C...Virtual exchange boson (gamma or Z0). + IF(MSTJ(115).GE.3) THEN + NC=NC+1 + KF=22 + IF(MSTJ(102).EQ.2) KF=23 + MSTU10=MSTU(10) + MSTU(10)=1 + P(NC,5)=ECMC + CALL PY1ENT(NC,KF,ECMC,0D0,0D0) + K(NC,1)=21 + K(NC,3)=1 + MSTU(10)=MSTU10 + ENDIF + +C...Choice of flavour and jet configuration. + CALL PYXKFL(KFL,ECM,ECMC,KFLC) + IF(KFLC.EQ.0) GOTO 100 + CALL PYXJET(ECMC,NJET,CUT) + KFLN=21 + IF(NJET.EQ.4) CALL PYX4JT(NJET,CUT,KFLC,ECMC,KFLN,X1,X2,X4, + &X12,X14) + IF(NJET.EQ.3) CALL PYX3JT(NJET,CUT,KFLC,ECMC,X1,X3) + IF(NJET.EQ.2) MSTJ(120)=1 + +C...Fill jet configuration and origin. + IF(NJET.EQ.2.AND.MSTJ(101).NE.5) CALL PY2ENT(NC+1,KFLC,-KFLC,ECMC) + IF(NJET.EQ.2.AND.MSTJ(101).EQ.5) CALL PY2ENT(-(NC+1),KFLC,-KFLC, + &ECMC) + IF(NJET.EQ.3) CALL PY3ENT(NC+1,KFLC,21,-KFLC,ECMC,X1,X3) + IF(NJET.EQ.4.AND.KFLN.EQ.21) CALL PY4ENT(NC+1,KFLC,KFLN,KFLN, + &-KFLC,ECMC,X1,X2,X4,X12,X14) + IF(NJET.EQ.4.AND.KFLN.NE.21) CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN, + &-KFLC,ECMC,X1,X2,X4,X12,X14) + IF(MSTU(24).NE.0) GOTO 100 + DO 110 IP=NC+1,N + K(IP,3)=K(IP,3)+MIN(MSTJ(115)/2,1)+(MSTJ(115)/3)*(NC-1) + 110 CONTINUE + +C...Angular orientation according to matrix element. + IF(MSTJ(106).EQ.1) THEN + CALL PYXDIF(NC,NJET,KFLC,ECMC,CHI,THE,PHI) + CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0) + CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0) + ENDIF + +C...Rotation and boost from radiative photon. + IF(MK.EQ.1) THEN + DBEK=-PAK/(ECM-PAK) + NMIN=NC+1-MSTJ(115)/3 + CALL PYROBO(NMIN,N,0D0,-PHIK,0D0,0D0,0D0) + CALL PYROBO(NMIN,N,ALPK,0D0,DBEK*SIN(THEK),0D0,DBEK*COS(THEK)) + CALL PYROBO(NMIN,N,0D0,PHIK,0D0,0D0,0D0) + ENDIF + +C...Generate parton shower. Rearrange along strings and check. + IF(MSTJ(101).EQ.5) THEN + CALL PYSHOW(N-1,N,ECMC) + MSTJ14=MSTJ(14) + IF(MSTJ(105).EQ.-1) MSTJ(14)=-1 + IF(MSTJ(105).GE.0) MSTU(28)=0 + CALL PYPREP(0) + MSTJ(14)=MSTJ14 + IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100 + ENDIF + +C...Fragmentation/decay generation. Information for PYTABU. + IF(MSTJ(105).EQ.1) CALL PYEXEC + MSTU(161)=KFLC + MSTU(162)=-KFLC + + RETURN + END + +C********************************************************************* + +C...PYXTEE +C...Calculates total cross-section, including initial state +C...radiation effects. + + SUBROUTINE PYXTEE(KFL,ECM,XTOT) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /PYDAT1/,/PYDAT2/ + +C...Status, (optimized) Q^2 scale, alpha_strong. + PARJ(151)=ECM + MSTJ(119)=10*MSTJ(102)+KFL + IF(MSTJ(111).EQ.0) THEN + Q2R=ECM**2 + ELSEIF(MSTU(111).EQ.0) THEN + PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/ + & ((33D0-2D0*MSTU(112))*PARU(111))))) + Q2R=PARJ(168)*ECM**2 + ELSE + PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM, + & (2D0*PARU(112)/ECM)**2)) + Q2R=PARJ(168)*ECM**2 + ENDIF + ALSPI=PYALPS(Q2R)/PARU(1) + +C...QCD corrections factor in R. + IF(MSTJ(101).EQ.0.OR.MSTJ(109).EQ.1) THEN + RQCD=1D0 + ELSEIF(IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.0) THEN + RQCD=1D0+ALSPI + ELSEIF(MSTJ(109).EQ.0) THEN + RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2 + IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+(33D0-2D0*MSTU(112))/12D0* + & LOG(PARJ(168))*ALSPI**2) + ELSEIF(IABS(MSTJ(101)).EQ.1) THEN + RQCD=1D0+(3D0/4D0)*ALSPI + ELSE + RQCD=1D0+(3D0/4D0)*ALSPI-(3D0/32D0+0.519D0*MSTU(118))*ALSPI**2 + ENDIF + +C...Calculate Z0 width if default value not acceptable. + IF(MSTJ(102).GE.3) THEN + RVA=3D0*(3D0+(4D0*PARU(102)-1D0)**2)+6D0*RQCD*(2D0+ + & (1D0-8D0*PARU(102)/3D0)**2+(4D0*PARU(102)/3D0-1D0)**2) + DO 100 KFLC=5,6 + VQ=1D0 + IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0- + & (2D0*PYMASS(KFLC)/ ECM)**2)) + IF(KFLC.EQ.5) VF=4D0*PARU(102)/3D0-1D0 + IF(KFLC.EQ.6) VF=1D0-8D0*PARU(102)/3D0 + RVA=RVA+3D0*RQCD*(0.5D0*VQ*(3D0-VQ**2)*VF**2+VQ**3) + 100 CONTINUE + PARJ(124)=PARU(101)*PARJ(123)*RVA/(48D0*PARU(102)* + & (1D0-PARU(102))) + ENDIF + +C...Calculate propagator and related constants for QFD case. + POLL=1D0-PARJ(131)*PARJ(132) + IF(MSTJ(102).GE.2) THEN + SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102))) + SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2) + SFI=SFW*(1D0-(PARJ(123)/ECM)**2) + VE=4D0*PARU(102)-1D0 + SF1I=SFF*(VE*POLL+PARJ(132)-PARJ(131)) + SF1W=SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131))) + HF1I=SFI*SF1I + HF1W=SFW*SF1W + ENDIF + +C...Loop over different flavours: charge, velocity. + RTOT=0D0 + RQQ=0D0 + RQV=0D0 + RVA=0D0 + DO 110 KFLC=1,MAX(MSTJ(104),KFL) + IF(KFL.GT.0.AND.KFLC.NE.KFL) GOTO 110 + MSTJ(93)=1 + PMQ=PYMASS(KFLC) + IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 110 + QF=KCHG(KFLC,1)/3D0 + VQ=1D0 + IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(1D0-(2D0*PMQ/ECM)**2) + +C...Calculate R and sum of charges for QED or QFD case. + RQQ=RQQ+3D0*QF**2*POLL + IF(MSTJ(102).LE.1) THEN + RTOT=RTOT+3D0*0.5D0*VQ*(3D0-VQ**2)*QF**2*POLL + ELSE + VF=SIGN(1D0,QF)-4D0*QF*PARU(102) + RQV=RQV-6D0*QF*VF*SF1I + RVA=RVA+3D0*(VF**2+1D0)*SF1W + RTOT=RTOT+3D0*(0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL- + & 2D0*QF*VF*HF1I+VF**2*HF1W)+VQ**3*HF1W) + ENDIF + 110 CONTINUE + RSUM=RQQ + IF(MSTJ(102).GE.2) RSUM=RQQ+SFI*RQV+SFW*RVA + +C...Calculate cross-section, including QCD corrections. + PARJ(141)=RQQ + PARJ(142)=RTOT + PARJ(143)=RTOT*RQCD + PARJ(144)=PARJ(143) + PARJ(145)=PARJ(141)*86.8D0/ECM**2 + PARJ(146)=PARJ(142)*86.8D0/ECM**2 + PARJ(147)=PARJ(143)*86.8D0/ECM**2 + PARJ(148)=PARJ(147) + PARJ(157)=RSUM*RQCD + PARJ(158)=0D0 + PARJ(159)=0D0 + XTOT=PARJ(147) + IF(MSTJ(107).LE.0) RETURN + +C...Virtual cross-section. + XKL=PARJ(135) + XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2) + ALE=2D0*LOG(ECM/PYMASS(11))-1D0 + SIGV=ALE/3D0+2D0*LOG(ECM**2/(PYMASS(13)*PYMASS(15)))/3D0-4D0/3D0+ + &1.526D0*LOG(ECM**2/0.932D0) + +C...Soft and hard radiative cross-section in QED case. + IF(MSTJ(102).LE.1) THEN + SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+2D0*SIGV + SIGS=ALE*(2D0*LOG(XKL)-LOG(1D0-XKL)-XKL) + SIGH=ALE*(2D0*LOG(XKU/XKL)-LOG((1D0-XKU)/(1D0-XKL))-(XKU-XKL)) + +C...Soft and hard radiative cross-section in QFD case. + ELSE + SZM=1D0-(PARJ(123)/ECM)**2 + SZW=PARJ(123)*PARJ(124)/ECM**2 + PARJ(161)=-RQQ/RSUM + PARJ(162)=-(RQQ+RQV+RVA)/RSUM + PARJ(163)=(RQV*(1D0-0.5D0*SZM-SFI)+RVA*(1.5D0-SZM-SFW))/RSUM + PARJ(164)=(RQV*SZW**2*(1D0-2D0*SFW)+RVA*(2D0*SFI+SZW**2- + & 4D0+3D0*SZM-SZM**2))/(SZW*RSUM) + SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+((2D0*RQQ+SFI*RQV)/ + & RSUM)*SIGV+(SZW*SFW*RQV/RSUM)*PARU(1)*20D0/9D0 + SIGS=ALE*(2D0*LOG(XKL)+PARJ(161)*LOG(1D0-XKL)+PARJ(162)*XKL+ + & PARJ(163)*LOG(((XKL-SZM)**2+SZW**2)/(SZM**2+SZW**2))+ + & PARJ(164)*(ATAN((XKL-SZM)/SZW)-ATAN(-SZM/SZW))) + SIGH=ALE*(2D0*LOG(XKU/XKL)+PARJ(161)*LOG((1D0-XKU)/ + & (1D0-XKL))+PARJ(162)*(XKU-XKL)+PARJ(163)* + & LOG(((XKU-SZM)**2+SZW**2)/((XKL-SZM)**2+SZW**2))+ + & PARJ(164)*(ATAN((XKU-SZM)/SZW)-ATAN((XKL-SZM)/SZW))) + ENDIF + +C...Total cross-section and fraction of hard photon events. + PARJ(160)=SIGH/(PARU(1)/PARU(101)+SIGV+SIGS+SIGH) + PARJ(157)=RSUM*(1D0+(PARU(101)/PARU(1))*(SIGV+SIGS+SIGH))*RQCD + PARJ(144)=PARJ(157) + PARJ(148)=PARJ(144)*86.8D0/ECM**2 + XTOT=PARJ(148) + + RETURN + END + +C********************************************************************* + +C...PYRADK +C...Generates initial state photon radiation. + + SUBROUTINE PYRADK(ECM,MK,PAK,THEK,PHIK,ALPK) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + SAVE /PYDAT1/ + +C...Function: cumulative hard photon spectrum in QFD case. + FXK(XX)=2D0*LOG(XX)+PARJ(161)*LOG(1D0-XX)+PARJ(162)*XX+ + &PARJ(163)*LOG((XX-SZM)**2+SZW**2)+PARJ(164)*ATAN((XX-SZM)/SZW) + +C...Determine whether radiative photon or not. + MK=0 + PAK=0D0 + IF(PARJ(160).LT.PYR(0)) RETURN + MK=1 + +C...Photon energy range. Find photon momentum in QED case. + XKL=PARJ(135) + XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2) + IF(MSTJ(102).LE.1) THEN + 100 XK=1D0/(1D0+(1D0/XKL-1D0)*((1D0/XKU-1D0)/(1D0/XKL-1D0))**PYR(0)) + IF(1D0+(1D0-XK)**2.LT.2D0*PYR(0)) GOTO 100 + +C...Ditto in QFD case, by numerical inversion of integrated spectrum. + ELSE + SZM=1D0-(PARJ(123)/ECM)**2 + SZW=PARJ(123)*PARJ(124)/ECM**2 + FXKL=FXK(XKL) + FXKU=FXK(XKU) + FXKD=1D-4*(FXKU-FXKL) + FXKR=FXKL+PYR(0)*(FXKU-FXKL) + NXK=0 + 110 NXK=NXK+1 + XK=0.5D0*(XKL+XKU) + FXKV=FXK(XK) + IF(FXKV.GT.FXKR) THEN + XKU=XK + FXKU=FXKV + ELSE + XKL=XK + FXKL=FXKV + ENDIF + IF(NXK.LT.15.AND.FXKU-FXKL.GT.FXKD) GOTO 110 + XK=XKL+(XKU-XKL)*(FXKR-FXKL)/(FXKU-FXKL) + ENDIF + PAK=0.5D0*ECM*XK + +C...Photon polar and azimuthal angle. + PME=2D0*(PYMASS(11)/ECM)**2 + 120 CTHM=PME*(2D0/PME)**PYR(0) + IF(1D0-(XK**2*CTHM*(1D0-0.5D0*CTHM)+2D0*(1D0-XK)*PME/MAX(PME, + &CTHM*(1D0-0.5D0*CTHM)))/(1D0+(1D0-XK)**2).LT.PYR(0)) GOTO 120 + CTHE=1D0-CTHM + IF(PYR(0).GT.0.5D0) CTHE=-CTHE + STHE=SQRT(MAX(0D0,(CTHM-PME)*(2D0-CTHM))) + THEK=PYANGL(CTHE,STHE) + PHIK=PARU(2)*PYR(0) + +C...Rotation angle for hadronic system. + SGN=1D0 + IF(0.5D0*(2D0-XK*(1D0-CTHE))**2/((2D0-XK)**2+(XK*CTHE)**2).GT. + &PYR(0)) SGN=-1D0 + ALPK=ASIN(SGN*STHE*(XK-SGN*(2D0*SQRT(1D0-XK)-2D0+XK)*CTHE)/ + &(2D0-XK*(1D0-SGN*CTHE))) + + RETURN + END + +C********************************************************************* + +C...PYXKFL +C...Selects flavour for produced qqbar pair. + + SUBROUTINE PYXKFL(KFL,ECM,ECMC,KFLC) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /PYDAT1/,/PYDAT2/ + +C...Calculate maximum weight in QED or QFD case. + IF(MSTJ(102).LE.1) THEN + RFMAX=4D0/9D0 + ELSE + POLL=1D0-PARJ(131)*PARJ(132) + SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102))) + SFW=ECMC**4/((ECMC**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2) + SFI=SFW*(1D0-(PARJ(123)/ECMC)**2) + VE=4D0*PARU(102)-1D0 + HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131)) + HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131))) + RFMAX=MAX(4D0/9D0*POLL-4D0/3D0*(1D0-8D0*PARU(102)/3D0)*HF1I+ + & ((1D0-8D0*PARU(102)/3D0)**2+1D0)*HF1W,1D0/9D0*POLL+2D0/3D0* + & (-1D0+4D0*PARU(102)/3D0)*HF1I+((-1D0+4D0*PARU(102)/3D0)**2+ + & 1D0)*HF1W) + ENDIF + +C...Choose flavour. Gives charge and velocity. + NTRY=0 + 100 NTRY=NTRY+1 + IF(NTRY.GT.100) THEN + CALL PYERRM(14,'(PYXKFL:) caught in an infinite loop') + KFLC=0 + RETURN + ENDIF + KFLC=KFL + IF(KFL.LE.0) KFLC=1+INT(MSTJ(104)*PYR(0)) + MSTJ(93)=1 + PMQ=PYMASS(KFLC) + IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 100 + QF=KCHG(KFLC,1)/3D0 + VQ=1D0 + IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-(2D0*PMQ/ECMC)**2)) + +C...Calculate weight in QED or QFD case. + IF(MSTJ(102).LE.1) THEN + RF=QF**2 + RFV=0.5D0*VQ*(3D0-VQ**2)*QF**2 + ELSE + VF=SIGN(1D0,QF)-4D0*QF*PARU(102) + RF=QF**2*POLL-2D0*QF*VF*HF1I+(VF**2+1D0)*HF1W + RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+VF**2*HF1W)+ + & VQ**3*HF1W + IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV) + ENDIF + +C...Weighting or new event (radiative photon). Cross-section update. + IF(KFL.LE.0.AND.RF.LT.PYR(0)*RFMAX) GOTO 100 + PARJ(158)=PARJ(158)+1D0 + IF(ECMC.LT.2D0*PMQ+PARJ(127).OR.RFV.LT.PYR(0)*RF) KFLC=0 + IF(MSTJ(107).LE.0.AND.KFLC.EQ.0) GOTO 100 + IF(KFLC.NE.0) PARJ(159)=PARJ(159)+1D0 + PARJ(144)=PARJ(157)*PARJ(159)/PARJ(158) + PARJ(148)=PARJ(144)*86.8D0/ECM**2 + + RETURN + END + +C********************************************************************* + +C...PYXJET +C...Selects number of jets in matrix element approach. + + SUBROUTINE PYXJET(ECM,NJET,CUT) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + SAVE /PYDAT1/ +C...Local array and data. + DIMENSION ZHUT(5) + DATA ZHUT/3.0922D0, 6.2291D0, 7.4782D0, 7.8440D0, 8.2560D0/ + +C...Trivial result for two-jets only, including parton shower. + IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN + CUT=0D0 + +C...QCD and Abelian vector gluon theory: Q^2 for jet rate and R. + ELSEIF(MSTJ(109).EQ.0.OR.MSTJ(109).EQ.2) THEN + CF=4D0/3D0 + IF(MSTJ(109).EQ.2) CF=1D0 + IF(MSTJ(111).EQ.0) THEN + Q2=ECM**2 + Q2R=ECM**2 + ELSEIF(MSTU(111).EQ.0) THEN + PARJ(169)=MIN(1D0,PARJ(129)) + Q2=PARJ(169)*ECM**2 + PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/ + & ((33D0-2D0*MSTU(112))*PARU(111))))) + Q2R=PARJ(168)*ECM**2 + ELSE + PARJ(169)=MIN(1D0,MAX(PARJ(129),(2D0*PARU(112)/ECM)**2)) + Q2=PARJ(169)*ECM**2 + PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM, + & (2D0*PARU(112)/ECM)**2)) + Q2R=PARJ(168)*ECM**2 + ENDIF + +C...alpha_strong for R and R itself. + ALSPI=(3D0/4D0)*CF*PYALPS(Q2R)/PARU(1) + IF(IABS(MSTJ(101)).EQ.1) THEN + RQCD=1D0+ALSPI + ELSEIF(MSTJ(109).EQ.0) THEN + RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2 + IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+ + & (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(168))*ALSPI**2) + ELSE + RQCD=1D0+ALSPI-(3D0/32D0+0.519D0*MSTU(118))*(4D0*ALSPI/3D0)**2 + ENDIF + +C...alpha_strong for jet rate. Initial value for y cut. + ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1) + CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2) + IF(IABS(MSTJ(101)).LE.1.OR.(MSTJ(109).EQ.0.AND.MSTJ(111).EQ.0)) + & CUT=MAX(CUT,EXP(-SQRT(0.75D0/ALSPI))/2D0) + IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT)) + +C...Parametrization of first order three-jet cross-section. + 100 IF(MSTJ(101).EQ.0.OR.CUT.GE.0.25D0) THEN + PARJ(152)=0D0 + ELSE + PARJ(152)=(2D0*ALSPI/3D0)*((3D0-6D0*CUT+2D0*LOG(CUT))* + & LOG(CUT/(1D0-2D0*CUT))+(2.5D0+1.5D0*CUT-6.571D0)* + & (1D0-3D0*CUT)+5.833D0*(1D0-3D0*CUT)**2-3.894D0* + & (1D0-3D0*CUT)**3+1.342D0*(1D0-3D0*CUT)**4)/RQCD + IF(MSTJ(109).EQ.2.AND.(MSTJ(101).EQ.2.OR.MSTJ(101).LE.-2)) + & PARJ(152)=0D0 + ENDIF + +C...Parametrization of second order three-jet cross-section. + IF(IABS(MSTJ(101)).LE.1.OR.MSTJ(101).EQ.3.OR.MSTJ(109).EQ.2.OR. + & CUT.GE.0.25D0) THEN + PARJ(153)=0D0 + ELSEIF(MSTJ(110).LE.1) THEN + CT=LOG(1D0/CUT-2D0) + PARJ(153)=ALSPI**2*CT**2*(2.419D0+0.5989D0*CT+0.6782D0*CT**2- + & 0.2661D0*CT**3+0.01159D0*CT**4)/RQCD + +C...Interpolation in second/first order ratio for Zhu parametrization. + ELSEIF(MSTJ(110).EQ.2) THEN + IZA=0 + DO 110 IY=1,5 + IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY + 110 CONTINUE + IF(IZA.NE.0) THEN + ZHURAT=ZHUT(IZA) + ELSE + IZ=100D0*CUT + ZHURAT=ZHUT(IZ)+(100D0*CUT-IZ)*(ZHUT(IZ+1)-ZHUT(IZ)) + ENDIF + PARJ(153)=ALSPI*PARJ(152)*ZHURAT + ENDIF + +C...Shift in second order three-jet cross-section with optimized Q^2. + IF(MSTJ(111).EQ.1.AND.IABS(MSTJ(101)).GE.2.AND.MSTJ(101).NE.3 + & .AND.CUT.LT.0.25D0) PARJ(153)=PARJ(153)+ + & (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(169))*ALSPI*PARJ(152) + +C...Parametrization of second order four-jet cross-section. + IF(IABS(MSTJ(101)).LE.1.OR.CUT.GE.0.125D0) THEN + PARJ(154)=0D0 + ELSE + CT=LOG(1D0/CUT-5D0) + IF(CUT.LE.0.018D0) THEN + XQQGG=6.349D0-4.330D0*CT+0.8304D0*CT**2 + IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(3.035D0-2.091D0*CT+ + & 0.4059D0*CT**2) + XQQQQ=1.25D0*(-0.1080D0+0.01486D0*CT+0.009364D0*CT**2) + IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ + ELSE + XQQGG=-0.09773D0+0.2959D0*CT-0.2764D0*CT**2+0.08832D0*CT**3 + IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(-0.04079D0+ + & 0.1340D0*CT-0.1326D0*CT**2+0.04365D0*CT**3) + XQQQQ=1.25D0*(0.003661D0-0.004888D0*CT-0.001081D0*CT**2+ + & 0.002093D0*CT**3) + IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ + ENDIF + PARJ(154)=ALSPI**2*CT**2*(XQQGG+XQQQQ)/RQCD + PARJ(155)=XQQQQ/(XQQGG+XQQQQ) + ENDIF + +C...If negative three-jet rate, change y' optimization parameter. + IF(MSTJ(111).EQ.1.AND.PARJ(152)+PARJ(153).LT.0D0.AND. + & PARJ(169).LT.0.99D0) THEN + PARJ(169)=MIN(1D0,1.2D0*PARJ(169)) + Q2=PARJ(169)*ECM**2 + ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1) + GOTO 100 + ENDIF + +C...If too high cross-section, use harder cuts, or fail. + IF(PARJ(152)+PARJ(153)+PARJ(154).GE.1) THEN + IF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0.AND.MSTJ(111).EQ.1.AND. + & PARJ(169).LT.0.99D0) THEN + PARJ(169)=MIN(1D0,1.2D0*PARJ(169)) + Q2=PARJ(169)*ECM**2 + ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1) + GOTO 100 + ELSEIF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0) THEN + CALL PYERRM(26, + & '(PYXJET:) no allowed y cut value for Zhu parametrization') + ENDIF + CUT=0.26D0*(4D0*CUT)**(PARJ(152)+PARJ(153)+ + & PARJ(154))**(-1D0/3D0) + IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT)) + GOTO 100 + ENDIF + +C...Scalar gluon (first order only). + ELSE + ALSPI=PYALPS(ECM**2)/PARU(1) + CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2,EXP(-3D0/ALSPI)) + PARJ(152)=0D0 + IF(CUT.LT.0.25D0) PARJ(152)=(ALSPI/3D0)*((1D0-2D0*CUT)* + & LOG((1D0-2D0*CUT)/CUT)+0.5D0*(9D0*CUT**2-1D0)) + PARJ(153)=0D0 + PARJ(154)=0D0 + ENDIF + +C...Select number of jets. + PARJ(150)=CUT + IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN + NJET=2 + ELSEIF(MSTJ(101).LE.0) THEN + NJET=MIN(4,2-MSTJ(101)) + ELSE + RNJ=PYR(0) + NJET=2 + IF(PARJ(152)+PARJ(153)+PARJ(154).GT.RNJ) NJET=3 + IF(PARJ(154).GT.RNJ) NJET=4 + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYX3JT +C...Selects the kinematical variables of three-jet events. + + SUBROUTINE PYX3JT(NJET,CUT,KFL,ECM,X1,X2) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + SAVE /PYDAT1/ +C...Local array. + DIMENSION ZHUP(5,12) + +C...Coefficients of Zhu second order parametrization. + DATA ((ZHUP(IC1,IC2),IC2=1,12),IC1=1,5)/ + &18.29D0, 89.56D0, 4.541D0, -52.09D0, -109.8D0, 24.90D0, + &11.63D0, 3.683D0, 17.50D0,0.002440D0, -1.362D0,-0.3537D0, + &11.42D0, 6.299D0, -22.55D0, -8.915D0, 59.25D0, -5.855D0, + &-32.85D0, -1.054D0, -16.90D0,0.006489D0,-0.8156D0,0.01095D0, + &7.847D0, -3.964D0, -35.83D0, 1.178D0, 29.39D0, 0.2806D0, + &47.82D0, -12.36D0, -56.72D0, 0.04054D0,-0.4365D0, 0.6062D0, + &5.441D0, -56.89D0, -50.27D0, 15.13D0, 114.3D0, -18.19D0, + &97.05D0, -1.890D0, -139.9D0, 0.08153D0,-0.4984D0, 0.9439D0, + &-17.65D0, 51.44D0, -58.32D0, 70.95D0, -255.7D0, -78.99D0, + &476.9D0, 29.65D0, -239.3D0, 0.4745D0, -1.174D0, 6.081D0/ + +C...Dilogarithm of x for x<0.5 (x>0.5 obtained by analytic trick). + DILOG(X)=X+X**2/4D0+X**3/9D0+X**4/16D0+X**5/25D0+X**6/36D0+ + &X**7/49D0 + +C...Event type. Mass effect factors and other common constants. + MSTJ(120)=2 + MSTJ(121)=0 + PMQ=PYMASS(KFL) + QME=(2D0*PMQ/ECM)**2 + IF(MSTJ(109).NE.1) THEN + CUTL=LOG(CUT) + CUTD=LOG(1D0/CUT-2D0) + IF(MSTJ(109).EQ.0) THEN + CF=4D0/3D0 + CN=3D0 + TR=2D0 + WTMX=MIN(20D0,37D0-6D0*CUTD) + IF(MSTJ(110).EQ.2) WTMX=2D0*(7.5D0+80D0*CUT) + ELSE + CF=1D0 + CN=0D0 + TR=12D0 + WTMX=0D0 + ENDIF + +C...Alpha_strong and effects of optimized Q^2 scale. Maximum weight. + ALS2PI=PARU(118)/PARU(2) + WTOPT=0D0 + IF(MSTJ(111).EQ.1) WTOPT=(33D0-2D0*MSTU(112))/6D0* + & LOG(PARJ(169))*ALS2PI + WTMAX=MAX(0D0,1D0+WTOPT+ALS2PI*WTMX) + +C...Choose three-jet events in allowed region. + 100 NJET=3 + 110 Y13L=CUTL+CUTD*PYR(0) + Y23L=CUTL+CUTD*PYR(0) + Y13=EXP(Y13L) + Y23=EXP(Y23L) + Y12=1D0-Y13-Y23 + IF(Y12.LE.CUT) GOTO 110 + IF(Y13**2+Y23**2+2D0*Y12.LE.2D0*PYR(0)) GOTO 110 + +C...Second order corrections. + IF(MSTJ(101).EQ.2.AND.MSTJ(110).LE.1) THEN + Y12L=LOG(Y12) + Y13M=LOG(1D0-Y13) + Y23M=LOG(1D0-Y23) + Y12M=LOG(1D0-Y12) + IF(Y13.LE.0.5D0) Y13I=DILOG(Y13) + IF(Y13.GE.0.5D0) Y13I=1.644934D0-Y13L*Y13M-DILOG(1D0-Y13) + IF(Y23.LE.0.5D0) Y23I=DILOG(Y23) + IF(Y23.GE.0.5D0) Y23I=1.644934D0-Y23L*Y23M-DILOG(1D0-Y23) + IF(Y12.LE.0.5D0) Y12I=DILOG(Y12) + IF(Y12.GE.0.5D0) Y12I=1.644934D0-Y12L*Y12M-DILOG(1D0-Y12) + WT1=(Y13**2+Y23**2+2D0*Y12)/(Y13*Y23) + WT2=CF*(-2D0*(CUTL-Y12L)**2-3D0*CUTL-1D0+3.289868D0+ + & 2D0*(2D0*CUTL-Y12L)*CUT/Y12)+ + & CN*((CUTL-Y12L)**2-(CUTL-Y13L)**2-(CUTL-Y23L)**2- + & 11D0*CUTL/6D0+67D0/18D0+1.644934D0-(2D0*CUTL-Y12L)*CUT/Y12+ + & (2D0*CUTL-Y13L)*CUT/Y13+(2D0*CUTL-Y23L)*CUT/Y23)+ + & TR*(2D0*CUTL/3D0-10D0/9D0)+ + & CF*(Y12/(Y12+Y13)+Y12/(Y12+Y23)+(Y12+Y23)/Y13+(Y12+Y13)/Y23+ + & Y13L*(4D0*Y12**2+2D0*Y12*Y13+4D0*Y12*Y23+Y13*Y23)/ + & (Y12+Y23)**2+Y23L*(4D0*Y12**2+2D0*Y12*Y23+4D0*Y12*Y13+ + & Y13*Y23)/(Y12+Y13)**2)/WT1+ + & CN*(Y13L*Y13/(Y12+Y23)+Y23L*Y23/(Y12+Y13))/WT1+(CN-2D0*CF)* + & ((Y12**2+(Y12+Y13)**2)*(Y12L*Y23L-Y12L*Y12M-Y23L* + & Y23M+1.644934D0-Y12I-Y23I)/(Y13*Y23)+(Y12**2+(Y12+Y23)**2)* + & (Y12L*Y13L-Y12L*Y12M-Y13L*Y13M+1.644934D0-Y12I-Y13I)/ + & (Y13*Y23)+(Y13**2+Y23**2)/(Y13*Y23*(Y13+Y23))- + & 2D0*Y12L*Y12**2/(Y13+Y23)**2-4D0*Y12L*Y12/(Y13+Y23))/WT1- + & CN*(Y13L*Y23L-Y13L*Y13M-Y23L*Y23M+1.644934D0-Y13I-Y23I) + IF(1D0+WTOPT+ALS2PI*WT2.LE.0D0) MSTJ(121)=1 + IF(1D0+WTOPT+ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110 + PARJ(156)=(WTOPT+ALS2PI*WT2)/(1D0+WTOPT+ALS2PI*WT2) + + ELSEIF(MSTJ(101).EQ.2.AND.MSTJ(110).EQ.2) THEN +C...Second order corrections; Zhu parametrization of ERT. + ZX=(Y23-Y13)**2 + ZY=1D0-Y12 + IZA=0 + DO 120 IY=1,5 + IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY + 120 CONTINUE + IF(IZA.NE.0) THEN + IZ=IZA + WT2=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+ + & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+ + & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+ + & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY + ELSE + IZ=100D0*CUT + WTL=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+ + & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+ + & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+ + & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY + IZ=IZ+1 + WTU=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+ + & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+ + & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+ + & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY + WT2=WTL+(WTU-WTL)*(100D0*CUT+1D0-IZ) + ENDIF + IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.0D0) MSTJ(121)=1 + IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110 + PARJ(156)=(WTOPT+2D0*ALS2PI*WT2)/(1D0+WTOPT+2D0*ALS2PI*WT2) + ENDIF + +C...Impose mass cuts (gives two jets). For fixed jet number new try. + X1=1D0-Y23 + X2=1D0-Y13 + X3=1D0-Y12 + IF(4D0*Y23*Y13*Y12/X3**2.LE.QME) NJET=2 + IF(MOD(MSTJ(103),4).GE.2.AND.IABS(MSTJ(101)).LE.1.AND.QME*X3+ + & 0.5D0*QME**2+(0.5D0*QME+0.25D0*QME**2)*((1D0-X2)/(1D0-X1)+ + & (1D0-X1)/(1D0-X2)).GT.(X1**2+X2**2)*PYR(0)) NJET=2 + IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 100 + +C...Scalar gluon model (first order only, no mass effects). + ELSE + 130 NJET=3 + 140 X3=SQRT(4D0*CUT**2+PYR(0)*((1D0-CUT)**2-4D0*CUT**2)) + IF(LOG((X3-CUT)/CUT).LE.PYR(0)*LOG((1D0-2D0*CUT)/CUT)) GOTO 140 + YD=SIGN(2D0*CUT*((X3-CUT)/CUT)**PYR(0)-X3,PYR(0)-0.5D0) + X1=1D0-0.5D0*(X3+YD) + X2=1D0-0.5D0*(X3-YD) + IF(4D0*(1D0-X1)*(1D0-X2)*(1D0-X3)/X3**2.LE.QME) NJET=2 + IF(MSTJ(102).GE.2) THEN + IF(X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*PARJ(171).LT. + & X3**2*PYR(0)) NJET=2 + ENDIF + IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 130 + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYX4JT +C...Selects the kinematical variables of four-jet events. + + SUBROUTINE PYX4JT(NJET,CUT,KFL,ECM,KFLN,X1,X2,X4,X12,X14) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + SAVE /PYDAT1/ +C...Local arrays. + DIMENSION WTA(4),WTB(4),WTC(4),WTD(4),WTE(4) + +C...Common constants. Colour factors for QCD and Abelian gluon theory. + PMQ=PYMASS(KFL) + QME=(2D0*PMQ/ECM)**2 + CT=LOG(1D0/CUT-5D0) + IF(MSTJ(109).EQ.0) THEN + CF=4D0/3D0 + CN=3D0 + TR=2.5D0 + ELSE + CF=1D0 + CN=0D0 + TR=15D0 + ENDIF + +C...Choice of process (qqbargg or qqbarqqbar). + 100 NJET=4 + IT=1 + IF(PARJ(155).GT.PYR(0)) IT=2 + IF(MSTJ(101).LE.-3) IT=-MSTJ(101)-2 + IF(IT.EQ.1) WTMX=0.7D0/CUT**2 + IF(IT.EQ.1.AND.MSTJ(109).EQ.2) WTMX=0.6D0/CUT**2 + IF(IT.EQ.2) WTMX=0.1125D0*CF*TR/CUT**2 + ID=1 + +C...Sample the five kinematical variables (for qqgg preweighted in y34). + 110 Y134=3D0*CUT+(1D0-6D0*CUT)*PYR(0) + Y234=3D0*CUT+(1D0-6D0*CUT)*PYR(0) + IF(IT.EQ.1) Y34=(1D0-5D0*CUT)*EXP(-CT*PYR(0)) + IF(IT.EQ.2) Y34=CUT+(1D0-6D0*CUT)*PYR(0) + IF(Y34.LE.Y134+Y234-1D0.OR.Y34.GE.Y134*Y234) GOTO 110 + VT=PYR(0) + CP=COS(PARU(1)*PYR(0)) + Y14=(Y134-Y34)*VT + Y13=Y134-Y14-Y34 + VB=Y34*(1D0-Y134-Y234+Y34)/((Y134-Y34)*(Y234-Y34)) + Y24=0.5D0*(Y234-Y34)*(1D0-4D0*SQRT(MAX(0D0,VT*(1D0-VT)* + &VB*(1D0-VB)))*CP-(1D0-2D0*VT)*(1D0-2D0*VB)) + Y23=Y234-Y34-Y24 + Y12=1D0-Y134-Y23-Y24 + IF(MIN(Y12,Y13,Y14,Y23,Y24).LE.CUT) GOTO 110 + Y123=Y12+Y13+Y23 + Y124=Y12+Y14+Y24 + +C...Calculate matrix elements for qqgg or qqqq process. + IC=0 + WTTOT=0D0 + 120 IC=IC+1 + IF(IT.EQ.1) THEN + WTA(IC)=(Y12*Y34**2-Y13*Y24*Y34+Y14*Y23*Y34+3D0*Y12*Y23*Y34+ + & 3D0*Y12*Y14*Y34+4D0*Y12**2*Y34-Y13*Y23*Y24+2D0*Y12*Y23*Y24- + & Y13*Y14*Y24-2D0*Y12*Y13*Y24+2D0*Y12**2*Y24+Y14*Y23**2+2D0*Y12* + & Y23**2+Y14**2*Y23+4D0*Y12*Y14*Y23+4D0*Y12**2*Y23+2D0*Y12*Y14**2+ + & 2D0*Y12*Y13*Y14+4D0*Y12**2*Y14+2D0*Y12**2*Y13+2D0*Y12**3)/ + & (2D0*Y13*Y134*Y234*Y24)+(Y24*Y34+Y12*Y34+Y13*Y24- + & Y14*Y23+Y12*Y13)/(Y13*Y134**2)+2D0*Y23*(1D0-Y13)/ + & (Y13*Y134*Y24)+Y34/(2D0*Y13*Y24) + WTB(IC)=(Y12*Y24*Y34+Y12*Y14*Y34-Y13*Y24**2+Y13*Y14*Y24+2D0*Y12* + & Y14*Y24)/(Y13*Y134*Y23*Y14)+Y12*(1D0+Y34)*Y124/(Y134*Y234*Y14* + & Y24)-(2D0*Y13*Y24+Y14**2+Y13*Y23+2D0*Y12*Y13)/(Y13*Y134*Y14)+ + & Y12*Y123*Y124/(2D0*Y13*Y14*Y23*Y24) + WTC(IC)=-(5D0*Y12*Y34**2+2D0*Y12*Y24*Y34+2D0*Y12*Y23*Y34+ + & 2D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+4D0*Y12**2*Y34-Y13*Y24**2+ + & Y14*Y23*Y24+Y13*Y23*Y24+Y13*Y14*Y24-Y12*Y14*Y24-Y13**2*Y24- + & 3D0*Y12*Y13*Y24-Y14*Y23**2-Y14**2*Y23+Y13*Y14*Y23- + & 3D0*Y12*Y14*Y23-Y12*Y13*Y23)/(4D0*Y134*Y234*Y34**2)+ + & (3D0*Y12*Y34**2-3D0*Y13*Y24*Y34+3D0*Y12*Y24*Y34+ + & 3D0*Y14*Y23*Y34-Y13*Y24**2-Y12*Y23*Y34+6D0*Y12*Y14*Y34+ + & 2D0*Y12*Y13*Y34-2D0*Y12**2*Y34+Y14*Y23*Y24-3D0*Y13*Y23*Y24- + & 2D0*Y13*Y14*Y24+4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+ + & 3D0*Y14*Y23**2+2D0*Y14**2*Y23+2D0*Y14**2*Y12+ + & 2D0*Y12**2*Y14+6D0*Y12*Y14*Y23-2D0*Y12*Y13**2- + & 2D0*Y12**2*Y13)/(4D0*Y13*Y134*Y234*Y34) + WTC(IC)=WTC(IC)+(2D0*Y12*Y34**2-2D0*Y13*Y24*Y34+Y12*Y24*Y34+ + & 4D0*Y13*Y23*Y34+4D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+2D0*Y12**2*Y34- + & Y13*Y24**2+3D0*Y14*Y23*Y24+4D0*Y13*Y23*Y24-2D0*Y13*Y14*Y24+ + & 4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+2D0*Y14*Y23**2+4D0*Y13*Y23**2+ + & 2D0*Y13*Y14*Y23+2D0*Y12*Y14*Y23+4D0*Y12*Y13*Y23+2D0*Y12*Y14**2+ + & 4D0*Y12**2*Y13+4D0*Y12*Y13*Y14+2D0*Y12**2*Y14)/ + & (4D0*Y13*Y134*Y24*Y34)-(Y12*Y34**2-2D0*Y14*Y24*Y34- + & 2D0*Y13*Y24*Y34-Y14*Y23*Y34+Y13*Y23*Y34+Y12*Y14*Y34+ + & 2D0*Y12*Y13*Y34-2D0*Y14**2*Y24-4D0*Y13*Y14*Y24- + & 4D0*Y13**2*Y24-Y14**2*Y23-Y13**2*Y23+Y12*Y13*Y14- + & Y12*Y13**2)/(2D0*Y13*Y34*Y134**2)+(Y12*Y34**2- + & 4D0*Y14*Y24*Y34-2D0*Y13*Y24*Y34-2D0*Y14*Y23*Y34- + & 4D0*Y13*Y23*Y34-4D0*Y12*Y14*Y34-4D0*Y12*Y13*Y34- + & 2D0*Y13*Y14*Y24+2D0*Y13**2*Y24+2D0*Y14**2*Y23- + & 2D0*Y13*Y14*Y23-Y12*Y14**2-6D0*Y12*Y13*Y14- + & Y12*Y13**2)/(4D0*Y34**2*Y134**2) + WTTOT=WTTOT+Y34*CF*(CF*WTA(IC)+(CF-0.5D0*CN)*WTB(IC)+ + & CN*WTC(IC))/8D0 + ELSE + WTD(IC)=(Y13*Y23*Y34+Y12*Y23*Y34-Y12**2*Y34+Y13*Y23*Y24+2D0*Y12* + & Y23*Y24-Y14*Y23**2+Y12*Y13*Y24+Y12*Y14*Y23+Y12*Y13*Y14)/(Y13**2* + & Y123**2)-(Y12*Y34**2-Y13*Y24*Y34+Y12*Y24*Y34-Y14*Y23*Y34-Y12* + & Y23*Y34-Y13*Y24**2+Y14*Y23*Y24-Y13*Y23*Y24-Y13**2*Y24+Y14* + & Y23**2)/(Y13**2*Y123*Y134)+(Y13*Y14*Y12+Y34*Y14*Y12-Y34**2*Y12+ + & Y13*Y14*Y24+2D0*Y34*Y14*Y24-Y23*Y14**2+Y34*Y13*Y24+Y34*Y23*Y14+ + & Y34*Y13*Y23)/(Y13**2*Y134**2)-(Y34*Y12**2-Y13*Y24*Y12+Y34*Y24* + & Y12-Y23*Y14*Y12-Y34*Y14*Y12-Y13*Y24**2+Y23*Y14*Y24-Y13*Y14*Y24- + & Y13**2*Y24+Y23*Y14**2)/(Y13**2*Y134*Y123) + WTE(IC)=(Y12*Y34*(Y23-Y24+Y14+Y13)+Y13*Y24**2-Y14*Y23*Y24+Y13* + & Y23*Y24+Y13*Y14*Y24+Y13**2*Y24-Y14*Y23*(Y14+Y23+Y13))/(Y13*Y23* + & Y123*Y134)-Y12*(Y12*Y34-Y23*Y24-Y13*Y24-Y14*Y23-Y14*Y13)/(Y13* + & Y23*Y123**2)-(Y14+Y13)*(Y24+Y23)*Y34/(Y13*Y23*Y134*Y234)+ + & (Y12*Y34*(Y14-Y24+Y23+Y13)+Y13*Y24**2-Y23*Y14*Y24+Y13*Y14*Y24+ + & Y13*Y23*Y24+Y13**2*Y24-Y23*Y14*(Y14+Y23+Y13))/(Y13*Y14*Y134* + & Y123)-Y34*(Y34*Y12-Y14*Y24-Y13*Y24-Y23*Y14-Y23*Y13)/(Y13*Y14* + & Y134**2)-(Y23+Y13)*(Y24+Y14)*Y12/(Y13*Y14*Y123*Y124) + WTTOT=WTTOT+CF*(TR*WTD(IC)+(CF-0.5D0*CN)*WTE(IC))/16D0 + ENDIF + +C...Permutations of momenta in matrix element. Weighting. + 130 IF(IC.EQ.1.OR.IC.EQ.3.OR.ID.EQ.2.OR.ID.EQ.3) THEN + YSAV=Y13 + Y13=Y14 + Y14=YSAV + YSAV=Y23 + Y23=Y24 + Y24=YSAV + YSAV=Y123 + Y123=Y124 + Y124=YSAV + ENDIF + IF(IC.EQ.2.OR.IC.EQ.4.OR.ID.EQ.3.OR.ID.EQ.4) THEN + YSAV=Y13 + Y13=Y23 + Y23=YSAV + YSAV=Y14 + Y14=Y24 + Y24=YSAV + YSAV=Y134 + Y134=Y234 + Y234=YSAV + ENDIF + IF(IC.LE.3) GOTO 120 + IF(ID.EQ.1.AND.WTTOT.LT.PYR(0)*WTMX) GOTO 110 + IC=5 + +C...qqgg events: string configuration and event type. + IF(IT.EQ.1) THEN + IF(MSTJ(109).EQ.0.AND.ID.EQ.1) THEN + PARJ(156)=Y34*(2D0*(WTA(1)+WTA(2)+WTA(3)+WTA(4))+4D0*(WTC(1)+ + & WTC(2)+WTC(3)+WTC(4)))/(9D0*WTTOT) + IF(WTA(2)+WTA(4)+2D0*(WTC(2)+WTC(4)).GT.PYR(0)*(WTA(1)+WTA(2)+ + & WTA(3)+WTA(4)+2D0*(WTC(1)+WTC(2)+WTC(3)+WTC(4)))) ID=2 + IF(ID.EQ.2) GOTO 130 + ELSEIF(MSTJ(109).EQ.2.AND.ID.EQ.1) THEN + PARJ(156)=Y34*(WTA(1)+WTA(2)+WTA(3)+WTA(4))/(8D0*WTTOT) + IF(WTA(2)+WTA(4).GT.PYR(0)*(WTA(1)+WTA(2)+WTA(3)+WTA(4))) ID=2 + IF(ID.EQ.2) GOTO 130 + ENDIF + MSTJ(120)=3 + IF(MSTJ(109).EQ.0.AND.0.5D0*Y34*(WTC(1)+WTC(2)+WTC(3)+ + & WTC(4)).GT.PYR(0)*WTTOT) MSTJ(120)=4 + KFLN=21 + +C...Mass cuts. Kinematical variables out. + IF(Y12.LE.CUT+QME) NJET=2 + IF(NJET.EQ.2) GOTO 150 + Q12=0.5D0*(1D0-SQRT(1D0-QME/Y12)) + X1=1D0-(1D0-Q12)*Y234-Q12*Y134 + X4=1D0-(1D0-Q12)*Y134-Q12*Y234 + X2=1D0-Y124 + X12=(1D0-Q12)*Y13+Q12*Y23 + X14=Y12-0.5D0*QME + IF(Y134*Y234/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2 + +C...qqbarqqbar events: string configuration, choose new flavour. + ELSE + IF(ID.EQ.1) THEN + WTR=PYR(0)*(WTD(1)+WTD(2)+WTD(3)+WTD(4)) + IF(WTR.LT.WTD(2)+WTD(3)+WTD(4)) ID=2 + IF(WTR.LT.WTD(3)+WTD(4)) ID=3 + IF(WTR.LT.WTD(4)) ID=4 + IF(ID.GE.2) GOTO 130 + ENDIF + MSTJ(120)=5 + PARJ(156)=CF*TR*(WTD(1)+WTD(2)+WTD(3)+WTD(4))/(16D0*WTTOT) + 140 KFLN=1+INT(5D0*PYR(0)) + IF(KFLN.NE.KFL.AND.0.2D0*PARJ(156).LE.PYR(0)) GOTO 140 + IF(KFLN.EQ.KFL.AND.1D0-0.8D0*PARJ(156).LE.PYR(0)) GOTO 140 + IF(KFLN.GT.MSTJ(104)) NJET=2 + PMQN=PYMASS(KFLN) + QMEN=(2D0*PMQN/ECM)**2 + +C...Mass cuts. Kinematical variables out. + IF(Y24.LE.CUT+QME.OR.Y13.LE.1.1D0*QMEN) NJET=2 + IF(NJET.EQ.2) GOTO 150 + Q24=0.5D0*(1D0-SQRT(1D0-QME/Y24)) + Q13=0.5D0*(1D0-SQRT(1D0-QMEN/Y13)) + X1=1D0-(1D0-Q24)*Y123-Q24*Y134 + X4=1D0-(1D0-Q24)*Y134-Q24*Y123 + X2=1D0-(1D0-Q13)*Y234-Q13*Y124 + X12=(1D0-Q24)*((1D0-Q13)*Y14+Q13*Y34)+Q24*((1D0-Q13)*Y12+ + & Q13*Y23) + X14=Y24-0.5D0*QME + X34=(1D0-Q24)*((1D0-Q13)*Y23+Q13*Y12)+Q24*((1D0-Q13)*Y34+ + & Q13*Y14) + IF(PMQ**2+PMQN**2+MIN(X12,X34)*ECM**2.LE. + & (PARJ(127)+PMQ+PMQN)**2) NJET=2 + IF(Y123*Y134/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2 + ENDIF + 150 IF(MSTJ(101).LE.-2.AND.NJET.EQ.2) GOTO 100 + + RETURN + END + +C********************************************************************* + +C...PYXDIF +C...Gives the angular orientation of events. + + SUBROUTINE PYXDIF(NC,NJET,KFL,ECM,CHI,THE,PHI) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ + +C...Charge. Factors depending on polarization for QED case. + QF=KCHG(KFL,1)/3D0 + POLL=1D0-PARJ(131)*PARJ(132) + POLD=PARJ(132)-PARJ(131) + IF(MSTJ(102).LE.1.OR.MSTJ(109).EQ.1) THEN + HF1=POLL + HF2=0D0 + HF3=PARJ(133)**2 + HF4=0D0 + +C...Factors depending on flavour, energy and polarization for QFD case. + ELSE + SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102))) + SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2) + SFI=SFW*(1D0-(PARJ(123)/ECM)**2) + AE=-1D0 + VE=4D0*PARU(102)-1D0 + AF=SIGN(1D0,QF) + VF=AF-4D0*QF*PARU(102) + HF1=QF**2*POLL-2D0*QF*VF*SFI*SFF*(VE*POLL-AE*POLD)+ + & (VF**2+AF**2)*SFW*SFF**2*((VE**2+AE**2)*POLL-2D0*VE*AE*POLD) + HF2=-2D0*QF*AF*SFI*SFF*(AE*POLL-VE*POLD)+2D0*VF*AF*SFW*SFF**2* + & (2D0*VE*AE*POLL-(VE**2+AE**2)*POLD) + HF3=PARJ(133)**2*(QF**2-2D0*QF*VF*SFI*SFF*VE+(VF**2+AF**2)* + & SFW*SFF**2*(VE**2-AE**2)) + HF4=-PARJ(133)**2*2D0*QF*VF*SFW*(PARJ(123)*PARJ(124)/ECM**2)* + & SFF*AE + ENDIF + +C...Mass factor. Differential cross-sections for two-jet events. + SQ2=SQRT(2D0) + QME=0D0 + IF(MSTJ(103).GE.4.AND.IABS(MSTJ(101)).LE.1.AND.MSTJ(102).LE.1.AND. + &MSTJ(109).NE.1) QME=(2D0*PYMASS(KFL)/ECM)**2 + IF(NJET.EQ.2) THEN + SIGU=4D0*SQRT(1D0-QME) + SIGL=2D0*QME*SQRT(1D0-QME) + SIGT=0D0 + SIGI=0D0 + SIGA=0D0 + SIGP=4D0 + +C...Kinematical variables. Reduce four-jet event to three-jet one. + ELSE + IF(NJET.EQ.3) THEN + X1=2D0*P(NC+1,4)/ECM + X2=2D0*P(NC+3,4)/ECM + ELSE + ECMR=P(NC+1,4)+P(NC+4,4)+SQRT((P(NC+2,1)+P(NC+3,1))**2+ + & (P(NC+2,2)+P(NC+3,2))**2+(P(NC+2,3)+P(NC+3,3))**2) + X1=2D0*P(NC+1,4)/ECMR + X2=2D0*P(NC+4,4)/ECMR + ENDIF + +C...Differential cross-sections for three-jet (or reduced four-jet). + XQ=(1D0-X1)/(1D0-X2) + CT12=(X1*X2-2D0*X1-2D0*X2+2D0+QME)/SQRT((X1**2-QME)*(X2**2-QME)) + ST12=SQRT(1D0-CT12**2) + IF(MSTJ(109).NE.1) THEN + SIGU=2D0*X1**2+X2**2*(1D0+CT12**2)-QME*(3D0+CT12**2-X1-X2)- + & QME*X1/XQ+0.5D0*QME*((X2**2-QME)*ST12**2-2D0*X2)*XQ + SIGL=(X2*ST12)**2-QME*(3D0-CT12**2-2.5D0*(X1+X2)+X1*X2+QME)+ + & 0.5D0*QME*(X1**2-X1-QME)/XQ+0.5D0*QME*((X2**2-QME)*CT12**2- + & X2)*XQ + SIGT=0.5D0*(X2**2-QME-0.5D0*QME*(X2**2-QME)/XQ)*ST12**2 + SIGI=((1D0-0.5D0*QME*XQ)*(X2**2-QME)*ST12*CT12+ + & QME*(1D0-X1-X2+0.5D0*X1*X2+0.5D0*QME)*ST12/CT12)/SQ2 + SIGA=X2**2*ST12/SQ2 + SIGP=2D0*(X1**2-X2**2*CT12) + +C...Differential cross-sect for scalar gluons (no mass effects). + ELSE + X3=2D0-X1-X2 + XT=X2*ST12 + CT13=SQRT(MAX(0D0,1D0-(XT/X3)**2)) + SIGU=(1D0-PARJ(171))*(X3**2-0.5D0*XT**2)+ + & PARJ(171)*(X3**2-0.5D0*XT**2-4D0*(1D0-X1)*(1D0-X2)**2/X1) + SIGL=(1D0-PARJ(171))*0.5D0*XT**2+ + & PARJ(171)*0.5D0*(1D0-X1)**2*XT**2 + SIGT=(1D0-PARJ(171))*0.25D0*XT**2+ + & PARJ(171)*0.25D0*XT**2*(1D0-2D0*X1) + SIGI=-(0.5D0/SQ2)*((1D0-PARJ(171))*XT*X3*CT13+ + & PARJ(171)*XT*((1D0-2D0*X1)*X3*CT13-X1*(X1-X2))) + SIGA=(0.25D0/SQ2)*XT*(2D0*(1D0-X1)-X1*X3) + SIGP=X3**2-2D0*(1D0-X1)*(1D0-X2)/X1 + ENDIF + ENDIF + +C...Upper bounds for differential cross-section. + HF1A=ABS(HF1) + HF2A=ABS(HF2) + HF3A=ABS(HF3) + HF4A=ABS(HF4) + SIGMAX=(2D0*HF1A+HF3A+HF4A)*ABS(SIGU)+2D0*(HF1A+HF3A+HF4A)* + &ABS(SIGL)+2D0*(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGT)+2D0*SQ2* + &(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGI)+4D0*SQ2*HF2A*ABS(SIGA)+ + &2D0*HF2A*ABS(SIGP) + +C...Generate angular orientation according to differential cross-sect. + 100 CHI=PARU(2)*PYR(0) + CTHE=2D0*PYR(0)-1D0 + PHI=PARU(2)*PYR(0) + CCHI=COS(CHI) + SCHI=SIN(CHI) + C2CHI=COS(2D0*CHI) + S2CHI=SIN(2D0*CHI) + THE=ACOS(CTHE) + STHE=SIN(THE) + C2PHI=COS(2D0*(PHI-PARJ(134))) + S2PHI=SIN(2D0*(PHI-PARJ(134))) + SIG=((1D0+CTHE**2)*HF1+STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGU+ + &2D0*(STHE**2*HF1-STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGL+ + &2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)*C2CHI*C2PHI-2D0*CTHE*S2CHI* + &S2PHI)*HF3-((1D0+CTHE**2)*C2CHI*S2PHI+2D0*CTHE*S2CHI*C2PHI)*HF4)* + &SIGT-2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE*(CTHE*CCHI*C2PHI- + &SCHI*S2PHI)*HF3+2D0*STHE*(CTHE*CCHI*S2PHI+SCHI*C2PHI)*HF4)*SIGI+ + &4D0*SQ2*STHE*CCHI*HF2*SIGA+2D0*CTHE*HF2*SIGP + IF(SIG.LT.SIGMAX*PYR(0)) GOTO 100 + + RETURN + END + +C********************************************************************* + +C...PYONIA +C...Generates Upsilon and toponium decays into three gluons +C...or two gluons and a photon. + + SUBROUTINE PYONIA(KFL,ECM) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ + +C...Printout. Check input parameters. + IF(MSTU(12).NE.12345) CALL PYLIST(0) + IF(KFL.LT.0.OR.KFL.GT.8) THEN + CALL PYERRM(16,'(PYONIA:) called with unknown flavour code') + IF(MSTU(21).GE.1) RETURN + ENDIF + IF(ECM.LT.PARJ(127)+2.02D0*PARF(101)) THEN + CALL PYERRM(16,'(PYONIA:) called with too small CM energy') + IF(MSTU(21).GE.1) RETURN + ENDIF + +C...Initial e+e- and onium state (optional). + NC=0 + IF(MSTJ(115).GE.2) THEN + NC=NC+2 + CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0) + K(NC-1,1)=21 + CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0) + K(NC,1)=21 + ENDIF + KFLC=IABS(KFL) + IF(MSTJ(115).GE.3.AND.KFLC.GE.5) THEN + NC=NC+1 + KF=110*KFLC+3 + MSTU10=MSTU(10) + MSTU(10)=1 + P(NC,5)=ECM + CALL PY1ENT(NC,KF,ECM,0D0,0D0) + K(NC,1)=21 + K(NC,3)=1 + MSTU(10)=MSTU10 + ENDIF + +C...Choose x1 and x2 according to matrix element. + NTRY=0 + 100 X1=PYR(0) + X2=PYR(0) + X3=2D0-X1-X2 + IF(X3.GE.1D0.OR.((1D0-X1)/(X2*X3))**2+((1D0-X2)/(X1*X3))**2+ + &((1D0-X3)/(X1*X2))**2.LE.2D0*PYR(0)) GOTO 100 + NTRY=NTRY+1 + NJET=3 + IF(MSTJ(101).LE.4) CALL PY3ENT(NC+1,21,21,21,ECM,X1,X3) + IF(MSTJ(101).GE.5) CALL PY3ENT(-(NC+1),21,21,21,ECM,X1,X3) + +C...Photon-gluon-gluon events. Small system modifications. Jet origin. + MSTU(111)=MSTJ(108) + IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1)) + &MSTU(111)=1 + PARU(112)=PARJ(121) + IF(MSTU(111).EQ.2) PARU(112)=PARJ(122) + QF=0D0 + IF(KFLC.NE.0) QF=KCHG(KFLC,1)/3D0 + RGAM=7.2D0*QF**2*PARU(101)/PYALPS(ECM**2) + MK=0 + ECMC=ECM + IF(PYR(0).GT.RGAM/(1D0+RGAM)) THEN + IF(1D0-MAX(X1,X2,X3).LE.MAX((PARJ(126)/ECM)**2,PARJ(125))) + & NJET=2 + IF(NJET.EQ.2.AND.MSTJ(101).LE.4) CALL PY2ENT(NC+1,21,21,ECM) + IF(NJET.EQ.2.AND.MSTJ(101).GE.5) CALL PY2ENT(-(NC+1),21,21,ECM) + ELSE + MK=1 + ECMC=SQRT(1D0-X1)*ECM + IF(ECMC.LT.2D0*PARJ(127)) GOTO 100 + K(NC+1,1)=1 + K(NC+1,2)=22 + K(NC+1,4)=0 + K(NC+1,5)=0 + IF(MSTJ(101).GE.5) K(NC+2,4)=MSTU(5)*(NC+3) + IF(MSTJ(101).GE.5) K(NC+2,5)=MSTU(5)*(NC+3) + IF(MSTJ(101).GE.5) K(NC+3,4)=MSTU(5)*(NC+2) + IF(MSTJ(101).GE.5) K(NC+3,5)=MSTU(5)*(NC+2) + NJET=2 + IF(ECMC.LT.4D0*PARJ(127)) THEN + MSTU10=MSTU(10) + MSTU(10)=1 + P(NC+2,5)=ECMC + CALL PY1ENT(NC+2,83,0.5D0*(X2+X3)*ECM,PARU(1),0D0) + MSTU(10)=MSTU10 + NJET=0 + ENDIF + ENDIF + DO 110 IP=NC+1,N + K(IP,3)=K(IP,3)+(MSTJ(115)/2)+(KFLC/5)*(MSTJ(115)/3)*(NC-1) + 110 CONTINUE + +C...Differential cross-sections. Upper limit for cross-section. + IF(MSTJ(106).EQ.1) THEN + SQ2=SQRT(2D0) + HF1=1D0-PARJ(131)*PARJ(132) + HF3=PARJ(133)**2 + CT13=(X1*X3-2D0*X1-2D0*X3+2D0)/(X1*X3) + ST13=SQRT(1D0-CT13**2) + SIGL=0.5D0*X3**2*((1D0-X2)**2+(1D0-X3)**2)*ST13**2 + SIGU=(X1*(1D0-X1))**2+(X2*(1D0-X2))**2+(X3*(1D0-X3))**2-SIGL + SIGT=0.5D0*SIGL + SIGI=(SIGL*CT13/ST13+0.5D0*X1*X3*(1D0-X2)**2*ST13)/SQ2 + SIGMAX=(2D0*HF1+HF3)*ABS(SIGU)+2D0*(HF1+HF3)*ABS(SIGL)+2D0*(HF1+ + & 2D0*HF3)*ABS(SIGT)+2D0*SQ2*(HF1+2D0*HF3)*ABS(SIGI) + +C...Angular orientation of event. + 120 CHI=PARU(2)*PYR(0) + CTHE=2D0*PYR(0)-1D0 + PHI=PARU(2)*PYR(0) + CCHI=COS(CHI) + SCHI=SIN(CHI) + C2CHI=COS(2D0*CHI) + S2CHI=SIN(2D0*CHI) + THE=ACOS(CTHE) + STHE=SIN(THE) + C2PHI=COS(2D0*(PHI-PARJ(134))) + S2PHI=SIN(2D0*(PHI-PARJ(134))) + SIG=((1D0+CTHE**2)*HF1+STHE**2*C2PHI*HF3)*SIGU+2D0*(STHE**2*HF1- + & STHE**2*C2PHI*HF3)*SIGL+2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)* + & C2CHI*C2PHI-2D0*CTHE*S2CHI*S2PHI)*HF3)*SIGT- + & 2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE* + & (CTHE*CCHI*C2PHI-SCHI*S2PHI)*HF3)*SIGI + IF(SIG.LT.SIGMAX*PYR(0)) GOTO 120 + CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0) + CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0) + ENDIF + +C...Generate parton shower. Rearrange along strings and check. + IF(MSTJ(101).GE.5.AND.NJET.GE.2) THEN + CALL PYSHOW(NC+MK+1,-NJET,ECMC) + MSTJ14=MSTJ(14) + IF(MSTJ(105).EQ.-1) MSTJ(14)=-1 + IF(MSTJ(105).GE.0) MSTU(28)=0 + CALL PYPREP(0) + MSTJ(14)=MSTJ14 + IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100 + ENDIF + +C...Generate fragmentation. Information for PYTABU: + IF(MSTJ(105).EQ.1) CALL PYEXEC + MSTU(161)=110*KFLC+3 + MSTU(162)=0 + + RETURN + END + +C********************************************************************* + +C...PYBOOK +C...Books a histogram. + + SUBROUTINE PYBOOK(ID,TITLE,NX,XL,XU) + +C...Double precision declaration. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) +C...Commonblock. + COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000) + SAVE /PYBINS/ +C...Local character variables. + CHARACTER TITLE*(*), TITFX*60 + +C...Check that input is sensible. Find initial address in memory. + IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28, + &'(PYBOOK:) not allowed histogram number') + IF(NX.LE.0.OR.NX.GT.100) CALL PYERRM(28, + &'(PYBOOK:) not allowed number of bins') + IF(XL.GE.XU) CALL PYERRM(28, + &'(PYBOOK:) x limits in wrong order') + INDX(ID)=IHIST(4) + IHIST(4)=IHIST(4)+28+NX + IF(IHIST(4).GT.IHIST(2)) CALL PYERRM(28, + &'(PYBOOK:) out of histogram space') + IS=INDX(ID) + +C...Store histogram size and reset contents. + BIN(IS+1)=NX + BIN(IS+2)=XL + BIN(IS+3)=XU + BIN(IS+4)=(XU-XL)/NX + CALL PYNULL(ID) + +C...Store title by conversion to integer to double precision. + TITFX=TITLE//' ' + DO 100 IT=1,20 + BIN(IS+8+NX+IT)=256**2*ICHAR(TITFX(3*IT-2:3*IT-2))+ + & 256*ICHAR(TITFX(3*IT-1:3*IT-1))+ICHAR(TITFX(3*IT:3*IT)) + 100 CONTINUE + + RETURN + END + +C********************************************************************* + +C...PYFILL +C...Fills entry in histogram. + + SUBROUTINE PYFILL(ID,X,W) + +C...Double precision declaration. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) +C...Commonblock. + COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000) + SAVE /PYBINS/ + +C...Find initial address in memory. Increase number of entries. + IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28, + &'(PYFILL:) not allowed histogram number') + IS=INDX(ID) + IF(IS.EQ.0) CALL PYERRM(28, + &'(PYFILL:) filling unbooked histogram') + BIN(IS+5)=BIN(IS+5)+1D0 + +C...Find bin in x, including under/overflow, and fill. + IF(X.LT.BIN(IS+2)) THEN + BIN(IS+6)=BIN(IS+6)+W + ELSEIF(X.GE.BIN(IS+3)) THEN + BIN(IS+8)=BIN(IS+8)+W + ELSE + BIN(IS+7)=BIN(IS+7)+W + IX=(X-BIN(IS+2))/BIN(IS+4) + IX=MAX(0,MIN(NINT(BIN(IS+1))-1,IX)) + BIN(IS+9+IX)=BIN(IS+9+IX)+W + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYFACT +C...Multiplies histogram contents by factor. + + SUBROUTINE PYFACT(ID,F) + +C...Double precision declaration. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) +C...Commonblock. + COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000) + SAVE /PYBINS/ + +C...Find initial address in memory. Multiply all contents bins. + IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28, + &'(PYFACT:) not allowed histogram number') + IS=INDX(ID) + IF(IS.EQ.0) CALL PYERRM(28, + &'(PYFACT:) scaling unbooked histogram') + DO 100 IX=IS+6,IS+8+NINT(BIN(IS+1)) + BIN(IX)=F*BIN(IX) + 100 CONTINUE + + RETURN + END + +C********************************************************************* + +C...PYOPER +C...Performs operations between histograms. + + SUBROUTINE PYOPER(ID1,OPER,ID2,ID3,F1,F2) + +C...Double precision declaration. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) +C...Commonblock. + COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000) + SAVE /PYBINS/ +C...Character variable. + CHARACTER OPER*(*) + +C...Find initial addresses in memory, and histogram size. + IF(ID1.LE.0.OR.ID1.GT.IHIST(1)) CALL PYERRM(28, + &'(PYFACT:) not allowed histogram number') + IS1=INDX(ID1) + IS2=INDX(MIN(IHIST(1),MAX(1,ID2))) + IS3=INDX(MIN(IHIST(1),MAX(1,ID3))) + NX=NINT(BIN(IS3+1)) + IF(OPER.EQ.'M'.AND.ID3.EQ.0) NX=NINT(BIN(IS2+1)) + +C...Update info on number of histogram entries. + IF(OPER.EQ.'+'.OR.OPER.EQ.'-'.OR.OPER.EQ.'*'.OR.OPER.EQ.'/') THEN + BIN(IS3+5)=BIN(IS1+5)+BIN(IS2+5) + ELSEIF(OPER.EQ.'A'.OR.OPER.EQ.'S'.OR.OPER.EQ.'L') THEN + BIN(IS3+5)=BIN(IS1+5) + ENDIF + +C...Operations on pair of histograms: addition, subtraction, +C...multiplication, division. + IF(OPER.EQ.'+') THEN + DO 100 IX=6,8+NX + BIN(IS3+IX)=F1*BIN(IS1+IX)+F2*BIN(IS2+IX) + 100 CONTINUE + ELSEIF(OPER.EQ.'-') THEN + DO 110 IX=6,8+NX + BIN(IS3+IX)=F1*BIN(IS1+IX)-F2*BIN(IS2+IX) + 110 CONTINUE + ELSEIF(OPER.EQ.'*') THEN + DO 120 IX=6,8+NX + BIN(IS3+IX)=F1*BIN(IS1+IX)*F2*BIN(IS2+IX) + 120 CONTINUE + ELSEIF(OPER.EQ.'/') THEN + DO 130 IX=6,8+NX + FA2=F2*BIN(IS2+IX) + IF(ABS(FA2).LE.1D-20) THEN + BIN(IS3+IX)=0D0 + ELSE + BIN(IS3+IX)=F1*BIN(IS1+IX)/FA2 + ENDIF + 130 CONTINUE + +C...Operations on single histogram: multiplication+addition, +C...square root+addition, logarithm+addition. + ELSEIF(OPER.EQ.'A') THEN + DO 140 IX=6,8+NX + BIN(IS3+IX)=F1*BIN(IS1+IX)+F2 + 140 CONTINUE + ELSEIF(OPER.EQ.'S') THEN + DO 150 IX=6,8+NX + BIN(IS3+IX)=F1*SQRT(MAX(0D0,BIN(IS1+IX)))+F2 + 150 CONTINUE + ELSEIF(OPER.EQ.'L') THEN + ZMIN=1D20 + DO 160 IX=9,8+NX + IF(BIN(IS1+IX).LT.ZMIN.AND.BIN(IS1+IX).GT.1D-20) + & ZMIN=0.8D0*BIN(IS1+IX) + 160 CONTINUE + DO 170 IX=6,8+NX + BIN(IS3+IX)=F1*LOG10(MAX(ZMIN,BIN(IS1+IX)))+F2 + 170 CONTINUE + +C...Operation on two or three histograms: average and +C...standard deviation. + ELSEIF(OPER.EQ.'M') THEN + DO 180 IX=6,8+NX + IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN + BIN(IS2+IX)=0D0 + ELSE + BIN(IS2+IX)=BIN(IS2+IX)/BIN(IS1+IX) + ENDIF + IF(ID3.NE.0) THEN + IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN + BIN(IS3+IX)=0D0 + ELSE + BIN(IS3+IX)=SQRT(MAX(0D0,BIN(IS3+IX)/BIN(IS1+IX)- + & BIN(IS2+IX)**2)) + ENDIF + ENDIF + BIN(IS1+IX)=F1*BIN(IS1+IX) + 180 CONTINUE + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYHIST +C...Prints and resets all histograms. + + SUBROUTINE PYHIST + +C...Double precision declaration. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) +C...Commonblock. + COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000) + SAVE /PYBINS/ + +C...Loop over histograms, print and reset used ones. + DO 100 ID=1,IHIST(1) + IS=INDX(ID) + IF(IS.NE.0.AND.NINT(BIN(IS+5)).GT.0) THEN + CALL PYPLOT(ID) + CALL PYNULL(ID) + ENDIF + 100 CONTINUE + + RETURN + END + +C********************************************************************* + +C...PYPLOT +C...Prints a histogram (but does not reset it). + + SUBROUTINE PYPLOT(ID) + +C...Double precision declaration. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000) + SAVE /PYDAT1/,/PYBINS/ +C...Local arrays and character variables. + DIMENSION IDATI(6), IROW(100), IFRA(100), DYAC(10) + CHARACTER TITLE*60, OUT*100, CHA(0:11)*1 + +C...Steps in histogram scale. Character sequence. + DATA DYAC/.04,.05,.06,.08,.10,.12,.15,.20,.25,.30/ + DATA CHA/'0','1','2','3','4','5','6','7','8','9','X','-'/ + +C...Find initial address in memory; skip if empty histogram. + IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN + IS=INDX(ID) + IF(IS.EQ.0) RETURN + IF(NINT(BIN(IS+5)).LE.0) THEN + WRITE(MSTU(11),5000) ID + RETURN + ENDIF + +C...Number of histogram lines and x bins. + LIN=IHIST(3)-18 + NX=NINT(BIN(IS+1)) + +C...Extract title by conversion from double precision via integer. + DO 100 IT=1,20 + IEQ=NINT(BIN(IS+8+NX+IT)) + TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//CHAR(MOD(IEQ,256**2)/256) + & //CHAR(MOD(IEQ,256)) + 100 CONTINUE + +C...Find time; print title. + CALL PYTIME(IDATI) + IF(IDATI(1).GT.0) THEN + WRITE(MSTU(11),5100) ID, TITLE, (IDATI(J),J=1,5) + ELSE + WRITE(MSTU(11),5200) ID, TITLE + ENDIF + +C...Find minimum and maximum bin content. + YMIN=BIN(IS+9) + YMAX=BIN(IS+9) + DO 110 IX=IS+10,IS+8+NX + IF(BIN(IX).LT.YMIN) YMIN=BIN(IX) + IF(BIN(IX).GT.YMAX) YMAX=BIN(IX) + 110 CONTINUE + +C...Determine scale and step size for y axis. + IF(YMAX-YMIN.GT.LIN*DYAC(1)*1D-9) THEN + IF(YMIN.GT.0D0.AND.YMIN.LT.0.1D0*YMAX) YMIN=0D0 + IF(YMAX.LT.0D0.AND.YMAX.GT.0.1D0*YMIN) YMAX=0D0 + IPOT=INT(LOG10(YMAX-YMIN)+10D0)-10 + IF(YMAX-YMIN.LT.LIN*DYAC(1)*10D0**IPOT) IPOT=IPOT-1 + IF(YMAX-YMIN.GT.LIN*DYAC(10)*10D0**IPOT) IPOT=IPOT+1 + DELY=DYAC(1) + DO 120 IDEL=1,9 + IF(YMAX-YMIN.GE.LIN*DYAC(IDEL)*10D0**IPOT) DELY=DYAC(IDEL+1) + 120 CONTINUE + DY=DELY*10D0**IPOT + +C...Convert bin contents to integer form; fractional fill in top row. + DO 130 IX=1,NX + CTA=ABS(BIN(IS+8+IX))/DY + IROW(IX)=SIGN(CTA+0.95D0,BIN(IS+8+IX)) + IFRA(IX)=10D0*(CTA+1.05D0-DBLE(INT(CTA+0.95D0))) + 130 CONTINUE + IRMI=SIGN(ABS(YMIN)/DY+0.95D0,YMIN) + IRMA=SIGN(ABS(YMAX)/DY+0.95D0,YMAX) + +C...Print histogram row by row. + DO 150 IR=IRMA,IRMI,-1 + IF(IR.EQ.0) GOTO 150 + OUT=' ' + DO 140 IX=1,NX + IF(IR.EQ.IROW(IX)) OUT(IX:IX)=CHA(IFRA(IX)) + IF(IR*(IROW(IX)-IR).GT.0) OUT(IX:IX)=CHA(10) + 140 CONTINUE + WRITE(MSTU(11),5300) IR*DELY, IPOT, OUT + 150 CONTINUE + +C...Print sign and value of bin contents. + IPOT=INT(LOG10(MAX(YMAX,-YMIN))+10.0001D0)-10 + OUT=' ' + DO 160 IX=1,NX + IF(BIN(IS+8+IX).LT.-10D0**(IPOT-4)) OUT(IX:IX)=CHA(11) + IROW(IX)=NINT(10D0**(3-IPOT)*ABS(BIN(IS+8+IX))) + 160 CONTINUE + WRITE(MSTU(11),5400) OUT + DO 180 IR=4,1,-1 + DO 170 IX=1,NX + OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1)) + 170 CONTINUE + WRITE(MSTU(11),5500) IPOT+IR-4, OUT + 180 CONTINUE + +C...Print sign and value of lower bin edge. + IPOT=INT(LOG10(MAX(-BIN(IS+2),BIN(IS+3)-BIN(IS+4)))+ + & 10.0001D0)-10 + OUT=' ' + DO 190 IX=1,NX + IF(BIN(IS+2)+(IX-1)*BIN(IS+4).LT.-10D0**(IPOT-3)) + & OUT(IX:IX)=CHA(11) + IROW(IX)=NINT(10D0**(2-IPOT)*ABS(BIN(IS+2)+(IX-1)*BIN(IS+4))) + 190 CONTINUE + WRITE(MSTU(11),5600) OUT + DO 210 IR=3,1,-1 + DO 200 IX=1,NX + OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1)) + 200 CONTINUE + WRITE(MSTU(11),5500) IPOT+IR-3, OUT + 210 CONTINUE + ENDIF + +C...Calculate and print statistics. + CSUM=0D0 + CXSUM=0D0 + CXXSUM=0D0 + DO 220 IX=1,NX + CTA=ABS(BIN(IS+8+IX)) + X=BIN(IS+2)+(IX-0.5D0)*BIN(IS+4) + CSUM=CSUM+CTA + CXSUM=CXSUM+CTA*X + CXXSUM=CXXSUM+CTA*X**2 + 220 CONTINUE + XMEAN=CXSUM/MAX(CSUM,1D-20) + XRMS=SQRT(MAX(0D0,CXXSUM/MAX(CSUM,1D-20)-XMEAN**2)) + WRITE(MSTU(11),5700) NINT(BIN(IS+5)),XMEAN,BIN(IS+6), + &BIN(IS+2),BIN(IS+7),XRMS,BIN(IS+8),BIN(IS+3) + +C...Formats for output. + 5000 FORMAT(/5X,'Histogram no',I5,' : no entries') + 5100 FORMAT('1'/5X,'Histogram no',I5,6X,A60,5X,I4,'-',I2,'-',I2,1X, + &I2,':',I2/) + 5200 FORMAT('1'/5X,'Histogram no',I5,6X,A60/) + 5300 FORMAT(2X,F7.2,'*10**',I2,3X,A100) + 5400 FORMAT(/8X,'Contents',3X,A100) + 5500 FORMAT(9X,'*10**',I2,3X,A100) + 5600 FORMAT(/8X,'Low edge',3X,A100) + 5700 FORMAT(/5X,'Entries =',I12,1P,6X,'Mean =',D12.4,6X,'Underflow =' + &,D12.4,6X,'Low edge =',D12.4/5X,'All chan =',D12.4,6X, + &'Rms =',D12.4,6X,'Overflow =',D12.4,6X,'High edge =',D12.4) + + RETURN + END + +C********************************************************************* + +C...PYNULL +C...Resets bin contents of a histogram. + + SUBROUTINE PYNULL(ID) + +C...Double precision declaration. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) +C...Commonblock. + COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000) + SAVE /PYBINS/ + + IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN + IS=INDX(ID) + IF(IS.EQ.0) RETURN + DO 100 IX=IS+5,IS+8+NINT(BIN(IS+1)) + BIN(IX)=0D0 + 100 CONTINUE + + RETURN + END + +C********************************************************************* + +C...PYDUMP +C...Dumps histogram contents on file for reading by other program. +C...Can also read back own dump. + + SUBROUTINE PYDUMP(MDUMP,LFN,NHI,IHI) + +C...Double precision declaration. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) +C...Commonblock. + COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000) + SAVE /PYBINS/ +C...Local arrays and character variables. + DIMENSION IHI(*),ISS(100),VAL(5) + CHARACTER TITLE*60,FORMAT*13 + +C...Dump all histograms that have been booked, +C...including titles and ranges, one after the other. + IF(MDUMP.EQ.1) THEN + +C...Loop over histograms and find which are wanted and booked. + IF(NHI.LE.0) THEN + NW=IHIST(1) + ELSE + NW=NHI + ENDIF + DO 130 IW=1,NW + IF(NHI.EQ.0) THEN + ID=IW + ELSE + ID=IHI(IW) + ENDIF + IS=INDX(ID) + IF(IS.NE.0) THEN + +C...Write title, histogram size, filling statistics. + NX=NINT(BIN(IS+1)) + DO 100 IT=1,20 + IEQ=NINT(BIN(IS+8+NX+IT)) + TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)// + & CHAR(MOD(IEQ,256**2)/256)//CHAR(MOD(IEQ,256)) + 100 CONTINUE + WRITE(LFN,5100) ID,TITLE + WRITE(LFN,5200) NX,BIN(IS+2),BIN(IS+3) + WRITE(LFN,5300) NINT(BIN(IS+5)),BIN(IS+6),BIN(IS+7), + & BIN(IS+8) + + +C...Write histogram contents, in groups of five. + DO 120 IXG=1,(NX+4)/5 + DO 110 IXV=1,5 + IX=5*IXG+IXV-5 + IF(IX.LE.NX) THEN + VAL(IXV)=BIN(IS+8+IX) + ELSE + VAL(IXV)=0D0 + ENDIF + 110 CONTINUE + WRITE(LFN,5400) (VAL(IXV),IXV=1,5) + 120 CONTINUE + +C...Go to next histogram; finish. + ELSEIF(NHI.GT.0) THEN + CALL PYERRM(8,'(PYDUMP:) unknown histogram number') + ENDIF + 130 CONTINUE + +C...Read back in histograms dumped MDUMP=1. + ELSEIF(MDUMP.EQ.2) THEN + +C...Read histogram number, title and range, and book. + 140 READ(LFN,5100,END=170) ID,TITLE + READ(LFN,5200) NX,XL,XU + CALL PYBOOK(ID,TITLE,NX,XL,XU) + IS=INDX(ID) + +C...Read filling statistics. + READ(LFN,5300) NENTRY,BIN(IS+6),BIN(IS+7),BIN(IS+8) + BIN(IS+5)=DBLE(NENTRY) + +C...Read histogram contents, in groups of five. + DO 160 IXG=1,(NX+4)/5 + READ(LFN,5400) (VAL(IXV),IXV=1,5) + DO 150 IXV=1,5 + IX=5*IXG+IXV-5 + IF(IX.LE.NX) BIN(IS+8+IX)=VAL(IXV) + 150 CONTINUE + 160 CONTINUE + +C...Go to next histogram; finish. + GOTO 140 + 170 CONTINUE + +C...Write histogram contents in column format, +C...convenient e.g. for GNUPLOT input. + ELSEIF(MDUMP.EQ.3) THEN + +C...Find addresses to wanted histograms. + NSS=0 + IF(NHI.LE.0) THEN + NW=IHIST(1) + ELSE + NW=NHI + ENDIF + DO 180 IW=1,NW + IF(NHI.EQ.0) THEN + ID=IW + ELSE + ID=IHI(IW) + ENDIF + IS=INDX(ID) + IF(IS.NE.0.AND.NSS.LT.100) THEN + NSS=NSS+1 + ISS(NSS)=IS + ELSEIF(NSS.GE.100) THEN + CALL PYERRM(8,'(PYDUMP:) too many histograms requested') + ELSEIF(NHI.GT.0) THEN + CALL PYERRM(8,'(PYDUMP:) unknown histogram number') + ENDIF + 180 CONTINUE + +C...Check that they have common number of x bins. Fix format. + NX=NINT(BIN(ISS(1)+1)) + DO 190 IW=2,NSS + IF(NINT(BIN(ISS(IW)+1)).NE.NX) THEN + CALL PYERRM(8,'(PYDUMP:) different number of bins') + RETURN + ENDIF + 190 CONTINUE + FORMAT='(1P,000E12.4)' + WRITE(FORMAT(5:7),'(I3)') NSS+1 + +C...Write histogram contents; first column x values. + DO 200 IX=1,NX + X=BIN(ISS(1)+2)+(IX-0.5D0)*BIN(ISS(1)+4) + WRITE(LFN,FORMAT) X, (BIN(ISS(IW)+8+IX),IW=1,NSS) + 200 CONTINUE + + ENDIF + +C...Formats for output. + 5100 FORMAT(I5,5X,A60) + 5200 FORMAT(I5,1P,2D12.4) + 5300 FORMAT(I12,1P,3D12.4) + 5400 FORMAT(1P,5D12.4) + + RETURN + END + +C********************************************************************* + +C...PYSTOP +C...Allows users to handle STOP statemens + + SUBROUTINE PYSTOP(MCOD) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + SAVE /PYDAT1/ + + +C...Write message, then stop + WRITE(MSTU(11),5000) MCOD + STOP + + +C...Formats for output. + 5000 FORMAT(/5X,'PYSTOP called with code: ',I4) + END + +C********************************************************************* + +C...PYKCUT +C...Dummy routine, which the user can replace in order to make cuts on +C...the kinematics on the parton level before the matrix elements are +C...evaluated and the event is generated. The cross-section estimates +C...will automatically take these cuts into account, so the given +C...values are for the allowed phase space region only. MCUT=0 means +C...that the event has passed the cuts, MCUT=1 that it has failed. + + SUBROUTINE PYKCUT(MCUT) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) + SAVE /PYDAT1/,/PYINT1/,/PYINT2/ + +C...Set default value (accepting event) for MCUT. + MCUT=0 + +C...Read out subprocess number. + ISUB=MINT(1) + ISTSB=ISET(ISUB) + +C...Read out tau, y*, cos(theta), tau' (where defined, else =0). + TAU=VINT(21) + YST=VINT(22) + CTH=0D0 + IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23) + TAUP=0D0 + IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26) + +C...Calculate x_1, x_2, x_F. + IF(ISTSB.LE.2.OR.ISTSB.GE.5) THEN + X1=SQRT(TAU)*EXP(YST) + X2=SQRT(TAU)*EXP(-YST) + ELSE + X1=SQRT(TAUP)*EXP(YST) + X2=SQRT(TAUP)*EXP(-YST) + ENDIF + XF=X1-X2 + +C...Calculate shat, that, uhat, p_T^2. + SHAT=TAU*VINT(2) + SQM3=VINT(63) + SQM4=VINT(64) + RM3=SQM3/SHAT + RM4=SQM4/SHAT + BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4)) + RPTS=4D0*VINT(71)**2/SHAT + BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS)) + RM34=2D0*RM3*RM4 + RSQM=1D0+RM34 + RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L) + THAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4-BE34*CTH) + UHAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4+BE34*CTH) + PT2=MAX(VINT(71)**2,0.25D0*SHAT*BE34**2*(1D0-CTH**2)) + +C...Decisions by user to be put here. + +C...Stop program if this routine is ever called. +C...You should not copy these lines to your own routine. + WRITE(MSTU(11),5000) + CALL PYSTOP(6) + +C...Format for error printout. + 5000 FORMAT(1X,'Error: you did not link your PYKCUT routine ', + &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/ + &1X,'Execution stopped!') + + RETURN + END + +! C********************************************************************* +! +! C...PYEVWT +! C...Dummy routine, which the user can replace in order to multiply the +! C...standard PYTHIA differential cross-section by a process- and +! C...kinematics-dependent factor WTXS. For MSTP(142)=1 this corresponds +! C...to generation of weighted events, with weight 1/WTXS, while for +! C...MSTP(142)=2 it corresponds to a modification of the underlying +! C...physics. +! +! SUBROUTINE PYEVWT(WTXS) +! +! C...Double precision and integer declarations. +! IMPLICIT DOUBLE PRECISION(A-H, O-Z) +! IMPLICIT INTEGER(I-N) +! INTEGER PYK,PYCHGE,PYCOMP +! C...Commonblocks. +! COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) +! COMMON/PYINT1/MINT(400),VINT(400) +! COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) +! SAVE /PYDAT1/,/PYINT1/,/PYINT2/ +! +! C...Set default weight for WTXS. +! WTXS=1D0 +! +! C...Read out subprocess number. +! ISUB=MINT(1) +! ISTSB=ISET(ISUB) +! +! C...Read out tau, y*, cos(theta), tau' (where defined, else =0). +! TAU=VINT(21) +! YST=VINT(22) +! CTH=0D0 +! IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23) +! TAUP=0D0 +! IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26) +! +! C...Read out x_1, x_2, x_F, shat, that, uhat, p_T^2. +! X1=VINT(41) +! X2=VINT(42) +! XF=X1-X2 +! SHAT=VINT(44) +! THAT=VINT(45) +! UHAT=VINT(46) +! PT2=VINT(48) +! +! C...Modifications by user to be put here. +! +! C...Stop program if this routine is ever called. +! C...You should not copy these lines to your own routine. +! WRITE(MSTU(11),5000) +! CALL PYSTOP(4) +! +! C...Format for error printout. +! 5000 FORMAT(1X,'Error: you did not link your PYEVWT routine ', +! &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/ +! &1X,'Execution stopped!') +! +! RETURN +! END + + + SUBROUTINE PYEVWT(WTXS) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) + SAVE /PYDAT1/,/PYINT1/,/PYINT2/ +C--event weight exponent + COMMON/WEXPO/WEIGHTEX + DOUBLE PRECISION WEIGHTEX + +C...Read out p_T^2 + PT2=VINT(48) + WTXS=PT2**(WEIGHTEX/2.d0) + RETURN + END + +C********************************************************************* + +C...UPINIT +C...Dummy routine, to be replaced by a user implementing external +C...processes. Is supposed to fill the HEPRUP commonblock with info +C...on incoming beams and allowed processes. + +C...New example: handles a standard Les Houches Events File. + + SUBROUTINE UPINIT + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + +C...PYTHIA commonblock: only used to provide read unit MSTP(161). + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + SAVE /PYPARS/ + +C...User process initialization commonblock. + INTEGER MAXPUP + PARAMETER (MAXPUP=100) + INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP + DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP + COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2), + &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP), + &LPRUP(MAXPUP) + SAVE /HEPRUP/ + +C...Lines to read in assumed never longer than 200 characters. + PARAMETER (MAXLEN=200) + CHARACTER*(MAXLEN) STRING + +C...Format for reading lines. + CHARACTER*6 STRFMT + STRFMT='(A000)' + WRITE(STRFMT(3:5),'(I3)') MAXLEN + +C...Loop until finds line beginning with "" or "'.AND. + &STRING(IBEG:IBEG+5).NE.'" or "'.AND. + &STRING(IBEG:IBEG+6).NE.'gg splitting decide on colour order + IF(QUARK.OR.QQBAR)THEN + DIR=0 + ELSE + IF(PYR(0).LT.0.5)THEN + DIR=1 + ELSE + DIR=-1 + ENDIF + ENDIF + Z=ZD(L) + IF(Z.EQ.0.d0)THEN + write(logfid,*)'makesplitting: z=0',L + goto 36 + ENDIF + GOTO 35 +C--generate z value + 36 IF(ANGORD.AND.(ZA(L).NE.1.d0))THEN +C--additional z constraint due to angular ordering + QH=4.*P(L,5)**2*(1.-ZA(L))/(ZA(L)*P(K(L,3),5)**2) + IF(QH.GT.1)THEN + write(logfid,*)L,': reject event: angular ordering + & conflict in medium' + CALL PYLIST(3) + DISCARD=.TRUE. + GOTO 31 + ENDIF + EPS=0.5-0.5*SQRT(1.-QH) + ELSE + EPS=0d0 + ENDIF + IF(QUARK)THEN + Z=GENERATEZ(P(L,5)**2,P(L,4),EPS,'QQ') + ELSE + IF(QQBAR)THEN + Z=GENERATEZ(P(L,5)**2,P(L,4),EPS,'QG') + ELSE + Z=GENERATEZ(P(L,5)**2,P(L,4),EPS,'GG') + ENDIF + ENDIF + 35 CONTINUE +C--maximum virtualities for daughters + BMAX1=MIN(P(L,5),Z*P(L,4)) + CMAX1=MIN(P(L,5),(1.-Z)*P(L,4)) +C--generate mass of quark or gluon (particle b) from Sudakov FF + 30 IF(QUARK.OR.QQBAR)THEN + MB=GETMASS(0.d0,BMAX1,THETA,Z*P(L,4),'QQ', + & BMAX1,.FALSE.,ZDECB,QQBARDECB) + ELSE + MB=GETMASS(0.d0,BMAX1,THETA,Z*P(L,4),'GC', + & BMAX1,.FALSE.,ZDECB,QQBARDECB) + ENDIF +C--generate mass gluon (particle c) from Sudakov FF + IF(QUARK.OR.(.NOT.QQBAR))THEN + MC=GETMASS(0.d0,CMAX1,THETA,(1.-Z)*P(L,4),'GC', + & CMAX1,.FALSE.,ZDECC,QQBARDECC) + ELSE + MC=GETMASS(0.d0,CMAX1,THETA,(1.-Z)*P(L,4),'QQ', + & CMAX1,.FALSE.,ZDECC,QQBARDECC) + ENDIF +C--quark (parton b) momentum + 182 PZ=(2.*Z*P(L,4)**2-P(L,5)**2-MB**2+MC**2)/(2.*P(L,3)) + PTS=Z**2*(P(L,4)**2)-PZ**2-MB**2 +C--if kinematics doesn't work out, generate new virtualities +C for daughters +C--massive phase space weight + IF((MB.EQ.0.d0).AND.(MC.EQ.0.d0).AND.(PTS.LT.0.d0)) GOTO 36 + WEIGHT=1.d0 + IF((PYR(0).GT.WEIGHT).OR.(PTS.LT.0.d0) + & .OR.((MB+MC).GT.P(L,5)))THEN + IF(MB.GT.MC)THEN + IF(QUARK.OR.QQBAR)THEN + MB=GETMASS(0.d0,MB,THETA,Z*P(L,4),'QQ', + & BMAX1,.FALSE.,ZDECB,QQBARDECB) + ELSE + MB=GETMASS(0.d0,MB,THETA,Z*P(L,4),'GC', + & BMAX1,.FALSE.,ZDECB,QQBARDECB) + ENDIF + ELSE + IF(QUARK.OR.(.NOT.QQBAR))THEN + MC=GETMASS(0.d0,MC,THETA,(1.-Z)*P(L,4),'GC', + & CMAX1,.FALSE.,ZDECC,QQBARDECC) + ELSE + MC=GETMASS(0.d0,MC,THETA,(1.-Z)*P(L,4),'QQ', + & CMAX1,.FALSE.,ZDECC,QQBARDECC) + ENDIF + ENDIF + GOTO 182 + ENDIF + N=N+2 +C--take care of first daughter (radiated gluon or antiquark) + K(N-1,1)=K(L,1) + IF(QQBAR)THEN + K(N-1,2)=-1 + TRIP(N-1)=0 + ANTI(N-1)=ANTI(L) + ELSE + K(N-1,2)=21 + IF((K(L,2).GT.0).AND.(DIR.GE.0))THEN + TRIP(N-1)=TRIP(L) + ANTI(N-1)=COLMAX+1 + ELSE + TRIP(N-1)=COLMAX+1 + ANTI(N-1)=ANTI(L) + ENDIF + COLMAX=COLMAX+1 + ENDIF + K(N-1,3)=L + K(N-1,4)=0 + K(N-1,5)=0 + P(N-1,4)=(1-Z)*P(L,4) + P(N-1,5)=MC + ZA(N-1)=1.-Z + IF(ZDECC.GT.0.d0)THEN + THETAA(N-1)=P(N-1,5)/(SQRT(ZDECC*(1.-ZDECC))*P(N-1,4)) + ELSE + THETAA(N-1)=0.d0 + ENDIF + ZD(N-1)=ZDECC + QQBARD(N-1)=QQBARDECC +C--take care of second daughter (final quark or gluon or quark from +C gluon splitting) + K(N,1)=K(L,1) + IF(QUARK)THEN + K(N,2)=K(L,2) + IF(K(N,2).GT.0)THEN + TRIP(N)=ANTI(N-1) + ANTI(N)=0 + ELSE + TRIP(N)=0 + ANTI(N)=TRIP(N-1) + ENDIF + ELSEIF(QQBAR)THEN + K(N,2)=1 + TRIP(N)=TRIP(L) + ANTI(N)=0 + ELSE + K(N,2)=21 + IF(DIR.EQ.1)THEN + TRIP(N)=ANTI(N-1) + ANTI(N)=ANTI(L) + ELSE + TRIP(N)=TRIP(L) + ANTI(N)=TRIP(N-1) + ENDIF + ENDIF + K(N,3)=L + K(N,4)=0 + K(N,5)=0 + P(N,3)=PZ + P(N,4)=Z*P(L,4) + P(N,5)=MB + ZA(N)=Z + IF(ZDECB.GT.0.d0)THEN + THETAA(N)=P(N,5)/(SQRT(ZDECB*(1.-ZDECB))*P(N,4)) + ELSE + THETAA(N)=0.d0 + ENDIF + ZD(N)=ZDECB + QQBARD(N)=QQBARDECB +C--azimuthal angle + PHIQ=2*PI*PYR(0) + P(N,1)=SQRT(PTS)*COS(PHIQ) + P(N,2)=SQRT(PTS)*SIN(PHIQ) +C--gluon momentum + P(N-1,1)=P(L,1)-P(N,1) + P(N-1,2)=P(L,2)-P(N,2) + P(N-1,3)=P(L,3)-P(N,3) + MV(N-1,4)=MV(L,5) + IF(P(N-1,5).GT.0.d0)THEN + LAMBDA=1.d0/(FTFAC*P(N-1,4)*0.2/P(N-1,5)**2) + MV(N-1,5)=MV(L,5)-LOG(1.d0-PYR(0))/LAMBDA + ELSE + MV(N-1,5)=0.d0 + ENDIF + MV(N,4)=MV(L,5) + IF(P(N,5).GT.0.d0)THEN + LAMBDA=1.d0/(FTFAC*P(N,4)*0.2/P(N,5)**2) + MV(N,5)=MV(L,5)-LOG(1.d0-PYR(0))/LAMBDA + ELSE + MV(N,5)=0.d0 + ENDIF +C--take care of initial quark (or gluon) + IF(K(L,1).EQ.2)THEN + K(L,1)=13 + ELSE + K(L,1)=11 + ENDIF + K(L,4)=N-1 + K(L,5)=N + NSPLIT=NSPLIT+EVWEIGHT + 31 CONTINUE + END + + +*********************************************************************** +*** subroutine makeinsplit +*********************************************************************** + SUBROUTINE MAKEINSPLIT(L,X,TSUM,VIRT,TYPI,TIME,TAURAD) + IMPLICIT NONE +C--identifier of file for hepmc output and logfile + common/hepmcid/hpmcfid,logfid + integer hpmcfid,logfid +C--Common block of Pythia + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + INTEGER N,NPAD,K + DOUBLE PRECISION P,V +C--time common block + COMMON/TIME/MV(23000,5) + DOUBLE PRECISION MV +C--factor in front of formation times + COMMON/FTIMEFAC/FTFAC + DOUBLE PRECISION FTFAC +C--colour index common block + COMMON/COLOUR/TRIP(23000),ANTI(23000),COLMAX + INTEGER TRIP,ANTI,COLMAX +C--variables for angular ordering + COMMON/ANGOR/ZA(23000),ZD(23000),THETAA(23000),QQBARD(23000) + DOUBLE PRECISION ZA,ZD,THETAA + LOGICAL QQBARD +C--discard event flag + COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD + LOGICAL DISCARD + INTEGER NDISC,NSTRANGE,NGOOD,errcount + double precision wdisc +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--number of scattering events + COMMON/CHECK/NSCAT,NSCATEFF,NSPLIT + DOUBLE PRECISION NSCAT,NSCATEFF,NSPLIT +C--event weight + COMMON/WEIGHT/EVWEIGHT,sumofweights + double precision EVWEIGHT,sumofweights + +C--local variables + INTEGER L,TYPI,NOLD,DIR + DOUBLE PRECISION X,VIRT,MB2,MC2,GETMASS,PZ,KT2,THETA,PHI,PI, + &PHIQ,PYP,PYR,R,TIME,TSUM,TAURAD,LAMBDA,ZDEC + LOGICAL QQBARDEC + CHARACTER*2 TYP2,TYPC + integer bin + DATA PI/3.141592653589793d0/ + + IF((N+2).GT.22990) THEN + write(logfid,*)'event too long for event record' + DISCARD=.TRUE. + RETURN + ENDIF + + IF(K(L,2).EQ.21)THEN + IF(TYPI.EQ.21)THEN + TYP2='GG' + TYPC='GC' + ELSE + TYP2='QG' + TYPC='QQ' + ENDIF + ELSE + IF(TYPI.EQ.21)THEN + TYP2='GQ' + TYPC='QQ' + ELSE + TYP2='QQ' + TYPC='GC' + ENDIF + ENDIF + +C--if g->gg decide on colour configuration + IF(TYP2.EQ.'GG')THEN + IF(PYR(0).LT.0.5)THEN + DIR=1 + ELSE + DIR=-1 + ENDIF + ELSE + DIR=0 + ENDIF + + MB2=VIRT**2 + MB2=P(L,5)**2-MB2 + MC2=GETMASS(0.d0,SCALEFACM*SQRT(-TSUM),-1.d0, + & (1.-X)*P(L,4),TYPC,(1.-X)*P(L,4), + & .FALSE.,ZDEC,QQBARDEC)**2 + +C--rotate such that momentum points in z-direction + NOLD=N + THETA=PYP(L,13) + PHI=PYP(L,15) + CALL PYROBO(L,L,0d0,-PHI,0d0,0d0,0d0) + CALL PYROBO(L,L,-THETA,0d0,0d0,0d0,0d0) + PZ=(2*X*P(L,4)**2-P(L,5)**2-MB2+MC2)/(2*P(L,3)) + KT2=X**2*(P(L,4)**2)-PZ**2-MB2 + IF(KT2.LT.0.d0)THEN + MC2=0.d0 + PZ=(2*X*P(L,4)**2-P(L,5)**2-MB2+MC2)/(2*P(L,3)) + KT2=X**2*(P(L,4)**2)-PZ**2-MB2 + IF(KT2.LT.0.d0)THEN + CALL PYROBO(L,L,THETA,0d0,0d0,0d0,0d0) + CALL PYROBO(L,L,0d0,PHI,0d0,0d0,0d0) + X=1.d0 + RETURN + ENDIF + ENDIF + N=N+2 +C--take care of first daughter (radiated gluon or antiquark) + K(N-1,1)=K(L,1) + IF(TYP2.EQ.'QG')THEN + K(N-1,2)=-TYPI + IF(K(N-1,2).GT.0)THEN + TRIP(N-1)=TRIP(L) + ANTI(N-1)=0 + ELSE + TRIP(N-1)=0 + ANTI(N-1)=ANTI(L) + ENDIF + ELSEIF(TYP2.EQ.'GQ')THEN + K(N-1,2)=K(L,2) + IF(K(N-1,2).GT.0)THEN + TRIP(N-1)=COLMAX+1 + ANTI(N-1)=0 + ELSE + TRIP(N-1)=0 + ANTI(N-1)=COLMAX+1 + ENDIF + COLMAX=COLMAX+1 + ELSE + K(N-1,2)=21 + IF((K(L,2).GT.0).AND.(DIR.GE.0))THEN + TRIP(N-1)=TRIP(L) + ANTI(N-1)=COLMAX+1 + ELSE + TRIP(N-1)=COLMAX+1 + ANTI(N-1)=ANTI(L) + ENDIF + COLMAX=COLMAX+1 + ENDIF + K(N-1,3)=L + K(N-1,4)=0 + K(N-1,5)=0 + P(N-1,4)=(1.-X)*P(L,4) + P(N-1,5)=SQRT(MC2) +C--take care of second daughter (final quark or gluon or quark from +C gluon splitting) + K(N,1)=K(L,1) + IF(TYP2.EQ.'QG')THEN + K(N,2)=TYPI + IF(K(N,2).GT.0)THEN + TRIP(N)=TRIP(L) + ANTI(N)=0 + ELSE + TRIP(N)=0 + ANTI(N)=ANTI(L) + ENDIF + ELSEIF(TYPI.NE.21)THEN + K(N,2)=K(L,2) + IF(K(N,2).GT.0)THEN + TRIP(N)=ANTI(N-1) + ANTI(N)=0 + ELSE + TRIP(N)=0 + ANTI(N)=TRIP(N-1) + ENDIF + ELSE + K(N,2)=21 + IF(K(N-1,2).EQ.21)THEN + IF(DIR.EQ.1)THEN + TRIP(N)=ANTI(N-1) + ANTI(N)=ANTI(L) + ELSE + TRIP(N)=TRIP(L) + ANTI(N)=TRIP(N-1) + ENDIF + ELSEIF(K(N-1,2).GT.0)THEN + TRIP(N)=TRIP(L) + ANTI(N)=TRIP(N-1) + ELSE + TRIP(N)=ANTI(N-1) + ANTI(N)=ANTI(L) + ENDIF + ENDIF + K(N,3)=L + K(N,4)=0 + K(N,5)=0 + P(N,3)=PZ + P(N,4)=X*P(L,4) + IF(MB2.LT.0.d0)THEN + P(N,5)=-SQRT(-MB2) + ELSE + P(N,5)=SQRT(MB2) + ENDIF +C--azimuthal angle + PHIQ=2*PI*PYR(0) + P(N,1)=SQRT(KT2)*COS(PHIQ) + P(N,2)=SQRT(KT2)*SIN(PHIQ) +C--gluon momentum + P(N-1,1)=P(L,1)-P(N,1) + P(N-1,2)=P(L,2)-P(N,2) + P(N-1,3)=P(L,3)-P(N,3) + MV(L,5)=TIME-TAURAD + MV(N-1,4)=MV(L,5) + IF(P(N-1,5).GT.0.d0)THEN + LAMBDA=1.d0/(FTFAC*P(N-1,4)*0.2/P(N-1,5)**2) + MV(N-1,5)=MV(L,5)-LOG(1.d0-PYR(0))/LAMBDA + ELSE + MV(N-1,5)=0.d0 + ENDIF + MV(N,4)=MV(L,5) + IF(P(N,5).GT.0.d0)THEN + MV(N,5)=TIME + ELSE + MV(N,5)=0.d0 + ENDIF + ZA(N-1)=1.d0 + THETAA(N-1)=-1.d0 + ZD(N-1)=ZDEC + QQBARD(N-1)=QQBARDEC + ZA(N)=1.d0 + THETAA(N)=-1.d0 + ZD(N)=0.d0 + QQBARD(N)=.FALSE. +C--take care of initial quark (or gluon) + IF(K(L,1).EQ.2)THEN + K(L,1)=13 + ELSE + K(L,1)=11 + ENDIF + K(L,4)=N-1 + K(L,5)=N + NSPLIT=NSPLIT+EVWEIGHT + CALL PYROBO(L,L,THETA,0d0,0d0,0d0,0d0) + CALL PYROBO(N-1,N,THETA,0d0,0d0,0d0,0d0) + CALL PYROBO(L,L,0d0,PHI,0d0,0d0,0d0) + CALL PYROBO(N-1,N,0d0,PHI,0d0,0d0,0d0) + +C--set the production vertices: x_mother + (tprod - tprod_mother) * beta_mother + MV(N-1,1)=MV(L,1)+(MV(N-1,4)-MV(L,4))*P(L,1)/max(pyp(l,8),P(L,4)) + MV(N-1,2)=MV(L,2)+(MV(N-1,4)-MV(L,4))*P(L,2)/max(pyp(l,8),P(L,4)) + MV(N-1,3)=MV(L,3)+(MV(N-1,4)-MV(L,4))*P(L,3)/max(pyp(l,8),P(L,4)) + MV(N, 1)=MV(L,1)+(MV(N, 4)-MV(L,4))*P(L,1)/max(pyp(l,8),P(L,4)) + MV(N, 2)=MV(L,2)+(MV(N, 4)-MV(L,4))*P(L,2)/max(pyp(l,8),P(L,4)) + MV(N, 3)=MV(L,3)+(MV(N, 4)-MV(L,4))*P(L,3)/max(pyp(l,8),P(L,4)) + + END + + +*********************************************************************** +*** subroutine doinstatescat +*********************************************************************** + SUBROUTINE DOINSTATESCAT(L,X,TYPI,Q,TSTART,DELTAT,OVERQ0, + & RETRYSPLIT) + IMPLICIT NONE +C--Common block of Pythia + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + INTEGER N,NPAD,K + DOUBLE PRECISION P,V +C--time common block + COMMON/TIME/MV(23000,5) + DOUBLE PRECISION MV +C--factor in front of formation times + COMMON/FTIMEFAC/FTFAC + DOUBLE PRECISION FTFAC +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--discard event flag + COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD + LOGICAL DISCARD + INTEGER NDISC,NSTRANGE,NGOOD,errcount + double precision wdisc +C--variables for coherent scattering + COMMON/COHERENT/NSTART,NEND,ALLQS(10000,6),SCATCENTRES(10000,10), + &QSUMVEC(4),QSUM2 + INTEGER NSTART,NEND + DOUBLE PRECISION ALLQS,SCATCENTRES,QSUMVEC,QSUM2 +C--identifier of file for hepmc output and logfile + common/hepmcid/hpmcfid,logfid + integer hpmcfid,logfid +C--local variables + INTEGER L,TYPI,COUNTER,COUNTMAX,COUNT2 + DOUBLE PRECISION X,DELTAT,DELTAL,PYR,R,PNORAD,GETPNORAD1,GETNOSCAT, + &WEIGHT,LOW,FMAX,GETPDF,SIGMATOT,GETSSCAT,PFCHANGE,PI,TNOW,TLEFT, + &XMAX,PQQ,PQG,PGQ,PGG,ALPHAS,TSTART,TSUM,Q,QOLD,Q2OLD,GETNEWMASS, + &GENERATEZ,TMAX,TMAXNEW,DT,XSC,YSC,ZSC,TSC,MS1,MD1,GETMS,GETMD, + &GETTEMP,GETNEFF,LAMBDA,RTAU,PHI,TAUEST,QSUMVECOLD(4),ZDUM,WEIGHT, + &pyp + LOGICAL FCHANGE,NORAD,OVERQ0,NOSCAT,GETDELTAT,RETRYSPLIT, + &QQBARDUM + CHARACTER TYP + CHARACTER*2 TYP2 + DATA PI/3.141592653589793d0/ + DATA COUNTMAX/10000/ + + COUNTER=0 + + XSC=MV(L,1)+(TSTART-MV(L,4))*P(L,1)/P(L,4) + YSC=MV(L,2)+(TSTART-MV(L,4))*P(L,2)/P(L,4) + ZSC=MV(L,3)+(TSTART-MV(L,4))*P(L,3)/P(L,4) + TSC=TSTART + MD1=GETMD(XSC,YSC,ZSC,TSC) + MS1=GETMS(XSC,YSC,ZSC,TSC) + + IF(MD1.LE.1.D-4.OR.MS1.LE.1.D-4)THEN + write(logfid,*)'problem!',GETTEMP(XSC,YSC,ZSC,TSC), + &GETNEFF(XSC,YSC,ZSC,TSC) + ENDIF + +C--check for scattering + NOSCAT=.NOT.GETDELTAT(L,TSTART,DELTAT,DT) + IF(NOSCAT.AND.(.NOT.RETRYSPLIT)) GOTO 116 + +C--decide whether there will be radiation + PNORAD=GETPNORAD1(L,xsc,ysc,zsc,tsc) + IF((PYR(0).LT.PNORAD).OR.(P(L,4).LT.1.001*Q0))THEN + NORAD=.TRUE. + ELSE + NORAD=.FALSE. + ENDIF + +C--decide whether q or g is to be scattered + IF(K(L,2).EQ.21)THEN + TYP='G' + TYP2='GC' + SIGMATOT=GETSSCAT(P(L,4),p(l,1),p(l,2),p(l,3),P(L,5), + & Q0,'G','C',xsc,ysc,zsc,tsc,0) + IF((SIGMATOT.EQ.0.d0).OR.(PNORAD.EQ.1.d0))THEN + PFCHANGE=0.d0 + ELSE + PFCHANGE=GETSSCAT(P(L,4),p(l,1),p(l,2),p(l,3),P(L,5), + & Q0,'G','Q',xsc,ysc,zsc,tsc,0) + & /SIGMATOT + ENDIF + SIGMATOT=GETSSCAT(P(L,4),p(l,1),p(l,2),p(l,3),P(L,5), + & 0.d0,'G','C',xsc,ysc,zsc,tsc,0) + ELSE + TYP='Q' + TYP2='QQ' + SIGMATOT=GETSSCAT(P(L,4),p(l,1),p(l,2),p(l,3),P(L,5), + & Q0,'Q','C',xsc,ysc,zsc,tsc,0) + IF((SIGMATOT.EQ.0.d0).OR.(PNORAD.EQ.1.d0))THEN + PFCHANGE=0.d0 + ELSE + PFCHANGE=GETSSCAT(P(L,4),p(l,1),p(l,2),p(l,3),P(L,5), + & Q0,'Q','G',xsc,ysc,zsc,tsc,0) + & /SIGMATOT + ENDIF + SIGMATOT=GETSSCAT(P(L,4),p(l,1),p(l,2),p(l,3),P(L,5), + & 0.d0,'Q','C',xsc,ysc,zsc,tsc,0) + ENDIF + IF((PFCHANGE.LT.-1.d-4).OR.(PFCHANGE.GT.1.d0+1.d-4)) THEN + write(logfid,*)'error: flavour change probability=', + & PFCHANGE,'for ',TYP + ENDIF + IF(PYR(0).LT.PFCHANGE)THEN + FCHANGE=.TRUE. + ELSE + FCHANGE=.FALSE. + ENDIF + IF (NORAD) FCHANGE=.FALSE. +C--set TYPI + IF(TYP.EQ.'G')THEN + IF(FCHANGE)THEN + TYPI=INT(SIGN(2.d0,PYR(0)-0.5)) + ELSE + TYPI=K(L,2) + ENDIF + ELSE + IF(FCHANGE)THEN + TYPI=21 + ELSE + TYPI=K(L,2) + ENDIF + ENDIF + LOW=Q0**2/SCALEFACM**2 + TMAX=4.*(P(L,4)**2-P(L,5)**2) + XMAX=1.-Q0**2/(SCALEFACM**2*4.*TMAX) + + IF(SIGMATOT.EQ.0.d0) GOTO 116 + + RTAU=PYR(0) + +C--generate a trial emission +C--pick a x value from splitting function + 112 COUNTER=COUNTER+1 + IF(TYP.EQ.'G')THEN + IF(FCHANGE)THEN + X=GENERATEZ(0.d0,0.d0,1.-XMAX,'QG') + ELSE + X=GENERATEZ(0.d0,0.d0,1.-XMAX,'GG') + ENDIF + ELSE + IF(FCHANGE)THEN + X=1.-GENERATEZ(0.d0,0.d0,1.-XMAX,'QQ') + ELSE + X=GENERATEZ(0.d0,0.d0,1.-XMAX,'QQ') + ENDIF + ENDIF + IF(NORAD) X=1.d0 +C--initialisation + TMAXNEW=(X*P(L,4))**2 + PHI=0.d0 + TLEFT=DELTAT + TNOW=TSTART + QSUMVEC(1)=0.d0 + QSUMVEC(2)=0.d0 + QSUMVEC(3)=0.d0 + QSUMVEC(4)=0.d0 + QSUM2=-1.d-10 + OVERQ0=.FALSE. + Q=P(L,5) + QOLD=P(L,5) + TAUEST=DELTAT +C--generate first momentum transfer + DELTAL=DT + NSTART=1 + NEND=1 + TNOW=TNOW+DELTAL + TSUM=DELTAL + TLEFT=TLEFT-DELTAL + ALLQS(NEND,6)=TNOW + Q2OLD=QSUM2 +C--get new momentum transfer + COUNT2=0 + 118 CALL GETQVEC(L,NEND,TNOW-MV(L,4),X) + IF(-QSUM2.GT.P(L,4)**2)THEN + QSUMVEC(1)=0.d0 + QSUMVEC(2)=0.d0 + QSUMVEC(3)=0.d0 + QSUMVEC(4)=0.d0 + QSUM2=Q2OLD + IF(COUNT2.LT.100)THEN + COUNT2=COUNT2+1 + GOTO 118 + ELSE + ALLQS(NEND,1)=0.d0 + ALLQS(NEND,2)=0.d0 + ALLQS(NEND,3)=0.d0 + ALLQS(NEND,4)=0.d0 + ALLQS(NEND,5)=0.d0 + ENDIF + ENDIF +C--update OVERQ0 + IF(-ALLQS(NEND,1).GT.LOW) OVERQ0=.TRUE. +C--get new virtuality + IF(OVERQ0.AND.(.NOT.NORAD))THEN + Q=GETNEWMASS(L,SCALEFACM**2*QSUM2,SCALEFACM**2*Q2OLD,0.d0, + & .TRUE.,X,ZDUM,QQBARDUM) + ELSE + Q=0.d0 + ENDIF + +C--estimate formation time + 111 IF((Q.EQ.0.d0).OR.(Q.EQ.P(L,5)))THEN + TAUEST=DELTAT + ELSE + TAUEST=FTFAC*(1.-PHI)*0.2*X*P(L,4)/Q**2 + ENDIF + LAMBDA=1.d0/TAUEST + TAUEST=-LOG(1.d0-RTAU)/LAMBDA + +C--find number, position and momentum transfers of further scatterings + NOSCAT=.NOT.GETDELTAT(L,TNOW,MIN(TLEFT,TAUEST),DELTAL) + IF((.NOT.NOSCAT).AND.(.NOT.NORAD))THEN +C--add a momentum transfer + NEND=NEND+1 + IF(NEND.GE.100)THEN + nend=nend-1 + goto 114 + ENDIF + TNOW=TNOW+DELTAL + TSUM=TSUM+DELTAL + TLEFT=TLEFT-DELTAL +C--update phase + IF((Q.NE.0.d0).AND.(Q.NE.P(L,5)))THEN + PHI=PHI+5.*DELTAL*Q**2/(1.*X*P(L,4)) + ENDIF +C--get new momentum transfer + ALLQS(NEND,6)=TNOW + Q2OLD=QSUM2 + QSUMVECOLD(1)=QSUMVEC(1) + QSUMVECOLD(2)=QSUMVEC(2) + QSUMVECOLD(3)=QSUMVEC(3) + QSUMVECOLD(4)=QSUMVEC(4) + COUNT2=0 + 119 CALL GETQVEC(L,NEND,TNOW-MV(L,4),X) + IF(-QSUM2.GT.P(L,4)**2)THEN + QSUMVEC(1)=QSUMVECOLD(1) + QSUMVEC(2)=QSUMVECOLD(2) + QSUMVEC(3)=QSUMVECOLD(3) + QSUMVEC(4)=QSUMVECOLD(4) + QSUM2=Q2OLD + IF(COUNT2.LT.100)THEN + COUNT2=COUNT2+1 + GOTO 119 + ELSE + ALLQS(NEND,1)=0.d0 + ALLQS(NEND,2)=0.d0 + ALLQS(NEND,3)=0.d0 + ALLQS(NEND,4)=0.d0 + ALLQS(NEND,5)=0.d0 + ENDIF + ENDIF +C--update OVERQ0 + IF((-QSUM2.GT.LOW) + & .OR.(-ALLQS(NEND,1).GT.LOW)) OVERQ0=.TRUE. +C--get new virtuality + QOLD=Q + IF(OVERQ0.AND.(.NOT.NORAD))THEN + Q=GETNEWMASS(L,SCALEFACM**2*QSUM2,SCALEFACM**2*Q2OLD,0.d0, + & .TRUE.,X,ZDUM,QQBARDUM) + ELSE + Q=0.d0 + ENDIF + GOTO 111 + ENDIF + +C--do reweighting + 114 TMAXNEW=X**2*P(L,4)**2 + IF(NORAD)THEN + WEIGHT=1.d0 + Q=0.d0 + X=1.d0 + ELSEIF((-QSUM2.LT.LOW).OR.(Q.EQ.0.d0))THEN + WEIGHT=0.d0 + ELSEIF(-QSUM2.GT.P(L,4)**2)THEN + WEIGHT=0.d0 + ELSE + IF(TYP.EQ.'G')THEN + FMAX=2.*LOG(-SCALEFACM**2*QSUM2/Q0**2) + & *ALPHAS(Q0**2/4.,LPS)/(2.*PI) + IF(QSUM2.EQ.0.d0)THEN + WEIGHT=0.d0 + NORAD=.TRUE. + ELSE + IF(FCHANGE)THEN + WEIGHT=2.*GETPDF(X,SCALEFACM*SQRT(-QSUM2),'QG')/(PQG(X)*FMAX) + IF((WEIGHT.GT.1.d0+1.d-4).OR.(WEIGHT.LT.-1.d-4))THEN + write(logfid,*)'x,sqrt(qsum^2),getpdf,fmax:',X, + & SQRT(-QSUM2),GETPDF(X,SCALEFACM*SQRT(-QSUM2),'QG'),'qg', + & FMAX + ENDIF + ELSE + WEIGHT=GETPDF(X,SCALEFACM*SQRT(-QSUM2),'GG')/(PGG(X)*FMAX) + IF((WEIGHT.GT.1.d0+1.d-4).OR.(WEIGHT.LT.-1.d-4))THEN + write(logfid,*)'x,sqrt(qsum^2),getpdf,fmax:',X, + & SQRT(-QSUM2),GETPDF(X,SCALEFACM*SQRT(-QSUM2),'GG'),'gg', + & FMAX + ENDIF + ENDIF + ENDIF + ELSE + FMAX=LOG(-SCALEFACM**2*QSUM2/Q0**2) + & *ALPHAS(Q0**2/4.,LPS)/(2.*PI) + IF(QSUM2.EQ.0.d0)THEN + WEIGHT=0.d0 + NORAD=.TRUE. + ELSE + IF(FCHANGE)THEN + WEIGHT=GETPDF(X,SCALEFACM*SQRT(-QSUM2),'GQ')/(PGQ(X)*FMAX) + IF((WEIGHT.GT.1.d0+1.d-4).OR.(WEIGHT.LT.-1.d-4))THEN + write(logfid,*)'x,sqrt(qsum^2),getpdf:,fmax',X, + & SQRT(-QSUM2),GETPDF(X,SCALEFACM*SQRT(-QSUM2),'GQ'),'gq', + & FMAX + ENDIF + ELSE + WEIGHT=GETPDF(X,SCALEFACM*SQRT(-QSUM2),'QQ')/(PQQ(X)*FMAX) + IF((WEIGHT.GT.1.d0+1.d-4).OR.(WEIGHT.LT.-1.d-4))THEN + write(logfid,*)'x,sqrt(qsum^2),getpdf,fmax:',X, + & SQRT(-QSUM2),GETPDF(X,SCALEFACM*SQRT(-QSUM2),'QQ'),'qq', + & FMAX + ENDIF + ENDIF + ENDIF + ENDIF + ENDIF + IF((WEIGHT.GT.1.d0+1.d-4).OR.(WEIGHT.LT.-1.d-4)) + & write(logfid,*)'error: weight=',WEIGHT + 115 IF(PYR(0).GT.WEIGHT)THEN + IF(COUNTER.LT.COUNTMAX)THEN + GOTO 112 + ELSE + Q=0.d0 + X=1.d0 + NEND=NSTART + QSUM2=ALLQS(NEND,1) + QSUMVEC(1)=ALLQS(NEND,2) + QSUMVEC(2)=ALLQS(NEND,3) + QSUMVEC(3)=ALLQS(NEND,4) + QSUMVEC(4)=ALLQS(NEND,5) + TYPI=K(L,2) + IF(-ALLQS(NEND,1).GT.LOW)THEN + OVERQ0=.TRUE. + ELSE + OVERQ0=.FALSE. + ENDIF + DELTAT=ALLQS(NEND,6)-TSTART + TNOW=ALLQS(1,6) + RETURN + ENDIF + ENDIF +C--found meaningful configuration, now do final checks +C--check if phase is unity and weight with 1/Nscat + IF(((TLEFT.LT.TAUEST).OR.(PYR(0).GT.1.d0/(NEND*1.d0))) + & .AND.(.NOT.NORAD))THEN + Q=0.d0 + X=1.d0 + NEND=NSTART + QSUM2=ALLQS(NEND,1) + QSUMVEC(1)=ALLQS(NEND,2) + QSUMVEC(2)=ALLQS(NEND,3) + QSUMVEC(3)=ALLQS(NEND,4) + QSUMVEC(4)=ALLQS(NEND,5) + TYPI=K(L,2) + IF(-ALLQS(NEND,1).GT.LOW)THEN + OVERQ0=.TRUE. + ELSE + OVERQ0=.FALSE. + ENDIF + DELTAT=ALLQS(NEND,6)-TSTART + TNOW=ALLQS(1,6) + ELSE + IF(.NOT.NORAD)THEN + TLEFT=TLEFT-TAUEST + TNOW=TNOW+TAUEST + TSUM=TSUM+TAUEST + ENDIF + DELTAT=TSUM + ENDIF + RETURN +C--exit in case of failure + 116 Q=0.d0 + X=1.d0 + NSTART=0 + NEND=0 + QSUMVEC(1)=0.d0 + QSUMVEC(2)=0.d0 + QSUMVEC(3)=0.d0 + QSUMVEC(4)=0.d0 + QSUM2=0.d0 + OVERQ0=.FALSE. + TYPI=K(L,2) + RETURN + END + + +*********************************************************************** +*** subroutine dofistatescat +*********************************************************************** + SUBROUTINE DOFISTATESCAT(L,TNOW,DTLEFT,DELTAT,NEWMASS, + & OVERQ0,Z,QQBAR) + IMPLICIT NONE +C--identifier of file for hepmc output and logfile + common/hepmcid/hpmcfid,logfid + integer hpmcfid,logfid +C--Common block of Pythia + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + INTEGER N,NPAD,K + DOUBLE PRECISION P,V +C--time common block + COMMON/TIME/MV(23000,5) + DOUBLE PRECISION MV +C--factor in front of formation times + COMMON/FTIMEFAC/FTFAC + DOUBLE PRECISION FTFAC +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--discard event flag + COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD + LOGICAL DISCARD + INTEGER NDISC,NSTRANGE,NGOOD,errcount + double precision wdisc +C--variables for coherent scattering + COMMON/COHERENT/NSTART,NEND,ALLQS(10000,6),SCATCENTRES(10000,10), + &QSUMVEC(4),QSUM2 + INTEGER NSTART,NEND + DOUBLE PRECISION ALLQS,SCATCENTRES,QSUMVEC,QSUM2 +C--local variables + INTEGER L,COUNTER,COUNTMAX,COUNT2 + DOUBLE PRECISION TNOW,DELTAT,NEWMASS,TLEFT,DELTAL,Q2OLD, + &GETNEWMASS,PYR,TSUM,QSUMVECOLD(4),RTAU,LAMBDA,DTLEFT,PHI, + &TAUEST,LOW,Z,pyp + LOGICAL OVERQ0,NOSCAT,GETDELTAT,QQBAR + CHARACTER TYP + DATA COUNTMAX/100/ + DELTAL=0.d0 + + IF(-QSUM2.GT.P(L,4)**2) + & write(logfid,*) 'DOFISTATESCAT has a problem:',-QSUM2,P(L,4)**2 + + IF(K(L,2).EQ.21)THEN + TYP='G' + ELSE + TYP='Q' + ENDIF + LOW=Q0**2/SCALEFACM**2 + + TSUM=0.d0 + PHI=0.d0 + DELTAT=0.d0 + +C--check for radiation with first (given) momentum transfer + Q2OLD=0.d0 + IF(OVERQ0.OR.(-QSUM2.GT.LOW))THEN + NEWMASS=GETNEWMASS(L,SCALEFACM**2*QSUM2,SCALEFACM**2*Q2OLD, + & NEWMASS,.FALSE.,1.d0,Z,QQBAR) + OVERQ0=.TRUE. + ELSE + NEWMASS=P(L,5) + ENDIF + + RTAU=PYR(0) + + TLEFT=DTLEFT + 222 IF((NEWMASS.EQ.0.d0).OR.(NEWMASS.EQ.P(L,5)))THEN + TAUEST=TLEFT + ELSE + TAUEST=FTFAC*(1.-PHI)*0.2*P(L,4)/NEWMASS**2 + ENDIF + LAMBDA=1.d0/TAUEST + TAUEST=-LOG(1.d0-RTAU)/LAMBDA + NOSCAT=.NOT.GETDELTAT(L,TNOW+TSUM,MIN(TAUEST,TLEFT),DELTAL) + IF(.NOT.NOSCAT)THEN +C--do scattering + NEND=NEND+1 + IF(NEND.gt.countmax)THEN + nend=nend-1 + goto 218 + ENDIF + IF(NSTART.EQ.0) NSTART=1 + TSUM=TSUM+DELTAL + TLEFT=TLEFT-DELTAL + IF((NEWMASS.NE.0.d0).AND.(NEWMASS.NE.P(L,5)))THEN + PHI=PHI+5.*DELTAL*NEWMASS**2/(1.*P(L,4)) + ENDIF + ALLQS(NEND,6)=TNOW+TSUM + QSUMVECOLD(1)=QSUMVEC(1) + QSUMVECOLD(2)=QSUMVEC(2) + QSUMVECOLD(3)=QSUMVEC(3) + QSUMVECOLD(4)=QSUMVEC(4) + Q2OLD=QSUM2 +C--get new momentum transfer + COUNT2=0 + 219 CALL GETQVEC(L,NEND,TNOW+TSUM-MV(L,4),1.d0) + IF(-QSUM2.GT.P(L,4)**2)THEN + QSUMVEC(1)=QSUMVECOLD(1) + QSUMVEC(2)=QSUMVECOLD(2) + QSUMVEC(3)=QSUMVECOLD(3) + QSUMVEC(4)=QSUMVECOLD(4) + QSUM2=Q2OLD + IF(COUNT2.LT.100)THEN + COUNT2=COUNT2+1 + GOTO 219 + ELSE + ALLQS(NEND,1)=0.d0 + ALLQS(NEND,2)=0.d0 + ALLQS(NEND,3)=0.d0 + ALLQS(NEND,4)=0.d0 + ALLQS(NEND,5)=0.d0 + ENDIF + ENDIF +C--figure out new virtuality + IF(OVERQ0.OR.(-QSUM2.GT.LOW))THEN + NEWMASS=GETNEWMASS(L,SCALEFACM**2*QSUM2,SCALEFACM**2*Q2OLD, + & NEWMASS,.FALSE.,1.d0,Z,QQBAR) + OVERQ0=.TRUE. + ENDIF + GOTO 222 + ENDIF +C--no more scattering + 218 if ((newmass**2.gt.low).and.(newmass.ne.p(l,5))) then + if ((TLEFT.LT.TAUEST).OR.(PYR(0).GT.1.d0/(NEND*1.d0))) then + if (nend.eq.countmax) then + deltat=tsum + else if (TLEFT.LT.TAUEST) then + DELTAT=TSUM+tleft + else + DELTAT=TSUM+tauest + endif + NEWMASS=P(L,5) + ELSE + DELTAT=TSUM+TAUEST + ENDIF + else + DELTAT=0.d0 + NSTART=1 + NEND=1 + QSUM2=ALLQS(NEND,1) + QSUMVEC(1)=ALLQS(NEND,2) + QSUMVEC(2)=ALLQS(NEND,3) + QSUMVEC(3)=ALLQS(NEND,4) + QSUMVEC(4)=ALLQS(NEND,5) + IF(-ALLQS(NEND,1).GT.LOW)THEN + OVERQ0=.TRUE. + ELSE + OVERQ0=.FALSE. + ENDIF + NEWMASS=P(L,5) + endif + return + END + + +*********************************************************************** +*** function getnewmass +*********************************************************************** + DOUBLE PRECISION FUNCTION GETNEWMASS(L,Q2,QOLD2,MASS,IN,X, + & ZDEC,QQBARDEC) + IMPLICIT NONE +C--Common block of Pythia + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + INTEGER N,NPAD,K + DOUBLE PRECISION P,V +C--time common block + COMMON/TIME/MV(23000,5) + DOUBLE PRECISION MV +C--variables for angular ordering + COMMON/ANGOR/ZA(23000),ZD(23000),THETAA(23000),QQBARD(23000) + DOUBLE PRECISION ZA,ZD,THETAA + LOGICAL QQBARD +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--local variables + INTEGER L + DOUBLE PRECISION Q2,QOLD2,R,PYR,PNOSPLIT1,PNOSPLIT2,Z,QA, + &GETSUDAKOV,GETMASS,PKEEP,X,MASS,ZDEC,QTMP,ZOLD + LOGICAL IN,QQBARDEC,QQBAROLD + CHARACTER*2 TYP + + IF(x*P(L,4).LT.Q0)THEN + GETNEWMASS=0.d0 + ZDEC=0.d0 + QQBARDEC=.FALSE. + RETURN + ENDIF + IF (-Q2.LT.Q0**2)THEN + GETNEWMASS=0.d0 + RETURN + ENDIF + IF(K(L,2).EQ.21)THEN + TYP='GC' + ELSE + TYP='QQ' + ENDIF + IF(SQRT(-QOLD2).LE.Q0)THEN + IF(IN)THEN + GETNEWMASS=GETMASS(0.d0,SQRT(-Q2),-1.d0, + & X*P(L,4),TYP,X*P(L,4),IN,ZDEC,QQBARDEC) + ELSE + GETNEWMASS=GETMASS(0.d0,SQRT(-Q2),-1.d0,P(L,4),TYP, + & SQRT(-Q2),IN,ZDEC,QQBARDEC) + ENDIF + GETNEWMASS=MIN(GETNEWMASS,X*P(L,4)) + RETURN + ENDIF + Z=1.d0 + QA=1.d0 + IF(MAX(P(L,5),MASS).GT.0.d0)THEN + IF(-Q2.GT.-QOLD2)THEN + ZOLD=ZDEC + QQBAROLD=QQBARDEC + QTMP=GETMASS(SQRT(-QOLD2),SQRT(-Q2),-1.d0,X*P(L,4),TYP, + & SQRT(-Q2),IN,ZDEC,QQBARDEC) + IF(QTMP.EQ.0.d0)THEN + GETNEWMASS=MASS + ZDEC=ZOLD + QQBARDEC=QQBAROLD + ELSE + GETNEWMASS=QTMP + ENDIF + ELSE + PNOSPLIT1=GETSUDAKOV(SQRT(-QOLD2),QA,Q0,Z,X*P(L,4), + & TYP,MV(L,4),IN) + PNOSPLIT2=GETSUDAKOV(SQRT(-Q2),QA,Q0,Z,X*P(L,4), + & TYP,MV(L,4),IN) + PKEEP=(1.-PNOSPLIT2)/(1.-PNOSPLIT1) + IF(PYR(0).LT.PKEEP)THEN + IF(P(L,5).LT.SQRT(-Q2))THEN + GETNEWMASS=MASS + ELSE + 55 GETNEWMASS=GETMASS(0.d0,SQRT(-Q2),-1.d0,X*P(L,4),TYP, + & SQRT(-Q2),IN,ZDEC,QQBARDEC) + IF((GETNEWMASS.EQ.0.d0).AND.(X*P(L,4).GT.Q0)) GOTO 55 + ENDIF + ELSE + GETNEWMASS=0.d0 + ZDEC=0.d0 + QQBARDEC=.FALSE. + ENDIF + ENDIF + ELSE + IF(-Q2.GT.-QOLD2)THEN + GETNEWMASS=GETMASS(MAX(SQRT(-QOLD2),Q0),SQRT(-Q2),-1.d0, + & X*P(L,4),TYP,X*P(L,4),IN,ZDEC,QQBARDEC) + ELSE + GETNEWMASS=0.d0 + ZDEC=0.d0 + QQBARDEC=.FALSE. + ENDIF + ENDIF + GETNEWMASS=MIN(GETNEWMASS,x*P(L,4)) + END + + +*********************************************************************** +*** function getpnorad1 +*********************************************************************** + DOUBLE PRECISION FUNCTION GETPNORAD1(LINE,x,y,z,t) + IMPLICIT NONE +C--identifier of file for hepmc output and logfile + common/hepmcid/hpmcfid,logfid + integer hpmcfid,logfid +C--Common block of Pythia + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + INTEGER N,NPAD,K + DOUBLE PRECISION P,V +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--local variables + INTEGER LINE + DOUBLE PRECISION UP,LOW,CCOL,SIGMATOT,GETSSCAT,GETXSECINT, + &SCATPRIMFUNC,MS1,MD1,shat,pcms2,avmom(5),x,y,z,t,getmd + + md1 = getmd(x,y,z,t) + call avscatcen(x,y,z,t, + &avmom(1),avmom(2),avmom(3),avmom(4),avmom(5)) + ms1 = avmom(5) + shat = avmom(5)**2 + p(line,5)**2 + 2.*(avmom(4)*p(line,4) + & -avmom(1)*p(line,1)-avmom(2)*p(line,2)-avmom(3)*p(line,3)) + pcms2 = (shat+p(line,5)**2-ms1**2)**2/(4.*shat)-p(line,5)**2 + up = 4.*pcms2 + LOW=Q0**2/SCALEFACM**2 + IF((UP.LE.LOW).OR.(P(LINE,4).LT.Q0/SCALEFACM))THEN + GETPNORAD1=1.d0 + RETURN + ENDIF + IF(K(LINE,2).EQ.21)THEN + CCOL=3./2. +C--probability for no initial state radiation + SIGMATOT=GETSSCAT(P(LINE,4),p(line,1),p(line,2),p(line,3), + & P(LINE,5),0.d0,'G','C',x,y,z,t,0) + IF(SIGMATOT.EQ.0.d0)THEN + GETPNORAD1=-1.d0 + RETURN + ENDIF + GETPNORAD1=(CCOL*(SCATPRIMFUNC(LOW,MD1)- + &SCATPRIMFUNC(0.d0,MD1)) + & + GETXSECINT(UP,MD1,'GB'))/SIGMATOT + ELSE + CCOL=2./3. +C--probability for no initial state radiation + SIGMATOT=GETSSCAT(P(LINE,4),p(line,1),p(line,2),p(line,3), + & P(LINE,5),0.d0,'Q','C',x,y,z,t,0) + IF(SIGMATOT.EQ.0.d0)THEN + GETPNORAD1=1.d0 + RETURN + ENDIF + GETPNORAD1=(CCOL*(SCATPRIMFUNC(LOW,MD1)- + &SCATPRIMFUNC(0.d0,MD1)) + & + GETXSECINT(UP,MD1,'QB'))/SIGMATOT + ENDIF + IF((GETPNORAD1.LT.-1.d-4).OR.(GETPNORAD1.GT.1.d0+1.d-4))THEN + write(logfid,*)'error: P_norad=',GETPNORAD1, + & P(LINE,4),P(LINE,5),LOW,UP,K(LINE,2),MD1 + ENDIF + END + + +*********************************************************************** +*** subroutine getqvec +*********************************************************************** + SUBROUTINE GETQVEC(L,J,DT,X) + IMPLICIT NONE +C--identifier of file for hepmc output and logfile + common/hepmcid/hpmcfid,logfid + integer hpmcfid,logfid +C--Common block of Pythia + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + INTEGER N,NPAD,K + DOUBLE PRECISION P,V +C--time common block + COMMON/TIME/MV(23000,5) + DOUBLE PRECISION MV +C--variables for coherent scattering + COMMON/COHERENT/NSTART,NEND,ALLQS(10000,6),SCATCENTRES(10000,10), + &QSUMVEC(4),QSUM2 + INTEGER NSTART,NEND + DOUBLE PRECISION ALLQS,SCATCENTRES,QSUMVEC,QSUM2 +C--discard event flag + COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD + LOGICAL DISCARD + INTEGER NDISC,NSTRANGE,NGOOD,errcount + double precision wdisc +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--local variables + INTEGER L,J,COUNTER,COUNTMAX,COUNT2,i + DOUBLE PRECISION XSC,YSC,ZSC,TSC,GETMD,GETTEMP,DT,X,PYR,NEWMOM(4), + &T,PT,MAXT,PHI2,BETA(3),PHI,THETA,GETT,PYP,PI,PT2,GETMS, + &savemom(5),theta2,mb2,pz,kt2,phiq,maxt2,xi,md,shat,pcms2, + &avmom(5) + CHARACTER TYPS + DATA PI/3.141592653589793d0/ + DATA COUNTMAX/1000/ + + IF (J.GT.10000)THEN + discard = .true. + return + ENDIF + + COUNTER=0 + COUNT2=0 + + XSC=MV(L,1)+DT*P(L,1)/P(L,4) + YSC=MV(L,2)+DT*P(L,2)/P(L,4) + ZSC=MV(L,3)+DT*P(L,3)/P(L,4) + TSC=MV(L,4)+DT + md = GETMD(XSC,YSC,ZSC,TSC) + + call AVSCATCEN(xsc,ysc,zsc,tsc, + &avmom(1),avmom(2),avmom(3),avmom(4),avmom(5)) + + do 210 i=1,5 + savemom(i) = p(l,i) + 210 continue + + xi = sqrt(max(x**2*p(l,4)**2,p(l,5)**2) - p(l,5)**2)/pyp(l,8) + p(l,1) = xi*p(l,1) + p(l,2) = xi*p(l,2) + p(l,3) = xi*p(l,3) + p(l,4) = max(x*p(l,4),p(l,5)) + + + 444 CALL GETSCATTERER(XSC,YSC,ZSC,TSC, + &K(1,2),P(1,1),P(1,2),P(1,3),P(1,4),P(1,5)) + MV(1,1)=XSC + MV(1,2)=YSC + MV(1,3)=ZSC + MV(1,4)=TSC + TYPS='Q' + IF(K(1,2).EQ.21)TYPS='G' + + shat = avmom(5)**2 + savemom(5)**2 + 2.*(avmom(4)*savemom(4) + & -avmom(1)*savemom(1)-avmom(2)*savemom(2)-avmom(3)*savemom(3)) + pcms2 = (shat+savemom(5)**2-avmom(5)**2)**2/(4.*shat) + & -savemom(5)**2 + maxt = 4.*pcms2 + + K(1,1)=13 + SCATCENTRES(J,1)=K(1,2) + SCATCENTRES(J,2)=P(1,1) + SCATCENTRES(J,3)=P(1,2) + SCATCENTRES(J,4)=P(1,3) + SCATCENTRES(J,5)=P(1,4) + SCATCENTRES(J,6)=P(1,5) + SCATCENTRES(J,7)=MV(1,1) + SCATCENTRES(J,8)=MV(1,2) + SCATCENTRES(J,9)=MV(1,3) + SCATCENTRES(J,10)=MV(1,4) +C--transform to scattering centre's rest frame and rotate such that parton momentum is in z-direction + BETA(1)=P(1,1)/P(1,4) + BETA(2)=P(1,2)/P(1,4) + BETA(3)=P(1,3)/P(1,4) + CALL PYROBO(L,L,0d0,0d0,-BETA(1),-BETA(2),-BETA(3)) + CALL PYROBO(1,1,0d0,0d0,-BETA(1),-BETA(2),-BETA(3)) + THETA=PYP(L,13) + PHI=PYP(L,15) + CALL PYROBO(L,L,0d0,-PHI,0d0,0d0,0d0) + CALL PYROBO(1,1,0d0,-PHI,0d0,0d0,0d0) + CALL PYROBO(L,L,-THETA,0d0,0d0,0d0,0d0) + CALL PYROBO(1,1,-THETA,0d0,0d0,0d0,0d0) +C--pick a t from differential scattering cross section + 204 T=-GETT(0.d0,MAXT,md) + 202 NEWMOM(4)=P(L,4)+T/(2.*p(1,5)) + NEWMOM(3)=(T-2.*P(L,5)**2+2.*p(l,4)*NEWMOM(4))/(2.*P(L,3)) + PT2=NEWMOM(4)**2-NEWMOM(3)**2-P(L,5)**2 + IF(DABS(PT2).LT.1.d-10) PT2=0.d0 + IF(T.EQ.0.d0) PT2=0.d0 + IF(PT2.LT.0.d0)THEN + T=0.d0 + GOTO 202 + ENDIF + PT=SQRT(PT2) + PHI2=PYR(0)*2*PI + NEWMOM(1)=PT*COS(PHI2) + NEWMOM(2)=PT*SIN(PHI2) + P(1,1)=NEWMOM(1)-P(L,1) + P(1,2)=NEWMOM(2)-P(L,2) + P(1,3)=NEWMOM(3)-P(L,3) + P(1,4)=NEWMOM(4)-P(L,4) + P(1,5)=0.d0 +C--transformation to lab + CALL PYROBO(L,L,THETA,0d0,0d0,0d0,0d0) + CALL PYROBO(1,1,THETA,0d0,0d0,0d0,0d0) + CALL PYROBO(L,L,0d0,PHI,0d0,0d0,0d0) + CALL PYROBO(1,1,0d0,PHI,0d0,0d0,0d0) + CALL PYROBO(L,L,0d0,0d0,BETA(1),BETA(2),BETA(3)) + CALL PYROBO(1,1,0d0,0d0,BETA(1),BETA(2),BETA(3)) + ALLQS(J,1)=T + ALLQS(J,2)=P(1,1) + ALLQS(J,3)=P(1,2) + ALLQS(J,4)=P(1,3) + ALLQS(J,5)=P(1,4) + QSUMVEC(1)=QSUMVEC(1)+ALLQS(NEND,2) + QSUMVEC(2)=QSUMVEC(2)+ALLQS(NEND,3) + QSUMVEC(3)=QSUMVEC(3)+ALLQS(NEND,4) + QSUMVEC(4)=QSUMVEC(4)+ALLQS(NEND,5) + QSUM2=QSUMVEC(4)**2-QSUMVEC(1)**2-QSUMVEC(2)**2-QSUMVEC(3)**2 + IF(QSUM2.GT.0.d0)THEN + QSUMVEC(1)=QSUMVEC(1)-ALLQS(NEND,2) + QSUMVEC(2)=QSUMVEC(2)-ALLQS(NEND,3) + QSUMVEC(3)=QSUMVEC(3)-ALLQS(NEND,4) + QSUMVEC(4)=QSUMVEC(4)-ALLQS(NEND,5) + QSUM2=QSUMVEC(4)**2-QSUMVEC(1)**2-QSUMVEC(2)**2-QSUMVEC(3)**2 + IF(COUNTER.GT.COUNTMAX)THEN + write(logfid,*)'GETQVEC unable to find q vector' + ALLQS(J,1)=0.d0 + ALLQS(J,2)=0.d0 + ALLQS(J,3)=0.d0 + ALLQS(J,4)=0.d0 + ALLQS(J,5)=0.d0 + ELSE + COUNTER=COUNTER+1 + GOTO 444 + ENDIF + ENDIF + do 211 i=1,5 + p(l,i) = savemom(i) + 211 continue + END + +*********************************************************************** +*** subroutine dokinematics +*********************************************************************** + SUBROUTINE DOKINEMATICS(L,lold,N1,N2,NEWM,RETRYSPLIT, + & TIME,X,Z,QQBAR) + IMPLICIT NONE +C--identifier of file for hepmc output and logfile + common/hepmcid/hpmcfid,logfid + integer hpmcfid,logfid +C--Common block of Pythia + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + INTEGER N,NPAD,K + DOUBLE PRECISION P,V +C--time common block + COMMON/TIME/MV(23000,5) + DOUBLE PRECISION MV +C--factor in front of formation times + COMMON/FTIMEFAC/FTFAC + DOUBLE PRECISION FTFAC +C--colour index common block + COMMON/COLOUR/TRIP(23000),ANTI(23000),COLMAX + INTEGER TRIP,ANTI,COLMAX +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--discard event flag + COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD + LOGICAL DISCARD + INTEGER NDISC,NSTRANGE,NGOOD,errcount + double precision wdisc +C--variables for angular ordering + COMMON/ANGOR/ZA(23000),ZD(23000),THETAA(23000),QQBARD(23000) + DOUBLE PRECISION ZA,ZD,THETAA + LOGICAL QQBARD +C--variables for coherent scattering + COMMON/COHERENT/NSTART,NEND,ALLQS(10000,6),SCATCENTRES(10000,10), + &QSUMVEC(4),QSUM2 + INTEGER NSTART,NEND + DOUBLE PRECISION ALLQS,SCATCENTRES,QSUMVEC,QSUM2 +C--number of scattering events + COMMON/CHECK/NSCAT,NSCATEFF,NSPLIT + DOUBLE PRECISION NSCAT,NSCATEFF,NSPLIT +C--event weight + COMMON/WEIGHT/EVWEIGHT,sumofweights + double precision EVWEIGHT,sumofweights +C--local variables + INTEGER L,LINE,N1,N2,J,DIR,lold,nold,colmaxold,statold + DOUBLE PRECISION PYR,PI,BETA(3),THETA,PHI,PYP,PHI2,MAXT,T, + &NEWMASS,DELTAM,DM,TTOT,DMLEFT,LAMBDA,TIME,ENDTIME,X,tmp, + &m32,newm2,shat,theta2,z,gettemp,E3new,E4new,p32,p42,p3old, + &newm,mass2,enew,pt2,pt,pl,m12,firsttime,pcms2 + CHARACTER*2 TYP + LOGICAL RETRYSPLIT,QQBAR,QQBARDEC,rejectt,redokin,reshuffle + DATA PI/3.141592653589793d0/ + + IF((N+2*(n2-n1+1)).GT.22990)THEN + write(logfid,*)'event too long for event record' + DISCARD=.TRUE. + RETURN + ENDIF + + firsttime = mv(l,5) + + redokin = .false. + + newm2=newm + nold=n + colmaxold=colmax + statold=k(l,1) + 204 DELTAM=NEWM2-P(L,5) + DMLEFT=DELTAM + + TTOT=0.d0 + DO 220 J=N1,N2 + TTOT=TTOT+ALLQS(J,1) + 220 CONTINUE + + LINE=L + + DO 222 J=N1,N2 + +C--projectile type + IF(K(LINE,2).EQ.21)THEN + TYP='GC' + IF(PYR(0).LT.0.5)THEN + DIR=1 + ELSE + DIR=-1 + ENDIF + ELSE + TYP='QQ' + DIR=0 + ENDIF + K(1,1)=5 + K(1,2)=SCATCENTRES(J,1) + P(1,1)=SCATCENTRES(J,2) + P(1,2)=SCATCENTRES(J,3) + P(1,3)=SCATCENTRES(J,4) + P(1,4)=SCATCENTRES(J,5) + P(1,5)=SCATCENTRES(J,6) + MV(1,1)=SCATCENTRES(J,7) + MV(1,2)=SCATCENTRES(J,8) + MV(1,3)=SCATCENTRES(J,9) + MV(1,4)=SCATCENTRES(J,10) + T=ALLQS(J,1) + if (t.eq.0.d0) then + rejectt = .true. + else + rejectt = .false. + endif + +C--transform to c.m.s. and rotate such that parton momentum is in z-direction + BETA(1)=(P(1,1)+p(line,1))/(P(1,4)+p(line,4)) + BETA(2)=(P(1,2)+p(line,2))/(P(1,4)+p(line,4)) + BETA(3)=(P(1,3)+p(line,3))/(P(1,4)+p(line,4)) + IF ((BETA(1).GT.1.d0).OR.(BETA(2).GT.1.d0).OR.(BETA(3).GT.1.d0) + & .or.(sqrt(beta(1)**2+beta(2)**2+beta(3)**2).gt.1.d0))THEN + reshuffle = .false. + else + reshuffle = .true. + endif + 205 if (.not.reshuffle) then + BETA(1)=P(1,1)/P(1,4) + BETA(2)=P(1,2)/P(1,4) + BETA(3)=P(1,3)/P(1,4) + CALL PYROBO(LINE,LINE,0d0,0d0,-BETA(1),-BETA(2),-BETA(3)) + CALL PYROBO(1,1,0d0,0d0,-BETA(1),-BETA(2),-BETA(3)) + THETA=PYP(LINE,13) + PHI=PYP(LINE,15) + CALL PYROBO(LINE,LINE,0d0,-PHI,0d0,0d0,0d0) + CALL PYROBO(1,1,0d0,-PHI,0d0,0d0,0d0) + CALL PYROBO(LINE,LINE,-THETA,0d0,0d0,0d0,0d0) + CALL PYROBO(1,1,-THETA,0d0,0d0,0d0,0d0) + + maxt = -2.*p(1,5)*p(line,4) + if (t.lt.maxt) then + t=0.d0 + rejectt = .true. + endif + m12 = -p(line,5)**2 + 203 enew = p(line,4)+t/(2.*p(1,5)) + pl = (t+2.*p(line,4)*enew-2.*m12)/(2.*p(line,3)) + pt2 = enew**2-pl**2-m12 + if (t.eq.0.d0) pt2 = 0.d0 + if (dabs(pt2).lt.1.d-8) pt2 = 0.d0 + if (pt2.lt.0.d0) then + write(logfid,*)' This should not have happened: pt^2<0!' + write(logfid,*)t,enew,pl,pt2 + t = 0.d0 + rejectt = .true. + goto 203 + endif + pt = sqrt(pt2) + phi2 = pyr(0)*2.*pi + n=n+2 + p(n,1)=pt*cos(phi2) + p(n,2)=pt*sin(phi2) + p(n,3)=pl + p(n,4)=enew + p(n,5)=p(line,5) +!--------------------------------- + P(N-1,1)=P(1,1)+P(LINE,1)-P(N,1) + P(N-1,2)=P(1,2)+P(LINE,2)-P(N,2) + P(N-1,3)=P(1,3)+P(LINE,3)-P(N,3) + P(N-1,4)=P(1,4)+P(LINE,4)-P(N,4) + mass2 = P(N-1,4)**2-P(N-1,1)**2-P(N-1,2)**2-P(N-1,3)**2 + if ((mass2.lt.0.d0).and.(mass2.gt.-1.-6)) mass2=0.d0 + if (mass2.lt.0.d0) + & write(logfid,*)'messed up scattering centres mass^2: ', + & mass2,p(1,5)**2 + P(N-1,5)=SQRT(mass2) + if (abs(p(n-1,5)-p(1,5)).gt.1.d-6) + & write(logfid,*)'messed up scattering centres mass: ', + & p(n-1,5),p(1,5),p(l,5) + call flush(logfid) +!--------------------------------- +! P(N-1,1)=P(1,1) +! P(N-1,2)=P(1,2) +! P(N-1,3)=P(1,3) +! P(N-1,4)=P(1,4) +! P(N-1,5)=P(1,5) +!--------------------------------- + else + CALL PYROBO(LINE,LINE,0d0,0d0,-BETA(1),-BETA(2),-BETA(3)) + CALL PYROBO(1,1,0d0,0d0,-BETA(1),-BETA(2),-BETA(3)) + if ((p(1,4).lt.0.d0).or.(p(line,4).lt.0.d0)) then + CALL PYROBO(1,1,0d0,0d0,BETA(1),BETA(2),BETA(3)) + CALL PYROBO(LINE,LINE,0d0,0d0,BETA(1),BETA(2),BETA(3)) + reshuffle = .false. + goto 205 + endif + THETA=PYP(LINE,13) + PHI=PYP(LINE,15) + CALL PYROBO(LINE,LINE,0d0,-PHI,0d0,0d0,0d0) + CALL PYROBO(1,1,0d0,-PHI,0d0,0d0,0d0) + CALL PYROBO(LINE,LINE,-THETA,0d0,0d0,0d0,0d0) + CALL PYROBO(1,1,-THETA,0d0,0d0,0d0,0d0) + shat = (p(1,4)+p(line,4))**2 + p3old = p(line,3) + + maxt = -4.*p(line,3)**2 + if (t.lt.maxt) then + t=0.d0 + rejectt = .true. + endif + theta2 = acos(1.d0+t/(2.*p(line,3)**2)) + phi2 = pyr(0)*2.*pi + n=n+2 + p(n,1)=p(line,3)*sin(theta2)*cos(phi2) + p(n,2)=p(line,3)*sin(theta2)*sin(phi2) + p(n,3)=p(line,3)*cos(theta2) + p(n,4)=p(line,4) + p(n,5)=p(line,5) +!--------------------------------- + P(N-1,1)=P(1,1)+P(LINE,1)-P(N,1) + P(N-1,2)=P(1,2)+P(LINE,2)-P(N,2) + P(N-1,3)=P(1,3)+P(LINE,3)-P(N,3) + P(N-1,4)=P(1,4)+P(LINE,4)-P(N,4) + mass2 = P(N-1,4)**2-P(N-1,1)**2-P(N-1,2)**2-P(N-1,3)**2 + if ((mass2.lt.0.d0).and.(mass2.gt.-1.-6)) mass2=0.d0 + if (mass2.lt.0.d0) + & write(logfid,*)'messed up scattering centres mass^2: ', + & mass2,p(1,5)**2 + P(N-1,5)=SQRT(mass2) + if (abs(p(n-1,5)-p(1,5)).gt.1.d-6) + & write(logfid,*)'messed up scattering centres mass: ', + & p(n-1,5),p(1,5),p(l,5) + call flush(logfid) +!--------------------------------- +! P(N-1,1)=P(1,1) +! P(N-1,2)=P(1,2) +! P(N-1,3)=P(1,3) +! P(N-1,4)=P(1,4) +! P(N-1,5)=P(1,5) +!--------------------------------- + endif +C--outgoing projectile + ZA(N)=1.d0 + THETAA(N)=-1.d0 + ZD(N)=Z + QQBARD(N)=QQBAR + K(N,1)=K(LINE,1) + K(N,2)=K(LINE,2) + K(N,3)=L + K(N,4)=0 + K(N,5)=0 + IF(ALLHAD.and.(.not.rejectt))THEN + IF(K(N,2).EQ.21)THEN + IF(DIR.EQ.1)THEN + TRIP(N)=COLMAX+1 + ANTI(N)=ANTI(LINE) + ELSE + TRIP(N)=TRIP(LINE) + ANTI(N)=COLMAX+1 + ENDIF + ELSEIF(K(N,2).GT.0)THEN + TRIP(N)=COLMAX+1 + ANTI(N)=0 + ELSE + TRIP(N)=0 + ANTI(N)=COLMAX+1 + ENDIF + COLMAX=COLMAX+1 + ELSE + TRIP(N)=TRIP(LINE) + ANTI(N)=ANTI(LINE) + ENDIF +C--take care of incoming projectile + IF(K(LINE,1).EQ.1)THEN + K(LINE,1)=12 + ELSE + K(LINE,1)=14 + ENDIF + K(LINE,4)=N-1 + K(LINE,5)=N +C--outgoing scattering centre + ZA(N-1)=1.d0 + THETAA(N-1)=-1.d0 + ZD(N-1)=0.d0 + QQBARD(N-1)=.false. +C--temporary status code, will be overwritten later + K(N-1,1)=3 + K(N-1,2)=21 + K(N-1,3)=0 + K(N-1,4)=0 + K(N-1,5)=0 + IF(ALLHAD.and.(.not.rejectt))THEN + IF((K(N,2).GT.0).AND.(DIR.GE.0))THEN + TRIP(N-1)=TRIP(LINE) + ANTI(N-1)=TRIP(N) + ELSE + TRIP(N-1)=ANTI(N) + ANTI(N-1)=ANTI(LINE) + ENDIF + ELSE + TRIP(N-1)=0 + ANTI(N-1)=0 + ENDIF + + if (reshuffle.and.(dm.gt.0.d0)) then +C--adjust mass and re-shuffle momenta + + IF(TTOT.EQ.0.d0)THEN + DM=0.d0 + ELSE + if (dmleft.lt.0.d0) then + DM=max(DMLEFT*T/TTOT*1.5d0,dmleft) + else + DM=min(DMLEFT*T/TTOT*1.5d0,dmleft) + endif + ENDIF + TTOT=TTOT-ALLQS(J,1) + + newmass = p(n,5)+dm + if (newmass.lt.0.d0) then + m32 = -NEWMASS**2 + else + m32 = NEWMASS**2 + endif + E3new = (shat + m32 - p(1,5)**2)/(2.d0*sqrt(shat)) + E4new = (shat - m32 + p(1,5)**2)/(2.d0*sqrt(shat)) + p32 = E3new**2 - m32 + p42 = E4new**2 - p(1,5)**2 + if ((p32.lt.0.d0).or.(p42.lt.0.d0).or. + & (E3new.lt.0.d0).or.(E4new.lt.0.d0)) then + p32 = 0.d0 + p42 = 0.d0 + E4new = p(n-1,5) + E3new = sqrt(shat) - E4new + m32 = E3new**2 + if ((E3new.lt.0.d0).or.(E4new.lt.0.d0)) then + E3new = p(n,4) + E4new = p(n-1,4) + p32 = p3old**2 + p42 = p3old**2 + if (p(n,5).lt.0.d0) then + m32 = -p(n,5)**2 + else + m32 = p(n,5)**2 + endif + endif + endif + p(n,1) = sqrt(p32)*p(n,1)/p3old + p(n,2) = sqrt(p32)*p(n,2)/p3old + p(n,3) = sqrt(p32)*p(n,3)/p3old + p(n,4) = E3new + p(n,5) = sign(sqrt(abs(m32)),newmass) + tmp = p(n,4)**2-p(n,1)**2-p(n,2)**2-p(n,3)**2 + if (abs(tmp-m32).gt.1.d-6) + & write(logfid,*) 'Oups, messed up projectiles mass:', + & tmp,m32,p(n,5) +!--------------------------------- + p(n-1,1) = sqrt(p42)*p(n-1,1)/p3old + p(n-1,2) = sqrt(p42)*p(n-1,2)/p3old + p(n-1,3) = sqrt(p42)*p(n-1,3)/p3old + p(n-1,4) = E4new +!--------------------------------- +! P(N-1,1)=P(1,1) +! P(N-1,2)=P(1,2) +! P(N-1,3)=P(1,3) +! P(N-1,4)=P(1,4) +! P(N-1,5)=P(1,5) +!--------------------------------- + tmp = p(n-1,4)**2-p(n-1,1)**2-p(n-1,2)**2-p(n-1,3)**2 + & -p(n-1,5)**2 + if (abs(tmp).gt.1.d-6) + & write(logfid,*) 'Oups, messed up scattering centres mass:', + & tmp,p3old,p(n-1,1),p(n-1,2),p(n-1,3),p(n-1,4),p(n-1,5) + if ((abs(p(n,1)+p(n-1,1)).gt.1.d-6).or. + & (abs(p(n,2)+p(n-1,2)).gt.1.d-6).or. + & (abs(p(n,3)+p(n-1,3)).gt.1.d-6)) + & write(logfid,*) 'Oups, momentum not conserved', + & p(n,1)+p(n-1,1),p(n,2)+p(n-1,2),p(n,3)+p(n-1,3) + endif + +C--transformation to lab + CALL PYROBO(N-1,N,THETA,0d0,0d0,0d0,0d0) + CALL PYROBO(LINE,LINE,THETA,0d0,0d0,0d0,0d0) + CALL PYROBO(N-1,N,0d0,PHI,0d0,0d0,0d0) + CALL PYROBO(LINE,LINE,0d0,PHI,0d0,0d0,0d0) + CALL PYROBO(N-1,N,0d0,0d0,BETA(1),BETA(2),BETA(3)) + CALL PYROBO(LINE,LINE,0d0,0d0,BETA(1),BETA(2),BETA(3)) + CALL PYROBO(1,1,THETA,0d0,0d0,0d0,0d0) + CALL PYROBO(1,1,0d0,PHI,0d0,0d0,0d0) + CALL PYROBO(1,1,0d0,0d0,BETA(1),BETA(2),BETA(3)) + if (.not.allhad) then + k(n-1,1)=13 + else + IF(SCATRECOIL.AND.(P(N-1,4).GT.1.5*3.* + &GETTEMP(MV(1,1),MV(1,2),MV(1,3),MV(1,4))))THEN + K(N-1,1)=2 + ELSE + K(N-1,1)=3 + ENDIF + endif + if (rejectt) k(n-1,1)=11 + MV(N,4)=MV(1,4) + MV(N-1,4)=MV(1,4) +C--set the production vertices: x_mother + (tprod - tprod_mother) * beta_mother + MV(N-1,1)=MV(line,1) + & +(MV(N-1,4)-MV(line,4))*P(line,1)/max(pyp(line,8),P(line,4)) + MV(N-1,2)=MV(line,2) + & +(MV(N-1,4)-MV(line,4))*P(line,2)/max(pyp(line,8),P(line,4)) + MV(N-1,3)=MV(line,3) + & +(MV(N-1,4)-MV(line,4))*P(line,3)/max(pyp(line,8),P(line,4)) + MV(N, 1)=MV(line,1) + & +(MV(N, 4)-MV(line,4))*P(line,1)/max(pyp(line,8),P(line,4)) + MV(N, 2)=MV(line,2) + & +(MV(N, 4)-MV(line,4))*P(line,2)/max(pyp(line,8),P(line,4)) + MV(N, 3)=MV(line,3) + & +(MV(N, 4)-MV(line,4))*P(line,3)/max(pyp(line,8),P(line,4)) + IF(P(N-1,5).GT.P(1,5))THEN + LAMBDA=1.d0/(FTFAC*0.2*P(N-1,4)/P(N-1,5)**2) + MV(N-1,5)=MV(N-1,4)-LOG(1.d0-PYR(0))/LAMBDA + ELSE + MV(N-1,5)=0.d0 + ENDIF + IF(J.LT.N2)THEN + MV(N,5)=SCATCENTRES(J+1,10) + ELSE + IF(P(N,5).GT.0.d0)THEN + IF(DELTAM.EQ.0.d0)THEN + ENDTIME=firsttime + ELSE + IF(X.LT.1.d0)THEN + LAMBDA=1.d0/(FTFAC*P(N,4)*0.2/P(N,5)**2) + ENDTIME=SCATCENTRES(J,10)-LOG(1.d0-PYR(0))/LAMBDA + ELSE + ENDTIME=TIME + ENDIF + ENDIF + MV(N,5)=ENDTIME + ELSE + MV(N,5)=0.d0 + ENDIF + ENDIF + MV(LINE,5)=ALLQS(J,6) + + DMLEFT=DMLEFT-(p(n,5)-P(LINE,5)) + LINE=N + tmp = abs(p(n,4)**2-p(n,1)**2-p(n,2)**2-p(n,3)**2)-p(n,5)**2 + if (abs(tmp).ge.1.d-6) + & write(logfid,*)tmp,j,p(l,5),p(line,5),p(n,5) + 222 CONTINUE + if (p(n,5).lt.0.d0) then + RETRYSPLIT=.TRUE. + return + endif + if (p(n,5).ne.newm2) then + RETRYSPLIT=.TRUE. + redokin = .true. + n=nold + colmax=colmaxold + k(l,1)=statold + if (p(l,5).le.0.d0) then + newm2 = 0.d0 + else + if (p(l,5).lt.q0) then + if ((newm2.eq.newm).and.(newm.ne.q0+1.d-6)) then + newm2=q0+1.d-6 + else + RETRYSPLIT=.TRUE. + return + endif + else + newm2=p(l,5) + endif + n2=n1 + endif + goto 204 + endif + if ((p(n,5).lt.0.d0).or.((p(n,5).gt.0.d0).and.(p(n,5).lt.q0))) + &write(logfid,*)'dokinematics did not reach sensible mass: ', + &p(n,5),newm,p(l,5),newm2 + NSCATEFF=NSCATEFF+EVWEIGHT + END + + + +*********************************************************************** +*** function getproba +*********************************************************************** + DOUBLE PRECISION FUNCTION GETPROBA(QI,QF,QAA,ZAA,EBB,TYPE, + & T1,INS2) + IMPLICIT NONE +C--variables for Sudakov integration + COMMON/SUDAINT/QA,ZA2,EB,T,INSTATE,TYP + DOUBLE PRECISION QA,ZA2,EB,T + CHARACTER*2 TYP + LOGICAL INSTATE +C--local variables + DOUBLE PRECISION QI,QF,QAA,ZAA,EBB,GETSUDAKOV,DERIV,T1 + CHARACTER*2 TYPE + LOGICAL INS2 + + QA=QAA + ZA2=ZAA + EB=EBB + TYP=TYPE + T=T1 + INSTATE=INS2 + GETPROBA=GETSUDAKOV(QI,QAA,QF,ZAA,EBB,TYPE,T1,INS2) + & *DERIV(QF,1) + END + + +*********************************************************************** +*** function getsudakov +*********************************************************************** + DOUBLE PRECISION FUNCTION GETSUDAKOV(QMAX1,QA1,QB1,ZA1,EB1, + & TYPE3,T2,INS) + IMPLICIT NONE +C--identifier of file for hepmc output and logfile + common/hepmcid/hpmcfid,logfid + integer hpmcfid,logfid +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--variables for Sudakov integration + COMMON/SUDAINT/QA,ZA2,EB,T,INSTATE,TYP + DOUBLE PRECISION QA,ZA2,EB,T + CHARACTER*2 TYP + LOGICAL INSTATE +C--local variables + DOUBLE PRECISION QMAX1,QA1,QB1,ZA1,EB1,TMAX,TB,YSTART,EPSI, + &HFIRST,T2,GETINSUDAFAST,QB2 + CHARACTER*2 TYPE3 + LOGICAL INS + DATA EPSI/1.d-4/ + + QB2=QB1 + IF(INS)THEN + IF(QB2.LT.Q0) write(logfid,*) 'error: Q < Q0',QB2,QMAX1 + IF(QB2.LT.(Q0+1.d-10)) QB2=QB2+1.d-10 + ELSE + IF(QB2.LT.Q0) write(logfid,*) 'error: Q < min',QB2,QMAX1 + IF(QB2.LT.(Q0+1.d-10)) QB2=QB2+1.d-10 + ENDIF + IF(QB2.GE.(QMAX1-1.d-10)) THEN + GETSUDAKOV=1.d0 + ELSE + IF(INS)THEN + GETSUDAKOV=GETINSUDAFAST(QB1,QMAX1,TYPE3) + ELSE + QA=QA1 + ZA2=ZA1 + EB=EB1 + TYP=TYPE3 + T=T2 + INSTATE=.FALSE. + HFIRST=0.01*(QMAX1-QB1) + YSTART=0.d0 + CALL ODEINT(YSTART,QB2,QMAX1,EPSI,HFIRST,0.d0,1) + GETSUDAKOV=EXP(-YSTART) + ENDIF + ENDIF + END + + +*********************************************************************** +*** function getinsudakov +*********************************************************************** + DOUBLE PRECISION FUNCTION GETINSUDAKOV(QB,QMAX1,TYPE3) + IMPLICIT NONE +C--identifier of file for hepmc output and logfile + common/hepmcid/hpmcfid,logfid + integer hpmcfid,logfid +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--variables for Sudakov integration + COMMON/SUDAINT/QA,ZA2,EB,T,INSTATE,TYP + DOUBLE PRECISION QA,ZA2,EB,T + CHARACTER*2 TYP + LOGICAL INSTATE +C--local variables + DOUBLE PRECISION QMAX1,QB,QB1,ZA1,EA1,YSTART,EPSI, + &HFIRST + CHARACTER*2 TYPE3 + DATA EPSI/1.d-4/ + + QB1=QB + IF(QB1.LT.Q0) write(logfid,*) 'error: Q < Q0',QB1,QMAX1 + IF(QB1.LT.(Q0+1.d-12)) QB1=QB1+1.d-12 + IF(QB1.GE.(QMAX1-1.d-12)) THEN + GETINSUDAKOV=1.d0 + ELSE + TYP=TYPE3 + HFIRST=0.01*(QMAX1-QB1) + YSTART=0.d0 + CALL ODEINT(YSTART,QB1,QMAX1,EPSI,HFIRST,0.d0,6) + GETINSUDAKOV=EXP(-YSTART) + ENDIF + END + + +*********************************************************************** +*** function deriv +*********************************************************************** + DOUBLE PRECISION FUNCTION DERIV(XVAL,W4) + IMPLICIT NONE +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--variables for splitting function integration + COMMON/INTSPLITF/QQUAD,FM + DOUBLE PRECISION QQUAD,FM +C--variables for Sudakov integration + COMMON/SUDAINT/QA,ZA2,EB,T,INSTATE,TYP + DOUBLE PRECISION QA,ZA2,EB,T + CHARACTER*2 TYP + LOGICAL INSTATE +C--variables for pdf integration + COMMON/PDFINTV/XMAX,Z + DOUBLE PRECISION XMAX,Z +C--variables for cross section integration + COMMON/XSECV/QLOW,MDX + DOUBLE PRECISION QLOW,MDX +C--local variables + INTEGER W4 + DOUBLE PRECISION XVAL,GETSPLITI,PI,ALPHAS,GETINSPLITI, + &GETINSUDAFAST,SCATPRIMFUNC,PQQ,PQG,PGG,PGQ, + &MEDDERIV + DATA PI/3.141592653589793d0/ + + IF(W4.EQ.1)THEN +C--Sudakov integration + IF(INSTATE)THEN + DERIV=2.*GETINSPLITI(XVAL,TYP)/XVAL + ELSE + DERIV=2.*GETSPLITI(QA,XVAL,ZA2,EB,TYP)/XVAL + ENDIF + ELSEIF(W4.EQ.2)THEN +C--P(q->qg) integration + DERIV=(1.+FM)*ALPHAS(XVAL*(1.-XVAL)*QQUAD/1.,LPS)* + & PQQ(XVAL)/(2.*PI) + ELSEIF(W4.EQ.3)THEN +C--P(g->gg) integration + DERIV=(1.+FM)*ALPHAS(XVAL*(1.-XVAL)*QQUAD/1.,LPS) + & *PGG(XVAL)/(2.*PI) + ELSEIF(W4.EQ.4)THEN +C--P(g->qq) integration + DERIV=(1.+FM)*ALPHAS(XVAL*(1-XVAL)*QQUAD/1.,LPS)* + & PQG(XVAL)/(2.*PI) + ELSEIF(W4.EQ.5)THEN + DERIV=EXP(-XVAL)/XVAL + ELSEIF(W4.EQ.6)THEN + DERIV=2.*GETINSPLITI(XVAL,TYP)/XVAL + ELSEIF(W4.EQ.7)THEN + DERIV=2.*GETINSUDAFAST(XVAL,XMAX,'QQ') + & *ALPHAS((1.-Z)*XVAL**2/1.,LPS) + & *PQQ(Z)/(2.*PI*XVAL) + ELSEIF(W4.EQ.8)THEN + DERIV=2.*GETINSUDAFAST(XVAL,XMAX,'GC') + & *ALPHAS((1.-Z)*XVAL**2/1.,LPS) + & *PGQ(Z)/(2.*PI*XVAL) + ELSEIF(W4.EQ.9)THEN + DERIV=2.*GETINSUDAFAST(XVAL,XMAX,'QQ') + & *ALPHAS((1.-Z)*XVAL**2/1.,LPS) + & *PQG(Z)/(2.*PI*XVAL) + ELSEIF(W4.EQ.10)THEN + DERIV=2.*GETINSUDAFAST(XVAL,XMAX,'GC') + & *ALPHAS((1.-Z)*XVAL**2/1.,LPS)* + & *2.*PGG(Z)/(2.*PI*XVAL) + ELSEIF(W4.EQ.11)THEN + DERIV=3.*GETINSPLITI(SCALEFACM*SQRT(XVAL),'GQ') + & *SCATPRIMFUNC(XVAL,MDX)/(2.*XVAL) + ELSEIF(W4.EQ.12)THEN + DERIV=2.*GETINSPLITI(SCALEFACM*SQRT(XVAL),'QG') + & *SCATPRIMFUNC(XVAL,MDX)/(3.*XVAL) + ELSEIF(W4.EQ.13)THEN + DERIV=GETINSUDAFAST(QLOW,SCALEFACM*SQRT(XVAL),'GC') + & *3.*2.*PI*ALPHAS(XVAL+MDX**2,LQCD)**2/(2.*(XVAL+MDX**2)**2) + ELSEIF(W4.EQ.14)THEN + DERIV=GETINSUDAFAST(QLOW,SCALEFACM*SQRT(XVAL),'QQ') + & *2.*2.*PI*ALPHAS(XVAL+MDX**2,LQCD)**2/(3.*(XVAL+MDX**2)**2) + ELSEIF(W4.EQ.21)THEN + DERIV=2.*GETINSUDAFAST(XVAL,XMAX,'QQ')*GETINSPLITI(XVAL,'QQ') + & /XVAL + ELSEIF(W4.EQ.22)THEN + DERIV=2.*GETINSUDAFAST(XVAL,XMAX,'GC')*GETINSPLITI(XVAL,'GQ') + & /XVAL + ELSEIF(W4.EQ.23)THEN + DERIV=2.*GETINSUDAFAST(XVAL,XMAX,'QQ')*GETINSPLITI(XVAL,'QG') + & /XVAL + ELSEIF(W4.EQ.24)THEN + DERIV=2.*GETINSUDAFAST(XVAL,XMAX,'GC')*2. + & *GETINSPLITI(XVAL,'GG')/XVAL + ELSE + DERIV=MEDDERIV(XVAL,W4-100) + ENDIF + END + + +*********************************************************************** +*** function getspliti +*********************************************************************** + DOUBLE PRECISION FUNCTION GETSPLITI(QA,QB,ZETA,EB,TYPE1) + IMPLICIT NONE +C--identifier of file for hepmc output and logfile + common/hepmcid/hpmcfid,logfid + integer hpmcfid,logfid +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--splitting integral + COMMON/SPLITINT/SPLITIGGV(1000,1000),SPLITIQQV(1000,1000), + &SPLITIQGV(1000,1000),QVAL(1000),ZMVAL(1000),QMAX,ZMMIN,NPOINT + INTEGER NPOINT + DOUBLE PRECISION SPLITIGGV,SPLITIQQV,SPLITIQGV, + &QVAL,ZMVAL,QMAX,ZMMIN +C--variables for splitting function integration + COMMON/INTSPLITF/QQUAD,FM + DOUBLE PRECISION QQUAD,FM +C--number of extrapolations in tables + common/extrapolations/ntotspliti,noverspliti,ntotpdf,noverpdf, + &ntotxsec,noverxsec,ntotsuda,noversuda + integer ntotspliti,noverspliti,ntotpdf,noverpdf, + &ntotxsec,noverxsec,ntotsuda,noversuda +C--local variables + INTEGER I,J,LT,QLMAX,ZLMAX,QLINE,ZLINE + DOUBLE PRECISION QA,QB,ZETA,EB,LOW,X1A(2),X2A(2),YA(2,2),Y, + &SPLITINTGG,SPLITINTQG,A,B,YB(2) + CHARACTER*2 TYPE1 + + ntotspliti=ntotspliti+1 + if (qb.gt.qmax) then + noverspliti=noverspliti+1 + if (noverspliti.le.25) + & write(logfid,*)'WARNING in getspliti: need to extrapolate: ', + & qb,qmax + endif + +C--find boundaries for z integration + IF(ANGORD.AND.(ZETA.NE.1.d0))THEN + LOW=MAX(0.5-0.5*SQRT(1.-Q0**2/QB**2) + & *SQRT(1.-QB**2/EB**2), + & 0.5-0.5*SQRT(1.-4.*QB**2*(1.-ZETA)/(ZETA*QA**2))) + ELSE + LOW=0.5-0.5*SQRT(1.-Q0**2/QB**2) + & *SQRT(1.-QB**2/EB**2) + ENDIF +C--find values in array + QLMAX=INT((QB-QVAL(1))*NPOINT/(QVAL(1000)-QVAL(1))+1) + QLINE=MAX(QLMAX,1) + QLINE=MIN(QLINE,NPOINT) + ZLMAX=INT((LOG(LOW)-LOG(ZMVAL(1)))*NPOINT/ + & (LOG(ZMVAL(1000))-LOG(ZMVAL(1)))+1) + ZLINE=MAX(ZLMAX,1) + ZLINE=MIN(ZLINE,NPOINT) + IF((QLINE.GT.999).OR.(ZLINE.GT.999).OR. + & (QLINE.LT.1).OR.(ZLINE.LT.1))THEN + write(logfid,*)'ERROR in GETSPLITI: line number out of bound', + & QLINE,ZLINE + ENDIF + IF((TYPE1.EQ.'GG').OR.(TYPE1.EQ.'GC'))THEN + DO 17 I=1,2 + X1A(I)=QVAL(QLINE-1+I) + X2A(I)=ZMVAL(ZLINE-1+I) + DO 16 J=1,2 + YA(I,J)=SPLITIGGV(QLINE-1+I,ZLINE-1+J) + 16 CONTINUE + 17 CONTINUE + DO 30 I=1,2 + A=(YA(I,2)-YA(I,1))/(X2A(2)-X2A(1)) + B=YA(I,1)-A*X2A(1) + YB(I)=A*LOW+B + 30 CONTINUE + IF(X1A(1).EQ.X1A(2))THEN + Y=(YB(1)+YB(2))/2. + ELSE + A=(YB(2)-YB(1))/(X1A(2)-X1A(1)) + B=YB(1)-A*X1A(1) + Y=A*QB+B + ENDIF + IF(TYPE1.EQ.'GG')THEN + GETSPLITI=MIN(Y,10.d0) + ELSE + SPLITINTGG=MIN(Y,10.d0) + ENDIF + ENDIF + IF((TYPE1.EQ.'QG').OR.(TYPE1.EQ.'GC'))THEN + DO 19 I=1,2 + X1A(I)=QVAL(QLINE-1+I) + X2A(I)=ZMVAL(ZLINE-1+I) + DO 18 J=1,2 + YA(I,J)=SPLITIQGV(QLINE-1+I,ZLINE-1+J) + 18 CONTINUE + 19 CONTINUE + DO 31 I=1,2 + A=(YA(I,2)-YA(I,1))/(X2A(2)-X2A(1)) + B=YA(I,1)-A*X2A(1) + YB(I)=A*LOW+B + 31 CONTINUE + IF(X1A(1).EQ.X1A(2))THEN + Y=(YB(1)+YB(2))/2. + ELSE + A=(YB(2)-YB(1))/(X1A(2)-X1A(1)) + B=YB(1)-A*X1A(1) + Y=A*QB+B + ENDIF + IF(TYPE1.EQ.'QG')THEN + GETSPLITI=NF*MIN(Y,10.d0) + ELSE + SPLITINTQG=NF*MIN(Y,10.d0) + ENDIF + ENDIF + IF(TYPE1.EQ.'QQ')THEN + DO 21 I=1,2 + X1A(I)=QVAL(QLINE-1+I) + X2A(I)=ZMVAL(ZLINE-1+I) + DO 20 J=1,2 + YA(I,J)=SPLITIQQV(QLINE-1+I,ZLINE-1+J) + 20 CONTINUE + 21 CONTINUE + DO 32 I=1,2 + A=(YA(I,2)-YA(I,1))/(X2A(2)-X2A(1)) + B=YA(I,1)-A*X2A(1) + YB(I)=A*LOW+B + 32 CONTINUE + IF(X1A(1).EQ.X1A(2))THEN + Y=(YB(1)+YB(2))/2. + ELSE + A=(YB(2)-YB(1))/(X1A(2)-X1A(1)) + B=YB(1)-A*X1A(1) + Y=A*QB+B + ENDIF + GETSPLITI=MIN(Y,10.d0) + ENDIF + IF(TYPE1.EQ.'GC') GETSPLITI=SPLITINTGG+SPLITINTQG + END + + +*********************************************************************** +*** function getinspliti +*********************************************************************** + DOUBLE PRECISION FUNCTION GETINSPLITI(QB,TYPE1) + IMPLICIT NONE +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--local variables + DOUBLE PRECISION QB,LOW,PI,Y,SPLITINTGG,SPLITINTQG,UP,EI + CHARACTER*2 TYPE1 + DATA PI/3.141592653589793d0/ + +C--find boundaries for z integration + UP = 1. - Q0**2/(4.*QB**2) + IF((TYPE1.EQ.'GG').OR.(TYPE1.EQ.'GC'))THEN + LOW=1.d0-UP + IF (UP.LE.LOW) THEN + GETINSPLITI=0.d0 + RETURN + ENDIF + Y = 2.* ( LOG(LOG((1.-LOW)*QB**2/LPS**2)) + & - LPS**2*EI(LOG((1.-LOW)*QB**2/LPS**2))/QB**2 + & + LPS**4*EI(2.*LOG((1.-LOW)*QB**2/LPS**2))/QB**4 + & - LPS**6*EI(3.*LOG((1.-LOW)*QB**2/LPS**2))/QB**6 + & - LOG(LOG((1.-UP)*QB**2/LPS**2)) + & + LPS**2*EI(LOG((1.-UP)*QB**2/LPS**2))/QB**2 + & - LPS**4*EI(2.*LOG((1.-UP)*QB**2/LPS**2))/QB**4 + & + LPS**6*EI(3.*LOG((1.-UP)*QB**2/LPS**2))/QB**6 + & + LOW - LOG(LOW) - UP + LOG(UP) ) + & *3.*12.*PI/(2.*PI*(33.-2.*NF)) + IF(TYPE1.EQ.'GG')THEN + GETINSPLITI=Y + ELSE + SPLITINTGG=Y + ENDIF + ENDIF + IF((TYPE1.EQ.'QG').OR.(TYPE1.EQ.'GC'))THEN + LOW=0.d0 + IF (UP.LE.LOW) THEN + GETINSPLITI=0.d0 + RETURN + ENDIF + Y = ( 2.*LPS**6*EI(3.*LOG((1.-LOW)*QB**2/LPS**2))/QB**6 + & - 2.*LPS**4*EI(2.*LOG((1.-LOW)*QB**2/LPS**2))/QB**4 + & + 2.*LPS**2*EI(LOG((1.-LOW)*QB**2/LPS**2))/QB**2 + & - 2.*LPS**6*EI(3.*LOG((1.-UP)*QB**2/LPS**2))/QB**6 + & + 2.*LPS**4*EI(2.*LOG((1.-UP)*QB**2/LPS**2))/QB**4 + & - 2.*LPS**2*EI(LOG((1.-UP)*QB**2/LPS**2))/QB**2 ) + & *12.*PI/(2.*2.*PI*(33.-2.*NF)) + IF(TYPE1.EQ.'QG')THEN + GETINSPLITI=NF*Y + ELSE + SPLITINTQG=NF*Y + ENDIF + ENDIF + IF(TYPE1.EQ.'QQ')THEN + LOW=0.d0 + IF (UP.LE.LOW) THEN + GETINSPLITI=0.d0 + RETURN + ENDIF + Y = ( 2.*LOG(LOG((1.-LOW)*QB**2/LPS**2)) + & - 2.*LPS**2*EI(LOG((1.-LOW)*QB**2/LPS**2))/QB**2 + & + LPS**4*EI(2.*LOG((1.-LOW)*QB**2/LPS**2))/QB**4 + & - 2.*LOG(LOG((1.-UP)*QB**2/LPS**2)) + & + 2.*LPS**2*EI(LOG((1.-UP)*QB**2/LPS**2))/QB**2 + & - LPS**4*EI(2.*LOG((1.-UP)*QB**2/LPS**2))/QB**4 ) + & *4.*12.*PI/(3.*2.*PI*(33.-2.*NF)) + GETINSPLITI=Y + ENDIF + IF(TYPE1.EQ.'GQ')THEN + LOW=1.d0-UP + IF (UP.LE.LOW) THEN + GETINSPLITI=0.d0 + RETURN + ENDIF + Y = (UP**2/2.-2.*UP+2.*LOG(UP)-LOW**2/2.+2.*LOW- 2.*LOG(LOW)) + & *4.*12.*PI/(3.*2.*PI*(33.-2.*NF)*LOG(QB**2/LPS**2)) + GETINSPLITI=Y + ENDIF + IF(TYPE1.EQ.'GC') GETINSPLITI=SPLITINTGG+SPLITINTQG + END + + +*********************************************************************** +*** function getpdf +*********************************************************************** + DOUBLE PRECISION FUNCTION GETPDF(X,Q,TYP) + IMPLICIT NONE +C--identifier of file for hepmc output and logfile + common/hepmcid/hpmcfid,logfid + integer hpmcfid,logfid +C--pdf common block + COMMON/PDFS/QINQX(2,1000),GINQX(2,1000),QINGX(2,1000), + &GINGX(2,1000) + DOUBLE PRECISION QINQX,GINQX,QINGX,GINGX +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--variables for pdf integration + COMMON/PDFINTV/XMAX,Z + DOUBLE PRECISION XMAX,Z +C--local variables + DOUBLE PRECISION X,Q,QLOW,QHIGH,YSTART,EPSI,HFIRST + CHARACTER*2 TYP + DATA EPSI/1.d-4/ + + IF((X.LT.0.d0).OR.(X.GT.1.d0).OR.(Q.LT.Q0))THEN + write(logfid,*)'error in GETPDF: parameter out of bound',X,Q + GETPDF=0.d0 + RETURN + ENDIF + + IF(TYP.EQ.'QQ')THEN + Z=X + XMAX=Q +C--f_q^q + QLOW=MAX(Q0,Q0/(2.*SQRT(1.-X))) + QHIGH=Q + IF((QLOW.GE.QHIGH*(1.d0-1.d-10)).OR.(X.GT.1.d0-1.d-10))THEN + YSTART=0.d0 + ELSE + HFIRST=0.01*(QHIGH-QLOW) + YSTART=0.d0 + CALL ODEINT(YSTART,QLOW,QHIGH,EPSI,HFIRST,0.d0,7) + ENDIF + GETPDF=YSTART + ELSEIF(TYP.EQ.'GQ')THEN + Z=X + XMAX=Q +C--f_q^g + QLOW=MAX(Q0,MAX(Q0/(2.*SQRT(X)),Q0/(2.*SQRT(1.-X)))) + QHIGH=Q + IF((QLOW.GE.QHIGH*(1.d0-1.d-10)).OR.(X.LT.0.d0+1.d-10) + & .OR.(X.GT.1.d0-1.d-10))THEN + YSTART=0.d0 + ELSE + HFIRST=0.01*(QHIGH-QLOW) + YSTART=0.d0 + CALL ODEINT(YSTART,QLOW,QHIGH,EPSI,HFIRST,0.d0,8) + ENDIF + GETPDF=YSTART + ELSEIF(TYP.EQ.'QG')THEN + Z=X + XMAX=Q +C--f_q^g + QLOW=MAX(Q0,Q0/(2.*SQRT(1.-X))) + QHIGH=Q + IF((QLOW.GE.QHIGH*(1.d0-1.d-10)).OR.(X.GT.1.d0-1.d-10))THEN + YSTART=0.d0 + ELSE + HFIRST=0.01*(QHIGH-QLOW) + YSTART=0.d0 + CALL ODEINT(YSTART,QLOW,QHIGH,EPSI,HFIRST,0.d0,9) + ENDIF + GETPDF=YSTART + ELSEIF(TYP.EQ.'GG')THEN + Z=X + XMAX=Q +C--f_q^q + QLOW=MAX(Q0,MAX(Q0/(2.*SQRT(X)),Q0/(2.*SQRT(1.-X)))) + QHIGH=Q + IF((QLOW.GE.QHIGH*(1.d0-1.d-10)).OR.(X.LT.0.d0+1.d-10) + & .OR.(X.GT.1.d0-1d-10))THEN + YSTART=0.d0 + ELSE + HFIRST=0.01*(QHIGH-QLOW) + YSTART=0.d0 + CALL ODEINT(YSTART,QLOW,QHIGH,EPSI,HFIRST,0.d0,10) + ENDIF + GETPDF=YSTART + ELSE + write(logfid,*)'error: pdf-type ',TYP,' does not exist' + GETPDF=0.d0 + ENDIF + END + +*********************************************************************** +*** function getpdfxint +*********************************************************************** + DOUBLE PRECISION FUNCTION GETPDFXINT(Q,TYP) + IMPLICIT NONE +C--identifier of file for hepmc output and logfile + common/hepmcid/hpmcfid,logfid + integer hpmcfid,logfid +C--pdf common block + COMMON/PDFS/QINQX(2,1000),GINQX(2,1000),QINGX(2,1000), + &GINGX(2,1000) + DOUBLE PRECISION QINQX,GINQX,QINGX,GINGX +C--number of extrapolations in tables + common/extrapolations/ntotspliti,noverspliti,ntotpdf,noverpdf, + &ntotxsec,noverxsec,ntotsuda,noversuda + integer ntotspliti,noverspliti,ntotpdf,noverpdf, + &ntotxsec,noverxsec,ntotsuda,noversuda +C--local variables + INTEGER J,Q2CLOSE,Q2LINE + DOUBLE PRECISION Q,XA(2),YA(2),Y,A,B + CHARACTER*2 TYP + + ntotpdf=ntotpdf+1 + if (q**2.gt.QINQX(1,1000)) then + noverpdf=noverpdf+1 + if (noverpdf.le.25) + & write(logfid,*)'WARNING in getpdfxint: need to extrapolate: ', + & q**2,QINQX(1,1000) + endif + + Q2CLOSE=INT((LOG(Q**2)-LOG(QINQX(1,1)))*999.d0/ + & (LOG(QINQX(1,1000))-LOG(QINQX(1,1)))+1) + Q2LINE=MAX(Q2CLOSE,1) + Q2LINE=MIN(Q2LINE,999) + IF((Q2LINE.GT.999).OR.(Q2LINE.LT.1))THEN + write(logfid,*)'ERROR in GETPDFXINT: line number out of bound', + & Q2LINE + ENDIF + + IF(TYP.EQ.'QQ')THEN + DO 11 J=1,2 + XA(J)=QINQX(1,Q2LINE-1+J) + YA(J)=QINQX(2,Q2LINE-1+J) + 11 CONTINUE + ELSEIF(TYP.EQ.'GQ')THEN + DO 13 J=1,2 + XA(J)=GINQX(1,Q2LINE-1+J) + YA(J)=GINQX(2,Q2LINE-1+J) + 13 CONTINUE + ELSEIF(TYP.EQ.'QG')THEN + DO 15 J=1,2 + XA(J)=QINGX(1,Q2LINE-1+J) + YA(J)=QINGX(2,Q2LINE-1+J) + 15 CONTINUE + ELSEIF(TYP.EQ.'GG')THEN + DO 17 J=1,2 + XA(J)=GINGX(1,Q2LINE-1+J) + YA(J)=GINGX(2,Q2LINE-1+J) + 17 CONTINUE + ELSE + write(logfid,*)'error in GETPDFXINT: unknown integral type ',TYP + ENDIF + A=(YA(2)-YA(1))/(XA(2)-XA(1)) + B=YA(1)-A*XA(1) + Y=A*Q**2+B + GETPDFXINT=Y + END + + +*********************************************************************** +*** subroutine getpdfxintexact +*********************************************************************** + DOUBLE PRECISION FUNCTION GETPDFXINTEXACT(Q,TYP) + IMPLICIT NONE +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--variables for pdf integration + COMMON/PDFINTV/XMAX,Z + DOUBLE PRECISION XMAX,Z +C--local variables + DOUBLE PRECISION Q,EPSI,YSTART,HFIRST + CHARACTER*2 TYP + DATA EPSI/1.d-4/ + + HFIRST=0.01d0 + YSTART=0.d0 + XMAX=Q + Z=0.d0 + IF(TYP.EQ.'QQ')THEN + CALL ODEINT(YSTART,Q0,Q,EPSI,HFIRST,0.d0,21) + ELSEIF(TYP.EQ.'QG')THEN + CALL ODEINT(YSTART,Q0,Q,EPSI,HFIRST,0.d0,23) + ELSEIF(TYP.EQ.'GQ')THEN + CALL ODEINT(YSTART,Q0,Q,EPSI,HFIRST,0.d0,22) + ELSEIF(TYP.EQ.'GG')THEN + CALL ODEINT(YSTART,Q0,Q,EPSI,HFIRST,0.d0,24) + ENDIF + GETPDFXINTEXACT=YSTART + END + + +*********************************************************************** +*** function getxsecint +*********************************************************************** + DOUBLE PRECISION FUNCTION GETXSECINT(TM,MD,TYP2) + IMPLICIT NONE +C--identifier of file for hepmc output and logfile + common/hepmcid/hpmcfid,logfid + integer hpmcfid,logfid +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--cross secttion common block + COMMON/XSECS/INTQ1(1001,101),INTQ2(1001,101), + &INTG1(1001,101),INTG2(1001,101) + DOUBLE PRECISION INTQ1,INTQ2,INTG1,INTG2 +C--variables for cross section integration + COMMON/XSECV/QLOW,MDX + DOUBLE PRECISION QLOW,MDX +C--number of extrapolations in tables + common/extrapolations/ntotspliti,noverspliti,ntotpdf,noverpdf, + &ntotxsec,noverxsec,ntotsuda,noversuda + integer ntotspliti,noverspliti,ntotpdf,noverpdf, + &ntotxsec,noverxsec,ntotsuda,noversuda +C--local variables + INTEGER TLINE,TCLOSE,MDCLOSE,MDLINE,I,J + DOUBLE PRECISION TM,X1A(2),X2A(2),YA(2,2),Y,MD,YB(2),A,B + CHARACTER*2 TYP2 + + ntotxsec=ntotxsec+1 + if (tm.gt.intq1(1000,101)) then + noverxsec=noverxsec+1 + if (noverpdf.le.25) + & write(logfid,*)'WARNING in getxsecint: need to extrapolate: ', + & tm,intq1(1000,101) + endif + + TCLOSE=INT((LOG(TM)-LOG(INTQ1(1,101)))*999.d0/ + & (LOG(INTQ1(1000,101))-LOG(INTQ1(1,101)))+1) + TLINE=MAX(TCLOSE,1) + TLINE=MIN(TLINE,999) + MDCLOSE=INT((MD-INTQ1(1001,1))*99.d0/ + &(INTQ1(1001,100)-INTQ1(1001,1))+1) + MDLINE=MAX(MDCLOSE,1) + MDLINE=MIN(MDLINE,99) + IF((TLINE.GT.999).OR.(MDLINE.GT.99) + & .OR.(TLINE.LT.1).OR.(MDLINE.LT.1)) THEN + write(logfid,*)'ERROR in GETXSECINT: line number out of bound', + & TLINE,MDLINE + ENDIF + + IF(TYP2.EQ.'QA')THEN +C--first quark integral + DO 12 I=1,2 + X1A(I)=INTQ1(1001,MDLINE-1+I) + X2A(I)=INTQ1(TLINE-1+I,101) + DO 11 J=1,2 + YA(I,J)=INTQ1(TLINE-1+J,MDLINE-1+I) + 11 CONTINUE + 12 CONTINUE + ELSEIF(TYP2.EQ.'QB')THEN +C--second quark integral + DO 18 I=1,2 + X1A(I)=INTQ2(1001,MDLINE-1+I) + X2A(I)=INTQ2(TLINE-1+I,101) + DO 17 J=1,2 + YA(I,J)=INTQ2(TLINE-1+J,MDLINE-1+I) + 17 CONTINUE + 18 CONTINUE + ELSEIF(TYP2.EQ.'GA')THEN +C--first gluon integral + DO 14 I=1,2 + X1A(I)=INTG1(1001,MDLINE-1+I) + X2A(I)=INTG1(TLINE-1+I,101) + DO 13 J=1,2 + YA(I,J)=INTG1(TLINE-1+J,MDLINE-1+I) + 13 CONTINUE + 14 CONTINUE + ELSEIF(TYP2.EQ.'GB')THEN +C--second gluon integral + DO 16 I=1,2 + X1A(I)=INTG2(1001,MDLINE-1+I) + X2A(I)=INTG2(TLINE-1+I,101) + DO 15 J=1,2 + YA(I,J)=INTG2(TLINE-1+J,MDLINE-1+I) + 15 CONTINUE + 16 CONTINUE + ELSE + write(logfid,*)'error in GETXSECINT: unknown integral type ', + & TYP2 + ENDIF + DO 19 I=1,2 + A=(YA(I,2)-YA(I,1))/(X2A(2)-X2A(1)) + B=YA(I,1)-A*X2A(1) + YB(I)=A*TM+B + 19 CONTINUE + IF(X1A(1).EQ.X1A(2))THEN + Y=YB(1) + ELSE + A=(YB(2)-YB(1))/(X1A(2)-X1A(1)) + B=YB(1)-A*X1A(1) + Y=A*MD+B + ENDIF + GETXSECINT=Y + END + + +*********************************************************************** +*** function getinsudafast +*********************************************************************** + DOUBLE PRECISION FUNCTION GETINSUDAFAST(Q1,Q2,TYP) + IMPLICIT NONE +C--identifier of file for hepmc output and logfile + common/hepmcid/hpmcfid,logfid + integer hpmcfid,logfid +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--local variables + DOUBLE PRECISION Q1,Q2,GETINSUDARED + CHARACTER*2 TYP + + IF(Q2.LE.Q1)THEN + GETINSUDAFAST=1.d0 + ELSEIF(Q1.LE.Q0)THEN + GETINSUDAFAST=GETINSUDARED(Q2,TYP) + ELSE + GETINSUDAFAST=GETINSUDARED(Q2,TYP)/GETINSUDARED(Q1,TYP) + ENDIF + IF(GETINSUDAFAST.GT.1.d0) GETINSUDAFAST=1.d0 + IF(GETINSUDAFAST.LT.(-1.d-10))THEN + write(logfid,*)'ERROR: GETINSUDAFAST < 0:', + & GETINSUDAFAST,' for',Q1,' ',Q2,' ',TYP + ENDIF + if (getinsudafast.lt.0.d0) getinsudafast = 0.d0 + END + + +*********************************************************************** +*** function getinsudared +*********************************************************************** + DOUBLE PRECISION FUNCTION GETINSUDARED(Q,TYP2) + IMPLICIT NONE +C--identifier of file for hepmc output and logfile + common/hepmcid/hpmcfid,logfid + integer hpmcfid,logfid +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--Sudakov common block + COMMON/INSUDA/SUDAQQ(1000,2),SUDAQG(1000,2),SUDAGG(1000,2), + &SUDAGC(1000,2) + DOUBLE PRECISION SUDAQQ,SUDAQG,SUDAGG,SUDAGC +C--number of extrapolations in tables + common/extrapolations/ntotspliti,noverspliti,ntotpdf,noverpdf, + &ntotxsec,noverxsec,ntotsuda,noversuda + integer ntotspliti,noverspliti,ntotpdf,noverpdf, + &ntotxsec,noverxsec,ntotsuda,noversuda +C--local variables + INTEGER QCLOSE,QBIN,I + DOUBLE PRECISION Q,XA(2),YA(2),Y,A,B + CHARACTER*2 TYP2 + + ntotsuda=ntotsuda+1 + if (q.gt.sudaqq(1000,1)) then + noversuda=noversuda+1 + if (noversuda.le.25) + & write(logfid,*)'WARNING in getinsudared: need to extrapolate: ', + & q,sudaqq(1000,1) + endif + + QCLOSE=INT((LOG(Q)-LOG(SUDAQQ(1,1)))*999.d0 + & /(LOG(SUDAQQ(1000,1))-LOG(SUDAQQ(1,1)))+1) + QBIN=MAX(QCLOSE,1) + QBIN=MIN(QBIN,999) + IF((QBIN.GT.999).OR.(QBIN.LT.1)) THEN + write(logfid,*) + & 'ERROR in GETINSUDARED: line number out of bound',QBIN + ENDIF + IF(TYP2.EQ.'QQ')THEN + DO 16 I=1,2 + XA(I)=SUDAQQ(QBIN-1+I,1) + YA(I)=SUDAQQ(QBIN-1+I,2) + 16 CONTINUE + ELSEIF(TYP2.EQ.'QG')THEN + DO 17 I=1,2 + XA(I)=SUDAQG(QBIN-1+I,1) + YA(I)=SUDAQG(QBIN-1+I,2) + 17 CONTINUE + ELSEIF(TYP2.EQ.'GG')THEN + DO 18 I=1,2 + XA(I)=SUDAGG(QBIN-1+I,1) + YA(I)=SUDAGG(QBIN-1+I,2) + 18 CONTINUE + ELSEIF(TYP2.EQ.'GC')THEN + DO 19 I=1,2 + XA(I)=SUDAGC(QBIN-1+I,1) + YA(I)=SUDAGC(QBIN-1+I,2) + 19 CONTINUE + ELSE + write(logfid,*)'error in GETINSUDARED: unknown type ',TYP2 + ENDIF + A=(YA(2)-YA(1))/(XA(2)-XA(1)) + B=YA(1)-A*XA(1) + Y=A*Q+B + GETINSUDARED=Y + IF(GETINSUDARED.LT.(-1.d-10))THEN + write(logfid,*) 'ERROR: GETINSUDARED < 0:',GETINSUDARED,Q,TYP2 + ENDIF + if (getinsudared.lt.0.d0) getinsudared = 0.d0 + END + + +*********************************************************************** +*** function getsscat +*********************************************************************** + DOUBLE PRECISION FUNCTION GETSSCAT(EN,px,py,PZ,MP,LW,TYPE1,TYPE2, + & x,y,z,t,mode) + IMPLICIT NONE +C--identifier of file for hepmc output and logfile + common/hepmcid/hpmcfid,logfid + integer hpmcfid,logfid +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--variables for cross section integration + COMMON/XSECV/QLOW,MDX + DOUBLE PRECISION QLOW,MDX +C--local variables + integer mode + DOUBLE PRECISION UP,EN,LW,SCATPRIMFUNC,CCOL,MP, + &LOW,GETPDFXINT,GETXSECINT,MDEB,pz,pcms2,shat, + &x,y,z,t,getmd,avmom(5),px,py,getmdmin,getmdmax,pproj,psct + CHARACTER TYPE1,TYPE2 + + IF(TYPE1.EQ.'Q')THEN + CCOL=2./3. + ELSE + CCOL=3./2. + ENDIF + if (mode.eq.0) then + mdeb = getmd(x,y,z,t) + call avscatcen(x,y,z,t, + & avmom(1),avmom(2),avmom(3),avmom(4),avmom(5)) + shat = avmom(5)**2 + mp**2 + + & 2.*(avmom(4)*en - avmom(1)*px - avmom(2)*py - avmom(3)*pz) + pcms2 = (shat+mp**2-avmom(5)**2)**2/(4.*shat)-mp**2 + up = 4.*pcms2 + else + if (mode.eq.1) then + mdeb = getmdmin() + else + mdeb = getmdmax() + endif + call maxscatcen(avmom(1),avmom(2),avmom(3),avmom(4),avmom(5)) + psct = sqrt(avmom(1)**2+avmom(2)**2+avmom(3)**2) + pproj = sqrt(px**2+py**2+pz**2) + shat = avmom(5)**2 + mp**2 + 2.*(en*avmom(4) + pproj*psct) + pcms2 = (shat+mp**2-avmom(5)**2)**2/(4.*shat)-mp**2 + up = 4.*pcms2 + endif + LOW=LW**2 + IF(LOW.GT.UP)THEN + GETSSCAT=0.d0 + RETURN + ENDIF + IF((TYPE2.EQ.'C').OR. + & ((TYPE1.EQ.'Q').AND.(TYPE2.EQ.'Q')).OR. + & ((TYPE1.EQ.'G').AND.(TYPE2.EQ.'G')))THEN + GETSSCAT=CCOL*(SCATPRIMFUNC(UP,MDEB)-SCATPRIMFUNC(LOW,MDEB)) + ELSE + GETSSCAT=0.d0 + ENDIF + LOW=Q0**2/SCALEFACM**2 + IF(UP.GT.LOW)THEN + IF(TYPE1.EQ.'Q')THEN + IF((TYPE2.EQ.'C').OR.(TYPE2.EQ.'G'))THEN + GETSSCAT=GETSSCAT+GETPDFXINT(SCALEFACM*SQRT(UP),'GQ') + & *3.*SCATPRIMFUNC(UP,MDEB)/2. + GETSSCAT=GETSSCAT-GETXSECINT(UP,MDEB,'QA') + ENDIF + ELSE + IF((TYPE2.EQ.'C').OR.(TYPE2.EQ.'G'))THEN + GETSSCAT=GETSSCAT+CCOL*(SCATPRIMFUNC(UP,MDEB)- + & SCATPRIMFUNC(LOW,MDEB)) + & - GETXSECINT(UP,MDEB,'GB') + ENDIF + IF((TYPE2.EQ.'C').OR.(TYPE2.EQ.'Q'))THEN + GETSSCAT=GETSSCAT+2.*GETPDFXINT(SCALEFACM*SQRT(UP),'QG') + & *2.*SCATPRIMFUNC(UP,MDEB)/3. + GETSSCAT=GETSSCAT-2.*GETXSECINT(UP,MDEB,'GA') + ENDIF + ENDIF + ENDIF + IF(GETSSCAT.LT.-1.d-4) + & write(logfid,*) 'error: cross section < 0',GETSSCAT,'for', + & EN,MP,LW,TYPE1,TYPE2,LW**2,UP + GETSSCAT=MAX(GETSSCAT,0.d0) + END + + + +*********************************************************************** +*** function getmass +*********************************************************************** + DOUBLE PRECISION FUNCTION GETMASS(QBMIN,QBMAX,THETA,EP,TYPE, + & MAX2,INS,ZDEC,QQBARDEC) + IMPLICIT NONE +C--identifier of file for hepmc output and logfile + common/hepmcid/hpmcfid,logfid + integer hpmcfid,logfid +C--Common block of Pythia + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + INTEGER N,NPAD,K + DOUBLE PRECISION P,V + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + INTEGER MSTU,MSTJ + DOUBLE PRECISION PARU,PARJ + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + INTEGER MDCY,MDME,KFDP + DOUBLE PRECISION BRAT +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--time common block + COMMON/TIME/MV(23000,5) + DOUBLE PRECISION MV +C--factor in front of alphas argument + COMMON/ALPHASFAC/PTFAC + DOUBLE PRECISION PTFAC +C--local variables + DOUBLE PRECISION qbmin,qbmax,theta,ep,max2,zdec, + &q2min,alphmax,alphas,log14,pref,q2max,sudaover,gmin, + &gmax,arg,cand,eps,trueeps,trueval,oest,weight,getinspliti, + &r,pyr,z,rz,thetanew,r2,pi,pqq,pgg,pqg + CHARACTER*2 TYPE + LOGICAL INS,QQBARDEC + DATA PI/3.141592653589793d0/ + + q2min = q0**2 + + alphmax = alphas(3.*ptfac*q2min/16.,lps) + log14 = log(0.25) + + IF(TYPE.EQ.'QQ')THEN + pref=4.*alphmax/(3.*2.*PI) + ELSE + pref=29.*alphmax/(8.*2.*PI) + ENDIF + +C--check if virtual mass is allowed, return 0.d0 otherwise + IF((qbmax.LE.QBMIN).OR.(EP.LT.QBMIN)) THEN + getmass=0.d0 + ZDEC=0.d0 + QQBARDEC=.FALSE. + RETURN + ENDIF + + q2max = qbmax**2 + 21 sudaover = exp(-pref*(log(q2min/(4.*q2max))**2 - log14**2)) + IF(pyr(0).LE.sudaover)THEN + getmass=0.d0 + ZDEC=0.d0 + QQBARDEC=.FALSE. + RETURN + endif + r=pyr(0) + gmin = pref*log14**2 + gmax = pref*log(q2min/(4.*q2max))**2 + arg = log(r*exp(gmax)+(1.-r)*exp(gmin)) + cand = q2min*exp(sqrt(arg/pref))/4. + eps = q2min/(4.*cand) + + if (cand.lt.qbmin**2) then + getmass=0.d0 + ZDEC=0.d0 + QQBARDEC=.FALSE. + RETURN + endif + + IF((CAND.GT.MAX2**2).OR.(CAND.GT.EP**2))THEN + q2max=cand + goto 21 + ENDIF + + if (ins) then + trueval=getinspliti(sqrt(cand),type) + oest = -2.*pref*log(eps) + weight = trueval/oest + else +C--find true z interval + TRUEEPS=0.5-0.5*SQRT(1.-q2min/cand) + & *SQRT(1.-cand/EP**2) + IF(TRUEEPS.LT.EPS) + & WRITE(logfid,*)'error in getmass: true eps < eps',TRUEEPS,EPS + RZ=PYR(0) + z = 1.-eps**rz + if ((z.lt.trueeps).or.(z.gt.(1.-trueeps))) then + weight = 0. + else + if (type.eq.'QQ')then + trueval = alphas(ptfac*z*(1.-z)*cand,lps)*pqq(z)/(2.*pi) + oest = 2.*pref/(1.-z) + weight = trueval/oest + else + if (pyr(0).lt.(17./29.)) z = 1.-z + trueval = alphas(ptfac*z*(1.-z)*cand,lps) + & *(pgg(z)+pqg(z))/(2.*pi) + oest = alphmax*(17./(4.*z)+3./(1.-z))/(2.*pi) + weight = trueval/oest + endif + thetanew = sqrt(cand/(z*(1.-z)))/ep + if (angord.and.(theta.gt.0.).and.(thetanew.gt.theta)) + & weight = 0.d0 + endif + endif + IF (WEIGHT.GT.1.d0) WRITE(logfid,*) + & 'problem in getmass: weight> 1', + & WEIGHT,TYPE,EPS,TRUEEPS,Z,CAND + R2=PYR(0) + IF(R2.GT.WEIGHT)THEN + q2max=cand + GOTO 21 + ELSE + getmass=sqrt(cand) + if (.not.ins) then + ZDEC=Z + IF(TYPE.EQ.'QQ')THEN + QQBARDEC=.FALSE. + ELSE + IF(PYR(0).LT.PQG(Z)/(PQG(Z)+PGG(Z)))THEN + QQBARDEC=.TRUE. + ELSE + QQBARDEC=.FALSE. + ENDIF + ENDIF + endif + ENDIF + END + + + +*********************************************************************** +*** function generatez +*********************************************************************** + DOUBLE PRECISION FUNCTION GENERATEZ(TI,EA,EPSI,TYPE) + IMPLICIT NONE +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--local variables + DOUBLE PRECISION TI,EA,EPS,PYR,X,R,HELP,R1,EPSI + CHARACTER*2 TYPE + + IF(TI.EQ.0.d0)THEN + EPS=EPSI + ELSE + EPS=MAX(0.5-0.5*SQRT(1.-Q0**2/TI) + & *SQRT(1.-TI/EA**2),EPSI) + ENDIF + IF(EPS.GT.0.5)THEN + GENERATEZ=0.5 + GOTO 61 + ENDIF + 60 R=PYR(0) + IF(TYPE.EQ.'QQ')THEN + X=1.-(1.-EPS)*(EPS/(1.-EPS))**R + R=PYR(0) + IF(R.LT.((1.+X**2)/2.))THEN + GENERATEZ=X + ELSE + GOTO 60 + ENDIF + ELSEIF(TYPE.EQ.'GG')THEN + X=1./(1.+((1.-EPS)/EPS)**(1.-2.*R)) + R=PYR(0) + HELP=((1.-X)/X+X/(1.-X)+X*(1.-X))/(1./(1.-X)+1./X) + IF(R.LT.HELP)THEN + GENERATEZ=X + ELSE + GOTO 60 + ENDIF + ELSE + R=PYR(0)*(1.-2.*EPS)+EPS + R1=PYR(0)/2. + HELP=0.5*(R**2+(1.-R)**2) + IF(R1.LT.HELP)THEN + GENERATEZ=R + ELSE + GOTO 60 + ENDIF + ENDIF + 61 END + + + +*********************************************************************** +*** function scatprimfunc +*********************************************************************** + DOUBLE PRECISION FUNCTION SCATPRIMFUNC(T,MDEB) + IMPLICIT NONE +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--local variables + DOUBLE PRECISION T,PI,S,EI,ALPHAS,T1,MDEB + DATA PI/3.141592653589793d0/ + + SCATPRIMFUNC = 2.*PI*(12.*PI)**2*( + & - EI(-LOG((T+MDEB**2)/LQCD**2))/LQCD**2 + & - 1./((T+MDEB**2)*LOG((T+MDEB**2)/LQCD**2)))/(33.-2.*NF)**2 + END + + + +*********************************************************************** +*** function intpqq +*********************************************************************** + DOUBLE PRECISION FUNCTION INTPQQ(Z,Q) + IMPLICIT NONE +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--local variables + DOUBLE PRECISION Z,Q + + INTPQQ=6.*4.*(-2.*LOG(LOG(Q**2/LPS**2) + & +LOG(1.-Z)))/((33.-2.*NF)*3.) + END + + + +*********************************************************************** +*** function intpgglow +*********************************************************************** + DOUBLE PRECISION FUNCTION INTPGGLOW(Z,Q) + IMPLICIT NONE +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--local variables + DOUBLE PRECISION Z,Q + + INTPGGLOW=6.*3.*(LOG(LOG(Q**2/LPS**2)+LOG(Z)))/(33.-2.*NF) + END + + + +*********************************************************************** +*** function intpgghigh +*********************************************************************** + DOUBLE PRECISION FUNCTION INTPGGHIGH(Z,Q) + IMPLICIT NONE +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--local variables + DOUBLE PRECISION Z,Q + + INTPGGHIGH=-6.*3.*(LOG(LOG(Q**2/LPS**2)+LOG(1.-Z)))/(33.-2.*NF) + END + + + +*********************************************************************** +*** function intpqglow +*********************************************************************** + DOUBLE PRECISION FUNCTION INTPQGLOW(Z,Q) + IMPLICIT NONE +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--local variables + DOUBLE PRECISION Z,Q,EI + + INTPQGLOW=6.*(LPS**2*EI(LOG(Q**2/LPS**2)+LOG(Z))/Q**2 + & - 2.*LPS**4*EI(2.*(LOG(Q**2/LPS**2)+LOG(Z)))/Q**4 + & + 2.*LPS**6*EI(3.*(LOG(Q**2/LPS**2)+LOG(Z)))/Q**6)/ + &((33.-2.*NF)*2.) + END + + + +*********************************************************************** +*** function intpqghigh +*********************************************************************** + DOUBLE PRECISION FUNCTION INTPQGHIGH(Z,Q) + IMPLICIT NONE +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--local variables + DOUBLE PRECISION Z,Q,EI + + INTPQGHIGH=-6.*(LPS**2*EI(LOG(Q**2/LPS**2)+LOG(1.-Z))/Q**2 + & - 2.*LPS**4*EI(2.*(LOG(Q**2/LPS**2)+LOG(1.-Z)))/Q**4 + & + 2.*LPS**6*EI(3.*(LOG(Q**2/LPS**2)+LOG(1.-Z)))/Q**6)/ + &((33.-2.*NF)*2.) + END + + + +*********************************************************************** +*** function gett +*********************************************************************** + DOUBLE PRECISION FUNCTION GETT(MINT,MAXT,MDEB) + IMPLICIT NONE +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--local variables + DOUBLE PRECISION TMIN,TMAX,MAXI,PYR,R1,R2,ALPHAS,PI,Y,MAXT, + &MDEB,MINT,T + DATA PI/3.141592653589793d0/ + + TMAX=MAXT+MDEB**2 + TMIN=MINT+MDEB**2 + IF(TMIN.GT.TMAX) THEN + GETT=0.d0 + RETURN + ENDIF + 20 R1=PYR(0) + T=TMAX*TMIN/(TMAX+R1*(TMIN-TMAX)) + R2=PYR(0) + IF(R2.LT.ALPHAS(T,LQCD)**2/ALPHAS(TMIN,LQCD)**2)THEN + GETT=T-MDEB**2 + ELSE + GOTO 20 + ENDIF + + END + + + +*********************************************************************** +*** function ei +*********************************************************************** + DOUBLE PRECISION FUNCTION EI(X) + IMPLICIT NONE +C--identifier of file for hepmc output and logfile + common/hepmcid/hpmcfid,logfid + integer hpmcfid,logfid +C--exponential integral for negative arguments + COMMON/EXPINT/EIXS(3,1000),VALMAX,NVAL + INTEGER NVAL + DOUBLE PRECISION EIXS,VALMAX +C--local variables + INTEGER K,LINE,LMAX + DOUBLE PRECISION X,R,GA,XA(2),YA(2),Y,DY,A,B + DOUBLE PRECISION YSTART,EPSI,HFIRST + DATA EPSI/1.e-5/ + + IF(DABS(X).GT.VALMAX) + & write(logfid,*)'warning: value out of array in Ei(x)',X,VALMAX + + IF(X.GE.0.d0)THEN + LMAX=INT(X*NVAL/VALMAX) + LINE=MAX(LMAX,1) + LINE=MIN(LINE,999) + IF((LINE.GT.999).OR.(LINE.LT.1)) THEN + write(logfid,*)'ERROR in EI: line number out of bound',LINE + ENDIF + DO 26 K=1,2 + XA(K)=EIXS(1,LINE-1+K) + YA(K)=EIXS(3,LINE-1+K) + 26 CONTINUE + A=(YA(2)-YA(1))/(XA(2)-XA(1)) + B=YA(1)-A*XA(1) + Y=A*X+B + ELSE + LMAX=INT(-X*NVAL/VALMAX) + LINE=MAX(LMAX,1) + LINE=MIN(LINE,999) + IF((LINE.GT.999).OR.(LINE.LT.1)) THEN + write(logfid,*)'ERROR in EI: line number out of bound',LINE + ENDIF + DO 27 K=1,2 + XA(K)=EIXS(1,LINE-1+K) + YA(K)=EIXS(2,LINE-1+K) + 27 CONTINUE + A=(YA(2)-YA(1))/(XA(2)-XA(1)) + B=YA(1)-A*XA(1) + Y=-A*X+B + ENDIF + EI=Y + END + + + +*********************************************************************** +*** function pqq +*********************************************************************** + DOUBLE PRECISION FUNCTION PQQ(Z) + IMPLICIT NONE + DOUBLE PRECISION Z + PQQ=4.*(1.+Z**2)/(3.*(1.-Z)) + END + + + +*********************************************************************** +*** function pgq +*********************************************************************** + DOUBLE PRECISION FUNCTION PGQ(Z) + IMPLICIT NONE + DOUBLE PRECISION Z + PGQ=4.*(1.+(1.-Z)**2)/(3.*Z) + END + + + +*********************************************************************** +*** function pgg +*********************************************************************** + DOUBLE PRECISION FUNCTION PGG(Z) + IMPLICIT NONE + DOUBLE PRECISION Z + PGG=3.*((1.-Z)/Z + Z/(1.-Z) + Z*(1.-Z)) + END + + + +*********************************************************************** +*** function pqg +*********************************************************************** + DOUBLE PRECISION FUNCTION PQG(Z) + IMPLICIT NONE + DOUBLE PRECISION Z + PQG=0.5*(Z**2 + (1.-Z)**2) + END + + + +*********************************************************************** +*** function alphas +*********************************************************************** + DOUBLE PRECISION FUNCTION ALPHAS(T,LAMBDA) + IMPLICIT NONE +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--local variables + DOUBLE PRECISION T,L0,PI,LAMBDA + DATA PI/3.141592653589793d0/ + + ALPHAS=4.*PI/((11.-2.*NF/3.)*LOG(T/LAMBDA**2)) + END + + + +*********************************************************************** +*** subroutine splitfncint +*********************************************************************** + SUBROUTINE SPLITFNCINT(EMAX) + IMPLICIT NONE +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--splitting integral + COMMON/SPLITINT/SPLITIGGV(1000,1000),SPLITIQQV(1000,1000), + &SPLITIQGV(1000,1000),QVAL(1000),ZMVAL(1000),QMAX,ZMMIN,NPOINT + INTEGER NPOINT + DOUBLE PRECISION SPLITIGGV,SPLITIQQV,SPLITIQGV, + &QVAL,ZMVAL,QMAX,ZMMIN +C--variables for splitting function integration + COMMON/INTSPLITF/QQUAD,FM + DOUBLE PRECISION QQUAD,FM +C--max rapidity + common/rapmax/etamax + double precision etamax +C--local variables + INTEGER NSTEP,I,J + DOUBLE PRECISION EMAX,ZMMAX,EPSI,HFIRST,YSTART,LNZMMIN, + &LNZMMAX,ZM,ZM2,Q,GETMSMAX,avmom(5),shat,pcms2 + DATA ZMMAX/0.5/ + DATA NSTEP/999/ + DATA EPSI/1.d-5/ + + call maxscatcen(avmom(1),avmom(2),avmom(3),avmom(4),avmom(5)) + shat = avmom(5)**2 + + & 2.*emax*(avmom(4)+sqrt(avmom(1)**2+avmom(2)**2+avmom(3)**2)) + pcms2 = (shat-avmom(5)**2)**2/(4.*shat) + qmax = sqrt(scalefacm*4.*pcms2) + + ZMMIN=Q0/EMAX + + LNZMMIN=LOG(ZMMIN) + LNZMMAX=LOG(ZMMAX) + + NPOINT=NSTEP + + DO 100 I=1,NSTEP+1 + Q=(I-1)*(QMAX-Q0)/NSTEP+Q0 + QVAL(I)=Q + QQUAD=Q**2 + DO 110 J=1,NSTEP+1 + ZM=EXP((J-1)*(LNZMMAX-LNZMMIN)/NSTEP+LNZMMIN) + ZMVAL(J)=ZM + IF(Q**2.LT.Q0**2)THEN + ZM2=0.5 + ELSE + ZM2=0.5-0.5*SQRT(1.-Q0**2/Q**2) + ENDIF + ZM=MAX(ZM,ZM2) + IF(ZM.EQ.0.5)THEN + SPLITIQQV(I,J)=0.d0 + SPLITIGGV(I,J)=0.d0 + SPLITIQGV(I,J)=0.d0 + ELSE + YSTART=0d0 + HFIRST=0.01 + FM=0.d0 + CALL ODEINT(YSTART,ZM,1.-ZM,EPSI,HFIRST,0d0,2) + SPLITIQQV(I,J)=YSTART + YSTART=0d0 + HFIRST=0.01 + FM=0.d0 + CALL ODEINT(YSTART,ZM,1.-ZM,EPSI,HFIRST,0d0,3) + SPLITIGGV(I,J)=YSTART + YSTART=0d0 + HFIRST=0.01 + FM=0.d0 + CALL ODEINT(YSTART,ZM,1.-ZM,EPSI,HFIRST,0d0,4) + SPLITIQGV(I,J)=YSTART + ENDIF + 110 CONTINUE + 100 CONTINUE + + END + + + +*********************************************************************** +*** subroutine pdfint +*********************************************************************** + SUBROUTINE PDFINT(EMAX) + IMPLICIT NONE +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--pdf common block + COMMON/PDFS/QINQX(2,1000),GINQX(2,1000),QINGX(2,1000), + &GINGX(2,1000) + DOUBLE PRECISION QINQX,GINQX,QINGX,GINGX +C--variables for pdf integration + COMMON/PDFINTV/XMAX,Z + DOUBLE PRECISION XMAX,Z +C--max rapidity + common/rapmax/etamax + double precision etamax +C--local variables + INTEGER I,J + DOUBLE PRECISION EMAX,Q2,GETPDFXINTEXACT,YSTART,HFIRST,EPSI, + &Q2MAX,DELTAQ2,avmom(5),shat,pcms2 + DATA EPSI/1.d-4/ + + call maxscatcen(avmom(1),avmom(2),avmom(3),avmom(4),avmom(5)) + shat = avmom(5)**2 + + & 2.*emax*(avmom(4)+sqrt(avmom(1)**2+avmom(2)**2+avmom(3)**2)) + pcms2 = (shat-avmom(5)**2)**2/(4.*shat) + q2max = scalefacm*4.*pcms2 + + DELTAQ2=LOG(Q2MAX)-LOG(Q0**2) + QINQX(1,1)=Q0**2 + GINQX(1,1)=Q0**2 + QINGX(1,1)=Q0**2 + GINGX(1,1)=Q0**2 + QINQX(2,1)=0.d0 + GINQX(2,1)=0.d0 + QINGX(2,1)=0.d0 + GINGX(2,1)=0.d0 + DO 12 J=2,1000 + Q2 = EXP((J-1)*DELTAQ2/999.d0 + LOG(Q0**2)) + QINQX(1,J)=Q2 + GINQX(1,J)=Q2 + QINGX(1,J)=Q2 + GINGX(1,J)=Q2 + QINQX(2,J)=GETPDFXINTEXACT(SQRT(Q2),'QQ') + GINQX(2,J)=GETPDFXINTEXACT(SQRT(Q2),'GQ') + QINGX(2,J)=GETPDFXINTEXACT(SQRT(Q2),'QG') + GINGX(2,J)=GETPDFXINTEXACT(SQRT(Q2),'GG') + 12 CONTINUE + END + + + +*********************************************************************** +*** subroutine xsecint +*********************************************************************** + SUBROUTINE XSECINT(EMAX) + IMPLICIT NONE +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--cross secttion common block + COMMON/XSECS/INTQ1(1001,101),INTQ2(1001,101), + &INTG1(1001,101),INTG2(1001,101) + DOUBLE PRECISION INTQ1,INTQ2,INTG1,INTG2 +C--variables for cross section integration + COMMON/XSECV/QLOW,MDX + DOUBLE PRECISION QLOW,MDX +C--max rapidity + common/rapmax/etamax + double precision etamax +C--local variables + INTEGER J,K + DOUBLE PRECISION EMAX,TMAX,TMAXMAX,DELTATMAX,YSTART,HFIRST,EPSI, + &GETMSMAX,GETMDMAX,MDMIN,MDMAX,DELTAMD,GETMDMIN,avmom(5),shat,pcms2 + DATA EPSI/1.d-4/ + + call maxscatcen(avmom(1),avmom(2),avmom(3),avmom(4),avmom(5)) + shat = avmom(5)**2 + + & 2.*emax*(avmom(4)+sqrt(avmom(1)**2+avmom(2)**2+avmom(3)**2)) + pcms2 = (shat-avmom(5)**2)**2/(4.*shat) + tmaxmax = scalefacm*4.*pcms2 + DELTATMAX=(LOG(TMAXMAX)- + & LOG(Q0**2*(1.d0+1.d-6)/SCALEFACM**2))/999.d0 + MDMIN=GETMDMIN() + MDMAX=MAX(MDMIN,GETMDMAX()) + DELTAMD=(MDMAX-MDMIN)/99.d0 + + DO 12 J=1,1000 + TMAX = EXP((J-1)*DELTATMAX + & + LOG(Q0**2*(1.d0+1.d-6)/SCALEFACM**2)) + INTQ1(J,101)=TMAX + INTQ2(J,101)=TMAX + INTG1(J,101)=TMAX + INTG2(J,101)=TMAX + DO 13 K=1,100 + MDX=MDMIN+(K-1)*DELTAMD + INTQ1(1001,K)=MDX + INTQ2(1001,K)=MDX + INTG1(1001,K)=MDX + INTG2(1001,K)=MDX + IF(TMAX.LT.Q0**2/SCALEFACM**2)THEN + INTQ1(J,K)=0.d0 + INTQ2(J,K)=0.d0 + INTG1(J,K)=0.d0 + INTG2(J,K)=0.d0 + ELSE +C--first quark integral + QLOW=Q0 + HFIRST=0.01*(TMAX-Q0**2/SCALEFACM**2) + YSTART=0.d0 + CALL ODEINT(YSTART,Q0**2/SCALEFACM**2,TMAX,EPSI,HFIRST + & ,0.d0,11) + INTQ1(J,K)=YSTART +C--second quark integral + QLOW=Q0 + HFIRST=0.01*(TMAX-Q0**2/SCALEFACM**2) + YSTART=0.d0 + CALL ODEINT(YSTART,Q0**2/SCALEFACM**2,TMAX,EPSI,HFIRST + & ,0.d0,14) + INTQ2(J,K)=YSTART +C--first gluon integral + QLOW=Q0 + YSTART=0.d0 + CALL ODEINT(YSTART,Q0**2/SCALEFACM**2,TMAX,EPSI,HFIRST + & ,0.d0,12) + INTG1(J,K)=YSTART +C--second gluon integral + QLOW=Q0 + YSTART=0.d0 + CALL ODEINT(YSTART,Q0**2/SCALEFACM**2,TMAX,EPSI,HFIRST + & ,0.d0,13) + INTG2(J,K)=YSTART + ENDIF + 13 CONTINUE + 12 CONTINUE + END + + + +*********************************************************************** +*** function insudaint +*********************************************************************** + SUBROUTINE INSUDAINT(EMAX) + IMPLICIT NONE +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--Sudakov common block + COMMON/INSUDA/SUDAQQ(1000,2),SUDAQG(1000,2),SUDAGG(1000,2), + &SUDAGC(1000,2) + DOUBLE PRECISION SUDAQQ,SUDAQG,SUDAGG,SUDAGC +C--max rapidity + common/rapmax/etamax + double precision etamax +C--local variables + INTEGER I + DOUBLE PRECISION QMAX,Q,GETINSUDAKOV,DELTA,EMAX,avmom(5), + &shat,pcms2 + + call maxscatcen(avmom(1),avmom(2),avmom(3),avmom(4),avmom(5)) + shat = avmom(5)**2 + + & 2.*emax*(avmom(4)+sqrt(avmom(1)**2+avmom(2)**2+avmom(3)**2)) + pcms2 = (shat-avmom(5)**2)**2/(4.*shat) + qmax = sqrt(scalefacm*4.*pcms2) + DELTA=(LOG(3.*QMAX)-LOG(Q0**2*(1.d0+1.d-6)))/999.d0 + DO 22 I=1,1000 + Q = EXP((I-1)*DELTA + LOG(Q0**2*(1.d0+1.d-6))) + SUDAQQ(I,1)=Q + SUDAQG(I,1)=Q + SUDAGG(I,1)=Q + SUDAGC(I,1)=Q + SUDAQQ(I,2)=GETINSUDAKOV(Q0,Q,'QQ') + SUDAQG(I,2)=GETINSUDAKOV(Q0,Q,'QG') + SUDAGG(I,2)=GETINSUDAKOV(Q0,Q,'GG') + SUDAGC(I,2)=GETINSUDAKOV(Q0,Q,'GC') + 22 CONTINUE + END + + + +*********************************************************************** +*** function eixint +*********************************************************************** + SUBROUTINE EIXINT + IMPLICIT NONE +C--exponential integral for negative arguments + COMMON/EXPINT/EIXS(3,1000),VALMAX,NVAL + INTEGER NVAL + DOUBLE PRECISION EIXS,VALMAX +C-local variables + INTEGER I,K + DOUBLE PRECISION X,EPSI,HFIRST,YSTART,EI,GA,R + DATA EPSI/1.d-5/ + + NVAL=1000 + VALMAX=55. + + DO 10 I=1,NVAL + X=I*VALMAX/(NVAL*1.d0) + EIXS(1,I)=X +C--do negative arguments first + YSTART=0d0 + HFIRST=0.01 + CALL ODEINT(YSTART,X,1000.d0,EPSI,HFIRST,0.d0,5) + EIXS(2,I)=-YSTART +C--now do the positive arguments + IF (X.EQ.0.0) THEN + EI=-1.0D+300 + ELSE IF (X.LE.40.0) THEN + EI=1.0D0 + R=1.0D0 + DO 15 K=1,100 + R=R*K*X/(K+1.0D0)**2 + EI=EI+R + IF (DABS(R/EI).LE.1.0D-15) GO TO 20 +15 CONTINUE +20 GA=0.5772156649015328D0 + EI=GA+DLOG(X)+X*EI + ELSE + EI=1.0D0 + R=1.0D0 + DO 25 K=1,20 + R=R*K/X +25 EI=EI+R + EI=DEXP(X)/X*EI + ENDIF + EIXS(3,I)=EI + 10 CONTINUE + END + + + +*********************************************************************** +*** function odeint +*********************************************************************** + subroutine odeint(ystart,a,b,eps,h1,hmin,w1) + implicit none +C--identifier of file for hepmc output and logfile + common/hepmcid/hpmcfid,logfid + integer hpmcfid,logfid +C--local variables + integer nmax,nstep,w1 + double precision ystart,a,b,eps,h1,hmin,x,h,y,dydx, + &deriv,yscale,hdid,hnew + data nmax/100000/ + + x = a + y = ystart + h = sign(h1,b-a) + do 20 nstep=1,nmax + dydx = deriv(x,w1) + yscale = abs(y) + abs(h*dydx) + 1.e-25 + if (((x + h - b)*h).gt.0.) h = b-x + call rkstepper(x,y,dydx,h,hdid,hnew,yscale,eps,w1) + if ((x - b)*h.ge.0) then + ystart = y + return + endif + h = hnew + if (abs(h).lt.abs(hmin)) then + write(logfid,*)'Error in odeint: stepsize too small',w1 + & ,ystart,a,b,h1 + return + endif + 20 continue + write(logfid,*)'Error in odeint: too many steps',w1 + & ,ystart,a,b,h1 + end + + + +*********************************************************************** +*** function rkstepper +*********************************************************************** + subroutine rkstepper(x,y,dydx,htest,hdid,hnew,yscale,eps,w1) + implicit none +C--identifier of file for hepmc output and logfile + common/hepmcid/hpmcfid,logfid + integer hpmcfid,logfid +C--local variables + integer w1 + double precision x,y,dydx,htest,hdid,hnew,yscale,eps, + &yhalf,y1,y2,rk4step,dydxhalf,xnew,delta,err,h,safety, powerdown, + &powerup,maxup,maxdown,deriv,fac + logical reject + data powerdown/0.25/ + data powerup/0.2/ + data safety/0.9/ + data maxdown/10./ + data maxup/5./ + + reject = .false. + h = htest + 10 xnew = x + h + if (x.eq.xnew) then + write(logfid,*)'Error in rkstepper: step size not significant' + return + endif + yhalf = rk4step(x,y,dydx,h/2.,w1) + dydxhalf = deriv(x+h/2.,w1) + y2 = rk4step(x+h/2.,yhalf,dydxhalf,h/2.,w1) + y1 = rk4step(x,y,dydx,h,w1) + delta = y2-y1 + err = abs(delta)/(yscale*eps) + if (err.gt.1.) then + reject = .true. + fac = max(1./maxdown,safety/err**powerdown) + h = h*fac + goto 10 + else + if (reject) then + hnew = h + else + fac = min(maxup,safety/err**powerup) + hnew = fac*h + endif + x = xnew + y = y2 + delta/15. + hdid = h + endif + end + + + +*********************************************************************** +*** function rk4step +*********************************************************************** + double precision function rk4step(x,y,dydx,h,w1) + implicit none + integer w1 + double precision x,y,dydx,h,k1,k2,k4,yout,deriv + k1 = h*dydx + k2 = h*deriv(x+h/2.,w1) + k4 = h*deriv(x+h,w1) + yout = y+k1/6.+2.*k2/3.+k4/6. + rk4step = yout + end + + + +*********************************************************************** +*** function getdeltat +*********************************************************************** + LOGICAL FUNCTION GETDELTAT(LINE,TSTART,DTMAX1,DELTAT) + IMPLICIT NONE +C--identifier of file for hepmc output and logfile + common/hepmcid/hpmcfid,logfid + integer hpmcfid,logfid +C--pythia common block + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + INTEGER N,NPAD,K + DOUBLE PRECISION P,V +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--time common block + COMMON/TIME/MV(23000,5) + DOUBLE PRECISION MV +C--max rapidity + common/rapmax/etamax + double precision etamax +C--memory for error message from getdeltat + common/errline/errl + integer errl +C--local variables + INTEGER LINE,I,NNULL + DOUBLE PRECISION DTMAX,SIGMAMAX,NEFFMAX,LINVMAX,PYR, + &R,TOFF,XS,YS,ZS,TS,GETSSCAT,GETMSMAX,GETMDMIN,MSMAX,MDMIN, + &XSTART,YSTART,ZSTART,WEIGHT,MS,MD,NEFF,SIGMA,GETNEFF, + &GETNEFFMAX,GETMS,GETMD,TAU,MDMAX,GETMDMAX,GETNATMDMIN, + &SIGMAMIN,NEFFMIN,TSTART,DTMAX1,DELTAT + CHARACTER PTYPE + LOGICAL STOPNOW + +C--initialization + GETDELTAT=.FALSE. + DELTAT=0.D0 + DTMAX=DTMAX1 + IF(K(LINE,2).EQ.21)THEN + PTYPE='G' + ELSE + PTYPE='Q' + ENDIF + + NNULL=0 + STOPNOW=.FALSE. + +C--check for upper bound from plasma lifetime + IF((TSTART+DTMAX).GE.LTIME)DTMAX=LTIME-TSTART + IF(DTMAX.LT.0.D0) RETURN + +C--calculate time relative to production of the considered parton + TOFF=TSTART-MV(LINE,4) + XSTART=MV(LINE,1)+TOFF*P(LINE,1)/P(LINE,4) + YSTART=MV(LINE,2)+TOFF*P(LINE,2)/P(LINE,4) + ZSTART=MV(LINE,3)+TOFF*P(LINE,3)/P(LINE,4) + +C--calculate upper limit for density*cross section + SIGMAMAX=GETSSCAT(P(LINE,4),p(line,1),p(line,2),p(line,3), +! & xstart,ystart,-sign(abs(zstart),p(line,3)),zstart+1.d-6) + & P(LINE,5),0.d0,PTYPE,'C',xstart,ystart,zstart,tstart,1) + SIGMAMIN=GETSSCAT(P(LINE,4),p(line,1),p(line,2),p(line,3), +! & xstart,ystart,-sign(abs(zstart),p(line,3)),zstart+1.d-6) + & P(LINE,5),0.d0,PTYPE,'C',xstart,ystart,zstart,tstart,2) + NEFFMAX=GETNEFFMAX() + NEFFMIN=GETNATMDMIN() + LINVMAX=5.d0*MAX(NEFFMIN*SIGMAMAX,NEFFMAX*SIGMAMIN) + + DO 333 I=1,1000000 + DELTAT=DELTAT-LOG(PYR(0))/LINVMAX + XS=XSTART+DELTAT*P(LINE,1)/P(LINE,4) + YS=YSTART+DELTAT*P(LINE,2)/P(LINE,4) + ZS=ZSTART+DELTAT*P(LINE,3)/P(LINE,4) + TS=TSTART+DELTAT + IF(TS.LT.ZS)THEN + TAU=-1.d0 + ELSE + TAU=SQRT(TS**2-ZS**2) + ENDIF + NEFF=GETNEFF(XS,YS,ZS,TS) + IF((TAU.GT.1.d0).AND.(NEFF.EQ.0.d0))THEN + IF(NNULL.GT.4)THEN + STOPNOW=.TRUE. + ELSE + NNULL=NNULL+1 + ENDIF + ELSE + NNULL=0 + ENDIF + IF((DELTAT.GT.DTMAX).OR.STOPNOW) THEN + DELTAT=DTMAX + RETURN + ENDIF + IF(NEFF.GT.0.d0)THEN + SIGMA=GETSSCAT(P(LINE,4),p(line,1),p(line,2),p(line,3), + & P(LINE,5),0.d0,PTYPE,'C',xs,ys,zs,ts,0) + ELSE + SIGMA=0.d0 + ENDIF + WEIGHT=5.d0*NEFF*SIGMA/LINVMAX + IF(WEIGHT.GT.1.d0+1d-6) then + if (line.ne.errl) then + write(logfid,*)'error in GETDELTAT: weight > 1',WEIGHT, + & NEFF*SIGMA/(NEFFMAX*SIGMAMIN),NEFF*SIGMA/(NEFFMIN*SIGMAMAX), + & p(line,4) + errl=line + endif + endif + R=PYR(0) + IF(R.LT.WEIGHT)THEN + GETDELTAT=.TRUE. + RETURN + ENDIF + 333 CONTINUE + END + + + integer function poissonian(lambda) + implicit none + integer n + double precision lambda,disc,p,pyr,u,v,pi + data pi/3.141592653589793d0/ + + if (lambda.gt.745.d0) then + u = pyr(0); + v = pyr(0); + poissonian = + & int(sqrt(lambda)*sqrt(-2.*log(u))*cos(2.*pi*v)+lambda) + else + disc=exp(-lambda) + p=1.d0 + n=0 + 800 p = p*pyr(0) + if (p.gt.disc) then + n = n+1 + goto 800 + endif + poissonian=n + endif + end + + +*********************************************************************** +*** function ishadron +*********************************************************************** + LOGICAL FUNCTION ISHADRON(ID) + IMPLICIT NONE +C--local variables + INTEGER ID + IF(ABS(ID).LT.100) THEN + ISHADRON=.FALSE. + ELSE + IF(MOD(INT(ABS(ID)/10.),10).EQ.0) THEN + ISHADRON = .FALSE. + ELSE + ISHADRON = .TRUE. + ENDIF + ENDIF + END + + + +*********************************************************************** +*** function isdiquark +*********************************************************************** + LOGICAL FUNCTION ISDIQUARK(ID) + IMPLICIT NONE +C--local variables + INTEGER ID + IF(ABS(ID).LT.1000) THEN + ISDIQUARK=.FALSE. + ELSE + IF(MOD(INT(ID/10),10).EQ.0) THEN + ISDIQUARK = .TRUE. + ELSE + ISDIQUARK = .FALSE. + ENDIF + ENDIF + END + +*********************************************************************** +*** function islepton +*********************************************************************** + LOGICAL FUNCTION ISLEPTON(ID) + IMPLICIT NONE +C-- local variables + INTEGER ID + IF((ABS(ID).EQ.11).OR.(ABS(ID).EQ.13).OR.(ABS(ID).EQ.15)) THEN + ISLEPTON=.TRUE. + ELSE + ISLEPTON=.FALSE. + ENDIF + END + +*********************************************************************** +*** function isparton +*********************************************************************** + LOGICAL FUNCTION ISPARTON(ID) + IMPLICIT NONE +C--local variables + INTEGER ID + LOGICAL ISDIQUARK + IF((ABS(ID).LT.6).OR.(ID.EQ.21).OR.ISDIQUARK(ID)) THEN + ISPARTON=.TRUE. + ELSE + ISPARTON=.FALSE. + ENDIF + END + + + +*********************************************************************** +*** function isprimstring +*********************************************************************** + logical function isprimstring(l) + implicit none + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + INTEGER N,NPAD,K + DOUBLE PRECISION P,V +C--local variables + integer l + logical isparton + if ((K(l,2).ne.91).and.(K(l,2).ne.92)) then + isprimstring=.false. + return + endif + if ((K(K(l,3),3).eq.0).or.(isparton(K(K(K(l,3),3),2)))) then + isprimstring=.true. + else + isprimstring=.false. + endif + end + + + +*********************************************************************** +*** function issecstring +*********************************************************************** + logical function issecstring(l) + implicit none + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + INTEGER N,NPAD,K + DOUBLE PRECISION P,V +C--local variables + integer l + logical isparton,isprimstring + if ((K(l,2).ne.91).and.(K(l,2).ne.92)) then + issecstring = .false. + return + endif + if (isprimstring(l)) then + issecstring = .false. + return + endif + if (isparton(K(K(K(l,3),3),2))) then + issecstring = .false. + else + issecstring = .true. + endif + end + + + +*********************************************************************** +*** function isprimhadron +*********************************************************************** + logical function isprimhadron(l) + implicit none + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + INTEGER N,NPAD,K + DOUBLE PRECISION P,V +C--local variables + integer l + logical isprimstring,isparton + if (((K(K(l,3),2).EQ.91).OR.(K(K(l,3),2).EQ.92)) + & .and.isprimstring(K(l,3)) + & .and.(.not.isparton(K(l,2)))) then + isprimhadron=.true. + else + isprimhadron=.false. + endif + if (k(l,1).eq.17) isprimhadron=.true. + end + + + +*********************************************************************** +*** function compressevent +*********************************************************************** + logical function compressevent(l1) + implicit none +C--identifier of file for hepmc output and logfile + common/hepmcid/hpmcfid,logfid + integer hpmcfid,logfid + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + INTEGER N,NPAD,K + DOUBLE PRECISION P,V +C--variables for angular ordering + COMMON/ANGOR/ZA(23000),ZD(23000),THETAA(23000),QQBARD(23000) + DOUBLE PRECISION ZA,ZD,THETAA + LOGICAL QQBARD +C--time common block + COMMON/TIME/MV(23000,5) + DOUBLE PRECISION MV +C--colour index common block + COMMON/COLOUR/TRIP(23000),ANTI(23000),COLMAX + INTEGER TRIP,ANTI,COLMAX +C--local variables + integer l1,i,j,nold,nnew,nstart + + nold = n + + do 777 i=2,nold + if (((k(i,1).eq.11).or.(k(i,1).eq.12).or.(k(i,1).eq.13)).and. + & (i.ne.l1)) then + nnew = i + goto 778 + endif + 777 continue + compressevent = .false. + return + 778 continue + nstart = nnew + do 779 i=nstart,nold + if (((k(i,1).ne.11).and.(k(i,1).ne.12).and.(k(i,1).ne.13)).or. + & (i.eq.l1)) then + do 780 j=1,5 + p(nnew,j)=p(i,j) + v(nnew,j)=v(i,j) + mv(nnew,j)=mv(i,j) + 780 continue + trip(nnew)=trip(i) + anti(nnew)=anti(i) + za(nnew)=za(i) + zd(nnew)=zd(i) + thetaa(nnew)=thetaa(i) + qqbard(nnew)=qqbard(i) + k(nnew,1)=k(i,1) + k(nnew,2)=k(i,2) + k(nnew,3)=0 + k(nnew,4)=0 + k(nnew,5)=0 + if (l1.eq.i) l1=nnew + nnew=nnew+1 + endif + 779 continue + n=nnew-1 + if ((nold-n).le.10) then + compressevent = .false. + else + compressevent = .true. + endif + do 781 i=nnew,nold + do 782 j=1,5 + k(i,j)=0 + p(i,j)=0.d0 + v(i,j)=0.d0 + mv(i,j)=0.d0 + 782 continue + trip(i)=0 + anti(i)=0 + za(i)=0.d0 + zd(i)=0.d0 + thetaa(i)=0.d0 + qqbard(i)=.false. + 781 continue + if (n.gt.23000) write(logfid,*)'Error in compressevent: n = ',n + if (l1.gt.n) write(logfid,*)'Error in compressevent: l1 = ',l1 + call flush(logfid) + return + end + + + +*********************************************************************** +*** subroutine pevrec +*********************************************************************** + SUBROUTINE PEVREC(NUM,COL) +C--identifier of file for hepmc output and logfile + implicit none + common/hepmcid/hpmcfid,logfid + integer hpmcfid,logfid + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + INTEGER N,NPAD,K + DOUBLE PRECISION P,V +C--variables for angular ordering + COMMON/ANGOR/ZA(23000),ZD(23000),THETAA(23000),QQBARD(23000) + DOUBLE PRECISION ZA,ZD,THETAA + LOGICAL QQBARD +C--time common block + COMMON/TIME/MV(23000,5) + DOUBLE PRECISION MV +C--colour index common block + COMMON/COLOUR/TRIP(23000),ANTI(23000),COLMAX + INTEGER TRIP,ANTI,COLMAX + INTEGER NUM,i + LOGICAL COL + + DO 202 I=1,N + V(I,1)=MV(I,1) + V(I,2)=MV(I,2) + V(I,3)=MV(I,3) + V(I,4)=MV(I,4) + V(I,5)=MV(I,5) + IF(COL) write(logfid,*)I,' (',TRIP(I),',',ANTI(I),') [', + &K(I,3),K(I,4),K(I,5),' ] {',K(I,2),K(I,1),' } ', + &ZD(I),THETAA(I) + 202 CONTINUE + CALL PYLIST(NUM) + + END + + + +*********************************************************************** +*** subroutine converttohepmc +*********************************************************************** + SUBROUTINE CONVERTTOHEPMC(J,EVNUM,PID,beam1,beam2) + IMPLICIT NONE + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + INTEGER N,NPAD,K + DOUBLE PRECISION P,V + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + INTEGER MSTP,MSTI + DOUBLE PRECISION PARP,PARI +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--organisation of event record +C--organisation of event record + common/evrecord/nsim,npart,offset,hadrotype,sqrts,collider,hadro, + &shorthepmc,channel,isochannel + integer nsim,npart,offset,hadrotype + double precision sqrts + character*4 collider,channel + character*2 isochannel + logical hadro,shorthepmc +C--local variables + INTEGER EVNUM,PBARCODE,VBARCODE,CODELIST(25000),I,PID,NSTART, + &NFIRST,NVERTEX,NTOT,J,CODEFIRST + DOUBLE PRECISION mproton,mneutron + LOGICAL ISHADRON,ISDIQUARK,ISPARTON,isprimhadron,isprimstring, + &issecstring + character*2 beam1,beam2 + data mproton/0.9383/ + data mneutron/0.9396/ + + 5000 FORMAT(A2,I10,I3,3E14.6,2I2,I6,4I2,E14.6) + 5100 FORMAT(A2,2E14.6) + 5200 FORMAT(A2,9I2,4E14.6) + 5300 FORMAT(A2,2I2,5E14.6,2I2) + 5400 FORMAT(A2,I6,6I2,I6,I2) + 5500 FORMAT(A2,I6,I6,5E14.6,3I2,I6,I2) + + PBARCODE=0 + VBARCODE=0 + + if (shorthepmc) then +C--short output + IF(COLLIDER.EQ.'EEJJ')THEN + NVERTEX=3 + PBARCODE=5 + ELSE + NVERTEX=1 + PBARCODE=2 + ENDIF + nfirst = 0 + do 131 i=1,N + if (((k(i,1).lt.10).or.(k(i,1).eq.17))) + & nfirst = nfirst+1 + 131 continue + + WRITE(J,5000)'E ',EVNUM,-1,0.d0,0.d0,0.d0,0,0,NVERTEX,1,2,0,1, + &PARI(10) + WRITE(J,'(A2,I2,A5)')'N ',1,'"0"' + WRITE(J,'(A)')'U GEV MM' + WRITE(J,5100)'C ',PARI(1)*1.d9,0.d0 + WRITE(J,5200)'H ',0,0,0,0,0,0,0,0,0,0.d0,0.d0,0.d0,0.d0 + WRITE(J,5300)'F ',0,0,-1.d0,-1.d0,-1.d0,-1.d0,-1.d0,0,0 +C--write out vertex line + IF(COLLIDER.EQ.'EEJJ')THEN + WRITE(J,5400)'V ',-1,0,0,0,0,0,2,1,0 + WRITE(J,5500)'P ',1,-11,0.d0,0.d0,sqrts/2.,sqrts/2., + & 0.00051,2,0,0,-1,0 + WRITE(J,5500)'P ',2,11,0.d0,0.d0,-sqrts/2.,sqrts/2., + & 0.00051,2,0,0,-1,0 + WRITE(J,5500)'P ',3,23,0.d0,0.d0,0.d0,sqrts, + & 91.2,2,0,0,-2,0 + WRITE(J,5400)'V ',-2,0,0,0,0,0,0,2,0 + WRITE(J,5500)'P ',4,PID,sqrts/2.,0.d0,0.d0,sqrts/2., + & 0.000,2,0,0,-3,0 + WRITE(J,5500)'P ',5,-PID,-sqrts/2.,0.d0,0.d0,sqrts/2., + & 0.000,2,0,0,-3,0 + WRITE(J,5400)'V ',-3,0,0,0,0,0,0,NFIRST,0 + ELSE + WRITE(J,5400)'V ',-1,0,0,0,0,0,2,NFIRST,0 + if (beam1.eq.'p+') then + WRITE(J,5500)'P ',1,2212,0.d0,0.d0, + & sqrt(sqrts**2/4.-mproton**2),sqrts/2.,mproton,2,0,0,-1,0 + else + WRITE(J,5500)'P ',1,2112,0.d0,0.d0, + & sqrt(sqrts**2/4.-mneutron**2),sqrts/2.,mneutron,2,0,0,-1,0 + endif + if (beam2.eq.'p+') then + WRITE(J,5500)'P ',2,2212,0.d0,0.d0, + & -sqrt(sqrts**2/4.-mproton**2),sqrts/2.,mproton,2,0,0,-1,0 + else + WRITE(J,5500)'P ',2,2112,0.d0,0.d0, + & -sqrt(sqrts**2/4.-mneutron**2),sqrts/2.,mneutron,2,0,0,-1,0 + endif + ENDIF +C--write out particle lines + do 132 i=1,N + if(((k(i,1).lt.10).or.(k(i,1).eq.17))) then + pbarcode=pbarcode+1 + WRITE(J,5500)'P ',PBARCODE,K(I,2),P(I,1),P(I,2),P(I,3), + & P(I,4),P(I,5),1,0,0,0,0 + endif + 132 continue + + else +C--long output + if (hadro) then +C--hadronised events + NFIRST=0 + IF(COLLIDER.EQ.'EEJJ')THEN + NVERTEX=3 + ELSE + NVERTEX=1 + ENDIF + DO 123 I=1,N + IF(K(i,3).ne.0)THEN + NSTART=I + GOTO 124 + ENDIF + 123 CONTINUE + 124 CONTINUE + nstart=0 + + DO 126 I=NSTART+1,N + IF(isprimhadron(i)) NFIRST=NFIRST+1 + IF((ISHADRON(K(I,2)).OR.(ABS(K(I,2)).EQ.15)) + & .AND.(K(I,4).NE.0)) NVERTEX=NVERTEX+1 + 126 CONTINUE + 127 CONTINUE + + WRITE(J,5000)'E ',EVNUM,-1,0.d0,0.d0,0.d0,0,0,NVERTEX, + &1,2,0,1,PARI(10) + WRITE(J,'(A2,I2,A5)')'N ',1,'"0"' + WRITE(J,'(A)')'U GEV MM' + WRITE(J,5100)'C ',PARI(1)*1.d9,0.d0 + WRITE(J,5200)'H ',0,0,0,0,0,0,0,0,0,0.d0,0.d0,0.d0,0.d0 + WRITE(J,5300)'F ',0,0,-1.d0,-1.d0,-1.d0,-1.d0,-1.d0,0,0 + +C--write out vertex line + IF(COLLIDER.EQ.'EEJJ')THEN + VBARCODE=-3 + PBARCODE=5 + ELSE + VBARCODE=-1 + PBARCODE=2 + ENDIF + IF(COLLIDER.EQ.'EEJJ')THEN + WRITE(J,5400)'V ',-1,0,0,0,0,0,2,1,0 + WRITE(J,5500)'P ',1,-11,0.d0,0.d0,sqrts/2.,sqrts/2., + & 0.00051,2,0,0,-1,0 + WRITE(J,5500)'P ',2,11,0.d0,0.d0,-sqrts/2.,sqrts/2., + & 0.00051,2,0,0,-1,0 + WRITE(J,5500)'P ',3,23,0.d0,0.d0,0.d0,sqrts, + & 91.2,2,0,0,-2,0 + WRITE(J,5400)'V ',-2,0,0,0,0,0,0,2,0 + WRITE(J,5500)'P ',4,PID,sqrts/2.,0.d0,0.d0,sqrts/2., + & 0.000,2,0,0,-3,0 + WRITE(J,5500)'P ',5,-PID,-sqrts/2.,0.d0,0.d0,sqrts/2., + & 0.000,2,0,0,-3,0 + WRITE(J,5400)'V ',VBARCODE,0,0,0,0,0,0,NFIRST,0 + ELSE + WRITE(J,5400)'V ',-1,0,0,0,0,0,2,NFIRST,0 + if (beam1.eq.'p+') then + WRITE(J,5500)'P ',1,2212,0.d0,0.d0, + & sqrt(sqrts**2/4.-mproton**2),sqrts/2.,mproton,2,0,0,-1,0 + else + WRITE(J,5500)'P ',1,2112,0.d0,0.d0, + & sqrt(sqrts**2/4.-mneutron**2),sqrts/2.,mneutron,2,0,0,-1,0 + endif + if (beam2.eq.'p+') then + WRITE(J,5500)'P ',2,2212,0.d0,0.d0, + & -sqrt(sqrts**2/4.-mproton**2),sqrts/2.,mproton,2,0,0,-1,0 + else + WRITE(J,5500)'P ',2,2112,0.d0,0.d0, + & -sqrt(sqrts**2/4.-mneutron**2),sqrts/2.,mneutron,2,0,0,-1,0 + endif + ENDIF + + CODEFIRST=NFIRST+PBARCODE + + +C--first write out all particles coming directly from string or cluster decays + DO 125 I=NSTART+1,N + IF(.not.isprimhadron(i))THEN + GOTO 125 + ELSE + IF (PBARCODE.EQ.CODEFIRST) GOTO 130 + PBARCODE=PBARCODE+1 +C--write out particle line + IF(K(I,4).GT.0)THEN + VBARCODE=VBARCODE-1 + CODELIST(I)=VBARCODE + WRITE(J,5500)'P ',PBARCODE,K(I,2),P(I,1),P(I,2),P(I,3), + & P(I,4),P(I,5),2,0,0,VBARCODE,0 + ELSE + WRITE(J,5500)'P ',PBARCODE,K(I,2),P(I,1),P(I,2),P(I,3), + & P(I,4),P(I,5),1,0,0,0,0 + ENDIF + ENDIF + 125 CONTINUE + 130 CONTINUE +C--now write out all other particles and vertices + DO 129 I=NSTART+1,N + if (isprimhadron(i).or.isprimstring(i)) goto 129 + if (isparton(K(i,2))) then + if (ishadron(K(K(i,3),2))) codelist(i)=codelist(K(i,3)) + goto 129 + endif + if (issecstring(i)) then + codelist(i)=codelist(K(i,3)) + goto 129 + endif + PBARCODE=PBARCODE+1 + IF((K(I,3).NE.K(I-1,3)))THEN +C--write out vertex line + WRITE(J,5400)'V ',CODELIST(K(I,3)),0,0,0,0,0,0, + & K(K(I,3),5)-K(K(I,3),4)+1,0 + ENDIF +C--write out particle line + IF(K(I,4).GT.0)THEN + VBARCODE=VBARCODE-1 + CODELIST(I)=VBARCODE + WRITE(J,5500)'P ',PBARCODE,K(I,2),P(I,1),P(I,2),P(I,3), + & P(I,4),P(I,5),2,0,0,VBARCODE,0 + ELSE + WRITE(J,5500)'P ',PBARCODE,K(I,2),P(I,1),P(I,2),P(I,3), + & P(I,4),P(I,5),1,0,0,0,0 + ENDIF + 129 CONTINUE + + else +C--partonic events + endif + endif + call flush(j) + END + + + +*********************************************************************** +*** subroutine printlogo +*********************************************************************** + subroutine printlogo(fid) + implicit none + integer fid + + write(fid,*) + write(fid,*)' _______________'// + &'__________________________ ' + write(fid,*)' | '// + &' | ' + write(fid,*)' | JJJJJ EEEEE '// + &' W W EEEEE L | ' + write(fid,*)' | J E '// + &' W W E L | ' + write(fid,*)' _________________| J EEE '// + &' W W W EEE L |_________________ ' + write(fid,*)'| | J J E '// + &' W W W W E L | |' + write(fid,*)'| | JJJ EEEEE '// + &' W W EEEEE LLLLL | |' + write(fid,*)'| |_______________'// + &'__________________________| |' + write(fid,*)'| '// + &' |' + write(fid,*)'| '// + &'this is JEWEL 2.1.0 |' + write(fid,*)'| '// + &' |' + write(fid,*)'| Copyright Korinna C. Zapp (2016)'// + &' [Korinna.Zapp@cern.ch] |' + write(fid,*)'| '// + &' |' + write(fid,*)'| The JEWEL homepage is jewel.hepforge.org '// + &' |' + write(fid,*)'| '// + &' |' + write(fid,*)'| The medium model was partly '// + &'implemented by Jochen Klein |' + write(fid,*)'| [Jochen.Klein@cern.ch]. Raghav '// + &'Kunnawalkam Elayavalli helped with the |' + write(fid,*)'| implementation of the V+jet processes '// + &'[raghav.k.e@cern.ch]. |' + write(fid,*)'| '// + &' |' + write(fid,*)'| Please cite JHEP 1303 (2013) '// + &'080 [arXiv:1212.1599] and optionally |' + write(fid,*)'| EPJC C60 (2009) 617 [arXiv:0804.3568] '// + &'for the physics and arXiv:1311.0048 |' + write(fid,*)'| for the code. The reference for '// + &'V+jet processes is arXiv:1608.03099. |' + write(fid,*)'| '// + &' |' + write(fid,*)'| JEWEL contains code provided by '// + &'S. Zhang and J. M. Jing |' + write(fid,*)'| (Computation of Special Functions, '// + &'John Wiley & Sons, New York, 1996 and |' + write(fid,*)'| http://jin.ece.illinois.edu) for '// + &'computing the exponential integral Ei(x). |' + write(fid,*)'| '// + &' |' + write(fid,*)'| JEWEL relies heavily on PYTHIA 6'// + &' for the event generation. The modified |' + write(fid,*)'| version of PYTHIA 6.4.25 that is'// + &' shipped with JEWEL is, however, not an |' + write(fid,*)'| official PYTHIA release and must'// + &' not be used for anything else. Please |' + write(fid,*)'| refer to results as "JEWEL+PYTHIA".'// + &' |' + write(fid,*)'| '// + &' |' + write(fid,*)'|_________________________________'// + &'____________________________________________|' + write(fid,*) + write(fid,*) + end + + +*********************************************************************** +*** subroutine printtime +*********************************************************************** + subroutine printtime + implicit none +C--identifier of file for hepmc output and logfile + common/hepmcid/hpmcfid,logfid + integer hpmcfid,logfid +C--local variables + integer*4 date(3),time(3) + + 1000 format (i2.2, '.', i2.2, '.', i4.4, ', ', + & i2.2, ':', i2.2, ':', i2.2 ) + call idate(date) + call itime(time) + write(logfid,1000)date,time + end + Index: branches/rel-2.3.0/meix.f =================================================================== --- branches/rel-2.3.0/meix.f (revision 0) +++ branches/rel-2.3.0/meix.f (revision 477) @@ -0,0 +1,37 @@ +C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +C++ Copyright S. Zhang and J. M. Jing ++ +C++ Computation of Special Functions, John Wiley & Sons, New York, ++ +C++ 1996 and http://jin.ece.illinois.edu . ++ +C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +C + SUBROUTINE EIX(X,EI) +C +C ============================================ +C Purpose: Compute exponential integral Ei(x) +C Input : x --- Argument of Ei(x) +C Output: EI --- Ei(x) ( x > 0 ) +C ============================================ +C + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + IF (X.EQ.0.0) THEN + EI=-1.0D+300 + ELSE IF (X.LE.40.0) THEN + EI=1.0D0 + R=1.0D0 + DO 15 K=1,100 + R=R*K*X/(K+1.0D0)**2 + EI=EI+R + IF (DABS(R/EI).LE.1.0D-15) GO TO 20 +15 CONTINUE +20 GA=0.5772156649015328D0 + EI=GA+DLOG(X)+X*EI + ELSE + EI=1.0D0 + R=1.0D0 + DO 25 K=1,20 + R=R*K/X +25 EI=EI+R + EI=DEXP(X)/X*EI + ENDIF + RETURN + END Property changes on: branches/rel-2.3.0/meix.f ___________________________________________________________________ Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: branches/rel-2.3.0/jewel-2.2.0.f =================================================================== --- branches/rel-2.3.0/jewel-2.2.0.f (revision 0) +++ branches/rel-2.3.0/jewel-2.2.0.f (revision 477) @@ -0,0 +1,7035 @@ +C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +C++ Copyright (C) 2017 Korinna C. Zapp [Korinna.Zapp@cern.ch] ++ +C++ ++ +C++ This file is part of JEWEL 2.2.0 ++ +C++ ++ +C++ The JEWEL homepage is jewel.hepforge.org ++ +C++ ++ +C++ The medium model was partly implemented by Jochen Klein. ++ +C++ Raghav Kunnawalkam Elayavalli helped with the implementation ++ +C++ of the V+jet processes. ++ +C++ ++ +C++ Please follow the MCnet GUIDELINES and cite Eur.Phys.J. C74 ++ +C++ (2014) no.2, 2762 [arXiv:1311.0048] for the code and ++ +C++ JHEP 1303 (2013) 080 [arXiv:1212.1599] and ++ +C++ optionally EPJC 60 (2009) 617 [arXiv:0804.3568] for the ++ +C++ physics. The reference for V+jet processes is EPJC 76 (2016) ++ +C++ no.12 695 [arXiv:1608.03099] and for recoil effects it is ++ +C++ arXiv:1707.01539. +C++ ++ +C++ JEWEL relies heavily on PYTHIA 6 for the event generation. The ++ +C++ modified version of PYTHIA 6.4.25 that is distributed with ++ +C++ JEWEL is, however, not an official PYTHIA release and must not ++ +C++ be used for anything else. Please refer to results as ++ +C++ "JEWEL+PYTHIA". ++ +C++ ++ +C++ JEWEL also uses code provided by S. Zhang and J. M. Jing ++ +C++ (Computation of Special Functions, John Wiley & Sons, New York, ++ +C++ 1996 and http://jin.ece.illinois.edu) for computing the ++ +C++ exponential integral Ei(x). ++ +C++ ++ +C++ ++ +C++ JEWEL is free software; you can redistribute it and/or ++ +C++ modify it under the terms of the GNU General Public License ++ +C++ as published by the Free Software Foundation; either version 2 ++ +C++ of the License, or (at your option) any later version. ++ +C++ ++ +C++ JEWEL is distributed in the hope that it will be useful, ++ +C++ but WITHOUT ANY WARRANTY; without even the implied warranty of ++ +C++ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ++ +C++ GNU General Public License for more details. ++ +C++ ++ +C++ You should have received a copy of the GNU General Public ++ +C++ License along with this program; if not, write to the Free ++ +C++ Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, ++ +C++ MA 02110-1301 USA ++ +C++ ++ +C++ Linking JEWEL statically or dynamically with other modules is ++ +C++ making a combined work based on JEWEL. Thus, the terms and ++ +C++ conditions of the GNU General Public License cover the whole ++ +C++ combination. ++ +C++ ++ +C++ In addition, as a special exception, I give you permission to ++ +C++ combine JEWEL with the code for the computation of special ++ +C++ functions provided by S. Zhang and J. M. Jing. You may copy and ++ +C++ distribute such a system following the terms of the GNU GPL for ++ +C++ JEWEL and the licenses of the other code concerned, provided ++ +C++ that you include the source code of that other code when and as ++ +C++ the GNU GPL requires distribution of source code. ++ +C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + + PROGRAM JEWEL + IMPLICIT NONE +C--Common block of Pythia + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + INTEGER N,NPAD,K + DOUBLE PRECISION P,V + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + INTEGER MSTU,MSTJ + DOUBLE PRECISION PARU,PARJ + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + INTEGER MDCY,MDME,KFDP + DOUBLE PRECISION BRAT + COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) + INTEGER MSEL,MSELPD,MSUB,KFIN + DOUBLE PRECISION CKIN + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + INTEGER MSTP,MSTI + DOUBLE PRECISION PARP,PARI + COMMON/PYDATR/MRPY(6),RRPY(100) + INTEGER MRPY + DOUBLE PRECISION RRPY +C--identifier of file for hepmc output and logfile + common/hepmcid/hpmcfid,logfid + integer hpmcfid,logfid +C--use nuclear pdf? + COMMON/NPDF/MASS,NSET,EPS09,INITSTR + INTEGER NSET + DOUBLE PRECISION MASS + LOGICAL EPS09 + CHARACTER*10 INITSTR +C--number of protons + common/np/nproton + integer nproton +C--organisation of event record + common/evrecord/nsim,npart,offset,hadrotype,sqrts,collider,hadro, + &shorthepmc,channel,isochannel + integer nsim,npart,offset,hadrotype + double precision sqrts + character*4 collider,channel + character*2 isochannel + logical hadro,shorthepmc +C--discard event flag + COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD + LOGICAL DISCARD + INTEGER NDISC,NSTRANGE,NGOOD,errcount + double precision wdisc +C--event weight + COMMON/WEIGHT/EVWEIGHT,sumofweights + double precision EVWEIGHT,sumofweights +C--number of scattering events + COMMON/CHECK/NSCAT,NSCATEFF,NSPLIT + DOUBLE PRECISION NSCAT,NSCATEFF,NSPLIT +C--number of extrapolations in tables + common/extrapolations/ntotspliti,noverspliti,ntotpdf,noverpdf, + &ntotxsec,noverxsec,ntotsuda,noversuda + integer ntotspliti,noverspliti,ntotpdf,noverpdf, + &ntotxsec,noverxsec,ntotsuda,noversuda +C--local variables + integer j,i,kk,poissonian + integer nsimpp,nsimpn,nsimnp,nsimnn,nsimsum,nsimchn + double precision sumofweightstot,wdisctot,scalefac + double precision gettemp,r,tau + character*2 b1,b2 + + call init() + + SUMOFWEIGHTSTOT=0.d0 + WDISCTOT=0.d0 + +C--e+ + e- event generation + if (collider.eq.'EEJJ') then + b1 = 'e+' + b2 = 'e-' + write(logfid,*) + write(logfid,*) + &'####################################################' + write(logfid,*) + write(logfid,*)'generating ',nsim,' events in ',b1,' + ',b2, + &' channel' + write(logfid,*) + write(logfid,*) + &'####################################################' + write(logfid,*) + SUMOFWEIGHTS=0.d0 + WDISC=0.d0 + call initpythia(b1,b2) + write(logfid,*) +C--e+ + e- event loop + DO 100 J=1,NSIM + call genevent(j,b1,b2) + 100 CONTINUE + sumofweightstot = sumofweightstot+sumofweights + wdisctot = wdisctot + wdisc + write(logfid,*) + write(logfid,*)'cross section in e+ + e- channel:',PARI(1),'mb' + write(logfid,*)'sum of event weights in e+ + e- channel:', + & sumofweights-wdisc + write(logfid,*) + + else +C--hadronic event generation + if (isochannel.eq.'PP') then + nsimpp = nsim + nsimpn = 0 + nsimnp = 0 + nsimnn = 0 + elseif (isochannel.eq.'PN') then + nsimpp = 0 + nsimpn = nsim + nsimnp = 0 + nsimnn = 0 + elseif (isochannel.eq.'NP') then + nsimpp = 0 + nsimpn = 0 + nsimnp = nsim + nsimnn = 0 + elseif (isochannel.eq.'NN') then + nsimpp = 0 + nsimpn = 0 + nsimnp = 0 + nsimnn = nsim + else + nsimpp = poissonian(nsim*nproton**2/mass**2) + nsimpn = poissonian(nsim*nproton*(mass-nproton*1.d0)/mass**2) + nsimnp = poissonian(nsim*nproton*(mass-nproton*1.d0)/mass**2) + nsimnn = poissonian(nsim*(mass-nproton*1.d0)**2/mass**2) + nsimsum = nsimpp + nsimpn + nsimnp + nsimnn + scalefac = nsim*1.d0/(nsimsum*1.d0) + nsimpp = int(nsimpp*scalefac) + nsimpn = int(nsimpn*scalefac) + nsimnp = int(nsimnp*scalefac) + nsimnn = int(nsimnn*scalefac) + nsimsum = nsimpp + nsimpn + nsimnp + nsimnn + endif +C--loop over channels + do 101 kk=1,4 + if (kk.eq.1) then + b1 = 'p+' + b2 = 'p+' + nsimchn = nsimpp + elseif (kk.eq.2) then + b1 = 'p+' + b2 = 'n0' + nsimchn = nsimpn + elseif (kk.eq.3) then + b1 = 'n0' + b2 = 'p+' + nsimchn = nsimnp + else + b1 = 'n0' + b2 = 'n0' + nsimchn = nsimnn + endif + write(logfid,*) + write(logfid,*) + &'####################################################' + write(logfid,*) + write(logfid,*)'generating ',nsimchn,' events in ', + &b1,' + ',b2,' channel' + write(logfid,*) + write(logfid,*) + &'####################################################' + write(logfid,*) + SUMOFWEIGHTS=0.d0 + WDISC=0.d0 + call initpythia(b1,b2) + write(logfid,*) +C--event loop + DO 102 J=1,nsimchn + call genevent(j,b1,b2) + 102 CONTINUE + sumofweightstot = sumofweightstot+sumofweights + wdisctot = wdisctot + wdisc + write(logfid,*) + write(logfid,*)'cross section in ',b1,' + ',b2,' channel:', + & PARI(1),'mb' + write(logfid,*)'sum of event weights in ',b1,' + ',b2, + & ' channel:',sumofweights-wdisc + write(logfid,*) + 101 continue + endif + +C--finish + WRITE(HPMCFID,'(A)')'HepMC::IO_GenEvent-END_EVENT_LISTING' + WRITE(HPMCFID,*) + CLOSE(HPMCFID,status='keep') + + write(logfid,*) + write(logfid,*)'mean number of scatterings:', + & NSCAT/(SUMOFWEIGHTSTOT-WDISCTOT) + write(logfid,*)'mean number of effective scatterings:', + & NSCATEFF/(SUMOFWEIGHTSTOT-WDISCTOT) + write(logfid,*)'mean number of splittings:', + & NSPLIT/(SUMOFWEIGHTSTOT-WDISCTOT) + write(logfid,*) + write(logfid,*)'number of extrapolations in splitting integral: ', + & noverspliti,' (',(noverspliti*1.d0)/(ntotspliti*1.d0),'%)' + write(logfid,*) + & 'number of extrapolations in splitting partonic PDFs: ', + & noverpdf,' (',(noverpdf*1.d0)/(ntotpdf*1.d0),'%)' + write(logfid,*) + & 'number of extrapolations in splitting cross sections: ', + & noverxsec,' (',(noverxsec*1.d0)/(ntotxsec*1.d0),'%)' + write(logfid,*) + & 'number of extrapolations in Sudakov form factor: ', + & noversuda,' (',(noversuda*1.d0)/(ntotsuda*1.d0),'%)' + write(logfid,*) + write(logfid,*)'number of good events: ',ngood + write(logfid,*)'total number of discarded events: ',NDISC + write(logfid,*)'number of events for which conversion '// + &'to hepmc failed: ',NSTRANGE + call printtime + + close(logfid,status='keep') + + END + + + +*********************************************************************** +*********************************************************************** +*** END OF MAIN PROGRAM - NOW COME THE SUBROUTINES **************** +*********************************************************************** +*********************************************************************** + + +*********************************************************************** +*** subroutine init +*********************************************************************** + subroutine init() + implicit none + INTEGER PYCOMP + INTEGER NMXHEP +C--Common block of Pythia + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + INTEGER N,NPAD,K + DOUBLE PRECISION P,V + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + INTEGER MSTU,MSTJ + DOUBLE PRECISION PARU,PARJ + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + INTEGER MDCY,MDME,KFDP + DOUBLE PRECISION BRAT + COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) + INTEGER MSEL,MSELPD,MSUB,KFIN + DOUBLE PRECISION CKIN + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + INTEGER MSTP,MSTI + DOUBLE PRECISION PARP,PARI + COMMON/PYDATR/MRPY(6),RRPY(100) + INTEGER MRPY + DOUBLE PRECISION RRPY +C--use nuclear pdf? + COMMON/NPDF/MASS,NSET,EPS09,INITSTR + INTEGER NSET + DOUBLE PRECISION MASS + LOGICAL EPS09 + CHARACTER*10 INITSTR +C--pdfset + common/pdf/pdfset + integer pdfset +C--number of protons + common/np/nproton + integer nproton +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--splitting integral + COMMON/SPLITINT/SPLITIGGV(1000,1000),SPLITIQQV(1000,1000), + &SPLITIQGV(1000,1000),QVAL(1000),ZMVAL(1000),QMAX,ZMMIN,NPOINT + INTEGER NPOINT + DOUBLE PRECISION SPLITIGGV,SPLITIQQV,SPLITIQGV, + &QVAL,ZMVAL,QMAX,ZMMIN +C--pdf common block + COMMON/PDFS/QINQX(2,1000),GINQX(2,1000),QINGX(2,1000), + &GINGX(2,1000) + DOUBLE PRECISION QINQX,GINQX,QINGX,GINGX +C--cross secttion common block + COMMON/XSECS/INTQ1(1001,101),INTQ2(1001,101), + &INTG1(1001,101),INTG2(1001,101) + DOUBLE PRECISION INTQ1,INTQ2,INTG1,INTG2 +C--Sudakov common block + COMMON/INSUDA/SUDAQQ(1000,2),SUDAQG(1000,2),SUDAGG(1000,2) + &,SUDAGC(1000,2) + DOUBLE PRECISION SUDAQQ,SUDAQG,SUDAGG,SUDAGC +C--exponential integral for negative arguments + COMMON/EXPINT/EIX(3,1000),VALMAX,NVAL + INTEGER NVAL + DOUBLE PRECISION EIX,VALMAX +C--discard event flag + COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD + LOGICAL DISCARD + INTEGER NDISC,NSTRANGE,NGOOD,errcount + double precision wdisc +C--factor in front of formation times + COMMON/FTIMEFAC/FTFAC + DOUBLE PRECISION FTFAC +C--factor in front of alphas argument + COMMON/ALPHASFAC/PTFAC + DOUBLE PRECISION PTFAC +C--number of scattering events + COMMON/CHECK/NSCAT,NSCATEFF,NSPLIT + DOUBLE PRECISION NSCAT,NSCATEFF,NSPLIT +C--number of extrapolations in tables + common/extrapolations/ntotspliti,noverspliti,ntotpdf,noverpdf, + &ntotxsec,noverxsec,ntotsuda,noversuda + integer ntotspliti,noverspliti,ntotpdf,noverpdf, + &ntotxsec,noverxsec,ntotsuda,noversuda +C--event weight + COMMON/WEIGHT/EVWEIGHT,sumofweights + double precision EVWEIGHT,sumofweights +C--event weight exponent + COMMON/WEXPO/WEIGHTEX + DOUBLE PRECISION WEIGHTEX +C--identifier of file for hepmc output and logfile + common/hepmcid/hpmcfid,logfid + integer hpmcfid,logfid +C--max rapidity + common/rapmax/etamax + double precision etamax +C--memory for error message from getdeltat + common/errline/errl + integer errl +C--organisation of event record + common/evrecord/nsim,npart,offset,hadrotype,sqrts,collider,hadro, + &shorthepmc,channel,isochannel + integer nsim,npart,offset,hadrotype + double precision sqrts + character*4 collider,channel + character*2 isochannel + logical hadro,shorthepmc +C--extra storage for scattering centres before interactions + common/storescatcen/nscatcen,maxnscatcen,scatflav(10000), + &scatcen(10000,5),writescatcen,writedummies + integer nscatcen,maxnscatcen,scatflav + double precision scatcen + logical writescatcen,writedummies +C--Pythia parameters + common/pythiaparams/PTMIN,PTMAX,weighted + double precision PTMIN,PTMAX + LOGICAL WEIGHTED + +C--Variables local to this program + INTEGER NJOB,ios,pos,i,j,jj,intmass + DOUBLE PRECISION GETLTIMEMAX,EOVEST,r,pyr + character firstchar + CHARACTER*2 SNSET + CHARACTER*80 PDFFILE,XSECFILE,FILEMED,FILESPLIT,buffer, + &label,value + CHARACTER*100 HEPMCFILE,LOGFILE,FILENAME2 + CHARACTER(LEN=100) filename + LOGICAL PDFEXIST,SPLITIEXIST,XSECEXIST + + data maxnscatcen/10000/ + + HPMCFID = 4 + logfid = 3 + +C--default settings + nsim = 10000 + njob = 0 + logfile = 'out.log' + hepmcfile = 'out.hepmc' + filesplit = 'splitint.dat' + pdffile = 'pdfs.dat' + xsecfile = 'xsecs.dat' + filemed = 'medium-params.dat' + nf = 3 + lqcd = 0.4 + q0 = 1.5 + ptmin = 5. + ptmax = 350. + etamax = 3.1 + collider = 'PPJJ' + isochannel = 'XX' + channel = 'MUON' + sqrts = 2760 + pdfset = 10042 + nset = 1 + mass = 208. + nproton = 82 + weighted = .true. + weightex = 5. + angord = .true. + allhad = .false. + hadro = .true. + hadrotype = 0 + shorthepmc = .true. + compress = .true. + writescatcen = .false. + writedummies = .false. + + lps = lqcd + scatrecoil = .false. + if (.not.hadro) shorthepmc = .true. + + SCALEFACM=1. + ptfac=1. + ftfac=1.d0 + + if (iargc().eq.0) then + write(*,*)'No parameter file given, '// + &'will run with default settings.' + else + call getarg(1,filename) + write(*,*)'Reading parameters from ',filename + open(unit=1,file=filename,status='old',err=110) + do 120 i=1,1000 + read(1, '(A)', iostat=ios) buffer + if(ios.ne.0) goto 130 + firstchar = buffer(1:1) + if (firstchar.eq.'#') goto 120 + pos=scan(buffer,' ') + label=buffer(1:pos) + value=buffer(pos+1:) + if(label.eq."NEVENT")then + read(value,*,iostat=ios) nsim + elseif(label.eq."NJOB")then + read(value,*,iostat=ios) njob + elseif(label.eq."LOGFILE")then + read(value,'(a)',iostat=ios) logfile + elseif(label.eq."HEPMCFILE")then + read(value,'(a)',iostat=ios) hepmcfile + elseif(label.eq."SPLITINTFILE")then + read(value,'(a)',iostat=ios) filesplit + elseif(label.eq."PDFFILE")then + read(value,'(a)',iostat=ios) pdffile + elseif(label.eq."XSECFILE")then + read(value,'(a)',iostat=ios) xsecfile + elseif(label.eq."MEDIUMPARAMS")then + read(value,'(a)',iostat=ios) filemed + elseif(label.eq."NF")then + read(value,*,iostat=ios) nf + elseif(label.eq."LAMBDAQCD")then + read(value,*,iostat=ios) lqcd + elseif(label.eq."Q0")then + read(value,*,iostat=ios) q0 + elseif(label.eq."PTMIN")then + read(value,*,iostat=ios) ptmin + elseif(label.eq."PTMAX")then + read(value,*,iostat=ios) ptmax + elseif(label.eq."ETAMAX")then + read(value,*,iostat=ios) etamax + elseif(label.eq."PROCESS")then + read(value,*,iostat=ios) collider + elseif(label.eq."ISOCHANNEL")then + read(value,*,iostat=ios) isochannel + elseif(label.eq."CHANNEL")then + read(value,*,iostat=ios) channel + elseif(label.eq."SQRTS")then + read(value,*,iostat=ios) sqrts + elseif(label.eq."PDFSET")then + read(value,*,iostat=ios) pdfset + elseif(label.eq."NSET")then + read(value,*,iostat=ios) nset + elseif(label.eq."MASS")then + read(value,*,iostat=ios) mass + elseif(label.eq."NPROTON")then + read(value,*,iostat=ios) nproton + elseif(label.eq."WEIGHTED")then + read(value,*,iostat=ios) weighted + elseif(label.eq."WEXPO")then + read(value,*,iostat=ios) weightex + elseif(label.eq."ANGORD")then + read(value,*,iostat=ios) angord + elseif(label.eq."KEEPRECOILS")then + read(value,*,iostat=ios) allhad + elseif(label.eq."HADRO")then + read(value,*,iostat=ios) hadro + elseif(label.eq."HADROTYPE")then + read(value,*,iostat=ios) hadrotype + elseif(label.eq."SHORTHEPMC")then + read(value,*,iostat=ios) shorthepmc + elseif(label.eq."COMPRESS")then + read(value,*,iostat=ios) compress + elseif(label.eq."WRITESCATCEN")then + read(value,*,iostat=ios) writescatcen + elseif(label.eq."WRITEDUMMIES")then + read(value,*,iostat=ios) writedummies + else + write(*,*)'unknown label ',label + endif + 120 continue + + + 110 write(*,*) + & 'Unable to open parameter file, will exit the run.' + call exit(1) + + 130 close(1,status='keep') + write(*,*)'...done' + endif + + if (ptmin.lt.3.d0) ptmin = 3.d0 + if (.not.writescatcen) writedummies = .false. + + OPEN(unit=logfid,file=LOGFILE,status='unknown') + MSTU(11)=logfid + + call printtime + call printlogo(logfid) + + + write(logfid,*) + write(logfid,*)'parameters of the run:' + write(logfid,*)'NEVENT = ',nsim + write(logfid,*)'NJOB = ',njob + write(logfid,*)'LOGFILE = ',logfile + write(logfid,*)'HEPMCFILE = ',hepmcfile + write(logfid,*)'SPLITINTFILE = ',filesplit + write(logfid,*)'PDFFILE = ',pdffile + write(logfid,*)'XSECFILE = ',xsecfile + write(logfid,*)'MEDIUMPARAMS = ',filemed + write(logfid,*)'NF = ',nf + write(logfid,*)'LAMBDAQCD = ',lqcd + write(logfid,*)'Q0 = ',q0 + write(logfid,*)'PTMIN = ',ptmin + write(logfid,*)'PTMAX = ',ptmax + write(logfid,*)'ETAMAX = ',etamax + write(logfid,*)'PROCESS = ',collider + write(logfid,*)'ISOCHANNEL = ',isochannel + write(logfid,*)'CHANNEL = ',channel + write(logfid,*)'SQRTS = ',sqrts + write(logfid,*)'PDFSET = ',pdfset + write(logfid,*)'NSET = ',nset + write(logfid,*)'MASS = ',mass + write(logfid,*)'NPROTON = ',nproton + write(logfid,*)'WEIGHTED = ',weighted + write(logfid,*)'WEXPO = ',weightex + write(logfid,*)'ANGORD = ',angord + write(logfid,*)'KEEPRECOILS = ',allhad + write(logfid,*)'HADRO = ',hadro + write(logfid,*)'HADROTYPE = ',hadrotype + write(logfid,*)'SHORTHEPMC = ',shorthepmc + write(logfid,*)'COMPRESS = ',compress + write(logfid,*)'WRITESCATCEN = ',writescatcen + write(logfid,*)'WRITEDUMMIES = ',writedummies + write(logfid,*) + call flush(logfid) + + if ((collider.ne.'PPJJ').and.(collider.ne.'EEJJ') + & .and.(collider.ne.'PPYJ').and.(collider.ne.'PPYQ') + & .and.(collider.ne.'PPYG') + & .and.(collider.ne.'PPZJ').and.(collider.ne.'PPZQ') + & .and.(collider.ne.'PPZG').and.(collider.ne.'PPWJ') + & .and.(collider.ne.'PPWQ').and.(collider.ne.'PPWG') + & .and.(collider.ne.'PPDY')) then + write(logfid,*)'Fatal error: colliding system unknown, '// + & 'will exit now' + call exit(1) + endif + +C--initialize medium + intmass = int(mass) + CALL MEDINIT(FILEMED,logfid,etamax,intmass) + CALL MEDNEXTEVT + + OPEN(unit=HPMCFID,file=HEPMCFILE,status='unknown') + WRITE(HPMCFID,*) + WRITE(HPMCFID,'(A)')'HepMC::Version 2.06.05' + WRITE(HPMCFID,'(A)')'HepMC::IO_GenEvent-START_EVENT_LISTING' + + NPART=2 + + if(ptmax.gt.0.)then + EOVEST=MIN(1.5*(PTMAX+50.)*COSH(ETAMAX),sqrts/2.) + else + EOVEST=sqrts/2. + endif + + + CALL EIXINT + CALL INSUDAINT(EOVEST) + + write(logfid,*) + INQUIRE(file=FILESPLIT,exist=SPLITIEXIST) + IF(SPLITIEXIST)THEN + write(logfid,*)'read splitting integrals from ',FILESPLIT + OPEN(unit=10,file=FILESPLIT,status='old') + READ(10,*)QMAX,ZMMIN,NPOINT + DO 893 I=1,NPOINT+1 + READ(10,*) QVAL(I),ZMVAL(I) + 893 CONTINUE + DO 891 I=1,NPOINT+1 + DO 892 J=1,NPOINT+1 + READ(10,*)SPLITIGGV(I,J),SPLITIQQV(I,J),SPLITIQGV(I,J) + 892 CONTINUE + 891 CONTINUE + CLOSE(10,status='keep') + ELSE + write(logfid,*)'have to integrate splitting functions, '// + &'this may take some time' + CALL SPLITFNCINT(EOVEST) + INQUIRE(file=FILESPLIT,exist=SPLITIEXIST) + IF(.NOT.SPLITIEXIST)THEN + write(logfid,*)'write splitting integrals to ',FILESPLIT + OPEN(unit=10,file=FILESPLIT,status='new') + WRITE(10,*)QMAX,ZMMIN,NPOINT + DO 896 I=1,NPOINT+1 + WRITE(10,*) QVAL(I),ZMVAL(I) + 896 CONTINUE + DO 897 I=1,NPOINT+1 + DO 898 J=1,NPOINT+1 + WRITE(10,*)SPLITIGGV(I,J),SPLITIQQV(I,J),SPLITIQGV(I,J) + 898 CONTINUE + 897 CONTINUE + CLOSE(10,status='keep') + ENDIF + ENDIF + write(logfid,*) + + INQUIRE(file=PDFFILE,exist=PDFEXIST) + IF(PDFEXIST)THEN + write(logfid,*)'read pdfs from ',PDFFILE + OPEN(unit=10,file=PDFFILE,status='old') + DO 872 I=1,2 + DO 873 J=1,1000 + READ(10,*)QINQX(I,J),GINQX(I,J),QINGX(I,J),GINGX(I,J) + 873 CONTINUE + 872 CONTINUE + CLOSE(10,status='keep') + ELSE + write(logfid,*)'have to integrate pdfs, this may take some time' + CALL PDFINT(EOVEST) + INQUIRE(file=PDFFILE,exist=PDFEXIST) + IF(.NOT.PDFEXIST)THEN + write(logfid,*)'write pdfs to ',PDFFILE + OPEN(unit=10,file=PDFFILE,status='new') + DO 876 I=1,2 + DO 877 J=1,1000 + WRITE(10,*)QINQX(I,J),GINQX(I,J),QINGX(I,J),GINGX(I,J) + 877 CONTINUE + 876 CONTINUE + CLOSE(10,status='keep') + ENDIF + ENDIF + write(logfid,*) + + INQUIRE(file=XSECFILE,exist=XSECEXIST) + IF(XSECEXIST)THEN + write(logfid,*)'read cross sections from ',XSECFILE + OPEN(unit=10,file=XSECFILE,status='old') + DO 881 J=1,1001 + DO 885 JJ=1,101 + READ(10,*)INTQ1(J,JJ),INTQ2(J,JJ), + &INTG1(J,JJ),INTG2(J,JJ) + 885 CONTINUE + 881 CONTINUE + CLOSE(10,status='keep') + ELSE + write(logfid,*)'have to integrate cross sections, '// + &'this may take some time' + CALL XSECINT(EOVEST) + INQUIRE(file=XSECFILE,exist=XSECEXIST) + IF(.NOT.XSECEXIST)THEN + write(logfid,*)'write cross sections to ',XSECFILE + OPEN(unit=10,file=XSECFILE,status='new') + DO 883 J=1,1001 + DO 884 JJ=1,101 + WRITE(10,*)INTQ1(J,JJ),INTQ2(J,JJ), + &INTG1(J,JJ),INTG2(J,JJ) + 884 CONTINUE + 883 CONTINUE + CLOSE(10,status='keep') + ENDIF + ENDIF + write(logfid,*) + CALL FLUSH(3) + + + +C--initialise random number generator status + IF(NJOB.GT.0)THEN + MRPY(1)=NJOB*1000 + MRPY(2)=0 + ENDIF + +C--Call PYR once for initialization + R=PYR(0) + + NDISC=0 + NGOOD=0 + NSTRANGE=0 + + ERRCOUNT=0 + errl = 0 + + NSCAT=0.d0 + NSCATEFF=0.d0 + NSPLIT=0.d0 + + ntotspliti=0 + noverspliti=0 + ntotpdf=0 + noverpdf=0 + ntotxsec=0 + noverxsec=0 + ntotsuda=0 + noversuda=0 + + IF(NSET.EQ.0)THEN + EPS09=.FALSE. + ELSE + EPS09=.TRUE. + IF(NSET.LT.10)THEN + WRITE(SNSET,'(i1)') NSET + ELSE + WRITE(SNSET,'(i2)') NSET + ENDIF + INITSTR='EPS09LO,'//SNSET + ENDIF + + end + + + +*********************************************************************** +*** subroutine initpythia +*********************************************************************** + subroutine initpythia(beam1,beam2) + implicit none + INTEGER PYCOMP + INTEGER NMXHEP +C--Common block of Pythia + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + INTEGER N,NPAD,K + DOUBLE PRECISION P,V + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + INTEGER MSTU,MSTJ + DOUBLE PRECISION PARU,PARJ + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + INTEGER MDCY,MDME,KFDP + DOUBLE PRECISION BRAT + COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) + INTEGER MSEL,MSELPD,MSUB,KFIN + DOUBLE PRECISION CKIN + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + INTEGER MSTP,MSTI + DOUBLE PRECISION PARP,PARI + COMMON/PYDATR/MRPY(6),RRPY(100) + INTEGER MRPY + DOUBLE PRECISION RRPY +C--use nuclear pdf? + COMMON/NPDF/MASS,NSET,EPS09,INITSTR + INTEGER NSET + DOUBLE PRECISION MASS + LOGICAL EPS09 + CHARACTER*10 INITSTR +C--pdfset + common/pdf/pdfset + integer pdfset +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--discard event flag + COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD + LOGICAL DISCARD + INTEGER NDISC,NSTRANGE,NGOOD,errcount + double precision wdisc +C--event weight + COMMON/WEIGHT/EVWEIGHT,sumofweights + double precision EVWEIGHT,sumofweights +C--event weight exponent + COMMON/WEXPO/WEIGHTEX + DOUBLE PRECISION WEIGHTEX +C--memory for error message from getdeltat + common/errline/errl + integer errl +C--organisation of event record + common/evrecord/nsim,npart,offset,hadrotype,sqrts,collider,hadro, + &shorthepmc,channel,isochannel + integer nsim,npart,offset,hadrotype + double precision sqrts + character*4 collider,channel + character*2 isochannel + logical hadro,shorthepmc +C--Pythia parameters + common/pythiaparams/PTMIN,PTMAX,weighted + double precision PTMIN,PTMAX + LOGICAL WEIGHTED + +C--Variables local to this program + character*2 beam1,beam2 + + +C--initialise PYTHIA +C--no multiple interactions + MSTP(81) = 0 +C--initial state radiation + MSTP(61)=1 +C--switch off final state radiation + MSTP(71)=0 +C--No hadronisation (yet) + MSTP(111)=0 +C--parameter affecting treatment of string corners + PARU(14)=1. +C--Min shat in simulation + CKIN(1)=2. +C--pT-cut + CKIN(3)=PTMIN + CKIN(4)=PTMAX +C--use LHAPDF + MSTP(52)=2 +C--choose pdf: CTEQ6ll (LO fit/LO alphas) - 10042 +C MSTW2008 (LO central) - 21000 + MSTP(51)=PDFSET + IF(COLLIDER.EQ.'PPYQ')THEN + MSEL=0 + MSUB(29)=1 + ELSEIF(COLLIDER.EQ.'PPYG')THEN + MSEL=0 + MSUB(14)=1 + MSUB(115)=1 + ELSEIF(COLLIDER.EQ.'PPYJ')THEN + MSEL=0 + MSUB(14)=1 + MSUB(29)=1 + MSUB(115)=1 + ELSEIF((COLLIDER.EQ.'PPZJ').or.(COLLIDER.EQ.'PPZQ') + & .or.(COLLIDER.EQ.'PPZG') + & .or.(collider.eq.'PPDY'))THEN + MSEL=0 + IF((COLLIDER.EQ.'PPZJ').or.(COLLIDER.EQ.'PPZQ')) MSUB(30)=1 + IF((COLLIDER.EQ.'PPZJ').or.(COLLIDER.EQ.'PPZG')) MSUB(15)=1 + IF(COLLIDER.EQ.'PPDY') MSUB(1)=1 + MDME(174,1)=0 !Z decay into d dbar', + MDME(175,1)=0 !Z decay into u ubar', + MDME(176,1)=0 !Z decay into s sbar', + MDME(177,1)=0 !Z decay into c cbar', + MDME(178,1)=0 !Z decay into b bbar', + MDME(179,1)=0 !Z decay into t tbar', + MDME(182,1)=0 !Z decay into e- e+', + MDME(183,1)=0 !Z decay into nu_e nu_ebar', + MDME(184,1)=0 !Z decay into mu- mu+', + MDME(185,1)=0 !Z decay into nu_mu nu_mubar', + MDME(186,1)=0 !Z decay into tau- tau+', + MDME(187,1)=0 !Z decay into nu_tau nu_taubar', + if (channel.EQ.'ELEC')THEN + MDME(182,1)=1 + ELSEIF(channel.EQ.'MUON')THEN + MDME(184,1)=1 + ENDIF + ELSEIF((COLLIDER.EQ.'PPWJ').or.(COLLIDER.EQ.'PPWQ') + & .or.(COLLIDER.EQ.'PPWG'))THEN + MSEL=0 + IF((COLLIDER.EQ.'PPWJ').or.(COLLIDER.EQ.'PPWQ')) MSUB(31)=1 + IF((COLLIDER.EQ.'PPWJ').or.(COLLIDER.EQ.'PPWG')) MSUB(16)=1 + MDME(190,1)=0 ! W+ decay into dbar u, + MDME(191,1)=0 ! W+ decay into dbar c, + MDME(192,1)=0 ! W+ decay into dbar t, + MDME(194,1)=0 ! W+ decay into sbar u, + MDME(195,1)=0 ! W+ decay into sbar c, + MDME(196,1)=0 ! W+ decay into sbar t, + MDME(198,1)=0 ! W+ decay into bbar u, + MDME(199,1)=0 ! W+ decay into bbar c, + MDME(200,1)=0 ! W+ decay into bbar t, + MDME(202,1)=0 ! W+ decay into b'bar u, + MDME(203,1)=0 ! W+ decay into b'bar c, + MDME(204,1)=0 ! W+ decay into b'bar t, + MDME(206,1)=0 ! W+ decay into e+ nu_e, + MDME(207,1)=0 ! W+ decay into mu+ nu_mu, + MDME(208,1)=0 ! W+ decay into tau+ nu_tau, + MDME(209,1)=0 ! W+ decay into tau'+ nu'_tau, + if (channel.EQ.'ELEC')THEN + MDME(206,1)=1 + ELSEIF(channel.EQ.'MUON')THEN + MDME(207,1)=1 + ENDIF + ELSE +C--All QCD processes are active + MSEL=1 + ENDIF +! MSEL=0 +! MSUB(11)=1 +! MSUB(12)=1 +! MSUB(53)=1 +! MSUB(13)=1 +! MSUB(68)=1 +! MSUB(28)=1 + +C--weighted events + IF(WEIGHTED) MSTP(142)=1 + +C--number of errors to be printed + MSTU(22)=MAX(10,INT(5.*NSIM/100.)) + +C--number of lines in event record + MSTU(4)=23000 + MSTU(5)=23000 + +C--switch off pi0 decay + MDCY(PYCOMP(111),1)=0 +C--initialisation call + IF(COLLIDER.EQ.'EEJJ')THEN + OFFSET=9 + CALL PYINIT('CMS',beam1,beam2,sqrts) + ELSEIF((COLLIDER.EQ.'PPJJ').OR.(COLLIDER.EQ.'PPYJ').OR. + & (COLLIDER.EQ.'PPYG').OR.(COLLIDER.EQ.'PPYQ'))THEN + OFFSET=8 + CALL PYINIT('CMS',beam1,beam2,sqrts) + ELSEIF((COLLIDER.EQ.'PPWJ').OR.(COLLIDER.EQ.'PPZJ').or. + & (COLLIDER.EQ.'PPWQ').OR.(COLLIDER.EQ.'PPZQ').or. + & (COLLIDER.EQ.'PPWG').OR.(COLLIDER.EQ.'PPZG'))THEN + OFFSET=10 + CALL PYINIT('CMS',beam1,beam2,sqrts) + elseif (collider.eq.'PPDY') then + CALL PYINIT('CMS',beam1,beam2,sqrts) + ENDIF + + end + + + +*********************************************************************** +*** subroutine genevent +*********************************************************************** + subroutine genevent(j,b1,b2) + implicit none +C--identifier of file for hepmc output and logfile + common/hepmcid/hpmcfid,logfid + integer hpmcfid,logfid + INTEGER PYCOMP + INTEGER NMXHEP +C--Common block of Pythia + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + INTEGER N,NPAD,K + DOUBLE PRECISION P,V + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + INTEGER MSTU,MSTJ + DOUBLE PRECISION PARU,PARJ + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + INTEGER MDCY,MDME,KFDP + DOUBLE PRECISION BRAT + COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) + INTEGER MSEL,MSELPD,MSUB,KFIN + DOUBLE PRECISION CKIN + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + INTEGER MSTP,MSTI + DOUBLE PRECISION PARP,PARI + COMMON/PYDATR/MRPY(6),RRPY(100) + INTEGER MRPY + DOUBLE PRECISION RRPY +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--discard event flag + COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD + LOGICAL DISCARD + INTEGER NDISC,NSTRANGE,NGOOD,errcount + double precision wdisc +C--variables for angular ordering + COMMON/ANGOR/ZA(23000),ZD(23000),THETAA(23000),QQBARD(23000) + DOUBLE PRECISION ZA,ZD,THETAA + LOGICAL QQBARD +C--factor in front of formation times + COMMON/FTIMEFAC/FTFAC + DOUBLE PRECISION FTFAC +C--time common block + COMMON/TIME/MV(23000,5) + DOUBLE PRECISION MV +C--colour index common block + COMMON/COLOUR/TRIP(23000),ANTI(23000),COLMAX + INTEGER TRIP,ANTI,COLMAX +C--number of scattering events + COMMON/CHECK/NSCAT,NSCATEFF,NSPLIT + DOUBLE PRECISION NSCAT,NSCATEFF,NSPLIT +C--event weight + COMMON/WEIGHT/EVWEIGHT,sumofweights + double precision EVWEIGHT,sumofweights +C--event weight exponent + COMMON/WEXPO/WEIGHTEX + DOUBLE PRECISION WEIGHTEX +C--max rapidity + common/rapmax/etamax + double precision etamax +C--production point + common/jetpoint/x0,y0 + double precision x0,y0 +C--organisation of event record + common/evrecord/nsim,npart,offset,hadrotype,sqrts,collider,hadro, + &shorthepmc,channel,isochannel + integer nsim,npart,offset,hadrotype + double precision sqrts + character*4 collider,channel + character*2 isochannel + logical hadro,shorthepmc +C--extra storage for scattering centres before interactions + common/storescatcen/nscatcen,maxnscatcen,scatflav(10000), + &scatcen(10000,5),writescatcen,writedummies + integer nscatcen,maxnscatcen,scatflav + double precision scatcen + logical writescatcen,writedummies + +C--Variables local to this program + INTEGER NOLD,PID,IPART,LME1,LME2,j,i,LME1ORIG,LME2ORIG,llep1, + &llep2,lv + DOUBLE PRECISION PYR,ENI,QMAX1,R,GETMASS,PYP,Q1,Q2,P21,P22,ETOT, + &QMAX2,POLD,EN1,EN2,BETA(3),ENEW1,ENEW2,emax,lambda,x1,x2,x3, + &MEWEIGHT,PSWEIGHT,WEIGHT,EPS1,EPS2,THETA1,THETA2,Z1,Z2, + &getltimemax,pi,m1,m2 + character*2 b1,b2 + CHARACTER*2 TYPE1,TYPE2 + LOGICAL FIRSTTRIP,WHICH1,WHICH2,ISDIQUARK + DATA PI/3.141592653589793d0/ + + N=0 + COLMAX=600 + DISCARD=.FALSE. + DO 91 I=1,23000 + MV(I,1)=0.d0 + MV(I,2)=0.d0 + MV(I,3)=0.d0 + MV(I,4)=0.d0 + MV(I,5)=0.d0 + 91 CONTINUE + nscatcen = 0 + + CALL MEDNEXTEVT + +C--initialisation with matrix element +C--production vertex + CALL PICKVTX(X0,Y0) + LTIME=GETLTIMEMAX() + + 99 CALL PYEVNT + NPART=N-OFFSET + EVWEIGHT=PARI(10) + SUMOFWEIGHTS=SUMOFWEIGHTS+EVWEIGHT + IF((COLLIDER.EQ.'EEJJ').AND.(ABS(K(8,2)).GT.6))THEN + WDISC=WDISC+EVWEIGHT + NDISC=NDISC+1 + GOTO 102 + ELSE + NGOOD=NGOOD+1 + ENDIF + +C--DY: don't have to do anything + if (collider.eq.'PPDY') then + CALL PYEXEC + call CONVERTTOHEPMC(HPMCFID,NGOOD,PID,b1,b2) + goto 102 + endif + + +C-- prepare event record + if((COLLIDER.EQ.'PPZJ').OR.(COLLIDER.EQ.'PPZQ').or. + & (COLLIDER.EQ.'PPZG').or.(COLLIDER.EQ.'PPWJ').or. + & (COLLIDER.EQ.'PPWQ').or.(COLLIDER.EQ.'PPWG'))THEN + LME1ORIG=7 + LME2ORIG=8 + if(abs(k(7,2)).gt.21) then + lv=7 + else + lv=8 + endif + ELSE + LME1ORIG=OFFSET-1 + LME2ORIG=OFFSET + ENDIF + DO 180 IPART=OFFSET+1, OFFSET+NPART +C--find decay leptons in V+jet events + if((COLLIDER.EQ.'PPZJ').OR.(COLLIDER.EQ.'PPZQ').or. + & (COLLIDER.EQ.'PPZG').or.(COLLIDER.EQ.'PPWJ').or. + & (COLLIDER.EQ.'PPWQ').or.(COLLIDER.EQ.'PPWG'))THEN + if(k(ipart,3).eq.offset-1) llep1=ipart + if(k(ipart,3).eq.offset) llep2=ipart + endif + IF(K(IPART,3).EQ.(LME1ORIG))THEN + LME1=IPART + IF(K(IPART,2).EQ.21)THEN + TYPE1='GC' + ELSE + TYPE1='QQ' + ENDIF + ELSEIF(K(IPART,3).EQ.LME2ORIG)THEN + LME2=IPART + IF(K(IPART,2).EQ.21)THEN + TYPE2='GC' + ELSE + TYPE2='QQ' + ENDIF + ELSE + TRIP(IPART)=0 + ANTI(IPART)=0 + ZD(IPART)=0.d0 + THETAA(IPART)=0.d0 + ENDIF +C--assign colour indices + IF(K(IPART,1).EQ.2)THEN + IF(K(IPART-1,1).EQ.2)THEN +C--in middle of colour singlet + IF(FIRSTTRIP)THEN + TRIP(IPART)=COLMAX+1 + ANTI(IPART)=TRIP(IPART-1) + ELSE + TRIP(IPART)=ANTI(IPART-1) + ANTI(IPART)=COLMAX+1 + ENDIF + COLMAX=COLMAX+1 + ELSE +C--beginning of colour singlet + IF(((ABS(K(IPART,2)).LT.10).AND.(K(IPART,2).GT.0)) + & .OR.(ISDIQUARK(K(IPART,2)).AND.(K(IPART,2).LT.0)))THEN + TRIP(IPART)=COLMAX+1 + ANTI(IPART)=0 + FIRSTTRIP=.TRUE. + ELSE + TRIP(IPART)=0 + ANTI(IPART)=COLMAX+1 + FIRSTTRIP=.FALSE. + ENDIF + COLMAX=COLMAX+1 + ENDIF + ENDIF + IF(K(IPART,1).EQ.1)THEN +C--end of colour singlet + IF(FIRSTTRIP)THEN + TRIP(IPART)=0 + ANTI(IPART)=TRIP(IPART-1) + ELSE + TRIP(IPART)=ANTI(IPART-1) + ANTI(IPART)=0 + ENDIF + ENDIF + 180 CONTINUE + if (k(lme1,1).lt.11) K(LME1,1)=1 + if (k(lme2,1).lt.11) K(LME2,1)=1 + PID=K(LME1,2) + ENI=MAX(P(LME1,4),P(LME2,4)) + DO 183 IPART=OFFSET+1, OFFSET+NPART + IF((IPART.NE.LME1).AND.(IPART.NE.LME2).AND.(K(IPART,1).LT.11)) + & K(IPART,1)=4 + if (k(ipart,2).eq.22) k(ipart,1)=4 + 183 CONTINUE + +C--find virtualities and adapt four-vectors + if((COLLIDER.EQ.'PPZJ').OR.(COLLIDER.EQ.'PPZQ').or. + & (COLLIDER.EQ.'PPZG').or.(COLLIDER.EQ.'PPWJ').or. + & (COLLIDER.EQ.'PPWQ').or.(COLLIDER.EQ.'PPWG'))THEN + if (abs(k(lme1,2)).gt.21) then + QMAX1=0.d0 + QMAX2=sqrt(pari(18)+p(lme1,5)**2) + else + QMAX1=sqrt(pari(18)+p(lme2,5)**2) + QMAX2=0.d0 + endif + EMAX=P(LME1,4)+P(LME2,4) + THETA1=-1.d0 + THETA2=-1.d0 + ELSEIF(COLLIDER.EQ.'PPJJ'.OR.COLLIDER.EQ.'PPYJ' + & .OR.COLLIDER.EQ.'PPYQ'.OR.COLLIDER.EQ.'PPYG')THEN + if (k(lme1,1).eq.4) then + qmax1 = 0.d0 + else + QMAX1=pari(17) + endif + if (k(lme2,1).eq.4) then + qmax2 = 0.d0 + else + QMAX2=pari(17) + endif +! QMAX1=PYP(LME1,10)*exp(0.3*abs(pyp(lme1,17)-pyp(lme2,17))/2.)/2. +! QMAX2=PYP(LME2,10)*exp(0.3*abs(pyp(lme1,17)-pyp(lme2,17))/2.)/2. + EMAX=P(LME1,4)+P(LME2,4) + THETA1=-1.d0 + THETA2=-1.d0 + ENDIF + EN1=P(LME1,4) + EN2=P(LME2,4) + BETA(1)=(P(LME1,1)+P(LME2,1))/(P(LME1,4)+P(LME2,4)) + BETA(2)=(P(LME1,2)+P(LME2,2))/(P(LME1,4)+P(LME2,4)) + BETA(3)=(P(LME1,3)+P(LME2,3))/(P(LME1,4)+P(LME2,4)) + CALL PYROBO(LME1,LME1,0d0,0d0,-BETA(1),-BETA(2),-BETA(3)) + CALL PYROBO(LME2,LME2,0d0,0d0,-BETA(1),-BETA(2),-BETA(3)) + ETOT=P(LME1,4)+P(LME2,4) + IF(COLLIDER.EQ.'EEJJ')THEN + QMAX1=ETOT + QMAX2=ETOT + EMAX=P(LME1,4)+P(LME2,4) + THETA1=-1.d0 + THETA2=-1.d0 + ENDIF +C-- find virtuality + Q1=GETMASS(0.d0,QMAX1,THETA1,EMAX,TYPE1,EMAX,.FALSE., + & Z1,WHICH1) + Q2=GETMASS(0.d0,QMAX2,THETA2,EMAX,TYPE2,EMAX,.FALSE., + & Z2,WHICH2) + 182 if (abs(k(lme1,2)).gt.21) then + m1=p(lme1,5) + else + m1=q1 + endif + if (abs(k(lme2,2)).gt.21) then + m2=p(lme2,5) + else + m2=q2 + endif + ENEW1=ETOT/2.d0 + (m1**2-m2**2)/(2.*ETOT) + ENEW2=ETOT/2.d0 - (m1**2-m2**2)/(2.*ETOT) + P21 = (ETOT/2.d0 + (m1**2-m2**2)/(2.*ETOT))**2 - m1**2 + P22 = (ETOT/2.d0 - (m1**2-m2**2)/(2.*ETOT))**2 - m2**2 + WEIGHT=1.d0 + IF((PYR(0).GT.WEIGHT).OR.(P21.LT.0.d0).OR.(P22.LT.0.d0) + & .OR.(ENEW1.LT.0.d0).OR.(ENEW2.LT.0.d0) + & )THEN + IF(Q1.GT.Q2)THEN + Q1=GETMASS(0.d0,Q1,THETA1,EMAX,TYPE1,EMAX,.FALSE., + & Z1,WHICH1) + ELSE + Q2=GETMASS(0.d0,Q2,THETA2,EMAX,TYPE2,EMAX,.FALSE., + & Z2,WHICH2) + ENDIF + GOTO 182 + ENDIF + POLD=PYP(LME1,8) + P(LME1,1)=P(LME1,1)*SQRT(P21)/POLD + P(LME1,2)=P(LME1,2)*SQRT(P21)/POLD + P(LME1,3)=P(LME1,3)*SQRT(P21)/POLD + P(LME1,4)=ENEW1 + P(LME1,5)=m1 + POLD=PYP(LME2,8) + P(LME2,1)=P(LME2,1)*SQRT(P22)/POLD + P(LME2,2)=P(LME2,2)*SQRT(P22)/POLD + P(LME2,3)=P(LME2,3)*SQRT(P22)/POLD + P(LME2,4)=ENEW2 + P(LME2,5)=m2 + CALL PYROBO(LME1,LME1,0d0,0d0,BETA(1),BETA(2),BETA(3)) + CALL PYROBO(LME2,LME2,0d0,0d0,BETA(1),BETA(2),BETA(3)) +C--correct for overestimated energy + IF(Q1.GT.0.d0)THEN + EPS1=0.5-0.5*SQRT(1.-Q0**2/Q1**2) + & *SQRT(1.-Q1**2/P(LME1,4)**2) + IF((Z1.LT.EPS1).OR.(Z1.GT.(1.-EPS1)))THEN + Q1=GETMASS(0.d0,Q1,THETA1,EMAX,TYPE1,EMAX,.FALSE., + & Z1,WHICH1) + CALL PYROBO(LME1,LME1,0d0,0d0,-BETA(1),-BETA(2),-BETA(3)) + CALL PYROBO(LME2,LME2,0d0,0d0,-BETA(1),-BETA(2),-BETA(3)) + GOTO 182 + ENDIF + ENDIF + IF(Q2.GT.0.d0)THEN + EPS2=0.5-0.5*SQRT(1.-Q0**2/Q2**2) + & *SQRT(1.-Q2**2/P(LME2,4)**2) + IF((Z2.LT.EPS2).OR.(Z2.GT.(1.-EPS2)))THEN + Q2=GETMASS(0.d0,Q2,THETA2,EMAX,TYPE2,EMAX,.FALSE., + & Z2,WHICH2) + CALL PYROBO(LME1,LME1,0d0,0d0,-BETA(1),-BETA(2),-BETA(3)) + CALL PYROBO(LME2,LME2,0d0,0d0,-BETA(1),-BETA(2),-BETA(3)) + GOTO 182 + ENDIF + ENDIF + +C--correct to ME for first parton + IF(COLLIDER.EQ.'EEJJ')THEN + BETA(1)=(P(LME1,1)+P(LME2,1))/(P(LME1,4)+P(LME2,4)) + BETA(2)=(P(LME1,2)+P(LME2,2))/(P(LME1,4)+P(LME2,4)) + BETA(3)=(P(LME1,3)+P(LME2,3))/(P(LME1,4)+P(LME2,4)) + CALL PYROBO(LME1,LME1,0d0,0d0,-BETA(1),-BETA(2),-BETA(3)) + CALL PYROBO(LME2,LME2,0d0,0d0,-BETA(1),-BETA(2),-BETA(3)) + IF(Q1.GT.0.d0)THEN +C--generate z value + X1=Z1*(ETOT**2+Q1**2)/ETOT**2 + X2=(ETOT**2-Q1**2)/ETOT**2 + X3=(1.-Z1)*(ETOT**2+Q1**2)/ETOT**2 + PSWEIGHT=(1.-X1)*(1.+(X1/(2.-X2))**2)/X3 + & + (1.-X2)*(1.+(X2/(2.-X1))**2)/X3 + MEWEIGHT=X1**2+X2**2 + WEIGHT=MEWEIGHT/PSWEIGHT + IF(PYR(0).GT.WEIGHT)THEN + 184 Q1=GETMASS(0.d0,Q1,THETA1,EMAX,TYPE1,EMAX,.FALSE., + & Z1,WHICH1) + ENDIF + ENDIF +C--correct to ME for second parton + IF(Q2.GT.0.d0)THEN +C--generate z value + X1=(ETOT**2-Q2**2)/ETOT**2 + X2=Z2*(ETOT**2+Q2**2)/ETOT**2 + X3=(1.-Z2)*(ETOT**2+Q2**2)/ETOT**2 + PSWEIGHT=(1.-X1)*(1.+(X1/(2.-X2))**2)/X3 + & + (1.-X2)*(1.+(X2/(2.-X1))**2)/X3 + MEWEIGHT=X1**2+X2**2 + WEIGHT=MEWEIGHT/PSWEIGHT + IF(PYR(0).GT.WEIGHT)THEN + 185 Q2=GETMASS(0.d0,Q2,THETA2,EMAX,TYPE2,EMAX,.FALSE., + & Z2,WHICH2) + ENDIF + ENDIF + 186 ENEW1=ETOT/2.d0 + (Q1**2-Q2**2)/(2.*ETOT) + ENEW2=ETOT/2.d0 - (Q1**2-Q2**2)/(2.*ETOT) + P21 = (ETOT/2.d0 + (Q1**2-Q2**2)/(2.*ETOT))**2 - Q1**2 + P22 = (ETOT/2.d0 - (Q1**2-Q2**2)/(2.*ETOT))**2 - Q2**2 + POLD=PYP(LME1,8) + P(LME1,1)=P(LME1,1)*SQRT(P21)/POLD + P(LME1,2)=P(LME1,2)*SQRT(P21)/POLD + P(LME1,3)=P(LME1,3)*SQRT(P21)/POLD + P(LME1,4)=ENEW1 + P(LME1,5)=Q1 + POLD=PYP(LME2,8) + P(LME2,1)=P(LME2,1)*SQRT(P22)/POLD + P(LME2,2)=P(LME2,2)*SQRT(P22)/POLD + P(LME2,3)=P(LME2,3)*SQRT(P22)/POLD + P(LME2,4)=ENEW2 + P(LME2,5)=Q2 + CALL PYROBO(LME1,LME1,0d0,0d0,BETA(1),BETA(2),BETA(3)) + CALL PYROBO(LME2,LME2,0d0,0d0,BETA(1),BETA(2),BETA(3)) +C--correct for overestimated energy + IF(Q1.GT.0.d0)THEN + EPS1=0.5-0.5*SQRT(1.-Q0**2/Q1**2) + & *SQRT(1.-Q1**2/P(LME1,4)**2) + IF((Z1.LT.EPS1).OR.(Z1.GT.(1.-EPS1)))THEN + Q1=GETMASS(0.d0,Q1,THETA1,EMAX,TYPE1,EMAX,.FALSE., + & Z1,WHICH1) + CALL PYROBO(LME1,LME1,0d0,0d0,-BETA(1),-BETA(2),-BETA(3)) + CALL PYROBO(LME2,LME2,0d0,0d0,-BETA(1),-BETA(2),-BETA(3)) + GOTO 186 + ENDIF + ENDIF + IF(Q2.GT.0.d0)THEN + EPS2=0.5-0.5*SQRT(1.-Q0**2/Q2**2) + & *SQRT(1.-Q2**2/P(LME2,4)**2) + IF((Z2.LT.EPS2).OR.(Z2.GT.(1.-EPS2)))THEN + Q2=GETMASS(0.d0,Q2,THETA2,EMAX,TYPE2,EMAX,.FALSE., + & Z2,WHICH2) + CALL PYROBO(LME1,LME1,0d0,0d0,-BETA(1),-BETA(2),-BETA(3)) + CALL PYROBO(LME2,LME2,0d0,0d0,-BETA(1),-BETA(2),-BETA(3)) + GOTO 186 + ENDIF + ENDIF + ENDIF + +C--transfer recoil to decay leptons in V+jet + if((COLLIDER.EQ.'PPZJ').OR.(COLLIDER.EQ.'PPZQ').or. + & (COLLIDER.EQ.'PPZG').or.(COLLIDER.EQ.'PPWJ').or. + & (COLLIDER.EQ.'PPWQ').or.(COLLIDER.EQ.'PPWG'))THEN + beta(1)=p(lv,1)/p(lv,4) + beta(2)=p(lv,2)/p(lv,4) + beta(3)=p(lv,3)/p(lv,4) + CALL PYROBO(llep1,llep1,0d0,0d0,-BETA(1),-BETA(2),-BETA(3)) + CALL PYROBO(llep2,llep2,0d0,0d0,-BETA(1),-BETA(2),-BETA(3)) + if (abs(k(lme1,2)).gt.21) then + beta(1)=p(lme1,1)/p(lme1,4) + beta(2)=p(lme1,2)/p(lme1,4) + beta(3)=p(lme1,3)/p(lme1,4) + else + beta(1)=p(lme2,1)/p(lme2,4) + beta(2)=p(lme2,2)/p(lme2,4) + beta(3)=p(lme2,3)/p(lme2,4) + endif + CALL PYROBO(llep1,llep1,0d0,0d0,BETA(1),BETA(2),BETA(3)) + CALL PYROBO(llep2,llep2,0d0,0d0,BETA(1),BETA(2),BETA(3)) + endif + + + ZA(LME1)=1.d0 + ZA(LME2)=1.d0 + THETAA(LME1)=P(LME1,5)/(SQRT(Z1*(1.-Z1))*P(LME1,4)) + THETAA(LME2)=P(LME2,5)/(SQRT(Z2*(1.-Z2))*P(LME2,4)) + ZD(LME1)=Z1 + ZD(LME2)=Z2 + QQBARD(LME1)=WHICH1 + QQBARD(LME2)=WHICH2 + + MV(LME1,1)=X0 + MV(LME1,2)=Y0 + MV(LME1,3)=0.d0 + MV(LME1,4)=0.d0 + IF(P(LME1,5).GT.0.d0)THEN + LAMBDA=1.d0/(FTFAC*P(LME1,4)*0.2/Q1**2) + MV(LME1,5)=-LOG(1.d0-PYR(0))/LAMBDA + ELSE + MV(LME1,5)=LTIME + ENDIF + + MV(LME2,1)=X0 + MV(LME2,2)=Y0 + MV(LME2,3)=0.d0 + MV(LME2,4)=0.d0 + IF(P(LME2,5).GT.0.d0)THEN + LAMBDA=1.d0/(FTFAC*P(LME2,4)*0.2/Q2**2) + MV(LME2,5)=-LOG(1.d0-PYR(0))/LAMBDA + ELSE + MV(LME2,5)=LTIME + ENDIF + +C--develop parton shower + CALL MAKECASCADE + IF(DISCARD) THEN + NGOOD=NGOOD-1 + WDISC=WDISC+EVWEIGHT + NDISC=NDISC+1 + write(logfid,*)'discard event',J + GOTO 102 + ENDIF + + IF(.NOT.ALLHAD)THEN + DO 86 I=1,N + IF(K(I,1).EQ.3) K(I,1)=22 + 86 CONTINUE + ENDIF + IF(HADRO)THEN + CALL MAKESTRINGS(HADROTYPE) + IF(DISCARD) THEN + write(logfid,*)'discard event',J + WDISC=WDISC+EVWEIGHT + NDISC=NDISC+1 + NGOOD=NGOOD-1 + GOTO 102 + ENDIF + CALL PYEXEC + IF(MSTU(30).NE.ERRCOUNT)THEN + write(logfid,*)'PYTHIA discards event',J, + & ' (error number',MSTU(30),')' + ERRCOUNT=MSTU(30) + WDISC=WDISC+EVWEIGHT + NDISC=NDISC+1 + NGOOD=NGOOD-1 + GOTO 102 + ENDIF + ENDIF + + IF(MSTU(30).NE.ERRCOUNT)THEN + ERRCOUNT=MSTU(30) + ELSE + CALL CONVERTTOHEPMC(HPMCFID,NGOOD,PID,b1,b2) + ENDIF + +C--write message to log-file + 102 IF(NSIM.GT.100)THEN + IF(MOD(J,NSIM/100).EQ.0)THEN + write(logfid,*) 'done with event number ',J + ENDIF + else + write(logfid,*) 'done with event number ',J + ENDIF + call flush(logfid) + end + + + +*********************************************************************** +*** subroutine makestrings +*********************************************************************** + SUBROUTINE MAKESTRINGS(WHICH) + IMPLICIT NONE +C--identifier of file for hepmc output and logfile + common/hepmcid/hpmcfid,logfid + integer hpmcfid,logfid + INTEGER WHICH + IF(WHICH.EQ.0)THEN + CALL MAKESTRINGS_VAC + ELSEIF(WHICH.EQ.1)THEN + CALL MAKESTRINGS_MINL + ELSE + WRITE(logfid,*)'error: unknown hadronisation type in MAKESTRINGS' + ENDIF + END + + +*********************************************************************** +*** subroutine makestrings_vac +*********************************************************************** + SUBROUTINE MAKESTRINGS_VAC + IMPLICIT NONE +C--identifier of file for hepmc output and logfile + common/hepmcid/hpmcfid,logfid + integer hpmcfid,logfid +C--Common block of Pythia + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + INTEGER N,NPAD,K + DOUBLE PRECISION P,V +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--colour index common block + COMMON/COLOUR/TRIP(23000),ANTI(23000),COLMAX + INTEGER TRIP,ANTI,COLMAX +C--discard event flag + COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD + LOGICAL DISCARD + INTEGER NDISC,NSTRANGE,NGOOD,errcount + double precision wdisc +C--local variables + INTEGER NOLD,I,J,LQUARK,LMATCH,LLOOSE,NOLD1 + DOUBLE PRECISION EADDEND,PYR,DIR + LOGICAL ISDIQUARK,compressevent,roomleft + DATA EADDEND/10.d0/ + + i = 0 + if (compress) roomleft = compressevent(i) + NOLD1=N +C--remove all active lines that are leptons, gammas, hadrons etc. + DO 52 I=1,NOLD1 + IF((K(I,1).EQ.4).AND.(TRIP(I).EQ.0).AND.(ANTI(I).EQ.0))THEN +C--copy line to end of event record + N=N+1 + IF(N.GT.22990) THEN + write(logfid,*)'event too long for event record' + DISCARD=.TRUE. + RETURN + ENDIF + K(N,1)=11 + K(N,2)=K(I,2) + K(N,3)=I + K(N,4)=0 + K(N,5)=0 + P(N,1)=P(I,1) + P(N,2)=P(I,2) + P(N,3)=P(I,3) + P(N,4)=P(I,4) + P(N,5)=P(I,5) + K(I,1)=17 + K(I,4)=N + K(I,5)=N + TRIP(N)=TRIP(I) + ANTI(N)=ANTI(I) + ENDIF + 52 CONTINUE + NOLD=N +C--first do strings with existing (anti)triplets +C--find string end (=quark or antiquark) + 43 LQUARK=0 + DO 40 I=1,NOLD + IF((K(I,1).EQ.11).OR.(K(I,1).EQ.12).OR.(K(I,1).EQ.13) + & .OR.(K(I,1).EQ.14)) K(I,1)=17 + IF(((K(I,1).EQ.1).OR.(K(I,1).EQ.3).OR.(K(I,1).EQ.4).OR. + & (K(I,1).EQ.5)).AND.((K(I,2).LT.6).OR.ISDIQUARK(K(I,2))))THEN + LQUARK=I + GOTO 41 + ENDIF + 40 CONTINUE + GOTO 50 + 41 CONTINUE +C--copy string end to end of event record + N=N+1 + IF(N.GT.22990) THEN + write(logfid,*)'event too long for event record' + DISCARD=.TRUE. + RETURN + ENDIF + K(N,1)=2 + K(N,2)=K(LQUARK,2) + K(N,3)=LQUARK + K(N,4)=0 + K(N,5)=0 + P(N,1)=P(LQUARK,1) + P(N,2)=P(LQUARK,2) + P(N,3)=P(LQUARK,3) + P(N,4)=P(LQUARK,4) + P(N,5)=P(LQUARK,5) + K(LQUARK,1)=16 + K(LQUARK,4)=N + K(LQUARK,5)=N + TRIP(N)=TRIP(LQUARK) + ANTI(N)=ANTI(LQUARK) +C--append matching colour partner + LMATCH=0 + DO 44 J=1,10000000 + DO 42 I=1,NOLD + IF(((K(I,1).EQ.1).OR.(K(I,1).EQ.3).OR.(K(I,1).EQ.4) + & .OR.(K(I,1).EQ.5)) + & .AND.(((TRIP(I).EQ.ANTI(N)).AND.(TRIP(I).NE.0)) + & .OR.((ANTI(I).EQ.TRIP(N)).AND.(ANTI(I).NE.0))))THEN + N=N+1 + IF(N.GT.22990) THEN + write(logfid,*)'event too long for event record' + DISCARD=.TRUE. + RETURN + ENDIF + K(N,2)=K(I,2) + K(N,3)=I + K(N,4)=0 + K(N,5)=0 + P(N,1)=P(I,1) + P(N,2)=P(I,2) + P(N,3)=P(I,3) + P(N,4)=P(I,4) + P(N,5)=P(I,5) + TRIP(N)=TRIP(I) + ANTI(N)=ANTI(I) + K(I,1)=16 + K(I,4)=N + K(I,5)=N + IF(K(I,2).EQ.21)THEN + K(N,1)=2 + GOTO 44 + ELSE + K(N,1)=1 + GOTO 43 + ENDIF + ENDIF + 42 CONTINUE +C--no matching colour partner found + write(logfid,*)'Error in MAKESTRINGS_VAC: failed to reconstruct '// + &'colour singlet system, will discard event' + discard = .true. + return + 44 CONTINUE +C--now take care of purely gluonic remainder system +C----------------------------------------- +C--find gluon where anti-triplet is not matched + 50 LLOOSE=0 + DO 45 I=1,NOLD + IF(((K(I,1).EQ.1).OR.(K(I,1).EQ.3).OR.(K(I,1).EQ.4) + & .OR.(K(I,1).EQ.5)))THEN + DO 46 J=1,NOLD + IF(((K(I,1).EQ.1).OR.(K(I,1).EQ.3).OR.(K(I,1).EQ.4) + & .OR.(K(I,1).EQ.5)))THEN + IF(ANTI(I).EQ.TRIP(J)) GOTO 45 + ENDIF + 46 CONTINUE + LLOOSE=I + GOTO 47 + ENDIF + 45 CONTINUE + GOTO 51 + 47 CONTINUE +C--generate artificial triplet end + write(logfid,*)'Error in MAKESTRINGS_VAC: failed to reconstruct '// + &'colour singlet system, will discard event' + discard = .true. + return +C--copy loose gluon to end of event record + N=N+1 + IF(N.GT.22990) THEN + write(logfid,*)'event too long for event record' + DISCARD=.TRUE. + RETURN + ENDIF + K(N,1)=2 + K(N,2)=K(LLOOSE,2) + K(N,3)=LLOOSE + K(N,4)=0 + K(N,5)=0 + P(N,1)=P(LLOOSE,1) + P(N,2)=P(LLOOSE,2) + P(N,3)=P(LLOOSE,3) + P(N,4)=P(LLOOSE,4) + P(N,5)=P(LLOOSE,5) + K(LLOOSE,1)=16 + K(LLOOSE,4)=N + K(LLOOSE,5)=N + TRIP(N)=TRIP(LLOOSE) + ANTI(N)=ANTI(LLOOSE) +C--append matching colour partner + LMATCH=0 + DO 48 J=1,10000000 + DO 49 I=1,NOLD + IF(((K(I,1).EQ.1).OR.(K(I,1).EQ.3).OR.(K(I,1).EQ.4) + & .OR.(K(I,1).EQ.5)) + & .AND.(ANTI(I).EQ.TRIP(N)))THEN + N=N+1 + IF(N.GT.22990) THEN + write(logfid,*)'event too long for event record' + DISCARD=.TRUE. + RETURN + ENDIF + K(N,2)=K(I,2) + K(N,3)=I + K(N,4)=0 + K(N,5)=0 + P(N,1)=P(I,1) + P(N,2)=P(I,2) + P(N,3)=P(I,3) + P(N,4)=P(I,4) + P(N,5)=P(I,5) + TRIP(N)=TRIP(I) + ANTI(N)=ANTI(I) + K(I,1)=16 + K(I,4)=N + K(I,5)=N + K(N,1)=2 + GOTO 48 + ENDIF + 49 CONTINUE +C--no matching colour partner found, add artificial end point + write(logfid,*)'Error in MAKESTRINGS_VAC: failed to reconstruct '// + &'colour singlet system, will discard event' + discard = .true. + return + 48 CONTINUE + 51 CONTINUE + CALL CLEANUP(NOLD1) + END + + +*********************************************************************** +*** subroutine makestrings_minl +*********************************************************************** + SUBROUTINE MAKESTRINGS_MINL + IMPLICIT NONE +C--Common block of Pythia + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + INTEGER N,NPAD,K + DOUBLE PRECISION P,V +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--colour index common block + COMMON/COLOUR/TRIP(23000),ANTI(23000),COLMAX + INTEGER TRIP,ANTI,COLMAX +C--local variables + INTEGER NOLD,I,J,LMAX,LMIN,LEND,nold1 + DOUBLE PRECISION EMAX,MINV,MMIN,Z,GENERATEZ,MCUT,EADDEND,PYR,DIR, + &pyp + DATA MCUT/1.d8/ + DATA EADDEND/10.d0/ +C--identifier of file for hepmc output and logfile + common/hepmcid/hpmcfid,logfid + integer hpmcfid,logfid +C--discard event flag + COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD + LOGICAL DISCARD + INTEGER NDISC,NSTRANGE,NGOOD,errcount + double precision wdisc + logical compressevent,roomleft + + i = 0 + if (compress) roomleft = compressevent(i) + NOLD1=N +C--remove all active lines that are leptons, gammas, hadrons etc. + DO 52 I=1,NOLD1 + IF((K(I,1).EQ.4).AND.(TRIP(I).EQ.0).AND.(ANTI(I).EQ.0))THEN +C--copy line to end of event record + N=N+1 + IF(N.GT.22990) THEN + write(logfid,*)'event too long for event record' + DISCARD=.TRUE. + RETURN + ENDIF + K(N,1)=11 + K(N,2)=K(I,2) + K(N,3)=I + K(N,4)=0 + K(N,5)=0 + P(N,1)=P(I,1) + P(N,2)=P(I,2) + P(N,3)=P(I,3) + P(N,4)=P(I,4) + P(N,5)=P(I,5) + K(I,1)=17 + K(I,4)=N + K(I,5)=N + TRIP(N)=TRIP(I) + ANTI(N)=ANTI(I) + ENDIF + 52 CONTINUE + NOLD=N +C--find most energetic unfragmented parton in event + 43 EMAX=0 + LMAX=0 + DO 40 I=1,NOLD + IF((K(I,1).EQ.11).OR.(K(I,1).EQ.12).OR.(K(I,1).EQ.13) + & .OR.(K(I,1).EQ.14)) K(I,1)=17 + if (abs(pyp(I,17)).gt.4.d0) k(i,1)=17 + IF(((K(I,1).EQ.1).OR.(K(I,1).EQ.3).OR.(K(I,1).EQ.4) + & .OR.(K(I,1).EQ.5)).AND.(P(I,4).GT.EMAX))THEN + EMAX=P(I,4) + LMAX=I + ENDIF + 40 CONTINUE +C--if there is non, we are done + IF(LMAX.EQ.0) GOTO 50 +C--check if highest energy parton is (anti)quark or gluon + IF(K(LMAX,2).EQ.21)THEN +C--split gluon in qqbar pair and store one temporarily in line 1 +C--make new line in event record for string end + N=N+2 + IF(N.GT.22990) THEN + write(logfid,*)'event too long for event record' + DISCARD=.TRUE. + RETURN + ENDIF + IF((N-2).GT.NOLD)THEN + DO 47 J=NOLD,N-3 + K(N+NOLD-J,1)=K(N+NOLD-J-2,1) + K(N+NOLD-J,2)=K(N+NOLD-J-2,2) + IF(K(N+NOLD-J-2,3).GT.NOLD) THEN + K(N+NOLD-J,3)=K(N+NOLD-J-2,3)+2 + ELSE + K(N+NOLD-J,3)=K(N+NOLD-J-2,3) + ENDIF + K(N+NOLD-J,4)=0 + K(N+NOLD-J,5)=0 + P(N+NOLD-J,1)=P(N+NOLD-J-2,1) + P(N+NOLD-J,2)=P(N+NOLD-J-2,2) + P(N+NOLD-J,3)=P(N+NOLD-J-2,3) + P(N+NOLD-J,4)=P(N+NOLD-J-2,4) + P(N+NOLD-J,5)=P(N+NOLD-J-2,5) + K(K(N+NOLD-J-2,3),4)=K(K(N+NOLD-J-2,3),4)+2 + K(K(N+NOLD-J-2,3),5)=K(K(N+NOLD-J-2,3),5)+2 + 47 CONTINUE + ENDIF + NOLD=NOLD+2 + K(LMAX,1)=18 + Z=GENERATEZ(0.d0,0.d0,1.d-3,'QG') + IF(Z.GT.0.5)THEN + K(NOLD-1,2)=1 + K(NOLD,2)=-1 + ELSE + Z=1.-Z + K(NOLD-1,2)=-1 + K(NOLD,2)=1 + ENDIF + K(NOLD-1,1)=1 + K(NOLD-1,3)=LMAX + K(NOLD-1,4)=0 + K(NOLD-1,5)=0 + P(NOLD-1,1)=(1.-Z)*P(LMAX,1) + P(NOLD-1,2)=(1.-Z)*P(LMAX,2) + P(NOLD-1,3)=(1.-Z)*P(LMAX,3) + P(NOLD-1,4)=(1.-Z)*P(LMAX,4) + P(NOLD-1,5)=P(LMAX,5) + K(NOLD,1)=1 + K(NOLD,3)=LMAX + K(NOLD,4)=0 + K(NOLD,5)=0 + P(NOLD,1)=Z*P(LMAX,1) + P(NOLD,2)=Z*P(LMAX,2) + P(NOLD,3)=Z*P(LMAX,3) + P(NOLD,4)=Z*P(LMAX,4) + P(NOLD,5)=P(LMAX,5) + K(LMAX,1)=18 + K(LMAX,4)=NOLD-1 + K(LMAX,5)=NOLD + LMAX=NOLD + ENDIF + N=N+1 + IF(N.GT.22990) THEN + write(logfid,*)'event too long for event record' + DISCARD=.TRUE. + RETURN + ENDIF + K(N,1)=2 + K(N,2)=K(LMAX,2) + K(N,3)=LMAX + K(N,4)=0 + K(N,5)=0 + P(N,1)=P(LMAX,1) + P(N,2)=P(LMAX,2) + P(N,3)=P(LMAX,3) + P(N,4)=P(LMAX,4) + P(N,5)=P(LMAX,5) + K(LMAX,1)=16 + K(LMAX,4)=N + K(LMAX,5)=N + LEND=LMAX +C--find closest partner + 42 MMIN=1.d10 + LMIN=0 + DO 41 I=1,NOLD + IF(((K(I,1).EQ.1).OR.(K(I,1).EQ.3).OR.(K(I,1) + & .EQ.4).OR.(K(I,1).EQ.5)) + & .AND.((K(I,2).EQ.21).OR.((K(I,2)*K(LEND,2).LT.0.d0).AND. + & (K(I,3).NE.K(LEND,3)))) + & .AND.(P(I,1)*P(LEND,1).GT.0.d0))THEN + MINV=P(I,4)*P(LMAX,4)-P(I,1)*P(LMAX,1)-P(I,2)*P(LMAX,2) + & -P(I,3)*P(LMAX,3) + IF((MINV.LT.MMIN).AND.(MINV.GT.0.d0).AND.(MINV.LT.MCUT))THEN + MMIN=MINV + LMIN=I + ENDIF + ENDIF + 41 CONTINUE +C--if no closest partner can be found, generate artificial end point for string + IF(LMIN.EQ.0)THEN + N=N+1 + IF(N.GT.22990) THEN + write(logfid,*)'event too long for event record' + DISCARD=.TRUE. + RETURN + ENDIF + K(N,1)=1 + K(N,2)=-K(LEND,2) + K(N,3)=0 + K(N,4)=0 + K(N,5)=0 + P(N,1)=0.d0 + P(N,2)=0.d0 + IF(PYR(0).LT.0.5)THEN + DIR=1.d0 + ELSE + DIR=-1.d0 + ENDIF + P(N,3)=DIR*EADDEND + P(N,4)=EADDEND + P(N,5)=0.d0 + GOTO 43 + ELSE +C--else build closest partner in string + N=N+1 + IF(N.GT.22990) THEN + write(logfid,*)'event too long for event record' + DISCARD=.TRUE. + RETURN + ENDIF + K(N,2)=K(LMIN,2) + K(N,3)=LMIN + K(N,4)=0 + K(N,5)=0 + P(N,1)=P(LMIN,1) + P(N,2)=P(LMIN,2) + P(N,3)=P(LMIN,3) + P(N,4)=P(LMIN,4) + P(N,5)=P(LMIN,5) + K(LMIN,1)=16 + K(LMIN,4)=N + K(LMIN,5)=N + IF(K(LMIN,2).EQ.21)THEN + K(N,1)=2 + LMAX=LMIN + GOTO 42 + ELSE + K(N,1)=1 + GOTO 43 + ENDIF + ENDIF + 50 CONTINUE + CALL CLEANUP(NOLD) + END + + +*********************************************************************** +*** subroutine cleanup +*********************************************************************** + SUBROUTINE CLEANUP(NFIRST) + IMPLICIT NONE +C--Common block of Pythia + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + INTEGER N,NPAD,K + DOUBLE PRECISION P,V +C--local variables + INTEGER NFIRST,NLAST,I,J + + NLAST=N + DO 21 I=1,NLAST-NFIRST + DO 22 J=1,5 + K(I,J)=K(NFIRST+I,J) + P(I,J)=P(NFIRST+I,J) + V(I,J)=V(NFIRST+I,J) + 22 CONTINUE + K(I,3)=0 + 21 CONTINUE + N=NLAST-NFIRST + END + + +*********************************************************************** +*** subroutine makecascade +*********************************************************************** + SUBROUTINE MAKECASCADE + IMPLICIT NONE +C--Common block of Pythia + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + INTEGER N,NPAD,K + DOUBLE PRECISION P,V +C--time common block + COMMON/TIME/MV(23000,5) + DOUBLE PRECISION MV +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--discard event flag + COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD + LOGICAL DISCARD + INTEGER NDISC,NSTRANGE,NGOOD,errcount + double precision wdisc + +C--local variables + INTEGER NOLD,I + LOGICAL CONT + + 10 NOLD=N + CONT=.FALSE. + DO 11 I=2,NOLD + if (i.gt.n) goto 10 +C--check if parton may evolve, i.e. do splitting or scattering + IF((K(I,1).EQ.1).OR.(K(I,1).EQ.2))THEN + CONT=.TRUE. + CALL MAKEBRANCH(I) + IF(DISCARD) GOTO 12 + ENDIF + 11 CONTINUE + IF(CONT) GOTO 10 + 12 END + + +*********************************************************************** +*** subroutine makebranch +*********************************************************************** + SUBROUTINE MAKEBRANCH(L) + IMPLICIT NONE +C--Common block of Pythia + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + INTEGER N,NPAD,K + DOUBLE PRECISION P,V +C--time common block + COMMON/TIME/MV(23000,5) + DOUBLE PRECISION MV +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--discard event flag + COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD + LOGICAL DISCARD + INTEGER NDISC,NSTRANGE,NGOOD,errcount + double precision wdisc +C--variables for angular ordering + COMMON/ANGOR/ZA(23000),ZD(23000),THETAA(23000),QQBARD(23000) + DOUBLE PRECISION ZA,ZD,THETAA + LOGICAL QQBARD +C--number of scattering events + COMMON/CHECK/NSCAT,NSCATEFF,NSPLIT + DOUBLE PRECISION NSCAT,NSCATEFF,NSPLIT +C--variables for coherent scattering + COMMON/COHERENT/NSTART,NEND,ALLQS(10000,6),SCATCENTRES(10000,10), + &QSUMVEC(4),QSUM2 + INTEGER NSTART,NEND + DOUBLE PRECISION ALLQS,SCATCENTRES,QSUMVEC,QSUM2 +C--event weight + COMMON/WEIGHT/EVWEIGHT,sumofweights + double precision EVWEIGHT,sumofweights +C--identifier of file for hepmc output and logfile + common/hepmcid/hpmcfid,logfid + integer hpmcfid,logfid +C--extra storage for scattering centres before interactions + common/storescatcen/nscatcen,maxnscatcen,scatflav(10000), + & scatcen(10000,5),writescatcen,writedummies + integer nscatcen,maxnscatcen,scatflav + double precision scatcen + logical writescatcen,writedummies +C--local variables + INTEGER L,LINE,NOLD,TYPI,LINEOLD,LKINE,nendold,nscatcenold + DOUBLE PRECISION THETA,PHI,PYP,FORMTIME,STARTTIME,TLEFT, + &TSUM,DELTAT,NEWMASS,GETMASS,Q,GETMS,ZDEC,X,DTCORR + LOGICAL OVERQ0,QQBARDEC + CHARACTER TYP + LOGICAL RADIATION,RETRYSPLIT,MEDIND,roomleft,compressevent + + LINE=L + NSTART=0 + NEND=0 + STARTTIME=MV(LINE,4) + TSUM=0.d0 + QSUM2=0.d0 + QSUMVEC(1)=0.d0 + QSUMVEC(2)=0.d0 + QSUMVEC(3)=0.d0 + QSUMVEC(4)=0.d0 + RETRYSPLIT=.FALSE. + MEDIND=.FALSE. + X=0.d0 + Q=0.d0 + TYPI=0 + + IF ((N.GT.20000).and.compress) roomleft = compressevent(line) + +20 IF(DISCARD) RETURN + IF(((K(LINE,1).EQ.1).AND.(P(LINE,5).GT.0.d0)) + & .OR.((K(LINE,1).EQ.2).AND.(zd(line).gt.0.d0)))THEN + IF(MEDIND)THEN + FORMTIME=starttime + ELSE + FORMTIME=MIN(MV(LINE,5),LTIME) + ENDIF + RADIATION=.TRUE. + ELSE + FORMTIME=LTIME + RADIATION=.FALSE. + ENDIF + TLEFT=FORMTIME-STARTTIME + IF(K(LINE,2).EQ.21)THEN + TYP='G' + ELSE + TYP='Q' + ENDIF + MEDIND=.FALSE. + + IF(TLEFT.LE.1.d-10)THEN +C--no scattering + IF(RADIATION)THEN +C--if there is radiation associated with the parton then form it now +C--rotate such that momentum points in z-direction + NOLD=N + nscatcenold=nscatcen + THETA=PYP(LINE,13) + PHI=PYP(LINE,15) + CALL PYROBO(LINE,LINE,0d0,-PHI,0d0,0d0,0d0) + CALL PYROBO(LINE,LINE,-THETA,0d0,0d0,0d0,0d0) + CALL MAKESPLITTING(LINE) +C--rotate back + CALL PYROBO(LINE,LINE,THETA,0d0,0d0,0d0,0d0) + CALL PYROBO(LINE,LINE,0d0,PHI,0d0,0d0,0d0) + IF(DISCARD) RETURN + CALL PYROBO(N-1,N,THETA,0d0,0d0,0d0,0d0) + CALL PYROBO(N-1,N,0d0,PHI,0d0,0d0,0d0) +C--set the production vertices: x_mother + (tprod - tprod_mother) * beta_mother + MV(N-1,1)=MV(LINE,1) + & +(MV(N-1,4)-MV(LINE,4))*P(LINE,1)/max(pyp(line,8),P(LINE,4)) + MV(N-1,2)=MV(LINE,2) + & +(MV(N-1,4)-MV(LINE,4))*P(LINE,2)/max(pyp(line,8),P(LINE,4)) + MV(N-1,3)=MV(LINE,3) + & +(MV(N-1,4)-MV(LINE,4))*P(LINE,3)/max(pyp(line,8),P(LINE,4)) + MV(N, 1)=MV(LINE,1) + & +(MV(N, 4)-MV(LINE,4))*P(LINE,1)/max(pyp(line,8),P(LINE,4)) + MV(N, 2)=MV(LINE,2) + & +(MV(N, 4)-MV(LINE,4))*P(LINE,2)/max(pyp(line,8),P(LINE,4)) + MV(N, 3)=MV(LINE,3) + & +(MV(N, 4)-MV(LINE,4))*P(LINE,3)/max(pyp(line,8),P(LINE,4)) + + LINE=N + NSTART=0 + NEND=0 + STARTTIME=MV(N,4) + QSUMVEC(1)=0.d0 + QSUMVEC(2)=0.d0 + QSUMVEC(3)=0.d0 + QSUMVEC(4)=0.d0 + QSUM2=0.d0 + TSUM=0.d0 + GOTO 21 + ELSE + NSTART=0 + NEND=0 + STARTTIME=FORMTIME + QSUMVEC(1)=0.d0 + QSUMVEC(2)=0.d0 + QSUMVEC(3)=0.d0 + QSUMVEC(4)=0.d0 + QSUM2=0.d0 + TSUM=0.d0 + GOTO 21 + ENDIF + ELSE +C--do scattering +C--find delta t for the scattering + DELTAT=TLEFT + OVERQ0=.FALSE. + CALL DOINSTATESCAT(LINE,X,TYPI,Q,STARTTIME+TSUM,DELTAT, + & OVERQ0,.FALSE.) + TSUM=TSUM+DELTAT + TLEFT=TLEFT-DELTAT +C--do initial state splitting if there is one + NOLD=N + LINEOLD=LINE + ZDEC=ZD(LINE) + QQBARDEC=QQBARD(LINE) + nscatcenold=nscatcen + 25 IF(X.LT.1.d0) THEN + CALL MAKEINSPLIT(LINE,X,QSUM2,Q,TYPI,STARTTIME+TSUM,DELTAT) + IF(DISCARD) RETURN + IF(X.LT.1.d0)THEN + LINE=N + LKINE=N + IF(K(LINE,2).EQ.21)THEN + NEWMASS=GETMASS(0.d0,SCALEFACM*SQRT(-QSUM2),-1.d0,P(LINE,4), + & 'GC',SQRT(-QSUM2),.FALSE.,ZDEC,QQBARDEC) + IF(ZDEC.GT.0.d0)THEN + THETAA(LINE)=NEWMASS/(SQRT(ZDEC*(1.-ZDEC))*P(LINE,4)) + ELSE + THETAA(LINE)=0.d0 + ENDIF + ZD(LINE)=ZDEC + QQBARD(LINE)=QQBARDEC + ELSE + NEWMASS=GETMASS(0.d0,SCALEFACM*SQRT(-QSUM2),-1.d0,P(LINE,4), + & 'QQ',SQRT(-QSUM2),.FALSE.,ZDEC,QQBARDEC) + IF(ZDEC.GT.0.d0)THEN + THETAA(LINE)=NEWMASS/(SQRT(ZDEC*(1.-ZDEC))*P(LINE,4)) + ELSE + THETAA(LINE)=0.d0 + ENDIF + ZD(LINE)=ZDEC + QQBARD(LINE)=QQBARDEC + ENDIF + ZDEC=ZD(LINE) + QQBARDEC=QQBARD(LINE) + ELSE + LKINE=LINE + NEND=NSTART + QSUM2=ALLQS(NEND,1) + QSUMVEC(1)=ALLQS(NEND,2) + QSUMVEC(2)=ALLQS(NEND,3) + QSUMVEC(3)=ALLQS(NEND,4) + QSUMVEC(4)=ALLQS(NEND,5) + IF(-ALLQS(NEND,1).GT.Q0**2/SCALEFACM**2)THEN + OVERQ0=.TRUE. + ELSE + OVERQ0=.FALSE. + ENDIF + tleft = starttime+tsum+tleft-allqs(1,6) + tsum = allqs(1,6)-starttime + ENDIF + ENDIF + IF(X.EQ.1.d0)THEN + NEWMASS=0.d0 + IF(NEND.GT.0)THEN + CALL DOFISTATESCAT(LINE,STARTTIME+TSUM,TLEFT,DELTAT, + & NEWMASS,OVERQ0,ZDEC,QQBARDEC) + IF(NEWMASS.GT.(P(LINE,5)*(1.d0+1.d-6)))THEN + MEDIND=.TRUE. + ELSE + MEDIND=.FALSE. + ZDEC=ZD(LINE) + QQBARDEC=QQBARD(LINE) + ENDIF + TSUM=TSUM+DELTAT + TLEFT=TLEFT-DELTAT + LKINE=LINE + ENDIF + ENDIF +C--do kinematics + RETRYSPLIT=.FALSE. + IF(NEND.GT.0) THEN + nendold=nend + CALL DOKINEMATICS(LKINE,lineold,NSTART,NEND,NEWMASS,RETRYSPLIT, + & STARTTIME+TSUM,X,ZDEC,QQBARDEC) + IF(RETRYSPLIT) THEN + tleft = starttime+tsum+tleft-allqs(1,6) + tsum = allqs(1,6)-starttime + if (x.lt.1.d0) then + NEND=NSTART + QSUM2=ALLQS(NEND,1) + QSUMVEC(1)=ALLQS(NEND,2) + QSUMVEC(2)=ALLQS(NEND,3) + QSUMVEC(3)=ALLQS(NEND,4) + QSUMVEC(4)=ALLQS(NEND,5) + TYPI=K(L,2) + IF(-ALLQS(NEND,1).GT.Q0**2/SCALEFACM**2)THEN + OVERQ0=.TRUE. + ELSE + OVERQ0=.FALSE. + ENDIF + N=NOLD + LINE=LINEOLD + X=1.d0 + K(LINE,1)=1 + nscatcen=nscatcenold + NSPLIT=NSPLIT-EVWEIGHT + GOTO 25 + else + LINE=N + STARTTIME=STARTTIME+TSUM + TSUM=0.d0 + endif + ELSE + LINE=N + STARTTIME=STARTTIME+TSUM + TSUM=0.d0 + ENDIF + ELSE + STARTTIME=STARTTIME+TSUM + TSUM=0.d0 + ENDIF + IF(P(LINE,5).GT.0.d0) RADIATION=.TRUE. + ENDIF + + 21 IF(((K(LINE,1).EQ.1).AND.(P(LINE,5).GT.0.d0)) + & .OR.((K(LINE,1).EQ.2).AND.(zd(line).gt.0.d0)) + & .OR.(STARTTIME.LT.LTIME))THEN + GOTO 20 + ENDIF + IF((K(LINE,1).EQ.1).AND.(P(LINE,5).EQ.0.d0)) K(LINE,1)=4 + IF((K(LINE,1).EQ.2).AND.(zd(line).lt.0.d0)) K(LINE,1)=5 + END + + + +*********************************************************************** +*** subroutine makesplitting +*********************************************************************** + SUBROUTINE MAKESPLITTING(L) + IMPLICIT NONE +C--identifier of file for hepmc output and logfile + common/hepmcid/hpmcfid,logfid + integer hpmcfid,logfid +C--Common block of Pythia + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + INTEGER N,NPAD,K + DOUBLE PRECISION P,V +C--time common block + COMMON/TIME/MV(23000,5) + DOUBLE PRECISION MV +C--factor in front of formation times + COMMON/FTIMEFAC/FTFAC + DOUBLE PRECISION FTFAC +C--colour index common block + COMMON/COLOUR/TRIP(23000),ANTI(23000),COLMAX + INTEGER TRIP,ANTI,COLMAX +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--discard event flag + COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD + LOGICAL DISCARD + INTEGER NDISC,NSTRANGE,NGOOD,errcount + double precision wdisc +C--variables for angular ordering + COMMON/ANGOR/ZA(23000),ZD(23000),THETAA(23000),QQBARD(23000) + DOUBLE PRECISION ZA,ZD,THETAA + LOGICAL QQBARD +C--number of scattering events + COMMON/CHECK/NSCAT,NSCATEFF,NSPLIT + DOUBLE PRECISION NSCAT,NSCATEFF,NSPLIT +C--event weight + COMMON/WEIGHT/EVWEIGHT,sumofweights + double precision EVWEIGHT,sumofweights + +C--local variables + INTEGER L,DIR + DOUBLE PRECISION PHIQ,PYR,PI,GENERATEZ,BMAX1,CMAX1,PTS,MB,MC, + &GETMASS,PZ,EPS,QH,Z,R,LAMBDA,WEIGHT,ZDECB,ZDECC,XDEC(3),THETA, + &GETTEMP + LOGICAL QUARK,QQBAR,QQBARDECB,QQBARDECC + integer bin + DATA PI/3.141592653589793d0/ + + IF((N+2).GT.22990) THEN + write(logfid,*)'event too long for event record' + DISCARD=.TRUE. + RETURN + ENDIF + + XDEC(1)=MV(L,1)+(MV(L,5)-MV(L,4))*P(L,1)/P(L,4) + XDEC(2)=MV(L,2)+(MV(L,5)-MV(L,4))*P(L,2)/P(L,4) + XDEC(3)=MV(L,3)+(MV(L,5)-MV(L,4))*P(L,3)/P(L,4) + IF(GETTEMP(XDEC(1),XDEC(2),XDEC(3),MV(L,5)).GT.0.d0)THEN + THETA=-1.d0 + ELSE + THETA=THETAA(L) + ENDIF + +C--on-shell partons cannot split + IF((P(L,5).EQ.0d0).OR.(K(L,1).EQ.11).OR.(K(L,1).EQ.12) + & .OR.(K(L,1).EQ.13).OR.(K(L,1).EQ.14).OR.(K(L,1).EQ.3) + & .or.(zd(l).lt.0.d0)) GOTO 31 +C--quark or gluon? + IF(K(L,2).EQ.21)THEN + QUARK=.FALSE. + ELSE + QUARK=.TRUE. + QQBAR=.FALSE. + ENDIF +C--if gluon decide on kind of splitting + QQBAR=QQBARD(L) +C--if g->gg splitting decide on colour order + IF(QUARK.OR.QQBAR)THEN + DIR=0 + ELSE + IF(PYR(0).LT.0.5)THEN + DIR=1 + ELSE + DIR=-1 + ENDIF + ENDIF + Z=ZD(L) + IF(Z.EQ.0.d0)THEN + write(logfid,*)'makesplitting: z=0',L + goto 36 + ENDIF + GOTO 35 +C--generate z value + 36 IF(ANGORD.AND.(ZA(L).NE.1.d0))THEN +C--additional z constraint due to angular ordering + QH=4.*P(L,5)**2*(1.-ZA(L))/(ZA(L)*P(K(L,3),5)**2) + IF(QH.GT.1)THEN + write(logfid,*)L,': reject event: angular ordering + & conflict in medium' + CALL PYLIST(3) + DISCARD=.TRUE. + GOTO 31 + ENDIF + EPS=0.5-0.5*SQRT(1.-QH) + ELSE + EPS=0d0 + ENDIF + IF(QUARK)THEN + Z=GENERATEZ(P(L,5)**2,P(L,4),EPS,'QQ') + ELSE + IF(QQBAR)THEN + Z=GENERATEZ(P(L,5)**2,P(L,4),EPS,'QG') + ELSE + Z=GENERATEZ(P(L,5)**2,P(L,4),EPS,'GG') + ENDIF + ENDIF + 35 CONTINUE +C--maximum virtualities for daughters + BMAX1=MIN(P(L,5),Z*P(L,4)) + CMAX1=MIN(P(L,5),(1.-Z)*P(L,4)) +C--generate mass of quark or gluon (particle b) from Sudakov FF + 30 IF(QUARK.OR.QQBAR)THEN + MB=GETMASS(0.d0,BMAX1,THETA,Z*P(L,4),'QQ', + & BMAX1,.FALSE.,ZDECB,QQBARDECB) + ELSE + MB=GETMASS(0.d0,BMAX1,THETA,Z*P(L,4),'GC', + & BMAX1,.FALSE.,ZDECB,QQBARDECB) + ENDIF +C--generate mass gluon (particle c) from Sudakov FF + IF(QUARK.OR.(.NOT.QQBAR))THEN + MC=GETMASS(0.d0,CMAX1,THETA,(1.-Z)*P(L,4),'GC', + & CMAX1,.FALSE.,ZDECC,QQBARDECC) + ELSE + MC=GETMASS(0.d0,CMAX1,THETA,(1.-Z)*P(L,4),'QQ', + & CMAX1,.FALSE.,ZDECC,QQBARDECC) + ENDIF +C--quark (parton b) momentum + 182 PZ=(2.*Z*P(L,4)**2-P(L,5)**2-MB**2+MC**2)/(2.*P(L,3)) + PTS=Z**2*(P(L,4)**2)-PZ**2-MB**2 +C--if kinematics doesn't work out, generate new virtualities +C for daughters +C--massive phase space weight + IF((MB.EQ.0.d0).AND.(MC.EQ.0.d0).AND.(PTS.LT.0.d0)) GOTO 36 + WEIGHT=1.d0 + IF((PYR(0).GT.WEIGHT).OR.(PTS.LT.0.d0) + & .OR.((MB+MC).GT.P(L,5)))THEN + IF(MB.GT.MC)THEN + IF(QUARK.OR.QQBAR)THEN + MB=GETMASS(0.d0,MB,THETA,Z*P(L,4),'QQ', + & BMAX1,.FALSE.,ZDECB,QQBARDECB) + ELSE + MB=GETMASS(0.d0,MB,THETA,Z*P(L,4),'GC', + & BMAX1,.FALSE.,ZDECB,QQBARDECB) + ENDIF + ELSE + IF(QUARK.OR.(.NOT.QQBAR))THEN + MC=GETMASS(0.d0,MC,THETA,(1.-Z)*P(L,4),'GC', + & CMAX1,.FALSE.,ZDECC,QQBARDECC) + ELSE + MC=GETMASS(0.d0,MC,THETA,(1.-Z)*P(L,4),'QQ', + & CMAX1,.FALSE.,ZDECC,QQBARDECC) + ENDIF + ENDIF + GOTO 182 + ENDIF + N=N+2 +C--take care of first daughter (radiated gluon or antiquark) + K(N-1,1)=K(L,1) + IF(QQBAR)THEN + K(N-1,2)=-1 + TRIP(N-1)=0 + ANTI(N-1)=ANTI(L) + ELSE + K(N-1,2)=21 + IF((K(L,2).GT.0).AND.(DIR.GE.0))THEN + TRIP(N-1)=TRIP(L) + ANTI(N-1)=COLMAX+1 + ELSE + TRIP(N-1)=COLMAX+1 + ANTI(N-1)=ANTI(L) + ENDIF + COLMAX=COLMAX+1 + ENDIF + K(N-1,3)=L + K(N-1,4)=0 + K(N-1,5)=0 + P(N-1,4)=(1-Z)*P(L,4) + P(N-1,5)=MC + ZA(N-1)=1.-Z + IF(ZDECC.GT.0.d0)THEN + THETAA(N-1)=P(N-1,5)/(SQRT(ZDECC*(1.-ZDECC))*P(N-1,4)) + ELSE + THETAA(N-1)=0.d0 + ENDIF + ZD(N-1)=ZDECC + QQBARD(N-1)=QQBARDECC +C--take care of second daughter (final quark or gluon or quark from +C gluon splitting) + K(N,1)=K(L,1) + IF(QUARK)THEN + K(N,2)=K(L,2) + IF(K(N,2).GT.0)THEN + TRIP(N)=ANTI(N-1) + ANTI(N)=0 + ELSE + TRIP(N)=0 + ANTI(N)=TRIP(N-1) + ENDIF + ELSEIF(QQBAR)THEN + K(N,2)=1 + TRIP(N)=TRIP(L) + ANTI(N)=0 + ELSE + K(N,2)=21 + IF(DIR.EQ.1)THEN + TRIP(N)=ANTI(N-1) + ANTI(N)=ANTI(L) + ELSE + TRIP(N)=TRIP(L) + ANTI(N)=TRIP(N-1) + ENDIF + ENDIF + K(N,3)=L + K(N,4)=0 + K(N,5)=0 + P(N,3)=PZ + P(N,4)=Z*P(L,4) + P(N,5)=MB + ZA(N)=Z + IF(ZDECB.GT.0.d0)THEN + THETAA(N)=P(N,5)/(SQRT(ZDECB*(1.-ZDECB))*P(N,4)) + ELSE + THETAA(N)=0.d0 + ENDIF + ZD(N)=ZDECB + QQBARD(N)=QQBARDECB +C--azimuthal angle + PHIQ=2*PI*PYR(0) + P(N,1)=SQRT(PTS)*COS(PHIQ) + P(N,2)=SQRT(PTS)*SIN(PHIQ) +C--gluon momentum + P(N-1,1)=P(L,1)-P(N,1) + P(N-1,2)=P(L,2)-P(N,2) + P(N-1,3)=P(L,3)-P(N,3) + MV(N-1,4)=MV(L,5) + IF(P(N-1,5).GT.0.d0)THEN + LAMBDA=1.d0/(FTFAC*P(N-1,4)*0.2/P(N-1,5)**2) + MV(N-1,5)=MV(L,5)-LOG(1.d0-PYR(0))/LAMBDA + ELSE + MV(N-1,5)=0.d0 + ENDIF + MV(N,4)=MV(L,5) + IF(P(N,5).GT.0.d0)THEN + LAMBDA=1.d0/(FTFAC*P(N,4)*0.2/P(N,5)**2) + MV(N,5)=MV(L,5)-LOG(1.d0-PYR(0))/LAMBDA + ELSE + MV(N,5)=0.d0 + ENDIF +C--take care of initial quark (or gluon) + IF(K(L,1).EQ.2)THEN + K(L,1)=13 + ELSE + K(L,1)=11 + ENDIF + K(L,4)=N-1 + K(L,5)=N + NSPLIT=NSPLIT+EVWEIGHT + 31 CONTINUE + END + + +*********************************************************************** +*** subroutine makeinsplit +*********************************************************************** + SUBROUTINE MAKEINSPLIT(L,X,TSUM,VIRT,TYPI,TIME,TAURAD) + IMPLICIT NONE +C--identifier of file for hepmc output and logfile + common/hepmcid/hpmcfid,logfid + integer hpmcfid,logfid +C--Common block of Pythia + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + INTEGER N,NPAD,K + DOUBLE PRECISION P,V +C--time common block + COMMON/TIME/MV(23000,5) + DOUBLE PRECISION MV +C--factor in front of formation times + COMMON/FTIMEFAC/FTFAC + DOUBLE PRECISION FTFAC +C--colour index common block + COMMON/COLOUR/TRIP(23000),ANTI(23000),COLMAX + INTEGER TRIP,ANTI,COLMAX +C--variables for angular ordering + COMMON/ANGOR/ZA(23000),ZD(23000),THETAA(23000),QQBARD(23000) + DOUBLE PRECISION ZA,ZD,THETAA + LOGICAL QQBARD +C--discard event flag + COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD + LOGICAL DISCARD + INTEGER NDISC,NSTRANGE,NGOOD,errcount + double precision wdisc +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--number of scattering events + COMMON/CHECK/NSCAT,NSCATEFF,NSPLIT + DOUBLE PRECISION NSCAT,NSCATEFF,NSPLIT +C--event weight + COMMON/WEIGHT/EVWEIGHT,sumofweights + double precision EVWEIGHT,sumofweights + +C--local variables + INTEGER L,TYPI,NOLD,DIR + DOUBLE PRECISION X,VIRT,MB2,MC2,GETMASS,PZ,KT2,THETA,PHI,PI, + &PHIQ,PYP,PYR,R,TIME,TSUM,TAURAD,LAMBDA,ZDEC + LOGICAL QQBARDEC + CHARACTER*2 TYP2,TYPC + integer bin + DATA PI/3.141592653589793d0/ + + IF((N+2).GT.22990) THEN + write(logfid,*)'event too long for event record' + DISCARD=.TRUE. + RETURN + ENDIF + + IF(K(L,2).EQ.21)THEN + IF(TYPI.EQ.21)THEN + TYP2='GG' + TYPC='GC' + ELSE + TYP2='QG' + TYPC='QQ' + ENDIF + ELSE + IF(TYPI.EQ.21)THEN + TYP2='GQ' + TYPC='QQ' + ELSE + TYP2='QQ' + TYPC='GC' + ENDIF + ENDIF + +C--if g->gg decide on colour configuration + IF(TYP2.EQ.'GG')THEN + IF(PYR(0).LT.0.5)THEN + DIR=1 + ELSE + DIR=-1 + ENDIF + ELSE + DIR=0 + ENDIF + + MB2=VIRT**2 + MB2=P(L,5)**2-MB2 + MC2=GETMASS(0.d0,SCALEFACM*SQRT(-TSUM),-1.d0, + & (1.-X)*P(L,4),TYPC,(1.-X)*P(L,4), + & .FALSE.,ZDEC,QQBARDEC)**2 + +C--rotate such that momentum points in z-direction + NOLD=N + THETA=PYP(L,13) + PHI=PYP(L,15) + CALL PYROBO(L,L,0d0,-PHI,0d0,0d0,0d0) + CALL PYROBO(L,L,-THETA,0d0,0d0,0d0,0d0) + PZ=(2*X*P(L,4)**2-P(L,5)**2-MB2+MC2)/(2*P(L,3)) + KT2=X**2*(P(L,4)**2)-PZ**2-MB2 + IF(KT2.LT.0.d0)THEN + MC2=0.d0 + PZ=(2*X*P(L,4)**2-P(L,5)**2-MB2+MC2)/(2*P(L,3)) + KT2=X**2*(P(L,4)**2)-PZ**2-MB2 + IF(KT2.LT.0.d0)THEN + CALL PYROBO(L,L,THETA,0d0,0d0,0d0,0d0) + CALL PYROBO(L,L,0d0,PHI,0d0,0d0,0d0) + X=1.d0 + RETURN + ENDIF + ENDIF + N=N+2 +C--take care of first daughter (radiated gluon or antiquark) + K(N-1,1)=K(L,1) + IF(TYP2.EQ.'QG')THEN + K(N-1,2)=-TYPI + IF(K(N-1,2).GT.0)THEN + TRIP(N-1)=TRIP(L) + ANTI(N-1)=0 + ELSE + TRIP(N-1)=0 + ANTI(N-1)=ANTI(L) + ENDIF + ELSEIF(TYP2.EQ.'GQ')THEN + K(N-1,2)=K(L,2) + IF(K(N-1,2).GT.0)THEN + TRIP(N-1)=COLMAX+1 + ANTI(N-1)=0 + ELSE + TRIP(N-1)=0 + ANTI(N-1)=COLMAX+1 + ENDIF + COLMAX=COLMAX+1 + ELSE + K(N-1,2)=21 + IF((K(L,2).GT.0).AND.(DIR.GE.0))THEN + TRIP(N-1)=TRIP(L) + ANTI(N-1)=COLMAX+1 + ELSE + TRIP(N-1)=COLMAX+1 + ANTI(N-1)=ANTI(L) + ENDIF + COLMAX=COLMAX+1 + ENDIF + K(N-1,3)=L + K(N-1,4)=0 + K(N-1,5)=0 + P(N-1,4)=(1.-X)*P(L,4) + P(N-1,5)=SQRT(MC2) +C--take care of second daughter (final quark or gluon or quark from +C gluon splitting) + K(N,1)=K(L,1) + IF(TYP2.EQ.'QG')THEN + K(N,2)=TYPI + IF(K(N,2).GT.0)THEN + TRIP(N)=TRIP(L) + ANTI(N)=0 + ELSE + TRIP(N)=0 + ANTI(N)=ANTI(L) + ENDIF + ELSEIF(TYPI.NE.21)THEN + K(N,2)=K(L,2) + IF(K(N,2).GT.0)THEN + TRIP(N)=ANTI(N-1) + ANTI(N)=0 + ELSE + TRIP(N)=0 + ANTI(N)=TRIP(N-1) + ENDIF + ELSE + K(N,2)=21 + IF(K(N-1,2).EQ.21)THEN + IF(DIR.EQ.1)THEN + TRIP(N)=ANTI(N-1) + ANTI(N)=ANTI(L) + ELSE + TRIP(N)=TRIP(L) + ANTI(N)=TRIP(N-1) + ENDIF + ELSEIF(K(N-1,2).GT.0)THEN + TRIP(N)=TRIP(L) + ANTI(N)=TRIP(N-1) + ELSE + TRIP(N)=ANTI(N-1) + ANTI(N)=ANTI(L) + ENDIF + ENDIF + K(N,3)=L + K(N,4)=0 + K(N,5)=0 + P(N,3)=PZ + P(N,4)=X*P(L,4) + IF(MB2.LT.0.d0)THEN + P(N,5)=-SQRT(-MB2) + ELSE + P(N,5)=SQRT(MB2) + ENDIF +C--azimuthal angle + PHIQ=2*PI*PYR(0) + P(N,1)=SQRT(KT2)*COS(PHIQ) + P(N,2)=SQRT(KT2)*SIN(PHIQ) +C--gluon momentum + P(N-1,1)=P(L,1)-P(N,1) + P(N-1,2)=P(L,2)-P(N,2) + P(N-1,3)=P(L,3)-P(N,3) + MV(L,5)=TIME-TAURAD + MV(N-1,4)=MV(L,5) + IF(P(N-1,5).GT.0.d0)THEN + LAMBDA=1.d0/(FTFAC*P(N-1,4)*0.2/P(N-1,5)**2) + MV(N-1,5)=MV(L,5)-LOG(1.d0-PYR(0))/LAMBDA + ELSE + MV(N-1,5)=0.d0 + ENDIF + MV(N,4)=MV(L,5) + IF(P(N,5).GT.0.d0)THEN + MV(N,5)=TIME + ELSE + MV(N,5)=0.d0 + ENDIF + ZA(N-1)=1.d0 + THETAA(N-1)=-1.d0 + ZD(N-1)=ZDEC + QQBARD(N-1)=QQBARDEC + ZA(N)=1.d0 + THETAA(N)=-1.d0 + ZD(N)=0.d0 + QQBARD(N)=.FALSE. +C--take care of initial quark (or gluon) + IF(K(L,1).EQ.2)THEN + K(L,1)=13 + ELSE + K(L,1)=11 + ENDIF + K(L,4)=N-1 + K(L,5)=N + NSPLIT=NSPLIT+EVWEIGHT + CALL PYROBO(L,L,THETA,0d0,0d0,0d0,0d0) + CALL PYROBO(N-1,N,THETA,0d0,0d0,0d0,0d0) + CALL PYROBO(L,L,0d0,PHI,0d0,0d0,0d0) + CALL PYROBO(N-1,N,0d0,PHI,0d0,0d0,0d0) + +C--set the production vertices: x_mother + (tprod - tprod_mother) * beta_mother + MV(N-1,1)=MV(L,1)+(MV(N-1,4)-MV(L,4))*P(L,1)/max(pyp(l,8),P(L,4)) + MV(N-1,2)=MV(L,2)+(MV(N-1,4)-MV(L,4))*P(L,2)/max(pyp(l,8),P(L,4)) + MV(N-1,3)=MV(L,3)+(MV(N-1,4)-MV(L,4))*P(L,3)/max(pyp(l,8),P(L,4)) + MV(N, 1)=MV(L,1)+(MV(N, 4)-MV(L,4))*P(L,1)/max(pyp(l,8),P(L,4)) + MV(N, 2)=MV(L,2)+(MV(N, 4)-MV(L,4))*P(L,2)/max(pyp(l,8),P(L,4)) + MV(N, 3)=MV(L,3)+(MV(N, 4)-MV(L,4))*P(L,3)/max(pyp(l,8),P(L,4)) + + END + + +*********************************************************************** +*** subroutine doinstatescat +*********************************************************************** + SUBROUTINE DOINSTATESCAT(L,X,TYPI,Q,TSTART,DELTAT,OVERQ0, + & RETRYSPLIT) + IMPLICIT NONE +C--Common block of Pythia + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + INTEGER N,NPAD,K + DOUBLE PRECISION P,V +C--time common block + COMMON/TIME/MV(23000,5) + DOUBLE PRECISION MV +C--factor in front of formation times + COMMON/FTIMEFAC/FTFAC + DOUBLE PRECISION FTFAC +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--discard event flag + COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD + LOGICAL DISCARD + INTEGER NDISC,NSTRANGE,NGOOD,errcount + double precision wdisc +C--variables for coherent scattering + COMMON/COHERENT/NSTART,NEND,ALLQS(10000,6),SCATCENTRES(10000,10), + &QSUMVEC(4),QSUM2 + INTEGER NSTART,NEND + DOUBLE PRECISION ALLQS,SCATCENTRES,QSUMVEC,QSUM2 +C--identifier of file for hepmc output and logfile + common/hepmcid/hpmcfid,logfid + integer hpmcfid,logfid +C--local variables + INTEGER L,TYPI,COUNTER,COUNTMAX,COUNT2 + DOUBLE PRECISION X,DELTAT,DELTAL,PYR,R,PNORAD,GETPNORAD1,GETNOSCAT, + &WEIGHT,LOW,FMAX,GETPDF,SIGMATOT,GETSSCAT,PFCHANGE,PI,TNOW,TLEFT, + &XMAX,PQQ,PQG,PGQ,PGG,ALPHAS,TSTART,TSUM,Q,QOLD,Q2OLD,GETNEWMASS, + &GENERATEZ,TMAX,TMAXNEW,DT,XSC,YSC,ZSC,TSC,MS1,MD1,GETMS,GETMD, + &GETTEMP,GETNEFF,LAMBDA,RTAU,PHI,TAUEST,QSUMVECOLD(4),ZDUM,WEIGHT, + &pyp + LOGICAL FCHANGE,NORAD,OVERQ0,NOSCAT,GETDELTAT,RETRYSPLIT, + &QQBARDUM + CHARACTER TYP + CHARACTER*2 TYP2 + DATA PI/3.141592653589793d0/ + DATA COUNTMAX/10000/ + + COUNTER=0 + + XSC=MV(L,1)+(TSTART-MV(L,4))*P(L,1)/P(L,4) + YSC=MV(L,2)+(TSTART-MV(L,4))*P(L,2)/P(L,4) + ZSC=MV(L,3)+(TSTART-MV(L,4))*P(L,3)/P(L,4) + TSC=TSTART + MD1=GETMD(XSC,YSC,ZSC,TSC) + MS1=GETMS(XSC,YSC,ZSC,TSC) + + IF(MD1.LE.1.D-4.OR.MS1.LE.1.D-4)THEN + write(logfid,*)'problem!',GETTEMP(XSC,YSC,ZSC,TSC), + &GETNEFF(XSC,YSC,ZSC,TSC) + ENDIF + +C--check for scattering + NOSCAT=.NOT.GETDELTAT(L,TSTART,DELTAT,DT) + IF(NOSCAT.AND.(.NOT.RETRYSPLIT)) GOTO 116 + +C--decide whether there will be radiation + PNORAD=GETPNORAD1(L,xsc,ysc,zsc,tsc) + IF((PYR(0).LT.PNORAD).OR.(P(L,4).LT.1.001*Q0))THEN + NORAD=.TRUE. + ELSE + NORAD=.FALSE. + ENDIF + +C--decide whether q or g is to be scattered + IF(K(L,2).EQ.21)THEN + TYP='G' + TYP2='GC' + SIGMATOT=GETSSCAT(P(L,4),p(l,1),p(l,2),p(l,3),P(L,5), + & Q0,'G','C',xsc,ysc,zsc,tsc,0) + IF((SIGMATOT.EQ.0.d0).OR.(PNORAD.EQ.1.d0))THEN + PFCHANGE=0.d0 + ELSE + PFCHANGE=GETSSCAT(P(L,4),p(l,1),p(l,2),p(l,3),P(L,5), + & Q0,'G','Q',xsc,ysc,zsc,tsc,0) + & /SIGMATOT + ENDIF + SIGMATOT=GETSSCAT(P(L,4),p(l,1),p(l,2),p(l,3),P(L,5), + & 0.d0,'G','C',xsc,ysc,zsc,tsc,0) + ELSE + TYP='Q' + TYP2='QQ' + SIGMATOT=GETSSCAT(P(L,4),p(l,1),p(l,2),p(l,3),P(L,5), + & Q0,'Q','C',xsc,ysc,zsc,tsc,0) + IF((SIGMATOT.EQ.0.d0).OR.(PNORAD.EQ.1.d0))THEN + PFCHANGE=0.d0 + ELSE + PFCHANGE=GETSSCAT(P(L,4),p(l,1),p(l,2),p(l,3),P(L,5), + & Q0,'Q','G',xsc,ysc,zsc,tsc,0) + & /SIGMATOT + ENDIF + SIGMATOT=GETSSCAT(P(L,4),p(l,1),p(l,2),p(l,3),P(L,5), + & 0.d0,'Q','C',xsc,ysc,zsc,tsc,0) + ENDIF + IF((PFCHANGE.LT.-1.d-4).OR.(PFCHANGE.GT.1.d0+1.d-4)) THEN + write(logfid,*)'error: flavour change probability=', + & PFCHANGE,'for ',TYP + ENDIF + IF(PYR(0).LT.PFCHANGE)THEN + FCHANGE=.TRUE. + ELSE + FCHANGE=.FALSE. + ENDIF + IF (NORAD) FCHANGE=.FALSE. +C--set TYPI + IF(TYP.EQ.'G')THEN + IF(FCHANGE)THEN + TYPI=INT(SIGN(2.d0,PYR(0)-0.5)) + ELSE + TYPI=K(L,2) + ENDIF + ELSE + IF(FCHANGE)THEN + TYPI=21 + ELSE + TYPI=K(L,2) + ENDIF + ENDIF + LOW=Q0**2/SCALEFACM**2 + TMAX=4.*(P(L,4)**2-P(L,5)**2) + XMAX=1.-Q0**2/(SCALEFACM**2*4.*TMAX) + + IF(SIGMATOT.EQ.0.d0) GOTO 116 + + RTAU=PYR(0) + +C--generate a trial emission +C--pick a x value from splitting function + 112 COUNTER=COUNTER+1 + IF(TYP.EQ.'G')THEN + IF(FCHANGE)THEN + X=GENERATEZ(0.d0,0.d0,1.-XMAX,'QG') + ELSE + X=GENERATEZ(0.d0,0.d0,1.-XMAX,'GG') + ENDIF + ELSE + IF(FCHANGE)THEN + X=1.-GENERATEZ(0.d0,0.d0,1.-XMAX,'QQ') + ELSE + X=GENERATEZ(0.d0,0.d0,1.-XMAX,'QQ') + ENDIF + ENDIF + IF(NORAD) X=1.d0 +C--initialisation + TMAXNEW=(X*P(L,4))**2 + PHI=0.d0 + TLEFT=DELTAT + TNOW=TSTART + QSUMVEC(1)=0.d0 + QSUMVEC(2)=0.d0 + QSUMVEC(3)=0.d0 + QSUMVEC(4)=0.d0 + QSUM2=-1.d-10 + OVERQ0=.FALSE. + Q=P(L,5) + QOLD=P(L,5) + TAUEST=DELTAT +C--generate first momentum transfer + DELTAL=DT + NSTART=1 + NEND=1 + TNOW=TNOW+DELTAL + TSUM=DELTAL + TLEFT=TLEFT-DELTAL + ALLQS(NEND,6)=TNOW + Q2OLD=QSUM2 +C--get new momentum transfer + COUNT2=0 + 118 CALL GETQVEC(L,NEND,TNOW-MV(L,4),X) + IF(-QSUM2.GT.P(L,4)**2)THEN + QSUMVEC(1)=0.d0 + QSUMVEC(2)=0.d0 + QSUMVEC(3)=0.d0 + QSUMVEC(4)=0.d0 + QSUM2=Q2OLD + IF(COUNT2.LT.100)THEN + COUNT2=COUNT2+1 + GOTO 118 + ELSE + ALLQS(NEND,1)=0.d0 + ALLQS(NEND,2)=0.d0 + ALLQS(NEND,3)=0.d0 + ALLQS(NEND,4)=0.d0 + ALLQS(NEND,5)=0.d0 + ENDIF + ENDIF +C--update OVERQ0 + IF(-ALLQS(NEND,1).GT.LOW) OVERQ0=.TRUE. +C--get new virtuality + IF(OVERQ0.AND.(.NOT.NORAD))THEN + Q=GETNEWMASS(L,SCALEFACM**2*QSUM2,SCALEFACM**2*Q2OLD,0.d0, + & .TRUE.,X,ZDUM,QQBARDUM) + ELSE + Q=0.d0 + ENDIF + +C--estimate formation time + 111 IF((Q.EQ.0.d0).OR.(Q.EQ.P(L,5)))THEN + TAUEST=DELTAT + ELSE + TAUEST=FTFAC*(1.-PHI)*0.2*X*P(L,4)/Q**2 + ENDIF + LAMBDA=1.d0/TAUEST + TAUEST=-LOG(1.d0-RTAU)/LAMBDA + +C--find number, position and momentum transfers of further scatterings + NOSCAT=.NOT.GETDELTAT(L,TNOW,MIN(TLEFT,TAUEST),DELTAL) + IF((.NOT.NOSCAT).AND.(.NOT.NORAD))THEN +C--add a momentum transfer + NEND=NEND+1 + IF(NEND.GE.100)THEN + nend=nend-1 + goto 114 + ENDIF + TNOW=TNOW+DELTAL + TSUM=TSUM+DELTAL + TLEFT=TLEFT-DELTAL +C--update phase + IF((Q.NE.0.d0).AND.(Q.NE.P(L,5)))THEN + PHI=PHI+5.*DELTAL*Q**2/(1.*X*P(L,4)) + ENDIF +C--get new momentum transfer + ALLQS(NEND,6)=TNOW + Q2OLD=QSUM2 + QSUMVECOLD(1)=QSUMVEC(1) + QSUMVECOLD(2)=QSUMVEC(2) + QSUMVECOLD(3)=QSUMVEC(3) + QSUMVECOLD(4)=QSUMVEC(4) + COUNT2=0 + 119 CALL GETQVEC(L,NEND,TNOW-MV(L,4),X) + IF(-QSUM2.GT.P(L,4)**2)THEN + QSUMVEC(1)=QSUMVECOLD(1) + QSUMVEC(2)=QSUMVECOLD(2) + QSUMVEC(3)=QSUMVECOLD(3) + QSUMVEC(4)=QSUMVECOLD(4) + QSUM2=Q2OLD + IF(COUNT2.LT.100)THEN + COUNT2=COUNT2+1 + GOTO 119 + ELSE + ALLQS(NEND,1)=0.d0 + ALLQS(NEND,2)=0.d0 + ALLQS(NEND,3)=0.d0 + ALLQS(NEND,4)=0.d0 + ALLQS(NEND,5)=0.d0 + ENDIF + ENDIF +C--update OVERQ0 + IF((-QSUM2.GT.LOW) + & .OR.(-ALLQS(NEND,1).GT.LOW)) OVERQ0=.TRUE. +C--get new virtuality + QOLD=Q + IF(OVERQ0.AND.(.NOT.NORAD))THEN + Q=GETNEWMASS(L,SCALEFACM**2*QSUM2,SCALEFACM**2*Q2OLD,0.d0, + & .TRUE.,X,ZDUM,QQBARDUM) + ELSE + Q=0.d0 + ENDIF + GOTO 111 + ENDIF + +C--do reweighting + 114 TMAXNEW=X**2*P(L,4)**2 + IF(NORAD)THEN + WEIGHT=1.d0 + Q=0.d0 + X=1.d0 + ELSEIF((-QSUM2.LT.LOW).OR.(Q.EQ.0.d0))THEN + WEIGHT=0.d0 + ELSEIF(-QSUM2.GT.P(L,4)**2)THEN + WEIGHT=0.d0 + ELSE + IF(TYP.EQ.'G')THEN + FMAX=2.*LOG(-SCALEFACM**2*QSUM2/Q0**2) + & *ALPHAS(Q0**2/4.,LPS)/(2.*PI) + IF(QSUM2.EQ.0.d0)THEN + WEIGHT=0.d0 + NORAD=.TRUE. + ELSE + IF(FCHANGE)THEN + WEIGHT=2.*GETPDF(X,SCALEFACM*SQRT(-QSUM2),'QG')/(PQG(X)*FMAX) + IF((WEIGHT.GT.1.d0+1.d-4).OR.(WEIGHT.LT.-1.d-4))THEN + write(logfid,*)'x,sqrt(qsum^2),getpdf,fmax:',X, + & SQRT(-QSUM2),GETPDF(X,SCALEFACM*SQRT(-QSUM2),'QG'),'qg', + & FMAX + ENDIF + ELSE + WEIGHT=GETPDF(X,SCALEFACM*SQRT(-QSUM2),'GG')/(PGG(X)*FMAX) + IF((WEIGHT.GT.1.d0+1.d-4).OR.(WEIGHT.LT.-1.d-4))THEN + write(logfid,*)'x,sqrt(qsum^2),getpdf,fmax:',X, + & SQRT(-QSUM2),GETPDF(X,SCALEFACM*SQRT(-QSUM2),'GG'),'gg', + & FMAX + ENDIF + ENDIF + ENDIF + ELSE + FMAX=LOG(-SCALEFACM**2*QSUM2/Q0**2) + & *ALPHAS(Q0**2/4.,LPS)/(2.*PI) + IF(QSUM2.EQ.0.d0)THEN + WEIGHT=0.d0 + NORAD=.TRUE. + ELSE + IF(FCHANGE)THEN + WEIGHT=GETPDF(X,SCALEFACM*SQRT(-QSUM2),'GQ')/(PGQ(X)*FMAX) + IF((WEIGHT.GT.1.d0+1.d-4).OR.(WEIGHT.LT.-1.d-4))THEN + write(logfid,*)'x,sqrt(qsum^2),getpdf:,fmax',X, + & SQRT(-QSUM2),GETPDF(X,SCALEFACM*SQRT(-QSUM2),'GQ'),'gq', + & FMAX + ENDIF + ELSE + WEIGHT=GETPDF(X,SCALEFACM*SQRT(-QSUM2),'QQ')/(PQQ(X)*FMAX) + IF((WEIGHT.GT.1.d0+1.d-4).OR.(WEIGHT.LT.-1.d-4))THEN + write(logfid,*)'x,sqrt(qsum^2),getpdf,fmax:',X, + & SQRT(-QSUM2),GETPDF(X,SCALEFACM*SQRT(-QSUM2),'QQ'),'qq', + & FMAX + ENDIF + ENDIF + ENDIF + ENDIF + ENDIF + IF((WEIGHT.GT.1.d0+1.d-4).OR.(WEIGHT.LT.-1.d-4)) + & write(logfid,*)'error: weight=',WEIGHT + 115 IF(PYR(0).GT.WEIGHT)THEN + IF(COUNTER.LT.COUNTMAX)THEN + GOTO 112 + ELSE + Q=0.d0 + X=1.d0 + NEND=NSTART + QSUM2=ALLQS(NEND,1) + QSUMVEC(1)=ALLQS(NEND,2) + QSUMVEC(2)=ALLQS(NEND,3) + QSUMVEC(3)=ALLQS(NEND,4) + QSUMVEC(4)=ALLQS(NEND,5) + TYPI=K(L,2) + IF(-ALLQS(NEND,1).GT.LOW)THEN + OVERQ0=.TRUE. + ELSE + OVERQ0=.FALSE. + ENDIF + DELTAT=ALLQS(NEND,6)-TSTART + TNOW=ALLQS(1,6) + RETURN + ENDIF + ENDIF +C--found meaningful configuration, now do final checks +C--check if phase is unity and weight with 1/Nscat + IF(((TLEFT.LT.TAUEST).OR.(PYR(0).GT.1.d0/(NEND*1.d0))) + & .AND.(.NOT.NORAD))THEN + Q=0.d0 + X=1.d0 + NEND=NSTART + QSUM2=ALLQS(NEND,1) + QSUMVEC(1)=ALLQS(NEND,2) + QSUMVEC(2)=ALLQS(NEND,3) + QSUMVEC(3)=ALLQS(NEND,4) + QSUMVEC(4)=ALLQS(NEND,5) + TYPI=K(L,2) + IF(-ALLQS(NEND,1).GT.LOW)THEN + OVERQ0=.TRUE. + ELSE + OVERQ0=.FALSE. + ENDIF + DELTAT=ALLQS(NEND,6)-TSTART + TNOW=ALLQS(1,6) + ELSE + IF(.NOT.NORAD)THEN + TLEFT=TLEFT-TAUEST + TNOW=TNOW+TAUEST + TSUM=TSUM+TAUEST + ENDIF + DELTAT=TSUM + ENDIF + RETURN +C--exit in case of failure + 116 Q=0.d0 + X=1.d0 + NSTART=0 + NEND=0 + QSUMVEC(1)=0.d0 + QSUMVEC(2)=0.d0 + QSUMVEC(3)=0.d0 + QSUMVEC(4)=0.d0 + QSUM2=0.d0 + OVERQ0=.FALSE. + TYPI=K(L,2) + RETURN + END + + +*********************************************************************** +*** subroutine dofistatescat +*********************************************************************** + SUBROUTINE DOFISTATESCAT(L,TNOW,DTLEFT,DELTAT,NEWMASS, + & OVERQ0,Z,QQBAR) + IMPLICIT NONE +C--identifier of file for hepmc output and logfile + common/hepmcid/hpmcfid,logfid + integer hpmcfid,logfid +C--Common block of Pythia + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + INTEGER N,NPAD,K + DOUBLE PRECISION P,V +C--time common block + COMMON/TIME/MV(23000,5) + DOUBLE PRECISION MV +C--factor in front of formation times + COMMON/FTIMEFAC/FTFAC + DOUBLE PRECISION FTFAC +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--discard event flag + COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD + LOGICAL DISCARD + INTEGER NDISC,NSTRANGE,NGOOD,errcount + double precision wdisc +C--variables for coherent scattering + COMMON/COHERENT/NSTART,NEND,ALLQS(10000,6),SCATCENTRES(10000,10), + &QSUMVEC(4),QSUM2 + INTEGER NSTART,NEND + DOUBLE PRECISION ALLQS,SCATCENTRES,QSUMVEC,QSUM2 +C--local variables + INTEGER L,COUNTER,COUNTMAX,COUNT2 + DOUBLE PRECISION TNOW,DELTAT,NEWMASS,TLEFT,DELTAL,Q2OLD, + &GETNEWMASS,PYR,TSUM,QSUMVECOLD(4),RTAU,LAMBDA,DTLEFT,PHI, + &TAUEST,LOW,Z,pyp + LOGICAL OVERQ0,NOSCAT,GETDELTAT,QQBAR + CHARACTER TYP + DATA COUNTMAX/100/ + DELTAL=0.d0 + + IF(-QSUM2.GT.P(L,4)**2) + & write(logfid,*) 'DOFISTATESCAT has a problem:',-QSUM2,P(L,4)**2 + + IF(K(L,2).EQ.21)THEN + TYP='G' + ELSE + TYP='Q' + ENDIF + LOW=Q0**2/SCALEFACM**2 + + TSUM=0.d0 + PHI=0.d0 + DELTAT=0.d0 + +C--check for radiation with first (given) momentum transfer + Q2OLD=0.d0 + IF(OVERQ0.OR.(-QSUM2.GT.LOW))THEN + NEWMASS=GETNEWMASS(L,SCALEFACM**2*QSUM2,SCALEFACM**2*Q2OLD, + & NEWMASS,.FALSE.,1.d0,Z,QQBAR) + OVERQ0=.TRUE. + ELSE + NEWMASS=P(L,5) + ENDIF + + RTAU=PYR(0) + + TLEFT=DTLEFT + 222 IF((NEWMASS.EQ.0.d0).OR.(NEWMASS.EQ.P(L,5)))THEN + TAUEST=TLEFT + ELSE + TAUEST=FTFAC*(1.-PHI)*0.2*P(L,4)/NEWMASS**2 + ENDIF + LAMBDA=1.d0/TAUEST + TAUEST=-LOG(1.d0-RTAU)/LAMBDA + NOSCAT=.NOT.GETDELTAT(L,TNOW+TSUM,MIN(TAUEST,TLEFT),DELTAL) + IF(.NOT.NOSCAT)THEN +C--do scattering + NEND=NEND+1 + IF(NEND.gt.countmax)THEN + nend=nend-1 + goto 218 + ENDIF + IF(NSTART.EQ.0) NSTART=1 + TSUM=TSUM+DELTAL + TLEFT=TLEFT-DELTAL + IF((NEWMASS.NE.0.d0).AND.(NEWMASS.NE.P(L,5)))THEN + PHI=PHI+5.*DELTAL*NEWMASS**2/(1.*P(L,4)) + ENDIF + ALLQS(NEND,6)=TNOW+TSUM + QSUMVECOLD(1)=QSUMVEC(1) + QSUMVECOLD(2)=QSUMVEC(2) + QSUMVECOLD(3)=QSUMVEC(3) + QSUMVECOLD(4)=QSUMVEC(4) + Q2OLD=QSUM2 +C--get new momentum transfer + COUNT2=0 + 219 CALL GETQVEC(L,NEND,TNOW+TSUM-MV(L,4),1.d0) + IF(-QSUM2.GT.P(L,4)**2)THEN + QSUMVEC(1)=QSUMVECOLD(1) + QSUMVEC(2)=QSUMVECOLD(2) + QSUMVEC(3)=QSUMVECOLD(3) + QSUMVEC(4)=QSUMVECOLD(4) + QSUM2=Q2OLD + IF(COUNT2.LT.100)THEN + COUNT2=COUNT2+1 + GOTO 219 + ELSE + ALLQS(NEND,1)=0.d0 + ALLQS(NEND,2)=0.d0 + ALLQS(NEND,3)=0.d0 + ALLQS(NEND,4)=0.d0 + ALLQS(NEND,5)=0.d0 + ENDIF + ENDIF +C--figure out new virtuality + IF(OVERQ0.OR.(-QSUM2.GT.LOW))THEN + NEWMASS=GETNEWMASS(L,SCALEFACM**2*QSUM2,SCALEFACM**2*Q2OLD, + & NEWMASS,.FALSE.,1.d0,Z,QQBAR) + OVERQ0=.TRUE. + ENDIF + GOTO 222 + ENDIF +C--no more scattering + 218 if ((newmass**2.gt.low).and.(newmass.ne.p(l,5))) then + if ((TLEFT.LT.TAUEST).OR.(PYR(0).GT.1.d0/(NEND*1.d0))) then + if (nend.eq.countmax) then + deltat=tsum + else if (TLEFT.LT.TAUEST) then + DELTAT=TSUM+tleft + else + DELTAT=TSUM+tauest + endif + NEWMASS=P(L,5) + ELSE + DELTAT=TSUM+TAUEST + ENDIF + else + DELTAT=0.d0 + NSTART=1 + NEND=1 + QSUM2=ALLQS(NEND,1) + QSUMVEC(1)=ALLQS(NEND,2) + QSUMVEC(2)=ALLQS(NEND,3) + QSUMVEC(3)=ALLQS(NEND,4) + QSUMVEC(4)=ALLQS(NEND,5) + IF(-ALLQS(NEND,1).GT.LOW)THEN + OVERQ0=.TRUE. + ELSE + OVERQ0=.FALSE. + ENDIF + NEWMASS=P(L,5) + endif + return + END + + +*********************************************************************** +*** function getnewmass +*********************************************************************** + DOUBLE PRECISION FUNCTION GETNEWMASS(L,Q2,QOLD2,MASS,IN,X, + & ZDEC,QQBARDEC) + IMPLICIT NONE +C--Common block of Pythia + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + INTEGER N,NPAD,K + DOUBLE PRECISION P,V +C--time common block + COMMON/TIME/MV(23000,5) + DOUBLE PRECISION MV +C--variables for angular ordering + COMMON/ANGOR/ZA(23000),ZD(23000),THETAA(23000),QQBARD(23000) + DOUBLE PRECISION ZA,ZD,THETAA + LOGICAL QQBARD +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--local variables + INTEGER L + DOUBLE PRECISION Q2,QOLD2,R,PYR,PNOSPLIT1,PNOSPLIT2,Z,QA, + &GETSUDAKOV,GETMASS,PKEEP,X,MASS,ZDEC,QTMP,ZOLD + LOGICAL IN,QQBARDEC,QQBAROLD + CHARACTER*2 TYP + + IF(x*P(L,4).LT.Q0)THEN + GETNEWMASS=0.d0 + ZDEC=0.d0 + QQBARDEC=.FALSE. + RETURN + ENDIF + IF (-Q2.LT.Q0**2)THEN + GETNEWMASS=0.d0 + RETURN + ENDIF + IF(K(L,2).EQ.21)THEN + TYP='GC' + ELSE + TYP='QQ' + ENDIF + IF(SQRT(-QOLD2).LE.Q0)THEN + IF(IN)THEN + GETNEWMASS=GETMASS(0.d0,SQRT(-Q2),-1.d0, + & X*P(L,4),TYP,X*P(L,4),IN,ZDEC,QQBARDEC) + ELSE + GETNEWMASS=GETMASS(0.d0,SQRT(-Q2),-1.d0,P(L,4),TYP, + & SQRT(-Q2),IN,ZDEC,QQBARDEC) + ENDIF + GETNEWMASS=MIN(GETNEWMASS,X*P(L,4)) + RETURN + ENDIF + Z=1.d0 + QA=1.d0 + IF(MAX(P(L,5),MASS).GT.0.d0)THEN + IF(-Q2.GT.-QOLD2)THEN + ZOLD=ZDEC + QQBAROLD=QQBARDEC + QTMP=GETMASS(0.d0,SQRT(-Q2),-1.d0,X*P(L,4),TYP, + & SQRT(-Q2),IN,ZDEC,QQBARDEC) + IF(QTMP.LT.SQRT(-QOLD2))THEN + GETNEWMASS=MASS + ZDEC=ZOLD + QQBARDEC=QQBAROLD + ELSE + GETNEWMASS=QTMP + ENDIF + ELSE + PNOSPLIT1=GETSUDAKOV(SQRT(-QOLD2),QA,Q0,Z,X*P(L,4), + & TYP,MV(L,4),IN) + PNOSPLIT2=GETSUDAKOV(SQRT(-Q2),QA,Q0,Z,X*P(L,4), + & TYP,MV(L,4),IN) + PKEEP=(1.-PNOSPLIT2)/(1.-PNOSPLIT1) + IF(PYR(0).LT.PKEEP)THEN + IF(P(L,5).LT.SQRT(-Q2))THEN + GETNEWMASS=MASS + ELSE + 55 GETNEWMASS=GETMASS(Q0,SQRT(-Q2),-1.d0,X*P(L,4),TYP, + & SQRT(-Q2),IN,ZDEC,QQBARDEC) + IF((GETNEWMASS.EQ.0.d0).AND.(X*P(L,4).GT.Q0)) GOTO 55 + ENDIF + ELSE + GETNEWMASS=0.d0 + ZDEC=0.d0 + QQBARDEC=.FALSE. + ENDIF + ENDIF + ELSE + IF(-Q2.GT.-QOLD2)THEN + GETNEWMASS=GETMASS(0.d0,SQRT(-Q2),-1.d0, + & X*P(L,4),TYP,X*P(L,4),IN,ZDEC,QQBARDEC) + if(getnewmass.lt.SQRT(-QOLD2))then + GETNEWMASS=0.d0 + ZDEC=0.d0 + QQBARDEC=.FALSE. + endif + ELSE + GETNEWMASS=0.d0 + ZDEC=0.d0 + QQBARDEC=.FALSE. + ENDIF + ENDIF + GETNEWMASS=MIN(GETNEWMASS,x*P(L,4)) + END + + +*********************************************************************** +*** function getpnorad1 +*********************************************************************** + DOUBLE PRECISION FUNCTION GETPNORAD1(LINE,x,y,z,t) + IMPLICIT NONE +C--identifier of file for hepmc output and logfile + common/hepmcid/hpmcfid,logfid + integer hpmcfid,logfid +C--Common block of Pythia + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + INTEGER N,NPAD,K + DOUBLE PRECISION P,V +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--local variables + INTEGER LINE + DOUBLE PRECISION UP,LOW,CCOL,SIGMATOT,GETSSCAT,GETXSECINT, + &SCATPRIMFUNC,MS1,MD1,shat,pcms2,avmom(5),x,y,z,t,getmd + + md1 = getmd(x,y,z,t) + call avscatcen(x,y,z,t, + &avmom(1),avmom(2),avmom(3),avmom(4),avmom(5)) + ms1 = avmom(5) + shat = avmom(5)**2 + p(line,5)**2 + 2.*(avmom(4)*p(line,4) + & -avmom(1)*p(line,1)-avmom(2)*p(line,2)-avmom(3)*p(line,3)) + pcms2 = (shat+p(line,5)**2-ms1**2)**2/(4.*shat)-p(line,5)**2 + up = 4.*pcms2 + LOW=Q0**2/SCALEFACM**2 + IF((UP.LE.LOW).OR.(P(LINE,4).LT.Q0/SCALEFACM))THEN + GETPNORAD1=1.d0 + RETURN + ENDIF + IF(K(LINE,2).EQ.21)THEN + CCOL=3./2. +C--probability for no initial state radiation + SIGMATOT=GETSSCAT(P(LINE,4),p(line,1),p(line,2),p(line,3), + & P(LINE,5),0.d0,'G','C',x,y,z,t,0) + IF(SIGMATOT.EQ.0.d0)THEN + GETPNORAD1=-1.d0 + RETURN + ENDIF + GETPNORAD1=(CCOL*(SCATPRIMFUNC(LOW,MD1)- + &SCATPRIMFUNC(0.d0,MD1)) + & + GETXSECINT(UP,MD1,'GB'))/SIGMATOT + ELSE + CCOL=2./3. +C--probability for no initial state radiation + SIGMATOT=GETSSCAT(P(LINE,4),p(line,1),p(line,2),p(line,3), + & P(LINE,5),0.d0,'Q','C',x,y,z,t,0) + IF(SIGMATOT.EQ.0.d0)THEN + GETPNORAD1=1.d0 + RETURN + ENDIF + GETPNORAD1=(CCOL*(SCATPRIMFUNC(LOW,MD1)- + &SCATPRIMFUNC(0.d0,MD1)) + & + GETXSECINT(UP,MD1,'QB'))/SIGMATOT + ENDIF + IF((GETPNORAD1.LT.-1.d-4).OR.(GETPNORAD1.GT.1.d0+1.d-4))THEN + write(logfid,*)'error: P_norad=',GETPNORAD1, + & P(LINE,4),P(LINE,5),LOW,UP,K(LINE,2),MD1 + ENDIF + END + + +*********************************************************************** +*** subroutine getqvec +*********************************************************************** + SUBROUTINE GETQVEC(L,J,DT,X) + IMPLICIT NONE +C--identifier of file for hepmc output and logfile + common/hepmcid/hpmcfid,logfid + integer hpmcfid,logfid +C--Common block of Pythia + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + INTEGER N,NPAD,K + DOUBLE PRECISION P,V +C--time common block + COMMON/TIME/MV(23000,5) + DOUBLE PRECISION MV +C--variables for coherent scattering + COMMON/COHERENT/NSTART,NEND,ALLQS(10000,6),SCATCENTRES(10000,10), + &QSUMVEC(4),QSUM2 + INTEGER NSTART,NEND + DOUBLE PRECISION ALLQS,SCATCENTRES,QSUMVEC,QSUM2 +C--discard event flag + COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD + LOGICAL DISCARD + INTEGER NDISC,NSTRANGE,NGOOD,errcount + double precision wdisc +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--local variables + INTEGER L,J,COUNTER,COUNTMAX,COUNT2,i + DOUBLE PRECISION XSC,YSC,ZSC,TSC,GETMD,GETTEMP,DT,X,PYR,NEWMOM(4), + &T,PT,MAXT,PHI2,BETA(3),PHI,THETA,GETT,PYP,PI,PT2,GETMS, + &savemom(5),theta2,mb2,pz,kt2,phiq,maxt2,xi,md,shat,pcms2, + &avmom(5) + CHARACTER TYPS + DATA PI/3.141592653589793d0/ + DATA COUNTMAX/1000/ + + IF (J.GT.10000)THEN + discard = .true. + return + ENDIF + + COUNTER=0 + COUNT2=0 + + XSC=MV(L,1)+DT*P(L,1)/P(L,4) + YSC=MV(L,2)+DT*P(L,2)/P(L,4) + ZSC=MV(L,3)+DT*P(L,3)/P(L,4) + TSC=MV(L,4)+DT + md = GETMD(XSC,YSC,ZSC,TSC) + + call AVSCATCEN(xsc,ysc,zsc,tsc, + &avmom(1),avmom(2),avmom(3),avmom(4),avmom(5)) + + do 210 i=1,5 + savemom(i) = p(l,i) + 210 continue + + xi = sqrt(max(x**2*p(l,4)**2,p(l,5)**2) - p(l,5)**2)/pyp(l,8) + p(l,1) = xi*p(l,1) + p(l,2) = xi*p(l,2) + p(l,3) = xi*p(l,3) + p(l,4) = max(x*p(l,4),p(l,5)) + + + 444 CALL GETSCATTERER(XSC,YSC,ZSC,TSC, + &K(1,2),P(1,1),P(1,2),P(1,3),P(1,4),P(1,5)) + MV(1,1)=XSC + MV(1,2)=YSC + MV(1,3)=ZSC + MV(1,4)=TSC + TYPS='Q' + IF(K(1,2).EQ.21)TYPS='G' + + shat = avmom(5)**2 + savemom(5)**2 + 2.*(avmom(4)*savemom(4) + & -avmom(1)*savemom(1)-avmom(2)*savemom(2)-avmom(3)*savemom(3)) + pcms2 = (shat+savemom(5)**2-avmom(5)**2)**2/(4.*shat) + & -savemom(5)**2 + maxt = 4.*pcms2 + + K(1,1)=13 + SCATCENTRES(J,1)=K(1,2) + SCATCENTRES(J,2)=P(1,1) + SCATCENTRES(J,3)=P(1,2) + SCATCENTRES(J,4)=P(1,3) + SCATCENTRES(J,5)=P(1,4) + SCATCENTRES(J,6)=P(1,5) + SCATCENTRES(J,7)=MV(1,1) + SCATCENTRES(J,8)=MV(1,2) + SCATCENTRES(J,9)=MV(1,3) + SCATCENTRES(J,10)=MV(1,4) +C--transform to scattering centre's rest frame and rotate such that parton momentum is in z-direction + BETA(1)=P(1,1)/P(1,4) + BETA(2)=P(1,2)/P(1,4) + BETA(3)=P(1,3)/P(1,4) + CALL PYROBO(L,L,0d0,0d0,-BETA(1),-BETA(2),-BETA(3)) + CALL PYROBO(1,1,0d0,0d0,-BETA(1),-BETA(2),-BETA(3)) + THETA=PYP(L,13) + PHI=PYP(L,15) + CALL PYROBO(L,L,0d0,-PHI,0d0,0d0,0d0) + CALL PYROBO(1,1,0d0,-PHI,0d0,0d0,0d0) + CALL PYROBO(L,L,-THETA,0d0,0d0,0d0,0d0) + CALL PYROBO(1,1,-THETA,0d0,0d0,0d0,0d0) +C--pick a t from differential scattering cross section + 204 T=-GETT(0.d0,MAXT,md) + 202 NEWMOM(4)=P(L,4)+T/(2.*p(1,5)) + NEWMOM(3)=(T-2.*P(L,5)**2+2.*p(l,4)*NEWMOM(4))/(2.*P(L,3)) + PT2=NEWMOM(4)**2-NEWMOM(3)**2-P(L,5)**2 + IF(DABS(PT2).LT.1.d-10) PT2=0.d0 + IF(T.EQ.0.d0) PT2=0.d0 + IF(PT2.LT.0.d0)THEN + T=0.d0 + GOTO 202 + ENDIF + PT=SQRT(PT2) + PHI2=PYR(0)*2*PI + NEWMOM(1)=PT*COS(PHI2) + NEWMOM(2)=PT*SIN(PHI2) + P(1,1)=NEWMOM(1)-P(L,1) + P(1,2)=NEWMOM(2)-P(L,2) + P(1,3)=NEWMOM(3)-P(L,3) + P(1,4)=NEWMOM(4)-P(L,4) + P(1,5)=0.d0 +C--transformation to lab + CALL PYROBO(L,L,THETA,0d0,0d0,0d0,0d0) + CALL PYROBO(1,1,THETA,0d0,0d0,0d0,0d0) + CALL PYROBO(L,L,0d0,PHI,0d0,0d0,0d0) + CALL PYROBO(1,1,0d0,PHI,0d0,0d0,0d0) + CALL PYROBO(L,L,0d0,0d0,BETA(1),BETA(2),BETA(3)) + CALL PYROBO(1,1,0d0,0d0,BETA(1),BETA(2),BETA(3)) + ALLQS(J,1)=T + ALLQS(J,2)=P(1,1) + ALLQS(J,3)=P(1,2) + ALLQS(J,4)=P(1,3) + ALLQS(J,5)=P(1,4) + QSUMVEC(1)=QSUMVEC(1)+ALLQS(NEND,2) + QSUMVEC(2)=QSUMVEC(2)+ALLQS(NEND,3) + QSUMVEC(3)=QSUMVEC(3)+ALLQS(NEND,4) + QSUMVEC(4)=QSUMVEC(4)+ALLQS(NEND,5) + QSUM2=QSUMVEC(4)**2-QSUMVEC(1)**2-QSUMVEC(2)**2-QSUMVEC(3)**2 + IF(QSUM2.GT.0.d0)THEN + QSUMVEC(1)=QSUMVEC(1)-ALLQS(NEND,2) + QSUMVEC(2)=QSUMVEC(2)-ALLQS(NEND,3) + QSUMVEC(3)=QSUMVEC(3)-ALLQS(NEND,4) + QSUMVEC(4)=QSUMVEC(4)-ALLQS(NEND,5) + QSUM2=QSUMVEC(4)**2-QSUMVEC(1)**2-QSUMVEC(2)**2-QSUMVEC(3)**2 + IF(COUNTER.GT.COUNTMAX)THEN + write(logfid,*)'GETQVEC unable to find q vector' + ALLQS(J,1)=0.d0 + ALLQS(J,2)=0.d0 + ALLQS(J,3)=0.d0 + ALLQS(J,4)=0.d0 + ALLQS(J,5)=0.d0 + ELSE + COUNTER=COUNTER+1 + GOTO 444 + ENDIF + ENDIF + do 211 i=1,5 + p(l,i) = savemom(i) + 211 continue + END + +*********************************************************************** +*** subroutine dokinematics +*********************************************************************** + SUBROUTINE DOKINEMATICS(L,lold,N1,N2,NEWM,RETRYSPLIT, + & TIME,X,Z,QQBAR) + IMPLICIT NONE +C--identifier of file for hepmc output and logfile + common/hepmcid/hpmcfid,logfid + integer hpmcfid,logfid +C--Common block of Pythia + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + INTEGER N,NPAD,K + DOUBLE PRECISION P,V +C--time common block + COMMON/TIME/MV(23000,5) + DOUBLE PRECISION MV +C--factor in front of formation times + COMMON/FTIMEFAC/FTFAC + DOUBLE PRECISION FTFAC +C--colour index common block + COMMON/COLOUR/TRIP(23000),ANTI(23000),COLMAX + INTEGER TRIP,ANTI,COLMAX +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--discard event flag + COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD + LOGICAL DISCARD + INTEGER NDISC,NSTRANGE,NGOOD,errcount + double precision wdisc +C--variables for angular ordering + COMMON/ANGOR/ZA(23000),ZD(23000),THETAA(23000),QQBARD(23000) + DOUBLE PRECISION ZA,ZD,THETAA + LOGICAL QQBARD +C--variables for coherent scattering + COMMON/COHERENT/NSTART,NEND,ALLQS(10000,6),SCATCENTRES(10000,10), + &QSUMVEC(4),QSUM2 + INTEGER NSTART,NEND + DOUBLE PRECISION ALLQS,SCATCENTRES,QSUMVEC,QSUM2 +C--number of scattering events + COMMON/CHECK/NSCAT,NSCATEFF,NSPLIT + DOUBLE PRECISION NSCAT,NSCATEFF,NSPLIT +C--event weight + COMMON/WEIGHT/EVWEIGHT,sumofweights + double precision EVWEIGHT,sumofweights +C--extra storage for scattering centres before interactions + common/storescatcen/nscatcen,maxnscatcen,scatflav(10000), + &scatcen(10000,5),writescatcen,writedummies + integer nscatcen,maxnscatcen,scatflav + double precision scatcen + logical writescatcen,writedummies +C--local variables + INTEGER L,LINE,N1,N2,J,DIR,lold,nold,colmaxold,statold,nscatcenold + DOUBLE PRECISION PYR,PI,BETA(3),THETA,PHI,PYP,PHI2,MAXT,T, + &NEWMASS,DELTAM,DM,TTOT,DMLEFT,LAMBDA,TIME,ENDTIME,X,tmp, + &m32,newm2,shat,theta2,z,gettemp,E3new,E4new,p32,p42,p3old, + &newm,mass2,enew,pt2,pt,pl,m12,firsttime,pcms2 + CHARACTER*2 TYP + LOGICAL RETRYSPLIT,QQBAR,QQBARDEC,rejectt,redokin,reshuffle + DATA PI/3.141592653589793d0/ + + IF((N+2*(n2-n1+1)).GT.22990)THEN + write(logfid,*)'event too long for event record' + DISCARD=.TRUE. + RETURN + ENDIF + + firsttime = mv(l,5) + + redokin = .false. + + newm2=newm + nold=n + colmaxold=colmax + statold=k(l,1) + 204 DELTAM=NEWM2-P(L,5) + DMLEFT=DELTAM + + TTOT=0.d0 + DO 220 J=N1,N2 + TTOT=TTOT+ALLQS(J,1) + 220 CONTINUE + + LINE=L + + DO 222 J=N1,N2 + +C--projectile type + IF(K(LINE,2).EQ.21)THEN + TYP='GC' + IF(PYR(0).LT.0.5)THEN + DIR=1 + ELSE + DIR=-1 + ENDIF + ELSE + TYP='QQ' + DIR=0 + ENDIF + K(1,1)=6 + K(1,2)=SCATCENTRES(J,1) + P(1,1)=SCATCENTRES(J,2) + P(1,2)=SCATCENTRES(J,3) + P(1,3)=SCATCENTRES(J,4) + P(1,4)=SCATCENTRES(J,5) + P(1,5)=SCATCENTRES(J,6) + MV(1,1)=SCATCENTRES(J,7) + MV(1,2)=SCATCENTRES(J,8) + MV(1,3)=SCATCENTRES(J,9) + MV(1,4)=SCATCENTRES(J,10) + T=ALLQS(J,1) + if (t.eq.0.d0) then + rejectt = .true. + else + rejectt = .false. + endif + +C--transform to c.m.s. and rotate such that parton momentum is in z-direction + BETA(1)=(P(1,1)+p(line,1))/(P(1,4)+p(line,4)) + BETA(2)=(P(1,2)+p(line,2))/(P(1,4)+p(line,4)) + BETA(3)=(P(1,3)+p(line,3))/(P(1,4)+p(line,4)) + IF ((BETA(1).GT.1.d0).OR.(BETA(2).GT.1.d0).OR.(BETA(3).GT.1.d0) + & .or.(sqrt(beta(1)**2+beta(2)**2+beta(3)**2).gt.1.d0))THEN + reshuffle = .false. + else + reshuffle = .true. + endif + 205 if (.not.reshuffle) then + BETA(1)=P(1,1)/P(1,4) + BETA(2)=P(1,2)/P(1,4) + BETA(3)=P(1,3)/P(1,4) + CALL PYROBO(LINE,LINE,0d0,0d0,-BETA(1),-BETA(2),-BETA(3)) + CALL PYROBO(1,1,0d0,0d0,-BETA(1),-BETA(2),-BETA(3)) + THETA=PYP(LINE,13) + PHI=PYP(LINE,15) + CALL PYROBO(LINE,LINE,0d0,-PHI,0d0,0d0,0d0) + CALL PYROBO(1,1,0d0,-PHI,0d0,0d0,0d0) + CALL PYROBO(LINE,LINE,-THETA,0d0,0d0,0d0,0d0) + CALL PYROBO(1,1,-THETA,0d0,0d0,0d0,0d0) + + maxt = -2.*p(1,5)*p(line,4) + if (t.lt.maxt) then + t=0.d0 + rejectt = .true. + endif + m12 = -p(line,5)**2 + 203 enew = p(line,4)+t/(2.*p(1,5)) + pl = (t+2.*p(line,4)*enew-2.*m12)/(2.*p(line,3)) + pt2 = enew**2-pl**2-m12 + if (t.eq.0.d0) pt2 = 0.d0 + if (dabs(pt2).lt.1.d-8) pt2 = 0.d0 + if (pt2.lt.0.d0) then + write(logfid,*)' This should not have happened: pt^2<0!' + write(logfid,*)t,enew,pl,pt2 + t = 0.d0 + rejectt = .true. + goto 203 + endif + pt = sqrt(pt2) + phi2 = pyr(0)*2.*pi + n=n+2 + p(n,1)=pt*cos(phi2) + p(n,2)=pt*sin(phi2) + p(n,3)=pl + p(n,4)=enew + p(n,5)=p(line,5) +!--------------------------------- + P(N-1,1)=P(1,1)+P(LINE,1)-P(N,1) + P(N-1,2)=P(1,2)+P(LINE,2)-P(N,2) + P(N-1,3)=P(1,3)+P(LINE,3)-P(N,3) + P(N-1,4)=P(1,4)+P(LINE,4)-P(N,4) + mass2 = P(N-1,4)**2-P(N-1,1)**2-P(N-1,2)**2-P(N-1,3)**2 + if ((mass2.lt.0.d0).and.(mass2.gt.-1.-6)) mass2=0.d0 + if (mass2.lt.0.d0) + & write(logfid,*)'messed up scattering centres mass^2: ', + & mass2,p(1,5)**2 + P(N-1,5)=SQRT(mass2) + if (abs(p(n-1,5)-p(1,5)).gt.1.d-6) + & write(logfid,*)'messed up scattering centres mass: ', + & p(n-1,5),p(1,5),p(l,5) + call flush(logfid) +!--------------------------------- +! P(N-1,1)=P(1,1) +! P(N-1,2)=P(1,2) +! P(N-1,3)=P(1,3) +! P(N-1,4)=P(1,4) +! P(N-1,5)=P(1,5) +!--------------------------------- + else + CALL PYROBO(LINE,LINE,0d0,0d0,-BETA(1),-BETA(2),-BETA(3)) + CALL PYROBO(1,1,0d0,0d0,-BETA(1),-BETA(2),-BETA(3)) + if ((p(1,4).lt.0.d0).or.(p(line,4).lt.0.d0)) then + CALL PYROBO(1,1,0d0,0d0,BETA(1),BETA(2),BETA(3)) + CALL PYROBO(LINE,LINE,0d0,0d0,BETA(1),BETA(2),BETA(3)) + reshuffle = .false. + goto 205 + endif + THETA=PYP(LINE,13) + PHI=PYP(LINE,15) + CALL PYROBO(LINE,LINE,0d0,-PHI,0d0,0d0,0d0) + CALL PYROBO(1,1,0d0,-PHI,0d0,0d0,0d0) + CALL PYROBO(LINE,LINE,-THETA,0d0,0d0,0d0,0d0) + CALL PYROBO(1,1,-THETA,0d0,0d0,0d0,0d0) + shat = (p(1,4)+p(line,4))**2 + p3old = p(line,3) + + maxt = -4.*p(line,3)**2 + if (t.lt.maxt) then + t=0.d0 + rejectt = .true. + endif + theta2 = acos(1.d0+t/(2.*p(line,3)**2)) + phi2 = pyr(0)*2.*pi + n=n+2 + p(n,1)=p(line,3)*sin(theta2)*cos(phi2) + p(n,2)=p(line,3)*sin(theta2)*sin(phi2) + p(n,3)=p(line,3)*cos(theta2) + p(n,4)=p(line,4) + p(n,5)=p(line,5) +!--------------------------------- + P(N-1,1)=P(1,1)+P(LINE,1)-P(N,1) + P(N-1,2)=P(1,2)+P(LINE,2)-P(N,2) + P(N-1,3)=P(1,3)+P(LINE,3)-P(N,3) + P(N-1,4)=P(1,4)+P(LINE,4)-P(N,4) + mass2 = P(N-1,4)**2-P(N-1,1)**2-P(N-1,2)**2-P(N-1,3)**2 + if ((mass2.lt.0.d0).and.(mass2.gt.-1.-6)) mass2=0.d0 + if (mass2.lt.0.d0) + & write(logfid,*)'messed up scattering centres mass^2: ', + & mass2,p(1,5)**2 + P(N-1,5)=SQRT(mass2) + if (abs(p(n-1,5)-p(1,5)).gt.1.d-6) + & write(logfid,*)'messed up scattering centres mass: ', + & p(n-1,5),p(1,5),p(l,5) + call flush(logfid) +!--------------------------------- +! P(N-1,1)=P(1,1) +! P(N-1,2)=P(1,2) +! P(N-1,3)=P(1,3) +! P(N-1,4)=P(1,4) +! P(N-1,5)=P(1,5) +!--------------------------------- + endif +C--outgoing projectile + ZA(N)=1.d0 + THETAA(N)=-1.d0 + ZD(N)=Z + QQBARD(N)=QQBAR + K(N,1)=K(LINE,1) + K(N,2)=K(LINE,2) + K(N,3)=L + K(N,4)=0 + K(N,5)=0 + IF(ALLHAD.and.(.not.rejectt))THEN + IF(K(N,2).EQ.21)THEN + IF(DIR.EQ.1)THEN + TRIP(N)=COLMAX+1 + ANTI(N)=ANTI(LINE) + ELSE + TRIP(N)=TRIP(LINE) + ANTI(N)=COLMAX+1 + ENDIF + ELSEIF(K(N,2).GT.0)THEN + TRIP(N)=COLMAX+1 + ANTI(N)=0 + ELSE + TRIP(N)=0 + ANTI(N)=COLMAX+1 + ENDIF + COLMAX=COLMAX+1 + ELSE + TRIP(N)=TRIP(LINE) + ANTI(N)=ANTI(LINE) + ENDIF +C--take care of incoming projectile + IF(K(LINE,1).EQ.1)THEN + K(LINE,1)=12 + ELSE + K(LINE,1)=14 + ENDIF + K(LINE,4)=N-1 + K(LINE,5)=N +C--outgoing scattering centre + ZA(N-1)=1.d0 + THETAA(N-1)=-1.d0 + ZD(N-1)=-1.d0 + QQBARD(N-1)=.false. +C--temporary status code, will be overwritten later + K(N-1,1)=3 + K(N-1,2)=21 + K(N-1,3)=0 + K(N-1,4)=0 + K(N-1,5)=0 + IF(ALLHAD.and.(.not.rejectt))THEN + IF((K(N,2).GT.0).AND.(DIR.GE.0))THEN + TRIP(N-1)=TRIP(LINE) + ANTI(N-1)=TRIP(N) + ELSE + TRIP(N-1)=ANTI(N) + ANTI(N-1)=ANTI(LINE) + ENDIF + ELSE + TRIP(N-1)=0 + ANTI(N-1)=0 + ENDIF + + if (reshuffle.and.(dm.gt.0.d0)) then +C--adjust mass and re-shuffle momenta + + IF(TTOT.EQ.0.d0)THEN + DM=0.d0 + ELSE + if (dmleft.lt.0.d0) then + DM=max(DMLEFT*T/TTOT*1.5d0,dmleft) + else + DM=min(DMLEFT*T/TTOT*1.5d0,dmleft) + endif + ENDIF + TTOT=TTOT-ALLQS(J,1) + + newmass = p(n,5)+dm + if (newmass.lt.0.d0) then + m32 = -NEWMASS**2 + else + m32 = NEWMASS**2 + endif + E3new = (shat + m32 - p(1,5)**2)/(2.d0*sqrt(shat)) + E4new = (shat - m32 + p(1,5)**2)/(2.d0*sqrt(shat)) + p32 = E3new**2 - m32 + p42 = E4new**2 - p(1,5)**2 + if ((p32.lt.0.d0).or.(p42.lt.0.d0).or. + & (E3new.lt.0.d0).or.(E4new.lt.0.d0)) then + p32 = 0.d0 + p42 = 0.d0 + E4new = p(n-1,5) + E3new = sqrt(shat) - E4new + m32 = E3new**2 + if ((E3new.lt.0.d0).or.(E4new.lt.0.d0)) then + E3new = p(n,4) + E4new = p(n-1,4) + p32 = p3old**2 + p42 = p3old**2 + if (p(n,5).lt.0.d0) then + m32 = -p(n,5)**2 + else + m32 = p(n,5)**2 + endif + endif + endif + p(n,1) = sqrt(p32)*p(n,1)/p3old + p(n,2) = sqrt(p32)*p(n,2)/p3old + p(n,3) = sqrt(p32)*p(n,3)/p3old + p(n,4) = E3new + p(n,5) = sign(sqrt(abs(m32)),newmass) + tmp = p(n,4)**2-p(n,1)**2-p(n,2)**2-p(n,3)**2 + if (abs(tmp-m32).gt.1.d-6) + & write(logfid,*) 'Oups, messed up projectiles mass:', + & tmp,m32,p(n,5) +!--------------------------------- + p(n-1,1) = sqrt(p42)*p(n-1,1)/p3old + p(n-1,2) = sqrt(p42)*p(n-1,2)/p3old + p(n-1,3) = sqrt(p42)*p(n-1,3)/p3old + p(n-1,4) = E4new + tmp = p(n-1,4)**2-p(n-1,1)**2-p(n-1,2)**2-p(n-1,3)**2 + & -p(n-1,5)**2 + if (abs(tmp).gt.1.d-6) + & write(logfid,*) 'Oups, messed up scattering centres mass:', + & tmp,p3old,p(n-1,1),p(n-1,2),p(n-1,3),p(n-1,4),p(n-1,5) + if ((abs(p(n,1)+p(n-1,1)).gt.1.d-6).or. + & (abs(p(n,2)+p(n-1,2)).gt.1.d-6).or. + & (abs(p(n,3)+p(n-1,3)).gt.1.d-6)) + & write(logfid,*) 'Oups, momentum not conserved', + & p(n,1)+p(n-1,1),p(n,2)+p(n-1,2),p(n,3)+p(n-1,3) +!--------------------------------- +! P(N-1,1)=P(1,1) +! P(N-1,2)=P(1,2) +! P(N-1,3)=P(1,3) +! P(N-1,4)=P(1,4) +! P(N-1,5)=P(1,5) +!--------------------------------- + endif + +C--transformation to lab + CALL PYROBO(N-1,N,THETA,0d0,0d0,0d0,0d0) + CALL PYROBO(LINE,LINE,THETA,0d0,0d0,0d0,0d0) + CALL PYROBO(N-1,N,0d0,PHI,0d0,0d0,0d0) + CALL PYROBO(LINE,LINE,0d0,PHI,0d0,0d0,0d0) + CALL PYROBO(N-1,N,0d0,0d0,BETA(1),BETA(2),BETA(3)) + CALL PYROBO(LINE,LINE,0d0,0d0,BETA(1),BETA(2),BETA(3)) + CALL PYROBO(1,1,THETA,0d0,0d0,0d0,0d0) + CALL PYROBO(1,1,0d0,PHI,0d0,0d0,0d0) + CALL PYROBO(1,1,0d0,0d0,BETA(1),BETA(2),BETA(3)) + if (.not.allhad) then + k(n-1,1)=13 + else + IF(SCATRECOIL.AND.(P(N-1,4).GT.(10.*3.* + &GETTEMP(MV(1,1),MV(1,2),MV(1,3),MV(1,4)))))THEN + K(N-1,1)=2 + ELSE + K(N-1,1)=3 + ENDIF + endif + if (rejectt) k(n-1,1)=11 + MV(N,4)=MV(1,4) + MV(N-1,4)=MV(1,4) +C--set the production vertices: x_mother + (tprod - tprod_mother) * beta_mother + MV(N-1,1)=MV(line,1) + & +(MV(N-1,4)-MV(line,4))*P(line,1)/max(pyp(line,8),P(line,4)) + MV(N-1,2)=MV(line,2) + & +(MV(N-1,4)-MV(line,4))*P(line,2)/max(pyp(line,8),P(line,4)) + MV(N-1,3)=MV(line,3) + & +(MV(N-1,4)-MV(line,4))*P(line,3)/max(pyp(line,8),P(line,4)) + MV(N, 1)=MV(line,1) + & +(MV(N, 4)-MV(line,4))*P(line,1)/max(pyp(line,8),P(line,4)) + MV(N, 2)=MV(line,2) + & +(MV(N, 4)-MV(line,4))*P(line,2)/max(pyp(line,8),P(line,4)) + MV(N, 3)=MV(line,3) + & +(MV(N, 4)-MV(line,4))*P(line,3)/max(pyp(line,8),P(line,4)) + IF(P(N-1,5).GT.P(1,5))THEN + LAMBDA=1.d0/(FTFAC*0.2*P(N-1,4)/P(N-1,5)**2) + MV(N-1,5)=MV(N-1,4)-LOG(1.d0-PYR(0))/LAMBDA + ELSE + MV(N-1,5)=0.d0 + ENDIF + IF(J.LT.N2)THEN + MV(N,5)=SCATCENTRES(J+1,10) + ELSE + IF(P(N,5).GT.0.d0)THEN + IF(DELTAM.EQ.0.d0)THEN + ENDTIME=firsttime + ELSE + IF(X.LT.1.d0)THEN + LAMBDA=1.d0/(FTFAC*P(N,4)*0.2/P(N,5)**2) + ENDTIME=SCATCENTRES(J,10)-LOG(1.d0-PYR(0))/LAMBDA + ELSE + ENDTIME=TIME + ENDIF + ENDIF + MV(N,5)=ENDTIME + ELSE + MV(N,5)=0.d0 + ENDIF + ENDIF + MV(LINE,5)=ALLQS(J,6) + + +C--store scattering centre before interaction in separate common block + if (writescatcen.and.(.not.rejectt).and. + & (nscatcen.lt.maxnscatcen)) then + nscatcen = nscatcen+1 + if (nscatcen.le.maxnscatcen) then + scatflav(nscatcen) = k(1,2) + scatcen(nscatcen,1) = p(1,1) + scatcen(nscatcen,2) = p(1,2) + scatcen(nscatcen,3) = p(1,3) + scatcen(nscatcen,4) = p(1,4) + scatcen(nscatcen,5) = p(1,5) + else + write(logfid,*) + &'WARNING: no room left to store further scattering centres' + endif + endif + +! if ((p(line,4).gt.100.d0).and.(p(n,4)-p(line,4).gt.1.d0)) then +! write(*,*)p(line,1),p(line,2),p(line,3),p(line,4),p(line,5) +! write(*,*)p(n,1),p(n,2),p(n,3),p(n,4),p(n,5) +! write(*,*)p(1,1),p(1,2),p(1,3),p(1,4),p(1,5) +! write(*,*)p(n-1,1),p(n-1,2),p(n-1,3),p(n-1,4),p(n-1,5) +! write(*,*)t +! write(*,*)GETTEMP(MV(1,1),MV(1,2),MV(1,3),MV(1,4)) +! write(*,*) +! endif + + DMLEFT=DMLEFT-(p(n,5)-P(LINE,5)) + LINE=N + tmp = abs(p(n,4)**2-p(n,1)**2-p(n,2)**2-p(n,3)**2)-p(n,5)**2 + if (abs(tmp).ge.1.d-6) + & write(logfid,*)tmp,j,p(l,5),p(line,5),p(n,5) + 222 CONTINUE + if (p(n,5).lt.0.d0) then + RETRYSPLIT=.TRUE. + return + endif + if (p(n,5).ne.newm2) then + RETRYSPLIT=.TRUE. + redokin = .true. + n=nold + colmax=colmaxold + k(l,1)=statold + if (p(l,5).le.0.d0) then + newm2 = 0.d0 + else + if (p(l,5).lt.q0) then + if ((newm2.eq.newm).and.(newm.ne.q0+1.d-6)) then + newm2=q0+1.d-6 + else + RETRYSPLIT=.TRUE. + return + endif + else + newm2=p(l,5) + endif + n2=n1 + endif + goto 204 + endif + if ((k(n,1).eq.1).and. + & ((p(n,5).lt.0.d0).or.((p(n,5).gt.0.d0).and.(p(n,5).lt.q0)))) + &write(logfid,*)'dokinematics did not reach sensible mass: ', + &p(n,5),newm,p(l,5),newm2 + NSCATEFF=NSCATEFF+EVWEIGHT + END + + + +*********************************************************************** +*** function getproba +*********************************************************************** + DOUBLE PRECISION FUNCTION GETPROBA(QI,QF,QAA,ZAA,EBB,TYPE, + & T1,INS2) + IMPLICIT NONE +C--variables for Sudakov integration + COMMON/SUDAINT/QA,ZA2,EB,T,INSTATE,TYP + DOUBLE PRECISION QA,ZA2,EB,T + CHARACTER*2 TYP + LOGICAL INSTATE +C--local variables + DOUBLE PRECISION QI,QF,QAA,ZAA,EBB,GETSUDAKOV,DERIV,T1 + CHARACTER*2 TYPE + LOGICAL INS2 + + QA=QAA + ZA2=ZAA + EB=EBB + TYP=TYPE + T=T1 + INSTATE=INS2 + GETPROBA=GETSUDAKOV(QI,QAA,QF,ZAA,EBB,TYPE,T1,INS2) + & *DERIV(QF,1) + END + + +*********************************************************************** +*** function getsudakov +*********************************************************************** + DOUBLE PRECISION FUNCTION GETSUDAKOV(QMAX1,QA1,QB1,ZA1,EB1, + & TYPE3,T2,INS) + IMPLICIT NONE +C--identifier of file for hepmc output and logfile + common/hepmcid/hpmcfid,logfid + integer hpmcfid,logfid +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--variables for Sudakov integration + COMMON/SUDAINT/QA,ZA2,EB,T,INSTATE,TYP + DOUBLE PRECISION QA,ZA2,EB,T + CHARACTER*2 TYP + LOGICAL INSTATE +C--local variables + DOUBLE PRECISION QMAX1,QA1,QB1,ZA1,EB1,TMAX,TB,YSTART,EPSI, + &HFIRST,T2,GETINSUDAFAST,QB2 + CHARACTER*2 TYPE3 + LOGICAL INS + DATA EPSI/1.d-4/ + + QB2=QB1 + IF(INS)THEN + IF(QB2.LT.Q0) write(logfid,*) 'error: Q < Q0',QB2,QMAX1 + IF(QB2.LT.(Q0+1.d-10)) QB2=QB2+1.d-10 + ELSE + IF(QB2.LT.Q0) write(logfid,*) 'error: Q < min',QB2,QMAX1 + IF(QB2.LT.(Q0+1.d-10)) QB2=QB2+1.d-10 + ENDIF + IF(QB2.GE.(QMAX1-1.d-10)) THEN + GETSUDAKOV=1.d0 + ELSE + IF(INS)THEN + GETSUDAKOV=GETINSUDAFAST(QB1,QMAX1,TYPE3) + ELSE + QA=QA1 + ZA2=ZA1 + EB=EB1 + TYP=TYPE3 + T=T2 + INSTATE=.FALSE. + HFIRST=0.01*(QMAX1-QB1) + YSTART=0.d0 + CALL ODEINT(YSTART,QB2,QMAX1,EPSI,HFIRST,0.d0,1) + GETSUDAKOV=EXP(-YSTART) + ENDIF + ENDIF + END + + +*********************************************************************** +*** function getinsudakov +*********************************************************************** + DOUBLE PRECISION FUNCTION GETINSUDAKOV(QB,QMAX1,TYPE3) + IMPLICIT NONE +C--identifier of file for hepmc output and logfile + common/hepmcid/hpmcfid,logfid + integer hpmcfid,logfid +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--variables for Sudakov integration + COMMON/SUDAINT/QA,ZA2,EB,T,INSTATE,TYP + DOUBLE PRECISION QA,ZA2,EB,T + CHARACTER*2 TYP + LOGICAL INSTATE +C--local variables + DOUBLE PRECISION QMAX1,QB,QB1,ZA1,EA1,YSTART,EPSI, + &HFIRST + CHARACTER*2 TYPE3 + DATA EPSI/1.d-4/ + + QB1=QB + IF(QB1.LT.Q0) write(logfid,*) 'error: Q < Q0',QB1,QMAX1 + IF(QB1.LT.(Q0+1.d-12)) QB1=QB1+1.d-12 + IF(QB1.GE.(QMAX1-1.d-12)) THEN + GETINSUDAKOV=1.d0 + ELSE + TYP=TYPE3 + HFIRST=0.01*(QMAX1-QB1) + YSTART=0.d0 + CALL ODEINT(YSTART,QB1,QMAX1,EPSI,HFIRST,0.d0,6) + GETINSUDAKOV=EXP(-YSTART) + ENDIF + END + + +*********************************************************************** +*** function deriv +*********************************************************************** + DOUBLE PRECISION FUNCTION DERIV(XVAL,W4) + IMPLICIT NONE +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--variables for splitting function integration + COMMON/INTSPLITF/QQUAD,FM + DOUBLE PRECISION QQUAD,FM +C--variables for Sudakov integration + COMMON/SUDAINT/QA,ZA2,EB,T,INSTATE,TYP + DOUBLE PRECISION QA,ZA2,EB,T + CHARACTER*2 TYP + LOGICAL INSTATE +C--variables for pdf integration + COMMON/PDFINTV/XMAX,Z + DOUBLE PRECISION XMAX,Z +C--variables for cross section integration + COMMON/XSECV/QLOW,MDX + DOUBLE PRECISION QLOW,MDX +C--local variables + INTEGER W4 + DOUBLE PRECISION XVAL,GETSPLITI,PI,ALPHAS,GETINSPLITI, + &GETINSUDAFAST,SCATPRIMFUNC,PQQ,PQG,PGG,PGQ, + &MEDDERIV + DATA PI/3.141592653589793d0/ + + IF(W4.EQ.1)THEN +C--Sudakov integration + IF(INSTATE)THEN + DERIV=2.*GETINSPLITI(XVAL,TYP)/XVAL + ELSE + DERIV=2.*GETSPLITI(QA,XVAL,ZA2,EB,TYP)/XVAL + ENDIF + ELSEIF(W4.EQ.2)THEN +C--P(q->qg) integration + DERIV=(1.+FM)*ALPHAS(XVAL*(1.-XVAL)*QQUAD/1.,LPS)* + & PQQ(XVAL)/(2.*PI) + ELSEIF(W4.EQ.3)THEN +C--P(g->gg) integration + DERIV=(1.+FM)*ALPHAS(XVAL*(1.-XVAL)*QQUAD/1.,LPS) + & *PGG(XVAL)/(2.*PI) + ELSEIF(W4.EQ.4)THEN +C--P(g->qq) integration + DERIV=(1.+FM)*ALPHAS(XVAL*(1-XVAL)*QQUAD/1.,LPS)* + & PQG(XVAL)/(2.*PI) + ELSEIF(W4.EQ.5)THEN + DERIV=EXP(-XVAL)/XVAL + ELSEIF(W4.EQ.6)THEN + DERIV=2.*GETINSPLITI(XVAL,TYP)/XVAL + ELSEIF(W4.EQ.7)THEN + DERIV=2.*GETINSUDAFAST(XVAL,XMAX,'QQ') + & *ALPHAS((1.-Z)*XVAL**2/1.,LPS) + & *PQQ(Z)/(2.*PI*XVAL) + ELSEIF(W4.EQ.8)THEN + DERIV=2.*GETINSUDAFAST(XVAL,XMAX,'GC') + & *ALPHAS((1.-Z)*XVAL**2/1.,LPS) + & *PGQ(Z)/(2.*PI*XVAL) + ELSEIF(W4.EQ.9)THEN + DERIV=2.*GETINSUDAFAST(XVAL,XMAX,'QQ') + & *ALPHAS((1.-Z)*XVAL**2/1.,LPS) + & *PQG(Z)/(2.*PI*XVAL) + ELSEIF(W4.EQ.10)THEN + DERIV=2.*GETINSUDAFAST(XVAL,XMAX,'GC') + & *ALPHAS((1.-Z)*XVAL**2/1.,LPS)* + & *2.*PGG(Z)/(2.*PI*XVAL) + ELSEIF(W4.EQ.11)THEN + DERIV=3.*GETINSPLITI(SCALEFACM*SQRT(XVAL),'GQ') + & *SCATPRIMFUNC(XVAL,MDX)/(2.*XVAL) + ELSEIF(W4.EQ.12)THEN + DERIV=2.*GETINSPLITI(SCALEFACM*SQRT(XVAL),'QG') + & *SCATPRIMFUNC(XVAL,MDX)/(3.*XVAL) + ELSEIF(W4.EQ.13)THEN + DERIV=GETINSUDAFAST(QLOW,SCALEFACM*SQRT(XVAL),'GC') + & *3.*2.*PI*ALPHAS(XVAL+MDX**2,LQCD)**2/(2.*(XVAL+MDX**2)**2) + ELSEIF(W4.EQ.14)THEN + DERIV=GETINSUDAFAST(QLOW,SCALEFACM*SQRT(XVAL),'QQ') + & *2.*2.*PI*ALPHAS(XVAL+MDX**2,LQCD)**2/(3.*(XVAL+MDX**2)**2) + ELSEIF(W4.EQ.21)THEN + DERIV=2.*GETINSUDAFAST(XVAL,XMAX,'QQ')*GETINSPLITI(XVAL,'QQ') + & /XVAL + ELSEIF(W4.EQ.22)THEN + DERIV=2.*GETINSUDAFAST(XVAL,XMAX,'GC')*GETINSPLITI(XVAL,'GQ') + & /XVAL + ELSEIF(W4.EQ.23)THEN + DERIV=2.*GETINSUDAFAST(XVAL,XMAX,'QQ')*GETINSPLITI(XVAL,'QG') + & /XVAL + ELSEIF(W4.EQ.24)THEN + DERIV=2.*GETINSUDAFAST(XVAL,XMAX,'GC')*2. + & *GETINSPLITI(XVAL,'GG')/XVAL + ELSE + DERIV=MEDDERIV(XVAL,W4-100) + ENDIF + END + + +*********************************************************************** +*** function getspliti +*********************************************************************** + DOUBLE PRECISION FUNCTION GETSPLITI(QA,QB,ZETA,EB,TYPE1) + IMPLICIT NONE +C--identifier of file for hepmc output and logfile + common/hepmcid/hpmcfid,logfid + integer hpmcfid,logfid +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--splitting integral + COMMON/SPLITINT/SPLITIGGV(1000,1000),SPLITIQQV(1000,1000), + &SPLITIQGV(1000,1000),QVAL(1000),ZMVAL(1000),QMAX,ZMMIN,NPOINT + INTEGER NPOINT + DOUBLE PRECISION SPLITIGGV,SPLITIQQV,SPLITIQGV, + &QVAL,ZMVAL,QMAX,ZMMIN +C--variables for splitting function integration + COMMON/INTSPLITF/QQUAD,FM + DOUBLE PRECISION QQUAD,FM +C--number of extrapolations in tables + common/extrapolations/ntotspliti,noverspliti,ntotpdf,noverpdf, + &ntotxsec,noverxsec,ntotsuda,noversuda + integer ntotspliti,noverspliti,ntotpdf,noverpdf, + &ntotxsec,noverxsec,ntotsuda,noversuda +C--local variables + INTEGER I,J,LT,QLMAX,ZLMAX,QLINE,ZLINE + DOUBLE PRECISION QA,QB,ZETA,EB,LOW,X1A(2),X2A(2),YA(2,2),Y, + &SPLITINTGG,SPLITINTQG,A,B,YB(2) + CHARACTER*2 TYPE1 + + ntotspliti=ntotspliti+1 + if (qb.gt.qmax) then + noverspliti=noverspliti+1 + if (noverspliti.le.25) + & write(logfid,*)'WARNING in getspliti: need to extrapolate: ', + & qb,qmax + endif + +C--find boundaries for z integration + IF(ANGORD.AND.(ZETA.NE.1.d0))THEN + LOW=MAX(0.5-0.5*SQRT(1.-Q0**2/QB**2) + & *SQRT(1.-QB**2/EB**2), + & 0.5-0.5*SQRT(1.-4.*QB**2*(1.-ZETA)/(ZETA*QA**2))) + ELSE + LOW=0.5-0.5*SQRT(1.-Q0**2/QB**2) + & *SQRT(1.-QB**2/EB**2) + ENDIF +C--find values in array + QLMAX=INT((QB-QVAL(1))*NPOINT/(QVAL(1000)-QVAL(1))+1) + QLINE=MAX(QLMAX,1) + QLINE=MIN(QLINE,NPOINT) + ZLMAX=INT((LOG(LOW)-LOG(ZMVAL(1)))*NPOINT/ + & (LOG(ZMVAL(1000))-LOG(ZMVAL(1)))+1) + ZLINE=MAX(ZLMAX,1) + ZLINE=MIN(ZLINE,NPOINT) + IF((QLINE.GT.999).OR.(ZLINE.GT.999).OR. + & (QLINE.LT.1).OR.(ZLINE.LT.1))THEN + write(logfid,*)'ERROR in GETSPLITI: line number out of bound', + & QLINE,ZLINE + ENDIF + IF((TYPE1.EQ.'GG').OR.(TYPE1.EQ.'GC'))THEN + DO 17 I=1,2 + X1A(I)=QVAL(QLINE-1+I) + X2A(I)=ZMVAL(ZLINE-1+I) + DO 16 J=1,2 + YA(I,J)=SPLITIGGV(QLINE-1+I,ZLINE-1+J) + 16 CONTINUE + 17 CONTINUE + DO 30 I=1,2 + A=(YA(I,2)-YA(I,1))/(X2A(2)-X2A(1)) + B=YA(I,1)-A*X2A(1) + YB(I)=A*LOW+B + 30 CONTINUE + IF(X1A(1).EQ.X1A(2))THEN + Y=(YB(1)+YB(2))/2. + ELSE + A=(YB(2)-YB(1))/(X1A(2)-X1A(1)) + B=YB(1)-A*X1A(1) + Y=A*QB+B + ENDIF + IF(TYPE1.EQ.'GG')THEN + GETSPLITI=MIN(Y,10.d0) + ELSE + SPLITINTGG=MIN(Y,10.d0) + ENDIF + ENDIF + IF((TYPE1.EQ.'QG').OR.(TYPE1.EQ.'GC'))THEN + DO 19 I=1,2 + X1A(I)=QVAL(QLINE-1+I) + X2A(I)=ZMVAL(ZLINE-1+I) + DO 18 J=1,2 + YA(I,J)=SPLITIQGV(QLINE-1+I,ZLINE-1+J) + 18 CONTINUE + 19 CONTINUE + DO 31 I=1,2 + A=(YA(I,2)-YA(I,1))/(X2A(2)-X2A(1)) + B=YA(I,1)-A*X2A(1) + YB(I)=A*LOW+B + 31 CONTINUE + IF(X1A(1).EQ.X1A(2))THEN + Y=(YB(1)+YB(2))/2. + ELSE + A=(YB(2)-YB(1))/(X1A(2)-X1A(1)) + B=YB(1)-A*X1A(1) + Y=A*QB+B + ENDIF + IF(TYPE1.EQ.'QG')THEN + GETSPLITI=NF*MIN(Y,10.d0) + ELSE + SPLITINTQG=NF*MIN(Y,10.d0) + ENDIF + ENDIF + IF(TYPE1.EQ.'QQ')THEN + DO 21 I=1,2 + X1A(I)=QVAL(QLINE-1+I) + X2A(I)=ZMVAL(ZLINE-1+I) + DO 20 J=1,2 + YA(I,J)=SPLITIQQV(QLINE-1+I,ZLINE-1+J) + 20 CONTINUE + 21 CONTINUE + DO 32 I=1,2 + A=(YA(I,2)-YA(I,1))/(X2A(2)-X2A(1)) + B=YA(I,1)-A*X2A(1) + YB(I)=A*LOW+B + 32 CONTINUE + IF(X1A(1).EQ.X1A(2))THEN + Y=(YB(1)+YB(2))/2. + ELSE + A=(YB(2)-YB(1))/(X1A(2)-X1A(1)) + B=YB(1)-A*X1A(1) + Y=A*QB+B + ENDIF + GETSPLITI=MIN(Y,10.d0) + ENDIF + IF(TYPE1.EQ.'GC') GETSPLITI=SPLITINTGG+SPLITINTQG + END + + +*********************************************************************** +*** function getinspliti +*********************************************************************** + DOUBLE PRECISION FUNCTION GETINSPLITI(QB,TYPE1) + IMPLICIT NONE +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--local variables + DOUBLE PRECISION QB,LOW,PI,Y,SPLITINTGG,SPLITINTQG,UP,EI + CHARACTER*2 TYPE1 + DATA PI/3.141592653589793d0/ + +C--find boundaries for z integration + UP = 1. - Q0**2/(4.*QB**2) + IF((TYPE1.EQ.'GG').OR.(TYPE1.EQ.'GC'))THEN + LOW=1.d0-UP + IF (UP.LE.LOW) THEN + GETINSPLITI=0.d0 + RETURN + ENDIF + Y = 2.* ( LOG(LOG((1.-LOW)*QB**2/LPS**2)) + & - LPS**2*EI(LOG((1.-LOW)*QB**2/LPS**2))/QB**2 + & + LPS**4*EI(2.*LOG((1.-LOW)*QB**2/LPS**2))/QB**4 + & - LPS**6*EI(3.*LOG((1.-LOW)*QB**2/LPS**2))/QB**6 + & - LOG(LOG((1.-UP)*QB**2/LPS**2)) + & + LPS**2*EI(LOG((1.-UP)*QB**2/LPS**2))/QB**2 + & - LPS**4*EI(2.*LOG((1.-UP)*QB**2/LPS**2))/QB**4 + & + LPS**6*EI(3.*LOG((1.-UP)*QB**2/LPS**2))/QB**6 + & + LOW - LOG(LOW) - UP + LOG(UP) ) + & *3.*12.*PI/(2.*PI*(33.-2.*NF)) + IF(TYPE1.EQ.'GG')THEN + GETINSPLITI=Y + ELSE + SPLITINTGG=Y + ENDIF + ENDIF + IF((TYPE1.EQ.'QG').OR.(TYPE1.EQ.'GC'))THEN + LOW=0.d0 + IF (UP.LE.LOW) THEN + GETINSPLITI=0.d0 + RETURN + ENDIF + Y = ( 2.*LPS**6*EI(3.*LOG((1.-LOW)*QB**2/LPS**2))/QB**6 + & - 2.*LPS**4*EI(2.*LOG((1.-LOW)*QB**2/LPS**2))/QB**4 + & + 2.*LPS**2*EI(LOG((1.-LOW)*QB**2/LPS**2))/QB**2 + & - 2.*LPS**6*EI(3.*LOG((1.-UP)*QB**2/LPS**2))/QB**6 + & + 2.*LPS**4*EI(2.*LOG((1.-UP)*QB**2/LPS**2))/QB**4 + & - 2.*LPS**2*EI(LOG((1.-UP)*QB**2/LPS**2))/QB**2 ) + & *12.*PI/(2.*2.*PI*(33.-2.*NF)) + IF(TYPE1.EQ.'QG')THEN + GETINSPLITI=NF*Y + ELSE + SPLITINTQG=NF*Y + ENDIF + ENDIF + IF(TYPE1.EQ.'QQ')THEN + LOW=0.d0 + IF (UP.LE.LOW) THEN + GETINSPLITI=0.d0 + RETURN + ENDIF + Y = ( 2.*LOG(LOG((1.-LOW)*QB**2/LPS**2)) + & - 2.*LPS**2*EI(LOG((1.-LOW)*QB**2/LPS**2))/QB**2 + & + LPS**4*EI(2.*LOG((1.-LOW)*QB**2/LPS**2))/QB**4 + & - 2.*LOG(LOG((1.-UP)*QB**2/LPS**2)) + & + 2.*LPS**2*EI(LOG((1.-UP)*QB**2/LPS**2))/QB**2 + & - LPS**4*EI(2.*LOG((1.-UP)*QB**2/LPS**2))/QB**4 ) + & *4.*12.*PI/(3.*2.*PI*(33.-2.*NF)) + GETINSPLITI=Y + ENDIF + IF(TYPE1.EQ.'GQ')THEN + LOW=1.d0-UP + IF (UP.LE.LOW) THEN + GETINSPLITI=0.d0 + RETURN + ENDIF + Y = (UP**2/2.-2.*UP+2.*LOG(UP)-LOW**2/2.+2.*LOW- 2.*LOG(LOW)) + & *4.*12.*PI/(3.*2.*PI*(33.-2.*NF)*LOG(QB**2/LPS**2)) + GETINSPLITI=Y + ENDIF + IF(TYPE1.EQ.'GC') GETINSPLITI=SPLITINTGG+SPLITINTQG + END + + +*********************************************************************** +*** function getpdf +*********************************************************************** + DOUBLE PRECISION FUNCTION GETPDF(X,Q,TYP) + IMPLICIT NONE +C--identifier of file for hepmc output and logfile + common/hepmcid/hpmcfid,logfid + integer hpmcfid,logfid +C--pdf common block + COMMON/PDFS/QINQX(2,1000),GINQX(2,1000),QINGX(2,1000), + &GINGX(2,1000) + DOUBLE PRECISION QINQX,GINQX,QINGX,GINGX +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--variables for pdf integration + COMMON/PDFINTV/XMAX,Z + DOUBLE PRECISION XMAX,Z +C--local variables + DOUBLE PRECISION X,Q,QLOW,QHIGH,YSTART,EPSI,HFIRST + CHARACTER*2 TYP + DATA EPSI/1.d-4/ + + IF((X.LT.0.d0).OR.(X.GT.1.d0).OR.(Q.LT.Q0))THEN + write(logfid,*)'error in GETPDF: parameter out of bound',X,Q + GETPDF=0.d0 + RETURN + ENDIF + + IF(TYP.EQ.'QQ')THEN + Z=X + XMAX=Q +C--f_q^q + QLOW=MAX(Q0,Q0/(2.*SQRT(1.-X))) + QHIGH=Q + IF((QLOW.GE.QHIGH*(1.d0-1.d-10)).OR.(X.GT.1.d0-1.d-10))THEN + YSTART=0.d0 + ELSE + HFIRST=0.01*(QHIGH-QLOW) + YSTART=0.d0 + CALL ODEINT(YSTART,QLOW,QHIGH,EPSI,HFIRST,0.d0,7) + ENDIF + GETPDF=YSTART + ELSEIF(TYP.EQ.'GQ')THEN + Z=X + XMAX=Q +C--f_q^g + QLOW=MAX(Q0,MAX(Q0/(2.*SQRT(X)),Q0/(2.*SQRT(1.-X)))) + QHIGH=Q + IF((QLOW.GE.QHIGH*(1.d0-1.d-10)).OR.(X.LT.0.d0+1.d-10) + & .OR.(X.GT.1.d0-1.d-10))THEN + YSTART=0.d0 + ELSE + HFIRST=0.01*(QHIGH-QLOW) + YSTART=0.d0 + CALL ODEINT(YSTART,QLOW,QHIGH,EPSI,HFIRST,0.d0,8) + ENDIF + GETPDF=YSTART + ELSEIF(TYP.EQ.'QG')THEN + Z=X + XMAX=Q +C--f_q^g + QLOW=MAX(Q0,Q0/(2.*SQRT(1.-X))) + QHIGH=Q + IF((QLOW.GE.QHIGH*(1.d0-1.d-10)).OR.(X.GT.1.d0-1.d-10))THEN + YSTART=0.d0 + ELSE + HFIRST=0.01*(QHIGH-QLOW) + YSTART=0.d0 + CALL ODEINT(YSTART,QLOW,QHIGH,EPSI,HFIRST,0.d0,9) + ENDIF + GETPDF=YSTART + ELSEIF(TYP.EQ.'GG')THEN + Z=X + XMAX=Q +C--f_q^q + QLOW=MAX(Q0,MAX(Q0/(2.*SQRT(X)),Q0/(2.*SQRT(1.-X)))) + QHIGH=Q + IF((QLOW.GE.QHIGH*(1.d0-1.d-10)).OR.(X.LT.0.d0+1.d-10) + & .OR.(X.GT.1.d0-1d-10))THEN + YSTART=0.d0 + ELSE + HFIRST=0.01*(QHIGH-QLOW) + YSTART=0.d0 + CALL ODEINT(YSTART,QLOW,QHIGH,EPSI,HFIRST,0.d0,10) + ENDIF + GETPDF=YSTART + ELSE + write(logfid,*)'error: pdf-type ',TYP,' does not exist' + GETPDF=0.d0 + ENDIF + END + +*********************************************************************** +*** function getpdfxint +*********************************************************************** + DOUBLE PRECISION FUNCTION GETPDFXINT(Q,TYP) + IMPLICIT NONE +C--identifier of file for hepmc output and logfile + common/hepmcid/hpmcfid,logfid + integer hpmcfid,logfid +C--pdf common block + COMMON/PDFS/QINQX(2,1000),GINQX(2,1000),QINGX(2,1000), + &GINGX(2,1000) + DOUBLE PRECISION QINQX,GINQX,QINGX,GINGX +C--number of extrapolations in tables + common/extrapolations/ntotspliti,noverspliti,ntotpdf,noverpdf, + &ntotxsec,noverxsec,ntotsuda,noversuda + integer ntotspliti,noverspliti,ntotpdf,noverpdf, + &ntotxsec,noverxsec,ntotsuda,noversuda +C--local variables + INTEGER J,Q2CLOSE,Q2LINE + DOUBLE PRECISION Q,XA(2),YA(2),Y,A,B + CHARACTER*2 TYP + + ntotpdf=ntotpdf+1 + if (q**2.gt.QINQX(1,1000)) then + noverpdf=noverpdf+1 + if (noverpdf.le.25) + & write(logfid,*)'WARNING in getpdfxint: need to extrapolate: ', + & q**2,QINQX(1,1000) + endif + + Q2CLOSE=INT((LOG(Q**2)-LOG(QINQX(1,1)))*999.d0/ + & (LOG(QINQX(1,1000))-LOG(QINQX(1,1)))+1) + Q2LINE=MAX(Q2CLOSE,1) + Q2LINE=MIN(Q2LINE,999) + IF((Q2LINE.GT.999).OR.(Q2LINE.LT.1))THEN + write(logfid,*)'ERROR in GETPDFXINT: line number out of bound', + & Q2LINE + ENDIF + + IF(TYP.EQ.'QQ')THEN + DO 11 J=1,2 + XA(J)=QINQX(1,Q2LINE-1+J) + YA(J)=QINQX(2,Q2LINE-1+J) + 11 CONTINUE + ELSEIF(TYP.EQ.'GQ')THEN + DO 13 J=1,2 + XA(J)=GINQX(1,Q2LINE-1+J) + YA(J)=GINQX(2,Q2LINE-1+J) + 13 CONTINUE + ELSEIF(TYP.EQ.'QG')THEN + DO 15 J=1,2 + XA(J)=QINGX(1,Q2LINE-1+J) + YA(J)=QINGX(2,Q2LINE-1+J) + 15 CONTINUE + ELSEIF(TYP.EQ.'GG')THEN + DO 17 J=1,2 + XA(J)=GINGX(1,Q2LINE-1+J) + YA(J)=GINGX(2,Q2LINE-1+J) + 17 CONTINUE + ELSE + write(logfid,*)'error in GETPDFXINT: unknown integral type ',TYP + ENDIF + A=(YA(2)-YA(1))/(XA(2)-XA(1)) + B=YA(1)-A*XA(1) + Y=A*Q**2+B + GETPDFXINT=Y + END + + +*********************************************************************** +*** subroutine getpdfxintexact +*********************************************************************** + DOUBLE PRECISION FUNCTION GETPDFXINTEXACT(Q,TYP) + IMPLICIT NONE +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--variables for pdf integration + COMMON/PDFINTV/XMAX,Z + DOUBLE PRECISION XMAX,Z +C--local variables + DOUBLE PRECISION Q,EPSI,YSTART,HFIRST + CHARACTER*2 TYP + DATA EPSI/1.d-4/ + + HFIRST=0.01d0 + YSTART=0.d0 + XMAX=Q + Z=0.d0 + IF(TYP.EQ.'QQ')THEN + CALL ODEINT(YSTART,Q0,Q,EPSI,HFIRST,0.d0,21) + ELSEIF(TYP.EQ.'QG')THEN + CALL ODEINT(YSTART,Q0,Q,EPSI,HFIRST,0.d0,23) + ELSEIF(TYP.EQ.'GQ')THEN + CALL ODEINT(YSTART,Q0,Q,EPSI,HFIRST,0.d0,22) + ELSEIF(TYP.EQ.'GG')THEN + CALL ODEINT(YSTART,Q0,Q,EPSI,HFIRST,0.d0,24) + ENDIF + GETPDFXINTEXACT=YSTART + END + + +*********************************************************************** +*** function getxsecint +*********************************************************************** + DOUBLE PRECISION FUNCTION GETXSECINT(TM,MD,TYP2) + IMPLICIT NONE +C--identifier of file for hepmc output and logfile + common/hepmcid/hpmcfid,logfid + integer hpmcfid,logfid +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--cross secttion common block + COMMON/XSECS/INTQ1(1001,101),INTQ2(1001,101), + &INTG1(1001,101),INTG2(1001,101) + DOUBLE PRECISION INTQ1,INTQ2,INTG1,INTG2 +C--variables for cross section integration + COMMON/XSECV/QLOW,MDX + DOUBLE PRECISION QLOW,MDX +C--number of extrapolations in tables + common/extrapolations/ntotspliti,noverspliti,ntotpdf,noverpdf, + &ntotxsec,noverxsec,ntotsuda,noversuda + integer ntotspliti,noverspliti,ntotpdf,noverpdf, + &ntotxsec,noverxsec,ntotsuda,noversuda +C--local variables + INTEGER TLINE,TCLOSE,MDCLOSE,MDLINE,I,J + DOUBLE PRECISION TM,X1A(2),X2A(2),YA(2,2),Y,MD,YB(2),A,B + CHARACTER*2 TYP2 + + ntotxsec=ntotxsec+1 + if (tm.gt.intq1(1000,101)) then + noverxsec=noverxsec+1 + if (noverpdf.le.25) + & write(logfid,*)'WARNING in getxsecint: need to extrapolate: ', + & tm,intq1(1000,101) + endif + + TCLOSE=INT((LOG(TM)-LOG(INTQ1(1,101)))*999.d0/ + & (LOG(INTQ1(1000,101))-LOG(INTQ1(1,101)))+1) + TLINE=MAX(TCLOSE,1) + TLINE=MIN(TLINE,999) + MDCLOSE=INT((MD-INTQ1(1001,1))*99.d0/ + &(INTQ1(1001,100)-INTQ1(1001,1))+1) + MDLINE=MAX(MDCLOSE,1) + MDLINE=MIN(MDLINE,99) + IF((TLINE.GT.999).OR.(MDLINE.GT.99) + & .OR.(TLINE.LT.1).OR.(MDLINE.LT.1)) THEN + write(logfid,*)'ERROR in GETXSECINT: line number out of bound', + & TLINE,MDLINE + ENDIF + + IF(TYP2.EQ.'QA')THEN +C--first quark integral + DO 12 I=1,2 + X1A(I)=INTQ1(1001,MDLINE-1+I) + X2A(I)=INTQ1(TLINE-1+I,101) + DO 11 J=1,2 + YA(I,J)=INTQ1(TLINE-1+J,MDLINE-1+I) + 11 CONTINUE + 12 CONTINUE + ELSEIF(TYP2.EQ.'QB')THEN +C--second quark integral + DO 18 I=1,2 + X1A(I)=INTQ2(1001,MDLINE-1+I) + X2A(I)=INTQ2(TLINE-1+I,101) + DO 17 J=1,2 + YA(I,J)=INTQ2(TLINE-1+J,MDLINE-1+I) + 17 CONTINUE + 18 CONTINUE + ELSEIF(TYP2.EQ.'GA')THEN +C--first gluon integral + DO 14 I=1,2 + X1A(I)=INTG1(1001,MDLINE-1+I) + X2A(I)=INTG1(TLINE-1+I,101) + DO 13 J=1,2 + YA(I,J)=INTG1(TLINE-1+J,MDLINE-1+I) + 13 CONTINUE + 14 CONTINUE + ELSEIF(TYP2.EQ.'GB')THEN +C--second gluon integral + DO 16 I=1,2 + X1A(I)=INTG2(1001,MDLINE-1+I) + X2A(I)=INTG2(TLINE-1+I,101) + DO 15 J=1,2 + YA(I,J)=INTG2(TLINE-1+J,MDLINE-1+I) + 15 CONTINUE + 16 CONTINUE + ELSE + write(logfid,*)'error in GETXSECINT: unknown integral type ', + & TYP2 + ENDIF + DO 19 I=1,2 + A=(YA(I,2)-YA(I,1))/(X2A(2)-X2A(1)) + B=YA(I,1)-A*X2A(1) + YB(I)=A*TM+B + 19 CONTINUE + IF(X1A(1).EQ.X1A(2))THEN + Y=YB(1) + ELSE + A=(YB(2)-YB(1))/(X1A(2)-X1A(1)) + B=YB(1)-A*X1A(1) + Y=A*MD+B + ENDIF + GETXSECINT=Y + END + + +*********************************************************************** +*** function getinsudafast +*********************************************************************** + DOUBLE PRECISION FUNCTION GETINSUDAFAST(Q1,Q2,TYP) + IMPLICIT NONE +C--identifier of file for hepmc output and logfile + common/hepmcid/hpmcfid,logfid + integer hpmcfid,logfid +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--local variables + DOUBLE PRECISION Q1,Q2,GETINSUDARED + CHARACTER*2 TYP + + IF(Q2.LE.Q1)THEN + GETINSUDAFAST=1.d0 + ELSEIF(Q1.LE.Q0)THEN + GETINSUDAFAST=GETINSUDARED(Q2,TYP) + ELSE + GETINSUDAFAST=GETINSUDARED(Q2,TYP)/GETINSUDARED(Q1,TYP) + ENDIF + IF(GETINSUDAFAST.GT.1.d0) GETINSUDAFAST=1.d0 + IF(GETINSUDAFAST.LT.(-1.d-10))THEN + write(logfid,*)'ERROR: GETINSUDAFAST < 0:', + & GETINSUDAFAST,' for',Q1,' ',Q2,' ',TYP + ENDIF + if (getinsudafast.lt.0.d0) getinsudafast = 0.d0 + END + + +*********************************************************************** +*** function getinsudared +*********************************************************************** + DOUBLE PRECISION FUNCTION GETINSUDARED(Q,TYP2) + IMPLICIT NONE +C--identifier of file for hepmc output and logfile + common/hepmcid/hpmcfid,logfid + integer hpmcfid,logfid +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--Sudakov common block + COMMON/INSUDA/SUDAQQ(1000,2),SUDAQG(1000,2),SUDAGG(1000,2), + &SUDAGC(1000,2) + DOUBLE PRECISION SUDAQQ,SUDAQG,SUDAGG,SUDAGC +C--number of extrapolations in tables + common/extrapolations/ntotspliti,noverspliti,ntotpdf,noverpdf, + &ntotxsec,noverxsec,ntotsuda,noversuda + integer ntotspliti,noverspliti,ntotpdf,noverpdf, + &ntotxsec,noverxsec,ntotsuda,noversuda +C--local variables + INTEGER QCLOSE,QBIN,I + DOUBLE PRECISION Q,XA(2),YA(2),Y,A,B + CHARACTER*2 TYP2 + + ntotsuda=ntotsuda+1 + if (q.gt.sudaqq(1000,1)) then + noversuda=noversuda+1 + if (noversuda.le.25) + & write(logfid,*)'WARNING in getinsudared: need to extrapolate: ', + & q,sudaqq(1000,1) + endif + + QCLOSE=INT((LOG(Q)-LOG(SUDAQQ(1,1)))*999.d0 + & /(LOG(SUDAQQ(1000,1))-LOG(SUDAQQ(1,1)))+1) + QBIN=MAX(QCLOSE,1) + QBIN=MIN(QBIN,999) + IF((QBIN.GT.999).OR.(QBIN.LT.1)) THEN + write(logfid,*) + & 'ERROR in GETINSUDARED: line number out of bound',QBIN + ENDIF + IF(TYP2.EQ.'QQ')THEN + DO 16 I=1,2 + XA(I)=SUDAQQ(QBIN-1+I,1) + YA(I)=SUDAQQ(QBIN-1+I,2) + 16 CONTINUE + ELSEIF(TYP2.EQ.'QG')THEN + DO 17 I=1,2 + XA(I)=SUDAQG(QBIN-1+I,1) + YA(I)=SUDAQG(QBIN-1+I,2) + 17 CONTINUE + ELSEIF(TYP2.EQ.'GG')THEN + DO 18 I=1,2 + XA(I)=SUDAGG(QBIN-1+I,1) + YA(I)=SUDAGG(QBIN-1+I,2) + 18 CONTINUE + ELSEIF(TYP2.EQ.'GC')THEN + DO 19 I=1,2 + XA(I)=SUDAGC(QBIN-1+I,1) + YA(I)=SUDAGC(QBIN-1+I,2) + 19 CONTINUE + ELSE + write(logfid,*)'error in GETINSUDARED: unknown type ',TYP2 + ENDIF + A=(YA(2)-YA(1))/(XA(2)-XA(1)) + B=YA(1)-A*XA(1) + Y=A*Q+B + GETINSUDARED=Y + IF(GETINSUDARED.LT.(-1.d-10))THEN + write(logfid,*) 'ERROR: GETINSUDARED < 0:',GETINSUDARED,Q,TYP2 + ENDIF + if (getinsudared.lt.0.d0) getinsudared = 0.d0 + END + + +*********************************************************************** +*** function getsscat +*********************************************************************** + DOUBLE PRECISION FUNCTION GETSSCAT(EN,px,py,PZ,MP,LW,TYPE1,TYPE2, + & x,y,z,t,mode) + IMPLICIT NONE +C--identifier of file for hepmc output and logfile + common/hepmcid/hpmcfid,logfid + integer hpmcfid,logfid +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--variables for cross section integration + COMMON/XSECV/QLOW,MDX + DOUBLE PRECISION QLOW,MDX +C--local variables + integer mode + DOUBLE PRECISION UP,EN,LW,SCATPRIMFUNC,CCOL,MP, + &LOW,GETPDFXINT,GETXSECINT,MDEB,pz,pcms2,shat,gettemp, + &x,y,z,t,getmd,avmom(5),px,py,getmdmin,getmdmax,pproj,psct + CHARACTER TYPE1,TYPE2 + + IF(TYPE1.EQ.'Q')THEN + CCOL=2./3. + ELSE + CCOL=3./2. + ENDIF + if (mode.eq.0) then + mdeb = getmd(x,y,z,t) + call avscatcen(x,y,z,t, + & avmom(1),avmom(2),avmom(3),avmom(4),avmom(5)) + shat = avmom(5)**2 + mp**2 + + & 2.*(avmom(4)*en - avmom(1)*px - avmom(2)*py - avmom(3)*pz) + pcms2 = (shat+mp**2-avmom(5)**2)**2/(4.*shat)-mp**2 + up = 4.*pcms2 + else + if (mode.eq.1) then + mdeb = getmdmin() + else + mdeb = getmdmax() + endif + call maxscatcen(avmom(1),avmom(2),avmom(3),avmom(4),avmom(5)) + psct = sqrt(avmom(1)**2+avmom(2)**2+avmom(3)**2) + pproj = sqrt(px**2+py**2+pz**2) + shat = avmom(5)**2 + mp**2 + 2.*(en*avmom(4) + pproj*psct) + pcms2 = (shat+mp**2-avmom(5)**2)**2/(4.*shat)-mp**2 + up = 4.*pcms2 + endif + LOW=LW**2 + IF(LOW.GT.UP)THEN + GETSSCAT=0.d0 + RETURN + ENDIF + IF((TYPE2.EQ.'C').OR. + & ((TYPE1.EQ.'Q').AND.(TYPE2.EQ.'Q')).OR. + & ((TYPE1.EQ.'G').AND.(TYPE2.EQ.'G')))THEN + GETSSCAT=CCOL*(SCATPRIMFUNC(UP,MDEB)-SCATPRIMFUNC(LOW,MDEB)) + ELSE + GETSSCAT=0.d0 + ENDIF + LOW=Q0**2/SCALEFACM**2 + IF(UP.GT.LOW)THEN + IF(TYPE1.EQ.'Q')THEN + IF((TYPE2.EQ.'C').OR.(TYPE2.EQ.'G'))THEN + GETSSCAT=GETSSCAT+GETPDFXINT(SCALEFACM*SQRT(UP),'GQ') + & *3.*SCATPRIMFUNC(UP,MDEB)/2. + GETSSCAT=GETSSCAT-GETXSECINT(UP,MDEB,'QA') + ENDIF + ELSE + IF((TYPE2.EQ.'C').OR.(TYPE2.EQ.'G'))THEN + GETSSCAT=GETSSCAT+CCOL*(SCATPRIMFUNC(UP,MDEB)- + & SCATPRIMFUNC(LOW,MDEB)) + & - GETXSECINT(UP,MDEB,'GB') + ENDIF + IF((TYPE2.EQ.'C').OR.(TYPE2.EQ.'Q'))THEN + GETSSCAT=GETSSCAT+2.*GETPDFXINT(SCALEFACM*SQRT(UP),'QG') + & *2.*SCATPRIMFUNC(UP,MDEB)/3. + GETSSCAT=GETSSCAT-2.*GETXSECINT(UP,MDEB,'GA') + ENDIF + ENDIF + ENDIF + IF(GETSSCAT.LT.-1.d-4) + & write(logfid,*) 'error: cross section < 0',GETSSCAT,'for', + & EN,MP,LW,TYPE1,TYPE2,LW**2,UP + GETSSCAT=MAX(GETSSCAT,0.d0) + END + + + +*********************************************************************** +*** function getmass +*********************************************************************** + DOUBLE PRECISION FUNCTION GETMASS(QBMIN,QBMAX,THETA,EP,TYPE, + & MAX2,INS,ZDEC,QQBARDEC) + IMPLICIT NONE +C--identifier of file for hepmc output and logfile + common/hepmcid/hpmcfid,logfid + integer hpmcfid,logfid +C--Common block of Pythia + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + INTEGER N,NPAD,K + DOUBLE PRECISION P,V + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + INTEGER MSTU,MSTJ + DOUBLE PRECISION PARU,PARJ + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + INTEGER MDCY,MDME,KFDP + DOUBLE PRECISION BRAT +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--time common block + COMMON/TIME/MV(23000,5) + DOUBLE PRECISION MV +C--factor in front of alphas argument + COMMON/ALPHASFAC/PTFAC + DOUBLE PRECISION PTFAC +C--local variables + DOUBLE PRECISION qbmin,qbmax,theta,ep,max2,zdec, + &q2min,alphmax,alphas,log14,pref,q2max,sudaover,gmin, + &gmax,arg,cand,eps,trueeps,trueval,oest,weight,getinspliti, + &r,pyr,z,rz,thetanew,r2,pi,pqq,pgg,pqg,rmin + CHARACTER*2 TYPE + LOGICAL INS,QQBARDEC + DATA PI/3.141592653589793d0/ + + q2min = q0**2 + + alphmax = alphas(3.*ptfac*q2min/16.,lps) + log14 = log(0.25) + + IF(TYPE.EQ.'QQ')THEN + pref=4.*alphmax/(3.*2.*PI) + ELSE + pref=29.*alphmax/(8.*2.*PI) + ENDIF + +C--check if phase space available, return 0.d0 otherwise + IF((qbmax.LE.QBMIN).OR.(EP.LT.QBMIN)) THEN + getmass=0.d0 + ZDEC=0.d0 + QQBARDEC=.FALSE. + RETURN + ENDIF + + q2max = qbmax**2 +! 21 sudaover = exp(-pref*(log(q2min/(4.*q2max))**2 - log14**2)) +! IF(pyr(0).LE.sudaover)THEN + 21 if (q2max-qbmin**2.lt.1e-4)then + getmass=qbmin + zdec=0.5 + IF(TYPE.EQ.'QQ')THEN + QQBARDEC=.FALSE. + ELSE + IF(PYR(0).LT.PQG(0.5d0)/(PQG(0.5d0)+PGG(0.5d0)))THEN + QQBARDEC=.TRUE. + ELSE + QQBARDEC=.FALSE. + ENDIF + endif + return + endif + gmax = pref*log(q2min/(4.*q2max))**2 + if (qbmin.gt.0.d0) then + rmin = exp(pref*log(q2min/(4.*qbmin**2))**2-gmax) + else + rmin = 0.d0 + endif + + r=pyr(0)*(1.d0-rmin)+rmin + arg=gmax+log(r) + if(arg.lt.0.d0)then + getmass=0.d0 + ZDEC=0.d0 + QQBARDEC=.FALSE. + RETURN + endif +! r=pyr(0) +! gmin = pref*log14**2 +! gmax = pref*log(q2min/(4.*q2max))**2 +! arg = log(r*exp(gmax)+(1.-r)*exp(gmin)) + cand = q2min*exp(sqrt(arg/pref))/4. + eps = q2min/(4.*cand) + + if ((cand.lt.q2min).or.(cand.lt.qbmin**2)) then + getmass=0.d0 + ZDEC=0.d0 + QQBARDEC=.FALSE. + RETURN + endif + + IF((CAND.GT.MAX2**2).OR.(CAND.GT.EP**2))THEN + q2max=cand + goto 21 + ENDIF + + if (ins) then + trueval=getinspliti(sqrt(cand),type) + oest = -2.*pref*log(eps) + weight = trueval/oest + else +C--find true z interval + TRUEEPS=0.5-0.5*SQRT(1.-q2min/cand) + & *SQRT(1.-cand/EP**2) + IF(TRUEEPS.LT.EPS) + & WRITE(logfid,*)'error in getmass: true eps < eps',TRUEEPS,EPS + RZ=PYR(0) + z = 1.-eps**rz + if ((z.lt.trueeps).or.(z.gt.(1.-trueeps))) then + weight = 0. + else + if (type.eq.'QQ')then +! if (ins) then +! trueval = alphas(ptfac*(1.-z)*cand,lps)*pqq(z)/(2.*pi) +! else + trueval = alphas(ptfac*z*(1.-z)*cand,lps)*pqq(z)/(2.*pi) +! endif + oest = 2.*pref/(1.-z) + weight = trueval/oest + else + if (pyr(0).lt.(17./29.)) z = 1.-z +! if (ins)then +! trueval = alphas(ptfac*(1.-z)*cand,lps) +! & *(pgg(z)+pqg(z))/(2.*pi) +! else + trueval = alphas(ptfac*z*(1.-z)*cand,lps) + & *(pgg(z)+pqg(z))/(2.*pi) +! endif + oest = alphmax*(17./(4.*z)+3./(1.-z))/(2.*pi) + weight = trueval/oest + endif + thetanew = sqrt(cand/(z*(1.-z)))/ep + if (angord.and.(theta.gt.0.).and.(thetanew.gt.theta)) + & weight = 0.d0 + endif + endif + IF (WEIGHT.GT.1.d0) WRITE(logfid,*) + & 'problem in getmass: weight> 1', + & WEIGHT,TYPE,EPS,TRUEEPS,Z,CAND + R2=PYR(0) + IF(R2.GT.WEIGHT)THEN + q2max=cand + GOTO 21 + ELSE + getmass=sqrt(cand) + if (.not.ins) then + ZDEC=Z + IF(TYPE.EQ.'QQ')THEN + QQBARDEC=.FALSE. + ELSE + IF(PYR(0).LT.PQG(Z)/(PQG(Z)+PGG(Z)))THEN + QQBARDEC=.TRUE. + ELSE + QQBARDEC=.FALSE. + ENDIF + ENDIF + endif + ENDIF + END + + + +*********************************************************************** +*** function generatez +*********************************************************************** + DOUBLE PRECISION FUNCTION GENERATEZ(TI,EA,EPSI,TYPE) + IMPLICIT NONE +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--local variables + DOUBLE PRECISION TI,EA,EPS,PYR,X,R,HELP,R1,EPSI + CHARACTER*2 TYPE + + IF(TI.EQ.0.d0)THEN + EPS=EPSI + ELSE + EPS=MAX(0.5-0.5*SQRT(1.-Q0**2/TI) + & *SQRT(1.-TI/EA**2),EPSI) + ENDIF + IF(EPS.GT.0.5)THEN + GENERATEZ=0.5 + GOTO 61 + ENDIF + 60 R=PYR(0) + IF(TYPE.EQ.'QQ')THEN + X=1.-(1.-EPS)*(EPS/(1.-EPS))**R + R=PYR(0) + IF(R.LT.((1.+X**2)/2.))THEN + GENERATEZ=X + ELSE + GOTO 60 + ENDIF + ELSEIF(TYPE.EQ.'GG')THEN + X=1./(1.+((1.-EPS)/EPS)**(1.-2.*R)) + R=PYR(0) + HELP=((1.-X)/X+X/(1.-X)+X*(1.-X))/(1./(1.-X)+1./X) + IF(R.LT.HELP)THEN + GENERATEZ=X + ELSE + GOTO 60 + ENDIF + ELSE + R=PYR(0)*(1.-2.*EPS)+EPS + R1=PYR(0)/2. + HELP=0.5*(R**2+(1.-R)**2) + IF(R1.LT.HELP)THEN + GENERATEZ=R + ELSE + GOTO 60 + ENDIF + ENDIF + 61 END + + + +*********************************************************************** +*** function scatprimfunc +*********************************************************************** + DOUBLE PRECISION FUNCTION SCATPRIMFUNC(T,MDEB) + IMPLICIT NONE +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--local variables + DOUBLE PRECISION T,PI,S,EI,ALPHAS,T1,MDEB + DATA PI/3.141592653589793d0/ + + SCATPRIMFUNC = 2.*PI*(12.*PI)**2*( + & - EI(-LOG((T+MDEB**2)/LQCD**2))/LQCD**2 + & - 1./((T+MDEB**2)*LOG((T+MDEB**2)/LQCD**2)))/(33.-2.*NF)**2 + END + + + +*********************************************************************** +*** function intpqq +*********************************************************************** + DOUBLE PRECISION FUNCTION INTPQQ(Z,Q) + IMPLICIT NONE +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--local variables + DOUBLE PRECISION Z,Q + + INTPQQ=6.*4.*(-2.*LOG(LOG(Q**2/LPS**2) + & +LOG(1.-Z)))/((33.-2.*NF)*3.) + END + + + +*********************************************************************** +*** function intpgglow +*********************************************************************** + DOUBLE PRECISION FUNCTION INTPGGLOW(Z,Q) + IMPLICIT NONE +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--local variables + DOUBLE PRECISION Z,Q + + INTPGGLOW=6.*3.*(LOG(LOG(Q**2/LPS**2)+LOG(Z)))/(33.-2.*NF) + END + + + +*********************************************************************** +*** function intpgghigh +*********************************************************************** + DOUBLE PRECISION FUNCTION INTPGGHIGH(Z,Q) + IMPLICIT NONE +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--local variables + DOUBLE PRECISION Z,Q + + INTPGGHIGH=-6.*3.*(LOG(LOG(Q**2/LPS**2)+LOG(1.-Z)))/(33.-2.*NF) + END + + + +*********************************************************************** +*** function intpqglow +*********************************************************************** + DOUBLE PRECISION FUNCTION INTPQGLOW(Z,Q) + IMPLICIT NONE +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--local variables + DOUBLE PRECISION Z,Q,EI + + INTPQGLOW=6.*(LPS**2*EI(LOG(Q**2/LPS**2)+LOG(Z))/Q**2 + & - 2.*LPS**4*EI(2.*(LOG(Q**2/LPS**2)+LOG(Z)))/Q**4 + & + 2.*LPS**6*EI(3.*(LOG(Q**2/LPS**2)+LOG(Z)))/Q**6)/ + &((33.-2.*NF)*2.) + END + + + +*********************************************************************** +*** function intpqghigh +*********************************************************************** + DOUBLE PRECISION FUNCTION INTPQGHIGH(Z,Q) + IMPLICIT NONE +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--local variables + DOUBLE PRECISION Z,Q,EI + + INTPQGHIGH=-6.*(LPS**2*EI(LOG(Q**2/LPS**2)+LOG(1.-Z))/Q**2 + & - 2.*LPS**4*EI(2.*(LOG(Q**2/LPS**2)+LOG(1.-Z)))/Q**4 + & + 2.*LPS**6*EI(3.*(LOG(Q**2/LPS**2)+LOG(1.-Z)))/Q**6)/ + &((33.-2.*NF)*2.) + END + + + +*********************************************************************** +*** function gett +*********************************************************************** + DOUBLE PRECISION FUNCTION GETT(MINT,MAXT,MDEB) + IMPLICIT NONE +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--local variables + DOUBLE PRECISION TMIN,TMAX,MAXI,PYR,R1,R2,ALPHAS,PI,Y,MAXT, + &MDEB,MINT,T + DATA PI/3.141592653589793d0/ + + TMAX=MAXT+MDEB**2 + TMIN=MINT+MDEB**2 + IF(TMIN.GT.TMAX) THEN + GETT=0.d0 + RETURN + ENDIF + 20 R1=PYR(0) + T=TMAX*TMIN/(TMAX+R1*(TMIN-TMAX)) + R2=PYR(0) + IF(R2.LT.ALPHAS(T,LQCD)**2/ALPHAS(TMIN,LQCD)**2)THEN + GETT=T-MDEB**2 + ELSE + GOTO 20 + ENDIF + + END + + + +*********************************************************************** +*** function ei +*********************************************************************** + DOUBLE PRECISION FUNCTION EI(X) + IMPLICIT NONE +C--identifier of file for hepmc output and logfile + common/hepmcid/hpmcfid,logfid + integer hpmcfid,logfid +C--exponential integral for negative arguments + COMMON/EXPINT/EIXS(3,1000),VALMAX,NVAL + INTEGER NVAL + DOUBLE PRECISION EIXS,VALMAX +C--local variables + INTEGER K,LINE,LMAX + DOUBLE PRECISION X,R,GA,XA(2),YA(2),Y,DY,A,B + DOUBLE PRECISION YSTART,EPSI,HFIRST + DATA EPSI/1.e-5/ + + IF(DABS(X).GT.VALMAX) + & write(logfid,*)'warning: value out of array in Ei(x)',X,VALMAX + + IF(X.GE.0.d0)THEN + LMAX=INT(X*NVAL/VALMAX) + LINE=MAX(LMAX,1) + LINE=MIN(LINE,999) + IF((LINE.GT.999).OR.(LINE.LT.1)) THEN + write(logfid,*)'ERROR in EI: line number out of bound',LINE + ENDIF + DO 26 K=1,2 + XA(K)=EIXS(1,LINE-1+K) + YA(K)=EIXS(3,LINE-1+K) + 26 CONTINUE + A=(YA(2)-YA(1))/(XA(2)-XA(1)) + B=YA(1)-A*XA(1) + Y=A*X+B + ELSE + LMAX=INT(-X*NVAL/VALMAX) + LINE=MAX(LMAX,1) + LINE=MIN(LINE,999) + IF((LINE.GT.999).OR.(LINE.LT.1)) THEN + write(logfid,*)'ERROR in EI: line number out of bound',LINE + ENDIF + DO 27 K=1,2 + XA(K)=EIXS(1,LINE-1+K) + YA(K)=EIXS(2,LINE-1+K) + 27 CONTINUE + A=(YA(2)-YA(1))/(XA(2)-XA(1)) + B=YA(1)-A*XA(1) + Y=-A*X+B + ENDIF + EI=Y + END + + + +*********************************************************************** +*** function pqq +*********************************************************************** + DOUBLE PRECISION FUNCTION PQQ(Z) + IMPLICIT NONE + DOUBLE PRECISION Z + PQQ=4.*(1.+Z**2)/(3.*(1.-Z)) + END + + + +*********************************************************************** +*** function pgq +*********************************************************************** + DOUBLE PRECISION FUNCTION PGQ(Z) + IMPLICIT NONE + DOUBLE PRECISION Z + PGQ=4.*(1.+(1.-Z)**2)/(3.*Z) + END + + + +*********************************************************************** +*** function pgg +*********************************************************************** + DOUBLE PRECISION FUNCTION PGG(Z) + IMPLICIT NONE + DOUBLE PRECISION Z + PGG=3.*((1.-Z)/Z + Z/(1.-Z) + Z*(1.-Z)) + END + + + +*********************************************************************** +*** function pqg +*********************************************************************** + DOUBLE PRECISION FUNCTION PQG(Z) + IMPLICIT NONE + DOUBLE PRECISION Z + PQG=0.5*(Z**2 + (1.-Z)**2) + END + + + +*********************************************************************** +*** function alphas +*********************************************************************** + DOUBLE PRECISION FUNCTION ALPHAS(T,LAMBDA) + IMPLICIT NONE +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--local variables + DOUBLE PRECISION T,L0,PI,LAMBDA + DATA PI/3.141592653589793d0/ + + ALPHAS=4.*PI/((11.-2.*NF/3.)*LOG(T/LAMBDA**2)) + END + + + +*********************************************************************** +*** subroutine splitfncint +*********************************************************************** + SUBROUTINE SPLITFNCINT(EMAX) + IMPLICIT NONE +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--splitting integral + COMMON/SPLITINT/SPLITIGGV(1000,1000),SPLITIQQV(1000,1000), + &SPLITIQGV(1000,1000),QVAL(1000),ZMVAL(1000),QMAX,ZMMIN,NPOINT + INTEGER NPOINT + DOUBLE PRECISION SPLITIGGV,SPLITIQQV,SPLITIQGV, + &QVAL,ZMVAL,QMAX,ZMMIN +C--variables for splitting function integration + COMMON/INTSPLITF/QQUAD,FM + DOUBLE PRECISION QQUAD,FM +C--max rapidity + common/rapmax/etamax + double precision etamax +C--local variables + INTEGER NSTEP,I,J + DOUBLE PRECISION EMAX,ZMMAX,EPSI,HFIRST,YSTART,LNZMMIN, + &LNZMMAX,ZM,ZM2,Q,GETMSMAX,avmom(5),shat,pcms2 + DATA ZMMAX/0.5/ + DATA NSTEP/999/ + DATA EPSI/1.d-5/ + + call maxscatcen(avmom(1),avmom(2),avmom(3),avmom(4),avmom(5)) + shat = avmom(5)**2 + + & 2.*emax*(avmom(4)+sqrt(avmom(1)**2+avmom(2)**2+avmom(3)**2)) + pcms2 = (shat-avmom(5)**2)**2/(4.*shat) + qmax = sqrt(scalefacm*4.*pcms2) + + ZMMIN=Q0/EMAX + + LNZMMIN=LOG(ZMMIN) + LNZMMAX=LOG(ZMMAX) + + NPOINT=NSTEP + + DO 100 I=1,NSTEP+1 + Q=(I-1)*(QMAX-Q0)/NSTEP+Q0 + QVAL(I)=Q + QQUAD=Q**2 + DO 110 J=1,NSTEP+1 + ZM=EXP((J-1)*(LNZMMAX-LNZMMIN)/NSTEP+LNZMMIN) + ZMVAL(J)=ZM + IF(Q**2.LT.Q0**2)THEN + ZM2=0.5 + ELSE + ZM2=0.5-0.5*SQRT(1.-Q0**2/Q**2) + ENDIF + ZM=MAX(ZM,ZM2) + IF(ZM.EQ.0.5)THEN + SPLITIQQV(I,J)=0.d0 + SPLITIGGV(I,J)=0.d0 + SPLITIQGV(I,J)=0.d0 + ELSE + YSTART=0d0 + HFIRST=0.01 + FM=0.d0 + CALL ODEINT(YSTART,ZM,1.-ZM,EPSI,HFIRST,0d0,2) + SPLITIQQV(I,J)=YSTART + YSTART=0d0 + HFIRST=0.01 + FM=0.d0 + CALL ODEINT(YSTART,ZM,1.-ZM,EPSI,HFIRST,0d0,3) + SPLITIGGV(I,J)=YSTART + YSTART=0d0 + HFIRST=0.01 + FM=0.d0 + CALL ODEINT(YSTART,ZM,1.-ZM,EPSI,HFIRST,0d0,4) + SPLITIQGV(I,J)=YSTART + ENDIF + 110 CONTINUE + 100 CONTINUE + + END + + + +*********************************************************************** +*** subroutine pdfint +*********************************************************************** + SUBROUTINE PDFINT(EMAX) + IMPLICIT NONE +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--pdf common block + COMMON/PDFS/QINQX(2,1000),GINQX(2,1000),QINGX(2,1000), + &GINGX(2,1000) + DOUBLE PRECISION QINQX,GINQX,QINGX,GINGX +C--variables for pdf integration + COMMON/PDFINTV/XMAX,Z + DOUBLE PRECISION XMAX,Z +C--max rapidity + common/rapmax/etamax + double precision etamax +C--local variables + INTEGER I,J + DOUBLE PRECISION EMAX,Q2,GETPDFXINTEXACT,YSTART,HFIRST,EPSI, + &Q2MAX,DELTAQ2,avmom(5),shat,pcms2 + DATA EPSI/1.d-4/ + + call maxscatcen(avmom(1),avmom(2),avmom(3),avmom(4),avmom(5)) + shat = avmom(5)**2 + + & 2.*emax*(avmom(4)+sqrt(avmom(1)**2+avmom(2)**2+avmom(3)**2)) + pcms2 = (shat-avmom(5)**2)**2/(4.*shat) + q2max = scalefacm*4.*pcms2 + + DELTAQ2=LOG(Q2MAX)-LOG(Q0**2) + QINQX(1,1)=Q0**2 + GINQX(1,1)=Q0**2 + QINGX(1,1)=Q0**2 + GINGX(1,1)=Q0**2 + QINQX(2,1)=0.d0 + GINQX(2,1)=0.d0 + QINGX(2,1)=0.d0 + GINGX(2,1)=0.d0 + DO 12 J=2,1000 + Q2 = EXP((J-1)*DELTAQ2/999.d0 + LOG(Q0**2)) + QINQX(1,J)=Q2 + GINQX(1,J)=Q2 + QINGX(1,J)=Q2 + GINGX(1,J)=Q2 + QINQX(2,J)=GETPDFXINTEXACT(SQRT(Q2),'QQ') + GINQX(2,J)=GETPDFXINTEXACT(SQRT(Q2),'GQ') + QINGX(2,J)=GETPDFXINTEXACT(SQRT(Q2),'QG') + GINGX(2,J)=GETPDFXINTEXACT(SQRT(Q2),'GG') + 12 CONTINUE + END + + + +*********************************************************************** +*** subroutine xsecint +*********************************************************************** + SUBROUTINE XSECINT(EMAX) + IMPLICIT NONE +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--cross secttion common block + COMMON/XSECS/INTQ1(1001,101),INTQ2(1001,101), + &INTG1(1001,101),INTG2(1001,101) + DOUBLE PRECISION INTQ1,INTQ2,INTG1,INTG2 +C--variables for cross section integration + COMMON/XSECV/QLOW,MDX + DOUBLE PRECISION QLOW,MDX +C--max rapidity + common/rapmax/etamax + double precision etamax +C--local variables + INTEGER J,K + DOUBLE PRECISION EMAX,TMAX,TMAXMAX,DELTATMAX,YSTART,HFIRST,EPSI, + &GETMSMAX,GETMDMAX,MDMIN,MDMAX,DELTAMD,GETMDMIN,avmom(5),shat,pcms2 + DATA EPSI/1.d-4/ + + call maxscatcen(avmom(1),avmom(2),avmom(3),avmom(4),avmom(5)) + shat = avmom(5)**2 + + & 2.*emax*(avmom(4)+sqrt(avmom(1)**2+avmom(2)**2+avmom(3)**2)) + pcms2 = (shat-avmom(5)**2)**2/(4.*shat) + tmaxmax = scalefacm*4.*pcms2 + DELTATMAX=(LOG(TMAXMAX)- + & LOG(Q0**2*(1.d0+1.d-6)/SCALEFACM**2))/999.d0 + MDMIN=GETMDMIN() + MDMAX=MAX(MDMIN,GETMDMAX()) + DELTAMD=(MDMAX-MDMIN)/99.d0 + + DO 12 J=1,1000 + TMAX = EXP((J-1)*DELTATMAX + & + LOG(Q0**2*(1.d0+1.d-6)/SCALEFACM**2)) + INTQ1(J,101)=TMAX + INTQ2(J,101)=TMAX + INTG1(J,101)=TMAX + INTG2(J,101)=TMAX + DO 13 K=1,100 + MDX=MDMIN+(K-1)*DELTAMD + INTQ1(1001,K)=MDX + INTQ2(1001,K)=MDX + INTG1(1001,K)=MDX + INTG2(1001,K)=MDX + IF(TMAX.LT.Q0**2/SCALEFACM**2)THEN + INTQ1(J,K)=0.d0 + INTQ2(J,K)=0.d0 + INTG1(J,K)=0.d0 + INTG2(J,K)=0.d0 + ELSE +C--first quark integral + QLOW=Q0 + HFIRST=0.01*(TMAX-Q0**2/SCALEFACM**2) + YSTART=0.d0 + CALL ODEINT(YSTART,Q0**2/SCALEFACM**2,TMAX,EPSI,HFIRST + & ,0.d0,11) + INTQ1(J,K)=YSTART +C--second quark integral + QLOW=Q0 + HFIRST=0.01*(TMAX-Q0**2/SCALEFACM**2) + YSTART=0.d0 + CALL ODEINT(YSTART,Q0**2/SCALEFACM**2,TMAX,EPSI,HFIRST + & ,0.d0,14) + INTQ2(J,K)=YSTART +C--first gluon integral + QLOW=Q0 + YSTART=0.d0 + CALL ODEINT(YSTART,Q0**2/SCALEFACM**2,TMAX,EPSI,HFIRST + & ,0.d0,12) + INTG1(J,K)=YSTART +C--second gluon integral + QLOW=Q0 + YSTART=0.d0 + CALL ODEINT(YSTART,Q0**2/SCALEFACM**2,TMAX,EPSI,HFIRST + & ,0.d0,13) + INTG2(J,K)=YSTART + ENDIF + 13 CONTINUE + 12 CONTINUE + END + + + +*********************************************************************** +*** function insudaint +*********************************************************************** + SUBROUTINE INSUDAINT(EMAX) + IMPLICIT NONE +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--Sudakov common block + COMMON/INSUDA/SUDAQQ(1000,2),SUDAQG(1000,2),SUDAGG(1000,2), + &SUDAGC(1000,2) + DOUBLE PRECISION SUDAQQ,SUDAQG,SUDAGG,SUDAGC +C--max rapidity + common/rapmax/etamax + double precision etamax +C--local variables + INTEGER I + DOUBLE PRECISION QMAX,Q,GETINSUDAKOV,DELTA,EMAX,avmom(5), + &shat,pcms2 + + call maxscatcen(avmom(1),avmom(2),avmom(3),avmom(4),avmom(5)) + shat = avmom(5)**2 + + & 2.*emax*(avmom(4)+sqrt(avmom(1)**2+avmom(2)**2+avmom(3)**2)) + pcms2 = (shat-avmom(5)**2)**2/(4.*shat) + qmax = sqrt(scalefacm*4.*pcms2) + DELTA=(LOG(3.*QMAX)-LOG(Q0**2*(1.d0+1.d-6)))/999.d0 + DO 22 I=1,1000 + Q = EXP((I-1)*DELTA + LOG(Q0**2*(1.d0+1.d-6))) + SUDAQQ(I,1)=Q + SUDAQG(I,1)=Q + SUDAGG(I,1)=Q + SUDAGC(I,1)=Q + SUDAQQ(I,2)=GETINSUDAKOV(Q0,Q,'QQ') + SUDAQG(I,2)=GETINSUDAKOV(Q0,Q,'QG') + SUDAGG(I,2)=GETINSUDAKOV(Q0,Q,'GG') + SUDAGC(I,2)=GETINSUDAKOV(Q0,Q,'GC') + 22 CONTINUE + END + + + +*********************************************************************** +*** function eixint +*********************************************************************** + SUBROUTINE EIXINT + IMPLICIT NONE +C--exponential integral for negative arguments + COMMON/EXPINT/EIXS(3,1000),VALMAX,NVAL + INTEGER NVAL + DOUBLE PRECISION EIXS,VALMAX +C-local variables + INTEGER I,K + DOUBLE PRECISION X,EPSI,HFIRST,YSTART,EI,GA,R + DATA EPSI/1.d-5/ + + NVAL=1000 + VALMAX=55. + + DO 10 I=1,NVAL + X=I*VALMAX/(NVAL*1.d0) + EIXS(1,I)=X +C--do negative arguments first + YSTART=0d0 + HFIRST=0.01 + CALL ODEINT(YSTART,X,1000.d0,EPSI,HFIRST,0.d0,5) + EIXS(2,I)=-YSTART +C--now do the positive arguments + IF (X.EQ.0.0) THEN + EI=-1.0D+300 + ELSE IF (X.LE.40.0) THEN + EI=1.0D0 + R=1.0D0 + DO 15 K=1,100 + R=R*K*X/(K+1.0D0)**2 + EI=EI+R + IF (DABS(R/EI).LE.1.0D-15) GO TO 20 +15 CONTINUE +20 GA=0.5772156649015328D0 + EI=GA+DLOG(X)+X*EI + ELSE + EI=1.0D0 + R=1.0D0 + DO 25 K=1,20 + R=R*K/X +25 EI=EI+R + EI=DEXP(X)/X*EI + ENDIF + EIXS(3,I)=EI + 10 CONTINUE + END + + + +*********************************************************************** +*** function odeint +*********************************************************************** + subroutine odeint(ystart,a,b,eps,h1,hmin,w1) + implicit none +C--identifier of file for hepmc output and logfile + common/hepmcid/hpmcfid,logfid + integer hpmcfid,logfid +C--local variables + integer nmax,nstep,w1 + double precision ystart,a,b,eps,h1,hmin,x,h,y,dydx, + &deriv,yscale,hdid,hnew + data nmax/100000/ + + x = a + y = ystart + h = sign(h1,b-a) + do 20 nstep=1,nmax + dydx = deriv(x,w1) + yscale = abs(y) + abs(h*dydx) + 1.e-25 + if (((x + h - b)*h).gt.0.) h = b-x + call rkstepper(x,y,dydx,h,hdid,hnew,yscale,eps,w1) + if ((x - b)*h.ge.0) then + ystart = y + return + endif + h = hnew + if (abs(h).lt.abs(hmin)) then + write(logfid,*)'Error in odeint: stepsize too small',w1 + & ,ystart,a,b,h1 + return + endif + 20 continue + write(logfid,*)'Error in odeint: too many steps',w1 + & ,ystart,a,b,h1 + end + + + +*********************************************************************** +*** function rkstepper +*********************************************************************** + subroutine rkstepper(x,y,dydx,htest,hdid,hnew,yscale,eps,w1) + implicit none +C--identifier of file for hepmc output and logfile + common/hepmcid/hpmcfid,logfid + integer hpmcfid,logfid +C--local variables + integer w1 + double precision x,y,dydx,htest,hdid,hnew,yscale,eps, + &yhalf,y1,y2,rk4step,dydxhalf,xnew,delta,err,h,safety, powerdown, + &powerup,maxup,maxdown,deriv,fac + logical reject + data powerdown/0.25/ + data powerup/0.2/ + data safety/0.9/ + data maxdown/10./ + data maxup/5./ + + reject = .false. + h = htest + 10 xnew = x + h + if (x.eq.xnew) then + write(logfid,*)'Error in rkstepper: step size not significant' + return + endif + yhalf = rk4step(x,y,dydx,h/2.,w1) + dydxhalf = deriv(x+h/2.,w1) + y2 = rk4step(x+h/2.,yhalf,dydxhalf,h/2.,w1) + y1 = rk4step(x,y,dydx,h,w1) + delta = y2-y1 + err = abs(delta)/(yscale*eps) + if (err.gt.1.) then + reject = .true. + fac = max(1./maxdown,safety/err**powerdown) + h = h*fac + goto 10 + else + if (reject) then + hnew = h + else + fac = min(maxup,safety/err**powerup) + hnew = fac*h + endif + x = xnew + y = y2 + delta/15. + hdid = h + endif + end + + + +*********************************************************************** +*** function rk4step +*********************************************************************** + double precision function rk4step(x,y,dydx,h,w1) + implicit none + integer w1 + double precision x,y,dydx,h,k1,k2,k4,yout,deriv + k1 = h*dydx + k2 = h*deriv(x+h/2.,w1) + k4 = h*deriv(x+h,w1) + yout = y+k1/6.+2.*k2/3.+k4/6. + rk4step = yout + end + + + +*********************************************************************** +*** function getdeltat +*********************************************************************** + LOGICAL FUNCTION GETDELTAT(LINE,TSTART,DTMAX1,DELTAT) + IMPLICIT NONE +C--identifier of file for hepmc output and logfile + common/hepmcid/hpmcfid,logfid + integer hpmcfid,logfid +C--pythia common block + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + INTEGER N,NPAD,K + DOUBLE PRECISION P,V +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--time common block + COMMON/TIME/MV(23000,5) + DOUBLE PRECISION MV +C--max rapidity + common/rapmax/etamax + double precision etamax +C--memory for error message from getdeltat + common/errline/errl + integer errl +C--local variables + INTEGER LINE,I,NNULL + DOUBLE PRECISION DTMAX,SIGMAMAX,NEFFMAX,LINVMAX,PYR, + &R,TOFF,XS,YS,ZS,TS,GETSSCAT,GETMSMAX,GETMDMIN,MSMAX,MDMIN, + &XSTART,YSTART,ZSTART,WEIGHT,MS,MD,NEFF,SIGMA,GETNEFF, + &GETNEFFMAX,GETMS,GETMD,TAU,MDMAX,GETMDMAX,GETNATMDMIN, + &SIGMAMIN,NEFFMIN,TSTART,DTMAX1,DELTAT + CHARACTER PTYPE + LOGICAL STOPNOW + +C--initialization + GETDELTAT=.FALSE. + DELTAT=0.D0 + DTMAX=DTMAX1 + IF(K(LINE,2).EQ.21)THEN + PTYPE='G' + ELSE + PTYPE='Q' + ENDIF + + NNULL=0 + STOPNOW=.FALSE. + +C--check for upper bound from plasma lifetime + IF((TSTART+DTMAX).GE.LTIME)DTMAX=LTIME-TSTART + IF(DTMAX.LT.0.D0) RETURN + +C--calculate time relative to production of the considered parton + TOFF=TSTART-MV(LINE,4) + XSTART=MV(LINE,1)+TOFF*P(LINE,1)/P(LINE,4) + YSTART=MV(LINE,2)+TOFF*P(LINE,2)/P(LINE,4) + ZSTART=MV(LINE,3)+TOFF*P(LINE,3)/P(LINE,4) + +C--calculate upper limit for density*cross section + SIGMAMAX=GETSSCAT(P(LINE,4),p(line,1),p(line,2),p(line,3), +! & xstart,ystart,-sign(abs(zstart),p(line,3)),zstart+1.d-6) + & P(LINE,5),0.d0,PTYPE,'C',xstart,ystart,zstart,tstart,1) + SIGMAMIN=GETSSCAT(P(LINE,4),p(line,1),p(line,2),p(line,3), +! & xstart,ystart,-sign(abs(zstart),p(line,3)),zstart+1.d-6) + & P(LINE,5),0.d0,PTYPE,'C',xstart,ystart,zstart,tstart,2) + NEFFMAX=GETNEFFMAX() + NEFFMIN=GETNATMDMIN() + LINVMAX=5.d0*MAX(NEFFMIN*SIGMAMAX,NEFFMAX*SIGMAMIN) + if(linvmax.eq.0.d0) return + + DO 333 I=1,1000000 + DELTAT=DELTAT-LOG(PYR(0))/LINVMAX + XS=XSTART+DELTAT*P(LINE,1)/P(LINE,4) + YS=YSTART+DELTAT*P(LINE,2)/P(LINE,4) + ZS=ZSTART+DELTAT*P(LINE,3)/P(LINE,4) + TS=TSTART+DELTAT + IF(TS.LT.ZS)THEN + TAU=-1.d0 + ELSE + TAU=SQRT(TS**2-ZS**2) + ENDIF + NEFF=GETNEFF(XS,YS,ZS,TS) + IF((TAU.GT.1.d0).AND.(NEFF.EQ.0.d0))THEN + IF(NNULL.GT.4)THEN + STOPNOW=.TRUE. + ELSE + NNULL=NNULL+1 + ENDIF + ELSE + NNULL=0 + ENDIF + IF((DELTAT.GT.DTMAX).OR.STOPNOW) THEN + DELTAT=DTMAX + RETURN + ENDIF + IF(NEFF.GT.0.d0)THEN + SIGMA=GETSSCAT(P(LINE,4),p(line,1),p(line,2),p(line,3), + & P(LINE,5),0.d0,PTYPE,'C',xs,ys,zs,ts,0) + ELSE + SIGMA=0.d0 + ENDIF + WEIGHT=5.d0*NEFF*SIGMA/LINVMAX + IF(WEIGHT.GT.1.d0+1d-6) then + if (line.ne.errl) then + write(logfid,*)'error in GETDELTAT: weight > 1',WEIGHT, + & NEFF*SIGMA/(NEFFMAX*SIGMAMIN),NEFF*SIGMA/(NEFFMIN*SIGMAMAX), + & p(line,4) + errl=line + endif + endif + R=PYR(0) + IF(R.LT.WEIGHT)THEN + GETDELTAT=.TRUE. + RETURN + ENDIF + 333 CONTINUE + END + + + integer function poissonian(lambda) + implicit none + integer n + double precision lambda,disc,p,pyr,u,v,pi + data pi/3.141592653589793d0/ + + if (lambda.gt.745.d0) then + u = pyr(0); + v = pyr(0); + poissonian = + & int(sqrt(lambda)*sqrt(-2.*log(u))*cos(2.*pi*v)+lambda) + else + disc=exp(-lambda) + p=1.d0 + n=0 + 800 p = p*pyr(0) + if (p.gt.disc) then + n = n+1 + goto 800 + endif + poissonian=n + endif + end + + +*********************************************************************** +*** function ishadron +*********************************************************************** + LOGICAL FUNCTION ISHADRON(ID) + IMPLICIT NONE +C--local variables + INTEGER ID + IF(ABS(ID).LT.100) THEN + ISHADRON=.FALSE. + ELSE + IF(MOD(INT(ABS(ID)/10.),10).EQ.0) THEN + ISHADRON = .FALSE. + ELSE + ISHADRON = .TRUE. + ENDIF + ENDIF + END + + + +*********************************************************************** +*** function isdiquark +*********************************************************************** + LOGICAL FUNCTION ISDIQUARK(ID) + IMPLICIT NONE +C--local variables + INTEGER ID + IF(ABS(ID).LT.1000) THEN + ISDIQUARK=.FALSE. + ELSE + IF(MOD(INT(ID/10),10).EQ.0) THEN + ISDIQUARK = .TRUE. + ELSE + ISDIQUARK = .FALSE. + ENDIF + ENDIF + END + +*********************************************************************** +*** function islepton +*********************************************************************** + LOGICAL FUNCTION ISLEPTON(ID) + IMPLICIT NONE +C-- local variables + INTEGER ID + IF((ABS(ID).EQ.11).OR.(ABS(ID).EQ.13).OR.(ABS(ID).EQ.15)) THEN + ISLEPTON=.TRUE. + ELSE + ISLEPTON=.FALSE. + ENDIF + END + +*********************************************************************** +*** function isparton +*********************************************************************** + LOGICAL FUNCTION ISPARTON(ID) + IMPLICIT NONE +C--local variables + INTEGER ID + LOGICAL ISDIQUARK + IF((ABS(ID).LT.6).OR.(ID.EQ.21).OR.ISDIQUARK(ID)) THEN + ISPARTON=.TRUE. + ELSE + ISPARTON=.FALSE. + ENDIF + END + + + +*********************************************************************** +*** function isprimstring +*********************************************************************** + logical function isprimstring(l) + implicit none + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + INTEGER N,NPAD,K + DOUBLE PRECISION P,V +C--local variables + integer l + logical isparton + if ((K(l,2).ne.91).and.(K(l,2).ne.92)) then + isprimstring=.false. + return + endif + if ((K(K(l,3),3).eq.0).or.(isparton(K(K(K(l,3),3),2)))) then + isprimstring=.true. + else + isprimstring=.false. + endif + end + + + +*********************************************************************** +*** function issecstring +*********************************************************************** + logical function issecstring(l) + implicit none + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + INTEGER N,NPAD,K + DOUBLE PRECISION P,V +C--local variables + integer l + logical isparton,isprimstring + if ((K(l,2).ne.91).and.(K(l,2).ne.92)) then + issecstring = .false. + return + endif + if (isprimstring(l)) then + issecstring = .false. + return + endif + if (isparton(K(K(K(l,3),3),2))) then + issecstring = .false. + else + issecstring = .true. + endif + end + + + +*********************************************************************** +*** function isprimhadron +*********************************************************************** + logical function isprimhadron(l) + implicit none + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + INTEGER N,NPAD,K + DOUBLE PRECISION P,V +C--local variables + integer l + logical isprimstring,isparton + if (((K(K(l,3),2).EQ.91).OR.(K(K(l,3),2).EQ.92)) + & .and.isprimstring(K(l,3)) + & .and.(.not.isparton(K(l,2)))) then + isprimhadron=.true. + else + isprimhadron=.false. + endif + if (k(l,1).eq.17) isprimhadron=.true. + end + + + +*********************************************************************** +*** function compressevent +*********************************************************************** + logical function compressevent(l1) + implicit none +C--identifier of file for hepmc output and logfile + common/hepmcid/hpmcfid,logfid + integer hpmcfid,logfid + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + INTEGER N,NPAD,K + DOUBLE PRECISION P,V +C--variables for angular ordering + COMMON/ANGOR/ZA(23000),ZD(23000),THETAA(23000),QQBARD(23000) + DOUBLE PRECISION ZA,ZD,THETAA + LOGICAL QQBARD +C--time common block + COMMON/TIME/MV(23000,5) + DOUBLE PRECISION MV +C--colour index common block + COMMON/COLOUR/TRIP(23000),ANTI(23000),COLMAX + INTEGER TRIP,ANTI,COLMAX +C--local variables + integer l1,i,j,nold,nnew,nstart + + nold = n + + do 777 i=2,nold + if (((k(i,1).eq.11).or.(k(i,1).eq.12).or.(k(i,1).eq.13)).and. + & (i.ne.l1)) then + nnew = i + goto 778 + endif + 777 continue + compressevent = .false. + return + 778 continue + nstart = nnew + do 779 i=nstart,nold + if (((k(i,1).ne.11).and.(k(i,1).ne.12).and.(k(i,1).ne.13)).or. + & (i.eq.l1)) then + do 780 j=1,5 + p(nnew,j)=p(i,j) + v(nnew,j)=v(i,j) + mv(nnew,j)=mv(i,j) + 780 continue + trip(nnew)=trip(i) + anti(nnew)=anti(i) + za(nnew)=za(i) + zd(nnew)=zd(i) + thetaa(nnew)=thetaa(i) + qqbard(nnew)=qqbard(i) + k(nnew,1)=k(i,1) + k(nnew,2)=k(i,2) + k(nnew,3)=0 + k(nnew,4)=0 + k(nnew,5)=0 + if (l1.eq.i) l1=nnew + nnew=nnew+1 + endif + 779 continue + n=nnew-1 + if ((nold-n).le.10) then + compressevent = .false. + else + compressevent = .true. + endif + do 781 i=nnew,nold + do 782 j=1,5 + k(i,j)=0 + p(i,j)=0.d0 + v(i,j)=0.d0 + mv(i,j)=0.d0 + 782 continue + trip(i)=0 + anti(i)=0 + za(i)=0.d0 + zd(i)=0.d0 + thetaa(i)=0.d0 + qqbard(i)=.false. + 781 continue + if (n.gt.23000) write(logfid,*)'Error in compressevent: n = ',n + if (l1.gt.n) write(logfid,*)'Error in compressevent: l1 = ',l1 + call flush(logfid) + return + end + + + +*********************************************************************** +*** subroutine pevrec +*********************************************************************** + SUBROUTINE PEVREC(NUM,COL) +C--identifier of file for hepmc output and logfile + implicit none + common/hepmcid/hpmcfid,logfid + integer hpmcfid,logfid + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + INTEGER N,NPAD,K + DOUBLE PRECISION P,V +C--variables for angular ordering + COMMON/ANGOR/ZA(23000),ZD(23000),THETAA(23000),QQBARD(23000) + DOUBLE PRECISION ZA,ZD,THETAA + LOGICAL QQBARD +C--time common block + COMMON/TIME/MV(23000,5) + DOUBLE PRECISION MV +C--colour index common block + COMMON/COLOUR/TRIP(23000),ANTI(23000),COLMAX + INTEGER TRIP,ANTI,COLMAX + INTEGER NUM,i + LOGICAL COL + + DO 202 I=1,N + V(I,1)=MV(I,1) + V(I,2)=MV(I,2) + V(I,3)=MV(I,3) + V(I,4)=MV(I,4) + V(I,5)=MV(I,5) + IF(COL) write(logfid,*)I,' (',TRIP(I),',',ANTI(I),') [', + &K(I,3),K(I,4),K(I,5),' ] {',K(I,2),K(I,1),' } ', + &ZD(I),THETAA(I) + 202 CONTINUE + CALL PYLIST(NUM) + + END + + + +*********************************************************************** +*** subroutine converttohepmc +*********************************************************************** + SUBROUTINE CONVERTTOHEPMC(J,EVNUM,PID,beam1,beam2) + IMPLICIT NONE + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + INTEGER N,NPAD,K + DOUBLE PRECISION P,V + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + INTEGER MSTP,MSTI + DOUBLE PRECISION PARP,PARI +C--Parameter common block + COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM,ANGORD,SCATRECOIL, + &ALLHAD,compress,NF + INTEGER NF + DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM + LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress +C--organisation of event record + common/evrecord/nsim,npart,offset,hadrotype,sqrts,collider,hadro, + &shorthepmc,channel,isochannel + integer nsim,npart,offset,hadrotype + double precision sqrts + character*4 collider,channel + character*2 isochannel + logical hadro,shorthepmc +C--extra storage for scattering centres before interactions + common/storescatcen/nscatcen,maxnscatcen,scatflav(10000), + &scatcen(10000,5),writescatcen,writedummies + integer nscatcen,maxnscatcen,scatflav + double precision scatcen + logical writescatcen,writedummies +C--local variables + INTEGER EVNUM,PBARCODE,VBARCODE,CODELIST(25000),I,PID,NSTART, + &NFIRST,NVERTEX,NTOT,J,CODEFIRST + DOUBLE PRECISION mproton,mneutron,pdummy,pscatcen + LOGICAL ISHADRON,ISDIQUARK,ISPARTON,isprimhadron,isprimstring, + &issecstring + character*2 beam1,beam2 + data mproton/0.9383/ + data mneutron/0.9396/ + data pdummy/1.d-6/ + + 5000 FORMAT(A2,I10,I3,3E14.6,2I2,I6,4I2,E14.6) + 5100 FORMAT(A2,2E14.6) + 5200 FORMAT(A2,6I7,2I2,1I7,4E14.6) + 5300 FORMAT(A2,2I2,5E14.6,2I2) + 5400 FORMAT(A2,I6,6I2,I6,I2) + 5500 FORMAT(A2,I6,I6,5E14.6,3I2,I6,I2) + + PBARCODE=0 + VBARCODE=0 + + if (shorthepmc) then +C--short output + IF(COLLIDER.EQ.'EEJJ')THEN + NVERTEX=3 + PBARCODE=5 + ELSE + NVERTEX=1 + PBARCODE=2 + ENDIF + nfirst = 0 + do 131 i=1,N + if (((k(i,1).lt.6).or.(k(i,1).eq.17))) + & nfirst = nfirst+1 + 131 continue + if(writescatcen) NFIRST=NFIRST+nscatcen + if(writedummies) NFIRST=NFIRST+nscatcen + + WRITE(J,5000)'E ',EVNUM,-1,0.d0,0.d0,0.d0,0,0,NVERTEX,1,2,0,1, + &PARI(10) + WRITE(J,'(A2,I2,A5)')'N ',1,'"0"' + WRITE(J,'(A)')'U GEV MM' + WRITE(J,5100)'C ',PARI(1)*1.d9,0.d0 + WRITE(J,5200)'H ',0,0,0,0,0,0,0,0,0,0.d0,0.d0,0.d0,0.d0 + WRITE(J,5300)'F ',0,0,-1.d0,-1.d0,-1.d0,-1.d0,-1.d0,0,0 +C--write out vertex line + IF(COLLIDER.EQ.'EEJJ')THEN + WRITE(J,5400)'V ',-1,0,0,0,0,0,2,1,0 + WRITE(J,5500)'P ',1,-11,0.d0,0.d0,sqrts/2.,sqrts/2., + & 0.00051,2,0,0,-1,0 + WRITE(J,5500)'P ',2,11,0.d0,0.d0,-sqrts/2.,sqrts/2., + & 0.00051,2,0,0,-1,0 + WRITE(J,5500)'P ',3,23,0.d0,0.d0,0.d0,sqrts, + & 91.2,2,0,0,-2,0 + WRITE(J,5400)'V ',-2,0,0,0,0,0,0,2,0 + WRITE(J,5500)'P ',4,PID,sqrts/2.,0.d0,0.d0,sqrts/2., + & 0.000,2,0,0,-3,0 + WRITE(J,5500)'P ',5,-PID,-sqrts/2.,0.d0,0.d0,sqrts/2., + & 0.000,2,0,0,-3,0 + WRITE(J,5400)'V ',-3,0,0,0,0,0,0,NFIRST,0 + ELSE + WRITE(J,5400)'V ',-1,0,0,0,0,0,2,NFIRST,0 + if (beam1.eq.'p+') then + WRITE(J,5500)'P ',1,2212,0.d0,0.d0, + & sqrt(sqrts**2/4.-mproton**2),sqrts/2.,mproton,2,0,0,-1,0 + else + WRITE(J,5500)'P ',1,2112,0.d0,0.d0, + & sqrt(sqrts**2/4.-mneutron**2),sqrts/2.,mneutron,2,0,0,-1,0 + endif + if (beam2.eq.'p+') then + WRITE(J,5500)'P ',2,2212,0.d0,0.d0, + & -sqrt(sqrts**2/4.-mproton**2),sqrts/2.,mproton,2,0,0,-1,0 + else + WRITE(J,5500)'P ',2,2112,0.d0,0.d0, + & -sqrt(sqrts**2/4.-mneutron**2),sqrts/2.,mneutron,2,0,0,-1,0 + endif + ENDIF +C--write out scattering centres + if(writescatcen) then + do 133 i=1,nscatcen + pbarcode=pbarcode+1 + WRITE(J,5500)'P ',pbarcode,scatflav(i),scatcen(I,1), + & scatcen(I,2),scatcen(I,3),scatcen(I,4),scatcen(I,5), + & 3,0,0,0,0 + 133 continue + endif +C--write out dummy particles + if(writedummies) then + do 135 i=1,nscatcen + pbarcode=pbarcode+1 + pscatcen=sqrt(scatcen(I,1)**2+scatcen(I,2)**2+ + & scatcen(I,3)**2) + WRITE(J,5500)'P ',pbarcode,111,pdummy*scatcen(I,1)/pscatcen, + & pdummy*scatcen(I,2)/pscatcen,pdummy*scatcen(I,3)/pscatcen, + & pdummy,0.d0,1,0,0,0,0 + 135 continue + endif +C--write out particle lines + do 132 i=1,N + if(((k(i,1).lt.6).or.(k(i,1).eq.17))) then + pbarcode=pbarcode+1 + if((k(i,1).eq.3).or.(k(i,1).eq.5)) then + WRITE(J,5500)'P ',PBARCODE,K(I,2),P(I,1),P(I,2),P(I,3), + & P(I,4),P(I,5),4,0,0,0,0 + else + WRITE(J,5500)'P ',PBARCODE,K(I,2),P(I,1),P(I,2),P(I,3), + & P(I,4),P(I,5),1,0,0,0,0 + endif + endif + 132 continue + + else +C--long output + if (hadro) then +C--hadronised events + NFIRST=0 + IF(COLLIDER.EQ.'EEJJ')THEN + NVERTEX=3 + ELSE + NVERTEX=1 + ENDIF + DO 123 I=1,N + IF(K(i,3).ne.0)THEN + NSTART=I + GOTO 124 + ENDIF + 123 CONTINUE + 124 CONTINUE + nstart=0 + + DO 126 I=NSTART+1,N + IF(isprimhadron(i)) NFIRST=NFIRST+1 + IF((ISHADRON(K(I,2)).OR.(ABS(K(I,2)).EQ.15)) + & .AND.(K(I,4).NE.0)) NVERTEX=NVERTEX+1 + 126 CONTINUE + 127 CONTINUE + + if(writescatcen) NFIRST=NFIRST+nscatcen + if(writedummies) NFIRST=NFIRST+nscatcen + + WRITE(J,5000)'E ',EVNUM,-1,0.d0,0.d0,0.d0,0,0,NVERTEX, + &1,2,0,1,PARI(10) + WRITE(J,'(A2,I2,A5)')'N ',1,'"0"' + WRITE(J,'(A)')'U GEV MM' + WRITE(J,5100)'C ',PARI(1)*1.d9,0.d0 + WRITE(J,5200)'H ',0,0,0,0,0,0,0,0,0,0.d0,0.d0,0.d0,0.d0 + WRITE(J,5300)'F ',0,0,-1.d0,-1.d0,-1.d0,-1.d0,-1.d0,0,0 + +C--write out vertex line + IF(COLLIDER.EQ.'EEJJ')THEN + VBARCODE=-3 + PBARCODE=5 + ELSE + VBARCODE=-1 + PBARCODE=2 + ENDIF + IF(COLLIDER.EQ.'EEJJ')THEN + WRITE(J,5400)'V ',-1,0,0,0,0,0,2,1,0 + WRITE(J,5500)'P ',1,-11,0.d0,0.d0,sqrts/2.,sqrts/2., + & 0.00051,2,0,0,-1,0 + WRITE(J,5500)'P ',2,11,0.d0,0.d0,-sqrts/2.,sqrts/2., + & 0.00051,2,0,0,-1,0 + WRITE(J,5500)'P ',3,23,0.d0,0.d0,0.d0,sqrts, + & 91.2,2,0,0,-2,0 + WRITE(J,5400)'V ',-2,0,0,0,0,0,0,2,0 + WRITE(J,5500)'P ',4,PID,sqrts/2.,0.d0,0.d0,sqrts/2., + & 0.000,2,0,0,-3,0 + WRITE(J,5500)'P ',5,-PID,-sqrts/2.,0.d0,0.d0,sqrts/2., + & 0.000,2,0,0,-3,0 + WRITE(J,5400)'V ',VBARCODE,0,0,0,0,0,0,NFIRST,0 + ELSE + WRITE(J,5400)'V ',-1,0,0,0,0,0,2,NFIRST,0 + if (beam1.eq.'p+') then + WRITE(J,5500)'P ',1,2212,0.d0,0.d0, + & sqrt(sqrts**2/4.-mproton**2),sqrts/2.,mproton,2,0,0,-1,0 + else + WRITE(J,5500)'P ',1,2112,0.d0,0.d0, + & sqrt(sqrts**2/4.-mneutron**2),sqrts/2.,mneutron,2,0,0,-1,0 + endif + if (beam2.eq.'p+') then + WRITE(J,5500)'P ',2,2212,0.d0,0.d0, + & -sqrt(sqrts**2/4.-mproton**2),sqrts/2.,mproton,2,0,0,-1,0 + else + WRITE(J,5500)'P ',2,2112,0.d0,0.d0, + & -sqrt(sqrts**2/4.-mneutron**2),sqrts/2.,mneutron,2,0,0,-1,0 + endif + ENDIF + + CODEFIRST=NFIRST+PBARCODE + +C--write out scattering centres + if(writescatcen) then + do 134 i=1,nscatcen + pbarcode=pbarcode+1 + WRITE(J,5500)'P ',PBARCODE,scatflav(I),scatcen(I,1), + & scatcen(I,2),scatcen(I,3),scatcen(I,4),scatcen(I,5), + & 3,0,0,0,0 + 134 continue + endif +C--write out dummy particles + if(writedummies) then + do 136 i=1,nscatcen + pbarcode=pbarcode+1 + pscatcen=sqrt(scatcen(I,1)**2+scatcen(I,2)**2+ + & scatcen(I,3)**2) + WRITE(J,5500)'P ',pbarcode,111,pdummy*scatcen(I,1)/pscatcen, + & pdummy*scatcen(I,2)/pscatcen,pdummy*scatcen(I,3)/pscatcen, + & pdummy,0.d0,1,0,0,0,0 + 136 continue + endif + +C--first write out all particles coming directly from string or cluster decays + DO 125 I=NSTART+1,N + IF(.not.isprimhadron(i))THEN + GOTO 125 + ELSE + IF (PBARCODE.EQ.CODEFIRST) GOTO 130 + PBARCODE=PBARCODE+1 +C--write out particle line + IF(K(I,4).GT.0)THEN + VBARCODE=VBARCODE-1 + CODELIST(I)=VBARCODE + WRITE(J,5500)'P ',PBARCODE,K(I,2),P(I,1),P(I,2),P(I,3), + & P(I,4),P(I,5),2,0,0,VBARCODE,0 + ELSE + WRITE(J,5500)'P ',PBARCODE,K(I,2),P(I,1),P(I,2),P(I,3), + & P(I,4),P(I,5),1,0,0,0,0 + ENDIF + ENDIF + 125 CONTINUE + 130 CONTINUE +C--now write out all other particles and vertices + DO 129 I=NSTART+1,N + if (isprimhadron(i).or.isprimstring(i)) goto 129 + if (isparton(K(i,2))) then + if (ishadron(K(K(i,3),2))) codelist(i)=codelist(K(i,3)) + goto 129 + endif + if (issecstring(i)) then + codelist(i)=codelist(K(i,3)) + goto 129 + endif + PBARCODE=PBARCODE+1 + IF((K(I,3).NE.K(I-1,3)))THEN +C--write out vertex line + WRITE(J,5400)'V ',CODELIST(K(I,3)),0,0,0,0,0,0, + & K(K(I,3),5)-K(K(I,3),4)+1,0 + ENDIF +C--write out particle line + IF(K(I,4).GT.0)THEN + VBARCODE=VBARCODE-1 + CODELIST(I)=VBARCODE + WRITE(J,5500)'P ',PBARCODE,K(I,2),P(I,1),P(I,2),P(I,3), + & P(I,4),P(I,5),2,0,0,VBARCODE,0 + ELSE + WRITE(J,5500)'P ',PBARCODE,K(I,2),P(I,1),P(I,2),P(I,3), + & P(I,4),P(I,5),1,0,0,0,0 + ENDIF + 129 CONTINUE + + else +C--partonic events + endif + endif + call flush(j) + END + + + +*********************************************************************** +*** subroutine printlogo +*********************************************************************** + subroutine printlogo(fid) + implicit none + integer fid + + write(fid,*) + write(fid,*)' _______________'// + &'__________________________ ' + write(fid,*)' | '// + &' | ' + write(fid,*)' | JJJJJ EEEEE '// + &' W W EEEEE L | ' + write(fid,*)' | J E '// + &' W W E L | ' + write(fid,*)' _________________| J EEE '// + &' W W W EEE L |_________________ ' + write(fid,*)'| | J J E '// + &' W W W W E L | |' + write(fid,*)'| | JJJ EEEEE '// + &' W W EEEEE LLLLL | |' + write(fid,*)'| |_______________'// + &'__________________________| |' + write(fid,*)'| '// + &' |' + write(fid,*)'| '// + &'this is JEWEL 2.1.0 |' + write(fid,*)'| '// + &' |' + write(fid,*)'| Copyright Korinna C. Zapp (2016)'// + &' [Korinna.Zapp@cern.ch] |' + write(fid,*)'| '// + &' |' + write(fid,*)'| The JEWEL homepage is jewel.hepforge.org '// + &' |' + write(fid,*)'| '// + &' |' + write(fid,*)'| The medium model was partly '// + &'implemented by Jochen Klein |' + write(fid,*)'| [Jochen.Klein@cern.ch]. Raghav '// + &'Kunnawalkam Elayavalli helped with the |' + write(fid,*)'| implementation of the V+jet processes '// + &'[raghav.k.e@cern.ch]. |' + write(fid,*)'| '// + &' |' + write(fid,*)'| Please cite JHEP 1303 (2013) '// + &'080 [arXiv:1212.1599] and optionally |' + write(fid,*)'| EPJC C60 (2009) 617 [arXiv:0804.3568] '// + &'for the physics and arXiv:1311.0048 |' + write(fid,*)'| for the code. The reference for '// + &'V+jet processes is EPJC 76 (2016) no.12 695 |' + write(fid,*)'| [arXiv:1608.03099] and for recoil effects'// + &' it is arXiv:1707.01539. |' + write(fid,*)'| '// + &' |' + write(fid,*)'| JEWEL contains code provided by '// + &'S. Zhang and J. M. Jing |' + write(fid,*)'| (Computation of Special Functions, '// + &'John Wiley & Sons, New York, 1996 and |' + write(fid,*)'| http://jin.ece.illinois.edu) for '// + &'computing the exponential integral Ei(x). |' + write(fid,*)'| '// + &' |' + write(fid,*)'| JEWEL relies heavily on PYTHIA 6'// + &' for the event generation. The modified |' + write(fid,*)'| version of PYTHIA 6.4.25 that is'// + &' shipped with JEWEL is, however, not an |' + write(fid,*)'| official PYTHIA release and must'// + &' not be used for anything else. Please |' + write(fid,*)'| refer to results as "JEWEL+PYTHIA".'// + &' |' + write(fid,*)'| '// + &' |' + write(fid,*)'|_________________________________'// + &'____________________________________________|' + write(fid,*) + write(fid,*) + end + + +*********************************************************************** +*** subroutine printtime +*********************************************************************** + subroutine printtime + implicit none +C--identifier of file for hepmc output and logfile + common/hepmcid/hpmcfid,logfid + integer hpmcfid,logfid +C--local variables + integer*4 date(3),time(3) + + 1000 format (i2.2, '.', i2.2, '.', i4.4, ', ', + & i2.2, ':', i2.2, ':', i2.2 ) + call idate(date) + call itime(time) + write(logfid,1000)date,time + end + Index: branches/rel-2.3.0/meix.for =================================================================== --- branches/rel-2.3.0/meix.for (revision 0) +++ branches/rel-2.3.0/meix.for (revision 477) @@ -0,0 +1,59 @@ + PROGRAM MEIX +C +C ========================================================= +C Purpose: This program computes the exponential integral +C Ei(x) using subroutine EIX +C Example: +C x Ei(x) +C ----------------------- +C 0 -.10000000+301 +C 1 .18951178E+01 +C 2 .49542344E+01 +C 3 .99338326E+01 +C 4 .19630874E+02 +C 5 .40185275E+02 +C ========================================================= +C + DOUBLE PRECISION EI,X + WRITE(*,*)'Please enter x ' + READ(*,*)X + WRITE(*,*) + WRITE(*,*)' x Ei(x)' + WRITE(*,*)'------------------------' + CALL EIX(X,EI) + WRITE(*,10)X,EI +10 FORMAT(1X,F5.1,E18.8) + END + + + SUBROUTINE EIX(X,EI) +C +C ============================================ +C Purpose: Compute exponential integral Ei(x) +C Input : x --- Argument of Ei(x) +C Output: EI --- Ei(x) ( x > 0 ) +C ============================================ +C + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + IF (X.EQ.0.0) THEN + EI=-1.0D+300 + ELSE IF (X.LE.40.0) THEN + EI=1.0D0 + R=1.0D0 + DO 15 K=1,100 + R=R*K*X/(K+1.0D0)**2 + EI=EI+R + IF (DABS(R/EI).LE.1.0D-15) GO TO 20 +15 CONTINUE +20 GA=0.5772156649015328D0 + EI=GA+DLOG(X)+X*EI + ELSE + EI=1.0D0 + R=1.0D0 + DO 25 K=1,20 + R=R*K/X +25 EI=EI+R + EI=DEXP(X)/X*EI + ENDIF + RETURN + END Property changes on: branches/rel-2.3.0/meix.for ___________________________________________________________________ Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: branches/rel-2.3.0/GUIDELINES =================================================================== --- branches/rel-2.3.0/GUIDELINES (revision 0) +++ branches/rel-2.3.0/GUIDELINES (revision 477) @@ -0,0 +1,108 @@ + + MCNET GUIDELINES + + for Event Generator Authors and Users + + + PREAMBLE + +This generator has been developed as part of an academic research +project and is the result of many years of work by the authors. +Proper academic recognition is a requirement for its continued +development. + +The components of the program have been developed to work together +as a coherent physics framework. We believe that the creation of +separately maintained forks or piecewise distribution of individual +parts would diminish their scientific value. + +The authors are convinced that software development in a scientific +context requires full availability of all source code, to further +progress and to allow local modifications to meet the specific +requirements of the individual user. + +Therefore we have decided to release this program under the +GNU General Public License (GPL) version 2. This ensures +that the source code will be available to you and grants you the +freedom to use and modify the program. You can redistribute your +modified versions as long as you retain the GPL and respect existing +copyright notices (see the file 'COPYING' for details). + +By using the GPL, we entrust you with considerable freedom and expect +you to use it wisely, since the GPL does not address the issues in +the first two paragraphs. To remedy this shortcoming, we have +formulated the following guidelines relevant for the distribution +and usage of event generator software in an academic setting. + + + GUIDELINES + +1) The integrity of the program should be respected. + ------------------------------------------------- + +1.1) Suspected bugs and proposed fixes should be reported back to the + original authors to be considered for inclusion in the standard + distribution. No independently developed and maintained forks + should be created as long as the original authors actively work on + the program. + +1.2) The program should normally be redistributed in its entirety. + When there are special reasons, an agreement should be sought with + the original authors to redistribute only specific parts. This + should be arranged such that the redistributed parts remain + updated in step with the standard distribution. + +1.3) Any changes in the code must be clearly marked in the source + (reason, author, date) and documented. If any modified version is + redistributed it should be stated at the point of distribution + (download link) that it has been modified and why. + +1.4) If a significant part of the code is used by another program, + this should be clearly specified in that program's documentation and + stated at its point of distribution. + +1.5) Copyright information and references may not be removed. + Copyright-related program messages may not be altered and must be + printed even if only a part of the program is used. Adding further + messages specifying any modifications is encouraged. + + +2) The program and its physics should be properly cited when used for + academic publications + ------------------------------------------------------------------ + +2.1) The main software reference as designated by the program authors + should always be cited. + +2.2) In addition, the original literature on which the program is based + should be cited to the extent that it is of relevance for a study, + applying the same threshold criteria as for other literature. + +2.3) When several programs are combined, they should all be mentioned, + commensurate with their importance for the physics study at hand. + +2.4) To make published results reproducible, the exact versions of the + codes that were used and any relevant program and parameter + modifications should be spelled out. + + + POSTSCRIPT + +The copyright license of the software is the GPL v2 alone, therefore +the above guidelines are not legally binding. However, we reserve the +right to criticize offenders. The guidelines should always be combined +with common sense, for interpretation and for issues not covered. +Enquiries regarding the guidelines and related issues are encouraged +and should be directed to the authors of the program. + +Please note that the program, including all its code and documentation, +is intended for academic use and is delivered "as is" to be used at +your own risk, without any guarantees. + +---------------------------------------------------------------------- + +These guidelines were edited by Nils Lavesson and David Grellscheid +for the MCnet collaboration, which has approved and agreed to respect +them. MCnet is a Marie Curie Research Training Network funded under +Framework Programme 6 contract MRTN-CT-2006-035606. + Index: branches/rel-2.3.0/medium.params.dat =================================================================== --- branches/rel-2.3.0/medium.params.dat (revision 0) +++ branches/rel-2.3.0/medium.params.dat (revision 477) @@ -0,0 +1,6 @@ +# This is the parameter file for the medium model. +# Let's change the initial temperature: +TI 0.40 +# and the centrality +CENTRMIN 60. +CENTRMAX 80.