diff --git a/Processes/UrQMD/Copyright b/Processes/UrQMD/Copyright
new file mode 100644
index 0000000000000000000000000000000000000000..0667505f66addd37ae1094f423366bdf97ab69a4
--- /dev/null
+++ b/Processes/UrQMD/Copyright
@@ -0,0 +1,35 @@
+
+Copyright
+
+
+UrQMD source and documentation are provided freely for the purpose of
+checking and reproducing published results of the authors.
+
+The Open Standard Codes and Routines (OSCAR)-Group has established -
+for good reasons - guidelines for reproducablity, usage and quality
+control of simlulations codes for pA and AA collsions.
+
+UrQMD is a complex model. In order to ensure that it is used correctly
+that all results are reproducible and that the proper credits are
+given we ask for your agreement to the following copyright and
+safeguard mechanisms in the OSCAR spirit.
+
+The UrQMD collaboration favors cooperation and joint projects with
+outside researchers. We encourage experimental collaborations to
+compare their results to UrQMD. We support you and/or cooperate on any
+sensible project related to UrQMD
+
+If you are interested in a project, please contact us.
+
+Projects without the participation of the UrQMD-Collaboration are
+accepted, if the project is not a current thesis topic of any
+UrQMD-Collaboration member.
+
+We expect that the code authors are informed about any changes and
+modifications made to the code. Any changes to the official version
+must be documented.
+
+The code or any fragments of it shall not be given away to third
+parties. Similarily, events generated with UrQMD shall not be given
+to third parties without consent of the code authors.
+
diff --git a/Processes/UrQMD/addpart.f b/Processes/UrQMD/addpart.f
new file mode 100644
index 0000000000000000000000000000000000000000..1d28a4cfaf419f344474da52210659fb53ad1bef
--- /dev/null
+++ b/Processes/UrQMD/addpart.f
@@ -0,0 +1,154 @@
+c $Id: addpart.f,v 1.4 2000/01/12 16:02:32 bass Exp $
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+ subroutine addpart(index)
+c
+c Revision : 1.0
+c
+cinput index : index for slot to create in particle arrays
+c
+c This subroutine creates an entry for a particle with index {\tt index} in all
+c particle arrays.
+c \danger{The {\tt nbar} and {\tt nmes} counters must be updated by the
+c calling routine !}
+c
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+ implicit none
+ include 'coms.f'
+ include 'newpart.f'
+ include 'freezeout.f'
+ integer ind,i,j,index
+ ind=index
+
+c now shift vectors upwards
+ do 10 i=npart,ind,-1
+ r0(i+1)=r0(i)
+ rx(i+1)=rx(i)
+ ry(i+1)=ry(i)
+ rz(i+1)=rz(i)
+
+ p0(i+1)=p0(i)
+ px(i+1)=px(i)
+ py(i+1)=py(i)
+ pz(i+1)=pz(i)
+ fmass(i+1)=fmass(i)
+ ityp(i+1)=ityp(i)
+ iso3(i+1)=iso3(i)
+ ncoll(i+1)=ncoll(i)
+ lstcoll(i+1)=lstcoll(i)
+ charge(i+1)=charge(i)
+ spin(i+1)=spin(i)
+ dectime(i+1)=dectime(i)
+ tform(i+1)=tform(i)
+ xtotfac(i+1)=xtotfac(i)
+ origin(i+1)=origin(i)
+ strid(i+1)=strid(i)
+ uid(i+1)=uid(i)
+ frr0(i+1)=frr0(i)
+ frrx(i+1)=frrx(i)
+ frry(i+1)=frry(i)
+ frrz(i+1)=frrz(i)
+ frp0(i+1)=frp0(i)
+ frpx(i+1)=frpx(i)
+ frpy(i+1)=frpy(i)
+ frpz(i+1)=frpz(i)
+ ffermpx(i+1)=ffermpx(i)
+ ffermpy(i+1)=ffermpy(i)
+ ffermpz(i+1)=ffermpz(i)
+
+ r0_t(i+1)=r0_t(i)
+ rx_t(i+1)=rx_t(i)
+ ry_t(i+1)=ry_t(i)
+ rz_t(i+1)=rz_t(i)
+
+ do 11 j=1,2
+ p0td(j,i+1)=p0td(j,i)
+ pxtd(j,i+1)=pxtd(j,i)
+ pytd(j,i+1)=pytd(j,i)
+ pztd(j,i+1)=pztd(j,i)
+ fmasstd(j,i+1)=fmasstd(j,i)
+ ityptd(j,i+1)=ityptd(j,i)
+ iso3td(j,i+1)=iso3td(j,i)
+ 11 continue
+
+
+ 10 continue
+
+c increment npart
+ npart=npart+1
+c
+ if(npart.ge.nmax) then
+ write(6,*)'*** error in addpart:too much particles>',nmax
+ write(6,*)' -> increase nmax in coms.f '
+ call file14out(999)
+ stop
+ endif
+
+c initialize new slot
+ r0(ind)=0.0
+ rx(ind)=0.0
+ ry(ind)=0.0
+ rz(ind)=0.0
+
+ p0(ind)=0.0
+ px(ind)=0.0
+ py(ind)=0.0
+ pz(ind)=0.0
+ fmass(ind)=0.0
+ ityp(ind)=0
+ iso3(ind)=0
+ ncoll(ind)=0
+ lstcoll(ind)=0
+ charge(ind)=0
+ spin(ind)=-1
+ dectime(ind)=0.d0
+ tform(ind)=0.0d0
+ xtotfac(ind)=1.0d0
+ origin(ind)=0
+ strid(ind)=0
+ uid(ind)=0
+ frr0(ind)=0.d0
+ frrx(ind)=0.d0
+ frry(ind)=0.d0
+ frrz(ind)=0.d0
+ frp0(ind)=0.d0
+ frpx(ind)=0.d0
+ frpy(ind)=0.d0
+ frpz(ind)=0.d0
+ ffermpx(ind)=0.d0
+ ffermpy(ind)=0.d0
+ ffermpz(ind)=0.d0
+cpot
+ r0_t(ind)=0.d0
+ rx_t(ind)=0.d0
+ ry_t(ind)=0.d0
+ rz_t(ind)=0.d0
+ctd
+ do 12 j=1,2
+ p0td(j,ind)=0.d0
+ pxtd(j,ind)=0.d0
+ pytd(j,ind)=0.d0
+ pztd(j,ind)=0.d0
+ fmasstd(j,ind)=0.d0
+ ityptd(j,ind)=0
+ iso3td(j,ind)=0
+ 12 continue
+
+c rescan collision table - all particle indices which have been
+c shifted upwards must be modified in the collision tables, too.
+ call scantab(ind,1)
+
+c the lstcoll array must also be shifted due to the new particle slot
+ do 15 i=1,npart
+ if(lstcoll(i).le.nmax) then
+ if(lstcoll(i).eq.ind) then
+ lstcoll(i)=0
+ elseif(lstcoll(i).gt.ind) then
+ lstcoll(i)=lstcoll(i) + 1
+ endif
+ endif
+ 15 continue
+
+
+ return
+ end
diff --git a/Processes/UrQMD/angdis.f b/Processes/UrQMD/angdis.f
new file mode 100644
index 0000000000000000000000000000000000000000..90fdb4aaf1fd84279ca167b6d5e1fc28999e7f46
--- /dev/null
+++ b/Processes/UrQMD/angdis.f
@@ -0,0 +1,343 @@
+c $Id: angdis.f,v 1.15 2000/01/12 16:02:33 bass Exp $
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ subroutine angdisnew(sqrts,m1,m2,iline,costh,phi)
+c
+c Revision : 1.1
+c
+c input: sqrts, m1, m2, iline : characteristics of the ingoing channel
+coutput costh : cos(theta) of theta-angle
+coutput phi : phi-angle
+c
+c {\tt angdisnew} delivers phi and cos(theta) scattering angles
+c according to the angular distributions given by Mao et al.
+c {\tt angdisnew} performs numerical inversion of the integral of the
+c differential cross-section by means of a bisection method.
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ implicit none
+
+ real*8 sqrts, m1, m2, costh, costhcoll, phi, ranf, pi, s
+ real*8 anginter
+ integer iline
+ logical symlog(38)
+
+ parameter (pi = 3.14159265358979312d0)
+
+c symmetrize or not angular distribution (depending on iline)
+c this data statements may be changed ...
+ data symlog /14*.true., 1*.false., 6*.true., 7*.false.,
+ & 7*.true., 1*.false., 2*.true./
+
+
+ s = sqrts*sqrts
+ phi = 2.0d0*pi*ranf(0)
+
+ goto (4, 4, 4, 4, 4, 4, 4, 4, 4, 9,
+ & 9, 4, 4, 4, 4, 4, 4, 4, 4, 9,
+c ISO-FB interpolation for MB iline 26/27/28
+ & 4, 4,10,10,10,11,11,11, 4, 4,
+ & 4, 4, 4, 4, 4, 9, 9, 4) abs(iline)
+
+c cross-sections NN (Mao et al.)
+ 4 continue
+ costh = -costhcoll(s,m1,m2,symlog(abs(iline)))
+
+ return
+
+c isotropic decay
+ 9 continue
+ costh = 1.0d0-2.0d0*ranf(0)
+ return
+
+c no deflection at all
+ 10 continue
+ costh = 1.0d0
+ return
+
+c smooth interpolation between iso and f-b:
+ 11 continue
+cbl only for intermediate masses, otherwise no deflection (zero degree scattering)
+ if(sqrts.gt.6d0) goto 10
+ costh = anginter()
+ return
+
+ end
+
+ function costhcoll(s,m1,m2,sym)
+ implicit none
+ real*8 costhcoll, s, m1, m2, x, dct, ct, dsigma, ranf
+ integer j
+ logical sym
+
+ x = ranf(0)
+ dct = 2.0d0
+ costhcoll = -1.0d0
+c
+c for jmax=12 the accuracy is better than 0.1 degree
+c
+ do j=1,12 ! accuracy 2**-jmax
+ dct = 0.5d0*dct
+ ct = costhcoll+dct
+ if (dsigma(s,m1,m2,sym,ct).le.x) costhcoll=ct
+ enddo
+c
+c randomize in final interval in order to avoid discrete angles
+c
+ costhcoll = costhcoll+ranf(0)*dct
+ return
+ end
+
+ function dsigma(s_in,m1_in,m2_in,sym,costh)
+c
+cc dsigma(s\_in,chosth) = int_-1^costh dsigma/dOmega(s_in,..) dOmega
+cc it is normalized such that dsigma(s\_in,-1) = 0 and
+cc dsigma(s\_in,1) = 1
+ implicit none
+
+ include 'coms.f'
+
+ real*8 dsigma
+ real*8 s_in, m1_in, m2_in, costh,
+ & msi, cmsi, gsi, mom, cmom, gom, mpi, cmpi, gpi, m
+ real*8 m42, mpi2, cmpi2, d_pi1, d_pi2, cm6gp,
+ & cpi_3, cpi_2, cpi_1, cpi_m, cpi_l, cpi_0,
+ & msi2, cmsi2, cmsi4, cmsi6, d_si1, d_si2, d_si3, cm2gs,
+ & csi_3, csi_2, csi_1, csi_m, csi_l, csi_0,
+ & mom2, cmom2, cmom4, cmom6, d_om1, d_om2, d_om3, s_om1,
+ & cm2go, com_3, com_2, com_1, com_m, com_l,
+ & fac1, d_mx1, d_mx2, d_mx3,
+ & cmx_o1, cmx_s1, cmx_om, cmx_sm, fac2, fac3,
+ & cmx_olc, cmx_ols, cmx_slc, cmx_sls
+
+ real*8 sig, tp_pi, tp_si, tp_om, tm_pi, tm_si, tm_om,
+ & bom_3, bom_2, bom_1, bom_m, bom_0, bom_l,
+ & bmx_o1, bmx_s1, bmx_om, bmx_sm, bmx_ol, bmx_sl
+
+ real*8 s, tmax, tp, to, twos, brak1, norm,
+ & t1_pi, t2_pi, t1_si, t2_si, t1_om, t2_om,
+ & t3_pi, t4_pi, t3_si, t4_si, t3_om, t4_om
+
+ logical firstlog, sym
+ common /nn/ norm
+
+
+c define masses and coupling constants
+ data msi /0.550d0/ cmsi /1.200d0/ gsi /9.40d0/
+ data mom /0.783d0/ cmom /0.808d0/ gom /10.95d0/
+ data mpi /0.138d0/ cmpi /0.510d0/ gpi /7.27d0/
+ data m /0.938d0/
+
+ save firstlog
+
+ save m42, mpi2, cmpi2, d_pi1, d_pi2, cm6gp,
+ & cpi_3, cpi_2, cpi_1, cpi_m, cpi_l, cpi_0
+
+ save msi2, cmsi2, cmsi4, cmsi6, d_si1, d_si2, d_si3, cm2gs,
+ & csi_3, csi_2, csi_1, csi_m, csi_l, csi_0
+
+ save mom2, cmom2, cmom4, cmom6, d_om1, d_om2, d_om3, s_om1,
+ & cm2go, com_3, com_2, com_1, com_m, com_l
+
+ save fac1, d_mx1, d_mx2, d_mx3,
+ & cmx_o1, cmx_s1, cmx_om, cmx_sm, fac2, fac3,
+ & cmx_olc, cmx_ols, cmx_slc, cmx_sls
+
+ sig(tp_pi,tp_si,tp_om,tm_pi,tm_si,tm_om) =
+c pion
+ & +((cpi_3*tp_pi + cpi_2)*tp_pi + cpi_1)*tp_pi
+ & + cpi_m/tm_pi + cpi_0 + cpi_l*log(tp_pi*tm_pi)
+c sigma
+ & +((csi_3*tp_si + csi_2)*tp_si + csi_1)*tp_si
+ & + csi_m/tm_si + csi_0 + csi_l*log(tp_si*tm_si)
+c omega
+ & +((bom_3*tp_om + bom_2)*tp_om + bom_1)*tp_om
+ & + bom_m/tm_om + bom_0 + bom_l*log(tp_om*tm_om)
+c mix
+ & + bmx_o1*(tp_om - 1.0d0)
+ & + bmx_s1*(tp_si - 1.0d0)
+ & + bmx_om*log(tm_om)
+ & + bmx_sm*log(tm_si)
+ & + bmx_ol*log(tp_om)
+ & + bmx_sl*log(tp_si)
+
+c calculate constants only once!
+ if(firstlog) goto 1000
+ if (info) write(6,*)
+ $ '(info) dsigma: calculating constants for ang. dist.'
+
+c define constants for pion-Term (no s-dependence)
+ m42 = 4.0d0*m*m
+ mpi2 = mpi*mpi
+ cmpi2 = cmpi*cmpi
+ d_pi1 = cmpi2-mpi2
+ d_pi2 = d_pi1*d_pi1
+ cm6gp = 1.5d0*cmpi2**3*gpi**4*m42*m42/d_pi2
+
+ cpi_3 = -(cm6gp/3.0d0)
+ cpi_2 = -(cm6gp*mpi2/d_pi1)
+ cpi_1 = -(cm6gp*mpi2*(2.0d0*cmpi2 + mpi2)/d_pi2)
+ cpi_m = -(cm6gp*cmpi2*mpi2/d_pi2)
+ cpi_l = -(cm6gp*2.0d0*cmpi2*mpi2*(cmpi2 + mpi2)/d_pi2/d_pi1)
+ cpi_0 = -(cpi_3 + cpi_2 + cpi_1 + cpi_m)
+
+c define constants for sigma-Term (no s-dependence)
+ msi2 = msi*msi
+ cmsi2 = cmsi*cmsi
+ cmsi4 = cmsi2*cmsi2
+ cmsi6 = cmsi2*cmsi4
+ d_si1 = m42-cmsi2
+ d_si2 = m42-msi2
+ d_si3 = cmsi2-msi2
+ cm2gs = 0.5d0*cmsi2*gsi**4/d_si3**2
+
+ csi_3 = -(cm2gs*d_si1**2/3.0d0)
+ csi_2 = -(cm2gs*cmsi2*d_si1*d_si2/d_si3)
+ csi_1 = -(cm2gs*cmsi4*(2.0d0*d_si1 + d_si2)*d_si2/d_si3**2)
+ csi_m = -(cm2gs*cmsi6*d_si2**2/msi2/d_si3**2)
+ csi_l = -(cm2gs*cmsi6*d_si2*(d_si1 + d_si2)*2.0d0/d_si3**3)
+ csi_0 = -(csi_3 + csi_2 + csi_1 + csi_m)
+
+c define constants for omega-Term
+ mom2 = mom*mom
+ cmom2 = cmom*cmom
+ cmom4 = cmom2*cmom2
+ cmom6 = cmom2*cmom4
+ d_om1 = m42-cmom2
+ d_om2 = m42-mom2
+ d_om3 = cmom2-mom2
+ s_om1 = cmom2+mom2
+ cm2go = 0.5d0*cmom2*gom**4/d_om3**2
+
+ com_3 = cm2go/3.0d0
+ com_2 = -(cm2go*cmom2/d_om3)
+ com_1 = cm2go*cmom4/d_om3**2
+ com_m = cm2go*cmom6/(d_om3**2*mom2)
+ com_l = -(cm2go*cmom6*4.0d0/d_om3**3)
+
+c define constants for mix-Term
+ fac1 = -((gsi*gom*cmsi2*cmom2)**2*m42)
+ d_mx1 = cmom2 - cmsi2
+ d_mx2 = cmom2 - msi2
+ d_mx3 = cmsi2 - mom2
+
+ cmx_o1 = fac1/(cmom2*d_mx1**2*d_mx2*d_om3)
+ cmx_s1 = fac1/(cmsi2*d_mx1**2*d_mx3*d_si3)
+ cmx_om = fac1/(d_om3**2*d_mx3**2*(mom2 - msi2))
+ cmx_sm = fac1/(d_si3**2*d_mx2**2*(msi2 - mom2))
+ fac2 = (-fac1)/(d_mx1**3*d_om3**2*d_mx2**2)
+ fac3 = (-fac1)/(d_mx1**3*d_mx3**2*d_si3**2)
+
+ cmx_olc =
+ & fac2*(3.0d0*cmom2**3 - cmom2**2*cmsi2
+ & - 2.0d0*cmom2**2*mom2 - 2.0d0*cmom2**2*msi2
+ & + cmom2*mom2*msi2 + cmsi2*mom2*msi2
+ & - 4.0d0*cmom2**2*m42 + 2.0d0*cmom2*cmsi2*m42
+ & + 3.0d0*cmom2*mom2*m42 - cmsi2*mom2*m42
+ & + 3.0d0*cmom2*msi2*m42 - cmsi2*msi2*m42
+ & - 2.0d0*mom2*msi2*m42)
+
+ cmx_ols =
+ & fac2*(8.0d0*cmom2**2 - 4.0d0*cmom2*cmsi2
+ & - 6.0d0*cmom2*mom2 + 2.0d0*cmsi2*mom2
+ & - 6.0d0*cmom2*msi2 + 2.0d0*cmsi2*msi2
+ & + 4.0d0*mom2*msi2)
+
+ cmx_slc =
+ & fac3*(cmom2*cmsi2**2 - 3.0d0*cmsi2**3
+ & + 2.0d0*cmsi2**2*mom2 + 2.0d0*cmsi2**2*msi2
+ & - cmom2*mom2*msi2 - cmsi2*mom2*msi2
+ & - 2.0d0*cmom2*cmsi2*m42 + 4.0d0*cmsi2**2*m42
+ & + cmom2*mom2*m42 - 3.0d0*cmsi2*mom2*m42
+ & + cmom2*msi2*m42 - 3.0d0*cmsi2*msi2*m42
+ & + 2.0d0*mom2*msi2*m42)
+
+ cmx_sls =
+ & fac3*(4.0d0*cmom2*cmsi2 - 8.0d0*cmsi2**2
+ & - 2.0d0*cmom2*mom2 + 6.0d0*cmsi2*mom2
+ & - 2.0d0*cmom2*msi2 + 6.0d0*cmsi2*msi2
+ & - 4.0d0*mom2*msi2)
+
+ firstlog = .true.
+ if (info) write(6,*) '(info) dsigma: calculation finished'
+
+c s-dependence beyond this point
+
+ 1000 continue
+ s = s_in - (m1_in+m2_in)**2 + m42
+ tmax = s-m42
+ tp = 0.5d0*(costh+1.0d0)*tmax
+ twos = 2.0d0*s
+
+c define s-dependent stuff for omega-Term
+ brak1 = (twos-m42)**2
+ bom_3 = com_3*(-(2.0d0*cmom2**2) - 2.0d0*cmom2*twos - brak1)
+ bom_2 = com_2*(2.0d0*cmom2*mom2 + s_om1*twos + brak1)
+ bom_1 = com_1*(-(4.0d0*cmom2*mom2) - 2.0d0*mom2**2 -
+ & 2.0d0*(cmom2+2*mom2)*twos - 3.0d0*brak1)
+ bom_m = com_m*(-(2.0d0*mom2**2)- 2.0d0*mom2*twos - brak1)
+ bom_l = com_l*(s_om1*mom2 + (cmom2 + 3.0d0*mom2)*s + brak1)
+ bom_0 = -(bom_3 + bom_2 + bom_1 + bom_m)
+
+c define s-dependent stuff for mix-Term
+ bmx_o1 = cmx_o1*(d_om1 - twos)
+ bmx_s1 = cmx_s1*(d_si1 - twos)
+ bmx_om = cmx_om*(d_om2 - twos)
+ bmx_sm = cmx_sm*(d_si2 - twos)
+ bmx_ol = cmx_olc + cmx_ols*s
+ bmx_sl = cmx_slc + cmx_sls*s
+
+ t1_pi = 1.0d0/(1.0d0+tmax/cmpi2)
+ t2_pi = 1.0d0+tmax/mpi2
+ t1_si = 1.0d0/(1.0d0+tmax/cmsi2)
+ t2_si = 1.0d0+tmax/msi2
+ t1_om = 1.0d0/(1.0d0+tmax/cmom2)
+ t2_om = 1.0d0+tmax/mom2
+
+ norm = sig(t1_pi,t1_si,t1_om,t2_pi,t2_si,t2_om)
+
+ t1_pi = 1.0d0/(1.0d0+tp/cmpi2)
+ t2_pi = 1.0d0+tp/mpi2
+ t1_si = 1.0d0/(1.0d0+tp/cmsi2)
+ t2_si = 1.0d0+tp/msi2
+ t1_om = 1.0d0/(1.0d0+tp/cmom2)
+ t2_om = 1.0d0+tp/mom2
+
+ if (sym) then
+ norm=2.0d0*norm
+ to = tmax-tp
+ t3_pi = 1.0d0/(1.0d0+to/cmpi2)
+ t4_pi = 1.0d0+to/mpi2
+ t3_si = 1.0d0/(1.0d0+to/cmsi2)
+ t4_si = 1.0d0+to/msi2
+ t3_om = 1.0d0/(1.0d0+to/cmom2)
+ t4_om = 1.0d0+to/mom2
+
+ dsigma = (sig(t1_pi,t1_si,t1_om,t2_pi,t2_si,t2_om)
+ & -sig(t3_pi,t3_si,t3_om,t4_pi,t4_si,t4_om))/norm+0.5d0
+ else
+ dsigma = sig(t1_pi,t1_si,t1_om,t2_pi,t2_si,t2_om)/norm
+ end if
+ return
+ end
+
+ function anginter()
+ implicit none
+ real*8 ranf, anginter, a
+c*
+ a=8d0
+c*
+c the costheta distribution p(x) is proportional to exp(a*x)
+c x is chosen between -1 and +1
+c a=0 corresponds to isotropic distr.
+c a=infinity corresponds to exactly forward distr.
+c inverse transform method is used:
+
+ anginter=1d0/a*log( ranf(0)*(exp(a)-exp(-a))+exp(-a) )
+
+ if(anginter.lt.-1d0.or.anginter.gt.1d0)then
+ write(*,*)"#angdis# illegal costh value: ",anginter
+ endif
+
+ return
+ end
+
diff --git a/Processes/UrQMD/anndec.f b/Processes/UrQMD/anndec.f
new file mode 100644
index 0000000000000000000000000000000000000000..6ccce6a4512034caa7f0aa12144791307b3fcacd
--- /dev/null
+++ b/Processes/UrQMD/anndec.f
@@ -0,0 +1,983 @@
+c $Id: anndec.f,v 1.20 2003/05/02 13:14:47 weber Exp $
+C####C##1#########2#########3#########4#########5#########6#########7##
+ subroutine anndec(io,mm1,ii1,iiz1,mm2,ii2,iiz2,sqrts,sig,gam)
+c
+c
+cinput io : 0: annihilation; 1: decay
+cinput mm1 : mass of scattering/decaying particle 1
+cinput ii1 : ID of scattering/decaying particle 1
+cinput iiz1 : $2\cdot I_3$ of scattering/decaying particle 1
+cinput mm2 : mass of scattering particle 2
+cinput ii2 : ID of scattering particle 2
+cinput iiz2 : $2\cdot I_3$ of scattering particle 2
+cinput sqrts : $sqrts{s}$ of collision; resonance mass for decay
+coutput sig : resonance scattering cross section
+coutput gam : width of the produced resonance
+c
+c {\tt anndec} handles meson-baryon and meson-meson annihilations
+c as well as all meson and baryon resonance decays. In case of
+c annihilations it returs the total resonance production cross section
+c and the decay width of the resonance chosen as final state.
+c The final state itself for both cases, annihilation and decay
+c is returned via the {\tt newpart} common block. In the case
+c of a decay the final state may consist of up to 4 particles.
+c
+c Technically, {\tt anndec} is only an interface to {\tt anndex},
+c which actually handles the summation of the Breit-Wigner formulas
+c in the annihilation case and the final state generation for
+c annihilation and decay.
+c
+Ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+C
+ implicit none
+ integer io,i1,i2,iz1,iz2,ii1,ii2,iiz1,iiz2,is
+ real*8 m1,m2,mm1,mm2,sig,gam,sqrts
+
+ include 'comres.f'
+ include 'options.f'
+
+ integer strit
+C
+C ************************************************************************
+C Case 1 : Two ingoing Particles --> One outgoing Particle (Resonance,...)
+C
+C
+ i1=ii1
+ i2=ii2
+ iz1=iiz1
+ iz2=iiz2
+ m1=mm1
+ m2=mm2
+
+ if(io.eq.0)then !annihilation
+C
+ sig=0d0
+ gam=0d0
+C
+C Check if (sqrt(s)-masses of ingoing particles) is significant different
+C from zero
+C
+ if(sqrts-mm1-mm2.le.1d-3)return
+C
+C Check if CTOption(15) is set different from zero-->then skip anndec.f
+C
+ if(CTOption(15).ne.0)return
+C
+C
+C Check if itype of particle one is smaller than the one of particle two
+C if so --> interchange particle one and particle two
+C in case of particle one = B and particle two = M --> then
+C new particle one = M and new particle two = B
+C
+ if(iabs(i1).lt.iabs(i2))call swpizm(i1,iz1,m1,i2,iz2,m2)
+C
+C Determination of the amount of the netstrangness
+C
+ is=iabs(strit(i1)+strit(i2))
+C
+C maxbar (Maximum Baryon ityp)
+C if second particle is antibaryon and first particle is strange
+C switch antibaryon to baryon
+C
+ if(iabs(i2).le.maxbar)then
+ if(i2.lt.0)then
+ if(strit(i1).ne.0)i1=-i1 ! get corresponding anti-branch
+ end if
+ end if
+C
+C
+C Check if both particles are mesons
+C
+ if(iabs(i1).ge.minmes.and.iabs(i2).ge.minmes)then
+C
+C
+c... boson+boson sector
+C
+C
+C Check if amount of netstrangeness is greater than 1
+c currently no resonant processes for |s|>1 are implemented
+
+ if(is.gt.1)return
+
+ if(is.ne.0)then
+ call anndex(0,m1,i1,iz1,m2,i2,iz2,sqrts,
+ . sig,gam,maxbrm,minmes+1,maxmes,bmtype,branmes)
+ else
+ call anndex(0,m1,i1,iz1,m2,i2,iz2,sqrts,
+ . sig,gam,maxbrm,minmes+1,maxmes,bmtype,branmes)
+ endif
+
+C
+C Check if second particle is baryon
+C (with zero amount of netstrangeness) ?
+C e.g. pion-nucleon case
+C
+ else if(is.eq.0.and.iabs(i2).le.maxbar)then
+c... (anti-)N*,D*
+ call anndex(0,m1,i1,iz1,m2,i2,iz2,sqrts,sig,gam,
+ . maxbra,minnuc+1,maxdel,brtype,branres)
+
+C
+C Check if second particle is baryon
+C (with amount one of netstrangeness) ?
+C
+ else if(is.eq.1.and.iabs(i2).le.maxbar)then
+c... (anti-)Y*
+ call anndex(0,m1,i1,iz1,m2,i2,iz2,sqrts,sig,gam,
+ . maxbrs1,minlam+1,maxsig,bs1type,branbs1)
+C
+C Check if second particle is baryon
+C (with amount two of netstrangeness) ?
+C
+ else if(is.eq.2.and.iabs(i2).le.maxbar)then
+c... (anti-)X*
+ call anndex(0,m1,i1,iz1,m2,i2,iz2,sqrts,sig,gam,
+ . maxbrs2,mincas+1,maxcas,bs2type,branbs2)
+C
+C
+ else
+ sig=0d0
+ return
+ end if
+C
+C *************************************************************
+Css Case 2 : one ingoing particle (resonance,..) --> 2-4 outgoing
+Css particles (decay)
+C
+ else ! decay !!!!!
+
+ i2=0
+ iz2=0
+ m2=0.d0
+ is=iabs(strit(i1))
+c
+ if(iabs(i1).ge.minmes)then ! meson dec.
+ call anndex(1,m1,i1,iz1,m2,i2,iz2,sqrts,sig,gam,
+ . maxbrm ,minmes+1,maxmes,bmtype,branmes)
+
+
+ else if(is.eq.0)then ! n*,d,d*
+ call anndex(1,m1,i1,iz1,m2,i2,iz2,sqrts,sig,gam,
+ . maxbra,minnuc+1,maxdel,brtype,branres)
+
+
+ else if(is.eq.1)then !
+ call anndex(1,m1,i1,iz1,m2,i2,iz2,sqrts,sig,gam,
+ . maxbrs1,minlam+1,maxsig,bs1type,branbs1)
+
+
+ else if(is.eq.2)then
+ call anndex(1,m1,i1,iz1,m2,i2,iz2,sqrts,sig,gam,
+ . maxbrs2,mincas+1,maxcas,bs2type,branbs2)
+
+ else
+ write(6,*)'make22(anndex): s=',is,'not included'
+ stop
+ end if
+C
+C End of Cases 1 and 2 : annihilation/decay
+C
+ end if
+C ************************************************************
+C
+ return
+ end
+
+
+
+C####C##1#########2#########3#########4#########5#########6#########7##
+ subroutine anndex(io,m1,i1,iz1,m2,i2,iz2,sqrts,sig,gam,
+ & maxbr,mini,maxi,btype,branch)
+c
+cinput io : 0: annihilation; 1: decay
+cinput m1 : mass of scattering/decaying particle 1
+cinput i1 : ID of scattering/decaying particle 1
+cinput iz1 : $2\cdot I_3$ of scattering/decaying particle 1
+cinput m2 : mass of scattering particle 2
+cinput i2 : ID of scattering particle 2
+cinput iz2 : $2\cdot I_3$ of scattering particle 2
+cinput sqrts : $sqrts{s}$ of collision; resonance mass for decay
+coutput sig : resonance scattering cross section
+coutput gam : width of the produced resonance
+cinput maxbr : number of decay channels for particle class
+cinput mini : smallest {\tt ityp} of particle class
+cinput maxi : largest {\tt ityp} of particle class
+cinput btype : array with exit channel definitions
+cinput branch : array with branching ratios for final state
+c
+c
+c {\tt anndex} performs meson-baryon and meson-meson annihilations
+c as well as all meson and baryon resonance decays. In case of
+c annihilations it returs the total resonance production cross section
+c and the decay width of the resonance chosen as final state.
+c The final state itself for both cases, annihilation and decay
+c is returned via the {\tt newpart} common block. In the case
+c of a decay the final state may consist of up to 4 particles.
+c
+c In {\tt anndex} the actual summation over Breit-Wigner formulas
+c in the case of annihilations is performed.
+c
+c For decays the branch is choosen according to the mass dependent
+c part of the decay width (call to {\tt fbrancx}); then the final
+c state (which consists of particle {\tt ityp}, $2\cdot I_3$ and
+c mass is generated and transferred to teh {\tt newpart} common
+c block.
+c
+Ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+ implicit none
+
+ include 'comres.f'
+ include 'comwid.f'
+ include 'newpart.f'
+ include 'options.f'
+
+ real*8 pi,cc,sqrts
+ parameter(pi=3.1415927,cc=0.38937966)
+ integer maxbr,mini,maxi,btype(4,0:maxbr)
+ real*8 branch(0:maxbr,mini:maxi)
+ integer icnt,is
+
+
+ integer io,i,j,i1,i2,iz1,iz2,itag,ii1,ii2
+ integer itn1,itnz1
+ real*8 m1,m2,prob(0:100),sum,sig,gam,cgk2
+ real*8 sigi(minnuc:maxmes),mmax,mmin,br,mmi1,mmi2,ppcm,gt
+ real*8 m,g,mo
+
+c functions
+ real*8 fbrwig,pcms,massit
+ real*8 mminit,widit,fbrancx,ranf,fcgk,fwidth
+ real*8 fprwdt
+ integer jit,isoit,strit
+ if(io.eq.1)then
+C
+C
+C one ingoing particle --> two,three,four outgoing particles
+C
+c... decays
+
+ do 3 i=0,maxbr
+ if(isoit(btype(1,i))+isoit(btype(2,i))+isoit(btype(3,i))+
+ & isoit(btype(4,i)).lt.iabs(iz1).or.
+ & m1.lt.mminit(btype(1,i))+mminit(btype(2,i))
+ & +mminit(btype(3,i))+mminit(btype(4,i)) )then
+ prob(i)=0.d0
+ else
+ prob(i)=fbrancx(i,iabs(i1),iz1,m1,branch(i,iabs(i1)),
+ & btype(1,i),btype(2,i),btype(3,i),btype(4,i))
+ endif
+ 3 continue
+
+ icnt=0
+c... find out branch = i
+ call getbran(prob,0,100,sum,0,maxbr,i)
+ctp060202 9 call getbran(prob,0,100,sum,0,maxbr,i)
+
+ if(i.gt.maxbr)then
+ write(6,*)'anndex(dec): no final state found for:',i1,m1,iz1
+ write(6,*)'please check minimal masses: m1,m1min,m2min'
+ write(6,*)'and iso3 of decaying particle'
+ write(6,*)(prob(j),j=0,maxbr)
+ stop
+ end if
+
+c... get itypes and set number of outgoing particles, prepare final state
+ nexit=2
+ itypnew(1)=btype(1,i)
+ itot(1)=isoit(itypnew(1))
+ itypnew(2)=btype(2,i)
+ itot(2)=isoit(itypnew(2))
+
+
+ itypnew(3)=btype(3,i)
+ if(itypnew(3).ne.0) then
+ itot(3)=isoit(itypnew(3))
+ pnew(5,3)=massit(itypnew(3))
+c sidnew is used to set the lstcoll array
+ sidnew(3)=strcount
+ sidnew(2)=strcount ! correct here, set only for nexit > 2
+ nexit=nexit+1
+ endif
+ itypnew(4)=btype(4,i)
+ if(itypnew(4).ne.0) then
+ itot(4)=isoit(itypnew(4))
+ pnew(5,4)=massit(itypnew(4))
+ sidnew(4)=strcount
+ nexit=nexit+1
+ endif
+ if(nexit.gt.2) strcount=strcount+1
+
+
+c check for some special cases involving decay of antibaryons and
+c strange mesons
+ if(iabs(i1).ge.minmes.and.strit(i1).ne.0) then
+ do 41 j=1,nexit
+ if(strit(itypnew(j)).ne.0)then
+c for anti-K* decays(mesons with one s-quark)
+ itypnew(j)=isign(itypnew(j),i1)
+ end if
+ 41 continue
+ elseif(iabs(i1).lt.minmes) then
+c the (anti-)baryon MUST always be the first outgoing particle
+c -> conserve baryon-charge
+ itypnew(1)=isign(itypnew(1),i1)
+ do 42 j=2,nexit
+ if(strit(itypnew(j)).ne.0.and.i1.lt.0) then
+ itypnew(j)=(-1)*itypnew(j)
+ endif
+ 42 continue
+ endif
+
+
+
+c... get isopin-3 components
+ itag=-50
+ call isonew4(isoit(i1),iz1,itot,i3new,itag)
+c write(6,*)'anndem:',iz3,iz1,iz2,'#',is3,is1,is2
+
+
+c... get masses
+ if(widit(itypnew(1)).ge.1.d-4.and.
+ & widit(itypnew(2)).le.1.d-4)then
+c... i1 is a broad meson
+ pnew(5,2)=massit(itypnew(2))
+ mmin=mminit(itypnew(1))
+ mo = pnew(5,2)
+ if(nexit.gt.2) then
+ do 39 j=3,nexit
+ mo=mo+pnew(5,j)
+ 39 continue
+ endif
+
+ mmax=sqrts-mo
+ call getmas(massit(itypnew(1)),widit(itypnew(1)),itypnew(1)
+ & ,isoit(itypnew(1)),mmin,mmax,mo,pnew(5,1))
+
+ elseif(widit(itypnew(2)).ge.1.d-4
+ & .and.widit(itypnew(1)).le.1.d-4)then
+c... i2 is a broad meson
+ pnew(5,1)=massit(itypnew(1))
+ mmin=mminit(itypnew(2))
+
+ mo = pnew(5,1)
+ if(nexit.gt.2) then
+ do 49 j=3,nexit
+ mo=mo+pnew(5,j)
+ 49 continue
+ endif
+ mmax=sqrts-mo
+ call getmas(massit(itypnew(2)),widit(itypnew(2)),itypnew(2)
+ & ,isoit(itypnew(2)),mmin,mmax,mo,pnew(5,2))
+
+ elseif(widit(itypnew(1)).ge.1.d-4
+ & .and.widit(itypnew(2)).ge.1.d-4)then
+c... i1&i2 are both broad
+ if(ranf(0).gt.0.5)then
+ mmin=mminit(itypnew(1))
+ mo=mminit(itypnew(2))
+ if(nexit.gt.2) then
+ do 59 j=3,nexit
+ mo=mo+pnew(5,j)
+ 59 continue
+ endif
+ mmax=sqrts-mo
+
+ call getmas(massit(itypnew(1)),widit(itypnew(1)),
+ & itypnew(1),isoit(itypnew(1)),mmin,mmax,mo,pnew(5,1))
+
+ mmin=mminit(itypnew(2))
+ mo=pnew(5,1)
+ if(nexit.gt.2) then
+ do 69 j=3,nexit
+ mo=mo+pnew(5,j)
+ 69 continue
+ endif
+ mmax=sqrts-mo
+ call getmas(massit(itypnew(2)),widit(itypnew(2)),
+ & itypnew(2),isoit(itypnew(2)),mmin,mmax,mo,pnew(5,2))
+
+ else ! of ranf.gt.0.5
+ mmin=mminit(itypnew(2))
+ mo=mminit(itypnew(1))
+ if(nexit.gt.2) then
+ do 79 j=3,nexit
+ mo=mo+pnew(5,j)
+ 79 continue
+ endif
+ mmax=sqrts-mo
+ call getmas(massit(itypnew(2)),widit(itypnew(2)),
+ & itypnew(2),isoit(itypnew(2)),mmin,mmax,mo,pnew(5,2))
+
+ mmin=mminit(itypnew(1))
+ mo=pnew(5,2)
+ if(nexit.gt.2) then
+ do 89 j=3,nexit
+ mo=mo+pnew(5,j)
+ 89 continue
+ endif
+ mmax=sqrts-mo
+ call getmas(massit(itypnew(1)),widit(itypnew(1)),
+ & itypnew(1),isoit(itypnew(1)),mmin,mmax,mo,pnew(5,1))
+
+ endif
+c none are broad
+ else
+ pnew(5,2)=massit(itypnew(2))
+ pnew(5,1)=massit(itypnew(1))
+ end if
+
+ mmax=0.d0
+ do 99 j=1,nexit
+ mmax=mmax+pnew(5,j)
+ 99 continue
+
+ if(sqrts.le.mmax)then
+ write(6,*)' *** error(anndex): treshold violated',sqrts-mmax
+ stop
+ end if
+C
+C
+C two ingoing particles --> one outgoing particle (resonance)
+C
+C i.e. (i0=0)
+ else
+c.... collisions: find in-branch = j
+ sig=0.0
+ gam=0.0
+C
+ ii1=i1
+ ii2=i2
+c for strange - nonstrange meson-meson scattering: strip sign
+ is=iabs(strit(i1)+strit(i2))
+ if(is.ne.0.and.iabs(i1).ge.minmes.and.iabs(i2).ge.minmes) then
+ ii1=iabs(i1)
+ ii2=iabs(i2)
+ endif
+c for meson baryon, strip sign of baryon
+ if(iabs(i2).le.maxbar) then
+ ii2=iabs(i2)
+ endif
+
+c
+ call getobr(btype,0,maxbr,ii1,ii2,j)
+
+ if(j.eq.-99)return
+
+ mmi1=mminit(i1)
+ mmi2=mminit(i2)
+c
+C next line outside the loop (compare post-QM-version: inside the loop)
+C
+C
+ ppcm=pcms(sqrts,m1,m2)
+C
+C Loop over different branches (resonances...)
+C
+ do 88 i=mini,maxi
+ sigi(i)=0.d0
+ br=branch(j,i)
+ gt=widit(i)
+ if(br*gt.lt.1d-4)goto 88
+
+ cgk2=fcgk(i1,i2,iz1,iz2,i)
+ if(br*cgk2.gt.0d0.and.sqrts.gt.mmi1+mmi2+1d-2.and.
+ & ppcm.gt.1d-2)then
+C
+C
+ br=fprwdt(j,i,iz1+iz2,sqrts)/fwidth(i,iz1+iz2,sqrts)
+ m=dabs(sqrts)
+ g=fwidth(i,iz1+iz2,m)
+ sigi(i)=dble(jit(i)+1)
+ / /dble((jit(i1)+1)*(jit(i2)+1))
+ * *pi/ppcm**2*br
+ * *g*g/((m-massit(i))**2+g*g/4d0)*cgk2*cc
+ end if
+ if(sigi(i).gt.1e10)then
+ write(6,*)' ***error(anndec) cross section too high '
+ write(6,*)'anndex(ann):',i,
+ , br,cgk2,fbrwig(i,iz1+iz2,sqrts,1),
+ , 1/pcms(sqrts,m1,m2),sigi(i)
+ write(6,*)m1,m2,sqrts
+ write(6,*)i1,i2,i
+ write(6,*)iz1,iz2,iz1+iz2
+ end if
+C
+C
+ 88 continue
+c... find outgoing resonance
+ call getbran(sigi,minnuc,maxmes,sig,mini,maxi,itn1)
+ctp060202 108 call getbran(sigi,minnuc,maxmes,sig,mini,maxi,itn1)
+
+ if(sig.ge.1d-10)then
+ itnz1=iz1+iz2
+ gam=fwidth(itn1,itnz1,sqrts)
+ end if
+
+c copy created resonance into newpart arrays
+ itypnew(1)=itn1
+ i3new(1)=itnz1
+ pnew(5,1)=sqrts
+
+ if(iabs(i1).ge.minmes.and.iabs(i2).ge.minmes) then
+ if(iabs(strit(i1)+strit(i2)).ne.0) then
+ itypnew(1)=isign(itypnew(1),i1*i2)
+ endif
+ else
+ itypnew(1)=isign(itypnew(1),i2)
+ endif
+
+ctp060202 3333 continue
+
+
+C
+C End of two Cases (annihilation/decay)
+C
+C
+ end if !dec/ann
+
+ return
+ end
+
+C####C##1#########2#########3#########4#########5#########6#########7##
+ real*8 function fbrwig(i,iz,mi,bit)
+c
+cinput i : resonance ID
+cinput iz : $2\cdot I_3$ of resonance
+cinput mi : mass of resonance
+cinput bit : sign is used as option to toggle between fixed and m.dep. widths
+c
+c {\tt fbrwig} returns a normalized Breit-Wigner Function.
+c Note, that the normalization actually only holds true for
+c fixed decay widths. {\tt fbrwig}, however, uses per default
+c a mass dependent width. You should divide by
+c {\tt bwnorm} to obtain normalized Breit-Wigners for mass dependent
+c widths also. For {\tt bit} < 0 a fixed width is used.
+c
+cccccCcc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc
+
+ implicit none
+
+ integer i,iz,bit
+ real*8 pi,mi,g,fwidth,massit,widit
+ real*8 f,e,m0,g1,g2
+ parameter(pi=3.1415927)
+
+ f(e,m0,g1,g2)=0.5/pi*g1/((e-m0)**2+0.25*g2**2)
+
+ if(bit.lt.0)then
+ g=widit(i)
+ fbrwig=f(mi,massit(i),g,g)
+ else
+ g=fwidth(i,iz,mi)
+ fbrwig=f(mi,massit(i),g,g)
+ end if
+
+ return
+ end
+
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ subroutine getbran(x,dmin,dmax,sumx,nmin,nmax,i)
+c
+c
+cinput x : vector containing weights, dimension is {\tt x(dmin:dmax)}
+cinput dmin : lower dimension of {\tt x}
+cinput dmax : upper dimension of {\tt x}
+coutput sumx : sum of elements of {\tt x} from {\tt nmin} to {\tt nmax}
+cinput nmin : lower boundary for {\tt getbran} operation
+cinput nmax : upper boundary for {\tt getbran} operation
+coutput i : index of element which has been choosen randomly
+c
+c {\tt getbran} takes a vector of weights or probabilities
+c {\tt x(dmin:dmax)} and sums up the elements from
+c {\tt nmin} to {\tt nmax}. It then chooses randomly an element {\tt i}
+c between {\tt nmin} and {\tt nmax}. The probability of
+c choosing {\tt i} depends on the weights contained in {\tt x}.
+c
+c \danger{ {\tt i} will be undefined if {\tt sum} is less or
+c equal to zero}
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+ implicit none
+
+ integer i,j,nmin,nmax,dmin,dmax
+ real*8 x(dmin:dmax),sumx,ranf,rx,cut
+ parameter (cut=1d-20)
+
+ sumx=0D0
+ do 10 j=nmin,nmax
+ sumx=sumx+x(j)
+ 10 continue
+ if (sumx.lt.cut) then
+ i=nmax+1
+ return
+ endif
+
+ rx=sumx*ranf(0)
+ do 20 j=nmin,nmax
+ if (rx.le.x(j)) then
+ i=j
+ return
+ endif
+ rx=rx-x(j)
+ 20 continue
+ if (abs(rx).lt.1D-10) then
+ i=nmax
+ return
+ endif
+
+ call error ('getbran','no channel found',rx,3)
+
+ end
+
+C####C##1#########2#########3#########4#########5#########6#########7##
+ subroutine getobr(x,dmin,dmax,i1,i2,i)
+c
+c
+cinput x : array, either {\tt brtype, bmtype, bs1type} or {\tt bs2type}
+cinput dmin : lower dimension of {\tt x(4,dmin:dmax)}
+cinput dmin : upper dimension of {\tt x(4,dmin:dmax)}
+cinput i1 : ID of first incoming particle
+cinput i2 : ID of second incoming particle
+coutput i : index of decay branch into {\tt i1} and {\tt i2}
+c
+c {\tt getobr} returns the index of the decay branch for the
+c exit channel $B^* \rightarrow$ {\tt i1} + {\tt i2}
+c from one of the arrays
+c {\tt brtype, bmtype, bs1type} or {\tt bs2type}. This index
+c is needed for the calculation of the cross section
+c {\tt i1} + {\tt i2} $\rightarrow B^*$.
+c
+cccccCcc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc
+ implicit none
+ integer i,j,i1,i2,dmin,dmax,x(4,dmin:dmax)
+
+ do 108 j=dmin,dmax
+ if((x(1,j).eq.i1.and.x(2,j).eq.i2.and.x(3,j).eq.0).OR.
+ & (x(1,j).eq.i2.and.x(2,j).eq.i1.and.x(3,j).eq.0))then
+ i=j
+ return
+ end if
+ 108 continue
+ i=-99
+ return
+ end
+
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ subroutine normit (sigma,isigline)
+c
+c Revision : 1.0
+c
+cinput sigma : vector with all (partial) cross sections
+coutput sigma : unitarized vector with cross sections
+cinput isigline : process class of cross sections
+c
+c {\tt normit} unitarizes the cross sections contained in the
+c {\tt sigma} array. The total cross section is stored in
+c {\tt sigma(0)}. The partial cross sections are unitarized
+c (rescaled) such, that their sum adds up to the total cross
+c section. Confidence levels can be assigned to different
+c partial cross sections indicating whether they may be rescaled
+c (i.e. if they are not well known) or whether they must not
+c be rescaled (i.e. because they have been fitted to experimental
+c data).
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+ implicit none
+
+ include 'options.f'
+ include 'comres.f'
+
+ real*8 sigma(0:maxpsig)
+ integer isigline
+
+ integer i, npsig, restart
+ integer uncert(1:maxpsig)
+ real*8 diff, sumpart, gsumpart
+ real*8 newsig(0:maxpsig)
+
+c get the number of channels
+ npsig=sigmaln(1,1,isigline)
+c normalize only if sigtot is not given by the sum of sigpart
+ if (sigmaln(2,1,isigline).gt.0) then
+c copy array
+ do 10 i=1,npsig
+ uncert(i)=sigmaln(i+2,2,isigline)
+ 10 continue
+ 100 restart=0
+ sumpart=0
+ gsumpart=0
+c calculate the sum of all sigpart
+ do 20 i=1,npsig
+ sumpart=sumpart+sigma(i)
+ gsumpart=gsumpart+sigma(i)*uncert(i)
+ 20 continue
+c difference between sigtot and the sum of sigpart
+ diff=sigma(0)-sumpart
+c if all channels are exactly zero, there must be an error in blockres.f!
+ if (sumpart.eq.0.0) then
+ write (6,*) 'normit: Error! sumpart.eq.0'
+c stop
+ return
+ endif
+ if (gsumpart.eq.0.0) then
+ do 50 i=1,npsig
+c now all channels can be modified
+ if (uncert(i).eq.0) then
+c write (6,*) 'modify channel',i
+ uncert(i)=1
+ endif
+ 50 continue
+c restart calculation
+ goto 100
+ endif
+ do 60 i=1,npsig
+c rescale channels
+ newsig(i)=sigma(i)+uncert(i)*diff*sigma(i)/gsumpart
+c if a channel is negative...
+ if (newsig(i).lt.0) then
+c set it to zero and restart
+ sigma(i)=0.0
+ restart=1
+ endif
+ 60 continue
+ if (restart.eq.1) goto 100
+c copy new values to sigma
+ do 70 i=1,npsig
+ sigma(i)=newsig(i)
+ 70 continue
+ endif
+
+ if (CTOption(7).eq.1.and.sigma(2).gt.1d-10) then
+ sigma(1)=0d0
+ endif
+ if (CTOption(7).eq.-1) then
+ do 80 i=2,npsig
+ sigma(i)=0d0
+ 80 continue
+ end if
+
+ return
+ end
+
+
+
+C####C##1#########2#########3#########4#########5#########6#########7##
+ real*8 function fwidth(ir,izr,m)
+c
+cinput ir : resonance ID
+cinput izr : $2\cdot I_3$ of resonance
+cinput m : mass of resonance
+c
+c {\tt fwidth} returns the mass-dependent total decay width
+c of the resonance {\tt ir}.
+c
+c
+C####C##1#########2#########3#########4#########5#########6#########7##
+
+ implicit none
+
+ include 'comres.f'
+ include 'comwid.f'
+ include 'options.f'
+
+ integer i,ir,izr,mm,mp,ires
+ real*8 gtot,m,widit,splint
+ real*8 minwid, fprwdt
+
+ if (CTOption(1).ne.0) then
+ fwidth=widit(ir)
+ return
+ endif
+ if (wtabflg.gt.0.and.CTOption(33).eq.0) then
+ ires=iabs(ir)
+ minwid=min(widit(ir),1D-8)
+ if (ires.ge.minbar.and.ires.le.maxbar) then !baryons
+c widths are continued horicontally outside the spline region
+ if(m.le.maxtab2)then
+ fwidth=max(splint(tabx(1),fbtaby(1,ires,1),
+ . fbtaby(1,ires,2),widnsp,m),minwid)
+ else
+ fwidth=max(splint(tabx(1),fbtaby(1,ires,1),
+ . fbtaby(1,ires,2),widnsp,maxtab2),minwid)
+ endif
+ else if (ires.ge.minmes.and.ires.le.maxmes) then !mesons
+c widths are continued horicontally outside the spline region
+ if(m.le.maxtab2)then
+ fwidth=max(splint(tabx(1),fmtaby(1,ires,1),
+ . fmtaby(1,ires,2),widnsp,m),minwid)
+ else
+ fwidth=max(splint(tabx(1),fmtaby(1,ires,1),
+ . fmtaby(1,ires,2),widnsp,maxtab2),minwid)
+ endif
+ else
+ write (6,*) '*** error(fwidth) wrong itype:',ir
+ fwidth=0
+ endif
+ else
+ call brange(ir,mm,mp)
+ gtot=0d0
+ if(mp.gt.0)then
+ do 27 i=mm,mp
+ gtot=gtot+fprwdt(i,ir,izr,m)
+ 27 continue
+ end if
+ fwidth=gtot !*widit(ir)
+ end if
+
+ return
+ end
+
+C####C##1#########2#########3#########4#########5#########6#########7##
+ real*8 function fprwdt(i,ir,izr,mi)
+c
+cinput i : decay branch
+cinput ir : resonance ID
+cinput izr : $2\cdot I_3$ of resonance
+cinput mi : mass of resonance
+c
+c {\tt fprwdt} returns the mass dependent partial decay width
+c of the decay channel {\tt i}.
+c
+C####C##1#########2#########3#########4#########5#########6#########7##
+
+ implicit none
+ real*8 m,br,bi,mir,g,mi
+ integer i,ir,izr,i1,i2,i3,i4
+ real*8 widit,fbrancx,mminit,massit
+
+ call b3type(ir,i,bi,i1,i2,i3,i4)
+ m=dabs(mi)
+ g=0d0
+ mir=massit(ir)
+ if(bi.gt.1d-9.and.mir.gt.mminit(i1)+mminit(i2))then
+ br=fbrancx(i,ir,izr,m,bi,i1,i2,i3,i4)
+c write(6,*)' ',bi,gi,widit(ir)
+ g=br*widit(ir)
+ end if
+ fprwdt=g
+ return
+ end
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ real*8 function fbrancx(i,ir,izr,em,bi,b1,b2,b3,b4)
+c
+cinput i : decay branch
+cinput ir : ID of resonance
+cinput em : actual mass of resonance
+cinput bi : branching ration at peak
+cinput b1 : itype of 1st outgoing particle
+cinput b2 : itype of 2nd outgoing particle
+cinput b3 : itype of 3rd outgoing particle
+cinput b4 : itype of 4th outgoing particle
+c
+c {\tt fbrancx} returns the mass dependent branching ratio for
+c the decay channel {\tt i} of resonance {\tt ir}. This
+c branching ratio is NOT normalized. To extract the mass dependent
+c decay width, use {\tt fprwdt}.
+c
+c {\tt fbrancx} =$
+c \left( \Gamma^{i,j}_{R} \frac{M_{R}}{M}
+c \left( \frac{\langle p_{i,j}(M) \rangle}
+c {\langle p_{i,j}(M_{R}) \rangle} \right)^{2l+1}
+c \frac{1.2}{1+ 0.2
+c \left( \frac{\langle p_{i,j}(M) \rangle}
+c {\langle p_{i,j}(M_{R}) \rangle} \right)^{2l} }
+c \right) $
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ implicit none
+ real*8 kdiv1,kdiv2,em,b,mmin,mn,m1m,m2m
+ real*8 bi,minwid
+ real*8 fbran,splint,splintth,pmean
+ integer i,ires,ir,izr,b1,b2,b3,b4
+ include 'comres.f'
+ include 'comwid.f'
+ include 'options.f'
+
+ real*8 mminit,massit
+ integer isoit,flbr,ipwr,ipwr1
+
+ ires=iabs(ir)
+
+ if(iabs(izr).gt.isoit(ires))then
+ fbrancx=0d0
+ return
+ end if
+
+ if(CTOption(8).ne.0)then
+ fbrancx=bi
+ return
+ end if
+
+ m1m=mminit(b1)
+ m2m=mminit(b2)
+c in case of three or four particle decays put masses in m2m
+ if(b3.ne.0) m2m=m2m+mminit(b3)
+ if(b4.ne.0) m2m=m2m+mminit(b4)
+ mn=massit(ires) ! nominal mass
+ mmin= m1m+m2m ! minimal mass of resonance
+
+ if (wtabflg.ge.2.and.CTOption(33).eq.0) then
+ minwid=min(fbran(i,ires),1D-8)
+ if (ires.ge.minbar.and.ires.le.maxbar) then !baryons
+c branching ratios are continued horicontally outside the spline region
+ if(em.le.maxtab2)then
+ b=max(splintth(tabx,pbtaby(1,1,ires,i),
+ . pbtaby(1,2,ires,i),widnsp,em,mmin),minwid)
+ else
+ b=max(splintth(tabx,pbtaby(1,1,ires,i),
+ . pbtaby(1,2,ires,i),widnsp,maxtab2,mmin),minwid)
+ endif
+ else if (ires.ge.minmes.and.ires.le.maxmes) then !mesons
+ if (em.le.maxtab2) then
+c branching ratios are continued horicontally outside the spline region
+ b=max(splint(tabx,pmtaby(1,1,ires,i),
+ . pmtaby(1,2,ires,i),widnsp,em),minwid)
+ else
+ b=max(splint(tabx,pmtaby(1,1,ires,i),
+ . pmtaby(1,2,ires,i),widnsp,maxtab2),minwid)
+ endif
+ else
+ write (6,*) '*** error(fbrancx) wrong id:',ir
+ b=0
+ endif
+ else
+ b=0d0
+ if (bi.gt.0.and.em.gt.mmin.and.mn.gt.mmin) then
+
+ ipwr=flbr(i,ires)
+ ipwr1=ipwr+1
+
+c determine expectation values of outgoing masses
+c call of pmean with -99 instead of iso3 to ensure usage of fixed
+c resonance widths: 5% error, but avoids recursion via call
+c to fwidth from pmean
+ if(CTOption(33).ne.0)then
+ kdiv1=pmean(em,b1,-99,b2,-99,b3,-99,b4,-99,ipwr1)/
+ & pmean(mn,b1,-99,b2,-99,b3,-99,b4,-99,ipwr1)
+ kdiv2=pmean(em,b1,-99,b2,-99,b3,-99,b4,-99,ipwr)/
+ & pmean(mn,b1,-99,b2,-99,b3,-99,b4,-99,ipwr)
+ else
+ kdiv1=pmean(em,b1,isoit(b1),b2,isoit(b2),
+ & b3,isoit(b3),b4,isoit(b4),ipwr1)/
+ & pmean(mn,b1,isoit(b1),b2,isoit(b2),
+ & b3,isoit(b3),b4,isoit(b4),ipwr1)
+ kdiv2=pmean(em,b1,isoit(b1),b2,isoit(b2),
+ & b3,isoit(b3),b4,isoit(b4),ipwr)/
+ & pmean(mn,b1,isoit(b1),b2,isoit(b2),
+ & b3,isoit(b3),b4,isoit(b4),ipwr)
+ end if
+ b=bi*mn/em*kdiv1*1.2/(1.+0.2*kdiv2)
+ else
+ b=0.
+ end if
+ end if
+ fbrancx=b
+ return
+ end
+
diff --git a/Processes/UrQMD/blockres.f b/Processes/UrQMD/blockres.f
new file mode 100644
index 0000000000000000000000000000000000000000..fa6357301152c284ca1f328a25edcadcc71e3b30
--- /dev/null
+++ b/Processes/UrQMD/blockres.f
@@ -0,0 +1,1033 @@
+c $Id: blockres.f,v 1.19 2003/06/29 14:26:35 weber Exp $
+ blockdata setres
+cc itypes: 100 g, 101 pi, 102 eta, 103 om, 104 rho, 105 f_0(1370)
+cc 106 K, 107 eta', 108 K*, 109 phi,
+cc 0++ 110 k_0*(1430), 111 a_0(980), 112 f_0(1370)
+cc 1++ 113 k_1(1270), 114 a_1(1260), 115 f_1(1285), 116 f_1(1420),
+cc 2++ 117 k_2(1430), 118 a_2(1320), 119 f_2(1270), 120 f_2'(1525)
+cc 1+- 121 K_1(1400), 122 b_1(1235), 123 h_1(1170), 124 h_1'(1380)
+cc 1-- 125 K*(1410), 126 rho(1465), 127 om(1419), 128 phi(1680),
+cc 1-- 129 K*(1680), 130 rho(1700), 131 om(1662), 132 phi?(1900)
+cc
+cc (see 'Review of Particle Properties' Phys. Rev. D50 (1994)
+cc Phys. Rev. D54 (1996) and Eur. Phys. J. C3 (1998))
+cc
+ implicit none
+ include 'comres.f'
+ integer i, j, k
+
+c set a string for the what and ident tools
+ data versiontag/'@(#)$UrQMD: Version 1.3b (10035/10002) $'/
+c channels, branching ratios, angular momentum of branches,
+c etc.
+c ALL of the beyond is sensitive to the parameters defined in comres.f
+
+ data massres/0.938,
+c Nucleon resonances
+ @ 1.440,1.515,1.550,1.645,1.675,1.680,
+ @ 1.730,1.710,1.720,1.850,1.950,2.000, 2.150,
+ @ 2.220,2.250,
+c Delta (and resonances)(Particle Data Group)
+c @ 1.232,1.600,1.620,1.700,1.900,1.905,
+c @ 1.910,1.920,1.930,1.950,
+c Delta (and resonances)
+ @ 1.232,1.700,1.675,1.750,1.840,1.880,
+ @ 1.900,1.920,1.970,1.990,
+c Lambda (and resonances)
+ @ 1.116,1.407,1.520,1.600,1.670,1.690,
+ @ 1.800,1.810,1.820,1.830,1.890,2.100,
+ @ 2.110,
+c Sigma (and resonances)
+ @ 1.192,1.384,1.660,1.670,1.750,1.775,
+ @ 1.915,1.940,2.030,
+c Xi (and resonances)
+ @ 1.315,1.532,1.700,1.823,1.950,2.025,
+c @ 1.315,1.532,1.690,1.823,1.950,2.025,
+c Omega
+ @ 1.672/
+
+ data widres/ 0.d0,
+c Nucleon resonances
+ @ 0.350,0.120,0.140,0.160,0.140,0.120,
+ @ 0.120,0.140,0.150,0.500,0.550,0.350,0.500,
+ @ 0.550,0.470,
+c Delta (and resonances)(Particle-Data-Group)
+c @ 0.120,0.350,0.150,0.300,0.200,0.350,
+c @ 0.250,0.200,0.350,0.300,
+c Delta (and resonances)
+ @ 0.115,0.350,0.160,0.350,0.260,0.350,
+ @ 0.250,0.200,0.350,0.350,
+c Lambda (and resonances)
+ @ 0.,0.050,0.016,0.150,0.035,0.060,
+ @ 0.300,0.150,0.080,0.095,0.100,0.200,
+ @ 0.200,
+c Sigma (and resonances)
+ @ 0.,0.036,0.100,0.060,0.090,0.120,
+ @ 0.120,0.220,0.180,
+c Xi (and resonances)
+ @ 0.,0.009,0.05,0.024,0.06,0.02,
+c Omega
+ @ 0./
+
+ data massmes/
+c g pi eta omega rho f_0(980) K
+ & 0.000, 0.138, 0.547, 0.782, 0.769, 0.990, 0.494,
+c eta' K* phi
+ @ 0.958, 0.893, 1.019,
+c 0++ scalar k_0*(1430), a_0(980), f_0(1370)
+ @ 1.429, .990, 1.370,
+c 1++ k_1(1270),a_1(1260),f_1(1285),f_1(1420)
+ @ 1.273, 1.230, 1.282, 1.426,
+c 2++ tensor k_2*(1430),a_2(1320),f_2(1270),f_2'(1525)
+ @ 1.430, 1.318, 1.275, 1.525,
+c 1+- K_1(1400) b1 h1 h1'
+ @ 1.400, 1.235, 1.170, 1.386,
+c 1-- K rho omega phi
+ & 1.410,1.465,1.419,1.681,
+ & 1.680,1.720,1.649,1.910/
+
+ data widmes /
+c g pi eta omega rho f_0(980) K
+ & 0.0, 0.0, 0.0, 8.43e-3 ,0.151, 0.1, 0.0,
+c eta' K* phi
+ @ 0.201e-3, 50.e-3, 4.43e-3,
+c 0++ scalar k_0*(1430), a_0(980), f_0(1370)
+ @ .287, .100, .200,
+c 1++ pseudo-vector k_1(1270),a_1(1260),f_1(1285),f_1(1420)
+ @ .090, .400, .024, .055,
+c 2++ tensor k_2*(1430),a_2(1320),f_2(1270),f_2'(1525)
+ @ .100, .107, .185, .076,
+c 1+- k1(1400) b1 h1 h1*
+ @ 0.174, 0.142, 0.36, 0.09,
+c 1-- K rho omega phi
+ & 0.227, 0.310, 0.174, 0.150,
+ & 0.323, 0.240, 0.220, 0.090/
+
+c Spins of resonances and mesons (multiplied by two):
+
+ data Jres/ 1,
+ @ 1, 3, 1, 1, 5, 5,
+ @ 3, 1, 3, 3, 7, 3, 7,
+ @ 9, 9,
+ D 3, 3, 1, 3, 1, 5,
+ @ 1, 3, 5, 7,
+ L 1, 1, 3, 1, 1, 3,
+ @ 1, 1, 5, 5, 3, 7, 5,
+ S 1, 3, 1, 3, 1, 5,
+ @ 5, 3, 7,
+ X 1, 3, 3, 3, 3, 5,
+ O 3 /
+
+ data Jmes/ 2,0,0,2,2,0,0,0,2,2,0,0,0,2,2,2,2,4,4,4,4,2,2,2,2,
+c 1--
+ & 2,2,2,2,2,2,2,2/
+
+c Parities of resonances and mesons:
+
+ data Pares/ 1,
+ @ 1, -1, -1, -1, -1, 1,
+ @ -1, 1, 1, 1, 1, -1, -1,
+ @ 1, -1,
+ D 1, 1, -1, -1, -1, 1,
+ @ 1, 1, -1, 1,
+ L 1, -1, -1, 1, -1, -1,
+ @ -1, 1, 1, -1, 1, -1, 1,
+ S 1, 1, 1, -1, -1, -1,
+ @ 1, -1, 1,
+c some Xi parities are unknown ? ? ?
+ X 1, 1, 1, -1, 1, 1,
+ O 1 /
+
+c g pi et om rh si k et k* ph k0* a0 f0 k1 a1 f1 f1*
+ data Pames/ -1,-1,-1,-1,-1, 1,-1,-1,-1,-1, 1, 1, 1, 1, 1, 1, 1,
+c k2 a2 f2* f2' k1 b1 h1 h1* rh* rh* om* om*
+ & 1, 1, 1, 1, 1, 1, 1, 1,
+c 1-- (incl. rh* rh* om* om*)
+ & -1, -1, -1, -1, -1, -1, -1, -1/
+
+c
+
+c Isospins of resonances and mesons (multiplied by two)
+
+ data Isores/ 1,
+ @ 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
+ d 3,3,3,3,3,3,3,3,3,3,
+ l 0,0,0,0,0,0,0,0,0,0,0,0,0,
+ s 2,2,2,2,2,2,2,2,2,
+ x 1,1,1,1,1,1,
+ o 0/
+ data Isomes/ 0,2,0,0,2,0,1,0,1,0,1,2,0,1,2,0,0,1,2,0,0,1,2,0,0,
+c 1--
+ & 1,2,0,0,1,2,0,0/
+c & 2,2,0,0/
+
+c strres gives the number of strange quarks for baryons
+c (switch sign for anti-part.)
+ data strres/ 26*0,13*1,9*1,6*2,3/
+c strmes gives the number of strange quarks for mesons
+c (switch sign for anti-part.)
+ data strmes/ 6*0,-1,0,-1,0,-1,0,0,-1,0,0,0,-1,0,0,0,-1,0,0,0,
+c 1--
+ & -1,0,0,0,-1,0,0,0/
+c & 0,0,0,0/
+
+
+c meson id's sorted by multipletts
+ data mlt2it/
+ & 101, 106, 102, 107,
+ & 104, 108, 103, 109,
+ & 111, 110, 105, 112,
+ & 114, 113, 115, 116,
+ & 118, 117, 119, 120,
+ & 122, 121, 123, 124,
+ & 126, 125, 127, 128,
+ & 130, 129, 131, 132/
+
+
+c the decay branches have different angular momentum
+C gN,piN,etN,omN,rhN,pipiN,piD,piN*,KL,KS,f0N,a0N
+c now some n*'s
+ data lbr/
+ & 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0,
+ & 0, 2, 2, 0, 0, 2, 0, 2, 2, 2, 1, 1,
+ & 0, 0, 0, 0, 0, 0, 2, 0, 0, 0, 1, 1,
+ & 0, 0, 0, 0, 0, 0, 2, 0, 0, 0, 1, 1,
+ & 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 3, 3,
+ & 1, 3, 3, 1, 1, 3, 1, 3, 3, 3, 2, 2,
+ & 0, 2, 2, 0, 0, 2, 0, 2, 2, 2, 1, 1,
+ & 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0,
+ & 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2,
+ & 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2,
+ & 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 4, 4,
+ & 0, 2, 2, 0, 0, 2, 0, 2, 2, 2, 1, 1,
+ & 2, 4, 4, 2, 2, 4, 2, 4, 4, 4, 3, 3,
+ & 3, 5, 5, 3, 3, 5, 3, 5, 5, 5, 4, 4,
+ & 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 5, 5,
+
+
+c d,d*
+ & 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2,
+ & 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2,
+ & 0, 0, 0, 0, 0, 0, 2, 0, 0, 0, 1, 1,
+ & 0, 2, 2, 0, 0, 2, 0, 2, 2, 2, 1, 1,
+ & 0, 0, 0, 0, 0, 0, 2, 0, 0, 0, 1, 1,
+ & 1, 3, 3, 1, 1, 3, 1, 3, 3, 3, 2, 2,
+ & 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0,
+ & 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2,
+ & 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 3, 3,
+ & 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 4, 4/
+
+
+ data lbs1/
+c orbital angular momentum of decays (baryons with s=1)
+c _ _ _
+c NK NK892 Sipi Si*pi gLa etLa omLa Lapi etSi La*pi DelK
+c lambda*'s
+ & 0, 0, 0, 2, 0, 0, 0, 0, 0, 1, 2,
+ & 2, 0, 2, 0, 0, 2, 0, 2, 2, 1, 0,
+ & 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 1,
+ & 0, 0, 0, 2, 0, 0, 0, 0, 0, 1, 2,
+ & 2, 0, 2, 0, 0, 2, 0, 2, 2, 1, 0,
+ & 0, 0, 0, 2, 0, 0, 0, 0, 0, 1, 2,
+ & 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 1,
+ & 3, 1, 3, 1, 1, 3, 1, 3, 3, 2, 1,
+ & 2, 2, 2, 2, 2, 2, 2, 2, 2, 1, 2,
+ & 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 1,
+ & 4, 2, 4, 2, 2, 4, 2, 4, 4, 3, 2,
+ & 3, 1, 3, 1, 1, 3, 1, 3, 3, 2, 1,
+c sigma's
+ & 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 1,
+ & 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 1,
+ & 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 1,
+ & 2, 0, 2, 0, 0, 2, 0, 2, 2, 1, 0,
+ & 0, 0, 0, 2, 0, 0, 0, 0, 0, 1, 2,
+ & 2, 2, 2, 2, 2, 2, 2, 2, 2, 1, 2,
+ & 3, 1, 3, 1, 1, 3, 1, 3, 3, 2, 1,
+ & 2, 0, 2, 0, 0, 2, 0, 2, 2, 1, 0,
+ & 3, 3, 3, 3, 3, 3, 3, 3, 3, 2, 3/
+
+
+ data lbs2/
+c orbital angular momentum of decays (baryons with s=2)
+ & 1, 1, 1, 1,
+ & 1, 1, 1, 1,
+ & 2, 0, 2, 2,
+ & 1, 1, 1, 1,
+ & 3, 1, 3, 3/
+
+ data lbm/
+c orbital angular momentum of meson decays
+c (9 stands for 'forbidden', branching ratio should be zero!)
+C gg gpi grho gome geta gK 2pi pirho pisi pieta sisi
+c 0 1 2 3 4 5 6 7 8 9 10
+c rhet etsig 2rho rhom 2eta KK KK* Kpi K*pi Krho kome K*K ompi
+c 11 12 13 14 15 16 17 18 19 20 21 22 23
+c
+C gg gpi grho gome geta gK 2pi pirho 3pi pieta 4pi KK* K*K
+c 0 1 2 3 4 5 6 7 8 9 10 11 12
+c et2pi etrho rho2pi om2pi 2eta KK 2Kpi Kpi K*pi Krho kom K*2pi ompi
+c 13 14 15 16 17 18 19 20 21 22 23 24 25
+c 8 10 121314 1617 19 23
+ & 1,1,1,1,1,1,9,1,9,9,9,1,1,9,1,1,1,9,9,9,9,1,1,1,1,1, !101
+ & 1,1,1,1,1,1,9,1,9,9,9,1,1,9,1,1,1,9,9,9,9,1,1,1,1,1, !102
+ & 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, !103
+ & 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, !104
+ & 0,9,0,0,9,9,0,9,0,0,0,9,9,0,9,9,9,0,0,0,0,9,9,9,9,9, !105
+ & 1,1,1,1,1,1,9,1,9,9,9,1,1,9,1,1,1,9,9,9,9,1,1,1,1,1, !106
+ & 1,1,1,1,1,1,9,1,9,9,9,1,1,9,1,1,1,9,9,9,9,1,1,1,1,1, !107
+ & 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, !108
+ & 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, !109
+c 0++
+c 8 10 121314 1617 19 23
+ & 0,9,0,0,9,9,0,9,0,0,0,9,9,0,9,9,9,0,0,0,0,9,9,9,9,9, !110
+ & 0,9,0,0,9,9,0,9,0,0,0,9,9,0,9,9,9,0,0,0,0,9,9,9,9,9,
+ & 0,9,0,0,9,9,0,9,0,0,0,9,9,0,9,9,9,0,0,0,0,9,9,9,9,9,
+c 1++
+ & 0,0,0,0,0,0,9,0,9,9,9,0,0,9,0,0,0,9,9,9,9,0,0,0,0,0,
+ & 0,0,0,0,0,0,9,0,9,9,9,0,0,9,0,0,0,9,9,9,9,0,0,0,0,0,
+ & 0,0,0,0,0,0,9,0,9,9,9,0,0,9,0,0,0,9,9,9,9,0,0,0,0,0,
+ & 0,0,0,0,0,0,9,0,9,9,9,0,0,9,0,0,0,9,9,9,9,0,0,0,0,0,
+c 2++
+ & 0,2,0,0,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,
+ & 0,2,0,0,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,
+ & 0,2,0,0,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,
+ & 0,2,0,0,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,
+c 1+-
+C gg gpi grho gome geta gK 2pi pirho pisi pieta sisi
+c 0 1 2 3 4 5 6 7 8 9 10
+c rhet etsig 2rho rhom 2eta KK KK* Kpi K*pi Krho kome K*K ompi
+c 11 12 13 14 15 16 17 18 19 20 21 22 23
+c
+C gg gpi grho gome geta gK 2pi pirho 3pi pieta 4pi KK* K*K
+c 0 1 2 3 4 5 6 7 8 9 10 11 12
+c et2pi etrho rho2pi om2pi 2eta KK 2Kpi Kpi K*pi Krho kom K*2pi ompi
+c 13 14 15 16 17 18 19 20 21 22 23 24 25
+c 8 10 121314 1617 19 23
+ & 0,0,0,0,0,0,9,0,9,9,9,0,0,9,0,0,0,9,9,9,9,0,0,0,0,0,
+ & 0,0,0,0,0,0,9,0,9,9,9,0,0,9,0,0,0,9,9,9,9,0,0,0,0,0,
+ & 0,0,0,0,0,0,9,0,9,9,9,0,0,9,0,0,0,9,9,9,9,0,0,0,0,0,
+ & 0,0,0,0,0,0,9,0,9,9,9,0,0,9,0,0,0,9,9,9,9,0,0,0,0,0,
+c 1--
+ & 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
+ & 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
+ & 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
+ & 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
+c 1--
+ & 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
+ & 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
+ & 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
+ & 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1/
+
+
+ data branres/
+
+Channels: gN piN etN omN rhN pipiN piD piN* KL KS f0N a0N
+c n* resonances
+ a 4d-4, .65, .00, .00, .00, .10, .25, .00, .00, .00, .00, .00, !1440
+ b 45d-4, .60, .00, .00, .15, .05, .20, .00, .00, .00, .00, .00, !1520
+ c 45d-4, .60, .30, .00, .00, .05, .00, .05, .00, .00, .00, .00, !1535
+ d 1d-3 , .60, .06, .00, .00, .10, .10, .05, .07, .02, .00, .00, !1650
+ e 5d-5 , .40, .00, .00, .00, .00, .55, .05, .00, .00, .00, .00, !1675
+ f 21d-4, .60, .00, .00, .00, .20, .15, .05, .00, .00, .00, .00, !1680
+ g 1d-4 , .05, .15, .00, .05, .30, .40, .05, .00, .00, .00, .00, !1700
+ h 0., .16, .15, .00, .05, .26, .20, .10, .05, .03, .00, .00, !1710
+ i 1d-4 , .10, .00, .00, .80, .05, .00, .00, .03, .02, .00, .00, !1720
+ j 0., .30, .00, .55, .15, .00, .00, .00, .00, .00, .00, .00, !1900
+ k 0., .12, .00, .00, .43, .19, .14, .05, .03, .00, .04, .00, !1990
+ l 0., .45, .10, .10, .20, .05, .10, .00, .00, .00, .00, .00, !2080
+ m 0., .35, .00, .05, .30, .10, .15, .05, .00, .00, .00, .00, !2190
+ n 0., .35, .00, .00, .25, .20, .20, .00, .00, .00, .00, .00, !2220
+ o 0., .30, .00, .00, .25, .20, .20, .05, .00, .00, .00, .00, !2250
+c delta resonances
+ a 6d-3, 1.0, .00, .00, .00, .00, .00, .00, .00, .00, .00, .00, !1232
+ b 0., .10, .00, .00, .00, .00, .65, .25, .00, .00, .00, .00, !1600
+ c 4d-4, .15, .00, .00, .05, .00, .65, .15, .00, .00, .00, .00, !1620
+ d 2d-3, .20, .00, .00, .25, .00, .55, .00, .00, .00, .00, .00, !1700
+ e 0., .25, .00, .00, .25, .00, .25, .25, .00, .00, .00, .00, !1900
+ f 3d-4, .18, .00, .00, .80, .00, .02, .00, .00, .00, .00, .00, !1905
+ g 0., .30, .00, .00, .10, .00, .35, .25, .00, .00, .00, .00, !1910
+ h 0., .27, .00, .00, .00, .00, .40, .30, .00, .03, .00, .00, !1920
+ i 0., .22, .00, .00, .05, .00, .40, .30, .00, .03, .00, .00, !1930
+ j 15d-3, .38, .00, .00, .00, .00, .34, .24, .00, .00, .00, .04/ !1950
+
+
+ data branbs1/
+c...the branching ratios for unstable baryons with strangeness -1:
+channels: _ _ _
+c NK NK892 Sipi Si*pi gLa etLa omLa Lapi etSi La*pi DelK
+c lambda*'s
+ @ .00, .00,1.00, .00, .00, .00, .00, .00, .00, .00, .00,
+ @ .45, .00, .43, .11,.008, .00, .00, .00, .00, .00, .00,
+ @ .35, .00, .65, .00, .00, .00, .00, .00, .00, .00, .00,
+ @ .20, .00, .50, .00, .00, .30, .00, .00, .00, .00, .00,
+ @ .25, .00, .45, .30, .00, .00, .00, .00, .00, .00, .00,
+ @ .40, .20, .20, .20, .00, .00, .00, .00, .00, .00, .00,
+ @ .35, .45, .15, .05, .00, .00, .00, .00, .00, .00, .00,
+ @ .65, .00, .14, .10, .00, .00, .00, .00, .00, .00, .00,
+ @ .10, .00, .70, .20, .00, .00, .00, .00, .00, .00, .00,
+ @ .35, .20, .10, .30, .00, .00, .00, .00, .00, .00, .00,
+ @ .35, .20, .05, .30, .00, .02, .08, .00, .00, .00, .00,
+ @ .25, .45, .30, .00, .00, .00, .00, .00, .00, .00, .00,
+c sigma's ! stable particles shoud add to zero!
+ @ .00, .00, .00, .00, .00, .00, .00, .00, .00, .00, .00,
+ @ .00, .00, .12, .00, .00, .00, .00, .88, .00, .00, .00,
+ @ .30, .00, .35, .00, .00, .00, .00, .35, .00, .00, .00,
+ @ .15, .00, .70, .00, .00, .00, .00, .15, .00, .00, .00,
+ @ .40, .00, .05, .00, .00, .00, .00, .00, .55, .00, .00,
+ @ .40, .00, .04, .10, .00, .00, .00, .23, .00, .23, .00,
+ @ .15, .00, .40, .05, .00, .00, .00, .40, .00, .00, .00,
+ @ .10, .15, .15, .15, .00, .00, .00, .15, .00, .15, .15,
+ @ .20, .04, .10, .10, .00, .00, .00, .20, .00, .18, .18/
+
+ data branbs2/
+c...the branching ratios for unstable baryons with strangeness -2:
+channels: _ _
+c Xipi Xigamma LaK SigK
+c Xi's
+ @ .98, .02, 0., 0.,
+ @ .10, .00, .70, .20,
+ @ .15, .00, .70, .15,
+ @ .20, .00, .40, .20,
+ @ .10, .00, .20, .70/
+
+
+ data branmes /
+C gg gpi grho gome geta gK 2pi pirho 3pi pieta 4pi KK* K*K
+c 0 1 2 3 4 5 6 7 8 9 10 11 12
+c et2pi etrho rho2pi om2pi 2eta KK 2Kpi Kpi K*pi Krho kom K*2pi ompi
+c 13 14 15 16 17 18 19 20 21 22 23 24 25
+c pion
+ a 1.00, .00, .00, .00, .00, .00, .00, .00, .00, .00, .00, .00, .00,
+ a .00, .00, .00, .00, .00, .00, .00, .00, .00, .00, .00, .00, .00,
+c eta
+ a .00, .00, .00, .00, .00, .00, .00, .00, .00, .00, .00, .00, .00,
+ a .00, .00, .00, .00, .00, .00, .00, .00, .00, .00, .00, .00, .00,
+c omega
+ a .00, .09, .00, .00, .00, .00, .02, .00, .89, .00, .00, .00, .00,
+ a .00, .00, .00, .00, .00, .00, .00, .00, .00, .00, .00, .00, .00,
+c rho(770)
+ a .00, .00, .00, .00, .00, .00,1.00, .00, .00, .00, .00, .00, .00,
+ a .00, .00, .00, .00, .00, .00, .00, .00, .00, .00, .00, .00, .00,
+c f_0(980)
+ a .00, .00, .00, .00, .00, .00, .70, .00, .00, .00, .00, .00, .00,
+ a .00, .00, .00, .00, .00, .30, .00, .00, .00, .00, .00, .00, .00,
+c kaon
+ a .00, .00, .00, .00, .00, .00, .00, .00, .00, .00, .00, .00, .00,
+ a .00, .00, .00, .00, .00, .00, .00, .00, .00, .00, .00, .00, .00,
+c eta'
+ a .02, .00, .30, .03, .00, .00, .00, .00, .00, .00, .00, .00, .00,
+ a .65, .00, .00, .00, .00, .00, .00, .00, .00, .00, .00, .00, .00,
+c K*(892)
+ a .00, .00, .00, .00, .00,.003, .00, .00, .00, .00, .00, .00, .00,
+ a .00, .00, .00, .00, .00, .00, .00,1.00, .00, .00, .00, .00, .00,
+c phi
+ a .00, .00, .00, .00, .01, .00, .00, .13, .02, .00, .00, .00, .00,
+ a .00, .00, .00, .00, .00, .84, .00, .00, .00, .00, .00, .00, .00,
+c K_0(1430)
+ a .00, .00, .00, .00, .00, .00, .00, .00, .00, .00, .00, .00, .00,
+ a .00, .00, .00, .00, .00, .00, .00,1.00, .00, .00, .00, .00, .00,
+c a_0(980)
+ a .00, .00, .00, .00, .00, .00, .00, .00, .00, .90, .00, .00, .00,
+ a .00, .00, .00, .00, .00, .10, .00, .00, .00, .00, .00, .00, .00,
+c f_0(1370)
+ a .00, .00, .00, .00, .00, .00, .10, .00, .00, .00, .70, .00, .00,
+ a .00, .00, .00, .00, .00, .20, .00, .00, .00, .00, .00, .00, .00,
+C gg gpi grho gome geta gK 2pi pirho 3pi pieta 4pi KK* K*K
+c 0 1 2 3 4 5 6 7 8 9 10 11 12
+c et2pi etrho rho2pi om2pi 2eta KK 2Kpi Kpi K*pi Krho kom K*2pi ompi
+c 13 14 15 16 17 18 19 20 21 22 23 24 25
+c K_1(1270)
+ a .00, .00, .00, .00, .00, .00, .00, .00, .00, .00, .00, .00, .00,
+ a .00, .00, .00, .00, .00, .00, .00, .00, .47, .42, .11, .00, .00,
+c a_1(1260)
+ a .00, .10, .00, .00, .00, .00, .00, .90, .00, .00, .00, .00, .00,
+ a .00, .00, .00, .00, .00, .00, .00, .00, .00, .00, .00, .00, .00,
+c f_1(1285)
+ a .00, .00, .05, .00, .00, .00, .00, .00, .00, .00, .33, .00, .00,
+ a .53, .00, .00, .00, .00, .00, .09, .00, .00, .00, .00, .00, .00,
+c f_1(1420)
+ a .00, .00, .00, .00, .00, .00, .00, .00, .04, .00, .00, .48, .48,
+ a .00, .00, .00, .00, .00, .00, .00, .00, .00, .00, .00, .00, .00,
+c k_2(1430)
+ a .00, .00, .00, .00, .00, .00, .00, .00, .00, .00, .00, .00, .00,
+ a .00, .00, .00, .00, .00, .00, .00, .50, .25, .09, .03, .13, .00,
+c a_2(1320)
+ a .00, .00, .00, .00, .00, .00, .00, .70, .00, .14, .00, .00, .00,
+ a .00, .00, .00, .11, .00, .05, .00, .00, .00, .00, .00, .00, .00,
+c f_2(1270)
+ a .00, .00, .00, .00, .00, .00, .50, .00, .00, .00, .30, .00, .00,
+ a .00, .00, .00, .00, .00, .20, .00, .00, .00, .00, .00, .00, .00,
+c f_2'(1525)
+ a .00, .00, .00, .00, .00, .00, .01, .00, .00, .00, .00, .00, .00,
+ a .00, .00, .00, .00, .10, .89, .00, .00, .00, .00, .00, .00, .00,
+C gg gpi grho gome geta gK 2pi pirho 3pi pieta 4pi KK* K*K
+c 0 1 2 3 4 5 6 7 8 9 10 11 12
+c et2pi etrho rho2pi om2pi 2eta KK 2Kpi Kpi K*pi Krho kom K*2pi ompi
+c 13 14 15 16 17 18 19 20 21 22 23 24 25
+c 1+-
+c K_1(1400)
+ a .00, .00, .00, .00, .00, .00, .00, .00, .00, .00, .00, .00, .00,
+ a .00, .00, .00, .00, .00, .00, .00, .00, .96, .03, .01, .00, .00,
+c b_1(1235)
+ a .00, .00, .00, .00, .00, .00, .00, .00, .00, .00, .00, .00, .00,
+ a .00, .10, .00, .00, .00, .00, .00, .00, .00, .00, .00, .00, .90,
+c h_1(1170)
+ a .00, .00, .00, .00, .00, .00, .00, .90, .10, .00, .00, .00, .00,
+ a .00, .00, .00, .00, .00, .00, .00, .00, .00, .00, .00, .00, .00,
+c h_1'(1380)
+ a .00, .00, .00, .00, .00, .00, .00, .00, .00, .00, .00, .50, .50,
+ a .00, .00, .00, .00, .00, .00, .00, .00, .00, .00, .00, .00, .00,
+C gg gpi grho gome geta gK 2pi pirho 3pi pieta 4pi KK* K*K
+c 0 1 2 3 4 5 6 7 8 9 10 11 12
+c et2pi etrho rho2pi om2pi 2eta KK 2Kpi Kpi K*pi Krho kom K*2pi ompi
+c 13 14 15 16 17 18 19 20 21 22 23 24 25
+c 1--
+c K*(1410)
+ a .00, .00, .00, .00, .00, .00, .00, .00, .00, .00, .00, .00, .00,
+ a .00, .00, .00, .00, .00, .00, .00, .30, .65, .05, .00, .00, .00,
+c rho(1450)
+ a .00, .00, .00, .00, .00, .00, .50, .00, .00, .00, .50, .00, .00,
+ a .00, .00, .00, .00, .00, .00, .00, .00, .00, .00, .00, .00, .00,
+c om(1420)
+ a .00, .00, .00, .00, .00, .00, .00,1.00, .00, .00, .00, .00, .00,
+ a .00, .00, .00, .00, .00, .00, .00, .00, .00, .00, .00, .00, .00,
+c phi(1680)
+ a .00, .00, .00, .00, .00, .00, .00, .00, .00, .00, .00, .40, .40,
+ a .00, .00, .00, .00, .00, .10, .10, .00, .00, .00, .00, .00, .00,
+C gg gpi grho gome geta gK 2pi pirho 3pi pieta 4pi KK* K*K
+c 0 1 2 3 4 5 6 7 8 9 10 11 12
+c et2pi etrho rho2pi om2pi 2eta KK 2Kpi Kpi K*pi Krho kom K*2pi ompi
+c 13 14 15 16 17 18 19 20 21 22 23 24 25
+c 1--
+c K*(1680)
+ a .00, .00, .00, .00, .00,.003, .00, .00, .00, .00, .00, .00, .00,
+ a .00, .00, .00, .00, .00, .00, .00, .40, .30, .30, .00, .00, .00,
+c rho(1700)
+ a .00, .00, .00, .00, .00, .00, .20, .00, .00, .00, .10, .00, .00,
+ a .00, .00, .70, .00, .00, .00, .00, .00, .00, .00, .00, .00, .00,
+c om(1600)
+ a .00, .00, .00, .00, .00, .00, .00, .50, .00, .00, .00, .00, .00,
+ a .00, .00, .00, .50, .00, .00, .00, .00, .00, .00, .00, .00, .00,
+c phi(1900)
+ a .00, .00, .00, .00, .00, .00, .20, .00, .00, .00, .00, .00, .00,
+ a .00, .00, .00, .00, .10, .70, .00, .00, .00, .00, .00, .00, .00
+ a /
+C gg gpi grho gome geta gK 2pi pirho 3pi pieta 4pi KK* K*K
+c 0 1 2 3 4 5 6 7 8 9 10 11 12
+c et2pi etrho rho2pi om2pi 2eta KK 2Kpi Kpi K*pi Krho kom K*2pi ompi
+c 13 14 15 16 17 18 19 20 21 22 23 24 25
+
+c minimal masses of mesons
+c g pi eta om rh f0 k
+ data mmesmn/0.0,0.138,0.547,0.276,0.276,0.276,0.495,
+c eta', k*, phi,k_0*, a_0,f_0
+ a 0.278,0.636,.414,.636,0.685,0.276,
+c k1 a1 f1 f1 k2* a2* f2 f2'
+ a 0.774, 0.414, 0.276,1.272,0.636,0.414,0.276,.990,
+c 1+-
+ & 0.774,0.556,0.417,1.272,
+c 1--
+ & 0.636, 0.278, 0.414, 0.990,
+ & 0.636, 0.278, 0.414, 0.990/
+
+ data bmtype/
+c for each branch you have itype1(M),itype2(M),itype3(M),itype4(M)
+c in case of resonances in the exit-channel, maximum two are allowed
+c which must be listed as the first two entries
+c note: if total strangeness .ne.0, the first meson should be strange!
+c g g g pi g rho g om
+ @ 100,100,0,0, 100,101,0,0, 100,104,0,0, 100,103,0,0,
+c g eta k g pi pi pi rho
+ @ 100,102,0,0, 106,100,0,0, 101,101,0,0, 101,104,0,0,
+c pi pi pi pi et pi pi pi pi k kbar*
+ @ 101,101,101,0, 101,102,0,0, 101,101,101,101, 106,-108,0,0,
+c kbar k* et pi pi
+ @ -106,108,0,0, 102,101,101,0,
+c rho et rho pi pi om pi pi et et
+ @ 104,102,0,0, 104,101,101,0, 103,101,101,0, 102,102,0,0,
+c k kbar k kbar pi k pi k* pi
+ @ 106,-106,0,0, 106,-106,101,0, 106,101,0,0, 108,101,0,0,
+c k rho k om k* pi pi om pi
+ @ 106,104,0,0, 106,103,0,0, 108,101,101,0, 103,101,0,0/
+
+ data brtype/
+c non-strange baryon decay branches:
+c for each branch you have a maximum of 4 outgoing itypes
+c in case of resonances in the exit-channel, maximum two are allowed
+c which must be listed as the first two entries
+c N g N pi N et N om N rho
+ @ 1,100,0,0, 1,101,0,0, 1,102,0,0, 1,103,0,0, 1,104,0,0,
+c N pi pi Delta pi N* pi La k Sig k
+ @ 1,101,101,0, 17,101,0,0, 2,101,0,0, 27,106,0,0, 40,106,0,0,
+c N f0 N a0
+ @ 1,105,0,0, 1,111,0,0/
+
+
+
+c strangeness -1 baryon decay branches:
+c in case of resonances in the exit-channel, maximum two are allowed
+c which must be listed as the first two entries
+ data bs1type/
+c N Kbar N K*bar Si pi Si*pi
+ @ 1,-106,0,0, 1,-108,0,0, 40,101,0,0, 41,101,0,0,
+c La g La et La om La pi
+ @ 27,100,0,0, 27,102,0,0, 27,103,0,0, 27,101,0,0,
+c Si et La* pi Delta kbar
+ @ 40,102,0,0, 29,101,0,0, 17,-106,0,0/
+
+c strangeness -2 baryon decay branches:
+c in case of resonances in the exit-channel, maximum two are allowed
+c which must be listed as the first two entries
+ data bs2type/
+c Xi pi Xi pi La Kbar Si Kbar
+ @ 49,101,0,0, 49,100,0,0, 27,-106,0,0, 40,-106,0,0/
+
+
+c
+cccccccccccccccccccc pointer arrays for cross sections cccccccccccccccccc
+c general structure:
+c SigmaLn(SigLnXX(ICLTYP),*) contains in its columns
+c EITHER flags for the crossx and make22 subroutines in which
+c the respective parametrizations and exitchannels are stored
+c OR the line-numbers of the
+c sigmainf(LINE,*) and sigmascal(LINE,*) arrays
+c in which information about the cross sections for the processes with
+c particles of ITYPs ITYP1 and ITYP2 in the entry channel are stored.
+c The first entry in the respective LINE of the sigmainf contains
+c the number of possible exit channels for the collision and the
+c second entry points to the total cross section.
+c The ELASTIC cross section MUST always exist and be the FIRST
+c cross section entry after the total cross section!!
+c In case of NEGATIVE LINENUMBERS in sigmaLn(j>2,i), a DETAILED BALANCE
+c calculation will be performed
+
+
+ data (((sigmaLN(i,j,k),i=1,maxpsig),j=1,2),k=1,maxreac) /
+c 1 proton neutron
+c nCH t el ND pN* ND* DD DN* DD*
+ . 9, 16, 17, 1, 2, 3, 4, 5, 6, 7, 15, 0,
+ . 0, 0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 0,
+c 2 proton proton (and neutron neutron)
+c nCH t el ND pN* ND* DD DN* DD*
+ . 9, 18, 19, 1, 2, 3, 4, 5, 6, 7, 15, 0,
+ . 0, 0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 0,
+c 3 D N (sigtot=-1 sum over branches for total cross section)
+ . 5, -1, 13, 30, 8, 35, 15, 0, 0, 0, 0, 0,
+ . 0, 0, 1, 1, 1, 1, 1, 0, 0, 0, 0, 0,
+c 4 N* N (sigtot=-1 sum over branches for total cross section)
+ . 4, 12, 13, -2, 14, 15, 0, 0, 0, 0, 0, 0,
+ . 0, 0, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0,
+c 5 D* N(sigtot=-1 sum over branches for total cross section)
+ . 4, 12, 13, -3, 14, 15, 0, 0, 0, 0, 0, 0,
+ . 0, 0, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0,
+c 6 D D (sigtot=-1 sum over branches for total cross section)
+ . 5, -1, 13, 32, 31, 14, 15, 0, 0, 0, 0, 0,
+ . 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+c 7 D N* (sigtot=-1 sum over branches for total cross section)
+ . 4, 12, 13, -5, 14, 15, 0, 0, 0, 0, 0, 0,
+ . 0, 0, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0,
+c 8 D D* (sigtot=-1 sum over branches for total cross section)
+ . 4, 12, 13, -6, 14, 15, 0, 0, 0, 0, 0, 0,
+ . 0, 0, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0,
+c 9 meson baryon
+ . 5, 25, 26, 10, 27, 28, 36, 0, 0, 0, 0, 0,
+ . 0, 0, 1, 0, 1, 1, 0, 0, 0, 0, 0, 0,
+c10 meson meson (are automatically summed)
+ . 5, -1, 38, 11, 27, 28, 37, 0, 0, 0, 0, 0,
+ . 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+c11 bbar-b
+ . 3, -1, 22, 23, 24, 0, 0, 0, 0, 0, 0, 0,
+ . 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+c12 D*D* or D*N* or N*N*
+ . 4, 12, 13, -7, 14, 15, 0, 0, 0, 0, 0, 0,
+ . 0, 0, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0,
+c13 BB (for all that are not specified above: YY etc.)
+ . 2, 12, 13, 15, 0, 0, 0, 0, 0, 0, 0, 0,
+ . 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0 /
+
+
+cccccccccccccccccccc cross sections info ccccccccccccccccccccccccccccccccccccc
+c IMPORTANT:
+c In sigmainf(LINE,*) the following information is stored:
+c column 1 : line# number for sigmas(line#,*) array (index(sig))
+c column 2 : flag for angular distribution in the out-channel
+c 0 : isotropic scattering
+c 1 : elastic scattering (ident. part.) ang. distrib. exp (-as)
+c 2 : elastic scattering (non ident. part.) ang. distrib.
+c 3 : f-b peaked N N to N Delta
+c 3 : number of particles in the out-channel
+c ( 0 for total cross sections)
+c for <0 number of calls to crossx for sub-branches
+c 4 - 8 : ITYPs of particles in the out-channel
+c 9 - 15: 2*I3 of particles in the out-channel (-9 for isocgk call)
+c DANGER: the entries have to be sorted in a way, that ALL
+c unknown I3 components (those which are -9) are
+c at the END of the list !!!
+ccccccccccccccc
+c IN sigmascal(LINE,*) the following information is stored:
+c column 1 : scaling factor for cross section in sigmas(line#,*)
+c column 2 : sqrt(s) value corresponding to entry sigmas(line#,1)
+c column 3 : Delta(sqrt(s)) between sigmas(line#,n) and sigmas(line#,n+1)
+c column 4,5 : undefined (optionally formation time for outgoing channel)
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c proton - neutron total cs. index(inf)=1, index(sig)=1
+ data (sigmainf(1,i),i=1,20) /
+ @ 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ @ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 /
+
+ data(sigmascal(1,i),i=1,5) /
+ @ 1.0000000, 1.8964808, 0.0100000, 0.0000000, 0.0000000 /
+
+
+c proton - neutron elastic cs. index(inf)=2, index(sig)=2
+ data (sigmainf(2,i),i=1,20) /
+ @ 2, 2, 2, 1, 1, 0, 0, 0, -9, -9,
+ @ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 /
+
+ data(sigmascal(2,i),i=1,5) /
+ @ 1.0000000, 1.8964808, 0.0100000, 0.0000000, 0.0000000 /
+
+
+c proton - proton (neutron - neutron) total cs. index(inf)=3, index(sig)=3
+c low energy forward peak is subtracted
+ data (sigmainf(3,i),i=1,20) /
+ @ 3, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ @ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 /
+
+ data(sigmascal(3,i),i=1,5) /
+ @ 1.0000000, 1.8964808, 0.0100000, 0.0000000, 0.0000000 /
+
+
+c proton - proton (neutron-neutron) elastic cs. index(inf)=4, index(sig)=4
+ data (sigmainf(4,i),i=1,20) /
+ @ 4, 1, 2, 1, 1, 0, 0, 0, -9, -9,
+ @ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 /
+
+ data(sigmascal(4,i),i=1,5) /
+ @ 1.0000000, 1.8964808, 0.0100000, 0.0000000, 0.0000000 /
+
+
+cccccccccccccccccccccccc cross sections sigmas() cccccccccccccccccccccccccc
+c
+c proton - neutron total cs. index=1
+ data (sigmas(1,i),i=1,ITBLSZ) /
+ @248.20, 93.38, 55.26, 44.50, 41.33, 38.48, 37.20, 35.98,
+ @ 35.02, 34.47, 34.37, 34.67, 35.23, 35.97, 36.75, 37.37,
+ @ 37.77, 38.03, 38.40, 38.83, 39.26, 39.67, 40.06, 40.45,
+ @ 40.79, 41.06, 41.31, 41.52, 41.70, 41.81, 41.87, 41.98,
+ @ 42.12, 42.29, 42.55, 42.82, 43.01, 43.12, 43.16, 43.14,
+ @ 43.06, 42.95, 42.81, 42.67, 42.54, 42.45, 42.38, 42.33,
+ @ 42.30, 42.29, 42.28, 42.26, 42.24, 42.21, 42.17, 42.14,
+ @ 42.10, 42.07, 42.06, 42.05, 42.04, 42.03, 42.02, 42.00,
+ @ 41.97, 41.94, 41.89, 41.84, 41.79, 41.73, 41.67, 41.61,
+ @ 41.55, 41.49, 41.44, 41.38, 41.34, 41.31, 41.29, 41.28,
+ @ 41.27, 41.28, 41.30, 41.33, 41.36, 41.40, 41.44, 41.49,
+ @ 41.50, 41.51, 41.51, 41.51, 41.52, 41.51, 41.51, 41.50,
+ @ 41.50, 41.49, 41.47, 41.46
+ @/
+
+c proton - neutron elastic cs. index=2
+ data (sigmas(2,i),i=1,ITBLSZ) /
+ @248.20, 93.38, 55.26, 44.50, 41.33, 38.48, 37.20, 35.98,
+ @ 35.02, 34.47, 32.48, 30.76, 29.46, 28.53, 27.84, 27.20,
+ @ 26.53, 25.95, 25.59, 25.46, 25.00, 24.49, 24.08, 23.86,
+ @ 23.17, 22.70, 21.88, 21.48, 20.22, 19.75, 18.97, 18.39,
+ @ 17.98, 17.63, 17.21, 16.72, 16.68, 16.58, 16.42, 16.22,
+ @ 15.98, 15.71, 15.42, 15.14, 14.87, 14.65, 14.44, 14.26,
+ @ 14.10, 13.95, 13.80, 13.64, 13.47, 13.29, 13.09, 12.89,
+ @ 12.68, 12.47, 12.27, 12.06, 11.84, 11.76, 11.69, 11.60,
+ @ 11.50, 11.41, 11.29, 11.17, 11.06, 10.93, 10.81, 10.68,
+ @ 10.56, 10.44, 10.33, 10.21, 10.12, 10.03, 9.96, 9.89,
+ @ 9.83, 9.80, 9.77, 9.75, 9.74, 9.74, 9.74, 9.76,
+ @ 9.73, 9.70, 9.68, 9.65, 9.63, 9.60, 9.57, 9.55,
+ @ 9.52, 9.49, 9.46, 9.43
+ @/
+
+
+c proton - proton (neut - neut) total cs. index=3
+c low energy forward peak is subtracted
+ data (sigmas(3,i),i=1,ITBLSZ) /
+ @ 39.48, 31.76, 26.26, 24.05, 23.94, 23.77, 23.72, 23.98,
+ @ 24.48, 24.52, 28.72, 33.21, 37.33, 39.87, 42.14, 44.15,
+ @ 46.85, 48.56, 48.65, 48.97, 48.81, 48.43, 48.36, 48.19,
+ @ 47.89, 47.53, 47.42, 47.37, 47.17, 46.65, 46.48, 45.94,
+ @ 45.63, 45.75, 45.52, 45.24, 45.13, 44.96, 44.55, 44.44,
+ @ 44.10, 43.89, 43.77, 43.32, 43.30, 43.07, 42.95, 42.74,
+ @ 42.46, 42.28, 42.11, 41.96, 41.86, 41.74, 41.64, 41.54,
+ @ 41.44, 41.37, 41.29, 41.22, 41.14, 41.09, 41.01, 40.93,
+ @ 40.83, 40.74, 40.66, 40.58, 40.51, 40.47, 40.40, 40.35,
+ @ 40.47, 40.44, 40.38, 40.35, 40.32, 40.27, 40.25, 40.23,
+ @ 40.19, 40.13, 40.11, 40.09, 40.06, 40.02, 40.00, 39.95,
+ @ 39.94, 39.90, 39.87, 39.82, 39.77, 39.72, 39.67, 39.59,
+ @ 39.54, 39.48, 39.41, 39.32
+ @/
+
+c proton - proton (neut - neut) elastic cs. index=4
+ data (sigmas(4,i),i=1,ITBLSZ) /
+ @ 39.48, 31.76, 26.26, 24.05, 23.94, 23.77, 23.72, 23.98,
+ @ 24.48, 24.52, 25.00, 25.40, 25.80, 26.00, 24.32, 23.81,
+ @ 24.37, 24.36, 23.13, 22.83, 22.50, 22.20, 21.83, 21.50,
+ @ 21.55, 21.25, 20.90, 20.55, 20.30, 20.15, 20.05, 19.90,
+ @ 19.50, 19.25, 19.00, 18.50, 18.10, 17.60, 17.20, 17.00,
+ @ 16.70, 16.50, 16.20, 15.80, 15.57, 15.20, 15.00, 14.60,
+ @ 14.20, 14.00, 13.80, 13.60, 13.40, 13.20, 13.00, 12.85,
+ @ 12.70, 12.60, 12.50, 12.40, 12.30, 12.20, 12.10, 12.00,
+ @ 11.90, 11.80, 11.75, 11.70, 11.64, 11.53, 11.41, 11.31,
+ @ 11.22, 11.13, 11.05, 10.97, 10.89, 10.82, 10.75, 10.68,
+ @ 10.61, 10.54, 10.48, 10.41, 10.35, 10.28, 10.22, 10.16,
+ @ 10.13, 10.10, 10.08, 10.05, 10.02, 9.99, 9.96, 9.93,
+ @ 9.90, 9.87, 9.84, 9.80
+ @/
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ end
+
+
+
+C####C##1#########2#########3#########4#########5#########6#########7##
+ integer function flbr(i,iir)
+ implicit none
+ integer i,iir,ir,l
+ include 'comres.f'
+ ir=iabs(iir)
+ l=0
+ if(ir.gt.minnuc.and.ir.le.maxdel)then
+ l=lbr(i,ir)
+ else if(ir.gt.minlam.and.ir.le.maxsig)then
+ l=lbs1(i,ir)
+ else if(ir.gt.mincas.and.ir.le.maxcas)then
+ l=lbs2(i,ir)
+ else if(ir.gt.minmes.and.ir.le.maxmes)then
+ l=lbm(i,ir)
+ else
+ write(6,*)'*** error(flbr) *** i,ir:',i,ir
+ stop
+ endif
+ flbr=l*2 ! angular momentum of decay into ch.i(x2)
+ return
+ end
+
+C####C##1#########2#########3#########4#########5#########6#########7##
+ real*8 function fbran(i,iir)
+ implicit none
+ integer i,iir,ir
+ real*8 b
+ include 'comres.f'
+ ir=iabs(iir)
+ b=0.d0
+ if(ir.gt.minnuc.and.ir.le.maxdel)then
+ b=branres(i,ir)
+ else if(ir.gt.minlam.and.ir.le.maxsig)then
+ b=branbs1(i,ir)
+ else if(ir.gt.mincas.and.ir.le.maxcas)then
+ b=branbs2(i,ir)
+ else if(ir.gt.minmes.and.ir.le.maxmes)then
+ b=branmes(i,ir)
+ else
+ write(6,*)'*** error(fbran) *** i,ir:',i,ir
+ stop
+ endif
+ fbran=b ! branching ratio of decay into ch.i(x2)
+ return
+ end
+
+C####C##1#########2#########3#########4#########5#########6#########7##
+ integer function strit(i)
+ implicit none
+ integer i,is,ia
+ include 'comres.f'
+ if(i.eq.0) then
+ strit=0
+ return
+ endif
+ ia=iabs(i)
+ if(ia.ge.minmes)then
+ is=strmes(ia)
+ else
+ is=strres(ia)
+ endif
+ strit=is*iabs(i)/i ! number of strange quarks in part. i
+ return
+ end
+
+C####C##1#########2#########3#########4#########5#########6#########7##
+ integer function fchg(i3,i)
+ integer i,i3,b,s,ia,strit
+ include 'comres.f'
+ if(i.eq.0) then
+ fchg=0
+ return
+ endif
+
+ s=strit(i)
+ ia=iabs(i)
+ if(ia.ge.minmes)then
+ b=0
+ else
+ b=ia/i
+ endif
+ fchg =(i3+b-s)/2 ! i3 is multiplied whith 2 & s(s)=-1!
+ return ! charge of particle i
+ end
+
+C####C##1#########2#########3#########4#########5#########6#########7##
+ real*8 function massit(i)
+ integer i,ia
+ include 'comres.f'
+ ia=iabs(i)
+ if(ia.ge.minmes)then
+ massit=massmes(ia)
+ else
+ massit=massres(ia)
+ endif
+ return ! mass of particle i
+ end
+
+C####C##1#########2#########3#########4#########5#########6#########7##
+ real*8 function mminit(i)
+ implicit none
+ integer i,ia
+ real*8 massit,widit ! functions
+ real*8 cut,pcut
+ parameter(pcut=1d-3) ! keep pcut*mass for rel.kinetic energy
+ include 'comres.f'
+ if(i.eq.0) then
+ mminit=0.d0
+ return
+ endif
+
+ ia=iabs(i)
+ cut=pcut*massit(ia)
+ if(widit(ia).le.pcut)then ! narrow particle condition
+ mminit=massit(ia)
+ else if(ia.ge.minmes)then
+ mminit=mmesmn(ia)+cut
+ else if(ia.gt.minnuc.and.ia.le.maxdel)then
+ mminit=massit(minnuc)+massit(pimeson)+cut
+ else if(ia.gt.minlam.and.ia.le.maxlam)then
+ mminit=massit(minsig)+massit(pimeson)+cut
+ else if(ia.gt.minsig.and.ia.le.maxsig)then
+ mminit=massit(minsig)+massit(pimeson)+cut
+ else if(ia.gt.mincas.and.ia.le.maxcas)then
+ mminit=massit(mincas)+massit(pimeson)+cut
+ else
+ mminit=massit(ia)
+ endif
+ return ! minimal mass of particle i
+ end
+
+C####C##1#########2#########3#########4#########5#########6#########7##
+ real*8 function widit(i)
+ implicit none
+ integer i,ia
+ include 'comres.f'
+ if(i.eq.0) then
+ widit=0.d0
+ return
+ endif
+
+ ia=iabs(i)
+ if(ia.ge.minmes)then
+ widit=widmes(ia)
+ else
+ widit=widres(ia)
+ endif
+ return ! width of particle i
+ end
+
+C####C##1#########2#########3#########4#########5#########6#########7##
+ subroutine brange(i,mm,mp)
+ implicit none
+ integer mm,mp,ia,i
+ include 'comres.f'
+ ia=abs(i)
+ mm=0
+ if(ia.ge.minmes)then
+ mp=maxbrm
+ else if(ia.gt.minnuc.and.ia.le.maxdel)then
+ mp=maxbra
+ else if(ia.gt.minlam.and.ia.le.maxsig)then
+ mp=maxbrs1
+ else if(ia.gt.mincas.and.ia.le.maxcas)then
+ mp=maxbrs2
+ else
+ mp=0
+ endif
+ return
+ end
+
+C####C##1#########2#########3#########4#########5#########6#########7##
+ subroutine b3type(i,j,bi,b1,b2,b3,b4)
+c i=itype j=number of decay channel bi=branching ratio b1-4 outgoing itypes
+ implicit none
+ integer ia,i,j,b1,b2,b3,b4
+ real*8 bi
+ include 'comres.f'
+ ia=abs(i)
+ if(ia.gt.minmes)then
+ bi=branmes(j,ia)
+ b1=bmtype(1,j)
+ b2=bmtype(2,j)
+ b3=bmtype(3,j)
+ b4=bmtype(4,j)
+ else if(ia.gt.minnuc.and.ia.le.maxdel)then
+ bi=branres(j,ia)
+ b1=brtype(1,j)
+ b2=brtype(2,j)
+ b3=brtype(3,j)
+ b4=brtype(4,j)
+ else if(ia.gt.minlam.and.ia.le.maxsig)then
+ bi=branbs1(j,ia)
+ b1=bs1type(1,j)
+ b2=bs1type(2,j)
+ b3=bs1type(3,j)
+ b4=bs1type(4,j)
+ else if(ia.gt.mincas.and.ia.le.maxcas)then
+ bi=branbs2(j,ia)
+ b1=bs2type(1,j)
+ b2=bs2type(2,j)
+ b3=bs2type(3,j)
+ b4=bs2type(4,j)
+ else
+ bi=0d0
+ endif
+ return
+ end
+
+
+C####C##1#########2#########3#########4#########5#########6#########7##
+ integer function isoit(i)
+ implicit none
+ integer i,ia
+ include 'comres.f'
+ if(i.eq.0) then
+ isoit=0
+ return
+ endif
+ ia=iabs(i)
+ if(ia.ge.minmes)then
+ isoit=isomes(ia)
+ else
+ isoit=isores(ia)
+ end if
+ return ! isospin of particle i
+ end
+
+C####C##1#########2#########3#########4#########5#########6#########7##
+ integer function jit(i)
+ implicit none
+ integer i,ia
+ include 'comres.f'
+
+ if(i.eq.0) then
+ jit=0
+ return
+ endif
+
+ ia=iabs(i)
+ if(ia.ge.minmes)then
+ jit=jmes(ia)
+ else
+ jit=jres(ia)
+ endif
+ return ! spin of particle i
+ end
diff --git a/Processes/UrQMD/boxinc.f b/Processes/UrQMD/boxinc.f
new file mode 100644
index 0000000000000000000000000000000000000000..8d2eb827cbbca769a6da1cfe005d7ed7df583ccd
--- /dev/null
+++ b/Processes/UrQMD/boxinc.f
@@ -0,0 +1,38 @@
+c $Id: boxinc.f,v 1.3 1999/01/18 09:56:53 ernst Exp $
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+c Unit : all modules using the box
+c Version : 1.0
+c
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+c max count of different species
+ integer bptmax
+ parameter(bptmax=20)
+
+c counter
+ integer cbox
+c Flags
+ integer boxflag
+ integer edensflag, mbflag
+ integer para,solid,mtest
+c number of different species
+ integer mbox
+c particle counters
+ integer bptpart(bptmax),bptityp(bptmax),bptiso3(bptmax)
+ real*8 bptpmax(bptmax)
+ real*8 edens
+c edge length of a cube in fm
+ real*8 lbox
+c half edge lengt of a cube
+ real*8 lboxhalbe
+c double edge length of a cube
+ real*8 lboxd
+c momenta
+ real*8 mbp0, mbpx, mbpy, mbpz
+
+ common /boxic/ cbox,boxflag, mbox, bptityp, bptiso3, bptpart
+ common /boxic/ edensflag, para, solid, mbflag, mtest
+ common /boxrc/ lbox, lboxhalbe, lboxd, bptpmax, edens
+ common /boxrc/ mbp0, mbpx, mbpy, mbpz
+
diff --git a/Processes/UrQMD/boxprg.f b/Processes/UrQMD/boxprg.f
new file mode 100644
index 0000000000000000000000000000000000000000..2daa11ad2a1aba109c102dbb280c242e583aa45a
--- /dev/null
+++ b/Processes/UrQMD/boxprg.f
@@ -0,0 +1,293 @@
+c $Id: boxprg.f,v 1.8 1999/01/18 09:56:53 ernst Exp $
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ subroutine bptinit(ibox)
+c
+c Unit : Initis all the particles setted by the bpt command
+c Version : 1.0
+c
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+ implicit none
+
+ include 'coms.f'
+ include 'comres.f'
+ include 'boxinc.f'
+ include 'options.f'
+
+c Var
+c counter, spin
+ integer i,ibox,fchg,getspin
+c randomnumbergenerator, particlemass, deacy times
+ real*8 ranf,massit,dectim
+c momentum, angle distribution
+ real*8 P,cost,sint,phi
+
+ ecm=0.d0
+ ebeam=0.d0
+
+c main program
+
+c loop over all particles
+ do 42 i=npart+1,npart+bptpart(ibox)
+c configuration space
+ r0(i)=0.d0
+ rx(i)=lboxhalbe*(1-2*ranf(0))
+ ry(i)=lboxhalbe*(1-2*ranf(0))
+ rz(i)=lboxhalbe*(1-2*ranf(0))
+
+c isospin and ityp
+ iso3(i)=bptiso3(ibox)
+ ityp(i)=bptityp(ibox)
+
+c set baryon and meson numbers
+ if(abs(ityp(i)).le.maxbar) then
+ nbar=nbar+1
+ else
+ nmes=nmes+1
+ endif
+
+c charge
+ charge(i)=fchg(iso3(i),ityp(i))
+c massarray
+ fmass(i)=massit(ityp(i))
+c Spin
+ spin(i)=getspin(ityp(i),-1)
+c decaytime
+ dectime(i)=dectim(i,1)
+
+ 42 continue
+c End of loop
+
+ if (edensflag.le.0) then
+c homogenious momentum distribution, randomly distributed
+c max momentum is a parameter
+ do 45 i=npart+1,npart+bptpart(ibox)
+ P=bptpmax(ibox)*ranf(0)**(1./3.)
+ cost = 1.-2.*ranf(0)
+ sint = sqrt(1.-cost**2)
+ phi = 2.*Pi*ranf(0)
+ px(i) = P*sint*cos(phi)
+ py(i) = P*sint*sin(phi)
+ pz(i) = P*cost
+ call setonshell(i)
+ 45 continue
+ elseif (edensflag.ge.1) then
+
+c energiedensity
+
+c loop over all particles
+ do 60 i=npart+1,npart+bptpart(ibox)
+ P=bptpmax(ibox)/bptpart(ibox)*ranf(0)**(1./3.)
+
+ cost = 1.-2.*ranf(0)
+ sint = sqrt(1.-cost**2)
+ phi = 2.*Pi*ranf(0)
+
+c different initialisations
+
+ if (para.eq.0) then
+
+c Boxmode
+ if (i.eq.1) write(*,*) 'Boxmode'
+ px(i) = P*sint*cos(phi)
+ py(i) = P*sint*sin(phi)
+ pz(i) = P*cost
+
+ elseif(para.eq.1) then
+
+c stream over stream
+ if (i.eq.1) write(*,*) 'streammode'
+ px(i) = 0.d0
+ py(i) = 0.d0
+ pz(i) = bptpmax(ibox)/bptpart(ibox)*(-1.d0)**i
+ elseif(para.eq.2) then
+
+c slab on slab
+ if (i.eq.1) write(*,*) 'slabmode'
+ px(i)=0.d0
+ py(i)=0.d0
+ if (rz(i).gt.0) then
+ pz(i)=(-1.0d0)*bptpmax(ibox)/bptpart(ibox)
+ else
+ pz(i)=bptpmax(ibox)/bptpart(ibox)
+ endif
+ endif
+ 60 continue
+ endif
+c sum of particles
+ npart=npart+bptpart(ibox)
+ Write(*,*) 'Particles = ',npart
+cc
+ return
+
+ end
+
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ function swapi(x,dx)
+c
+c Version: 1.0
+c
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+ real*8 swapi, x, dx
+
+ swapi = x
+ 1 if (swapi.lt.-dx) then
+ swapi = swapi + 2.0d0*dx
+ goto 1
+ end if
+ 2 if (swapi.gt.dx) then
+ swapi = swapi - 2.0d0*dx
+ goto 2
+ end if
+ end
+
+
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ Function Energie(alpha,max)
+c
+c Unit : calculate the energy
+c Version : 1.0
+c
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+ implicit none
+
+ include 'coms.f'
+ integer i
+
+ real*8 alpha,max
+ real*8 Energie, E
+
+ E=0
+ Do 42 i=1,npart
+ E=E+sqrt((alpha**2)*(px(i)*px(i)+py(i)*py(i)+pz(i)*pz(i))+
+ $ fmass(i)**2)
+ 42 continue
+
+ Energie=E-max
+
+ Return
+ End
+
+
+
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ Function Regula(me)
+c
+c Unit : Searches for the zero of the function
+c Version : 1.0
+c
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+
+ implicit none
+
+ include 'coms.f'
+
+ real*8 Regula,xn,xu,x0,me,Energie
+ integer i
+ real*8 E1,E2,E3
+
+c init
+ xu=0.d0
+ x0=3.d0
+c main
+ Write(*,*) 'Regula is running!'
+ i=0
+ 10 Continue
+ i=i+1
+ E1=Energie(x0,me)
+ E2=Energie(xu,me)
+
+ xn=x0-(E1*(x0-xu))/(E1-E2)
+ E3=Energie(xn,me)
+ IF ((E2*E3).LE.0) then
+ x0=xn
+ else
+ xu=xn
+ EndIF
+
+ IF ((ABS(x0-xu).GE.1.D-12).and.(i.le.1000).and.(
+ & ((E3.ge.1.D-12).or.(-E3.ge.1.D-12)))) goto 10
+ Regula=xn
+ End
+
+
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ real*8 function wallcoll(ipart,wall)
+c
+c Unit : Collisions with an imaginary wall
+c Version : 1.0
+c
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+ implicit none
+
+ include 'coms.f'
+ include 'boxinc.f'
+ include 'options.f'
+
+c var
+ real*8 betax,betay,betaz
+ real*8 ty,tz
+ real*8 tn
+ integer wall,ipart
+ integer wally,wallz
+
+
+c Mainprogram
+c init the variables
+ wall=0
+ tn=0
+
+c velocity
+ betax=px(ipart)/p0(ipart)
+ betay=py(ipart)/p0(ipart)
+ betaz=pz(ipart)/p0(ipart)
+
+c check which wall is reached next and sort by impact time
+c wall presents the wall and tn the time
+
+ if (betax.lt.0) then
+ wall=-4
+ tn=(-lboxhalbe-rx(ipart))/(-max(-betax,1.d-13))
+ else
+ wall=-1
+ tn=((lboxhalbe-rx(ipart))/max(betax,1.d-13))
+ endif
+
+ if (betay.lt.0) then
+ wally=-5
+ ty=(-lboxhalbe-ry(ipart))/(-max(-betay,1.d-13))
+ else
+ wally=-2
+ ty=((lboxhalbe-ry(ipart))/max(betay,1.d-13))
+ endif
+
+ if(ty.lt.tn) then
+ tn=ty
+ wall=wally
+ endif
+
+ if (betaz.lt.0) then
+ wallz=-6
+ tz=(-lboxhalbe-rz(ipart))/(-max(-betaz,1.d-13))
+ else
+ wallz=-3
+ tz=((lboxhalbe-rz(ipart))/max(betaz,1.d-13))
+ endif
+
+ if(tz.lt.tn) then
+ tn=tz
+ wall=wallz
+ endif
+
+
+c sets the time for the earliest wall collision
+ wallcoll=tn
+
+ return
+ End
+
+
diff --git a/Processes/UrQMD/cascinit.f b/Processes/UrQMD/cascinit.f
new file mode 100644
index 0000000000000000000000000000000000000000..121924e9ae895f7dcce781c3f7a5df0b9ff0e989
--- /dev/null
+++ b/Processes/UrQMD/cascinit.f
@@ -0,0 +1,511 @@
+c $Id: cascinit.f,v 1.11 2002/05/14 12:33:50 balazs Exp $
+ subroutine cascinit(ZZ,AA,nucleus)
+
+ implicit none
+
+ include 'coms.f'
+ include 'options.f'
+ include 'inputs.f'
+
+ integer Z,A,i,getspin,fchg,ZZ,AA,antia, j,k, nrjc,izcnt,nucleus
+ real*8 R,P,R2,ranf,sint,phi,nucrad,cost,drr
+ real*8 xcm,ycm,zcm,pxcm,pycm,pzcm,densnorm,add,avd,ws
+ real*8 r_long, r_short, rdef, ratio, alpha
+c
+c mass correction according to binding energy
+ real*8 meff
+ce bcorr to prevent recycling odd nuclei
+ logical bcorr
+ common /ini/ bcorr
+ bcorr=.false.
+
+C averaged density of one Gaussian in units of central value
+ avd = 0.5**1.5
+
+ pxcm=0.d0
+ pycm=0.d0
+ pzcm=0.d0
+
+ A=abs(AA)
+ Z=abs(ZZ)
+ antia=A/AA
+
+ PT_AA(nucleus)=A
+
+ if(A.gt.AAmax) then
+ write(6,*)'***(E): Mass ',A,' exceeds initialization limit!'
+ write(6,*)' -> increase parameter AAmax=',AAmax
+ write(6,*)' in include-file inputs.f '
+ write(6,*)' -> uqmd aborting ... '
+ stop
+ endif
+
+ if (A.eq.1) then ! proton or neutron
+ i = 1
+ PT_iso3(i,nucleus) = antia*(-1+2*Z)
+ PT_ityp(i,nucleus) = antia*1
+ uid_cnt=uid_cnt+1
+ PT_uid(i,nucleus)=uid_cnt
+ PT_spin(i,nucleus) = 1
+ PT_dectime(i,nucleus)=1.d31
+ PT_charge(i,nucleus)=fchg(PT_iso3(i,nucleus),
+ & PT_ityp(i,nucleus))
+ PT_fmass(i,nucleus) = EMNUC
+ PT_p0(i,nucleus)=sqrt(PT_fmass(i,nucleus)**2)
+ return
+ end if
+
+C
+C Initialisation of A nucleons in configuration space
+C
+ xcm=0.d0
+ ycm=0.d0
+ zcm=0.d0
+ R2=0.d0
+ if (CTOption(24).eq.1) then
+ R2 = nucrad(A) + 10.0
+ elseif(CTOption(24).eq.0)then
+ R2 = nucrad(A)
+ endif
+ nrjc = 0
+ if(CTOption(24).eq.2)then ! use fast method
+ call nucfast(A,nucleus)
+ do j=1,A
+ PT_dectime(j,nucleus)=1.d31
+ xcm=xcm+PT_rx(j,nucleus)
+ ycm=ycm+PT_ry(j,nucleus)
+ zcm=zcm+PT_rz(j,nucleus)
+ enddo
+ else
+ do 1 j=1,A
+ PT_dectime(j,nucleus)=1.d31
+111 nrjc = nrjc+1
+ R = R2*ranf(0)**(1./3.)
+ cost = 1.-2.*ranf(0)
+ sint = sqrt(1.-cost**2)
+ phi = 2.*Pi*ranf(0)
+ PT_r0(j,nucleus) = 0.d0
+ PT_rx(j,nucleus) = R*sint*cos(phi)
+ PT_ry(j,nucleus) = R*sint*sin(phi)
+ PT_rz(j,nucleus) = R*cost
+ if (CTParam(21).gt.0.0) then
+ ratio = sqrt((1 + 4.0*CTParam(21)/3.0) /
+ $ (1 - 2.0*CTParam(21)/3.0) )
+ alpha = atan( sqrt(PT_rx(j,nucleus)*PT_rx(j,nucleus)
+ $ + PT_ry(j,nucleus)*PT_ry(j,nucleus))/PT_rz(j,nucleus))
+ r_short = nucrad(A)*(ratio**(-(1.0/3.0)))
+ r_long = nucrad(A)*(ratio**(2.0/3.0))
+ rdef = r_short/sqrt(1-((r_long**2-r_short**2)/r_long**2)
+ $ *cos(alpha)*cos(alpha))
+ else
+ rdef = nucrad(A)
+ endif
+
+
+ if (CTOption(24).eq.1) then
+ WS = 1 / ( 1 + dexp( ( R - rdef ) / 0.545 ) )
+cdh if (ranf(0) > WS ) then
+ if (ranf(0) .gt. WS ) then
+c write (6,*) "rejected: ",R
+ goto 111
+ endif
+ else
+ do 11 k=1,j-1
+ drr=(PT_rx(j,nucleus)-PT_rx(k,nucleus))**2
+ & +(PT_ry(j,nucleus)-PT_ry(k,nucleus))**2
+ & +(PT_rz(j,nucleus)-PT_rz(k,nucleus))**2
+ if (drr.lt.2.6.and.nrjc.lt.CTParam(46)) goto 111
+ 11 continue
+ endif
+ xcm=xcm+PT_rx(j,nucleus)
+ ycm=ycm+PT_ry(j,nucleus)
+ zcm=zcm+PT_rz(j,nucleus)
+1 continue
+ endif
+
+ if (nrjc.ge.CTParam(46)) then
+c write(6,*)'*** warning: initialisation corrupt '
+ bcorr=.true.
+ end if
+
+ xcm = xcm/dble(A)
+ ycm = ycm/dble(A)
+ zcm = zcm/dble(A)
+ do 13 j=1,A
+ if (CTOption(24).eq.0) then
+ PT_rx(j,nucleus) = PT_rx(j,nucleus)-xcm
+ PT_ry(j,nucleus) = PT_ry(j,nucleus)-ycm
+ PT_rz(j,nucleus) = PT_rz(j,nucleus)-zcm
+ endif
+ PT_rho(j,nucleus) = avd
+13 continue
+
+C local proton density in nucleus A,Z
+ do 14 j=1,Z
+ do 15 k=j+1,Z
+ drr=(PT_rx(j,nucleus)-PT_rx(k,nucleus))**2
+ & +(PT_ry(j,nucleus)-PT_ry(k,nucleus))**2
+ & +(PT_rz(j,nucleus)-PT_rz(k,nucleus))**2
+ add=exp(-(2.0*gw*drr))
+ PT_rho(j,nucleus) = PT_rho(j,nucleus)+add
+ PT_rho(k,nucleus) = PT_rho(k,nucleus)+add
+15 continue
+14 continue
+
+C local neutron density in nucleus A,Z
+ do 16 j=Z+1,A
+ do 17 k=j+1,A
+ drr=(PT_rx(j,nucleus)-PT_rx(k,nucleus))**2
+ & +(PT_ry(j,nucleus)-PT_ry(k,nucleus))**2
+ & +(PT_rz(j,nucleus)-PT_rz(k,nucleus))**2
+ add=exp(-(2.0*gw*drr))
+ PT_rho(j,nucleus) = PT_rho(j,nucleus)+add
+ PT_rho(k,nucleus) = PT_rho(k,nucleus)+add
+17 continue
+16 continue
+
+ densnorm = (2.0*gw/pi)**1.5
+ do 18 j=1,A
+ PT_rho(j,nucleus) = PT_rho(j,nucleus)*densnorm
+ PT_pmax(j,nucleus) = hqc*(3.0*pi*pi*PT_rho(j,nucleus))**(1./3.)
+18 continue
+
+ izcnt=0
+ do 12 j=1,A
+ P = PT_pmax(j,nucleus)*ranf(0)**(1./3.)
+ cost = 1.-2.*ranf(0)
+ sint = sqrt(1.-cost**2)
+ phi = 2.*Pi*ranf(0)
+ PT_px(j,nucleus) = P*sint*cos(phi)
+ PT_py(j,nucleus) = P*sint*sin(phi)
+ PT_pz(j,nucleus) = P*cost
+ pxcm=pxcm+PT_px(j,nucleus)
+ pycm=pycm+PT_py(j,nucleus)
+ pzcm=pzcm+PT_pz(j,nucleus)
+ if (j.le.Z) then
+ PT_iso3(j,nucleus)= 1*antia
+ PT_charge(j,nucleus)=1*antia
+ else
+ PT_iso3(j,nucleus)= -(1*antia)
+ PT_charge(j,nucleus)=0
+ endif
+
+ PT_spin(j,nucleus) = getspin(1,-1)
+ PT_ityp(j,nucleus) = 1*antia
+ uid_cnt=uid_cnt+1
+ PT_uid(j,nucleus)=uid_cnt
+
+12 continue
+
+c perform CM-correction
+ pxcm=pxcm/A
+ pycm=pycm/A
+ pzcm=pzcm/A
+ do 2 i=1,A
+ PT_px(i,nucleus)=PT_px(i,nucleus)-pxcm
+ PT_py(i,nucleus)=PT_py(i,nucleus)-pycm
+ PT_pz(i,nucleus)=PT_pz(i,nucleus)-pzcm
+c effective masses for initial energy corr. (CTOption(11).eq.0)
+ r=sqrt(PT_rx(i,nucleus)**2+PT_ry(i,nucleus)**2
+ & +PT_rz(i,nucleus)**2)
+ p=sqrt(PT_px(i,nucleus)**2+PT_py(i,nucleus)**2
+ & +PT_pz(i,nucleus)**2)
+ctp060202 PT_fmass(i,nucleus) = meff(z,a,r,p)
+ PT_fmass(i,nucleus) = meff(z,a,p)
+ PT_p0(i,nucleus)=sqrt(PT_px(i,nucleus)**2+PT_py(i,nucleus)**2
+ & +PT_pz(i,nucleus)**2+PT_fmass(i,nucleus)**2)
+ 2 continue
+c end of CM-correction
+
+ return
+ end
+
+ subroutine nucfast(IA,JJ)
+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+
+ include 'inputs.f'
+ real*8 nucrad
+
+ am=0.545
+ rad=nucrad(ia)/am
+ cr1=1.+3./rad+6./rad**2+6./rad**3
+ cr2=3./rad
+ cr3=3./rad+6./rad**2
+ rimmax=0.0
+
+ DO I=1,IA
+ 1 zuk=ranf(0)*cr1-1.
+ if(zuk.le.0.)then
+ tt=rad*(ranf(0)**.3333-1.)
+ elseif(zuk.le.cr2 )then
+ tt=-log(ranf(0))
+ elseif(zuk.lt.cr3 )then
+ tt=-log(ranf(0))-log(ranf(0))
+ else
+ tt=-log(ranf(0))-log(ranf(0))-log(ranf(0))
+ endif
+ if(ranf(0).gt.1./(1.+exp(-abs(tt))))goto 1
+ rim=tt+rad
+ z=rim*(2D0*ranf(0)-1D0)
+ rim=dsqrt(rim*rim-z*z)
+cc if(rimmax.lt.rim*AM)rimmax=rim*AM
+ PT_r0(I,JJ)=0d0
+ PT_rz(I,JJ)=Z * AM
+
+ 2 s1=2d0*ranf(0)-1d0
+ s2=2d0*ranf(0)-1d0
+ s3=s1*s1+s2*s2
+ if(s3.gt.1d0)goto 2
+ s3=dsqrt(s3)
+ c=s1/s3
+ s=s2/s3
+ PT_rx(I,JJ)=rim * C * AM
+ PT_ry(I,JJ)=rim * S * AM
+ enddo
+cc print *,"rimmax",rimmax
+cc if(debug.ge.3)then
+cc write (*,*) "nucleons"
+cc do i=1,ia
+cc write (*,'(i3,3g12.6)')i,PT_rx(i,JJ),PT_ry(i,JJ),PT_rz(i,JJ)
+cc enddo
+cc write (*,*)
+cc endif
+ return
+ END
+
+
+ function nucrad(AA)
+ implicit none
+ real*8 nucrad, r_0
+ integer A,AA
+ include 'coms.f'
+ include 'options.f'
+
+ A=abs(AA)
+c root mean square radius of nucleus of mass A
+c r_0 corresponding to rho0
+ if (CTOption(24).ge.1) then
+c root mean square radius of nucleus of mass A (Mayer-Kuckuck)
+ nucrad = 1.128 * a**(1./3.) - 0.89 * a**(-(1./3.))
+ else
+ r_0 = (0.75/pi/rho0)**(1./3.)
+c subtract gaussian tails, for distributing centroids correctly
+ nucrad = r_0*(0.5*(a + (a**(1./3.)-1.)**3.))**(1./3.)
+ endif
+
+ return
+ end
+
+ subroutine boostnuc(i1,i2,pin,b,dst)
+ implicit none
+ include 'coms.f'
+ include 'options.f'
+ integer i1,i2,i
+ real*8 b,dst,ei,ti
+ real*8 pin,beta,gamma
+
+ do 1 i=i1,i2
+
+ beta = pin/sqrt(pin**2+fmass(i)**2)
+ gamma = 1.d0/sqrt(1.d0-beta**2)
+
+c Gallilei-Trafo in x-direction (impact parameter)
+c projectile hits at POSITIVE x
+ rx(i) = rx(i) + b
+c distance between nuclei: projectile at NEGATIVE z for dst < 0
+ if(CTOption(23).eq.0)then
+ ti = r0(i)
+ rz(i) = rz(i)/gamma+dst/gamma
+ else
+ rz(i) = (rz(i) + dst)
+ end if
+
+
+ Ei = p0(i)
+ p0(i) = gamma*(p0(i) - beta*pz(i))
+ pz(i) = gamma*(pz(i) - beta*Ei)
+
+ 1 continue
+ return
+ end
+
+ctp060202 real*8 function meff(z,a,r,p)
+ real*8 function meff(z,a,p)
+c mean binding energy of a nucleon in a nucleus according to weizaecker
+ implicit none
+ include 'options.f'
+ real*8 av,as,ac,aa,ap,mdef,p,e,EMNUC
+ integer z,a
+ parameter (av=0.01587,as=0.01834,ac=0.00071)
+ parameter (aa=0.09286,ap=11.46,EMNUC=0.938)
+ if(CTOption(11).ne.0.or.a.eq.1)then
+ meff=EMNUC
+ return
+ end if
+c...mass defect
+ mdef=-(av*A)+as*A**0.66667+ac*z*z/a**0.33333+aa*(z-a/2.)**2/a
+c...energy per nucleon = binding energy + nucleon mass
+ e=min(0d0,mdef/a)+EMNUC
+ meff=sqrt(e**2-p**2)
+ return
+ end
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ subroutine getnucleus(nucleus,offset)
+c
+c Revision: 1.0
+c
+cinput nucleus : 1=projectile, 2=target
+cinput offset : offset for location of nucleus in particle vectors
+c
+c output : via common blocks
+c
+c This subroutine read in a nucleus which has been initialized
+c by {\tt cascinit} and stored in the {\tt PT\_ *(i,nucleus)} arrays.
+c The respective nucleus is then rotated randomly in configuration
+c and momentum space to yield a new initial state.
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ implicit none
+ include 'coms.f'
+ include 'options.f'
+ include 'inputs.f'
+
+c local variables
+ real*8 eul1,eul2,eul3,ceul1,seul1,ceul2,seul2,ceul3,seul3
+ real*8 vecx0,vecy0,vecz0,vecx1,vecy1,vecz1,vecx2
+ real*8 vecy2,vecz2
+ integer k,nucleus,offset
+
+c functions
+ real*8 ranf
+
+c ***
+c *** rotation around Euler-angles
+c ***
+ if (CTParam(21).gt.0.0) then
+ eul1 = 0.0
+ eul2 = 0.0
+ eul3 = 0.0
+ else
+ eul1 = ranf(0)*2.0*pi
+ eul2 = ranf(0)*2.0*pi
+ eul3 = ranf(0)*2.0*pi
+ endif
+
+ ceul1 = cos(eul1)
+ seul1 = sin(eul1)
+ ceul2 = cos(eul2)
+ seul2 = sin(eul2)
+ ceul3 = cos(eul3)
+ seul3 = sin(eul3)
+
+ do 178 k=1,PT_AA(nucleus)
+
+c rotate in configuration space
+
+ vecx0 = PT_rx(k,nucleus)
+ vecy0 = PT_ry(k,nucleus)
+ vecz0 = PT_rz(k,nucleus)
+
+
+ vecx1 = ceul1*vecx0 + seul1*vecy0
+ vecy1 = -(seul1*vecx0)+ ceul1*vecy0
+ vecz1 = vecz0
+
+ vecx2 = ceul2*vecx1 + seul2*vecz1
+ vecy2 = vecy1
+ vecz2 = -(seul2*vecx1) + ceul2*vecz1
+
+ vecx0 = ceul3*vecx2 + seul3*vecy2
+ vecy0 = -(seul3*vecx2)+ ceul3*vecy2
+ vecz0 = vecz2
+
+ rx(k+offset) = vecx0
+ ry(k+offset) = vecy0
+ rz(k+offset) = vecz0
+
+c rotate in momentum space
+
+ vecx0 = PT_px(k,nucleus)
+ vecy0 = PT_py(k,nucleus)
+ vecz0 = PT_pz(k,nucleus)
+
+
+ vecx1 = ceul1*vecx0 + seul1*vecy0
+ vecy1 = -(seul1*vecx0)+ ceul1*vecy0
+ vecz1 = vecz0
+
+ vecx2 = ceul2*vecx1 + seul2*vecz1
+ vecy2 = vecy1
+ vecz2 = -(seul2*vecx1) + ceul2*vecz1
+
+ vecx0 = ceul3*vecx2 + seul3*vecy2
+ vecy0 = -(seul3*vecx2) + ceul3*vecy2
+ vecz0 = vecz2
+
+ px(k+offset) = vecx0
+ py(k+offset) = vecy0
+ pz(k+offset) = vecz0
+
+c initialize the other quantum numbers
+
+ iso3(k+offset)=PT_iso3(k,nucleus)
+ ityp(k+offset)=PT_ityp(k,nucleus)
+ uid(k+offset)=PT_uid(k,nucleus)
+ spin(k+offset)=PT_spin(k,nucleus)
+ dectime(k+offset)=PT_dectime(k,nucleus)
+ charge(k+offset)=PT_charge(k,nucleus)
+ fmass(k+offset)=PT_fmass(k,nucleus)
+ r0(k+offset)=PT_r0(k,nucleus)
+ p0(k+offset)=PT_p0(k,nucleus)
+
+ 178 continue
+
+ return
+ end
+
+C####C##1#########2#########3#########4#########5#########6#########7##
+ real*8 function rnfWSX(AA,zmin,zmax)
+c yields a $x^n$ distributet value for $x$ between mmin and mmax
+cccccCcc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc
+
+ implicit none
+
+ real*8 zmin,zmax,ranf,a,rr,yf,z,nucrad
+ integer AA
+ parameter (a=0.54d0)
+
+ rr=nucrad(aa)
+
+ if(zmax.lt.rr)then
+ write(6,*)'rnfwsx: maximum radius seems too low'
+ stop
+ end if
+
+ 108 continue
+ z=zmin+ranf(0)*(zmax-zmin)
+ yf=z*z/((zmax-zmin)**3)*0.5d0/(1d0+exp(z-rr)/a)
+ rnfWSX=z
+ if(yf.gt.1d0)stop'rnfWSX: wrong normalisaton:'
+ if(yf.gt.ranf(0)) return
+ goto 108
+
+ end
+
+
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+ subroutine setonshell(i)
+c
+c Revision : 1.0
+c This subroutine set particle i on-shell
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+ include 'coms.f'
+ integer i
+
+ p0(i) = sqrt(px(i)**2+py(i)**2+pz(i)**2+fmass(i)**2)
+
+ return
+ end
+
diff --git a/Processes/UrQMD/colltab.f b/Processes/UrQMD/colltab.f
new file mode 100644
index 0000000000000000000000000000000000000000..a16ee8129c5810a9702898baa0044300da61a434
--- /dev/null
+++ b/Processes/UrQMD/colltab.f
@@ -0,0 +1,29 @@
+c $Id: colltab.f,v 1.5 1999/11/24 19:47:48 ssoff Exp $
+c
+cdes This file contains the uqmd collision tables
+c
+ integer ncollmax
+ parameter (ncollmax = 100) ! maximum number of entries in collision table
+ integer nct,actcol,nsav,apt
+ real*8 cttime(0:ncollmax),ctsqrts(ncollmax),ctsigtot(ncollmax)
+ real*8 ctcolfluc(ncollmax)
+ logical ctvalid(ncollmax)
+ real*8 tmin
+ integer cti1(ncollmax),cti2(ncollmax),ctsav(ncollmax)
+c integer updi1(ncollmax),updi2(ncollmax)
+c
+c cttime : collision time
+c ctsqrts : $sqrt{s}$ of collision
+c ctsigtot: total cross section in mbarn
+c tmin : paramteter for {\tt collupd}
+c cti1 : index of particle 1
+c cti2 : index of particle 2
+c nct : number of collisions in the table
+c actcol : current collision
+c ctvalid : tag whether collision is {\em true} or {\em false}
+c ctsav : list of particles which lost their collision partner
+c nsav : number of entries in {\tt ctsav}
+c apt : mass of first particle/composite in the part. arrays
+
+ common /colltab/cttime,ctsqrts,ctsigtot,tmin,cti1,cti2,nct,actcol,
+ & ctvalid,ctsav,nsav,apt,ctcolfluc
diff --git a/Processes/UrQMD/coload.f b/Processes/UrQMD/coload.f
new file mode 100644
index 0000000000000000000000000000000000000000..efe92e6469bcd564369412fa0ee8b95e76f5ebce
--- /dev/null
+++ b/Processes/UrQMD/coload.f
@@ -0,0 +1,911 @@
+c $Id: coload.f,v 1.11 2001/04/06 21:48:16 weber Exp $
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ real*8 function sigtot(ind1,ind2,sqrts)
+c
+c Revision : 1.0
+C
+cinput ind1 : index of particle 1
+cinput ind2 : index of particle 2
+cinput sqrts: $\sqrt{s}$ of collision between part. 1 and 2
+c
+c {\tt sigtot} returns the total cross section (in mbarn) for the collision
+c between the particles with the indices {\tt ind1} and {\tt ind2}.
+c
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+ implicit none
+ include 'coms.f'
+ include 'comres.f'
+ include 'newpart.f'
+c
+ integer isigline
+ integer ind1,ind2,collclass
+ integer ityp1,ityp2,iso31,iso32
+ real*8 sqrts,mminit
+c for detailed-balance
+ integer nCh,ii
+ real*8 e1,e2,sigma
+
+
+c reset sigtot, store often needed values in scalars
+ sigtot=0.d0
+ ityp1=ityp(ind1)
+ ityp2=ityp(ind2)
+ iso31=iso3(ind1)
+ iso32=iso3(ind2)
+
+c now get collision class (line-number for sigmaLN array in blockres.f)
+c isigline classifies the collision (pp,pn,Delta N, Meson-Baryon etc)
+ isigline=collclass(ityp1,iso31,ityp2,iso32)
+
+ if(isigline.eq.0) return ! zero cross section for collclass=0
+
+c get pointer for total cross section (column #2 in SigmaLN array)
+ iline=SigmaLn(2,1,isigline) ! flag of total cross section
+
+c if zero, cross section is zero, return
+ if(iline.eq.0) return
+
+ if(iline.gt.0) then
+c
+c if gt zero we have a tabulated or parameterized total cross section,
+c all table-lookups and parametrizations are accessed via crossx
+c
+ call crossx(iline,sqrts,ityp1,iso31,
+ & max(fmass(ind1),mminit(ityp1)),
+ & ityp2,iso32,
+ & max(fmass(ind2),mminit(ityp2)),
+ & sigtot)
+
+ else
+c
+c total cross section via sum of partial cross sections
+c
+c get number of exit-channels:
+ if (isigline.gt.maxreac) then
+ write (6,*) '4isigline: ',isigline
+ endif
+ nCh=SigmaLn(1,1,isigline)
+c
+c transformation quantities into NN system for proper kinematics
+c (necessary for detailed balance cross sections)
+c first compute transformation betas
+ e1=sqrt(fmass(ind1)**2+px(ind1)**2
+ & +py(ind1)**2+pz(ind1)**2)
+ e2=sqrt(fmass(ind2)**2+px(ind2)**2
+ & +py(ind2)**2+pz(ind2)**2)
+ betax=(px(ind1)+px(ind2))/(e1+e2)
+ betay=(py(ind1)+py(ind2))/(e1+e2)
+ betaz=(pz(ind1)+pz(ind2))/(e1+e2)
+c now transform momenta
+ pxnn=px(ind1)
+ pynn=py(ind1)
+ pznn=pz(ind1)
+ p0nn=e1
+c call to Lorentz transformation
+ call rotbos(0d0,0d0,-betax,-betay,-betaz,
+ & pxnn,pynn,pznn,p0nn)
+ pnn=sqrt(pxnn*pxnn+pynn*pynn+pznn*pznn)
+c end of transform part
+c
+c loop over exit channels for sum of partial cross sections
+c partial cross sections start in column #3 of SigmaLN in blockres.f
+ do 10 ii=3,nCh+2
+c get pointer for partial cross section
+ iline=SigmaLn(ii,1,isigline)
+c normal partial cross sections
+ if(iline.gt.0) then
+ call crossx(iline,sqrts,ityp1,iso31,fmass(ind1),
+ & ityp2,iso32,fmass(ind2),sigma)
+ else
+c detailed balance partial cross section (must be computed now)
+c (crossz delivers inelastic channel for SINGLE resonance)
+ call crossz(iline,sqrts,ityp1,iso31,fmass(ind1),
+ & ityp2,iso32,fmass(ind2),sigma)
+ endif
+c perform summation of partial cross sections
+ sigtot=sigtot+sigma
+c end of loop for partial cross sections
+ 10 continue
+c end of total / sum of partial cross sections if
+ endif
+
+c return to caller
+ return
+
+ end
+
+
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ subroutine getnext(k)
+c
+c Revision : 1.0
+C
+coutput k : index of next collison
+c
+c {\tt getnext} returns the index of the next collision or decay
+c to be performed.
+c If no further collisons occur in the timestep, {\tt getnext} returns
+c {\tt k}=0 .
+c
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+ implicit none
+ integer k
+ include 'coms.f'
+ include 'options.f'
+ include 'colltab.f'
+
+c shrink collision tables in case 80% load to counter possible overflow
+ if(dble(nct)/ncollmax.ge.0.8) call collshrink
+
+c
+c set k to current collision/decay (which has already been performed and
+c and is outdated by the time of this call)
+ k = actcol
+
+ 1 continue
+c increment counter, next entry in table is now the current one
+ k = k+1
+c if the end of the collision table has been reached, return with k=0
+ if (k.gt.nct) then
+ k = 0
+ actcol = k
+ return
+ endif
+
+c if the current entry in the collision table is marked "F" - false -
+c (due to previous interaction of one of the collision partners)
+c then find new collision partners for the particle(s) via calls
+c to collupd
+ if (.not.ctvalid(k)) then
+ call collupd(cti1(k),1)
+c second call only if not a decay entry
+ if(cti2(k).gt.0) call collupd(cti2(k),1)
+c if the current collision is now marked "T" - true - return
+ if(ctvalid(k)) then
+ actcol = k
+ return
+ endif
+c the current collision is still marked false, go to top of loop
+c (and increment counter)
+ goto 1
+ endif
+c
+c the current entry is marked "T" - true - this is the next
+c collision to be perfomed
+ actcol = k
+ return
+ end
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ subroutine collshrink
+c
+c Revision : 1.0
+c
+c This subroutine deletes all entries in the collision tables between
+c 1 and {\tt actcol}-1. It's purpose is to counter a possible overflow
+c of the collision tables.
+c
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ implicit none
+ integer i
+ include 'colltab.f'
+
+ do 104 i=actcol,nct
+ cttime(1+i-actcol) = cttime(i)
+ ctsqrts(1+i-actcol) = ctsqrts(i)
+ ctsigtot(1+i-actcol) = ctsigtot(i)
+ cti1(1+i-actcol) = cti1(i)
+ cti2(1+i-actcol) = cti2(i)
+ ctvalid(1+i-actcol) = ctvalid(i)
+ ctcolfluc(1+i-actcol) = ctcolfluc(i)
+ 104 continue
+c recalculate number of collisions in tables
+ nct=1+nct-actcol
+c reset pointer to current collision
+ actcol=1
+
+ return
+ end
+
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ subroutine colload
+c
+c Revision : 1.0
+c
+c
+c This routine fills the collision tables with all collisions and decays
+c to be performed in the current timestep. Within the timestep,
+c particle propagation is assumed on straight lines. This routine
+c actually only performs the outer of the double particle loop and
+c calls {\tt collupd} for the inner loop.
+c
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+ implicit none
+ integer i
+
+ include 'coms.f'
+ include 'colltab.f'
+
+c reset number of collisions in table and current collision pointer
+ nct = 0
+ actcol = 0
+
+c reset all collision arrays
+ do 10 i=1,ncollmax
+ cttime(i)=0.d0
+ ctsqrts(i)=0.d0
+ ctsigtot(i)=0.d0
+ cti1(i)=0
+ cti2(i)=0
+ ctvalid(i)=.false.
+ ctcolfluc(i)=1.d0
+ 10 continue
+
+c outer loop over all particles
+ do 20 i=1,npart
+c call collupd for inner loop, -1: inner loop only from i+1 to npart
+ call collupd(i,-1)
+ 20 continue
+ return
+ end
+
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ subroutine collupd(i,all)
+c
+c Revision : 1.0
+C
+cinput i : particle to be checked for collison or decay
+cinput all : flag for update mode
+c
+c {\tt collupd} checks whether particle {\tt i} will collide or decay
+c in the time interval between the current time {\tt acttime}
+c and the end of the time step.
+c {\tt collupd} uses the variable {\tt tmin} to find the {\bf earliest}
+c interaction/decay of particle {\tt i} and store it in the
+c collision arrays via a call to {\tt ctupdate}.
+c For {\tt all}$>0$ all other particles from 1 to {\tt npart} are checked
+c (necessary for update after a collision/decay), whereas for
+c {\tt all}$<0$ only the particles with the indices from {\tt i+1} to
+c {\tt npart} are checked (for calls via {\tt colload}).
+c
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+ implicit none
+
+ include 'coms.f'
+ include 'options.f'
+ include 'colltab.f'
+ include 'boxinc.f'
+
+ real*8 dst2
+ integer i,all
+ integer j,imin,jmin,j0,A
+ integer wall
+ integer stidx
+ logical isstable
+ real*8 tn, wallcoll
+cc
+ real*8 tcoll,sqrs,sigt,sqrts,sigtot
+ real*8 smin,sigmin,sigfac
+
+ real*8 colfaci,colfacj,colfac,colfacmin
+
+c number of "initial" particles in event
+ A = At+Ap
+c initially tmin is set to the time-interval until the end of the timestep
+c tmin is then minimized to the time of the first interaction of
+c particle i
+c
+c acttime: current time
+c time: time at beginning of timestep
+c dtimestep: length of timestep
+ tmin=dtimestep-acttime+time
+c
+c other information to be stored together with tmin
+ smin = 0 ! sqrt(s) of interaction
+ sigmin = 0 ! total cross section of interaction
+ imin = 0 ! index of first particle
+ jmin = 0 ! index of second particle
+c
+c check, if particle i is a resonance, that might decay within the remaining
+c part of the timestep.
+c If so, than treat decay as collision (with particle 2= 0)
+ if (dectime(i)-acttime.lt.tmin) then
+ isstable = .false.
+ do 132 stidx=1,nstable
+ if (ityp(i).eq.stabvec(stidx)) then
+c write (6,*) 'no decay of particle ',ityp(i)
+ isstable = .true.
+ endif
+ 132 enddo
+ if (.not.isstable) then
+ tmin = dectime(i) - acttime
+ smin=fmass(i)
+ imin = i
+ jmin = 0
+ endif
+ endif
+
+
+ccccccccccccccccccccccccccccccccc
+c new walls selected if mbflag equals 2
+ if ((mbox.gt.0).and.(mbflag.eq.2)) then
+
+c acttime is the ACTUAL time
+c time is the time at the BEGINNING of the timestep
+c tmin is being minimized RELATIVE to the beginning of the timestep
+
+c tn is the relativ time to the next wall colision
+ tn=wallcoll(i,wall)
+
+c comparison wheather a particle decays before a wall colision
+ if (tn.lt.tmin) then
+c set the time
+ tmin=tn
+c set the particle number
+ imin=i
+c set the wall
+ jmin=wall
+ endif
+ endif
+cc
+
+
+c default setting: loop does only go from i+1 to npart
+ j0 = i+1
+c in case of "update mode" let loop run starting from 1
+ if (all.gt.0) j0 = 1
+c
+c Now check, which is the earliest collision of particle i
+c
+ do 101 j=j0,npart
+
+c check for some exclusion cases
+ if (
+c 1. avoid "self-interaction"
+ & i.ne.j
+c 2. particles which have interacted with each other in the past
+c are only allowed to interact with each other if at least one
+c of them has had an interaction in between.
+c (due to string-decays the structure is a little complicated, since
+c one particle can have multiple partners of it's last interaction)
+ & .AND.
+ & ((lstcoll(i).ne.j.and.lstcoll(i).ne.(nmax+strid(j)+1))
+ & .or.
+ & (lstcoll(j).ne.i.and.lstcoll(j).ne.(nmax+strid(i)+1))
+ & .or.
+ & (lstcoll(i).eq.0.and.lstcoll(j).eq.0))
+c 3. Particles within the projectile or target respectively are per
+c default only allowed to interact with each other in case they
+c have already had an interaction with a particle of the target
+c or projectile respectively. This can be turned off by setting
+c CTOption(6) to a nonzero value.
+c This rule of course must not not apply to produced particles.
+c In the case of a meson nucleus collision, projectile and
+c target may be swapped in the particle vectors (therefore the
+c use of Apt instead of Ap, because Apt has been then swapped
+c accordingly)
+ & .AND.
+ & (CToption(6).ne.0.or.i.gt.A.or.j.gt.A.or.
+ & ncoll(i)+ncoll(j).gt.0.or.
+ & (i.le.Apt.and.j.gt.Apt).or.(j.le.Apt.and.i.gt.Apt))
+ & ) then
+
+c
+c determine time of minimal approach of particles i and j
+c relative to current time
+ call nxtcoll(i,j,dst2,tcoll)
+c
+c are the particles close enough - check cut off
+c (default: 250 mbarn, defined in coms.f)
+ if (dst2.lt.hit_sphere) then
+c does the collision occur in the current time step?
+ if (tcoll.gt.0.d0.and.tcoll.lt.tmin) then
+c get sqrt(s) and total cross section
+ sqrs = sqrts(i,j)
+c
+c reduced cross section for leading hadrons of string fragmentation
+c within their formation time
+c the scaling factor is sigfac which is determined by the
+c individual particles scaling factors xtotfac
+ if(tform(i).le.acttime+tcoll
+ & .and.tform(j).le.acttime+tcoll) then
+ sigfac=1.d0
+ else if(tform(i).le.acttime+tcoll
+ & .and.tform(j).gt.acttime+tcoll) then
+ sigfac=xtotfac(j)
+ else if(tform(j).le.acttime+tcoll
+ & .and.tform(i).gt.acttime+tcoll) then
+ sigfac=xtotfac(i)
+ else
+ sigfac=xtotfac(i)*xtotfac(j)
+ endif
+c get total cross section via call to sigtot and rescale
+ sigt = sigfac*sigtot(i,j,sqrs)
+c rescale sigtot due to color fluctuations
+ctp060202 call colorfluc(ityp(i),ityp(j),sqrs,
+ call colorfluc(ityp(i),ityp(j),
+ & colfaci,colfacj)
+ colfac=colfaci*colfacj
+ sigt = sigt*colfac
+c are we within the geometrical cross section
+ if (sigt.gt.max(1.d-8,(10.d0*pi*dst2))) then
+c this collision is to beat, now
+ tmin = tcoll
+ smin = sqrs
+ sigmin = sigt
+ imin = i
+ jmin = j
+ colfacmin=colfac
+ endif
+ endif
+ endif
+ endif
+ 101 continue
+ if (imin.gt.0) then
+c if we found something, then update table via call to ctupdate
+c (keep in mind: tmin is relative to actual time!)
+ call ctupdate(imin,jmin,acttime+tmin,smin,sigmin,colfacmin)
+c in case of "full load mode" after every collision
+c only the first entry in the collision table is relevant
+ if(CTOption(17).ne.0) nct=1
+ endif
+
+ return
+ end
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ subroutine ctupdate(i,j,t,s,sig,cfac)
+c
+cinput i : index of 1st colliding particle
+cinput j : index of 2nd colliding particle (0 for decay)
+cinput t : (absolut) time of collision/decay
+cinput s : $sqrt{s}$ (GeV) of collison
+cinput sig : total cross section (mbarn) of collision
+cinput cfac : scaling factor for color fluctuation
+c
+c This subroutine updates the collision arrays.
+c It determines the (chonologically) correct position for the new
+c entry in the collision arrays, creates the respective slot and
+c inserts the new entry (via a call to {\tt ctset}.
+c Then the arrays are scanned to tag the chonologically first collision
+c of particle {\tt i} or {\tt j} {\em true} and all subsequent ones
+c as {\em false}.
+c
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+
+ implicit none
+
+ integer i,j
+ real*8 t,s,sig,cfac
+ include 'colltab.f'
+ integer k,tfound,ncoll1
+
+ ncoll1 = nct + 1
+ tfound = ncoll1
+c loop over all collisions in table
+ do 101 k=actcol+1,nct
+c get the correct position for the new entry (chronologically sorted)
+ if (tfound.eq.ncoll1.and.t.le.cttime(k)) tfound = k
+c the above construct works as follows:
+c as long as t > cttime(k), the first term is true and teh
+c the second is false. At the correct position for the new
+c entry BOTH terms are true, for all later times the first
+c term is false in order not to overwrite the value of tfound
+ 101 continue
+
+c make sure that collision is not already listed in the table
+ if (.not.(t.eq.cttime(tfound).and.(i.eq.cti1(tfound).and.
+ & j.eq.cti2(tfound).or.i.eq.cti2(tfound).and.
+ & j.eq.cti1(tfound)))) then
+c then create slot for new entry
+ do 102 k=nct,tfound,-1
+ cttime(k+1) = cttime(k)
+ ctsqrts(k+1) = ctsqrts(k)
+ ctsigtot(k+1) = ctsigtot(k)
+ cti1(k+1) = cti1(k)
+ cti2(k+1) = cti2(k)
+ ctvalid(k+1) = ctvalid(k)
+ ctcolfluc(k+1) = ctcolfluc(k)
+ 102 continue
+c increment number of collisions/decays in table
+ nct = ncoll1
+ endif
+c insert new entry into the created slot via call to ctset
+ call ctset(tfound,i,j,t,s,sig,cfac)
+c
+c only the chonologically FIRST collision of particle i is set to true
+c
+ do 103 k=actcol+1,nct,1
+c the newly found collision must be omitted in the following sequence
+ if (k.eq.tfound) goto 103
+c is there already a collision with i or j ?
+ if (cti1(k).eq.i.or.cti2(k).eq.i) then
+c if the other collision is at an earlier time (the table is time-ordered,
+c therefore k < tfound corresponds to an earlier time)
+c then set the new one to false or vice versa
+ if (k.lt.tfound.and.ctvalid(k)) then
+ ctvalid(tfound) = .false.
+ else
+ ctvalid(k) = .false.
+ endif
+ endif
+c do likewise for the second particle
+ if (j.gt.0.and.(cti1(k).eq.j.or.cti2(k).eq.j)) then
+ if (k.lt.tfound.and.ctvalid(k)) then
+ ctvalid(tfound) = .false.
+ else
+ ctvalid(k) = .false.
+ endif
+ endif
+ 103 continue
+
+ return
+ end
+
+
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+ subroutine ctset(tfound,i,j,t,s,sig,cfac)
+c
+c Revision : 1.0
+C
+cinput tfound : index in coll. array for coll. to be inserted
+cinput i : index of first colliding particle
+cinput j : index of second colliing particle (0 for decay, negative: wall)
+cinput t : (absolute) time of collision
+cinput s : $sqrt{s}$ (GeV) of collison
+cinput sig : total cross section (mbarn) of collsion
+cinput cfac : scaling factor for color fluctuation
+c
+c {\tt ctset} enters the collision of particles {\tt i} and {\tt j}
+c into the collision arrays at index {\tt tfound}.
+c
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+
+ implicit none
+
+ integer tfound,i,j
+
+ real*8 t,s,sig,cfac
+ include 'colltab.f'
+c
+ cttime(tfound) = t
+ ctsqrts(tfound) = s
+ ctsigtot(tfound) = sig
+ cti1(tfound) = i
+ cti2(tfound) = j
+ ctvalid(tfound) = .true.
+ ctcolfluc(tfound) = cfac
+ return
+ end
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+ real*8 function sqrts(i,j)
+c
+c Revision : 1.0
+c
+c input: i,j : numbers of colliding particles
+c output: $\sqrt{s}$ of collision as return value
+c
+c
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+
+ implicit none
+
+ include 'coms.f'
+ integer i,j
+ real*8 p10,p20
+ p10 = sqrt((px(i)+ffermpx(i))**2
+ + +(py(i)+ffermpy(i))**2
+ + +(pz(i)+ffermpz(i))**2+fmass(i)**2)
+ p20 = sqrt((px(j)+ffermpx(j))**2
+ + +(py(j)+ffermpy(j))**2
+ + +(pz(j)+ffermpz(j))**2+fmass(j)**2)
+ sqrts = sqrt((p10+p20)**2
+ + -(px(i)+ffermpx(i)+px(j)+ffermpx(j))**2
+ + -(py(i)+ffermpy(i)+py(j)+ffermpy(j))**2
+ + -(pz(i)+ffermpz(i)+pz(j)+ffermpz(j))**2)
+ return
+ end
+
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ subroutine nxtcoll(j,k,dst,dtauc)
+c
+c Revision : 1.0
+c
+c input: j,k : indices of colliding particles
+coutput dst : impact parameter squared
+coutput dtauc : collisiontime in the computational system
+c
+c {\tt nxtcoll} is the heart of the collision term. It determines
+c the time in the computional system, when the collision between
+c j and k took or will take place ({\tt dtauc}). The squared impact
+c parameter of the collision is returned in {\tt dst}. {\tt dst} is
+c independent of the computational system in which the coordinates
+c of j and k are given.
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+ implicit none
+ integer j,k, i
+ include 'coms.f'
+ real*8 u1(0:3), u2(0:3), p1(0:3), p2(0:3)
+ real*8 dp(0:3), du(0:3), bt_com(3), bt(3)
+ real*8 du2, dp2, dudp, bt_du, bt_dp, btdr, bt2
+ real*8 dst, gam_com, gam_com2, bt_com2, dtauc
+
+c
+c do some assignments first
+c
+ u1(0) = r0(j)
+ u1(1) = rx(j)
+ u1(2) = ry(j)
+ u1(3) = rz(j)
+ u2(0) = r0(k)
+ u2(1) = rx(k)
+ u2(2) = ry(k)
+ u2(3) = rz(k)
+
+ p1(0) = sqrt(px(j)**2+py(j)**2+pz(j)**2+fmass(j)**2)
+ p1(1) = px(j)
+ p1(2) = py(j)
+ p1(3) = pz(j)
+ p2(0) = sqrt(px(k)**2+py(k)**2+pz(k)**2+fmass(k)**2)
+ p2(1) = px(k)
+ p2(2) = py(k)
+ p2(3) = pz(k)
+c
+c -velocity and gamma-factor of the two particle center of momentum
+c frame (com) measured in the computational system
+c
+ bt_com2 = 0.0d0
+ do 1 i=1,3
+ bt_com(i) = -((p1(i)+p2(i))/(p1(0)+p2(0)))
+ bt_com2 = bt_com2 + bt_com(i)**2
+ 1 continue
+ gam_com = 1.0d0/sqrt(1.0d0-bt_com2)
+ gam_com2 = gam_com**2/(1.0d0+gam_com)
+c
+c calculate some numbers which are needed for the Lorentz-transformation
+c
+ bt_du = 0.0d0
+ bt_dp = 0.0d0
+ do 2 i=1,3
+ bt_du = bt_du + bt_com(i)*(u1(i) - u2(i))
+ bt_dp = bt_dp + bt_com(i)*(p1(i) - p2(i))
+ 2 continue
+c
+c calculate bt_com square and the dotproduct bt_com*(r(j)-r(k)),
+c where the r's are given in the computational frame
+c
+c perform Lorentz-transformation of relative distance and relative
+c momentum vectors of particles j and k into com-frame
+c
+c use the resulting 3-vectors du and dp to obtain du and dp squared
+c and the dotproduct du*dp
+c
+ du2 = 0.0d0
+ dp2 = 0.0d0
+ dudp = 0.0d0
+ bt2 = 0.0d0
+ btdr = 0.0d0
+ do 3 i=1,3
+ bt(i) = p1(i)/p1(0) - p2(i)/p2(0) ! Rechensystem rel. vel.
+ bt2 = bt2 + bt(i)**2
+ btdr = btdr + bt(i)*(u1(i)-u2(i)) ! Rechensystem
+ du(i) = u1(i)-u2(i) + bt_com(i)*
+ * (gam_com2*bt_du+gam_com*(u1(0)-u2(0)))
+ dp(i) = p1(i)-p2(i) + bt_com(i)*
+ * (gam_com2*bt_dp+gam_com*(p1(0)-p2(0)))
+ du2 = du2 + du(i)*du(i)
+ dp2 = dp2 + dp(i)*dp(i)
+ dudp = dudp + du(i)*dp(i)
+ 3 continue
+c
+c obtain collision time and impact parameter squared
+c
+ dtauc = -(btdr/bt2)
+ dst = du2 - dudp*dudp/dp2
+
+ end
+
+
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ subroutine scantab(ind,offs)
+c
+c Revision : 1.0
+c
+cinput ind : index of particle
+cinput offs: offset
+c
+c {\tt scantab} adjusts the collision table to changed particle
+c indices due to calls to {\tt addpart} or {\tt delpart}.
+c
+c In case of an annihilation a list is created of those particles
+c which have lost their collision partner and have to be rechecked
+c for possible collisions/decays.
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+ implicit none
+ include 'colltab.f'
+ include 'coms.f'
+ integer ind,offs,i,k
+ logical rescan
+
+c reset counters for the rechecking of particles due to lost collision
+c partners
+ nsav=0
+ rescan=.false.
+
+c call from addpart
+ if (offs.gt.0) then
+c shift upwards, if necessary
+ do 1 i=1,nct
+ if (cti1(i).ge.ind) cti1(i) = cti1(i) + offs
+ if (cti2(i).ge.ind) cti2(i) = cti2(i) + offs
+ 1 continue
+c
+c call from delpart
+ else
+
+c omit scan, if last collision in table
+ if(actcol.eq.nct) return
+c start loop with next collision in table
+ i=actcol+1
+ 2 continue
+ if((cti1(i).eq.ind).or.(cti2(i).eq.ind)) then
+c a dubious entry has been found, now
+c look for particles with 'lost' collision partners
+ if(cti1(i).eq.ind.and.cti2(i).gt.0) then
+c save particles with 'lost' partners in the ctsav array
+ nsav=nsav+1
+ ctsav(nsav)=cti2(i)
+ if(ctsav(nsav).gt.ind) ctsav(nsav)=ctsav(nsav) + offs
+ elseif(cti2(i).eq.ind.and.cti1(i).gt.0) then
+ nsav=nsav+1
+ ctsav(nsav)=cti1(i)
+ if(ctsav(nsav).gt.ind) ctsav(nsav)=ctsav(nsav) + offs
+ endif
+c delete obsolete collision
+ do 4 k=i+1,nct
+ cttime(k-1) = cttime(k)
+ ctsqrts(k-1) = ctsqrts(k)
+ ctsigtot(k-1) = ctsigtot(k)
+ cti1(k-1) = cti1(k)
+ cti2(k-1) = cti2(k)
+ ctvalid(k-1) = ctvalid(k)
+ ctcolfluc(k-1) = ctcolfluc(k)
+ 4 continue
+c decrement collision counter
+ nct = nct-1
+ rescan=.true.
+ else
+c else entry is OK
+ rescan=.false.
+ endif
+c shift rest of table, in case entry has not been deleted
+ if(.not.rescan) then
+ if (cti1(i).gt.ind) cti1(i) = cti1(i) + offs
+ if (cti2(i).gt.ind) cti2(i) = cti2(i) + offs
+ i=i+1
+ endif
+c condinue procedure until all collisions have been scanned
+ if(i.le.nct) goto 2
+ endif
+
+ return
+ end
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ subroutine printtab
+c
+c Revision: 1.0
+c
+c {\tt printtab} prints the contents of the collision arrays on
+c unit 6 and marks the current collision with an *. This subroutine
+c is used for debugging purposes only.
+c
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+ implicit none
+
+ include 'colltab.f'
+ integer i
+ character*1 c
+c
+ write(6,*) 'colltab:'
+ do 101 i=1,nct
+ c = ' '
+ if (i.eq.actcol) c = '*'
+ write(6,'(i4,1x,L1,A1,2(i4,1x),4(f6.3,1x))')
+ & i,ctvalid(i),c,cti1(i),cti2(i),cttime(i),ctsqrts(i)
+ 101 continue
+ return
+ end
+
+
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ctp060202 subroutine colorfluc(it1,it2,ws,fac1,fac2)
+ subroutine colorfluc(it1,it2,fac1,fac2)
+c
+c Revision : 1.0
+c
+cinput it1 : ityp particle 1
+cinput it2 : ityp particle 2
+cinput ws : $\sqrt{s}$ of collision
+coutput fac1 : x-section scaling factor of particle 1
+coutput fac2 : x-section scaling factor of particle 2
+c
+c Modifies the hadron cross section due to color fluctuations,
+c ref. L. Frankfurt et al.: Ann. Rev. Nucl. Part. Sc. 44 (1994)501
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+ implicit none
+ include 'options.f'
+
+ctp060202 real*8 ws,fac1,fac2
+ real*8 fac1,fac2
+ real*8 x,y,Pmes,Pbar,ranf
+ integer it1,it2
+
+
+ fac1=1d0
+ fac2=1d0
+
+c switched on ?
+ if (ctoption(42).eq.0) return
+
+
+c particle 1 is baryon
+ if (abs(it1).lt.100) then
+ 1 x=ranf(0)*3d0
+ y=ranf(0)
+
+c probability disrtibution for x-section factor
+ Pbar=(1.19+32.11*x-15.65*x**2-1.24*x**3+0.94*x**4)/18.d0
+ Pbar=max(0d0,Pbar)
+ if(y.gt.Pbar) goto 1
+ fac1=x
+c particle 1 is meson
+ else
+ 2 x=ranf(0)*5d0
+ y=ranf(0)
+
+c probability disrtibution for x-section factor
+ Pmes=(21.76+4.41*x-3-79*x**2+0.40*x**3)/25.d0
+ Pmes=max(0d0,Pmes)
+ if(y.gt.Pmes) goto 2
+ fac1=x
+ endif
+
+c particle 2 is baryon
+ if (abs(it2).lt.100) then
+ 3 x=ranf(0)*3d0
+ y=ranf(0)
+
+c probability disrtibution for x-section factor
+ Pbar=(1.19+32.11*x-15.65*x**2-1.24*x**3+0.94*x**4)/18.d0
+ Pbar=max(0d0,Pbar)
+ if(y.gt.Pbar) goto 3
+ fac2=x
+c particle 2 is meson
+ else
+ 4 x=ranf(0)*5d0
+ y=ranf(0)
+
+c probability disrtibution for x-section factor
+ Pmes=(21.76+4.41*x-3-79*x**2+0.40*x**3)/25.d0
+ Pmes=max(0d0,Pmes)
+ if(y.gt.Pmes) goto 4
+ fac2=x
+ endif
+
+ return
+ end
+
diff --git a/Processes/UrQMD/comnorm.f b/Processes/UrQMD/comnorm.f
new file mode 100644
index 0000000000000000000000000000000000000000..fdc0b49e29569d3073c1e47a162b743e2f50758f
--- /dev/null
+++ b/Processes/UrQMD/comnorm.f
@@ -0,0 +1,6 @@
+c $Id: comnorm.f,v 1.5 1999/01/18 09:56:55 ernst Exp $
+ integer n
+ parameter (n = 400)
+ real*8 x_norm(0:3,1:n),y_norm(0:3,1:n)
+ real*8 y2a(0:3,1:n),y2b(0:3,1:n),dx
+ common /normsplin/ x_norm,y_norm,y2a,y2b,dx
diff --git a/Processes/UrQMD/comres.f b/Processes/UrQMD/comres.f
new file mode 100644
index 0000000000000000000000000000000000000000..e7a4a7cc393d06ad044df35dabbfa9364e7fd949
--- /dev/null
+++ b/Processes/UrQMD/comres.f
@@ -0,0 +1,172 @@
+c $Id: comres.f,v 1.15 2003/06/29 14:26:36 weber Exp $
+c
+cdes This file contains definitions for the collision term
+c
+ integer maxbar,maxbra,minbar
+ integer offmeson,maxmeson,pimeson,maxbrm,minnuc,mindel
+ integer maxbrs1,maxbrs2
+ integer numnuc,numdel,nucleon,maxnuc,maxdel
+ integer minmes,maxmes
+
+
+ parameter (minnuc=1) ! lowest baryon particle ID
+ parameter (minmes=100) ! lowest meson particle ID
+ parameter (maxmes=132) ! hightest meson particle ID
+
+c number of resonances of a kind
+ parameter (numnuc=16) ! number of nucleon resonances
+ parameter (numdel=10) ! number of delta resonances
+c indices of minimal and maximal itype of a kind (redundant but nice)
+ parameter (maxnuc=minnuc+numnuc-1) ! highest nucleon ID
+ parameter (mindel=minnuc+maxnuc) ! lowest delta ID
+ parameter (maxdel=mindel+numdel-1) ! highest delta ID
+
+c minres & maxres define the range of nonstable & nonstrange baryons
+ integer minres,maxres
+ parameter (minres=minnuc+1) ! lowest baryon resonance ID
+ parameter (maxres=maxdel) ! highest (nonstrange) baryon
+ ! resonance ID
+
+c strangenes.ne.0 baryon resonances
+ integer minlam,minsig,mincas,minome
+ integer numlam,numsig,numcas,numome
+ integer maxlam,maxsig,maxcas,maxome
+ parameter (numlam=13) ! number of lambda states
+ parameter (numsig=9) ! number of sigma states
+ parameter (numcas=6) ! number of cascade states
+ parameter (numome=1) ! number of omega states
+ parameter (minlam=mindel+numdel) ! ID of lowest lambda state
+ parameter (maxlam=minlam+numlam-1) ! ID of highest lambda state
+ parameter (minsig=minlam+numlam) ! ID of lowest sigma state
+ parameter (maxsig=minsig+numsig-1) ! ID of highest sigma state
+ parameter (mincas=minsig+numsig) ! ID of lowest cascade state
+ parameter (maxcas=mincas+numcas-1) ! ID of highest cascade state
+ parameter (minome=mincas+numcas) ! ID of lowest omega state
+ parameter (maxome=minome+numome-1) ! ID of highest omega state
+
+c minbar & maxbar define the range of all baryons
+ parameter (minbar=minnuc) ! ID of lowest baryon state
+ parameter (maxbar=maxome) ! ID of highest baryon state
+
+ parameter (offmeson=minmes) ! offset between zero and lowest
+ ! meson state
+ parameter (maxmeson=maxmes) ! ID of highest meson state
+c... these variables are in principal obsolete and should be exchanged
+c were referenced
+
+c... avoid hard coded itypes
+ integer itrho,itome,iteta,itkaon,itphi,itetapr
+ parameter (itkaon=106) ! ID of kaon
+ parameter (itrho=104) ! ID of rho meson
+ parameter (itome=103) ! ID of omega meson
+ parameter (iteta=102) ! ID of eta
+ parameter (itphi=109) ! ID of phi
+ parameter (itetapr=107) ! ID of eta'
+ parameter (pimeson=101) ! ID of $\pi$
+ parameter (nucleon=minnuc) ! ID of nucleon
+
+ integer itmin,itmax
+ parameter (itmin=minnuc) ! lowest defined ID
+ parameter (itmax=maxmes) ! highest defined ID
+c
+ parameter (maxbra=11) ! decay channels for $s=0$ baryon resonances
+ parameter (maxbrm=25) ! decay channels for meson resonances
+ parameter (maxbrs1=10)! decay channels for $s=1$ baryon resonances
+ parameter (maxbrs2=3) ! decay channels for $s=2$ baryon resonances
+
+c
+ integer mlt2it(maxmes-minmes) ! meson IDs sorted by multipletts
+
+
+ real*8 massoff,mresmin,mresmax
+ parameter (massoff=1d-4) ! offset for mass generation
+ parameter (mresmin=1.0765d0) ! minimum baryon resonance mass
+ parameter (mresmax=5d0) ! maximum baryon resonance mass
+
+ character*45 versiontag
+ common /versioning/ versiontag
+
+ real*8 massres(minbar:maxbar),widres(minbar:maxbar)
+ real*8 branmes(0:maxbrm,minmes+1:maxmes)
+ real*8 branres(0:maxbra,minnuc+1:maxdel)
+ real*8 branbs1(0:maxbrs1,minlam+1:maxsig)
+ real*8 branbs2(0:maxbrs2,mincas+1:maxcas)
+ integer Jres(minbar:maxbar)
+ integer Jmes(minmes:maxmes)
+ integer pares(minbar:maxbar),pames(minmes:maxmes)
+ integer Isores(minbar:maxbar), Isomes(minmes:maxmes)
+ integer brtype(4,0:maxbra),bmtype(4,0:maxbrm)
+ integer bs1type(4,0:maxbrs1),bs2type(4,0:maxbrs2)
+ real*8 massmes(minmes:maxmes)
+ real*8 mmesmn(minmes:maxmes)
+ real*8 widmes(minmes:maxmes)
+ integer strres(minbar:maxbar),strmes(minmes:maxmes)
+
+ integer lbr(0:maxbra,minnuc+1:maxdel)
+ integer lbs1(0:maxbrs1,minlam+1:maxsig)
+ integer lbs2(0:maxbrs2,mincas+1:maxcas)
+ integer lbm(0:maxbrm,minmes+1:maxmes)
+
+ common /resonances/ massres,widres,massmes,widmes,mmesmn,
+ , branres,branmes,branbs1,branbs2,
+ , bs1type,bs2type,lbs1,lbs2,lbm,
+ , jres,jmes,lbr,brtype,pares,pames,
+ , bmtype,
+ , Isores,Isomes,strres,strmes,mlt2it
+
+c massres : baryon mass table
+c widres : baryon decay width table
+c massmes : meson mass table
+c widmes : meson decay width table
+c mmesmn : table of minimum masses for meson resonances
+c branres : branching ratios for $s=0$ baryon resonances
+c branmes : branching ratios for meson resonances
+c branbs1 : branching ratios for $s=1$ baryon resonances
+c branbs2 : branching ratios for $s=2$ baryon resonances
+c brtype : definitions of the decay branches for $s=0$ baryon resonances
+c bmtype : definitions of the decay branches for meson resonances
+c bs1type : definitions of the decay branches for $s=1$ baryon resonances
+c bs2type : definitions of the decay branches for $s=2$ baryon resonances
+c lbr : decay angular momenta for $s=0$ baryon decays
+c lbm : decay angular momenta for meson decays
+c lbs1 : decay angular momenta for $s=1$ baryon decays
+c lbs2 : decay angular momenta for $s=2$ baryon decays
+c jres : spin table for baryons
+c jmes : spin table for mesons
+c pares : parity table for baryons
+c pames : parity table for mesons
+c isores : isospin table for baryons
+c isomes : isospin table for mesons
+c strres : strangeness table for baryons
+c strmes : strangeness table for mesons
+c
+c
+ccccccccccccccccccccc sigtab-declarations cccccccccccccccccccccccccccccccccc
+
+ integer itblsz,nsigs,maxreac,maxpsig,sigver
+c VERSION NUMBER of SIGTAB
+ parameter (sigver = 1000) ! version number for collision
+ ! term and tables
+ccccccccccccccccccccccccccccccccccccccc
+c
+
+ parameter (maxreac = 13) ! maximum number of collision classes
+ parameter (maxpsig = 12) ! maximum number of cross
+ ! sections per class
+ parameter (nsigs = 10) ! number of tabulated cross sections
+
+ PARAMETER (ITBLSZ= 100) ! table size of cross section tables
+
+
+c
+ integer sigmaLN(maxpsig,2,maxreac)
+ integer sigmainf(nsigs,20)
+ real*8 sigmascal(nsigs,5), sigmas(nsigs,itblsz)
+c
+ common/sigtabi/sigmaln,sigmainf
+ common/sigtabr/sigmas,sigmascal
+
+c sigmaln : pointer array connecting collision classes with cross sections
+c sigmainf : information related to tabulated cross sections
+c sigmascal : information related to tabulated cross sections
+c sigmas : tabulated cross sections
diff --git a/Processes/UrQMD/coms.f b/Processes/UrQMD/coms.f
new file mode 100644
index 0000000000000000000000000000000000000000..be4c3f43a1a91d7de36d7cb931f8938002e89060
--- /dev/null
+++ b/Processes/UrQMD/coms.f
@@ -0,0 +1,215 @@
+c $Id: coms.f,v 1.21 2003/06/29 14:26:36 weber Exp $
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+c standard common block for uQMD
+c
+cdes This file contains the standard commom blocks of UrQMD
+c
+ real*8 emnuc
+ parameter (emnuc = 0.938) ! nucleon mass
+
+ integer nmax, nspl
+ real*8 hit_sphere
+ parameter (nmax = 500) ! maximum number of particles
+ parameter (nspl = 500) ! dimension of spline arrays
+ parameter (hit_sphere = 8.d0) ! hard collision cutoff: 251 mbarn
+
+c debug and validity range
+ logical check, info, warn
+ parameter (check=.true., info=.false., warn=.false.)
+
+ integer Ap, At, Zp, Zt, npart, nbar, nmes, ctag
+ integer nsteps,ranseed,event,eos,dectag,uid_cnt
+ integer NHardRes,NSoftRes,NDecRes,NElColl,NBlColl
+ real*8 time, acttime, bdist, ebeam, bimp,bmin,ecm
+c 7 integer
+
+ common /sys/ npart, nbar, nmes, ctag,nsteps,uid_cnt,
+ + ranseed,event,Ap,At,Zp,Zt,eos,dectag,
+ + NHardRes,NSoftRes,NDecRes,NElColl,NBlColl
+ common /rsys/ time,acttime,bdist,bimp,bmin,ebeam,ecm
+
+c Ap : projectile mass
+c Zp : projectile charge
+c At : target mass
+c Zt : target charge
+c npart : total number of particles
+c nbar : number of baryons AND antibaryons
+c nmes : number of mesons
+c ctag : counter of All interactions (coll. and dec.)
+c nsteps : number of timesteps
+c uid_cnt : counter for assigning unique particle ID-tags
+c ranseed : random number generator seed of event
+c event : event counter
+c eos : flag for the EoS chosen
+c dectag : counter for decays
+c NHardRes : counter for resonance excitation in BB collisions
+c NSoftRes : counter for resonance excitation in MB collisions
+c NElColl : counter for elastic collisions
+c NBlColl : counter for Pauli-blocked collisions
+c time : system time at beginning of timestep
+c acttime : current system time
+c bdist : maximum impact parameter (of event sample)
+c bimp : actual impact parameter
+c bmin : minimum impact parameter (of event sample)
+c ebeam : incident beam energy (lab frame)
+c ecm : initial projectile-hadron target-hadron c.m. energy
+
+ logical firstseed
+ common /comseed/firstseed
+
+ logical lsct(nmax),
+ + logSky, logYuk, logCb, logPau
+ common /logic/ lsct, logSky, logYuk, logCb, logPau
+c 2*nmax*nmax logical
+
+ integer spin(nmax),ncoll(nmax),charge(nmax),strid(nmax),
+ + ityp(nmax),lstcoll(nmax),iso3(nmax),origin(nmax),uid(nmax)
+c 6*nmax integer
+
+
+
+ real*8 eps, er0, pi, rho0,hqc
+ parameter (eps = 1.0E-12) ! small number
+ parameter (er0 = 1.128379167) ! used for error function
+ parameter (pi = 3.1415926535) ! useful constant
+ parameter (rho0 = 0.16) ! nuclear matter ground state density
+ parameter (hqc = 0.197327) ! value of $\hbar c$
+
+c IMPORTANT: when you change the version number please change also
+c the versiontag in blockres.f !
+ integer version, laires
+ parameter ( version = 10035) ! version number
+ parameter ( laires = 10002) ! additional tag
+
+c MD temporary arrays
+ real*8 r0_t(nmax), rx_t(nmax), ry_t(nmax), rz_t(nmax)
+
+ common/mdprop/ r0_t, rx_t, ry_t, rz_t
+
+ real*8
+ + gw, sgw, delr, fdel, dt,
+ + da, db,
+ + Cb0, Yuk0, Pau0, Sky20, Sky30, gamSky, gamYuk, drPau, dpPau,
+ + dtimestep
+c 19 real*8
+
+ real*8 cutmax, cutPau, cutCb, cutYuk, cutSky, cutdww
+ common /cuts/ cutmax, cutPau, cutCb, cutYuk, cutSky, cutdww
+
+ real*8 spx(nspl), spPauy(nspl), outPau(nspl),
+ + spCby(nspl), outCb(nspl),
+ + spYuky(nspl), outYuk(nspl),
+ + spSkyy(nspl), outSky(nspl),
+ + spdwwy(nspl), outdww(nspl)
+
+ common /spdata/ spx, spPauy, outPau, spCby, outCb,
+ + spYuky, outYuk, spSkyy, outSky,
+ + spdwwy, outdww
+
+ real*8
+ + r0(nmax), rx(nmax), ry(nmax), rz(nmax),
+ + p0(nmax), px(nmax), py(nmax), pz(nmax),
+ + airx(nmax), airy(nmax), airz(nmax),
+ + aipx(nmax), aipy(nmax), aipz(nmax),
+ + aorx(nmax,4), aory(nmax,4), aorz(nmax,4),
+ + aopx(nmax,4), aopy(nmax,4), aopz(nmax,4),
+ + fmass(nmax), rww(nmax),
+ + dectime(nmax), tform(nmax), xtotfac(nmax)
+
+ common/isys/spin,ncoll,charge,ityp,lstcoll,iso3,origin,strid,
+ + uid
+ common /coor/ r0, rx, ry, rz, p0, px, py, pz, fmass, rww, dectime
+ common /frag/ tform, xtotfac
+
+c spin : particle spin
+c ncoll : particle number of collisions
+c charge : particle charge
+c strid : ID of last string, the particle was contained in
+c ityp : particle ID
+c lstcoll : tag of last interaction of particle
+c iso3 : $2 \cdot I_3$ of particle
+c origin : ID of last interaction of particle
+c uid : unique particle ID tag
+c r0 : particle time
+c rx : $x$ coordinate
+c ry : $y$ coordinate
+c rz : $z$ coordinate
+c p0 : particle energy
+c px : $p_x$ momentum
+c py : $p_y$ momentum
+c pz : $p_z$ momentum
+c fmass : mass of particle
+c rww : ??
+c dectime : decay time of particle
+c tform : formation time of particle
+c xtotfac : cross section scaling factor during formation time
+c
+ common /aios/ airx, airy, airz, aipx, aipy, aipz,
+ + aorx, aory, aorz, aopx, aopy, aopz
+
+ common /pots/ Cb0, Yuk0, Pau0, Sky20, Sky30, gamSky,
+ + gamYuk, drPau, dpPau, gw, sgw, delr, fdel,
+ + dt,da, db,dtimestep
+
+
+c spectator arrays
+ integer smax
+ parameter(smax=500) ! maximum number of spectators
+ real*8 r0s(smax), rxs(smax), rys(smax), rzs(smax),
+ + p0s(smax), pxs(smax), pys(smax), pzs(smax),
+ + sfmass(smax)
+
+
+ integer sspin(smax), scharge(smax), sityp(smax), siso3(smax),
+ + suid(smax)
+
+ integer nspec
+
+ common /scoor/ r0s, rxs, rys, rzs, p0s, pxs ,pys, pzs, sfmass
+
+ common /sisys/ sspin, scharge, sityp, siso3, suid
+
+ common /ssys/ nspec
+
+c sspin : spectator particle spin
+c scharge : spectator particle charge
+c sityp : spectator particle ID
+c siso3 : $2 \cdot I_3$ of spectator particle
+c r0s : spectator particle time
+c rxs : spectator $x$ coordinate
+c rys : spectator $y$ coordinate
+c rzs : spectator $z$ coordinate
+c p0s : spectator particle energy
+c pxs : spectator $p_x$ momentum
+c pys : spectator $p_y$ momentum
+c pzs : spectator $p_z$ momentum
+c sfmass : mass of spectator particle
+
+
+c
+ real*8 p0td(2,nmax),pxtd(2,nmax),pytd(2,nmax),pztd(2,nmax),
+ + fmasstd(2,nmax)
+ integer ityptd(2,nmax),iso3td(2,nmax)
+ integer itypt(2),uidt(2),origint(2),iso3t(2)
+
+ common /rtdelay/p0td,pxtd,pytd,pztd,fmasstd
+ common /itdelay/ityptd,iso3td
+ common /svinfo/itypt,uidt,origint,iso3t
+
+c p0td : energy of parent particles of resonace (DP formalism)
+c pxtd : $p_x$ of parent particles of resonace (DP formalism)
+c pytd : $p_y$ of parent particles of resonace (DP formalism)
+c pztd : $p_z$ of parent particles of resonace (DP formalism)
+c fmasstd : mass of parent particles of resonace (DP formalism)
+c ityptd : ID of parent particles of resonace (DP formalism)
+c iso3td : $2\cdot I_3$ of parent particles of resonace (DP formalism)
+
+ real*8 ffermpx(nmax), ffermpy(nmax), ffermpz(nmax)
+ real*8 peq1, peq2
+ common /ffermi/ ffermpx, ffermpy, ffermpz
+ common /peq/ peq1,peq2
+
+c ffermpx : fermi momentum in $x$ direction
+c ffermpy : fermi momentum in $y$ direction
+c ffermpz : fermi momentum in $z$ direction
diff --git a/Processes/UrQMD/comstr.f b/Processes/UrQMD/comstr.f
new file mode 100644
index 0000000000000000000000000000000000000000..570effcc8fc4ae48ada2407999dc7b32228a368e
--- /dev/null
+++ b/Processes/UrQMD/comstr.f
@@ -0,0 +1,23 @@
+c $Id: comstr.f,v 1.2 1999/01/18 09:56:58 ernst Exp $
+
+ parameter (njspin=8)
+
+ real*8 PJSPNS,PMIX1S(3,njspin),PMIX2S(3,njspin),PBARS,
+ *PARQLS,PARRS
+ real*8 PJSPNC,PMIX1C(3,njspin),PMIX2C(3,njspin),PBARC
+
+
+
+ COMMON/FRGSPA/ PJSPNS,PMIX1S,PMIX2S,PBARS,
+ *PARQLS,PARRS
+ COMMON/FRGCPA/ PJSPNC,PMIX1C,PMIX2C,PBARC
+
+c parm gives the probability for different meson multiplets according
+c to spin degeneracy and average mass ratios
+c spin-parity 0- : 1- : 0+ : 1+ : 2+ = parm(1):parm(2)...:parm(njspin)
+ real*8 parm(njspin)
+
+ common/coparm/parm
+
+ real*8 pi
+ COMMON/CONST/ PI
diff --git a/Processes/UrQMD/comwid.f b/Processes/UrQMD/comwid.f
new file mode 100644
index 0000000000000000000000000000000000000000..fe0b2b97f9928f70749910d5121eb760bfa0cbdb
--- /dev/null
+++ b/Processes/UrQMD/comwid.f
@@ -0,0 +1,60 @@
+c $Id: comwid.f,v 1.13 2003/06/29 14:26:36 weber Exp $
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+c Revision : 1.0
+c
+c common block for the tabulated branching ratios
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+c number of points for the interpolation
+ integer widnsp
+c the branching ratios are interpolated with high precision in the range
+c from mintab to maxtab1 and from maxtab1 to maxtab2 with a smaller precision
+
+c version number of the table
+ integer tabver
+ real*8 mintab, maxtab1, maxtab2
+
+c set the default values
+ parameter (widnsp=120)
+ parameter (mintab=0.1d0)
+ parameter (maxtab1=5.0d0)
+ parameter (maxtab2=50.0d0)
+c increase this parameter, if you make changes, which require a new table
+ parameter (tabver=9)
+
+c tabulated x-values (i.e. sqrt(s) of the collision)
+ real*8 tabx (1:widnsp)
+c tabulated y-values (i.e. the branching ratios) and the second
+c derivatives of the function.
+c full baryon ratio
+ real*8 fbtaby (1:widnsp,minbar:maxbar,1:2)
+c partial baryon ratios
+cdh real*8 pbtaby (1:widnsp,1:2,minbar:maxbar,0:maxbrs1)
+ real*8 pbtaby (1:widnsp,1:2,minbar:maxbar,0:maxbra)
+c full meson ratio
+ real*8 fmtaby (1:widnsp,minmes:maxmes,1:2)
+c partial meson ratios
+ real*8 pmtaby (1:widnsp,1:2,minmes:maxmes,0:maxbrm)
+
+c Breit-Wigner norms
+c norm of Breit-Wigner with mass dependent widths baryons/mesons
+ real*8 bwbarnorm(minbar:maxbar),bwmesnorm(minmes:maxmes)
+
+c tabulated fppfit()
+c tabulated x-values (i.e. sqrt(s) of the collision)
+ real*8 tabxnd (1:widnsp)
+c 2-resonance channels
+c x deriv ND N*..D*
+ real*8 frrtaby(1:widnsp,1:2,1:2,2:maxdel)
+
+c this flag indicates the progress of tabulating the function
+ integer wtabflg
+c name of file containing the tables
+ character*77 tabname
+
+ common /decaywidth/ tabx,fbtaby,pbtaby,fmtaby,pmtaby,wtabflg
+ common /brwignorm/ bwbarnorm,bwmesnorm
+ common /xsections/ tabxnd,frrtaby
+ common /tabnames/ tabname
diff --git a/Processes/UrQMD/dectim.f b/Processes/UrQMD/dectim.f
new file mode 100644
index 0000000000000000000000000000000000000000..5c803ee70ad6465360babe4bb5cc1b8dee868f52
--- /dev/null
+++ b/Processes/UrQMD/dectim.f
@@ -0,0 +1,77 @@
+c $Id: dectim.f,v 1.7 1999/01/18 09:56:59 ernst Exp $
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ real*8 function dectim(ind,iproc)
+c
+c Revision : 1.0
+C
+cinput ind : ID of particle
+cinput iproc: process ID for resonance creation
+couput dectim: time of decay
+c
+c This function computes a random choice for the time at which
+c a resonance will decay and transformes it to the computational
+c frame.
+c
+c
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+ implicit none
+ include 'coms.f'
+ include 'options.f'
+ include 'colltab.f'
+
+ integer ind,iproc
+ real*8 gg,wid,tau,ranf,fwidth,widit,fbwnorm,mr,massit
+ real*8 tmp,factor
+c
+c first determine width of resonace
+c
+ if(CTOption(1).eq.0.and.CTOption(34).ne.1) then
+c mass dependent width
+ wid=fwidth(ityp(ind),iso3(ind),fmass(ind))*CTParam(1)
+ else
+c fixed width
+ wid=widit(ityp(ind))*CTParam(1)
+ end if
+
+C ... REST FRAME DECAY TIME
+ if(WID .GT. 1.d-10) then
+ if(CTOption(34).lt.2) then
+c "normal" life time tau=1/gamma
+ TAU=-(dLOG(1.d0-RANF(0))/WID)
+ else
+c use Danielewicz delay
+ if(iproc.ne.36.and.iproc.ne.37) then
+c delay for scattering wave
+ TAU=-(dLOG(1.d0-RANF(0))*
+ & fbwnorm(fmass(ind),ityp(ind),iso3(ind))*pi/2.d0)
+ else
+c delay for forward wave
+ if(CTOption(34).eq.2) then
+ factor=1.d0/CTParam(58)
+ elseif(CTOption(34).eq.3) then
+ factor=(ctsigtot(actcol)-CTParam(58))/CTParam(58)
+ elseif(CTOption(34).eq.4) then
+ tmp=dsqrt(2.d0/(wid*3.14d0*
+ & fbwnorm(fmass(ind),ityp(ind),iso3(ind))))
+ factor=1.d0/(CTParam(58)*tmp)
+ else
+ factor=1.d0
+ endif
+ mr=massit(ityp(ind))
+ TAU=-(dLOG(1.d0-RANF(0))*factor*
+ & 2.d0*pi*fbwnorm(fmass(ind),ityp(ind),iso3(ind))*
+ & (fmass(ind)-mr)**2/wid**2)
+ endif
+ endif
+ ELSE
+c stable particle
+ DECTIM=1.d34
+ RETURN
+ END IF
+C ... APPLY TIME DILATION
+C ... GAMMA FOR THE RESONANCE RESTFRAME <-> COMP. FRAME TRAFO
+ gg=p0(ind)/fmass(ind)
+ DECTIM=TAU*GG*hqc
+
+ RETURN
+ END
diff --git a/Processes/UrQMD/delpart.f b/Processes/UrQMD/delpart.f
new file mode 100644
index 0000000000000000000000000000000000000000..73bbe76a36f1e711566acc916bd99089cc3f0f63
--- /dev/null
+++ b/Processes/UrQMD/delpart.f
@@ -0,0 +1,243 @@
+c $Id: delpart.f,v 1.5 2000/01/12 16:02:34 bass Exp $
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+ subroutine delpart(index)
+c
+c Revision : 1.0
+c
+cinput index : index of particle to delete
+c
+c This subroutine deletes the entry of particle {\tt index} in all
+c particle arrays.
+c
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+ implicit none
+ include 'coms.f'
+ include 'comres.f'
+ include 'newpart.f'
+ include 'freezeout.f'
+ integer index,i,j,ind
+
+ ind=index
+ if(ind.lt.1.or.ind.gt.npart) then
+ write(6,*)'***(E) delpart: ind out of bounds ',ind,npart
+ stop
+ endif
+
+c update nbar and nmes counters
+ if(iabs(ityp(ind)).le.maxbar) then
+ nbar=nbar-1
+ elseif(iabs(ityp(ind)).ge.minmes)then
+ nmes=nmes-1
+ endif
+
+c delete slot
+ do 10 i=ind+1,npart
+ r0(i-1)=r0(i)
+ rx(i-1)=rx(i)
+ ry(i-1)=ry(i)
+ rz(i-1)=rz(i)
+ p0(i-1)=p0(i)
+ px(i-1)=px(i)
+ py(i-1)=py(i)
+ pz(i-1)=pz(i)
+ fmass(i-1)=fmass(i)
+ ityp(i-1)=ityp(i)
+ iso3(i-1)=iso3(i)
+ ncoll(i-1)=ncoll(i)
+ lstcoll(i-1)=lstcoll(i)
+ charge(i-1)=charge(i)
+ spin(i-1)=spin(i)
+ dectime(i-1)=dectime(i)
+ tform(i-1)=tform(i)
+ xtotfac(i-1)=xtotfac(i)
+ origin(i-1)=origin(i)
+ strid(i-1)=strid(i)
+ uid(i-1)=uid(i)
+ frr0(i-1)=frr0(i)
+ frrx(i-1)=frrx(i)
+ frry(i-1)=frry(i)
+ frrz(i-1)=frrz(i)
+ frp0(i-1)=frp0(i)
+ frpx(i-1)=frpx(i)
+ frpy(i-1)=frpy(i)
+ frpz(i-1)=frpz(i)
+ ffermpx(i-1)=ffermpx(i)
+ ffermpy(i-1)=ffermpy(i)
+ ffermpz(i-1)=ffermpz(i)
+ r0_t(i-1)=r0_t(i)
+ rx_t(i-1)=rx_t(i)
+ ry_t(i-1)=ry_t(i)
+ rz_t(i-1)=rz_t(i)
+ctd
+ do 11 j=1,2
+ p0td(j,i-1)=p0td(j,i)
+ pxtd(j,i-1)=pxtd(j,i)
+ pytd(j,i-1)=pytd(j,i)
+ pztd(j,i-1)=pztd(j,i)
+ fmasstd(j,i-1)=fmasstd(j,i)
+ ityptd(j,i-1)=ityptd(j,i)
+ iso3td(j,i-1)=iso3td(j,i)
+ 11 continue
+
+c ...
+ 10 continue
+ npart=npart-1
+
+c update entries of lstcoll vector
+ do 15 i=1,npart
+ if(lstcoll(i).le.nmax) then
+ if(lstcoll(i).eq.ind) then
+ lstcoll(i)=0
+ elseif(lstcoll(i).gt.ind) then
+ lstcoll(i)=lstcoll(i)-1
+ endif
+ endif
+ 15 continue
+
+c update collision tables
+c and scan for particles which have lost their collision partner
+ call scantab(ind,-1)
+
+c update pointer array for new/scattered particles
+ do 20 i=1,nexit
+ if(inew(i).gt.ind) then
+ inew(i)=inew(i)-1
+ elseif(inew(i).eq.ind) then
+ inew(i)=0
+ endif
+ 20 continue
+ return
+ end
+
+
+
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+ subroutine adspec(index)
+c
+c Revision : 1.0
+c
+cinput index : index of particle to delete
+c
+c This subroutine deletes the entry of particle {\tt index} in all
+c particle arrays and writes it to file 14 and 16 by the call
+c of specout
+c
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+ implicit none
+ include 'coms.f'
+ include 'comres.f'
+ include 'newpart.f'
+ integer index,i,ind
+
+ ind=index
+ if(ind.lt.1.or.ind.gt.npart) then
+ write(6,*)'***(E) adspec: ind out of bounds ',ind,npart
+ stop
+ endif
+
+cernst fill spectator-arrays
+ nspec=nspec+1
+ r0s(nspec)=r0(ind)
+ rxs(nspec)=rx(ind)
+ rys(nspec)=ry(ind)
+ rzs(nspec)=rz(ind)
+ p0s(nspec)=p0(ind)
+ pxs(nspec)=px(ind)
+ pys(nspec)=py(ind)
+ pzs(nspec)=pz(ind)
+ sfmass(nspec)=fmass(ind)
+ sspin(nspec)=spin(ind)
+ scharge(nspec)=charge(ind)
+ sityp(nspec)=ityp(ind)
+ siso3(nspec)=iso3(ind)
+ suid(nspec)=uid(ind)
+
+c update nbar and nmes counters
+ if(iabs(ityp(ind)).le.maxbar) then
+ nbar=nbar-1
+ elseif(iabs(ityp(ind)).ge.minmes)then
+ nmes=nmes-1
+ endif
+
+ i=ind
+ call specout(i,14)
+ call specout(i,16)
+
+ do 10 i=ind+1,npart
+ r0(i-1)=r0(i)
+ rx(i-1)=rx(i)
+ ry(i-1)=ry(i)
+ rz(i-1)=rz(i)
+ p0(i-1)=p0(i)
+ px(i-1)=px(i)
+ py(i-1)=py(i)
+ pz(i-1)=pz(i)
+ fmass(i-1)=fmass(i)
+ ityp(i-1)=ityp(i)
+ iso3(i-1)=iso3(i)
+ ncoll(i-1)=ncoll(i)
+ lstcoll(i-1)=lstcoll(i)
+ charge(i-1)=charge(i)
+ spin(i-1)=spin(i)
+ dectime(i-1)=dectime(i)
+ tform(i-1)=tform(i)
+ xtotfac(i-1)=xtotfac(i)
+ uid(i-1)=uid(i)
+c ...
+ 10 continue
+ npart=npart-1
+
+c update entries of lstcoll vector
+ do 15 i=1,npart
+ if(lstcoll(i).eq.ind) then
+ lstcoll(i)=0
+ elseif(lstcoll(i).gt.ind) then
+ lstcoll(i)=lstcoll(i)-1
+ endif
+ 15 continue
+
+c update collision tables
+ call scantab(ind,-1)
+
+c update pointer array for new/scattered particles
+ do 20 i=1,nexit
+ if(inew(i).gt.ind) then
+ inew(i)=inew(i)-1
+ elseif(inew(i).eq.ind) then
+ inew(i)=0
+ endif
+ 20 continue
+ return
+ end
+
+
+C####C##1#########2#########3#########4#########5#########6#########7##
+ subroutine rmspec(bpro,btar)
+cccccCcc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc
+ implicit none
+ include 'coms.f'
+ include 'options.f'
+ integer i,n,nspc
+ real*8 sr1,sr2,srp,srt,bpro,btar,roff
+ real*8 nucrad
+
+ n=npart
+ nspc=0
+ roff=CTParam(35)
+ srp=(roff+nucrad(Ap))**2
+ srt=(roff+nucrad(At))**2
+ if(n.le.2)return
+ i=n
+ 108 continue
+
+ sr1=ry(i)**2+(rx(i)-bpro)**2
+ sr2=ry(i)**2+(rx(i)-btar)**2
+ if((sr1.gt.srp.or.sr2.gt.srt).and.ityp(i).eq.1)then
+ write(6,*)'rmspec: ',rx(i),ry(i),i
+ call adspec(i)
+ end if
+ i=i-1
+ if(i.ge.1)goto 108
+
+ return
+ end
diff --git a/Processes/UrQMD/detbal.f b/Processes/UrQMD/detbal.f
new file mode 100644
index 0000000000000000000000000000000000000000..eee1d770b8e6adf748c7d0380043face92fe2366
--- /dev/null
+++ b/Processes/UrQMD/detbal.f
@@ -0,0 +1,895 @@
+c $Id: detbal.f,v 1.12 1999/01/18 09:57:00 ernst Exp $
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+ subroutine detbal(sqrts,ityp1,ityp2,iso31,iso32,
+ & em1,em2,itnew1,itnew2,dbfact)
+c
+c Revision : 1.0
+c
+cinput sqrts : sqrt(s)
+cinput ityp1 : ityp of incoming particle 1
+cinput ityp2 : ityp of incoming particle 2
+cinput iso31 : 2*I3 of incoming particle 1
+cinput iso32 : 2*I3 of incoming particle 2
+cinput em1 : mass of incoming particle 1
+cinput em2 : mass of incoming particle 2
+cinput itnew1 : ityp of outgoing particle 1
+cinput itnew2 : ityp of outgoing particle 2
+c
+coutput dbfact : correction factor for cross section
+c
+c This subroutine calculates a correction factor for the
+c partial crosssection based on the principle of detailed balance.
+C
+c For {\tt CTOption(3)=0} a modified detailed balance (default) is used
+c which takes finite resonance widths into account. For
+c {\tt CTOption(3)=1} the old standard detailed balance relation is used.
+c
+c
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+c
+ implicit none
+
+ include 'coms.f'
+ include 'options.f'
+ include 'comres.f'
+ include 'newpart.f'
+c
+
+ real*8 sqrts, dbfact
+ integer iso31, iso32
+ real*8 em1, em2, clebweight
+ integer ityp1, ityp2, itnew1, itnew2
+c local vars for integration of Breit-Wigner:
+ real*8 mepsilon
+ real*8 oq, q, minwid, factor
+ integer inres, outres,idum1,idum2,idum3,idum4
+c called functions
+ real*8 pcms, dbweight, massit
+ real*8 pmean, widit, dgcgkfct
+ integer isoit
+ real*8 detbalin
+ external detbalin
+
+c
+c 0.1 MeV shift for integrator-maxvalue
+ parameter(mepsilon=0.0001)
+c minimal width for "unstable" particle
+ parameter( minwid=1.d-4 )
+
+ctp060202 to avoid warnings with gfortran compilation
+ logical ctp060202
+ ctp060202=.false.
+ if(ctp060202)write(*,*)em1,em2
+ctp060202 end
+
+ idum1=0
+ idum2=0
+ idum3=0
+ idum4=0
+c
+c fix itypes, iso3 and phase-space for outgoing particles
+c
+c a) set up call to isocgk and getmass: determine outgoing isospins
+c and masses
+
+
+c
+c clebweight: actually areduction of given isospin_summed cross_section
+c to actual incoming channel - here it is used to probe
+c wether the process in question is isospin allowed or not
+c
+ clebweight=dbweight(isoit(ityp1),iso31,isoit(ityp2),iso32,
+ & isoit(itnew1),isoit(itnew2))
+ if(clebweight.lt.0.00001) then
+ dbfact=0.d0
+ return
+ endif
+
+
+c
+c b) determine momenta
+c
+ pnnout=pcms(sqrts,massit(itnew1),massit(itnew2))
+c
+c d) now calculate correction factor
+c
+
+c
+c call to dgcgkfct which calculates degeneracy factors and clebsches
+c
+ factor=dgcgkfct(ityp1,ityp2,iso31,iso32,itnew1,itnew2)
+
+
+ if(CTOption(3).eq.0) then
+
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c modified detailed balance
+c
+c reference: Danielewicz and Bertsch: Nuclear Physics A533(1991) 712.
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+
+c
+c count resonances in the incoming channel:
+c
+ inres=0
+ if(widit(ityp1).gt.minwid) inres=inres+1
+ if(widit(ityp2).gt.minwid) inres=inres+1
+
+c
+c count resonances in the outgoing channel:
+ outres=0
+ if(widit(itnew1).gt.minwid) outres=outres+1
+ if(widit(itnew2).gt.minwid) outres=outres+1
+
+ if(inres.eq.0) then
+c in this case detbal without resonances, original prescription
+ dbfact=factor*pnnout**2/(pnn**2)
+c
+cccccccccccccccccccccccccccccc
+ elseif(inres.eq.1) then
+c modified det-bal for one resonance
+c
+
+c now generate the correction factor
+ dbfact=factor*pnnout**2/
+ & pmean(sqrts,ityp1,iso31,ityp2,iso32,
+ & idum1,idum2,idum3,idum4,2)
+
+cccccccccccccccccccccccccc
+ else
+c modified det-bal for two resonances
+c reference: S.A. Bass, private calculation
+c
+ccccccccccccccccccccccccccccccccc
+ oq=0D0
+ if(outres.gt.0) then
+
+c here we have B* B* to B* N
+ oq=pmean(sqrts,itnew1,-99,itnew2,-99,
+ & idum1,idum2,idum3,idum4,2)
+
+ endif
+ccccccccccccccccccccccccccccccccc
+
+ q=pmean(sqrts,ityp1,iso31,ityp2,iso32,
+ & idum1,idum2,idum3,idum4,2)
+c
+c now generate the correction factor
+ if(outres.eq.0) then
+ dbfact=factor*pnnout**2/(max(1.d-12,q))
+ else
+ dbfact=factor*oq/(max(1.d-12,q))
+ endif
+ endif
+
+ return
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c original detailed balance
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ elseif(CTOption(3).eq.1) then
+ dbfact=factor*pnnout**2/(pnn**2)
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c error processing
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ else
+ write(6,*)'undefined detailed balance mode in DETBAL'
+ dbfact=1.
+ endif
+c
+ return
+ end
+
+
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+ real*8 function ppiso(pid,ityp1,iso31,ityp2,iso32,itnew1,itnew2)
+c
+c Revision : 1.0
+c
+cinput pid : ID of process
+cinput ityp1 : ityp of incoming particle 1
+cinput ityp2 : ityp of incoming particle 2
+cinput iso31 : 2*I3 of incoming particle 1
+cinput iso32 : 2*I3 of incoming particle 2
+cinput itnew1 : ityp of outgoing particle 1
+cinput itnew2 : ityp of outgoing particle 2
+c
+coutput nniso : isospin-factor for the reaction $p p \to B B$
+c
+c This subroutine calculates the isospin-factor for resonance
+c excitation in inelastic proton proton collisions.
+c
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+c
+ implicit none
+
+ real*8 dbweight,factor,dgcgkfct
+ integer isoit,pid,itag,iz1,iz2,i1,i2,im,jm,ityp1,ityp2
+ integer iso31,iso32,itnew1,itnew2,itmp1,itmp2
+
+ include 'comres.f'
+ include 'newpart.f'
+
+
+ i1=ityp1
+ i2=ityp2
+ iz1=iso31
+ iz2=iso32
+ im=itnew1
+ jm=itnew2
+
+ if(pid.gt.0) then
+ ppiso=dbweight(i1,iz1,i2,iz2,isoit(im),isoit(jm))/
+ / dbweight(1,1,1,1,isoit(im),isoit(jm))
+ else
+
+ factor=dgcgkfct(i1,i2,iz1,iz2,nucleon,nucleon)
+ if(factor.le.1.d-8) then
+ ppiso=0.d0
+ return
+ endif
+
+ nexit=2
+ itot(1)=isoit(nucleon)
+ itot(2)=isoit(nucleon)
+ call isocgk4(isoit(i1),iz1,isoit(i2),iz2,itot,i3new,itag)
+ itmp1=i3new(1)
+ itmp2=i3new(2)
+ ppiso=dbweight(nucleon,itmp1,nucleon,itmp2,
+ & isoit(im),isoit(jm))/
+ / dbweight(1,1,1,1,isoit(im),isoit(jm))
+ endif
+
+ return
+
+ end
+
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+ real*8 function dgcgkfct(ityp1,ityp2,iso31,iso32,itnew1,itnew2)
+c
+c Revision : 1.0
+c
+cinput ityp1 : ityp of incoming particle 1
+cinput ityp2 : ityp of incoming particle 2
+cinput iso31 : 2*I3 of incoming particle 1
+cinput iso32 : 2*I3 of incoming particle 2
+cinput itnew1 : ityp of outgoing particle 1
+cinput itnew2 : ityp of outgoing particle 2
+c
+coutput dgcgkfct : product of degeneracy and cgk factor for detailed bal.
+c
+c This subroutine calculates the product of the spin and isospin
+c degeneracy factors and the a isospin correction factor
+c (isospin dependence of cross section) for the detailed balance
+c cross section.
+c
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+c
+ implicit none
+
+ include 'comres.f'
+c
+
+ integer iso31,iso32
+ real*8 clebweight
+ integer ityp1, ityp2,stot(4),itnew1,itnew2
+c components of degeneracy factor
+ integer gin1,gin2,gout1,gout2
+ real*8 dgfact
+c called functions
+ real*8 dbweight
+ integer jit,isoit
+c
+c a) set up call to isocgk and getmass: determine outgoing isospins
+c and masses
+
+c
+c clebweight: reduction of given isospin_summed cross_section to actual
+c incoming channel
+c
+c 1) reduction:
+ clebweight=dbweight(isoit(ityp1),iso31,isoit(ityp2),iso32,
+ & isoit(itnew1),isoit(itnew2))
+ if(clebweight.lt.0.00001) then
+ dgcgkfct=0.d0
+ return
+ endif
+
+
+c c) calculate degeneracy factors
+c reference: S. Bass, GSI-Report 93-13 p. 25 and references therein
+c
+c get spins: in-channel stot(1 and 2), out-channel stot(3 and 4)
+ stot(1)=jit(ityp1)
+ stot(2)=jit(ityp2)
+ stot(3)=jit(itnew1)
+ stot(4)=jit(itnew2)
+c
+
+ gout1=(stot(3)+1)
+ gout2=(stot(4)+1)
+ gin1=(stot(1)+1)
+ gin2=(stot(2)+1)
+c
+c
+c the degeneracy factor is
+ dgfact=dble(gout1*gout2)/dble(gin1*gin2)
+c
+c d) now calculate correction factor
+c
+c
+ dgcgkfct=dgfact*clebweight
+c
+ return
+ end
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ real*8 function pmean(sqrts,itp1,iz1,itp2,iz2,
+ & itp3,iz3,itp4,iz4,ipwr)
+c
+c Revision : 1.0
+c
+cinput sqrts : $\sqrt{s}$
+cinput itp1 : ityp of particle 1
+cinput iz1 : $2 \cdot I_3$ of particle 1
+cinput itp2 : ityp of particle 2
+cinput iz2 : $2 \cdot I_3$ of particle 2
+cinput itp3 : ityp of particle 3
+cinput iz3 : $2 \cdot I_3$ of particle 3
+cinput itp4 : ityp of particle 4
+cinput iz4 : $2 \cdot I_3$ of particle 4
+cinput ipwr : power of $p_{mean}$ to integrate
+c
+c This function returns the value of the following integral:
+c \begin{displaymath}
+c \int\limits_{m_1= {\tt mmin}}^{\tt mmax}
+c p_{CMS}^{\tt ipwr}(\sqrt{s},m_1,m_2) A_1(m_1) A_2(m_2) \; dm_1 dm_2
+c \end{displaymath}
+c with $A_r(m)$ being the spectral function of the resonance:
+c \begin{displaymath}
+c A(m) = \displaystyle\frac{\Gamma(m)/2}{(m-m_0)^2+\Gamma(m)^2/4}
+c \end{displaymath}
+c
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ implicit none
+
+c include "comres.f"
+
+ real*8 sqrts,minwid,q1,q2
+ real*8 mmin1,mfix,mmin2,maxs1,maxs2,mepsilon,diverg1
+ real*8 smass
+ integer itp1,ipwr,iz1,itp2,iz2,itp3,iz3,itp4,iz4
+ integer inres,izz1,ind1,ind2
+
+cfunctions
+ real*8 detbalin,widit,massit,detbalin2,mminit,pcms
+c integer
+ external detbalin,detbalin2
+
+c minimal width for "unstable" particle
+ parameter( minwid=1.d-3 )
+c 0.1 MeV shift for integrator-maxvalue
+ parameter(mepsilon=0.0001)
+ctp060202 to avoid warnings with gfortran compilation
+ logical ctp060202
+ ctp060202=.false.
+ if(ctp060202)write(*,*)iz3,iz4
+ctp060202 end
+
+
+ if(sqrts.le.mminit(itp1)+mminit(itp2)) then
+ pmean=0.d0
+ return
+ endif
+
+c count broad particles and store number in inres
+c NOTE: only particles 1 and 2 may be broad!!!!
+c
+ inres=0
+ if(widit(itp1).gt.minwid) inres=inres+1
+ if(widit(itp2).gt.minwid) inres=inres+1
+
+ if(inres.eq.0) then
+c in this case the Breit-Wigner distributions are Delta functions,
+c no integrations necessary
+ smass=massit(itp2)
+ if(itp3.ne.0) smass=smass+massit(itp3)
+ if(itp4.ne.0) smass=smass+massit(itp4)
+
+ pmean=pcms(sqrts,massit(itp1),smass)**ipwr
+
+ return
+c
+cccccccccccccccccccccccccccccc
+ elseif(inres.eq.1) then
+c modified det-bal for one resonance
+c
+c first determine which particle is the resonance and store ityp in ind1
+ if(widit(itp1).gt.minwid) then
+ ind2=itp2
+ ind1=itp1
+ izz1=iz1
+ else
+ ind2=itp1
+ ind1=itp2
+ izz1=iz2
+ endif
+
+c now set integration boundaries
+ mmin1=mminit(ind1)
+ mfix=mminit(ind2)
+
+ if(itp3.ne.0) mfix=mfix+massit(itp3)
+ if(itp4.ne.0) mfix=mfix+massit(itp4)
+
+ maxs1=sqrts-mfix-mepsilon
+c the integration might be divided by the pole of the Breit-Wigner
+c then two integrations with diverg1 as upper or lower boundary
+c respectively are necessary
+ diverg1=massit(ind1)
+c
+c now perform integration in function detbalin
+c integrate f(m1)=pcms(sqrts,m1,m2)**ipwr*fbwnorm(m1,ityp1)
+ q1=0.d0
+ q2=0.d0
+ if(mmin1.le.diverg1) then
+ if(maxs1.gt.diverg1) then
+ call qsimp(detbalin,mmin1,diverg1,
+ & ind1,izz1,mfix,sqrts,ipwr,q1,-1)
+ call qsimp(detbalin,diverg1,maxs1,
+ & ind1,izz1,mfix,sqrts,ipwr,q2,1)
+ else
+ call qsimp(detbalin,mmin1,maxs1,
+ & ind1,izz1,mfix,sqrts,ipwr,q1,-1)
+ endif
+ else
+ call qsimp(detbalin,mmin1,maxs1,
+ & ind1,izz1,mfix,sqrts,ipwr,q2,1)
+ endif
+
+ pmean=(q1+q2)
+
+ return
+c
+cccccccccccccccccccccccccc
+ else
+c 2 resonances to integrate over
+c
+c
+ if(itp3.ne.0) then
+ write(6,*) 'ERROR in pmean: only one broad particle allowed'
+ write(6,*) ' in case of 3 or 4 body decays!!'
+ stop
+ endif
+
+
+c outer integration:
+c set integration boundaries
+ mmin1=mminit(itp1)
+ mmin2=mminit(itp2)
+ maxs2=sqrts-mmin1
+ diverg1=massit(itp2)
+ q1=0.d0
+ q2=0.d0
+ if(mmin2.le.diverg1) then
+ if(maxs2.gt.diverg1) then
+ call qsimp2(detbalin2,mmin2,diverg1,
+ & itp2,iz2,mmin1,itp1,iz1,ipwr,sqrts,q1,-1)
+ call qsimp2(detbalin2,diverg1,maxs2,
+ & itp2,iz2,mmin1,itp1,iz1,ipwr,sqrts,q1,1)
+ else
+ call qsimp2(detbalin2,mmin2,maxs2,
+ & itp2,iz2,mmin1,itp1,iz1,ipwr,sqrts,q1,-1)
+ endif
+ else
+ call qsimp2(detbalin2,mmin2,maxs2,
+ & itp2,iz2,mmin1,itp1,iz1,ipwr,sqrts,q1,1)
+ endif
+
+ pmean=(q1+q2)
+
+ return
+ endif
+
+
+ return
+ end
+
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+ real*8 function detbalin(m1,ityp1,iz1,m2,sqrts,ipwr)
+c
+c Revision : 1.0
+c
+cinput m1 : mass of resonance (integration variable)
+cinput ityp1 : ityp of Delta/N* resonance for fbwnorm()
+cinput iz1 : $2\cdot I_3$ of resonance
+cinput m2 : second mass for call to pcms
+cinput sqrts : sqrt(s)
+cinput ipwr : power for $p_mean$
+c
+c This function is an integrand for the modified detailed balance:
+c \begin{displaymath}
+c detbalin(m1)=\, p_{CMS}^{\tt ipwr}(\sqrt{s},m_1,m_2) A_1(m_1)
+c \end{displaymath}
+c with $A_r(M)$ being the spectral function of the resonance:
+c \begin{displaymath}
+c A(m) = \displaystyle\frac{\Gamma(m)/2}{(m-m_0)^2+\Gamma(m)^2/4}
+c \end{displaymath}
+c
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ implicit none
+c arguments
+ real*8 m1,m2,sqrts
+ integer ityp1,iz1,ipwr
+c called functions
+ real*8 fbwnorm,pcms
+
+ detbalin=pcms(sqrts,m1,m2)**ipwr*fbwnorm(m1,ityp1,iz1)
+
+ return
+ end
+
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+ real*8 function detbalin2(m2,ityp2,iz2,min1,
+ & ityp1,iz1,ipwr,sqrts)
+c
+c Revision : 1.0
+c
+c This function represents the integrand
+c \begin{displaymath}
+c detbalin2\,=\,A_2(m2)\;
+c \int \limits_{m_N + m_{\pi}}^{\sqrt{s} - m_2}
+c p_{rel}(\sqrt{s},m_1,m_2) A_1(m_1) \, d m_1
+c \end{displaymath}
+c for the modified detailed balance with two resonances in the
+c incoming channel.
+c $A_r(M)$ is the spectral function of the resonance (see {\tt detbalin}).
+c
+c
+cinput m2 : mass of resonance2 (outer integration in detbal)
+cinput ityp1 : ityp of resonance1
+cinput ityp2 : ityp of resonance2
+cinput min1 : lower boundary for integration via {\tt qsimp}
+ccinput max1 : upper boundary for integration via {\tt qsimp}
+cinput iz1 : $2\cdot I_3$ of resonance 1
+cinput iz2 : $2\cdot I_3$ of resonance 2
+cinput ipwr : power for $p_mean$
+cinput sqrts : $\sqrt{s}$
+c
+c output:
+c detbalin2 : value of function
+c
+c function and subroutine calls:
+c detbalin (referenced as external)
+c fbwnorm
+c qsimp
+c
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ implicit none
+ integer ityp1,ityp2,iz1,iz2,ipwr
+ real*8 m2,min1,max1,sqrts,q1,q2,diverg1,fbwnorm,mepsilon
+ real*8 massit
+ real*8 detbalin
+ external detbalin
+c 0.1 MeV shift for integrator-maxvalue
+ parameter(mepsilon=0.0001)
+
+ max1=sqrts-m2-mepsilon
+
+ diverg1=massit(ityp1)
+ q1=0.d0
+ q2=0.d0
+ if(min1.le.diverg1) then
+ if(max1.gt.diverg1) then
+ call qsimp(detbalin,min1,diverg1,
+ & ityp1,iz1,m2,sqrts,ipwr,q1,-1)
+ call qsimp(detbalin,diverg1,max1,
+ & ityp1,iz1,m2,sqrts,ipwr,q2,1)
+ else
+ call qsimp(detbalin,min1,max1,
+ & ityp1,iz1,m2,sqrts,ipwr,q1,-1)
+ endif
+ else
+ call qsimp(detbalin,min1,max1,
+ & ityp1,iz1,m2,sqrts,ipwr,q2,1)
+ endif
+
+ detbalin2=fbwnorm(m2,ityp2,iz2)*(q1+q2)
+
+ return
+ end
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ real*8 function fbwnorm(m,ires,iz1)
+c
+c Revision : 1.0
+c
+cinput m : mass of resonance
+cinput ires: ityp of resonance
+cinput iz1 : $2\cdot I_3$ of resonance
+c
+c {\tt fbwnorm} returns a Breit-Wigner distribution (non-relativistic)
+c which is normalized to 1 in the limit of mass-independent
+c decay widths. However this function uses mass-dependent decay
+c widths when available. The function only uses widths down to
+c a lower boundary of 1 MeV, smaller widths are automatically set
+c to 1 MeV. For {\tt iz=-99} fixed widths are used instead of
+c a call to {\tt fwidth}. You should use {\tt fbrwig} for standard purpose
+c since in case of mass dependent widths fbwnorm() is not very well
+c defined for widths smaller than 1 MeV.
+c
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+
+ implicit none
+
+ real*8 m,gam2,mres,fwidth,massit,widit,gam,minwid
+ integer ires,ires1,iz1
+ include 'comres.f'
+ include 'coms.f'
+ include 'comwid.f'
+
+c minimal width for "unstable" particle
+ parameter( minwid=1.d-3 )
+
+ ires1 = ires
+ mres = massit(ires1)
+ if(iz1.eq.-99.or.wtabflg.eq.0)then
+ gam = widit(ires1)
+ else
+ gam = fwidth(ires1,iz1,m)
+ end if
+c cutoff for small widths
+ gam=max(gam,minwid)
+ gam2=gam**2
+ fbwnorm = 0.5*gam/(pi*((m-mres)**2+gam2/4.0))!*norm
+ return
+ end
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+c here start the numerical receipies routines for numerical integration
+c no more physics beyond this point in the file!!!
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c(c) numerical receipies, adapted for f(x,idum,dum,dum)
+ SUBROUTINE qsimp(func,a,b,idum1,idum2,dum2,dum3,idum3,s,flag)
+c
+c Simpson integration via Numerical Receipies.
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ implicit none
+ include 'options.f'
+
+ INTEGER JMAX,j,idum1,idum2,idum3,flag
+ REAL*8 a,b,func,s,EPS
+ REAL*8 os,ost,st,dum2,dum3
+ EXTERNAL func
+ PARAMETER (JMAX=20)
+
+ if(b-a.le.1.d-4) then
+ s=0.d0
+ return
+ endif
+
+ EPS = 6.d-2
+ if (CTOption(35).eq.1) EPS=6.d-3
+
+ ost=-1.d30
+ os= -1.d30
+ do 11 j=1,JMAX
+ if(flag.eq.-1) then
+ call midsqu1(func,a,b,idum1,idum2,dum2,dum3,idum3,st,j)
+ elseif(flag.eq.1) then
+ call midsql1(func,a,b,idum1,idum2,dum2,dum3,idum3,st,j)
+ endif
+ s=(9.*st-ost)/8.
+ if (abs(s-os).le.EPS*abs(os)) return
+ os=s
+ ost=st
+11 continue
+ write(6,*) 'too many steps in qsimp, increase JMAX!'
+
+ return
+ END
+
+C (C) Copr. 1986-92 Numerical Recipes Software.
+
+
+
+ SUBROUTINE midsqu1(funk,aa,bb,idum1,idum2,dum2,dum3,idum3,s,n)
+c modified midpoint rule; allows singuarity at upper limit
+ implicit none
+ integer idum1,idum2,idum3
+ real*8 dum2,dum3
+ INTEGER n
+ REAL*8 aa,bb,s,funk
+ EXTERNAL funk
+ INTEGER it,j
+ REAL*8 ddel,del,sum,tnm,x,func,a,b,xx
+
+ func(x)=2.*x*funk(bb-x**2,idum1,idum2,dum2,dum3,idum3)
+
+ b=sqrt(bb-aa)
+ a=0.d0
+ if (n.eq.1) then
+ xx=0.5d0*(a+b)
+
+ s=(b-a)*func(0.5d0*(a+b))
+
+ else
+ it=3**(n-2)
+ tnm=it
+ del=(b-a)/(3.*tnm)
+ ddel=del+del
+ x=a+0.5*del
+ sum=0.
+ do 11 j=1,it
+ sum=sum+func(x)
+ x=x+ddel
+ sum=sum+func(x)
+ x=x+del
+11 continue
+ s=(s+(b-a)*sum/tnm)/3.
+ endif
+ return
+ END
+
+ SUBROUTINE midsql1(funk,aa,bb,idum1,idum2,dum2,dum3,idum3,s,n)
+c modified midpoint rule; allows singularity at lower limit
+ implicit none
+ integer idum1,idum2,idum3
+ real*8 dum2,dum3
+ INTEGER n
+ REAL*8 aa,bb,s,funk
+ EXTERNAL funk
+ INTEGER it,j
+ REAL*8 ddel,del,sum,tnm,x,func,a,b
+ func(x)=2.*x*funk(aa+x**2,idum1,idum2,dum2,dum3,idum3)
+ b=sqrt(bb-aa)
+ a=0.
+ if (n.eq.1) then
+ s=(b-a)*func(0.5*(a+b))
+ else
+ it=3**(n-2)
+ tnm=it
+ del=(b-a)/(3.*tnm)
+ ddel=del+del
+ x=a+0.5*del
+ sum=0.
+ do 11 j=1,it
+ sum=sum+func(x)
+ x=x+ddel
+ sum=sum+func(x)
+ x=x+del
+11 continue
+ s=(s+(b-a)*sum/tnm)/3.
+ endif
+ return
+ END
+
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c(c) numerical receipies, adapted for f(x,idum,dum,dum)
+ SUBROUTINE qsimp2(func,a,b,idum1,idum2,dum1,idum3,idum4,
+ & idum5,dum2,s,flag)
+c
+c Simpson integration via Numerical Receipies.
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ implicit none
+
+ include 'options.f'
+
+ INTEGER JMAX,j,idum1,idum2,idum3,idum4,idum5,flag
+ REAL*8 a,b,s,EPS
+ REAL*8 os,ost,st,dum1,dum2
+ REAL*8 func
+ PARAMETER (JMAX=10)
+ external func
+
+ if(b-a.le.1.d-4) then
+ s=0.d0
+ return
+ endif
+
+ EPS = 6.d-2
+ if (CTOption(35).eq.1) EPS=6.d-3
+
+ ost=-1.d30
+ os= -1.d30
+ do 11 j=1,JMAX
+ if(flag.eq.-1) then
+ call midsqu2(func,a,b,idum1,idum2,dum1,idum3,idum4,
+ & idum5,dum2,st,j)
+ elseif(flag.eq.1) then
+ call midsql2(func,a,b,idum1,idum2,dum1,idum3,idum4,
+ & idum5,dum2,st,j)
+ endif
+ s=(9.*st-ost)/8.
+
+ if (abs(s-os).le.EPS*abs(os)) return
+ os=s
+ ost=st
+11 continue
+
+ write(6,*) 'too many steps in qsimp2, increase JMAX!'
+
+ return
+ END
+
+
+ SUBROUTINE midsqu2(funk,aa,bb,idum1,idum2,dum1,idum3,idum4,
+ & idum5,dum2,s,n)
+c modified midpoint rule; allows singuarity at upper limit
+ implicit none
+ integer idum1,idum2,idum3,idum4,idum5
+ real*8 dum1,dum2
+ INTEGER n
+ REAL*8 aa,bb,s,funk
+ EXTERNAL funk
+ INTEGER it,j
+ REAL*8 ddel,del,sum,tnm,x,func,a,b
+ func(x)=2.*x*funk(bb-x**2,
+ & idum1,idum2,dum1,idum3,idum4,idum5,dum2)
+ b=sqrt(bb-aa)
+ a=0.
+ if (n.eq.1) then
+ s=(b-a)*func(0.5*(a+b))
+ else
+ it=3**(n-2)
+ tnm=it
+ del=(b-a)/(3.*tnm)
+ ddel=del+del
+ x=a+0.5*del
+ sum=0.
+ do 11 j=1,it
+ sum=sum+func(x)
+ x=x+ddel
+ sum=sum+func(x)
+ x=x+del
+11 continue
+ s=(s+(b-a)*sum/tnm)/3.
+ endif
+ return
+ END
+
+ SUBROUTINE midsql2(funk,aa,bb,idum1,idum2,dum1,idum3,idum4,
+ & idum5,dum2,s,n)
+c modified midpoint rule; allows singularity at lower limit
+ implicit none
+ integer idum1,idum2,idum3,idum4,idum5
+ real*8 dum1,dum2
+ INTEGER n
+ REAL*8 aa,bb,s,funk
+ EXTERNAL funk
+ INTEGER it,j
+ REAL*8 ddel,del,sum,tnm,x,func,a,b
+ func(x)=2.*x*funk(aa+x**2,
+ & idum1,idum2,dum1,idum3,idum4,idum5,dum2)
+ b=sqrt(bb-aa)
+ a=0.
+ if (n.eq.1) then
+ s=(b-a)*func(0.5*(a+b))
+ else
+ it=3**(n-2)
+ tnm=it
+ del=(b-a)/(3.*tnm)
+ ddel=del+del
+ x=a+0.5*del
+ sum=0.
+ do 11 j=1,it
+ sum=sum+func(x)
+ x=x+ddel
+ sum=sum+func(x)
+ x=x+del
+11 continue
+ s=(s+(b-a)*sum/tnm)/3.
+ endif
+ return
+ END
diff --git a/Processes/UrQMD/dwidth.f b/Processes/UrQMD/dwidth.f
new file mode 100644
index 0000000000000000000000000000000000000000..f1debcd42fe6c0618fa8ac02a9ed594dbc5ab35a
--- /dev/null
+++ b/Processes/UrQMD/dwidth.f
@@ -0,0 +1,326 @@
+c $Id: dwidth.f,v 1.10 2001/04/06 22:08:24 weber Exp $
+C####C##1#########2#########3#########4#########5#########6#########7##
+ real*8 function mmean (io,m0,g,mmin,mmax)
+c
+cinput io : flag (see bleow)
+cinput m0 : pole mass
+cinput g : nominal width
+cinput mmin : minimal mass
+cinput mmax : maximal mass
+c
+c io=0 : Yields average mass between {\rm mmin} and {\rm mmax}
+c according to a Breit-Wigner function with constant width {\rm g}
+c and pole {\rm m0}.\\
+c io=1 : Chooses a mass randomly between {\rm mmin} and {\rm mmax}
+c according to a Breit-Wigner function with constant
+c width {\rm g} and pole {\rm m0}.\\
+c else: Integral of a Breit-Wigner function from {\rm mmin} to {\rm mmax}.
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ implicit none
+
+ real*8 m0,g,mmin,mmax,x,i0,i1,inv,fmin,fmax,ranf,f,gcut
+ parameter(gcut=1d-10)
+ integer io
+ logical errchk
+ parameter (errchk=.true.)
+
+ i0(x) =2.*g*atan( 2.* (x-m0)/ g )
+ i1(x) =.5*g**2*log( (x-m0)**2+g**2/4. ) + m0*i0(x)
+ inv(x)=.5*g*tan( 0.5*x/g )+m0
+
+
+c...check for some error conditions
+ if(errchk)then
+ if(mmin.gt.mmax)
+ . write(6,*)'mmean: mass range negative (mmin>mmax)'
+ . ,mmin,mmax
+ if(g.le.gcut.and.(m0.gt.mmax.or.m0.lt.mmin))
+ . write(6,*)'mmean: narrow particle out of mass range'
+ end if
+
+ if(io.eq.0)then
+ if(g.le.gcut)then
+ mmean=0d0
+ if(mmin.le.m0.and.m0.le.mmax)mmean=1d0
+ else
+ mmean=(i1(mmax)-i1(mmin))/(i0(mmax)-i0(mmin))
+ end if
+ else if(io.eq.1)then
+c... determin a mass in a given interval
+ if(g.le.gcut)then
+ mmean=max(mmin,min(mmax,m0))
+ else
+ fmin=i0(mmin)
+ fmax=i0(mmax)
+ f=fmin+(fmax-fmin)*ranf(0)
+ mmean=inv(f)
+ end if
+ else
+ mmean=i0(mmax)-i0(mmin) !this might not work for narrow part.
+ end if
+ return
+ end
+
+
+C####C##1#########2#########3#########4#########5#########6#########7##
+ subroutine getmas(m0,g0,i,iz,mmin,mmax,mrest,m)
+c
+cinput m0 : pole mass of resonance
+cinput g0 : nominal width of resonance
+cinput i : resonance ID
+cinput iz : iso3 of resonance
+cinput mmin : minimal mass
+cinput mmax : maximal mass
+coutput m : actual mass of the resonance
+c
+c {\tt getmas} (not $\rightarrow$ {\tt getmass}) first chooses the
+c mass {\tt m} of resonance {\tt i} between {\tt mmin} and {\tt mmax}
+c by a call of {\tt mmean}. Since {\tt mmean} only handles Breit-Wigners
+c with constant widths it follows
+c a correction such that {\tt m} is distributed according to mass
+c dependent widths (corresponding to {\tt fbrwig(...,m,1)}).
+c
+C####C##1#########2#########3#########4#########5#########6#########7##
+ implicit none
+ include 'options.f'
+ include 'comres.f'
+ integer i,iz,nrej, nrejmax
+ real*8 m,m0,g0,mmin,mmax,x,x0,gg,f,g,h,pi,al,alpha,ce,mmax2
+ real*8 phi,k,k0,mrest
+c...functions
+ real*8 ranf,mmean,fbrwig,bwnorm,pcms
+ parameter(pi=3.1415926535d0)
+ parameter(alpha=3d0, ce=2d0, nrejmax=5000)
+
+c 'broadened' Breit-Wigner function with h(x0,al)=h(x0,1)
+c normalised to alpha
+ h(x,x0,gg,al)=al*0.5/pi*(al*gg)/((x-x0)**2+0.25*(al*gg)**2)
+
+c cut-off for maximum resonance mass
+ mmax2=min(mresmax,mmax)
+
+
+ if(g0.lt.1d-4.or.CTOption(1).ne.0.or.CTOption(32).ne.0)then
+ m=mmean(1,m0,g0,mmin,mmax2)
+ return
+ else
+ nrej=0
+
+c This is a Monte Carlo rejection method, where the invertable
+c BW-distribution with constant widths is used to limit the BW-distribution
+c with mass-dep. widths whose inverse is not known analytically.
+
+108 continue
+ m=mmean(1,m0,alpha*g0,mmin,mmax2)
+ if(m.gt.(mmax2+1d-8).or.m.lt.(mmin-1d-8))then
+ write(*,*)'getmas (W): m outside (mmin,mmax2)',m,mmin,mmax2
+ write(*,*)'called as getmas(',m0,g0,i,mmin,mmax,')'
+ write(*,*)'Program stopped'
+ stop
+ endif
+cdh if ((CTOption(25).eq.1).and.(mrest.gt.0.0)) then
+ if ((CTOption(25).eq.1).and.(mrest.gt.0.d0)) then
+ k=pcms(mmax2+mrest,mrest,m)
+ k0=pcms(mmax2+mrest,mrest,mmin)
+ phi = m*k / (mmin*k0)
+ else
+ phi = 1.0
+ endif
+
+c Breit-Wigner with mass dependent widths and phase space correction
+
+ f=fbrwig(i,iz,m,1)*phi/bwnorm(i)
+ g=ce*h(m,m0,g0,alpha)
+
+ if(g.lt.f)then
+ write(*,*)'(W) getmas: C h(m) not limiting at m=',m
+ write(*,*)'->mass distribution of ',i,'might be corrupt'
+ endif
+ nrej=nrej+1
+ if (nrej.le.nrejmax.and.(ranf(0)*g).gt.f) goto 108
+ if (nrej.gt.nrejmax) then
+ write(*,*)'(W) getmas_space: too many rejections, m= ',m
+ write(*,*)'called with (',m0,g0,i,mmin,mmax,mrest,')'
+ write(*,*)'->mass distribution of ',i,' might be corrupt'
+ m=mmean(1,m0,alpha*g0,mmin,mmax2)
+ endif
+
+ endif
+
+ return
+ end
+
+C####C##1#########2#########3#########4#########5#########6#########7##
+ real*8 function bwnorm(ires)
+c
+cinput ires : itype of resonance
+c
+c This function calculates the integral of {\tt fbrwig}
+c between parameters {\tt mmin}(= 0~GeV) and {\tt mmax}(= 30~GeV) by
+c calling {\tt qsimp3} resp. by table lookup. It's value shall
+c serve as the norm of the Breit-Wigner function of particle {\tt ires}
+c with mass dependent width.
+c
+C####C##1#########2#########3#########4#########5#########6#########7##
+
+ implicit none
+ include 'comres.f'
+ include 'comwid.f'
+ include 'options.f'
+ integer ires,iz,isoit,it
+ real*8 mmin,mmax,pole,norm1,norm2
+ real*8 widit,massit
+ parameter(mmin=0d0,mmax=50d0)
+ real*8 fbrwig
+ external fbrwig
+
+ if((CTOption(36).ne.0.or.CTOption(1).ne.0).and.wtabflg.gt.1)then
+ bwnorm=1d0
+ return
+ endif
+
+ it=iabs(ires)
+
+ if (wtabflg.ge.2.and.CTOption(33).eq.0) then
+c table lookup
+ if (it.ge.minbar.and.it.le.maxbar) then
+ bwnorm=bwbarnorm(it)
+ else if (it.ge.minmes.and.it.le.maxmes) then
+ bwnorm=bwmesnorm(it)
+ else
+ write (6,*) '*** error(bwnorm) wrong id:',it
+ bwnorm=1d0
+ endif
+ else
+c calculate
+ if (widit(it).gt.1d-3)then
+
+ pole=massit(it)
+c arbitrary value of iz
+ iz=isoit(it)
+
+c the integration is divided by the pole of the Breit-Wigner -
+c thus two integrations with pole as upper or lower boundary
+c respectively are necessary
+
+ call qsimp3(fbrwig,mmin,pole,it,iz,norm1,-1)
+ call qsimp3(fbrwig,pole,mmax,it,iz,norm2,+1)
+ bwnorm=norm1+norm2
+ else
+ bwnorm=1d0
+ endif
+ endif
+
+ return
+ end
+
+
+c no physics after these routines!
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c(c) numerical receipies, adapted for f(idum1,idum2,x)
+ SUBROUTINE qsimp3(func,a,b,idum1,idum2,s,flag)
+c
+c Simpson integration via Numerical Receipies.
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ implicit none
+
+ include 'options.f'
+
+ INTEGER JMAX,j,idum1,idum2,flag
+ REAL*8 a,b,func,s,EPS
+ REAL*8 os,ost,st
+ PARAMETER (JMAX=100)
+ external func
+ if(b-a.le.1.d-4) then
+ s=0.d0
+ return
+ endif
+
+ EPS = 5d-3
+ if (CTOption(35).eq.1) EPS=5d-4
+
+ ost=-1.d30
+ os= -1.d30
+ do 11 j=1,JMAX
+ if(flag.eq.-1) then
+ call midsqu3(func,a,b,idum1,idum2,st,j)
+ elseif(flag.eq.1) then
+ call midsql3(func,a,b,idum1,idum2,st,j)
+ endif
+ s=(9.*st-ost)/8.
+
+ if (abs(s-os).le.EPS*abs(os)) return
+ os=s
+ ost=st
+11 continue
+
+ write(6,*) 'too many steps in qsimp3, increase JMAX!'
+
+ return
+ END
+
+
+ SUBROUTINE midsqu3(funk,aa,bb,idum1,idum2,s,n)
+c modified midpoint rule; allows singuarity at upper limit
+ implicit none
+ integer idum1,idum2
+ INTEGER n
+ REAL*8 aa,bb,s,funk
+ EXTERNAL funk
+ INTEGER it,j
+ REAL*8 ddel,del,sum,tnm,x,func,a,b
+ func(x)=2.*x*funk(idum1,idum2,bb-x**2,1)
+ b=sqrt(bb-aa)
+ a=0.
+ if (n.eq.1) then
+ s=(b-a)*func(0.5*(a+b))
+ else
+ it=3**(n-2)
+ tnm=it
+ del=(b-a)/(3.*tnm)
+ ddel=del+del
+ x=a+0.5*del
+ sum=0.
+ do 11 j=1,it
+ sum=sum+func(x)
+ x=x+ddel
+ sum=sum+func(x)
+ x=x+del
+11 continue
+ s=(s+(b-a)*sum/tnm)/3.
+ endif
+ return
+ END
+
+ SUBROUTINE midsql3(funk,aa,bb,idum1,idum2,s,n)
+c modified midpoint rule; allows singularity at lower limit
+ implicit none
+ integer idum1,idum2
+ INTEGER n
+ REAL*8 aa,bb,s,funk
+ EXTERNAL funk
+ INTEGER it,j
+ REAL*8 ddel,del,sum,tnm,x,func,a,b
+ func(x)=2.*x*funk(idum1,idum2,aa+x**2,1)
+ b=sqrt(bb-aa)
+ a=0.
+ if (n.eq.1) then
+ s=(b-a)*func(0.5*(a+b))
+ else
+ it=3**(n-2)
+ tnm=it
+ del=(b-a)/(3.*tnm)
+ ddel=del+del
+ x=a+0.5*del
+ sum=0.
+ do 11 j=1,it
+ sum=sum+func(x)
+ x=x+ddel
+ sum=sum+func(x)
+ x=x+del
+11 continue
+ s=(s+(b-a)*sum/tnm)/3.
+ endif
+ return
+ END
diff --git a/Processes/UrQMD/error.f b/Processes/UrQMD/error.f
new file mode 100644
index 0000000000000000000000000000000000000000..694f15fc22a7c3ea8de7028d5cf708149dcf9750
--- /dev/null
+++ b/Processes/UrQMD/error.f
@@ -0,0 +1,47 @@
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ subroutine error (function_name, message, value, level)
+c
+c Revision : 1.0
+c
+c output of errors and warnings
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+ implicit none
+
+ character function_name*(*)
+ character message*(*)
+ real*8 value
+ integer level
+
+ include 'inputs.f'
+
+ integer errdev
+
+ errdev=6
+
+ if ((level.lt.1).or.(level.gt.3)) then
+ write (errdev,*) '*** Error in Subroutine error:'
+ write (errdev,*) '*** Message: Wrong Errorlevel'
+ write (errdev,*) '*** Related Value: ', level
+ endif
+
+ if (level.eq.1) then
+ write (errdev,*) '*** Warning in Subroutine ',function_name,':'
+ elseif (level.eq.2) then
+ write (errdev,*) '*** Error in Subroutine ',function_name,':'
+ else
+ write (errdev,*) '*** Fatal Error in Subroutine ',
+ $ function_name,':'
+ endif
+ write (errdev,*) '*** Message: ',message
+ write (errdev,*) '*** Related Value: ',value
+
+ if (level.ge.3) then
+ write (errdev,*)
+ write (errdev,*) '*** Program stopped.'
+ stop
+ endif
+
+ return
+ end
diff --git a/Processes/UrQMD/freezeout.f b/Processes/UrQMD/freezeout.f
new file mode 100644
index 0000000000000000000000000000000000000000..f40e492055fe190e665c0aad160e955029abd7ec
--- /dev/null
+++ b/Processes/UrQMD/freezeout.f
@@ -0,0 +1,13 @@
+c $Id: freezeout.f,v 1.4 1999/01/18 09:57:01 ernst Exp $
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+c freezeout common block for uQMD
+c
+c Revision : 1.0
+c
+c
+
+ real*8 frr0(nmax), frrx(nmax), frry(nmax), frrz(nmax),
+ + frp0(nmax), frpx(nmax), frpy(nmax), frpz(nmax)
+
+ common /frcoor/ frr0, frrx, frry, frrz, frp0, frpx, frpy, frpz
diff --git a/Processes/UrQMD/getmass.f b/Processes/UrQMD/getmass.f
new file mode 100644
index 0000000000000000000000000000000000000000..85d92d97e0fda06d9f53627612dd13a6c350995d
--- /dev/null
+++ b/Processes/UrQMD/getmass.f
@@ -0,0 +1,113 @@
+c $Id: getmass.f,v 1.9 1999/01/18 09:57:02 ernst Exp $
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ real*8 function getmass(ssqrt,type)
+c
+c Revision : 1.0
+c
+cinput ssqrt : maximum energy available
+cinput type : class of resonance defined in getrange
+coutput getmass: mass of the resonance
+c
+C DETERMINES MASS OF A non-strange baryon RESONANCE.
+c
+c function calls: massdist ranf
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+ implicit none
+ real*8 ssqrt,mdice,mm,mmax
+ integer type
+ real*8 ranf
+ include 'comnorm.f'
+ include 'comres.f'
+
+c... only n*,d,d* included in n_splint
+
+ mmax=min(mresmax,ssqrt)
+
+c get probability mdice
+ call n_splint(x_norm,y_norm,y2a,n,mmax,mdice,type)
+ if(mdice.eq.0)write(6,*)'getmass:mdice=',mdice
+c for this probability choose mass mm
+ call n_splint(y_norm,x_norm,y2b,n,mdice*ranf(0),mm,type)
+
+ if(mm.lt.mresmin) then
+ write(6,*)'(W) getmass-error - m, mmin',mm,mresmin
+ mm=mresmin
+ else if(mm.gt.mresmax) then
+ write(6,*)'(W) getmass-error - m, ,max',mm,mresmax
+ mm=mresmax
+ endif
+
+ getmass=mm
+
+ return
+ end
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ subroutine norm_init
+c
+coutput : via common-block comnorm
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ implicit none
+ include 'comres.f'
+ include 'comnorm.f'
+ real*8 massdist
+ real*8 x(n),y(n),y21(n),y22(n)
+ integer i,j
+c linear weighting restored
+c in comnorm.f n is set to 400 again
+ dx = (mresmax-mresmin)/dble(n-1) ! (n-1)**2 for quad. weight
+ do 1 i=0,3
+ y_norm(i,1) = 0.0
+ y(1) = 0.0
+ x_norm(i,1) = mresmin
+ x(1) = mresmin
+ do 2 j=2,n
+ x_norm(i,j) = mresmin+dble(j-1)*dx ! (j-1)**2 for quad. weight
+ x(j) = x_norm(i,j)
+ y(j) = y(j-1) + (x(j)-x(j-1)) ! valid for both weights
+ & *(massdist(x(j-1),i)+massdist(x(j),i)
+ & + 4.0*massdist(0.5*(x(j)+x(j-1)),i))/6.0
+ y_norm(i,j) = y(j)
+2 continue
+ call spline(x,y,n,massdist(mresmin,i),
+ & massdist(mresmax,i),y21)
+ call spline(y,x,n,1.0/massdist(mresmin,i),
+ & 1.0/massdist(mresmax,i),y22)
+ do 3 j=1,n
+ y2a(i,j) = y21(j)
+ y2b(i,j) = y22(j)
+3 continue
+1 continue
+ return
+ end
+
+c Numerical recipies:
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c (modified)
+ SUBROUTINE n_splint(xa,ya,y2a,n,x,y,m)
+ implicit none
+ INTEGER n,m
+ real*8 x,y,xa(0:3,n),y2a(0:3,n),ya(0:3,n)
+ INTEGER k,khi,klo
+ real*8 a,b,h
+ klo=1
+ khi=n
+1 if (khi-klo.gt.1) then
+ k=(khi+klo)/2
+ if(xa(m,k).gt.x)then
+ khi=k
+ else
+ klo=k
+ endif
+ goto 1
+ endif
+ h=xa(m,khi)-xa(m,klo)
+ if (h.eq.0.)pause 'bad xa input in splint'
+ a=(xa(m,khi)-x)/h
+ b=(x-xa(m,klo))/h
+ y=a*ya(m,klo)+b*ya(m,khi)+((a**3-a)*y2a(m,klo)+
+ * (b**3-b)*y2a(m,khi))*(h**2)/6.
+ return
+ END
+C (C) Copr. 1986-92 Numerical Recipes Software.
diff --git a/Processes/UrQMD/getspin.f b/Processes/UrQMD/getspin.f
new file mode 100644
index 0000000000000000000000000000000000000000..7b34e1ec1a91b5d48bbe1629f1831c683a1dbe95
--- /dev/null
+++ b/Processes/UrQMD/getspin.f
@@ -0,0 +1,48 @@
+c $Id: getspin.f,v 1.3 1999/01/18 09:57:03 ernst Exp $
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+ integer function getspin(iityp,itag)
+c
+c Revision : 1.0
+c
+cinput ityp : ID of particle
+cinput itag : flag for return value
+c
+c output: $2*J_{tot}$ of particle
+c
+c This subroutine converts global ityp to maximum spin and optionally
+c chooses a random projection ({\tt itag=-1}).
+c
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+c
+ implicit none
+ include 'comres.f'
+c
+ integer ityp,iityp,jtot,itag
+ real*8 ranf
+c
+ ityp=abs(iityp)
+
+ jtot=0
+ if(ityp.ge.nucleon.and.ityp.le.maxbar) then
+ jtot=Jres(ityp)
+ elseif(ityp.ge.offmeson.and.ityp.le.maxmeson) then
+ jtot=Jmes(ityp)
+ else
+ write(6,*)'undefined total isospin in getspin:'
+ write(6,*)'ityp: ',ityp
+ stop
+ endif
+c
+ getspin=0
+ if(itag.eq.1) then
+ getspin=jtot
+ elseif(itag.eq.-1) then
+ getspin=jtot-2*int(ranf(0)*(jtot+1))
+ else
+ write(6,*)'itag-error in getspin.f'
+ stop
+ endif
+
+ return
+ end
diff --git a/Processes/UrQMD/init.f b/Processes/UrQMD/init.f
new file mode 100644
index 0000000000000000000000000000000000000000..d934f7f74aae1a87bbdaa76a9e75c0a99e55b371
--- /dev/null
+++ b/Processes/UrQMD/init.f
@@ -0,0 +1,550 @@
+c $Id: init.f,v 1.20 2002/05/14 12:33:50 balazs Exp $
+C####C##1#########2#########3#########4#########5#########6#########7##
+ subroutine init
+c
+c Revision : 1.0
+c This subroutine calls initialization procedures for different
+c equations of state and calculation modi.
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+ implicit none
+ include 'coms.f'
+ include 'options.f'
+ include 'comres.f'
+ include 'inputs.f'
+ include 'freezeout.f'
+ include 'newpart.f'
+ include 'boxinc.f'
+ include 'colltab.f'
+
+ integer j,k,icount,npold,getspin,fchg,indsp(2),isrt,ipbm
+ real*8 nucrad,dstt,dstp,pcm,eb,embeam,emtarget
+ real*8 massit,ranf,pcms,dectim
+ real*8 gaeq,beeq,galab,belab,ppeq,pteq
+ real*8 pboost
+ real*8 ratio
+ integer AAp, AAt
+ integer nnuc
+ parameter (nnuc=11)
+ save isrt,ipbm
+ logical bcorr
+ common /ini/ bcorr
+
+ integer i,flagy
+ real*8 alf,regula
+c momenta
+ real*8 mx,my,mz
+c important: never change!
+ npart = 0
+ npold = 0
+ nbar=0
+ nmes=0
+ apt=0
+ uid_cnt=0
+c reset counters
+c all collisions/decays
+ ctag = 0
+c all decays
+ dectag = 0
+c number of prod. hard resonances
+ NHardRes=0
+c number of prod. soft resonances
+ NSoftRes=0
+c number of prod. resonances via decay
+ NDecRes=0
+c number of blocked collisions
+ NBlColl=0
+c number of elastic collisions
+ NElColl=0
+c number of strings
+ strcount=1
+c
+ nspec = 0 !hjd
+c
+ eb=0D0
+c icount is the number of EXTRAordinary pro/tar combinations (i.e. pion ...)
+ icount = 0
+c reset particle vectors
+ do 20 j=1,nmax
+ spin(j) = 0
+ ncoll(j) = 0
+ lstcoll(j)=0
+ r0(j) = 0.0
+ rx(j) = 0.0
+ ry(j) = 0.0
+ rz(j) = 0.0
+ p0(j) = 0.0
+ px(j) = 0.0
+ py(j) = 0.0
+ pz(j) = 0.0
+ frr0(j) = 0.0
+ frrx(j) = 0.0
+ frry(j) = 0.0
+ frrz(j) = 0.0
+ frp0(j) = 0.0
+ frpx(j) = 0.0
+ frpy(j) = 0.0
+ frpz(j) = 0.0
+ fmass(j) = 0.0
+ charge(j)= 0
+ iso3(j) = 0
+ ityp(j) = 0
+ dectime(j)= 0.0
+ origin(j)=0
+ tform(j)=0.0
+ xtotfac(j)=1.0
+ strid(j)=0
+ uid(j)=0
+ ffermpx(j) = 0.0
+ ffermpy(j) = 0.0
+ ffermpz(j) = 0.0
+ctd
+ do 21 k=1,2
+ p0td(k,j)=0.d0
+ pxtd(k,j)=0.d0
+ pytd(k,j)=0.d0
+ pztd(k,j)=0.d0
+ fmasstd(k,j)=0.d0
+ ityptd(k,j)=0
+ iso3td(k,j)=0
+ 21 continue
+ 20 continue
+
+
+ if(CTOption(40).eq.1) then
+ call getoldevent
+ return
+ endif
+
+
+ if (boxflag.eq.1) then
+ mbpx=0
+ mbpy=0
+ mbpz=0
+ mx=0
+ my=0
+ mz=0
+
+ nbar=0
+ nmes=0
+ flagy=edensflag
+ ctoption(30)=0 ! no frozen fermi for box
+ do 100 cbox=1,mbox
+ if (flagy.ge.1) then
+ bptpmax(cbox)=edens/mbox
+ endif
+ call bptinit(cbox)
+ 100 Continue
+
+c prevents a collective motion in the box
+ do 143 i=1,npart
+ mbpx=mbpx+px(i)
+ mbpy=mbpy+py(i)
+ mbpz=mbpz+pz(i)
+ 143 continue
+ do 142 i=1,npart
+ px(i)=px(i)-mbpx/npart
+ py(i)=py(i)-mbpy/npart
+ pz(i)=pz(i)-mbpz/npart
+ call setonshell(i)
+ 142 continue
+
+ if (flagy.ge.1) then
+ alf=Regula(edens)
+ do 42 i=1,npart
+ px(i) = alf*px(i)
+ py(i) = alf*py(i)
+ pz(i) = alf*pz(i)
+ call setonshell(i)
+ 42 continue
+ endif
+ Write(*,*) 'walls selected'
+ mbflag=2
+ if (solid.gt.0) Write(*,*)'solid walls selected'
+
+ Return
+ EndIf
+
+ if(At.ne.0) then
+ if (CTParam(21).eq.0.0) then
+ dstp = nucrad(Ap)+CTParam(41)
+ dstt = nucrad(At)+CTParam(41)
+ else
+ ratio = sqrt((1 + 4.0*CTParam(21)/3.0) /
+ $ (1 - 2.0*CTParam(21)/3.0) )
+ dstp = nucrad(Ap)*ratio**(2.0/3.0)+CTParam(41)
+ dstt = nucrad(At)*ratio**(2.0/3.0)+CTParam(41)
+ endif
+c add radius offset
+ dstp=dstp+CTParam(30)
+ dstt=dstt+CTParam(30)
+c
+c dst=0.5d0*(dstt+dstp)
+ else
+c dst=0.d0
+ dstp=0d0
+ dstt=0d0
+ endif
+
+ce For anti nuclei:
+ AAp = abs(Ap)
+ AAt = abs(At)
+
+c
+c fix masses of projectile and target for calculation of pbeam,ecm,pcm
+ if(prspflg.eq.0) then
+ embeam=AAp*EMNUC
+ elseif(prspflg.eq.1) then
+ icount=icount+1
+c!!! sofar only pro/tar with fixed masses allowed
+ embeam=massit(spityp(1))
+ endif
+ if(trspflg.eq.0) then
+ emtarget=AAt*EMNUC
+ elseif(trspflg.eq.1) then
+ icount=icount+1
+ emtarget=massit(spityp(2))
+ endif
+c
+c p(equal_speed) with given elab cccccccccccccccccccccccccccccccccccccc
+
+ if(srtflag.eq.0) then
+
+ ebeam=AAp*ebeam
+ eb=ebeam+embeam
+ pbeam=sqrt(ebeam*(ebeam+2.0d0*embeam))
+
+c p(equal_speed) with given sqrt(s) ccccccccccccccccccccccccccccccccccccc
+
+ elseif(srtflag.eq.1) then
+
+c in this mode, everything has to calculated on a per particle basis
+ embeam=embeam/dble(AAp)
+ emtarget=emtarget/dble(AAt)
+
+ if(emtarget+embeam.gt.srtmin)then
+ srtmin=emtarget+embeam+1d-2
+ write(6,*)' *** error:initial energy below treshold'
+ write(6,*)' c.m. energy will be increased to:',
+ & srtmin
+ srtmax=max(srtmax,srtmin)
+ end if
+ if(efuncflag.eq.0) then
+ ecm=srtmin
+ else ! if(efuncflag.eq.1) then
+c excitation function
+ if(mod((event-1)*nsrt,nevents).eq.0
+ & .and.firstev.gt.0)then
+ if(efuncflag.eq.1)then
+ ecm=ecm+(srtmax-srtmin)/dble(nsrt-1)
+ else if(efuncflag.eq.2)then
+ isrt=isrt+1
+ ecm=srtmin*exp(
+ & (dlog(srtmax/srtmin))
+ & *isrt/(nsrt-1))
+ end if
+ elseif(firstev.eq.0) then
+ isrt=0
+ firstev=1
+ ecm=srtmin
+ endif
+ endif
+c
+c this is all on a per particle basis
+ pcm=pcms(ecm,embeam,emtarget)
+ ebeam=sqrt(embeam**2 + (pcm*ecm/emtarget)**2) - embeam
+ pbeam=pcm*ecm/emtarget
+c now revert to full quantities
+ ebeam=AAp*ebeam
+ pbeam=AAp*pbeam
+ embeam=embeam*AAp
+ emtarget=emtarget*AAt
+ eb=sqrt(embeam**2+pbeam**2)
+
+
+
+c p(equal_speed) with given plab ccccccccccccccccccccccccccccccccccc
+ elseif(srtflag.eq.2) then
+ if(efuncflag.gt.0) then
+c excitation function
+c calculate the next pbeam if number of events at current pbeam exceeds nevents/npb
+ if (mod((event-1)*npb,nevents).eq.0
+ & .and.firstev.gt.0) then
+c excitation function linear in pbeam
+ if (efuncflag.eq.1) then
+ pbeam=pbeam+(pbmax-pbmin)/dble(npb-1)
+c else use a logaritmic excitation function
+ else if(efuncflag.eq.2) then
+ ipbm=ipbm+1
+ pbeam=pbmin*exp(
+ & (dlog(pbmax/pbmin))
+ & *ipbm/(npb-1))
+ end if
+ else if (firstev.eq.0) then
+ ipbm=0
+ firstev=1
+ pbeam=pbmin
+ endif
+ endif
+c input was pbeam per particle
+ pbeam=AAp*pbeam
+ eb=sqrt(embeam**2+pbeam**2)
+ ebeam=eb-embeam
+ endif
+
+c now do the calculation of equal_speed quantities
+
+ galab=eb/embeam ! gamma_lab
+ belab=pbeam/eb ! beta_lab
+ gaeq=sqrt(0.5*(1+galab)) ! gamma_equal_speed
+ beeq=belab*galab/(1+galab) ! beta_equal_speed
+ ppeq=gaeq*beeq*embeam ! p_projectile(eq)
+ pteq=-(gaeq*beeq*emtarget) ! p_target(eq)
+
+c reduce to per particle quantities
+ ppeq=ppeq/dble(AAp)
+ if(AAt.ne.0) then
+ pteq=pteq/dble(AAt)
+ emtarget=emtarget/dble(AAt)
+ endif
+ embeam=embeam/dble(AAp)
+ pbeam=pbeam/dble(AAp)
+ ebeam=ebeam/dble(AAp)
+c the following is the NN sqrt(s)
+ ecm=sqrt(embeam**2+2*eb/dble(AAp)*emtarget+emtarget**2)
+
+ccccccccccccccccccccccccccccccccccccccccccccc
+c compute transformation betas for output
+
+ pcm=max(1d-10,pbeam*emtarget/ecm)
+
+ if(CTOption(27).eq.0) then
+ betann=0.d0
+ betatar=pcm/sqrt(pcm**2+emtarget**2)
+ betapro=-(1.*pcm/sqrt(pcm**2+embeam**2))
+ elseif(CTOption(27).eq.1) then
+ betann=-(1*pcm/sqrt(pcm**2+emtarget**2))
+ betatar=0.d0
+ betapro=-(1*pbeam/sqrt(pbeam**2+embeam**2))
+ elseif(CTOption(27).eq.2) then
+ betann=pcm/sqrt(pcm**2+emtarget**2)
+ betatar=pbeam/sqrt(pbeam**2+embeam**2)
+ betapro=0.d0
+ endif
+
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c determine impact parameter
+ if(CTOption(5).eq.0) then
+ bimp=bdist
+ elseif(CTOption(5).eq.1) then
+c hjd1
+c if(bdist.gt.(nucrad(Ap)+nucrad(At)+2*CTParam(30)))
+c & bdist=nucrad(Ap)+nucrad(At)+2*CTParam(30)
+c hjd1
+c ! M.R. 2019-04-24: updated sampling procedure from UrQMD 3.4
+ bimp=sqrt(bmin**2 + ranf(0) * (bdist**2 - bmin**2))
+
+cdh if (bimp<bmin) goto 215
+ elseif(CTOption(5).eq.2) then
+CMR if(bdist.gt.(nucrad(Ap)+nucrad(At)+2*CTParam(30)))
+CMR & bdist=nucrad(Ap)+nucrad(At)+2*CTParam(30)
+ bimp=bmin+ranf(0)*(bdist-bmin)
+ else
+ write(6,*)'illegal CTOption(5) :',CTOption(5)
+ stop
+ endif
+
+ if(At.eq.0) bimp=0.d0
+
+c initialize normal projectile
+ if(prspflg.eq.0) then
+ if(mod(event,nnuc).eq.0)then
+ call cascinit(Zp,Ap,1)
+ endif
+ call getnucleus(1,npart)
+ npart=npart+AAp
+c change reference frame
+ if (CTOption(27).eq.1) then
+ pboost = -pbeam
+ elseif (CTOption(27).eq.2) then
+ pboost = 0.d0
+ else
+ pboost = -ppeq
+ endif
+ call boostnuc(npold+1,npold+AAp,
+ & pboost,0.5*bimp,-dstp)
+c save fermi motion
+ if (CTOption(30).eq.1) then
+ call savefermi(npold+1,npold+AAp,-pboost)
+ endif
+ npold=npart
+ nbar=nbar+AAp
+ if (CTParam(20).ne.0) then
+ call getnucleus(1,npart)
+ npart=npart+AAp
+ call boostnuc(npold+1,npold+AAp,
+ & pboost,0.5*bimp,-dstp+CTParam(20))
+ if (CTOption(30).eq.1) then
+ call savefermi(npold+1,npold+AAp,-pboost)
+ endif
+ npold=npart
+ nbar=nbar+AAp
+ endif
+ endif
+
+
+c initialize normal target
+ if(At.ne.0) then
+ if(trspflg.eq.0) then
+ if(mod(event,nnuc).eq.0)then
+ call cascinit(Zt,At,2)
+ endif
+ call getnucleus(2,npart)
+ npart=npart+AAt
+c change ref. frame
+ if(CTOption(27).eq.1) then
+ pboost = 0.d0
+ elseif(CTOption(27).eq.2) then
+ pboost = pbeam
+ else
+ pboost = -pteq
+ endif
+ call boostnuc(npold+1,npold+AAt,
+ & pboost,-(0.5*bimp),dstt)
+c save fermi motion
+ if (CTOption(30).eq.1) then
+ call savefermi(npold+1,npold+AAt,-pboost)
+ endif
+ npold=npart
+ nbar = nbar + AAt
+ endif
+ endif
+
+c set unique ID-tag counter (is not initialized with getnucleus calls)
+ uid_cnt=npart
+
+ if(icount.eq.0) then
+c set counter for collupd
+ apt=Ap
+ return
+c initialize special PRO/TAR combinations
+ elseif(icount.eq.1) then
+ if(prspflg.eq.1) then
+ indsp(1)=1
+c the "regular" target sits first in the arrays
+ apt=At
+ else
+ indsp(1)=2
+ apt=Ap
+ endif
+ elseif(icount.eq.2) then
+ if(abs(spityp(1)).le.abs(spityp(2))) then
+ indsp(1)=1
+ indsp(2)=2
+ apt=Ap
+ else
+ indsp(1)=2
+ indsp(2)=1
+ apt=At
+ endif
+ endif
+ do 40 j=1,icount
+ npart=npart+1
+ if(abs(spityp(indsp(j))).lt.minmes) then
+ nbar=nbar+1
+ else
+ nmes=nmes+1
+ endif
+ iso3(npart) = spiso3(indsp(j))
+ ityp(npart) = spityp(indsp(j))
+ uid_cnt=uid_cnt+1
+ uid(npart)=uid_cnt
+ spin(npart) = getspin(ityp(npart),-1)
+ charge(npart)=fchg(iso3(npart),ityp(npart))
+ fmass(npart) = massit(ityp(npart))
+ rx(npart) = 0.d0
+ ry(npart) = 0.d0
+ rz(npart) = 0.d0
+ px(npart) = 0.d0
+ py(npart) = 0.d0
+c pz ist stored in pbeam,p?eq!
+ pz(npart) = 0.d0
+ p0(npart)=sqrt(px(npart)**2+py(npart)**2+pz(npart)**2
+ & +fmass(npart)**2)
+ if(indsp(j).eq.1) then
+ if(CTOption(27).eq.1) then
+ call boostnuc(npart,npart,-pbeam,0.5*bimp,-dstp)
+ elseif(CTOption(27).eq.2) then
+ call boostnuc(npart,npart,0.d0,0.5*bimp,-dstp)
+ else
+ call boostnuc(npart,npart,-ppeq,0.5*bimp,-dstp)
+ endif
+ elseif(indsp(j).eq.2) then
+ if(CTOption(27).eq.1) then
+ call boostnuc(npart,npart,0.d0,-(0.5*bimp),dstt)
+ elseif(CTOption(27).eq.2) then
+ call boostnuc(npart,npart,pbeam,-(0.5*bimp),dstt)
+ else
+ call boostnuc(npart,npart,-pteq,-(0.5*bimp),dstt)
+ endif
+ endif
+ dectime(npart) = dectim(npart,1)
+
+ 40 continue
+ return
+ end
+
+ subroutine savefermi(i1,i2,p)
+c
+c Revision : 1.0
+c Store fermi momentum in fferm
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+ implicit none
+ include 'coms.f'
+
+ integer i,i1,i2
+ real*8 p
+
+ if (i1.eq.0) return
+
+ if (ncoll(i1).gt.0) return
+
+ do i=i1,i2
+ ffermpx(i)=px(i)
+ ffermpy(i)=py(i)
+ ffermpz(i)=pz(i)-p
+ px(i)=0.0
+ py(i)=0.0
+ pz(i)=p
+ enddo
+
+ return
+ end
+
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+ subroutine addfermi(ind,p)
+c
+c Revision : 1.0
+c Restore fermi momentum from fferm
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+ implicit none
+ include 'coms.f'
+
+ integer ind
+ real*8 p
+
+ if (ind.eq.0) return
+
+ p = pz(ind)
+ px(ind) = px(ind)+ffermpx(ind)
+ py(ind) = py(ind)+ffermpy(ind)
+ pz(ind) = pz(ind)+ffermpz(ind)
+ ffermpx(ind) = 0.0
+ ffermpy(ind) = 0.0
+ ffermpz(ind) = 0.0
+
+ return
+ end
diff --git a/Processes/UrQMD/inputs.f b/Processes/UrQMD/inputs.f
new file mode 100644
index 0000000000000000000000000000000000000000..206ea9981eb537295a0e77498d32a12c1d67cb47
--- /dev/null
+++ b/Processes/UrQMD/inputs.f
@@ -0,0 +1,30 @@
+c $Id: inputs.f,v 1.4 2000/01/12 16:02:36 bass Exp $
+c include file for data from the input subroutine
+ integer nevents,spityp(2),prspflg
+ integer trspflg,spiso3(2),outsteps,bflag,srtflag,efuncflag
+ integer nsrt,npb,firstev
+ real*8 srtmin,srtmax,pbeam,betann,betatar,betapro
+ real*8 pbmin,pbmax
+
+ common /inputs/nevents,spityp,prspflg,trspflg,
+ & spiso3,outsteps,bflag,srtflag,efuncflag,nsrt,
+ & firstev, npb
+ common /input2/ srtmin,srtmax,pbeam,betann,betatar,betapro,
+ & pbmin, pbmax
+
+c
+c maximum mass for projectile and target
+ integer AAmax
+ parameter(AAmax=300)
+c storage arrays for projectile and target nuclei
+ integer PT_iso3(AAmax,2),PT_ityp(AAmax,2),PT_spin(AAmax,2)
+ integer PT_charge(AAmax,2),PT_AA(2),PT_uid(AAmax,2)
+ real*8 PT_r0(AAmax,2),PT_rx(AAmax,2),PT_ry(AAmax,2),PT_rz(AAmax,2)
+ real*8 PT_p0(AAmax,2),PT_px(AAmax,2),PT_py(AAmax,2),PT_pz(AAmax,2)
+ real*8 PT_dectime(AAmax,2),PT_fmass(AAmax,2),PT_rho(AAmax,2)
+ real*8 PT_pmax(AAmax,2)
+c common blocks (data transfer between cascinit and getinit)
+ common/ProTarInts/PT_iso3,PT_ityp,PT_spin,PT_charge,PT_AA,PT_uid
+ common/ProTarReals/PT_r0,PT_rx,PT_ry,PT_rz,PT_fmass,PT_dectime,
+ & PT_p0,PT_px,PT_py,PT_pz,PT_rho,PT_pmax
+c
diff --git a/Processes/UrQMD/iso.f b/Processes/UrQMD/iso.f
new file mode 100644
index 0000000000000000000000000000000000000000..681b2c3b3e343b53c771213b2b2f4eb0dba363fc
--- /dev/null
+++ b/Processes/UrQMD/iso.f
@@ -0,0 +1,814 @@
+c $Id: iso.f,v 1.7 1999/01/18 09:57:06 ernst Exp $
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+ SUBROUTINE ISOCGK4(J1,M1,J2,M2,Jnew,Mnew,ITAG)
+c
+c Revision : 1.0
+c
+c This subroutine determines according to probabilities given by
+c Clebsch Gordan cefficients the total and 3-component of the
+c isospin of up to 4 outgoing particles
+C
+c input:
+c (isocgk: two part. in and two part. out)
+c J1 : 2*I of ingoing particle 1
+c M1 : 2*I3 of ingoing particle 1
+c J2 : 2*I of ingoing particle 2
+c M2 : 2*I3 of ingoing particle 2
+c Jnew : 2*I of outgoing particles (array)
+c
+c
+c (isonew: one part. in and two part. out)
+c J : 2*I of ingoing particle
+c M : 2*I3 of ingoing particle
+c Jnew : 2*I of outgoing particles (array)
+c ITAG=-50 << necessary for correct functioning of routine
+c
+c input/output:
+c Mnew : 2*I3 of outgoing particles (array)
+c Mnew(i)=-9 to determine the I3 component of the
+c i-th particle randomly
+c ITAG : = -1 then no possible isospin combination has been found
+c
+c
+c function calls:
+c ranf()
+c clebsch
+c
+c important global variables:
+c nexit : number of outgoing particles
+c
+c important local variables:
+C JMINOL/JMINNW THE MINIMAL POSSIBLE TOTAL ISOSPIN IN IN-/OUT-STATE
+C M TOTAL I3 OF IN-/OUT-STATE
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ implicit none
+ include 'newpart.f'
+ integer m1,j1,m2,j2,itag,Jnew,Mnew
+ integer Jtot,M,Jminol,Jmaxol,Jminnw,Jmaxnw,i,j,k,l,il,jp,jpr
+ integer jmin,jmax,Nj,ifind
+ integer m1pr,m1p,m1pos,m1out
+ integer m2pr,m2p,m2pos,m2out
+ integer m3pr,m3p,m3pos,m3out
+ integer m4pr,m4p,m4pos,m4out,Mmin,Mmax
+ integer m12,m34,j12,j34
+ integer Jin,Min
+ real*8 pjin,prbout,prbsum,zrand,c12,c34,c_tot
+ DIMENSION pjin(20),prbout(20,20,20,20)
+ DIMENSION m1out(20),m2out(20),m3out(20),m4out(20)
+ DIMENSION JNEW(mprt),Mnew(mprt),Mmin(mprt),Mmax(mprt)
+ real*8 ranf,clebsch
+
+ ITAG=0
+ M=M1+M2
+
+
+c 1.) first treat some special cases
+ if(nexit.gt.4)then
+ write(6,*)'ISOCGK: only <=4 outgoing Isospins can be coupled'
+ itag=-1
+ stop
+ return
+ endif
+
+ if(nexit.eq.3)Jnew(4)=0
+
+ if(nexit.eq.2)then !nexit.eq.2
+ Jnew(3)=0
+ Jnew(4)=0
+c check for zero in out-channel:
+ if(Jnew(1).eq.0) then
+ Mnew(1)=0
+ Mnew(2)=m
+ return
+ elseif(Jnew(2).eq.0) then
+ Mnew(2)=0
+ Mnew(1)=m
+ return
+ endif
+ endif !nexit.eq.2
+
+c 2.) determine possible min and max isospins for in/out state
+c
+c determine number of possible in-states
+ Jminol= MAX0(IABS(J1-J2),IABS(M))
+ Jmaxol= J1+J2
+
+c determine number of possible out-states
+c JMINNW= MAX0(IABS(J1NEW-J2NEW),IABS(M))
+ Jminnw=1000
+ do 1 i=-1,1,2
+ do 2 j=-1,1,2
+ do 3 k=-1,1,2
+ do 4 l=-1,1,2
+ jp=IABS(i*Jnew(1)+j*Jnew(2)+k*Jnew(3)+l*Jnew(4))
+ if(jp.lt.Jminnw)Jminnw=jp
+4 continue
+3 continue
+2 continue
+1 continue
+ Jminnw=MAX0(Jminnw,IABS(M))
+
+c JMAXNW= J1NEW+J2NEW
+ Jmaxnw=0
+ do 5 i=1,nexit
+ Jmaxnw=Jmaxnw+Jnew(i)
+5 continue
+
+c check which possible states match (are common for in AND out state)
+ Jmin = MAX0(Jminol,Jminnw)
+ Jmax = MIN0(Jmaxol,Jmaxnw)
+c error check for unphysical input
+ if(Jmin.gt.Jmax) then
+ itag=-1
+ write(6,*)'isocgk: jmin > jmax : unphysical input!'
+ write(6,*) J1,M1,J2,M2,jnew(1),jnew(2),jmin,jmax
+ return
+ endif
+
+c 3.) calculate number of possible isospins
+ nj = (Jmax-Jmin)/2 +1
+ if(J1.eq.0.or.J2.eq.0)then
+ if(Jmin.ne.Jmax) then
+ itag=-1
+ write(6,*) 'J1(2)=0,Jmin.ne.Jmax IN ISOCGK - check calling'
+ return
+ endif
+ if(J1.eq.0.and.J2.eq.0) then
+ write(6,*) "J1,J2=0 IN ISOCGK - can't couple this"
+ itag=-1
+ return
+ endif
+c here only one total isospin is possible (probability is unity)
+ pjin(1)=1.
+ goto 310
+ END IF !J1.EQ.0.OR.J2.EQ.0
+c if no overlap between in and out state, return with itag=-1
+ if(nj.le.0) then
+ itag=-1
+ write(6,*)'Isocgk: nj.le.0 - no combination possible'
+ return
+ endif
+
+ ifind=0
+c 4) loops over all possible combinations of J1,J2,M1,M2,Jtot
+c to get the probabilities of the in-channel couplings
+ DO 6 jpr=Jmin,Jmax,2
+ ifind=ifind+1
+ pjin(ifind)=clebsch(J1,J2,m1,m2,jpr)
+6 CONTINUE
+
+C
+c error message, if not all possible Jtot's have been found
+c if(ifind.ne.nj) then
+c write(6,*)'ERROR IN ISOCGK IFIND.NE.NJ'
+c stop
+c endif
+c sum CGKs over all possible Jtots (-> probabilities)
+ prbsum=0.
+ do 7 il=1,nj
+ prbsum=prbsum+pjin(il)
+7 continue
+
+c check for nonsense
+ IF(prbsum.le.0.) THEN
+ write(6,*)'ERROR IN ISOCGK 30:PRBSUM.LE.0.'
+ stop
+ END IF
+c normalize PJIN(.) to 1
+c now PJIN contains CGK-based probabilities for the different possible Jtots
+ Do 8 il=1,nj
+ pjin(il)=pjin(il)/prbsum
+8 Continue
+310 continue
+c 5) now throw dice to determine one of the possible Jtots
+ zrand=ranf(0)
+ Do 9 il=1,nj
+ if(zrand.lt.pjin(il))then
+c this is now the "real Jtot"
+ Jtot= Jmin +2*(il-1)
+ goto 11
+ else
+ zrand=zrand-pjin(il)
+ endif
+9 Continue
+11 Continue
+
+
+ goto 111
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c this is the entry for one in and >= two out particles
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ ENTRY ISONEW4(JIN,MIN,JNEW,MNEW,ITAG)
+
+ IF(ITAG.EQ.-50) THEN
+
+ Jtot=Jin
+ M=Min
+ itag=0
+
+ END IF !itag=-50
+
+c here now both cases (one/two-in particles) together
+c now the in-channel is determined -> get out-channel
+ 111 continue
+
+c special cases
+ if(nexit.gt.4)then
+ write(6,*)'ISONEW: only <=4 outgoing Isospins can be coupled'
+ itag=-1
+ stop
+ return
+ endif
+
+ if(nexit.eq.3)then
+ Jnew(4)=0
+ Mnew(4)=0
+ endif
+
+ if(nexit.eq.2)then
+ Jnew(3)=0
+ Jnew(4)=0
+ Mnew(3)=0
+ Mnew(4)=0
+c check for zero in out-channel:
+ if(Jnew(1).eq.0) then
+ mnew(1)=0
+ mnew(2)=m
+ return
+ elseif(Jnew(2).eq.0) then
+ mnew(2)=0
+ mnew(1)=m
+ return
+ endif
+ endif !nexit=2
+
+
+c reset counters
+ m1pos=2*Jnew(1)+1
+ m2pos=2*Jnew(2)+1
+ m3pos=2*Jnew(3)+1
+ m4pos=2*Jnew(4)+1
+ Do 161 m1p=1,20
+ m1out(m1p)=0
+ m2out(m1p)=0
+ m3out(m1p)=0
+ m4out(m1p)=0
+ Do 162 m2p=1,m2pos
+ Do 163 m3p=1,m3pos
+ Do 164 m4p=1,m4pos
+ prbout(m1p,m2p,m3p,m4p)=0d0
+164 Continue
+163 Continue
+162 Continue
+161 Continue
+
+c get min/maximal M
+ Do 100 i=1,4
+ Mmin(i)=-Jnew(i)
+ Mmax(i)=Jnew(i)
+100 Continue
+
+c calculate the possible |J_i M_i> combinations and their probability
+ do 112 j12=Iabs(Jnew(1)-Jnew(2)),(Jnew(1)+Jnew(2)),2
+ do 134 j34=Iabs(Jnew(3)-Jnew(4)),(Jnew(3)+Jnew(4)),2
+ m1pos=0
+ Do 41 m1pr=Mmin(1),Mmax(1),2
+ m1pos=m1pos+1
+ m1out(m1pos)=m1pr
+ m2pos=0
+ Do 42 m2pr=Mmin(2),Mmax(2),2
+ m2pos=m2pos+1
+ m2out(m2pos)=m2pr
+ m3pos=0
+ Do 43 m3pr=Mmin(3),Mmax(3),2
+ m3pos=m3pos+1
+ m3out(m3pos)=m3pr
+ m4pos=0
+ Do 44 m4pr=Mmin(4),Mmax(4),2
+ m4pos=m4pos+1
+ m4out(m4pos)=m4pr
+c m4pr=m-m1pr-m2pr-m3pr
+ If(m1pr+m2pr+m3pr+m4pr.ne.m)goto 44
+ m12=m1pr+m2pr
+ m34=m3pr+m4pr
+
+ c12=clebsch(Jnew(1),Jnew(2),m1pr,m2pr,J12)
+ c34=clebsch(Jnew(3),Jnew(4),m3pr,m4pr,J34)
+ c_tot= clebsch(J12,J34,m12,m34,Jtot)
+
+ prbout(m1pos,m2pos,m3pos,m4pos)=
+ + prbout(m1pos,m2pos,m3pos,m4pos)+c12*c34*c_tot
+
+
+ 44 Continue
+ 43 Continue
+ 42 Continue
+ 41 Continue
+ 134 continue
+ 112 continue
+
+c error check
+ if(m1pos.eq.0.or.m2pos.eq.0.or.m3pos.eq.0.or.m4pos.eq.0)then
+ write(6,*)'IN ISOCGK/ISONEW: MPOS=0 ERROR'
+ write(6,*)"Can't couple Jin, Min=",Jtot,M
+ write(6,*)'To J1,J2,J3,J4=',Jnew(1),Jnew(2),Jnew(3),Jnew(4)
+ itag=-1
+ return
+ endif
+
+c sum up all CGKs
+ prbsum=0.
+ Do 51 m1p=1,m1pos
+ Do 52 m2p=1,m2pos
+ Do 53 m3p=1,m3pos
+ Do 54 m4p=1,m4pos
+ prbsum=prbsum+prbout(m1p,m2p,m3p,m4p)
+54 Continue
+53 continue
+52 continue
+51 continue
+
+c error check
+ IF(prbsum.le.0.) then
+ write(6,*)'ERROR IN ISOCGK/ISONEW:PRBSUM.LE.0.'
+ write(6,*)"Can't couple Jin, Min=",Jtot,M
+ write(6,*)'To J1,J2,J3,J4=',Jnew(1),Jnew(2),Jnew(3),Jnew(4)
+ stop
+ endif
+
+c normalize to 1 (now we have real probabilities for different Mout combis)
+ Do 61 m1p=1,m1pos
+ Do 62 m2p=1,m2pos
+ Do 63 m3p=1,m3pos
+ Do 64 m4p=1,m4pos
+ prbout(m1p,m2p,m3p,m4p)=prbout(m1p,m2p,m3p,m4p)/prbsum
+c write(*,*)'!p= ',m1out(m1p),m2out(m2p),m3out(m3p),
+c & m4out(m4p),prbout(m1p,m2p,m3p,m4p)
+64 Continue
+63 Continue
+62 Continue
+61 Continue
+
+c now determine according to the PRBOUT values the outgoing M combination
+ zrand=ranf(0)
+ Do 71 m1p=1,m1pos
+ Do 72 m2p=1,m2pos
+ Do 73 m3p=1,m3pos
+ Do 74 m4p=1,m4pos
+ if(zrand.lt.prbout(m1p,m2p,m3p,m4p)) then
+ Mnew(1)= M1out(m1p)
+ Mnew(2)= M2out(m2p)
+ Mnew(3)= M3out(m3p)
+ Mnew(4)= M4out(m4p)
+ goto 70
+ else
+ zrand=zrand-prbout(m1p,m2p,m3p,m4p)
+ endif
+74 Continue
+73 Continue
+72 Continue
+71 Continue
+70 Continue
+ RETURN
+ END
+
+
+C####C##1#########2#########3#########4#########5#########6#########7##
+ real*8 function fcgk(i1,i2,iz1,iz2,i) !L.A.W. Tue Aug 15 1995
+c returns the normalized clebsch gorden factor also for combinations
+c involving strange mesons and antibaryons
+C####C##1#########2#########3#########4#########5#########6#########7##
+ implicit none
+ include 'comres.f'
+ real*8 c
+ integer i1,i2,iz1,iz2,i,iz,isoit,i12,i12a,ir,strit,icnt
+ logical nombbb
+
+ fcgk=0D0
+ icnt=0
+ c=0d0
+ iz=iz1+iz2
+ if(isoit(i).lt.iabs(iz))goto 1008
+ if(isoit(i1)*isoit(i2).eq.0)then
+ c=1d0
+ goto 1008
+ end if
+
+ call cgknrm(isoit(i),iz,isoit(i1),isoit(i2),iz1,iz2,ir,c)
+ if(i1.eq.i2.and.iz1.ne.iz2.and.iz1+iz2.eq.0)c=2d0*c
+c... particle exchange
+
+ if(ir.ne.0)then
+ icnt=icnt+1
+ if(icnt.le.1)then
+ write(6,*)'fcgk: no iso-spin decomposition found for:',
+ @ i,iz,' to ',i1,iz1,'+',i2,iz2
+ write(6,*)' please check this channel'
+ end if
+ return
+ end if
+
+ if(strit(i).eq.0)then
+c... this is now for particle+antiparticle (except nonstrange mesons)
+ i12=i1*i2
+ i12a=iabs(i12)
+ nombbb=i12a.lt.maxbar**2.or.i12a.gt.minmes**2
+c... the charge conjugated states have the same weight
+ if(i12.lt.0.and.nombbb)then
+c... for example anti-K* + K
+ if(i1.ne.-i2)c=c*5d-1
+ end if
+ end if
+1008 fcgk=c
+ return
+ end
+C####C##1#########2#########3#########4#########5#########6#########7##
+ subroutine cgknrm(JIN,MIN,J1NEW,J2NEW,M1IN,M2IN,ierr,cf)
+C gives the normalized cg-factor i.e. poosibility into a given
+C iso-spin decomposition of JIN,MIN into J1NEW,J2NEW,M1IN,M2IN
+C ierr equals 0 if there is any alowed J1,J2,M1,M2 (not necessaryly
+C equal to J1NEW,J2NEW,M1IN,M2).
+C ierr is not equal 0 if all channels are iso-spin forbidden
+C for specific couplings possibly involving strange particles or
+C anti-particles function fcgk should be used (see beyond)
+Coutput cf : normalized cg-factor
+C####C##1#########2#########3#########4#########5#########6#########7##
+ implicit integer (i - n)
+ implicit real*8 (a - h , o - z)
+ DIMENSION PRBOUT(20),M1OUT(20)
+ real*8 clebsch
+
+c the in particle of course defines Jtot and Mtot
+ cf =0d0
+ ierr = 0
+ctp060202 1 JTOT=JIN
+ JTOT=JIN
+ M=MIN
+ ITAG=0
+c check for zero in out-channel:
+ if(j1new.eq.0) then
+ m1new=0
+ m2new=m
+ return
+ elseif(j2new.eq.0) then
+ m2new=0
+ m1new=m
+ return
+ endif
+
+c here now both cases (one/two in particles) together
+c reset counters
+ M1POS=0
+c loop over all J1,J2,Jtot,M1,M2 combinations
+ do 39 m1pr=-j1new,j1new,2
+ m2pr=m-m1pr
+c if J1new and J2new and Jtot and Mtot create a match then store M1new
+c inM1OUT array and the CGK in PRBOUT array; the counter for possible
+c Mnew combinations is M1POS
+ M1POS=M1POS+1
+ M1OUT(M1POS)=M1PR
+ PRBOUT(M1POS)=clebsch(j1new,j2new,m1pr,m2pr,jtot)
+ if( ! (m1pr.eq.m2in.and.m2pr.eq.m1in).or.
+ @ (m2pr.eq.m2in.and.m1pr.eq.m1in))cf=cf+PRBOUT(M1POS)
+ 39 continue
+c error check
+ IF(M1POS.EQ.0) then
+ write(6,*)'IN ISOCGK: M1POS=0 ERROR'
+ write(6,*)'jtot,j1new,j2new,m',jtot,j1new,j2new,m
+ itag=-1
+ return
+ endif
+c sum over all CGKs
+ PRBSUM=0.
+ DO 50 M1P=1,M1POS
+ PRBSUM=PRBSUM+PRBOUT(M1P)
+ 50 continue
+
+c error check
+ IF(PRBSUM.LT.1d-3) then
+ ierr = 1
+ cf = 0d0
+ return
+ endif
+c normalize to 1 (now we have real probabilities for different Mout combis)
+ cf=cf/PRBSUM
+
+ RETURN
+ END
+
+
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ real*8 function dbweight(j1,m1,j2,m2,j1new,j2new)
+c
+c Revision : 1.0
+c
+c This function delivers a weight, based on a Clebsch Gordan
+c coefficient, for detailed balance cross sections
+C
+c input:
+c J1 : 2*I of ingoing particle 1
+c J2 : 2*I of ingoing particle 2
+c M1 : 2*I3 of ingoing particle 1
+c M2 : 2*I3 of ingoing particle 2
+c J1new : 2*I of outgoing particle 1
+c J2new : 2*I of outgoing particle 2
+c
+c output:
+c weight : weight factor
+c
+c function calls:
+c clebsch
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+ implicit none
+ integer j1,m1,j2,m2,j1new,j2new,jminol,jmaxol,jminnw,jmaxnw
+ integer nj,jpr,m,jmax,jmin,ind
+ real*8 clebsch,weight(10)
+
+ dbweight=0.d0
+ m=m1+m2
+c determine number of possible states
+c fist the in state
+ JMINOL= MAX0(IABS(J1-J2),IABS(M))
+ JMAXOL= J1+J2
+c now the out state
+ JMINNW= MAX0(IABS(J1NEW-J2NEW),IABS(M))
+ JMAXNW= J1NEW+J2NEW
+c which possible states match (are common for in AND out state)
+ JMIN = MAX0(JMINOL,JMINNW)
+ JMAX = MIN0(JMAXOL,JMAXNW)
+ NJ = (JMAX-JMIN)/2 +1
+ if(nj.lt.1) return
+ ind=0
+ do 18 jpr=jmin,jmax,2
+ ind=ind+1
+ weight(ind)=clebsch(j1,j2,m1,m2,jpr)
+ dbweight=dbweight+weight(ind)
+ 18 continue
+
+ return
+ end
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ real*8 function clebsch(j1,j2,m1,m2,j3)
+c
+c Revision : 1.0
+c
+c This function delivers a Clebsch Gordan Coefficient, which has been
+c calculated by w3j.
+C
+c input:
+c J1 : 2*I of ingoing particle 1
+c J2 : 2*I of ingoing particle 2
+c M1 : 2*I3 of ingoing particle 1
+c M2 : 2*I3 of ingoing particle 2
+c J3 : 2*I of projection requested
+c (i.e. resonance to be formed)
+c
+c output:
+c clebsch : CGK**2
+c
+c function calls:
+c w3j
+c !!! first call function after intialization with loginit
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+ implicit none
+ real*8 LogFak( 0 : 100 ),dj1,dj2,dj3,dm1,dm2,dm3,w3j
+ real*8 cfct,cgk
+ integer j1,j2,j3,m1,m2,ipot,jmm,jmm1
+ common /FACTORIALS/LogFak
+
+ integer jmax
+ parameter(jmax=7)
+ real*8 cgktab(0:jmax,0:jmax,-jmax:jmax,-jmax:jmax,0:jmax)
+ common /cgks/cgktab
+
+c each cgk for j's in the range up to jmax is calculated only once
+c and then stored in the cgktab table for further use
+ jmm1=max(j1,j2)
+ jmm=max(j3,jmm1)
+ if(jmm.gt.jmax.or.(cgktab(j1,j2,m1,m2,j3).lt.-8.d0)) then
+
+ dj1=dble(j1)/2.d0
+ dj2=dble(j2)/2.d0
+ dj3=dble(j3)/2.d0
+ dm1=dble(m1)/2.d0
+ dm2=dble(m2)/2.d0
+ dm3=-(dm1+dm2)
+ ipot=(j1+m1+j2-m2)/2
+ cfct=sqrt(2*dj3+1.d0)/(-(1.d0**ipot))
+ cgk=cfct*w3j(dj1,dj2,dj3,dm1,dm2,dm3)
+ clebsch=cgk**2
+ if(jmm.le.jmax) then
+ cgktab(j1,j2,m1,m2,j3)=clebsch
+ endif
+ else
+ clebsch=cgktab(j1,j2,m1,m2,j3)
+ endif
+ return
+ END
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ function W3j( J1, J2, J3, M1, M2, M3 )
+c
+c
+c This program calculates the 3-j wigner symbols according to the
+c representation of A. Lindner.
+c
+c Reference:
+c A. Lindner, Drehimpulse in der Quantenmechanik, Teubner 1984, P.39
+c
+c======================================================================
+ implicit none
+c Program input
+
+ real*8 J1, J2, J3, M1, M2, M3
+
+c Program returns
+
+ real*8 W3j
+
+c Global variables
+
+ real*8 LogFak( 0 : 100 )
+ common /FACTORIALS/ LogFak
+
+c Program variables
+
+ real*8 R1, R2, R3, R4, R5, R6, R7, R8, R9
+ real*8 N( 1 : 3, 1 : 3 )
+ real*8 Sum1, Sum2
+ real*8 Sigma
+ real*8 LF_R1, LF_R2, LF_R3, LF_R4, LF_R5, LF_R6
+ real*8 LF_R7, LF_R8, LF_R9
+ real*8 LF_Sigma
+ real*8 Hlp1, Hlp2, Pre
+ real*8 Summe, S( 0 : 100 )
+ integer*4 Signum
+ integer*4 in
+ real*8 minimal
+ integer*4 imin, jmin
+ integer*4 i, j
+ real*8 dn
+ real*8 dummy
+
+c Start of calculation
+
+c Evaluation due to equivalence with Regge symbol
+
+c call LogInit
+C
+ Sigma = J1 + J2 + J3
+
+ N( 1, 1 ) = -J1 + J2 + J3
+ N( 1, 2 ) = J1 - J2 + J3
+ N( 1, 3 ) = J1 + J2 - J3
+ N( 2, 1 ) = J1 - M1
+ N( 2, 2 ) = J2 - M2
+ N( 2, 3 ) = J3 - M3
+ N( 3, 1 ) = J1 + M1
+ N( 3, 2 ) = J2 + M2
+ N( 3, 3 ) = J3 + M3
+
+ do 20 i = 1, 3
+ do 10 j = 1, 3
+ if ( nint( N( i, j ) ) .lt. 0 ) goto 99999
+ 10 continue
+ Sum1 = N( i, 1 ) + N( i, 2 ) + N( i, 3 )
+ Sum2 = N( 1, i ) + N( 2, i ) + N( 3, i )
+ if ( nint( Sum1 ) .ne. nint( Sigma ) ) goto 99999
+ if ( nint( Sum2 ) .ne. nint( Sigma ) ) goto 99999
+ 20 continue
+
+c do 101 i=1, 3
+c write(6,'(3f14.5)') (N(i,j), j=1, 3 )
+c 101 continue
+
+ imin = 1
+ jmin = 1
+ Signum = 1
+ minimal = N( 1, 1 )
+
+c Looking for the smallest N( i, j )
+
+ do 40 i = 1, 3
+ do 30 j = 1, 3
+ if ( N(i,j) .lt. minimal ) then
+ minimal = N( i, j )
+ imin = i
+ jmin = j
+ endif
+ 30 continue
+ 40 continue
+
+ Signum = 1
+
+ if ( imin .gt. 1 ) then
+ do 50 j = 1, 3
+ dummy = N( 1, j )
+ N( 1, j ) = N( imin, j )
+ N( imin, j ) = dummy
+ 50 continue
+ Signum = (-1)**nint( Sigma )
+ endif
+
+ if ( jmin .gt. 1 ) then
+ do 60 i = 1, 3
+ dummy = N( i, 1 )
+ N( i, 1 ) = N( i, jmin )
+ N( i, jmin ) = dummy
+ 60 continue
+ Signum = (-1)**nint( Sigma ) * Signum
+ endif
+
+
+ R1 = N( 1, 1 )
+ R2 = N( 1, 2 )
+ R3 = N( 1, 3 )
+ R4 = N( 2, 1 )
+ R5 = N( 2, 2 )
+ R6 = N( 2, 3 )
+ R7 = N( 3, 1 )
+ R8 = N( 3, 2 )
+ R9 = N( 3, 3 )
+
+ LF_R1 = LogFak( nint( R1 ) )
+ LF_R2 = LogFak( nint( R2 ) )
+ LF_R3 = LogFak( nint( R3 ) )
+ LF_R4 = LogFak( nint( R4 ) )
+ LF_R5 = LogFak( nint( R5 ) )
+ LF_R6 = LogFak( nint( R6 ) )
+ LF_R7 = LogFak( nint( R7 ) )
+ LF_R8 = LogFak( nint( R8 ) )
+ LF_R9 = LogFak( nint( R9 ) )
+ LF_Sigma = LogFak( nint( Sigma+1.d0 ) )
+
+ Hlp1 = ( LF_R2 + LF_R3 + LF_R4 + LF_R7 - LF_Sigma -
+ & LF_R1 - LF_R5 - LF_R9 - LF_R6 - LF_R8 ) / 2.d0
+
+ Pre = dexp( Hlp1 ) * (-1)**( nint( R6 + R8 ) )
+
+ Hlp2 = LF_R6 - LogFak( nint(R6-R1) )
+ & + LF_R8 - LogFak( nint(R8-R1) )
+ S( 0 ) = dexp( Hlp2 )
+ Summe = S( 0 )
+
+ do 70 in = 1, nint( R1 )
+ dn = dble( in )
+ S( in ) = (-1)*S( in-1 ) * ( R1+1.d0-dn ) * ( R5+1.d0-dn )
+ & * ( R9+1.d0-dn ) / dn / ( R6-R1+dn ) / ( R8-R1+dn )
+ Summe = Summe + S( in )
+ 70 continue
+
+ W3j = Pre * Summe * Signum
+ return
+
+99999 W3j = 0.d0
+ return
+
+ end
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ subroutine LogInit
+c=====================================================================
+c
+c This function computes the logarithm of the factorials and
+c stores it in the array LogFak.
+c
+c=====================================================================
+
+ implicit none
+
+c Program output
+ integer jmax
+ parameter(jmax=7) ! must be identical to value in clebsch!!!
+ real*8 cgktab(0:jmax,0:jmax,-jmax:jmax,-jmax:jmax,0:jmax)
+ common /cgks/cgktab
+
+ real*8 LogFak( 0 : 100 )
+
+ common / FACTORIALS / LogFak
+
+c Program variables
+
+ integer*4 i,j1,j2,j3,m1,m2
+
+c Program start
+ do 1 j1=0,jmax
+ do 1 j2=0,jmax
+ do 1 m1=-jmax,jmax
+ do 1 m2=-jmax,jmax
+ do 1 j3=0,jmax
+ cgktab(j1,j2,m1,m2,j3)=-9.d0
+ 1 continue
+
+
+ LogFak( 0 ) = 0.d0
+ do 10 i = 1, 100
+ LogFak( i ) = LogFak( i-1 ) + dlog( dble( i ) )
+ 10 continue
+
+ end
diff --git a/Processes/UrQMD/ityp2pdg.f b/Processes/UrQMD/ityp2pdg.f
new file mode 100644
index 0000000000000000000000000000000000000000..5a48225dceac7fb948026ec4cb80d05ff3946d8d
--- /dev/null
+++ b/Processes/UrQMD/ityp2pdg.f
@@ -0,0 +1,360 @@
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ function pdgid (ityp, iso3)
+c
+c Revision : 1.0
+c
+coutput pdgid : Particle-ID according to Particle Data Group
+c
+c converts UrQMD-Id to PDG-Id
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+ implicit none
+
+ include 'comres.f'
+
+ integer pdgid
+ integer ityp
+ integer iso3
+
+ integer tab_size
+ parameter (TAB_SIZE = 165)
+
+ logical anti
+ integer abs_ityp
+ integer norm_iso3
+ integer idtab(3,TAB_SIZE)
+ integer first
+ integer last
+ integer next
+
+ data idtab/
+c Neutron
+ . 1, -1, 2112,
+c Proton
+ . 1, 1, 2212,
+c N*
+ . 2, -1, 12112, 2, 1, 12212,
+ . 3, -1, 1214, 3, 1, 2124,
+ . 4, -1, 22112, 4, 1, 22212,
+ . 5, -1, 32112, 5, 1, 32212,
+ . 6, -1, 2116, 6, 1, 2216,
+ . 7, -1, 12116, 7, 1, 12216,
+ . 8, -1, 21214, 8, 1, 22124,
+ . 9, -1, 42112, 9, 1, 42212,
+ . 10, -1, 31214, 10, 1, 32124,
+ . 14, -1, 1218, 14, 1, 2128,
+c Delta
+ . 17, -3, 1114, 17, -1, 2114, 17, 1, 2214, 17, 3, 2224,
+ . 18, -3, 31114, 18, -1, 32114, 18, 1, 32214, 18, 3, 32224,
+ . 19, -3, 1112, 19, -1, 1212, 19, 1, 2122, 19, 3, 2222,
+ . 20, -3, 11114, 20, -1, 12114, 20, 1, 12214, 20, 3, 12224,
+ . 21, -3, 11112, 21, -1, 11212, 21, 1, 12122, 21, 3, 12222,
+ . 22, -3, 1116, 22, -1, 1216, 22, 1, 2126, 22, 3, 2226,
+ . 23, -3, 21112, 23, -1, 21212, 23, 1, 22122, 23, 3, 22222,
+ . 24, -3, 21114, 24, -1, 22114, 24, 1, 22214, 24, 3, 22224,
+ . 25, -3, 11116, 25, -1, 11216, 25, 1, 12126, 25, 3, 12226,
+ . 26, -3, 1118, 26, -1, 2118, 26, 1, 2218, 26, 3, 2228,
+c Lambda
+ . 27, 0, 3122,
+ . 28, 0, 13122,
+ . 29, 0, 3124,
+ . 30, 0, 23122,
+ . 31, 0, 33122,
+ . 32, 0, 13124,
+ . 33, 0, 43122,
+ . 34, 0, 53122,
+ . 35, 0, 3126,
+ . 36, 0, 13126,
+ . 37, 0, 23124,
+ . 38, 0, 3128,
+ . 39, 0, 23126,
+c Sigma
+ . 40, -2, 3112, 40, 0, 3212, 40, 2, 3222,
+ . 41, -2, 3114, 41, 0, 3214, 41, 2, 3224,
+ . 42, -2, 13112, 42, 0, 13212, 42, 2, 13222,
+ . 43, -2, 13114, 43, 0, 13214, 43, 2, 13224,
+ . 44, -2, 23112, 44, 0, 23212, 44, 2, 23222,
+ . 45, -2, 3116, 45, 0, 3216, 45, 2, 3226,
+ . 46, -2, 13116, 46, 0, 13216, 46, 2, 13226,
+ . 47, -2, 23114, 47, 0, 23214, 47, 2, 23224,
+ . 48, -2, 3118, 48, 0, 3218, 48, 2, 3228,
+c Xi
+ . 49, -1, 3312, 49, 1, 3322,
+ . 50, -1, 3314, 50, 1, 3324,
+ . 52, -1, 13314, 52, 1, 13324,
+c Omega
+ . 55, 0, 3334,
+c gamma
+ . 100, 0, 22,
+c pion
+ . 101, -2, -211, 101, 0, 111, 101, 2, 211,
+c eta
+ . 102, 0, 221,
+c omega
+ . 103, 0, 223,
+c rho
+ . 104, -2, -213, 104, 0, 113, 104, 2, 213,
+c f0(980)
+ . 105, 0, 10221,
+c kaon
+ . 106, -1, 311, 106, 1, 321,
+c eta'
+ . 107, 0, 331,
+c k*(892)
+ . 108, -1, 313, 108, 1, 323,
+c phi
+ . 109, 0, 333,
+c k0*(1430)
+ . 110, -1, 10313, 110, 1, 10323,
+c a0(980)
+ . 111, -2,-10211, 111, 0, 10111, 111, 2, 10211,
+c f0(1370)
+ . 112, 0, 20221,
+c k1(1270)
+ . 113, -1, 10313, 113, 1, 10323,
+c a1(1260)
+ . 114, -2,-20213, 114, 0, 20113, 114, 2, 20213,
+c f1(1285)
+ . 115, 0, 20223,
+c f1'(1510)
+ . 116, 0, 40223,
+c k2*(1430)
+ . 117, -1, 315, 117, 1, 325,
+c a2(1329)
+ . 118, -2, -215, 118, 0, 115, 118, 2, 215,
+c f2(1270)
+ . 119, 0, 225,
+c f2'(1525)
+ . 120, 0, 335,
+c k1(1400)
+ . 121, -1, 20313, 121, 1, 20323,
+c b1
+ . 122, -2,-10213, 122, 0, 10113, 122, 2, 10213,
+c h1
+ . 123, 0, 10223,
+c K* (1410)
+ . 125, -1, 30313, 125, 1, 30323,
+c rho (1450)
+ . 126, -2,-40213, 126, 0, 40113, 126, 2, 40213,
+c omega (1420)
+ . 127, 0, 50223,
+c phi(1680)
+ . 128, 0, 10333,
+c k*(1680)
+ . 129, -1, 40313, 129, 1, 40323,
+c rho(1700)
+ . 130, -2,-30213, 130, 0, 30113, 130, 2, 30213,
+c omega(1600)
+ . 131, 0, 60223,
+c phi(1850)
+ . 132, 0, 337 /
+
+cb check for antiparticles
+ if (ityp.lt.0) then
+cl its an antiparticle
+ anti = .true.
+ abs_ityp = abs(ityp)
+ norm_iso3 = -iso3
+cl only mesons with odd isospin can have a negative ITYPE
+ if (abs_ityp.gt.minmes)then
+ if(mod(isomes(abs_ityp),2).eq.0) then
+ call error ('pdgid','Negative ITYP not allowed',
+ . dble(ityp),3)
+ pdgid = 0
+ return
+ endif
+ endif
+ else
+ anti = .false.
+ abs_ityp = ityp
+ norm_iso3 = iso3
+ endif
+
+cb search for the ITYP in IDTAB
+
+ first = 1
+ last = TAB_SIZE
+ if (idtab(1,first).eq.abs_ityp) then
+ next = first
+ goto 200
+ endif
+ if (idtab(1,last).eq.abs_ityp) then
+ next = last
+ goto 200
+ endif
+
+ 100 continue
+
+cl ITYP not found in IDTAB
+ if (last.le.(first+1)) then
+ pdgid = 0
+ return
+ endif
+
+ next = (first+last)/2
+
+ if (idtab(1,next).lt.abs_ityp) then
+ first = next
+ goto 100
+ elseif (idtab(1,next).gt.abs_ityp) then
+ last = next
+ goto 100
+ endif
+
+ 200 continue
+
+cl calculate the entry with the wanted ISO3
+ next = next - (idtab(2,next)-norm_iso3)/2
+
+cl check if we found the correct values in IDTAB
+ if ((idtab(1,next).eq.abs_ityp).and.
+ . (idtab(2,next).eq.norm_iso3)) then
+ if (anti) then
+ pdgid = -idtab(3,next)
+ else
+ pdgid = idtab(3,next)
+ endif
+ else
+ call error ('pdgid','Error in tablelookup',dble(next),3)
+ pdgid = 0
+ endif
+
+ return
+ end
+
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ function partname (ityp)
+c
+c Revision : 1.0
+c
+coutput partname : Name of the Particle as a character string
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+ implicit none
+
+ include 'comres.f'
+
+ character*15 partname
+ integer ityp
+
+ integer abs_ityp
+ character*7 baryon_names(maxbar-minbar+1)
+ character*11 meson_names(maxmes-minmes+1)
+ character*1 prefix
+
+ data baryon_names/
+ . 'Nukleon',
+ . 'N(1440)',
+ . 'N(1520)',
+ . 'N(1535)',
+ . 'N(1650)',
+ . 'N(1675)',
+ . 'N(1680)',
+ . 'N(1700)',
+ . 'N(1710)',
+ . 'N(1720)',
+ . 'N(1900)',
+ . 'N(1990)',
+ . 'N(2080)',
+ . 'N(2190)',
+ . 'N(2220)',
+ . 'N(2250)',
+ . 'D(1232)',
+ . 'D(1600)',
+ . 'D(1620)',
+ . 'D(1700)',
+ . 'D(1900)',
+ . 'D(1905)',
+ . 'D(1910)',
+ . 'D(1920)',
+ . 'D(1930)',
+ . 'D(1950)',
+ . 'Lambda',
+ . 'L(1405)',
+ . 'L(1520)',
+ . 'L(1600)',
+ . 'L(1670)',
+ . 'L(1690)',
+ . 'L(1800)',
+ . 'L(1810)',
+ . 'L(1820)',
+ . 'L(1830)',
+ . 'L(1890)',
+ . 'L(2100)',
+ . 'L(2110)',
+ . 'Sigma',
+ . 'S(1385)',
+ . 'S(1660)',
+ . 'S(1670)',
+ . 'S(1750)',
+ . 'S(1775)',
+ . 'S(1915)',
+ . 'S(1940)',
+ . 'S(2030)',
+ . 'Xi',
+ . 'X(1530)',
+ . 'X(1690)',
+ . 'X(1820)',
+ . 'X(1950)',
+ . 'X(2030)',
+ . 'Omega' /
+
+
+ data meson_names/
+ . 'gamma',
+ . 'pion',
+ . 'eta',
+ . 'omega',
+ . 'rho',
+ . 'f0(980)',
+ . 'kaon',
+ . 'eta''',
+ . 'k*(892)',
+ . 'phi',
+ . 'k0(1430)',
+ . 'a0(980)',
+ . 'f0(1370)',
+ . 'k1(1270)',
+ . 'a1(1260)',
+ . 'f1(1285)',
+ . 'f1(1510)',
+ . 'k2*(1430)',
+ . 'a2(1329)',
+ . 'f2(1270)',
+ . 'f2''(1525)',
+ . 'k1(1400)',
+ . 'b1',
+ . 'h1',
+ . 'h1''',
+ . 'k*(1410)',
+ . 'rho(1450)',
+ . 'omega(1420)',
+ . 'phi(1680)',
+ . 'k*(1680)',
+ . 'rho(1700)',
+ . 'omega(1600)',
+ . 'phi3(1850)' /
+
+ abs_ityp = abs(ityp)
+
+c set the prefix for anti-particles
+ if (ityp.lt.0) then
+ prefix = '*'
+ else
+ prefix = ' '
+ endif
+
+ if ((abs_ityp.ge.minbar).and.(abs_ityp.le.maxbar)) then
+ partname = prefix//baryon_names (abs_ityp)
+ elseif ((abs_ityp.ge.minmes).and.(abs_ityp.le.maxmes)) then
+ partname = prefix//meson_names (abs_ityp-99)
+ else
+ call error ('partname','ITYP out of range',dble(ityp),3)
+ partname = '---'
+ endif
+
+ return
+ end
diff --git a/Processes/UrQMD/jdecay2.f b/Processes/UrQMD/jdecay2.f
new file mode 100644
index 0000000000000000000000000000000000000000..a69c70a940ca75e89846603b4775561381645bd6
--- /dev/null
+++ b/Processes/UrQMD/jdecay2.f
@@ -0,0 +1,344 @@
+ subroutine nbodydec(rm)
+c
+c Revision : 1.0
+c
+c input: rm: Resonance mass
+c
+c {\tt nbodydec} performs the decay of a resonance with mass rm in
+c its local rest frame into nexit particles with 4-momenta and
+c masses stored in the array pnew (see comment to SUB jdecay).
+c The accessible many-body phase-space is homogenously populated,
+c i.e. each configuration has equal probability. The theory behind
+c this approach can be found in M.M. Block and J.D. Jackson, Z.
+c Phys. C 3, 255 (1980). The original routine is contained in CPC
+c (Code ACGJ). It has been modified for uQMD purposes.
+c More documentation and better readability are to follow.
+
+ implicit none
+ integer j,i,imin1
+ include 'newpart.f'
+ real*8 rm
+ real*8 p4loc(0:3), p1loc(3), ploc(3)
+ real*8 M(mprt), MEFFloc(mprt), MASS
+ real*8 M1,F1,M11
+
+
+ real*8 z3, v2, ptot, costheta, z4, v1, reci1, z9, delx2, xi,
+ + z10, pp1dot,ener1,p2, p1s, z5, sintheta, phii,psin,
+ + p1sq, u, u1, ximin,ximax,delu,energy,pi,wmax,w,esys,z2,s,
+ + z8,reci,b, delxi,a,delz,ranf
+
+ LOGICAL MASSLESS
+ integer ntry
+
+ p4loc(0) = rm
+ p4loc(1) = 0d0
+ p4loc(2) = 0d0
+ p4loc(3) = 0d0
+ wmax = 1d0
+
+ PI=4d0*ATAN(1d0)
+C
+ M1=0d0 !Initialize M1=sum of all masses.
+ MASSLESS=.FALSE.
+C Read masses.
+ DO I=1,nexit
+ m(i) = pnew(5,i)
+ M1=M1+M(I) ! M1= sum of all masses.
+ ENDDO
+ IF (M1.EQ.0.) THEN ! If massless.
+ MASSLESS=.TRUE.
+ WMAX=1d0
+ ENDIF
+ MEFFloc(1)=M(1) !Initialize Meff(1)
+C Initialize ESYS.
+ ESYS=SQRT(p4loc(0)*p4loc(0)+p4loc(1)*p4loc(1)+
+ + p4loc(2)*p4loc(2)+p4loc(3)*p4loc(3))
+C
+
+C Main Calculation
+C
+ ntry=0
+60 W=1d0 !Initial weight, for each new event.
+ ntry=ntry+1
+ MASS=M1 !Initial M=total mass of ALL particles.
+ ENERGY=p4loc(0) !Initialize E to E*=cms energy.
+
+ DO I=nexit-1,2,-1 !Loop over all N-2 effective masses needed.
+ U1=M(I+1)/ENERGY
+ U=U1**2
+ MASS=MASS-M(I+1)
+C MASS=SUM of all rest masses of the REMAINING particles.
+ XIMIN=(MASS/ENERGY)**2 !This is Xi,minimum.
+ DELU=1d0-U1
+ XIMAX=DELU**2 !This is Xi,maximum,where
+ !XIMIN <= XI <= XIMAX.
+ DELXI=XIMAX-XIMIN ! DELXI=delta (XI)=XIMAX-XIMIN.
+ B=(1d0+U-XIMIN) ! Used in FAST event generator.
+ A=dble(I)*B ! A=commonly used factor.
+ IMIN1=I-1 ! IMIN1=commonly used factor.
+ DELZ=(A-dble(IMIN1)*DELXI)*DELXI**IMIN1 ! DELZ=Zmax-Zmin
+C
+C Here, we introduce the FAST generators.
+C
+ RECI=1d0/dble(I)
+ S=1d0/(dble(I)-dble(IMIN1)*DELXI/B) ! The probability
+ ! for the distribution i*(i-1)*y**(i-2)*(1-y).
+100 Z2=ranf(0)
+ IF (Z2.LT.S) THEN ! The distribution i*(i-1)*y**(i-2)*(1-y).
+ Z8=ranf(0)
+ Z9=ranf(0)
+ RECI1=1d0/dble(IMIN1)
+ DELX2=DELXI*Z8**RECI*Z9**RECI1
+ ELSE
+ Z10=ranf(0)
+ DELX2=DELXI*Z10**RECI ! The probability distribution
+ ! i*y**(i-1)
+ ENDIF
+ IF (DELX2.EQ.0.) GOTO 100 ! Guards against division by 0.
+ctp060202 110 XI=XIMIN+DELX2 ! XI=XImin+deltaXI.
+ XI=XIMIN+DELX2 ! XI=XImin+deltaXI.
+ ! We reweight (multiply) W by
+ ! DELZ*F1*[(XI/(XI-XIMIN))**(I-2)]/(1+U-XI) .
+ W=W*DELZ*F1(U,XI)*((XI/DELX2)**(I-2))/(1d0+U-XI)
+ MEFFloc(I)=ENERGY*SQRT(XI) ! Store effective mass I, and
+ ! update E for next effective mass.
+ ENERGY=MEFFloc(I)
+ ENDDO
+ V1=(M(1)/ENERGY)**2 ! Set up final weight, with particles 1 and 2.
+ V2=(M(2)/ENERGY)**2
+ W=W*F1(V1,V2) ! We now have the FINAL weight.
+ !We find WMAX, the max weight, here.
+c IF (W.GT.WMAX) WMAX=W ! Update WMAX.
+ ! This routine selects W=1 (unweighted events).
+ Z3=ranf(0)
+ IF (W.LT.WMAX*Z3.and.ntry.le.1000) THEN
+ GOTO 60
+ ENDIF
+ ! We have accepted event, so see if we Lorentz transform it.
+
+ M11=p4loc(0)
+ p1loc(1)=p4loc(1)
+ p1loc(2)=p4loc(2)
+ p1loc(3)=p4loc(3)
+
+ !Iterate over all blob masses, MEFF(I), where MEFF(1)=M(1),MEFF(N)=E*.
+ DO 2500 I=nexit,2,-1
+ ENERGY=.5d0*(M11+(M(I)**2-MEFFloc(I-1)**2)/M11)
+ PTOT=SQRT(ENERGY**2-M(I)**2)
+ !Find RANDOM cos(theta*)=COSTHETA, random PHI*=PHI
+ ! SINTHETA=SIN(THETHA*)
+ Z4=ranf(0)
+ COSTHETA=2d0*Z4-1d0 ! -PI <= THETA* <= PI
+ SINTHETA=SQRT(1d0-COSTHETA**2)
+ Z5=ranf(0)
+ PHII=2d0*PI*Z5 ! 0 <= PHI* <= 2*PI, random PHII
+ PSIN=PTOT*SINTHETA !Commonly used combination.
+ ! Calculate momentum compon. of particle I, ploc(k), k=1 to 3.
+ ploc(1)=PSIN*COS(PHII) ! x-component.
+ ploc(2)=PSIN*SIN(PHII) !y-component.
+ ploc(3)=PTOT*COSTHETA ! z-component.
+ P1SQ=p1loc(1)**2+p1loc(2)**2+p1loc(3)**2
+ P1S=SQRT(P1SQ)
+ ENER1=SQRT(P1SQ+M11**2)
+ ! Calculate Plab(i) =
+ !P*(i) + betagamma(i)*
+ ! [Energy + betagamma(j).ploc(j)/(gamma+1)],
+ !where . means DOT product, i,j=x,y,z.
+ PP1DOT=ploc(1)*p1loc(1)+ploc(2)*p1loc(2)+ploc(3)*p1loc(3) ! DOT product.
+ A=(ENERGY+PP1DOT/M11/(1d0+ENER1/M11))/M11
+ ! Plab=P1 for particle I;store in matrix OUT(K,I,3), update
+ ! new M11 and new p1loc()=ploc()-p1loc().
+ P2=0d0
+ DO J=1,3
+ ploc(J)=ploc(J)+A*p1loc(J) !Store new ploc().
+ P2=P2+ploc(J)*ploc(J) !Get square of ploc() vector.
+ p1loc(J)=p1loc(J)-ploc(J) !Update p1loc()
+ ENDDO
+ ENERGY=SQRT(P2+M(I)**2) !Store new ENERGY.
+ M11=MEFFloc(I-1) ! Update M11.
+c WRITE (5,2600) M(I),ENERGY,ploc(1),ploc(2),ploc(3)
+ pnew(5,i) = m(i)
+ pnew(4,i) = sqrt(m(i)**2+ploc(1)**2+ploc(2)**2+ploc(3)**2)
+ pnew(1,i) = ploc(1)
+ pnew(2,i) = ploc(2)
+ pnew(3,i) = ploc(3)
+2500 ENDDO
+c2600 FORMAT(0P,F7.4,2X,G13.7,5X,G13.7,3X,G13.7,3X,G13.7)
+ P2=0d0 ! Do LAST particle here.
+ DO J=1,3
+ ploc(J)=p1loc(J) ! Store last ploc().
+ P2=P2+ploc(J)*ploc(J)
+ ENDDO
+ ENERGY=SQRT(P2+M(1)**2) ! Store last ENERGY.
+c WRITE (5,2600) M(1),ENERGY,ploc(1),ploc(2),ploc(3)
+c WRITE (5,*)
+ pnew(5,1) = m(1)
+ pnew(4,1) = sqrt(m(1)**2+ploc(1)**2+ploc(2)**2+ploc(3)**2)
+ pnew(1,1) = ploc(1)
+ pnew(2,1) = ploc(2)
+ pnew(3,1) = ploc(3)
+
+ RETURN
+ END
+!-------------------------------------------------------------------------
+ FUNCTION F1(V1,V2)
+ ! Function F1(V1,V2)=SQR(1+(V1-V2)**2-2*(V1+V2))=2*(P*)/(E*).
+ implicit none
+ REAL*8 F1, F2, V1, V2
+ F2=1d0+(V1-V2)**2-2d0*(V1+V2)
+ IF (F2.LE.0d0) THEN
+ F1=0d0
+ ELSE
+ F1=SQRT(F2) ! Guard against sqr(-).
+ ENDIF
+ END
+
+
+ function M_inv_2(v01,vx1,vy1,vz1,
+ + v02,vx2,vy2,vz2)
+ real*8 M_inv_2,v01,vx1,vy1,vz1,
+ + v02,vx2,vy2,vz2
+
+ M_inv_2 = sqrt((v01+v02)**2
+ + -(vx1+vx2)**2
+ + -(vy1+vy2)**2
+ + -(vz1+vz2)**2)
+ return
+ end
+
+ function M_inv_3(v01,vx1,vy1,vz1,
+ + v02,vx2,vy2,vz2,
+ + v03,vx3,vy3,vz3)
+ real*8 M_inv_3,v01,vx1,vy1,vz1,
+ + v02,vx2,vy2,vz2,
+ + v03,vx3,vy3,vz3
+
+ M_inv_3 = sqrt((v01+v02+v03)**2
+ + -(vx1+vx2+vx3)**2
+ + -(vy1+vy2+vy3)**2
+ + -(vz1+vz2+vz3)**2)
+ return
+ end
+
+
+
+
+
+
+ subroutine jdecay(rm)
+C input px,py,pz : CM-momenta of total system
+C rm: Mass of resonance (sqrt(s))
+c for pnew and pgen :
+c first index: 1=px, 2=py, 3=pz, 4=E, 5=m0
+c second index: particle number
+ implicit none
+ include 'newpart.f'
+ real*8 pgen(5,mprt),rnd(mprt),u(3),beta(3),wt,tmp
+ real*8 wtmax,rm,sum,pi,sum1,sum2,pcms,ranf,gamma,bp,phi,qcm,r1234
+
+ parameter(pi=3.141592654)
+ integer n,nadd1,i,j,ii,k
+c
+ pgen(1,1)=0d0
+ pgen(2,1)=0d0
+ pgen(3,1)=0d0
+ pgen(5,1)=rm
+ pgen(4,1)=rm
+c
+ nadd1=nexit-1
+c
+ pgen(5,nexit)=pnew(5,nexit)
+
+c Two body decay
+c ---------------
+ if(nexit.eq.2) goto 400
+ sum=0d0
+c sum: sum of masses in the outgoing channel
+ do 20 n=1,nexit
+ sum=sum+pnew(5,n)
+ 20 continue
+
+c calculate maximum phase-space weight wtmax
+c ------------------------------------
+ wtmax=0.5d0
+ sum1=pgen(5,1)
+ sum2=sum-pnew(5,1)
+ do 200 i=1,nadd1
+ wtmax=wtmax*pcms(sum1,sum2,pnew(5,i))
+ sum1=sum1-pnew(5,i)
+ sum2=sum2-pnew(5,i+1)
+ 200 continue
+
+c generate uniform nexit-body phase space
+c --------------------------------------
+300 continue
+c first generate nexit random numbers with decreasing value
+c as excess energy distribution weights
+ rnd(1)=ranf(1)
+ do 110 i=2,nexit
+ rnd(i)=ranf(1)
+ do 120 j=i,2,-1
+ if(rnd(j).gt.rnd(j-1)) then
+ tmp=rnd(j-1)
+ rnd(j-1)=rnd(j)
+ rnd(j)=tmp
+ endif
+ 120 continue
+ 110 continue
+c last weight has to be zero
+ rnd(nexit)=0d0
+c now ?
+ wt=1d0
+ sum1=sum
+ do 330 i=2,nexit
+ sum1=sum1-pnew(5,i-1)
+ pgen(5,i)=sum1+rnd(i)*(pgen(5,1)-sum)
+ if(pgen(5,1)-sum.lt.0.0) write(6,*)'glrrrrrp'
+ wt=wt*pcms(pgen(5,i-1),pgen(5,i),pnew(5,i-1))
+ 330 continue
+ r1234=ranf(1)
+ if(wt.lt.r1234*wtmax) goto 300
+
+c carry out two-body decays in pgen frames
+c ----------------------------------------
+ 400 continue
+ do 410 i=1,nadd1
+ qcm=pcms(pgen(5,i),pgen(5,i+1),pnew(5,i))
+c u(3) is cos(theta)
+ u(3)=2d0*ranf(1)-1d0
+ phi=2d0*pi*ranf(1)
+ u(1)=sqrt(1d0-u(3)**2)*cos(phi)
+ u(2)=sqrt(1d0-u(3)**2)*sin(phi)
+ do 420 j=1,3
+ pnew(j,i)=qcm*u(j)
+ pgen(j,i+1)=-pnew(j,i)
+ 420 continue
+ pnew(4,i)=sqrt(qcm**2+pnew(5,i)**2)
+ pgen(4,i+1)=sqrt(qcm**2+pgen(5,i+1)**2)
+ 410 continue
+ do 430 j=1,4
+ pnew(j,nexit)=pgen(j,nexit)
+ 430 continue
+
+c boost pgen frames to lab frame
+c -------------------------------------------------
+ do 500 ii=1,nadd1
+ i=nexit-ii
+ do 510 j=1,3
+ beta(j)=pgen(j,i)/pgen(4,i)
+ 510 continue
+ gamma=pgen(4,i)/pgen(5,i)
+ do 520 k=i,nexit
+ bp=beta(1)*pnew(1,k)+beta(2)*pnew(2,k)+beta(3)*pnew(3,k)
+ do 530 j=1,3
+ pnew(j,k)=pnew(j,k)+gamma*beta(j)*(pnew(4,k)
+ & +bp*gamma/(gamma+1d0))
+ 530 continue
+ pnew(4,k)=gamma*(pnew(4,k)+bp)
+ 520 continue
+ 500 continue
+
+ return
+ end
+
diff --git a/Processes/UrQMD/make22.f b/Processes/UrQMD/make22.f
new file mode 100644
index 0000000000000000000000000000000000000000..72c02a21e03b8642d64ddb888f37addf78e50617
--- /dev/null
+++ b/Processes/UrQMD/make22.f
@@ -0,0 +1,2951 @@
+c$Id: make22.f,v 1.36 2003/05/02 11:06:54 weber Exp $
+C####C##1#########2#########3#########4#########5#########6#########7##
+ subroutine make22(iio,e,ii1,iiz1,mm1,xfac1,ii2,iiz2,mm2,xfac2)
+c
+cinput iio : label for exit-channel
+cinput e : $\sqrt{s}$ of process
+cinput ii1 : ID of incoming particle 1
+cinput iiz1 : $2\cdot I_3$ of incoming particle 1
+cinput mm1 : mass of incoming particle 1
+cinput xfac1 : scaling factor for preformed hadron
+cinput ii2 : ID of incoming particle 2
+cinput iiz2 : $2\cdot I_3$ of incoming particle 2
+cinput mm2 : mass of incoming particle 2
+cinput xfac2 : scaling factor for preformed hadron
+c
+c output: exit channel via common-blocks in {\tt newpart.f}
+c
+c {\tt make22} generates the final state for all scatterings and
+c decays. Due to the diverse nature of the interactions handled
+c many special cases have to be taken care of. The label {\tt iio}
+c matches in most cases the respective label in subroutine {\tt crossx},
+c which returns the respective partial cross sections.
+c
+C####C##1#########2#########3#########4#########5#########6#########7##
+ implicit none
+
+ include 'coms.f'
+ include 'options.f'
+ include 'newpart.f'
+ include 'comres.f'
+
+
+
+ integer io,iio,i1,i2,i3,i4,i,k,i1p,i1m,i2p,i2m
+ integer ifqrk1,ifqrk2,ifdiq1,ifdiq2,ifqrk3,ifqrk4,ifdiq3,ifdiq4
+ integer iq1(2),iq2(3),kq1,kq2,kqq1,kqq2,iii,iff(3)
+ real*8 sig,e,m1,m2,m3,m4,gam,mm1,mm2,m1m,m2m,xfac1,xfac2
+
+ integer iz1,iz2,iz3,iz4,errflg,icnt,ntry,ib1,ib2,i1old,i2old
+
+ logical bit
+
+
+c...functions
+ integer isoit,whichres
+ real*8 getmass,fmsr,ranf,pcms,massit,widit,mminit
+
+c...vacuum quantumnumber(s) for special string decay (don't touch)
+ real*8 valint(1)
+ common /values/ valint
+
+c...string
+ real*8 b1,b2,ba1(3),ba2(3)
+ integer j,l,ii1,ii2,iiz1,iiz2,iexopt,iddum,ibar,jbar
+ logical fboost,switips
+
+
+
+ integer ident(2,mprt)
+ real*8 part(9,mprt),ms1,ms2,msmin1,msmin2,tau,esum
+
+
+ bit=.true.
+ switips=.false.
+ io=mod(iio,200)
+ i1=ii1
+ i2=ii2
+ iz1=iiz1
+ iz2=iiz2
+ m1=mm1
+ m2=mm2
+ icnt=0
+ ntry=0
+ ibar=0
+
+ if(iabs(i1).lt.minmes)ibar=ibar+isign(1,i1)
+ if(iabs(i2).lt.minmes)ibar=ibar+isign(1,i2)
+
+c in case of a MB-reaction, sort particles (but keep track of
+c any id-switch with the 'switips'-flag)
+ if(iabs(i1).ge.minmes.and.iabs(i1).le.maxmes.and.
+ & iabs(i2).ge.minbar.and.iabs(i2).le.maxbar)then
+ call swpizm(i1,iz1,m1,i2,iz2,m2)
+ switips=.true.
+ endif
+
+ if(i1+i2.eq.0.and.iz1+iz2.eq.0.and.CTOption(20).ne.0.and.
+ . io.gt.20)goto 27 !e+e-
+
+ if(io.lt.0)goto(100,100,100,100,100,100,100,29)-io
+
+c if(i1+i2.gt.2)write(6,*)'make22:',i1,i2
+ctp060202 1007 continue
+ goto(1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,9,17,9,17,20,
+ ,9,13,23,14,12,26,27,15,14,100,29,100,14,15,14,36,36,13)io
+
+ write(6,*)'make22: unknown channel requested io:',io
+ write(6,*)' ',e,i1,iz1,m1,i2,iz2,m2
+ stop
+
+ 1 continue
+c...pp->ND
+ i3=minnuc
+ i4=mindel
+ m3=massit(i3)
+
+ call getmas(massit(i4),widit(i4),i4,isoit(i4),mminit(i4),
+ . e-m3,m3,m4)
+
+ if(ranf(0).gt.0.5d0)call swpizm(i3,iz3,m3,i4,iz4,m4)
+ goto 1008
+
+ 2 continue
+c...pp->pp*
+ i3=minnuc
+ m3=massit(i3)
+ if(bit)call getres(io,e,minnuc+1,maxnuc,i4)
+ call getmas(massit(i4),widit(i4),i4,isoit(i4),mminit(i4),
+ . e-m3,m3,m4)
+
+ if(ranf(0).gt.0.5d0)call swpizm(i3,iz3,m3,i4,iz4,m4)
+ goto 1008
+
+ 3 continue
+c...pp->ND*
+ i3=minnuc
+ m3=massit(i3)
+ if(bit)call getres(io,e,mindel+1,maxdel,i4)
+ call getmas(massit(i4),widit(i4),i4,isoit(i4),mminit(i4),
+ . e-m3,m3,m4)
+
+ if(ranf(0).gt.0.5d0)call swpizm(i3,iz3,m3,i4,iz4,m4)
+ goto 1008
+
+ 4 continue
+c...pp->DD
+ i3=mindel
+ i4=mindel
+ call getmas(massit(i3),widit(i3),i3,isoit(i3),
+ . mminit(i4),e-mminit(i4),mminit(i4),m3)
+ call getmas(massit(i4),widit(i4),i4,isoit(i4),mminit(i4),
+ . e-m3,m3,m4)
+
+ if(ranf(0).gt.0.5d0)call swpizm(i3,iz3,m3,i4,iz4,m4)
+ goto 1008
+
+ 5 continue
+c...pp->DN*, DN* with factor 4/3
+ i3=mindel
+ if(bit)call getres(io,e,minnuc+1,maxnuc,i4)
+ call getmas(massit(i3),widit(i3),i3,isoit(i3),
+ . mminit(i3),e-mminit(i4),mminit(i4),m3)
+ call getmas(massit(i4),widit(i4),i4,isoit(i4),mminit(i4),
+ . e-m3,m3,m4)
+
+ if(ranf(0).gt.0.5d0)call swpizm(i3,iz3,m3,i4,iz4,m4)
+ goto 1008
+
+ 6 continue
+c...pp->DD*, DN* with factor 4/3
+ i3=mindel
+ if(bit)call getres(io,e,mindel+1,maxdel,i4)
+ call getmas(massit(i3),widit(i3),i3,isoit(i3),
+ . mminit(i3),e-mminit(i4),mminit(i4),m3)
+ call getmas(massit(i4),widit(i4),i4,isoit(i4),mminit(i4),
+ . e-m3,m3,m4)
+
+ if(ranf(0).gt.0.5d0)call swpizm(i3,iz3,m3,i4,iz4,m4)
+ goto 1008
+
+ 7 continue
+c...pp -> generate N*N*,N*D*,D*D*
+ m3=fmsr(mminit(mindel),e-mresmin)
+ m4=fmsr(mminit(mindel),e-m3)
+ if(bit)i3=whichres(m3,3)
+ if(bit)i4=whichres(m4,3)
+ if(ranf(0).gt.0.5d0)call swpizm(i3,iz3,m3,i4,iz4,m4)
+ goto 1008
+
+ 8 continue
+c...ND->DD
+ i3=mindel
+ i4=mindel
+ call getmas(massit(i3),widit(i3),i3,isoit(i3),
+ . mminit(i4),e-mminit(i4),mminit(i4),m3)
+ call getmas(massit(i4),widit(i4),i4,isoit(i4),mminit(i4),
+ . e-m3,m3,m4)
+
+ if(ranf(0).gt.0.5d0)call swpizm(i3,iz3,m3,i4,iz4,m4)
+ goto 1008
+
+ 9 continue
+ write(6,*)'make22: channel no.',io,'not implemented.'
+ stop
+
+ 10 continue
+c...MB->B',MM->M* annihilations
+ call anndec(0,m1,i1,iz1,m2,i2,iz2,e,sig,gam)
+
+ goto 2002
+c return
+
+ 11 continue
+c...MM->M'
+ call anndec(0,m1,i1,iz1,m2,i2,iz2,e,sig,gam)
+
+ goto 2002
+c return
+
+
+ 12 continue
+ write(6,*)'make22: channel no.',io,'should correspond to',
+ ,'total cross section, i.e. make22 should not be called.'
+ stop
+
+ 13 continue
+c...elastic scattering
+c
+ if(switips)then
+ call swpizm(i1,iz1,m1,i2,iz2,m2)
+ switips=.false.
+ endif
+
+ call setizm(i1,iz1,m1,i2,iz2,m2,i3,iz3,m3,i4,iz4,m4)
+
+ if(mminit(i4)+mminit(i3).gt.e)then
+ctp060926 write(6,*)'make22(el):threshold violated'
+ctp060926 write(6,*)'m3:',m3,mminit(i3)
+ctp060926 write(6,*)'m4:',m4,mminit(i4)
+ else
+c
+c
+ if(m3.lt.mminit(i3))m3=mminit(i3)
+ if(m4.lt.mminit(i4))m4=mminit(i4)
+ end if
+
+ goto 2001
+
+ 14 continue
+c...inelastic scattering (aqm for nonstrange resonances)
+c for arbitrary resonances getinw should be modified
+c arbitrary particles are excited (whithout charge exchange)
+
+c...get minimal masses
+ call getirg(i1,i1m,i1p)
+ m1m=mminit(i1m)
+ call getirg(i2,i2m,i2p)
+ m2m=mminit(i2m)
+
+ if(e-m1m-m2m.le.0d0)then
+c...elastic scattering
+ call setizm(i1,iz1,m1,i2,iz2,m2,i3,iz3,m3,i4,iz4,m4)
+ goto 2001
+c return
+ end if
+
+c...masses
+ if(ranf(0).lt.5d-1)then
+ m3=fmsr(m1m,e-m2m)
+ m4=fmsr(m2m,e-m3)
+ else
+ m4=fmsr(m2m,e-m1m)
+ m3=fmsr(m1m,e-m4)
+ end if
+
+ if(e-m3-m4.lt.0d0)goto 13
+
+c...itype3
+ if(i1m.lt.i1p.and.widit(i1m).lt.1d-3.and.
+ . m3.le.massit(i1m+1)-0.5*widit(i1m+1))then
+c...lowest itype of this kind of particles is stable
+c & mass .lt. approximate minimal mass of lowest itype + 1
+ m3=massit(i1m)
+ i3=i1m
+ else if(i1m.eq.i1p.and.widit(i1m).lt.1d-3) then
+c...class with only one narrow particle
+ i3=i1
+ m3=massit(i3)
+ else
+c...itypes of this kind are all unstable
+ call whichi(i3,i1m,i1p,m3)
+ end if
+
+c...itype4
+ if(i2m.lt.i2p.and.widit(i2m).lt.1d-3.and.
+ . m4.le.massit(i2m+1)-0.5*widit(i2m+1))then
+c...lowest itype of this kind of particles is stable
+ m4=massit(i2m)
+ i4=i2m
+ else if(i2m.eq.i2p.and.widit(i2m).lt.1d-3) then
+c...class with only one narrow particle
+ i4=i2
+ m4=massit(i4)
+ else
+c...itypes of this kind are all unstable
+ call whichi(i4,i2m,i2p,m4)
+ end if
+
+c...no charge transfer
+ iz3=iz1
+ iz4=iz2
+ i3=isign(i3,ii1)
+ i4=isign(i4,ii2)
+ goto 2001
+c return
+
+ 15 continue
+c...XX -> 2 strings
+ if(CTOption(12).ne.0)then
+ write(6,*)' *** error(make22): string section is called ',
+ . 'while strings are switched off:CTOption(12).ne.0'
+ stop
+ end if
+
+c
+ if(switips)then
+ call swpizm(i1,iz1,m1,i2,iz2,m2)
+ switips=.false.
+ endif
+
+
+c store old itypes
+ i1old=i1
+ i2old=i2
+
+ 155 continue
+
+c allow for deexcitation: 'excitation' starts from groundstate
+
+ if(iabs(i1).ge.minmes)then
+c.. meson resonances may also be deexcitated: assign the particle
+c id's of the lowest multiplet (with the same quark content)
+ call ityp2id(i1,iz1,iq1(1),iq1(2))
+ if(iabs(iq1(1)).gt.iabs(iq1(2)))then
+ iddum=iq1(1)
+ iq1(1)=iq1(2)
+ iq1(2)=iddum
+ endif
+ iddum=isign(100*iabs(iq1(1))+10*iabs(iq1(2)),iq1(1))
+ call id2ityp(iddum,0d0,i1,iz1)
+ else
+ call getirg(i1,i1m,i1p)
+ endif
+
+c same for second particle
+ if(iabs(i2).ge.minmes)then
+ call ityp2id(i2,iz2,iq1(1),iq1(2))
+ if(iabs(iq1(1)).gt.iabs(iq1(2)))then
+ iddum=iq1(1)
+ iq1(1)=iq1(2)
+ iq1(2)=iddum
+ endif
+ iddum=isign(100*iabs(iq1(1))+10*iabs(iq1(2)),iq1(1))
+ call id2ityp(iddum,0d0,i2,iz2)
+ else
+ call getirg(i2,i2m,i2p)
+ endif
+
+c
+c BEWARE: now i1 and i2 do not contain anymore the ityps of the ingoing
+c particles, but the ityps of the lowest possible states (groundstates).
+c This is needed in order for the string-excitation to be able to
+c excite ALL states and not only those above the state of the ingoing
+c particle.
+c If you need the old ityps (i.e. for elastic scattering) then reset them
+c via i1old and i2old
+
+
+c if the incoming masses are changed due to excitation, then the
+c new masses should not be lower than:
+ m1m=mminit(i1)
+ m2m=mminit(i2)
+
+c..discriminate between BB and MB collisions:
+ ib1=1
+ ib2=1
+ if(iabs(i1).ge.minmes)ib1=0
+ if(iabs(i2).ge.minmes)ib2=0
+
+
+c set minimum energy for the two strings
+ msmin1=m1m+CTParam(2)
+ msmin2=m2m+CTParam(2)
+
+c no (meson) string below 1 gev:
+ if(msmin1.lt.1d0)msmin1=1d0
+ if(msmin2.lt.1d0)msmin2=1d0
+
+c if energy too low: do elastic collision
+ if(m1m+m2m+CTParam(34).ge.e)then
+ctp060926 write(*,*)'make22: not enough energy for string exc. ->elastic/
+ctp060926 &deexcitation'
+ctp060926 write(*,*)' i1, i2, m1, m2, e: ',i1,i2,m1,m2,e
+ i1=i1old
+ i2=i2old
+ goto 13
+ endif
+
+
+c convert to quark-IDs
+ call ityp2id(i1,iz1,ifdiq1,ifqrk1)
+ call ityp2id(i2,iz2,ifdiq2,ifqrk2)
+
+ iexopt=CTOption(22)
+ 81 continue
+c 100 tries for excitation, otherwise elastic scattering
+ ntry=ntry+1
+ if(ntry.gt.100)then
+ctp060926 write(*,*)'make22: too many tries for string exc. ->elastic/
+ctp060926 & deexcitation'
+ctp060926 write(*,*)' i1, i2, m1, m2, e: ',i1,i2,m1,m2,e
+ i1=i1old
+ i2=i2old
+ goto 13
+ endif
+
+c string-excitation:
+c get string masses ms1,ms2 and the leading quarks
+ call STREXCT(IFdiq1,IFqrk1,ib1,M1m,
+ & ifdiq2,ifqrk2,ib2,M2m,E,
+ & iexopt,
+ & ba1,ms1,ba2,ms2,
+ & ifdiq3,ifqrk3,ifdiq4,ifqrk4)
+c the boost parameters are now fixed for the masses ms1, ms2. If the
+c masses will be changed, set the parameter fboost to "false":
+ fboost=.true.
+
+c accept deexcitation of one of the hadrons:
+ if(ms1.le.msmin1.and.ms2.ge.msmin2)then
+ ms1=massit(i1)
+ fboost=.false.
+ else if(ms2.le.msmin2.and.ms1.ge.msmin1)then
+ ms2=massit(i2)
+ fboost=.false.
+c don't accept elastic-like (both masses too low):
+ else if(ms1.lt.msmin1.and.ms2.lt.msmin2)then
+ goto 81
+ endif
+
+c in case of deexcitation new masses are necessary
+c single diffractive, mass excitation according 1/m
+ if(ms1.le.msmin1)then
+ ms2=fmsr(msmin2,e-ms1)
+ fboost=.false.
+ elseif(ms2.le.msmin2)then
+ ms1=fmsr(msmin1,e-ms2)
+ fboost=.false.
+ endif
+
+c quark-quark scattering -> only elastic !
+ if(xfac1.lt..999d0.and.xfac2.lt..999d0
+ & .and.ranf(0).lt..25) then
+ i1=i1old
+ i2=i2old
+ goto 13
+ endif
+
+c single diffractive if one particle is a quark state,
+c mass excitation according 1/m
+ if(xfac1.lt..999d0.and.ranf(0).lt..5)then
+ ms1=massit(i1)
+ ms2=fmsr(msmin2,e-ms1)
+ fboost=.false.
+ elseif(xfac2.lt..999d0.and.ranf(0).lt..5)then
+ ms2=massit(i2)
+ ms1=fmsr(msmin1,e-ms2)
+ fboost=.false.
+ endif
+
+c take care that the particles will be able to decay lateron:
+ if(ms1.lt.m1m)then
+ ms1=m1m
+ fboost=.false.
+ endif
+ if(ms2.lt.m2m)then
+ ms2=m2m
+ fboost=.false.
+ endif
+
+c avoid energy conservation violation
+ if(ms1+ms2.gt.e)goto 155
+
+ if(CTOption(22).ne.1.or..not.fboost)then
+c the boost parameters have to be calculated:
+ b1=2.*e*pcms(e,ms1,ms2)/(e**2+ms1**2-ms2**2)
+ b2=2.*e*pcms(e,ms1,ms2)/(e**2-ms1**2+ms2**2)
+ ba1(3)=+b1
+ ba2(3)=-b2
+ do 151 j=1,2
+ ba1(j)=0d0
+ 151 ba2(j)=0d0
+ end if
+
+c now write information to newpart common-blocks
+ mstring(1)=ms1
+ mstring(2)=ms2
+
+c string#1
+ if(ms1.le.msmin1)then
+ nstring1=1
+ l=1
+ do j=1,3
+ part(j,l)=0d0
+ part(j+5,l)=0d0
+ enddo
+ part(4,l)=ms1
+ part(4+5,l)=0d0
+ part(5,l)=ms1
+ ident(1,l)=i1
+ ident(2,l)=iz1
+ else
+ call qstring(ifdiq3,ifqrk3,ms1,part,ident,nstring1)
+ if(nstring1.eq.0) goto 155
+ end if
+
+ esum=0d0
+
+ jbar=0
+
+ do l=1,nstring1
+ pnew(5,l)=part(5,l)
+ itypnew(l)=ident(1,l)
+
+ if(iabs(ident(1,l)).lt.minmes)jbar=jbar+isign(1,ident(1,l))
+
+ i3new(l)=ident(2,l)
+ do j=1,4
+ pnew(j,l)=part(j,l)
+ xnew(j,l)=part(j+5,l)
+ enddo
+ pnew(3,l)=part(3,l)
+ xnew(3,l)=part(3+5,l)
+ call rotbos(0d0,0d0,ba1(1),ba1(2),ba1(3),
+ , pnew(1,l),pnew(2,l),pnew(3,l),pnew(4,l))
+ call rotbos(0d0,0d0,ba1(1),ba1(2),ba1(3),
+ , xnew(1,l),xnew(2,l),xnew(3,l),xnew(4,l))
+ esum=esum+pnew(4,l)
+ enddo
+ call leadhad(1,nstring1,1)
+
+
+c string #2
+ if(ms2.le.msmin2) then
+ nstring2=1
+ l=1
+ do j=1,3
+ part(j,l)=0d0
+ part(j+5,l)=0d0
+ enddo
+ part(4,l)=ms2
+ part(4+5,l)=0d0
+ part(5,l)=ms2
+ ident(1,l)=i2
+ ident(2,l)=iz2
+ else
+ call qstring(ifdiq4,ifqrk4,ms2,part,ident,nstring2)
+ if(nstring2.eq.0) goto 155
+ end if
+
+ esum=0d0
+ do l=1,nstring2
+ pnew(5,nstring1+l)=part(5,l)
+ itypnew(nstring1+l)=ident(1,l)
+
+ if(iabs(ident(1,l)).lt.minmes)jbar=jbar+isign(1,ident(1,l))
+
+ i3new(nstring1+l)=ident(2,l)
+ do j=1,4
+ pnew(j,nstring1+l)=part(j,l)
+ xnew(j,nstring1+l)=part(j+5,l)
+ enddo
+ pnew(3,nstring1+l)=-pnew(3,nstring1+l)
+ xnew(3,nstring1+l)=-xnew(3,nstring1+l)
+ call rotbos(0d0,0d0,ba2(1),ba2(2),ba2(3),
+ , pnew(1,nstring1+l),pnew(2,nstring1+l),pnew(3,nstring1+l),
+ , pnew(4,nstring1+l))
+ call rotbos(0d0,0d0,ba2(1),ba2(2),ba2(3),
+ , xnew(1,nstring1+l),xnew(2,nstring1+l),xnew(3,nstring1+l),
+ , xnew(4,nstring1+l))
+ esum=esum+pnew(4,nstring1+l)
+ enddo
+ call leadhad(nstring1+1,nstring1+nstring2,1)
+
+c error check
+ctp060926 if(ibar.ne.jbar)then
+ctp060926 write(6,*)' *** (E) no baryon number conservation', ibar,jbar
+ctp060926 write(6,*)' ',i1,i2,ms1,ms2
+ctp060926 write(6,'(5i4)')(itypnew(l),l=1,nstring1+nstring2)
+ctp060926 end if
+
+
+ return
+
+
+ctp060202 718 format(i2,i4,i3,1x,10(f10.4,1x))
+
+
+
+ 17 continue
+
+ iz3=iz1
+ iz4=iz2
+ i3=i1
+ i4=i2
+
+
+ m3=m1
+ m4=m2
+
+c the following lines MUST be there in order to set nucleons on-shell
+c after their first collision
+ if(m3.lt.mminit(i3))m3=mminit(i3)
+ if(m4.lt.mminit(i4))m4=mminit(i4)
+
+
+ goto 2001
+
+ 20 continue
+c...decays
+ if(ityptd(1,pslot(1)).eq.0) then
+c normal decay
+c note: m4,i4 and iz4 are dummies in this call
+ call anndec(1,m1,i1,iz1,m4,i4,iz4,e,sig,gam)
+ else
+c forward time-delay
+ pnew(5,1)=fmasstd(1,pslot(1))
+ itypnew(1)=ityptd(1,pslot(1))
+ i3new(1)=iso3td(1,pslot(1))
+ pnew(5,2)=fmasstd(2,pslot(1))
+ itypnew(2)=ityptd(2,pslot(1))
+ i3new(2)=iso3td(2,pslot(1))
+ endif
+
+ if(nexit.eq.2) then
+ i3=itypnew(1)
+ iz3=i3new(1)
+ m3=pnew(5,1)
+ i4=itypnew(2)
+ iz4=i3new(2)
+ m4=pnew(5,2)
+ goto 2001
+ else
+c three or four body decay
+ nstring1=1
+ nstring2=nexit-1
+ do i=1,4
+ do j=1,nexit
+ pnew(i,j)=0d0
+ xnew(i,j)=0d0
+ end do
+ end do
+ mstring(1)=pnew(5,1)
+c
+ mstring(2)=pnew(5,2)
+ do 91 j=3,nexit
+ mstring(2)=mstring(2)+pnew(5,j)
+ 91 continue
+c
+c now call routine for momentum phase space...
+ call nbodydec(e)
+ return
+ endif
+
+ 23 continue
+c...annihilation -> string
+ if(CTOption(12).ne.0)then
+ write(6,*)' *** error(make22): string section is called ',
+ . 'while strings are switched off:CTOption(12).ne.0'
+ stop
+ end if
+
+ ms1=e/2.
+ ms2=e/2.
+ mstring(1)=ms1
+ mstring(2)=ms2
+
+c determine flavour content of b-bbar-system
+ call ityp2id(i1,iz1,ifdiq1,ifqrk1)
+ call ityp2id(i2,iz2,ifdiq2,ifqrk2)
+c...create string 1 out of quark-antiquark pair
+ call qstring(ifqrk1,ifqrk2,ms1,part,ident,nstring1)
+ esum=0d0
+
+ do k=1,nstring1
+ l=k
+ do j=1,4
+ pnew(j,l)=part(j,l)
+ xnew(j,l)=part(j+5,l)
+ enddo
+ esum=esum+pnew(4,l)
+ pnew(5,l)=part(5,l)
+ itypnew(l)=ident(1,l)
+ i3new(l)=ident(2,l)
+ tau=part(9,l)/ (part(4,l)/part(5,l))
+ enddo
+ call leadhad(1,nstring1,0)
+
+c...create string 2 out of diquark-antidiquark-pair
+c use one quark and one antiquark for the string-ends:
+ ifqrk1=int(ifdiq1/1000)
+ ifqrk2=int(ifdiq2/1000)
+c...store remaining flavour quantum numbers in ctp(26), they will
+c be passed to the 'clustr'-routine:
+ ifdiq1=mod(ifdiq1/100,10)
+ ifdiq2=mod(ifdiq2/100,10)
+ valint(1)=dble(((abs(ifdiq1*10.d0)+abs(ifdiq2*1.d0))
+ & *isign(1,ifdiq1)))
+ valint(1)=sign(valint(1),dble(ifdiq1))
+ call qstring(ifqrk1,ifqrk2,ms2,part,ident,nstring2)
+ valint(1)=0.d0
+ esum=0d0
+
+ do l=1,nstring2
+ do j=1,4
+ pnew(j,nstring1+l)=part(j,l)
+ xnew(j,nstring1+l)=part(j+5,l)
+ enddo
+ esum=esum+pnew(4,nstring1+l)
+ pnew(5,nstring1+l)=part(5,l)
+ itypnew(nstring1+l)=ident(1,l)
+ i3new(nstring1+l)=ident(2,l)
+ tau=part(9,nstring1+l)/ (part(4,l)/part(5,l))
+ enddo
+ call leadhad(nstring1+1,nstring1+nstring2,0)
+
+ return
+
+ 26 continue
+c...elastic MB scattering (the outgoing particle id's must not be
+c assigned randomly like at label 2001)
+c
+ if(switips)then
+ call swpizm(i1,iz1,m1,i2,iz2,m2)
+ switips=.false.
+ endif
+
+ call setizm(i1,iz1,m1,i2,iz2,m2,i3,iz3,m3,i4,iz4,m4)
+
+ if(mminit(i4)+mminit(i3).gt.e)then
+ctp060926 write(6,*)'make22(el):threshold violated'
+ctp060926 write(6,*)'m3:',m3,mminit(i3)
+ctp060926 write(6,*)'m4:',m4,mminit(i4)
+ else
+ if(m3.lt.mminit(i3))m3=mminit(i3)
+ if(m4.lt.mminit(i4))m4=mminit(i4)
+ end if
+
+c... get momenta & fill newpart, 2 particle exit-channel
+
+ nstring1=1
+ nstring2=1
+ nexit=2
+ do i=1,4
+ do j=1,2
+ pnew(i,j)=0d0
+ xnew(i,j)=0d0
+ end do
+ end do
+
+c...boost to 2-particle cms
+
+ pnew(3,1)=pcms(e,m3,m4)
+ pnew(3,2)=-pcms(e,m3,m4)
+
+ pnew(4,1)=sqrt(m3**2+pnew(3,1)**2)
+ pnew(4,2)=sqrt(m4**2+pnew(3,2)**2)
+
+ pnew(5,1)=m3
+ mstring(1)=m3
+ itypnew(1)=i3
+ i3new(1)=iz3
+
+ pnew(5,2)=m4
+ mstring(2)=m4
+ itypnew(2)=i4
+ i3new(2)=iz4
+
+ return
+
+ 27 continue
+c XX-> 1 string : e+e- , MB
+ if(CTOption(12).ne.0)then
+ write(6,*)' *** error(make22): string section is called ',
+ . 'while strings are switched off:CTOption(12).ne.0'
+ stop
+ end if
+
+c quark-quark scattering -> only elastic !
+ if(xfac1.lt..999d0.and.xfac2.lt..999d0
+ & .and.ranf(0).lt.0.25) goto 26
+
+ ms1=e
+ mstring(1)=ms1
+ mstring(2)=0d0
+
+c determine flavour content of string
+ if(CTOption(20).eq.1)then
+c..e+e- annihilation
+ if(ranf(0).lt.CTParam(6))then
+ ifqrk1=3 ! ssbar
+ ifqrk2=-3
+ else
+ call ityp2id(104,0,ifqrk1,ifqrk2) ! qqbar
+ end if
+ else
+c...MB annihilation. the quark content must be known:
+ call ityp2id(i2,iz2,iq1(1),iq1(2))
+ call ityp2id(i1,iz1,ifdiq2,iq2(3))
+
+ if(abs(i1).ge.minmes) then
+ iq2(1)=ifdiq2
+ iq2(2)=iq2(3)
+ iq2(3)=0
+ else
+ iq2(1)=mod(ifdiq2/100,10)
+ iq2(2)=int(ifdiq2/1000)
+ endif
+
+ do 312 kq1=1,2
+ do 412 kq2=1,3
+c..two of the quarks must be able to annihilate:
+ if(iq1(kq1)+iq2(kq2).eq.0) then
+ kqq1=kq1
+ kqq2=kq2
+ goto 414
+ endif
+ 412 continue
+ 312 continue
+ goto 26 ! could not create double charged strange baryon string
+ 414 continue
+c.. the 'iff'-quarks constitute the produced (anti-)baron
+ iff(1)=iq1(3-kqq1)
+ iii=1
+ do 512 kq2=1,3
+ if (kq2.ne.kqq2) then
+ iii=iii+1
+ iff(iii)=iq2(kq2)
+ endif
+ 512 continue
+
+ if(abs(i1).lt.minmes) then
+ call mquarks(iff,ifqrk1,ifqrk2)
+ else
+ ifqrk1=iff(1)
+ ifqrk2=iff(2)
+ endif
+
+ endif
+
+c...create string 1 out of quark-antiquark pair
+ call qstring(ifqrk1,ifqrk2,ms1,part,ident,nstring1)
+ esum=0d0
+
+c primitive bug-fix:
+ if(nstring1.eq.0)then
+ctp060926 write(6,*)'make22: iline 27 not completed. ->elastic'
+ goto 26
+ endif
+
+ do 101 k=1,nstring1
+ l=k
+c no leading hadron in e+e-
+ if(CTOption(20).eq.1)then
+ leadfac(l)=0.0d0
+ endif
+ do 102 j=1,4
+ pnew(j,l)=part(j,l)
+ xnew(j,l)=part(j+5,l)
+ 102 continue
+ esum=esum+pnew(4,l)
+ pnew(5,l)=part(5,l)
+ itypnew(l)=ident(1,l)
+ i3new(l)=ident(2,l)
+ tau=part(9,l)/ (part(4,l)/part(5,l))
+ 101 continue
+ if(CTOption(20).eq.1)then
+ call leadhad(1,nstring1,3)
+ else
+ call leadhad(1,nstring1,1)
+ endif
+
+ nstring2=0
+ return
+
+
+ 29 continue
+c...DD->ND detailed balance
+ i3=minnuc
+ i4=mindel
+ m3=massit(i3)
+ m4=getmass(e-m3,0)
+ if(iabs(iz1+iz2).gt.isoit(i3)+isoit(i4))then
+ iz3=-9
+ iz4=-9
+ else
+ nexit=2
+ itot(1)=isoit(i3)
+ itot(2)=isoit(i4)
+ call isocgk4(isoit(i1),iz1,isoit(i2),iz2,itot,i3new,errflg)
+ i3=isign(i3,ii1)
+ i4=isign(i4,ii2)
+ iz3=i3new(1)
+ iz4=i3new(2)
+ end if
+
+ if(ranf(0).gt.0.5d0)call swpizm(i3,iz3,m3,i4,iz4,m4)
+ goto 2001
+
+
+ 100 continue
+c...??->NN detailed balance inverse channels
+c iso3 are assigned in detbal
+ nexit=2
+ i3=minnuc
+ i4=minnuc
+ m3=massit(minnuc)
+ m4=massit(minnuc)
+ itot(1)=isoit(i3)
+ itot(2)=isoit(i4)
+ call isocgk4(isoit(i1),iz1,isoit(i2),iz2,itot,i3new,errflg)
+ i3=isign(i3,ii1)
+ i4=isign(i4,ii2)
+ iz3=i3new(1)
+ iz4=i3new(2)
+
+ if(ranf(0).gt.0.5d0)call swpizm(i3,iz3,m3,i4,iz4,m4)
+ goto 2001
+
+
+ 36 continue
+c...MB->B',MM->M* annihilations (forward time delay)
+ call anndec(0,m1,i1,iz1,m2,i2,iz2,e,sig,gam)
+ goto 2003
+
+ 1008 continue
+c...get isospin-3 components
+
+ nexit=2
+ itot(1)=isoit(i3)
+ itot(2)=isoit(i4)
+ call isocgk4(isoit(i1),iz1,isoit(i2),iz2,itot,i3new,errflg)
+ iz3=i3new(1)
+ iz4=i3new(2)
+
+ctp060926 if(errflg.ne.0)then
+ctp060926 write(6,*)'make22: iso-spin conservation ',
+ctp060926 , 'not possible in isocgk: error-flag=',errflg
+ctp060926 write(6,*)' ',isoit(i1),iz1,isoit(i2),iz2,'>',
+ctp060926 , isoit(i3),isoit(i4),iz3,iz4,
+ctp060926 , ' process:',e,i1,m1,i2,m2,'>',i3,m3,i4,m4,'io=',io
+ctp060926 end if
+ i3=isign(i3,ii1)
+ i4=isign(i4,ii2)
+
+ 2001 continue
+
+
+c... get momenta & fill newpart, 2 particle exit-channel
+
+ nstring1=1
+ nstring2=1
+ nexit=2
+ do i=1,4
+ do j=1,2
+ pnew(i,j)=0d0
+ xnew(i,j)=0d0
+ end do
+ end do
+
+c...boost to 2-particle cms
+
+
+ if(.not.(ityptd(1,pslot(1)).ne.0.and.CTOption(34).eq.2.and.
+ & iline.eq.20)) then
+c normal decay
+
+ pnew(3,1)=pcms(e,m3,m4)
+ pnew(3,2)=-pcms(e,m3,m4)
+
+ pnew(4,1)=sqrt(m3**2+pnew(3,1)**2)
+ pnew(4,2)=sqrt(m4**2+pnew(3,2)**2)
+ else
+c forward time delay
+ pnew(1,1)=pxtd(1,pslot(1))
+ pnew(1,2)=pxtd(2,pslot(1))
+ pnew(2,1)=pytd(1,pslot(1))
+ pnew(2,2)=pytd(2,pslot(1))
+ pnew(3,1)=pztd(1,pslot(1))
+ pnew(3,2)=pztd(2,pslot(1))
+ pnew(4,1)=p0td(1,pslot(1))
+ pnew(4,2)=p0td(2,pslot(1))
+ endif
+
+ pnew(5,1)=m3
+ mstring(1)=m3
+ itypnew(1)=i3
+ i3new(1)=iz3
+
+ pnew(5,2)=m4
+ mstring(2)=m4
+ itypnew(2)=i4
+ i3new(2)=iz4
+
+ return
+
+ 2002 continue
+c... fill newpart, one particle exit channel
+ nstring1=1
+ nstring2=0
+ nexit=1
+ do i=1,4
+ pnew(i,1)=0d0
+ xnew(i,1)=0d0
+ end do
+ pnew(4,1)=e
+ mstring(1)=e
+c the rest of the relevant new particle data have been
+c filled into the newpart arrays by anndex
+
+ return
+
+ 2003 continue
+c bookkeeping for forward time-delay
+ do 204 j=1,2
+ if(pslot(j).lt.1) goto 204
+ pold(1,j)=px(pslot(j))
+ pold(2,j)=py(pslot(j))
+ pold(3,j)=pz(pslot(j))
+ pold(4,j)=p0(pslot(j))
+ pold(5,j)=fmass(pslot(j))
+ itypold(j)=ityp(pslot(j))
+ iso3old(j)=iso3(pslot(j))
+ 204 continue
+
+c... fill newpart, one particle exit channel
+ nstring1=1
+ nstring2=0
+ nexit=1
+ do i=1,4
+ pnew(i,1)=0d0
+ xnew(i,1)=0d0
+ end do
+ pnew(4,1)=e
+ mstring(1)=e
+
+ return
+ end
+
+
+C####C##1#########2#########3#########4#########5#########6#########7##
+ real*8 function rnfxf(b,xm,xp)
+c
+cinput b : parameter
+cinput xm : lower interval boundary
+cinput xp : upper interval boundary
+c
+c {\tt rnfxf} yields a value $x$ between {\tt xm} and {\tt xp}
+c distributetd like $(1-x)^b/x$.
+c
+cccccCcc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc
+ implicit none
+ real*8 xm,xp,i,inv,x,fmin,fmax,f,ranf,b
+
+ i(x)=log(x)
+ inv(x)=exp(x)
+
+ fmin=i(xm)
+ fmax=i(xp)
+ 3 f=fmin+(fmax-fmin)*ranf(0)
+ x=inv(f)
+ if(ranf(0).gt.(1d0-x/xp)**b)goto 3
+ rnfxf=x
+
+ return
+ end
+
+C####C##1#########2#########3#########4#########5#########6#########7##
+ subroutine setizm(i1,iz1,m1,i2,iz2,m2,i3,iz3,m3,i4,iz4,m4)
+c
+c input : {\tt i1,iz1,m1,i2,iz2,m2}
+c output : {\tt i3,iz3,m3,i4,iz4,m4}
+c
+c This subroutine simply maps {\tt iz1} $\to$ {\tt iz3} $\ldots$
+c {\tt m2} $\to$ {\tt m4}
+c
+cccccCcc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc
+ real*8 m1,m2,m3,m4
+ integer i1,iz1,i2,iz2,i3,iz3,i4,iz4
+ i3=i1
+ i4=i2
+ m3=m1
+ m4=m2
+ iz3=iz1
+ iz4=iz2
+ return
+ end
+
+C####C##1#########2#########3#########4#########5#########6#########7##
+ subroutine swpizm(i1,iz1,m1,i2,iz2,m2)
+c
+c
+c input : {\tt i1,iz1,m1,i2,iz2,m2}
+c output : {\tt i1,iz1,m1,i2,iz2,m2}
+c
+c This subroutine simply swaps {\tt 1} $\to$ {\tt 2} and vice versa.
+c
+c
+cccccCcc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc
+ real*8 m1,m2,ms
+ integer i1,iz1,i2,iz2,is,izs
+ is=i1
+ i1=i2
+ ms=m1
+ m1=m2
+ izs=iz1
+ iz1=iz2
+ i2=is
+ iz2=izs
+ m2=ms
+ return
+ end
+
+
+C####C##1#########2#########3#########4#########5#########6#########7##
+ real*8 function rnfpow(n,mmin,mmax)
+c
+cinput n : parameter
+cinput mmin : lower interval boundary
+cinput mmax : upper interval boundary
+c
+c {\tt rnfpow} yields a value $x$ between {\tt mmin} and {\tt mmax}
+c distributetd like $x^n$.
+c
+cccccCcc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc
+ implicit none
+ real*8 mmin,mmax,i,inv,ii,iinv,x,fmin,fmax,f,ranf
+ integer n
+
+ i(x)=x**(n+1)/(n+1)
+ inv(x)=((n+1)*x)**(1/(n+1))
+ ii(x)=log(x)
+ iinv(x)=exp(x)
+
+ if(n.eq.-1)then
+ fmin=ii(mmin)
+ fmax=ii(mmax)
+ f=fmin+(fmax-fmin)*ranf(0)
+ rnfpow=iinv(f)
+ else
+ fmin=i(mmin)
+ fmax=i(mmax)
+ f=fmin+(fmax-fmin)*ranf(0)
+ rnfpow=inv(f)
+ end if
+ return
+ end
+
+C####C##1#########2#########3#########4#########5#########6#########7##
+ real*8 function fmsr(mmin,mmax)
+c
+cinput mmin : minimum mass
+cinput mmax : maximum mass
+c
+c {\tt fmsr} yields a mass according to the finite mass sum rule (FMSR)
+c A.I.Sanda Phys.~Rev.~{\bf D6}~(1973)~231 and
+c M.B.Einhorn et al., Phys. Rev. {\bf D5}~(1972)~2063
+c
+cccccCcc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc
+ implicit none
+ real*8 mmin,mmax,rnfpow!,x
+ ! i(x)=log(x)
+ ! inv(x)=exp(x)
+
+ fmsr=rnfpow(-1,mmin,mmax)
+ return
+ end
+
+C####C##1#########2#########3#########4#########5#########6#########7##
+ subroutine getfmsr(io,mmin,mmax,ir,mr)
+c
+cinput io : class of resonance
+cinput mmin : minimum mass
+cinput mmax : maximum mass
+coutput ir : ID of resonance
+coutput mr : mass of resonance
+c
+c {\tt getfmsr} is an extension of {\tt fmsr} to simulate
+c a resonance structure at low masses
+c
+cccccCcc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc
+
+ implicit none
+ integer io,ir,whichres
+ real*8 mmin,mmax,mr,massit,widit
+ include 'comres.f'
+ real*8 fmsr,mmean
+
+ mr=fmsr(mmin,mmax)
+c...if strings come into play > modify whichres!
+ ir=whichres(mr,io)
+ mr=mmean(1,massit(ir),widit(ir),mmin,mmax)
+ return
+ end
+
+C####C##1#########2#########3#########4#########5#########6#########7##
+ SUBROUTINE STREXCT(IFL11,IFL12,IB1,AM1,IFL21,IFL22,IB2,AM2,ECM,
+ *IOPT,ba1,ams1,ba2,ams2,ifl31,ifl32,ifl41,ifl42)
+c
+cinput ifl11 : ID of (di)quark of projectile hadron
+cinput ifl12 : ID of remaining quark of projectile hadron
+cinput ib1 : baryon number of projectile hadron
+cinput am1 : mass of projectile hadron
+cinput ifl21 : ID of (di)quark of target hadron
+cinput ifl22 : ID of remaining quark of target hadron
+cinput ib2 : baryon number of target hadron
+cinput am2 : mass of target hadron
+cinput ecm : $\sqrt{s}$ of excitation
+cinput iopt : flag for excitation ansatz (1: Fritiof, 2:QGSM)
+coutput ba1 : velocity of 1st string
+coutput ams1 : mass of 1st string
+coutput ba2 : velocity vector of 2nd string
+coutput ams2 : mass of 2nd string
+coutput ifl31 : (di)quark content of 1st string
+coutput ifl32 : remainig quark content of 1st string
+coutput ifl41 : (di)quark content of 2nd string
+coutput ifl42 : remaining quark content of 2nd string
+c
+c output : particle IDs, masses and momenta via common block {\tt newpart}
+c
+c This routine performs the excitation of two strings according
+c to different ansatzes defined via parameter {\tt iopt}
+c
+cccccCcc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc
+ implicit real*8 (a-h,o-z)
+ implicit integer (i-n)
+ include 'options.f'
+
+ real*8 ba1(3),ba2(3),P(2,5),ranf
+ integer IFLS(2,2)
+
+ PARAMETER(PI=3.14159)! value of Pi
+ PARAMETER(XMAX=1.0)
+ LOGICAL SPINT,bt
+
+ sigma=CTParam(31)
+ alpha=CTParam(32)
+ betav=CTParam(33)
+ ampit=CTParam(34)
+ betas=CTParam(40)
+c
+C CHECK INITIAL ENERGY
+ IF(AM1+AM2+ampit.gt.ECM) THEN
+ WRITE(6,*) '....STOP! Initial energy is too low for string
+ * excitation, ECM=', ECM,'<',am1,'+',am2
+ STOP
+ ENDIF
+
+ bt=.false.
+ if(ranf(0).lt.5d-1)bt=.true.
+
+C COMPUTE XMIN
+ XMIN=AMPIT/ECM
+
+C COMPUTE C.M.S. HADRON MOMENTUM AND ENERGIES
+ PCMS=SQRT(ALAMB(ECM**2,AM1**2,AM2**2))/(2.0*ECM)
+ ECMS1=SQRT(PCMS**2+AM1**2)
+ ECMS2=SQRT(PCMS**2+AM2**2)
+
+C COMPUTE LIGHT-CONE VARIABLES FOR HADRON-PROJECTILE :
+C (PPLS01,PMINS01,PTX01,PTY01)
+ PPLS01=ECMS1+PCMS
+ PMINS01=ECMS1-PCMS
+ PTX01=0.
+ PTY01=0.
+
+C COMPUTE LIGHT-CONE VARIABLES FOR HADRON-TARGET :
+C (PPLS02,PMINS02,PTX02,PTY02)
+ PPLS02=ECMS2-PCMS
+ PMINS02=ECMS2+PCMS
+ PTX02=0.
+ PTY02=0.
+
+C COMPUTE TRANSFERRED TRANSVERSE MOMENTUM :
+C (QX,QY)
+100 CALL GAUSPT(QT,SIGMA)
+ PHI=2.*PI*ranf(0)
+ QX=QT*COS(PHI)
+ QY=QT*SIN(PHI)
+
+C COMPUTE XPLUS AND XMINUS VALUES FOR INTERACTING PARTONS
+c IF(IOPT.EQ.1) THEN
+ if(IOPT.eq.1.or.dabs(alpha).lt.1d-4)then
+ CALL XSDIS(XPLUS,XMIN,XMAX,BETAS)
+ CALL XSDIS(XMINUS,XMIN,XMAX,BETAS)
+ else ! IF(IOPT.EQ.2) THEN
+ XPLUS=XVDIS(XMIN,ALPHA,BETAV)
+ XMINUS=XVDIS(XMIN,ALPHA,BETAV)
+c else
+c write(6,*)'strexct: undefined excitation model'
+c stop
+ ENDIF
+C COMPUTE LIGHT-CONE PARAMETERS OF INTERACTING PARTONS :
+C (PPRPLS1,PPRMINS1,PPRX1,PPRY1)
+ PPRPLS1=XPLUS*PPLS01
+ PPRMINS1=0.
+ PPRX1=0.
+ PPRY1=0.
+C
+C (PPRPLS2,PPRMINS2,PPRX2,PPRY2)
+ PPRPLS2=0.
+ PPRMINS2=XMINUS*PMINS02
+ PPRX2=0.
+ PPRY2=0.
+C
+C COMPUTE LIGHT-CONE COMPONENT OF TRANSFERRED MOMENTUM :
+C (QPLS,QMINS)
+ QPLS=-(QT**2/PPRMINS2)
+ QMINS= QT**2/PPRPLS1
+C
+C COMPUTE LIGHT-CONE PARAMETERS AND QUARK CONTENTS FOR EXCITED STRINGS
+ IF(IOPT.EQ.1) THEN
+C FRITIOF ANSATZ :
+C P1 ---> P1 + Q
+C P2 ---> P2 - Q
+ PPLS1=PPLS01+QPLS
+ PMINS1=PMINS01+QMINS
+ PTX1=PTX01+QX
+ PTY1=PTY01+QY
+C
+ PPLS2=PPLS02-QPLS
+ PMINS2=PMINS02-QMINS
+ PTX2=PTX02-QX
+ PTY2=PTY02-QY
+C
+C NO QUARK REARRANGEMENT
+ IFLS(1,1)=IFL11
+ IFLS(1,2)=IFL12
+ IFLS(2,1)=IFL21
+ IFLS(2,2)=IFL22
+ ELSEIF(IOPT.EQ.2) THEN
+C QGSM ANSATZ :
+C P1 ---> P1 - PPR1 + PPR2 - Q
+C P2 ---> P2 - PPR2 + PPR1 + Q
+C
+ PPLS1=PPLS01-PPRPLS1+PPRPLS2-QPLS
+ PMINS1=PMINS01-PPRMINS1+PPRMINS2-QMINS
+ PTX1=PTX01-PPRX1+PPRX2-QX
+ PTY1=PTY01-PPRY1+PPRY2-QY
+C
+ PPLS2=PPLS02-PPRPLS2+PPRPLS1+QPLS
+ PMINS2=PMINS02-PPRMINS2+PPRMINS1+QMINS
+ PTX2=PTX02-PPRX2+PPRX1+QX
+ PTY2=PTY02-PPRY2+PPRY1+QY
+
+C QUARK REARRANGEMENT IS NEEDED TO CREATE COLOUR NEUTRAL STRINGS
+C (In case of Baryon-Baryon or Meson-Meson or
+C Antibaryon-Antibaryon or Meson-Antibaryon or Antibaryon-Meson
+C interaction)
+ IF((IB1.EQ.1.AND.IB2.EQ.1).OR.
+ . (IB1.EQ.-1.AND.IB2.EQ.-1).OR.
+ . (IB1.EQ.0.AND.IB2.EQ.0).OR.
+ . (IB1.EQ.0.AND.IB2.EQ.-1).OR.
+ . (IB1.EQ.-1.AND.IB2.EQ.0)) THEN
+ IFLS(1,1)=IFL11
+ IFLS(1,2)=IFL22
+ IFLS(2,1)=IFL21
+ IFLS(2,2)=IFL12
+ ENDIF
+
+C QUARK REARRANGEMENT (In case of Meson-Baryon or Antibaryon-Baryon or v.v.
+C interaction)
+ IF((IB1.EQ.0.AND.IB2.EQ.1).OR.
+ . (IB1.EQ.1.AND.IB2.EQ.0).OR.
+ . (IB1.EQ.-1.AND.IB2.EQ.1).OR.
+ . (IB1.EQ.1.AND.IB2.EQ.-1)) THEN
+ IFLS(1,1)=IFL11
+ IFLS(1,2)=IFL21
+ IFLS(2,1)=IFL22
+ IFLS(2,2)=IFL12
+ ENDIF
+ ELSE
+ PPLS1=0
+ PMINS1=0
+ PTX1=0
+ PTY1=0
+C
+ PPLS2=0
+ PMINS2=0
+ PTX2=0
+ PTY2=0
+C
+ WRITE(6,*) 'ERROR IN MAKE22: WRONG IOPT'
+ STOP
+ ENDIF
+
+C COMPUTE OUTGOING STRING MASSES. They should be more than stable hadron
+C (with the same quark content) masses. In the contrary case generation
+C should be repeated
+ AMS1S=PPLS1*PMINS1-QT**2
+ SPINT=.TRUE.
+ AMS0=0
+C COMPUTE AMS0
+ IF(MOD(IFLS(1,1),100).EQ.0.AND.MOD(IFLS(1,2),100).EQ.0) THEN
+C qq-qqbar string
+ IFLU=1 ! add u- quark to construct hadron
+C AMS0 is sum of masses of lowest baryon states
+ IFLH1=IDPARS(IFLS(1,1), -ISIGN(IFLU,IFLS(1,1)),SPINT,2)
+ IFLH2=IDPARS(IFLS(1,2), -ISIGN(IFLU,IFLS(1,2)),SPINT,2)
+ AMS0=amass(IFLH1)+amass(IFLH2)
+ ENDIF
+ IF(.NOT.(MOD(IFLS(1,1),100).EQ.0
+ . .AND.MOD(IFLS(1,2),100).EQ.0))THEN
+C AMS0 is mass of lowest hadron state
+ IKH=IDPARS(IFLS(1,1),IFLS(1,2),SPINT,2)
+ AMS0=amass(IKH)
+ ENDIF
+C
+ IF(AMS1S.LT.AMS0**2) GO TO 100
+C
+ AMS2S=PPLS2*PMINS2-QT**2
+ SPINT=.TRUE.
+C COMPUTE AMS0
+ IF(MOD(IFLS(2,1),100).EQ.0.AND.MOD(IFLS(2,2),100).EQ.0) THEN
+C qq-qqbar string
+ IFLU=1 ! add u- quark to construct hadron
+C AMS0 is sum of masses of lowest baryon states
+ IFLH1=IDPARS(IFLS(2,1),-ISIGN(IFLU,IFLS(2,1)),SPINT,2)
+ IFLH2=IDPARS(IFLS(2,2),-ISIGN(IFLU,IFLS(2,2)),SPINT,2)
+ AMS0=amass(IFLH1)+amass(IFLH2)
+ ENDIF
+ IF(.NOT.(MOD(IFLS(2,1),100).EQ.0
+ . .AND.MOD(IFLS(2,2),100).EQ.0)) THEN
+C AMS0 is mass of lowest hadron state
+ IKH=IDPARS(IFLS(2,1),IFLS(2,2),SPINT,2)
+ AMS0=amass(IKH)
+ ENDIF
+C
+ IF(AMS2S.LT.AMS0**2) GO TO 100
+C
+ AMS1=SQRT(AMS1S)
+ AMS2=SQRT(AMS2S)
+C
+C SUM OF MASSES OF EXCITED STRINGS SHOULD BE LESS THAN INITIAL ENERGY
+ IF(AMS1+AMS2.GT.ECM) GO TO 100
+C
+ P(1,1)=PTX1
+ P(1,2)=PTY1
+ P(1,3)=0.5*(PPLS1-PMINS1)
+ P(1,4)=0.5*(PPLS1+PMINS1)
+ P(1,5)=AMS1
+ P(2,1)=PTX2
+ P(2,2)=PTY2
+ P(2,3)=0.5*(PPLS2-PMINS2)
+ P(2,4)=0.5*(PPLS2+PMINS2)
+ P(2,5)=AMS2
+c
+ do 152 j=1,3
+ ba1(j)=p(1,j)/p(1,4)
+ 152 ba2(j)=p(2,j)/p(2,4)
+
+ ifl31=ifls(1,1)
+ ifl32=ifls(1,2)
+ ifl41=ifls(2,1)
+ ifl42=ifls(2,2)
+
+C
+C CHECK ENERGY-MOMENTUM CONSERVATION
+ ESTR=P(1,4)+P(2,4)
+ PSTRX=PTX1+PTX2
+ PSTRY=PTY1+PTY2
+ PSTRZ=P(1,3)+P(2,3)
+C
+ctp060926 if(abs(estr-ecm).gt.1d-12)then
+ctp060926 WRITE(6,*) 'ECM=',ECM
+ctp060926 WRITE(6,*) 'ESTR=',ESTR
+ctp060926 end if
+ctp060926 if(pstrx.gt.1d-12)WRITE(6,*) 'PSTRX=',PSTRX
+ctp060926 if(pstry.gt.1d-12)WRITE(6,*) 'PSTRY=',PSTRY
+ctp060926 if(pstrz.gt.1d-12)WRITE(6,*) 'PSTRZ=',PSTRZ
+C Note! One should also check flavour conservation!
+C
+ RETURN
+ END
+C####C##1#########2#########3#########4#########5#########6#########7##
+ real*8 FUNCTION ALAMB(X,Y,Z)
+c
+c input : {\tt x,y,z}
+c
+C THIS ROUTINE COMPUTES KINEMATICAL FUNCTION
+cccccCcc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc
+ implicit none
+ real*8 x,y,z
+
+ ALAMB=max(0d0,(X-Y-Z)*(X-Y-Z) - 4.D0*Y*Z)
+
+ RETURN
+ END
+
+C####C##1#########2#########3#########4#########5#########6#########7##
+ real*8 FUNCTION XVDIS(XMIN,ALFA,BETA)
+c
+cinput xmin : lower boundary
+cinput alfa : parameter
+cinput beta : parameter
+c
+C This function returns {\tt xmin}$ < x < 1$
+c values distributed according to the Beta-function
+C
+cccccCcc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc
+ implicit none
+ real*8 x,xmin,alfa,beta
+
+ 100 CALL SBETA(X,ALFA,BETA)
+ IF(X.LE.XMIN) GO TO 100
+ XVDIS=X
+ RETURN
+ END
+
+C####C##1#########2#########3#########4#########5#########6#########7##
+ SUBROUTINE SBETA(X,ALFA,BETA)
+c
+coutput x : Beta-distributed value
+cinput alfa : parameter
+cinput beta : parameter
+
+C THIS ROUTINE GENERATES X ACCORDING TO BETA DISTRIBUTION
+C $U(X)=C*X**(ALFA-1)*(1-X)**(BETA-1)$
+C IONK,S METHOD IS USED
+c
+cccccCcc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc
+ implicit none
+ real*8 ran1,ran2,alfa,beta,r1a,r2b,r12,x,ranf
+
+ 1 RAN1=ranf(0)
+ RAN2=ranf(0)
+ R1A=RAN1**(1./ALFA)
+ R2B=RAN2**(1./BETA)
+ R12=R1A+R2B
+ IF(R12.GE.1.) GO TO 1
+ X=R1A/R12
+ RETURN
+ END
+
+
+
+C####C##1#########2#########3#########4#########5#########6#########7##
+ SUBROUTINE XSDIS(X,XMIN,XMAX,BETA)
+c
+cinput xmin : lower boundary
+cinput xmax : upper boundary
+cinput beta : parameter
+c
+C THIS FUNCTION GENERATES $XMIN < X < XMAX$ ACCORDING TO
+C DISTRIBUTION $U(X)= 1./X*(1.-X)**(BETA+1)$ DISTRIBUTION
+C PARAMETER $BETA > 0$
+c
+cccccCcc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc
+ implicit real*8 (a-h,o-z)
+ implicit integer (i-n)
+
+ PE1=(1.-XMIN)**(BETA+1.)/(BETA+1.)-(1.-XMAX)**(BETA+1.)/
+ *(BETA+1.)
+ PE=PE1+DLOG(XMAX/XMIN)
+ PE1=PE1/PE
+ 108 RND=ranf(0)
+ RNDMPE1=ranf(0)
+ IF(RNDMPE1.GT.PE1) GO TO 200
+ X=1.-((1.-XMIN)**(BETA+1.)*(1.-RND)+(1.-XMAX)**(BETA+1.)*
+ *RND)**(1./(BETA+1.))
+ GO TO 300
+200 X=XMIN*(XMAX/XMIN)**RND
+300 PPE1=(1.-X)**BETA
+ PPE2=1./X
+ PPE1=PPE1+PPE2
+ PPE2=PPE1*PPE2
+ IF(PPE1*ranf(0).GT.PPE2) GO TO 108
+ RETURN
+ END
+
+
+C####C##1#########2#########3#########4#########5#########6#########7##
+ subroutine getres(io,e,im,ip,ir)
+c
+cinput io : resonance class
+cinput e : $\sqrt{s}$ of excitation process
+cinput im : lower boundary for resonance ID's
+cinput ip : upper boundary for resonance ID's
+coutput ir : ID of resonance
+c
+c This subroutine randomly selects a resonance ID for a given
+c resonance class ({\tt io}), collision $\sqrt{s}$ and ID possible range.
+c The selected resonance choice is weighted according to the respective
+c partial cross section for the excitation of such a resonance.
+c
+C####C##1#########2#########3#########4#########5#########6#########7##
+ implicit none
+ include 'comres.f'
+ include 'options.f'
+ integer io,i,im,ip,ir
+ real*8 e,x(minnuc:maxmes),xmax
+
+ do i=im,ip
+ call crossf(io,e,i,x(i))
+ end do
+ call getbran(x,minnuc,maxmes,xmax,im,ip,ir)
+
+ctp060926 if(ir.gt.ip.or.ir.lt.im) then
+ctp060926 write(6,*)'***(E) getres: no final state selected...'
+ctp060926 write(6,*)io,e,xmax,im,ip,ir
+ctp060926 endif
+
+ return
+ end
+
+C####C##1#########2#########3#########4#########5#########6#########7##
+ subroutine aqm(i1,i2,xt,xel)
+c
+cinput : {\tt i1,i2} : ID's of particle 1 and 2
+coutput : {\tt xt,xel}: total and elastic cross section
+c
+c This subroutine returns cross sections according
+c to the additive quark model.
+c
+C####C##1#########2#########3#########4#########5#########6#########7##
+ integer i(2),ij,j,i1,i2,strit
+ real*8 s(2),xt,xel,mn(2)
+ integer ifa, ifb, isoit
+ include 'comres.f'
+
+ i(1)=i1
+ i(2)=i2
+ do 108 j=1,2
+ ij=i(j)
+ if(iabs(ij).ge.minmes)then
+ s(j)=1d0*abs(strit(ij))
+ call ityp2id(ij, isoit(ij), ifa, ifb)
+c take care of hidden strangeness
+ if (abs(ifa).eq.3 .and. abs(ifb).eq.3) s(j)=2
+ mn(j)=1.d0
+ else
+ s(j)=1d0*abs(strit(ij))
+ mn(j)=0.d0
+ end if
+ 108 continue
+
+ xt=max(0d0,40d0*0.666667**(mn(1)+mn(2))
+ * *( 1d0-0.4*s(1)/(3d0-mn(1)) )
+ * *( 1d0-0.4*s(2)/(3d0-mn(2)) ) )
+ xel=0.039*xt**1.5d0
+ return
+ end
+
+C####C##1#########2#########3#########4#########5#########6#########7##
+ real* 8 function fppfit(iio,e,i3,i4)
+c
+c Version: 1.0
+c
+cinput iio : tag for cross section class
+cinput e : $\sqrt{s}$ of collision
+cinput i3 : ID of first outgoing particle
+cinput i4 : ID of second outgoing particle
+c
+c
+c {\tt fppfit} returns the isospin-independent part
+c of the production cross section
+c for one or two outgoing resonances ({\tt i3} and {\tt i4})
+c in a proton-proton
+c collision. {\tt io} sets the class of cross section
+c which is returned (i.e. $p p \rightarrow N \Delta$). If
+c {\tt io} is set 99 the class will be determined according
+c to {\tt i3} and {\tt i4}.
+c
+C####C##1#########2#########3#########4#########5#########6#########7##
+ implicit none
+ include 'comres.f'
+ include 'comwid.f'
+ include 'options.f'
+
+ real*8 e,tmp
+ integer i,iio,io,im,jm,id1,id2,id3,id4,i3,i4
+ integer i1m,i1p,i2m,i2p,class1,class2,iim
+c funct.
+ real*8 pmean,widit,massit,splint
+ integer jit,isoit
+
+c...parameters for resonance production in NN
+ integer nfit
+ parameter (nfit=7)
+ real*8 ar(nfit)
+ integer rr(2,nfit)
+c io = 1 2 3 4 5 6 7
+c nd nn* nd* dd dn* dd* B*B*
+ data ar/ 4d4, 6.3d0, 12d0, 2.8d0, 3.5d0, 3.5d0, 0.d0 /
+ data rr/ 4,0, 4,1, 4,2, 0,0, 0,1, 0,2, 3,3 /
+c rr tells of which particle class the out particles are
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+c hard cut: no resonant cross section at highest energies
+ if(e.gt.maxtab2)then
+ fppfit=0d0
+ return
+ endif
+c
+
+ id1=0
+ id2=0
+ id3=0
+ id4=0
+ im=i3
+ jm=i4
+
+ if(iio.eq.99)then
+c determine iline
+
+c get class of 1 particle
+ do 101 i=0,4
+ call getrange(i,i1m,i1p)
+ class1=0
+ if(im.ge.i1m.and.im.le.i1p)then
+ class1=i
+ goto 102
+ endif
+101 continue
+ write(*,*)'(E) fppfit: no x-section parametrized for ',im
+ stop
+102 continue
+c get class of 2 particle
+ do 103 i=0,4
+ call getrange(i,i2m,i2p)
+ class2=0
+ if(jm.ge.i2m.and.jm.le.i2p)then
+ class2=i
+ goto 104
+ endif
+103 continue
+ write(*,*)'(E) fppfit: no x-section parametrized for ',jm
+ stop
+104 continue
+c get iline corrsponding to pp->i3,i4
+ do 105 i=1,nfit
+ if((rr(1,i).eq.class1.and.rr(2,i).eq.class2).or.
+ v (rr(1,i).eq.class2.and.rr(2,i).eq.class1))then
+ io=i
+ goto 106
+ endif
+105 continue
+c maybe we have an R*R* reaction?
+ if(im.ge.minres.and.im.le.maxres
+ & .and.jm.ge.minres.and.jm.le.maxres)then
+ io=7
+ goto 106
+ endif
+ write(*,*)'(E) fppfit: no iline found for particles',im,jm
+ stop
+106 continue
+ else
+ io=iio
+ endif
+
+c sort particles acc. to itypes
+ if(io.ne.5.and.im.gt.jm)then
+ im=i4
+ jm=i3
+ endif
+ if(io.eq.5.and.im.lt.jm)then
+ im=i4
+ jm=i3
+ endif
+
+c consistency checks
+ call getrange(rr(1,io),i1m,i1p)
+ if(im.lt.i1m.or.im.gt.i1p)then
+ write(*,*)'(E) fppfit: wrong iline for outgoing particles',
+ & io,im,jm
+ stop
+ endif
+ call getrange(rr(2,io),i2m,i2p)
+ if(jm.lt.i2m.or.jm.gt.i2p)then
+ write(*,*)'(E) fppfit: wrong iline for outgoing particles',
+ & io,im,jm
+ stop
+ endif
+
+
+ goto(1,2,2,2,2,2,4) io
+ write(6,*) '****(E) wrong x-section ID in fppfit *****',io
+ stop
+
+c pp ->ND
+ 1 continue
+ if(wtabflg.ge.3.and.CTOption(9).eq.0)then
+c table lookup
+ iim=0
+ if(im.eq.minnuc)then
+ iim=1
+ elseif(im.eq.mindel)then
+ iim=2
+ else
+ write(*,*)'(E) fppfit: First particle should be N or Delta'
+ stop
+ endif
+ fppfit=max(0d0,splint(tabxnd,frrtaby(1,1,iim,jm),
+ & frrtaby(1,2,iim,jm),widnsp,e))
+ else
+c calculate cross section
+ fppfit=pmean(e,im,isoit(im),jm,isoit(jm),id1,id2,id3,id4,1)
+ & /(pmean(e,1,1,1,1,id1,id2,id3,id4,1)
+ & *e*e)*ar(io)
+ & *(massit(jm)**2*widit(jm)**2/((e**2-massit(jm)**2)**2
+ & +widit(jm)**2*massit(jm)**2))
+ & *dble((jit(im)+1)*(jit(jm)+1))
+ endif
+
+ return
+
+c pp->NN* pp->ND* pp->DD pp->DN* pp->DD*
+ 2 continue
+ if(wtabflg.ge.3.and.CTOption(9).eq.0)then
+c table lookup
+ iim=0
+ if(im.eq.minnuc)then
+ iim=1
+ elseif(im.eq.mindel)then
+ iim=2
+ else
+ write(*,*)'(E) fppfit: First particle should be N or Delta'
+ stop
+ endif
+ fppfit=max(0d0,splint(tabxnd,frrtaby(1,1,iim,jm),
+ . frrtaby(1,2,iim,jm),widnsp,e))
+ else
+c calculate cross section
+ tmp=pmean(e,im,isoit(im),jm,isoit(jm),id1,id2,id3,id4,1)
+ & /(pmean(e,1,1,1,1,id1,id2,id3,id4,1)
+ & *e*e)*ar(io)
+ & *dble((jit(im)+1)*(jit(jm)+1))
+ if(im.ne.jm) then
+ tmp=tmp
+ & /((massit(jm)-massit(im))**2*(massit(jm)+massit(im))**2)
+ endif
+ fppfit=tmp
+ endif
+ return
+
+c pp->B*B*
+ 4 continue
+c sofar set to zero
+ fppfit=0d0
+ return
+
+ end
+
+
+
+C####C##1#########2#########3#########4#########5#########6#########7##
+ subroutine crossx(iio,e,ii1,iiz1,mm1,ii2,iiz2,mm2,sig)
+c
+cinput iio : pointer to cross section
+cinput e : $\sqrt{s}$ of collision
+cinput ii1 : ID of particle 1
+cinput iiz1 : $2\cdot I_3$ of particle 1
+cinput mm1 : mass of particle 1
+cinput ii2 : ID of particle 2
+cinput iiz2 : $2\cdot I_3$ of particle 2
+cinput mm2 : mass of particle 2
+coutput sig : cross section
+c
+c This routine returns cross sections which are accessed via tags (pointers)
+c {\tt iio}. The cross sections can either be partial ones for specific
+c exit channels or total cross sections for the two incoming hadrons
+c
+C####C##1#########2#########3#########4#########5#########6#########7##
+ implicit none
+
+ include 'comres.f'
+ include 'options.f'
+ include 'newpart.f'
+
+ integer io,iio,i1,i2,iz1,iz2
+ integer i,im,ip,j,jm,jp,ii1,iiz1,ii2,iiz2
+c integer itmp1,itmp2,itag
+ real*8 sig,e,e0,sum,m1,m2,m3,gam,dum,s1,s2,s3
+ real*8 c1,c2,mm1,mm2,aaqm,dbfact,cgkcor,qflg,factor,ggam
+ real*8 sighelp,meltpoint2,pfrome,pmelt,pmelt2,plab
+ logical kplflag
+c...functions
+ real*8 clebsch,siglookup,bcms,massit,widit,mminit,xmelt
+ real*8 fppfit,fwidth,fbwnorm,ppiso
+c...additional functions and variables for ppbar&pp scattering:
+ real*8 bbphi,nnphi,sighera,sapptot,
+ & sappela,sappann,sappdiff,dgcgkfct
+ integer isoit,iq1(2),iq2(3),ifdiq2,kq1,kq2
+
+c
+ real*8 sigheramb,sigmb,meltpoint
+
+ logical excl
+
+ real*8 ef,sigf,ee
+ integer jf,if
+
+c...parameters for resonance production in NN
+ integer nfit
+ parameter (nfit=7)
+c real*8 er(nfit)
+ integer rr(2,nfit),in(nfit)
+ real*8 x,x0,xa,xb,xc,bf
+ real*8 f
+
+ save kplflag
+
+ f(x,x0,xa,xb,xc)=max(0d0,2.*xb*xa*(x-x0)/(xb**2+(x-x0)**2))*
+ * ((x0+xb)/(x))**xc
+
+
+c io = 1 2 3 4 5 6 7
+c nd nn* nd* dd dn* dd* B*B*
+c data er/ 4d-2, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0/
+ data rr/ 4,0, 4,1, 4,2, 0,0, 0,1, 0,2, 3,3 /
+c rr tells of which particle class the out particles are
+ data in/ 1, 1, 1, 1, -1, 1, 1 /
+c in tells which out particle has the higher itype
+
+
+ excl=.false. !flag for exclusive cross section(detailed balance)
+
+ kplflag=.false. ! flag for k+ p total x-section
+
+ goto 107
+
+ entry crossf(if,ef,jf,sigf)
+ io=if
+ ee=ef
+ j=jf
+ call getrange(rr(1,io),i,ip) ! call getrange(rr(2,io),jm,jp)
+
+ sigf=fppfit(io,ee,i,j)
+
+ return
+
+ entry crossz(iio,e,ii1,iiz1,mm1,ii2,iiz2,mm2,sig)
+
+ excl=.true. !flag for exclusive cross section(detailed balance)
+
+ 107 continue
+
+c...some settings for all channels enter here
+ sig=0d0
+ io=iabs(iio)
+ aaqm=CTParam(3) !exponent for bcm scaled AQM-cross sections
+
+ call setizm(ii1,iiz1,mm1,ii2,iiz2,mm2,
+ ,i1,iz1,m1,i2,iz2,m2)
+
+c in case of a MB-reaction, sort particles: meson must be second (i2)
+ if(iabs(i1).ge.minmes.and.iabs(i1).le.maxmes.and.
+ & iabs(i2).ge.minbar.and.iabs(i2).le.maxbar)then
+ call swpizm(i1,iz1,m1,i2,iz2,m2)
+ endif
+
+
+ goto(1,1,1,1,1,1,1,8,9,10,
+ , 11,12,13,14,15,16,17,18,19,9,21,22,23,24,
+ , 25,26,27,28,29,30,31,32,33,34,35,36,37,38)io
+
+
+ write(6,*)'cross[x,z]: ',
+ ,' unknown channel requested, wrong io:',io
+ stop
+
+
+ 1 continue
+c...pp-> ND pp->NN* pp->ND* pp->DD pp->DN* pp->DD*
+ call setizm(iabs(ii1),iiz1,mm1,iabs(ii2),iiz2,mm2,
+ ,i1,iz1,m1,i2,iz2,m2)
+c fist outgoing particle has lower ID
+ if(i1.gt.i2)call swpizm(i1,iz1,m1,i2,iz2,m2)
+
+c determine range for first outgoing particle
+ call getrange(rr(1,io),im,ip)
+
+
+ if(excl)then
+cut down the loop to one resonance for inverse exclusive processes
+ jm=in(io)*max0(in(io)*i1,in(io)*i2)
+ jp=jm
+ else
+ call getrange(rr(2,io),jm,jp)
+
+ end if
+ sum=0.
+
+ do i=im,ip
+c...loop over i3 (1st outgoing particle)
+ do j=jm,jp
+c...loop over i4 (2nd outgoing particle)
+c sum over x-section
+
+c explicit isospin dependence
+ cgkcor=ppiso(iio,i1,iz1,i2,iz2,i,j)
+
+ sum=sum+fppfit(io,e,i,j)*cgkcor
+ end do
+ end do
+ sig=sum
+c
+c detailed balance
+ if(iio.lt.0.and.sig.gt.1.d-12) then
+
+
+ call detbal(e,i1,i2,iz1,iz2,max(mminit(i1),m1),
+ & max(mminit(i2),m2),1,1,dbfact)
+ sig=sig*dbfact
+ endif
+
+c check energy conservation (cut-off is one 1 MeV)
+ if(max(m1,mminit(i1))+max(m2,mminit(i2))+1.d-3.gt.e) sig=0.d0
+
+ return
+
+
+ 8 continue
+c...ND->DD iso-spin summed value
+ call setizm(iabs(ii1),iiz1,mm1,iabs(ii2),iiz2,mm2,
+ ,i1,iz1,m1,i2,iz2,m2)
+
+ e0=2.*massit(mindel)-widit(mindel)
+
+ c1=clebsch(isoit(i1),isoit(i2),iz1,iz2,1)
+ c2=clebsch(isoit(i1),isoit(i2),iz1,iz2,2)
+
+ctp060926 if(io.lt.0)write(6,*)'crossz(DD->ND):c1,c2=',c1,c2,
+ctp060926 , isoit(i1),isoit(i2),iz1,iz2,'itypes:',i1,i2
+ sig=f(e,e0,12.0d0,0.02d0,2d0)*(0.66667*c1+4d0/dsqrt(20d0)*c2)
+
+ if(iio.lt.0.and.sig.gt.1.d-12) then
+ call detbal(e,i1,i2,iz1,iz2,max(mminit(i1),m1),
+ & max(mminit(i2),m2),minnuc,mindel,dbfact)
+ sig=sig*dbfact
+ endif
+ return
+
+ 9 continue
+ write(6,*)'crossx: channel no.',io,'not implemented.'
+ stop
+
+ 10 continue
+c...MB->B'
+ call anndec(0,m1,i1,iz1,m2,i2,iz2,e,sig,gam)
+ return
+
+ 11 continue
+c...MM->M'
+ call anndec(0,m1,i1,iz1,m2,i2,iz2,e,sig,gam)
+ return
+
+ 12 continue
+c...??->X => additive quark model total cross section
+ call aqm(i1,i2,sig,dum)
+ if(sig.gt.1d3)then
+ write(6,*)'sig=',sig
+ end if
+
+c check energy conservation (cut-off is one 1 MeV)
+ if(max(m1,mminit(i1))+max(m2,mminit(i2))+1.d-3.gt.e) sig=0.d0
+
+ return
+
+ 13 continue
+c...??->X => additive quark model elastic cross section
+ call aqm(i1,i2,dum,sig)
+
+c check energy conservation (cut-off is one 1 MeV)
+ if(max(m1,mminit(i1))+max(m2,mminit(i2))+1.d-3.gt.e) sig=0.d0
+
+ return
+
+ 14 continue
+c...??->X => additive quark model inelastic cross section
+ call aqm(i1,i2,s1,s2)
+ s3=s1-s2
+ s1=s3
+c DD->DD is possible only for e<4gev, then DD->Strings (15) is used
+ e0=mminit(i1)+mminit(i2)+2d0*CTParam(4)
+ bf=2d0*dabs(CTParam(4)-CTParam(2))
+ s2=f(e,e0,s3,bf,1d0)
+ sig=xmelt(e,s1,s2,max(mminit(i1),m1)+max(mminit(i2),m2),
+ @ e0+2d0*CTparam(2))
+
+c check energy conservation (cut-off is one 1 MeV)
+ if(max(m1,mminit(i1))+max(m2,mminit(i2))+1.d-3.gt.e) sig=0.d0
+
+ return
+
+ 15 continue
+c...??->X => additive quark model string cross section
+ if(CTOption(12).ne.0)return
+ if(CTOption(12).eq.0)then
+ call aqm(i1,i2,sig,dum)
+ sig=sig-dum
+c dum is the inelastic xsec
+c string threshold is at 3.2 GeV by default
+ if(e.gt.2d0*(1.08d0+ctparam(2)))then
+ sig=sig*bcms(e,1.08d0+ctparam(2),1.08d0+ctparam(2))**(aaqm)
+ else
+ sig=0.d0
+ end if
+ end if
+
+c check energy conservation (cut-off is one 1 MeV)
+ if(max(m1,mminit(i1))+max(m2,mminit(i2))+1.d-3.gt.e) sig=0.d0
+
+ return
+
+ 16 continue
+c...pn-total...low energy tables & high energy fit
+ sig=xmelt(e,siglookup(1,e),sighera(.938d0,.938d0,e,3),3.d0,5.d0)
+ return
+
+ 17 continue
+c...pn-elastic...low energy tables & high energy fit (then pn=pp)
+ sig=xmelt(e,siglookup(2,e),sighera(.938d0,.938d0,e,2),3.d0,5.d0)
+ return
+
+ 18 continue
+c...pp-total...low energy tables & high energy fit
+ sig=xmelt(e,siglookup(3,e),sighera(.938d0,.938d0,e,1),3.d0,5.d0)
+ return
+
+ 19 continue
+c...pp-elastic...low energy tables & high energy fit
+ sig=xmelt(e,siglookup(4,e),sighera(.938d0,.938d0,e,2),3.d0,5.d0)
+ return
+
+ctp060202 20 continue
+ write(6,*)'crossx: cross section for decay(io=20) requested'
+ stop
+ return
+
+ 21 continue
+c...bbar total...from ppbar via AQM & phase-space
+ call aqm(1,-1,nnphi,dum)
+ call aqm(i1,i2,bbphi,dum)
+ sig=sapptot(e,m1,m2)*bbphi/nnphi
+ return
+
+
+ 22 continue
+c...bbar elastic...from ppbar via AQM & phase-space
+ call aqm(1,-1,nnphi,dum)
+ call aqm(i1,i2,bbphi,dum)
+ sig=sappela(e,m1,m2)*bbphi/nnphi
+ return
+
+ 23 continue
+c...bbar annihilation from ppbar via AQM & phase-space
+ call aqm(1,-1,nnphi,dum)
+ call aqm(i1,i2,bbphi,dum)
+ sig=sappann(e,m1,m2)*bbphi/nnphi
+ return
+
+ 24 continue
+c...bbar diffractive...from ppbar via AQM & phase-space
+ call aqm(1,-1,nnphi,dum)
+ call aqm(i1,i2,bbphi,dum)
+ sig=sappdiff(e,m1,m2)*bbphi/nnphi
+ return
+
+ 25 continue
+c...pi^+ +p
+ if ((i2.eq.minmes+1).and.(iz2.eq.2)
+ & .and.(i1.eq.1).and.(iz1.eq.1)) then
+ sigheramb=sighera(m2,m1,e,7)
+ meltpoint=2.00d0
+c...pi^- +p
+ elseif ((i2.eq.minmes+1).and.(iz2.eq.-2)
+ & .and.(i1.eq.1).and.(iz1.eq.1)) then
+ sigheramb=sighera(m2,m1,e,9)
+ meltpoint=2.18d0
+c...K^+ +p
+ elseif ((i2.eq.minmes+6).and.(iz2.eq.1)
+ & .and.(i1.eq.1).and.(iz1.eq.1)) then
+ sigheramb=sighera(m2,m1,e ,11)
+ meltpoint=1.84d0
+C here second meltpoint to enable linear interpolation between
+C meltpoint2 and meltpoint (in plab)
+ meltpoint2=1.7d0
+ kplflag=.true.
+c...K^- +p
+ elseif ((i2.eq.-(minmes+6)).and.(iz2.eq.-1)
+ & .and.(i1.eq.1).and.(iz1.eq.1)) then
+ sigheramb=sighera(m2,m1,e,14)
+ meltpoint=2.12d0
+c...K^+ +n
+ elseif ((i2.eq.minmes+6).and.(iz2.eq.1)
+ & .and.(i1.eq.1).and.(iz1.eq.-1)) then
+ sigheramb=sighera(m2,m1,e,13)
+ meltpoint=1.75d0
+c...K^- +n
+ elseif ((i2.eq.-(minmes+6)).and.(iz2.eq.-1)
+ & .and.(i1.eq.1).and.(iz1.eq.-1)) then
+ sigheramb=sighera(m2,m1,e,16)
+ meltpoint=1.6d0
+c...gamma + p
+ elseif ((i2.eq.minmes).and.(iz2.eq.0)
+ & .and.iabs(i1).le.maxbar) then
+ sigheramb=sighera(m2,m1,e,6)
+ meltpoint=1.75d0
+ else
+c...MB total (->B*/->Strings/el.)
+ call anndec(0,m1,i1,iz1,m2,i2,iz2,e,sigmb,gam)
+ if (sigmb.gt.1d-8) then
+c meltpoint for resonant meson absorption moved to higher energies
+ meltpoint=max(1.7d0, m1+m2+.2d0)
+ else
+ meltpoint=1.7d0
+ endif
+ call aqm(pimeson,nucleon,dum,nnphi)
+ call aqm(i1,i2,dum,bbphi)
+ sigheramb=sighera(m2,m1,e,7)*bbphi/nnphi
+C
+ endif
+C
+C
+c...breit-wigners...
+ call anndec(0,m1,i1,iz1,m2,i2,iz2,e,sigmb,gam)
+c now melt the low energy resonance x-sec and the high energy hera-fits:
+ if (e.lt.meltpoint) then
+C
+c cross section for Danielewicz forward delay
+c here the DP-cross section has the same form as the normal one
+C
+ if(CTOption(34).eq.2) then
+ sig=sigmb+CTParam(58)*sigmb
+ elseif(CTOption(34).eq.3) then
+ m3=e
+ call anndec(0,m1,i1,iz1,m2,i2,iz2,e,sigmb,gam)
+ if(sig.gt.1d-5) sig=sigmb+CTParam(58)
+ elseif(CTOption(34).eq.4) then
+ m3=e
+ call anndec(0,m1,i1,iz1,m2,i2,iz2,e,sigmb,gam)
+ if(sigmb.gt.1d-5)then
+ ggam=fwidth(itypnew(1),i3new(1),m3)
+ sig=sigmb+CTParam(58)*
+ & sig*dsqrt(2.d0/(ggam*3.1415d0*fbwnorm(m3,
+ & itypnew(1),i3new(1))))
+ endif
+ else
+C
+C actually default for e.lt.meltpoint
+C take result from anndec as sigma
+C
+ sig=sigmb
+C
+ endif
+C
+c-- nonres adds s-channel strings for strange meson baryon reactions
+c-- resonances are not sufficient to fit data - sig gets modified in nonres !!!
+C-- so that k- p cross section describes data reasonable.
+C-- nonres call only below meltpoint
+C
+ call nonres(e,i1,iz1,i2,iz2,sig)
+C
+ else
+C
+C for e.ge.meltpoint
+C
+ sig=sigheramb
+C
+ endif
+C
+
+
+c.. is annihilation possible ? (quark content?)
+ call ityp2id(i2,iz2,iq1(1),iq1(2))
+ call ityp2id(i1,iz1,ifdiq2,iq2(3))
+ if(abs(i1).ge.minmes) then
+ iq2(1)=ifdiq2
+ iq2(2)=iq2(3)
+ iq2(3)=0
+ else
+ iq2(1)=mod(ifdiq2/100,10)
+ iq2(2)=int(ifdiq2/1000)
+ endif
+ qflg=0.d0
+ do 7312 kq1=1,2
+ do 7412 kq2=1,3
+c.. annihilation ?
+ if(iq1(kq1)+iq2(kq2).eq.0) qflg=1.d0
+ 7412 continue
+ 7312 continue
+c..--> elastic X-section gets minimum val. of 12.5 mb (K+ P)
+c.. if annihilation is not possible
+c.. (exclude gamma baryon elastic)
+ if (i2.ne.minmes) then
+ sig=max(sig,12.5d0*(1d0-qflg))
+
+C for k+ p linear interpolation between meltpoint2 and meltpoint
+ if (kplflag.and.
+ & qflg.eq.0.d0.and.e.lt.meltpoint
+ & .and.e.gt.meltpoint2) then
+ sighelp=sighera(m2,m1,meltpoint,11)
+ pfrome=plab(m2,m1,e)
+ pmelt2=plab(m2,m1,meltpoint2)
+ pmelt=plab(m2,m1,meltpoint)
+ sig=xmelt(pfrome,1.25d1,sighelp,pmelt2,pmelt)
+ endif
+ endif
+
+c check energy conservation (cut-off is one 1 MeV)
+ if(max(m1,mminit(i1))+max(m2,mminit(i2))+1.d-3.gt.e) sig=0.d0
+
+
+C
+C end of MB total
+C
+ return
+
+ 26 continue
+ if(i2.eq.minmes)then
+c..no elastic gamma B scattering:
+ sig=0.d0
+ return
+ endif
+c...MB->MB elastic (pi+ p scaled with aqm)
+ if(mminit(i1)+mminit(i2).gt.e) then
+c no collision if sqrts is insufficient to put particles on-shell
+ sig=0.d0
+ else
+ call aqm(pimeson,nucleon,dum,nnphi)
+ call aqm(i1,i2,dum,bbphi)
+ sig=sighera(m2,m1,e,8)*bbphi/nnphi
+ endif
+ return
+
+ 27 continue
+c..MB-> 1 String (s-channel) (pi+ p scaled with aqm)
+ if(CTOption(12).ne.0)return
+ call aqm(pimeson,nucleon,nnphi,dum)
+ call aqm(i1,i2,bbphi,dum)
+ sig=sighera(m2,m1,e,7)*bbphi/nnphi
+c-- minus elastic x-sect. (scaled with el. aqm)
+ call aqm(pimeson,nucleon,dum,nnphi)
+ call aqm(i1,i2,dum,bbphi)
+ sig=sig-sighera(m2,m1,e,8)*bbphi/nnphi
+c.. is s-channel possible ? (quark content?)
+ call ityp2id(i2,iz2,iq1(1),iq1(2))
+ call ityp2id(i1,iz1,ifdiq2,iq2(3))
+ if(abs(i1).ge.minmes) then
+ iq2(1)=ifdiq2
+ iq2(2)=iq2(3)
+ iq2(3)=0
+ else
+ iq2(1)=mod(ifdiq2/100,10)
+ iq2(2)=int(ifdiq2/1000)
+ endif
+ qflg=0.d0
+ do 312 kq1=1,2
+ do 412 kq2=1,3
+c..two of the quarks must be able to annihilate:
+ if(iq1(kq1)+iq2(kq2).eq.0) qflg=1.d0
+ 412 continue
+ 312 continue
+ sig=xmelt(e,sig,0.d0,3d0,6.d0)*qflg
+ if(e.le.1.7d0)sig=0.d0
+ call nonres(e,i1,iz1,i2,iz2,sig)
+
+ return
+
+ 28 continue
+c..MB-> 2 Strings (t-channel) (pi+ p scaled with aqm)
+ if(CTOption(12).ne.0)return
+ call aqm(pimeson,nucleon,nnphi,dum)
+ call aqm(i1,i2,bbphi,dum)
+ sig=sighera(m2,m1,e,7)*bbphi/nnphi
+c-- minus elastic x-sect. (scaled with el. aqm)
+ call aqm(pimeson,nucleon,dum,nnphi)
+ call aqm(i1,i2,dum,bbphi)
+ sig=sig-sighera(m2,m1,e,8)*bbphi/nnphi
+c-- melting
+ sig=xmelt(e,0d0,sig,3d0,6.d0)
+ return
+
+ 29 continue
+c...??->X => additive quark model inelastic cross section
+c specially reduced to avoid double-counting in case of DN and DD
+c cross sections
+ call aqm(i1,i2,sig,dum)
+ sig=sig-dum
+ sig=sig*bcms(e,max(mminit(i1),m1),max(mminit(i2),m2))**aaqm
+ sig=xmelt(e,sig,0d0,2d0*(1.08d0+ctparam(2)),5.0d0)
+c here comes the reduction
+ sig=xmelt(e,0d0,sig,2.75d0,3.4d0)
+ return
+
+ 30 continue
+c parameterized detailed balance cross sections for ND->NN
+ factor=dgcgkfct(i1,i2,iz1,iz2,nucleon,nucleon)
+ if(factor.le.1.d-8) then
+ sig=0.d0
+ return
+ endif
+ cgkcor=ppiso(-1,i1,iz1,i2,iz2,nucleon,nucleon)
+
+ sig=factor*cgkcor*(1.3d8*(e**(-17.5d0))+3.6d4*(e**(-7d0)))
+
+c write(6,*)factor,cgkcor,sig
+
+ return
+
+ 31 continue
+c parameterized detailed balance cross sections for DD->DN
+ e0=massit(i1)-0.5*widit(i1)+massit(i2)-0.5*widit(i2)
+
+ factor=dgcgkfct(i1,i2,iz1,iz2,nucleon,mindel)
+ if(factor.le.1.d-8.or.e.lt.e0)then
+ sig=0.d0
+ else
+ c1=clebsch(isoit(i1),isoit(i2),iz1,iz2,1)
+ c2=clebsch(isoit(i1),isoit(i2),iz1,iz2,2)
+
+c param
+ sig=
+ & (2.5d56*exp(-(50.0d0*e))
+ & +4.9d14*exp(-(12.d0*e))
+ & +1.1d6*exp(-(4.50d0*e)))
+ & *factor
+c the following factors are from Heinz Sorge's Habilitation
+ & *(0.66667*c1+4d0/dsqrt(20d0)*c2)
+
+ endif
+ return
+
+ 32 continue
+C parameterized detailed balance cross sections for DD->NN
+ factor=dgcgkfct(i1,i2,iz1,iz2,nucleon,nucleon)
+ if(factor.le.1.d-8.or.e.lt.2.15d0) then
+ sig=0.d0
+ return
+ endif
+ cgkcor=ppiso(-4,i1,iz1,i2,iz2,nucleon,nucleon)
+c param
+ sig=(7.27d0*(e-2.14d0)**(-1.2176d0)+0.05d0*(e-2.14d0)**(-3.257d0))
+ & *factor*cgkcor
+
+ return
+
+ 33 continue
+c...??->X => additive quark model resonance cross section
+ call aqm(i1,i2,sig,dum)
+ sig=sig-dum ! dum is the elastic xsec
+ if(e.gt.mminit(i1)+mminit(i2))then
+c x_string+x_resonances
+ sig=sig*bcms(e,mminit(i1),mminit(i2))**(aaqm*3)
+c get x_string
+ sig=xmelt(e,sig,0d0,mminit(i1)+mminit(i2)+1.5d0,
+ @ mminit(i1)+mminit(i2)+3d0)
+
+ end if
+
+ return
+
+ 34 continue
+c...??->X => additive quark model string cross section
+ if(CTOption(12).ne.0)return
+ call aqm(i1,i2,sig,dum)
+ sig=sig-dum ! dum is the elastic xsec
+ if(e.gt.mminit(i1)+mminit(i2))then
+c x_string+x_resonances
+ sig=sig*bcms(e,mminit(i1),mminit(i2))**(aaqm*3)
+c get x_resonances
+ sig=xmelt(e,0d0,sig,mminit(i1)+mminit(i2)+1.5d0,
+ @ mminit(i1)+mminit(i2)+3d0)
+ end if
+ return
+
+ 35 continue
+ e0=mminit(i1)+mminit(i2)+CTParam(4)*2d0
+ call aqm(i1,i2,sig,dum)
+ sig=f(e,e0,sig-dum,1d0,1d0)
+ return
+
+ 36 continue
+c cross section for Danielewicz forward delay
+c...MB->B'
+ if(CTOption(34).eq.2) then
+ call anndec(0,m1,i1,iz1,m2,i2,iz2,e,sig,gam)
+ sig=CTParam(58)*sig
+ elseif(CTOption(34).eq.3) then
+ m3=e
+ call anndec(0,m1,i1,iz1,m2,i2,iz2,e,sig,gam)
+ if(sig.gt.1d-5) sig=CTParam(58)
+ elseif(CTOption(34).eq.4) then
+ m3=e
+ call anndec(0,m1,i1,iz1,m2,i2,iz2,e,sig,gam)
+ if(sig.gt.1d-5)then
+ ggam=fwidth(itypnew(1),i3new(1),m3)
+ sig=CTParam(58)*
+ & sig*dsqrt(2.d0/(ggam*3.1415d0*
+ & fbwnorm(m3,itypnew(1),i3new(1))))
+ endif
+ else
+ sig=0.d0
+ endif
+ return
+
+ 37 continue
+c cross section for Danielewicz forward delay
+c...MM->M'
+ if(CTOption(34).eq.2) then
+ call anndec(0,m1,i1,iz1,m2,i2,iz2,e,sig,gam)
+ sig=CTParam(58)*sig
+ elseif(CTOption(34).eq.3) then
+ m3=e
+ call anndec(0,m1,i1,iz1,m2,i2,iz2,e,sig,gam)
+ if(sig.gt.1d-5) sig=CTParam(58)
+ elseif(CTOption(34).eq.4) then
+ m3=e
+ call anndec(0,m1,i1,iz1,m2,i2,iz2,e,sig,gam)
+ if(sig.gt.1d-5)then
+ ggam=fwidth(itypnew(1),i3new(1),m3)
+ sig=CTParam(58)*
+ & sig*dsqrt(2.d0/(ggam*3.1415d0*
+ & fbwnorm(m3,itypnew(1),i3new(1))))
+ endif
+ else
+ sig=0.d0
+ endif
+ return
+ 38 continue
+c elastic meson-meson cross section
+ sig=5.d0
+
+c check energy conservation (cut-off is one 1 MeV)
+ if(max(m1,mminit(i1))+max(m2,mminit(i2))+1.d-3.gt.e) sig=0.d0
+
+ return
+
+ctp060202 99 continue
+c...single diffr. pp
+ sig=.68*(1.+36/e**2)*log(0.6+0.1*e**2)
+ return
+
+ end
+
+C####C##1#########2#########3#########4#########5#########6#########7##
+ subroutine nonres(e,ii1,iiz1,ii2,iiz2,sig)
+c
+cinput e : $\sqrt{s}$ of collision
+cinput ii1 : ID of particle 1
+cinput iiz1 : $2\cdot I_3$ of particle 1
+cinput ii2 : ID of particle 2
+cinput iiz2 : $2\cdot I_3$ of particle 2
+coutput sig : cross section
+c
+c {\tt nonres} adds s-channel strings for strange meson baryon reactions,
+c since
+c resonances are not sufficient to fit data -
+c {\tt sig} gets modified in {\tt nonres},
+C so that $k^- p$ cross section describes data reasonable.
+C {\tt nonres} should be only called below {\tt meltpoint}
+c
+C####C##1#########2#########3#########4#########5#########6#########7##
+ implicit none
+ logical b
+ real*8 m1,m2,e,sig
+ integer strit,i1,i2,iz1,iz2,ii1,ii2,iiz1,iiz2
+
+ b=.false.
+ call setizm(ii1,iiz1,0d0,ii2,iiz2,0d0,
+ @ i1,iz1,m1,i2,iz2,m2)
+ if(iabs(i1).gt.iabs(i2))
+ @ call swpizm(i1,iz1,m1,i2,iz2,m2)
+
+C check wether sigma should be modified
+C 1) strange meson required
+C 2) nonstrange baryon required
+C 3) combination of strange meson + baryon (k- p)
+C or antistrange meson + antibaryon (k+ pbar) required
+C
+ if(strit(i2).ne.0.and.i1*i2.lt.0.and.strit(i1).eq.0)b=.true.
+C if this condition is fullfilled modify sigma
+C add exponential underground and corrections
+C (two gaussians,constant,low energy cut off)
+C to describe experimental k- p cross section
+C four cases for different corrections
+C
+ if ((b).and.e.gt.1.433.and.e.lt.1.4738188) then
+ sig=sig+120.
+ elseif ((b).and.e.ge.1.4738188.and.e.lt.1.485215) then
+ sig=sig-1.296457765d7*(e-1.433)**4+
+ & 2.160975431d4*(e-1.433)**2+120.
+ elseif ((b).and.e.ge.1.485215.and.e.lt.1.977) then
+ sig=sig+1.07769d+06*exp(-(6.44463d0*e))-
+ & 10.*exp(-(((e-1.644)**2)/0.004))+
+ & 10.*exp(-(((e-1.977)**2)/0.004))
+ elseif ((b).and.e.ge.1.977.and.e.lt.2.12) then
+C keep maximum value of gaussian above e=1.977 GeV
+C (e=2.12 GeV is meltpoint)
+ sig=sig+1.07769d+06*exp(-(6.44463d0*e))+10.
+ endif
+
+C
+ return
+ end
+
+C####C##1#########2#########3#########4#########5#########6#########7##
+ real*8 function sappann(sroot,m1,m2)
+c
+cinput sroot : $\sqrt{s}$ of collision
+cinput m1 : mass of 1st (anti-)baryon
+cinput m2 : mass of 2nd (anti-)baryon
+c
+c OUTPUT: {\ttsappann} = annihilation cross section for $\bar N N$
+c
+c Taken from: P. Koch, C.B. Dover, Phys. Rev. {\bf C40} (1989) 145
+c
+C####C##1#########2#########3#########4#########5#########6#########7##
+
+ implicit none
+
+ include 'options.f'
+
+ real*8 sroot,m1,m2,s0,a,b,sig0,s,srootnn,snn
+ parameter(a=0.05d0,b=0.6d0,sig0=120.d0,s0=3.52)
+
+ if (CTOption(38).eq.1) then
+c evaluate the parametrization at the same relative momentum as in nbar-n
+ srootnn=snn(sroot,m1,m2)
+ s=srootnn**2
+ else
+c evaluate parametrization now at the same sqrts
+ s=sroot**2
+ endif
+ sappann=sig0*(s0/s)*(a**2*s0/((s-s0)**2+a**2*s0)+b)
+
+ return
+ end
+
+C####C##1#########2#########3#########4#########5#########6#########7##
+ real*8 function sapptot(sroot,m1,m2)
+c
+cinput sroot : $\sqrt{s}$ of collision
+cinput m1 : mass of 1st (anti-)baryon
+cinput m2 : mass of 2nd (anti-)baryon
+c
+c OUTPUT: {\ttsapptot} = total cross section for $\bar N N$
+c high energy paramametrization and data taken from PRD 50 (1994)\\
+c $p_{lab} > 5 $GeV: CERN/HERA parametrization\\
+c 0.3 GeV $< p_{lab} <$ 5 GeV: polynomial fit to the data (by C.S.)\\
+c $p_{lab} <0.3$ GeV: another fit, only constrained by sigma annihilation
+c
+C####C##1#########2#########3#########4#########5#########6#########7##
+
+ implicit none
+
+ include 'options.f'
+
+ real*8 p,sroot,plab,sighera,m1,m2,srootnn,snn
+
+ if (CTOption(38).eq.1) then
+c evaluate the parametrization at the same relative momentum as in nbar-n
+ srootnn=snn(sroot,m1,m2)
+ else
+c evaluate parametrization now at the same sqrts
+ srootnn=sroot
+ endif
+
+ p=plab(0.938d0,0.938d0,srootnn)
+
+ if(p.ge.5.d0)then
+ sapptot=sighera(0.938d0,0.938d0,srootnn,4)
+ return
+ else if(p.ge.0.3d0)then
+ sapptot=75.0146d0+43.1276d0/p+2.58298d0/p**2-3.90783d0*p
+ return
+ else
+ sapptot=271.6d0*exp(-(1.1d0*p**2))
+ return
+ endif
+
+ end
+
+
+C####C##1#########2#########3#########4#########5#########6#########7##
+ real*8 function sappela(sroot,m1,m2)
+c
+cinput sroot : $\sqrt{s}$ of collision
+cinput m1 : mass of 1st (anti-)baryon
+cinput m2 : mass of 2nd (anti-)baryon
+c
+c OUTPUT: {\tt sappela} = elastic cross section for $\bar N N$
+c high energy paramametrization and data taken from PRD 50 (1994)\\
+c $p_{lab} > 5 $GeV: CERN/HERA parametrization\\
+c 0.3 GeV $< p_{lab} <$ 5 GeV: polynomial fit to the data (by C.S.)\\
+c $p_{lab} <0.3$ GeV: no data, set constant
+c
+C####C##1#########2#########3#########4#########5#########6#########7##
+
+ implicit none
+
+ include 'options.f'
+
+ real*8 p,sroot,plab,sighera,m1,m2,srootnn,snn
+
+ if (CTOption(38).eq.1) then
+c evaluate the parametrization at the same relative momentum as in nbar-n
+ srootnn=snn(sroot,m1,m2)
+ else
+c evaluate parametrization now at the same sqrts
+ srootnn=sroot
+ endif
+
+ p=plab(0.938d0,0.938d0,srootnn)
+ if(p.ge.5.d0)then
+ sappela=sighera(0.938d0,0.938d0,srootnn,5)
+ return
+ else if(p.ge.0.3d0)then
+ sappela=31.6166d0+18.2842d0/p-1.14896d0/p**2-3.79508d0*p
+ return
+ else
+ sappela=78.6d0
+ return
+ endif
+
+ end
+
+C####C##1#########2#########3#########4#########5#########6#########7##
+ real*8 function sappdiff(sroot,m1,m2)
+c
+cinput sroot : $\sqrt{s}$ of collision
+cinput m1 : mass of 1st (anti-)baryon
+cinput m2 : mass of 2nd (anti-)baryon
+c
+c OUTPUT: {\tt sappdiff} = diffractive cross section for $\bar N N$
+c
+c This cross section is totally determined by
+c $ \sigma_{diff}=\sigma_{tot}-\sigma_{elast.}-\sigma_{annihil.}$
+c
+C####C##1#########2#########3#########4#########5#########6#########7##
+ implicit none
+ real*8 p,sroot,m1,m2,plab,sappann,sapptot,sappela
+
+ p=plab(0.938d0,0.938d0,sroot)
+ if(p.le.0.1d0)then
+ sappdiff=0.d0
+ return
+ else
+ sappdiff=max(0.d0,sapptot(sroot,m1,m2)
+ & -sappela(sroot,m1,m2)-sappann(sroot,m1,m2))
+ return
+ endif
+ end
+
+C####C##1#########2#########3#########4#########5#########6#########7##
+ blockdata herafits
+c cross section parameters for specific collsion type
+c CERN/HERA fits, taken from PRD 50 (1994)
+c see: function 'sighera'
+C####C##1#########2#########3#########4#########5#########6#########7##
+ implicit none
+ integer nfit
+c integer io
+ parameter (nfit=16)
+ real*8 a(nfit),b(nfit),n(nfit),c(nfit),d(nfit)
+ & ,p1(nfit),p2(nfit)
+ common /HERA/ a,b,n,c,d,p1,p2
+
+c io = 1 2 3 4 5 6
+c pp(tot) pp(ela) pn(tot) app(tot) app(ela) gammap(tot)
+c 7 8 9 10 11 12
+c pi+p(tot) pi+p(el) pi-p(tot) pi-p(el) k+p(tot) k+p(el)
+c 13 14 15 16
+c k+n(tot) k-p(tot) k-p(ela) k-n(tot)
+c
+c p1 (p2) give the momentum range (lab momentum) of the fit
+
+ data a/ 48.0, 11.9, 47.3, 38.4, 10.2, 0.147,
+ @ 16.4, 0., 33.0, 1.76, 18.1, 5.0,
+ @ 18.7, 32.1, 7.3, 25.2/
+ data b/ 0., 26.9, 0., 77.6, 52.7, 0.,
+ @ 19.3, 11.4, 14.0, 11.2, 0., 8.1,
+ @ 0., 0., 0., 0./
+ data n/ 0., -1.21, 0., -0.64, -1.16, 0.,
+ @ -.42, -.4, -1.36, -0.64, 0., -1.8,
+ @ 0., 0., 0., 0./
+ data c/ 0.522, 0.169, 0.513, 0.26, 0.125, .0022,
+ @ .19, .079, .456, .043, .26, .16,
+ @ .21, .66, .29, .38/
+ data d/ -4.51, -1.85, -4.27, -1.2, -1.28, -.017,
+ @ 0., 0., -4.03, 0., -1., -1.3,
+ @ -.89, -5.6, -2.4, -2.9/
+ data p1/ 3., 2., 3., 5., 5., 3.,
+ @ 3., 2., 1.8, 1.8, 2., 2.,
+ @ 2., 1.75, 3., 1.8/
+c for (k- p) p1=1.75 GeV/c works reasonable
+ data p2/2100., 2100., 370., 1.7d6, 1.7d6, 183.,
+ @ 340., 200., 370., 360., 310., 175.,
+ @ 310., 310., 175., 310./
+
+ end
+
+C####C##1#########2#########3#########4#########5#########6#########7##
+ real*8 function sighera(m1,m2,sroot,io)
+c
+c
+cinput sroot : $\sqrt{s}$ of collision
+cinput m1 : mass of 1st (anti-)baryon
+cinput m2 : mass of 2nd (anti-)baryon
+cinput io : flag for respective cross section
+c
+c OUTPUT: {\tt sighera} = cross section for specific collsion type
+c
+c {\tt io} can have the following values:
+c \begin{tabular}{rl}
+c 1 & $pp$ total \\
+c 2 & $pp$ elastic \\
+c 3 & $pn$ total \\
+c 4 & $\bar p p$ total\\
+c 5 & $\bar p p$ elastic\\
+c 6 & $\gamma p$ (tot) \\
+c 7 & $\pi^+ p$ (tot) \\
+c 8 & $\pi^+ p$ (el) \\
+c 9 & $\pi^- p$ (tot)\\
+c 10 & $\ pi- p$ (el) \\
+c 11 & $k^+ p$ (tot)\\
+c 12 & $k^+ p$ (el)\\
+c 13 & $k^+ n$ (tot)\\
+c 14 & $k^- p$ (tot)\\
+c 15 & $k^- p$ (ela)\\
+c 16 & $k^- n$ (tot)\\
+c \end{tabular}
+c
+c This subroutine returns CERN/HERA parametrizations for cross sections
+c {\tt p1} and {\tt p2} in the {\tt blockdata} routine
+c give the momentum range (lab momentum) of the fit.
+c The fits have been taken from
+c Phys. Rev. {\bf D50} (1994).
+c
+C####C##1#########2#########3#########4#########5#########6#########7##
+ implicit none
+ include 'coms.f'
+ include 'comres.f'
+ integer nfit,io
+ parameter (nfit=16)
+ real*8 a(nfit),b(nfit),n(nfit),c(nfit),d(nfit),sroot,p,plab
+ & ,p1(nfit),p2(nfit),m1,m2,massit
+ common /HERA/ a,b,n,c,d,p1,p2
+
+c p=plab(m1,m2,sroot)
+ p=0.d0
+ if(io.ge.1.and.io.le.5)then
+ p=plab(massit(minnuc),massit(minnuc),sroot)
+ elseif(io.eq.6)then
+ p=plab(massit(minmes),massit(minnuc),sroot)
+ elseif(io.ge.7.and.io.le.10)then
+ p=plab(massit(pimeson),massit(minnuc),sroot)
+ elseif(io.ge.11.and.io.le.16)then
+ p=plab(massit(itkaon),massit(minnuc),sroot)
+ else
+ write(*,*)'#make22 error. sighera called with io=',io
+ stop
+ endif
+
+ if(p.lt.1d-15) then
+c if energy conservation is not possible (p.eq.0) then return zero
+ sighera=0.d0
+ return
+ endif
+C
+ if(p.lt.p1(io))then
+ p=p1(io)
+C
+ elseif (p.gt.p2(io).and.(warn)) then
+ write(6,*)'sighera: sroot=',sroot,' high!, io=',io
+ write(6,*)' m1,m2,plab,p2(io)=',m1,m2,p,p2(io)
+ write(6,*)'sighera fit used above upper limit (extrapolation)'
+ endif
+ sighera=a(io)+b(io)*p**n(io)+c(io)*log(p)**2+d(io)*log(p)
+ return
+ end
+
+C####C##1#########2#########3#########4#########5#########6#########7##
+ real*8 function xmelt(e,x1,x2,em,ep)
+c
+cinput e : $\sqrt{s}$ of process
+cinput x1 : value at {\tt em}
+cinput x2 : value at {\tt ep}
+cinput em : lower boundary in $\sqrt{s}$
+cinput ep : upper boundary in $\sqrt{s}$
+c
+c {\tt xmelt } yields an interpolation beween {\tt x1} and {\tt x2}
+c in the $\sqrt{s}$ range beween {\tt em} and {\tt ep}.
+c For {\tt e < em} it equals {\tt x2}, if {\tt e > em} it yields
+c a combination of both {\tt x1} and {\tt x2} such that there is a
+c continuous transition from {\tt x1} to {\tt x2}.
+c
+c For parameter b=.false. a linear combination is used,
+c for parameter b=.true. a sin-form is used.
+c
+C####C##1#########2#########3#########4#########5#########6#########7##
+ implicit none
+ real*8 e,x1,x2,em,ep,lam,pi
+ logical b
+ parameter(b=.false.,pi=.31415927d-1)
+
+
+ lam=max(0d0,min(1d0,(e-min(em,ep))/abs(ep-em)))
+ if(b)lam=5d-1*sin((lam-5d-1)*pi)+5d-1
+
+ xmelt=(1d0-lam)*x1+lam*x2
+
+ return
+ end
+
+C####C##1#########2#########3#########4#########5#########6#########7##
+ real*8 function plab(m1,m2,sroot)
+c
+cinput sroot : $\sqrt{s}$ of collision
+cinput m1 : mass of 1st (anti-)baryon
+cinput m2 : mass of 2nd (anti-)baryon
+c
+c {\tt plab} returns the lab-momentum of particle 1
+c
+C####C##1#########2#########3#########4#########5#########6#########7##
+ implicit none
+ real*8 sroot,m1,m2
+ if(sroot-m1-m2.lt.0d0)then
+ plab=0d0
+ else
+ plab=sqrt((sroot**2-(m1+m2)**2)*(sroot**2-(m1-m2)**2))/(2*m2)
+ end if
+ return
+ end
+C####C##1#########2#########3#########4#########5#########6#########7##
+ real*8 function snn(sbb,m1,m2)
+c
+cinput sbb : $\sqrt{s}$ of a $BB$ collision
+cinput m1 : mass of 1st (anti-)baryon
+cinput m2 : mass of 2nd (anti-)baryon
+c
+c {\tt snn} returns the equivalent c.o.m. energy of a $NN$-collision
+c with the same relative momentum
+c
+C####C##1#########2#########3#########4#########5#########6#########7##
+ implicit none
+ real*8 sbb,prel,m1,m2
+ prel=sqrt((sbb**2-(m1+m2)**2)*(sbb**2-(m1-m2)**2))/sbb
+ snn=sqrt(prel**2+3.52d0)
+ return
+ end
diff --git a/Processes/UrQMD/newpart.f b/Processes/UrQMD/newpart.f
new file mode 100644
index 0000000000000000000000000000000000000000..5feec4c429f1e1f79328483dca028c289f1d82fd
--- /dev/null
+++ b/Processes/UrQMD/newpart.f
@@ -0,0 +1,66 @@
+c $Id: newpart.f,v 1.6 1999/01/18 09:57:09 ernst Exp $
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+c include-file newpart
+c
+cdes this file contains arrays for scattered or new created particles
+cdes and is used to communicate between the different routines which
+cdes are involved in hadling the kinematics
+c
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+ integer mprt,oprt
+c maximum number of new particles:
+ parameter(mprt=200) ! maximum number of produced particles
+ parameter(oprt=2) ! maximum number of incoming particles
+c pslot : slots of incoming particles
+c itypnew: ityps of new particles
+c i3new: $2*I_3$ of new particles
+c inew: array-indices of new particles (will be assigned in scatter-routines)
+c nexit: number of particles in exit-channel
+c iline: tag for out-channel process
+c nstring1 : number of particles in string 1
+c nstring2 : number of particles in string 2
+c strcount : ??
+c sidnew : stringID for produced particles
+c pslot : slots of incoming particles
+c itot: $2*I_{tot}$ of new particles (will be assigned in scatter-routines)
+c pnew(5,mprt) : momenta, energy and mass of produced particles
+c pnew(1,*) = px
+c pnew(2,*) = py
+c pnew(3,*) = pz
+c pnew(4,*) = e
+c pnew(5,*) = mass
+c xnew(4,mprt) : locations and time of produced particles
+c xnew(1,*) = rx
+c xnew(2,*) = ry
+c xnew(3,*) = rz
+c xnew(4,*) = r0
+c pold(5,oprt) : momenta, defined like pnew
+c itypold : incoming itypes
+c iso3old : incoming iso3's
+c xtotfacold: xtotfacs of incoming particles
+c mstring() masses of strings 1 and 2 (or particles 1 and 2)
+c leadfac(mprt): (1-leadfac) is the factor, by which the total cross
+c section of a hadron is multiplied within its formation
+c time (.ne.1 only for leading hadrons)
+ integer itypnew(mprt),i3new(mprt),itot(mprt),inew(mprt),nexit
+ integer nstring1, nstring2,iline,itypold(oprt),iso3old(oprt)
+ integer pslot(oprt),strcount
+ real*8 pnew(5,mprt),xnew(4,mprt),mstring(2),leadfac(mprt)
+ real*8 pold(5,oprt),xtotfacold(oprt)
+ integer sidnew(mprt)
+
+
+c relative velocity/between comp. frame and two particle rest frame
+c is betax, betay, betaz (needed for lotrans)
+c momentum vector in two particle restframe is p0nn,pxnn,pynn,pznn
+
+ real*8 betax,betay,betaz,p0nn,pxnn,pynn,pznn,pnn,pnnout
+
+ common /inewpart/ itypnew,i3new,itot,inew,nexit,iline,strcount,
+ & pslot,nstring1,nstring2,sidnew,itypold,iso3old
+ common /rnewpart/ pnew,xnew,betax,betay,betaz,pold,
+ & p0nn,pxnn,pynn,pznn,pnn,mstring,pnnout,
+ & xtotfacold
+ common /fnewpart/ leadfac
diff --git a/Processes/UrQMD/numrec.f b/Processes/UrQMD/numrec.f
new file mode 100644
index 0000000000000000000000000000000000000000..e8ba84680d441badb3941228c7830319bf823566
--- /dev/null
+++ b/Processes/UrQMD/numrec.f
@@ -0,0 +1,76 @@
+c$Id: numrec.f,v 1.5 1999/01/18 09:57:10 ernst Exp $
+C=======================================================================
+C Routines taken from Numerical Recipes
+C
+C
+
+c
+ SUBROUTINE spline(x,y,n,yp1,ypn,y2)
+ implicit integer (i - n)
+ implicit real*8 (a - h , o - z)
+ INTEGER n,NMAXsp
+ PARAMETER (NMAXsp=500)
+ REAL*8 yp1,ypn,x(NMAXsp),y(NMAXsp),y2(NMAXsp)
+ INTEGER i,k
+ REAL*8 p,qn,sig,un,u(NMAXsp)
+ if (yp1.gt..99e30) then
+ y2(1)=0.
+ u(1)=0.
+ else
+ y2(1)=-0.5
+ u(1)=(3./(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-yp1)
+ endif
+ do 11 i=2,n-1
+ sig=(x(i)-x(i-1))/(x(i+1)-x(i-1))
+ p=sig*y2(i-1)+2.
+ y2(i)=(sig-1.)/p
+ u(i)=(6.*((y(i+1)-y(i))/(x(i+
+ *1)-x(i))-(y(i)-y(i-1))/(x(i)-x(i-1)))/(x(i+1)-x(i-1))-sig*
+ *u(i-1))/p
+11 continue
+ if (ypn.gt..99e30) then
+ qn=0.
+ un=0.
+ else
+ qn=0.5
+ un=(3./(x(n)-x(n-1)))*(ypn-(y(n)-y(n-1))/(x(n)-x(n-1)))
+ endif
+ y2(n)=(un-qn*u(n-1))/(qn*y2(n-1)+1.)
+ do 12 k=n-1,1,-1
+ y2(k)=y2(k)*y2(k+1)+u(k)
+12 continue
+ return
+ END
+
+ FUNCTION ran1(idum)
+ implicit integer (i - n)
+c real*4 is on purpose, do not change!!!
+ implicit real*4 (a - h , o - z)
+ INTEGER*4 idum,IA,IM,IQ,IR,NTAB,NDIV
+ REAL*4 AM,EPS,RNMX
+ real*8 ran1
+ PARAMETER (IA=16807,IM=2147483647,AM=1./IM,IQ=127773,IR=2836,
+ *NTAB=32,NDIV=1+(IM-1)/NTAB,EPS=1.2e-7,RNMX=1.-EPS)
+ INTEGER*4 j,k,iv(NTAB),iy
+ SAVE iv,iy
+ DATA iv /NTAB*0/, iy /0/
+ if (idum.le.0.or.iy.eq.0) then
+ idum=max(-idum,1)
+ do 11 j=NTAB+8,1,-1
+ k=idum/IQ
+ idum=IA*(idum-k*IQ)-IR*k
+ if (idum.lt.0) idum=idum+IM
+ if (j.le.NTAB) iv(j)=idum
+11 continue
+ iy=iv(1)
+ endif
+ k=idum/IQ
+ idum=IA*(idum-k*IQ)-IR*k
+ if (idum.lt.0) idum=idum+IM
+ j=1+iy/NDIV
+ iy=iv(j)
+ iv(j)=idum
+ ran1=dble(min(AM*iy,RNMX))
+ return
+ END
+C (C) Copr. 1986-92 Numerical Recipes Software .
diff --git a/Processes/UrQMD/options.f b/Processes/UrQMD/options.f
new file mode 100644
index 0000000000000000000000000000000000000000..7500864dc940d99698270fc893d7c8af7068bc3d
--- /dev/null
+++ b/Processes/UrQMD/options.f
@@ -0,0 +1,22 @@
+c $Id: options.f,v 1.9 2001/04/06 21:48:16 weber Exp $
+c... law: include file (only) for global parameters & options
+ integer numcto,numctp,maxstables
+ parameter(numcto=400) ! maximum number of options
+ parameter(numctp=400) ! maximum number of parameters
+ parameter(maxstables=20) ! maximum number of stable particles
+c...
+ integer CTOption(numcto)
+ character ctodc(numcto)*2
+c...
+ real*8 CTParam(numctp)
+ character ctpdc(numctp)*2
+
+ integer nstable
+ integer stabvec(maxstables)
+
+ logical bf13,bf14,bf15,bf16,bf17,bf18,bf19,bf20,fixedseed
+ common /options/CTOption,CTParam
+ common /optstrings/ctodc,ctpdc
+ common /loptions/fixedseed,bf13,bf14,bf15,bf16,bf17,bf18,
+ . bf19,bf20
+ common /stables/nstable,stabvec
diff --git a/Processes/UrQMD/outcom.f b/Processes/UrQMD/outcom.f
new file mode 100644
index 0000000000000000000000000000000000000000..67ccc0dd2a8f739d74dce5f53f76de751d50bbe2
--- /dev/null
+++ b/Processes/UrQMD/outcom.f
@@ -0,0 +1,13 @@
+c $Id: outcom.f,v 1.3 2000/01/12 16:02:39 bass Exp $
+c temporary storage for in-channel
+ real*8 tsqrts,tstot,tsigpart
+ real*8 tr0(3),trx(3),try(3),trz(3),ttform(3),txtotfac(3),
+ @ tp0(3),tpx(3),tpy(3),tpz(3),tm(3)
+ integer tind(3),tityp(3),tiso3(3),tcoll(3),tstrange(3)
+ integer tlcoll(3),tcharge(3),torigin(3),tstrid(3),tuid(3)
+
+ common/outcom/tsqrts,tstot,tsigpart,
+ & tr0,trx,try,trz,ttform,txtotfac,
+ @ tp0,tpx,tpy,tpz,tm,
+ & tind,tityp,tiso3,tcoll,tstrange,
+ & tlcoll,tcharge,torigin,tstrid,tuid
diff --git a/Processes/UrQMD/output.f b/Processes/UrQMD/output.f
new file mode 100644
index 0000000000000000000000000000000000000000..efcef27473f23ef404e9a87c41059fb84fe9729c
--- /dev/null
+++ b/Processes/UrQMD/output.f
@@ -0,0 +1,864 @@
+c $Id: output.f,v 1.19 2003/05/02 11:19:18 weber Exp $
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+ subroutine output(iunit)
+c
+c Revision : 1.0
+c
+c This subroutine writes the event-header to file(iunit)
+C
+c
+cinput iunit : output-unit
+c
+c
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+c
+ implicit none
+
+ include 'comres.f'
+ include 'coms.f'
+ include 'options.f'
+ include 'inputs.f'
+ include 'newpart.f'
+ include 'freezeout.f'
+ include 'boxinc.f'
+
+c
+ integer iunit,i,ttime,iu,app,att,zpp,ztt
+ integer iiunit,isunit
+cdh integer id, pdgid
+ integer timestep,itotcoll,iinelcoll
+ real*8 sigmatot,ptsigtot,stot,otime
+ common /outco2/sigmatot
+
+
+ character*4 reffram
+ character*20 aa,ah,ai,ak
+ character*36 ae,abt
+ character*31 aee
+ character*15 ab,aj,al,am
+ character*13 ac,ag,pds,tds
+ character*12 ad
+ character*7 af
+ character*9 ag2
+ character*1 add
+ character*191 apa14,apa15,apav
+ character*2 apa,aop
+
+c file15out
+ integer ind,ind1,ind2,nin
+ integer istr,ich,ii
+
+ real*8 sqrts, sigpart, colldens, cdens,cdens_
+ logical bdum,paulibl,ctp060202
+
+ include 'outcom.f'
+
+ integer fchg,strit
+ character*1 echar
+
+ integer iou(13:20)
+
+ save
+
+cdh data iou/13,14,15,16,17,18,19,20/
+ data iou/ 6, 6, 6,16,17,18,19,20/
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c output formats
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+c fileheader
+ 101 format(a20,3i7,a15,i2)
+ 301 format(a13,a13,i4,i4,a12,a13,i4,i4,a1)
+c 305 format(a36,3f10.7)
+ 304 format(a36,3f6.2,a31,1f9.2)
+ 302 format (a7,i9,a13,i12,a9,a20,i4,a20,f7.3)
+c 303 format(a20,i3,a15,e10.4,a15,e10.4,a15,e10.4)
+ 102 format(a2,15(i3,a2))
+c 103 format(a2,12(e10.4,a2))
+ 306 format(a171)
+
+ 305 format(a36,3f11.7)
+ 303 format(a20,i3,a15,e11.4,a15,e11.4,a15,e11.4)
+ 103 format(a2,12(e11.4,a2))
+
+c standard particle information vector
+ 201 format(9e16.8,i5,2i3,i6,i5,i4)
+c special output for cto40 (restart of old event)
+ 210 format(9e16.8,i5,2i3,i6,i5,i10,3e16.8,i8)
+c special output for mmaker
+ctp060202 203 format(9e16.8,i5,2i3,i6,i5,i4,i5,2e16.8)
+c same with index for file15
+ 501 format(i5,9e16.8,i5,2i3,i6,i5,i3,i15)
+c enhanced file16
+ 503 format(9e15.7,i5,2i3,i6,i5,i4,2i4)
+c same including freeze-out coordinates
+ 213 format(9e16.8,i5,2i3,i6,i5,i4,8e16.8)
+
+c collsision stats for file14
+ 202 format(8i8)
+c same with EndOfEvent tag for file16
+ 602 format(a1,8i8)
+
+c header-line for each collision in file15
+ 502 format(i1,i8,i4,i7,f8.3,4e12.4)
+
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+ if(iunit.eq.17)return
+ if(bf13.and.(iunit.eq.13)) return
+ if(bf14.and.(iunit.eq.14)) return
+ if(bf15.and.(iunit.eq.15)) return
+ if(bf16.and.(iunit.eq.16)) return
+
+c copy projectile/target info to local vars
+ app=ap
+ zpp=zp
+ att=at
+ ztt=zt
+
+ if(iunit.eq.19) return
+c
+ aa='UQMD version: '
+ ab=' output_file '
+ abt='transformation betas (NN,lab,pro) '
+ ac='projectile: '
+ ad=' target: '
+ add=' '
+ ae='impact_parameter_real/min/max(fm): '
+ aee=' total_cross_section(mbarn): '
+ af='event# '
+ ag=' random seed:'
+ ah='equation_of_state: '
+ ai=' total_time(fm/c): '
+ aj=' E_lab(GeV/u):'
+ ak=' Delta(t)_O(fm/c): '
+ al=' sqrt(s)(GeV):'
+ am=' p_lab(GeV/u):'
+ apa='pa'
+ aop='op'
+
+ apa14='pvec: '//
+ & 'r0 rx ry rz '//
+ & ' p0 px py pz '//
+ & ' m ityp 2i3 chg lcl# ncl or'
+ apa15='pvec:ind '//
+ & 'r0 rx ry rz '//
+ & ' p0 px py pz '//
+ & ' m ityp 2i3 chg lcl# ncl st'
+ if(iunit.eq.15) then
+ apav=apa15
+ else
+ apav=apa14
+ endif
+
+ if(fixedseed) then
+ ag2=' (fixed) '
+ else
+ ag2=' (auto) '
+ endif
+ if(prspflg.eq.1) then
+ pds='(ityp, char) '
+ app=spityp(1)
+ zpp=fchg(spiso3(1),app)
+ else
+ pds='(mass, char) '
+ endif
+ if(trspflg.eq.1) then
+ tds='(ityp, char) '
+ att=spityp(2)
+ ztt=fchg(spiso3(2),att)
+ else
+ tds='(mass, char) '
+ endif
+
+c determine cross section of the projectile-target system
+ sigmatot = ptsigtot()
+ccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+ otime=outsteps*dtimestep
+ ttime=int(nsteps*dtimestep+0.01)
+
+ if(iunit.eq.15)then
+ write(iou(15),502)0,event,Ap,At,bimp,ecm
+ , ,sigmatot,ebeam,pbeam
+ else
+ write(iou(iunit),101) aa,version, sigver, laires, ab,iunit
+ write(iou(iunit),301) ac,pds, App, Zpp, ad,tds, Att, Ztt,add
+ write(iou(iunit),305) abt,betann,betatar,betapro
+ write(iou(iunit),304) ae,bimp,bmin,bdist,aee,sigmatot
+ write(iou(iunit),303) ah,eos,aj,ebeam,al,ecm,am,pbeam
+ write(iou(iunit),302) af,event,ag,ranseed,ag2,ai,ttime,ak,otime
+ write(iou(iunit),102) aop,(CTOption(i),CTOdc(i),i=1,15)
+ write(iou(iunit),102) aop,(CTOption(i),CTOdc(i),i=16,30)
+ write(iou(iunit),102) aop,(CTOption(i),CTOdc(i),i=31,45)
+ write(iou(iunit),103) apa,(CTParam(i),CTPdc(i),i=1,12)
+ write(iou(iunit),103) apa,(CTParam(i),CTPdc(i),i=13,24)
+ write(iou(iunit),103) apa,(CTParam(i),CTPdc(i),i=25,36)
+ write(iou(iunit),103) apa,(CTParam(i),CTPdc(i),i=37,48)
+ write(iou(iunit),306) apav
+ end if
+
+c
+ return
+c.....
+ entry uounit(iiunit,isunit)
+ iou(iiunit)=isunit
+ return
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ entry file14out(timestep)
+c
+c Revision : 1.0
+c
+c This subroutine writes the standard output-file (unit 14)
+c
+cinput timestep : timestep of output
+c
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+c
+
+c
+ if(bf14)return
+ ttime=int(timestep*dtimestep+0.01)
+ itotcoll=ctag-dectag
+ iinelcoll=itotcoll-NBlColl-NElColl
+ write(iou(14),*) npart,ttime
+ write(iou(14),202) itotcoll,NElColl,iinelcoll,NBlColl,dectag,
+ @ NHardRes,NSoftRes,NDecRes
+
+c now write particle-output
+
+c write spectators
+ if(CTOption(28).eq.2)then
+ if(CTOption(41).eq.0) then
+ do 141 i=1,nspec
+ write(iou(14),201) r0s(i),rxs(i),rys(i),rzs(i),p0s(i),
+ @ pxs(i),pys(i),pzs(i),sfmass(i),
+ @ sityp(i),siso3(i),scharge(i),
+ @ -1,-1,0
+ 141 continue
+ else
+ do 142 i=1,nspec
+ write(iou(14),210) r0s(i),rxs(i),rys(i),rzs(i),p0s(i),
+ @ pxs(i),pys(i),pzs(i),sfmass(i),
+ @ sityp(i),siso3(i),scharge(i),
+ @ -1,-1,0,1d34,0d0,1d0,0
+ 142 continue
+ endif
+ endif
+ if(CTOption(41).eq.0) then
+ do 13 i=1,npart
+ write(iou(14),201) r0(i),rx(i),ry(i),rz(i),p0(i),
+ @ px(i)+ffermpx(i),py(i)+ffermpy(i),
+ @ pz(i)+ffermpz(i),fmass(i),
+ @ ityp(i),iso3(i),charge(i),
+ @ lstcoll(i),ncoll(i),mod(origin(i),100)
+ 13 continue
+ else
+ do 31 i=1,npart
+ write(iou(14),210) r0(i),rx(i),ry(i),rz(i),p0(i),
+ @ px(i)+ffermpx(i),py(i)+ffermpy(i),
+ @ pz(i)+ffermpz(i),fmass(i),
+ @ ityp(i),iso3(i),charge(i),
+ @ lstcoll(i),ncoll(i),origin(i),
+ @ dectime(i),tform(i),xtotfac(i),uid(i)
+ 31 continue
+ endif
+c
+ return
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ entry file13out(timestep)
+c
+c Revision : 1.0
+c
+c This subroutine writes the standard output-file (unit 13),
+c including the freeze-out configuration of the particles
+c
+cinput timestep : timestep of output
+c
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+c
+
+c
+ if(bf13)return
+ ttime=int(timestep*dtimestep+0.01)
+ itotcoll=ctag-dectag
+ iinelcoll=itotcoll-NBlColl-NElColl
+ write(iou(13),*) npart,ttime
+ write(iou(13),202) itotcoll,NElColl,iinelcoll,NBlColl,dectag,
+ @ NHardRes,NSoftRes,NDecRes
+
+c now write particle-output
+
+c write spectators
+ if(CTOption(28).eq.2)then
+ do 191 i=1,nspec
+ write(iou(13),213) r0s(i),rxs(i),rys(i),rzs(i),p0s(i),
+ @ pxs(i),pys(i),pzs(i),sfmass(i),
+ @ sityp(i),siso3(i),scharge(i),
+ @ -1,-1,0,r0s(i),rxs(i),rys(i),rzs(i),p0s(i),
+ @ pxs(i),pys(i),pzs(i)
+ 191 continue
+ endif
+
+
+ do 90 i=1,npart
+ if(ncoll(i).eq.0) then
+ write(iou(13),213) r0(i),rx(i),ry(i),rz(i),p0(i),
+ @ px(i)+ffermpx(i),py(i)+ffermpy(i),
+ @ pz(i)+ffermpz(i),fmass(i),
+ @ ityp(i),iso3(i),charge(i),
+ @ lstcoll(i),ncoll(i),mod(origin(i),100),
+ @ r0(i),rx(i),ry(i),rz(i),p0(i),px(i)+ffermpx(i),
+ @ py(i)+ffermpy(i),pz(i)+ffermpz(i)
+ else
+ write(iou(13),213) r0(i),rx(i),ry(i),rz(i),p0(i),
+ @ px(i)+ffermpx(i),py(i)+ffermpy(i),
+ @ pz(i)+ffermpz(i),fmass(i),
+ @ ityp(i),iso3(i),charge(i),
+ @ lstcoll(i),ncoll(i),mod(origin(i),100),
+ @ frr0(i),frrx(i),frry(i),frrz(i),frp0(i),frpx(i),
+ @ frpy(i),frpz(i)
+ endif
+ 90 continue
+c
+ return
+
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+ entry file15out(ind1,ind2,sqrts,stot,sigpart)
+c
+c Revision : 1.0
+c
+c This subroutine writes information about the in-channel to file15
+c (the collision statistics file)
+c
+cinput ind1 : index of particle 1
+cinput ind2 : index of particle 2 (=0 for decay of {\tt ind1})
+cinput sqrts : $\sqrt{s}$ of collision
+cinput stot : total cross section
+cinput sigpart : partial cross section
+c
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+
+c determine tag for scatter-input or decay-input
+c and store entry channel in temporary observables
+ bdum=paulibl(ind1,cdens)
+ tsqrts=sqrts
+ tstot=stot
+ tsigpart=sigpart
+
+ tind(1)=ind1
+ tr0(1)=r0(ind1)
+ trx(1)=rx(ind1)
+ try(1)=ry(ind1)
+ trz(1)=rz(ind1)
+ tp0(1)=p0(ind1)
+ tpx(1)=px(ind1)
+ tpy(1)=py(ind1)
+ tpz(1)=pz(ind1)
+ tm(1)=fmass(ind1)
+ tityp(1)=ityp(ind1)
+ tiso3(1)=iso3(ind1)
+ tstrange(1) = strit(tityp(1))
+ tcoll(1) = ncoll(ind1)
+ tlcoll(1)=lstcoll(ind1)
+ torigin(1)=origin(ind1)
+ tuid(1)=uid(ind1)
+ if(ind2.le.0) then
+ nin=1
+ elseif(ind2.gt.0) then
+ bdum=paulibl(ind2,cdens_)
+ cdens=5d-1*(cdens+cdens_)
+ nin=2
+ tind(2)=ind2
+ tr0(2)=r0(ind2)
+ trx(2)=rx(ind2)
+ try(2)=ry(ind2)
+ trz(2)=rz(ind2)
+ tp0(2)=p0(ind2)
+ tpx(2)=px(ind2)
+ tpy(2)=py(ind2)
+ tpz(2)=pz(ind2)
+ tm(2)=fmass(ind2)
+ tityp(2)=ityp(ind2)
+ tiso3(2)=iso3(ind2)
+ tstrange(2)=strit(tityp(2))
+ tcoll(2) = ncoll(ind2)
+ tlcoll(2)=lstcoll(ind2)
+ torigin(2)=origin(ind2)
+ tuid(2)=uid(ind2)
+ endif
+
+ return
+
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ entry f15outch(colldens)
+
+ctp060202 to avoid warnings with gfortran compilation
+ ctp060202=.false.
+ if(ctp060202)write(*,*)colldens
+ctp060202 end
+
+ if (bf15) return
+c This entry writes information about the collision to file15
+c one line for each particle:
+c format: x y z px py pz ityp iso3...
+
+ write(iou(15),502) nin,nexit,iline,ctag,acttime,tsqrts
+ , ,tstot,tsigpart,cdens
+ do 11 i=1,nin
+ istr=strit(tityp(i))
+ ich = fchg(tiso3(i),tityp(i))
+
+ write(iou(15),501) tind(i),tr0(i),trx(i),try(i),trz(i),
+ @ tp0(i),tpx(i),tpy(i),tpz(i),tm(i),
+ @ tityp(i),tiso3(i),ich,tlcoll(i),
+ @ tcoll(i),istr,torigin(i)
+ 11 continue
+ do 20 ii=1,nexit
+ i=inew(ii)
+ istr=strit(ityp(i))
+ write(iou(15),501) i,r0(i),rx(i),ry(i),rz(i),
+ @ p0(i),px(i),py(i),pz(i),fmass(i),
+ @ ityp(i),iso3(i),charge(i),lstcoll(i),
+ @ ncoll(i),istr,origin(i)
+ 20 continue
+
+ return
+
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ entry f16outch
+
+ if (bf16.or.(CTOption(13).eq.0)) return
+ if (nin.eq.1) then
+ tityp(2)=0
+ endif
+
+ do 22 ii=1,nexit
+ i=inew(ii)
+ write(iou(16),503) r0(i),rx(i),ry(i),rz(i),
+ @ p0(i),px(i)+ffermpx(i),py(i)+ffermpy(i),
+ @ pz(i)+ffermpz(i),fmass(i),
+ @ ityp(i),iso3(i),charge(i),lstcoll(i),
+ @ ncoll(i),mod(origin(i),100),tityp(1),tityp(2)
+ 22 continue
+
+ return
+
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ entry file16out
+
+ echar='E'
+ itotcoll=ctag-dectag
+ iinelcoll=itotcoll-NBlColl-NElColl
+
+c
+ if(bf16) return
+
+c now write particle-output
+ if (CToption(13).eq.0) then
+c write spectators
+ if (CTOption(28).eq.2)then
+ do 151 i=1,nspec
+ write(iou(16),201)r0s(i),rxs(i),rys(i),rzs(i),p0s(i),
+ @ pxs(i),pys(i),pzs(i),sfmass(i),
+ @ sityp(i),siso3(i),scharge(i),
+ @ -1,-1,0
+ 151 continue
+ endif
+
+ do 12 i=1,npart
+ write(iou(16),201) r0(i),rx(i),ry(i),rz(i),p0(i),
+ @ px(i)+ffermpx(i),py(i)+ffermpy(i),
+ @ pz(i)+ffermpz(i),fmass(i),
+ @ ityp(i),iso3(i),charge(i),
+ @ dectag+lstcoll(i),ncoll(i),mod(origin(i),100)
+
+ 12 continue
+ else
+ do 14 i=1,npart
+ write(iou(16),503) r0(i),rx(i),ry(i),rz(i),p0(i),
+ @ px(i)+ffermpx(i),py(i)+ffermpy(i),
+ @ pz(i)+ffermpz(i),fmass(i),
+ @ ityp(i),iso3(i),charge(i),
+ @ dectag+lstcoll(i),ncoll(i),mod(origin(i),100),-99,-99
+ 14 continue
+ endif
+c
+c write collision counters etc.
+ write(iou(16),602) echar,itotcoll,NElColl,iinelcoll,NBlColl,
+ @ dectag,NHardRes,NSoftRes,NDecRes
+ return
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ entry file16entry(ind)
+c
+c This entry stores one decay for later output (must be done, in case
+c of pauli-blocked decay)
+c
+ tr0(3)=r0(ind)
+ trx(3)=rx(ind)
+ try(3)=ry(ind)
+ trz(3)=rz(ind)
+ tp0(3)=p0(ind)
+ tpx(3)=px(ind)
+ tpy(3)=py(ind)
+ tpz(3)=pz(ind)
+ tm(3)=fmass(ind)
+ tityp(3)=ityp(ind)
+ tind(3)=ind
+ tiso3(3)=iso3(ind)
+ tcharge(3)=charge(ind)
+
+c lstcoll is negative to identify decayed particles
+
+
+ tlcoll(3)=-(1*lstcoll(ind))
+ tcoll(3)=ncoll(ind)
+ torigin(3)=origin(ind)
+ tuid(3)=uid(ind)
+
+ return
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ entry file16write
+
+c This entry writes the decay to file
+ i=3
+
+ if(bf16)return
+ if (CTOption(13).eq.0) then
+
+ write(iou(16),201) tr0(i),trx(i),try(i),trz(i),tp0(i),tpx(i),
+ @ tpy(i),tpz(i),tm(i),tityp(i),tiso3(i),tcharge(i),
+ @ tlcoll(i),tcoll(i),mod(torigin(i),100)
+ else
+ write(iou(16),503) tr0(i),trx(i),try(i),trz(i),tp0(i),tpx(i),
+ @ tpy(i),tpz(i),tm(i),tityp(i),tiso3(i),tcharge(i),
+ @ tlcoll(i),tcoll(i),mod(torigin(i),100),-98,-98
+ endif
+
+ return
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ entry osc_header
+
+ if (bf19) return
+
+ write (19,901) 'OSC1997A '
+ write (19,901) 'final_id_p_x'
+
+ 901 format (a12)
+
+ if (CTOption(27).eq.0) then
+ reffram='eqsp'
+ elseif (CTOption(27).eq.1) then
+ reffram='tar'
+ elseif (CTOption(27).eq.2) then
+ reffram='pro'
+ else
+ call error ('osc_header','Unknown Ref-Frame',
+ . dble(CTOption(27)),2)
+ reffram='----'
+ endif
+
+ write (19,902) 'UrQMD', '1.2', app, zpp, att, ztt,
+ . reffram, ebeam, 1
+
+ 902 format (2(a8,2x),'(',i3,',',i6,')+(',i3,',',i6,')',2x,a4,2x,
+ & e10.4,2x,i8)
+
+ return
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ entry osc99_header
+
+c header for OSCAR 99A output format
+
+ if (bf20) return
+
+ write (20,991)
+ write (20,992)
+
+ 991 format ('# OSC1999A')
+ 992 format ('# full_event_history')
+
+ if (CTOption(27).eq.0) then
+ reffram='nncm'
+ elseif (CTOption(27).eq.1) then
+ reffram='tar'
+ elseif (CTOption(27).eq.2) then
+ reffram='pro'
+ else
+ call error ('osc_header','Unknown Ref-Frame',
+ . dble(CTOption(27)),2)
+ reffram='----'
+ endif
+
+ write (20,993)
+ 993 format ('# UrQMD 1.2')
+
+ write (20,994) app, zpp, att, ztt,reffram, ebeam, 1
+
+ 994 format ('# (',i3,',',i6,')+(',i3,',',i6,')',2x,a4,2x,
+ & e10.4,2x,i8)
+
+ return
+
+
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ entry osc_event
+
+c body for OSCAR 97A format
+
+ if (bf19) return
+
+ write (19,903) event, npart, bimp, 0D0
+
+ 903 format (i10,2x,i10,2x,f8.3,2x,f8.3)
+
+c particles
+
+ do 99 i=1,npart
+cdh id = pdgid(ityp(i), iso3(i))
+cdh write(19,904) i, id,
+cdh . px(i)+ffermpx(i), py(i)+ffermpy(i), pz(i)+ffermpz(i),
+cdh . p0(i), fmass(i),
+cdh . frrx(i), frry(i), frrz(i), frr0(i)
+ 99 continue
+
+cdh 904 format (i10,2x,i10,2x,9(e12.6,2x))
+
+ return
+
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ entry osc99_event(ind)
+
+c full event info for OSCAR 99A format
+
+ if (bf20) return
+
+ if(ind.eq.-1) then
+ write (20,995) 0, npart, event, bimp, 0D0
+ elseif(ind.eq.1) then
+ write (20,996) npart, 0
+ else
+ write(6,*) 'fatal error in osc_99_event: wrong tag'
+ stop
+ endif
+
+ 995 format (3(i7,2x),2(f8.3,2x))
+ 996 format (2(i7,2x))
+
+c particles
+
+ do 88 i=1,npart
+cdh id = pdgid(ityp(i), iso3(i))
+cdh write(20,997) uid(i), id, 0,
+cdh . px(i)+ffermpx(i), py(i)+ffermpy(i), pz(i)+ffermpz(i),
+cdh . p0(i), fmass(i),
+cdh . frrx(i), frry(i), frrz(i), frr0(i)
+ 88 continue
+
+cdh 997 format (3(i10,2x),9(e12.6,2x))
+
+ return
+
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ entry osc99_coll
+
+ if (bf20) return
+c This entry writes information about the collision to file20
+c one line for each particle:
+c format: x y z px py pz ityp iso3...
+
+ write(iou(20),999) nin,nexit,iline,ctag,acttime,tsqrts
+ , ,tstot,tsigpart,cdens
+
+ do 911 i=1,nin
+cdh id = pdgid(tityp(i), tiso3(i))
+cdh write(20,997) tuid(i), id, 0,
+cdh . tpx(i), tpy(i), tpz(i),tp0(i),tm(i),
+cdh . trx(i), try(i), trz(i), tr0(i)
+ 911 continue
+ do 912 ii=1,nexit
+ i=inew(ii)
+cdh id = pdgid(ityp(i), iso3(i))
+cdh write(20,997) uid(i), id, 0,
+cdh . px(i), py(i), pz(i),p0(i),fmass(i),
+cdh . rx(i), ry(i), rz(i), r0(i)
+ 912 continue
+
+
+ 999 format(3(i7,2x),i7,f8.3,4e12.4)
+ return
+
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ entry osc99_eoe
+
+c end of event tag for OSCAR 99A format
+ if (bf20) return
+
+ write(20,996) 0,0
+
+ return
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ entry getoldevent
+
+c read event header
+ read(10,*,end=666)
+ @ aa
+
+ read(10,301) ac,pds, App, Zpp, ad,tds, Att, Ztt,add
+ read(10,305) abt,betann,betatar,betapro
+ read(10,304) ae,bimp,bmin,bdist,aee,sigmatot
+ read(10,303) ah,eos,aj,ebeam,al,ecm,am,pbeam
+ read(10,302) af,event,ag,ranseed,ag2,ai,ttime,ak,otime
+ read(10,102) aop,(CTOption(i),CTOdc(i),i=1,15)
+ read(10,102) aop,(CTOption(i),CTOdc(i),i=16,30)
+ read(10,102) aop,(CTOption(i),CTOdc(i),i=31,45)
+ read(10,103) apa,(CTParam(i),CTPdc(i),i=1,12)
+ read(10,103) apa,(CTParam(i),CTPdc(i),i=13,24)
+ read(10,103) apa,(CTParam(i),CTPdc(i),i=25,36)
+ read(10,103) apa,(CTParam(i),CTPdc(i),i=37,48)
+ read(10,306) apav
+c reset option 40
+ CTOption(40)=1
+
+c read event body
+ read(10,*) npart,ttime
+ read(10,202) itotcoll,NElColl,iinelcoll,NBlColl,dectag,
+ @ NHardRes,NSoftRes,NDecRes
+c timestep=dble(ttime)/dtimestep
+ ctag=itotcoll+dectag
+c now read particle-output
+ nbar=0
+ do 39 i=1,npart
+ read(10,210) r0(i),rx(i),ry(i),rz(i),p0(i),
+ @ px(i),py(i),pz(i),fmass(i),
+ @ ityp(i),iso3(i),charge(i),
+ @ lstcoll(i),ncoll(i),origin(i),
+ @ dectime(i),tform(i),xtotfac(i)
+ if(abs(ityp(i)).le.maxbar)nbar=nbar+1
+ 39 continue
+ nmes=npart-nbar
+ acttime=r0(1)
+c read options-file
+cdh call getparams
+ return
+c stop in case of EoF
+ 666 stop
+
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ entry specout(ind,iu)
+ i=ind
+ if (CTOption(28).lt.0) return
+ if (iu.eq.16.and.bf16) return
+ if (iu.eq.14.and.bf14) return
+ write(iu,201) r0(i),rx(i),ry(i),rz(i),p0(i),
+ @ px(i)+ffermpx(i),py(i)+ffermpy(i),
+ @ pz(i)+ffermpz(i),fmass(i),
+ @ ityp(i),iso3(i),charge(i),
+ @ dectag+lstcoll(i),ncoll(i),mod(origin(i),100)
+
+ return
+
+ end
+
+
+
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ subroutine spectrans(tstep)
+c
+c (when cto 28 is set to 2 this subroutine is called
+c to propagate the spectators along straight lines)
+c
+cinput tstep : timestep
+c
+ccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ implicit none
+ real*8 dtime,energ,tstep
+ integer j
+ include 'coms.f'
+
+ dtime=tstep
+
+ do 1 j=1,nspec
+ energ = p0s(j)
+ r0s(j) = r0s(j) + dtime
+ rxs(j) = rxs(j) + pxs(j)/energ*dtime
+ rys(j) = rys(j) + pys(j)/energ*dtime
+ rzs(j) = rzs(j) + pzs(j)/energ*dtime
+1 continue
+
+ return
+ end
+
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+ real*8 function ptsigtot()
+c
+c Revision : 1.0
+c
+c This function caculates the total cross section of the reaction.
+c (Projectile - target total cross section)
+C
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+ implicit none
+
+ include 'comres.f'
+ include 'coms.f'
+ include 'options.f'
+
+ integer indmn,indmx,itypmn,iso3mn,itypmx,iso3mx
+ integer isigline,iline,collclass
+ real*8 stot,sigel
+ real*8 sigtot
+
+c determine total cross section for reaction:
+ if(abs(Ap)+abs(At).gt.2) then
+ stot=10.d0*pi*(bdist**2-bmin**2)
+ elseif(abs(Ap)+abs(At).eq.2) then
+ stot=sigtot(1,2,ecm)
+cccccccc for CTOption(7)=1 no elastic cross section:
+ if(CTOption(7).eq.1) then
+c first sort the two itypes for call to collclass and anndec
+ if(abs(ityp(1)).lt.abs(ityp(2))) then
+ indmn=1
+ indmx=2
+ else
+ indmn=2
+ indmx=1
+ endif
+
+ itypmn=ityp(indmn)
+ iso3mn=iso3(indmn)
+ itypmx=ityp(indmx)
+ iso3mx=iso3(indmx)
+ isigline=collclass(itypmx,iso3mx,itypmn,iso3mn)
+c the elastic cross section is always the first entry (#3)
+ iline=SigmaLn(3,1,isigline)
+c!!!!DANGER: does not work for unstable particles (-> detailed balance)
+ call crossx(iline,ecm,ityp(1),iso3(1),
+ & fmass(1),ityp(2),iso3(2),fmass(2),sigel)
+c
+ if(stot-sigel.gt.0) then
+ stot=stot-sigel
+ else
+ stot=sigel
+ endif
+ endif
+ else
+ stot=0.d0
+ endif
+c
+ ptsigtot=stot
+ return
+ end
diff --git a/Processes/UrQMD/paulibl.f b/Processes/UrQMD/paulibl.f
new file mode 100644
index 0000000000000000000000000000000000000000..55f07f278f2e68bf775dc850181ef2a91388b7d2
--- /dev/null
+++ b/Processes/UrQMD/paulibl.f
@@ -0,0 +1,97 @@
+c $Id: paulibl.f,v 1.4 1999/01/18 09:57:11 ernst Exp $
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+ logical function paulibl(i,rhob)
+c
+c Revision : 1.0
+c
+c This function determines wether the final state of particle i
+c is pauli-blocked ({\tt .true.}) or not ({\tt .false.}).
+c The baryon-density at the location of particle i is returned in {\tt rhob}
+c
+c
+cinput i : Index of particle to be added
+c
+coutput rhob : baryon density at location of i
+c
+c
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+ implicit none
+ integer i, j
+ real*8 afit, bfit, rho, f, rhob, test, r2, p2, pgw, rhob0
+ parameter (afit=1.49641d0, bfit=0.208736d0)
+
+ real*8 qij(4),pij(4),pr2,q2,qp
+
+ include 'coms.f'
+ include 'comres.f'
+ include 'options.f'
+
+ rho = 0.0d0
+ rhob = 0.0d0
+ rhob0 = 0d0
+ f = 0.0d0
+ pgw = 1.0d0/hqc/hqc/gw
+
+ if(CTOption(23).eq.0)goto 3
+
+ do 1 j=1,nbar
+ r2 = (rx(i)-rx(j))**2+(ry(i)-ry(j))**2+(rz(i)-rz(j))**2
+ if ((ityp(i).eq.ityp(j)).and.(iso3(i).eq.iso3(j))) then
+ p2 = (px(i)+ffermpx(i)-px(j)-ffermpx(j))**2
+ & +(py(i)+ffermpy(i)-py(j)-ffermpy(j))**2
+ & +(pz(i)+ffermpz(i)-pz(j)-ffermpz(j))**2
+ p2 = 0.25d0*p2
+ rho = rho + dexp(-(2.0d0*gw*r2))
+ f = f + dexp(-(gw*r2)-pgw*p2)
+ end if
+ rhob = rhob + dexp(-(2.0d0*gw*r2))
+ 1 continue
+ paulibl = .true.
+ test = afit + bfit*rho
+ if (test.gt.f) paulibl = .false.
+ if (CTOption(10).eq.1) paulibl=.false.
+
+ rhob = rhob*(2.0d0*gw/pi)**1.5/rho0
+ if(ityp(i).eq.104)write(6,*)'**',rhob
+
+ return
+
+ 3 continue
+ do 108 j=1,nbar
+ qij(4)=r0(i)-r0(j)
+ qij(1)=rx(i)-rx(j)
+ qij(2)=ry(i)-ry(j)
+ qij(3)=rz(i)-rz(j)
+ pij(4)=p0(i)+p0(j)
+ pij(1)=px(i)+ffermpx(i)+px(j)+ffermpx(j)
+ pij(2)=py(i)+ffermpy(i)+py(j)+ffermpy(j)
+ pij(3)=pz(i)+ffermpz(i)+pz(j)+ffermpz(j)
+ q2=qij(4)**2-qij(1)**2-qij(2)**2-qij(3)**2
+ p2=pij(4)**2-pij(1)**2-pij(2)**2-pij(3)**2
+ qp=qij(4)*pij(4)-qij(1)*pij(1)-qij(2)*pij(2)
+ . -qij(3)*pij(3)
+ r2=qp**2/p2 - q2
+ if(r2.lt.0) then
+ write(6,*)'***(E) negative transverse distance !!',r2
+ write(6,*)r0(j),rx(j),ry(j),rz(j),p0(j),px(j),py(j),pz(j)
+ write(6,*)r0(i),rx(i),ry(i),rz(i),p0(i),px(i),py(i),pz(i)
+ r2=1000.d0
+ endif
+ pr2 = (px(i)-px(j))**2+(py(i)-py(j))**2+(pz(i)-pz(j))**2
+ if ((ityp(i).eq.ityp(j)).and.(iso3(i).eq.iso3(j))) then
+ rho=rho+dexp(-(2.0d0*gw*r2))
+ f=f+dexp(-(gw*r2)-.25d0*pgw*pr2)
+ end if
+c baryon density in rest frame of particle
+ if(j.ne.lstcoll(i))rhob=rhob+dexp(-(2.0d0*gw*r2))
+ 108 continue
+ paulibl=.true.
+ test=afit+bfit*rho
+ if (test.gt.f) paulibl=.false.
+ if (CTOption(10).eq.1) paulibl=.false.
+
+ rhob=max(0d0,min(.1d3,rhob*(2.0d0*gw/pi)**1.5/rho0))
+
+ return
+ end
diff --git a/Processes/UrQMD/proppot.f b/Processes/UrQMD/proppot.f
new file mode 100644
index 0000000000000000000000000000000000000000..bc5960586ccb799742576f53596e3304934eede0
--- /dev/null
+++ b/Processes/UrQMD/proppot.f
@@ -0,0 +1,950 @@
+c $Id: proppot.f,v 1.10 1999/01/18 09:57:12 ernst Exp $
+c Setting of global paramters
+c
+ subroutine params
+ implicit none
+ real*8 A0, chi
+ include 'coms.f'
+
+c gw = 0.25 fm^-2 width of the gaussian
+
+ logSky = .true.
+ logYuk = .true.
+ logCb = .true.
+ logPau = .false.
+
+ gw = 0.25
+ sgw = sqrt(gw)
+ Cb0 = 1.44
+ Yuk0 = 0.0 !-85.0
+ gamYuk = 1.4
+ drPau = 9.0
+ dpPau = 0.0144
+ Pau0 = 0.0 !99.5*(hqc/sqrt(drPau*dpPau))**3
+
+C
+C hard Skyrme EOS (usual stuff)
+C
+c Sky30 = 70.5
+c gamSky = 2.0
+c A0 = -124.2 * 0.5
+C
+C hard Skyrme EOS (JK parametrisation corrected for Gausswidth gw=0.25)
+C
+ Sky30 = 125.93
+ gamSky = 1.676
+ A0 = -87.67
+ chi = 0.93
+
+c Sky30 = 303.0 !188.18
+c gamSky = 7.0/6.0 !1.457
+c A0 = -356.0 * 0.5
+
+
+ Sky20 = chi*2.0*A0
+ Yuk0 = (1.0-chi)/(2.0*pi*gamYuk**2)*A0
+
+c Sky20 = 0.0d0
+c Sky30 = 0.0d0
+c Yuk0 = 0.0d0
+c Cb0 = 0.0d0
+
+ delr = 0.2
+ fdel = delr*delr/6.0
+ da = -(1.0/delr)
+ db = -da
+
+ cutdww = 20.0
+ cutPau = 20.0
+ cutYuk = 20.0
+ cutCb = 20.0
+
+ dtimestep=0.2
+ dt = 0.02
+c dt2 = 0.5*dt
+c dt6 = dt/6.0
+
+ return
+ end
+
+
+c Reset of all indexed variables
+c
+ subroutine set0
+ implicit none
+ integer i, j
+ include 'coms.f'
+
+ do 10 i=1,nspl
+ spPauy(i) = 0.0
+ outPau(i) = 0.0
+ spCby(i) = 0.0
+ outCb(i) = 0.0
+ spYuky(i) = 0.0
+ outYuk(i) = 0.0
+ spSkyy(i) = 0.0
+ outSky(i) = 0.0
+ spdwwy(i) = 0.0
+ outdww(i) = 0.0
+ 10 continue
+
+ do 20 j=1,nmax
+ spin(j) = 0
+ iso3(j) = 0
+ ncoll(j) = 0
+ rx(j) = 0.0
+ ry(j) = 0.0
+ rz(j) = 0.0
+ px(j) = 0.0
+ py(j) = 0.0
+ pz(j) = 0.0
+ fmass(j) = 0.0
+ 20 continue
+ return
+ end
+
+
+
+ subroutine derivs(row)
+ implicit none
+ integer j, k, index, row
+ real*8 spu, spo, outu, outo, tmp, a, b, dy, dp, drdp, dpj
+ real*8 rxjku, ryjku, rzjku, rjku, pxjku, pyjku, pzjku, pjku
+ logical iPau
+ include 'coms.f'
+
+C aopx(j,?) = -dH/dx_j
+C aorx(j,?) = dH/dpx_j
+
+ do 10 j=1,nbar
+ rww(j) = 0.0
+ 10 continue
+ if(logSky) then
+ do 20 j=1,nbar
+ do 30 k=j+1,nbar
+ rxjku = (airx(j)-airx(k))
+ ryjku = (airy(j)-airy(k))
+ rzjku = (airz(j)-airz(k))
+ rjku = sqrt(rxjku**2+ryjku**2+rzjku**2)
+ if(rjku.lt.cutdww) then
+ index = int(rjku/delr)+1
+ a = dble(index) - rjku/delr
+ b = 1.0 - a
+ tmp = a*spdwwy(index)+b*spdwwy(index+1)+
+ + ((a**3-a)*outdww(index)+(b**3-b)*outdww(index+1))*fdel
+ rww(j) = rww(j) + tmp
+ rww(k) = rww(k) + tmp
+ end if
+ 30 continue
+ 20 continue
+ end if
+
+ do 40 j=1,nbar
+ aopx(j,row) = 0.0
+ aopy(j,row) = 0.0
+ aopz(j,row) = 0.0
+ dpj = 1.0/sqrt(aipx(j)*aipx(j)+aipy(j)*aipy(j)+aipz(j)*aipz(j)+
+ + fmass(j)*fmass(j))
+ aorx(j,row) = aipx(j)*dpj
+ aory(j,row) = aipy(j)*dpj
+ aorz(j,row) = aipz(j)*dpj
+ 40 continue
+
+ do 50 j=1,nbar
+ do 60 k=j+1,nbar
+ rxjku = (airx(j)-airx(k))
+ ryjku = (airy(j)-airy(k))
+ rzjku = (airz(j)-airz(k))
+ rjku = sqrt(rxjku**2+ryjku**2+rzjku**2)
+ if (rjku.ge.1.0E-8) then
+ rxjku = rxjku/rjku
+ ryjku = ryjku/rjku
+ rzjku = rzjku/rjku
+ else
+ rxjku = 0.0
+ ryjku = 0.0
+ rzjku = 0.0
+ end if
+ spu = 0.0
+ spo = 0.0
+ outu = 0.0
+ outo = 0.0
+ dy = 0.0
+ index = int(rjku/delr)+1
+ a = dble(index)-rjku/delr
+ b = 1.0-a
+ if(logYuk.and.rjku.lt.cutYuk) then
+ spu = spu + spYuky(index)
+ spo = spo + spYuky(index+1)
+ outu = outu + outYuk(index)
+ outo = outo + outYuk(index+1)
+ end if
+ if(logSky.and.rjku.lt.cutdww) then
+ tmp = Sky20 + Sky30*gamSky/(gamSky+1.0)*
+ * (rww(j)**(gamSky-1.0)+rww(k)**(gamSky-1.0))
+ spu = spu + spdwwy(index)*tmp
+ spo = spo + spdwwy(index+1)*tmp
+ outu = outu + outdww(index)*tmp
+ outo = outo + outdww(index+1)*tmp
+ end if
+ dy = da*spu+db*spo+
+ + ((3.0*a**2-1.0)*da*outu+(3.0*b**2-1.0)*db*outo)*fdel
+ if(logCb) then
+ if(rjku.lt.cutCb) then
+ dy = dy + (da*spCby(index)+db*spCby(index+1)+
+ + ((3.0*a**2-1.0)*da*outCb(index)+
+ + (3.0*b**2-1.0)*db*outCb(index+1))*fdel)*
+ * dble(charge(j)*charge(k))
+ else
+ dy = dy - Cb0/rjku/rjku*dble(charge(j)*charge(k))
+ end if
+ end if
+ if(logPau.and.iPau(j,k)) then
+ pxjku = (aipx(j)-aipx(k))
+ pyjku = (aipy(j)-aipy(k))
+ pzjku = (aipz(j)-aipz(k))
+ pjku = sqrt(pxjku**2+pyjku**2+pzjku**2)
+ if (pjku.ge.1.0E-8) then
+ pxjku = pxjku/pjku
+ pyjku = pyjku/pjku
+ pzjku = pzjku/pjku
+ else
+ pxjku = 0.0
+ pyjku = 0.0
+ pzjku = 0.0
+ end if
+ drdp = 0.5*(pjku*pjku/dpPau+rjku*rjku/drPau)
+ if(drdp.lt.cutPau) then
+ index = int(drdp/delr)+1
+ a = dble(index)-drdp/delr
+ b = 1.0-a
+ tmp = da*spPauy(index)+db*spPauy(index+1)+
+ + ((3.0*a**2-1.0)*da*outPau(index)+
+ + (3.0*b**2-1.0)*db*outPau(index+1))*fdel
+ dy = dy+tmp*rjku/drPau
+ dp = tmp*pjku/dpPau*0.001
+ aorx(j,row) = aorx(j,row)+dp*pxjku
+ aory(j,row) = aory(j,row)+dp*pyjku
+ aorz(j,row) = aorz(j,row)+dp*pzjku
+ aorx(k,row) = aorx(k,row)-dp*pxjku
+ aory(k,row) = aory(k,row)-dp*pyjku
+ aorz(k,row) = aorz(k,row)-dp*pzjku
+ end if
+ end if
+ dy = -(0.001*dy)
+ aopx(j,row) = aopx(j,row)+dy*rxjku
+ aopy(j,row) = aopy(j,row)+dy*ryjku
+ aopz(j,row) = aopz(j,row)+dy*rzjku
+ aopx(k,row) = aopx(k,row)-dy*rxjku
+ aopy(k,row) = aopy(k,row)-dy*ryjku
+ aopz(k,row) = aopz(k,row)-dy*rzjku
+ 60 continue
+ 50 continue
+ return
+ end
+
+ real*8 function Ekintot()
+ implicit none
+ integer j
+ real*8 Ekin
+ include 'coms.f'
+
+ Ekintot = 0.0
+ do 3 j=1,npart
+ Ekintot= Ekintot+Ekin(j)
+ 3 continue
+ return
+ end
+
+ real*8 function EtotJK()
+ implicit none
+ real*8 Etot
+ integer j
+ include 'coms.f'
+
+ EtotJK = Etot()
+ do 3 j=1,npart
+ EtotJK= EtotJK-fmass(j)
+ 3 continue
+ EtotJK = EtotJK/npart
+ return
+ end
+
+
+ real*8 function Etot()
+ implicit none
+ integer j, k, index
+ real*8 a, b, y, drdp, tp, tr, tmp, Ekintot
+ real*8 Ekinbar, Ekinmes, ESky2, ESky3, EYuk, ECb, EPau, Ekin
+ real*8 rxjku, ryjku, rzjku, rjku, pxjku, pyjku, pzjku, pjku
+ logical iPau
+ include 'coms.f'
+ common /energies/ Ekinbar, Ekinmes, ESky2, ESky3, EYuk, ECb, EPau
+
+ Etot = 0.0
+ Ekinbar = 0.0
+ Ekinmes = 0.0
+ ESky2 = 0.0
+ ESky3 = 0.0
+ EYuk = 0.0
+ ECb = 0.0
+ EPau = 0.0
+
+ if(EoS.eq.0) then
+
+c CASCADE mode
+ Etot=Ekintot()
+ return
+ else
+c with potentials
+c kinetic energies of mesons first
+ do 4 j=nbar+1,npart
+ Etot= Etot+Ekin(j)
+ Ekinmes = Ekinmes+Ekin(j)
+ 4 continue
+
+ do 10 j=1,nbar
+ rww(j) = 0.0
+ 10 continue
+ if(logSky) then
+ do 20 j=1,nbar
+ do 30 k=j+1,nbar
+ rxjku = (rx(j)-rx(k))
+ ryjku = (ry(j)-ry(k))
+ rzjku = (rz(j)-rz(k))
+ rjku = sqrt(rxjku**2+ryjku**2+rzjku**2)
+ if(rjku.lt.cutdww) then
+ index = int(rjku/delr)+1
+ a = dble(index) - rjku/delr
+ b = 1.0 - a
+ tmp = a*spdwwy(index)+b*spdwwy(index+1)+
+ + ((a**3-a)*outdww(index)+(b**3-b)*outdww(index+1))*fdel
+ rww(j) = rww(j) + tmp
+ rww(k) = rww(k) + tmp
+ end if
+ 30 continue
+ 20 continue
+ end if
+
+ do 40 j=1,nbar
+ Etot = Etot + Ekin(j) + 0.0005*Sky20*rww(j) +
+ + 0.001*Sky30/(gamSky+1.0)*rww(j)**gamSky
+ Ekinbar = Ekinbar + Ekin(j)
+ ESky2 = ESky2 + 0.0005*Sky20*rww(j)
+ ESky3 = ESky3 + 0.001*Sky30/(gamSky+1.0)*rww(j)**gamSky
+ do 50 k=j+1,nbar
+ rxjku = (rx(j)-rx(k))
+ ryjku = (ry(j)-ry(k))
+ rzjku = (rz(j)-rz(k))
+ rjku = sqrt(rxjku**2+ryjku**2+rzjku**2)
+ index = int(rjku/delr)+1
+ a = dble(index)-rjku/delr
+ b = 1.0-a
+ if(logYuk.and.rjku.lt.cutYuk) then
+ y = a*spYuky(index)+b*spYuky(index+1)+
+ + ((a**3-a)*outYuk(index)+(b**3-b)*outYuk(index+1))*fdel
+ Etot = Etot + 0.001*y
+ EYuk = EYuk + 0.001*y
+ end if
+ if(logCb) then
+ if(rjku.lt.cutCb) then
+ y = (a*spCby(index)+b*spCby(index+1)+
+ + ((a**3-a)*outCb(index)+(b**3-b)*outCb(index+1))*fdel)*
+ * dble(charge(j)*charge(k))
+ else
+ y = Cb0/rjku*dble(charge(j)*charge(k))
+ end if
+ Etot = Etot + 0.001*y
+ ECb = ECb + 0.001*y
+ end if
+ if(logPau.and.iPau(j,k)) then
+ pxjku = (px(j)-px(k))
+ pyjku = (py(j)-py(k))
+ pzjku = (pz(j)-pz(k))
+ pjku = sqrt(pxjku**2+pyjku**2+pzjku**2)
+ tp = pjku
+ tr = rjku
+ drdp = 0.5*(pjku*pjku/dpPau+rjku*rjku/drPau)
+ if(drdp.lt.cutPau) then
+ index = int(drdp/delr)+1
+ a = dble(index)-drdp/delr
+ b = 1.0-a
+ y = a*spPauy(index)+b*spPauy(index+1)+
+ + ((a**3-a)*outPau(index)+(b**3-b)*outPau(index+1))*fdel
+ Etot = Etot + 0.001*y
+ EPau = EPau + 0.001*y
+ end if
+ end if
+ 50 continue
+ 40 continue
+ Ekinbar = Ekinbar/dble(nbar)
+ Ekinmes = Ekinmes/dble(max(1,npart-nbar))
+ ESky2 = ESky2/dble(nbar)
+ ESky3 = ESky3/dble(nbar)
+ EYuk = EYuk/dble(nbar)
+ ECb = ECb/dble(nbar)
+ EPau = EPau/dble(nbar)
+ end if
+ return
+ end
+
+
+ subroutine cascstep(tim,dtime)
+ implicit none
+ real*8 tim,dtime,energ
+ integer j
+ include 'coms.f'
+ include 'boxinc.f'
+ include 'options.f'
+ctp060202 to avoid warnings with gfortran compilation
+ logical ctp060202
+ ctp060202=.false.
+ if(ctp060202)write(*,*)tim
+ctp060202 end
+
+ do 1 j=1,npart
+ energ = sqrt(px(j)**2+py(j)**2+pz(j)**2+fmass(j)**2)
+ r0(j) = r0(j) + dtime
+ rx(j) = rx(j) + px(j)/energ*dtime
+ rz(j) = rz(j) + pz(j)/energ*dtime
+ ry(j) = ry(j) + py(j)/energ*dtime
+1 continue
+ return
+ end
+
+ subroutine proprk(tim,dtime)
+
+ implicit none
+ real*8 tim,dtime,energ,dt2, dt6
+ integer j
+
+ include 'coms.f'
+ include 'boxinc.f'
+ include 'options.f'
+ctp060202 to avoid warnings with gfortran compilation
+ logical ctp060202
+ ctp060202=.false.
+ if(ctp060202)write(*,*)tim
+ctp060202 end
+
+ if (EoS.eq.0) then
+c cascade mode
+ do 1 j=1,npart
+ energ = p0(j) ! sqrt(px(j)**2+py(j)**2+pz(j)**2+fmass(j)**2)
+ r0(j) = r0(j) + dtime
+ rx(j) = rx(j) + px(j)/energ*dtime
+ ry(j) = ry(j) + py(j)/energ*dtime
+ rz(j) = rz(j) + pz(j)/energ*dtime
+1 continue
+ return
+ else
+c propagation with potentials
+c propagate mesons on straight lines
+ do 2 j=nbar+1,npart
+ energ = p0(j) ! sqrt(px(j)**2+py(j)**2+pz(j)**2+fmass(j)**2)
+ r0(j) = r0(j) + dtime
+ rx(j) = rx(j) + px(j)/energ*dtime
+ ry(j) = ry(j) + py(j)/energ*dtime
+ rz(j) = rz(j) + pz(j)/energ*dtime
+2 continue
+
+c propagate baryons
+c adjust time-step parameters
+ dt = dtime
+ dt2 = dtime/2.0d0
+ dt6 = dtime/6.0d0
+
+ do 10 j=1,nbar
+ airx(j) = rx(j)
+ airy(j) = ry(j)
+ airz(j) = rz(j)
+ aipx(j) = px(j)
+ aipy(j) = py(j)
+ aipz(j) = pz(j)
+ 10 continue
+
+ call derivs(1)
+ do 20 j=1,nbar
+ airx(j) = rx(j) + dt2*aorx(j,1)
+ airy(j) = ry(j) + dt2*aory(j,1)
+ airz(j) = rz(j) + dt2*aorz(j,1)
+ aipx(j) = px(j) + dt2*aopx(j,1)
+ aipy(j) = py(j) + dt2*aopy(j,1)
+ aipz(j) = pz(j) + dt2*aopz(j,1)
+ 20 continue
+
+ call derivs(2)
+
+ do 30 j=1,nbar
+ airx(j) = rx(j) + dt2*aorx(j,2)
+ airy(j) = ry(j) + dt2*aory(j,2)
+ airz(j) = rz(j) + dt2*aorz(j,2)
+ aipx(j) = px(j) + dt2*aopx(j,2)
+ aipy(j) = py(j) + dt2*aopy(j,2)
+ aipz(j) = pz(j) + dt2*aopz(j,2)
+ 30 continue
+
+ call derivs(3)
+
+ do 40 j=1,nbar
+ airx(j) = rx(j) + dt*aorx(j,3)
+ airy(j) = ry(j) + dt*aory(j,3)
+ airz(j) = rz(j) + dt*aorz(j,3)
+ aipx(j) = px(j) + dt*aopx(j,3)
+ aipy(j) = py(j) + dt*aopy(j,3)
+ aipz(j) = pz(j) + dt*aopz(j,3)
+ 40 continue
+
+ call derivs(4)
+
+ do 50 j=1,nbar
+ r0(j) = r0(j) + dtime
+ rx(j)=rx(j)+dt6*(aorx(j,1)+2.0*(aorx(j,2)+aorx(j,3))+aorx(j,4))
+ ry(j)=ry(j)+dt6*(aory(j,1)+2.0*(aory(j,2)+aory(j,3))+aory(j,4))
+ rz(j)=rz(j)+dt6*(aorz(j,1)+2.0*(aorz(j,2)+aorz(j,3))+aorz(j,4))
+ px(j)=px(j)+dt6*(aopx(j,1)+2.0*(aopx(j,2)+aopx(j,3))+aopx(j,4))
+ py(j)=py(j)+dt6*(aopy(j,1)+2.0*(aopy(j,2)+aopy(j,3))+aopy(j,4))
+ pz(j)=pz(j)+dt6*(aopz(j,1)+2.0*(aopz(j,2)+aopz(j,3))+aopz(j,4))
+ p0(j)=sqrt(px(j)**2+py(j)**2+pz(j)**2+fmass(j)**2)
+ 50 continue
+ end if
+
+ return
+ end
+
+
+ subroutine potPau
+ implicit none
+ integer i, ncut, index
+ real*8 Ecut, dr, abl0, abln, a, b, y, dy, Pau
+ include 'coms.f'
+
+ rx(1) = 0.0d0
+ ry(1) = 0.0d0
+ rz(1) = 0.0d0
+ ry(2) = 0.0d0
+ rz(2) = 0.0d0
+ px(1) = 0.0d0
+ py(1) = 0.0d0
+ pz(1) = 0.0d0
+ px(1) = 0.0d0
+ py(2) = 0.0d0
+ pz(2) = 0.0d0
+ Ecut = 1.0E-5
+ i = 0
+ 99 i = i+1
+ dr = delr*dble(i-1)
+ rx(2) = sqrt(2.0*dr*drPau)
+ spx(i) = dr
+ spPauy(i) = Pau(1,2)
+ if(spPauy(i).lt.Ecut) then
+ spPauy(i) = 0.0
+ cutPau = dr
+ abl0 = -Pau0
+ abln = 0.0
+ ncut = i
+ else
+ goto 99
+ end if
+ call spline(spx,spPauy,ncut,abl0,abln,outPau)
+
+ write(6,'(''Pauli-Potential '',e10.3,i5,f7.1)')
+ + Ecut, ncut, cutPau
+
+ do 10 i=0,20
+ dr = 0.323*dble(i)
+ if(dr.gt.cutPau) then
+ y = 0.0
+ dy = 0.0
+ else
+ rx(2) = dr
+ dr = 0.5*dr*dr/drPau
+ index = int(dr/delr)+1
+ a = dble(index) - dr/delr
+ b = 1.0 - a
+ y = a*spPauy(index)+b*spPauy(index+1)+
+ + ((a**3-a)*outPau(index)+
+ + (b**3-b)*outPau(index+1))*fdel
+ dy = da*spPauy(index)+db*spPauy(index+1)+
+ + ((3.0*a**2-1.0)*da*outPau(index)+
+ + (3.0*b**2-1.0)*db*outPau(index+1))*fdel
+ dy = dy*sqrt(2.0*dr*drPau)/drPau
+ end if
+ 10 continue
+ return
+ end
+
+ subroutine potCb
+ implicit none
+ integer i, ncut, index
+ real*8 Ecut, dr, abl0, abln, a, b, y, dy, dCb, Cb
+ include 'coms.f'
+
+ rx(1) = 0.0d0
+ ry(1) = 0.0d0
+ rz(1) = 0.0d0
+ ry(2) = 0.0d0
+ rz(2) = 0.0d0
+ Ecut = 1.0E-5
+ iso3(1) = 1
+ iso3(2) = 1
+ i = 0
+ 99 i = i+1
+ dr = delr*dble(i-1)
+ rx(2) = dr
+ spx(i) = dr
+ spCby(i) = Cb(1,2)
+ if(abs(spCby(i)*dr-Cb0)/max(dr,1.0d-5).lt.Ecut) then
+ spCby(i) = Cb0/dr
+ cutCb = dr
+ abln = dCb(1,2)
+ abl0 = 0.0
+ ncut = i
+ else
+ goto 99
+ end if
+ call spline(spx,spCby,ncut,abl0,abln,outCb)
+
+ write(6,'(''Coulomb-Potential '',e10.3,i5,f7.1)')
+ + Ecut, ncut, cutCb
+
+ do 10 i=0,20
+ dr = 0.2*dble(i)+0.01212
+ rx(2) = dr
+ if(dr.ge.cutCb) then
+ y = Cb0/dr
+ dy = -(Cb0/dr/dr)
+ else
+ index = int(dr/delr)+1
+ a = dble(index) - dr/delr
+ b = 1.0 - a
+ y = a*spCby(index)+b*spCby(index+1)+
+ + ((a**3-a)*outCb(index)+(b**3-b)*outCb(index+1))*fdel
+ dy = da*spCby(index)+db*spCby(index+1)+
+ + ((3.0*a**2-1.0)*da*outCb(index)+
+ + (3.0*b**2-1.0)*db*outCb(index+1))*fdel
+ end if
+ 10 continue
+ return
+ end
+
+ subroutine potYuk
+ implicit none
+ integer i, ncut, index
+ real*8 Ecut, dr, abl0, abln, a, b, y, dy
+ real*8 Yuk
+ include 'coms.f'
+
+ rx(1) = 0.0d0
+ ry(1) = 0.0d0
+ rz(1) = 0.0d0
+ ry(2) = 0.0d0
+ rz(2) = 0.0d0
+ Ecut = 1.0E-5
+ i = 0
+ 99 i = i+1
+ dr = delr*dble(i-1)
+ rx(2) = dr
+ spx(i) = dr
+ spYuky(i) = Yuk(1,2)
+ if(abs(spYuky(i)).lt.Ecut) then
+ spYuky(i) = 0.0
+ cutYuk = dr
+ abl0 = 0.0
+ abln = 0.0
+ ncut = i
+ else
+ goto 99
+ end if
+ call spline(spx,spYuky,ncut,abl0,abln,outYuk)
+
+ write(6,'(''Yukawa-Potential '',e10.3,i5,f7.1)')
+ + Ecut, ncut, cutYuk
+
+ do 10 i=0,40
+ dr = 0.2*dble(i)
+ rx(2) = dr
+ if(dr.gt.cutYuk) then
+ y = 0.0
+ dy = 0.0
+ else
+ index = int(dr/delr)+1
+ a = dble(index) - dr/delr
+ b = 1.0 - a
+ y = a*spYuky(index)+b*spYuky(index+1)+
+ + ((a**3-a)*outYuk(index)+(b**3-b)*outYuk(index+1))*fdel
+ dy = da*spYuky(index)+db*spYuky(index+1)+
+ + ((3.0*a**2-1.0)*da*outYuk(index)+
+ + (3.0*b**2-1.0)*db*outYuk(index+1))*fdel
+ end if
+ 10 continue
+ return
+ end
+
+
+ subroutine potdww
+ implicit none
+ integer i, ncut, index
+ real*8 Ecut, dr, abl0, abln, a, b, y, dy
+ real*8 dww
+ include 'coms.f'
+
+ rx(1) = 0.0d0
+ ry(1) = 0.0d0
+ rz(1) = 0.0d0
+ ry(2) = 0.0d0
+ rz(2) = 0.0d0
+ Ecut = 1.0E-8
+ i = 0
+ 99 i = i+1
+ dr = delr*dble(i-1)
+ rx(2) = dr
+ spx(i) = dr
+ spdwwy(i) = dww(1,2)
+ if(abs(spdwwy(i)).lt.Ecut) then
+ spdwwy(i) = 0.0
+ cutdww = dr
+ abl0 = 0.0
+ abln = 0.0
+ ncut = i
+ else
+ goto 99
+ end if
+ call spline(spx,spdwwy,ncut,abl0,abln,outdww)
+
+ write(6,'(''Interaction-Density'',e10.3,i5,f7.1)')
+ + Ecut, ncut, cutdww
+
+ do 10 i=0,20
+ dr = 0.295*dble(i)
+ rx(2) = dr
+ if(dr.gt.cutdww) then
+ y = 0.0
+ dy = 0.0
+ else
+ index = int(dr/delr)+1
+ a = dble(index) - dr/delr
+ b = 1.0 - a
+ y = a*spdwwy(index)+b*spdwwy(index+1)+
+ + ((a**3-a)*outdww(index)+(b**3-b)*outdww(index+1))*fdel
+ dy = da*spdwwy(index)+db*spdwwy(index+1)+
+ + ((3.0*a**2-1.0)*da*outdww(index)+
+ + (3.0*b**2-1.0)*db*outdww(index+1))*fdel
+ end if
+ 10 continue
+ return
+ end
+
+c Kinetic Energy
+c
+ function Ekin(j)
+ implicit none
+ integer j
+ real*8 Ekin
+ include 'coms.f'
+
+ Ekin = sqrt((px(j)+ffermpx(j))*(px(j)+ffermpx(j))+
+ + (py(j)+ffermpy(j))*(py(j)+ffermpy(j))+
+ + (pz(j)+ffermpz(j))*(pz(j)+ffermpz(j))+
+ + fmass(j)*fmass(j))
+
+ return
+ end
+
+c Derivative for Kinetic Energy
+c
+ function dEkin(j)
+ implicit none
+ integer j
+ real*8 dEkin
+ include 'coms.f'
+
+ dEkin = 1.0/sqrt(px(j)*px(j)+py(j)*py(j)+pz(j)*pz(j)+
+ + fmass(j)*fmass(j))
+ return
+ end
+
+c Skyrme Potential (3-body) rwwterm
+c
+ function dww(j,k)
+ implicit none
+ integer j, k
+ real*8 dww, rjk
+ include 'coms.f'
+
+ dww = gw/pi*sqrt(gw/pi)*exp(-(gw*rjk(j,k)*rjk(j,k)))/
+ / rho0
+ return
+ end
+
+cc Skyrme Potential
+cc
+ function Sky(j,k)
+ implicit none
+ integer j, k
+ real*8 Sky, rjk
+ include 'coms.f'
+
+ Sky = Sky20*gw/pi*sqrt(gw/pi)*exp(-(gw*rjk(j,k)*rjk(j,k)))
+ return
+ end
+
+c Coulomb Potential
+c
+ function Cb(j,k)
+ implicit none
+ integer j, k
+ real*8 Cb, rjk
+ real*8 erf
+ include 'coms.f'
+
+ if (iso3(j).eq.1.and.iso3(k).eq.1) then
+ if (rjk(j,k).lt.eps) then
+ Cb = Cb0*er0*sgw
+ else
+ Cb = Cb0/rjk(j,k)*erf(sgw*rjk(j,k))
+ end if
+ else
+ Cb = 0.0
+ end if
+ return
+ end
+
+c Derivative for Coulomb Potential
+c
+ function dCb(j,k)
+ implicit none
+ integer j, k
+ real*8 dCb, rjk
+ real*8 erf
+ include 'coms.f'
+
+ if (iso3(j).eq.1.and.iso3(k).eq.1) then
+ if (rjk(j,k).lt.eps) then
+ dCb = 0.0
+ else
+ dCb = Cb0*(er0*exp(-(gw*rjk(j,k)*rjk(j,k)))*sgw*rjk(j,k)-
+ + erf(sgw*rjk(j,k)))/rjk(j,k)/rjk(j,k)
+ end if
+ else
+ dCb = 0.0
+ end if
+ return
+ end
+
+c Yukawa Potential
+c
+ function Yuk(j,k)
+ implicit none
+ integer j, k
+ real*8 Yuk, rjk
+ real*8 erf
+ include 'coms.f'
+
+ if(rjk(j,k).lt.eps) then
+ Yuk = Yuk0*(er0*sgw-exp(0.25/gamYuk/gamYuk/gw)/gamYuk*
+ * (1.0-erf(0.5/gamYuk/sgw)))
+ else
+ Yuk = Yuk0*0.5/rjk(j,k)*exp(0.25/gamYuk/gamYuk/gw)*
+ * (exp(-(rjk(j,k)/gamYuk))*
+ + (1.0-erf(0.5/gamYuk/sgw-sgw*rjk(j,k)))-
+ - exp(rjk(j,k)/gamYuk)*
+ + (1.0-erf(0.5/gamYuk/sgw+sgw*rjk(j,k))))
+ end if
+ return
+ end
+
+c Derivative for Yukawa Potential
+c
+ function dYuk(j,k)
+ implicit none
+ integer j, k
+ real*8 dYuk, rjk
+ real*8 erf
+ include 'coms.f'
+
+ if(rjk(j,k).lt.eps) then
+ dYuk = 0.0
+ else
+ dYuk = 0.5*Yuk0/rjk(j,k)*( exp(0.25/gamYuk/gamYuk/gw)*(
+ * (-(1.0/rjk(j,k))-1.0/gamYuk)*exp(-(rjk(j,k)/gamYuk))*
+ * (1.0-erf(0.5/gamYuk/sgw-sgw*rjk(j,k))) +
+ * (1.0/rjk(j,k)-1.0/gamYuk)*exp(rjk(j,k)/gamYuk)*
+ * (1.0-erf(0.5/gamYuk/sgw+sgw*rjk(j,k))) ) +
+ + sgw*er0*2.0*exp(-(gw*rjk(j,k)*rjk(j,k))) )
+ end if
+ return
+ end
+
+
+c Pauli Potential
+c
+ function Pau(j,k)
+ implicit none
+ integer j, k
+ real*8 Pau, pjk, rjk
+ include 'coms.f'
+
+ Pau = Pau0*exp(-(0.5*rjk(j,k)*rjk(j,k)/drPau))*
+ * exp(-(0.5*pjk(j,k)*pjk(j,k)/dpPau))
+ return
+ end
+
+c Derivative (p) for Pauli Potential
+c
+ function dPaup(j,k)
+ implicit none
+ integer j, k
+ real*8 dPaup, pjk, rjk
+ include 'coms.f'
+
+ dPaup = -(Pau0/dpPau*pjk(j,k)*
+ * exp(-(0.5*rjk(j,k)*rjk(j,k)/drPau))*
+ * exp(-(0.5*pjk(j,k)*pjk(j,k)/dpPau)))
+ return
+ end
+
+c Derivative (r) for Pauli Potential
+c
+ function dPaur(j,k)
+ implicit none
+ integer j, k
+ real*8 dPaur, pjk, rjk
+ include 'coms.f'
+
+ dPaur = -(Pau0/drPau*rjk(j,k)*
+ * exp(-(0.5*rjk(j,k)*rjk(j,k)/drPau))*
+ * exp(-(0.5*pjk(j,k)*pjk(j,k)/dpPau)))
+ return
+ end
+
+ function rjk(j,k)
+ implicit none
+ integer j, k
+ real*8 rjk
+ include 'coms.f'
+
+ rjk = sqrt((rx(j)-rx(k))**2+(ry(j)-ry(k))**2+(rz(j)-rz(k))**2)
+ return
+ end
+
+ function pjk(j,k)
+ implicit none
+ integer j, k
+ real*8 pjk
+ include 'coms.f'
+
+ pjk = sqrt((px(j)-px(k))**2+(py(j)-py(k))**2+(pz(j)-pz(k))**2)
+ return
+ end
+
+ function iPau(j,k)
+ implicit none
+ integer j, k
+ logical iPau
+ include 'coms.f'
+
+ iPau = .false.
+ if (iso3(j).eq.iso3(k).and.ityp(j).eq.ityp(k)) iPau = .true.
+ return
+ end
diff --git a/Processes/UrQMD/saveinfo.f b/Processes/UrQMD/saveinfo.f
new file mode 100644
index 0000000000000000000000000000000000000000..a14a935ac213a52c04bd0295d932860201f0ba4b
--- /dev/null
+++ b/Processes/UrQMD/saveinfo.f
@@ -0,0 +1,121 @@
+c $Id: saveinfo.f,v 1.7 2002/05/03 00:31:19 weber Exp $
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+ subroutine saveinfo(ind,itag)
+c
+c Revision : 1.0
+c
+cinput ind: particle ID
+cinput itag: slot for particle to stored (>0) or extracted (<0) from
+c
+c This subroutine stores the information of the {\tt ind} slot in
+c the particle arrays (necessary in case of pauli-blocked collisions)
+c The absolute value of {\tt itag} indicates the storage slot to be used.
+c For positive values of {\tt itag} the information is stored, for negative
+c values it is restored. Currently two slots are available.
+C
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+c
+ implicit none
+ include 'coms.f'
+c
+ integer ind,itag,islot,j
+ integer lstcollt(2),ncollt(2)
+ integer charget(2),spint(2),stridt(2)
+c origint(2),uidt(2)
+ real*8 r0t(2),rxt(2),ryt(2),rzt(2),
+ p r0tt(2),rxtt(2),rytt(2),rztt(2),
+ @ p0t(2),pxt(2),pyt(2),pzt(2),fmasst(2),tdectime(2),
+ @ xtotfact(2),tformt(2),p0tdt(2,2),pxtdt(2,2),pytdt(2,2),
+ @ pztdt(2,2),fmasstdt(2,2)
+ integer ityptdt(2,2),iso3tdt(2,2)
+ save
+c
+ if(ind.eq.0) return
+c
+ islot=abs(itag)
+
+c save particle
+ if(itag.gt.0) then
+ r0t(islot)=r0(ind)
+ rxt(islot)=rx(ind)
+ ryt(islot)=ry(ind)
+ rzt(islot)=rz(ind)
+cpot
+ r0tt(islot)=r0_t(ind)
+ rxtt(islot)=rx_t(ind)
+ rytt(islot)=ry_t(ind)
+ rztt(islot)=rz_t(ind)
+
+ p0t(islot)=p0(ind)
+ pxt(islot)=px(ind)
+ pyt(islot)=py(ind)
+ pzt(islot)=pz(ind)
+ fmasst(islot)=fmass(ind)
+ itypt(islot)=ityp(ind)
+ iso3t(islot)=iso3(ind)
+ ncollt(islot)=ncoll(ind)
+ lstcollt(islot)=lstcoll(ind)
+ origint(islot)=origin(ind)
+ charget(islot)=charge(ind)
+ spint(islot)=spin(ind)
+ tdectime(islot)=dectime(ind)
+ stridt(islot)=strid(ind)
+ uidt(islot)=uid(ind)
+ xtotfact(islot)=xtotfac(ind)
+ tformt(islot)=tform(ind)
+ctd
+ do 11 j=1,2
+ p0tdt(j,islot)=p0td(j,ind)
+ pxtdt(j,islot)=pxtd(j,ind)
+ pytdt(j,islot)=pytd(j,ind)
+ pztdt(j,islot)=pztd(j,ind)
+ fmasstdt(j,islot)=fmasstd(j,ind)
+ ityptdt(j,islot)=ityptd(j,ind)
+ iso3tdt(j,islot)=iso3td(j,ind)
+ 11 continue
+
+c ...
+ elseif(itag.lt.0)then
+c restore particle
+ r0(ind)=r0t(islot)
+ rx(ind)=rxt(islot)
+ ry(ind)=ryt(islot)
+ rz(ind)=rzt(islot)
+cpot
+ r0_t(ind)=r0tt(islot)
+ rx_t(ind)=rxtt(islot)
+ ry_t(ind)=rytt(islot)
+ rz_t(ind)=rztt(islot)
+
+ p0(ind)=p0t(islot)
+ px(ind)=pxt(islot)
+ py(ind)=pyt(islot)
+ pz(ind)=pzt(islot)
+ fmass(ind)=fmasst(islot)
+ ityp(ind)=itypt(islot)
+ iso3(ind)=iso3t(islot)
+ ncoll(ind)=ncollt(islot)
+ lstcoll(ind)=lstcollt(islot)
+ origin(ind)=origint(islot)
+ charge(ind)=charget(islot)
+ spin(ind)=spint(islot)
+ dectime(ind)=tdectime(islot)
+ strid(ind)=stridt(islot)
+ uid(ind)=uidt(islot)
+ xtotfac(ind)=xtotfact(islot)
+ tform(ind)=tformt(islot)
+ctd
+ do 12 j=1,2
+ p0td(j,ind)=p0tdt(j,islot)
+ pxtd(j,ind)=pxtdt(j,islot)
+ pytd(j,ind)=pytdt(j,islot)
+ pztd(j,ind)=pztdt(j,islot)
+ fmasstd(j,ind)=fmasstdt(j,islot)
+ ityptd(j,ind)=ityptdt(j,islot)
+ iso3td(j,ind)=iso3tdt(j,islot)
+ 12 continue
+
+ endif
+ return
+ end
diff --git a/Processes/UrQMD/scatter.f b/Processes/UrQMD/scatter.f
new file mode 100644
index 0000000000000000000000000000000000000000..0611287bcbb322fa797dd28435673efd30c9a9a0
--- /dev/null
+++ b/Processes/UrQMD/scatter.f
@@ -0,0 +1,1437 @@
+c$Id: scatter.f,v 1.23 2002/05/03 00:31:19 weber Exp $
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+ subroutine scatter(id1,id2,ssigtot,sqrts,ccolfac)
+c
+c Revision : 1.0
+c
+cinput id1 : index of particle 1
+cinput id2 : index of particle 2
+cinput ssigtot: total cross section
+cinput sqrts : $sqrt{s}$ of collision
+cinput ccolfac : scale factor for color fluctuations
+c
+c This subroutine performs the scattering/annihilation
+c of two particles or the decay
+c of one particle in the incoming channel.
+c
+c Structure of this routine:
+c \begin{enumerate}
+c \item transform to NN system for proper kinematics
+c \item get collision class and number of exit-channels
+c \item loop over exit-channels and get partial cross sections
+c \item select exit-channel
+c \item save information in case of pauli-blocking
+c \item call kinematics routines
+c \item call output routine for collision file
+c \end{enumerate}
+c
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+ implicit none
+
+ include 'coms.f'
+ include 'comres.f'
+ include 'newpart.f'
+ include 'options.f'
+ include 'boxinc.f'
+
+
+c local variables
+ real*8 sqrts,ssigtot,sigpart,sigma(0:maxpsig),sigsum,sigfac
+ real*8 e1,e2,lambda,colldens,ccolfac
+ integer ind1,ind2,ityp1,ityp2,isigline,nCh,ii
+ integer i,j,itot1,itot2,iso31,iso32
+ integer id1,id2
+c functions and subroutines
+ integer collclass,isoit
+
+c
+c make local copies of particle indices
+ ind1=id1
+ ind2=id2
+c increment collision-counter
+ ctag=ctag+1
+
+c save total cross section in sigma(0)
+ sigma(0)=ssigtot
+
+c initialize some arrays (definitions are listed in newpart.f)
+ do 13 j=1,mprt
+ do 12 i=1,5
+ pnew(i,j)=0.0
+ 12 continue
+ inew(j)=0
+ leadfac(j)=1.d0
+ sidnew(j)=0
+ 13 continue
+
+c if ind2 is less than 0, a collision with a wall takes place
+ if (ind2.lt.0) then
+
+ call file15out(ind1,ind2,sqrts,ssigtot,sigpart)
+
+c solid < 1 then periodic boundary conditions
+ if (solid.lt.1) then
+ if (ind2.eq.-1) then
+ rx(ind1)=rx(ind1)-lbox
+ elseif (ind2.eq.-4) then
+ rx(ind1)=rx(ind1)+lbox
+ elseif (ind2.eq.-2) then
+ ry(ind1)=ry(ind1)-lbox
+ elseif (ind2.eq.-5) then
+ ry(ind1)=ry(ind1)+lbox
+ elseif (ind2.eq.-3) then
+ rz(ind1)=rz(ind1)-lbox
+ else
+ rz(ind1)=rz(ind1)+lbox
+ endif
+ else
+c solid walls
+ if (ind2.eq.-1) then
+ px(ind1)=-px(ind1)
+ elseif (ind2.eq.-4) then
+ px(ind1)=-px(ind1)
+ elseif (ind2.eq.-2) then
+ py(ind1)=-py(ind1)
+ elseif (ind2.eq.-5) then
+ py(ind1)=-py(ind1)
+ elseif (ind2.eq.-3) then
+ pz(ind1)=-pz(ind1)
+ else
+ pz(ind1)=-pz(ind1)
+ endif
+ Endif
+
+ nexit=1
+ inew(1)=ind1
+
+ call f15outch(0.d0)
+
+ return
+ endif
+cc
+
+c add fermi motion
+ if (CTOption(30).eq.1) then
+ call addfermi(ind1,peq1)
+ call addfermi(ind2,peq2)
+ endif
+
+c clear array of partial cross sections
+ do 14 i=1,maxpsig
+ sigma(i)=0.d0
+ 14 continue
+
+c save particle indices into pslot for later use (Danielewicz-Pratt delays)
+ pslot(1)=ind1
+ pslot(2)=ind2
+
+c some abbreviations
+ ityp1=ityp(ind1)
+ itot1=isoit(ityp1)
+ iso31=iso3(ind1)
+ if(ind2.eq.0) then
+ ityp2=0
+ itot2=0
+ iso32=0
+ else
+ ityp2=ityp(ind2)
+ itot2=isoit(ityp2)
+ iso32=iso3(ind2)
+ endif
+
+
+
+
+c transform in to NN system for proper kinematics
+
+ e1 = p0(ind1)
+
+ if(ind2.eq.0) then
+cccc DECAY cccccccccccccccccccccccc
+
+c increment decay counter
+ dectag=dectag+1
+
+c prepare output to decay file
+ call file16entry(ind1)
+
+ sqrts=fmass(ind1)
+ betax=px(ind1)/e1
+ betay=py(ind1)/e1
+ betaz=pz(ind1)/e1
+ p0nn=p0(ind1)
+ pxnn=px(ind1)
+ pynn=py(ind1)
+ pznn=pz(ind1)
+ pnn=sqrt(pxnn*pxnn+pynn*pynn+pznn*pznn)
+
+c set tag for decay:
+ iline=20
+
+ else
+cccc SCATTERING/ANNIHILATION cccc
+ e2 = p0(ind2)
+c transformation betas into two particle CMS system
+ betax=(px(ind1)+px(ind2))/(e1+e2)
+ betay=(py(ind1)+py(ind2))/(e1+e2)
+ betaz=(pz(ind1)+pz(ind2))/(e1+e2)
+
+c calculate momenta in two particle CMS system
+ pxnn=px(ind1)
+ pynn=py(ind1)
+ pznn=pz(ind1)
+ p0nn=e1
+c call to Lorentz transformation
+ call rotbos(0d0,0d0,-betax,-betay,-betaz,
+ & pxnn,pynn,pznn,p0nn)
+ pnn=sqrt(pxnn*pxnn+pynn*pynn+pznn*pznn)
+
+c reduced cross section for leading hadrons of string fragmentation
+c sigfac is scaling factor for cross section
+ sigfac=1.d0
+ if(tform(ind1).le.acttime
+ & .and.tform(ind2).gt.acttime) then
+ sigfac=xtotfac(ind2)
+ else if(tform(ind2).le.acttime
+ & .and.tform(ind1).gt.acttime) then
+ sigfac=xtotfac(ind1)
+ elseif(tform(ind1).gt.acttime
+ & .and.tform(ind2).gt.acttime) then
+ sigfac=xtotfac(ind1)*xtotfac(ind2)
+ endif
+
+c modify sigfac due to color fluctuations
+ sigfac = sigfac*ccolfac
+
+c now get line-number for sigmaLN array in blockres
+ isigline=collclass(ityp1,iso31,ityp2,iso32)
+
+c number of exit-channels:
+ nCh=SigmaLn(1,1,isigline)
+
+ do 10 ii=3,nCh+2 ! loop over exit-channels
+c get process-id (iline) from sigmaLN array in blockres
+ iline=SigmaLn(ii,1,isigline)
+ if(iline.gt.0) then ! normal cross sections:
+
+ call crossx(iline,sqrts,ityp1,iso31,fmass(ind1),
+ & ityp2,iso32,fmass(ind2),sigma(ii-2))
+
+ else ! detailed balance:
+ call crossz(iline,sqrts,ityp1,iso31,fmass(ind1),
+ & ityp2,iso32,fmass(ind2),sigma(ii-2))
+ endif ! end of detailed balance
+c ensure reduction of part. cross sections within formation time
+ sigma(ii-2)=sigfac*sigma(ii-2)
+
+
+ 10 continue ! end of exit channel loop
+
+c unitarize partial cross sections (rescale sum to match the total cross section)
+ call normit (sigma,isigline)
+
+c select partial cross section ii
+ call getbran(sigma,0,maxpsig,sigsum,1,nCh,ii)
+
+ if(sigsum.lt.1d-10)then
+ write(6,*)'***(W) scatter: ',
+ , 'no entry found for fin. state -> forced elastic scat. ',
+ , 'particles:line=',isigline,'ecm=',sqrts
+ write(6,*)' collision of : ',
+ & ityp1,iso31,fmass(ind1),
+ & ityp2,iso32,fmass(ind2)
+ write(6,*)' sigma=',sigma,ii
+c force elastic scattering
+ sigpart=sigma(0)
+ iline=13
+ else
+ sigpart=sigma(ii) ! partial cross section
+ iline=SigmaLN(ii+2,1,isigline) ! <- correct! ii has been redefined
+ end if
+ endif
+cccc end of scatter/decay if
+
+ call file15out(ind1,ind2,sqrts,ssigtot,sigpart)
+
+c save old particle information in case of pauli blocking
+c or rejection due to energy non-conservation
+ call saveinfo(ind1,1)
+ call saveinfo(ind2,2)
+
+c... prepare exit channel
+ call scatprep(ind1,ind2,sqrts,sigpart)
+
+ lambda=1.0d0
+ call prescale(lambda)
+
+ call scatfinal(colldens)
+
+c output to collision file
+ call f15outch(colldens)
+ call osc99_coll
+
+c write output to decay file
+ if(ind2.eq.0) call file16write
+c in case of ctoption(13).ne.0 more output is written with the next call
+ call f16outch
+
+ return
+ end
+
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+ subroutine scatprep(in1,in2,sqrts,sigpart)
+c
+c Revision : 1.0
+c
+cinput ind1 : index of ingoing particle 1
+cinput ind2 : index of ingoing particle 2
+cinput sqrts : $sqrt{s}$ of collision
+cinput sigpart: partial cross section for process
+c
+c {\tt scatprep, prescale} and {\tt scatfinal} handle the collision/decay
+c kinematics and the book-keeping of the global particle vectors.
+c In {\tt scatprep} the exit channel is generated via a call to
+c {\tt make22}, the information is stored in common blocks of the
+c {\tt newpart.f} file. Furthermore the new particle order including
+c new slots for the exit channel are generated in {\tt scatprep}
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+ implicit none
+ include 'coms.f'
+ include 'options.f'
+ include 'comres.f'
+ include 'newpart.f'
+
+ integer i,ind1,ind2,k,in1,in2
+ integer itmp(mprt),ipmp(mprt)
+ real*8 sqrts,sigpart
+ real*8 phi1,phi2
+ real*8 pzi1,pzi2,pxi1,pxi2,pyi1,pyi2
+ real*8 rstringx(2),rstringy(2),rstringz(2),tstring(2),tformold(2)
+ real*8 rpott(2),rpotx(2),rpoty(2),rpotz(2)
+ real*8 th,rdum, ctheta1
+ integer bar,nb1,nb2,nm1,nm2,meslist2(mprt),strid1,strid2
+ integer barlist1(mprt),barlist2(mprt),meslist1(mprt)
+ logical dnscall
+
+c functions:
+
+ real*8 pcms
+ common /scatcomr/rstringx,rstringy,rstringz,tstring,
+ & rpott,rpotx,rpoty,rpotz,
+ & pzi1,pzi2,pxi1,pxi2,pyi1,pyi2,
+ & ctheta1,phi1,th,phi2,tformold
+ common /scatcomi/itmp,ipmp,ind1,ind2,nb1,nb2,strid1,strid2,
+ & bar,nm1,nm2
+ common /scatcoml/dnscall
+ctp060202 to avoid warnings with gfortran compilation
+ logical ctp060202
+ ctp060202=.false.
+ if(ctp060202)write(*,*)sigpart
+ctp060202 end
+
+c call to paulibl for baryon-density
+ dnscall=CTOption(39).ne.0
+
+
+c reset some pointer arrays
+ do 10 i=1,mprt
+ itmp(i)=0
+ ipmp(i)=0
+ barlist1(i)=0
+ barlist2(i)=0
+ meslist1(i)=0
+ 10 continue
+
+ ind1=in1
+ ind2=in2
+ strid1=0
+ strid2=0
+
+c reset xtotfacs
+ if(tform(ind1).le.acttime) xtotfac(ind1)=1.d0
+ if(ind2.gt.0) then
+ if(tform(ind2).le.acttime) xtotfac(ind2)=1.d0
+ endif
+
+c 1. determine mass, ityp's, iso3's of outgoing channel
+c
+ if(ind2.ne.0) then ! scattering/annihilation
+ call make22(iline,sqrts,
+ & ityp(ind1),iso3(ind1),fmass(ind1),xtotfac(ind1),
+ & ityp(ind2),iso3(ind2),fmass(ind2),xtotfac(ind2))
+
+
+ elseif(ind2.eq.0) then ! decay
+ call make22(iline,sqrts,
+ & ityp(ind1),iso3(ind1),fmass(ind1),xtotfac(ind1),
+ & 0,0,0d0,1d0)
+ endif
+
+
+c set here the true nexit (number of particles in the exit channel):
+ nexit=nstring1+nstring2
+
+
+c
+c 2a). annihilation/soft resonance production: store properties
+c
+ if(nstring2.eq.0) then
+c store average time and position of particles (only one part/string coming out...)
+ tstring(1)=(r0(ind1)+r0(ind2))/2.
+ rstringx(1)=(rx(ind1)+rx(ind2))/2.
+ rstringy(1)=(ry(ind1)+ry(ind2))/2.
+ rstringz(1)=(rz(ind1)+rz(ind2))/2.
+c do the same for the MD trajectories
+ rpott(1)=(r0_t(ind1)+r0_t(ind2))/2.
+ rpotx(1)=(rx_t(ind1)+rx_t(ind2))/2.
+ rpoty(1)=(ry_t(ind1)+ry_t(ind2))/2.
+ rpotz(1)=(rz_t(ind1)+rz_t(ind2))/2.
+
+ pnnout=pnn
+
+
+c store the incoming momenta for further use before the slots get erased/replaced
+c by outgoing particles
+ pxi1=px(ind1)
+ pxi2=px(ind2)
+ pyi1=py(ind1)
+ pyi2=py(ind2)
+ pzi1=pz(ind1)
+ pzi2=pz(ind2)
+
+c store old formation times
+ tformold(1)=max(tform(ind1),tform(ind2))
+ tformold(2)=max(tform(ind1),tform(ind2))
+c two leading hadrons form s-channel -> the larger reduction factor
+c of the incoming hadrons is maintained:
+ xtotfacold(1)=max(xtotfac(ind1),xtotfac(ind2))
+ xtotfacold(2)=max(xtotfac(ind1),xtotfac(ind2))
+ else
+
+c 2b) 1. scattering/decay/strings: store both locations for later use
+c store time and position of both incoming particles
+ tstring(1)=r0(ind1)
+ rstringx(1)=rx(ind1)
+ rstringy(1)=ry(ind1)
+ rstringz(1)=rz(ind1)
+c likewise for the MD trajectory arrays
+ rpott(1)=r0_t(ind1)
+ rpotx(1)=rx_t(ind1)
+ rpoty(1)=ry_t(ind1)
+ rpotz(1)=rz_t(ind1)
+
+c store old formation time and reduction factor
+ tformold(1)=tform(ind1)
+ xtotfacold(1)=xtotfac(ind1)
+
+ if(ind2.eq.0) then !decay
+c likewise for particles 2,3,4...
+ tstring(2)=r0(ind1)
+ rstringx(2)=rx(ind1)
+ rstringy(2)=ry(ind1)
+ rstringz(2)=rz(ind1)
+ rpott(2)=r0_t(ind1)
+ rpotx(2)=rx_t(ind1)
+ rpoty(2)=ry_t(ind1)
+ rpotz(2)=rz_t(ind1)
+
+ tformold(2)=tform(ind1)
+ xtotfacold(2)=xtotfac(ind1)
+
+ else
+ tstring(2)=r0(ind2)
+ rstringx(2)=rx(ind2)
+ rstringy(2)=ry(ind2)
+ rstringz(2)=rz(ind2)
+
+ rpott(2)=r0_t(ind2)
+ rpotx(2)=rx_t(ind2)
+ rpoty(2)=ry_t(ind2)
+ rpotz(2)=rz_t(ind2)
+
+ tformold(2)=tform(ind2)
+ xtotfacold(2)=xtotfac(ind2)
+
+ endif
+c
+c 2b) 2. get relative momentum in 2 particle cms (only for ang. distrib.!)
+c
+ if(iline.gt.0) then
+ pnnout=pcms(sqrts,mstring(1),mstring(2))
+ endif
+
+ endif ! nstring2.eq.0
+c
+c 2b) 3. get angular distribution
+c
+
+ if (ind2.ne.0) then
+ call angdisnew(sqrts,fmass(ind1),fmass(ind2),iline,ctheta1,phi1)
+ else
+ call angdisnew(sqrts,fmass(ind1),0.0d0,iline,ctheta1,phi1)
+ end if
+
+
+c for CTOption(2)<>0 phi1=0 and 2-part. scattering is in the scattering plane
+ if(ind2.ne.0.and.CTOption(2).ne.0) then
+ phi1=0.d0
+ endif
+
+c get angles between two particle CMS and computational frame
+ call getang(pxnn,pynn,pznn,th,phi2,rdum)
+
+c option for pure forward streaming
+ if(CTOption(14).ne.0)then
+ ctheta1=1d0
+ th=0d0
+ end if
+c
+c 3. generate slots for new particles
+c
+c count baryons AND anti-baryons in old slots (NOT net-baryons!!)
+ bar=0
+ if(abs(ityp(ind1)).le.maxbar)then
+ bar=bar+1
+ endif
+c
+cccc in case of baryon-boson scattering, inew(1) contains the baryon,
+cccc otherwise it does not matter
+c
+ if(ind2.ne.0) then
+ if(abs(ityp(ind2)).le.maxbar) then
+ bar=bar+1
+ endif
+ if(abs(ityp(ind2)).le.maxbar.and.
+ & abs(ityp(ind1)).ge.minmes) then
+ inew(1)=ind2
+ inew(2)=ind1
+ else
+ inew(1)=ind1
+ inew(2)=ind2
+ endif
+ else
+cccc decay: must create a second slot
+ inew(1)=ind1
+c increment meson counter
+ nmes=nmes+1
+c set new slot number
+ inew(2)=nbar+nmes
+c create the slot
+ call addpart(inew(2))
+c this is needed for delpart (to esure correct counters):
+ ityp(inew(2))=999
+c three or four body decays
+ if(nexit.gt.2) then
+ do 91 i=3,nexit
+ nmes=nmes+1
+ inew(i)=nbar+nmes
+ call addpart(inew(i))
+ ityp(inew(i))=999
+ 91 continue
+ endif
+ endif
+
+cccc soft resonance production (second slot must be deleted)
+ if(nexit.eq.1) then
+c the smaller index automatically belongs to a baryon if there was one
+ inew(1)=min0(ind1,ind2)
+c get index to be deleted
+ inew(2)=max0(ind1,ind2)
+c delete second slot
+ call delpart(inew(2))
+ endif
+
+c generate sorting-order for new particles:
+c 1. leading baryon of particle/string 1
+c 2. leading baryon of particle/string 2
+c 3. all other baryons of particle/string 1
+c 4. all other baryons of particle/string 2
+c 5. all mesons of particle/string 1
+c 6. all mesons of particle/string 2
+c the itypnew-indices are stored into the itmp-array
+c the location-index (do the new particles "belong" to incident particle 1 or 2)
+c is stored in the ipmp-array
+
+ nb1=0 ! number of baryons in string 1
+ nb2=0 ! number of baryons in string 2
+ nm1=0 ! number of mesons in string 1
+ nm2=0 ! number of mesons in string 2
+c now get the number of baryons and mesons and their ityps from string/particle 1
+ call instring(1,nstring1,nb1,nm1,barlist1,meslist1)
+ if(nstring2.ne.0)
+c likewise from string/particle 2
+ & call instring(nstring1+1,nexit,nb2,nm2,barlist2,meslist2)
+
+c now really generate the above described sorting-order
+ if( (bar.eq.0)
+ & .or.(bar.eq.1.and.nb1.gt.0)
+ & .or.(bar.eq.2.and.nb1.gt.0.and.nb2.eq.0)) then
+c loop over baryons in string/particle 1
+ do 381 i=1,nb1
+ itmp(i)=barlist1(i)
+ ipmp(i)=1
+ 381 continue
+c loop over baryons in string/particle 2
+ do 382 i=1,nb2
+ itmp(nb1+i)=barlist2(i)
+ ipmp(nb1+i)=2
+ 382 continue
+ elseif((bar.eq.1.and.nb2.gt.0.and.nb1.eq.0)
+ & .or.(bar.eq.2.and.nb2.gt.0.and.nb1.eq.0)) then
+c loop over baryons in string/particle 2
+ do 391 i=1,nb2
+ itmp(i)=barlist2(i)
+ ipmp(i)=2
+ 391 continue
+ elseif(bar.eq.2.and.nb1.gt.0.and.nb2.gt.0) then
+ itmp(1)=barlist1(1)
+ ipmp(1)=1
+ itmp(2)=barlist2(1)
+ ipmp(2)=2
+c loop over baryons in string/particle 1
+ do 371 i=2,nb1
+ itmp(1+i)=barlist1(i)
+ ipmp(1+i)=1
+ 371 continue
+c loop over baryons in string/particle 2
+ do 372 i=2,nb2
+ itmp(nb1+i)=barlist2(i)
+ ipmp(nb1+i)=2
+ 372 continue
+ endif
+c loop over mesons in string/particle 1
+ do 383 i=1,nm1
+ itmp(nb1+nb2+i)=meslist1(i)
+ ipmp(nb1+nb2+i)=1
+ 383 continue
+c loop over mesons in string/particle 2
+ do 384 i=1,nm2
+ itmp(nb1+nb2+nm1+i)=meslist2(i)
+ ipmp(nb1+nb2+nm1+i)=2
+ 384 continue
+
+
+c in case of annihilation without baryon production
+c or if a baryon-antibaryon pair is created via a meson-meson collision,
+c delete old slots
+c
+c note: this sequence is needed to keep all baryons at the top
+c of the particle table. However, it destroys distinctive
+c projectile/target areas in the particle arrays.
+c
+
+ if((bar.eq.2.and.(nb1+nb2).eq.0)
+ & .or.
+ & (bar.eq.0.and.(nb1+nb2).gt.0)
+ & ) then
+ call delpart(inew(1))
+ call delpart(inew(2))
+ inew(1)=0
+ inew(2)=0
+
+c store average time and position of particles
+ tstring(1)=(r0(ind1)+r0(ind2))/2.
+ rstringx(1)=(rx(ind1)+rx(ind2))/2.
+ rstringy(1)=(ry(ind1)+ry(ind2))/2.
+ rstringz(1)=(rz(ind1)+rz(ind2))/2.
+
+ tstring(2)=tstring(1)
+ rstringx(2)=rstringx(1)
+ rstringy(2)=rstringy(1)
+ rstringz(2)=rstringz(1)
+
+c do likewise for MD trajectories
+ rpott(1)=(r0_t(ind1)+r0_t(ind2))/2.
+ rpotx(1)=(rx_t(ind1)+rx_t(ind2))/2.
+ rpoty(1)=(ry_t(ind1)+ry_t(ind2))/2.
+ rpotz(1)=(rz_t(ind1)+rz_t(ind2))/2.
+ rpott(2)=rpott(1)
+ rpotx(2)=rpotx(1)
+ rpoty(2)=rpoty(1)
+ rpotz(2)=rpotz(1)
+
+c in case of a meson-string with baryon-antibaryon creation
+c the meson-slot must be deleted
+ elseif(bar.eq.1.and.(nb1+nb2).gt.1) then
+ call delpart(inew(2))
+ inew(2)=0
+ endif
+
+c now create new slots:
+ do 307 i=1,nexit
+ if(inew(i).lt.1) then
+c the new particle ID is stored in itypnew
+ if(iabs(itypnew(itmp(i))).le.maxbar) then
+c the particle is a baryon
+ do 385 k=1,i
+c make sure that mesons in the inew array are shifted upwards
+ if(inew(k).gt.nbar)inew(k)=inew(k)+1
+ 385 continue
+c increment baryon counter
+ nbar=nbar+1
+c this is the new particle slot
+ inew(i)=nbar
+ elseif(iabs(itypnew(itmp(i))).ge.minmes) then
+c the particle is a meson
+ nmes=nmes+1
+ inew(i)=nbar+nmes
+ endif
+c create the slot
+ call addpart(inew(i))
+ endif
+ 307 continue
+
+ return
+ end
+
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ subroutine prescale(lambda)
+c
+c Revision : 1.0
+c
+cinput lambda : scaling factor for momenta of outgoing particles
+c
+c {\tt scatprep, prescale} and {\tt scatfinal} handle the collision/decay
+c kinematics and the book-keeping of the global particle vectors.
+c In {\tt prescale} the actual kinematics for the exit-channel, including
+c a call to {\tt angdis} for the angular distribution and the transformation
+c from the two particle restframe to the computational frame is being
+c performed. Momenta and locations of exit channel particles are written
+c to the global particle vectors. \\
+c The scaling factor {\tt lambda} is needed to ensure global energy conservation
+c in the case of momentum dependent interactions (MDI). In that case {\tt prescale}
+c can be called several succesive times with different values of {\tt lambda}
+c to minimize $E_{tot,in} - E_{tot,out}$.
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ implicit none
+ include 'coms.f'
+ include 'options.f'
+ include 'newpart.f'
+
+ integer i,j,itmp(mprt),ipmp(mprt),ind1,ind2,nb1,nb2
+ real*8 lambda,th,phi2,ctheta1,phi1,theta3,phi3,pabs
+ real*8 pzi1,pzi2,pxi1,pxi2,pyi1,pyi2
+ real*8 rstringx(2),rstringy(2),rstringz(2),tstring(2)
+ real*8 rpott(2),rpotx(2),rpoty(2),rpotz(2)
+ real*8 tauf(mprt),tformold(2)
+ integer getspin,strid1,strid2,bar,nm1,nm2
+
+ common /scatcomr/rstringx,rstringy,rstringz,tstring,
+ & rpott,rpotx,rpoty,rpotz,
+ & pzi1,pzi2,pxi1,pxi2,pyi1,pyi2,
+ & ctheta1,phi1,th,phi2,tformold
+ common /scatcomi/itmp,ipmp,ind1,ind2,nb1,nb2,strid1,strid2,
+ & bar,nm1,nm2
+
+
+ if(nexit.eq.1) then ! soft resonance production
+
+c new momenta are stored in pnew
+ pnew(1,1)=lambda*(pxi1+pxi2)
+ pnew(2,1)=lambda*(pyi1+pyi2)
+ pnew(3,1)=lambda*(pzi1+pzi2)
+c this is the energy
+ pnew(4,1)=dsqrt(pnew(5,1)**2+
+ & pnew(1,1)**2+pnew(2,1)**2+pnew(3,1)**2)
+c formation time
+ tauf(1)=0.d0
+ else ! scattering/decay
+ do 205 j=1,nexit
+c compute formation time (as a eigentime)
+ tauf(j)=xnew(4,j)*pnew(5,j)/pnew(4,j)
+
+c rescale momenta of particles
+ call getang(pnew(1,j),pnew(2,j),pnew(3,j),theta3,phi3,pabs)
+ pabs=lambda*pabs
+ call putang(pnew(1,j),pnew(2,j),pnew(3,j),theta3,phi3,pabs)
+
+
+c check for forward time-delay
+c in case of delay the momenta are already in the comp. frame
+ if(.not.(CTOption(34).eq.2.and.iline.eq.20.and.
+ & ityptd(1,pslot(1)).ne.0)) then
+
+c rotate in the from z-axis to th&phi given by angdis
+ call rotbos(dacos(ctheta1),phi1,0d0,0d0,0d0,
+ & pnew(1,j),pnew(2,j),pnew(3,j),pnew(4,j))
+
+c rotate from the NN to the comp. sys. and
+c transform particles to computational system
+
+c decays should not be rotated
+ if (iline.eq.20) then
+ th = 0.d0
+ phi2 = 0.d0
+ end if
+
+ call rotbos(th,phi2,betax,betay,betaz,
+ & pnew(1,j),pnew(2,j),pnew(3,j),pnew(4,j))
+
+ endif
+c end of delay-if
+
+
+ 205 continue
+ endif
+
+c write coordinates for energy-check and pauli-blocking
+c correct particle/string-locations from relative to absolute
+
+ do 215 i=1,nexit
+c write locations to global arrays
+c the ipmp values determine wether the new particle belongs to incoming slot 1 or 2
+ r0(inew(i))=tstring(ipmp(i))
+ rx(inew(i))=rstringx(ipmp(i))
+ ry(inew(i))=rstringy(ipmp(i))
+ rz(inew(i))=rstringz(ipmp(i))
+cpot
+c likewise for MD trajectories
+ r0_t(inew(i))=rpott(ipmp(i))
+ rx_t(inew(i))=rpotx(ipmp(i))
+ ry_t(inew(i))=rpoty(ipmp(i))
+ rz_t(inew(i))=rpotz(ipmp(i))
+
+c write momenta to global arrays
+ p0(inew(i))=pnew(4,itmp(i))
+ px(inew(i))=pnew(1,itmp(i))
+ py(inew(i))=pnew(2,itmp(i))
+ pz(inew(i))=pnew(3,itmp(i))
+
+
+c store formation time and leading hadron
+ if(pnew(5,itmp(i)).gt.0d0)then
+ tform(inew(i))=tstring(1)+tauf(itmp(i))*
+ & pnew(4,itmp(i))/pnew(5,itmp(i))
+ else
+ tform(inew(i))=tstring(ipmp(i))
+ endif
+
+c cross section reduction factor and string ID
+ xtotfac(inew(i))=leadfac(itmp(i))
+ strid(inew(i))=sidnew(itmp(i))
+
+c additional reduction of the leading hadrons' cross section
+c in case the incoming hadron x-sec was already reduced
+c otherwise an elastic scattering would erase formation time...
+ if(xtotfacold(ipmp(i)).lt.1d0) then
+ xtotfac(inew(i))=xtotfacold(ipmp(i))*xtotfac(inew(i))
+ endif
+ if(tform(inew(i)).lt.tformold(ipmp(i))
+ & .and.xtotfac(inew(i)).gt.0) then
+ tform(inew(i))=tformold(ipmp(i))
+ endif
+
+
+c store the respective string-ids in strid1 and strid2
+ if(ipmp(i).eq.1.and.strid(inew(i)).ne.0) then
+ strid1=strid(inew(i))
+ elseif(ipmp(i).eq.2.and.strid(inew(i)).ne.0) then
+ strid2=strid(inew(i))
+ endif
+
+c write mass, ID, I3 and spin to global arrays
+ fmass(inew(i))=pnew(5,itmp(i))
+ ityp(inew(i))=itypnew(itmp(i))
+ iso3(inew(i))=i3new(itmp(i))
+ spin(inew(i))=getspin(itypnew(itmp(i)),-1)
+
+ 215 continue
+
+c set lstcoll:
+c lstcoll relates the outgoing particles of this scattering/decay interaction
+c to each other - it is used to prevent them from directly interacting again
+c with each other because this would be unphysical.
+ if(ind2.eq.0) then
+ lstcoll(inew(1))=ind1
+ else
+ lstcoll(inew(1))=inew(2)
+ endif
+ if(nexit.gt.1) lstcoll(inew(2))=inew(1)
+
+ do 216 i=1,nexit
+c in case of strings assign string-id's to lstcoll of leading hadrons
+c instead of collision-partner index
+c on string id's can be can be distinguished from normal indices
+c by an offset of NMAX+1
+c
+c case 1: part.1 is excited to string
+ if(nstring1.gt.1.and.nstring2.eq.1) then
+ if(ipmp(i).eq.2) then
+ lstcoll(inew(i))=nmax+strid1+1
+ elseif(ipmp(i).eq.1) then
+ if(bar.eq.2.and.nb1.gt.0.and.nb2.gt.0) then
+ lstcoll(inew(i))=inew(2)
+ else
+ lstcoll(inew(i))=inew(nb1+nb2+nm1+1)
+ endif
+ endif
+c case 2: part.2 is excited to string
+ elseif(nstring1.eq.1.and.nstring2.gt.1) then
+ if(ipmp(i).eq.1) then
+ lstcoll(inew(i))=nmax+strid2+1
+ elseif(ipmp(i).eq.2) then
+ lstcoll(inew(i))=inew(1)
+ endif
+c case 3: two strings
+ elseif(nstring1.gt.1.and.nstring2.gt.1) then
+ if(ipmp(i).eq.1) then
+ lstcoll(inew(i))=nmax+strid2+1
+ elseif(ipmp(i).eq.2) then
+ lstcoll(inew(i))=nmax+strid1+1
+ endif
+c case 4: one (mesonic) string
+ elseif(nstring1.gt.1.and.nstring2.eq.0) then
+ lstcoll(inew(i))=nmax+strid1+1
+ endif
+
+ 216 continue
+
+ return
+ end
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ subroutine scatFinal(colldens)
+c
+c Revision : 1.0
+c
+coutput colldens : baryon density at point of interaction
+c
+c {\tt scatprep, prescale} and {\tt scatfinal} handle the collision/decay
+c kinematics and the book-keeping of the global particle vectors.
+c In {\tt scatfinal} the interaction is checked for Pauli-blocking and all
+c particle {\em quantum numbers} which so far have not been set are written
+c to the global arrays. Some collision counters are incremented here, too.
+c
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+ implicit none
+ include 'coms.f'
+ include 'comres.f'
+ include 'newpart.f'
+ include 'freezeout.f'
+ include 'options.f'
+
+ integer i,ind1,ind2,itmp(mprt),ipmp(mprt),nb1,nb2,j
+ integer ikill1,ikill2,strid1,strid2,bar,nm1,nm2
+ integer iloffset
+ real*8 colldens
+ logical dnscall,dnsdum
+
+c functions:
+ integer fchg
+ real*8 dectim
+ logical paulibl
+
+ common /scatcomi/itmp,ipmp,ind1,ind2,nb1,nb2,strid1,strid2,
+ & bar,nm1,nm2
+ common /scatcoml/dnscall
+
+c check pauli-blocking (only for nucleons and delta(1232)
+c loop over all baryons in exit-channel
+ do 306 i=1,nb1+nb2
+ if(itypnew(itmp(i)).eq.nucleon) then
+ dnscall=.false.
+ ikill1=0
+ ikill2=0
+c call to Pauli-Blocker
+ if(paulibl(inew(i),colldens)) then
+c pauli-blocked collision, restore information and return
+
+c first delete unnecessary slots
+ if(nexit.gt.2) then
+ do 317 j=3,nexit
+ call delpart(inew(j))
+ 317 continue
+ endif
+
+c in case of blocked decay, delete second entry
+ if(ind2.eq.0) then
+ call delpart(inew(2))
+c only delete/create slots if something more than a mere
+c swapping has happened
+ elseif(.not.(((inew(1).eq.ind1).or.(inew(1).eq.ind2))
+ & .and.((inew(2).eq.ind1).or.(inew(2).eq.ind2))))
+ & then
+ ikill1=max0(inew(1),inew(2))
+ ikill2=min0(inew(1),inew(2))
+ call delpart(ikill1)
+ if(ikill2.gt.0) call delpart(ikill2)
+ call addpart(ind1)
+ if(ind2.gt.0) call addpart(ind2)
+ endif
+c restore old contents of slots ind1 and ind2
+ call saveinfo(ind1,-1)
+ call saveinfo(ind2,-2)
+c in case of blocked decay, sample new decay time
+ if(ind2.eq.0) then
+ dectime(ind1)=dectim(ind1,iline)+acttime
+ endif
+c restore frozen fermi state if necessary
+ if (CTOption(30).eq.1) then
+ call savefermi(ind1,ind1,peq1)
+ call savefermi(ind2,ind2,peq2)
+ endif
+c set lstcoll
+ if(ind2.ne.0) then
+ lstcoll(ind1)=ind2
+ lstcoll(ind2)=ind1
+ else
+ lstcoll(ind1)=ind1
+ endif
+
+c set baryon and meson counters
+ if(ikill1.ne.0) then
+ if(abs(ityp(ind1)).lt.minmes) then
+ nbar=nbar+1
+ else
+ nmes=nmes+1
+ endif
+ endif
+ if(ind2.gt.0.and.ikill2.ne.0) then
+ if(abs(ityp(ind2)).lt.minmes) then
+ nbar=nbar+1
+ else
+ nmes=nmes+1
+ endif
+ endif
+
+c increment blocking counter
+ NBlColl=NBlColl+1
+c set number of particles in exit-channel to zero
+ nexit=0
+ return
+ endif
+ endif
+ 306 continue
+
+c the collision was not blocked, proceed...
+
+c 4. rewrite arrays, clear entries etc.
+c fill the rest of the slot
+
+c in case the Pauli-Blocker was not called, do it now in order to
+c get the baryon density at the interaction point, colldens
+ if(dnscall) dnsdum=paulibl(inew(1),colldens)
+
+c write rest of the quantum numbers to global vectors
+ do 312 i=1,nexit
+c number of collisions
+ ncoll(inew(i))=ncoll(inew(i))+1
+c charge
+ charge(inew(i))=fchg(iso3(inew(i)),ityp(inew(i)))
+c time of decay
+ dectime(inew(i))=dectim(inew(i),iline)+tform(inew(i))
+c last process the particle was involved in
+ if ( (iline.ne.13).and.(iline.ne.17).and.(iline.ne.19).and.
+ $ (iline.ne.22).and.(iline.ne.26).and.(iline.ne.38)) then
+ if (ind2.gt.0) then
+ iloffset=0
+ if ( (iline.eq.27).or.(iline.eq.28) ) then
+ if ( (CTOption(41).gt.1) ) then
+ if ( (abs(itypt(1)).gt.100).and.
+ $ (abs(itypt(2)).gt.100) ) then
+ iloffset=20
+ endif
+ if ( (itypt(1).eq.ityp(inew(i))).and.
+ $ (iso3t(1).eq.iso3(inew(i))) ) then
+ origin(inew(i))=origint(1)+100
+ uid(inew(i))=uidt(1)
+ elseif ( (itypt(2).eq.ityp(inew(i))).and.
+ $ (iso3t(2).eq.iso3(inew(i))) ) then
+ origin(inew(i))=origint(2)+100
+ uid(inew(i))=uidt(2)
+ else
+ origin(inew(i))=iline+iloffset
+ $ +1000*(iabs(itypt(1))+1000*iabs(itypt(2)))
+ endif
+ else
+ origin(inew(i))=iline+iloffset
+ $ +1000*(iabs(itypt(1))+1000*iabs(itypt(2)))
+ endif
+ else
+ origin(inew(i))=iline
+ $ +1000*(iabs(itypt(1))+1000*iabs(itypt(2)))
+ endif
+ else
+ origin(inew(i))=iline
+ $ +1000*(iabs(itypt(1)))
+ endif
+c unique ID tag
+ uid_cnt=uid_cnt+1
+ uid(inew(i))=uid_cnt
+ else
+ origin(inew(i))=origint(i)+100
+ uid(inew(i))=uidt(i)
+ if (ityp(inew(1)).ne.itypt(1)) then
+ if (nexit.ne.2) then
+ write(6,*) "fatal error in scatter: nexit.ne.2!"
+ stop
+ endif
+ origin(inew(i))=origint(3-i)+100
+ uid(inew(i))=uidt(3-i)
+ endif
+ endif
+c freeze-out coordinates
+ frr0(inew(i))=r0(inew(i))
+ frrx(inew(i))=rx(inew(i))
+ frry(inew(i))=ry(inew(i))
+ frrz(inew(i))=rz(inew(i))
+ frp0(inew(i))=p0(inew(i))
+ frpx(inew(i))=px(inew(i))
+ frpy(inew(i))=py(inew(i))
+ frpz(inew(i))=pz(inew(i))
+
+c forward time-delay
+ if(CTOption(34).eq.2.and.(iline.eq.36.or.iline.eq.37)) then
+ do 307 j=1,2
+ p0td(j,inew(i))=pold(4,j)
+ pxtd(j,inew(i))=pold(1,j)
+ pytd(j,inew(i))=pold(2,j)
+ pztd(j,inew(i))=pold(3,j)
+ fmasstd(j,inew(i))=pold(5,j)
+ ityptd(j,inew(i))=itypold(j)
+ iso3td(j,inew(i))=iso3old(j)
+ 307 continue
+ else
+ do 308 j=1,2
+ p0td(j,inew(i))=0.d0
+ pxtd(j,inew(i))=0.d0
+ pytd(j,inew(i))=0.d0
+ pztd(j,inew(i))=0.d0
+ fmasstd(j,inew(i))=0.d0
+ ityptd(j,inew(i))=0
+ iso3td(j,inew(i))=0
+ 308 continue
+ endif
+
+c in a N particle exit channel the produced resonance
+c either comes from BB->B* ? ? or a String -> B* ? ?
+ if(ityp(inew(i)).ge.minres.and.ityp(inew(i)).le.maxres) then
+ if(iline.ne.20.or.iline.ne.10) then
+c B B -> ? ?
+ NHardRes=NHardRes+1
+ elseif(iline.eq.20) then
+ NDecRes=NDecRes+1
+ elseif(iline.eq.10) then
+ NSoftRes=NSoftRes+1
+ endif
+ endif
+ 312 continue
+c other counters for B-strings/M-strings could be added here...
+ if(iline.eq.13.or.iline.eq.17
+ & .or.iline.eq.19.or.iline.eq.26) then
+ NElColl=NElColl+1
+ endif
+
+ return
+ end
+
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+ integer function collclass(ityp1,iso31,ityp2,iso32)
+c
+c Revision : 1.0
+c
+c This function links the ingoing collision channel to the
+c line number of the sigmaLN array in {\tt blockres.f} in which the
+c types of cross section parametrizations to perform are defined.
+c
+cinput ityp1 : ityp of particle 1
+cinput iso31 : $I_3$ of particle 1
+cinput ityp2 : ityp of particle 2
+cinput iso32 : $I_3$ of particle 2
+c
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ implicit none
+ include 'comres.f'
+ include 'options.f'
+ integer ityp1,ityp2,iso31,iso32,i1,i2,iz1,iz2
+ real*8 d1,d2
+
+c copy to new variables MUST be done because of swpizm
+c (otherwise scatter will crash due to swapped particle properties)
+ i1=iabs(ityp1)
+ i2=iabs(ityp2)
+ iz1=iso31
+ iz2=iso32
+ d1=0.d0
+ d2=0.d0
+
+ if(i1.lt.i2)call swpizm(i1,iz1,d1,i2,iz2,d2)
+
+c baryon-antibaryon
+ if(i1.le.maxbar.and.i2.le.maxbar.and.ityp1*ityp2.lt.0) then
+ collclass=11
+ if(CTOption(19).ne.0)collclass=0
+ return
+ end if
+
+c nucleon nucleon
+ if(i1.eq.nucleon.and.i2.eq.nucleon) then
+ if(iz1.eq.iz2) then
+c proton proton or neutron-neutron
+ collclass=2
+ return
+ else
+c proton neutron
+ collclass=1
+ return
+ endif
+ elseif(i1.eq.mindel.and.i2.eq.nucleon) then
+c Delta(1232) nucleon
+ collclass=3
+ return
+ elseif(i1.gt.minnuc.and.i1.le.maxnuc.and.
+ & i2.eq.nucleon) then
+c N+ nucleon
+ collclass=4
+ return
+ elseif(i1.ge.mindel.and.
+ & i1.le.maxdel.and.
+ & i2.eq.nucleon) then
+c D* nucleon
+ collclass=5
+ return
+ elseif(i1.eq.mindel.and.i2.eq.mindel) then
+c Delta(1232)-Delta(1232)
+ collclass=6
+ return
+ elseif(i1.eq.mindel.and.
+ & i2.gt.minnuc.and.
+ & i2.le.maxnuc) then
+c Delta(1232)-N*
+ collclass=7
+ return
+ elseif(i2.eq.mindel.and.
+ & i1.gt.mindel.and.
+ & i1.le.maxdel) then
+c Delta(1232)-D*
+ collclass=8
+ return
+ elseif(i1.ge.minmes.and.i2.le.maxbar) then
+c Boson-Baryon
+ collclass=9
+ return
+ elseif(i1.ge.minmes.and.i2.ge.minmes) then
+c Boson-Boson
+ collclass=10
+ return
+ elseif(i1.gt.minnuc.and.
+ & i1.le.maxdel.and.
+ & i2.gt.minnuc.and.
+ & i2.le.maxdel) then
+c D*-D* or D*-N* or N*-N*
+ collclass=12
+ return
+ elseif(i1.le.maxbar.and.i2.le.maxbar) then
+c all remaining BB-collisions
+ collclass=13
+ return
+ else
+c class not defined (sets sigtot to zero)
+ write(*,*)'scatter: collclass of ',i1,i2,' not yet defined!'
+ collclass=0
+ endif
+ return
+ end
+
+
+C####C##1#########2#########3#########4#########5#########6#########7##
+ subroutine getang(x,y,z,th,ph,r)
+c
+c gives spherical coordinates of cartesian 3-vector $(x,y,z)$
+c
+c input : 3-vector x,y,z
+c output: angles {\tt th}($\vartheta$), {\tt ph}($\varphi$) and radius {\tt r}
+c
+C####C##1#########2#########3#########4#########5#########6#########7##
+ implicit none
+ real*8 x,y,z,th,ph,cut,r
+ parameter (cut=1d-9)
+ if(abs(x).lt.cut.and.abs(y).lt.cut) then
+ ph=0d0
+ else
+ ph=datan2(y,x)
+ endif
+ r=sqrt(x*x+y*y+z*z)
+ th=dacos(z/max(r,cut))
+ return
+ end
+
+C####C##1#########2#########3#########4#########5#########6#########7##
+ subroutine putang(x,y,z,th,ph,r)
+c
+c creates 3-vector $(x,y,z)$ out of spherical coordinates
+c input: angles {\tt th}($\vartheta$), {\tt ph}($\varphi$) and radius {\tt r}
+c output: 3-vector x,y,z
+C####C##1#########2#########3#########4#########5#########6#########7##
+ implicit none
+ real*8 x,y,z,th,ph,r
+ x=r*sin(th)*cos(ph)
+ y=r*sin(th)*sin(ph)
+ z=r*cos(th)
+ return
+ end
+
+C####C##1#########2#########3#########4#########5#########6#########7##
+ SUBROUTINE rotbos(THE,PHI,BEX,BEY,BEZ,p1,p2,p3,p4)
+c
+c INPUT: the,phi,bex,bey,bez,p
+c OUTPUT: p
+c 1)rotate 4-vector p according to the and phi 2/ boost 4-vector p
+C####C##1#########2#########3#########4#########5#########6#########7##
+ implicit none
+ real*8 P(4),BEX,BEY,BEZ,GA,BEP,GABEP,rot(3,3),the,phi
+ real*8 p1,p2,p3,p4,bb2
+ integer j
+
+
+ IF(THE**2+PHI**2.GT.1E-20) THEN
+C...ROTATE
+ 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)=0.
+ ROT(3,3)=COS(THE)
+ DO 108 J=1,3
+ 108 P(J)=ROT(J,1)*P1+ROT(J,2)*P2+ROT(J,3)*P3
+ p(4)=p4
+ else
+ p(1)=p1
+ p(2)=p2
+ p(3)=p3
+ p(4)=p4
+ ENDIF
+
+ bb2=BEX**2+BEY**2+BEZ**2
+ IF(bb2.GT.1E-20) THEN
+C...LORENTZ BOOST (TYPICALLY FROM REST TO MOMENTUM/ENERGY=BETA)
+ GA=1D0/DSQRT(1D0-bb2)
+ BEP=BEX*P(1)+BEY*P(2)+BEZ*P(3)
+ GABEP=GA*(GA*BEP/(1D0+GA)+P(4))
+ P(1)=P(1)+GABEP*BEX
+ P(2)=P(2)+GABEP*BEY
+ P(3)=P(3)+GABEP*BEZ
+ P(4)=GA*(P(4)+BEP)
+ ENDIF
+
+ p1=p(1)
+ p2=p(2)
+ p3=p(3)
+ p4=p(4)
+
+ RETURN
+ END
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ subroutine instring(low,high,nb,nm,barlist,meslist)
+c
+c version: 1.0
+c
+c this subroutine returns arrays with the indices of the baryons/mesons
+c found in the itypnew-array of {\tt newpart.f}
+c
+cinput low: lower search boundary
+cinput high: upper search boundary
+c
+coutput nb : number of baryons in range
+coutput nm : number of mesons in range
+coutput barlist: list of indices for baryons
+coutput meslist: list of indices for mesons
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+ implicit none
+
+ include 'newpart.f'
+ include 'comres.f'
+
+ integer i,low,high,nb,nm,barlist(mprt),meslist(mprt)
+
+ nb=0
+ nm=0
+
+ do 10 i=low,high
+ if(abs(itypnew(i)).le.maxbar) then
+ nb=nb+1
+ barlist(nb)=i
+ else
+ nm=nm+1
+ meslist(nm)=i
+ endif
+ 10 continue
+ return
+ end
+
+C####C##1#########2#########3#########4#########5#########6#########7##
+ subroutine leadhad(n1l,n2l,nbl)
+c
+cinput n1l : First index of this string in the newpart-arrays
+cinput n2l : Last index of this string in the newpart-arrays
+cinput nbl : Baryon number of string system, nbl=3 is e+e-
+c
+c output : via common-block {\tt newpart.f}
+c
+c This subroutine determines the position of the leading hadrons
+c of a string fragmentation in the newpart-arrays and assigns the
+c reduction factor for the total cross sections (for all non-leading
+c hadrons this factor is zero, i.e. they have no cross-section during
+c their formation time)
+c
+C####C##1#########2#########3#########4#########5#########6#########7##
+
+ implicit none
+ include 'newpart.f'
+ include 'comres.f'
+ include 'coms.f'
+ integer n1l,n2l,nbl,ll
+
+c default: no leading hadron at all
+ do 1 ll=n1l,n2l
+ leadfac(ll)=0.d0
+ 1 continue
+
+c no leading quarks in e+e-
+ if(nbl.eq.3) return
+
+c full x-section, if there is only one particle
+ if(n1l.eq.n2l)then
+ leadfac(n1l)=1.d0
+ sidnew(n1l)=0
+ return
+ endif
+
+c the last hadron contains always one leading quark
+ if(iabs(itypnew(n2l)).le.maxbar)then
+ leadfac(n2l)=0.33d0
+ else
+ leadfac(n2l)=0.5d0
+ endif
+c baryonic string: look for the first (=leading) baryon
+ if(nbl.gt.0)then
+ do 10 ll=n1l,n2l
+ if(iabs(itypnew(ll)).le.maxbar)then
+ leadfac(ll)=0.66d0
+ goto 20
+ endif
+ 10 continue
+ 20 continue
+ else
+c mesonic string: the first hadron contains one leading quark
+ if(iabs(itypnew(n1l)).le.maxbar)then
+ leadfac(n1l)=0.33d0
+ else
+ leadfac(n1l)=0.5d0
+ endif
+ endif
+ do 33 ll=n1l,n2l
+ if (leadfac(ll).gt.0d0) then
+ sidnew(ll)=strcount
+ else
+ sidnew(ll)=0
+ endif
+ 33 continue
+ strcount=strcount + 1
+
+ return
+ end
diff --git a/Processes/UrQMD/siglookup.f b/Processes/UrQMD/siglookup.f
new file mode 100644
index 0000000000000000000000000000000000000000..cd45e5a3f8da28d406f4415751e88b26f855e0be
--- /dev/null
+++ b/Processes/UrQMD/siglookup.f
@@ -0,0 +1,74 @@
+c $Id: siglookup.f,v 1.4 1999/01/18 09:57:15 ernst Exp $
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+ real*8 function SIGLOOKUP(iline,sqrts)
+c
+c Revision : 1.0
+c
+cinput iline : line\# for information in {\tt sigmainf} array
+cinput sqrts : $\sqrt{s}$ of collision
+c
+c output : returns tabulated cross section value
+c
+c This function returns the cross section stored in line ISIGLINE of
+c the SIGMAS array at the respective value of sqrt(s) (SQRTS)
+c Optional scaling according to SIGMASCAL is performed.
+C
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+ implicit none
+
+ real*8 sqrts,xpt,x1,y1in,y2in,slin,tlow,tblstp,thigh
+ integer isigline,index,iline
+c
+c later, sigtab.f should only be included into main.f and all relevant tables
+c should be accessed via common blocks
+ include 'comres.f'
+c
+c line for sigmas(line,*) array
+ isigline=sigmainf(iline,1)
+c
+c log of lowest sqrt(s) entry in the table
+ tlow=log(sigmascal(iline,2))
+
+c
+c exp(tblstp) is Delta(sqrts) for table
+ tblstp=sigmascal(iline,3)
+c
+c maximum log of sqrt(s) enty in the table
+ thigh=itblsz*tblstp+tlow
+c
+c table-lookup sequence (modified IQMD/RQMD)
+c first generate x-coordinate from sqrt(s) for the table
+ XPT=LOG(sqrts)
+c check if sqrt(s) is below lower boundary
+ IF(XPT.LT.TLOW) THEN
+ siglookup=0.d0
+ return
+ END IF
+c now get index (which is the column in sigtab)
+ INDEX=INT((XPT-TLOW)/TBLSTP) + 1
+c check if sqrt(s) is above upper boundary
+ IF(INDEX.GE.ITBLSZ) THEN
+c also this solution is not clean...
+ INDEX=ITBLSZ-1
+ xpt=thigh
+ END IF
+C FIND SLOPES AND CROSSECTIONS
+c now make a straighforward interpolation
+c in the sigtab array
+c bracket for sqrt(s) value (between X1 and XPT)
+ X1=(INDEX-1)*TBLSTP + TLOW
+c sigmas(isigline,INDEX) is the c.s. array, the wanted c.s. is stored
+c in line isigline
+ Y1IN=sigmas(isigline,INDEX)
+ Y2IN=sigmas(isigline,INDEX+1)
+c get the slope
+ SLIN=(Y2IN-Y1IN)/TBLSTP
+c get the cross section and store it in SIGLOOKUP
+ SIGLOOKUP=SLIN*(XPT-X1) + Y1IN
+c scale the cross section
+ siglookup=sigmascal(iline,1)*siglookup
+ return
+ end
diff --git a/Processes/UrQMD/string.f b/Processes/UrQMD/string.f
new file mode 100644
index 0000000000000000000000000000000000000000..62edad89561432977c45d5457902fd24cfd3becc
--- /dev/null
+++ b/Processes/UrQMD/string.f
@@ -0,0 +1,2078 @@
+c $Id: string.f,v 1.18 2003/05/02 11:06:56 weber Exp $
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ subroutine stringdec(ityp,iz2,smass,part,ident2,npart)
+c
+cinput smass : Stringmass
+cinput ityp : Particle ID
+cinput iz2 : Isospin$_3\cdot 2$
+c
+coutput part : 4-momenta, 4-position, masses (array)
+coutput ident2 : ityp, iz2 (array)
+coutput npart : number of outgoing particles
+c
+c This subroutine performs string fragmentation.
+c
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+ implicit real*8 (a-h,o-z)
+ implicit integer (i-n)
+
+ PARAMETER(MXPTCL=200)
+ COMMON/PARTCL/ PPTCL(9,MXPTCL),nptcl,IDENT(MXPTCL),IDCAY(MXPTCL)
+
+ include 'comstr.f'
+
+ dimension part(9,mxptcl)
+ dimension ident2(2,mxptcl)
+
+
+c we call the translation routine
+ call ityp2id(ityp,iz2,ifa,ifb)
+
+ goto 1
+cspl... string fragmentation called with quark id's and energy as arguments
+ entry qstring(ifanew,ifbnew,smass,part,ident2,npart)
+ ifa=ifanew
+ ifb=ifbnew
+ 1 continue
+
+
+ smem=smass
+c here we call the fragmentation routine. the produced hadrons and their
+c properties are returned via the pptcl- and ident-array in the common-block
+ call string(ifa,ifb,smass)
+c here the array pptcl has been filled with nptcl entries (1->nptcl)
+c now we translate to uqmd and shift the pptcl- and ident-info to the
+c corresponding part- and ident2-arrays of the newpart-common-block:
+ npart=nptcl
+ do 2 i=1,nptcl
+ call id2ityp(ident(i),pptcl(5,i),itypout,iz2out)
+ ident2(1,i)=itypout
+ ident2(2,i)=iz2out
+ smem=smem-pptcl(4,i)
+ do 3 j=1,9
+ part(j,i)=pptcl(j,i)
+ 3 continue
+ 2 continue
+c check for energy conservation:
+ctp060926 if(abs(smem).gt.1.0D-5)then
+ctp060926 write(*,*)'! stringdec: energy difference=',smem
+ctp060926 write(*,*)'ifa,ifb,smass=',ifa,ifb,smass
+ctp060926 endif
+ return
+
+ end
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ subroutine strini
+c
+c output : via common blocks
+c
+c {\tt strini} calculates mixing angles for the meson-multipletts
+c
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+ implicit real*8 (a-h,o-z)
+ implicit integer (i-n)
+
+ include 'options.f'
+ include 'comres.f'
+ include 'comstr.f'
+ real*8 m3
+ real*8 massit
+ integer jit
+c mixing angles of meson multiplets according to flavor SU(3) quark model:
+cspl-0795 these parameters assign the pure u/ubar,d/dbar,s/sbar states
+c (e.g. 110,220,330) to the physical particles according to the su(3)
+c quark model. The flavor mixing angles are chosen according to quadratic
+c Gell-Mann-Okubo mass formula (Review of Particle Properties,
+c Phys. Rev D50 (1994) 1319). For the scalar mesons this formula is not
+c applicable. We assume an ideal mixing angle (tan(theta)=1/sqrt(2)).
+c
+c pseudoscalar: theta=-10 deg
+c vector : theta= 39 deg
+c pseudovector: theta= 51 deg
+c tensor : theta= 28 deg
+c
+ real*8 mixang(njspin)
+c ideal mixing angles assumed for the last three multiplets
+ data mixang/-10d0,39d0,35.3d0,51d0,28d0,35.3d0,35.3d0,35.3d0/
+c
+
+ pi = 4d0*datan2(1d0,1d0)
+
+c calculate 'singlet shift probabilities', e.g. a 11 (u-ubar) state
+c can be changed to a 22 (d-dbar) or 33 (s-sbar) state with a certain
+c probability. THEN they can be identified with physical hadrons!
+ do 3 i=1,njspin
+ mixang(i)=mixang(i)/36d1*2d0*3.1416d0
+ PMIX1S(1,i)=(dcos(mixang(i))/sqrt(6d0)
+ & -dsin(mixang(i))/sqrt(3d0))**2
+ PMIX1S(2,i)=PMIX1S(1,i)
+ PMIX1S(3,i)=(-(dcos(mixang(i))*2d0/dsqrt(6d0))
+ & -dsin(mixang(i))/dsqrt(3d0))**2
+ PMIX2S(1,i)=0.5d0
+ PMIX2S(2,i)=0.5d0
+ PMIX2S(3,i)=1d0
+
+ce calculate probabilities of the meson multipletts
+ce according to parm=(spin degeneracy)/(average mass) *ctp(50 ff.)
+ parm(i)=0d0
+ m3=0d0
+ do 102 j=0,3
+ itp=mlt2it(4*(i-1)+j+1)
+ m3=m3+massit(itp)
+ jpc=jit(itp)/2
+102 continue
+ parm(i)=parm(i)+(2*jpc+1)/m3*4*CTParam(49+i)
+
+c the mixing-angles are the same for 'string' and 'cluster':
+ do 2 k=1,3
+ PMIX1C(k,i)=PMIX1S(k,i)
+ PMIX2C(k,i)=PMIX2S(k,i)
+c write(6,*)'#',pmix1c(k,i)
+ 2 continue
+ 3 continue
+
+ return
+ end
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ SUBROUTINE GAUSPT(PT0,SIGQT)
+c
+cinput sigqt : Width of Gaussian
+c
+coutput pt0 : transverse momentum
+c
+C generate pt with Gaussian
+c distribution $\propto pt \exp(-pt^2/sigqt^2)$
+c
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+ implicit none
+ real*8 pt0,sigqt,rnd,ranf
+
+ RND=ranf(0)
+ PT0=SIGQT*SQRT(-DLOG(1.d0-RND))
+ RETURN
+ END
+
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ SUBROUTINE FLAVOR(ID,IFL1,IFL2,IFL3,JSPIN)
+c
+cinput ID : quarkcode
+c
+coutput ifl1 : single quarks id
+coutput ifl2 : single quarks id
+coutput ifl3 : single quarks id
+coutput jspin : spin id
+c
+C THIS SUBROUTINE UNPACKS THE IDENT CODE ID=+/-IJKL
+c
+C -MESONS:
+C I=0, J<=K, +/- IS SIGN FOR J,
+C ID=110 FOR PI0, ID=220 FOR ETA, ETC.
+c
+C -BARYONS:
+C I<=J<=K IN GENERAL,
+C J<I<K FOR SECOND STATE ANTISYMMETRIC IN (I,J), EG. L = 2130
+c
+C -DIQUARKS:
+C ID=+/-IJ00, I<J FOR DIQUARK COMPOSED OF I,J.
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+ implicit real*8 (a-h,o-z)
+ implicit integer (i-n)
+
+ IDABS=IABS(ID)
+c extract the single (anti-)quark ids from the hadron id:
+ I=IDABS/1000
+ J=MOD(IDABS/100,10)
+ K=MOD(IDABS/10,10)
+ JSPIN=MOD(IDABS,10)
+c diquarks:
+ IF(ID.NE.0.AND.MOD(ID,100).EQ.0) GO TO 300
+c quarks oder so:
+ IF(J.EQ.0) GO TO 200
+c mesonen:
+ IF(I.EQ.0) GO TO 100
+
+C..BARYONS:
+C..ONLY X,Y BARYONS ARE QQX, QQY, Q=U,D,S.
+ IFL1=ISIGN(I,ID)
+ IFL2=ISIGN(J,ID)
+ IFL3=ISIGN(K,ID)
+ RETURN
+C MESONS
+100 CONTINUE
+ IFL1=0
+ IFL2=ISIGN(J,ID)
+ IFL3=ISIGN(K,-ID)
+ RETURN
+200 CONTINUE
+ IFL1=0
+ IFL2=0
+ IFL3=0
+ JSPIN=0
+ return
+300 IFL1=ISIGN(I,ID)
+ IFL2=ISIGN(J,ID)
+ IFL3=0
+ JSPIN=0
+ RETURN
+ END
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ SUBROUTINE STRING(IFL1,IFL2,AMSTR)
+c
+cinput amstr : stringmass
+cinput ifl1 : leading (di)quark (along +Z)
+cinput ifl2 : leading (di)quark
+c
+c output : produced particles via common block ({\tt pptcl})
+c
+C Hadron production via string fragmentation. masses acc. to Breit
+c Wigner distr., incl. production of mesonic and baryonic resonances
+c
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+ implicit real*8 (a-h,o-z)
+ implicit integer (i-n)
+
+
+ COMMON/COMTRY/ NTRIES
+ PARAMETER(MXPTCL=200)
+ COMMON/PARTCL/ PPTCL(9,MXPTCL),nptcl,IDENT(MXPTCL),IDCAY(MXPTCL)
+
+ include 'comstr.f'
+
+ DIMENSION PX1L(2),PY1L(2),PX1(2),PY1(2),PMTS(2),W(2),IFL(2)
+ LOGICAL DIQBR,SPINT,BACK
+ DIMENSION VC(3)
+ DIMENSION PPTL(5,MXPTCL),PPTR(5,MXPTCL),
+ *IDENTL(MXPTCL),IDENTR(MXPTCL)
+ COMMON/KAPPA/ XAP
+ COMMON/COLRET/ LRET
+ LOGICAL LRET
+ COMMON/CONSTI/ CONSTI
+ LOGICAL CONSTI
+
+ LOGICAL leading
+
+ include 'options.f'
+
+ IFLL=0
+ PXL=0
+ PYL=0
+c..strange quark and charm quark probabilities:
+ prbs=ctparam(6)
+ prbc=ctparam(7)
+cspl the diquark-suppresion parameter is reduced for small
+c string masses (finite size effect) see A. Jahns diploma thesis
+ if(amstr.le.2.8d0)then
+ pbars=0.d0
+ elseif (amstr.le.5d0)then
+ pbars=((amstr-2.8d0)/2.2d0)**3*ctparam(8)
+ else
+ pbars=ctparam(8)
+ endif
+
+c..some parameters (see input.f)
+ dmas=ctparam(9)
+ dmass=ctparam(10)
+ pardbs=ctparam(25)
+ sigqts=ctparam(42)
+C
+C PRBS STRANGENESS SUPPRESSION PARAMETER
+C PRBC CHARM SUPPRESSION PARAMETER
+ PU=1./(2.+PRBS+PRBC)
+C
+ LRET=.FALSE.
+C
+ NREP = 0
+ DIQBR=.TRUE.
+ NFIX=0
+ BACK=.TRUE.
+
+c.. here starts everything (if the string break up didn't work
+c.. we start again at this point)
+ 100 I=NFIX
+ ilead=0
+ NPR=0
+ NPL=0
+ NPTCL=NFIX
+c.. nrep=number of tries to break string
+ NREP=NREP+1
+ IF(NREP.LT.NTRIES) GO TO 102
+ LRET=.TRUE.
+ctp060926 write(*,*)'!! STRING: no fragmentation.'
+ return
+102 CONTINUE
+ IFL(1)=IFL1
+ IFL(2)=IFL2
+ DO 110 J=1,2
+ 110 W(J)=AMSTR
+ DO 120 J=1,2
+ PX1L(J)=0.
+ PY1L(J)=0.
+ PX1(J)=0.
+ 120 PY1(J)=0.
+C WILL THERE BE ONLY ONE BREAK OR NOT ?
+ SPINT=.TRUE.
+ KSPIN=1
+ IF(MOD(IFL(1),100).EQ.0.AND.MOD(IFL(2),100).EQ.0) GOTO 131
+ IDR=IDPARS(IFL(1),IFL(2),SPINT,KSPIN)
+ WEND=(AMASS(IDR)+DMAS)**2
+ GO TO 151
+131 IFCN=1
+ IF(ranf(0).GT.0.5) IFCN=2
+ IFLC1=IFCN
+ IF(IFL(1).LT.0) IFLC1=-IFCN
+ IDR1=IDPARS(IFL(1),IFLC1,SPINT,KSPIN)
+ IDR2=IDPARS(IFL(2),-IFLC1,SPINT,KSPIN)
+ WEND=(AMASS(IDR1)+AMASS(IDR2)+DMAS)**2
+151 SPINT=.FALSE.
+ KSPIN=0
+c.. only one break goto 225 is the end of the fragmentation
+ IF(W(1)*W(2).LE.WEND) GO TO 225
+
+c..the main iteration loop for the fragmentation:
+ 130 I=I+1
+ IF(I.GT.MXPTCL) GO TO 9999
+C CHOOSE SIDE OF BREAK
+ JSIDE=INT(1.+2.*ranf(0))
+ IF(JSIDE.EQ.1) NPR=NPR+1
+ IF(JSIDE.EQ.2) NPL=NPL+1
+ IF(NPR.GT.MXPTCL.OR.NPL.GT.MXPTCL) GO TO 9999
+C IS IFL(JSIDE) A QUARK OR A DIQUARK ? (di-quark-->150)
+ IF(MOD(IFL(JSIDE),100).EQ.0) GO TO 150
+C IFL(JSIDE) IS A QUARK
+C NOW WE SELECT Q,QBAR PAIR OR QQ,QQBAR PAIR
+ DIQBR=.FALSE.
+ DRND=ranf(0)
+c.. do a qq-qqbar pair with certain prob.
+ IF(DRND.LT.PBARS) GO TO 140
+C Q,QBAR PAIR
+ IFLN=ISIGN(IFLAV(PU,PRBS),-IFL(JSIDE))
+ GO TO 200
+C QQ,QQBAR PAIR
+140 IQ1=IFLAV(PU,PRBS)
+ IQ2=IFLAV(PU,PRBS)
+
+c.. no single-strange diquarks (us,ds)!
+cblubb if(max0(iq1,iq2).eq.3.and.min0(iq1,iq2).lt.3)goto 140
+c.. suppr. double strange di-quarks(ss) with certain prob. (acc. to ctp 29)
+ if((IQ1.eq.3.and.IQ2.eq.3)
+ & .and.ranf(0).gt.CTParam(29))goto 140
+
+ IF(IQ1.LE.IQ2) GO TO 145
+ ISWAP=IQ1
+ IQ1=IQ2
+ IQ2=ISWAP
+145 IFQQ=1000*IQ1+100*IQ2
+ IFLN=ISIGN(IFQQ,IFL(JSIDE))
+ GO TO 200
+c..the di-quark part:
+C IFL(JSIDE) IS A DIQUARK
+C CAN DIQUARK BREAK OR NOT
+ 150 DRND=ranf(0)
+ IF(DRND.LE. PARDBS) GO TO 190
+C DIQUARK BREAK (prob. in PARDBS)
+ CALL FLAVOR(IFL(JSIDE),IFLD1,IFLD2,IFLD3,JSPIN)
+ IFLL=IFLD1
+ IFL(JSIDE)=IFLD2
+ DRND=ranf(0)
+ IF(DRND.GE.PARQLS) GO TO 160
+ IFLL=IFLD2
+ IFL(JSIDE)=IFLD1
+ 160 DIQBR=.TRUE.
+C LEADING QUARK TRANSVERSE MOMENTUM
+ CALL GAUSPT(PTL0,SIGQTS)
+ PHI=2.*PI*ranf(0)
+ PXL=PTL0*COS(PHI)
+ PYL=PTL0*SIN(PHI)
+ PX1L(JSIDE)=PX1(JSIDE)
+ PY1L(JSIDE)=PY1(JSIDE)
+ PX1(JSIDE)=-PXL
+ PY1(JSIDE)=-PYL
+C Q,QBAR PAIR
+ IFLN=ISIGN(IFLAV(PU,PRBS),-IFL(JSIDE))
+ GO TO 200
+C DIQUARK DOES NOT BREAK
+C Q,QBAR PAIR
+ 190 IFLN=ISIGN(IFLAV(PU,PRBS),IFL(JSIDE))
+ DIQBR=.FALSE.
+C IDENT,MASS AND TRANSVERSE MOMENTUM OF PARTICLE
+ 200 IDENT(I)=IDPARS(IFL(JSIDE),IFLN,SPINT,KSPIN)
+ PPTCL(5,I)=AMASS(IDENT(I))
+ SIGQTSN=SIGQTS
+ IF(MOD(IFLN,100).EQ.0) SIGQTSN=sigqts*ctparam(38)
+ if(iabs(ifln).eq.3.or.iabs(ifl(jside)).eq.3)
+ & sigqtsn=sigqts*ctparam(39)
+ CALL GAUSPT(PT2,SIGQTSN)
+c no pt for leading hadron:
+ leading=.false.
+ if((JSIDE.EQ.1.and.NPR.eq.1).and.
+ & (abs(IDENT(I)).eq.1120 .or.abs(IDENT(I)).eq.1220) )then
+c & (abs(IDENT(I)).ge.1110))then
+ leading=.true.
+cblu pt2=pt2/2d0
+ ilead=ilead+1
+ endif
+ if((JSIDE.EQ.2.and.NPL.eq.1).and.
+ & (abs(IDENT(I)).eq.1120 .or.abs(IDENT(I)).eq.1220) )then
+c & (abs(IDENT(I)).ge.1110))then
+ leading=.true.
+cblu pt2=pt2/2d0
+ ilead=ilead+1
+ endif
+c..transverse momentum choosen for the newly produced hadron
+ PHI=2.*PI*ranf(0)
+ PX2=PT2*COS(PHI)
+ PY2=PT2*SIN(PHI)
+ PPTCL(1,I)=PX1(JSIDE)+PX2
+ PPTCL(2,I)=PY1(JSIDE)+PY2
+C GENERATE Z-momentum
+ PMTS(3-JSIDE)=AMASS(IABS(IFL(3-JSIDE)))**2
+ PTS=PPTCL(1,I)**2+PPTCL(2,I)**2
+ PMTS(JSIDE)=PPTCL(5,I)**2+PTS
+ IF(PMTS(JSIDE)+PMTS(3-JSIDE).GE.PARRS*W(1)*W(2)) GO TO 100
+ ZMIN=PMTS(JSIDE)/(W(1)*W(2))
+ ZMAX=1.-PMTS(3-JSIDE)/(W(1)*W(2))
+ IF(ZMIN.GE.ZMAX) GO TO 100
+C..WARNING: VERY IMPORTANT THE ORDER OF IFL AND IFLN IN ZFRAGS
+c.. fraction of momentum acc. to the fragmentation fct.
+ Z=ZFRAGS(IFL(JSIDE),IFLN,PTS,ZMIN,ZMAX,leading)
+
+ PPTCL(3,I)=0.5*(Z*W(JSIDE)-PMTS(JSIDE)/
+ *(Z*W(JSIDE)))*(-1.)**(JSIDE+1)
+ PPTCL(4,I)=0.5*(Z*W(JSIDE)+PMTS(JSIDE)/(Z*W(JSIDE)))
+ IDCAY(I)=0
+ IF(.NOT.(JSIDE.EQ.1)) GO TO 282
+ IDENTR(NPR)=IDENT(I)
+ PPTR(1,NPR)=PPTCL(1,I)
+ PPTR(2,NPR)=PPTCL(2,I)
+ PPTR(3,NPR)=PPTCL(3,I)
+ PPTR(4,NPR)=PPTCL(4,I)
+ PPTR(5,NPR)=PPTCL(5,I)
+ 282 IF(.NOT.(JSIDE.EQ.2)) GO TO 283
+ IDENTL(NPL)=IDENT(I)
+ PPTL(1,NPL)=PPTCL(1,I)
+ PPTL(2,NPL)=PPTCL(2,I)
+ PPTL(3,NPL)=PPTCL(3,I)
+ PPTL(4,NPL)=PPTCL(4,I)
+ PPTL(5,NPL)=PPTCL(5,I)
+ 283 IF(DIQBR) GO TO 210
+ IFL(JSIDE)=-IFLN
+ PX1(JSIDE)=-PX2
+ PY1(JSIDE)=-PY2
+ GO TO 220
+C NEW DIQUARK CREATION
+210 ID1=IABS(IFLL)
+ ID2=IABS(IFLN)
+ IF(ID1.LE.ID2) GO TO 215
+ ISWAP=ID1
+ ID1=ID2
+ ID1=ISWAP
+215 IFL(JSIDE)=ISIGN(1000*ID1+100*ID2,IFLL)
+ PX1L(JSIDE)=PX1L(JSIDE)+PXL-PX2
+ PY1L(JSIDE)=PY1L(JSIDE)+PYL-PY2
+ PX1(JSIDE)=PX1L(JSIDE)
+ PY1(JSIDE)=PY1L(JSIDE)
+ 220 W(1)=W(1)-PPTCL(4,I)-PPTCL(3,I)
+ W(2)=W(2)-PPTCL(4,I)+PPTCL(3,I)
+ SPINT=.TRUE.
+ KSPIN=2
+ IF(MOD(IFL(1),100).EQ.0.AND.MOD(IFL(2),100).EQ.0) GO TO 240
+ IDB=IDPARS(IFL(1),IFL(2),SPINT,KSPIN)
+ AMB=AMASS(IDB)+dmass
+ GO TO 211
+240 IFCN=1
+ IF(ranf(0).GT.0.5) IFCN=2
+ IFLC1=-IFCN
+ IF(IFL(1).GT.0) IFLC1=IFCN
+ IFLC2=-IFLC1
+ IKH1=IDPARS(IFL(1),IFLC1,SPINT,KSPIN)
+ IKH2=IDPARS(IFL(2),IFLC2,SPINT,KSPIN)
+ AMB=AMASS(IKH1)+AMASS(IKH2)+DMASs
+211 P1X=PX1(1)+PX1(2)
+ P1Y=PY1(1)+PY1(2)
+ PT12=P1X**2+P1Y**2
+ W12=W(1)*W(2)
+ AMS2=W12-PT12
+ IF(AMS2.LT.AMB**2) GO TO 100
+ SPINT=.TRUE.
+ KSPIN=1
+ IF(MOD(IFL(1),100).EQ.0.AND.MOD(IFL(2),100).EQ.0) GO TO 231
+ IDR=IDPARS(IFL(1),IFL(2),SPINT,KSPIN)
+ WEND=(AMASS(IDR)+DMAS)**2
+ GO TO 232
+231 IKHR1=IDPARS(IFL(1),IFLC1,SPINT,KSPIN)
+ IKHR2=IDPARS(IFL(2),IFLC2,SPINT,KSPIN)
+ WEND=(AMASS(IKHR1)+AMASS(IKHR2)+DMAS)**2
+232 SPINT=.FALSE.
+ KSPIN=0
+ IF(W(1)*W(2).GE.WEND) GO TO 130
+ GO TO 230
+225 P1X=PX1(1)+PX1(2)
+ P1Y=PY1(1)+PY1(2)
+ PT12=P1X**2+P1Y**2
+ W12=W(1)*W(2)
+ AMS2=W12-PT12
+C LAST BREAK OF STRING
+ 230 NPTCL=I
+ AMC=SQRT(AMS2)
+ EC=(W(1)+W(2))/2.0
+ VC(1)=P1X/EC
+ VC(2)=P1Y/EC
+ VC(3)=(W(1)-W(2))/(2.0*EC)
+ NIN1=NPTCL+1
+c.. the last break of the string will be done in clustr
+ CALL CLUSTR(IFL(1),IFL(2),AMC,ilead)
+ IF(LRET) GO TO 100
+ NFIN1=NPTCL
+ CALL LORTR(VC,NIN1,NFIN1,BACK)
+ NPR=NPR+1
+ NPL=NPL+1
+ IF(NPR.GT.MXPTCL.OR.NPL.GT.MXPTCL) GO TO 9999
+c..the hadron from the left and the right side of the string
+c..are copied to the final pptcl array
+ IDENTL(NPL)=IDENT(NFIN1)
+ PPTL(1,NPL)=PPTCL(1,NFIN1)
+ PPTL(2,NPL)=PPTCL(2,NFIN1)
+ PPTL(3,NPL)=PPTCL(3,NFIN1)
+ PPTL(4,NPL)=PPTCL(4,NFIN1)
+ PPTL(5,NPL)=PPTCL(5,NFIN1)
+ IDENTR(NPR)=IDENT(NIN1)
+ PPTR(1,NPR)=PPTCL(1,NIN1)
+ PPTR(2,NPR)=PPTCL(2,NIN1)
+ PPTR(3,NPR)=PPTCL(3,NIN1)
+ PPTR(4,NPR)=PPTCL(4,NIN1)
+ PPTR(5,NPR)=PPTCL(5,NIN1)
+ JJ=NFIX
+ DO 284 J=1,NPR
+ JJ=JJ+1
+ IDENT(JJ)=IDENTR(J)
+ PPTCL(1,JJ)=PPTR(1,J)
+ PPTCL(2,JJ)=PPTR(2,J)
+ PPTCL(3,JJ)=PPTR(3,J)
+ PPTCL(4,JJ)=PPTR(4,J)
+ PPTCL(5,JJ)=PPTR(5,J)
+284 CONTINUE
+ JJ=NFIX+NPR
+ DO 285 J=1,NPL
+ JJ=JJ+1
+ K=NPL-J+1
+ IDENT(JJ)=IDENTL(K)
+ PPTCL(1,JJ)=PPTL(1,K)
+ PPTCL(2,JJ)=PPTL(2,K)
+ PPTCL(3,JJ)=PPTL(3,K)
+ PPTCL(4,JJ)=PPTL(4,K)
+ PPTCL(5,JJ)=PPTL(5,K)
+285 CONTINUE
+ N1=NFIX+1
+ N2=NFIX+NPR+NPL-1
+c.. we choose the LUND scheme
+ consti=.false.
+
+ IF(CONSTI) THEN
+C------------------------------------------------------C
+C----- CONSTITUENT TIME ----------------C
+C------------------------------------------------------C
+ DO 1286 J=N1,N2
+ P3S=0.
+ ES=0.
+ DO 1287 L=N1,J
+ P3S=P3S+PPTCL(3,L)
+1287 ES=ES+PPTCL(4,L)
+c.. TI is the formation time of the particle
+c.. ZI is the z coordinate
+ TI=(AMSTR-2.*P3S)/(2.*XAP)
+ ZI=(AMSTR-2.*ES)/(2.*XAP)
+ IF(J.NE.N2) GO TO 1288
+ TII=TI
+ ZII=ZI
+1288 PPTCL(6,J)=0.
+ PPTCL(7,J)=0.
+ PPTCL(8,J)=ZI
+ PPTCL(9,J)=TI
+1286 CONTINUE
+C
+ PPTCL(6,N2+1)=0.
+ PPTCL(7,N2+1)=0.
+ PPTCL(8,N2+1)=ZII
+ PPTCL(9,N2+1)=TII
+C
+ GO TO 1253
+ ENDIF
+C------------------------------------------------------C
+C----- INSIDE-OUTSIDE TIME (LUND) ----------------C
+C------------------------------------------------------C
+ DO 286 J=N1,NPTCL
+ P3S=0.
+ ES=0.
+ NJ=J-1
+ IF(NJ.EQ.0) GO TO 289
+ DO 287 L=N1,NJ
+ P3S=P3S+PPTCL(3,L)
+ 287 ES=ES+PPTCL(4,L)
+c.. TI is the formation time of the particle
+c.. ZI is the z coordinate
+ 289 TI=(AMSTR-2.*P3S+PPTCL(4,J)-PPTCL(3,J))/(2.*XAP)
+ ZI=(AMSTR-2.*ES-PPTCL(4,J)+PPTCL(3,J))/(2.*XAP)
+ PPTCL(6,J)=0.
+ PPTCL(7,J)=0.
+ PPTCL(8,J)=ZI
+ PPTCL(9,J)=TI
+ 286 CONTINUE
+1253 RETURN
+
+c.. warning if to many hadrons are produced in string
+c.. increase the particle arrays to avoid this
+9999 WRITE(6,9998) I
+9998 FORMAT(//10X,40H...STOP IN STRING..NPTCL TOO HIGH NPTCL=,I5)
+ STOP
+ END
+
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ SUBROUTINE CLUSTR(IFL1,IFL2,AMCTR,ilead)
+c
+cinput amctr : stringmass,
+cinput ifl1 : leading quark (or diquark) along $+Z$ axis
+cinput ifl2 : 2nd leading quark (or diquark)
+cinput ilead : $2-ilead=$ number of leading (di-)quarks
+c
+c output : produced particles via common block ({\tt pptcl})
+c
+C HADRONS PRODUCTION BY MEANS CLUSTER BREAKING
+C WITH QUARK AND ANTIQUARK OR QUARK AND DIQUARK OR DIQUARK AND
+C ANTIDIQUARK IFL1 AND IFL2 ON ENDS.
+c Only the final 2 particles are created in {\tt clustr}!
+c
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+ implicit real*8 (a-h,o-z)
+ implicit integer (i-n)
+
+ COMMON/COMTRY/ NTRIES
+
+ PARAMETER(MXPTCL=200)
+ COMMON/PARTCL/ PPTCL(9,MXPTCL),nptcl,IDENT(MXPTCL),IDCAY(MXPTCL)
+
+ include 'comstr.f'
+
+ COMMON/COLRET/ LRET
+ LOGICAL LRET
+ DIMENSION IFL(2),U(3)
+ LOGICAL SPINT
+ real*8 valint(1)
+ common /values/ valint
+
+ include 'options.f'
+ctp060202 to avoid warnings with gfortran compilation
+ logical ctp060202
+ ctp060202=.false.
+ if(ctp060202)write(*,*)ilead
+ctp060202 end
+
+c.. strange and charm suppression in clustr (see string)
+ prbs=ctparam(6)
+ prbc=ctparam(7)
+c..the diquark-suppresion parameter is reduced for small
+c string masses (finite size effect) see A. Jahns diploma thesis
+ if(amctr.le.2.8d0)then
+ pbarc=0.d0
+ elseif (amctr.le.5d0)then
+ pbarc=((amctr-2.8d0)/2.2d0)**3*ctparam(8)
+ else
+ pbarc=ctparam(8)
+ endif
+
+ dmas=ctparam(9)
+ dmass=ctparam(10)
+
+C
+C PRBS STRANGENESS SUPPRESSION PARAMETER
+C PRBC CHARM SUPPRESSION PARAMETER
+ PU=1./(2.+PRBS+PRBC)
+C
+ NFIX=NPTCL
+ NREP=0
+ LRET=.FALSE.
+ 100 I=NFIX
+ IF(NREP.LT.NTRIES) GO TO 101
+ LRET=.TRUE.
+ RETURN
+101 CONTINUE
+ KSPIN=0
+ IFL(1)=IFL1
+ IFL(2)=IFL2
+ SPINT=.FALSE.
+ I=I+2
+ IF(I.GT.MXPTCL) GO TO 9999
+C CHOOSE SIDE OF BREAK
+ JSIDE=1
+C IF ANY IFL IS A DIQUARK
+ IF(MOD(IFL(1),100).EQ.0.OR.MOD(IFL(2),100).EQ.0) GO TO 150
+C IFL(1) AND IFL(2) ARE QUARKS
+C SELECT Q,QBARPAIR OR QQ,QQBAR PAIR
+ DRND=ranf(0)
+ IF(DRND.LT.PBARC.and.valint(1).eq.0.d0) GO TO 140
+C Q,QBAR PAIR
+ IFLN=ISIGN(IFLAV(PU,PRBS),-IFL(JSIDE))
+ GO TO 200
+C QQ,QQBAR PAIR
+140 IQ1=IFLAV(PU,PRBS)
+ IQ2=IFLAV(PU,PRBS)
+ IF(IQ1.LE.IQ2) GO TO 145
+ ISWAP=IQ1
+ IQ1=IQ2
+ IQ2=ISWAP
+145 IFQQ=1000*IQ1+100*IQ2
+ IFLN=ISIGN(IFQQ,IFL(JSIDE))
+ GO TO 200
+C IFL(1) OR IFL(2) IS DIQUARK
+C Q,QBAR PAIR
+150 IPSIGN=IFL(JSIDE)
+ IF(MOD(IFL(JSIDE),100).EQ.0) GO TO 130
+ IPSIGN=-IFL(JSIDE)
+130 IFLN=ISIGN(IFLAV(PU,PRBS),IPSIGN)
+C IDENTS AND MASSES OF PARTICLES
+ 200 continue
+c..quark-flip included (to describe some phi data)
+ if(CTParam(5).gt.ranf(0).and.mod(ifln,100).ne.0.and.
+ & mod(ifl(jside),100).ne.0.and.mod(ifl(3-jside),100).ne.0)then
+c quark-flip
+ IDENT(I-1)=IDPARC(IFL(JSIDE),IFL(3-JSIDE),SPINT,KSPIN)
+ IDENT(I)=IDPARC(-IFLN,IFLN,SPINT,KSPIN)
+ else
+ IDENT(I-1)=IDPARC(IFL(JSIDE),IFLN,SPINT,KSPIN)
+ IDENT(I)=IDPARC(IFL(3-JSIDE),-IFLN,SPINT,KSPIN)
+ end if
+c..for special bbar-b annihilation reactions for conservation
+c of total quantum numbers
+ if(valint(1).ne.0.d0)then
+ ifq1=int(valint(1)/10.)
+ ifq2=-mod(int(valint(1)),10)
+ if(isign(1,ifln).eq.isign(1,ifq1))then
+ IDENT(I-1)=IDPARC(IFL(JSIDE),ifq1,SPINT,KSPIN)
+ IDENT(I)=IDPARC(IFL(3-JSIDE),ifq2,SPINT,KSPIN)
+ else
+ IDENT(I-1)=IDPARC(IFL(JSIDE),ifq2,SPINT,KSPIN)
+ IDENT(I)=IDPARC(IFL(3-JSIDE),ifq1,SPINT,KSPIN)
+ endif
+ endif
+
+ PPTCL(5,I-1)=AMASS(IDENT(I-1))
+ PPTCL(5,I)=AMASS(IDENT(I))
+C IF TOO LOW MASS,START ALL OVER (i.e. goto 100)
+ DEMAS=0.15
+ IF(IFLN.LT.3) DEMAS=0.
+c IF(AMCTR.GT.PPTCL(5,I-1)+PPTCL(5,I)+DEMAS) GO TO 102
+ IF(AMCTR.GT.PPTCL(5,I-1)+PPTCL(5,I)+DEMAS) then
+ if(mod(ifl1,100).eq.0.or.mod(ifl2,100).eq.0)goto 102
+c..maximum kinetic energy cutoff for meson-clustr:
+c..we want a lot of energy in the particle mass in this last break
+ IF(AMCTR-PPTCL(5,I-1)-PPTCL(5,I).lt.ctparam(43)) GO TO 102
+ endif
+ NREP=NREP+1
+c.. 100 starts all over
+ GO TO 100
+
+102 CONTINUE
+
+c.. isotropic px py pz distribution
+ PA=DBLPCM(AMCTR,PPTCL(5,I-1),PPTCL(5,I))
+ U(3)=1.-2.*ranf(0)
+ PHI=2.*PI*ranf(0)
+ ST=SQRT(1.-U(3)**2)
+ U(1)=ST*COS(PHI)
+ U(2)=ST*SIN(PHI)
+ PPTCL(1,I-1)=PA*U(1)
+ PPTCL(1,I)=-(PA*U(1))
+ PPTCL(2,I-1)=PA*U(2)
+ PPTCL(2,I)=-(PA*U(2))
+ PPTCL(3,I-1)=PA*U(3)
+ PPTCL(3,I)=-(PA*U(3))
+ PA2=PA**2
+ PPTCL(4,I-1)=SQRT(PA2+PPTCL(5,I-1)**2)
+ PPTCL(4,I)=SQRT(PA2+PPTCL(5,I)**2)
+ IDCAY(I-1)=0
+ IDCAY(I)=0
+ NPTCL=I
+c..forward/backward distribution in clustr for baryons
+c..(no pt in the last string break!)
+c..pt for the baryon comes from parton kick in the excitation
+ if(abs(ident(i)).ge.1000.or.abs(ident(i-1)).ge.1000)then
+ PPTCL(1,I-1)=0.d0
+ PPTCL(1,I)=0.d0
+ PPTCL(2,I-1)=0.d0
+ PPTCL(2,I)=0.d0
+ PPTCL(3,I-1)=PA
+ PPTCL(3,I)=-PA
+ PA2=PA**2
+ PPTCL(4,I-1)=SQRT(PA2+PPTCL(5,I-1)**2)
+ PPTCL(4,I)=SQRT(PA2+PPTCL(5,I)**2)
+ IDCAY(I-1)=0
+ IDCAY(I)=0
+ NPTCL=I
+ endif
+
+c..if baryon number=+-1, force the (anti-)baryon in positive
+c..z-direction (just pick the right hemisphere)
+ if(ctoption(29).gt.0)then
+ if( (iabs(ident(i)/1000).ne.0.and.iabs(ident(i-1)/1000).eq.0
+ & .and.pptcl(3,i).lt.0.d0).or.
+ & (iabs(ident(i-1)/1000).ne.0.and.iabs(ident(i)/1000).eq.0
+ & .and.pptcl(3,i-1).lt.0.d0)) then
+ pptcl(3,i) =-pptcl(3,i)
+ pptcl(3,i-1)=-pptcl(3,i-1)
+ endif
+ endif
+
+
+ RETURN
+c.. particle array to small warning:
+9999 WRITE(6,9998) I
+9998 FORMAT(//10X,40H...STOP IN CLUSTR..NPTCL TOO HIGH NPTCL=,I5)
+ STOP
+ END
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ integer FUNCTION IFLAV(PU,PRBS)
+c
+cinput PU : 1-{\tt PU}= up (down, resp.) probability
+cinput PRBS : Strange quark suppression
+c
+c output : {\tt iflav}: flavor of created quark
+c
+c Returns quark flavor acc. to suppression prob's:
+c 1=up, 2=down, 3=strange, 4=charm
+c
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+ implicit real*8 (a-h,o-z)
+ implicit integer (i-n)
+
+C
+ RNDOM=ranf(0)
+C
+ IF(RNDOM.GT.PU) GO TO 1
+c..create up quark
+ IFLAV=1
+ RETURN
+ 1 IF(RNDOM.GT.2.0*PU) GO TO 2
+c..create down quark
+ IFLAV=2
+ RETURN
+ 2 IF(RNDOM.GT.PU*(2.0+PRBS)) GO TO 3
+c..create strange quark
+ IFLAV=3
+ RETURN
+c..create charm quark
+ 3 IFLAV=4
+ RETURN
+ END
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ real*8 FUNCTION ZFRAGS(IFL,IFLN,PT2,ZMIN,ZMAX,leading)
+c
+cinput IFL : ID of existing quark
+cinput IFLN : ID of newly created quark
+cinput PT2 : $p_t$ of newly created hadron
+cinput ZMIN : lowest allowed longitudinal momentum fraction
+cinput ZMAX : highest allowed longitudinal momentum fraction
+cinput leading : flag for leading particle
+c
+coutput ZFRAGS : longitudinal momentum fraction of created hadron
+c
+c According to the fragmentation function(s), longitudinal momentum
+c is assigned to the hadron.
+c
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+ implicit real*8 (a-h,o-z)
+ implicit integer (i-n)
+
+ LOGICAL leading
+
+ include 'options.f'
+
+ COMMON/INPRNT/ ITDKY,ITLIS
+ PARAMETER(ALFT=0.5,ARHO=0.5,APHI=0.,APSI=-2.)
+ PARAMETER(AN=-0.5,ALA=-0.75,ALAC=-1.75)
+ PARAMETER(AKSI=-1.0,AUSC=-2.0,AUCC=-2.0)
+
+c.. cto 21 chooses the fragmentation fct.
+ if ((.not.leading).or.(ifln.eq.3)) then
+ affm=ctparam(47)
+ bffm=ctparam(48)
+ 5108 ZFRAGS=ZMIN+ranf(0)*(ZMAX-ZMIN)
+ YF=((1d0-ZFRAGS)**bffm*(bffm+1)*affm+1-affm)/3d0
+ctp060926 if(yf.gt.1d0.or.yf.lt.0d0)then
+ctp060926 write(6,*)'ZFRAGS: wrong norm:',yf,zmin,zmax,zfrags
+ctp060926 end if
+ IF(ranf(0).LE.YF) RETURN
+ GO TO 5108
+ endif
+
+c.. GAUSSIAN fragmentation fct.
+ if(CTOption(21).eq.0)then
+ affm=CTParam(36)
+ bffm=CTParam(37)
+c.. suppress low momentum particles
+ deltaz=zmax-zmin
+ zmin=zmin+deltaz*0.25d0
+ 108 ZFRAGS=ZMIN+ranf(0)*(ZMAX-ZMIN)
+c.. gaussian distr.
+ yf=exp(-(((zfrags-bffm)**2)/(2.*affm**2)))
+c.. field-feynmann fragmentation fct.
+c YF=((1d0-ZFRAGS)**bffm*(bffm+1)*affm+1-affm)/3d0
+ctp060926 if(yf.gt.1d0.or.yf.lt.0d0)then
+ctp060926 write(6,*)'ZFRAGS: wrong norm:',yf,zmin,zmax,zfrags
+ctp060926 end if
+c return
+ IF(ranf(0).LE.YF) RETURN
+ GO TO 108
+
+ else if(CTOption(21).eq.1)then
+c..lund-fragmentation fct.
+ 1008 ZFRAGS=ZMIN+ranf(0)*(ZMAX-ZMIN)
+ YF=(1-zfrags)*exp(-(0.7*pt2/zfrags))/3d0
+ctp060926 if(yf.gt.1d0.or.yf.lt.0d0)then
+ctp060926 write(6,*)'ZFRAGS: wrong norm:',yf,zmin,zmax,zfrags
+ctp060926 end if
+ IF(ranf(0).LE.YF) RETURN
+ GO TO 1008
+
+ else if(CTOption(21).eq.2)then
+c.. kaidalov's fragmentation fct.
+ ID1=IABS(IFL)
+ ID2=IABS(IFLN)
+ IF(MOD(ID2,100).EQ.0) GO TO 15
+ GO TO(1,2,3,4),ID2
+C UU-TRAJECTORY
+ 1 ZFRAGS=ZMIN+ranf(0)*(ZMAX-ZMIN)
+ YF=(1.0-ZFRAGS)**(ALFT-ARHO)
+ IF(ranf(0).LE.YF) RETURN
+ GO TO 1
+C DD-TRAJECTORY
+ 2 ZFRAGS=ZMIN+ranf(0)*(ZMAX-ZMIN)
+ YF=(1.-ZFRAGS)**(ALFT-ARHO)
+ IF(ranf(0).LE.YF) RETURN
+ GO TO 2
+C SS-TRAJECTORY
+ 3 ZFRAGS=ZMIN+ranf(0)*(ZMAX-ZMIN)
+ YF=(1.-ZFRAGS)**(ALFT-APHI)
+ IF(ranf(0).LE.YF) RETURN
+ GO TO 3
+C CC-TRAJECTORY
+ 4 ZFRAGS=ZMIN+ranf(0)*(ZMAX-ZMIN)
+ YF=(1.-ZFRAGS)**(ALFT-APSI)
+ IF(ranf(0).LE.YF) RETURN
+ GO TO 4
+C
+15 Continue
+ CALL FLAVOR(ID2,IFL2,IFL3,IFL1,ISPIN)
+ IF((IFL2.EQ.1.AND.IFL3.EQ.1)) GO TO 16
+ IF((IFL2.EQ.1.AND.IFL3.EQ.2)) GO TO 17
+ IF((IFL2.EQ.1.AND.IFL3.EQ.3)) GO TO 18
+ IF((IFL2.EQ.1.AND.IFL3.EQ.4)) GO TO 19
+ IF((IFL2.EQ.2.AND.IFL3.EQ.2)) GO TO 20
+ IF((IFL2.EQ.2.AND.IFL3.EQ.3)) GO TO 21
+ IF((IFL2.EQ.2.AND.IFL3.EQ.4)) GO TO 22
+ IF((IFL2.EQ.3.AND.IFL3.EQ.3)) GO TO 23
+ IF((IFL2.EQ.3.AND.IFL3.EQ.4)) GO TO 24
+ IF((IFL2.EQ.4.AND.IFL3.EQ.4)) GO TO 25
+C UUUU-TRAJECTORY
+16 ZFRAGS=ZMIN+ranf(0)*(ZMAX-ZMIN)
+ YF=(1.-ZFRAGS)**(ALFT-(2.*AN-ARHO))
+ IF(ranf(0).LE.YF) RETURN
+ GO TO 16
+C UDUD-TRAJECTORY
+17 ZFRAGS=ZMIN+ranf(0)*(ZMAX-ZMIN)
+ YF=(1.-ZFRAGS)**(ALFT-(2.*AN-ARHO))
+ IF(ranf(0).LE.YF) RETURN
+ GO TO 17
+C USUS-TRAJECTORY
+18 ZFRAGS=ZMIN+ranf(0)*(ZMAX-ZMIN)
+ YF=(1.-ZFRAGS)**(ALFT-(2.*ALA-ARHO))
+ IF(ranf(0).LE.YF) RETURN
+ GO TO 18
+C UCUC-TRAJECTORY
+19 ZFRAGS=ZMIN+ranf(0)*(ZMAX-ZMIN)
+ YF=(1.-ZFRAGS)**(ALFT-(2.*ALAC-ARHO))
+ IF(ranf(0).LE.YF) RETURN
+ GO TO 19
+C DDDD-TRAJECTORY
+20 ZFRAGS=ZMIN+ranf(0)*(ZMAX-ZMIN)
+ YF=(1.-ZFRAGS)**(ALFT-(2.*AN-ARHO))
+ IF(ranf(0).LE.YF) RETURN
+ GO TO 16
+C DSDS-TRAJECTORY
+21 ZFRAGS=ZMIN+ranf(0)*(ZMAX-ZMIN)
+ YF=(1.-ZFRAGS)**(ALFT-(2.*ALA-ARHO))
+ IF(ranf(0).LE.YF) RETURN
+ GO TO 21
+C DCDC-TRAJECTORY
+22 ZFRAGS=ZMIN+ranf(0)*(ZMAX-ZMIN)
+ YF=(1.-ZFRAGS)**(ALFT-(2.*ALAC-ARHO))
+ IF(ranf(0).LE.YF) RETURN
+ GO TO 22
+C SSSS-TRAJECTORY
+23 ZFRAGS=ZMIN+ranf(0)*(ZMAX-ZMIN)
+ YF=(1.-ZFRAGS)**(ALFT-(2.*AKSI-ARHO))
+ IF(ranf(0).LE.YF) RETURN
+ GO TO 23
+C SCSC-TRAJECTORY
+24 ZFRAGS=ZMIN+ranf(0)*(ZMAX-ZMIN)
+ YF=(1.-ZFRAGS)**(ALFT-(2.*AUSC-ARHO))
+ IF(ranf(0).LE.YF) RETURN
+ GO TO 24
+C CCCC-BARYON
+25 ZFRAGS=ZMIN+ranf(0)*(ZMAX-ZMIN)
+ YF=(1.-ZFRAGS)**(ALFT-(2.*AUCC-ARHO))
+ IF(ranf(0).LE.YF) RETURN
+ GO TO 25
+ else
+ write(6,*)'string.f: cto(21)=',ctoption(21),' not valid'
+ stop
+ end if
+
+ END
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ SUBROUTINE LORTR(V,NIN,NFIN,BACK)
+c
+cinput V : boost velocity (3-vector)
+cinput NIN : lower boundary in the pptcl array
+cinput NFIN : upper boundary in the pptcl array
+cinput back : inversion flag for transformation
+c
+c output : via common block ({\tt pptcl})
+c
+c Performs a Lorentz-boost of a part of the pptcl array
+c (from {\tt nin} to {\tt nfin})
+c
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+ implicit real*8 (a-h,o-z)
+ implicit integer (i-n)
+
+ PARAMETER(MXPTCL=200)
+ COMMON/PARTCL/ PPTCL(9,MXPTCL),nptcl,IDENT(MXPTCL),IDCAY(MXPTCL)
+ DIMENSION V(3),VD(3)
+ LOGICAL BACK
+ L=1
+ IF(BACK) L=-1
+ DO 3 I=1,3
+3 VD(I)=V(I)
+ VVD=VD(1)*VD(1)+VD(2)*VD(2)+VD(3)*VD(3)
+ GAD=1.D0/DSQRT(DABS(1.D0-VVD))
+ GA=GAD
+ DO 100 J=NIN,NFIN
+ VP=V(1)*PPTCL(1,J)+V(2)*PPTCL(2,J)+V(3)*PPTCL(3,J)
+ GAVP=GA*(GA*VP/(1.+GA)-FLOAT(L)*PPTCL(4,J))
+ PPTCL(1,J)=PPTCL(1,J)+GAVP*V(1)
+ PPTCL(2,J)=PPTCL(2,J)+GAVP*V(2)
+ PPTCL(3,J)=PPTCL(3,J)+GAVP*V(3)
+ PMAS=PPTCL(5,J)
+ PPTCL(4,J)=SQRT(PPTCL(1,J)**2+PPTCL(2,J)**2+PPTCL(3,J)**2+
+ +PMAS**2)
+100 CONTINUE
+ RETURN
+ END
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ BLOCK DATA D2
+c
+c Initial values for several common blocks
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+ implicit real*8 (a-h,o-z)
+ implicit integer (i-n)
+C
+C INPUT QUARK DISTRIBUTION PARAMETERS
+C
+
+ include 'comstr.f'
+
+ COMMON/KAPPA/ XAP
+ COMMON/CONSTI/ CONSTI
+ LOGICAL CONSTI
+ DATA CONSTI/.FALSE./
+C
+C
+C DATA FOR COSPAR
+c this parameter controls the min. energy for ending string fragmentation
+c default DATA DMAS/0.35/
+c now: ctparam(9) and ctparam(10)
+c DATA DMAS/1./
+c data dmass/0.25/
+C
+C
+C INPUT STRING TENSION (FERMI/GEV)
+ DATA XAP/1.0/
+C
+C INPUT FRAGMENTATION PARAMETERS:
+C
+ DATA PARQLS/0.5/,PARRS/0.9/
+C PRBS STRANGENESS SUPPRESSION PARAMETER
+C PRBC CHARM SUPPRESSION PARAMETER
+C PBARC AND PBARS BARYON PAIRS SUPPRESION PARAMETERS
+C DATA PRBS/0.3/,PRBC/0.0005/,PBARC/0.09/,PBARS/0.09/
+c these are now ctparam(6),ctparam(7) and ctparam(8)
+c DATA PRBS/0.33/,PRBC/0.0/,PBARC/0.09/,PBARS/0.09/
+C
+C THESE PARAMETERS ARE IMPORTANT FOR RESONANCE PRODUCTION
+ DATA PJSPNC/.50/
+ DATA PJSPNS/.50/
+c DATA PJSPNC/1./
+c DATA PJSPNS/1./
+C DATA PMIX1C/.25,.25,.5,.5,.5,1./,PMIX2C/.5,.5,1.,0.,0.,1./
+c DATA PMIX1S/.25,.25,.5,.5,.5,1./,PMIX2S/.5,.5,1.,0.,0.,1./
+c QUARK MIXING PARAMETERS
+cspl-0795 these parameters assign the pure u/ubar,d/dbar,s/sbar states
+c (e.g. 110,220,330) to the physical particles according to the su(3)
+c quark model. The flavor mixing angles are chosen according to quadratic
+c Gell-Mann-Okubo mass formula (Review of Particle Properties,
+c Phys. Rev D50 (1994) 1319). For the scalar mesons this formula is not
+c applicable. We assume an ideal mixing angle (tan(theta)=1/sqrt(2)).
+c
+c pseudoscalar: theta=-10 deg
+c vector : theta= 39 deg
+c pseudovector: theta= 51 deg
+c tensor : theta= 28 deg
+c
+c PMIX1C/S(IF1,JSPIN) gives the quark content of the heavy isosinglet:
+c e.g. the eta' (330) is 25% u/ubar 25% d/dbar and 50% s/sbar
+c PMIX2C/S(IF1,JSPIN) chooses for nonstrange qqbars between the isosinglet
+c the and the isotriplet
+c quark content of the heavy singlett
+c DATA PMIX1C/.25,.25,.5, ! eta'
+c & 0.,0.,1., ! phi
+c & 0.,0.,1., ! f_0
+c & .04,.04,.92, ! f_1'
+c & .01,.01,.98/ ! f_2'
+c DATA PMIX2C/.5 ,.5 ,1.,.5,.5,1.,.5,.5,1.,.5 ,.5 ,1. ,.5 ,.5 , 1./
+c DATA PMIX1S/.25,.25,.5,0.,0.,1.,0.,0.,1.,.04,.04,.92,.01,.01,.98/,
+c & PMIX2S/.5 ,.5 ,1.,.5,.5,1.,.5,.5,1.,.5 ,.5 ,1. ,.5 ,.5 , 1./
+C
+C SIGQTS IS IMPORTANT PARAMETER FOR PRODUCED HADRON TRANSVERSE MOMENTA
+C
+c DATA SIGQTS/0.65/ -> ctparam(42)
+ END
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ BLOCK DATA D4
+c
+cinput () : NONE
+c
+coutput () : via common blocks
+c
+c Initial values for several common blocks
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+ implicit real*8 (a-h,o-z)
+ implicit integer (i-n)
+
+ COMMON/COMTRY/ NTRIES
+C
+C
+C DATA COMTRY
+ DATA NTRIES/1000/
+C
+
+ END
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ integer FUNCTION IDPARS(IFL01,IFL02,SPINT,IR)
+c
+cinput IFL01 : ID of (anti-)quarks/di-quarks
+cinput IFL02 : ID of (anti-)quarks/di-quarks
+cinput SPINT : flag for spin assignment
+cinput IR : Determines particle spin
+c
+c output : Quark code of the hadron
+c
+C CONSTRUCT MESON FROM QUARK AND ANTIQUARK WITH FLAVORS IFL01,IFL02
+C OR CONSTRUCT BARYON FROM DIQUARK AND QUARK OR ANTIDIQUARK AND
+C ANTIQUARK WITH FLAVORS IFL01,IFL02.
+c THE MESON MULTIPLETT IS CHOSEN ACC. TO SUPPRESSION PARAM'S:
+c parm gives the probability for different meson multiplets according
+c to spin degeneracy and average mass ratios
+c spin-parity 0- : 1- : 0+ : 1+ : 2+ = parm(1):parm(2)...:parm(5)
+c If SPINT=.t., IR will be used to assign particle spin
+c
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+ implicit real*8 (a-h,o-z)
+ implicit integer (i-n)
+
+
+ LOGICAL SPINT
+ include 'options.f'
+
+ include 'comstr.f'
+
+C
+ IFL1=IFL01
+ IFL2=IFL02
+C CONSTRUCT MESON WITH ACCOUNT FLAVOR MIXING
+ IF(MOD(IFL1,100).EQ.0) GO TO 420
+ IF(MOD(IFL2,100).EQ.0) GO TO 425
+c
+ call getbran(parm,1,njspin,psdum,1,njspin,jspin)
+ jspin=jspin-1
+
+ IF(SPINT.AND.IR.EQ.2) JSPIN=0
+ IF(SPINT.AND.IR.EQ.1) JSPIN=1
+ ID1=IFL1
+ ID2=IFL2
+ IF(ID1+ID2.NE.0) GO TO 400
+C
+ ID1=IABS(ID1)
+ IF(ID1.GE.4) GO TO 401
+ RND=ranf(0)
+ ID1=INT(PMIX1S(ID1,JSPIN+1)+RND)+INT(PMIX2S(ID1,JSPIN+1)+RND)+1
+ 401 ID2=-ID1
+C
+ 400 IF(IABS(ID1).LE.IABS(ID2)) GO TO 410
+ ISAVE=ID1
+ ID1=ID2
+ ID2=ISAVE
+ 410 IDHAD=ISIGN(100*IABS(ID1)+10*IABS(ID2)+JSPIN,ID1)
+ GO TO 470
+C CONSTRUCT BARYON IDENT
+ 420 ID3=ISIGN(MOD(IFL1/100,10),IFL1)
+ ID2=IFL1/1000
+ ID1=IFL2
+ GO TO 430
+ 425 ID3=ISIGN(MOD(IFL2/100,10),IFL2)
+ ID2=IFL2/1000
+ ID1=IFL1
+ 430 IF(IABS(ID1).LE.IABS(ID2)) GO TO 431
+ ISWAP=ID1
+ ID1=ID2
+ ID2=ISWAP
+ 431 IF(IABS(ID2).LE.IABS(ID3)) GO TO 432
+ ISWAP=ID2
+ ID2=ID3
+ ID3=ISWAP
+ 432 IF(IABS(ID1).LE.IABS(ID2)) GO TO 440
+ ISWAP=ID1
+ ID1=ID2
+ ID2=ISWAP
+ 440 JSPIN=1
+ IF(ID1.EQ.ID2.AND.ID2.EQ.ID3) GO TO 450
+ JSPIN=INT(ranf(0)+PJSPNS)
+ IF(SPINT.AND.IR.EQ.2) JSPIN=0
+ IF(SPINT.AND.IR.EQ.1) JSPIN=1
+
+ 450 IF(JSPIN.EQ.1.OR.ID1.EQ.ID2.OR.ID2.EQ.ID3) GO TO 460
+ DRND=ranf(0)
+ IF(DRND.GT.PJSPNS) GO TO 460
+ ISWAP=ID1
+ ID1=ID2
+ ID2=ISWAP
+ 460 IDHAD=1000*IABS(ID1)+100*IABS(ID2)+10*IABS(ID3)+JSPIN
+ IDHAD=ISIGN(IDHAD,IFL1)
+ 470 IDPARS=IDHAD
+ RETURN
+ END
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ integer FUNCTION IDPARC(IFL01,IFL02,SPINT,IR)
+c
+cinput IFL01 : ID of (anti-)quarks/di-quarks
+cinput IFL02 : ID of (anti-)quarks/di-quarks
+cinput SPINT : flag for spin assignment
+cinput IR : Determines particle spin
+c
+c output : Quark code of the hadron
+c
+C CONSTRUCT MESON FROM QUARK AND ANTIQUARK WITH FLAVORS IFL01,IFL02
+C OR CONSTRUCT BARYON FROM DIQUARK AND QUARK OR ANTIDIQUARK AND
+C ANTIQUARK WITH FLAVORS IFL01,IFL02.
+c THE MESON MULTIPLETT IS CHOSEN ACC. TO SUPPRESSION PARAM'S:
+c parm gives the probability for different meson multiplets according
+c to spin degeneracy and average mass ratios
+c spin-parity 0- : 1- : 0+ : 1+ : 2+ = parm(1):parm(2)...:parm(5)
+c If SPINT=.t., IR will be used to assign particle spin
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+ implicit real*8 (a-h,o-z)
+ implicit integer (i-n)
+
+ LOGICAL SPINT
+ include 'options.f'
+
+ include 'comstr.f'
+
+C
+ IFL1=IFL01
+ IFL2=IFL02
+C CONSTRUCT MESON WITH ACCOUNT FLAVOR MIXING
+ IF(MOD(IFL1,100).EQ.0) GO TO 420
+ IF(MOD(IFL2,100).EQ.0) GO TO 425
+
+c.. choose multiplett by its probability
+ call getbran(parm,1,njspin,dummy,1,njspin,jspin)
+ jspin=jspin-1
+
+ IF(SPINT.AND.IR.EQ.2) JSPIN=0
+ IF(SPINT.AND.IR.EQ.1) JSPIN=1
+ ID1=IFL1
+ ID2=IFL2
+ IF(ID1+ID2.NE.0) GO TO 400
+C
+ ID1=IABS(ID1)
+ IF(ID1.GE.4) GO TO 401
+c.. singlet mixing acc. to mixing angles
+ RND=ranf(0)
+ ID1=INT(PMIX1C(ID1,JSPIN+1)+RND)+INT(PMIX2C(ID1,JSPIN+1)+RND)+1
+ 401 ID2=-ID1
+C
+ 400 IF(IABS(ID1).LE.IABS(ID2)) GO TO 410
+ ISAVE=ID1
+ ID1=ID2
+ ID2=ISAVE
+ 410 IDHAD=ISIGN(100*IABS(ID1)+10*IABS(ID2)+JSPIN,ID1)
+ GO TO 470
+C CONSTRUCT BARYON IDENT
+ 420 ID3=ISIGN(MOD(IFL1/100,10),IFL1)
+ ID2=IFL1/1000
+ ID1=IFL2
+ GO TO 430
+ 425 ID3=ISIGN(MOD(IFL2/100,10),IFL2)
+ ID2=IFL2/1000
+ ID1=IFL1
+ 430 IF(IABS(ID1).LE.IABS(ID2)) GO TO 431
+ ISWAP=ID1
+ ID1=ID2
+ ID2=ISWAP
+ 431 IF(IABS(ID2).LE.IABS(ID3)) GO TO 432
+ ISWAP=ID2
+ ID2=ID3
+ ID3=ISWAP
+ 432 IF(IABS(ID1).LE.IABS(ID2)) GO TO 440
+ ISWAP=ID1
+ ID1=ID2
+ ID2=ISWAP
+ 440 JSPIN=1
+ IF(ID1.EQ.ID2.AND.ID2.EQ.ID3) GO TO 450
+ JSPIN=INT(ranf(0)+PJSPNC)
+ IF(SPINT.AND.IR.EQ.2) JSPIN=0
+ IF(SPINT.AND.IR.EQ.1) JSPIN=1
+ 450 IF(JSPIN.EQ.1.OR.ID1.EQ.ID2.OR.ID2.EQ.ID3) GO TO 460
+ DRND=ranf(0)
+ IF(DRND.GT.PJSPNC) GO TO 460
+ ISWAP=ID1
+ ID1=ID2
+ ID2=ISWAP
+ 460 IDHAD=1000*IABS(ID1)+100*IABS(ID2)+10*IABS(ID3)+JSPIN
+ IDHAD=ISIGN(IDHAD,IFL1)
+ 470 IDPARC=IDHAD
+ RETURN
+ END
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ real*8 FUNCTION AMASS(ID)
+c
+c
+cinput ID : Quark code
+c
+c
+C THIS FUNCTION RETURNS THE MASS OF THE PARTICLE WITH
+C IDENT CODE ID. (QUARK-BASED IDENT CODE)
+c
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+ implicit real*8 (a-h,o-z)
+ implicit integer (i-n)
+ include 'comres.f'
+ include 'comstr.f'
+
+ real*8 mmin,mmax,m0,mminit, massit, widit
+ integer isoit
+ dimension amq(4)
+ include 'options.f'
+
+c.. quark masses (u,d,s,c)
+ DATA AMq/.15,.15,.45,1.6/
+
+c fraction of baryonresonances
+ bresfrac=ctparam(11)
+
+ CALL FLAVOR(ID,IFL1,IFL2,IFL3,JSPIN)
+ idabs=iabs(id)
+
+c get quark masses
+ if (idabs.le.4) then
+ amass=amq(idabs)
+ return
+ endif
+c get diquark masses
+ IF(ID.NE.0.AND.MOD(ID,100).EQ.0) then
+ AMASS=AMq(IABS(IFL1))+AMq(IABS(IFL2))
+ return
+ endif
+
+c get hadron masses
+
+c get baryon masses
+c (anti-)nucleon ?
+ if ((idabs.eq.1120).or.(idabs.eq.1220)) then
+ if (ranf(0).lt.bresfrac)then
+c.. N*
+ amass=getmass(mresmax,1)
+ return
+ else
+c.. N
+ amass=0.938
+ return
+ endif
+ endif
+c (anti-)delta ?
+ if ((idabs.eq.1111).or.(idabs.eq.1121)
+ & .or.(idabs.eq.1221).or.(idabs.eq.2221)) then
+ if (ranf(0).lt.bresfrac)then
+c.. D*
+ amass=getmass(mresmax,2)
+ return
+ else
+c.. Delta(1232)
+ m0=massit(mindel)
+ w0=widit(mindel)
+c get meson mass accord. to breit wigner distr.
+ mmin=mminit(mindel)
+ mmax=m0+3d0*w0
+cdh call getmas(m0,w0,mindel,isoit(mindel),mmin,mmax,-1,amass)
+ call getmas(m0,w0,mindel,isoit(mindel),mmin,mmax,-1.d0,amass)
+ return
+ endif
+ endif
+c (other baryons)
+ if(idabs-1000.ge.0) then
+ call id2ityp(id,0.d0,itypin,iz2)
+c..check range and avoid double counting for explicitely treated resonances
+ if ((abs(itypin).ge.minlam.and.abs(itypin).le.maxcas).and.
+ & (idabs.ne.1231.and.idabs.ne.1131.and.idabs.ne.2231.and.
+ & idabs.ne.1331.and.idabs.ne.2331).and.
+ & (ctoption(31).eq.1)) then
+c.. generate also non-groundstate ityps for strange baryons
+ call probitypres(itypin,ityp)
+ else
+ ityp=itypin
+ endif
+ amass=massit(iabs(ityp))
+ return
+ endif
+
+c mesons
+ if(idabs.le.330+njspin-1) then
+ call id2ityp(id,0.d0,ityp,iz2)
+ m0=massit(iabs(ityp))
+ w0=widit(iabs(ityp))
+c get meson mass accord. to breit wigner distr.
+ mmin=max(mminit(iabs(ityp)),m0-3d0*w0)
+ mmax=m0+3d0*w0
+cdh call getmas(m0,w0,ityp,iz2,mmin,mmax,-1,amass)
+ call getmas(m0,w0,ityp,iz2,mmin,mmax,-1.d0,amass)
+ return
+ endif
+ write(6,*)'! amass: no mass for part.id:',id
+ return
+ END
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ real*8 FUNCTION DBLPCM(A,B,C)
+c
+cinput A : Mass of particle A
+cinput B : Mass of particle B
+cinput C : Mass of particle C
+c
+c
+c In the rest frame of a particle of mass A, decaying into particles
+c of masses B and C, {\tt dblpcm} returns the momenta of the outgoing
+c particles.
+c
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+ implicit real*8 (a-h,o-z)
+ implicit integer (i-n)
+
+ DA=A
+ DB=B
+ DC=C
+ DVAL=(DA**2-DB**2-DC**2)**2-(2.D0*DB*DC)**2
+ DBLPCM=0.
+ IF(DVAL.GT.0.D0)DBLPCM=DSQRT(DVAL)/(2.D0*DA)
+ return
+ END
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ subroutine ityp2id(ityp,iz2,ifa,ifb)
+c
+cinput ityp : UrQMD particle ID
+cinput iz2 : UrQMD $2\cdot I_3$
+c
+coutput ifa : quarkcode (diquark)
+coutput ifb : quarkcode (quark)
+c
+c returns quark id from uqmd-ityp and isospin z-component (times 2)
+c
+c quark ids are: 1 up, 2 down, 3 strange, 4 charm
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+ implicit none
+ include 'comres.f'
+ integer itypabs,ityp,iz2,ifa,ifb,sf
+ integer t3,if(3)
+ itypabs=iabs(ityp)
+ t3=iz2*isign(1,ityp)
+
+c nucleons ?
+ if (itypabs.lt.minmes) then
+ sf=strres(itypabs)
+c uuu
+ if(t3.eq.3) then
+ if(1)=1
+ if(2)=1
+ if(3)=1
+ call mquarks(if,ifa,ifb)
+ ifa=ifa*isign(1,ityp)
+ ifb=ifb*isign(1,ityp)
+ return
+ endif
+c uus
+ if(t3.eq.2) then
+ if(1)=1
+ if(2)=1
+ if(3)=3
+ call mquarks(if,ifa,ifb)
+ ifa=ifa*isign(1,ityp)
+ ifb=ifb*isign(1,ityp)
+ return
+ endif
+c uud
+ if((t3.eq.1).and.(sf.eq.0)) then
+ if(1)=1
+ if(2)=1
+ if(3)=2
+ call mquarks(if,ifa,ifb)
+ ifa=ifa*isign(1,ityp)
+ ifb=ifb*isign(1,ityp)
+ return
+ endif
+c uss
+ if((t3.eq.1).and.(sf.eq.2)) then
+ if(1)=1
+ if(2)=3
+ if(3)=3
+ call mquarks(if,ifa,ifb)
+ ifa=ifa*isign(1,ityp)
+ ifb=ifb*isign(1,ityp)
+ return
+ endif
+c uds
+ if((t3.eq.0).and.(sf.eq.1)) then
+ if(1)=1
+ if(2)=2
+ if(3)=3
+ call mquarks(if,ifa,ifb)
+ ifa=ifa*isign(1,ityp)
+ ifb=ifb*isign(1,ityp)
+ return
+ endif
+c sss
+ if((t3.eq.0).and.(sf.eq.3)) then
+ if(1)=3
+ if(2)=3
+ if(3)=3
+ call mquarks(if,ifa,ifb)
+ ifa=ifa*isign(1,ityp)
+ ifb=ifb*isign(1,ityp)
+ return
+ endif
+c udd
+ if((t3.eq.-1).and.(sf.eq.0)) then
+ if(1)=1
+ if(2)=2
+ if(3)=2
+ call mquarks(if,ifa,ifb)
+ ifa=ifa*isign(1,ityp)
+ ifb=ifb*isign(1,ityp)
+ return
+ endif
+c dss
+ if((t3.eq.-1).and.(sf.eq.2)) then
+ if(1)=2
+ if(2)=3
+ if(3)=3
+ call mquarks(if,ifa,ifb)
+ ifa=ifa*isign(1,ityp)
+ ifb=ifb*isign(1,ityp)
+ return
+ endif
+c dds
+ if (t3.eq.-2) then
+ if(1)=2
+ if(2)=2
+ if(3)=3
+ call mquarks(if,ifa,ifb)
+ ifa=ifa*isign(1,ityp)
+ ifb=ifb*isign(1,ityp)
+ return
+ endif
+c ddd
+ if (t3.eq.-3) then
+ if(1)=2
+ if(2)=2
+ if(3)=2
+ call mquarks(if,ifa,ifb)
+ ifa=ifa*isign(1,ityp)
+ ifb=ifb*isign(1,ityp)
+ return
+ endif
+
+ endif
+c-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
+c bosons
+ if (itypabs.ge.minmes) then
+ sf=strmes(itypabs)
+c d ubar
+ if(t3.eq.-2) then
+ ifa=2
+ ifb=-1
+ return
+ endif
+c d sbar
+ if((t3.eq.-1).and.(sf*isign(1,ityp).eq.-1)) then
+ ifa=2
+ ifb=-3
+ return
+ endif
+c s ubar
+ if((t3.eq.-1).and.(sf*isign(1,ityp).eq.+1)) then
+ ifa=3
+ ifb=-2
+ return
+ endif
+c q qbar
+ if(t3.eq.0) then
+c u ubar
+c all neutral triplet states:
+ if ((itypabs.eq.minmes+1) .or. !pi0
+ & (itypabs.eq.minmes+4) .or.
+ & (itypabs.eq.minmes+11) .or.
+ & (itypabs.eq.minmes+14) .or.
+ & (itypabs.eq.minmes+18) .or.
+ & (itypabs.eq.minmes+22) .or.
+ & (itypabs.eq.minmes+26) .or.
+ & (itypabs.eq.minmes+30) .or.
+c the gamma gets also a quark content
+ & (itypabs.eq.minmes)) then
+ ifa=1
+ ifb=-1
+ return
+ endif
+c d dbar
+c light singlet states (generally less strange quark content)
+ if ((itypabs.eq.minmes+2) .or. !eta
+ & (itypabs.eq.minmes+3) .or.
+ & (itypabs.eq.minmes+5) .or.
+ & (itypabs.eq.minmes+15) .or.
+ & (itypabs.eq.minmes+19) .or.
+ & (itypabs.eq.minmes+23) .or.
+ & (itypabs.eq.minmes+27) .or.
+ & (itypabs.eq.minmes+31)) then
+ ifa=2
+ ifb=-2
+ return
+ endif
+c s sbar
+ if ((itypabs.eq.minmes+7) .or. !eta' (958)
+ & (itypabs.eq.minmes+9) .or. !phi (1020)
+ & (itypabs.eq.minmes+12) .or. !f_0 (980)
+ & (itypabs.eq.minmes+16) .or. !f_1 (1510)
+ & (itypabs.eq.minmes+20) .or. !f_2'(1525)
+ & (itypabs.eq.minmes+24) .or. !f_2'(1525)
+ & (itypabs.eq.minmes+28) .or. !f_2'(1525)
+ & (itypabs.eq.minmes+32))then
+ ifa=3
+ ifb=-3
+ return
+ endif
+ endif
+c u sbar
+ if((t3.eq.1).and.(sf*isign(1,ityp).eq.-1)) then
+ ifa=1
+ ifb=-3
+ return
+ endif
+c s dbar
+ if((t3.eq.1).and.(sf*isign(1,ityp).eq.+1)) then
+ ifa=3
+ ifb=-1
+ return
+ endif
+c u dbar
+ if(t3.eq.2) then
+ ifa=1
+ ifb=-2
+ return
+ endif
+ endif
+
+c in any other case we will do a mesonic string
+c.. and a warning !
+ctp060926 write(*,*)'! ityp2id: ityp',ityp,',iz2',iz2,
+ctp060926 & ' can not be converted into id. Please check.'
+ ifa=1
+ ifb=-1
+ RETURN
+ end
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ subroutine mquarks(if,ifa,ifb)
+c
+cinput if : single quarks (array)
+c
+coutput ifa : diquark
+coutput ifb : quark
+c
+c this routine adds randomly the single quarks of the
+c baryon to become a diquark and a quark.
+c
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+ implicit none
+
+ include 'options.f'
+
+ real*8 ranf
+ integer if(0:2),ifa,ifb,ir
+
+ integer i,prod,inons
+
+
+ ir=int(3.*ranf(0))
+
+ ifa=1000*if(ir)+100*if(mod(ir+1,3))
+ ifb=if(mod(ir+2,3))
+c.. check if heavy quark clusters are switched off (cto 37=0)
+ if (CTOption(37).eq.0) return
+
+c.. not switched off -> clusters strange quarks to
+c.. diquark molecule, i.e. keep ss-diquark together
+c. are there 2 strange quarks
+ prod=if(0)*if(1)*if(2)
+ if (prod.eq.9.or.prod.eq.18.or.prod.eq.27) then
+c. find the non-strange quark inons
+ inons=0
+ do i=0,2
+ if(if(i).lt.3) inons=i
+ enddo
+ ifb=if(inons)
+ ifa=1000*if(mod(inons+1,3))+100*if(mod(inons+2,3))
+ endif
+ return
+ end
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ subroutine id2ityp(id,mass,it,iz)
+c
+cinput id : quarkcode
+cinput mass : mass of resonance
+c
+coutput: it : UrQMD particle ID
+coutput: iz : $2\cdot I_3$ of particle
+c
+c returns UrQMD ID ({\tt it}) and isospin z-component (times 2) ({\tt IZ})
+c from quark id
+c
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+ implicit none
+ include 'comres.f'
+ include 'options.f'
+ integer IT,IZ,id,idabs,i,j,k,jspin,idloc,whichres
+ real*8 mass,pardelt,mminit,dm,dmold,massit
+ integer iit,irun
+
+c.. extract quark id's and spin
+ IDABS=IABS(ID)
+ I=IDABS/1000
+ J=MOD(IDABS/100,10)
+ K=MOD(IDABS/10,10)
+ JSPIN=MOD(IDABS,10)
+
+c single diquarks are not popular in urqmd:
+ IF(ID.NE.0.AND.MOD(ID,100).EQ.0) GO TO 222
+c single quarks are not popular in urqmd:
+ IF(J.EQ.0) GO TO 222
+
+c mesons:
+ if(I.EQ.0) then
+c calculate isospin from quark content:
+ IZ=0
+ if(j.lt.3) IZ=3-2*j
+ if(k.lt.3) IZ=IZ+(2*k-3)
+ IZ=isign(1,id)*IZ
+
+ idloc=idabs-jspin
+ if((idloc.eq.110).or.(idloc.eq.120))then
+c..triplett (e.g. pion)
+ IT= mlt2it(jspin*4+1) ! minmes+1
+ return
+ else if(idloc.eq.220)then
+c..1st singlett (e.g. eta)
+ IT= mlt2it(jspin*4+3) !minmes+2
+ return
+ else if(idloc.eq.130.or.idloc.eq.230)then
+c..strange doublett (e.g. (anti-)kaon)
+ IT=isign(mlt2it(jspin*4+2),id)
+ return
+ else if(idloc.eq.330)then
+c..2nd singlett (e.g. eta')
+ IT=mlt2it(jspin*4+4) !minmes+7
+ return
+ else
+ goto 222
+ endif
+
+ else
+c.. baryons:
+
+c calculate isospin from quark content:
+ IZ=0
+ if(i.lt.3) IZ=3-2*i
+ if(j.lt.3) IZ=IZ+3-2*j
+ if(k.lt.3) IZ=IZ+3-2*k
+ IZ=isign(1,id)*IZ
+c spin 1/2 baryons (all nucleon-resonances are treated here!)
+ if(jspin.eq.0)then
+c (anti-)nucleons and resonances
+ if(idabs.eq.1120.or.idabs.eq.1220)then
+c mass below parnuc -> nucleon (ground state), mass above parnuc ->N*
+ if(mass.lt.mminit(minnuc+1))then
+ IT=isign(minnuc,id)
+ return
+ else
+ IT=isign(whichres(dble(mass),1),id)
+ return
+ endif
+ else if(idabs.eq.2130)then
+c lambda
+ iit=minlam
+ if (mass.gt.1d0)then
+ dmold=1d30
+ do irun = minlam,maxlam
+ dm=abs(massit(irun)-mass)
+ if (dm.le.dmold)then
+ dmold=dm
+ iit=irun
+ end if
+ end do
+ end if
+ IT=isign(iit,id)
+ return
+ else if(idabs.eq.1230.or.idabs.eq.1130.or.idabs.eq.2230)then
+c sigma
+ iit=minsig
+ if (mass.gt.1d0)then
+ dmold=1d30
+ do irun = minsig,maxsig
+ dm=abs(massit(irun)-mass)
+ if (dm.le.dmold)then
+ dmold=dm
+ iit=irun
+ end if
+ end do
+ end if
+ IT=isign(iit,id)
+ return
+ else if(idabs.eq.1330.or.idabs.eq.2330)then
+c cascade
+ iit=mincas
+ if (mass.gt.1d0)then
+ dmold=1d30
+ do irun = mincas,maxcas
+ dm=abs(massit(irun)-mass)
+ if (dm.le.dmold)then
+ dmold=dm
+ iit=irun
+ end if
+ end do
+ endif
+ IT=isign(iit,id)
+ return
+ else
+ goto 222
+ endif
+c spin 3/2 baryons (all delta-resonances are treated here!)
+ else if(jspin.eq.1)then
+ if(idabs.eq.1111.or.idabs.eq.1121.or.
+ & idabs.eq.1221.or.idabs.eq.2221)then
+c if mass below pardelt -> Delta1232, otherwise: Delta-resonance
+ pardelt=1.45
+ if(mass.lt.pardelt)then
+c delta 1232
+ IT=isign(whichres(dble(mass),0),id)
+ return
+ else
+c delta resonance
+ IT=isign(whichres(dble(mass),2),id)
+ return
+ endif
+ else if(idabs.eq.1231.or.idabs.eq.1131.or.idabs.eq.2231)then
+c sigma*
+ IT=isign(minsig+1,id)
+ return
+ else if(idabs.eq.1331.or.idabs.eq.2331)then
+c cascade*
+ IT=isign(mincas+1,id)
+ return
+ else if(idabs.eq.3331)then
+c omega
+ IT=isign(minome,id)
+ return
+ else
+ goto 222
+ endif
+c higher spin baryons include here:
+
+ else
+ goto 222
+ endif
+ endif
+
+ 222 continue
+ctp060926 write(6,*)'! ID=',id,' can not be converted into ityp'
+ctp060926 write(6,*)'I=',i,'J=',j,'K=',k,'spin=',jspin
+ RETURN
+ END
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ subroutine probitypres(itypin,itypout)
+c
+cinput itypin : ityp of groundstate
+c
+coutput: itypout : ityp of groundstate plus resonances
+c
+c returns a new ityp which also includes resonce ityps, this is
+c necessary to include hyperon resonces as long as no proper getmass
+c for hyperons existst.
+c the probabilities are chooses according to a exp(delta m/b) distribution.
+c
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+ implicit none
+ include 'comres.f'
+
+ integer itypin,itypout,ss,i,itypinn
+ real*8 prob(1:200),probres,norm,deltam,massit
+
+ ss=itypin/abs(itypin)
+ itypinn=abs(itypin)
+
+c.. the lambda
+ if (itypinn.ge.minlam.and.itypinn.le.maxlam)then
+c get probabilities and norm
+ norm=0d0
+ do i=minlam+1,maxlam
+ deltam=abs(massit(i)-massit(minlam))
+ prob(i)=probres(deltam,massit(minlam),i)
+ norm=norm+prob(i)
+ end do
+ do i=minlam+1,maxlam
+ prob(i)=prob(i)/norm
+ end do
+ call findityp(prob,itypout,minlam+1,maxlam)
+ itypout=itypout*ss
+ return
+ end if
+
+c.. the sigma
+ if (itypinn.ge.minsig.and.itypinn.le.maxsig)then
+c get probabilities and norm
+ norm=0d0
+ do i=minsig+1,maxsig
+ deltam=abs(massit(i)-massit(minsig))
+ prob(i)=probres(deltam,massit(minsig),i)
+c... do not generate masses for minsig+1 they are treated ecplicitely
+ if (i.eq.minsig+1) prob(i)=0d0
+ norm=norm+prob(i)
+ end do
+ do i=minsig+1,maxsig
+ prob(i)=prob(i)/norm
+ end do
+ call findityp(prob,itypout,minsig+1,maxsig)
+ itypout=itypout*ss
+ return
+ end if
+
+c.. the cascades
+ if (itypinn.ge.mincas.and.itypinn.le.maxcas)then
+c get probabilities and norm
+ norm=0d0
+ do i=mincas+1,maxcas
+ deltam=abs(massit(i)-massit(mincas))
+ prob(i)=probres(deltam,massit(mincas),i)
+c... do not generate masses for mincas+1 they are treated ecplicitely
+ if (i.eq.mincas+1) prob(i)=0d0
+ norm=norm+prob(i)
+ end do
+ do i=mincas+1,maxcas
+ prob(i)=prob(i)/norm
+ end do
+ call findityp(prob,itypout,mincas+1,maxcas)
+ itypout=itypout*ss
+ return
+ end if
+ write(*,*)'itypin, itypout',itypin,itypout
+ stop 'Error in probitypres!'
+ end
+
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ real*8 function probres(dm,minmass,it)
+c
+cinput dm : mass difference to groundstate
+cinput minmass : mass of groundstate
+cinput it : ityp
+c
+coutput: probres: unnormalized probability for this state
+c
+c returns probabilty for a higher mass state according to
+c exponential distribution with degeneracy
+c
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+ implicit none
+ real*8 dm,minmass,j,g,T
+ integer it, getspin
+
+c.. assume temperature T=170 MeV (from statistical model, e.g. becattini,heinz)
+ T=0.170d0
+
+c.. get spin*2
+ j=1d0*getspin(it,1)
+
+ if (j.lt.0) then
+c.. take spin into account via J= m^2 and deg. g=2j+1 (regge theory)
+ j=2d0*(minmass+dm)**2
+ end if
+
+ g=(j+1d0)
+
+ probres=g*exp(-(dm/T))
+ return
+ end
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ subroutine findityp (p,it,mini,maxi)
+c
+cinput p : array with normalized probabilities
+cinput mini : lowest index
+cinput maxi : largest index
+c
+coutput: it: ityp according to probability
+c
+c returns a new ityp according to probabilties defined in p
+c
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+ implicit none
+ real*8 p(1:200),y,ranf
+ integer it,mini,maxi,ix
+
+ it=mini
+ ix=0
+ y=0d0
+
+ 1 continue
+ ix=int(mini+int((maxi-mini+1)*ranf(0)))
+ y=ranf(0)
+ if (y.lt.p(ix)) then
+ it=ix
+ return
+ end if
+ goto 1
+ end
+
+C---------------------------------------------------------------------------
+C THE END
diff --git a/Processes/UrQMD/tabinit.f b/Processes/UrQMD/tabinit.f
new file mode 100644
index 0000000000000000000000000000000000000000..5032e1c8ba87a88d7dbe4c7e49ebd03c768c3a96
--- /dev/null
+++ b/Processes/UrQMD/tabinit.f
@@ -0,0 +1,527 @@
+c $Id: tabinit.f,v 1.14 2003/05/02 13:14:46 weber Exp $
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ subroutine loadwtab (io)
+c
+c Revision : 1.0
+c
+coutput : information in common-block comwid.f
+c
+c load the tabulated branching ratios from disk
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+ implicit none
+
+ include 'comres.f'
+ include 'comwid.f'
+
+ integer ios, nsp, io, ver!, i
+c character*35 pwdcmd
+ character*10 deftab
+ character*8 defexe
+ logical b
+
+c set the defaultname of the file, containing the table
+ parameter (deftab='tables.dat', defexe='uqmd.exe')
+
+ b=io.eq.1
+
+c get the name of the table from the environment variable
+ call getenv('URQMD13_TAB',tabname)
+c if it is empty, use the default name
+ if (tabname(1:4).eq.' ') then
+ tabname=deftab
+ endif
+
+ if(b)write (6,*) 'Looking for the tabulated decay width...'
+ & ,tabname
+c open the table
+ open (unit=75,iostat=ios,file=tabname,form='unformatted',
+ . status='old')
+c if it fails ...
+ if (ios.ne.0) then
+c close the file handle
+c close (unit=75, status='delete')
+ if(b)write (6,*) 'No file:',tabname,'in this directory'
+c get the full path of the executable, ...
+c call getenv('_',pwdcmd)
+c write (6,*) 'pwd:',pwdcmd
+ write (6,*) 'tabname:',tabname
+c extract the path
+c i=max(index(pwdcmd,defexe),2)
+c write (tabname,*) pwdcmd (1:i-1),deftab
+c tabname=tabname(2:)
+ if(b)write (6,*) 'Looking for ',tabname,'...'
+c and look for a table in the directory of the executable
+ open (unit=75,iostat=ios,file=tabname,
+ . form='unformatted',status='old')
+ endif
+c if the last 'open' command succeeds read the file
+ if (ios.eq.0) then
+ if(b)write (6,*) 'O.K.'
+ if(b)write (6,*) 'reading...'
+c read all tables
+ read (unit=75, iostat=ios) ver, nsp, tabx, fbtaby, pbtaby,
+ . fmtaby, pmtaby, bwbarnorm, bwmesnorm,
+ . tabxnd, frrtaby
+c caution! the file is unformatted, therefor it is system dependent!
+ if(b)write (6,*) 'version=',ver
+c if no errors occur ...
+ if (ios.eq.0) then
+ if(b)write (6,*) 'O.K.'
+ wtabflg=3
+c check, if the version number is correct
+ if (ver.eq.tabver) then
+ if(b)write (6,*) 'tabver=',ver,' O.K.'
+ else
+ write (6,*) 'wrong table!'
+ write (6,*) 'tabver should be',tabver,',instead of',ver
+ wtabflg=0
+ endif
+c check, if the table has the correct 'widnsp'
+ if (nsp.eq.widnsp) then
+ if(b)write (6,*) 'widnsp=',nsp,' O.K.'
+ else
+ write (6,*) 'wrong table!'
+ write (6,*) 'widnsp should be',widnsp,', instead of',nsp
+ wtabflg=0
+ endif
+c if table is O.K. close file
+ if (wtabflg.eq.3) then
+ close (unit=75, status='keep')
+c otherwise ...
+ else
+c delete the present table
+ close (unit=75, status='delete')
+ tabname=deftab
+c and calculate a new one
+ call mkwtab
+ endif
+c in case of read errors ...
+ else
+c delete the present table
+ close (unit=75, status='delete')
+ write (6,*) 'Error while reading ',tabname
+ tabname=deftab
+c and calculate a new one
+ call mkwtab
+ endif
+c in any other case ...
+ else
+ctp tabname=deftab
+c calculate an new table
+ call mkwtab
+ endif
+
+ return
+ end
+
+
+
+
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ subroutine savewtab
+c
+c Revision : 1.0
+c
+c save the tabulated branching ratios to disk
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+ implicit none
+
+ include 'comres.f'
+ include 'comwid.f'
+
+ integer ios
+
+ write (6,*) 'Writing new table...'
+
+c try to generate a new file
+ open (unit=75,iostat=ios,file=tabname,form='unformatted',
+ . status='new')
+c if it succedds ...
+ if (ios.eq.0) then
+c write the tables into the file
+ write (unit=75, iostat=ios) tabver, widnsp, tabx, fbtaby,
+ . pbtaby, fmtaby, pmtaby, bwbarnorm, bwmesnorm,
+ . tabxnd, frrtaby
+ if (ios.eq.0) write (6,*) 'O.K.'
+c otherwise complain
+ else
+ write (6,*) 'Error: ',tabname,'exists!'
+ endif
+c close the file
+ close (unit=75, status='keep')
+
+ return
+ end
+
+
+
+
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ subroutine mkwtab
+c
+c Revision : 1.0
+c
+coutput : information in common-block comwid.f
+c
+c tabulate the mass dependent branching ratios
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+ implicit none
+
+ include 'comres.f'
+ include 'comwid.f'
+
+ real*8 fwidth,m,first,last,delta,abl0,abln,mir,mminit,fbrancx
+ real*8 massit,bran,smass,bwnorm,fppfit
+ integer i,bchan,itp,isoit,cmin,cmax,i1,i2,i3,i4,ii1
+
+ write (6,*) 'Generating table...'
+c this indicates, that all tables are still empty
+ wtabflg=0
+
+c high precision splines from mintab to maxtab1
+c lower precicision between maxtab1 and maxtab2
+
+c now fill the x-values
+c start with 'mintab'
+ first=mintab
+c 66 % of all fixpoints between mintab and maxtab1
+c calculate the steps
+ delta=(maxtab1-mintab)/((widnsp-1d0)*2d0/3d0)
+ if (delta.le.0d0) then
+ write(*,*)'(E) Please allow maxtab1>mintab in comwid'
+ stop
+ endif
+c store the values into 'tabx'
+ do 10 i=1,int(widnsp*2./3.)
+ m=first+(i-1)*delta
+ tabx(i)=m
+ 10 continue
+c 33 % of all fixpoints with larger delta between maxtab1 and maxtab2
+ delta=(maxtab2-maxtab1)/((widnsp-1d0)*1d0/3d0)
+ if (delta.le.0d0) then
+ write(*,*)'(E) Please allow maxtab2>maxtab1 in comwid'
+ stop
+ endif
+c store the values into 'tabx'
+ do 11 i=int(widnsp*2./3.)+1,widnsp
+ m=maxtab1+(i-1-int(widnsp*2./3.))*delta
+ tabx(i)=m
+ 11 continue
+
+c now fill the y-values of the full branching ratios
+
+c these are the first derivatives at the first an the last point
+c of the interpolating function. a value greater than 1E30 signals the
+c 'spline' routine to set the boundary condition for a natural spline
+c with zero second derivative
+ abl0=2D30
+ abln=2D30
+
+c loop over all baryons
+ do 20 itp=minbar,maxbar
+c loop over all x-values
+ do 21 i=1,widnsp
+c store the values ...
+ fbtaby (i,itp,1)=fwidth(itp,isoit(itp),tabx(i))
+ 21 continue
+c calculate the second derivate and store it in 'fbtaby(,,2)'
+ call spline (tabx(1),fbtaby(1,itp,1),widnsp,abl0,abln,
+ . fbtaby(1,itp,2))
+ 20 continue
+ write (6,*) '(1/7) ready.'
+
+c loop over all mesons
+ do 30 itp=minmes,maxmes
+c loop over all x-values
+ do 31 i=1,widnsp
+c store the values ...
+ fmtaby (i,itp,1)=fwidth(itp,isoit(itp),tabx(i))
+ 31 continue
+c calculate the second derivate and store it in 'fmtaby(,,2)'
+ call spline (tabx(1),fmtaby(1,itp,1),widnsp,abl0,abln,
+ . fmtaby(1,itp,2))
+ 30 continue
+ write (6,*) '(2/7) ready.'
+
+c the flag indicates, that now all full widths are tabulated
+ wtabflg=1
+
+c now fill the y-values of the partial branching ratios
+
+c loop over all baryons
+ do 40 itp=minbar,maxbar
+c get the mass of this particle
+ mir=massit(itp)
+c get the range of possible decay channels
+ call brange (itp, cmin, cmax)
+c check, if there are any decay channels
+ if (cmax.gt.0) then
+c loop over all decay channels
+ do 41 bchan=cmin,cmax
+c now get the outgoing particles 'i1' and 'i2' for the channel 'j'
+c 'bran' is the mass independent branching ratio (tabulated in blockres)
+c 'bflag' indicates, if 'i1', 'i2' or both are broad
+ call b3type (itp,bchan,bran,i1,i2,i3,i4)
+c check, if decay is allowed
+
+ smass=mminit(i2)
+ if(i3.ne.0) smass=smass+mminit(i3)
+ if(i4.ne.0) smass=smass+mminit(i4)
+
+ if (bran.gt.1d-9.and.mir.gt.mminit(i1)+smass) then
+c loop over all x-values
+ do 42 i=1,widnsp
+c store the values
+
+cdh
+* write(*,*)'mkwtab: i,itp,bchan=',i,itp,bchan
+* write(*,*)'mkwtab: isoit,tabx,bran,i1,i2,i3,i4=',
+* & isoit(itp),tabx(i),bran,i1,i2,i3,i4
+cdh
+
+ pbtaby(i,1,itp,bchan)=
+ . fbrancx (bchan,itp,isoit(itp),tabx(i),
+ . bran,i1,i2,i3,i4)
+ 42 continue
+c calculate the second derivate and store it in 'pbtaby(,2,,)'
+ call spline (tabx(1),pbtaby(1,1,itp,bchan),widnsp,
+ . abl0,abln,pbtaby(1,2,itp,bchan))
+ end if
+ 41 continue
+ end if
+ 40 continue
+ write (6,*) '(3/7) ready.'
+
+c loop over all mesons
+ do 50 itp=minmes,maxmes
+c get the mass of this particle
+ mir=massit(itp)
+c get the range of possible decay channels
+ call brange (itp, cmin, cmax)
+c check, if there are any decay channels
+ if (cmax.gt.0) then
+ do 51 bchan=cmin,cmax
+c now get the outgoing particles 'i1' and 'i2' for the channel 'j'
+c 'bran' is the mass independent branching ratio (tabulated in blockres)
+c 'bflag' indicates, if 'i1', 'i2' or both are broad
+ call b3type(itp,bchan,bran,i1,i2,i3,i4)
+c!!!
+ smass=mminit(i2)
+ if(i3.ne.0) smass=smass+mminit(i3)
+ if(i4.ne.0) smass=smass+mminit(i4)
+
+ if (bran.gt.1d-9.and.mir.gt.mminit(i1)+smass) then
+c loop over all x-values
+ do 52 i=1,widnsp
+ pmtaby(i,1,itp,bchan)=
+ . fbrancx (bchan,itp,isoit(itp),tabx(i),
+ . bran,i1,i2,i3,i4)
+ 52 continue
+c calculate the second derivate and store it in 'pmtaby(,2,,)'
+ call spline (tabx(1),pmtaby(1,1,itp,bchan),widnsp,
+ . abl0,abln,pmtaby(1,2,itp,bchan))
+ end if
+ 51 continue
+ end if
+ 50 continue
+
+ write (6,*) '(4/7) ready.'
+
+
+c calculate the norm integral of the Breit-Wigner functions
+c with mass dependent widths
+
+c..baryons
+ do 60 i=minbar,maxbar
+ bwbarnorm(i)=bwnorm(i)
+60 continue
+ write (6,*) '(5/7) ready.'
+
+c.. mesons
+ do 61 i=minmes,maxmes
+ bwmesnorm(i)=bwnorm(i)
+61 continue
+ write (6,*) '(6/7) ready.'
+
+c now all branching ratios and BW-integrals are tabulated
+ wtabflg=2
+
+ce tabulate fppfit
+c fill the x-values
+c range of tabulated cross sections
+ first=2d0*massit(nucleon)+massit(pimeson)
+ last=maxtab1
+c calculate the steps
+c the energies are weighted quadratically
+ delta=(last-first)/((widnsp-1)*2./3.)**2
+c store the values into 'tabx'
+c 66 % of all fixpoints between mintab and maxtab1
+ do 69 i=1,int(widnsp*2./3.)
+ m=first+(i-1)**2*delta
+ tabxnd(i)=m
+ 69 continue
+c 33 % of all fixpoints with larger, constant delta between maxtab1 and maxtab2
+ delta=(maxtab2-last)/((widnsp-1)*1./3.)
+ do 70 i=int(widnsp*2./3.)+1,widnsp
+ m=maxtab1+(i-1-int(widnsp*2./3.))*delta
+ tabxnd(i)=m
+ 70 continue
+
+
+c.. all pp-exit channels
+c loop over first out-particle N & D
+ do 81 ii1=1,2
+ if(ii1.eq.1)i1=minnuc
+ if(ii1.eq.2)i1=mindel
+c loop over second out-particle N(1440)..maxdel
+ do 82 i2=minnuc+1,maxdel
+c loop over all x-values
+ do 83 i=1,widnsp
+c store the values ...
+ frrtaby(i,1,ii1,i2)=fppfit(99,tabxnd(i),i1,i2)
+83 continue
+c calculate the second derivate and store it in 'frrtaby(,,2)'
+ call spline (tabxnd(1),frrtaby(1,1,ii1,i2),widnsp,abl0,abln,
+ . frrtaby(1,2,ii1,i2))
+82 continue
+81 continue
+
+
+ write (6,*) '(7/7) ready.'
+
+c pp cross sections are now tabulated
+ wtabflg=3
+
+c save the table on disk
+ call savewtab
+
+ return
+ end
+
+
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ real*8 function splint (xa,ya,y2a,n,x)
+c
+c Unit : general infrastructure
+c Author : (C) Copr. 1986-92 Numerical Recipes Software
+c Date : 03/07/96
+c Revision : 1.1
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+ implicit none
+
+ include 'comres.f'
+ include 'comwid.f'
+
+ integer n
+ integer k,khi,klo
+ real*8 x,y,xa(n),y2a(n),ya(n)
+ real*8 a,b,h
+
+ save khi,klo
+ data klo/1/
+ data khi/2/
+
+ if(khi.le.n.and.x.ge.xa(klo).and.x.lt.xa(khi))then
+ elseif(khi+1.le.n.and.x.ge.xa(klo+1).and.x.lt.xa(khi+1))then
+ klo=klo+1
+ khi=khi+1
+ else
+
+ klo=1
+ khi=n
+1 if (khi-klo.gt.1) then
+ k=(khi+klo)/2d0
+ if(xa(k).gt.x)then
+ khi=k
+ else
+ klo=k
+ endif
+ goto 1
+ endif
+ endif
+
+ h=xa(khi)-xa(klo)
+ if (h.eq.0.) pause 'bad xa input in splint'
+ a=(xa(khi)-x)/h
+ b=(x-xa(klo))/h
+ y=a*ya(klo)+b*ya(khi)+((a*a*a-a)*y2a(klo)+
+ . (b*b*b-b)*y2a(khi))*(h*h)/6d0
+ splint=y
+
+ return
+ end
+
+
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ real*8 function splintth (xa,ya,y2a,n,x,th)
+c
+c Unit : general infrastructure
+c Author : (C) Copr. 1986-92 Numerical Recipes Software
+c modified my H. Weber
+c Date : 03/07/96
+c Revision : 1.1
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+c split routine with nice threshold behaviour for cross sections
+c
+
+ implicit none
+
+ include 'comres.f'
+ include 'comwid.f'
+
+ integer n
+ integer k,khi,klo
+ real*8 x,y,xa(n),y2a(n),ya(n)
+ real*8 a,b,h,th
+
+ save khi,klo
+ data klo/1/
+ data khi/2/
+
+ if(khi.le.n.and.x.ge.xa(klo).and.x.lt.xa(khi))then
+ elseif(khi+1.le.n.and.x.ge.xa(klo+1).and.x.lt.xa(khi+1))then
+ klo=klo+1
+ khi=khi+1
+ else
+
+ klo=1
+ khi=n
+1 if (khi-klo.gt.1) then
+ k=(khi+klo)/2d0
+ if(xa(k).gt.x)then
+ khi=k
+ else
+ klo=k
+ endif
+ goto 1
+ endif
+ endif
+ h=xa(khi)-xa(klo)
+ if (h.eq.0.) pause 'bad xa input in splint'
+ if (xa(khi).lt.(th+2*h)) then
+c linear approximation close to threshold (within 2h)
+ splintth=ya(khi)*(x-th)/(xa(khi)-th)
+ else
+ a=(xa(khi)-x)/h
+ b=(x-xa(klo))/h
+ y=a*ya(klo)+b*ya(khi)+((a*a*a-a)*y2a(klo)+
+ . (b*b*b-b)*y2a(khi))*(h*h)/6d0
+ splintth=y
+ endif
+
+ return
+ end
diff --git a/Processes/UrQMD/urqmd.f b/Processes/UrQMD/urqmd.f
new file mode 100644
index 0000000000000000000000000000000000000000..e71329318d41a2820e3d62502131f76aab9fc8c5
--- /dev/null
+++ b/Processes/UrQMD/urqmd.f
@@ -0,0 +1,353 @@
+c $Id: urqmd.f,v 1.22 2001/04/06 22:38:54 weber Exp $
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+cdh program UrQMD
+ subroutine UrQMD(iflbmax)
+c
+c Authors : The UrQMD collaboration
+c S.A. Bass, M. Belkacem, M. Bleicher, M. Brandstetter,
+c L. Bravina, C. Ernst, L. Gerland, M. Hofmann,
+c S. Hofmann, J. Konopka, G. Mao, L. Neise, S. Soff,
+c C. Spieles, H. Weber, L.A. Winckelmann, H. Stoecker
+c and W. Greiner
+c
+c Revision: 1.2
+c
+cc contact address:
+cc
+cc urqmd@th.physik.uni-frankfurt.de
+cc
+c
+c This is the main module of {\tt urqmd}. It servers as a connection between
+c the initialization, the propagation (including the real part of the
+c optical potential) and the collision term (imaginary part of the optical
+c potential).
+c
+c iflbmax: flag for retrying interaction after non-interaction
+c 0 = do retry until interaction happens
+c 1 = do not ( propagate particle, retry then)
+c
+C modifications for use in connection with CORSIKA by D. Heck
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+ implicit none
+ include 'coms.f'
+ include 'comres.f'
+ include 'options.f'
+ include 'colltab.f'
+ include 'inputs.f'
+ include 'newpart.f'
+ include 'boxinc.f'
+c
+ integer i,j,k,steps,ii,ocharge,ncharge, mc, mp, noc, it1,it2
+ real*8 sqrts,otime,xdummy,st
+ logical isstable
+ integer stidx,iflbmax
+ real*8 Ekinbar, Ekinmes, ESky2, ESky3, EYuk, ECb, EPau
+ common /energies/ Ekinbar, Ekinmes, ESky2, ESky3, EYuk, ECb, EPau
+ integer cti1sav,cti2sav
+ common/cncc/ncc
+ integer*8 ncc
+
+c
+c numerical/technical initialisation
+c
+cdh call uinit(0)
+cdh call osc_header
+cdh call osc99_header
+c
+c Main program
+c
+ noc=0
+
+ 1 mc=0
+ mp=0
+c
+c loop over all events
+c
+cdh do 10 event=1,nevents
+
+c start event here
+c
+
+c time is the system time at the BEGINNING of every timestep
+ time = 0.0
+
+c initialize random number generator
+c call auto-seed generator only for first event and if no seed was fixed
+cdh if(.not.firstseed.and.(.not.fixedseed)) then
+cdh ranseed=-(1*abs(ranseed))
+cdh call sseed(ranseed)
+cdh else
+cdh firstseed=.false.
+cdh endif
+cdh
+cdh write(6,*)'event# ',event,ranseed
+
+c
+c initialisation of physics quantities
+c
+ call init
+
+c old time if an old fort.14 is used
+ if(CTOption(40).eq.1)time=acttime
+
+c output preparation
+
+c write headers to file
+ call output(13)
+ call output(14)
+ call output(15)
+cdh call output(16)
+cdh if(event.eq.1)call output(17)
+cdh call osc99_event(-1)
+
+
+c for CTOption(4)=1 : output of initialization configuration
+ if(CTOption(4).eq.1)call file14out(0)
+
+c participant/spectator model:
+cdh if(CTOption(28).ne.0) call rmspec(0.5d0*bimp,-(0.5d0*bimp))
+
+c compute time of output
+ otime = outsteps*dtimestep
+
+c reset time step counter
+ steps = 0
+
+c loop over all timesteps
+
+ do 20 steps=1,nsteps
+c store coordinates in arrays with *_t
+c this is needed for MD type propagation
+ if (eos.ne.0) then
+ do 23 j=1,npart
+ r0_t(j) = r0(j)
+ rx_t(j) = rx(j)
+ ry_t(j) = ry(j)
+ rz_t(j) = rz(j)
+ 23 continue
+ end if
+
+c we are at the beginning of the timestep, set current time (acttime)
+ acttime = time
+
+c option for MD without collision term
+ if(CTOption(16).ne.0) goto 103
+
+c Load collision table with next collisions in current timestep
+ call colload
+c check for collisions in time-step, nct = # of collisions in table
+ if (nct.gt.0) then
+
+c entry-point for collision loop in case of full colload after every coll.
+ 101 continue
+ k = 0
+c normal entry-point for collision loop
+ 100 continue
+c get next collision
+ call getnext(k)
+
+c exit collision loop if no collisions are left
+ if (k.eq.0) goto 102
+
+c propagate all particles to next collision time
+c store actual time in acttime, propagation time st=cttime(k)-acttime
+ st=cttime(k)-acttime
+ call cascstep(acttime,st)
+c new actual time (for upcoming collision)
+ acttime = cttime(k)
+
+c perform collision
+
+ if(cti2(k).gt.0.)then
+ if(abs(sqrts(cti1(k),cti2(k))-ctsqrts(k)).gt.1d-3)then
+ write(6,*)' ***(E) wrong collision update (col) ***'
+ write(6,*)cti1(k),cti2(k),
+ & ctsqrts(k),sqrts(cti1(k),cti2(k))
+ endif
+ else if(cti2(k).eq.0.and.
+ & abs(fmass(cti1(k))-ctsqrts(k)).gt.1d-3) then
+ write(6,*)' *** main(W) wrong collision update (decay)'
+ write(6,*)ctag,cti1(k),ityp(cti1(k)),dectime(cti1(k)),
+ & fmass(cti1(k)),ctsqrts(k)
+ endif
+
+ ocharge=charge(cti1(k))
+ if(cti2(k).gt.0) ocharge=ocharge+charge(cti2(k))
+
+c store quantities in local variables for charge conservation check
+ it1= ityp(cti1(k))
+ if(cti2(k).gt.0)it2= ityp(cti2(k))
+
+c increment "dirty" collision counter
+ if(cti2(k).gt.0)then !scatter !scatter
+ mc=mc+1
+ endif
+c perform scattering/decay
+ ncc = ncc+1
+ cti1sav = cti1(k) ! hjd
+ cti2sav = cti2(k) ! hjd
+ call scatter(cti1(k),cti2(k),ctsigtot(k),ctsqrts(k),
+ & ctcolfluc(k))
+
+c
+c update collision table
+c
+c normal update mode
+ if(CTOption(17).eq.0) then
+ if(nexit.eq.0) then
+c new collision partners for pauli-blocked states (nexit=0)
+c hjd1 and cdh
+ if (cti1(k).ne.cti1sav.or.cti2(k).ne.cti2sav) then
+ goto 1
+c cti1(k) = cti1sav !!! hjd1
+c cti2(k) = cti2sav !!! hjd1
+ endif
+c hjd1 and cdh
+ call collupd(cti1(k),1)
+ if(cti2(k).gt.0) call collupd(cti2(k),1)
+ else
+ ncharge=0
+c new collision partners for scattered/produced particles (nexit><0)
+ do 30 i=1,nexit
+c ncharge is used for charge conservation check
+ ncharge=ncharge+charge(inew(i))
+ call collupd(inew(i),1)
+ 30 continue
+
+c charge conservation check
+ if(ocharge.ne.ncharge) then
+ write(6,*)'ch-conservation error coll/dec ',ctag
+ write(6,*)' it1:',it1,' it2:',it2
+ write(6,*)' ch:',ocharge,ncharge
+ write(6,*)'cti1(k),cti2(k),ctsigtot(k),ctsqrts(k)'
+ write(6,*)cti1(k),cti2(k),ctsigtot(k),ctsqrts(k)
+ endif
+ endif
+
+c update collisions for partners of annihilated particles
+ do 55 ii=1,nsav
+ call collupd(ctsav(ii),1)
+ 55 continue
+ nsav=0
+
+ else ! (CTOption(17).ne.0)
+c full collision load
+ call colload
+ endif
+
+ if (CTOption(17).eq.0) goto 100
+ goto 101
+
+c this is the point to jump to after all collisions in the timestep
+c have been taken care of
+ 102 continue
+
+ endif ! (nct.gt.0)
+
+c After all collisions in the timestep are done, propagate to end of
+c the timestep.
+
+c point to jump to in case of MD without collision term
+ 103 continue
+
+c increment timestep
+ time = time+dtimestep
+
+c After all collisions in the timestep are done, propagate to end of
+c the timestep.
+ call cascstep(acttime,time-acttime)
+
+c in case of potential interaction, do MD propagation step
+ if (eos.ne.0) then
+
+c set initial conditions for MD propagation-step
+ do 24 j=1,npart
+ r0(j) = r0_t(j)
+ rx(j) = rx_t(j)
+ ry(j) = ry_t(j)
+ rz(j) = rz_t(j)
+ 24 continue
+
+c now molecular dynamics trajectories
+ call proprk(time,dtimestep)
+
+ end if ! (eos.ne.0)
+
+c perform output if desired
+cdh if(mod(steps,outsteps).eq.0.and.steps.lt.nsteps)then
+cdh if(CTOption(28).eq.2)call spectrans(otime)
+cdh call file14out(steps)
+cdh endif ! output handling
+
+ 20 continue ! time step loop
+
+c
+ acttime=time
+c optional decay of all unstable particles before final output
+c DANGER: pauli-blocked decays are not performed !!!
+ if(CTOption(18).eq.0) then
+c no do-loop is used because npart changes in loop-structure
+ i=0
+ nct=0
+ actcol=0
+c disable Pauli-Blocker for final decays
+ CTOption(10)=1
+c decay loop structure starts here
+ 40 continue
+ i=i+1
+
+c is particle unstable
+ if(dectime(i).lt.1.d30) then
+ 41 continue
+ isstable = .false.
+ do 44 stidx=1,nstable
+ if (ityp(i).eq.stabvec(stidx)) then
+cdh write (6,*) 'no decay of particle ',ityp(i)
+ isstable = .true.
+ endif
+ 44 enddo
+ if (.not.isstable) then
+c perform decay
+ call scatter(i,0,0.d0,fmass(i),xdummy)
+c backtracing if decay-product is unstable itself
+ if(dectime(i).lt.1.d30) goto 41
+ endif
+ endif
+c check next particle
+ if(i.lt.npart) goto 40
+ endif ! final decay
+c final output
+
+cdh if(CTOption(28).eq.2)call spectrans(otime)
+
+ call file13out(nsteps)
+ call file14out(nsteps)
+cdh call file16out
+cdh call osc_event
+cdh call osc99_event(1)
+cdh call osc99_eoe
+
+c print *,"noc",noc,bdist,ctag,bimp
+ mp=mp+npart
+ if(iflbmax.eq.0.and.ctag.eq.0)then
+cdh write(*,*)'(W) No collision in event ',event
+ noc=noc+1
+ if(noc.ge.1000 .and. mod(noc,1000) .eq. 0)then
+ print *,'no collision problem in UrQMD'
+c~ stop
+ endif
+ goto 1
+ endif
+
+ write(*,*) 'iterations =', noc
+
+c end of event loop
+cdh 10 continue
+
+cdh write(6,*)'no. of collisions = ',mc/dble(nevents), ' (per event)'
+cdh write(6,*)'final particles = ',mp/dble(nevents), ' (per event)'
+cdh write(6,*)'empty events : ', noc, ' = ',
+cdh + noc*1d2/dble(nevents), '%'
+ return
+ end
diff --git a/Processes/UrQMD/urqmdInterface.F b/Processes/UrQMD/urqmdInterface.F
index 8eaf1f740aab02052962e8d151c5a84d91bfd784..4fe9c044e447f577559444be28e0798ab3cd678e 100644
--- a/Processes/UrQMD/urqmdInterface.F
+++ b/Processes/UrQMD/urqmdInterface.F
@@ -17,12 +17,12 @@ c Primary initialization for UrQMD 1.31
c-----------------------------------------------------------------------
implicit none
c CONEX includes
-#include "conex.h"
-#include "conex.incnex"
+c~ #include "conex.h"
+c~ #include "conex.incnex"
#ifndef __CXCORSIKA__
- character*500 furqdat
- integer ifurqdat, nfurqdat
- common/urqfname/ furqdat, ifurqdat, nfurqdat
+c~ character*500 furqdat
+c~ integer ifurqdat, nfurqdat
+c~ common/urqfname/ furqdat, ifurqdat, nfurqdat
include 'boxinc.f'
include 'inputs.f'
@@ -44,12 +44,12 @@ c local
character adum
double precision sig_u1,ekdummy
integer iamaxu,idmaxu,iemaxu
- common /cxs_u1/ sig_u1(mxie,mxid,mxia),iamaxu,idmaxu,iemaxu
- double precision xs(3),bim(3)
-c M.R.: bim added to cxs_u2
- common /cxs_u2/ xs,bim
+c~ common /cxs_u1/ sig_u1(mxie,mxid,mxia),iamaxu,idmaxu,iemaxu
+c~ double precision xs(3),bim(3)
+c~ c M.R.: bim added to cxs_u2
+c~ common /cxs_u2/ xs,bim
integer iudebug
- data bim/6.d0,6.d0,7.d0/
+c~ data bim/6.d0,6.d0,7.d0/
integer init
data init/0/
SAVE
@@ -63,11 +63,11 @@ c M.R.: bim added to cxs_u2
C-----------------------------------------------------------------------
- IF ( isx.ge.2 ) THEN
- IUDEBUG = isx-1
- ELSE
- IUDEBUG = 0
- ENDIF
+c~ IF ( isx.ge.2 ) THEN
+c~ IUDEBUG = isx-1
+c~ ELSE
+c~ IUDEBUG = 0
+c~ ENDIF
WRITE (*,*)
$ '############################################################'
@@ -95,9 +95,9 @@ C-----------------------------------------------------------------------
$ '############################################################'
C SET THE 'LARGE' CROSS-SECTIONS FOR ALL 3 TARGET ELEMENTS
- DO I = 1, 3
- XS(I) = 10.D0 * PI * BIM(I)**2
- ENDDO
+c~ DO I = 1, 3
+c~ XS(I) = 10.D0 * PI * BIM(I)**2
+c~ ENDDO
C SET NMAX TO DEFAULT VALUE
call set0
@@ -141,22 +141,22 @@ C SUPPRESS ALL OUTPUT
bf20 = .true.
C SET DEBUG OUTPUT DEPENDING ON CHOSEN DEBUG LEVEL
C SET THE OUTPUT OF UNITS 13, 14, 15 TO THE DEBUG OUTPUT UNIT
- IF ( IUDEBUG .EQ. 1 ) THEN
- bf13 = .true.
- bf14 = .false.
- call uounit(14,IFCK)
- bf15 = .true.
- ELSEIF ( IUDEBUG .EQ. 2 ) THEN
- bf13 = .false.
- call uounit(13,IFCK)
- bf14 = .true.
- bf15 = .true.
- ELSEIF ( IUDEBUG .GT. 2 ) THEN
- bf13 = .true.
- bf14 = .true.
- bf15 = .false.
- call uounit(15,IFCK)
- ENDIF
+c~ IF ( IUDEBUG .EQ. 1 ) THEN
+c~ bf13 = .true.
+c~ bf14 = .false.
+c~ call uounit(14,IFCK)
+c~ bf15 = .true.
+c~ ELSEIF ( IUDEBUG .EQ. 2 ) THEN
+c~ bf13 = .false.
+c~ call uounit(13,IFCK)
+c~ bf14 = .true.
+c~ bf15 = .true.
+c~ ELSEIF ( IUDEBUG .GT. 2 ) THEN
+c~ bf13 = .true.
+c~ bf14 = .true.
+c~ bf15 = .false.
+c~ call uounit(15,IFCK)
+c~ ENDIF
do i = 1, numcto
CTOdc(i) = ' '
enddo
@@ -391,7 +391,7 @@ C INITIALIZES SOME ARRAYS
IF ( CTOption(33) .EQ. 0 .OR. CTOption(9) .EQ. 0 ) THEN
call loadwtab(io)
- IF ( IUDEBUG .GT. 0 ) WRITE(IFCK,*) 'URQINI: AFTER LOADWTAB'
+c~ IF ( IUDEBUG .GT. 0 ) WRITE(IFCK,*) 'URQINI: AFTER LOADWTAB'
ENDIF
C READ URQMD TOTAL CROSS SECTION TABLE
@@ -400,22 +400,22 @@ c ie=1..41 E=10.0**(float(ie)/10-1.0-0.05) (bin-middle)
c id=1..9 p,ap,n,an,pi+,pi-,K+,K-,KS
c ia=1..3 N,O,Ar
c
- if(ifurqdat.eq.1)then
- OPEN(UNIT=76,FILE=furqdat(1:nfurqdat),STATUS='OLD')
- else
- OPEN(UNIT=76,FILE='UrQMD-1.3.1-xs.dat',STATUS='OLD')
- endif
- read(76,*) adum,iamaxu,idmaxu,iemaxu
- do ia=1,iamaxu
- do id=1,idmaxu
- do ie=1,iemaxu
- read(76,*) ekdummy,sig_u1(ie,id,ia)
- enddo
- read(76,*)
- read(76,*)
- enddo
- enddo
- close(76)
+c~ if(ifurqdat.eq.1)then
+c~ OPEN(UNIT=76,FILE=furqdat(1:nfurqdat),STATUS='OLD')
+c~ else
+c~ OPEN(UNIT=76,FILE='UrQMD-1.3.1-xs.dat',STATUS='OLD')
+c~ endif
+c~ read(76,*) adum,iamaxu,idmaxu,iemaxu
+c~ do ia=1,iamaxu
+c~ do id=1,idmaxu
+c~ do ie=1,iemaxu
+c~ read(76,*) ekdummy,sig_u1(ie,id,ia)
+c~ enddo
+c~ read(76,*)
+c~ read(76,*)
+c~ enddo
+c~ enddo
+c~ close(76)
C IN CASE OF CASCADE MODE, THE POTENTIALS NEED NOT BE CALCULATED
@@ -424,7 +424,7 @@ C CALCULATE NORMALIZATION OF RESONANCES DISTRIBUTION...
#endif
- xsegymin=0.25d0
+c~ xsegymin=0.25d0
#ifdef __CXDEBUG__
call utisx2
diff --git a/Processes/UrQMD/whichres.f b/Processes/UrQMD/whichres.f
new file mode 100644
index 0000000000000000000000000000000000000000..bd2e66561b83d894b8b7af609522a7a076e95990
--- /dev/null
+++ b/Processes/UrQMD/whichres.f
@@ -0,0 +1,261 @@
+c $Id: whichres.f,v 1.6 1999/01/18 09:57:18 ernst Exp $
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ integer function whichres(m,class)
+c
+c Revision : 1.0
+cinput m : Mass of the resonance
+cinput class : class of resonance: see subr. getrange
+coutput whichres : itype of the resonance
+c
+c DETERMINES ID OF A RESONANCE WITH MASS M ACCORDING TO THE GLOBAL
+c TYPE OF THE RESONANCE. THE TYPE OF THE RESONANCE IS SELECTED
+c RANDOMLY BETWEEN ALL TYPES PERMITTED.
+c
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+ implicit none
+ real*8 m
+ integer class,i,im,ip
+
+ call getrange(class,im,ip)
+
+ call whichi(i,im,ip,m)
+
+ whichres=i
+
+ return
+ end
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ subroutine whichi(i,im,ip,m)
+c
+c Revision : 1.0
+cinput m : Mass of the resonance
+cinput im,ip : lower and upper limit of itypes
+coutput i : itype of the resonance
+c
+c DETERMINES ID OF A RESONANCE WITH MASS M ACCORDING TO
+c the range defined by {\tt im} and {\tt ip}.
+c
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+ implicit none
+ include 'comres.f'
+ real*8 m,fmax,f(-itmax:itmax),fbrwig,bwnorm
+ integer i,im,ip,jit,isoit
+ include 'options.f'
+
+
+ do 101 i=im,ip
+c f(i) = breitwig(m,i)
+ f(i) = fbrwig(i,isoit(i),m,1)/bwnorm(i)*dble(jit(i)+1)
+
+ 101 continue
+
+ call getbran(f,-itmax,itmax,fmax,im,ip,i)
+
+ return
+ end
+
+
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ subroutine getrange(class,i1,i2)
+c
+c Revision : 1.0
+c
+cinput class : class of resonance:
+c 0 = Delta(1232)
+c 1 = N*
+c 2 = Delta* (EXcludind D(1232))
+c 3 = all nonstrange resonances allowed
+c 4 = nucleon
+c 11 = N and N*
+c 12 = Delta(1232) and Delta*
+c 13 = Lambda, Lambda*
+c 14 = Sigma, Sigma*
+c 15 = Cascade, Cascade*
+c 16 = Omega(s)
+c
+coutput i1,i2 : range of resonance IDs (from,to)
+c
+C INTERFACE BETWEEN class AND paticle ID
+c
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+ implicit none
+ integer class,i1,i2
+ include 'comres.f'
+
+ if (class.eq.0) then
+c inspect only Delta(1232)
+ i1 = mindel
+ i2 = mindel
+ else if (class.eq.1) then
+c all N*-Resonances
+ i1 = minnuc+1
+ i2 = maxnuc
+ else if (class.eq.2) then
+c all Delta-Resonances (EXcluding D(1232))
+ i1 = mindel+1
+ i2 = maxdel
+ else if (class.eq.3) then
+c all non strange Resonances
+ i1 = minres
+ i2 = maxres
+ else if (class.eq.4) then
+ i1 = nucleon
+ i2 = nucleon
+ else if (class.eq.11) then
+ i1 = minnuc
+ i2 = maxnuc
+ else if (class.eq.12) then
+ i1 = mindel
+ i2 = maxdel
+ else if (class.eq.13) then
+ i1 = minlam
+ i2 = maxlam
+ else if (class.eq.14) then
+ i1 = minsig
+ i2 = maxsig
+ else if (class.eq.15) then
+ i1 = mincas
+ i2 = maxcas
+ else if (class.eq.16) then
+ i1 = minome
+ i2 = maxome
+ else
+c something went wrong
+ write(6,*) 'getrange: class=',class,' not valid...'
+ stop
+ endif
+
+ end
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ subroutine getinw(i,m,class,mmax)
+c
+c Revision : 1.0
+c
+cinput i : Resonance ID
+cinput mmax : upper limit for mass to create
+coutput i : Resonance ID of particle in same class
+coutput m : Mass of particle in same class
+coutput class : Class of resonance i (see {\tt getrange})
+c
+c Does in a way the inverse of subr. getrange: look in which class
+c resonance i is and determine mass m and itype i of same class with
+c maximal mass of mmax.
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+ include 'comres.f'
+ integer i,j,im,ip,isav,class,ii,iim,iip
+ real*8 m,mmax
+
+ real*8 massit,getmass
+ integer whichres,isign
+
+ isav=i
+ do 108 j=0,2
+ call getrange(j,im,ip)
+ if(i.ge.im.and.i.le.ip)then
+ m=getmass(mmax,j)
+ i=whichres(m,j)
+ class=j
+ return
+ end if
+ 108 continue
+c if failed keep old value of i and standard value for m
+claw next line is for debug purpose
+ write(6,*)'getinw: itype not in resonance range:itype=',isav
+ i=isav
+ m=massit(i)
+ return
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ entry getirg(ii,iim,iip)
+c
+cinput ii : particle ID
+coutput iim,iip : minimal and maximal itype of particle's class
+c
+c Determine which range (acc. to {\tt getrange}) particle
+c {\tt ii} belongs to.
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+ do 1008 j=11,16
+ call getrange(j,iim,iip)
+ if(iabs(ii).ge.iim.and.iabs(ii).le.iip)then
+ iim=min(isign(iim,ii),isign(iip,ii))
+ iip=max(isign(iim,ii),isign(iip,ii))
+ return
+ endif
+ 1008 continue
+c only one particle (ii) within range
+ iim=ii
+ iip=ii
+ return
+
+ end
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ real*8 function massdist(m,class)
+c
+c Revision : 1.0
+c
+cinput m : mass to look at
+cinput class : resonance class (see {\tt getrange}
+coutput massdist : value of mass distribution at mass m
+c
+C MASS DISTRIBUTION AT MASS M FOR GIVEN class OF RESONANCES.
+C DISTRIBUTION IS CALCULATED BY SUPERPOSING BREIT-WIGNER-
+C DISTRIBUTIONS FOR ALL RESONANCES OF A KIND.
+c
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+ implicit none
+ real*8 m
+ integer class,i1,i2,i,isoit,jit
+ include 'comres.f'
+ real*8 fbrwig,bwnorm
+ include 'options.f'
+
+ call getrange(class,i1,i2)
+c Delta(1232) is included via i1=i2=mindel
+ massdist = 0.0
+ do 101 i=i1,i2
+c massdist=massdist+breitwig(m,i)
+ massdist=massdist+fbrwig(i,isoit(i),m,1)
+ & /bwnorm(i)*dble(jit(i)+1)
+ 101 continue
+ return
+ end
+
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+ real*8 function pcms(ecm,m1,m2)
+c calculates the CM-momentum in a 2-body decay/coll. depending on ecm
+ implicit none
+ real*8 ecm,m1,m2,s
+
+ctp131205 lt -> le
+c if (ecm.lt.m1+m2) then
+ if (ecm.le.m1+m2) then
+ pcms = 0.0
+ return
+ endif
+
+ s = ecm*ecm
+ pcms = sqrt( (s-(m1+m2)**2)*(s-(m1-m2)**2)/(4.0*s))
+ return
+ end
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+ real*8 function bcms(ecm,m1,m2)
+c calculates the CM-velocity in a 2-body decay/coll. depending on ecm
+
+ implicit none
+ real*8 ecm,m1,m2,s
+
+ if (ecm.le.m1+m2) then
+ bcms = 0.0
+ return
+ endif
+
+ s = ecm*ecm
+ bcms = sqrt( (1d0-(m1+m2)**2/s) * (1d0-(m1-m2)**2/s) )
+ return
+ end