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        else     !update the 3-momentum and energy of remnant: ep
7416
7417           if(ish.ge.1.and.abs(ep(4)-re(4)-a(4)).gt.1.d-2*ep(4))then
7418             write(ifmt,*)'Pb with energy conservation in gethad'
7419             if(ish.ge.6)then
7420               write(ifch,*)'Pb with energy conservation :'
7421               write(ifch,*)'   p1_ini:',ep(1),'  p1:',re(1)+a(1)
7422               write(ifch,*)'   p2_ini:',ep(2),'  p2:',re(2)+a(2)
7423               write(ifch,*)'   p3_ini:',ep(3),'  p3:',re(3)+a(3)
7424               write(ifch,*)'   p4_ini:',ep(4),'  p4:',re(4)+a(4)
7425             endif
7426           endif
7427
7428           do i=1,5
7429             ep(i)=re(i)
7430           enddo
7431           if(ish.ge.5)then
7432             write(ifch,*)'get hadron with id and 5-momentum:',idf, a
7433           endif
7434
7435 c        endif
7436
7437         !do i=1,5
7438         !  sm(i)=ep(i)+a(i)
7439         !enddo
7440         !write(*,'(a,5f8.3,i5)')'p after:  ',sm,iret
7441
7442 c      ghost condition
7443 c         if(abs((a(4)+a(3))*(a(4)-a(3))
7444 c     $           -a(2)**2-a(1)**2-a(5)**2).gt.0.3
7445 c     $      .and.  abs(1.-abs(a(3))/a(4)).gt.0.01)print*,iret,dd
7446
7447 c$$$        if(iodiba.eq.1)then  ! for H-dibaryon study ??????????
7448 c$$$          call idenco(jc,ic,iret)
7449 c$$$          if(ic(1).eq.222000.and.ic(2).eq.0)ep(5)=ep(5)-bidiba
7450 c$$$        endif
7451
7452         if(ish.ge.5)then
7453           write(ifch,*)'new remnant flavor and 5-momentum:',jc, ep,iret
7454         endif
7455         iret=0
7456 c          write(ifmt,*)'get hadron with id and 5-momentum:',idf, a
7457 c          write(ifmt,*)'new remnant flavor and 5-momentum:',jc, ep
7458
7459  1000 call utprix('gethad',ish,ishini,5)
7460
7461       return
7462       end
7463
7464
7465
7466 c------------------------------------------------------------------
7467          subroutine getdroplet(ir,iept,ic,jc,z,ep,a,pass,xmdrmax)
7468 c------------------------------------------------------------------
7469 c  emit a droplet, update the remnant string flavor and 5-momentum
7470 c
7471 c input
7472 c       ir ........ 1  projectile, -1  target remnant
7473 c       iept ...... particle excitation
7474 c       ep ........ remnant  5-momentum
7475 c       jc ........ remnant jc
7476 c       z  ........ Z factor from splitting
7477 c output
7478 c       pass ...  .true. = successful droplet emission
7479 c                            jc, ep ....... droplet  ic and 5-momentum
7480 c                            ic, a ........ remnant string jc and 5-momentum
7481 c                 .false. = unsuccessful
7482 c                            jc, ep .... unchanged,
7483 c                            considered as droplet jc and 5-momentum
7484 c-----------------------------------------------------------------
7485
7486         include 'epos.inc'
7487         include 'epos.incems'
7488         double precision ep(5),a(5),p1(5),re(5),eps,amasex,xmdrmax
7489         double precision xxx,rr,alp,p5sq,xmin,xmax,ampt2str
7490      &  ,sxini,strmas,xxxmax,xxxmin,ampt2dro,xmdrmaxi
7491         parameter(eps=1.d-20)
7492         integer jc(nflav,2),ic(2),icx(2)
7493         integer jcini(nflav,2),jcfin(nflav,2)
7494         logical pass
7495         common/cems5/plc,s
7496         double precision s,plc,ptm,qcm,u(3),utpcmd,ptt,drangen,phi
7497
7498         call utpri('getdro',ish,ishini,4)
7499
7500         iret=0
7501         iret2=0
7502         xmdrmaxi=min(50.d0,xmdrmax)
7503         pass=.true.
7504         idps=0
7505         idms=0
7506         do i=1,nflav
7507           jcini(i,1)=jc(i,1)
7508           jcini(i,2)=jc(i,2)
7509           jcfin(i,1)=0
7510           jcfin(i,2)=0
7511         enddo
7512
7513
7514         call idquacjc(jcini,nqu,naq)
7515
7516         do i=1,5
7517           a(i)=0.d0
7518           re(i)=0.d0
7519         enddo
7520         npart=nqu+naq
7521         nqc=jcini(4,1)+jcini(4,2)
7522
7523         if(ir.eq.1)then
7524            iclpt=iclpro
7525          else
7526            iclpt=icltar
7527          endif
7528
7529          if(ish.ge.5)then
7530            write(ifch,10)'remnant flavor and 5-momentum:'
7531      &                    ,jc,ep,nqu,naq,nqc,iept
7532  10        format(a,/,'jc:',6i3,' |',6i3,/,'ep:',5(e10.3,1x),/,4i4)
7533          endif
7534
7535 c  get id of string ends, the remnant string jc is updated
7536          if(iremn.eq.3)then  !  remnant content=string content (droplet empty)
7537
7538            do i=1,nflav
7539              jcfin(i,1)=jcini(i,1)
7540              jcfin(i,2)=jcini(i,2)
7541              jcini(i,1)=0
7542              jcini(i,2)=0
7543            enddo
7544
7545          else
7546
7547          if(npart.lt.3.and.ep(5).lt.xmdrmax.and.nqc.eq.0)then !light droplet with few quarks
7548             pass=.false.
7549             goto 1000
7550          elseif(npart.lt.3)then    !few quarks but heavy, add some quarks to extract a q-qbar string (should not exit directly because of the large mass)
7551            ifq=idrafl(iclpt,jcini,2,'r',3,iret2)
7552            if(nqu.eq.1.and.naq.eq.1)then
7553              idps=1
7554              idms=1
7555              nqu=2
7556              naq=2
7557            else
7558              call utstop('This should not happen (getdrop) !&')
7559            endif
7560          elseif(nqu.eq.2.and.naq.eq.2)then
7561            idps=1
7562            idms=1
7563          elseif(naq.eq.0)then
7564            idps=5
7565            idms=1
7566          elseif(nqu.eq.0)then
7567            idps=1
7568            idms=5
7569          else                 !There is enough q or aq to do qq-q string
7570
7571
7572            if(jcini(4,1)-jcini(4,2).eq.0)then !if c-cbar
7573
7574              idps=1
7575              idms=1
7576
7577            else
7578
7579 c One chooses the first q or aq
7580
7581            rrr=rangen()
7582            npart=nqu+naq
7583            if(jcini(4,1)+jcini(4,2).ne.0)then !if some charm take it out
7584              if(jcini(4,1).ne.0)then
7585                idps=1
7586                nqu=nqu-1
7587              else
7588                idms=1
7589                naq=naq-1
7590              endif
7591            elseif(rrr.gt.float(naq)/float(npart))then
7592              idps=1
7593              nqu=nqu-1
7594            else
7595              idms=1
7596              naq=naq-1
7597            endif
7598
7599 c One chooses the second one
7600
7601            rrr=rangen()
7602            npart=nqu+naq
7603            if(idps.eq.1.and.jcini(4,1).ne.0)then !if some charm take it out
7604              idps=5
7605            elseif(idms.eq.1.and.jcini(4,2).ne.0)then !if some charm take it out
7606              idms=5
7607            elseif(rrr.gt.float(naq)/float(npart))then
7608              if(idps.eq.1.and.nqu.ge.2)then
7609                idps=5
7610              else
7611                idps=1
7612              endif
7613            else
7614              if(idms.eq.1.and.naq.ge.2)then
7615                idms=5
7616              else
7617                idms=1
7618              endif
7619            endif
7620
7621 c If there is already 2 q or 2 aq as string end, we know that we need
7622 c a third one to complete the string
7623
7624            if(idps.eq.5)idms=1
7625            if(idms.eq.5)idps=1
7626            if(idps.eq.1.and.idms.ne.5)idms=1
7627            if(idms.eq.1.and.idps.ne.5)idps=1
7628
7629          endif
7630
7631          endif
7632
7633          if(ish.ge.5)then
7634            write(ifch,*)'remnant string ends :',idps,idms
7635          endif
7636
7637           if(idps.ne.5.and.idms.ne.5)then              ! q-aq string
7638             if(jcini(4,1).eq.1)then
7639               ifq=idrafl(iclpt,jcini,1,'c',1,iret)
7640             else
7641               ifq=idrafl(iclpt,jcini,1,'v',1,iret)
7642             endif
7643             if(jcini(4,1).eq.1)then
7644               ifa=idrafl(iclpt,jcini,2,'c',1,iret)
7645             else
7646               ifa=idrafl(iclpt,jcini,2,'v',1,iret)
7647             endif
7648             jcfin(ifq,1)=1
7649             jcfin(ifa,2)=1
7650
7651           elseif(idps.eq.5)then                       ! qq-q string
7652             do ik=1,3
7653               if(jcini(4,1).ne.0)then
7654                 i=idrafl(iclpt,jcini,1,'c',1,iret)
7655               else
7656                 i=idrafl(iclpt,jcini,1,'v',1,iret)
7657               endif
7658               jcfin(i,1)=jcfin(i,1)+1
7659             enddo
7660
7661           elseif(idms.eq.5)then                        !aqaq-aq string
7662             do ik=1,3
7663               if(jcini(4,2).ne.0)then
7664                 i=idrafl(iclpt,jcini,2,'c',1,iret)
7665               else
7666                 i=idrafl(iclpt,jcini,2,'v',1,iret)
7667               endif
7668               jcfin(i,2)=jcfin(i,2)+1
7669             enddo
7670           endif
7671
7672           endif      !iremn=3
7673
7674           if(iret.ne.0)call utstop('Not enough quark in getdro ???&')
7675           if(jcini(4,1)+jcini(4,2).ne.0)
7676      &         call utstop('There is sitll charm quark in getdro???&')
7677
7678 c string id
7679
7680          call idenco(jcfin,icx,iret)
7681          if(iret.eq.1)then
7682            call utstop('Exotic flavor in getdroplet !&')
7683          endif
7684
7685
7686 c boost remnant in rest frame
7687       if(ish.ge.6) write (ifch,*) 'on-shell check'
7688         do k=1,5
7689           p1(k)=ep(k)
7690         enddo
7691         p1(5)=(p1(4)-p1(3))*(p1(4)+p1(3))-p1(2)**2-p1(1)**2
7692         if(p1(5).gt.0d0.and.abs(p1(5)-ep(5)*ep(5)).lt.ep(5))then
7693           p1(5)=sqrt(p1(5))
7694         else
7695           if(ish.ge.2)write(ifch,*)'Precision problem in getdro, p:',
7696      &             (p1(k),k=1,5),ep(5)*ep(5)
7697           p1(5)=ep(5)
7698           p1(4)=sqrt(p1(3)*p1(3)+p1(2)*p1(2)+p1(1)*p1(1)+p1(5)*p1(5))
7699         endif
7700       if(ish.ge.6) write (ifch,*) 'boost vector:',p1
7701
7702 c limits for momenta
7703
7704       mamod=4
7705       mamos=4
7706       fad=alpdro(1)
7707       if(iremn.eq.3)fad=fad*(1.+z*zdrinc)
7708       fad=max(1.5,fad)
7709       ptm=p1(5)
7710       amasex=dble(fad*utamnz(jcini,mamod))
7711       fas=2.
7712       if(iremn.eq.3)then
7713         id=idtra(icx,ier,ires,0)
7714         if(ier.eq.0)then
7715           call idmass(id,amass)           !minimum is particle mass
7716           strmas=dble(amass)
7717         else
7718           strmas=dble(fas*utamnz(jcfin,mamos))
7719         endif
7720       else
7721         strmas=dble(fas*utamnz(jcfin,mamos))
7722       endif
7723
7724
7725 c redo
7726
7727        nredo=0
7728  777   continue
7729        nredo=nredo+1
7730        if(nredo.eq.10)then
7731           amasex=1.5d0*dble(utamnz(jcini,mamod))
7732           if(iremn.ne.3)strmas=1.5d0*dble(utamnz(jcfin,mamos))
7733        elseif(nredo.gt.20)then
7734           !write(ifch,*)'nredo.gt.20 -> only drop'
7735          if(ish.ge.4)write(ifch,*)
7736      &     'Pb with string mass in Getdrop, continue with gethad'
7737           pass=.false.
7738          goto 1000
7739        endif
7740
7741 c fix pt
7742
7743           sxini=ptm*ptm
7744           ptt=dble(ranpt()*alpdro(2))**2         !pt
7745           if(ptt.ge.sxini)goto 777
7746           sxini=sqrt(sxini-ptt)
7747
7748
7749           ampt2dro=amasex**2d0
7750           ampt2str=strmas**2d0
7751           if(ampt2dro.gt.xmdrmaxi)then
7752             xmdrmaxi=2d0*ampt2dro
7753 c            write(ifmt,*)'Warning Mmin>Mmax in Getdroplet'
7754           endif
7755
7756           xxxmax=min(xmdrmaxi,(sxini-strmas)**2)    !strmas/(strmas+ampt2)
7757           xxxmin=ampt2dro
7758
7759           if(xxxmin.gt.xxxmax)then
7760             !write(ifch,*)'Warning Mmin>sxini -> only drop'
7761            if(ish.ge.4)write(ifch,*)
7762      &     'Pb with ampt2 in Getdrop, retry',nredo,ir
7763      &             ,ampt2dro,ampt2str,xxxmin,xxxmax,sxini,ptt,xmdrmaxi
7764             goto 777
7765           endif
7766
7767
7768
7769 c fix mass
7770
7771             rr=drangen(xxxmax)
7772             xmax=xxxmax
7773             xmin=xxxmin
7774             alp=dble(alpdro(3))
7775             if(dabs(alp-1.d0).lt.eps)then
7776               xxx=xmax**rr*xmin**(1d0-rr)
7777             else
7778               xxx=(rr*xmax**(1d0-alp)+(1d0-rr)*xmin**(1d0-alp))
7779      &                                                **(1d0/(1d0-alp))
7780             endif
7781
7782
7783 c        write(ifch,*)'ini',xmin,xxx,xmax,rr,ampt2dro
7784 c    &                   ,(sxini-sqrt(xxx)),ampt2str,p1(5)
7785
7786
7787
7788           re(5)=sqrt(xxx)
7789           a(5)=sxini-re(5)
7790           if(a(5).lt.strmas)then
7791             if(ish.ge.6)write(ifch,*)
7792      &           'Pb with initial mass in Getdrop, retry',ir
7793      &       ,xmin,xxx,xmax,rr,ampt2dro,ampt2str,a(5)
7794             goto 777
7795           endif
7796
7797
7798 c two body decay
7799           if(ish.ge.6)write(ifch,*)'2 body decay',ptm,re(5),a(5)
7800           qcm=utpcmd(ptm,re(5),a(5),iret)
7801           u(3)=0.d0 !2.d0*drangen(qcm)-1.d0
7802           phi=2.d0*dble(pi)*drangen(u(3))
7803           u(1)=sqrt(1.d0-u(3)**2)*cos(phi)
7804           u(2)=sqrt(1.d0-u(3)**2)*sin(phi)
7805           if(u(3).lt.0d0)then          !send always droplet backward
7806 c          if(u(3).gt.0d0)then          !send always droplet forward     ?????
7807             do j=1,3
7808               re(j)=qcm*u(j)
7809               a(j)=-re(j)
7810             enddo
7811           else
7812             do j=1,3
7813               a(j)=qcm*u(j)
7814               re(j)=-a(j)
7815             enddo
7816           endif
7817
7818           re(4)=sqrt(qcm**2+re(5)**2)
7819           a(4)=sqrt(qcm**2+a(5)**2)
7820
7821           if(ish.ge.6)write(ifch,*)'momentum in rest frame : ',re,a
7822
7823
7824
7825 c Fix a of string
7826
7827 c boost string in collision frame
7828         call utlob2(-1,p1(1),p1(2),p1(3),p1(4),p1(5)
7829      $       ,a(1),a(2),a(3),a(4),71)
7830
7831          p5sq=(a(4)+a(3))*(a(4)-a(3))-(a(1)**2.d0+a(2)**2.d0)
7832          if(p5sq.gt.ampt2str)then
7833            a(5)=sqrt(p5sq)
7834          else
7835            if(ish.ge.6)then
7836              write(ifch,*)'Pb with string mass -> retry'
7837              write(ifch,*)'   m^2:',p5sq,'  m_min^2:',ampt2str
7838              write(ifch,*)'   momentum four vector:',(a(ii),ii=1,4)
7839            endif
7840            goto 777
7841          endif
7842
7843 c Fix ep of droplet
7844
7845 c boost droplet in collision frame
7846         call utlob2(-1,p1(1),p1(2),p1(3),p1(4),p1(5)
7847      $       ,re(1),re(2),re(3),re(4),72)
7848
7849          p5sq=(re(4)+re(3))*(re(4)-re(3))-(re(1)*re(1)+re(2)*re(2))
7850          if(p5sq.gt.ampt2dro)then
7851            re(5)=sqrt(p5sq)
7852          else
7853            if(ish.ge.6)then
7854              write(ifch,*)'Pb with droplet mass -> retry'
7855              write(ifch,*)'   m^2:',p5sq,'  m_min^2:',ampt2dro
7856              write(ifch,*)'   momentum four vector:',(re(ii),ii=1,4)
7857            endif
7858            goto 777
7859          endif
7860
7861
7862        if(ish.ge.1.and.abs(ep(4)-re(4)-a(4)).gt.1.d-2*ep(4))then
7863          write(ifmt,*)'Pb with energy conservation in getdro'
7864          if(ish.ge.6)then
7865            write(ifch,*)'Pb with energy conservation :'
7866            write(ifch,*)'   p1_ini:',ep(1),'  p1:',re(1)+a(1)
7867            write(ifch,*)'   p2_ini:',ep(2),'  p2:',re(2)+a(2)
7868            write(ifch,*)'   p3_ini:',ep(3),'  p3:',re(3)+a(3)
7869          endif
7870        endif
7871
7872 c If OK, save flavors of droplet and string
7873          do i=1,5
7874            ep(i)=re(i)
7875          enddo
7876          ic(1)=icx(1)
7877          ic(2)=icx(2)
7878          do i=1,nflav
7879            jc(i,1)=jcini(i,1)
7880            jc(i,2)=jcini(i,2)
7881          enddo
7882
7883          if(ish.ge.6)then
7884            write(ifch,20)'droplet:',jc,ep
7885            write(ifch,30)'string remnant:',ic,a
7886          endif
7887  20      format(a,/,'jc:',6i3,' |',6i3,/,'ep:',5(e10.3,1x))
7888  30      format(a,/,'ic:',i7,' |',i7,/,'a:',5(e10.3,1x))
7889
7890  1000    continue
7891          call utprix('getdro',ish,ishini,4)
7892          end
7893
7894 c------------------------------------------------------------------
7895          subroutine getdropx(ir,iept,m,ic,jc,jcv,z,ep,a,pass,xmdrmax)
7896 c------------------------------------------------------------------
7897 c  emit a droplet taken into account momentum fraction without screening,
7898 c  update the remnant string flavor and 5-momentum (to be used with iremn=2)
7899 c
7900 c input
7901 c       ir ........ 1  projectile, -1  target remnant
7902 c       iept ...... particle excitation
7903 c       m  ........ remnant index
7904 c       ep ........ remnant  5-momentum
7905 c       jc ........ remnant jc
7906 c       jcv ....... remnant jc valence quark
7907 c       z  ........ Z factor from splitting
7908 c output
7909 c       pass ...  .true. = successful droplet emission
7910 c                            jc, ep ....... droplet  ic and 5-momentum
7911 c                            ic, a ........ remnant string jc and 5-momentum
7912 c                 .false. = unsuccessful
7913 c                            jc, ep .... unchanged,
7914 c                            considered as droplet jc and 5-momentum
7915 c-----------------------------------------------------------------
7916
7917         include 'epos.inc'
7918         include 'epos.incems'
7919         double precision ep(5),a(5),p1(5),re(5),eps,amasex,xmdrmax
7920         double precision xxx,rr,alpm,p5sq,xmin,xmax,ampt2str,xmsmax
7921      &  ,sxini,strmas,xxxmax,xxxmin,ampt2dro,xmdrmaxi,xprmi,xmrmi
7922      &  ,xprmd,xmrmd,xprms,xmrms,xpti,ypti,xptd,yptd,xpts,ypts,xptt,yptt
7923         double precision om1xpr,xremd,xrems,freduc
7924      &       ,atil(ntymi:ntymx),btilp(ntymi:ntymx),btilpp(ntymi:ntymx)
7925         parameter(eps=1.d-20)
7926         integer jc(nflav,2),jcv(nflav,2),ic(2),icx(2)
7927         integer jcvini(nflav,2),jcini(nflav,2)
7928      &         ,jcfin(nflav,2),jcvfin(nflav,2)
7929         logical pass
7930         common/cems5/plc,s
7931         double precision s,plc,ptm,qcm,u(3),utpcmd,ptt,drangen,phi
7932         logical strcomp,valqu
7933
7934         call utpri('getdrx',ish,ishini,4)
7935
7936         iret=0
7937         xmdrmaxi=min(50.d0,xmdrmax)
7938         pass=.true.
7939         idps=0
7940         idms=0
7941         do i=1,nflav
7942           jcini(i,1)=jc(i,1)
7943           jcini(i,2)=jc(i,2)
7944           jcvini(i,1)=jcv(i,1)
7945           jcvini(i,2)=jcv(i,2)
7946           jcfin(i,1)=0
7947           jcfin(i,2)=0
7948           jcvfin(i,1)=0
7949           jcvfin(i,2)=0
7950         enddo
7951
7952
7953         call idquacjc(jcini,nqu,naq)
7954         call idquacjc(jcvini,nqv,nav)
7955
7956         do i=1,5
7957           a(i)=0.d0
7958           re(i)=0.d0
7959         enddo
7960         nqc=jcini(4,1)+jcini(4,2)
7961
7962         idrf=0
7963         if(nqu-naq.ne.0)idrf=1
7964         if(ir.eq.1)then
7965            iclpt=iclpro
7966            if(idrf.eq.0)idrf=idp(m)  !change it only if not 1
7967            xprmi=xpp(m)
7968            xmrmi=xmp(m)
7969            xpti=xxp(m)
7970            ypti=xyp(m)
7971            if(lproj3(m).gt.0)then
7972              nlnk=max(1,nint(z*float(lproj3(m))))
7973            else
7974              nlnk=0
7975            endif
7976         else
7977            iclpt=icltar
7978            if(idrf.eq.0)idrf=idt(m)  !change it only if not 1
7979            xprmi=xmt(m)
7980            xmrmi=xpt(m)
7981            xpti=xxt(m)
7982            ypti=xyt(m)
7983            if(ltarg3(m).gt.0)then
7984              nlnk=max(1,nint(z*float(ltarg3(m))))
7985            else
7986              nlnk=0
7987            endif
7988          endif
7989
7990          if(ish.ge.5)then
7991            write(ifch,10)'remnant flavor and 5-momentum:'
7992      &                    ,jc,jcv,ep,nqu,naq,nqv,nav,nqc,idrf,iept,nlnk
7993  10        format(a,/,'jc:',6i3,' |',6i3,/,'jcv:',6i3,' |',6i3,/
7994      &            ,'ep:',5(e10.3,1x),/,8i4)
7995          endif
7996
7997 c check formation conditions
7998
7999          strcomp=.false.
8000          valqu=.false.    !if true, valence quark will always be in strings : reduce lambda production
8001          if((nqu.eq.3.and.naq.eq.0).or.(nqu.eq.0.and.naq.eq.3)
8002      &          .or.(nqu.eq.1.and.naq.eq.1).and.nlnk.ne.0)then
8003 c not enough quark for the droplet, check mass
8004            if(iept.ne.5.and.ep(5)*ep(5).lt.xmdrmax.and.nqc.eq.0)then
8005              pass=.false.       !continue without droplet
8006              if(ish.ge.4)write(ifch,*)
8007      &      'Normal remnant in Getdropx, continue only with droplet ...'
8008              goto 1000
8009            endif
8010 c create q-aq from sea (but no charm)
8011            do n=1,nlnk
8012              idum=idrafl(iclpt,jcini,1,'r',3,iret)
8013              nqu=nqu+1
8014              naq=naq+1
8015            enddo
8016            strcomp=.true.
8017            valqu=.false.
8018          elseif(mod(nqu-naq,3).ne.0)then
8019            call utstop('This should not happen (getdropx) !&')
8020          endif
8021
8022 c  get id of string ends, the remnant string jc is updated
8023
8024 c First remove all charm
8025
8026          if(nqc.ne.0.and.jcini(4,1)-jcini(4,2).eq.0)then !if c-cbar
8027
8028            if(jcini(4,1).eq.1)then
8029              idps=1
8030              idms=1
8031            else
8032              call utstop('getdropx can not manage more than c-cb !&')
8033            endif
8034
8035          elseif(nqc.ne.0.and.jcini(4,1)*jcini(4,2).ne.0)then
8036
8037            call utstop('getdropx can not manage c quarks this way !&')
8038
8039          else
8040
8041
8042            if(nqc.ne.0)then !if some charm take it out
8043              if(jcini(4,1).ne.0)then
8044                if(nqu.lt.3)then
8045                  idrf=0         !can not use c in antibaryon
8046                elseif(jcini(4,1).gt.1)then
8047                  idrf=1         !more than 1 c quark only in baryon
8048                endif
8049              elseif(jcini(4,2).ne.0)then
8050                if(naq.lt.3)then
8051                  idrf=0         !can not use cb in baryon
8052                elseif(jcini(4,2).gt.1)then
8053                  idrf=1         !more than 1 c antiquark only in antibaryon
8054                endif
8055              endif
8056              if(idrf.ne.0.and.jcini(4,1).gt.0.and.jcini(4,1).le.3)then
8057                idps=5
8058                idms=1
8059          elseif(idrf.ne.0.and.jcini(4,2).gt.0.and.jcini(4,2).le.3)then
8060                idps=1
8061                idms=5
8062              elseif(jcini(4,1).gt.1.or.jcini(4,2).gt.1)then
8063                call utstop('getdropx can not use more than 3 c/cb !&')
8064              endif
8065            endif
8066
8067 c take into account number of diquark in final remnant string
8068
8069            if(idps.eq.0)then
8070
8071              if(idrf.ne.0)then  !use a diquark
8072                if(nqu.gt.naq)then        !qq-q
8073                  idps=5
8074                  idms=1
8075                elseif(nqu.lt.naq)then    !qbqb-qb
8076                  idps=1
8077                  idms=5
8078                endif
8079              else               !q-qb
8080                idps=1
8081                idms=1
8082              endif
8083
8084            endif
8085
8086          endif                  !string end type
8087
8088          if(ish.ge.5)then
8089            write(ifch,*)'remnant string ends :',idps,idms
8090          endif
8091
8092 c choose flavor with priority to valence quark (after charm)
8093
8094           if(idps.ne.5.and.idms.ne.5)then              ! q-aq string
8095             j=1
8096             if(jcini(4,j).gt.0)then
8097               i=4
8098               jcini(i,j)=jcini(i,j)-1
8099               if(jcvini(i,j).gt.0)then
8100                 jcvfin(i,j)=jcvfin(i,j)+1
8101                 jcvini(i,j)=jcvini(i,j)-1
8102                 nqv=nqv-1
8103               endif
8104             elseif(valqu.and.nqv.gt.0)then
8105               i=idraflz(jcvini,j)
8106               jcvfin(i,j)=jcvfin(i,j)+1
8107               jcini(i,j)=jcini(i,j)-1
8108               nqv=nqv-1
8109             else
8110               i=idrafl(iclpt,jcini,j,'v',1,iret)
8111               if(jcini(i,j)-jcvini(i,j).lt.0)then
8112                 jcvini(i,j)=jcvini(i,j)-1
8113                 jcvfin(i,j)=jcvfin(i,j)+1
8114               endif
8115             endif
8116             ifq=i
8117             j=2
8118             if(jcini(4,j).gt.0)then
8119               i=4
8120               jcini(i,j)=jcini(i,j)-1
8121               if(jcvini(i,j).gt.0)then
8122                 jcvfin(i,j)=jcvfin(i,j)+1
8123                 jcvini(i,j)=jcvini(i,j)-1
8124                 nav=nav-1
8125               endif
8126             elseif(valqu.and.nav.gt.0)then
8127               i=idraflz(jcvini,j)
8128               jcvfin(i,j)=jcvfin(i,j)+1
8129               jcini(i,j)=jcini(i,j)-1
8130               nav=nav-1
8131             else
8132               i=idrafl(iclpt,jcini,j,'v',1,iret)
8133               if(jcini(i,j)-jcvini(i,j).lt.0)then
8134                 jcvini(i,j)=jcvini(i,j)-1
8135                 jcvfin(i,j)=jcvfin(i,j)+1
8136               endif
8137             endif
8138             ifa=i
8139             jcfin(ifq,1)=1
8140             jcfin(ifa,2)=1
8141
8142           elseif(idps.eq.5)then                       ! qq-q string
8143             j=1
8144             do ik=1,3
8145               if(jcini(4,j).ne.0)then
8146                 i=4
8147                 jcini(i,j)=jcini(i,j)-1
8148                 if(jcvini(i,j).gt.0)then
8149                   jcvfin(i,j)=jcvfin(i,j)+1
8150                   jcvini(i,j)=jcvini(i,j)-1
8151                   nqv=nqv-1
8152                 endif
8153               elseif(valqu.and.nqv.gt.0)then
8154                 i=idraflz(jcvini,j)
8155                 jcvfin(i,j)=jcvfin(i,j)+1
8156                 jcini(i,j)=jcini(i,j)-1
8157                 nqv=nqv-1
8158               else
8159                 i=idrafl(iclpt,jcini,j,'v',1,iret)
8160                 if(jcini(i,j)-jcvini(i,j).lt.0)then
8161                   jcvini(i,j)=jcvini(i,j)-1
8162                   jcvfin(i,j)=jcvfin(i,j)+1
8163                 endif
8164               endif
8165               jcfin(i,j)=jcfin(i,j)+1
8166             enddo
8167
8168           elseif(idms.eq.5)then                        !aqaq-aq string
8169             j=2
8170             do ik=1,3
8171               if(jcini(4,j).gt.0)then
8172                 i=4
8173                 jcini(i,j)=jcini(i,j)-1
8174                 if(jcvini(i,j).gt.0)then
8175                   jcvfin(i,j)=jcvfin(i,j)+1
8176                   jcvini(i,j)=jcvini(i,j)-1
8177                   nav=nav-1
8178                 endif
8179               elseif(valqu.and.nav.gt.0)then
8180                 i=idraflz(jcvini,j)
8181                 jcvfin(i,j)=jcvfin(i,j)+1
8182                 jcini(i,j)=jcini(i,j)-1
8183                 nav=nav-1
8184               else
8185                 i=idrafl(iclpt,jcini,j,'v',1,iret)
8186                 if(jcini(i,j)-jcvini(i,j).lt.0)then
8187                   jcvini(i,j)=jcvini(i,j)-1
8188                   jcvfin(i,j)=jcvfin(i,j)+1
8189                 endif
8190               endif
8191               jcfin(i,j)=jcfin(i,j)+1
8192             enddo
8193
8194           endif
8195
8196           if(iret.ne.0)call utstop('Not enough quark in getdropx ???&')
8197           if(jcini(4,1)+jcini(4,2).ne.0)
8198      &         call utstop('There is sitll charm quark in getdropx???&')
8199
8200 c string id
8201
8202          call idenco(jcfin,icx,iret)
8203          if(iret.eq.1)then
8204            call utstop('Exotic flavor in getdropx !&')
8205          endif
8206
8207
8208 c boost remnant in rest frame
8209       if(ish.ge.6) write (ifch,*) 'on-shell check'
8210         do k=1,5
8211           p1(k)=ep(k)
8212         enddo
8213         p1(5)=(p1(4)-p1(3))*(p1(4)+p1(3))-p1(2)**2-p1(1)**2
8214         if(p1(5).gt.0d0.and.abs(p1(5)-ep(5)*ep(5)).lt.ep(5))then
8215           p1(5)=sqrt(p1(5))
8216         else
8217           if(ish.ge.2)write(ifch,*)'Precision problem in getdropx, p:',
8218      &             (p1(k),k=1,5),ep(5)*ep(5)
8219           p1(5)=ep(5)
8220           p1(4)=sqrt(p1(3)*p1(3)+p1(2)*p1(2)+p1(1)*p1(1)+p1(5)*p1(5))
8221         endif
8222
8223 c limits for momenta
8224
8225       mamod=4
8226       mamos=4
8227       fad=alpdro(1)
8228       fad=max(1.5,fad*(1.+z*zdrinc))
8229       ptm=p1(5)
8230       amasex=dble(fad*utamnz(jcini,mamod))
8231       fas=2.
8232       strmas=dble(fas*utamnz(jcfin,mamos))
8233       ampt2dro=amasex**2d0
8234       ampt2str=strmas**2d0
8235       if(ampt2dro.gt.xmdrmaxi)then
8236         xmdrmaxi=2d0*ampt2dro
8237 c       write(ifmt,*)'Warning Mmin>Mmax in Getdropx'
8238       endif
8239
8240
8241 c redo
8242
8243        xxxmin=1d0-xprmi
8244        if(xxxmin.gt.ampt2dro/(s*xmrmi))then
8245          xmrmd=ampt2dro/(s*xxxmin)
8246        else
8247          nlnk=0
8248        endif
8249        nredo=-1
8250        freduc=1d0
8251  777   continue
8252        nredo=nredo+1
8253        if(strcomp.and.nredo.eq.20)then  !after 19 try and remnant compatible with a string
8254          pass=.false.         !continue without droplet
8255          if(ish.ge.4)write(ifch,'(a,2i3,4e12.5)')
8256      &     'Pb with splitting in Getdropx, continue without split ...'
8257      &     ,nlnk,nvirt,xxxmax,xxxmin,ep(5)**2,xmdrmax
8258          goto 1000
8259        elseif(nredo.eq.10.or.nredo.eq.26)then        !reduce minimum mass
8260           amasex=1.5d0*dble(utamnz(jcini,mamod))
8261           strmas=1.5d0*dble(utamnz(jcfin,mamos))
8262           ampt2dro=amasex**2d0
8263           ampt2str=strmas**2d0
8264           xmrmd=ampt2dro/(s*xxxmin)
8265        elseif(nredo.eq.20)then    !after 19 try, use 2 body decay
8266          xmrmd=1d0+xmrmi
8267          if(ish.ge.4)write(ifch,*)
8268      &     'nredo>20, use 2 body decay ...',nvirt,xxxmax,xxxmin
8269          amasex=dble(fad*utamnz(jcini,mamod))
8270          strmas=dble(fas*utamnz(jcfin,mamos))
8271          ampt2dro=amasex**2d0
8272          ampt2str=strmas**2d0
8273          if(ish.ge.6) write (ifch,*) 'boost vector:',p1
8274        elseif(nredo.ge.30)then
8275           !write(ifch,*)'nredo.gt.20 -> only drop'
8276          if(ish.ge.4)write(ifch,*)
8277      &    'Pb with string mass in Getdropx, continue without split ...'
8278           pass=.false.
8279          goto 1000
8280        endif
8281
8282        if(xmrmd.lt.xmrmi.and.nlnk.gt.0)then        !kinetic compatibility
8283
8284          xmrms=xmrmi-xmrmd
8285
8286 c fix the virtual number of collision (no screening)
8287          iscreensave=iscreen
8288          iscreen=0
8289          imin=ntymin
8290          imax=ntymx
8291          if(iomega.eq.2)imax=1
8292          spp=sngl(s)
8293          nvirt=0
8294          xxxmax=0d0
8295          xpts=0d0
8296          ypts=0d0
8297          if(ir.eq.1)then
8298            do l=1,lproj3(m)    !use all pairs attached to remnant
8299              kp=kproj3(m,l)
8300              nvirt=nvirt+1
8301              do i=imin,imax
8302                call Gfunpar(0.,0.,1,i,bk(kp),spp,alp,bet,betp,epsp,epst
8303      &                                                       ,epss,gamv)
8304                atil(i)=dble(alp)
8305                btilp(i)=dble(bet)
8306                btilpp(i)=dble(betp)
8307              enddo
8308              xprms=1d0-xxxmax
8309 c take x from an "unscreened" Pomeron (reduction factor if too high)
8310              xxx=om1xpr(atil,btilp,btilpp,xprms,xmrmi,ir)*freduc
8311              ptt=dble(ranptcut(1.)*alpdro(2))
8312 c             ptt=dble(ranptcut(ptsems)*alpdro(2))
8313              phi=2d0*dble(pi)*drangen(ptt)
8314              xprms=1d0-xxxmax-xxx
8315              xptt=xpts+ptt*cos(phi)
8316              yptt=ypts+ptt*sin(phi)
8317              xrems=xprms*xmrms*s-(xpti+xptt)**2-(ypti+yptt)**2
8318              if(xrems.gt.ampt2str)then
8319                xxxmax=xxxmax+xxx
8320                xpts=xptt
8321                ypts=yptt
8322              endif
8323            enddo
8324          else
8325            do l=1,ltarg3(m)    !use all pairs attached to remnant
8326              kt=ktarg3(m,l)
8327              nvirt=nvirt+1
8328              do i=imin,imax
8329                call Gfunpar(0.,0.,1,i,bk(kt),spp,alp,bet,betp,epsp,epst
8330      &                                                       ,epss,gamv)
8331                atil(i)=dble(alp)
8332                btilp(i)=dble(bet)
8333                btilpp(i)=dble(betp)
8334              enddo
8335              xprms=1d0-xxxmax
8336 c take x from an "unscreened" Pomeron (reduction factor if too high)
8337             xxx=om1xpr(atil,btilp,btilpp,xprms,xmrmi,ir)*freduc
8338              ptt=dble(ranptcut(1.)*alpdro(2))
8339 c             ptt=dble(ranptcut(ptsems)*alpdro(2))
8340              phi=2d0*dble(pi)*drangen(ptt)
8341              xprms=1d0-xxxmax-xxx
8342              xptt=xpts+ptt*cos(phi)
8343              yptt=ypts+ptt*sin(phi)
8344              xrems=xprms*xmrms*s-(xpti+xptt)**2-(ypti+yptt)**2
8345              if(xrems.gt.ampt2str)then
8346                xxxmax=xxxmax+xxx
8347                xpts=xptt
8348                ypts=yptt
8349              endif
8350            enddo
8351          endif
8352          iscreen=iscreensave
8353
8354          if(xxxmax.le.xxxmin)goto 777
8355
8356
8357 c check string mass and energy
8358
8359          xprms=1d0-xxxmax
8360          xpts=xpti+xpts
8361          ypts=ypti+ypts
8362          xrems=xprms*xmrms*s-xpts*xpts-ypts*ypts
8363          if(xrems.lt.ampt2str)then
8364            if(ish.ge.4)write(ifch,*)
8365      &          'Pb with string mass in Getdropx, retry',nredo,ir
8366      &          ,ampt2str,xrems,xprms,xmrms,xpts,ypts
8367            goto 777
8368          endif
8369
8370 c check droplet mass and energy
8371
8372 c Droplet mass should not exceed to much mdrmaxi. Use random to smooth distrib.
8373          xmsmax=xmdrmaxi*(1.+drangen(xmdrmaxi))
8374          xprmd=xprmi-xprms
8375          xptd=xpti-xpts
8376          yptd=ypti-ypts
8377          xremd=xprmd*xmrmd*s-xptd*xptd-yptd*yptd
8378          if(xremd.lt.ampt2dro)then
8379 c Droplet should not have a mass too low.
8380            if(ish.ge.4)write(ifch,*)
8381      &          'Pb with drop mass (low) in Getdropx, retry',nredo,ir
8382      &          ,ampt2dro,xremd,xprmd,xmrmd,xptd,yptd
8383            goto 777
8384          elseif(xremd.ge.xmsmax)then
8385 c Droplet should not have a mass too high.
8386            if(ish.ge.4)write(ifch,*)
8387      &          'Pb with drop mass (high) in Getdropx, retry',nredo,ir
8388      &          ,xremd,xmsmax,xprmd,xmrmd,xptd,yptd
8389            freduc=freduc*0.5d0
8390            goto 777
8391          endif
8392
8393
8394          re(1)=xptd
8395          re(2)=yptd
8396          if(ir.eq.1)then
8397            re(3)=(xprmd-xmrmd)*plc*0.5d0
8398          else
8399            re(3)=(xmrmd-xprmd)*plc*0.5d0
8400          endif
8401          re(4)=(xprmd+xmrmd)*plc*0.5d0
8402          re(5)=sqrt(xremd)
8403
8404          a(1)=xpts
8405          a(2)=ypts
8406          if(ir.eq.1)then
8407            a(3)=(xprms-xmrms)*plc*0.5d0
8408          else
8409            a(3)=(xmrms-xprms)*plc*0.5d0
8410          endif
8411          a(4)=(xprms+xmrms)*plc*0.5d0
8412          a(5)=sqrt(xrems)
8413
8414
8415
8416        else   !if xm to small, use two body decay (should be rare)
8417
8418          if(ish.ge.6)write (ifch,*)'kinematic limit -> boost vector:',p1
8419
8420 c fix pt
8421
8422           sxini=ptm*ptm
8423           ptt=dble(ranpt()*alpdro(2))**2         !pt
8424           if(ptt.ge.sxini)goto 777
8425           sxini=sqrt(sxini-ptt)
8426
8427
8428
8429           xmsmax=xmdrmaxi*(1.+drangen(xmdrmaxi))
8430           xxxmax=min(xmsmax,(sxini-strmas)**2)    !strmas/(strmas+ampt2)
8431           xxxmin=ampt2dro
8432
8433           if(xxxmin.gt.xxxmax)then
8434             !write(ifch,*)'Warning Mmin>sxini -> only drop'
8435            if(ish.ge.4)write(ifch,*)
8436      &     'Pb with ampt2 in Getdropx, retry',nredo,ir
8437      &             ,ampt2dro,ampt2str,xxxmin,xxxmax,sxini,ptt,xmsmax
8438             goto 777
8439           endif
8440
8441
8442
8443 c fix mass
8444
8445             rr=drangen(xxxmax)
8446             xmax=xxxmax
8447             xmin=xxxmin
8448             alpm=dble(alpdro(3))
8449             if(dabs(alpm-1.d0).lt.eps)then
8450               xxx=xmax**rr*xmin**(1d0-rr)
8451             else
8452               xxx=(rr*xmax**(1d0-alpm)+(1d0-rr)*xmin**(1d0-alpm))
8453      &                                                **(1d0/(1d0-alpm))
8454             endif
8455
8456
8457 c        write(ifch,*)'ini',xmin,xxx,xmax,rr,ampt2dro
8458 c     &                   ,(sxini-sqrt(xxx)),ampt2str,p1(5)
8459
8460
8461
8462           re(5)=sqrt(xxx)
8463           a(5)=sxini-re(5)
8464           if(a(5).lt.strmas)then
8465             if(ish.ge.6)write(ifch,*)
8466      &           'Pb with initial mass in Getdropx, retry',ir
8467      &       ,xmin,xxx,xmax,rr,ampt2dro,ampt2str,a(5)
8468             goto 777
8469           endif
8470
8471
8472 c two body decay
8473           if(ish.ge.6)write(ifch,*)'2 body decay',ptm,re(5),a(5)
8474           qcm=utpcmd(ptm,re(5),a(5),iret)
8475           u(3)=2.d0*drangen(qcm)-1.d0
8476           phi=2.d0*dble(pi)*drangen(u(3))
8477           u(1)=sqrt(1.d0-u(3)**2)*cos(phi)
8478           u(2)=sqrt(1.d0-u(3)**2)*sin(phi)
8479           do j=1,3
8480             re(j)=qcm*u(j)
8481             a(j)=-re(j)
8482           enddo
8483
8484           re(4)=sqrt(qcm**2+re(5)**2)
8485           a(4)=sqrt(qcm**2+a(5)**2)
8486
8487           if(ish.ge.6)write(ifch,*)'momentum in rest frame : ',re,a
8488
8489
8490
8491 c Fix a of string
8492
8493 c boost string in collision frame
8494         call utlob2(-1,p1(1),p1(2),p1(3),p1(4),p1(5)
8495      $       ,a(1),a(2),a(3),a(4),73)
8496
8497          p5sq=(a(4)+a(3))*(a(4)-a(3))-(a(1)**2.d0+a(2)**2.d0)
8498          if(p5sq.gt.ampt2str)then
8499            a(5)=sqrt(p5sq)
8500          else
8501            if(ish.ge.6)then
8502              write(ifch,*)'Pb with string mass -> retry'
8503              write(ifch,*)'   m^2:',p5sq,'  m_min^2:',ampt2str
8504              write(ifch,*)'   momentum four vector:',(a(ii),ii=1,4)
8505            endif
8506            goto 777
8507          endif
8508
8509 c Fix ep of droplet
8510
8511 c boost droplet in collision frame
8512         call utlob2(-1,p1(1),p1(2),p1(3),p1(4),p1(5)
8513      $       ,re(1),re(2),re(3),re(4),74)
8514
8515          p5sq=(re(4)+re(3))*(re(4)-re(3))-(re(1)*re(1)+re(2)*re(2))
8516          if(p5sq.gt.ampt2dro)then
8517            re(5)=sqrt(p5sq)
8518          else
8519            if(ish.ge.6)then
8520              write(ifch,*)'Pb with droplet mass -> retry'
8521              write(ifch,*)'   m^2:',p5sq,'  m_min^2:',ampt2dro
8522              write(ifch,*)'   momentum four vector:',(re(ii),ii=1,4)
8523            endif
8524            goto 777
8525          endif
8526
8527        endif     !test of xm
8528
8529
8530        if(ish.ge.1.and.abs(ep(4)-re(4)-a(4)).gt.1.e-2*ep(4))then
8531          write(ifmt,*)'Pb with energy conservation in getdropx'
8532          if(ish.ge.6)then
8533            write(ifch,*)'Pb with energy conservation :'
8534            write(ifch,*)'   p1_ini:',ep(1),'  p1:',re(1)+a(1)
8535            write(ifch,*)'   p2_ini:',ep(2),'  p2:',re(2)+a(2)
8536            write(ifch,*)'   p3_ini:',ep(3),'  p3:',re(3)+a(3)
8537          endif
8538        endif
8539
8540 c If OK, save flavors of droplet and string
8541          do i=1,5
8542            ep(i)=re(i)
8543          enddo
8544          ic(1)=icx(1)
8545          ic(2)=icx(2)
8546          do i=1,nflav
8547            jc(i,1)=jcini(i,1)
8548            jc(i,2)=jcini(i,2)
8549            jcv(i,1)=jcvfin(i,1)
8550            jcv(i,2)=jcvfin(i,2)
8551          enddo
8552
8553          if(ish.ge.6)then
8554            write(ifch,20)'droplet:',jc,ep
8555            write(ifch,30)'string remnant:',ic,a
8556            write(ifch,'(a)')'valence:'
8557            write(ifch,'(6i3)')jcv
8558          endif
8559  20      format(a,/,'jc:',6i3,' |',6i3,/,'ep:',5(e10.3,1x))
8560  30      format(a,/,'ic:',i7,' |',i7,/,'a:',5(e10.3,1x))
8561
8562  1000    continue
8563          call utprix('getdrx',ish,ishini,4)
8564          end
8565
8566 c-----------------------------------------------------
8567        subroutine neworder(n1, n2, n3)
8568 c-----------------------------------------------------
8569 c make 3 integers ordered like 1 2 3
8570 c------------------------------------------------------
8571             if(n2.lt.n1)then
8572               ifb=n2
8573               n2=n1
8574               n1=ifb
8575             endif
8576             if(n3.lt.n1)then
8577               ifb=n3
8578               n3=n2
8579               n2=n1
8580               n1=ifb
8581             elseif(n3.lt.n2)then
8582               ifb=n3
8583               n3=n2
8584               n2=ifb
8585             endif
8586          end
8587
8588 c-----------------------------------------------------
8589        subroutine neworderx(x1,x2,x3,i1,i2,i3)
8590 c-----------------------------------------------------
8591 c make 3 reals ordered like 1 2 3
8592 c------------------------------------------------------
8593             if(x2.lt.x1)then
8594               xfb=x2
8595               x2=x1
8596               x1=xfb
8597               ifb=i2
8598               i2=i1
8599               i1=ifb
8600             endif
8601             if(x3.lt.x1)then
8602               xfb=x3
8603               x3=x2
8604               x2=x1
8605               x1=xfb
8606               ifb=i3
8607               i3=i2
8608               i2=i1
8609               i1=ifb
8610             elseif(x3.lt.x2)then
8611               xfb=x3
8612               x3=x2
8613               x2=xfb
8614               ifb=i3
8615               i3=i2
8616               i2=ifb
8617             endif
8618          end
8619
8620 c-----------------------------------------------------------------------
8621       function idtr2(ic)
8622 c-----------------------------------------------------------------------
8623 c transforms ic to id such that only hadrons have nonzero id
8624 c-----------------------------------------------------------------------
8625       parameter (nidt=30)
8626       integer idt(3,nidt),ic(2)
8627       data idt/
8628      * 100000,100000, 110   ,100000,010000, 120   ,010000,010000, 220
8629      *,100000,001000, 130   ,010000,001000, 230   ,001000,001000, 330
8630      *,100000,000100, 140   ,010000,000100, 240   ,001000,000100, 340
8631      *,000100,000100, 440
8632      *,300000,000000,1111   ,210000,000000,1120   ,120000,000000,1220
8633      *,030000,000000,2221   ,201000,000000,1130   ,111000,000000,1230
8634      *,021000,000000,2230   ,102000,000000,1330   ,012000,000000,2330
8635      *,003000,000000,3331   ,200100,000000,1140   ,110100,000000,1240
8636      *,020100,000000,2240   ,101100,000000,1340   ,011100,000000,2340
8637      *,002100,000000,3340   ,100200,000000,1440   ,010200,000000,2440
8638      *,001200,000000,3440   ,000300,000000,4441/
8639
8640       idtr2=0
8641       if(ic(1).eq.0.and.ic(2).eq.0)then
8642        if(rangen().ge.0.5)then
8643         idtr2=110
8644         ic(1)=100000
8645         ic(2)=100000
8646        else
8647         idtr2=220
8648         ic(1)=10000
8649         ic(2)=10000
8650        endif
8651        return
8652       endif
8653       do 1 i=1,nidt
8654        if(ic(2).eq.idt(1,i).and.ic(1).eq.idt(2,i))idtr2=-idt(3,i)
8655        if(ic(1).eq.idt(1,i).and.ic(2).eq.idt(2,i))idtr2=idt(3,i)
8656 1     continue
8657       return
8658       end
8659
8660 c----------------------------------------------------------------------
8661       subroutine emsini(e,idpji,idtgi)
8662 c----------------------------------------------------------------------
8663 c  energy-momentum sharing initializations
8664 c----------------------------------------------------------------------
8665       include 'epos.inc'
8666       include 'epos.incems'
8667       include 'epos.incsem'
8668       common/cemsr5/at(0:1,0:5)
8669       common/cems5/plc,s
8670       common/cems10/a(0:ntypmx),b(0:ntypmx),d(0:ntypmx)
8671       common/ems6/ivp0,iap0,idp0,isp0,ivt0,iat0,idt0,ist0
8672       double precision d,a,b,plc,s,amd,dcel,xvpr,xdm,at,xdm2
8673       common/ems3/dcel,ad
8674       common/cems13/xvpr(0:3)
8675
8676
8677 c parameter test
8678
8679       if(nflavems.lt.nrflav)
8680      &   call utstop("nflavems<nrflav : change it in epos-ems !&")
8681
8682
8683 c abreviations
8684
8685       plc=dble(e)
8686       s=plc**2
8687       amd=0.5d0   !dble(delrex) !(large enough in case of strangeness in string end
8688
8689
8690 c alpha (0=0, 1=s, 2=v, 4=d, 8=f)
8691
8692       a(0)=0d0
8693       a(1)=dble(alpsea)
8694       a(2)=dble(alpval)
8695       a(3)= 0.0d0
8696       a(4)=dble(alpdiq)
8697       a(5)=dble(a(4))
8698       a(6)= 0.0d0
8699       a(7)= 0.0d0
8700       a(8)=dble(a(2))
8701       a(9)= 0.0d0
8702
8703 c beta (0=0, 1=s, 2=v, 4=d, 8=f)
8704
8705       b(0)=0.0d0
8706       b(1)=dble(-alpqua)
8707       b(2)=dble(-alpqua)
8708       b(3)=0.0d0
8709       b(4)=0.0d0
8710       b(5)=0.0d0
8711       b(6)=0.0d0
8712       b(7)=0.0d0
8713       b(8)=dble(-alpqua)
8714       b(9)=0.0d0
8715
8716
8717 c alpha_trailing and beta_trailing (0=meson, 1=baryon;
8718 c                                   0=no excit, 1=nondiffr, 2=diffr,
8719 c                                   3=nondiffr split, 5=diffr split)
8720
8721       at(0,0)=0.0d0
8722       at(0,1)=dble(alpndi)
8723       at(0,2)=dble(alpdi)
8724       at(0,3)=dble(alpdro(3))
8725       at(0,4)=10d0
8726       at(0,5)=dble(alpdro(3))
8727       at(1,0)=0.0d0
8728       at(1,1)=dble(alpndi)
8729       at(1,2)=dble(alpdi)
8730       at(1,3)=dble(alpdro(3))
8731       at(1,4)=10d0
8732       at(1,5)=dble(alpdro(3))
8733
8734 c minimal string masses ( i+j, each one: 0=0, 1=s, 2=v, 4=d, 5=d, 8=f)
8735
8736       ammn(0)=0d0
8737       ammn(1)=0d0
8738       ammn(2)=dble(ammsqq)+amd
8739       ammn(3)=dble(ammsqq)
8740       ammn(4)=dble(ammsqq)
8741       ammn(5)=dble(ammsqd)+amd
8742       ammn(6)=dble(ammsqd)+amd
8743       ammn(7)=0d0
8744       ammn(8)=dble(ammsdd)+amd
8745       ammn(9)=dble(ammsqd)+amd
8746       ammn(10)=dble(ammsqd)+amd
8747       ammn(12)=dble(ammsqd)+amd
8748       ammn(16)=0.14d0
8749
8750 c minimal pomeron masses (0=soft or gg, 1=qg, 2=gq, 3=qq)
8751
8752       amprmn(0)=ammsqq
8753       amprmn(1)=dsqrt(4d0*dble(q2min))
8754       amprmn(2)=amprmn(1)
8755       amprmn(3)=amprmn(1)
8756
8757 c cutoff for virtual pomeron (0=0, 1=soft Pom, 2=regge, 3=hard)
8758
8759 c      xvpr(0)=0d0
8760 c      xvpr(1)=dble(cumpom**2)/s
8761 c      xvpr(2)=dble(cumpom**2)/s
8762 c      xvpr(3)=0.0d0**2/s
8763
8764 c minimal remnant masses (0=meson, 1=baryon)
8765
8766       idpj=idpji
8767       xdm=0.35d0                  !<pt>
8768       call idmass(idpj,ampj)
8769       if(iabs(idpj).gt.1000)then
8770        ampmn(0)=0.14d0+xdm
8771        ampmn(1)=dble(ampj)+xdm
8772       else
8773        ampmn(0)=dble(ampj)+xdm
8774        ampmn(1)=0.94d0+xdm
8775       endif
8776       idtg=idtgi
8777       if(idtg.eq.0)idtg=1120
8778       call idmass(idtg,amtg)
8779       if(iabs(idtg).gt.1000)then
8780        amtmn(0)=0.14d0+xdm
8781        amtmn(1)=dble(amtg)+xdm
8782       else
8783        amtmn(0)=dble(amtg)+xdm
8784        amtmn(1)=0.94d0+xdm
8785       endif
8786
8787 c minimal excitation masses (0=meson, 1=baryon
8788 c                            0=no excit, 1=nondiffr, 2=diffr,
8789 c                                   6=nondiffr but no pomeron)
8790
8791       xdm2=0.35d0
8792       amemn(0,0)=0.d0
8793       amemn(1,0)=0.d0
8794       amemn(0,4)=0.d0
8795       amemn(1,4)=0.d0
8796       amemn(0,6)=0.d0
8797       amemn(1,6)=0.d0
8798
8799       amemn(0,1)=xdm2!+dble(delrex)
8800       amemn(0,2)=xdm2!+dble(delrex)
8801       amemn(0,3)=xdm2!+dble(delrex)
8802       amemn(0,5)=xdm2+dble(delrex) !remnant excited without connexion (split)
8803
8804       amemn(1,1)=xdm2!+dble(delrex)
8805       amemn(1,2)=xdm2!+dble(delrex)
8806       amemn(1,3)=xdm2!+dble(delrex)
8807       amemn(1,5)=xdm2+dble(delrex) !remnant excited without connexion (split)
8808
8809 c maximal excitation masses (0=no excit, 1=nondiffr, 2=diffr)
8810
8811       amemx(0)=2d0*xdm
8812       amemx(1)=plc
8813       amemx(2)=plc
8814
8815       if(idpj.gt.1000)then     ! baryon
8816
8817 c initial quark configuration
8818        ivp0=3
8819        iap0=0
8820        idp0=1
8821        isp0=1
8822
8823 c no val quark for exotic projectile
8824        if(iremn.ge.2.and.(idpj.ne.1120.and.idpj.ne.1220))ivp0=0
8825
8826       elseif(idpj.lt.-1000)then     ! antibaryon
8827
8828 c initial quark configuration
8829        ivp0=0
8830        iap0=3
8831        idp0=1
8832        isp0=1
8833
8834 c no val quark for exotic projectile
8835        if(iremn.ge.2.and.(idpj.ne.-1120.and.idpj.ne.-1220))iap0=0
8836
8837       else      ! meson
8838
8839 c initial quark configuration
8840        ivp0=1
8841        iap0=1
8842        idp0=0
8843        if(iclpro.eq.1)then
8844          isp0=0
8845        else
8846          isp0=1
8847        endif
8848
8849 c no val quark for exotic projectile
8850        if(iremn.ge.2.and.(mod(abs(idpj/100),10).gt.4
8851      &                 .or.mod(abs(idpj/10),10).gt.4
8852      &    .or.mod(abs(idpj/100),10)/mod(abs(idpj/10),10).eq.1))then
8853          ivp0=0
8854          iap0=0
8855        endif
8856       endif
8857
8858       if(idtg.gt.1000)then    ! baryon
8859
8860 c initial quark configuration
8861        ivt0=3
8862        iat0=0
8863        idt0=1
8864        ist0=0
8865
8866 c no val quark for exotic target
8867        if(iremn.ge.2.and.(idtg.ne.1120.and.idtg.ne.1220))ivt0=0
8868
8869       elseif(idtg.lt.-1000)then   ! antibaryon
8870
8871 c initial quark configuration
8872        ivt0=0
8873        iat0=3
8874        idt0=1
8875        ist0=0
8876
8877 c no val quark for exotic target
8878        if(iremn.ge.2.and.(idtg.ne.-1120.and.idtg.ne.-1220))iat0=0
8879
8880       else       ! meson
8881
8882 c initial quark configuration
8883        ivt0=1
8884        iat0=1
8885        if(icltar.eq.1)then
8886          idt0=0
8887        else
8888          idt0=1
8889        endif
8890        ist0=0
8891
8892 c no val quark for exotic target
8893        if(iremn.ge.2.and.(mod(abs(idtg/100),10).gt.4
8894      &                 .or.mod(abs(idtg/10),10).gt.4
8895      &    .or.mod(abs(idtg/100),10)/mod(abs(idtg/10),10).eq.1))then
8896          ivt0=0
8897          iat0=0
8898        endif
8899
8900       endif
8901
8902
8903 c eikonal parameters
8904
8905        dcel=dble(chad(iclpro)*chad(icltar))
8906
8907 c counters
8908
8909        antot=0.
8910        ansh=0.
8911        ansf=0.
8912        antotf=0.
8913        anshf=0.
8914        ansff=0.
8915        pp4max=0.
8916        pp4ini=0.
8917        andropl=0.
8918        anstrg0=0.
8919        anstrg1=0.
8920        anreso0=0.
8921        anreso1=0.
8922        anghadr=0.
8923        antotre=0.
8924        anintdiff=0.
8925        anintsdif=0.
8926        anintine=0.
8927
8928       return
8929       end
8930
8931 c-----------------------------------------------------------------------
8932       subroutine emsigr
8933 c-----------------------------------------------------------------------
8934 c initialize grid
8935 c-----------------------------------------------------------------------
8936
8937       include 'epos.inc'
8938       include 'epos.incems'
8939
8940       common/emsptl/nppr(npommx,kollmx),npproj(mamx),nptarg(mamx)
8941
8942       call utpri('emsigr',ish,ishini,5)
8943
8944       do k=1,koll  !----k-loop---->
8945
8946 c determine length of k-th line of grid
8947
8948        o=max(1.e-5,min(sngl(om1intc(k)),float(npommx)))!if GFF used for propo
8949         if(ish.ge.7)write(ifch,*)'emsigr:k,o',k,o
8950        n=0
8951        if(o.le.50)then
8952          p=1./(exp(o)-1)
8953        else
8954          p=0.
8955        endif
8956 10     n=n+1
8957        p=p*o/n
8958         if(ish.ge.7)write(ifch,*)'emsigr:n,p',n,p
8959        if((p.gt.1e-4.or.n.lt.int(o)).and.n.lt.npommx
8960      *.and.n.lt.nprmax)goto 10
8961
8962        if(ish.ge.5)write(ifch,*)'emsigr:nmax,b',n,bk(k)
8963
8964        npr(0,k)=n
8965        nprmx(k)=n
8966        nprt(k)=0
8967        do i=1,3
8968         npr(i,k)=0
8969        enddo
8970
8971
8972 c initial value for interaction type
8973
8974        itpr(k)=0
8975
8976 c initial value for nuclear splitting
8977
8978        do ir=1,2
8979          knucnt(ir,k)=0
8980          do ncon=1,mamx
8981            npnuc(ncon,ir,k)=0
8982            irnuc(ncon,ir,k)=0
8983            xxnuc(ncon,ir,k)=0d0
8984          enddo
8985        enddo
8986
8987 c initialize grid
8988
8989
8990        do n=1,nprmx(k)
8991         idpr(n,k)=0
8992         idfpr(n,k)=0
8993         ivpr(n,k)=1
8994         nppr(n,k)=0
8995         nbkpr(n,k)=0
8996         nvpr(n,k)=0
8997         idsppr(n,k)=0
8998         idstpr(n,k)=0
8999         idrpr(n,k)=0
9000         idhpr(n,k)=0
9001         bhpr(n,k)=0.
9002         xpr(n,k)=0d0
9003         ypr(n,k)=0d0
9004         xppr(n,k)=0d0
9005         xmpr(n,k)=0d0
9006         xp1pr(n,k)=0d0
9007         xp2pr(n,k)=0d0
9008         xm1pr(n,k)=0d0
9009         xm2pr(n,k)=0d0
9010         xp1pr(n,k)=0d0
9011         xp2pr(n,k)=0d0
9012         xm1pr(n,k)=0d0
9013         xm2pr(n,k)=0d0
9014         idp1pr(n,k)=0
9015         idp2pr(n,k)=0
9016         idm1pr(n,k)=0
9017         idm2pr(n,k)=0
9018         xxp1pr(n,k)=0d0
9019         xyp1pr(n,k)=0d0
9020         xxp2pr(n,k)=0d0
9021         xyp2pr(n,k)=0d0
9022         xxm1pr(n,k)=0d0
9023         xym1pr(n,k)=0d0
9024         xxm2pr(n,k)=0d0
9025         xym2pr(n,k)=0d0
9026        enddo
9027
9028       enddo !  <----k-loop-----
9029
9030       call utprix('emsigr',ish,ishini,5)
9031       return
9032       end
9033
9034 c-----------------------------------------------------------------------
9035       subroutine emsipt
9036 c-----------------------------------------------------------------------
9037 c initialize projectile and target
9038 c-----------------------------------------------------------------------
9039
9040       include 'epos.inc'
9041       include 'epos.incems'
9042
9043       common/emsptl/nppr(npommx,kollmx),npproj(mamx),nptarg(mamx)
9044       common/cems5/plc,s
9045       common/ems3/dcel,ad
9046       common/ems6/ivp0,iap0,idp0,isp0,ivt0,iat0,idt0,ist0
9047       common /cncl/xproj(mamx),yproj(mamx),zproj(mamx)
9048      *            ,xtarg(mamx),ytarg(mamx),ztarg(mamx)
9049
9050       double precision dcel,s,plc
9051
9052 c initialize projectile
9053
9054       do i=1,maproj
9055        idp(i)=idp0
9056        ivp(i)=ivp0+iap0
9057        iap(i)=iap0
9058        isp(i)=isp0
9059        iep(i)=-1
9060        ifp(i)=0
9061        kolp(i)=0
9062        npp(i)=0
9063        npproj(i)=0
9064        xxp(i)=0d0
9065        xyp(i)=0d0
9066        xpmn(i)=(amemn(idp(i),0)+ampmn(isp(i)))**2/s
9067        xpmx(i)=dmin1(1d0,(amemx(0)+ampmn(isp(i)))**2/s)
9068        xpos(i)=0.9d0*(amemx(0)+ampmn(isp(i)))**2/s
9069        xppmx(i)=0.5d0/(1d0+1d0/dble(maproj)**0.3d0)!1d0-dsqrt(xpmn(i))/maproj
9070        xmpmx(i)=0.5d0/(1d0+1d0/dble(matarg)**0.3d0)!1d0-dsqrt(xpmn(i))/matarg
9071        xmpmn(i)=xpmn(i)/xppmx(i)
9072        xppmn(i)=xpmn(i)/xmpmx(i)
9073        xpp(i)=1d0
9074        xmp(i)=0d0
9075        xppst(i)=0.d0
9076        xmpst(i)=0.d0
9077        xposst(i)=0.d0
9078       enddo
9079
9080 c initialize target
9081
9082       do j=1,matarg
9083        idt(j)=idt0
9084        ivt(j)=ivt0+iat0
9085        iat(j)=iat0
9086        ist(j)=ist0
9087        iet(j)=-1
9088        ift(j)=0
9089        kolt(j)=0
9090        npt(j)=0
9091        nptarg(j)=0
9092        xxt(j)=0d0
9093        xyt(j)=0d0
9094        xtmn(j)=(amemn(idt(j),0)+amtmn(ist(j)))**2/s
9095        xtmx(j)=dmin1(1d0,(amemx(0)+amtmn(ist(j)))**2/s)
9096        xtos(j)=0.9d0*(amemx(0)+amtmn(ist(j)))**2/s
9097        xmtmx(j)=0.5d0/(1d0+1d0/dble(matarg)**0.3d0)!1d0-dsqrt(xtmn(j))/matarg
9098        xptmx(j)=0.5d0/(1d0+1d0/dble(maproj)**0.3d0)!1d0-dsqrt(xtmn(j))/maproj
9099        xptmn(j)=xtmn(j)/xmtmx(j)
9100        xmtmn(j)=xtmn(j)/xptmx(j)
9101        xmt(j)=1d0
9102        xpt(j)=0d0
9103        xmtst(j)=0.d0
9104        xptst(j)=0.d0
9105        xtosst(j)=0.d0
9106       enddo
9107
9108       return
9109       end
9110
9111
9112 c-----------------------------------------------------------------------
9113       subroutine emszz
9114 c-----------------------------------------------------------------------
9115 c     completes /cptl/ for nucleons, checks for no interaction
9116 c     writes   /cevt/
9117 c-----------------------------------------------------------------------
9118       include 'epos.inc'
9119       include 'epos.incems'
9120       common/nucl3/phi,bimp
9121       common/col3/ncol,kolpt
9122       integer kolpz(mamx),koltz(mamx)
9123
9124       call utpri('emszz ',ish,ishini,6)
9125
9126 c     write /cptl/
9127 c     ------------
9128
9129       if(iokoll.eq.1)then   ! precisely matarg collisions
9130
9131 c nothing to do
9132         ntg=0
9133         npj=0
9134         ncoli=0
9135
9136       else
9137
9138 c determine ncol
9139
9140        ncolx=ncol
9141        ncol=0
9142        ncoli=0
9143        do 8 k=1,koll
9144        if(ish.ge.7)write(ifch,*)'k,itpr,ncol,ncolx',k,itpr(k),ncol,ncolx
9145         if(itpr(k).eq.0)goto 8
9146         if(abs(itpr(k)).eq.1)ncoli=ncoli+1
9147           ncol=ncol+1
9148           if(itpr(k).ne.3)then          !empty pair, remnant not modified
9149             i=iproj(k)
9150             j=itarg(k)
9151             istptl(i)=1
9152             iorptl(i)=-1
9153             tivptl(2,i)=coord(4,k)
9154             istptl(maproj+j)=1
9155             iorptl(maproj+j)=-1
9156             tivptl(2,maproj+j)=coord(4,k)
9157           endif
9158 8      continue
9159        if(ncolx.ne.ncol)write(6,*)'ncolx,ncol:', ncolx,ncol
9160        if(ncolx.ne.ncol)call utstop('********ncolx.ne.ncol********&')
9161        if(ncol.eq.0)goto1001
9162
9163 c determine npj, ntg
9164
9165        do ip=1,maproj
9166         kolpz(ip)=0
9167        enddo
9168        do it=1,matarg
9169         koltz(it)=0
9170        enddo
9171       do k=1,koll
9172        if(itpr(k).ne.0.and.itpr(k).ne.3)then
9173         ip=iproj(k)
9174         it=itarg(k)
9175         kolpz(ip)=kolpz(ip)+1
9176         koltz(it)=koltz(it)+1
9177        endif
9178       enddo
9179       npj=0
9180       do ip=1,maproj
9181        if(kolpz(ip).gt.0.or.iep(ip).ge.3)npj=npj+1
9182       enddo
9183       ntg=0
9184       do it=1,matarg
9185        if(koltz(it).gt.0.or.iet(it).ge.3)ntg=ntg+1
9186       enddo
9187 c     write(6,*)'npj,ntg,npj+ntg:',npj,ntg,npj+ntg
9188
9189        endif
9190
9191 c     write /cevt/
9192 c     ------------
9193
9194       nevt=1
9195       bimevt=bimp
9196       phievt=phi
9197       kolevt=ncol
9198       koievt=ncoli
9199       kohevt=0      !not yet defined
9200       npjevt=npj
9201       ntgevt=ntg
9202       pmxevt=pnll
9203       egyevt=engy
9204       !print*,' ===== ',kolevt,koievt' ====='
9205
9206 c     exit
9207 c     ----
9208
9209       if(ish.ge.7)then
9210       do n=1,nptl
9211       write(ifch,115)iorptl(n),jorptl(n),n,istptl(n)
9212      *,tivptl(1,n),tivptl(2,n)
9213       enddo
9214   115 format(1x,'/cptl/',2i6,2i10,2(e10.3,1x))
9215       endif
9216
9217 1000  continue
9218       call utprix('emszz ',ish,ishini,6)
9219       return
9220
9221 1001  continue
9222       if(ish.ge.3)then
9223       write(ifch,*)
9224       write(ifch,*)'   ***** no interaction!!!'
9225       write(ifch,*)'   ***** ncol=0 detected in emszz'
9226       write(ifch,*)
9227       endif
9228       goto 1000
9229
9230       end
9231
9232 c-----------------------------------------------------------------------
9233       subroutine ProCop(i,ii)
9234 c-----------------------------------------------------------------------
9235 c Propose Coordinates of remnants from active projectile nucleons
9236 c-----------------------------------------------------------------------
9237
9238       include 'epos.inc'
9239       include 'epos.incems'
9240       include 'epos.incsem'
9241
9242       double precision xmptmp,aproj
9243       common/cems5/plc,s
9244       common/emsptl/nppr(npommx,kollmx),npproj(mamx),nptarg(mamx)
9245       integer icrmn(2),jc(nflav,2),icini(2)
9246       double precision s,plc
9247
9248       nptl=nptl+1
9249       npproj(i)=nptl
9250       idptl(nptl)=idptl(ii)*100+99  !100*10**idp(i)+iep(i)
9251       istptl(nptl)=40
9252       ityptl(nptl)=40
9253       iorptl(nptl)=ii
9254       jorptl(nptl)=0
9255       ifrptl(1,nptl)=0
9256       ifrptl(2,nptl)=0
9257       do j=1,2
9258         do k=1,nflav
9259           jc(k,j)=0
9260         enddo
9261       enddo
9262
9263       istptl(ii)=1
9264
9265 c     determine kolz
9266
9267       if(lproj(i).gt.1)then
9268         zmax=-ainfin
9269         kolz=0
9270         do l=1,lproj(i)
9271           k=kproj(i,l)
9272           z=coord(3,k)
9273           if(itpr(k).ne.0.and.z.gt.zmax)then
9274             zmax=z
9275             kolz=k
9276           endif
9277         enddo
9278       else
9279         kolz=1
9280       endif
9281 c      if(kolz.eq.0)call utstop(' kolz=0 (proj)&')
9282       if(kolz.eq.0)then
9283         t=0.
9284       else
9285         t=coord(4,kolz)
9286       endif
9287
9288       xorptl(1,nptl)=xorptl(1,ii)
9289       xorptl(2,nptl)=xorptl(2,ii)
9290       xorptl(3,nptl)=xorptl(3,ii)
9291       xorptl(4,nptl)=t
9292       tivptl(1,nptl)=t
9293       tivptl(2,nptl)=t
9294       naq=0
9295       nqu=0
9296
9297       if(iremn.ge.2)then   !update icproj
9298         idp(i)=min(1,abs(idp(i)))
9299         k=1
9300         nqu=0
9301         do n=1,nrflav
9302           jc(n,k)=jcpref(n,k,i)
9303           nqu=nqu+jc(n,k)
9304         enddo
9305         k=2
9306         naq=0
9307         do n=1,nrflav
9308           jc(n,k)=jcpref(n,k,i)
9309           naq=naq+jc(n,k)
9310         enddo
9311         isum=nqu+naq
9312         call idenco(jc,icrmn,iret)
9313         if(iret.eq.0.and.(isum.le.3.or.iremn.ne.3))then
9314           icproj(1,i)=icrmn(1)
9315           icproj(2,i)=icrmn(2)
9316         elseif(iremn.eq.3)then
9317       write(ifch,*)'Problem in projectile flavor :',i,' ->',jc,' :',isum
9318           call utstop('Procop: Problem in projectile flavor !&')
9319         else     !for iremn=2 and large number of quark define icproj=999999
9320           icproj(1,i)=999999
9321           icproj(2,i)=999999
9322         endif
9323       endif
9324
9325       icrmn(1)=icproj(1,i)
9326       icrmn(2)=icproj(2,i)
9327
9328       if(iremn.ge.1)then      !excited remnant ?
9329         call idtr4(idptl(ii),icini)
9330         if(ish.ge.5)write(ifch,*)'Procop icini proj',i,icini,' ->',icrmn
9331         if((icrmn(1)-icini(1))+(icrmn(2)-icini(2)).ne.0)then
9332           if(iep(i).eq.6)then
9333             write(ifch,'(a,d25.15)')
9334      &'Flavor problem in proj for pseudo-inelastic collision !',seedc
9335           elseif(iep(i).eq.0)then
9336             iep(i)=1
9337           endif
9338         endif
9339
9340         if(iremn.eq.2)then
9341           if(.not.((nqu.eq.3.and.naq.eq.0).or.(nqu.eq.0.and.naq.eq.3)
9342      &       .or.(nqu.eq.1.and.naq.eq.1)))iep(i)=3
9343
9344         endif
9345       endif
9346
9347       if(ish.ge.5)write(ifch,'(a,i3,a,i3,a,i2)')
9348      &            'Procop part ',ii,', iep(',i,'): ',iep(i)
9349
9350       if(iremn.le.1)call iddeco(icrmn,jc)
9351       if(iep(i).ge.1.and.iep(i).ne.6)then
9352         aproj=dble(max(amproj,fremnux(jc)))
9353       else
9354         aproj=dble(max(amproj,fremnux2(jc)))
9355       endif
9356 c      aprojex=max(ampmn(isp(i))+amemn(idp(i),iep(i))
9357 c     &           ,dble(fremnux(jc)))
9358       xmptmp=(aproj**2+xxp(i)*xxp(i)+xyp(i)*xyp(i))
9359      &       /(xpp(i)*s)
9360       xpos(i)=xpp(i)*xmptmp
9361       if(ish.ge.5)write(ifch,*)'Procop mass : ',aproj,xpos(i)*s
9362       if(xmptmp.gt.1.d0)then
9363         xmptmp=0.d0
9364       if(ish.ge.1)write(ifmt,*)'Warning in ProCop, Remnant mass too low'
9365       endif
9366
9367       pptl(1,nptl)=sngl(xxp(i))
9368       pptl(2,nptl)=sngl(xyp(i))
9369       pptl(3,nptl)=sngl((xpp(i)-xmptmp)*plc/2d0)
9370       pptl(4,nptl)=sngl((xpp(i)+xmptmp)*plc/2d0)
9371       pptl(5,nptl)=aproj
9372
9373 c      write(ifmt,*)'ProCop',i,nptl
9374
9375       return
9376
9377       end
9378
9379 c-----------------------------------------------------------------------
9380       subroutine ProCot(j,jj)
9381 c-----------------------------------------------------------------------
9382 c Propose Coordinates of remnants from active targets nucleons
9383 c-----------------------------------------------------------------------
9384
9385       include 'epos.inc'
9386       include 'epos.incems'
9387       include 'epos.incsem'
9388
9389       double precision xpttmp,atarg
9390       common/cems5/plc,s
9391       common/emsptl/nppr(npommx,kollmx),npproj(mamx),nptarg(mamx)
9392       integer icrmn(2),jc(nflav,2),icini(2)
9393       double precision s,plc
9394
9395       nptl=nptl+1
9396       nptarg(j)=nptl
9397
9398       idptl(nptl)=idptl(jj)*100+99    !100*10**idt(j)+iet(j)
9399       istptl(nptl)=40
9400       ityptl(nptl)=50
9401       iorptl(nptl)=jj
9402       jorptl(nptl)=0
9403       ifrptl(1,nptl)=0
9404       ifrptl(2,nptl)=0
9405       do k=1,2
9406         do i=1,nflav
9407           jc(i,k)=0
9408         enddo
9409       enddo
9410
9411       istptl(jj)=1
9412
9413 c     determine kolz
9414
9415       if(ltarg(j).gt.1)then
9416         zmin=ainfin
9417         kolz=0
9418         do l=1,ltarg(j)
9419           k=ktarg(j,l)
9420           z=coord(3,k)
9421           if(itpr(k).ne.0.and.z.lt.zmin)then
9422             zmin=z
9423             kolz=k
9424           endif
9425         enddo
9426       else
9427         kolz=1
9428       endif
9429 c      if(kolz.eq.0)call utstop(' kolz=0 (targ)&')
9430       if(kolz.eq.0)then
9431         t=0.
9432       else
9433         t=coord(4,kolz)
9434       endif
9435
9436       xorptl(1,nptl)=xorptl(1,jj)
9437       xorptl(2,nptl)=xorptl(2,jj)
9438       xorptl(3,nptl)=xorptl(3,jj)
9439       xorptl(4,nptl)=t
9440       tivptl(1,nptl)=t
9441       tivptl(2,nptl)=t
9442       naq=0
9443       nqu=0
9444
9445       if(iremn.ge.2)then   !update ictarg
9446         idt(j)=min(1,abs(idt(j)))
9447         k=1
9448         nqu=0
9449         do n=1,nrflav
9450           jc(n,k)=jctref(n,k,j)
9451           nqu=nqu+jc(n,k)
9452         enddo
9453         k=2
9454         naq=0
9455         do n=1,nrflav
9456           jc(n,k)=jctref(n,k,j)
9457           naq=naq+jc(n,k)
9458         enddo
9459         isum=nqu+naq
9460         call idenco(jc,icrmn,iret)
9461         if(iret.eq.0.and.(isum.le.3.or.iremn.ne.3))then
9462           ictarg(1,j)=icrmn(1)
9463           ictarg(2,j)=icrmn(2)
9464         elseif(iremn.eq.3)then
9465       write(ifch,*)'Problem in projectile flavor :',j,' ->',jc,' :',isum
9466           call utstop('Procot: Problem in target flavor !&')
9467         else     !for iremn=2 and large number of quark define ictarg=999999
9468           ictarg(1,j)=999999
9469           ictarg(2,j)=999999
9470         endif
9471       endif
9472
9473       icrmn(1)=ictarg(1,j)
9474       icrmn(2)=ictarg(2,j)
9475
9476       if(iremn.ge.1)then      !excited remnant ?
9477         call idtr4(idptl(jj),icini)
9478         if(ish.ge.5)write(ifch,*)'Procot icini targ',j,icini,' ->',icrmn
9479         if((icrmn(1)-icini(1))+(icrmn(2)-icini(2)).ne.0)then
9480           if(iet(j).eq.6)then
9481             write(ifch,'(a,d25.15)')
9482      &'Flavor problem in targ for pseudo-inelastic collision !',seedc
9483           elseif(iet(j).eq.0)then
9484             iet(j)=1
9485           endif
9486         endif
9487
9488         if(iremn.eq.2)then
9489           if(.not.((nqu.eq.3.and.naq.eq.0).or.(nqu.eq.0.and.naq.eq.3)
9490      &       .or.(nqu.eq.1.and.naq.eq.1)))iet(j)=3
9491
9492         endif
9493       endif
9494       if(ish.ge.5)write(ifch,'(a,i3,a,i3,a,i2)')
9495      &            'Procot part ',jj,', iet(',j,'): ',iet(j)
9496
9497
9498
9499       if(iremn.le.1)call iddeco(icrmn,jc)
9500       if(iet(j).ge.1.and.iet(j).ne.6)then
9501         atarg=dble(max(amtarg,fremnux(jc)))
9502       else
9503         atarg=dble(max(amtarg,fremnux2(jc)))
9504       endif
9505 c      atargex=max(amtmn(ist(j))+amemn(idt(j),iet(j))
9506 c     &           ,dble(fremnux(jc)))
9507       xpttmp=(atarg**2+xxt(j)*xxt(j)+xyt(j)*xyt(j))
9508      &       /(xmt(j)*s)
9509       xtos(j)=xpttmp*xmt(j)
9510       if(ish.ge.5)write(ifch,*)'Procot mass : ',atarg,xtos(j)*s
9511       if(xpttmp.gt.1.d0)then
9512         xpttmp=0.d0
9513       if(ish.ge.1)write(ifch,*)'Warning in ProCot, Remnant mass too low'
9514       endif
9515
9516       pptl(1,nptl)=sngl(xxt(j))
9517       pptl(2,nptl)=sngl(xyt(j))
9518       pptl(3,nptl)=sngl((xpttmp-xmt(j))*plc/2d0)
9519       pptl(4,nptl)=sngl((xpttmp+xmt(j))*plc/2d0)
9520       pptl(5,nptl)=atarg
9521
9522 c      write(ifmt,*)'ProCot',j,nptl
9523
9524       return
9525       end
9526
9527 c-----------------------------------------------------------------------
9528       subroutine emswrp(i,ii)
9529 c-----------------------------------------------------------------------
9530
9531       include 'epos.inc'
9532       include 'epos.incems'
9533
9534       double precision p5sq
9535       common/cems5/plc,s
9536       common/emsptl/nppr(npommx,kollmx),npproj(mamx),nptarg(mamx)
9537       double precision s,plc
9538       parameter(eps=1.e-5)
9539
9540       if(npproj(i).eq.0)then
9541         write(*,*)'emswrp i ii',i,ii
9542         call utstop('emswrp with npproj=0 should never happen !&')
9543
9544 c        t=xorptl(4,kolp(i))
9545 c        istptl(ii)=1
9546 c        iorptl(ii)=-1
9547 c        tivptl(2,ii)=t
9548 c        nptl=nptl+1
9549 c        npproj(i)=nptl
9550 c        idptl(nptl)=idptl(ii)*100+99 !100*10**idp(i)+iep(i)
9551 c        istptl(nptl)=40
9552 c        ityptl(nptl)=40
9553 c        iorptl(nptl)=ii
9554 c        jorptl(nptl)=kolp(i)
9555 c        ifrptl(1,nptl)=0
9556 c        ifrptl(2,nptl)=0
9557 c        xorptl(1,nptl)=xorptl(1,ii)
9558 c        xorptl(2,nptl)=xorptl(2,ii)
9559 c        xorptl(3,nptl)=xorptl(3,ii)
9560 c        xorptl(4,nptl)=t
9561 c        tivptl(1,nptl)=t
9562 c        tivptl(2,nptl)=t
9563         mm=nptl
9564 c        kolp(i)=1
9565       else
9566         mm=npproj(i)
9567       endif
9568       if(iLHC.eq.1.and.(iep(i).eq.0.or.iep(i).eq.6))
9569      &xmp(i)=min(1d0-xpp(i),xmp(i))
9570       pptl(1,mm)=sngl(xxp(i))
9571       pptl(2,mm)=sngl(xyp(i))
9572       pptl(3,mm)=sngl((xpp(i)-xmp(i))*plc/2d0)
9573       pptl(4,mm)=sngl((xpp(i)+xmp(i))*plc/2d0)
9574       if(pptl(4,mm).lt.-eps)call utstop('E pro<0 !&')
9575       p5sq=xpp(i)*xmp(i)*s-xxp(i)*xxp(i)-xyp(i)*xyp(i)
9576       if(p5sq.gt.1.d-10)then
9577         pptl(5,mm)=sngl(sqrt(p5sq))
9578       elseif(iep(i).eq.0)then
9579         pptl(5,mm)=pptl(5,ii)
9580       else
9581         if(ish.ge.2)then
9582           write(ifch,*)'problem with mass for projectile, '
9583      &         ,'continue with zero mass'
9584           write(ifch,*)i,mm,xxp(i),xyp(i),xpp(i),xmp(i),p5sq
9585         endif
9586         pptl(5,mm)=0.
9587       endif
9588
9589       do l=1,4
9590        ibptl(l,mm)=0
9591       enddo
9592
9593       return
9594
9595       end
9596
9597 c-----------------------------------------------------------------------
9598       subroutine emswrt(j,jj)
9599 c-----------------------------------------------------------------------
9600
9601       include 'epos.inc'
9602       include 'epos.incems'
9603
9604       double precision p5sq
9605       common/cems5/plc,s
9606       common/emsptl/nppr(npommx,kollmx),npproj(mamx),nptarg(mamx)
9607       double precision s,plc
9608       parameter(eps=1.e-5)
9609
9610       if(nptarg(j).eq.0)then
9611
9612         write(*,*)'emswrt j jj',j,jj
9613         call utstop('emswrt with nptarg=0 should never happen !&')
9614
9615 c        t=xorptl(4,kolt(j))
9616 c        istptl(jj)=1
9617 c        iorptl(jj)=-1
9618 c        tivptl(2,jj)=t
9619 c        nptl=nptl+1
9620 c        nptarg(j)=nptl
9621 c        idptl(nptl)=idptl(jj)*100+99 !100*10**idp(i)+iep(i)
9622 c        istptl(nptl)=40
9623 c        ityptl(nptl)=50
9624 c        iorptl(nptl)=jj
9625 c        jorptl(nptl)=kolt(j)
9626 c        ifrptl(1,nptl)=0
9627 c        ifrptl(2,nptl)=0
9628 c        xorptl(1,nptl)=xorptl(1,jj)
9629 c        xorptl(2,nptl)=xorptl(2,jj)
9630 c        xorptl(3,nptl)=xorptl(3,jj)
9631 c        xorptl(4,nptl)=t
9632 c        tivptl(1,nptl)=t
9633 c        tivptl(2,nptl)=t
9634 c... initialize
9635         mm=nptl
9636 c        kolt(j)=1
9637       else
9638         mm=nptarg(j)
9639       endif
9640       if(iLHC.eq.1.and.(iet(j).eq.0.or.iet(j).eq.6))
9641      &xpt(j)=min(1d0-xmt(j),xpt(j))
9642       pptl(1,mm)=sngl(xxt(j))
9643       pptl(2,mm)=sngl(xyt(j))
9644       pptl(3,mm)=sngl((xpt(j)-xmt(j))*plc/2d0)
9645       pptl(4,mm)=sngl((xpt(j)+xmt(j))*plc/2d0)
9646       if(pptl(4,mm).lt.-eps)call utstop('E targ<0 !&')
9647       p5sq=xpt(j)*xmt(j)*s-xxt(j)*xxt(j)-xyt(j)*xyt(j)
9648       if(p5sq.gt.1.d-10)then
9649         pptl(5,mm)=sngl(sqrt(p5sq))
9650       elseif(iet(j).eq.0)then
9651         pptl(5,mm)=pptl(5,jj)
9652       else
9653         if(ish.ge.2)then
9654           write(ifch,*)'problem with mass for target, '
9655      &            ,'continue with zero mass'
9656           write(ifch,*)j,mm,xxt(j),xyt(j),xpt(j),xmt(j),p5sq
9657         endif
9658         pptl(5,mm)=0.
9659       endif
9660
9661       do l=1,4
9662        ibptl(l,mm)=0
9663       enddo
9664
9665       return
9666       end
9667
9668 c-----------------------------------------------------------------------
9669       subroutine emswrpom(k,i,j)
9670 c-----------------------------------------------------------------------
9671
9672       include 'epos.inc'
9673       include 'epos.incems'
9674
9675       common/cems5/plc,s
9676       common/emsptl/nppr(npommx,kollmx),npproj(mamx),nptarg(mamx)
9677       double precision s,px,py,plc
9678
9679       do 30 n=1,nprmx(k)
9680        if(idpr(n,k).eq.0.or.ivpr(n,k).eq.0)goto30
9681        nptl=nptl+1
9682        nppr(n,k)=nptl
9683        px=xxp1pr(n,k)+xxp2pr(n,k)+xxm1pr(n,k)+xxm2pr(n,k)
9684        py=xyp1pr(n,k)+xyp2pr(n,k)+xym1pr(n,k)+xym2pr(n,k)
9685        pptl(1,nptl)=sngl(px)
9686        pptl(2,nptl)=sngl(py)
9687        pptl(3,nptl)=sngl(dsqrt(xpr(n,k))*dsinh(ypr(n,k))*plc)
9688        pptl(4,nptl)=sngl(dsqrt(xpr(n,k))*dcosh(ypr(n,k))*plc)
9689        pptl(5,nptl)=sngl(dsqrt(xpr(n,k)*s-px*px-py*py))
9690    !    print*,pptl(5,nptl)/plc
9691        idptl(nptl)=idpr(n,k)*10000
9692      &     +idp1pr(n,k)*1000
9693      &     +idp2pr(n,k)*100
9694      &     +idm1pr(n,k)*10
9695      &     +idm2pr(n,k)
9696        idptl(nptl)=idptl(nptl)*100+99
9697        istptl(nptl)=30
9698        iorptl(nptl)=i
9699        jorptl(nptl)=j
9700        ifrptl(1,nptl)=0
9701        ifrptl(2,nptl)=0
9702        xorptl(1,nptl)=coord(1,k)
9703        xorptl(2,nptl)=coord(2,k)
9704        xorptl(3,nptl)=coord(3,k)
9705        xorptl(4,nptl)=coord(4,k)
9706        tivptl(1,nptl)=coord(4,k)
9707        tivptl(2,nptl)=coord(4,k)
9708        if(idpr(n,k).eq.1)then
9709         ityptl(nptl)=20
9710         if(itpr(k).gt.0)ityptl(nptl)=25
9711        elseif(idpr(n,k).eq.3)then
9712         ityptl(nptl)=30
9713         if(itpr(k).gt.0)ityptl(nptl)=35
9714        else
9715         call utstop('emswrpom: unknown id&')
9716        endif
9717        do l = 1,4
9718         ibptl(l,nptl)=0
9719        enddo
9720 30    continue
9721
9722       return
9723       end
9724
9725 c-----------------------------------------------------------------------
9726       subroutine emsfrag(iret)
9727 c-----------------------------------------------------------------------
9728
9729       include 'epos.inc'
9730       include 'epos.incems'
9731       double precision pfrx(mamxx),pfry(mamxx),pfrz(mamxx),xmean,ymean
9732      &                ,zmean,spec
9733       integer          ityp(mamxx)
9734
9735       iret=0
9736
9737 c Projectile fragment(s)
9738
9739       irest = maproj*100+abs(laproj)
9740       inew=0
9741       idrest=0
9742       mapro=maproj
9743       xmean=0d0
9744       ymean=0d0
9745       zmean=0d0
9746       spec=0d0
9747       amrest=0.
9748       imin=maproj
9749       imax=1
9750
9751       do is=1,maproj
9752
9753         if(istptl(is).eq.0)then
9754           if ( iorptl(is) .eq. 0 ) then
9755             if(infragm.eq.0)then   !keep free nucleons
9756 c  copy spectators at the end of the list (necessary for hepmc interface)
9757               nptl=nptl+1
9758               if(nptl.gt.mxptl)then
9759                 iret=1
9760                 goto 1000
9761               endif
9762               call utrepl(nptl,is)
9763               istptl(is)=1
9764               ifrptl(1,is)=nptl
9765               ifrptl(2,is)=nptl
9766               istptl(nptl)=0
9767               iorptl(nptl)=is
9768             else
9769 c  compose projectile spectators to remaining nucleus
9770               spec=spec+1d0
9771               tivptl(2,is)=0d0
9772               xmean=xmean+xorptl(1,is)
9773               ymean=ymean+xorptl(2,is)
9774               zmean=0d0
9775               amrest=amrest+pptl(5,is)
9776               imin=min(imin,is)
9777               imax=max(imax,is)
9778               istptl(is)=1
9779               ifrptl(1,is)=nptl+1
9780               ifrptl(2,is)=nptl+1
9781               idrest = is
9782               id=idptl(is)
9783               if     ( id .eq. 1120 ) then
9784                 inew  = inew + 101
9785                 irest = irest - 101
9786               elseif ( id .eq. 1220 ) then
9787                 inew  = inew + 100
9788                 irest = irest - 100
9789               endif
9790             endif
9791           endif
9792         elseif( iorptl(is) .le. 0  .and.  istptl(is) .eq. 1 ) then
9793           if( iorptl(is) .eq. 0 )jorptl(is)=1
9794           mapro=mapro-1
9795         endif
9796
9797       enddo
9798
9799       if(inew.eq.0)goto 100
9800
9801       xmean=xmean/spec
9802       ymean=ymean/spec
9803       zmean=zmean/spec
9804       nptla=nptl
9805 c prepare intermediate particle to produce nuclear fragment
9806       nptl=nptl+1
9807       if(nptl.gt.mxptl)then
9808         iret=1
9809         goto 1000
9810       endif
9811
9812       if( inew .eq. 100 .or. inew .eq. 101 ) then
9813 c  remaining nucleus is single neutron or proton
9814         call utrepl(nptl,idrest)
9815         ifrptl(1,idrest)=nptl
9816         ifrptl(2,idrest)=nptl
9817         istptl(nptl)=0
9818         iorptl(nptl)=idrest
9819         goto 100
9820
9821       else
9822
9823 c intermediate particles for father/mother relationship
9824         idptl(nptl)=800000000+inew
9825         ea = float(inew/100)*pptl(4,idrest)
9826 c  momenta squared
9827         ptm = sqrt(max(0.,(ea-amrest)*(ea+amrest)))
9828         istptl(nptl)=51
9829         pptl(1,nptl)=0.
9830         pptl(2,nptl)=0.
9831         pptl(3,nptl)=ptm
9832         pptl(4,nptl)=sqrt(pptl(1,nptl)**2+pptl(2,nptl)**2
9833      *                     +pptl(3,nptl)**2+amrest**2)
9834         pptl(5,nptl)=amrest         !mass
9835         ityptl(nptl)=40
9836         iorptl(nptl)=imax
9837         jorptl(nptl)=imax
9838         ifrptl(1,nptl)=nptl+1
9839         ifrptl(2,nptl)=0
9840         xorptl(1,nptl)=0d0
9841         xorptl(2,nptl)=0d0
9842         xorptl(3,nptl)=0d0
9843         xorptl(4,nptl)=0d0
9844         tivptl(1,nptl)=0d0
9845         tivptl(2,nptl)=0d0
9846
9847         if ( infragm .ge. 2 ) then
9848 c  remaining nucleus is evaporating nucleons and alpha particles
9849          jfin  = 0
9850          call epovapor( mapro,inew,jfin,ityp,pfrx,pfry,pfrz )
9851          if ( jfin .eq. 0 )then   !something failed
9852            iret=1
9853            goto 1000
9854          endif
9855 c loop to treat the remnants of the desintegrated fragment
9856          do  135  j = 1, jfin
9857           if(ityp(j).lt.0.)then
9858             idnucl=-ityp(j)
9859             inucl= idnucl/100
9860             if(idnucl.eq.402)then   !helium (alpha)
9861               idnucl=19
9862             elseif(idnucl.eq.301)then   !tritium
9863               idnucl=18
9864             elseif(idnucl.eq.201)then   !deuterium
9865               idnucl=17
9866             else
9867               iprot= mod(idnucl,100)
9868               idnucl=1000000000+iprot*10000+inucl*10 !PDG code for nucleus
9869             endif
9870           else
9871             inucl=1
9872             idnucl=ityp(j)
9873           endif
9874           ea = float(inucl)*pptl(4,idrest)
9875 c  momenta squared
9876           call idmass(idnucl,am)
9877           ptm = ( ea - am ) * ( ea + am )
9878           pt2 = sngl( pfrx(j)**2 + pfry(j)**2 )
9879           if(ish.ge.6)write(ifch,*) 'pro fragment: j,id,ea,ptm,pt2=',
9880      *                                       j,idnucl,ea,ptm,pt2
9881           if ( pt2 + pfrz(j)**2 .ge. ptm ) then
9882             if (ish.ge.2) write(ifch,*) 'emsfrag: pt reject particle',j
9883             nnn=0
9884             is=0
9885             do while (is.lt.maproj.and.nnn.lt.inucl)
9886               is=is+1
9887               if(istptl(is).eq.1
9888      &             .and.jorptl(is).eq.0.and.iorptl(is).eq.0)then
9889                 nnn=nnn+1
9890 c  copy spectators at the end of the list (necessary for hepmc interface)
9891                 nptl=nptl+1
9892                 if(nptl.gt.mxptl)then
9893                   iret=1
9894                   goto 1000
9895                 endif
9896                 call utrepl(nptl,is)
9897                 jorptl(is)=1
9898                 ifrptl(1,is)=nptl
9899                 ifrptl(2,is)=nptl
9900                 istptl(nptl)=0
9901                 iorptl(nptl)=is
9902               endif
9903             enddo
9904             goto 135
9905           else
9906             plong = sqrt(ptm-pt2)
9907           endif
9908           nptl=nptl+1
9909           if(nptl.gt.mxptl)then
9910             iret=1
9911             goto 1000
9912           endif
9913           istptl(nptl)=0
9914           pptl(1,nptl)=sngl(pfrx(j))
9915           pptl(2,nptl)=sngl(pfry(j))
9916           pptl(3,nptl)=plong+sngl(pfrz(j))   !OK if plong >> pfrz
9917           pptl(4,nptl)=sqrt(pptl(1,nptl)**2+pptl(2,nptl)**2
9918      *                     +pptl(3,nptl)**2+am**2)
9919           pptl(5,nptl)=am    !mass
9920           ityptl(nptl)=0
9921           iorptl(nptl)=nptla+1
9922           jorptl(nptl)=0
9923           ifrptl(1,nptl)=0
9924           ifrptl(2,nptl)=0
9925           xorptl(1,nptl)=xmean
9926           xorptl(2,nptl)=ymean
9927           xorptl(3,nptl)=zmean
9928           xorptl(4,nptl)=zmean
9929           tivptl(1,nptl)=zmean
9930           tivptl(2,nptl)=tivptl(2,idrest)
9931           idptl(nptl)=idnucl
9932  135    continue
9933
9934         elseif ( infragm .eq. 1 ) then
9935 c  remaining nucleus is one fragment
9936           nptl=nptl+1
9937           if(nptl.gt.mxptl)then
9938             iret=1
9939             goto 1000
9940           endif
9941           istptl(nptl)=0
9942           pptl(1,nptl)=0.d0
9943           pptl(2,nptl)=0.d0
9944           pptl(4,nptl)=0.d0
9945           inucl=0
9946           do is=1,maproj
9947             if(iorptl(is).eq.0.and.jorptl(is).eq.0)then
9948               inucl=inucl+1
9949               pptl(4,nptl)=pptl(4,nptl)+dble(pptl(4,is))
9950             endif
9951           enddo
9952           if(inucl.ne.inew/100)call utstop('Pb in emsfrag !&')
9953           idnucl=1000000000+mod(inew,100)*10000+(inew/100)*10
9954           call idmass(idnucl,am)
9955           pptl(5,nptl)=am    !mass
9956           ptot=(pptl(4,nptl)+am)*(pptl(4,nptl)-am)
9957           pptl(3,nptl)=sqrt(ptot)
9958           ityptl(nptl)=0
9959           istptl(nptl)=0
9960           iorptl(nptl)=nptla+1
9961           jorptl(nptl)=0
9962           ifrptl(1,nptl)=0
9963           ifrptl(2,nptl)=0
9964           xorptl(1,nptl)=xmean
9965           xorptl(2,nptl)=ymean
9966           xorptl(3,nptl)=zmean
9967           xorptl(4,nptl)=zmean
9968           tivptl(1,nptl)=zmean
9969           tivptl(2,nptl)=tivptl(2,idrest)
9970           idptl(nptl)=idnucl
9971         endif
9972         ifrptl(2,nptla+1)=nptl
9973         if(ifrptl(1,nptla+1).gt.ifrptl(2,nptla+1))then
9974           ifrptl(1,nptla+1)=0
9975           ifrptl(2,nptla+1)=0
9976         endif
9977       endif
9978
9979       do is=nptla+1,nptl
9980           if(ish.ge.5)write(ifch,'(a,i5,a,i10,a,4(e10.4,1x),f6.3)')
9981      $       ' Projectile fragments ',is,' id :',idptl(is)
9982      $  , ' momentum :',(pptl(k,is),k=1,5)
9983       enddo
9984
9985  100  continue
9986
9987 c Target fragment(s)
9988
9989       irest = matarg*100+abs(latarg)
9990       inew=0
9991       matar=matarg
9992       xmean=0d0
9993       ymean=0d0
9994       zmean=0d0
9995       spec=0d0
9996       amrest=0.
9997       imin=maproj+matarg
9998       imax=maproj+1
9999
10000       do is=maproj+1,maproj+matarg
10001
10002         if(istptl(is).eq.0)then
10003           if ( iorptl(is) .eq. 0 ) then
10004             if(infragm.eq.0)then   !keep free nucleons
10005 c  copy spectators at the end of the list (necessary for hepmc interface)
10006               nptl=nptl+1
10007               if(nptl.gt.mxptl)then
10008                 iret=1
10009                 goto 1000
10010               endif
10011               call utrepl(nptl,is)
10012               istptl(is)=1
10013               ifrptl(1,is)=nptl
10014               ifrptl(2,is)=nptl
10015               istptl(nptl)=0
10016               iorptl(nptl)=is
10017             else
10018 c  compose projectile spectators to remaining nucleus
10019               spec=spec+1d0
10020               tivptl(2,is)=0d0
10021               xmean=xmean+xorptl(1,is)
10022               ymean=ymean+xorptl(2,is)
10023               zmean=0d0
10024               amrest=amrest+pptl(5,is)
10025               imin=min(imin,is)
10026               imax=max(imax,is)
10027               istptl(is)=1
10028               ifrptl(1,is)=nptl+1
10029               ifrptl(2,is)=nptl+1
10030               idrest = is
10031               id=idptl(is)
10032               if     ( id .eq. 1120 ) then
10033                 inew  = inew + 101
10034                 irest = irest - 101
10035               elseif ( id .eq. 1220 ) then
10036                 inew  = inew + 100
10037                 irest = irest - 100
10038               endif
10039             endif
10040           endif
10041
10042         elseif( iorptl(is) .le. 0  .and.  istptl(is) .eq. 1 ) then
10043           if( iorptl(is) .eq. 0 ) jorptl(is)=1
10044           matar=matar-1
10045         endif
10046
10047       enddo
10048
10049       if(inew.eq.0)goto 1000
10050
10051       xmean=xmean/spec
10052       ymean=ymean/spec
10053       zmean=zmean/spec
10054       nptla=nptl
10055 c prepare intermediate particle to produce nuclear fragment
10056       nptl=nptl+1
10057       if(nptl.gt.mxptl)then
10058         iret=1
10059         goto 1000
10060       endif
10061
10062       if( inew .eq. 100 .or. inew .eq. 101 ) then
10063 c  remaining nucleus is single neutron or proton
10064         call utrepl(nptl,idrest)
10065         ifrptl(1,idrest)=nptl
10066         ifrptl(2,idrest)=nptl
10067         istptl(nptl)=0
10068         iorptl(nptl)=idrest
10069         goto 1000
10070
10071       else
10072
10073 c intermediate particles for father/mother relationship
10074         idptl(nptl)=800000000+inew
10075         ea = float(inew/100)*pptl(4,idrest)
10076 c  momenta squared
10077         ptm = sqrt(max(0.,(ea-amrest)*(ea+amrest)))
10078         istptl(nptl)=51
10079         pptl(1,nptl)=0.
10080         pptl(2,nptl)=0.
10081         pptl(3,nptl)=-ptm
10082         pptl(4,nptl)=sqrt(pptl(1,nptl)**2+pptl(2,nptl)**2
10083      *                     +pptl(3,nptl)**2+amrest**2)
10084         pptl(5,nptl)=amrest         !mass
10085         ityptl(nptl)=50
10086         iorptl(nptl)=imax
10087         jorptl(nptl)=imax
10088         ifrptl(1,nptl)=nptl+1
10089         ifrptl(2,nptl)=0
10090         xorptl(1,nptl)=0d0
10091         xorptl(2,nptl)=0d0
10092         xorptl(3,nptl)=0d0
10093         xorptl(4,nptl)=0d0
10094         tivptl(1,nptl)=0d0
10095         tivptl(2,nptl)=0d0
10096
10097         if ( infragm .ge. 2 ) then
10098 c  remaining nucleus is evaporating nucleons and alpha particles
10099          jfin  = 0
10100          call epovapor( matar,inew,jfin,ityp,pfrx,pfry,pfrz )
10101          if ( jfin .eq. 0 )then   !something failed
10102            iret=1
10103            goto 1000
10104          endif
10105 c loop to treat the remnants of the desintegrated fragment
10106          do  235  j = 1, jfin
10107           if(ityp(j).lt.0.)then
10108             idnucl=-ityp(j)
10109             inucl= idnucl/100
10110             if(idnucl.eq.402)then   !helium (alpha)
10111               idnucl=19
10112             elseif(idnucl.eq.301)then   !tritium
10113               idnucl=18
10114             elseif(idnucl.eq.201)then   !deuterium
10115               idnucl=17
10116             else
10117               iprot= mod(idnucl,100)
10118               idnucl=1000000000+iprot*10000+inucl*10 !PDG code for nucleus
10119             endif
10120           else
10121             inucl=1
10122             idnucl=ityp(j)
10123           endif
10124           ea = float(inucl)*pptl(4,idrest)
10125 c  momenta squared
10126           call idmass(idnucl,am)
10127           ptm = ( ea - dble(am) ) * ( ea + dble(am) )
10128           pt2 = sngl( pfrx(j)**2 + pfry(j)**2 )
10129           if(ish.ge.6)write(ifch,*) 'tar fragment: j,id,ea,ptm,pt2=',
10130      *                                       j,idnucl,ea,ptm,pt2
10131           if ( pt2 + pfrz(j)**2 .ge. ptm ) then
10132             if (ish.ge.2) write(ifch,*) 'emsfrag: pt reject particle',j
10133             nnn=0
10134             is=maproj
10135             do while (is.lt.maproj+matarg.and.nnn.lt.inucl)
10136               is=is+1
10137               if(istptl(is).eq.1
10138      &             .and.jorptl(is).eq.0.and.iorptl(is).eq.0)then
10139                 nnn=nnn+1
10140 c  copy spectators at the end of the list (necessary for hepmc interface)
10141                 nptl=nptl+1
10142                 if(nptl.gt.mxptl)then
10143                   iret=1
10144                   goto 1000
10145                 endif
10146                 call utrepl(nptl,is)
10147                 jorptl(is)=1
10148                 ifrptl(1,is)=nptl
10149                 ifrptl(2,is)=nptl
10150                 istptl(nptl)=0
10151                 iorptl(nptl)=is
10152               endif
10153             enddo
10154             goto 235
10155           else
10156             plong=-sqrt(ptm-pt2)
10157           endif
10158           nptl=nptl+1
10159           if(nptl.gt.mxptl)then
10160             iret=1
10161             goto 1000
10162           endif
10163           istptl(nptl)=0
10164           pptl(1,nptl)=sngl(pfrx(j))
10165           pptl(2,nptl)=sngl(pfry(j))
10166           pptl(3,nptl)=plong+sngl(pfrz(j))   !OK if plong >> pfrz
10167           pptl(4,nptl)=sqrt(pptl(1,nptl)**2+pptl(2,nptl)**2
10168      *                     +pptl(3,nptl)**2+am**2)
10169           pptl(5,nptl)=am    !mass
10170           ityptl(nptl)=0
10171           iorptl(nptl)=nptla+1
10172           jorptl(nptl)=0
10173           ifrptl(1,nptl)=0
10174           ifrptl(2,nptl)=0
10175           xorptl(1,nptl)=xmean
10176           xorptl(2,nptl)=ymean
10177           xorptl(3,nptl)=zmean
10178           xorptl(4,nptl)=zmean
10179           tivptl(1,nptl)=zmean
10180           tivptl(2,nptl)=tivptl(2,idrest)
10181           idptl(nptl)=idnucl
10182  235    continue
10183
10184         elseif ( infragm .eq. 1 ) then
10185 c  remaining nucleus is one fragment
10186           nptl=nptl+1
10187           if(nptl.gt.mxptl)then
10188             iret=1
10189             goto 1000
10190           endif
10191           istptl(nptl)=0
10192           pptl(1,nptl)=0.d0
10193           pptl(2,nptl)=0.d0
10194           pptl(4,nptl)=0.d0
10195           inucl=0
10196           do is=maproj+1,maproj+matarg
10197             if(iorptl(is).eq.0.and.jorptl(is).eq.0)then
10198               inucl=inucl+1
10199               pptl(4,nptl)=pptl(4,nptl)+dble(pptl(4,is))
10200             endif
10201           enddo
10202           if(inucl.ne.inew/100)call utstop('Pb in emsfrag !&')
10203           idnucl=1000000000+mod(inew,100)*10000+(inew/100)*10
10204           call idmass(idnucl,am)
10205           pptl(5,nptl)=am    !mass
10206           ptot=(pptl(4,nptl)+am)*(pptl(4,nptl)-am)
10207           pptl(3,nptl)=sqrt(ptot)
10208           ityptl(nptl)=0
10209           istptl(nptl)=0
10210           iorptl(nptl)=nptla+1
10211           jorptl(nptl)=0
10212           ifrptl(1,nptl)=0
10213           ifrptl(2,nptl)=0
10214           xorptl(1,nptl)=xmean
10215           xorptl(2,nptl)=ymean
10216           xorptl(3,nptl)=zmean
10217           xorptl(4,nptl)=zmean
10218           tivptl(1,nptl)=zmean
10219           tivptl(2,nptl)=tivptl(2,idrest)
10220           idptl(nptl)=idnucl
10221         endif
10222         ifrptl(2,nptla+1)=nptl
10223         if(ifrptl(1,nptla+1).gt.ifrptl(2,nptla+1))then
10224           ifrptl(1,nptla+1)=0
10225           ifrptl(2,nptla+1)=0
10226         endif
10227       endif
10228
10229       do is=nptla+1,nptl
10230           if(ish.ge.5)write(ifch,'(a,i5,a,i10,a,4(e10.4,1x),f6.3)')
10231      $       ' Target fragments ',is,' id :',idptl(is)
10232      $  , ' momentum :',(pptl(k,is),k=1,5)
10233       enddo
10234
10235
10236  1000 continue
10237
10238
10239       end
10240
10241 cc--------------------------------------------------------------------------
10242 c      subroutine reaction(idpj,idtg,ireac)
10243 cc--------------------------------------------------------------------------
10244 cc returns reaction code ireac
10245 cc--------------------------------------------------------------------------
10246 c      iap=iabs(idpj/10)
10247 c      iat=iabs(idtg/10)
10248 c      isp=idpj/10/iap
10249 c      ist=idtg/10/iat
10250 c      call idchrg(idpj,cp)
10251 c      call idchrg(idtg,ct)
10252 c      ac=abs(cp+ct)
10253 c      if(iap.gt.100)then
10254 c       if(iat.gt.100)then
10255 c        if(isp.eq.1)then
10256 c         if(ist.eq.1)then
10257 c          ireac=1
10258 c         else
10259 c          ireac=6
10260 c         endif
10261 c        else
10262 c         if(ist.eq.1)then
10263 c          ireac=6
10264 c         else
10265 c          ireac=1
10266 c         endif
10267 c        endif
10268 c       elseif(iat.eq.11.or.iat.eq.12.or.iat.eq.22)then
10269 c        if(ac.ge.2.)then
10270 c         ireac=2
10271 c        else
10272 c         ireac=3
10273 c        endif
10274 c       else
10275 c        if(ac.ge.2.)then
10276 c         ireac=4
10277 c        else
10278 c         ireac=5
10279 c        endif
10280 c       endif
10281 c      elseif(iap.eq.11.or.iap.eq.12.or.iap.eq.22)then
10282 c       if(iat.gt.100)then
10283 c        if(ac.ge.2.)then
10284 c         ireac=2
10285 c        else
10286 c         ireac=3
10287 c        endif
10288 c       elseif(iat.eq.11.or.iat.eq.12.or.iat.eq.22)then
10289 c        ireac=7
10290 c       else
10291 c        ireac=8
10292 c       endif
10293 c      else
10294 c       if(iat.gt.100)then
10295 c        if(ac.ge.2.)then
10296 c         ireac=4
10297 c        else
10298 c         ireac=5
10299 c        endif
10300 c       elseif(iat.eq.11.or.iat.eq.12.or.iat.eq.22)then
10301 c        ireac=8
10302 c       else
10303 c        ireac=9
10304 c       endif
10305 c      endif
10306 c
10307 c      end
10308 c
10309 c-----------------------------------------------------------------------
10310       subroutine xEmsI1(iii,kc,omlog)
10311 c-----------------------------------------------------------------------
10312 c plot omlog vs iter
10313 c plot  nr of pomerons vs iter
10314 c plot number of collisions vs iter
10315 c-----------------------------------------------------------------------
10316
10317       include 'epos.inc'
10318       include 'epos.incems'
10319       include 'epos.incsem'
10320
10321       parameter(nbin=100)
10322       common/cmc/ot(0:nbin),zz(0:nbin),i(0:nbin)
10323      *,yt1,yt2,kx(0:nbin)
10324       parameter(nbim=100)
10325       common/cmc1/xp(0:nbim),xt(0:nbim),x(0:nbim),o(0:nbim)
10326      *,y1,y2,car
10327       character car*5
10328       double precision xp,xt,x,omlog,om1intbc
10329       character ce*8
10330       double precision plc,s,seedp
10331       common/cems5/plc,s
10332
10333 c      if(iemsi2.eq.0)call utstop('ERROR in XemsI1: iemsi2 = 0&')
10334
10335        if(iii.eq.1)then
10336
10337       o(kc)=sngl(omlog)
10338       nptk=0
10339       kollx=0
10340       do ko=1,koll
10341       nptk=nptk+nprt(ko)
10342 c      if(itpr(ko).gt.0)then
10343       if(nprt(ko).gt.0)then
10344        kollx=kollx+1
10345       endif
10346       enddo
10347       zz(kc)=nptk
10348       kx(kc)=kollx
10349
10350         elseif(iii.eq.2)then
10351
10352       call ranfgt(seedp)
10353       sum=0
10354       kollx=0
10355       sumg=0
10356       kollg=0
10357       kollini=koll
10358       koll=1
10359       do ko=1,kollini
10360 ctp060829       ip=iproj(ko)
10361 ctp060829       it=itarg(ko)
10362        om1i=sngl(om1intbc(bk(ko)))
10363 ctp060829         wk=1.
10364 ctp060829         wp=0.
10365 ctp060829         wt=0.
10366        om1g=sngl(om1intbc(bk(ko)))
10367        sum=sum+om1i
10368        sumg=sumg+om1g
10369        if(rangen().lt.1.-exp(-om1i))then
10370         kollx=kollx+1
10371        endif
10372        if(rangen().lt.1.-exp(-om1g))then
10373         kollg=kollg+1
10374        endif
10375       enddo
10376       koll=kollini
10377       call ranfst(seedp)
10378
10379       x1=0
10380       x2=nbin
10381       write(ce,'(f8.2)')sngl(plc)
10382
10383       write(ifhi,'(a)')       '!##################################'
10384       write(ifhi,'(a,i3)')    '!   log omega       for event ',nrevt+1
10385       write(ifhi,'(a)')       '!##################################'
10386       write(ifhi,'(a,i1)')    'openhisto name omega-',nrevt+1
10387       write(ifhi,'(a)')       'htyp lin'
10388       write(ifhi,'(a)')       'xmod lin ymod lin'
10389       write(ifhi,'(a,2e11.3)')'xrange',x1,x2
10390       write(ifhi,'(a)')       'yrange auto auto '
10391       write(ifhi,'(a)')    'text 0 0 "xaxis iteration"'
10392       write(ifhi,'(a)')    'text 0 0 "yaxis ln[W]"'
10393       write(ifhi,'(a,a)')  'text 0.5 0.90 "E ='//ce//'"'
10394       write(ifhi,'(a)')       'array 2'
10395          do k=0,nbim
10396       write(ifhi,'(2e11.3)')float(k),o(k)
10397          enddo
10398       write(ifhi,'(a)')    '  endarray'
10399       write(ifhi,'(a)')    'closehisto plot 0'
10400
10401       write(ifhi,'(a)')   '!##################################'
10402       write(ifhi,'(a,i3)')'! nr of coll`s  for event ',nrevt+1
10403       write(ifhi,'(a)')   '!##################################'
10404       write(ifhi,'(a,i1)')    'openhisto name coll-',nrevt+1
10405       write(ifhi,'(a)')       'htyp lin'
10406       write(ifhi,'(a)')       'xmod lin ymod lin'
10407       write(ifhi,'(a,2e11.3)')'xrange',x1,x2
10408       write(ifhi,'(a)')    'text 0 0 "xaxis iteration"'
10409       write(ifhi,'(a)')    'text 0 0 "yaxis nr of collisions"'
10410       write(ifhi,'(a)')       'array 2'
10411          do k=0,nbin
10412       write(ifhi,'(2e11.3)')float(k),float(kx(k))
10413          enddo
10414       write(ifhi,'(a)')    '  endarray'
10415       write(ifhi,'(a)')    'closehisto plot 0-'
10416       write(ifhi,'(a)')       'openhisto'
10417       write(ifhi,'(a)')       'htyp lin'
10418       write(ifhi,'(a)')       'array 2'
10419          do k=0,nbin
10420       write(ifhi,'(2e11.3)')float(k),float(kollx)
10421          enddo
10422       write(ifhi,'(a)')    '  endarray'
10423       write(ifhi,'(a)')    'closehisto plot 0-'
10424       write(ifhi,'(a)')       'openhisto'
10425       write(ifhi,'(a)')       'htyp lin'
10426       write(ifhi,'(a)')       'array 2'
10427          do k=0,nbin
10428       write(ifhi,'(2e11.3)')float(k),float(kollg)
10429          enddo
10430       write(ifhi,'(a)')    '  endarray'
10431       write(ifhi,'(a)')    'closehisto plot 0'
10432
10433       write(ifhi,'(a)')   '!##################################'
10434       write(ifhi,'(a,i3)')'! nr of pom`s  for event ',nrevt+1
10435       write(ifhi,'(a)')   '!##################################'
10436       write(ifhi,'(a,i1)')    'openhisto name pom-',nrevt+1
10437       write(ifhi,'(a)')       'htyp lin'
10438       write(ifhi,'(a)')       'xmod lin ymod lin'
10439       write(ifhi,'(a,2e11.3)')'xrange',x1,x2
10440       write(ifhi,'(a)')    'text 0 0 "xaxis iteration"'
10441       write(ifhi,'(a)')    'text 0 0 "yaxis nr of Pomerons"'
10442       write(ifhi,'(a)')       'array 2'
10443          do k=0,nbin
10444       write(ifhi,'(2e11.3)')float(k),zz(k)
10445          enddo
10446       write(ifhi,'(a)')    '  endarray'
10447       if(sum.lt.4*zz(nbin))then
10448       write(ifhi,'(a)')    'closehisto plot 0-'
10449       write(ifhi,'(a)')       'openhisto'
10450       write(ifhi,'(a)')       'htyp lin'
10451       write(ifhi,'(a)')       'array 2'
10452          do k=0,nbin
10453       write(ifhi,'(2e11.3)')float(k),sum
10454          enddo
10455       write(ifhi,'(a)')    '  endarray'
10456       write(ifhi,'(a)')    'closehisto plot 0-'
10457       write(ifhi,'(a)')       'openhisto'
10458       write(ifhi,'(a)')       'htyp lin'
10459       write(ifhi,'(a)')       'array 2'
10460          do k=0,nbin
10461       write(ifhi,'(2e11.3)')float(k),sumg
10462          enddo
10463       write(ifhi,'(a)')    '  endarray'
10464       endif
10465       write(ifhi,'(a)')    'closehisto plot 0'
10466
10467         endif
10468
10469       return
10470       end
10471
10472 c-----------------------------------------------------------------------
10473       subroutine xEmsI2(iii,kc)
10474 c-----------------------------------------------------------------------
10475 c plot quanities vs iter
10476 c   plot 1: <x> for Pomeron vs iter
10477 c   plot 2: <x> for projectile vs iter
10478 c   plot 3: <x> for target vs iter
10479 c arguments:
10480 c   iii:   modus (1,2)
10481 c   kc:    iteration step
10482 c   omega: config probability
10483 c-----------------------------------------------------------------------
10484
10485       include 'epos.inc'
10486       include 'epos.incems'
10487
10488       parameter(nbim=100)
10489       common/cmc1/xp(0:nbim),xt(0:nbim),x(0:nbim),o(0:nbim)
10490      *,y1,y2,car
10491       character car*5
10492       double precision xp,xt,x,xpo,xpj,xtg
10493       common/cemsi2/xpo,xpj,xtg
10494
10495         if(iii.eq.1)then
10496
10497       npom=0
10498       xpo=0
10499       do k=1,koll
10500 c       ip=iproj(k)
10501 c       it=itarg(k)
10502        if(nprmx(k).gt.0)then
10503         do n=1,nprmx(k)
10504          if(idpr(n,k).gt.0.and.ivpr(n,k).gt.0)then
10505           xpo=xpo+xpr(n,k)
10506           npom=npom+1
10507          endif
10508         enddo
10509        endif
10510       enddo
10511       if(npom.gt.0)xpo=xpo/npom
10512
10513       npk=0
10514       xpj=0d0
10515       do i=1,maproj
10516        if(xpp(i).lt.0.999)then
10517         xpj=xpj+xpp(i)!*xmp(i)
10518         npk=npk+1
10519        endif
10520       enddo
10521       if(npk.gt.0)xpj=xpj/dble(npk)
10522
10523       ntk=0
10524       xtg=0d0
10525       do j=1,matarg
10526        if(xmt(j).lt.0.999)then
10527         xtg=xtg+xmt(j)!*xpt(j)
10528         ntk=ntk+1
10529        endif
10530       enddo
10531       if(ntk.gt.0)xtg=xtg/dble(ntk)
10532
10533       x(kc)=xpo
10534       xp(kc)=xpj
10535       xt(kc)=xtg
10536
10537         elseif(iii.eq.2)then
10538
10539       x1=0
10540       x2=nbim
10541
10542       write(ifhi,'(a)')       '!##################################'
10543       write(ifhi,'(a,i3)')    '!   average x  Pom   for event ',nrevt+1
10544       write(ifhi,'(a)')       '!##################################'
10545       write(ifhi,'(a,i1)')    'openhisto name avxPom-',nrevt+1
10546       write(ifhi,'(a)')       'htyp lin'
10547       write(ifhi,'(a)')       'xmod lin ymod lin'
10548       write(ifhi,'(a,2e11.3)')'xrange',x1,x2
10549       write(ifhi,'(a)')    'text 0 0 "xaxis iteration"'
10550       write(ifhi,'(a)')    'text 0 0 "yaxis average x Pomeron"'
10551       write(ifhi,'(a)')       'array 2'
10552          do k=0,nbim
10553       write(ifhi,'(2e11.3)')float(k),x(k)
10554          enddo
10555       write(ifhi,'(a)')    '  endarray'
10556       write(ifhi,'(a)')    'closehisto plot 0'
10557
10558       write(ifhi,'(a)')       '!##################################'
10559       write(ifhi,'(a,i3)')    '!   average x proj   for event ',nrevt+1
10560       write(ifhi,'(a)')       '!##################################'
10561       write(ifhi,'(a,i1)')    'openhisto name avxProj-',nrevt+1
10562       write(ifhi,'(a)')       'htyp lin'
10563       write(ifhi,'(a)')       'xmod lin ymod lin'
10564       write(ifhi,'(a,2e11.3)')'xrange',x1,x2
10565       write(ifhi,'(a)')    'text 0 0 "xaxis iteration"'
10566       write(ifhi,'(a)')    'text 0 0 "yaxis average x proj"'
10567       write(ifhi,'(a)')       'array 2'
10568          do k=0,nbim
10569       write(ifhi,'(2e11.3)')float(k),xp(k)
10570          enddo
10571       write(ifhi,'(a)')    '  endarray'
10572       write(ifhi,'(a)')    'closehisto plot 0'
10573
10574       write(ifhi,'(a)')       '!##################################'
10575       write(ifhi,'(a,i3)')    '!   average x targ   for event ',nrevt+1
10576       write(ifhi,'(a)')       '!##################################'
10577       write(ifhi,'(a,i1)')    'openhisto name avxTarg-',nrevt+1
10578       write(ifhi,'(a)')       'htyp lin'
10579       write(ifhi,'(a)')       'xmod lin ymod lin'
10580       write(ifhi,'(a,2e11.3)')'xrange',x1,x2
10581       write(ifhi,'(a)')    'text 0 0 "xaxis iteration"'
10582       write(ifhi,'(a)')    'text 0 0 "yaxis average x targ"'
10583       write(ifhi,'(a)')       'array 2'
10584          do k=0,nbim
10585       write(ifhi,'(2e11.3)')float(k),xt(k)
10586          enddo
10587       write(ifhi,'(a)')    '  endarray'
10588       write(ifhi,'(a)')    'closehisto plot 0'
10589         endif
10590
10591       return
10592       end
10593
10594 c-----------------------------------------------------------------------
10595       subroutine xEmsRx(iii,id,xp,xm)
10596 c-----------------------------------------------------------------------
10597 c plot  x+, x-, x, y distribution of remnants
10598 c-----------------------------------------------------------------------
10599
10600       include 'epos.inc'
10601
10602       parameter(nbix=50,nbiy=50,nid=2)
10603       common/cxp/nxp(nid),nxm(nid),nx(nid),ny(nid)
10604      *,wxp(nbix,nid),wxm(nbix,nid),wx(nbix,nid),wy(nbiy,nid)
10605      *,xpu,xpo,xmu,xmo,xu,xo,yu,yo,dy
10606
10607       if(iemsrx.eq.0)call utstop('ERROR in XemsRx: iemsrx = 0&')
10608
10609         if(iii.eq.0)then
10610
10611       xpu=10/engy**2
10612       xpo=1
10613       xmu=10/engy**2
10614       xmo=1
10615       xu=10/engy**2
10616       xo=1
10617       yu=-alog(engy**2)
10618       yo=alog(engy**2)
10619       dy=(yo-yu)/nbiy
10620       do j=1,nid
10621        nxp(j)=0
10622        nxm(j)=0
10623        nx(j)=0
10624        do i=1,nbix
10625         wxp(i,j)=0
10626         wxm(i,j)=0
10627         wx(i,j)=0
10628        enddo
10629        ny(j)=0
10630        do i=1,nbiy
10631         wy(i,j)=0
10632        enddo
10633       enddo
10634
10635         elseif(iii.eq.1)then
10636
10637       i=0
10638       if(xp.lt.xpu)goto1
10639       i=1+int(alog(xp/xpu)/alog(xpo/xpu)*nbix)
10640       if(i.gt.nbix)goto1
10641       if(i.lt.1)goto1
10642       wxp(i,id)=wxp(i,id)+1
10643       nxp(id)=nxp(id)+1
10644 1     continue
10645
10646       if(xm.lt.xmu)goto2
10647       i=1+int(alog(xm/xmu)/alog(xmo/xmu)*nbix)
10648       if(i.gt.nbix)goto2
10649       if(i.lt.1)goto2
10650       wxm(i,id)=wxm(i,id)+1
10651       nxm(id)=nxm(id)+1
10652 2     continue
10653
10654       x=xp*xm
10655       if(x.lt.xu)goto3
10656       i=1+int(alog(x/xu)/alog(xo/xu)*nbix)
10657       if(i.gt.nbix)goto3
10658       if(i.lt.1)goto3
10659       wx(i,id)=wx(i,id)+1
10660       nx(id)=nx(id)+1
10661 3     continue
10662
10663       if(xm.le.0.)goto4
10664       if(xp.le.0.)goto4
10665       y=0.5*alog(xp/xm)
10666       if(y.lt.yu)goto4
10667       i=int((y-yu)/dy)+1
10668       if(i.gt.nbiy)goto4
10669       if(i.lt.1)goto4
10670       wy(i,id)=wy(i,id)+1
10671       ny(id)=ny(id)+1
10672 4     continue
10673
10674         elseif(iii.eq.2)then
10675
10676       do j=1,nid
10677       if(j.eq.1)then
10678         iclrem=iclpro
10679       elseif(j.eq.2)then
10680         iclrem=icltar
10681       else
10682         iclrem=0
10683       endif
10684       write(ifhi,'(a)')      '!----------------------------------'
10685       write(ifhi,'(a)')      '!   remnant xp distribution      '
10686       write(ifhi,'(a)')      '!----------------------------------'
10687       write(ifhi,'(a,i1)')    'openhisto name xpRemnant-',j
10688       write(ifhi,'(a)')       'htyp lin'
10689       write(ifhi,'(a)')       'xmod log ymod log'
10690       write(ifhi,'(a,2e11.3)')'xrange',xpu,xpo
10691       write(ifhi,'(a)')    'text 0 0 "xaxis remnant x+"'
10692       write(ifhi,'(a)')    'text 0 0 "yaxis P(x+)"'
10693       write(ifhi,'(a)')       'array 2'
10694          do i=1,nbix
10695       x=xpu*(xpo/xpu)**((i-0.5)/nbix)
10696       dx=xpu*(xpo/xpu)**(1.*i/nbix)*(1.-(xpo/xpu)**(-1./nbix))
10697       if(nxp(j).ne.0)write(ifhi,'(2e11.3)')x,wxp(i,j)/dx/nxp(j)
10698       if(nxp(j).eq.0)write(ifhi,'(2e11.3)')x,0.
10699          enddo
10700       write(ifhi,'(a)')    '  endarray'
10701       write(ifhi,'(a)')    'closehisto plot 0-'
10702       write(ifhi,'(a)')       'openhisto'
10703       write(ifhi,'(a)')       'htyp lin'
10704       write(ifhi,'(a)')       'array 2'
10705          do i=1,nbix
10706       x=xu*(xo/xu)**((i-0.5)/nbix)
10707       write(ifhi,'(2e11.3)')x,x**alplea(iclrem)*(1+alplea(iclrem))
10708          enddo
10709       write(ifhi,'(a)')    '  endarray'
10710       write(ifhi,'(a)')    'closehisto plot 0'
10711
10712       write(ifhi,'(a)')      '!----------------------------------'
10713       write(ifhi,'(a)')      '!   remnant xm distribution      '
10714       write(ifhi,'(a)')      '!----------------------------------'
10715       write(ifhi,'(a,i1)')    'openhisto name xmRemnant-',j
10716       write(ifhi,'(a)')       'htyp lin'
10717       write(ifhi,'(a)')       'xmod log ymod log'
10718       write(ifhi,'(a,2e11.3)')'xrange',xmu,xmo
10719       write(ifhi,'(a)')    'text 0 0 "xaxis remnant x-"'
10720       write(ifhi,'(a)')    'text 0 0 "yaxis P(x-)"'
10721       write(ifhi,'(a)')       'array 2'
10722          do i=1,nbix
10723       x=xmu*(xmo/xmu)**((i-0.5)/nbix)
10724       dx=xmu*(xmo/xmu)**(1.*i/nbix)*(1.-(xmo/xmu)**(-1./nbix))
10725       if(nxm(j).ne.0)write(ifhi,'(2e11.3)')x,wxm(i,j)/dx/nxm(j)
10726       if(nxm(j).eq.0)write(ifhi,'(2e11.3)')x,0.
10727          enddo
10728       write(ifhi,'(a)')    '  endarray'
10729       write(ifhi,'(a)')    'closehisto plot 0'
10730
10731       write(ifhi,'(a)')      '!----------------------------------'
10732       write(ifhi,'(a)')      '!   remnant x distribution      '
10733       write(ifhi,'(a)')      '!----------------------------------'
10734       write(ifhi,'(a,i1)')    'openhisto name xRemnant-',j
10735       write(ifhi,'(a)')       'htyp lin'
10736       write(ifhi,'(a)')       'xmod log ymod log'
10737       write(ifhi,'(a,2e11.3)')'xrange',xu,xo
10738       write(ifhi,'(a)')    'text 0 0 "xaxis remnant x"'
10739       write(ifhi,'(a)')    'text 0 0 "yaxis P(x)"'
10740       write(ifhi,'(a)')       'array 2'
10741          do i=1,nbix
10742       x=xu*(xo/xu)**((i-0.5)/nbix)
10743       dx=xu*(xo/xu)**(1.*i/nbix)*(1.-(xo/xu)**(-1./nbix))
10744       if(nx(j).ne.0)write(ifhi,'(2e11.3)')x,wx(i,j)/dx/nx(j)
10745       if(nx(j).eq.0)write(ifhi,'(2e11.3)')x,0.
10746          enddo
10747       write(ifhi,'(a)')    '  endarray'
10748       write(ifhi,'(a)')    'closehisto plot 0'
10749
10750       write(ifhi,'(a)')      '!----------------------------------'
10751       write(ifhi,'(a)')      '!   remnant y distribution      '
10752       write(ifhi,'(a)')      '!----------------------------------'
10753       write(ifhi,'(a,i1)')    'openhisto name yRemnant-',j
10754       write(ifhi,'(a)')       'htyp lin'
10755       write(ifhi,'(a)')       'xmod lin ymod log'
10756       write(ifhi,'(a,2e11.3)')'xrange',yu,yo
10757       write(ifhi,'(a)')    'text 0 0 "xaxis remnant y"'
10758       write(ifhi,'(a)')    'text 0 0 "yaxis P(y)"'
10759       write(ifhi,'(a)')       'array 2'
10760          do i=1,nbix
10761       y=yu+dy/2.+(i-1)*dy
10762       if(ny(j).ne.0)write(ifhi,'(2e11.3)')y,wy(i,j)/dy/ny(j)
10763       if(ny(j).eq.0)write(ifhi,'(2e11.3)')y,0.
10764          enddo
10765       write(ifhi,'(a)')    '  endarray'
10766       write(ifhi,'(a)')    'closehisto plot 0'
10767
10768       enddo
10769
10770         endif
10771
10772       return
10773       end
10774
10775 c-----------------------------------------------------------------------
10776       subroutine xEmsPm(iii,ko,nmci,nmcmx)
10777 c-----------------------------------------------------------------------
10778 c m (pomeron number) distribution for different b-bins.
10779 c arguments:
10780 c   iii:  modus (0,1,2)
10781 c   ko:   pair number (1 - AB)
10782 c   nmc:  number of pomerons
10783 c   nmcmx: number max of pomerons
10784 c-----------------------------------------------------------------------
10785       include 'epos.inc'
10786       include 'epos.incems'
10787       common/geom/rmproj,rmtarg,bmax,bkmx
10788       parameter(nbin=200)
10789       parameter(nbib=32)
10790       common/cn/wn(0:nbin,nbib),wnmc(0:nbin,nbib),npmx(nbib),nn(nbib)
10791      &         ,nn2(nbib),dn(nbib)
10792       common/cb1/db,b1,b2,bb(nbib),nbibx
10793       double precision plc,s,om1intbc
10794       character ce*8,cb*4
10795       common/cems5/plc,s
10796       common/cemspm/sumb(nbib)
10797
10798       if(iemspm.eq.0)call utstop('ERROR in XemsPm: iemspm = 0&')
10799
10800         if(iii.eq.0)then
10801
10802       do k=1,nbib
10803        nn(k)=0
10804        nn2(k)=0
10805        sumb(k)=0
10806        do i=0,nbin
10807         wnmc(i,k)=0
10808        enddo
10809       enddo
10810       nbibx=6
10811       b1=0
10812       b2=2
10813       db=(b2-b1)/nbibx
10814
10815
10816         elseif(iii.eq.1)then
10817
10818       k=int((bk(ko)-b1)/db)+1
10819 c      nmc=nmci
10820       if(k.gt.nbibx)k=nbibx
10821       if(k.lt.1)k=1
10822       dn(k)=max(1.,float(nmcmx)/float(nbin))
10823       nmc=nint(float(nmci)/dn(k)+0.499999)
10824       if(nmc.gt.nbin)nmc=nbin
10825       if(nmc.lt.0)return
10826       nn(k)=nn(k)+1
10827       wnmc(nmc,k)=wnmc(nmc,k)+1./dn(k)
10828       sumb(k)=sumb(k)+bk(ko)
10829
10830
10831         elseif(iii.eq.2)then
10832
10833       kollini=koll
10834       koll=1         !to have screening for pp
10835
10836       do 1 k=1,nbibx
10837
10838        bb(k)=b1+(k-0.5)*db
10839        if(maproj.eq.1.and.matarg.eq.1.and.bmaxim.eq.0.)bb(k)=b1
10840        om1i=sngl(om1intbc(bb(k)))
10841        wntmp=0.
10842        do 10 i=0,nbin
10843          wn(i,k)=0.
10844          if(wntmp.gt.1e5)goto 10
10845          do j=i,i+int(dn(k))-1
10846            if(j.eq.0)then
10847              wntmp=exp(-om1i)
10848            else
10849              wntmp=wntmp*om1i/j
10850            endif
10851            wn(i,k)=wn(i,k)+wntmp/dn(k)
10852          enddo
10853          if(wn(i,k).gt.0.000001*(1.-exp(-om1i)))npmx(k)=i
10854  10    continue
10855
10856       write(ifhi,'(a)')   '!##################################'
10857       write(ifhi,'(a)')   '! distr of Pomeron number vs b'
10858       write(ifhi,'(a)')   '!##################################'
10859       write(ce,'(f8.2)')sngl(plc)
10860       write(cb,'(f4.2)')bb(k)
10861       if(nn(k).gt.0)then
10862       write(ifhi,'(a,i1)')    'openhisto name mPom-',k
10863       write(ifhi,'(a)')       'htyp lru'
10864       write(ifhi,'(a)')       'xmod lin ymod log'
10865       write(ifhi,'(a,2e11.3)')'xrange',0.,float(npmx(k))*dn(k)
10866       write(ifhi,'(a)')    'text 0 0 "xaxis number m of Pomerons"'
10867       write(ifhi,'(a)')    'text 0 0 "yaxis prob(m)"'
10868       if(k.eq.1)
10869      *write(ifhi,'(a,a)')     'text 0.5 0.90 "E ='//ce//'"'
10870       write(ifhi,'(a,a)')     'text 0.5 0.80 "b ='//cb//'"'
10871       write(ifhi,'(a)')       'array 2'
10872          do i=0,nbin
10873       write(ifhi,'(2e11.3)')float(i)*dn(k),wnmc(i,k)/max(1,nn(k))
10874          enddo
10875       write(ifhi,'(a)')    '  endarray'
10876       write(ifhi,'(a)')    'closehisto plot 0-'
10877       endif
10878
10879       write(ifhi,'(a)')   '!##################################'
10880       write(ifhi,'(a)')   '! distr of Pomeron number vs b'
10881       write(ifhi,'(a)')   '!   traditional approach'
10882       write(ifhi,'(a)')   '!##################################'
10883       write(ifhi,'(a,i1)')    'openhisto name mPomTradi-',k
10884       write(ifhi,'(a)')       'htyp lba'
10885       write(ifhi,'(a)')       'xmod lin ymod log'
10886       write(ifhi,'(a,2e11.3)')'xrange',0.,float(npmx(k))*dn(k)
10887       write(ifhi,'(a)')       'array 2'
10888          do i=0,nbin
10889       write(ifhi,'(2e11.3)')float(i)*dn(k),wn(i,k)
10890          enddo
10891       write(ifhi,'(a)')    '  endarray'
10892       write(ifhi,'(a)')    'closehisto plot 0'
10893
10894  1    continue
10895
10896       koll=kollini
10897
10898       endif
10899
10900       return
10901       end
10902
10903 c-----------------------------------------------------------------------
10904       subroutine xEmsB(iii,jjj,ko)
10905 c-----------------------------------------------------------------------
10906 c b distribution at different stages
10907 c arguments:
10908 c   iii:  modus (0,1,2)
10909 c   jjj:  stage or type of interaction
10910 c     just after Metropolis:
10911 c           1 ... all
10912 c           2 ... interaction
10913 c     after defining diffraction:
10914 c           3 ... nothing
10915 c           4 ... cut
10916 c           5 ... diffr
10917 c           6 ... cut + diffr cut
10918 c   ko:   pair number (1 - AB)
10919 c-----------------------------------------------------------------------
10920       include 'epos.inc'
10921       include 'epos.incems'
10922       include 'epos.incsem'
10923       parameter(njjj=6)
10924       parameter(nbib=32)
10925       common/cxemsb1/w(0:njjj,nbib),nn(njjj)
10926       common/cxemsb2/db,b1,b2
10927       common/cxemsb3/njjj1
10928       double precision PhiExact,om1intbi,PhiExpo!,PhiUnit
10929       common/geom/rmproj,rmtarg,bmax,bkmx
10930       dimension uua2(nbib),uuo2(nbib),uu3(nbib)
10931
10932       if(iemsb.eq.0)call utstop('ERROR in XemsB: iemsB = 0&')
10933
10934         if(iii.eq.0)then
10935
10936       do k=1,nbib
10937        do j=0,njjj
10938         w(j,k)=0
10939        enddo
10940       enddo
10941       do j=1,njjj
10942        nn(j)=0
10943       enddo
10944       njjj1=0
10945
10946         elseif(iii.eq.1)then
10947
10948       b1=0
10949       b2=bkmx*1.2
10950       db=(b2-b1)/nbib
10951       k=int((bk(ko)-b1)/db)+1
10952       if(k.gt.nbib)return
10953       if(k.lt.1)return
10954       w(jjj,k)=w(jjj,k)+1
10955       nn(jjj)=nn(jjj)+1
10956       if(jjj.eq.1)njjj1=1
10957
10958         elseif(iii.eq.2)then
10959
10960       if(njjj1.ne.1)call utstop
10961      &('xEmsB must be called also with jjj=1&')
10962       ymax=0
10963       kollini=koll
10964       koll=1
10965       do k=1,nbib
10966        x=b1+(k-0.5)*db
10967        y=w(1,k)/nn(1)/(pi*((x+0.5*db)**2-(x-0.5*db)**2))
10968        ymax=max(ymax,y)
10969       enddo
10970       fk=bkmx**2*pi
10971       ymax=1.4
10972
10973       do 1 j=1,njjj
10974        if(nn(j).eq.0)goto1
10975
10976       write(ifhi,'(a)')   '!##################################'
10977       write(ifhi,'(a)')   '! b distr exact theory '
10978       write(ifhi,'(a)')   '!##################################'
10979          if(j.ge.2.and.j.le.6)then
10980       write(ifhi,'(a,i1,a)')  'openhisto name b',j,'Exact'
10981       write(ifhi,'(a)')       'htyp lba xmod lin ymod lin'
10982       write(ifhi,'(a)')    'text 0 0 "xaxis impact parameter b"'
10983       write(ifhi,'(a)')    'text 0 0 "yaxis P(b)"'
10984       write(ifhi,'(a)')       'array 2'
10985          do k=1,nbib
10986       b=b1+(k-0.5)*db
10987       if(j.eq.2)then
10988         uuo2(k)=sngl(PhiExpo(0.,0.,1.,1.d0,1.d0,engy**2,b))
10989         uua2(k)=min(uuo2(k),max(0.,
10990      &          sngl(Phiexact(0.,0.,1.,1.d0,1.d0,engy**2,b))))
10991         uu3(k)=sngl(min(50d0,exp(om1intbi(b,2)/dble(r2hads(iclpro)
10992      &                                             +r2hads(icltar)))))
10993       endif
10994       if(j.eq.2)y=(1.-uua2(k))
10995       if(j.eq.3)y=uua2(k)
10996       if(j.eq.4.or.j.eq.6)y=(1.-uua2(k)*uu3(k))
10997       if(j.eq.5)y=uua2(k)*(uu3(k)-1.)
10998       write(ifhi,'(2e11.3)')b,y
10999          enddo
11000       write(ifhi,'(a)')    '  endarray'
11001       write(ifhi,'(a)')    'closehisto plot 0-'
11002          endif
11003       write(ifhi,'(a)')   '!##################################'
11004       write(ifhi,'(a)')   '! b distr unitarized theory '
11005       write(ifhi,'(a)')   '!##################################'
11006       write(ifhi,'(a,i1,a)')  'openhisto name b',j,'Unit'
11007       write(ifhi,'(a)')       'htyp lbf xmod lin ymod lin'
11008       write(ifhi,'(a)')    'text 0 0 "xaxis impact parameter b"'
11009       write(ifhi,'(a)')    'text 0 0 "yaxis P(b)"'
11010       write(ifhi,'(a)')       'array 2'
11011          do k=1,nbib
11012       b=b1+(k-0.5)*db
11013       if(j.eq.1)y=1
11014       if(j.eq.2)y=(1.-uuo2(k))
11015       if(j.eq.3)y=uuo2(k)
11016       if(j.eq.4.or.j.eq.6)y=(1.-uuo2(k)*uu3(k))
11017       if(j.eq.5)y=uuo2(k)*(uu3(k)-1.)
11018       write(ifhi,'(2e11.3)')b,y
11019          enddo
11020       write(ifhi,'(a)')    '  endarray'
11021       write(ifhi,'(a)')    'closehisto plot 0-'
11022       write(ifhi,'(a)')   '!##################################'
11023       write(ifhi,'(a)')   '! b distr for cross section '
11024       write(ifhi,'(a)')   '!##################################'
11025       write(ifhi,'(a,i1,a)')  'openhisto name b',j,'Unit'
11026       write(ifhi,'(a)')       'htyp lge xmod lin ymod lin'
11027       write(ifhi,'(a)')    'text 0 0 "xaxis impact parameter b"'
11028       write(ifhi,'(a)')    'text 0 0 "yaxis P(b)"'
11029       write(ifhi,'(a)')       'array 2'
11030          do k=1,nbib
11031       b=b1+(k-0.5)*db
11032       if(j.eq.1)y=1
11033       if(j.eq.2)y=(1.-(uuo2(k)+uua2(k))*0.5)
11034       if(j.eq.3)y=(uuo2(k)+uua2(k))*0.5
11035       if(j.eq.4.or.j.eq.6)y=(1.-(uuo2(k)+uua2(k))*0.5*uu3(k))
11036       if(j.eq.5)y=(uuo2(k)+uua2(k))*0.5*(uu3(k)-1.)
11037       write(ifhi,'(2e11.3)')b,y
11038          enddo
11039       write(ifhi,'(a)')    '  endarray'
11040       write(ifhi,'(a)')    'closehisto plot 0-'
11041       write(ifhi,'(a)')   '!##################################'
11042       write(ifhi,'(a)')   '! b distribution simulation'
11043       write(ifhi,'(a)')   '!##################################'
11044       write(ifhi,'(a,i1,a)')  'openhisto name b',j,'Simu'
11045       write(ifhi,'(a)')       'htyp lrf xmod lin ymod lin'
11046       write(ifhi,'(a,2e11.3)')'xrange',0.0,b2
11047       write(ifhi,'(a,2e11.3)')'yrange',0.,ymax
11048       write(ifhi,'(a)')    'text 0 0 "xaxis impact parameter b"'
11049       write(ifhi,'(a)')    'text 0 0 "yaxis P(b)"'
11050       if(j.eq.1)write(ifhi,'(a)')'text 0.1 0.35 "after Metropolis"'
11051       if(j.eq.1)write(ifhi,'(a)')'text 0.2 0.20 "all "'
11052       if(j.eq.2)write(ifhi,'(a)')'text 0.3 0.85 "after Metropolis"'
11053       if(j.eq.2)write(ifhi,'(a)')'text 0.5 0.70 "interaction "'
11054       if(j.eq.3)write(ifhi,'(a)')'text 0.3 0.85 "nothing"'
11055       if(j.eq.4)write(ifhi,'(a)')'text 0.3 0.85 "cut"'
11056       if(j.eq.5)write(ifhi,'(a)')'text 0.3 0.85 "diffr"'
11057       if(j.eq.6)write(ifhi,'(a)')'text 0.3 0.85 "cut + diffr cut"'
11058       write(ifhi,'(a)')       'array 2'
11059          do k=1,nbib
11060       x=b1+(k-0.5)*db
11061       if(j.eq.1)y=fk*w(j,k)/nn(1)/(pi*((x+0.5*db)**2-(x-0.5*db)**2))
11062       if(j.ne.1)y=0.
11063       if(j.ne.1.and.w(1,k).ne.0.)y=w(j,k)/w(1,k)
11064       if(nn(j).gt.0)write(ifhi,'(2e11.3)')x,y
11065          enddo
11066       write(ifhi,'(a)')    '  endarray'
11067       write(ifhi,'(a)')    'closehisto plot 0'
11068
11069    1  continue
11070
11071       koll=kollini
11072
11073       endif
11074
11075       return
11076       end
11077
11078 c-----------------------------------------------------------------------
11079       subroutine xEmsBg(iii,jjj,ko)
11080 c-----------------------------------------------------------------------
11081 c b distribution at different stages for different group
11082 c arguments:
11083 c   iii:  modus (0,1,2,3)
11084 c   jjj:  group of interaction (1,2 ... ,7)
11085 c   ko:   pair number (1 - AB)
11086 c-----------------------------------------------------------------------
11087       include 'epos.inc'
11088       include 'epos.incems'
11089       parameter(njjj=7)
11090       parameter(nbib=16)
11091       common/cxemsb4/wg(-1:njjj,nbib),nng(nbib),uug(nbib),kollx
11092       common/cxemsb5/dbg,b1g,b2g
11093       common/cxemsb6/njjj0
11094       double precision seedp,PhiExpo!,PhiExact
11095       common/geom/rmproj,rmtarg,bmax,bkmx
11096
11097       if(iemsbg.eq.0)call utstop('ERROR in XemsBg: iemsbg = 0&')
11098
11099         if(iii.eq.0)then
11100
11101       do k=1,nbib
11102        nng(k)=0
11103        do j=-1,njjj
11104         wg(j,k)=0
11105        enddo
11106       enddo
11107       njjj0=0
11108       kollx=0
11109
11110         elseif(iii.eq.1)then
11111
11112       b1g=0
11113       b2g=bkmx*1.2
11114       dbg=(b2g-b1g)/nbib
11115       k=int((bk(ko)-b1g)/dbg)+1
11116       if(k.gt.nbib)return
11117       if(k.lt.1)return
11118       if(jjj.eq.-1.or.jjj.eq.0)then
11119         wg(jjj,k)=wg(jjj,k)+1
11120       else
11121         wg(jjj,k)=wg(jjj,k)+1
11122         nng(k)=nng(k)+1
11123       endif
11124       if(jjj.eq.0)njjj0=1
11125
11126         elseif(iii.eq.3)then
11127
11128           call ranfgt(seedp)
11129           do k=1,koll
11130             om1i=sngl(om1intc(k))
11131             if(rangen().lt.1.-exp(-om1i))then
11132 c            om1i=sngl(PhiExpo(0.,0.,1.,1.d0,1.d0,engy*engy,bk(k)))
11133 c            if(rangen().lt.1.-om1i)then
11134               kollx=kollx+1
11135             endif
11136           enddo
11137           call ranfst(seedp)
11138
11139         elseif(iii.eq.2)then
11140
11141       if(njjj0.ne.1)call utstop
11142      &('xEmsBg must be called also with jjj=0&')
11143       ymax=1.4
11144       kollini=koll
11145       koll=1
11146
11147       wtot=1.
11148       if(matarg+maproj.gt.2)then
11149       wtot=0.
11150       do k=1,nbib
11151        wtot=wtot+wg(-1,k)
11152       enddo
11153       if(kollx.gt.0)wtot=wtot/float(kollx)
11154       endif
11155
11156       do 1 j=1,njjj
11157
11158       write(ifhi,'(a)')   '!##################################'
11159       write(ifhi,'(a)')   '! b distribution simulation'
11160       write(ifhi,'(a)')   '!##################################'
11161       write(ifhi,'(a,i1,a)')  'openhisto name bg',j,'Simu'
11162       write(ifhi,'(a)')       'htyp lin xmod lin ymod lin'
11163       write(ifhi,'(a,2e11.3)')'xrange',0.,b2g
11164       write(ifhi,'(a,2e11.3)')'yrange',0.,ymax
11165       write(ifhi,'(a)')    'text 0 0 "xaxis impact parameter b"'
11166       write(ifhi,'(a)')    'text 0 0 "yaxis P(b)"'
11167       if(wtot.gt.0.d0)
11168      &write(ifhi,'(a,f7.4,a)')    'text 0.5 0.8 "alpha=',1./wtot,'"'
11169       write(ifhi,'(a)')       'array 2'
11170          do k=1,nbib
11171       b=b1g+(k-0.5)*dbg
11172       y=0.
11173       if(nng(k).ne.0.and.wg(0,k).ne.0)
11174      &              y=wg(j,k)/float(nng(k))*wg(-1,k)/wg(0,k)!/wtot
11175 c      if(wg(0,k).ne.0..and.nng(k).ne.0)y=wg(j,k)/nng(k)*wg(-1,k)/wg(0,k)
11176 c!???????????? better normalization ? probability to have an interaction
11177 c in epos compared to eikonal probability, instead of normalized by the
11178 c probability of a collision for a pair (the number collision/number
11179 c active pair).
11180       uug(k)=uug(k)+y
11181       write(ifhi,'(2e11.3)')b,y
11182          enddo
11183       write(ifhi,'(a)')    '  endarray'
11184       write(ifhi,'(a)')    'closehisto plot 0-'
11185    1  continue
11186       write(ifhi,'(a)')   '!##################################'
11187       write(ifhi,'(a)')   '! b distr tot simul theory '
11188       write(ifhi,'(a)')   '!##################################'
11189       write(ifhi,'(a)')  'openhisto name btotSimu'
11190       write(ifhi,'(a)')       'htyp pfc xmod lin ymod lin'
11191       write(ifhi,'(a)')    'text 0 0 "xaxis impact parameter b"'
11192       write(ifhi,'(a)')    'text 0 0 "yaxis P(b)"'
11193       write(ifhi,'(a)')       'array 2'
11194          do k=1,nbib
11195       b=b1g+(k-0.5)*dbg
11196       write(ifhi,'(2e11.3)')b,uug(k)
11197          enddo
11198       write(ifhi,'(a)')    '  endarray'
11199       write(ifhi,'(a)')    'closehisto plot 0-'
11200       write(ifhi,'(a)')   '!##################################'
11201       write(ifhi,'(a)')   '! b distr unitarized theory '
11202       write(ifhi,'(a)')   '!##################################'
11203       write(ifhi,'(a,i1,a)')  'openhisto name bg',j,'Unit'
11204       write(ifhi,'(a)')       'htyp lba xmod lin ymod lin'
11205       write(ifhi,'(a)')    'text 0 0 "xaxis impact parameter b"'
11206       write(ifhi,'(a)')    'text 0 0 "yaxis P(b)"'
11207       write(ifhi,'(a)')       'array 2'
11208          do k=1,nbib
11209       b=b1g+(k-0.5)*dbg
11210 c      a1=Phiexact(0.,0.,1.,1.d0,1.d0,engy**2,b)
11211        a1=sngl(PhiExpo(0.,0.,1.,1.d0,1.d0,engy**2,b))
11212       y=(1.-a1)
11213       write(ifhi,'(2e11.3)')b,y
11214          enddo
11215       write(ifhi,'(a)')    '  endarray'
11216       write(ifhi,'(a)')    'closehisto plot 0'
11217
11218       koll=kollini
11219
11220       endif
11221
11222       return
11223       end
11224
11225 c-----------------------------------------------------------------------
11226       subroutine xEmsPx(iii,xmc,ymc,npos)
11227 c-----------------------------------------------------------------------
11228 c plot  x-distribution and y-distribution of Pomerons
11229 c-----------------------------------------------------------------------
11230
11231       include 'epos.inc'
11232       include 'epos.incems'
11233       common/geom/rmproj,rmtarg,bmax,bkmx
11234
11235       parameter(nbix=30,nbib=51)
11236       common/cx/x(2,nbix),dx(2,nbix),wxmc(2,nbix),wxmcI(2,nbix)
11237      * ,xl(2,nbix),dxl(2,nbix),wxp(2,nbix),wxm(2,nbix),wxpI(2,nbix)
11238      *,wxmI(2,nbix),wxpY(2,nbix),wxmY(2,nbix),wxmcY(2,nbix)
11239       parameter(nbiy=50)
11240       common/cy/y(nbiy),wymc(nbiy),wymcY(nbiy),wymcI(nbiy),nyp,nym
11241       double precision PomIncXExact,PomIncPExact,PomIncMExact,dcel
11242       double precision PomIncXIExact,PomIncPIExact,PomIncMIExact
11243       common/ems3/dcel,ad
11244       common/cemspx/xu,xo,yu,yo,dy,xlu,xlo,bb,nn,db,mm,nm,nt
11245       character mod*5, imod*5, txtxm*6
11246
11247       nposi=5
11248
11249       if(iemspx.eq.0)call utstop('ERROR in XemsPx: iemspx = 0&')
11250
11251       if(iii.eq.0)then
11252
11253        xu=0.1/engy**2
11254        xo=1.
11255        xlu=0.01/engy
11256        xlo=1.
11257        yu=-alog(engy**2)
11258        yo=alog(engy**2)
11259        dy=(yo-yu)/nbiy
11260         do i=1,nbix
11261         x(1,i)=xu*(xo/xu)**((i-0.5)/nbix)
11262         x(2,i)=xu+(xo-xu)*((i-0.5)/nbix)
11263         dx(1,i)=xu*(xo/xu)**(1.*i/nbix)*(1.-(xo/xu)**(-1./nbix))
11264         dx(2,i)=(xo-xu)/nbix
11265         wxmc(1,i)=0.
11266         wxmc(2,i)=0.
11267         wxmcI(1,i)=0.
11268         wxmcI(2,i)=0.
11269         wxmcY(1,i)=0.
11270         wxmcY(2,i)=0.
11271        enddo
11272        do i=1,nbix
11273         xl(1,i)=xlu*(xlo/xlu)**((i-0.5)/nbix)
11274         xl(2,i)=xlu+(xlo-xlu)*((i-0.5)/nbix)
11275         dxl(1,i)=xlu*(xlo/xlu)**(1.*i/nbix)*(1.-(xlo/xlu)**(-1./nbix))
11276         dxl(2,i)=(xlo-xlu)/nbix
11277         wxp(1,i)=0.
11278         wxp(2,i)=0.
11279         wxm(1,i)=0.
11280         wxm(2,i)=0.
11281         wxpI(1,i)=0.
11282         wxpI(2,i)=0.
11283         wxmI(1,i)=0.
11284         wxmI(2,i)=0.
11285         wxpY(1,i)=0.
11286         wxpY(2,i)=0.
11287         wxmY(1,i)=0.
11288         wxmY(2,i)=0.
11289        enddo
11290        do i=1,nbiy
11291         y(i)=yu+dy/2.+float(i-1)*dy
11292         wymc(i)=0.
11293         wymcI(i)=0.
11294         wymcY(i)=0.
11295        enddo
11296        mm=0
11297        nt=0
11298        nyp=0
11299        nym=0
11300        db=bkmx*2./float(nbib-1)
11301
11302       elseif(iii.eq.1)then
11303
11304        xp=sqrt(xmc)*exp(ymc)
11305        xm=sqrt(xmc)*exp(-ymc)
11306        mm=mm+1
11307
11308        if(xmc.lt.xu)goto11
11309        i=1+int(alog(xmc/xu)/alog(xo/xu)*nbix)
11310        if(i.gt.nbix)goto1
11311        if(i.lt.1)goto1
11312        wxmc(1,i)=wxmc(1,i)+1.
11313        if(npos.eq.1)    wxmcI(1,i)=wxmcI(1,i)+1.
11314        if(npos.eq.nposi)wxmcY(1,i)=wxmcY(1,i)+1.
11315 1      continue
11316        i=1+int((xmc-xu)/(xo-xu)*nbix)
11317        if(i.gt.nbix)goto11
11318        if(i.lt.1)goto11
11319        wxmc(2,i)=wxmc(2,i)+1.
11320        if(npos.eq.1)    wxmcI(2,i)=wxmcI(2,i)+1.
11321        if(npos.eq.nposi)wxmcY(2,i)=wxmcY(2,i)+1.
11322 11     continue
11323
11324        if(xp.lt.xlu)goto12
11325        i=1+int(alog(xp/xlu)/alog(xlo/xlu)*nbix)
11326        if(i.gt.nbix)goto2
11327        if(i.lt.1)goto2
11328        wxp(1,i)=wxp(1,i)+1.
11329        if(npos.eq.1)    wxpI(1,i)=wxpI(1,i)+1.
11330        if(npos.eq.nposi)wxpY(1,i)=wxpY(1,i)+1.
11331 2      continue
11332        i=1+int((xp-xlu)/(xlo-xlu)*nbix)
11333        if(i.gt.nbix)goto12
11334        if(i.lt.1)goto12
11335        wxp(2,i)=wxp(2,i)+1.
11336        if(npos.eq.1)    wxpI(2,i)=wxpI(2,i)+1.
11337        if(npos.eq.nposi)wxpY(2,i)=wxpY(2,i)+1.
11338 12     continue
11339
11340        if(xm.lt.xlu)goto13
11341        i=1+int(alog(xm/xlu)/alog(xlo/xlu)*nbix)
11342        if(i.gt.nbix)goto3
11343        if(i.lt.1)goto3
11344        wxm(1,i)=wxm(1,i)+1.
11345        if(npos.eq.1)    wxmI(1,i)=wxmI(1,i)+1.
11346        if(npos.eq.nposi)wxmY(1,i)=wxmY(1,i)+1.
11347 3      continue
11348        i=1+int((xm-xlu)/(xlo-xlu)*nbix)
11349        if(i.gt.nbix)goto13
11350        if(i.lt.1)goto13
11351        wxm(2,i)=wxm(2,i)+1.
11352        if(npos.eq.1)    wxmI(2,i)=wxmI(2,i)+1.
11353        if(npos.eq.nposi)wxmY(2,i)=wxmY(2,i)+1.
11354 13     continue
11355
11356        if(ymc.lt.yu)return
11357        i=int((ymc-yu)/dy)+1
11358        if(i.gt.nbiy)return
11359        if(i.lt.1)return
11360        wymc(i)=wymc(i)+1
11361        if(npos.eq.1)    wymcI(i)=wymcI(i)+1
11362        if(npos.eq.nposi)wymcY(i)=wymcY(i)+1
11363        if(ymc.gt.0)nyp=nyp+1
11364        if(ymc.lt.0)nym=nym+1
11365
11366       elseif(iii.eq.2)then
11367
11368        if(maproj.eq.1.and.matarg.eq.1.and.bminim.eq.bmaxim)then
11369         mmmm=1
11370         bb=bmaxim
11371         ff=float(nrevt)/float(ntevt)
11372         imod='   dn'
11373        elseif(maproj.eq.1.and.matarg.eq.1)then
11374         mmmm=3
11375         ff=1.
11376         imod='   dn'
11377        elseif(bminim.lt.0.001.and.bmaxim.gt.20)then
11378         mmmm=2
11379         area=pi*(rmproj+rmtarg)**2
11380         ff=area*float(nrevt)/float(ntevt)/(maproj*matarg)/sigine*10
11381         imod='   dn'
11382        else
11383         write(ifmt,*)'xEmsPx ignored'
11384         return
11385        endif
11386        kollini=koll
11387        koll=1
11388
11389        kk1=nint(xpar1)
11390        kk2=nint(xpar2)
11391
11392        do kk=kk1,kk2
11393
11394        if(kk.eq.1)mod=' log '
11395        if(kk.eq.2)mod=' lin '
11396
11397        write(ifhi,'(a)')       '!----------------------------------'
11398        write(ifhi,'(a)')       '!   Pomeron x distribution    '//mod
11399        write(ifhi,'(a)')       '!----------------------------------'
11400
11401        write(ifhi,'(a)')  'openhisto name xPomSimuL'//mod(3:4)
11402        write(ifhi,'(a)')  'htyp lru xmod'//mod//'ymod log'
11403        write(ifhi,'(a,2e11.3)')'xrange',xu,xo
11404        write(ifhi,'(a)')    'text 0 0 "xaxis x?PE!"'
11405        write(ifhi,'(a)') 'text 0 0 "yaxis'//imod//'?Pom! / dx?PE!"'
11406        if(kk.eq.1)write(ifhi,'(a,f5.2,a)')'text 0.1 0.3 "f=',ff,'"'
11407        if(kk.eq.2)write(ifhi,'(a,f5.2,a)')'text 0.1 0.1 "f=',ff,'"'
11408        write(ifhi,'(a)')       'array 2'
11409        s1=0
11410        do i=1,nbix
11411        u=x(kk,i)
11412        z=ff*wxmc(kk,i)/dx(kk,i)/nrevt
11413        s1=s1+z*dx(kk,i)
11414         write(ifhi,'(2e11.3)')u,z
11415        enddo
11416        write(ifhi,'(a)')    '  endarray'
11417        write(ifhi,'(a)')    'closehisto plot 0-'
11418
11419        write(ifhi,'(a)')       'openhisto name xPomUnitL'//mod(3:4)
11420        write(ifhi,'(a)')  'htyp lba xmod'//mod//'ymod log'
11421        write(ifhi,'(a,2e11.3)')'xrange',xu,xo
11422        write(ifhi,'(a)')    'text 0 0 "xaxis x?PE!"'
11423        write(ifhi,'(a)') 'text 0 0 "yaxis'//imod//'?Pom! / dx?PE!"'
11424        write(ifhi,'(a)')       'array 2'
11425        s2=0
11426        do i=1,nbix
11427         u=x(kk,i)
11428         if(mmmm.eq.1)z=sngl(PomIncXExact(dble(u),bb))
11429         if(mmmm.eq.2)z=sngl(PomIncXIExact(dble(u)))/sigine*10
11430         if(mmmm.eq.3)z=sngl(PomIncXIExact(dble(u)))/sigine*10
11431         s2=s2+dx(kk,i)*z
11432         write(ifhi,'(2e11.3)')u,z
11433        enddo
11434        write(ifhi,'(a)')    '  endarray'
11435        write(ifhi,'(a,f5.3,a,f5.3,a)')
11436      *                       'text .1 .85 "I= ',s1,' (',s2,')"'
11437        write(ifhi,'(a)')    'closehisto plot 0'
11438
11439        write(ifhi,'(a)')           '!--------------------------------'
11440        write(ifhi,'(a)')           '!   Pomeron y distribution   '//mod
11441        write(ifhi,'(a)')           '!--------------------------------'
11442
11443        write(ifhi,'(a)')       'openhisto name yPomSimuL'//mod(3:4)
11444        write(ifhi,'(a)')       'htyp lru xmod lin ymod'//mod
11445        write(ifhi,'(a,2e11.3)')'xrange',yu,yo
11446        write(ifhi,'(a)')    'text 0 0 "xaxis y?PE!"'
11447        write(ifhi,'(a)') 'text 0 0 "yaxis'//imod//'?Pom!/dy?PE!"'
11448        write(ifhi,'(a,f5.2,a)')'text 0.1 0.7 "f=',ff,'"'
11449        write(ifhi,'(a)')       'array 2'
11450        s1=0
11451        do i=1,nbiy
11452        u=y(i)
11453        z=ff*wymc(i)/dy/nrevt
11454        s1=s1+z*dy
11455         write(ifhi,'(2e11.3)')u,z
11456        enddo
11457        write(ifhi,'(a)')    '  endarray'
11458        write(ifhi,'(a)')    'closehisto plot 0'
11459
11460        write(ifhi,'(a)')       '!----------------------------------'
11461        write(ifhi,'(a)')       '!   Pomeron x+ distribution    '//mod
11462        write(ifhi,'(a)')       '!----------------------------------'
11463
11464        write(ifhi,'(a)')   'openhisto name xpPomSimuL'//mod(3:4)
11465        write(ifhi,'(a)')   'htyp lru xmod'//mod//'ymod log'
11466        write(ifhi,'(a,2e11.3)')'xrange',xlu,xlo
11467        write(ifhi,'(a)')    'text 0 0 "xaxis x+?PE!"'
11468        write(ifhi,'(a)') 'text 0 0 "yaxis'//imod//'?Pom! / dx+?PE!"'
11469        if(kk.eq.1)write(ifhi,'(a,f5.2,a)')'text 0.1 0.3 "f=',ff,'"'
11470        if(kk.eq.2)write(ifhi,'(a,f5.2,a)')'text 0.1 0.1 "f=',ff,'"'
11471        write(ifhi,'(a)')       'array 2'
11472        s1=0
11473        do i=1,nbix
11474        u=xl(kk,i)
11475        z=ff*wxp(kk,i)/dxl(kk,i)/nrevt
11476        s1=s1+z*dxl(kk,i)
11477         write(ifhi,'(2e11.3)')u,z
11478        enddo
11479        write(ifhi,'(a)')    '  endarray'
11480        write(ifhi,'(a)')    'closehisto plot 0-'
11481
11482        write(ifhi,'(a)')       'openhisto name xpPomUnitL'//mod(3:4)
11483        write(ifhi,'(a)')   'htyp lba xmod'//mod//'ymod log'
11484        write(ifhi,'(a,2e11.3)')'xrange',xlu,xlo
11485        write(ifhi,'(a)')    'text 0 0 "xaxis x+?PE!"'
11486        write(ifhi,'(a)') 'text 0 0 "yaxis'//imod//'?Pom! / dx+?PE!"'
11487        write(ifhi,'(a)')       'array 2'
11488        s2=0
11489        do i=1,nbix
11490         u=xl(kk,i)
11491         if(mmmm.eq.1)z=sngl(PomIncPExact(dble(u),bb))
11492         if(mmmm.eq.2)z=sngl(PomIncPIExact(dble(u)))/sigine*10
11493         if(mmmm.eq.3)z=sngl(PomIncPIExact(dble(u)))/sigine*10
11494         s2=s2+dxl(kk,i)*z
11495         write(ifhi,'(2e11.3)')u,z
11496        enddo
11497        write(ifhi,'(a)')    '  endarray'
11498        write(ifhi,'(a,f5.3,a,f5.3,a)')
11499      *                       'text .1 .85 "I= ',s1,' (',s2,')"'
11500        write(ifhi,'(a)')    'closehisto plot 0'
11501
11502        write(ifhi,'(a)')       '!----------------------------------'
11503        write(ifhi,'(a)')       '!   x-?PE! distribution    '//mod
11504        write(ifhi,'(a)')       '!----------------------------------'
11505
11506        write(ifhi,'(a)')   'openhisto name xmPomSimuL'//mod(3:4)
11507        write(ifhi,'(a)')   'htyp lru xmod'//mod//'ymod log'
11508        write(ifhi,'(a,2e11.3)')'xrange',xlu,xlo
11509        write(ifhi,'(a)')    'text 0 0 "xaxis x-?PE!"'
11510        write(ifhi,'(a)') 'text 0 0 "yaxis'//imod//'?Pom! / dx-?PE!"'
11511        if(kk.eq.1)write(ifhi,'(a,f5.2,a)')'text 0.1 0.3 "f=',ff,'"'
11512        if(kk.eq.2)write(ifhi,'(a,f5.2,a)')'text 0.1 0.1 "f=',ff,'"'
11513        write(ifhi,'(a)')       'array 2'
11514        s1=0
11515        do i=1,nbix
11516        u=xl(kk,i)
11517        z=ff*wxm(kk,i)/dxl(kk,i)/nrevt
11518        s1=s1+z*dxl(kk,i)
11519         write(ifhi,'(2e11.3)')u,z
11520        enddo
11521        write(ifhi,'(a)')    '  endarray'
11522        write(ifhi,'(a)')    'closehisto plot 0-'
11523
11524        write(ifhi,'(a)')       'openhisto name xmPomUnitL'//mod(3:4)
11525        write(ifhi,'(a)')   'htyp lba xmod'//mod//'ymod log'
11526        write(ifhi,'(a,2e11.3)')'xrange',xlu,xlo
11527        write(ifhi,'(a)')    'text 0 0 "xaxis x-?PE!"'
11528        write(ifhi,'(a)') 'text 0 0 "yaxis'//imod//'?Pom! / dx-"'
11529        write(ifhi,'(a)')       'array 2'
11530        s2=0
11531        do i=1,nbix
11532         u=xl(kk,i)
11533         if(mmmm.eq.1)z=sngl(PomIncMExact(dble(u),bb))
11534         if(mmmm.eq.2)z=sngl(PomIncMIExact(dble(u))/sigine*10)
11535         if(mmmm.eq.3)z=sngl(PomIncMIExact(dble(u))/sigine*10)
11536         s2=s2+dxl(kk,i)*z
11537         write(ifhi,'(2e11.3)')u,z
11538        enddo
11539        write(ifhi,'(a)')    '  endarray'
11540        write(ifhi,'(a,f5.3,a,f5.3,a)')
11541      *                       'text .1 .85 "I= ',s1,' (',s2,')"'
11542        write(ifhi,'(a)')    'closehisto plot 0'
11543
11544   !................................................................
11545
11546        xm=-1. !xm integration
11547        txtxm='xm int'
11548        do jjb=0,3
11549        b=jjb*0.5
11550        do jj=0,2
11551
11552        write(ifhi,'(a)')       '!----------------------------------'
11553        write(ifhi,'(a,3i1)')   '!   ffom11    '//mod,jjb,jj
11554        write(ifhi,'(a)')       '!----------------------------------'
11555
11556        write(ifhi,'(a,2i1)')'openhisto name ffom11L'//mod(3:4),jjb,jj+8
11557        write(ifhi,'(a)')    'htyp lin xmod'//mod//'ymod log'
11558        write(ifhi,'(a,2e11.3)')'xrange ',xlu,xlo
11559        write(ifhi,'(a)')'txt "xaxis  x+?PE!"'
11560        write(ifhi,'(a)')'txt "yaxis dn?Pom! / dx+?PE! "'
11561        write(ifhi,'(a)')'text 0.05 0.1  "fit and exact, all contrib."'
11562        if(jjb.lt.3)write(ifhi,'(a,f4.1,3a)')
11563      *             'txt "title ffom11   b =',b,'   ',txtxm,'"'
11564        if(jjb.ge.3)write(ifhi,'(3a)')
11565      *             'txt "title ffom11   b aver   ',txtxm,'"'
11566        write(ifhi,'(a)')       'array 2'
11567        do i=1,nbix
11568        u=xl(kk,i)
11569        if(jjb.lt.3.and.jj.eq.0)z= ffom11(u,xm,b,-1,-1)
11570        if(jjb.lt.3.and.jj.eq.1)z= ffom11(u,xm,b,0,5)
11571        if(jjb.lt.3.and.jj.eq.2)z= ffom11(u,xm,b,0,4)
11572        if(jjb.eq.3.and.jj.eq.0)z=ffom11a(u,xm,-1,-1)
11573        if(jjb.eq.3.and.jj.eq.1)z=ffom11a(u,xm,0,5)
11574        if(jjb.eq.3.and.jj.eq.2)z=ffom11a(u,xm,0,4)
11575         write(ifhi,'(2e11.3)')u,z
11576        enddo
11577        write(ifhi,'(a)')    '  endarray'
11578        if(jj.le.1)write(ifhi,'(a)')    'closehisto plot 0-'
11579        if(jj.eq.2)write(ifhi,'(a)')    'closehisto plot 0'
11580
11581        enddo
11582        enddo
11583
11584        do jjb=0,3
11585        b=jjb*0.5
11586        do jjj=1,6
11587        jj=jjj
11588        if(jjj.eq.6)jj=0
11589
11590        write(ifhi,'(a)')       '!----------------------------------'
11591        write(ifhi,'(a,3i1)')   '!   ffom11    '//mod,jjb,jj
11592        write(ifhi,'(a)')       '!----------------------------------'
11593
11594        write(ifhi,'(a,3i1)')'openhisto name om1ffL'//mod(3:4),jjb,jj
11595        if(jj.ne.0)write(ifhi,'(a)')    'htyp lin xmod'//mod//'ymod log'
11596        if(jj.eq.0)write(ifhi,'(a)')    'htyp lro xmod'//mod//'ymod log'
11597        write(ifhi,'(a,2e11.3)')'xrange ',xlu,xlo
11598        if(jj.eq.1)then
11599        write(ifhi,'(a)') 'txt "xaxis  x+?PE!"'
11600        write(ifhi,'(a)') 'txt "yaxis  dn?Pom! / dx+?PE!  "'
11601        if(kk.eq.2)then
11602         write(ifhi,'(a)') 'text 0.1 0.2  "soft sea-sea"'
11603         write(ifhi,'(a)') 'text 0.1 0.1  "val-sea sea-val val-val"'
11604        else
11605         write(ifhi,'(a)') 'text 0.05 0.8  "soft"'
11606         write(ifhi,'(a)') 'text 0.05 0.7  "diff"'
11607         write(ifhi,'(a)') 'text 0.05 0.6  "sea-sea"'
11608         write(ifhi,'(a)') 'text 0.05 0.5  "val-sea"'
11609         write(ifhi,'(a)') 'text 0.05 0.4  "sea-val"'
11610         write(ifhi,'(a)') 'text 0.05 0.3  "val-val"'
11611       endif
11612        if(jjb.lt.3)write(ifhi,'(a,f4.1,3a)')
11613      *             'txt "title ffom11   b =',b,'  ',txtxm,'"'
11614        if(jjb.ge.3)write(ifhi,'(3a)')
11615      *             'txt "title ffom11   b aver  ',txtxm,'"'
11616        endif
11617        write(ifhi,'(a)')       'array 2'
11618        do i=1,nbix
11619        u=xl(kk,i)
11620        if(jjb.lt.3)z= ffom11(u,xm,b,jj,jj)
11621        if(jjb.eq.3)z=ffom11a(u,xm,jj,jj)
11622        write(ifhi,'(2e11.3)')u,z
11623        enddo
11624        write(ifhi,'(a)')    '  endarray'
11625        if(jjj.ne.6)write(ifhi,'(a)')    'closehisto plot 0-'
11626        if(jjj.eq.6)write(ifhi,'(a)')    'closehisto plot 0'
11627
11628        enddo
11629        enddo
11630
11631       enddo
11632
11633       koll=kollini
11634       endif
11635
11636       return
11637       end
11638
11639 c-----------------------------------------------------------------------
11640       subroutine xEmsP2(iii,jaa,jex,xpd,xmd,xpb,xmb,pt1,pt2)
11641 c-----------------------------------------------------------------------
11642 c plot  x+ distributions of Pomeron ends (PE) (xpd)
11643 c          and Pomeron's in Born (IB) partons (xpb),
11644 c     and pt dist of Pomeron's out Born (OB) partons
11645 c       integrated over x- bins (xmd,xmb)
11646 c  iii=0: initialize
11647 c  ii=1: fill arrays
11648 c  iii>=2: make histogram
11649 c           (2 - Pomeron end PE, 3 - in Born IB, 4 - out Born OB)
11650 c  jaa: type of semihard Pomeron
11651 c         0= sea-sea diff,
11652 c         1= sea-sea, 2= val=sea, 3= sea-val, 4= val-val
11653 c         5= all  for iii=2
11654 c  jex: emission type
11655 c         1= no emission, 2= proj emis, 3= targ emis, 4= both sides
11656 c         5= all  for iii=2
11657 c-----------------------------------------------------------------------
11658
11659       include 'epos.inc'
11660       include 'epos.incsem'
11661       include 'epos.incems'
11662       common/geom/rmproj,rmtarg,bmax,bkmx
11663       parameter(nbixp=25,nbixm=5,nbipt=20)
11664       common/cxb/xlp(2,nbixp),dxlp(2,nbixp)
11665      *          ,xlm(2,nbixm),dxlm(2,nbixm)
11666      *          ,wxb(2,0:4,4,nbixp,nbixm)
11667      *          ,wxe(2,0:4,4,nbixp,nbixm)
11668       common/cptb/ptu,pto,ptob(nbipt),wptob(0:4,4,nbipt)
11669       common/cemspbx/xlub1,xlub2,xlob
11670 ctp060829      character imod*5
11671
11672       if(iemspbx.eq.0)call utstop('ERROR in xEmsP2: iemspbx = 0&')
11673
11674       if(iii.eq.0)then
11675
11676        xlub1=0.01/engy
11677        xlub2=0.
11678        xlob=1.
11679        do i=1,nbixp
11680         xlp(1,i)=xlub1*(xlob/xlub1)**((i-0.5)/nbixp)
11681         xlp(2,i)=xlub2+(xlob-xlub2)*((i-0.5)/nbixp)
11682         dxlp(1,i)=xlub1*(xlob/xlub1)**(1.*i/nbixp)
11683      *             *(1.-(xlob/xlub1)**(-1./nbixp))
11684         dxlp(2,i)=(xlob-xlub2)/nbixp
11685        enddo
11686        do i=1,nbixm
11687         xlm(1,i)=xlub1*(xlob/xlub1)**((i-0.5)/nbixm)
11688         xlm(2,i)=xlub2+(xlob-xlub2)*((i-0.5)/nbixm)
11689         dxlm(1,i)=xlub1*(xlob/xlub1)**(1.*i/nbixm)
11690      *             *(1.-(xlob/xlub1)**(-1./nbixm))
11691         dxlm(2,i)=(xlob-xlub2)/nbixm
11692        enddo
11693        do i=1,nbixp
11694        do j=1,nbixm
11695        do jaai=0,4
11696        do jexi=1,4
11697         wxb(1,jaai,jexi,i,j)=0.
11698         wxb(2,jaai,jexi,i,j)=0.
11699         wxe(1,jaai,jexi,i,j)=0.
11700         wxe(2,jaai,jexi,i,j)=0.
11701        enddo
11702        enddo
11703        enddo
11704        enddo
11705        ptu=2
11706        pto=20
11707        do i=1,nbipt
11708        ptob(i)=ptu+(pto-ptu)*(i-0.5)/nbipt
11709        do jaai=0,4
11710        do jexi=1,4
11711        wptob(jaai,jexi,i)=0
11712        enddo
11713        enddo
11714        enddo
11715
11716       elseif(iii.eq.1)then
11717
11718        xp=xpb
11719        xm=xmb
11720        if(xp.lt.xlub1)goto2
11721        if(xm.lt.xlub1)goto2
11722        i=1+int(alog(xp/xlub1)/alog(xlob/xlub1)*nbixp)
11723        if(i.gt.nbixp)goto2
11724        if(i.lt.1)goto2
11725        j=1+int(alog(xm/xlub1)/alog(xlob/xlub1)*nbixm)
11726        if(j.gt.nbixm)goto2
11727        if(j.lt.1)goto2
11728        wxb(1,jaa,jex,i,j)=wxb(1,jaa,jex,i,j)+1.
11729 2      continue
11730
11731        if(xp.lt.xlub2)goto12
11732        if(xm.lt.xlub2)goto12
11733        i=1+int((xp-xlub2)/(xlob-xlub2)*nbixp)
11734        if(i.gt.nbixp)goto12
11735        if(i.lt.1)goto12
11736        j=1+int((xm-xlub2)/(xlob-xlub2)*nbixm)
11737        if(j.gt.nbixm)goto12
11738        if(j.lt.1)goto12
11739        wxb(2,jaa,jex,i,j)=wxb(2,jaa,jex,i,j)+1.
11740 12     continue
11741
11742        xp=xpd
11743        xm=xmd
11744        if(xp.lt.xlub1)goto22
11745        if(xm.lt.xlub1)goto22
11746        i=1+int(alog(xp/xlub1)/alog(xlob/xlub1)*nbixp)
11747        if(i.gt.nbixp)goto22
11748        if(i.lt.1)goto22
11749        j=1+int(alog(xm/xlub1)/alog(xlob/xlub1)*nbixm)
11750        if(j.gt.nbixm)goto22
11751        if(j.lt.1)goto22
11752        wxe(1,jaa,jex,i,j)=wxe(1,jaa,jex,i,j)+1.
11753   22   continue
11754
11755        if(xp.lt.xlub2)goto32
11756        if(xm.lt.xlub2)goto32
11757        i=1+int((xp-xlub2)/(xlob-xlub2)*nbixp)
11758        if(i.gt.nbixp)goto32
11759        if(i.lt.1)goto32
11760        j=1+int((xm-xlub2)/(xlob-xlub2)*nbixm)
11761        if(j.gt.nbixm)goto32
11762        if(j.lt.1)goto32
11763        wxe(2,jaa,jex,i,j)=wxe(2,jaa,jex,i,j)+1.
11764   32   continue
11765
11766        do m=1,2
11767        if(m.eq.1)pt=pt1
11768        if(m.eq.2)pt=pt2
11769        i=1+int((pt-ptu)/(pto-ptu)*nbipt)
11770        if(i.lt.1)goto42
11771        if(i.gt.nbipt)goto42
11772        wptob(jaa,jex,i)=wptob(jaa,jex,i)+1
11773    42  continue
11774        enddo
11775
11776       elseif(iii.ge.2)then
11777
11778        if(maproj.eq.1.and.matarg.eq.1.and.bminim.eq.bmaxim)then
11779 ctp060829        mmmm=1
11780 ctp060829        bb=bmaxim
11781         ff=float(nrevt)/float(ntevt)
11782 ctp060829        imod='   dn'
11783        elseif(maproj.eq.1.and.matarg.eq.1)then
11784 ctp060829        mmmm=3
11785         ff=1.
11786 ctp060829        imod='   dn'
11787        elseif(bminim.lt.0.001.and.bmaxim.gt.20)then
11788 ctp060829        mmmm=2
11789         area=pi*(rmproj+rmtarg)**2
11790         ff=area*float(nrevt)/float(ntevt)/(maproj*matarg)/sigine*10
11791 ctp060829        imod='   dn'
11792        else
11793         write(ifmt,*)'xEmsP2 ignored'
11794         return
11795        endif
11796
11797        j1=1  !nint(xpar1)   !first xminus bin
11798        j2=5  !nint(xpar2)   !last xminus bin
11799        if(iii.eq.4)j2=1
11800        kkk=2 !nint(xpar3)   !1 (log binning) 2 (lin binning)
11801        if(kkk.eq.1)then
11802 ctp060829         xmi1=xlub1*(xlob/xlub1)**((j1-1.)/nbixm)
11803 ctp060829         xmi2=xlub1*(xlob/xlub1)**((j2-0.)/nbixm)
11804          xlub=xlub1
11805        elseif(kkk.eq.2)then
11806 ctp060829         xmi1=xlub2+(xlob-xlub2)*((j1-1.)/nbixm)
11807 ctp060829         xmi2=xlub2+(xlob-xlub2)*((j2-0.)/nbixm)
11808          xlub=xlub2
11809        endif
11810
11811        jaa1=jaa
11812        jaa2=jaa
11813        jex1=jex
11814        jex2=jex
11815        if(jaa.eq.5)then
11816        jaa1=0
11817        jaa2=4
11818        endif
11819        if(jex.eq.5)then
11820        jex1=1
11821        jex2=4
11822        endif
11823
11824        if(jex.eq.1)then
11825         je1=0
11826         je2=0
11827        elseif(jex.eq.2)then
11828         je1=1
11829         je2=0
11830        elseif(jex.eq.3)then
11831         je1=0
11832         je2=1
11833        elseif(jex.eq.4)then
11834         je1=1
11835         je2=1
11836        elseif(jex.eq.5)then
11837         je1=2
11838         je2=2
11839        endif
11840
11841        if(iii.eq.2)then
11842
11843         write(ifhi,'(a)')       '!----------------------------------'
11844         write(ifhi,'(a,3i1)')   '!   PE    ',jaa,jex
11845         write(ifhi,'(a)')       '!----------------------------------'
11846
11847         sum=ffom12aii(max(1,jaa),je1,je2)
11848         write(ifhi,'(a,2i1)')'openhisto name ffom12a',jaa,jex
11849         write(ifhi,'(a)')'htyp lin xmod lin ymod log'
11850         write(ifhi,'(a,2e11.3)')'xrange ',xlub,xlob
11851         write(ifhi,'(a)')    'txt "xaxis  x+?PE!"'
11852         write(ifhi,'(a)')    'txt "yaxis dn?semi! / dx+?PE!    "'
11853        write(ifhi,'(a,2i1,a)')'txt "title ffom12a + MC   (',jaa,jex,')"'
11854         write(ifhi,'(a)')    'array 2'
11855         do i=1,nbixp
11856          u=xlp(kkk,i)
11857          z=ffom12ai(u,max(1,jaa1),jaa2,je1,je2)
11858          write(ifhi,'(2e11.3)')u,z
11859         enddo
11860         write(ifhi,'(a)')    '  endarray'
11861         if(jex.eq.5)then
11862           write(ifhi,'(a)')    'closehisto plot 0-'
11863           write(ifhi,'(a,2i1)')'openhisto name ffom11',jaa,jex
11864           write(ifhi,'(a)')'htyp lba'
11865           write(ifhi,'(a)')'text 0.05 0.5 "+ ffom11a "'
11866           write(ifhi,'(a)')'array 2'
11867           do i=1,nbixp
11868            u=xlp(kkk,i)
11869            z=ffom11a(u,-1.,max(1,jaa1),jaa2)
11870            write(ifhi,'(2e11.3)')u,z
11871           enddo
11872           write(ifhi,'(a)')    '  endarray'
11873         endif
11874
11875        elseif(iii.eq.3)then
11876
11877         write(ifhi,'(a)')       '!----------------------------------'
11878         write(ifhi,'(a,3i1)')   '!   IB    ',jaa,jex
11879         write(ifhi,'(a)')       '!----------------------------------'
11880
11881     !.......total integral
11882         s2min=4*q2min
11883         zmin=s2min/engy**2
11884         zmax=1
11885         xpmin0 = 0.01/engy
11886         xpmax=1
11887         ig1=3
11888         ig2=3
11889         r1=0
11890         do i1=1,ig1
11891         do m1=1,2
11892           z=zmin*(zmax/zmin)**(.5+tgss(ig1,i1)*(m1-1.5))
11893           xpmin=max(z,xpmin0)
11894           r2=0
11895           if(xpmin.lt.xpmax)then
11896           do i2=1,ig2
11897           do m2=1,2
11898             xp=xpmin*(xpmax/xpmin)**(.5+tgss(ig2,i2)*(m2-1.5))
11899             xm=z/xp
11900             r2=r2+wgss(ig2,i2)*ffsigiut(xp,xm,max(1,jaa),je1,je2)
11901           enddo
11902           enddo
11903           endif
11904           r2=r2*0.5*log(xpmax/xpmin)
11905           r1=r1+wgss(ig1,i1)*r2*z
11906         enddo
11907         enddo
11908         r1=r1*0.5*log(zmax/zmin)
11909         res=  r1 * factk * .0390  /sigine*10
11910         sum=res
11911    !.......plot
11912         xx2min = 0.01/engy     !max(xpar1,0.01/engy)
11913         xx2max = 1             !xpar2
11914         xx1min = 0.01/engy     !max(xpar3,0.01/engy)
11915         xx1max = 1             !xpar4
11916         nbins  = 10            !nint(xpar5)
11917
11918         write(ifhi,'(a,2i1)') 'openhisto xrange 0 1 name ffsig',jaa,jex
11919         write(ifhi,'(a)') 'yrange auto auto htyp lin xmod lin ymod log'
11920         write(ifhi,'(a)') 'txt "xaxis x+?IB!         "              '
11921         write(ifhi,'(a)') 'txt "yaxis dn?semi! / dx+?IB!  "'
11922         write(ifhi,'(a,2i1,a)')'txt "title ffsig + MC   (',jaa,jex,')"'
11923         write(ifhi,'(a)') 'array 2'
11924         del=(xx1max-xx1min)/nbins
11925         do ii=1,nbins
11926           xx1=xx1min+(ii-0.5)*del
11927           ig2=3
11928           r2=0
11929           do i2=1,ig2
11930           do m2=1,2
11931             xx2=xx2min*(xx2max/xx2min)**(.5+tgss(ig2,i2)*(m2-1.5))
11932             r2=r2+wgss(ig2,i2)*ffsigiut(xx1,xx2,max(1,jaa),je1,je2)*xx2
11933           enddo
11934           enddo
11935           sig=r2*0.5*log(xx2max/xx2min)
11936           sig   = sig * factk * .0390   /sigine*10
11937           write(ifhi,'(2e12.4)')xx1,sig
11938         enddo
11939         write(ifhi,'(a)')  '  endarray'
11940
11941        elseif(iii.eq.4)then
11942
11943         write(ifhi,'(a)')       '!----------------------------------'
11944         write(ifhi,'(a,3i1)')   '!   OB    ',jaa,jex
11945         write(ifhi,'(a)')       '!----------------------------------'
11946
11947       !...... integral
11948         y2     = 10
11949         ptmin  = 2
11950         ptmax  = 6
11951         sum=0
11952         ig=2
11953         do i=1,ig
11954         do m=1,2
11955               pt=ptmin*(ptmax/ptmin)**(.5+tgss(ig,i)*(m-1.5))
11956           sig=ffsigi(pt**2,y2)
11957           sig   =sig    * factk * .0390 /sigine*10  * 2   ! 2 partons!
11958               sum=sum+wgss(ig,i)*sig*pt
11959         enddo
11960         enddo
11961         sum=sum*0.5*log(ptmax/ptmin)
11962       !...... pt distr
11963         y2     = 10
11964         ptmin  = 2
11965         ptmax  = 20
11966         nbins  = 18
11967         sx=engy**2
11968         do jj=3,1,-1
11969         write(ifhi,'(a,i1)')'openhisto name jet',jj
11970         write(ifhi,'(a)')'xrange 0 20 xmod lin ymod log '
11971         write(ifhi,'(a)') 'txt "xaxis pt?OB!         "           '
11972         write(ifhi,'(a)') 'txt "yaxis dn?ptn! / dpt?OB!  "'
11973         if(jj.eq.1)write(ifhi,'(a)')'htyp lro'
11974         if(jj.eq.2)write(ifhi,'(a)')'htyp lgo'
11975         if(jj.eq.3)write(ifhi,'(a)')'htyp lyo'
11976         write(ifhi,'(a,f7.2,a)')  'text 0.05 0.1 "1/f=',1./ff,'"'
11977         write(ifhi,'(a)')'array 2'
11978         delpt=(ptmax-ptmin)/nbins
11979         do i=1,nbins
11980           pt=ptmin+(i-0.5)*delpt
11981           sig=1
11982           if(jj.eq.1)then
11983             sig=ffsigi(pt**2,y2)      ! our stuff
11984           elseif(jj.eq.2)then
11985             if(engy.ge.10.)sig=psjvrg1(pt**2,sx,y2) ! grv
11986           elseif(jj.eq.3)then
11987             if(engy.ge.10.)sig=psjwo1(pt**2,sx,y2)   !duke-owens
11988           endif
11989           sig   =sig    * factk * .0390 /sigine*10 * 2
11990           write(ifhi,'(2e12.4)')pt,sig
11991         enddo
11992         write(ifhi,'(a)')       '  endarray'
11993         if(jj.ne.1)write(ifhi,'(a)')       'closehisto'
11994         if(jj.ne.1)write(ifhi,'(a)')  'plot 0-'
11995         enddo
11996
11997        endif
11998
11999        x=0.1+(min(3,iii)-2)*0.30
12000        y=0.2+(min(3,iii)-2)*0.55
12001        if(engy.gt.100.)then
12002        write(ifhi,'(a,2f5.2,a,f6.3,a)')'text',x,y,' "   form ',sum,'"'
12003        else
12004        write(ifhi,'(a,2f5.2,a,f6.5,a)')'text',x,y,' "   form ',sum,'"'
12005        endif
12006        write(ifhi,'(a)')  'closehisto plot 0-'
12007
12008        write(ifhi,'(a)') "!-----------------------------"
12009        write(ifhi,'(a)') "! MC   "
12010        write(ifhi,'(a)') "!-----------------------------"
12011
12012        if(iii.eq.2)
12013      *  write(ifhi,'(a,i1,i1)')'openhisto name dndxPE',jaa,jex
12014        if(iii.eq.3)
12015      *  write(ifhi,'(a,i1,i1)')'openhisto name dndxIB',jaa,jex
12016        if(iii.eq.4)
12017      *  write(ifhi,'(a,i1,i1)')'openhisto name dndptOB',jaa,jex
12018        write(ifhi,'(a)')     'htyp prs'
12019        write(ifhi,'(a)')     'array 2'
12020        sum=0
12021        imax=nbixp
12022        if(iii.eq.4)imax=nbipt
12023        do i=1,imax
12024         u=xlp(kkk,i)
12025         if(iii.eq.4)u=ptob(i)
12026         z=0
12027         do j=j1,j2
12028         do jaai=jaa1,jaa2
12029         do jexi=jex1,jex2
12030          if(iii.eq.2)z=z+wxe(kkk,jaai,jexi,i,j)
12031          if(iii.eq.3)z=z+wxb(kkk,jaai,jexi,i,j)
12032          if(iii.eq.4)z=z+wptob(jaai,jexi,i)
12033         enddo
12034         enddo
12035         enddo
12036         del=dxlp(kkk,i)
12037         if(iii.eq.4)del=(pto-ptu)/nbipt
12038         z=z/del*ff/nrevt
12039         write(ifhi,'(2e11.3)')u,z
12040         sum=sum+z*del
12041        enddo
12042        write(ifhi,'(a)')    '  endarray'
12043        x=0.1+(min(3,iii)-2)*0.30
12044        y=0.1+(min(3,iii)-2)*0.55
12045        if(engy.gt.100)then
12046        write(ifhi,'(a,2f5.2,a,f6.3,a)')'text',x,y,' "   simu ',sum,'"'
12047        else
12048        write(ifhi,'(a,2f5.2,a,f6.5,a)')'text',x,y,' "   simu ',sum,'"'
12049        endif
12050        write(ifhi,'(a)')    'closehisto'
12051
12052       endif
12053
12054       return
12055       end
12056
12057 c-----------------------------------------------------------------------
12058       subroutine xEmsSe(iii,xmc,ptmc,ih,iqq)
12059 c-----------------------------------------------------------------------
12060 c     iqq = 1 : String End mass and rapidity
12061 c     iqq = 2 : String mass and rapidity
12062 c-----------------------------------------------------------------------
12063
12064       include 'epos.inc'
12065
12066       parameter(nbix=50)
12067       common/cxpar/nx(2),x(nbix),wxmc(nbix,2),xmn,xmx,xu,xo
12068       parameter(nbiy=40)
12069       common/cypar/ny(2),y(nbiy),wymc(nbiy,2),ymin,ymax,dy,yu,yo
12070
12071       s=engy**2
12072
12073       if(iii.eq.0)then
12074
12075        nx(iqq)=0
12076        xu=0.1/engy**2
12077        xo=1.
12078        do i=1,nbix
12079          x(i)=xu*(xo/xu)**((i-0.5)/nbix)
12080          wxmc(i,iqq)=0
12081        enddo
12082        yo=alog(s)
12083        yu=-yo
12084        dy=(yo-yu)/nbiy
12085        ny(iqq)=0
12086        do i=1,nbiy
12087          y(i)=yu+dy/2.+(i-1)*dy
12088          wymc(i,iqq)=0
12089        enddo
12090
12091       elseif(iii.eq.1)then
12092
12093        if(xmc.lt.xu)return
12094        if(ptmc.eq.0.)return
12095        ymc=0.
12096        if(iqq.eq.1)ymc=0.5*alog(xmc*s/ptmc)*ih
12097        if(iqq.eq.2)ymc=0.5*alog(xmc/ptmc)
12098        i=1+int(alog(xmc/xu)/alog(xo/xu)*nbix)
12099        if(i.gt.nbix)goto1
12100        if(i.lt.1)goto1
12101        wxmc(i,iqq)=wxmc(i,iqq)+1
12102        nx(iqq)=nx(iqq)+1
12103 1      continue
12104        if(ymc.lt.yu)return
12105        i=int((ymc-yu)/dy)+1
12106        if(i.gt.nbiy)return
12107        if(i.lt.1)return
12108        wymc(i,iqq)=wymc(i,iqq)+1
12109        ny(iqq)=ny(iqq)+1
12110
12111       elseif(iii.eq.2)then
12112
12113        write(ifhi,'(a)')        '!--------------------------------'
12114        write(ifhi,'(a)')        '!   string end x distr       '
12115        write(ifhi,'(a)')        '!--------------------------------'
12116         write(ifhi,'(a)')       'openhisto'
12117         write(ifhi,'(a)')       'htyp lin'
12118         write(ifhi,'(a)')       'xmod log ymod log'
12119         write(ifhi,'(a,2e11.3)')'xrange',xu,xo
12120         if(iqq.eq.1)write(ifhi,'(a)')    'text 0 0 "xaxis string end x"'
12121         if(iqq.eq.2)write(ifhi,'(a)')    'text 0 0 "xaxis string x"'
12122         write(ifhi,'(a)')    'text 0 0 "yaxis P(x)"'
12123         write(ifhi,'(a)')       'array 2'
12124         do i=1,nbix
12125          dx=xu*(xo/xu)**(1.*i/nbix)*(1.-(xo/xu)**(-1./nbix))
12126          if(nx(iqq).gt.0)
12127      *   write(ifhi,'(2e11.3)')x(i),wxmc(i,iqq)/dx/nx(iqq)
12128         enddo
12129         write(ifhi,'(a)')    '  endarray'
12130         write(ifhi,'(a)')    'closehisto plot 0'
12131         write(ifhi,'(a)')       'openhisto'
12132         write(ifhi,'(a)')       'htyp lin'
12133         write(ifhi,'(a)')       'xmod lin ymod lin'
12134         write(ifhi,'(a,2e11.3)')'xrange',yu,yo
12135         if(iqq.eq.1)write(ifhi,'(a)')    'text 0 0 "xaxis string end y"'
12136         if(iqq.eq.2)write(ifhi,'(a)')    'text 0 0 "xaxis string y"'
12137         write(ifhi,'(a)')    'text 0 0 "yaxis P(y)"'
12138         write(ifhi,'(a)')       'array 2'
12139         do i=1,nbiy
12140          if(ny(iqq).gt.0)
12141      *   write(ifhi,'(2e11.3)')y(i),wymc(i,iqq)/dy/ny(iqq)
12142         enddo
12143         write(ifhi,'(a)')    '  endarray'
12144         write(ifhi,'(a)')    'closehisto plot 0'
12145       endif
12146
12147       return
12148       end
12149
12150 c-----------------------------------------------------------------------
12151       subroutine xEmsDr(iii,xpmc,xmmc,ie)
12152 c-----------------------------------------------------------------------
12153
12154       include 'epos.inc'
12155
12156       parameter(nbix=50,nie=4)
12157       common/cxpardr/nxp(nie),nxm(nie),x(nbix),wxpmc(nbix,nie)
12158      &      ,wxmmc(nbix,nie),xmn,xmx,xu,xo,wxmc(nbix,nie),nx(nie)
12159       parameter(nbiy=40)
12160       common/cypardr/ny(nie),y(nbiy),wymc(nbiy,nie),ymin,ymax,dy,yu,yo
12161
12162       s=engy**2
12163
12164       if(iii.eq.0)then
12165
12166        do ni=1,nie
12167          nxp(ni)=0
12168          nxm(ni)=0
12169          nx(ni)=0
12170        enddo
12171        xu=0.1/engy**2
12172        xo=1.
12173        do i=1,nbix
12174          x(i)=xu*(xo/xu)**((i-0.5)/nbix)
12175          do ni=1,nie
12176            wxpmc(i,ni)=0
12177            wxmmc(i,ni)=0
12178            wxmc(i,ni)=0
12179          enddo
12180        enddo
12181        yo=alog(s)
12182        yu=-yo
12183        dy=(yo-yu)/nbiy
12184        do ni=1,nie
12185          ny(ni)=0
12186        enddo
12187        do i=1,nbiy
12188          y(i)=yu+dy/2.+(i-1)*dy
12189          do ni=1,nie
12190            wymc(i,ni)=0
12191          enddo
12192        enddo
12193
12194       elseif(iii.eq.1)then
12195
12196        if(ie.lt.1.or.ie.gt.nie)return
12197
12198        if(xpmc.lt.xu)return
12199        i=1+int(alog(xpmc/xu)/alog(xo/xu)*nbix)
12200        if(i.gt.nbix)goto1
12201        if(i.lt.1)goto1
12202        wxpmc(i,ie)=wxpmc(i,ie)+1
12203        nxp(ie)=nxp(ie)+1
12204        if(xmmc.lt.xu)return
12205        i=1+int(alog(xmmc/xu)/alog(xo/xu)*nbix)
12206        if(i.gt.nbix)goto1
12207        if(i.lt.1)goto1
12208        wxmmc(i,ie)=wxmmc(i,ie)+1
12209        nxm(ie)=nxm(ie)+1
12210 1      continue
12211        if(xmmc.ge.xu)then
12212          ymc=0.5*alog(xpmc/xmmc)
12213        else
12214          return
12215        endif
12216        if(ymc.lt.yu)return
12217        i=int((ymc-yu)/dy)+1
12218        if(i.gt.nbiy)return
12219        if(i.lt.1)return
12220        wymc(i,ie)=wymc(i,ie)+1
12221        ny(ie)=ny(ie)+1
12222
12223        xmc=xpmc*xmmc
12224        if(xmc.lt.xu)return
12225        i=1+int(alog(xmc/xu)/alog(xo/xu)*nbix)
12226        if(i.gt.nbix)return
12227        if(i.lt.1)return
12228        wxmc(i,ie)=wxmc(i,ie)+1
12229        nx(ie)=nx(ie)+1
12230
12231       elseif(iii.eq.2)then
12232
12233         do ii=1,nie
12234
12235        if(ii.eq.1)write(ifhi,'(a)')'!-----  projectile droplet  ----'
12236        if(ii.eq.2)write(ifhi,'(a)')'!-----    target droplet    ----'
12237        if(ii.eq.3)write(ifhi,'(a)')'!-----  projectile string end  ----'
12238        if(ii.eq.4)write(ifhi,'(a)')'!-----    target string end    ----'
12239         write(ifhi,'(a)')       '!--------------------------------'
12240         write(ifhi,'(a)')       '!   droplet/string x+ distr       '
12241         write(ifhi,'(a)')       '!--------------------------------'
12242         write(ifhi,'(a)')       'openhisto'
12243         write(ifhi,'(a)')       'htyp lru'
12244         write(ifhi,'(a)')       'xmod log ymod log'
12245         write(ifhi,'(a,2e11.3)')'xrange',xu,xo
12246         if(ii.eq.1.or.ii.eq.2)
12247      *  write(ifhi,'(a)')    'text 0 0 "xaxis droplet x+"'
12248         if(ii.eq.3.or.ii.eq.4)
12249      *  write(ifhi,'(a)')    'text 0 0 "xaxis string end x+"'
12250         write(ifhi,'(a)')    'text 0 0 "yaxis P(x)"'
12251         write(ifhi,'(a)')       'array 2'
12252         do i=1,nbix
12253          dx=xu*(xo/xu)**(1.*i/nbix)*(1.-(xo/xu)**(-1./nbix))
12254          if(nxp(ii).gt.0)
12255      *   write(ifhi,'(2e11.3)')x(i),wxpmc(i,ii)/dx/nxp(ii)
12256         enddo
12257         write(ifhi,'(a)')    '  endarray'
12258         write(ifhi,'(a)')    'closehisto plot 0-'
12259         write(ifhi,'(a)')       '!--------------------------------'
12260         write(ifhi,'(a)')       '!   droplet/string x- distr       '
12261         write(ifhi,'(a)')       '!--------------------------------'
12262         write(ifhi,'(a)')       'openhisto'
12263         write(ifhi,'(a)')       'htyp lba'
12264         write(ifhi,'(a)')       'xmod log ymod log'
12265         write(ifhi,'(a,2e11.3)')'xrange',xu,xo
12266         if(ii.eq.1.or.ii.eq.2)
12267      *  write(ifhi,'(a)')    'text 0 0 "xaxis droplet x-"'
12268         if(ii.eq.3.or.ii.eq.4)
12269      *  write(ifhi,'(a)')    'text 0 0 "xaxis string end x-"'
12270         write(ifhi,'(a)')    'text 0 0 "yaxis P(x)"'
12271         write(ifhi,'(a)')       'array 2'
12272         do i=1,nbix
12273          dx=xu*(xo/xu)**(1.*i/nbix)*(1.-(xo/xu)**(-1./nbix))
12274          if(nxm(ii).gt.0)
12275      *   write(ifhi,'(2e11.3)')x(i),wxmmc(i,ii)/dx/nxm(ii)
12276         enddo
12277         write(ifhi,'(a)')    '  endarray'
12278         write(ifhi,'(a)')    'closehisto plot 0'
12279         write(ifhi,'(a)')       '!--------------------------------'
12280         write(ifhi,'(a)')       '!   droplet/string y distr       '
12281         write(ifhi,'(a)')       '!--------------------------------'
12282         write(ifhi,'(a)')       'openhisto'
12283         write(ifhi,'(a)')       'htyp lin'
12284         write(ifhi,'(a)')       'xmod lin ymod lin'
12285         write(ifhi,'(a,2e11.3)')'xrange',yu,yo
12286         if(ii.eq.1.or.ii.eq.2)
12287      *  write(ifhi,'(a)')    'text 0 0 "xaxis droplet y"'
12288         if(ii.eq.3.or.ii.eq.4)
12289      *  write(ifhi,'(a)')    'text 0 0 "xaxis string end y"'
12290         write(ifhi,'(a)')    'text 0 0 "yaxis P(y)"'
12291         write(ifhi,'(a)')       'array 2'
12292         do i=1,nbiy
12293          if(ny(ii).gt.0)
12294      *   write(ifhi,'(2e11.3)')y(i),wymc(i,ii)/dy/ny(ii)
12295         enddo
12296         write(ifhi,'(a)')    '  endarray'
12297         write(ifhi,'(a)')    'closehisto plot 0'
12298
12299       enddo
12300
12301         write(ifhi,'(a)')       '!--------------------------------'
12302         write(ifhi,'(a)')       '!   droplet/string mass distr       '
12303         write(ifhi,'(a)')       '!--------------------------------'
12304       do ii=1,nie
12305
12306
12307         if(ii.eq.2.or.ii.eq.4)write(ifhi,'(a)')    'closehisto plot 0-'
12308         if(ii.eq.3)write(ifhi,'(a)')    'closehisto plot 0'
12309         write(ifhi,'(a)')       'openhisto'
12310         if(ii.eq.1.or.ii.eq.3)write(ifhi,'(a)')       'htyp lru'
12311         if(ii.eq.2.or.ii.eq.4)write(ifhi,'(a)')       'htyp lba'
12312         write(ifhi,'(a)')       'xmod log ymod log'
12313         write(ifhi,'(a,2e11.3)')'xrange',sqrt(xu*s),sqrt(s*xo)
12314         if(ii.eq.1.or.ii.eq.2)
12315      *  write(ifhi,'(a)')    'text 0 0 "xaxis droplet mass (GeV)"'
12316         if(ii.eq.4.or.ii.eq.3)
12317      *  write(ifhi,'(a)')    'text 0 0 "xaxis string end mass (GeV)"'
12318         write(ifhi,'(a)')    'text 0 0 "yaxis P(x)"'
12319         write(ifhi,'(a)')       'array 2'
12320         do i=1,nbix
12321          dx=xu*(xo/xu)**(1.*i/nbix)*(1.-(xo/xu)**(-1./nbix))
12322          if(nx(ii).gt.0)
12323      *   write(ifhi,'(2e11.3)')sqrt(x(i)*s),wxmc(i,ii)/dx/nx(ii)
12324         enddo
12325         write(ifhi,'(a)')    '  endarray'
12326       enddo
12327        write(ifhi,'(a)')    'closehisto plot 0'
12328
12329       endif
12330
12331       return
12332       end
12333
12334 cc--------------------------------------------------------------------------
12335 c      subroutine xtype(k,n,i1,i2,text)
12336 cc--------------------------------------------------------------------------
12337 c
12338 c      include 'epos.inc'
12339 c      include 'epos.incems'
12340 c      parameter(itext=40)
12341 c      character  text*40
12342 c
12343 c      imax=itext+1
12344 c      do i=itext,1,-1
12345 c      if(text(i:i).eq.'&')imax=i
12346 c      enddo
12347 c
12348 c      ip=iproj(k)
12349 c      it=itarg(k)
12350 c
12351 c      if(i1.eq.1)then
12352 c         write(ifch,*)
12353 c         write(ifch,*)('-',ll=1,27)
12354 c         write(ifch,*)'  '//text(1:imax-1)
12355 c         write(ifch,*)('-',ll=1,27)
12356 c      endif
12357 c
12358 c      if(i2.eq.1)then
12359 c         write(ifch,*)
12360 c         write(ifch,*)'k:',k,'   n:',n,'   ip:',ip,'   it:',it
12361 c         write(ifch,*)'bk:',bk(k)
12362 c         if(n.ne.0)write(ifch,*)'idpr:',idpr(n,k)
12363 c         write(ifch,*)'iep:',iep(ip),'   iet:',iet(it)
12364 c         write(ifch,*)'idp:',idp(ip),'   idt:',idt(it)
12365 c      endif
12366 c
12367 c      end
12368 c
12369 c------------------------------------------------------------------------
12370       subroutine XPrint(text)
12371 c------------------------------------------------------------------------
12372       include 'epos.inc'
12373       include 'epos.incems'
12374       double precision xpptot,xmptot,xpttot,xmttot
12375 c      parameter(itext=15)
12376       character  text*(*)
12377       imax=index(text,'&')
12378       if(imax.gt.1)write(ifch,'(1x,a)')text(1:imax-1)
12379
12380       write(ifch,'(a)')
12381      *' k:     itpr:   npr0: npr1: nprmx:   Pomeron id lattice:'
12382       do k=1,koll
12383        write(ifch,'(1x,i6,1x,i4,4x,i4,2x,i4,3x,i4,a3,$)')
12384      *              k,itpr(k),npr(0,k),npr(1,k),nprmx(k),'   '
12385        do n=1,nprmx(k)
12386         write(ifch,'(i2,$)')idpr(n,k)
12387        enddo
12388        write(ifch,*)' '
12389       enddo
12390
12391       xpptot=0d0
12392       xmptot=0d0
12393       xpttot=0d0
12394       xmttot=0d0
12395       write(ifch,'(a)')' Pomeron xy lattice:'
12396       do k=1,koll
12397        do n=1,nprmx(k)
12398        xpptot=xpptot+xppr(n,k)
12399        xmttot=xmttot+xmpr(n,k)
12400         write(ifch,'(i6,1x,i2,1x,d10.3,1x,d10.3,3x,$)')
12401      *                  k,n,xpr(n,k),ypr(n,k)
12402        enddo
12403        write(ifch,*)' '
12404       enddo
12405
12406       write(ifch,'(a)')' projectile remnants x+,x-,px,py,x,iep:'
12407       do ip=1,maproj
12408        xpptot=xpptot+xpp(ip)
12409        xmptot=xmptot+xmp(ip)
12410        write(ifch,'(i3,2x,5d12.3,i3)')ip,xpp(ip),xmp(ip),xxp(ip),xyp(ip)
12411      *                             ,xpos(ip),iep(ip)
12412       enddo
12413
12414       write(ifch,'(a)')' target remnants x-,x+,px,py,x,iet:'
12415       do it=1,matarg
12416        xpttot=xpttot+xpt(it)
12417        xmttot=xmttot+xmt(it)
12418        write(ifch,'(i3,2x,5d12.3,i3)')it,xmt(it),xpt(it),xxt(it),xyt(it)
12419      *                             ,xtos(it),iet(it)
12420       enddo
12421
12422       write(ifch,*)' remnant balance x+,x-:'
12423      &,(xpptot+xpttot)/dble(maproj)
12424      &,(xmptot+xmttot)/dble(matarg)
12425       end
12426
12427
12428 c-------------------------------------------------------------------------
12429       subroutine xfom
12430 c-------------------------------------------------------------------------
12431       include 'epos.inc'
12432       double precision fom,x
12433       write(ifhi,'(a)')     '!##################################'
12434       write(ifhi,'(a,i3)')  '!   fom     '
12435       write(ifhi,'(a)')     '!##################################'
12436       b=0.
12437       do i=1,6
12438         z=0.2*exp(0.8*i)
12439         xi=0.01+0.16*float(i-1)
12440         write(ifhi,'(a,i1)') 'openhisto name fom',i
12441         write(ifhi,'(a)')    'htyp lin xmod lin ymod log'
12442         write(ifhi,'(a)')    'xrange 0 1'
12443         write(ifhi,'(a)')    'yrange 0.1 1000 '
12444         write(ifhi,'(a)')    'text 0 0 "xaxis x "'
12445         write(ifhi,'(a)')    'text 0 0 "yaxis fom"'
12446         if(z.lt.10.)
12447      &   write(ifhi,'(a,f4.2,a,f4.1,a)')'text ',xi,' 0.9 "',z,'"'
12448         if(z.ge.10.)
12449      &   write(ifhi,'(a,f4.2,a,f4.0,a)')'text ',xi,' 0.9 "',z,'"'
12450         write(ifhi,'(a)')    'array 2'
12451         do n=1,99
12452           x=dble(n)*0.01d0
12453           write(ifhi,'(2e11.3)')x,fom(z,x,b)
12454         enddo
12455         write(ifhi,'(a)')    '  endarray'
12456         write(ifhi,'(a)')    '  closehisto '
12457         if(i.lt.6)write(ifhi,'(a)')    'plot 0-'
12458         if(i.eq.6)write(ifhi,'(a)')    'plot 0'
12459       enddo
12460       end
12461
12462
12463 c-----------------------------------------------------------------------
12464       subroutine xbDens(jjj)
12465 c-----------------------------------------------------------------------
12466 c plots b distribution for all pairs
12467 c----------------------------------------------------------------
12468       include 'epos.inc'
12469       include 'epos.incems'
12470       common/geom/rmproj,rmtarg,bmax,bkmx
12471
12472       if(jjj.eq.1)then
12473 c prepare plot for xbDens
12474       if(ixbDens.eq.1)then
12475         iii=1     !proj
12476         Nnucla=0
12477         do ip=1,maproj
12478           if(lproj(ip).ne.0)then
12479             Nnucla=Nnucla+1
12480             do l=1,lproj(ip)
12481 C...fix compilation warning
12482 C              k=kproj(ip,l)
12483 C              b=bk(k)
12484 C              i=1+int(b/bkmx*float(mxnucl))
12485               i=1+int(bk(kproj(ip,l))/bkmx*float(mxnucl))
12486               if(i.le.mxnucl)bnucl(i,iii)=bnucl(i,iii)+1.
12487             enddo
12488           endif
12489           if(lproj3(ip).ne.0)then
12490             do l=1,lproj3(ip)
12491 C...fix compilation warning
12492 C              k=kproj3(ip,l)
12493 C              b=bk(k)
12494 C              i=1+int(b/bkmx*float(mxnucl))
12495               i=1+int(bk(kproj3(ip,l))/bkmx*float(mxnucl))
12496               if(i.le.mxnucl)bnucl(i,iii+2)=bnucl(i,iii+2)+1.
12497             enddo
12498           endif
12499         enddo
12500         xbtot(iii)=xbtot(iii)+float(Nnucla)
12501         iii=2     !targ
12502         Nnucla=0
12503         do it=1,matarg
12504           if(ltarg(it).ne.0)then
12505             Nnucla=Nnucla+1
12506             do l=1,ltarg(it)
12507               k=ktarg(it,l)
12508               b=bk(k)
12509               i=1+int(b/bkmx*float(mxnucl))
12510               if(i.le.mxnucl)bnucl(i,iii)=bnucl(i,iii)+1.
12511             enddo
12512           endif
12513           if(ltarg3(it).ne.0)then
12514             do l=1,ltarg3(it)
12515               k=ktarg3(it,l)
12516               b=bk(k)
12517               i=1+int(b/bkmx*float(mxnucl))
12518               if(i.le.mxnucl)bnucl(i,iii+2)=bnucl(i,iii+2)+1.
12519             enddo
12520           endif
12521         enddo
12522         xbtot(iii)=xbtot(iii)+float(Nnucla)
12523       endif
12524
12525       else
12526
12527       if(xbtot(1).gt.0.)then
12528         xbtot(3)=xbtot(1)
12529         xbtot(4)=xbtot(2)
12530         write(ifhi,'(a)')       'openhisto'
12531         write(ifhi,'(a)')       'htyp lin name bdens'
12532         write(ifhi,'(a)')       '- txt "xaxis b (fm)" '
12533         write(ifhi,'(a)')       '+ txt "yaxis P(b) proj " '
12534         write(ifhi,'(a)')       '+ txt "yaxis P(b) targ " '
12535         write(ifhi,'(a)')       '+ txt "yaxis P(b) scr proj " '
12536         write(ifhi,'(a)')       '+ txt "yaxis P(b) scr targ " '
12537         write(ifhi,'(a)')       'array 5'
12538         db=bkmx/float(mxnucl)
12539         do j=1,mxnucl
12540           b=(j-0.5)*db
12541           d=pi*((b+db)**2-b**2)
12542           write(ifhi,'(2e12.4)') b,(bnucl(j,iii)/xbtot(iii)/d,iii=1,4)
12543         enddo
12544         write(ifhi,'(a)')       '  endarray'
12545         write(ifhi,'(a)')       'closehisto'
12546         write(ifhi,'(a)')       'plot bdens+1- plot bdens+2-'
12547         write(ifhi,'(a)')       'plot bdens+3- plot bdens+4 '
12548       endif
12549
12550       endif
12551
12552       end