ReggeGribovPartonMCInterface/src/epos-ems.f

0001 c-----------------------------------------------------------------------
0002       subroutine emsaa(iret)
0003 c-----------------------------------------------------------------------
0004 c  energy-momentum sharing
0005 c-----------------------------------------------------------------------
0006
0007       include 'epos.inc'
0008       include 'epos.incems'
0009       include 'epos.incsem'
0010       common/cwzero/wzero,wzerox
0011       double precision omega,omlog,oma,omb,wab,wba,wmatrix,wzero,nbar
0012      *,wzerox,rrr,eps,xprem,xmrem,om1intgck
0013       parameter(eps=1.d-30)
0014       common/col3/ncol,kolpt
0015 c      logical modu
0016       common/cems5/plc,s
0017       double precision s,px,py,pomass,plc!,PhiExpo
0018       common/ems6/ivp0,iap0,idp0,isp0,ivt0,iat0,idt0,ist0
0019       common/emsptl/nppr(npommx,kollmx),npproj(mamx),nptarg(mamx)
0020       common/nucl3/phi,bimp
0021       common/epoquasi/iquasi
0022       logical vpom,difint
0023       dimension ishuff(2*mamx,2),icp(2),ict(2),jcp(nflav,2),jct(nflav,2)
0024      &          ,nishuff(2)
0025       call utpri('emsaa ',ish,ishini,4)
0026
0027       irea=iret
0028
0029       do j=1,2
0030         do i=1,nflav
0031           jcp(i,j)=0
0032           jct(i,j)=0
0033         enddo
0034       enddo
0035
0036       iret=0
0037       iret2=0
0038
0039 c     initialize
0040 c     ----------
0041
0042       call emsipt   !initialize projectile and target
0043       call emsigr   !initialize grid
0044
0045
0046
0047 c Metropolis
0048
0049       if(iokoll.ne.1)then
0050
0051         nSprmx=0
0052         do k=1,koll
0053           nSprmx=nSprmx+nprmx(k)
0054         enddo
0055
0056         omlog=0
0057         nemsi=nemsi+1
0058         if(nemsi.le.4.and.iemsi1.eq.1)call xEmsI1(1,0,omlog)
0059         if(ish.ge.6)write (ifch,*)'after xEmsI1'
0060         if(nemsi.le.4.and.iemsi2.eq.1)call xEmsI2(1,0)
0061         if(ish.ge.6)write (ifch,*)'after xEmsI2'
0062         if(ish.ge.6)call XPrint('Before Markov:&')
0063
0064
0065 c     Markov
0066 c     ------
0067
0068       if(ish.ge.4)write(ifch,*)'Markov Process'
0069       kint=int(max(15.,2.*engy**0.2))
0070       if(koll.gt.50)kint=3*kint/int(log(float(koll)))
0071       kmcmx=nSprmx*kint        !50*kint  !100*kint
0072
0073
0074       do kmc=1,kmcmx               !-----> start Metropolis
0075
0076        knprmx=0
0077        rrr=dble(rangen())
0078        do ik=1,koll
0079          knprmx=knprmx+nprmx(ik)
0080          if(rrr.le.dble(knprmx)/dble(nSprmx))then ! k-th pair
0081            k=ik
0082            goto 10
0083          endif
0084        enddo
0085  10    continue
0086
0087        ip=iproj(k)
0088        it=itarg(k)
0089        n=1+int(rangen()*float(nprmx(k)))  ! n-th spot for k-th pair
0090        nbar=dble(npr(0,k))
0091        if(idpr(n,k).eq.0)nbar=nbar-1d0
0092
0093        xprem=1.d0!xpp(ip)+xppr(n,k)        !consistently, it should be 1.
0094        xmrem=1.d0!xmt(it)+xmpr(n,k)
0095        wzerox=(nbar+1d0)
0096        wzero=wzerox    / ( wzerox
0097      &                    +om1intgck(k,xprem,xmrem)*gammaV(k) )
0098
0099        if(ish.ge.8)write(ifch,*)'wzero',k,n,wzero,wzerox,gammaV(k)
0100      &                          ,om1intgck(k,xprem,xmrem)
0101        if(ish.ge.1.and.100000*(kmc/100000).eq.kmc)
0102      & write(ifmt,*)'kmc',kmc,kmcmx
0103
0104        call StoCon(1,k,n)
0105        call RemPom(k,n)
0106        call ProPo(k,n)
0107        call ProXY(k,n)
0108
0109        call StoCon(2,k,n)
0110
0111        if(idpr(n,k).eq.0.and.idx0.eq.0)then
0112          accept=accept+1.
0113        else
0114
0115          omb=omega(n,k)
0116          if(omb.le.0.d0)then
0117            reject=reject+1.
0118            call RemPom(k,n)
0119            call StoCon(-1,k,n)
0120          else
0121
0122            wab=wmatrix(k,n)
0123            if(ish.ge.8)write(ifch,*)'omb',omb,wab,k,n
0124            if(wab.le.0.d0)then
0125              write (ifmt,*)'wab,kmc',wab,omb,kmc,k,n,xpr(n,k),ypr(n,k)
0126      &  ,xppr(n,k),xmpr(n,k),xpp(ip),xmt(it),ip,it,idpr(n,k)
0127              write(ifmt,'(a,i12,d25.15)')'ems,seedf',nrevt+1,seedc
0128              iret=1
0129              goto 1000
0130            endif
0131            call RemPom(k,n)
0132            call StoCon(-1,k,n)
0133            oma=omega(n,k)
0134            wba=wmatrix(k,n)
0135            if(oma.ge.0.d0.and.oma.le.eps*omb*wba/wab)then
0136              accept=accept+1.
0137              call RemPom(k,n)
0138              call StoCon(-2,k,n)
0139              omlog=omlog+dlog(omb)
0140              goto 500
0141            elseif(oma.le.1.d-300.or.oma.ne.oma.or.omb.ne.omb)then
0142              write (ifmt,*)'oma,kmc',oma,omb,kmc,k,n,xpr(n,k),ypr(n,k)
0143      &  ,xppr(n,k),xmpr(n,k),idpr(n,k),npr(1,k),xpp(ip),xmt(it),ip,it
0144              write(ifmt,'(a,i12,d25.15)')'ems,seedf',nrevt+1,seedc
0145              iret=1
0146              goto 1000
0147            endif
0148
0149            z=sngl(omb/oma*wba/wab)
0150            if(ish.ge.8)write(ifch,*)'z,oma',z,oma,wba,k,n
0151            if(rangen().gt.z)then
0152              reject=reject+1.
0153            else
0154              accept=accept+1.
0155              call RemPom(k,n)
0156              call StoCon(-2,k,n)
0157              omlog=omlog-dlog(oma)+dlog(omb)
0158            endif
0159
0160  500       continue
0161
0162          endif
0163
0164          endif
0165
0166        if(nemsi.le.4)then
0167          kplot=int(float(kmc)/float(kmcmx)*100.)
0168          if(iemsi1.eq.1)call xEmsI1(1,kplot,omlog)
0169          if(iemsi2.eq.1)call xEmsI2(1,kplot)
0170        endif
0171
0172       enddo                     !-----> end Metropolis
0173
0174
0175       else
0176
0177         n=1
0178
0179         do k=1,koll
0180
0181           call ProPo(k,n)
0182           call ProXY(k,n)
0183
0184         enddo
0185
0186       endif
0187
0188 c --- Plot Pomeron b-distributions ---
0189
0190       if(ish.ge.6)call XPrint('After Markov :&')
0191
0192       if(iemsb.eq.1)then ! plot
0193        do k=1,koll
0194         call xEmsB(1,1,k)
0195         if(nprt(k).gt.0)call xEmsB(1,2,k)
0196        enddo
0197       endif
0198
0199       if(iemsbg.eq.1)then ! plot
0200         call xEmsBg(3,0,0)
0201         do k=1,koll
0202           call xEmsBg(1,0,k)
0203           if(nprt(k).gt.0)then
0204             call xEmsBg(1,-1,k)
0205             do n=1,nprmx(k)
0206               if(idpr(n,k).ne.0)call xEmsBg(1,idpr(n,k),k)
0207             enddo
0208           endif
0209         enddo
0210       endif
0211
0212 c --- Plot distr of pomeron number ---
0213
0214
0215       if(iemspm.eq.1)then
0216        do k=1,koll
0217            call xEmsPm(1,k,nprt(k),nprmx(k))
0218        enddo
0219       endif
0220
0221
0222 c --- Count all interactions ---
0223
0224       ncol=0
0225       ncolh=0
0226       do k=1,koll
0227         if(nprt(k).gt.0)then
0228           ncol=ncol+1
0229           if(isplit.eq.1)then
0230             do n=1,nprmx(k)
0231               if(xpr(n,k).gt.xzcutpar(k))itpr(k)=1  !for nuclear splitting
0232             enddo
0233           endif
0234           ip=iproj(k)
0235           it=itarg(k)
0236           kolp(ip)=kolp(ip)+nprt(k) !number of cut Pomerons
0237           kolt(it)=kolt(it)+nprt(k) !on remnants
0238         endif
0239       enddo
0240
0241 c --- Calculate Z (written to zzremn)
0242
0243
0244       do ip=1,maproj
0245        call CalcZZ(1,ip)
0246       enddo
0247       do it=1,matarg
0248        call CalcZZ(-1,it)
0249       enddo
0250
0251 c -- Split Enhanced Pomerons and fix their nature ---
0252
0253       if(isplit.eq.1.and.ncol.gt.0)then
0254
0255         if (iLHC.eq.1)then  !make random selection to avoid assymetry
0256
0257           nishuff(1)=0
0258           nishuff(2)=0
0259           do ip=1,maproj
0260             nishuff(1)=nishuff(1)+1
0261             ishuff(nishuff(1),1)=ip
0262           enddo
0263           do it=1,matarg
0264             nishuff(2)=nishuff(2)+1
0265             ishuff(nishuff(2),2)=it
0266           enddo
0267
0268           do while(nishuff(1)+nishuff(2).gt.0)
0269
0270 c random selection
0271             if(nishuff(1).gt.0.and.nishuff(2).gt.0)then
0272               ir=1+int(rangen()+0.5)
0273             elseif(nishuff(1).gt.0)then
0274               ir=1
0275             else
0276               ir=2
0277             endif
0278
0279             indx=1+int(rangen()*float(nishuff(ir)))
0280             if(ir.eq.1)then
0281               ip=ishuff(indx,ir)
0282               if(lproj3(ip).ne.0.and.kolp(ip).eq.0)call ProNucSpl( 1,ip)
0283             else
0284               it=ishuff(indx,ir)
0285               if(ltarg3(it).ne.0.and.kolt(it).eq.0)call ProNucSpl(-1,it)
0286             endif
0287             ishuff(indx,ir)=ishuff(nishuff(ir),ir)
0288             nishuff(ir)=nishuff(ir)-1
0289
0290           enddo
0291
0292         else
0293
0294           do ip=1,maproj
0295             if(lproj3(ip).ne.0.and.kolp(ip).eq.0)call ProNucSpl( 1,ip)
0296           enddo
0297           do it=1,matarg
0298             if(ltarg3(it).ne.0.and.kolt(it).eq.0)call ProNucSpl(-1,it)
0299           enddo
0300
0301         endif
0302
0303         if(ish.ge.6)call XPrint('After ProNucSpl:&')
0304
0305       endif
0306
0307 c -- Fix Pomeron type ---
0308
0309       do k=1,koll
0310         itpr(k)=0
0311         do n=1,nprmx(k)
0312           if(idfpr(n,k).eq.0)call ProPoTy(k,n)
0313         enddo
0314       enddo
0315
0316
0317
0318 c --- Fix Remnant Excitation
0319
0320       do ip=1,maproj
0321        if(lproj(ip).ne.0)then
0322          call ProReEx( 1,ip)
0323          if(iremn.ge.2)call UpdateFlav(ip,jcp,0) !reset jcpref to 0
0324        endif
0325       enddo
0326       do it=1,matarg
0327        if(ltarg(it).ne.0)then
0328          call ProReEx(-1,it)
0329          if(iremn.ge.2)call UpdateFlav(it,jct,0) !reset jctref to 0
0330        endif
0331       enddo
0332
0333
0334 c --- LHC tune : remove unnecessary diffractive Pomerons
0335       if(iLHC.eq.1)then
0336         do k=1,koll
0337           ip=iproj(k)
0338           it=itarg(k)
0339 c remove temporary diffractive Pomeron if at least on remnant excited
0340 c          ymean=0.
0341           do n=1,nprmx(k)
0342             if(idpr(n,k).eq.-1)then
0343               idpr(n,k)=1
0344               if((iep(ip).gt.0.or.iet(it).gt.0)
0345      &             .and.xpr(n,k).le.xzcutpar(k))call VirPom(k,n,0)
0346 c              if(iep(ip).gt.0.or.iet(it).gt.0)then
0347 c                if(xpr(n,k).ge.xzcutpar(k))then
0348 c                  call VirPom(k,n,0)
0349 c                else
0350 c                  ymean=ymean+ypr(n,k)
0351 c                endif
0352 c              endif
0353            endif
0354           enddo
0355 cc put excitation on the side of the pomeron
0356 c          if((ymean.gt.0..and.iet(it).gt.0).or.
0357 c     &       (ymean.lt.0..and.iep(ip).gt.0))then
0358 c            ietmp=iep(ip)
0359 c            iep(ip)=iet(it)
0360 c            iet(it)=ietmp
0361 c          endif
0362         enddo
0363       endif
0364
0365 c --- Count real interactions ---
0366
0367       ncol=0
0368       do k=1,koll
0369         if(nprt(k).gt.0)then        !inelastic
0370           ncol=ncol+1
0371           if(itpr(k).lt.0)then
0372             itpr(k)=-1
0373           else
0374             itpr(k)=1              !diffractive with Pomeron
0375           endif
0376         elseif(itpr(k).gt.0)then    !diffractive
0377           ncol=ncol+1
0378           call ProDiSc(k)
0379           itpr(k)=2
0380         endif
0381       enddo
0382       if(ish.ge.5)write(ifch,*)'ncol:',ncol
0383
0384
0385
0386 c --- fix all variables
0387
0388
0389       if(ish.ge.4)write(ifch,*)'fix all variables'
0390
0391
0392 c ---  recalculate Zptn
0393
0394
0395 c      if(irzptn.eq.1)call recalcZPtn
0396
0397
0398       typevt=0                !ela
0399       if(maproj+matarg.eq.2)then     !pp
0400         if(itpr(1).ne.0)then
0401           anintine=anintine+1.
0402           if(itpr(1).gt.0)then
0403             if(ionudi.eq.1
0404      &        .or.iep(1).ne.0.or.iet(1).ne.0.or.itpr(1).eq.1)then
0405               anintdiff=anintdiff+1.
0406               if((iep(1).eq.0.and.iet(1).eq.2).or.
0407      &           (iet(1).eq.0.and.iep(1).eq.2))anintsdif=anintsdif+1.
0408               if(iep(1).eq.0.and.iet(1).eq.2)typevt=-4    !SD tar
0409               if(iet(1).eq.0.and.iep(1).eq.2)typevt=4     !SD pro
0410               if(iep(1).eq.2.and.iet(1).eq.2)typevt=2     !DD
0411               if(iep(1).eq.0.and.iet(1).eq.0)typevt=3     !CD
0412             else
0413               anintine=anintine-1. !diffractive without excitation = elastic
0414             endif
0415           else
0416             typevt=1                                      !ND
0417           endif
0418         endif
0419       else
0420         aidif=0.
0421         aidifp=0.
0422         aidift=0.
0423         aiine=0.
0424         do k=1,koll
0425           ip=iproj(k)
0426           it=itarg(k)
0427           if(aidif.ge.0..and.itpr(k).gt.0)then
0428             aidifp=aidifp+iep(ip)+(2-itpr(k))*0.00001
0429             aidift=aidift+iet(it)+(2-itpr(k))*0.00001
0430             if(ionudi.eq.1)then !count all diff as inelastic (to compare to tabulated cs)
0431               aidif=aidif+1.
0432             endif
0433           elseif(itpr(k).eq.-1)then
0434             aiine=aiine+1.
0435             aidif=-ainfin
0436           endif
0437         enddo
0438         if(ionudi.eq.2)then
0439           aidif=aidif+aidifp
0440         else
0441           aidif=aidif+aidifp+aidift
0442         endif
0443         if(aidif.gt.0.)then
0444           anintdiff=anintdiff+1.
0445           anintine=anintine+1.
0446           if(aidifp.gt.0.5.and.aidift.le.0.5)then
0447             anintsdif=anintsdif+1.
0448             typevt=4                        !SD pro
0449           endif
0450           if(aidifp.gt.0.5.and.aidift.gt.0.5)then
0451             typevt=2                        !DD
0452           endif
0453           if(ionudi.ne.2)then
0454             if(aidifp.le.0.5.and.aidift.gt.0.5)then
0455               anintsdif=anintsdif+1.
0456               typevt=-4                      !SD tar
0457             elseif(typevt.le.0.5.and.aidifp.gt.0..and.aidift.gt.0.)then
0458               typevt=3                      !CD
0459             endif
0460           endif
0461         elseif(aiine.gt.0.)then
0462           anintine=anintine+1.
0463           typevt=1                          !ND
0464         endif
0465       endif
0466
0467       if(ish.ge.6)call XPrint('After fixing:&')
0468
0469
0470 c --- Plot MC pomeron number ---
0471
0472       if(nemsi.le.4.and.irea.ge.0)then
0473        if(iemsi1.eq.1)call xEmsI1(1,100,omlog)
0474        if(iemsi2.eq.1)call xEmsI2(1,100)
0475        if(iemsi1.eq.1.and.ncol.gt.0)call xEmsI1(2,0,omlog)
0476        if(iemsi2.eq.1.and.ncol.gt.0)call xEmsI2(2,0)
0477        if((iemsi1.eq.1.or.iemsi2.eq.1).and.ncol.eq.0)nemsi=nemsi-1
0478       endif
0479
0480       if(iemsb.eq.1)then        ! plot
0481         do k=1,koll
0482           if(itpr(k).eq.0)call xEmsB(1,3,k) !nothing
0483           if(itpr(k).eq.-1)call xEmsB(1,4,k) !cut
0484           if(itpr(k).gt.0)call xEmsB(1,5,k) !diffr
0485           if(abs(itpr(k)).eq.1)call xEmsB(1,6,k) !cut+diffr cut
0486         enddo
0487       endif
0488
0489
0490 c check for diffractive interaction without excitation
0491       difint=.true.
0492       ieptot=0
0493       if(maproj+matarg.eq.2)ieptot=1     !not used for pp
0494       do k=1,koll
0495         if(itpr(k).eq.2)then
0496           ip=iproj(k)
0497           it=itarg(k)
0498           ieptot=ieptot+iep(ip)
0499           if(ionudi.ne.2)ieptot=ieptot+iet(it)
0500 c for CR, ionudi=1, count diffraction without excitation as inelastic (part of the xs)
0501           if(ionudi.ne.1.and.iep(ip).eq.0.and.iet(it).eq.0)then
0502             ncol=ncol-1
0503             itpr(k)=0
0504             kolp(ip)=kolp(ip)-1
0505             kolt(it)=kolt(it)-1
0506           endif
0507         else
0508           if(iLHC.eq.1.and.abs(itpr(k)).eq.1)then
0509             difint=.false.
0510           elseif(iLHC.eq.0)then   !bug in CR version for ionudi=2 (difint=F always !)
0511             difint=.false.
0512           endif
0513         endif
0514       enddo
0515       if(difint.and.ionudi.eq.2.and.ieptot.eq.0)then
0516         ncol=0                  !for ionudi=2
0517         iret=0
0518         goto 1000               !no projectile excitation = elastic
0519       endif
0520
0521       iquasi=0
0522       if(ncol.eq.0)goto 998
0523       if(difint.and.ieptot-1.le.0)then
0524         iquasi=1
0525         if(ish.ge.2)write(ifch,*)'EPOS Quasi-elastic event'
0526         goto 998
0527       endif
0528
0529 c --- Treat Pomerons ---------------------------------------
0530
0531
0532 c --- Check minimum mass ---
0533
0534       do k=1,koll
0535         ip=iproj(k)
0536         it=itarg(k)
0537       do n=1,nprmx(k)
0538         if(xpr(n,k).lt.(cumpom/engy)**2)then
0539           nnb=nbkpr(n,k)
0540           nnv=nvpr(n,k)
0541           if(nnv.ne.0)then
0542             nbkpr(nnv,k)=0                  !if bckp Pomeron
0543           endif
0544           if(nnb.ne.0)then
0545             ivi=1
0546             call VirPom(k,nnb,ivi)            !if hard backup exist
0547             nbkpr(n,k)=0                    !remove it
0548           endif
0549           ivi=2
0550           call VirPom(k,n,ivi)
0551         elseif(itpr(k).eq.1.and.abs(idfpr(n,k)).eq.1)then
0552 c diffractive cut Pomeron should not change remnant excitation
0553           idfs=sign(1,idfpr(n,k))
0554           if(iep(ip).eq.0.and.iet(it).eq.0)then
0555             idfpr(n,k)=idfs*4       !not linked to both proj and targ
0556           elseif(iep(ip).eq.0)then
0557             idfpr(n,k)=idfs*3       !linked to targ
0558             iet(it)=1               !target excitation is inelastic type
0559           elseif(iet(it).eq.0)then
0560             idfpr(n,k)=idfs*2       !linked to proj
0561             iep(ip)=1               !projectile excitation is inelastic type
0562           endif
0563         endif
0564       enddo
0565       enddo
0566
0567 c --- Set String End Type and Pt
0568
0569       do k=1,koll
0570         ip=iproj(k)
0571         it=itarg(k)
0572         do n=1,nprmx(k)
0573
0574           if(idpr(n,k).gt.0)then
0575
0576           ntry=0
0577           vpom=.false.
0578           ivpi=ivp(ip)
0579           ivti=ivt(it)
0580           idpi=idp(ip)
0581           idti=idt(it)
0582           do i=1,2
0583             icp(i)=icproj(i,ip)
0584             ict(i)=ictarg(i,it)
0585           enddo
0586           if(iremn.ge.2)then    !save jcpref and jctref into jcp and jct
0587             call UpdateFlav(ip,jcp,1)
0588             call UpdateFlav(it,jct,2)
0589           endif
0590
0591  100      ntry=ntry+1
0592           iret=0
0593           if(ntry.ge.200)vpom=.true.
0594           if(ntry.gt.1)then
0595        if(ish.ge.4)write(ifch,*)'Try again setting string ends for k,n'
0596      &                               ,k,n,ntry
0597             ivp(ip)=ivpi
0598             ivt(it)=ivti
0599             idp(ip)=idpi
0600             idt(it)=idti
0601             do i=1,2
0602               icproj(i,ip)=icp(i)
0603               ictarg(i,it)=ict(i)
0604             enddo
0605             if(iremn.ge.2)then       !restore jcpref and jctref from jcp and jct
0606               call UpdateFlav(ip,jcp,-1)
0607               call UpdateFlav(it,jct,-2)
0608             endif
0609             call RmPt(k,n)
0610           endif
0611
0612           if(nvpr(n,k).eq.0)call ProSeTy(k,n)      !Not for backup Pomeron
0613           call ProSePt(k,n,iret)
0614           if(iret.eq.1)then
0615             if(vpom)then
0616               ivi=13
0617               call VirPom(k,n,ivi)
0618             else
0619               goto 100
0620             endif
0621           endif
0622
0623 c      enddo
0624 c      enddo
0625
0626 c --- Check Pomeron mass
0627
0628 c      do k=1,koll
0629 c      do n=1,nprmx(k)
0630        if(idpr(n,k).ne.0.and.ivpr(n,k).ne.0)then
0631         px=xxp1pr(n,k)+xxp2pr(n,k)+xxm1pr(n,k)+xxm2pr(n,k)
0632         py=xyp1pr(n,k)+xyp2pr(n,k)+xym1pr(n,k)+xym2pr(n,k)
0633         pomass=xpr(n,k)*s-px*px-py*py
0634         if(pomass.lt.amprmn(idhpr(n,k)))then
0635           nnv=nvpr(n,k)
0636           nnb=nbkpr(n,k)
0637           idfpom=iabs(idfpr(n,k))
0638           if(vpom)then
0639             ivi=3
0640             call VirPom(k,n,ivi)  !call RmPt(k,n)
0641             if(nnv.ne.0)then    !bckp Pomeron
0642               nbkpr(nnv,k)=0
0643             endif
0644             if(nnb.ne.0)then    !big Pomeron with bckp one
0645               ivpr(nnb,k)=1
0646               nvpr(nnb,k)=0
0647               idfpr(nnb,k)=idfpom
0648               npr(1,k)=npr(1,k)+1
0649               npr(3,k)=npr(3,k)-1
0650             endif
0651           else
0652             goto 100
0653           endif
0654         endif
0655        endif
0656 c      enddo
0657 c      enddo
0658
0659 c --- Define String ends for "backup" Pomerons ---
0660
0661 c      do k=1,koll
0662 c      do n=1,nprmx(k)
0663 c        if(nvpr(n,k).ne.0)call ProSeX(k,n,iret)
0664 c        if(iret.eq.1)then
0665 c          if(vpom)then
0666 c            nn=nvpr(n,k)
0667 c            ivi=7
0668 c            call VirPom(k,n,ivi)
0669 c            nbkpr(nn,k)=0
0670 c          else
0671 c            goto 100
0672 c          endif
0673 c        endif
0674         iret=0
0675         iret2=0
0676 c      enddo
0677 c      enddo
0678
0679 c --- Define String ends for "normal" Pomerons ---
0680
0681 c      do k=1,koll
0682 c      do n=1,nprmx(k)
0683         if(nvpr(n,k).eq.0)call ProSeX(k,n,iret)   !Not for backup Pomeron
0684         if(iret.eq.1)then
0685           if(vpom)then
0686             ivi=12
0687             call VirPom(k,n,ivi)
0688           else
0689             goto 100
0690           endif
0691         endif
0692         iret=0
0693         iret2=0
0694
0695       endif
0696
0697       enddo
0698       enddo
0699
0700
0701 c --- Write ---
0702
0703  998  call emszz
0704       if(ncol.eq.0)then
0705         iret=0
0706         goto 1000
0707       endif
0708
0709
0710       do k=1,koll
0711        if(abs(itpr(k)).eq.1)call emswrpom(k,iproj(k),maproj+itarg(k))
0712       enddo
0713
0714
0715 c --- Treat hard Pomeron
0716
0717       ncolh=0
0718       do k=1,koll
0719         ncolhp=0
0720         do n=1,nprmx(k)
0721           if(idpr(n,k).eq.3)then
0722             if(ishpom.eq.1)then
0723               call psahot(k,n,iret)
0724               if(iret.eq.0)ncolhp=ncolhp+1
0725               if(iret.eq.1)then
0726                 if(nbkpr(n,k).ne.0)then
0727                   nn=nbkpr(n,k)
0728                   call ProSeTy(k,nn)
0729                   call ProSeX(k,nn,iret2)
0730                   if(iret2.eq.1)then
0731                     ivi=15
0732                     call VirPom(k,nn,ivi)
0733                     if(ivi.lt.0)then
0734                       jerr(7)=jerr(7)+1
0735                       iret=1
0736                       goto 1000
0737                     endif
0738                     istptl(nppr(nn,k))=32
0739                     nbkpr(n,k)=0
0740                   else
0741                     ivpr(nn,k)=1
0742                     nvpr(nn,k)=0
0743                     idfpr(nn,k)=idfpr(n,k)
0744                     npr(1,k)=npr(1,k)+1
0745                     npr(3,k)=npr(3,k)-1
0746                     ansff=ansff+1 !counters
0747                     anshf=anshf-1
0748                   endif
0749                 endif
0750                 ivi=16
0751                 call VirPom(k,n,ivi)
0752                 if(ivi.lt.0)then
0753                   jerr(7)=jerr(7)+1
0754                   iret=1
0755                   goto 1000
0756                 endif
0757                 istptl(nppr(n,k))=32
0758               elseif(nbkpr(n,k).ne.0)then
0759                 nn=nbkpr(n,k)
0760                 ivi=17
0761                 call VirPom(k,nn,ivi)
0762                 if(ivi.lt.0)then
0763                   jerr(7)=jerr(7)+1
0764                   iret=1
0765                   goto 1000
0766                 endif
0767                 istptl(nppr(nn,k))=32
0768                 nbkpr(n,k)=0
0769               endif
0770               iret=0
0771             else
0772               istptl(nppr(n,k))=32
0773               if(nbkpr(n,k).ne.0)then
0774                 nn=nbkpr(n,k)
0775                 istptl(nppr(nn,k))=32
0776               endif
0777             endif
0778           endif
0779         enddo
0780         if(ncolhp.gt.0)ncolh=ncolh+1     !count hard binary collisions
0781       enddo
0782       kohevt=ncolh     !update number of hard collisions
0783
0784       if(iLHC.eq.0.and.iremn.ge.2)then
0785 c --- Add valence quark to jcpref and jctref for soft string ends ---
0786         do ip=1,maproj
0787           if(iep(ip).ne.-1)then
0788             call UpdateFlav(ip,jcp,10)
0789             do nnn=1,nrflav
0790               jcpval(nnn,1,ip)=jcp(nnn,1)
0791             enddo
0792             do nnn=1,nrflav
0793               jcpval(nnn,2,ip)=jcp(nnn,2)
0794             enddo
0795           else
0796             icp(1)=icproj(1,ip)
0797             icp(2)=icproj(2,ip)
0798             call iddeco(icp,jcp)
0799             do nnn=1,nrflav
0800               jcpval(nnn,1,ip)=jcp(nnn,1)
0801             enddo
0802             do nnn=1,nrflav
0803               jcpval(nnn,2,ip)=jcp(nnn,2)
0804             enddo
0805           endif
0806         enddo
0807         do it=1,matarg
0808           if(iet(it).ne.-1)then
0809             call UpdateFlav(it,jct,20)
0810             do nnn=1,nrflav
0811               jctval(nnn,1,it)=jct(nnn,1)
0812             enddo
0813             do nnn=1,nrflav
0814               jctval(nnn,2,it)=jct(nnn,2)
0815             enddo
0816           else
0817             ict(1)=ictarg(1,it)
0818             ict(2)=ictarg(2,it)
0819             call iddeco(ict,jct)
0820             do nnn=1,nrflav
0821               jctval(nnn,1,it)=jct(nnn,1)
0822             enddo
0823             do nnn=1,nrflav
0824               jctval(nnn,2,it)=jct(nnn,2)
0825             enddo
0826           endif
0827         enddo
0828       endif
0829
0830 c --- Treat "normal" soft Pomerons ---
0831
0832       do k=1,koll
0833         do n=1,nprmx(k)
0834           if(nvpr(n,k).eq.0)then
0835             if(isopom.eq.1)then
0836               call ProSeF(k,n,iret)
0837               if(iret.eq.1)then
0838                 ivi=18
0839                 call VirPom(k,n,ivi)
0840                 if(ivi.lt.0)then
0841                   jerr(7)=jerr(7)+1
0842                   iret=1
0843                   goto 1000
0844                 endif
0845                 istptl(nppr(n,k))=32
0846               endif
0847               iret=0
0848             else
0849               istptl(nppr(n,k))=32
0850             endif
0851           endif
0852         enddo
0853       enddo
0854
0855
0856
0857 c --- Treat Remnants -----------------------------------------
0858
0859 c --- Fix Pion Exchange in diffractive remnants
0860
0861       do ip=1,maproj
0862        if(iep(ip).eq.2)call ProReEx( 2,ip)
0863       enddo
0864       do it=1,matarg
0865        if(iet(it).eq.2)call ProReEx( -2,it)
0866       enddo
0867
0868 c --- Diffractive Pt and check Pomeron status
0869
0870       iret=1
0871       do k=1,koll
0872         call ProDiPt(k,1,iret)
0873       enddo
0874       if(iret.ne.0)then
0875         jerr(8)=jerr(8)+1
0876         ivi=99
0877         if(ish.ge.2)then
0878           write(ifch,*)'All Pomeron lost, redo event !'
0879           write(ifmt,*)'All Pomeron lost, redo event !'
0880         endif
0881         iret=1
0882         goto 1000
0883       endif
0884
0885       if(iLHC.eq.1.and.iremn.ge.2)then
0886 c --- Add valence quark to jcpref and jctref for soft string ends ---
0887         do ip=1,maproj
0888           if(iep(ip).ne.-1)then
0889             call UpdateFlav(ip,jcp,10)
0890             do nnn=1,nrflav
0891               jcpval(nnn,1,ip)=jcp(nnn,1)
0892             enddo
0893             do nnn=1,nrflav
0894               jcpval(nnn,2,ip)=jcp(nnn,2)
0895             enddo
0896           else
0897             icp(1)=icproj(1,ip)
0898             icp(2)=icproj(2,ip)
0899             call iddeco(icp,jcp)
0900             do nnn=1,nrflav
0901               jcpval(nnn,1,ip)=jcp(nnn,1)
0902             enddo
0903             do nnn=1,nrflav
0904               jcpval(nnn,2,ip)=jcp(nnn,2)
0905             enddo
0906           endif
0907         enddo
0908         do it=1,matarg
0909           if(iet(it).ne.-1)then
0910             call UpdateFlav(it,jct,20)
0911             do nnn=1,nrflav
0912               jctval(nnn,1,it)=jct(nnn,1)
0913             enddo
0914             do nnn=1,nrflav
0915               jctval(nnn,2,it)=jct(nnn,2)
0916             enddo
0917           else
0918             ict(1)=ictarg(1,it)
0919             ict(2)=ictarg(2,it)
0920             call iddeco(ict,jct)
0921             do nnn=1,nrflav
0922               jctval(nnn,1,it)=jct(nnn,1)
0923             enddo
0924             do nnn=1,nrflav
0925               jctval(nnn,2,it)=jct(nnn,2)
0926             enddo
0927           endif
0928         enddo
0929       endif
0930
0931       do ip=1,maproj
0932 c Here and later "kolp(ip).ne.0" replaced by "iep(ip).ne.-1" to count
0933 c projectile and target nucleons which are counted in paires but are not used
0934 c in collision (no diffractive or inelastic interaction) as slow particles
0935 c at the end. Then we can use them in ProRem to give mass to all other nucleons
0936 c and avoid energy conservation violation that utrescl can not treat
0937 c (and it gives a reasonnable number of grey particles even if distributions
0938 c are not really reproduced).
0939 c       if(kolp(ip).ne.0)call ProCop(ip,ip)
0940        if(iep(ip).ne.-1)call ProCop(ip,ip)
0941       enddo
0942       do it=1,matarg
0943        if(iet(it).ne.-1)call ProCot(it,maproj+it)
0944 c       if(kolt(it).ne.0)call ProCot(it,maproj+it)
0945       enddo
0946
0947
0948 c ---- Remnant Masses (ProReM)
0949
0950
0951       if(ish.ge.6)call XPrint('Before  ProReM:&')
0952       ntry=0
0953       iret=0
0954       call StoRe(1)             !Store Remnant configuration
0955  123  ntry=ntry+1
0956       nishuff(1)=0
0957       nishuff(2)=0
0958       do ip=1,maproj
0959         if(iep(ip).eq.0)then
0960           nishuff(1)=nishuff(1)+1
0961           ishuff(nishuff(1),1)=ip      !positive for non excited projectile
0962         elseif(iep(ip).gt.0)then
0963           nishuff(2)=nishuff(2)+1
0964           ishuff(nishuff(2),2)=ip      !positive for excited projectile
0965         endif
0966       enddo
0967       do it=1,matarg
0968         if(iet(it).eq.0)then
0969           nishuff(1)=nishuff(1)+1
0970           ishuff(nishuff(1),1)=-it !negative for non excited  target
0971         elseif(iet(it).gt.0)then
0972           nishuff(2)=nishuff(2)+1
0973           ishuff(nishuff(2),2)=-it !negative for excited  target
0974         endif
0975       enddo
0976
0977 c      do ir=1,2         !first set mass of non excited remnant
0978 cc      do ir=2,1,-1         !first set mass of excited remnant
0979
0980 c      do while(nishuff(ir).gt.0)
0981       do while(nishuff(1)+nishuff(2).gt.0)
0982
0983 c random selection
0984         if(nishuff(1).gt.0.and.nishuff(2).gt.0)then
0985           ir=1+int(rangen()+0.5)
0986         elseif(nishuff(1).gt.0)then
0987           ir=1
0988         else
0989           ir=2
0990         endif
0991
0992         indx=1+int(rangen()*float(nishuff(ir)))
0993         if(ishuff(indx,ir).gt.0)then
0994           ip=ishuff(indx,ir)
0995           call ProReM( 1,ip,iret)
0996         else
0997           it=-ishuff(indx,ir)
0998           call ProReM(-1,it,iret)
0999         endif
1000         if(ish.ge.10)call XPrint('In  ProReM:&')
1001
1002         if(iret.eq.1)then
1003           !----------------------------------------
1004           !If there is a problem, try again shuffle (30 times),
1005           !if it doesn't work, for pp, try 10 times with the same type
1006           !of event and if doesn't work redo event;
1007           !for pA redo event ; and for AB (with A or B >10)
1008           !continue with some ghosts ...
1009           !----------------------------------------
1010           if(ntry.lt.30)then
1011             if(ish.ge.3)write(ifch,*)'shuffle, try again',ntry
1012             call StoRe(-1)         !Restore Remnant configuration
1013             iret=0
1014             goto 123
1015           elseif(ntry.gt.30.or.maproj.le.20.or.matarg.le.20)then
1016             if(ish.ge.2)write(ifch,*)'ProRem, redo event ! ntry=',ntry
1017             if(ish.ge.1)write(ifmt,*)'ProRem, redo event ! ntry=',ntry
1018             iret=1
1019             goto 1000
1020           else
1021             if(ish.ge.3)write(ifch,*)'shuffle, try again forcing ...'
1022             call StoRe(-1)         !Restore Remnant configuration
1023             iret=10
1024             goto 123
1025           endif
1026         endif
1027
1028         ishuff(indx,ir)=ishuff(nishuff(ir),ir)
1029         nishuff(ir)=nishuff(ir)-1
1030
1031        enddo
1032 c      enddo
1033
1034 c --- Correction for Diffractive Pt (from Ralph but seems to be less good for NA49)
1035
1036 c      do k=1,koll
1037 c        call ProDiPt(k,2,idum)
1038 c      enddo
1039
1040
1041       iret=0
1042       if(ish.ge.6)call XPrint('After ProReM:&')
1043
1044
1045 c --- Write Z into zpaptl for connected strings
1046
1047
1048       do ip=1,maproj
1049         if(kolp(ip).ne.0)call WriteZZ(1,ip)
1050       enddo
1051       do it=1,matarg
1052         if(kolt(it).ne.0)call WriteZZ(-1,it)
1053       enddo
1054
1055
1056 c --- Write Remnants
1057
1058
1059       do ip=1,maproj
1060 c       if(kolp(ip).ne.0)call emswrp(ip,ip)
1061        if(iep(ip).ne.-1)call emswrp(ip,ip)
1062       enddo
1063
1064       do it=1,matarg
1065 c       if(kolt(it).ne.0)call emswrt(it,maproj+it)
1066        if(iet(it).ne.-1)call emswrt(it,maproj+it)
1067       enddo
1068
1069
1070 c --- Remnant Flavors (ProReF)
1071
1072
1073       do ip=1,maproj
1074         call ProReF(1,ip,iret)
1075         if(iret.ne.0)goto 1000
1076       enddo
1077       do it=1,matarg
1078         call ProReF(-1,it,iret)
1079         if(iret.ne.0)goto 1000
1080       enddo
1081
1082
1083 c     plot
1084 c     ----
1085
1086        if(iemspx.eq.1)then
1087        do ko=1,koll
1088         if(nprt(ko).gt.0)then
1089          do np=1,nprmx(ko)
1090           if(idpr(np,ko).gt.0)then
1091            call xEmsPx(1,sngl(xpr(np,ko)),sngl(ypr(np,ko)),nprt(ko))
1092           endif
1093          enddo
1094         endif
1095        enddo
1096       endif
1097
1098       if(iemspbx.eq.1)then
1099        do k=1,koll
1100         if(nprt(k).gt.0)then
1101          do n=1,nprmx(k)
1102           if(idpr(n,k).eq.3)then
1103             je1=min(1,nemispr(1,n,k))
1104             je2=min(1,nemispr(2,n,k))
1105             jex=1+je1+2*je2
1106             if(itpr(k).eq.-1)then
1107               call xEmsP2(1,1+idhpr(n,k),jex
1108      *            ,sngl(xppr(n,k))
1109      *            ,sngl(xmpr(n,k))
1110      *            ,sngl(xpprbor(n,k)),sngl(xmprbor(n,k))
1111      *            ,ptprboo(1,n,k),ptprboo(2,n,k)  )
1112             else !diffractive hard pomeron
1113               call xEmsP2(1,0,jex
1114      *            ,sngl(xppr(n,k))
1115      *            ,sngl(xmpr(n,k))
1116      *            ,sngl(xpprbor(n,k)),sngl(xmprbor(n,k))
1117      *            ,ptprboo(1,n,k),ptprboo(2,n,k)  )
1118             endif
1119           endif
1120          enddo
1121         endif
1122        enddo
1123       endif
1124
1125
1126       if(iemsse.eq.1)then
1127        do ko=1,koll
1128         if(nprt(ko).gt.0)then
1129          do np=1,nprmx(ko)
1130           if(idpr(np,ko).gt.0)then
1131            ptp1=sngl(xxp1pr(np,ko)**2+xyp1pr(np,ko)**2)
1132            ptp2=sngl(xxp2pr(np,ko)**2+xyp2pr(np,ko)**2)
1133            ptm1=sngl(xxm1pr(np,ko)**2+xym1pr(np,ko)**2)
1134            ptm2=sngl(xxm2pr(np,ko)**2+xym2pr(np,ko)**2)
1135            call xEmsSe(1,sngl(xp1pr(np,ko)),ptp1,1,1)
1136            call xEmsSe(1,sngl(xp2pr(np,ko)),ptp2,1,1)
1137            call xEmsSe(1,sngl(xm1pr(np,ko)),ptm1,-1,1)
1138            call xEmsSe(1,sngl(xm2pr(np,ko)),ptm2,-1,1)
1139            call xEmsSe(1,sngl(xp1pr(np,ko)),sngl(xm1pr(np,ko)),1,2)
1140            call xEmsSe(1,sngl(xm2pr(np,ko)),sngl(xp2pr(np,ko)),1,2)
1141           endif
1142          enddo
1143         endif
1144        enddo
1145       endif
1146
1147       if(iemsdr.eq.1)then
1148        do i=maproj+matarg+1,nptl
1149         if(istptl(iorptl(i)).eq.41)then
1150           xpdr=(pptl(4,i)+pptl(3,i))/sngl(plc)
1151           xmdr=(pptl(4,i)-pptl(3,i))/sngl(plc)
1152           if(ityptl(i).eq.41)call xEmsDr(1,xpdr,xmdr,1)
1153           if(ityptl(i).eq.51)call xEmsDr(1,xpdr,xmdr,2)
1154           if(ityptl(i).eq.42)call xEmsDr(1,xpdr,xmdr,3)
1155           if(ityptl(i).eq.52)call xEmsDr(1,xpdr,xmdr,4)
1156         endif
1157        enddo
1158       endif
1159
1160       if(iemsrx.eq.1)then
1161        do i=1,maproj
1162         if(kolp(i).gt.0)call xEmsRx(1,1,sngl(xpp(i)),sngl(xmp(i)))
1163        enddo
1164        do j=1,matarg
1165         if(kolt(j).gt.0)call xEmsRx(1,2,sngl(xmt(j)),sngl(xpt(j)))
1166        enddo
1167       endif
1168
1169       if(ixbDens.eq.1)call xbDens(1)
1170
1171 c     exit
1172 c     ----
1173
1174  1000 continue
1175 c      write(*,*)'emsaa-iret',iret
1176       if(ish.ge.2.and.iret.ne.0)write(ifch,*)'iret not 0 (ems)=> redo'
1177      &                                       ,iret,ivi
1178       call utprix('emsaa ',ish,ishini,4)
1179       return
1180       end
1181
1182
1183 c----------------------------------------------------------------------
1184       subroutine StoCon(mode,k,n)
1185 c----------------------------------------------------------------------
1186 c store or restore configuration
1187 c   mode = 1 (store) or -1 (restore)
1188 c   k = collision index
1189 c   n = pomeron index
1190 c----------------------------------------------------------------------
1191
1192       include 'epos.inc'
1193       include 'epos.incems'
1194
1195       ip=iproj(k)
1196       it=itarg(k)
1197
1198       if(mode.eq.1)then
1199
1200        do i=0,3
1201         nprx0(i)=npr(i,k)
1202        enddo
1203        nprtx0=nprt(k)
1204        idx0=idpr(n,k)
1205        xxpr0=xpr(n,k)
1206        yx0=ypr(n,k)
1207        xxppr0=xppr(n,k)
1208        xxmpr0=xmpr(n,k)
1209        nppx0=npp(ip)
1210        nptx0=npt(it)
1211        xppx0=xpp(ip)
1212        xppstx0=xppmx(ip)
1213        xmpstx0=xppmn(ip)
1214        xmtx0=xmt(it)
1215        xptstx0=xmtmx(it)
1216        xmtstx0=xmtmn(it)
1217
1218       elseif(mode.eq.2)then
1219
1220        do i=0,3
1221         nprx(i)=npr(i,k)
1222        enddo
1223        nprtx=nprt(k)
1224        idx=idpr(n,k)
1225        xxpr=xpr(n,k)
1226        yx=ypr(n,k)
1227        xxppr=xppr(n,k)
1228        xxmpr=xmpr(n,k)
1229        nppx=npp(ip)
1230        nptx=npt(it)
1231        xppx=xpp(ip)
1232        xppstx=xppmx(ip)
1233        xmpstx=xppmn(ip)
1234        xmtx=xmt(it)
1235        xptstx=xmtmx(it)
1236        xmtstx=xmtmn(it)
1237
1238       elseif(mode.eq.-1)then
1239
1240        do i=0,3
1241         npr(i,k)=nprx0(i)
1242        enddo
1243        nprt(k)=nprtx0
1244        idpr(n,k)=idx0
1245        xpr(n,k)=xxpr0
1246        ypr(n,k)=yx0
1247        xppr(n,k)=xxppr0
1248        xmpr(n,k)=xxmpr0
1249        npp(ip)=nppx0
1250        npt(it)=nptx0
1251        xpp(ip)=xppx0
1252        xppmx(ip)=xppstx0
1253        xppmn(ip)=xmpstx0
1254        xmt(it)=xmtx0
1255        xmtmx(it)=xptstx0
1256        xmtmn(it)=xmtstx0
1257
1258       elseif(mode.eq.-2)then
1259
1260        do i=0,3
1261         npr(i,k)=nprx(i)
1262        enddo
1263        nprt(k)=nprtx
1264        idpr(n,k)=idx
1265        xpr(n,k)=xxpr
1266        ypr(n,k)=yx
1267        xppr(n,k)=xxppr
1268        xmpr(n,k)=xxmpr
1269        npp(ip)=nppx
1270        npt(it)=nptx
1271        xpp(ip)=xppx
1272        xppmx(ip)=xppstx
1273        xppmn(ip)=xmpstx
1274        xmt(it)=xmtx
1275        xmtmx(it)=xptstx
1276        xmtmn(it)=xmtstx
1277
1278       else
1279       call utstop('mode should integer from -2 to 2 (without 0)&')
1280       endif
1281       return
1282       end
1283
1284 c-------------------------------------------------------------------------
1285       subroutine RemPom(k,n)
1286 c-------------------------------------------------------------------------
1287 c remove pomeron
1288 c-------------------------------------------------------------------------
1289       include 'epos.inc'
1290       include 'epos.incems'
1291
1292       ip=iproj(k)
1293       it=itarg(k)
1294       npr(idpr(n,k),k)=npr(idpr(n,k),k)-1  !nr of pomerons
1295       nprt(k)=npr(1,k)+npr(3,k)
1296       if(idpr(n,k).gt.0)then
1297        npp(ip)=npp(ip)-1                     !nr of pomerons per proj
1298        npt(it)=npt(it)-1                     !nr of pomerons per targ
1299        idpr(n,k)=0
1300        xpp(ip)=xpp(ip)+xppr(n,k)
1301        xmt(it)=xmt(it)+xmpr(n,k)
1302        xpr(n,k)=0.d0
1303        ypr(n,k)=0.d0
1304        xppr(n,k)=0.d0
1305        xmpr(n,k)=0.d0
1306
1307
1308
1309       endif
1310
1311       end
1312
1313 c-------------------------------------------------------------------------
1314       subroutine ProPo(k,n)
1315 c-------------------------------------------------------------------------
1316 c propose pomeron type = idpr(n,k
1317 c-------------------------------------------------------------------------
1318       include 'epos.inc'
1319       include 'epos.incems'
1320       double precision wzero,wzerox
1321       common/cwzero/wzero,wzerox
1322
1323       ip=iproj(k)
1324       it=itarg(k)
1325
1326       idpr(n,k)=0
1327
1328       if(dble(rangen()).gt.wzero)then
1329         idpr(n,k)=1
1330
1331
1332 c nbr of pomerons per proj
1333        npp(ip)=npp(ip)+1
1334 c nbr of pomerons per targ
1335        npt(it)=npt(it)+1
1336
1337       endif
1338
1339       npr(idpr(n,k),k)=npr(idpr(n,k),k)+1 !nr of pomerons
1340       nprt(k)=npr(1,k)+npr(3,k)
1341
1342
1343       end
1344
1345
1346 c-------------------------------------------------------------------------
1347       subroutine ProXY(k,n)
1348 c-------------------------------------------------------------------------
1349 c propose pomeron x,y
1350 c-------------------------------------------------------------------------
1351
1352       include 'epos.inc'
1353       include 'epos.incpar'
1354       include 'epos.incems'
1355       include 'epos.incsem'
1356       double precision xp,xm,om1xprk,om1xmrk,anip,anit,eps
1357      &,xprem,xmrem,xprm,xmrm
1358       parameter (eps=1.d-30)
1359
1360
1361       ip=iproj(k)
1362       it=itarg(k)
1363
1364
1365       xpr(n,k)=0.d0
1366       ypr(n,k)=0.d0
1367
1368       if(idpr(n,k).ne.0)then
1369           xprem=xpp(ip)
1370           xmrem=xmt(it)
1371 c because of fom, it's not symetric any more if we choose always xp first
1372 c and then xm ... so choose it randomly.
1373           if(rangen().lt.0.5)then
1374             xp=om1xprk(k,xprem,xminDf,1)
1375             xmrm=xmrem
1376             xprm=xminDf
1377             xm=om1xmrk(k,xp,xprm,xmrm,1)
1378           else
1379             xm=om1xprk(k,xmrem,xminDf,-1)
1380             xmrm=xminDf
1381             xprm=xprem
1382             xp=om1xmrk(k,xm,xmrm,xprm,-1)
1383           endif
1384           xpr(n,k)=xp*xm
1385           ypr(n,k)=0.d0
1386           if(xm.gt.eps.and.xp.gt.eps)then
1387             ypr(n,k)=0.5D0*dlog(xp/xm)
1388             xppr(n,k)=xp
1389             xmpr(n,k)=xm
1390           else
1391             if(ish.ge.1)write(ifmt,*)'Warning in ProXY ',xp,xm
1392             npr(idpr(n,k),k)=npr(idpr(n,k),k)-1
1393             idpr(n,k)=0
1394             npr(idpr(n,k),k)=npr(idpr(n,k),k)+1
1395             xpr(n,k)=0.d0
1396             ypr(n,k)=0.d0
1397             xppr(n,k)=0.d0
1398             xmpr(n,k)=0.d0
1399             nprt(k)=npr(1,k)+npr(3,k)
1400             npp(ip)=npp(ip)-1   !nr of pomerons per proj
1401             npt(it)=npt(it)-1   !nr of pomerons per targ
1402           endif
1403
1404 c Update xp and xm of remnant, and change the limit to have big enought mass.
1405
1406         anip=dble(npp(ip))
1407         anit=dble(npt(it))
1408         xpp(ip)=xpp(ip)-xppr(n,k)
1409         xppmn(ip)=min(1.d0,anip*xpmn(ip)/xmpmx(ip))
1410         xmt(it)=xmt(it)-xmpr(n,k)
1411         xmtmn(it)=min(1.d0,anit*xtmn(it)/xptmx(it))
1412
1413       endif
1414
1415       end
1416
1417 c-------------------------------------------------------------------------
1418       double precision function wmatrix(k,n)
1419 c-------------------------------------------------------------------------
1420 c proposal matrix w(a->b), considering pomeron type, x, y
1421 c-------------------------------------------------------------------------
1422
1423       include 'epos.incems'
1424       double precision wzero,wzerox,Womegak,xprem,xmrem,om1intgck
1425       common/cwzero/wzero,wzerox
1426
1427
1428 c      ip=iproj(k)
1429 c      it=itarg(k)
1430
1431       if(idpr(n,k).eq.0)then
1432         wmatrix=wzero
1433       else
1434           xprem=1.d0!xpp(ip)+xppr(n,k)
1435           xmrem=1.d0!xmt(it)+xmpr(n,k)
1436           wmatrix=(1d0-wzero)/om1intgck(k,xprem,xmrem)
1437      *           *Womegak(xppr(n,k),xmpr(n,k),xprem,xmrem,k)
1438       endif
1439
1440
1441       end
1442
1443 c-------------------------------------------------------------------------
1444       double precision function omega(n,k)
1445 c-------------------------------------------------------------------------
1446 c calculates partial omega for spot (k,n)
1447 c-------------------------------------------------------------------------
1448
1449       include 'epos.inc'
1450       include 'epos.incems'
1451       include 'epos.incsem'
1452       common/cwzero/wzero,wzerox
1453       double precision wzero,wzerox,eps
1454       parameter(eps=1.d-15)
1455       double precision PhiExpoK,omGamk,xp,xm,fom
1456       double precision plc,s
1457       common/cems5/plc,s
1458       common/nucl3/phi,bimp
1459
1460       omega=0.d0
1461
1462       ip=iproj(k)
1463       it=itarg(k)
1464
1465       if(xpp(ip).lt.xppmn(ip)+eps.or.xpp(ip).gt.1.d0+eps)goto 1001
1466       if(xmt(it).lt.xmtmn(it)+eps.or.xmt(it).gt.1.d0+eps)goto 1001
1467
1468       omega=xpp(ip)**dble(alplea(iclpro))
1469      &     *xmt(it)**dble(alplea(icltar))
1470
1471 c      ztg=0
1472 c      zpj=0
1473 c      nctg=0
1474 c      ncpj=0
1475 c      zsame=nprt(k)
1476 c      if(idpr(n,k).gt.0)then
1477 c        if(nprt(k).le.0)stop'omega: nprt(k) should be positive !!!!    '
1478 c        zsame=zsame-1
1479 c      endif
1480 c      nlpop=nint(zsame)
1481 c      nlpot=nint(zsame)
1482 c      bglaub2=sigine/10./pi        !10= fm^2 -> mb
1483 c      bglaub=sqrt(bglaub2)
1484 c      b2x=epscrp*epscrp*bglaub2
1485 c      b2=bk(k)**2
1486 c      ztgx=epscrw*exp(-b2/2./b2x)*fscra(engy/egyscr)
1487 c      zpjx=epscrw*exp(-b2/2./b2x)*fscra(engy/egyscr)
1488 c
1489 c      if(koll.gt.1)then
1490 c        do li=1,lproj(ip)
1491 c          kk=kproj(ip,li)
1492 c          if(kk.ne.k)then
1493 c            b2=bk(kk)**2
1494 c            if(b2.le.bglaub2)nctg=nctg+1
1495 c            ztg=ztg+epscrw*exp(-b2/2./b2x)*fscro(engy/egyscr)
1496 c            nlpop=nlpop+nprt(kk)
1497 c          endif
1498 c        enddo
1499 c        do li=1,ltarg(it)
1500 c          kk=ktarg(it,li)
1501 c          if(kk.ne.k)then
1502 c            b2=bk(kk)**2
1503 c            if(b2.le.bglaub2)ncpj=ncpj+1
1504 c            zpj=zpj+epscrw*exp(-b2/2./b2x)*fscro(engy/egyscr)
1505 c            nlpot=nlpot+nprt(kk)
1506 c          endif
1507 c        enddo
1508 c      endif
1509       !  zpjx+zpj is equal to zparpro(k)
1510       !  ztgx+ztg is equal to zpartar(k)
1511       zprj=zparpro(k)  !zsame+zpj
1512       ztgt=zpartar(k)  !zsame+ztg
1513 c      if(npp(ip).gt.nfctrl)stop'nfctrl too small (1)         '
1514 c      if(npt(it).gt.nfctrl)stop'nfctrl too small (2)         '
1515       if(idpr(n,k).eq.0)then
1516         omega=omega*wzerox
1517       else
1518         xp=xppr(n,k)
1519         xm=xmpr(n,k)
1520 c        !-------------------------------------------------------------------------
1521 c        ! fom : part of Phi regularization; Phi -> Phi^(n) (n = number of Poms)
1522 c        ! Phi^(0) relevant for Xsect unchanged, apart of (maybe) normalization (Z)
1523 c        !-------------------------------------------------------------------------
1524         omega=omega*omGamk(k,xp,xm)*gammaV(k)*fom(zprj,xm,bk(k))
1525      &                                       *fom(ztgt,xp,bk(k))
1526       endif
1527
1528       omega=omega*PhiExpoK(k,xpp(ip),xmt(it))
1529
1530
1531       if(omega.le.0.d0)goto 1001
1532
1533       if(koll.gt.1)then
1534         do li=1,lproj(ip)
1535           kk=kproj(ip,li)
1536           if(itarg(kk).ne.it)then
1537             ipl=iproj(kk)
1538             itl=itarg(kk)
1539             omega=omega*PhiExpoK(kk,xpp(ipl),xmt(itl))
1540             if(omega.le.0.d0)goto 1001
1541           endif
1542         enddo
1543         do li=1,ltarg(it)
1544           kk=ktarg(it,li)
1545           if(iproj(kk).ne.ip)then
1546             ipl=iproj(kk)
1547             itl=itarg(kk)
1548             omega=omega*PhiExpoK(kk,xpp(ipl),xmt(itl))
1549             if(omega.le.0.d0)goto 1001
1550           endif
1551         enddo
1552       endif
1553
1554       if(omega.lt.1.d-100)then
1555         if(ish.ge.6)write(*,*)'omega-exit',omega
1556         omega=0.d0
1557       elseif(omega.gt.1.d100)then
1558         if(ish.ge.6)write(*,*)'omega-exit',omega
1559         omega=0.d0
1560       endif
1561
1562       return
1563
1564  1001 continue
1565
1566       omega=0.d0
1567       return
1568
1569       end
1570
1571 c-------------------------------------------------------------------------
1572       double precision function fom(z,x,b)
1573 c-------------------------------------------------------------------------
1574       include 'epos.inc'
1575       double precision x,u,w,z0
1576       !----------------------------------------------------------------
1577       ! part of Phi regularization; Phi -> Phi^(n) (n = number of Poms)
1578       ! Phi^(0) relevant for Xsect unchanged
1579       !----------------------------------------------------------------
1580       fom=1d0
1581       if(z.gt.0..and.alpfomi.gt.0.)then
1582        z0=dble(alpfomi)
1583        u=dble(z**gamfom)
1584 c       u=z0*dble(z/z0)**2.
1585        w=u/z0*exp(-dble(b*b/delD(1,iclpro,icltar)))
1586 c       w=10.d0*u
1587        !---------------------------------------------------
1588        !e=exp(-0.05*u)  !analytic function with e(0)=1
1589        !fom=((1-u)+(u+w)*sqrt(x**2+((u-1+e)/(u+w))**2))
1590        !     fom(z=0)=1  fom(x=0)=e  fom(x=1)~w
1591        !---------------------------------------------------
1592        fom=1.d0+w*x**betfom
1593        !---------------------------------------------------
1594       endif
1595       end
1596
1597 c-------------------------------------------------------------------------
1598       subroutine ProNucSpl(ir,ii)
1599 c-------------------------------------------------------------------------
1600 c propose nuclear splitting
1601 c for proj (iep) if ir=1 or target (iet) if ir=-1
1602 c If remnant full of parton, force excitation to mimic fan diagram connections
1603 c-------------------------------------------------------------------------
1604
1605       include 'epos.inc'
1606       include 'epos.incsem'
1607       include 'epos.incems'
1608       double precision alp,eps,xrr,zfrac(kollmx),zsum,xk,proba,xp,xm,xr0
1609      &,drangen,omGamk,PomInt!,PomIncPExact,PomIncMExact
1610       integer knopp(kollmx)
1611       parameter(eps=1.d-10)
1612
1613
1614       if(ir.eq.1)then                   !proj
1615
1616         ip=ii
1617         zzz=zzremn(ip,1)!excite more if many nucleon connected or if in nucleus
1618         if(ish.ge.4)write(ifch,*)'ProNucSpl proj:',ip,zzz
1619         r=rangen()
1620         if(r.gt.exp(-min(50.,zrminc*zzz)))then
1621           iep(ip)=5
1622           if(kolp(ip).eq.0)then
1623           if(1.d0-xpp(ip).gt.eps)stop'ProNucSpl: should not happen (2)'
1624             alp=1.d0/(1.d0+dble(alplea(iclpro)))
1625             ncon=0
1626             zsum=0d0
1627             do l=1,lproj3(ip)
1628               kp=kproj3(ip,l)
1629               it=itarg(kp)
1630               if(kolt(it).gt.0)then
1631                 do m=1,ltarg3(it)
1632                   kt=ktarg3(it,m)
1633                   if(itpr(kt).gt.0)then
1634                     do n=1,nprmx(kt)
1635                       if(xpr(n,kt).gt.xzcutpar(kt))then
1636                         ncon=ncon+1
1637                         knopp(ncon)=kt
1638                         zfrac(ncon)=dble(zparpro(kt))
1639                         zsum=zsum+zfrac(ncon)
1640                       endif
1641                     enddo
1642                   endif
1643                 enddo
1644               endif
1645             enddo
1646             if(ish.ge.4)write(ifch,*)'ProNucSpl zsum:',zsum,ncon
1647             if(zsum.gt.0d0)then
1648               xr0=xpp(ip)-drangen(xpp(ip))**alp
1649               xrr=xr0
1650               if(ish.ge.6)write(ifch,*)'xrr:',xrr
1651               do nc=1,ncon
1652                 k=knopp(nc)
1653                 xk=zfrac(nc)/zsum*xr0
1654                 if(ish.ge.6)write(ifch,*)'xk:',nc,k,xk
1655                 ipp=iproj(k)
1656                 itt=itarg(k)
1657                 do n=1,nprmx(k)
1658                   if(xpr(n,k).gt.xzcutpar(k))then
1659                     xp=xppr(n,k)+xk
1660                     if(xp.lt.1d0)then
1661 c accept xp with probability GFF/PomIncExact
1662                      PomInt=PomInck(k)
1663                      if(PomInt.gt.0d0)then
1664                       proba=omGamk(k,xp,xmpr(n,k))
1665      &                   *xrr**dble(alplea(iclpro))
1666      &                   *xpp(ipp)**dble(alplea(iclpro))
1667      &                   *xmt(itt)**dble(alplea(icltar))
1668      &                   /PomInt
1669                       if(drangen(proba).lt.proba)then !accept xp for pair k
1670                         xppr(n,k)=xp
1671                         xpr(n,k)=xppr(n,k)*xmpr(n,k)
1672                         ypr(n,k)=0.5D0*log(xppr(n,k)/xmpr(n,k))
1673                         xpp(ip)=xpp(ip)-xk
1674                         knucnt(1,k)=knucnt(1,k)+1 !store info of momentum transfer
1675                         irnuc(knucnt(1,k),1,k)=ip !in case of virpom later
1676                         npnuc(knucnt(1,k),1,k)=n
1677                         xxnuc(knucnt(1,k),1,k)=xk
1678                         if(ish.ge.6)write(ifch,*)'Transfer:'
1679      &                                          ,knucnt(1,k),k,n,xk,ip
1680                         goto 10
1681                       endif
1682                      endif
1683                     endif
1684                   endif
1685                 enddo
1686                 xrr=xrr-xk
1687  10             continue
1688               enddo
1689               if(xrr.lt.eps)then
1690                 iep(ip)=0       !excitation not possible
1691                 zzremn(ip,1)=0.
1692               endif
1693               if(ish.ge.4)write(ifch,*)'ProNucSpl out:',iep(ip),xrr
1694             else
1695               iep(ip)=0
1696               zzremn(ip,1)=0.
1697               if(ish.ge.4)write(ifch,*)'ProNucSpl out:',iep(ip)
1698             endif
1699           else
1700             if(ish.ge.4)write(ifch,*)'ProNucSpl out:',iep(ip)
1701           endif
1702         else
1703           iep(ip)=0
1704         endif
1705
1706
1707       elseif(ir.eq.-1)then      !targ
1708
1709         it=ii
1710         zzz=zzremn(it,2)!excite more if many nucleon connected or if in nucleus
1711         if(ish.ge.4)write(ifch,*)'ProNucSpl targ:',it,zzz
1712         r=rangen()
1713         if(r.gt.exp(-min(50.,zrminc*zzz)))then
1714           iet(it)=5
1715           if(kolt(it).eq.0)then
1716           if(1.d0-xmt(it).gt.eps)stop'ProNucSpl: should not happen (4)'
1717             alp=1.d0/(1.d0+dble(alplea(icltar)))
1718             ncon=0
1719             zsum=0d0
1720             do l=1,ltarg3(it)
1721               kt=ktarg3(it,l)
1722               ip=iproj(kt)
1723               if(kolp(ip).gt.0)then
1724                 do m=1,lproj3(ip)
1725                   kp=kproj(ip,m)
1726                   if(itpr(kp).gt.0)then
1727                     do n=1,nprmx(kp)
1728                       if(xpr(n,kp).gt.xzcutpar(kp))then
1729                         ncon=ncon+1
1730                         knopp(ncon)=kp
1731                         zfrac(ncon)=dble(zpartar(kp))
1732                         zsum=zsum+zfrac(ncon)
1733                       endif
1734                     enddo
1735                   endif
1736                 enddo
1737               endif
1738             enddo
1739             if(ish.ge.4)write(ifch,*)'ProNucSpl zsum:',zsum,ncon
1740             if(zsum.gt.0d0)then
1741               xr0=xmt(it)-drangen(xmt(it))**alp
1742               xrr=xr0
1743               if(ish.ge.6)write(ifch,*)'xrr:',xrr
1744               do nc=1,ncon
1745                 k=knopp(nc)
1746                 xk=zfrac(nc)/zsum*xr0
1747                 if(ish.ge.6)write(ifch,*)'xk:',nc,k,xk
1748                 ipp=iproj(k)
1749                 itt=itarg(k)
1750                 do n=1,nprmx(k)
1751                   if(xpr(n,k).gt.xzcutpar(k))then
1752                     xm=xmpr(n,k)+xk
1753                     if(xm.lt.1d0)then
1754 c accept xp with probability GFF/PomIncExact
1755                      PomInt=PomInck(k)
1756                      if(PomInt.gt.0d0)then
1757                       proba=omGamk(k,xppr(n,k),xm)
1758      &                     *xpp(ipp)**dble(alplea(iclpro))
1759      &                     *xmt(itt)**dble(alplea(icltar))
1760      &                     *xrr**dble(alplea(icltar))
1761      &                     / PomInt
1762                       if(drangen(proba).lt.proba)then !accept xp for pair k
1763                         xmpr(n,k)=xm
1764                         xpr(n,k)=xppr(n,k)*xmpr(n,k)
1765                         ypr(n,k)=0.5D0*log(xppr(n,k)/xmpr(n,k))
1766                         xmt(it)=xmt(it)-xk
1767                         knucnt(2,k)=knucnt(2,k)+1 !store info of momentum transfer
1768                         irnuc(knucnt(2,k),2,k)=it !in case of virpom later
1769                         npnuc(knucnt(2,k),2,k)=n
1770                         xxnuc(knucnt(2,k),2,k)=xk
1771                         if(ish.ge.6)write(ifch,*)'Transfer:'
1772      &                                          ,knucnt(2,k),k,n,xk,it
1773                         goto 20
1774                       endif
1775                      endif
1776                     endif
1777                   endif
1778                 enddo
1779                 xrr=xrr-xk
1780  20             continue
1781               enddo
1782               if(xrr.lt.eps)then
1783                 iet(it)=0       !excitation not possible
1784                 zzremn(it,2)=0.
1785               endif
1786               if(ish.ge.4)write(ifch,*)'ProNucSpl out:',iet(it),xrr
1787             else
1788               iet(it)=0
1789               zzremn(it,2)=0.
1790               if(ish.ge.4)write(ifch,*)'ProNucSpl out:',iet(it)
1791             endif
1792           else
1793             if(ish.ge.4)write(ifch,*)'ProNucSpl out:',iet(it)
1794           endif
1795         else
1796           iet(it)=0
1797         endif
1798       endif
1799
1800       end
1801
1802 c-------------------------------------------------------------------------
1803       subroutine ProPoTy(k,n)
1804 c-------------------------------------------------------------------------
1805 c propose pomeron type
1806 c-------------------------------------------------------------------------
1807
1808       include 'epos.inc'
1809       include 'epos.incems'
1810       include 'epos.incsem'
1811       common/cems5/plc,s
1812       double precision s,plc
1813       double precision ww,w0,w1,w2,w3,w4,w5,w(0:7),aks,eps,zdiff
1814      *,xh,yp!,xp,xm
1815       parameter(eps=1.d-10)
1816       logical cont
1817       dimension nnn(3),kkk(3)
1818
1819       if(idpr(n,k).eq.0)return
1820       ip=iproj(k)
1821       it=itarg(k)
1822       if(ish.ge.4)write(ifch,*)'ProPoTy:k,n,idpr,x',k,n,ip,it,nprt(k)
1823      *                                              ,idpr(n,k),xpr(n,k)
1824       if(idpr(n,k).ne.1)call utstop('ProPoTy: should not happen&')
1825
1826       cont=.true.
1827       do i=1,3
1828         nnn(i)=0
1829         kkk(i)=0
1830       enddo
1831
1832       idfpr(n,k)=1
1833       xh=xpr(n,k)
1834       yp=ypr(n,k)
1835 c      xp=xppr(n,k)
1836 c      xm=xmpr(n,k)
1837       nnn(3)=n
1838       kkk(3)=k
1839
1840       if(iep(ip).ne.5)iep(ip)=-1
1841       if(iet(it).ne.5)iet(it)=-1
1842
1843
1844       idpr(n,k)=1
1845
1846         w0=0.d0
1847         w1=0.d0
1848         w2=0.d0
1849         w3=0.d0
1850         w4=0.d0
1851         w5=0.d0
1852
1853         call WomTy(w,xh,yp,k)
1854
1855
1856         if(w(0).gt.0.d0)w0=w(0)
1857         if(w(1).gt.0.d0)w1=w(1)
1858         if(iremn.ge.2)then
1859           if(w(2).gt.0.d0)then                 !q-g
1860             if(ivp(ip).gt.0)then
1861               w2=w(2)
1862             else
1863               w1=w1+w(2)
1864             endif
1865           endif
1866           if(w(3).gt.0.d0)then                 !g-q
1867             if(ivt(it).gt.0)then
1868               w3=w(3)
1869             else
1870               w1=w1+w(3)
1871             endif
1872           endif
1873           if(w(4).gt.0.d0)then                 !q-q
1874             if(ivp(ip)*ivt(it).gt.0)then
1875               w4=w(4)
1876             else
1877               w1=w1+w(4)
1878             endif
1879           endif
1880         else
1881           if(w(2).gt.0.d0)w2=w(2)
1882           if(w(3).gt.0.d0)w3=w(3)
1883           if(w(4).gt.0.d0)w4=w(4)
1884         endif
1885         if(w(5).gt.0.d0)w5=w(5)
1886
1887         ww=w0+w1+w2+w3+w4+w5
1888         if(ish.ge.4)write(ifch,*)'ProPoTy:ww,ww_i'
1889      *       ,ww,w0/ww*100.d0,w1/ww*100.d0,w2/ww*100.d0
1890      *       ,w3/ww*100.d0,w4/ww*100.d0,w5/ww*100.d0
1891
1892
1893         aks=dble(rangen())*ww
1894
1895         if(ww.lt.eps.or.aks.le.w0)then            !soft pomeron
1896
1897           itpr(k)=-2*npommx        !Pair is not diffractive
1898           if(ish.ge.5)write(ifch,*)'ProPoTy:idpr',idpr(n,k)
1899
1900         elseif(aks.ge.ww-w5)then !diffractive interaction
1901
1902           itpr(k)=itpr(k)+2
1903 c the probability to have a real diffractive Pomeron increase with Z and hard P
1904 c          zdiff=exp(-min(50.d0,dble(zdfinc*(zparpro(k)+zpartar(k)))*w1))
1905           zdiff=1d0/sqrt(1d0+dble(zdfinc*(zparpro(k)+zpartar(k)))*w1)
1906 c          print *,xpr(n,k),zdiff,w1!,zdiff2
1907           if(ish.ge.5)write(ifch,*)'ProPoTy:itpr',itpr(k),zdiff
1908           if(xpr(n,k).gt.xzcutpar(k).and.rangen().gt.zdiff)then
1909 c          if(rangen().gt.zdiff)then
1910 c High mass diffraction : Keep pomeron and choose between soft and semi-hard
1911             aks=dble(rangen())*(w0+w1)
1912             if(aks.gt.w0)then
1913               idpr(n,k)=3
1914               npr(3,k)=npr(3,k)+1
1915               npr(1,k)=npr(1,k)-1
1916               bhpr(n,k)=bk(k)
1917               idhpr(n,k)=0
1918 c            elseif(iLHC.eq.1)then
1919 c              idpr(n,k)=-1
1920             endif
1921           else
1922            if(iLHC.eq.1)then     !LHC tune
1923 c keep soft Pomeron for later
1924               idpr(n,k)=-1
1925            else                     !original CR
1926 c Low mass diffraction : no pomeron
1927 c restore x from nuclear splitting
1928             if(knucnt(1,k).gt.0)then
1929               do nuc=1,knucnt(1,k)
1930                 if(npnuc(nuc,1,k).eq.n)then
1931                   ipp=irnuc(nuc,1,k)
1932                   xpp(ipp)=xpp(ipp)+xxnuc(nuc,1,k)
1933                   if(xpp(ipp)-1d0.ge.-1d-10)iep(ipp)=0
1934                   xppr(n,k)=xppr(n,k)-xxnuc(nuc,1,k)
1935                   xpr(n,k)=xppr(n,k)*xmpr(n,k)
1936                   ypr(n,k)=0.5D0*log(xppr(n,k)/xmpr(n,k))
1937                   npnuc(nuc,1,k)=0 !to be sure not to use it again
1938                 endif
1939               enddo
1940             endif
1941             if(knucnt(2,k).gt.0)then
1942               do nuc=1,knucnt(2,k)
1943                 if(npnuc(nuc,2,k).eq.n)then
1944                   itt=irnuc(nuc,2,k)
1945                   xmt(itt)=xmt(itt)+xxnuc(nuc,2,k)
1946                   if(xmt(itt)-1d0.ge.-1d-10)iet(itt)=0
1947                   xmpr(n,k)=xmpr(n,k)-xxnuc(nuc,2,k)
1948                   xpr(n,k)=xppr(n,k)*xmpr(n,k)
1949                   ypr(n,k)=0.5D0*log(xppr(n,k)/xmpr(n,k))
1950                   npnuc(nuc,2,k)=0 !to be sure not to use it again
1951                 endif
1952               enddo
1953             endif
1954             call RemPom(k,n)
1955             idfpr(n,k)=0
1956             npr(0,k)=npr(0,k)+1 !nr of empty cells
1957             kolp(ip)=kolp(ip)-1 !suppress diffractive collision from the remnant
1958             kolt(it)=kolt(it)-1 !it will be restored if the pair is diffractive
1959             if(ish.ge.6)write(ifch,*)'ProPoTy:idpr',idpr(n,k)
1960           endif
1961
1962          endif
1963
1964         else
1965
1966           itpr(k)=-2*npommx        !Pair is not diffractive
1967           idpr(n,k)=3
1968           if(ish.ge.5)write(ifch,*)'ProPoTy:idpr',idpr(n,k)
1969           npr(3,k)=npr(3,k)+1
1970           npr(1,k)=npr(1,k)-1
1971           bhpr(n,k)=bk(k)
1972
1973           aks=aks-w0
1974           if(aks.le.w1)then                             !gg-pomeron
1975             idhpr(n,k)=0
1976           elseif(aks.le.w1+w2)then                      !qg-pomeron
1977             idhpr(n,k)=1
1978             ivp(ip)=ivp(ip)-1
1979           elseif(aks.le.w1+w2+w3)then                   !gq-pomeron
1980             idhpr(n,k)=2
1981             ivt(it)=ivt(it)-1
1982           elseif(aks.le.w1+w2+w3+w4)then                !qq-pomeron
1983             idhpr(n,k)=3
1984             ivp(ip)=ivp(ip)-1
1985             ivt(it)=ivt(it)-1
1986           else
1987             call utstop('ems-unknown pomeron&')
1988           endif
1989           if(ish.ge.6)write(ifch,*)'ProPoTy:idhpr',idhpr(n,k)
1990      &         ,' |',ip,ivp(ip),' |',it,ivt(it)
1991
1992         endif
1993
1994         if(idfpr(n,k).eq.1)then
1995           antot=antot+1
1996           antotf=antotf+1
1997           if(abs(idpr(n,k)).eq.1)then
1998             ansf=ansf+1
1999             ansff=ansff+1
2000           endif
2001           if(idpr(n,k).eq.3)then
2002             ansh=ansh+1
2003             anshf=anshf+1
2004           endif
2005         endif
2006
2007       do i=3,1,-1
2008
2009         if(nnn(i).ne.0.and.kkk(i).ne.0.and.cont)then
2010
2011           if(idpr(nnn(i),kkk(i)).eq.3)then
2012
2013                        !Backup soft Pomeron if sh not possible later
2014
2015             kb=kkk(i)
2016             nb=nnn(i)
2017             ip=iproj(kb)
2018             it=itarg(kb)
2019             do nn=1,nprmx(kb)
2020               if(idpr(nn,kb).eq.0)then !empty spot
2021                 nbkpr(nb,kb)=nn
2022                 nvpr(nn,kb)=nb
2023                 idpr(nn,kb)=1
2024                 ivpr(nn,kb)=2
2025                 xpr(nn,kb)=xpr(nb,kb)
2026                 ypr(nn,kb)=ypr(nb,kb)
2027                 xppr(nn,kb)=xppr(nb,kb)
2028                 xmpr(nn,kb)=xmpr(nb,kb)
2029                 idfpr(nn,kb)=-idfpr(nb,kb)
2030                 bhpr(nn,kb)=bhpr(nb,kb)
2031                 idp1pr(nn,kb)=0
2032                 idp2pr(nn,kb)=0
2033                 idm1pr(nn,kb)=0
2034                 idm2pr(nn,kb)=0
2035                 xm1pr(nn,kb)=0.d0
2036                 xp1pr(nn,kb)=0.d0
2037                 xm2pr(nn,kb)=0.d0
2038                 xp2pr(nn,kb)=0.d0
2039                 xxm1pr(nn,kb)=0.d0
2040                 xym1pr(nn,kb)=0.d0
2041                 xxp1pr(nn,kb)=0.d0
2042                 xyp1pr(nn,kb)=0.d0
2043                 xxm2pr(nn,kb)=0.d0
2044                 xym2pr(nn,kb)=0.d0
2045                 xxp2pr(nn,kb)=0.d0
2046                 xyp2pr(nn,kb)=0.d0
2047                 goto 10
2048               endif
2049             enddo
2050       if(ish.ge.2)write(ifmt,*)'no empty lattice site, backup lost'
2051
2052  10         continue
2053           endif
2054         endif
2055       enddo
2056
2057       return
2058       end
2059
2060 c-------------------------------------------------------------------------
2061       subroutine ProDiSc(k)
2062 c-------------------------------------------------------------------------
2063 c propose diffractive scattering
2064 c-------------------------------------------------------------------------
2065
2066       include 'epos.incems'
2067
2068       ip=iproj(k)
2069       it=itarg(k)
2070       kolp(ip)=kolp(ip)+itpr(k)/2 !number of diffractive Pomerons
2071       kolt(it)=kolt(it)+itpr(k)/2 !on remnants
2072
2073
2074       end
2075
2076 c-------------------------------------------------------------------------
2077       subroutine ProReEx(ir,ii)
2078 c-------------------------------------------------------------------------
2079 c propose remnant excitation
2080 c for proj (iep) if ir=1 or target (iet) if ir=-1:
2081 c 0 = no,  1 = inel excitation,  2 = diffr excitation
2082 c fixed before : 5 = excit due to split without connection
2083 c fixed after : 3 = large excitation due to # quark > 3
2084 c               6 = active spectator (get small pt and used for mass)
2085 c propose "pion exchange" process for diffractive remnant excitation
2086 c for proj (iep) if ir=2 or target (iet) if ir=-2:
2087 c 4 = diffr excitation but with fixed minimum excited mass
2088 c-------------------------------------------------------------------------
2089
2090       include 'epos.inc'
2091       include 'epos.incsem'
2092       include 'epos.incems'
2093       include 'epos.incpar'
2094
2095
2096       if(ir.eq.1)then                   !proj
2097
2098         ip=ii
2099         mine=0
2100         mdif=0
2101         do l=1,lproj(ip)
2102           kp=kproj(ip,l)
2103           if(itpr(kp).lt.0)mine=1
2104           if(itpr(kp).gt.0)mdif=1
2105         enddo
2106         r=rangen()
2107         if(mine.eq.1)then   !inelastic
2108           if(iremn.eq.1)then
2109 c increase excitation probability with number of close enough nucleons
2110             if(r.lt.1.-(1.-rexndi(iclpro))**(kolp(ip)
2111      &          *(1.+rexres(iclpro)*log(max(1.,float(lproj(ip)))))))then
2112               iep(ip)=1
2113             else
2114               iep(ip)=0
2115             endif
2116           elseif(iremn.ne.0)then
2117 c increase of inelastic remnant excitation in pA needed for Barton
2118             if(r.lt.1.-(1.-rexndi(iclpro))
2119      &         **(1.+rexres(iclpro)*float(lproj(ip)-1)))then
2120               iep(ip)=1
2121             else
2122               iep(ip)=0
2123             endif
2124           else!if(iremn.ne.2)then
2125             if(r.lt.rexndi(iclpro))then
2126               iep(ip)=1
2127             else
2128               iep(ip)=0
2129             endif
2130           endif
2131         elseif(mdif.eq.1)then        !diffr
2132           if(iremn.eq.1)then
2133 c increase excitation probability with number of close enough nucleons
2134             if(r.lt.1.-(1.-rexdif(iclpro))**(kolp(ip)
2135      &          *(1.+rexres(iclpro)*log(max(1.,float(lproj(ip)))))))then
2136               iep(ip)=2
2137             else
2138               iep(ip)=0
2139             endif
2140           elseif(iremn.ne.0)then
2141 c increase of diffractive remnant excitation in pA needed for Barton
2142             if(r.lt.1.-(1.-rexdif(iclpro))
2143      &        **(1.+rexres(iclpro)*float(lproj(ip)-1)))then
2144               iep(ip)=2
2145             else
2146               iep(ip)=0
2147             endif
2148           else
2149             if(r.lt.1.-(1.-rexdif(iclpro)))then
2150               iep(ip)=2
2151             else
2152               iep(ip)=0
2153             endif
2154           endif
2155         elseif(iep(ip).ne.5)then
2156 c for non-excited spectators
2157           iep(ip)=0
2158         endif
2159
2160       elseif(ir.eq.-1)then                !targ
2161
2162         it=ii
2163         mine=0
2164         mdif=0
2165         do l=1,ltarg(it)
2166           kt=ktarg(it,l)
2167           if(itpr(kt).lt.0)mine=1
2168           if(itpr(kt).gt.0)mdif=1
2169         enddo
2170         r=rangen()
2171         if(mine.eq.1)then   !inelastic
2172           if(iremn.eq.1)then
2173             if(r.lt.1.-(1.-rexndi(icltar))**(kolt(it)
2174      &          *(1.+rexres(icltar)*log(max(1.,float(ltarg(it)))))))then
2175               iet(it)=1
2176             else
2177               iet(it)=0
2178             endif
2179           elseif(iremn.ne.0)then
2180 c increase of inelastic remnant excitation in pA needed for Barton
2181             if(r.lt.1.-(1.-rexndi(icltar))
2182      &         **(1.+rexres(icltar)*float(ltarg(it)-1)))then
2183               iet(it)=1
2184             else
2185               iet(it)=0
2186             endif
2187           else
2188             if(r.lt.rexndi(icltar))then
2189               iet(it)=1
2190              else
2191               iet(it)=0
2192             endif
2193          endif
2194         elseif(mdif.eq.1)then        !diffr
2195           if(iremn.eq.1)then
2196               if(r.lt.1.-(1.-rexdif(icltar))**(kolt(it)
2197      &      *(1.+rexres(icltar)*log(max(1.,float(ltarg(it)))))))then
2198                 iet(it)=2
2199               else
2200                 iet(it)=0
2201               endif
2202             elseif(iremn.ne.0)then
2203 c increase of diffractive remnant excitation in pA needed for Barton anb xsection
2204               if(r.lt.1.-(1.-rexdif(icltar))
2205      &      **(1.+rexres(icltar)*float(ltarg(it)-1)))then
2206                 iet(it)=2
2207               else
2208                 iet(it)=0
2209               endif
2210             else
2211               if(r.lt.1.-(1.-rexdif(icltar)))then
2212                 iet(it)=2
2213               else
2214                 iet(it)=0
2215               endif
2216             endif
2217         elseif(iet(it).ne.5)then
2218           iet(it)=0
2219         endif
2220
2221       elseif(ir.eq.2)then                !proj diff excitation
2222
2223 c minimum mass excitation
2224         ip=ii
2225         r=rangen()
2226 c        if(r.lt.rexpdif(iclpro))iep(ip)=4
2227         if(r.lt.rexpdif(iclpro)
2228      & **(1.+rexres(iclpro)*float(lproj(ip)-1)))iep(ip)=4
2229
2230       elseif(ir.eq.-2)then                !targ diff excitation
2231
2232 cminimum mass excitation
2233         it=ii
2234         r=rangen()
2235 c        if(r.lt.rexpdif(icltar))iet(it)=4
2236         if(r.lt.rexpdif(icltar)
2237      & **(1.+rexres(icltar)*float(ltarg(it)-1)))iet(it)=4
2238
2239       endif
2240
2241       end
2242
2243
2244 c-------------------------------------------------------------------------
2245       subroutine ProDiPt(k,iqq,iret)
2246 c-------------------------------------------------------------------------
2247 c propose transverse momentum for diffractive interaction
2248 c iqq=1  : fix pt for non diffractive pair (and check if all pairs are still valid)
2249 c iqq=2  : diffractive pt with mass dependence
2250 c-------------------------------------------------------------------------
2251
2252       include 'epos.incems'
2253       include 'epos.incsem'
2254       include 'epos.inc'
2255       double precision xxe(kollmx),xye(kollmx),pt2,am0,am1,am2!,p5sqpr,p5sqtg
2256       double precision plc,s,xxpnew,xypnew,xxtnew,xytnew,rannorm
2257       common/cems5/plc,s
2258       common/emsptl/nppr(npommx,kollmx),npproj(mamx),nptarg(mamx)
2259       save xxe,xye
2260
2261       ip=iproj(k)
2262       it=itarg(k)
2263       pt=0.
2264       phi=0.
2265
2266
2267 c generate p_t for diffractive
2268       if(iqq.eq.1)then
2269
2270        if(ptdiff.gt.0.)then
2271          if(itpr(k).eq.2)then
2272            pt=ranpt()*ptdiff/(1.+0.02*max(0.,sngl(log(s))))
2273          elseif(itpr(k).eq.0)then   !pt for non-wounded nucleon (usefull in ProRem to avoid problem in utrescl)
2274            if(iLHC.eq.1)then
2275              pt = sngl(RANNORM(0.088D0,0.044D0))  !limited by some data like sal.optns
2276            else
2277              ptnw=0.005
2278              pt=ranptd()*ptnw
2279            endif
2280            if(kolp(ip).eq.0.and.iep(ip).le.0)iep(ip)=6   !active spectators
2281            if(kolt(it).eq.0.and.iet(it).le.0)iet(it)=6
2282          else
2283            xxe(k)=0d0
2284            xye(k)=0d0
2285            goto 10
2286          endif
2287          phi=2.*pi*rangen()
2288          xxe(k)=dble(pt*cos(phi))
2289          xye(k)=dble(pt*sin(phi))
2290        else
2291          xxe(k)=0d0
2292          xye(k)=0d0
2293        endif
2294
2295 c update remnant p_t
2296
2297  10    xxp(ip)=xxp(ip)-xxe(k)
2298        xyp(ip)=xyp(ip)-xye(k)
2299        xxt(it)=xxt(it)+xxe(k)
2300        xyt(it)=xyt(it)+xye(k)
2301
2302        if(ish.ge.8)write(ifch,'(a,i5,3i4,4g13.5)')
2303      &                    'ProDiPt',k,ip,it,itpr(k),pt,phi,xxe(k),xye(k)
2304
2305        if(itpr(k).ne.0.and.itpr(k).ne.3)iret=0
2306 !to simulate the fact that originally we had a Pomeron
2307 c         if(koll.le.2)then
2308 c           call StoCon(-k,k,1)  !to fixe mass of corresponding remnants
2309 c           xpp(ip)=xpp(ip)-xppr(1,k)
2310 c           xpt(it)=xpt(it)+xppr(1,k)
2311 c           xmt(it)=xmt(it)-xmpr(1,k)
2312 c           xmp(ip)=xmp(ip)+xmpr(1,k)
2313 c           idpr(1,k)=0
2314 c           xpr(1,k)=0.d0
2315 c           ypr(1,k)=0.d0
2316 c           xppr(1,k)=0.d0
2317 c           xmpr(1,k)=0.d0
2318 c         endif
2319 c         p5sqpr=xpp(ip)*xmp(ip)*s-dble(amproj*amproj)
2320 c         p5sqtg=xpt(it)*xmt(it)*s-dble(amtarg*amtarg)
2321 c         phi=2.*pi*rangen()
2322 c         ntry=0
2323 c 20      ntry=ntry+1
2324 c         pt=ranptcut(ptsems)*ptsend**2
2325 c         if(ntry.lt.100.and.(p5sqpr-dble(pt*pt).lt.0.d0
2326 c     &                   .or.p5sqtg-dble(pt*pt).lt.0.d0))then
2327 c             goto 20
2328 c         else
2329 c           pt=ranptcut(ptsems)*ptsendi
2330 c         endif
2331 c         xxe(k)=dble(pt*cos(phi))
2332 c         xye(k)=dble(pt*sin(phi))
2333 c         xxp(ip)=xxp(ip)-xxe(k)
2334 c         xyp(ip)=xyp(ip)-xye(k)
2335 c         xxt(it)=xxt(it)+xxe(k)
2336 c         xyt(it)=xyt(it)+xye(k)
2337 c       endif
2338
2339       elseif(itpr(k).eq.2.and.ptdiff.ne.0.)then
2340
2341         pt2=xxe(k)*xxe(k)+xye(k)*xye(k)
2342         if(pt2.gt.0d0)then
2343           am0=dble(amproj**2*amtarg**2)
2344           am1=max(dble(amproj**2),xpp(ip)*xmp(ip)*s
2345      &              -xxp(ip)*xxp(ip)-xyp(ip)*xyp(ip))
2346           am2=max(dble(amtarg**2),xpt(it)*xmt(it)*s
2347      &              -xxp(it)*xxp(it)-xyp(it)*xyp(it))
2348           ptd=ptdiff/(1.+0.02*max(0.,sngl(log(s*am0/am1/am2)))) !0.02 comes from data (Z. Phys. C 67, 227-237, 1995)
2349 c           ad=pi/4./ptd**2
2350 c           r=rangen()
2351           pt=ranpt()*ptd        !sqrt(-alog(r)/ad)
2352         else
2353           return
2354         endif
2355         if(ish.ge.8)write(ifch,'(a,i5,2i4,5g13.5)')
2356      &                    'ProDiPt',k,ip,it,pt,sqrt(pt2),ptd,am1,am2
2357 c suppress the pt given with iqq=1 and give a new one taking into account the mass (iqq=2) with the same angle phi
2358         pt=pt/sqrt(pt2)
2359         xxe(k)=xxe(k)*pt
2360         xye(k)=xye(k)*pt
2361
2362 c update remnant p_t if enough energy available
2363         xxpnew=xxp(ip)-xxe(k)
2364         xypnew=xyp(ip)-xye(k)
2365         xxtnew=xxt(it)+xxe(k)
2366         xytnew=xyt(it)+xye(k)
2367         if((iep(ip).eq.0.or.
2368      &      xpp(ip)*xmp(ip)*s-xxpnew*xxpnew-xypnew*xypnew
2369      &      .gt.1.3d0*dble(pptl(5,npproj(ip)))**2)
2370      &.and.(iet(it).eq.0.or.
2371      &      xpt(it)*xmt(it)*s-xxtnew*xxtnew-xytnew*xytnew
2372      &      .gt.1.3d0*dble(pptl(5,nptarg(it)))**2))then
2373           xxp(ip)=xxp(ip)-xxe(k)
2374           xyp(ip)=xyp(ip)-xye(k)
2375           xxt(it)=xxt(it)+xxe(k)
2376           xyt(it)=xyt(it)+xye(k)
2377         endif
2378
2379        endif
2380
2381        end
2382
2383 c-------------------------------------------------------------------------
2384       subroutine ProSePt(k,n,iret)
2385 c-------------------------------------------------------------------------
2386 c propose transverse momentum for string ends
2387 c-------------------------------------------------------------------------
2388
2389       include 'epos.inc'
2390       include 'epos.incems'
2391       common/cems5/plc,s
2392       double precision s,plc
2393       double precision x1p,x2p,x1t,x2t
2394
2395       if(ivpr(n,k).eq.2)return            !Backup Pomeron
2396
2397       ip=iproj(k)
2398       it=itarg(k)
2399       amk0=1. ! included in ptsend !(qmass(1)+qmass(2)+qmass(3))/3.     !mass for mt distribution
2400
2401       ptsecut=ptsecu        !cut for gaussian distribution (center around 0.4)
2402
2403 c generate p_t for string ends  (proj)
2404       iret=0
2405       ntry=0
2406  10   ntry=ntry+1
2407       xxp1pr(n,k)=0d0
2408       xyp1pr(n,k)=0d0
2409       xxp2pr(n,k)=0d0
2410       xyp2pr(n,k)=0d0
2411       xxm1pr(n,k)=0d0
2412       xym1pr(n,k)=0d0
2413       xxm2pr(n,k)=0d0
2414       xym2pr(n,k)=0d0
2415       x1p=0d0
2416       x2p=0d0
2417       x1t=0d0
2418       x2t=0d0
2419       pt=0.
2420       phi=0.
2421       if(ntry.gt.100)then
2422         iret=1
2423         goto 1000               !no pt
2424       endif
2425 c
2426 c      !---proj-----
2427         ptsef=ptsend
2428         if(iep(ip).eq.0)ptsef=ptsendi
2429         ptsendx = ptsems
2430         ptsendy = ptsendx
2431         if(iLHC.eq.0)ptsendy = ptsendx*2
2432
2433         ipt=1
2434
2435 c 2 step pt : first give pt between remnant and Pomeron and then between
2436 c string ends on the same side.
2437         if(iLHC.eq.-1)ipt=2
2438
2439         do ii=1,ipt
2440
2441       if(idp1pr(n,k).gt.0)then
2442         if(ii.eq.1)then
2443          if(idp1pr(n,k).eq.4.or.idp1pr(n,k).eq.5)then   !diquarks
2444            amk1=amk0*ptsendy+qmass(0) !mass for mt distribution with bounding energy for diquark
2445          else
2446            amk1=amk0*ptsendx
2447          endif
2448 c         if(iep(ip).eq.0)amk1=0.
2449          if(iep(ip).eq.0)then
2450            pt=ranptd()*ptsef
2451          else
2452            pt=ranptcut(ptsecut)*ptsef
2453 c           pt=ranptd()*ptsef
2454            pt=pt+amk1
2455          endif
2456 c         pt=ranptcut(ptsecut)*ptsef
2457 c         pt=pt+amk1
2458 c         pt=ranptd()*ptsef
2459 c         pt=sqrt(pt*pt+amk1*amk1)
2460        else
2461          pt=ranpt()*ptfraqq
2462        endif
2463          phi=2.*pi*rangen()
2464          xxp1pr(n,k)=xxp1pr(n,k)+dble(pt*cos(phi))
2465          xyp1pr(n,k)=xyp1pr(n,k)+dble(pt*sin(phi))
2466       else
2467          xxp1pr(n,k)=0d0
2468          xyp1pr(n,k)=0d0
2469       endif
2470       if(idp2pr(n,k).gt.0)then
2471         if(ii.eq.1)then
2472          if(idp2pr(n,k).eq.4.or.idp2pr(n,k).eq.5)then
2473            amk1=amk0*ptsendy+qmass(0) !mass for mt distribution with bounding energy for diquark
2474          else
2475            amk1=amk0*ptsendx
2476          endif
2477 c         if(iep(ip).eq.0)amk1=0.
2478          if(iep(ip).eq.0)then
2479            pt=ranptd()*ptsef
2480          else
2481            pt=ranptcut(ptsecut)*ptsef
2482 c           pt=ranptd()*ptsef
2483            pt=pt+amk1
2484          endif
2485 c         pt=ranptcut(ptsecut)*ptsef
2486 c         pt=pt+amk1
2487 c         pt=ranptd()*ptsef
2488 c         pt=sqrt(pt*pt+amk1*amk1)
2489          phi=2.*pi*rangen()
2490        else    !use pt and phi from other string ends
2491          pt=-pt
2492        endif
2493          xxp2pr(n,k)=xxp2pr(n,k)+dble(pt*cos(phi))
2494          xyp2pr(n,k)=xyp2pr(n,k)+dble(pt*sin(phi))
2495       else
2496          xxp2pr(n,k)=0d0
2497          xyp2pr(n,k)=0d0
2498       endif
2499 c generate p_t for string ends  (targ)
2500
2501
2502 c      !---targ-----
2503         ptsef=ptsend
2504         if(iet(it).eq.0)ptsef=ptsendi
2505         ptsendx = ptsems
2506         ptsendy = ptsendx
2507         if(iLHC.eq.0)ptsendy = ptsendx*2.
2508
2509       if(idm1pr(n,k).gt.0)then
2510         if(ii.eq.1)then
2511          if(idm1pr(n,k).eq.4.or.idm1pr(n,k).eq.5)then
2512            amk1=amk0*ptsendy+qmass(0) !mass for mt distribution with bounding energy for diquark
2513          else
2514            amk1=amk0*ptsendx
2515          endif
2516 c         if(iet(it).eq.0)amk1=0.
2517          if(iet(it).eq.0)then
2518            pt=ranptd()*ptsef
2519          else
2520            pt=ranptcut(ptsecut)*ptsef
2521 c           pt=ranptd()*ptsef
2522            pt=pt+amk1
2523          endif
2524 c         pt=ranptcut(ptsecut)*ptsef
2525 c         pt=pt+amk1
2526 c         pt=ranptd()*ptsef
2527 c         pt=sqrt(pt*pt+amk1*amk1)
2528        else
2529          pt=ranpt()*ptfraqq
2530        endif
2531          phi=2.*pi*rangen()
2532          xxm1pr(n,k)=xxm1pr(n,k)+dble(pt*cos(phi))
2533          xym1pr(n,k)=xym1pr(n,k)+dble(pt*sin(phi))
2534       else
2535          xxm1pr(n,k)=0d0
2536          xym1pr(n,k)=0d0
2537       endif
2538       if(idm2pr(n,k).gt.0)then
2539         if(ii.eq.1)then
2540          if(idm2pr(n,k).eq.4.or.idm2pr(n,k).eq.5)then
2541            amk1=amk0*ptsendy+qmass(0) !mass for mt distribution with bounding energy for diquark
2542          else
2543            amk1=amk0*ptsendx
2544          endif
2545 c         if(iet(it).eq.0)amk1=0.
2546          if(iet(it).eq.0)then
2547            pt=ranptd()*ptsef
2548          else
2549            pt=ranptcut(ptsecut)*ptsef
2550 c           pt=ranptd()*ptsef
2551            pt=pt+amk1
2552          endif
2553 c         pt=ranptcut(ptsecut)*ptsef
2554 c         pt=pt+amk1
2555 c         pt=ranptd()*ptsef
2556 c         pt=sqrt(pt*pt+amk1*amk1)
2557          phi=2.*pi*rangen()
2558        else    !use pt and phi from other string ends
2559          pt=-pt
2560        endif
2561          xxm2pr(n,k)=xxm2pr(n,k)+dble(pt*cos(phi))
2562          xym2pr(n,k)=xym2pr(n,k)+dble(pt*sin(phi))
2563       else
2564          xxm2pr(n,k)=0d0
2565          xym2pr(n,k)=0d0
2566       endif
2567
2568       if(ii.eq.1)then    !balance pt bwteen string ends and remnant
2569
2570         x1p=xxp(ip)-xxp1pr(n,k)-xxp2pr(n,k)
2571         x2p=xyp(ip)-xyp1pr(n,k)-xyp2pr(n,k)
2572         x1t=xxt(it)-xxm1pr(n,k)-xxm2pr(n,k)
2573         x2t=xyt(it)-xym1pr(n,k)-xym2pr(n,k)
2574
2575         if(iLHC.eq.1)then       !check energy
2576           if(x1p**2+x2p**2+2.*amproj**2.ge.xpp(ip)*s)goto 10
2577           if(x1t**2+x2t**2+2.*amtarg**2.ge.xmt(it)*s)goto 10
2578         endif
2579
2580       endif
2581
2582       if(ish.ge.8)write(ifch,*) 'ProSePt',ii,n,k
2583      *   ,sqrt(xxp1pr(n,k)**2+xyp1pr(n,k)**2)
2584      *   ,sqrt(xxp2pr(n,k)**2+xyp2pr(n,k)**2)
2585      *   ,sqrt(xxm1pr(n,k)**2+xym1pr(n,k)**2)
2586      *   ,sqrt(xxm2pr(n,k)**2+xym2pr(n,k)**2)
2587
2588       enddo
2589
2590
2591 c update remnant p_t (pomeron)
2592         xxp(ip)=x1p
2593         xyp(ip)=x2p
2594         xxt(it)=x1t
2595         xyt(it)=x2t
2596
2597 c update backup soft pomeron p_t if exist
2598
2599  1000   if(nbkpr(n,k).ne.0)then
2600           nn=nbkpr(n,k)
2601           xxp1pr(nn,k)=xxp1pr(n,k)
2602           xyp1pr(nn,k)=xyp1pr(n,k)
2603           xxp2pr(nn,k)=xxp2pr(n,k)
2604           xyp2pr(nn,k)=xyp2pr(n,k)
2605           xxm1pr(nn,k)=xxm1pr(n,k)
2606           xym1pr(nn,k)=xym1pr(n,k)
2607           xxm2pr(nn,k)=xxm2pr(n,k)
2608           xym2pr(nn,k)=xym2pr(n,k)
2609         endif
2610
2611         if(ish.ge.6)then
2612         write(ifch,*) 'ProSePt'
2613         write(ifch,'(4i14/4d14.3/4d14.3/)')
2614      * idp1pr(n,k),idp2pr(n,k),idm1pr(n,k),idm2pr(n,k)
2615      *,xxp1pr(n,k),xxp2pr(n,k),xxm1pr(n,k),xxm2pr(n,k)
2616      *,xyp1pr(n,k),xyp2pr(n,k),xym1pr(n,k),xym2pr(n,k)
2617         endif
2618
2619         end
2620
2621 c-----------------------------------------------------------------------
2622       subroutine ProSeX(k,n,iret)
2623 c-----------------------------------------------------------------------
2624 c calculates x of string ends
2625 c-----------------------------------------------------------------------
2626
2627       include 'epos.inc'
2628       include 'epos.incems'
2629       common/cems5/plc,s
2630       double precision s,plc
2631       common/cems10/a(0:ntypmx),b(0:ntypmx),d(0:ntypmx)
2632       double precision a,b,d
2633      *,xp,xm,ap1,ap2,am1,am2,aamin1,aamin2,u
2634      *,xmn1,xmn2
2635
2636       iret=0
2637
2638       if(abs(itpr(k)).ne.1)return
2639       if(idpr(n,k).ne.1.or.ivpr(n,k).eq.0)return
2640
2641       if(idp1pr(n,k).eq.0.and.idp2pr(n,k).eq.0
2642      * .and.idm1pr(n,k).eq.0.and.idm2pr(n,k).eq.0)
2643      *call utstop('no Pomeron in ProSex&')
2644
2645       xp=xppr(n,k)
2646       xm=xmpr(n,k)
2647       ap1=a(idp1pr(n,k))
2648       ap2=a(idp2pr(n,k))
2649       am1=a(idm1pr(n,k))
2650       am2=a(idm2pr(n,k))
2651       aamin1=ammn(idp1pr(n,k)+idm2pr(n,k))
2652       aamin2=ammn(idp2pr(n,k)+idm1pr(n,k))
2653       xmn1=(aamin1**2+(xxp1pr(n,k)+xxm2pr(n,k))**2
2654      &               +(xyp1pr(n,k)+xym2pr(n,k))**2)/s
2655       xmn2=(aamin2**2+(xxp2pr(n,k)+xxm1pr(n,k))**2
2656      &               +(xyp2pr(n,k)+xym1pr(n,k))**2)/s
2657
2658       ntry=0
2659  999  ntry=ntry+1
2660       if(ntry.gt.100)then
2661         iret=1
2662         if(ish.ge.5)write(ifch,*)'Problem in ProSex(k,n)',k,n
2663         return
2664       endif
2665
2666     1 u=dble(rangen())**(1d0/(1d0+ap1))
2667       if(dble(rangen()).gt.(1d0-u)**ap2)goto1
2668       xp1pr(n,k)=u*xp
2669       xp2pr(n,k)=(1-u)*xp
2670     2 u=dble(rangen())**(1d0/(1d0+am1))
2671       if(dble(rangen()).gt.(1d0-u)**am2)goto2
2672       xm1pr(n,k)=u*xm
2673       xm2pr(n,k)=(1-u)*xm
2674
2675       if(xp1pr(n,k)*xm2pr(n,k).lt.xmn1)then
2676       goto 999
2677 c       fc=xp1pr(n,k)*xm2pr(n,k)/xmn1   !avoid virpom
2678 c       if(fc.eq.0.)goto 999
2679 c       xp1pr(n,k)=xp1pr(n,k)/sqrt(fc)
2680 c       xm2pr(n,k)=xm2pr(n,k)/sqrt(fc)
2681       endif
2682       if(xp2pr(n,k)*xm1pr(n,k).lt.xmn2)then
2683       goto 999
2684 c       fc=xp2pr(n,k)*xm1pr(n,k)/xmn2   !avoid virpom
2685 c       if(fc.eq.0.)goto 999
2686 c       xp2pr(n,k)=xp2pr(n,k)/sqrt(fc)
2687 c       xm1pr(n,k)=xm1pr(n,k)/sqrt(fc)
2688       endif
2689
2690       if(ish.ge.6)then
2691        write(ifch,*) 'ProSeX'
2692        write(ifch,'(2d28.3,i8)') xp,xm,ntry
2693        write(ifch,'(4d14.3)')xp1pr(n,k),xp2pr(n,k),xm1pr(n,k),xm2pr(n,k)
2694        write(ifch,'(4d14.3/)')xp1pr(n,k)*xm2pr(n,k)
2695      *                   ,xp2pr(n,k)*xm1pr(n,k),  xmn1, xmn2
2696       endif
2697
2698       end
2699 c-------------------------------------------------------------------------
2700       subroutine RmPt(k,n)
2701 c-------------------------------------------------------------------------
2702 c remove pt from pomeron
2703 c-------------------------------------------------------------------------
2704       include 'epos.inc'
2705       include 'epos.incems'
2706       ip=iproj(k)
2707       it=itarg(k)
2708       xxp(ip)=xxp(ip)+xxp1pr(n,k)+xxp2pr(n,k)
2709       xyp(ip)=xyp(ip)+xyp1pr(n,k)+xyp2pr(n,k)
2710       xxt(it)=xxt(it)+xxm1pr(n,k)+xxm2pr(n,k)
2711       xyt(it)=xyt(it)+xym1pr(n,k)+xym2pr(n,k)
2712       xp1pr(n,k)=0d0
2713       xp2pr(n,k)=0d0
2714       xm1pr(n,k)=0d0
2715       xm2pr(n,k)=0d0
2716       xxm1pr(n,k)=0d0
2717       xym1pr(n,k)=0d0
2718       xxp1pr(n,k)=0d0
2719       xyp1pr(n,k)=0d0
2720       xxm2pr(n,k)=0d0
2721       xym2pr(n,k)=0d0
2722       xxp2pr(n,k)=0d0
2723       xyp2pr(n,k)=0d0
2724       idp1pr(n,k)=0
2725       idm2pr(n,k)=0
2726       idp2pr(n,k)=0
2727       idm1pr(n,k)=0
2728       end
2729
2730 c-------------------------------------------------------------------------
2731       subroutine VirPom(k,n,id)
2732 c-------------------------------------------------------------------------
2733 c create virtual pomeron
2734 c virtual pomeron: ivpr(n,k)=0, otherwise ivpr(n,k)=1
2735 c-------------------------------------------------------------------------
2736
2737       include 'epos.inc'
2738       include 'epos.incems'
2739       include 'epos.incsem'
2740       common/col3/ncol,kolpt
2741       common/emsptl/nppr(npommx,kollmx),npproj(mamx),nptarg(mamx)
2742       double precision plc,s
2743       common/cems5/plc,s
2744       integer jcp(nflav,2),jct(nflav,2)
2745 c      data nvir/0/
2746 c      save nvir
2747
2748       call utpri('VirPom',ish,ishini,3)
2749
2750       if(idpr(n,k).eq.0)return
2751
2752       ip=iproj(k)
2753       it=itarg(k)
2754
2755       nnv=nvpr(n,k)
2756       nnb=nbkpr(n,k)
2757
2758 c                        nvir=nvir+1
2759 c                   print *,'  ',id,'   ',nvir
2760
2761       if(ish.ge.3)then
2762       write(ifch,*)"virpom ",id," (n,k)",n,k,nnb,nnv,nppr(n,k),itpr(k)
2763      &                            ,nprt(k),idpr(n,k),npr(1,k),npr(3,k)
2764       if(ish.ge.5)write(ifch,*)"remnant in",xpp(ip),xmt(it)
2765       endif
2766
2767       if(nnv.ne.0)then
2768         nn=nnv
2769         kk=k
2770         if(idpr(nn,kk).eq.0)then
2771           nvpr(n,k)=0
2772         endif
2773       endif
2774
2775       if(nnb.ne.0)then
2776         nn=nnb
2777         kk=k
2778         if(idpr(nn,kk).eq.0)then
2779           nbkpr(n,k)=0
2780         endif
2781       endif
2782
2783
2784       if(nbkpr(n,k).eq.0.and.nvpr(n,k).eq.0)then     !normal Pomeron
2785
2786       npr(0,k)=npr(0,k)+1
2787       npp(ip)=npp(ip)-1
2788       npt(it)=npt(it)-1
2789       npr(idpr(n,k),k)=npr(idpr(n,k),k)-1
2790       nprt(k)=npr(1,k)+npr(3,k)
2791       antotf=antotf-1
2792       if(idpr(n,k).eq.1)ansff=ansff-1
2793       if(idpr(n,k).eq.3)anshf=anshf-1
2794       kolp(ip)=kolp(ip)-1
2795       kolt(it)=kolt(it)-1
2796       xxp(ip)=xxp(ip)+xxp1pr(n,k)+xxp2pr(n,k)
2797       xyp(ip)=xyp(ip)+xyp1pr(n,k)+xyp2pr(n,k)
2798       xxt(it)=xxt(it)+xxm1pr(n,k)+xxm2pr(n,k)
2799       xyt(it)=xyt(it)+xym1pr(n,k)+xym2pr(n,k)
2800
2801 c restore x from nuclear splitting
2802       if(knucnt(1,k).gt.0)then
2803         do nuc=1,knucnt(1,k)
2804           if(npnuc(nuc,1,k).eq.n)then
2805             ipp=irnuc(nuc,1,k)
2806             xpp(ipp)=xpp(ipp)+xxnuc(nuc,1,k)
2807             if(xpp(ipp).ge.1d0)iep(ipp)=0
2808             xppr(n,k)=xppr(n,k)-xxnuc(nuc,1,k)
2809             xpr(n,k)=xppr(n,k)*xmpr(n,k)
2810             ypr(n,k)=0.5D0*log(xppr(n,k)/xmpr(n,k))
2811             npnuc(nuc,1,k)=0    !to be sure not to use it again
2812           endif
2813         enddo
2814       endif
2815       if(knucnt(2,k).gt.0)then
2816         do nuc=1,knucnt(2,k)
2817           if(npnuc(nuc,2,k).eq.n)then
2818             itt=irnuc(nuc,2,k)
2819             xmt(itt)=xmt(itt)+xxnuc(nuc,2,k)
2820             if(xmt(itt).ge.1d0)iet(itt)=0
2821             xmpr(n,k)=xmpr(n,k)-xxnuc(nuc,2,k)
2822             xpr(n,k)=xppr(n,k)*xmpr(n,k)
2823             ypr(n,k)=0.5D0*log(xppr(n,k)/xmpr(n,k))
2824             npnuc(nuc,2,k)=0    !to be sure not to use it again
2825           endif
2826         enddo
2827       endif
2828
2829       xpp(ip)=xpp(ip)+xppr(n,k)
2830       xmt(it)=xmt(it)+xmpr(n,k)
2831
2832
2833       if(abs(itpr(k)).eq.1.and.nprt(k).eq.0)then !no more Pomeron on this pair
2834         if(itpr(k).gt.0)then
2835           itpr(k)=2             !this pair is diffractive
2836           if(id.gt.0.and.iep(ip).eq.0.and.iet(it).eq.0)itpr(k)=3  !this pair is empty now
2837         else
2838           itpr(k)=3             !this pair is empty now
2839         endif
2840       endif
2841
2842       endif
2843
2844       istring=idp1pr(n,k)+idp2pr(n,k)+idm1pr(n,k)+idm2pr(n,k)
2845       if(istring.ne.0.and.iremn.ge.2)then
2846         if(ish.ge.7)write(ifch,*)"restore flavor:",istring
2847
2848         if(idp1pr(n,k).eq.2)ivp(ip)=ivp(ip)+1 !update number of valence quark
2849         if(idm1pr(n,k).eq.2)ivt(it)=ivt(it)+1
2850         if(idp2pr(n,k).eq.2)ivp(ip)=ivp(ip)+1
2851         if(idm2pr(n,k).eq.2)ivt(it)=ivt(it)+1
2852         if(idp1pr(n,k).eq.5)idp(ip)=idp(ip)+1 !update number of valence diquark
2853         if(idm1pr(n,k).eq.5)idt(it)=idt(it)+1
2854         if(idp2pr(n,k).eq.5)idp(ip)=idp(ip)+1
2855         if(idm2pr(n,k).eq.5)idt(it)=idt(it)+1
2856         if(iLHC.eq.1)then
2857         if(idp1pr(n,k).eq.4)idp(ip)=idp(ip)-1 !update number of diquark
2858         if(idm1pr(n,k).eq.4)idt(it)=idt(it)-1
2859         if(idp2pr(n,k).eq.4)idp(ip)=idp(ip)-1
2860         if(idm2pr(n,k).eq.4)idt(it)=idt(it)-1
2861         endif
2862
2863         if(iremn.eq.3)then      !virtual Pomeron (remove unnecessary flavors for string ends)
2864           do j=1,2
2865             do i=1,nrflav
2866               jcp(i,j)=jcpref(i,j,ip)
2867               jct(i,j)=jctref(i,j,it)
2868             enddo
2869             do i=nrflav+1,nflav
2870               jcp(i,j)=0
2871               jct(i,j)=0
2872             enddo
2873           enddo
2874           if(ish.ge.7)write(ifch,*)"in:",jcp,' |',jct
2875           iret=0
2876
2877 c Projectile diquark-antidiquark pair
2878           iaq=nint(1.5+sign(0.5,float(idproj)))
2879           iq=3-iaq
2880           if(idp1pr(n,k).eq.4)then  !diquark
2881 c    first quark
2882             idum=idrafl(iclpro,jcp,iaq,'v',0,iret)      !pick anti-quark
2883             ntry=0
2884             do while (jcp(idum,iq).eq.0.and.ntry.lt.100)!look for the corresponding quark
2885               ntry=ntry+1
2886               idum=idrafl(iclpro,jcp,iaq,'v',0,iret)
2887             enddo
2888             if(ntry.lt.100)then          !if OK, then remove the pair and pick a second quark
2889               call idsufl3(idum,1,jcp)
2890               call idsufl3(idum,2,jcp)
2891               if(jcp(idum,1)-jcpval(idum,1,ip).lt.0) !check valence quark number
2892      &             jcpval(idum,1,ip)=jcpval(idum,1,ip)-1
2893               if(jcp(idum,2)-jcpval(idum,2,ip).lt.0)
2894      &             jcpval(idum,2,ip)=jcpval(idum,2,ip)-1
2895
2896 c   second quark
2897               idum=idrafl(iclpro,jcp,iaq,'v',0,iret)
2898               ntry2=0
2899               do while (jcp(idum,iq).eq.0.and.ntry2.lt.100)!look for the corresponding antiquark
2900                 ntry2=ntry2+1
2901                 idum=idrafl(iclpro,jcp,iaq,'v',0,iret)
2902               enddo
2903               if(ntry2.lt.100)then          !if OK, then remove the pair
2904                 call idsufl3(idum,1,jcp)
2905                 call idsufl3(idum,2,jcp)
2906                 if(jcp(idum,1)-jcpval(idum,1,ip).lt.0)
2907      &               jcpval(idum,1,ip)=jcpval(idum,1,ip)-1
2908                 if(jcp(idum,2)-jcpval(idum,2,ip).lt.0)
2909      &               jcpval(idum,2,ip)=jcpval(idum,2,ip)-1
2910               else          !if not (because quarks already used by other valid string), then redo event to avoid problem in flavor conservation
2911                 if(id.ge.15)then
2912                   id=-1
2913                   return
2914                 else
2915                   call utstop("Virpom:should not happen (2) !&")
2916                 endif
2917               endif
2918             else      !if no pair has be found (because quarks already used by other valid string), then redo event to avoid problem in flavor conservation
2919               if(id.ge.15)then
2920                 id=-1
2921                 return
2922               else
2923                 call utstop("Virpom:should not happen  (3) !&")
2924               endif
2925             endif
2926
2927 c Projectile quark-antiquark pair
2928           else
2929             idum=idrafl(iclpro,jcp,iaq,'v',0,iret)      !pick anti-quark
2930             ntry=0
2931             do while (jcp(idum,iq).eq.0.and.ntry.lt.100)  !look for the corresponding quark
2932               ntry=ntry+1
2933               idum=idrafl(iclpro,jcp,iaq,'v',0,iret)
2934             enddo
2935             if(ntry.lt.100)then          !if OK, then remove the pair
2936               call idsufl3(idum,1,jcp)
2937               call idsufl3(idum,2,jcp)
2938               if(jcp(idum,1)-jcpval(idum,1,ip).lt.0)
2939      &             jcpval(idum,1,ip)=jcpval(idum,1,ip)-1
2940               if(jcp(idum,2)-jcpval(idum,2,ip).lt.0)
2941      &             jcpval(idum,2,ip)=jcpval(idum,2,ip)-1
2942             else                         !if not (because quarks already used by other valid string),then redo event to avoid problem in flavor conservation
2943               if(id.ge.15)then
2944                 id=-1
2945                 return
2946               else
2947                 call utstop("Virpom:should not happen (4) !&")
2948               endif
2949             endif
2950           endif
2951
2952 c Target diquark-antidiquark pair
2953           iaq=nint(1.5+sign(0.5,float(idtarg)))
2954           iq=3-iaq
2955           if(idm1pr(n,k).eq.4)then  !diquark
2956 c    first quark
2957             idum=idrafl(icltar,jct,iaq,'v',0,iret)
2958             ntry=0
2959             do while (jct(idum,iq).eq.0.and.ntry.lt.100)
2960               ntry=ntry+1
2961               idum=idrafl(icltar,jct,iaq,'v',0,iret)
2962             enddo
2963             if(ntry.lt.100)then
2964               call idsufl3(idum,1,jct)
2965               call idsufl3(idum,2,jct)
2966               if(jct(idum,1)-jctval(idum,1,it).lt.0)
2967      &             jctval(idum,1,it)=jctval(idum,1,it)-1
2968               if(jct(idum,2)-jctval(idum,2,it).lt.0)
2969      &             jctval(idum,2,it)=jctval(idum,2,it)-1
2970 c    second quark
2971               idum=idrafl(icltar,jct,1,'v',0,iret)
2972               ntry2=0
2973               do while (jct(idum,2).eq.0.and.ntry2.lt.100)
2974                 ntry2=ntry2+1
2975                 idum=idrafl(icltar,jct,1,'v',0,iret)
2976               enddo
2977               if(ntry2.lt.100)then
2978                 call idsufl3(idum,1,jct)
2979                 call idsufl3(idum,2,jct)
2980                 if(jct(idum,1)-jctval(idum,1,it).lt.0)
2981      &               jctval(idum,1,it)=jctval(idum,1,it)-1
2982                 if(jct(idum,2)-jctval(idum,2,it).lt.0)
2983      &               jctval(idum,2,it)=jctval(idum,2,it)-1
2984               else
2985                 if(id.ge.15)then
2986                   id=-1
2987                   return
2988                 else
2989                   call utstop("Virpom:should not happen (5) !&")
2990                 endif
2991               endif
2992             else
2993               if(id.ge.15)then
2994                 id=-1
2995                 return
2996               else
2997                 call utstop("Virpom:should not happen (6) !&")
2998               endif
2999             endif
3000
3001 c Target quark-antiquark pair
3002           else
3003             idum=idrafl(icltar,jct,1,'v',0,iret)
3004             ntry=0
3005             do while (jct(idum,2).eq.0.and.ntry.lt.100)
3006               ntry=ntry+1
3007               idum=idrafl(icltar,jct,1,'v',0,iret)
3008             enddo
3009             if(ntry.lt.100)then
3010               call idsufl3(idum,1,jct)
3011               call idsufl3(idum,2,jct)
3012               if(jct(idum,1)-jctval(idum,1,it).lt.0)
3013      &             jctval(idum,1,it)=jctval(idum,1,it)-1
3014               if(jct(idum,2)-jctval(idum,2,it).lt.0)
3015      &             jctval(idum,2,it)=jctval(idum,2,it)-1
3016             else
3017               if(id.ge.15)then
3018                 id=-1
3019                 return
3020               else
3021                 call utstop("Virpom:should not happen (7) !&")
3022               endif
3023             endif
3024           endif
3025
3026           if(ish.ge.7)write(ifch,*)"out:",jcp,' |',jct
3027           do j=1,2
3028             do i=1,nrflav
3029               jcpref(i,j,ip)=jcp(i,j)
3030               jctref(i,j,it)=jct(i,j)
3031             enddo
3032           enddo
3033
3034         endif
3035       endif
3036
3037
3038       ivpr(n,k)=0
3039       nbkpr(n,k)=0
3040       nvpr(n,k)=0
3041       idpr(n,k)=0
3042       idfpr(n,k)=0
3043       xpr(n,k)=0d0
3044       ypr(n,k)=0d0
3045       xppr(n,k)=0d0
3046       xmpr(n,k)=0d0
3047       idp1pr(n,k)=0
3048       idp2pr(n,k)=0
3049       idm1pr(n,k)=0
3050       idm2pr(n,k)=0
3051       xm1pr(n,k)=0d0
3052       xp1pr(n,k)=0d0
3053       xm2pr(n,k)=0d0
3054       xp2pr(n,k)=0d0
3055       xxm1pr(n,k)=0d0
3056       xym1pr(n,k)=0d0
3057       xxp1pr(n,k)=0d0
3058       xyp1pr(n,k)=0d0
3059       xxm2pr(n,k)=0d0
3060       xym2pr(n,k)=0d0
3061       xxp2pr(n,k)=0d0
3062       xyp2pr(n,k)=0d0
3063
3064        if(ish.ge.5)write(ifch,*)"remnant out",xpp(ip),xmt(it),itpr(k)
3065
3066       call utprix('VirPom',ish,ishini,3)
3067
3068       end
3069
3070 c-----------------------------------------------------------------------
3071       subroutine StoRe(imod)
3072 c-----------------------------------------------------------------------
3073 c Store Remnant configuration (imod=1) before shuffle  to restore the
3074 c initial configuration (imod=-1) in case of problem.
3075 c-----------------------------------------------------------------------
3076
3077       include 'epos.inc'
3078       include 'epos.incems'
3079
3080       if(imod.eq.1)then
3081
3082 c       initialize projectile
3083
3084         do i=1,maproj
3085           iepst(i)=iep(i)
3086           xppst(i)=xpp(i)
3087           xmpst(i)=xmp(i)
3088           xposst(i)=xpos(i)
3089         enddo
3090
3091 c       initialize target
3092
3093         do j=1,matarg
3094           ietst(j)=iet(j)
3095           xmtst(j)=xmt(j)
3096           xptst(j)=xpt(j)
3097           xtosst(j)=xtos(j)
3098         enddo
3099
3100       elseif(imod.eq.-1)then
3101
3102 c       restore projectile
3103
3104         do i=1,maproj
3105           iep(i)=iepst(i)
3106           xpp(i)=xppst(i)
3107           xmp(i)=xmpst(i)
3108           xpos(i)=xposst(i)
3109         enddo
3110
3111 c       restore target
3112
3113         do j=1,matarg
3114           iet(j)=ietst(j)
3115           xmt(j)=xmtst(j)
3116           xpt(j)=xptst(j)
3117           xtos(j)=xtosst(j)
3118         enddo
3119
3120       else
3121
3122         call utstop('Do not know what to do in StoRe.&')
3123
3124       endif
3125
3126       return
3127       end
3128
3129 c-----------------------------------------------------------------------
3130       subroutine UpdateFlav(ir,jc,mod)
3131 c-----------------------------------------------------------------------
3132 C Add valence quark to sea quarks in projectile jcpref (mod=10) or target
3133 c jctref (mod=20) for soft string ends (mod=0 reset jcrpref and
3134 c jctref to 0).
3135 c For mod=1 or 2, save jcref into jc.
3136 c For mod=-1 or -2, put jc into jcref.
3137 c-----------------------------------------------------------------------
3138       include 'epos.inc'
3139       include 'epos.incems'
3140       include 'epos.incsem'
3141       dimension ic(2),jc(nflav,2),jc2(nflav,2)
3142
3143       if(mod.eq.0)then
3144         do j=1,2
3145           do i=1,nrflav
3146             jcpref(i,j,ir)=0
3147             jctref(i,j,ir)=0
3148           enddo
3149         enddo
3150       elseif(mod.eq.-1)then
3151         do j=1,2
3152           do i=1,nrflav
3153             jcpref(i,j,ir)=jc(i,j)
3154           enddo
3155         enddo
3156       elseif(mod.eq.-2)then
3157         do j=1,2
3158           do i=1,nrflav
3159             jctref(i,j,ir)=jc(i,j)
3160           enddo
3161         enddo
3162       elseif(mod.eq.1)then
3163         do j=1,2
3164           do i=1,nrflav
3165             jc(i,j)=jcpref(i,j,ir)
3166           enddo
3167         enddo
3168       elseif(mod.eq.2)then
3169         do j=1,2
3170           do i=1,nrflav
3171             jc(i,j)=jctref(i,j,ir)
3172           enddo
3173         enddo
3174       elseif(mod.eq.10)then
3175         ic(1)=icproj(1,ir)
3176         ic(2)=icproj(2,ir)
3177         call iddeco(ic,jc)
3178         itest=0
3179         do j=1,2
3180           do i=1,nrflav
3181             jcpref(i,j,ir)=jcpref(i,j,ir)+jc(i,j)
3182           enddo
3183         enddo
3184
3185 c cancel quark and antiquarks to avoid to much remnant excitation
3186         do i=1,nrflav
3187
3188           if(iLHC.eq.1)then
3189
3190           if(jcpref(i,1,ir).ge.jcpref(i,2,ir))then
3191             jcpref(i,1,ir)=jcpref(i,1,ir)-jcpref(i,2,ir)
3192             jcpref(i,2,ir)=0
3193 c update valence quarks (cancel first sea quarks)
3194             if(jcpref(i,1,ir)-jc(i,1).lt.0)jc(i,1)=jcpref(i,1,ir)
3195             jc(i,2)=0
3196           else
3197             jcpref(i,2,ir)=jcpref(i,2,ir)-jcpref(i,1,ir)
3198             jcpref(i,1,ir)=0
3199 c update valence quarks (cancel first sea quarks)
3200             if(jcpref(i,2,ir)-jc(i,2).lt.0)jc(i,2)=jcpref(i,2,ir)
3201             jc(i,1)=0
3202           endif
3203
3204           endif
3205
3206           do j=1,2
3207             itest=itest+jcpref(i,j,ir)
3208             jc2(i,j)=jcpref(i,j,ir)
3209           enddo
3210         enddo
3211         if(itest.eq.0)then !do not leave empty remnant
3212           idum=idrafl(iclpro,jc2,1,'r',3,iretso)     !create q-qb
3213           do j=1,2
3214             do i=1,nrflav
3215               jcpref(i,j,ir)=jc2(i,j)
3216             enddo
3217           enddo
3218         endif
3219       if(ish.ge.6)write(ifch,'(a,i3,a,1x,4i3,3x,4i3)')
3220      & 'jcpref(',ir,') ini:',((jcpref(i,j,ir),i=1,nflavems),j=1,2)
3221       elseif(mod.eq.20)then
3222         ic(1)=ictarg(1,ir)
3223         ic(2)=ictarg(2,ir)
3224         call iddeco(ic,jc)
3225         itest=0
3226         do j=1,2
3227           do i=1,nrflav
3228             jctref(i,j,ir)=jctref(i,j,ir)+jc(i,j)
3229           enddo
3230         enddo
3231
3232         do i=1,nrflav
3233
3234           if(iLHC.eq.1)then
3235
3236 c cancel quark and antiquarks to avoid to much remnant excitation
3237           if(jctref(i,1,ir).ge.jctref(i,2,ir))then
3238             jctref(i,1,ir)=jctref(i,1,ir)-jctref(i,2,ir)
3239             jctref(i,2,ir)=0
3240 c update valence quarks (cancel first sea quarks)
3241             if(jctref(i,1,ir)-jc(i,1).lt.0)jc(i,1)=jctref(i,1,ir)
3242             jc(i,2)=0
3243           else
3244             jctref(i,2,ir)=jctref(i,2,ir)-jctref(i,1,ir)
3245             jctref(i,1,ir)=0
3246 c update valence quarks (cancel first sea quarks)
3247             if(jctref(i,2,ir)-jc(i,2).lt.0)jc(i,2)=jctref(i,2,ir)
3248             jc(i,1)=0
3249           endif
3250
3251           endif
3252
3253           do j=1,2
3254             itest=itest+jctref(i,j,ir)
3255             jc2(i,j)=jctref(i,j,ir)
3256           enddo
3257         enddo
3258         if(itest.eq.0)then !do not leave empty remnant
3259           idum=idrafl(icltar,jc2,1,'r',3,iretso)     !create q-qb
3260           do j=1,2
3261             do i=1,nrflav
3262               jctref(i,j,ir)=jc2(i,j)
3263             enddo
3264           enddo
3265         endif
3266       if(ish.ge.6)write(ifch,'(a,i3,a,1x,4i3,3x,4i3)')
3267      & 'jctref(',ir,') ini:',((jctref(i,j,ir),i=1,nflavems),j=1,2)
3268       else
3269         stop'mod not recognized in UpdateFlav'
3270       endif
3271       end
3272
3273 c-----------------------------------------------------------------------
3274       subroutine CalcZZ(ir,m)
3275 c-----------------------------------------------------------------------
3276 C Calculates zz for remnant m for proj (ir=1) or target (ir=-1)
3277 c   writes it to zzremn(m, 1 or 2)
3278 c-----------------------------------------------------------------------
3279       include 'epos.inc'
3280       include 'epos.incems'
3281       include 'epos.incpar'
3282       if(isplit.eq.1)then
3283         if(ir.eq.1)then
3284           zz=0.
3285           if(lproj3(m).ge.1)then
3286             do l=1,lproj3(m)
3287               kpair=kproj3(m,l)
3288               zpar=zparpro(kpair)
3289               zz=zz+min(zpar,epscrx)
3290              enddo
3291           endif
3292           zzremn(m,1)=zz
3293        elseif(ir.eq.-1)then
3294           zz=0
3295           if(ltarg3(m).ge.1)then
3296             do l=1,ltarg3(m)
3297               kpair=ktarg3(m,l)
3298               zpar=zpartar(kpair)
3299               zz=zz+min(zpar,epscrx)
3300             enddo
3301           endif
3302           zzremn(m,2)=zz
3303         else
3304           stop'CalcZZ: invalid option.          '
3305         endif
3306       else
3307         if(ir.eq.1) zzremn(m,1)=0
3308         if(ir.eq.-1)zzremn(m,2)=0
3309       endif
3310       end
3311
3312 c-----------------------------------------------------------------------
3313       subroutine WriteZZ(ir,irem)
3314 c-----------------------------------------------------------------------
3315 c Write Z into zpaptl(K) for connected strings
3316 c                 K is the index for the string end
3317 c                 on the corresponding remnant side
3318 c-----------------------------------------------------------------------
3319
3320       include 'epos.inc'
3321       include 'epos.incems'
3322       common/emsptl/nppr(npommx,kollmx),npproj(mamx),nptarg(mamx)
3323       common/cems5/plc,s
3324       double precision s,plc
3325
3326       if(ir.eq.1)then
3327         jrem=1
3328       elseif(ir.eq.-1)then
3329         jrem=2
3330       else
3331         jrem=0
3332         call utstop("Wrong ir in WriteZZ !&")
3333       endif
3334
3335       do li=1,lremn(irem,jrem)
3336         kkk=kremn(irem,li,jrem)
3337 c        ip=iproj(kkk)
3338 c        it=itarg(kkk)
3339          amtot=0.
3340          do n=1,nprmx(kkk)
3341            if(idpr(n,kkk).ne.0)amtot=amtot+sngl(xpr(n,kkk)*s)
3342          enddo
3343          amtot=sqrt(amtot)
3344          do n=1,nprmx(kkk)
3345           if(idpr(n,kkk).ne.0)then
3346            npom=nppr(n,kkk)
3347 c              write(ifch,*)'remn',irem,' (',jrem,' )     pom',npom
3348 c     &            ,'    ',zzremn(irem,jrem)
3349            ie=0
3350            is1=0
3351            if(ifrptl(1,npom).gt.0)then
3352             do is=ifrptl(1,npom),ifrptl(2,npom)
3353               if(ie.eq.0)is1=is
3354               if(idptl(is).ne.9)ie=ie+1
3355               if(ie.eq.2)then
3356                is2=is
3357                ie=0
3358                if(ir.eq. 1)then
3359 c  Z for remnant ip (low if alone and high in nucleus)
3360                  zpaptl(1,is1)=zzremn(irem,jrem)
3361 c  sum of Z of remnant itt linked to ip (high if connected to many other remn)
3362                  zpaptl(2,is1)=amtot !float(nprt(kkk)) !float(lproj(ip))
3363 c                 zpaptl(2,is1)=0.
3364 c                 if(lproj(ip).ge.1)then
3365 c                   do l=1,lproj(ip)
3366 c                     kpair=kproj(ip,l)
3367 c                     itt=itarg(kpair)
3368 c                     zpaptl(2,is1)=zpaptl(2,is1)+zzremn(itt,2)
3369 c                   enddo
3370 c                 endif
3371                endif
3372                if(ir.eq.-1)then
3373 c  Z for remnant it (low if alone and high in nucleus)
3374                  zpaptl(1,is2)=zzremn(irem,jrem)
3375 c  sum of Z of remnant ipp linked to it (high if connected to many other remn)
3376                  zpaptl(2,is2)=float(nprt(kkk)) !float(ltarg(it))
3377 c                 zpaptl(2,is2)=0.
3378 c                 if(ltarg(it).ge.1)then
3379 c                   do l=1,ltarg(it)
3380 c                     kpair=ktarg(it,l)
3381 c                     ipp=iproj(kpair)
3382 c                     zpaptl(2,is2)=zpaptl(2,is2)+zzremn(ipp,1)
3383 c                   enddo
3384 c                 endif
3385                endif
3386 c               do isi=is1,is2
3387 c                write(ifch,*)' ',isi,idptl(isi),zpaptl(1,isi),zpaptl(2,isi)
3388 c               enddo
3389               endif
3390             enddo
3391            endif
3392           endif
3393         enddo
3394       enddo
3395
3396       end
3397
3398 c-----------------------------------------------------------------------
3399       subroutine ProReM(ir,irem,iret)
3400 c-----------------------------------------------------------------------
3401 c propose remnant mass of remnant irem in case of proj (ir=1)
3402 c or target (ir=-1)
3403 c   (-> xmp, xpt)
3404 c iret : input : if iret=10 force to give mass even if no more energy,
3405 c        when input not 10 : output = error if 1
3406 c Energy is taken only from the other side nucleon which are close enough
3407 c to form a pair even if that pair was not used for a collision.
3408 c-----------------------------------------------------------------------
3409
3410       include 'epos.inc'
3411       include 'epos.incems'
3412       include 'epos.incsem'
3413       double precision rr,xxx,xmin,xmax,msmin,xmmin,xpt2rem,xtest0,xtmp
3414       double precision at,alp,xi,xii,eps,sx,xmin0,xtest(mamx),fxtest
3415       parameter(eps=1.d-20)
3416       common/cemsr5/at(0:1,0:5)
3417       double precision plc,s,p5sq,aremn,aremnex,xxmax,drangen!,xmdrmax
3418       common/cems5/plc,s
3419       integer icrmn(2),jc(nflav,2)
3420       logical cont,force,drop,excited
3421       character cremn*4
3422       dimension k2j(mamx)
3423
3424       call utpri('ProReM',ish,ishini,5)
3425
3426       if(iret.eq.10)then
3427         force=.true.
3428       else
3429         iret=0
3430         force=.false.
3431       endif
3432       ntrymx=50
3433       do j=1,2
3434         do i=1,nflav
3435           jc(i,j)=0
3436         enddo
3437       enddo
3438
3439 c uncomment the following two lines to force the excitation
3440
3441 ccc      force=.true.   !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
3442 ccc      ntrymx=1       !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
3443
3444 c initial definitions
3445
3446       ntry=0
3447       iremo1=0
3448       jremo=0
3449 c... initialize
3450       jrem=0.0
3451       amremn=0.0
3452       if(ir.eq.1)then
3453         cremn='targ'
3454         jrem=1
3455         jremo=2
3456         masso=lproj(irem)     !number of target nucleon linked to irem
3457         do k=1,masso
3458           k2j(k)=itarg(kproj(irem,k))
3459           xme(k2j(k))=0.d0
3460         enddo
3461         icrmn(1)=icremn(1,irem,jrem)
3462         if(icrmn(1).eq.999999)then    !more than 9 quark : use jcpref
3463           do j=1,2
3464             do i=1,nrflav
3465               jc(i,j)=jcpref(i,j,irem)
3466             enddo
3467           enddo
3468         else
3469           icrmn(2)=icremn(2,irem,jrem)
3470           call iddeco(icrmn,jc)
3471         endif
3472         amremn=amproj
3473            !idx=isign(iabs(idproj)/10*10+1,idproj)
3474            !call idmass(idx,amremn)
3475         iremo1=itarg(1)
3476         msmin=dble(amremn*amremn)
3477         zz=1.
3478         if(iez(irem,jrem).eq.3.or.iez(irem,jrem).eq.5)
3479      &  zz=zz+zzremn(irem,1)*zmsinc
3480       elseif(ir.eq.-1)then
3481         cremn='proj'
3482         jrem=2
3483         jremo=1
3484         masso=ltarg(irem)  !number of projectile nucleon linked to irem
3485         do k=1,masso
3486           k2j(k)=iproj(ktarg(irem,k))
3487           xme(k2j(k))=0.d0
3488         enddo
3489         icrmn(1)=icremn(1,irem,jrem)
3490         if(icrmn(1).eq.999999)then    !more than 9 quark : use jctref
3491           do j=1,2
3492             do i=1,nrflav
3493               jc(i,j)=jctref(i,j,irem)
3494             enddo
3495           enddo
3496         else
3497           icrmn(2)=icremn(2,irem,jrem)
3498           call iddeco(icrmn,jc)
3499         endif
3500         amremn=amtarg
3501            !idx=isign(iabs(idtarg)/10*10+1,idtarg)
3502            !call idmass(idx,amremn)
3503         iremo1=iproj(1)
3504         msmin=dble(amremn*amremn)
3505         zz=1.
3506         if(iez(irem,jrem).eq.3.or.iez(irem,jrem).eq.5)
3507      &  zz=zz+zzremn(irem,2)*zmsinc
3508       endif
3509       drop=.false.
3510       if(iremn.ge.2.and.(iez(irem,jrem).eq.3.or.iez(irem,jrem).eq.5))
3511      &   drop=.true.
3512       excited=.false.
3513       if(iez(irem,jrem).gt.0.and.iez(irem,jrem).ne.6)
3514      &   excited=.true.
3515
3516 c for spectators only low mass and few partners, so do not care about energy
3517       if(iez(irem,jrem).eq.6)force=.true.
3518
3519 c defs
3520
3521       sx=s*xpz(irem,jrem)
3522       xpt2rem=xxz(irem,jrem)**2d0+xyz(irem,jrem)**2d0
3523
3524 c  fremnux (+) and not fremnux2 (-) which gives a mass too low in case of gethadron where q and aq do not cancel
3525
3526
3527       if(excited)then
3528         aremn=dble(max(amremn,fremnux(jc)))
3529 c       if(iremn.eq.2.and.iez(irem,jrem).eq.3)      !droplet
3530 c     &     aremn=dble(max(amremn,fremnux(jc)))
3531         if(iremn.ge.2)then
3532           aremnex=aremn+amemn(idz(irem,jrem),iez(irem,jrem))
3533 c         if(drop)aremnex=aremnex*zz
3534         else
3535           aremnex=aremn+amemn(idz(irem,jrem),iez(irem,jrem))
3536         endif
3537       elseif(iLHC.eq.1)then !minimum mass for spectators should be as low as possible
3538         aremn=amremn
3539         aremnex=dble(max(amremn,fremnux2(jc)))
3540       else    !minimum mass for spectators should be as low as possible
3541         aremn=dble(max(amremn,fremnux2(jc)))
3542         aremnex=aremn
3543       endif
3544
3545
3546       if(ish.ge.8)write(ifch,10)ir,irem,masso,icrmn,iez(irem,jrem),force
3547      &                         ,amremn,fremnux(jc),aremn,aremnex
3548      &                         ,xpz(irem,jrem),xpt2rem,sx
3549  10   format('prorem :  ',i3,2i4,2i7,i2,L2,/
3550      &      ,'    mass :',4g13.5,/
3551      &      ,' x,pt,sx :',3g13.5)
3552 c ntry
3553
3554     1 ntry=ntry+1
3555       if(ntry.gt.ntrymx)then
3556         if(ish.ge.5)then
3557           call utmsg('ProReM')
3558           write(ifch,*)'Remnant mass assignment not possible (ntry)'
3559      &                 ,ir,irem
3560           if(force)write(ifch,*)'Ignore p4 conservation'
3561           call utmsgf
3562         endif
3563         if(.not.force)then
3564           iret=1
3565           goto 1000
3566         else
3567 c not enough energy availabe : force last mass and check
3568           goto 900
3569         endif
3570       endif
3571
3572 c check
3573
3574       if(xpz(irem,jrem).le.0.d0)then
3575         write(ifch,*)'ProRem ipp',xpz(irem,jrem)
3576      &                           ,jrem,irem,lremn(irem,jrem)
3577         do li=1,lremn(irem,jrem)
3578           kkk=kremn(irem,li,jrem)
3579           write(ifch,*)'kkk',kkk
3580         enddo
3581         call XPrint('ProRem :&')
3582         call utstop('Big problem in ProRem !&')
3583       endif
3584
3585 c xtest = xminus-max,  corresponding mostly to a remnant mass 0.2
3586
3587       xtest0=0.d0
3588       fxtest=0.4d0*(1d0+drangen(xxx)) !1.d0 !0.3d0
3589       do k=1,masso
3590         j=k2j(k)
3591         cont=.false.
3592 ctp        if(xmz(j,jremo).gt.eps.and.iez(j,jrem).gt.0)then !xmz(,jremo)=xplus
3593 ctp060824        if(xmz(j,jremo).gt.eps.and.iez(j,jrem).ge.0)then !xmz(,jremo)=xplus
3594 c        if(iez(j,jremo).gt.0.or.koll.eq.1)then !xmz(,jremo)=xplus
3595           if(xmz(j,jremo).gt.eps)then !xmz(,jremo)=xplus
3596             cont=.true.
3597             xmmin=xzos(j,jremo)/xmz(j,jremo)
3598           else
3599             xmmin=xzos(j,jremo)
3600           endif
3601           xtest(j)=xpz(j,jremo)-xmmin !maximal momentum available
3602 !this term is very important for non excited remnants in pp, it changes the xf
3603 ! distribution of proton and the multiplicity at low energy. Fxtest should not
3604 ! be to close to 0. otherwise it makes a step in xf distribution of p at
3605 ! 1-fxtest but if fxtest=1, multiplicity at low energy is too high ...
3606 ! but better (and smoother) with exponential decrease).
3607           if(.not.cont)then
3608             if(xtest(j).gt.0d0)then
3609               xtest(j)=min(xtest(j),fxtest/xpz(irem,jrem))
3610             else
3611               xtest(j)=min(1.d0,fxtest/xpz(irem,jrem))
3612             endif
3613           endif
3614 c        else
3615 c          xtest(j)=0.01d0 !maximal momentum available for non exited state
3616 c        endif
3617          xtest0=max(xtest0,xtest(j))
3618 c        print *,iep(1),iet(1),iez(irem,jrem),xtest(j),xpz(j,jremo),xmmin
3619 c     & ,xzos(j,jremo),xmz(j,jremo)
3620       enddo
3621 ctp060824      if(.not.cont)xtest=min(1.d0,0.2d0/xpz(irem,jrem))
3622
3623
3624
3625 c determine xminus
3626
3627 c      xmin0=1.05*(aremn**2d0+xxz(irem,jrem)**2d0+xyz(irem,jrem)**2d0)/sx
3628 c      xmin=1.1*(aremnex**2d0+xxz(irem,jrem)**2d0+xyz(irem,jrem)**2d0)/sx
3629       xmin0=1.1d0*(aremn**2d0+xpt2rem)/sx
3630       if(iLHC.eq.1.and.xmin0.ge.1.d0)xmin0=min(xmin0,0.9d0)
3631       if(ish.ge.1.and.xmin0.ge.1d0)
3632      &   write(ifch,*)"Warning in ProReM with xmin0 !"
3633
3634       if(iez(irem,jrem).eq.4)then !pion exchange, minim should not change
3635         xmin=dble(xmindiff)*(aremnex**2d0+xpt2rem)/sx
3636       else
3637         xmin=dble(xminremn)*(aremnex**2d0+xpt2rem)/sx
3638       endif
3639 c      xmax=min(1.d6/s,xtest0)             !to avoid ultra high mass remnants
3640       xmax=xtest0
3641 c for diffractive remnant, mass should never exceed 5% of the proj or targ energy
3642 c      if(iez(irem,jrem).eq.1)then
3643 c        xmax=min(xmax,max(dble(xminremn),xmin))
3644 c      elseif(iez(irem,jrem).eq.2)then
3645 c        xmax=min(xmax,max(dble(xmindiff),xmin))
3646 c      endif
3647 c      if(iez(irem,jrem).eq.1.or.iez(irem,jrem).eq.3)then
3648 c       xtmp=max(dble(min(1.,xminremn*float(maproj+matarg-1))),xmin)
3649 c     &               *drangen(xmin)
3650       xtmp=1.d0
3651       if(excited)then
3652       if(iez(irem,jrem).eq.2)then
3653 c        xtmp=max(min(1d0,dble(xmindiff)),xmin)!*drangen(xmin)
3654         xtmp=min(1d0,dble(xmxrem)*dble(masso)
3655      &                      *drangen(xmin)**0.05)
3656 c        xtmp=dble(xmindiff)
3657       elseif(iez(irem,jrem).eq.1)then
3658         xtmp=min(1d0,dble(xmxrem)*dble(masso)
3659      &                      *drangen(xmin)**0.05)
3660 c        xtmp=dble(xminremn)
3661       elseif(drop)then     !3 or 5
3662 c       xtmp=max(dble(min(1.,xminremn*float(maproj+matarg-1))),xmin)
3663 c     &               *drangen(xmin)
3664         xtmp=min(1d0,dble(xmxrem)*zz*dble(masso)
3665      &                         *drangen(xmin)**0.05)
3666 c        xtmp=dble(xminremn)
3667       endif
3668       endif
3669       xmax=min(xmax,max(xtmp,xmin))
3670       if(ish.ge.8)write(ifch,*)'ntry',ntry,xmin,xmax,xtmp
3671      *                               ,xmax*dble(masso),xmin0,excited
3672       if(koll.eq.1)xmax=min(xmax,xpz(iremo1,jremo))
3673       xxmax=xmax*dble(masso)-eps
3674       if(iLHC.eq.1)xxmax=min(1d0-eps,xxmax)      !check energy limit
3675       if(xmin.ge.xxmax)then
3676         xmax=xxmax
3677         xmin=xmin0
3678         if(xmin0.ge.xmax-eps)then
3679           if(.not.force)then
3680             iret=1
3681           elseif(excited)then
3682             xmz(irem,jrem)=min(1.-xpz(irem,jrem),
3683      &                       xmin0+0.5d0*(1d0-xmin0)*drangen(xmin)) !random not to form a peak
3684           else
3685             xxx=(aremn**2d0+xpt2rem)/sx
3686             xmz(irem,jrem)=xxx
3687 c            xmin0=max(0.5d0,(1d0-((amzmn(idz(irem,jremo),jremo)
3688 c     &                   +6d0*drangen(xxx))**2+xpt2rem)/sx))*xxx
3689             if(iLHC.eq.1)then     !LHC tune (more reasonnable xsi distribution)
3690 c          xmin0=(1d0-xmin**0.3)*xxx
3691               xmin0=max(0.35d0*(1d0+drangen(xxx))
3692      &          ,1d0-((amzmn(idz(irem,jremo),jremo)
3693      &             +engy**drangen(xxx))**2+xpt2rem)/sx)*xxx
3694             else   !original CR version
3695               xmin0=max(0.35d0*(1d0+drangen(xxx))
3696      &          ,1d0-((amzmn(idz(irem,jremo),jremo)
3697      &             +sqrt(engy)*drangen(xxx)**0.5)**2+xpt2rem)/sx)*xxx
3698             endif
3699           endif
3700           goto 1000
3701         endif
3702       elseif(xmin.ge.xmax)then
3703         xmax=1d0
3704       endif
3705       rr=dble(rangen())
3706       alp=0.
3707       xxx=0.d0
3708       if(excited)then
3709 c        xmin=xmin-xpt2rem/sx                     !no pt
3710 c        xmax=xmax-xpt2rem/sx                     !no pt
3711         alp=at(idz(irem,jrem),iez(irem,jrem))/dble(zz)
3712
3713         if(dabs(alp-1.d0).lt.eps)then
3714           xxx=xmax**rr*xmin**(1d0-rr)
3715         else
3716           xxx=(rr*xmax**(1d0-alp)+(1d0-rr)*xmin**(1d0-alp))
3717      &                                             **(1d0/(1d0-alp))
3718         endif
3719 c        xxx=xxx+xpt2rem/sx                       !no pt
3720 !smooth distribution
3721         if(iez(irem,jrem).eq.4)xmin=xmin0
3722         xmin0=xmin+(1d0-exp(-2d0*drangen(xxx)**2))*(xxx-xmin)
3723       else
3724         if(masso.eq.1)ntry=ntrymx   !xxx is fixed so 1 try is enough
3725 c        xmin=dble(amremn)**2d0/sx                !no pt
3726 c        xxx=xmin+xpt2rem/sx                      !no pt
3727         xmin=(dble(aremn)**2d0+xpt2rem)/sx
3728         xxx=xmin
3729         if(xmin.gt.xmax+eps)then
3730           if(ish.ge.6)write(ifch,*)'xmin>xmax for proj not possible (2)'
3731      &                 ,ir,irem
3732           if(.not.force)then
3733             iret=1
3734           else
3735             xmz(irem,jrem)=xxx
3736           endif
3737           goto 1000
3738         endif
3739 c to have a nice diffractive peak, do not allow too much fluctuation
3740 c this function is more or less a fit of the diffractive peak
3741 c (pp100, ep-forward (ZEUS), NA49, pipp100, taking into account the
3742 c contribution of inelastic remnants)
3743           if(iLHC.eq.1)then     !LHC tune (more reasonnable xsi distribution)
3744 c          xmin0=(1d0-xmin**0.3)*xxx
3745             xmin0=max(0.35d0*(1d0+drangen(xxx))
3746      &          ,1d0-((amzmn(idz(irem,jremo),jremo)
3747      &             +engy**drangen(xxx))**2+xpt2rem)/sx)*xxx
3748           else   !original CR version
3749             xmin0=max(0.35d0*(1d0+drangen(xxx))
3750      &          ,1d0-((amzmn(idz(irem,jremo),jremo)
3751      &             +sqrt(engy)*drangen(xxx)**0.5)**2+xpt2rem)/sx)*xxx
3752           endif
3753
3754 c       write(*,*)'->',xmin0/xxx,sx,log10(1d0-xmin0/xxx)
3755 c     &,1d0-((amzmn(idz(irem,jremo),jremo)
3756 c     &+5d0*exp(-0.5d0*drangen(xxx)**2))**2+xpt2rem)/sx
3757 c        xmin0=dble(0.9+0.09*rangen())*xxx
3758       endif
3759       if(ish.ge.8)write(ifch,*)'alp',alp,xmin,xxx,xmax,zz
3760       msmin=xmin*sx
3761 c      msmin=xmin*sx+xpt2rem                      !no pt
3762
3763 c partition xminus between nucleons of the other side
3764
3765       xii=1d0
3766       ii=masso
3767       kk=int(rangen()*float(ii))+1   ! choose ramdomly a nucleon to start
3768
3769       do while(ii.gt.0)
3770
3771         iro=k2j(kk)
3772         cont=iez(iro,jremo).lt.0.or.xme(iro).lt.-0.99d0
3773         do while(cont)
3774           kk=kk+1
3775           if(kk.gt.masso)kk=kk-masso
3776           iro=k2j(kk)
3777           ii=ii-1
3778           if(ii.lt.1)then
3779             ntry=ntrymx
3780             goto 1
3781           endif
3782           cont=iez(iro,jremo).lt.0.or.xme(iro).lt.-0.99d0
3783         enddo
3784
3785         if(ii-1.gt.0)then
3786          xi=xii*dble(rangen())**(1.d0/dble(ii-1))
3787         else
3788          xi=0d0
3789         endif
3790         xme(iro)=xxx*(xii-xi)
3791
3792         xmmin=xzos(iro,jremo)
3793         if(xmz(iro,jremo).gt.eps)then
3794           xmmin=xmmin/xmz(iro,jremo)
3795         elseif(koll.eq.1.and.xtest(iro).gt.eps)then
3796           xmmin=xmmin/min(xpz(irem,jrem),xtest(iro))
3797         elseif(xtest(iro).gt.eps)then
3798           xmmin=xmmin/xtest(iro)
3799         endif
3800         if((xpz(iro,jremo)-xme(iro)).lt.xmmin)then
3801           if(ish.ge.8)write(ifch,*)'     skip ',cremn,' ',ii,masso,ntry
3802      &                      ,iro,xme(iro),xpz(iro,jremo)-xme(iro),xmmin
3803           xme(iro)=-1.d0
3804           if(ii.le.1)goto 1
3805         else
3806           xii=xi
3807           if(ish.ge.8)write(ifch,*)'       ok ',cremn,' ',ii,masso,ntry
3808      &                      ,iro,xme(iro),xme(iro)/xxx
3809         endif
3810         kk=kk+1
3811         if(kk.gt.masso)kk=kk-masso
3812         ii=ii-1
3813
3814       enddo
3815
3816 c check xmz(irem,jrem)
3817
3818  900  xmz(irem,jrem)=xxx
3819
3820       p5sq=xpz(irem,jrem)*xmz(irem,jrem)*s
3821       if(ish.ge.8)write(ifch,*)'final mass',irem,p5sq,msmin
3822      &,xpz(irem,jrem),xmz(irem,jrem),force
3823       if(p5sq-msmin.lt.-1d-10)then
3824         if(ish.ge.5)then
3825           call utmsg('ProReM')
3826           write(ifch,*)'Remnant mass assignment not possible (M<Mmin)!'
3827      &                 ,ir,irem
3828           if(force)write(ifch,*)'Ignore p4 conservation'
3829           call utmsgf
3830         endif
3831         if(.not.force)then
3832           iret=1
3833         elseif(xpz(irem,jrem).gt.0.d0)then
3834           xmz(irem,jrem)=min(1.-xpz(irem,jrem),
3835      &                       xmin+0.5d0*(1d0-xmin)*drangen(xmin))   !random not to form a peak
3836         endif
3837         goto 1000
3838       endif
3839
3840 c subtract xme
3841
3842       do k=1,masso
3843         iro=k2j(k)
3844         if(xme(iro).gt.0.d0)then
3845           xpz(iro,jremo)=xpz(iro,jremo)-xme(iro)  !xpz(,jremo)=xminus
3846         endif
3847       enddo
3848
3849  1000 continue
3850       if(iret.ne.1)xzos(irem,jrem)=xmin0*xpz(irem,jrem)
3851
3852       call utprix('ProReM',ish,ishini,5)
3853
3854       end
3855
3856 c-----------------------------------------------------------------------
3857       subroutine ProSeTy(k,n)
3858 c-----------------------------------------------------------------------
3859 c creates proposal for string ends, idp., idm.
3860 c updates quark counters
3861 c-----------------------------------------------------------------------
3862       include 'epos.inc'
3863       include 'epos.incems'
3864       include 'epos.incsem'
3865
3866       common/ems6/ivp0,iap0,idp0,isp0,ivt0,iat0,idt0,ist0
3867       double precision pes,xfqp,xfqt   !so01
3868       parameter(eps=1.e-6)
3869       common/ems9/xfqp(0:9),xfqt(0:9)
3870       common/emsx3/pes(0:3,0:6)
3871       integer jcp(nflav,2),jct(nflav,2)
3872      &       ,jcpi(nflavems,2),jcti(nflavems,2)
3873       logical go
3874
3875       if(idpr(n,k).eq.2)stop'no Reggeons any more'
3876
3877       iret=0
3878       ip=iproj(k)
3879       it=itarg(k)
3880       if(iremn.ge.3)then
3881         do j=1,2
3882           do i=1,nrflav
3883             jcp(i,j)=jcpref(i,j,ip)
3884             jct(i,j)=jctref(i,j,it)
3885           enddo
3886           do i=nrflav+1,nflav
3887             jcp(i,j)=0
3888             jct(i,j)=0
3889           enddo
3890         enddo
3891       endif
3892
3893       idp1pr(n,k)=0
3894       idm1pr(n,k)=0
3895       idp2pr(n,k)=0
3896       idm2pr(n,k)=0
3897       idsppr(n,k)=0
3898       idstpr(n,k)=0
3899       pssp=0.
3900       pvsp=0.
3901       pvap=0.
3902       pddp=0.
3903       psvvp=0.
3904       paasp=0.
3905       psst=0.
3906       pvst=0.
3907       pvat=0.
3908       pddt=0.
3909       psvvt=0.
3910       paast=0.
3911
3912       if(iLHC.eq.1)then
3913
3914 c for hard Pomeron, define which string ends are connected to valence quark
3915 c treat gluon has soft string ends (including diquarks but can not be
3916 c a "soft" valence like in soft Pomerons) later
3917       if(idpr(n,k).eq.3)then
3918         go=.false.
3919         if(ivp0.eq.iap0.and.rangen().lt.0.5)go=.true.    !meson
3920         idsppr(n,k)=5
3921         if(idhpr(n,k).eq.3.or.idhpr(n,k).eq.1)then
3922           if(iremn.ge.2)ivp(ip)=ivp(ip)-1
3923           if(iap0.eq.0.or.go)then !baryon
3924             idp1pr(n,k)=2
3925           else                    !antibaryon
3926             idp2pr(n,k)=2
3927           endif
3928         endif
3929         idstpr(n,k)=5
3930         if(idhpr(n,k).eq.3.or.idhpr(n,k).eq.2)then
3931           if(iremn.ge.2)ivt(it)=ivp(it)-1
3932           if(iat0.eq.0)then     !baryon
3933             idm1pr(n,k)=2
3934           else                  !antibaryon
3935             idm2pr(n,k)=2
3936           endif
3937         endif
3938       endif
3939
3940       if(idpr(n,k).ne.0)then
3941
3942 c    projectile
3943
3944        if(idfpr(n,k).eq.1.or.idfpr(n,k).eq.2)then
3945
3946        ntry=0
3947        ivpi=ivp(ip)
3948        idpi=idp(ip)
3949        idspi=idsppr(n,k)
3950        if(iremn.eq.3)then
3951          do j=1,2
3952            do i=1,nrflav
3953              jcpi(i,j)=jcp(i,j)
3954            enddo
3955          enddo
3956        endif
3957   1    ntry=ntry+1
3958       if(ntry.gt.10)call utstop('something goes wrong in sr ProSeTy&')
3959        ivp(ip)=ivpi
3960        idp(ip)=idpi
3961        idsppr(n,k)=idspi
3962        if(iremn.eq.3)then
3963          do j=1,2
3964            do i=1,nrflav
3965              jcp(i,j)=jcpi(i,j)
3966            enddo
3967          enddo
3968        endif
3969        pss=wgtval+wgtsea
3970        if(pss.gt.0.)then
3971          pss=wgtsea/pss
3972        else
3973          pss=0.
3974        endif
3975        if(iremn.ge.2)then
3976          if(iap0.eq.0)then
3977            pvs=0.
3978            if(ivp(ip).ne.0.and.idpr(n,k).ne.3)pvs=1.-pss
3979            pva=0.
3980            psvv=0.
3981            if(idp(ip).ne.0.and.idp2pr(n,k).ne.2)psvv=wgtqqq(iclpro)
3982            paas=0.
3983          elseif(ivp0.eq.0)then
3984            pva=0.
3985            if(ivp(ip).ne.0.and.idpr(n,k).ne.3)pva=1.-pss
3986            pvs=0.
3987            psvv=0.
3988            paas=0.
3989            if(idp(ip).ne.0.and.idp1pr(n,k).ne.2)paas=wgtqqq(iclpro)
3990          else                   !for meson, no soft string with valence quark (we do not know whether the quark or the antiquark will be used by hard string)
3991            pvs=0.
3992            pva=0.
3993 c diquark or antidiquark can be created once in meson remnant
3994            psvv=0.
3995            paas=0.
3996            if(1+idp(ip).ne.0)then
3997              if(idp2pr(n,k).ne.2)psvv=wgtqqq(iclpro)
3998              if(idp1pr(n,k).ne.2)paas=wgtqqq(iclpro)
3999            endif
4000          endif
4001          pdd=wgtdiq/(1.+float(abs(idp(ip))))
4002 c         if(idpr(n,k).eq.3)then
4003 c           pdd=0.
4004 c           psvv=0.
4005 c           paas=0.
4006 c         endif
4007        elseif(iremn.ne.0)then
4008          pvs=0.
4009          pva=0.
4010          psvv=0.
4011          paas=0.
4012          if(idp2pr(n,k).ne.2)psvv=wgtqqq(iclpro)
4013          if(idp1pr(n,k).ne.2)paas=wgtqqq(iclpro)
4014          pdd=wgtdiq/(1.+float(abs(idp(ip))))
4015        else
4016          pvs=0.
4017          pva=0.
4018          psvv=0.
4019          paas=0.
4020          pdd=wgtdiq/(1.+float(abs(idp(ip))))
4021        endif
4022        if(idp1pr(n,k).eq.2)then  !with valence quark only 1 SE available
4023          psd=pdd
4024          pds=0.
4025          pdd=0.
4026        elseif(idp2pr(n,k).eq.2)then  !with valence antiquark only 1 SE available
4027          pds=pdd
4028          psd=0.
4029          pdd=0.
4030        else
4031          psd=pdd
4032          pds=pdd
4033          pdd=pdd**2
4034        endif
4035        su=1.-min(1.,pdd+psd+pds)            !diquark probability
4036        pss=(1.-min(1.,pvs+pva))*su        !no more valence quark: take from sea
4037        pvs=pvs*su
4038        pva=pva*su
4039        su=1.-min(1.,psvv+paas)      !stopping probability
4040        pss=pss*su
4041        pvs=pvs*su
4042        pva=pva*su
4043        psd=psd*su
4044        pds=pds*su
4045        pdd=pdd*su
4046        su=pss+pvs+pva+pdd+psd+pds+psvv+paas
4047        pssp = pss /su
4048        pvsp = pvs /su
4049        pvap = pva /su
4050        psdp = psd /su
4051        pdsp = pds /su
4052        pddp = pdd /su
4053        psvvp= psvv/su
4054        paasp= paas/su
4055        r=rangen()
4056        if(r.gt.(pssp+pvsp+pvap+psdp+pdsp+psvvp+paasp)
4057      &                               .and.pddp.gt.eps)then
4058         if(idp1pr(n,k).ne.2)idp1pr(n,k)=4
4059         if(idp2pr(n,k).ne.2)idp2pr(n,k)=4
4060         idsppr(n,k)=idsppr(n,k)+4
4061         if(iremn.ge.2)idp(ip)=idp(ip)+2
4062         if(iremn.eq.3)then   !add diquark flavor to jcpref for ProSeF later (sea quark)
4063           idum=idrafl(iclpro,jcp,1,'s',3,iret)
4064           idum=idrafl(iclpro,jcp,1,'d',3,iret)
4065           idum=idrafl(iclpro,jcp,1,'s',3,iret)
4066           idum=idrafl(iclpro,jcp,1,'d',3,iret)
4067         endif
4068       elseif(r.gt.(pssp+pvsp+pvap+psdp+psvvp+paasp).and.pdsp.gt.eps)then
4069         if(idp1pr(n,k).ne.2)idp1pr(n,k)=4
4070         if(idp2pr(n,k).ne.2)idp2pr(n,k)=1
4071         idsppr(n,k)=idsppr(n,k)+4
4072         if(iremn.ge.2)idp(ip)=idp(ip)+1
4073         if(iremn.eq.3)then   !add diquark flavor to jcpref for ProSeF later (sea quark)
4074           idum=idrafl(iclpro,jcp,1,'s',3,iret)
4075           idum=idrafl(iclpro,jcp,1,'d',3,iret)
4076         endif
4077        elseif(r.gt.(pssp+pvsp+pvap+psvvp+paasp).and.psdp.gt.eps)then
4078         if(idp1pr(n,k).ne.2)idp1pr(n,k)=1
4079         if(idp2pr(n,k).ne.2)idp2pr(n,k)=4
4080         idsppr(n,k)=idsppr(n,k)+4
4081         if(iremn.ge.2)idp(ip)=idp(ip)+1
4082         if(iremn.eq.3)then   !add diquark flavor to jcpref for ProSeF later (sea quark)
4083           idum=idrafl(iclpro,jcp,1,'s',3,iret)
4084           idum=idrafl(iclpro,jcp,1,'d',3,iret)
4085         endif
4086        elseif(r.gt.(pssp+pvsp+pvap+psvvp).and.paasp.gt.eps)then
4087         if(idp1pr(n,k).ne.2)idp1pr(n,k)=5
4088         if(idp2pr(n,k).ne.2)idp2pr(n,k)=1
4089         idsppr(n,k)=idsppr(n,k)+5
4090         if(iremn.ge.2)idp(ip)=idp(ip)-1
4091         if(iremn.eq.3)idum=idrafl(iclpro,jcp,1,'s',3,iret) !add flavor to jcpref for ProSeF later (sea quark) (only a q-aq pair because we replace diquark by q-aq (baryon "decay" or "stopping")
4092        elseif(r.gt.(pssp+pvsp+pvap+pddp).and.psvvp.gt.eps)then
4093         if(idp1pr(n,k).ne.2)idp1pr(n,k)=1
4094         if(idp2pr(n,k).ne.2)idp2pr(n,k)=5
4095         idsppr(n,k)=idsppr(n,k)+5
4096         if(iremn.ge.2)idp(ip)=idp(ip)-1
4097         if(iremn.eq.3)idum=idrafl(iclpro,jcp,1,'s',3,iret) !add flavor to jcpref for ProSeF later (sea quark) (only a q-aq pair because we replace diquark by q-aq (baryon "decay" or "stopping")
4098        elseif(r.gt.(pssp+pvsp).and.pvap.gt.eps)then
4099         if(idp1pr(n,k).ne.2)idp1pr(n,k)=1
4100         if(idp2pr(n,k).ne.2)idp2pr(n,k)=2
4101         idsppr(n,k)=idsppr(n,k)+2
4102         if(iremn.ge.2)ivp(ip)=ivp(ip)-1
4103         if(iremn.eq.3)idum=idrafl(iclpro,jcp,1,'s',3,iret) !add flavor to jcpref for ProSeF later (sea quark)
4104        elseif(r.gt.pssp.and.pvsp.gt.eps)then
4105         if(idp1pr(n,k).ne.2)idp1pr(n,k)=2
4106         if(idp2pr(n,k).ne.2)idp2pr(n,k)=1
4107         idsppr(n,k)=idsppr(n,k)+2
4108         if(iremn.ge.2)ivp(ip)=ivp(ip)-1
4109         if(iremn.eq.3)idum=idrafl(iclpro,jcp,2,'s',3,iret) !add flavor to jcpref for ProSeF later (sea quark)
4110        elseif(pssp.gt.eps)then
4111         if(idp1pr(n,k).ne.2)idp1pr(n,k)=1
4112         if(idp2pr(n,k).ne.2)idp2pr(n,k)=1
4113         idsppr(n,k)=idsppr(n,k)+1
4114         if(iremn.eq.3)idum=idrafl(iclpro,jcp,1,'s',3,iret) !add flavor to jcpref for ProSeF later (sea quark)
4115        else
4116         goto 1
4117        endif
4118
4119        else
4120         idp1pr(n,k)=1
4121         idp2pr(n,k)=1
4122         idsppr(n,k)=0
4123        endif
4124
4125
4126 c    target
4127
4128        if(idfpr(n,k).eq.1.or.idfpr(n,k).eq.3)then
4129
4130
4131        ntry=0
4132        ivti=ivt(it)
4133        idti=idt(it)
4134        idsti=idstpr(n,k)
4135        if(iremn.eq.3)then
4136          do j=1,2
4137            do i=1,nrflav
4138              jcti(i,j)=jct(i,j)
4139            enddo
4140          enddo
4141        endif
4142   2    ntry=ntry+1
4143        if(ntry.gt.10)call utstop('something goes wrong in sr ProSeTy&')
4144        ivt(it)=ivti
4145        idt(it)=idti
4146        idstpr(n,k)=idsti
4147        if(iremn.eq.3)then
4148          do j=1,2
4149            do i=1,nrflav
4150              jct(i,j)=jcti(i,j)
4151            enddo
4152          enddo
4153        endif
4154        pss=wgtval+wgtsea
4155        if(pss.gt.0.)then
4156          pss=wgtsea/pss
4157        else
4158          pss=0.
4159        endif
4160        if(iremn.ge.2)then
4161          if(iat0.eq.0)then
4162            pvs=0.
4163            if(ivt(it).ne.0.and.idpr(n,k).ne.3)pvs=1.-pss
4164            pva=0.
4165            psvv=0.
4166            if(idt(it).ne.0.and.idm2pr(n,k).ne.2)psvv=wgtqqq(icltar)
4167            paas=0.
4168          elseif(ivt0.eq.0)then
4169            pva=0.
4170            if(ivt(it).ne.0.and.idpr(n,k).ne.3)pva=1.-pss
4171            pvs=0.
4172            psvv=0.
4173            paas=0.
4174            if(idt(it).ne.0.and.idm1pr(n,k).ne.2)paas=wgtqqq(icltar)
4175          else                   !for meson, no soft string with valence quark (we do not know whether the quark or the antiquark will be used by hard string)
4176            pvs=0.
4177            pva=0.
4178 c diquark or antidiquark can be created once in meson remnant
4179            psvv=0.
4180            paas=0.
4181            if(1+idt(it).ne.0)then
4182              if(idm2pr(n,k).ne.2)psvv=wgtqqq(icltar)
4183              if(idm1pr(n,k).ne.2)paas=wgtqqq(icltar)
4184            endif
4185          endif
4186          pdd=wgtdiq/(1.+float(abs(idt(it))))
4187 c         if(idpr(n,k).eq.3)then
4188 c           pdd=0.
4189 c           psvv=0.
4190 c           paas=0.
4191 c         endif
4192        elseif(iremn.ne.0)then
4193          pvs=0.
4194          pva=0.
4195          psvv=0.
4196          paas=0.
4197          if(idm2pr(n,k).ne.2)psvv=wgtqqq(icltar)
4198          if(idm1pr(n,k).ne.2)paas=wgtqqq(icltar)
4199          pdd=wgtdiq/(1.+float(abs(idt(it))))
4200        else
4201          pvs=0.
4202          pva=0.
4203          psvv=0.
4204          paas=0.
4205          pdd=wgtdiq/(1.+float(abs(idt(it))))
4206        endif
4207        if(idm1pr(n,k).eq.2)then  !with valence quark only 1 SE available
4208          psd=pdd
4209          pds=0.
4210          pdd=0.
4211        elseif(idm2pr(n,k).eq.2)then  !with valence antiquark only 1 SE available
4212          pds=pdd
4213          psd=0.
4214          pdd=0.
4215        else
4216          psd=pdd
4217          pds=pdd
4218          pdd=pdd**2
4219        endif
4220        su=1.-min(1.,pdd+pds+psd)            !diquark probability
4221        pss=(1.-min(1.,pvs+pva))*su        !no more valence quark: take from sea
4222        pvs=pvs*su
4223        pva=pva*su
4224        su=1.-min(1.,psvv+paas)      !stopping probability
4225        pss=pss*su
4226        pvs=pvs*su
4227        pva=pva*su
4228        pds=pds*su
4229        psd=psd*su
4230        pdd=pdd*su
4231        su=pss+pvs+pva+pdd+psd+pds+psvv+paas
4232        psst = pss /su
4233        pvst = pvs /su
4234        pvat = pva /su
4235        psdt = psd /su
4236        pdst = pds /su
4237        pddt = pdd /su
4238        psvvt= psvv/su
4239        paast= paas/su
4240        r=rangen()
4241        if(r.gt.(psst+pvst+pvat+psdt+pdst+psvvt+paast)
4242      &                               .and.pddt.gt.eps)then
4243         if(idm1pr(n,k).ne.2)idm1pr(n,k)=4
4244         if(idm2pr(n,k).ne.2)idm2pr(n,k)=4
4245         idstpr(n,k)=idstpr(n,k)+4
4246         if(iremn.ge.2)idt(it)=idt(it)+2
4247         if(iremn.eq.3)then   !add diquark flavor to jctref for ProSeF later (sea quark)
4248           idum=idrafl(icltar,jct,1,'s',3,iret)
4249           idum=idrafl(icltar,jct,1,'d',3,iret)
4250           idum=idrafl(icltar,jct,1,'s',3,iret)
4251           idum=idrafl(icltar,jct,1,'d',3,iret)
4252         endif
4253       elseif(r.gt.(psst+pvst+pvat+psdt+psvvt+paast).and.pdst.gt.eps)then
4254         if(idm1pr(n,k).ne.2)idm1pr(n,k)=4
4255         if(idm2pr(n,k).ne.2)idm2pr(n,k)=1
4256         idstpr(n,k)=idstpr(n,k)+4
4257         if(iremn.ge.2)idt(it)=idt(it)+1
4258         if(iremn.eq.3)then   !add diquark flavor to jctref for ProSeF later (sea quark)
4259           idum=idrafl(icltar,jct,1,'s',3,iret)
4260           idum=idrafl(icltar,jct,1,'d',3,iret)
4261         endif
4262        elseif(r.gt.(psst+pvst+pvat+psvvt+paast).and.psdt.gt.eps)then
4263         if(idm1pr(n,k).ne.2)idm1pr(n,k)=1
4264         if(idm2pr(n,k).ne.2)idm2pr(n,k)=4
4265         idstpr(n,k)=idstpr(n,k)+4
4266         if(iremn.ge.2)idt(it)=idt(it)+1
4267         if(iremn.eq.3)then   !add diquark flavor to jctref for ProSeF later (sea quark)
4268           idum=idrafl(icltar,jct,1,'s',3,iret)
4269           idum=idrafl(icltar,jct,1,'d',3,iret)
4270         endif
4271        elseif(r.gt.(psst+pvst+pvat+psvvt).and.paast.gt.eps)then
4272         if(idm1pr(n,k).ne.2)idm1pr(n,k)=5
4273         if(idm2pr(n,k).ne.2)idm2pr(n,k)=1
4274         idstpr(n,k)=idstpr(n,k)+5
4275         if(iremn.ge.2)idt(it)=idt(it)-1
4276         if(iremn.eq.3)idum=idrafl(icltar,jct,1,'s',3,iret) !add flavor to jcpref for ProSeF later (sea quark) (only a q-aq pair because we replace diquark by q-aq (baryon "decay" or "stopping")
4277        elseif(r.gt.(psst+pvst+pvat+pddt).and.psvvt.gt.eps)then
4278         if(idm1pr(n,k).ne.2)idm1pr(n,k)=1
4279         if(idm2pr(n,k).ne.2)idm2pr(n,k)=5
4280         idstpr(n,k)=idstpr(n,k)+5
4281         if(iremn.ge.2)idt(it)=idt(it)-1
4282         if(iremn.eq.3)idum=idrafl(icltar,jct,1,'s',3,iret) !add flavor to jcpref for ProSeF later (sea quark) (only a q-aq pair because we replace diquark by q-aq (baryon "decay" or "stopping")
4283        elseif(r.gt.(psst+pvst).and.pvat.gt.eps)then
4284         if(idm1pr(n,k).ne.2)idm1pr(n,k)=1
4285         if(idm2pr(n,k).ne.2)idm2pr(n,k)=2
4286         idstpr(n,k)=idstpr(n,k)+2
4287         if(iremn.ge.2)ivt(it)=ivt(it)-1
4288         if(iremn.eq.3)idum=idrafl(icltar,jct,1,'s',3,iret) !add flavor to jctref for ProSeF later (sea quark)
4289        elseif(r.gt.psst.and.pvst.gt.eps)then
4290         if(idm1pr(n,k).ne.2)idm1pr(n,k)=2
4291         if(idm2pr(n,k).ne.2)idm2pr(n,k)=1
4292         idstpr(n,k)=idstpr(n,k)+2
4293         if(iremn.ge.2)ivt(it)=ivt(it)-1
4294         if(iremn.eq.3)idum=idrafl(icltar,jct,2,'s',3,iret) !add flavor to jctref for ProSeF later (sea quark)
4295        elseif(psst.gt.eps)then
4296         if(idm1pr(n,k).ne.2)idm1pr(n,k)=1
4297         if(idm2pr(n,k).ne.2)idm2pr(n,k)=1
4298         idstpr(n,k)=idstpr(n,k)+1
4299         if(iremn.eq.3)idum=idrafl(icltar,jct,1,'s',3,iret) !add flavor to jctref for ProSeF later (sea quark)
4300        else
4301         goto 2
4302        endif
4303
4304        else
4305         idm1pr(n,k)=1
4306         idm2pr(n,k)=1
4307         idstpr(n,k)=0
4308        endif
4309
4310       else
4311
4312         idp1pr(n,k)=0
4313         idm2pr(n,k)=0
4314         idp2pr(n,k)=0
4315         idm1pr(n,k)=0
4316
4317       endif
4318
4319       else       !iLHC
4320
4321       if(idpr(n,k).eq.3)then
4322        pssp=0.
4323        pvsp=0.
4324        pvap=0.
4325        pddp=0.
4326        psvvp=0.
4327        paasp=0.
4328        psst=0.
4329        pvst=0.
4330        pvat=0.
4331        pddt=0.
4332        psvvt=0.
4333        paast=0.
4334        if(idhpr(n,k).eq.3)then  !so01
4335         idp1pr(n,k)=2
4336         idp2pr(n,k)=8
4337         idm1pr(n,k)=2
4338         idm2pr(n,k)=8
4339        elseif(idhpr(n,k).eq.2)then
4340         idp1pr(n,k)=1
4341         idp2pr(n,k)=1
4342         idm1pr(n,k)=2
4343         idm2pr(n,k)=8
4344        elseif(idhpr(n,k).eq.1)then
4345         idp1pr(n,k)=2
4346         idp2pr(n,k)=8
4347         idm1pr(n,k)=1
4348         idm2pr(n,k)=1
4349        elseif(idhpr(n,k).eq.0)then
4350         idp1pr(n,k)=1
4351         idp2pr(n,k)=1
4352         idm1pr(n,k)=1
4353         idm2pr(n,k)=1
4354        else
4355         call utstop('ProSeTy-idhpr????&')
4356        endif
4357        if(iremn.eq.3)then       !add flavor to jcpref and jctref for psahot and ProSeF later (sea quark)
4358          idum=idrafl(iclpro,jcp,1,'s',3,iret)
4359          idum=idrafl(icltar,jct,1,'s',3,iret)
4360        endif
4361
4362
4363       elseif(idpr(n,k).eq.1)then
4364
4365 c    projectile
4366
4367        if(idfpr(n,k).eq.1.or.idfpr(n,k).eq.2)then
4368
4369        ntry=0
4370        ivpi=ivp(ip)
4371        idpi=idp(ip)
4372        if(iremn.eq.3)then
4373          do j=1,2
4374            do i=1,nrflav
4375              jcpi(i,j)=jcp(i,j)
4376            enddo
4377          enddo
4378        endif
4379  3     ntry=ntry+1
4380        if(ntry.gt.10)call utstop('something goes wrong in sr ProSeTy&')
4381        ivp(ip)=ivpi
4382        idp(ip)=idpi
4383        if(iremn.eq.3)then
4384          do j=1,2
4385            do i=1,nrflav
4386              jcp(i,j)=jcpi(i,j)
4387            enddo
4388          enddo
4389        endif
4390        pss=wgtval+wgtsea
4391        if(pss.gt.0.)then
4392          pss=wgtsea/pss
4393        else
4394          pss=0.
4395        endif
4396        if(iremn.ge.2)then
4397          if(iap0.eq.0)then
4398            pvs=0.
4399            if(ivp(ip).ne.0)pvs=1.-pss
4400            pva=0.
4401            psvv=0.
4402            if(idp(ip).ne.0)psvv=wgtqqq(iclpro)
4403            paas=0.
4404          elseif(ivp0.eq.0)then
4405            pva=0.
4406            if(ivp(ip).ne.0)pva=1.-pss
4407            pvs=0.
4408            psvv=0.
4409            paas=0.
4410            if(idp(ip).ne.0)paas=wgtqqq(iclpro)
4411          else                   !for meson, no soft string with valence quark (we do not know whether the quark or the antiquark will be used by hard string)
4412            pvs=0.
4413            pva=0.
4414 c diquark or antidiquark can be created once in meson remnant
4415            psvv=0.
4416            paas=0.
4417            if(1+idp(ip).ne.0)then
4418              psvv=wgtqqq(iclpro)
4419              paas=wgtqqq(iclpro)
4420            endif
4421          endif
4422          pdd=wgtdiq
4423        elseif(iremn.ne.0)then
4424          pvs=0.
4425          pva=0.
4426          psvv=wgtqqq(iclpro)
4427          paas=wgtqqq(iclpro)
4428          pdd=wgtdiq
4429        else
4430          pvs=0.
4431          pva=0.
4432          psvv=0.
4433          paas=0.
4434          pdd=wgtdiq
4435        endif
4436        su=1.-min(1.,pdd)            !diquark probability
4437        pss=(1.-min(1.,pvs+pva))*su        !no more valence quark: take from sea
4438        pvs=pvs*su
4439        pva=pva*su
4440        su=1.-min(1.,psvv+paas)      !stopping probability
4441        pdd=pdd*su
4442        pss=pss*su
4443        pvs=pvs*su
4444        pva=pva*su
4445        su=pss+pvs+pva+pdd+psvv+paas
4446        pssp = pss /su
4447        pvsp = pvs /su
4448        pvap = pva /su
4449        pddp = pdd /su
4450        psvvp= psvv/su
4451        paasp= paas/su
4452        r=rangen()
4453        if(r.gt.(pssp+pvsp+pvap+pddp+psvvp).and.paasp.gt.eps)then
4454         idp1pr(n,k)=5
4455         idp2pr(n,k)=1
4456         idsppr(n,k)=6
4457         if(iremn.ge.2)idp(ip)=idp(ip)-1
4458         if(iremn.eq.3)idum=idrafl(iclpro,jcp,1,'s',3,iret) !add flavor to jcpref for ProSeF later (sea quark) (only a q-aq pair because we replace diquark by q-aq (baryon "decay" or "stopping")
4459        elseif(r.gt.(pssp+pvsp+pvap+pddp).and.psvvp.gt.eps)then
4460         idp1pr(n,k)=1
4461         idp2pr(n,k)=5
4462         idsppr(n,k)=5
4463         if(iremn.ge.2)idp(ip)=idp(ip)-1
4464         if(iremn.eq.3)idum=idrafl(iclpro,jcp,1,'s',3,iret) !add flavor to jcpref for ProSeF later (sea quark) (only a q-aq pair because we replace diquark by q-aq (baryon "decay" or "stopping")
4465        elseif(r.gt.(pssp+pvsp+pvap).and.pddp.gt.eps)then
4466         idp1pr(n,k)=4
4467         idp2pr(n,k)=4
4468         idsppr(n,k)=4
4469         if(iremn.eq.3)then   !add diquark flavor to jcpref for ProSeF later (sea quark)
4470           idum=idrafl(iclpro,jcp,1,'s',3,iret)
4471           idum=idrafl(iclpro,jcp,1,'d',3,iret)
4472         endif
4473        elseif(r.gt.(pssp+pvsp).and.pvap.gt.eps)then
4474         idp1pr(n,k)=1
4475         idp2pr(n,k)=2
4476         idsppr(n,k)=3
4477         if(iremn.ge.2)ivp(ip)=ivp(ip)-1
4478         if(iremn.eq.3)idum=idrafl(iclpro,jcp,1,'s',3,iret) !add flavor to jcpref for ProSeF later (sea quark)
4479        elseif(r.gt.pssp.and.pvsp.gt.eps)then
4480         idp1pr(n,k)=2
4481         idp2pr(n,k)=1
4482         idsppr(n,k)=2
4483         if(iremn.ge.2)ivp(ip)=ivp(ip)-1
4484         if(iremn.eq.3)idum=idrafl(iclpro,jcp,2,'s',3,iret) !add flavor to jcpref for ProSeF later (sea quark)
4485        elseif(pssp.gt.eps)then
4486         idp1pr(n,k)=1
4487         idp2pr(n,k)=1
4488         idsppr(n,k)=1
4489         if(iremn.eq.3)idum=idrafl(iclpro,jcp,1,'s',3,iret) !add flavor to jcpref for ProSeF later (sea quark)
4490        else
4491         goto 3
4492        endif
4493
4494        else
4495         idp1pr(n,k)=1
4496         idp2pr(n,k)=1
4497         idsppr(n,k)=0
4498        endif
4499
4500
4501 c    target
4502
4503        if(idfpr(n,k).eq.1.or.idfpr(n,k).eq.3)then
4504
4505
4506        ntry=0
4507        ivti=ivt(it)
4508        idti=idt(it)
4509        if(iremn.eq.3)then
4510          do j=1,2
4511            do i=1,nrflav
4512              jcti(i,j)=jct(i,j)
4513            enddo
4514          enddo
4515        endif
4516  4     ntry=ntry+1
4517        if(ntry.gt.10)call utstop('something goes wrong in sr ProSeTy&')
4518        ivt(it)=ivti
4519        idt(it)=idti
4520        if(iremn.eq.3)then
4521          do j=1,2
4522            do i=1,nrflav
4523              jct(i,j)=jcti(i,j)
4524            enddo
4525          enddo
4526        endif
4527        pss=wgtval+wgtsea
4528        if(pss.gt.0.)then
4529          pss=wgtsea/pss
4530        else
4531          pss=0.
4532        endif
4533        if(iremn.ge.2)then
4534          if(iat0.eq.0)then
4535            pvs=0.
4536            if(ivt(it).ne.0)pvs=1.-pss
4537            pva=0.
4538            psvv=0.
4539            if(idt(it).ne.0)psvv=wgtqqq(icltar)
4540            paas=0.
4541          elseif(ivt0.eq.0)then
4542            pva=0.
4543            if(ivt(it).ne.0)pva=1.-pss
4544            pvs=0.
4545            psvv=0.
4546            paas=0.
4547            if(idt(it).ne.0)paas=wgtqqq(icltar)
4548          else                   !for meson, no soft string with valence quark (we do not know whether the quark or the antiquark will be used by hard string)
4549            pvs=0.
4550            pva=0.
4551            psvv=0.
4552            paas=0.
4553 c diquark or antidiquark can be created once in meson remnant
4554            if(1+idt(it).ne.0)then
4555              psvv=wgtqqq(icltar)
4556              paas=wgtqqq(icltar)
4557            endif
4558          endif
4559          pdd=wgtdiq
4560        elseif(iremn.ne.0)then
4561          pvs=0.
4562          pva=0.
4563          psvv=wgtqqq(icltar)
4564          paas=wgtqqq(icltar)
4565          pdd=wgtdiq
4566        else
4567          pvs=0.
4568          pva=0.
4569          psvv=0.
4570          paas=0.
4571          pdd=wgtdiq
4572        endif
4573 c no more valence quark: take from sea
4574        su=1.-min(1.,pdd)            !diquark probability
4575        pss=(1.-min(1.,pvs+pva))*su        !no more valence quark: take from sea
4576        pvs=pvs*su
4577        pva=pva*su
4578        su=1.-min(1.,psvv+paas)      !stopping probability
4579        pdd=pdd*su
4580        pss=pss*su
4581        pvs=pvs*su
4582        pva=pva*su
4583        su=pss+pvs+pva+pdd+psvv+paas
4584        psst = pss /su
4585        pvst = pvs /su
4586        pvat = pva /su
4587        pddt = pdd /su
4588        psvvt= psvv/su
4589        paast= paas/su
4590        r=rangen()
4591        if(r.gt.(psst+pvst+pvat+pddt+psvvt).and.paast.gt.eps)then
4592         idm1pr(n,k)=5
4593         idm2pr(n,k)=1
4594         idstpr(n,k)=6
4595         if(iremn.ge.2)idt(it)=idt(it)-1
4596         if(iremn.eq.3)idum=idrafl(icltar,jct,1,'s',3,iret) !add flavor to jcpref for ProSeF later (sea quark) (only a q-aq pair because we replace diquark by q-aq (baryon "decay" or "stopping")
4597        elseif(r.gt.(psst+pvst+pvat+pddt).and.psvvt.gt.eps)then
4598         idm1pr(n,k)=1
4599         idm2pr(n,k)=5
4600         idstpr(n,k)=5
4601         if(iremn.ge.2)idt(it)=idt(it)-1
4602         if(iremn.eq.3)idum=idrafl(icltar,jct,1,'s',3,iret) !add flavor to jcpref for ProSeF later (sea quark) (only a q-aq pair because we replace diquark by q-aq (baryon "decay" or "stopping")
4603        elseif(r.gt.(psst+pvst+pvat).and.pddt.gt.eps)then
4604         idm1pr(n,k)=4
4605         idm2pr(n,k)=4
4606         idstpr(n,k)=4
4607         if(iremn.eq.3)then   !add diquark flavor to jctref for ProSeF later (sea quark)
4608           idum=idrafl(icltar,jct,1,'s',3,iret)
4609           idum=idrafl(icltar,jct,1,'d',3,iret)
4610         endif
4611        elseif(r.gt.(psst+pvst).and.pvat.gt.eps)then
4612         idm1pr(n,k)=1
4613         idm2pr(n,k)=2
4614         idstpr(n,k)=3
4615         if(iremn.ge.2)ivt(it)=ivt(it)-1
4616         if(iremn.eq.3)idum=idrafl(icltar,jct,1,'s',3,iret) !add flavor to jctref for ProSeF later (sea quark)
4617        elseif(r.gt.psst.and.pvst.gt.eps)then
4618         idm1pr(n,k)=2
4619         idm2pr(n,k)=1
4620         idstpr(n,k)=2
4621         if(iremn.ge.2)ivt(it)=ivt(it)-1
4622         if(iremn.eq.3)idum=idrafl(icltar,jct,2,'s',3,iret) !add flavor to jctref for ProSeF later (sea quark)
4623        elseif(psst.gt.eps)then
4624         idm1pr(n,k)=1
4625         idm2pr(n,k)=1
4626         idstpr(n,k)=1
4627         if(iremn.eq.3)idum=idrafl(icltar,jct,1,'s',3,iret) !add flavor to jctref for ProSeF later (sea quark)
4628        else
4629         goto 4
4630        endif
4631
4632        else
4633         idm1pr(n,k)=1
4634         idm2pr(n,k)=1
4635         idstpr(n,k)=0
4636        endif
4637
4638       elseif(idpr(n,k).eq.0)then
4639
4640         idp1pr(n,k)=0
4641         idm2pr(n,k)=0
4642         idp2pr(n,k)=0
4643         idm1pr(n,k)=0
4644
4645       endif
4646
4647       endif
4648
4649         if(ish.ge.6)then
4650       write(ifch,'(a,2(6(f4.2,1x),2x),$)')'ProSeTy ',
4651      * pssp,pvsp,pvap,pddp,psvvp,paasp, psst,pvst,pvat,pddt,psvvt,paast
4652       write(ifch,'(2x,3i3,2x,2(i2,1x,2i2,1x,i2,i3,2x))')idpr(n,k),n,k
4653      * ,idsppr(n,k),idp1pr(n,k),idp2pr(n,k),ivp(ip),idp(ip)
4654      * ,idstpr(n,k),idm1pr(n,k),idm2pr(n,k),ivt(it),idt(it)
4655         endif
4656
4657       if(iremn.eq.3)then
4658         do j=1,2
4659           do i=1,nrflav
4660             jcpref(i,j,ip)=jcp(i,j)
4661             jctref(i,j,it)=jct(i,j)
4662           enddo
4663         enddo
4664         if(ish.ge.6)then
4665           write(ifch,'(a,i3,a,1x,4i3,3x,4i3)')'jcpref(',ip,'):',jcp
4666           write(ifch,'(a,i3,a,1x,4i3,3x,4i3)')'jctref(',it,'):',jct
4667         endif
4668       endif
4669
4670       return
4671       end
4672
4673 c-----------------------------------------------------------------------
4674       subroutine ProSeF(k,n,iret)
4675 c-----------------------------------------------------------------------
4676 c starting from string properties as already determined in EMS,
4677 c one determines string end flavors
4678 c by checking compatibility with remnant masses.
4679 c strings are written to /cems/ and then to /cptl/
4680 c remnant ic is updated (icproj,ictarg)
4681 c------------------------------------------------------------------------
4682
4683       include 'epos.inc'
4684       include 'epos.incems'
4685       include 'epos.incsem'
4686
4687       double precision plc,s,pstg,pend
4688       common/cems5/plc,s
4689       common/cems/pstg(5,2),pend(4,4),idend(4)
4690       common/emsptl/nppr(npommx,kollmx),npproj(mamx),nptarg(mamx)
4691       integer icp(2),ict(2),ic(2),icp1(2),icp2(2),icm1(2),icm2(2)
4692       integer jcp(nflav,2),jct(nflav,2),jcpv(nflav,2),jctv(nflav,2)
4693       integer jcp1(nflav,2),jcp2(nflav,2),jcm1(nflav,2),jcm2(nflav,2)
4694       common/col3/ncol,kolpt /cfacmss/facmss /cts/its
4695
4696
4697 c     entry
4698 c     -----
4699
4700       iret=0
4701
4702       if(ncol.eq.0)return
4703       if(abs(itpr(k)).ne.1)return
4704
4705       ip=iproj(k)
4706       it=itarg(k)
4707
4708       if(idpr(n,k).eq.0.or.ivpr(n,k).eq.0)return
4709       if(idpr(n,k).eq.2)stop'Reggeon'
4710       if(idpr(n,k).eq.3)return
4711       call utpri('ProSeF',ish,ishini,5)
4712       if(ish.ge.5)then
4713           write(ifch,*)'soft Pomeron'
4714           write(ifch,*)'k:',k,'  n:',n,'  ip:',ip,'  it:',it
4715       endif
4716       np=nppr(n,k)
4717
4718 c         string ends
4719
4720           pend(1,1)=xxp1pr(n,k)
4721           pend(2,1)=xyp1pr(n,k)
4722           pend(3,1)=xp1pr(n,k)*plc/2d0
4723           pend(4,1)=dsqrt(pend(1,1)**2+pend(2,1)**2+pend(3,1)**2)
4724           pend(1,2)=xxp2pr(n,k)
4725           pend(2,2)=xyp2pr(n,k)
4726           pend(3,2)=xp2pr(n,k)*plc/2d0
4727           pend(4,2)=dsqrt(pend(1,2)**2+pend(2,2)**2+pend(3,2)**2)
4728           pend(1,4)=xxm1pr(n,k)
4729           pend(2,4)=xym1pr(n,k)
4730           pend(3,4)=-xm1pr(n,k)*plc/2d0
4731           pend(4,4)=dsqrt(pend(1,4)**2+pend(2,4)**2+pend(3,4)**2)
4732           pend(1,3)=xxm2pr(n,k)
4733           pend(2,3)=xym2pr(n,k)
4734           pend(3,3)=-xm2pr(n,k)*plc/2d0
4735           pend(4,3)=dsqrt(pend(1,3)**2+pend(2,3)**2+pend(3,3)**2)
4736
4737 c         strings
4738
4739           pstg(1,1)=xxp1pr(n,k)+xxm2pr(n,k)
4740           pstg(2,1)=xyp1pr(n,k)+xym2pr(n,k)
4741           pstg(3,1)=(xp1pr(n,k)-xm2pr(n,k))*plc/2d0
4742           pstg(4,1)=(xp1pr(n,k)+xm2pr(n,k))*plc/2d0
4743           pstg(5,1)=dsqrt((pstg(4,1)-pstg(3,1))*(pstg(4,1)+pstg(3,1))
4744      &                   -pstg(1,1)**2-pstg(2,1)**2)
4745           pstg(1,2)=xxp2pr(n,k)+xxm1pr(n,k)
4746           pstg(2,2)=xyp2pr(n,k)+xym1pr(n,k)
4747           pstg(3,2)=(xp2pr(n,k)-xm1pr(n,k))*plc/2d0
4748           pstg(4,2)=(xp2pr(n,k)+xm1pr(n,k))*plc/2d0
4749           pstg(5,2)=dsqrt((pstg(4,2)-pstg(3,2))*(pstg(4,2)+pstg(3,2))
4750      &                   -pstg(2,2)**2-pstg(1,2)**2)
4751
4752 c         initialize
4753
4754           ntry=0
4755   777     ntry=ntry+1
4756           if(ntry.gt.100)goto1001
4757
4758           if(iremn.ge.2)then    !uses precalculated flavors
4759             do i=1,2
4760               icp(i)=icproj(i,ip)
4761               ict(i)=ictarg(i,it)
4762             enddo
4763             if(iLHC.eq.1)then
4764               call iddeco(icp,jcpv)
4765               call iddeco(ict,jctv)
4766             endif
4767             do j=1,2
4768               do i=1,nrflav
4769                 jcp(i,j)=jcpref(i,j,ip)
4770                 jct(i,j)=jctref(i,j,it)
4771                 if(iLHC.eq.0)then
4772                 jcpv(i,j)=jcpval(i,j,ip)
4773                 jctv(i,j)=jctval(i,j,it)
4774                 endif
4775               enddo
4776               do i=nrflav+1,nflav
4777                 jcp(i,j)=0
4778                 jct(i,j)=0
4779                 jcpv(i,j)=0
4780                 jctv(i,j)=0
4781                enddo
4782             enddo
4783           else
4784             do i=1,2
4785               icp(i)=icproj(i,ip)
4786               ict(i)=ictarg(i,it)
4787             enddo
4788             call iddeco(icp,jcp)
4789             call iddeco(ict,jct)
4790             do j=1,2
4791               do i=1,nflav
4792                 jcpv(i,j)=0
4793                 jctv(i,j)=0
4794               enddo
4795             enddo
4796           endif
4797           do i=1,2
4798            icp1(i)=0
4799            icp2(i)=0
4800            icm1(i)=0
4801            icm2(i)=0
4802            do j=1,nflav
4803             jcp1(j,i)=0
4804             jcp2(j,i)=0
4805             jcm1(j,i)=0
4806             jcm2(j,i)=0
4807            enddo
4808           enddo
4809           idpj0=idtr2(icp)
4810           idtg0=idtr2(ict)
4811           do j=1,4
4812            idend(j)=0
4813           enddo
4814
4815           if(ish.ge.7)then
4816             write(ifch,'(a,3x,6i3,3x,6i3,i9)')' proj: '
4817      *     ,jcp,idpj0
4818             write(ifch,'(a,6i3,3x,6i3)')' proj val:  ',jcpv
4819           endif
4820           if(ish.ge.7)then
4821             write(ifch,'(a,3x,6i3,3x,6i3,i9)')' targ: '
4822      *    ,jct,idtg0
4823             write(ifch,'(a,6i3,3x,6i3)')' targ val:  ',jctv
4824           endif
4825
4826 c         determine string flavors
4827
4828           call fstrfl(jcp,jct,jcpv,jctv,icp1,icp2,icm1,icm2
4829      *                ,idp1pr(n,k),idp2pr(n,k),idm1pr(n,k),idm2pr(n,k)
4830      *                                   ,idsppr(n,k),idstpr(n,k),iret)
4831           if(iret.ne.0)goto 1002
4832
4833 c         check mass string 1
4834
4835           ic(1)=icp1(1)+icm2(1)
4836           ic(2)=icp1(2)+icm2(2)
4837           if(ic(1).gt.0.or.ic(2).gt.0)then
4838            am=sngl(pstg(5,1))
4839            call iddeco(icp1,jcp1)
4840            call iddeco(icm2,jcm2)
4841            ammns=utamnx(jcp1,jcm2)
4842            if(ish.ge.7)write(ifch,'(a,2i7,2e12.3)')
4843      *           ' string 1 - ic,mass,min.mass:',ic,am,ammns
4844            if(am.lt.ammns*facmss)then
4845              goto 777   !avoid virpom
4846            endif
4847            if(iLHC.eq.1)then
4848            idend(1)=idtra(icp1,0,0,0)
4849            idend(3)=idtra(icm2,0,0,0)
4850            else
4851            idend(1)=idtra(icp1,0,0,3)
4852            idend(3)=idtra(icm2,0,0,3)
4853            endif
4854            if(ish.ge.7)write(ifch,'(a,2i6)') ' string 1 - SE-ids:'
4855      *      ,idend(1),idend(3)
4856           endif
4857
4858 c         check mass string 2
4859
4860           ic(1)=icp2(1)+icm1(1)
4861           ic(2)=icp2(2)+icm1(2)
4862           if(ic(1).gt.0.or.ic(2).gt.0)then
4863            am=sngl(pstg(5,2))
4864            call iddeco(icp2,jcp2)
4865            call iddeco(icm1,jcm1)
4866            ammns=utamnx(jcp2,jcm1)
4867            if(ish.ge.7)write(ifch,'(a,2i7,2e12.3)')
4868      *           ' string 2 - ic,mass,min.mass:',ic,am,ammns
4869            if(am.lt.ammns*facmss)then
4870              goto 777  !avoid virpom
4871            endif
4872            if(iLHC.eq.1)then
4873            idend(2)=idtra(icp2,0,0,0)
4874            idend(4)=idtra(icm1,0,0,0)
4875            else
4876            idend(2)=idtra(icp2,0,0,3)
4877            idend(4)=idtra(icm1,0,0,3)
4878            endif
4879            if(ish.ge.7)write(ifch,'(a,2i6)') ' string 2 - SE-ids:'
4880      *      ,idend(2),idend(4)
4881           endif
4882
4883           if(ish.ge.5)then
4884           write(ifch,'(a,i10)')' pom:   '
4885      *    ,idptl(np)
4886           write(ifch,'(a,2i5)')' str 1: '
4887      *    ,idend(1),idend(3)
4888           write(ifch,'(a,2i5)')' str 2: '
4889      *    ,idend(2),idend(4)
4890           endif
4891
4892 c         update remnant ic
4893
4894 c determine icp,ict
4895 c Similar process for hard pomeron in epos-rsh !!!!
4896
4897           if(iremn.ge.2)then    !uses precalculated flavors
4898
4899             do j=1,2
4900               do i=1,nrflav
4901                 jcpref(i,j,ip)=jcp(i,j)
4902                 jctref(i,j,it)=jct(i,j)
4903                 if(iLHC.eq.0)then
4904                 jcpval(i,j,ip)=jcpv(i,j)
4905                 jctval(i,j,it)=jctv(i,j)
4906                 endif
4907               enddo
4908             enddo
4909             if(iLHC.eq.1)then
4910             call idenco(jcpv,icp,iret)
4911             if(iret.ne.0)goto 1002
4912             call idenco(jctv,ict,iret)
4913             if(iret.ne.0)goto 1002
4914             do i=1,2
4915               icproj(i,ip)=icp(i)
4916               ictarg(i,it)=ict(i)
4917             enddo
4918             endif
4919             if(ish.ge.5)then
4920               write(ifch,'(a,6i3,3x,6i3)')' proj:  ',jcp
4921               write(ifch,'(a,6i3,3x,6i3)')' proj val:  ',jcpv
4922               write(ifch,'(a,6i3,3x,6i3)')' targ:  ',jct
4923               write(ifch,'(a,6i3,3x,6i3)')' targ val:  ',jctv
4924             endif
4925
4926           else
4927
4928             call idenco(jcp,icp,iret)
4929             if(iret.ne.0)goto 1002
4930             call idenco(jct,ict,iret)
4931             if(iret.ne.0)goto 1002
4932             do i=1,2
4933               icproj(i,ip)=icp(i)
4934               ictarg(i,it)=ict(i)
4935             enddo
4936             if(ish.ge.5)then
4937               write(ifch,'(a,2i7,1x,a)')' proj:  '
4938      *             ,(icp(l),l=1,2)
4939               write(ifch,'(a,2i7,1x,a)')' targ:  '
4940      *             ,(ict(l),l=1,2)
4941             endif
4942
4943           endif
4944
4945 c         write strings to /cptl/
4946
4947           its=idp1pr(n,k)+idm2pr(n,k)
4948           call fstrwr(1,1,3,k,n)
4949           its=idp2pr(n,k)+idm1pr(n,k)
4950           call fstrwr(2,2,4,k,n)
4951
4952 c     exit
4953 c     ----
4954
4955 1000  continue
4956       call utprix('ProSeF',ish,ishini,5)
4957       return
4958
4959  1002 jerr(1)=jerr(1)+1         ! > 9 quarks per flavor attempted.
4960  1001 iret=1
4961       if(ish.ge.5)write(ifch,'(a)')'Problem in ProSeF ... '
4962       goto 1000
4963
4964       end
4965
4966 c-----------------------------------------------------------------------
4967       subroutine fstrfl(jcp,jct,jcpv,jctv,icp1,icp2,icm1,icm2
4968      *                         ,idp1,idp2,idm1,idm2,idsp,idst,iret)
4969 c-----------------------------------------------------------------------
4970 c knowing the string end types (idp1,idp2,idm1,idm2)
4971 c               and remnant flavors (icp,ict)
4972 c               and remnant link of the string (idsp and idst)
4973 c   for LHC     (idsp/t=100 with one idp/idm=2 means that the valence quark
4974 c                to use is define in the corresponding icp/icm
4975 c                (using just 1 to 6 for flavor identification (no diquark)))
4976 c one determines quark flavors of string ends (icp1,icp2,icm1,icm2)
4977 c               and updates remnant flavors (icp,ict)
4978 c iret=0   ok
4979 c iret=1   problem, more than 9 quarks per flavor attempted
4980 c-----------------------------------------------------------------------
4981       include 'epos.inc'
4982       include 'epos.incems'
4983       include 'epos.incsem'
4984       integer icp1(2),icp2(2),icm1(2),icm2(2)
4985       integer jcp(nflav,2),jct(nflav,2)
4986      &       ,jcpi(nflavems,2),jcti(nflavems,2)
4987       integer iq(2,4),jcpv(nflav,2),jctv(nflav,2)
4988       character m
4989 c      data neuz/0/proz/0/dtaz/0/
4990 c      save neuz,proz,dtaz
4991
4992       call utpri('fstrfl',ish,ishini,7)
4993
4994 c     entry
4995 c     -----
4996
4997       idum=0
4998       iret=0
4999       iret1=0
5000       iret2=0
5001       iret3=0
5002       iret4=0
5003
5004       if(idp1.eq.8)stop'fstrfl: fragm quarks not used any more'
5005       if(idp2.eq.8)stop'fstrfl: fragm quarks not used any more'
5006       if(idm1.eq.8)stop'fstrfl: fragm quarks not used any more'
5007       if(idm2.eq.8)stop'fstrfl: fragm quarks not used any more'
5008
5009 c determine flavors of string ends (u,d,s)
5010
5011       if(ish.ge.7)then
5012        write(ifch,'(a,3x,2i3)')' string 1, SE types:',idp1,idm2
5013        write(ifch,'(a,3x,2i3)')' string 2, SE types:',idp2,idm1
5014       endif
5015
5016 c empty
5017
5018       if(idp1.eq.0)then
5019        iq(1,1)=0
5020        iq(2,1)=0
5021       endif
5022       if(idp2.eq.0)then
5023        iq(1,2)=0
5024        iq(2,2)=0
5025       endif
5026       if(idm1.eq.0)then
5027        iq(1,4)=0
5028        iq(2,4)=0
5029       endif
5030       if(idm2.eq.0)then
5031        iq(1,3)=0
5032        iq(2,3)=0
5033       endif
5034       do j=1,2
5035         do n=1,nrflav
5036           jcpi(n,j)=jcp(n,j)
5037           jcti(n,j)=jct(n,j)
5038         enddo
5039       enddo
5040
5041 c Projectile
5042
5043       if(idsp.eq.0.or.iremn.eq.0)then
5044 c give the same flavor to quark and antiquark not to change remnant flavor
5045
5046         if(idp1.eq.4)then
5047 c diquarks, code 4
5048           iq(1,1)=idrafl(iclpro,jcp,1,'d',0,iret)
5049           iq(2,1)=idrafl(iclpro,jcp,1,'d',0,iret)
5050           iq(1,2)=iq(1,1)
5051           iq(2,2)=iq(2,1)
5052         else
5053 c sea quarks, code 1
5054           iq(1,1)=idrafl(iclpro,jcp,1,'s',0,iret)
5055           iq(2,1)=0
5056           iq(1,2)=iq(1,1)
5057           iq(2,2)=0
5058         endif
5059
5060       elseif(iremn.ge.2)then
5061 c count valence quarks properly
5062
5063 c valence quarks
5064
5065         if(idp1.eq.2)then
5066
5067           if(iLHC.eq.1)then
5068             if(idsp.eq.100)then
5069               iq(1,1)=icp1(1)   !flavor of hard quark already defined
5070             else
5071               iq(1,1)=idrafl(iclpro,jcpv,1,'v',0,idum)
5072             endif
5073             if(iq(1,1).gt.0)then !if still exist, update jcp and jcpv
5074               call idsufl3(iq(1,1),1,jcpv)
5075             else                ! if not, use jcp directly and sea
5076               iq(1,1)=idrafl(iclpro,jcp,1,'s',1,idum)
5077             endif
5078           else
5079
5080           iq(1,1)=idrafl(iclpro,jcpv,1,'v',0,idum)
5081           if(iq(1,1).gt.0)then          !if still exist, update jcp and jcpv
5082             call idsufl3(iq(1,1),1,jcpv)
5083             call idsufl3(iq(1,1),1,jcp)
5084           else                          ! if not, use jcp directly
5085             iq(1,1)=idrafl(iclpro,jcp,1,'v',1,idum)
5086           endif
5087
5088           endif
5089
5090           iq(2,1)=0
5091         endif
5092
5093         if(idp2.eq.2)then
5094
5095           if(iLHC.eq.1)then
5096             if(idsp.eq.100)then
5097               iq(1,2)=icp2(2)   !flavor of hard antiquark already defined
5098             else
5099               iq(1,2)=idrafl(iclpro,jcpv,2,'v',0,idum)
5100             endif
5101             if(iq(1,2).gt.0)then !if still exist, update jcp and jcpv
5102               call idsufl3(iq(1,2),2,jcpv)
5103             else                ! if not, use jcp directly and sea
5104               iq(1,2)=idrafl(iclpro,jcp,2,'s',1,idum)
5105             endif
5106           else
5107
5108           iq(1,2)=idrafl(iclpro,jcpv,2,'v',0,idum)
5109           if(iq(1,2).gt.0)then          !if still exist, update jcp and jcpv
5110             call idsufl3(iq(1,2),2,jcpv)
5111             call idsufl3(iq(1,2),2,jcp)
5112           else                          ! if not, use jcp directly
5113             iq(1,2)=idrafl(iclpro,jcp,2,'v',1,idum)
5114           endif
5115           endif
5116           iq(2,2)=0
5117         endif
5118
5119 c sea quarks
5120         m='v'           !iremn=3
5121
5122         if(idp1.eq.1)then
5123           if(iremn.eq.2)m='s'
5124           j=1                    !quark
5125           i=idrafl(iclpro,jcp,j,m,1,idum)
5126           iq(1,1)=i
5127           if(iLHC.eq.0.and.jcp(i,j)-jcpv(i,j).lt.0)jcpv(i,j)=jcpv(i,j)-1
5128           iq(2,1)=0
5129         elseif(idp1.ge.4)then
5130           if(iremn.eq.2)m='d'
5131           j=2                    !anti-diquark
5132           i=idrafl(iclpro,jcp,j,m,1,idum)
5133           iq(1,1)=i
5134           if(iLHC.eq.0.and.jcp(i,j)-jcpv(i,j).lt.0)jcpv(i,j)=jcpv(i,j)-1
5135           i=idrafl(iclpro,jcp,j,m,1,idum)
5136           iq(2,1)=i
5137           if(iLHC.eq.0.and.jcp(i,j)-jcpv(i,j).lt.0)jcpv(i,j)=jcpv(i,j)-1
5138         endif
5139         if(idp2.eq.1)then
5140           if(iremn.eq.2)m='s'
5141           j=2                    !antiquark
5142           i=idrafl(iclpro,jcp,j,m,1,idum)
5143           iq(1,2)=i
5144           if(iLHC.eq.0.and.jcp(i,j)-jcpv(i,j).lt.0)jcpv(i,j)=jcpv(i,j)-1
5145           iq(2,2)=0
5146         elseif(idp2.ge.4)then
5147           if(iremn.eq.2)m='d'
5148           j=1                    !diquark
5149           i=idrafl(iclpro,jcp,j,m,1,idum)
5150           iq(1,2)=i
5151           if(iLHC.eq.0.and.jcp(i,j)-jcpv(i,j).lt.0)jcpv(i,j)=jcpv(i,j)-1
5152           i=idrafl(iclpro,jcp,j,m,1,idum)
5153           iq(2,2)=i
5154           if(iLHC.eq.0.and.jcp(i,j)-jcpv(i,j).lt.0)jcpv(i,j)=jcpv(i,j)-1
5155         endif
5156
5157       elseif(iremn.ne.0)then
5158 c free remant content
5159
5160 c valence quarks
5161
5162         if(idp1.eq.2)then
5163           if(iLHC.eq.1.and.idsp.eq.100)then
5164             iq(1,1)=icp1(1)         !flavor of hard quark already defined
5165           else
5166             iq(1,1)=idrafl(iclpro,jcp,1,'v',1,iret)
5167           endif
5168           iq(2,1)=0
5169         endif
5170         if(idp2.eq.2)then
5171           if(iLHC.eq.1.and.idsp.eq.100)then
5172             iq(1,2)=icp2(1)     !flavor of hard antiquark already defined
5173           else
5174             iq(1,2)=idrafl(iclpro,jcp,2,'v',1,iret)
5175           endif
5176           iq(2,2)=0
5177         endif
5178
5179 c sea quarks
5180
5181         if(idp1.eq.1)then
5182           iq(1,1)=idrafl(iclpro,jcp,1,'s',1,iret1)
5183           iq(2,1)=0
5184         endif
5185         if(idp2.eq.1)then
5186           iq(1,2)=idrafl(iclpro,jcp,2,'s',1,iret2)
5187           iq(2,2)=0
5188         endif
5189
5190 c diquarks, code 4
5191
5192         if(idp1.eq.4.or.idp2.eq.4)then
5193           iq(1,1)=idrafl(iclpro,jcp,2,'d',1,iret1)
5194           iq(2,1)=idrafl(iclpro,jcp,2,'d',1,iret1)
5195           iq(1,2)=idrafl(iclpro,jcp,1,'d',1,iret2)
5196           iq(2,2)=idrafl(iclpro,jcp,1,'d',1,iret2)
5197         endif
5198
5199 c diquarks, code 5 (former valence, but actually sea)
5200
5201         if(idp1.eq.5)then
5202           iq(1,1)=idrafl(iclpro,jcp,2,'d',1,iret1)
5203           iq(2,1)=idrafl(iclpro,jcp,2,'d',1,iret1)
5204         endif
5205         if(idp2.eq.5)then
5206           iq(1,2)=idrafl(iclpro,jcp,1,'d',1,iret2)
5207           iq(2,2)=idrafl(iclpro,jcp,1,'d',1,iret2)
5208         endif
5209
5210
5211         if(iret.ne.0)goto 1000
5212
5213
5214
5215 c in case of saturated remnants, use the same flavor for quark and anti-quark
5216 c at string-end
5217         if(iret1.ne.0.or.iret2.ne.0)then
5218           do j=1,2
5219             do n=1,nrflav
5220               jcp(n,j)=jcpi(n,j)
5221             enddo
5222           enddo
5223           if(idp1.gt.idp2.or.(idp1.eq.idp2.and.rangen().gt.0.5))then
5224             iq(1,2)=iq(1,1)
5225             iq(2,2)=iq(2,1)
5226           else
5227             iq(1,1)=iq(1,2)
5228             iq(2,1)=iq(2,2)
5229           endif
5230         endif
5231
5232       endif
5233
5234 c Target
5235
5236       if(idst.eq.0.or.iremn.eq.0)then
5237 c give the same flavor to quark and antiquark not to change remnant flavor
5238
5239
5240         if(idm1.eq.4)then
5241 c diquarks, code 4
5242           iq(1,4)=idrafl(icltar,jct,1,'d',0,iret)
5243           iq(2,4)=idrafl(icltar,jct,1,'d',0,iret)
5244           iq(1,3)=iq(1,4)
5245           iq(2,3)=iq(2,4)
5246         else
5247 c sea quarks,code 1
5248           iq(1,4)=idrafl(icltar,jct,1,'s',0,iret)
5249           iq(2,4)=0
5250           iq(1,3)=iq(1,4)
5251           iq(2,3)=0
5252         endif
5253
5254       elseif(iremn.ge.2)then
5255 c count valence quarks properly
5256
5257 c valence quarks
5258
5259         if(idm1.eq.2)then
5260
5261           if(iLHC.eq.1)then
5262             if(idst.eq.100)then
5263               iq(1,4)=icm1(1)   !flavor of hard quark already defined
5264             else
5265               iq(1,4)=idrafl(icltar,jctv,1,'v',0,idum)
5266             endif
5267             if(iq(1,4).gt.0)then !if still exist, update jct and jctv
5268               call idsufl3(iq(1,4),1,jctv)
5269             else                ! if not, use jct directly
5270               iq(1,4)=idrafl(icltar,jct,1,'s',1,idum)
5271             endif
5272           else
5273
5274           iq(1,4)=idrafl(icltar,jctv,1,'v',0,idum)
5275           if(iq(1,4).gt.0)then          !if still exist, update jct and jctv
5276             call idsufl3(iq(1,4),1,jctv)
5277             call idsufl3(iq(1,4),1,jct)
5278           else                          ! if not, use jct directly
5279             iq(1,4)=idrafl(icltar,jct,1,'v',1,idum)
5280           endif
5281
5282           endif
5283
5284           iq(2,4)=0
5285         endif
5286         if(idm2.eq.2)then
5287
5288           if(iLHC.eq.1)then
5289             if(idst.eq.100)then
5290               iq(1,3)=icm2(2)   !flavor of hard antiquark already defined
5291             else
5292               iq(1,3)=idrafl(icltar,jctv,2,'v',0,idum)
5293             endif
5294             if(iq(1,3).gt.0)then !if still exist, update jct and jctv
5295               call idsufl3(iq(1,3),2,jctv)
5296             else                ! if not, use jct directly
5297               iq(1,3)=idrafl(icltar,jct,2,'s',1,idum)
5298             endif
5299           else
5300
5301           iq(1,3)=idrafl(icltar,jctv,2,'v',0,idum)
5302           if(iq(1,3).gt.0)then          !if still exist, update jct and jctv
5303             call idsufl3(iq(1,3),2,jctv)
5304             call idsufl3(iq(1,3),2,jct)
5305           else                          ! if not, use jct directly
5306             iq(1,3)=idrafl(icltar,jct,2,'v',1,idum)
5307           endif
5308           endif
5309           iq(2,3)=0
5310         endif
5311
5312 c sea quarks
5313         m='v'           !iremn=3
5314
5315         if(idm1.eq.1)then
5316           if(iremn.eq.2)m='s'
5317           j=1                    !quark
5318           i=idrafl(icltar,jct,j,m,1,idum)
5319           iq(1,4)=i
5320           if(iLHC.eq.0.and.jct(i,j)-jctv(i,j).lt.0)jctv(i,j)=jctv(i,j)-1
5321           iq(2,4)=0
5322         elseif(idm1.ge.4)then
5323           if(iremn.eq.2)m='d'
5324           j=2                   !anti-diquark
5325           i=idrafl(icltar,jct,j,m,1,idum)
5326           iq(1,4)=i
5327           if(iLHC.eq.0.and.jct(i,j)-jctv(i,j).lt.0)jctv(i,j)=jctv(i,j)-1
5328           i=idrafl(icltar,jct,j,m,1,idum)
5329           iq(2,4)=i
5330           if(iLHC.eq.0.and.jct(i,j)-jctv(i,j).lt.0)jctv(i,j)=jctv(i,j)-1
5331         endif
5332         if(idm2.eq.1)then
5333           if(iremn.eq.2)m='s'
5334           j=2                    !antiquark
5335           i=idrafl(icltar,jct,j,m,1,idum)
5336           iq(1,3)=i
5337           if(iLHC.eq.0.and.jct(i,j)-jctv(i,j).lt.0)jctv(i,j)=jctv(i,j)-1
5338           iq(2,3)=0
5339         elseif(idm2.ge.4)then
5340           if(iremn.eq.2)m='d'
5341           j=1                    !diquark
5342           i=idrafl(icltar,jct,j,m,1,idum)
5343           iq(1,3)=i
5344           if(iLHC.eq.0.and.jct(i,j)-jctv(i,j).lt.0)jctv(i,j)=jctv(i,j)-1
5345           i=idrafl(icltar,jct,j,m,1,idum)
5346           iq(2,3)=i
5347           if(iLHC.eq.0.and.jct(i,j)-jctv(i,j).lt.0)jctv(i,j)=jctv(i,j)-1
5348         endif
5349
5350       elseif(iremn.ne.0)then
5351
5352 c valence quarks
5353
5354         if(idm1.eq.2)then
5355           if(iLHC.eq.1.and.idst.eq.100)then
5356             iq(1,4)=icm1(1)         !flavor of hard quark already defined
5357           else
5358             iq(1,4)=idrafl(icltar,jct,1,'v',1,iret)
5359           endif
5360           iq(2,4)=0
5361         endif
5362         if(idm2.eq.2)then
5363           if(iLHC.eq.1.and.idst.eq.100)then
5364             iq(1,3)=icm2(1)         !flavor of hard antiquark already defined
5365           else
5366             iq(1,3)=idrafl(icltar,jct,2,'v',1,iret)
5367           endif
5368           iq(2,3)=0
5369         endif
5370
5371 c sea quarks
5372
5373         if(idm1.eq.1)then
5374           iq(1,4)=idrafl(icltar,jct,1,'s',1,iret4)
5375           iq(2,4)=0
5376         endif
5377         if(idm2.eq.1)then
5378           iq(1,3)=idrafl(icltar,jct,2,'s',1,iret3)
5379           iq(2,3)=0
5380         endif
5381
5382 c diquarks, code 4
5383
5384         if(idm1.eq.4.or.idm2.eq.4)then
5385           iq(1,4)=idrafl(icltar,jct,2,'d',1,iret3)
5386           iq(2,4)=idrafl(icltar,jct,2,'d',1,iret3)
5387           iq(1,3)=idrafl(icltar,jct,1,'d',1,iret4)
5388           iq(2,3)=idrafl(icltar,jct,1,'d',1,iret4)
5389         endif
5390
5391 c diquarks, code 5 (former valence, but actually sea)
5392
5393         if(idm1.eq.5)then
5394           iq(1,4)=idrafl(icltar,jct,2,'d',1,iret4)
5395           iq(2,4)=idrafl(icltar,jct,2,'d',1,iret4)
5396         endif
5397         if(idm2.eq.5)then
5398           iq(1,3)=idrafl(icltar,jct,1,'d',1,iret3)
5399           iq(2,3)=idrafl(icltar,jct,1,'d',1,iret3)
5400         endif
5401
5402
5403         if(iret.ne.0)goto 1000
5404
5405
5406
5407 c in case of saturated remnants, use the same flavor for quark and anti-quark
5408 c at string-end
5409
5410         if(iret3.ne.0.or.iret4.ne.0)then
5411           do j=1,2
5412             do n=1,nrflav
5413               jct(n,j)=jcti(n,j)
5414             enddo
5415           enddo
5416           if(idm1.gt.idm2.or.(idm1.eq.idm2.and.rangen().gt.0.5))then
5417             iq(1,4)=iq(1,3)
5418             iq(2,4)=iq(2,3)
5419           else
5420             iq(1,3)=iq(1,4)
5421             iq(2,3)=iq(2,4)
5422           endif
5423         endif
5424
5425       endif
5426
5427       ifla=iq(1,1)
5428       iflb=iq(2,1)
5429       iflc=iq(1,3)
5430       ifld=iq(2,3)
5431       if(ish.ge.7)write(ifch,'(a,2i5,4x,2i5)')
5432      *' string 1, string ends:',ifla,iflb,iflc,ifld
5433
5434       if(ifla.gt.0)then
5435        if(iflb.eq.0)then
5436         icp1(1)=10**(6-ifla)
5437         icp1(2)=0
5438        else
5439         icp1(1)=0
5440         icp1(2)=10**(6-ifla)
5441         icp1(2)=icp1(2)+10**(6-iflb)
5442        endif
5443       endif
5444
5445       if(iflc.gt.0)then
5446        if(ifld.eq.0)then
5447         icm2(1)=0
5448         icm2(2)=10**(6-iflc)
5449        else
5450         icm2(1)=10**(6-iflc)
5451         icm2(1)=icm2(1)+10**(6-ifld)
5452         icm2(2)=0
5453        endif
5454       endif
5455
5456       ifla=iq(1,4)
5457       iflb=iq(2,4)
5458       iflc=iq(1,2)
5459       ifld=iq(2,2)
5460       if(ish.ge.7)write(ifch,'(a,2i5,4x,2i5)')
5461      *' string 2, string ends:',ifla,iflb,iflc,ifld
5462
5463       if(ifla.gt.0)then
5464        if(iflb.eq.0)then
5465         icm1(1)=10**(6-ifla)
5466         icm1(2)=0
5467        else
5468         icm1(1)=0
5469         icm1(2)=10**(6-ifla)
5470         icm1(2)=icm1(2)+10**(6-iflb)
5471        endif
5472       endif
5473
5474       if(iflc.gt.0)then
5475        if(ifld.eq.0)then
5476         icp2(1)=0
5477         icp2(2)=10**(6-iflc)
5478        else
5479         icp2(1)=10**(6-iflc)
5480         icp2(1)=icp2(1)+10**(6-ifld)
5481         icp2(2)=0
5482        endif
5483       endif
5484
5485       if(ish.ge.7)then
5486         write(ifch,'(a,2i7,4x,2i7)')
5487      *  ' SE-forw:',icp1(1),icp1(2),icp2(1),icp2(2)
5488         write(ifch,'(a,2i7,4x,2i7)')
5489      *  ' SE-back:',icm1(1),icm1(2),icm2(1),icm2(2)
5490         write(ifch,'(a,3x,6i3,3x,6i3)')' proj:',jcp
5491         write(ifch,'(a,3x,6i3,3x,6i3)')' proj val:',jcpv
5492         write(ifch,'(a,3x,6i3,3x,6i3)')' targ:',jct
5493         write(ifch,'(a,3x,6i3,3x,6i3)')' targ val:',jctv
5494       endif
5495
5496 c     exit
5497 c     ----
5498
5499 1000  continue
5500       call utprix('fstrfl',ish,ishini,7)
5501       return
5502       end
5503
5504
5505 cc-----------------------------------------------------------------------
5506 c      subroutine fremfl(icp,ict,iret)
5507 cc-----------------------------------------------------------------------
5508 cc checks projectile and target flavor (icp,ict)
5509 cc in case of reggeon exchange they do not correspond to hadrons.
5510 cc one transfers therefore flavor from one side to the other in order
5511 cc to have hadron flavor.
5512 cc icp and ict are modified correspondingly
5513 cc-----------------------------------------------------------------------
5514 c      include 'epos.inc'
5515 c      integer icp(2),ict(2),jcp(6,2),jct(6,2),kp(4),kt(4)
5516 c
5517 c      call utpri('fremfl',ish,ishini,7)
5518 c
5519 cc     entry
5520 cc     -----
5521 c
5522 c      iret=0
5523 c
5524 c      call iddeco(icp,jcp)
5525 c      call iddeco(ict,jct)
5526 c
5527 c      iakp=0
5528 c      iakt=0
5529 c      ikp=0
5530 c      ikt=0
5531 c      do l=1,4
5532 c       kp(l)=jcp(l,1)-jcp(l,2)
5533 c       kt(l)=jct(l,1)-jct(l,2)
5534 c       iakp=iakp+iabs(kp(l))
5535 c       iakt=iakt+iabs(kt(l))
5536 c       ikp=ikp+kp(l)
5537 c       ikt=ikt+kt(l)
5538 c      enddo
5539 c      if(ish.ge.7)write(ifch,*)'iak_p:',iakp,' ik_p:',ikp
5540 c      if(ish.ge.7)write(ifch,*)'iak_t:',iakt,' ik_t:',ikt
5541 c
5542 c      if(iakp.eq.4)then
5543 c       if(ikp.eq.4.or.ikp.eq.-2)then
5544 c        ifl=idrafl(jcp,1,'v',iret)
5545 c        iqp=2      ! subtract quark
5546 c        iqt=1      ! add quark
5547 c       elseif(ikp.eq.-4.or.ikp.eq.2)then
5548 c        ifl=idrafl(jcp,2,'v',iret)
5549 c        iqp=1      ! subtract antiquark
5550 c        iqt=2      ! add antiquark
5551 c       else
5552 c        call utstop('fremfl&')
5553 c       endif
5554 c      elseif(iakt.eq.4)then
5555 c       if(ikt.eq.4.or.ikt.eq.-2)then
5556 c        ifl=idrafl(jct,1,'v',iret)
5557 c        iqp=1      ! add quark
5558 c        iqt=2      ! subtract quark
5559 c       elseif(ikt.eq.-4.or.ikt.eq.2)then
5560 c        ifl=idrafl(jct,2,'v',iret)
5561 c        iqp=2      ! add antiquark
5562 c        iqt=1      ! subtract antiquark
5563 c       else
5564 c        call utstop('fremfl&')
5565 c       endif
5566 c      elseif(iakp.eq.3)then
5567 c       if(ikp.gt.0)then
5568 c        ifl=idrafl(jcp,1,'v',iret)
5569 c        iqp=2      ! subtract quark
5570 c        iqt=1      ! add quark
5571 c       else
5572 c        ifl=idrafl(jcp,2,'v',iret)
5573 c        iqp=1      ! subtract antiquark
5574 c        iqt=2      ! add antiquark
5575 c       endif
5576 c      elseif(iakt.eq.3)then
5577 c       if(ikt.gt.0)then
5578 c        ifl=idrafl(jct,1,'v',iret)
5579 c        iqp=1      ! add quark
5580 c        iqt=2      ! subtract quark
5581 c       else
5582 c        ifl=idrafl(jct,2,'v',iret)
5583 c        iqp=2      ! add antiquark
5584 c        iqt=1      ! subtract antiquark
5585 c       endif
5586 c      elseif(iakp.eq.2)then
5587 c       if(ikp.gt.0)then
5588 c        ifl=idrafl(jct,1,'v',iret)
5589 c        iqp=1      ! add quark
5590 c        iqt=2      ! subtract quark
5591 c       else
5592 c        ifl=idrafl(jct,2,'v',iret)
5593 c        iqp=2      ! add antiquark
5594 c        iqt=1      ! subtract antiquark
5595 c       endif
5596 c      elseif(iakt.eq.2)then
5597 c       if(ikt.gt.0)then
5598 c        ifl=idrafl(jct,1,'v',iret)
5599 c        iqp=2      ! subtract quark
5600 c        iqt=1      ! add quark
5601 c       else
5602 c        ifl=idrafl(jct,2,'v',iret)
5603 c        iqp=1      ! subtract antiquark
5604 c        iqt=2      ! add antiquark
5605 c       endif
5606 c      elseif(iakp.eq.1)then
5607 c       if(ikp.gt.0)then
5608 c        ifl=idrafl(jcp,2,'v',iret)
5609 c        iqp=2      ! add antiquark
5610 c        iqt=1      ! subtract antiquark
5611 c       else
5612 c        ifl=idrafl(jcp,1,'v',iret)
5613 c        iqp=1      ! add quark
5614 c        iqt=2      ! subtract quark
5615 c       endif
5616 c      elseif(iakt.eq.1)then
5617 c       if(ikt.gt.0)then
5618 c        ifl=idrafl(jct,2,'v',iret)
5619 c        iqp=1      ! subtract antiquark
5620 c        iqt=2      ! add antiquark
5621 c       else
5622 c        ifl=idrafl(jct,1,'v',iret)
5623 c        iqp=2      ! subtract quark
5624 c        iqt=1      ! add quark
5625 c       endif
5626 c      else
5627 c       call utstop('fremfl: error&')
5628 c      endif
5629 c
5630 c      if(ish.ge.7)write(ifch,*)'iq_p:',iqp,' iq_t:',iqt,' if:',ifl
5631 c      call uticpl(icp,ifl,iqp,iret)
5632 c      if(iret.ne.0)goto1000
5633 c      call uticpl(ict,ifl,iqt,iret)
5634 c      if(iret.ne.0)goto1000
5635 c
5636 cc     exit
5637 cc     ----
5638 c
5639 c1000  continue
5640 c      call utprix('fremfl',ish,ishini,7)
5641 c      return
5642 c      end
5643 c
5644 c-----------------------------------------------------------------------
5645       subroutine fstrwr(j,ii,jj,k,n)
5646 c-----------------------------------------------------------------------
5647 c take pstg(5,j),pend(4,ii),idend(ii),pend(4,jj),idend(jj)  (/cems/)
5648 c and write it to /cptl/
5649 c-----------------------------------------------------------------------
5650 c  j:     string 1 or 2
5651 c  ii,jj: string end (1,2: proj; 3,4: targ)
5652 c  k:     current collision
5653 c  n:     current pomeron
5654 c-----------------------------------------------------------------------
5655
5656       include 'epos.inc'
5657       include 'epos.incems'
5658
5659       double precision pstg,pend,ptt3!,utpcmd
5660       common/cems/pstg(5,2),pend(4,4),idend(4)
5661       common/emsptl/nppr(npommx,kollmx),npproj(mamx),nptarg(mamx)
5662       double precision  pp(4)
5663       common/cts/its
5664
5665       call utpri('fstrwr',ish,ishini,7)
5666
5667       if(idend(ii).ne.0.and.idend(jj).ne.0)then
5668
5669 c string
5670 c        id1=abs(idend(ii))
5671 c        id2=abs(idend(jj))
5672 c        call idmass(id1,am1)
5673 c        call idmass(id2,am2)
5674 c        if(id1.gt.100)then
5675 c          am1=am1+qmass(0)
5676 c        endif
5677 c        if(id2.gt.100)then
5678 c          am2=am2+qmass(0)
5679 c        endif
5680 c        ptt3=utpcmd(pstg(5,j),dble(am1),dble(am2),iret)
5681 c        if(iret.ne.0.or.pstg(5,j)-dble(am1)-dble(am2).le.0d0)then
5682 c          ptt3=0.5d0*pstg(5,j)
5683 c          am1=0.
5684 c          am2=0.
5685 c        endif
5686         am1=0.
5687         am2=0.
5688         ptt3=0.5d0*pstg(5,j)
5689
5690        call utlob2(1,pstg(1,j),pstg(2,j),pstg(3,j),pstg(4,j),pstg(5,j)
5691      * ,pend(1,ii),pend(2,ii),pend(3,ii),pend(4,ii),20)
5692        pp(1)=0d0
5693        pp(2)=0d0
5694        pp(3)=ptt3!.5d0*pstg(5,j)
5695        pp(4)=sqrt(ptt3*ptt3+dble(am1*am1))!.5d0*pstg(5,j)
5696        call utrot2
5697      * (-1,pend(1,ii),pend(2,ii),pend(3,ii),pp(1),pp(2),pp(3))
5698        call utlob2(-1,pstg(1,j),pstg(2,j),pstg(3,j),pstg(4,j),pstg(5,j)
5699      * ,pp(1),pp(2),pp(3),pp(4),21)
5700
5701        npom=nppr(n,k)
5702        if(ifrptl(1,npom).eq.0)ifrptl(1,npom)=nptl+1
5703        ifrptl(2,npom)=nptl+2
5704        istptl(npom)=31
5705
5706        nptl=nptl+1
5707        pptl(1,nptl)=sngl(pp(1))
5708        pptl(2,nptl)=sngl(pp(2))
5709        pptl(3,nptl)=sngl(pp(3))
5710        pptl(4,nptl)=sngl(pp(4))
5711        pptl(5,nptl)=am1 !0.
5712        istptl(nptl)=20
5713        iorptl(nptl)=npom
5714        jorptl(nptl)=0
5715        ifrptl(1,nptl)=0
5716        ifrptl(2,nptl)=0
5717        xorptl(1,nptl)=coord(1,k)
5718        xorptl(2,nptl)=coord(2,k)
5719        xorptl(3,nptl)=coord(3,k)
5720        xorptl(4,nptl)=coord(4,k)
5721        tivptl(1,nptl)=xorptl(4,nptl)
5722        tivptl(2,nptl)=xorptl(4,nptl)
5723        idptl(nptl)=idend(ii)
5724        ityptl(nptl)=ityptl(npom)+j
5725        itsptl(nptl)=its
5726        rinptl(nptl)=-9999
5727        qsqptl(nptl)=pstg(4,j)**2
5728        zpaptl(1,nptl)=0.
5729        zpaptl(2,nptl)=0.
5730
5731        nptl=nptl+1
5732        do i=1,4
5733         pptl(i,nptl)=sngl(pstg(i,j))-pptl(i,nptl-1)
5734        enddo
5735        pptl(5,nptl)=am2!0.
5736
5737        istptl(nptl)=20
5738        iorptl(nptl)=nppr(n,k)
5739        jorptl(nptl)=0
5740        ifrptl(1,nptl)=0
5741        ifrptl(2,nptl)=0
5742        xorptl(1,nptl)=coord(1,k)
5743        xorptl(2,nptl)=coord(2,k)
5744        xorptl(3,nptl)=coord(3,k)
5745        xorptl(4,nptl)=coord(4,k)
5746        tivptl(1,nptl)=xorptl(4,nptl)
5747        tivptl(2,nptl)=xorptl(4,nptl)
5748        idptl(nptl)=idend(jj)
5749        ityptl(nptl)=ityptl(npom)+j
5750        itsptl(nptl)=its
5751        rinptl(nptl)=-9999
5752        qsqptl(nptl)=pstg(4,j)**2
5753        zpaptl(1,nptl)=0.
5754        zpaptl(2,nptl)=0.
5755
5756        if(ish.ge.7)then
5757         write(ifch,100)' kink:',(pptl(l,nptl-1),l=1,4),idptl(nptl-1)
5758         write(ifch,100)' kink:',(pptl(l,nptl),l=1,4),idptl(nptl)
5759        endif
5760
5761       elseif(idend(ii).ne.0.and.idend(jj).eq.0)then
5762
5763 c resonance
5764
5765        npom=nppr(n,k)
5766        if(ifrptl(1,npom).eq.0)ifrptl(1,npom)=nptl+1
5767        ifrptl(2,npom)=nptl+1
5768        istptl(npom)=31
5769
5770        nptl=nptl+1
5771        idptl(nptl)=idend(ii)
5772        pptl(1,nptl)=sngl(pstg(1,j))
5773        pptl(2,nptl)=sngl(pstg(2,j))
5774        pptl(3,nptl)=sngl(pstg(3,j))
5775        pptl(4,nptl)=sngl(pstg(4,j))
5776        pptl(5,nptl)=sngl(pstg(5,j))
5777        istptl(nptl)=0
5778        iorptl(nptl)=npom
5779        jorptl(nptl)=0
5780        ifrptl(1,nptl)=0
5781        ifrptl(2,nptl)=0
5782        xorptl(1,nptl)=coord(1,k)
5783        xorptl(2,nptl)=coord(2,k)
5784        xorptl(3,nptl)=coord(3,k)
5785        xorptl(4,nptl)=coord(4,k)
5786        tivptl(1,nptl)=coord(4,k)
5787        call idtau(idptl(nptl),pptl(4,nptl),pptl(5,nptl),taugm)
5788        tivptl(2,nptl)=tivptl(1,nptl)+taugm*(-alog(rangen()))
5789        ityptl(nptl)=ityptl(npom)+2+j
5790        itsptl(nptl)=its
5791        rinptl(nptl)=-9999
5792        qsqptl(nptl)=0.
5793        zpaptl(1,nptl)=0.
5794        zpaptl(2,nptl)=0.
5795
5796        if(ish.ge.7)then
5797         write(ifch,100)'  res:',(pptl(l,nptl),l=1,4),idptl(nptl)
5798        endif
5799       elseif(idend(ii).eq.0.and.idend(jj).eq.0)then
5800        goto1000
5801       else
5802        call utstop('error in fstrwr&')
5803       endif
5804
5805   100 format(a,4e9.3,i5)
5806
5807 1000  continue
5808       call utprix('fstrwr',ish,ishini,7)
5809       return
5810       end
5811
5812 c-----------------------------------------------------------------------
5813       subroutine ProReF(ir,m,iretxx)
5814 c-----------------------------------------------------------------------
5815 c  proposes flavor for remnant m for proj (ir=1) or target (ir=-1)
5816 c  and writes remnant into /cptl/ as string or hadron
5817 c   ityptl definitions:
5818 c      51  41  ...  rmn drop
5819 c      52  42  ...  rmn str inel
5820 c      53  43  ...  rmn str diff
5821 c      54  44  ...  rmn str inel with split (or after droplet or hadron split)
5822 c      55  45  ...  rmn res
5823 c      56  46  ...  rmn from split without connexion
5824 c      57  47  ...  rmn res active spectators
5825 c      58  48  ...  rmn res from diff
5826 c      59  49  ...  hadron split
5827 c-----------------------------------------------------------------------
5828
5829       include 'epos.inc'
5830       include 'epos.incems'
5831       include 'epos.incsem'
5832
5833       double precision plc,s   ,ptt1,ptt2,ptt3
5834       common/cems5/plc,s
5835       double precision tpro,zpro,ttar,ztar,ttaus,detap,detat,zor,tor
5836       common/cttaus/tpro,zpro,ttar,ztar,ttaus,detap,detat
5837       common /cncl/xproj(mamx),yproj(mamx),zproj(mamx)
5838      *            ,xtarg(mamx),ytarg(mamx),ztarg(mamx)
5839       double precision amasmin,amasini,xmdrmax,xmdrmin!,utpcmd
5840       integer icf(2),icb(2)
5841       integer jcf(nflav,2),jcval(nflav,2)!,jcdummy(nflav,2)
5842       logical gdrop, ghadr,gproj
5843       double precision ept(5),ep(4),aa(5),am2t,piq1,piq2,piq3
5844       common/emsptl/nppr(npommx,kollmx),npproj(mamx),nptarg(mamx)
5845       common /ems12/iodiba,bidiba  ! defaut iodiba=0. if iodiba=1, study H-Dibaryon
5846       character c*1,c1*1,c2*1
5847
5848       call utpri('ProReF',ish,ishini,3)
5849
5850       iretxx=0
5851
5852       if(ir.ne.1.and.ir.ne.-1)stop'ProReF: wrong ir'
5853
5854       irmdropx=irmdrop
5855  55   idrop=0
5856       gdrop=.false.
5857       ghadr=.false.
5858       iret=0
5859       dens=0.0765
5860       do j=1,2
5861         do i=1,nflav
5862           jcf(i,j)=0
5863         enddo
5864       enddo
5865
5866       flow=1.
5867       if(ir.eq.1)then
5868 c        if(kolp(m).le.0)goto1000
5869         if(iep(m).le.-1)goto1000
5870         gproj=.true.
5871         mm=npproj(m)
5872         iept=iep(m)
5873         zz=zzremn(m,1)
5874         iclpt=iclpro
5875         isopt=isoproj
5876         if(iremn.ge.2)then         !number of valence quarks still in proj
5877           if((iept.eq.3.or.iept.eq.5).and.yrmaxi.gt.1.e-5)
5878      &      flow=1./fradflii**2
5879           do nnn=1,nrflav
5880             jcval(nnn,1)=jcpval(nnn,1,m)
5881             jcval(nnn,2)=jcpval(nnn,2,m)
5882           enddo
5883           do nnn=nrflav+1,nflav
5884             jcval(nnn,1)=0
5885             jcval(nnn,2)=0
5886           enddo
5887         else
5888           do nnn=1,nflav
5889             jcval(nnn,1)=0
5890           enddo
5891           do nnn=1,nflav
5892             jcval(nnn,2)=0
5893           enddo
5894         endif
5895       elseif(ir.eq.-1)then
5896 c        if(kolt(m).le.0)goto1000
5897         if(iet(m).le.-1)goto1000
5898         gproj=.false.
5899         mm=nptarg(m)
5900         iept=iet(m)
5901         zz=zzremn(m,2)
5902         iclpt=icltar
5903         isopt=isotarg
5904         if(iremn.ge.2)then         !number of valence quarks still in proj
5905           if((iept.eq.3.or.iept.eq.5).and.yrmaxi.gt.1.e-5)
5906      &      flow=1./fradflii**2
5907           do nnn=1,nrflav
5908             jcval(nnn,1)=jctval(nnn,1,m)
5909             jcval(nnn,2)=jctval(nnn,2,m)
5910           enddo
5911           do nnn=nrflav+1,nflav
5912             jcval(nnn,1)=0
5913             jcval(nnn,2)=0
5914           enddo
5915         else
5916           do nnn=1,nflav
5917             jcval(nnn,1)=0
5918           enddo
5919           do nnn=1,nflav
5920             jcval(nnn,2)=0
5921           enddo
5922         endif
5923       else
5924         call utstop('ProReF: ir ???&')
5925       endif
5926       if(ish.ge.3)
5927      &write(ifch,*)'remnant particle index:',mm,m,iclpt,isopt
5928
5929       if(ish.ge.8)call alist('ProRef&',1,nptl)
5930       antotre=antotre+1.
5931
5932       mmini=mm
5933       nptlini=nptl
5934       minfra=min(minfra,nptlini)   !for trigger condition
5935
5936       do l=1,5
5937        ept(l)=dble(pptl(l,mm))
5938       enddo
5939
5940       ifrptl(1,mm)=0
5941       ifrptl(2,mm)=0
5942
5943 c  initialize forward and backward ic (to transform remnant into string)
5944
5945       if(gproj)then
5946         icf(1)=icproj(1,m)
5947         icf(2)=icproj(2,m)
5948         if(icf(1).eq.999999)then    !more than 9 quark : use jcpref
5949           do j=1,2
5950             do i=1,nrflav
5951               jcf(i,j)=jcpref(i,j,m)
5952             enddo
5953           enddo
5954         else
5955           call iddeco(icf,jcf)
5956         endif
5957       else                     !gtarg
5958         icf(1)=ictarg(1,m)
5959         icf(2)=ictarg(2,m)
5960         if(icf(1).eq.999999)then    !more than 9 quark : use jctref
5961           do j=1,2
5962             do i=1,nrflav
5963               jcf(i,j)=jctref(i,j,m)
5964             enddo
5965           enddo
5966         else
5967           call iddeco(icf,jcf)
5968         endif
5969       endif
5970       icb(1)=0
5971       icb(2)=0
5972
5973       call idquacjc(jcf,nqu,naq)
5974 c use RemoveHadron if too many c quarks
5975       if(nrflav.gt.3)then
5976         nqc=jcf(4,1)+jcf(4,2)
5977         if(nqu.lt.3.and.jcf(4,1).gt.1.or.
5978      &     naq.lt.3.and.jcf(4,2).gt.1.or.
5979      &             jcf(4,1)*jcf(4,2).gt.1 )nqc=4
5980       else
5981         nqc=0
5982       endif
5983       if(iremn.ge.2)then
5984         ier=0
5985         ires=0
5986         id=idtra(icf,ier,ires,0)
5987         if(ier.eq.0)then
5988           call idspin(id,ispin,jspin,istra)
5989         else
5990           ispin=0
5991           jspin=0
5992           istra=0
5993         endif
5994       endif
5995
5996 c define masses
5997
5998       amasmin=dble(fremnux(jcf))**2.d0
5999       if(ept(5).le.0.d0)then
6000         ept(5)=dble(fremnux(jcf)*(1.+rangen()))
6001         if(ish.ge.2)then
6002           call utmsg('ProReF')
6003           write(ifch,*)'zero remnant mass -> amasmin'
6004           call utmsgf
6005         endif
6006       endif
6007       am2t=sqrt(ept(1)**2+ept(2)**2+ept(5)**2)
6008       if(iLHC.eq.1.and.ept(4).gt.am2t.and.(iept.eq.0.or.iept.eq.6))then
6009         ept(3)=sign(sqrt((ept(4)+am2t)*(ept(4)-am2t)),ept(3))
6010       else
6011         ept(4)=sqrt(ept(3)*ept(3)+ept(2)*ept(2)+ept(1)*ept(1)
6012      &           +ept(5)*ept(5))
6013       endif
6014       am2t=(ept(4)+ept(3))*(ept(4)-ept(3))-(ept(1)**2+ept(2)**2)
6015       if(ish.ge.2
6016      &   .and.(am2t.lt.-1d0.or.abs(am2t-ept(5)*ept(5)).gt.ept(5)))then
6017           write(ifch,*)'Precision problem in ProRef, p:',
6018      &             (ept(k),k=1,4),ept(5)*ept(5),am2t
6019       endif
6020
6021       if(ish.ge.3)then
6022         if(gproj)then
6023             write(ifch,'(a,5e11.3,2i7)')' proj:'
6024      &      ,(sngl(ept(k)) ,k=1,5),(icproj(k,m) ,k=1,2)
6025         else    !gtarg
6026            write(ifch,'(a,5e11.3,2i7)')' targ:'
6027      &      ,(sngl(ept(k)) ,k=1,5),(ictarg(k,m),k=1,2)
6028          endif
6029       endif
6030
6031       amasini=ept(5)*ept(5)
6032
6033       xmdrmin=dble(fremnux(jcf)+amdrmin)**2
6034       xmdrmax=dble(fremnux(jcf)+amdrmax)**2
6035
6036
6037       if(ish.ge.4)write(ifch,*)'remnant masses:',am2t,amasini,amasmin
6038      &                ,xmdrmin,zz,iept
6039
6040 c.............................exotic ...................................
6041
6042 c      if(amasini.gt.amasmin.and.irmdropx.eq.1)then
6043
6044 c      if(.not.((nqu.eq.3.and.naq.eq.0).or.(nqu.eq.0.and.naq.eq.3)
6045       if((iept.eq.3.or.iept.eq.5.or.
6046 c     &   (iept.eq.1.and.iremn.eq.3!.and.amasini.le.xmdrmin
6047 c     &    .and.(jcf(4,1)+jcf(4,2).eq.0)).or.
6048      &   .not.((nqu.eq.3.and.naq.eq.0).or.(nqu.eq.0.and.naq.eq.3)
6049      &           .or.(nqu.eq.1.and.naq.eq.1))).and.nqc.le.3
6050      &    .and.amasini.gt.amasmin.and.irmdropx.eq.1)then
6051
6052 c      if((
6053 c     &   .not.((nqu.eq.3.and.naq.eq.0).or.(nqu.eq.0.and.naq.eq.3)
6054 c     &           .or.(nqu.eq.1.and.naq.eq.1)).or.
6055 c     &   (iept.ne.0.and.iept.le.2.and.reminv/ept(5).gt.rangen()))
6056 c     &    .and.amasini.gt.amasmin.and.irmdropx.eq.1)then
6057
6058          !print*,'-------------------------------------------' !!!
6059          !print*,jcf
6060          !print*,icf,sqrt(amasini),sqrt(amasmin),sqrt(xmdrmin)  !!!
6061          !print*,nqu,naq                                      !!!
6062 c charm not possible in droplet
6063         if(iremn.ge.2.or.
6064      &     (amasini.gt.xmdrmin.or.nqc.ne.0))then
6065           if(iremn.eq.2)then
6066          call getdropx(ir,iept,m,icf,jcf,jcval,zz,ept,aa
6067      &                                          ,gdrop,xmdrmax)
6068           else
6069          call getdroplet(ir,iept,icf,jcf,zz,ept,aa,gdrop,xmdrmax)
6070           endif
6071           !--------------------------------
6072           !emit a droplet, update the remnant string flavor and 5-momentum
6073           ! input
6074           !     ir ......... 1  projectile, -1  target remnant
6075           !     ept ........ remnant  5-momentum
6076           !     jcf ........ remnant jc
6077           ! output
6078           !     gdrop ...  .true. = successful droplet emission
6079           !                          jcf, ept ....... droplet  ic and 5-momentum
6080           !                          icf, a ......... remnant string jc and 5-momentum
6081           !               .false. = unsuccessful
6082           !                          jcf, ept .... unchanged,
6083           !                          emits hadrons instead of droplet
6084 c         !                          considered as droplet jc and 5-momentum
6085           !-------------------------------------
6086         endif
6087
6088 c redefine energy and charm quarks in droplet
6089         amasini=ept(5)*ept(5)
6090         nqc=jcf(4,1)+jcf(4,2)
6091 c use remove hadrons if droplet too heavy (should not happen) or charm
6092         if(amasini.gt.1e4.or.nqc.ne.0)goto 500
6093
6094         !...........droplet
6095         !also in case of unsuccessful drop emission, then remnant = droplet !
6096         idrop=1
6097         nptl=nptl+1
6098         t=xorptl(4,mm)
6099         istptl(mm)=41
6100         ifrptl(1,mm)=nptl
6101         ifrptl(2,mm)=nptl
6102         tivptl(2,mm)=t
6103 c            Remnant radius to have eps=dens GeV/fm3
6104         radptl(nptl)=(3.*sngl(ept(5))/4./pi/dens)**0.3333
6105         dezptl(nptl)=0.
6106         do l=1,5
6107           pptl(l,nptl)=sngl(ept(l))
6108         enddo
6109         if(gdrop)then
6110           idx=0
6111         else
6112           if(iLHC.eq.1)then
6113             idx=idtra(icf,0,0,0)
6114           else
6115             idx=idtra(icf,0,0,3)
6116           endif
6117         endif
6118         if(abs(idx).gt.100)then
6119          amx=sngl(ept(5))
6120          call idres(idx,amx,idrx,iadjx)
6121          idx=idrx
6122         else
6123          idx=0
6124         endif
6125         if(idx.eq.0)then
6126           istptl(nptl)=10
6127           call idenct(jcf,idptl(nptl)
6128      *    ,ibptl(1,nptl),ibptl(2,nptl),ibptl(3,nptl),ibptl(4,nptl))
6129           if(gproj)then
6130             ityptl(nptl)=40
6131           else  !gtarg
6132             ityptl(nptl)=50
6133           endif
6134         else
6135           istptl(nptl)=0
6136           idptl(nptl)=idx
6137           pptl(5,nptl)=amx
6138           pptl(4,nptl)=sqrt(amx*amx+pptl(1,nptl)*pptl(1,nptl)
6139      &       +pptl(2,nptl)*pptl(2,nptl)+pptl(3,nptl)*pptl(3,nptl))
6140           if(gproj)then
6141             ityptl(nptl)=45
6142             if(iept.eq.6)ityptl(nptl)=47
6143           else  !gtarg
6144             ityptl(nptl)=55
6145             if(iept.eq.6)ityptl(nptl)=57
6146           endif
6147         endif
6148         iorptl(nptl)=mm
6149         jorptl(nptl)=0
6150         ifrptl(1,nptl)=0
6151         ifrptl(2,nptl)=0
6152         xorptl(1,nptl)=xorptl(1,mm)
6153         xorptl(2,nptl)=xorptl(2,mm)
6154         xorptl(3,nptl)=xorptl(3,mm)
6155         xorptl(4,nptl)=t
6156         tivptl(1,nptl)=t
6157         call idtau(idptl(nptl),pptl(4,nptl),pptl(5,nptl),taugm)
6158         tivptl(2,nptl)=tivptl(1,nptl)+taugm*(-alog(rangen()))
6159         do l=1,4
6160           ibptl(l,nptl)=0
6161         enddo
6162         andropl=andropl+1
6163         if(ish.ge.3)write(ifch,*)'Proref,ept(5),id',ept(5),idptl(nptl)
6164         !print*,nptl,idptl(nptl),sngl(ept(5)),pptl(5,nptl)  !!!
6165
6166         !..........remnant update
6167         if(gdrop)then  !drop emission: new remnant -> ept, icf
6168           idrop=0
6169           do l=1,5
6170             ept(l)=aa(l)
6171           enddo
6172           call iddeco(icf,jcf)
6173           call idquacjc(jcf,nqu,naq)
6174           if(iret.eq.1)call utstop('Pb in ProRef in strg+drop process&')
6175           !!!  print*,'new remnant:',icf,ept(5)    !!!
6176           nptl=nptl+1
6177           t=xorptl(4,mm)
6178           ifrptl(2,mm)=nptl
6179           do l=1,5
6180             pptl(l,nptl)=sngl(ept(l))
6181           enddo
6182           idptl(nptl)=idptl(mm)
6183           istptl(nptl)=40
6184           iorptl(nptl)=mm
6185           jorptl(nptl)=0
6186           ifrptl(1,nptl)=0
6187           ifrptl(2,nptl)=0
6188           xorptl(1,nptl)=xorptl(1,mm)
6189           xorptl(2,nptl)=xorptl(2,mm)
6190           xorptl(3,nptl)=xorptl(3,mm)
6191           xorptl(4,nptl)=t
6192           tivptl(1,nptl)=t
6193           tivptl(2,nptl)=ainfin
6194           if(gproj)then
6195             ityptl(nptl)=40
6196           else   !gtarg
6197             ityptl(nptl)=50
6198           endif
6199           do l=1,4
6200             ibptl(l,nptl)=0
6201           enddo
6202         endif
6203
6204         !........decay mini-droplet......
6205         mm=nptlini+1
6206         nptlb=nptl
6207         if(iabs(idptl(mm)).gt.10**8)then
6208
6209           iret=0
6210           if(iorsdf.ne.3.or.pptl(5,mm).gt.100.
6211      &       .or.amasini.le.amasmin*flow)then      !decay here only if no fusion or large mass or mass too low for flow
6212
6213           if(ish.ge.3)write(ifch,*)'Decay remnant droplet...'
6214           if(nptlb.gt.mxptl-10)call utstop('ProRef: mxptl too small&')
6215
6216           if(ifrade.gt.0.and.ispherio.eq.0)then
6217             if(ioclude.eq.3.or.dble(pptl(5,mm)).lt.xmdrmin)then
6218               call hnbaaa(mm,iret)
6219             else
6220               call DropletDecay(mm,iret)!Decay remn
6221               iret=0
6222             endif
6223           endif
6224           if(iret.ne.1.and.nptl.ne.nptlb)then ! ---successful decay---
6225             istptl(mm)=istptl(mm)+1
6226             ifrptl(1,mm)=nptlb+1
6227             ifrptl(2,mm)=nptl
6228             t=tivptl(2,mm)
6229             x=xorptl(1,mm)+(t-xorptl(4,mm))*pptl(1,mm)/pptl(4,mm)
6230             y=xorptl(2,mm)+(t-xorptl(4,mm))*pptl(2,mm)/pptl(4,mm)
6231             z=xorptl(3,mm)+(t-xorptl(4,mm))*pptl(3,mm)/pptl(4,mm)
6232             do 21 n=nptlb+1,nptl
6233               iorptl(n)=mm
6234               jorptl(n)=0
6235               istptl(n)=0
6236               ifrptl(1,n)=0
6237               ifrptl(2,n)=0
6238               radius=0.8*sqrt(rangen())
6239               phi=2*pi*rangen()
6240               ti=t
6241               zi=z
6242               xorptl(1,n)=x + radius*cos(phi)
6243               xorptl(2,n)=y + radius*sin(phi)
6244               xorptl(3,n)=zi
6245               xorptl(4,n)=ti
6246               iioo=mm
6247               zor=dble(xorptl(3,iioo))
6248               tor=dble(xorptl(4,iioo))
6249 c              call idquac(iioo,nq,ndummy1,ndummy2,jcdummy)
6250               r=rangen()
6251               tauran=-taurea*alog(r)
6252               call jtaix(n,tauran,zor,tor,zis,tis)
6253               tivptl(1,n)=amax1(ti,tis)
6254               call idtau(idptl(n),pptl(4,n),pptl(5,n),taugm)
6255               r=rangen()
6256               tivptl(2,n)=t+taugm*(-alog(r))
6257               ityptl(n)=ityptl(n)+1
6258               if(iept.eq.6)ityptl(n)=ityptl(n)+6
6259               radptl(n)=0.
6260               dezptl(n)=0.
6261               itsptl(n)=0
6262               rinptl(nptl)=-9999
6263    21       continue
6264             if(iabs(idptl(nptlb+1)).le.6) then
6265               call gakli2(0,0)
6266               if(ish.ge.1)write (ifmt,*)'string from drop:nptlb+1,nptl:'
6267      *                                 ,nptlb+1,nptl
6268               istptl(nptlb+1)=1
6269               do n=nptlb+2,nptl
6270                 istptl(n)=20
6271                 zpaptl(1,n)=0.
6272                 zpaptl(2,n)=0.
6273               enddo
6274               call gakfra(0,iret)
6275               call gakli2(0,0)
6276             endif
6277             jerr(4)=jerr(4)+1
6278           elseif(ifrade.gt.0.and.ispherio.eq.0)then ! Unsuccessful decay
6279             jerr(5)=jerr(5)+1
6280             if(ish.ge.4)write(ifch,*)
6281      *         '***** Unsuccessful remnant cluster decay'
6282      *             ,' --> do RemoveHadrons instead.'
6283             mm=mmini
6284             nptl=nptlini
6285             irmdropx=0
6286             goto 55
6287           endif
6288
6289           endif
6290         endif
6291
6292         if(idrop.eq.1)goto 1000
6293         !successful drop decay, no additional string, nothing to do
6294
6295       endif
6296
6297 c...............................................................
6298
6299  500  mm=mmini
6300       if(gdrop)mm=nptlini+2
6301       istptl(mm)=41
6302       ifrptl(1,mm)=nptl+1
6303
6304 c........................remove hadrons.........................
6305
6306       if(.not.((nqu.eq.3.and.naq.eq.0).or.(nqu.eq.0.and.naq.eq.3)
6307      &          .or.(nqu.eq.1.and.naq.eq.1)))then
6308         if(irmdropx.eq.irmdrop)then
6309           jerr(6)=jerr(6)+1
6310              !call utmsg('ProReF')
6311              !write(ifch,*)'***** condition for droplet treatment: '
6312              !write(ifch,*)'*****  amasini.gt.amasmin.and.irmdropx.eq.1 = '
6313              !*           ,amasini.gt.amasmin.and.irmdropx.eq.1
6314              !write(ifch,*)'***** amasini,amasmin,irmdropx:'
6315              !*                 ,amasini,amasmin,irmdropx
6316              !write(ifch,*)'***** nqu,naq:',nqu,naq
6317              !write(ifch,*)'***** call RemoveHadrons'
6318              !call utmsgf
6319         endif
6320        call RemoveHadrons(gproj,ghadr,m,mm,jcf,jcval,icf,ept,iret)
6321        if(iret.ne.0)then
6322          iretxx=1
6323          goto 1000
6324        endif
6325       endif
6326
6327 c........................ determine idr (0=string, else=resonance).......
6328
6329       if(icf(1).eq.0.and.icf(2).eq.0)then
6330         id=110
6331       else
6332         if(iLHC.eq.1)then
6333           id=idtra(icf,0,0,0)
6334         else
6335           id=idtra(icf,0,0,3)
6336         endif
6337       endif
6338       idr=0
6339       am=sngl(ept(5))
6340       call idres(id,am,idr,iadj)
6341 c      if(iabs(mod(idr,10)).le.2.and.idr.ne.0)then
6342 c       id=idr
6343 c      else
6344 c       idr=0
6345 c      endif                                !ckeck on-shell mass (see uti)
6346       if(iadj.ne.0.and.iept.gt.0.and.ept(5).gt.0.d0
6347      &     .and.(dabs((ept(4)+ept(3))*(ept(4)-ept(3))
6348      $           -ept(2)**2-ept(1)**2-dble(am)**2).gt.0.3d0))idr=0
6349
6350       if(ish.ge.3)then
6351         write(ifch,'(a,5e11.3)')' updt:',(sngl(ept(k)) ,k=1,5)
6352         write(ifch,*)'            icf: ',icf,' idr: ',idr,' iept: ',iept
6353       endif
6354
6355 c      if(iept.eq.3)stop'ProReF: iept=3 ???'
6356
6357 c...........................................string...................
6358       if(iept.gt.0.and.iept.ne.6.and.idr.eq.0)then
6359
6360         !... nqu of remainder string
6361
6362         anstrg0=anstrg0+1
6363         if(gdrop)anstrg1=anstrg1+1
6364
6365         call iddeco(icf,jcf)
6366         nqu=0
6367         nqv=0
6368         nav=0
6369         do l=1,nrflav
6370           nqu=nqu+jcf(l,1)-jcf(l,2)
6371           nqv=nqv+jcval(l,1)+jcval(l,2)
6372           nav=nav+jcval(l,2)
6373         enddo
6374
6375 c        if(zrminc.lt.0.)stop'ProReF: not supported any more.         '
6376
6377         !......determine forward momentum ep
6378
6379
6380         am1=0.
6381         am2=0.
6382         ptt1=0d0
6383         ptt2=0d0
6384         if(iLHC.eq.1)then
6385           pt=ranptcut(1.)*ptfraqq
6386           if(pt.lt.0.5d0*ept(5))then
6387             phi=2.*pi*rangen()
6388             ptt1=dble(pt*cos(phi))
6389             ptt2=dble(pt*sin(phi))
6390           endif
6391           ptt3=dble(ir)*sqrt((0.5d0*ept(5))**2-ptt1*ptt1-ptt2*ptt2)
6392         else
6393           ptt3=dble(ir)*0.5d0*ept(5)
6394         endif
6395
6396         ep(1)=ptt1
6397         ep(2)=ptt2
6398         ep(3)=ptt3
6399 cc        ep(4)=0.5d0*ept(5)
6400         ep(4)=sqrt(ptt3*ptt3+ptt2*ptt2+ptt1*ptt1+dble(am1*am1))
6401
6402 c        if(abs(ept(3)).le.ptsend)then
6403 c          phi=2.*pi*rangen()
6404 c          theta=2.*pi*rangen()
6405 c          ca=cos(theta)
6406 c          sa=sin(theta)
6407 c          call utroa2(dble(phi),dble(ca),dble(sa),0d0,ep(1),ep(2),ep(3))
6408 c        endif
6409         call utlob2(-1,ept(1),ept(2),ept(3),ept(4),ept(5)
6410      *     ,ep(1),ep(2),ep(3),ep(4),25)
6411
6412
6413         xxx=min(1.,sngl(abs(ep(3)/ep(4))))
6414         qqs=sngl(ept(5)**2)
6415
6416         !....determine forward and backward flavor icf, icb
6417
6418         if(iremn.ge.2)then
6419           xm3val=9.
6420           xm2val=3.
6421           xm1val=1.
6422           ntryx=0
6423  33       xx1=0.
6424           xx2=0.
6425           xx3=0.
6426           del=1./(1.-alppar)
6427           if(nqv.eq.3)then
6428             xx1=min(1.,ranptcut(xm3val))
6429             xx2=min(1.,ranptcut(xm3val))
6430             xx3=min(1.,ranptcut(xm3val))
6431           elseif(nqv.eq.2)then
6432             xx1=min(1.,ranptcut(xm2val))
6433             xx2=min(1.,ranptcut(xm2val))
6434             xx3=rangen()**del
6435           elseif(nqv.eq.1)then
6436             xx1=min(1.,ranptcut(xm1val))
6437             xx2=rangen()**del
6438             xx3=rangen()**del
6439           else
6440             xx1=rangen()**del
6441             xx2=rangen()**del
6442             xx3=rangen()**del
6443           endif
6444           if(ntryx.lt.1000)then
6445             if(xx1+xx2+xx3.gt.1)goto 33
6446           else
6447             xx1=rangen()
6448             xx2=rangen()*(1.-xx1)
6449             xx3=rangen()*(1.-xx1-xx2)
6450           endif
6451           xx1=xxx*xx1
6452           xx2=xxx*xx2
6453           xx3=xxx*xx3
6454           piq1=0d0
6455           piq2=0d0
6456           piq3=0d0
6457           if(iept.eq.4)then
6458             ireminv=0       !no inversion for very low mass diffraction
6459           else
6460 c inversion needed for inelatic remnant because of cascade (NA49)
6461             ireminv=1
6462           endif
6463        if(nqu.eq.3)then      !---baryon---
6464           c="s"
6465           if(nqv.ge.1)c="v"
6466           iq1=idraflx(piq1,xx1,qqs,iclpt,jcf,jcval,1,isopt,c)
6467           c="s"
6468           if(nqv.ge.2)c="v"
6469           iq2=idraflx(piq2,xx2,qqs,iclpt,jcf,jcval,1,isopt,c)
6470           c="s"
6471           if(nqv.ge.3)c="v"
6472           iq3=idraflx(piq3,xx3,qqs,iclpt,jcf,jcval,1,isopt,c)
6473 c rescale x to have heavier quark backward (neutron in ZEUS or lambda in NA49 not forward)
6474 c          if(iept.eq.2)then
6475 c            if(isopt.gt.0)then
6476 c              xx1=xx1/float(iq1)
6477 c              xx2=xx2/float(iq2)
6478 c              xx3=xx3/float(iq3)
6479 c            elseif(isopt.lt.0)then
6480 c              if(iq1.lt.3)then
6481 c                xx1=xx1/float(3-iq1)
6482 c              else
6483 c                xx1=xx1/float(iq1)
6484 c              endif
6485 c              if(iq2.lt.3)then
6486 c                xx2=xx2/float(3-iq2)
6487 c              else
6488 c                xx2=xx2/float(iq2)
6489 c              endif
6490 c              if(iq3.lt.3)then
6491 c                xx3=xx3/float(3-iq3)
6492 c              else
6493 c                xx3=xx3/float(iq3)
6494 c              endif
6495 c            endif
6496 c          endif
6497           call neworderx(xx3,xx2,xx1,iq3,iq2,iq1)
6498           if(xx2-xx3.gt.reminv*(xx1-xx2))ireminv=0
6499 c put always strange quarks in diquark (for lambda and cascade (NA49))
6500           if(iq3.ge.3.and.ireminv.eq.0)ireminv=1 !here inversion only in diffraction except for strange particles (lambda and cascade very central)
6501 c if inversion for diffractive and inelastic
6502 c          if(iq1+iq2.lt.6.and.iq3.ge.3.and.ireminv.eq.0)then
6503 c            iqtmp=iq3
6504 c            if(iq2.eq.3.or.(iq1.ne.3.and.rangen().gt.0.5))then
6505 c              iq3=iq1
6506 c              iq1=iqtmp
6507 c            else
6508 c              iq3=iq2
6509 c              iq2=iqtmp
6510 c            endif
6511 c          endif
6512           if(ireminv.eq.0)then
6513             call uticpl(icf,iq3,2,iret) ! antiquark
6514             call uticpl(icb,iq3,1,iret) ! quark
6515           else
6516             call uticpl(icf,iq3,2,iret) ! antiquark
6517             call uticpl(icb,iq3,1,iret) ! quark
6518             call uticpl(icf,iq2,2,iret) ! antiquark
6519             call uticpl(icb,iq2,1,iret) ! quark
6520           endif
6521         elseif(nqu.eq.-3)then !---antibaryon---
6522           c="s"
6523           if(nqv.ge.1)c="v"
6524           iq1=idraflx(piq1,xx1,qqs,iclpt,jcf,jcval,2,isopt,c)
6525           c="s"
6526           if(nqv.ge.2)c="v"
6527           iq2=idraflx(piq2,xx2,qqs,iclpt,jcf,jcval,2,isopt,c)
6528           c="s"
6529           if(nqv.ge.3)c="v"
6530           iq3=idraflx(piq3,xx3,qqs,iclpt,jcf,jcval,2,isopt,c)
6531 c rescale x to have heavier quark backward (neutron in ZEUS or lambda in NA49 not forward)
6532 c          if(iept.eq.2)then
6533 c            if(isopt.gt.0)then
6534 c              xx1=xx1/float(iq1)
6535 c              xx2=xx2/float(iq2)
6536 c              xx3=xx3/float(iq3)
6537 c            elseif(isopt.lt.0)then
6538 c              if(iq1.lt.3)then
6539 c                xx1=xx1/float(3-iq1)
6540 c              else
6541 c                xx1=xx1/float(iq1)
6542 c              endif
6543 c              if(iq2.lt.3)then
6544 c                xx2=xx2/float(3-iq2)
6545 c              else
6546 c                xx2=xx2/float(iq2)
6547 c              endif
6548 c              if(iq3.lt.3)then
6549 c                xx3=xx3/float(3-iq3)
6550 c              else
6551 c                xx3=xx3/float(iq3)
6552 c              endif
6553 c            endif
6554 c          endif
6555           call neworderx(xx3,xx2,xx1,iq3,iq2,iq1)
6556           if(xx2-xx3.gt.reminv*(xx1-xx2))ireminv=0
6557 c put always strange quarks in diquark
6558           if(iq3.ge.3.and.ireminv.eq.0)ireminv=1
6559 c          if(iq1+iq2.lt.6.and.iq3.ge.3.and.ireminv.eq.0)then
6560 c            iqtmp=iq3
6561 c            if(iq2.eq.3.or.(iq1.ne.3.and.rangen().gt.0.5))then
6562 c              iq3=iq1
6563 c              iq1=iqtmp
6564 c            else
6565 c              iq3=iq2
6566 c              iq2=iqtmp
6567 c            endif
6568 c          endif
6569           if(ireminv.eq.0)then
6570             call uticpl(icf,iq3,1,iret) ! quark
6571             call uticpl(icb,iq3,2,iret) ! antiquark
6572           else
6573             call uticpl(icf,iq1,1,iret) ! quark
6574             call uticpl(icb,iq1,2,iret) ! antiquark
6575             call uticpl(icf,iq2,1,iret) ! quark
6576             call uticpl(icb,iq2,2,iret) ! antiquark
6577           endif
6578         elseif(nqu.eq.0)then !---meson---
6579           xx3=0.    !no third quark
6580           iq3=0
6581           if(nqv.eq.2)then
6582             c1="v"
6583             c2="v"
6584             j=min(2,1+int(0.5+rangen()))
6585           elseif(nav.ne.0)then    !valence antiquark
6586             c1="v"
6587             c2="s"
6588             j=2
6589           elseif(nqv.ne.0)then    !valence quark
6590             c1="v"
6591             c2="s"
6592             j=1
6593           else                    !only sea quarks
6594             c1="s"
6595             c2="s"
6596             j=min(2,1+int(0.5+rangen()))
6597           endif
6598           iq1=idraflx(piq1,xx1,qqs,iclpt,jcf,jcval,j,isopt,c1)
6599           iq2=idraflx(piq2,xx2,qqs,iclpt,jcf,jcval,3-j,isopt,c2)
6600           if(xx1.gt.xx2)ireminv=0
6601          if(ireminv.eq.1)then
6602             call uticpl(icf,iq1,3-j,iret) ! subtract quark 1 forward
6603             call uticpl(icb,iq1,j,iret) ! add quark 1 backward
6604           else
6605             call uticpl(icf,iq2,j,iret) ! subtract antiquark 2 forward
6606             call uticpl(icb,iq2,3-j,iret) ! add antiquark 2 backward
6607           endif
6608         else
6609           call utmsg('ProReF')
6610           write(ifch,*)'***** neither baryon nor antibaryon nor meson.'
6611           write(ifch,*)'*****  number of net quarks:',nqu
6612           write(ifmt,*)'ProReF: no hadron; ',nqu,' quarks  --> redo'
6613           iretxx=1
6614           goto 1000
6615         endif
6616         if(ish.ge.3)write(ifch,'(a,2i3,3(i2,e13.6))')' inversion:',isopt
6617      &         ,ireminv,iq1,xx1,iq2,xx2,iq3,xx3
6618         else
6619         ireminv=0
6620         if(iept.ne.0)then
6621           if(rangen().lt.reminv)ireminv=1
6622         endif
6623         if(nqu.eq.3)then      !---baryon---
6624           iq=idrafl(iclpt,jcf,1,'v',1,iret)
6625           call uticpl(icf,iq,2,iret)       ! antiquark
6626           call uticpl(icb,iq,1,iret)       ! quark
6627           if(ireminv.eq.1)then
6628            iq=idrafl(iclpt,jcf,1,'v',1,iret)
6629            call uticpl(icf,iq,2,iret)       ! antiquark
6630            call uticpl(icb,iq,1,iret)       ! quark
6631           endif
6632         elseif(nqu.eq.-3)then !---antibaryon---
6633           iq=idrafl(iclpt,jcf,2,'v',1,iret)
6634           call uticpl(icf,iq,1,iret)       ! quark
6635           call uticpl(icb,iq,2,iret)       ! antiquark
6636           if(ireminv.eq.1)then
6637            iq=idrafl(iclpt,jcf,2,'v',1,iret)
6638            call uticpl(icf,iq,1,iret)       ! quark
6639            call uticpl(icb,iq,2,iret)       ! antiquark
6640           endif
6641         elseif(nqu.eq.0)then !---meson---
6642            iq1=idrafl(iclpt,jcf,1,'v',1,iret)
6643            iq2=idrafl(iclpt,jcf,2,'v',1,iret)
6644            if(rangen().gt.0.5)then
6645              call uticpl(icf,iq1,2,iret) ! subtract quark
6646              call uticpl(icb,iq1,1,iret) ! add quark
6647            else
6648              call uticpl(icf,iq2,1,iret) ! subtract antiquark
6649              call uticpl(icb,iq2,2,iret) ! add antiquark
6650            endif
6651 c        elseif(nqu.eq.0)then !---meson---
6652 c          if(iept.ne.1.and.iept.ne.6.and.rangen().lt.0.5)then
6653 c           iq=idrafl(iclpt,jcf,1,'v',1,iret)
6654 c           call uticpl(icf,iq,2,iret)       ! subtract quark
6655 c           call uticpl(icb,iq,1,iret)       ! add quark
6656 c          else
6657 cc put quark in forward direction always for inelastic
6658 c           iq=idrafl(iclpt,jcf,2,'v',1,iret)
6659 c           call uticpl(icf,iq,1,iret)       ! subtract antiquark
6660 c           call uticpl(icb,iq,2,iret)       ! add antiquark
6661 c          endif
6662         else
6663           if(ish.ge.1)then
6664           call utmsg('ProReF')
6665           write(ifch,*)'***** neither baryon nor antibaryon nor meson.'
6666           write(ifch,*)'*****  number of net quarks:',nqu
6667           endif
6668           write(ifmt,*)'ProReF: no hadron; ',nqu,' quarks  --> redo'
6669           iretxx=1
6670           goto1000
6671         endif
6672       endif
6673
6674
6675         !..... forward string end
6676
6677         nptl=nptl+1
6678         if(nptl.gt.mxptl)call utstop('ProRef: mxptl too small&')
6679         pptl(1,nptl)=sngl(ep(1))
6680         pptl(2,nptl)=sngl(ep(2))
6681         pptl(3,nptl)=sngl(ep(3))
6682         pptl(4,nptl)=sngl(ep(4))
6683         pptl(5,nptl)=am1 !0.
6684         istptl(nptl)=20
6685         iorptl(nptl)=mm
6686         if(.not.gdrop)istptl(mm)=41
6687         jorptl(nptl)=0
6688         if(.not.ghadr.and..not.gdrop)ifrptl(1,mm)=nptl
6689         ifrptl(2,mm)=nptl
6690         xorptl(1,nptl)=xorptl(1,mm)
6691         xorptl(2,nptl)=xorptl(2,mm)
6692         xorptl(3,nptl)=xorptl(3,mm)
6693         xorptl(4,nptl)=xorptl(4,mm)
6694         tivptl(1,nptl)=xorptl(4,nptl)
6695         tivptl(2,nptl)=xorptl(4,nptl)
6696         if(iLHC.eq.1)then
6697           idptl(nptl)=idtra(icf,0,0,0)
6698         else
6699           idptl(nptl)=idtra(icf,0,0,3)
6700         endif
6701         if(gproj)then
6702           if(iep(m).lt.1)stop'ProReF: iep(m)<1     '
6703           ityptl(nptl)=41+iep(m)  ! =42 =43 =44 =46 =47
6704           if(iep(m).eq.4)ityptl(nptl)=42
6705           if(gdrop.and.iep(m).ne.6)ityptl(nptl)=44
6706           if(ghadr)ityptl(nptl)=44
6707         else  !gtarg
6708           if(iet(m).lt.1)stop'ProReF: iet(m)<1     '
6709           ityptl(nptl)=51+iet(m)  !=52 =53 =54 =56 =57
6710           if(iet(m).eq.4)ityptl(nptl)=52
6711           if(gdrop.and.iet(m).ne.6)ityptl(nptl)=54
6712           if(ghadr)ityptl(nptl)=54
6713         endif
6714         itsptl(nptl)=1
6715         qsqptl(nptl)=qqs
6716         rinptl(nptl)=-9999
6717         !write(6,'(a,i9,$)')'     ',idptl(nptl) !======================
6718         zpaptl(1,nptl)=zz
6719         if(gproj)then
6720           zpaptl(2,nptl)=float(lproj(m))
6721 c          zpaptl(2,nptl)=0.
6722 c          if(lproj(m).ge.1)then
6723 c            do l=1,lproj(m)
6724 c              kpair=kproj(m,l)
6725 c              itt=itarg(kpair)
6726 c              zpaptl(2,nptl)=zpaptl(2,nptl)+zzremn(itt,2)
6727 c            enddo
6728 c          endif
6729         else  !gtarg
6730           zpaptl(2,nptl)=float(ltarg(m))
6731 c          zpaptl(2,nptl)=0.
6732 c          if(ltarg(m).ge.1)then
6733 c            do l=1,ltarg(m)
6734 c              kpair=ktarg(m,l)
6735 c              ipp=iproj(kpair)
6736 c              zpaptl(2,nptl)=zpaptl(2,nptl)+zzremn(ipp,1)
6737 c            enddo
6738 c          endif
6739         endif
6740         if(ish.ge.3)then
6741           write(ifch,'(a,5e11.3,$)')' kink:',(pptl(k,nptl),k=1,5)
6742           write(ifch,*)' id: ',idptl(nptl)
6743         endif
6744         !....... backward string end
6745
6746         nptl=nptl+1
6747         if(nptl.gt.mxptl)call utstop('ProRef: mxptl too small&')
6748         pptl2=0.
6749         do i=1,3
6750          pptl(i,nptl)=sngl(ept(i)-ep(i))
6751          pptl2=pptl2+pptl(i,nptl)*pptl(i,nptl)
6752         enddo
6753         pptl(5,nptl)=am2 !0.
6754         pptl2=pptl2+pptl(5,nptl)*pptl(5,nptl)
6755         pptl(4,nptl)=sqrt(pptl2)
6756         pptl2=sngl(ept(4)-ep(4))
6757         if(ish.ge.1.and.abs(pptl2-pptl(4,nptl)).gt.max(0.1,
6758      &                                         0.1*abs(pptl2)))then
6759           write(ifmt,*)
6760      &    'Warning in ProRef: inconsistent backward string end energy !'
6761      &    ,pptl(4,nptl),pptl2,abs(pptl2-pptl(4,nptl)),am1,am2,ptt3,ep(4)
6762           if(ish.ge.2)write(ifch,*)
6763      &    'Warning in ProRef: inconsistent backward string end energy !'
6764      &    ,(pptl(kkk,nptl),kkk=1,4),pptl2,abs(pptl2-pptl(4,nptl))
6765         endif
6766         istptl(nptl)=20
6767         iorptl(nptl)=mm
6768         jorptl(nptl)=0
6769         ifrptl(2,mm)=nptl
6770         ifrptl(1,nptl)=0
6771         ifrptl(2,nptl)=0
6772         xorptl(1,nptl)=xorptl(1,mm)
6773         xorptl(2,nptl)=xorptl(2,mm)
6774         xorptl(3,nptl)=xorptl(3,mm)
6775         xorptl(4,nptl)=xorptl(4,mm)
6776         tivptl(1,nptl)=xorptl(4,nptl)
6777         tivptl(2,nptl)=xorptl(4,nptl)
6778         if(iLHC.eq.1)then
6779           idptl(nptl)=idtra(icb,0,0,0)
6780         else
6781           idptl(nptl)=idtra(icb,0,0,3)
6782         endif
6783         if(gproj)then
6784           ityptl(nptl)=41+iep(m)  ! =42 =43 =47
6785           if(iep(m).eq.4)ityptl(nptl)=42
6786           if(gdrop.and.iep(m).ne.6)ityptl(nptl)=44
6787           if(ghadr)ityptl(nptl)=44
6788         else  !gtarg
6789           ityptl(nptl)=51+iet(m)  !=52 =53 =57
6790           if(iet(m).eq.4)ityptl(nptl)=52
6791           if(gdrop.and.iet(m).ne.6)ityptl(nptl)=54
6792           if(ghadr)ityptl(nptl)=54
6793         endif
6794         itsptl(nptl)=1
6795         qsqptl(nptl)=qqs
6796         rinptl(nptl)=-9999
6797         !write(6,'(a,i9)')'     ',idptl(nptl)
6798         zpaptl(1,nptl)=0.
6799         zpaptl(2,nptl)=1.
6800         if(ish.ge.3)then
6801           write(ifch,'(a,5e11.3,$)')' kink:',(pptl(k,nptl),k=1,5)
6802           write(ifch,*)' id: ',idptl(nptl)
6803         endif
6804
6805 c............................no string = resonance...................
6806       else
6807
6808         anreso0=anreso0+1
6809         if(gdrop)anreso1=anreso1+1
6810
6811         nptl=nptl+1
6812         if(idr.ne.0)id=idr
6813         if(nptl.gt.mxptl)call utstop('ProRef: mxptl too small&')
6814         if(iept.eq.0.or.iept.eq.6)call idmass(id,am)
6815         idptl(nptl)=id
6816         pptl(1,nptl)=sngl(ept(1))
6817         pptl(2,nptl)=sngl(ept(2))
6818         am2t=sqrt(ept(2)*ept(2)+ept(1)*ept(1)+dble(am*am))
6819         if(iLHC.eq.1.and.ept(4).gt.am2t)then   !conserve value of E on not pz
6820           pptl(4,nptl)=sngl(ept(4))
6821           pptl(3,nptl)=sngl(sign(sqrt((ept(4)+am2t)*(ept(4)-am2t))
6822      &                          ,ept(3)))
6823         else
6824           pptl(3,nptl)=sngl(ept(3))
6825           pptl(4,nptl)=sngl(sqrt(ept(3)*ept(3)+am2t))
6826         endif
6827         pptl(5,nptl)=am
6828         istptl(nptl)=0
6829         iorptl(nptl)=mm
6830         if(.not.gdrop)istptl(mm)=41
6831         jorptl(nptl)=0
6832         if(.not.ghadr.and..not.gdrop)ifrptl(1,mm)=nptl
6833         ifrptl(2,mm)=nptl
6834         ifrptl(1,nptl)=0
6835         ifrptl(2,nptl)=0
6836         xorptl(1,nptl)=xorptl(1,mm)
6837         xorptl(2,nptl)=xorptl(2,mm)
6838         xorptl(3,nptl)=xorptl(3,mm)
6839         xorptl(4,nptl)=xorptl(4,mm)
6840         tivptl(1,nptl)=xorptl(4,nptl)
6841         call idtau(idptl(nptl),pptl(4,nptl),pptl(5,nptl),taugm)
6842         tivptl(2,nptl)=tivptl(1,nptl)+taugm*(-alog(rangen()))
6843         if(gproj)then
6844           ityptl(nptl)=45
6845           if(gdrop)then
6846             ityptl(nptl)=46
6847           elseif(iept.eq.6)then
6848             ityptl(nptl)=47
6849           elseif(iept.eq.2.or.iept.eq.4)then
6850 c          elseif(iept.eq.2)then
6851             ityptl(nptl)=48
6852           elseif(ghadr)then
6853             ityptl(nptl)=49
6854           else
6855             mine=0
6856             mdif=0
6857             do l=1,lproj(m)
6858               kp=kproj(m,l)
6859               if(abs(itpr(kp)).eq.1)mine=1
6860               if(itpr(kp).eq.2)mdif=1
6861             enddo
6862             if(mine.eq.0.and.mdif.eq.1)ityptl(nptl)=48
6863           endif
6864         else   !gtarg
6865           ityptl(nptl)=55
6866           if(gdrop)then
6867             ityptl(nptl)=56
6868           elseif(iept.eq.6)then
6869             ityptl(nptl)=57
6870           elseif(iept.eq.2.or.iept.eq.4)then
6871 c          elseif(iept.eq.2)then
6872             ityptl(nptl)=58
6873           elseif(ghadr)then
6874             ityptl(nptl)=59
6875           else
6876             mine=0
6877             mdif=0
6878             do l=1,lproj(m)
6879               kp=kproj(m,l)
6880               if(abs(itpr(kp)).eq.1)mine=1
6881               if(itpr(kp).eq.2)mdif=1
6882             enddo
6883             if(mine.eq.0.and.mdif.eq.1)ityptl(nptl)=58
6884           endif
6885         endif
6886         itsptl(nptl)=0
6887         qsqptl(nptl)=0.
6888         rinptl(nptl)=-9999
6889
6890         if(ish.ge.3)write(ifch,'(a,5e10.3,i7)')' nucl:'
6891      *         ,(pptl(i,nptl),i=1,5),idptl(nptl)
6892
6893       endif
6894 c.......................................................................
6895 c      print *,iep(1),iet(1),ityptl(nptl)
6896  1000 call utprix('ProReF',ish,ishini,3)
6897 ctp060829        if(ityptl(nptl).gt.60)print*,ityptl(nptl)
6898       return
6899
6900       end
6901
6902 c-----------------------------------------------------------------------
6903       subroutine RemoveHadrons(gproj,ghadr,m,mm,jcf,jcv
6904      &                        ,icf,ept,iret)
6905 c-----------------------------------------------------------------------
6906       include 'epos.inc'
6907       include 'epos.incems'
6908       integer jcf(nflav,2),jcv(nflav,2),icf(2)
6909       double precision aa(5),ept(5)
6910       logical ghadr,gproj
6911       common/ems6/ivp0,iap0,idp0,isp0,ivt0,iat0,idt0,ist0
6912       common /cncl/xproj(mamx),yproj(mamx),zproj(mamx)
6913      *            ,xtarg(mamx),ytarg(mamx),ztarg(mamx)
6914
6915       iret=0
6916
6917       if(iremn.ge.2)then
6918         if(gproj)then
6919           idrf=idp(m)
6920         else
6921           idrf=idt(m)
6922         endif
6923       else
6924         if(gproj)then
6925           idrf=idp0
6926         else
6927           idrf=idt0
6928         endif
6929       endif
6930       call idquacjc(jcf,nqu,naq)
6931       if(nqu.eq.naq.and.(nqu.le.2.or.idrf.eq.0))then
6932         nmes=nqu
6933         nmes=nmes-1             !string is aq-q
6934         nbar=0
6935       elseif(nqu.gt.naq)then
6936         nmes=naq
6937         nbar=(nqu-nmes)/3     !nbar baryons
6938         if(nmes.eq.0.or.idrf.eq.1)then
6939           nbar=nbar-1        !string is qq-q
6940         else
6941           nmes=nmes-1        !string is aq-q
6942         endif
6943       elseif(nqu.lt.naq)then
6944         nmes=nqu
6945         nbar=(naq-nmes)/3    !nbar antibaryons
6946         if(nmes.eq.0.or.idrf.eq.1)then
6947           nbar=nbar-1        !string is aqaq-aq
6948         else
6949           nmes=nmes-1        !string is aq-q
6950         endif
6951       else
6952         nbar=nqu/3
6953         nmes=nqu-3*nbar
6954         nbar=nbar+naq/3
6955         nbar=nbar-1             !string is qq-q or aqaq-aq
6956       endif
6957       if(ish.ge.5)
6958      &       write(ifch,*)'RemoveHadron part (nq,na,nb,nm,dq):'
6959      &                     ,nqu,naq,nbar,nmes,idrf
6960       if(nmes+nbar.gt.0)ghadr=.true.
6961 c  remove mesons
6962        if(nmes.gt.0)then
6963           do mes=1,nmes
6964             !write(ifch,*)'remove meson',mes,' / ',nmes
6965             call gethadron(1,idd,aa,jcf,jcv,ept,gproj,iret)
6966             if(iret.ne.0)goto 1000
6967               nptl=nptl+1
6968               if(nptl.gt.mxptl)
6969      &             call utstop('RemoveHadrons: mxptl too small&')
6970               idptl(nptl)=idd
6971               do i=1,5
6972                 pptl(i,nptl)=sngl(aa(i))
6973               enddo
6974               iorptl(nptl)=mm
6975               jorptl(nptl)=0
6976               if(mes.eq.1)then
6977                 ifrptl(1,mm)=nptl
6978                 ifrptl(2,mm)=nptl
6979               else
6980                 ifrptl(2,mm)=nptl
6981               endif
6982               ifrptl(1,nptl)=0
6983               ifrptl(2,nptl)=0
6984               istptl(nptl)=0
6985               if(gproj)then
6986                 ityptl(nptl)=49
6987                 xorptl(1,nptl)=xproj(m)
6988                 xorptl(2,nptl)=yproj(m)
6989                 xorptl(3,nptl)=zproj(m)
6990               else   !gtarg
6991                 ityptl(nptl)=59
6992                 xorptl(1,nptl)=xtarg(m)
6993                 xorptl(2,nptl)=ytarg(m)
6994                 xorptl(3,nptl)=ztarg(m)
6995               endif
6996               xorptl(4,nptl)=xorptl(4,mm)
6997               tivptl(1,nptl)=xorptl(4,nptl)
6998               call idtau(idptl(nptl),pptl(4,nptl),pptl(5,nptl),taugm)
6999               tivptl(2,nptl)=tivptl(1,nptl)+taugm*(-alog(rangen()))
7000               qsqptl(nptl)=0.
7001 c           deleted: after abstracting a meson,
7002 c           check if the NEW remnant is a H-Dibaryon
7003           enddo
7004         endif
7005 c remove (anti)baryons
7006         call idquacjc(jcf,nqu,naq)
7007         if(nbar.gt.0)then
7008           do nb=1,nbar
7009             !write(ifch,*)'remove baryon',nb,' / ',nbar
7010             prq=float(nqu/3)
7011             pra=float(naq/3)
7012             psum=prq+pra
7013             if(psum.gt.0.)then
7014               if(rangen()*psum.le.prq)then      !baryon
7015                 call gethadron(2,idd,aa,jcf,jcv,ept,gproj,iret)
7016                 nqu=nqu-3
7017               else                              !antibaryon
7018                 call gethadron(3,idd,aa,jcf,jcv,ept,gproj,iret)
7019                 naq=naq-3
7020              endif
7021             else
7022               iret=1
7023             endif
7024             if(iret.ne.0)goto 1000
7025               nptl=nptl+1
7026               if(nptl.gt.mxptl)
7027      &             call utstop('RemoveHadron: mxptl too small&')
7028               idptl(nptl)=idd
7029               do i=1,5
7030                 pptl(i,nptl)=sngl(aa(i))
7031               enddo
7032               iorptl(nptl)=mm
7033               jorptl(nptl)=0
7034               if(nmes.eq.0.and.nb.eq.1)then
7035                 ifrptl(1,mm)=nptl
7036                 ifrptl(2,mm)=nptl
7037               else
7038                 ifrptl(2,mm)=nptl
7039               endif
7040               ifrptl(1,nptl)=0
7041               ifrptl(2,nptl)=0
7042               istptl(nptl)=0
7043               if(gproj)then
7044                 ityptl(nptl)=49
7045                 xorptl(1,nptl)=xproj(m)
7046                 xorptl(2,nptl)=yproj(m)
7047                 xorptl(3,nptl)=zproj(m)
7048               else    !gtarg
7049                 ityptl(nptl)=59
7050                 xorptl(1,nptl)=xtarg(m)
7051                 xorptl(2,nptl)=ytarg(m)
7052                 xorptl(3,nptl)=ztarg(m)
7053               endif
7054               xorptl(4,nptl)=xorptl(4,mm)
7055               tivptl(1,nptl)=xorptl(4,nptl)
7056               call idtau(idptl(nptl),pptl(4,nptl),pptl(5,nptl),taugm)
7057               tivptl(2,nptl)=tivptl(1,nptl)+taugm*(-alog(rangen()))
7058               qsqptl(nptl)=0.
7059 c             deleted: after abstracting a (anti)baryon,
7060 c                                  check if the NEW remnant is a H-Dibaryon
7061           enddo
7062         endif
7063         call idenco(jcf,icf,iret)
7064
7065  1000 return
7066       end
7067
7068 c------------------------------------------------------------------
7069          subroutine gethadron(imb,idf,a,jc,jcv,ep,gproj,iret)
7070 c------------------------------------------------------------------
7071 c       goal:  emit a hadron (imb= 1 meson, 2 baryon, 3 antibaryon)
7072 c              update the remnant flavor and 5-momentum
7073 c
7074 c       idf ,a : hadron id and 5-momentum
7075 c       gproj  : T  projectile, F  target remnant
7076 c       jc, ep : remnant flavor and 5-momentum
7077 c       iret   : in case of error, keep correct momentum in remnant
7078 c                and lose the quarks of the (not) emitted hadron
7079 c-----------------------------------------------------------------
7080
7081         include 'epos.inc'
7082         include 'epos.incems'
7083         common/cems5/plc,s
7084         double precision s,plc
7085         double precision ep(5),a(5),re(5),p1(5)
7086         integer jc(nflav,2),jcv(nflav,2),jcini(nflav,2),jcvini(nflav,2)
7087      &    ,ifh(3),ic(2)
7088         common /ems12/iodiba,bidiba  ! defaut iodiba=0. if iodiba=1, study H-Dibaryon
7089         double precision ptm,qcm,u(3),utpcmd,ptt,phi,sxini,sxini0,strmas
7090      &                  ,ampt2dro,ampt2str,p5sq,amasex,drangen,xmaxrm
7091         logical gproj
7092
7093         call utpri('gethad',ish,ishini,5)
7094
7095         iret=0
7096         do i=1,5
7097           a(i)=0.d0
7098           re(i)=ep(i)
7099         enddo
7100         ic(1)=0
7101         ic(2)=0
7102         do j=1,2
7103           do i=1,nflav
7104             jcini(i,j)=jc(i,j)
7105             jcvini(i,j)=jcv(i,j)
7106           enddo
7107         enddo
7108
7109         if(iremn.ge.2)then
7110           if(ish.ge.5)then
7111             write(ifch,*)'remnant flavor and 5-momentum:',jc
7112             write(ifch,*)'                              ',jcv
7113             write(ifch,*)'momentum :',ep,gproj,imb
7114           endif
7115           call idquacjc(jcvini,nqv,nav)
7116         else
7117           if(ish.ge.5)
7118      &       write(ifch,*)'remnant flavor and 5-momentum:',jc,ep,gproj
7119      &                                                          ,imb
7120           nqv=0
7121           nav=0
7122         endif
7123        !write(*,'(/a,5f8.3)')'p before: ',ep
7124
7125         if(gproj)then
7126           iclpt=iclpro
7127         else
7128           iclpt=icltar
7129         endif
7130
7131 c boost remnant in rest frame
7132          if(ish.ge.6) write (ifch,*) 'on-shell check'
7133          do k=1,5
7134            p1(k)=ep(k)
7135          enddo
7136          p1(5)=(p1(4)-p1(3))*(p1(4)+p1(3))-p1(2)**2-p1(1)**2
7137          if(p1(5).gt.0d0.and.abs(p1(5)-ep(5)*ep(5)).lt.ep(5))then
7138            p1(5)=sqrt(p1(5))
7139          else
7140            if(ish.ge.1)write(ifch,*)'Precision problem in gethad, p:',
7141      &          (p1(k),k=1,5),ep(5)*ep(5)
7142            p1(5)=0d0
7143         endif
7144
7145 c       initial limits
7146         mamos=4
7147         ptm=p1(5)
7148         sxini0=ptm*ptm
7149         idf=0
7150 c redo
7151
7152         nredo=0
7153  777    continue
7154         nredo=nredo+1
7155         if(nredo.gt.1)then       !restore initial flavors
7156           ic(1)=0
7157           ic(2)=0
7158           do j=1,2
7159             do i=1,nflav
7160               jc(i,j)=jcini(i,j)
7161               jcv(i,j)=jcvini(i,j)
7162             enddo
7163           enddo
7164           if(iremn.ge.2)then
7165             call idquacjc(jcvini,nqv,nav)
7166           endif
7167           if(ish.ge.7)write(ifch,*)'Restore flavor',idf,jc
7168           idf=0
7169           if(ptm.eq.0.or.nredo.gt.20)then
7170             if(ish.ge.4)write(ifch,*)
7171      &         'Pb with hadron momentum in Gethad !'
7172             iret=1
7173           endif
7174         endif
7175
7176 c  get the id and mass of hadron, the remnant jc is updated
7177         iret2=0
7178           if(imb.eq.1)then              ! a meson
7179             j=1
7180             if(nqv.gt.0)then
7181               i=idraflz(jcv,j)
7182               jc(i,j)=jc(i,j)-1
7183               nqv=nqv-1
7184             else
7185               i=idrafl(iclpt,jc,j,'v',1,iret2)
7186               if(iLHC.eq.1.and.iret2.ne.0)goto 77
7187             endif
7188             ifq=i
7189             j=2
7190             if(nav.gt.0)then
7191               i=idraflz(jcv,j)
7192               jc(i,j)=jc(i,j)-1
7193               nav=nav-1
7194             else
7195               i=idrafl(iclpt,jc,j,'v',1,iret2)
7196               if(iLHC.eq.1.and.iret2.ne.0)goto 77
7197             endif
7198             ifa=i
7199 c            write(ifch,*)'ici',ifq,ifa,jc,'| ',jcv
7200             ic(1)=10**(6-ifq)
7201             ic(2)=10**(6-ifa)
7202             ier=0
7203             idf=idtra(ic,ier,idum,0)
7204             if(ier.ne.0)then
7205               if(ifq.le.ifa)then
7206                 idf=ifq*100+ifa*10
7207               else
7208                 idf=-(ifq*10+ifa*100)
7209               endif
7210             endif
7211             call idmass(idf,amss)
7212
7213           elseif(imb.eq.2)then            ! a baryon
7214             j=1
7215             do ik=1,3
7216               if(nqv.gt.0)then
7217                 i=idraflz(jcv,j)
7218                 jc(i,j)=jc(i,j)-1
7219                 nqv=nqv-1
7220               else
7221                 i=idrafl(iclpt,jc,j,'v',1,iret2)
7222               if(iLHC.eq.1.and.iret2.ne.0)goto 77
7223               endif
7224               ifh(ik)=i
7225               ic(j)=ic(j)+10**(6-i)
7226             enddo
7227             ier=0
7228             idf=idtra(ic,ier,idum,0)
7229             if(ier.ne.0)then
7230               call neworder(ifh(1),ifh(2),ifh(3))
7231               idf=ifh(1)*1000+ifh(2)*100+ifh(3)*10
7232               if(ifh(1).ne.ifh(2).and.ifh(2).ne.ifh(3)
7233      $             .and.ifh(1).ne.ifh(3))  idf=2130
7234               if(ifh(1).eq.ifh(2).and.ifh(2).eq.ifh(3))idf=idf+1
7235             endif
7236             call idmass(idf,amss)
7237
7238           elseif(imb.eq.3)then           ! an antibaryon
7239             j=2
7240             do ik=1,3
7241               if(nav.gt.0)then
7242                 i=idraflz(jcv,j)
7243                 jc(i,j)=jc(i,j)-1
7244                 nav=nav-1
7245               else
7246                 i=idrafl(iclpt,jc,j,'v',1,iret2)
7247               if(iLHC.eq.1.and.iret2.ne.0)goto 77
7248               endif
7249               ifh(ik)=i
7250               ic(j)=ic(j)+10**(6-i)
7251             enddo
7252             ier=0
7253             idf=idtra(ic,ier,idum,0)
7254             if(ier.ne.0)then
7255               call neworder(ifh(1),ifh(2),ifh(3))
7256               idf=ifh(1)*1000+ifh(2)*100+ifh(3)*10
7257               if(ifh(1).ne.ifh(2).and.ifh(2).ne.ifh(3)
7258      $             .and.ifh(1).ne.ifh(3))  idf=2130
7259               if(ifh(1).eq.ifh(2).and.ifh(2).eq.ifh(3))idf=idf+1
7260               idf=-idf
7261             endif
7262             call idmass(idf,amss)
7263            else
7264             call utstop('This imb does not exist in gethad !&')
7265            endif
7266
7267    77     if(iret2.ne.0)then
7268           write(ifmt,*)'warning in gethadron: imb=',imb,'  iclpt:',iclpt
7269           write(ifmt,*)'   jc: ',jc,'  j: ',j,'   (1=q,2=aq)  --> redo'
7270           call utmsg('gethad')
7271           write(ifch,*)'Not enough quark ??? ... redo event !'
7272           call utmsgf
7273           iret=1
7274           goto 1000
7275           endif
7276
7277 c fix pt
7278           amasex=dble(amss)
7279           strmas=dble(utamnz(jc,mamos))
7280
7281           ptt=dble(ranpt()*alpdro(2))**2         !pt+pl
7282           if(iret.ne.0)ptt=min(ptt,sxini0)
7283           if(ptt.gt.sxini0)goto 777
7284           sxini=sqrt(sxini0-ptt)
7285
7286
7287
7288           a(5)=amasex
7289           re(5)=sxini-a(5)
7290           if(re(5).lt.strmas)then
7291             call idquacjc(jc,nq,na)
7292             if(nq+na.le.3)then
7293               idtmp=idtra(ic,1,idum,0)
7294               amtmp=0.
7295               call idmass(idtmp,amtmp)
7296               if(re(5).lt.amtmp)then
7297                 if(ish.ge.6)write(ifch,*)
7298      &           'Pb with initial mass in Gethad, retry',idf
7299      &       ,amasex,re(5),strmas,sxini,ptm,ptt,amtmp,idtmp,ic,iret
7300                 if(iret.eq.0)then
7301                   goto 777
7302                 else
7303                   if(ish.ge.6)write(ifch,*)
7304      &           'Continue with minimal mass for remnant',re(5)
7305      &                                                   ,amtmp
7306                   re(5)=amtmp
7307                 endif
7308               else
7309                 strmas=amtmp
7310               endif
7311             endif
7312           endif
7313
7314           ampt2dro=amasex**2d0
7315           ampt2str=strmas**2d0
7316
7317 c two body decay
7318           iret2=0
7319           if(iret.eq.1)then
7320 c If energy to small, then produce a new particle adding the needed missing energy (limited energy violation to avoid stop and corrected in utrescl)
7321             xmaxrm=a(5)*a(5)+re(5)*re(5)
7322             if(ptm*ptm-xmaxrm.lt.0d0)then
7323              ptm=1.1d0*sqrt(2.d0*abs(a(5))*abs(re(5))+xmaxrm)
7324              p1(5)=ptm
7325              p1(4)=sqrt(p1(3)*p1(3)+p1(2)*p1(2)+p1(1)*p1(1)+p1(5)*p1(5))
7326             endif
7327           endif
7328           if(ish.ge.6)write(ifch,*)'2 body decay',ptm,a(5),re(5),iret
7329           qcm=utpcmd(ptm,a(5),re(5),iret2)
7330           if(iret2.ne.0)then
7331             if(iret.eq.0)then
7332              goto 777
7333             else
7334 c              call utstop('Problem with qcm in gethadron !&')
7335               if(ish.ge.1)then
7336                 call utmsg('gethad')
7337                 write(ifch,*)'Problem with qcm  ... redo event !'
7338                 call utmsgf
7339               endif
7340               iret=1
7341               return
7342             endif
7343           endif
7344           u(3)=2.d0*drangen(qcm)-1.d0
7345           phi=2.d0*dble(pi)*drangen(u(3))
7346           u(1)=sqrt(1.d0-u(3)**2)*cos(phi)
7347           u(2)=sqrt(1.d0-u(3)**2)*sin(phi)
7348           if(u(3).ge.0d0)then          !send always hadron backward
7349             do j=1,3
7350               re(j)=qcm*u(j)
7351               a(j)=-re(j)
7352             enddo
7353           else
7354             do j=1,3
7355               a(j)=qcm*u(j)
7356               re(j)=-a(j)
7357             enddo
7358           endif
7359
7360           re(4)=sqrt(qcm**2+re(5)**2)
7361           a(4)=sqrt(qcm**2+a(5)**2)
7362
7363           if(ish.ge.6)write(ifch,*)'boost : ',qcm
7364      &      ,' and momentum in rest frame : ',re,a
7365
7366
7367 c Fix re of remnant
7368
7369 c boost string in collision frame
7370         call utlob2(-1,p1(1),p1(2),p1(3),p1(4),p1(5)
7371      $       ,re(1),re(2),re(3),re(4),81)
7372
7373          p5sq=(re(4)+re(3))*(re(4)-re(3))-(re(1)*re(1)+re(2)*re(2))
7374          if(p5sq.ge.ampt2str)then
7375            re(5)=sqrt(p5sq)
7376          else
7377            if(ish.ge.6)then
7378              write(ifch,*)'Pb with remnant mass -> retry'
7379              write(ifch,*)'   m^2:',p5sq,'  m_min^2:',ampt2str
7380              write(ifch,*)'   momentum four vector:',(re(ii),ii=1,4)
7381            endif
7382            if(iret.eq.0)then
7383              goto 777
7384            else
7385              if(ish.ge.6)write(ifch,*)
7386      &            'Finish with minimal mass for remnant',re(5)
7387            endif
7388          endif
7389
7390 c Fix a of hadron
7391
7392 c boost hadron in collision frame
7393         call utlob2(-1,p1(1),p1(2),p1(3),p1(4),p1(5)
7394      $       ,a(1),a(2),a(3),a(4),82)
7395
7396          p5sq=(a(4)+a(3))*(a(4)-a(3))-(a(1)**2.d0+a(2)**2.d0)
7397          if(abs(p5sq-ampt2dro).le.0.1)then
7398            a(5)=sqrt(p5sq)
7399          else
7400            if(ish.ge.6)then
7401              write(ifch,*)'Pb with hadron mass'
7402              write(ifch,*)'   m^2:',p5sq,'  m_min^2:',ampt2dro
7403              write(ifch,*)'   momentum four vector:',(a(ii),ii=1,4)
7404            endif
7405            a(4)=sqrt(a(5)*a(5)+a(3)*a(3)+a(2)*a(2)+a(1)*a(1))
7406            if(ish.ge.6)write(ifch,*)'Fix E with M and P:',(a(ii),ii=1,5)
7407          endif
7408
7409
7410 c        if(iret.eq.1)then      !If problem with momenta do not update remnant
7411 c
7412 c          if(ish.ge.4)
7413 c     *    write(ifch,*)'no hadron emission in gethad'
7414 c
7415 c