EPOS/epos167/epos-ems-165.f

   1 c-----------------------------------------------------------------------
   2       subroutine emsaa(iret)
   3 c-----------------------------------------------------------------------
   4 c  energy-momentum sharing
   5 c-----------------------------------------------------------------------
   6
   7       include 'epos.inc'
   8       include 'epos.incems'
   9       common/cwzero/wzero,wzerox
  10       double precision omega,omlog,oma,omb,wab,wba,wmatrix,wzero,nbar
  11      *,wzerox,rrr,eps,xprem,xmrem,om1intgck
  12       parameter(eps=1.d-30)
  13       common/col3/ncol,kolpt
  14 c      logical modu
  15       common/cems5/plc,s
  16       double precision s,px,py,pomass,plc!,PhiExpo
  17       common/emsptl/nppr(npommx,kollmx),npproj(mamx),nptarg(mamx)
  18       common/cncl3/iactpr(mamx),iacttg(mamx)
  19       common/nucl3/phi,bimp
  20       logical vpom
  21       dimension ishuff(500),icp(2),ict(2)
  22       call utpri('emsaa ',ish,ishini,4)
  23
  24       ntry2=0
  25       irea=iret
  26
  27  0001 continue
  28       iret=0
  29       iret2=0
  30
  31 c     initialize
  32 c     ----------
  33
  34       if(ntry2.gt.0)then
  35         call conre
  36         call conwr
  37       endif
  38       call emsipt   !initialize projectile and target
  39       call emsigr   !initialize grid
  40
  41
  42
  43            if((iactpr(1).eq.1.and.iacttg(1).eq.1.and.maproj+matarg.eq.2)
  44      &
  45      &.or.(iactpr(1).eq.1.and.maproj.eq.1.and.maproj+matarg.gt.2)
  46      &.or.(iacttg(1).eq.1.and.matarg.eq.1.and.maproj+matarg.gt.2)
  47      &.or.(maproj.gt.1.and.matarg.gt.1))then !if not nothing
  48
  49
  50         ievt0=0
  51
  52         nSprmx=0
  53         do k=1,koll
  54           nSprmx=nSprmx+nprmx(k)
  55         enddo
  56
  57         omlog=0
  58         nemsi=nemsi+1
  59         if(nemsi.le.4.and.iemsi1.eq.1)call xEmsI1(1,0,omlog)
  60         if(ish.ge.6)write (ifch,*)'after xEmsI1'
  61         if(nemsi.le.4.and.iemsi2.eq.1)call xEmsI2(1,0)
  62         if(ish.ge.6)write (ifch,*)'after xEmsI2'
  63         if(ish.ge.6)call XPrint('Before Markov:&')
  64
  65
  66 c     Markov
  67 c     ------
  68
  69       if(ish.ge.4)write(ifch,*)'Markov Process'
  70       kint=int(max(15.,2.*engy**0.2))
  71       if(koll.gt.50)kint=3*kint/int(log(float(koll)))
  72       kmcmx=nSprmx*kint        !50*kint  !100*kint
  73
  74
  75       do kmc=1,kmcmx               !-----> start Metropolis
  76
  77        knprmx=0
  78        rrr=dble(rangen())
  79        do ik=1,koll
  80          knprmx=knprmx+nprmx(ik)
  81          if(rrr.le.dble(knprmx)/dble(nSprmx))then ! k-th pair
  82            k=ik
  83            goto 10
  84          endif
  85        enddo
  86  10    continue
  87
  88        ip=iproj(k)
  89        it=itarg(k)
  90        n=1+int(rangen()*float(nprmx(k)))  ! n-th spot for k-th pair
  91        nbar=dble(npr(0,k))
  92        if(idpr(n,k).eq.0)nbar=nbar-1d0
  93
  94        xprem=1.d0!xpp(ip)+xppr(n,k)        !consistently, it should be 1.
  95        xmrem=1.d0!xmt(it)+xmpr(n,k)
  96        wzerox=(nbar+1d0)
  97        wzero=wzerox    / ( wzerox
  98      &                    +om1intgck(k,xprem,xmrem)*gammaV(k) )
  99
 100        if(ish.ge.8)write(ifch,*)'wzero',k,n,wzero,wzerox,gammaV(k)
 101      &                          ,om1intgck(k,xprem,xmrem)
 102        if(ish.ge.1.and.100000*(kmc/100000).eq.kmc)
 103      & write(ifmt,*)'kmc',kmc,kmcmx
 104
 105        call StoCon(1,k,n)
 106        call RemPom(k,n)
 107        call ProPo(k,n)
 108        call ProXY(k,n)
 109
 110        call StoCon(2,k,n)
 111
 112        if(idpr(n,k).eq.0.and.idx0.eq.0)then
 113          accept=accept+1.
 114        else
 115
 116          omb=omega(n,k)
 117          if(omb.le.0.d0)then
 118            reject=reject+1.
 119            call RemPom(k,n)
 120            call StoCon(-1,k,n)
 121          else
 122
 123            wab=wmatrix(k,n)
 124            if(ish.ge.8)write(ifch,*)'omb',omb,wab,k,n
 125            if(wab.le.0.d0)then
 126              write (ifmt,*)'wab,kmc',wab,omb,kmc,k,n,xpr(n,k),ypr(n,k)
 127      &  ,xppr(n,k),xmpr(n,k),xpp(ip),xmt(it),ip,it,idpr(n,k)
 128              write(ifmt,'(a,i12,d25.15)')'ems,seedf',nrevt+1,seedc
 129              iret=1
 130              goto 1000
 131            endif
 132            call RemPom(k,n)
 133            call StoCon(-1,k,n)
 134            oma=omega(n,k)
 135            wba=wmatrix(k,n)
 136            if(oma.ge.0.d0.and.oma.le.eps*omb*wba/wab)then
 137              accept=accept+1.
 138              call RemPom(k,n)
 139              call StoCon(-2,k,n)
 140              omlog=omlog+dlog(omb)
 141              goto 500
 142            elseif(oma.le.1.d-300.or.oma.ne.oma.or.omb.ne.omb)then
 143              write (ifmt,*)'oma,kmc',oma,omb,kmc,k,n,xpr(n,k),ypr(n,k)
 144      &  ,xppr(n,k),xmpr(n,k),idpr(n,k),npr(1,k),xpp(ip),xmt(it),ip,it
 145              write(ifmt,'(a,i12,d25.15)')'ems,seedf',nrevt+1,seedc
 146              iret=1
 147              goto 1000
 148            endif
 149
 150            z=sngl(omb/oma*wba/wab)
 151            if(ish.ge.8)write(ifch,*)'z,oma',z,oma,wba,k,n
 152            if(rangen().gt.z)then
 153              reject=reject+1.
 154            else
 155              accept=accept+1.
 156              call RemPom(k,n)
 157              call StoCon(-2,k,n)
 158              omlog=omlog-dlog(oma)+dlog(omb)
 159            endif
 160
 161  500       continue
 162
 163          endif
 164
 165          endif
 166
 167        if(nemsi.le.4)then
 168          kplot=int(float(kmc)/float(kmcmx)*100.)
 169          if(iemsi1.eq.1)call xEmsI1(1,kplot,omlog)
 170          if(iemsi2.eq.1)call xEmsI2(1,kplot)
 171        endif
 172
 173       enddo  !-----> end Metropolis
 174
 175
 176            elseif(iokoll.eq.1)then
 177
 178              ievt0=0
 179              n=1
 180
 181              do k=1,koll
 182
 183        call ProPo(k,n)
 184        call ProXY(k,n)
 185
 186              enddo
 187
 188            else
 189
 190         ievt0=1
 191
 192            endif
 193
 194
 195 c --- Plot Pomeron b-distributions ---
 196
 197       if(ish.ge.6)call XPrint('After Markov :&')
 198
 199            if(ntry2.eq.0)then
 200
 201       if(iemsb.eq.1)then ! plot
 202        do k=1,koll
 203         call xEmsB(1,1,k)
 204         if(nprt(k).gt.0)call xEmsB(1,2,k)
 205        enddo
 206       endif
 207
 208       if(iemsbg.eq.1.and.ievt0.eq.0)then ! plot
 209         call xEmsBg(3,0,0)
 210         do k=1,koll
 211           call xEmsBg(1,0,k)
 212           if(nprt(k).gt.0)then
 213             call xEmsBg(1,-1,k)
 214             do n=1,nprmx(k)
 215               if(idpr(n,k).ne.0)call xEmsBg(1,idpr(n,k),k)
 216             enddo
 217           endif
 218         enddo
 219       endif
 220
 221 c --- Plot distr of pomeron number ---
 222
 223
 224       if(iemspm.eq.1.and.ievt0.eq.0)then
 225        do k=1,koll
 226            call xEmsPm(1,k,nprt(k))
 227        enddo
 228       endif
 229
 230            endif
 231
 232 c -- Split Enhanced Pomerons and fix their nature ---
 233
 234       do k=1,koll
 235         do n=1,nprmx(k)
 236           if(idfpr(n,k).eq.0)call ProPoTy(k,n)
 237         enddo
 238       enddo
 239
 240
 241 c --- Count real interactions ---
 242
 243       ncol=0
 244       do k=1,koll
 245        if(nprt(k).gt.0)then
 246         ncol=ncol+1
 247         itpr(k)=1
 248         ip=iproj(k)
 249         it=itarg(k)
 250         kolp(ip)=kolp(ip)+nprt(k)        !number of cut Pomerons
 251         kolt(it)=kolt(it)+nprt(k)        !on remnants
 252 c        kolp(ip)=kolp(ip)+1
 253 c        kolt(it)=kolt(it)+1
 254 c       else
 255 c        itpr(k)=0
 256        endif
 257       enddo
 258       if(ish.ge.5)write(ifch,*)'ncol:',ncol
 259
 260
 261 c --- Calculate Z (written to zzremn)
 262
 263
 264       do ip=1,maproj
 265        call CalcZZ(1,ip)
 266       enddo
 267       do it=1,matarg
 268        call CalcZZ(-1,it)
 269       enddo
 270
 271
 272 c ---  recalculate Zptn
 273
 274
 275       if(irzptn.eq.1)call recalcZPtn
 276
 277
 278 c --- fix all variables
 279
 280
 281       if(ish.ge.4)write(ifch,*)'fix all variables'
 282
 283       do k=1,koll
 284         if(itpr(k).ge.2)call ProDiSc(k)
 285       enddo
 286
 287       do ip=1,maproj
 288        if(lproj(ip).ne.0)call ProReEx( 1,ip)
 289       enddo
 290       do it=1,matarg
 291        if(ltarg(it).ne.0)call ProReEx(-1,it)
 292       enddo
 293
 294
 295       if(isigma.eq.1)then
 296       if(koll.eq.1)then
 297         if(itpr(1).ne.0)then
 298           anintine=anintine+1.
 299           if(itpr(1).eq.2)then
 300             anintdiff=anintdiff+1.
 301             if((iep(1).eq.0.and.iet(1).eq.2).or.
 302      &           (iet(1).eq.0.and.iep(1).eq.2))anintsdif=anintsdif+1.
 303           endif
 304         endif
 305       else
 306         aidif=0.
 307         aiine=0.
 308         do k=1,koll
 309           if(aidif.ge.0..and.itpr(k).eq.2)then
 310             aidif=aidif+iep(k)+iet(k)
 311           elseif(itpr(k).eq.1)then
 312             aiine=aiine+1.
 313             aidif=-0.5
 314           endif
 315         enddo
 316         if(aidif.gt.0.)anintdiff=anintdiff+1.
 317         if(aidif.eq.2.)anintsdif=anintsdif+1.
 318         if(aiine+aidif.gt.0.)anintine=anintine+1.
 319       endif
 320       endif
 321
 322       if(ish.ge.6)call XPrint('After fixing:&')
 323
 324
 325 c --- Plot MC pomeron number ---
 326
 327       if(nemsi.le.4.and.ntry2.eq.0.and.irea.ge.0)then
 328        if(iemsi1.eq.1)call xEmsI1(1,100,omlog)
 329        if(iemsi2.eq.1)call xEmsI2(1,100)
 330        if(iemsi1.eq.1.and.ncol.gt.0)call xEmsI1(2,0,omlog)
 331        if(iemsi2.eq.1.and.ncol.gt.0)call xEmsI2(2,0)
 332        if((iemsi1.eq.1.or.iemsi2.eq.1).and.ncol.eq.0)nemsi=nemsi-1
 333       endif
 334
 335       if(ntry2.eq.0)then
 336         if(iemsb.eq.1)then      ! plot
 337           do k=1,koll
 338             if(itpr(k).eq.0)call xEmsB(1,3,k)
 339             if(itpr(k).eq.1)call xEmsB(1,4,k)
 340             if(itpr(k).eq.2)call xEmsB(1,5,k)
 341             if(itpr(k).ne.0)call xEmsB(1,6,k)
 342           enddo
 343         endif
 344       endif
 345
 346
 347
 348       if(ncol.eq.0)goto 998
 349
 350 c --- Treat Pomerons ---------------------------------------
 351
 352
 353 c --- Check minimum mass ---
 354
 355       do k=1,koll
 356       do n=1,nprmx(k)
 357         if(xpr(n,k).lt.cumpom**2/engy**2)then
 358           nnb=nbkpr(n,k)
 359           nnv=nvpr(n,k)
 360           if(nnv.ne.0)then
 361             nbkpr(nnv,k)=0                  !if bckp Pomeron
 362           endif
 363           if(nnb.ne.0)then
 364             call VirPom(k,nnb,1)            !if hard backup exist
 365             nbkpr(n,k)=0                    !remove it
 366           endif
 367           call VirPom(k,n,2)
 368         endif
 369       enddo
 370       enddo
 371
 372 c --- Set String End Type and Pt
 373
 374       do k=1,koll
 375         ip=iproj(k)
 376         it=itarg(k)
 377         do n=1,nprmx(k)
 378
 379           if(idpr(n,k).gt.0)then
 380
 381           ntry=0
 382           vpom=.false.
 383           do i=1,2
 384             icp(i)=icproj(i,ip)
 385             ict(i)=ictarg(i,it)
 386           enddo
 387  100      ntry=ntry+1
 388           iret=0
 389           if(ntry.ge.200)vpom=.true.
 390           if(ntry.gt.1)then
 391        if(ish.ge.4)write(ifch,*)'Try again setting string ends for k,n'
 392      &                               ,k,n,ntry
 393             do i=1,2
 394               icproj(i,ip)=icp(i)
 395               ictarg(i,it)=ict(i)
 396             enddo
 397             call RmPt(k,n)
 398           endif
 399
 400         call ProSeTy(k,n)
 401         call ProSePt(k,n)
 402 c      enddo
 403 c      enddo
 404
 405 c --- Check Pomeron mass
 406
 407 c      do k=1,koll
 408 c      do n=1,nprmx(k)
 409        if(idpr(n,k).ne.0.and.ivpr(n,k).ne.0)then
 410         px=xxp1pr(n,k)+xxp2pr(n,k)+xxm1pr(n,k)+xxm2pr(n,k)
 411         py=xyp1pr(n,k)+xyp2pr(n,k)+xym1pr(n,k)+xym2pr(n,k)
 412         pomass=xpr(n,k)*plc*plc-px*px-py*py
 413         if(pomass.le.0.d0)then
 414           nnv=nvpr(n,k)
 415           nnb=nbkpr(n,k)
 416           idfpom=iabs(idfpr(n,k))
 417           if(vpom)then
 418             call VirPom(k,n,3)  !call RmPt(k,n)
 419             if(nnv.ne.0)then    !bckp Pomeron
 420               nbkpr(nnv,k)=0
 421             endif
 422             if(nnb.ne.0)then    !big Pomeron with bckp one
 423               ivpr(nnb,k)=1
 424               nvpr(nnb,k)=0
 425               idfpr(nnb,k)=idfpom
 426               npr(1,k)=npr(1,k)+1
 427               npr(3,k)=npr(3,k)-1
 428             endif
 429           else
 430             goto 100
 431           endif
 432         endif
 433        endif
 434 c      enddo
 435 c      enddo
 436
 437 c --- Define String ends for "backup" Pomerons ---
 438
 439 c      do k=1,koll
 440 c      do n=1,nprmx(k)
 441         if(nvpr(n,k).ne.0)call ProSeX(k,n,iret)
 442         if(iret.eq.1)then
 443           if(vpom)then
 444             nn=nvpr(n,k)
 445             call VirPom(k,n,7)
 446             nbkpr(nn,k)=0
 447           else
 448             goto 100
 449           endif
 450         endif
 451         iret=0
 452         iret2=0
 453 c      enddo
 454 c      enddo
 455
 456 c --- Define String ends for "normal" Pomerons ---
 457
 458 c      do k=1,koll
 459 c      do n=1,nprmx(k)
 460         if(nvpr(n,k).eq.0)call ProSeX(k,n,iret)
 461         if(iret.eq.1)then
 462           if(vpom)then
 463             call VirPom(k,n,12)
 464           else
 465             goto 100
 466           endif
 467         endif
 468         iret=0
 469         iret2=0
 470
 471       endif
 472
 473       enddo
 474       enddo
 475
 476
 477 c --- Write ---
 478
 479  998  call emszz
 480       if(ncol.eq.0)goto 1000
 481
 482       do k=1,koll
 483        if(itpr(k).eq.1)call emswrpom(k,iproj(k),maproj+itarg(k))
 484       enddo
 485
 486
 487 c --- Treat hard Pomeron
 488
 489       do k=1,koll
 490         do n=1,nprmx(k)
 491           if(idpr(n,k).eq.3)then
 492             if(ishpom.eq.1)then
 493               call psahot(k,n,iret)
 494               if(iret.eq.1)then
 495                 if(nbkpr(n,k).ne.0)then
 496                   nn=nbkpr(n,k)
 497                   call ProSeX(k,nn,iret2)
 498                   if(iret2.eq.1)then
 499                     call VirPom(k,nn,7)
 500                     istptl(nppr(nn,k))=32
 501                     nbkpr(n,k)=0
 502                   else
 503                     ivpr(nn,k)=1
 504                     nvpr(nn,k)=0
 505                     idfpr(nn,k)=idfpr(n,k)
 506                     npr(1,k)=npr(1,k)+1
 507                     npr(3,k)=npr(3,k)-1
 508                     ansff=ansff+1 !counters
 509                     anshf=anshf-1
 510                   endif
 511                 endif
 512                 call VirPom(k,n,16)
 513                 istptl(nppr(n,k))=32
 514               elseif(nbkpr(n,k).ne.0)then
 515                 nn=nbkpr(n,k)
 516                 call VirPom(k,nn,17)
 517                 istptl(nppr(nn,k))=32
 518                 nbkpr(n,k)=0
 519               endif
 520               iret=0
 521             else
 522               istptl(nppr(n,k))=32
 523               if(nbkpr(n,k).ne.0)then
 524                 nn=nbkpr(n,k)
 525                 istptl(nppr(nn,k))=32
 526               endif
 527             endif
 528           endif
 529         enddo
 530       enddo
 531
 532
 533 c --- Treat "normal" soft Pomerons ---
 534
 535       do k=1,koll
 536         do n=1,nprmx(k)
 537           if(nvpr(n,k).eq.0)then
 538             if(isopom.eq.1)then
 539               call ProSeF(k,n,iret)
 540               if(iret.eq.1)then
 541                 call VirPom(k,n,18)
 542                 istptl(nppr(n,k))=32
 543               endif
 544               iret=0
 545             else
 546               istptl(nppr(n,k))=32
 547             endif
 548           endif
 549         enddo
 550       enddo
 551
 552
 553 c --- Treat Remnants -----------------------------------------
 554
 555
 556 c --- Diffractive Pt
 557
 558       do k=1,koll
 559         call ProDiPt(k)
 560       enddo
 561
 562       do ip=1,maproj
 563 c Here and later "kolp(ip).ne.0" replaced by "iep(ip).ne.-1" to count
 564 c projectile and target nucleons which are counted in paires but are not used
 565 c in collision (no diffractive or inelastic interaction) as slow particles
 566 c at the end. Then we can use them in ProRem to give mass to all other nucleons
 567 c and avoid energy conservation violation that utrescl can not treat
 568 c (and it gives a reasonnable number of grey particles even if distributions
 569 c are not really reproduced).
 570 c       if(kolp(ip).ne.0)call ProCop(ip,ip)
 571        if(iep(ip).ne.-1)call ProCop(ip,ip)
 572       enddo
 573       do it=1,matarg
 574        if(iet(it).ne.-1)call ProCot(it,maproj+it)
 575 c       if(kolt(it).ne.0)call ProCot(it,maproj+it)
 576       enddo
 577
 578
 579 c ---- Remnant Masses (ProReM)
 580
 581
 582       if(ish.ge.6)call XPrint('Before  ProReM:&')
 583       ntry=0
 584       call StoRe(1)             !Store Remnant configuration
 585  123  ntry=ntry+1
 586       nshuffi=maproj+matarg
 587       if(nshuffi.gt.500)
 588      &call utstop('ems: increase dimension for ishuff&')
 589       do ip=1,maproj
 590         ishuff(ip)=ip           !positive for projectile
 591       enddo
 592       do it=1,matarg
 593         ishuff(maproj+it)=-it   !negative for target
 594       enddo
 595
 596       nshuff=maproj+matarg
 597
 598       do while(nshuff.gt.0)
 599
 600         if(nshuff.gt.1.and.koll.eq.1.and.iep(1).ne.iet(1))then
 601 c to set the mass of diffractive or not excited remnant first
 602 c (to avoid unlimited mass of inelastic remants)
 603           if(iep(1).ne.1.and.iep(1).lt.iet(1))then
 604             indx=1
 605           else
 606             indx=2
 607           endif
 608         else
 609           indx=1+int(rangen()*float(nshuff))
 610         endif
 611         if(ishuff(indx).gt.0)then
 612           ip=ishuff(indx)
 613 c          if(kolp(ip).ne.0)call ProReM( 1,ip,iret)
 614           if(iep(ip).ne.-1)call ProReM( 1,ip,iret)
 615         else
 616           it=-ishuff(indx)
 617 c          if(kolt(it).ne.0)call ProReM(-1,it,iret)
 618           if(iet(it).ne.-1)call ProReM(-1,it,iret)
 619         endif
 620
 621         if(iret.eq.1)then
 622           !----------------------------------------
 623           !If there is a problem, try again shuffle (30 times),
 624           !if it doesn't work, for pp, try 10 times with the same type
 625           !of event and if doesn't work redo event;
 626           !for pA redo event ; and for AB (with A or B >10)
 627           !continue with some ghosts ...
 628           !----------------------------------------
 629           if(ntry.lt.30)then
 630             if(ish.ge.3)write(ifch,*)'shuffle, try again',ntry
 631             call StoRe(-1)         !Restore Remnant configuration
 632             iret=0
 633             goto 123
 634           elseif(maproj+matarg.eq.2.and.ntry2.lt.10)then
 635             ntry2=ntry2+1
 636             if(ish.ge.2)write(ifch,*)'ProRem, try again ! ntry=',ntry2
 637             if(ish.ge.2)write(ifmt,*)'ProRem, try again ! ntry=',ntry2
 638             goto 0001
 639           elseif(maproj.le.10.or.matarg.le.10)then
 640             if(ish.ge.2)write(ifch,*)'ProRem, redo event ! ntry=',ntry
 641             if(ish.ge.2)write(ifmt,*)'ProRem, redo event ! ntry=',ntry
 642             goto 1000
 643           else
 644             iret=10
 645           endif
 646         endif
 647
 648         ishuff(indx)=ishuff(nshuff)
 649         nshuff=nshuff-1
 650
 651       enddo
 652
 653       iret=0
 654       if(ish.ge.6)call XPrint('After ProReM:&')
 655
 656
 657 c --- Write Z into zpaptl for connected strings
 658
 659
 660       if(isplit.eq.1)then
 661         do ip=1,maproj
 662           if(kolp(ip).ne.0)call WriteZZ(1,ip)
 663         enddo
 664         do it=1,matarg
 665           if(kolt(it).ne.0)call WriteZZ(-1,it)
 666         enddo
 667       endif
 668
 669
 670 c --- Write Remnants
 671
 672
 673       do ip=1,maproj
 674 c       if(kolp(ip).ne.0)call emswrp(ip,ip)
 675        if(iep(ip).ne.-1)call emswrp(ip,ip)
 676       enddo
 677       do it=1,matarg
 678 c       if(kolt(it).ne.0)call emswrt(it,maproj+it)
 679        if(iet(it).ne.-1)call emswrt(it,maproj+it)
 680       enddo
 681
 682
 683 c --- Remnant Flavors (ProReF)
 684
 685
 686       do ip=1,maproj
 687         call ProReF(1,ip)
 688       enddo
 689       do it=1,matarg
 690         call ProReF(-1,it)
 691       enddo
 692
 693 999   continue
 694
 695 c     plot
 696 c     ----
 697
 698        if(iemspx.eq.1)then
 699        do ko=1,koll
 700         if(nprt(ko).gt.0)then
 701          do np=1,nprmx(ko)
 702           if(idpr(np,ko).gt.0)then
 703            call xEmsPx(1,sngl(xpr(np,ko)),sngl(ypr(np,ko)),nprt(ko))
 704           endif
 705          enddo
 706         endif
 707        enddo
 708       endif
 709
 710       if(iemspbx.eq.1)then
 711        do k=1,koll
 712         if(nprt(k).gt.0)then
 713          do n=1,nprmx(k)
 714           if(idpr(n,k).eq.3)then
 715             je1=min(1,nemispr(1,n,k))
 716             je2=min(1,nemispr(2,n,k))
 717             jex=1+je1+2*je2
 718             call xEmsP2(1,1+idhpr(n,k),jex
 719      *            ,sngl(xppr(n,k))
 720      *            ,sngl(xmpr(n,k))
 721      *            ,sngl(xpprbor(n,k)),sngl(xmprbor(n,k))
 722      *            ,ptprboo(1,n,k),ptprboo(2,n,k)  )
 723           endif
 724          enddo
 725         endif
 726        enddo
 727       endif
 728
 729
 730       if(iemsse.eq.1)then
 731        do ko=1,koll
 732         if(nprt(ko).gt.0)then
 733          do np=1,nprmx(ko)
 734           if(idpr(np,ko).gt.0)then
 735            ptp1=sngl(xxp1pr(np,ko)**2+xyp1pr(np,ko)**2)
 736            ptp2=sngl(xxp2pr(np,ko)**2+xyp2pr(np,ko)**2)
 737            ptm1=sngl(xxm1pr(np,ko)**2+xym1pr(np,ko)**2)
 738            ptm2=sngl(xxm2pr(np,ko)**2+xym2pr(np,ko)**2)
 739            call xEmsSe(1,sngl(xp1pr(np,ko)),ptp1,1,1)
 740            call xEmsSe(1,sngl(xp2pr(np,ko)),ptp2,1,1)
 741            call xEmsSe(1,sngl(xm1pr(np,ko)),ptm1,-1,1)
 742            call xEmsSe(1,sngl(xm2pr(np,ko)),ptm2,-1,1)
 743            call xEmsSe(1,sngl(xp1pr(np,ko)),sngl(xm1pr(np,ko)),1,2)
 744            call xEmsSe(1,sngl(xm2pr(np,ko)),sngl(xp2pr(np,ko)),1,2)
 745           endif
 746          enddo
 747         endif
 748        enddo
 749       endif
 750
 751       if(iemsdr.eq.1)then
 752        do i=maproj+matarg+1,nptl
 753         if(istptl(iorptl(i)).eq.41)then
 754           xpdr=(pptl(4,i)+pptl(3,i))/sngl(plc)
 755           xmdr=(pptl(4,i)-pptl(3,i))/sngl(plc)
 756           if(ityptl(i).eq.41)call xEmsDr(1,xpdr,xmdr,1)
 757           if(ityptl(i).eq.51)call xEmsDr(1,xpdr,xmdr,2)
 758           if(ityptl(i).eq.42)call xEmsDr(1,xpdr,xmdr,3)
 759           if(ityptl(i).eq.52)call xEmsDr(1,xpdr,xmdr,4)
 760         endif
 761        enddo
 762       endif
 763
 764       if(iemsrx.eq.1)then
 765        do i=1,maproj
 766         if(kolp(i).gt.0)call xEmsRx(1,1,sngl(xpp(i)),sngl(xmp(i)))
 767        enddo
 768        do j=1,matarg
 769         if(kolt(j).gt.0)call xEmsRx(1,2,sngl(xmt(j)),sngl(xpt(j)))
 770        enddo
 771       endif
 772
 773
 774 c     exit
 775 c     ----
 776
 777  1000 continue
 778 c      write(*,*)'emsaa-iret',iret
 779       if(ish.ge.1.and.iret.ne.0)write(ifch,*)'iret not 0 (ems)=> redo'
 780       call utprix('emsaa ',ish,ishini,4)
 781       return
 782       end
 783
 784
 785 c----------------------------------------------------------------------
 786       subroutine StoCon(mode,k,n)
 787 c----------------------------------------------------------------------
 788 c store or restore configuration
 789 c   mode = 1 (store) or -1 (restore)
 790 c   k = collision index
 791 c   n = pomeron index
 792 c----------------------------------------------------------------------
 793
 794       include 'epos.inc'
 795       include 'epos.incems'
 796
 797       ip=iproj(k)
 798       it=itarg(k)
 799
 800       if(mode.eq.1)then
 801
 802        do i=0,3
 803         nprx0(i)=npr(i,k)
 804        enddo
 805        nprtx0=nprt(k)
 806        idx0=idpr(n,k)
 807        xxpr0=xpr(n,k)
 808        yx0=ypr(n,k)
 809        xxppr0=xppr(n,k)
 810        xxmpr0=xmpr(n,k)
 811        nppx0=npp(ip)
 812        nptx0=npt(it)
 813        xppx0=xpp(ip)
 814        xppstx0=xppmx(ip)
 815        xmpstx0=xppmn(ip)
 816        xmtx0=xmt(it)
 817        xptstx0=xmtmx(it)
 818        xmtstx0=xmtmn(it)
 819
 820       elseif(mode.eq.2)then
 821
 822        do i=0,3
 823         nprx(i)=npr(i,k)
 824        enddo
 825        nprtx=nprt(k)
 826        idx=idpr(n,k)
 827        xxpr=xpr(n,k)
 828        yx=ypr(n,k)
 829        xxppr=xppr(n,k)
 830        xxmpr=xmpr(n,k)
 831        nppx=npp(ip)
 832        nptx=npt(it)
 833        xppx=xpp(ip)
 834        xppstx=xppmx(ip)
 835        xmpstx=xppmn(ip)
 836        xmtx=xmt(it)
 837        xptstx=xmtmx(it)
 838        xmtstx=xmtmn(it)
 839
 840       elseif(mode.eq.-1)then
 841
 842        do i=0,3
 843         npr(i,k)=nprx0(i)
 844        enddo
 845        nprt(k)=nprtx0
 846        idpr(n,k)=idx0
 847        xpr(n,k)=xxpr0
 848        ypr(n,k)=yx0
 849        xppr(n,k)=xxppr0
 850        xmpr(n,k)=xxmpr0
 851        npp(ip)=nppx0
 852        npt(it)=nptx0
 853        xpp(ip)=xppx0
 854        xppmx(ip)=xppstx0
 855        xppmn(ip)=xmpstx0
 856        xmt(it)=xmtx0
 857        xmtmx(it)=xptstx0
 858        xmtmn(it)=xmtstx0
 859
 860       elseif(mode.eq.-2)then
 861
 862        do i=0,3
 863         npr(i,k)=nprx(i)
 864        enddo
 865        nprt(k)=nprtx
 866        idpr(n,k)=idx
 867        xpr(n,k)=xxpr
 868        ypr(n,k)=yx
 869        xppr(n,k)=xxppr
 870        xmpr(n,k)=xxmpr
 871        npp(ip)=nppx
 872        npt(it)=nptx
 873        xpp(ip)=xppx
 874        xppmx(ip)=xppstx
 875        xppmn(ip)=xmpstx
 876        xmt(it)=xmtx
 877        xmtmx(it)=xptstx
 878        xmtmn(it)=xmtstx
 879
 880       else
 881       call utstop('mode should integer from -2 to 2 (without 0)&')
 882       endif
 883       return
 884       end
 885
 886 c-------------------------------------------------------------------------
 887       subroutine RemPom(k,n)
 888 c-------------------------------------------------------------------------
 889 c remove pomeron
 890 c-------------------------------------------------------------------------
 891       include 'epos.incems'
 892       include 'epos.inc'
 893
 894       ip=iproj(k)
 895       it=itarg(k)
 896       npr(idpr(n,k),k)=npr(idpr(n,k),k)-1  !nr of pomerons
 897       nprt(k)=npr(1,k)+npr(3,k)
 898       if(idpr(n,k).gt.0)then
 899        npp(ip)=npp(ip)-1                     !nr of pomerons per proj
 900        npt(it)=npt(it)-1                     !nr of pomerons per targ
 901        idpr(n,k)=0
 902        xpp(ip)=xpp(ip)+xppr(n,k)
 903        xmt(it)=xmt(it)+xmpr(n,k)
 904        xpr(n,k)=0.d0
 905        ypr(n,k)=0.d0
 906        xppr(n,k)=0.d0
 907        xmpr(n,k)=0.d0
 908
 909
 910
 911       endif
 912
 913       end
 914
 915 c-------------------------------------------------------------------------
 916       subroutine ProPo(k,n)
 917 c-------------------------------------------------------------------------
 918 c propose pomeron type = idpr(n,k
 919 c-------------------------------------------------------------------------
 920       include 'epos.inc'
 921       include 'epos.incems'
 922       double precision wzero,wzerox
 923       common/cwzero/wzero,wzerox
 924
 925       ip=iproj(k)
 926       it=itarg(k)
 927
 928       idpr(n,k)=0
 929
 930       if(dble(rangen()).gt.wzero)then
 931         idpr(n,k)=1
 932
 933
 934 c nbr of pomerons per proj
 935        npp(ip)=npp(ip)+1
 936 c nbr of pomerons per targ
 937        npt(it)=npt(it)+1
 938
 939       endif
 940
 941       npr(idpr(n,k),k)=npr(idpr(n,k),k)+1 !nr of pomerons
 942       nprt(k)=npr(1,k)+npr(3,k)
 943
 944
 945       end
 946
 947
 948 c-------------------------------------------------------------------------
 949       subroutine ProXY(k,n)
 950 c-------------------------------------------------------------------------
 951 c propose pomeron x,y
 952 c-------------------------------------------------------------------------
 953
 954       include 'epos.inc'
 955       include 'epos.incems'
 956       include 'epos.incsem'
 957       double precision xp,xm,om1xprk,om1xmrk,anip,anit,eps
 958      &,xprem,xmrem
 959       parameter (eps=1.d-30)
 960
 961
 962       ip=iproj(k)
 963       it=itarg(k)
 964
 965
 966       xpr(n,k)=0.d0
 967       ypr(n,k)=0.d0
 968
 969
 970       if(idpr(n,k).ne.0)then
 971           xprem=xpp(ip)
 972           xmrem=xmt(it)
 973 c because of fom, it's not symetric any more if we choose always xp first
 974 c and then xm ... so choose it randomly.
 975           if(rangen().lt.0.5)then
 976             xp=om1xprk(k,xprem,xmrem,1)
 977             xm=om1xmrk(k,xp,xprem,xmrem,1)
 978           else
 979             xm=om1xprk(k,xmrem,xprem,-1)
 980             xp=om1xmrk(k,xm,xmrem,xprem,-1)
 981           endif
 982           xpr(n,k)=xp*xm
 983           ypr(n,k)=0.d0
 984           if(xm.gt.eps.and.xp.gt.eps)then
 985             ypr(n,k)=0.5D0*dlog(xp/xm)
 986             xppr(n,k)=xp
 987             xmpr(n,k)=xm
 988           else
 989             if(ish.ge.1)write(ifmt,*)'Warning in ProXY ',xp,xm
 990             npr(idpr(n,k),k)=npr(idpr(n,k),k)-1
 991             idpr(n,k)=0
 992             npr(idpr(n,k),k)=npr(idpr(n,k),k)+1
 993             xpr(n,k)=0.d0
 994             ypr(n,k)=0.d0
 995             xppr(n,k)=0.d0
 996             xmpr(n,k)=0.d0
 997             nprt(k)=npr(1,k)+npr(3,k)
 998             npp(ip)=npp(ip)-1   !nr of pomerons per proj
 999             npt(it)=npt(it)-1   !nr of pomerons per targ
1000           endif
1001
1002 c Update xp and xm of remnant, and change the limit to have big enought mass.
1003
1004         anip=dble(npp(ip))
1005         anit=dble(npt(it))
1006         xpp(ip)=xpp(ip)-xppr(n,k)
1007         xppmn(ip)=min(1.d0,anip*xpmn(ip)/xmpmx(ip))
1008         xmt(it)=xmt(it)-xmpr(n,k)
1009         xmtmn(it)=min(1.d0,anit*xtmn(it)/xptmx(it))
1010
1011       endif
1012
1013       end
1014
1015 c-------------------------------------------------------------------------
1016       double precision function wmatrix(k,n)
1017 c-------------------------------------------------------------------------
1018 c proposal matrix w(a->b), considering pomeron type, x, y
1019 c-------------------------------------------------------------------------
1020
1021       include 'epos.incems'
1022       include 'epos.incsem'
1023       double precision wzero,wzerox,Womegak,xprem,xmrem,om1intgck
1024       common/cwzero/wzero,wzerox
1025
1026
1027 c      ip=iproj(k)
1028 c      it=itarg(k)
1029
1030       if(idpr(n,k).eq.0)then
1031         wmatrix=wzero
1032       else
1033           xprem=1.d0!xpp(ip)+xppr(n,k)
1034           xmrem=1.d0!xmt(it)+xmpr(n,k)
1035           wmatrix=(1d0-wzero)/om1intgck(k,xprem,xmrem)
1036      *           *Womegak(xppr(n,k),xmpr(n,k),xprem,xmrem,k)
1037       endif
1038
1039
1040       end
1041
1042 c-------------------------------------------------------------------------
1043       double precision function omega(n,k)
1044 c-------------------------------------------------------------------------
1045 c calculates partial omega for spot (k,n)
1046 c-------------------------------------------------------------------------
1047
1048       include 'epos.inc'
1049       include 'epos.incems'
1050       include 'epos.incsem'
1051       common/cwzero/wzero,wzerox
1052       double precision wzero,wzerox,eps
1053       parameter(eps=1.d-15)
1054       double precision PhiExpoK,omGamk,xp,xm,fom
1055       double precision plc,s
1056       common/cems5/plc,s
1057       common/nucl3/phi,bimp
1058
1059       omega=0.d0
1060
1061       ip=iproj(k)
1062       it=itarg(k)
1063
1064       if(xpp(ip).lt.xppmn(ip)+eps.or.xpp(ip).gt.1.d0+eps)goto 1001
1065       if(xmt(it).lt.xmtmn(it)+eps.or.xmt(it).gt.1.d0+eps)goto 1001
1066
1067       omega=xpp(ip)**dble(alplea(iclpro))
1068      &     *xmt(it)**dble(alplea(icltar))
1069
1070 c      ztg=0
1071 c      zpj=0
1072 c      nctg=0
1073 c      ncpj=0
1074 c      zsame=nprt(k)
1075 c      if(idpr(n,k).gt.0)then
1076 c        if(nprt(k).le.0)stop'omega: nprt(k) should be positive !!!!    '
1077 c        zsame=zsame-1
1078 c      endif
1079 c      nlpop=nint(zsame)
1080 c      nlpot=nint(zsame)
1081 c      bglaub2=sigine/10./pi        !10= fm^2 -> mb
1082 c      bglaub=sqrt(bglaub2)
1083 c      b2x=epscrp*epscrp*bglaub2
1084 c      b2=bk(k)**2
1085 c      ztgx=epscrw*exp(-b2/2./b2x)*fscra(engy/egyscr)
1086 c      zpjx=epscrw*exp(-b2/2./b2x)*fscra(engy/egyscr)
1087 c
1088 c      if(koll.gt.1)then
1089 c        do li=1,lproj(ip)
1090 c          kk=kproj(ip,li)
1091 c          if(kk.ne.k)then
1092 c            b2=bk(kk)**2
1093 c            if(b2.le.bglaub2)nctg=nctg+1
1094 c            ztg=ztg+epscrw*exp(-b2/2./b2x)*fscro(engy/egyscr)
1095 c            nlpop=nlpop+nprt(kk)
1096 c          endif
1097 c        enddo
1098 c        do li=1,ltarg(it)
1099 c          kk=ktarg(it,li)
1100 c          if(kk.ne.k)then
1101 c            b2=bk(kk)**2
1102 c            if(b2.le.bglaub2)ncpj=ncpj+1
1103 c            zpj=zpj+epscrw*exp(-b2/2./b2x)*fscro(engy/egyscr)
1104 c            nlpot=nlpot+nprt(kk)
1105 c          endif
1106 c        enddo
1107 c      endif
1108       !  zpjx+zpj is equal to zparpro(k)
1109       !  ztgx+ztg is equal to zpartar(k)
1110       zprj=zparpro(k)  !zsame+zpj
1111       ztgt=zpartar(k)  !zsame+ztg
1112       if(idpr(n,k).eq.0)then
1113         omega=omega*wzerox
1114       else
1115         xp=xppr(n,k)
1116         xm=xmpr(n,k)
1117 c        !-------------------------------------------------------------------------
1118 c        ! fom : part of Phi regularization; Phi -> Phi^(n) (n = number of Poms)
1119 c        ! Phi^(0) relevant for Xsect unchanged, apart of (maybe) normalization (Z)
1120 c        !-------------------------------------------------------------------------
1121         omega=omega*omGamk(k,xp,xm)*gammaV(k)*fom(zprj,xm,bk(k))
1122      &                                       *fom(ztgt,xp,bk(k))
1123       endif
1124
1125       omega=omega*PhiExpoK(k,xpp(ip),xmt(it))
1126
1127
1128       if(omega.le.0.d0)goto 1001
1129
1130       if(koll.gt.1)then
1131         do li=1,lproj(ip)
1132           kk=kproj(ip,li)
1133           if(itarg(kk).ne.it)then
1134             ipl=iproj(kk)
1135             itl=itarg(kk)
1136             omega=omega*PhiExpoK(kk,xpp(ipl),xmt(itl))
1137             if(omega.le.0.d0)goto 1001
1138           endif
1139         enddo
1140         do li=1,ltarg(it)
1141           kk=ktarg(it,li)
1142           if(iproj(kk).ne.ip)then
1143             ipl=iproj(kk)
1144             itl=itarg(kk)
1145             omega=omega*PhiExpoK(kk,xpp(ipl),xmt(itl))
1146             if(omega.le.0.d0)goto 1001
1147           endif
1148         enddo
1149       endif
1150
1151       if(omega.lt.1.d-100)then
1152         if(ish.ge.6)write(*,*)'omega-exit',omega
1153         omega=0.d0
1154       elseif(omega.gt.1.d100)then
1155         if(ish.ge.6)write(*,*)'omega-exit',omega
1156         omega=0.d0
1157       endif
1158
1159       return
1160
1161  1001 continue
1162
1163       omega=0.d0
1164       return
1165
1166       end
1167
1168 c-------------------------------------------------------------------------
1169       double precision function fom(z,x,b)
1170 c-------------------------------------------------------------------------
1171       include 'epos.inc'
1172       double precision x,u,w,z0
1173       !----------------------------------------------------------------
1174       ! part of Phi regularization; Phi -> Phi^(n) (n = number of Poms)
1175       ! Phi^(0) relevant for Xsect unchanged
1176       !----------------------------------------------------------------
1177       fom=1d0
1178       if(z.gt.0..and.alpfomi.gt.0.)then
1179        z0=dble(alpfomi)
1180        u=dble(z**gamfom)
1181 c       u=z0*dble(z/z0)**2.
1182        w=u/z0*exp(-dble(b*b/delD(1,iclpro,icltar)))
1183 c       w=10.d0*u
1184        !---------------------------------------------------
1185        !e=exp(-0.05*u)  !analytic function with e(0)=1
1186        !fom=((1-u)+(u+w)*sqrt(x**2+((u-1+e)/(u+w))**2))
1187        !     fom(z=0)=1  fom(x=0)=e  fom(x=1)~w
1188        !---------------------------------------------------
1189        fom=1.d0+w*x**betfom
1190        !---------------------------------------------------
1191       endif
1192       end
1193
1194 c-------------------------------------------------------------------------
1195       subroutine ProPoTy(k,n)
1196 c-------------------------------------------------------------------------
1197 c propose pomeron type
1198 c-------------------------------------------------------------------------
1199
1200       include 'epos.inc'
1201       include 'epos.incems'
1202       include 'epos.incsem'
1203       double precision ww,w0,w1,w2,w3,w4,w5,w(0:7),aks,eps
1204      *,xh,yp!,xp,xm
1205       parameter(eps=1.d-10)
1206       logical cont
1207       dimension nnn(3),kkk(3)
1208
1209       if(idpr(n,k).eq.0)return
1210       if(ish.ge.4)write(ifch,*)'ProPoTy:k,n,idpr,x',k,n,idpr(n,k)
1211      *                                              ,xpr(n,k)
1212       if(idpr(n,k).ne.1)call utstop('ProPoTy: should not happen&')
1213
1214       cont=.true.
1215       do i=1,3
1216         nnn(i)=0
1217         kkk(i)=0
1218       enddo
1219
1220       idfpr(n,k)=1
1221       ip=iproj(k)
1222       it=itarg(k)
1223       xh=xpr(n,k)
1224       yp=ypr(n,k)
1225 c      xp=xppr(n,k)
1226 c      xm=xmpr(n,k)
1227       nnn(3)=n
1228       kkk(3)=k
1229
1230       if(iep(ip).ne.-1)iep(ip)=-1
1231       if(iet(it).ne.-1)iet(it)=-1
1232
1233
1234       idpr(n,k)=1
1235
1236         w0=0.d0
1237         w1=0.d0
1238         w2=0.d0
1239         w3=0.d0
1240         w4=0.d0
1241         w5=0.d0
1242
1243         call WomTy(w,xh,yp,k)
1244
1245
1246         if(w(0).gt.0.d0)w0=w(0)
1247         if(w(1).gt.0.d0)w1=w(1)
1248         if(w(2).gt.0.d0)w2=w(2)
1249         if(w(3).gt.0.d0)w3=w(3)
1250         if(w(4).gt.0.d0)w4=w(4)
1251         if(w(5).gt.0.d0)w5=w(5)
1252
1253         ww=w0+w1+w2+w3+w4+w5
1254         if(ish.ge.4)write(ifch,*)'ProPoTy:ww,ww_i'
1255      *       ,ww,w0/ww*100.d0,w1/ww*100.d0,w2/ww*100.d0
1256      *       ,w3/ww*100.d0,w4/ww*100.d0,w5/ww*100.d0
1257
1258
1259         aks=dble(rangen())*ww
1260
1261         if(ww.lt.eps.or.aks.le.w0)then            !soft pomeron
1262
1263           if(ish.ge.8)write(ifch,*)'ProPoTy:idpr',idpr(n,k)
1264
1265         elseif(aks.ge.ww-w5)then !diffractive interaction
1266           itpr(k)=itpr(k)+2
1267           if(ish.ge.8)write(ifch,*)'ProPoTy:itpr',itpr(k)
1268           call RemPom(k,n)
1269           npr(0,k)=npr(0,k)+1 !nr of empty cells
1270
1271         else
1272
1273           idpr(n,k)=3
1274           if(ish.ge.8)write(ifch,*)'ProPoTy:idpr',idpr(n,k)
1275           npr(3,k)=npr(3,k)+1
1276           npr(1,k)=npr(1,k)-1
1277           bhpr(n,k)=bk(k)
1278
1279           aks=aks-w0
1280           if(aks.le.w1)then                             !gg-pomeron
1281             idhpr(n,k)=0
1282           elseif(aks.le.w1+w2)then                      !qg-pomeron
1283             idhpr(n,k)=1
1284           elseif(aks.le.w1+w2+w3)then                   !gq-pomeron
1285             idhpr(n,k)=2
1286           elseif(aks.le.w1+w2+w3+w4)then                !qq-pomeron
1287             idhpr(n,k)=3
1288           else
1289             call utstop('ems-unknown pomeron&')
1290           endif
1291
1292         endif
1293
1294         if(xpr(n,k).gt.0.d0)then
1295           antot=antot+1
1296           antotf=antotf+1
1297           if(idpr(n,k).eq.1)then
1298             ansf=ansf+1
1299             ansff=ansff+1
1300           endif
1301           if(idpr(n,k).eq.3)then
1302             ansh=ansh+1
1303             anshf=anshf+1
1304           endif
1305         endif
1306
1307       do i=3,1,-1
1308
1309         if(nnn(i).ne.0.and.kkk(i).ne.0.and.cont)then
1310
1311           if(idpr(nnn(i),kkk(i)).eq.3)then
1312
1313                        !Backup soft Pomeron if sh not possible later
1314
1315             kb=kkk(i)
1316             nb=nnn(i)
1317             ip=iproj(kb)
1318             it=itarg(kb)
1319             do nn=1,nprmx(kb)
1320               if(idpr(nn,kb).eq.0)then !empty spot
1321                 nbkpr(nb,kb)=nn
1322                 nvpr(nn,kb)=nb
1323                 idpr(nn,kb)=1
1324                 ivpr(nn,kb)=2
1325                 xpr(nn,kb)=xpr(nb,kb)
1326                 ypr(nn,kb)=ypr(nb,kb)
1327                 xppr(nn,kb)=xppr(nb,kb)
1328                 xmpr(nn,kb)=xmpr(nb,kb)
1329                 idfpr(nn,kb)=-idfpr(nb,kb)
1330                 bhpr(nn,kb)=bhpr(nb,kb)
1331                 idp1pr(nn,kb)=0
1332                 idp2pr(nn,kb)=0
1333                 idm1pr(nn,kb)=0
1334                 idm2pr(nn,kb)=0
1335                 xm1pr(nn,kb)=0.d0
1336                 xp1pr(nn,kb)=0.d0
1337                 xm2pr(nn,kb)=0.d0
1338                 xp2pr(nn,kb)=0.d0
1339                 xxm1pr(nn,kb)=0.d0
1340                 xym1pr(nn,kb)=0.d0
1341                 xxp1pr(nn,kb)=0.d0
1342                 xyp1pr(nn,kb)=0.d0
1343                 xxm2pr(nn,kb)=0.d0
1344                 xym2pr(nn,kb)=0.d0
1345                 xxp2pr(nn,kb)=0.d0
1346                 xyp2pr(nn,kb)=0.d0
1347                 goto 10
1348               endif
1349             enddo
1350       if(ish.ge.2)write(ifmt,*)'no empty lattice site, backup lost'
1351
1352  10         continue
1353           endif
1354         endif
1355       enddo
1356
1357       return
1358       end
1359
1360 c-------------------------------------------------------------------------
1361       subroutine ProDiSc(k)
1362 c-------------------------------------------------------------------------
1363 c propose diffractive scattering
1364 c-------------------------------------------------------------------------
1365
1366       include 'epos.inc'
1367       include 'epos.incsem'
1368       include 'epos.incems'
1369       common/col3/ncol,kolpt
1370
1371       ncol=ncol+1
1372       ip=iproj(k)
1373       it=itarg(k)
1374       kolp(ip)=kolp(ip)+itpr(k)/2   !number of cut on remnants
1375       kolt(it)=kolt(it)+itpr(k)/2
1376       itpr(k)=2
1377
1378
1379       end
1380
1381 c-------------------------------------------------------------------------
1382       subroutine ProReEx(ir,ii)
1383 c-------------------------------------------------------------------------
1384 c propose remnant excitation
1385 c for proj (iep) if ir=1 or target (iet) if ir=-1:
1386 c 0 = no,  1 = inel excitation,  2 = diffr excitation
1387 c-------------------------------------------------------------------------
1388
1389       include 'epos.inc'
1390       include 'epos.incsem'
1391       include 'epos.incems'
1392       common/cncl3/iactpr(mamx),iacttg(mamx)
1393
1394
1395       if(ir.eq.1)then                   !proj
1396
1397         ip=ii
1398         if(iactpr(ip).eq.0)stop'ProReEx: should not happen (1)'
1399         mine=0
1400         mdif=0
1401         do l=1,lproj(ip)
1402           kp=kproj(ip,l)
1403           if(itpr(kp).eq.1)mine=1
1404           if(itpr(kp).eq.2)mdif=1
1405         enddo
1406         iep(ip)=0
1407         r=rangen()
1408         if(mine.eq.1)then   !inelastic
1409 c          if(r.lt.1.-(1.-rexndi(iclpro))**kolp(ip))iep(ip)=1
1410           if(r.lt.1.-(1.-rexndi(iclpro)))iep(ip)=1
1411         elseif(mdif.eq.1)then        !diffr
1412           if(r.lt.1.-(1.-rexdif(iclpro))**kolp(ip))iep(ip)=2
1413 c          if(r.lt.1.-(1.-rexdif(iclpro)))iep(ip)=2
1414         endif
1415       elseif(ir.eq.-1)then                !targ
1416
1417         it=ii
1418         if(iacttg(it).eq.0)stop'ProReEx: should not happen (2)'
1419         mine=0
1420         mdif=0
1421         do l=1,ltarg(it)
1422           kt=ktarg(it,l)
1423           if(itpr(kt).eq.1)mine=1
1424           if(itpr(kt).eq.2)mdif=1
1425         enddo
1426         iet(it)=0
1427         r=rangen()
1428         if(mine.eq.1)then   !inelastic
1429 c          if(r.lt.1.-(1.-rexndi(icltar))**kolt(it))iet(it)=1
1430           if(r.lt.1.-(1.-rexndi(icltar)))iet(it)=1
1431         elseif(mdif.eq.1)then        !diffr
1432           if(r.lt.1.-(1.-rexdif(icltar))**kolt(it))iet(it)=2
1433 c          if(r.lt.1.-(1.-rexdif(icltar)))iet(it)=2
1434         endif
1435
1436       endif
1437
1438       end
1439
1440
1441 c-------------------------------------------------------------------------
1442       subroutine ProDiPt(k)
1443 c-------------------------------------------------------------------------
1444 c propose transverse momentum for diffractive interaction
1445 c-------------------------------------------------------------------------
1446
1447       include 'epos.incems'
1448       include 'epos.inc'
1449       double precision xxe,xye,p5sqpr,p5sqtg
1450       double precision plc,s
1451       common/cems5/plc,s
1452
1453       ip=iproj(k)
1454       it=itarg(k)
1455
1456
1457 c generate p_t for diffractive
1458
1459        if(ptdiff.ne.0.)then
1460          if(itpr(k).eq.2)then
1461            ptd=ptdiff
1462 c           ad=pi/4./ptd**2
1463 c           r=rangen()
1464            pt=ranpt()*ptd !sqrt(-alog(r)/ad)
1465          elseif(itpr(k).eq.0)then   !pt for non-wounded nucleon (usefull in ProRem to avoid problem in utrescl)
1466            ptnw=0.005
1467            pt=ranptd()*ptnw
1468          else
1469            xxe=0d0
1470            xye=0d0
1471            goto 10
1472          endif
1473          phi=2.*pi*rangen()
1474          xxe=dble(pt*cos(phi))
1475          xye=dble(pt*sin(phi))
1476        else
1477          xxe=0d0
1478          xye=0d0
1479        endif
1480
1481 c update remnant p_t
1482
1483  10    xxp(ip)=xxp(ip)-xxe
1484        xyp(ip)=xyp(ip)-xye
1485        xxt(it)=xxt(it)+xxe
1486        xyt(it)=xyt(it)+xye
1487
1488        if(iep(ip).eq.6.and.iet(it).eq.6)then             !to simulate the fact that originally
1489          if(itpr(k).eq.3)then
1490            call StoCon(-k,k,1)  !to fixe mass of corresponding remnants
1491            xpp(ip)=xpp(ip)-xppr(1,k)
1492            xpt(it)=xpt(it)+xppr(1,k)
1493            xmt(it)=xmt(it)-xmpr(1,k)
1494            xmp(ip)=xmp(ip)+xmpr(1,k)
1495            idpr(1,k)=0
1496            xpr(1,k)=0.d0
1497            ypr(1,k)=0.d0
1498            xppr(1,k)=0.d0
1499            xmpr(1,k)=0.d0
1500          endif
1501          p5sqpr=xpp(ip)*plc*xmp(ip)*plc-dble(amproj*amproj)
1502          p5sqtg=xpt(it)*plc*xmt(it)*plc-dble(amtarg*amtarg)
1503          phi=2.*pi*rangen()
1504          ntry=0
1505  20      ntry=ntry+1
1506          pt=ranptcut(ptsemx)*ptsend**2
1507          if(ntry.lt.100.and.(p5sqpr-dble(pt*pt).lt.0.d0
1508      &                   .or.p5sqtg-dble(pt*pt).lt.0.d0))then
1509              goto 20
1510          else
1511            pt=ranptcut(ptsemx)*ptsendi
1512          endif
1513          xxe=dble(pt*cos(phi))
1514          xye=dble(pt*sin(phi))
1515          xxp(ip)=xxp(ip)-xxe
1516          xyp(ip)=xyp(ip)-xye
1517          xxt(it)=xxt(it)+xxe
1518          xyt(it)=xyt(it)+xye
1519        endif
1520
1521
1522        end
1523
1524 c-------------------------------------------------------------------------
1525       subroutine ProSePt(k,n)
1526 c-------------------------------------------------------------------------
1527 c propose transverse momentum for string ends
1528 c-------------------------------------------------------------------------
1529
1530       include 'epos.inc'
1531       include 'epos.incems'
1532
1533       if(ivpr(n,k).eq.2)return            !Backup Pomeron
1534
1535       ip=iproj(k)
1536       it=itarg(k)
1537       amk0=(qmass(1)+qmass(2)+qmass(3))     !mass for mt distribution but spoil <pt> of anti-proton at low energy
1538
1539 ctp060829      id=idpr(n,k)
1540 ctp060829      ih=0
1541 ctp060829      if(id.eq.3)ih=1
1542
1543 c generate p_t for string ends  (proj)
1544
1545 c      nph=0
1546 c      do l=1,lproj(ip)
1547 c        kk=kproj(ip,l)
1548 c        nph=nph+npr(3,kk)
1549 c      enddo
1550 c
1551 c      !---proj-----
1552 c        zz=0
1553 c        if(isplit.eq.1)then
1554 c         if(lproj(ip).ge.1)then
1555 c          do l=1,lproj(ip)
1556 c           kpair=kproj(ip,l)
1557 c           if(itpr(kpair).eq.1)then
1558 c            zz=zz+zparpro(kpair)
1559 c           endif
1560 c          enddo
1561 c         endif
1562 c        endif
1563 c      !------
1564         ptsef=ptsemx
1565 c        if(iep(ip).eq.0)ptsef=ptsef*ptsendi
1566         ptsendx=ptsend
1567         if(iep(ip).eq.0)ptsendx=ptsendi
1568         ptsendy = ptsendi
1569
1570       if(idp1pr(n,k).gt.0)then
1571          if(idp1pr(n,k).eq.4.or.idp1pr(n,k).eq.5)then   !diquarks
1572 c          pt=ranptd()*ptsendx
1573 c           if(iep(ip).eq.0)then
1574 c            pt=ranpt()*ptsendy
1575 c          else
1576 c            pt=ranptd()*ptsendy
1577 c          endif
1578            pt=ranptcut(ptsef)*ptsendy
1579            amk1=amk0!+qmass(0)*0.5 !mass for mt distribution with bounding energy for diquark
1580          else
1581 c          pt=ranptd()*ptsendx
1582 c           if(iep(ip).eq.0)then
1583 c             pt=ranpt()*ptsendx
1584 c           else
1585 c             pt=ranptd()*ptsendx
1586 c           endif
1587           pt=ranptcut(ptsef)*ptsendx
1588            amk1=amk0
1589          endif
1590          pt=sqrt(pt*pt+2.*pt*amk1) !sample mt-m0 instead of pt ...
1591          phi=2.*pi*rangen()
1592          xxp1pr(n,k)=dble(pt*cos(phi))
1593          xyp1pr(n,k)=dble(pt*sin(phi))
1594       else
1595          xxp1pr(n,k)=0d0
1596          xyp1pr(n,k)=0d0
1597       endif
1598       if(idp2pr(n,k).gt.0)then
1599          if(idp2pr(n,k).eq.4.or.idp2pr(n,k).eq.5)then
1600 c           pt=ranptd()*ptsendy
1601 c           if(iep(ip).eq.0)then
1602 c             pt=ranpt()*ptsendy
1603 c           else
1604 c             pt=ranptd()*ptsendy
1605 c           endif
1606            pt=ranptcut(ptsef)*ptsendy
1607            amk1=amk0!+qmass(0)*0.5 !mass for mt distribution with bounding energy for diquark
1608          else
1609 c           pt=ranptd()*ptsendx
1610 c           if(iep(ip).eq.0)then
1611 c             pt=ranpt()*ptsendx
1612 c           else
1613 c             pt=ranptd()*ptsendx
1614 c           endif
1615            pt=ranptcut(ptsef)*ptsendx
1616            amk1=amk0
1617          endif
1618          pt=sqrt(pt*pt+2.*pt*amk1) !sample mt-m0 instead of pt ...
1619          phi=2.*pi*rangen()
1620          xxp2pr(n,k)=dble(pt*cos(phi))
1621          xyp2pr(n,k)=dble(pt*sin(phi))
1622       else
1623          xxp2pr(n,k)=0d0
1624          xyp2pr(n,k)=0d0
1625       endif
1626 c generate p_t for string ends  (targ)
1627
1628
1629 c      nph=0
1630 c      do l=1,ltarg(it)
1631 c        kk=ktarg(it,l)
1632 c        nph=nph+npr(3,kk)
1633 c      enddo
1634 c
1635 c      !---targ-----
1636 c        zz=0
1637 c        if(isplit.eq.1)then
1638 c         if(ltarg(it).ge.1)then
1639 c          do l=1,ltarg(it)
1640 c           kpair=ktarg(it,l)
1641 c           if(itpr(kpair).eq.1)then
1642 c            zz=zz+zpartar(kpair)
1643 c           endif
1644 c          enddo
1645 c         endif
1646 c        endif
1647 c      !---------
1648         ptsef=ptsemx
1649 c        if(iet(it).eq.0)ptsef=ptsef*ptsendi
1650         ptsendx=ptsend
1651         if(iet(it).eq.0)ptsendx=ptsendi
1652         ptsendy = ptsendx
1653
1654       if(idm1pr(n,k).gt.0)then
1655          if(idm1pr(n,k).eq.4.or.idm1pr(n,k).eq.5)then
1656 c           pt=ranptd()*ptsendy
1657 c           if(iet(it).eq.0)then
1658 c             pt=ranpt()*ptsendy
1659 c           else
1660 c             pt=ranptd()*ptsendy
1661 c           endif
1662            pt=ranptcut(ptsef)*ptsendy
1663            amk1=amk0!+qmass(0)*0.5 !mass for mt distribution with bounding energy for diquark
1664          else
1665 c           pt=ranptd()*ptsendx
1666 c           if(iet(it).eq.0)then
1667 c             pt=ranpt()*ptsendx
1668 c           else
1669 c             pt=ranptd()*ptsendx
1670 c           endif
1671            pt=ranptcut(ptsef)*ptsendx
1672            amk1=amk0
1673          endif
1674          pt=sqrt(pt*pt+2.*pt*amk1) !sample mt-m0 instead of pt ...
1675          phi=2.*pi*rangen()
1676          xxm1pr(n,k)=dble(pt*cos(phi))
1677          xym1pr(n,k)=dble(pt*sin(phi))
1678       else
1679          xxm1pr(n,k)=0d0
1680          xym1pr(n,k)=0d0
1681       endif
1682       if(idm2pr(n,k).gt.0)then
1683          if(idm2pr(n,k).eq.4.or.idm2pr(n,k).eq.5)then
1684 c           pt=ranptd()*ptsendy
1685 c           if(iet(it).eq.0)then
1686 c             pt=ranpt()*ptsendy
1687 c           else
1688 c             pt=ranptd()*ptsendy
1689 c           endif
1690            pt=ranptcut(ptsef)*ptsendy
1691            amk1=amk0!+qmass(0)*0.5 !mass for mt distribution with bounding energy for diquark
1692          else
1693 c           pt=ranptd()*ptsendx
1694 c           if(iet(it).eq.0)then
1695 c             pt=ranpt()*ptsendx
1696 c           else
1697 c             pt=ranptd()*ptsendx
1698 c           endif
1699            pt=ranptcut(ptsef)*ptsendx
1700            amk1=amk0
1701          endif
1702          pt=sqrt(pt*pt+2.*pt*amk1) !sample mt-m0 instead of pt ...
1703          phi=2.*pi*rangen()
1704          xxm2pr(n,k)=dble(pt*cos(phi))
1705          xym2pr(n,k)=dble(pt*sin(phi))
1706       else
1707          xxm2pr(n,k)=0d0
1708          xym2pr(n,k)=0d0
1709       endif
1710
1711 c update backup soft pomeron p_t if exist
1712
1713         if(nbkpr(n,k).ne.0)then
1714           nn=nbkpr(n,k)
1715           xxp1pr(nn,k)=xxp1pr(n,k)
1716           xyp1pr(nn,k)=xyp1pr(n,k)
1717           xxp2pr(nn,k)=xxp2pr(n,k)
1718           xyp2pr(nn,k)=xyp2pr(n,k)
1719           xxm1pr(nn,k)=xxm1pr(n,k)
1720           xym1pr(nn,k)=xym1pr(n,k)
1721           xxm2pr(nn,k)=xxm2pr(n,k)
1722           xym2pr(nn,k)=xym2pr(n,k)
1723         endif
1724
1725
1726
1727 c update remnant p_t (pomeron)
1728         xxp(ip)=xxp(ip)-xxp1pr(n,k)-xxp2pr(n,k)
1729         xyp(ip)=xyp(ip)-xyp1pr(n,k)-xyp2pr(n,k)
1730         xxt(it)=xxt(it)-xxm1pr(n,k)-xxm2pr(n,k)
1731         xyt(it)=xyt(it)-xym1pr(n,k)-xym2pr(n,k)
1732
1733         if(ish.ge.6)then
1734         write(ifch,*) 'ProSePt'
1735         write(ifch,'(4i14/4d14.3/4d14.3/)')
1736      * idp1pr(n,k),idp2pr(n,k),idm1pr(n,k),idm2pr(n,k)
1737      *,xxp1pr(n,k),xxp2pr(n,k),xxm1pr(n,k),xxm2pr(n,k)
1738      *,xyp1pr(n,k),xyp2pr(n,k),xym1pr(n,k),xym2pr(n,k)
1739         endif
1740
1741         end
1742
1743 c-----------------------------------------------------------------------
1744       subroutine ProSeX(k,n,iret)
1745 c-----------------------------------------------------------------------
1746 c calculates x of string ends
1747 c-----------------------------------------------------------------------
1748
1749       include 'epos.inc'
1750       include 'epos.incems'
1751       common/cems5/plc,s
1752       double precision s,plc
1753       common/cems10/a(0:ntypmx),b(0:ntypmx),d(0:ntypmx)
1754       double precision a,b,d
1755      *,xp,xm,ap1,ap2,am1,am2,aamin1,aamin2,u
1756      *,xmn1,xmn2
1757
1758       iret=0
1759
1760       if(itpr(k).ne.1)return
1761       if(idpr(n,k).ne.1.or.ivpr(n,k).eq.0)return
1762
1763       if(idp1pr(n,k).eq.0.and.idp2pr(n,k).eq.0
1764      * .and.idm1pr(n,k).eq.0.and.idm2pr(n,k).eq.0)
1765      *call utstop('no Pomeron in ProSex&')
1766
1767       xp=xppr(n,k)
1768       xm=xmpr(n,k)
1769       ap1=a(idp1pr(n,k))
1770       ap2=a(idp2pr(n,k))
1771       am1=a(idm1pr(n,k))
1772       am2=a(idm2pr(n,k))
1773       aamin1=ammn(idp1pr(n,k)+idm2pr(n,k))
1774       aamin2=ammn(idp2pr(n,k)+idm1pr(n,k))
1775       xmn1=(aamin1**2+(xxp1pr(n,k)+xxm2pr(n,k))**2
1776      &               +(xyp1pr(n,k)+xym2pr(n,k))**2)/s
1777       xmn2=(aamin2**2+(xxp2pr(n,k)+xxm1pr(n,k))**2
1778      &               +(xyp2pr(n,k)+xym1pr(n,k))**2)/s
1779
1780       ntry=0
1781  999  ntry=ntry+1
1782       if(ntry.gt.100)then
1783         iret=1
1784         if(ish.ge.5)write(ifch,*)'Problem in ProSex(k,n)',k,n
1785         return
1786       endif
1787
1788     1 u=dble(rangen())**(1d0/(1d0+ap1))
1789       if(dble(rangen()).gt.(1d0-u)**ap2)goto1
1790       xp1pr(n,k)=u*xp
1791       xp2pr(n,k)=(1-u)*xp
1792     2 u=dble(rangen())**(1d0/(1d0+am1))
1793       if(dble(rangen()).gt.(1d0-u)**am2)goto2
1794       xm1pr(n,k)=u*xm
1795       xm2pr(n,k)=(1-u)*xm
1796
1797       if(xp1pr(n,k)*xm2pr(n,k).lt.xmn1)then
1798       goto 999
1799 c       fc=xp1pr(n,k)*xm2pr(n,k)/xmn1   !avoid virpom
1800 c       if(fc.eq.0.)goto 999
1801 c       xp1pr(n,k)=xp1pr(n,k)/sqrt(fc)
1802 c       xm2pr(n,k)=xm2pr(n,k)/sqrt(fc)
1803       endif
1804       if(xp2pr(n,k)*xm1pr(n,k).lt.xmn2)then
1805       goto 999
1806 c       fc=xp2pr(n,k)*xm1pr(n,k)/xmn2   !avoid virpom
1807 c       if(fc.eq.0.)goto 999
1808 c       xp2pr(n,k)=xp2pr(n,k)/sqrt(fc)
1809 c       xm1pr(n,k)=xm1pr(n,k)/sqrt(fc)
1810       endif
1811
1812       if(ish.ge.6)then
1813        write(ifch,*) 'ProSeX'
1814        write(ifch,'(2d28.3,i8)') xp,xm,ntry
1815        write(ifch,'(4d14.3)')xp1pr(n,k),xp2pr(n,k),xm1pr(n,k),xm2pr(n,k)
1816        write(ifch,'(4d14.3/)')xp1pr(n,k)*xm2pr(n,k)
1817      *                   ,xp2pr(n,k)*xm1pr(n,k),  xmn1, xmn2
1818       endif
1819
1820       end
1821 c-------------------------------------------------------------------------
1822       subroutine RmPt(k,n)
1823 c-------------------------------------------------------------------------
1824 c remove pt from pomeron
1825 c-------------------------------------------------------------------------
1826       include 'epos.inc'
1827       include 'epos.incems'
1828       ip=iproj(k)
1829       it=itarg(k)
1830       xxp(ip)=xxp(ip)+xxp1pr(n,k)+xxp2pr(n,k)
1831       xyp(ip)=xyp(ip)+xyp1pr(n,k)+xyp2pr(n,k)
1832       xxt(it)=xxt(it)+xxm1pr(n,k)+xxm2pr(n,k)
1833       xyt(it)=xyt(it)+xym1pr(n,k)+xym2pr(n,k)
1834       xp1pr(n,k)=0d0
1835       xp2pr(n,k)=0d0
1836       xm1pr(n,k)=0d0
1837       xm2pr(n,k)=0d0
1838       xxm1pr(n,k)=0d0
1839       xym1pr(n,k)=0d0
1840       xxp1pr(n,k)=0d0
1841       xyp1pr(n,k)=0d0
1842       xxm2pr(n,k)=0d0
1843       xym2pr(n,k)=0d0
1844       xxp2pr(n,k)=0d0
1845       xyp2pr(n,k)=0d0
1846       idp1pr(n,k)=0
1847       idm2pr(n,k)=0
1848       idp2pr(n,k)=0
1849       idm1pr(n,k)=0
1850       end
1851
1852 c-------------------------------------------------------------------------
1853       subroutine VirPom(k,n,id)
1854 c-------------------------------------------------------------------------
1855 c create virtual pomeron
1856 c virtual pomeron: ivpr(n,k)=0, otherwise ivpr(n,k)=1
1857 c-------------------------------------------------------------------------
1858
1859       include 'epos.inc'
1860       include 'epos.incems'
1861       common/col3/ncol,kolpt
1862       common/emsptl/nppr(npommx,kollmx),npproj(mamx),nptarg(mamx)
1863       double precision plc,s
1864       common/cems5/plc,s
1865 c      data nvir/0/
1866 c      save nvir
1867
1868       call utpri('VirPom',ish,ishini,3)
1869
1870       if(idpr(n,k).eq.0)return
1871
1872       ip=iproj(k)
1873       it=itarg(k)
1874
1875       nnv=nvpr(n,k)
1876       nnb=nbkpr(n,k)
1877
1878 c                        nvir=nvir+1
1879 c                   print *,'  ',id,'   ',nvir
1880
1881       if(ish.ge.3)then
1882       write(ifch,*)"virpom ",id," (n,k)",n,k,nnb,nnv,nppr(n,k)
1883       if(ish.ge.5)write(ifch,*)"remnant in",xpp(ip),xmt(it)
1884       endif
1885
1886       if(nnv.ne.0)then
1887         nn=nnv
1888         kk=k
1889         if(idpr(nn,kk).eq.0)then
1890           nvpr(n,k)=0
1891         endif
1892       endif
1893
1894       if(nnb.ne.0)then
1895         nn=nnb
1896         kk=k
1897         if(idpr(nn,kk).eq.0)then
1898           nbkpr(n,k)=0
1899          endif
1900       endif
1901
1902
1903       if(nbkpr(n,k).eq.0.and.nvpr(n,k).eq.0)then     !normal Pomeron
1904
1905       npr(0,k)=npr(0,k)+1
1906       npp(ip)=npp(ip)-1
1907       npt(it)=npt(it)-1
1908       npr(idpr(n,k),k)=npr(idpr(n,k),k)-1
1909       nprt(k)=npr(1,k)+npr(3,k)
1910       antotf=antotf-1
1911       if(idpr(n,k).eq.1)ansff=ansff-1
1912       if(idpr(n,k).eq.3)anshf=anshf-1
1913       kolp(ip)=kolp(ip)-1
1914       kolt(it)=kolt(it)-1
1915       xpp(ip)=xpp(ip)+xppr(n,k)
1916       xmt(it)=xmt(it)+xmpr(n,k)
1917       xxp(ip)=xxp(ip)+xxp1pr(n,k)+xxp2pr(n,k)
1918       xyp(ip)=xyp(ip)+xyp1pr(n,k)+xyp2pr(n,k)
1919       xxt(it)=xxt(it)+xxm1pr(n,k)+xxm2pr(n,k)
1920       xyt(it)=xyt(it)+xym1pr(n,k)+xym2pr(n,k)
1921
1922       if(itpr(k).eq.1.and.nprt(k).eq.0)then  !no more Pomeron on this pair
1923         if(kolp(ip).eq.0)then
1924           kolp(ip)=1        !excite nucleon (remnant get pt in ProDiPt)
1925           iep(ip)=6         !with inel mass and inverted string
1926         endif
1927         if(kolt(it).eq.0)then
1928           kolt(it)=1
1929           iet(it)=6
1930         endif
1931         if(koll.le.2.and.iep(ip).eq.6.and.iet(it).eq.6)then  !for small systems we can store lost informations
1932           itpr(k)=3             !to use it to define remnant mass
1933           call StoCon(k,k,n)    !store information on lost Pomeron
1934         endif
1935       endif
1936
1937       endif
1938
1939
1940       ivpr(n,k)=0
1941       nbkpr(n,k)=0
1942       nvpr(n,k)=0
1943       idpr(n,k)=0
1944       idfpr(n,k)=0
1945       xpr(n,k)=0d0
1946       ypr(n,k)=0d0
1947       xppr(n,k)=0d0
1948       xmpr(n,k)=0d0
1949       idp1pr(n,k)=0
1950       idp2pr(n,k)=0
1951       idm1pr(n,k)=0
1952       idm2pr(n,k)=0
1953       xm1pr(n,k)=0d0
1954       xp1pr(n,k)=0d0
1955       xm2pr(n,k)=0d0
1956       xp2pr(n,k)=0d0
1957       xxm1pr(n,k)=0d0
1958       xym1pr(n,k)=0d0
1959       xxp1pr(n,k)=0d0
1960       xyp1pr(n,k)=0d0
1961       xxm2pr(n,k)=0d0
1962       xym2pr(n,k)=0d0
1963       xxp2pr(n,k)=0d0
1964       xyp2pr(n,k)=0d0
1965
1966        if(ish.ge.5)write(ifch,*)"remnant out",xpp(ip),xmt(it)
1967
1968       call utprix('VirPom',ish,ishini,3)
1969
1970       end
1971
1972 c-----------------------------------------------------------------------
1973       subroutine StoRe(imod)
1974 c-----------------------------------------------------------------------
1975 c Store Remnant configuration (imod=1) before shuffle  to restore the
1976 c initial configuration (imod=-1) in case of problem.
1977 c-----------------------------------------------------------------------
1978
1979       include 'epos.inc'
1980       include 'epos.incems'
1981
1982       if(imod.eq.1)then
1983
1984 c       initialize projectile
1985
1986         do i=1,maproj
1987           xppst(i)=xpp(i)
1988           xmpst(i)=xmp(i)
1989           xposst(i)=xpos(i)
1990         enddo
1991
1992 c       initialize target
1993
1994         do j=1,matarg
1995           xmtst(j)=xmt(j)
1996           xptst(j)=xpt(j)
1997           xtosst(j)=xtos(j)
1998         enddo
1999
2000       elseif(imod.eq.-1)then
2001
2002 c       restore projectile
2003
2004         do i=1,maproj
2005           xpp(i)=xppst(i)
2006           xmp(i)=xmpst(i)
2007           xpos(i)=xposst(i)
2008         enddo
2009
2010 c       restore target
2011
2012         do j=1,matarg
2013           xmt(j)=xmtst(j)
2014           xpt(j)=xptst(j)
2015           xtos(j)=xtosst(j)
2016         enddo
2017
2018       else
2019
2020         call utstop('Do not know what to do in StoRe.&')
2021
2022       endif
2023
2024       return
2025       end
2026
2027 c-----------------------------------------------------------------------
2028       subroutine CalcZZ(ir,m)
2029 c-----------------------------------------------------------------------
2030 C Calculates zz for remnant m for proj (ir=1) or target (ir=-1)
2031 c   writes it to zzremn(m, 1 or 2)
2032 c-----------------------------------------------------------------------
2033       include 'epos.inc'
2034       include 'epos.incems'
2035       if(ir.eq.1)then
2036         if(kolp(m).eq.0)then
2037           zzremn(m,1)=0
2038           return
2039         endif
2040       elseif(ir.eq.-1)then
2041         if(kolt(m).eq.0)then
2042           zzremn(m,2)=0
2043           return
2044         endif
2045       endif
2046       if(isplit.eq.1)then
2047         if(ir.eq.1)then
2048           zz=0
2049           if(lproj(m).ge.1)then
2050            do l=1,lproj(m)
2051             kpair=kproj(m,l)
2052             if(itpr(kpair).eq.1)then
2053              zz=zz+zparpro(kpair)
2054             endif
2055            enddo
2056           endif
2057           zzremn(m,1)=zz
2058         elseif(ir.eq.-1)then
2059           zz=0
2060           if(ltarg(m).ge.1)then
2061            do l=1,ltarg(m)
2062             kpair=ktarg(m,l)
2063             if(itpr(kpair).eq.1)then
2064              zz=zz+zpartar(kpair)
2065             endif
2066            enddo
2067           endif
2068           zzremn(m,2)=zz
2069         else
2070           stop'CalcZZ: invalid option.          '
2071         endif
2072       else
2073         if(ir.eq.1) zzremn(m,1)=0
2074         if(ir.eq.-1)zzremn(m,2)=0
2075       endif
2076       end
2077
2078 c-----------------------------------------------------------------------
2079       subroutine WriteZZ(ir,irem)
2080 c-----------------------------------------------------------------------
2081 c Write Z into zpaptl(K) for connected strings
2082 c                 K is the index for the string end
2083 c                 on the corresponding remnant side
2084 c-----------------------------------------------------------------------
2085
2086       include 'epos.inc'
2087       include 'epos.incems'
2088       common/emsptl/nppr(npommx,kollmx),npproj(mamx),nptarg(mamx)
2089
2090       if(ir.eq.1)then
2091         jrem=1
2092       elseif(ir.eq.-1)then
2093         jrem=2
2094       endif
2095
2096       do li=1,lremn(irem,jrem)
2097         kkk=kremn(irem,li,jrem)
2098          do n=1,nprmx(kkk)
2099           if(idpr(n,kkk).ne.0)then
2100             npom=nppr(n,kkk)
2101 c              write(ifch,*)'remn',irem,' (',jrem,' )     pom',npom
2102 c     &            ,'    ',zzremn(irem,jrem)
2103             ie=0
2104             do is=ifrptl(1,npom),ifrptl(2,npom)
2105               if(ie.eq.0)is1=is
2106               if(idptl(is).ne.9)ie=ie+1
2107               if(ie.eq.2)then
2108                is2=is
2109                ie=0
2110                if(ir.eq. 1)zpaptl(is1)=zzremn(irem,jrem)
2111                if(ir.eq.-1)zpaptl(is2)=zzremn(irem,jrem)
2112                do isi=is1,is2
2113 c                     write(ifch,*)'            ',isi,idptl(isi),zpaptl(isi)
2114                enddo
2115               endif
2116             enddo
2117           endif
2118         enddo
2119       enddo
2120
2121       end
2122
2123 c-----------------------------------------------------------------------
2124       subroutine ProReM(ir,irem,iret)
2125 c-----------------------------------------------------------------------
2126 c propose remnant mass of remnant irem in case of proj (ir=1)
2127 c or target (ir=-1)
2128 c   (-> xmp, xpt)
2129 c iret : input : if iret=10 force to give mass even if no more energy,
2130 c        when input not 10 : output = error if 1
2131 c-----------------------------------------------------------------------
2132
2133       include 'epos.inc'
2134       include 'epos.incems'
2135       double precision rr,xxx,xmin,xmax,msmin,xmmin,xpt2rem,xtest0
2136       double precision at,alp,xi,xii,eps,sx,xmin0,xtest(mamx),fxtest
2137       parameter(eps=1.d-20)
2138       common/cemsr5/at(0:1,0:6)
2139       double precision plc,s,p5sq,aremn,aremnex
2140       common/cems5/plc,s
2141       integer icrmn(2)
2142       logical cont,force
2143       character cremn*4
2144
2145       call utpri('ProReM',ish,ishini,5)
2146
2147       if(iret.eq.10)then
2148         force=.true.
2149       else
2150         iret=0
2151         force=.false.
2152       endif
2153       ntrymx=50
2154
2155 c uncomment the following two lines to force the excitation
2156
2157 ccc      force=.true.   !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
2158 ccc      ntrymx=1       !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
2159
2160 c initial definitions
2161
2162       ntry=0
2163       xxx=0.d0
2164       if(ir.eq.1)then
2165         cremn='proj'
2166         jrem=1
2167         jremo=2
2168         masso=matarg
2169         do j=1,masso
2170           xme(j)=0.d0
2171         enddo
2172         amremn=amproj
2173            !idx=isign(iabs(idproj)/10*10+1,idproj)
2174            !call idmass(idx,amremn)
2175         iremo1=itarg(1)
2176 ctp        kolzi=kolp(irem)
2177         noevt=ntgevt
2178         msmin=dble(amremn*amremn)
2179         if(iep(irem).eq.6)goto 678
2180       elseif(ir.eq.-1)then
2181         cremn='targ'
2182         jrem=2
2183         jremo=1
2184         masso=maproj
2185         do j=1,masso
2186           xme(j)=0.d0
2187         enddo
2188         amremn=amtarg
2189            !idx=isign(iabs(idtarg)/10*10+1,idtarg)
2190            !call idmass(idx,amremn)
2191         iremo1=iproj(1)
2192 ctp        kolzi=kolt(irem)
2193         noevt=npjevt
2194         msmin=dble(amremn*amremn)
2195         if(iet(irem).eq.6)goto 678
2196       endif
2197
2198 ctp   noevt replace noxevt
2199 ctp if iez=0, 5% energy violation allowed to give mass to the other side
2200 ctp      noxevt=0      !?????? otherwise, energy is strongly not conserved
2201 ctp      do i=1,masso
2202 ctp       if(iez(i,jremo).gt.0)noxevt=noxevt+1
2203 ctp      enddo
2204
2205
2206 c ntry
2207
2208     1 ntry=ntry+1
2209       if(ntry.gt.ntrymx)then
2210         if(ish.ge.5)then
2211           call utmsg('ProReM')
2212           write(ifch,*)'Remnant mass assignment not possible (ntry)'
2213           if(force)write(ifch,*)'Ignore p4 conservation'
2214           call utmsgf
2215         endif
2216         if(.not.force)then
2217           iret=1
2218         else
2219           if(ir.eq.1)then
2220             xmp(irem)=xxx
2221           else
2222             xpt(irem)=xxx
2223           endif
2224         endif
2225         goto 1000
2226       endif
2227
2228 c check
2229
2230       if(xpz(irem,jrem).le.0.d0)then
2231         write(ifch,*)'ProRem ipp',xpz(irem,jrem),irem,lremn(irem,jrem)
2232         do li=1,lremn(irem,jrem)
2233           kkk=kremn(irem,li,jrem)
2234           write(ifch,*)'kkk',kkk
2235         enddo
2236         call XPrint('ProRem pro:&')
2237         call utstop('Big problem in ProRem pro!&')
2238       endif
2239
2240 c xtest = xminus-max,  corresponding mostly to a remnant mass 0.2
2241
2242       xtest0=0.d0
2243       fxtest=0.2d0
2244       do j=1,masso
2245         cont=.false.
2246         xme(j)=0.d0
2247 ctp        if(xmz(j,jremo).gt.eps.and.iez(j,jrem).gt.0)then !xmz(,jremo)=xplus
2248 ctp060824        if(xmz(j,jremo).gt.eps.and.iez(j,jrem).ge.0)then !xmz(,jremo)=xplus
2249 c        if(iez(j,jremo).gt.0.or.koll.eq.1)then !xmz(,jremo)=xplus
2250           if(xmz(j,jremo).gt.eps)then !xmz(,jremo)=xplus
2251             cont=.true.
2252             xmmin=xzos(j,jremo)/xmz(j,jremo)
2253           else
2254             xmmin=xzos(j,jremo)
2255           endif
2256           xtest(j)=xpz(j,jremo)-xmmin !maximal momentum available
2257 !this term is very important for non excited remnants in pp, it changes the xf
2258 ! distribution of proton and the multiplicity at low energy. Fxtest should not
2259 ! be to close to 0. otherwise it makes a step in xf distribution of p at
2260 ! 1-fxtest but if fxtest=1, multiplicity at low energy is too high ...
2261           if(.not.cont)then
2262             if(xtest(j).gt.0d0)then
2263               xtest(j)=min(xtest(j),fxtest/xpz(irem,jrem))
2264             else
2265               xtest(j)=min(1.d0,fxtest/xpz(irem,jrem))
2266             endif
2267           endif
2268 c        else
2269 c          xtest(j)=0.01d0 !maximal momentum available for non exited state
2270 c        endif
2271          xtest0=max(xtest0,xtest(j))
2272 c        print *,iep(1),iet(1),iez(irem,jrem),xtest(j),xpz(j,jremo),xmmin
2273 c     & ,xzos(j,jremo),xmz(j,jremo)
2274       enddo
2275 ctp060824      if(.not.cont)xtest=min(1.d0,0.2d0/xpz(irem,jrem))
2276
2277
2278       cont=.true.
2279
2280 c defs
2281
2282       sx=s*xpz(irem,jrem)
2283       icrmn(1)=icremn(1,irem,jrem)
2284       icrmn(2)=icremn(2,irem,jrem)
2285       xpt2rem=xxz(irem,jrem)**2d0+xyz(irem,jrem)**2d0
2286
2287 c  fremnux (+) or fremnux2 (-) ?
2288
2289       aremn=dble(fremnux2(icrmn)) !dble(max(amremn,fremnux2(icrmn)))
2290 c      if(iez(j,jrem).eq.2)then
2291 c        aremnex=aremn
2292 c      else
2293 c        aremnex=max(amzmn(idz(irem,jrem),jrem)   !makes remnant to heavy at low energy
2294 c     &   +amemn(idz(irem,jrem),iez(irem,jrem))
2295 c     &           ,dble(fremnux(icrmn)))
2296         aremnex=aremn+amemn(idz(irem,jrem),iez(irem,jrem))
2297 c      endif
2298
2299 c determine xminus
2300
2301 c      xmin0=1.05*(aremn**2d0+xxz(irem,jrem)**2d0+xyz(irem,jrem)**2d0)/sx
2302 c      xmin=1.1*(aremnex**2d0+xxz(irem,jrem)**2d0+xyz(irem,jrem)**2d0)/sx
2303       xmin0=1.01d0*(aremn**2d0+xpt2rem)/sx
2304       xmin=1.01d0*(aremnex**2d0+xpt2rem)/sx
2305       xmax=min(1.d6/s,xtest0)             !to avoid ultra high mass remnants
2306 c for diffractive remnant, mass should never exceed 5% of the proj or targ energy
2307       if(iez(irem,jrem).eq.1)then
2308         xmax=min(xmax,max(dble(xmaxremn),xmin))
2309       elseif(iez(irem,jrem).eq.2)then
2310         xmax=min(xmax,max(dble(xmaxdiff),xmin))
2311       endif
2312       if(koll.eq.1)xmax=min(xmax,xpz(iremo1,jremo))
2313       if(xmin.ge.xmax-eps)then
2314         xmin=xmin0
2315         if(koll.ne.1)xmax=1.d0
2316         if(xmin.ge.xmax-eps)then
2317         if(.not.force)then
2318           iret=1
2319         else
2320           xmz(irem,jrem)=xmin
2321         endif
2322         goto 1000
2323         endif
2324       endif
2325       xmin0=xmin
2326       rr=dble(rangen())
2327       if(iez(irem,jrem).gt.0)then
2328 c        xmin=xmin-xpt2rem/sx                     !no pt
2329 c        xmax=xmax-xpt2rem/sx                     !no pt
2330         alp=at(idz(irem,jrem),iez(irem,jrem))
2331 c        print *,'alp',iez(irem,jrem),alp,xmin,xmax
2332         if(dabs(alp-1.d0).lt.eps)then
2333           xxx=xmax**rr*xmin**(1d0-rr)
2334         else
2335           xxx=(rr*xmax**(1d0-alp)+(1d0-rr)*xmin**(1d0-alp))
2336      &                                             **(1d0/(1d0-alp))
2337         endif
2338 c        xxx=xxx+xpt2rem/sx                       !no pt
2339       else
2340 c        xmin=dble(amremn)**2d0/sx                !no pt
2341 c        xxx=xmin+xpt2rem/sx                      !no pt
2342         xmin=(dble(amremn)**2d0+xpt2rem)/sx
2343         xxx=xmin
2344         if(xmin.gt.xmax+eps)then
2345           if(ish.ge.6)write(ifch,*)'xmin>xmax for proj not possible (2)'
2346           if(.not.force)then
2347             iret=1
2348           else
2349             xmz(irem,jrem)=xxx
2350           endif
2351           goto 1000
2352         endif
2353         !to have nice diffractive pic, do not allow too much fluctuation
2354 c        xmin0=0.92d0*xxx
2355 c        xmin0=0.9d0*xxx
2356         xmin0=min(0.99d0,1d0-fxtest*dble(1.-rangen()))*xxx
2357 c        xmin0=dble(0.9+0.09*rangen())*xxx
2358       endif
2359       xzos(irem,jrem)=xmin0*xpz(irem,jrem)
2360       msmin=xmin*sx
2361 c      msmin=xmin*sx+xpt2rem                      !no pt
2362
2363 c partition xminus between nucleons of the other side
2364
2365       xii=1d0
2366       iimax=noevt                 !number of opposite side participants
2367 ctp      iimax=noxevt                 !number of opposite side participants
2368       ii=iimax
2369       iro=int(rangen()*masso)+1   ! choose ramdomly a nucleon to start
2370
2371       do while(ii.gt.0)
2372
2373         cont=iez(iro,jremo).lt.0.or.xme(iro).lt.-0.99
2374         do while(cont)
2375           iro=iro+1
2376           if(iro.gt.masso)iro=iro-masso
2377           ii=ii-1
2378           if(ii.lt.1)goto 1
2379           cont=iez(iro,jremo).lt.0.or.xme(iro).lt.-0.99
2380         enddo
2381
2382         if(ii-1.gt.0)then
2383          xi=xii*dble(rangen())**(1.d0/dble(ii-1))
2384         else
2385          xi=0d0
2386         endif
2387         xme(iro)=xxx*(xii-xi)
2388
2389         xmmin=xzos(iro,jremo)
2390         if(xmz(iro,jremo).gt.eps)then
2391           xmmin=xmmin/xmz(iro,jremo)
2392         elseif(koll.eq.1.and.xtest(iro).gt.eps)then
2393           xmmin=xmmin/min(xpz(irem,jrem),xtest(iro))
2394         elseif(xtest(iro).gt.eps)then
2395           xmmin=xmmin/xtest(iro)
2396         endif
2397         if((xpz(iro,jremo)-xme(iro)).lt.xmmin)then
2398 c          write(ifch,*)'     skip ',cremn,' ',ii,iimax,ntry,xxx
2399 c     &    ,xpz(iro,jremo)-xme(iro),xmmin
2400           if(ii.le.1)goto1
2401           xme(iro)=-1.d0
2402         else
2403           xii=xi
2404 c          write(ifch,*)'       ok ',cremn,' ',ii,iimax,ntry,xme(iro)/xxx
2405         endif
2406         iro=iro+1
2407         if(iro.gt.masso)iro=iro-masso
2408         ii=ii-1
2409
2410       enddo
2411
2412 c check xmz(irem,jrem)
2413
2414       xmz(irem,jrem)=xxx
2415
2416  678  p5sq=xpz(irem,jrem)*plc*xmz(irem,jrem)*plc
2417 c      write(ifch,*)'final mass',p5sq,msmin,xpz(irem,jrem),xmz(irem,jrem)
2418 c     &,force
2419       if(p5sq.lt.msmin)then
2420         if(ish.ge.5)then
2421           call utmsg('ProReM')
2422           write(ifch,*)'Remnant mass assignment not possible (M<Mmin)!'
2423           if(force)write(ifch,*)'Ignore p4 conservation'
2424           call utmsgf
2425         endif
2426         if(.not.force)then
2427           iret=1
2428           goto 1000
2429         elseif(xpz(irem,jrem).gt.0.d0)then
2430           xmz(irem,jrem)=msmin/(plc*plc*xpz(irem,jrem))
2431         endif
2432       endif
2433
2434 c subtract xme
2435
2436       do iro=1,masso
2437         if(xme(iro).gt.0.d0)then
2438           xpz(iro,jremo)=xpz(iro,jremo)-xme(iro)  !xpz(,jremo)=xminus
2439         endif
2440       enddo
2441
2442  1000 continue
2443
2444       call utprix('ProReM',ish,ishini,5)
2445
2446       end
2447
2448 c-----------------------------------------------------------------------
2449       subroutine ProSeTy(k,n)
2450 c-----------------------------------------------------------------------
2451 c creates proposal for string ends, idp., idm.
2452 c updates quark counters
2453 c-----------------------------------------------------------------------
2454       include 'epos.inc'
2455       include 'epos.incems'
2456
2457       common/ems6/ivp0,iap0,idp0,isp0,ivt0,iat0,idt0,ist0
2458       double precision pes,xfqp,xfqt   !so01
2459       parameter(eps=1.e-6)
2460       common/ems9/xfqp(0:9),xfqt(0:9)
2461       common/emsx3/pes(0:3,0:6)
2462
2463       if(idpr(n,k).eq.2)stop'no Reggeons any more'
2464
2465       ip=iproj(k)
2466       it=itarg(k)
2467
2468       if(idpr(n,k).eq.3)then
2469        pssp=0.
2470        pvsp=0.
2471        psap=0.
2472        pddp=0.
2473        psvvp=0.
2474        paasp=0.
2475        psst=0.
2476        pvst=0.
2477        psat=0.
2478        pddt=0.
2479        psvvt=0.
2480        paast=0.
2481        if(idhpr(n,k).eq.3)then  !so01
2482         idp1pr(n,k)=2
2483         idp2pr(n,k)=8
2484         idm1pr(n,k)=2
2485         idm2pr(n,k)=8
2486         ivp(ip)=ivp(ip)          !-1
2487         ivt(it)=ivt(it)          !-1
2488        elseif(idhpr(n,k).eq.2)then
2489         idp1pr(n,k)=1
2490         idp2pr(n,k)=1
2491         idm1pr(n,k)=2
2492         idm2pr(n,k)=8
2493         ivt(it)=ivt(it)          !-1
2494        elseif(idhpr(n,k).eq.1)then
2495         idp1pr(n,k)=2
2496         idp2pr(n,k)=8
2497         idm1pr(n,k)=1
2498         idm2pr(n,k)=1
2499         ivp(ip)=ivp(ip)          !-1
2500        elseif(idhpr(n,k).eq.0)then
2501         idp1pr(n,k)=1
2502         idp2pr(n,k)=1
2503         idm1pr(n,k)=1
2504         idm2pr(n,k)=1
2505        else
2506         call utstop('ProSeTy-idhpr????&')
2507        endif
2508
2509
2510       elseif(idpr(n,k).eq.1)then
2511
2512 c    projectile
2513
2514        if(iabs(idfpr(n,k)).eq.1)then
2515
2516        ntry=0
2517   1    ntry=ntry+1
2518        if(ntry.gt.10)call utstop('something goes wrong in sr ProSeTy&')
2519        pss=wgtsea
2520        pvs=wgtval      !  *ivp(ip)
2521        psa=wgtval      !  *iap(ip)
2522        pdd=wgtdiq
2523        psvv=wgtqqq(iclpro)     !  *ivp(ip)*(ivp(ip)-1)/2.
2524        paas=wgtqqq(iclpro)    !  *iap(ip)*(iap(ip)-1)/2.
2525        su=pss+pvs+psa+pdd+psvv+paas
2526        pssp = pss /su
2527        pvsp = pvs /su
2528        psap = psa /su
2529        pddp = pdd /su
2530        psvvp= psvv/su
2531        paasp= paas/su
2532        r=rangen()
2533        if(r.gt.(pssp+pvsp+psap+pddp+psvvp).and.paasp.gt.eps)then
2534         idp1pr(n,k)=5
2535         idp2pr(n,k)=1
2536         idsppr(n,k)=6
2537 c        iap(ip)=iap(ip)-2
2538        elseif(r.gt.(pssp+pvsp+psap+pddp).and.psvvp.gt.eps)then
2539         idp1pr(n,k)=1
2540         idp2pr(n,k)=5
2541         idsppr(n,k)=5
2542 c        ivp(ip)=ivp(ip)-2
2543        elseif(r.gt.(pssp+pvsp+psap).and.pddp.gt.eps)then
2544         idp1pr(n,k)=4
2545         idp2pr(n,k)=4
2546         idsppr(n,k)=4
2547        elseif(r.gt.(pssp+pvsp).and.psap.gt.eps)then
2548         idp1pr(n,k)=1
2549         idp2pr(n,k)=2
2550         idsppr(n,k)=2
2551 c        iap(ip)=iap(ip)-1
2552        elseif(r.gt.pssp.and.pvsp.gt.eps)then
2553         idp1pr(n,k)=2
2554         idp2pr(n,k)=1
2555         idsppr(n,k)=1
2556 c        ivp(ip)=ivp(ip)-1
2557        elseif(pssp.gt.eps)then
2558         idp1pr(n,k)=1
2559         idp2pr(n,k)=1
2560         idsppr(n,k)=0
2561        else
2562         goto1
2563        endif
2564
2565        else
2566         idp1pr(n,k)=1
2567         idp2pr(n,k)=1
2568         idsppr(n,k)=0
2569        endif
2570
2571 c    target
2572
2573        if(iabs(idfpr(n,k)).eq.1)then
2574
2575
2576        ntry=0
2577   2    ntry=ntry+1
2578        if(ntry.gt.10)call utstop('something goes wrong in sr ProSeTy&')
2579        pss=wgtsea
2580        pvs=wgtval      !   *ivt(it)
2581        psa=wgtval      !   *iat(it)
2582        pdd=wgtdiq
2583        psvv=wgtqqq(icltar)     !   *ivt(it)*(ivt(it)-1)/2.
2584        paas=wgtqqq(icltar)    !   *iat(it)*(iat(it)-1)/2.
2585        su=pss+pvs+psa+pdd+psvv+paas
2586        psst = pss /su
2587        pvst = pvs /su
2588        psat = psa /su
2589        pddt = pdd /su
2590        psvvt= psvv/su
2591        paast= paas/su
2592        r=rangen()
2593        if(r.gt.(psst+pvst+psat+pddt+psvvt).and.paast.gt.eps)then
2594         idm1pr(n,k)=5
2595         idm2pr(n,k)=1
2596         idstpr(n,k)=6
2597 c        iat(it)=iat(it)-2
2598        elseif(r.gt.(psst+pvst+psat+pddt).and.psvvt.gt.eps)then
2599         idm1pr(n,k)=1
2600         idm2pr(n,k)=5
2601         idstpr(n,k)=5
2602 c        ivt(it)=ivt(it)-2
2603        elseif(r.gt.(psst+pvst+psat).and.pddt.gt.eps)then
2604         idm1pr(n,k)=4
2605         idm2pr(n,k)=4
2606         idstpr(n,k)=4
2607        elseif(r.gt.(psst+pvst).and.psat.gt.eps)then
2608         idm1pr(n,k)=1
2609         idm2pr(n,k)=2
2610         idstpr(n,k)=2
2611 c        iat(it)=iat(it)-1
2612        elseif(r.gt.psst.and.pvst.gt.eps)then
2613         idm1pr(n,k)=2
2614         idm2pr(n,k)=1
2615         idstpr(n,k)=1
2616 c        ivt(it)=ivt(it)-1
2617        elseif(psst.gt.eps)then
2618         idm1pr(n,k)=1
2619         idm2pr(n,k)=1
2620         idstpr(n,k)=0
2621        else
2622         goto2
2623        endif
2624
2625        else
2626         idm1pr(n,k)=1
2627         idm2pr(n,k)=1
2628         idstpr(n,k)=0
2629        endif
2630
2631       elseif(idpr(n,k).eq.0)then
2632
2633         idp1pr(n,k)=0
2634         idm2pr(n,k)=0
2635         idp2pr(n,k)=0
2636         idm1pr(n,k)=0
2637
2638       endif
2639
2640         if(ish.ge.6)then
2641       write(ifch,'(a,2(6(f3.2,1x),2x),$)')'ProSeTy ',
2642      * pssp,pvsp,psap,pddp,psvvp,paasp, psst,pvst,psat,pddt,psvvt,paast
2643       write(ifch,'(2x,3i3,2x,2(i2,1x,2i2,1x,2i2,2x))')idpr(n,k),n,k
2644      * ,idsppr(n,k),idp1pr(n,k),idp2pr(n,k),ivp(ip),iap(ip)
2645      * ,idstpr(n,k),idm1pr(n,k),idm2pr(n,k),ivt(it),iat(it)
2646         endif
2647
2648       return
2649       end
2650
2651 c-----------------------------------------------------------------------
2652       subroutine ProSeF(k,n,iret)
2653 c-----------------------------------------------------------------------
2654 c starting from string properties as already determined in EMS,
2655 c one determines string end flavors
2656 c by checking compatibility with remnant masses.
2657 c strings are written to /cems/ and then to /cptl/
2658 c remnant ic is updated (icproj,ictarg)
2659 c------------------------------------------------------------------------
2660
2661       include 'epos.inc'
2662       include 'epos.incems'
2663
2664       double precision plc,s,pstg,pend
2665       common/cems5/plc,s
2666       common/cems/pstg(5,2),pend(4,4),idend(4)
2667       common/emsptl/nppr(npommx,kollmx),npproj(mamx),nptarg(mamx)
2668       integer icp(2),ict(2),ic(2),icp1(2),icp2(2),icm1(2),icm2(2)
2669       integer icini(2)
2670       integer jcp1(nflav,2),jcp2(nflav,2),jcm1(nflav,2),jcm2(nflav,2)
2671       common/col3/ncol,kolpt /cfacmss/facmss /cts/its
2672
2673       call utpri('ProSeF',ish,ishini,6)
2674
2675 c     entry
2676 c     -----
2677
2678       iret=0
2679
2680       if(ncol.eq.0)return
2681       if(itpr(k).ne.1)return
2682
2683       ip=iproj(k)
2684       it=itarg(k)
2685
2686       if(idpr(n,k).eq.0.or.ivpr(n,k).eq.0)return
2687       if(idpr(n,k).eq.2)stop'Reggeon'
2688       if(idpr(n,k).eq.3)goto 1000
2689       if(ish.ge.5)then
2690           write(ifch,*)'soft Pomeron'
2691           write(ifch,*)'k:',k,'  n:',n,'  ip:',ip,'  it:',it
2692       endif
2693       np=nppr(n,k)
2694
2695 c         string ends
2696
2697           pend(1,1)=xxp1pr(n,k)
2698           pend(2,1)=xyp1pr(n,k)
2699           pend(3,1)=xp1pr(n,k)*plc/2d0
2700           pend(4,1)=dsqrt(pend(1,1)**2+pend(2,1)**2+pend(3,1)**2)
2701           pend(1,2)=xxp2pr(n,k)
2702           pend(2,2)=xyp2pr(n,k)
2703           pend(3,2)=xp2pr(n,k)*plc/2d0
2704           pend(4,2)=dsqrt(pend(1,2)**2+pend(2,2)**2+pend(3,2)**2)
2705           pend(1,4)=xxm1pr(n,k)
2706           pend(2,4)=xym1pr(n,k)
2707           pend(3,4)=-xm1pr(n,k)*plc/2d0
2708           pend(4,4)=dsqrt(pend(1,4)**2+pend(2,4)**2+pend(3,4)**2)
2709           pend(1,3)=xxm2pr(n,k)
2710           pend(2,3)=xym2pr(n,k)
2711           pend(3,3)=-xm2pr(n,k)*plc/2d0
2712           pend(4,3)=dsqrt(pend(1,3)**2+pend(2,3)**2+pend(3,3)**2)
2713
2714 c         strings
2715
2716           pstg(1,1)=xxp1pr(n,k)+xxm2pr(n,k)
2717           pstg(2,1)=xyp1pr(n,k)+xym2pr(n,k)
2718           pstg(3,1)=(xp1pr(n,k)-xm2pr(n,k))*plc/2d0
2719           pstg(4,1)=(xp1pr(n,k)+xm2pr(n,k))*plc/2d0
2720           pstg(5,1)=dsqrt((pstg(4,1)-pstg(3,1))*(pstg(4,1)+pstg(3,1))
2721      &                   -pstg(1,1)**2-pstg(2,1)**2)
2722           pstg(1,2)=xxp2pr(n,k)+xxm1pr(n,k)
2723           pstg(2,2)=xyp2pr(n,k)+xym1pr(n,k)
2724           pstg(3,2)=(xp2pr(n,k)-xm1pr(n,k))*plc/2d0
2725           pstg(4,2)=(xp2pr(n,k)+xm1pr(n,k))*plc/2d0
2726           pstg(5,2)=dsqrt((pstg(4,2)-pstg(3,2))*(pstg(4,2)+pstg(3,2))
2727      &                   -pstg(2,2)**2-pstg(1,2)**2)
2728
2729 c         initialize
2730
2731           ntry=0
2732   777     ntry=ntry+1
2733           if(ntry.gt.100)goto1001
2734
2735           do i=1,2
2736            icp(i)=icproj(i,ip)
2737            ict(i)=ictarg(i,it)
2738            icp1(i)=0
2739            icp2(i)=0
2740            icm1(i)=0
2741            icm2(i)=0
2742            do j=1,nflav
2743             jcp1(j,i)=0
2744             jcp2(j,i)=0
2745             jcm1(j,i)=0
2746             jcm2(j,i)=0
2747            enddo
2748           enddo
2749           idpj0=idtr2(icp)
2750           idtg0=idtr2(ict)
2751           do j=1,4
2752            idend(j)=0
2753           enddo
2754
2755           if(ish.ge.5)write(ifch,'(a,3x,2i7,i9)')' proj: '
2756      *     ,(icp(l),l=1,2),idpj0
2757           if(ish.ge.5)write(ifch,'(a,3x,2i7,i9)')' targ: '
2758      *    ,(ict(l),l=1,2),idtg0
2759
2760 c         determine string flavors
2761
2762           call fstrfl(icp,ict,icp1,icp2,icm1,icm2
2763      *               ,idp1pr(n,k),idp2pr(n,k),idm1pr(n,k),idm2pr(n,k)
2764      *               ,iabs(idfpr(n,k)),iret)
2765           if(iret.ne.0)then
2766             jerr(1)=jerr(1)+1  ! > 9 quarks per flavor attempted.
2767                                !    OK when happens rarely.
2768             goto 1001
2769           endif
2770
2771 c         check mass string 1
2772
2773           ic(1)=icp1(1)+icm2(1)
2774           ic(2)=icp1(2)+icm2(2)
2775           if(ic(1).gt.0.or.ic(2).gt.0)then
2776            am=sngl(pstg(5,1))
2777            call iddeco(icp1,jcp1)
2778            call iddeco(icm2,jcm2)
2779            ammns=utamnx(jcp1,jcm2)
2780            if(ish.ge.7)write(ifch,'(a,2i7,2e12.3)')
2781      *           ' string 1 - ic,mass,min.mass:',ic,am,ammns
2782            if(am.lt.ammns*facmss)then
2783              goto 777   !avoid virpom
2784            endif
2785            idend(1)=idtra(icp1,0,0,3)
2786            idend(3)=idtra(icm2,0,0,3)
2787            if(ish.ge.7)write(ifch,'(a,2i4)') ' string 1 - SE-ids:'
2788      *      ,idend(1),idend(3)
2789           endif
2790
2791 c         check mass string 2
2792
2793           ic(1)=icp2(1)+icm1(1)
2794           ic(2)=icp2(2)+icm1(2)
2795           if(ic(1).gt.0.or.ic(2).gt.0)then
2796            am=sngl(pstg(5,2))
2797            call iddeco(icp2,jcp2)
2798            call iddeco(icm1,jcm1)
2799            ammns=utamnx(jcp2,jcm1)
2800            if(ish.ge.7)write(ifch,'(a,2i7,2e12.3)')
2801      *           ' string 2 - ic,mass,min.mass:',ic,am,ammns
2802            if(am.lt.ammns*facmss)then
2803              goto 777  !avoid virpom
2804            endif
2805            idend(2)=idtra(icp2,0,0,3)
2806            idend(4)=idtra(icm1,0,0,3)
2807            if(ish.ge.7)write(ifch,'(a,2i4)') ' string 2 - SE-ids:'
2808      *      ,idend(2),idend(4)
2809           endif
2810
2811           if(ish.ge.5)then
2812           write(ifch,'(a,i10)')' pom:   '
2813      *    ,idptl(np)
2814           write(ifch,'(a,2i5)')' str 1: '
2815      *    ,idend(1),idend(3)
2816           write(ifch,'(a,2i5)')' str 2: '
2817      *    ,idend(2),idend(4)
2818           write(ifch,'(a,2i7,1x,a)')' proj:  '
2819      *    ,(icp(l),l=1,2)
2820           write(ifch,'(a,2i7,1x,a)')' targ:  '
2821      *    ,(ict(l),l=1,2)
2822           endif
2823
2824 c         update remnant ic
2825
2826           do i=1,2
2827            icproj(i,ip)=icp(i)
2828            ictarg(i,it)=ict(i)
2829           enddo
2830
2831           call idtr4(idptl(ip),icini)   !excited remnant ?
2832           if(ish.ge.5)write(ifch,*)'icini proj',icini
2833      &    ,(icp(1)-icini(1)),(icp(2)-icini(2))
2834           if((icp(1)-icini(1))+(icp(2)-icini(2)).ne.0)iep(ip)=1
2835           call idtr4(idptl(maproj+it),icini)
2836           if(ish.ge.5)write(ifch,*)'icini targ',icini
2837      &    ,(ict(1)-icini(1)),(ict(2)-icini(2))
2838           if((ict(1)-icini(1))+(ict(2)-icini(2)).ne.0)iet(it)=1
2839           if(ish.ge.5)write(ifch,*)'iep,iet ',iep(ip),iet(it)
2840
2841 c         write strings to /cptl/
2842
2843           its=idp1pr(n,k)+idm2pr(n,k)
2844           call fstrwr(1,1,3,k,n)
2845           its=idp2pr(n,k)+idm1pr(n,k)
2846           call fstrwr(2,2,4,k,n)
2847
2848 c     exit
2849 c     ----
2850
2851 1000  continue
2852       call utprix('ProSeF',ish,ishini,6)
2853       return
2854
2855 1001  iret=1
2856       goto1000
2857
2858       end
2859
2860 c-----------------------------------------------------------------------
2861       subroutine fstrfl(icp,ict,icp1,icp2,icm1,icm2
2862      *                         ,idp1,idp2,idm1,idm2,idfp,iret)
2863 c-----------------------------------------------------------------------
2864 c knowing the string end types (idp1,idp2,idm1,idm2)
2865 c               and remnant flavors (icp,ict)
2866 c               and remnant link of the string (idfp)
2867 c one determines quark flavors of string ends (icp1,icp2,icm1,icm2)
2868 c               and updates remnant flavors (icp,ict)
2869 c iret=0   ok
2870 c iret=1   problem, more than 9 quarks per flavor attempted
2871 c-----------------------------------------------------------------------
2872       include 'epos.inc'
2873       integer icp(2),ict(2),icp1(2),icp2(2),icm1(2),icm2(2)
2874       integer jcp(6,2),jct(6,2),jcpi(6,2),jcti(6,2)
2875       integer iq(2,4)
2876 c      data neuz/0/proz/0/dtaz/0/
2877 c      save neuz,proz,dtaz
2878
2879       call utpri('fstrfl',ish,ishini,7)
2880
2881 c     entry
2882 c     -----
2883
2884       iret=0
2885       iret1=0
2886       iret2=0
2887       iret3=0
2888       iret4=0
2889
2890       if(idfp.eq.2)stop'fstrfl: should not happen (2).      '
2891       if(idfp.eq.3)stop'fstrfl: should not happen (3).      '
2892       if(idp1.eq.4)stop'fstrfl: diq code 4 not used any more'
2893       if(idm1.eq.4)stop'fstrfl: diq code 4 not used any more'
2894       if(idp2.eq.4)stop'fstrfl: diq code 4 not used any more'
2895       if(idm2.eq.4)stop'fstrfl: diq code 4 not used any more'
2896       if(idp1.eq.8)stop'fstrfl: fragm quarks not used any more'
2897       if(idp2.eq.8)stop'fstrfl: fragm quarks not used any more'
2898       if(idm1.eq.8)stop'fstrfl: fragm quarks not used any more'
2899       if(idm2.eq.8)stop'fstrfl: fragm quarks not used any more'
2900
2901 c determine flavors of string ends (u,d,s)
2902
2903       call iddeco(icp,jcpi)
2904       call iddeco(ict,jcti)
2905       call iddeco(icp,jcp)
2906       call iddeco(ict,jct)
2907       if(ish.ge.7)then
2908        write(ifch,'(a,2i7,5x,6i2,3x,6i2,3x,i1)')' proj:',icp,jcp
2909        write(ifch,'(a,2i7,5x,6i2,3x,6i2,3x,i1)')' targ:',ict,jct
2910       endif
2911
2912 c empty
2913
2914       if(idp1.eq.0)then
2915        iq(1,1)=0
2916        iq(2,1)=0
2917       endif
2918       if(idp2.eq.0)then
2919        iq(1,2)=0
2920        iq(2,2)=0
2921       endif
2922       if(idm1.eq.0)then
2923        iq(1,4)=0
2924        iq(2,4)=0
2925       endif
2926       if(idm2.eq.0)then
2927        iq(1,3)=0
2928        iq(2,3)=0
2929       endif
2930
2931 c valence quarks
2932
2933       if(idp1.eq.2)then
2934        iq(1,1)=idrafl(iclpro,jcp,1,'s',iret)
2935        iq(2,1)=0
2936       endif
2937       if(idp2.eq.2)then
2938        iq(1,2)=idrafl(iclpro,jcp,2,'s',iret)
2939        iq(2,2)=0
2940       endif
2941       if(idm1.eq.2)then
2942        iq(1,4)=idrafl(icltar,jct,1,'s',iret)
2943        iq(2,4)=0
2944       endif
2945       if(idm2.eq.2)then
2946        iq(1,3)=idrafl(icltar,jct,2,'s',iret)
2947        iq(2,3)=0
2948       endif
2949
2950 c sea quarks
2951
2952       if(idp1.eq.1)then
2953        iq(1,1)=idrafl(iclpro,jcp,1,'s',iret1)
2954        iq(2,1)=0
2955       endif
2956       if(idm1.eq.1)then
2957        iq(1,4)=idrafl(icltar,jct,1,'s',iret4)
2958        iq(2,4)=0
2959       endif
2960       if(idp2.eq.1)then
2961        iq(1,2)=idrafl(iclpro,jcp,2,'s',iret2)
2962        iq(2,2)=0
2963       endif
2964       if(idm2.eq.1)then
2965        iq(1,3)=idrafl(icltar,jct,2,'s',iret3)
2966        iq(2,3)=0
2967       endif
2968
2969 c diquarks, code 5 (former valence, but actually sea)
2970
2971       if(idp1.eq.5)then
2972 c       fc=puds
2973 c       iq(1,1)=idraflx(fc,iclpro,jcp,2,'s',iret)
2974 c       if(iq(1,1).eq.3)fc=fc*puds
2975 c       iq(2,1)=idraflx(fc,iclpro,jcp,2,'s',iret)
2976        iq(1,1)=idrafl(iclpro,jcp,2,'d',iret)
2977        iq(2,1)=idrafl(iclpro,jcp,2,'d',iret)
2978       endif
2979       if(idm1.eq.5)then
2980 c       fc=puds
2981 c       iq(1,4)=idraflx(fc,icltar,jct,2,'s',iret)
2982 c       if(iq(1,4).eq.3)fc=fc*puds
2983 c       iq(2,4)=idraflx(fc,icltar,jct,2,'s',iret)
2984        iq(1,4)=idrafl(icltar,jct,2,'d',iret)
2985        iq(2,4)=idrafl(icltar,jct,2,'d',iret)
2986       endif
2987       if(idp2.eq.5)then
2988 c       fc=puds
2989 c       iq(1,2)=idraflx(fc,iclpro,jcp,1,'s',iret)
2990 c       if(iq(1,2).eq.3)fc=fc*puds
2991 c       iq(2,2)=idraflx(fc,iclpro,jcp,1,'s',iret)
2992        iq(1,2)=idrafl(iclpro,jcp,1,'d',iret)
2993        iq(2,2)=idrafl(iclpro,jcp,1,'d',iret)
2994       endif
2995       if(idm2.eq.5)then
2996 c       fc=puds
2997 c       iq(1,3)=idraflx(fc,icltar,jct,1,'s',iret)
2998 c       if(iq(1,3).eq.3)fc=fc*puds
2999 c       iq(2,3)=idraflx(fc,icltar,jct,1,'s',iret)
3000        iq(1,3)=idrafl(icltar,jct,1,'d',iret)
3001        iq(2,3)=idrafl(icltar,jct,1,'d',iret)
3002       endif
3003
3004       if(iret.ne.0)goto 1000
3005
3006
3007 c in case of saturated remnants, use the same flavor for quark and anti-quark
3008 c at string-end
3009       if(iret1.ne.0.and.iret2.ne.0)then
3010         call iddeco(icp,jcp)
3011         if(rangen().gt.0.5)then
3012           iq(1,2)=iq(1,1)
3013         else
3014           iq(1,1)=iq(1,2)
3015         endif
3016       elseif(iret1.eq.0.and.iret2.ne.0.and.idp1.eq.1)then
3017         call iddeco(icp,jcp)
3018         iq(1,2)=iq(1,1)
3019         if(idp1.eq.4)iq(2,1)=iq(1,1)
3020 c        if(idp2.eq.4)iq(2,2)=iq(1,2)
3021       elseif(iret2.eq.0.and.iret1.ne.0.and.idp2.eq.1)then
3022         call iddeco(icp,jcp)
3023         iq(1,1)=iq(1,2)
3024         if(idp1.eq.4)iq(2,1)=iq(1,1)
3025 c        if(idp2.eq.4)iq(2,2)=iq(1,2)
3026       elseif(iret1.ne.0.or.iret2.ne.0)then
3027         iret=1
3028         goto 1000
3029       endif
3030
3031       if(iret3.ne.0.and.iret4.ne.0)then
3032         call iddeco(ict,jct)
3033         if(rangen().gt.0.5)then
3034           iq(1,4)=iq(1,3)
3035         else
3036           iq(1,3)=iq(1,4)
3037         endif
3038       elseif(iret3.eq.0.and.iret4.ne.0.and.idm1.eq.1)then
3039         call iddeco(ict,jct)
3040         iq(1,4)=iq(1,3)
3041 c        if(idm2.eq.4)iq(2,3)=iq(1,3)
3042         if(idm1.eq.4)iq(2,4)=iq(1,4)
3043       elseif(iret4.eq.0.and.iret3.ne.0.and.idm2.eq.1)then
3044         call iddeco(ict,jct)
3045         iq(1,3)=iq(1,4)
3046 c        if(idm2.eq.4)iq(2,3)=iq(1,3)
3047         if(idm1.eq.4)iq(2,4)=iq(1,4)
3048       elseif(iret3.ne.0.or.iret4.ne.0)then
3049         iret=1
3050         goto 1000
3051       endif
3052
3053
3054 c determine icp,ict
3055
3056       call idenco(jcp,icp,iret)
3057       if(iret.ne.0)goto 1000
3058       call idenco(jct,ict,iret)
3059       if(iret.ne.0)goto 1000
3060
3061       ifla=iq(1,1)
3062       iflb=iq(2,1)
3063       iflc=iq(1,3)
3064       ifld=iq(2,3)
3065       if(ish.ge.7)write(ifch,'(a,2i3,4x,2i3)')
3066      *' string 1, string ends:',ifla,iflb,iflc,ifld
3067
3068       if(ifla.gt.0)then
3069        if(iflb.eq.0)then
3070         icp1(1)=10**(6-ifla)
3071         icp1(2)=0
3072        else
3073         icp1(1)=0
3074         icp1(2)=10**(6-ifla)
3075         icp1(2)=icp1(2)+10**(6-iflb)
3076        endif
3077       endif
3078
3079       if(iflc.gt.0)then
3080        if(ifld.eq.0)then
3081         icm2(1)=0
3082         icm2(2)=10**(6-iflc)
3083        else
3084         icm2(1)=10**(6-iflc)
3085         icm2(1)=icm2(1)+10**(6-ifld)
3086         icm2(2)=0
3087        endif
3088       endif
3089
3090       ifla=iq(1,4)
3091       iflb=iq(2,4)
3092       iflc=iq(1,2)
3093       ifld=iq(2,2)
3094       if(ish.ge.7)write(ifch,'(a,2i3,4x,2i3)')
3095      *' string 2, string ends:',ifla,iflb,iflc,ifld
3096
3097       if(ifla.gt.0)then
3098        if(iflb.eq.0)then
3099         icm1(1)=10**(6-ifla)
3100         icm1(2)=0
3101        else
3102         icm1(1)=0
3103         icm1(2)=10**(6-ifla)
3104         icm1(2)=icm1(2)+10**(6-iflb)
3105        endif
3106       endif
3107
3108       if(iflc.gt.0)then
3109        if(ifld.eq.0)then
3110         icp2(1)=0
3111         icp2(2)=10**(6-iflc)
3112        else
3113         icp2(1)=10**(6-iflc)
3114         icp2(1)=icp2(1)+10**(6-ifld)
3115         icp2(2)=0
3116        endif
3117       endif
3118
3119       if(ish.ge.7)then
3120         write(ifch,'(a,2i7,4x,2i7)')
3121      *  ' SE-forw:',icp1(1),icp1(2),icp2(1),icp2(2)
3122         write(ifch,'(a,2i7,4x,2i7)')
3123      *  ' SE-back:',icm1(1),icm1(2),icm2(1),icm2(2)
3124         write(ifch,'(a,2i7,5x,6i2,3x,6i2)')' proj:',icp,jcp
3125         write(ifch,'(a,2i7,5x,6i2,3x,6i2)')' targ:',ict,jct
3126       endif
3127
3128 c     exit
3129 c     ----
3130
3131 1000  continue
3132       call utprix('fstrfl',ish,ishini,7)
3133       return
3134       end
3135
3136 c-----------------------------------------------------------------------
3137       integer function jdrafl(icl,jc,mod,iret)
3138 c-----------------------------------------------------------------------
3139 c mod=1
3140 c returns random flavor of a quark
3141 c
3142 c mod=2
3143 c jc : quark content of remnant
3144 c returns random flavor and  update remant with corresponding q-qbar pair \
3145 c if there is  enough place (else iret=1)
3146 c
3147 c     id=1 u, id=2 d, id=3 s
3148 c-----------------------------------------------------------------------
3149       include 'epos.inc'
3150       integer jc(nflav,2)
3151
3152 c        write(*,*)'entry jdrafl, j,c,jc: ',j,c,jc
3153
3154        pu=rstrau(icl)
3155        pd=rstrad(icl)
3156        ps=rstras(icl)
3157
3158        s=pu+pd+ps
3159        if(s.gt.0.)then
3160          r=rangen()*s
3161          if(r.gt.(pu+pd).and.ps.gt.1d-10)then
3162            i=3
3163          elseif(r.gt.pu.and.pd.gt.1d-10)then
3164            i=2
3165          else
3166            i=1
3167          endif
3168        else
3169          i=1+int((2.+rstras(icl))*rangen())
3170        endif
3171        jdrafl=i
3172
3173 c      write(*,*)'jc before updating',jc
3174 c      write(*,*)'i,j,jc',i,j,jc
3175
3176        if(mod.eq.2)then
3177          call idsufl2(i,1,jc,iret)
3178          call idsufl2(i,2,jc,iret)
3179        endif
3180
3181       return
3182       end
3183
3184
3185 cc-----------------------------------------------------------------------
3186 c      subroutine fremfl(icp,ict,iret)
3187 cc-----------------------------------------------------------------------
3188 cc checks projectile and target flavor (icp,ict)
3189 cc in case of reggeon exchange they do not correspond to hadrons.
3190 cc one transfers therefore flavor from one side to the other in order
3191 cc to have hadron flavor.
3192 cc icp and ict are modified correspondingly
3193 cc-----------------------------------------------------------------------
3194 c      include 'epos.inc'
3195 c      integer icp(2),ict(2),jcp(6,2),jct(6,2),kp(4),kt(4)
3196 c
3197 c      call utpri('fremfl',ish,ishini,7)
3198 c
3199 cc     entry
3200 cc     -----
3201 c
3202 c      iret=0
3203 c
3204 c      call iddeco(icp,jcp)
3205 c      call iddeco(ict,jct)
3206 c
3207 c      iakp=0
3208 c      iakt=0
3209 c      ikp=0
3210 c      ikt=0
3211 c      do l=1,4
3212 c       kp(l)=jcp(l,1)-jcp(l,2)
3213 c       kt(l)=jct(l,1)-jct(l,2)
3214 c       iakp=iakp+iabs(kp(l))
3215 c       iakt=iakt+iabs(kt(l))
3216 c       ikp=ikp+kp(l)
3217 c       ikt=ikt+kt(l)
3218 c      enddo
3219 c      if(ish.ge.7)write(ifch,*)'iak_p:',iakp,' ik_p:',ikp
3220 c      if(ish.ge.7)write(ifch,*)'iak_t:',iakt,' ik_t:',ikt
3221 c
3222 c      if(iakp.eq.4)then
3223 c       if(ikp.eq.4.or.ikp.eq.-2)then
3224 c        ifl=idrafl(jcp,1,'v',iret)
3225 c        iqp=2      ! subtract quark
3226 c        iqt=1      ! add quark
3227 c       elseif(ikp.eq.-4.or.ikp.eq.2)then
3228 c        ifl=idrafl(jcp,2,'v',iret)
3229 c        iqp=1      ! subtract antiquark
3230 c        iqt=2      ! add antiquark
3231 c       else
3232 c        call utstop('fremfl&')
3233 c       endif
3234 c      elseif(iakt.eq.4)then
3235 c       if(ikt.eq.4.or.ikt.eq.-2)then
3236 c        ifl=idrafl(jct,1,'v',iret)
3237 c        iqp=1      ! add quark
3238 c        iqt=2      ! subtract quark
3239 c       elseif(ikt.eq.-4.or.ikt.eq.2)then
3240 c        ifl=idrafl(jct,2,'v',iret)
3241 c        iqp=2      ! add antiquark
3242 c        iqt=1      ! subtract antiquark
3243 c       else
3244 c        call utstop('fremfl&')
3245 c       endif
3246 c      elseif(iakp.eq.3)then
3247 c       if(ikp.gt.0)then
3248 c        ifl=idrafl(jcp,1,'v',iret)
3249 c        iqp=2      ! subtract quark
3250 c        iqt=1      ! add quark
3251 c       else
3252 c        ifl=idrafl(jcp,2,'v',iret)
3253 c        iqp=1      ! subtract antiquark
3254 c        iqt=2      ! add antiquark
3255 c       endif
3256 c      elseif(iakt.eq.3)then
3257 c       if(ikt.gt.0)then
3258 c        ifl=idrafl(jct,1,'v',iret)
3259 c        iqp=1      ! add quark
3260 c        iqt=2      ! subtract quark
3261 c       else
3262 c        ifl=idrafl(jct,2,'v',iret)
3263 c        iqp=2      ! add antiquark
3264 c        iqt=1      ! subtract antiquark
3265 c       endif
3266 c      elseif(iakp.eq.2)then
3267 c       if(ikp.gt.0)then
3268 c        ifl=idrafl(jct,1,'v',iret)
3269 c        iqp=1      ! add quark
3270 c        iqt=2      ! subtract quark
3271 c       else
3272 c        ifl=idrafl(jct,2,'v',iret)
3273 c        iqp=2      ! add antiquark
3274 c        iqt=1      ! subtract antiquark
3275 c       endif
3276 c      elseif(iakt.eq.2)then
3277 c       if(ikt.gt.0)then
3278 c        ifl=idrafl(jct,1,'v',iret)
3279 c        iqp=2      ! subtract quark
3280 c        iqt=1      ! add quark
3281 c       else
3282 c        ifl=idrafl(jct,2,'v',iret)
3283 c        iqp=1      ! subtract antiquark
3284 c        iqt=2      ! add antiquark
3285 c       endif
3286 c      elseif(iakp.eq.1)then
3287 c       if(ikp.gt.0)then
3288 c        ifl=idrafl(jcp,2,'v',iret)
3289 c        iqp=2      ! add antiquark
3290 c        iqt=1      ! subtract antiquark
3291 c       else
3292 c        ifl=idrafl(jcp,1,'v',iret)
3293 c        iqp=1      ! add quark
3294 c        iqt=2      ! subtract quark
3295 c       endif
3296 c      elseif(iakt.eq.1)then
3297 c       if(ikt.gt.0)then
3298 c        ifl=idrafl(jct,2,'v',iret)
3299 c        iqp=1      ! subtract antiquark
3300 c        iqt=2      ! add antiquark
3301 c       else
3302 c        ifl=idrafl(jct,1,'v',iret)
3303 c        iqp=2      ! subtract quark
3304 c        iqt=1      ! add quark
3305 c       endif
3306 c      else
3307 c       call utstop('fremfl: error&')
3308 c      endif
3309 c
3310 c      if(ish.ge.7)write(ifch,*)'iq_p:',iqp,' iq_t:',iqt,' if:',ifl
3311 c      call uticpl(icp,ifl,iqp,iret)
3312 c      if(iret.ne.0)goto1000
3313 c      call uticpl(ict,ifl,iqt,iret)
3314 c      if(iret.ne.0)goto1000
3315 c
3316 cc     exit
3317 cc     ----
3318 c
3319 c1000  continue
3320 c      call utprix('fremfl',ish,ishini,7)
3321 c      return
3322 c      end
3323 c
3324 c-----------------------------------------------------------------------
3325       subroutine fstrwr(j,ii,jj,k,n)
3326 c-----------------------------------------------------------------------
3327 c take pstg(5,j),pend(4,ii),idend(ii),pend(4,jj),idend(jj)  (/cems/)
3328 c and write it to /cptl/
3329 c-----------------------------------------------------------------------
3330 c  j:     string 1 or 2
3331 c  ii,jj: string end (1,2: proj; 3,4: targ)
3332 c  k:     current collision
3333 c  n:     current pomeron
3334 c-----------------------------------------------------------------------
3335
3336       include 'epos.inc'
3337       include 'epos.incems'
3338
3339       double precision pstg,pend
3340       common/cems/pstg(5,2),pend(4,4),idend(4)
3341       common/emsptl/nppr(npommx,kollmx),npproj(mamx),nptarg(mamx)
3342       double precision  pp(4)
3343       common/cts/its
3344
3345       call utpri('fstrwr',ish,ishini,7)
3346
3347       if(idend(ii).ne.0.and.idend(jj).ne.0)then
3348
3349 c string
3350
3351        call utlob2(1,pstg(1,j),pstg(2,j),pstg(3,j),pstg(4,j),pstg(5,j)
3352      * ,pend(1,ii),pend(2,ii),pend(3,ii),pend(4,ii),20)
3353        pp(1)=0d0
3354        pp(2)=0d0
3355        pp(3)=.5d0*pstg(5,j)
3356        pp(4)=.5d0*pstg(5,j)
3357        call utrot2
3358      * (-1,pend(1,ii),pend(2,ii),pend(3,ii),pp(1),pp(2),pp(3))
3359        call utlob2(-1,pstg(1,j),pstg(2,j),pstg(3,j),pstg(4,j),pstg(5,j)
3360      * ,pp(1),pp(2),pp(3),pp(4),21)
3361
3362        npom=nppr(n,k)
3363        if(ifrptl(1,npom).eq.0)ifrptl(1,npom)=nptl+1
3364        ifrptl(2,npom)=nptl+2
3365        istptl(npom)=31
3366
3367        nptl=nptl+1
3368        pptl(1,nptl)=sngl(pp(1))
3369        pptl(2,nptl)=sngl(pp(2))
3370        pptl(3,nptl)=sngl(pp(3))
3371        pptl(4,nptl)=sngl(pp(4))
3372        pptl(5,nptl)=0.
3373        istptl(nptl)=20
3374        iorptl(nptl)=npom
3375        jorptl(nptl)=0
3376        ifrptl(1,nptl)=0
3377        ifrptl(2,nptl)=0
3378        xorptl(1,nptl)=coord(1,k)
3379        xorptl(2,nptl)=coord(2,k)
3380        xorptl(3,nptl)=coord(3,k)
3381        xorptl(4,nptl)=coord(4,k)
3382        tivptl(1,nptl)=xorptl(4,nptl)
3383        tivptl(2,nptl)=xorptl(4,nptl)
3384        idptl(nptl)=idend(ii)
3385        ityptl(nptl)=ityptl(npom)+j
3386        itsptl(nptl)=its
3387        rinptl(nptl)=-9999
3388        qsqptl(nptl)=0.
3389        zpaptl(nptl)=0.
3390
3391        nptl=nptl+1
3392        do i=1,4
3393         pptl(i,nptl)=sngl(pstg(i,j))-pptl(i,nptl-1)
3394        enddo
3395        pptl(5,nptl)=0.
3396
3397        istptl(nptl)=20
3398        iorptl(nptl)=nppr(n,k)
3399        jorptl(nptl)=0
3400        ifrptl(1,nptl)=0
3401        ifrptl(2,nptl)=0
3402        xorptl(1,nptl)=coord(1,k)
3403        xorptl(2,nptl)=coord(2,k)
3404        xorptl(3,nptl)=coord(3,k)
3405        xorptl(4,nptl)=coord(4,k)
3406        tivptl(1,nptl)=xorptl(4,nptl)
3407        tivptl(2,nptl)=xorptl(4,nptl)
3408        idptl(nptl)=idend(jj)
3409        ityptl(nptl)=ityptl(npom)+j
3410        itsptl(nptl)=its
3411        rinptl(nptl)=-9999
3412        qsqptl(nptl)=0.
3413        zpaptl(nptl)=0.
3414
3415        if(ish.ge.7)then
3416         write(ifch,100)' kink:',(pptl(l,nptl-1),l=1,4),idptl(nptl-1)
3417         write(ifch,100)' kink:',(pptl(l,nptl),l=1,4),idptl(nptl)
3418        endif
3419
3420       elseif(idend(ii).ne.0.and.idend(jj).eq.0)then
3421
3422 c resonance
3423
3424        npom=nppr(n,k)
3425        if(ifrptl(1,npom).eq.0)ifrptl(1,npom)=nptl+1
3426        ifrptl(2,npom)=nptl+1
3427        istptl(npom)=31
3428
3429        nptl=nptl+1
3430        idptl(nptl)=idend(ii)
3431        pptl(1,nptl)=sngl(pstg(1,j))
3432        pptl(2,nptl)=sngl(pstg(2,j))
3433        pptl(3,nptl)=sngl(pstg(3,j))
3434        pptl(4,nptl)=sngl(pstg(4,j))
3435        pptl(5,nptl)=sngl(pstg(5,j))
3436        istptl(nptl)=0
3437        iorptl(nptl)=npom
3438        jorptl(nptl)=0
3439        ifrptl(1,nptl)=0
3440        ifrptl(2,nptl)=0
3441        xorptl(1,nptl)=coord(1,k)
3442        xorptl(2,nptl)=coord(2,k)
3443        xorptl(3,nptl)=coord(3,k)
3444        xorptl(4,nptl)=coord(4,k)
3445        tivptl(1,nptl)=coord(4,k)
3446        call idtau(idptl(nptl),pptl(4,nptl),pptl(5,nptl),taugm)
3447        tivptl(2,nptl)=tivptl(1,nptl)+taugm*(-alog(rangen()))
3448        ityptl(nptl)=ityptl(npom)+2+j
3449        itsptl(nptl)=its
3450        rinptl(nptl)=-9999
3451        qsqptl(nptl)=0.
3452        zpaptl(nptl)=0.
3453
3454        if(ish.ge.7)then
3455         write(ifch,100)'  res:',(pptl(l,nptl),l=1,4),idptl(nptl)
3456        endif
3457       elseif(idend(ii).eq.0.and.idend(jj).eq.0)then
3458        goto1000
3459       else
3460        call utstop('error in fstrwr&')
3461       endif
3462
3463   100 format(a,4e9.3,i5)
3464
3465 1000  continue
3466       call utprix('fstrwr',ish,ishini,7)
3467       return
3468       end
3469
3470 c-----------------------------------------------------------------------
3471       subroutine ProReF(ir,m)
3472 c-----------------------------------------------------------------------
3473 c  proposes flavor for remnant m for proj (ir=1) or target (ir=-1)
3474 c  and writes remnant into /cptl/ as string or hadron
3475 c   ityptl definitions:
3476 c      51  41  ...  rmn drop
3477 c      52  42  ...  rmn str inel
3478 c      53  43  ...  rmn str diff
3479 c      54  44  ...  rmn str after droplet or hadron split
3480 c      55  45  ...  rmn res
3481 c      56  46  ...  rmn res after droplet or hadron split
3482 c      57  47  ...  rmn res after all Pomeron killed
3483 c      58  48  ...  rmn res from diff
3484 c      59  49  ...  hadron split
3485 c-----------------------------------------------------------------------
3486
3487       include 'epos.inc'
3488       include 'epos.incems'
3489
3490       double precision plc,s   !,ptt1,ptt2
3491       common/cems5/plc,s
3492       common/cdfptl/idfptl(mxptl)
3493       double precision tpro,zpro,ttar,ztar,ttaus,detap,detat,zor,tor
3494       common/cttaus/tpro,zpro,ttar,ztar,ttaus,detap,detat
3495       common /cncl/xproj(mamx),yproj(mamx),zproj(mamx)
3496      *            ,xtarg(mamx),ytarg(mamx),ztarg(mamx)
3497       double precision amasmin,amasini,mdrmax
3498       integer icf(2),icb(2)
3499       integer jcf(nflav,2),jcdummy(nflav,2)
3500       logical gdrop, ghadr,gproj,gtarg
3501       double precision ept(5),ep(4),aa(5),am2t
3502       common/emsptl/nppr(npommx,kollmx),npproj(mamx),nptarg(mamx)
3503       common /ems12/iodiba,bidiba  ! defaut iodiba=0. if iodiba=1, study H-Dibaryon
3504
3505       call utpri('ProReF',ish,ishini,3)
3506
3507       if(ir.ne.1.and.ir.ne.-1)stop'ProReF: wrong ir'
3508
3509       irmdropx=irmdrop
3510  55   idrop=0
3511       gdrop=.false.
3512       ghadr=.false.
3513       iret=0
3514       dens=0.15
3515
3516       if(ir.eq.1)then
3517 c        if(kolp(m).le.0)goto1000
3518         if(iep(m).le.-1)goto1000
3519         gproj=.true.
3520         gtarg=.false.
3521         mm=npproj(m)
3522         iept=iep(m)
3523         zz=zzremn(m,1)
3524         iclpt=iclpro
3525       elseif(ir.eq.-1)then
3526 c        if(kolt(m).le.0)goto1000
3527         if(iet(m).le.-1)goto1000
3528         gproj=.false.
3529         gtarg=.true.
3530         mm=nptarg(m)
3531         iept=iet(m)
3532         zz=zzremn(m,2)
3533         iclpt=icltar
3534       else
3535         call utstop('ProReF: ir ???&')
3536       endif
3537       if(ish.ge.3)write(ifch,*)'remnant particle index:',mm
3538
3539       if(ish.ge.8)call alist('ProRef&',1,nptl)
3540       antotre=antotre+1
3541
3542       mmini=mm
3543       nptlini=nptl
3544       minfra=min(minfra,nptlini)   !for trigger condition
3545
3546       do l=1,5
3547        ept(l)=dble(pptl(l,mm))
3548       enddo
3549
3550       ifrptl(1,mm)=0
3551       ifrptl(2,mm)=0
3552
3553 c  initialize forward and backward ic (to transform remnant into string)
3554
3555       if(gproj)then
3556         icf(1)=icproj(1,m)
3557         icf(2)=icproj(2,m)
3558       else                     !gtarg
3559         icf(1)=ictarg(1,m)
3560         icf(2)=ictarg(2,m)
3561       endif
3562       icb(1)=0
3563       icb(2)=0
3564
3565       call iddeco(icf,jcf)
3566       call idquacjc(jcf,nqu,naq)
3567
3568 c define masses
3569
3570       amasmin=dble(fremnux2(icf))**2.d0
3571       if(ept(5).le.0.)then
3572         ept(5)=sqrt(2*amasmin)
3573         if(ish.ge.1)then
3574           call utmsg('ProReF')
3575           write(ifch,*)'zero remnant mass -> amasmin'
3576           call utmsgf
3577         endif
3578       endif
3579       am2t=(ept(4)+ept(3))*(ept(4)-ept(3))-(ept(1)**2+ept(2)**2)
3580       if(ish.ge.1
3581      &   .and.(am2t.le.0d0.or.abs(am2t-ept(5)*ept(5)).gt.ept(5)))then
3582           write(ifch,*)'Precision problem in ProRef, p:',
3583      &             (ept(k),k=1,4),ept(5)*ept(5),am2t
3584       endif
3585       ept(4)=sqrt(ept(3)*ept(3)+ept(2)*ept(2)+ept(1)*ept(1)
3586      &           +ept(5)*ept(5))
3587
3588       if(ish.ge.3)then
3589         if(gproj)
3590      *      write(ifch,'(a,5e11.3,2i7)')' proj:'
3591      *      ,(sngl(ept(k)) ,k=1,5),(icproj(k,m) ,k=1,2)
3592         if(gtarg)
3593      *      write(ifch,'(a,5e11.3,2i7)')' targ:'
3594      *      ,(sngl(ept(k)) ,k=1,5),(ictarg(k,m),k=1,2)
3595       endif
3596
3597       amasini=ept(5)*ept(5)
3598
3599 c      mdrmax=amasmin+dble(amdrmax*amdrmax)
3600       mdrmax=dble(fremnux(icf)+amdrmax)**2.d0
3601
3602       if(ish.ge.4)write(ifch,*)'remnant masses:',am2t,amasini,amasmin
3603      &                                          ,mdrmax
3604
3605 c.............................exotic ...................................
3606
3607 c      if(amasini.gt.amasmin.and.irmdropx.eq.1)then
3608
3609 c      if((iept.eq.6.or.
3610 c     &   .not.((nqu.eq.3.and.naq.eq.0).or.(nqu.eq.0.and.naq.eq.3)
3611       if(.not.((nqu.eq.3.and.naq.eq.0).or.(nqu.eq.0.and.naq.eq.3)
3612      &           .or.(nqu.eq.1.and.naq.eq.1))
3613      &    .and.amasini.gt.amasmin.and.irmdropx.eq.1)then
3614
3615 c      if((
3616 c     &   .not.((nqu.eq.3.and.naq.eq.0).or.(nqu.eq.0.and.naq.eq.3)
3617 c     &           .or.(nqu.eq.1.and.naq.eq.1)).or.
3618 c     &   (iept.ne.0.and.iept.le.2.and.reminv/ept(5).gt.rangen()))
3619 c     &    .and.amasini.gt.amasmin.and.irmdropx.eq.1)then
3620
3621          !print*,'-------------------------------------------' !!!
3622          !print*,jcf
3623          !print*,icf,sqrt(amasini),sqrt(amasmin),sqrt(mdrmax)  !!!
3624          !print*,nqu,naq                                      !!!
3625         if(amasini.gt.mdrmax.or.(jcf(4,1)+jcf(4,2).ne.0))then         !charm not possible in droplet
3626           call getdroplet(ir,icf,jcf,ept,aa,gdrop,mdrmax)
3627           !--------------------------------
3628           !emit a droplet, update the remnant string flavour and 5-momentum
3629           ! input
3630           !     ir ......... 1  projectile, -1  target remnant
3631           !     ept ........ remnant  5-momentum
3632           !     jcf ........ remnant jc
3633           ! output
3634           !     gdrop ...  .true. = successful droplet emission
3635           !                          icf, ept ....... droplet  ic and 5-momentum
3636           !                          jcf, a ......... remnant string jc and 5-momentum
3637           !               .false. = unsuccessful
3638           !                          jcf, ept .... unchanged,
3639           !                          emits hadrons instead of droplet
3640 c          !                          considered as droplet jc and 5-momentum
3641           !-------------------------------------
3642           if(.not.gdrop)goto 500
3643         endif
3644
3645         !...........droplet
3646         !also in case of unsuccessful drop emission, then remnant = droplet !
3647         idrop=1
3648         nptl=nptl+1
3649         t=xorptl(4,mm)
3650         istptl(mm)=41
3651         ifrptl(1,mm)=nptl
3652         ifrptl(2,mm)=nptl
3653         tivptl(2,mm)=t
3654 c            Remnant radius to have eps=dens GeV/fm3
3655         radptl(nptl)=(3.*sngl(ept(5))/4./pi/dens)**0.3333
3656         dezptl(nptl)=0.
3657         do l=1,5
3658           pptl(l,nptl)=sngl(ept(l))
3659         enddo
3660         idx=idtra(icf,0,0,3)
3661         if(idx.ne.0)then
3662          amx=sngl(ept(5))
3663          call idres(idx,amx,idrx,iadjx,1)
3664          idx=idrx
3665         endif
3666         if(idx.eq.0)then
3667           istptl(nptl)=10
3668           idptl(nptl)=8*10**8+icf(1)*100+icf(2)/100
3669           if(gproj)then
3670             ityptl(nptl)=40
3671           else  !gtarg
3672             ityptl(nptl)=50
3673           endif
3674         else
3675           istptl(nptl)=0
3676           idptl(nptl)=idx
3677           pptl(5,nptl)=amx
3678           if(gproj)then
3679             ityptl(nptl)=45
3680             if(iept.eq.6)ityptl(nptl)=47
3681           else  !gtarg
3682             ityptl(nptl)=55
3683             if(iept.eq.6)ityptl(nptl)=57
3684           endif
3685         endif
3686         iorptl(nptl)=mm
3687         jorptl(nptl)=0
3688         ifrptl(1,nptl)=0
3689         ifrptl(2,nptl)=0
3690         xorptl(1,nptl)=xorptl(1,mm)
3691         xorptl(2,nptl)=xorptl(2,mm)
3692         xorptl(3,nptl)=xorptl(3,mm)
3693         xorptl(4,nptl)=t
3694         tivptl(1,nptl)=t
3695         call idtau(idptl(nptl),pptl(4,nptl),pptl(5,nptl),taugm)
3696         tivptl(2,nptl)=tivptl(1,nptl)+taugm*(-alog(rangen()))
3697         do l=1,4
3698           ibptl(l,nptl)=0
3699         enddo
3700         andropl=andropl+1
3701         if(ish.ge.3)write(ifch,*)'Proref,ept(5),id',ept(5),idptl(nptl)
3702         !print*,nptl,idptl(nptl),sngl(ept(5)),pptl(5,nptl)  !!!
3703
3704         !..........remnant update
3705         if(gdrop)then  !drop emission: new remnant -> ept, icf
3706           idrop=0
3707           do l=1,5
3708             ept(l)=aa(l)
3709           enddo
3710           call idquacjc(jcf,nqu,naq)
3711           call idenco(jcf,icf,iret)
3712           if(iret.eq.1)call utstop('Pb in ProRef in strg+drop process&')
3713           !!!  print*,'new remnant:',icf,ept(5)    !!!
3714           nptl=nptl+1
3715           t=xorptl(4,mm)
3716           ifrptl(2,mm)=nptl
3717           do l=1,5
3718             pptl(l,nptl)=sngl(ept(l))
3719           enddo
3720           idptl(nptl)=idptl(mm)
3721           istptl(nptl)=40
3722           iorptl(nptl)=mm
3723           jorptl(nptl)=0
3724           ifrptl(1,nptl)=0
3725           ifrptl(2,nptl)=0
3726           xorptl(1,nptl)=xorptl(1,mm)
3727           xorptl(2,nptl)=xorptl(2,mm)
3728           xorptl(3,nptl)=xorptl(3,mm)
3729           xorptl(4,nptl)=t
3730           tivptl(1,nptl)=t
3731           tivptl(2,nptl)=ainfin
3732           if(gproj)then
3733             ityptl(nptl)=40
3734           else   !gtarg
3735             ityptl(nptl)=50
3736           endif
3737           do l=1,4
3738             ibptl(l,nptl)=0
3739           enddo
3740         endif
3741
3742         !........decay mini-droplet......
3743         mm=nptlini+1
3744         nptlb=nptl
3745         if(iabs(idptl(mm)).gt.10**8)then
3746           if(ish.ge.3)write(ifch,*)'Make droplet'
3747           if(nptlb.gt.mxptl-10)call utstop('ProRef: mxptl too small&')
3748           iret=0
3749           if(ifrade.gt.0.and.ispherio.eq.0)call hnbaaa(mm,iret)!Decay remn
3750           if(iret.ne.1.and.nptl.ne.nptlb)then ! ---successful decay---
3751             istptl(mm)=istptl(mm)+1
3752             ifrptl(1,mm)=nptlb+1
3753             ifrptl(2,mm)=nptl
3754             t=tivptl(2,mm)
3755             x=xorptl(1,mm)+(t-xorptl(4,mm))*pptl(1,mm)/pptl(4,mm)
3756             y=xorptl(2,mm)+(t-xorptl(4,mm))*pptl(2,mm)/pptl(4,mm)
3757             z=xorptl(3,mm)+(t-xorptl(4,mm))*pptl(3,mm)/pptl(4,mm)
3758             do 21 n=nptlb+1,nptl
3759               iorptl(n)=mm
3760               jorptl(n)=0
3761               istptl(n)=0
3762               ifrptl(1,n)=0
3763               ifrptl(2,n)=0
3764               if(idfptl(mm).eq.0)then
3765                 idfptl(n)=0
3766               else
3767                 idfptl(n)=1
3768               endif
3769               radius=0.8*sqrt(rangen())
3770               phi=2*pi*rangen()
3771               ti=t
3772               zi=z
3773               xorptl(1,n)=x + radius*cos(phi)
3774               xorptl(2,n)=y + radius*sin(phi)
3775               xorptl(3,n)=zi
3776               xorptl(4,n)=ti
3777               iioo=mm
3778               zor=dble(xorptl(3,iioo))
3779               tor=dble(xorptl(4,iioo))
3780               call idquac(iioo,nq,ndummy1,ndummy2,jcdummy)
3781               r=rangen()
3782               tauran=-taurea*alog(r)
3783               call jtaix(n,tauran,zor,tor,zis,tis)
3784               tivptl(1,n)=amax1(ti,tis)
3785               call idtau(idptl(n),pptl(4,n),pptl(5,n),taugm)
3786               r=rangen()
3787               tivptl(2,n)=t+taugm*(-alog(r))
3788               if(gproj)then
3789                 ityptl(n)=41
3790                 if(iept.eq.6)ityptl(n)=47
3791               else  !gtarg
3792                 ityptl(n)=51
3793                 if(iept.eq.6)ityptl(n)=57
3794               endif
3795               radptl(n)=0.
3796               dezptl(n)=0.
3797               itsptl(n)=0
3798               rinptl(nptl)=-9999
3799    21       continue
3800             if(iabs(idptl(nptlb+1)).le.6) then
3801               call gakli2(0,0)
3802               if(ish.ge.1)write (ifmt,*)'string from drop:nptlb+1,nptl:'
3803      *                                 ,nptlb+1,nptl
3804               istptl(nptlb+1)=1
3805               do n=nptlb+2,nptl
3806                 istptl(n)=20
3807                 zpaptl(n)=0.
3808               enddo
3809               call gakfra(iret)
3810               call gakli2(0,0)
3811             endif
3812             jerr(4)=jerr(4)+1
3813           elseif(ifrade.gt.0.and.ispherio.eq.0)then ! Unsuccessful decay
3814             jerr(5)=jerr(5)+1
3815             if(ish.ge.4)write(ifch,*)
3816      *         '***** Unsuccessful remnant cluster decay'
3817      *             ,' --> do RemoveHadrons instead.'
3818             mm=mmini
3819             nptl=nptlini
3820             irmdropx=0
3821             goto 55
3822           endif
3823         endif
3824
3825         if(idrop.eq.1)goto 1000
3826         !successful drop decay, no additional string, nothing to do
3827
3828       endif
3829
3830 c...............................................................
3831
3832  500  mm=mmini
3833       if(gdrop)mm=nptlini+2
3834       istptl(mm)=41
3835       ifrptl(1,mm)=nptl+1
3836
3837 c........................remove hadrons.........................
3838
3839       nbar=0
3840       nmes=0
3841
3842       if(.not.((nqu.eq.3.and.naq.eq.0).or.(nqu.eq.0.and.naq.eq.3)
3843      &          .or.(nqu.eq.1.and.naq.eq.1)))then
3844         if(irmdropx.eq.irmdrop)then
3845           jerr(6)=jerr(6)+1
3846              !call utmsg('ProReF')
3847              !write(ifch,*)'***** condition for droplet treatment: '
3848              !write(ifch,*)'*****  amasini.gt.amasmin.and.irmdropx.eq.1 = '
3849              !*           ,amasini.gt.amasmin.and.irmdropx.eq.1
3850              !write(ifch,*)'***** amasini,amasmin,irmdropx:'
3851              !*                 ,amasini,amasmin,irmdropx
3852              !write(ifch,*)'***** nqu,naq:',nqu,naq
3853              !write(ifch,*)'***** call RemoveHadrons'
3854              !call utmsgf
3855         endif
3856         call RemoveHadrons(gproj,gtarg,ghadr,m,mm,jcf,icf,ept)
3857       endif
3858
3859 c........................ determine idr (0=string, else=resonance).......
3860
3861       if(icf(1).eq.0.and.icf(2).eq.0)then
3862         id=110
3863       else
3864         id=idtra(icf,0,0,3)
3865       endif
3866       idr=0
3867       am=sngl(ept(5))
3868       call idres(id,am,idr,iadj,1)
3869       if(iabs(mod(idr,10)).le.2.and.idr.ne.0)then
3870        id=idr
3871       else
3872        idr=0
3873       endif                                !ckeck on-shell mass (see uti)
3874       if(iadj.ne.0.and.iept.gt.0.and.ept(5).gt.0.d0
3875      &     .and.(dabs((ept(4)+ept(3))*(ept(4)-ept(3))
3876      $           -ept(2)**2-ept(1)**2-dble(am)**2).gt.0.3d0))idr=0
3877
3878       if(ish.ge.3)then
3879         write(ifch,'(a,5e11.3)')' updt:',(sngl(ept(k)) ,k=1,5)
3880         write(ifch,*)'            icf: ',icf,' idr: ',idr,' iept: ',iept
3881       endif
3882
3883       if(iept.eq.3)stop'ProReF: iept=3 ???'
3884
3885 c...........................................string...................
3886       if(iept.gt.0.and.idr.eq.0)then
3887
3888         !... nqu of remainder string
3889
3890         anstrg0=anstrg0+1
3891         if(gdrop)anstrg1=anstrg1+1
3892
3893         call iddeco(icf,jcf)
3894         nqu=0
3895         do l=1,4
3896           nqu=nqu+jcf(l,1)-jcf(l,2)
3897         enddo
3898
3899         if(zbarfl.lt.0.)stop'ProReF: not supported any more.         '
3900
3901         !......determine forward momentum ep
3902
3903            !ptt=0.5*min(zopmax,zopinc*zz)
3904            !phi=2.*pi*rangen()
3905            !ptt1=dble(ptt*cos(phi))
3906            !ptt2=dble(ptt*sin(phi))
3907
3908         ep(1)=0
3909         ep(2)=0
3910         ep(3)=ir*0.5d0*ept(5)
3911         ep(4)=   0.5d0*ept(5)
3912
3913         call utlob2(-1,ept(1),ept(2),ept(3),ept(4),ept(5)
3914      *     ,ep(1),ep(2),ep(3),ep(4),25)
3915
3916         !....determine forward and backward flavor icf, icb
3917
3918         ireminv=0
3919 c        if(iept.le.2.and.ept(5)/reminv.lt.rangen())ireminv=1
3920 c        if(iept.eq.2.and.ept(5).lt.reminv.and.rangen().lt.0.5)ireminv=1
3921         if(iept.eq.6.and.rangen().lt.0.25)ireminv=1
3922 c        if(iept.le.2)then
3923 c          if(reminv/ept(5).gt.rangen())ireminv=1
3924 c        elseif(iept.eq.6)then
3925 c          ireminv=1
3926 c        endif
3927         if(nqu.eq.3)then      !---baryon---
3928           iq=idrafl(iclpt,jcf,1,'v',iret)
3929           call uticpl(icf,iq,2,iret)       ! antiquark
3930           call uticpl(icb,iq,1,iret)       ! quark
3931           if(ireminv.eq.1)then
3932            iq=idrafl(iclpt,jcf,1,'v',iret)
3933            call uticpl(icf,iq,2,iret)       ! antiquark
3934            call uticpl(icb,iq,1,iret)       ! quark
3935           endif
3936         elseif(nqu.eq.-3)then !---antibaryon---
3937           iq=idrafl(iclpt,jcf,2,'v',iret)
3938           call uticpl(icf,iq,1,iret)       ! quark
3939           call uticpl(icb,iq,2,iret)       ! antiquark
3940           if(ireminv.eq.1)then
3941            iq=idrafl(iclpt,jcf,2,'v',iret)
3942            call uticpl(icf,iq,1,iret)       ! quark
3943            call uticpl(icb,iq,2,iret)       ! antiquark
3944           endif
3945         elseif(nqu.eq.0)then !---meson---
3946            iq1=idrafl(iclpt,jcf,1,'v',iret)
3947            iq2=idrafl(iclpt,jcf,2,'v',iret)
3948            if(rangen().gt.0.5)then
3949              call uticpl(icf,iq1,2,iret) ! subtract quark
3950              call uticpl(icb,iq1,1,iret) ! add quark
3951            else
3952              call uticpl(icf,iq2,1,iret) ! subtract antiquark
3953              call uticpl(icb,iq2,2,iret) ! add antiquark
3954            endif
3955 c        elseif(nqu.eq.0)then !---meson---
3956 c          if(iept.ne.1.and.iept.ne.6.and.rangen().lt.0.5)then
3957 c           iq=idrafl(iclpt,jcf,1,'v',iret)
3958 c           call uticpl(icf,iq,2,iret)       ! subtract quark
3959 c           call uticpl(icb,iq,1,iret)       ! add quark
3960 c          else
3961 cc put quark in forward direction always for inelastic
3962 c           iq=idrafl(iclpt,jcf,2,'v',iret)
3963 c           call uticpl(icf,iq,1,iret)       ! subtract antiquark
3964 c           call uticpl(icb,iq,2,iret)       ! add antiquark
3965 c          endif
3966         else
3967           call utmsg('ProReF')
3968           write(ifch,*)'***** neither baryon nor antibaryon nor meson.'
3969           write(ifch,*)'*****  number of net quarks:',nqu
3970           call utstop('ProRef&')
3971         endif
3972 c        if(nqu.eq.3)then      !---baryon---
3973 c          iq1=idrafl(iclpt,jcf,1,'v',iret)
3974 c          iq2=idrafl(iclpt,jcf,1,'v',iret)
3975 c          iq3=idrafl(iclpt,jcf,1,'v',iret)
3976 c          amdqa=qmass(iq2)+qmass(iq3)+qmass(0)
3977 c          if(rangen().lt.qmass(iq1)/amdqa)ireminv=1
3978 c          if(ireminv.ne.1)then
3979 c            call uticpl(icf,iq1,2,iret) ! antiquark
3980 c            call uticpl(icb,iq1,1,iret) ! quark
3981 c          else
3982 c            call uticpl(icf,iq2,2,iret) ! antiquark
3983 c            call uticpl(icb,iq2,1,iret) ! quark
3984 c            call uticpl(icf,iq3,2,iret) ! antiquark
3985 c            call uticpl(icb,iq3,1,iret) ! quark
3986 c          endif
3987 c        elseif(nqu.eq.-3)then !---antibaryon---
3988 c          iq1=idrafl(iclpt,jcf,2,'v',iret)
3989 c          iq2=idrafl(iclpt,jcf,2,'v',iret)
3990 c          iq3=idrafl(iclpt,jcf,2,'v',iret)
3991 c          amdqa=qmass(iq2)+qmass(iq3)+qmass(0)
3992 c          if(rangen().lt.qmass(iq1)/amdqa)ireminv=1
3993 c          if(ireminv.ne.1)then
3994 c            call uticpl(icf,iq1,1,iret) ! antiquark
3995 c            call uticpl(icb,iq1,2,iret) ! quark
3996 c          else
3997 c            call uticpl(icf,iq2,1,iret) ! antiquark
3998 c            call uticpl(icb,iq2,2,iret) ! quark
3999 c            call uticpl(icf,iq3,1,iret) ! antiquark
4000 c            call uticpl(icb,iq3,2,iret) ! quark
4001 c          endif
4002 c        elseif(nqu.eq.0)then !---meson---
4003 c           iq1=idrafl(iclpt,jcf,1,'v',iret)
4004 c           iq2=idrafl(iclpt,jcf,2,'v',iret)
4005 c           if(rangen().lt.qmass(iq1)/qmass(iq2))then
4006 cc           if(rangen().gt.0.5)then
4007 c             call uticpl(icf,iq1,2,iret) ! subtract quark
4008 c             call uticpl(icb,iq1,1,iret) ! add quark
4009 c           else
4010 c             call uticpl(icf,iq2,1,iret) ! subtract antiquark
4011 c             call uticpl(icb,iq2,2,iret) ! add antiquark
4012 c           endif
4013 c        else
4014 c          call utmsg('ProReF')
4015 c          write(ifch,*)'***** neither baryon nor antibaryon nor meson.'
4016 c          write(ifch,*)'*****  number of net quarks:',nqu
4017 c          call utstop('ProRef&')
4018 c        endif
4019
4020         !..... forward string end
4021
4022         nptl=nptl+1
4023         if(nptl.gt.mxptl)call utstop('ProRef: mxptl too small&')
4024         pptl(1,nptl)=sngl(ep(1))
4025         pptl(2,nptl)=sngl(ep(2))
4026         pptl(3,nptl)=sngl(ep(3))
4027         pptl(4,nptl)=sngl(ep(4))
4028         pptl(5,nptl)=0.
4029         istptl(nptl)=20
4030         iorptl(nptl)=mm
4031         if(.not.gdrop)istptl(mm)=41
4032         jorptl(nptl)=0
4033         if(nmes.eq.0.and.nbar.eq.0.and..not.gdrop)ifrptl(1,mm)=nptl
4034         ifrptl(2,mm)=nptl
4035         xorptl(1,nptl)=xorptl(1,mm)
4036         xorptl(2,nptl)=xorptl(2,mm)
4037         xorptl(3,nptl)=xorptl(3,mm)
4038         xorptl(4,nptl)=xorptl(4,mm)
4039         tivptl(1,nptl)=xorptl(4,nptl)
4040         tivptl(2,nptl)=xorptl(4,nptl)
4041         idptl(nptl)=idtra(icf,0,0,3)
4042         if(gproj)then
4043           if(iep(m).lt.1)stop'ProReF: iep(m)<1     '
4044           ityptl(nptl)=41+iep(m)  ! =42 =43 =47
4045           if(gdrop.and.iep(m).ne.6)ityptl(nptl)=44
4046           if(ghadr)ityptl(nptl)=44
4047         else  !gtarg
4048           if(iet(m).lt.1)stop'ProReF: iet(m)<1     '
4049           ityptl(nptl)=51+iet(m)  !=52 =53 =57
4050           if(gdrop.and.iet(m).ne.6)ityptl(nptl)=54
4051           if(ghadr)ityptl(nptl)=54
4052         endif
4053         itsptl(nptl)=1
4054         qsqptl(nptl)=0.
4055         rinptl(nptl)=-9999
4056         !write(6,'(a,i9,$)')'     ',idptl(nptl) !======================
4057         if(gproj)then
4058           zpaptl(nptl)=zz
4059         else  !gtarg
4060           zpaptl(nptl)=0
4061         endif
4062         if(ish.ge.3)then
4063           write(ifch,'(a,5e11.3,$)')' kink:',(pptl(k,nptl),k=1,5)
4064           write(ifch,*)' id: ',idptl(nptl)
4065         endif
4066         !....... backward string end
4067
4068         nptl=nptl+1
4069         if(nptl.gt.mxptl)call utstop('ProRef: mxptl too small&')
4070         pptl2=0.
4071         do i=1,3
4072          pptl(i,nptl)=sngl(ept(i)-ep(i))
4073          pptl2=pptl2+pptl(i,nptl)*pptl(i,nptl)
4074         enddo
4075         pptl(4,nptl)=sqrt(pptl2)
4076         pptl2=sngl(ept(4)-ep(4))
4077         if(ish.ge.1.and.abs(pptl2-pptl(4,nptl)).gt.max(0.1,
4078      &                                         0.1*abs(pptl2)))then
4079           write(ifmt,*)
4080      &    'Warning in ProRef: inconsistent backward string end energy !'
4081      &    ,pptl(4,nptl),pptl2,abs(pptl2-pptl(4,nptl))
4082           if(ish.ge.2)write(ifch,*)
4083      &    'Warning in ProRef: inconsistent backward string end energy !'
4084      &    ,(pptl(kkk,nptl),kkk=1,4),pptl2,abs(pptl2-pptl(4,nptl))
4085         endif
4086         pptl(5,nptl)=0.
4087         istptl(nptl)=20
4088         iorptl(nptl)=mm
4089         jorptl(nptl)=0
4090         ifrptl(2,mm)=nptl
4091         ifrptl(1,nptl)=0
4092         ifrptl(2,nptl)=0
4093         xorptl(1,nptl)=xorptl(1,mm)
4094         xorptl(2,nptl)=xorptl(2,mm)
4095         xorptl(3,nptl)=xorptl(3,mm)
4096         xorptl(4,nptl)=xorptl(4,mm)
4097         tivptl(1,nptl)=xorptl(4,nptl)
4098         tivptl(2,nptl)=xorptl(4,nptl)
4099         idptl(nptl)=idtra(icb,0,0,3)
4100         if(gproj)then
4101           ityptl(nptl)=41+iep(m)  ! =42 =43 =47
4102           if(gdrop.and.iep(m).ne.6)ityptl(nptl)=44
4103           if(ghadr)ityptl(nptl)=44
4104         else  !gtarg
4105           ityptl(nptl)=51+iet(m)  !=52 =53 =57
4106           if(gdrop.and.iep(m).ne.6)ityptl(nptl)=54
4107           if(ghadr)ityptl(nptl)=54
4108         endif
4109         itsptl(nptl)=1
4110         qsqptl(nptl)=0.
4111         rinptl(nptl)=-9999
4112         !write(6,'(a,i9)')'     ',idptl(nptl)
4113         if(gtarg)then
4114           zpaptl(nptl)=zz
4115         else  !gproj
4116           zpaptl(nptl)=0
4117         endif
4118         if(ish.ge.3)then
4119           write(ifch,'(a,5e11.3,$)')' kink:',(pptl(k,nptl),k=1,5)
4120           write(ifch,*)' id: ',idptl(nptl)
4121         endif
4122
4123 c............................no string = resonance...................
4124       else
4125
4126         anreso0=anreso0+1
4127         if(gdrop)anreso1=anreso1+1
4128
4129         nptl=nptl+1
4130         if(nptl.gt.mxptl)call utstop('ProRef: mxptl too small&')
4131         if(iept.eq.0)call idmass(id,am)
4132         idptl(nptl)=id
4133         pptl(1,nptl)=sngl(ept(1))
4134         pptl(2,nptl)=sngl(ept(2))
4135         pptl(3,nptl)=sngl(ept(3))
4136         pptl(4,nptl)=sngl(ept(4))
4137         pptl(5,nptl)=am
4138         istptl(nptl)=0
4139         iorptl(nptl)=mm
4140         if(.not.gdrop)istptl(mm)=41
4141         jorptl(nptl)=0
4142         if(nmes.eq.0.and.nbar.eq.0.and..not.gdrop)ifrptl(1,mm)=nptl
4143         ifrptl(2,mm)=nptl
4144         ifrptl(1,nptl)=0
4145         ifrptl(2,nptl)=0
4146         xorptl(1,nptl)=xorptl(1,mm)
4147         xorptl(2,nptl)=xorptl(2,mm)
4148         xorptl(3,nptl)=xorptl(3,mm)
4149         xorptl(4,nptl)=xorptl(4,mm)
4150         tivptl(1,nptl)=xorptl(4,nptl)
4151         call idtau(idptl(nptl),pptl(4,nptl),pptl(5,nptl),taugm)
4152         tivptl(2,nptl)=tivptl(1,nptl)+taugm*(-alog(rangen()))
4153         if(gproj)then
4154           ityptl(nptl)=45
4155           if(gdrop)ityptl(nptl)=46
4156           if(ghadr)ityptl(nptl)=46
4157           if(iept.eq.6)ityptl(nptl)=47
4158           if(iept.eq.2)ityptl(nptl)=48
4159         else   !gtarg
4160           ityptl(nptl)=55
4161           if(gdrop)ityptl(nptl)=56
4162           if(ghadr)ityptl(nptl)=56
4163           if(iept.eq.6)ityptl(nptl)=57
4164           if(iept.eq.2)ityptl(nptl)=58
4165         endif
4166         itsptl(nptl)=0
4167         qsqptl(nptl)=0.
4168         rinptl(nptl)=-9999
4169
4170         if(ish.ge.3)write(ifch,'(a,5e10.3,i7)')' nucl:'
4171      *         ,(pptl(i,nptl),i=1,5),idptl(nptl)
4172
4173       endif
4174 c.......................................................................
4175 c      print *,iep(1),iet(1),ityptl(nptl)
4176  1000 call utprix('ProReF',ish,ishini,3)
4177 ctp060829        if(ityptl(nptl).gt.60)print*,ityptl(nptl)
4178       return
4179
4180       end
4181
4182 c---------------------------------------------------------------------------------------
4183       subroutine RemoveHadrons(gproj,gtarg,ghadr,m,mm,jcf,icf,ept)
4184 c---------------------------------------------------------------------------------------
4185       include 'epos.inc'
4186       include 'epos.incems'
4187       integer jcf(nflav,2),icf(2)
4188       double precision aa(5),ept(5)
4189       logical ghadr,gproj,gtarg
4190       common /cncl/xproj(mamx),yproj(mamx),zproj(mamx)
4191      *            ,xtarg(mamx),ytarg(mamx),ztarg(mamx)
4192
4193       if(gproj)then
4194         ir=1
4195       elseif(gtarg)then
4196         ir=-1
4197       else
4198         call utstop('RemoveHadron : neither proj or targ !&')
4199       endif
4200
4201       call idquacjc(jcf,nqu,naq)
4202       if(nqu.eq.naq)then
4203         nmes=nqu-1
4204         nbar=0
4205       elseif(nqu.gt.naq)then
4206         nmes=naq
4207         nbar=(nqu-naq-3)/3     !nbar baryons
4208       else
4209         nmes=nqu
4210         nbar=(naq-nqu-3)/3    !nbar antibaryons
4211       endif
4212       if(nmes+nbar.gt.0)ghadr=.true.
4213 c  remove mesons
4214        if(nmes.gt.0)then
4215           do mes=1,nmes
4216             !write(ifch,*)'remove meson',mes,' / ',nmes
4217             call gethadron(1,idd,aa,jcf,ept,ir,iret)
4218             call idenco(jcf,icf,iret2)
4219             if(iret.eq.0.and.iret2.eq.0)then
4220               nptl=nptl+1
4221               if(nptl.gt.mxptl)
4222      &             call utstop('RemoveHadrons: mxptl too small&')
4223               idptl(nptl)=idd
4224               do i=1,5
4225                 pptl(i,nptl)=sngl(aa(i))
4226               enddo
4227               iorptl(nptl)=mm
4228               jorptl(nptl)=0
4229               if(mes.eq.1)then
4230                 ifrptl(1,mm)=nptl
4231                 ifrptl(2,mm)=nptl
4232               else
4233                 ifrptl(2,mm)=nptl
4234               endif
4235               ifrptl(1,nptl)=0
4236               ifrptl(2,nptl)=0
4237               istptl(nptl)=0
4238               if(gproj)then
4239                 ityptl(nptl)=49
4240                 xorptl(1,nptl)=xproj(m)
4241                 xorptl(2,nptl)=yproj(m)
4242                 xorptl(3,nptl)=zproj(m)
4243               elseif(gtarg)then
4244                 ityptl(nptl)=59
4245                 xorptl(1,nptl)=xtarg(m)
4246                 xorptl(2,nptl)=ytarg(m)
4247                 xorptl(3,nptl)=ztarg(m)
4248               endif
4249               xorptl(4,nptl)=xorptl(4,mm)
4250               tivptl(1,nptl)=xorptl(4,nptl)
4251               call idtau(idptl(nptl),pptl(4,nptl),pptl(5,nptl),taugm)
4252               tivptl(2,nptl)=tivptl(1,nptl)+taugm*(-alog(rangen()))
4253               qsqptl(nptl)=0.
4254             endif
4255 c           deleted: after abstracting a meson,
4256 c           check if the NEW remnant is a H-Dibaryon
4257           enddo
4258         endif
4259 c remove (anti)baryons
4260         call idquacjc(jcf,nqu,naq)
4261         if(nbar.gt.0)then
4262           do nb=1,nbar
4263             !write(ifch,*)'remove baryon',nb,' / ',nbar
4264             if(nqu.gt.0)then
4265               call gethadron(2,idd,aa,jcf,ept,ir,iret)
4266             else
4267               call gethadron(3,idd,aa,jcf,ept,ir,iret)
4268             endif
4269             call idenco(jcf,icf,iret2)
4270             if(iret.eq.0.and.iret2.eq.0)then
4271               nptl=nptl+1
4272               if(nptl.gt.mxptl)
4273      &             call utstop('RemoveHadron: mxptl too small&')
4274               idptl(nptl)=idd
4275               do i=1,5
4276                 pptl(i,nptl)=sngl(aa(i))
4277               enddo
4278               iorptl(nptl)=mm
4279               jorptl(nptl)=0
4280               if(nmes.eq.0.and.nb.eq.1)then
4281                 ifrptl(1,mm)=nptl
4282                 ifrptl(2,mm)=nptl
4283               else
4284                 ifrptl(2,mm)=nptl
4285               endif
4286               ifrptl(1,nptl)=0
4287               ifrptl(2,nptl)=0
4288               istptl(nptl)=0
4289               if(gproj)then
4290                 ityptl(nptl)=49
4291                 xorptl(1,nptl)=xproj(m)
4292                 xorptl(2,nptl)=yproj(m)
4293                 xorptl(3,nptl)=zproj(m)
4294               elseif(gtarg)then
4295                 ityptl(nptl)=59
4296                 xorptl(1,nptl)=xtarg(m)
4297                 xorptl(2,nptl)=ytarg(m)
4298                 xorptl(3,nptl)=ztarg(m)
4299               endif
4300               xorptl(4,nptl)=xorptl(4,mm)
4301               tivptl(1,nptl)=xorptl(4,nptl)
4302               call idtau(idptl(nptl),pptl(4,nptl),pptl(5,nptl),taugm)
4303               tivptl(2,nptl)=tivptl(1,nptl)+taugm*(-alog(rangen()))
4304               qsqptl(nptl)=0.
4305             endif
4306 c             deleted: after abstracting a (anti)baryon,
4307 c                                  check if the NEW remnant is a H-Dibaryon
4308           enddo
4309         endif
4310       end
4311
4312 c------------------------------------------------------------------
4313          subroutine gethadron(imb,idf,a,jc,ep,ir,iret)
4314 c------------------------------------------------------------------
4315 c       goal:  emit a hadron (imb= 1 meson, 2 baryon, 3 antibaryon)
4316 c              update the remnant flavour and 5-momentum
4317 c
4318 c       idf ,a : hadron id and 5-momentum
4319 c       ir     : 1  projectile, -1  target remnant
4320 c       jc, ep : remnant flavor and 5-momentum
4321 c       iret   : in case of error, keep correct momentum in remnant
4322 c                and lose the quarks of the (not) emitted hadron
4323 c-----------------------------------------------------------------
4324
4325         include 'epos.inc'
4326         include 'epos.incems'
4327         common/cems5/plc,s
4328         double precision s,plc
4329         double precision ep(5),a(5),re(5),p1(5)
4330         integer jc(nflav,2),ifh(3)!,ic(2)
4331         common /ems12/iodiba,bidiba  ! defaut iodiba=0. if iodiba=1, study H-Dibaryon
4332         double precision ptm,qcm,u(3),utpcmd,ptt,phi,sxini,strmas
4333      &                  ,ampt2dro,ampt2str,p5sq,amasex,drangen
4334
4335         call utpri('gethad',ish,ishini,5)
4336
4337         iret=0
4338         do i=1,5
4339           a(i)=0.d0
4340           re(i)=ep(i)
4341         enddo
4342
4343          if(ish.ge.5)then
4344            write(ifch,*)'remnant flavour and 5-momentum:',jc, ep,  ir
4345          endif
4346          !write(*,'(/a,5f8.3)')'p before: ',ep
4347
4348          if(ir.eq.1)then
4349            iclpt=iclpro
4350          else
4351            iclpt=icltar
4352          endif
4353
4354 c  get the id and mass of hadron, the remnant jc is updated
4355
4356           if(imb.eq.1)then              ! a meson
4357             ifq=idrafl(iclpt,jc,1,'v',iret)
4358             ifa=idrafl(iclpt,jc,2,'v',iret)
4359             if(ifq.le.ifa)then
4360                      idf=ifq*100+ifa*10
4361             else
4362               idf=-(ifq*10+ifa*100)
4363             endif
4364             call idmass(idf,amss)
4365
4366           elseif(imb.eq.2)then            ! a baryon
4367             do ik=1,3
4368               ifh(ik)=idrafl(iclpt,jc,1,'v',iret)
4369             enddo
4370             call neworder(ifh(1),ifh(2),ifh(3))
4371             idf=ifh(1)*1000+ifh(2)*100+ifh(3)*10
4372             if(ifh(1).ne.ifh(2).and.ifh(2).ne.ifh(3)
4373      $        .and.ifh(1).ne.ifh(3))  idf=2130
4374             if(ifh(1).eq.ifh(2).and.ifh(2).eq.ifh(3))idf=idf+1
4375             call idmass(idf,amss)
4376
4377           elseif(imb.eq.3)then           ! an antibaryon
4378             do ik=1,3
4379               ifh(ik)=idrafl(iclpt,jc,2,'v',iret)
4380             enddo
4381             call neworder(ifh(1),ifh(2),ifh(3))
4382             idf=ifh(1)*1000+ifh(2)*100+ifh(3)*10
4383             if(ifh(1).ne.ifh(2).and.ifh(2).ne.ifh(3)
4384      $        .and.ifh(1).ne.ifh(3))  idf=2130
4385             if(ifh(1).eq.ifh(2).and.ifh(2).eq.ifh(3))idf=idf+1
4386             idf=-idf
4387             call idmass(idf,amss)
4388           endif
4389
4390           if(iret.ne.0)call utstop('Not enough quark in gethad ???&')
4391
4392 c boost remnant in rest frame
4393       if(ish.ge.6) write (ifch,*) 'on-shell check'
4394         do k=1,5
4395           p1(k)=ep(k)
4396         enddo
4397         p1(5)=(p1(4)-p1(3))*(p1(4)+p1(3))-p1(2)**2-p1(1)**2
4398         if(p1(5).gt.0d0.and.abs(p1(5)-ep(5)*ep(5)).lt.ep(5))then
4399           p1(5)=sqrt(p1(5))
4400         else
4401           if(ish.ge.1)write(ifch,*)'Precision problem in gethad, p:',
4402      &             (p1(k),k=1,5),ep(5)*ep(5)
4403           p1(5)=ep(5)
4404           p1(4)=sqrt(p1(3)*p1(3)+p1(2)*p1(2)+p1(1)*p1(1)+p1(5)*p1(5))
4405         endif
4406
4407 c initial limits
4408
4409           ptm=p1(5)
4410           amasex=dble(amss)
4411           strmas=dble(2.*utamnz(jc,4))
4412           sxini=ptm*ptm
4413 c redo
4414
4415        nredo=0
4416  777   continue
4417        nredo=nredo+1
4418        if(nredo.gt.20)then
4419           !write(ifch,*)'nredo.gt.20 -> only drop'
4420          if(ish.ge.4)write(ifch,*)
4421      &  'Pb with hadron momentum in Gethad !'
4422          iret=1
4423          goto 999
4424        endif
4425
4426 c fix pt
4427
4428           ptt=dble(ranpt()*alpdro(2))**2         !pt+pl
4429           if(ptt.ge.sxini)goto 777
4430           sxini=sqrt(sxini-ptt)
4431
4432
4433           ampt2dro=amasex**2d0
4434           ampt2str=strmas**2d0
4435
4436           a(5)=amasex
4437           re(5)=sxini-a(5)
4438           if(re(5).le.strmas)then
4439             if(ish.ge.6)write(ifch,*)
4440      &           'Pb with initial mass in Gethad, retry',ir
4441      &       ,amasex,strmas,sxini,ptm,ptt
4442             goto 777
4443           endif
4444
4445
4446 c two body decay
4447           if(ish.ge.6)write(ifch,*)'2 body decay',ptm,a(5),re(5)
4448           qcm=utpcmd(ptm,a(5),re(5))
4449           u(3)=2.d0*drangen(qcm)-1.d0
4450           phi=2.d0*dble(pi)*drangen(u(3))
4451           u(1)=sqrt(1.d0-u(3)**2)*cos(phi)
4452           u(2)=sqrt(1.d0-u(3)**2)*sin(phi)
4453           if(u(3).ge.0d0)then          !send always hadron backward
4454             do j=1,3
4455               re(j)=qcm*u(j)
4456               a(j)=-re(j)
4457             enddo
4458           else
4459             do j=1,3
4460               a(j)=qcm*u(j)
4461               re(j)=-a(j)
4462             enddo
4463           endif
4464
4465           re(4)=sqrt(qcm**2+re(5)**2)
4466           a(4)=sqrt(qcm**2+a(5)**2)
4467
4468           if(ish.ge.6)write(ifch,*)'momentum in rest frame : ',re,a
4469
4470
4471 c Fix re of remnant
4472
4473 c boost string in collision frame
4474         call utlob2(-1,p1(1),p1(2),p1(3),p1(4),p1(5)
4475      $       ,re(1),re(2),re(3),re(4),81)
4476
4477          p5sq=(re(4)+re(3))*(re(4)-re(3))-(re(1)*re(1)+re(2)*re(2))
4478          if(p5sq.gt.ampt2str)then
4479            re(5)=sqrt(p5sq)
4480          else
4481            if(ish.ge.6)then
4482              write(ifch,*)'Pb with remnant mass -> retry'
4483              write(ifch,*)'   m^2:',p5sq,'  m_min^2:',ampt2str
4484              write(ifch,*)'   momentum four vector:',(re(ii),ii=1,4)
4485            endif
4486            goto 777
4487          endif
4488
4489 c Fix a of hadron
4490
4491 c boost droplet in collision frame
4492         call utlob2(-1,p1(1),p1(2),p1(3),p1(4),p1(5)
4493      $       ,a(1),a(2),a(3),a(4),82)
4494
4495          p5sq=(a(4)+a(3))*(a(4)-a(3))-(a(1)**2.d0+a(2)**2.d0)
4496          if(abs(p5sq-ampt2dro).le.0.1)then
4497            a(5)=sqrt(p5sq)
4498          else
4499            if(ish.ge.6)then
4500              write(ifch,*)'Pb with hadron mass -> retry'
4501              write(ifch,*)'   m^2:',p5sq,'  m_min^2:',ampt2dro
4502              write(ifch,*)'   momentum four vector:',(a(ii),ii=1,4)
4503            endif
4504            goto 777
4505          endif
4506
4507
4508  999    continue
4509
4510
4511         if(iret.eq.1)then      !If problem with momenta do not update remnant
4512
4513           if(ish.ge.4)
4514      *    write(ifch,*)'no hadron emission in gethad'
4515
4516         else     !update the 3-momentum and energy of remnant: ep
4517
4518           if(ish.ge.1.and.abs(ep(4)-re(4)-a(4)).gt.1.e-2*ep(4))then
4519             write(ifmt,*)'Pb with energy conservation in gethad'
4520             if(ish.ge.6)then
4521               write(ifch,*)'Pb with energy conservation :'
4522               write(ifch,*)'   p1_ini:',ep(1),'  p1:',re(1)+a(1)
4523               write(ifch,*)'   p2_ini:',ep(2),'  p2:',re(2)+a(2)
4524               write(ifch,*)'   p3_ini:',ep(3),'  p3:',re(3)+a(3)
4525             endif
4526           endif
4527
4528           do i=1,5
4529             ep(i)=re(i)
4530           enddo
4531           if(ish.ge.5)then
4532             write(ifch,*)'get hadron with id and 5-momentum:',idf, a
4533           endif
4534
4535         endif
4536         !do i=1,5
4537         !  sm(i)=ep(i)+a(i)
4538         !enddo
4539         !write(*,'(a,5f8.3,i5)')'p after:  ',sm,iret
4540
4541 c      ghost condition
4542 c         if(abs((a(4)+a(3))*(a(4)-a(3))
4543 c     $           -a(2)**2-a(1)**2-a(5)**2).gt.0.3
4544 c     $      .and.  abs(1.-abs(a(3))/a(4)).gt.0.01)print*,iret,dd
4545
4546 c$$$        if(iodiba.eq.1)then  ! for H-dibaryon study ??????????
4547 c$$$          call idenco(jc,ic,iret)
4548 c$$$          if(ic(1).eq.222000.and.ic(2).eq.0)ep(5)=ep(5)-bidiba
4549 c$$$        endif
4550
4551         if(ish.ge.5)then
4552           write(ifch,*)'new remnant flavour and 5-momentum:',jc, ep
4553         endif
4554 c          write(ifmt,*)'get hadron with id and 5-momentum:',idf, a
4555 c          write(ifmt,*)'new remnant flavour and 5-momentum:',jc, ep
4556
4557         call utprix('gethad',ish,ishini,5)
4558
4559       return
4560       end
4561
4562
4563
4564 c------------------------------------------------------------------
4565          subroutine getdroplet(ir,ic,jc,ep,a,pass,mdrmax)
4566 c------------------------------------------------------------------
4567 c  emit a droplet, update the remnant string flavour and 5-momentum
4568 c
4569 c input
4570 c       ir ........ 1  projectile, -1  target remnant
4571 c       ep ........ remnant  5-momentum
4572 c       jc ........ remnant jc
4573 c output
4574 c       pass ...  .true. = successful droplet emission
4575 c                            ic, ep ....... droplet  ic and 5-momentum
4576 c                            jc, a ........ remnant string jc and 5-momentum
4577 c                 .false. = unsuccessful
4578 c                            jc, ep .... unchanged,
4579 c                            considered as droplet jc and 5-momentum
4580 c-----------------------------------------------------------------
4581
4582         include 'epos.inc'
4583         include 'epos.incems'
4584         double precision ep(5),a(5),p1(5),re(5),eps,amasex,mdrmax
4585         double precision xxx,rr,alp,p5sq,xmin,xmax,ampt2str
4586      &  ,sxini,strmas,xxxmax,xxxmin,ampt2dro,mdrmaxi
4587         parameter(eps=1.d-20)
4588         integer jc(nflav,2),jcini(nflav,2),jcfin(nflav,2),ifh(3),ic(2)
4589         integer icx(2)   !,icxx(2)
4590         logical pass
4591         common/cems5/plc,s
4592         double precision s,plc,ptm,qcm,u(3),utpcmd,ptt,drangen,phi
4593
4594         call utpri('getdro',ish,ishini,4)
4595
4596         iret=0
4597         iret2=0
4598         mdrmaxi=mdrmax
4599         pass=.true.
4600         idps=0
4601         idms=0
4602         do i=1,nflav
4603           jcini(i,1)=jc(i,1)
4604           jcini(i,2)=jc(i,2)
4605           jcfin(i,1)=0
4606           jcfin(i,2)=0
4607         enddo
4608
4609         call idquacjc(jc,nqu,naq)
4610
4611         do i=1,5
4612           a(i)=0.d0
4613           re(i)=0.d0
4614         enddo
4615         npart=nqu+naq
4616
4617          if(ir.eq.1)then
4618            iclpt=iclpro
4619          else
4620            iclpt=icltar
4621          endif
4622
4623          if(ish.ge.5)then
4624            write(ifch,*)'remnant flavour and 5-momentum:',jc,ep,npart
4625          endif
4626
4627 c  get id of string ends, the remnant string jc is updated
4628
4629          if(npart.lt.3.and.ep(5).lt.mdrmax.and.iclpt.ne.4)then !light droplet with few quarks
4630             pass=.false.
4631             goto 1000
4632          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)
4633            ifq=jdrafl(iclpt,jcini,2,iret2)
4634            if(nqu.eq.1.and.naq.eq.1)then
4635              idps=1
4636              idms=1
4637              nqu=2
4638              naq=2
4639            else
4640              call utstop('This should not happen (getdrop) !&')
4641            endif
4642          elseif((nqu.eq.2.and.naq.le.2).or.(nqu.le.2.and.naq.eq.2))then
4643            idps=1
4644            idms=1
4645          elseif(naq.eq.0)then
4646            idps=5
4647            idms=1
4648          elseif(nqu.eq.0)then
4649            idps=1
4650            idms=5
4651          else                 !There is enough q or aq to do qq-q string
4652
4653
4654            if(jcini(4,1)-jcini(4,2).eq.0)then !if c-cbar
4655
4656              idps=1
4657              idms=1
4658
4659            else
4660
4661 c One chooses the first q or aq
4662
4663            rrr=rangen()
4664            npart=nqu+naq
4665            if(jcini(4,1)+jcini(4,2).ne.0)then !if some charm take it out
4666              if(jcini(4,1).ne.0)then
4667                idps=1
4668                nqu=nqu-1
4669              else
4670                idms=1
4671                naq=naq-1
4672              endif
4673            elseif(rrr.gt.float(naq)/float(npart))then
4674              idps=1
4675              nqu=nqu-1
4676            else
4677              idms=1
4678              naq=naq-1
4679            endif
4680
4681 c One chooses the second one
4682
4683            rrr=rangen()
4684            npart=nqu+naq
4685            if(idps.eq.1.and.jcini(4,1).ne.0)then !if some charm take it out
4686              idps=5
4687            elseif(idms.eq.1.and.jcini(4,2).ne.0)then !if some charm take it out
4688              idms=5
4689            elseif(rrr.gt.float(naq)/float(npart))then
4690              if(idps.eq.1.and.nqu.ge.2)then
4691                idps=5
4692              else
4693                idps=1
4694              endif
4695            else
4696              if(idms.eq.1.and.naq.ge.2)then
4697                idms=5
4698              else
4699                idms=1
4700              endif
4701            endif
4702
4703 c If there is already 2 q or 2 aq as string end, we know that we need
4704 c a third one to complete the string
4705
4706            if(idps.eq.5)idms=1
4707            if(idms.eq.5)idps=1
4708            if(idps.eq.1.and.idms.ne.5)idms=1
4709            if(idms.eq.1.and.idps.ne.5)idps=1
4710
4711          endif
4712
4713          endif
4714
4715          if(ish.ge.5)then
4716            write(ifch,*)'remnant string ends :',idps,idms
4717          endif
4718
4719           if(idps.ne.5.and.idms.ne.5)then              ! q-aq string
4720             if(jcini(4,1).eq.1)then
4721               ifq=idrafl(iclpt,jcini,1,'c',iret)
4722             else
4723               ifq=idrafl(iclpt,jcini,1,'v',iret)
4724             endif
4725             if(jcini(4,1).eq.1)then
4726               ifa=idrafl(iclpt,jcini,2,'c',iret)
4727             else
4728               ifa=idrafl(iclpt,jcini,2,'v',iret)
4729             endif
4730             jcfin(ifq,1)=1
4731             jcfin(ifa,2)=1
4732
4733           elseif(idps.eq.5)then                       ! qq-q string
4734             do ik=1,3
4735               if(jcini(4,1).ne.0)then
4736                 ifh(ik)=idrafl(iclpt,jcini,1,'c',iret)
4737               else
4738                 ifh(ik)=idrafl(iclpt,jcini,1,'v',iret)
4739               endif
4740               jcfin(ifh(ik),1)=jcfin(ifh(ik),1)+1
4741             enddo
4742
4743           elseif(idms.eq.5)then                        !aqaq-aq string
4744             do ik=1,3
4745               if(jcini(4,2).ne.0)then
4746                 ifh(ik)=idrafl(iclpt,jcini,2,'c',iret)
4747               else
4748                 ifh(ik)=idrafl(iclpt,jcini,2,'v',iret)
4749               endif
4750               jcfin(ifh(ik),2)=jcfin(ifh(ik),2)+1
4751             enddo
4752           endif
4753
4754           if(iret.ne.0)call utstop('Not enough quark in getdro ???&')
4755           if(jcini(4,1)+jcini(4,2).ne.0)
4756      &         call utstop('There is sitll charm quark in getdro???&')
4757
4758 c droplet id
4759
4760          call idenco(jcini,icx,iret)
4761          if(iret.eq.1)then
4762            call utstop('Exotic flavor in getdroplet !&')
4763          endif
4764          amx=0
4765          idx=idtra(icx,0,0,3)
4766          if(idx.ne.0)call idmass(idx,amx)
4767 ccc         print*,idx,amx
4768
4769
4770 c boost remnant in rest frame
4771       if(ish.ge.6) write (ifch,*) 'on-shell check'
4772         do k=1,5
4773           p1(k)=ep(k)
4774         enddo
4775         p1(5)=(p1(4)-p1(3))*(p1(4)+p1(3))-p1(2)**2-p1(1)**2
4776         if(p1(5).gt.0d0.and.abs(p1(5)-ep(5)*ep(5)).lt.ep(5))then
4777           p1(5)=sqrt(p1(5))
4778         else
4779           if(ish.ge.2)write(ifch,*)'Precision problem in getdro, p:',
4780      &             (p1(k),k=1,5),ep(5)*ep(5)
4781           p1(5)=ep(5)
4782           p1(4)=sqrt(p1(3)*p1(3)+p1(2)*p1(2)+p1(1)*p1(1)+p1(5)*p1(5))
4783         endif
4784       if(ish.ge.6) write (ifch,*) 'boost vector:',p1
4785
4786 c limits for momenta
4787
4788           mamod=4
4789           mamos=4
4790           fad=alpdro(1)
4791           fas=2
4792           ptm=p1(5)
4793           amasex=dble(fad*utamnz(jcini,mamod))
4794           strmas=dble(fas*utamnz(jcfin,mamos))
4795
4796
4797 c redo
4798
4799        nredo=0
4800  777   continue
4801        nredo=nredo+1
4802        if(nredo.eq.10)then
4803           amasex=dble(utamnz(jcini,mamod))
4804           strmas=dble(utamnz(jcfin,mamos))
4805        elseif(nredo.gt.20)then
4806           !write(ifch,*)'nredo.gt.20 -> only drop'
4807          if(ish.ge.4)write(ifch,*)
4808      &     'Pb with string mass in Getdrop, continue with gethad'
4809           pass=.false.
4810          goto 1000
4811        endif
4812
4813 c fix pt
4814
4815           sxini=ptm*ptm
4816           ptt=dble(ranpt()*alpdro(2))**2         !pt+pl
4817           if(ptt.ge.sxini)goto 777
4818           sxini=sqrt(sxini-ptt)
4819
4820
4821           ampt2dro=amasex**2d0
4822           ampt2str=strmas**2d0
4823           if(ampt2dro.gt.mdrmaxi)then
4824             mdrmaxi=2d0*ampt2dro
4825 c            write(ifmt,*)'Warning Mmin>Mmax in Getdroplet'
4826           endif
4827
4828           xxxmax=min(mdrmaxi,(sxini-strmas)**2)    !strmas/(strmas+ampt2)
4829           xxxmin=ampt2dro
4830
4831           if(xxxmin.gt.xxxmax)then
4832             !write(ifch,*)'Warning Mmin>sxini -> only drop'
4833            if(ish.ge.4)write(ifch,*)
4834      &     'Pb with ampt2 in Getdrop, retry',nredo,ir
4835      &             ,ampt2dro,ampt2str,xxxmin,xxxmax,sxini,ptt,mdrmaxi
4836             goto 777
4837           endif
4838
4839
4840
4841 c fix mass
4842
4843           rr=drangen(xxxmax)
4844           xmax=xxxmax
4845           xmin=xxxmin
4846           alp=dble(alpdro(3))
4847           if(dabs(alp-1.d0).lt.eps)then
4848             xxx=xmax**rr*xmin**(1d0-rr)
4849           else
4850             xxx=(rr*xmax**(1d0-alp)+(1d0-rr)*xmin**(1d0-alp))
4851      &                                                **(1d0/(1d0-alp))
4852           endif
4853
4854 c          write(ifch,*)'ini',xmin,xxx,xmax,rr,ampt2dro
4855 c     &                   ,(sxini-sqrt(xxx)),ampt2str,p1(5)
4856
4857
4858
4859           re(5)=sqrt(xxx)
4860           a(5)=sxini-re(5)
4861           if(a(5).le.strmas)then
4862             if(ish.ge.6)write(ifch,*)
4863      &           'Pb with initial mass in Getdrop, retry',ir
4864      &       ,xmin,xxx,xmax,rr,ampt2dro,ampt2str
4865             goto 777
4866           endif
4867
4868
4869 c two body decay
4870           if(ish.ge.6)write(ifch,*)'2 body decay',ptm,re(5),a(5)
4871           qcm=utpcmd(ptm,re(5),a(5))
4872           u(3)=2.d0*drangen(qcm)-1.d0
4873           phi=2.d0*dble(pi)*drangen(u(3))
4874           u(1)=sqrt(1.d0-u(3)**2)*cos(phi)
4875           u(2)=sqrt(1.d0-u(3)**2)*sin(phi)
4876           if(u(3).lt.0d0)then          !send always droplet backward
4877             do j=1,3
4878               re(j)=qcm*u(j)
4879               a(j)=-re(j)
4880             enddo
4881           else
4882             do j=1,3
4883               a(j)=qcm*u(j)
4884               re(j)=-a(j)
4885             enddo
4886           endif
4887
4888           re(4)=sqrt(qcm**2+re(5)**2)
4889           a(4)=sqrt(qcm**2+a(5)**2)
4890
4891           if(ish.ge.6)write(ifch,*)'momentum in rest frame : ',re,a
4892
4893
4894
4895 c Fix a of string
4896
4897 c boost string in collision frame
4898         call utlob2(-1,p1(1),p1(2),p1(3),p1(4),p1(5)
4899      $       ,a(1),a(2),a(3),a(4),71)
4900
4901          p5sq=(a(4)+a(3))*(a(4)-a(3))-(a(1)**2.d0+a(2)**2.d0)
4902          if(p5sq.gt.ampt2str)then
4903            a(5)=sqrt(p5sq)
4904          else
4905            if(ish.ge.6)then
4906              write(ifch,*)'Pb with string mass -> retry'
4907              write(ifch,*)'   m^2:',p5sq,'  m_min^2:',ampt2str
4908              write(ifch,*)'   momentum four vector:',(a(ii),ii=1,4)
4909            endif
4910            goto 777
4911          endif
4912
4913 c Fix ep of droplet
4914
4915 c boost droplet in collision frame
4916         call utlob2(-1,p1(1),p1(2),p1(3),p1(4),p1(5)
4917      $       ,re(1),re(2),re(3),re(4),72)
4918
4919          p5sq=(re(4)+re(3))*(re(4)-re(3))-(re(1)*re(1)+re(2)*re(2))
4920          if(p5sq.gt.ampt2dro)then
4921            re(5)=sqrt(p5sq)
4922          else
4923            if(ish.ge.6)then
4924              write(ifch,*)'Pb with droplet mass -> retry'
4925              write(ifch,*)'   m^2:',p5sq,'  m_min^2:',ampt2dro
4926              write(ifch,*)'   momentum four vector:',(re(ii),ii=1,4)
4927            endif
4928            goto 777
4929          endif
4930
4931
4932        if(ish.ge.1.and.abs(ep(4)-re(4)-a(4)).gt.1.e-2*ep(4))then
4933          write(ifmt,*)'Pb with energy conservation in getdro'
4934          if(ish.ge.6)then
4935            write(ifch,*)'Pb with energy conservation :'
4936            write(ifch,*)'   p1_ini:',ep(1),'  p1:',re(1)+a(1)
4937            write(ifch,*)'   p2_ini:',ep(2),'  p2:',re(2)+a(2)
4938            write(ifch,*)'   p3_ini:',ep(3),'  p3:',re(3)+a(3)
4939          endif
4940        endif
4941
4942 c If OK, save flavours of droplet and string
4943          do i=1,5
4944            ep(i)=re(i)
4945          enddo
4946          ic(1)=icx(1)
4947          ic(2)=icx(2)
4948          do i=1,nflav
4949            jc(i,1)=jcfin(i,1)
4950            jc(i,2)=jcfin(i,2)
4951          enddo
4952
4953          if(ish.ge.6)then
4954            write(ifch,*)'droplet:'
4955            write(ifch,*)ic
4956            write(ifch,*)ep
4957            write(ifch,*)'string remnant:'
4958            write(ifch,*)jc
4959            write(ifch,*)a
4960          endif
4961
4962  1000    continue
4963          call utprix('getdro',ish,ishini,4)
4964          end
4965
4966 c-----------------------------------------------------
4967        subroutine neworder(n1, n2, n3)
4968 c-----------------------------------------------------
4969 c make 3 integers ordered like 1 2 3
4970 c------------------------------------------------------
4971             if(n2.lt.n1)then
4972               ifb=n2
4973               n2=n1
4974               n1=ifb
4975             endif
4976             if(n3.lt.n1)then
4977               ifb=n3
4978               n3=n2
4979               n2=n1
4980               n1=ifb
4981             elseif(n3.lt.n2)then
4982               ifb=n3
4983               n3=n2
4984               n2=ifb
4985             endif
4986          end
4987
4988 c-----------------------------------------------------------------------
4989       function idtr2(ic)
4990 c-----------------------------------------------------------------------
4991 c transforms ic to id such that only hadrons have nonzero id
4992 c-----------------------------------------------------------------------
4993       parameter (nidt=30)
4994       integer idt(3,nidt),ic(2)
4995       data idt/
4996      * 100000,100000, 110   ,100000,010000, 120   ,010000,010000, 220
4997      *,100000,001000, 130   ,010000,001000, 230   ,001000,001000, 330
4998      *,100000,000100, 140   ,010000,000100, 240   ,001000,000100, 340
4999      *,000100,000100, 440
5000      *,300000,000000,1111   ,210000,000000,1120   ,120000,000000,1220
5001      *,030000,000000,2221   ,201000,000000,1130   ,111000,000000,1230
5002      *,021000,000000,2230   ,102000,000000,1330   ,012000,000000,2330
5003      *,003000,000000,3331   ,200100,000000,1140   ,110100,000000,1240
5004      *,020100,000000,2240   ,101100,000000,1340   ,011100,000000,2340
5005      *,002100,000000,3340   ,100200,000000,1440   ,010200,000000,2440
5006      *,001200,000000,3440   ,000300,000000,4441/
5007
5008       idtr2=0
5009       if(ic(1).eq.0.and.ic(2).eq.0)then
5010        if(rangen().ge.0.5)then
5011         idtr2=110
5012         ic(1)=100000
5013         ic(2)=100000
5014        else
5015         idtr2=220
5016         ic(1)=10000
5017         ic(2)=10000
5018        endif
5019        return
5020       endif
5021       do 1 i=1,nidt
5022        if(ic(2).eq.idt(1,i).and.ic(1).eq.idt(2,i))idtr2=-idt(3,i)
5023        if(ic(1).eq.idt(1,i).and.ic(2).eq.idt(2,i))idtr2=idt(3,i)
5024 1     continue
5025       return
5026       end
5027
5028 c----------------------------------------------------------------------
5029       subroutine emsini(e,idpj,idtg)
5030 c----------------------------------------------------------------------
5031 c  energy-momentum sharing initializations
5032 c----------------------------------------------------------------------
5033       include 'epos.inc'
5034       include 'epos.incems'
5035       include 'epos.incsem'
5036       common/cemsr5/at(0:1,0:6)
5037       common/cems5/plc,s
5038       common/cems10/a(0:ntypmx),b(0:ntypmx),d(0:ntypmx)
5039       common/ems6/ivp0,iap0,idp0,isp0,ivt0,iat0,idt0,ist0
5040       double precision d,a,b,plc,s,amd,dcel,xvpr,xdm,at,xdm2
5041       common/ems3/dcel,ad
5042       common/cems13/xvpr(0:3)
5043
5044 c abreviations
5045
5046       plc=dble(e)
5047       s=plc**2
5048       amd=dble(delrex)
5049
5050
5051 c alpha (0=0, 1=s, 2=v, 4=d, 8=f)
5052
5053       a(0)=0d0
5054       a(1)=dble(alpsea)
5055       a(2)=dble(alpval)
5056       a(3)= 0.0d0
5057       a(4)=dble(alpdiq)
5058       a(5)=dble(a(4))
5059       a(6)= 0.0d0
5060       a(7)= 0.0d0
5061       a(8)=dble(a(2))
5062       a(9)= 0.0d0
5063
5064 c beta (0=0, 1=s, 2=v, 4=d, 8=f)
5065
5066       b(0)=0.0d0
5067       b(1)=dble(-alpqua)
5068       b(2)=dble(-alpqua)
5069       b(3)=0.0d0
5070       b(4)=0.0d0
5071       b(5)=0.0d0
5072       b(6)=0.0d0
5073       b(7)=0.0d0
5074       b(8)=dble(-alpqua)
5075       b(9)=0.0d0
5076
5077
5078 c alpha_trailing and beta_trailing (0=meson, 1=baryon;
5079 c                                   0=no excit, 1=nondiffr, 2=diffr,
5080 c                                   6=nondiffr but no pomeron)
5081
5082       at(0,0)=0.0d0
5083       at(0,1)=dble(alpndi)
5084       at(0,2)=dble(alpdi)
5085       at(0,3)=dble(alpndi)
5086       at(0,6)=dble(alpndi)
5087       at(1,0)=0.0d0
5088       at(1,1)=dble(alpndi)
5089       at(1,2)=dble(alpdi)
5090       at(1,3)=dble(alpndi)
5091       at(1,6)=dble(alpndi)
5092
5093 c minimal string masses ( i+j, each one: 0=0, 1=s, 2=v, 4=d, 8=f)
5094
5095       ammn(0)=0d0
5096       ammn(1)=0d0
5097       ammn(2)=dble(ammsqq)+amd
5098       ammn(3)=dble(ammsqq)+amd
5099       ammn(4)=dble(ammsqq)+amd
5100       ammn(5)=dble(ammsqd)+amd
5101       ammn(6)=dble(ammsqd)+amd
5102       ammn(7)=0d0
5103       ammn(8)=dble(ammsdd)+amd
5104       ammn(9)=dble(ammsqd)+amd
5105       ammn(10)=dble(ammsqd)+amd
5106       ammn(12)=dble(ammsqd)+amd
5107       ammn(16)=0.14d0
5108
5109 c minimal pomeron masses (0=0, 1=softPom, 2=regge, 3=hard)
5110
5111       amprmn(0)=0d0
5112       amprmn(1)=0d0
5113       amprmn(2)=0d0
5114       amprmn(3)=dsqrt(4d0*dble(q2min))
5115
5116 c cutoff for virtual pomeron (0=0, 1=soft Pom, 2=regge, 3=hard)
5117
5118       xvpr(0)=0d0
5119       xvpr(1)=dble(cumpom**2)/s
5120       xvpr(2)=dble(cumpom**2)/s
5121       xvpr(3)=0.0d0**2/s
5122
5123 c minimal remnant masses (0=meson, 1=baryon)
5124
5125       xdm=0.35d0                  !<pt>
5126       call idmass(idpj,ampj)
5127       if(iabs(idpj).gt.1000)then
5128        ampmn(0)=0.14d0+xdm
5129        ampmn(1)=dble(ampj)+xdm
5130       else
5131        ampmn(0)=dble(ampj)+xdm
5132        ampmn(1)=0.94d0+xdm
5133       endif
5134       call idmass(idtg,amtg)
5135       if(iabs(idtg).gt.1000)then
5136        amtmn(0)=0.14d0+xdm
5137        amtmn(1)=dble(amtg)+xdm
5138       else
5139        amtmn(0)=dble(amtg)+xdm
5140        amtmn(1)=0.94d0+xdm
5141       endif
5142
5143 c minimal excitation masses (0=meson, 1=baryon
5144 c                            0=no excit, 1=nondiffr, 2=diffr,
5145 c                                   6=nondiffr but no pomeron)
5146
5147       xdm2=0.35d0
5148 c to take into account increase of mean pt in inelastic remnants
5149 c      if(isplit.eq.1)xdm=max(2d0*max(0d0,sqrt(log(s))-2.5d0),xdm)
5150       amemn(0,0)=0d0
5151       amemn(0,1)=xdm2+0.31d0
5152 c      amemn(0,1)=0d0
5153       amemn(0,2)=xdm2+0.31d0
5154 c      amemn(0,2)=0.d0
5155       amemn(0,3)=xdm2+0.31d0
5156 c      amemn(0,6)=xdm2+0.31d0
5157       amemn(0,6)=0.d0
5158 c      amemn(1,0)=0d0
5159       amemn(1,1)=xdm2+0.15d0 !+0.15d0
5160 c      amemn(1,1)=0d0
5161       amemn(1,2)=xdm2+0.15d0
5162 c      amemn(1,2)=0.d0
5163       amemn(1,3)=xdm2+0.15d0
5164 c      amemn(1,6)=xdm2+0.15d0
5165       amemn(1,6)=0.d0
5166
5167 c maximal excitation masses (0=no excit, 1=nondiffr, 2=diffr)
5168
5169       amemx(0)=2d0*xdm
5170       amemx(1)=plc
5171       amemx(2)=plc
5172
5173       if(idpj.gt.1000)then     ! baryon
5174
5175 c initial quark configuration
5176        ivp0=3
5177        iap0=0
5178        idp0=1
5179        isp0=0
5180
5181       elseif(idpj.lt.-1000)then     ! antibaryon
5182
5183 c initial quark configuration
5184        ivp0=0
5185        iap0=3
5186        idp0=1
5187        isp0=0
5188
5189       else      ! meson
5190
5191 c initial quark configuration
5192        ivp0=1
5193        iap0=1
5194        idp0=0
5195        isp0=0
5196
5197       endif
5198
5199       if(idtg.gt.1000)then    ! baryon
5200
5201 c initial quark configuration
5202        ivt0=3
5203        iat0=0
5204        idt0=1
5205        ist0=0
5206
5207       elseif(idtg.lt.-1000)then   ! antibaryon
5208
5209 c initial quark configuration
5210        ivt0=0
5211        iat0=3
5212        idt0=1
5213        ist0=0
5214
5215       else       ! meson
5216
5217 c initial quark configuration
5218        ivt0=1
5219        iat0=1
5220        idt0=0
5221        ist0=0
5222
5223       endif
5224
5225
5226 c eikonal parameters
5227
5228        dcel=dble(chad(iclpro)*chad(icltar))
5229
5230 c counters
5231
5232        antot=0.
5233        ansh=0.
5234        ansf=0.
5235        antotf=0.
5236        anshf=0.
5237        ansff=0.
5238        pp4max=0.
5239        pp4ini=0.
5240        andropl=0.
5241        anstrg0=0.
5242        anstrg1=0.
5243        anreso0=0.
5244        anreso1=0.
5245        anghadr=0.
5246        antotre=0.
5247        anintdiff=0.
5248        anintsdif=0.
5249        anintine=0.
5250
5251       return
5252       end
5253
5254 c-----------------------------------------------------------------------
5255       subroutine emsigr
5256 c-----------------------------------------------------------------------
5257 c initialize grid
5258 c-----------------------------------------------------------------------
5259
5260       include 'epos.inc'
5261       include 'epos.incems'
5262
5263       common/emsptl/nppr(npommx,kollmx),npproj(mamx),nptarg(mamx)
5264
5265       call utpri('emsigr',ish,ishini,5)
5266
5267       do k=1,koll  !----k-loop---->
5268
5269 c determine length of k-th line of grid
5270
5271        o=max(1.e-5,min(sngl(om1intc(k)),float(npommx)))!if GFF used for propo
5272         if(ish.ge.7)write(ifch,*)'emsigr:k,o',k,o
5273        n=0
5274        if(o.le.50)then
5275          p=1./(exp(o)-1)
5276        else
5277          p=0.
5278        endif
5279 10     n=n+1
5280        p=p*o/n
5281         if(ish.ge.7)write(ifch,*)'emsigr:n,p',n,p
5282        if((p.gt.1e-4.or.n.lt.int(o)).and.n.lt.npommx
5283      *.and.n.lt.nprmax)goto 10
5284
5285        if(ish.ge.5)write(ifch,*)'emsigr:nmax,b',n,bk(k)
5286
5287        npr(0,k)=n
5288        nprmx(k)=n
5289        nprt(k)=0
5290        do i=1,3
5291         npr(i,k)=0
5292        enddo
5293
5294
5295 c initial value for interaction type
5296
5297        itpr(k)=0
5298
5299 c initialize grid
5300
5301
5302        do n=1,nprmx(k)
5303         idpr(n,k)=0
5304         idfpr(n,k)=0
5305         ivpr(n,k)=1
5306         nppr(n,k)=0
5307         nbkpr(n,k)=0
5308         nvpr(n,k)=0
5309         idsppr(n,k)=0
5310         idstpr(n,k)=0
5311         idrpr(n,k)=0
5312         idhpr(n,k)=0
5313         bhpr(n,k)=0.
5314         xpr(n,k)=0d0
5315         ypr(n,k)=0d0
5316         xppr(n,k)=0d0
5317         xmpr(n,k)=0d0
5318         xp1pr(n,k)=0d0
5319         xp2pr(n,k)=0d0
5320         xm1pr(n,k)=0d0
5321         xm2pr(n,k)=0d0
5322         xp1pr(n,k)=0d0
5323         xp2pr(n,k)=0d0
5324         xm1pr(n,k)=0d0
5325         xm2pr(n,k)=0d0
5326         idp1pr(n,k)=0
5327         idp2pr(n,k)=0
5328         idm1pr(n,k)=0
5329         idm2pr(n,k)=0
5330         xxp1pr(n,k)=0d0
5331         xyp1pr(n,k)=0d0
5332         xxp2pr(n,k)=0d0
5333         xyp2pr(n,k)=0d0
5334         xxm1pr(n,k)=0d0
5335         xym1pr(n,k)=0d0
5336         xxm2pr(n,k)=0d0
5337         xym2pr(n,k)=0d0
5338        enddo
5339
5340       enddo !  <----k-loop-----
5341
5342       call utprix('emsigr',ish,ishini,5)
5343       return
5344       end
5345
5346 c-----------------------------------------------------------------------
5347       subroutine emsipt
5348 c-----------------------------------------------------------------------
5349 c initialize projectile and target
5350 c-----------------------------------------------------------------------
5351
5352       include 'epos.inc'
5353       include 'epos.incems'
5354
5355       common/emsptl/nppr(npommx,kollmx),npproj(mamx),nptarg(mamx)
5356       common/cems5/plc,s
5357       common/ems3/dcel,ad
5358       common/ems6/ivp0,iap0,idp0,isp0,ivt0,iat0,idt0,ist0
5359       common /cncl/xproj(mamx),yproj(mamx),zproj(mamx)
5360      *            ,xtarg(mamx),ytarg(mamx),ztarg(mamx)
5361
5362       double precision dcel,s,plc
5363
5364 c initialize projectile
5365
5366       do i=1,maproj
5367        idp(i)=idp0
5368        ivp(i)=ivp0
5369        iap(i)=iap0
5370        isp(i)=isp0
5371        iep(i)=-1
5372        ifp(i)=0
5373        kolp(i)=0
5374        npp(i)=0
5375        npproj(i)=0
5376        xxp(i)=0d0
5377        xyp(i)=0d0
5378        xpmn(i)=(amemn(idp(i),0)+ampmn(idp(i)))**2/s
5379        xpmx(i)=dmin1(1d0,(amemx(0)+ampmn(idp(i)))**2/s)
5380        xpos(i)=0.9d0*(amemx(0)+ampmn(idp(i)))**2/s
5381        xppmx(i)=0.5d0/(1d0+1d0/dble(maproj)**0.3d0)!1d0-dsqrt(xpmn(i))/maproj
5382        xmpmx(i)=0.5d0/(1d0+1d0/dble(matarg)**0.3d0)!1d0-dsqrt(xpmn(i))/matarg
5383        xmpmn(i)=xpmn(i)/xppmx(i)
5384        xppmn(i)=xpmn(i)/xmpmx(i)
5385        xpp(i)=1d0
5386        xmp(i)=0d0
5387        xppst(i)=0.d0
5388        xmpst(i)=0.d0
5389        xposst(i)=0.d0
5390       enddo
5391
5392 c initialize target
5393
5394       do j=1,matarg
5395        idt(j)=idt0
5396        ivt(j)=ivt0
5397        iat(j)=iat0
5398        ist(j)=ist0
5399        iet(j)=-1
5400        ift(j)=0
5401        kolt(j)=0
5402        npt(j)=0
5403        nptarg(j)=0
5404        xxt(j)=0d0
5405        xyt(j)=0d0
5406        xtmn(j)=(amemn(idt(j),0)+amtmn(idt(j)))**2/s
5407        xtmx(j)=dmin1(1d0,(amemx(0)+amtmn(idt(j)))**2/s)
5408        xtos(j)=0.9d0*(amemx(0)+amtmn(idt(j)))**2/s
5409        xmtmx(j)=0.5d0/(1d0+1d0/dble(matarg)**0.3d0)!1d0-dsqrt(xtmn(j))/matarg
5410        xptmx(j)=0.5d0/(1d0+1d0/dble(maproj)**0.3d0)!1d0-dsqrt(xtmn(j))/maproj
5411        xptmn(j)=xtmn(j)/xmtmx(j)
5412        xmtmn(j)=xtmn(j)/xptmx(j)
5413        xmt(j)=1d0
5414        xpt(j)=0d0
5415        xmtst(j)=0.d0
5416        xptst(j)=0.d0
5417        xtosst(j)=0.d0
5418       enddo
5419
5420       return
5421       end
5422
5423
5424 c-----------------------------------------------------------------------
5425       subroutine emszz
5426 c-----------------------------------------------------------------------
5427 c     completes /cptl/ for nucleons, checks for no interaction
5428 c     writes   /cevt/
5429 c-----------------------------------------------------------------------
5430       include 'epos.inc'
5431       include 'epos.incems'
5432       common/nucl3/phi,bimp
5433       common/col3/ncol,kolpt
5434       integer kolpz(mamx),koltz(mamx)
5435
5436       call utpri('emszz ',ish,ishini,6)
5437
5438 c     write /cptl/
5439 c     ------------
5440
5441       if(iokoll.eq.1)then   ! precisely matarg collisions
5442
5443 c nothing to do
5444
5445       else
5446
5447 c determine ncol
5448
5449        ncolx=ncol
5450        ncol=0
5451        ncoli=0
5452        do 8 k=1,koll
5453        if(ish.ge.7)write(ifch,*)'k,itpr,ncol,ncolx',k,itpr(k),ncol,ncolx
5454         if(itpr(k).eq.0)goto 8
5455         if(itpr(k).eq.1.or.itpr(k).eq.3)ncoli=ncoli+1
5456         ncol=ncol+1
5457         i=iproj(k)
5458         j=itarg(k)
5459         istptl(i)=1
5460         iorptl(i)=-1
5461         tivptl(2,i)=coord(4,k)
5462         istptl(maproj+j)=1
5463         iorptl(maproj+j)=-1
5464         tivptl(2,maproj+j)=coord(4,k)
5465 8      continue
5466        if(ncolx.ne.ncol)write(6,*)'ncolx,ncol:', ncolx,ncol
5467        if(ncolx.ne.ncol)call utstop('********ncolx.ne.ncol********&')
5468        if(ncol.eq.0)goto1001
5469
5470 c determine npj, ntg
5471
5472        do ip=1,maproj
5473         kolpz(ip)=0
5474        enddo
5475        do it=1,matarg
5476         koltz(it)=0
5477        enddo
5478       do k=1,koll
5479        if(itpr(k).gt.0)then
5480         ip=iproj(k)
5481         it=itarg(k)
5482         kolpz(ip)=kolpz(ip)+1
5483         koltz(it)=koltz(it)+1
5484        endif
5485       enddo
5486       npj=0
5487       do ip=1,maproj
5488        if(kolpz(ip).gt.0)npj=npj+1
5489       enddo
5490       ntg=0
5491       do it=1,matarg
5492        if(koltz(it).gt.0)ntg=ntg+1
5493       enddo
5494 c     write(6,*)'npj,ntg,npj+ntg:',npj,ntg,npj+ntg
5495
5496        endif
5497
5498 c     write /cevt/
5499 c     ------------
5500
5501       nevt=1
5502       bimevt=bimp
5503       phievt=phi
5504       kolevt=ncol
5505       koievt=ncoli
5506       npjevt=npj
5507       ntgevt=ntg
5508       pmxevt=pnll
5509       egyevt=engy
5510       !print*,' ===== ',kolevt,koievt,' ====='
5511
5512 c     exit
5513 c     ----
5514
5515       if(ish.ge.7)then
5516       do n=1,nptl
5517       write(ifch,115)iorptl(n),jorptl(n),n,istptl(n)
5518      *,tivptl(1,n),tivptl(2,n)
5519       enddo
5520   115 format(1x,'/cptl/',2i6,2i10,2(e10.3,1x))
5521       endif
5522
5523 1000  continue
5524       call utprix('emszz ',ish,ishini,6)
5525       return
5526
5527 1001  continue
5528       if(ish.ge.3)then
5529       write(ifch,*)
5530       write(ifch,*)'   ***** no interaction!!!'
5531       write(ifch,*)'   ***** ncol=0 detected in emszz'
5532       write(ifch,*)
5533       endif
5534       goto1000
5535
5536       end
5537
5538 c-----------------------------------------------------------------------
5539       subroutine ProCop(i,ii)
5540 c-----------------------------------------------------------------------
5541 c Propose Coordinates of remnants from active projectile nucleons
5542 c-----------------------------------------------------------------------
5543
5544       include 'epos.incems'
5545       include 'epos.inc'
5546
5547       double precision xmptmp,aproj
5548       common/cems5/plc,s
5549       common/emsptl/nppr(npommx,kollmx),npproj(mamx),nptarg(mamx)
5550       integer icrmn(2)
5551       double precision s,plc
5552
5553       nptl=nptl+1
5554       npproj(i)=nptl
5555       idptl(nptl)=idptl(ii)*100+99  !100*10**idp(i)+iep(i)
5556       istptl(nptl)=40
5557       ityptl(nptl)=40
5558       iorptl(nptl)=ii
5559       jorptl(nptl)=0
5560       ifrptl(1,nptl)=0
5561       ifrptl(2,nptl)=0
5562
5563       istptl(ii)=1
5564
5565 c     determine kolz
5566
5567       if(lproj(i).gt.1)then
5568         zmax=-ainfin
5569         kolz=0
5570         do l=1,lproj(i)
5571           k=kproj(i,l)
5572           z=coord(3,k)
5573           if(itpr(k).gt.0.and.z.gt.zmax)then
5574             zmax=z
5575             kolz=k
5576           endif
5577         enddo
5578       else
5579         kolz=1
5580       endif
5581 c      if(kolz.eq.0)call utstop(' kolz=0 (proj)&')
5582       if(kolz.eq.0)then
5583         t=0.
5584       else
5585         t=coord(4,kolz)
5586       endif
5587
5588       xorptl(1,nptl)=xorptl(1,ii)
5589       xorptl(2,nptl)=xorptl(2,ii)
5590       xorptl(3,nptl)=xorptl(3,ii)
5591       xorptl(4,nptl)=t
5592       tivptl(1,nptl)=t
5593       tivptl(2,nptl)=t
5594
5595       icrmn(1)=icproj(1,i)
5596       icrmn(2)=icproj(2,i)
5597       aproj=dble(max(amproj,fremnux2(icrmn)))
5598 c      aprojex=max(ampmn(idp(i))+amemn(idp(i),iep(i))
5599 c     &           ,dble(fremnux(icrmn)))
5600       xmptmp=(aproj**2+xxp(i)*xxp(i)+xyp(i)*xyp(i))
5601      &       /(xpp(i)*s)
5602       if(iep(i).eq.6)xmptmp=max(xmptmp,xmp(i))
5603       xpos(i)=1.1d0*xpp(i)*xmptmp
5604       if(xmptmp.gt.1.d0)then
5605         xmptmp=0.d0
5606       if(ish.ge.1)write(ifmt,*)'Warning in ProCop, Remnant mass too low'
5607       endif
5608
5609       pptl(1,nptl)=sngl(xxp(i))
5610       pptl(2,nptl)=sngl(xyp(i))
5611       pptl(3,nptl)=sngl((xpp(i)-xmptmp)*plc/2d0)
5612       pptl(4,nptl)=sngl((xpp(i)+xmptmp)*plc/2d0)
5613       pptl(5,nptl)=amproj
5614
5615 c      write(ifmt,*)'ProCop',i,nptl
5616
5617       return
5618
5619       end
5620
5621 c-----------------------------------------------------------------------
5622       subroutine ProCot(j,jj)
5623 c-----------------------------------------------------------------------
5624 c Propose Coordinates of remnants from active targets nucleons
5625 c-----------------------------------------------------------------------
5626
5627       include 'epos.inc'
5628       include 'epos.incems'
5629
5630       double precision xpttmp,atarg
5631       common/cems5/plc,s
5632       common/emsptl/nppr(npommx,kollmx),npproj(mamx),nptarg(mamx)
5633       integer icrmn(2)
5634       double precision s,plc
5635
5636       nptl=nptl+1
5637       nptarg(j)=nptl
5638
5639       idptl(nptl)=idptl(jj)*100+99    !100*10**idt(j)+iet(j)
5640       istptl(nptl)=40
5641       ityptl(nptl)=50
5642       iorptl(nptl)=jj
5643       jorptl(nptl)=0
5644       ifrptl(1,nptl)=0
5645       ifrptl(2,nptl)=0
5646
5647       istptl(jj)=1
5648
5649 c     determine kolz
5650
5651       if(ltarg(j).gt.1)then
5652         zmin=ainfin
5653         kolz=0
5654         do l=1,ltarg(j)
5655           k=ktarg(j,l)
5656           z=coord(3,k)
5657           if(itpr(k).gt.0.and.z.lt.zmin)then
5658             zmin=z
5659             kolz=k
5660           endif
5661         enddo
5662       else
5663         kolz=1
5664       endif
5665 c      if(kolz.eq.0)call utstop(' kolz=0 (targ)&')
5666       if(kolz.eq.0)then
5667         t=0.
5668       else
5669         t=coord(4,kolz)
5670       endif
5671
5672       xorptl(1,nptl)=xorptl(1,jj)
5673       xorptl(2,nptl)=xorptl(2,jj)
5674       xorptl(3,nptl)=xorptl(3,jj)
5675       xorptl(4,nptl)=t
5676       tivptl(1,nptl)=t
5677       tivptl(2,nptl)=t
5678
5679       icrmn(1)=ictarg(1,j)
5680       icrmn(2)=ictarg(2,j)
5681       atarg=dble(max(amtarg,fremnux2(icrmn)))
5682 c      atargex=max(amtmn(idt(j))+amemn(idt(j),iet(j))
5683 c     &           ,dble(fremnux(icrmn)))
5684       xpttmp=(atarg**2+xxt(j)*xxt(j)+xyt(j)*xyt(j))
5685      &       /(xmt(j)*s)
5686       if(iet(j).eq.6)xpttmp=max(xpttmp,xpt(j))
5687       xtos(j)=1.1d0*xpttmp*xmt(j)
5688       if(xpttmp.gt.1.d0)then
5689         xpttmp=0.d0
5690       if(ish.ge.1)write(ifch,*)'Warning in ProCot, Remnant mass too low'
5691       endif
5692
5693       pptl(1,nptl)=sngl(xxt(j))
5694       pptl(2,nptl)=sngl(xyt(j))
5695       pptl(3,nptl)=sngl((xpttmp-xmt(j))*plc/2d0)
5696       pptl(4,nptl)=sngl((xpttmp+xmt(j))*plc/2d0)
5697       pptl(5,nptl)=amtarg
5698
5699 c      write(ifmt,*)'ProCot',j,nptl
5700
5701       return
5702       end
5703
5704 c-----------------------------------------------------------------------
5705       subroutine emswrp(i,ii)
5706 c-----------------------------------------------------------------------
5707
5708       include 'epos.incems'
5709       include 'epos.inc'
5710
5711       double precision p5sq
5712       common/cems5/plc,s
5713       common/emsptl/nppr(npommx,kollmx),npproj(mamx),nptarg(mamx)
5714       double precision s,plc
5715       parameter(eps=1.e-5)
5716
5717       if(npproj(i).eq.0)then
5718         write(*,*)'emswrp i ii',i,ii
5719         call utstop('emswrp with npproj=0 should never happen !&')
5720
5721 c        t=xorptl(4,kolp(i))
5722 c        istptl(ii)=1
5723 c        iorptl(ii)=-1
5724 c        tivptl(2,ii)=t
5725 c        nptl=nptl+1
5726 c        npproj(i)=nptl
5727 c        idptl(nptl)=idptl(ii)*100+99 !100*10**idp(i)+iep(i)
5728 c        istptl(nptl)=40
5729 c        ityptl(nptl)=40
5730 c        iorptl(nptl)=ii
5731 c        jorptl(nptl)=kolp(i)
5732 c        ifrptl(1,nptl)=0
5733 c        ifrptl(2,nptl)=0
5734 c        xorptl(1,nptl)=xorptl(1,ii)
5735 c        xorptl(2,nptl)=xorptl(2,ii)
5736 c        xorptl(3,nptl)=xorptl(3,ii)
5737 c        xorptl(4,nptl)=t
5738 c        tivptl(1,nptl)=t
5739 c        tivptl(2,nptl)=t
5740 c        mm=nptl
5741 c        kolp(i)=1
5742       else
5743         mm=npproj(i)
5744       endif
5745       pptl(1,mm)=sngl(xxp(i))
5746       pptl(2,mm)=sngl(xyp(i))
5747       pptl(3,mm)=sngl((xpp(i)-xmp(i))*plc/2d0)
5748       pptl(4,mm)=sngl((xpp(i)+xmp(i))*plc/2d0)
5749       if(pptl(4,mm).lt.-eps)call utstop('E pro<0 !&')
5750       p5sq=xpp(i)*plc*xmp(i)*plc-xxp(i)*xxp(i)-xyp(i)*xyp(i)
5751       if(p5sq.gt.1.d-10)then
5752         pptl(5,mm)=sngl(dsqrt(p5sq))
5753       else
5754         if(ish.ge.2)then
5755           write(ifch,*)'problem with mass for projectile, '
5756      &         ,'continue with zero mass'
5757           write(ifch,*)i,mm,xxp(i),xyp(i),xpp(i),xmp(i),p5sq
5758         endif
5759         pptl(5,mm)=0.
5760       endif
5761
5762       do l=1,4
5763        ibptl(l,mm)=0
5764       enddo
5765
5766       return
5767
5768       end
5769
5770 c-----------------------------------------------------------------------
5771       subroutine emswrt(j,jj)
5772 c-----------------------------------------------------------------------
5773
5774       include 'epos.inc'
5775       include 'epos.incems'
5776
5777       double precision p5sq
5778       common/cems5/plc,s
5779       common/emsptl/nppr(npommx,kollmx),npproj(mamx),nptarg(mamx)
5780       double precision s,plc
5781       parameter(eps=1.e-5)
5782
5783       if(nptarg(j).eq.0)then
5784
5785         write(*,*)'emswrt j jj',j,jj
5786         call utstop('emswrt with nptarg=0 should never happen !&')
5787
5788 c        t=xorptl(4,kolt(j))
5789 c        istptl(jj)=1
5790 c        iorptl(jj)=-1
5791 c        tivptl(2,jj)=t
5792 c        nptl=nptl+1
5793 c        nptarg(j)=nptl
5794 c        idptl(nptl)=idptl(jj)*100+99 !100*10**idp(i)+iep(i)
5795 c        istptl(nptl)=40
5796 c        ityptl(nptl)=50
5797 c        iorptl(nptl)=jj
5798 c        jorptl(nptl)=kolt(j)
5799 c        ifrptl(1,nptl)=0
5800 c        ifrptl(2,nptl)=0
5801 c        xorptl(1,nptl)=xorptl(1,jj)
5802 c        xorptl(2,nptl)=xorptl(2,jj)
5803 c        xorptl(3,nptl)=xorptl(3,jj)
5804 c        xorptl(4,nptl)=t
5805 c        tivptl(1,nptl)=t
5806 c        tivptl(2,nptl)=t
5807 c        mm=nptl
5808 c        kolt(j)=1
5809       else
5810         mm=nptarg(j)
5811       endif
5812       pptl(1,mm)=sngl(xxt(j))
5813       pptl(2,mm)=sngl(xyt(j))
5814       pptl(3,mm)=sngl((xpt(j)-xmt(j))*plc/2d0)
5815       pptl(4,mm)=sngl((xpt(j)+xmt(j))*plc/2d0)
5816       if(pptl(4,mm).lt.-eps)call utstop('E targ<0 !&')
5817       p5sq=xpt(j)*plc*xmt(j)*plc-xxt(j)*xxt(j)-xyt(j)*xyt(j)
5818       if(p5sq.gt.1.d-10)then
5819         pptl(5,mm)=sngl(dsqrt(p5sq))
5820       else
5821         if(ish.ge.2)then
5822           write(ifch,*)'problem with mass for target, '
5823      &            ,'continue with zero mass'
5824           write(ifch,*)j,mm,xxt(j),xyt(j),xpt(j),xmt(j),p5sq
5825         endif
5826         pptl(5,mm)=0.
5827       endif
5828
5829       do l=1,4
5830        ibptl(l,mm)=0
5831       enddo
5832
5833       return
5834       end
5835
5836 c-----------------------------------------------------------------------
5837       subroutine emswrpom(k,i,j)
5838 c-----------------------------------------------------------------------
5839
5840       include 'epos.inc'
5841       include 'epos.incems'
5842
5843       common/cems5/plc,s
5844       common/emsptl/nppr(npommx,kollmx),npproj(mamx),nptarg(mamx)
5845       double precision s,px,py,plc
5846
5847       do 30 n=1,nprmx(k)
5848        if(idpr(n,k).eq.0.or.ivpr(n,k).eq.0)goto30
5849        nptl=nptl+1
5850        nppr(n,k)=nptl
5851        px=xxp1pr(n,k)+xxp2pr(n,k)+xxm1pr(n,k)+xxm2pr(n,k)
5852        py=xyp1pr(n,k)+xyp2pr(n,k)+xym1pr(n,k)+xym2pr(n,k)
5853        pptl(1,nptl)=sngl(px)
5854        pptl(2,nptl)=sngl(py)
5855        pptl(3,nptl)=sngl(dsqrt(xpr(n,k))*dsinh(ypr(n,k))*plc)
5856        pptl(4,nptl)=sngl(dsqrt(xpr(n,k))*dcosh(ypr(n,k))*plc)
5857        pptl(5,nptl)=sngl(dsqrt(xpr(n,k)*plc*plc-px*px-py*py))
5858    !    print*,pptl(5,nptl)/plc
5859        idptl(nptl)=idpr(n,k)*10000
5860      &     +idp1pr(n,k)*1000
5861      &     +idp2pr(n,k)*100
5862      &     +idm1pr(n,k)*10
5863      &     +idm2pr(n,k)
5864        idptl(nptl)=idptl(nptl)*100+99
5865        istptl(nptl)=30
5866        iorptl(nptl)=i
5867        jorptl(nptl)=j
5868        ifrptl(1,nptl)=0
5869        ifrptl(2,nptl)=0
5870        xorptl(1,nptl)=coord(1,k)
5871        xorptl(2,nptl)=coord(2,k)
5872        xorptl(3,nptl)=coord(3,k)
5873        xorptl(4,nptl)=coord(4,k)
5874        tivptl(1,nptl)=coord(4,k)
5875        tivptl(2,nptl)=coord(4,k)
5876        if(idpr(n,k).eq.1)then
5877         ityptl(nptl)=20
5878        elseif(idpr(n,k).eq.2)then
5879         ityptl(nptl)=25
5880        elseif(idpr(n,k).eq.3)then
5881         ityptl(nptl)=30
5882        else
5883         call utstop('emswrpom: unknown id&')
5884        endif
5885        do l = 1,4
5886         ibptl(l,nptl)=0
5887        enddo
5888 30    continue
5889
5890       return
5891       end
5892
5893 cc--------------------------------------------------------------------------
5894 c      subroutine reaction(idpj,idtg,ireac)
5895 cc--------------------------------------------------------------------------
5896 cc returns reaction code ireac
5897 cc--------------------------------------------------------------------------
5898 c      iap=iabs(idpj/10)
5899 c      iat=iabs(idtg/10)
5900 c      isp=idpj/10/iap
5901 c      ist=idtg/10/iat
5902 c      call idchrg(idpj,cp)
5903 c      call idchrg(idtg,ct)
5904 c      ac=abs(cp+ct)
5905 c      if(iap.gt.100)then
5906 c       if(iat.gt.100)then
5907 c        if(isp.eq.1)then
5908 c         if(ist.eq.1)then
5909 c          ireac=1
5910 c         else
5911 c          ireac=6
5912 c         endif
5913 c        else
5914 c         if(ist.eq.1)then
5915 c          ireac=6
5916 c         else
5917 c          ireac=1
5918 c         endif
5919 c        endif
5920 c       elseif(iat.eq.11.or.iat.eq.12.or.iat.eq.22)then
5921 c        if(ac.ge.2.)then
5922 c         ireac=2
5923 c        else
5924 c         ireac=3
5925 c        endif
5926 c       else
5927 c        if(ac.ge.2.)then
5928 c         ireac=4
5929 c        else
5930 c         ireac=5
5931 c        endif
5932 c       endif
5933 c      elseif(iap.eq.11.or.iap.eq.12.or.iap.eq.22)then
5934 c       if(iat.gt.100)then
5935 c        if(ac.ge.2.)then
5936 c         ireac=2
5937 c        else
5938 c         ireac=3
5939 c        endif
5940 c       elseif(iat.eq.11.or.iat.eq.12.or.iat.eq.22)then
5941 c        ireac=7
5942 c       else
5943 c        ireac=8
5944 c       endif
5945 c      else
5946 c       if(iat.gt.100)then
5947 c        if(ac.ge.2.)then
5948 c         ireac=4
5949 c        else
5950 c         ireac=5
5951 c        endif
5952 c       elseif(iat.eq.11.or.iat.eq.12.or.iat.eq.22)then
5953 c        ireac=8
5954 c       else
5955 c        ireac=9
5956 c       endif
5957 c      endif
5958 c
5959 c      end
5960 c
5961 c-----------------------------------------------------------------------
5962       subroutine xEmsI1(iii,kc,omlog)
5963 c-----------------------------------------------------------------------
5964 c plot omlog vs iter
5965 c plot  nr of pomerons vs iter
5966 c plot number of collisions vs iter
5967 c-----------------------------------------------------------------------
5968
5969       include 'epos.inc'
5970       include 'epos.incems'
5971       include 'epos.incsem'
5972
5973       parameter(nbin=100)
5974       common/cmc/ot(0:nbin),zz(0:nbin),i(0:nbin)
5975      *,yt1,yt2,kx(0:nbin)
5976       parameter(nbim=100)
5977       common/cmc1/xp(0:nbim),xt(0:nbim),x(0:nbim),o(0:nbim)
5978      *,y1,y2,car
5979       character car*5
5980       double precision xp,xt,x,omlog,om1intbc
5981       character ce*8
5982       double precision plc,s,seedp
5983       common/cems5/plc,s
5984
5985 c      if(iemsi2.eq.0)call utstop('ERROR in XemsI1: iemsi2 = 0&')
5986
5987        if(iii.eq.1)then
5988
5989       o(kc)=sngl(omlog)
5990       nptk=0
5991       kollx=0
5992       do ko=1,koll
5993       nptk=nptk+nprt(ko)
5994 c      if(itpr(ko).gt.0)then
5995       if(nprt(ko).gt.0)then
5996        kollx=kollx+1
5997       endif
5998       enddo
5999       zz(kc)=nptk
6000       kx(kc)=kollx
6001
6002         elseif(iii.eq.2)then
6003
6004       call ranfgt(seedp)
6005       sum=0
6006       kollx=0
6007       sumg=0
6008       kollg=0
6009       do ko=1,koll
6010 ctp060829       ip=iproj(ko)
6011 ctp060829       it=itarg(ko)
6012        om1i=sngl(om1intbc(bk(ko)))
6013 ctp060829         wk=1.
6014 ctp060829         wp=0.
6015 ctp060829         wt=0.
6016        om1g=sngl(om1intbc(bk(ko)))
6017        sum=sum+om1i
6018        sumg=sumg+om1g
6019        if(rangen().lt.1.-exp(-om1i))then
6020         kollx=kollx+1
6021        endif
6022        if(rangen().lt.1.-exp(-om1g))then
6023         kollg=kollg+1
6024        endif
6025       enddo
6026       call ranfst(seedp)
6027
6028       x1=0
6029       x2=nbin
6030       write(ce,'(f8.2)')sngl(plc)
6031
6032       write(ifhi,'(a)')       '!##################################'
6033       write(ifhi,'(a,i3)')    '!   log omega       for event ',nrevt+1
6034       write(ifhi,'(a)')       '!##################################'
6035       write(ifhi,'(a,i1)')    'openhisto name omega-',nrevt+1
6036       write(ifhi,'(a)')       'htyp lin'
6037       write(ifhi,'(a)')       'xmod lin ymod lin'
6038       write(ifhi,'(a,2e11.3)')'xrange',x1,x2
6039       write(ifhi,'(a)')       'yrange auto auto '
6040       write(ifhi,'(a)')    'text 0 0 "xaxis iteration"'
6041       write(ifhi,'(a)')    'text 0 0 "yaxis ln[W]"'
6042       write(ifhi,'(a,a)')  'text 0.5 0.90 "E ='//ce//'"'
6043       write(ifhi,'(a)')       'array 2'
6044          do k=0,nbim
6045       write(ifhi,'(2e11.3)')float(k),o(k)
6046          enddo
6047       write(ifhi,'(a)')    '  endarray'
6048       write(ifhi,'(a)')    'closehisto plot 0'
6049
6050       write(ifhi,'(a)')   '!##################################'
6051       write(ifhi,'(a,i3)')'! nr of coll`s  for event ',nrevt+1
6052       write(ifhi,'(a)')   '!##################################'
6053       write(ifhi,'(a,i1)')    'openhisto name coll-',nrevt+1
6054       write(ifhi,'(a)')       'htyp lin'
6055       write(ifhi,'(a)')       'xmod lin ymod lin'
6056       write(ifhi,'(a,2e11.3)')'xrange',x1,x2
6057       write(ifhi,'(a)')    'text 0 0 "xaxis iteration"'
6058       write(ifhi,'(a)')    'text 0 0 "yaxis nr of collisions"'
6059       write(ifhi,'(a)')       'array 2'
6060          do k=0,nbin
6061       write(ifhi,'(2e11.3)')float(k),float(kx(k))
6062          enddo
6063       write(ifhi,'(a)')    '  endarray'
6064       write(ifhi,'(a)')    'closehisto plot 0-'
6065       write(ifhi,'(a)')       'openhisto'
6066       write(ifhi,'(a)')       'htyp lin'
6067       write(ifhi,'(a)')       'array 2'
6068          do k=0,nbin
6069       write(ifhi,'(2e11.3)')float(k),float(kollx)
6070          enddo
6071       write(ifhi,'(a)')    '  endarray'
6072       write(ifhi,'(a)')    'closehisto plot 0-'
6073       write(ifhi,'(a)')       'openhisto'
6074       write(ifhi,'(a)')       'htyp lin'
6075       write(ifhi,'(a)')       'array 2'
6076          do k=0,nbin
6077       write(ifhi,'(2e11.3)')float(k),float(kollg)
6078          enddo
6079       write(ifhi,'(a)')    '  endarray'
6080       write(ifhi,'(a)')    'closehisto plot 0'
6081
6082       write(ifhi,'(a)')   '!##################################'
6083       write(ifhi,'(a,i3)')'! nr of pom`s  for event ',nrevt+1
6084       write(ifhi,'(a)')   '!##################################'
6085       write(ifhi,'(a,i1)')    'openhisto name pom-',nrevt+1
6086       write(ifhi,'(a)')       'htyp lin'
6087       write(ifhi,'(a)')       'xmod lin ymod lin'
6088       write(ifhi,'(a,2e11.3)')'xrange',x1,x2
6089       write(ifhi,'(a)')    'text 0 0 "xaxis iteration"'
6090       write(ifhi,'(a)')    'text 0 0 "yaxis nr of Pomerons"'
6091       write(ifhi,'(a)')       'array 2'
6092          do k=0,nbin
6093       write(ifhi,'(2e11.3)')float(k),zz(k)
6094          enddo
6095       write(ifhi,'(a)')    '  endarray'
6096       if(sum.lt.4*zz(nbin))then
6097       write(ifhi,'(a)')    'closehisto plot 0-'
6098       write(ifhi,'(a)')       'openhisto'
6099       write(ifhi,'(a)')       'htyp lin'
6100       write(ifhi,'(a)')       'array 2'
6101          do k=0,nbin
6102       write(ifhi,'(2e11.3)')float(k),sum
6103          enddo
6104       write(ifhi,'(a)')    '  endarray'
6105       write(ifhi,'(a)')    'closehisto plot 0-'
6106       write(ifhi,'(a)')       'openhisto'
6107       write(ifhi,'(a)')       'htyp lin'
6108       write(ifhi,'(a)')       'array 2'
6109          do k=0,nbin
6110       write(ifhi,'(2e11.3)')float(k),sumg
6111          enddo
6112       write(ifhi,'(a)')    '  endarray'
6113       endif
6114       write(ifhi,'(a)')    'closehisto plot 0'
6115
6116         endif
6117
6118       return
6119       end
6120
6121 c-----------------------------------------------------------------------
6122       subroutine xEmsI2(iii,kc)
6123 c-----------------------------------------------------------------------
6124 c plot quanities vs iter
6125 c   plot 1: <x> for Pomeron vs iter
6126 c   plot 2: <x> for projectile vs iter
6127 c   plot 3: <x> for target vs iter
6128 c arguments:
6129 c   iii:   modus (1,2)
6130 c   kc:    iteration step
6131 c   omega: config probability
6132 c-----------------------------------------------------------------------
6133
6134       include 'epos.inc'
6135       include 'epos.incems'
6136
6137       parameter(nbim=100)
6138       common/cmc1/xp(0:nbim),xt(0:nbim),x(0:nbim),o(0:nbim)
6139      *,y1,y2,car
6140       character car*5
6141       double precision xp,xt,x,xpo,xpj,xtg
6142       common/cemsi2/xpo,xpj,xtg
6143
6144         if(iii.eq.1)then
6145
6146       npom=0
6147       xpo=0
6148       do k=1,koll
6149 c       ip=iproj(k)
6150 c       it=itarg(k)
6151        if(nprmx(k).gt.0)then
6152         do n=1,nprmx(k)
6153          if(idpr(n,k).gt.0.and.ivpr(n,k).gt.0)then
6154           xpo=xpo+xpr(n,k)
6155           npom=npom+1
6156          endif
6157         enddo
6158        endif
6159       enddo
6160       if(npom.gt.0)xpo=xpo/npom
6161
6162       npk=0
6163       xpj=0d0
6164       do i=1,maproj
6165        if(xpp(i).lt.0.999)then
6166         xpj=xpj+xpp(i)!*xmp(i)
6167         npk=npk+1
6168        endif
6169       enddo
6170       if(npk.gt.0)xpj=xpj/dble(npk)
6171
6172       ntk=0
6173       xtg=0d0
6174       do j=1,matarg
6175        if(xmt(j).lt.0.999)then
6176         xtg=xtg+xmt(j)!*xpt(j)
6177         ntk=ntk+1
6178        endif
6179       enddo
6180       if(ntk.gt.0)xtg=xtg/dble(ntk)
6181
6182       x(kc)=xpo
6183       xp(kc)=xpj
6184       xt(kc)=xtg
6185
6186         elseif(iii.eq.2)then
6187
6188       x1=0
6189       x2=nbim
6190
6191       write(ifhi,'(a)')       '!##################################'
6192       write(ifhi,'(a,i3)')    '!   average x  Pom   for event ',nrevt+1
6193       write(ifhi,'(a)')       '!##################################'
6194       write(ifhi,'(a,i1)')    'openhisto name avxPom-',nrevt+1
6195       write(ifhi,'(a)')       'htyp lin'
6196       write(ifhi,'(a)')       'xmod lin ymod lin'
6197       write(ifhi,'(a,2e11.3)')'xrange',x1,x2
6198       write(ifhi,'(a)')    'text 0 0 "xaxis iteration"'
6199       write(ifhi,'(a)')    'text 0 0 "yaxis average x Pomeron"'
6200       write(ifhi,'(a)')       'array 2'
6201          do k=0,nbim
6202       write(ifhi,'(2e11.3)')float(k),x(k)
6203          enddo
6204       write(ifhi,'(a)')    '  endarray'
6205       write(ifhi,'(a)')    'closehisto plot 0'
6206
6207       write(ifhi,'(a)')       '!##################################'
6208       write(ifhi,'(a,i3)')    '!   average x proj   for event ',nrevt+1
6209       write(ifhi,'(a)')       '!##################################'
6210       write(ifhi,'(a,i1)')    'openhisto name avxProj-',nrevt+1
6211       write(ifhi,'(a)')       'htyp lin'
6212       write(ifhi,'(a)')       'xmod lin ymod lin'
6213       write(ifhi,'(a,2e11.3)')'xrange',x1,x2
6214       write(ifhi,'(a)')    'text 0 0 "xaxis iteration"'
6215       write(ifhi,'(a)')    'text 0 0 "yaxis average x proj"'
6216       write(ifhi,'(a)')       'array 2'
6217          do k=0,nbim
6218       write(ifhi,'(2e11.3)')float(k),xp(k)
6219          enddo
6220       write(ifhi,'(a)')    '  endarray'
6221       write(ifhi,'(a)')    'closehisto plot 0'
6222
6223       write(ifhi,'(a)')       '!##################################'
6224       write(ifhi,'(a,i3)')    '!   average x targ   for event ',nrevt+1
6225       write(ifhi,'(a)')       '!##################################'
6226       write(ifhi,'(a,i1)')    'openhisto name avxTarg-',nrevt+1
6227       write(ifhi,'(a)')       'htyp lin'
6228       write(ifhi,'(a)')       'xmod lin ymod lin'
6229       write(ifhi,'(a,2e11.3)')'xrange',x1,x2
6230       write(ifhi,'(a)')    'text 0 0 "xaxis iteration"'
6231       write(ifhi,'(a)')    'text 0 0 "yaxis average x targ"'
6232       write(ifhi,'(a)')       'array 2'
6233          do k=0,nbim
6234       write(ifhi,'(2e11.3)')float(k),xt(k)
6235          enddo
6236       write(ifhi,'(a)')    '  endarray'
6237       write(ifhi,'(a)')    'closehisto plot 0'
6238         endif
6239
6240       return
6241       end
6242
6243 c-----------------------------------------------------------------------
6244       subroutine xEmsRx(iii,id,xp,xm)
6245 c-----------------------------------------------------------------------
6246 c plot  x+, x-, x, y distribution of remnants
6247 c-----------------------------------------------------------------------
6248
6249       include 'epos.inc'
6250
6251       parameter(nbix=50,nbiy=50,nid=2)
6252       common/cxp/nxp(nid),nxm(nid),nx(nid),ny(nid)
6253      *,wxp(nbix,nid),wxm(nbix,nid),wx(nbix,nid),wy(nbiy,nid)
6254      *,xpu,xpo,xmu,xmo,xu,xo,yu,yo,dy
6255
6256       if(iemsrx.eq.0)call utstop('ERROR in XemsRx: iemsrx = 0&')
6257
6258         if(iii.eq.0)then
6259
6260       xpu=10/engy**2
6261       xpo=1
6262       xmu=10/engy**2
6263       xmo=1
6264       xu=10/engy**2
6265       xo=1
6266       yu=-alog(engy**2)
6267       yo=alog(engy**2)
6268       dy=(yo-yu)/nbiy
6269       do j=1,nid
6270        nxp(j)=0
6271        nxm(j)=0
6272        nx(j)=0
6273        do i=1,nbix
6274         wxp(i,j)=0
6275         wxm(i,j)=0
6276         wx(i,j)=0
6277        enddo
6278        ny(j)=0
6279        do i=1,nbiy
6280         wy(i,j)=0
6281        enddo
6282       enddo
6283
6284         elseif(iii.eq.1)then
6285
6286       i=0
6287       if(xp.lt.xpu)goto1
6288       i=1+int(alog(xp/xpu)/alog(xpo/xpu)*nbix)
6289       if(i.gt.nbix)goto1
6290       if(i.lt.1)goto1
6291       wxp(i,id)=wxp(i,id)+1
6292       nxp(id)=nxp(id)+1
6293 1     continue
6294
6295       if(xm.lt.xmu)goto2
6296       i=1+int(alog(xm/xmu)/alog(xmo/xmu)*nbix)
6297       if(i.gt.nbix)goto2
6298       if(i.lt.1)goto2
6299       wxm(i,id)=wxm(i,id)+1
6300       nxm(id)=nxm(id)+1
6301 2     continue
6302
6303       x=xp*xm
6304       if(x.lt.xu)goto3
6305       i=1+int(alog(x/xu)/alog(xo/xu)*nbix)
6306       if(i.gt.nbix)goto3
6307       if(i.lt.1)goto3
6308       wx(i,id)=wx(i,id)+1
6309       nx(id)=nx(id)+1
6310 3     continue
6311
6312       if(xm.le.0.)goto4
6313       if(xp.le.0.)goto4
6314       y=0.5*alog(xp/xm)
6315       if(y.lt.yu)goto4
6316       i=int((y-yu)/dy)+1
6317       if(i.gt.nbiy)goto4
6318       if(i.lt.1)goto4
6319       wy(i,id)=wy(i,id)+1
6320       ny(id)=ny(id)+1
6321 4     continue
6322
6323         elseif(iii.eq.2)then
6324
6325       do j=1,nid
6326       if(j.eq.1)iclrem=iclpro
6327       if(j.eq.2)iclrem=icltar
6328       write(ifhi,'(a)')      '!----------------------------------'
6329       write(ifhi,'(a)')      '!   remnant xp distribution      '
6330       write(ifhi,'(a)')      '!----------------------------------'
6331       write(ifhi,'(a,i1)')    'openhisto name xpRemnant-',j
6332       write(ifhi,'(a)')       'htyp lin'
6333       write(ifhi,'(a)')       'xmod log ymod log'
6334       write(ifhi,'(a,2e11.3)')'xrange',xpu,xpo
6335       write(ifhi,'(a)')    'text 0 0 "xaxis remnant x+"'
6336       write(ifhi,'(a)')    'text 0 0 "yaxis P(x+)"'
6337       write(ifhi,'(a)')       'array 2'
6338          do i=1,nbix
6339       x=xpu*(xpo/xpu)**((i-0.5)/nbix)
6340       dx=xpu*(xpo/xpu)**(1.*i/nbix)*(1.-(xpo/xpu)**(-1./nbix))
6341       if(nxp(j).ne.0)write(ifhi,'(2e11.3)')x,wxp(i,j)/dx/nxp(j)
6342       if(nxp(j).eq.0)write(ifhi,'(2e11.3)')x,0.
6343          enddo
6344       write(ifhi,'(a)')    '  endarray'
6345       write(ifhi,'(a)')    'closehisto plot 0-'
6346       write(ifhi,'(a)')       'openhisto'
6347       write(ifhi,'(a)')       'htyp lin'
6348       write(ifhi,'(a)')       'array 2'
6349          do i=1,nbix
6350       x=xu*(xo/xu)**((i-0.5)/nbix)
6351       write(ifhi,'(2e11.3)')x,x**alplea(iclrem)*(1+alplea(iclrem))
6352          enddo
6353       write(ifhi,'(a)')    '  endarray'
6354       write(ifhi,'(a)')    'closehisto plot 0'
6355
6356       write(ifhi,'(a)')      '!----------------------------------'
6357       write(ifhi,'(a)')      '!   remnant xm distribution      '
6358       write(ifhi,'(a)')      '!----------------------------------'
6359       write(ifhi,'(a,i1)')    'openhisto name xmRemnant-',j
6360       write(ifhi,'(a)')       'htyp lin'
6361       write(ifhi,'(a)')       'xmod log ymod log'
6362       write(ifhi,'(a,2e11.3)')'xrange',xmu,xmo
6363       write(ifhi,'(a)')    'text 0 0 "xaxis remnant x-"'
6364       write(ifhi,'(a)')    'text 0 0 "yaxis P(x-)"'
6365       write(ifhi,'(a)')       'array 2'
6366          do i=1,nbix
6367       x=xmu*(xmo/xmu)**((i-0.5)/nbix)
6368       dx=xmu*(xmo/xmu)**(1.*i/nbix)*(1.-(xmo/xmu)**(-1./nbix))
6369       if(nxm(j).ne.0)write(ifhi,'(2e11.3)')x,wxm(i,j)/dx/nxm(j)
6370       if(nxm(j).eq.0)write(ifhi,'(2e11.3)')x,0.
6371          enddo
6372       write(ifhi,'(a)')    '  endarray'
6373       write(ifhi,'(a)')    'closehisto plot 0'
6374
6375       write(ifhi,'(a)')      '!----------------------------------'
6376       write(ifhi,'(a)')      '!   remnant x distribution      '
6377       write(ifhi,'(a)')      '!----------------------------------'
6378       write(ifhi,'(a,i1)')    'openhisto name xRemnant-',j
6379       write(ifhi,'(a)')       'htyp lin'
6380       write(ifhi,'(a)')       'xmod log ymod log'
6381       write(ifhi,'(a,2e11.3)')'xrange',xu,xo
6382       write(ifhi,'(a)')    'text 0 0 "xaxis remnant x"'
6383       write(ifhi,'(a)')    'text 0 0 "yaxis P(x)"'
6384       write(ifhi,'(a)')       'array 2'
6385          do i=1,nbix
6386       x=xu*(xo/xu)**((i-0.5)/nbix)
6387       dx=xu*(xo/xu)**(1.*i/nbix)*(1.-(xo/xu)**(-1./nbix))
6388       if(nx(j).ne.0)write(ifhi,'(2e11.3)')x,wx(i,j)/dx/nx(j)
6389       if(nx(j).eq.0)write(ifhi,'(2e11.3)')x,0.
6390          enddo
6391       write(ifhi,'(a)')    '  endarray'
6392       write(ifhi,'(a)')    'closehisto plot 0'
6393
6394       write(ifhi,'(a)')      '!----------------------------------'
6395       write(ifhi,'(a)')      '!   remnant y distribution      '
6396       write(ifhi,'(a)')      '!----------------------------------'
6397       write(ifhi,'(a,i1)')    'openhisto name yRemnant-',j
6398       write(ifhi,'(a)')       'htyp lin'
6399       write(ifhi,'(a)')       'xmod lin ymod log'
6400       write(ifhi,'(a,2e11.3)')'xrange',yu,yo
6401       write(ifhi,'(a)')    'text 0 0 "xaxis remnant y"'
6402       write(ifhi,'(a)')    'text 0 0 "yaxis P(y)"'
6403       write(ifhi,'(a)')       'array 2'
6404          do i=1,nbix
6405       y=yu+dy/2.+(i-1)*dy
6406       if(ny(j).ne.0)write(ifhi,'(2e11.3)')y,wy(i,j)/dy/ny(j)
6407       if(ny(j).eq.0)write(ifhi,'(2e11.3)')y,0.
6408          enddo
6409       write(ifhi,'(a)')    '  endarray'
6410       write(ifhi,'(a)')    'closehisto plot 0'
6411
6412       enddo
6413
6414         endif
6415
6416       return
6417       end
6418
6419 c-----------------------------------------------------------------------
6420       subroutine xEmsPm(iii,ko,nmc)
6421 c-----------------------------------------------------------------------
6422 c m (pomeron number) distribution for different b-bins.
6423 c arguments:
6424 c   iii:  modus (0,1,2)
6425 c   ko:   pair number (1 - AB)
6426 c   nmc:  number of pomerons
6427 c-----------------------------------------------------------------------
6428       include 'epos.inc'
6429       include 'epos.incems'
6430       common/geom/rmproj,rmtarg,bmax,bkmx
6431       parameter(nbin=npommx)
6432       parameter(nbib=32)
6433       common/cn/wn(0:nbin,nbib),wnmc(0:nbin,nbib),npmx(nbib),nn(nbib)
6434      &         ,nn2(nbib)
6435       common/cb1/db,b1,b2,bb(nbib),nbibx
6436       double precision plc,s,om1intbc
6437       character ce*8,cb*4
6438       common/cems5/plc,s
6439       common/cemspm/sumb(nbib)
6440
6441       if(iemspm.eq.0)call utstop('ERROR in XemsPm: iemspm = 0&')
6442
6443         if(iii.eq.0)then
6444
6445       do k=1,nbib
6446        nn(k)=0
6447        nn2(k)=0
6448        sumb(k)=0
6449        do i=0,nbin
6450         wnmc(i,k)=0
6451        enddo
6452       enddo
6453       nbibx=6
6454       b1=0
6455       b2=2
6456       db=(b2-b1)/nbibx
6457
6458
6459         elseif(iii.eq.1)then
6460
6461       k=int((bk(ko)-b1)/db)+1
6462       if(k.gt.nbibx)k=nbibx
6463       if(k.lt.1)k=1
6464       if(nmc.gt.nbin)return
6465       if(nmc.lt.0)return
6466       nn(k)=nn(k)+1
6467       wnmc(nmc,k)=wnmc(nmc,k)+1
6468       sumb(k)=sumb(k)+bk(ko)
6469
6470
6471         elseif(iii.eq.2)then
6472
6473       do 1 k=1,nbibx
6474
6475        bb(k)=b1+(k-0.5)*db
6476        if(maproj.eq.1.and.matarg.eq.1.and.bmaxim.eq.0.)bb(k)=b1
6477        om1i=sngl(om1intbc(bb(k)))
6478        do i=0,nbin
6479         if(i.eq.0)then
6480          wn(i,k)=exp(-om1i)
6481         else
6482          wn(i,k)=wn(i-1,k)*om1i/i
6483         endif
6484        if(wn(i,k).gt.0.000001*(1.-exp(-om1i)))npmx(k)=i
6485        enddo
6486
6487       write(ifhi,'(a)')   '!##################################'
6488       write(ifhi,'(a)')   '! distr of Pomeron number vs b'
6489       write(ifhi,'(a)')   '!##################################'
6490       write(ce,'(f8.2)')sngl(plc)
6491       write(cb,'(f4.2)')bb(k)
6492       if(nn(k).gt.0)then
6493       write(ifhi,'(a,i1)')    'openhisto name mPom-',k
6494       write(ifhi,'(a)')       'htyp lru'
6495       write(ifhi,'(a)')       'xmod lin ymod log'
6496       write(ifhi,'(a,2e11.3)')'xrange',0.,float(npmx(k))
6497       write(ifhi,'(a)')    'text 0 0 "xaxis number m of Pomerons"'
6498       write(ifhi,'(a)')    'text 0 0 "yaxis prob(m)"'
6499       if(k.eq.1)
6500      *write(ifhi,'(a,a)')     'text 0.5 0.90 "E ='//ce//'"'
6501       write(ifhi,'(a,a)')     'text 0.5 0.80 "b ='//cb//'"'
6502       write(ifhi,'(a)')       'array 2'
6503          do i=0,nbin
6504       write(ifhi,'(2e11.3)')float(i),wnmc(i,k)/max(1,nn(k))
6505          enddo
6506       write(ifhi,'(a)')    '  endarray'
6507       write(ifhi,'(a)')    'closehisto plot 0-'
6508       endif
6509
6510       write(ifhi,'(a)')   '!##################################'
6511       write(ifhi,'(a)')   '! distr of Pomeron number vs b'
6512       write(ifhi,'(a)')   '!   traditional approach'
6513       write(ifhi,'(a)')   '!##################################'
6514       write(ifhi,'(a,i1)')    'openhisto name mPomTradi-',k
6515       write(ifhi,'(a)')       'htyp lba'
6516       write(ifhi,'(a)')       'xmod lin ymod log'
6517       write(ifhi,'(a,2e11.3)')'xrange',0.,float(npmx(k))
6518       write(ifhi,'(a)')       'array 2'
6519          do i=0,nbin
6520       write(ifhi,'(2e11.3)')float(i),wn(i,k)
6521          enddo
6522       write(ifhi,'(a)')    '  endarray'
6523       write(ifhi,'(a)')    'closehisto plot 0'
6524
6525  1    continue
6526
6527
6528       endif
6529
6530       return
6531       end
6532
6533 c-----------------------------------------------------------------------
6534       subroutine xEmsB(iii,jjj,ko)
6535 c-----------------------------------------------------------------------
6536 c b distribution at different stages
6537 c arguments:
6538 c   iii:  modus (0,1,2)
6539 c   jjj:  stage or type of interaction
6540 c     just after Metropolis:
6541 c           1 ... all
6542 c           2 ... interaction
6543 c     after defining diffraction:
6544 c           3 ... nothing
6545 c           4 ... cut
6546 c           5 ... diffr
6547 c           6 ... cut + diffr
6548 c   ko:   pair number (1 - AB)
6549 c-----------------------------------------------------------------------
6550       include 'epos.inc'
6551       include 'epos.incems'
6552       include 'epos.incsem'
6553       parameter(njjj=6)
6554       parameter(nbib=32)
6555       common/cxemsb1/w(0:njjj,nbib),nn(njjj)
6556       common/cxemsb2/db,b1,b2
6557       common/cxemsb3/njjj1
6558       double precision PhiExact,om1intbi,PhiExpo!,PhiUnit
6559       common/geom/rmproj,rmtarg,bmax,bkmx
6560       dimension uua2(nbib),uuo2(nbib),uu3(nbib)
6561
6562       if(iemsb.eq.0)call utstop('ERROR in XemsB: iemsB = 0&')
6563
6564         if(iii.eq.0)then
6565
6566       do k=1,nbib
6567        do j=0,njjj
6568         w(j,k)=0
6569        enddo
6570       enddo
6571       do j=1,njjj
6572        nn(j)=0
6573       enddo
6574       njjj1=0
6575
6576         elseif(iii.eq.1)then
6577
6578       b1=0
6579       b2=bkmx*1.2
6580       db=(b2-b1)/nbib
6581       k=int((bk(ko)-b1)/db)+1
6582       if(k.gt.nbib)return
6583       if(k.lt.1)return
6584       w(jjj,k)=w(jjj,k)+1
6585       nn(jjj)=nn(jjj)+1
6586       if(jjj.eq.1)njjj1=1
6587
6588         elseif(iii.eq.2)then
6589
6590       if(njjj1.ne.1)call utstop
6591      &('xEmsB must be called also with jjj=1&')
6592       ymax=0
6593       kollini=koll
6594       koll=1
6595       do k=1,nbib
6596        x=b1+(k-0.5)*db
6597        y=w(1,k)/nn(1)/(pi*((x+0.5*db)**2-(x-0.5*db)**2))
6598        ymax=max(ymax,y)
6599       enddo
6600       fk=bkmx**2*pi
6601       ymax=1.4
6602
6603       do 1 j=1,njjj
6604        if(nn(j).eq.0)goto1
6605
6606       write(ifhi,'(a)')   '!##################################'
6607       write(ifhi,'(a)')   '! b distr exact theory '
6608       write(ifhi,'(a)')   '!##################################'
6609          if(j.ge.2.and.j.le.6)then
6610       write(ifhi,'(a,i1,a)')  'openhisto name b',j,'Exact'
6611       write(ifhi,'(a)')       'htyp lba xmod lin ymod lin'
6612       write(ifhi,'(a)')    'text 0 0 "xaxis impact parameter b"'
6613       write(ifhi,'(a)')    'text 0 0 "yaxis P(b)"'
6614       write(ifhi,'(a)')       'array 2'
6615          do k=1,nbib
6616       b=b1+(k-0.5)*db
6617       if(j.eq.2)then
6618         uuo2(k)=sngl(PhiExpo(1.,1.d0,1.d0,engy**2,b))
6619         uua2(k)=min(uuo2(k),max(0.,
6620      &          sngl(PhiExact(1.,1.d0,1.d0,engy**2,b))))
6621         uu3(k)=sngl(min(50d0,exp(om1intbi(b,2)/dble(r2hads(iclpro)
6622      &                                             +r2hads(icltar)))))
6623       endif
6624       if(j.eq.2)y=(1.-uua2(k))
6625       if(j.eq.3)y=uua2(k)
6626       if(j.eq.4)y=(1.-uua2(k)*uu3(k))
6627       if(j.eq.5)y=uua2(k)*(uu3(k)-1.)
6628       if(j.eq.6)y=(1.-uua2(k))
6629       write(ifhi,'(2e11.3)')b,y
6630          enddo
6631       write(ifhi,'(a)')    '  endarray'
6632       write(ifhi,'(a)')    'closehisto plot 0-'
6633          endif
6634       write(ifhi,'(a)')   '!##################################'
6635       write(ifhi,'(a)')   '! b distr unitarized theory '
6636       write(ifhi,'(a)')   '!##################################'
6637       write(ifhi,'(a,i1,a)')  'openhisto name b',j,'Unit'
6638       write(ifhi,'(a)')       'htyp lbf xmod lin ymod lin'
6639       write(ifhi,'(a)')    'text 0 0 "xaxis impact parameter b"'
6640       write(ifhi,'(a)')    'text 0 0 "yaxis P(b)"'
6641       write(ifhi,'(a)')       'array 2'
6642          do k=1,nbib
6643       b=b1+(k-0.5)*db
6644       if(j.eq.1)y=1
6645       if(j.eq.2)y=(1.-uuo2(k))
6646       if(j.eq.3)y=uuo2(k)
6647       if(j.eq.4)y=(1.-uuo2(k)*uu3(k))
6648       if(j.eq.5)y=uuo2(k)*(uu3(k)-1.)
6649       if(j.eq.6)y=(1.-uuo2(k))
6650       write(ifhi,'(2e11.3)')b,y
6651          enddo
6652       write(ifhi,'(a)')    '  endarray'
6653       write(ifhi,'(a)')    'closehisto plot 0-'
6654       write(ifhi,'(a)')   '!##################################'
6655       write(ifhi,'(a)')   '! b distr for cross section '
6656       write(ifhi,'(a)')   '!##################################'
6657       write(ifhi,'(a,i1,a)')  'openhisto name b',j,'Unit'
6658       write(ifhi,'(a)')       'htyp lge xmod lin ymod lin'
6659       write(ifhi,'(a)')    'text 0 0 "xaxis impact parameter b"'
6660       write(ifhi,'(a)')    'text 0 0 "yaxis P(b)"'
6661       write(ifhi,'(a)')       'array 2'
6662          do k=1,nbib
6663       b=b1+(k-0.5)*db
6664       if(j.eq.1)y=1
6665       if(j.eq.2)y=(1.-(uuo2(k)+uua2(k))*0.5)
6666       if(j.eq.3)y=(uuo2(k)+uua2(k))*0.5
6667       if(j.eq.4)y=(1.-(uuo2(k)+uua2(k))*0.5*uu3(k))
6668       if(j.eq.5)y=(uuo2(k)+uua2(k))*0.5*(uu3(k)-1.)
6669       if(j.eq.6)y=(1.-(uuo2(k)+uua2(k))*0.5)
6670       write(ifhi,'(2e11.3)')b,y
6671          enddo
6672       write(ifhi,'(a)')    '  endarray'
6673       write(ifhi,'(a)')    'closehisto plot 0-'
6674       write(ifhi,'(a)')   '!##################################'
6675       write(ifhi,'(a)')   '! b distribution simulation'
6676       write(ifhi,'(a)')   '!##################################'
6677       write(ifhi,'(a,i1,a)')  'openhisto name b',j,'Simu'
6678       write(ifhi,'(a)')       'htyp lrf xmod lin ymod lin'
6679       write(ifhi,'(a,2e11.3)')'xrange',0.0,b2
6680       write(ifhi,'(a,2e11.3)')'yrange',0.,ymax
6681       write(ifhi,'(a)')    'text 0 0 "xaxis impact parameter b"'
6682       write(ifhi,'(a)')    'text 0 0 "yaxis P(b)"'
6683       if(j.eq.1)write(ifhi,'(a)')'text 0.1 0.35 "after Metropolis"'
6684       if(j.eq.1)write(ifhi,'(a)')'text 0.2 0.20 "all "'
6685       if(j.eq.2)write(ifhi,'(a)')'text 0.3 0.85 "after Metropolis"'
6686       if(j.eq.2)write(ifhi,'(a)')'text 0.5 0.70 "interaction "'
6687       if(j.eq.3)write(ifhi,'(a)')'text 0.3 0.85 "nothing"'
6688       if(j.eq.4)write(ifhi,'(a)')'text 0.3 0.85 "cut"'
6689       if(j.eq.5)write(ifhi,'(a)')'text 0.3 0.85 "diffr"'
6690       if(j.eq.6)write(ifhi,'(a)')'text 0.3 0.85 "cut + diffr"'
6691       write(ifhi,'(a)')       'array 2'
6692          do k=1,nbib
6693       x=b1+(k-0.5)*db
6694       if(j.eq.1)y=fk*w(j,k)/nn(1)/(pi*((x+0.5*db)**2-(x-0.5*db)**2))
6695       if(j.ne.1)y=0.
6696       if(j.ne.1.and.w(1,k).ne.0.)y=w(j,k)/w(1,k)
6697       if(nn(j).gt.0)write(ifhi,'(2e11.3)')x,y
6698          enddo
6699       write(ifhi,'(a)')    '  endarray'
6700       write(ifhi,'(a)')    'closehisto plot 0'
6701
6702    1  continue
6703
6704       koll=kollini
6705
6706       endif
6707
6708       return
6709       end
6710
6711 c-----------------------------------------------------------------------
6712       subroutine xEmsBg(iii,jjj,ko)
6713 c-----------------------------------------------------------------------
6714 c b distribution at different stages for different group
6715 c arguments:
6716 c   iii:  modus (0,1,2,3)
6717 c   jjj:  group of interaction (1,2 ... ,7)
6718 c   ko:   pair number (1 - AB)
6719 c-----------------------------------------------------------------------
6720       include 'epos.inc'
6721       include 'epos.incems'
6722       parameter(njjj=7)
6723       parameter(nbib=16)
6724       common/cxemsb4/wg(-1:njjj,nbib),nng(nbib),uug(nbib),kollx
6725       common/cxemsb5/dbg,b1g,b2g
6726       common/cxemsb6/njjj0
6727       double precision seedp,PhiExpo!,PhiExact
6728       common/geom/rmproj,rmtarg,bmax,bkmx
6729
6730       if(iemsbg.eq.0)call utstop('ERROR in XemsBg: iemsbg = 0&')
6731
6732         if(iii.eq.0)then
6733
6734       do k=1,nbib
6735        nng(k)=0
6736        do j=-1,njjj
6737         wg(j,k)=0
6738        enddo
6739       enddo
6740       njjj0=0
6741       kollx=0
6742
6743         elseif(iii.eq.1)then
6744
6745       b1g=0
6746       b2g=bkmx*1.2
6747       dbg=(b2g-b1g)/nbib
6748       k=int((bk(ko)-b1g)/dbg)+1
6749       if(k.gt.nbib)return
6750       if(k.lt.1)return
6751       if(jjj.eq.-1.or.jjj.eq.0)then
6752         wg(jjj,k)=wg(jjj,k)+1
6753       else
6754         wg(jjj,k)=wg(jjj,k)+1
6755         nng(k)=nng(k)+1
6756       endif
6757       if(jjj.eq.0)njjj0=1
6758
6759         elseif(iii.eq.3)then
6760
6761           call ranfgt(seedp)
6762           do k=1,koll
6763             om1i=sngl(om1intc(k))
6764             if(rangen().lt.1.-exp(-om1i))then
6765 c            om1i=sngl(PhiExpo(1.,1.d0,1.d0,engy*engy,bk(k)))
6766 c            if(rangen().lt.1.-om1i)then
6767               kollx=kollx+1
6768             endif
6769           enddo
6770           call ranfst(seedp)
6771
6772         elseif(iii.eq.2)then
6773
6774       if(njjj0.ne.1)call utstop
6775      &('xEmsBg must be called also with jjj=0&')
6776       ymax=1.4
6777       kollini=koll
6778       koll=1
6779
6780       wtot=1.
6781       if(matarg+maproj.gt.2)then
6782       wtot=0.
6783       do k=1,nbib
6784        wtot=wtot+wg(-1,k)
6785       enddo
6786       wtot=wtot/float(kollx)
6787       endif
6788
6789       do 1 j=1,njjj
6790
6791       write(ifhi,'(a)')   '!##################################'
6792       write(ifhi,'(a)')   '! b distribution simulation'
6793       write(ifhi,'(a)')   '!##################################'
6794       write(ifhi,'(a,i1,a)')  'openhisto name bg',j,'Simu'
6795       write(ifhi,'(a)')       'htyp lin xmod lin ymod lin'
6796       write(ifhi,'(a,2e11.3)')'xrange',0.,b2g
6797       write(ifhi,'(a,2e11.3)')'yrange',0.,ymax
6798       write(ifhi,'(a)')    'text 0 0 "xaxis impact parameter b"'
6799       write(ifhi,'(a)')    'text 0 0 "yaxis P(b)"'
6800       if(wtot.gt.0.d0)
6801      &write(ifhi,'(a,f7.4,a)')    'text 0.5 0.8 "alpha=',1./wtot,'"'
6802       write(ifhi,'(a)')       'array 2'
6803          do k=1,nbib
6804       b=b1g+(k-0.5)*dbg
6805       y=0.
6806       if(nng(k).ne.0.and.wg(0,k).ne.0)
6807      &              y=wg(j,k)/float(nng(k))*wg(-1,k)/wg(0,k)!/wtot
6808 c      if(wg(0,k).ne.0..and.nng(k).ne.0)y=wg(j,k)/nng(k)*wg(-1,k)/wg(0,k)
6809 c!???????????? better normalization ? probability to have an interaction
6810 c in epos compared to eikonal probability, instead of normalized by the
6811 c probability of a collision for a pair (the number collision/number
6812 c active pair).
6813       uug(k)=uug(k)+y
6814       write(ifhi,'(2e11.3)')b,y
6815          enddo
6816       write(ifhi,'(a)')    '  endarray'
6817       write(ifhi,'(a)')    'closehisto plot 0-'
6818    1  continue
6819       write(ifhi,'(a)')   '!##################################'
6820       write(ifhi,'(a)')   '! b distr tot simul theory '
6821       write(ifhi,'(a)')   '!##################################'
6822       write(ifhi,'(a)')  'openhisto name btotSimu'
6823       write(ifhi,'(a)')       'htyp pfc xmod lin ymod lin'
6824       write(ifhi,'(a)')    'text 0 0 "xaxis impact parameter b"'
6825       write(ifhi,'(a)')    'text 0 0 "yaxis P(b)"'
6826       write(ifhi,'(a)')       'array 2'
6827          do k=1,nbib
6828       b=b1g+(k-0.5)*dbg
6829       write(ifhi,'(2e11.3)')b,uug(k)
6830          enddo
6831       write(ifhi,'(a)')    '  endarray'
6832       write(ifhi,'(a)')    'closehisto plot 0-'
6833       write(ifhi,'(a)')   '!##################################'
6834       write(ifhi,'(a)')   '! b distr unitarized theory '
6835       write(ifhi,'(a)')   '!##################################'
6836       write(ifhi,'(a,i1,a)')  'openhisto name bg',j,'Unit'
6837       write(ifhi,'(a)')       'htyp lba xmod lin ymod lin'
6838       write(ifhi,'(a)')    'text 0 0 "xaxis impact parameter b"'
6839       write(ifhi,'(a)')    'text 0 0 "yaxis P(b)"'
6840       write(ifhi,'(a)')       'array 2'
6841          do k=1,nbib
6842       b=b1g+(k-0.5)*dbg
6843 c      a1=PhiExact(1.,1.d0,1.d0,engy**2,b)
6844        a1=sngl(PhiExpo(1.,1.d0,1.d0,engy**2,b))
6845       y=(1.-a1)
6846       write(ifhi,'(2e11.3)')b,y
6847          enddo
6848       write(ifhi,'(a)')    '  endarray'
6849       write(ifhi,'(a)')    'closehisto plot 0'
6850
6851       koll=kollini
6852
6853       endif
6854
6855       return
6856       end
6857
6858 c-----------------------------------------------------------------------
6859       subroutine xEmsPx(iii,xmc,ymc,npos)
6860 c-----------------------------------------------------------------------
6861 c plot  x-distribution and y-distribution of Pomerons
6862 c-----------------------------------------------------------------------
6863
6864       include 'epos.inc'
6865       include 'epos.incems'
6866       common/geom/rmproj,rmtarg,bmax,bkmx
6867
6868       parameter(nbix=30,nbib=51)
6869       common/cx/x(2,nbix),dx(2,nbix),wxmc(2,nbix),wxmcI(2,nbix)
6870      * ,xl(2,nbix),dxl(2,nbix),wxp(2,nbix),wxm(2,nbix),wxpI(2,nbix)
6871      *,wxmI(2,nbix),wxpY(2,nbix),wxmY(2,nbix),wxmcY(2,nbix)
6872       parameter(nbiy=50)
6873       common/cy/y(nbiy),wymc(nbiy),wymcY(nbiy),wymcI(nbiy),nyp,nym
6874       double precision PomIncXExact,PomIncPExact,PomIncMExact,dcel
6875       double precision PomIncXIExact,PomIncPIExact,PomIncMIExact
6876       common/ems3/dcel,ad
6877       common/cemspx/xu,xo,yu,yo,dy,xlu,xlo,bb,nn,db,mm,nm,nt
6878       character mod*5, imod*5, txtxm*6
6879
6880       nposi=5
6881
6882       if(iemspx.eq.0)call utstop('ERROR in XemsPx: iemspx = 0&')
6883
6884       if(iii.eq.0)then
6885
6886        xu=0.1/engy**2
6887        xo=1.
6888        xlu=0.01/engy
6889        xlo=1.
6890        yu=-alog(engy**2)
6891        yo=alog(engy**2)
6892        dy=(yo-yu)/nbiy
6893         do i=1,nbix
6894         x(1,i)=xu*(xo/xu)**((i-0.5)/nbix)
6895         x(2,i)=xu+(xo-xu)*((i-0.5)/nbix)
6896         dx(1,i)=xu*(xo/xu)**(1.*i/nbix)*(1.-(xo/xu)**(-1./nbix))
6897         dx(2,i)=(xo-xu)/nbix
6898         wxmc(1,i)=0.
6899         wxmc(2,i)=0.
6900         wxmcI(1,i)=0.
6901         wxmcI(2,i)=0.
6902         wxmcY(1,i)=0.
6903         wxmcY(2,i)=0.
6904        enddo
6905        do i=1,nbix
6906         xl(1,i)=xlu*(xlo/xlu)**((i-0.5)/nbix)
6907         xl(2,i)=xlu+(xlo-xlu)*((i-0.5)/nbix)
6908         dxl(1,i)=xlu*(xlo/xlu)**(1.*i/nbix)*(1.-(xlo/xlu)**(-1./nbix))
6909         dxl(2,i)=(xlo-xlu)/nbix
6910         wxp(1,i)=0.
6911         wxp(2,i)=0.
6912         wxm(1,i)=0.
6913         wxm(2,i)=0.
6914         wxpI(1,i)=0.
6915         wxpI(2,i)=0.
6916         wxmI(1,i)=0.
6917         wxmI(2,i)=0.
6918         wxpY(1,i)=0.
6919         wxpY(2,i)=0.
6920         wxmY(1,i)=0.
6921         wxmY(2,i)=0.
6922        enddo
6923        do i=1,nbiy
6924         y(i)=yu+dy/2.+float(i-1)*dy
6925         wymc(i)=0.
6926         wymcI(i)=0.
6927         wymcY(i)=0.
6928        enddo
6929        mm=0
6930        nt=0
6931        nyp=0
6932        nym=0
6933        db=bkmx*2./float(nbib-1)
6934
6935       elseif(iii.eq.1)then
6936
6937        xp=sqrt(xmc)*exp(ymc)
6938        xm=sqrt(xmc)*exp(-ymc)
6939        mm=mm+1
6940
6941        if(xmc.lt.xu)goto11
6942        i=1+int(alog(xmc/xu)/alog(xo/xu)*nbix)
6943        if(i.gt.nbix)goto1
6944        if(i.lt.1)goto1
6945        wxmc(1,i)=wxmc(1,i)+1.
6946        if(npos.eq.1)    wxmcI(1,i)=wxmcI(1,i)+1.
6947        if(npos.eq.nposi)wxmcY(1,i)=wxmcY(1,i)+1.
6948 1      continue
6949        i=1+int((xmc-xu)/(xo-xu)*nbix)
6950        if(i.gt.nbix)goto11
6951        if(i.lt.1)goto11
6952        wxmc(2,i)=wxmc(2,i)+1.
6953        if(npos.eq.1)    wxmcI(2,i)=wxmcI(2,i)+1.
6954        if(npos.eq.nposi)wxmcY(2,i)=wxmcY(2,i)+1.
6955 11     continue
6956
6957        if(xp.lt.xlu)goto12
6958        i=1+int(alog(xp/xlu)/alog(xlo/xlu)*nbix)
6959        if(i.gt.nbix)goto2
6960        if(i.lt.1)goto2
6961        wxp(1,i)=wxp(1,i)+1.
6962        if(npos.eq.1)    wxpI(1,i)=wxpI(1,i)+1.
6963        if(npos.eq.nposi)wxpY(1,i)=wxpY(1,i)+1.
6964 2      continue
6965        i=1+int((xp-xlu)/(xlo-xlu)*nbix)
6966        if(i.gt.nbix)goto12
6967        if(i.lt.1)goto12
6968        wxp(2,i)=wxp(2,i)+1.
6969        if(npos.eq.1)    wxpI(2,i)=wxpI(2,i)+1.
6970        if(npos.eq.nposi)wxpY(2,i)=wxpY(2,i)+1.
6971 12     continue
6972
6973        if(xm.lt.xlu)goto13
6974        i=1+int(alog(xm/xlu)/alog(xlo/xlu)*nbix)
6975        if(i.gt.nbix)goto3
6976        if(i.lt.1)goto3
6977        wxm(1,i)=wxm(1,i)+1.
6978        if(npos.eq.1)    wxmI(1,i)=wxmI(1,i)+1.
6979        if(npos.eq.nposi)wxmY(1,i)=wxmY(1,i)+1.
6980 3      continue
6981        i=1+int((xm-xlu)/(xlo-xlu)*nbix)
6982        if(i.gt.nbix)goto13
6983        if(i.lt.1)goto13
6984        wxm(2,i)=wxm(2,i)+1.
6985        if(npos.eq.1)    wxmI(2,i)=wxmI(2,i)+1.
6986        if(npos.eq.nposi)wxmY(2,i)=wxmY(2,i)+1.
6987 13     continue
6988
6989        if(ymc.lt.yu)return
6990        i=int((ymc-yu)/dy)+1
6991        if(i.gt.nbiy)return
6992        if(i.lt.1)return
6993        wymc(i)=wymc(i)+1
6994        if(npos.eq.1)    wymcI(i)=wymcI(i)+1
6995        if(npos.eq.nposi)wymcY(i)=wymcY(i)+1
6996        if(ymc.gt.0)nyp=nyp+1
6997        if(ymc.lt.0)nym=nym+1
6998
6999       elseif(iii.eq.2)then
7000
7001        if(maproj.eq.1.and.matarg.eq.1.and.bminim.eq.bmaxim)then
7002         mmmm=1
7003         bb=bmaxim
7004         ff=float(nrevt)/float(ntevt)
7005         imod='   dn'
7006        elseif(maproj.eq.1.and.matarg.eq.1)then
7007         mmmm=3
7008         ff=1.
7009         imod='   dn'
7010        elseif(bminim.lt.0.001.and.bmaxim.gt.20)then
7011         mmmm=2
7012         area=pi*(rmproj+rmtarg)**2
7013         ff=area*float(nrevt)/float(ntevt)/(maproj*matarg)/sigine*10
7014         imod='   dn'
7015        else
7016         write(ifmt,*)'xEmsPx ignored'
7017         return
7018        endif
7019
7020        kk1=nint(xpar1)
7021        kk2=nint(xpar2)
7022
7023        do kk=kk1,kk2
7024
7025        if(kk.eq.1)mod=' log '
7026        if(kk.eq.2)mod=' lin '
7027
7028        write(ifhi,'(a)')       '!----------------------------------'
7029        write(ifhi,'(a)')       '!   Pomeron x distribution    '//mod
7030        write(ifhi,'(a)')       '!----------------------------------'
7031
7032        write(ifhi,'(a)')  'openhisto name xPomSimuL'//mod(3:4)
7033        write(ifhi,'(a)')  'htyp lru xmod'//mod//'ymod log'
7034        write(ifhi,'(a,2e11.3)')'xrange',xu,xo
7035        write(ifhi,'(a)')    'text 0 0 "xaxis x?PE!"'
7036        write(ifhi,'(a)') 'text 0 0 "yaxis'//imod//'?Pom! / dx?PE!"'
7037        if(kk.eq.1)write(ifhi,'(a,f5.2,a)')'text 0.1 0.3 "f=',ff,'"'
7038        if(kk.eq.2)write(ifhi,'(a,f5.2,a)')'text 0.1 0.1 "f=',ff,'"'
7039        write(ifhi,'(a)')       'array 2'
7040        s1=0
7041        do i=1,nbix
7042        u=x(kk,i)
7043        z=ff*wxmc(kk,i)/dx(kk,i)/nrevt
7044        s1=s1+z*dx(kk,i)
7045         write(ifhi,'(2e11.3)')u,z
7046        enddo
7047        write(ifhi,'(a)')    '  endarray'
7048        write(ifhi,'(a)')    'closehisto plot 0-'
7049
7050        write(ifhi,'(a)')       'openhisto name xPomUnitL'//mod(3:4)
7051        write(ifhi,'(a)')  'htyp lba xmod'//mod//'ymod log'
7052        write(ifhi,'(a,2e11.3)')'xrange',xu,xo
7053        write(ifhi,'(a)')    'text 0 0 "xaxis x?PE!"'
7054        write(ifhi,'(a)') 'text 0 0 "yaxis'//imod//'?Pom! / dx?PE!"'
7055        write(ifhi,'(a)')       'array 2'
7056        s2=0
7057        do i=1,nbix
7058         u=x(kk,i)
7059         if(mmmm.eq.1)z=PomIncXExact(dble(u),bb)
7060         if(mmmm.eq.2)z=PomIncXIExact(dble(u))/sigine*10
7061         if(mmmm.eq.3)z=PomIncXIExact(dble(u))/sigine*10
7062         s2=s2+dx(kk,i)*z
7063         write(ifhi,'(2e11.3)')u,z
7064        enddo
7065        write(ifhi,'(a)')    '  endarray'
7066        write(ifhi,'(a,f5.3,a,f5.3,a)')
7067      *                       'text .1 .85 "I= ',s1,' (',s2,')"'
7068        write(ifhi,'(a)')    'closehisto plot 0'
7069
7070        write(ifhi,'(a)')           '!--------------------------------'
7071        write(ifhi,'(a)')           '!   Pomeron y distribution   '//mod
7072        write(ifhi,'(a)')           '!--------------------------------'
7073
7074        write(ifhi,'(a)')       'openhisto name yPomSimuL'//mod(3:4)
7075        write(ifhi,'(a)')       'htyp lru xmod lin ymod'//mod
7076        write(ifhi,'(a,2e11.3)')'xrange',yu,yo
7077        write(ifhi,'(a)')    'text 0 0 "xaxis y?PE!"'
7078        write(ifhi,'(a)') 'text 0 0 "yaxis'//imod//'?Pom!/dy?PE!"'
7079        write(ifhi,'(a,f5.2,a)')'text 0.1 0.7 "f=',ff,'"'
7080        write(ifhi,'(a)')       'array 2'
7081        s1=0
7082        do i=1,nbiy
7083        u=y(i)
7084        z=ff*wymc(i)/dy/nrevt
7085        s1=s1+z*dy
7086         write(ifhi,'(2e11.3)')u,z
7087        enddo
7088        write(ifhi,'(a)')    '  endarray'
7089        write(ifhi,'(a)')    'closehisto plot 0'
7090
7091        write(ifhi,'(a)')       '!----------------------------------'
7092        write(ifhi,'(a)')       '!   Pomeron x+ distribution    '//mod
7093        write(ifhi,'(a)')       '!----------------------------------'
7094
7095        write(ifhi,'(a)')   'openhisto name xpPomSimuL'//mod(3:4)
7096        write(ifhi,'(a)')   'htyp lru xmod'//mod//'ymod log'
7097        write(ifhi,'(a,2e11.3)')'xrange',xlu,xlo
7098        write(ifhi,'(a)')    'text 0 0 "xaxis x+?PE!"'
7099        write(ifhi,'(a)') 'text 0 0 "yaxis'//imod//'?Pom! / dx+?PE!"'
7100        if(kk.eq.1)write(ifhi,'(a,f5.2,a)')'text 0.1 0.3 "f=',ff,'"'
7101        if(kk.eq.2)write(ifhi,'(a,f5.2,a)')'text 0.1 0.1 "f=',ff,'"'
7102        write(ifhi,'(a)')       'array 2'
7103        s1=0
7104        do i=1,nbix
7105        u=xl(kk,i)
7106        z=ff*wxp(kk,i)/dxl(kk,i)/nrevt
7107        s1=s1+z*dxl(kk,i)
7108         write(ifhi,'(2e11.3)')u,z
7109        enddo
7110        write(ifhi,'(a)')    '  endarray'
7111        write(ifhi,'(a)')    'closehisto plot 0-'
7112
7113        write(ifhi,'(a)')       'openhisto name xpPomUnitL'//mod(3:4)
7114        write(ifhi,'(a)')   'htyp lba xmod'//mod//'ymod log'
7115        write(ifhi,'(a,2e11.3)')'xrange',xlu,xlo
7116        write(ifhi,'(a)')    'text 0 0 "xaxis x+?PE!"'
7117        write(ifhi,'(a)') 'text 0 0 "yaxis'//imod//'?Pom! / dx+?PE!"'
7118        write(ifhi,'(a)')       'array 2'
7119        s2=0
7120        do i=1,nbix
7121         u=xl(kk,i)
7122         if(mmmm.eq.1)z=PomIncPExact(dble(u),bb)
7123         if(mmmm.eq.2)z=PomIncPIExact(dble(u))/sigine*10
7124         if(mmmm.eq.3)z=PomIncPIExact(dble(u))/sigine*10
7125         s2=s2+dxl(kk,i)*z
7126         write(ifhi,'(2e11.3)')u,z
7127        enddo
7128        write(ifhi,'(a)')    '  endarray'
7129        write(ifhi,'(a,f5.3,a,f5.3,a)')
7130      *                       'text .1 .85 "I= ',s1,' (',s2,')"'
7131        write(ifhi,'(a)')    'closehisto plot 0'
7132
7133        write(ifhi,'(a)')       '!----------------------------------'
7134        write(ifhi,'(a)')       '!   x-?PE! distribution    '//mod
7135        write(ifhi,'(a)')       '!----------------------------------'
7136
7137        write(ifhi,'(a)')   'openhisto name xmPomSimuL'//mod(3:4)
7138        write(ifhi,'(a)')   'htyp lru xmod'//mod//'ymod log'
7139        write(ifhi,'(a,2e11.3)')'xrange',xlu,xlo
7140        write(ifhi,'(a)')    'text 0 0 "xaxis x-?PE!"'
7141        write(ifhi,'(a)') 'text 0 0 "yaxis'//imod//'?Pom! / dx-?PE!"'
7142        if(kk.eq.1)write(ifhi,'(a,f5.2,a)')'text 0.1 0.3 "f=',ff,'"'
7143        if(kk.eq.2)write(ifhi,'(a,f5.2,a)')'text 0.1 0.1 "f=',ff,'"'
7144        write(ifhi,'(a)')       'array 2'
7145        s1=0
7146        do i=1,nbix
7147        u=xl(kk,i)
7148        z=ff*wxm(kk,i)/dxl(kk,i)/nrevt
7149        s1=s1+z*dxl(kk,i)
7150         write(ifhi,'(2e11.3)')u,z
7151        enddo
7152        write(ifhi,'(a)')    '  endarray'
7153        write(ifhi,'(a)')    'closehisto plot 0-'
7154
7155        write(ifhi,'(a)')       'openhisto name xmPomUnitL'//mod(3:4)
7156        write(ifhi,'(a)')   'htyp lba xmod'//mod//'ymod log'
7157        write(ifhi,'(a,2e11.3)')'xrange',xlu,xlo
7158        write(ifhi,'(a)')    'text 0 0 "xaxis x-?PE!"'
7159        write(ifhi,'(a)') 'text 0 0 "yaxis'//imod//'?Pom! / dx-"'
7160        write(ifhi,'(a)')       'array 2'
7161        s2=0
7162        do i=1,nbix
7163         u=xl(kk,i)
7164         if(mmmm.eq.1)z=PomIncMExact(dble(u),bb)
7165         if(mmmm.eq.2)z=PomIncMIExact(dble(u))/sigine*10
7166         if(mmmm.eq.3)z=PomIncMIExact(dble(u))/sigine*10
7167         s2=s2+dxl(kk,i)*z
7168         write(ifhi,'(2e11.3)')u,z
7169        enddo
7170        write(ifhi,'(a)')    '  endarray'
7171        write(ifhi,'(a,f5.3,a,f5.3,a)')
7172      *                       'text .1 .85 "I= ',s1,' (',s2,')"'
7173        write(ifhi,'(a)')    'closehisto plot 0'
7174
7175   !................................................................
7176
7177        xm=-1. !xm integration
7178        txtxm='xm int'
7179        do jjb=0,3
7180        b=jjb*0.5
7181        do jj=0,2
7182
7183        write(ifhi,'(a)')       '!----------------------------------'
7184        write(ifhi,'(a,3i1)')   '!   ffom11    '//mod,jjb,jj
7185        write(ifhi,'(a)')       '!----------------------------------'
7186
7187        write(ifhi,'(a,2i1)')'openhisto name ffom11L'//mod(3:4),jjb,jj+8
7188        write(ifhi,'(a)')    'htyp lin xmod'//mod//'ymod log'
7189        write(ifhi,'(a,2e11.3)')'xrange ',xlu,xlo
7190        write(ifhi,'(a)')'txt "xaxis  x+?PE!"'
7191        write(ifhi,'(a)')'txt "yaxis dn?Pom! / dx+?PE! "'
7192        write(ifhi,'(a)')'text 0.05 0.1  "fit and exact, all contrib."'
7193        if(jjb.lt.3)write(ifhi,'(a,f4.1,3a)')
7194      *             'txt "title ffom11   b =',b,'   ',txtxm,'"'
7195        if(jjb.ge.3)write(ifhi,'(3a)')
7196      *             'txt "title ffom11   b aver   ',txtxm,'"'
7197        write(ifhi,'(a)')       'array 2'
7198        do i=1,nbix
7199        u=xl(kk,i)
7200        if(jjb.lt.3.and.jj.eq.0)z= ffom11(u,xm,b,-1,-1)
7201        if(jjb.lt.3.and.jj.eq.1)z= ffom11(u,xm,b,0,5)
7202        if(jjb.lt.3.and.jj.eq.2)z= ffom11(u,xm,b,0,4)
7203        if(jjb.eq.3.and.jj.eq.0)z=ffom11a(u,xm,-1,-1)
7204        if(jjb.eq.3.and.jj.eq.1)z=ffom11a(u,xm,0,5)
7205        if(jjb.eq.3.and.jj.eq.2)z=ffom11a(u,xm,0,4)
7206         write(ifhi,'(2e11.3)')u,z
7207        enddo
7208        write(ifhi,'(a)')    '  endarray'
7209        if(jj.le.1)write(ifhi,'(a)')    'closehisto plot 0-'
7210        if(jj.eq.2)write(ifhi,'(a)')    'closehisto plot 0'
7211
7212        enddo
7213        enddo
7214
7215        do jjb=0,3
7216        b=jjb*0.5
7217        do jjj=1,6
7218        jj=jjj
7219        if(jjj.eq.6)jj=0
7220
7221        write(ifhi,'(a)')       '!----------------------------------'
7222        write(ifhi,'(a,3i1)')   '!   ffom11    '//mod,jjb,jj
7223        write(ifhi,'(a)')       '!----------------------------------'
7224
7225        write(ifhi,'(a,3i1)')'openhisto name om1ffL'//mod(3:4),jjb,jj
7226        if(jj.ne.0)write(ifhi,'(a)')    'htyp lin xmod'//mod//'ymod log'
7227        if(jj.eq.0)write(ifhi,'(a)')    'htyp lro xmod'//mod//'ymod log'
7228        write(ifhi,'(a,2e11.3)')'xrange ',xlu,xlo
7229        if(jj.eq.1)then
7230        write(ifhi,'(a)') 'txt "xaxis  x+?PE!"'
7231        write(ifhi,'(a)') 'txt "yaxis  dn?Pom! / dx+?PE!  "'
7232        if(kk.eq.2)then
7233         write(ifhi,'(a)') 'text 0.1 0.2  "soft sea-sea"'
7234         write(ifhi,'(a)') 'text 0.1 0.1  "val-sea sea-val val-val"'
7235        else
7236         write(ifhi,'(a)') 'text 0.05 0.8  "soft"'
7237         write(ifhi,'(a)') 'text 0.05 0.7  "diff"'
7238         write(ifhi,'(a)') 'text 0.05 0.6  "sea-sea"'
7239         write(ifhi,'(a)') 'text 0.05 0.5  "val-sea"'
7240         write(ifhi,'(a)') 'text 0.05 0.4  "sea-val"'
7241         write(ifhi,'(a)') 'text 0.05 0.3  "val-val"'
7242       endif
7243        if(jjb.lt.3)write(ifhi,'(a,f4.1,3a)')
7244      *             'txt "title ffom11   b =',b,'  ',txtxm,'"'
7245        if(jjb.ge.3)write(ifhi,'(3a)')
7246      *             'txt "title ffom11   b aver  ',txtxm,'"'
7247        endif
7248        write(ifhi,'(a)')       'array 2'
7249        do i=1,nbix
7250        u=xl(kk,i)
7251        if(jjb.lt.3)z= ffom11(u,xm,b,jj,jj)
7252        if(jjb.eq.3)z=ffom11a(u,xm,jj,jj)
7253        write(ifhi,'(2e11.3)')u,z
7254        enddo
7255        write(ifhi,'(a)')    '  endarray'
7256        if(jjj.ne.6)write(ifhi,'(a)')    'closehisto plot 0-'
7257        if(jjj.eq.6)write(ifhi,'(a)')    'closehisto plot 0'
7258
7259        enddo
7260        enddo
7261
7262       enddo
7263
7264       endif
7265
7266       return
7267       end
7268
7269 c-----------------------------------------------------------------------
7270       subroutine xEmsP2(iii,jaa,jex,xpd,xmd,xpb,xmb,pt1,pt2)
7271 c-----------------------------------------------------------------------
7272 c plot  x+ distributions of Pomeron ends (PE) (xpd)
7273 c          and Pomeron's in Born (IB) partons (xpb),
7274 c     and pt dist of Pomeron's out Born (OB) partons
7275 c       integrated over x- bins (xmd,xmb)
7276 c  iii=0: initialize
7277 c  ii=1: fill arrays
7278 c  iii>=2: make histogram
7279 c           (2 - Pomeron end PE, 3 - in Born IB, 4 - out Born OB)
7280 c  jaa: type of semihard Pomeron
7281 c         1= sea-sea, 2= val=sea, 3= sea-val, 4= val-val
7282 c         5= all  for iii=2
7283 c  jex: emission type
7284 c         1= no emission, 2= proj emis, 3= targ emis, 4= both sides
7285 c         5= all  for iii=2
7286 c-----------------------------------------------------------------------
7287
7288       include 'epos.inc'
7289       include 'epos.incsem'
7290       include 'epos.incems'
7291       common/geom/rmproj,rmtarg,bmax,bkmx
7292       parameter(nbixp=25,nbixm=5,nbipt=20)
7293       common/cxb/xlp(2,nbixp),dxlp(2,nbixp)
7294      *          ,xlm(2,nbixm),dxlm(2,nbixm)
7295      *          ,wxb(2,4,4,nbixp,nbixm)
7296      *          ,wxe(2,4,4,nbixp,nbixm)
7297       common/cptb/ptu,pto,ptob(nbipt),wptob(4,4,nbipt)
7298       common/cemspbx/xlub1,xlub2,xlob
7299 ctp060829      character imod*5
7300
7301       if(iemspbx.eq.0)call utstop('ERROR in xEmsP2: iemspbx = 0&')
7302
7303       if(iii.eq.0)then
7304
7305        xlub1=0.01/engy
7306        xlub2=0.
7307        xlob=1.
7308        do i=1,nbixp
7309         xlp(1,i)=xlub1*(xlob/xlub1)**((i-0.5)/nbixp)
7310         xlp(2,i)=xlub2+(xlob-xlub2)*((i-0.5)/nbixp)
7311         dxlp(1,i)=xlub1*(xlob/xlub1)**(1.*i/nbixp)
7312      *             *(1.-(xlob/xlub1)**(-1./nbixp))
7313         dxlp(2,i)=(xlob-xlub2)/nbixp
7314        enddo
7315        do i=1,nbixm
7316         xlm(1,i)=xlub1*(xlob/xlub1)**((i-0.5)/nbixm)
7317         xlm(2,i)=xlub2+(xlob-xlub2)*((i-0.5)/nbixm)
7318         dxlm(1,i)=xlub1*(xlob/xlub1)**(1.*i/nbixm)
7319      *             *(1.-(xlob/xlub1)**(-1./nbixm))
7320         dxlm(2,i)=(xlob-xlub2)/nbixm
7321        enddo
7322        do i=1,nbixp
7323        do j=1,nbixm
7324        do jaai=1,4
7325        do jexi=1,4
7326         wxb(1,jaai,jexi,i,j)=0.
7327         wxb(2,jaai,jexi,i,j)=0.
7328         wxe(1,jaai,jexi,i,j)=0.
7329         wxe(2,jaai,jexi,i,j)=0.
7330        enddo
7331        enddo
7332        enddo
7333        enddo
7334        ptu=2
7335        pto=20
7336        do i=1,nbipt
7337        ptob(i)=ptu+(pto-ptu)*(i-0.5)/nbipt
7338        do jaai=1,4
7339        do jexi=1,4
7340        wptob(jaai,jexi,i)=0
7341        enddo
7342        enddo
7343        enddo
7344
7345       elseif(iii.eq.1)then
7346
7347        xp=xpb
7348        xm=xmb
7349        if(xp.lt.xlub1)goto2
7350        if(xm.lt.xlub1)goto2
7351        i=1+int(alog(xp/xlub1)/alog(xlob/xlub1)*nbixp)
7352        if(i.gt.nbixp)goto2
7353        if(i.lt.1)goto2
7354        j=1+int(alog(xm/xlub1)/alog(xlob/xlub1)*nbixm)
7355        if(j.gt.nbixm)goto2
7356        if(j.lt.1)goto2
7357        wxb(1,jaa,jex,i,j)=wxb(1,jaa,jex,i,j)+1.
7358 2      continue
7359
7360        if(xp.lt.xlub2)goto12
7361        if(xm.lt.xlub2)goto12
7362        i=1+int((xp-xlub2)/(xlob-xlub2)*nbixp)
7363        if(i.gt.nbixp)goto12
7364        if(i.lt.1)goto12
7365        j=1+int((xm-xlub2)/(xlob-xlub2)*nbixm)
7366        if(j.gt.nbixm)goto12
7367        if(j.lt.1)goto12
7368        wxb(2,jaa,jex,i,j)=wxb(2,jaa,jex,i,j)+1.
7369 12     continue
7370
7371        xp=xpd
7372        xm=xmd
7373        if(xp.lt.xlub1)goto22
7374        if(xm.lt.xlub1)goto22
7375        i=1+int(alog(xp/xlub1)/alog(xlob/xlub1)*nbixp)
7376        if(i.gt.nbixp)goto22
7377        if(i.lt.1)goto22
7378        j=1+int(alog(xm/xlub1)/alog(xlob/xlub1)*nbixm)
7379        if(j.gt.nbixm)goto22
7380        if(j.lt.1)goto22
7381        wxe(1,jaa,jex,i,j)=wxe(1,jaa,jex,i,j)+1.
7382   22   continue
7383
7384        if(xp.lt.xlub2)goto32
7385        if(xm.lt.xlub2)goto32
7386        i=1+int((xp-xlub2)/(xlob-xlub2)*nbixp)
7387        if(i.gt.nbixp)goto32
7388        if(i.lt.1)goto32
7389        j=1+int((xm-xlub2)/(xlob-xlub2)*nbixm)
7390        if(j.gt.nbixm)goto32
7391        if(j.lt.1)goto32
7392        wxe(2,jaa,jex,i,j)=wxe(2,jaa,jex,i,j)+1.
7393   32   continue
7394
7395        do m=1,2
7396        if(m.eq.1)pt=pt1
7397        if(m.eq.2)pt=pt2
7398        i=1+int((pt-ptu)/(pto-ptu)*nbipt)
7399        if(i.lt.1)goto42
7400        if(i.gt.nbipt)goto42
7401        wptob(jaa,jex,i)=wptob(jaa,jex,i)+1
7402    42  continue
7403        enddo
7404
7405       elseif(iii.ge.2)then
7406
7407        if(maproj.eq.1.and.matarg.eq.1.and.bminim.eq.bmaxim)then
7408 ctp060829        mmmm=1
7409 ctp060829        bb=bmaxim
7410         ff=float(nrevt)/float(ntevt)
7411 ctp060829        imod='   dn'
7412        elseif(maproj.eq.1.and.matarg.eq.1)then
7413 ctp060829        mmmm=3
7414         ff=1.
7415 ctp060829        imod='   dn'
7416        elseif(bminim.lt.0.001.and.bmaxim.gt.20)then
7417 ctp060829        mmmm=2
7418         area=pi*(rmproj+rmtarg)**2
7419         ff=area*float(nrevt)/float(ntevt)/(maproj*matarg)/sigine*10
7420 ctp060829        imod='   dn'
7421        else
7422         write(ifmt,*)'xEmsP2 ignored'
7423         return
7424        endif
7425
7426        j1=1  !nint(xpar1)   !first xminus bin
7427        j2=5  !nint(xpar2)   !last xminus bin
7428        if(iii.eq.4)j2=1
7429        kkk=2 !nint(xpar3)   !1 (log binning) 2 (lin binning)
7430        if(kkk.eq.1)then
7431 ctp060829         xmi1=xlub1*(xlob/xlub1)**((j1-1.)/nbixm)
7432 ctp060829         xmi2=xlub1*(xlob/xlub1)**((j2-0.)/nbixm)
7433          xlub=xlub1
7434        elseif(kkk.eq.2)then
7435 ctp060829         xmi1=xlub2+(xlob-xlub2)*((j1-1.)/nbixm)
7436 ctp060829         xmi2=xlub2+(xlob-xlub2)*((j2-0.)/nbixm)
7437          xlub=xlub2
7438        endif
7439
7440        jaa1=jaa
7441        jaa2=jaa
7442        jex1=jex
7443        jex2=jex
7444        if(jaa.eq.5)then
7445        jaa1=1
7446        jaa2=4
7447        endif
7448        if(jex.eq.5)then
7449        jex1=1
7450        jex2=4
7451        endif
7452
7453        if(jex.eq.1)then
7454         je1=0
7455         je2=0
7456        elseif(jex.eq.2)then
7457         je1=1
7458         je2=0
7459        elseif(jex.eq.3)then
7460         je1=0
7461         je2=1
7462        elseif(jex.eq.4)then
7463         je1=1
7464         je2=1
7465        elseif(jex.eq.5)then
7466         je1=2
7467         je2=2
7468        endif
7469
7470        if(iii.eq.2)then
7471
7472         write(ifhi,'(a)')       '!----------------------------------'
7473         write(ifhi,'(a,3i1)')   '!   PE    ',jaa,jex
7474         write(ifhi,'(a)')       '!----------------------------------'
7475
7476         sum=ffom12aii(jaa,je1,je2)
7477         write(ifhi,'(a,2i1)')'openhisto name ffom12a',jaa,jex
7478         write(ifhi,'(a)')'htyp lin xmod lin ymod log'
7479         write(ifhi,'(a,2e11.3)')'xrange ',xlub,xlob
7480         write(ifhi,'(a)')    'txt "xaxis  x+?PE!"'
7481         write(ifhi,'(a)')    'txt "yaxis dn?semi! / dx+?PE!    "'
7482        write(ifhi,'(a,2i1,a)')'txt "title ffom12a + MC   (',jaa,jex,')"'
7483         write(ifhi,'(a)')    'array 2'
7484         do i=1,nbixp
7485          u=xlp(kkk,i)
7486          z=ffom12ai(u,jaa1,jaa2,je1,je2)
7487          write(ifhi,'(2e11.3)')u,z
7488         enddo
7489         write(ifhi,'(a)')    '  endarray'
7490         if(jex.eq.5)then
7491           write(ifhi,'(a)')    'closehisto plot 0-'
7492           write(ifhi,'(a,2i1)')'openhisto name ffom11',jaa,jex
7493           write(ifhi,'(a)')'htyp lba'
7494           write(ifhi,'(a)')'text 0.05 0.5 "+ ffom11a "'
7495           write(ifhi,'(a)')'array 2'
7496           do i=1,nbixp
7497            u=xlp(kkk,i)
7498            z=ffom11a(u,-1.,jaa1,jaa2)
7499            write(ifhi,'(2e11.3)')u,z
7500           enddo
7501           write(ifhi,'(a)')    '  endarray'
7502         endif
7503
7504        elseif(iii.eq.3)then
7505
7506         write(ifhi,'(a)')       '!----------------------------------'
7507         write(ifhi,'(a,3i1)')   '!   IB    ',jaa,jex
7508         write(ifhi,'(a)')       '!----------------------------------'
7509
7510     !.......total integral
7511         s2min=4*q2min
7512         zmin=s2min/engy**2
7513         zmax=1
7514         xpmin0 = 0.01/engy
7515         xpmax=1
7516         ig1=3
7517         ig2=3
7518         r1=0
7519         do i1=1,ig1
7520         do m1=1,2
7521           z=zmin*(zmax/zmin)**(.5+tgss(ig1,i1)*(m1-1.5))
7522           xpmin=max(z,xpmin0)
7523           r2=0
7524           if(xpmin.lt.xpmax)then
7525           do i2=1,ig2
7526           do m2=1,2
7527             xp=xpmin*(xpmax/xpmin)**(.5+tgss(ig2,i2)*(m2-1.5))
7528             xm=z/xp
7529             r2=r2+wgss(ig2,i2)*ffsigiut(xp,xm,jaa,je1,je2)
7530           enddo
7531           enddo
7532           endif
7533           r2=r2*0.5*log(xpmax/xpmin)
7534           r1=r1+wgss(ig1,i1)*r2*z
7535         enddo
7536         enddo
7537         r1=r1*0.5*log(zmax/zmin)
7538         res=  r1 * factk * .0390  /sigine*10
7539         sum=res
7540    !.......plot
7541         xx2min = 0.01/engy     !max(xpar1,0.01/engy)
7542         xx2max = 1             !xpar2
7543         xx1min = 0.01/engy     !max(xpar3,0.01/engy)
7544         xx1max = 1             !xpar4
7545         nbins  = 10            !nint(xpar5)
7546
7547         write(ifhi,'(a,2i1)') 'openhisto xrange 0 1 name ffsig',jaa,jex
7548         write(ifhi,'(a)') 'yrange auto auto htyp lin xmod lin ymod log'
7549         write(ifhi,'(a)') 'txt "xaxis x+?IB!         "              '
7550         write(ifhi,'(a)') 'txt "yaxis dn?semi! / dx+?IB!  "'
7551         write(ifhi,'(a,2i1,a)')'txt "title ffsig + MC   (',jaa,jex,')"'
7552         write(ifhi,'(a)') 'array 2'
7553         del=(xx1max-xx1min)/nbins
7554         do ii=1,nbins
7555           xx1=xx1min+(ii-0.5)*del
7556           ig2=3
7557           r2=0
7558           do i2=1,ig2
7559           do m2=1,2
7560             xx2=xx2min*(xx2max/xx2min)**(.5+tgss(ig2,i2)*(m2-1.5))
7561             r2=r2+wgss(ig2,i2)*ffsigiut(xx1,xx2,jaa,je1,je2)*xx2
7562           enddo
7563           enddo
7564           sig=r2*0.5*log(xx2max/xx2min)
7565           sig   = sig * factk * .0390   /sigine*10
7566           write(ifhi,'(2e12.4)')xx1,sig
7567         enddo
7568         write(ifhi,'(a)')  '  endarray'
7569
7570        elseif(iii.eq.4)then
7571
7572         write(ifhi,'(a)')       '!----------------------------------'
7573         write(ifhi,'(a,3i1)')   '!   OB    ',jaa,jex
7574         write(ifhi,'(a)')       '!----------------------------------'
7575
7576       !...... integral
7577         y2     = 10
7578         ptmin  = 2
7579         ptmax  = 6
7580         sum=0
7581         ig=2
7582         do i=1,ig
7583         do m=1,2
7584               pt=ptmin*(ptmax/ptmin)**(.5+tgss(ig,i)*(m-1.5))
7585           sig=ffsigi(pt**2,y2)
7586           sig   =sig    * factk * .0390 /sigine*10  * 2   ! 2 partons!
7587               sum=sum+wgss(ig,i)*sig*pt
7588         enddo
7589         enddo
7590         sum=sum*0.5*log(ptmax/ptmin)
7591       !...... pt distr
7592         y2     = 10
7593         ptmin  = 2
7594         ptmax  = 20
7595         nbins  = 18
7596         sx=engy**2
7597         do jj=3,1,-1
7598         write(ifhi,'(a,i1)')'openhisto name jet',jj
7599         write(ifhi,'(a)')'xrange 0 20 xmod lin ymod log '
7600         write(ifhi,'(a)') 'txt "xaxis pt?OB!         "           '
7601         write(ifhi,'(a)') 'txt "yaxis dn?ptn! / dpt?OB!  "'
7602         if(jj.eq.1)write(ifhi,'(a)')'htyp lro'
7603         if(jj.eq.2)write(ifhi,'(a)')'htyp lgo'
7604         if(jj.eq.3)write(ifhi,'(a)')'htyp lyo'
7605         write(ifhi,'(a,f7.2,a)')  'text 0.05 0.1 "1/f=',1./ff,'"'
7606         write(ifhi,'(a)')'array 2'
7607         delpt=(ptmax-ptmin)/nbins
7608         do i=1,nbins
7609           pt=ptmin+(i-0.5)*delpt
7610           sig=1
7611           if(jj.eq.1)then
7612             sig=ffsigi(pt**2,y2)      ! our stuff
7613           elseif(jj.eq.2)then
7614             if(engy.ge.10.)sig=psjvrg1(pt**2,sx,y2) ! grv
7615           elseif(jj.eq.3)then
7616             if(engy.ge.10.)sig=psjwo1(pt**2,sx,y2)   !duke-owens
7617           endif
7618           sig   =sig    * factk * .0390 /sigine*10 * 2
7619           write(ifhi,'(2e12.4)')pt,sig
7620         enddo
7621         write(ifhi,'(a)')       '  endarray'
7622         if(jj.ne.1)write(ifhi,'(a)')       'closehisto'
7623         if(jj.ne.1)write(ifhi,'(a)')  'plot 0-'
7624         enddo
7625
7626        endif
7627
7628        x=0.1+(min(3,iii)-2)*0.30
7629        y=0.2+(min(3,iii)-2)*0.55
7630        if(engy.gt.100.)then
7631        write(ifhi,'(a,2f5.2,a,f6.3,a)')'text',x,y,' "   form ',sum,'"'
7632        else
7633        write(ifhi,'(a,2f5.2,a,f6.5,a)')'text',x,y,' "   form ',sum,'"'
7634        endif
7635        write(ifhi,'(a)')  'closehisto plot 0-'
7636
7637        write(ifhi,'(a)') "!-----------------------------"
7638        write(ifhi,'(a)') "! MC   "
7639        write(ifhi,'(a)') "!-----------------------------"
7640
7641        if(iii.eq.2)
7642      *  write(ifhi,'(a,i1,i1)')'openhisto name dndxPE',jaa,jex
7643        if(iii.eq.3)
7644      *  write(ifhi,'(a,i1,i1)')'openhisto name dndxIB',jaa,jex
7645        if(iii.eq.4)
7646      *  write(ifhi,'(a,i1,i1)')'openhisto name dndptOB',jaa,jex
7647        write(ifhi,'(a)')     'htyp prs'
7648        write(ifhi,'(a)')     'array 2'
7649        sum=0
7650        imax=nbixp
7651        if(iii.eq.4)imax=nbipt
7652        do i=1,imax
7653         u=xlp(kkk,i)
7654         if(iii.eq.4)u=ptob(i)
7655         z=0
7656         do j=j1,j2
7657         do jaai=jaa1,jaa2
7658         do jexi=jex1,jex2
7659          if(iii.eq.2)z=z+wxe(kkk,jaai,jexi,i,j)
7660          if(iii.eq.3)z=z+wxb(kkk,jaai,jexi,i,j)
7661          if(iii.eq.4)z=z+wptob(jaai,jexi,i)
7662         enddo
7663         enddo
7664         enddo
7665         del=dxlp(kkk,i)
7666         if(iii.eq.4)del=(pto-ptu)/nbipt
7667         z=z/del*ff/nrevt
7668         write(ifhi,'(2e11.3)')u,z
7669         sum=sum+z*del
7670        enddo
7671        write(ifhi,'(a)')    '  endarray'
7672        x=0.1+(min(3,iii)-2)*0.30
7673        y=0.1+(min(3,iii)-2)*0.55
7674        if(engy.gt.100)then
7675        write(ifhi,'(a,2f5.2,a,f6.3,a)')'text',x,y,' "   simu ',sum,'"'
7676        else
7677        write(ifhi,'(a,2f5.2,a,f6.5,a)')'text',x,y,' "   simu ',sum,'"'
7678        endif
7679        write(ifhi,'(a)')    'closehisto'
7680
7681       endif
7682
7683       return
7684       end
7685
7686 c-----------------------------------------------------------------------
7687       subroutine xEmsSe(iii,xmc,ptmc,ih,iqq)
7688 c-----------------------------------------------------------------------
7689 c     iqq = 1 : String End mass and rapidity
7690 c     iqq = 2 : String mass and rapidity
7691 c-----------------------------------------------------------------------
7692
7693       include 'epos.inc'
7694
7695       parameter(nbix=50)
7696       common/cxpar/nx(2),x(nbix),wxmc(nbix,2),xmn,xmx,xu,xo
7697       parameter(nbiy=40)
7698       common/cypar/ny(2),y(nbiy),wymc(nbiy,2),ymin,ymax,dy,yu,yo
7699
7700       s=engy**2
7701
7702       if(iii.eq.0)then
7703
7704        nx(iqq)=0
7705        xu=0.1/engy**2
7706        xo=1.
7707        do i=1,nbix
7708          x(i)=xu*(xo/xu)**((i-0.5)/nbix)
7709          wxmc(i,iqq)=0
7710        enddo
7711        yo=alog(s)
7712        yu=-yo
7713        dy=(yo-yu)/nbiy
7714        ny(iqq)=0
7715        do i=1,nbiy
7716          y(i)=yu+dy/2.+(i-1)*dy
7717          wymc(i,iqq)=0
7718        enddo
7719
7720       elseif(iii.eq.1)then
7721
7722        if(xmc.lt.xu)return
7723        if(ptmc.eq.0.)return
7724        if(iqq.eq.1)ymc=0.5*alog(xmc*s/ptmc)*ih
7725        if(iqq.eq.2)ymc=0.5*alog(xmc/ptmc)
7726        i=1+int(alog(xmc/xu)/alog(xo/xu)*nbix)
7727        if(i.gt.nbix)goto1
7728        if(i.lt.1)goto1
7729        wxmc(i,iqq)=wxmc(i,iqq)+1
7730        nx(iqq)=nx(iqq)+1
7731 1      continue
7732        if(ymc.lt.yu)return
7733        i=int((ymc-yu)/dy)+1
7734        if(i.gt.nbiy)return
7735        if(i.lt.1)return
7736        wymc(i,iqq)=wymc(i,iqq)+1
7737        ny(iqq)=ny(iqq)+1
7738
7739       elseif(iii.eq.2)then
7740
7741        write(ifhi,'(a)')        '!--------------------------------'
7742        write(ifhi,'(a)')        '!   string end x distr       '
7743        write(ifhi,'(a)')        '!--------------------------------'
7744         write(ifhi,'(a)')       'openhisto'
7745         write(ifhi,'(a)')       'htyp lin'
7746         write(ifhi,'(a)')       'xmod log ymod log'
7747         write(ifhi,'(a,2e11.3)')'xrange',xu,xo
7748         if(iqq.eq.1)write(ifhi,'(a)')    'text 0 0 "xaxis string end x"'
7749         if(iqq.eq.2)write(ifhi,'(a)')    'text 0 0 "xaxis string x"'
7750         write(ifhi,'(a)')    'text 0 0 "yaxis P(x)"'
7751         write(ifhi,'(a)')       'array 2'
7752         do i=1,nbix
7753          dx=xu*(xo/xu)**(1.*i/nbix)*(1.-(xo/xu)**(-1./nbix))
7754          if(nx(iqq).gt.0)
7755      *   write(ifhi,'(2e11.3)')x(i),wxmc(i,iqq)/dx/nx(iqq)
7756         enddo
7757         write(ifhi,'(a)')    '  endarray'
7758         write(ifhi,'(a)')    'closehisto plot 0'
7759         write(ifhi,'(a)')       'openhisto'
7760         write(ifhi,'(a)')       'htyp lin'
7761         write(ifhi,'(a)')       'xmod lin ymod lin'
7762         write(ifhi,'(a,2e11.3)')'xrange',yu,yo
7763         if(iqq.eq.1)write(ifhi,'(a)')    'text 0 0 "xaxis string end y"'
7764         if(iqq.eq.2)write(ifhi,'(a)')    'text 0 0 "xaxis string y"'
7765         write(ifhi,'(a)')    'text 0 0 "yaxis P(y)"'
7766         write(ifhi,'(a)')       'array 2'
7767         do i=1,nbiy
7768          if(ny(iqq).gt.0)
7769      *   write(ifhi,'(2e11.3)')y(i),wymc(i,iqq)/dy/ny(iqq)
7770         enddo
7771         write(ifhi,'(a)')    '  endarray'
7772         write(ifhi,'(a)')    'closehisto plot 0'
7773       endif
7774
7775       return
7776       end
7777
7778 c-----------------------------------------------------------------------
7779       subroutine xEmsDr(iii,xpmc,xmmc,ie)
7780 c-----------------------------------------------------------------------
7781
7782       include 'epos.inc'
7783
7784       parameter(nbix=50,nie=4)
7785       common/cxpardr/nxp(nie),nxm(nie),x(nbix),wxpmc(nbix,nie)
7786      &      ,wxmmc(nbix,nie),xmn,xmx,xu,xo,wxmc(nbix,nie),nx(nie)
7787       parameter(nbiy=40)
7788       common/cypardr/ny(nie),y(nbiy),wymc(nbiy,nie),ymin,ymax,dy,yu,yo
7789
7790       s=engy**2
7791
7792       if(iii.eq.0)then
7793
7794        do ni=1,nie
7795          nxp(ni)=0
7796          nxm(ni)=0
7797          nx(ni)=0
7798        enddo
7799        xu=0.1/engy**2
7800        xo=1.
7801        do i=1,nbix
7802          x(i)=xu*(xo/xu)**((i-0.5)/nbix)
7803          do ni=1,nie
7804            wxpmc(i,ni)=0
7805            wxmmc(i,ni)=0
7806            wxmc(i,ni)=0
7807          enddo
7808        enddo
7809        yo=alog(s)
7810        yu=-yo
7811        dy=(yo-yu)/nbiy
7812        do ni=1,nie
7813          ny(ni)=0
7814        enddo
7815        do i=1,nbiy
7816          y(i)=yu+dy/2.+(i-1)*dy
7817          do ni=1,nie
7818            wymc(i,ni)=0
7819          enddo
7820        enddo
7821
7822       elseif(iii.eq.1)then
7823
7824        if(ie.lt.1.or.ie.gt.nie)return
7825
7826        if(xpmc.lt.xu)return
7827        i=1+int(alog(xpmc/xu)/alog(xo/xu)*nbix)
7828        if(i.gt.nbix)goto1
7829        if(i.lt.1)goto1
7830        wxpmc(i,ie)=wxpmc(i,ie)+1
7831        nxp(ie)=nxp(ie)+1
7832        if(xmmc.lt.xu)return
7833        i=1+int(alog(xmmc/xu)/alog(xo/xu)*nbix)
7834        if(i.gt.nbix)goto1
7835        if(i.lt.1)goto1
7836        wxmmc(i,ie)=wxmmc(i,ie)+1
7837        nxm(ie)=nxm(ie)+1
7838 1      continue
7839        if(xmmc.ge.xu)then
7840          ymc=0.5*alog(xpmc/xmmc)
7841        else
7842          return
7843        endif
7844        if(ymc.lt.yu)return
7845        i=int((ymc-yu)/dy)+1
7846        if(i.gt.nbiy)return
7847        if(i.lt.1)return
7848        wymc(i,ie)=wymc(i,ie)+1
7849        ny(ie)=ny(ie)+1
7850
7851        xmc=xpmc*xmmc
7852        if(xmc.lt.xu)return
7853        i=1+int(alog(xmc/xu)/alog(xo/xu)*nbix)
7854        if(i.gt.nbix)return
7855        if(i.lt.1)return
7856        wxmc(i,ie)=wxmc(i,ie)+1
7857        nx(ie)=nx(ie)+1
7858
7859       elseif(iii.eq.2)then
7860
7861         do ii=1,nie
7862
7863        if(ii.eq.1)write(ifhi,'(a)')'!-----  projectile droplet  ----'
7864        if(ii.eq.2)write(ifhi,'(a)')'!-----    target droplet    ----'
7865        if(ii.eq.3)write(ifhi,'(a)')'!-----  projectile string end  ----'
7866        if(ii.eq.4)write(ifhi,'(a)')'!-----    target string end    ----'
7867         write(ifhi,'(a)')       '!--------------------------------'
7868         write(ifhi,'(a)')       '!   droplet/string x+ distr       '
7869         write(ifhi,'(a)')       '!--------------------------------'
7870         write(ifhi,'(a)')       'openhisto'
7871         write(ifhi,'(a)')       'htyp lru'
7872         write(ifhi,'(a)')       'xmod log ymod log'
7873         write(ifhi,'(a,2e11.3)')'xrange',xu,xo
7874         if(ii.eq.1.or.ii.eq.2)
7875      *  write(ifhi,'(a)')    'text 0 0 "xaxis droplet x+"'
7876         if(ii.eq.3.or.ii.eq.4)
7877      *  write(ifhi,'(a)')    'text 0 0 "xaxis string end x+"'
7878         write(ifhi,'(a)')    'text 0 0 "yaxis P(x)"'
7879         write(ifhi,'(a)')       'array 2'
7880         do i=1,nbix
7881          dx=xu*(xo/xu)**(1.*i/nbix)*(1.-(xo/xu)**(-1./nbix))
7882          if(nxp(ii).gt.0)
7883      *   write(ifhi,'(2e11.3)')x(i),wxpmc(i,ii)/dx/nxp(ii)
7884         enddo
7885         write(ifhi,'(a)')    '  endarray'
7886         write(ifhi,'(a)')    'closehisto plot 0-'
7887         write(ifhi,'(a)')       '!--------------------------------'
7888         write(ifhi,'(a)')       '!   droplet/string x- distr       '
7889         write(ifhi,'(a)')       '!--------------------------------'
7890         write(ifhi,'(a)')       'openhisto'
7891         write(ifhi,'(a)')       'htyp lba'
7892         write(ifhi,'(a)')       'xmod log ymod log'
7893         write(ifhi,'(a,2e11.3)')'xrange',xu,xo
7894         if(ii.eq.1.or.ii.eq.2)
7895      *  write(ifhi,'(a)')    'text 0 0 "xaxis droplet x-"'
7896         if(ii.eq.3.or.ii.eq.4)
7897      *  write(ifhi,'(a)')    'text 0 0 "xaxis string end x-"'
7898         write(ifhi,'(a)')    'text 0 0 "yaxis P(x)"'
7899         write(ifhi,'(a)')       'array 2'
7900         do i=1,nbix
7901          dx=xu*(xo/xu)**(1.*i/nbix)*(1.-(xo/xu)**(-1./nbix))
7902          if(nxm(ii).gt.0)
7903      *   write(ifhi,'(2e11.3)')x(i),wxmmc(i,ii)/dx/nxm(ii)
7904         enddo
7905         write(ifhi,'(a)')    '  endarray'
7906         write(ifhi,'(a)')    'closehisto plot 0'
7907         write(ifhi,'(a)')       '!--------------------------------'
7908         write(ifhi,'(a)')       '!   droplet/string y distr       '
7909         write(ifhi,'(a)')       '!--------------------------------'
7910         write(ifhi,'(a)')       'openhisto'
7911         write(ifhi,'(a)')       'htyp lin'
7912         write(ifhi,'(a)')       'xmod lin ymod lin'
7913         write(ifhi,'(a,2e11.3)')'xrange',yu,yo
7914         if(ii.eq.1.or.ii.eq.2)
7915      *  write(ifhi,'(a)')    'text 0 0 "xaxis droplet y"'
7916         if(ii.eq.3.or.ii.eq.4)
7917      *  write(ifhi,'(a)')    'text 0 0 "xaxis string end y"'
7918         write(ifhi,'(a)')    'text 0 0 "yaxis P(y)"'
7919         write(ifhi,'(a)')       'array 2'
7920         do i=1,nbiy
7921          if(ny(ii).gt.0)
7922      *   write(ifhi,'(2e11.3)')y(i),wymc(i,ii)/dy/ny(ii)
7923         enddo
7924         write(ifhi,'(a)')    '  endarray'
7925         write(ifhi,'(a)')    'closehisto plot 0'
7926
7927       enddo
7928
7929         write(ifhi,'(a)')       '!--------------------------------'
7930         write(ifhi,'(a)')       '!   droplet/string mass distr       '
7931         write(ifhi,'(a)')       '!--------------------------------'
7932       do ii=1,nie
7933
7934
7935         if(ii.eq.2.or.ii.eq.4)write(ifhi,'(a)')    'closehisto plot 0-'
7936         if(ii.eq.3)write(ifhi,'(a)')    'closehisto plot 0'
7937         write(ifhi,'(a)')       'openhisto'
7938         if(ii.eq.1.or.ii.eq.3)write(ifhi,'(a)')       'htyp lru'
7939         if(ii.eq.2.or.ii.eq.4)write(ifhi,'(a)')       'htyp lba'
7940         write(ifhi,'(a)')       'xmod log ymod log'
7941         write(ifhi,'(a,2e11.3)')'xrange',sqrt(xu*s),sqrt(s*xo)
7942         if(ii.eq.1.or.ii.eq.2)
7943      *  write(ifhi,'(a)')    'text 0 0 "xaxis droplet mass (GeV)"'
7944         if(ii.eq.4.or.ii.eq.3)
7945      *  write(ifhi,'(a)')    'text 0 0 "xaxis string end mass (GeV)"'
7946         write(ifhi,'(a)')    'text 0 0 "yaxis P(x)"'
7947         write(ifhi,'(a)')       'array 2'
7948         do i=1,nbix
7949          dx=xu*(xo/xu)**(1.*i/nbix)*(1.-(xo/xu)**(-1./nbix))
7950          if(nx(ii).gt.0)
7951      *   write(ifhi,'(2e11.3)')sqrt(x(i)*s),wxmc(i,ii)/dx/nx(ii)
7952         enddo
7953         write(ifhi,'(a)')    '  endarray'
7954       enddo
7955        write(ifhi,'(a)')    'closehisto plot 0'
7956
7957       endif
7958
7959       return
7960       end
7961
7962 cc--------------------------------------------------------------------------
7963 c      subroutine xtype(k,n,i1,i2,text)
7964 cc--------------------------------------------------------------------------
7965 c
7966 c      include 'epos.inc'
7967 c      include 'epos.incems'
7968 c      parameter(itext=40)
7969 c      character  text*40
7970 c
7971 c      imax=itext+1
7972 c      do i=itext,1,-1
7973 c      if(text(i:i).eq.'&')imax=i
7974 c      enddo
7975 c
7976 c      ip=iproj(k)
7977 c      it=itarg(k)
7978 c
7979 c      if(i1.eq.1)then
7980 c         write(ifch,*)
7981 c         write(ifch,*)('-',ll=1,27)
7982 c         write(ifch,*)'  '//text(1:imax-1)
7983 c         write(ifch,*)('-',ll=1,27)
7984 c      endif
7985 c
7986 c      if(i2.eq.1)then
7987 c         write(ifch,*)
7988 c         write(ifch,*)'k:',k,'   n:',n,'   ip:',ip,'   it:',it
7989 c         write(ifch,*)'bk:',bk(k)
7990 c         if(n.ne.0)write(ifch,*)'idpr:',idpr(n,k)
7991 c         write(ifch,*)'iep:',iep(ip),'   iet:',iet(it)
7992 c         write(ifch,*)'idp:',idp(ip),'   idt:',idt(it)
7993 c      endif
7994 c
7995 c      end
7996 c
7997 c------------------------------------------------------------------------
7998       subroutine XPrint(text)
7999 c------------------------------------------------------------------------
8000       include 'epos.inc'
8001       include 'epos.incems'
8002       double precision xpptot,xmptot,xpttot,xmttot
8003       parameter(itext=15)
8004       character  text*15
8005       imax=itext+1
8006       do i=itext,1,-1
8007       if(text(i:i).eq.'&')imax=i
8008       enddo
8009       write(ifch,'(1x,a)')text(1:imax-1)
8010
8011       write(ifch,'(a)')' npr0:   npr1:   nprmx:   Pomeron id lattice:'
8012       do k=1,koll
8013        write(ifch,'(1x,i6,1x,i2,6x,i2,6x,i2,7x,$)')
8014      *              k,npr(0,k),npr(1,k),nprmx(k)
8015        do n=1,nprmx(k)
8016         write(ifch,'(i2,$)')idpr(n,k)
8017        enddo
8018        write(ifch,*)' '
8019       enddo
8020
8021       xpptot=0d0
8022       xmptot=0d0
8023       xpttot=0d0
8024       xmttot=0d0
8025       write(ifch,'(a)')' Pomeron xy lattice:'
8026       do k=1,koll
8027        do n=1,nprmx(k)
8028        xpptot=xpptot+xppr(n,k)
8029        xmttot=xmttot+xmpr(n,k)
8030         write(ifch,'(i6,1x,i2,1x,d10.3,1x,d10.3,3x,$)')
8031      *                  k,n,xpr(n,k),ypr(n,k)
8032        enddo
8033        write(ifch,*)' '
8034       enddo
8035
8036       write(ifch,'(a)')' projectile remnants x+,x-,px,py,x,iep:'
8037       do ip=1,maproj
8038        xpptot=xpptot+xpp(ip)
8039        xmptot=xmptot+xmp(ip)
8040        write(ifch,'(i3,2x,5d12.3,i3)')ip,xpp(ip),xmp(ip),xxp(ip),xyp(ip)
8041      *                             ,xpos(ip),iep(ip)
8042       enddo
8043
8044       write(ifch,'(a)')' target remnants x-,x+,px,py,x,iet:'
8045       do it=1,matarg
8046        xpttot=xpttot+xpt(it)
8047        xmttot=xmttot+xmt(it)
8048        write(ifch,'(i3,2x,5d12.3,i3)')it,xmt(it),xpt(it),xxt(it),xyt(it)
8049      *                             ,xtos(it),iet(it)
8050       enddo
8051
8052       write(ifch,*)' remnant balance x+,x-:'
8053      &,(xpptot+xpttot)/dble(maproj)
8054      &,(xmptot+xmttot)/dble(matarg)
8055       end
8056
8057
8058 c-------------------------------------------------------------------------
8059       subroutine xfom
8060 c-------------------------------------------------------------------------
8061       include 'epos.inc'
8062       double precision fom,x
8063       write(ifhi,'(a)')     '!##################################'
8064       write(ifhi,'(a,i3)')  '!   fom     '
8065       write(ifhi,'(a)')     '!##################################'
8066       b=0.
8067       do i=1,6
8068         z=0.2*exp(0.8*i)
8069         xi=0.01+0.16*float(i-1)
8070         write(ifhi,'(a,i1)') 'openhisto name fom',i
8071         write(ifhi,'(a)')    'htyp lin xmod lin ymod log'
8072         write(ifhi,'(a)')    'xrange 0 1'
8073         write(ifhi,'(a)')    'yrange 0.1 1000 '
8074         write(ifhi,'(a)')    'text 0 0 "xaxis x "'
8075         write(ifhi,'(a)')    'text 0 0 "yaxis fom"'
8076         if(z.lt.10.)
8077      &   write(ifhi,'(a,f4.2,a,f4.1,a)')'text ',xi,' 0.9 "',z,'"'
8078         if(z.ge.10.)
8079      &   write(ifhi,'(a,f4.2,a,f4.0,a)')'text ',xi,' 0.9 "',z,'"'
8080         write(ifhi,'(a)')    'array 2'
8081         do n=1,99
8082           x=dble(n)*0.01d0
8083           write(ifhi,'(2e11.3)')x,fom(z,x,b)
8084         enddo
8085         write(ifhi,'(a)')    '  endarray'
8086         write(ifhi,'(a)')    '  closehisto '
8087         if(i.lt.6)write(ifhi,'(a)')    'plot 0-'
8088         if(i.eq.6)write(ifhi,'(a)')    'plot 0'
8089       enddo
8090       end
8091
8092