]> git.uio.no Git - u/mrichter/AliRoot.git/blame - EPOS/epos167/epos-dro-168.f
git://git.uio.no / u / mrichter / AliRoot.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Update timestamp for new data points simulation
[u/mrichter/AliRoot.git] / EPOS / epos167 / epos-dro-168.f
CommitLineData
9ef1c2d9 1c----------------------------------------------------------------------
2 subroutine amicro
3c----------------------------------------------------------------------
4c microcanonical decay of cluster specified via keu...ket, tecm, volu
5c----------------------------------------------------------------------
6 include 'epos.inc'
7 common/drop9/mkeu,mked,mkes,mkec,mkeb,mket
8 $ ,iwkeu,iwked,iwkes,iwkec,iwkeb,iwket
9 common/cxyzt/xptl(mxptl),yptl(mxptl),zptl(mxptl),tptl(mxptl)
10 *,optl(mxptl),uptl(mxptl),sptl(mxptl),rptl(mxptl,3)
11 double precision tpro,zpro,ttar,ztar,ttaus,detap,detat
60ed90b3 12 common /cttaus/ tpro,zpro,ttar,ztar,ttaus,detap,detat
9ef1c2d9 13 integer jc(nflav,2),ic(2)
14
15 call utpri('amicro',ish,ishini,4)
16
17 nevt=0
18 nptl=0
19
20 ttaus=1
21ctp060829 taus=sngl(ttaus)
22 ypjtl=6
23 yhaha=3
24 etapro=(ypjtl-yhaha)*etafac
25 etatar=-yhaha*etafac
26 detap=dble(etapro)
27 detat=dble(etatar)
28 tpro=dcosh(detap)
29 zpro=dsinh(detap)
30 ttar=dcosh(detat)
31 ztar=dsinh(detat)
32
33 if(ish.ge.5)write(ifch,'(a/6i4)')
34 *' keu ked kes kec keb ket:',keu,ked,kes,kec,keb,ket
35 do i=1,6
36 jc(i,1)=0
37 jc(i,2)=0
38 enddo
39 10 if(mkeu.ne.0.or.iwkeu.ne.0)then
40 12 x=-log(rangen())*iwkeu+mkeu
41 if(rangen().lt.0.5) x=real(mkeu)-(x-real(mkeu))
42 if( exp(-((x-mkeu)/iwkeu)**2) / exp(-abs(x-mkeu)/iwkeu)/2
43 $ .lt. rangen() ) goto 12
44 keu=nint(x)
45 endif
46 if(mked.ne.0.or.iwked.ne.0)then
47 13 x=-log(rangen())*iwked+mked
48 if(rangen().lt.0.5) x=real(mked)-(x-real(mked))
49 if( exp(-((x-mked)/iwked)**2) / exp(-abs(x-mked)/iwked)/2
50 $ .lt. rangen() ) goto 13
51 ked=nint(x)
52 endif
53 if(mkes.ne.0.or.iwkes.ne.0)then
54 15 x=-log(rangen())*iwkes+mkes
55 if(rangen().lt.0.5) x=real(mkes)-(x-real(mkes))
56 if( exp(-((x-mkes)/iwkes)**2) / exp(-abs(x-mkes)/iwkes)/2
57 $ .lt. rangen() ) goto 15
58 kes=nint(x)
59 endif
60ed90b3 60 if(real((keu+ked+kes)/3).ne.real(keu+kes+ked)/3.) goto 10
9ef1c2d9 61 if(keu.ge.0)jc(1,1)=keu
62 if(ked.ge.0)jc(2,1)=ked
63 if(kes.ge.0)jc(3,1)=kes
64 if(kec.ge.0)jc(4,1)=kec
65 if(keb.ge.0)jc(5,1)=keb
66 if(ket.ge.0)jc(6,1)=ket
67 if(keu.lt.0)jc(1,2)=-keu
68 if(ked.lt.0)jc(2,2)=-ked
69 if(kes.lt.0)jc(3,2)=-kes
70 if(kec.lt.0)jc(4,2)=-kec
71 if(keb.lt.0)jc(5,2)=-keb
72 if(ket.lt.0)jc(6,2)=-ket
73 if(ish.ge.5)write(ifch,'(a/6i4/6i4)')' jc:',jc
74 idr=0
75 do nf=1,nflav
76 do ij=1,2
77 if(jc(nf,ij).ge.10)idr=7*10**8
78 enddo
79 enddo
80 if(idr/10**8.ne.7)then
81 call idenco(jc,ic,ireten)
82c if(ireten.eq.1)call utstop('ametro: idenco ret code = 1&')
83 if(ic(1).eq.0.and.ic(2).eq.0)then
84 ic(1)=100000
85 ic(2)=100000
86 endif
87
88 idr=8*10**8+ic(1)*100+ic(2)/100
89 if(ish.ge.5)write(ifch,'(a,i9)')' id:',idr
90 dez=0.5e-4
60ed90b3 91 else
9ef1c2d9 92 idr=idr
93 * +mod(jc(1,1)+jc(2,1)+jc(3,1)+jc(4,1),10**4)*10**4
94 * +mod(jc(1,2)+jc(2,2)+jc(3,2)+jc(4,2),10**4)
95 call idtrbi(jc,ibptl(1,1),ibptl(2,1),ibptl(3,1),ibptl(4,1))
96 dez=0.5e-4
97 endif
98
99 pptl(1,1)=0
100 pptl(2,1)=0
101 pptl(3,1)=0
102 pptl(4,1)=tecm
103 pptl(5,1)=tecm
104
105 g=1
106
107 nptl=nptl+1
108 idptl(nptl)=idr
109 pptl(1,nptl)=0
110 pptl(2,nptl)=0
111 pptl(3,nptl)=0
112 pptl(4,nptl)=tecm*g
113 pptl(5,nptl)=tecm*g
114 radptl(nptl)=(3*volu/pi/4.)**0.33333
115 istptl(nptl)=10
116 tivptl(2,1)=1.
60ed90b3 117
9ef1c2d9 118 nptlb=nptl
119 call hnbaaa(nptl,iret)
120 if(iret.eq.1)stop'STOP: sr amicro: hnbaaa return code = 1. '
121 istptl(nptl)=istptl(nptl)+1
122 ifrptl(1,nptl)=nptlb+1
123 ifrptl(2,nptl)=nptl
124 x=xorptl(1,nptl)
125 y=xorptl(2,nptl)
126 z=xorptl(3,nptl)
127 t=xorptl(4,nptl)
128 do n=nptlb+1,nptl
129 iorptl(n)=nptlb
130 jorptl(n)=0
131 istptl(n)=0
132 ifrptl(1,n)=0
133 ifrptl(2,n)=0
60ed90b3 134 xorptl(1,n)=x
135 xorptl(2,n)=y
9ef1c2d9 136 xorptl(3,n)=z
137 xorptl(4,n)=t
138 tivptl(1,n)=t
139 call idtau(idptl(n),pptl(4,n),pptl(5,n),taugm)
140 r=rangen()
141 tivptl(2,n)=t+taugm*(-alog(r))
142 ityptl(n)=60
143 radptl(n)=0.
144 itsptl(n)=0
145 rinptl(n)=-9999
146 enddo
147
148 if(ioceau.eq.1)call xhnbte(0)
149 if(iociau.eq.1)call xhnbti(0)
150
151 call utprix('amicro',ish,ishini,4)
152 return
153 end
154
155c-----------------------------------------------------------------------
156 subroutine hgcaaa
157c-----------------------------------------------------------------------
158c hadronic resonance gas in grand canonical treatment
60ed90b3 159c returns T, chemical potentials and hadronic yield
160c (hadron chemical potentials as combinations of quark chemical potentials)
9ef1c2d9 161c
162c input:
163c iostat: 1: Boltzmann approximation, 0: quantum statistics /metr3/
164c tecm: droplet energy /confg/
165c volu: droplet volume /confg/
166c keu ked kes kec keb ket: net flavor number /drop5/
167c
168c output:
169c tem : temperature [GeV] /cgchg/
170c chem(1:nflav): quark chem. pot. [GeV] /cflav/
171c chemgc(1:nspecs): hadron chem. pot. [GeV] /cgchg/
172c ptlngc(1:nspecs): hadron number /cgchg/
173c rmsngc(1:nspecs): standard deviation of hadron number /cgchg/
174c
175c exact treatment (iostat=0):
176c for massive hadrons : first in Boltzmann approximation with analytical
177c expressions for particle and energy densities,
178c then by using quantum statistics in integral form,
179c extracting mu and T using numerical integration
180c and an iterative procedure to solve for mu, T
181c for massless hadrons : using analytic expressions for massles particles
182c and employing the same algorithm as for massive
183c-----------------------------------------------------------------------
184 include 'epos.inc'
60ed90b3 185 parameter (mspecs=56)
9ef1c2d9 186 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
187 common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
188 common/cbol/rmsbol(mspecs),ptlbol(mspecs),chebol(mspecs),tembol
189 common/cflavs/nflavs,kef(nflav),chem(nflav)
190 common/ciakt/gen,iafs,ians,genm
191 common/cnrit/nrit
192 gen=10.0**(-epsgc)
193 genm=gen/10.
194
195 isho=ish
196 if(ishsub/100.eq.51)ish=mod(ishsub,100)
197
198 iug=(1+iospec)/2*2-1
199
200
201c initialization
202c --------------
203 kef(1)=keu
204 kef(2)=ked
205 kef(3)=kes
206 kef(4)=kec
207 kef(5)=keb
208 kef(6)=ket
209
210 if(iug.eq.1)nflavs=1
211 if(iug.eq.3)nflavs=2
212 if(iug.eq.5)nflavs=2
213 if(iug.eq.7)nflavs=3
214 if(iug.eq.9)nflavs=3
215 if(iug.eq.11)nflavs=3
216 tem=0.0
217 do i=1,nflavs
218 chem(i)=0.0
219 enddo
220 call hgchac(0)
221 do i=1,nspecs
222 ptlngc(i)=0.0
223 rmsngc(i)=0.0
224 enddo
225 nrit=0
226
227 if(ish.ge.5)then
228 write(ifch,*)('-',l=1,10)
229 *,' entry sr hgcaaa ',('-',l=1,30)
230 write(ifch,'(1x,a,2x,3i3)')
231 *'>>> grand canonical hadron gas for droplet with u d s content:'
232 *,keu,ked,kes
233 write(ifch,'(1x,a,2x,f7.3,2x,a,2x,f7.3)')
234 *'mass [GeV]:',tecm,'volume [fm^3]:',volu
235 endif
236
237 if(iug.eq.1.and.keu.ne.0.and.ish.ge.5)then
238 write(ifch,*)'inversion impossible !!!'
239 write(ifch,*)'keu=0 required for this option'
240 write(ifch,*)'T = mu(i) = 0 returned'
241 if(ish.ge.5)write(ifch,*)('-',i=1,30)
242 *,' exit sr hgcaaa ',('-',i=1,10)
243 return
244 endif
245 if(iug.eq.3.and.(keu+ked).ne.0.and.ish.ge.5)then
246 write(ifch,*)'inversion impossible !!!'
247 write(ifch,*)'keu+ked=0 required for this option'
248 write(ifch,*)'T = mu(i) = 0 returned'
249 if(ish.ge.5)write(ifch,*)('-',i=1,30)
250 *,' exit sr hgcaaa ',('-',i=1,10)
251 return
252 endif
253 kf=keu+ked+kes+kec+keb+ket
254 kf=abs(kf)
255 if(kf.ne.0)then
256 if(mod(kf,3).ne.0.and.ish.ge.5)then
257 write(ifch,*)'inversion impossible !!!'
258 write(ifch,*)'sum must be multiple of three'
259 write(ifch,*)'T = mu(i) = 0 returned'
260 if(ish.ge.5)write(ifch,*)('-',i=1,30)
261 *,' exit sr hgcaaa ',('-',i=1,10)
262 return
263 endif
264 endif
265
266
267c initial T (m=0, baryon free)
268c -------------------------------
269 gfac=0.0
270
271 if(iostat.eq.0.and.iospec.eq.iug)then
272 do i=1,nspecs
273 igsp=int(gspecs(i))
274 if(mod(igsp,2).eq.0)then
275 gfac=gfac+7.*gspecs(i)/8.
276 else
277 gfac=gfac+gspecs(i)
278 endif
279 enddo
60ed90b3 280 if(iabs(ispecs(nspecs)).lt.10)gfac=gfac+16.
9ef1c2d9 281 tem=(tecm/volu*hquer**3*30./pi**2/gfac)**.25
282 else
283 do i=1,nspecs
284 gfac=gfac+gspecs(i)
285 enddo
286 if(iabs(ispecs(nspecs)).lt.10)gfac=gfac+16.
287 tem=(tecm/volu*hquer**3*pi**2/gfac/3.)**.25
288 tem=2.*tem
289 endif
290
291 if(ish.ge.5)write(ifch,1)'initial T :',tem
2921 format(1x,a,3x,f9.6)
293
294 if(ish.ge.5)write(ifch,*)'iospec: ',iospec
295
296 if(ish.ge.5.and.iospec.ne.iug)then
297 write(ifch,*)'inversion in Boltzmann approx. :'
60ed90b3 298 elseif(ish.ge.5.and.iospec.eq.iug)then
9ef1c2d9 299 write(ifch,*)'inversion for massless hadrons :'
300 endif
301
60ed90b3 302 if(ish.ge.5)then
9ef1c2d9 303 if(nflavs.eq.1)write(ifch,'(3x,a,8x,a)')
304 *'T:','chemu:'
305 if(nflavs.eq.2)write(ifch,'(3x,a,8x,a,5x,a)')
306 *'T:','chemu:','chemd:'
307 if(nflavs.eq.3)write(ifch,'(3x,a,8x,a,5x,a,5x,a)')
308 *'T:','chemu:','chemd:','chems:'
309 endif
310
311 k=1
31210 continue
313 if(ish.ge.9.and.mod(k,10).eq.0)
314 *write(ifch,*)'hgc iteration:',k
315 if(ish.ge.9)call hgccch(1)
316
317c search for temperature (chem=const)
318c -----------------------------------
319 idt=0
320 temo=tem
321
322 if(iospec.eq.iug)then
323
324c massless particles
325c ------------------
326 if(iostat.eq.0)then
327 if(ish.ge.9)
328 *write(ifch,*)'iteration (massless):',k
329 call hgctm0
330 elseif(iostat.eq.1)then
331 if(ish.ge.9)
332 *write(ifch,*)'iteration (Boltzmann, massless):',k
333 call hgctbo(ibna)
334 if(ibna.eq.1)then
335 tem=temo
336 goto20
337 endif
338 endif
339
340 else
341
342c Boltzmann approxiamtion (massive particles)
343c -------------------------------------------
344 if(ish.ge.9)
345 *write(ifch,*)'iteration (Boltzmann, massive):',k
346 call hgctbo(ibna)
347 if(ibna.eq.1)then
348 tem=temo
349 goto20
350 endif
351
352 endif
353
354 if(tem.le.1.e-6.and.ish.ge.5)then
355 write(ifch,*)'inversion imposssible'
356 write(ifch,*)'T:',tem
357 if(ioinco.ge.1)call hnbmin(keu,ked,kes,kec)
358 if(ish.ge.5)write(ifch,*)('-',i=1,30)
359 *,' exit sr hgcaaa ',('-',i=1,10)
360 ish=isho
361 return
362 endif
363
364 dt=abs(temo-tem)
365 if(dt.le.gen*temo.or.dt.le.genm)idt=1
366
367c search for chemical potentials (tem=const)
368c ------------------------------------------
369 idch=0
370 ibna=0
371
372 do iafs=1,nflavs
373 chemo=chem(iafs)
374
375 if(iospec.eq.iug)then
376
377c massless particles
378c ------------------
379 if(iostat.eq.0)then
380 call hgccm0
381 elseif(iostat.eq.1)then
382 call hgccbo(ibna)
383 endif
384
385 else
386
387c Boltzmann approxiamtion (massive particles)
388c -------------------------------------------
389 call hgccbo(ibna)
390
391 endif
392
393 dch=abs(chemo-chem(iafs))
394 if(ish.ge.9)write(ifch,*)'dch:',dch
395 if(dch.le.abs(gen*chemo).or.dch.le.genm)idch=idch+1
396 if(ibna.eq.1)then
397 chem(iafs)=chemo
398 call hgchac(0)
399 goto20
400 endif
401
402 enddo
403
404
405c new hadron chem. potentials
406c ---------------------------
407 call hgchac(0)
408
409
410 if(ish.ge.5.and.nflavs.eq.1)
411 *write(ifch,'(1x,f8.6,2x,f9.6)')
412 *tem,chem(1)
413 if(ish.ge.5.and.nflavs.eq.2)
414 *write(ifch,'(1x,f8.6,2x,f9.6,2x,f9.6)')
415 *tem,chem(1),chem(2)
416 if(ish.ge.5.and.nflavs.eq.3)
417 *write(ifch,'(1x,f8.6,2x,f9.6,2x,f9.6,2x,f9.6)')
418 *tem,chem(1),chem(2),chem(3)
419 if(idch.eq.nflavs.and.idt.eq.1)goto20
420
421
422 k=k+1
423
424 if(k.gt.300)then
425 if(ish.ge.5)
426 *write(ifch,*)'failure in approximate solution'
427 goto20
428 endif
429
430 goto10
431
43220 continue
433 if(ish.ge.9)call hgccch(0)
434 if(ish.ge.5)write(ifch,'(1x,a,1x,f9.6)')' T :',tem
435 do i=1,nflavs
436 if(i.eq.1.and.ish.ge.5)
437 *write(ifch,'(1x,a,1x,f9.6)')'chemu:',chem(1)
438 if(i.eq.2.and.ish.ge.5)
439 *write(ifch,'(1x,a,1x,f9.6)')'chemd:',chem(2)
440 if(i.eq.3.and.ish.ge.5)
441 *write(ifch,'(1x,a,1x,f9.6)')'chems:',chem(3)
442 enddo
60ed90b3 443
9ef1c2d9 444
445c checking results
446c ----------------
447 if(ish.ge.5)call hgcchb
448
449c particle yield
450c --------------
451 call hgcpyi(1)
452
453c checking flavor conservation
454c ----------------------------
455 if(ish.ge.5)call hgccfc
456
457 if(iug.eq.iospec.and.iostat.eq.0)then
458 if(ish.ge.5)write(ifch,*)
459 *'approximation and exact treatment equal'
460 if(ish.ge.5)write(ifch,*)('-',i=1,30)
461 *,' exit sr hgcaaa ',('-',i=1,10)
462 ish=isho
463 return
464 endif
465
466c continue or return approximate values
467c -------------------------------------
468 do i=1,nspecs
469 rmsbol(i)=rmsngc(i)
470 ptlbol(i)=ptlngc(i)
471 chebol(i)=chemgc(i)
472 enddo
473 tembol=tem
474 if(iostat.eq.1)then
475 if(ish.ge.5)write(ifch,*)('-',i=1,30)
476 *,' exit sr hgcaaa ',('-',i=1,10)
477 ish=isho
478 return
479 endif
60ed90b3 480
9ef1c2d9 481
482c quantum statistics
483c ------------------
484 if(ish.ge.5)write(ifch,*)'quantum statistics:'
60ed90b3 485 if(ish.ge.5.and.nflavs.eq.1)write(ifch,'(3x,a,8x,a)')
9ef1c2d9 486 *'T:','chemu:'
60ed90b3 487 if(ish.ge.5.and.nflavs.eq.2)write(ifch,'(3x,a,8x,a,6x,a)')
9ef1c2d9 488 *'T:','chemu:','chemd:'
60ed90b3 489 if(ish.ge.5.and.nflavs.eq.3)write(ifch,'(3x,a,8x,a,6x,a,6x,a)')
9ef1c2d9 490 *'T:','chemu:','chemd:','chems:'
491 k=1
492
49330 continue
494 if(ish.ge.9.and.mod(k,10).eq.0)
495 *write(ifch,*)'hgc iteration:',k
496
497c new temperature
498c ---------------
499 idt=0
500 temo=tem
501 call hgctex
502 if(ish.ge.5.and.nflavs.eq.1)
503 *write(ifch,'(1x,f10.8,2x,f10.7)')
504 *tem,chem(1)
505 if(ish.ge.5.and.nflavs.eq.2)
506 *write(ifch,'(1x,f10.8,2x,f10.7,2x,f10.7)')
507 *tem,chem(1),chem(2)
508 if(ish.ge.5.and.nflavs.eq.3)
509 *write(ifch,'(1x,f10.8,2x,f10.7,2x,f10.7,2x,f10.7)')
510 *tem,chem(1),chem(2),chem(3)
511
512 if(tem.le.1.e-6.and.ish.ge.5)then
513 write(ifch,*)'inversion imposssible'
514 write(ifch,*)'T:',tem
515 call hnbmin(keu,ked,kes,kec)
516 if(ish.ge.5)write(ifch,*)('-',i=1,30)
517 *,' exit sr hgcaaa ',('-',i=1,10)
518 ish=isho
519 return
520 endif
521
522 dt=abs(temo-tem)
523 if(dt.le.gen*temo.or.dt.le.genm)idt=1
524 if(ish.ge.9)write(ifch,*)'dtem:',dt
525
526c new quark chem. potentials
527c --------------------------
528 idch=0
529 do iafs=1,nflavs
530 chemo=chem(iafs)
531 call hgccex
532 dch=abs(chemo-chem(iafs))
533 if(ish.ge.9)write(ifch,*)'dche:',dch
534 if(dch.le.abs(gen*chemo).or.dch.le.genm)idch=idch+1
535 enddo
536
537c new hadron chem. potentials
538c ---------------------------
539 call hgchac(0)
540
541 if(idch.eq.nflavs.and.idt.eq.1)then
54250 continue
543 if(ish.ge.5)write(ifch,*)'results:'
544 if(ish.ge.5)write(ifch,51)' T :',tem
545 if(nflavs.ge.1.and.ish.ge.5)write(ifch,51)'chemu:',chem(1)
546 if(nflavs.ge.2.and.ish.ge.5)write(ifch,51)'chemd:',chem(2)
547 if(nflavs.ge.3.and.ish.ge.5)write(ifch,51)'chems:',chem(3)
54851 format(1x,a,3x,f9.6)
549
550c checking results
551c ----------------
60ed90b3 552 if(ish.ge.5)call hgcchh(i)
9ef1c2d9 553
554c particle yield
555c --------------
556 call hgcpyi(0)
557
558c checking flavor conservation
559c ----------------------------
560 call hgccfc
561
562 if(ish.ge.5)write(ifch,*)('-',i=1,30)
563 *,' exit sr hgcaaa ',('-',i=1,10)
564 ish=isho
60ed90b3 565 return
9ef1c2d9 566 endif
567
568 if(k.gt.300)then
569 if(ish.ge.5)
570 *write(ifch,*)'failure in exact solution'
571 if(ish.ge.5)write(ifch,*)'results:'
572 if(ish.ge.5)write(ifch,51)' T :',tem
573 if(nflavs.ge.1.and.ish.ge.5)write(ifch,51)'chemu:',chem(1)
574 if(nflavs.ge.2.and.ish.ge.5)write(ifch,51)'chemd:',chem(2)
575 if(nflavs.ge.3.and.ish.ge.5)write(ifch,51)'chems:',chem(3)
576
577c particle yield
578c --------------
579 call hgcpyi(0)
580
581 if(ish.ge.5)write(ifch,*)('-',i=1,30)
582 *,' exit sr hgcaaa ',('-',i=1,10)
583 ish=isho
584 return
585
586 endif
587
588 k=k+1
589 goto30
590
591 end
592
593
594c---------------------------------------------------------------------
595 function hgcbi0(x)
596c---------------------------------------------------------------------
597 DOUBLE PRECISION p1,p2,p3,p4,p5,p6,p7,q1,q2,q3,q4,q5,q6,q7,q8,q9,y
598 SAVE p1,p2,p3,p4,p5,p6,p7,q1,q2,q3,q4,q5,q6,q7,q8,q9
599 DATA p1,p2,p3,p4,p5,p6,p7/1.0d0,3.5156229d0,3.0899424d0,
600 *1.2067492d0,0.2659732d0,0.360768d-1,0.45813d-2/
601 DATA q1,q2,q3,q4,q5,q6,q7,q8,q9/0.39894228d0,0.1328592d-1,
602 *0.225319d-2,-0.157565d-2,0.916281d-2,-0.2057706d-1,0.2635537d-1,
603 *-0.1647633d-1,0.392377d-2/
604 if (abs(x).lt.3.75) then
605 y=dble((x/3.75)**2)
606 hgcbi0=sngl(p1+y*(p2+y*(p3+y*(p4+y*(p5+y*(p6+y*p7))))))
607 else
608 ax=abs(x)
609 y=dble(3.75/ax)
610 hgcbi0=(exp(ax)/sqrt(ax))*(q1+y*(q2+y*(q3+y*(q4+y*(q5+y*(q6+y*
611 *(q7+y*(q8+y*q9))))))))
612 endif
613 return
614 end
615
616
617c------------------------------------------------------------------------
618 function hgcbi1(x)
619c------------------------------------------------------------------------
620 DOUBLE PRECISION p1,p2,p3,p4,p5,p6,p7,q1,q2,q3,q4,q5,q6,q7,q8,q9,y
621 SAVE p1,p2,p3,p4,p5,p6,p7,q1,q2,q3,q4,q5,q6,q7,q8,q9
622 DATA p1,p2,p3,p4,p5,p6,p7/0.5d0,0.87890594d0,0.51498869d0,
623 *0.15084934d0,0.2658733d-1,0.301532d-2,0.32411d-3/
624 DATA q1,q2,q3,q4,q5,q6,q7,q8,q9/0.39894228d0,-0.3988024d-1,
625 *-0.362018d-2,0.163801d-2,-0.1031555d-1,0.2282967d-1,-0.2895312d-1,
626 *0.1787654d-1,-0.420059d-2/
627 if (abs(x).lt.3.75) then
628 y=dble((x/3.75)**2)
629 hgcbi1=x*(p1+y*(p2+y*(p3+y*(p4+y*(p5+y*(p6+y*p7))))))
630 else
631 ax=abs(x)
632 y=dble(3.75/ax)
633 hgcbi1=(exp(ax)/sqrt(ax))*(q1+y*(q2+y*(q3+y*(q4+y*(q5+y*(q6+y*
634 *(q7+y*(q8+y*q9))))))))
635 if(x.lt.0.)hgcbi1=-hgcbi1
636 endif
637 return
638 END
639
640
641c---------------------------------------------------------------------
642 function hgcbk0(x)
643c------------------------------------------------------------------------
644 DOUBLE PRECISION p1,p2,p3,p4,p5,p6,p7,q1,q2,q3,q4,q5,q6,q7,y
645 SAVE p1,p2,p3,p4,p5,p6,p7,q1,q2,q3,q4,q5,q6,q7
646 DATA p1,p2,p3,p4,p5,p6,p7/-0.57721566d0,0.42278420d0,0.23069756d0,
647 *0.3488590d-1,0.262698d-2,0.10750d-3,0.74d-5/
648 DATA q1,q2,q3,q4,q5,q6,q7/1.25331414d0,-0.7832358d-1,0.2189568d-1,
649 *-0.1062446d-1,0.587872d-2,-0.251540d-2,0.53208d-3/
650 if (x.le.2.0) then
651 y=dble(x*x/4.0)
652 hgcbk0=(-log(x/2.0)*hgcbi0(x))+(p1+y*(p2+y*(p3+y*(p4+y*(p5+y*
653 *(p6+y*p7))))))
654 else
655 y=dble(2.0/x)
656 hgcbk0=(exp(-x)/sqrt(x))*(q1+y*(q2+y*(q3+y*(q4+y*(q5+y*(q6+y*
657 *q7))))))
658 endif
659 return
660 END
661
662
663c---------------------------------------------------------------
664 function hgcbk1(x)
665c--------------------------------------------------------------------
666 DOUBLE PRECISION p1,p2,p3,p4,p5,p6,p7,q1,q2,q3,q4,q5,q6,q7,y
667 SAVE p1,p2,p3,p4,p5,p6,p7,q1,q2,q3,q4,q5,q6,q7
668 DATA p1,p2,p3,p4,p5,p6,p7/1.0d0,0.15443144d0,-0.67278579d0,
669 *-0.18156897d0,-0.1919402d-1,-0.110404d-2,-0.4686d-4/
670 DATA q1,q2,q3,q4,q5,q6,q7/1.25331414d0,0.23498619d0,-0.3655620d-1,
671 *0.1504268d-1,-0.780353d-2,0.325614d-2,-0.68245d-3/
672 if (x.le.2.0) then
673 y=dble(x*x/4.0)
674 hgcbk1=(log(x/2.0)*hgcbi1(x))+(1.0/x)*(p1+y*(p2+y*(p3+y*(p4+y*
675 *(p5+y*(p6+y*p7))))))
676 else
677 y=dble(2.0/x)
678 hgcbk1=(exp(-x)/sqrt(x))*(q1+y*(q2+y*(q3+y*(q4+y*(q5+y*(q6+y*
679 *q7))))))
680 endif
681 return
682 END
683
684
685c-------------------------------------------------------------------
686 function hgcbk(n,x)
60ed90b3 687c------------------------------------------------------------------
9ef1c2d9 688 tox=2.0/x
689 bkm=hgcbk0(x)
690 bk=hgcbk1(x)
691 do 11 j=1,n-1
692 bkp=bkm+j*tox*bk
693 bkm=bk
694 bk=bkp
69511 continue
696 hgcbk=bk
697 return
698 END
699
700
60ed90b3 701c----------------------------------------------------------------
9ef1c2d9 702 subroutine hgccbo(iba)
703c----------------------------------------------------------------
704c returns new chem(iafs) for boltzmann statistics
705c input:
706c tem
707c kef/volu
708c output:
709c chem(iafs)
710c-----------------------------------------------------------------------
711 common/cnsta/pi,pii,hquer,prom,piom,ainfin
712 common/drop6/tecm,volu
60ed90b3 713 parameter (mspecs=56)
9ef1c2d9 714 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
715 common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
716 parameter(nflav=6)
717 common/cflavs/nflavs,kef(nflav),chem(nflav)
718 common/cflac/ifok(nflav,mspecs),ifoa(nflav)
719 common/ciakt/gen,iafs,ians,genm
720 external hgcbk
721 k=1
722 iba=0
723 c1=-0.5
724 c2=0.5
725 goto11
726
727c new chemical potential
728c ----------------------
72910 chem(iafs)=c1+0.5*(c2-c1)
73011 continue
731 fd=0.0
732 call hgchac(0)
60ed90b3 733
9ef1c2d9 734 do i=1,nspecs
735
736 if(ifok(iafs,i).ne.0)then
737 if((chemgc(i)/tem).gt.70.)then
738 hpd=1.e30
739 else
740 hpd=exp(chemgc(i)/tem)
741 endif
742 if(aspecs(i).ne.0.)then
743 fk2=hgcbk(2,aspecs(i)/tem)
744 hpd=hpd*gspecs(i)*aspecs(i)**2*tem*fk2
745 */2./pi**2/hquer**3
746 else
747 hpd=hpd*gspecs(i)*tem**3/pi**2/hquer**3
748 endif
749 hfd=ifok(iafs,i)*hpd
750 fd=fd+hfd
751 endif
752
753 enddo
754
755 dfd=abs(fd-(kef(iafs)/volu))
756 if(dfd.le.abs(gen*(kef(iafs)/volu)).or.dfd.le.genm)return
757c if(abs(fd).ge.100.)then
758c iba=1
759c return
760c endif
761
762
763 if(fd.gt.(kef(iafs)/volu))then
764 c2=chem(iafs)
765 else
766 c1=chem(iafs)
767 endif
768
769 k=k+1
770 if(k.gt.300)return
771
772 goto10
60ed90b3 773
9ef1c2d9 774 end
775
776
777c----------------------------------------------------------------------
778 subroutine hgccch(iii)
779c----------------------------------------------------------------------
780c checks convergence of iterative algorithm
781c plots iteration values for T and mu_i
782c----------------------------------------------------------------------
783 include 'epos.inc'
60ed90b3 784 parameter (mspecs=56)
9ef1c2d9 785 common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
786 common/cflavs/nflavs,kef(nflav),chem(nflav)
787 parameter (nbin=500)
788 common/cdatc/data(nbin),datb(nbin),datc(nbin),datd(nbin)
789 *,date(nbin),datf(nbin),datg(nbin),dath(nbin),dati(nbin)
790 common/cnrit/nrit
791 character cen*4,cvol*4,cu*3,cd*3,cs*3
792
793 if(iii.gt.0)then
794
795 nrit=nrit+1
796 data(nrit)=nrit
797 datb(nrit)=tem
798 datc(nrit)=chem(1)
799 datd(nrit)=chem(2)
800 date(nrit)=chem(3)
801
802 elseif(iii.eq.0)then
803
804 nrit=nrit+1
805 data(nrit)=nrit
806 datb(nrit)=tem
807 datc(nrit)=chem(1)
808 datd(nrit)=chem(2)
809 date(nrit)=chem(3)
810 do i=1,nrit
811 datf(i)=datb(nrit)
812 datg(i)=datc(nrit)
813 dath(i)=datd(nrit)
814 dati(i)=date(nrit)
815 enddo
816
817 x1=data(1)
818 x2=data(nrit)
819 write(cen,'(f4.1)')tecm
820 write(cvol,'(f4.1)')volu
821 write(cu,'(i3)')keu
822 write(cd,'(i3)')ked
823 write(cs,'(i3)')kes
60ed90b3 824
9ef1c2d9 825
826 write(ifhi,'(a)') 'newpage zone 1 4 1 openhisto'
827 write(ifhi,'(a)') 'htyp lin xmod lin ymod lin'
828 write(ifhi,'(a)') 'text 0 0 "xaxis Iteration"'
829 write(ifhi,'(a)') 'text 0 0 "yaxis T (GeV)"'
830 write(ifhi,'(a)') 'text 0.15 0.9 "E= '//cen//'"'
831 write(ifhi,'(a)') 'text 0.4 0.9 "V= '//cvol//'"'
832 write(ifhi,'(a,2e11.3)')'xrange',x1,x2
833 write(ifhi,'(3a)')'yrange',' auto',' auto'
834 write(ifhi,'(a)') 'array 2'
835 do j=1,nrit
836 write(ifhi,'(2e12.4)')data(j),datb(j)
837 enddo
838 write(ifhi,'(a)') ' endarray'
839 write(ifhi,'(a)') 'closehisto plot 0-'
840
841 write(ifhi,'(a)') 'openhisto'
842 write(ifhi,'(a)') 'htyp lin xmod lin ymod lin'
843 write(ifhi,'(a,2e11.3)')'xrange',x1,x2
844 write(ifhi,'(3a)')'yrange',' auto',' auto'
845 write(ifhi,'(a)') 'array 2'
846 do j=1,nrit
847 write(ifhi,'(2e12.4)')data(j),datf(j)
848 enddo
849 write(ifhi,'(a)') ' endarray'
850 write(ifhi,'(a)') 'closehisto plot 0'
60ed90b3 851
9ef1c2d9 852 write(ifhi,'(a)') 'openhisto'
853 write(ifhi,'(a)') 'htyp lin xmod lin ymod lin'
854 write(ifhi,'(a)') 'text 0 0 "xaxis Iteration"'
855 write(ifhi,'(a)') 'text 0 0 "yaxis [m]^1! (GeV)"'
856 write(ifhi,'(a)') 'text 0.15 0.9 "Q^1!= '//cu//'"'
857 write(ifhi,'(a,2e11.3)')'xrange',x1,x2
858 write(ifhi,'(3a)')'yrange',' auto',' auto'
859 write(ifhi,'(a)') 'array 2'
860 do j=1,nrit
861 write(ifhi,'(2e12.4)')data(j),datc(j)
862 enddo
863 write(ifhi,'(a)') ' endarray'
864 write(ifhi,'(a)') 'closehisto plot 0-'
865
866 write(ifhi,'(a)') 'openhisto'
867 write(ifhi,'(a)') 'htyp lin xmod lin ymod lin'
868 write(ifhi,'(a,2e11.3)')'xrange',x1,x2
869 write(ifhi,'(3a)')'yrange',' auto',' auto'
870 write(ifhi,'(a)') 'array 2'
871 do j=1,nrit
872 write(ifhi,'(2e12.4)')data(j),datg(j)
873 enddo
874 write(ifhi,'(a)') ' endarray'
875 write(ifhi,'(a)') 'closehisto plot 0'
876
877 write(ifhi,'(a)') 'openhisto'
878 write(ifhi,'(a)') 'htyp lin xmod lin ymod lin'
879 write(ifhi,'(a)') 'text 0 0 "xaxis Iteration"'
880 write(ifhi,'(a)') 'text 0 0 "yaxis [m]^2! (GeV)"'
881 write(ifhi,'(a)') 'text 0.15 0.9 "Q^2!= '//cd//'"'
882 write(ifhi,'(a,2e11.3)')'xrange',x1,x2
883 write(ifhi,'(3a)')'yrange',' auto',' auto'
884 write(ifhi,'(a)') 'array 2'
885 do j=1,nrit
886 write(ifhi,'(2e12.4)')data(j),datd(j)
887 enddo
888 write(ifhi,'(a)') ' endarray'
889 write(ifhi,'(a)') 'closehisto plot 0-'
890
891 write(ifhi,'(a)') 'openhisto'
892 write(ifhi,'(a)') 'htyp lin xmod lin ymod lin'
893 write(ifhi,'(a,2e11.3)')'xrange',x1,x2
894 write(ifhi,'(3a)')'yrange',' auto',' auto'
895 write(ifhi,'(a)') 'array 2'
896 do j=1,nrit
897 write(ifhi,'(2e12.4)')data(j),dath(j)
898 enddo
899 write(ifhi,'(a)') ' endarray'
900 write(ifhi,'(a)') 'closehisto plot 0'
901
902 write(ifhi,'(a)') 'openhisto'
903 write(ifhi,'(a)') 'htyp lin xmod lin ymod lin'
904 write(ifhi,'(a)') 'text 0 0 "xaxis Iteration"'
905 write(ifhi,'(a)') 'text 0 0 "yaxis [m]^3! (GeV)"'
906 write(ifhi,'(a)') 'text 0.15 0.9 "Q^3!= '//cs//'"'
907 write(ifhi,'(a,2e11.3)')'xrange',x1,x2
908 write(ifhi,'(3a)')'yrange',' auto',' auto'
909 write(ifhi,'(a)') 'array 2'
910 do j=1,nrit
911 write(ifhi,'(2e12.4)')data(j),date(j)
912 enddo
913 write(ifhi,'(a)') ' endarray'
914 write(ifhi,'(a)') 'closehisto plot 0-'
915
916 write(ifhi,'(a)') 'openhisto'
917 write(ifhi,'(a)') 'htyp lin xmod lin ymod lin'
918 write(ifhi,'(a,2e11.3)')'xrange',x1,x2
919 write(ifhi,'(3a)')'yrange',' auto',' auto'
920 write(ifhi,'(a)') 'array 2'
921 do j=1,nrit
922 write(ifhi,'(2e12.4)')data(j),dati(j)
923 enddo
924 write(ifhi,'(a)') ' endarray'
925 write(ifhi,'(a)') 'closehisto plot 0'
926
927 endif
60ed90b3 928
9ef1c2d9 929 return
60ed90b3 930
9ef1c2d9 931 end
932
933c-----------------------------------------------------------------------
934 subroutine hgccex
935c-----------------------------------------------------------------------
936c returns new chem(iafs) for massive quantum statistics
937c input:
938c tem
939c kef/volu
940c output:
941c chem(iafs)
942c-----------------------------------------------------------------------
943 include 'epos.inc'
60ed90b3 944 parameter (mspecs=56)
9ef1c2d9 945 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
946 common/cflavs/nflavs,kef(nflav),chem(nflav)
947 common/cflac/ifok(nflav,mspecs),ifoa(nflav)
948 common/ciakt/gen,iafs,ians,genm
949 external hgcfhn
950
951 k=1
952
953 c1=-0.5
954 c2=0.5
955 goto11
956
957c new chemical potential
958c ----------------------
95910 chem(iafs)=c1+0.5*(c2-c1)
96011 continue
961
962 fd=0.0
963 do ians=1,nspecs
964 if(ifok(iafs,ians).ne.0)then
965
966 call hgchac(0)
60ed90b3 967 call hgclim(a,b)
9ef1c2d9 968 if(b.eq.0.0)then
969 hpd=0.0
970 else
971 call uttraq(hgcfhn,a,b,hpd)
972 endif
973 hpd=hpd*gspecs(ians)/2./pi**2/hquer**3
974 fd=fd+hpd*ifok(iafs,ians)
975
976 endif
977 enddo
978
979 dfd=abs(fd-(kef(iafs)/volu))
980 if(dfd.le.abs(gen*(kef(iafs)/volu)).or.dfd.le.genm)return
981
982 if(fd.gt.(kef(iafs)/volu))then
983 c2=chem(iafs)
984 else
985 c1=chem(iafs)
986 endif
987
988 k=k+1
989 if(k.gt.300)then
990 if(ish.ge.5)
991 *write(ifch,*)'failure at cex at iafs:',iafs
992 return
993 endif
994
995 goto10
996
997 end
998
999
1000c------------------------------------------------------------------
1001 subroutine hgccfc
1002c------------------------------------------------------------------
1003c checks flavor conservation in particle yield
1004c------------------------------------------------------------------
1005 include 'epos.inc'
60ed90b3 1006 parameter (mspecs=56)
9ef1c2d9 1007 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
1008 common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
1009 common/cflavs/nflavs,kef(nflav),chem(nflav)
1010 common/cflac/ifok(nflav,mspecs),ifoa(nflav)
1011
1012 if(ish.ge.5)write(ifch,*)'checking flavor conservation'
1013 do i=1,nflavs
1014 ckef=0.0
1015 do ii=1,nspecs
1016 ckef=ckef+ifok(i,ii)*ptlngc(ii)
1017 enddo
1018 dkef=abs(ckef-kef(i))
1019 if(dkef.le.1.e-2)then
1020 if(i.eq.1.and.ish.ge.5)write(ifch,*)'u conserved'
1021 if(i.eq.2.and.ish.ge.5)write(ifch,*)'d conserved'
60ed90b3 1022 if(i.eq.3.and.ish.ge.5)write(ifch,*)'s conserved'
9ef1c2d9 1023 else
1024 if(i.eq.1.and.ish.ge.5)write(ifch,*)'u not conserved'
1025 if(i.eq.2.and.ish.ge.5)write(ifch,*)'d not conserved'
1026 if(i.eq.3.and.ish.ge.5)write(ifch,*)'s not conserved'
1027 if(ish.ge.5)write(ifch,*)'df:',dkef
1028 endif
1029 enddo
1030
60ed90b3 1031 return
9ef1c2d9 1032 end
1033
1034c----------------------------------------------------------------
1035 subroutine hgcchb
1036c----------------------------------------------------------------
1037c checks results by numerical integration
1038c----------------------------------------------------------------
1039 include 'epos.inc'
60ed90b3 1040 parameter (mspecs=56)
9ef1c2d9 1041 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
1042 common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
1043 common/cflavs/nflavs,kef(nflav),chem(nflav)
1044 common/cflac/ifok(nflav,mspecs),ifoa(nflav)
1045 common/ciakt/gen,iafs,ians,genm
1046 external hgcfbe
1047 external hgcfbn
1048 if(ish.ge.5)write(ifch,*)
1049 *'check by numer. calc. of expect. values:'
1050 iced=0
1051 ceden=0.0
1052 do ians=1,nspecs
1053 call hgclim(a,b)
1054 if(b.eq.0.0)then
1055 cedh=0.0
1056 else
1057 call uttraq(hgcfbe,a,b,cedh)
1058 endif
1059 if(ish.ge.9)write(ifch,*)'cedh:',cedh
1060 ced=cedh*gspecs(ians)/2./pi**2/hquer**3
1061 ceden=ceden+ced
1062 enddo
1063
1064 if(iabs(ispecs(nspecs)).lt.10)
1065 *ceden=ceden+(8.*pi**2*tem**4/15.+bag4rt**4)/hquer**3
1066
1067 if(ish.ge.5)write(ifch,*)'energy density :',ceden
1068 ded=abs((tecm/volu)-ceden)
1069 if((tecm/volu)*gen.ge.ded.or.ded.le.gen)iced=1
1070 icfd=0
1071
1072 do i=1,nflavs
1073 cfd=0.0
1074 do ians=1,nspecs
1075 call hgclim(a,b)
1076 if(b.eq.0.0)then
1077 hpd=0.0
1078 else
1079 call uttraq(hgcfbn,a,b,hpd)
1080 endif
1081 hfd=ifok(i,ians)*hpd*gspecs(ians)/2./pi**2/hquer**3
1082 if(ish.ge.9)write(ifch,*)'hfd:',hfd
1083 cfd=cfd+hfd
1084 enddo
1085 if(i.eq.1.and.ish.ge.5)write(ifch,5)'flavor density u :',cfd
1086 if(i.eq.2.and.ish.ge.5)write(ifch,5)'flavor density d :',cfd
1087 if(i.eq.3.and.ish.ge.5)write(ifch,5)'flavor density s :',cfd
10885 format(1x,a,1x,f12.6)
1089 dfd=abs(cfd-(kef(i)/volu))
1090 if(abs(gen*(kef(i)/volu)).ge.dfd.or.dfd.le.gen)
1091 *icfd=icfd+1
1092 enddo
1093
1094 if(iced.eq.1.and.icfd.eq.nflavs)then
1095 if(ish.ge.5)write(ifch,*)'results agree'
1096 else
1097 if(ish.ge.5)write(ifch,*)'results disagree'
1098 endif
1099
1100 return
1101 end
1102
1103c----------------------------------------------------------------
1104 subroutine hgcchh(icorr)
1105c----------------------------------------------------------------
1106c checks results by numerical integration
1107c----------------------------------------------------------------
1108 include 'epos.inc'
60ed90b3 1109 parameter (mspecs=56)
9ef1c2d9 1110 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
1111 common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
1112 common/cflavs/nflavs,kef(nflav),chem(nflav)
1113 common/cflac/ifok(nflav,mspecs),ifoa(nflav)
1114 common/ciakt/gen,iafs,ians,genm
1115 external hgcfhe
1116 external hgcfhn
1117 icorr=0
1118 if(ish.ge.5)write(ifch,*)
1119 *'check by numer. calc. of expect. values:'
1120
1121 iced=0
1122 ceden=0.0
1123 do ians=1,nspecs
1124 call hgclim(a,b)
1125 if(b.eq.0.0)then
1126 cedh=0.0
1127 else
1128 call uttraq(hgcfhe,a,b,cedh)
1129 endif
1130 if(ish.ge.9)write(ifch,*)'cedh:',cedh
1131 ced=cedh*gspecs(ians)/2./pi**2/hquer**3
1132 ceden=ceden+ced
1133 enddo
1134
1135 if(iabs(ispecs(nspecs)).lt.10)
1136 *ceden=ceden+(8.*pi**2*tem**4/15.+bag4rt**4)/hquer**3
1137
1138 if(ish.ge.5)write(ifch,*)'energy density :',ceden
1139 ded=abs((tecm/volu)-ceden)
1140 if((tecm/volu)*gen.ge.ded.or.ded.le.gen)iced=1
1141
1142 icfd=0
1143
1144 do i=1,nflavs
1145 cfd=0.0
1146 do ians=1,nspecs
1147 call hgclim(a,b)
1148 if(b.eq.0.0)then
1149 hpd=0.0
1150 else
1151 call uttraq(hgcfhn,a,b,hpd)
1152 endif
1153 hfd=ifok(i,ians)*hpd*gspecs(ians)/2./pi**2/hquer**3
1154 if(ish.ge.9)write(ifch,*)'hfd:',hfd
60ed90b3 1155 cfd=cfd+hfd
9ef1c2d9 1156 enddo
1157 if(i.eq.1.and.ish.ge.5)write(ifch,5)'flavor density u :',cfd
1158 if(i.eq.2.and.ish.ge.5)write(ifch,5)'flavor density d :',cfd
1159 if(i.eq.3.and.ish.ge.5)write(ifch,5)'flavor density s :',cfd
11605 format(1x,a,1x,f9.6)
1161 dfd=abs(cfd-(kef(i)/volu))
1162 if(abs(gen*(kef(i)/volu)).ge.dfd.or.dfd.le.gen)
1163 *icfd=icfd+1
1164 enddo
1165
1166 if(iced.eq.1.and.icfd.eq.nflavs)then
1167 if(ish.ge.5)write(ifch,*)'results agree'
1168 icorr=1
1169 else
1170 if(ish.ge.5)write(ifch,*)'results disagree'
1171 endif
1172
60ed90b3 1173 return
9ef1c2d9 1174 end
1175
1176
1177c--------------------------------------------------------------------
1178 subroutine hgccm0
1179c--------------------------------------------------------------------
1180c returns new quark chemical potentials for massless quantum statistics
1181c input:
1182c tem
1183c kef/volu
1184c output:
1185c chem
1186c---------------------------------------------------------------------
1187 include 'epos.inc'
60ed90b3 1188 parameter (mspecs=56)
9ef1c2d9 1189 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
1190 common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
1191 common/cflavs/nflavs,kef(nflav),chem(nflav)
1192 common/cflac/ifok(nflav,mspecs),ifoa(nflav)
1193 common/ciakt/gen,iafs,ians,genm
1194 external hgcfhn
1195 k=1
1196 z3=1.2020569
1197
1198 c1=-0.5
1199 c2=0.5
1200 goto11
1201
1202c new chemical potential
1203c ----------------------
120410 chem(iafs)=c1+0.5*(c2-c1)
120511 continue
1206
1207 fd=0.0
1208 call hgchac(0)
1209
1210 do i=1,nspecs
1211 if(ifok(iafs,i).ne.0)then
1212
1213 igsp=int(gspecs(i))
1214 if(mod(igsp,2).eq.0)then
1215
1216 if(ispecs(i).gt.0)then
1217 hpd=gspecs(i)*(chemgc(i)*tem**2+chemgc(i)**3/pi**2)/6./hquer**3
1218 else
1219 hpd=0.0
1220 endif
1221
1222c else
1223c if(ispecs(i).gt.0)then
1224c hpd=gspecs(i)*(chemgc(i)*tem**2/3.-chemgc(i)**3/pi**2/6.)/hquer**3
1225c else
1226c hpd=0.0
1227c endif
1228c endif
1229
1230c n=1
1231c0 xx=n*abs(chemgc(i))/tem
1232c if(xx.le.60.)then
1233c hpd=hpd+(-1.)**(n+1)/n**3/exp(xx)
1234c n=n+1
1235c goto20
1236c endif
1237c hpd=hpd*gspecs(i)*tem**3/pi**2/hquer**3
1238c if(chemgc(i).eq.abs(chemgc(i)))then
60ed90b3 1239c hpd=gspecs(i)*(chemgc(i)*tem**2+chemgc(i)**3/pi**2)/6./hquer**3
9ef1c2d9 1240c *-hpd
1241c endif
1242
1243c else
1244c hpd=3.*gspecs(i)*tem**3*z3/4./pi**2/hquer**3
1245c endif
60ed90b3 1246
9ef1c2d9 1247 else
1248
1249 hpd=gspecs(i)*tem**3*z3/pi**2/hquer**3
1250
1251 endif
1252
1253 hfd=hpd*ifok(iafs,i)
1254 fd=fd+hfd
1255
1256 endif
1257 enddo
1258
1259 dfd=abs(fd-(kef(iafs)/volu))
1260 if(dfd.le.abs(gen*(kef(iafs)/volu)).or.dfd.le.genm)return
1261
1262 if(fd.gt.(kef(iafs)/volu))then
1263 c2=chem(iafs)
1264 else
1265 c1=chem(iafs)
1266 endif
1267
1268 k=k+1
1269 if(k.gt.300)then
1270 if(ish.ge.5)
1271 *write(ifch,*)'failure at cm0 at iafs:',iafs
1272 return
1273 endif
1274 goto10
1275 end
1276
1277c-----------------------------------------------------------------------
1278 function hgcfbe(x)
1279c-----------------------------------------------------------------------
1280c integrand of energy density
1281c------------------------------------------------------------------------
60ed90b3 1282 parameter (mspecs=56)
9ef1c2d9 1283 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
1284 common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
1285 common/ciakt/gen,iafs,ians,genm
1286 eex=81.
1287 hgcfbe=0.0
1288 sq=sqrt(x**2+aspecs(ians)**2)
1289 if(tem.ne.0.0)eex=(sq-chemgc(ians))/tem
1290 if(eex.gt.60.)return
1291 if(eex.lt.-60)then
1292 hgcfbe=1.e25
1293 return
1294 endif
1295
1296 hgcfbe=sq*x**2*exp(-eex)
1297
1298 return
1299 end
1300
1301c-----------------------------------------------------------------
1302 function hgcfbf(x)
1303c-----------------------------------------------------------------
1304c integrand of mean square variance of energy
1305c----------------------------------------------------------------
60ed90b3 1306 parameter (mspecs=56)
9ef1c2d9 1307 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
1308 common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
1309 common/ciakt/gen,iafs,ians,genm
1310 eex=61
1311 hgcfbf=0.0
1312
1313 sq=sqrt(x**2+aspecs(ians)**2)
1314 if(tem.ne.0.0)eex=(sq-chemgc(ians))/tem
1315 if(eex.gt.60.)return
1316 if(eex.lt.-60)then
1317 hgcfbf=1.e25
1318 return
1319 endif
1320
1321 hgcfbf=(aspecs(ians)**2+x**2)*x**2*exp(-eex)
1322
1323 return
1324 end
1325
1326c-----------------------------------------------------------------
1327 function hgcfbn(x)
1328c-----------------------------------------------------------------
1329c integrand of hadron density
1330c-----------------------------------------------------------------
60ed90b3 1331 parameter (mspecs=56)
9ef1c2d9 1332 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
1333 common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
1334 common/ciakt/gen,iafs,ians,genm
1335 eex=81.
1336 hgcfbn=0.0
1337
1338 sq=sqrt(x**2+aspecs(ians)**2)
1339 if(tem.ne.0.0)eex=(sq-chemgc(ians))/tem
1340 if(eex.gt.80.)return
1341 if(eex.lt.-60)then
1342 hgcfbn=1.e25
1343 return
1344 endif
1345
1346 hgcfbn=x**2*exp(-eex)
1347
1348 return
1349 end
1350
1351c-----------------------------------------------------------------------
1352 function hgcfhe(x)
1353c-----------------------------------------------------------------------
1354c integrand of energy density
1355c------------------------------------------------------------------------
60ed90b3 1356 parameter (mspecs=56)
9ef1c2d9 1357 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
1358 common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
1359 common/ciakt/gen,iafs,ians,genm
1360 eex=81.
1361 hgcfhe=0.0
1362 igsp=int(gspecs(ians))
1363
1364 sq=sqrt(x**2+aspecs(ians)**2)
1365 if(tem.ne.0.0)eex=(sq-chemgc(ians))/tem
1366 if(eex.gt.80.)return
1367
1368 if(mod(igsp,2).ne.0)then
1369 d=-1.0
60ed90b3 1370 if(eex.lt.1.e-10)return
9ef1c2d9 1371 else
1372 d=1.0
60ed90b3 1373 endif
9ef1c2d9 1374
1375 hgcfhe=sq*x**2/(exp(eex)+d)
1376
60ed90b3 1377 return
9ef1c2d9 1378 end
1379
1380c-----------------------------------------------------------------
1381 function hgcfhf(x)
1382c-----------------------------------------------------------------
1383c integrand of mean square variance of energy
1384c----------------------------------------------------------------
60ed90b3 1385 parameter (mspecs=56)
9ef1c2d9 1386 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
1387 common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
1388 common/ciakt/gen,iafs,ians,genm
1389 eex=61
1390 hgcfhf=0.0
1391 igsp=int(gspecs(ians))
1392
1393 sq=sqrt(x**2+aspecs(ians)**2)
1394 if(tem.ne.0.0)eex=(sq-chemgc(ians))/tem
1395 if(eex.gt.60.)return
1396 if(eex.lt.(-60.))return
1397
1398 if(mod(igsp,2).ne.0)then
1399 d=-1.0
1400 if(eex.lt.1.0e-10.and.eex.gt.(-1.0e-10))return
1401 else
1402 d=1.0
1403 endif
1404
1405 hgcfhf=(aspecs(ians)**2+x**2)*x**2/(exp(eex)+2.0*d+exp(-eex))
1406
1407 return
1408 end
1409
1410c-----------------------------------------------------------------
1411 function hgcfhn(x)
1412c-----------------------------------------------------------------
1413c integrand of hadron density
1414c-----------------------------------------------------------------
60ed90b3 1415 parameter (mspecs=56)
9ef1c2d9 1416 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
1417 common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
1418 common/ciakt/gen,iafs,ians,genm
1419 eex=81.
1420 hgcfhn=0.0
1421 igsp=int(gspecs(ians))
1422
1423 sq=sqrt(x**2+aspecs(ians)**2)
1424 if(tem.ne.0.0)eex=(sq-chemgc(ians))/tem
1425 if(eex.gt.80.)return
1426
1427 if(mod(igsp,2).ne.0)then
1428 d=-1.0
60ed90b3 1429 if(eex.lt.1.e-10)return
9ef1c2d9 1430 else
1431 d=1.0
60ed90b3 1432 endif
9ef1c2d9 1433
1434 hgcfhn=x**2/(exp(eex)+d)
1435
1436 return
1437 end
1438
1439c-----------------------------------------------------------------
1440 function hgcfhw(x)
1441c-----------------------------------------------------------------
1442c integrand of mean square variance of hadron yield
1443c----------------------------------------------------------------
60ed90b3 1444 parameter (mspecs=56)
9ef1c2d9 1445 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
1446 common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
1447 common/ciakt/gen,iafs,ians,genm
1448 eex=61
1449 hgcfhw=0.0
1450 igsp=int(gspecs(ians))
1451
1452 sq=sqrt(x**2+aspecs(ians)**2)
1453 if(tem.ne.0.0)eex=(sq-chemgc(ians))/tem
60ed90b3 1454 if(eex.gt.60.)return
1455 if(eex.lt.(-60.))return
9ef1c2d9 1456
1457 if(mod(igsp,2).ne.0)then
1458 d=-1.0
60ed90b3 1459 if(eex.lt.1.0e-10.and.eex.gt.(-1.0e-10))return
9ef1c2d9 1460 else
1461 d=1.0
60ed90b3 1462 endif
9ef1c2d9 1463
1464 hgcfhw=x**2/(exp(eex)+2.0*d+exp(-eex))
1465
1466 return
1467 end
1468
1469
1470c-----------------------------------------------------------------
1471 subroutine hgchac(iboco)
1472c------------------------------------------------------------------
1473c returns hadronic chemical potentials as combinations of quark
1474c chemical potentials
1475c----------------------------------------------------------------------
1476 include 'epos.inc'
60ed90b3 1477 parameter (mspecs=56)
9ef1c2d9 1478 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
1479 common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
1480 common/cflavs/nflavs,kef(nflav),chem(nflav)
1481 common/cflac/ifok(nflav,mspecs),ifoa(nflav)
1482
1483 do i=1,nspecs
1484 chemgc(i)=0.0
1485 do ii=1,nflavs
1486 chemgc(i)=chemgc(i)+ifok(ii,i)*chem(ii)
1487 if(ish.ge.9)write(ifch,*)'mu_i:',chem(ii),' k_i:',ifok(ii,i)
1488 enddo
1489 if(ish.ge.9)write(ifch,*)'mu_nu:',chemgc(i)
1490 igsp=int(gspecs(i))
1491 if(mod(igsp,2).ne.0.and.chemgc(i).gt.aspecs(i).and.iboco.eq.0)
1492 *chemgc(i)=aspecs(i)
1493 enddo
1494
1495 return
1496 end
1497
1498
1499c-----------------------------------------------------------------------
1500 subroutine hgclim(a,b)
1501c----------------------------------------------------------------------
1502c returns integration limits for numerical evaluation of particle
1503c and energy densities using quantum statistics
1504c----------------------------------------------------------------------
1505 include 'epos.inc'
60ed90b3 1506 parameter (mspecs=56)
9ef1c2d9 1507 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
1508 common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
1509 common/ciakt/gen,iafs,ians,genm
1510
1511 igsp=int(gspecs(ians))
1512
1513 if(mod(igsp,2).ne.0)then
1514 a=0.001
1515 else
1516 a=0.0
1517 endif
1518
1519 b=0.0
1520 bb=(chemgc(ians)+tem*80.)**2-aspecs(ians)**2
1521 if(ish.ge.9)write(ifch,*)'bb:',bb
1522 if(bb.ge.0.0)b=sqrt(bb)
1523 if(bb.lt.0.0)then
1524 if(ish.ge.9)write(ifch,*)'failure at hgclim, bb=',bb
1525 if(ish.ge.9)write(ifch,'(1x,a,i5,a,2x,f12.6,1x,a,2x,f9.6)')
1526 *'mu(',ispecs(ians),'):',chemgc(ians),' T:',tem
1527 endif
1528 if(ish.ge.9)write(ifch,*)'ians:',ians,' a:',a,' b:',b
1529 return
1530 end
1531
1532c------------------------------------------------------------------------
1533 subroutine hgcnbi(iret)
1534c-----------------------------------------------------------------------
1535c uses hgcaaa results to generate initial hadron set, nlattc, iozero
1536c input:
1537c ptlngc(1:nspecs): particle number expectation values /cgchg/
1538c output:
1539c nump: number of hadrons /chnbin/
1540c ihadro(1:nump): hadron ids /chnbin/
1541c nlattc: lattice size /clatt/
1542c iozero: zero weight /metr1/
1543c-----------------------------------------------------------------------
1544 include 'epos.inc'
1545 parameter(maxp=500)
1546 common/chnbin/nump,ihadro(maxp)
60ed90b3 1547 parameter (mspecs=56)
9ef1c2d9 1548 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
1549 common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
1550 common/cgctot/rmstot,ptltot
1551 common/camgc/amgc,samgc,amtot
1552 common/cflavs/nflavs,kef(nflav),chem(nflav)
1553 common/cflac/ifok(nflav,mspecs),ifoa(nflav)
1554 common/clatt/nlattc,npmax
1555 common/cgcnb/nptlgc(mspecs)
1556 common/ctaue/taue
1557 common/cgck/k(nflav),kp(nflav),kps(nflav)
1558 *,idp(maxp),ida(mspecs),idb(mspecs)
1559 integer hgcndn
1560
1561 iret=0
1562 isho=ish
1563 if(ishsub/100.eq.50)ish=mod(ishsub,100)
1564
1565 if(ish.ge.7)write(ifch,*)('-',l=1,10)
1566 *,' entry sr hgcnbi ',('-',l=1,30)
1567
1568
1569 nh=nint(ptltot)
1570 iug=(1+iospec)/2*2-1
1571 if(iug.lt.9)call utstop('hgcnbi: iospec < 9&')
1572
1573c determine nlattc
1574c ----------------
1575 if(ionlat.eq.1)then
1576 s1=ptltot+2.*rmstot
1577 s2=1.3*ptltot
1578 s=max(s1,s2,6.)
1579 nlattc=nint(s)
1580 elseif(ionlat.eq.2)then
1581 s1=ptltot+3.*rmstot
1582 s2=1.5*ptltot
1583 s=max(s1,s2,6.)
1584 nlattc=nint(s)
1585 elseif(ionlat.eq.3)then
1586 s1=ptltot+4.*rmstot
1587 s2=2.*ptltot
1588 s=max(s1,s2,6.)
1589 nlattc=nint(s)
1590 elseif(ionlat.eq.0)then
1591 nlattc=8*(tecm/10)*(1/(tecm/volu))**0.2*(nspecs/3.)**0.3
1592 if(aspecs(1).lt.0.010)nlattc=nlattc*3
1593 nlattc=max(nlattc,20)
1594 endif
1595
1596 if(ish.ge.7)write(ifch,*)'nlattc:',nlattc
1597
1598c determine iozero
1599c ----------------
1600 if(iozero.eq.-1)then
1601 iozero=nspecs
1602 elseif(iozero.eq.-2)then
1603 iozero=nspecs*int(sqrt(volu/tecm))
1604 endif
1605
1606c modify iozero for testing
1607c -------------------------
1608 if(iozevt.gt.0)then
1609 iozero=(nrevt/iozevt+1)*iozinc !nrevt=event number - 1 !!
1610 write(ifch,*)'nrevt+1:',nrevt+1,' iozero:',iozero
1611 endif
1612
1613c initial hadron set
1614c ------------------
1615 ammin=2.*aspecs(1)
1616 if(tecm.lt.ammin)then
1617 write(ifch,*)'impossible to generate hadron configuration'
1618 call utstop('hgcnbi: tecm less than two pi0 masses&')
1619 endif
60ed90b3 1620
9ef1c2d9 1621 kk=1
1622100 continue
1623
1624 if(kk.gt.20)then
1625 iret=1
1626 if(ish.ge.7)then
1627 write(ifch,*)'failed to generate hadron set for'
1628 *,' event:',nrevt+1
1629 write(ifch,*)'u d s :',keu,ked,kes,' E:',tecm
1630 write(ifch,*)('-',i=1,30)
1631 *,' exit sr hgcnbi ',('-',i=1,10)
1632 endif
1633 ish=isho
1634 return
1635 endif
1636
1637 amtot=0.0
1638 do i=1,nspecs
1639 nptlgc(i)=0
1640 enddo
1641 do ii=1,nflavs
1642 k(ii)=kef(ii)
1643 enddo
1644
1645 if(ish.ge.7)write(ifch,*)
60ed90b3 1646 *'sample hadron multiplicities and total mass:'
9ef1c2d9 1647
1648 kbar=keu+ked+kes
1649 kpar=iabs(keu)+iabs(ked)+iabs(kes)
1650 nbar=kbar/3.
1651 if(ish.ge.7)write(ifch,*)'baryon number:',nbar,' parton number:'
1652 *,kpar
1653
1654 nn=2
1655 if(ioinco.ne.2)then
1656 nn=hgcndn(0)
1657 else
1658 nn=nh
1659 endif
1660 nb=iabs(nbar)
1661 if(ish.ge.7)write(ifch,*)'<n>:',nh,' n_sample:',nn,' n_bar:',nb
1662 if(nn.gt.nb.and.nb.ne.0.and.nb.ge.nh)nn=nb
1663 if(nn.lt.nb.and.nb.ne.0)nn=nb
1664 km=kpar-iabs(kbar)
1665 nt=km/2+nb
1666 if(nt.gt.nn)nn=nt
1667 nn=max(nn,2)
1668
1669 if(ioinco.eq.2)then
1670 nit=15*taue
1671 else
1672 itpn=100
1673 nit=nn*itpn
1674 endif
1675 nbb=0
1676 n=0
1677
1678c start with nb protons
1679 nptlgc(19)=nptlgc(19)+nb
1680 n=nb
1681 amtot=amtot+nb*aspecs(19)
1682 do ii=1,nflavs
1683 k(ii)=k(ii)-ifok(ii,19)*nb
1684 enddo
1685 nbb=nbb+nb
1686
1687
1688 do it=1,nit
1689
1690 xsp=nspecs
1691 x0=0.5
1692 xib=x0+xsp*rangen()
1693 ib=nint(xib)
1694 if(ib.gt.nspecs)ib=nspecs
1695 if(ib.lt.1)ib=1
1696 kb=ifok(1,ib)+ifok(2,ib)+ifok(3,ib)
1697 if(rangen().lt.0.5.and.nptlgc(ib).ge.1)then
1698 ni=-1
1699 else
1700 ni=1
1701 endif
1702 as=1.0
1703 if(nptlgc(ib).eq.0)as=0.5
1704 if(nptlgc(ib).eq.1.and.ni.eq.(-1))as=2.0
1705 if(ish.ge.9)write(ifch,*)
1706 *'id:',ispecs(ib),' <i>:',ptlngc(ib),' ni:',ni
1707
1708 if(ni.ne.0)then
1709
1710 if(ptlngc(ib).gt.5.0)then
1711
1712 pnla=hgcpnl(ib,0)
1713 pnlb=hgcpnl(ib,ni)
1714 pnlog=-pnla+pnlb
1715 if(ish.ge.9)write(ifch,*)'pnlog:',pnlog
1716 if(pnlog.lt.60)then
1717 pn=exp(pnlog)
60ed90b3 1718 else
9ef1c2d9 1719 pn=1.1
1720 endif
1721
1722 else
1723
1724 if(ni.eq.1)then
1725 pn=ptlngc(ib)/(nptlgc(ib)+1)
1726 elseif(ni.eq.(-1).and.ptlngc(ib).gt.1.e-20)then
1727 pn=nptlgc(ib)/ptlngc(ib)
1728 elseif(nptlgc(ib).gt.0)then
1729 pn=1.1
1730 else
1731 pn=0.0
1732 endif
1733
1734 endif
1735
1736 pm=1.0
1737 if(ioinfl.ge.0)then
1738 pmla=hgcpml(ib,0,ib,0)
1739 pmlb=hgcpml(ib,ni,ib,0)
1740 pmlog=-pmla+pmlb
1741 if(ish.ge.9)write(ifch,*)'pmlog:',pmlog
1742 if(pmlog.lt.60)then
1743 pm=exp(pmlog)
1744 else
1745 pm=1.1
1746 endif
1747 endif
1748
1749 p=pn*pm*as
1750 r=rangen()
1751 if(r.le.p)then
1752 nptlgc(ib)=nptlgc(ib)+ni
1753 n=n+ni
1754 amtot=amtot+ni*aspecs(ib)
1755 do ii=1,nflavs
1756 k(ii)=k(ii)-ifok(ii,ib)*ni
1757 enddo
1758 if(kb.ne.0)nbb=nbb+ni
1759 if(ish.ge.7.and.ni.gt.0)write(ifch,*)'add:'
1760 if(ish.ge.7.and.ni.lt.0)write(ifch,*)'remove:'
1761 if(ish.ge.7)write(ifch,*)'id:',ispecs(ib),' <n_i>:',ptlngc(ib)
1762 *,' n_i:',nptlgc(ib)
1763 if(ish.ge.7)write(ifch,*)'<n>:',nn,' it:',it
1764 if(ish.ge.7)write(ifch,*)'<M>:',amgc,' M:',amtot
1765 if(ish.ge.7)write(ifch,*)'p:',p,' r:',r
1766 if(ish.ge.7)write(ifch,*)'flav defect: u:',k(1),' d:'
1767 *,k(2),' s:',k(3)
1768 if(n.ge.nn.and.ioinco.ne.2)goto102
1769 endif
1770
1771 endif
1772
1773 enddo
1774
1775
1776102 continue
60ed90b3 1777
9ef1c2d9 1778 ndd=0
1779c if(nbb.lt.nb)then
1780c nba=nb-nbb
1781c if(nbar.gt.0)then
60ed90b3 1782c if(ish.ge.7)write(ifch,*)'add protons: nba:',nba
9ef1c2d9 1783c nptlgc(19)=nptlgc(19)+nba
1784c n=n+nba
1785c amtot=amtot+aspecs(19)*nba
1786c elseif(nbar.lt.0)then
60ed90b3 1787c if(ish.ge.7)write(ifch,*)'add aprotons: nba:',nba
9ef1c2d9 1788c nptlgc(20)=nptlgc(20)+nba
1789c n=n+nba
1790c amtot=amtot+aspecs(20)*nba
1791c endif
1792c endif
1793 if(n.lt.nn.and.ioinco.ne.2)then
1794 ndd=nn-n
1795 nd=mod(ndd,4)
1796 xn=n
1797 xnn=nn
1798 xl=(xnn-xn)/4.
1799 l=aint(xl)
1800 if(ish.ge.7)write(ifch,*)'add pions/etas: ndd:',ndd
1801 *,' l:',l,' nd:',nd
1802 if(l.ge.1)then
1803 do j=1,l
1804 nptlgc(1)=nptlgc(1)+1
1805 nptlgc(2)=nptlgc(2)+1
1806 nptlgc(3)=nptlgc(3)+1
1807 nptlgc(8)=nptlgc(8)+1
1808 amtot=amtot+aspecs(1)+aspecs(2)+aspecs(3)+aspecs(8)
1809 enddo
1810 endif
1811 if(nd.eq.1)then
1812 nptlgc(1)=nptlgc(1)+1
1813 amtot=amtot+aspecs(1)
1814 elseif(nd.eq.2)then
1815 nptlgc(2)=nptlgc(2)+1
1816 nptlgc(3)=nptlgc(3)+1
1817 amtot=amtot+aspecs(2)+aspecs(3)
1818 elseif(nd.eq.3)then
1819 nptlgc(2)=nptlgc(2)+1
1820 nptlgc(3)=nptlgc(3)+1
1821 nptlgc(1)=nptlgc(1)+1
1822 amtot=amtot+aspecs(2)+aspecs(3)+aspecs(1)
1823 endif
1824 endif
1825
1826 if(n.eq.0.and.ioinco.eq.2)then
1827 nptlgc(2)=nptlgc(2)+1
1828 nptlgc(3)=nptlgc(3)+1
1829 amtot=amtot+aspecs(2)+aspecs(3)
1830 elseif(n.eq.1.and.ioinco.eq.2)then
1831 nptlgc(1)=nptlgc(1)+1
1832 amtot=amtot+aspecs(1)
1833 endif
1834
1835 if(amtot.ge.tecm.and.ioinfl.ge.0)then
1836 if(ish.ge.7)write(ifch,*)
1837 *'total mass exceeded , redo configuration'
1838 kk=kk+1
1839 goto100
1840 endif
60ed90b3 1841
9ef1c2d9 1842
1843 iii=0
1844 if(ish.ge.7)then
1845 write(ifch,*)'u d s :',keu,ked,kes,' E:',tecm
1846 write(ifch,*)
1847 *'hadron set without flavor conservation:'
1848 endif
1849 do i=1,nspecs
1850 n=nptlgc(i)
1851 if(n.ge.1)then
1852 do j=1,n
1853 iii=iii+1
1854 if(iii.gt.maxp)stop'iii>maxp in hgcnbi'
1855 idp(iii)=ispecs(i)
1856 enddo
1857 endif
1858 enddo
1859 if(ish.ge.7)then
1860 write(ifch,'(1x,10i6)')(idp(i),i=1,iii)
1861 write(ifch,*)'flav defect: u:',k(1),' d:'
1862 *,k(2),' s:',k(3)
1863 write(ifch,*)'M:',amtot,' <M>:',amgc
1864 endif
1865 if(ioinfl.le.0)goto1000
1866
1867 ll=1
1868 llmax=nn*25
1869 ior=1
1870
1871120 if(k(1).ne.0.or.k(2).ne.0.or.k(3).ne.0)then
1872
1873 if(kk.gt.6)ior=0
1874
1875 if(ish.ge.7)write(ifch,*)
1876 *'remaining flavor defect before operation:',ll
1877 if(ish.ge.7)write(ifch,*)'flav defect: u:',k(1),' d:'
1878 *,k(2),' s:',k(3)
1879
1880 nida=0
1881 do i=1,nspecs
1882 if(nptlgc(i).gt.0)then
1883 nida=nida+1
1884 ida(nida)=i
1885 endif
1886 enddo
1887
1888 if(nida.eq.0)then
1889 if(ish.ge.7)write(ifch,*)'no proposals in a , redo'
1890 kk=kk+1
1891 goto100
1892 endif
1893
1894
1895 xna=0.5+nida*rangen()
1896 na=nint(xna)
1897 if(na.gt.nida)na=nida
1898 if(na.lt.1)na=1
1899 ia=ida(na)
1900 if(ish.ge.7)write(ifch,*)'nida:',nida,' ia:',ia
1901
1902 nidb=0
1903 do ii=1,nflavs
1904 kp(ii)=k(ii)+ifok(ii,ia)
1905 kps(ii)=isign(1,kp(ii))
1906 enddo
1907 if(ish.ge.7)write(ifch,*)
1908 *' assemble: u:',kp(1),' d:',kp(2),' s:',kp(3)
1909 do i=1,nspecs
1910 iacc=0
1911 naccsp=0
1912 naccmi=1
1913 do ii=1,nflavs
1914 naccsp=naccsp+iabs(ifok(ii,i))
1915 if(kp(ii).ne.0)then
1916 if(kps(ii)*ifok(ii,i).le.kps(ii)*kp(ii)
1917 *.and.kps(ii)*ifok(ii,i).gt.0)iacc=iacc+iabs(ifok(ii,i))
1918 endif
1919 enddo
1920 if(kp(1).eq.0.and.kp(2).eq.0.and.kp(3).eq.0)naccmi=0
1921 if(iacc.eq.naccsp.and.naccsp.ge.naccmi)then
1922 nidb=nidb+1
1923 idb(nidb)=i
1924 endif
1925 enddo
1926
1927 if(nidb.eq.0)then
1928 if(ish.ge.7)write(ifch,*)'no proposals in b , redo'
1929 kk=kk+1
1930 goto100
1931 endif
1932
1933 xnb=0.5+nidb*rangen()
1934 nb=nint(xnb)
1935 if(nb.gt.nidb)nb=nidb
1936 if(nb.lt.1)nb=1
1937 ib=idb(nb)
1938 if(ish.ge.7)write(ifch,*)'nidb:',nidb,' ib:',ib
1939 if(ish.ge.7)write(ifch,*)
1940 *'proposal:',ispecs(ia),' --> ',ispecs(ib)
1941
1942 asym=1.0
1943
1944c if(asym.gt.0.0)then
1945
1946 if(ptlngc(ia).gt.5.0)then
1947 pnali=hgcpnl(ia,0)
1948 pnalf=hgcpnl(ia,-1)
1949 pnalog=-pnali+pnalf
1950 if(ish.ge.7)write(ifch,*)'pnalog:',pnalog
1951 if(pnalog.lt.60)then
1952 pna=exp(pnalog)
1953 else
1954 pna=1.1
1955 endif
1956 else
1957 if(ptlngc(ia).gt.1.e-20)then
1958 pna=nptlgc(ia)/ptlngc(ia)
1959 elseif(nptlgc(ia).gt.0)then
1960 pna=1.1
1961 else
1962 pna=0.0
1963 endif
1964 endif
60ed90b3 1965
9ef1c2d9 1966 if(ptlngc(ib).gt.5.0)then
1967 pnbli=hgcpnl(ib,0)
1968 pnblf=hgcpnl(ib,1)
1969 pnblog=-pnbli+pnblf
1970 if(ish.ge.7)write(ifch,*)'pnblog:',pnblog
1971 if(pnblog.lt.60)then
1972 pnb=exp(pnblog)
1973 else
1974 pnb=1.1
1975 endif
60ed90b3 1976 else
9ef1c2d9 1977 pnb=ptlngc(ib)/(nptlgc(ib)+1)
1978 endif
1979
1980
1981 pmli=hgcpml(ia,0,ib,0)
1982 pmlf=hgcpml(ia,-1,ib,1)
1983 pmlog=-pmli+pmlf
1984 if(ish.ge.7)write(ifch,*)'pmlog:',pmlog
1985 if(pmlog.lt.60)then
1986 pm=exp(pmlog)
1987 else
1988 pm=1.1
1989 endif
1990
1991 p=pna*pnb*pm*asym
1992 if(ior.eq.0)then
1993 r=0.0
1994 else
1995 r=rangen()
1996 endif
60ed90b3 1997
9ef1c2d9 1998c else
1999
2000c r=1.0
2001c p=0.0
2002
2003c endif
2004
2005 if(r.lt.p)then
2006 if(ish.ge.7)write(ifch,*)'p:',p,' r:',r,' asymmetry:',asym
2007 if(ish.ge.7)write(ifch,*)'remove ',ispecs(ia),' add ',ispecs(ib)
2008 *,' proposal accepted'
2009 nptlgc(ia)=nptlgc(ia)-1
2010 nptlgc(ib)=nptlgc(ib)+1
2011 amtot=amtot-aspecs(ia)+aspecs(ib)
2012 do ii=1,nflavs
2013 k(ii)=k(ii)+ifok(ii,ia)-ifok(ii,ib)
2014 enddo
2015 endif
2016
60ed90b3 2017
9ef1c2d9 2018 if(k(1).ne.0.or.k(2).ne.0.or.k(3).ne.0)then
2019 ll=ll+1
2020 if(ll.le.llmax)then
2021 goto120
2022 else
2023 if(ish.ge.7)write(ifch,*)'failed to remove defect, redo'
2024 kk=kk+1
2025 goto100
2026 endif
2027 endif
2028
2029 endif
2030
20311000 continue
2032
2033 nump=0
2034 kcu=0
2035 kcd=0
2036 kcs=0
2037 do i=1,nspecs
2038 n=nptlgc(i)
2039 if(n.ge.1)then
2040 do j=1,n
2041 nump=nump+1
2042 ihadro(nump)=ispecs(i)
2043 kcu=kcu+ifok(1,i)
2044 kcd=kcd+ifok(2,i)
2045 kcs=kcs+ifok(3,i)
2046 enddo
2047 endif
2048 enddo
2049
2050 if(ioinfl.gt.0)then
2051 if(kcu.ne.keu.or.kcd.ne.ked.or.kcs.ne.kes)then
2052 if(ish.ge.7)write(ifch,*)
2053 *'failed to remove flavor defect, redo configuration'
2054 kk=kk+1
2055 goto100
2056 endif
2057 endif
2058
2059 if(ioinct.ge.1)then
2060 chitot=0.0
2061 nutot=nspecs
2062 do i=1,nspecs
2063 chi=0.0
2064 if(rmsngc(i).gt.1.e-10)chi=(ptlngc(i)-nptlgc(i))/rmsngc(i)
2065 chitot=chitot+chi**2
2066 enddo
2067 call xhgccc(chitot)
60ed90b3 2068
9ef1c2d9 2069 u=0
2070 d=0
2071 s=0
2072 do i=1,nspecs
2073 u=u+ifok(1,i)*nptlgc(i)
2074 d=d+ifok(2,i)*nptlgc(i)
2075 s=s+ifok(3,i)*nptlgc(i)
2076 enddo
2077 call xhgcfl(u,d,s,0)
2078 call xhgcam(amtot,0)
2079 endif
2080
2081 if(ish.ge.7)then
2082 write(ifch,*)
2083 *'initial hadron set for droplet decay:'
2084 write(ifch,'(1x,10i6)')(ihadro(i),i=1,nump)
2085 endif
2086 if(nump.ge.nlattc)then
2087 nlattc=nump+1
2088 if(ish.ge.7)then
2089 write(ifch,*)'initial set > nlattc !'
2090 write(ifch,*)'new nlattc:',nlattc
2091 endif
2092 endif
2093 if(ish.ge.7)then
2094 write(ifch,*)'keu:',kef(1),' kcu:',kcu,' ku:',k(1)
2095 write(ifch,*)'ked:',kef(2),' kcd:',kcd,' kd:',k(2)
2096 write(ifch,*)'kes:',kef(3),' kcs:',kcs,' ks:',k(3)
2097 write(ifch,*)' nh:',nh,' nump:',nump
2098 write(ifch,*)' nu:',nutot,' chi^2:',chitot
2099 write(ifch,*)'iozero:',iozero,' iomom:',iomom
2100 write(ifch,*)
2101 *'total mass:',amtot,' droplet mass:',tecm
2102 write(ifch,*)'trials needed:',kk
2103 *,' operations needed:',ll
2104 write(ifch,*)'iterations:',it,' pions added:',ndd
2105 write(ifch,*)('-',i=1,30)
2106 *,' exit sr hgcnbi ',('-',i=1,10)
2107 endif
2108 ish=isho
2109 return
2110
2111 end
2112
2113c--------------------------------------------------------------------
2114 integer function hgcndn(i)
2115c--------------------------------------------------------------------
2116c returns random multiplicity from gaussian distribution for species i
2117c---------------------------------------------------------------------
2118 include 'epos.inc'
60ed90b3 2119 parameter (mspecs=56)
9ef1c2d9 2120 common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
2121 common/cgctot/rmstot,ptltot
2122 common/clatt/nlattc,npmax
2123 a=iowidn
2124 kk=0
2125
2126 if(i.eq.0)then
2127
21281 continue
2129 kk=kk+1
2130 p=0.0
2131 nmin=2
2132 nh=nint(ptltot)
2133 nmax=nlattc
2134 xn=1.5+(nmax-nmin)*rangen()
2135 n=nint(xn)
2136 x=(n-ptltot)**2/2.0
2137 y=-70.
2138 if(rmstot.gt.1.e-15)y=-x/rmstot**2*a**2
2139 if(y.lt.70.)p=exp(y)
2140 if(rmstot.gt.1.e-15.and.iowidn.lt.0)p=p/sqrt(2.*pi)/rmstot
2141 if(p.ge.rangen())then
2142 hgcndn=n
2143 if(ish.ge.9)write(ifch,*)'hgcndn: k:',kk,' n:',hgcndn
2144 return
2145 else
2146 if(kk.le.25)goto1
2147 hgcndn=max(2,nh)
2148 if(ish.ge.9)write(ifch,*)'hgcndn: k:',kk,' n:',hgcndn
2149 return
2150 endif
2151
2152 else
60ed90b3 2153
9ef1c2d9 21542 continue
2155 kk=kk+1
2156 p=0.0
2157 nmin=0
2158 nh=nint(ptlngc(i))
2159 nmax=2*nh
2160 nmax=max(2,nmax)
2161 xn=-0.5+(nmax-nmin)*rangen()
2162 n=nint(xn)
2163 x=(n-ptlngc(i))**2/2.0
2164 if(x.lt.1.e-30)then
2165 p=1.
2166 else
2167 y=-70.
2168 if(rmsngc(i).gt.1.e-15)y=-x/rmsngc(i)**2
2169 if(y.lt.70.)p=exp(y)
2170 if(rmsngc(i).gt.1.e-15.and.iowidn.lt.0)
2171 *p=p/sqrt(2.*pi)/rmsngc(i)
2172 endif
2173 if(p.ge.rangen())then
2174 hgcndn=n
2175 if(ish.ge.9)write(ifch,*)'hgcndn: k:',kk,' n:',hgcndn
2176 return
2177 else
2178 if(kk.le.25)goto2
2179 hgcndn=nh
2180 if(ish.ge.9)write(ifch,*)'hgcndn: k:',kk,' n:',hgcndn
2181 return
2182 endif
2183
2184 endif
2185
2186 end
2187
2188c--------------------------------------------------------------------
2189 function hgcpml(i1,n1,i2,n2)
2190c--------------------------------------------------------------------
2191 include 'epos.inc'
60ed90b3 2192 parameter (mspecs=56)
9ef1c2d9 2193 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
2194 common/camgc/amgc,samgc,amtot
2195 common/cgcnb/nptlgc(mspecs)
2196 if(ish.ge.9)write(ifch,*)'i1:',i1,' i2:',i2
2197 if(ish.ge.9)write(ifch,*)'n1:',n1,' n2:',n2
2198 hgcpml=-1.e30
2199 ampr=n1*aspecs(i1)+n2*aspecs(i2)
2200 if((amtot+ampr).lt.tecm.and.(amtot+ampr).ge.0
2201 *.and.nptlgc(i1).ge.(-n1).and.nptlgc(i2).ge.(-n2))then
2202 hgcpml=0.0
2203 pl=(amtot-amgc+ampr)**2/2.0
2204 if(pl.lt.1.e-30)then
2205 hgcpml=0.0
2206 return
2207 endif
2208 if(samgc.gt.1.e-15)hgcpml=-pl/samgc**2
2209 endif
2210 if(ish.ge.9)write(ifch,*)'hgcpml:',hgcpml
2211 return
2212 end
2213
2214c--------------------------------------------------------------------
2215 function hgcpnl(i,n)
2216c--------------------------------------------------------------------
2217 include 'epos.inc'
60ed90b3 2218 parameter (mspecs=56)
9ef1c2d9 2219 common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
2220 common/cgcnb/nptlgc(mspecs)
2221 if(ish.ge.9)write(ifch,*)'i:',i,' n:',n
2222 hgcpnl=-1.e30
2223 if(nptlgc(i).ge.(-n))then
2224 pl=(nptlgc(i)-ptlngc(i)+n)**2/2.0
2225 if(pl.lt.1.e-30)then
2226 hgcpnl=0.0
2227 return
2228 endif
2229 if(rmsngc(i).gt.1.e-15)hgcpnl=-pl/rmsngc(i)**2
2230 endif
2231 if(ish.ge.9)write(ifch,*)'hgcpnl:',hgcpnl
2232 return
2233 end
2234
2235
2236c--------------------------------------------------------------------
2237 subroutine hgcpen
2238c--------------------------------------------------------------------
2239c returns array for twodimensional plot of energy- and flavor-
2240c density
2241c--------------------------------------------------------------------
2242c xpar1,xpar2 temperature range
2243c xpar3 # of bins for temperature
2244c xpar4,xpar5 chem.pot. range
2245c xpar6 # of bins for chem.pot.
2246c xpar7 max. density
2247c xpar8 strange chem.pot.
2248c--------------------------------------------------------------------
2249 include 'epos.inc'
60ed90b3 2250 parameter (mspecs=56)
9ef1c2d9 2251 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
2252 common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
2253 common/cflavs/nflavs,kef(nflav),chem(nflav)
2254 common/cflac/ifok(nflav,mspecs),ifoa(nflav)
2255 common/ciakt/gen,iafs,ians,genm
2256 parameter (nbin=100)
2257 real edensi(nbin,nbin),qdensi(nbin,nbin)
2258 external hgcfhe
2259 external hgcfhn
2260 external hgcfbe
2261 external hgcfbn
2262
2263 iug=(1+iospec)/2*2-1
2264
2265c initialization
2266c --------------
2267
2268 if(iug.eq.1)nflavs=1
2269 if(iug.eq.3)nflavs=2
2270 if(iug.eq.5)nflavs=2
2271 if(iug.eq.7)nflavs=3
2272 if(iug.eq.9)nflavs=3
2273 if(iug.eq.11)nflavs=3
2274 tem=0.0
2275 do i=1,nflavs
2276 chem(i)=0.0
2277 enddo
2278 call hgchac(0)
2279 do i=1,nspecs
2280 ptlngc(i)=0.0
2281 rmsngc(i)=0.0
2282 enddo
2283
2284 nbt=nint(xpar3)
2285 nbc=nint(xpar6)
2286 nbc=min(nbc,100)
2287 nbt=min(nbt,100)
2288 dt=(xpar2-xpar1)/nbt
2289 dc=(xpar5-xpar4)/nbc
2290 ymax=xpar7
2291 cs=xpar8
2292
2293
2294 t0=xpar1+dt/2.
2295 c0=xpar4+dc/2
2296 do i=1,nbc
2297 chem(1)=c0+(i-1)*dc
2298 chem(2)=chem(1)
2299 chem(3)=cs
2300 chem(4)=0.0
2301 chem(5)=0.0
2302 chem(6)=0.0
2303 call hgchac(0)
2304 do ii=1,nbt
2305 tem=t0+(ii-1)*dt
2306 if(ish.ge.5)write(ifch,*)' mu:',chem(1),' T:',tem
2307
2308 qd=0.0
2309 ed=0.0
2310
2311 do ians=1,nspecs
2312
2313 call hgclim(a,b)
2314
2315 if(b.eq.0.0)then
2316 hden=0.0
2317 elseif(iostat.eq.0)then
2318 call uttraq(hgcfhn,a,b,hden)
2319 elseif(iostat.eq.1)then
2320 call uttraq(hgcfbn,a,b,hden)
2321 endif
2322 hd=hden*gspecs(ians)/2./pi**2/hquer**3
60ed90b3 2323
9ef1c2d9 2324 if(ish.ge.7)write(ifch,*)'i:',ians,' n_u:',ifok(1,ians),' hd:',hd
2325
60ed90b3 2326 qd=qd+ifok(1,ians)*hd+ifok(2,ians)*hd
9ef1c2d9 2327 if(qd.gt.ymax)qd=ymax
2328c if(qd.gt.ymax)qd=0.0
2329 if(qd.lt.-ymax)qd=-ymax
2330c if(qd.lt.-ymax)qd=0.0
60ed90b3 2331
9ef1c2d9 2332
2333 if(b.eq.0.0)then
2334 edi=0.0
2335 elseif(iostat.eq.0)then
2336 call uttraq(hgcfhe,a,b,edi)
2337 elseif(iostat.eq.1)then
2338 call uttraq(hgcfbe,a,b,edi)
2339 endif
2340 edi=edi*gspecs(ians)/2./pi**2/hquer**3
2341
2342 if(ish.ge.7)write(ifch,*)'i:',ians,' mu:',chemgc(ians)
2343 * ,' edi:',edi
60ed90b3 2344
9ef1c2d9 2345 ed=ed+edi
2346 if(ed.gt.ymax)ed=ymax
2347c if(ed.gt.ymax)ed=0.0
2348 enddo
2349
2350 if(ish.ge.5)write(ifch,*)' ed:',ed,' qd:',qd
2351 edensi(i,ii)=ed
2352 qdensi(i,ii)=qd
60ed90b3 2353
9ef1c2d9 2354 enddo
2355 enddo
2356
2357 write(ifhi,'(a)') 'openhisto'
2358 write(ifhi,'(a,2e11.3)')'xrange',xpar1,xpar2
2359 write(ifhi,'(a,2e11.3)')'yrange',xpar4,xpar5
2360 write(ifhi,'(a)') 'set ityp2d 5'
2361 write(ifhi,'(a,i4)') 'array2d',nbt
2362 do j=1,nbc
2363 do jj=1,nbt
2364 write(ifhi,'(e11.3)') edensi(j,jj)
2365 enddo
2366 enddo
2367 write(ifhi,'(a)') ' endarray'
2368 write(ifhi,'(a)') 'closehisto plot2d'
2369
2370 write(ifhi,'(a)') 'openhisto'
2371 write(ifhi,'(a,2e11.3)')'xrange',xpar1,xpar2
2372 write(ifhi,'(a,2e11.3)')'yrange',xpar4,xpar5
2373 write(ifhi,'(a)') 'set ityp2d 5'
2374 write(ifhi,'(a,i4)') 'array2d',nbt
2375 do j=1,nbc
2376 do jj=1,nbt
2377 write(ifhi,'(e11.3)') qdensi(j,jj)
2378 enddo
2379 enddo
2380 write(ifhi,'(a)') ' endarray'
2381 write(ifhi,'(a)') 'closehisto plot2d'
2382
2383 return
2384 end
2385
2386c--------------------------------------------------------------------
2387 subroutine hgcpfl
2388c--------------------------------------------------------------------
2389c returns array for twodimensional plot of energy- and flavor-
2390c density fluctuations
2391c--------------------------------------------------------------------
2392c xpar1,xpar2 temperature range
2393c xpar3 # of bins for temperature
2394c xpar4,xpar5 chem.pot. range
2395c xpar6 # of bins for chem.pot.
2396c xpar7 max. density
2397c xpar8 strange chem.pot.
2398c--------------------------------------------------------------------
2399 include 'epos.inc'
60ed90b3 2400 parameter (mspecs=56)
9ef1c2d9 2401 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
2402 common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
2403 common/cflavs/nflavs,kef(nflav),chem(nflav)
2404 common/ciakt/gen,iafs,ians,genm
2405 parameter (nbin=100)
2406 real efl(nbin,nbin),qfl(nbin,nbin),v(nbin),wn(nbin),we(nbin)
2407 external hgcfhf
2408 external hgcfhe
2409 external hgcfhn
2410 external hgcfhw
2411 external hgcfbf
2412 external hgcfbe
2413 external hgcfbn
2414
2415 iug=(1+iospec)/2*2-1
2416
2417c initialization
2418c --------------
2419
2420 if(iug.eq.1)nflavs=1
2421 if(iug.eq.3)nflavs=2
2422 if(iug.eq.5)nflavs=2
2423 if(iug.eq.7)nflavs=3
2424 if(iug.eq.9)nflavs=3
2425 if(iug.eq.11)nflavs=3
2426 tem=0.0
2427 do i=1,nflavs
2428 chem(i)=0.0
2429 enddo
2430 call hgchac(0)
2431 do i=1,nspecs
2432 ptlngc(i)=0.0
2433 rmsngc(i)=0.0
2434 enddo
2435
2436 nbt=nint(xpar3)
2437 nbv=nint(xpar6)
2438 nbv=min(nbv,100)
2439 nbt=min(nbt,100)
2440 dt=(xpar2-xpar1)/nbt
2441 dv=(xpar5-xpar4)/nbv
2442 ymax=1.e20
2443 chem(1)=xpar7
2444 chem(2)=xpar7
2445 chem(3)=xpar8
2446 call hgchac(0)
2447
2448
2449 t0=xpar1+dt/2.
2450 v0=xpar4
2451 do i=1,nbv
2452 volu=v0+(i-1)*dv
2453 do ii=1,nbt
2454 tem=t0+(ii-1)*dt
2455 if(ish.ge.5)write(ifch,*)'volu:',volu,' tem:',tem
2456
2457 ev=0.0
2458 ee=0.0
2459 qv=0.0
2460 qe=0.0
2461
2462 do ians=1,nspecs
2463
2464 call hgclim(a,b)
2465
2466 if(b.eq.0.0)then
2467 hn=0.0
2468 hv=0.0
2469 elseif(iostat.eq.0)then
2470 call uttraq(hgcfhn,a,b,hn)
2471 call uttraq(hgcfhw,a,b,hv)
2472 elseif(iostat.eq.1)then
2473 call uttraq(hgcfbn,a,b,hn)
2474 hv=hn
2475 endif
2476 hn=hn*volu*gspecs(ians)/2./pi**2/hquer**3
2477 hv=hv*volu*gspecs(ians)/2./pi**2/hquer**3
2478 if(ish.ge.5)write(ifch,*)'hn:',hn,' hv:',hv
60ed90b3 2479
9ef1c2d9 2480 hn=max(hn,1.e-15)
2481 qv=qv+hv
2482 qe=qe+hn
2483
2484
2485 if(qv.gt.ymax)qv=ymax
2486 if(qe.gt.ymax)qe=ymax
60ed90b3 2487
9ef1c2d9 2488
2489 if(b.eq.0.0)then
2490 eei=0.0
2491 evi=0.0
2492 elseif(iostat.eq.0)then
2493 call uttraq(hgcfhe,a,b,eei)
2494 call uttraq(hgcfhf,a,b,evi)
2495 elseif(iostat.eq.1)then
2496 call uttraq(hgcfbe,a,b,eei)
2497 call uttraq(hgcfbf,a,b,evi)
2498 endif
2499 eei=eei*volu*gspecs(ians)/2./pi**2/hquer**3
2500 evi=evi*volu*gspecs(ians)/2./pi**2/hquer**3
2501 if(ish.ge.5)write(ifch,*)'eei:',eei,' evi:',evi
2502
60ed90b3 2503
9ef1c2d9 2504 eei=max(eei,1.e-15)
2505 ev=ev+evi
2506 ee=ee+eei
2507 if(ev.gt.ymax)ev=ymax
2508 if(ee.gt.ymax)ee=ymax
2509 enddo
2510 if(ish.ge.5)write(ifch,*)'qv:',qv,' ev:',ev
2511
2512 qfl(i,ii)=0.
2513 efl(i,ii)=0.
2514 if(ev.gt.0.0.and.ee.gt.1.e-15)efl(i,ii)=sqrt(ev)/ee
2515 if(qv.gt.0.0.and.ee.gt.1.e-15)qfl(i,ii)=sqrt(qv)/qe
2516 if(tem.eq.0.195)then
2517 we(i)=efl(i,ii)
2518 wn(i)=qfl(i,ii)
2519 v(i)=volu
2520 endif
60ed90b3 2521
9ef1c2d9 2522 enddo
2523 enddo
2524
2525 write(ifhi,'(a)') 'openhisto'
2526 write(ifhi,'(a,2e11.3)')'xrange',xpar1,xpar2
2527 write(ifhi,'(a,2e11.3)')'yrange',xpar4,xpar5
2528 write(ifhi,'(a)') 'set ityp2d 5'
2529 write(ifhi,'(a,i4)') 'array2d',nbt
2530 do j=1,nbv
2531 do jj=1,nbt
2532 write(ifhi,'(e11.3)') efl(j,jj)
2533 enddo
2534 enddo
2535 write(ifhi,'(a)') ' endarray'
2536 write(ifhi,'(a)') 'closehisto plot2d'
2537
2538 write(ifhi,'(a)') 'openhisto'
2539 write(ifhi,'(a,2e11.3)')'xrange',xpar1,xpar2
2540 write(ifhi,'(a,2e11.3)')'yrange',xpar4,xpar5
2541 write(ifhi,'(a)') 'set ityp2d 5'
2542 write(ifhi,'(a,i4)') 'array2d',nbt
2543 do j=1,nbv
2544 do jj=1,nbt
2545 write(ifhi,'(e11.3)') qfl(j,jj)
2546 enddo
2547 enddo
2548 write(ifhi,'(a)') ' endarray'
2549 write(ifhi,'(a)') 'closehisto plot2d'
2550
2551 write(ifhi,'(a)') 'newpage zone 1 2 1'
2552 write(ifhi,'(a)') 'openhisto'
2553 write(ifhi,'(a,2e11.3)')'xrange',xpar4,xpar5
2554 write(ifhi,'(a)') 'htyp lfu xmod lin ymod lin'
2555 write(ifhi,'(a,i4)') 'array 2'
2556 do j=1,nbv
2557 write(ifhi,'(2e13.5)')v(j),we(j)
2558 enddo
2559 write(ifhi,'(a)') ' endarray'
60ed90b3 2560 write(ifhi,'(a)') 'closehisto plot 0'
9ef1c2d9 2561
2562 write(ifhi,'(a)') 'openhisto'
2563 write(ifhi,'(a,2e11.3)')'xrange',xpar4,xpar5
2564 write(ifhi,'(a)') 'htyp lfu xmod lin ymod lin'
2565 write(ifhi,'(a,i4)') 'array 2'
2566 do j=1,nbv
2567 write(ifhi,'(2e13.5)')v(j),wn(j)
2568 enddo
2569 write(ifhi,'(a)') ' endarray'
2570 write(ifhi,'(a)') 'closehisto plot 0'
2571
2572
2573 return
2574 end
2575
2576
2577c------------------------------------------------------------------
2578 subroutine hgcpyi(ist)
2579c------------------------------------------------------------------
60ed90b3 2580c returns particle yield
9ef1c2d9 2581c input:
2582c tem : temperature
2583c chemgc: chemical potentials
2584c output:
2585c ptlngc: expectation value of particle number for each species
2586c rmsngc: standard deviation of ptlngc
2587c ptltot: total particle number
2588c rmstot: standard deviation of ptltot
2589c works for hadrons and partons
2590c ist=1 boltzmann statistics
2591c ist=0 quantum statistics
2592c--------------------------------------------------------------------
2593 include 'epos.inc'
60ed90b3 2594 parameter (mspecs=56)
9ef1c2d9 2595 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
2596 common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
2597 common/cgctot/rmstot,ptltot
2598 common/camgc/amgc,samgc,amtot
2599 common/ciakt/gen,iafs,ians,genm
2600 external hgcfhw
2601 external hgcfhn
2602
2603 if(iabs(ispecs(nspecs)).lt.10)then
2604
2605c parton yield
2606c ------------
2607 if(ish.ge.5)write(ifch,*)'parton yield:'
2608 gln=16.*1.20206*tem**3/pi**2*volu/hquer**3
2609 sdg=sqrt(gln) !!???
2610 if(ish.ge.5)write(ifch,'(1x,a,f10.4,2x,a,f9.4,a)')
2611 *'<N( 0)> :',gln,' sigma :',sdg,' (qm-statistics!)'
2612 ptltot=gln
2613 rmstot=0.0
2614 vartot=gln
2615
2616 else
2617
2618 if(ish.ge.5)write(ifch,*)'hadronic yield:'
2619 ptltot=0.0
2620 rmstot=0.0
2621 vartot=0.0
2622
2623 endif
2624
2625 amgc=0.0
2626 samgc=0.0
2627
2628 do ians=1,nspecs
2629
2630c hadronic yield
2631c --------------
2632 if(ist.eq.0)then
2633
2634 call hgclim(a,b)
2635 if(b.eq.0.0)then
2636 hden=0.0
2637 else
2638 call uttraq(hgcfhn,a,b,hden)
2639 endif
2640 ptlngc(ians)=hden*volu*gspecs(ians)/2./pi**2/hquer**3
2641
2642 else
2643
2644 if((chemgc(ians)/tem).gt.70.)then
2645 hpd=1.e30
2646 else
2647 hpd=exp(chemgc(ians)/tem)
2648 endif
2649 if(aspecs(ians).ne.0.)then
2650 fk2=hgcbk(2,aspecs(ians)/tem)
2651 hpd=hpd*gspecs(ians)*aspecs(ians)**2*tem*fk2
2652 */2./pi**2/hquer**3
2653 else
2654 hpd=hpd*gspecs(ians)*tem**3/pi**2/hquer**3
2655 endif
2656 ptlngc(ians)=hpd*volu
2657
2658 endif
2659
2660 ptltot=ptltot+ptlngc(ians)
2661 amgc=amgc+ptlngc(ians)*aspecs(ians)
2662 if(amgc.ge.tecm)amgc=tecm*0.9
2663
2664c standard deviation
2665c ------------------
2666 rmsngc(ians)=0.0
2667
2668 if(ist.eq.0)then
60ed90b3 2669
9ef1c2d9 2670 call uttraq(hgcfhw,a,b,var)
2671 var=var*gspecs(ians)*volu/2./pi**2/hquer**3
2672 vartot=vartot+var
2673 if(var.ge.0.0)rmsngc(ians)=sqrt(var)
2674 samgc=samgc+var*aspecs(ians)
60ed90b3 2675
9ef1c2d9 2676 else
2677
2678 if(ptlngc(ians).ge.0.0)rmsngc(ians)=sqrt(ptlngc(ians))
2679 vartot=vartot+ptlngc(ians)
2680 samgc=samgc+ptlngc(ians)*aspecs(ians)
2681
2682 endif
2683
2684
2685 if(ish.ge.7)write(ifch,'(2x,a,i5,a,2x,f8.4,5x,a,3x,f8.4)')
2686 *'m(',ispecs(ians),') :',aspecs(ians),'mu :',chemgc(ians)
2687 if(ish.ge.5)write(ifch,'(1x,a,i5,a,2x,f8.4,2x,a,2x,f10.4)')
2688 *'<N(',ispecs(ians),')> :',ptlngc(ians),'sigma :',rmsngc(ians)
2689
2690 enddo
60ed90b3 2691
9ef1c2d9 2692 if(vartot.ge.0.0)rmstot=sqrt(vartot)
2693 if(samgc.ge.0.0)samgc=sqrt(samgc)
2694 if(amgc.ge.tecm)samgc=sqrt(amgc)
2695 if(ish.ge.5)write(ifch,'(1x,a,2x,f8.4,2x,a,2x,f10.4)')
2696 *'<N( all)> :',ptltot,'sigma :',rmstot
2697 if(ish.ge.5)write(ifch,'(1x,a,2x,f8.4,2x,a,2x,f10.4)')
2698 *'<M_tot> :',amgc,'sigma :',samgc
2699
60ed90b3 2700 return
9ef1c2d9 2701 end
2702
2703c------------------------------------------------------------------------
2704 subroutine hgctbo(iba)
2705c------------------------------------------------------------------------
2706c returns new tem using boltzmann statistics in analytic form
2707c input:
2708c chemgc
2709c tecm/volu
2710c output:
2711c tem
2712c----------------------------------------------------------------------
2713 include 'epos.inc'
60ed90b3 2714 parameter (mspecs=56)
9ef1c2d9 2715 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
2716 common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
2717 common/ciakt/gen,iafs,ians,genm
2718 external hgcbk
2719 external hgcbk1
2720 iba=0
2721 k=1
2722 t1=0.0
2723 t2=1.0
60ed90b3 2724
9ef1c2d9 2725 goto15
2726
272710 tem=t1+.5*(t2-t1)
2728 if(tem.le.1.e-7)return
272915 eden=0.0
2730
2731 do i=1,nspecs
2732
2733 if(aspecs(i).ne.0)then
2734 if(tem.ne.0.)arr=aspecs(i)/tem
2735 cba=(aspecs(i)/tem+12.*tem/aspecs(i)-3.*chemgc(i)/aspecs(i))
2736 **hgcbk(2,arr)+(3.-chemgc(i)/tem)*hgcbk1(arr)
2737 else
2738 cba=4.*tem-chemgc(i)
2739 endif
2740
2741 if(cba.lt.0.0)then
2742 iba=1
2743 return
2744 endif
2745
2746 if(tem.ne.0.)x=chemgc(i)/tem
2747
2748 if(x.le.70.)then
2749 y=exp(x)
2750 else
2751 y=1.e30
2752 endif
2753
2754 if(aspecs(i).ne.0.)then
2755 edi=y*(3./arr*hgcbk(2,arr)+hgcbk1(arr))
2756 **gspecs(i)*aspecs(i)**3*tem/2./pi**2/hquer**3
2757 else
2758 edi=y*3.*gspecs(i)*tem**4/pi**2/hquer**3
2759 endif
2760
2761 eden=eden+edi
2762
2763 enddo
2764
2765 if(iabs(ispecs(nspecs)).lt.10)
2766 *eden=eden+(8.*pi**2*tem**4/15.+bag4rt**4)/hquer**3
2767
2768 de=abs(eden-(tecm/volu))
2769 if(de.le.gen*(tecm/volu).or.de.le.genm)return
2770c if(eden.ge.100.)return
2771
2772 if(eden.gt.(tecm/volu))then
2773 t2=tem
2774 else
2775 t1=tem
2776 endif
2777
2778 if(k.gt.300)return
60ed90b3 2779
9ef1c2d9 2780 k=k+1
2781 goto10
2782 end
2783
2784c----------------------------------------------------------------------
2785 subroutine hgctex
2786c----------------------------------------------------------------------
2787c returns new tem using massive quantum statistics in integral form
2788c input:
2789c chemgc
2790c tecm/volu
2791c output:
2792c tem
2793c----------------------------------------------------------------------
2794 include 'epos.inc'
60ed90b3 2795 parameter (mspecs=56)
9ef1c2d9 2796 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
2797 common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
2798 common/ciakt/gen,iafs,ians,genm
2799 external hgcfhe
2800 k=1
2801 t1=0.0
2802 t2=tem+0.1
2803 goto15
2804
2805c new temperature
2806c ---------------
280710 tem=t1+.5*(t2-t1)
280815 continue
2809 if(tem.le.1.e-6)return
2810 eden=0.0
60ed90b3 2811
9ef1c2d9 2812 do ians=1,nspecs
2813 call hgclim(a,b)
2814 if(b.eq.0.0)then
2815 edi=0.0
2816 else
2817 call uttraq(hgcfhe,a,b,edi)
2818 endif
2819 edi=edi*gspecs(ians)/2./pi**2/hquer**3
2820 eden=eden+edi
2821 enddo
2822
2823 if(iabs(ispecs(nspecs)).lt.10)
2824 *eden=eden+(8.*pi**2*tem**4/15.+bag4rt**4)/hquer**3
2825
2826 de=abs(eden-(tecm/volu))
2827 if(de.le.gen*(tecm/volu).or.de.le.genm)return
2828
2829 if(eden.gt.(tecm/volu))then
2830 t2=tem
2831 else
2832 t1=tem
2833 endif
2834
2835 if(k.gt.300)then
2836 if(ish.ge.5)
2837 *write(ifch,*)'failure in tex'
2838 return
2839 endif
60ed90b3 2840
9ef1c2d9 2841 k=k+1
2842 goto10
2843 end
2844
2845c-----------------------------------------------------------------
2846 subroutine hgctm0
2847c-----------------------------------------------------------------
2848c returns new tem using massless quantum statistics in analytic form
2849c input:
2850c chemgc
2851c tecm/volu
2852c output:
2853c tem
2854c----------------------------------------------------------------------
2855
2856 include 'epos.inc'
60ed90b3 2857 parameter (mspecs=56)
9ef1c2d9 2858 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
2859 common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
2860 common/ciakt/gen,iafs,ians,genm
2861
2862 k=1
60ed90b3 2863
9ef1c2d9 2864 t1=0.0
2865 t2=1.0
286610 tem=t1+.5*(t2-t1)
2867 if(tem.le.1.e-6)return
2868 eden=0.0
2869
2870 do i=1,nspecs
2871
2872 igsp=int(gspecs(i))
2873 if(mod(igsp,2).eq.0)then
2874 edhm0=7./240.*pi**2*tem**4+chemgc(i)**2*tem**2/8.
2875 *+chemgc(i)**4/pi**2/16.
2876 else
2877 edhm0=pi**2*tem**4/30.+chemgc(i)**2*tem**2/4.
2878 *-chemgc(i)**4/pi**2/16.
2879 endif
2880 edi=edhm0*gspecs(i)/hquer**3
2881
2882
2883 eden=eden+edi
2884 enddo
2885
2886 if(iabs(ispecs(nspecs)).lt.10)
2887 *eden=eden+(8.*pi**2*tem**4/15.+bag4rt**4)/hquer**3
2888
2889 de=abs(eden-(tecm/volu))
2890 if(de.le.gen*(tecm/volu).or.de.le.genm)return
2891
2892 if(eden.gt.(tecm/volu))then
2893 t2=tem
2894 else
2895 t1=tem
2896 endif
2897
2898 if(k.gt.300)then
2899 if(ish.ge.5)
2900 *write(ifch,*)'failure in tm0'
2901 return
2902 endif
60ed90b3 2903
9ef1c2d9 2904 k=k+1
2905 goto10
2906 end
2907
2908c----------------------------------------------------------------------
2909 subroutine hnbxxx(ip,iret)
2910c----------------------------------------------------------------------
2911c decays droplet very fast ... and hopefully not too badly
2912c----------------------------------------------------------------------
2913 include 'epos.inc'
2914 integer jc(nflav,2),jc1(nflav,2)
2915 integer ifl(nflav)
2916 double precision p(5),c(5)
2917 real u(3),pin(4),pout(4),poutx(4)
60ed90b3 2918 parameter (mspecs=56)
9ef1c2d9 2919 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
2920 !-------------------------------------------------------------
2921 ! 110, 120, -120, 130, -130, 230, -230, 220, 330
2922 !, 111, 121, -121, 131, -131, 231, -231, 221, 331
2923 !, 1120,-1120, 1220,-1220, 1130,-1130, 2130,-2130
2924 !, 1230,-1230, 2230,-2230, 1330,-1330, 2330,-2330
2925 !, 1111,-1111, 1121,-1121, 1221,-1221, 2221,-2221, 1131,-1131
60ed90b3 2926 !, 1231,-1231, 2231,-2231, 1331,-1331, 2331,-2331, 3331,-3331
9ef1c2d9 2927 !-------------------------------------------------------------
2928 integer ianti(mspecs)
2929 data ianti/ 1, 3, 2, 5, 4, 7, 6, 8, 9
2930 * ,10,12,11,14,13,16,15,17,18
2931 * ,20,19,22,21,24,23,26,25
2932 * ,28,27,30,29,32,31,34,33
2933 * ,36,35,38,37,40,39,42,41,44,43
2934 * ,46,45,48,47,50,49,52,51,54,53,0,0/
2935 common/xxxspecs/wtot,wspecs(mspecs),zspecs(mspecs)
2936 parameter(mxdrop=35,mxe=10)
2937 common/xxxspecsy/ndrop(-4:4,-4:4,-4:4)
2938 common/xxxspecsx/ee(mxe),wwspecs(mxdrop,mxe,mspecs)
2939 common/cspec2/jspecs(2,nflav,mspecs)
2940 common/cspec4/lkfoi(8,-3:3,-3:3,-3:3,-3:3) !-charm
2941ctp060829 parameter (mxidh=3331)
2942 real wbar(-1:1)
2943
2944 call utpri('hnbxxx',ish,ishini,4)
2945 iret=0
2946
2947 call idquac(ip,nqi,nsi,nai,jc)
2948 keu=jc(1,1)-jc(1,2)
2949 ked=jc(2,1)-jc(2,2)
2950 kes=jc(3,1)-jc(3,2)
2951 n=ndrop(keu,ked,kes)
2952 if(n.eq.0)stop'hnbxxx: n=0'
60ed90b3 2953
9ef1c2d9 2954c...fill wspecs
2955
2956 e=pptl(5,ip)
2957 k=1
2958 do while(k.lt.mxe.and.ee(k).lt.e)
2959 k=k+1
2960 enddo
2961 k=max(k,2)
2962 xi=(e-ee(k-1))/(ee(k)-ee(k-1))
2963 do i=1,nspecs
2964 ii=i
2965 if(n.lt.0)ii=ianti(i)
2966 w1=wwspecs(abs(n),k-1,ii)
2967 w2=wwspecs(abs(n),k,ii)
60ed90b3 2968 wspecs(i)=w1+xi*(w2-w1)
9ef1c2d9 2969 enddo
60ed90b3 2970
9ef1c2d9 2971 if(ish.ge.5)then
2972 write(ifch,*)'keu,ked,kes,n:',keu,ked,kes,n
2973 write(ifch,'(9x, 9f6.3)')(wspecs(i),i=1,9)
2974 write(ifch,'(9x, 9f6.3)')(wspecs(i),i=10,18)
2975 write(ifch,'(9x, 8f6.3)')(wspecs(i),i=19,26)
2976 write(ifch,'(9x, 8f6.3)')(wspecs(i),i=27,34)
2977 write(ifch,'(9x,10f6.3)')(wspecs(i),i=35,44)
2978 write(ifch,'(9x,10f6.3)')(wspecs(i),i=45,54)
2979 endif
2980
2981c...initializations
2982
2983 do j=1,5
2984 c(j)=pptl(j,ip)
2985 enddo
2986 do j=1,4
2987 pin(j)=pptl(j,ip)
2988 pout(j)=0
2989 poutx(j)=0
2990 enddo
2991 wtot=0
2992 do i=1,nspecs
2993 wtot=wtot+wspecs(i)
2994 zspecs(i)=0
2995 enddo
2996 wbar(1)=0
2997 wbar(-1)=0
2998 do i=19,53,2
2999 wbar(1)=wbar(1)+wspecs(i)
3000 wbar(-1)=wbar(-1)+wspecs(i+1)
3001 enddo
3002 wbar(1)=wbar(1) /wtot
3003 wbar(-1)=wbar(-1)/wtot
3004 w12=0
3005 do i=19,34
3006 w12=w12+wspecs(i)
3007 enddo
3008 w32=0 !35,36,41,42,53,54 excluded
60ed90b3 3009 do i=37,40
9ef1c2d9 3010 w32=w32+wspecs(i)
3011 enddo
60ed90b3 3012 do i=43,52
9ef1c2d9 3013 w32=w32+wspecs(i)
3014 enddo
3015 sum=w12+w32
3016 w12=w12/sum
3017 w32=w32/sum
3018 w0=0
3019 do i=1,9
3020 w0=w0+wspecs(i)
3021 enddo
3022 w1=0
3023 do i=10,18
3024 w1=w1+wspecs(i)
3025 enddo
3026 sum=w0+w1
3027 w0=w0/sum
3028 w1=w1/sum
3029 nptlb=nptl
3030 call idquac(ip,nq,ns,na,jc)
3031 nbar=nq/3
3032 nbarini=nbar
3033 do nf=1,nflav
3034 ifl(nf)=jc(nf,1)-jc(nf,2)
3035 enddo
60ed90b3 3036
3037c...print
3038
9ef1c2d9 3039 if(ish.ge.5)then
3040 write(ifch,*)'ip=',ip,' id=',idptl(ip),' e=',sngl(c(5))
3041 write(ifch,*)'jc=',jc
3042 write(ifch,*)'nq=',nq,' na=',na,' nbar=',nbar
3043 write(ifch,*)'wtot=',wtot
3044 endif
3045
3046c...generate number of hadrons
60ed90b3 3047
9ef1c2d9 3048 wfac=1.05 !mean increased by factor wfac
3049 aa=wtot*wfac
3050 if(aa.le.70.)then
3051 776 nhad=0
3052 pr=1
3053 sum=1
3054 wfac=1.05 !mean increased by factor wfac
3055 rr=rangen()*exp(aa)
3056 do while (sum.lt.rr)
3057 nhad=nhad+1
3058 if(nhad.gt.10*aa)goto776
3059 pr=pr*aa/nhad
3060 sum=sum+pr
3061 !print*,'r:',rr,' n:',nhad,' sum pr:',sum
3062 enddo
3063 nhad=max(2,nhad)
3064 else
3065 778 nhad=aa-30
3066 sum=0
3067 rr=rangen()
3068 do while (sum.lt.rr)
3069 nhad=nhad+1
3070 if(nhad.gt.10*aa)goto778
3071 sum=sum+exp(nhad-aa)*(aa/nhad)**nhad/sqrt(2*pi*nhad)
3072 !print*,'r:',rr,' n:',nhad,' sum pr:',sum
3073 enddo
3074 nhad=max(2,nhad)
3075 endif
3076 if(ish.ge.5)write(ifch,*)'-----> ',nhad,' hadrons'
60ed90b3 3077
3078c...generate first n-2 hadrons
9ef1c2d9 3079
3080 do n=1,nhad-2
3081 1 sum=0
3082 i=0
3083 rr=rangen()*wtot
3084 do while (sum.lt.rr)
3085 i=i+1
3086 sum=sum+wspecs(i)
3087 enddo
3088 if(ispecs(i).gt.1000)then
3089 nbari=1
3090 elseif(ispecs(i).lt.-1000)then
3091 nbari=-1
3092 else
60ed90b3 3093 nbari=0
9ef1c2d9 3094 endif
3095 if(nbari*nbarini.gt.0
3096 * .and.nbari*(nbar-nbari).lt.0.and.rangen().gt.wbar(-nbari))then
3097 if(ish.ge.5)
3098 * write(ifch,*)'-----',nptl,nbar,ispecs(i),wbar(-nbari),rr
3099 goto1
3100 elseif(nbari*(nbar-nbari).lt.0)then
3101 if(ish.ge.5)write(ifch,*)'+++++',wbar(-nbari)
60ed90b3 3102 endif
3103 nbar=nbar-nbari
9ef1c2d9 3104 nptl=nptl+1
3105 id=ispecs(i)
60ed90b3 3106 idptl(nptl)=id
9ef1c2d9 3107 call idquac(nptl,nq,ns,na,jc1)
3108 do nf=1,nflav
3109 ifl(nf)=ifl(nf)-jc1(nf,1)+jc1(nf,2)
3110 enddo
3111 if(ish.ge.5)
60ed90b3 3112 * write(ifch,*)'nptl=',nptl,' id=',id,' ifl=',ifl
9ef1c2d9 3113 enddo
3114 do nf=1,nflav
3115 if(ifl(nf).ge.0)then
3116 jc(nf,1)=ifl(nf)
3117 jc(nf,2)=0
3118 else
3119 jc(nf,1)=0
3120 jc(nf,2)=-ifl(nf)
60ed90b3 3121 endif
9ef1c2d9 3122 enddo
3123 if(ish.ge.5)then
3124 write(ifch,*)'jc=',jc
3125 write(ifch,*)'hadrons:',(idptl(n),n=nptlb+1,nptl)
3126 * ,' --> nbar=',nbar
3127 endif
60ed90b3 3128
9ef1c2d9 3129c...last two hadrons
60ed90b3 3130
9ef1c2d9 3131 if(nbar.ne.0)then
3132 do n=1,abs(nbar)
60ed90b3 3133 ii=nbar/abs(nbar)
9ef1c2d9 3134 i1=idraflz(jc,(3-ii)/2)
3135 i2=idraflz(jc,(3-ii)/2)
3136 i3=idraflz(jc,(3-ii)/2)
3137 if(i1.eq.i2.and.i2.eq.i3)then
3138 id=ii*(i1*1000+i2*100+i3*10+1)
60ed90b3 3139 else
9ef1c2d9 3140 if(i2.lt.i1)then
60ed90b3 3141 ix=i1
9ef1c2d9 3142 i1=i2
3143 i2=ix
60ed90b3 3144 endif
9ef1c2d9 3145 if(i3.lt.i2)then
60ed90b3 3146 ix=i2
9ef1c2d9 3147 i2=i3
3148 i3=ix
60ed90b3 3149 endif
9ef1c2d9 3150 if(i2.lt.i1)then
60ed90b3 3151 ix=i1
9ef1c2d9 3152 i1=i2
3153 i2=ix
60ed90b3 3154 endif
9ef1c2d9 3155 ispin=0
3156 if(rangen().lt.w32)ispin=1
3157 id=ii*(i1*1000+i2*100+i3*10+ispin)
60ed90b3 3158 endif
9ef1c2d9 3159 nptl=nptl+1
60ed90b3 3160 idptl(nptl)=id
9ef1c2d9 3161 if(ish.ge.5)
60ed90b3 3162 * write(ifch,*)'nptl=',nptl,' baryon=',id,' jc=',jc
9ef1c2d9 3163 enddo
3164 endif
3165
3166 call idquacjc(jc,nqu,naq)
3167 do while (nqu.gt.0.or.nptl.eq.nptlb)
3168 if(nqu.eq.0)then
3169 i1=1.5+rangen()
3170 i2=1.5+rangen()
3171 jc(i1,1)=jc(i1,1)+1
3172 jc(i2,2)=jc(i2,2)+1
3173 else
3174 i1=idraflz(jc,1)
3175 i2=idraflz(jc,2)
3176 endif
3177 ii=1
3178 if(i2.lt.i1)then
60ed90b3 3179 ix=i1
9ef1c2d9 3180 i1=i2
3181 i2=ix
3182 ii=-1
3183 endif
3184 ispin=0
3185 if(rangen().lt.w1)ispin=1
3186 id=ii*(i1*100+i2*10+ispin)
3187 nptl=nptl+1
60ed90b3 3188 idptl(nptl)=id
9ef1c2d9 3189 if(ish.ge.5)write(ifch,*)'nptl=',nptl,' nqu=',nqu
60ed90b3 3190 & ,' naq=',naq,' --> meson',id
9ef1c2d9 3191 call idquacjc(jc,nqu,naq)
3192 enddo
3193
3194 nmiss=nhad-nptl+nptlb
3195 if(ish.ge.5)then
3196 write(ifch,*)nmiss,' hadron(s) missing'
3197 write(ifch,*)'hadrons:',(idptl(n),n=nptlb+1,nptl)
3198 endif
60ed90b3 3199
3200c nsechad=lkfoi(1,ifl(1),ifl(2),ifl(3),ifl(4))
3201c if(nsechad.gt.0)then
9ef1c2d9 3202c i2x=min(nsechad,1+rangen()*nsechad)
3203c i2=lkfoi(1+i2x,ifl(1),ifl(2),ifl(3),ifl(4))
3204c !print*,'secnd chosen hadron:',ispecs(i2),wzspecs(i2)
60ed90b3 3205
3206c... generate momenta
9ef1c2d9 3207
3208 if(ish.ge.5)write(ifch,*)'hadron momenta:'
3209 do n=nptlb+1,nptl
3210 id=idptl(n)
3211 call idmass(id,am)
3212 !prepare proposal function
3213 ! f_prop: f0(x)=0, x<am
60ed90b3 3214 ! f1(x)=const=f2(b), am<x<b,
9ef1c2d9 3215 ! f2(x)=x**2*exp(7-a*x), x>b
3216 a=11
3217 b=0.9
3218 b=max(b,am+0.1)
3219 !relative weights ... consider here f1/exp(7), f2/exp(7)
3220 c1=(b-am)*b**2*exp(-a*b)
3221 c2=(b**2/a+2*b/a**2+2/a**3)*exp(-a*b)
3222 if(ish.ge.5)write(ifch,*)'c1 c2:',c1,c2
3223 rrr=1
3224 fff=0
3225 do while(rrr.gt.fff)
3226 !proposal
3227 i=2
3228 if(rangen().lt.c1/(c1+c2))i=1
3229 if(ish.ge.5)write(ifch,*)'i=',i
3230 if(i.eq.1)then
3231 x=am+rangen()*(b-am)
3232 fx=b**2*exp(-a*b) *exp(7.)
3233 else
3234 r=alog(rangen())
3235 !find root of log((x**2/a+2*x/a**2+2/a**3)*exp(-a*x)/c2)-r
3236 x=20
3237 do k=1,4
3238 f=alog(x**2/a+2*x/a**2+2/a**3)-a*x-alog(c2)-r
3239 fp=(2*x/a+2/a**2)/(x**2/a+2*x/a**2+2/a**3)-a
3240 xb=x
3241 x=x-f/fp
3242 if(ish.ge.5)write(ifch,*)'k,xb,f,fp,x: ',k,xb,f,fp,x
3243 enddo
3244 fx=x**2*exp(-a*x) *exp(7.)
3245 endif
3246 !acceptance
3247 rrr=rangen()
3248 if(x.le.2)then
3249 fff=sqrt(x-am)*x*exp(-4*x-1.75*x**2) /fx
3250 else
3251 fff=sqrt(x-am)*x*exp(7-11*x) /fx
3252 endif
3253 if(ish.ge.5)write(ifch,*)'fff,rrr',fff,rrr
3254 enddo
3255 e=x
3256 pa=sqrt(e**2-am**2)
3257 u(3)=2.*rangen()-1.
3258 phi=2.*pi*rangen()
3259 u(1)=sqrt(1.-u(3)**2)*cos(phi)
3260 u(2)=sqrt(1.-u(3)**2)*sin(phi)
3261 do j=1,3
3262 pptl(j,n)=pa*u(j)
3263 pout(j)=pout(j)+pptl(j,n)
3264 enddo
3265 pptl(4,n)=e
3266 pptl(5,n)=am
3267 pout(4)=pout(4)+e
3268 if(ish.ge.5)
3269 * write(ifch,*)pptl(1,n),pptl(2,n),pptl(3,n),pptl(4,n),pptl(5,n)
3270 enddo
3271
3272c...check total energy ... rescale (maybe)
3273
3274 if(ish.ge.5)then
3275 write(ifch,*)'pout(cms)=',pout
3276 write(ifch,*)'energy_in(cms)= ',sngl(c(5))
3277 endif
3278
3279c...boost
3280
3281 do n=nptlb+1,nptl
3282 do j=1,4
3283 p(j)=pptl(j,n)
3284 enddo
3285 call utlob2(-1,c(1),c(2),c(3),c(4),c(5),p(1),p(2),p(3),p(4),10)
3286 do j=1,4
3287 pptl(j,n)=p(j)
3288 poutx(j)=poutx(j)+pptl(j,n)
3289 enddo
3290 enddo
3291 if(ish.ge.5)then
3292 write(ifch,*)'pout(lab)=',poutx
3293 write(ifch,*)'pin(lab)= ',pin
3294 endif
3295 call utprix('hnbxxx',ish,ishini,4)
3296 return
3297 end
60ed90b3 3298
9ef1c2d9 3299c----------------------------------------------------------------------
3300 subroutine hnbxxxini
3301c----------------------------------------------------------------------
3302 include 'epos.inc'
3303 logical lcalc
60ed90b3 3304 parameter (mspecs=56)
9ef1c2d9 3305 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
3306 !-------------------------------------------------------------
3307 ! 110, 120, -120, 130, -130, 230, -230, 220, 330
3308 !, 111, 121, -121, 131, -131, 231, -231, 221, 331
3309 !, 1120,-1120, 1220,-1220, 1130,-1130, 2130,-2130
3310 !, 1230,-1230, 2230,-2230, 1330,-1330, 2330,-2330
3311 !, 1111,-1111, 1121,-1121, 1221,-1221, 2221,-2221, 1131,-1131
60ed90b3 3312 !, 1231,-1231, 2231,-2231, 1331,-1331, 2331,-2331, 3331,-3331
9ef1c2d9 3313 !-------------------------------------------------------------
3314 common/xxxspecs/wtot,wspecs(mspecs),zspecs(mspecs)
60ed90b3 3315 integer ittspecs(mspecs)
9ef1c2d9 3316 parameter(mxdrop=35,mxe=10)
3317 common/xxxspecsy/ndrop(-4:4,-4:4,-4:4)
3318 common/xxxspecsx/ee(mxe),wwspecs(mxdrop,mxe,mspecs)
3319 inquire(file=fndr(1:nfndr),exist=lcalc)
3320 if(lcalc)then
3321 if(inicnt.eq.1)then
3322 do ku=-4,4
3323 do kd=-4,4
3324 do ks=-4,4
3325 ndrop(ku,kd,ks)=0
3326 enddo
3327 enddo
3328 enddo
3329 write(ifmt,'(3a)')'read from ',fndr(1:nfndr),' ...'
3330 open(1,file=fndr(1:nfndr),status='old')
3331 read(1,*)mxxdrop
60ed90b3 3332 if(mxxdrop.ne.mxdrop)stop'hnbxxxini: wrong nr of droplets'
9ef1c2d9 3333 do n=1,mxdrop
3334 read(1,*)ku,kd,ks
3335 if(abs(ku).gt.4)stop'hnbxxxini: ku out of range'
3336 if(abs(kd).gt.4)stop'hnbxxxini: kd out of range'
3337 if(abs(ks).gt.4)stop'hnbxxxini: ks out of range'
3338 ndrop(ku,kd,ks)=n
3339 ndrop(-ku,-kd,-ks)=-n
3340 enddo
3341 read(1,*)(ittspecs(i),i=1,nspecs)
3342 do i=1,nspecs
3343 if(ittspecs(i).ne.ispecs(i))stop'hnbxxxini: wrong id table'
3344 enddo
3345 read(1,*)ee
3346 do n=1,mxdrop
3347 read(1,*)((wwspecs(n,k,i),i=1,nspecs),k=1,mxe)
3348 enddo
3349 close(1)
3350 endif
3351 else
3352 stop'hnbxxxini: file not found. '
3353 endif
60ed90b3 3354 end
9ef1c2d9 3355
3356c----------------------------------------------------------------------
3357 subroutine hnbaaa(ip,iret)
3358c----------------------------------------------------------------------
60ed90b3 3359 include 'epos.inc'
3360 if(ioclude.eq.1)call hnbaaa156(ip,iret)
9ef1c2d9 3361 if(ioclude.eq.2)stop'ioclude.eq.2 no longer supported. '
3362 if(ioclude.eq.3)call hnbaaanew(ip,iret)
3363 end
60ed90b3 3364
9ef1c2d9 3365c----------------------------------------------------------------------
3366 subroutine hnbaaanew(ip,iret)
3367c----------------------------------------------------------------------
3368c microcanonical decay of cluster ip via loop over hnbmet
3369c----------------------------------------------------------------------
3370 include 'epos.inc'
3371 include 'epos.inchy'
3372 common/cxyzt/xptl(mxptl),yptl(mxptl),zptl(mxptl),tptl(mxptl)
3373 *,optl(mxptl),uptl(mxptl),sptl(mxptl),rptl(mxptl,3)
3374 parameter(maxp=500)
3375 common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
3376 common/citer/iter,itermx
3377 integer jc(nflav,2)
3378 double precision p(5),c(5)
3379 parameter(maxit=50000)
3380 common/count/nacc,nrej,naccit(maxit),nptot,npit(maxit)
3381 dimension uu(4),pe(5),pa(5)
3382 common/yrad/yrad(maxp),phifop(maxp),radfop(maxp),taufop(maxp)
3383 common/xxxspecsy/ndrop(-4:4,-4:4,-4:4)
3384 common/cdelzet/delzet,delsgr /cvocell/vocell
3385 common/cen/ncentr /ctauhac/ntauhac(ncenthy,netahy)
3386 common/cranphi/ranphi,ranecc,weiecc
3387 character txt*40
60ed90b3 3388 data icnthnb /0/ !vv2 /0./ nvv2 /0/ vv3 /0./
9ef1c2d9 3389 !save vv2,nvv2,vv3
3390 save icnthnb
60ed90b3 3391
9ef1c2d9 3392 call utpri('hnbaaa',ish,ishini,4)
60ed90b3 3393
9ef1c2d9 3394 if(ish.ge.3)then
3395 write(ifch,140)
3396 140 format(/' ----------------------------------'/
3397 *' droplet decay'/
3398 *' ----------------------------------')
3399 write(ifch,*)'droplet:'
3400 call alist('&',ip,ip)
3401 endif
60ed90b3 3402
9ef1c2d9 3403 iret=0
3404 do j=1,5
3405 c(j)=pptl(j,ip)
3406 enddo
60ed90b3 3407
9ef1c2d9 3408 call idquac(ip,nqi,nsi,nai,jc)
3409 keu=jc(1,1)-jc(1,2)
3410 ked=jc(2,1)-jc(2,2)
3411 kes=jc(3,1)-jc(3,2)
3412 kec=jc(4,1)-jc(4,2)
3413 keb=jc(5,1)-jc(5,2)
3414 ket=jc(6,1)-jc(6,2)
3415 !print*,'droplet uds=',keu,ked,kes,' E=',pptl(5,ip)
3416
3417 volu=4./3.*pi*radptl(ip)**3
3418
3419 if(volu.le.0)call utstop('hnbaaa: volume = 0&')
3420 if(volu.lt.0.01)then
3421 call utmsg('hnbaaa')
3422 write(ifch,*)'***** very small volume:',volu
3423 write(ifch,*)
3424 * 'id:',idptl(ip),' r:',radptl(ip),' m:',pptl(5,ip)
3425 call utmsgf
3426 endif
60ed90b3 3427
3428 !~~~~~~~~~read in freeze out surface properties from hydro~~~~~~~~~~~~
3429 if(iorsdf.eq.3.and.ityptl(ip).eq.60)then
3430 icnthnb=icnthnb+1
9ef1c2d9 3431 if(icnthnb.eq.1)then
60ed90b3 3432 !here we use epos.iniXXX (like epos.ini1fc)
9ef1c2d9 3433 !instead of the generic filename epos.inihy
3434 open(3,file=fnnx(1:nfnnx)//fnhy(1:nfnhy),status='old',err=99)
3435 read(3,*)txt
3436 read(3,*)maprojx,matargx,engyx,epscrix
3437 if(maprojx.ne.maproj)stop'hnbaaa: maprojx.ne.maproj. '
3438 if(matargx.ne.matarg)stop'hnbaaanew: matargx.ne.matarg. '
3439 if(engyx.ne.engy)stop'hnbaaanew: engyx.ne.engy. '
3440 if(epscrix.ne.epscri(ioclude))then
3441 print*,'hnbaaanew: epscrix.ne.epscri(',ioclude,'). '
3442 stop
60ed90b3 3443 endif
9ef1c2d9 3444 read(3,*)ncenthyx,netahyx,ntauhyx,nphihyx,nradhyx
3445 if(ncenthyx.ne.ncenthy)stop'hnbaaanew: ncenthyx.ne.ncenthy. '
3446 if(netahyx.ne.netahy)stop'hnbaaanew: netahyx.ne.netahy. '
3447 if(ntauhyx.ne.ntauhy)stop'hnbaaanew: ntauhyx.ne.ntauhy. '
3448 if(nphihyx.ne.nphihy)stop'hnbaaanew: nphihyx.ne.nphihy. '
3449 if(nradhyx.ne.nradhy)stop'hnbaaanew: nradhyx.ne.nradhy. '
3450 read(3,*)ntauhoc
3451 read(3,*)centhy,etahy,phihy,radhy
3452 read(3,*)tauhoc
3453 read(3,*)epsii
3454 read(3,*)rom,yom,wom
3455 close(3)
3456 endif
3457 endif
3458
60ed90b3 3459 !~~~~~~~~~define womi yomi romi~~~~~~~~~~~~
3460 if(iorsdf.eq.3.and.icnthnb.eq.1)then
9ef1c2d9 3461 if(ioclude.eq.3)then
3462 do ncent=1,ncenthy
3463 do neta=1,netahy
3464 do ntau=1,ntauhoc(ncent)
3465 do i=1,2
3466 womi(ncent,neta,ntau,i)=wom(ncent,neta,ntau,i)
3467 yomi(ncent,neta,ntau,i)=yom(ncent,neta,ntau,i)
3468 romi(ncent,neta,ntau,i)=rom(ncent,neta,ntau,i)
3469 enddo
3470 enddo
3471 enddo
3472 enddo
3473 elseif(ioclude.eq.2)then
3474 stop'in hnbaaanew: ioclude=2 not supported any more.'
3475 else
60ed90b3 3476 stop'in hnbaaa: invalid ioclude. '
9ef1c2d9 3477 endif
3478 endif
3479
3480 !~~tau partition function paut(ncent,neta,ntau)
3481 !~~phi partition function pauf(ncent,neta,ntau,nphi)
60ed90b3 3482 if(iorsdf.eq.3.and.icnthnb.eq.1)then
9ef1c2d9 3483 do ncent=1,ncenthy
3484 do neta=1,netahy
3485 womax=0
3486 ntauhac(ncent,neta)=0
60ed90b3 3487 do ntau=1,ntauhoc(ncent)
3488 if(womi(ncent,neta,ntau,1).gt.womax )then
9ef1c2d9 3489 womax=womi(ncent,neta,ntau,1)
3490 ntauhac(ncent,neta)=ntau
3491 endif
3492 !print*,ncent,neta,ntau,ntauhac(ncent,neta)
3493 !. , womi(ncent,neta,ntau,1)
3494 enddo
3495 paut(ncent,neta,1)=0
3496 do ntau=2,ntauhac(ncent,neta)
3497 paut(ncent,neta,ntau)=womi(ncent,neta,ntau,1)/womax
3498 !print*,ncent,neta,ntau,paut(ncent,neta,ntau)
3499 enddo
3500 !~~phi~~~~
3501 do ntau=2,ntauhac(ncent,neta)
3502 pauf(ncent,neta,ntau,1)=0
3503 do nphi=2,nphihy
3504 dphi=phihy(nphi)-phihy(nphi-1)
3505 c1=cos(2*phihy(nphi-1))
3506 c2=cos(2*phihy(nphi))
3507 w1=womi(ncent,neta,ntau ,1)+c1*womi(ncent,neta,ntau ,2)
60ed90b3 3508 . -womi(ncent,neta,ntau-1,1)-c1*womi(ncent,neta,ntau-1,2)
9ef1c2d9 3509 w2=womi(ncent,neta,ntau ,1)+c2*womi(ncent,neta,ntau ,2)
60ed90b3 3510 . -womi(ncent,neta,ntau-1,1)-c2*womi(ncent,neta,ntau-1,2)
9ef1c2d9 3511 pauf(ncent,neta,ntau,nphi)
60ed90b3 3512 . =pauf(ncent,neta,ntau,nphi-1)+0.5*(w1+w2)*dphi
9ef1c2d9 3513 enddo
3514 w=pauf(ncent,neta,ntau,nphihy)
3515 if(w.eq.0.)stop'hnbaaanew: w.eq.0. '
3516 do nphi=2,nphihy
3517 pauf(ncent,neta,ntau,nphi)=pauf(ncent,neta,ntau,nphi)/w
3518 enddo
3519 enddo
3520 enddo
3521 enddo
3522 endif
60ed90b3 3523
9ef1c2d9 3524 !~~~~~~~~~determine ncentr~~~~~~~~~~~~
3525 if(iorsdf.eq.3.and.ityptl(ip).eq.60)then !!!fusion on!!!
3526 ncentr=0
3527 dbmin=1000.
3528 do ncent=1,ncenthy
3529 db=abs(bimevt-centhy(ncent))
3530 if(db.lt.dbmin)then
3531 dbmin=db
3532 ncentr=ncent
60ed90b3 3533 endif
9ef1c2d9 3534 enddo
3535 !print*,ncentr,bimevt,centhy(ncentr)
3536 endif
3537
60ed90b3 3538 !~~~~~define masses~~~~~~~~~~~~~~~~
9ef1c2d9 3539 amin=utamnu(keu,ked,kes,kec,keb,ket,5)
3540 aumin=amuseg
3541 ipo=ip
3542 if(ityptl(ip).eq.60)ipo=iorptl(ip)
3543 tecmor=pptl(5,ipo)
3544 tecm=pptl(5,ip)
3545 tecmxx=tecm
3546
3547 !~~~~~~~~~determine netar~~~~~~~~~~~~
60ed90b3 3548 if(iorsdf.eq.3.and.ityptl(ip).eq.60)then
9ef1c2d9 3549 z=xorptl(3,ipo)
3550 t=xorptl(4,ipo)
3551 !print*,z,t,ityptl(ip),tecm
3552 if(t+z.le.0..or.t-z.le.0.)then
3553 zetaor=1000.
3554 else
3555 zetaor=abs(0.5*log((t+z)/(t-z)))
3556 endif
3557 netar=0
3558 detamin=1000.
3559 do neta=1,netahy
3560 deta=abs(zetaor-etahy(neta))
3561 if(deta.lt.detamin)then
3562 detamin=deta
3563 netar=neta
60ed90b3 3564 endif
9ef1c2d9 3565 enddo
3566 !print*,netar,zetaor,etahy(netar)
3567 endif
3568
3569 fradflo=1.
60ed90b3 3570
3571 !~~~~~redefine energy in case of radial flow~~~~~~~~~~~~~~~~
9ef1c2d9 3572 if(iappl.ne.4.and.iorsdf.eq.3.and.tecmor.gt.aumin
3573 ..and.ityptl(ip).eq.60)then
3574 am=0.
3575 do ntau=2,ntauhac(ncentr,netar)
3576 d=paut(ncentr,netar,ntau)-paut(ncentr,netar,ntau-1)
3577 am=am+d
3578 enddo
3579 en=0.
3580 do ntau=2,ntauhac(ncentr,netar)
3581 d=paut(ncentr,netar,ntau)-paut(ncentr,netar,ntau-1)
3582 y=( yomi(ncentr,netar,ntau-1,1)
3583 . +yomi(ncentr,netar,ntau,1)) / 2
3584 en=en+d*cosh(y)
3585 enddo
3586 fradflo=1.
3587 if(en.ne.0.)fradflo=am/en
3588 if(tecm*fradflo.lt.amin)fradflo=1.
60ed90b3 3589 endif
9ef1c2d9 3590 tecm=tecm*fradflo
60ed90b3 3591
3592 !~~~~~redefine energy in case of long coll flow
9ef1c2d9 3593 if(iappl.eq.4.or.iorsdf.ne.3
60ed90b3 3594 &.or.ityptl(ip).eq.40.or.ityptl(ip).eq.50)then !not for droplets from remnants
9ef1c2d9 3595 yco=0
3596 else
3597 if(ylongmx.lt.0.)then
3598 yco=delzet * 1.75
3599 else
3600 yco=ylongmx
3601 endif
60ed90b3 3602 endif
9ef1c2d9 3603 tecmx=tecm
3604 if(yco.gt.0..and.tecmor.gt.aumin) then
60ed90b3 3605 tecm=tecm/sinh(yco)*yco
3606 else
3607 yco=0.
9ef1c2d9 3608 endif
3609 !print*,'========= cluster energy: ',pptl(5,ip),tecmx,tecm
3610
3611 !~~~~~~~~~redefine volume~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
3612
60ed90b3 3613 vocri=tecm/epscri(ioclude)
3614 volu=max(vocri,vocell)
9ef1c2d9 3615
3616 !~~~~~~~~~decay~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
3617 call hnbini(iret)
3618 !if(iret.ne.0)write(ifch,*)'***** unsucessfull hnbini *****'
3619 if(iret.ne.0)goto1000
3620 if(ioinct.ge.1)goto1
60ed90b3 3621
9ef1c2d9 3622 do iter=1,itermx
3623 naccit(iter)=0
3624 call hnbmet
3625 enddo
60ed90b3 3626
9ef1c2d9 36271 continue
3628
3629 if(ioceau.eq.1.and.iappl.eq.1)call xhnbte(ip)
3630
3631 !~~~~~~~~~~long coll flow -> particles~~~~~~~~~~~~~~~~
3632 if(yco.gt.0.) then
3633 errlim=0.0001
3634 tecm=tecmx
3635 611 energ=0.
3636 do i=1,np
3637 yrad(i)=(2*rangen()-1)*yco
3638 uu(3)=sinh(yrad(i))
3639 uu(4)=cosh(yrad(i))
3640 energ=energ+uu(4)*pcm(4,i)+uu(3)*pcm(3,i)
3641 enddo
3642 if(abs(energ-tecm).gt.0.1) goto 611
3643 !print*,'===== energy after flow boosts',energ,' soll: ',tecm
3644 do j=1,4
3645 pe(j)=0.
3646 enddo
60ed90b3 3647 do i=1,np
9ef1c2d9 3648 uu(1)= 0
3649 uu(2)= 0
3650 uu(3)= sinh(yrad(i))
3651 uu(4)= cosh(yrad(i))
3652 call utlob3(-1,uu(1),uu(2),uu(3),uu(4),1e0
3653 * , pcm(1,i), pcm(2,i), pcm(3,i), pcm(4,i))
3654 do j=1,4
3655 pe(j)=pe(j)+pcm(j,i)
3656 enddo
3657 enddo
3658 pe(5)=sqrt(pe(4)**2-pe(3)**2-pe(2)**2-pe(1)**2)
3659 !write(6,'(a,5e11.3)')'flow boosts',pe
3660 do j=1,4
3661 pa(j)=0.
3662 enddo
60ed90b3 3663 do i=1,np
9ef1c2d9 3664 call utlob3(1,pe(1),pe(2),pe(3),pe(4),pe(5)
3665 * , pcm(1,i), pcm(2,i), pcm(3,i), pcm(4,i))
3666 do j=1,4
3667 pa(j)=pa(j)+pcm(j,i)
3668 enddo
3669 enddo
3670 pa(5)=sqrt(pa(4)**2-pa(3)**2-pa(2)**2-pa(1)**2)
3671 !write(6,'(a,5e11.3)')' cms boost ',pa
3672 esoll=tecm
3673 scal=1.
3674 do ipass=1,200
3675 sum=0.
3676 do j=1,np
3677 do k=1,3
3678 pcm(k,j)=scal*pcm(k,j)
3679 enddo
3680 pcm(4,j)=sqrt(pcm(1,j)**2+pcm(2,j)**2+pcm(3,j)**2
3681 * +amass(j)**2)
3682 sum=sum+pcm(4,j)
60ed90b3 3683 enddo
9ef1c2d9 3684 scal=esoll/sum
3685 !write(6,*)'ipass,scal,e,esoll:'
60ed90b3 3686 ! $ ,ipass,scal,sum,esoll
9ef1c2d9 3687 if(abs(scal-1.).le.errlim) goto301
3688 enddo
60ed90b3 3689 301 continue
9ef1c2d9 3690 do j=1,4
3691 pa(j)=0.
3692 enddo
60ed90b3 3693 do i=1,np
9ef1c2d9 3694 do j=1,4
3695 pa(j)=pa(j)+pcm(j,i)
3696 enddo
3697 enddo
3698 pa(5)=sqrt(pa(4)**2-pa(3)**2-pa(2)**2-pa(1)**2)
3699 !write(6,'(a,5e11.3)')' rescaling ',pa
3700 endif
3701
3702 !~~~~~~~~~~radial flow -> particles~~~~~~~~~~~~~~~~~~
3703 if(fradflo.lt.1.) then
3704 aa=1
3705 bb=0
3706 cc=0
3707 dd=1
60ed90b3 3708 if(ityptl(ip).eq.60)then
9ef1c2d9 3709 ipo=iorptl(ip)
3710 xx=uptl(ipo) ! <x**2>
3711 yy=optl(ipo) ! <y**2>
3712 xy=desptl(ipo) ! <x*y>
3713 dta=0.5*abs(xx-yy)
3714 ev1=(xx+yy)/2+sqrt(dta**2+xy**2)
3715 ev2=(xx+yy)/2-sqrt(dta**2+xy**2)
3716 !if(xy.lt.0..and.dta.ne.0.)then
3717 ! phiclu=0.5*atan(-xy/dta)
3718 !elseif(xy.gt.0..and.dta.ne.0.)then
3719 ! phiclu=-0.5*atan(xy/dta)
3720 !else
3721 ! phiclu=0
3722 !endif
3723 yy=ev1
3724 xx=ev2
3725 ecc=(yy-xx)/(yy+xx)
3726 endif
3727 errlim=0.0001
3728 tecm=tecmxx
60ed90b3 3729 phinull=phievt+ranphi
9ef1c2d9 3730 do n=1,np
3731 !~~determine random tau from paut(ncentr,netar,ntau)
3732 r=rangen()
3733 ntau=1
3734 do while(paut(ncentr,netar,ntau).lt.r)
3735 ntau=ntau+1
3736 enddo
3737 if(ntau.eq.1)ntau=2
3738 ntau1=ntau-1
3739 ntau2=ntau
3740 tau1=tauhoc(ncentr,ntau1)
3741 tau2=tauhoc(ncentr,ntau2)
3742 f1=paut(ncentr,netar,ntau1)-r
3743 f2=paut(ncentr,netar,ntau2)-r
3744 f=f1/(f1-f2)
3745 fx=f
3746 tau= tau1*(1-f) + tau2*f
60ed90b3 3747 taufop(n)=tau
9ef1c2d9 3748 !~~determine phifop~~~~~
3749 r=rangen()
3750 if(pauf(ncentr,netar,ntau-1,nphihy).gt.0.
3751 . .and.pauf(ncentr,netar,ntau,nphihy).gt.0.)then
3752 nphi=1
3753 do while((pauf(ncentr,netar,ntau1,nphi)*(1-fx)
3754 . + pauf(ncentr,netar,ntau2,nphi)*fx) .lt.r)
3755 nphi=nphi+1
3756 enddo
3757 if(nphi.eq.1)nphi=2
3758 nphi1=nphi-1
3759 nphi2=nphi
3760 phi1=phihy(nphi1)
3761 phi2=phihy(nphi2)
3762 f1=pauf(ncentr,netar,ntau,nphi1)-r
3763 f2=pauf(ncentr,netar,ntau,nphi2)-r
3764 f=f1/(f1-f2)
3765 phi=phi1+f*(phi2-phi1)
3766 else
3767 phi=rangen()*pi/2.
3768 endif
3769 if(px.ge.0..and.py.ge.0.)then
3770 continue
3771 elseif(px.lt.0..and.py.gt.0.)then
3772 phi=pi-phi
3773 elseif(px.lt.0..and.py.lt.0.)then
3774 phi=pi+phi
3775 elseif(px.gt.0..and.py.lt.0.)then
3776 phi=2*pi-phi
3777 endif
3778 phifop(n)=phi
3779 !~~determine yrad~~~~
60ed90b3 3780 yr1=yomi(ncentr,netar,ntau1,1)
3781 . +yomi(ncentr,netar,ntau1,2)*cos(2*phi)
3782 yr2=yomi(ncentr,netar,ntau2,1)
3783 . +yomi(ncentr,netar,ntau2,2)*cos(2*phi)
3784 yr= yr1*(1-fx)+ fx*yr2
3785 yrad(n)=yr
9ef1c2d9 3786 !~~determine radfop~~~~
3787 rad1=romi(ncentr,netar,ntau1,1)
3788 . +romi(ncentr,netar,ntau1,2)*cos(2*phi)
3789 rad2=romi(ncentr,netar,ntau2,1)
3790 . +romi(ncentr,netar,ntau2,2)*cos(2*phi)
3791 rad= rad1*(1-fx) + fx*rad2
3792 radfop(n)=rad
3793 enddo
3794 energ=0.
60ed90b3 3795 do n=1,np
3796 uu(1)=sinh(yrad(n))*cos(phifop(n)+phinull)
3797 uu(2)=sinh(yrad(n))*sin(phifop(n)+phinull)
3798 uu(3)=0d0
9ef1c2d9 3799 uu(4)=sqrt(1+uu(1)**2+uu(2)**2)
3800 !px=pcm(1,n)
3801 !py=pcm(2,n)
3802 !vv2=vv2+(px**2-py**2)/(px**2+py**2)
3803 call utlob3(-1,uu(1),uu(2),uu(3),uu(4),1e0
3804 * , pcm(1,n), pcm(2,n), pcm(3,n), pcm(4,n))
3805 energ=energ+pcm(4,n)
3806 !?????????????????????????????????????????????????
3807 ! px=pcm(1,n)
3808 ! py=pcm(2,n)
3809 ! vv3=vv3+(px**2-py**2)/(px**2+py**2)
3810 ! nvv2=nvv2+1
3811 ! if(mod(nvv2,100).eq.0)
3812 !. print*,'++++',nvv2,vv2/nvv2,vv3/nvv2
3813 !?????????????????????????????????????????????????
3814 enddo
3815 esoll=tecm
3816 scal=1.
3817 do ipass=1,200
3818 sum=0.
3819 do j=1,np
3820 do k=1,3
3821 pcm(k,j)=scal*pcm(k,j)
3822 enddo
3823 pcm(4,j)=sqrt(pcm(1,j)**2+pcm(2,j)**2+pcm(3,j)**2
3824 * +amass(j)**2)
3825 sum=sum+pcm(4,j)
60ed90b3 3826 enddo
9ef1c2d9 3827 scal=esoll/sum
3828 !write(6,*)'ipass,scal,e,esoll:'
60ed90b3 3829 ! $ ,ipass,scal,sum,esoll
9ef1c2d9 3830 if(abs(scal-1.).le.errlim) goto300
3831 enddo
60ed90b3 3832 300 continue
9ef1c2d9 3833 !print*, scal
3834 else
3835 do n=1,np
3836 yrad(n)=0.
3837 phifop(n)=0.
3838 radfop(n)=0.
3839 taufop(n)=0.
3840 enddo
3841 endif
3842 !~~~~~~~~~~~~~~~
3843
3844 nptlb=nptl
3845 do n=1,np
3846 nptl=nptl+1
3847 if(nptl.gt.mxptl)call utstop('hnbptl: mxptl too small&')
3848 idptl(nptl)=ident(n)
3849 do j=1,4
3850 p(j)=pcm(j,n)
3851 enddo
3852 p(5)=amass(n)
3853 call utlob2(-1,c(1),c(2),c(3),c(4),c(5),p(1),p(2),p(3),p(4),10)
3854 do j=1,5
3855 pptl(j,nptl)=p(j)
3856 enddo
3857 if(fradflo.lt.1.) then
3858 ityptl(nptl)=60
3859 else
3860 ityptl(nptl)=19
3861 endif
3862 if(ityptl(ip).eq.60)then
3863 if(ityptl(nptl).eq.60)then
3864 ipo=iorptl(ip)
3865 yr=yrad(n)
3866 phi=phifop(n)
3867 tau=taufop(n)
3868 r=radfop(n)
3869 !---add r-randomness
3870 !dr=5
3871 !do while(dr.lt.-2.or.dr.gt.2.)
3872 ! dr=sqrt(3.)*(rangen()+rangen()+rangen()+rangen()-2)
3873 !enddo
3874 !r=r+dr
3875 zeta=0.5*log((p(4)+p(3))/(p(4)-p(3)))
3876 !deleta=etahy(2)-etahy(1)
3877 !zeta=zetaor-0.5*delzet+delzet*rangen()
3878 z=tau*sinh(zeta)
3879 t=tau*cosh(zeta)
60ed90b3 3880 xorptl(1,nptl)=r*cos(phifop(n)+phinull)
3881 xorptl(2,nptl)=r*sin(phifop(n)+phinull)
9ef1c2d9 3882 xorptl(3,nptl)=z
3883 xorptl(4,nptl)=t
3884 else
3885 xorptl(1,nptl)=xorptl(1,ip)
3886 xorptl(2,nptl)=xorptl(2,ip)
3887 xorptl(3,nptl)=xorptl(3,ip)
3888 xorptl(4,nptl)=xorptl(4,ip)
60ed90b3 3889 endif
9ef1c2d9 3890 endif
60ed90b3 3891 enddo
9ef1c2d9 3892 if(ish.ge.3)then
3893 write(ifch,*)'decay products:'
3894 call alist('&',nptlb+1,nptl)
3895 if(ish.ge.5)then
3896 write(ifch,*)'momentum sum:'
3897 do kk=1,5
3898 pptl(kk,nptl+1)=0
3899 do ii=nptlb+1,nptl
3900 pptl(kk,nptl+1)=pptl(kk,nptl+1)+pptl(kk,ii)
3901 enddo
3902 pptl(kk,nptl+2)=c(kk)
3903 enddo
3904 call alist('&',nptl+1,nptl+2)
3905 endif
3906 endif
3907
3908 1000 continue
3909
3910 call utprix('hnbaaa',ish,ishini,4)
3911 return
3912
60ed90b3 3913 99 print*,'hnbaaanew: error opening hydro table'
9ef1c2d9 3914 print*,' file=',fnnx(1:nfnnx)//fnhy(1:nfnhy)
3915 print*,'maybe "fname inihy ..." forgotten in optns file ???'
3916 print*,' this is necessary in case of "set ioclude 3"'
3917 stop'070817'
60ed90b3 3918
9ef1c2d9 3919 end
3920
3921c------------------------------------------------------------------------------
3922 subroutine xSpaceTime
3923c------------------------------------------------------------------------------
3924 include 'epos.inc'
3925 if(iSpaceTime.eq.1.and.ioclude.gt.1)then
3926 call xCoreCorona(0,0)
3927 do neta=1,5,2
60ed90b3 3928 call xFoMass(neta)
3929 call xFoRadius(neta)
3930 call xFoRadRapidity(neta)
3931 call xFreezeOutTauX(neta)
9ef1c2d9 3932 enddo
3933 call xFreezeOutTauEta
3934 call xFreezeOutTZ
3935 elseif(iSpaceTime.eq.1)then
3936 call xCoreCorona(0,0)
3937 !stop'bjinta: space-time plots require ioclude>1. '
60ed90b3 3938 endif
9ef1c2d9 3939 end
3940
3941c------------------------------------------------------------------------------
3942 subroutine xFreezeOutTauX(neta)
3943c------------------------------------------------------------------------------
3944 include 'epos.inc'
3945 include 'epos.inchy'
3946 common/cxyzt/xptl(mxptl),yptl(mxptl),zptl(mxptl),tptl(mxptl)
3947 *,optl(mxptl),uptl(mxptl),sptl(mxptl),rptl(mxptl,3)
3948 common/cen/ncentr /ctauhac/ntauhac(ncenthy,netahy)
3949 character *8 cbim,cbimhy
3950 call centrality(bimevt ,cbim)
3951 call centrality(centhy(ncentr),cbimhy)
3952 !..........................................................................
3953 nhis=1
3954 npl=0
3955 nplx=0
3956 deleta=etahy(2)-etahy(1)
3957 eta1=etahy(neta)-deleta/2
3958 eta2=etahy(neta)+deleta/2
3959 etaav=etahy(neta)
3960 taumax=tauhoc(ncentr,ntauhac(ncentr,neta))+4
3961 do n=1,nptl
3962 if(ityptl(n).eq.60
3963 * .and.istptl(n).ne.12.and.istptl(n).ne.11)then
3964 if(istptl(iorptl(n)).eq.11)then
3965 tau=0
3966 tau2=xorptl(4,n)**2-xorptl(3,n)**2
3967 if(tau2.gt.0.)tau=sqrt(tau2)
3968 if(tau.lt.taumax)then
3969 rap=
3970 * .5*alog((xorptl(4,n)+xorptl(3,n))/(xorptl(4,n)-xorptl(3,n)))
3971 if(rap.ge.eta1.and.rap.le.eta2)then
3972 if(abs(xorptl(2,n)).le.2)then
3973 npl=npl+1
3974 nplx=nplx+1
3975 if(npl.eq.1)then
3976 if(nplx.gt.1)
3977 * write(ifhi,'(a)') ' endarray closehisto plot 0-'
3978 write(ifhi,'(a)') '!-------------------------------'
3979 write(ifhi,'(a)') '! tau-x '
3980 write(ifhi,'(a)') '!-------------------------------'
3981 write(ifhi,'(a)') '!newpage'
3982 write(ifhi,'(a,i1)') 'openhisto name t-r-0-',nhis
3983 write(ifhi,'(a)') 'htyp prl xmod lin ymod lin'
3984 write(ifhi,'(a)') 'xrange -10 10'
3985 write(ifhi,'(a,f5.1)') 'yrange 0 ',taumax
3986 write(ifhi,'(a)') 'txt "xaxis x (fm)"'
3987 write(ifhi,'(a)') 'txt "yaxis [t] (fm/c)"'
3988 write(ifhi,'(a,f4.1,a)')'text 0.55 0.90 "[c]=',etaav,'"'
3989 write(ifhi,'(a)') 'text 0.02 0.90 ""-2fm"L#y"L#2fm""'
3990 write(ifhi,'(a,f4.1,a,f4.1,a)')'text 0.77 0.92 "'//cbim//'"'
3991 write(ifhi,'(a)') 'array 2'
3992 endif
3993 write(ifhi,'(2e11.3)')xorptl(1,n),tau
3994 if(npl.eq.1000)then
3995 nhis=nhis+1
3996 npl=0
3997 endif
3998 endif
60ed90b3 3999 endif
9ef1c2d9 4000 endif
60ed90b3 4001 endif
4002 endif
9ef1c2d9 4003 enddo
4004 if(nplx.gt.0)write(ifhi,'(a)') ' endarray closehisto plot 0-'
4005 !..........................................................................
4006 nhis=1
4007 npl=0
4008 nplx=0
4009 npli=20
4010 do n=1,nptl
4011 if(dezptl(n).lt.1e3.and.n.le.maxfra
4012 * .and.(istptl(n).eq.0.or.istptl(n).eq.1))then
4013 rap=1e10
4014 xp=tptl(n)+zptl(n)
4015 xm=tptl(n)-zptl(n)
4016 if(xp.gt.0.0.and.xm.gt.0.0)rap=.5*alog(xp/xm)
4017 if(rap.ge.-0.5.and.rap.le.0.5)then
4018 if(abs(xorptl(2,n)).le.2)then
4019 npl=npl+npli
4020 nplx=nplx+1
4021 if(npl.eq.npli)then
4022 if(nplx.gt.1)
4023 * write(ifhi,'(a)') ' endarray closehisto plot 0-'
4024 write(ifhi,'(a)') '!-------------------------------'
4025 write(ifhi,'(a)') '! tau-x corona '
4026 write(ifhi,'(a)') '!-------------------------------'
4027 write(ifhi,'(a,i1)') 'openhisto name t-r-0-cor-',nhis
4028 write(ifhi,'(a)') 'htyp pgl '
4029 write(ifhi,'(a)') 'array 2'
4030 endif
4031 x=xorptl(1,n)
4032 y=xorptl(2,n)
4033 z=xorptl(3,n)
4034 t=xorptl(4,n)
4035 tau=0
4036 tau2=t**2-z**2
4037 if(tau2.gt.0.)tau=sqrt(tau2)
4038 if(abs(y).le.2)
4039 . write(ifhi,'(2e11.3)')x,tau
4040 dt=0.1
4041 do k=1,npli-1
4042 x=x+pptl(1,n)/pptl(4,n)*dt
4043 y=y+pptl(2,n)/pptl(4,n)*dt
4044 z=z+pptl(3,n)/pptl(4,n)*dt
4045 t=t+dt
4046 tau=0
4047 tau2=t**2-z**2
4048 if(tau2.gt.0.)tau=sqrt(tau2)
4049 if(abs(y).le.2)
4050 . write(ifhi,'(2e11.3)')x,tau
4051 enddo
4052 if(npl.eq.1000)then
4053 nhis=nhis+1
4054 npl=0
4055 endif
4056 endif
60ed90b3 4057 endif
4058 endif
9ef1c2d9 4059 enddo
4060 write(ifhi,'(a)') ' endarray closehisto plot 0'
4061 !..........................................................................
4062 end
60ed90b3 4063
9ef1c2d9 4064c------------------------------------------------------------------------------
4065 subroutine xFreezeOutTauEta
4066c------------------------------------------------------------------------------
4067 include 'epos.inc'
4068 include 'epos.inchy'
4069 common/cxyzt/xptl(mxptl),yptl(mxptl),zptl(mxptl),tptl(mxptl)
4070 *,optl(mxptl),uptl(mxptl),sptl(mxptl),rptl(mxptl,3)
4071 character *8 cbim,cbimhy
4072 common/cen/ncentr /ctauhac/ntauhac(ncenthy,netahy)
4073 call centrality(bimevt ,cbim)
4074 call centrality(centhy(ncentr),cbimhy)
4075 taumax=tauhoc(ncentr,ntauhac(ncentr,1))+4
4076 !..........................................................................
4077 nhis=1
4078 npl=0
4079 do n=1,nptl
4080 if(ityptl(n).eq.60
4081 * .and.istptl(n).ne.12.and.istptl(n).ne.11)then
4082 if(istptl(iorptl(n)).eq.11)then
4083 tau=0
4084 tau2=xorptl(4,n)**2-xorptl(3,n)**2
4085 if(tau2.gt.0.)tau=sqrt(tau2)
4086 if(tau.lt.taumax)then
4087 npl=npl+1
4088 if(npl.eq.1)then
4089 write(ifhi,'(a)') '!-------------------------------'
4090 write(ifhi,'(a)') '! tau-eta '
4091 write(ifhi,'(a)') '!-------------------------------'
4092 write(ifhi,'(a)') '!newpage'
4093 write(ifhi,'(a,i1)') 'openhisto name t-eta-',nhis
4094 write(ifhi,'(a)') 'htyp prl xmod lin ymod lin'
4095 write(ifhi,'(a)') 'xrange -4 4'
4096 write(ifhi,'(a,f5.1)') 'yrange 0 ',taumax
4097 write(ifhi,'(a)') 'txt "xaxis [c] "'
4098 write(ifhi,'(a)') 'txt "yaxis [t] (fm/c)"'
60ed90b3 4099 write(ifhi,'(a,f4.1,a,f4.1,a)')'text 0.77 0.92 "'//cbim//'"'
9ef1c2d9 4100 write(ifhi,'(a)') 'array 2'
4101 endif
4102 eta=
4103 * .5*alog((xorptl(4,n)+xorptl(3,n))/(xorptl(4,n)-xorptl(3,n)))
4104 write(ifhi,'(2e11.3)') eta,tau
4105 if(npl.eq.1000)then
4106 write(ifhi,'(a)') ' endarray closehisto plot 0-'
4107 nhis=nhis+1
4108 npl=0
4109 endif
4110 endif
60ed90b3 4111 endif
4112 endif
9ef1c2d9 4113 enddo
4114 if(npl.ne.0)write(ifhi,'(a)') ' endarray closehisto plot 0'
4115 if(npl.eq.0)stop'xFreezeOutTZ: no particles!!!!! '
4116 end
4117
4118c------------------------------------------------------------------------------
4119 subroutine xFreezeOutTZ
4120c------------------------------------------------------------------------------
4121 include 'epos.inc'
4122 include 'epos.inchy'
4123 common/cxyzt/xptl(mxptl),yptl(mxptl),zptl(mxptl),tptl(mxptl)
4124 *,optl(mxptl),uptl(mxptl),sptl(mxptl),rptl(mxptl,3)
4125 character *8 cbim,cbimhy
4126 common/cen/ncentr
4127 call centrality(bimevt ,cbim)
4128 call centrality(centhy(ncentr),cbimhy)
4129 !..........................................................................
4130 nhis=1
4131 npl=0
4132 do n=1,nptl
4133 if(ityptl(n).eq.60
4134 * .and.istptl(n).ne.12.and.istptl(n).ne.11)then
4135 if(istptl(iorptl(n)).eq.11)then
4136 npl=npl+1
4137 if(npl.eq.1)then
4138 write(ifhi,'(a)') '!-------------------------------'
4139 write(ifhi,'(a)') '! t-z '
4140 write(ifhi,'(a)') '!-------------------------------'
4141 write(ifhi,'(a)') '!newpage'
4142 write(ifhi,'(a,i1)') 'openhisto name t-z-',nhis
4143 write(ifhi,'(a)') 'htyp prl xmod lin ymod lin'
4144 write(ifhi,'(a)') 'xrange -25 25'
4145 write(ifhi,'(a)') 'yrange 0 25 '
4146 write(ifhi,'(a)') 'txt "xaxis z (fm)"'
4147 write(ifhi,'(a)') 'txt "yaxis t (fm/c)"'
60ed90b3 4148 write(ifhi,'(a,f4.1,a,f4.1,a)')'text 0.75 0.22 "'//cbim//'"'
9ef1c2d9 4149 write(ifhi,'(a)') 'array 2'
4150 endif
4151 write(ifhi,'(2e11.3)') xorptl(3,n),xorptl(4,n)
4152 if(npl.eq.1000)then
4153 write(ifhi,'(a)') ' endarray closehisto plot 0-'
4154 nhis=nhis+1
4155 npl=0
4156 endif
60ed90b3 4157 endif
4158 endif
9ef1c2d9 4159 enddo
4160 if(npl.ne.0)write(ifhi,'(a)') ' endarray closehisto plot 0'
4161 if(npl.eq.0)stop'xFreezeOutTZ: no particles!!!!! '
4162 end
4163
4164c------------------------------------------------------------------------------
4165 subroutine xFoMass(neta)
4166c------------------------------------------------------------------------------
4167 include 'epos.inc'
4168 include 'epos.inchy'
4169 common/cen/ncentr /ctauhac/ntauhac(ncenthy,netahy)
4170 character *8 cbim
4171 call centrality(bimevt ,cbim)
4172 taumax=tauhoc(ncentr,ntauhac(ncentr,neta))+2
4173 netahyxx=netahy
4174 write(ifhi,'(a)') '!----------------------------------------'
4175 write(ifhi,'(a,i3)') '! hydro freeze out w_0 w_2 '
4176 write(ifhi,'(a)') '!----------------------------------------'
4177 write(ifhi,'(a)') '!newpage'
4178 do ii=1,2
4179 write(ifhi,'(a,3i1)')'openhisto htyp lin name w-',neta,nn,ii
4180 if(ii.eq.1)then !----------------------
60ed90b3 4181 write(ifhi,'(a,f4.1)')'xmod lin xrange 0. ',taumax
4182 write(ifhi,'(a)') 'txt "xaxis [t] (fm/c)"'
9ef1c2d9 4183 write(ifhi,'(a)') 'ymod lin yrange auto auto '
4184 write(ifhi,'(a,f4.2,a)') 'text 0.1 0.9 " [c]=',etahy(neta),'"'
4185 write(ifhi,'(a)')'txt "yaxis w?0! w?2! (GeVc/fm) "'
60ed90b3 4186 write(ifhi,'(a,f4.1,a,f4.1,a)')'text 0.50 0.9 "'//cbim//' "'
9ef1c2d9 4187 endif !-------------------------------
4188 write(ifhi,'(a)')'array 2'
4189 deltau=tauhoc(ncentr,2)-tauhoc(ncentr,1)
4190 do ntau=2,ntauhac(ncentr,neta)
4191 dy=(wom(ncentr,neta,ntau,ii)-wom(ncentr,neta,ntau-1,ii))
4192 write(ifhi,'(2e13.5)')tauhoc(ncentr,ntau)-deltau/2,dy
4193 enddo
4194 write(ifhi,'(a)') 'endarray closehisto '
4195 if(ii.ne.2)write(ifhi,'(a)') 'plot 0-'
4196 if(ii.eq.2)write(ifhi,'(a)') 'plot 0'
60ed90b3 4197 enddo
9ef1c2d9 4198 end
4199
4200c------------------------------------------------------------------------------
4201 subroutine xFoRadius(neta)
4202c------------------------------------------------------------------------------
4203 include 'epos.inc'
4204 include 'epos.inchy'
4205 common/cen/ncentr /ctauhac/ntauhac(ncenthy,netahy)
4206 character *8 cbim
4207 call centrality(bimevt ,cbim)
4208 taumax=tauhoc(ncentr,ntauhac(ncentr,neta))+2
4209 netahyxx=netahy
4210 write(ifhi,'(a)') '!----------------------------------------'
4211 write(ifhi,'(a,i3)') '! hydro freeze out r_0 r_2 '
4212 write(ifhi,'(a)') '!----------------------------------------'
4213 write(ifhi,'(a)') '!newpage'
4214 do ii=1,2
4215 write(ifhi,'(a,3i1)')'openhisto htyp lin name r-',neta,nn,ii
4216 if(ii.eq.1)then !----------------------
60ed90b3 4217 write(ifhi,'(a,f4.1)')'xmod lin xrange 0. ',taumax
9ef1c2d9 4218 write(ifhi,'(a)')'txt "xaxis [t] (fm/c)"'
4219 write(ifhi,'(a)') 'ymod lin yrange auto auto '
4220 write(ifhi,'(a,f4.2,a)')'text 0.1 0.9 " [c]=',etahy(neta),'"'
4221 write(ifhi,'(a)')'txt "yaxis r?0! r?2! (fm) "'
60ed90b3 4222 write(ifhi,'(a,f4.1,a,f4.1,a)')'text 0.50 0.9 "'//cbim//' "'
9ef1c2d9 4223 endif !-------------------------------
4224 write(ifhi,'(a)')'array 2'
4225 do ntau=2,ntauhac(ncentr,neta)
4226 write(ifhi,'(2e13.5)')tauhoc(ncentr,ntau)
4227 . ,romi(ncentr,neta,ntau,ii)
4228 enddo
4229 write(ifhi,'(a)') 'endarray closehisto '
4230 if(ii.ne.2)write(ifhi,'(a)') 'plot 0-'
4231 if(ii.eq.2)write(ifhi,'(a)') 'plot 0'
4232 enddo
4233 end
60ed90b3 4234
9ef1c2d9 4235c------------------------------------------------------------------------------
4236 subroutine xFoRadRapidity(neta)
4237c------------------------------------------------------------------------------
4238 include 'epos.inc'
4239 include 'epos.inchy'
4240 common/cen/ncentr /ctauhac/ntauhac(ncenthy,netahy)
4241 character *8 cbim
4242 call centrality(bimevt ,cbim)
4243 taumax=tauhoc(ncentr,ntauhac(ncentr,neta))+2
4244 netahyxx=netahy
4245 write(ifhi,'(a)') '!----------------------------------------'
4246 write(ifhi,'(a,i3)') '! hydro freeze out y_0 y_2 '
4247 write(ifhi,'(a)') '!----------------------------------------'
4248 write(ifhi,'(a)') '!newpage'
4249 do ii=1,2
4250 write(ifhi,'(a,3i1)')'openhisto htyp lin name y-',neta,nn,ii
4251 if(ii.eq.1)then !----------------------
4252 write(ifhi,'(a,f4.1)')'xmod lin xrange 0. ',taumax
4253 write(ifhi,'(a)')'txt "xaxis [t] (fm/c)"'
4254 write(ifhi,'(a)') 'ymod lin yrange auto auto '
4255 write(ifhi,'(a,f4.2,a)')'text 0.1 0.9 " [c]=',etahy(neta),'"'
4256 write(ifhi,'(a)')'txt "yaxis y?0! y?2! "'
60ed90b3 4257 write(ifhi,'(a,f4.1,a,f4.1,a)')'text 0.50 0.9 "'//cbim//' "'
9ef1c2d9 4258 endif !-------------------------------
4259 write(ifhi,'(a)')'array 2'
4260 do ntau=2,ntauhac(ncentr,neta)
4261 write(ifhi,'(2e13.5)')tauhoc(ncentr,ntau)
4262 . ,yomi(ncentr,neta,ntau,ii)
4263 enddo
4264 write(ifhi,'(a)') 'endarray closehisto '
4265 if(ii.ne.2)write(ifhi,'(a)') 'plot 0-'
4266 if(ii.eq.2)write(ifhi,'(a)') 'plot 0'
4267 enddo
4268 end
4269
4270c------------------------------------------------------------------------------
4271 subroutine centrality(b,cbim)
4272c------------------------------------------------------------------------------
4273 include 'epos.inc'
4274 character *8 cbim
4275 parameter (maxb=16)
4276 dimension iperc(maxb),bim(maxb)
4277 parameter(mxdefine=40)
4278 character w1define*100,w2define*100
4279 common/cdefine/ndefine,l1define(mxdefine),l2define(mxdefine)
4280 & ,w1define(mxdefine),w2define(mxdefine)
4281
4282 data iperc /0,5,10,15,20,25,30,35,40,45,50,60,70,80,92,100/
60ed90b3 4283
9ef1c2d9 4284 do n=1,maxb
4285 bim(n)=0
4286 enddo
4287 do m=1,ndefine
4288 if(w1define(m)(1:l1define(m)).eq.'bim05')then
4289 read(w2define(m)(1:l2define(m)),*)bim(2)
4290 elseif(w1define(m)(1:l1define(m)).eq.'bim10')then
4291 read(w2define(m)(1:l2define(m)),*)bim(3)
4292 elseif(w1define(m)(1:l1define(m)).eq.'bim15')then
4293 read(w2define(m)(1:l2define(m)),*)bim(4)
4294 elseif(w1define(m)(1:l1define(m)).eq.'bim20')then
4295 read(w2define(m)(1:l2define(m)),*)bim(5)
4296 elseif(w1define(m)(1:l1define(m)).eq.'bim25')then
4297 read(w2define(m)(1:l2define(m)),*)bim(6)
4298 elseif(w1define(m)(1:l1define(m)).eq.'bim30')then
4299 read(w2define(m)(1:l2define(m)),*)bim(7)
4300 elseif(w1define(m)(1:l1define(m)).eq.'bim35')then
4301 read(w2define(m)(1:l2define(m)),*)bim(8)
4302 elseif(w1define(m)(1:l1define(m)).eq.'bim40')then
4303 read(w2define(m)(1:l2define(m)),*)bim(9)
4304 elseif(w1define(m)(1:l1define(m)).eq.'bim45')then
4305 read(w2define(m)(1:l2define(m)),*)bim(10)
4306 elseif(w1define(m)(1:l1define(m)).eq.'bim50')then
4307 read(w2define(m)(1:l2define(m)),*)bim(11)
4308 elseif(w1define(m)(1:l1define(m)).eq.'bim60')then
4309 read(w2define(m)(1:l2define(m)),*)bim(12)
4310 elseif(w1define(m)(1:l1define(m)).eq.'bim70')then
4311 read(w2define(m)(1:l2define(m)),*)bim(13)
4312 elseif(w1define(m)(1:l1define(m)).eq.'bim80')then
4313 read(w2define(m)(1:l2define(m)),*)bim(14)
4314 elseif(w1define(m)(1:l1define(m)).eq.'bim92')then
4315 read(w2define(m)(1:l2define(m)),*)bim(15)
60ed90b3 4316 endif
9ef1c2d9 4317 enddo
4318 bim(16)=100.
4319 do n=2,maxb
4320 if(bim(n).eq.0.)then
4321 print*,'******* ERROR in subroutine centrality: '
4322 . ,' #define bim?? ??? missing. ******* '
4323 print*,' n=',n
60ed90b3 4324 stop'14082007'
9ef1c2d9 4325 endif
4326 enddo
4327
4328 n=1
4329 do while(bim(n).lt.b)
4330 n=n+1
4331 enddo
4332 n=max(2,n)
4333 write(cbim,'(a,i2,a,i2,a)')' ',iperc(n-1),'-',iperc(n),'% '
4334 !print*,cbim
4335
4336 end
4337
4338c-----------------------------------------------------------------------
4339 subroutine xCoreCorona(iii,jjj)
4340c-----------------------------------------------------------------------
4341c space-time evolution of core and corona
4342c
4343c cluster ............ ist=11 ity=60
4344c core particles ..... ist=0 ity=60
4345c corona particles ... ist=0 ity/=60
4346c
4347c iii=1: plot also binary collisions
4348c jjj>0: multiplicity trigger (useful for pp)
4349c-----------------------------------------------------------------------
4350 include 'epos.inc'
4351 include 'epos.incems'
4352 include 'epos.inchy'
4353 common/cen/ncentr
4354 common/cxyzt/xptl(mxptl),yptl(mxptl),zptl(mxptl),tptl(mxptl)
4355 *,optl(mxptl),uptl(mxptl),sptl(mxptl),rptl(mxptl,3)
4356 common/cdelzet/delzet,delsgr
4357 parameter (myy=48,mrr=100)
4358 real yy(myy),rr(mrr)
4359 common/cranphi/ranphi,ranecc,weiecc
4360 character *8 cbim,cbimhy
4361 cbim=' '
4362 cbimhy=' '
4363 if(ioclude.gt.1)call centrality(bimevt ,cbim)
4364 if(ioclude.gt.1)call centrality(centhy(ncentr),cbimhy)
4365
4366 phi=ranphi+phievt
4367 !print*,'RandomPhi=',ranphi,' EventPhi=',phievt
4368 rapmax=6
4369 radmax=10
4370 r1=0.0
4371 if(maproj.gt.1)r1=radnuc(maproj)
4372 r2=0.0
4373 if(matarg.gt.1)r2=radnuc(matarg)
4374 if(maproj.eq.1.and.matarg.gt.1)r1=r2
4375 if(maproj.gt.1.and.matarg.eq.1)r2=r1
4376 a=7.8
4377 b=bimevt/2
4378 n1=koievt
4379 n2=0
4380 do k=1,koll
4381 if(itpr(k).gt.0)n2=n2+1
4382 enddo
4383 n3=nglevt
4384
4385 if(jjj.gt.0)then
4386 multy1=0
4387 do i=maproj+matarg+1,nptl
4388 if(istptl(i).eq.0)then
4389 amt=pptl(5,i)**2+pptl(1,i)**2+pptl(2,i)**2
4390 rap=1000
4391 if(amt.gt.0..and.pptl(4,i).gt.0.)then
4392 amt=sqrt(amt)
4393 rap=sign(1.,pptl(3,i))*alog((pptl(4,i)+abs(pptl(3,i)))/amt)
4394 endif
4395 ch=0
4396 if(abs(idptl(i)).ge.100.and.abs(idptl(i)).lt.10000)then
4397 call idchrg(idptl(i),ch)
4398 if(abs(ch).gt.0.1.and.abs(rap).le.1.)multy1=multy1+1
4399 endif
4400 endif
60ed90b3 4401 enddo
9ef1c2d9 4402 ih1=jjj/100
4403 ih2=mod(jjj,100)
4404 if(0.5*multy1.lt.ih1.or.0.5*multy1.gt.ih2)return
4405 endif
4406
4407 write(ifhi,'(a)') '!---------------------------------'
4408 write(ifhi,'(a)') '! core particles '
4409 write(ifhi,'(a)') '!---------------------------------'
4410 write(ifhi,'(a)') '!newpage'
4411 write(ifhi,'(a)') 'openhisto name st1'
4412 write(ifhi,'(a)') 'htyp prv xmod lin ymod lin'
4413 write(ifhi,'(a,2e11.3)')'xrange',-a*1.5,a*1.5
4414 write(ifhi,'(a,2e11.3)')'yrange',-a,a
4415 write(ifhi,'(a)') 'text 1.02 -0.15 " x"'
4416 write(ifhi,'(a)') 'txt "yaxis y"'
4417 write(ifhi,'(a)') 'text 0.05 0.90 "core"'
4418 write(ifhi,'(a)') 'text 0.05 0.80 "corona"'
4419 write(ifhi,'(a,f4.1,a)')'text 0.82 0.07 "[c]=0"'
60ed90b3 4420 write(ifhi,'(a,f4.1,a,f4.1,a)')'text 0.77 0.92 "'//cbim//'"'
9ef1c2d9 4421 write(ifhi,'(a)') 'array 2'
4422 ncore=0
4423 do i=1,nptl
4424 if(abs(sptl(i)).lt.0.5*delsgr.and.istptl(i).eq.2)then
4425 write(ifhi,'(2e11.3)')xptl(i)*cos(phi)+yptl(i)*sin(phi)
4426 . , -xptl(i)*sin(phi)+yptl(i)*cos(phi)
4427 ncore=ncore+1
4428 endif
4429 enddo
4430 write(ifhi,'(a)') ' endarray'
4431 write(ifhi,'(a)') 'closehisto plot 0-'
4432 write(ifhi,'(a)') '!----------------------------------'
4433 write(ifhi,'(a)') '! corona particles '
4434 write(ifhi,'(a)') '!----------------------------------'
4435 write(ifhi,'(a)') 'openhisto name st2'
4436 write(ifhi,'(a)') 'htyp pgv xmod lin ymod lin'
4437 write(ifhi,'(a)') 'array 2'
4438 ncorona=0
4439 do i=1,nptl
4440 if(abs(sptl(i)).lt.0.5*delsgr.and.istptl(i).eq.0
4441 . .and.ityptl(i).ne.60.and.ityptl(i).ne.19)then
4442 write(ifhi,'(2e11.3)')xptl(i)*cos(phi)+yptl(i)*sin(phi)
4443 . , -xptl(i)*sin(phi)+yptl(i)*cos(phi)
4444 ncorona=ncorona+1
4445 endif
4446 enddo
4447 write(ifhi,'(a)') ' endarray'
4448 write(ifhi,'(a)') 'closehisto'
4449 !print*,'b=',bimevt,' ncorona:ncore = ',ncorona,':',ncore
4450 if(iii.eq.1)then
4451 write(ifhi,'(a)') '!----------------------------------'
4452 write(ifhi,'(a)') '! binary collisions '
4453 write(ifhi,'(a)') '!----------------------------------'
4454 write(ifhi,'(a)') 'plot 0-'
4455 write(ifhi,'(a)') 'openhisto name coo'
4456 write(ifhi,'(a)') 'htyp pbl xmod lin ymod lin'
4457 write(ifhi,'(a,2e11.3)')'xrange',-a*1.5,a*1.5
4458 write(ifhi,'(a,2e11.3)')'yrange',-a,a
4459 write(ifhi,'(a)') 'array 2'
4460 do k=1,koll
4461 if(itpr(k).gt.0)then
4462 write(ifhi,'(2e11.3)')coord(1,k)*cos(phi)+coord(2,k)*sin(phi)
4463 * , -coord(1,k)*sin(phi)+coord(2,k)*cos(phi)
4464 endif
4465 enddo
4466 write(ifhi,'(a)') ' endarray'
4467 write(ifhi,'(a)') 'closehisto'
4468 endif
4469 if(r1.ne.0.0)then
4470 write(ifhi,'(a)') 'plot 0-'
4471 write(ifhi,'(a)') '!----------------------------------'
4472 write(ifhi,'(a)') '! hard spheres '
4473 write(ifhi,'(a)') '!----------------------------------'
4474 write(ifhi,'(a)') 'openhisto name stc1 htyp lyu'
4475 write(ifhi,'(a)') 'array 2'
4476 do j=-50,50
4477 phi=j/50.*pi*0.55
4478 write(ifhi,'(2e11.3)')r1*cos(phi)-b,r1*sin(phi)
60ed90b3 4479 enddo
9ef1c2d9 4480 write(ifhi,'(a)') ' endarray'
4481 write(ifhi,'(a)') 'closehisto'
60ed90b3 4482 endif
9ef1c2d9 4483 if(r2.ne.0.0)then
4484 write(ifhi,'(a)') 'plot 0-'
4485 write(ifhi,'(a)') 'openhisto name stc1 htyp lyu'
4486 write(ifhi,'(a)') 'array 2'
4487 do j=-50,50
4488 phi=j/50.*pi*0.55
4489 write(ifhi,'(2e11.3)')-r1*cos(phi)+b,r1*sin(phi)
60ed90b3 4490 enddo
9ef1c2d9 4491 write(ifhi,'(a)') ' endarray'
4492 write(ifhi,'(a)') 'closehisto'
60ed90b3 4493 endif
4494
9ef1c2d9 4495 write(ifhi,'(a)') 'plot 0'
4496
4497 !........................................................................................
4498 if(ioclude.le.1)return
4499 !........................................................................................
4500 delrap=2*rapmax/float(myy)
4501 do m=1,myy
4502 yy(m)=0
4503 enddo
4504 do n=1,nptl
4505 if(dezptl(n).lt.1e3.and.n.le.maxfra.and.istptl(n).eq.2)then
4506 routp=-sin(phievt)*xptl(n)+cos(phievt)*yptl(n)
4507 rinp = cos(phievt)*xptl(n)+sin(phievt)*yptl(n)
4508 if(abs(rinp).le.1.and.abs(routp).le.1.)then
4509 rapx=dezptl(n)
4510 eco=0
4511 amt=pptl(5,n)**2+pptl(1,n)**2+pptl(2,n)**2
4512 if(amt.gt.0..and.pptl(4,n)+abs(pptl(3,n)).gt.0.d0)then
4513 amt=sqrt(amt)
4514 rap=sign(1.,pptl(3,n))*alog((pptl(4,n)+abs(pptl(3,n)))/amt)
4515 eco=amt*cosh(rap-rapx)
4516 endif
4517 m=(rapx+rapmax)/delrap+1
4518 if(m.gt.myy)m=myy
4519 yy(m)=yy(m)+eco
60ed90b3 4520 endif
4521 endif
4522 enddo
9ef1c2d9 4523 write(ifhi,'(a)')'!---------------------------------------------'
4524 write(ifhi,'(a)')'! core segment energy per d[c]dxdy '
4525 write(ifhi,'(a)')'! vs space-time rapidity rapx '
4526 write(ifhi,'(a)')'! (same as histogram rapx eco... in optns) '
4527 write(ifhi,'(a)')'!---------------------------------------------'
4528 write(ifhi,'(a)') '!newpage'
4529 write(ifhi,'(a)') 'openhisto name rapx'
4530 write(ifhi,'(a)') 'htyp lin xmod lin ymod lin'
4531 write(ifhi,'(a,2f7.3)') 'xrange ',-rapmax,rapmax
4532 write(ifhi,'(a)') 'yrange 0 auto '
4533 write(ifhi,'(a)') 'txt "title initial energy "'
4534 write(ifhi,'(a,f4.1,a)')'text 0.05 0.70 "x=0"'
4535 write(ifhi,'(a,f4.1,a)')'text 0.05 0.60 "y=0"'
60ed90b3 4536 write(ifhi,'(a,f4.1,a,f4.1,a)')'text 0.75 0.90 "'//cbim//'"'
9ef1c2d9 4537 write(ifhi,'(a)') 'txt "xaxis space-time rapidity [c] "'
4538 write(ifhi,'(a)') 'txt "yaxis dE/d[c]dxdy "'
4539 write(ifhi,'(a)') 'array 2'
4540 do m=1,myy
4541 write(ifhi,'(2e11.3)')-rapmax+(m-0.5)*delrap, yy(m)/4./delrap
4542 enddo
4543 write(ifhi,'(a)') ' endarray closehisto plot 0-'
4544 !........................................................................................
4545 delrap=2*rapmax/float(myy)
4546 do m=1,myy
4547 yy(m)=0
4548 enddo
4549 do n=1,nptl
4550 if(dezptl(n).lt.1e3.and.n.le.maxfra.and.istptl(n)/2.eq.0)then
4551 routp=-sin(phievt)*xptl(n)+cos(phievt)*yptl(n)
4552 rinp = cos(phievt)*xptl(n)+sin(phievt)*yptl(n)
4553 if(abs(rinp).le.1.and.abs(routp).le.1.)then
4554 rapx=dezptl(n)
4555 eco=0
4556 amt=pptl(5,n)**2+pptl(1,n)**2+pptl(2,n)**2
4557 if(amt.gt.0..and.pptl(4,n)+abs(pptl(3,n)).gt.0.d0)then
4558 amt=sqrt(amt)
4559 rap=sign(1.,pptl(3,n))*alog((pptl(4,n)+abs(pptl(3,n)))/amt)
4560 eco=amt*cosh(rap-rapx)
4561 endif
4562 m=(rapx+rapmax)/delrap+1
4563 if(m.ge.1.and.m.le.myy)yy(m)=yy(m)+eco
60ed90b3 4564 endif
4565 endif
4566 enddo
9ef1c2d9 4567 write(ifhi,'(a)')'!---------------------------------------------'
4568 write(ifhi,'(a)')'! corona segment energy per d[c]dxdy '
4569 write(ifhi,'(a)')'! vs space-time rapidity rapx '
4570 write(ifhi,'(a)')'! (same as histogram rapx eco... in optns) '
4571 write(ifhi,'(a)')'!---------------------------------------------'
4572 write(ifhi,'(a)') 'openhisto name rapx'
4573 write(ifhi,'(a)') 'htyp lin xmod lin ymod lin'
4574 write(ifhi,'(a,2f7.3)') 'xrange ',-rapmax,rapmax
4575 write(ifhi,'(a)') 'yrange 0 auto '
4576 write(ifhi,'(a)') 'txt "title initial energy "'
4577 write(ifhi,'(a)') 'txt "xaxis space-time rapidity [c] "'
4578 write(ifhi,'(a)') 'txt "yaxis dE/d[c]dxdy "'
4579 write(ifhi,'(a)') 'array 2'
4580 do m=1,myy
4581 write(ifhi,'(2e11.3)')-rapmax+(m-0.5)*delrap, yy(m)/4./delrap
4582 enddo
4583 write(ifhi,'(a)') ' endarray closehisto plot 0-'
60ed90b3 4584 call xEiniEta(1)
9ef1c2d9 4585 write(ifhi,'(a)') 'plot 0'
4586 !........................................................................................
4587 delrad=2*radmax/float(mrr)
4588 do m=1,mrr
4589 rr(m)=0
4590 enddo
4591 do n=1,nptl
4592 if(dezptl(n).lt.1e3.and.n.le.maxfra.and.istptl(n).eq.2)then
4593 routp=-sin(phievt)*xptl(n)+cos(phievt)*yptl(n)
4594 rinp = cos(phievt)*xptl(n)+sin(phievt)*yptl(n)
4595 rapx=dezptl(n)
4596 if(abs(rapx).le.1.and.abs(routp).le.1.)then
4597 eco=0
4598 amt=pptl(5,n)**2+pptl(1,n)**2+pptl(2,n)**2
4599 if(amt.gt.0..and.pptl(4,n)+abs(pptl(3,n)).gt.0.d0)then
4600 amt=sqrt(amt)
4601 rap=sign(1.,pptl(3,n))*alog((pptl(4,n)+abs(pptl(3,n)))/amt)
4602 eco=amt*cosh(rap-rapx)
4603 endif
4604 m=(rinp+radmax)/delrad+1
4605 if(m.gt.mrr)m=mrr
4606 rr(m)=rr(m)+eco
60ed90b3 4607 endif
4608 endif
4609 enddo
9ef1c2d9 4610 write(ifhi,'(a)')'!---------------------------------------------'
4611 write(ifhi,'(a)')'! core segment energy per d[c]dxdy vs x '
4612 write(ifhi,'(a)')'! (same as histogram rinp eco... in optns) '
4613 write(ifhi,'(a)')'!---------------------------------------------'
4614 write(ifhi,'(a)') '!newpage'
4615 write(ifhi,'(a)') 'openhisto name rapx'
4616 write(ifhi,'(a)') 'htyp lin xmod lin ymod lin'
4617 write(ifhi,'(a,2f7.3)') 'xrange ',-radmax,radmax
4618 write(ifhi,'(a)') 'yrange 0 auto '
4619 write(ifhi,'(a)') 'txt "title initial energy "'
4620 write(ifhi,'(a,f4.1,a)')'text 0.05 0.70 "[c]=0"'
4621 write(ifhi,'(a,f4.1,a)')'text 0.05 0.60 "y=0"'
60ed90b3 4622 write(ifhi,'(a,f4.1,a,f4.1,a)')'text 0.75 0.90 "'//cbim//'"'
9ef1c2d9 4623 write(ifhi,'(a)') 'txt "xaxis x (fm)"'
4624 write(ifhi,'(a)') 'txt "yaxis dE/d[c]dxdy "'
4625 write(ifhi,'(a)') 'array 2'
4626 do m=1,mrr
4627 write(ifhi,'(2e11.3)')-radmax+(m-0.5)*delrad, rr(m)/4./delrad
4628 enddo
4629 write(ifhi,'(a)') ' endarray closehisto plot 0-'
4630 !........................................................................................
4631 delrad=2*radmax/float(mrr)
4632 do m=1,mrr
4633 rr(m)=0
4634 enddo
4635 do n=1,nptl
4636 if(dezptl(n).lt.1e3.and.n.le.maxfra.and.istptl(n)/2.eq.0)then
4637 routp=-sin(phievt)*xptl(n)+cos(phievt)*yptl(n)
4638 rinp = cos(phievt)*xptl(n)+sin(phievt)*yptl(n)
4639 rapx=dezptl(n)
4640 if(abs(rapx).le.1.and.abs(routp).le.1.)then
4641 eco=0
4642 amt=pptl(5,n)**2+pptl(1,n)**2+pptl(2,n)**2
4643 if(amt.gt.0..and.pptl(4,n)+abs(pptl(3,n)).gt.0.d0)then
4644 amt=sqrt(amt)
4645 rap=sign(1.,pptl(3,n))*alog((pptl(4,n)+abs(pptl(3,n)))/amt)
4646 eco=amt*cosh(rap-rapx)
4647 endif
4648 m=(rinp+radmax)/delrad+1
4649 if(m.gt.mrr)m=mrr
4650 rr(m)=rr(m)+eco
60ed90b3 4651 endif
4652 endif
4653 enddo
9ef1c2d9 4654 write(ifhi,'(a)')'!---------------------------------------------'
4655 write(ifhi,'(a)')'! corona segment energy per d[c]dxdy vs x '
4656 write(ifhi,'(a)')'! (same as histogram rinp eco... in optns) '
4657 write(ifhi,'(a)')'!---------------------------------------------'
4658 write(ifhi,'(a)') 'openhisto name rapx'
4659 write(ifhi,'(a)') 'htyp lin xmod lin ymod lin'
4660 write(ifhi,'(a)') 'array 2'
4661 do m=1,mrr
4662 write(ifhi,'(2e11.3)')-radmax+(m-0.5)*delrad, rr(m)/4./delrad
4663 enddo
4664 write(ifhi,'(a)') ' endarray closehisto plot 0-'
60ed90b3 4665 call xEiniX(1)
9ef1c2d9 4666 write(ifhi,'(a)') 'plot 0'
4667 !........................................................................................
4668 delrad=2*radmax/float(mrr)
4669 do m=1,mrr
4670 rr(m)=0
4671 enddo
4672 do n=1,nptl
4673 if(dezptl(n).lt.1e3.and.n.le.maxfra.and.istptl(n).eq.2)then
4674 routp=-sin(phievt)*xptl(n)+cos(phievt)*yptl(n)
4675 rinp = cos(phievt)*xptl(n)+sin(phievt)*yptl(n)
4676 rapx=dezptl(n)
4677 if(abs(rapx).le.1.and.abs(rinp).le.1.)then
4678 eco=0
4679 amt=pptl(5,n)**2+pptl(1,n)**2+pptl(2,n)**2
4680 if(amt.gt.0..and.pptl(4,n)+abs(pptl(3,n)).gt.0.d0)then
4681 amt=sqrt(amt)
4682 rap=sign(1.,pptl(3,n))*alog((pptl(4,n)+abs(pptl(3,n)))/amt)
4683 eco=amt*cosh(rap-rapx)
4684 endif
4685 m=(routp+radmax)/delrad+1
4686 if(m.gt.mrr)m=mrr
4687 rr(m)=rr(m)+eco
60ed90b3 4688 endif
4689 endif
4690 enddo
9ef1c2d9 4691 write(ifhi,'(a)')'!---------------------------------------------'
4692 write(ifhi,'(a)')'! core segment energy per d[c]dxdy vs y '
4693 write(ifhi,'(a)')'! (same as histogram routp eco... in optns) '
4694 write(ifhi,'(a)')'!---------------------------------------------'
4695 write(ifhi,'(a)') '!newpage'
4696 write(ifhi,'(a)') 'openhisto name rout'
4697 write(ifhi,'(a)') 'htyp lin xmod lin ymod lin'
4698 write(ifhi,'(a,2f7.3)') 'xrange ',-radmax,radmax
4699 write(ifhi,'(a)') 'yrange 0 auto '
4700 write(ifhi,'(a)') 'txt "title initial energy "'
4701 write(ifhi,'(a,f4.1,a)')'text 0.05 0.70 "[c]=0"'
4702 write(ifhi,'(a,f4.1,a)')'text 0.05 0.60 "x=0"'
60ed90b3 4703 write(ifhi,'(a,f4.1,a,f4.1,a)')'text 0.75 0.90 "'//cbim//'"'
9ef1c2d9 4704 write(ifhi,'(a)') 'txt "xaxis y (fm)"'
4705 write(ifhi,'(a)') 'txt "yaxis dE/d[c]dxdy "'
4706 write(ifhi,'(a)') 'array 2'
4707 do m=1,mrr
4708 write(ifhi,'(2e11.3)')-radmax+(m-0.5)*delrad, rr(m)/4./delrad
4709 enddo
4710 write(ifhi,'(a)') ' endarray closehisto plot 0-'
4711 !........................................................................................
4712 delrad=2*radmax/float(mrr)
4713 do m=1,mrr
4714 rr(m)=0
4715 enddo
4716 do n=1,nptl
4717 if(dezptl(n).lt.1e3.and.n.le.maxfra.and.istptl(n)/2.eq.0)then
4718 routp=-sin(phievt)*xptl(n)+cos(phievt)*yptl(n)
4719 rinp = cos(phievt)*xptl(n)+sin(phievt)*yptl(n)
4720 rapx=dezptl(n)
4721 if(abs(rapx).le.1.and.abs(rinp).le.1.)then
4722 eco=0
4723 amt=pptl(5,n)**2+pptl(1,n)**2+pptl(2,n)**2
4724 if(amt.gt.0..and.pptl(4,n)+abs(pptl(3,n)).gt.0.d0)then
4725 amt=sqrt(amt)
4726 rap=sign(1.,pptl(3,n))*alog((pptl(4,n)+abs(pptl(3,n)))/amt)
4727 eco=amt*cosh(rap-rapx)
4728 endif
4729 m=(routp+radmax)/delrad+1
4730 if(m.gt.mrr)m=mrr
4731 rr(m)=rr(m)+eco
60ed90b3 4732 endif
4733 endif
4734 enddo
9ef1c2d9 4735 write(ifhi,'(a)')'!---------------------------------------------'
4736 write(ifhi,'(a)')'! corona segment energy per d[c]dxdy vs y '
4737 write(ifhi,'(a)')'! (same as histogram routp eco... in optns) '
4738 write(ifhi,'(a)')'!---------------------------------------------'
4739 write(ifhi,'(a)') 'openhisto name rout'
4740 write(ifhi,'(a)') 'htyp lin xmod lin ymod lin'
4741 write(ifhi,'(a)') 'array 2'
4742 do m=1,mrr
4743 write(ifhi,'(2e11.3)')-radmax+(m-0.5)*delrad, rr(m)/4./delrad
4744 enddo
4745 write(ifhi,'(a)') ' endarray closehisto plot 0-'
60ed90b3 4746 call xEiniY(1)
9ef1c2d9 4747 write(ifhi,'(a)') 'plot 0'
4748
4749 end
4750
4751c------------------------------------------------------------------------------
4752 subroutine xEini(ii)
4753c------------------------------------------------------------------------------
4754 include 'epos.inc'
4755 include 'epos.inchy'
4756 common/cen/ncentr
4757
4758 entry xEiniX(ii)
4759 write(ifhi,'(a)') '!----------------------------------------'
4760 write(ifhi,'(a,i3)') '! hydro initial energy vs x '
4761 write(ifhi,'(a)') '!----------------------------------------'
4762 write(ifhi,'(a)')'openhisto array 2'
4763 do nr=nradhy,2,-1
4764 write(ifhi,'(2e13.5)')
4765 . -radhy(nr),epsii(ncentr,ii,1,nr)*tauhoc(ncentr,1)
4766 enddo
4767 do nr=1,nradhy
4768 write(ifhi,'(2e13.5)')
4769 . radhy(nr),epsii(ncentr,ii,1,nr)*tauhoc(ncentr,1)
4770 enddo
4771 write(ifhi,'(a)') 'endarray closehisto '
4772 return
60ed90b3 4773
9ef1c2d9 4774 entry xEiniY(ii)
4775 write(ifhi,'(a)') '!----------------------------------------'
4776 write(ifhi,'(a,i3)') '! hydro initial energy vs y '
4777 write(ifhi,'(a)') '!----------------------------------------'
4778 write(ifhi,'(a)')'openhisto array 2'
4779 do nr=nradhy,2,-1
4780 write(ifhi,'(2e13.5)')
4781 . -radhy(nr),epsii(ncentr,ii,nphihy,nr)*tauhoc(ncentr,1)
4782 enddo
4783 do nr=1,nradhy
4784 write(ifhi,'(2e13.5)')
4785 . radhy(nr),epsii(ncentr,ii,nphihy,nr)*tauhoc(ncentr,1)
4786 enddo
4787 write(ifhi,'(a)') 'endarray closehisto '
4788 return
4789
4790 entry xEiniEta(ii)
4791 write(ifhi,'(a)') '!----------------------------------------'
4792 write(ifhi,'(a,i3)') '! hydro initial energy vs y '
4793 write(ifhi,'(a)') '!----------------------------------------'
4794 write(ifhi,'(a)')'openhisto array 2'
4795 do neta=netahy,2,-1
4796 write(ifhi,'(2e13.5)')
4797 . -etahy(neta),epsii(ncentr,neta,1,1)*tauhoc(ncentr,1)
4798 enddo
4799 do neta=1,netahy
4800 write(ifhi,'(2e13.5)')
4801 . etahy(neta),epsii(ncentr,neta,1,1)*tauhoc(ncentr,1)
4802 enddo
4803 write(ifhi,'(a)') 'endarray closehisto '
4804 return
4805
4806 end
4807
4808c------------------------------------------------------------------------------
4809 subroutine hnbcor(mode)
4810c------------------------------------------------------------------------------
60ed90b3 4811c determines(mode=1) and plots (mode=2) two particle correlations
9ef1c2d9 4812c for the configurations /confg/
4813c------------------------------------------------------------------------------
4814 include 'epos.inc'
4815 integer bns
4816 parameter (maxp=500,bns=100)
4817 common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
4818 dimension zwei(bns),zz(bns)!,phi(bns),yy(bns)
4819 common/cor/wert(bns),cwert(bns)
4820 character*6 cen,cvol
4821
4822 if(mode.eq.1)then
4823
4824 nctcor=nctcor+1
4825
4826 if(nctcor.eq.1)then
4827 do nn=1,bns
4828 wert(nn)=0
4829 cwert(nn)=0
4830 enddo
4831 endif
4832
4833 ll=0
4834
4835 do ii=1,np-1
4836 do jj=ii+1,np
4837
4838 ll=ll+1
4839 prod=0
4840
4841 do kk=1,3
4842 prod=prod+pcm(kk,ii)*pcm(kk,jj)
4843 enddo
4844
4845 cs=prod/pcm(5,ii)/pcm(5,jj)
4846
4847 if(abs(cs).gt.1.)then
4848 cs=aint(cs)
60ed90b3 4849 ang=acos(cs)
9ef1c2d9 4850 else
4851 ang=acos(cs)
4852 endif
4853
4854 if(cs.eq.1.)then
4855 nk=bns
4856 nw=1
4857 elseif(ang.eq.pi)then
4858 nk=1
4859 nw=bns
4860 else
60ed90b3 4861 nw=1+aint(ang/pi*bns)
4862 nk=1+aint((cs+1.)/2.*bns)
9ef1c2d9 4863 endif
4864 nw=min(nw,bns)
4865 nk=min(nk,bns)
4866
4867 wert(nw)=wert(nw)+1
4868 cwert(nk)=cwert(nk)+1
4869
4870 enddo
4871 enddo
4872
4873 elseif(mode.eq.2)then
4874
4875 do mm=1,bns
4876c phi(mm)=.5*pi/bns+(mm-1)*pi/bns
4877 zwei(mm)=.5*2./bns+(mm-1)*2./bns-1.
4878c yy(mm)=wert(mm)/nctcor
4879 zz(mm)=cwert(mm)/nctcor
4880 enddo
4881
4882 write(cen,'(f6.1)')tecm
4883 write(cvol,'(f6.1)')volu
4884
4885 write(ifhi,'(a)') 'newpage zone 1 1 1 openhisto'
4886 write(ifhi,'(a)') 'htyp lin xmod lin ymod lin'
4887 write(ifhi,'(a)') 'xrange -1 1'
4888 write(ifhi,'(a)') 'text 0 0 "xaxis cosine"'
4889 write(ifhi,'(a)') 'text 0 0 "yaxis counts"'
4890 write(ifhi,'(a)') 'text 0.4 0.91 "V='//cvol//'"'
4891 write(ifhi,'(a)') 'text 0.15 0.91 "E='//cen//'"'
4892 write(ifhi,'(a)') 'array 2'
4893 do mm=1,bns
4894 write(ifhi,'(2e13.5)')zwei(mm),zz(mm)
4895 enddo
4896 write(ifhi,'(a)') ' endarray'
4897 write(ifhi,'(a)') 'closehisto plot 0'
4898
4899 endif
4900
4901 return
4902 end
4903
4904c----------------------------------------------------------------------
4905 subroutine hnbfac(faclog)
4906c----------------------------------------------------------------------
4907c returns log of factor for phase space weight
4908c faclog= log{ prod[ m_i*(2*s_i+1)*volu/4/pi**3/hquer**3/(n_l+1-i) ] }
4909c ~~~~~~~~~~~~~~
4910c corresponds to eq. 67 of micro paper :
4911c Cvol * Cdeg * Cident * Cmicro
4912c the factors partly compensate each other !!
4913c----------------------------------------------------------------------
4914 include 'epos.inc'
4915 parameter(maxp=500)
4916 common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
4917c integer ii(maxp)
4918 common /clatt/nlattc,npmax
4919
4920 faclog=0
4921
4922c sum_i log m_i*g_i*volu/4/pi**3/hquer**3/(n_l+1-i) -> flog
4923 flog=0
4924 do i=1,np
4925 call hnbfaf(i,gg,am,ioma)
4926 flog=flog+alog(gg*am*volu/4/pi**3/hquer**3/(nlattc+1-i))
4927 enddo
4928 faclog=faclog+flog
60ed90b3 4929
9ef1c2d9 4930 return
4931 end
4932
4933c----------------------------------------------------------------------
4934 subroutine hnbfaf(i,gg,am,ioma)
4935c----------------------------------------------------------------------
4936c returns degeneracy gg and mass am for factor f5
4937c----------------------------------------------------------------------
4938 common/metr1/iospec,iocova,iopair,iozero,ioflac,iomom
4939 parameter(maxp=500)
4940 common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
4941 common/drop6/tecm,volu
4942
4943 ioma=5
4944
4945 hquer=0.197327
4946 cc=0.216416
4947 dd=13.773935
4948
4949 call hnbspi(ident(i),spideg)
4950 gg=spideg
4951
4952 if(ioma.eq.1)am=amass(i)
4953 if(ioma.eq.2)am=tecm/np
4954 if(ioma.eq.3)am=1
4955 if(ioma.eq.4)
4956 *am=cc*dd*gg**(-0.25)*(tecm/volu)**(0.25)*hquer**(0.75)
4957 if(ioma.eq.5)am=0.5 ! 1GeV / 2 (dimension energy)
4958 if(iocova.eq.2)then
4959 am=0.5 ! 1 / 2 (no dimension)
4960 ioma=0
4961 endif
4962 return
4963 end
4964
4965cc----------------------------------------------------------------------
60ed90b3 4966c subroutine hnbids(jc,ids,iwts,i)
9ef1c2d9 4967cc----------------------------------------------------------------------
4968cc returns i id-codes ids() corr to jc and their weights iwts()
4969cc----------------------------------------------------------------------
4970c parameter (mxids=200,mspecs=56,nflav=6)
4971c common/metr1/iospec,iocova,iopair,iozero,ioflac,iomom
4972c common/cflac/ifok(nflav,mspecs),ifoa(nflav)
4973c common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
4974c integer ids(mxids),jc(nflav,2),iwts(mxids),jc1mi2(nflav)
4975c
4976c if(nspecs+1.gt.mxids)call utstop('hnbids: mxids too small&')
4977c
4978c do n=1,nflav
4979c jc1mi2(n)=jc(n,1)-jc(n,2)
4980c enddo
4981c
4982c i=0
4983c
4984c do n=1,nflav
4985c if(jc1mi2(n).ne.0)goto1
4986c enddo
4987c i=i+1
4988c ids(i)=0
4989c iwts(i)=iozero
60ed90b3 4990c 1 continue
9ef1c2d9 4991c
4992c do j=1,nspecs
4993c do n=1,nflav
4994c if(jc1mi2(n).ne.ifok(n,j))goto2
4995c enddo
4996c i=i+1
4997c ids(i)=ispecs(j)
4998c iwts(i)=1
60ed90b3 4999c 2 continue
9ef1c2d9 5000c enddo
5001c
5002c return
5003c end
5004c
5005c----------------------------------------------------------------------
5006 subroutine hnbiiw(x,f,df)
5007c----------------------------------------------------------------------
5008c returns fctn value and first derivative at x of the
60ed90b3 5009c i-th integrated weight fctn minus random number
9ef1c2d9 5010c for the asympotic phase space integral.
5011c input:
5012c x: x-value
5013c iii: i-value (via common/ciiw/iii,rrr)
5014c rrr: random number ( " )
5015c output:
5016c f: fctn value
5017c df: first derivative
5018c----------------------------------------------------------------------
5019 common/ciiw/iii,rrr
5020 i=iii
5021 f=x**(2*i-2)*(i-(i-1)*x**2)-rrr
5022 df=2*i*(i-1)*(x**(2*i-3)-x**(2*i-1))
5023 return
5024 end
5025
5026c----------------------------------------------------------------------
5027 subroutine hnbini(iret)
5028c----------------------------------------------------------------------
5029c generates initial configuration
5030c----------------------------------------------------------------------
5031 include 'epos.inc'
5032 parameter(maxp=500)
5033 common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
60ed90b3 5034 parameter (mspecs=56)
9ef1c2d9 5035 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
5036 common/crnoz/rnoz(maxp-1)
5037 common/citer/iter,itermx
60ed90b3 5038 common/cfact/faclog
9ef1c2d9 5039 common/chnbin/nump,ihadro(maxp)
5040 common /clatt/nlattc,npmax
5041 parameter(maxit=50000)
5042 common/count/nacc,nrej,naccit(maxit),nptot,npit(maxit)
5043 common/ctaue/taue
5044 if(ish.ge.7)write(ifch,*)('-',i=1,10)
5045 *,' entry sr hnbini ',('-',i=1,30)
5046
5047 iter=0
5048
5049 nlattc=8*(tecm/10)*(1/(tecm/volu))**0.2*(nspecs/3.)**0.3
5050 if(aspecs(1).lt.0.010)nlattc=nlattc*3
5051 nlattc=max(nlattc,20)
5052 if(iternc.lt.0)iternc=1.500*nlattc
5053
5054 itermx=iterma
5055 if(itermx.le.0)then
5056 e=tecm/volu
5057 b=1.1*(e+0.33)**0.66
5058 a=13.*(e+0.13)**(-0.65)
5059 tm=34.*(e+0.65)**(-0.61)
5060 t=a+b*volu
5061 taue=max(t,tm)
5062 itermx=(-itermx)*taue
5063 else
5064 taue=0
5065 endif
5066 if(ish.ge.5)write(ifch,*)'itermx:',itermx
5067
5068 if(iternc.gt.itermx/2)iternc=itermx/2
5069
5070 if(ioinco.eq.0)then
5071 call hnbmin(keu,ked,kes,kec)
5072 if(iograc.eq.1)call hgcaaa
5073 elseif(ioinco.ge.1)then
5074 nk=keu+ked+ked+kec
5075 if(tecm.lt.1.5.and.nk.eq.0)then
5076 call hnbmin(keu,ked,kes,kec)
5077 elseif(tecm.lt.2.0.and.nk.ne.0)then
5078 call hnbmin(keu,ked,kes,kec)
60ed90b3 5079 else
9ef1c2d9 5080 call hgcaaa
5081 call hgcnbi(iret)
5082 if(iret.eq.1)then
5083 call hnbmin(keu,ked,kes,kec)
5084 if(ish.ge.5)then
5085 write(ifch,*)'hadron set from hnbmin:'
5086 write(ifch,'(10i6)')(ihadro(k),k=1,nump)
5087 endif
5088 endif
5089 endif
5090 endif
5091
5092 np=nump+nadd
5093 if(np.gt.maxp)stop'np too large'
5094
5095 nlattc=max(nlattc,1+int(np*1.2))
5096c print *,np,nlattc
5097 if(nlattc-1.gt.maxp)stop'maxp too small'
5098
5099 do i= 1, nlattc-1
5100 rnoz(i)=rangen()
5101 enddo
5102
5103 if(nadd.gt.0)then
5104 do i=nump+1,np
5105 ihadro(i)=110
5106 enddo
5107 endif
5108
5109 do i=1,np
5110 ident(i)=ihadro(i)
5111 amass(i)=-1
5112 do j=1,nspecs
5113 if(ident(i).eq.ispecs(j))then
5114 amass(i)=aspecs(j)
5115 goto1
5116 endif
5117 enddo
5118 1 continue
5119 if(amass(i).lt.0.)
5120 *call utstop('hnbini: invalid particle species&')
5121 enddo
5122
5123 if(iocova.eq.1)call hnbody !covariant
5124 if(iocova.eq.2)call hnbodz !noncovariant
5125 call hnbfac(faclog)
5126 wtlog=wtxlog+faclog
5127
5128 iret=0
5129 if(wtlog.le.-0.99999E+35)then
5130 if(ish.ge.1) then
5131 call utmsg('hnbini')
5132 write(ifch,*)'***** wtlog for initl config < -1E+35'
5133 write(ifch,*)'***** wtlog:',wtlog
5134 write(ifch,*)'***** droplet mass:',tecm
5135 write(ifch,*)'***** flavour:'
5136 write(ifch,*)'*****',keu,ked,kes,kec,keb,ket
5137 write(ifch,'(1x,a,1x,10i6)')'*****',(ihadro(i),i=1,nump)
5138 call utmsgf
5139 endif
5140 iret=1
5141 goto1000
5142 endif
5143
5144 if(ish.ge.7)then
5145 write(ifch,*)'initial configuration:'
5146 call hnbwri
5147 endif
5148
5149 itermx=iterma
5150 if(itermx.le.0)then
5151 e=tecm/volu
5152 b=1.1*(e+0.33)**0.66
5153 a=13.*(e+0.13)**(-0.65)
5154 tm=34.*(e+0.65)**(-0.61)
5155 t=a+b*volu
5156 taue=max(t,tm)
5157 itermx=(-itermx)*taue
5158 else
5159 taue=0
5160 endif
5161 if(ish.ge.5)write(ifch,*)'itermx:',itermx
5162
5163 if(iternc.gt.itermx/2)iternc=itermx/2
5164
5165 nacc=0
5166 nrej=0
5167
5168 1000 continue
5169
5170 if(ish.ge.7)write(ifch,*)('-',i=1,30)
5171 *,' exit sr hnbini ',('-',i=1,10)
5172
5173 return
5174 end
5175
5176cc----------------------------------------------------------------------
5177c subroutine hnbint(tecmx,nevtxx,nsho)
5178cc----------------------------------------------------------------------
5179cc calculates phase space integral of the minimal hadron configuration
5180cc compatibel with keu, ked, kes, kec for a total mass of tecm
5181cc by employing nevtxx simulations and printing results every nsho events
5182cc----------------------------------------------------------------------
5183c include 'epos.inc'
5184c parameter(maxp=500)
5185c common/chnbin/nump,ihadro(maxp)
5186c common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
5187c tecm=tecmx
5188c write(ifch,*)
5189c write(ifch,'(1x,a,4i3,a,f10.4)')'droplet id:',keu,ked,kes,kec
5190c *,' droplet mass:',tecm
5191c call hnbmin(keu,ked,kes,kec)
5192c np=nump
5193c if(np.gt.maxp)stop'np too large'
5194c do i=1,np
5195c id=ihadro(i)
5196c if(id.eq.30)then
5197c call idmass(2130,am)
5198c amass(i)=2*am-0.100
5199c else
5200c call idmass(id,amass(i))
5201c endif
5202c enddo
5203c wts=0
5204c n=0
5205c do ll=1,nevtxx
5206c n=n+1
5207c if(iocova.eq.1)call hnbody
5208c if(iocova.eq.2)call hnbodz
5209c wt=exp(wtxlog)
5210c wts=wts+wt
5211c if(mod(n,nsho).eq.0)
5212c *write(ifch,'(a,i7,3x,a,e13.6,3x,a,e13.6,3x,a,e13.6)')
5213c *'n:',n,'weight:',wt,'wts/n:',wts/n,'error:',wts/n/sqrt(1.*n)
5214c enddo
5215c return
60ed90b3 5216c end
9ef1c2d9 5217cc----------------------------------------------------------------------
5218 subroutine hnbmet
5219c----------------------------------------------------------------------
5220c change (or not) configuration via metropolis
5221c configuration=np,tecm,amass(),ident(),pcm(),volu,wtlog
5222c (common /confg/)
5223c nlattc (in /clatt/) must be set before calling this routine
5224c----------------------------------------------------------------------
5225 include 'epos.inc'
5226 parameter(maxp=500)
5227 common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
5228 common/crnoz/rnoz(maxp-1)
5229 real rnozo(maxp-1)
60ed90b3 5230 common/cfact/faclog
9ef1c2d9 5231 dimension amasso(maxp),idento(maxp),pcmo(5,maxp)
5232 integer jc(nflav,2),jc1(nflav,2),jc2(nflav,2)
5233 common/citer/iter,itermx
60ed90b3 5234 parameter (mspecs=56)
9ef1c2d9 5235 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
5236 parameter (literm=500)
5237 common/cmet/kspecs(mspecs),liter,lspecs(literm,mspecs)
5238 *,iterl(literm),iterc(literm)
5239c parameter (mxpair=mspecs**2*4)
5240 common /clatt/nlattc,npmax
5241 parameter (nhise=100)
5242 common/chise/hise(mspecs,nhise)
5243 integer id1old(2),id2old(2),id1new(2),id2new(2)
5244 parameter(maxit=50000)
5245 common/count/nacc,nrej,naccit(maxit),nptot,npit(maxit)
5246 if(ish.ge.7)then
5247 write(ifch,*)('-',i=1,10)
5248 *,' entry sr hnbmet ',('-',i=1,30)
5249 write(ifch,'(1x,a,i4)')'iteration:',iter
5250 endif
5251 if(mod(iter,iterpr).eq.0)write(ifmt,*)'iteration:',iter
5252 if(maxp.gt.np)then
5253 do n=np+1,maxp
5254 ident(n)=0
5255 enddo
5256 endif
5257
5258c for iter=1
5259c ----------
5260 if(iter.eq.1)then
5261 liter=1
5262 do i=1,nspecs
5263 kspecs(i)=0
5264 nptot=0
5265 do li=1,literm
5266 lspecs(li,i)=0
5267 enddo
5268 enddo
5269 do li=1,literm
5270 iterc(li)=0
5271 enddo
5272 do j=1,mspecs
5273 do i=1,nhise
5274 hise(j,i)=0
5275 enddo
5276 enddo
5277 call hnbzmu(-1)
5278 endif
60ed90b3 5279
9ef1c2d9 5280c remember old configuration
5281c --------------------------
5282 wtlo=wtlog
5283 wtlox=wtxlog
5284 faclo=faclog
5285 npo=np
5286 if(np-1.gt.0)then
5287 do i=1,np-1
5288 rnozo(i)=rnoz(i)
5289 enddo
5290 endif
5291 if(np.gt.0)then
5292 do i=1,np
5293 amasso(i)=amass(i)
5294 idento(i)=ident(i)
5295 do j=1,5
5296 pcmo(j,i)=pcm(j,i)
5297 enddo
5298 enddo
5299 endif
5300
5301c determine pair, construct new pair, update ident
5302c ------------------------------------------------
5303 if(iopair.eq.1)then
5304c (single pair method)
5305 call hnbpad(1,n1,n2,n3,n4,mm,jc)
5306 id1old(1)=ident(n1)
5307 id2old(1)=ident(n2)
5308 id1old(2)=0
5309 id2old(2)=0
5310 call hnbpaj(jc,iwpair,id1,id2)
5311 ident(n1)=id1
5312 ident(n2)=id2
5313 call hnbrmz
5314 id1new(1)=id1
5315 id2new(1)=id2
5316 id1new(2)=0
5317 id2new(2)=0
5318 xab=1
5319 xba=1
5320 nzold=0
5321 if(id1old(1).eq.0)nzold=nzold+1
5322 if(id2old(1).eq.0)nzold=nzold+1
5323 nznew=0
5324 if(id1new(1).eq.0)nznew=nznew+1
5325 if(id2new(1).eq.0)nznew=nznew+1
5326
5327c determine 2 pairs, construct 2 new pairs, update ident
5328c ------------------------------------------------------
5329 elseif(iopair.eq.2)then
5330c (double pair method)
5331 kkk=0
5332 25 call hnbpad(1,n1,n2,n3,n4,mm,jc)
5333 kkk=kkk+1
5334 id1old(1)=ident(n1)
5335 id2old(1)=ident(n2)
5336 call hnbpai(id1,id2,jc1)
5337 ident(n1)=id1
5338 ident(n2)=id2
5339 id1new(1)=id1
5340 id2new(1)=id2
5341 do i=1,nflav
5342 do j=1,2
5343 jc(i,j)=jc(i,j)-jc1(i,j)
5344 jc2(i,j)=jc(i,j)
5345 enddo
5346 enddo
5347 2 call hnbpad(2,n1,n2,n3,n4,mm,jc1)
5348 id1old(2)=ident(n3)
5349 id2old(2)=ident(n4)
5350 do i=1,nflav
5351 do j=1,2
5352 jc(i,j)=jc(i,j)+jc1(i,j)
5353 enddo
5354 enddo
5355 call hnbpaj(jc,iwpair,id1,id2)
5356 if(iwpair.eq.0)then
5357 do i=1,nflav
5358 do j=1,2
5359 jc(i,j)=jc2(i,j)
5360 enddo
5361 enddo
5362 if(ish.ge.7)write(ifch,*)'no pair possible'
5363 goto2
5364 endif
5365 ident(n3)=id1
5366 ident(n4)=id2
5367 id1new(2)=id1
5368 id2new(2)=id2
5369 call hnbrmz
5370 if(ish.ge.7)write(ifch,*)'wt-sum of 2. pairs (-->):',iwpair
5371 *,' chosen pair:',id1,id2
5372 call hnbpaj(jc1,iwpais,idum1,idum2)
5373 if(ish.ge.7)write(ifch,*)'wt-sum of 2. pairs (<--):',iwpais
5374 nzold=0
5375 if(id1old(1).eq.0)nzold=nzold+1
5376 if(id2old(1).eq.0)nzold=nzold+1
5377 if(id1old(2).eq.0)nzold=nzold+1
5378 if(id2old(2).eq.0)nzold=nzold+1
5379 if(ish.ge.7)write(ifch,*)'number of zeros (old):',nzold
5380 nznew=0
5381 if(id1new(1).eq.0)nznew=nznew+1
5382 if(id2new(1).eq.0)nznew=nznew+1
5383 if(id1new(2).eq.0)nznew=nznew+1
5384 if(id2new(2).eq.0)nznew=nznew+1
5385 if(ish.ge.7)write(ifch,*)'number of zeros (new):',nznew
5386 if(iorejz.eq.1.and.nzold.eq.4.and.nznew.eq.4.and.kkk.le.50)goto25
5387 xab=1./iwpair*iozero**nznew
5388 xba=1./iwpais*iozero**nzold
5389 if(ish.ge.7)write(ifch,*)'asymmetry factor:',xba/xab
5390 else
5391 call utstop('hnbmet: invalid choice for iopair&')
5392 endif
5393
5394c determine masses/momenta/weight of trial configuration
5395c ------------------------------------------------------
5396 if(np.ge.2)then
5397 do i=1,np
5398 amass(i)=-1
5399 do j=1,nspecs
5400 if(ident(i).eq.ispecs(j))then
5401 amass(i)=aspecs(j)
5402 goto1
5403 endif
5404 enddo
5405 1 continue
5406 if(amass(i).lt.0.)
5407 *call utstop('hnbmet: invalid particle species&')
5408 enddo
5409 keepr=0
60ed90b3 5410c-c call hnbolo(1000) !instead of "call hnbody" for testing
9ef1c2d9 5411 keepr=1
5412 if(iocova.eq.1)call hnbody
5413 if(iocova.eq.2)call hnbodz
5414 else
5415 wtxlog=-1e35
5416 endif
5417 call hnbfac(faclog)
5418 wtlog=wtxlog+faclog
5419 if(ish.ge.7)then
5420 write(ifch,*)'trial configuration:'
5421 call hnbwri
5422 endif
5423
5424c accept or not trial configuration (metropolis)
5425c ----------------------------------------------
5426 if(ish.ge.7)write(ifch,'(1x,a,4i5,a,4i5,a)')
5427 *'metropolis decision for '
5428 *,id1old(1),id2old(1),id1old(2),id2old(2),' --> '
5429 *,id1new(1),id2new(1),id1new(2),id2new(2),' :'
5430 iacc=0
5431 if(wtlog-wtlo.lt.30.)then
5432 q=exp(wtlog-wtlo)*xba/xab
5433 r=rangen()
60ed90b3 5434 if(r.le.q)iacc=1
9ef1c2d9 5435 if(ish.ge.7)write(ifch,*)'new weight / old weight:',q,' '
5436 *,'random number:',r
5437 else
5438 iacc=1
5439 if(ish.ge.7)write(ifch,*)'log new weight / old weight:'
5440 *,wtlog-wtlo
5441 endif
60ed90b3 5442 if(iacc.eq.1)then
9ef1c2d9 5443 if(ish.ge.7)write(ifch,*)'new configuration accepted'
5444 nacc=nacc+1
5445 naccit(iter)=1
5446 else
5447 if(ish.ge.7)write(ifch,*)'old configuration kept'
5448 nrej=nrej+1
5449 wtlog=wtlo
5450 wtxlog=wtlox
5451 faclog=faclo
5452 np=npo
5453 if(np-1.gt.0)then
5454 do i=1,np-1
5455 rnoz(i)=rnozo(i)
5456 enddo
5457 endif
5458 if(np.gt.0)then
5459 do i=1,np
5460 amass(i)=amasso(i)
5461 ident(i)=idento(i)
5462 do j=1,5
5463 pcm(j,i)=pcmo(j,i)
5464 enddo
5465 enddo
5466 endif
5467 endif
5468 if(ioobsv.eq.0)then
5469 npit(iter)=np
5470 if(iter.gt.iternc)nptot=nptot+np
5471 else
5472 npob=0
5473 do i=1,np
5474 if(ioobsv.eq.ident(i))npob=npob+1
5475 enddo
5476 npit(iter)=npob
5477 if(iter.gt.iternc)nptot=nptot+npob
5478 endif
5479 if(ish.ge.7)then
5480 write(ifch,*)'actual configuration:'
5481 call hnbwri
5482 if(ish.eq.27)stop'change this?????????????' !call hnbcor(1)
5483 endif
5484
5485c printout/return
5486c ---------------
5487 if(iosngl.ne.nrevt+1.and.iocite.ne.1)goto1000
5488 npmax=max(npmax,np)
5489 if(liter.le.literm)then
5490 iterc(liter)=iterc(liter)+1
5491 do i=1,np
5492 do j=1,nspecs
5493 if(ident(i).eq.ispecs(j))then
5494 lspecs(liter,j)=lspecs(liter,j)+1
5495 goto8
5496 endif
5497 enddo
5498 8 continue
5499 enddo
5500 if(mod(iter,iterpl).eq.0)then
5501 iterl(liter)=iter
5502 liter=liter+1
5503c if(liter.le.literm)then
5504c iterc(liter)=iterc(liter-1)
5505c do j=1,nspecs
5506c lspecs(liter,j)=lspecs(liter-1,j)
5507c enddo
60ed90b3 5508c endif
9ef1c2d9 5509 endif
5510 endif
5511 if(iter.le.iternc)return
5512
5513 do i=1,np
5514 call hnbzen(i) !fill energy histogram
5515 do j=1,nspecs
5516 if(ident(i).eq.ispecs(j))then
5517 kspecs(j)=kspecs(j)+1
5518 goto7
5519 endif
5520 enddo
5521 7 continue
5522 enddo
5523 call hnbzmu(1) !fill multiplicity histogram
5524
5525 if(iter.eq.itermx.and.npmax.ge.nlattc.and.ish.ge.1)then
5526 call utmsg('hnbmet')
5527 write(ifch,*)'***** nlattc too small'
5528 write(ifch,*)'nlattc:',nlattc,' npmax:',npmax
5529 call utmsgf
5530 endif
5531
55321000 continue
5533 if(ish.ge.7)then
5534 write(ifch,*)'accepted proposals:',nacc
5535 *,' rejected proposals:',nrej
5536 write(ifch,*)('-',i=1,30)
5537 *,' exit sr hnbmet ',('-',i=1,10)
5538 endif
5539 return
5540 end
5541
5542c----------------------------------------------------------------------
5543 subroutine hnbmin(keux,kedx,kesx,kecx)
5544c----------------------------------------------------------------------
5545c returns min hadron set with given u,d,s,c content
5546c input:
5547c keux: net u quark number
5548c kedx: net d quark number
5549c kesx: net s quark number
5550c kecx: net c quark number
5551c output (written to /chnbin/):
5552c nump: number of hadrons
5553c ihadro(n): hadron id for n'th hadron
5554c----------------------------------------------------------------------
5555 include 'epos.inc'
5556 parameter(maxp=500)
5557 common/chnbin/nump,ihadro(maxp)
5558 logical wri
5559 character f1*11
5560 wri=.false.
5561 if(ish.ge.7)wri=.true.
5562 if(wri)write(ifch,*)('-',i=1,10)
5563 *,' entry sr hnbmin ',('-',i=1,30)
5564
5565 nump=0
5566 f1='(4i3,i7,i6)'
5567 ke=iabs(keux+kedx+kesx+kecx)
60ed90b3 5568
9ef1c2d9 5569 if(keux+kedx+kesx+kecx.ge.0)then
5570 keu=keux
5571 ked=kedx
5572 kes=kesx
5573 kec=kecx
5574 isi=1
5575 else
5576 keu=-keux
5577 ked=-kedx
5578 kes=-kesx
5579 kec=-kecx
5580 isi=-1
5581 endif
5582 if(wri)write(ifch,'(4i3)')keux,kedx,kesx,kecx
5583 if(wri)write(ifch,'(4i3)')keu,ked,kes,kec
60ed90b3 5584
9ef1c2d9 5585c get rid of anti-c and c (140, 240, -140, -240)
5586 if(kec.ne.0)then
5587 10 continue
5588 if(kec.lt.0)then
5589 kec=kec+1
5590 if(keu.gt.ked)then
5591 keu=keu-1
5592 nump=nump+1
5593 ihadro(nump)=140
5594 if(wri)write(ifch,f1)keu,ked,kes,kec,nump,ihadro(nump)
5595 else
5596 ked=ked-1
5597 nump=nump+1
5598 ihadro(nump)=240
5599 if(wri)write(ifch,f1)keu,ked,kes,kec,nump,ihadro(nump)
5600 endif
5601 goto10
5602 endif
5603 11 continue
5604 if(kec.gt.0)then
5605 kec=kec-1
5606 if(keu.lt.ked)then
5607 keu=keu+1
5608 nump=nump+1
5609 ihadro(nump)=-140
5610 if(wri)write(ifch,f1)keu,ked,kes,kec,nump,ihadro(nump)
5611 else
5612 ked=ked+1
5613 nump=nump+1
5614 ihadro(nump)=-240
5615 if(wri)write(ifch,f1)keu,ked,kes,kec,nump,ihadro(nump)
5616 endif
5617 goto11
5618 endif
5619 endif
60ed90b3 5620
9ef1c2d9 5621c get rid of anti-s (130,230)
5622 5 continue
5623 if(kes.lt.0)then
5624 kes=kes+1
5625 if(keu.ge.ked)then
5626 keu=keu-1
5627 nump=nump+1
5628 ihadro(nump)=130
5629 if(wri)write(ifch,f1)keu,ked,kes,kec,nump,ihadro(nump)
5630 else
5631 ked=ked-1
5632 nump=nump+1
5633 ihadro(nump)=230
5634 if(wri)write(ifch,f1)keu,ked,kes,kec,nump,ihadro(nump)
5635 endif
5636 goto5
5637 endif
5638
60ed90b3 5639c get rid of anti-d (120, -230)
9ef1c2d9 5640 6 continue
5641 if(ked.lt.0)then
5642 ked=ked+1
5643 if(keu.ge.kes)then
5644 keu=keu-1
5645 nump=nump+1
5646 ihadro(nump)=120
5647 if(wri)write(ifch,f1)keu,ked,kes,kec,nump,ihadro(nump)
5648 else
5649 kes=kes-1
5650 nump=nump+1
5651 ihadro(nump)=-230
5652 if(wri)write(ifch,f1)keu,ked,kes,kec,nump,ihadro(nump)
5653 endif
5654 goto6
5655 endif
5656
5657c get rid of anti-u (-120, -130)
5658 7 continue
5659 if(keu.lt.0)then
5660 keu=keu+1
5661 if(ked.ge.kes)then
5662 ked=ked-1
5663 nump=nump+1
5664 ihadro(nump)=-120
5665 if(wri)write(ifch,f1)keu,ked,kes,kec,nump,ihadro(nump)
5666 else
5667 kes=kes-1
5668 nump=nump+1
5669 ihadro(nump)=-130
5670 if(wri)write(ifch,f1)keu,ked,kes,kec,nump,ihadro(nump)
5671 endif
5672 goto7
5673 endif
60ed90b3 5674
9ef1c2d9 5675 if(keu+ked+kes+kec.ne.ke)call utstop('hnbmin: sum_kei /= ke&')
5676
5677 keq=keu+ked
5678
60ed90b3 5679c get rid of s (3331, x330, xx30)
9ef1c2d9 5680 i=4
5681 2 i=i-1
5682 3 continue
5683 if((4-i)*kes.gt.(i-1)*keq)then
5684 kes=kes-i
5685 keq=keq-3+i
5686 nump=nump+1
5687 if(i.eq.3)ihadro(nump)=3331
5688 if(i.eq.2)ihadro(nump)=0330
5689 if(i.eq.1)ihadro(nump)=0030
5690 if(i.lt.3)then
5691 do j=1,3-i
5692 l=1+2*rangen()
5693 if(keu.gt.ked)l=1
5694 if(keu.lt.ked)l=2
5695 if(l.eq.1)keu=keu-1
5696 if(l.eq.2)ked=ked-1
5697 ihadro(nump)=ihadro(nump)+l*10**(4-j)
5698 enddo
5699 endif
5700 if(wri)write(ifch,f1)keu,ked,kes,kec,nump,ihadro(nump)
5701 if(kes.lt.0)call utstop('hnbmin: negative kes&')
5702 if(keq.lt.0)call utstop('hnbmin: negative keq&')
5703 goto3
5704 endif
5705 if(i.gt.1)goto2
5706
5707 if(keu+ked.ne.keq)call utstop('hnbmin: keu+ked /= keq&')
5708
60ed90b3 5709c get rid of d (2221, 1220, 1120)
9ef1c2d9 5710 i=4
5711 12 i=i-1
5712 13 continue
5713 if((4-i)*ked.gt.(i-1)*keu)then
5714 ked=ked-i
5715 keu=keu-3+i
5716 if(i.eq.3)then
5717 nump=nump+2
5718 ihadro(nump)=1220
5719 ihadro(nump-1)=-120
5720 else
5721 nump=nump+1
5722 if(i.eq.2)ihadro(nump)=1220
5723 if(i.eq.1)ihadro(nump)=1120
5724 endif
5725 if(wri)write(ifch,f1)keu,ked,kes,kec,nump,ihadro(nump)
5726 if(ked.lt.0)call utstop('hnbmin: negative ked&')
5727 if(keu.lt.0)call utstop('hnbmin: negative keu&')
5728 goto13
5729 endif
5730 if(i.gt.1)goto12
5731
5732 if(ked.ne.0)call utstop('hnbmin: ked .ne. 0&')
5733
60ed90b3 5734c get rid of u (1111)
9ef1c2d9 5735 9 continue
5736 if(keu.gt.0)then
5737 keu=keu-3
5738 nump=nump+2
5739 ihadro(nump)=1120
5740 ihadro(nump-1)=120
5741 if(wri)write(ifch,f1)keu,ked,kes,kec,nump,ihadro(nump)
5742 if(keu.lt.0)call utstop('hnbmin: negative keu&')
5743 goto9
5744 endif
5745
5746 if(keu.ne.0)call utstop('hnbmin: keu .ne. 0&')
5747
5748 if(isi.eq.-1)then
5749 do i=1,nump
5750 ihadro(i)=isi*ihadro(i)
5751 enddo
5752 endif
5753
5754 do lo=1,2
5755 if(nump.lt.2)then
5756 nump=nump+1
5757 ihadro(nump)=110
5758 if(wri)write(ifch,f1)keu,ked,kes,kec,nump,ihadro(nump)
5759 endif
5760 enddo
5761
5762 if(wri)write(ifch,*)('-',i=1,30)
5763 *,' exit sr hnbmin ',('-',i=1,10)
5764 return
5765 end
5766
5767c-------------------------------------------------------------
5768 subroutine hnbody
60ed90b3 5769c-------------------------------------------------------------
9ef1c2d9 5770c formerly subr genbod from genlib (cernlib).
5771c modified by K. Werner, march 94.
5772c subr to generate n-body event
5773c according to fermi lorentz-invariant phase space.
60ed90b3 5774c the phase space integral is the sum over the weights wt divided
9ef1c2d9 5775c by the number of events (sum wt / n).
5776c adapted from fowl (cern w505) sept. 1974 by f. james.
5777c events are generated in their own center-of-mass,
5778c but may be transformed to any frame using loren4.
5779c
5780c input to and output from subr thru common block config.
5781c input:
60ed90b3 5782c np=number of outgoing particles
9ef1c2d9 5783c tecm=total energy in center-of-mass
5784c amass(i)=mass of ith outgoing particle
5785c output:
5786c pcm(1,i)=x-momentum if ith particle
5787c pcm(2,i)=y-momentum if ith particle
5788c pcm(3,i)=z-momentum if ith particle
5789c pcm(4,i)=energy of ith particle
5790c pcm(5,i)=momentum of ith particle
5791c wtxlog=log of weight of event
5792c--------------------------------------------------------------
5793 include 'epos.inc'
5794 parameter(maxp=500)
5795 common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
5796 dimension emm(maxp)
5797 dimension rno(3*maxp-4)
5798c !pcm1 is linear equiv. of pcm to avoid double indices
5799 dimension em(maxp),pd(maxp),ems(maxp),sm(maxp)
5800 *,pcm1(5*maxp)
5801 common/cffq/ffqlog(maxp)
5802 common/ciiw/iii,rrr
5803 equivalence (nt,np),(amass(1),em(1)),(pcm1(1),pcm(1,1))
5804 logical wri
5805 data twopi/6.2831853073/
5806 external hnbiiw
5807ctp060829 nas=5 !must be at least 3
5808 wri=.false.
60ed90b3 5809 if(ish.ge.7)wri=.true.
9ef1c2d9 5810 if(wri)then
5811 write(ifch,*)('-',i=1,10)
5812 *,' entry sr hnbody ',('-',i=1,30)
5813 write(ifch,1200)np,tecm
5814 write(ifch,*)'particle masses:'
5815 write(ifch,'(1x,10f6.3)')(amass(n),n=1,np)
5816 endif
5817
5818c..... initialization
5819
5820 ktnbod=ktnbod + 1
5821 if(ktnbod.le.1)then
5822 !... ffq(n) = pi * (twopi)**(n-2) / (n-2)!
5823 ffqlog(1)=-1e35
5824 ffqlog(2)=alog(pi)
5825 do n=3,maxp
5826 ffqlog(n)=ffqlog(n-1)+log(twopi/(n-2))
5827 enddo
5828 endif
5829
5830 if(nt.lt.2) goto 1001
5831 if(nt.gt.maxp) goto 1002
5832 ntm1=nt-1
5833 ntm2=nt-2
5834 ntnm4=3*nt - 4
5835 emm(1)=em(1)
5836 tm=0.0
5837 do 2 i=1,nt
5838 ems(i)=em(i)**2
5839 tm=tm+em(i)
5840 2 sm(i)=tm
5841 tecmtm=tecm-tm
5842 if(tecmtm.le.0.0) goto 1000
5843 emm(nt)=tecm
5844 wtmlog=alog(tecmtm)*ntm2 + ffqlog(nt) - alog(tecm)
5845
5846c...fill rno with 3*nt-4 random numbers, the first nt-2 being ordered
5847
5848 do 3 i= 1, ntnm4
5849 3 rno(i)=rangen()
5850 if(ntm2) 9,5,4
5851 4 continue
5852 call flpsore(rno,ntm2)
60ed90b3 5853
9ef1c2d9 5854c...calculate emm().......M_i
5855
5856 do 6 j=2,ntm1
5857 6 emm(j)=rno(j-1)*tecmtm+sm(j)
60ed90b3 5858
9ef1c2d9 5859c...calculate wtlog
5860
5861 5 continue
5862 wtxlog=wtmlog
5863 ir=ntm2
5864 do 7 i=1,ntm1
5865 pd(i)=hnbpdk(emm(i+1),emm(i),em(i+1))
5866 if(pd(i).gt.0.)then
5867 pdlog=alog(pd(i))
5868 else
5869 pdlog=-1e35
5870 endif
5871 wtxlog=wtxlog+pdlog
5872 7 continue
5873
5874c...complete specification of event (raubold-lynch method)
5875
5876 pcm(1,1)=0.0
5877 pcm(2,1)=pd(1)
5878 pcm(3,1)=0.0
5879 do i=2,nt
5880 pcm(1,i)=0.0
5881 pcm(2,i)=-pd(i-1)
5882 pcm(3,i)=0.0
5883 ir=ir+1
5884 bang=twopi*rno(ir)
5885 cb=cos(bang)
5886 sb=sin(bang)
5887 ir=ir+1
5888 c=2.0*rno(ir)-1.0
5889 s=sqrt(1.0-c*c)
5890 if(i.ne.nt)then
5891 esys=sqrt(pd(i)**2+emm(i)**2)
5892 beta=pd(i)/esys
5893 gama=esys/emm(i)
5894 do j=1,i
5895 ndx=5*j - 5
5896 aa= pcm1(ndx+1)**2 + pcm1(ndx+2)**2 + pcm1(ndx+3)**2
5897 pcm1(ndx+5)=sqrt(aa)
5898 pcm1(ndx+4)=sqrt(aa+ems(j))
5899 call hnbrt2(c,s,cb,sb,pcm,j)
5900 psave=gama*(pcm(2,j)+beta*pcm(4,j))
5901 pcm(2,j)=psave
5902 enddo
5903 else !(i.eq.nt)
5904 do j=1,i
5905 aa=pcm(1,j)**2 + pcm(2,j)**2 + pcm(3,j)**2
5906 pcm(5,j)=sqrt(aa)
5907 pcm(4,j)=sqrt(aa+ems(j))
5908 call hnbrt2(c,s,cb,sb,pcm,j)
60ed90b3 5909 enddo
9ef1c2d9 5910 endif
5911 enddo
5912
5913c...returns
5914
5915 9 continue
5916 goto1111
5917
5918 1000 continue
5919 if(wri)
5920 *write(ifch,*)'available energy zero or negative -> wtxlog=-1e35'
5921 wtxlog=-1e35
5922 goto1111
5923
5924 1001 continue
5925 if(wri)
5926 *write(ifch,*)'less than 2 outgoing particles -> wtxlog=-1e35'
5927 wtxlog=-1e35
5928 goto1111
5929
5930 1002 continue
5931 write(ifch,*)'too many outgoing particles'
5932 1050 write(ifch,1150) ktnbod
5933 1150 format(47h0 above error detected in hnbody at call number,i7)
5934 write(ifch,1200) np,tecm
5935 1200 format(' np:',i6/' tecm:',f10.5)
5936 write(ifch,*)'particle masses:'
5937 write(ifch,'(1x,10f6.3)')(amass(jk),jk=1,np)
5938 stop
5939
59401111 continue
5941 if(wri)write(ifch,*)('-',i=1,30)
5942 *,' exit sr hnbody ',('-',i=1,10)
5943 return
5944 end
5945
5946c---------------------------------------------------------------------------------------------------------
5947 SUBROUTINE FLPSORE(A,N)
5948C---------------------------------------------------------------------------------------------------------
5949C CERN PROGLIB# M103 FLPSOR .VERSION KERNFOR 3.15 820113
5950C ORIG. 29/04/78
5951C
5952C SORT THE ONE-DIMENSIONAL FLOATING POINT ARRAY A(1),...,A(N) BY
5953C INCREASING VALUES
5954C
5955C- PROGRAM M103 TAKEN FROM CERN PROGRAM LIBRARY, 29-APR-78
5956C----------------------------------------------------------------------------------------------------------
5957 DIMENSION A(N)
5958 COMMON /SLATE/ LT(20),RT(20)
5959 INTEGER R,RT
5960C
5961 LEVEL=1
5962 LT(1)=1
5963 RT(1)=N
5964 10 L=LT(LEVEL)
5965 R=RT(LEVEL)
5966 LEVEL=LEVEL-1
5967 20 IF(R.GT.L) GO TO 200
5968 IF(LEVEL) 50,50,10
5969C
5970C SUBDIVIDE THE INTERVAL L,R
5971C L : LOWER LIMIT OF THE INTERVAL (INPUT)
5972C R : UPPER LIMIT OF THE INTERVAL (INPUT)
5973C J : UPPER LIMIT OF LOWER SUB-INTERVAL (OUTPUT)
5974C I : LOWER LIMIT OF UPPER SUB-INTERVAL (OUTPUT)
5975C
5976 200 I=L
5977 J=R
5978 M=(L+R)/2
5979 X=A(M)
5980 220 IF(A(I).GE.X) GO TO 230
5981 I=I+1
5982 GO TO 220
5983 230 IF(A(J).LE.X) GO TO 231
5984 J=J-1
5985 GO TO 230
5986C
5987 231 IF(I.GT.J) GO TO 232
5988 W=A(I)
5989 A(I)=A(J)
5990 A(J)=W
5991 I=I+1
5992 J=J-1
5993 IF(I.LE.J) GO TO 220
5994C
5995 232 LEVEL=LEVEL+1
5996 IF((R-I).GE.(J-L)) GO TO 30
5997 LT(LEVEL)=L
5998 RT(LEVEL)=J
5999 L=I
6000 GO TO 20
6001 30 LT(LEVEL)=I
6002 RT(LEVEL)=R
6003 R=J
6004 GO TO 20
6005 50 continue
60ed90b3 6006
9ef1c2d9 6007 do i=1,n-1
6008 if(a(i).gt.a(i+1))stop'FLPSORE: ERROR. '
60ed90b3 6009 enddo
6010
9ef1c2d9 6011 RETURN
6012 END
6013
6014
6015
6016
6017
6018c-------------------------------------------------------------
6019 subroutine hnbodz
60ed90b3 6020c-------------------------------------------------------------
9ef1c2d9 6021c subr to generate n-body event
6022c according to non-invariant phase space.
6023c the phase space integral is the sum over the weights exp(wtxlog)
6024c divided by the number of events.
6025c ref.: hagedorn, nuov. cim. suppl ix, x (1958) 646.
6026c events are generated in their own center-of-mass.
6027c
6028c input to and output from subr is thru common block config.
6029c input:
60ed90b3 6030c np=number of outgoing particles
9ef1c2d9 6031c tecm=total energy in center-of-mass
6032c amass(i)=mass of ith outgoing particle
6033c output:
6034c pcm(1,i)=x-momentum of ith particle
6035c pcm(2,i)=y-momentum of ith particle
6036c pcm(3,i)=z-momentum of ith particle
6037c pcm(4,i)=energy of ith particle
6038c pcm(5,i)=momentum of ith particle
6039c wtxlog=log of weight of event
6040c--------------------------------------------------------------
6041 include 'epos.inc'
6042 parameter(maxp=500)
6043 common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
6044 common /clatt/nlattc,npmax
6045 common/cffq/ffqlog(maxp)
6046 dimension ti(maxp),xi(maxp),si(maxp),zi(maxp)
6047 common/crnoz/rnoz(maxp-1)
6048 double precision ps(5)
6049
6050 call utpri('hnbodz',ish,ishini,6)
6051 if(ish.ge.6)write(ifch,1200)np,tecm
6052 if(ish.ge.6)write(ifch,*)'particle masses:'
6053 if(ish.ge.6)write(ifch,'(1x,10f6.3)')(amass(n),n=1,np)
60ed90b3 6054
9ef1c2d9 6055c initialization ktnbod=1
6056 ktnbod=ktnbod + 1
6057 if(ktnbod.gt.1) goto 1
6058c !ffqlog(n) = log{ (4*pi)**n / (n-1)! }
6059 ffqlog(1)=alog(4*pi)
6060 do n=2,maxp
6061 ffqlog(n)=ffqlog(n-1)+alog(4*pi/(n-1))
6062 enddo
6063 1 continue
60ed90b3 6064c set wtxlog -infinity for np<2
9ef1c2d9 6065 if(np.lt.2) goto 1001
6066c special treatment for np=2
6067 if(np.eq.2)then
6068 if(tecm.lt.amass(1)+amass(2)+0.00001)goto1000
6069 p0=utpcm(tecm,amass(1),amass(2))
6070 wtxlog=alog( 4*pi*p0
6071 */(1/sqrt(amass(1)**2+p0**2)+1/sqrt(amass(2)**2+p0**2)) )
6072 if(ish.ge.7)
6073 *write(ifch,*)'wtxlog:',wtxlog,' (np=2 treatment)'
6074 bang=2*pi*rangen()
6075 cb=cos(bang)
6076 sb=sin(bang)
6077 c=2.0*rangen()-1.0
6078 s=sqrt(1.0-c*c)
6079 do 9 i=1,2
6080 is=2*i-3
6081 pcm(5,i)=p0
6082 pcm(1,i)=is*pcm(5,i)*s*cb
6083 pcm(2,i)=is*pcm(5,i)*s*sb
6084 pcm(3,i)=is*pcm(5,i)*c
6085 pcm(4,i)=sqrt(amass(i)**2+p0**2)
6086 9 continue
6087 goto1111
6088 endif
6089c stop if np too large
6090 if(np.gt.maxp) goto 1002
6091c initialization all ktnbod
6092 tm=0.0
6093 do 2 i=1,np
6094 tm=tm+amass(i)
6095 2 continue
6096 tt=tecm-tm
6097 if(tt.le.0.0) goto 1000
6098c prefactor
6099 wtxlog=alog(tt)*(np-1) + ffqlog(np)
6100 if(ish.ge.7)
6101 *write(ifch,*)'wtxlog:',wtxlog,' (prefactor)'
60ed90b3 6102c fill rnoz with np-1 random numbers
9ef1c2d9 6103 if(keepr.eq.0)then
6104 do 3 i= 1, np-1
6105 3 rnoz(i)=rangen()
6106 else
6107 do lo=1,iomom
6108 j=1+rangen()*nlattc
6109 rnoz(j)=rangen()
6110 enddo
6111 endif
6112c calculate z_i distributed as i*z*(i-1)
6113 do i= 1, np-1
6114 zi(i)=rnoz(i)**(1./i)
6115 enddo
6116c calculate x_i
6117 xi(np)=1
6118 do i=np-1,1,-1
6119 xi(i)=zi(i)*xi(i+1)
6120 enddo
6121c calculate t_i, e_i, p_i
6122 if(ish.ge.9)write(ifch,*)'calculate t_i, e_i, p_i ...'
6123 do i=1,np-1
6124 si(i)=xi(i)*tt
6125 enddo
6126 ti(1)=si(1)
6127 if(ti(1).le.0.)ti(1)=1e-10
6128 ti(np)=tt-si(np-1)
6129 if(ti(np).le.0.)ti(np)=1e-10
6130 do i=np-1,2,-1
6131 ti(i)=si(i)-si(i-1)
6132 if(ti(i).le.0.)ti(i)=1e-10
6133 enddo
6134 do i=1,np
6135 pcm(1,i)=0
6136 pcm(2,i)=0
6137 pcm(3,i)=0
6138 pcm(4,i)=ti(i)+amass(i)
6139 p52=ti(i)*(ti(i)+2*amass(i))
60ed90b3 6140 if(p52.gt.0)then
9ef1c2d9 6141 pcm(5,i)=sqrt(p52)
6142 else
6143 pcm(5,i)=ti(i)*sqrt(1+2*amass(i)/ti(i))
6144 endif
6145 enddo
6146c calculate wtxlog
6147 call hnbraw(7,200,w)
6148 if(w.gt.0.)then
6149 wtxlog=wtxlog+alog(w)
6150 else
6151 wtxlog=wtxlog-1e+30
6152 endif
6153 do 7 i=1,np
6154 wtxlog=wtxlog+alog(pcm(5,i))+alog(ti(i)+amass(i))
6155 7 continue
6156 if(ish.ge.7)
6157 *write(ifch,*)'wtxlog:',wtxlog
6158c print
6159 if(ish.ge.7)then
6160 write(ifch,*)'momenta:'
6161 do j=1,4
6162 ps(j)=0
6163 enddo
6164 do i=1,np
6165 do j=1,4
6166 ps(j)=ps(j)+pcm(j,i)
6167 enddo
6168 write(ifch,'(1x,i3,5x,5f12.5)')i,(pcm(j,i),j=1,5)
6169 enddo
6170 ps(5)=dsqrt(ps(1)**2+ps(2)**2+ps(3)**2)
6171 write(ifch,'(1x,a4,8x,5f12.5)')'sum:',(sngl(ps(j)),j=1,5)
6172 endif
6173 if(w.le.0.)goto1111
6174c complete specification of event (random rotations and then deformations)
60ed90b3 6175 call hnbrot
9ef1c2d9 6176 if(ish.ge.7)write(ifch,*)'momenta after rotations:'
6177 call hnbrop(96,0)
6178 call hnbrod
6179 if(ish.ge.7)write(ifch,*)'momenta after deformations:'
6180 call hnbrop(96,1)
6181 goto1111
6182
6183c error returns
6184 1000 continue
6185 if(ish.ge.6)
6186 *write(ifch,*)'available energy zero or negative -> wtxlog=-1e35'
6187 wtxlog=-1e35
6188 goto1111
6189
6190 1001 continue
6191 if(ish.ge.6)
6192 *write(ifch,*)'less than 2 outgoing particles -> wtxlog=-1e35'
6193 wtxlog=-1e35
6194 goto1111
6195
6196 1002 continue
6197 write(ifch,*)'too many outgoing particles'
6198 1050 write(ifch,1150) ktnbod
6199 1150 format(47h0 above error detected in hnbody at call number,i7)
6200 write(ifch,1200) np,tecm
6201 1200 format(' np:',i6/' tecm:',f10.5)
6202 write(ifch,*)'particle masses:'
6203 write(ifch,'(1x,10f6.3)')(amass(jk),jk=1,np)
6204 stop
6205
62061111 continue
6207 call utprix('hnbodz',ish,ishini,6)
6208 return
6209 end
6210
6211c-----------------------------------------------------------------------
6212 subroutine hnbolo(loops)
6213c-----------------------------------------------------------------------
6214c loop over hnbody
6215c-----------------------------------------------------------------------
6216 include 'epos.inc'
6217 parameter(maxp=500)
6218 common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
60ed90b3 6219 a=0
6220 k=0
9ef1c2d9 6221 do j=1,loops
6222c-c if(mod(j,iterpr).eq.0)write(ifmt,*)' iteration:',iter,j
6223 if(iocova.eq.1)call hnbody
6224 if(iocova.eq.2)call hnbodz
6225 if(ish.ge.8)write(ifch,*)'j:',j,' wtxlog:',wtxlog
60ed90b3 6226 if(wtxlog.gt.-1e30)then
6227 k=k+1
9ef1c2d9 6228 if(k.eq.1)c=wtxlog
6229 if(a.gt.0.)then
6230 if(alog(a).lt.wtxlog-c-20)then
6231 a=0
6232 c=wtxlog
6233 endif
6234 endif
60ed90b3 6235 a=a+exp(wtxlog-c)
6236 endif
9ef1c2d9 6237 if(ish.ge.8)write(ifch,*)'k:',k,' c:',c
60ed90b3 6238 enddo
9ef1c2d9 6239 a=a/loops
60ed90b3 6240 wtxlog=alog(a)+c
9ef1c2d9 6241 return
6242 end
6243
6244c-----------------------------------------------------------------------
6245 function hnbpdk(a,b,c)
6246c-----------------------------------------------------------------------
6247c formerly pdk from cernlib
6248c returns momentum p for twobody decay a --> b + c
6249c a, b, c are the three masses
6250c~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
60ed90b3 6251c this p is related to twobody phase space as R2 = pi * p /a
9ef1c2d9 6252c-----------------------------------------------------------------------
6253 double precision aa,bb,cc,a2,b2,c2
6254 aa=a
6255 bb=b
6256 cc=c
6257 a2=aa*aa
6258 b2=bb*bb
6259 c2=cc*cc
6260 if(a2 + (b2-c2)**2/a2-2.0*(b2+c2).le.0.)then
6261 hnbpdk = 0
6262 else
6263 hnbpdk = 0.5*dsqrt(a2 + (b2-c2)**2/a2 - 2.0*(b2+c2))
6264 endif
6265 return
6266 end
6267
6268c----------------------------------------------------------------------
6269 subroutine hnbpad(k,n1,n2,n3,n4,mm,jc)
6270c----------------------------------------------------------------------
6271c k=1: determ pair indices k1,k2
6272c k=2: determ pair indices k3,k4 (.ne. n1,n2)
6273c k=1 and k=2: mm: type of pair, jc: flavour of pair
6274c----------------------------------------------------------------------
6275 include 'epos.inc'
6276 integer jc(nflav,2),ic(2),jc1(nflav,2),ic1(2),jc2(nflav,2),ic2(2)
6277 common /clatt/nlattc,npmax
6278 parameter(maxp=500)
6279 common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
6280
6281 if(k.eq.2)then
6282 k1=n1
6283 k2=n2
6284 endif
6285
6286c determine n1,n2 and mm
6287c ----------------------
6288 1 continue
6289 n1=1+rangen()*nlattc
6290 n1=min(n1,nlattc)
6291 2 continue
6292 n2=1+rangen()*nlattc
6293 n2=min(n2,nlattc)
6294 if(n2.eq.n1)goto2
6295 if(n2.lt.n1)then
6296 n1r=n1
6297 n1=n2
60ed90b3 6298 n2=n1r
9ef1c2d9 6299 endif
6300 if(k.eq.2)then
6301 if(n1.eq.k1.or.n1.eq.k2.or.n2.eq.k1.or.n2.eq.k2)goto1
6302 endif
60ed90b3 6303 if(ident(n1).ne.0.and.ident(n2).ne.0)mm=1 ! hadron-hadron
6304 if(ident(n1).ne.0.and.ident(n2).eq.0)mm=2 ! hadron-empty
6305 if(ident(n1).eq.0.and.ident(n2).ne.0)mm=2 ! empty-hadron
6306 if(ident(n1).eq.0.and.ident(n2).eq.0)mm=3 ! empty-empty
9ef1c2d9 6307 if(ish.ge.7)then
6308 write(ifch,'(a,i2)')' mm:',mm
6309 write(ifch,*)'to be replaced:',n1,ident(n1)
6310 write(ifch,*)'to be replaced:',n2,ident(n2)
6311 endif
6312
60ed90b3 6313c flavour of n1+n2 --> jc
9ef1c2d9 6314c -----------------------
60ed90b3 6315 if(mm.eq.1)then
9ef1c2d9 6316 call idtr4(ident(n1),ic1)
6317 call iddeco(ic1,jc1)
6318 call idtr4(ident(n2),ic2)
6319 call iddeco(ic2,jc2)
6320 do i=1,nflav
6321 do j=1,2
6322 jc(i,j)=jc1(i,j)+jc2(i,j)
6323 enddo
6324 enddo
6325 elseif(mm.eq.2.and.ident(n1).ne.0)then
6326 call idtr4(ident(n1),ic)
6327 call iddeco(ic,jc)
6328 elseif(mm.eq.2.and.ident(n2).ne.0)then
6329 call idtr4(ident(n2),ic)
6330 call iddeco(ic,jc)
6331 else
6332 do i=1,nflav
6333 do j=1,2
6334 jc(i,j)=0
6335 enddo
60ed90b3 6336 enddo
9ef1c2d9 6337 endif
6338
6339 if(k.eq.2)then
6340 n3=n1
6341 n4=n2
6342 endif
6343
6344 return
6345 end
6346
6347c----------------------------------------------------------------------
6348 subroutine hnbpai(id1,id2,jc)
6349c----------------------------------------------------------------------
60ed90b3 6350c returns arbitrary hadron pair id1,id2, flavour written to jc
9ef1c2d9 6351c----------------------------------------------------------------------
6352 include 'epos.inc'
6353 integer jc(nflav,2),jc1(nflav,2),ic1(2),jc2(nflav,2),ic2(2)
60ed90b3 6354 parameter (mspecs=56)
9ef1c2d9 6355 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
6356
6357c construct pair id1,id2
6358c ----------------------
6359 i1=rangen()*(nspecs+iozero)-(iozero-1)
6360 i1=max(i1,0)
6361 i1=min(i1,nspecs)
6362 if(i1.eq.0)then
6363 id1=0
6364 do i=1,nflav
6365 do j=1,2
6366 jc1(i,j)=0
6367 enddo
6368 enddo
6369 else
6370 id1=ispecs(i1)
6371 call idtr4(id1,ic1)
6372 call iddeco(ic1,jc1)
6373 endif
6374 if(ish.ge.7)write(ifch,'(1x,a,i3,a,i5,a,6i2,3x,6i2)')
6375 *'i1:',i1,' id1:',id1,' jc1:',jc1
6376 i2=rangen()*(nspecs+iozero)-(iozero-1)
6377 i2=max(i2,0)
6378 i2=min(i2,nspecs)
6379 if(i2.eq.0)then
6380 id2=0
6381 do i=1,nflav
6382 do j=1,2
6383 jc2(i,j)=0
6384 enddo
6385 enddo
6386 else
6387 id2=ispecs(i2)
6388 call idtr4(id2,ic2)
6389 call iddeco(ic2,jc2)
6390 endif
6391 if(ish.ge.7)write(ifch,'(1x,a,i3,a,i5,a,6i2,3x,6i2)')
6392 *'i2:',i2,' id2:',id2,' jc2:',jc2
6393 if(ish.ge.7)write(ifch,'(a,i6,i6)')' pair:',id1,id2
6394
6395c determine jc
6396c ------------
6397 do i=1,nflav
6398 do j=1,2
6399 jc(i,j)=jc1(i,j)+jc2(i,j)
6400 enddo
6401 enddo
6402 do i=1,nflav
6403 j12=jc(i,1)-jc(i,2)
6404 if(j12.ge.0)then
6405 jc(i,1)=j12
6406 jc(i,2)=0
6407 else
6408 jc(i,1)=0
6409 jc(i,2)=-j12
6410 endif
6411 enddo
6412 if(ish.ge.7)write(ifch,'(a,6i2,3x,6i2)')' jc:',jc
6413
6414 return
6415 end
6416
6417c----------------------------------------------------------------------
6418 subroutine hnbpaj(jc,iwpair,id1,id2)
6419c----------------------------------------------------------------------
6420c returns sum of weights iwpair of possible pairs
6421c and randomly chosen hadron pair id1,id2 for given flavour jc
6422c----------------------------------------------------------------------
6423 include 'epos.inc'
6424 parameter(mspecs=56,mxids=200)
6425 parameter(mxpair=mspecs**2*4)
6426 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
6427 common/cspec2/jspecs(2,nflav,mspecs)
6428 common/cspec3/lkfok(8,-3:3,-3:3,-3:3,-3:3) !-charm
6429 common/cspec5/idpairst(2,mxpair,3**6),iwtpaist(0:mxpair,3**6)
6430 & ,idxpair(0:2,0:2,0:2,-1:1,-1:1,-1:1),ipairst(3**6)
6431 common/cflac/ifok(nflav,mspecs),ifoa(nflav)
6432 dimension ids(mxids),iwts(mxids),jc(nflav,2)!,jc2(nflav,2)
6433 dimension idpair(2,mxpair),iwtpai(mxpair)
6434 dimension jc1mi2(nflav),jcmi(nflav)
6435
6436c nflv=nflav
6437c if(nflv.gt.6)
6438c *call utstop('hnbpaj: nflav.gt.6: modify this routine&')
6439
6440c construct possible pairs id1,id2
6441c --------------------------------
60ed90b3 6442
9ef1c2d9 6443 ipair=0
6444 iwpair=0
6445 idx=0
6446 if(jc(1,1).gt.2)then
6447 goto 1
6448 elseif(jc(1,1).lt.0)then
6449 goto 1
6450 elseif(jc(2,1).gt.2)then
6451 goto 1
6452 elseif(jc(2,1).lt.0)then
6453 goto 1
6454 elseif(jc(3,1).gt.2)then
6455 goto 1
6456 elseif(jc(3,1).lt.0)then
6457 goto 1
6458 elseif(jc(1,2).gt.1)then
6459 goto 1
6460 elseif(jc(1,2).lt.-1)then
6461 goto 1
6462 elseif(jc(2,2).gt.1)then
6463 goto 1
6464 elseif(jc(2,2).lt.-1)then
6465 goto 1
6466 elseif(jc(3,2).gt.1)then
6467 goto 1
6468 elseif(jc(3,2).lt.-1)then
6469 goto 1
6470 elseif((abs(jc(4,1))+abs(jc(5,1))+abs(jc(6,1))+abs(jc(4,2))
6471 & +abs(jc(5,2))+abs(jc(6,2))).gt.0)then
6472 goto 1
6473 endif
6474 idx=idxpair(jc(1,1),jc(2,1),jc(3,1),jc(1,2),jc(2,2),jc(3,2))
6475 ipair=ipairst(idx)
6476 if(ipair.eq.0)return
6477 iwpair=iwtpaist(0,idx)
6478 do i=1,ipair
6479 idpair(1,i)=idpairst(1,i,idx)
6480 idpair(2,i)=idpairst(2,i,idx)
6481 iwtpai(i)=iwtpaist(i,idx)
6482 enddo
6483 goto 4 !pair fixed via table
6484
6485c id1=0:
6486 1 continue
6487 if(nspecs+1.gt.mxids)call utstop('hnbpaj: mxids too small&')
6488
6489 jc1mi2(1)=jc(1,1)-jc(1,2)
6490 jc1mi2(2)=jc(2,1)-jc(2,2)
6491 jc1mi2(3)=jc(3,1)-jc(3,2)
6492 jc1mi2(4)=jc(4,1)-jc(4,2)
6493 jc1mi2(5)=jc(5,1)-jc(5,2)
6494 jc1mi2(6)=jc(6,1)-jc(6,2)
6495
6496 nids=0
6497
6498 if(jc1mi2(1).ne.0)goto11
6499 if(jc1mi2(2).ne.0)goto11
6500 if(jc1mi2(3).ne.0)goto11
6501 if(jc1mi2(4).ne.0)goto11
6502 if(jc1mi2(5).ne.0)goto11
6503 if(jc1mi2(6).ne.0)goto11
6504 nids=nids+1
6505 ids(nids)=0
6506 iwts(nids)=iozero
6507 11 continue
6508
6509 do j=1,nspecs
6510 if(jc1mi2(1).ne.ifok(1,j))goto22
6511 if(jc1mi2(2).ne.ifok(2,j))goto22
6512 if(jc1mi2(3).ne.ifok(3,j))goto22
6513 if(jc1mi2(4).ne.ifok(4,j))goto22
6514 if(jc1mi2(5).ne.ifok(5,j))goto22
6515 if(jc1mi2(6).ne.ifok(6,j))goto22
6516 nids=nids+1
6517 ids(nids)=ispecs(j)
6518 iwts(nids)=1
6519 22 continue
6520 enddo
6521
6522 if(nids.eq.0)goto2
6523 if(nids.gt.mxpair)call utstop('hnbpaj: mxpair too small&')
6524 do k=1,nids
6525 ipair=ipair+1
6526 idpair(1,ipair)=0
6527 idpair(2,ipair)=ids(k)
6528 iwtpai(ipair)=iozero*iwts(k)
6529 iwpair=iwpair+iwtpai(ipair)
6530c if(ish.ge.6)write(ifch,'(a,i5,5x,a,i6,i6,5x,a,i6)')' pair nr:'
6531c *,ipair,'ids:',0,ids(k),'weight:',iwtpai(ipair)
6532 enddo
6533 2 continue
6534
6535c id1>0:
6536
6537 do i1=1,nspecs
6538
6539c if(ish.ge.6)then
6540c do i=1,nflav
6541c jc2(i,1)=jc(i,1)-jspecs(1,i,i1)
6542c jc2(i,2)=jc(i,2)-jspecs(2,i,i1)
6543c enddo
6544c write(ifch,'(1x,a,i3,a,i6,a,6i2,3x,6i2)')
6545c *'i1:',i1,' id1:',ispecs(i1),' jc1:'
6546c *,(jspecs(1,i,i1),i=1,6),(jspecs(2,i,i1),i=1,6)
6547c write(ifch,'(a,6i2,3x,6i2)')' jc2:',jc2
6548c endif
6549
6550 jcmi(1)=jc1mi2(1)-jspecs(1,1,i1)+jspecs(2,1,i1)
6551 jcmi(2)=jc1mi2(2)-jspecs(1,2,i1)+jspecs(2,2,i1)
6552 jcmi(3)=jc1mi2(3)-jspecs(1,3,i1)+jspecs(2,3,i1)
6553 jcmi(4)=jc1mi2(4)-jspecs(1,4,i1)+jspecs(2,4,i1)
6554 jcmi(5)=jc1mi2(5)-jspecs(1,5,i1)+jspecs(2,5,i1)
6555 jcmi(6)=jc1mi2(6)-jspecs(1,6,i1)+jspecs(2,6,i1)
6556c-charm if(jcmi(4).ne.0)stop'HNBPAJ: c not treated'
6557 if(jcmi(5).ne.0)stop'HNBPAJ: b not treated'
6558 if(jcmi(6).ne.0)stop'HNBPAJ: t not treated'
6559
6560 nids=0
6561
6562 if(abs(jcmi(1)).gt.3)goto3
6563 if(abs(jcmi(2)).gt.3)goto3
6564 if(abs(jcmi(3)).gt.3)goto3
60ed90b3 6565 if(abs(jcmi(4)).gt.3)goto3 !-charm
9ef1c2d9 6566
6567 if(jcmi(1).ne.0)goto111
6568 if(jcmi(2).ne.0)goto111
6569 if(jcmi(3).ne.0)goto111
60ed90b3 6570 if(jcmi(4).ne.0)goto111 !-charm
9ef1c2d9 6571 nids=nids+1
6572 ids(nids)=0
6573 iwts(nids)=iozero
6574 111 continue
60ed90b3 6575
9ef1c2d9 6576 lkfok1=lkfok(1,jcmi(1),jcmi(2),jcmi(3),jcmi(4))
6577 if(lkfok1.gt.0)then
6578 nids=nids+1
6579 ids(nids)=lkfok(2,jcmi(1),jcmi(2),jcmi(3),jcmi(4))
6580 iwts(nids)=1
6581 if(lkfok1.gt.1)then
6582 nids=nids+1
6583 ids(nids)=lkfok(3,jcmi(1),jcmi(2),jcmi(3),jcmi(4))
6584 iwts(nids)=1
6585 if(lkfok1.gt.2)then
6586 if(lkfok1.gt.7) !-charm
6587 * stop'HNBPAJ: dimension of lkfok too small'
6588 do ii=3,lkfok1
6589 nids=nids+1
6590 ids(nids)=lkfok(1+ii,jcmi(1),jcmi(2),jcmi(3),jcmi(4))
6591 iwts(nids)=1
6592 enddo
6593 endif
6594 endif
6595 endif
6596
6597c do j=1,nspecs
6598c if(jcmi(1).ne.ifok(1,j))goto222
6599c if(jcmi(2).ne.ifok(2,j))goto222
6600c if(jcmi(3).ne.ifok(3,j))goto222
6601c if(jcmi(4).ne.ifok(4,j))goto222
6602c if(jcmi(5).ne.ifok(5,j))goto222
6603c if(jcmi(6).ne.ifok(6,j))goto222
6604c nids=nids+1
6605c ids(nids)=ispecs(j)
6606c iwts(nids)=1
6607c 222 continue
6608c enddo
6609
6610 if(nids.eq.0)goto3
6611 if(ipair+nids.gt.mxpair)call utstop('hnbpaj: mxpair too small&')
6612 do k=1,nids
6613 ipair=ipair+1
6614 idpair(1,ipair)=ispecs(i1)
6615 idpair(2,ipair)=ids(k)
6616 iwtpai(ipair)=iwts(k)
6617 iwpair=iwpair+iwtpai(ipair)
6618 enddo
6619 if(ish.ge.7)then
6620 ipair0=ipair-nids
6621 do k=1,nids
6622 ipair0=ipair0+1
6623 write(ifch,'(a,i5,5x,a,i6,i6,5x,a,i6)')' pair nr:'
6624 *,ipair0,'ids:',ispecs(i1),ids(k),'weight:',iwtpai(ipair0)
6625 enddo
6626 endif
6627 3 continue
6628
6629 enddo
6630
6631c no pair found
6632c -------------
6633 if(ipair.eq.0)then
6634 if(iwpair.ne.0)call utstop('hnbpaj: iwpair.ne.0&')
6635 return
6636 endif
6637
6638
6639 4 continue
6640c select pair
6641c -----------
6642 r=rangen()
6643 ir=1+r*iwpair
6644 ir=min(ir,iwpair)
6645 is=0
6646 do ip=1,ipair
6647 is=is+iwtpai(ip)
6648 if(ir.le.is)then
6649 id1=idpair(1,ip)
6650 id2=idpair(2,ip)
6651c if(ish.ge.6)write(ifch,*)'random number:',r
6652c *,' --> chosen pair:',ip
6653 goto 1000
6654 endif
6655 enddo
6656 write(ifmt,*)'hnbpaj:',jc,idx,ipair,iwpair,r,ir
6657 call utstop('hnbpaj: no pair selected&')
6658
66591000 continue
6660
6661 return
6662 end
6663
6664c----------------------------------------------------------------------
6665 subroutine hnbpajini
6666c----------------------------------------------------------------------
6667c initialize array to speed up hnbpaj calculation
60ed90b3 6668c store sum of weights iwpair of possible pairs in an array
9ef1c2d9 6669c for any combinations of quarks
6670c----------------------------------------------------------------------
6671 include 'epos.inc'
6672 parameter(mspecs=56,mxids=200)
6673 parameter(mxpair=mspecs**2*4)
6674 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
6675 common/cspec2/jspecs(2,nflav,mspecs)
6676 common/cspec3/lkfok(8,-3:3,-3:3,-3:3,-3:3) !-charm
6677 common/cspec5/idpairst(2,mxpair,3**6),iwtpaist(0:mxpair,3**6)
6678 & ,idxpair(0:2,0:2,0:2,-1:1,-1:1,-1:1),ipairst(3**6)
6679 common/cflac/ifok(nflav,mspecs),ifoa(nflav)
6680 dimension ids(mxids),iwts(mxids)
6681 dimension jc1mi2(3),jcmi(4)
6682
6683
6684c write(ifmt,*)' Initialize droplet decay ...'
6685
6686c construct possible pairs id1,id2
6687c --------------------------------
6688 idx=0
6689 do iaqs=-1,1
6690 do iaqd=-1,1
6691 do iaqu=-1,1
6692 do iqs=0,2
6693 do iqd=0,2
6694 do iqu=0,2
60ed90b3 6695
9ef1c2d9 6696 idx=idx+1
6697 idxpair(iqu,iqd,iqs,iaqu,iaqd,iaqs)=idx
6698
6699 ipair=0
6700 iwtpaist(0,idx)=0
6701 do i=1,mxids
6702 ids(i)=0
6703 iwts(i)=0
6704 enddo
6705 do i=1,mxpair
6706 idpairst(1,i,idx)=0
6707 idpairst(2,i,idx)=0
6708 iwtpaist(i,idx)=0
6709 enddo
6710
6711c id1=0:
6712
6713 if(nspecs+1.gt.mxids)call utstop('hnbpajini: mxids too small&')
6714
6715 jc1mi2(1)=iqu-iaqu
6716 jc1mi2(2)=iqd-iaqd
6717 jc1mi2(3)=iqs-iaqs
6718
6719 nids=0
6720
6721 if(jc1mi2(1).ne.0)goto11
6722 if(jc1mi2(2).ne.0)goto11
6723 if(jc1mi2(3).ne.0)goto11
6724 nids=nids+1
6725 ids(nids)=0
6726 iwts(nids)=iozero
6727 11 continue
6728
6729 do j=1,nspecs
6730 if(jc1mi2(1).ne.ifok(1,j))goto22
6731 if(jc1mi2(2).ne.ifok(2,j))goto22
6732 if(jc1mi2(3).ne.ifok(3,j))goto22
6733 nids=nids+1
6734 ids(nids)=ispecs(j)
6735 iwts(nids)=1
6736 22 continue
6737 enddo
6738
6739 if(nids.eq.0)goto2
6740 if(nids.gt.mxpair)call utstop('hnbpajini: mxpair too small&')
6741 do k=1,nids
6742 ipair=ipair+1
6743 idpairst(1,ipair,idx)=0
6744 idpairst(2,ipair,idx)=ids(k)
6745 iwtpaist(ipair,idx)=iozero*iwts(k)
6746 iwtpaist(0,idx)=iwtpaist(0,idx)+iwtpaist(ipair,idx)
6747c if(ish.ge.6)write(ifch,'(a,i5,5x,a,i6,i6,5x,a,i6)')' pair nr:'
6748c *,ipair,'ids:',0,ids(k),'weight:',iwtpai(ipair)
6749 enddo
6750 2 continue
6751
6752c id1>0:
6753
6754 do i1=1,nspecs
6755
6756c if(ish.ge.6)then
6757c do i=1,nflav
6758c jc2(i,1)=jc(i,1)-jspecs(1,i,i1)
6759c jc2(i,2)=jc(i,2)-jspecs(2,i,i1)
6760c enddo
6761c write(ifch,'(1x,a,i3,a,i6,a,6i2,3x,6i2)')
6762c *'i1:',i1,' id1:',ispecs(i1),' jc1:'
6763c *,(jspecs(1,i,i1),i=1,6),(jspecs(2,i,i1),i=1,6)
6764c write(ifch,'(a,6i2,3x,6i2)')' jc2:',jc2
6765c endif
6766
6767 jcmi(1)=jc1mi2(1)-jspecs(1,1,i1)+jspecs(2,1,i1)
6768 jcmi(2)=jc1mi2(2)-jspecs(1,2,i1)+jspecs(2,2,i1)
6769 jcmi(3)=jc1mi2(3)-jspecs(1,3,i1)+jspecs(2,3,i1)
6770 jcmi(4)=0
6771
6772 nids=0
6773
6774 if(abs(jcmi(1)).gt.3)goto3
6775 if(abs(jcmi(2)).gt.3)goto3
6776 if(abs(jcmi(3)).gt.3)goto3
6777
6778 if(jcmi(1).ne.0)goto111
6779 if(jcmi(2).ne.0)goto111
6780 if(jcmi(3).ne.0)goto111
6781 nids=nids+1
6782 ids(nids)=0
6783 iwts(nids)=iozero
6784 111 continue
60ed90b3 6785
9ef1c2d9 6786 lkfok1=lkfok(1,jcmi(1),jcmi(2),jcmi(3),jcmi(4))
6787 if(lkfok1.gt.0)then
6788 nids=nids+1
6789 ids(nids)=lkfok(2,jcmi(1),jcmi(2),jcmi(3),jcmi(4))
6790 iwts(nids)=1
6791 if(lkfok1.gt.1)then
6792 nids=nids+1
6793 ids(nids)=lkfok(3,jcmi(1),jcmi(2),jcmi(3),jcmi(4))
6794 iwts(nids)=1
6795 if(lkfok1.gt.2)then
6796 if(lkfok1.gt.7) !-charm
6797 * stop'HNBPAJINI: dimension of lkfok too small'
6798 do ii=3,lkfok1
6799 nids=nids+1
6800 ids(nids)=lkfok(1+ii,jcmi(1),jcmi(2),jcmi(3),jcmi(4))
6801 iwts(nids)=1
6802 enddo
6803 endif
6804 endif
6805 endif
6806
6807c do j=1,nspecs
6808c if(jcmi(1).ne.ifok(1,j))goto222
6809c if(jcmi(2).ne.ifok(2,j))goto222
6810c if(jcmi(3).ne.ifok(3,j))goto222
6811c if(jcmi(4).ne.ifok(4,j))goto222
6812c if(jcmi(5).ne.ifok(5,j))goto222
6813c if(jcmi(6).ne.ifok(6,j))goto222
6814c nids=nids+1
6815c ids(nids)=ispecs(j)
6816c iwts(nids)=1
6817c 222 continue
6818c enddo
6819
6820 if(nids.eq.0)goto3
6821 if(ipair+nids.gt.mxpair)
6822 & call utstop('hnbpajini: mxpair too small&')
6823 do k=1,nids
6824 ipair=ipair+1
6825 idpairst(1,ipair,idx)=ispecs(i1)
6826 idpairst(2,ipair,idx)=ids(k)
6827 iwtpaist(ipair,idx)=iwts(k)
6828 iwtpaist(0,idx)=iwtpaist(0,idx)+iwtpaist(ipair,idx)
6829 enddo
6830 ipairst(idx)=ipair
6831 3 continue
6832
6833 enddo
6834
6835c no pair found
6836c -------------
6837 if(ipair.eq.0)then
6838 if(iwtpaist(0,idx).ne.0)call utstop('hnbpajini: iwpair.ne.0&')
6839 endif
6840
68411000 continue
6842
6843
6844 enddo
6845 enddo
6846 enddo
6847 enddo
6848 enddo
6849 enddo
6850
6851 return
6852 end
6853
6854c--------------------------------------------------------------------
6855 subroutine hnbraw(npx,npy,w)
6856c--------------------------------------------------------------------
6857c returns random walk fctn w=w(0,p_1,p_2,...,p_n) for noncovariant
6858c phase space integral (see hagedorn, suppl nuov cim ix(x) (1958)646)
6859c input: dimension np and momenta p_i=pcm(5,i) via /confg/
6860c 1 < np <= npx : hagedorn method
6861c npx < np <= npy : integral method
60ed90b3 6862c npy < np : asymptotic method
9ef1c2d9 6863c--------------------------------------------------------------------
6864 include 'epos.inc'
6865 parameter(maxp=500)
6866 common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
6867 integer ii(maxp),isi(maxp)
6868 double precision ppcm(maxp),ww,ppsum,ppmax
6869 external hnbrax
60ed90b3 6870 common/cepsr/nepsr
9ef1c2d9 6871 if(ish.ge.9)write(ifch,*)('-',i=1,10)
6872 *,' entry sr hnbraw ',('-',i=1,30)
6873
6874 if(np.lt.3)call utstop('hnbraw: np must be at least 3&')
6875
6876 kper=5
6877 pi=3.1415927
6878 pmax=0
6879 do i=1,np
6880 pmax=pmax+pcm(5,i)
6881 enddo
6882 wio=0
6883 win=0
6884 whd=0
6885
6886c sum p_i - 2*p_max not positive
6887c ------------------------------
6888 px=0
6889 ps=0
6890 do i=1,np
6891 px=max(px,pcm(5,i))
6892 ps=ps+pcm(5,i)
6893 enddo
6894 if(ps-2*px.le.0.)then
6895 w=0
6896 if(ish.ge.7)write(ifch,'(1x,a,e12.5,4x)')
6897 *'sum p_i - 2*p_max not positive --> w:',w
6898 goto1000
60ed90b3 6899 endif
9ef1c2d9 6900
6901c asymptotic method
6902c -----------------
6903 was=0
6904 do i=1,np
6905 was=was+pcm(5,i)**2
6906 enddo
6907 was=(was*2*pi/3)**(-1.5)
6908 if(ish.ge.7)write(ifch,'(1x,a,e12.5,4x)')
6909 *'asymptotic method: was:',was
6910
6911 if(np.gt.npy)then
6912 w=was
6913 goto1000
6914 endif
6915
6916 if(np.le.npx)goto9
6917
6918c integral method
6919c ---------------
6920 if(ish.ge.9)write(ifch,*)'integral method...'
6921 itmax=8
6922 it=0
6923 b=pi*np*kper/pmax
6924 win=0
6925 nepsr=0
6926 3 continue
6927 it=it+1
6928 if(ish.ge.9)write(ifch,*)'it:',it
6929 b=b*5./3.
6930 wio=win
60ed90b3 6931 call uttrap(hnbrax,0.,b,win)
9ef1c2d9 6932 iok=0
6933 if(abs(win-wio).le.epsr*abs((win+wio)/2))iok=1
60ed90b3 6934 if(it.eq.itmax)iok=1
9ef1c2d9 6935 if(ish.ge.8.or.ish.ge.7.and.iok.eq.1)
6936 *write(ifch,'(1x,2(a,e12.5,2x),a,i2,2x,a,i4)')
6937 *'integral method: win:',win
6938 *,'upper limit:',b,'it:',it,'nepsr:',nepsr
6939 if(it.eq.itmax
6940 *.and.abs(win-wio).gt.epsr*abs((win+wio)/2))then
6941 nepsr=nepsr+1
6942 if(ish.ge.9)then
6943 call utmsg('hnbraw')
6944 write(ifch,*)
6945 *'***** requested accuracy could not be achieved'
6946 write(ifch,*)'achieved accuracy: '
6947 *,abs(win-wio)/abs((win+wio)/2)
6948 write(ifch,*)'requested accuracy:',epsr
6949 call utmsgf
6950 endif
6951 endif
6952 if(it.eq.1.or.iok.eq.0)goto3
6953
6954 if(nepsr.eq.0)then
6955 w=win
6956 goto1000
6957 endif
6958
6959 if(np.gt.20)then
6960 if(ish.ge.1)then
6961 call utmsg('hnbraw')
6962 write(ifch,*)
6963 * '***** requested accuracy could not be achieved'
6964 write(ifch,*)'achieved accuracy: '
6965 * ,abs(win-wio)/abs((win+wio)/2)
6966 write(ifch,*)'requested accuracy:',epsr
6967 call utmsgf
6968 endif
6969 w=win
6970 goto1000
6971 endif
6972
6973c hagedorn method (double)
6974c ------------------------
6975 9 continue
6976 ppmax=0
6977 do i=1,np
6978 ppcm(i)=pcm(5,i)
6979 ppmax=ppmax+ppcm(i)
6980 enddo
6981 ww=0
6982 do i=1,np
6983 ii(i)=0
6984 isi(i)=1
6985 enddo
6986 ppsum=ppmax
6987 i=0
6988 iprosi=1
6989 ww=iprosi*(ppsum/ppmax)**(np-3)
6990 if(ish.ge.8)
6991 *write(ifch,'(4x,i5,12x,f7.2,i5,f11.2)')np,sngl(ppsum)
6992 *,iprosi,sngl(ww)
6993 5 continue
6994 i=i+1
6995 if(i.gt.np)goto6
6996 if(ii(i).eq.1)goto5
6997 iprosi=-iprosi
6998 isi(i)=-isi(i)
6999 ppsum=ppsum+2*isi(i)*ppcm(i)
7000 if(ppsum.gt.0.or.ppsum.eq.0..and.isi(i).gt.0)then
7001 ww=ww+iprosi*(ppsum/ppmax)**(np-3)
7002 if(ish.ge.8)
7003 *write(ifch,'(4x,2i5,2f7.2,i5,f11.2)')
7004 *np,i,sngl(2*isi(i)*ppcm(i)),sngl(ppsum),iprosi,sngl(ww)
7005 else
7006 if(ish.ge.8)
7007 *write(ifch,'(4x,2i5,2f7.2,i5,4x,a)')
7008 *np,i,sngl(2*isi(i)*ppcm(i)),sngl(ppsum),iprosi,'not counted'
7009 endif
7010 ii(i)=1
7011 if(i.gt.1)then
7012 do j=1,i-1
7013 ii(j)=0
7014 enddo
7015 endif
7016 i=0
7017 goto5
7018 6 continue
7019 do i=1,np
7020 ww=ww*pmax/ppcm(i)/2./i
7021 enddo
7022 ww=-ww/pmax**3/pi/2.*np*(np-1)*(np-2)
60ed90b3 7023 whd=ww
9ef1c2d9 7024 if(ish.ge.7)write(ifch,'(1x,a,e12.5,4x,a)')
7025 *'hagedorn method: whd:',whd,'double precision'
7026
7027 w=whd
7028
70291000 continue
7030 if(ish.ge.9)write(ifch,*)('-',i=1,30)
7031 *,' exit sr hnbraw ',('-',i=1,10)
7032 return
7033 end
7034
7035c--------------------------------------------------------------------
7036 function hnbrax(x)
7037c--------------------------------------------------------------------
7038c returns integrand for random walk fctn w=w(0,p_1,p_2,...,p_n):
7039c 1./(2*pi**2) * x**2 * prod[sin(p_i*x)/(p_i*x)]
7040c input: dimension np and momenta p_i=pcm(5,i) via /confg/
7041c--------------------------------------------------------------------
7042 parameter(maxp=500)
7043 common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
7044 common/cnsta/pi,pii,hquer,prom,piom,ainfin
7045 hnbrax= pii * x**2
7046 do i=1,np
7047 px=pcm(5,i)*x
7048 if(px.ne.0.)hnbrax=hnbrax*sin(px)/px
7049 enddo
7050 return
7051 end
7052
7053c----------------------------------------------------------------------
7054 subroutine hnbrmz
7055c----------------------------------------------------------------------
7056c removes intermediate zeros from ident
7057c updates np
7058c----------------------------------------------------------------------
7059 include 'epos.inc'
7060 parameter(maxp=500)
7061 common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
7062c integer identx(maxp)
60ed90b3 7063 common /clatt/nlattc,npmax
9ef1c2d9 7064 if(ish.ge.9)write(ifch,*)('-',i=1,10)
7065 *,' entry sr hnbrmz ',('-',i=1,30)
7066 if(np.eq.0)goto1000
7067
7068c do i=1,np
7069c identx(i)=ident(i)
7070c enddo
7071c npx=np
7072
7073 i=0
7074 np=nlattc+1
7075
7076 1 i=i+1
7077 if(i.gt.nlattc)then
7078 np=nlattc
7079 goto1000
7080 endif
7081 if(ident(i).ne.0)goto1
7082 2 np=np-1
7083 if(np.eq.0)goto1000
7084 if(ident(np).eq.0)goto2
7085
7086 if(ish.ge.9)then
7087 write(ifch,*)'ident:'
7088 write(ifch,'(1x,10i7)')(ident(j),j=1,nlattc)
7089 write(ifch,'(1x,a,i3,3x,a,i3)')'i:',i,'np:',np
7090 endif
7091
7092 if(i.eq.np+1)goto1000
60ed90b3 7093
9ef1c2d9 7094 ident(i)=ident(np)
7095 ident(np)=0
7096 goto1
7097
70981000 continue
7099 if(ish.ge.9)write(ifch,*)('-',i=1,30)
7100 *,' exit sr hnbrmz ',('-',i=1,10)
7101 end
7102
7103c----------------------------------------------------------------------
7104 subroutine hnbrod
7105c----------------------------------------------------------------------
7106c deformes polygon of a sequence of arbitrarily rotated momentum
7107c vectors such that the polygon gets closed
7108c input: pcm(1-3,i) representing polygon
7109c output: pcm(1-3,i) representing closed polygon
7110c----------------------------------------------------------------------
7111 include 'epos.inc'
7112 parameter(maxp=500)
7113 common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
7114 real x(3),y(3),z(3),w(3)
7115 if(ish.ge.8)write(ifch,*)'sr hnbrod: polygon deformation:'
7116
7117 err=0.01
7118
7119 kmax=1000
7120 fac=0.30
7121 x2max=(err*tecm)**2
7122
7123 if(ish.ge.8)write(ifch,'(a,i4,a,f12.6)')
7124 *' kmax:',kmax,' x2max:',x2max
7125
7126 x(1)=0
7127 x(2)=0
7128 x(3)=0
7129 do i=1,np
7130 x(1)=x(1)+pcm(1,i)
7131 x(2)=x(2)+pcm(2,i)
7132 x(3)=x(3)+pcm(3,i)
7133 enddo ! i
7134
7135 k=0
7136 1 continue
7137
7138 x2=x(1)**2+x(2)**2+x(3)**2
7139 if(ish.ge.8)write(ifch,'(a,i3,a,3f9.3,a,f12.6)')
7140 *' it',k,': x:',x,' x2:',x2
7141 if(x2.le.x2max)goto1000
7142 if(k.gt.kmax)goto1001
7143
7144 k=k+1
7145 ir=1+rangen()*np
7146 ir=min(ir,np)
7147
7148 z(1)=-x(1)
7149 z(2)=-x(2)
7150 z(3)=-x(3)
7151 x(1)=x(1)-pcm(1,ir)
7152 x(2)=x(2)-pcm(2,ir)
7153 x(3)=x(3)-pcm(3,ir)
7154 y(1)=pcm(1,ir)
7155 y(2)=pcm(2,ir)
7156 y(3)=pcm(3,ir)
7157 if(ish.ge.9)write(ifch,'(a,i3,a,3f9.3,a,3f9.3,a,i4)')
7158 *' it',k,': x:',x,' y:',y,' ir:',ir
7159 xxx=x(1)**2+x(2)**2+x(3)**2
7160 yyy=y(1)**2+y(2)**2+y(3)**2
7161 zzz=z(1)**2+z(2)**2+z(3)**2
7162 if(xxx.gt.0..and.yyy.gt.0..and.zzz.gt.0.)then
7163c xx=sqrt(xxx)
7164 yy=sqrt(yyy)
7165 zz=sqrt(zzz)
7166 a=min(fac,fac*yy/zz)
7167 w(1)=y(1)+a*z(1)
7168 w(2)=y(2)+a*z(2)
7169 w(3)=y(3)+a*z(3)
7170 www=w(1)**2+w(2)**2+w(3)**2
7171 if(www.gt.0.)then
7172 ww=sqrt(www)
7173 y(1)=yy/ww*w(1)
7174 y(2)=yy/ww*w(2)
7175 y(3)=yy/ww*w(3)
7176 pcm(1,ir)=y(1)
7177 pcm(2,ir)=y(2)
7178 pcm(3,ir)=y(3)
7179 endif
7180 endif
7181 x(1)=x(1)+y(1)
7182 x(2)=x(2)+y(2)
7183 x(3)=x(3)+y(3)
7184 if(ish.ge.9)write(ifch,'(a,i3,a,3f9.3,a,3f9.3,a,i4)')
7185 *' it',k,': x:',x,' y:',y,' ir:',ir
7186
7187 goto1
7188
7189 1001 continue
7190 call utmsg('hnbrod')
7191 write(ifch,*)'***** total 3-momentum nonzero'
7192 write(ifch,'(3f12.5,5x,2f12.5)')(x(j),j=1,3),x2,x2max
7193 call utmsgf
7194
7195 1000 continue
7196 return
7197
7198 end
7199
7200c----------------------------------------------------------------------
7201 subroutine hnbrop(ishx,ichk)
7202c----------------------------------------------------------------------
7203c prints momenta of configuration (essentially to check rotation procedure)
7204c----------------------------------------------------------------------
7205 include 'epos.inc'
7206 parameter(maxp=500)
7207 common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
7208 double precision ps(5)
7209 err=0.01
7210 do j=1,4
7211 ps(j)=0
7212 enddo
7213 do i=1,np
7214 do j=1,4
7215 ps(j)=ps(j)+pcm(j,i)
7216 enddo
7217 if(ish.ge.ishx)write(ifch,'(1x,i3,5x,5f12.5)')i,(pcm(j,i),j=1,3)
7218 *,sqrt(pcm(1,i)**2+pcm(2,i)**2+pcm(3,i)**2),pcm(5,i)
7219 enddo
7220 ps(5)=dsqrt(ps(1)**2+ps(2)**2+ps(3)**2)
7221 if(ish.ge.ishx)write(ifch,'(1x,a4,8x,5f12.5)')
7222 *'sum:',(sngl(ps(j)),j=1,5)
7223 if(ichk.eq.1)then
7224 if(dabs(ps(1)).gt.err*tecm.or.dabs(ps(2)).gt.err*tecm
7225 *.or.dabs(ps(3)).gt.err*tecm)then
7226 call utmsg('hnbrop')
7227 write(ifch,*)'***** total 3-momentum nonzero'
7228 write(ifch,'(9x,5f12.5)')(sngl(ps(j)),j=1,5)
7229 call utmsgf
7230 endif
7231 endif
7232 return
7233 end
7234
7235c----------------------------------------------------------------------
7236 subroutine hnbrot
7237c----------------------------------------------------------------------
7238c rotates momenta of /confg/ randomly
7239c input: pcm(5,i)
7240c output: pcm(1-3,i)
7241c----------------------------------------------------------------------
60ed90b3 7242 common/cnsta/pi,pii,hquer,prom,piom,ainfin
9ef1c2d9 7243 parameter(maxp=500)
7244 common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
7245 real u(3)
7246
7247 do i=1,np
7248 u(3)=2.*rangen()-1.
7249 phi=2.*pi*rangen()
7250 u(1)=sqrt(1.-u(3)**2)*cos(phi)
7251 u(2)=sqrt(1.-u(3)**2)*sin(phi)
7252 pcm(1,i)=pcm(5,i)*u(1)
7253 pcm(2,i)=pcm(5,i)*u(2)
7254 pcm(3,i)=pcm(5,i)*u(3)
7255 enddo
7256
7257 return
7258 end
7259
7260cc-------------------------------------------------------------------
7261c subroutine hnbrt2old(c,s,c2,s2,pr,i)
7262cc-------------------------------------------------------------------
60ed90b3 7263cc formerly subr rotes2 from cernlib
9ef1c2d9 7264cc this subr now does two rotations (xy and xz)
7265cc-------------------------------------------------------------------
7266c parameter(maxp=500)
7267c dimension pr(5*maxp)
7268c k1 = 5*i - 4
7269c k2 = k1 + 1
7270c sa = pr(k1)
7271c sb = pr(k2)
7272c a = sa*c - sb*s
7273c pr(k2) = sa*s + sb*c
7274c k2 = k2 + 1
7275c b = pr(k2)
7276c pr(k1) = a*c2 - b*s2
7277c pr(k2) = a*s2 + b*c2
7278c return
7279c end
7280c
7281c-------------------------------------------------------------------
7282 subroutine hnbrt2(c,s,c2,s2,pr,i)
7283c-------------------------------------------------------------------
60ed90b3 7284c formerly subr rotes2 from cernlib
9ef1c2d9 7285c this subr now does two rotations (xy and xz)
7286c-------------------------------------------------------------------
7287 parameter(maxp=500)
7288 dimension pr(5,maxp)
7289 k1 = 5*i - 4
7290 k2 = k1 + 1
7291 sa = pr(1,i)
7292 sb = pr(2,i)
7293 a = sa*c - sb*s
7294 pr(2,i) = sa*s + sb*c
7295 k2 = k2 + 1
7296 b = pr(3,i)
7297 pr(1,i) = a*c2 - b*s2
7298 pr(3,i) = a*s2 + b*c2
7299 return
7300 end
7301
7302cc-----------------------------------------------------------------------
7303c subroutine hnbsor(a,n)
7304cc-----------------------------------------------------------------------
7305cc cern proglib# m103 flpsor .version kernfor 3.15 820113
7306cc orig. 29/04/78
7307cc-----------------------------------------------------------------------
7308cc sort the one-dimensional floating point array a(1),...,a(n) by
7309cc increasing values
7310cc-----------------------------------------------------------------------
7311c dimension a(*)
7312c common /slate/ lt(20),rt(20)
7313c integer r,rt
7314cc
7315c level=1
7316c lt(1)=1
7317c rt(1)=n
7318c 10 l=lt(level)
7319c r=rt(level)
7320c level=level-1
7321c 20 if(r.gt.l) go to 200
7322c if(level) 50,50,10
7323cc
7324cc subdivide the interval l,r
7325cc l : lower limit of the interval (input)
7326cc r : upper limit of the interval (input)
7327cc j : upper limit of lower sub-interval (output)
7328cc i : lower limit of upper sub-interval (output)
7329cc
7330c 200 i=l
7331c j=r
7332c m=(l+r)/2
7333c x=a(m)
7334c 220 if(a(i).ge.x) go to 230
7335c i=i+1
7336c go to 220
7337c 230 if(a(j).le.x) go to 231
7338c j=j-1
7339c go to 230
7340cc
7341c 231 if(i.gt.j) go to 232
7342c w=a(i)
7343c a(i)=a(j)
7344c a(j)=w
7345c i=i+1
7346c j=j-1
7347c if(i.le.j) go to 220
7348cc
7349c 232 level=level+1
7350c if(level.gt.20)stop'level too large'
7351c if((r-i).ge.(j-l)) go to 30
7352c lt(level)=l
7353c rt(level)=j
7354c l=i
7355c go to 20
7356c 30 lt(level)=i
7357c rt(level)=r
7358c r=j
7359c go to 20
7360c 50 return
7361c end
7362c
7363c-----------------------------------------------------------------------
7364 subroutine hnbspd(iopt)
7365c-----------------------------------------------------------------------
7366c defines particle species and masses and degeneracies.
7367c input:
7368c iopt=odd number: massless
60ed90b3 7369c iopt=even number: same as iopt-1, but massive
9ef1c2d9 7370c iopt= 1: pi0 (massless)
7371c iopt= 2: pi0
7372c iopt= 3: pi-,pi0,pi+ (massless)
7373c iopt= 4: pi-,pi0,pi+
7374c iopt= 5: pi-,pi0,pi+,prt,aprt,ntr,antr (massless)
7375c iopt= 6: pi-,pi0,pi+,prt,aprt,ntr,antr
7376c iopt= 7: 25 hadrons (massless)
7377c iopt= 8: 25 hadrons
7378c iopt= 9: 54 hadrons (massless)
7379c iopt=10: 54 hadrons
60ed90b3 7380c iopt=11: 3 quarks (massless)
7381c iopt=12: 3 quarks
7382c iopt=13: 54 hadrons + J/psi (massless)
7383c iopt=14: 54 hadrons + J/psi
7384c iopt=15: 54 hadrons + J/psi + H (massless)
7385c iopt=16: 54 hadrons + J/psi + H
9ef1c2d9 7386c output:
7387c nspecs: nr of species
7388c ispecs: id's
7389c aspecs: masses
7390c-----------------------------------------------------------------------
60ed90b3 7391 parameter (mspecs=56)
9ef1c2d9 7392 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
7393 parameter (nflav=6)
7394 integer jc(nflav,2),ic(2)
7395 common/cflac/ifok(nflav,mspecs),ifoa(nflav)
7396 common/cspec2/jspecs(2,nflav,mspecs)
7397 common/cspec3/lkfok(8,-3:3,-3:3,-3:3,-3:3) !-charm
7398 common/cspec4/lkfoi(8,-3:3,-3:3,-3:3,-3:3) !-charm
7399 parameter(nspe01=1,nspe03=3,nspe05=7,nspe07=25,nspe09=54)
7400 parameter(nspe11=6,nspe13=55,nspe15=56)
7401 real jspe01(nspe01),jspe03(nspe03),jspe05(nspe05),jspe07(nspe07)
7402 *,jspe09(nspe09),jspe11(nspe11),jspe13(nspe13),jspe15(nspe15)
7403 data jspe01/ 110 /
7404 data jspe03/ 110, 120, -120 /
7405 data jspe05/ 110, 120, -120, 1120,-1120, 1220,-1220 /
60ed90b3 7406 data jspe07/
9ef1c2d9 7407 * 110, 120, -120, 130, -130, 230, -230, 220, 330
7408 *, 1120,-1120, 1220,-1220, 1130,-1130, 2130,-2130
7409 *, 1230,-1230, 2230,-2230, 1330,-1330, 2330,-2330 /
60ed90b3 7410 data jspe09/
9ef1c2d9 7411 * 110, 120, -120, 130, -130, 230, -230, 220, 330
7412 *, 111, 121, -121, 131, -131, 231, -231, 221, 331
7413 *, 1120,-1120, 1220,-1220, 1130,-1130, 2130,-2130
7414 *, 1230,-1230, 2230,-2230, 1330,-1330, 2330,-2330
7415 *, 1111,-1111, 1121,-1121, 1221,-1221, 2221,-2221, 1131,-1131
7416 *, 1231,-1231, 2231,-2231, 1331,-1331, 2331,-2331, 3331,-3331 /
7417 data jspe11/
7418 * 1, -1, 2, -2, 3, -3 /
60ed90b3 7419 data jspe13/
9ef1c2d9 7420 * 110, 120, -120, 130, -130, 230, -230, 220, 330
7421 *, 111, 121, -121, 131, -131, 231, -231, 221, 331
7422 *, 1120,-1120, 1220,-1220, 1130,-1130, 2130,-2130
7423 *, 1230,-1230, 2230,-2230, 1330,-1330, 2330,-2330
7424 *, 1111,-1111, 1121,-1121, 1221,-1221, 2221,-2221, 1131,-1131
7425 *, 1231,-1231, 2231,-2231, 1331,-1331, 2331,-2331, 3331,-3331
7426 *, 441 /
60ed90b3 7427 data jspe15/
9ef1c2d9 7428 * 110, 120, -120, 130, -130, 230, -230, 220, 330
7429 *, 111, 121, -121, 131, -131, 231, -231, 221, 331
7430 *, 1120,-1120, 1220,-1220, 1130,-1130, 2130,-2130
7431 *, 1230,-1230, 2230,-2230, 1330,-1330, 2330,-2330
7432 *, 1111,-1111, 1121,-1121, 1221,-1221, 2221,-2221, 1131,-1131
7433 *, 1231,-1231, 2231,-2231, 1331,-1331, 2331,-2331, 3331,-3331
7434 *, 441 , 30 /
7435
7436 if(iopt.gt.16)call utstop('hnbspd: invalid option&')
7437 ioptx=(1+iopt)/2*2-1
7438
7439 if(ioptx.eq.1)nspecs=nspe01
7440 if(ioptx.eq.3)nspecs=nspe03
7441 if(ioptx.eq.5)nspecs=nspe05
7442 if(ioptx.eq.7)nspecs=nspe07
7443 if(ioptx.eq.9)nspecs=nspe09
7444 if(ioptx.eq.11)nspecs=nspe11
7445 if(ioptx.eq.13)nspecs=nspe13
7446 if(ioptx.eq.15)nspecs=nspe15
7447 do i=1,nspecs
60ed90b3 7448 if(ioptx.eq.1)ispecs(i)=jspe01(i)
7449 if(ioptx.eq.3)ispecs(i)=jspe03(i)
7450 if(ioptx.eq.5)ispecs(i)=jspe05(i)
7451 if(ioptx.eq.7)ispecs(i)=jspe07(i)
7452 if(ioptx.eq.9)ispecs(i)=jspe09(i)
9ef1c2d9 7453 if(ioptx.eq.11)ispecs(i)=jspe11(i)
7454 if(ioptx.eq.13)ispecs(i)=jspe13(i)
7455 if(ioptx.eq.15)ispecs(i)=jspe15(i)
7456 if(ioptx.eq.iopt)then
7457 aspecs(i)=0
7458 else
7459 id=ispecs(i)
7460 call idmass(id,am)
7461 aspecs(i)=am
7462 endif
7463 call hnbspi(ispecs(i),gg)
7464 gspecs(i)=gg
7465 enddo
7466
7467 do nf=1,nflav
7468 ifoa(nf)=0
7469 enddo
7470 do iic=-3, 3 !-charm
7471 do iis=-3, 3
7472 do iid=-3, 3
7473 do iiu=-3, 3
7474 do ii=1,7
7475 lkfok(ii,iiu,iid,iis,iic)=0 !-charm
7476 lkfoi(ii,iiu,iid,iis,iic)=0 !-charm
7477 enddo
7478 enddo
7479 enddo
7480 enddo
7481 enddo
7482 do i=1,nspecs
7483 id=ispecs(i)
7484 call idtr4(id,ic)
7485 call iddeco(ic,jc)
7486 do nf=1,nflav
7487 ifok(nf,i)=jc(nf,1)-jc(nf,2)
7488 ifoa(nf)=ifoa(nf)+iabs(ifok(nf,i))
7489 jspecs(1,nf,i)=jc(nf,1)
7490 jspecs(2,nf,i)=jc(nf,2)
7491 enddo
7492 iiu=ifok(1,i)
7493 iid=ifok(2,i)
7494 iis=ifok(3,i)
7495 iic=ifok(4,i) !-charm
7496 if(abs(iiu).gt.3)stop'HNBSPD: u-dimension of lkfok too small'
7497 if(abs(iid).gt.3)stop'HNBSPD: d-dimension of lkfok too small'
7498 if(abs(iis).gt.3)stop'HNBSPD: s-dimension of lkfok too small'
7499 if(abs(iic).gt.3)stop'HNBSPD: c-dimension of lkfok too small' !-charm
7500c-charm if(ifok(4,i).ne.0)stop'HNBSPD: lkfok needs index for c'
7501 if(ifok(5,i).ne.0)stop'HNBSPD: lkfok needs index for b'
7502 if(ifok(6,i).ne.0)stop'HNBSPD: lkfok needs index for t'
7503 lkfok(1,iiu,iid,iis,iic)=lkfok(1,iiu,iid,iis,iic)+1 !-charm
7504 lkfoi(1,iiu,iid,iis,iic)=lkfoi(1,iiu,iid,iis,iic)+1 !-charm
7505 ii=lkfok(1,iiu,iid,iis,iic) !-charm
7506 if(ii.gt.7)stop'HNBSPD: ii-dimension of lkfok too small'
7507 lkfok(1+ii,iiu,iid,iis,iic)=id !-charm
7508 lkfoi(1+ii,iiu,iid,iis,iic)=i !-charm
7509c write(6,'(i5,5x,3i5,5x,i5,5x,6i5)')
7510c * id,iiu,iid,iis,(lkfok(iiu,iid,iis,kk),kk=1,7)
7511 enddo
7512
7513 return
7514 end
7515
7516c-------------------------------------------------------------
7517 subroutine hnbspf(ku,kd,ks,kc,kb,kt,j,n,spelog)
60ed90b3 7518c-------------------------------------------------------------
9ef1c2d9 7519c returns spelog = log of factor for consid. different species
7520c spelog is double precision
7521c option ioflac determines the method:
7522c ioflac=1: ignore flavour conservation
7523c ioflac=2: flavour conservation implemented straightforward
7524c (only for nspecs=3,7)
7525c ioflac=3: flavour conservation via generating fctn
60ed90b3 7526c further input:
9ef1c2d9 7527c ku,...,kt (integer) : flavour
60ed90b3 7528c j (integer) : excluded species
7529c n (integer) : multiplicity
7530c-------------------------------------------------------------
9ef1c2d9 7531 include 'epos.inc'
60ed90b3 7532 parameter (mspecs=56)
9ef1c2d9 7533 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
7534 common/cflac/ifok(nflav,mspecs),ifoa(nflav)
7535 integer m(7),l(7),ifot(nflav)
7536 common/csph/ifox(nflav),ifoy(nflav),jx,nx,ifom(nflav,mspecs)
7537 parameter(mxfacu=200)
7538 double precision faci(0:mxfacu)
7539 double precision utgam2,spelog,spe
7540c parameter(numax=100,kqmax=100)
7541c parameter(mxhh=200)
7542 if(ish.ge.9)write(ifch,*)('-',i=1,10)
7543 *,' entry sr hnbspf ',('-',i=1,30)
7544 if(ish.ge.9)write(ifch,'(1x,a,9x,a,4x,a)')
7545 *' ku kd ks kc kb kt','j','n'
7546 if(ish.ge.9)write(ifch,'(1x,6i3,5x,2i5)')
7547 *ku,kd,ks,kc,kb,kt,j,n
7548 k=nspecs
7549 jx=j
7550 nx=n
7551 ifot(1)=ku
7552 ifot(2)=kd
7553 ifot(3)=ks
7554 ifot(4)=kc
7555 ifot(5)=kb
7556 ifot(6)=kt
7557
7558 if(ioflac.eq.1)then
7559
7560 if(ish.ge.9)write(ifch,'(1x,a,i1)')'ioflac=',ioflac
7561 g=0
7562 do i=1,nspecs
7563 if(i.ne.j)g=g+gspecs(i)
7564 enddo
7565 spelog=n*dlog(1.d0*g)
7566
7567 elseif(ioflac.eq.2)then
7568
7569 if(ish.ge.9)write(ifch,'(1x,a,i2)')'ioflac:',ioflac
7570 if(k.eq.3)then
7571 if(ish.ge.9)write(ifch,'(1x,a,i2)')'nspecs:',nspecs
7572 spe=0d0
7573 if(j.lt.1.or. j.gt.k)then
7574 do 1 n1=0,n
7575 do 2 n2=0,n-n1
7576 n3=n-n1-n2
7577 do 5 nf=1,nflav
7578 if(ifoa(nf).eq.0.and.ifot(nf).eq.0)goto5
60ed90b3 7579 if(n1*ifok(nf,1)+n2*ifok(nf,2)+n3*ifok(nf,3).ne.ifot(nf))goto2
9ef1c2d9 7580 5 continue
7581 spe=spe+utgam2(1.d0+n)
7582 &/utgam2(1.d0+n1)/utgam2(1.d0+n2)/utgam2(1.d0+n3)
7583 &*gspecs(1)**n1*gspecs(2)**n2*gspecs(3)**n3
7584 2 continue
7585 1 continue
7586 else
7587 do 3 i1=0,n
7588 i2=n-i1
7589 m(1)=0
7590 m(2)=i1
7591 m(3)=i2
7592 do i=1,3
7593 ii=1+mod(j-2+i,3)
7594 l(ii)=m(i)
7595 enddo
7596 n1=l(1)
7597 n2=l(2)
7598 n3=l(3)
7599 do 6 nf=1,nflav
7600 if(ifoa(nf).eq.0.and.ifot(nf).eq.0)goto6
7601 if(n1*ifok(nf,1)+n2*ifok(nf,2)+n3*ifok(nf,3).ne.ifot(nf))goto3
7602 6 continue
7603 spe=spe+utgam2(1.d0+n)
7604 &/utgam2(1.d0+n1)/utgam2(1.d0+n2)/utgam2(1.d0+n3)
7605 &*gspecs(1)**n1*gspecs(2)**n2*gspecs(3)**n3
7606 3 continue
7607 endif
7608 if(ish.ge.9)write(ifch,*)'spe:',spe
7609 spelog=-1000
7610 if(spe.gt.0.d0)spelog=dlog(spe)
7611 if(ish.ge.9)write(ifch,*)'spelog:',spelog
7612 elseif(k.eq.7)then
7613 if(ish.ge.9)write(ifch,'(1x,a,i2)')'nspecs:',nspecs
7614 if(n.gt.mxfacu)call utstop('hnbspf: mxfacu too small&')
7615 do lf=0,n
7616 faci(lf)=1.d0/utgam2(1d0+lf)
7617 enddo
7618 spe=0
7619 if(j.lt.1.or. j.gt.k)then
7620 do n1=0,n
7621 do n2=0,n-n1
7622 do n3=0,n-n1-n2
7623 do n4=0,n-n1-n2-n3
7624 do n5=0,n-n1-n2-n3-n4
7625 do 12 n6=0,n-n1-n2-n3-n4-n5
7626 n7=n-n1-n2-n3-n4-n5-n6
7627 do 15 nf=1,nflav
7628 if(ifoa(nf).eq.0.and.ifot(nf).eq.0)goto15
7629 if(n1*ifok(nf,1)+n2*ifok(nf,2)+n3*ifok(nf,3)+n4*ifok(nf,4)
60ed90b3 7630 *+n5*ifok(nf,5)+n6*ifok(nf,6)+n7*ifok(nf,7).ne.ifot(nf))goto12
9ef1c2d9 7631 15 continue
7632 spe=spe+1d0/faci(n)*faci(n1)*faci(n2)*faci(n3)*faci(n4)
7633 &*faci(n5)*faci(n6)*faci(n7)
7634 &*gspecs(1)**n1*gspecs(2)**n2*gspecs(3)**n3*gspecs(4)**n4
7635 &*gspecs(5)**n5*gspecs(6)**n6*gspecs(7)**n7
7636 12 continue
7637 enddo
7638 enddo
7639 enddo
7640 enddo
7641 enddo
7642 else
7643 do i1=0,n
7644 do i2=0,n-i1
7645 do i3=0,n-i1-i2
7646 do i4=0,n-i1-i2-i3
7647 do 13 i5=0,n-i1-i2-i3-i4
7648 i6=n-i1-i2-i3-i4-i5
7649 m(1)=0
7650 m(2)=i1
7651 m(3)=i2
7652 m(4)=i3
7653 m(5)=i4
7654 m(6)=i5
7655 m(7)=i6
7656 do i=1,7
7657 ii=1+mod(j-2+i,7)
7658 l(ii)=m(i)
7659 enddo
7660 n1=l(1)
7661 n2=l(2)
7662 n3=l(3)
7663 n4=l(4)
7664 n5=l(5)
7665 n6=l(6)
7666 n7=l(7)
7667 do 16 nf=1,nflav
7668 if(ifoa(nf).eq.0.and.ifot(nf).eq.0)goto16
7669 if(n1*ifok(nf,1)+n2*ifok(nf,2)+n3*ifok(nf,3)+n4*ifok(nf,4)
60ed90b3 7670 *+n5*ifok(nf,5)+n6*ifok(nf,6)+n7*ifok(nf,7).ne.ifot(nf))goto13
9ef1c2d9 7671 16 continue
7672 spe=spe+1d0/faci(n)*faci(n1)*faci(n2)*faci(n3)*faci(n4)
7673 &*faci(n5)*faci(n6)*faci(n7)
7674 &*gspecs(1)**n1*gspecs(2)**n2*gspecs(3)**n3*gspecs(4)**n4
7675 &*gspecs(5)**n5*gspecs(6)**n6*gspecs(7)**n7
7676 13 continue
7677 enddo
7678 enddo
7679 enddo
7680 enddo
7681 endif
7682 if(ish.ge.9)write(ifch,*)'spe:',spe
7683 spelog=-1000
7684 if(spe.gt.0.d0)spelog=dlog(spe)
7685 if(ish.ge.9)write(ifch,*)'spelog:',spelog
7686 else
7687 call utstop('hnbspf: ioflac=2 only for nspecs=3,7&')
7688 endif
7689
7690 elseif(ioflac.eq.3)then
7691
7692 call utstop('hnbspf: ioflac must be 1 or 2&')
7693
7694 endif
7695
7696 if(ish.ge.9)write(ifch,*)('-',i=1,30)
7697 *,' exit sr hnbspf ',('-',i=1,10)
7698 return
7699 end
7700
7701c-------------------------------------------------------------
7702 subroutine hnbspg(ku,kd,ks,kc,kb,kt,j,n,spelog)
60ed90b3 7703c-------------------------------------------------------------
9ef1c2d9 7704 include 'epos.inc'
7705 double precision spelog,spalog
7706 if(ioflac.ne.0)return
7707 ioflac=2
7708 call hnbspf(ku,kd,ks,kc,kb,kt,j,n,spalog)
7709 ioflac=3
7710 call hnbspf(ku,kd,ks,kc,kb,kt,j,n,spelog)
60ed90b3 7711 ioflac=0
9ef1c2d9 7712 write(ifch,*)'ioflac=2/3:',spalog,spelog
7713 return
7714 end
7715
7716c----------------------------------------------------------------------
7717 subroutine hnbspi(id,spideg)
7718c----------------------------------------------------------------------
7719c returns spin degeneracy spideg for particle id-code id
7720c----------------------------------------------------------------------
7721 include 'epos.inc'
7722 parameter (nspec=62)
7723 dimension ispec(nspec),spid(nspec)
7724 data ispec/
7725 * 1, -1, 2, -2, 3, -3
7726 *, 110, 120, -120, 220, 130, -130, 230, -230, 330
7727 *, 111, 121, -121, 221, 131, -131, 231, -231, 331
7728 *, 1120, 1220, 1130, 2130, 1230, 2230, 1330, 2330
7729 *, 1111, 1121, 1221, 2221, 1131, 1231, 2231, 1331, 2331, 3331
7730 *,-1120,-1220,-1130,-2130,-1230,-2230,-1330,-2330
7731 *,-1111,-1121,-1221,-2221,-1131,-1231,-2231,-1331,-2331,-3331
7732 *,441,30/
7733 data spid/
7734 * 6*6.
7735 *, 9*1.
7736 *, 9*3.
7737 *, 8*2.
7738 *,10*4.
7739 *, 8*2.
60ed90b3 7740 *,10*4.
9ef1c2d9 7741 *,1*3
7742 *,1*3/
7743 do i=1,nspec
7744 if(id.eq.ispec(i))then
7745 spideg=spid(i)
7746 fac=1
7747 !factb ... not used
7748 !factq ... not used
7749 call idflav(id,ifl1,ifl2,ifl3,jspin,index)
7750 ifls=0
7751 if(abs(ifl1).eq.3)ifls=ifls+1
7752 if(abs(ifl2).eq.3)ifls=ifls+1
7753 if(abs(ifl3).eq.3)ifls=ifls+1
7754 if(ifls.ge.1)then
7755 if(abs(id).gt.1000)then
7756 fac=fac*(1+facts)
7757 elseif(abs(id).lt.1000)then
7758 fac=fac*(1-facts)
60ed90b3 7759 endif
7760 endif
9ef1c2d9 7761 spideg=spideg*fac
7762 goto1
7763 endif
7764 enddo
7765 call utstop('hnbspi: id not found&')
7766 1 continue
7767 return
7768 end
7769
7770c----------------------------------------------------------------------
7771 subroutine hnbtst(iof12)
7772c----------------------------------------------------------------------
7773c calculates logs of prefactors and phase space integral
7774c for ultrarelativistic limit (massless particles) and (2*s_i+1)=1
7775c f12log and w15log=w35log+f12log not calculated calculated for iof12=0
7776c----------------------------------------------------------------------
7777 include 'epos.inc'
7778 parameter(maxp=500)
7779 common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
7780 common/ctst/psulog,wtulog
7781 integer ii(maxp)
7782 common /clatt/nlattc,npmax
7783
7784 pi=3.1415927
7785 hquer=0.197327
7786 ish0=ish
7787 if(ishsub/100.eq.23)ish=mod(ishsub,100)
7788 do i=1,np
7789 ii(i)=1
7790 enddo
7791
7792 if(ish.ge.7)write(ifch,*)('-',i=1,10)
7793 *,' entry sr hnbtst ',('-',i=1,30)
7794 if(ish.ge.7)write(ifch,*)'configuration:'
7795 if(ish.ge.7)write(ifch,*)(ident(i),i=1,np)
60ed90b3 7796 if(ish.ge.7)write(ifch,*)'n_l:',nlattc,' n_0:',nlattc-np
9ef1c2d9 7797
7798c log of prod m_i*volu/4/pi**3/hquer**3 -> f5log
7799 f5log=0
7800 do i=1,np
7801 call hnbfaf(i,gg,am,ioma)
7802 f5log=f5log+alog(gg*am*volu/4/pi**3/hquer**3)
7803 enddo
7804 if(ish.ge.7)write(ifch,*)'log(f5):',f5log
7805
7806c log f4log=0
7807 f4log=0
7808 if(ish.ge.7)write(ifch,*)'log(f4):',f4log
7809
60ed90b3 7810c log of 1/prod n_alpha! -> f3log
9ef1c2d9 7811 dbllog=0
7812 n1=1
7813 nx=1
7814 1 continue
7815 i=0
7816 x=0
7817 do n2=n1,np
7818 if(ident(n2).eq.ident(n1))then
7819 ii(n2)=0
7820 i=i+1
7821 x=x+alog(i*1.)
7822 endif
7823 if(ii(n2).ne.0.and.n2.gt.n1.and.nx.eq.n1
7824 *.and.ident(n2).ne.ident(n1))nx=n2
7825 enddo
7826 dbllog=dbllog+x
7827 if(nx.gt.n1)then
7828 n1=nx
7829 goto1
7830 endif
7831 f3log=-dbllog
7832 if(ish.ge.7)write(ifch,*)'log(f3):'
7833 *,f3log
7834
7835c log of f3 * f4 * f5
7836 f35log=f5log+f4log+f3log
7837 if(ish.ge.7)write(ifch,*)'log(f3*f4*f5):',f35log
60ed90b3 7838
9ef1c2d9 7839c log of phase space integral --> psilog
7840 if(iocova.eq.1)then
7841 psilog=alog(2.*np*np*(np-1)/tecm**4/pi)
7842 do i=1,np
7843 psilog=psilog+alog(tecm**2*pi/2./i/i)
7844 enddo
7845 elseif(iocova.eq.2)then
7846 psilog=-alog(2.*np-1)
7847 psilog=psilog+(np-1)*alog(pi/2.)
7848 do i=1,2*np-2
7849 psilog=psilog+alog((2.*np+i-2)/i)
7850 enddo
7851 do i=1,3*np-4
7852 psilog=psilog+alog(tecm/i)
7853 enddo
7854 endif
7855 if(ish.ge.7)write(ifch,*)'log(psi):',psilog
7856
7857c log of phase space integral * f3 * f4 * f5
7858 w35log=f35log+psilog
7859 if(ish.ge.7)write(ifch,*)'log(f35*psi):',w35log
7860
7861 if(iof12.ne.0)then
7862
7863c log of macro/micro factor (f1*f2) --> f12log
7864 deglog=0
7865 do i=1,np
7866 deglog=deglog+alog(1.*i)
7867 enddo
7868 deglog=deglog+f3log
7869 do i=1,np
7870 deglog=deglog+alog(nlattc+1.-i)-alog(1.*i)
7871 enddo
7872 f12log=-deglog
7873
7874 w15log=w35log+f12log
7875 if(ish.ge.7)then
7876 write(ifch,*)'log(f1*f2):',f12log
7877 write(ifch,*)'log(f15*psi):',w15log
7878 write(ifch,'(1x,4(a,3x))')
7879 *'log(fac):','log(psi):',' log(wt):','log(wta):'
7880 write(ifch,'(1x,4(f9.3,3x))')
7881 *f12log+f35log,psilog,w15log,w15log-f12log
7882 endif
7883
7884 endif
7885
7886 psulog=psilog
7887 wtulog=w35log
60ed90b3 7888
9ef1c2d9 7889 if(ish.ge.7)write(ifch,*)('-',i=1,30)
7890 *,' exit sr hnbtst ',('-',i=1,10)
7891 ish=ish0
7892 return
7893 end
7894
7895cc----------------------------------------------------------------------
7896c subroutine hnbuex(x,e)
7897cc----------------------------------------------------------------------
7898cc x --> x*10.**e with x.lt.10.**10.
7899cc----------------------------------------------------------------------
7900c if(x.eq.0.)then
60ed90b3 7901c e=0.
9ef1c2d9 7902c else
7903c e=int(alog10(abs(x)))/10*10
7904c x=x/10.**e
7905c endif
7906c return
7907c end
7908c
7909cc----------------------------------------------------------------------
7910c subroutine hnbwin(n,w,q,i)
7911cc----------------------------------------------------------------------
7912cc returns random index i according to weight w(i)
7913cc----------------------------------------------------------------------
7914c real w(n),q(n)
7915c q(1)=w(1)
7916c do k=2,n
7917c q(k)=q(k-1)+w(k)
7918c enddo
7919c y=rangen()*q(n)
7920c do k=1,n
7921c i=k
7922c if(q(k).ge.y)goto1000
7923c enddo
7924c i=n
7925c1000 return
7926c end
7927c
7928c----------------------------------------------------------------------
7929 subroutine hnbwri
7930c----------------------------------------------------------------------
7931c writes (to ifch) an configuration
7932c----------------------------------------------------------------------
7933 include 'epos.inc'
7934 parameter(maxp=500)
7935 common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
7936 common/cfact/faclog
7937 write(ifch,'(1x,a,i5)')'np:',np
7938 write(ifch,'(1x,3(a,3x))')
7939 *'log(fac):','log(psi):',' log(wt):'
7940 if(wtlog.gt.-1e30.and.wtxlog.gt.-1e30)then
7941 write(ifch,'(1x,3(f9.3,3x))')faclog,wtxlog,wtlog
7942 else
7943 write(ifch,*)faclog,wtxlog,wtlog
7944 endif
7945 if(np.le.1)return
7946 call hnbtst(1)
7947 write(ifch,*)'particle id codes:'
7948 write(ifch,'(1x,10i6)')(ident(n),n=1,np)
7949 write(ifch,*)'particle masses:'
7950 write(ifch,'(1x,10f6.3)')(amass(n),n=1,np)
7951 end
7952
7953c----------------------------------------------------------------------
7954 subroutine hnbzen(iii)
7955c----------------------------------------------------------------------
7956c analysis of events. energy spectra.
7957c for iii>0: filling histogram considering ptl iii
7958c----------------------------------------------------------------------
7959 parameter(maxp=500)
7960 common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
60ed90b3 7961 parameter (mspecs=56)
9ef1c2d9 7962 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
7963 parameter (nhise=100)
7964 common/chise/hise(mspecs,nhise)
7965 de=2./nhise/2.
7966
7967 if(iii.gt.0)then
7968
7969 i=iii
7970 do l=1,nspecs
7971 if(ident(i).eq.ispecs(l))then
7972 j=l
7973 goto1
7974 endif
7975 enddo
7976 1 continue
7977 am=aspecs(j)
7978 e=pcm(4,i)
7979 ke=1+int((e-am)/(2*de))
7980 if(ke.ge.1.and.ke.le.nhise)hise(j,ke)=hise(j,ke)+1
7981 return
7982
7983 else
7984
7985 stop'STOP in hnbzen: iii=0'
7986
7987 endif
7988
7989 end
7990
7991c----------------------------------------------------------------------
7992 subroutine hnbzmu(iii)
7993c----------------------------------------------------------------------
7994c analysis of events. multiplicity spectra.
7995c for iii<0: settting histograms to zero (should be first call)
7996c for iii>0: filling histogram considering ptl iii
7997c----------------------------------------------------------------------
7998 parameter(maxp=500)
7999 common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
60ed90b3 8000 parameter (mspecs=56)
9ef1c2d9 8001 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
8002 parameter (nhismu=500)
8003 common/chismu/hismu(mspecs,0:nhismu),hismus(nhismu)
8004
8005 if(iii.lt.0)then
8006
8007 do i=1,nhismu
8008 hismus(i)=0
8009 enddo
8010 do j=1,nspecs
8011 do i=0,nhismu
8012 hismu(j,i)=0
8013 enddo
8014 enddo
8015 goto1000
8016
8017 elseif(iii.gt.0)then
8018
8019 if(np.ge.1.and.np.le.nhismu)hismus(np)=hismus(np)+1
8020 do j=1,nspecs
8021 mu=0
8022 do i=1,np
8023 if(ident(i).eq.ispecs(j))mu=mu+1
8024 enddo
8025 if(mu.ge.0.and.mu.le.nhismu)hismu(j,mu)=hismu(j,mu)+1
8026 enddo
8027 goto1000
8028
8029 else
8030
8031 stop'STOP in sr hnbzmu: iii must not be 0'
8032
8033 endif
8034
80351000 continue
8036 return
8037 end
8038
8039c-----------------------------------------------------------------------
8040 subroutine xhgcam(amt,iii)
8041c-----------------------------------------------------------------------
60ed90b3 8042c creates unnormalized histogram for total mass of grand
9ef1c2d9 8043c canonically generated sample
8044c xpar1: nr. of bins
8045c xpar2: m_1 (lower boundary)
8046c xpar3: m_2 (upper boundary)
8047c-----------------------------------------------------------------------
8048 include 'epos.inc'
8049 parameter(nbmx=200)
8050 common/camdat/data(nbmx),datb(nbmx)
8051 parameter(mxclu=10000)
8052 real am(mxclu)
8053 character cen*6,cvol*6
8054
8055 if(iii.eq.0)then
60ed90b3 8056
9ef1c2d9 8057 am(nrclu)=amt
8058
8059 return
60ed90b3 8060
9ef1c2d9 8061 elseif(iii.lt.0)then
8062
8063 nbin=nint(xpar3)
8064 x1=xpar1
8065 x2=xpar2
8066 dam=(x2-x1)/nbin
8067 write(cen,'(f6.1)')tecm
8068 write(cvol,'(f6.1)')volu
8069
8070 do i=1,nbin
8071 data(i)=x1+(i-1)*dam
8072 datb(i)=0.0
8073 enddo
8074
8075 do i=1,nrclu
8076 xnb=(am(i)-x1)/dam+1.
8077 nb=nint(xnb)
8078 if(nb.le.nbin.and.nb.ge.1)datb(nb)=datb(nb)+1
8079 enddo
8080
8081 write(ifhi,'(a)') 'newpage zone 1 2 1'
8082
8083 write(ifhi,'(a)') 'openhisto'
8084 write(ifhi,'(a)') 'htyp his'
8085 write(ifhi,'(a)') 'xmod lin ymod lin'
8086 write(ifhi,'(a,2e11.3)')'xrange',x1,x2
8087 write(ifhi,'(a)') 'text 0 0 "xaxis total mass"'
8088 write(ifhi,'(a)') 'text 0 0 "yaxis N"'
8089 write(ifhi,'(a,a)') 'text 0.4 0.91 "V='//cvol//'"'
8090 write(ifhi,'(a,a)') 'text 0.15 0.91 "E='//cen//'"'
8091 write(ifhi,'(a)') 'array 2'
8092
8093 do j=1,nbin
8094 write(ifhi,'(2e13.5)')data(j),datb(j)
8095 enddo
8096
8097 write(ifhi,'(a)') ' endarray'
8098 write(ifhi,'(a)') 'closehisto plot 0'
8099
8100
8101 return
8102
8103 endif
8104
8105 end
8106
8107c-----------------------------------------------------------------------
8108 subroutine xhgccc(chi)
8109c-----------------------------------------------------------------------
8110c creates unnormalized histogram for chi-squared test of initial
8111c configuration (grand-canonical results are used)
8112c for chi>0: chi-squared for each droplet configuration is written
8113c to /cchi/
8114c for chi<0: creates histogram
8115c xpar1 specifies lower limit
8116c xpar2 specifies upper limit
8117c xpar3 specifies bin width
8118c newpage, zone and plot commands not included !!!
8119c-----------------------------------------------------------------------
8120 include 'epos.inc'
8121 parameter(nbin=200)
8122 common/chidat/data(nbin),datb(nbin)
8123 parameter(mxclu=10000)
8124 common/cchi/chi2(mxclu)
8125 character cnu*2,cinco*1,cen*6,cvol*6
60ed90b3 8126 parameter (mspecs=56)
9ef1c2d9 8127 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
8128
8129 if(chi.ge.0.0)then
8130
8131 nrclu=nrclu+1
8132 chi2(nrclu)=chi
8133
8134 return
8135
8136 elseif(chi.lt.0.0)then
8137
8138 x1=nint(xpar1)
8139 x2=nint(xpar2)
8140 da=xpar3
8141 write(cnu,'(i2)')nspecs
8142 write(cinco,'(i1)')ioinco
8143 write(cen,'(f6.1)')tecm
8144 write(cvol,'(f6.1)')volu
8145
8146 if(x2.eq.0)x2=50.0
8147 da=max(0.1,da)
8148 a0=x1
8149
8150 do i=1,nbin
8151 data(i)=a0+(i-1)*da
8152 datb(i)=0.0
8153 enddo
8154
8155 do i=1,nrclu
8156 nb=(chi2(i)+da/2.-a0)/da
8157 if(nb.le.nbin.and.nb.ge.1)datb(nb)=datb(nb)+1
8158 enddo
8159
8160 write(ifhi,'(a)') 'openhisto'
8161 write(ifhi,'(a)') 'htyp his'
8162 write(ifhi,'(a)') 'xmod lin ymod lin'
8163 write(ifhi,'(a,2e11.3)')'xrange',x1,x2
8164 write(ifhi,'(a)') 'text 0 0 "xaxis [V]^2"'
8165 write(ifhi,'(a)') 'text 0 0 "yaxis f([V]^2,n?eff!)"'
8166 if(iappl.eq.4)write(ifhi,'(a,a)')'text 0.4 0.91 "V='//cvol//'"'
8167 if(iappl.eq.4)write(ifhi,'(a,a)')'text 0.15 0.91 "E='//cen//'"'
8168 write(ifhi,'(a)') 'array 2'
8169
8170 do j=1,nbin
8171 dat=datb(j)/nevent/da
8172 write(ifhi,'(2e13.5)')data(j),dat
8173 enddo
8174
8175 write(ifhi,'(a)') ' endarray'
8176 write(ifhi,'(a)') 'closehisto'
8177
8178 return
8179
8180 endif
8181
8182 end
8183
8184c-----------------------------------------------------------------------
8185 subroutine xhgcen
8186c-----------------------------------------------------------------------
8187c creates energy spectrum plot for decayed QM-droplet
8188c using grand canonical results
8189c input:
8190c xpar1 specifies particle species by paige id, 0 for all
8191c xpar2 and xpar3 specify xrange of plot
8192c xpar4 specifies line type : dashed (0), dotted (1), full (2) dado (3)
8193c xpar5 specifies statistics to be used ,(0) same as iostat
8194c (1) boltzmann
8195c output:
60ed90b3 8196c histo-file
9ef1c2d9 8197c newpage, zone and plot commands not included !!!
8198c-----------------------------------------------------------------------
8199 include 'epos.inc'
8200 common/citer/iter,itermx
8201 parameter (nbin=200)
8202 real datx(nbin),daty(nbin)
60ed90b3 8203 parameter (mspecs=56)
9ef1c2d9 8204 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
8205 common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
8206 common/cbol/rmsbol(mspecs),ptlbol(mspecs),chebol(mspecs),tembol
8207 character ctem*5,cit*5,cen*6,cvo*6,chem*5
8208
8209 idpa=nint(xpar1)
8210 x1=xpar2
8211 x2=xpar3
8212 ltyp=nint(xpar4)
8213 ist=nint(xpar5)
8214 if(ist.eq.0.and.iostat.eq.1)ist=1
8215
8216 id=0
8217 jx=100
8218 do i=1,nspecs
8219 if(ispecs(i).eq.idpa)id=i
8220 enddo
8221
8222 dx=(x2-x1)/2./jx
8223 x0=x1+dx
8224
8225 do j=1,jx
8226 datx(j)=x0+(j-1)*dx*2.
8227 daty(j)=0.0
8228
8229 if(id.eq.0)then
8230
8231 do 10 i=1,nspecs
8232 dnde=0.0
8233 if(datx(j).ge.aspecs(i))then
8234 x=100.
8235 if(tem.ne.0.0.and.ist.eq.0)x=(datx(j)-chemgc(i))/tem
8236 if(tem.ne.0.0.and.ist.eq.1)x=(datx(j)-chebol(i))/tembol
8237 igsp=gspecs(i)
8238 if(x.ge.60)goto10
8239 if(mod(igsp,2).eq.0.and.ist.eq.0)then
8240 dnde=1./(exp(x)+1.)
8241 elseif(x.le.1.e-7.and.ist.eq.0)then
8242 dnde=1.e7
8243 elseif(ist.eq.0)then
8244 dnde=1./(exp(x)-1.)
8245 elseif(ist.eq.1)then
8246 dnde=exp(-x)
8247 endif
8248 endif
8249 daty(j)=daty(j)+dnde*gspecs(i)*volu/hquer**3/8./pi**3
825010 continue
60ed90b3 8251
9ef1c2d9 8252 else
60ed90b3 8253
9ef1c2d9 8254 dnde=0.0
8255 if(datx(j).ge.aspecs(id))then
8256 x=100.
8257 if(tem.ne.0.0.and.ist.eq.0)x=(datx(j)-chemgc(id))/tem
8258 if(tem.ne.0.0.and.ist.eq.1)x=(datx(j)-chebol(id))/tembol
8259 igsp=gspecs(id)
8260 if(x.ge.60)goto11
8261 if(mod(igsp,2).eq.0.and.ist.eq.0)then
8262 dnde=1./(exp(x)+1.)
8263 elseif(x.le.1.e-7.and.ist.eq.0)then
8264 dnde=1.e7
8265 elseif(ist.eq.0)then
8266 dnde=1./(exp(x)-1.)
8267 elseif(ist.eq.1)then
8268 dnde=exp(-x)
8269 endif
8270 endif
827111 daty(j)=dnde*gspecs(id)*volu/hquer**3/8./pi**3
8272
8273 endif
8274
8275 enddo
8276
8277 ctem=' '
8278 chem=' '
8279 if(tem.gt.0.)write(ctem,'(f5.3)')tem
8280 write(cen,'(f6.1)')tecm
8281 write(cvo,'(f6.1)')volu
8282 if(id.gt.0)write(chem,'(f5.3)')chemgc(id)
8283 write(cit,'(i5)')itermx
8284 write(ifhi,'(a)') 'openhisto'
8285 if(ltyp.eq.0)then
8286 write(ifhi,'(a)') 'htyp lda'
8287 elseif(ltyp.eq.1)then
8288 write(ifhi,'(a)') 'htyp ldo'
8289 elseif(ltyp.eq.2)then
8290 write(ifhi,'(a)') 'htyp lfu'
8291 elseif(ltyp.eq.3)then
8292 write(ifhi,'(a)') 'htyp ldd'
8293 endif
8294 write(ifhi,'(a)') 'xmod lin ymod log'
8295 write(ifhi,'(a,2e11.3)')'xrange',x1,x2
8296 write(ifhi,'(a)') 'text 0 0 "xaxis E?[n]! (GeV)"'
8297 write(ifhi,'(a)') 'text 0 0 "yaxis dN?[n]!/d^3!p"'
8298 write(ifhi,'(a,a)') 'text 0.3 0.10 "T='//ctem//'"'
8299 write(ifhi,'(a,a)') 'text 0.3 0.20 "[m]?[n]!='//chem//'"'
8300 write(ifhi,'(a,a)') 'text 0.3 0.20 "i?max!='//cit//'"'
8301 if(iocite.ne.1)then
8302 write(ifhi,'(a,a)') 'text 0.4 0.91 "V='//cvo//'"'
8303 write(ifhi,'(a,a)') 'text 0.15 0.91 "E='//cen//'"'
8304 endif
8305 write(ifhi,'(a)') 'array 2'
8306
8307 do j=1,jx
8308 write(ifhi,'(2e12.4)')datx(j),daty(j)
8309 enddo
8310
8311 write(ifhi,'(a)') ' endarray'
8312 write(ifhi,'(a)') 'closehisto'
8313
8314 return
8315 end
8316
8317c-----------------------------------------------------------------------
8318 subroutine xhgcfl(u,d,s,iii)
8319c-----------------------------------------------------------------------
60ed90b3 8320c creates unnormalized histogram for net flavor content of grand
9ef1c2d9 8321c canonically generated sample
8322c xpar1: specifies width of plot, netflavor centered
8323c-----------------------------------------------------------------------
8324 include 'epos.inc'
8325 parameter(nb=200)
8326 common/cfldat/data(nb),datb(nb),datc(nb),datu(nb)
8327 *,datd(nb),dats(nb)
8328 parameter(mxclu=10000)
8329 integer ku(mxclu),kd(mxclu),ks(mxclu)
8330 character cfl*3,cen*6,cvol*6
8331
8332 if(iii.eq.0)then
60ed90b3 8333
9ef1c2d9 8334 ku(nrclu)=u
8335 kd(nrclu)=d
8336 ks(nrclu)=s
8337
8338 return
60ed90b3 8339
9ef1c2d9 8340 elseif(iii.lt.0)then
8341
8342 kwid=nint(xpar1)
8343 nbin=2*kwid+1
8344 x1u=keu-kwid
8345 x2u=keu+kwid
8346 x1d=ked-kwid
8347 x2d=ked+kwid
8348 x1s=kes-kwid
8349 x2s=kes+kwid
8350 write(cen,'(f6.1)')tecm
8351 write(cvol,'(f6.1)')volu
8352
8353 do i=1,nbin
8354 data(i)=x1u+(i-1)
8355 datb(i)=x1d+(i-1)
8356 datc(i)=x1s+(i-1)
8357 datu(i)=0.0
8358 datd(i)=0.0
8359 dats(i)=0.0
8360 enddo
8361
8362 do i=1,nrclu
8363 nbu=(ku(i)-x1u+1)
8364 nbd=(kd(i)-x1d+1)
8365 nbs=(ks(i)-x1s+1)
8366 if(nbu.le.nbin.and.nbu.ge.1)datu(nbu)=datu(nbu)+1
8367 if(nbd.le.nbin.and.nbd.ge.1)datd(nbd)=datd(nbd)+1
8368 if(nbs.le.nbin.and.nbs.ge.1)dats(nbs)=dats(nbs)+1
8369 enddo
8370
8371 write(ifhi,'(a)') 'newpage zone 1 3 1'
8372
8373 write(cfl,'(i3)')keu
8374 write(ifhi,'(a)') 'openhisto'
8375 write(ifhi,'(a)') 'htyp his'
8376 write(ifhi,'(a)') 'xmod lin ymod lin'
8377 write(ifhi,'(a,2e11.3)')'xrange',x1u,x2u
8378 write(ifhi,'(a)') 'text 0 0 "xaxis net u content"'
8379 write(ifhi,'(a)') 'text 0 0 "yaxis N"'
8380 write(ifhi,'(a,a)') 'text 0.4 0.91 "V='//cvol//'"'
8381 write(ifhi,'(a,a)') 'text 0.15 0.91 "E='//cen//'"'
8382 write(ifhi,'(a,a)') 'text 0.65 0.91 "N?u!='//cfl//'"'
8383 write(ifhi,'(a)') 'array 2'
8384
8385 do j=1,nbin
8386 write(ifhi,'(2e13.5)')data(j),datu(j)
8387 enddo
8388
8389 write(ifhi,'(a)') ' endarray'
8390 write(ifhi,'(a)') 'closehisto plot 0'
8391
8392 write(cfl,'(i3)')ked
8393 write(ifhi,'(a)') 'openhisto'
8394 write(ifhi,'(a)') 'htyp his'
8395 write(ifhi,'(a)') 'xmod lin ymod lin'
8396 write(ifhi,'(a,2e11.3)')'xrange',x1d,x2d
8397 write(ifhi,'(a)') 'text 0 0 "xaxis net d content"'
8398 write(ifhi,'(a)') 'text 0 0 "yaxis N"'
8399 write(ifhi,'(a,a)') 'text 0.4 0.91 "V='//cvol//'"'
8400 write(ifhi,'(a,a)') 'text 0.15 0.91 "E='//cen//'"'
8401 write(ifhi,'(a,a)') 'text 0.65 0.91 "N?d!='//cfl//'"'
8402 write(ifhi,'(a)') 'array 2'
8403
8404 do j=1,nbin
8405 write(ifhi,'(2e13.5)')datb(j),datd(j)
8406 enddo
8407
8408 write(ifhi,'(a)') ' endarray'
8409 write(ifhi,'(a)') 'closehisto plot 0'
8410
8411 write(cfl,'(i3)')kes
8412 write(ifhi,'(a)') 'openhisto'
8413 write(ifhi,'(a)') 'htyp his'
8414 write(ifhi,'(a)') 'xmod lin ymod lin'
8415 write(ifhi,'(a,2e11.3)')'xrange',x1s,x2s
8416 write(ifhi,'(a)') 'text 0 0 "xaxis net s content"'
8417 write(ifhi,'(a)') 'text 0 0 "yaxis N"'
8418 write(ifhi,'(a,a)') 'text 0.4 0.91 "V='//cvol//'"'
8419 write(ifhi,'(a,a)') 'text 0.15 0.91 "E='//cen//'"'
8420 write(ifhi,'(a,a)') 'text 0.65 0.91 "N?s!='//cfl//'"'
8421 write(ifhi,'(a)') 'array 2'
8422
8423 do j=1,nbin
8424 write(ifhi,'(2e13.5)')datc(j),dats(j)
8425 enddo
8426
8427 write(ifhi,'(a)') ' endarray'
8428 write(ifhi,'(a)') 'closehisto plot 0'
8429
8430 return
8431
8432 endif
8433
8434 end
8435
8436c-----------------------------------------------------------------------
8437 subroutine xhgcmt
8438c-----------------------------------------------------------------------
8439c creates transverse mass spectrum for QM-droplet decay
8440c according to grand canonical results
8441c input:
8442c xpar1 specifies particle species by paige id, 0 for all
8443c xpar2 and xpar3 specify xrange of plot
8444c xpar4 specifies line type : dashed (0), dotted (1), full (2)
8445c output:
60ed90b3 8446c histo-file
9ef1c2d9 8447c newpage, zone and plot commands not included !!!
8448c-----------------------------------------------------------------------
8449 include 'epos.inc'
8450 common/citer/iter,itermx
8451 parameter (nbin=200)
8452 real datx(nbin),daty(nbin)
60ed90b3 8453 parameter (mspecs=56)
9ef1c2d9 8454 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
8455 common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
8456 character cen*6,cvo*6,cit*5,ctem*5
8457
8458 idpa=nint(xpar1)
8459 x1=xpar2
8460 x2=xpar3
8461 ltyp=nint(xpar4)
8462
8463 id=0
8464 jx=100
8465 do i=1,nspecs
8466 if(ispecs(i).eq.idpa)id=i
8467 enddo
8468
8469 dx=(x2-x1)/2./jx
8470 x0=x1+dx
8471
8472 do j=1,jx
8473 datx(j)=x0+(j-1)*dx*2.
8474 daty(j)=0.0
8475
8476 if(id.eq.0)then
8477
8478 do 10 i=1,nspecs
8479 dndmt=0.0
8480 if(datx(j).ge.aspecs(i))then
8481 x=100.
8482 xx=100.
8483 if(tem.ne.0.)x=datx(j)/tem
8484 if(tem.ne.0.)xx=chemgc(i)/tem
8485 if(abs(xx).le.60)dndmt=gspecs(i)*volu/hquer**3*exp(xx)*datx(j)
8486 */4./pi**3*hgcbk1(x)
8487 endif
8488 daty(j)=daty(j)+dndmt
848910 continue
8490
8491 else
8492
8493 dndmt=0.0
8494 if(datx(j).ge.aspecs(id))then
8495 x=100.
8496 xx=100.
8497 if(tem.ne.0.)x=datx(j)/tem
8498 if(tem.ne.0.)xx=chemgc(id)/tem
8499 if(abs(xx).le.60)dndmt=gspecs(id)*volu/hquer**3*exp(xx)*datx(j)
8500 */4./pi**3*hgcbk1(x)
8501 endif
8502 daty(j)=dndmt
8503
8504 endif
8505
8506 enddo
8507
8508 write(cit,'(i5)')itermx
8509 write(cen,'(f6.1)')tecm
8510 write(cvo,'(f6.1)')volu
8511 write(ctem,'(f5.3)')tem
8512 write(ifhi,'(a)') 'openhisto'
8513 if(ltyp.eq.0)then
8514 write(ifhi,'(a)') 'htyp lda'
8515 elseif(ltyp.eq.1)then
8516 write(ifhi,'(a)') 'htyp ldo'
8517 elseif(ltyp.eq.2)then
8518 write(ifhi,'(a)') 'htyp lfu'
8519 endif
8520 write(ifhi,'(a)') 'xmod lin ymod log'
8521 write(ifhi,'(a,2e11.3)')'xrange',x1,x2
8522 write(ifhi,'(a)') 'text 0 0 "xaxis m?t! (GeV)"'
8523 write(ifhi,'(a)') 'text 0 0 "yaxis dN?[n]!/d^2!m?t! "'
8524 write(ifhi,'(a,a)') 'text 0.3 0.10 "T='//ctem//'"'
8525 write(ifhi,'(a,a)') 'text 0.3 0.20 "i?max!='//cit//'"'
8526 write(ifhi,'(a,a)') 'text 0.4 0.91 "V='//cvo//'"'
8527 write(ifhi,'(a,a)') 'text 0.15 0.91 "E='//cen//'"'
8528 write(ifhi,'(a)') 'array 2'
8529
8530 do j=1,jx
8531 write(ifhi,'(2e12.4)')datx(j),daty(j)
8532 enddo
8533
8534 write(ifhi,'(a)') ' endarray'
8535 write(ifhi,'(a)') 'closehisto'
8536
8537 return
8538 end
8539
8540c-----------------------------------------------------------------------
8541 subroutine xhgcmu
8542c-----------------------------------------------------------------------
8543c creates multiplicity plot for decayed QM-droplet
8544c according to grand canonical results
8545c input:
8546c xpar1 specifies species by paige id, 0 for total multiplicity
8547c xpar2 specifies xrange to be set automatically (0) or by hand (1)
8548c xpar3 and xpar4 xrange if xpar2 ne 0
8549c xpar5 xrange = average+-sigma*xpar5
8550c xpar6 specifies line type : dashed (0), dotted (1), full (2)
8551c xpar7 specifies statistics : same as iostat (0)
8552c boltzmann (1)
8553c output:
60ed90b3 8554c histo-file
9ef1c2d9 8555c newpage, zone and plot commands not included !!!
60ed90b3 8556c-----------------------------------------------------------------------
9ef1c2d9 8557 include 'epos.inc'
8558 parameter (nbin=200)
8559 real datx(nbin),daty(nbin)
60ed90b3 8560 parameter (mspecs=56)
9ef1c2d9 8561 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
8562 common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
8563 common/cbol/rmsbol(mspecs),ptlbol(mspecs),chebol(mspecs),tembol
8564 common/cgctot/rmstot,ptltot
8565 character cyield*8,cen*6,cvo*6,cinco*1
60ed90b3 8566
9ef1c2d9 8567
8568 idpa=nint(xpar1)
8569 ixra=nint(xpar2)
8570 iwid=nint(xpar5)
8571 ltyp=nint(xpar6)
8572 ist=nint(xpar7)
8573 if(ist.eq.0.and.iostat.eq.1)ist=1
8574
60ed90b3 8575
9ef1c2d9 8576 id=0
8577 jx=100
8578 ymin=1./nevent/10.
8579 if(nevent.le.10)ymin=ymin/10.
8580 do i=1,nspecs
8581 if(ispecs(i).eq.idpa)id=i
8582 enddo
60ed90b3 8583
9ef1c2d9 8584 if(ixra.eq.1)then
8585 x1=anint(xpar3)
8586 x2=anint(xpar4)
8587 else
8588 if(id.eq.0)then
8589 x1=anint(ptltot-iwid*rmstot)
8590 x2=anint(ptltot+iwid*rmstot)
60ed90b3 8591 else
9ef1c2d9 8592 x1=anint(ptlngc(id)-iwid*rmsngc(id))
8593 x2=anint(ptlngc(id)+iwid*rmsngc(id))
8594 endif
8595 x2=max(x2,3.0)
8596 endif
8597
8598 x1=max(x1,0.0)
8599 dx=(x2-x1)/2./jx
8600 x0=x1+dx
8601
8602 do j=1,jx
8603 datx(j)=x0+(j-1)*dx*2.
8604 if(id.eq.0)then
8605
8606c total multiplicity
8607c ------------------
8608 x=100.
8609 if(rmstot.ge.1.e-10)x=(datx(j)-ptltot)**2/rmstot**2/2.
60ed90b3 8610
9ef1c2d9 8611 if(x.ge.60)then
8612 pn=0.0
8613 else
8614 pn=exp(-x)/rmstot/sqrt(2.*pi)
8615 endif
8616
8617 daty(j)=pn
8618
8619 else
60ed90b3 8620
9ef1c2d9 8621c one species (specified by id)
60ed90b3 8622c ------------------------------
9ef1c2d9 8623 x=100.
8624 if(rmsngc(id).ge.1.e-10.and.ist.eq.0)
8625 *x=(datx(j)-ptlngc(id))**2/rmsngc(id)**2/2.
8626 if(rmsbol(id).ge.1.e-10.and.ist.eq.1)
8627 *x=(datx(j)-ptlbol(id))**2/rmsbol(id)**2/2.
8628
8629 if(x.ge.60)then
8630 pn=0.0
8631 else
8632 if(ist.eq.0)pn=exp(-x)/rmsngc(id)/sqrt(2*pi)
8633 if(ist.eq.1)pn=exp(-x)/rmsbol(id)/sqrt(2*pi)
8634 endif
8635
8636 daty(j)=pn
8637
8638 endif
8639 enddo
8640
8641 if(id.eq.0)then
8642 write(cyield,'(f8.3)')ptltot
8643 else
8644 write(cyield,'(f8.3)')ptlngc(id)
8645 endif
8646 write(cinco,'(i1)')ioinco
8647 write(cen,'(f6.1)')tecm
8648 write(cvo,'(f6.1)')volu
8649 write(ifhi,'(a)') 'openhisto'
8650 if(ltyp.eq.0)then
8651 write(ifhi,'(a)') 'htyp lda'
8652 elseif(ltyp.eq.1)then
8653 write(ifhi,'(a)') 'htyp ldo'
8654 elseif(ltyp.eq.2)then
8655 write(ifhi,'(a)') 'htyp lfu'
8656 elseif(ltyp.eq.3)then
8657 write(ifhi,'(a)') 'htyp ldd'
8658 endif
8659 write(ifhi,'(a)') 'xmod lin ymod log'
8660 write(ifhi,'(a,2e11.3)')'xrange',x1,x2
8661 write(ifhi,'(a,e11.3,a)')'yrange',ymin,' auto'
8662 write(ifhi,'(a)') 'text 0 0 "xaxis N?[n]!"'
8663 write(ifhi,'(a)') 'text 0 0 "yaxis P(N?[n]!)"'
8664 write(ifhi,'(a,a)')'text 0.3 0.10 "" "L#N?[n]!"G#='//cyield//'""'
8665 write(ifhi,'(a,a)') 'text 0.3 0.2 "conf?in!='//cinco//'"'
8666 if(iocite.ne.1)then
8667 write(ifhi,'(a,a)') 'text 0.4 0.91 "V='//cvo//'"'
8668 write(ifhi,'(a,a)') 'text 0.15 0.91 "E='//cen//'"'
8669 endif
8670 write(ifhi,'(a)') 'array 2'
8671
8672 do j=1,jx
8673 write(ifhi,'(2e12.4)')datx(j),daty(j)
60ed90b3 8674 enddo
9ef1c2d9 8675
8676 write(ifhi,'(a)') ' endarray'
8677 write(ifhi,'(a)') 'closehisto'
8678
8679
60ed90b3 8680 return
9ef1c2d9 8681 end
8682
8683
8684c-----------------------------------------------------------------------
8685 subroutine xhgcmx
8686c-----------------------------------------------------------------------
8687c creates multiplicity plot for decayed QM-droplet
8688c according to grand canonical results POISSON DISTRIB.!!!!
8689c input:
8690c xpar1 specifies species by paige id, 0 for total multiplicity
8691c xpar2 specifies xrange to be set automatically (0) or by hand (1)
8692c xpar3 and xpar4 xrange if xpar2 ne 0
8693c xpar5 xrange = average+-sigma*xpar5
8694c xpar6 specifies line type : dashed (0), dotted (1), full (2) dado (3)
8695c xpar7 specifies statistics : same as iostat (0)
8696c boltzmann (1)
8697c output:
60ed90b3 8698c histo-file
9ef1c2d9 8699c newpage, zone and plot commands not included !!!
60ed90b3 8700c-----------------------------------------------------------------------
9ef1c2d9 8701 include 'epos.inc'
8702 parameter (nbin=200)
8703 real datx(nbin),daty(nbin)
60ed90b3 8704 parameter (mspecs=56)
9ef1c2d9 8705 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
8706 common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
8707 common/cbol/rmsbol(mspecs),ptlbol(mspecs),chebol(mspecs),tembol
8708 common/cgctot/rmstot,ptltot
8709 character cyield*8,cen*6,cvo*6,cinco*1
60ed90b3 8710
9ef1c2d9 8711
8712 idpa=nint(xpar1)
8713 ixra=nint(xpar2)
8714 iwid=nint(xpar5)
8715 ltyp=nint(xpar6)
8716 ist=nint(xpar7)
8717 if(ist.eq.0.and.iostat.eq.1)ist=1
8718
60ed90b3 8719
9ef1c2d9 8720 id=0
8721 ymin=1./nevent/10.
8722 if(nevent.le.10)ymin=ymin/10.
8723 do i=1,nspecs
8724 if(ispecs(i).eq.idpa)id=i
8725 enddo
60ed90b3 8726
9ef1c2d9 8727 if(ixra.eq.1)then
8728 n1=nint(xpar3)
8729 n2=nint(xpar4)
8730 else
8731 if(id.eq.0)then
8732 n1=nint(ptltot-iwid*rmstot)
8733 n2=nint(ptltot+iwid*rmstot)
60ed90b3 8734 else
9ef1c2d9 8735 n1=nint(ptlngc(id)-iwid*rmsngc(id))
8736 n2=nint(ptlngc(id)+iwid*rmsngc(id))
8737 endif
8738 n2=max(n2,3)
8739 endif
8740
8741 n1=max(n1,0)
8742 jx=n2+1
8743
8744 do j=1,jx
8745 datx(j)=j-1
8746 jf=1
8747 if(j.gt.1)then
8748 do i=1,j-1
8749 jf=jf*i
8750 enddo
8751 endif
8752 if(id.eq.0)then
8753
8754c total multiplicity
8755c ------------------
8756
8757 daty(j)=1./jf*ptltot**(j-1)*exp(-ptltot)
8758
8759 else
60ed90b3 8760
9ef1c2d9 8761c one species (specified by id)
60ed90b3 8762c ------------------------------
9ef1c2d9 8763
8764 if(ist.eq.0)pn=1./jf*ptlngc(id)**(j-1)*exp(-ptlngc(id))
8765 if(ist.eq.1)pn=1./jf*ptlbol(id)**(j-1)*exp(-ptlbol(id))
8766
8767 daty(j)=pn
8768
8769 endif
8770 enddo
8771
8772 if(id.eq.0)then
8773 write(cyield,'(f8.3)')ptltot
8774 else
8775 write(cyield,'(f8.3)')ptlngc(id)
8776 endif
8777 write(cinco,'(i1)')ioinco
8778 write(cen,'(f6.1)')tecm
8779 write(cvo,'(f6.1)')volu
8780 write(ifhi,'(a)') 'openhisto'
8781 if(ltyp.eq.0)then
8782 write(ifhi,'(a)') 'htyp lda'
8783 elseif(ltyp.eq.1)then
8784 write(ifhi,'(a)') 'htyp ldo'
8785 elseif(ltyp.eq.2)then
8786 write(ifhi,'(a)') 'htyp lfu'
8787 elseif(ltyp.eq.3)then
8788 write(ifhi,'(a)') 'htyp ldd'
8789 endif
8790 write(ifhi,'(a)') 'xmod lin ymod log'
8791 write(ifhi,'(a,2i3)')'xrange',n1,n2
8792 write(ifhi,'(a,e11.3,a)')'yrange',ymin,' auto'
8793 write(ifhi,'(a)') 'text 0 0 "xaxis N?[n]!"'
8794 write(ifhi,'(a)') 'text 0 0 "yaxis P(N?[n]!)"'
8795 write(ifhi,'(a,a)')'text 0.3 0.10 "" "L#N?[n]!"G#='//cyield//'""'
8796 write(ifhi,'(a,a)') 'text 0.3 0.2 "conf?in!='//cinco//'"'
8797 if(iocite.ne.1)then
8798 write(ifhi,'(a,a)') 'text 0.4 0.91 "V='//cvo//'"'
8799 write(ifhi,'(a,a)') 'text 0.15 0.91 "E='//cen//'"'
8800 endif
8801 write(ifhi,'(a)') 'array 2'
8802
8803 do j=1,jx
8804 write(ifhi,'(2e12.4)')datx(j),daty(j)
60ed90b3 8805 enddo
9ef1c2d9 8806
8807 write(ifhi,'(a)') ' endarray'
8808 write(ifhi,'(a)') 'closehisto'
8809
8810
60ed90b3 8811 return
9ef1c2d9 8812 end
8813
8814c-----------------------------------------------------------------------
8815 subroutine xhgcpt
8816c-----------------------------------------------------------------------
8817c creates transverse momentum spectrum for decayed QM-droplet
8818c according to grand canonical results
8819c input:
8820c xpar1 specifies particle species by paige id, 0 for all
8821c xpar2 rapidity window
8822c xpar3 and xpar4 specify xrange of plot
8823c xpar5 specifies line type : dashed (0), dotted (1), full (2)
8824c output:
60ed90b3 8825c histo-file
9ef1c2d9 8826c newpage, zone and plot commands not included !!!
8827c-----------------------------------------------------------------------
8828 include 'epos.inc'
8829 common/citer/iter,itermx
8830 parameter (nbin=200)
8831 real datx(nbin),daty(nbin)
60ed90b3 8832 parameter (mspecs=56)
9ef1c2d9 8833 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
8834 common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
8835 character crap*5,cen*6,cvo*6,cit*5
8836
8837 idpa=nint(xpar1)
8838 y=xpar2
8839 x1=xpar3
8840 x2=xpar4
8841 ltyp=xpar5
8842
8843 write(crap,'(f5.1)')y
8844 id=0
8845 jx=100
8846 do i=1,nspecs
8847 if(ispecs(i).eq.idpa)id=i
8848 enddo
8849
8850 dx=(x2-x1)/2./jx
8851 x0=x1+dx
8852
8853 do j=1,jx
8854 datx(j)=x0+(j-1)*dx*2.
8855 daty(j)=0.0
8856
8857 if(id.eq.0)then
8858
8859 do 10 i=1,nspecs
8860 x=100.
8861 if(tem.ne.0.)
8862 *x=(sqrt(aspecs(i)**2+datx(j)**2)*cosh(y)-chemgc(i))/tem
8863 if(x.ge.60)then
8864 dndpt=0.0
8865 else
8866 dndpt=exp(-x)
8867 endif
8868 dndpt=dndpt*gspecs(i)*volu/hquer**3*cosh(y)
8869 **sqrt(aspecs(i)**2+datx(j)**2)/8./pi**3
8870 daty(j)=daty(j)+dndpt
887110 continue
8872
8873 else
8874
8875 x=100.
8876 if(tem.ne.0.)
8877 *x=(sqrt(aspecs(id)**2+datx(j)**2)*cosh(y)-chemgc(id))/tem
8878 if(x.ge.60)then
8879 dndpt=0.0
8880 else
8881 dndpt=exp(-x)
8882 endif
8883 dndpt=dndpt*gspecs(id)*volu/hquer**3*cosh(y)
8884 **sqrt(aspecs(id)**2+datx(j)**2)/8./pi**3
8885 daty(j)=dndpt
8886
8887 endif
8888
8889 enddo
8890
8891 write(cit,'(i5)')itermx
8892 write(cen,'(f6.1)')tecm
8893 write(cvo,'(f6.1)')volu
8894 write(ifhi,'(a)') 'openhisto'
8895 if(ltyp.eq.0)then
8896 write(ifhi,'(a)') 'htyp lda'
8897 elseif(ltyp.eq.1)then
8898 write(ifhi,'(a)') 'htyp ldo'
8899 elseif(ltyp.eq.2)then
8900 write(ifhi,'(a)') 'htyp lfu'
8901 endif
8902 write(ifhi,'(a)') 'xmod lin ymod log'
8903 write(ifhi,'(a,2e11.3)')'xrange',x1,x2
8904 write(ifhi,'(a)') 'text 0 0 "xaxis p?t! (GeV/c)"'
8905 write(ifhi,'(a)') 'text 0 0 "yaxis dN?[n]!/dyd^2!p?t!"'
8906 write(ifhi,'(a)') 'text 0.10 0.10 "y = '//crap//'"'
8907 write(ifhi,'(a)') 'text 0.10 0.30 "i?max! = '//cit//'"'
8908 write(ifhi,'(a,a)') 'text 0.4 0.91 "V='//cvo//'"'
8909 write(ifhi,'(a,a)') 'text 0.15 0.91 "E='//cen//'"'
8910 write(ifhi,'(a)') 'array 2'
8911
8912 do j=1,jx
8913 write(ifhi,'(2e12.4)')datx(j),daty(j)
8914 enddo
8915
8916 write(ifhi,'(a)') ' endarray'
8917 write(ifhi,'(a)') 'closehisto'
8918
8919 return
8920 end
8921
8922c-----------------------------------------------------------------------
8923 subroutine xhgcra
8924c-----------------------------------------------------------------------
8925c creates rapidity distribution for decayed QM-droplet
8926c according to grand canonical results
8927c input:
8928c xpar1 specifies particle species by paige id, 0 for all
8929c xpar2 and xpar3 specify xrange of plot
8930c xpar4 specifies line type : dashed (0), dotted (1), full (2)
8931c output:
60ed90b3 8932c histo-file
9ef1c2d9 8933c newpage, zone and plot commands not included !!!
8934c-----------------------------------------------------------------------
8935 include 'epos.inc'
8936 parameter (nbin=200)
8937 real datx(nbin),daty(nbin)
60ed90b3 8938 parameter (mspecs=56)
9ef1c2d9 8939 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
8940 common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
8941 common/cgctot/rmstot,ptltot
8942 character cen*6,cvo*6,cng*8
8943
8944 idpa=nint(xpar1)
8945 x1=nint(xpar2)
8946 x2=nint(xpar3)
8947 ltyp=nint(xpar4)
8948
8949 id=0
8950 jx=100
8951 ymin=1./nevent/10.
8952 if(nevent.le.10)ymin=ymin/10.
8953 do i=1,nspecs
8954 if(ispecs(i).eq.idpa)id=i
8955 enddo
8956
8957 dx=(x2-x1)/2./jx
8958 x0=x1+dx
8959
8960 do j=1,jx
8961
8962 datx(j)=x0+(j-1)*dx*2.
8963 daty(j)=0.0
8964 y=datx(j)
8965 if(ish.ge.9)write(ifch,*)'cosh y:',cosh(y)
8966
8967 if(id.eq.0)then
8968
8969 do 10 i=1,nspecs
8970 dndy=0.0
8971 sum=aspecs(i)**2*tem+2.*aspecs(i)*tem**2/cosh(y)
8972 *+2.*tem**3/cosh(y)**2
8973 x=100.
8974 if(tem.ne.0.0)
8975 *x=(aspecs(i)*cosh(y)-chemgc(i))/tem
8976
8977 if(x.ge.60.)then
8978 pro=0.0
8979 else
8980 pro=exp(-x)
8981 endif
8982
8983 pro=pro*gspecs(i)*volu/hquer**3/4./pi**2
8984
8985 if(pro.ge.(1.e-30).and.sum.ge.(1.e-30))then
8986 che=alog(pro)+alog(sum)
8987 else
8988 che=-61.0
8989 endif
8990 if(che.le.60.0.and.che.ge.(-60.0))dndy=pro*sum
8991c if(che.le.60.0.and.che.ge.(-60.0))dndy=exp(che)
8992
8993 daty(j)=daty(j)+dndy
8994
60ed90b3 899510 continue
9ef1c2d9 8996
8997 else
8998
8999 dndy=0.0
9000 sum=aspecs(id)**2*tem+2.*aspecs(id)*tem**2/cosh(y)
9001 *+2.*tem**3/cosh(y)**2
9002 x=100.
9003 if(tem.ne.0.0)
9004 *x=(aspecs(id)*cosh(y)-chemgc(id))/tem
9005
9006 if(x.ge.60.)then
9007 pro=0.0
9008 else
9009 pro=exp(-x)
9010 endif
9011
9012 pro=pro*gspecs(id)*volu/hquer**3/4./pi**2
9013
9014 if(pro.ge.(1.e-30).and.sum.ge.(1.e-30))then
9015 che=alog(pro)+alog(sum)
9016 else
9017 che=-61.0
9018 endif
9019 if(che.le.60..and.che.ge.-60.)dndy=pro*sum
9020
9021 daty(j)=dndy
9022
9023 endif
9024
9025 enddo
60ed90b3 9026
9ef1c2d9 9027 write(cen,'(f6.1)')tecm
9028 write(cvo,'(f6.1)')volu
9029 if(id.eq.0)then
9030 write(cng,'(f8.3)')ptltot
9031 else
9032 write(cng,'(f8.3)')ptlngc(id)
9033 endif
9034 write(ifhi,'(a)') 'openhisto'
9035 if(ltyp.eq.0)then
9036 write(ifhi,'(a)') 'htyp lda'
9037 elseif(ltyp.eq.1)then
9038 write(ifhi,'(a)') 'htyp ldo'
9039 elseif(ltyp.eq.2)then
9040 write(ifhi,'(a)') 'htyp lfu'
9041 endif
9042
9043 write(ifhi,'(a)') 'xmod lin ymod log'
9044 write(ifhi,'(a,2e11.3)')'xrange',x1,x2
9045 write(ifhi,'(a,e11.3,a)')'yrange',ymin,' auto'
9046 write(ifhi,'(a)') 'text 0 0 "xaxis y"'
9047 write(ifhi,'(a)') 'text 0 0 "yaxis dN?[n]!/dy"'
9048 write(ifhi,'(a,a)') 'text 0.4 0.91 "V='//cvo//'"'
9049 write(ifhi,'(a,a)') 'text 0.15 0.91 "E='//cen//'"'
9050 write(ifhi,'(a,a)') 'text 0.3 0.10 "N?[n]!='//cng//'"'
9051 write(ifhi,'(a)') 'array 2'
9052
9053 do j=1,jx
9054 write(ifhi,'(2e12.4)')datx(j),daty(j)
9055 enddo
9056
9057 write(ifhi,'(a)') ' endarray'
9058 write(ifhi,'(a)') 'closehisto'
9059
9060 return
9061 end
9062
9063c-----------------------------------------------------------------------
9064 subroutine xhnben
9065c-----------------------------------------------------------------------
9066c produces histogram of energy spectrum (after metropolis run)
9067c complete histogram: openhisto ... closehisto
9068c iocite=1 required
9069c-----------------------------------------------------------------------
9070c xpar1: particle species (venus id-code)
9071c xpar2: 1: actual spectrum 2: fit
9072c xpar3: 1: de/d3p 2: ede/d3e
9073c-----------------------------------------------------------------------
9074 include 'epos.inc'
60ed90b3 9075 parameter (mspecs=56)
9ef1c2d9 9076 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
9077 parameter (nhise=100)
9078 common/chise/hise(mspecs,nhise)
9079 parameter (literm=500)
9080 common/cmet/kspecs(mspecs),liter,lspecs(literm,mspecs)
9081 *,iterl(literm),iterc(literm)
9082 real datx(nhise),daty(nhise),dats(nhise)
9083 common/citer/iter,itermx
9084 character ch*1,chid*5,cyield*9,ctem*5
9085 de=2./nhise/2.
9086
9087 if(iocite.ne.1)stop'STOP: xhnben: iocite=1 required'
9088
9089 idcode=nint(xpar1)
9090 mode=nint(xpar2)
9091 kind=nint(xpar3)
9092
9093 do j=1,nspecs
9094 if(idcode.eq.ispecs(j))then
9095
9096 id=idcode
9097 am=aspecs(j)
9098 yield=1.*kspecs(j)/(itermx-iternc)
9099 if(kind.eq.1)ch=' '
9100 if(kind.eq.2)ch='e'
9101 ll=kind-1
9102 e0=am+de
9103 nebins=0
9104 do i=1,nhise
9105 e=e0+(i-1)*2*de
9106 p1=sqrt((e-de)**2-am**2)
9107 p2=sqrt((e+de)**2-am**2)
9108 d3p=4*pi*(p2**3-p1**3)/3
9109 datx(i)=e
9110 y=(1-ll+ll*e)*hise(j,i)/(itermx-iternc)/d3p
9111 if(y.gt.0.)then
9112 nebins=nebins+1
9113 daty(i)=alog(y)
9114 d=y/sqrt(hise(j,i))
9115 dats(i)=1e10
9116 if(y-d.gt.0.)dats(i)=alog(y+d)-alog(y-d)
9117 else
9118 daty(i)=-100
9119 dats(i)=1e10
9120 endif
9121c-c if(e.lt.0.2)dats(i)=1e10
9122 enddo
9123 a=0.
9124 b=0.
9125 if(nebins.ge.3)then
9126 call utfit(datx,daty,nhise,dats,1,a,b,siga,sigb,chi2,q)
9127 tem=-1./b
9128 if(tem.lt.0.050.or.tem.gt.10.)then
9129 tem=0.
9130 a=0.
9131 b=0.
9132 endif
9133 endif
9134 do i=1,nhise
9135 daty(i)=exp(daty(i))
9136 enddo
9137 write(chid,'(i5)')id
9138 write(cyield,'(f9.4)')yield
9139 ctem=' '
9140 if(tem.gt.0.)write(ctem,'(f5.3)')tem
9141 write(ifhi,'(a)') 'openhisto xrange 0 3'
9142 write(ifhi,'(a)') 'htyp lin xmod lin ymod log'
9143 write(ifhi,'(a,a)') 'text 0 0 "title id='//chid
9144 * ,' N='//cyield//' T='//ctem//'"'
9145 write(ifhi,'(a)') 'text 0 0 "xaxis energy (GeV)"'
60ed90b3 9146 write(ifhi,'(a)') 'text 0 0 "yaxis '//ch//' dn/d3p (GeV-3)"'
9ef1c2d9 9147 write(ifhi,'(a)') 'array 2'
9148 do i=1,nhise
9149 if(mode.eq.1)write(ifhi,'(2e12.4)')datx(i),daty(i)
9150 if(mode.eq.2)write(ifhi,'(2e12.4)')datx(i),exp(a+b*datx(i))
9151 enddo
9152 write(ifhi,'(a)') ' endarray'
9153 write(ifhi,'(a)') 'closehisto'
9154
9155 endif
9156 enddo
9157
9158 return
9159 end
9160
9161c-----------------------------------------------------------------------
9162 subroutine xhnbit
9163c-----------------------------------------------------------------------
9164c produces histogram of multiplicity versus iterations (after metropolis run)
9165c complete histogram: openhisto ... closehisto
9166c iocite=1 required
9167c-----------------------------------------------------------------------
9168c xpar1: particle species (0=all, else venus id-code)
9169c xpar2: 1:actual multiplicity 2:average multiplicity 3:grand canonical
9170c-----------------------------------------------------------------------
9171 include 'epos.inc'
60ed90b3 9172 parameter (mspecs=56)
9ef1c2d9 9173 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
9174 parameter (literm=500)
9175 common/cmet/kspecs(mspecs),liter,lspecs(literm,mspecs)
9176 *,iterl(literm),iterc(literm)
9177 real datlx(literm),datly(literm)
9178 common/citer/iter,itermx
9179 character chid*5,ctecm*5,cvolu*6
9180 common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
9181 common/cgctot/rmstot,ptltot
9182
9183 if(iocite.ne.1)stop'STOP: xhnbit: iocite=1 required'
9184
9185 idcode=nint(xpar1)
9186 mode=nint(xpar2)
9187
9188 if(idcode.eq.0)then
9189
9190 yield=0
9191 do j=1,nspecs
9192 yield=yield+1.*kspecs(j)/(itermx-iternc)
9193 enddo
9194 datlx(1)=(iterl(1)+1)/2.
9195 do li=2,liter-1
9196 datlx(li)=(iterl(li)+iterl(li-1)+1)/2.
9197 enddo
9198 x1=0
9199 x2=iterl(liter-1)
9200 do li=1,liter-1
9201 y=0
9202 do j=1,nspecs
9203 y=y+lspecs(li,j)
9204 enddo
9205 if(mode.eq.1)datly(li)=y/iterc(li)
9206 if(mode.eq.2)datly(li)=yield
9207 if(mode.eq.3)datly(li)=ptltot
9208 enddo
9209 write(ctecm,'(f5.1)')tecm
9210 write(cvolu,'(f6.1)')volu
9211 write(ifhi,'(a,2e11.3)')'openhisto xrange',x1,x2
9212 write(ifhi,'(a)') 'htyp lin xmod lin ymod lin'
9213 write(ifhi,'(a,a)') 'text 0 0 "title E = '//ctecm//' V = '
9214 * ,cvolu//'"'
9215 write(ifhi,'(a)') 'text 0 0 "xaxis iterations"'
9216 write(ifhi,'(a)') 'text 0 0 "yaxis multiplicity"'
9217 write(ifhi,'(a)') 'array 2'
9218 do i=1,liter-1
9219 write(ifhi,'(2e12.4)') datlx(i),datly(i)
9220 enddo
9221 write(ifhi,'(a)') ' endarray'
9222 write(ifhi,'(a)') 'closehisto'
9223
9224 else
9225
9226 do j=1,nspecs
9227 if(idcode.eq.ispecs(j))then
9228
9229 yield=1.*kspecs(j)/(itermx-iternc)
9230 write(chid,'(i5)')idcode
9231 do li=1,liter-1
9232 datlx(li)=iterl(li)
9233 enddo
9234 x1=0
9235 x2=datlx(liter-1)
9236 do li=1,liter-1
9237 if(mode.eq.1)datly(li)=lspecs(li,j)*1./iterc(li)
9238 if(mode.eq.2)datly(li)=yield
9239 if(mode.eq.3)datly(li)=ptlngc(j)
9240 enddo
9241 write(ifhi,'(a,2e11.3)')'openhisto xrange',x1,x2
9242 write(ifhi,'(a)') 'htyp lin xmod lin ymod lin'
9243 write(ifhi,'(a)') 'text 0 0 "title id='//chid//'"'
9244 write(ifhi,'(a)') 'text 0 0 "xaxis iterations "'
9245 write(ifhi,'(a)') 'text 0 0 "yaxis multiplicity"'
9246 write(ifhi,'(a)') 'array 2'
9247 do i=1,liter-1
9248 write(ifhi,'(2e12.4)') datlx(i),datly(i)
9249 enddo
9250 write(ifhi,'(a)') ' endarray'
9251 write(ifhi,'(a)') 'closehisto'
9252
9253 endif
9254 enddo
9255
9256 endif
9257
9258 return
9259 end
9260
9261c-----------------------------------------------------------------------
9262 subroutine xhnbmu
9263c-----------------------------------------------------------------------
9264c produces histogram of multiplicity distribution (after metropolis run)
9265c complete histogram: openhisto ... closehisto
9266c iocite=1 required
9267c-----------------------------------------------------------------------
9268c xpar1: particle species (0=all, else venus id-code)
9269c xpar2: xrange automatic (0) or given via xpar3,4 (else)
9270c xpar3,4: xrange
9271c-----------------------------------------------------------------------
9272 include 'epos.inc'
60ed90b3 9273 parameter (mspecs=56)
9ef1c2d9 9274 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
9275 parameter (nhismu=500)
9276 common/chismu/hismu(mspecs,0:nhismu),hismus(nhismu)
9277 parameter (literm=500)
9278 common/cmet/kspecs(mspecs),liter,lspecs(literm,mspecs)
9279 *,iterl(literm),iterc(literm)
9280 real datx(nhismu),daty(nhismu)
9281 common/citer/iter,itermx
9282 common /clatt/nlattc,npmax
9283 character chid*5,cyield*9,ctecm*5,cvolu*6
9284
9285 if(iocite.ne.1)stop'STOP: xhnbmu: iocite=1 required'
9286
9287 idcode=nint(xpar1)
9288 ixr=nint(xpar2)
9289 xx1=xpar3
9290 xx2=xpar4
9291
9292 write(ctecm,'(f5.1)')tecm
9293 write(cvolu,'(f6.1)')volu
9294
9295 if(idcode.eq.0)then
9296
9297 yield=0
9298 do j=1,nspecs
9299 yield=yield+1.*kspecs(j)/(itermx-iternc)
9300 enddo
9301 write(cyield,'(f9.4)')yield
9302 i1=0
9303 i2=nlattc
9304 mus=0
9305 do i=1,nhismu
9306 if(i1.eq.0.and.nint(hismus(i)).gt.0)i1=i
9307 if(nint(hismus(i)).gt.0)i2=i
9308 mus=mus+hismus(i)
9309 enddo
9310 ij=0.5*(i1+i2)*0.20
9311 if(itermx.le.1000)ij=0.5*(i1+i2)*0.40
9312 if(itermx.le.100)ij=0.5*(i1+i2)*0.80
9313 i1=i1-ij
9314 i1=max(i1,2)
9315 i2=i2+ij
9316 ii=10
9317 if(i1.le.50)ii=5
9318 if(i1.le.20)ii=2
9319 i1=i1/ii*ii
9320 i2=i2/ii*ii+ii
9321 do i=i1,i2
9322 l=1+i-i1
9323 datx(l)=i
9324 daty(l)=hismus(i)/mus
9325 enddo
9326 jx=1+i2-i1
9327 if(ixr.eq.0)then
9328 x1=i1
9329 x2=i2
9330 else
9331 x1=xx1
9332 x2=xx2
9333 endif
9334 write(ifhi,'(a,2e11.3)')'openhisto xrange',x1,x2
9335 write(ifhi,'(a)') 'htyp lin xmod lin ymod log'
9336 write(ifhi,'(a,a)') 'text 0 0 "title E = '//ctecm//' V = '
9337 * ,cvolu//'"'
9338 write(ifhi,'(a)') 'text 0 0 "xaxis multiplicity n "'
9339 write(ifhi,'(a)') 'text 0 0 "yaxis dN/dn"'
60ed90b3 9340 write(ifhi,'(a)') 'text 0.30 0.25 "N?MC!='//cyield//'"'
9ef1c2d9 9341 write(ifhi,'(a)') 'array 2'
9342 do i=1,jx
9343 write(ifhi,'(2e12.4)') datx(i),daty(i)
9344 enddo
9345 write(ifhi,'(a)') ' endarray'
9346 write(ifhi,'(a)') 'closehisto'
9347
9348 else
9349
9350 do j=1,nspecs
9351 if(idcode.eq.ispecs(j))then
9352
9353 yield=1.*kspecs(j)/(itermx-iternc)
9354 write(cyield,'(f9.4)')yield
9355 write(chid,'(i5)')idcode
9356 i1=0
9357 i2=nlattc
9358 mus=0
9359 do i=0,nhismu
9360 if(i1.eq.0.and.nint(hismu(j,i)).gt.0)i1=i
9361 if(nint(hismu(j,i)).gt.0)i2=i
9362 mus=mus+hismu(j,i)
9363 enddo
9364 ij=0.5*(i1+i2)*0.30
9365 if(itermx.le.1000)ij=0.5*(i1+i2)*0.60
9366 if(itermx.le.100)ij=0.5*(i1+i2)*1.20
9367 i1=i1-ij
9368 i1=max(i1,0)
9369 i2=i2+ij
9370 ii=10
9371 if(i1.le.50)ii=5
9372 if(i1.le.20)ii=2
9373 i1=i1/ii*ii
9374 i2=i2/ii*ii+ii
9375 do i=i1,i2
9376 l=1+i-i1
9377 datx(l)=i
9378 daty(l)=hismu(j,i)/mus
9379 enddo
9380 jx=1+i2-i1
9381 if(ixr.eq.0)then
9382 x1=i1
9383 x2=i2
9384 else
9385 x1=xx1
9386 x2=xx2
9387 endif
9388 write(ifhi,'(a,2e11.3)')'openhisto xrange',x1,x2
9389 write(ifhi,'(a)') 'htyp lin xmod lin ymod log'
9390 write(ifhi,'(a)') 'text 0 0 "title id='//chid//'"'
9391 write(ifhi,'(a)') 'text 0 0 "xaxis multiplicity n "'
9392 write(ifhi,'(a)') 'text 0 0 "yaxis dN/dn"'
60ed90b3 9393 write(ifhi,'(a)') 'text 0.30 0.25 "N?MC!='//cyield//'"'
9ef1c2d9 9394 write(ifhi,'(a)') 'array 2'
9395 do i=1,jx
9396 write(ifhi,'(2e12.4)') datx(i),daty(i)
9397 enddo
9398 write(ifhi,'(a)') ' endarray'
9399 write(ifhi,'(a)') 'closehisto'
9400
9401 endif
9402 enddo
9403
9404 endif
9405
9406 return
9407 end
9408
9409c-----------------------------------------------------------------------
9410 subroutine xhnbmz
9411c-----------------------------------------------------------------------
60ed90b3 9412c produces histogram of multiplicity distribution from droplet decay
9ef1c2d9 9413c or average multiplicity versus iterations
9414c for massless hadrons
9415c complete histogram: openhisto ... closehisto
9416c-----------------------------------------------------------------------
9417c xpar1: particle species (0=all, else venus id-code)
9418c xpar2: lower limit multiplicity
9419c xpar3: upper limit multiplicity
9420c xpar4: lower limit total multiplicity (also necc for xpar1.ne.0)
9421c xpar5: upper limit " " (also necc for xpar1.ne.0)
60ed90b3 9422c xpar6: sets htyp: 1->lfu, 2->ldo, 3->lda, 4->ldd
9ef1c2d9 9423c xpar7: 0: multiplicity distribution
9424c >0: av multiplicity vs iterations (itermx=xpar7)
9425c-----------------------------------------------------------------------
9426 include 'epos.inc'
9427 parameter(maxp=500)
9428 common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
9429 common/ctst/psulog,wtulog
60ed90b3 9430 parameter (mspecs=56)
9ef1c2d9 9431 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
9432 parameter (nhismu=500)
9433 common/cflac/ifok(nflav,mspecs),ifoa(nflav)
9434 real datx(nhismu),datyu(nhismu)
9435 character cyieur*9
9436 real pzlog(nhismu)
9437 double precision spelog,cc,bb,dsu
9438 common/cyield/yield
9439 character*3 htyp
9440
9441 idcode=nint(xpar1)
9442 x1=xpar2
9443 x2=xpar3
9444 i1=nint(xpar2)
9445 i2=nint(xpar3)
9446 ii1=nint(xpar4)
9447 ii2=nint(xpar5)
9448 ih=nint(xpar6)
9449 htyp='lin'
9450 if(ih.eq.1)htyp='lfu'
9451 if(ih.eq.2)htyp='ldo'
9452 if(ih.eq.3)htyp='lda'
9453 if(ih.eq.4)htyp='ldd'
9454 itmax=nint(xpar7)
9455
9456 wtrlog=-1e30
9457 do i=ii1,ii2
9458 if(i.ge.2)then
9459 np=i
9460 do k=1,np
9461 ident(k)=110
9462 enddo
9463 call hnbtst(0)
9464 wtzlog=wtulog
9465 if(ioflac.eq.0)call hnbspg(keu,ked,kes,kec,keb,ket,0,np,spelog)
60ed90b3 9466 if(ioflac.ne.0)call hnbspf(keu,ked,kes,kec,keb,ket,0,np,spelog)
9ef1c2d9 9467 wtulog=wtulog+spelog
9468 else
9469 wtzlog=-1000
9470 wtulog=-1000
9471 endif
9472 pzlog(1+i-ii1)=wtzlog
9473 datyu(1+i-ii1)=wtulog
9474 wtrlog=max(wtrlog,wtulog)
9475 enddo
9476 yield=0
9477 su=0
9478 do i=ii1,ii2
9479 l=1+i-ii1
9480 pzlog(l)=pzlog(l)-wtrlog
9481 datyu(l)=datyu(l)-wtrlog
9482 if(datyu(l).gt.-50.)then
9483 datyu(l)=exp(datyu(l))
9484 else
9485 datyu(l)=exp(-50.)
60ed90b3 9486 endif
9ef1c2d9 9487 yield=yield+i*datyu(l)
9488 su=su+datyu(l)
9489 enddo
9490 yield=yield/su
9491 do i=ii1,ii2
9492 l=1+i-ii1
9493 datx(l)=i
9494 datyu(l)=datyu(l)/su
9495 enddo
9496 jx=1+ii2-ii1
9497 write(cyieur,'(f9.4)')yield
9498c ---
9499 if(idcode.eq.0.and.itmax.eq.0)then
9500 write(ifhi,'(a,2e11.3)')'openhisto xrange',x1,x2
9501 write(ifhi,'(a)') 'htyp '//htyp//' xmod lin ymod log'
60ed90b3 9502 write(ifhi,'(a)') 'text 0.30 0.15 "N?ana!='//cyieur//'"'
9ef1c2d9 9503 write(ifhi,'(a)') 'array 2'
9504 do i=1,jx
9505 write(ifhi,'(2e12.4)') datx(i),datyu(i)
9506 enddo
9507 write(ifhi,'(a)') ' endarray'
9508 write(ifhi,'(a)') 'closehisto'
9509 elseif(idcode.eq.0)then
9510 write(ifhi,'(a,2e11.3)')'openhisto xrange',0.,itmax*1.
9511 write(ifhi,'(a)') 'htyp '//htyp//' xmod lin ymod lin'
9512 write(ifhi,'(a)') 'array 2'
9513 itm=20
9514 do i=1,itm
9515 write(ifhi,'(2e12.4)') (i-1.)*itmax/(itm-1.),yield
9516 enddo
9517 write(ifhi,'(a)') ' endarray'
9518 write(ifhi,'(a)') 'closehisto'
9519 endif
9520c ---
9521 if(idcode.eq.0)return
9522
9523 do j=1,nspecs
9524 if(idcode.eq.ispecs(j))then
9525
9526 wtrlog=-1e30
9527 do i=i1,i2
9528 l=1+i-i1
9529 datx(l)=i
9530 enddo
9531 yield=0
9532 suj=0
9533 dsu=su
9534 do i=i1,i2
9535 l=1+i-i1
9536 bb=0
9537 nfi=0
9538 do ntot=max(i+1,ii1),min(i2*nspecs,ii2)
9539 nfi=nfi+1
9540 cc=1d0
9541 do kc=1,i
9542 cc=cc*(1.+ntot-kc)/kc*gspecs(j)
9543 enddo
9544 ku=keu-i*ifok(1,j)
9545 kd=ked-i*ifok(2,j)
9546 ks=kes-i*ifok(3,j)
9547 kc=kec-i*ifok(4,j)
9548 kb=keb-i*ifok(5,j)
9549 kt=ket-i*ifok(6,j)
9550 if(ioflac.eq.0)call hnbspg(ku,kd,ks,kc,kb,kt,j,ntot-i,spelog)
9551 if(ioflac.ne.0)call hnbspf(ku,kd,ks,kc,kb,kt,j,ntot-i,spelog)
9552 cc=cc*dexp(spelog)
9553 bb=bb+cc*dexp(1.d0*pzlog(1+ntot-ii1))/dsu
9554 enddo
9555 datyu(l)=bb
9556 yield=yield+i*datyu(l)
9557 suj=suj+datyu(l)
9558 enddo
9559 yield=yield/suj
9560 jx=1+i2-i1
9561 write(cyieur,'(f9.4)')yield
9562c ---
9563 if(itmax.eq.0)then
9564 write(ifhi,'(a,2e11.3)')'openhisto xrange',x1,x2
9565 write(ifhi,'(a)') 'htyp '//htyp//' xmod lin ymod log'
60ed90b3 9566 write(ifhi,'(a)') 'text 0.30 0.15 "N?ana!='//cyieur//'"'
9ef1c2d9 9567 write(ifhi,'(a)') 'array 2'
9568 do i=1,jx
9569 write(ifhi,'(2e12.4)') datx(i),datyu(i)
9570 enddo
9571 write(ifhi,'(a)') ' endarray'
9572 write(ifhi,'(a)') 'closehisto'
9573 else
9574 write(ifhi,'(a,2e11.3)')'openhisto xrange',0.,itmax*1.
9575 write(ifhi,'(a)') 'htyp '//htyp//' xmod lin ymod lin'
9576 write(ifhi,'(a)') 'array 2'
9577 itm=20
9578 do i=1,itm
9579 write(ifhi,'(2e12.4)') (i-1.)*itmax/(itm-1.),yield
9580 enddo
9581 write(ifhi,'(a)') ' endarray'
9582 write(ifhi,'(a)') 'closehisto'
9583 endif
9584c ---
9585 return
9586
9587 endif
9588 enddo
9589
9590 end
9591
9592c-----------------------------------------------------------------------
9593 subroutine xhnbte(iii)
9594c-----------------------------------------------------------------------
9595c fills histograms (iii>=0) or writes histogram to histo-file (iii<0)
9596c regarding exponential autocorrelation time and acceptance rate
9597c
9598c input:
60ed90b3 9599c requires complete run with application hadron (iappl=1)
9ef1c2d9 9600c or application metropolis (iappl=4)
9601c ioceau=1 necessary
9602c
9603c output:
9604c for iii=0 (only valid for iappl=4):
9605c data(nrevt): nrevt (event number) /cdat/
9606c datb(nrevt): taui (calculated corr time) /cdat/
60ed90b3 9607c datc(nrevt): accrat (acceptance rate) /cdat/
9ef1c2d9 9608c datd(nrevt): taue (parametrized corr time) /cdat/
9609c for iii>0 (only valid for iappl=1):
9610c nrclu=nrclu+1 /cnrclu/
9611c data(nrclu): nrclu (droplet number) /cdat/
9612c datb(nrclu): taui-taue (calc - param corr time) /cdat/
60ed90b3 9613c datc(nrclu): accrat (acceptance rate) /cdat/
9ef1c2d9 9614c datd(nrclu): avnp (average particle number) /cdat/
9615c for iii<0:
9616c writes complete histogram (openhisto ... closehisto) to histofile
9617c for iappl=4: for iappl=1:
9618c xpar1=1: (data,datb,datd) xpar1=1: (data,datb)
9619c xpar1=2: (data,datc) xpar1=2: (data,datd)
9620c xpar1=3: (data,datc)
9621c-----------------------------------------------------------------------
9622 include 'epos.inc'
9623 parameter(maxit=50000)
9624 common/count/nacc,nrej,naccit(maxit),nptot,npit(maxit)
9625 common/citer/iter,itermx
9626 common /clatt/nlattc,npmax
9627 common/cgctot/rmstot,ptltot
60ed90b3 9628 parameter (mspecs=56)
9ef1c2d9 9629 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
9630 common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
9631 parameter (nbin=500)
9632 common/cdat/ data(nbin),datb(nbin),datc(nbin),datd(nbin)
9633 real dev(maxit)
9634 character cobs*5,cnc*5,cdz*5,czer*5
9635 *,cmom*5,cnp*7,cen*7,cvol*7,clatt*5,cit*5
9636 common/ctaue/taue
9637
9638 if(ioceau.ne.1)stop'STOP: ioceau=1 required'
9639 if(iii.eq.0.and.iappl.ne.4)stop'STOP: iappl=4 required'
9640 if(iii.gt.0.and.iappl.ne.1)stop'STOP: iappl=1 required'
9641
9642 if(iii.lt.0)jjj=nint(xpar1)
9643
9644 ish0=ish
9645c ish=98
9646
9647c ----------------
9648 if(iii.ge.0)then
9649c ----------------
9650
9651 if(iii.gt.0)nrclu=nrclu+1
9652 if(nrclu.gt.500)return
9653
9654c mean
9655c ----
9656 xnptot=nptot
9657 avnp=xnptot/(itermx-iternc)
9658 if(ish.ge.9)write(ifch,*)'event:',nrevt,' droplet:',nrclu
9659 *,' avnp:',avnp
9660
9661c calculate corfct_0
9662c ------------------
9663 corzer=0.0
9664 do i=iternc+1,itermx
9665 dev(i)=npit(i)-avnp
9666 corzer=corzer+dev(i)**2
9667 enddo
9668 corzer=corzer/(itermx-iternc)
9669 if(ish.ge.9)write(ifch,*)'c_0:',corzer
9670
9671c calculate corfct_1
9672c ------------------
9673 corone=0.0
9674 do i=iternc+1,itermx-1
9675 corone=corone+dev(i)*dev(i+1)
9676 enddo
9677 corone=corone/(itermx-iternc-1)
9678
9679c calculate initial autocorrelation time
9680c -----------------------------------------
9681 if(corone.gt.1.e-30.and.corzer.gt.1.e-30)then
9682 r=alog(corone)-alog(corzer)
9683 if(ish.ge.9)write(ifch,*)'log rho_1:',r
9684 taui=(-1.)/r
9685 else
9686 taui=0.
9687 endif
9688 if(ish.ge.9)write(ifch,*)'tau_init:',taui
9689
9690c calculate parametrized autocorrelation time (if necessary)
9691c ----------------------------------------------------------
9692 if(taue.eq.0.0)then
9693 e=tecm/volu
9694 b=1.1*(e+0.33)**0.66
9695 a=13.*(e+0.13)**(-0.65)
9696 tm=34.*(e+0.65)**(-0.61)
9697 t=a+b*volu
9698 taue=max(t,tm)
9699 endif
9700
9701c calculate acceptance rate
9702c -------------------------
9703 xa=nacc
9704 ya=itermx
9705 accrat=xa/ya
9706
9707c write to data/b/c/d
9708c -------------------
9709 if(iii.eq.0)then
9710 if(iozevt.gt.0)then
9711 data(nrevt)=iozero
9712 else
9713 data(nrevt)=nrevt
9714 endif
9715 datb(nrevt)=taui
9716 datc(nrevt)=accrat
9717 datd(nrevt)=taue
9718 else
9719 data(nrclu)=nrclu
9720 datb(nrclu)=taui-taue
9721 datc(nrclu)=accrat
9722 datd(nrclu)=avnp
9723 endif
60ed90b3 9724
9725c -----------------------------------
9ef1c2d9 9726 elseif(iii.lt.0.and.iappl.eq.4)then
9727c -----------------------------------
9728
9729 write(cmom,'(i3)')iomom
9730 write(cen,'(f7.3)')tecm
9731 if(ioobsv.eq.0)then
9732 write(cnp,'(f7.3)')ptltot
9733 else
9734 do i=1,nspecs
9735 if(ioobsv.eq.ispecs(i))id=i
9736 enddo
9737 write(cnp,'(f7.3)')ptlngc(id)
9738 endif
9739 write(cvol,'(f7.3)')volu
9740 write(clatt,'(i3)')nlattc
60ed90b3 9741 write(cit,'(i5)')itermx
9ef1c2d9 9742 if(ioobsv.eq.0)then
9743 write(cobs,'(a)')'all'
9744 else
9745 write(cobs,'(i5)')ioobsv
9746 endif
9747 write(cnc,'(i5)')iternc
9748 if(iozevt.eq.0)write(czer,'(i5)')iozero
9749 if(iozevt.gt.0)write(cdz,'(i5)')iozinc
60ed90b3 9750
9ef1c2d9 9751 x1=1
9752 x2=nevent
9753
9754 if(jjj.eq.1)then
9755
9756 write(ifhi,'(a)') 'openhisto'
9757 write(ifhi,'(a)') 'htyp lin xmod lin ymod lin'
9758 if(iozevt.gt.0)then
9759 write(ifhi,'(a)') 'text 0 0 "xaxis iozero"'
9760 else
9761 write(ifhi,'(a)') 'text 0 0 "xaxis event"'
9762 endif
9763 write(ifhi,'(a)') 'text 0 0 "yaxis [t]?exp!"'
9764 write(ifhi,'(a)') 'text 0.05 0.95 "E='//cen//'"'
9765 write(ifhi,'(a)') 'text 0.2 0.95 "V='//cvol//'"'
9766 write(ifhi,'(a)') 'text 0.35 0.95 "N?g!='//cnp//'"'
9767 write(ifhi,'(a)') 'text 0.55 0.95 "observable '//cobs//'"'
9768 write(ifhi,'(a,2e11.3)')'xrange',x1,x2
9769 write(ifhi,'(a)') 'array 2'
9770 do j=1,nevent
9771 write(ifhi,'(2e12.4)')data(j),datb(j)
9772 enddo
9773 write(ifhi,'(a)') ' endarray'
9774 write(ifhi,'(a)') 'closehisto plot 0-'
9775
9776 write(ifhi,'(a)') 'openhisto'
9777 write(ifhi,'(a)') 'htyp lin xmod lin ymod lin'
9778 write(ifhi,'(a,2e11.3)')'xrange',x1,x2
9779 write(ifhi,'(a)') 'array 2'
9780 do j=1,nevent
9781 write(ifhi,'(2e12.4)')data(j),datd(j)
9782 enddo
9783 write(ifhi,'(a)') ' endarray'
9784 write(ifhi,'(a)') 'closehisto'
9785
9786 elseif(jjj.eq.2)then
9787
9788 write(ifhi,'(a)') 'openhisto'
9789 write(ifhi,'(a)') 'htyp lin xmod lin ymod lin'
9790 if(iozevt.gt.0)then
9791 write(ifhi,'(a)') 'text 0 0 "xaxis iozero"'
9792 else
9793 write(ifhi,'(a)') 'text 0 0 "xaxis event"'
9794 endif
9795 write(ifhi,'(a)') 'text 0 0 "yaxis acceptence rate"'
9796 write(ifhi,'(a)') 'text 0.05 0.95 "iomom= '//cmom//'"'
9797 write(ifhi,'(a)') 'text 0.2 0.95 "nlattc= '//clatt//'"'
9798 if(iozevt.eq.0)
9799 *write(ifhi,'(a)') 'text 0.35 0.95 "iozero= '//czer//'"'
9800 write(ifhi,'(a)') 'text 0.55 0.95 "itermx= '//cit//'"'
9801 write(ifhi,'(a)') 'text 0.75 0.95 "iternc= '//cnc//'"'
9802 if(iozevt.gt.0)
9803 *write(ifhi,'(a)') 'text 0.35 0.95 "dzero= '//cdz//'"'
9804 if(iorejz.eq.1)
9805 *write(ifhi,'(a)') 'text 0.25 0.05 "zeros rejected !"'
9806 if(ioinco.ge.1)then
9807 write(ifhi,'(a)') 'text 0.05 0.05 "hot start"'
9808 else
9809 write(ifhi,'(a)') 'text 0.05 0.05 "cold start"'
9810 endif
9811 write(ifhi,'(a,2e11.3)')'xrange',x1,x2
9812 write(ifhi,'(a)') 'array 2'
9813 do j=1,nevent
9814 write(ifhi,'(2e12.4)')data(j),datc(j)
9815 enddo
9816 write(ifhi,'(a)') ' endarray'
9817 write(ifhi,'(a)') 'closehisto'
9818
9819 endif
9820
60ed90b3 9821c -----------------------------------
9ef1c2d9 9822 elseif(iii.lt.0.and.iappl.eq.1)then
9823c -----------------------------------
60ed90b3 9824
9ef1c2d9 9825 if(ioobsv.eq.0)then
9826 write(cobs,'(a)')'all'
9827 else
9828 write(cobs,'(i5)')ioobsv
9829 endif
9830
9831 x1=1
9832 x2=nrclu
9833
9834 if(jjj.eq.1)then
9835
9836 write(ifhi,'(a)') 'openhisto'
9837 write(ifhi,'(a)') 'htyp lin xmod lin ymod lin'
9838 write(ifhi,'(a)') 'text 0 0 "xaxis droplet"'
9839 write(ifhi,'(a)') 'text 0 0 "yaxis [D][t]?exp!"'
9840 write(ifhi,'(a)') 'text 0.05 0.91 "[D][t]?exp!=[t]?measured!
9841 *-[t]?parametrized"'
9842 write(ifhi,'(a,2e11.3)')'xrange',x1,x2
9843 write(ifhi,'(a,a,a)')'yrange',' auto',' auto'
9844 write(ifhi,'(a)') 'array 2'
9845 do j=1,nrclu
9846 write(ifhi,'(2e12.4)')data(j),datb(j)
9847 enddo
9848 write(ifhi,'(a)') ' endarray'
9849 write(ifhi,'(a)') 'closehisto'
9850
9851 elseif(jjj.eq.2)then
9852
9853 write(ifhi,'(a)') 'openhisto'
9854 write(ifhi,'(a)') 'htyp lin xmod lin ymod lin'
9855 write(ifhi,'(a)') 'text 0 0 "xaxis droplet"'
9856 write(ifhi,'(a)') 'text 0 0 "yaxis N?obs!"'
9857 write(ifhi,'(a)') 'text 0.05 0.95 "observable '//cobs//'"'
9858 write(ifhi,'(a,2e11.3)')'xrange',x1,x2
9859 write(ifhi,'(a)') 'array 2'
9860 do j=1,nrclu
9861 write(ifhi,'(2e12.4)')data(j),datd(j)
9862 enddo
9863 write(ifhi,'(a)') ' endarray'
9864 write(ifhi,'(a)') 'closehisto'
9865
9866 elseif(jjj.eq.3)then
9867
9868 write(ifhi,'(a)') 'openhisto'
9869 write(ifhi,'(a)') 'htyp lin xmod lin ymod lin'
9870 write(ifhi,'(a)') 'text 0 0 "xaxis droplet"'
9871 write(ifhi,'(a)') 'text 0 0 "yaxis accep. rate"'
9872 write(ifhi,'(a,2e11.3)')'xrange',x1,x2
9873 write(ifhi,'(a)') 'array 2'
9874 do j=1,nrclu
9875 write(ifhi,'(2e12.4)')data(j),datc(j)
9876 enddo
9877 write(ifhi,'(a)') ' endarray'
9878 write(ifhi,'(a)') 'closehisto'
9879
9880 endif
9881
9882c -----
9883 endif
9884c -----
9885
9886 ish=ish0
9887 return
9888 end
9889
9890c-------------------------------------------------------------------------
9891 subroutine xhnbti(iii)
9892c-------------------------------------------------------------------------
9893c fills histograms (iii=0) or writes histogram to histo-file (iii<0)
9894c regarding integrated autocorrelation time and corresponding multiplicity
9895c and variance
9896c
9897c input:
9898c requires complete run with application metropolis (iappl=4)
9899c iociau=1 necessary
9900c iompar (parameter for windowing algorithm by a.d.sokal) must
9901c be set to 3 < c_M < 11
9902c
9903c output:
9904c for iii=0 (only valid for iappl=4):
9905c data(nrevt): nrevt (event number) /cdat/
9906c datb(nrevt): tau (calculated int corr time) /cdat/
60ed90b3 9907c datc(nrevt): stau (variance tau) /cdat/
9ef1c2d9 9908c datd(nrevt): avnp (multiplicity) /cdat/
9909c date(nrevt): sobs (variance multiplicity) /cdat/
9910c datf(nrevt): (gc multiplicity) /cdat/
9911c for iii=0 and iosngl>0:
9912c writes complete set of histograms (newpage zone 1 3 1
9913c openhisto ... closehisto plot0 ... openhisto ... closehisto plot 0)
60ed90b3 9914c concerning acceptance rate, rejection rate, correlation function
9ef1c2d9 9915c for specific event, specified by value of iosngl (=nrevt+1)
9916c for iii<0:
9917c writes complete histogram (openhisto ... closehisto) to histofile
60ed90b3 9918c xpar1=1: (data,datb,datc)
9919c xpar1=2: (data,datd,date,datf)
9ef1c2d9 9920c------------------------------------------------------------------------
9921 include 'epos.inc'
9922 parameter(maxit=50000)
9923 common/count/nacc,nrej,naccit(maxit),nptot,npit(maxit)
9924 common/citer/iter,itermx
9925 parameter(maxp=500)
9926 common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
9927 common /clatt/nlattc,npmax
9928 common/cgctot/rmstot,ptltot
60ed90b3 9929 parameter (mspecs=56)
9ef1c2d9 9930 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
9931 common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
9932 parameter (nbin=500)
9933 common/cdat2/data(nbin),datb(nbin),datc(nbin),datd(nbin)
9934 *,date(nbin),datf(nbin),datg(nbin),dath(nbin)
9935 common/cdat3/datx(nbin),daty(nbin),datz(nbin),datr(nbin)
9936 *,dats(nbin)
9937 real corfct(maxit),dev(maxit)
9938 character cobs*5,cdz*5,ccuev*5,cmpar*3,ctau*7
9939 character cmom*5,cnp*7,cen*7,cvol*7,clatt*5,cit*5,cavnp*7
9940 character cnacc*10,cnrej*10,caver*10,cioz*5,ciom*3,cnlat*5
9941
9942 if(iociau.ne.1)stop'STOP: iociau=1 required'
9943 if(iii.eq.0.and.iappl.ne.4)stop'STOP: iappl=4 required'
9944 if(iii.gt.0)stop'STOP: iii>0 not supported'
9945
9946 jjj=nint(xpar1)
9947
9948c ----------------
9949 if(iii.eq.0)then
9950c ----------------
60ed90b3 9951
9ef1c2d9 9952c mean
9953c ----
9954 xnptot=nptot
9955 avnp=xnptot/(itermx-iternc)
9956 if(ish.ge.9)write(ifch,*)'event:',nrevt,' avnp:',avnp
9957
9958c normalization of corfct_i
9959c -------------------------
9960 corzer=0.0
9961 do i=iternc+1,itermx
9962 dev(i)=npit(i)-avnp
9963 if(ish.ge.9)write(ifch,*)'i:',i,' dev_i:',dev(i)
9964 corzer=corzer+dev(i)**2
9965 enddo
9966 corzer=corzer/(itermx-iternc)
9967 if(ish.ge.9)write(ifch,*)'c_0:',corzer
9968
9969c calculate corfct_i
9970c ------------------
9971 nt=itermx-iternc-1
9972 do it=1,nt
9973 corfct(it)=0.0
9974 do i=iternc+1,itermx-it
9975 corfct(it)=corfct(it)+dev(i)*dev(i+it)
9976 enddo
9977 corfct(it)=corfct(it)/(itermx-iternc-it)
9978 if(it.le.10.and.ish.ge.9)
9979 *write(ifch,*)'t:',it,' c_t:',corfct(it)
9980 enddo
9981
9982c calculate initial autocorrelation time
9983c -----------------------------------------
9984 if(corfct(1).gt.1.e-30.and.corzer.gt.1.e-30)then
9985 r=alog(corfct(1))-alog(corzer)
9986 if(ish.ge.9)write(ifch,*)'log rho_1:',r
9987 taui=(-1.)/r
9988 else
9989 taui=0.
9990 endif
9991 if(ish.ge.9)write(ifch,*)'tau_init:',taui
9992
9993c calculate integrated autocorrelation time
9994c -----------------------------------------
9995 k=1
9996 mpar=iompar
9997 tau=taui
9998 taux=taui
9999 taum=0.0
10000 if(ish.ge.9)write(ifch,*)'initial tau:',tau,' c_M:',mpar
10001
10002 if(corzer.gt.1.e-30)then
10003
100045 mcut=mpar*abs(taux)
10005 tauo=tau
10006 tau=.5
10007 do it=1,mcut
10008 tau=tau+corfct(it)/corzer
10009 enddo
10010 taum=taum+tau
10011 taux=taum/k
10012 if(ish.ge.9)write(ifch,*)'iteration:',k,' M:',mcut,' tau:',tau
10013 if(mcut.lt.(mpar*tau).or.mcut.gt.(10.*tau))then
10014 dt=abs(tau-tauo)
10015 if(k.lt.20.and.dt.gt.0.2)then
10016 k=k+1
10017 goto5
10018 endif
10019 endif
10020 mcut=mpar*abs(taux)
10021 if(ish.ge.9)write(ifch,*)'tau_mean:',taux,' M:',mcut
10022 tau=0.5
10023 do it=1,mcut
10024 tau=tau+corfct(it)/corzer
10025 enddo
10026
10027 endif
10028
10029 vtau=(2.*mcut+1.)*2./(itermx-iternc)*tau**2
10030 stau=0.0
10031 if(vtau.ge.0.0)stau=sqrt(vtau)
10032 if(ish.ge.9)
10033 *write(ifch,*)'tau_int:',tau,' var:',vtau,' sig:',stau
10034
10035c calculate variance of observable
10036c --------------------------------
10037 vobs=2.*tau*corzer/(itermx-iternc)
10038 sobs=0.0
10039 if(vobs.ge.0.0)sobs=sqrt(vobs)
10040
10041c write to data-f
10042c ---------------
10043 if(ioobsv.eq.0)then
10044 datf(nrevt)=ptltot
10045 else
10046 do j=1,np
10047 if(ioobsv.eq.ispecs(j))id=j
10048 enddo
10049 datf(nrevt)=ptlngc(id)
10050 endif
10051 datb(nrevt)=tau
10052 datc(nrevt)=stau
10053 date(nrevt)=sobs
10054 datd(nrevt)=avnp
10055 if(iozevt.gt.0)then
10056 data(nrevt)=iozero
10057 else
10058 data(nrevt)=nrevt
10059 endif
10060
10061c -------------------------
10062 if(iosngl.eq.nrevt+1)then
10063c -------------------------
10064
10065 nb=itermx/iterpl
10066 if(nb.gt.nbin)nb=nbin
10067
10068 datx(1)=iterpl/2
10069 daty(1)=naccit(1)
10070 datz(1)=1-naccit(1)
10071 if(iterpl.ge.2)then
10072 do j=1,iterpl-1
10073 daty(1)=daty(1)+naccit(1+j)
10074 datz(1)=datz(1)+1-naccit(1+j)
10075 enddo
10076 endif
10077 datr(1)=daty(1)/iterpl
10078 dats(1)=datz(1)/iterpl
10079 do i=2,nb
10080 datx(i)=datx(i-1)+iterpl
10081 daty(i)=daty(i-1)
10082 datz(i)=datz(i-1)
10083 do j=1,iterpl
10084 daty(i)=daty(i)+naccit((i-1)*iterpl+j)
10085 datz(i)=datz(i)+1-naccit((i-1)*iterpl+j)
10086 enddo
10087 datr(i)=daty(i)/i/iterpl
10088 dats(i)=datz(i)/i/iterpl
10089 enddo
10090 b=nacc
10091 c=itermx
10092 avrate=b/c
10093 write(cnacc,'(i6)')nacc
10094 write(cnrej,'(i6)')nrej
10095 write(caver,'(f5.3)')avrate
10096 write(cioz,'(i5)')iozero
10097 write(ciom,'(i3)')iomom
10098 write(cnlat,'(i5)')nlattc
10099 x1=datx(1)
10100 x2=datx(nb)
10101
10102 write(ifhi,'(a)') 'newpage zone 1 3 1 openhisto'
10103 write(ifhi,'(a)') 'htyp lin xmod lin ymod lin'
10104 write(ifhi,'(a)') 'text 0 0 "xaxis iterations"'
10105 write(ifhi,'(a)') 'text 0 0 "yaxis acceptence rate"'
10106 write(ifhi,'(a)') 'text 0.6 0.5 "accepted '//cnacc//'"'
10107 write(ifhi,'(a)') 'text 0.6 0.4 "rejected '//cnrej//'"'
10108 write(ifhi,'(a)') 'text 0.6 0.3 "aver. rate '//caver//'"'
10109 write(ifhi,'(a)') 'text 0.4 0.5 "nlattc='//cnlat//'"'
10110 write(ifhi,'(a)') 'text 0.4 0.4 "iozero='//cioz//'"'
10111 write(ifhi,'(a)') 'text 0.4 0.3 "iomom='//ciom//'"'
10112 write(ifhi,'(a,2e11.3)')'xrange',x1,x2
10113 write(ifhi,'(a)') 'array 2'
10114 do j=1,nb
10115 write(ifhi,'(2e12.4)')datx(j),datr(j)
10116 enddo
10117 write(ifhi,'(a)') ' endarray'
10118 write(ifhi,'(a)') 'closehisto plot 0-'
10119
10120 write(ifhi,'(a)') 'openhisto'
10121 write(ifhi,'(a,2e11.3)')'xrange',x1,x2
10122 write(ifhi,'(a)') 'array 2'
10123 do j=1,nb
10124 write(ifhi,'(2e12.4)')datx(j),dats(j)
10125 enddo
10126 write(ifhi,'(a)') ' endarray'
10127 write(ifhi,'(a)') 'closehisto plot 0'
10128
10129 m=min(mcut,500)
10130 do i=1,m
10131 datg(i)=i
10132 dath(i)=1000.
10133 if(corzer.gt.1.e-30)dath(i)=corfct(i)/corzer
10134 enddo
10135 write(ccuev,'(i5)')nrevt+1
10136 write(cmpar,'(i3)')mpar
10137 write(ctau,'(i7)')tau
10138 x1=1.
10139 x2=m
10140
10141 write(ifhi,'(a)') 'openhisto'
10142 write(ifhi,'(a)') 'htyp lin xmod lin ymod lin'
10143 write(ifhi,'(a)') 'text 0 0 "xaxis t"'
10144 write(ifhi,'(a)') 'text 0 0 "yaxis correl. func."'
10145 write(ifhi,'(a)') 'text 0.8 0.95 "event '//ccuev//'"'
10146 write(ifhi,'(a)')'text 0.05 0.95 "window parameter= '//cmpar//'"'
10147 write(ifhi,'(a)') 'text 0.35 0.95 "tau= '//ctau//'"'
10148 write(ifhi,'(a,2e11.3)')'xrange',x1,x2
10149 write(ifhi,'(a,a,a)')'yrange',' auto',' auto'
10150 write(ifhi,'(a)') 'array 2'
10151 do j=1,m
10152 write(ifhi,'(2e12.4)')datg(j),dath(j)
10153 enddo
10154 write(ifhi,'(a)') ' endarray'
10155 write(ifhi,'(a)') 'closehisto plot 0'
10156
10157c -----
10158 endif
10159c -----
10160
10161c --------------------
10162 elseif(iii.lt.0)then
10163c --------------------
10164
10165 write(cmom,'(i3)')iomom
10166 if(ioobsv.eq.0)then
10167 write(cnp,'(f7.3)')ptltot
10168 else
10169 do j=1,np
10170 if(ioobsv.eq.ispecs(j))id=j
10171 enddo
10172 write(cnp,'(f7.3)')ptlngc(id)
10173 endif
10174 write(cen,'(f7.3)')tecm
10175 write(cvol,'(f7.3)')volu
10176 write(clatt,'(i3)')nlattc
10177 write(cit,'(i5)')itermx
10178 write(cavnp,'(f7.3)')avnp
10179 if(iozevt.gt.0)
10180 *write(cdz,'(i5)')iozinc
10181 write(cmpar,'(i3)')mpar
10182 if(ioobsv.eq.0)then
10183 write(cobs,'(a)')'all'
10184 else
10185 write(cobs,'(i5)')ioobsv
10186 endif
10187
10188 x1=data(1)
10189 x2=data(nevent)
10190
10191 if(jjj.eq.1)then
10192
10193 write(ifhi,'(a)') 'openhisto'
10194 write(ifhi,'(a)') 'htyp pnt xmod lin ymod lin'
10195 if(iozevt.gt.0)then
10196 write(ifhi,'(a)') 'text 0 0 "xaxis iozero"'
10197 else
10198 write(ifhi,'(a)') 'text 0 0 "xaxis event"'
10199 endif
10200 write(ifhi,'(a)') 'text 0 0 "yaxis [t]?int!"'
10201 write(ifhi,'(a)')'text 0.05 0.95 "window parameter '//cmpar//'"'
10202 if(iozevt.gt.0)
10203 *write(ifhi,'(a)') 'text 0.8 0.95 "dzero= '//cdz//'"'
10204 write(ifhi,'(a,2e11.3)')'xrange',x1,x2
10205 write(ifhi,'(a)') 'array 3'
10206 do j=1,nevent
10207 write(ifhi,'(3e12.4)')data(j),datb(j),datc(j)
10208 enddo
10209 write(ifhi,'(a)') ' endarray'
10210 write(ifhi,'(a)') 'closehisto'
10211
10212 elseif(jjj.eq.2)then
10213
10214 write(ifhi,'(a)') 'openhisto'
10215 write(ifhi,'(a)') 'htyp pnt xmod lin ymod lin'
10216 if(iozevt.gt.0)then
10217 write(ifhi,'(a)') 'text 0 0 "xaxis iozero"'
10218 else
10219 write(ifhi,'(a)') 'text 0 0 "xaxis event"'
10220 endif
10221 write(ifhi,'(a)') 'text 0 0 "yaxis multiplicity"'
10222 write(ifhi,'(a)') 'text 0.05 0.95 "E='//cen//'"'
10223 write(ifhi,'(a)') 'text 0.2 0.95 "V='//cvol//'"'
10224 write(ifhi,'(a)') 'text 0.35 0.95 "N?g!='//cnp//'"'
10225 write(ifhi,'(a)') 'text 0.55 0.95 "observable '//cobs//'"'
10226 write(ifhi,'(a,2e11.3)')'xrange',x1,x2
10227 write(ifhi,'(a,a,a)')'yrange',' auto',' auto'
10228 write(ifhi,'(a)') 'array 3'
10229 do j=1,nevent
10230 write(ifhi,'(3e12.4)')data(j),datd(j),date(j)
10231 enddo
10232 write(ifhi,'(a)') ' endarray'
10233 write(ifhi,'(a)') 'closehisto plot 0-'
10234
10235
10236 write(ifhi,'(a)') 'openhisto'
10237 write(ifhi,'(a)') 'htyp lda xmod lin ymod lin'
10238 write(ifhi,'(a)') 'array 2'
10239 do j=1,nevent
10240 write(ifhi,'(2e12.4)')data(j),datf(j)
10241 enddo
10242 write(ifhi,'(a)') ' endarray'
10243 write(ifhi,'(a)') 'closehisto'
10244
10245 endif
10246
10247c -----
10248 endif
60ed90b3 10249c -----
9ef1c2d9 10250
60ed90b3 10251 return
9ef1c2d9 10252 end