1 c----------------------------------------------------------------------
3 c----------------------------------------------------------------------
4 c microcanonical decay of cluster specified via keu...ket, tecm, volu
5 c----------------------------------------------------------------------
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
12 common /cttaus/ tpro,zpro,ttar,ztar,ttaus,detap,detat
13 integer jc(nflav,2),ic(2)
15 call utpri('amicro',ish,ishini,4)
21 ctp060829 taus=sngl(ttaus)
24 etapro=(ypjtl-yhaha)*etafac
33 if(ish.ge.5)write(ifch,'(a/6i4)')
34 *' keu ked kes kec keb ket:',keu,ked,kes,kec,keb,ket
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
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
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
60 if(real((keu+ked+kes)/3).ne.real(keu+kes+ked)/3.) goto 10
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
77 if(jc(nf,ij).ge.10)idr=7*10**8
80 if(idr/10**8.ne.7)then
81 call idenco(jc,ic,ireten)
82 c if(ireten.eq.1)call utstop('ametro: idenco ret code = 1&')
83 if(ic(1).eq.0.and.ic(2).eq.0)then
88 idr=8*10**8+ic(1)*100+ic(2)/100
89 if(ish.ge.5)write(ifch,'(a,i9)')' id:',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))
114 radptl(nptl)=(3*volu/pi/4.)**0.33333
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
139 call idtau(idptl(n),pptl(4,n),pptl(5,n),taugm)
141 tivptl(2,n)=t+taugm*(-alog(r))
148 if(ioceau.eq.1)call xhnbte(0)
149 if(iociau.eq.1)call xhnbti(0)
151 call utprix('amicro',ish,ishini,4)
155 c-----------------------------------------------------------------------
157 c-----------------------------------------------------------------------
158 c hadronic resonance gas in grand canonical treatment
159 c returns T, chemical potentials and hadronic yield
160 c (hadron chemical potentials as combinations of quark chemical potentials)
163 c iostat: 1: Boltzmann approximation, 0: quantum statistics /metr3/
164 c tecm: droplet energy /confg/
165 c volu: droplet volume /confg/
166 c keu ked kes kec keb ket: net flavor number /drop5/
169 c tem : temperature [GeV] /cgchg/
170 c chem(1:nflav): quark chem. pot. [GeV] /cflav/
171 c chemgc(1:nspecs): hadron chem. pot. [GeV] /cgchg/
172 c ptlngc(1:nspecs): hadron number /cgchg/
173 c rmsngc(1:nspecs): standard deviation of hadron number /cgchg/
175 c exact treatment (iostat=0):
176 c for massive hadrons : first in Boltzmann approximation with analytical
177 c expressions for particle and energy densities,
178 c then by using quantum statistics in integral form,
179 c extracting mu and T using numerical integration
180 c and an iterative procedure to solve for mu, T
181 c for massless hadrons : using analytic expressions for massles particles
182 c and employing the same algorithm as for massive
183 c-----------------------------------------------------------------------
185 parameter (mspecs=56)
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
196 if(ishsub/100.eq.51)ish=mod(ishsub,100)
215 if(iug.eq.11)nflavs=3
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:'
233 write(ifch,'(1x,a,2x,f7.3,2x,a,2x,f7.3)')
234 *'mass [GeV]:',tecm,'volume [fm^3]:',volu
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)
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)
253 kf=keu+ked+kes+kec+keb+ket
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)
267 c initial T (m=0, baryon free)
268 c -------------------------------
271 if(iostat.eq.0.and.iospec.eq.iug)then
274 if(mod(igsp,2).eq.0)then
275 gfac=gfac+7.*gspecs(i)/8.
280 if(iabs(ispecs(nspecs)).lt.10)gfac=gfac+16.
281 tem=(tecm/volu*hquer**3*30./pi**2/gfac)**.25
286 if(iabs(ispecs(nspecs)).lt.10)gfac=gfac+16.
287 tem=(tecm/volu*hquer**3*pi**2/gfac/3.)**.25
291 if(ish.ge.5)write(ifch,1)'initial T :',tem
292 1 format(1x,a,3x,f9.6)
294 if(ish.ge.5)write(ifch,*)'iospec: ',iospec
296 if(ish.ge.5.and.iospec.ne.iug)then
297 write(ifch,*)'inversion in Boltzmann approx. :'
298 elseif(ish.ge.5.and.iospec.eq.iug)then
299 write(ifch,*)'inversion for massless hadrons :'
303 if(nflavs.eq.1)write(ifch,'(3x,a,8x,a)')
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:'
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)
317 c search for temperature (chem=const)
318 c -----------------------------------
322 if(iospec.eq.iug)then
328 *write(ifch,*)'iteration (massless):',k
330 elseif(iostat.eq.1)then
332 *write(ifch,*)'iteration (Boltzmann, massless):',k
342 c Boltzmann approxiamtion (massive particles)
343 c -------------------------------------------
345 *write(ifch,*)'iteration (Boltzmann, massive):',k
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)
365 if(dt.le.gen*temo.or.dt.le.genm)idt=1
367 c search for chemical potentials (tem=const)
368 c ------------------------------------------
375 if(iospec.eq.iug)then
381 elseif(iostat.eq.1)then
387 c Boltzmann approxiamtion (massive particles)
388 c -------------------------------------------
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
405 c new hadron chem. potentials
406 c ---------------------------
410 if(ish.ge.5.and.nflavs.eq.1)
411 *write(ifch,'(1x,f8.6,2x,f9.6)')
413 if(ish.ge.5.and.nflavs.eq.2)
414 *write(ifch,'(1x,f8.6,2x,f9.6,2x,f9.6)')
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
426 *write(ifch,*)'failure in approximate solution'
433 if(ish.ge.9)call hgccch(0)
434 if(ish.ge.5)write(ifch,'(1x,a,1x,f9.6)')' T :',tem
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)
447 if(ish.ge.5)call hgcchb
453 c checking flavor conservation
454 c ----------------------------
455 if(ish.ge.5)call hgccfc
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)
466 c continue or return approximate values
467 c -------------------------------------
475 if(ish.ge.5)write(ifch,*)('-',i=1,30)
476 *,' exit sr hgcaaa ',('-',i=1,10)
484 if(ish.ge.5)write(ifch,*)'quantum statistics:'
485 if(ish.ge.5.and.nflavs.eq.1)write(ifch,'(3x,a,8x,a)')
487 if(ish.ge.5.and.nflavs.eq.2)write(ifch,'(3x,a,8x,a,6x,a)')
488 *'T:','chemu:','chemd:'
489 if(ish.ge.5.and.nflavs.eq.3)write(ifch,'(3x,a,8x,a,6x,a,6x,a)')
490 *'T:','chemu:','chemd:','chems:'
494 if(ish.ge.9.and.mod(k,10).eq.0)
495 *write(ifch,*)'hgc iteration:',k
502 if(ish.ge.5.and.nflavs.eq.1)
503 *write(ifch,'(1x,f10.8,2x,f10.7)')
505 if(ish.ge.5.and.nflavs.eq.2)
506 *write(ifch,'(1x,f10.8,2x,f10.7,2x,f10.7)')
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)
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)
523 if(dt.le.gen*temo.or.dt.le.genm)idt=1
524 if(ish.ge.9)write(ifch,*)'dtem:',dt
526 c new quark chem. potentials
527 c --------------------------
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
537 c new hadron chem. potentials
538 c ---------------------------
541 if(idch.eq.nflavs.and.idt.eq.1)then
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)
548 51 format(1x,a,3x,f9.6)
552 if(ish.ge.5)call hgcchh(i)
558 c checking flavor conservation
559 c ----------------------------
562 if(ish.ge.5)write(ifch,*)('-',i=1,30)
563 *,' exit sr hgcaaa ',('-',i=1,10)
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)
581 if(ish.ge.5)write(ifch,*)('-',i=1,30)
582 *,' exit sr hgcaaa ',('-',i=1,10)
594 c---------------------------------------------------------------------
596 c---------------------------------------------------------------------
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
606 hgcbi0=sngl(p1+y*(p2+y*(p3+y*(p4+y*(p5+y*(p6+y*p7))))))
610 hgcbi0=(exp(ax)/sqrt(ax))*(q1+y*(q2+y*(q3+y*(q4+y*(q5+y*(q6+y*
611 *(q7+y*(q8+y*q9))))))))
617 c------------------------------------------------------------------------
619 c------------------------------------------------------------------------
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
629 hgcbi1=x*(p1+y*(p2+y*(p3+y*(p4+y*(p5+y*(p6+y*p7))))))
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
641 c---------------------------------------------------------------------
643 c------------------------------------------------------------------------
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/
652 hgcbk0=(-log(x/2.0)*hgcbi0(x))+(p1+y*(p2+y*(p3+y*(p4+y*(p5+y*
656 hgcbk0=(exp(-x)/sqrt(x))*(q1+y*(q2+y*(q3+y*(q4+y*(q5+y*(q6+y*
663 c---------------------------------------------------------------
665 c--------------------------------------------------------------------
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/
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))))))
678 hgcbk1=(exp(-x)/sqrt(x))*(q1+y*(q2+y*(q3+y*(q4+y*(q5+y*(q6+y*
685 c-------------------------------------------------------------------
687 c------------------------------------------------------------------
701 c----------------------------------------------------------------
702 subroutine hgccbo(iba)
703 c----------------------------------------------------------------
704 c returns new chem(iafs) for boltzmann statistics
710 c-----------------------------------------------------------------------
711 common/cnsta/pi,pii,hquer,prom,piom,ainfin
712 common/drop6/tecm,volu
713 parameter (mspecs=56)
714 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
715 common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
717 common/cflavs/nflavs,kef(nflav),chem(nflav)
718 common/cflac/ifok(nflav,mspecs),ifoa(nflav)
719 common/ciakt/gen,iafs,ians,genm
727 c new chemical potential
728 c ----------------------
729 10 chem(iafs)=c1+0.5*(c2-c1)
736 if(ifok(iafs,i).ne.0)then
737 if((chemgc(i)/tem).gt.70.)then
740 hpd=exp(chemgc(i)/tem)
742 if(aspecs(i).ne.0.)then
743 fk2=hgcbk(2,aspecs(i)/tem)
744 hpd=hpd*gspecs(i)*aspecs(i)**2*tem*fk2
747 hpd=hpd*gspecs(i)*tem**3/pi**2/hquer**3
755 dfd=abs(fd-(kef(iafs)/volu))
756 if(dfd.le.abs(gen*(kef(iafs)/volu)).or.dfd.le.genm)return
757 c if(abs(fd).ge.100.)then
763 if(fd.gt.(kef(iafs)/volu))then
777 c----------------------------------------------------------------------
778 subroutine hgccch(iii)
779 c----------------------------------------------------------------------
780 c checks convergence of iterative algorithm
781 c plots iteration values for T and mu_i
782 c----------------------------------------------------------------------
784 parameter (mspecs=56)
785 common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
786 common/cflavs/nflavs,kef(nflav),chem(nflav)
788 common/cdatc/data(nbin),datb(nbin),datc(nbin),datd(nbin)
789 *,date(nbin),datf(nbin),datg(nbin),dath(nbin),dati(nbin)
791 character cen*4,cvol*4,cu*3,cd*3,cs*3
819 write(cen,'(f4.1)')tecm
820 write(cvol,'(f4.1)')volu
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'
836 write(ifhi,'(2e12.4)')data(j),datb(j)
838 write(ifhi,'(a)') ' endarray'
839 write(ifhi,'(a)') 'closehisto plot 0-'
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'
847 write(ifhi,'(2e12.4)')data(j),datf(j)
849 write(ifhi,'(a)') ' endarray'
850 write(ifhi,'(a)') 'closehisto plot 0'
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'
861 write(ifhi,'(2e12.4)')data(j),datc(j)
863 write(ifhi,'(a)') ' endarray'
864 write(ifhi,'(a)') 'closehisto plot 0-'
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'
872 write(ifhi,'(2e12.4)')data(j),datg(j)
874 write(ifhi,'(a)') ' endarray'
875 write(ifhi,'(a)') 'closehisto plot 0'
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'
886 write(ifhi,'(2e12.4)')data(j),datd(j)
888 write(ifhi,'(a)') ' endarray'
889 write(ifhi,'(a)') 'closehisto plot 0-'
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'
897 write(ifhi,'(2e12.4)')data(j),dath(j)
899 write(ifhi,'(a)') ' endarray'
900 write(ifhi,'(a)') 'closehisto plot 0'
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'
911 write(ifhi,'(2e12.4)')data(j),date(j)
913 write(ifhi,'(a)') ' endarray'
914 write(ifhi,'(a)') 'closehisto plot 0-'
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'
922 write(ifhi,'(2e12.4)')data(j),dati(j)
924 write(ifhi,'(a)') ' endarray'
925 write(ifhi,'(a)') 'closehisto plot 0'
933 c-----------------------------------------------------------------------
935 c-----------------------------------------------------------------------
936 c returns new chem(iafs) for massive quantum statistics
942 c-----------------------------------------------------------------------
944 parameter (mspecs=56)
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
957 c new chemical potential
958 c ----------------------
959 10 chem(iafs)=c1+0.5*(c2-c1)
964 if(ifok(iafs,ians).ne.0)then
971 call uttraq(hgcfhn,a,b,hpd)
973 hpd=hpd*gspecs(ians)/2./pi**2/hquer**3
974 fd=fd+hpd*ifok(iafs,ians)
979 dfd=abs(fd-(kef(iafs)/volu))
980 if(dfd.le.abs(gen*(kef(iafs)/volu)).or.dfd.le.genm)return
982 if(fd.gt.(kef(iafs)/volu))then
991 *write(ifch,*)'failure at cex at iafs:',iafs
1000 c------------------------------------------------------------------
1002 c------------------------------------------------------------------
1003 c checks flavor conservation in particle yield
1004 c------------------------------------------------------------------
1006 parameter (mspecs=56)
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)
1012 if(ish.ge.5)write(ifch,*)'checking flavor conservation'
1016 ckef=ckef+ifok(i,ii)*ptlngc(ii)
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'
1022 if(i.eq.3.and.ish.ge.5)write(ifch,*)'s conserved'
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
1034 c----------------------------------------------------------------
1036 c----------------------------------------------------------------
1037 c checks results by numerical integration
1038 c----------------------------------------------------------------
1040 parameter (mspecs=56)
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
1048 if(ish.ge.5)write(ifch,*)
1049 *'check by numer. calc. of expect. values:'
1057 call uttraq(hgcfbe,a,b,cedh)
1059 if(ish.ge.9)write(ifch,*)'cedh:',cedh
1060 ced=cedh*gspecs(ians)/2./pi**2/hquer**3
1064 if(iabs(ispecs(nspecs)).lt.10)
1065 *ceden=ceden+(8.*pi**2*tem**4/15.+bag4rt**4)/hquer**3
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
1079 call uttraq(hgcfbn,a,b,hpd)
1081 hfd=ifok(i,ians)*hpd*gspecs(ians)/2./pi**2/hquer**3
1082 if(ish.ge.9)write(ifch,*)'hfd:',hfd
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
1088 5 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)
1094 if(iced.eq.1.and.icfd.eq.nflavs)then
1095 if(ish.ge.5)write(ifch,*)'results agree'
1097 if(ish.ge.5)write(ifch,*)'results disagree'
1103 c----------------------------------------------------------------
1104 subroutine hgcchh(icorr)
1105 c----------------------------------------------------------------
1106 c checks results by numerical integration
1107 c----------------------------------------------------------------
1109 parameter (mspecs=56)
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
1118 if(ish.ge.5)write(ifch,*)
1119 *'check by numer. calc. of expect. values:'
1128 call uttraq(hgcfhe,a,b,cedh)
1130 if(ish.ge.9)write(ifch,*)'cedh:',cedh
1131 ced=cedh*gspecs(ians)/2./pi**2/hquer**3
1135 if(iabs(ispecs(nspecs)).lt.10)
1136 *ceden=ceden+(8.*pi**2*tem**4/15.+bag4rt**4)/hquer**3
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
1151 call uttraq(hgcfhn,a,b,hpd)
1153 hfd=ifok(i,ians)*hpd*gspecs(ians)/2./pi**2/hquer**3
1154 if(ish.ge.9)write(ifch,*)'hfd:',hfd
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
1160 5 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)
1166 if(iced.eq.1.and.icfd.eq.nflavs)then
1167 if(ish.ge.5)write(ifch,*)'results agree'
1170 if(ish.ge.5)write(ifch,*)'results disagree'
1177 c--------------------------------------------------------------------
1179 c--------------------------------------------------------------------
1180 c returns new quark chemical potentials for massless quantum statistics
1186 c---------------------------------------------------------------------
1188 parameter (mspecs=56)
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
1202 c new chemical potential
1203 c ----------------------
1204 10 chem(iafs)=c1+0.5*(c2-c1)
1211 if(ifok(iafs,i).ne.0)then
1214 if(mod(igsp,2).eq.0)then
1216 if(ispecs(i).gt.0)then
1217 hpd=gspecs(i)*(chemgc(i)*tem**2+chemgc(i)**3/pi**2)/6./hquer**3
1223 c if(ispecs(i).gt.0)then
1224 c hpd=gspecs(i)*(chemgc(i)*tem**2/3.-chemgc(i)**3/pi**2/6.)/hquer**3
1231 c0 xx=n*abs(chemgc(i))/tem
1233 c hpd=hpd+(-1.)**(n+1)/n**3/exp(xx)
1237 c hpd=hpd*gspecs(i)*tem**3/pi**2/hquer**3
1238 c if(chemgc(i).eq.abs(chemgc(i)))then
1239 c hpd=gspecs(i)*(chemgc(i)*tem**2+chemgc(i)**3/pi**2)/6./hquer**3
1244 c hpd=3.*gspecs(i)*tem**3*z3/4./pi**2/hquer**3
1249 hpd=gspecs(i)*tem**3*z3/pi**2/hquer**3
1253 hfd=hpd*ifok(iafs,i)
1259 dfd=abs(fd-(kef(iafs)/volu))
1260 if(dfd.le.abs(gen*(kef(iafs)/volu)).or.dfd.le.genm)return
1262 if(fd.gt.(kef(iafs)/volu))then
1271 *write(ifch,*)'failure at cm0 at iafs:',iafs
1277 c-----------------------------------------------------------------------
1279 c-----------------------------------------------------------------------
1280 c integrand of energy density
1281 c------------------------------------------------------------------------
1282 parameter (mspecs=56)
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
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
1296 hgcfbe=sq*x**2*exp(-eex)
1301 c-----------------------------------------------------------------
1303 c-----------------------------------------------------------------
1304 c integrand of mean square variance of energy
1305 c----------------------------------------------------------------
1306 parameter (mspecs=56)
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
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
1321 hgcfbf=(aspecs(ians)**2+x**2)*x**2*exp(-eex)
1326 c-----------------------------------------------------------------
1328 c-----------------------------------------------------------------
1329 c integrand of hadron density
1330 c-----------------------------------------------------------------
1331 parameter (mspecs=56)
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
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
1346 hgcfbn=x**2*exp(-eex)
1351 c-----------------------------------------------------------------------
1353 c-----------------------------------------------------------------------
1354 c integrand of energy density
1355 c------------------------------------------------------------------------
1356 parameter (mspecs=56)
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
1362 igsp=int(gspecs(ians))
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
1368 if(mod(igsp,2).ne.0)then
1370 if(eex.lt.1.e-10)return
1375 hgcfhe=sq*x**2/(exp(eex)+d)
1380 c-----------------------------------------------------------------
1382 c-----------------------------------------------------------------
1383 c integrand of mean square variance of energy
1384 c----------------------------------------------------------------
1385 parameter (mspecs=56)
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
1391 igsp=int(gspecs(ians))
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
1398 if(mod(igsp,2).ne.0)then
1400 if(eex.lt.1.0e-10.and.eex.gt.(-1.0e-10))return
1405 hgcfhf=(aspecs(ians)**2+x**2)*x**2/(exp(eex)+2.0*d+exp(-eex))
1410 c-----------------------------------------------------------------
1412 c-----------------------------------------------------------------
1413 c integrand of hadron density
1414 c-----------------------------------------------------------------
1415 parameter (mspecs=56)
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
1421 igsp=int(gspecs(ians))
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
1427 if(mod(igsp,2).ne.0)then
1429 if(eex.lt.1.e-10)return
1434 hgcfhn=x**2/(exp(eex)+d)
1439 c-----------------------------------------------------------------
1441 c-----------------------------------------------------------------
1442 c integrand of mean square variance of hadron yield
1443 c----------------------------------------------------------------
1444 parameter (mspecs=56)
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
1450 igsp=int(gspecs(ians))
1452 sq=sqrt(x**2+aspecs(ians)**2)
1453 if(tem.ne.0.0)eex=(sq-chemgc(ians))/tem
1454 if(eex.gt.60.)return
1455 if(eex.lt.(-60.))return
1457 if(mod(igsp,2).ne.0)then
1459 if(eex.lt.1.0e-10.and.eex.gt.(-1.0e-10))return
1464 hgcfhw=x**2/(exp(eex)+2.0*d+exp(-eex))
1470 c-----------------------------------------------------------------
1471 subroutine hgchac(iboco)
1472 c------------------------------------------------------------------
1473 c returns hadronic chemical potentials as combinations of quark
1474 c chemical potentials
1475 c----------------------------------------------------------------------
1477 parameter (mspecs=56)
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)
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)
1489 if(ish.ge.9)write(ifch,*)'mu_nu:',chemgc(i)
1491 if(mod(igsp,2).ne.0.and.chemgc(i).gt.aspecs(i).and.iboco.eq.0)
1492 *chemgc(i)=aspecs(i)
1499 c-----------------------------------------------------------------------
1500 subroutine hgclim(a,b)
1501 c----------------------------------------------------------------------
1502 c returns integration limits for numerical evaluation of particle
1503 c and energy densities using quantum statistics
1504 c----------------------------------------------------------------------
1506 parameter (mspecs=56)
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
1511 igsp=int(gspecs(ians))
1513 if(mod(igsp,2).ne.0)then
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)
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
1528 if(ish.ge.9)write(ifch,*)'ians:',ians,' a:',a,' b:',b
1532 c------------------------------------------------------------------------
1533 subroutine hgcnbi(iret)
1534 c-----------------------------------------------------------------------
1535 c uses hgcaaa results to generate initial hadron set, nlattc, iozero
1537 c ptlngc(1:nspecs): particle number expectation values /cgchg/
1539 c nump: number of hadrons /chnbin/
1540 c ihadro(1:nump): hadron ids /chnbin/
1541 c nlattc: lattice size /clatt/
1542 c iozero: zero weight /metr1/
1543 c-----------------------------------------------------------------------
1546 common/chnbin/nump,ihadro(maxp)
1547 parameter (mspecs=56)
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)
1557 common/cgck/k(nflav),kp(nflav),kps(nflav)
1558 *,idp(maxp),ida(mspecs),idb(mspecs)
1563 if(ishsub/100.eq.50)ish=mod(ishsub,100)
1565 if(ish.ge.7)write(ifch,*)('-',l=1,10)
1566 *,' entry sr hgcnbi ',('-',l=1,30)
1570 iug=(1+iospec)/2*2-1
1571 if(iug.lt.9)call utstop('hgcnbi: iospec < 9&')
1580 elseif(ionlat.eq.2)then
1585 elseif(ionlat.eq.3)then
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)
1596 if(ish.ge.7)write(ifch,*)'nlattc:',nlattc
1600 if(iozero.eq.-1)then
1602 elseif(iozero.eq.-2)then
1603 iozero=nspecs*int(sqrt(volu/tecm))
1606 c modify iozero for testing
1607 c -------------------------
1609 iozero=(nrevt/iozevt+1)*iozinc !nrevt=event number - 1 !!
1610 write(ifch,*)'nrevt+1:',nrevt+1,' iozero:',iozero
1613 c initial hadron set
1614 c ------------------
1616 if(tecm.lt.ammin)then
1617 write(ifch,*)'impossible to generate hadron configuration'
1618 call utstop('hgcnbi: tecm less than two pi0 masses&')
1627 write(ifch,*)'failed to generate hadron set for'
1629 write(ifch,*)'u d s :',keu,ked,kes,' E:',tecm
1630 write(ifch,*)('-',i=1,30)
1631 *,' exit sr hgcnbi ',('-',i=1,10)
1645 if(ish.ge.7)write(ifch,*)
1646 *'sample hadron multiplicities and total mass:'
1649 kpar=iabs(keu)+iabs(ked)+iabs(kes)
1651 if(ish.ge.7)write(ifch,*)'baryon number:',nbar,' parton number:'
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
1678 c start with nb protons
1679 nptlgc(19)=nptlgc(19)+nb
1681 amtot=amtot+nb*aspecs(19)
1683 k(ii)=k(ii)-ifok(ii,19)*nb
1694 if(ib.gt.nspecs)ib=nspecs
1696 kb=ifok(1,ib)+ifok(2,ib)+ifok(3,ib)
1697 if(rangen().lt.0.5.and.nptlgc(ib).ge.1)then
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
1710 if(ptlngc(ib).gt.5.0)then
1715 if(ish.ge.9)write(ifch,*)'pnlog:',pnlog
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
1738 pmla=hgcpml(ib,0,ib,0)
1739 pmlb=hgcpml(ib,ni,ib,0)
1741 if(ish.ge.9)write(ifch,*)'pmlog:',pmlog
1752 nptlgc(ib)=nptlgc(ib)+ni
1754 amtot=amtot+ni*aspecs(ib)
1756 k(ii)=k(ii)-ifok(ii,ib)*ni
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:'
1768 if(n.ge.nn.and.ioinco.ne.2)goto102
1782 c if(ish.ge.7)write(ifch,*)'add protons: nba:',nba
1783 c nptlgc(19)=nptlgc(19)+nba
1785 c amtot=amtot+aspecs(19)*nba
1786 c elseif(nbar.lt.0)then
1787 c if(ish.ge.7)write(ifch,*)'add aprotons: nba:',nba
1788 c nptlgc(20)=nptlgc(20)+nba
1790 c amtot=amtot+aspecs(20)*nba
1793 if(n.lt.nn.and.ioinco.ne.2)then
1800 if(ish.ge.7)write(ifch,*)'add pions/etas: ndd:',ndd
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)
1812 nptlgc(1)=nptlgc(1)+1
1813 amtot=amtot+aspecs(1)
1815 nptlgc(2)=nptlgc(2)+1
1816 nptlgc(3)=nptlgc(3)+1
1817 amtot=amtot+aspecs(2)+aspecs(3)
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)
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)
1835 if(amtot.ge.tecm.and.ioinfl.ge.0)then
1836 if(ish.ge.7)write(ifch,*)
1837 *'total mass exceeded , redo configuration'
1845 write(ifch,*)'u d s :',keu,ked,kes,' E:',tecm
1847 *'hadron set without flavor conservation:'
1854 if(iii.gt.maxp)stop'iii>maxp in hgcnbi'
1860 write(ifch,'(1x,10i6)')(idp(i),i=1,iii)
1861 write(ifch,*)'flav defect: u:',k(1),' d:'
1863 write(ifch,*)'M:',amtot,' <M>:',amgc
1865 if(ioinfl.le.0)goto1000
1871 120 if(k(1).ne.0.or.k(2).ne.0.or.k(3).ne.0)then
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:'
1882 if(nptlgc(i).gt.0)then
1889 if(ish.ge.7)write(ifch,*)'no proposals in a , redo'
1895 xna=0.5+nida*rangen()
1897 if(na.gt.nida)na=nida
1900 if(ish.ge.7)write(ifch,*)'nida:',nida,' ia:',ia
1904 kp(ii)=k(ii)+ifok(ii,ia)
1905 kps(ii)=isign(1,kp(ii))
1907 if(ish.ge.7)write(ifch,*)
1908 *' assemble: u:',kp(1),' d:',kp(2),' s:',kp(3)
1914 naccsp=naccsp+iabs(ifok(ii,i))
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))
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
1928 if(ish.ge.7)write(ifch,*)'no proposals in b , redo'
1933 xnb=0.5+nidb*rangen()
1935 if(nb.gt.nidb)nb=nidb
1938 if(ish.ge.7)write(ifch,*)'nidb:',nidb,' ib:',ib
1939 if(ish.ge.7)write(ifch,*)
1940 *'proposal:',ispecs(ia),' --> ',ispecs(ib)
1944 c if(asym.gt.0.0)then
1946 if(ptlngc(ia).gt.5.0)then
1950 if(ish.ge.7)write(ifch,*)'pnalog:',pnalog
1951 if(pnalog.lt.60)then
1957 if(ptlngc(ia).gt.1.e-20)then
1958 pna=nptlgc(ia)/ptlngc(ia)
1959 elseif(nptlgc(ia).gt.0)then
1966 if(ptlngc(ib).gt.5.0)then
1970 if(ish.ge.7)write(ifch,*)'pnblog:',pnblog
1971 if(pnblog.lt.60)then
1977 pnb=ptlngc(ib)/(nptlgc(ib)+1)
1981 pmli=hgcpml(ia,0,ib,0)
1982 pmlf=hgcpml(ia,-1,ib,1)
1984 if(ish.ge.7)write(ifch,*)'pmlog:',pmlog
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)
2013 k(ii)=k(ii)+ifok(ii,ia)-ifok(ii,ib)
2018 if(k(1).ne.0.or.k(2).ne.0.or.k(3).ne.0)then
2023 if(ish.ge.7)write(ifch,*)'failed to remove defect, redo'
2042 ihadro(nump)=ispecs(i)
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'
2064 if(rmsngc(i).gt.1.e-10)chi=(ptlngc(i)-nptlgc(i))/rmsngc(i)
2065 chitot=chitot+chi**2
2073 u=u+ifok(1,i)*nptlgc(i)
2074 d=d+ifok(2,i)*nptlgc(i)
2075 s=s+ifok(3,i)*nptlgc(i)
2077 call xhgcfl(u,d,s,0)
2078 call xhgcam(amtot,0)
2083 *'initial hadron set for droplet decay:'
2084 write(ifch,'(1x,10i6)')(ihadro(i),i=1,nump)
2086 if(nump.ge.nlattc)then
2089 write(ifch,*)'initial set > nlattc !'
2090 write(ifch,*)'new nlattc:',nlattc
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
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)
2113 c--------------------------------------------------------------------
2114 integer function hgcndn(i)
2115 c--------------------------------------------------------------------
2116 c returns random multiplicity from gaussian distribution for species i
2117 c---------------------------------------------------------------------
2119 parameter (mspecs=56)
2120 common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
2121 common/cgctot/rmstot,ptltot
2122 common/clatt/nlattc,npmax
2134 xn=1.5+(nmax-nmin)*rangen()
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
2143 if(ish.ge.9)write(ifch,*)'hgcndn: k:',kk,' n:',hgcndn
2148 if(ish.ge.9)write(ifch,*)'hgcndn: k:',kk,' n:',hgcndn
2161 xn=-0.5+(nmax-nmin)*rangen()
2163 x=(n-ptlngc(i))**2/2.0
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)
2173 if(p.ge.rangen())then
2175 if(ish.ge.9)write(ifch,*)'hgcndn: k:',kk,' n:',hgcndn
2180 if(ish.ge.9)write(ifch,*)'hgcndn: k:',kk,' n:',hgcndn
2188 c--------------------------------------------------------------------
2189 function hgcpml(i1,n1,i2,n2)
2190 c--------------------------------------------------------------------
2192 parameter (mspecs=56)
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
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
2203 pl=(amtot-amgc+ampr)**2/2.0
2204 if(pl.lt.1.e-30)then
2208 if(samgc.gt.1.e-15)hgcpml=-pl/samgc**2
2210 if(ish.ge.9)write(ifch,*)'hgcpml:',hgcpml
2214 c--------------------------------------------------------------------
2215 function hgcpnl(i,n)
2216 c--------------------------------------------------------------------
2218 parameter (mspecs=56)
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
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
2229 if(rmsngc(i).gt.1.e-15)hgcpnl=-pl/rmsngc(i)**2
2231 if(ish.ge.9)write(ifch,*)'hgcpnl:',hgcpnl
2236 c--------------------------------------------------------------------
2238 c--------------------------------------------------------------------
2239 c returns array for twodimensional plot of energy- and flavor-
2241 c--------------------------------------------------------------------
2242 c xpar1,xpar2 temperature range
2243 c xpar3 # of bins for temperature
2244 c xpar4,xpar5 chem.pot. range
2245 c xpar6 # of bins for chem.pot.
2246 c xpar7 max. density
2247 c xpar8 strange chem.pot.
2248 c--------------------------------------------------------------------
2250 parameter (mspecs=56)
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)
2263 iug=(1+iospec)/2*2-1
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
2288 dt=(xpar2-xpar1)/nbt
2289 dc=(xpar5-xpar4)/nbc
2306 if(ish.ge.5)write(ifch,*)' mu:',chem(1),' T:',tem
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)
2322 hd=hden*gspecs(ians)/2./pi**2/hquer**3
2324 if(ish.ge.7)write(ifch,*)'i:',ians,' n_u:',ifok(1,ians),' hd:',hd
2326 qd=qd+ifok(1,ians)*hd+ifok(2,ians)*hd
2327 if(qd.gt.ymax)qd=ymax
2328 c if(qd.gt.ymax)qd=0.0
2329 if(qd.lt.-ymax)qd=-ymax
2330 c if(qd.lt.-ymax)qd=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)
2340 edi=edi*gspecs(ians)/2./pi**2/hquer**3
2342 if(ish.ge.7)write(ifch,*)'i:',ians,' mu:',chemgc(ians)
2346 if(ed.gt.ymax)ed=ymax
2347 c if(ed.gt.ymax)ed=0.0
2350 if(ish.ge.5)write(ifch,*)' ed:',ed,' qd:',qd
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
2364 write(ifhi,'(e11.3)') edensi(j,jj)
2367 write(ifhi,'(a)') ' endarray'
2368 write(ifhi,'(a)') 'closehisto plot2d'
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
2377 write(ifhi,'(e11.3)') qdensi(j,jj)
2380 write(ifhi,'(a)') ' endarray'
2381 write(ifhi,'(a)') 'closehisto plot2d'
2386 c--------------------------------------------------------------------
2388 c--------------------------------------------------------------------
2389 c returns array for twodimensional plot of energy- and flavor-
2390 c density fluctuations
2391 c--------------------------------------------------------------------
2392 c xpar1,xpar2 temperature range
2393 c xpar3 # of bins for temperature
2394 c xpar4,xpar5 chem.pot. range
2395 c xpar6 # of bins for chem.pot.
2396 c xpar7 max. density
2397 c xpar8 strange chem.pot.
2398 c--------------------------------------------------------------------
2400 parameter (mspecs=56)
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)
2415 iug=(1+iospec)/2*2-1
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
2440 dt=(xpar2-xpar1)/nbt
2441 dv=(xpar5-xpar4)/nbv
2455 if(ish.ge.5)write(ifch,*)'volu:',volu,' tem:',tem
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)
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
2485 if(qv.gt.ymax)qv=ymax
2486 if(qe.gt.ymax)qe=ymax
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)
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
2507 if(ev.gt.ymax)ev=ymax
2508 if(ee.gt.ymax)ee=ymax
2510 if(ish.ge.5)write(ifch,*)'qv:',qv,' ev:',ev
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
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
2532 write(ifhi,'(e11.3)') efl(j,jj)
2535 write(ifhi,'(a)') ' endarray'
2536 write(ifhi,'(a)') 'closehisto plot2d'
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
2545 write(ifhi,'(e11.3)') qfl(j,jj)
2548 write(ifhi,'(a)') ' endarray'
2549 write(ifhi,'(a)') 'closehisto plot2d'
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'
2557 write(ifhi,'(2e13.5)')v(j),we(j)
2559 write(ifhi,'(a)') ' endarray'
2560 write(ifhi,'(a)') 'closehisto plot 0'
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'
2567 write(ifhi,'(2e13.5)')v(j),wn(j)
2569 write(ifhi,'(a)') ' endarray'
2570 write(ifhi,'(a)') 'closehisto plot 0'
2577 c------------------------------------------------------------------
2578 subroutine hgcpyi(ist)
2579 c------------------------------------------------------------------
2580 c returns particle yield
2583 c chemgc: chemical potentials
2585 c ptlngc: expectation value of particle number for each species
2586 c rmsngc: standard deviation of ptlngc
2587 c ptltot: total particle number
2588 c rmstot: standard deviation of ptltot
2589 c works for hadrons and partons
2590 c ist=1 boltzmann statistics
2591 c ist=0 quantum statistics
2592 c--------------------------------------------------------------------
2594 parameter (mspecs=56)
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
2603 if(iabs(ispecs(nspecs)).lt.10)then
2607 if(ish.ge.5)write(ifch,*)'parton yield:'
2608 gln=16.*1.20206*tem**3/pi**2*volu/hquer**3
2610 if(ish.ge.5)write(ifch,'(1x,a,f10.4,2x,a,f9.4,a)')
2611 *'<N( 0)> :',gln,' sigma :',sdg,' (qm-statistics!)'
2618 if(ish.ge.5)write(ifch,*)'hadronic yield:'
2638 call uttraq(hgcfhn,a,b,hden)
2640 ptlngc(ians)=hden*volu*gspecs(ians)/2./pi**2/hquer**3
2644 if((chemgc(ians)/tem).gt.70.)then
2647 hpd=exp(chemgc(ians)/tem)
2649 if(aspecs(ians).ne.0.)then
2650 fk2=hgcbk(2,aspecs(ians)/tem)
2651 hpd=hpd*gspecs(ians)*aspecs(ians)**2*tem*fk2
2654 hpd=hpd*gspecs(ians)*tem**3/pi**2/hquer**3
2656 ptlngc(ians)=hpd*volu
2660 ptltot=ptltot+ptlngc(ians)
2661 amgc=amgc+ptlngc(ians)*aspecs(ians)
2662 if(amgc.ge.tecm)amgc=tecm*0.9
2664 c standard deviation
2665 c ------------------
2670 call uttraq(hgcfhw,a,b,var)
2671 var=var*gspecs(ians)*volu/2./pi**2/hquer**3
2673 if(var.ge.0.0)rmsngc(ians)=sqrt(var)
2674 samgc=samgc+var*aspecs(ians)
2678 if(ptlngc(ians).ge.0.0)rmsngc(ians)=sqrt(ptlngc(ians))
2679 vartot=vartot+ptlngc(ians)
2680 samgc=samgc+ptlngc(ians)*aspecs(ians)
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)
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
2703 c------------------------------------------------------------------------
2704 subroutine hgctbo(iba)
2705 c------------------------------------------------------------------------
2706 c returns new tem using boltzmann statistics in analytic form
2712 c----------------------------------------------------------------------
2714 parameter (mspecs=56)
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
2727 10 tem=t1+.5*(t2-t1)
2728 if(tem.le.1.e-7)return
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)
2738 cba=4.*tem-chemgc(i)
2746 if(tem.ne.0.)x=chemgc(i)/tem
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
2758 edi=y*3.*gspecs(i)*tem**4/pi**2/hquer**3
2765 if(iabs(ispecs(nspecs)).lt.10)
2766 *eden=eden+(8.*pi**2*tem**4/15.+bag4rt**4)/hquer**3
2768 de=abs(eden-(tecm/volu))
2769 if(de.le.gen*(tecm/volu).or.de.le.genm)return
2770 c if(eden.ge.100.)return
2772 if(eden.gt.(tecm/volu))then
2784 c----------------------------------------------------------------------
2786 c----------------------------------------------------------------------
2787 c returns new tem using massive quantum statistics in integral form
2793 c----------------------------------------------------------------------
2795 parameter (mspecs=56)
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
2807 10 tem=t1+.5*(t2-t1)
2809 if(tem.le.1.e-6)return
2817 call uttraq(hgcfhe,a,b,edi)
2819 edi=edi*gspecs(ians)/2./pi**2/hquer**3
2823 if(iabs(ispecs(nspecs)).lt.10)
2824 *eden=eden+(8.*pi**2*tem**4/15.+bag4rt**4)/hquer**3
2826 de=abs(eden-(tecm/volu))
2827 if(de.le.gen*(tecm/volu).or.de.le.genm)return
2829 if(eden.gt.(tecm/volu))then
2837 *write(ifch,*)'failure in tex'
2845 c-----------------------------------------------------------------
2847 c-----------------------------------------------------------------
2848 c returns new tem using massless quantum statistics in analytic form
2854 c----------------------------------------------------------------------
2857 parameter (mspecs=56)
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
2866 10 tem=t1+.5*(t2-t1)
2867 if(tem.le.1.e-6)return
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.
2877 edhm0=pi**2*tem**4/30.+chemgc(i)**2*tem**2/4.
2878 *-chemgc(i)**4/pi**2/16.
2880 edi=edhm0*gspecs(i)/hquer**3
2886 if(iabs(ispecs(nspecs)).lt.10)
2887 *eden=eden+(8.*pi**2*tem**4/15.+bag4rt**4)/hquer**3
2889 de=abs(eden-(tecm/volu))
2890 if(de.le.gen*(tecm/volu).or.de.le.genm)return
2892 if(eden.gt.(tecm/volu))then
2900 *write(ifch,*)'failure in tm0'
2908 c----------------------------------------------------------------------
2909 subroutine hnbxxx(ip,iret)
2910 c----------------------------------------------------------------------
2911 c decays droplet very fast ... and hopefully not too badly
2912 c----------------------------------------------------------------------
2914 integer jc(nflav,2),jc1(nflav,2)
2916 double precision p(5),c(5)
2917 real u(3),pin(4),pout(4),poutx(4)
2918 parameter (mspecs=56)
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
2926 !, 1231,-1231, 2231,-2231, 1331,-1331, 2331,-2331, 3331,-3331
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
2941 ctp060829 parameter (mxidh=3331)
2944 call utpri('hnbxxx',ish,ishini,4)
2947 call idquac(ip,nqi,nsi,nai,jc)
2951 n=ndrop(keu,ked,kes)
2952 if(n.eq.0)stop'hnbxxx: n=0'
2958 do while(k.lt.mxe.and.ee(k).lt.e)
2962 xi=(e-ee(k-1))/(ee(k)-ee(k-1))
2965 if(n.lt.0)ii=ianti(i)
2966 w1=wwspecs(abs(n),k-1,ii)
2967 w2=wwspecs(abs(n),k,ii)
2968 wspecs(i)=w1+xi*(w2-w1)
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)
2999 wbar(1)=wbar(1)+wspecs(i)
3000 wbar(-1)=wbar(-1)+wspecs(i+1)
3002 wbar(1)=wbar(1) /wtot
3003 wbar(-1)=wbar(-1)/wtot
3008 w32=0 !35,36,41,42,53,54 excluded
3030 call idquac(ip,nq,ns,na,jc)
3034 ifl(nf)=jc(nf,1)-jc(nf,2)
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
3046 c...generate number of hadrons
3048 wfac=1.05 !mean increased by factor wfac
3054 wfac=1.05 !mean increased by factor wfac
3056 do while (sum.lt.rr)
3058 if(nhad.gt.10*aa)goto776
3061 !print*,'r:',rr,' n:',nhad,' sum pr:',sum
3068 do while (sum.lt.rr)
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
3076 if(ish.ge.5)write(ifch,*)'-----> ',nhad,' hadrons'
3078 c...generate first n-2 hadrons
3084 do while (sum.lt.rr)
3088 if(ispecs(i).gt.1000)then
3090 elseif(ispecs(i).lt.-1000)then
3095 if(nbari*nbarini.gt.0
3096 * .and.nbari*(nbar-nbari).lt.0.and.rangen().gt.wbar(-nbari))then
3098 * write(ifch,*)'-----',nptl,nbar,ispecs(i),wbar(-nbari),rr
3100 elseif(nbari*(nbar-nbari).lt.0)then
3101 if(ish.ge.5)write(ifch,*)'+++++',wbar(-nbari)
3107 call idquac(nptl,nq,ns,na,jc1)
3109 ifl(nf)=ifl(nf)-jc1(nf,1)+jc1(nf,2)
3112 * write(ifch,*)'nptl=',nptl,' id=',id,' ifl=',ifl
3115 if(ifl(nf).ge.0)then
3124 write(ifch,*)'jc=',jc
3125 write(ifch,*)'hadrons:',(idptl(n),n=nptlb+1,nptl)
3126 * ,' --> nbar=',nbar
3129 c...last two hadrons
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)
3156 if(rangen().lt.w32)ispin=1
3157 id=ii*(i1*1000+i2*100+i3*10+ispin)
3162 * write(ifch,*)'nptl=',nptl,' baryon=',id,' jc=',jc
3166 call idquacjc(jc,nqu,naq)
3167 do while (nqu.gt.0.or.nptl.eq.nptlb)
3185 if(rangen().lt.w1)ispin=1
3186 id=ii*(i1*100+i2*10+ispin)
3189 if(ish.ge.5)write(ifch,*)'nptl=',nptl,' nqu=',nqu
3190 & ,' naq=',naq,' --> meson',id
3191 call idquacjc(jc,nqu,naq)
3194 nmiss=nhad-nptl+nptlb
3196 write(ifch,*)nmiss,' hadron(s) missing'
3197 write(ifch,*)'hadrons:',(idptl(n),n=nptlb+1,nptl)
3200 c nsechad=lkfoi(1,ifl(1),ifl(2),ifl(3),ifl(4))
3201 c if(nsechad.gt.0)then
3202 c i2x=min(nsechad,1+rangen()*nsechad)
3203 c i2=lkfoi(1+i2x,ifl(1),ifl(2),ifl(3),ifl(4))
3204 c !print*,'secnd chosen hadron:',ispecs(i2),wzspecs(i2)
3206 c... generate momenta
3208 if(ish.ge.5)write(ifch,*)'hadron momenta:'
3212 !prepare proposal function
3213 ! f_prop: f0(x)=0, x<am
3214 ! f1(x)=const=f2(b), am<x<b,
3215 ! f2(x)=x**2*exp(7-a*x), x>b
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
3225 do while(rrr.gt.fff)
3228 if(rangen().lt.c1/(c1+c2))i=1
3229 if(ish.ge.5)write(ifch,*)'i=',i
3231 x=am+rangen()*(b-am)
3232 fx=b**2*exp(-a*b) *exp(7.)
3235 !find root of log((x**2/a+2*x/a**2+2/a**3)*exp(-a*x)/c2)-r
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
3242 if(ish.ge.5)write(ifch,*)'k,xb,f,fp,x: ',k,xb,f,fp,x
3244 fx=x**2*exp(-a*x) *exp(7.)
3249 fff=sqrt(x-am)*x*exp(-4*x-1.75*x**2) /fx
3251 fff=sqrt(x-am)*x*exp(7-11*x) /fx
3253 if(ish.ge.5)write(ifch,*)'fff,rrr',fff,rrr
3259 u(1)=sqrt(1.-u(3)**2)*cos(phi)
3260 u(2)=sqrt(1.-u(3)**2)*sin(phi)
3263 pout(j)=pout(j)+pptl(j,n)
3269 * write(ifch,*)pptl(1,n),pptl(2,n),pptl(3,n),pptl(4,n),pptl(5,n)
3272 c...check total energy ... rescale (maybe)
3275 write(ifch,*)'pout(cms)=',pout
3276 write(ifch,*)'energy_in(cms)= ',sngl(c(5))
3285 call utlob2(-1,c(1),c(2),c(3),c(4),c(5),p(1),p(2),p(3),p(4),10)
3288 poutx(j)=poutx(j)+pptl(j,n)
3292 write(ifch,*)'pout(lab)=',poutx
3293 write(ifch,*)'pin(lab)= ',pin
3295 call utprix('hnbxxx',ish,ishini,4)
3299 c----------------------------------------------------------------------
3300 subroutine hnbxxxini
3301 c----------------------------------------------------------------------
3304 parameter (mspecs=56)
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
3312 !, 1231,-1231, 2231,-2231, 1331,-1331, 2331,-2331, 3331,-3331
3313 !-------------------------------------------------------------
3314 common/xxxspecs/wtot,wspecs(mspecs),zspecs(mspecs)
3315 integer ittspecs(mspecs)
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)
3329 write(ifmt,'(3a)')'read from ',fndr(1:nfndr),' ...'
3330 open(1,file=fndr(1:nfndr),status='old')
3332 if(mxxdrop.ne.mxdrop)stop'hnbxxxini: wrong nr of droplets'
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'
3339 ndrop(-ku,-kd,-ks)=-n
3341 read(1,*)(ittspecs(i),i=1,nspecs)
3343 if(ittspecs(i).ne.ispecs(i))stop'hnbxxxini: wrong id table'
3347 read(1,*)((wwspecs(n,k,i),i=1,nspecs),k=1,mxe)
3352 stop'hnbxxxini: file not found. '
3356 c----------------------------------------------------------------------
3357 subroutine hnbaaa(ip,iret)
3358 c----------------------------------------------------------------------
3360 if(ioclude.eq.1)call hnbaaa156(ip,iret)
3361 if(ioclude.eq.2)stop'ioclude.eq.2 no longer supported. '
3362 if(ioclude.eq.3)call hnbaaanew(ip,iret)
3365 c----------------------------------------------------------------------
3366 subroutine hnbaaanew(ip,iret)
3367 c----------------------------------------------------------------------
3368 c microcanonical decay of cluster ip via loop over hnbmet
3369 c----------------------------------------------------------------------
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)
3375 common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
3376 common/citer/iter,itermx
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
3388 data icnthnb /0/ !vv2 /0./ nvv2 /0/ vv3 /0./
3392 call utpri('hnbaaa',ish,ishini,4)
3396 140 format(/' ----------------------------------'/
3398 *' ----------------------------------')
3399 write(ifch,*)'droplet:'
3400 call alist('&',ip,ip)
3408 call idquac(ip,nqi,nsi,nai,jc)
3415 !print*,'droplet uds=',keu,ked,kes,' E=',pptl(5,ip)
3417 volu=4./3.*pi*radptl(ip)**3
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
3424 * 'id:',idptl(ip),' r:',radptl(ip),' m:',pptl(5,ip)
3428 !~~~~~~~~~read in freeze out surface properties from hydro~~~~~~~~~~~~
3429 if(iorsdf.eq.3.and.ityptl(ip).eq.60)then
3431 if(icnthnb.eq.1)then
3432 !here we use epos.iniXXX (like epos.ini1fc)
3433 !instead of the generic filename epos.inihy
3434 open(3,file=fnnx(1:nfnnx)//fnhy(1:nfnhy),status='old',err=99)
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,'). '
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. '
3451 read(3,*)centhy,etahy,phihy,radhy
3454 read(3,*)rom,yom,wom
3459 !~~~~~~~~~define womi yomi romi~~~~~~~~~~~~
3460 if(iorsdf.eq.3.and.icnthnb.eq.1)then
3461 if(ioclude.eq.3)then
3464 do ntau=1,ntauhoc(ncent)
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)
3473 elseif(ioclude.eq.2)then
3474 stop'in hnbaaanew: ioclude=2 not supported any more.'
3476 stop'in hnbaaa: invalid ioclude. '
3480 !~~tau partition function paut(ncent,neta,ntau)
3481 !~~phi partition function pauf(ncent,neta,ntau,nphi)
3482 if(iorsdf.eq.3.and.icnthnb.eq.1)then
3486 ntauhac(ncent,neta)=0
3487 do ntau=1,ntauhoc(ncent)
3488 if(womi(ncent,neta,ntau,1).gt.womax )then
3489 womax=womi(ncent,neta,ntau,1)
3490 ntauhac(ncent,neta)=ntau
3492 !print*,ncent,neta,ntau,ntauhac(ncent,neta)
3493 !. , womi(ncent,neta,ntau,1)
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)
3501 do ntau=2,ntauhac(ncent,neta)
3502 pauf(ncent,neta,ntau,1)=0
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)
3508 . -womi(ncent,neta,ntau-1,1)-c1*womi(ncent,neta,ntau-1,2)
3509 w2=womi(ncent,neta,ntau ,1)+c2*womi(ncent,neta,ntau ,2)
3510 . -womi(ncent,neta,ntau-1,1)-c2*womi(ncent,neta,ntau-1,2)
3511 pauf(ncent,neta,ntau,nphi)
3512 . =pauf(ncent,neta,ntau,nphi-1)+0.5*(w1+w2)*dphi
3514 w=pauf(ncent,neta,ntau,nphihy)
3515 if(w.eq.0.)stop'hnbaaanew: w.eq.0. '
3517 pauf(ncent,neta,ntau,nphi)=pauf(ncent,neta,ntau,nphi)/w
3524 !~~~~~~~~~determine ncentr~~~~~~~~~~~~
3525 if(iorsdf.eq.3.and.ityptl(ip).eq.60)then !!!fusion on!!!
3529 db=abs(bimevt-centhy(ncent))
3535 !print*,ncentr,bimevt,centhy(ncentr)
3538 !~~~~~define masses~~~~~~~~~~~~~~~~
3539 amin=utamnu(keu,ked,kes,kec,keb,ket,5)
3542 if(ityptl(ip).eq.60)ipo=iorptl(ip)
3547 !~~~~~~~~~determine netar~~~~~~~~~~~~
3548 if(iorsdf.eq.3.and.ityptl(ip).eq.60)then
3551 !print*,z,t,ityptl(ip),tecm
3552 if(t+z.le.0..or.t-z.le.0.)then
3555 zetaor=abs(0.5*log((t+z)/(t-z)))
3560 deta=abs(zetaor-etahy(neta))
3561 if(deta.lt.detamin)then
3566 !print*,netar,zetaor,etahy(netar)
3571 !~~~~~redefine energy in case of radial flow~~~~~~~~~~~~~~~~
3572 if(iappl.ne.4.and.iorsdf.eq.3.and.tecmor.gt.aumin
3573 ..and.ityptl(ip).eq.60)then
3575 do ntau=2,ntauhac(ncentr,netar)
3576 d=paut(ncentr,netar,ntau)-paut(ncentr,netar,ntau-1)
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
3587 if(en.ne.0.)fradflo=am/en
3588 if(tecm*fradflo.lt.amin)fradflo=1.
3592 !~~~~~redefine energy in case of long coll flow
3593 if(iappl.eq.4.or.iorsdf.ne.3
3594 &.or.ityptl(ip).eq.40.or.ityptl(ip).eq.50)then !not for droplets from remnants
3597 if(ylongmx.lt.0.)then
3604 if(yco.gt.0..and.tecmor.gt.aumin) then
3605 tecm=tecm/sinh(yco)*yco
3609 !print*,'========= cluster energy: ',pptl(5,ip),tecmx,tecm
3611 !~~~~~~~~~redefine volume~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
3613 vocri=tecm/epscri(ioclude)
3614 volu=max(vocri,vocell)
3616 !~~~~~~~~~decay~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
3618 !if(iret.ne.0)write(ifch,*)'***** unsucessfull hnbini *****'
3619 if(iret.ne.0)goto1000
3620 if(ioinct.ge.1)goto1
3629 if(ioceau.eq.1.and.iappl.eq.1)call xhnbte(ip)
3631 !~~~~~~~~~~long coll flow -> particles~~~~~~~~~~~~~~~~
3637 yrad(i)=(2*rangen()-1)*yco
3640 energ=energ+uu(4)*pcm(4,i)+uu(3)*pcm(3,i)
3642 if(abs(energ-tecm).gt.0.1) goto 611
3643 !print*,'===== energy after flow boosts',energ,' soll: ',tecm
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))
3655 pe(j)=pe(j)+pcm(j,i)
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
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))
3667 pa(j)=pa(j)+pcm(j,i)
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
3678 pcm(k,j)=scal*pcm(k,j)
3680 pcm(4,j)=sqrt(pcm(1,j)**2+pcm(2,j)**2+pcm(3,j)**2
3685 !write(6,*)'ipass,scal,e,esoll:'
3686 ! $ ,ipass,scal,sum,esoll
3687 if(abs(scal-1.).le.errlim) goto301
3695 pa(j)=pa(j)+pcm(j,i)
3698 pa(5)=sqrt(pa(4)**2-pa(3)**2-pa(2)**2-pa(1)**2)
3699 !write(6,'(a,5e11.3)')' rescaling ',pa
3702 !~~~~~~~~~~radial flow -> particles~~~~~~~~~~~~~~~~~~
3703 if(fradflo.lt.1.) then
3708 if(ityptl(ip).eq.60)then
3710 xx=uptl(ipo) ! <x**2>
3711 yy=optl(ipo) ! <y**2>
3712 xy=desptl(ipo) ! <x*y>
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)
3729 phinull=phievt+ranphi
3731 !~~determine random tau from paut(ncentr,netar,ntau)
3734 do while(paut(ncentr,netar,ntau).lt.r)
3740 tau1=tauhoc(ncentr,ntau1)
3741 tau2=tauhoc(ncentr,ntau2)
3742 f1=paut(ncentr,netar,ntau1)-r
3743 f2=paut(ncentr,netar,ntau2)-r
3746 tau= tau1*(1-f) + tau2*f
3748 !~~determine phifop~~~~~
3750 if(pauf(ncentr,netar,ntau-1,nphihy).gt.0.
3751 . .and.pauf(ncentr,netar,ntau,nphihy).gt.0.)then
3753 do while((pauf(ncentr,netar,ntau1,nphi)*(1-fx)
3754 . + pauf(ncentr,netar,ntau2,nphi)*fx) .lt.r)
3762 f1=pauf(ncentr,netar,ntau,nphi1)-r
3763 f2=pauf(ncentr,netar,ntau,nphi2)-r
3765 phi=phi1+f*(phi2-phi1)
3769 if(px.ge.0..and.py.ge.0.)then
3771 elseif(px.lt.0..and.py.gt.0.)then
3773 elseif(px.lt.0..and.py.lt.0.)then
3775 elseif(px.gt.0..and.py.lt.0.)then
3779 !~~determine yrad~~~~
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
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
3796 uu(1)=sinh(yrad(n))*cos(phifop(n)+phinull)
3797 uu(2)=sinh(yrad(n))*sin(phifop(n)+phinull)
3799 uu(4)=sqrt(1+uu(1)**2+uu(2)**2)
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 !?????????????????????????????????????????????????
3809 ! vv3=vv3+(px**2-py**2)/(px**2+py**2)
3811 ! if(mod(nvv2,100).eq.0)
3812 !. print*,'++++',nvv2,vv2/nvv2,vv3/nvv2
3813 !?????????????????????????????????????????????????
3821 pcm(k,j)=scal*pcm(k,j)
3823 pcm(4,j)=sqrt(pcm(1,j)**2+pcm(2,j)**2+pcm(3,j)**2
3828 !write(6,*)'ipass,scal,e,esoll:'
3829 ! $ ,ipass,scal,sum,esoll
3830 if(abs(scal-1.).le.errlim) goto300
3847 if(nptl.gt.mxptl)call utstop('hnbptl: mxptl too small&')
3848 idptl(nptl)=ident(n)
3853 call utlob2(-1,c(1),c(2),c(3),c(4),c(5),p(1),p(2),p(3),p(4),10)
3857 if(fradflo.lt.1.) then
3862 if(ityptl(ip).eq.60)then
3863 if(ityptl(nptl).eq.60)then
3869 !---add r-randomness
3871 !do while(dr.lt.-2.or.dr.gt.2.)
3872 ! dr=sqrt(3.)*(rangen()+rangen()+rangen()+rangen()-2)
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()
3880 xorptl(1,nptl)=r*cos(phifop(n)+phinull)
3881 xorptl(2,nptl)=r*sin(phifop(n)+phinull)
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)
3893 write(ifch,*)'decay products:'
3894 call alist('&',nptlb+1,nptl)
3896 write(ifch,*)'momentum sum:'
3900 pptl(kk,nptl+1)=pptl(kk,nptl+1)+pptl(kk,ii)
3902 pptl(kk,nptl+2)=c(kk)
3904 call alist('&',nptl+1,nptl+2)
3910 call utprix('hnbaaa',ish,ishini,4)
3913 99 print*,'hnbaaanew: error opening hydro table'
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"'
3921 c------------------------------------------------------------------------------
3922 subroutine xSpaceTime
3923 c------------------------------------------------------------------------------
3925 if(iSpaceTime.eq.1.and.ioclude.gt.1)then
3926 call xCoreCorona(0,0)
3929 call xFoRadius(neta)
3930 call xFoRadRapidity(neta)
3931 call xFreezeOutTauX(neta)
3933 call xFreezeOutTauEta
3935 elseif(iSpaceTime.eq.1)then
3936 call xCoreCorona(0,0)
3937 !stop'bjinta: space-time plots require ioclude>1. '
3941 c------------------------------------------------------------------------------
3942 subroutine xFreezeOutTauX(neta)
3943 c------------------------------------------------------------------------------
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 !..........................................................................
3956 deleta=etahy(2)-etahy(1)
3957 eta1=etahy(neta)-deleta/2
3958 eta2=etahy(neta)+deleta/2
3960 taumax=tauhoc(ncentr,ntauhac(ncentr,neta))+4
3963 * .and.istptl(n).ne.12.and.istptl(n).ne.11)then
3964 if(istptl(iorptl(n)).eq.11)then
3966 tau2=xorptl(4,n)**2-xorptl(3,n)**2
3967 if(tau2.gt.0.)tau=sqrt(tau2)
3968 if(tau.lt.taumax)then
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
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'
3993 write(ifhi,'(2e11.3)')xorptl(1,n),tau
4004 if(nplx.gt.0)write(ifhi,'(a)') ' endarray closehisto plot 0-'
4005 !..........................................................................
4011 if(dezptl(n).lt.1e3.and.n.le.maxfra
4012 * .and.(istptl(n).eq.0.or.istptl(n).eq.1))then
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
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'
4037 if(tau2.gt.0.)tau=sqrt(tau2)
4039 . write(ifhi,'(2e11.3)')x,tau
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
4048 if(tau2.gt.0.)tau=sqrt(tau2)
4050 . write(ifhi,'(2e11.3)')x,tau
4060 write(ifhi,'(a)') ' endarray closehisto plot 0'
4061 !..........................................................................
4064 c------------------------------------------------------------------------------
4065 subroutine xFreezeOutTauEta
4066 c------------------------------------------------------------------------------
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 !..........................................................................
4081 * .and.istptl(n).ne.12.and.istptl(n).ne.11)then
4082 if(istptl(iorptl(n)).eq.11)then
4084 tau2=xorptl(4,n)**2-xorptl(3,n)**2
4085 if(tau2.gt.0.)tau=sqrt(tau2)
4086 if(tau.lt.taumax)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)"'
4099 write(ifhi,'(a,f4.1,a,f4.1,a)')'text 0.77 0.92 "'//cbim//'"'
4100 write(ifhi,'(a)') 'array 2'
4103 * .5*alog((xorptl(4,n)+xorptl(3,n))/(xorptl(4,n)-xorptl(3,n)))
4104 write(ifhi,'(2e11.3)') eta,tau
4106 write(ifhi,'(a)') ' endarray closehisto plot 0-'
4114 if(npl.ne.0)write(ifhi,'(a)') ' endarray closehisto plot 0'
4115 if(npl.eq.0)stop'xFreezeOutTZ: no particles!!!!! '
4118 c------------------------------------------------------------------------------
4119 subroutine xFreezeOutTZ
4120 c------------------------------------------------------------------------------
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
4127 call centrality(bimevt ,cbim)
4128 call centrality(centhy(ncentr),cbimhy)
4129 !..........................................................................
4134 * .and.istptl(n).ne.12.and.istptl(n).ne.11)then
4135 if(istptl(iorptl(n)).eq.11)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)"'
4148 write(ifhi,'(a,f4.1,a,f4.1,a)')'text 0.75 0.22 "'//cbim//'"'
4149 write(ifhi,'(a)') 'array 2'
4151 write(ifhi,'(2e11.3)') xorptl(3,n),xorptl(4,n)
4153 write(ifhi,'(a)') ' endarray closehisto plot 0-'
4160 if(npl.ne.0)write(ifhi,'(a)') ' endarray closehisto plot 0'
4161 if(npl.eq.0)stop'xFreezeOutTZ: no particles!!!!! '
4164 c------------------------------------------------------------------------------
4165 subroutine xFoMass(neta)
4166 c------------------------------------------------------------------------------
4168 include 'epos.inchy'
4169 common/cen/ncentr /ctauhac/ntauhac(ncenthy,netahy)
4171 call centrality(bimevt ,cbim)
4172 taumax=tauhoc(ncentr,ntauhac(ncentr,neta))+2
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'
4179 write(ifhi,'(a,3i1)')'openhisto htyp lin name w-',neta,nn,ii
4180 if(ii.eq.1)then !----------------------
4181 write(ifhi,'(a,f4.1)')'xmod lin xrange 0. ',taumax
4182 write(ifhi,'(a)') 'txt "xaxis [t] (fm/c)"'
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) "'
4186 write(ifhi,'(a,f4.1,a,f4.1,a)')'text 0.50 0.9 "'//cbim//' "'
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
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'
4200 c------------------------------------------------------------------------------
4201 subroutine xFoRadius(neta)
4202 c------------------------------------------------------------------------------
4204 include 'epos.inchy'
4205 common/cen/ncentr /ctauhac/ntauhac(ncenthy,netahy)
4207 call centrality(bimevt ,cbim)
4208 taumax=tauhoc(ncentr,ntauhac(ncentr,neta))+2
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'
4215 write(ifhi,'(a,3i1)')'openhisto htyp lin name r-',neta,nn,ii
4216 if(ii.eq.1)then !----------------------
4217 write(ifhi,'(a,f4.1)')'xmod lin xrange 0. ',taumax
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) "'
4222 write(ifhi,'(a,f4.1,a,f4.1,a)')'text 0.50 0.9 "'//cbim//' "'
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)
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'
4235 c------------------------------------------------------------------------------
4236 subroutine xFoRadRapidity(neta)
4237 c------------------------------------------------------------------------------
4239 include 'epos.inchy'
4240 common/cen/ncentr /ctauhac/ntauhac(ncenthy,netahy)
4242 call centrality(bimevt ,cbim)
4243 taumax=tauhoc(ncentr,ntauhac(ncentr,neta))+2
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'
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! "'
4257 write(ifhi,'(a,f4.1,a,f4.1,a)')'text 0.50 0.9 "'//cbim//' "'
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)
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'
4270 c------------------------------------------------------------------------------
4271 subroutine centrality(b,cbim)
4272 c------------------------------------------------------------------------------
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)
4282 data iperc /0,5,10,15,20,25,30,35,40,45,50,60,70,80,92,100/
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)
4320 if(bim(n).eq.0.)then
4321 print*,'******* ERROR in subroutine centrality: '
4322 . ,' #define bim?? ??? missing. ******* '
4329 do while(bim(n).lt.b)
4333 write(cbim,'(a,i2,a,i2,a)')' ',iperc(n-1),'-',iperc(n),'% '
4338 c-----------------------------------------------------------------------
4339 subroutine xCoreCorona(iii,jjj)
4340 c-----------------------------------------------------------------------
4341 c space-time evolution of core and corona
4343 c cluster ............ ist=11 ity=60
4344 c core particles ..... ist=0 ity=60
4345 c corona particles ... ist=0 ity/=60
4347 c iii=1: plot also binary collisions
4348 c jjj>0: multiplicity trigger (useful for pp)
4349 c-----------------------------------------------------------------------
4351 include 'epos.incems'
4352 include 'epos.inchy'
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
4363 if(ioclude.gt.1)call centrality(bimevt ,cbim)
4364 if(ioclude.gt.1)call centrality(centhy(ncentr),cbimhy)
4367 !print*,'RandomPhi=',ranphi,' EventPhi=',phievt
4371 if(maproj.gt.1)r1=radnuc(maproj)
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
4381 if(itpr(k).gt.0)n2=n2+1
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
4391 if(amt.gt.0..and.pptl(4,i).gt.0.)then
4393 rap=sign(1.,pptl(3,i))*alog((pptl(4,i)+abs(pptl(3,i)))/amt)
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
4404 if(0.5*multy1.lt.ih1.or.0.5*multy1.gt.ih2)return
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"'
4420 write(ifhi,'(a,f4.1,a,f4.1,a)')'text 0.77 0.92 "'//cbim//'"'
4421 write(ifhi,'(a)') 'array 2'
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)
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'
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)
4447 write(ifhi,'(a)') ' endarray'
4448 write(ifhi,'(a)') 'closehisto'
4449 !print*,'b=',bimevt,' ncorona:ncore = ',ncorona,':',ncore
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'
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)
4466 write(ifhi,'(a)') ' endarray'
4467 write(ifhi,'(a)') 'closehisto'
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'
4478 write(ifhi,'(2e11.3)')r1*cos(phi)-b,r1*sin(phi)
4480 write(ifhi,'(a)') ' endarray'
4481 write(ifhi,'(a)') 'closehisto'
4484 write(ifhi,'(a)') 'plot 0-'
4485 write(ifhi,'(a)') 'openhisto name stc1 htyp lyu'
4486 write(ifhi,'(a)') 'array 2'
4489 write(ifhi,'(2e11.3)')-r1*cos(phi)+b,r1*sin(phi)
4491 write(ifhi,'(a)') ' endarray'
4492 write(ifhi,'(a)') 'closehisto'
4495 write(ifhi,'(a)') 'plot 0'
4497 !........................................................................................
4498 if(ioclude.le.1)return
4499 !........................................................................................
4500 delrap=2*rapmax/float(myy)
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
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
4514 rap=sign(1.,pptl(3,n))*alog((pptl(4,n)+abs(pptl(3,n)))/amt)
4515 eco=amt*cosh(rap-rapx)
4517 m=(rapx+rapmax)/delrap+1
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"'
4536 write(ifhi,'(a,f4.1,a,f4.1,a)')'text 0.75 0.90 "'//cbim//'"'
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'
4541 write(ifhi,'(2e11.3)')-rapmax+(m-0.5)*delrap, yy(m)/4./delrap
4543 write(ifhi,'(a)') ' endarray closehisto plot 0-'
4544 !........................................................................................
4545 delrap=2*rapmax/float(myy)
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
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
4559 rap=sign(1.,pptl(3,n))*alog((pptl(4,n)+abs(pptl(3,n)))/amt)
4560 eco=amt*cosh(rap-rapx)
4562 m=(rapx+rapmax)/delrap+1
4563 if(m.ge.1.and.m.le.myy)yy(m)=yy(m)+eco
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'
4581 write(ifhi,'(2e11.3)')-rapmax+(m-0.5)*delrap, yy(m)/4./delrap
4583 write(ifhi,'(a)') ' endarray closehisto plot 0-'
4585 write(ifhi,'(a)') 'plot 0'
4586 !........................................................................................
4587 delrad=2*radmax/float(mrr)
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)
4596 if(abs(rapx).le.1.and.abs(routp).le.1.)then
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
4601 rap=sign(1.,pptl(3,n))*alog((pptl(4,n)+abs(pptl(3,n)))/amt)
4602 eco=amt*cosh(rap-rapx)
4604 m=(rinp+radmax)/delrad+1
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"'
4622 write(ifhi,'(a,f4.1,a,f4.1,a)')'text 0.75 0.90 "'//cbim//'"'
4623 write(ifhi,'(a)') 'txt "xaxis x (fm)"'
4624 write(ifhi,'(a)') 'txt "yaxis dE/d[c]dxdy "'
4625 write(ifhi,'(a)') 'array 2'
4627 write(ifhi,'(2e11.3)')-radmax+(m-0.5)*delrad, rr(m)/4./delrad
4629 write(ifhi,'(a)') ' endarray closehisto plot 0-'
4630 !........................................................................................
4631 delrad=2*radmax/float(mrr)
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)
4640 if(abs(rapx).le.1.and.abs(routp).le.1.)then
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
4645 rap=sign(1.,pptl(3,n))*alog((pptl(4,n)+abs(pptl(3,n)))/amt)
4646 eco=amt*cosh(rap-rapx)
4648 m=(rinp+radmax)/delrad+1
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'
4662 write(ifhi,'(2e11.3)')-radmax+(m-0.5)*delrad, rr(m)/4./delrad
4664 write(ifhi,'(a)') ' endarray closehisto plot 0-'
4666 write(ifhi,'(a)') 'plot 0'
4667 !........................................................................................
4668 delrad=2*radmax/float(mrr)
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)
4677 if(abs(rapx).le.1.and.abs(rinp).le.1.)then
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
4682 rap=sign(1.,pptl(3,n))*alog((pptl(4,n)+abs(pptl(3,n)))/amt)
4683 eco=amt*cosh(rap-rapx)
4685 m=(routp+radmax)/delrad+1
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"'
4703 write(ifhi,'(a,f4.1,a,f4.1,a)')'text 0.75 0.90 "'//cbim//'"'
4704 write(ifhi,'(a)') 'txt "xaxis y (fm)"'
4705 write(ifhi,'(a)') 'txt "yaxis dE/d[c]dxdy "'
4706 write(ifhi,'(a)') 'array 2'
4708 write(ifhi,'(2e11.3)')-radmax+(m-0.5)*delrad, rr(m)/4./delrad
4710 write(ifhi,'(a)') ' endarray closehisto plot 0-'
4711 !........................................................................................
4712 delrad=2*radmax/float(mrr)
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)
4721 if(abs(rapx).le.1.and.abs(rinp).le.1.)then
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
4726 rap=sign(1.,pptl(3,n))*alog((pptl(4,n)+abs(pptl(3,n)))/amt)
4727 eco=amt*cosh(rap-rapx)
4729 m=(routp+radmax)/delrad+1
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'
4743 write(ifhi,'(2e11.3)')-radmax+(m-0.5)*delrad, rr(m)/4./delrad
4745 write(ifhi,'(a)') ' endarray closehisto plot 0-'
4747 write(ifhi,'(a)') 'plot 0'
4751 c------------------------------------------------------------------------------
4752 subroutine xEini(ii)
4753 c------------------------------------------------------------------------------
4755 include 'epos.inchy'
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'
4764 write(ifhi,'(2e13.5)')
4765 . -radhy(nr),epsii(ncentr,ii,1,nr)*tauhoc(ncentr,1)
4768 write(ifhi,'(2e13.5)')
4769 . radhy(nr),epsii(ncentr,ii,1,nr)*tauhoc(ncentr,1)
4771 write(ifhi,'(a)') 'endarray closehisto '
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'
4780 write(ifhi,'(2e13.5)')
4781 . -radhy(nr),epsii(ncentr,ii,nphihy,nr)*tauhoc(ncentr,1)
4784 write(ifhi,'(2e13.5)')
4785 . radhy(nr),epsii(ncentr,ii,nphihy,nr)*tauhoc(ncentr,1)
4787 write(ifhi,'(a)') 'endarray closehisto '
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'
4796 write(ifhi,'(2e13.5)')
4797 . -etahy(neta),epsii(ncentr,neta,1,1)*tauhoc(ncentr,1)
4800 write(ifhi,'(2e13.5)')
4801 . etahy(neta),epsii(ncentr,neta,1,1)*tauhoc(ncentr,1)
4803 write(ifhi,'(a)') 'endarray closehisto '
4808 c------------------------------------------------------------------------------
4809 subroutine hnbcor(mode)
4810 c------------------------------------------------------------------------------
4811 c determines(mode=1) and plots (mode=2) two particle correlations
4812 c for the configurations /confg/
4813 c------------------------------------------------------------------------------
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
4842 prod=prod+pcm(kk,ii)*pcm(kk,jj)
4845 cs=prod/pcm(5,ii)/pcm(5,jj)
4847 if(abs(cs).gt.1.)then
4857 elseif(ang.eq.pi)then
4861 nw=1+aint(ang/pi*bns)
4862 nk=1+aint((cs+1.)/2.*bns)
4868 cwert(nk)=cwert(nk)+1
4873 elseif(mode.eq.2)then
4876 c phi(mm)=.5*pi/bns+(mm-1)*pi/bns
4877 zwei(mm)=.5*2./bns+(mm-1)*2./bns-1.
4878 c yy(mm)=wert(mm)/nctcor
4879 zz(mm)=cwert(mm)/nctcor
4882 write(cen,'(f6.1)')tecm
4883 write(cvol,'(f6.1)')volu
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'
4894 write(ifhi,'(2e13.5)')zwei(mm),zz(mm)
4896 write(ifhi,'(a)') ' endarray'
4897 write(ifhi,'(a)') 'closehisto plot 0'
4904 c----------------------------------------------------------------------
4905 subroutine hnbfac(faclog)
4906 c----------------------------------------------------------------------
4907 c returns log of factor for phase space weight
4908 c faclog= log{ prod[ m_i*(2*s_i+1)*volu/4/pi**3/hquer**3/(n_l+1-i) ] }
4910 c corresponds to eq. 67 of micro paper :
4911 c Cvol * Cdeg * Cident * Cmicro
4912 c the factors partly compensate each other !!
4913 c----------------------------------------------------------------------
4916 common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
4918 common /clatt/nlattc,npmax
4922 c sum_i log m_i*g_i*volu/4/pi**3/hquer**3/(n_l+1-i) -> flog
4925 call hnbfaf(i,gg,am,ioma)
4926 flog=flog+alog(gg*am*volu/4/pi**3/hquer**3/(nlattc+1-i))
4933 c----------------------------------------------------------------------
4934 subroutine hnbfaf(i,gg,am,ioma)
4935 c----------------------------------------------------------------------
4936 c returns degeneracy gg and mass am for factor f5
4937 c----------------------------------------------------------------------
4938 common/metr1/iospec,iocova,iopair,iozero,ioflac,iomom
4940 common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
4941 common/drop6/tecm,volu
4949 call hnbspi(ident(i),spideg)
4952 if(ioma.eq.1)am=amass(i)
4953 if(ioma.eq.2)am=tecm/np
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)
4959 am=0.5 ! 1 / 2 (no dimension)
4965 cc----------------------------------------------------------------------
4966 c subroutine hnbids(jc,ids,iwts,i)
4967 cc----------------------------------------------------------------------
4968 cc returns i id-codes ids() corr to jc and their weights iwts()
4969 cc----------------------------------------------------------------------
4970 c parameter (mxids=200,mspecs=56,nflav=6)
4971 c common/metr1/iospec,iocova,iopair,iozero,ioflac,iomom
4972 c common/cflac/ifok(nflav,mspecs),ifoa(nflav)
4973 c common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
4974 c integer ids(mxids),jc(nflav,2),iwts(mxids),jc1mi2(nflav)
4976 c if(nspecs+1.gt.mxids)call utstop('hnbids: mxids too small&')
4979 c jc1mi2(n)=jc(n,1)-jc(n,2)
4985 c if(jc1mi2(n).ne.0)goto1
4994 c if(jc1mi2(n).ne.ifok(n,j))goto2
5005 c----------------------------------------------------------------------
5006 subroutine hnbiiw(x,f,df)
5007 c----------------------------------------------------------------------
5008 c returns fctn value and first derivative at x of the
5009 c i-th integrated weight fctn minus random number
5010 c for the asympotic phase space integral.
5013 c iii: i-value (via common/ciiw/iii,rrr)
5014 c rrr: random number ( " )
5017 c df: first derivative
5018 c----------------------------------------------------------------------
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))
5026 c----------------------------------------------------------------------
5027 subroutine hnbini(iret)
5028 c----------------------------------------------------------------------
5029 c generates initial configuration
5030 c----------------------------------------------------------------------
5033 common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
5034 parameter (mspecs=56)
5035 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
5036 common/crnoz/rnoz(maxp-1)
5037 common/citer/iter,itermx
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)
5044 if(ish.ge.7)write(ifch,*)('-',i=1,10)
5045 *,' entry sr hnbini ',('-',i=1,30)
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
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)
5062 itermx=(-itermx)*taue
5066 if(ish.ge.5)write(ifch,*)'itermx:',itermx
5068 if(iternc.gt.itermx/2)iternc=itermx/2
5071 call hnbmin(keu,ked,kes,kec)
5072 if(iograc.eq.1)call hgcaaa
5073 elseif(ioinco.ge.1)then
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)
5083 call hnbmin(keu,ked,kes,kec)
5085 write(ifch,*)'hadron set from hnbmin:'
5086 write(ifch,'(10i6)')(ihadro(k),k=1,nump)
5093 if(np.gt.maxp)stop'np too large'
5095 nlattc=max(nlattc,1+int(np*1.2))
5097 if(nlattc-1.gt.maxp)stop'maxp too small'
5113 if(ident(i).eq.ispecs(j))then
5120 *call utstop('hnbini: invalid particle species&')
5123 if(iocova.eq.1)call hnbody !covariant
5124 if(iocova.eq.2)call hnbodz !noncovariant
5129 if(wtlog.le.-0.99999E+35)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)
5145 write(ifch,*)'initial configuration:'
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)
5157 itermx=(-itermx)*taue
5161 if(ish.ge.5)write(ifch,*)'itermx:',itermx
5163 if(iternc.gt.itermx/2)iternc=itermx/2
5170 if(ish.ge.7)write(ifch,*)('-',i=1,30)
5171 *,' exit sr hnbini ',('-',i=1,10)
5176 cc----------------------------------------------------------------------
5177 c subroutine hnbint(tecmx,nevtxx,nsho)
5178 cc----------------------------------------------------------------------
5179 cc calculates phase space integral of the minimal hadron configuration
5180 cc compatibel with keu, ked, kes, kec for a total mass of tecm
5181 cc by employing nevtxx simulations and printing results every nsho events
5182 cc----------------------------------------------------------------------
5183 c include 'epos.inc'
5184 c parameter(maxp=500)
5185 c common/chnbin/nump,ihadro(maxp)
5186 c common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
5189 c write(ifch,'(1x,a,4i3,a,f10.4)')'droplet id:',keu,ked,kes,kec
5190 c *,' droplet mass:',tecm
5191 c call hnbmin(keu,ked,kes,kec)
5193 c if(np.gt.maxp)stop'np too large'
5197 c call idmass(2130,am)
5198 c amass(i)=2*am-0.100
5200 c call idmass(id,amass(i))
5207 c if(iocova.eq.1)call hnbody
5208 c if(iocova.eq.2)call hnbodz
5211 c if(mod(n,nsho).eq.0)
5212 c *write(ifch,'(a,i7,3x,a,e13.6,3x,a,e13.6,3x,a,e13.6)')
5213 c *'n:',n,'weight:',wt,'wts/n:',wts/n,'error:',wts/n/sqrt(1.*n)
5217 cc----------------------------------------------------------------------
5219 c----------------------------------------------------------------------
5220 c change (or not) configuration via metropolis
5221 c configuration=np,tecm,amass(),ident(),pcm(),volu,wtlog
5223 c nlattc (in /clatt/) must be set before calling this routine
5224 c----------------------------------------------------------------------
5227 common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
5228 common/crnoz/rnoz(maxp-1)
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
5234 parameter (mspecs=56)
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)
5239 c 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)
5247 write(ifch,*)('-',i=1,10)
5248 *,' entry sr hnbmet ',('-',i=1,30)
5249 write(ifch,'(1x,a,i4)')'iteration:',iter
5251 if(mod(iter,iterpr).eq.0)write(ifmt,*)'iteration:',iter
5280 c remember old configuration
5281 c --------------------------
5301 c determine pair, construct new pair, update ident
5302 c ------------------------------------------------
5304 c (single pair method)
5305 call hnbpad(1,n1,n2,n3,n4,mm,jc)
5310 call hnbpaj(jc,iwpair,id1,id2)
5321 if(id1old(1).eq.0)nzold=nzold+1
5322 if(id2old(1).eq.0)nzold=nzold+1
5324 if(id1new(1).eq.0)nznew=nznew+1
5325 if(id2new(1).eq.0)nznew=nznew+1
5327 c determine 2 pairs, construct 2 new pairs, update ident
5328 c ------------------------------------------------------
5329 elseif(iopair.eq.2)then
5330 c (double pair method)
5332 25 call hnbpad(1,n1,n2,n3,n4,mm,jc)
5336 call hnbpai(id1,id2,jc1)
5343 jc(i,j)=jc(i,j)-jc1(i,j)
5347 2 call hnbpad(2,n1,n2,n3,n4,mm,jc1)
5352 jc(i,j)=jc(i,j)+jc1(i,j)
5355 call hnbpaj(jc,iwpair,id1,id2)
5362 if(ish.ge.7)write(ifch,*)'no pair possible'
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
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
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
5391 call utstop('hnbmet: invalid choice for iopair&')
5394 c determine masses/momenta/weight of trial configuration
5395 c ------------------------------------------------------
5400 if(ident(i).eq.ispecs(j))then
5407 *call utstop('hnbmet: invalid particle species&')
5410 c-c call hnbolo(1000) !instead of "call hnbody" for testing
5412 if(iocova.eq.1)call hnbody
5413 if(iocova.eq.2)call hnbodz
5420 write(ifch,*)'trial configuration:'
5424 c accept or not trial configuration (metropolis)
5425 c ----------------------------------------------
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),' :'
5431 if(wtlog-wtlo.lt.30.)then
5432 q=exp(wtlog-wtlo)*xba/xab
5435 if(ish.ge.7)write(ifch,*)'new weight / old weight:',q,' '
5436 *,'random number:',r
5439 if(ish.ge.7)write(ifch,*)'log new weight / old weight:'
5443 if(ish.ge.7)write(ifch,*)'new configuration accepted'
5447 if(ish.ge.7)write(ifch,*)'old configuration kept'
5470 if(iter.gt.iternc)nptot=nptot+np
5474 if(ioobsv.eq.ident(i))npob=npob+1
5477 if(iter.gt.iternc)nptot=nptot+npob
5480 write(ifch,*)'actual configuration:'
5482 if(ish.eq.27)stop'change this?????????????' !call hnbcor(1)
5487 if(iosngl.ne.nrevt+1.and.iocite.ne.1)goto1000
5489 if(liter.le.literm)then
5490 iterc(liter)=iterc(liter)+1
5493 if(ident(i).eq.ispecs(j))then
5494 lspecs(liter,j)=lspecs(liter,j)+1
5500 if(mod(iter,iterpl).eq.0)then
5503 c if(liter.le.literm)then
5504 c iterc(liter)=iterc(liter-1)
5506 c lspecs(liter,j)=lspecs(liter-1,j)
5511 if(iter.le.iternc)return
5514 call hnbzen(i) !fill energy histogram
5516 if(ident(i).eq.ispecs(j))then
5517 kspecs(j)=kspecs(j)+1
5523 call hnbzmu(1) !fill multiplicity histogram
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
5534 write(ifch,*)'accepted proposals:',nacc
5535 *,' rejected proposals:',nrej
5536 write(ifch,*)('-',i=1,30)
5537 *,' exit sr hnbmet ',('-',i=1,10)
5542 c----------------------------------------------------------------------
5543 subroutine hnbmin(keux,kedx,kesx,kecx)
5544 c----------------------------------------------------------------------
5545 c returns min hadron set with given u,d,s,c content
5547 c keux: net u quark number
5548 c kedx: net d quark number
5549 c kesx: net s quark number
5550 c kecx: net c quark number
5551 c output (written to /chnbin/):
5552 c nump: number of hadrons
5553 c ihadro(n): hadron id for n'th hadron
5554 c----------------------------------------------------------------------
5557 common/chnbin/nump,ihadro(maxp)
5561 if(ish.ge.7)wri=.true.
5562 if(wri)write(ifch,*)('-',i=1,10)
5563 *,' entry sr hnbmin ',('-',i=1,30)
5567 ke=iabs(keux+kedx+kesx+kecx)
5569 if(keux+kedx+kesx+kecx.ge.0)then
5582 if(wri)write(ifch,'(4i3)')keux,kedx,kesx,kecx
5583 if(wri)write(ifch,'(4i3)')keu,ked,kes,kec
5585 c get rid of anti-c and c (140, 240, -140, -240)
5594 if(wri)write(ifch,f1)keu,ked,kes,kec,nump,ihadro(nump)
5599 if(wri)write(ifch,f1)keu,ked,kes,kec,nump,ihadro(nump)
5610 if(wri)write(ifch,f1)keu,ked,kes,kec,nump,ihadro(nump)
5615 if(wri)write(ifch,f1)keu,ked,kes,kec,nump,ihadro(nump)
5621 c get rid of anti-s (130,230)
5629 if(wri)write(ifch,f1)keu,ked,kes,kec,nump,ihadro(nump)
5634 if(wri)write(ifch,f1)keu,ked,kes,kec,nump,ihadro(nump)
5639 c get rid of anti-d (120, -230)
5647 if(wri)write(ifch,f1)keu,ked,kes,kec,nump,ihadro(nump)
5652 if(wri)write(ifch,f1)keu,ked,kes,kec,nump,ihadro(nump)
5657 c get rid of anti-u (-120, -130)
5665 if(wri)write(ifch,f1)keu,ked,kes,kec,nump,ihadro(nump)
5670 if(wri)write(ifch,f1)keu,ked,kes,kec,nump,ihadro(nump)
5675 if(keu+ked+kes+kec.ne.ke)call utstop('hnbmin: sum_kei /= ke&')
5679 c get rid of s (3331, x330, xx30)
5683 if((4-i)*kes.gt.(i-1)*keq)then
5687 if(i.eq.3)ihadro(nump)=3331
5688 if(i.eq.2)ihadro(nump)=0330
5689 if(i.eq.1)ihadro(nump)=0030
5697 ihadro(nump)=ihadro(nump)+l*10**(4-j)
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&')
5707 if(keu+ked.ne.keq)call utstop('hnbmin: keu+ked /= keq&')
5709 c get rid of d (2221, 1220, 1120)
5713 if((4-i)*ked.gt.(i-1)*keu)then
5722 if(i.eq.2)ihadro(nump)=1220
5723 if(i.eq.1)ihadro(nump)=1120
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&')
5732 if(ked.ne.0)call utstop('hnbmin: ked .ne. 0&')
5734 c get rid of u (1111)
5741 if(wri)write(ifch,f1)keu,ked,kes,kec,nump,ihadro(nump)
5742 if(keu.lt.0)call utstop('hnbmin: negative keu&')
5746 if(keu.ne.0)call utstop('hnbmin: keu .ne. 0&')
5750 ihadro(i)=isi*ihadro(i)
5758 if(wri)write(ifch,f1)keu,ked,kes,kec,nump,ihadro(nump)
5762 if(wri)write(ifch,*)('-',i=1,30)
5763 *,' exit sr hnbmin ',('-',i=1,10)
5767 c-------------------------------------------------------------
5769 c-------------------------------------------------------------
5770 c formerly subr genbod from genlib (cernlib).
5771 c modified by K. Werner, march 94.
5772 c subr to generate n-body event
5773 c according to fermi lorentz-invariant phase space.
5774 c the phase space integral is the sum over the weights wt divided
5775 c by the number of events (sum wt / n).
5776 c adapted from fowl (cern w505) sept. 1974 by f. james.
5777 c events are generated in their own center-of-mass,
5778 c but may be transformed to any frame using loren4.
5780 c input to and output from subr thru common block config.
5782 c np=number of outgoing particles
5783 c tecm=total energy in center-of-mass
5784 c amass(i)=mass of ith outgoing particle
5786 c pcm(1,i)=x-momentum if ith particle
5787 c pcm(2,i)=y-momentum if ith particle
5788 c pcm(3,i)=z-momentum if ith particle
5789 c pcm(4,i)=energy of ith particle
5790 c pcm(5,i)=momentum of ith particle
5791 c wtxlog=log of weight of event
5792 c--------------------------------------------------------------
5795 common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
5797 dimension rno(3*maxp-4)
5798 c !pcm1 is linear equiv. of pcm to avoid double indices
5799 dimension em(maxp),pd(maxp),ems(maxp),sm(maxp)
5801 common/cffq/ffqlog(maxp)
5803 equivalence (nt,np),(amass(1),em(1)),(pcm1(1),pcm(1,1))
5805 data twopi/6.2831853073/
5807 ctp060829 nas=5 !must be at least 3
5809 if(ish.ge.7)wri=.true.
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)
5818 c..... initialization
5822 !... ffq(n) = pi * (twopi)**(n-2) / (n-2)!
5826 ffqlog(n)=ffqlog(n-1)+log(twopi/(n-2))
5830 if(nt.lt.2) goto 1001
5831 if(nt.gt.maxp) goto 1002
5842 if(tecmtm.le.0.0) goto 1000
5844 wtmlog=alog(tecmtm)*ntm2 + ffqlog(nt) - alog(tecm)
5846 c...fill rno with 3*nt-4 random numbers, the first nt-2 being ordered
5852 call flpsore(rno,ntm2)
5854 c...calculate emm().......M_i
5857 6 emm(j)=rno(j-1)*tecmtm+sm(j)
5865 pd(i)=hnbpdk(emm(i+1),emm(i),em(i+1))
5874 c...complete specification of event (raubold-lynch method)
5891 esys=sqrt(pd(i)**2+emm(i)**2)
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))
5905 aa=pcm(1,j)**2 + pcm(2,j)**2 + pcm(3,j)**2
5907 pcm(4,j)=sqrt(aa+ems(j))
5908 call hnbrt2(c,s,cb,sb,pcm,j)
5920 *write(ifch,*)'available energy zero or negative -> wtxlog=-1e35'
5926 *write(ifch,*)'less than 2 outgoing particles -> wtxlog=-1e35'
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)
5941 if(wri)write(ifch,*)('-',i=1,30)
5942 *,' exit sr hnbody ',('-',i=1,10)
5946 c---------------------------------------------------------------------------------------------------------
5947 SUBROUTINE FLPSORE(A,N)
5948 C---------------------------------------------------------------------------------------------------------
5949 C CERN PROGLIB# M103 FLPSOR .VERSION KERNFOR 3.15 820113
5952 C SORT THE ONE-DIMENSIONAL FLOATING POINT ARRAY A(1),...,A(N) BY
5955 C- PROGRAM M103 TAKEN FROM CERN PROGRAM LIBRARY, 29-APR-78
5956 C----------------------------------------------------------------------------------------------------------
5958 COMMON /SLATE/ LT(20),RT(20)
5967 20 IF(R.GT.L) GO TO 200
5970 C SUBDIVIDE THE INTERVAL L,R
5971 C L : LOWER LIMIT OF THE INTERVAL (INPUT)
5972 C R : UPPER LIMIT OF THE INTERVAL (INPUT)
5973 C J : UPPER LIMIT OF LOWER SUB-INTERVAL (OUTPUT)
5974 C I : LOWER LIMIT OF UPPER SUB-INTERVAL (OUTPUT)
5980 220 IF(A(I).GE.X) GO TO 230
5983 230 IF(A(J).LE.X) GO TO 231
5987 231 IF(I.GT.J) GO TO 232
5993 IF(I.LE.J) GO TO 220
5996 IF((R-I).GE.(J-L)) GO TO 30
6008 if(a(i).gt.a(i+1))stop'FLPSORE: ERROR. '
6018 c-------------------------------------------------------------
6020 c-------------------------------------------------------------
6021 c subr to generate n-body event
6022 c according to non-invariant phase space.
6023 c the phase space integral is the sum over the weights exp(wtxlog)
6024 c divided by the number of events.
6025 c ref.: hagedorn, nuov. cim. suppl ix, x (1958) 646.
6026 c events are generated in their own center-of-mass.
6028 c input to and output from subr is thru common block config.
6030 c np=number of outgoing particles
6031 c tecm=total energy in center-of-mass
6032 c amass(i)=mass of ith outgoing particle
6034 c pcm(1,i)=x-momentum of ith particle
6035 c pcm(2,i)=y-momentum of ith particle
6036 c pcm(3,i)=z-momentum of ith particle
6037 c pcm(4,i)=energy of ith particle
6038 c pcm(5,i)=momentum of ith particle
6039 c wtxlog=log of weight of event
6040 c--------------------------------------------------------------
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)
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)
6055 c initialization ktnbod=1
6057 if(ktnbod.gt.1) goto 1
6058 c !ffqlog(n) = log{ (4*pi)**n / (n-1)! }
6059 ffqlog(1)=alog(4*pi)
6061 ffqlog(n)=ffqlog(n-1)+alog(4*pi/(n-1))
6064 c set wtxlog -infinity for np<2
6065 if(np.lt.2) goto 1001
6066 c special treatment for np=2
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)) )
6073 *write(ifch,*)'wtxlog:',wtxlog,' (np=2 treatment)'
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)
6089 c stop if np too large
6090 if(np.gt.maxp) goto 1002
6091 c initialization all ktnbod
6097 if(tt.le.0.0) goto 1000
6099 wtxlog=alog(tt)*(np-1) + ffqlog(np)
6101 *write(ifch,*)'wtxlog:',wtxlog,' (prefactor)'
6102 c fill rnoz with np-1 random numbers
6112 c calculate z_i distributed as i*z*(i-1)
6114 zi(i)=rnoz(i)**(1./i)
6121 c calculate t_i, e_i, p_i
6122 if(ish.ge.9)write(ifch,*)'calculate t_i, e_i, p_i ...'
6127 if(ti(1).le.0.)ti(1)=1e-10
6129 if(ti(np).le.0.)ti(np)=1e-10
6132 if(ti(i).le.0.)ti(i)=1e-10
6138 pcm(4,i)=ti(i)+amass(i)
6139 p52=ti(i)*(ti(i)+2*amass(i))
6143 pcm(5,i)=ti(i)*sqrt(1+2*amass(i)/ti(i))
6147 call hnbraw(7,200,w)
6149 wtxlog=wtxlog+alog(w)
6154 wtxlog=wtxlog+alog(pcm(5,i))+alog(ti(i)+amass(i))
6157 *write(ifch,*)'wtxlog:',wtxlog
6160 write(ifch,*)'momenta:'
6166 ps(j)=ps(j)+pcm(j,i)
6168 write(ifch,'(1x,i3,5x,5f12.5)')i,(pcm(j,i),j=1,5)
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)
6174 c complete specification of event (random rotations and then deformations)
6176 if(ish.ge.7)write(ifch,*)'momenta after rotations:'
6179 if(ish.ge.7)write(ifch,*)'momenta after deformations:'
6186 *write(ifch,*)'available energy zero or negative -> wtxlog=-1e35'
6192 *write(ifch,*)'less than 2 outgoing particles -> wtxlog=-1e35'
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)
6207 call utprix('hnbodz',ish,ishini,6)
6211 c-----------------------------------------------------------------------
6212 subroutine hnbolo(loops)
6213 c-----------------------------------------------------------------------
6215 c-----------------------------------------------------------------------
6218 common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
6222 c-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
6226 if(wtxlog.gt.-1e30)then
6230 if(alog(a).lt.wtxlog-c-20)then
6237 if(ish.ge.8)write(ifch,*)'k:',k,' c:',c
6244 c-----------------------------------------------------------------------
6245 function hnbpdk(a,b,c)
6246 c-----------------------------------------------------------------------
6247 c formerly pdk from cernlib
6248 c returns momentum p for twobody decay a --> b + c
6249 c a, b, c are the three masses
6250 c~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
6251 c this p is related to twobody phase space as R2 = pi * p /a
6252 c-----------------------------------------------------------------------
6253 double precision aa,bb,cc,a2,b2,c2
6260 if(a2 + (b2-c2)**2/a2-2.0*(b2+c2).le.0.)then
6263 hnbpdk = 0.5*dsqrt(a2 + (b2-c2)**2/a2 - 2.0*(b2+c2))
6268 c----------------------------------------------------------------------
6269 subroutine hnbpad(k,n1,n2,n3,n4,mm,jc)
6270 c----------------------------------------------------------------------
6271 c k=1: determ pair indices k1,k2
6272 c k=2: determ pair indices k3,k4 (.ne. n1,n2)
6273 c k=1 and k=2: mm: type of pair, jc: flavour of pair
6274 c----------------------------------------------------------------------
6276 integer jc(nflav,2),ic(2),jc1(nflav,2),ic1(2),jc2(nflav,2),ic2(2)
6277 common /clatt/nlattc,npmax
6279 common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
6286 c determine n1,n2 and mm
6287 c ----------------------
6289 n1=1+rangen()*nlattc
6292 n2=1+rangen()*nlattc
6301 if(n1.eq.k1.or.n1.eq.k2.or.n2.eq.k1.or.n2.eq.k2)goto1
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
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)
6313 c flavour of n1+n2 --> jc
6314 c -----------------------
6316 call idtr4(ident(n1),ic1)
6317 call iddeco(ic1,jc1)
6318 call idtr4(ident(n2),ic2)
6319 call iddeco(ic2,jc2)
6322 jc(i,j)=jc1(i,j)+jc2(i,j)
6325 elseif(mm.eq.2.and.ident(n1).ne.0)then
6326 call idtr4(ident(n1),ic)
6328 elseif(mm.eq.2.and.ident(n2).ne.0)then
6329 call idtr4(ident(n2),ic)
6347 c----------------------------------------------------------------------
6348 subroutine hnbpai(id1,id2,jc)
6349 c----------------------------------------------------------------------
6350 c returns arbitrary hadron pair id1,id2, flavour written to jc
6351 c----------------------------------------------------------------------
6353 integer jc(nflav,2),jc1(nflav,2),ic1(2),jc2(nflav,2),ic2(2)
6354 parameter (mspecs=56)
6355 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
6357 c construct pair id1,id2
6358 c ----------------------
6359 i1=rangen()*(nspecs+iozero)-(iozero-1)
6372 call iddeco(ic1,jc1)
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)
6389 call iddeco(ic2,jc2)
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
6399 jc(i,j)=jc1(i,j)+jc2(i,j)
6412 if(ish.ge.7)write(ifch,'(a,6i2,3x,6i2)')' jc:',jc
6417 c----------------------------------------------------------------------
6418 subroutine hnbpaj(jc,iwpair,id1,id2)
6419 c----------------------------------------------------------------------
6420 c returns sum of weights iwpair of possible pairs
6421 c and randomly chosen hadron pair id1,id2 for given flavour jc
6422 c----------------------------------------------------------------------
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)
6438 c *call utstop('hnbpaj: nflav.gt.6: modify this routine&')
6440 c construct possible pairs id1,id2
6441 c --------------------------------
6446 if(jc(1,1).gt.2)then
6448 elseif(jc(1,1).lt.0)then
6450 elseif(jc(2,1).gt.2)then
6452 elseif(jc(2,1).lt.0)then
6454 elseif(jc(3,1).gt.2)then
6456 elseif(jc(3,1).lt.0)then
6458 elseif(jc(1,2).gt.1)then
6460 elseif(jc(1,2).lt.-1)then
6462 elseif(jc(2,2).gt.1)then
6464 elseif(jc(2,2).lt.-1)then
6466 elseif(jc(3,2).gt.1)then
6468 elseif(jc(3,2).lt.-1)then
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
6474 idx=idxpair(jc(1,1),jc(2,1),jc(3,1),jc(1,2),jc(2,2),jc(3,2))
6476 if(ipair.eq.0)return
6477 iwpair=iwtpaist(0,idx)
6479 idpair(1,i)=idpairst(1,i,idx)
6480 idpair(2,i)=idpairst(2,i,idx)
6481 iwtpai(i)=iwtpaist(i,idx)
6483 goto 4 !pair fixed via table
6487 if(nspecs+1.gt.mxids)call utstop('hnbpaj: mxids too small&')
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)
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
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
6523 if(nids.gt.mxpair)call utstop('hnbpaj: mxpair too small&')
6527 idpair(2,ipair)=ids(k)
6528 iwtpai(ipair)=iozero*iwts(k)
6529 iwpair=iwpair+iwtpai(ipair)
6530 c if(ish.ge.6)write(ifch,'(a,i5,5x,a,i6,i6,5x,a,i6)')' pair nr:'
6531 c *,ipair,'ids:',0,ids(k),'weight:',iwtpai(ipair)
6541 c jc2(i,1)=jc(i,1)-jspecs(1,i,i1)
6542 c jc2(i,2)=jc(i,2)-jspecs(2,i,i1)
6544 c write(ifch,'(1x,a,i3,a,i6,a,6i2,3x,6i2)')
6545 c *'i1:',i1,' id1:',ispecs(i1),' jc1:'
6546 c *,(jspecs(1,i,i1),i=1,6),(jspecs(2,i,i1),i=1,6)
6547 c write(ifch,'(a,6i2,3x,6i2)')' jc2:',jc2
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)
6556 c-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'
6562 if(abs(jcmi(1)).gt.3)goto3
6563 if(abs(jcmi(2)).gt.3)goto3
6564 if(abs(jcmi(3)).gt.3)goto3
6565 if(abs(jcmi(4)).gt.3)goto3 !-charm
6567 if(jcmi(1).ne.0)goto111
6568 if(jcmi(2).ne.0)goto111
6569 if(jcmi(3).ne.0)goto111
6570 if(jcmi(4).ne.0)goto111 !-charm
6576 lkfok1=lkfok(1,jcmi(1),jcmi(2),jcmi(3),jcmi(4))
6579 ids(nids)=lkfok(2,jcmi(1),jcmi(2),jcmi(3),jcmi(4))
6583 ids(nids)=lkfok(3,jcmi(1),jcmi(2),jcmi(3),jcmi(4))
6586 if(lkfok1.gt.7) !-charm
6587 * stop'HNBPAJ: dimension of lkfok too small'
6590 ids(nids)=lkfok(1+ii,jcmi(1),jcmi(2),jcmi(3),jcmi(4))
6598 c if(jcmi(1).ne.ifok(1,j))goto222
6599 c if(jcmi(2).ne.ifok(2,j))goto222
6600 c if(jcmi(3).ne.ifok(3,j))goto222
6601 c if(jcmi(4).ne.ifok(4,j))goto222
6602 c if(jcmi(5).ne.ifok(5,j))goto222
6603 c if(jcmi(6).ne.ifok(6,j))goto222
6605 c ids(nids)=ispecs(j)
6611 if(ipair+nids.gt.mxpair)call utstop('hnbpaj: mxpair too small&')
6614 idpair(1,ipair)=ispecs(i1)
6615 idpair(2,ipair)=ids(k)
6616 iwtpai(ipair)=iwts(k)
6617 iwpair=iwpair+iwtpai(ipair)
6623 write(ifch,'(a,i5,5x,a,i6,i6,5x,a,i6)')' pair nr:'
6624 *,ipair0,'ids:',ispecs(i1),ids(k),'weight:',iwtpai(ipair0)
6634 if(iwpair.ne.0)call utstop('hnbpaj: iwpair.ne.0&')
6651 c if(ish.ge.6)write(ifch,*)'random number:',r
6652 c *,' --> chosen pair:',ip
6656 write(ifmt,*)'hnbpaj:',jc,idx,ipair,iwpair,r,ir
6657 call utstop('hnbpaj: no pair selected&')
6664 c----------------------------------------------------------------------
6665 subroutine hnbpajini
6666 c----------------------------------------------------------------------
6667 c initialize array to speed up hnbpaj calculation
6668 c store sum of weights iwpair of possible pairs in an array
6669 c for any combinations of quarks
6670 c----------------------------------------------------------------------
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)
6684 c write(ifmt,*)' Initialize droplet decay ...'
6686 c construct possible pairs id1,id2
6687 c --------------------------------
6697 idxpair(iqu,iqd,iqs,iaqu,iaqd,iaqs)=idx
6713 if(nspecs+1.gt.mxids)call utstop('hnbpajini: mxids too small&')
6721 if(jc1mi2(1).ne.0)goto11
6722 if(jc1mi2(2).ne.0)goto11
6723 if(jc1mi2(3).ne.0)goto11
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
6740 if(nids.gt.mxpair)call utstop('hnbpajini: mxpair too small&')
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)
6747 c if(ish.ge.6)write(ifch,'(a,i5,5x,a,i6,i6,5x,a,i6)')' pair nr:'
6748 c *,ipair,'ids:',0,ids(k),'weight:',iwtpai(ipair)
6758 c jc2(i,1)=jc(i,1)-jspecs(1,i,i1)
6759 c jc2(i,2)=jc(i,2)-jspecs(2,i,i1)
6761 c write(ifch,'(1x,a,i3,a,i6,a,6i2,3x,6i2)')
6762 c *'i1:',i1,' id1:',ispecs(i1),' jc1:'
6763 c *,(jspecs(1,i,i1),i=1,6),(jspecs(2,i,i1),i=1,6)
6764 c write(ifch,'(a,6i2,3x,6i2)')' jc2:',jc2
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)
6774 if(abs(jcmi(1)).gt.3)goto3
6775 if(abs(jcmi(2)).gt.3)goto3
6776 if(abs(jcmi(3)).gt.3)goto3
6778 if(jcmi(1).ne.0)goto111
6779 if(jcmi(2).ne.0)goto111
6780 if(jcmi(3).ne.0)goto111
6786 lkfok1=lkfok(1,jcmi(1),jcmi(2),jcmi(3),jcmi(4))
6789 ids(nids)=lkfok(2,jcmi(1),jcmi(2),jcmi(3),jcmi(4))
6793 ids(nids)=lkfok(3,jcmi(1),jcmi(2),jcmi(3),jcmi(4))
6796 if(lkfok1.gt.7) !-charm
6797 * stop'HNBPAJINI: dimension of lkfok too small'
6800 ids(nids)=lkfok(1+ii,jcmi(1),jcmi(2),jcmi(3),jcmi(4))
6808 c if(jcmi(1).ne.ifok(1,j))goto222
6809 c if(jcmi(2).ne.ifok(2,j))goto222
6810 c if(jcmi(3).ne.ifok(3,j))goto222
6811 c if(jcmi(4).ne.ifok(4,j))goto222
6812 c if(jcmi(5).ne.ifok(5,j))goto222
6813 c if(jcmi(6).ne.ifok(6,j))goto222
6815 c ids(nids)=ispecs(j)
6821 if(ipair+nids.gt.mxpair)
6822 & call utstop('hnbpajini: mxpair too small&')
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)
6838 if(iwtpaist(0,idx).ne.0)call utstop('hnbpajini: iwpair.ne.0&')
6854 c--------------------------------------------------------------------
6855 subroutine hnbraw(npx,npy,w)
6856 c--------------------------------------------------------------------
6857 c returns random walk fctn w=w(0,p_1,p_2,...,p_n) for noncovariant
6858 c phase space integral (see hagedorn, suppl nuov cim ix(x) (1958)646)
6859 c input: dimension np and momenta p_i=pcm(5,i) via /confg/
6860 c 1 < np <= npx : hagedorn method
6861 c npx < np <= npy : integral method
6862 c npy < np : asymptotic method
6863 c--------------------------------------------------------------------
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
6871 if(ish.ge.9)write(ifch,*)('-',i=1,10)
6872 *,' entry sr hnbraw ',('-',i=1,30)
6874 if(np.lt.3)call utstop('hnbraw: np must be at least 3&')
6886 c sum p_i - 2*p_max not positive
6887 c ------------------------------
6894 if(ps-2*px.le.0.)then
6896 if(ish.ge.7)write(ifch,'(1x,a,e12.5,4x)')
6897 *'sum p_i - 2*p_max not positive --> w:',w
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
6920 if(ish.ge.9)write(ifch,*)'integral method...'
6928 if(ish.ge.9)write(ifch,*)'it:',it
6931 call uttrap(hnbrax,0.,b,win)
6933 if(abs(win-wio).le.epsr*abs((win+wio)/2))iok=1
6934 if(it.eq.itmax)iok=1
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
6940 *.and.abs(win-wio).gt.epsr*abs((win+wio)/2))then
6943 call utmsg('hnbraw')
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
6952 if(it.eq.1.or.iok.eq.0)goto3
6961 call utmsg('hnbraw')
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
6973 c hagedorn method (double)
6974 c ------------------------
6989 ww=iprosi*(ppsum/ppmax)**(np-3)
6991 *write(ifch,'(4x,i5,12x,f7.2,i5,f11.2)')np,sngl(ppsum)
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)
7003 *write(ifch,'(4x,2i5,2f7.2,i5,f11.2)')
7004 *np,i,sngl(2*isi(i)*ppcm(i)),sngl(ppsum),iprosi,sngl(ww)
7007 *write(ifch,'(4x,2i5,2f7.2,i5,4x,a)')
7008 *np,i,sngl(2*isi(i)*ppcm(i)),sngl(ppsum),iprosi,'not counted'
7020 ww=ww*pmax/ppcm(i)/2./i
7022 ww=-ww/pmax**3/pi/2.*np*(np-1)*(np-2)
7024 if(ish.ge.7)write(ifch,'(1x,a,e12.5,4x,a)')
7025 *'hagedorn method: whd:',whd,'double precision'
7030 if(ish.ge.9)write(ifch,*)('-',i=1,30)
7031 *,' exit sr hnbraw ',('-',i=1,10)
7035 c--------------------------------------------------------------------
7037 c--------------------------------------------------------------------
7038 c returns integrand for random walk fctn w=w(0,p_1,p_2,...,p_n):
7039 c 1./(2*pi**2) * x**2 * prod[sin(p_i*x)/(p_i*x)]
7040 c input: dimension np and momenta p_i=pcm(5,i) via /confg/
7041 c--------------------------------------------------------------------
7043 common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
7044 common/cnsta/pi,pii,hquer,prom,piom,ainfin
7048 if(px.ne.0.)hnbrax=hnbrax*sin(px)/px
7053 c----------------------------------------------------------------------
7055 c----------------------------------------------------------------------
7056 c removes intermediate zeros from ident
7058 c----------------------------------------------------------------------
7061 common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
7062 c integer identx(maxp)
7063 common /clatt/nlattc,npmax
7064 if(ish.ge.9)write(ifch,*)('-',i=1,10)
7065 *,' entry sr hnbrmz ',('-',i=1,30)
7069 c identx(i)=ident(i)
7081 if(ident(i).ne.0)goto1
7084 if(ident(np).eq.0)goto2
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
7092 if(i.eq.np+1)goto1000
7099 if(ish.ge.9)write(ifch,*)('-',i=1,30)
7100 *,' exit sr hnbrmz ',('-',i=1,10)
7103 c----------------------------------------------------------------------
7105 c----------------------------------------------------------------------
7106 c deformes polygon of a sequence of arbitrarily rotated momentum
7107 c vectors such that the polygon gets closed
7108 c input: pcm(1-3,i) representing polygon
7109 c output: pcm(1-3,i) representing closed polygon
7110 c----------------------------------------------------------------------
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:'
7123 if(ish.ge.8)write(ifch,'(a,i4,a,f12.6)')
7124 *' kmax:',kmax,' x2max:',x2max
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
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
7166 a=min(fac,fac*yy/zz)
7170 www=w(1)**2+w(2)**2+w(3)**2
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
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
7200 c----------------------------------------------------------------------
7201 subroutine hnbrop(ishx,ichk)
7202 c----------------------------------------------------------------------
7203 c prints momenta of configuration (essentially to check rotation procedure)
7204 c----------------------------------------------------------------------
7207 common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
7208 double precision ps(5)
7215 ps(j)=ps(j)+pcm(j,i)
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)
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)
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)
7235 c----------------------------------------------------------------------
7237 c----------------------------------------------------------------------
7238 c rotates momenta of /confg/ randomly
7240 c output: pcm(1-3,i)
7241 c----------------------------------------------------------------------
7242 common/cnsta/pi,pii,hquer,prom,piom,ainfin
7244 common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
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)
7260 cc-------------------------------------------------------------------
7261 c subroutine hnbrt2old(c,s,c2,s2,pr,i)
7262 cc-------------------------------------------------------------------
7263 cc formerly subr rotes2 from cernlib
7264 cc this subr now does two rotations (xy and xz)
7265 cc-------------------------------------------------------------------
7266 c parameter(maxp=500)
7267 c dimension pr(5*maxp)
7273 c pr(k2) = sa*s + sb*c
7276 c pr(k1) = a*c2 - b*s2
7277 c pr(k2) = a*s2 + b*c2
7281 c-------------------------------------------------------------------
7282 subroutine hnbrt2(c,s,c2,s2,pr,i)
7283 c-------------------------------------------------------------------
7284 c formerly subr rotes2 from cernlib
7285 c this subr now does two rotations (xy and xz)
7286 c-------------------------------------------------------------------
7288 dimension pr(5,maxp)
7294 pr(2,i) = sa*s + sb*c
7297 pr(1,i) = a*c2 - b*s2
7298 pr(3,i) = a*s2 + b*c2
7302 cc-----------------------------------------------------------------------
7303 c subroutine hnbsor(a,n)
7304 cc-----------------------------------------------------------------------
7305 cc cern proglib# m103 flpsor .version kernfor 3.15 820113
7307 cc-----------------------------------------------------------------------
7308 cc sort the one-dimensional floating point array a(1),...,a(n) by
7309 cc increasing values
7310 cc-----------------------------------------------------------------------
7312 c common /slate/ lt(20),rt(20)
7321 c 20 if(r.gt.l) go to 200
7322 c if(level) 50,50,10
7324 cc subdivide the interval l,r
7325 cc l : lower limit of the interval (input)
7326 cc r : upper limit of the interval (input)
7327 cc j : upper limit of lower sub-interval (output)
7328 cc i : lower limit of upper sub-interval (output)
7334 c 220 if(a(i).ge.x) go to 230
7337 c 230 if(a(j).le.x) go to 231
7341 c 231 if(i.gt.j) go to 232
7347 c if(i.le.j) go to 220
7350 c if(level.gt.20)stop'level too large'
7351 c if((r-i).ge.(j-l)) go to 30
7363 c-----------------------------------------------------------------------
7364 subroutine hnbspd(iopt)
7365 c-----------------------------------------------------------------------
7366 c defines particle species and masses and degeneracies.
7368 c iopt=odd number: massless
7369 c iopt=even number: same as iopt-1, but massive
7370 c iopt= 1: pi0 (massless)
7372 c iopt= 3: pi-,pi0,pi+ (massless)
7373 c iopt= 4: pi-,pi0,pi+
7374 c iopt= 5: pi-,pi0,pi+,prt,aprt,ntr,antr (massless)
7375 c iopt= 6: pi-,pi0,pi+,prt,aprt,ntr,antr
7376 c iopt= 7: 25 hadrons (massless)
7377 c iopt= 8: 25 hadrons
7378 c iopt= 9: 54 hadrons (massless)
7379 c iopt=10: 54 hadrons
7380 c iopt=11: 3 quarks (massless)
7382 c iopt=13: 54 hadrons + J/psi (massless)
7383 c iopt=14: 54 hadrons + J/psi
7384 c iopt=15: 54 hadrons + J/psi + H (massless)
7385 c iopt=16: 54 hadrons + J/psi + H
7387 c nspecs: nr of species
7390 c-----------------------------------------------------------------------
7391 parameter (mspecs=56)
7392 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
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)
7404 data jspe03/ 110, 120, -120 /
7405 data jspe05/ 110, 120, -120, 1120,-1120, 1220,-1220 /
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 /
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 /
7418 * 1, -1, 2, -2, 3, -3 /
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
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
7436 if(iopt.gt.16)call utstop('hnbspd: invalid option&')
7437 ioptx=(1+iopt)/2*2-1
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
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)
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
7463 call hnbspi(ispecs(i),gg)
7470 do iic=-3, 3 !-charm
7475 lkfok(ii,iiu,iid,iis,iic)=0 !-charm
7476 lkfoi(ii,iiu,iid,iis,iic)=0 !-charm
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)
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
7500 c-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
7509 c write(6,'(i5,5x,3i5,5x,i5,5x,6i5)')
7510 c * id,iiu,iid,iis,(lkfok(iiu,iid,iis,kk),kk=1,7)
7516 c-------------------------------------------------------------
7517 subroutine hnbspf(ku,kd,ks,kc,kb,kt,j,n,spelog)
7518 c-------------------------------------------------------------
7519 c returns spelog = log of factor for consid. different species
7520 c spelog is double precision
7521 c option ioflac determines the method:
7522 c ioflac=1: ignore flavour conservation
7523 c ioflac=2: flavour conservation implemented straightforward
7524 c (only for nspecs=3,7)
7525 c ioflac=3: flavour conservation via generating fctn
7527 c ku,...,kt (integer) : flavour
7528 c j (integer) : excluded species
7529 c n (integer) : multiplicity
7530 c-------------------------------------------------------------
7532 parameter (mspecs=56)
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
7540 c parameter(numax=100,kqmax=100)
7541 c 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
7560 if(ish.ge.9)write(ifch,'(1x,a,i1)')'ioflac=',ioflac
7563 if(i.ne.j)g=g+gspecs(i)
7565 spelog=n*dlog(1.d0*g)
7567 elseif(ioflac.eq.2)then
7569 if(ish.ge.9)write(ifch,'(1x,a,i2)')'ioflac:',ioflac
7571 if(ish.ge.9)write(ifch,'(1x,a,i2)')'nspecs:',nspecs
7573 if(j.lt.1.or. j.gt.k)then
7578 if(ifoa(nf).eq.0.and.ifot(nf).eq.0)goto5
7579 if(n1*ifok(nf,1)+n2*ifok(nf,2)+n3*ifok(nf,3).ne.ifot(nf))goto2
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
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
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
7608 if(ish.ge.9)write(ifch,*)'spe:',spe
7610 if(spe.gt.0.d0)spelog=dlog(spe)
7611 if(ish.ge.9)write(ifch,*)'spelog:',spelog
7613 if(ish.ge.9)write(ifch,'(1x,a,i2)')'nspecs:',nspecs
7614 if(n.gt.mxfacu)call utstop('hnbspf: mxfacu too small&')
7616 faci(lf)=1.d0/utgam2(1d0+lf)
7619 if(j.lt.1.or. j.gt.k)then
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
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)
7630 *+n5*ifok(nf,5)+n6*ifok(nf,6)+n7*ifok(nf,7).ne.ifot(nf))goto12
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
7647 do 13 i5=0,n-i1-i2-i3-i4
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)
7670 *+n5*ifok(nf,5)+n6*ifok(nf,6)+n7*ifok(nf,7).ne.ifot(nf))goto13
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
7682 if(ish.ge.9)write(ifch,*)'spe:',spe
7684 if(spe.gt.0.d0)spelog=dlog(spe)
7685 if(ish.ge.9)write(ifch,*)'spelog:',spelog
7687 call utstop('hnbspf: ioflac=2 only for nspecs=3,7&')
7690 elseif(ioflac.eq.3)then
7692 call utstop('hnbspf: ioflac must be 1 or 2&')
7696 if(ish.ge.9)write(ifch,*)('-',i=1,30)
7697 *,' exit sr hnbspf ',('-',i=1,10)
7701 c-------------------------------------------------------------
7702 subroutine hnbspg(ku,kd,ks,kc,kb,kt,j,n,spelog)
7703 c-------------------------------------------------------------
7705 double precision spelog,spalog
7706 if(ioflac.ne.0)return
7708 call hnbspf(ku,kd,ks,kc,kb,kt,j,n,spalog)
7710 call hnbspf(ku,kd,ks,kc,kb,kt,j,n,spelog)
7712 write(ifch,*)'ioflac=2/3:',spalog,spelog
7716 c----------------------------------------------------------------------
7717 subroutine hnbspi(id,spideg)
7718 c----------------------------------------------------------------------
7719 c returns spin degeneracy spideg for particle id-code id
7720 c----------------------------------------------------------------------
7722 parameter (nspec=62)
7723 dimension ispec(nspec),spid(nspec)
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
7744 if(id.eq.ispec(i))then
7749 call idflav(id,ifl1,ifl2,ifl3,jspin,index)
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
7755 if(abs(id).gt.1000)then
7757 elseif(abs(id).lt.1000)then
7765 call utstop('hnbspi: id not found&')
7770 c----------------------------------------------------------------------
7771 subroutine hnbtst(iof12)
7772 c----------------------------------------------------------------------
7773 c calculates logs of prefactors and phase space integral
7774 c for ultrarelativistic limit (massless particles) and (2*s_i+1)=1
7775 c f12log and w15log=w35log+f12log not calculated calculated for iof12=0
7776 c----------------------------------------------------------------------
7779 common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
7780 common/ctst/psulog,wtulog
7782 common /clatt/nlattc,npmax
7787 if(ishsub/100.eq.23)ish=mod(ishsub,100)
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)
7796 if(ish.ge.7)write(ifch,*)'n_l:',nlattc,' n_0:',nlattc-np
7798 c log of prod m_i*volu/4/pi**3/hquer**3 -> f5log
7801 call hnbfaf(i,gg,am,ioma)
7802 f5log=f5log+alog(gg*am*volu/4/pi**3/hquer**3)
7804 if(ish.ge.7)write(ifch,*)'log(f5):',f5log
7808 if(ish.ge.7)write(ifch,*)'log(f4):',f4log
7810 c log of 1/prod n_alpha! -> f3log
7818 if(ident(n2).eq.ident(n1))then
7823 if(ii(n2).ne.0.and.n2.gt.n1.and.nx.eq.n1
7824 *.and.ident(n2).ne.ident(n1))nx=n2
7832 if(ish.ge.7)write(ifch,*)'log(f3):'
7835 c log of f3 * f4 * f5
7836 f35log=f5log+f4log+f3log
7837 if(ish.ge.7)write(ifch,*)'log(f3*f4*f5):',f35log
7839 c log of phase space integral --> psilog
7841 psilog=alog(2.*np*np*(np-1)/tecm**4/pi)
7843 psilog=psilog+alog(tecm**2*pi/2./i/i)
7845 elseif(iocova.eq.2)then
7846 psilog=-alog(2.*np-1)
7847 psilog=psilog+(np-1)*alog(pi/2.)
7849 psilog=psilog+alog((2.*np+i-2)/i)
7852 psilog=psilog+alog(tecm/i)
7855 if(ish.ge.7)write(ifch,*)'log(psi):',psilog
7857 c log of phase space integral * f3 * f4 * f5
7858 w35log=f35log+psilog
7859 if(ish.ge.7)write(ifch,*)'log(f35*psi):',w35log
7863 c log of macro/micro factor (f1*f2) --> f12log
7866 deglog=deglog+alog(1.*i)
7870 deglog=deglog+alog(nlattc+1.-i)-alog(1.*i)
7874 w15log=w35log+f12log
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
7889 if(ish.ge.7)write(ifch,*)('-',i=1,30)
7890 *,' exit sr hnbtst ',('-',i=1,10)
7895 cc----------------------------------------------------------------------
7896 c subroutine hnbuex(x,e)
7897 cc----------------------------------------------------------------------
7898 cc x --> x*10.**e with x.lt.10.**10.
7899 cc----------------------------------------------------------------------
7903 c e=int(alog10(abs(x)))/10*10
7909 cc----------------------------------------------------------------------
7910 c subroutine hnbwin(n,w,q,i)
7911 cc----------------------------------------------------------------------
7912 cc returns random index i according to weight w(i)
7913 cc----------------------------------------------------------------------
7922 c if(q(k).ge.y)goto1000
7928 c----------------------------------------------------------------------
7930 c----------------------------------------------------------------------
7931 c writes (to ifch) an configuration
7932 c----------------------------------------------------------------------
7935 common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
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
7943 write(ifch,*)faclog,wtxlog,wtlog
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)
7953 c----------------------------------------------------------------------
7954 subroutine hnbzen(iii)
7955 c----------------------------------------------------------------------
7956 c analysis of events. energy spectra.
7957 c for iii>0: filling histogram considering ptl iii
7958 c----------------------------------------------------------------------
7960 common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
7961 parameter (mspecs=56)
7962 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
7963 parameter (nhise=100)
7964 common/chise/hise(mspecs,nhise)
7971 if(ident(i).eq.ispecs(l))then
7979 ke=1+int((e-am)/(2*de))
7980 if(ke.ge.1.and.ke.le.nhise)hise(j,ke)=hise(j,ke)+1
7985 stop'STOP in hnbzen: iii=0'
7991 c----------------------------------------------------------------------
7992 subroutine hnbzmu(iii)
7993 c----------------------------------------------------------------------
7994 c analysis of events. multiplicity spectra.
7995 c for iii<0: settting histograms to zero (should be first call)
7996 c for iii>0: filling histogram considering ptl iii
7997 c----------------------------------------------------------------------
7999 common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
8000 parameter (mspecs=56)
8001 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
8002 parameter (nhismu=500)
8003 common/chismu/hismu(mspecs,0:nhismu),hismus(nhismu)
8017 elseif(iii.gt.0)then
8019 if(np.ge.1.and.np.le.nhismu)hismus(np)=hismus(np)+1
8023 if(ident(i).eq.ispecs(j))mu=mu+1
8025 if(mu.ge.0.and.mu.le.nhismu)hismu(j,mu)=hismu(j,mu)+1
8031 stop'STOP in sr hnbzmu: iii must not be 0'
8039 c-----------------------------------------------------------------------
8040 subroutine xhgcam(amt,iii)
8041 c-----------------------------------------------------------------------
8042 c creates unnormalized histogram for total mass of grand
8043 c canonically generated sample
8044 c xpar1: nr. of bins
8045 c xpar2: m_1 (lower boundary)
8046 c xpar3: m_2 (upper boundary)
8047 c-----------------------------------------------------------------------
8050 common/camdat/data(nbmx),datb(nbmx)
8051 parameter(mxclu=10000)
8053 character cen*6,cvol*6
8061 elseif(iii.lt.0)then
8067 write(cen,'(f6.1)')tecm
8068 write(cvol,'(f6.1)')volu
8071 data(i)=x1+(i-1)*dam
8076 xnb=(am(i)-x1)/dam+1.
8078 if(nb.le.nbin.and.nb.ge.1)datb(nb)=datb(nb)+1
8081 write(ifhi,'(a)') 'newpage zone 1 2 1'
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'
8094 write(ifhi,'(2e13.5)')data(j),datb(j)
8097 write(ifhi,'(a)') ' endarray'
8098 write(ifhi,'(a)') 'closehisto plot 0'
8107 c-----------------------------------------------------------------------
8108 subroutine xhgccc(chi)
8109 c-----------------------------------------------------------------------
8110 c creates unnormalized histogram for chi-squared test of initial
8111 c configuration (grand-canonical results are used)
8112 c for chi>0: chi-squared for each droplet configuration is written
8114 c for chi<0: creates histogram
8115 c xpar1 specifies lower limit
8116 c xpar2 specifies upper limit
8117 c xpar3 specifies bin width
8118 c newpage, zone and plot commands not included !!!
8119 c-----------------------------------------------------------------------
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
8126 parameter (mspecs=56)
8127 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
8136 elseif(chi.lt.0.0)then
8141 write(cnu,'(i2)')nspecs
8142 write(cinco,'(i1)')ioinco
8143 write(cen,'(f6.1)')tecm
8144 write(cvol,'(f6.1)')volu
8156 nb=(chi2(i)+da/2.-a0)/da
8157 if(nb.le.nbin.and.nb.ge.1)datb(nb)=datb(nb)+1
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'
8171 dat=datb(j)/nevent/da
8172 write(ifhi,'(2e13.5)')data(j),dat
8175 write(ifhi,'(a)') ' endarray'
8176 write(ifhi,'(a)') 'closehisto'
8184 c-----------------------------------------------------------------------
8186 c-----------------------------------------------------------------------
8187 c creates energy spectrum plot for decayed QM-droplet
8188 c using grand canonical results
8190 c xpar1 specifies particle species by paige id, 0 for all
8191 c xpar2 and xpar3 specify xrange of plot
8192 c xpar4 specifies line type : dashed (0), dotted (1), full (2) dado (3)
8193 c xpar5 specifies statistics to be used ,(0) same as iostat
8197 c newpage, zone and plot commands not included !!!
8198 c-----------------------------------------------------------------------
8200 common/citer/iter,itermx
8201 parameter (nbin=200)
8202 real datx(nbin),daty(nbin)
8203 parameter (mspecs=56)
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
8214 if(ist.eq.0.and.iostat.eq.1)ist=1
8219 if(ispecs(i).eq.idpa)id=i
8226 datx(j)=x0+(j-1)*dx*2.
8233 if(datx(j).ge.aspecs(i))then
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
8239 if(mod(igsp,2).eq.0.and.ist.eq.0)then
8241 elseif(x.le.1.e-7.and.ist.eq.0)then
8243 elseif(ist.eq.0)then
8245 elseif(ist.eq.1)then
8249 daty(j)=daty(j)+dnde*gspecs(i)*volu/hquer**3/8./pi**3
8255 if(datx(j).ge.aspecs(id))then
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
8261 if(mod(igsp,2).eq.0.and.ist.eq.0)then
8263 elseif(x.le.1.e-7.and.ist.eq.0)then
8265 elseif(ist.eq.0)then
8267 elseif(ist.eq.1)then
8271 11 daty(j)=dnde*gspecs(id)*volu/hquer**3/8./pi**3
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'
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'
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//'"'
8302 write(ifhi,'(a,a)') 'text 0.4 0.91 "V='//cvo//'"'
8303 write(ifhi,'(a,a)') 'text 0.15 0.91 "E='//cen//'"'
8305 write(ifhi,'(a)') 'array 2'
8308 write(ifhi,'(2e12.4)')datx(j),daty(j)
8311 write(ifhi,'(a)') ' endarray'
8312 write(ifhi,'(a)') 'closehisto'
8317 c-----------------------------------------------------------------------
8318 subroutine xhgcfl(u,d,s,iii)
8319 c-----------------------------------------------------------------------
8320 c creates unnormalized histogram for net flavor content of grand
8321 c canonically generated sample
8322 c xpar1: specifies width of plot, netflavor centered
8323 c-----------------------------------------------------------------------
8326 common/cfldat/data(nb),datb(nb),datc(nb),datu(nb)
8328 parameter(mxclu=10000)
8329 integer ku(mxclu),kd(mxclu),ks(mxclu)
8330 character cfl*3,cen*6,cvol*6
8340 elseif(iii.lt.0)then
8350 write(cen,'(f6.1)')tecm
8351 write(cvol,'(f6.1)')volu
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
8371 write(ifhi,'(a)') 'newpage zone 1 3 1'
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'
8386 write(ifhi,'(2e13.5)')data(j),datu(j)
8389 write(ifhi,'(a)') ' endarray'
8390 write(ifhi,'(a)') 'closehisto plot 0'
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'
8405 write(ifhi,'(2e13.5)')datb(j),datd(j)
8408 write(ifhi,'(a)') ' endarray'
8409 write(ifhi,'(a)') 'closehisto plot 0'
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'
8424 write(ifhi,'(2e13.5)')datc(j),dats(j)
8427 write(ifhi,'(a)') ' endarray'
8428 write(ifhi,'(a)') 'closehisto plot 0'
8436 c-----------------------------------------------------------------------
8438 c-----------------------------------------------------------------------
8439 c creates transverse mass spectrum for QM-droplet decay
8440 c according to grand canonical results
8442 c xpar1 specifies particle species by paige id, 0 for all
8443 c xpar2 and xpar3 specify xrange of plot
8444 c xpar4 specifies line type : dashed (0), dotted (1), full (2)
8447 c newpage, zone and plot commands not included !!!
8448 c-----------------------------------------------------------------------
8450 common/citer/iter,itermx
8451 parameter (nbin=200)
8452 real datx(nbin),daty(nbin)
8453 parameter (mspecs=56)
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
8466 if(ispecs(i).eq.idpa)id=i
8473 datx(j)=x0+(j-1)*dx*2.
8480 if(datx(j).ge.aspecs(i))then
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)
8488 daty(j)=daty(j)+dndmt
8494 if(datx(j).ge.aspecs(id))then
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)
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'
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'
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'
8531 write(ifhi,'(2e12.4)')datx(j),daty(j)
8534 write(ifhi,'(a)') ' endarray'
8535 write(ifhi,'(a)') 'closehisto'
8540 c-----------------------------------------------------------------------
8542 c-----------------------------------------------------------------------
8543 c creates multiplicity plot for decayed QM-droplet
8544 c according to grand canonical results
8546 c xpar1 specifies species by paige id, 0 for total multiplicity
8547 c xpar2 specifies xrange to be set automatically (0) or by hand (1)
8548 c xpar3 and xpar4 xrange if xpar2 ne 0
8549 c xpar5 xrange = average+-sigma*xpar5
8550 c xpar6 specifies line type : dashed (0), dotted (1), full (2)
8551 c xpar7 specifies statistics : same as iostat (0)
8555 c newpage, zone and plot commands not included !!!
8556 c-----------------------------------------------------------------------
8558 parameter (nbin=200)
8559 real datx(nbin),daty(nbin)
8560 parameter (mspecs=56)
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
8573 if(ist.eq.0.and.iostat.eq.1)ist=1
8579 if(nevent.le.10)ymin=ymin/10.
8581 if(ispecs(i).eq.idpa)id=i
8589 x1=anint(ptltot-iwid*rmstot)
8590 x2=anint(ptltot+iwid*rmstot)
8592 x1=anint(ptlngc(id)-iwid*rmsngc(id))
8593 x2=anint(ptlngc(id)+iwid*rmsngc(id))
8603 datx(j)=x0+(j-1)*dx*2.
8606 c total multiplicity
8607 c ------------------
8609 if(rmstot.ge.1.e-10)x=(datx(j)-ptltot)**2/rmstot**2/2.
8614 pn=exp(-x)/rmstot/sqrt(2.*pi)
8621 c one species (specified by id)
8622 c ------------------------------
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.
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)
8642 write(cyield,'(f8.3)')ptltot
8644 write(cyield,'(f8.3)')ptlngc(id)
8646 write(cinco,'(i1)')ioinco
8647 write(cen,'(f6.1)')tecm
8648 write(cvo,'(f6.1)')volu
8649 write(ifhi,'(a)') 'openhisto'
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'
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//'"'
8667 write(ifhi,'(a,a)') 'text 0.4 0.91 "V='//cvo//'"'
8668 write(ifhi,'(a,a)') 'text 0.15 0.91 "E='//cen//'"'
8670 write(ifhi,'(a)') 'array 2'
8673 write(ifhi,'(2e12.4)')datx(j),daty(j)
8676 write(ifhi,'(a)') ' endarray'
8677 write(ifhi,'(a)') 'closehisto'
8684 c-----------------------------------------------------------------------
8686 c-----------------------------------------------------------------------
8687 c creates multiplicity plot for decayed QM-droplet
8688 c according to grand canonical results POISSON DISTRIB.!!!!
8690 c xpar1 specifies species by paige id, 0 for total multiplicity
8691 c xpar2 specifies xrange to be set automatically (0) or by hand (1)
8692 c xpar3 and xpar4 xrange if xpar2 ne 0
8693 c xpar5 xrange = average+-sigma*xpar5
8694 c xpar6 specifies line type : dashed (0), dotted (1), full (2) dado (3)
8695 c xpar7 specifies statistics : same as iostat (0)
8699 c newpage, zone and plot commands not included !!!
8700 c-----------------------------------------------------------------------
8702 parameter (nbin=200)
8703 real datx(nbin),daty(nbin)
8704 parameter (mspecs=56)
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
8717 if(ist.eq.0.and.iostat.eq.1)ist=1
8722 if(nevent.le.10)ymin=ymin/10.
8724 if(ispecs(i).eq.idpa)id=i
8732 n1=nint(ptltot-iwid*rmstot)
8733 n2=nint(ptltot+iwid*rmstot)
8735 n1=nint(ptlngc(id)-iwid*rmsngc(id))
8736 n2=nint(ptlngc(id)+iwid*rmsngc(id))
8754 c total multiplicity
8755 c ------------------
8757 daty(j)=1./jf*ptltot**(j-1)*exp(-ptltot)
8761 c one species (specified by id)
8762 c ------------------------------
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))
8773 write(cyield,'(f8.3)')ptltot
8775 write(cyield,'(f8.3)')ptlngc(id)
8777 write(cinco,'(i1)')ioinco
8778 write(cen,'(f6.1)')tecm
8779 write(cvo,'(f6.1)')volu
8780 write(ifhi,'(a)') 'openhisto'
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'
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//'"'
8798 write(ifhi,'(a,a)') 'text 0.4 0.91 "V='//cvo//'"'
8799 write(ifhi,'(a,a)') 'text 0.15 0.91 "E='//cen//'"'
8801 write(ifhi,'(a)') 'array 2'
8804 write(ifhi,'(2e12.4)')datx(j),daty(j)
8807 write(ifhi,'(a)') ' endarray'
8808 write(ifhi,'(a)') 'closehisto'
8814 c-----------------------------------------------------------------------
8816 c-----------------------------------------------------------------------
8817 c creates transverse momentum spectrum for decayed QM-droplet
8818 c according to grand canonical results
8820 c xpar1 specifies particle species by paige id, 0 for all
8821 c xpar2 rapidity window
8822 c xpar3 and xpar4 specify xrange of plot
8823 c xpar5 specifies line type : dashed (0), dotted (1), full (2)
8826 c newpage, zone and plot commands not included !!!
8827 c-----------------------------------------------------------------------
8829 common/citer/iter,itermx
8830 parameter (nbin=200)
8831 real datx(nbin),daty(nbin)
8832 parameter (mspecs=56)
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
8843 write(crap,'(f5.1)')y
8847 if(ispecs(i).eq.idpa)id=i
8854 datx(j)=x0+(j-1)*dx*2.
8862 *x=(sqrt(aspecs(i)**2+datx(j)**2)*cosh(y)-chemgc(i))/tem
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
8877 *x=(sqrt(aspecs(id)**2+datx(j)**2)*cosh(y)-chemgc(id))/tem
8883 dndpt=dndpt*gspecs(id)*volu/hquer**3*cosh(y)
8884 **sqrt(aspecs(id)**2+datx(j)**2)/8./pi**3
8891 write(cit,'(i5)')itermx
8892 write(cen,'(f6.1)')tecm
8893 write(cvo,'(f6.1)')volu
8894 write(ifhi,'(a)') 'openhisto'
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'
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'
8913 write(ifhi,'(2e12.4)')datx(j),daty(j)
8916 write(ifhi,'(a)') ' endarray'
8917 write(ifhi,'(a)') 'closehisto'
8922 c-----------------------------------------------------------------------
8924 c-----------------------------------------------------------------------
8925 c creates rapidity distribution for decayed QM-droplet
8926 c according to grand canonical results
8928 c xpar1 specifies particle species by paige id, 0 for all
8929 c xpar2 and xpar3 specify xrange of plot
8930 c xpar4 specifies line type : dashed (0), dotted (1), full (2)
8933 c newpage, zone and plot commands not included !!!
8934 c-----------------------------------------------------------------------
8936 parameter (nbin=200)
8937 real datx(nbin),daty(nbin)
8938 parameter (mspecs=56)
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
8952 if(nevent.le.10)ymin=ymin/10.
8954 if(ispecs(i).eq.idpa)id=i
8962 datx(j)=x0+(j-1)*dx*2.
8965 if(ish.ge.9)write(ifch,*)'cosh y:',cosh(y)
8971 sum=aspecs(i)**2*tem+2.*aspecs(i)*tem**2/cosh(y)
8972 *+2.*tem**3/cosh(y)**2
8975 *x=(aspecs(i)*cosh(y)-chemgc(i))/tem
8983 pro=pro*gspecs(i)*volu/hquer**3/4./pi**2
8985 if(pro.ge.(1.e-30).and.sum.ge.(1.e-30))then
8986 che=alog(pro)+alog(sum)
8990 if(che.le.60.0.and.che.ge.(-60.0))dndy=pro*sum
8991 c if(che.le.60.0.and.che.ge.(-60.0))dndy=exp(che)
8993 daty(j)=daty(j)+dndy
9000 sum=aspecs(id)**2*tem+2.*aspecs(id)*tem**2/cosh(y)
9001 *+2.*tem**3/cosh(y)**2
9004 *x=(aspecs(id)*cosh(y)-chemgc(id))/tem
9012 pro=pro*gspecs(id)*volu/hquer**3/4./pi**2
9014 if(pro.ge.(1.e-30).and.sum.ge.(1.e-30))then
9015 che=alog(pro)+alog(sum)
9019 if(che.le.60..and.che.ge.-60.)dndy=pro*sum
9027 write(cen,'(f6.1)')tecm
9028 write(cvo,'(f6.1)')volu
9030 write(cng,'(f8.3)')ptltot
9032 write(cng,'(f8.3)')ptlngc(id)
9034 write(ifhi,'(a)') 'openhisto'
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'
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'
9054 write(ifhi,'(2e12.4)')datx(j),daty(j)
9057 write(ifhi,'(a)') ' endarray'
9058 write(ifhi,'(a)') 'closehisto'
9063 c-----------------------------------------------------------------------
9065 c-----------------------------------------------------------------------
9066 c produces histogram of energy spectrum (after metropolis run)
9067 c complete histogram: openhisto ... closehisto
9069 c-----------------------------------------------------------------------
9070 c xpar1: particle species (venus id-code)
9071 c xpar2: 1: actual spectrum 2: fit
9072 c xpar3: 1: de/d3p 2: ede/d3e
9073 c-----------------------------------------------------------------------
9075 parameter (mspecs=56)
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
9087 if(iocite.ne.1)stop'STOP: xhnben: iocite=1 required'
9094 if(idcode.eq.ispecs(j))then
9098 yield=1.*kspecs(j)/(itermx-iternc)
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
9110 y=(1-ll+ll*e)*hise(j,i)/(itermx-iternc)/d3p
9116 if(y-d.gt.0.)dats(i)=alog(y+d)-alog(y-d)
9121 c-c if(e.lt.0.2)dats(i)=1e10
9126 call utfit(datx,daty,nhise,dats,1,a,b,siga,sigb,chi2,q)
9128 if(tem.lt.0.050.or.tem.gt.10.)then
9135 daty(i)=exp(daty(i))
9137 write(chid,'(i5)')id
9138 write(cyield,'(f9.4)')yield
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)"'
9146 write(ifhi,'(a)') 'text 0 0 "yaxis '//ch//' dn/d3p (GeV-3)"'
9147 write(ifhi,'(a)') 'array 2'
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))
9152 write(ifhi,'(a)') ' endarray'
9153 write(ifhi,'(a)') 'closehisto'
9161 c-----------------------------------------------------------------------
9163 c-----------------------------------------------------------------------
9164 c produces histogram of multiplicity versus iterations (after metropolis run)
9165 c complete histogram: openhisto ... closehisto
9167 c-----------------------------------------------------------------------
9168 c xpar1: particle species (0=all, else venus id-code)
9169 c xpar2: 1:actual multiplicity 2:average multiplicity 3:grand canonical
9170 c-----------------------------------------------------------------------
9172 parameter (mspecs=56)
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
9183 if(iocite.ne.1)stop'STOP: xhnbit: iocite=1 required'
9192 yield=yield+1.*kspecs(j)/(itermx-iternc)
9194 datlx(1)=(iterl(1)+1)/2.
9196 datlx(li)=(iterl(li)+iterl(li-1)+1)/2.
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
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 = '
9215 write(ifhi,'(a)') 'text 0 0 "xaxis iterations"'
9216 write(ifhi,'(a)') 'text 0 0 "yaxis multiplicity"'
9217 write(ifhi,'(a)') 'array 2'
9219 write(ifhi,'(2e12.4)') datlx(i),datly(i)
9221 write(ifhi,'(a)') ' endarray'
9222 write(ifhi,'(a)') 'closehisto'
9227 if(idcode.eq.ispecs(j))then
9229 yield=1.*kspecs(j)/(itermx-iternc)
9230 write(chid,'(i5)')idcode
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)
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'
9248 write(ifhi,'(2e12.4)') datlx(i),datly(i)
9250 write(ifhi,'(a)') ' endarray'
9251 write(ifhi,'(a)') 'closehisto'
9261 c-----------------------------------------------------------------------
9263 c-----------------------------------------------------------------------
9264 c produces histogram of multiplicity distribution (after metropolis run)
9265 c complete histogram: openhisto ... closehisto
9267 c-----------------------------------------------------------------------
9268 c xpar1: particle species (0=all, else venus id-code)
9269 c xpar2: xrange automatic (0) or given via xpar3,4 (else)
9271 c-----------------------------------------------------------------------
9273 parameter (mspecs=56)
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
9285 if(iocite.ne.1)stop'STOP: xhnbmu: iocite=1 required'
9292 write(ctecm,'(f5.1)')tecm
9293 write(cvolu,'(f6.1)')volu
9299 yield=yield+1.*kspecs(j)/(itermx-iternc)
9301 write(cyield,'(f9.4)')yield
9306 if(i1.eq.0.and.nint(hismus(i)).gt.0)i1=i
9307 if(nint(hismus(i)).gt.0)i2=i
9311 if(itermx.le.1000)ij=0.5*(i1+i2)*0.40
9312 if(itermx.le.100)ij=0.5*(i1+i2)*0.80
9324 daty(l)=hismus(i)/mus
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 = '
9338 write(ifhi,'(a)') 'text 0 0 "xaxis multiplicity n "'
9339 write(ifhi,'(a)') 'text 0 0 "yaxis dN/dn"'
9340 write(ifhi,'(a)') 'text 0.30 0.25 "N?MC!='//cyield//'"'
9341 write(ifhi,'(a)') 'array 2'
9343 write(ifhi,'(2e12.4)') datx(i),daty(i)
9345 write(ifhi,'(a)') ' endarray'
9346 write(ifhi,'(a)') 'closehisto'
9351 if(idcode.eq.ispecs(j))then
9353 yield=1.*kspecs(j)/(itermx-iternc)
9354 write(cyield,'(f9.4)')yield
9355 write(chid,'(i5)')idcode
9360 if(i1.eq.0.and.nint(hismu(j,i)).gt.0)i1=i
9361 if(nint(hismu(j,i)).gt.0)i2=i
9365 if(itermx.le.1000)ij=0.5*(i1+i2)*0.60
9366 if(itermx.le.100)ij=0.5*(i1+i2)*1.20
9378 daty(l)=hismu(j,i)/mus
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"'
9393 write(ifhi,'(a)') 'text 0.30 0.25 "N?MC!='//cyield//'"'
9394 write(ifhi,'(a)') 'array 2'
9396 write(ifhi,'(2e12.4)') datx(i),daty(i)
9398 write(ifhi,'(a)') ' endarray'
9399 write(ifhi,'(a)') 'closehisto'
9409 c-----------------------------------------------------------------------
9411 c-----------------------------------------------------------------------
9412 c produces histogram of multiplicity distribution from droplet decay
9413 c or average multiplicity versus iterations
9414 c for massless hadrons
9415 c complete histogram: openhisto ... closehisto
9416 c-----------------------------------------------------------------------
9417 c xpar1: particle species (0=all, else venus id-code)
9418 c xpar2: lower limit multiplicity
9419 c xpar3: upper limit multiplicity
9420 c xpar4: lower limit total multiplicity (also necc for xpar1.ne.0)
9421 c xpar5: upper limit " " (also necc for xpar1.ne.0)
9422 c xpar6: sets htyp: 1->lfu, 2->ldo, 3->lda, 4->ldd
9423 c xpar7: 0: multiplicity distribution
9424 c >0: av multiplicity vs iterations (itermx=xpar7)
9425 c-----------------------------------------------------------------------
9428 common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
9429 common/ctst/psulog,wtulog
9430 parameter (mspecs=56)
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)
9437 double precision spelog,cc,bb,dsu
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'
9465 if(ioflac.eq.0)call hnbspg(keu,ked,kes,kec,keb,ket,0,np,spelog)
9466 if(ioflac.ne.0)call hnbspf(keu,ked,kes,kec,keb,ket,0,np,spelog)
9467 wtulog=wtulog+spelog
9472 pzlog(1+i-ii1)=wtzlog
9473 datyu(1+i-ii1)=wtulog
9474 wtrlog=max(wtrlog,wtulog)
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))
9487 yield=yield+i*datyu(l)
9494 datyu(l)=datyu(l)/su
9497 write(cyieur,'(f9.4)')yield
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'
9502 write(ifhi,'(a)') 'text 0.30 0.15 "N?ana!='//cyieur//'"'
9503 write(ifhi,'(a)') 'array 2'
9505 write(ifhi,'(2e12.4)') datx(i),datyu(i)
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'
9515 write(ifhi,'(2e12.4)') (i-1.)*itmax/(itm-1.),yield
9517 write(ifhi,'(a)') ' endarray'
9518 write(ifhi,'(a)') 'closehisto'
9521 if(idcode.eq.0)return
9524 if(idcode.eq.ispecs(j))then
9538 do ntot=max(i+1,ii1),min(i2*nspecs,ii2)
9542 cc=cc*(1.+ntot-kc)/kc*gspecs(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)
9553 bb=bb+cc*dexp(1.d0*pzlog(1+ntot-ii1))/dsu
9556 yield=yield+i*datyu(l)
9561 write(cyieur,'(f9.4)')yield
9564 write(ifhi,'(a,2e11.3)')'openhisto xrange',x1,x2
9565 write(ifhi,'(a)') 'htyp '//htyp//' xmod lin ymod log'
9566 write(ifhi,'(a)') 'text 0.30 0.15 "N?ana!='//cyieur//'"'
9567 write(ifhi,'(a)') 'array 2'
9569 write(ifhi,'(2e12.4)') datx(i),datyu(i)
9571 write(ifhi,'(a)') ' endarray'
9572 write(ifhi,'(a)') 'closehisto'
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'
9579 write(ifhi,'(2e12.4)') (i-1.)*itmax/(itm-1.),yield
9581 write(ifhi,'(a)') ' endarray'
9582 write(ifhi,'(a)') 'closehisto'
9592 c-----------------------------------------------------------------------
9593 subroutine xhnbte(iii)
9594 c-----------------------------------------------------------------------
9595 c fills histograms (iii>=0) or writes histogram to histo-file (iii<0)
9596 c regarding exponential autocorrelation time and acceptance rate
9599 c requires complete run with application hadron (iappl=1)
9600 c or application metropolis (iappl=4)
9601 c ioceau=1 necessary
9604 c for iii=0 (only valid for iappl=4):
9605 c data(nrevt): nrevt (event number) /cdat/
9606 c datb(nrevt): taui (calculated corr time) /cdat/
9607 c datc(nrevt): accrat (acceptance rate) /cdat/
9608 c datd(nrevt): taue (parametrized corr time) /cdat/
9609 c for iii>0 (only valid for iappl=1):
9610 c nrclu=nrclu+1 /cnrclu/
9611 c data(nrclu): nrclu (droplet number) /cdat/
9612 c datb(nrclu): taui-taue (calc - param corr time) /cdat/
9613 c datc(nrclu): accrat (acceptance rate) /cdat/
9614 c datd(nrclu): avnp (average particle number) /cdat/
9616 c writes complete histogram (openhisto ... closehisto) to histofile
9617 c for iappl=4: for iappl=1:
9618 c xpar1=1: (data,datb,datd) xpar1=1: (data,datb)
9619 c xpar1=2: (data,datc) xpar1=2: (data,datd)
9620 c xpar1=3: (data,datc)
9621 c-----------------------------------------------------------------------
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
9628 parameter (mspecs=56)
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)
9634 character cobs*5,cnc*5,cdz*5,czer*5
9635 *,cmom*5,cnp*7,cen*7,cvol*7,clatt*5,cit*5
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'
9642 if(iii.lt.0)jjj=nint(xpar1)
9651 if(iii.gt.0)nrclu=nrclu+1
9652 if(nrclu.gt.500)return
9657 avnp=xnptot/(itermx-iternc)
9658 if(ish.ge.9)write(ifch,*)'event:',nrevt,' droplet:',nrclu
9661 c calculate corfct_0
9662 c ------------------
9664 do i=iternc+1,itermx
9666 corzer=corzer+dev(i)**2
9668 corzer=corzer/(itermx-iternc)
9669 if(ish.ge.9)write(ifch,*)'c_0:',corzer
9671 c calculate corfct_1
9672 c ------------------
9674 do i=iternc+1,itermx-1
9675 corone=corone+dev(i)*dev(i+1)
9677 corone=corone/(itermx-iternc-1)
9679 c calculate initial autocorrelation time
9680 c -----------------------------------------
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
9688 if(ish.ge.9)write(ifch,*)'tau_init:',taui
9690 c calculate parametrized autocorrelation time (if necessary)
9691 c ----------------------------------------------------------
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)
9701 c calculate acceptance rate
9702 c -------------------------
9707 c write to data/b/c/d
9708 c -------------------
9720 datb(nrclu)=taui-taue
9725 c -----------------------------------
9726 elseif(iii.lt.0.and.iappl.eq.4)then
9727 c -----------------------------------
9729 write(cmom,'(i3)')iomom
9730 write(cen,'(f7.3)')tecm
9732 write(cnp,'(f7.3)')ptltot
9735 if(ioobsv.eq.ispecs(i))id=i
9737 write(cnp,'(f7.3)')ptlngc(id)
9739 write(cvol,'(f7.3)')volu
9740 write(clatt,'(i3)')nlattc
9741 write(cit,'(i5)')itermx
9743 write(cobs,'(a)')'all'
9745 write(cobs,'(i5)')ioobsv
9747 write(cnc,'(i5)')iternc
9748 if(iozevt.eq.0)write(czer,'(i5)')iozero
9749 if(iozevt.gt.0)write(cdz,'(i5)')iozinc
9756 write(ifhi,'(a)') 'openhisto'
9757 write(ifhi,'(a)') 'htyp lin xmod lin ymod lin'
9759 write(ifhi,'(a)') 'text 0 0 "xaxis iozero"'
9761 write(ifhi,'(a)') 'text 0 0 "xaxis event"'
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'
9771 write(ifhi,'(2e12.4)')data(j),datb(j)
9773 write(ifhi,'(a)') ' endarray'
9774 write(ifhi,'(a)') 'closehisto plot 0-'
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'
9781 write(ifhi,'(2e12.4)')data(j),datd(j)
9783 write(ifhi,'(a)') ' endarray'
9784 write(ifhi,'(a)') 'closehisto'
9786 elseif(jjj.eq.2)then
9788 write(ifhi,'(a)') 'openhisto'
9789 write(ifhi,'(a)') 'htyp lin xmod lin ymod lin'
9791 write(ifhi,'(a)') 'text 0 0 "xaxis iozero"'
9793 write(ifhi,'(a)') 'text 0 0 "xaxis event"'
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//'"'
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//'"'
9803 *write(ifhi,'(a)') 'text 0.35 0.95 "dzero= '//cdz//'"'
9805 *write(ifhi,'(a)') 'text 0.25 0.05 "zeros rejected !"'
9807 write(ifhi,'(a)') 'text 0.05 0.05 "hot start"'
9809 write(ifhi,'(a)') 'text 0.05 0.05 "cold start"'
9811 write(ifhi,'(a,2e11.3)')'xrange',x1,x2
9812 write(ifhi,'(a)') 'array 2'
9814 write(ifhi,'(2e12.4)')data(j),datc(j)
9816 write(ifhi,'(a)') ' endarray'
9817 write(ifhi,'(a)') 'closehisto'
9821 c -----------------------------------
9822 elseif(iii.lt.0.and.iappl.eq.1)then
9823 c -----------------------------------
9826 write(cobs,'(a)')'all'
9828 write(cobs,'(i5)')ioobsv
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'
9846 write(ifhi,'(2e12.4)')data(j),datb(j)
9848 write(ifhi,'(a)') ' endarray'
9849 write(ifhi,'(a)') 'closehisto'
9851 elseif(jjj.eq.2)then
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'
9861 write(ifhi,'(2e12.4)')data(j),datd(j)
9863 write(ifhi,'(a)') ' endarray'
9864 write(ifhi,'(a)') 'closehisto'
9866 elseif(jjj.eq.3)then
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'
9875 write(ifhi,'(2e12.4)')data(j),datc(j)
9877 write(ifhi,'(a)') ' endarray'
9878 write(ifhi,'(a)') 'closehisto'
9890 c-------------------------------------------------------------------------
9891 subroutine xhnbti(iii)
9892 c-------------------------------------------------------------------------
9893 c fills histograms (iii=0) or writes histogram to histo-file (iii<0)
9894 c regarding integrated autocorrelation time and corresponding multiplicity
9898 c requires complete run with application metropolis (iappl=4)
9899 c iociau=1 necessary
9900 c iompar (parameter for windowing algorithm by a.d.sokal) must
9901 c be set to 3 < c_M < 11
9904 c for iii=0 (only valid for iappl=4):
9905 c data(nrevt): nrevt (event number) /cdat/
9906 c datb(nrevt): tau (calculated int corr time) /cdat/
9907 c datc(nrevt): stau (variance tau) /cdat/
9908 c datd(nrevt): avnp (multiplicity) /cdat/
9909 c date(nrevt): sobs (variance multiplicity) /cdat/
9910 c datf(nrevt): (gc multiplicity) /cdat/
9911 c for iii=0 and iosngl>0:
9912 c writes complete set of histograms (newpage zone 1 3 1
9913 c openhisto ... closehisto plot0 ... openhisto ... closehisto plot 0)
9914 c concerning acceptance rate, rejection rate, correlation function
9915 c for specific event, specified by value of iosngl (=nrevt+1)
9917 c writes complete histogram (openhisto ... closehisto) to histofile
9918 c xpar1=1: (data,datb,datc)
9919 c xpar1=2: (data,datd,date,datf)
9920 c------------------------------------------------------------------------
9922 parameter(maxit=50000)
9923 common/count/nacc,nrej,naccit(maxit),nptot,npit(maxit)
9924 common/citer/iter,itermx
9926 common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
9927 common /clatt/nlattc,npmax
9928 common/cgctot/rmstot,ptltot
9929 parameter (mspecs=56)
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)
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
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'
9955 avnp=xnptot/(itermx-iternc)
9956 if(ish.ge.9)write(ifch,*)'event:',nrevt,' avnp:',avnp
9958 c normalization of corfct_i
9959 c -------------------------
9961 do i=iternc+1,itermx
9963 if(ish.ge.9)write(ifch,*)'i:',i,' dev_i:',dev(i)
9964 corzer=corzer+dev(i)**2
9966 corzer=corzer/(itermx-iternc)
9967 if(ish.ge.9)write(ifch,*)'c_0:',corzer
9969 c calculate corfct_i
9970 c ------------------
9974 do i=iternc+1,itermx-it
9975 corfct(it)=corfct(it)+dev(i)*dev(i+it)
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)
9982 c calculate initial autocorrelation time
9983 c -----------------------------------------
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
9991 if(ish.ge.9)write(ifch,*)'tau_init:',taui
9993 c calculate integrated autocorrelation time
9994 c -----------------------------------------
10000 if(ish.ge.9)write(ifch,*)'initial tau:',tau,' c_M:',mpar
10002 if(corzer.gt.1.e-30)then
10004 5 mcut=mpar*abs(taux)
10008 tau=tau+corfct(it)/corzer
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
10015 if(k.lt.20.and.dt.gt.0.2)then
10020 mcut=mpar*abs(taux)
10021 if(ish.ge.9)write(ifch,*)'tau_mean:',taux,' M:',mcut
10024 tau=tau+corfct(it)/corzer
10029 vtau=(2.*mcut+1.)*2./(itermx-iternc)*tau**2
10031 if(vtau.ge.0.0)stau=sqrt(vtau)
10033 *write(ifch,*)'tau_int:',tau,' var:',vtau,' sig:',stau
10035 c calculate variance of observable
10036 c --------------------------------
10037 vobs=2.*tau*corzer/(itermx-iternc)
10039 if(vobs.ge.0.0)sobs=sqrt(vobs)
10043 if(ioobsv.eq.0)then
10047 if(ioobsv.eq.ispecs(j))id=j
10049 datf(nrevt)=ptlngc(id)
10055 if(iozevt.gt.0)then
10061 c -------------------------
10062 if(iosngl.eq.nrevt+1)then
10063 c -------------------------
10066 if(nb.gt.nbin)nb=nbin
10070 datz(1)=1-naccit(1)
10071 if(iterpl.ge.2)then
10073 daty(1)=daty(1)+naccit(1+j)
10074 datz(1)=datz(1)+1-naccit(1+j)
10077 datr(1)=daty(1)/iterpl
10078 dats(1)=datz(1)/iterpl
10080 datx(i)=datx(i-1)+iterpl
10084 daty(i)=daty(i)+naccit((i-1)*iterpl+j)
10085 datz(i)=datz(i)+1-naccit((i-1)*iterpl+j)
10087 datr(i)=daty(i)/i/iterpl
10088 dats(i)=datz(i)/i/iterpl
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
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'
10115 write(ifhi,'(2e12.4)')datx(j),datr(j)
10117 write(ifhi,'(a)') ' endarray'
10118 write(ifhi,'(a)') 'closehisto plot 0-'
10120 write(ifhi,'(a)') 'openhisto'
10121 write(ifhi,'(a,2e11.3)')'xrange',x1,x2
10122 write(ifhi,'(a)') 'array 2'
10124 write(ifhi,'(2e12.4)')datx(j),dats(j)
10126 write(ifhi,'(a)') ' endarray'
10127 write(ifhi,'(a)') 'closehisto plot 0'
10133 if(corzer.gt.1.e-30)dath(i)=corfct(i)/corzer
10135 write(ccuev,'(i5)')nrevt+1
10136 write(cmpar,'(i3)')mpar
10137 write(ctau,'(i7)')tau
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'
10152 write(ifhi,'(2e12.4)')datg(j),dath(j)
10154 write(ifhi,'(a)') ' endarray'
10155 write(ifhi,'(a)') 'closehisto plot 0'
10161 c --------------------
10162 elseif(iii.lt.0)then
10163 c --------------------
10165 write(cmom,'(i3)')iomom
10166 if(ioobsv.eq.0)then
10167 write(cnp,'(f7.3)')ptltot
10170 if(ioobsv.eq.ispecs(j))id=j
10172 write(cnp,'(f7.3)')ptlngc(id)
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
10180 *write(cdz,'(i5)')iozinc
10181 write(cmpar,'(i3)')mpar
10182 if(ioobsv.eq.0)then
10183 write(cobs,'(a)')'all'
10185 write(cobs,'(i5)')ioobsv
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"'
10198 write(ifhi,'(a)') 'text 0 0 "xaxis event"'
10200 write(ifhi,'(a)') 'text 0 0 "yaxis [t]?int!"'
10201 write(ifhi,'(a)')'text 0.05 0.95 "window parameter '//cmpar//'"'
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'
10207 write(ifhi,'(3e12.4)')data(j),datb(j),datc(j)
10209 write(ifhi,'(a)') ' endarray'
10210 write(ifhi,'(a)') 'closehisto'
10212 elseif(jjj.eq.2)then
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"'
10219 write(ifhi,'(a)') 'text 0 0 "xaxis event"'
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'
10230 write(ifhi,'(3e12.4)')data(j),datd(j),date(j)
10232 write(ifhi,'(a)') ' endarray'
10233 write(ifhi,'(a)') 'closehisto plot 0-'
10236 write(ifhi,'(a)') 'openhisto'
10237 write(ifhi,'(a)') 'htyp lda xmod lin ymod lin'
10238 write(ifhi,'(a)') 'array 2'
10240 write(ifhi,'(2e12.4)')data(j),datf(j)
10242 write(ifhi,'(a)') ' endarray'
10243 write(ifhi,'(a)') 'closehisto'