]> git.uio.no Git - u/mrichter/AliRoot.git/blame - EPOS/epos167/epos-ems-165.f
git://git.uio.no / u / mrichter / AliRoot.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Getting code working on grid, adding histograms for K0S correction
[u/mrichter/AliRoot.git] / EPOS / epos167 / epos-ems-165.f
CommitLineData
9ef1c2d9 1c-----------------------------------------------------------------------
2 subroutine emsaa(iret)
3c-----------------------------------------------------------------------
4c energy-momentum sharing
5c-----------------------------------------------------------------------
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
14c 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
31c initialize
32c ----------
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
66c Markov
67c ------
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
195c --- 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
221c --- 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
232c -- 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
241c --- 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
252c kolp(ip)=kolp(ip)+1
253c kolt(it)=kolt(it)+1
254c else
255c itpr(k)=0
256 endif
257 enddo
258 if(ish.ge.5)write(ifch,*)'ncol:',ncol
259
260
261c --- 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
272c --- recalculate Zptn
273
274
275 if(irzptn.eq.1)call recalcZPtn
276
277
278c --- 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
325c --- 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
350c --- Treat Pomerons ---------------------------------------
351
352
353c --- 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
372c --- 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)
402c enddo
403c enddo
404
405c --- Check Pomeron mass
406
407c do k=1,koll
408c 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
434c enddo
435c enddo
436
437c --- Define String ends for "backup" Pomerons ---
438
439c do k=1,koll
440c 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
453c enddo
454c enddo
455
456c --- Define String ends for "normal" Pomerons ---
457
458c do k=1,koll
459c 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
477c --- 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
487c --- 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
533c --- 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
553c --- Treat Remnants -----------------------------------------
554
555
556c --- Diffractive Pt
557
558 do k=1,koll
559 call ProDiPt(k)
560 enddo
561
562 do ip=1,maproj
563c Here and later "kolp(ip).ne.0" replaced by "iep(ip).ne.-1" to count
564c projectile and target nucleons which are counted in paires but are not used
565c in collision (no diffractive or inelastic interaction) as slow particles
566c at the end. Then we can use them in ProRem to give mass to all other nucleons
567c and avoid energy conservation violation that utrescl can not treat
568c (and it gives a reasonnable number of grey particles even if distributions
569c are not really reproduced).
570c 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)
575c if(kolt(it).ne.0)call ProCot(it,maproj+it)
576 enddo
577
578
579c ---- 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
601c to set the mass of diffractive or not excited remnant first
602c (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)
613c 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)
617c 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
657c --- 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
670c --- Write Remnants
671
672
673 do ip=1,maproj
674c 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
678c 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
683c --- 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
693999 continue
694
695c plot
696c ----
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
774c exit
775c ----
776
777 1000 continue
778c 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
785c----------------------------------------------------------------------
786 subroutine StoCon(mode,k,n)
787c----------------------------------------------------------------------
788c store or restore configuration
789c mode = 1 (store) or -1 (restore)
790c k = collision index
791c n = pomeron index
792c----------------------------------------------------------------------
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
886c-------------------------------------------------------------------------
887 subroutine RemPom(k,n)
888c-------------------------------------------------------------------------
889c remove pomeron
890c-------------------------------------------------------------------------
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
915c-------------------------------------------------------------------------
916 subroutine ProPo(k,n)
917c-------------------------------------------------------------------------
918c propose pomeron type = idpr(n,k
919c-------------------------------------------------------------------------
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
934c nbr of pomerons per proj
935 npp(ip)=npp(ip)+1
936c 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
948c-------------------------------------------------------------------------
949 subroutine ProXY(k,n)
950c-------------------------------------------------------------------------
951c propose pomeron x,y
952c-------------------------------------------------------------------------
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)
973c because of fom, it's not symetric any more if we choose always xp first
974c 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
1002c 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
1015c-------------------------------------------------------------------------
1016 double precision function wmatrix(k,n)
1017c-------------------------------------------------------------------------
1018c proposal matrix w(a->b), considering pomeron type, x, y
1019c-------------------------------------------------------------------------
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
1027c ip=iproj(k)
1028c 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
1042c-------------------------------------------------------------------------
1043 double precision function omega(n,k)
1044c-------------------------------------------------------------------------
1045c calculates partial omega for spot (k,n)
1046c-------------------------------------------------------------------------
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
1070c ztg=0
1071c zpj=0
1072c nctg=0
1073c ncpj=0
1074c zsame=nprt(k)
1075c if(idpr(n,k).gt.0)then
1076c if(nprt(k).le.0)stop'omega: nprt(k) should be positive !!!! '
1077c zsame=zsame-1
1078c endif
1079c nlpop=nint(zsame)
1080c nlpot=nint(zsame)
1081c bglaub2=sigine/10./pi !10= fm^2 -> mb
1082c bglaub=sqrt(bglaub2)
1083c b2x=epscrp*epscrp*bglaub2
1084c b2=bk(k)**2
1085c ztgx=epscrw*exp(-b2/2./b2x)*fscra(engy/egyscr)
1086c zpjx=epscrw*exp(-b2/2./b2x)*fscra(engy/egyscr)
1087c
1088c if(koll.gt.1)then
1089c do li=1,lproj(ip)
1090c kk=kproj(ip,li)
1091c if(kk.ne.k)then
1092c b2=bk(kk)**2
1093c if(b2.le.bglaub2)nctg=nctg+1
1094c ztg=ztg+epscrw*exp(-b2/2./b2x)*fscro(engy/egyscr)
1095c nlpop=nlpop+nprt(kk)
1096c endif
1097c enddo
1098c do li=1,ltarg(it)
1099c kk=ktarg(it,li)
1100c if(kk.ne.k)then
1101c b2=bk(kk)**2
1102c if(b2.le.bglaub2)ncpj=ncpj+1
1103c zpj=zpj+epscrw*exp(-b2/2./b2x)*fscro(engy/egyscr)
1104c nlpot=nlpot+nprt(kk)
1105c endif
1106c enddo
1107c 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)
1117c !-------------------------------------------------------------------------
1118c ! fom : part of Phi regularization; Phi -> Phi^(n) (n = number of Poms)
1119c ! Phi^(0) relevant for Xsect unchanged, apart of (maybe) normalization (Z)
1120c !-------------------------------------------------------------------------
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
1168c-------------------------------------------------------------------------
1169 double precision function fom(z,x,b)
1170c-------------------------------------------------------------------------
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)
1181c u=z0*dble(z/z0)**2.
1182 w=u/z0*exp(-dble(b*b/delD(1,iclpro,icltar)))
1183c 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
1194c-------------------------------------------------------------------------
1195 subroutine ProPoTy(k,n)
1196c-------------------------------------------------------------------------
1197c propose pomeron type
1198c-------------------------------------------------------------------------
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)
1225c xp=xppr(n,k)
1226c 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
1360c-------------------------------------------------------------------------
1361 subroutine ProDiSc(k)
1362c-------------------------------------------------------------------------
1363c propose diffractive scattering
1364c-------------------------------------------------------------------------
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
1381c-------------------------------------------------------------------------
1382 subroutine ProReEx(ir,ii)
1383c-------------------------------------------------------------------------
1384c propose remnant excitation
1385c for proj (iep) if ir=1 or target (iet) if ir=-1:
1386c 0 = no, 1 = inel excitation, 2 = diffr excitation
1387c-------------------------------------------------------------------------
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
1409c 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
1413c 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
1429c 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
1433c if(r.lt.1.-(1.-rexdif(icltar)))iet(it)=2
1434 endif
1435
1436 endif
1437
1438 end
1439
1440
1441c-------------------------------------------------------------------------
1442 subroutine ProDiPt(k)
1443c-------------------------------------------------------------------------
1444c propose transverse momentum for diffractive interaction
1445c-------------------------------------------------------------------------
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
1457c generate p_t for diffractive
1458
1459 if(ptdiff.ne.0.)then
1460 if(itpr(k).eq.2)then
1461 ptd=ptdiff
1462c ad=pi/4./ptd**2
1463c 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
1481c 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
1524c-------------------------------------------------------------------------
1525 subroutine ProSePt(k,n)
1526c-------------------------------------------------------------------------
1527c propose transverse momentum for string ends
1528c-------------------------------------------------------------------------
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
1539ctp060829 id=idpr(n,k)
1540ctp060829 ih=0
1541ctp060829 if(id.eq.3)ih=1
1542
1543c generate p_t for string ends (proj)
1544
1545c nph=0
1546c do l=1,lproj(ip)
1547c kk=kproj(ip,l)
1548c nph=nph+npr(3,kk)
1549c enddo
1550c
1551c !---proj-----
1552c zz=0
1553c if(isplit.eq.1)then
1554c if(lproj(ip).ge.1)then
1555c do l=1,lproj(ip)
1556c kpair=kproj(ip,l)
1557c if(itpr(kpair).eq.1)then
1558c zz=zz+zparpro(kpair)
1559c endif
1560c enddo
1561c endif
1562c endif
1563c !------
1564 ptsef=ptsemx
1565c 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
1572c pt=ranptd()*ptsendx
1573c if(iep(ip).eq.0)then
1574c pt=ranpt()*ptsendy
1575c else
1576c pt=ranptd()*ptsendy
1577c endif
1578 pt=ranptcut(ptsef)*ptsendy
1579 amk1=amk0!+qmass(0)*0.5 !mass for mt distribution with bounding energy for diquark
1580 else
1581c pt=ranptd()*ptsendx
1582c if(iep(ip).eq.0)then
1583c pt=ranpt()*ptsendx
1584c else
1585c pt=ranptd()*ptsendx
1586c 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
1600c pt=ranptd()*ptsendy
1601c if(iep(ip).eq.0)then
1602c pt=ranpt()*ptsendy
1603c else
1604c pt=ranptd()*ptsendy
1605c endif
1606 pt=ranptcut(ptsef)*ptsendy
1607 amk1=amk0!+qmass(0)*0.5 !mass for mt distribution with bounding energy for diquark
1608 else
1609c pt=ranptd()*ptsendx
1610c if(iep(ip).eq.0)then
1611c pt=ranpt()*ptsendx
1612c else
1613c pt=ranptd()*ptsendx
1614c 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
1626c generate p_t for string ends (targ)
1627
1628
1629c nph=0
1630c do l=1,ltarg(it)
1631c kk=ktarg(it,l)
1632c nph=nph+npr(3,kk)
1633c enddo
1634c
1635c !---targ-----
1636c zz=0
1637c if(isplit.eq.1)then
1638c if(ltarg(it).ge.1)then
1639c do l=1,ltarg(it)
1640c kpair=ktarg(it,l)
1641c if(itpr(kpair).eq.1)then
1642c zz=zz+zpartar(kpair)
1643c endif
1644c enddo
1645c endif
1646c endif
1647c !---------
1648 ptsef=ptsemx
1649c 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
1656c pt=ranptd()*ptsendy
1657c if(iet(it).eq.0)then
1658c pt=ranpt()*ptsendy
1659c else
1660c pt=ranptd()*ptsendy
1661c endif
1662 pt=ranptcut(ptsef)*ptsendy
1663 amk1=amk0!+qmass(0)*0.5 !mass for mt distribution with bounding energy for diquark
1664 else
1665c pt=ranptd()*ptsendx
1666c if(iet(it).eq.0)then
1667c pt=ranpt()*ptsendx
1668c else
1669c pt=ranptd()*ptsendx
1670c 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
1684c pt=ranptd()*ptsendy
1685c if(iet(it).eq.0)then
1686c pt=ranpt()*ptsendy
1687c else
1688c pt=ranptd()*ptsendy
1689c endif
1690 pt=ranptcut(ptsef)*ptsendy
1691 amk1=amk0!+qmass(0)*0.5 !mass for mt distribution with bounding energy for diquark
1692 else
1693c pt=ranptd()*ptsendx
1694c if(iet(it).eq.0)then
1695c pt=ranpt()*ptsendx
1696c else
1697c pt=ranptd()*ptsendx
1698c 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
1711c 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
1727c 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
1743c-----------------------------------------------------------------------
1744 subroutine ProSeX(k,n,iret)
1745c-----------------------------------------------------------------------
1746c calculates x of string ends
1747c-----------------------------------------------------------------------
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
1799c fc=xp1pr(n,k)*xm2pr(n,k)/xmn1 !avoid virpom
1800c if(fc.eq.0.)goto 999
1801c xp1pr(n,k)=xp1pr(n,k)/sqrt(fc)
1802c xm2pr(n,k)=xm2pr(n,k)/sqrt(fc)
1803 endif
1804 if(xp2pr(n,k)*xm1pr(n,k).lt.xmn2)then
1805 goto 999
1806c fc=xp2pr(n,k)*xm1pr(n,k)/xmn2 !avoid virpom
1807c if(fc.eq.0.)goto 999
1808c xp2pr(n,k)=xp2pr(n,k)/sqrt(fc)
1809c 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
1821c-------------------------------------------------------------------------
1822 subroutine RmPt(k,n)
1823c-------------------------------------------------------------------------
1824c remove pt from pomeron
1825c-------------------------------------------------------------------------
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
1852c-------------------------------------------------------------------------
1853 subroutine VirPom(k,n,id)
1854c-------------------------------------------------------------------------
1855c create virtual pomeron
1856c virtual pomeron: ivpr(n,k)=0, otherwise ivpr(n,k)=1
1857c-------------------------------------------------------------------------
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
1865c data nvir/0/
1866c 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
1878c nvir=nvir+1
1879c 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
1972c-----------------------------------------------------------------------
1973 subroutine StoRe(imod)
1974c-----------------------------------------------------------------------
1975c Store Remnant configuration (imod=1) before shuffle to restore the
1976c initial configuration (imod=-1) in case of problem.
1977c-----------------------------------------------------------------------
1978
1979 include 'epos.inc'
1980 include 'epos.incems'
1981
1982 if(imod.eq.1)then
1983
1984c 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
1992c 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
2002c 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
2010c 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
2027c-----------------------------------------------------------------------
2028 subroutine CalcZZ(ir,m)
2029c-----------------------------------------------------------------------
2030C Calculates zz for remnant m for proj (ir=1) or target (ir=-1)
2031c writes it to zzremn(m, 1 or 2)
2032c-----------------------------------------------------------------------
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
2078c-----------------------------------------------------------------------
2079 subroutine WriteZZ(ir,irem)
2080c-----------------------------------------------------------------------
2081c Write Z into zpaptl(K) for connected strings
2082c K is the index for the string end
2083c on the corresponding remnant side
2084c-----------------------------------------------------------------------
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)
2101c write(ifch,*)'remn',irem,' (',jrem,' ) pom',npom
2102c & ,' ',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
2113c write(ifch,*)' ',isi,idptl(isi),zpaptl(isi)
2114 enddo
2115 endif
2116 enddo
2117 endif
2118 enddo
2119 enddo
2120
2121 end
2122
2123c-----------------------------------------------------------------------
2124 subroutine ProReM(ir,irem,iret)
2125c-----------------------------------------------------------------------
2126c propose remnant mass of remnant irem in case of proj (ir=1)
2127c or target (ir=-1)
2128c (-> xmp, xpt)
2129c iret : input : if iret=10 force to give mass even if no more energy,
2130c when input not 10 : output = error if 1
2131c-----------------------------------------------------------------------
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
2155c uncomment the following two lines to force the excitation
2156
2157ccc force=.true. !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
2158ccc ntrymx=1 !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
2159
2160c 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)
2176ctp 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)
2192ctp kolzi=kolt(irem)
2193 noevt=npjevt
2194 msmin=dble(amremn*amremn)
2195 if(iet(irem).eq.6)goto 678
2196 endif
2197
2198ctp noevt replace noxevt
2199ctp if iez=0, 5% energy violation allowed to give mass to the other side
2200ctp noxevt=0 !?????? otherwise, energy is strongly not conserved
2201ctp do i=1,masso
2202ctp if(iez(i,jremo).gt.0)noxevt=noxevt+1
2203ctp enddo
2204
2205
2206c 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
2228c 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
2240c 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
2247ctp if(xmz(j,jremo).gt.eps.and.iez(j,jrem).gt.0)then !xmz(,jremo)=xplus
2248ctp060824 if(xmz(j,jremo).gt.eps.and.iez(j,jrem).ge.0)then !xmz(,jremo)=xplus
2249c 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
2268c else
2269c xtest(j)=0.01d0 !maximal momentum available for non exited state
2270c endif
2271 xtest0=max(xtest0,xtest(j))
2272c print *,iep(1),iet(1),iez(irem,jrem),xtest(j),xpz(j,jremo),xmmin
2273c & ,xzos(j,jremo),xmz(j,jremo)
2274 enddo
2275ctp060824 if(.not.cont)xtest=min(1.d0,0.2d0/xpz(irem,jrem))
2276
2277
2278 cont=.true.
2279
2280c 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
2287c fremnux (+) or fremnux2 (-) ?
2288
2289 aremn=dble(fremnux2(icrmn)) !dble(max(amremn,fremnux2(icrmn)))
2290c if(iez(j,jrem).eq.2)then
2291c aremnex=aremn
2292c else
2293c aremnex=max(amzmn(idz(irem,jrem),jrem) !makes remnant to heavy at low energy
2294c & +amemn(idz(irem,jrem),iez(irem,jrem))
2295c & ,dble(fremnux(icrmn)))
2296 aremnex=aremn+amemn(idz(irem,jrem),iez(irem,jrem))
2297c endif
2298
2299c determine xminus
2300
2301c xmin0=1.05*(aremn**2d0+xxz(irem,jrem)**2d0+xyz(irem,jrem)**2d0)/sx
2302c 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
2306c 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
2328c xmin=xmin-xpt2rem/sx !no pt
2329c xmax=xmax-xpt2rem/sx !no pt
2330 alp=at(idz(irem,jrem),iez(irem,jrem))
2331c 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
2338c xxx=xxx+xpt2rem/sx !no pt
2339 else
2340c xmin=dble(amremn)**2d0/sx !no pt
2341c 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
2354c xmin0=0.92d0*xxx
2355c xmin0=0.9d0*xxx
2356 xmin0=min(0.99d0,1d0-fxtest*dble(1.-rangen()))*xxx
2357c xmin0=dble(0.9+0.09*rangen())*xxx
2358 endif
2359 xzos(irem,jrem)=xmin0*xpz(irem,jrem)
2360 msmin=xmin*sx
2361c msmin=xmin*sx+xpt2rem !no pt
2362
2363c partition xminus between nucleons of the other side
2364
2365 xii=1d0
2366 iimax=noevt !number of opposite side participants
2367ctp 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
2398c write(ifch,*)' skip ',cremn,' ',ii,iimax,ntry,xxx
2399c & ,xpz(iro,jremo)-xme(iro),xmmin
2400 if(ii.le.1)goto1
2401 xme(iro)=-1.d0
2402 else
2403 xii=xi
2404c 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
2412c check xmz(irem,jrem)
2413
2414 xmz(irem,jrem)=xxx
2415
2416 678 p5sq=xpz(irem,jrem)*plc*xmz(irem,jrem)*plc
2417c write(ifch,*)'final mass',p5sq,msmin,xpz(irem,jrem),xmz(irem,jrem)
2418c &,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
2434c 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
2448c-----------------------------------------------------------------------
2449 subroutine ProSeTy(k,n)
2450c-----------------------------------------------------------------------
2451c creates proposal for string ends, idp., idm.
2452c updates quark counters
2453c-----------------------------------------------------------------------
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
2512c 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
2537c 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
2542c 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
2551c 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
2556c 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
2571c 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
2597c 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
2602c 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
2611c 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
2616c 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
2651c-----------------------------------------------------------------------
2652 subroutine ProSeF(k,n,iret)
2653c-----------------------------------------------------------------------
2654c starting from string properties as already determined in EMS,
2655c one determines string end flavors
2656c by checking compatibility with remnant masses.
2657c strings are written to /cems/ and then to /cptl/
2658c remnant ic is updated (icproj,ictarg)
2659c------------------------------------------------------------------------
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
2675c entry
2676c -----
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
2695c 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
2714c 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
2729c 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
2760c 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
2771c 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
2791c 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
2824c 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
2841c 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
2848c exit
2849c ----
2850
28511000 continue
2852 call utprix('ProSeF',ish,ishini,6)
2853 return
2854
28551001 iret=1
2856 goto1000
2857
2858 end
2859
2860c-----------------------------------------------------------------------
2861 subroutine fstrfl(icp,ict,icp1,icp2,icm1,icm2
2862 * ,idp1,idp2,idm1,idm2,idfp,iret)
2863c-----------------------------------------------------------------------
2864c knowing the string end types (idp1,idp2,idm1,idm2)
2865c and remnant flavors (icp,ict)
2866c and remnant link of the string (idfp)
2867c one determines quark flavors of string ends (icp1,icp2,icm1,icm2)
2868c and updates remnant flavors (icp,ict)
2869c iret=0 ok
2870c iret=1 problem, more than 9 quarks per flavor attempted
2871c-----------------------------------------------------------------------
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)
2876c data neuz/0/proz/0/dtaz/0/
2877c save neuz,proz,dtaz
2878
2879 call utpri('fstrfl',ish,ishini,7)
2880
2881c entry
2882c -----
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
2901c 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
2912c 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
2931c 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
2950c 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
2969c diquarks, code 5 (former valence, but actually sea)
2970
2971 if(idp1.eq.5)then
2972c fc=puds
2973c iq(1,1)=idraflx(fc,iclpro,jcp,2,'s',iret)
2974c if(iq(1,1).eq.3)fc=fc*puds
2975c 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
2980c fc=puds
2981c iq(1,4)=idraflx(fc,icltar,jct,2,'s',iret)
2982c if(iq(1,4).eq.3)fc=fc*puds
2983c 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
2988c fc=puds
2989c iq(1,2)=idraflx(fc,iclpro,jcp,1,'s',iret)
2990c if(iq(1,2).eq.3)fc=fc*puds
2991c 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
2996c fc=puds
2997c iq(1,3)=idraflx(fc,icltar,jct,1,'s',iret)
2998c if(iq(1,3).eq.3)fc=fc*puds
2999c 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
3007c in case of saturated remnants, use the same flavor for quark and anti-quark
3008c 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)
3020c 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)
3025c 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)
3041c 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)
3046c 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
3054c 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
3128c exit
3129c ----
3130
31311000 continue
3132 call utprix('fstrfl',ish,ishini,7)
3133 return
3134 end
3135
3136c-----------------------------------------------------------------------
3137 integer function jdrafl(icl,jc,mod,iret)
3138c-----------------------------------------------------------------------
3139c mod=1
3140c returns random flavor of a quark
3141c
3142c mod=2
3143c jc : quark content of remnant
3144c returns random flavor and update remant with corresponding q-qbar pair \
3145c if there is enough place (else iret=1)
3146c
3147c id=1 u, id=2 d, id=3 s
3148c-----------------------------------------------------------------------
3149 include 'epos.inc'
3150 integer jc(nflav,2)
3151
3152c 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
3173c write(*,*)'jc before updating',jc
3174c 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
3185cc-----------------------------------------------------------------------
3186c subroutine fremfl(icp,ict,iret)
3187cc-----------------------------------------------------------------------
3188cc checks projectile and target flavor (icp,ict)
3189cc in case of reggeon exchange they do not correspond to hadrons.
3190cc one transfers therefore flavor from one side to the other in order
3191cc to have hadron flavor.
3192cc icp and ict are modified correspondingly
3193cc-----------------------------------------------------------------------
3194c include 'epos.inc'
3195c integer icp(2),ict(2),jcp(6,2),jct(6,2),kp(4),kt(4)
3196c
3197c call utpri('fremfl',ish,ishini,7)
3198c
3199cc entry
3200cc -----
3201c
3202c iret=0
3203c
3204c call iddeco(icp,jcp)
3205c call iddeco(ict,jct)
3206c
3207c iakp=0
3208c iakt=0
3209c ikp=0
3210c ikt=0
3211c do l=1,4
3212c kp(l)=jcp(l,1)-jcp(l,2)
3213c kt(l)=jct(l,1)-jct(l,2)
3214c iakp=iakp+iabs(kp(l))
3215c iakt=iakt+iabs(kt(l))
3216c ikp=ikp+kp(l)
3217c ikt=ikt+kt(l)
3218c enddo
3219c if(ish.ge.7)write(ifch,*)'iak_p:',iakp,' ik_p:',ikp
3220c if(ish.ge.7)write(ifch,*)'iak_t:',iakt,' ik_t:',ikt
3221c
3222c if(iakp.eq.4)then
3223c if(ikp.eq.4.or.ikp.eq.-2)then
3224c ifl=idrafl(jcp,1,'v',iret)
3225c iqp=2 ! subtract quark
3226c iqt=1 ! add quark
3227c elseif(ikp.eq.-4.or.ikp.eq.2)then
3228c ifl=idrafl(jcp,2,'v',iret)
3229c iqp=1 ! subtract antiquark
3230c iqt=2 ! add antiquark
3231c else
3232c call utstop('fremfl&')
3233c endif
3234c elseif(iakt.eq.4)then
3235c if(ikt.eq.4.or.ikt.eq.-2)then
3236c ifl=idrafl(jct,1,'v',iret)
3237c iqp=1 ! add quark
3238c iqt=2 ! subtract quark
3239c elseif(ikt.eq.-4.or.ikt.eq.2)then
3240c ifl=idrafl(jct,2,'v',iret)
3241c iqp=2 ! add antiquark
3242c iqt=1 ! subtract antiquark
3243c else
3244c call utstop('fremfl&')
3245c endif
3246c elseif(iakp.eq.3)then
3247c if(ikp.gt.0)then
3248c ifl=idrafl(jcp,1,'v',iret)
3249c iqp=2 ! subtract quark
3250c iqt=1 ! add quark
3251c else
3252c ifl=idrafl(jcp,2,'v',iret)
3253c iqp=1 ! subtract antiquark
3254c iqt=2 ! add antiquark
3255c endif
3256c elseif(iakt.eq.3)then
3257c if(ikt.gt.0)then
3258c ifl=idrafl(jct,1,'v',iret)
3259c iqp=1 ! add quark
3260c iqt=2 ! subtract quark
3261c else
3262c ifl=idrafl(jct,2,'v',iret)
3263c iqp=2 ! add antiquark
3264c iqt=1 ! subtract antiquark
3265c endif
3266c elseif(iakp.eq.2)then
3267c if(ikp.gt.0)then
3268c ifl=idrafl(jct,1,'v',iret)
3269c iqp=1 ! add quark
3270c iqt=2 ! subtract quark
3271c else
3272c ifl=idrafl(jct,2,'v',iret)
3273c iqp=2 ! add antiquark
3274c iqt=1 ! subtract antiquark
3275c endif
3276c elseif(iakt.eq.2)then
3277c if(ikt.gt.0)then
3278c ifl=idrafl(jct,1,'v',iret)
3279c iqp=2 ! subtract quark
3280c iqt=1 ! add quark
3281c else
3282c ifl=idrafl(jct,2,'v',iret)
3283c iqp=1 ! subtract antiquark
3284c iqt=2 ! add antiquark
3285c endif
3286c elseif(iakp.eq.1)then
3287c if(ikp.gt.0)then
3288c ifl=idrafl(jcp,2,'v',iret)
3289c iqp=2 ! add antiquark
3290c iqt=1 ! subtract antiquark
3291c else
3292c ifl=idrafl(jcp,1,'v',iret)
3293c iqp=1 ! add quark
3294c iqt=2 ! subtract quark
3295c endif
3296c elseif(iakt.eq.1)then
3297c if(ikt.gt.0)then
3298c ifl=idrafl(jct,2,'v',iret)
3299c iqp=1 ! subtract antiquark
3300c iqt=2 ! add antiquark
3301c else
3302c ifl=idrafl(jct,1,'v',iret)
3303c iqp=2 ! subtract quark
3304c iqt=1 ! add quark
3305c endif
3306c else
3307c call utstop('fremfl: error&')
3308c endif
3309c
3310c if(ish.ge.7)write(ifch,*)'iq_p:',iqp,' iq_t:',iqt,' if:',ifl
3311c call uticpl(icp,ifl,iqp,iret)
3312c if(iret.ne.0)goto1000
3313c call uticpl(ict,ifl,iqt,iret)
3314c if(iret.ne.0)goto1000
3315c
3316cc exit
3317cc ----
3318c
3319c1000 continue
3320c call utprix('fremfl',ish,ishini,7)
3321c return
3322c end
3323c
3324c-----------------------------------------------------------------------
3325 subroutine fstrwr(j,ii,jj,k,n)
3326c-----------------------------------------------------------------------
3327c take pstg(5,j),pend(4,ii),idend(ii),pend(4,jj),idend(jj) (/cems/)
3328c and write it to /cptl/
3329c-----------------------------------------------------------------------
3330c j: string 1 or 2
3331c ii,jj: string end (1,2: proj; 3,4: targ)
3332c k: current collision
3333c n: current pomeron
3334c-----------------------------------------------------------------------
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
3349c 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
3422c 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
34651000 continue
3466 call utprix('fstrwr',ish,ishini,7)
3467 return
3468 end
3469
3470c-----------------------------------------------------------------------
3471 subroutine ProReF(ir,m)
3472c-----------------------------------------------------------------------
3473c proposes flavor for remnant m for proj (ir=1) or target (ir=-1)
3474c and writes remnant into /cptl/ as string or hadron
3475c ityptl definitions:
3476c 51 41 ... rmn drop
3477c 52 42 ... rmn str inel
3478c 53 43 ... rmn str diff
3479c 54 44 ... rmn str after droplet or hadron split
3480c 55 45 ... rmn res
3481c 56 46 ... rmn res after droplet or hadron split
3482c 57 47 ... rmn res after all Pomeron killed
3483c 58 48 ... rmn res from diff
3484c 59 49 ... hadron split
3485c-----------------------------------------------------------------------
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
3517c 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
3526c 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
3553c 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
3568c 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
3599c 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
3605c.............................exotic ...................................
3606
3607c if(amasini.gt.amasmin.and.irmdropx.eq.1)then
3608
3609c if((iept.eq.6.or.
3610c & .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
3615c if((
3616c & .not.((nqu.eq.3.and.naq.eq.0).or.(nqu.eq.0.and.naq.eq.3)
3617c & .or.(nqu.eq.1.and.naq.eq.1)).or.
3618c & (iept.ne.0.and.iept.le.2.and.reminv/ept(5).gt.rangen()))
3619c & .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
3640c ! 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
3654c 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
3830c...............................................................
3831
3832 500 mm=mmini
3833 if(gdrop)mm=nptlini+2
3834 istptl(mm)=41
3835 ifrptl(1,mm)=nptl+1
3836
3837c........................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
3859c........................ 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
3885c...........................................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
3919c if(iept.le.2.and.ept(5)/reminv.lt.rangen())ireminv=1
3920c 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
3922c if(iept.le.2)then
3923c if(reminv/ept(5).gt.rangen())ireminv=1
3924c elseif(iept.eq.6)then
3925c ireminv=1
3926c 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
3955c elseif(nqu.eq.0)then !---meson---
3956c if(iept.ne.1.and.iept.ne.6.and.rangen().lt.0.5)then
3957c iq=idrafl(iclpt,jcf,1,'v',iret)
3958c call uticpl(icf,iq,2,iret) ! subtract quark
3959c call uticpl(icb,iq,1,iret) ! add quark
3960c else
3961cc put quark in forward direction always for inelastic
3962c iq=idrafl(iclpt,jcf,2,'v',iret)
3963c call uticpl(icf,iq,1,iret) ! subtract antiquark
3964c call uticpl(icb,iq,2,iret) ! add antiquark
3965c 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
3972c if(nqu.eq.3)then !---baryon---
3973c iq1=idrafl(iclpt,jcf,1,'v',iret)
3974c iq2=idrafl(iclpt,jcf,1,'v',iret)
3975c iq3=idrafl(iclpt,jcf,1,'v',iret)
3976c amdqa=qmass(iq2)+qmass(iq3)+qmass(0)
3977c if(rangen().lt.qmass(iq1)/amdqa)ireminv=1
3978c if(ireminv.ne.1)then
3979c call uticpl(icf,iq1,2,iret) ! antiquark
3980c call uticpl(icb,iq1,1,iret) ! quark
3981c else
3982c call uticpl(icf,iq2,2,iret) ! antiquark
3983c call uticpl(icb,iq2,1,iret) ! quark
3984c call uticpl(icf,iq3,2,iret) ! antiquark
3985c call uticpl(icb,iq3,1,iret) ! quark
3986c endif
3987c elseif(nqu.eq.-3)then !---antibaryon---
3988c iq1=idrafl(iclpt,jcf,2,'v',iret)
3989c iq2=idrafl(iclpt,jcf,2,'v',iret)
3990c iq3=idrafl(iclpt,jcf,2,'v',iret)
3991c amdqa=qmass(iq2)+qmass(iq3)+qmass(0)
3992c if(rangen().lt.qmass(iq1)/amdqa)ireminv=1
3993c if(ireminv.ne.1)then
3994c call uticpl(icf,iq1,1,iret) ! antiquark
3995c call uticpl(icb,iq1,2,iret) ! quark
3996c else
3997c call uticpl(icf,iq2,1,iret) ! antiquark
3998c call uticpl(icb,iq2,2,iret) ! quark
3999c call uticpl(icf,iq3,1,iret) ! antiquark
4000c call uticpl(icb,iq3,2,iret) ! quark
4001c endif
4002c elseif(nqu.eq.0)then !---meson---
4003c iq1=idrafl(iclpt,jcf,1,'v',iret)
4004c iq2=idrafl(iclpt,jcf,2,'v',iret)
4005c if(rangen().lt.qmass(iq1)/qmass(iq2))then
4006cc if(rangen().gt.0.5)then
4007c call uticpl(icf,iq1,2,iret) ! subtract quark
4008c call uticpl(icb,iq1,1,iret) ! add quark
4009c else
4010c call uticpl(icf,iq2,1,iret) ! subtract antiquark
4011c call uticpl(icb,iq2,2,iret) ! add antiquark
4012c endif
4013c else
4014c call utmsg('ProReF')
4015c write(ifch,*)'***** neither baryon nor antibaryon nor meson.'
4016c write(ifch,*)'***** number of net quarks:',nqu
4017c call utstop('ProRef&')
4018c 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
4123c............................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
4174c.......................................................................
4175c print *,iep(1),iet(1),ityptl(nptl)
4176 1000 call utprix('ProReF',ish,ishini,3)
4177ctp060829 if(ityptl(nptl).gt.60)print*,ityptl(nptl)
4178 return
4179
4180 end
4181
4182c---------------------------------------------------------------------------------------
4183 subroutine RemoveHadrons(gproj,gtarg,ghadr,m,mm,jcf,icf,ept)
4184c---------------------------------------------------------------------------------------
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.
4213c 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
4255c deleted: after abstracting a meson,
4256c check if the NEW remnant is a H-Dibaryon
4257 enddo
4258 endif
4259c 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
4306c deleted: after abstracting a (anti)baryon,
4307c check if the NEW remnant is a H-Dibaryon
4308 enddo
4309 endif
4310 end
4311
4312c------------------------------------------------------------------
4313 subroutine gethadron(imb,idf,a,jc,ep,ir,iret)
4314c------------------------------------------------------------------
4315c goal: emit a hadron (imb= 1 meson, 2 baryon, 3 antibaryon)
4316c update the remnant flavour and 5-momentum
4317c
4318c idf ,a : hadron id and 5-momentum
4319c ir : 1 projectile, -1 target remnant
4320c jc, ep : remnant flavor and 5-momentum
4321c iret : in case of error, keep correct momentum in remnant
4322c and lose the quarks of the (not) emitted hadron
4323c-----------------------------------------------------------------
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
4354c 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
4392c 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
4407c initial limits
4408
4409 ptm=p1(5)
4410 amasex=dble(amss)
4411 strmas=dble(2.*utamnz(jc,4))
4412 sxini=ptm*ptm
4413c 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
4426c 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
4446c 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
4471c Fix re of remnant
4472
4473c 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
4489c Fix a of hadron
4490
4491c 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
4541c ghost condition
4542c if(abs((a(4)+a(3))*(a(4)-a(3))
4543c $ -a(2)**2-a(1)**2-a(5)**2).gt.0.3
4544c $ .and. abs(1.-abs(a(3))/a(4)).gt.0.01)print*,iret,dd
4545
4546c$$$ if(iodiba.eq.1)then ! for H-dibaryon study ??????????
4547c$$$ call idenco(jc,ic,iret)
4548c$$$ if(ic(1).eq.222000.and.ic(2).eq.0)ep(5)=ep(5)-bidiba
4549c$$$ endif
4550
4551 if(ish.ge.5)then
4552 write(ifch,*)'new remnant flavour and 5-momentum:',jc, ep
4553 endif
4554c write(ifmt,*)'get hadron with id and 5-momentum:',idf, a
4555c 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
4564c------------------------------------------------------------------
4565 subroutine getdroplet(ir,ic,jc,ep,a,pass,mdrmax)
4566c------------------------------------------------------------------
4567c emit a droplet, update the remnant string flavour and 5-momentum
4568c
4569c input
4570c ir ........ 1 projectile, -1 target remnant
4571c ep ........ remnant 5-momentum
4572c jc ........ remnant jc
4573c output
4574c pass ... .true. = successful droplet emission
4575c ic, ep ....... droplet ic and 5-momentum
4576c jc, a ........ remnant string jc and 5-momentum
4577c .false. = unsuccessful
4578c jc, ep .... unchanged,
4579c considered as droplet jc and 5-momentum
4580c-----------------------------------------------------------------
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
4627c 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
4661c 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
4681c 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
4703c If there is already 2 q or 2 aq as string end, we know that we need
4704c 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
4758c 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)
4767ccc print*,idx,amx
4768
4769
4770c 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
4786c 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
4797c 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
4813c 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
4825c 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
4841c 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
4854c write(ifch,*)'ini',xmin,xxx,xmax,rr,ampt2dro
4855c & ,(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
4869c 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
4895c Fix a of string
4896
4897c 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
4913c Fix ep of droplet
4914
4915c 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
4942c 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
4966c-----------------------------------------------------
4967 subroutine neworder(n1, n2, n3)
4968c-----------------------------------------------------
4969c make 3 integers ordered like 1 2 3
4970c------------------------------------------------------
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
4988c-----------------------------------------------------------------------
4989 function idtr2(ic)
4990c-----------------------------------------------------------------------
4991c transforms ic to id such that only hadrons have nonzero id
4992c-----------------------------------------------------------------------
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)
50241 continue
5025 return
5026 end
5027
5028c----------------------------------------------------------------------
5029 subroutine emsini(e,idpj,idtg)
5030c----------------------------------------------------------------------
5031c energy-momentum sharing initializations
5032c----------------------------------------------------------------------
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
5044c abreviations
5045
5046 plc=dble(e)
5047 s=plc**2
5048 amd=dble(delrex)
5049
5050
5051c 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
5064c 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
5078c alpha_trailing and beta_trailing (0=meson, 1=baryon;
5079c 0=no excit, 1=nondiffr, 2=diffr,
5080c 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
5093c 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
5109c 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
5116c 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
5123c 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
5143c minimal excitation masses (0=meson, 1=baryon
5144c 0=no excit, 1=nondiffr, 2=diffr,
5145c 6=nondiffr but no pomeron)
5146
5147 xdm2=0.35d0
5148c to take into account increase of mean pt in inelastic remnants
5149c 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
5152c amemn(0,1)=0d0
5153 amemn(0,2)=xdm2+0.31d0
5154c amemn(0,2)=0.d0
5155 amemn(0,3)=xdm2+0.31d0
5156c amemn(0,6)=xdm2+0.31d0
5157 amemn(0,6)=0.d0
5158c amemn(1,0)=0d0
5159 amemn(1,1)=xdm2+0.15d0 !+0.15d0
5160c amemn(1,1)=0d0
5161 amemn(1,2)=xdm2+0.15d0
5162c amemn(1,2)=0.d0
5163 amemn(1,3)=xdm2+0.15d0
5164c amemn(1,6)=xdm2+0.15d0
5165 amemn(1,6)=0.d0
5166
5167c 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
5175c initial quark configuration
5176 ivp0=3
5177 iap0=0
5178 idp0=1
5179 isp0=0
5180
5181 elseif(idpj.lt.-1000)then ! antibaryon
5182
5183c initial quark configuration
5184 ivp0=0
5185 iap0=3
5186 idp0=1
5187 isp0=0
5188
5189 else ! meson
5190
5191c 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
5201c initial quark configuration
5202 ivt0=3
5203 iat0=0
5204 idt0=1
5205 ist0=0
5206
5207 elseif(idtg.lt.-1000)then ! antibaryon
5208
5209c initial quark configuration
5210 ivt0=0
5211 iat0=3
5212 idt0=1
5213 ist0=0
5214
5215 else ! meson
5216
5217c initial quark configuration
5218 ivt0=1
5219 iat0=1
5220 idt0=0
5221 ist0=0
5222
5223 endif
5224
5225
5226c eikonal parameters
5227
5228 dcel=dble(chad(iclpro)*chad(icltar))
5229
5230c 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
5254c-----------------------------------------------------------------------
5255 subroutine emsigr
5256c-----------------------------------------------------------------------
5257c initialize grid
5258c-----------------------------------------------------------------------
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
5269c 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
527910 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
5295c initial value for interaction type
5296
5297 itpr(k)=0
5298
5299c 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
5346c-----------------------------------------------------------------------
5347 subroutine emsipt
5348c-----------------------------------------------------------------------
5349c initialize projectile and target
5350c-----------------------------------------------------------------------
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
5364c 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
5392c 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
5424c-----------------------------------------------------------------------
5425 subroutine emszz
5426c-----------------------------------------------------------------------
5427c completes /cptl/ for nucleons, checks for no interaction
5428c writes /cevt/
5429c-----------------------------------------------------------------------
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
5438c write /cptl/
5439c ------------
5440
5441 if(iokoll.eq.1)then ! precisely matarg collisions
5442
5443c nothing to do
5444
5445 else
5446
5447c 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)
54658 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
5470c 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
5494c write(6,*)'npj,ntg,npj+ntg:',npj,ntg,npj+ntg
5495
5496 endif
5497
5498c write /cevt/
5499c ------------
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
5512c exit
5513c ----
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
55231000 continue
5524 call utprix('emszz ',ish,ishini,6)
5525 return
5526
55271001 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
5538c-----------------------------------------------------------------------
5539 subroutine ProCop(i,ii)
5540c-----------------------------------------------------------------------
5541c Propose Coordinates of remnants from active projectile nucleons
5542c-----------------------------------------------------------------------
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
5565c 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
5581c 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)))
5598c aprojex=max(ampmn(idp(i))+amemn(idp(i),iep(i))
5599c & ,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
5615c write(ifmt,*)'ProCop',i,nptl
5616
5617 return
5618
5619 end
5620
5621c-----------------------------------------------------------------------
5622 subroutine ProCot(j,jj)
5623c-----------------------------------------------------------------------
5624c Propose Coordinates of remnants from active targets nucleons
5625c-----------------------------------------------------------------------
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
5649c 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
5665c 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)))
5682c atargex=max(amtmn(idt(j))+amemn(idt(j),iet(j))
5683c & ,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
5699c write(ifmt,*)'ProCot',j,nptl
5700
5701 return
5702 end
5703
5704c-----------------------------------------------------------------------
5705 subroutine emswrp(i,ii)
5706c-----------------------------------------------------------------------
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
5721c t=xorptl(4,kolp(i))
5722c istptl(ii)=1
5723c iorptl(ii)=-1
5724c tivptl(2,ii)=t
5725c nptl=nptl+1
5726c npproj(i)=nptl
5727c idptl(nptl)=idptl(ii)*100+99 !100*10**idp(i)+iep(i)
5728c istptl(nptl)=40
5729c ityptl(nptl)=40
5730c iorptl(nptl)=ii
5731c jorptl(nptl)=kolp(i)
5732c ifrptl(1,nptl)=0
5733c ifrptl(2,nptl)=0
5734c xorptl(1,nptl)=xorptl(1,ii)
5735c xorptl(2,nptl)=xorptl(2,ii)
5736c xorptl(3,nptl)=xorptl(3,ii)
5737c xorptl(4,nptl)=t
5738c tivptl(1,nptl)=t
5739c tivptl(2,nptl)=t
5740c mm=nptl
5741c 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
5770c-----------------------------------------------------------------------
5771 subroutine emswrt(j,jj)
5772c-----------------------------------------------------------------------
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
5788c t=xorptl(4,kolt(j))
5789c istptl(jj)=1
5790c iorptl(jj)=-1
5791c tivptl(2,jj)=t
5792c nptl=nptl+1
5793c nptarg(j)=nptl
5794c idptl(nptl)=idptl(jj)*100+99 !100*10**idp(i)+iep(i)
5795c istptl(nptl)=40
5796c ityptl(nptl)=50
5797c iorptl(nptl)=jj
5798c jorptl(nptl)=kolt(j)
5799c ifrptl(1,nptl)=0
5800c ifrptl(2,nptl)=0
5801c xorptl(1,nptl)=xorptl(1,jj)
5802c xorptl(2,nptl)=xorptl(2,jj)
5803c xorptl(3,nptl)=xorptl(3,jj)
5804c xorptl(4,nptl)=t
5805c tivptl(1,nptl)=t
5806c tivptl(2,nptl)=t
5807c mm=nptl
5808c 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
5836c-----------------------------------------------------------------------
5837 subroutine emswrpom(k,i,j)
5838c-----------------------------------------------------------------------
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
588830 continue
5889
5890 return
5891 end
5892
5893cc--------------------------------------------------------------------------
5894c subroutine reaction(idpj,idtg,ireac)
5895cc--------------------------------------------------------------------------
5896cc returns reaction code ireac
5897cc--------------------------------------------------------------------------
5898c iap=iabs(idpj/10)
5899c iat=iabs(idtg/10)
5900c isp=idpj/10/iap
5901c ist=idtg/10/iat
5902c call idchrg(idpj,cp)
5903c call idchrg(idtg,ct)
5904c ac=abs(cp+ct)
5905c if(iap.gt.100)then
5906c if(iat.gt.100)then
5907c if(isp.eq.1)then
5908c if(ist.eq.1)then
5909c ireac=1
5910c else
5911c ireac=6
5912c endif
5913c else
5914c if(ist.eq.1)then
5915c ireac=6
5916c else
5917c ireac=1
5918c endif
5919c endif
5920c elseif(iat.eq.11.or.iat.eq.12.or.iat.eq.22)then
5921c if(ac.ge.2.)then
5922c ireac=2
5923c else
5924c ireac=3
5925c endif
5926c else
5927c if(ac.ge.2.)then
5928c ireac=4
5929c else
5930c ireac=5
5931c endif
5932c endif
5933c elseif(iap.eq.11.or.iap.eq.12.or.iap.eq.22)then
5934c if(iat.gt.100)then
5935c if(ac.ge.2.)then
5936c ireac=2
5937c else
5938c ireac=3
5939c endif
5940c elseif(iat.eq.11.or.iat.eq.12.or.iat.eq.22)then
5941c ireac=7
5942c else
5943c ireac=8
5944c endif
5945c else
5946c if(iat.gt.100)then
5947c if(ac.ge.2.)then
5948c ireac=4
5949c else
5950c ireac=5
5951c endif
5952c elseif(iat.eq.11.or.iat.eq.12.or.iat.eq.22)then
5953c ireac=8
5954c else
5955c ireac=9
5956c endif
5957c endif
5958c
5959c end
5960c
5961c-----------------------------------------------------------------------
5962 subroutine xEmsI1(iii,kc,omlog)
5963c-----------------------------------------------------------------------
5964c plot omlog vs iter
5965c plot nr of pomerons vs iter
5966c plot number of collisions vs iter
5967c-----------------------------------------------------------------------
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
5985c 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)
5994c 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
6010ctp060829 ip=iproj(ko)
6011ctp060829 it=itarg(ko)
6012 om1i=sngl(om1intbc(bk(ko)))
6013ctp060829 wk=1.
6014ctp060829 wp=0.
6015ctp060829 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
6121c-----------------------------------------------------------------------
6122 subroutine xEmsI2(iii,kc)
6123c-----------------------------------------------------------------------
6124c plot quanities vs iter
6125c plot 1: <x> for Pomeron vs iter
6126c plot 2: <x> for projectile vs iter
6127c plot 3: <x> for target vs iter
6128c arguments:
6129c iii: modus (1,2)
6130c kc: iteration step
6131c omega: config probability
6132c-----------------------------------------------------------------------
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
6149c ip=iproj(k)
6150c 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
6243c-----------------------------------------------------------------------
6244 subroutine xEmsRx(iii,id,xp,xm)
6245c-----------------------------------------------------------------------
6246c plot x+, x-, x, y distribution of remnants
6247c-----------------------------------------------------------------------
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
62931 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
63012 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
63103 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
63214 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
6419c-----------------------------------------------------------------------
6420 subroutine xEmsPm(iii,ko,nmc)
6421c-----------------------------------------------------------------------
6422c m (pomeron number) distribution for different b-bins.
6423c arguments:
6424c iii: modus (0,1,2)
6425c ko: pair number (1 - AB)
6426c nmc: number of pomerons
6427c-----------------------------------------------------------------------
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
6533c-----------------------------------------------------------------------
6534 subroutine xEmsB(iii,jjj,ko)
6535c-----------------------------------------------------------------------
6536c b distribution at different stages
6537c arguments:
6538c iii: modus (0,1,2)
6539c jjj: stage or type of interaction
6540c just after Metropolis:
6541c 1 ... all
6542c 2 ... interaction
6543c after defining diffraction:
6544c 3 ... nothing
6545c 4 ... cut
6546c 5 ... diffr
6547c 6 ... cut + diffr
6548c ko: pair number (1 - AB)
6549c-----------------------------------------------------------------------
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
6711c-----------------------------------------------------------------------
6712 subroutine xEmsBg(iii,jjj,ko)
6713c-----------------------------------------------------------------------
6714c b distribution at different stages for different group
6715c arguments:
6716c iii: modus (0,1,2,3)
6717c jjj: group of interaction (1,2 ... ,7)
6718c ko: pair number (1 - AB)
6719c-----------------------------------------------------------------------
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
6765c om1i=sngl(PhiExpo(1.,1.d0,1.d0,engy*engy,bk(k)))
6766c 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
6808c if(wg(0,k).ne.0..and.nng(k).ne.0)y=wg(j,k)/nng(k)*wg(-1,k)/wg(0,k)
6809c!???????????? better normalization ? probability to have an interaction
6810c in epos compared to eikonal probability, instead of normalized by the
6811c probability of a collision for a pair (the number collision/number
6812c 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
6843c 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
6858c-----------------------------------------------------------------------
6859 subroutine xEmsPx(iii,xmc,ymc,npos)
6860c-----------------------------------------------------------------------
6861c plot x-distribution and y-distribution of Pomerons
6862c-----------------------------------------------------------------------
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.
69481 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.
695511 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.
69642 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.
697112 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.
69803 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.
698713 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
7269c-----------------------------------------------------------------------
7270 subroutine xEmsP2(iii,jaa,jex,xpd,xmd,xpb,xmb,pt1,pt2)
7271c-----------------------------------------------------------------------
7272c plot x+ distributions of Pomeron ends (PE) (xpd)
7273c and Pomeron's in Born (IB) partons (xpb),
7274c and pt dist of Pomeron's out Born (OB) partons
7275c integrated over x- bins (xmd,xmb)
7276c iii=0: initialize
7277c ii=1: fill arrays
7278c iii>=2: make histogram
7279c (2 - Pomeron end PE, 3 - in Born IB, 4 - out Born OB)
7280c jaa: type of semihard Pomeron
7281c 1= sea-sea, 2= val=sea, 3= sea-val, 4= val-val
7282c 5= all for iii=2
7283c jex: emission type
7284c 1= no emission, 2= proj emis, 3= targ emis, 4= both sides
7285c 5= all for iii=2
7286c-----------------------------------------------------------------------
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
7299ctp060829 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.
73582 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.
736912 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
7408ctp060829 mmmm=1
7409ctp060829 bb=bmaxim
7410 ff=float(nrevt)/float(ntevt)
7411ctp060829 imod=' dn'
7412 elseif(maproj.eq.1.and.matarg.eq.1)then
7413ctp060829 mmmm=3
7414 ff=1.
7415ctp060829 imod=' dn'
7416 elseif(bminim.lt.0.001.and.bmaxim.gt.20)then
7417ctp060829 mmmm=2
7418 area=pi*(rmproj+rmtarg)**2
7419 ff=area*float(nrevt)/float(ntevt)/(maproj*matarg)/sigine*10
7420ctp060829 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
7431ctp060829 xmi1=xlub1*(xlob/xlub1)**((j1-1.)/nbixm)
7432ctp060829 xmi2=xlub1*(xlob/xlub1)**((j2-0.)/nbixm)
7433 xlub=xlub1
7434 elseif(kkk.eq.2)then
7435ctp060829 xmi1=xlub2+(xlob-xlub2)*((j1-1.)/nbixm)
7436ctp060829 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
7686c-----------------------------------------------------------------------
7687 subroutine xEmsSe(iii,xmc,ptmc,ih,iqq)
7688c-----------------------------------------------------------------------
7689c iqq = 1 : String End mass and rapidity
7690c iqq = 2 : String mass and rapidity
7691c-----------------------------------------------------------------------
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
77311 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
7778c-----------------------------------------------------------------------
7779 subroutine xEmsDr(iii,xpmc,xmmc,ie)
7780c-----------------------------------------------------------------------
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
78381 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
7962cc--------------------------------------------------------------------------
7963c subroutine xtype(k,n,i1,i2,text)
7964cc--------------------------------------------------------------------------
7965c
7966c include 'epos.inc'
7967c include 'epos.incems'
7968c parameter(itext=40)
7969c character text*40
7970c
7971c imax=itext+1
7972c do i=itext,1,-1
7973c if(text(i:i).eq.'&')imax=i
7974c enddo
7975c
7976c ip=iproj(k)
7977c it=itarg(k)
7978c
7979c if(i1.eq.1)then
7980c write(ifch,*)
7981c write(ifch,*)('-',ll=1,27)
7982c write(ifch,*)' '//text(1:imax-1)
7983c write(ifch,*)('-',ll=1,27)
7984c endif
7985c
7986c if(i2.eq.1)then
7987c write(ifch,*)
7988c write(ifch,*)'k:',k,' n:',n,' ip:',ip,' it:',it
7989c write(ifch,*)'bk:',bk(k)
7990c if(n.ne.0)write(ifch,*)'idpr:',idpr(n,k)
7991c write(ifch,*)'iep:',iep(ip),' iet:',iet(it)
7992c write(ifch,*)'idp:',idp(ip),' idt:',idt(it)
7993c endif
7994c
7995c end
7996c
7997c------------------------------------------------------------------------
7998 subroutine XPrint(text)
7999c------------------------------------------------------------------------
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
8058c-------------------------------------------------------------------------
8059 subroutine xfom
8060c-------------------------------------------------------------------------
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