File indexing completed on 2024-04-06 12:14:03
0001
0002 subroutine hnbaaa(ip,iret) !former hnbaaa156 from epos-yyy
0003
0004
0005
0006 include 'epos.inc'
0007 common/cxyzt/xptl(mxptl),yptl(mxptl),zptl(mxptl),tptl(mxptl)
0008 *,optl(mxptl),uptl(mxptl),sptl(mxptl),rptl(mxptl,3)
0009 parameter(maxp=500)
0010 common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
0011 common/citer/iter,itermx
0012 double precision tpro,zpro,ttar,ztar,ttaus,detap,detat
0013 common /cttaus/ tpro,zpro,ttar,ztar,ttaus,detap,detat
0014 integer jc(nflav,2)
0015 double precision p(5),c(5)
0016 parameter(maxit=50000)
0017 common/count/nacc,nrej,naccit(maxit),nptot,npit(maxit)
0018 dimension be(4),pe(5),pa(5)
0019 common/yradx/yrad(maxp),phirad(maxp)
0020 common/xxxspecsy/ndrop(-4:4,-4:4,-4:4)
0021 common/cdelzet/delzet,delsgr /cvocell/vocell
0022 call utpri('hnbaaa',ish,ishini,4)
0023
0024
0025 ntry=0
0026 10 continue
0027 ntry=ntry+1
0028
0029 if(ish.ge.3)then
0030 write(ifch,140)sngl(ttaus)
0031 140 format(/' ----------------------------------'/
0032 *' droplet decay at tau =',f6.2/
0033 *' ----------------------------------')
0034 write(ifch,*)'droplet:'
0035 call alist('&',ip,ip)
0036 endif
0037
0038 iret=0
0039 do j=1,5
0040 c(j)=pptl(j,ip)
0041 enddo
0042
0043 call idquac(ip,nqi,nsi,nai,jc)
0044 keu=jc(1,1)-jc(1,2)
0045 ked=jc(2,1)-jc(2,2)
0046 kes=jc(3,1)-jc(3,2)
0047 kec=jc(4,1)-jc(4,2)
0048 keb=jc(5,1)-jc(5,2)
0049 ket=jc(6,1)-jc(6,2)
0050
0051
0052 !~~~~~redefine energy in case of radial flow
0053 amin=utamnu(keu,ked,kes,kec,keb,ket,4) !utamnu(...,4) and not utamnu(...,5)
0054 aumin=amuseg+yrmaxi !for rad and long flow
0055 ipo=ip !could be too light after flow
0056 if(ityptl(ip).eq.60)ipo=iorptl(ip)
0057 tecmor=pptl(5,ipo)
0058 if(iappl.eq.4.or.iorsdf.ne.3
0059 &.or.ityptl(ip).eq.40.or.ityptl(ip).eq.50)then !not for droplets from remnants
0060 yrmax=0
0061 else
0062 yrmax=yrmaxi
0063 !aumin=amin
0064 !if(yrmax.gt.0.2)print*,'===',tecmor,aamin,yrmax
0065 endif
0066 fradflo=1.
0067 if(yrmax.gt.1e-2)fradflo=fradflii
0068 tecm=pptl(5,ip)
0069 if(tecm.lt.amin)then
0070 iret=1
0071 if(ish.ge.4)write(ifch,*)'Decay skipped (M too low) !'
0072 & ,tecm,amin
0073 goto 1000
0074 endif
0075 if(iappl.eq.4.or.iorsdf.ne.3
0076 &.or.ityptl(ip).eq.40.or.ityptl(ip).eq.50)then !not for droplets from remnants
0077 yco=0
0078 else
0079 if(ylongmx.lt.0.)then
0080 yco=delzet !* 1.75
0081 else
0082 yco=ylongmx
0083 endif
0084 endif
0085 corrco=1.
0086 if(yco.gt.0.)corrco=sinh(yco)/yco
0087
0088
0089 tecmxx=tecm
0090 if(iLHC.eq.1)then
0091 corr=fradflo/corrco
0092 if(tecm*corr.lt.amin.and.tecm.gt.0.)then
0093 fradflo=min(1.,1.1*amin/tecm*corrco) !if flow too large, do something anyway (saturation of flow)
0094 corr=fradflo/corrco
0095 endif
0096 else
0097 if(tecm*fradflo.lt.amin.and.tecm.gt.0.)fradflo=1.1*amin/tecm !if flow too large, do something anyway (saturation of flow)
0098 corr=fradflo
0099 endif
0100 if(yrmax.gt.1e-2.and.tecmor.gt.aumin
0101 & .and.tecm*corr.ge.amin) then
0102 ! redefine energy to account for collective flow
0103 ! \int_0^yrmax f(y) d2y = E_new (effective mass)
0104 ! \int_0^yrmax cosh(y) f(y) d2y = E_old
0105 tecm=tecm*fradflo
0106 if(tecm.lt.amin)stop'aaahnb: small mass. should not happen. '
0107 else
0108 yrmax=0.
0109 endif
0110 !~~~~~redefine energy in case of long coll flow
0111 ! MANDATORY if RAD FLOW USED BECAUSE IT SMOOTH THE ETA DISTRIBUTION
0112 ! because of the grid structure for the cluster, fluctuations in eta
0113 ! appears if there is no smearing with long flow !
0114 tecmx=tecm
0115
0116 if(yco.gt.0) then
0117 if(iLHC.eq.1.and.tecm.ge.aumin)then
0118 tecm=tecm/corrco
0119 do while(tecm.lt.amin)
0120 yco=yco*0.5
0121 corrco=sinh(yco)/yco
0122 tecm=tecmx/corrco
0123 enddo
0124 else
0125 tecm=tecm/corrco
0126 if(tecm.lt.aumin)then !security to avoid minimum mass
0127 tecm=tecmx
0128 yco=0.
0129 endif
0130 endif
0131 else
0132 yco=0.
0133 endif
0134 if(ish.ge.4)write(ifch,*)'===== cluster energy: '
0135 & ,pptl(5,ip),tecmx,tecm,amin,aumin
0136 & ,delzet,yrmax,yco,ityptl(ip)
0137
0138 !~~~~~~~~~define volume~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
0139
0140 volu=tecm/epscri(1)
0141
0142 !~~~~~~~~~decay~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
0143 call hnbini(iret)
0144 !if(iret.ne.0)write(ifch,*)'***** unsucessfull hnbini *****'
0145 if(iret.ne.0)goto 1000
0146 if(ioinct.ge.1)goto 1
0147
0148 do iter=1,itermx
0149 naccit(iter)=0
0150 call hnbmet
0151 enddo
0152
0153 1 continue
0154
0155 if(ioceau.eq.1.and.iappl.eq.1)call xhnbte(ip)
0156
0157 !~~~~~~~~~~long coll flow -> particles~~~~~~~~~~~~~~~~
0158 tecmxxx=tecm
0159 if(yco.gt.0.) then
0160 errlim=0.0001
0161 tecm=tecmx
0162 niter=0
0163 611 energ=0.
0164 niter=niter+1
0165 do i=1,np
0166 yrad(i)=(2*rangen()-1)*yco
0167 be(3)=sinh(yrad(i))
0168 be(4)=cosh(yrad(i))
0169 energ=energ+be(4)*pcm(4,i)-be(3)*pcm(3,i)
0170 enddo
0171 if(abs(energ-tecm).gt.0.1.and.niter.lt.1000)then
0172 goto 611
0173 elseif(niter.ge.1000)then
0174 if(ish.ge.1)write(ifch,*)'Long Flow failed:'
0175 & ,energ,tecm
0176 yco=0
0177 tecm=tecmxxx
0178 goto 400
0179 endif
0180 !print*,'===== energy after flow boosts',energ,' soll: ',tecm
0181 do j=1,4
0182 pe(j)=0.
0183 enddo
0184 do i=1,np
0185 be(1)= 0
0186 be(2)= 0
0187 be(3)= sinh(yrad(i))
0188 be(4)= cosh(yrad(i))
0189 call utlob3(1,be(1),be(2),be(3),be(4),1e0
0190 * , pcm(1,i), pcm(2,i), pcm(3,i), pcm(4,i))
0191 do j=1,4
0192 pe(j)=pe(j)+pcm(j,i)
0193 enddo
0194 enddo
0195 pe(5)=sqrt(pe(4)**2-pe(3)**2-pe(2)**2-pe(1)**2)
0196 !write(6,'(a,5e11.3)')'flow boosts',pe
0197 do j=1,4
0198 pa(j)=0.
0199 enddo
0200 do i=1,np
0201 call utlob3(1,pe(1),pe(2),pe(3),pe(4),pe(5)
0202 * , pcm(1,i), pcm(2,i), pcm(3,i), pcm(4,i))
0203 do j=1,4
0204 pa(j)=pa(j)+pcm(j,i)
0205 enddo
0206 enddo
0207 pa(5)=sqrt(pa(4)**2-pa(3)**2-pa(2)**2-pa(1)**2)
0208 !write(6,'(a,5e11.3)')' cms boost ',pa
0209 esoll=tecm
0210 scal=1.
0211 do ipass=1,200
0212 sum=0.
0213 do j=1,np
0214 do k=1,3
0215 pcm(k,j)=scal*pcm(k,j)
0216 enddo
0217 pcm(4,j)=sqrt(pcm(1,j)**2+pcm(2,j)**2+pcm(3,j)**2
0218 * +amass(j)**2)
0219 sum=sum+pcm(4,j)
0220 enddo
0221 scal=esoll/sum
0222 !write(6,*)'ipass,scal,e,esoll:'
0223 ! $ ,ipass,scal,sum,esoll
0224 if(abs(scal-1.).le.errlim) goto301
0225 enddo
0226 301 continue
0227 do j=1,4
0228 pa(j)=0.
0229 enddo
0230 do i=1,np
0231 do j=1,4
0232 pa(j)=pa(j)+pcm(j,i)
0233 enddo
0234 enddo
0235 pa(5)=sqrt(pa(4)**2-pa(3)**2-pa(2)**2-pa(1)**2)
0236 !write(6,'(a,5e11.3)')' rescaling ',pa
0237 endif
0238
0239 400 continue
0240 !~~~~~~~~~~radial flow -> particles~~~~~~~~~~~~~~~~~~
0241 if(yrmax.gt.0.) then
0242 fecc=0
0243 aa=1
0244 bb=0
0245 cc=0
0246 dd=1
0247 if(ityptl(ip).eq.60)then
0248 ipo=iorptl(ip)
0249 xx=uptl(ipo) ! <x**2>
0250 yy=optl(ipo) ! <y**2>
0251 xy=desptl(ipo) ! <x*y>
0252 dta=0.5*abs(xx-yy)
0253 ev1=(xx+yy)/2+sqrt(dta**2+xy**2)
0254 ev2=(xx+yy)/2-sqrt(dta**2+xy**2)
0255 if(xy.lt.0..and.dta.ne.0.)then
0256 theta=0.5*atan(-xy/dta)
0257 elseif(xy.gt.0..and.dta.ne.0.)then
0258 theta=-0.5*atan(xy/dta)
0259 else
0260 theta=0
0261 endif
0262
0263
0264
0265
0266
0267
0268
0269
0270
0271
0272
0273
0274
0275
0276 !eccx=(yy-xx)/(yy+xx)
0277 yy=ev1
0278 xx=ev2
0279 ecc=(yy-xx)/(yy+xx)
0280
0281 if(iLHC.eq.1)then
0282 fecc=min(facecc,ecc) !be careful : fecc change <pt> since it is the elliptical deformation of the sub cluster(give strength of v2)
0283 else
0284 fecc=facecc*ecc
0285 fecc=min(0.3,fecc) !be careful : fecc change <pt> since it is the
0286 endif
0287 phiclu=mod(phievt+theta,2.*pi) !do not change otherwise v2 is gone
0288 if(phiclu.lt.-pi)phiclu=phiclu+2*pi
0289 if(phiclu.gt.pi)phiclu=phiclu-2*pi
0290 aa=cos(phiclu)
0291 bb=sin(phiclu)
0292 cc=-sin(phiclu)
0293 dd=cos(phiclu)
0294 endif
0295 errlim=0.0001
0296 tecm=tecmxx
0297 niter=0
0298 610 energ=0.
0299 niter=niter+1
0300 do i=1,np
0301 yrad(i)=sqrt(rangen())
0302 phirad(i)=2.*pi*rangen()
0303 pt2=0.
0304 if(iLHC.eq.1)pt2=(pcm(1,i)**2+pcm(2,i)**2) !+amass(i)**2)
0305 bex=dsinh(dble(yrad(i)*yrmax))*cos(phirad(i))
0306 * *(1+fecc/(1.+pt2))
0307 bey=dsinh(dble(yrad(i)*yrmax))*sin(phirad(i))
0308 * *(1-fecc/(1.+pt2))
0309 be(1)=aa*bex+cc*bey
0310 be(2)=bb*bex+dd*bey
0311 be(3)=-0d0
0312 be(4)=sqrt(1+be(1)**2+be(2)**2)
0313 bp=0d0
0314 do k=1,3
0315 bp=bp+pcm(k,i)*be(k)
0316 enddo
0317 en=be(4)*pcm(4,i)+bp
0318 energ=energ+en
0319
0320
0321
0322
0323
0324
0325
0326
0327 enddo
0328 if(abs(energ-tecm).gt.0.1.and.niter.lt.1000)then
0329 goto 610
0330 elseif(niter.ge.1000)then
0331 if(ish.ge.1)write(ifch,*)'Radial Flow failed:'
0332 & ,yrmax,energ,tecm,np
0333 iret=1
0334 if(ish.ge.1)write(ifch,*)'Decay skipped !'
0335 goto 1000
0336
0337 endif
0338 energ=0.
0339 do i=1,np
0340 pt2=0.
0341 if(iLHC.eq.1)pt2=(pcm(1,i)**2+pcm(2,i)**2)!+amass(i)**2)
0342 bex=dsinh(dble(yrad(i)*yrmax))*cos(phirad(i))
0343 * *(1+fecc/(1.+pt2))
0344 bey=dsinh(dble(yrad(i)*yrmax))*sin(phirad(i))
0345 * *(1-fecc/(1.+pt2))
0346 be(1)=aa*bex+cc*bey
0347 be(2)=bb*bex+dd*bey
0348 be(3)=0d0
0349 be(4)=sqrt(1+be(1)**2+be(2)**2)
0350 call utlob3(1,be(1),be(2),be(3),be(4),1e0
0351 * , pcm(1,i), pcm(2,i), pcm(3,i), pcm(4,i))
0352
0353
0354
0355
0356
0357
0358 energ=energ+pcm(4,i)
0359 enddo
0360 esoll=tecm
0361 scal=1.
0362 do ipass=1,200
0363 sum=0.
0364 do j=1,np
0365 do k=1,3
0366 pcm(k,j)=scal*pcm(k,j)
0367 enddo
0368 pcm(4,j)=sqrt(pcm(1,j)**2+pcm(2,j)**2+pcm(3,j)**2
0369 * +amass(j)**2)
0370 sum=sum+pcm(4,j)
0371 enddo
0372 scal=esoll/sum
0373
0374
0375 if(abs(scal-1.).le.errlim) goto300
0376 enddo
0377 300 continue
0378 else
0379 do n=1,np
0380 yrad(n)=0.
0381 phirad(n)=0.
0382 enddo
0383 endif
0384 !~~~~~~~~~~~~~~~
0385
0386 nptlb=nptl
0387 do n=1,np
0388 nptl=nptl+1
0389 if(nptl.gt.mxptl)call utstop('hnbptl: mxptl too small&')
0390 idptl(nptl)=ident(n)
0391 do j=1,4
0392 p(j)=pcm(j,n)
0393 enddo
0394 p(5)=amass(n)
0395 call utlob2(-1,c(1),c(2),c(3),c(4),c(5),p(1),p(2),p(3),p(4),10)
0396 do j=1,5
0397 pptl(j,nptl)=p(j)
0398 enddo
0399 if(tecmor.gt.aumin)then
0400 ityptl(nptl)=60
0401 elseif(ityptl(ip).eq.40.or.ityptl(ip).eq.50)then
0402 ityptl(nptl)=ityptl(ip)+1
0403 else
0404 ityptl(nptl)=19
0405 endif
0406 ipo=iorptl(ip)
0407 iorptl(nptl)=ip
0408 jorptl(nptl)=ipo
0409
0410 if(iLHC.eq.1.and.p(4).ge.0.5*engy)then
0411 if(ish.ge.4)call alist('&',nptlb+1,nptl)
0412 nptl=nptlb
0413 iret=1
0414 if(ish.ge.4)write(ifch,*)'Decay skipped (p4 too high) !', ntry
0415 if(ntry.lt.10)goto 10
0416 goto 1000
0417 endif
0418 if(ityptl(ip).eq.60)then
0419 if(ityptl(nptl).eq.60)then
0420 xx=uptl(ipo) ! <x**2>
0421 yy=optl(ipo) ! <y**2>
0422 rini=sqrt(5./3.*(xx+yy)) !<r**2>=3/5*R**2 for sphere of radius R
0423 r=1.15*rini*yrad(n) !yrad=y/ymax
0424 tau=2.25/sqrt(yrad(n)**2+0.04)-0.75
0425 z=xorptl(3,ipo)
0426 t=xorptl(4,ipo)
0427 !zeta=0.5*log((t+z)/(t-z))-0.5*delzet+2*0.5*delzet*rangen()
0428 zeta=0.5*log((p(4)+p(3))/(p(4)-p(3)))
0429 z=tau*sinh(zeta)
0430 t=tau*cosh(zeta)
0431 xorptl(1,nptl)=xorptl(1,ipo)+r*cos(phirad(n))
0432 xorptl(2,nptl)=xorptl(2,ipo)+r*sin(phirad(n))
0433 xorptl(3,nptl)=z
0434 xorptl(4,nptl)=t
0435 else
0436 xorptl(1,nptl)=xorptl(1,ip)
0437 xorptl(2,nptl)=xorptl(2,ip)
0438 xorptl(3,nptl)=xorptl(3,ip)
0439 xorptl(4,nptl)=xorptl(4,ip)
0440 endif
0441 endif
0442 enddo
0443
0444 if(ish.ge.4)then
0445 write(ifch,*)'decay products:'
0446 call alist('&',nptlb+1,nptl)
0447 if(ish.ge.5)then
0448 write(ifch,*)'momentum sum:'
0449 do kk=1,5
0450 pptl(kk,nptl+1)=0
0451 do ii=nptlb+1,nptl
0452 pptl(kk,nptl+1)=pptl(kk,nptl+1)+pptl(kk,ii)
0453 enddo
0454 pptl(kk,nptl+2)=c(kk)
0455 enddo
0456 call alist('&',nptl+1,nptl+2)
0457 endif
0458 endif
0459
0460 1000 continue
0461 call utprix('hnbaaa',ish,ishini,4)
0462 return
0463 end
0464
0465
0466
0467
0468
0469
0470
0471
0472
0473
0474
0475
0476
0477
0478
0479
0480
0481
0482 subroutine hgcaaa
0483
0484
0485
0486
0487
0488
0489
0490
0491
0492
0493
0494
0495
0496
0497
0498
0499
0500
0501
0502
0503
0504
0505
0506
0507
0508
0509
0510 include 'epos.inc'
0511 parameter (mspecs=56)
0512 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
0513 common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
0514 common/cbol/rmsbol(mspecs),ptlbol(mspecs),chebol(mspecs),tembol
0515 common/cflavs/nflavs,kef(nflav),chem(nflav)
0516 common/ciakt/gen,iafs,ians,genm
0517 common/cnrit/nrit
0518 gen=10.0**(-epsgc)
0519 genm=gen/10.
0520
0521 isho=ish
0522 if(ishsub/100.eq.51)ish=mod(ishsub,100)
0523
0524 iug=(1+iospec)/2*2-1
0525
0526
0527
0528
0529 kef(1)=keu
0530 kef(2)=ked
0531 kef(3)=kes
0532 kef(4)=kec
0533 kef(5)=keb
0534 kef(6)=ket
0535
0536 if(iug.eq.1)nflavs=1
0537 if(iug.eq.3)nflavs=2
0538 if(iug.eq.5)nflavs=2
0539 if(iug.eq.7)nflavs=3
0540 if(iug.eq.9)nflavs=3
0541 if(iug.eq.11)nflavs=3
0542 tem=0.0
0543 do i=1,nflavs
0544 chem(i)=0.0
0545 enddo
0546 call hgchac(0)
0547 do i=1,nspecs
0548 ptlngc(i)=0.0
0549 rmsngc(i)=0.0
0550 enddo
0551 nrit=0
0552
0553 if(ish.ge.5)then
0554 write(ifch,*)('-',l=1,10)
0555 *,' entry sr hgcaaa ',('-',l=1,30)
0556 write(ifch,'(1x,a,2x,3i3)')
0557 *'>>> grand canonical hadron gas for droplet with u d s content:'
0558 *,keu,ked,kes
0559 write(ifch,'(1x,a,2x,f7.3,2x,a,2x,f7.3)')
0560 *'mass [GeV]:',tecm,'volume [fm^3]:',volu
0561 endif
0562
0563 if(iug.eq.1.and.keu.ne.0.and.ish.ge.5)then
0564 write(ifch,*)'inversion impossible !!!'
0565 write(ifch,*)'keu=0 required for this option'
0566 write(ifch,*)'T = mu(i) = 0 returned'
0567 if(ish.ge.5)write(ifch,*)('-',i=1,30)
0568 *,' exit sr hgcaaa ',('-',i=1,10)
0569 return
0570 endif
0571 if(iug.eq.3.and.(keu+ked).ne.0.and.ish.ge.5)then
0572 write(ifch,*)'inversion impossible !!!'
0573 write(ifch,*)'keu+ked=0 required for this option'
0574 write(ifch,*)'T = mu(i) = 0 returned'
0575 if(ish.ge.5)write(ifch,*)('-',i=1,30)
0576 *,' exit sr hgcaaa ',('-',i=1,10)
0577 return
0578 endif
0579 kf=keu+ked+kes+kec+keb+ket
0580 kf=abs(kf)
0581 if(kf.ne.0)then
0582 if(mod(kf,3).ne.0.and.ish.ge.5)then
0583 write(ifch,*)'inversion impossible !!!'
0584 write(ifch,*)'sum must be multiple of three'
0585 write(ifch,*)'T = mu(i) = 0 returned'
0586 if(ish.ge.5)write(ifch,*)('-',i=1,30)
0587 *,' exit sr hgcaaa ',('-',i=1,10)
0588 return
0589 endif
0590 endif
0591
0592
0593
0594
0595 gfac=0.0
0596
0597 if(iostat.eq.0.and.iospec.eq.iug)then
0598 do i=1,nspecs
0599 igsp=int(gspecs(i))
0600 if(mod(igsp,2).eq.0)then
0601 gfac=gfac+7.*gspecs(i)/8.
0602 else
0603 gfac=gfac+gspecs(i)
0604 endif
0605 enddo
0606 if(iabs(ispecs(nspecs)).lt.10)gfac=gfac+16.
0607 tem=(tecm/volu*hquer**3*30./pi**2/gfac)**.25
0608 else
0609 do i=1,nspecs
0610 gfac=gfac+gspecs(i)
0611 enddo
0612 if(iabs(ispecs(nspecs)).lt.10)gfac=gfac+16.
0613 tem=(tecm/volu*hquer**3*pi**2/gfac/3.)**.25
0614 tem=2.*tem
0615 endif
0616
0617 if(ish.ge.5)write(ifch,1)'initial T :',tem
0618 1 format(1x,a,3x,f9.6)
0619
0620 if(ish.ge.5)write(ifch,*)'iospec: ',iospec
0621
0622 if(ish.ge.5.and.iospec.ne.iug)then
0623 write(ifch,*)'inversion in Boltzmann approx. :'
0624 elseif(ish.ge.5.and.iospec.eq.iug)then
0625 write(ifch,*)'inversion for massless hadrons :'
0626 endif
0627
0628 if(ish.ge.5)then
0629 if(nflavs.eq.1)write(ifch,'(3x,a,8x,a)')
0630 *'T:','chemu:'
0631 if(nflavs.eq.2)write(ifch,'(3x,a,8x,a,5x,a)')
0632 *'T:','chemu:','chemd:'
0633 if(nflavs.eq.3)write(ifch,'(3x,a,8x,a,5x,a,5x,a)')
0634 *'T:','chemu:','chemd:','chems:'
0635 endif
0636
0637 k=1
0638 10 continue
0639 if(ish.ge.9.and.mod(k,10).eq.0)
0640 *write(ifch,*)'hgc iteration:',k
0641 if(ish.ge.9)call hgccch(1)
0642
0643
0644
0645 idt=0
0646 temo=tem
0647
0648 if(iospec.eq.iug)then
0649
0650
0651
0652 if(iostat.eq.0)then
0653 if(ish.ge.9)
0654 *write(ifch,*)'iteration (massless):',k
0655 call hgctm0
0656 elseif(iostat.eq.1)then
0657 if(ish.ge.9)
0658 *write(ifch,*)'iteration (Boltzmann, massless):',k
0659 call hgctbo(ibna)
0660 if(ibna.eq.1)then
0661 tem=temo
0662 goto20
0663 endif
0664 endif
0665
0666 else
0667
0668
0669
0670 if(ish.ge.9)
0671 *write(ifch,*)'iteration (Boltzmann, massive):',k
0672 call hgctbo(ibna)
0673 if(ibna.eq.1)then
0674 tem=temo
0675 goto20
0676 endif
0677
0678 endif
0679
0680 if(tem.le.1.e-6.and.ish.ge.5)then
0681 write(ifch,*)'inversion imposssible'
0682 write(ifch,*)'T:',tem
0683 if(ioinco.ge.1)call hnbmin(keu,ked,kes,kec)
0684 if(ish.ge.5)write(ifch,*)('-',i=1,30)
0685 *,' exit sr hgcaaa ',('-',i=1,10)
0686 ish=isho
0687 return
0688 endif
0689
0690 dt=abs(temo-tem)
0691 if(dt.le.gen*temo.or.dt.le.genm)idt=1
0692
0693
0694
0695 idch=0
0696 ibna=0
0697
0698 do iafs=1,nflavs
0699 chemo=chem(iafs)
0700
0701 if(iospec.eq.iug)then
0702
0703
0704
0705 if(iostat.eq.0)then
0706 call hgccm0
0707 elseif(iostat.eq.1)then
0708 call hgccbo(ibna)
0709 endif
0710
0711 else
0712
0713
0714
0715 call hgccbo(ibna)
0716
0717 endif
0718
0719 dch=abs(chemo-chem(iafs))
0720 if(ish.ge.9)write(ifch,*)'dch:',dch
0721 if(dch.le.abs(gen*chemo).or.dch.le.genm)idch=idch+1
0722 if(ibna.eq.1)then
0723 chem(iafs)=chemo
0724 call hgchac(0)
0725 goto20
0726 endif
0727
0728 enddo
0729
0730
0731
0732
0733 call hgchac(0)
0734
0735
0736 if(ish.ge.5.and.nflavs.eq.1)
0737 *write(ifch,'(1x,f8.6,2x,f9.6)')
0738 *tem,chem(1)
0739 if(ish.ge.5.and.nflavs.eq.2)
0740 *write(ifch,'(1x,f8.6,2x,f9.6,2x,f9.6)')
0741 *tem,chem(1),chem(2)
0742 if(ish.ge.5.and.nflavs.eq.3)
0743 *write(ifch,'(1x,f8.6,2x,f9.6,2x,f9.6,2x,f9.6)')
0744 *tem,chem(1),chem(2),chem(3)
0745 if(idch.eq.nflavs.and.idt.eq.1)goto20
0746
0747
0748 k=k+1
0749
0750 if(k.gt.300)then
0751 if(ish.ge.5)
0752 *write(ifch,*)'failure in approximate solution'
0753 goto20
0754 endif
0755
0756 goto10
0757
0758 20 continue
0759 if(ish.ge.9)call hgccch(0)
0760 if(ish.ge.5)write(ifch,'(1x,a,1x,f9.6)')' T :',tem
0761 do i=1,nflavs
0762 if(i.eq.1.and.ish.ge.5)
0763 *write(ifch,'(1x,a,1x,f9.6)')'chemu:',chem(1)
0764 if(i.eq.2.and.ish.ge.5)
0765 *write(ifch,'(1x,a,1x,f9.6)')'chemd:',chem(2)
0766 if(i.eq.3.and.ish.ge.5)
0767 *write(ifch,'(1x,a,1x,f9.6)')'chems:',chem(3)
0768 enddo
0769
0770
0771
0772
0773 if(ish.ge.5)call hgcchb
0774
0775
0776
0777 call hgcpyi(1)
0778
0779
0780
0781 if(ish.ge.5)call hgccfc
0782
0783 if(iug.eq.iospec.and.iostat.eq.0)then
0784 if(ish.ge.5)write(ifch,*)
0785 *'approximation and exact treatment equal'
0786 if(ish.ge.5)write(ifch,*)('-',i=1,30)
0787 *,' exit sr hgcaaa ',('-',i=1,10)
0788 ish=isho
0789 return
0790 endif
0791
0792
0793
0794 do i=1,nspecs
0795 rmsbol(i)=rmsngc(i)
0796 ptlbol(i)=ptlngc(i)
0797 chebol(i)=chemgc(i)
0798 enddo
0799 tembol=tem
0800 if(iostat.eq.1)then
0801 if(ish.ge.5)write(ifch,*)('-',i=1,30)
0802 *,' exit sr hgcaaa ',('-',i=1,10)
0803 ish=isho
0804 return
0805 endif
0806
0807
0808
0809
0810 if(ish.ge.5)write(ifch,*)'quantum statistics:'
0811 if(ish.ge.5.and.nflavs.eq.1)write(ifch,'(3x,a,8x,a)')
0812 *'T:','chemu:'
0813 if(ish.ge.5.and.nflavs.eq.2)write(ifch,'(3x,a,8x,a,6x,a)')
0814 *'T:','chemu:','chemd:'
0815 if(ish.ge.5.and.nflavs.eq.3)write(ifch,'(3x,a,8x,a,6x,a,6x,a)')
0816 *'T:','chemu:','chemd:','chems:'
0817 k=1
0818
0819 30 continue
0820 if(ish.ge.9.and.mod(k,10).eq.0)
0821 *write(ifch,*)'hgc iteration:',k
0822
0823
0824
0825 idt=0
0826 temo=tem
0827 call hgctex
0828 if(ish.ge.5.and.nflavs.eq.1)
0829 *write(ifch,'(1x,f10.8,2x,f10.7)')
0830 *tem,chem(1)
0831 if(ish.ge.5.and.nflavs.eq.2)
0832 *write(ifch,'(1x,f10.8,2x,f10.7,2x,f10.7)')
0833 *tem,chem(1),chem(2)
0834 if(ish.ge.5.and.nflavs.eq.3)
0835 *write(ifch,'(1x,f10.8,2x,f10.7,2x,f10.7,2x,f10.7)')
0836 *tem,chem(1),chem(2),chem(3)
0837
0838 if(tem.le.1.e-6.and.ish.ge.5)then
0839 write(ifch,*)'inversion imposssible'
0840 write(ifch,*)'T:',tem
0841 call hnbmin(keu,ked,kes,kec)
0842 if(ish.ge.5)write(ifch,*)('-',i=1,30)
0843 *,' exit sr hgcaaa ',('-',i=1,10)
0844 ish=isho
0845 return
0846 endif
0847
0848 dt=abs(temo-tem)
0849 if(dt.le.gen*temo.or.dt.le.genm)idt=1
0850 if(ish.ge.9)write(ifch,*)'dtem:',dt
0851
0852
0853
0854 idch=0
0855 do iafs=1,nflavs
0856 chemo=chem(iafs)
0857 call hgccex
0858 dch=abs(chemo-chem(iafs))
0859 if(ish.ge.9)write(ifch,*)'dche:',dch
0860 if(dch.le.abs(gen*chemo).or.dch.le.genm)idch=idch+1
0861 enddo
0862
0863
0864
0865 call hgchac(0)
0866
0867 if(idch.eq.nflavs.and.idt.eq.1)then
0868
0869 if(ish.ge.5)write(ifch,*)'results:'
0870 if(ish.ge.5)write(ifch,51)' T :',tem
0871 if(nflavs.ge.1.and.ish.ge.5)write(ifch,51)'chemu:',chem(1)
0872 if(nflavs.ge.2.and.ish.ge.5)write(ifch,51)'chemd:',chem(2)
0873 if(nflavs.ge.3.and.ish.ge.5)write(ifch,51)'chems:',chem(3)
0874 51 format(1x,a,3x,f9.6)
0875
0876
0877
0878 if(ish.ge.5)call hgcchh(i)
0879
0880
0881
0882 call hgcpyi(0)
0883
0884
0885
0886 call hgccfc
0887
0888 if(ish.ge.5)write(ifch,*)('-',i=1,30)
0889 *,' exit sr hgcaaa ',('-',i=1,10)
0890 ish=isho
0891 return
0892 endif
0893
0894 if(k.gt.300)then
0895 if(ish.ge.5)
0896 *write(ifch,*)'failure in exact solution'
0897 if(ish.ge.5)write(ifch,*)'results:'
0898 if(ish.ge.5)write(ifch,51)' T :',tem
0899 if(nflavs.ge.1.and.ish.ge.5)write(ifch,51)'chemu:',chem(1)
0900 if(nflavs.ge.2.and.ish.ge.5)write(ifch,51)'chemd:',chem(2)
0901 if(nflavs.ge.3.and.ish.ge.5)write(ifch,51)'chems:',chem(3)
0902
0903
0904
0905 call hgcpyi(0)
0906
0907 if(ish.ge.5)write(ifch,*)('-',i=1,30)
0908 *,' exit sr hgcaaa ',('-',i=1,10)
0909 ish=isho
0910 return
0911
0912 endif
0913
0914 k=k+1
0915 goto30
0916
0917 end
0918
0919
0920
0921 function hgcbi0(x)
0922
0923 DOUBLE PRECISION p1,p2,p3,p4,p5,p6,p7,q1,q2,q3,q4,q5,q6,q7,q8,q9,y
0924 SAVE p1,p2,p3,p4,p5,p6,p7,q1,q2,q3,q4,q5,q6,q7,q8,q9
0925 DATA p1,p2,p3,p4,p5,p6,p7/1.0d0,3.5156229d0,3.0899424d0,
0926 *1.2067492d0,0.2659732d0,0.360768d-1,0.45813d-2/
0927 DATA q1,q2,q3,q4,q5,q6,q7,q8,q9/0.39894228d0,0.1328592d-1,
0928 *0.225319d-2,-0.157565d-2,0.916281d-2,-0.2057706d-1,0.2635537d-1,
0929 *-0.1647633d-1,0.392377d-2/
0930 if (abs(x).lt.3.75) then
0931 y=dble((x/3.75)**2)
0932 hgcbi0=sngl(p1+y*(p2+y*(p3+y*(p4+y*(p5+y*(p6+y*p7))))))
0933 else
0934 ax=abs(x)
0935 y=dble(3.75/ax)
0936 hgcbi0=(exp(ax)/sqrt(ax))*(q1+y*(q2+y*(q3+y*(q4+y*(q5+y*(q6+y*
0937 *(q7+y*(q8+y*q9))))))))
0938 endif
0939 return
0940 end
0941
0942
0943
0944 function hgcbi1(x)
0945
0946 DOUBLE PRECISION p1,p2,p3,p4,p5,p6,p7,q1,q2,q3,q4,q5,q6,q7,q8,q9,y
0947 SAVE p1,p2,p3,p4,p5,p6,p7,q1,q2,q3,q4,q5,q6,q7,q8,q9
0948 DATA p1,p2,p3,p4,p5,p6,p7/0.5d0,0.87890594d0,0.51498869d0,
0949 *0.15084934d0,0.2658733d-1,0.301532d-2,0.32411d-3/
0950 DATA q1,q2,q3,q4,q5,q6,q7,q8,q9/0.39894228d0,-0.3988024d-1,
0951 *-0.362018d-2,0.163801d-2,-0.1031555d-1,0.2282967d-1,-0.2895312d-1,
0952 *0.1787654d-1,-0.420059d-2/
0953 if (abs(x).lt.3.75) then
0954 y=dble((x/3.75)**2)
0955 hgcbi1=x*(p1+y*(p2+y*(p3+y*(p4+y*(p5+y*(p6+y*p7))))))
0956 else
0957 ax=abs(x)
0958 y=dble(3.75/ax)
0959 hgcbi1=(exp(ax)/sqrt(ax))*(q1+y*(q2+y*(q3+y*(q4+y*(q5+y*(q6+y*
0960 *(q7+y*(q8+y*q9))))))))
0961 if(x.lt.0.)hgcbi1=-hgcbi1
0962 endif
0963 return
0964 END
0965
0966
0967
0968 function hgcbk0(x)
0969
0970 DOUBLE PRECISION p1,p2,p3,p4,p5,p6,p7,q1,q2,q3,q4,q5,q6,q7,y
0971 SAVE p1,p2,p3,p4,p5,p6,p7,q1,q2,q3,q4,q5,q6,q7
0972 DATA p1,p2,p3,p4,p5,p6,p7/-0.57721566d0,0.42278420d0,0.23069756d0,
0973 *0.3488590d-1,0.262698d-2,0.10750d-3,0.74d-5/
0974 DATA q1,q2,q3,q4,q5,q6,q7/1.25331414d0,-0.7832358d-1,0.2189568d-1,
0975 *-0.1062446d-1,0.587872d-2,-0.251540d-2,0.53208d-3/
0976 if (x.le.2.0) then
0977 y=dble(x*x/4.0)
0978 hgcbk0=(-log(x/2.0)*hgcbi0(x))+(p1+y*(p2+y*(p3+y*(p4+y*(p5+y*
0979 *(p6+y*p7))))))
0980 else
0981 y=dble(2.0/x)
0982 hgcbk0=(exp(-x)/sqrt(x))*(q1+y*(q2+y*(q3+y*(q4+y*(q5+y*(q6+y*
0983 *q7))))))
0984 endif
0985 return
0986 END
0987
0988
0989
0990 function hgcbk1(x)
0991
0992 DOUBLE PRECISION p1,p2,p3,p4,p5,p6,p7,q1,q2,q3,q4,q5,q6,q7,y
0993 SAVE p1,p2,p3,p4,p5,p6,p7,q1,q2,q3,q4,q5,q6,q7
0994 DATA p1,p2,p3,p4,p5,p6,p7/1.0d0,0.15443144d0,-0.67278579d0,
0995 *-0.18156897d0,-0.1919402d-1,-0.110404d-2,-0.4686d-4/
0996 DATA q1,q2,q3,q4,q5,q6,q7/1.25331414d0,0.23498619d0,-0.3655620d-1,
0997 *0.1504268d-1,-0.780353d-2,0.325614d-2,-0.68245d-3/
0998 if (x.le.2.0) then
0999 y=dble(x*x/4.0)
1000 hgcbk1=(log(x/2.0)*hgcbi1(x))+(1.0/x)*(p1+y*(p2+y*(p3+y*(p4+y*
1001 *(p5+y*(p6+y*p7))))))
1002 else
1003 y=dble(2.0/x)
1004 hgcbk1=(exp(-x)/sqrt(x))*(q1+y*(q2+y*(q3+y*(q4+y*(q5+y*(q6+y*
1005 *q7))))))
1006 endif
1007 return
1008 END
1009
1010
1011
1012 function hgcbk(n,x)
1013
1014 tox=2.0/x
1015 bkm=hgcbk0(x)
1016 bk=hgcbk1(x)
1017 do 11 j=1,n-1
1018 bkp=bkm+j*tox*bk
1019 bkm=bk
1020 bk=bkp
1021 11 continue
1022 hgcbk=bk
1023 return
1024 END
1025
1026
1027
1028 subroutine hgccbo(iba)
1029
1030
1031
1032
1033
1034
1035
1036
1037 common/cnsta/pi,pii,hquer,prom,piom,ainfin
1038 common/drop6/tecm,volu
1039 parameter (mspecs=56)
1040 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
1041 common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
1042 parameter(nflav=6)
1043 common/cflavs/nflavs,kef(nflav),chem(nflav)
1044 common/cflac/ifok(nflav,mspecs),ifoa(nflav)
1045 common/ciakt/gen,iafs,ians,genm
1046 external hgcbk
1047 k=1
1048 iba=0
1049 c1=-0.5
1050 c2=0.5
1051 goto11
1052
1053
1054
1055 10 chem(iafs)=c1+0.5*(c2-c1)
1056 11 continue
1057 fd=0.0
1058 call hgchac(0)
1059
1060 do i=1,nspecs
1061
1062 if(ifok(iafs,i).ne.0)then
1063 if((chemgc(i)/tem).gt.70.)then
1064 hpd=1.e30
1065 else
1066 hpd=exp(chemgc(i)/tem)
1067 endif
1068 if(aspecs(i).ne.0.)then
1069 fk2=hgcbk(2,aspecs(i)/tem)
1070 hpd=hpd*gspecs(i)*aspecs(i)**2*tem*fk2
1071 */2./pi**2/hquer**3
1072 else
1073 hpd=hpd*gspecs(i)*tem**3/pi**2/hquer**3
1074 endif
1075 hfd=ifok(iafs,i)*hpd
1076 fd=fd+hfd
1077 endif
1078
1079 enddo
1080
1081 dfd=abs(fd-(kef(iafs)/volu))
1082 if(dfd.le.abs(gen*(kef(iafs)/volu)).or.dfd.le.genm)return
1083
1084
1085
1086
1087
1088
1089 if(fd.gt.(kef(iafs)/volu))then
1090 c2=chem(iafs)
1091 else
1092 c1=chem(iafs)
1093 endif
1094
1095 k=k+1
1096 if(k.gt.300)return
1097
1098 goto10
1099
1100 end
1101
1102
1103
1104 subroutine hgccch(iii)
1105
1106
1107
1108
1109 include 'epos.inc'
1110 parameter (mspecs=56)
1111 common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
1112 common/cflavs/nflavs,kef(nflav),chem(nflav)
1113 parameter (nbin=500)
1114 common/cdatc/data(nbin),datb(nbin),datc(nbin),datd(nbin)
1115 *,date(nbin),datf(nbin),datg(nbin),dath(nbin),dati(nbin)
1116 common/cnrit/nrit
1117 character cen*4,cvol*4,cu*3,cd*3,cs*3
1118
1119 if(iii.gt.0)then
1120
1121 nrit=nrit+1
1122 data(nrit)=nrit
1123 datb(nrit)=tem
1124 datc(nrit)=chem(1)
1125 datd(nrit)=chem(2)
1126 date(nrit)=chem(3)
1127
1128 elseif(iii.eq.0)then
1129
1130 nrit=nrit+1
1131 data(nrit)=nrit
1132 datb(nrit)=tem
1133 datc(nrit)=chem(1)
1134 datd(nrit)=chem(2)
1135 date(nrit)=chem(3)
1136 do i=1,nrit
1137 datf(i)=datb(nrit)
1138 datg(i)=datc(nrit)
1139 dath(i)=datd(nrit)
1140 dati(i)=date(nrit)
1141 enddo
1142
1143 x1=data(1)
1144 x2=data(nrit)
1145 write(cen,'(f4.1)')tecm
1146 write(cvol,'(f4.1)')volu
1147 write(cu,'(i3)')keu
1148 write(cd,'(i3)')ked
1149 write(cs,'(i3)')kes
1150
1151
1152 write(ifhi,'(a)') 'newpage zone 1 4 1 openhisto'
1153 write(ifhi,'(a)') 'htyp lin xmod lin ymod lin'
1154 write(ifhi,'(a)') 'text 0 0 "xaxis Iteration"'
1155 write(ifhi,'(a)') 'text 0 0 "yaxis T (GeV)"'
1156 write(ifhi,'(a)') 'text 0.15 0.9 "E= '//cen//'"'
1157 write(ifhi,'(a)') 'text 0.4 0.9 "V= '//cvol//'"'
1158 write(ifhi,'(a,2e11.3)')'xrange',x1,x2
1159 write(ifhi,'(3a)')'yrange',' auto',' auto'
1160 write(ifhi,'(a)') 'array 2'
1161 do j=1,nrit
1162 write(ifhi,'(2e12.4)')data(j),datb(j)
1163 enddo
1164 write(ifhi,'(a)') ' endarray'
1165 write(ifhi,'(a)') 'closehisto plot 0-'
1166
1167 write(ifhi,'(a)') 'openhisto'
1168 write(ifhi,'(a)') 'htyp lin xmod lin ymod lin'
1169 write(ifhi,'(a,2e11.3)')'xrange',x1,x2
1170 write(ifhi,'(3a)')'yrange',' auto',' auto'
1171 write(ifhi,'(a)') 'array 2'
1172 do j=1,nrit
1173 write(ifhi,'(2e12.4)')data(j),datf(j)
1174 enddo
1175 write(ifhi,'(a)') ' endarray'
1176 write(ifhi,'(a)') 'closehisto plot 0'
1177
1178 write(ifhi,'(a)') 'openhisto'
1179 write(ifhi,'(a)') 'htyp lin xmod lin ymod lin'
1180 write(ifhi,'(a)') 'text 0 0 "xaxis Iteration"'
1181 write(ifhi,'(a)') 'text 0 0 "yaxis [m]^1! (GeV)"'
1182 write(ifhi,'(a)') 'text 0.15 0.9 "Q^1!= '//cu//'"'
1183 write(ifhi,'(a,2e11.3)')'xrange',x1,x2
1184 write(ifhi,'(3a)')'yrange',' auto',' auto'
1185 write(ifhi,'(a)') 'array 2'
1186 do j=1,nrit
1187 write(ifhi,'(2e12.4)')data(j),datc(j)
1188 enddo
1189 write(ifhi,'(a)') ' endarray'
1190 write(ifhi,'(a)') 'closehisto plot 0-'
1191
1192 write(ifhi,'(a)') 'openhisto'
1193 write(ifhi,'(a)') 'htyp lin xmod lin ymod lin'
1194 write(ifhi,'(a,2e11.3)')'xrange',x1,x2
1195 write(ifhi,'(3a)')'yrange',' auto',' auto'
1196 write(ifhi,'(a)') 'array 2'
1197 do j=1,nrit
1198 write(ifhi,'(2e12.4)')data(j),datg(j)
1199 enddo
1200 write(ifhi,'(a)') ' endarray'
1201 write(ifhi,'(a)') 'closehisto plot 0'
1202
1203 write(ifhi,'(a)') 'openhisto'
1204 write(ifhi,'(a)') 'htyp lin xmod lin ymod lin'
1205 write(ifhi,'(a)') 'text 0 0 "xaxis Iteration"'
1206 write(ifhi,'(a)') 'text 0 0 "yaxis [m]^2! (GeV)"'
1207 write(ifhi,'(a)') 'text 0.15 0.9 "Q^2!= '//cd//'"'
1208 write(ifhi,'(a,2e11.3)')'xrange',x1,x2
1209 write(ifhi,'(3a)')'yrange',' auto',' auto'
1210 write(ifhi,'(a)') 'array 2'
1211 do j=1,nrit
1212 write(ifhi,'(2e12.4)')data(j),datd(j)
1213 enddo
1214 write(ifhi,'(a)') ' endarray'
1215 write(ifhi,'(a)') 'closehisto plot 0-'
1216
1217 write(ifhi,'(a)') 'openhisto'
1218 write(ifhi,'(a)') 'htyp lin xmod lin ymod lin'
1219 write(ifhi,'(a,2e11.3)')'xrange',x1,x2
1220 write(ifhi,'(3a)')'yrange',' auto',' auto'
1221 write(ifhi,'(a)') 'array 2'
1222 do j=1,nrit
1223 write(ifhi,'(2e12.4)')data(j),dath(j)
1224 enddo
1225 write(ifhi,'(a)') ' endarray'
1226 write(ifhi,'(a)') 'closehisto plot 0'
1227
1228 write(ifhi,'(a)') 'openhisto'
1229 write(ifhi,'(a)') 'htyp lin xmod lin ymod lin'
1230 write(ifhi,'(a)') 'text 0 0 "xaxis Iteration"'
1231 write(ifhi,'(a)') 'text 0 0 "yaxis [m]^3! (GeV)"'
1232 write(ifhi,'(a)') 'text 0.15 0.9 "Q^3!= '//cs//'"'
1233 write(ifhi,'(a,2e11.3)')'xrange',x1,x2
1234 write(ifhi,'(3a)')'yrange',' auto',' auto'
1235 write(ifhi,'(a)') 'array 2'
1236 do j=1,nrit
1237 write(ifhi,'(2e12.4)')data(j),date(j)
1238 enddo
1239 write(ifhi,'(a)') ' endarray'
1240 write(ifhi,'(a)') 'closehisto plot 0-'
1241
1242 write(ifhi,'(a)') 'openhisto'
1243 write(ifhi,'(a)') 'htyp lin xmod lin ymod lin'
1244 write(ifhi,'(a,2e11.3)')'xrange',x1,x2
1245 write(ifhi,'(3a)')'yrange',' auto',' auto'
1246 write(ifhi,'(a)') 'array 2'
1247 do j=1,nrit
1248 write(ifhi,'(2e12.4)')data(j),dati(j)
1249 enddo
1250 write(ifhi,'(a)') ' endarray'
1251 write(ifhi,'(a)') 'closehisto plot 0'
1252
1253 endif
1254
1255 return
1256
1257 end
1258
1259
1260 subroutine hgccex
1261
1262
1263
1264
1265
1266
1267
1268
1269 include 'epos.inc'
1270 parameter (mspecs=56)
1271 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
1272 common/cflavs/nflavs,kef(nflav),chem(nflav)
1273 common/cflac/ifok(nflav,mspecs),ifoa(nflav)
1274 common/ciakt/gen,iafs,ians,genm
1275 external hgcfhn
1276
1277 k=1
1278
1279 c1=-0.5
1280 c2=0.5
1281 goto11
1282
1283
1284
1285 10 chem(iafs)=c1+0.5*(c2-c1)
1286 11 continue
1287
1288 fd=0.0
1289 do ians=1,nspecs
1290 if(ifok(iafs,ians).ne.0)then
1291
1292 call hgchac(0)
1293 call hgclim(a,b)
1294 if(b.eq.0.0)then
1295 hpd=0.0
1296 else
1297 call uttraq(hgcfhn,a,b,hpd)
1298 endif
1299 hpd=hpd*gspecs(ians)/2./pi**2/hquer**3
1300 fd=fd+hpd*ifok(iafs,ians)
1301
1302 endif
1303 enddo
1304
1305 dfd=abs(fd-(kef(iafs)/volu))
1306 if(dfd.le.abs(gen*(kef(iafs)/volu)).or.dfd.le.genm)return
1307
1308 if(fd.gt.(kef(iafs)/volu))then
1309 c2=chem(iafs)
1310 else
1311 c1=chem(iafs)
1312 endif
1313
1314 k=k+1
1315 if(k.gt.300)then
1316 if(ish.ge.5)
1317 *write(ifch,*)'failure at cex at iafs:',iafs
1318 return
1319 endif
1320
1321 goto10
1322
1323 end
1324
1325
1326
1327 subroutine hgccfc
1328
1329
1330
1331 include 'epos.inc'
1332 parameter (mspecs=56)
1333 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
1334 common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
1335 common/cflavs/nflavs,kef(nflav),chem(nflav)
1336 common/cflac/ifok(nflav,mspecs),ifoa(nflav)
1337
1338 if(ish.ge.5)write(ifch,*)'checking flavor conservation'
1339 do i=1,nflavs
1340 ckef=0.0
1341 do ii=1,nspecs
1342 ckef=ckef+ifok(i,ii)*ptlngc(ii)
1343 enddo
1344 dkef=abs(ckef-kef(i))
1345 if(dkef.le.1.e-2)then
1346 if(i.eq.1.and.ish.ge.5)write(ifch,*)'u conserved'
1347 if(i.eq.2.and.ish.ge.5)write(ifch,*)'d conserved'
1348 if(i.eq.3.and.ish.ge.5)write(ifch,*)'s conserved'
1349 else
1350 if(i.eq.1.and.ish.ge.5)write(ifch,*)'u not conserved'
1351 if(i.eq.2.and.ish.ge.5)write(ifch,*)'d not conserved'
1352 if(i.eq.3.and.ish.ge.5)write(ifch,*)'s not conserved'
1353 if(ish.ge.5)write(ifch,*)'df:',dkef
1354 endif
1355 enddo
1356
1357 return
1358 end
1359
1360
1361 subroutine hgcchb
1362
1363
1364
1365 include 'epos.inc'
1366 parameter (mspecs=56)
1367 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
1368 common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
1369 common/cflavs/nflavs,kef(nflav),chem(nflav)
1370 common/cflac/ifok(nflav,mspecs),ifoa(nflav)
1371 common/ciakt/gen,iafs,ians,genm
1372 external hgcfbe
1373 external hgcfbn
1374 if(ish.ge.5)write(ifch,*)
1375 *'check by numer. calc. of expect. values:'
1376 iced=0
1377 ceden=0.0
1378 do ians=1,nspecs
1379 call hgclim(a,b)
1380 if(b.eq.0.0)then
1381 cedh=0.0
1382 else
1383 call uttraq(hgcfbe,a,b,cedh)
1384 endif
1385 if(ish.ge.9)write(ifch,*)'cedh:',cedh
1386 ced=cedh*gspecs(ians)/2./pi**2/hquer**3
1387 ceden=ceden+ced
1388 enddo
1389
1390 if(iabs(ispecs(nspecs)).lt.10)
1391 *ceden=ceden+(8.*pi**2*tem**4/15.+bag4rt**4)/hquer**3
1392
1393 if(ish.ge.5)write(ifch,*)'energy density :',ceden
1394 ded=abs((tecm/volu)-ceden)
1395 if((tecm/volu)*gen.ge.ded.or.ded.le.gen)iced=1
1396 icfd=0
1397
1398 do i=1,nflavs
1399 cfd=0.0
1400 do ians=1,nspecs
1401 call hgclim(a,b)
1402 if(b.eq.0.0)then
1403 hpd=0.0
1404 else
1405 call uttraq(hgcfbn,a,b,hpd)
1406 endif
1407 hfd=ifok(i,ians)*hpd*gspecs(ians)/2./pi**2/hquer**3
1408 if(ish.ge.9)write(ifch,*)'hfd:',hfd
1409 cfd=cfd+hfd
1410 enddo
1411 if(i.eq.1.and.ish.ge.5)write(ifch,5)'flavor density u :',cfd
1412 if(i.eq.2.and.ish.ge.5)write(ifch,5)'flavor density d :',cfd
1413 if(i.eq.3.and.ish.ge.5)write(ifch,5)'flavor density s :',cfd
1414 5 format(1x,a,1x,f12.6)
1415 dfd=abs(cfd-(kef(i)/volu))
1416 if(abs(gen*(kef(i)/volu)).ge.dfd.or.dfd.le.gen)
1417 *icfd=icfd+1
1418 enddo
1419
1420 if(iced.eq.1.and.icfd.eq.nflavs)then
1421 if(ish.ge.5)write(ifch,*)'results agree'
1422 else
1423 if(ish.ge.5)write(ifch,*)'results disagree'
1424 endif
1425
1426 return
1427 end
1428
1429
1430 subroutine hgcchh(icorr)
1431
1432
1433
1434 include 'epos.inc'
1435 parameter (mspecs=56)
1436 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
1437 common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
1438 common/cflavs/nflavs,kef(nflav),chem(nflav)
1439 common/cflac/ifok(nflav,mspecs),ifoa(nflav)
1440 common/ciakt/gen,iafs,ians,genm
1441 external hgcfhe
1442 external hgcfhn
1443 icorr=0
1444 if(ish.ge.5)write(ifch,*)
1445 *'check by numer. calc. of expect. values:'
1446
1447 iced=0
1448 ceden=0.0
1449 do ians=1,nspecs
1450 call hgclim(a,b)
1451 if(b.eq.0.0)then
1452 cedh=0.0
1453 else
1454 call uttraq(hgcfhe,a,b,cedh)
1455 endif
1456 if(ish.ge.9)write(ifch,*)'cedh:',cedh
1457 ced=cedh*gspecs(ians)/2./pi**2/hquer**3
1458 ceden=ceden+ced
1459 enddo
1460
1461 if(iabs(ispecs(nspecs)).lt.10)
1462 *ceden=ceden+(8.*pi**2*tem**4/15.+bag4rt**4)/hquer**3
1463
1464 if(ish.ge.5)write(ifch,*)'energy density :',ceden
1465 ded=abs((tecm/volu)-ceden)
1466 if((tecm/volu)*gen.ge.ded.or.ded.le.gen)iced=1
1467
1468 icfd=0
1469
1470 do i=1,nflavs
1471 cfd=0.0
1472 do ians=1,nspecs
1473 call hgclim(a,b)
1474 if(b.eq.0.0)then
1475 hpd=0.0
1476 else
1477 call uttraq(hgcfhn,a,b,hpd)
1478 endif
1479 hfd=ifok(i,ians)*hpd*gspecs(ians)/2./pi**2/hquer**3
1480 if(ish.ge.9)write(ifch,*)'hfd:',hfd
1481 cfd=cfd+hfd
1482 enddo
1483 if(i.eq.1.and.ish.ge.5)write(ifch,5)'flavor density u :',cfd
1484 if(i.eq.2.and.ish.ge.5)write(ifch,5)'flavor density d :',cfd
1485 if(i.eq.3.and.ish.ge.5)write(ifch,5)'flavor density s :',cfd
1486 5 format(1x,a,1x,f9.6)
1487 dfd=abs(cfd-(kef(i)/volu))
1488 if(abs(gen*(kef(i)/volu)).ge.dfd.or.dfd.le.gen)
1489 *icfd=icfd+1
1490 enddo
1491
1492 if(iced.eq.1.and.icfd.eq.nflavs)then
1493 if(ish.ge.5)write(ifch,*)'results agree'
1494 icorr=1
1495 else
1496 if(ish.ge.5)write(ifch,*)'results disagree'
1497 endif
1498
1499 return
1500 end
1501
1502
1503
1504 subroutine hgccm0
1505
1506
1507
1508
1509
1510
1511
1512
1513 include 'epos.inc'
1514 parameter (mspecs=56)
1515 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
1516 common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
1517 common/cflavs/nflavs,kef(nflav),chem(nflav)
1518 common/cflac/ifok(nflav,mspecs),ifoa(nflav)
1519 common/ciakt/gen,iafs,ians,genm
1520 external hgcfhn
1521 k=1
1522 z3=1.2020569
1523
1524 c1=-0.5
1525 c2=0.5
1526 goto11
1527
1528
1529
1530 10 chem(iafs)=c1+0.5*(c2-c1)
1531 11 continue
1532
1533 fd=0.0
1534 call hgchac(0)
1535
1536 do i=1,nspecs
1537 if(ifok(iafs,i).ne.0)then
1538
1539 igsp=int(gspecs(i))
1540 if(mod(igsp,2).eq.0)then
1541
1542 if(ispecs(i).gt.0)then
1543 hpd=gspecs(i)*(chemgc(i)*tem**2+chemgc(i)**3/pi**2)/6./hquer**3
1544 else
1545 hpd=0.0
1546 endif
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573 else
1574
1575 hpd=gspecs(i)*tem**3*z3/pi**2/hquer**3
1576
1577 endif
1578
1579 hfd=hpd*ifok(iafs,i)
1580 fd=fd+hfd
1581
1582 endif
1583 enddo
1584
1585 dfd=abs(fd-(kef(iafs)/volu))
1586 if(dfd.le.abs(gen*(kef(iafs)/volu)).or.dfd.le.genm)return
1587
1588 if(fd.gt.(kef(iafs)/volu))then
1589 c2=chem(iafs)
1590 else
1591 c1=chem(iafs)
1592 endif
1593
1594 k=k+1
1595 if(k.gt.300)then
1596 if(ish.ge.5)
1597 *write(ifch,*)'failure at cm0 at iafs:',iafs
1598 return
1599 endif
1600 goto10
1601 end
1602
1603
1604 function hgcfbe(x)
1605
1606
1607
1608 parameter (mspecs=56)
1609 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
1610 common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
1611 common/ciakt/gen,iafs,ians,genm
1612 eex=81.
1613 hgcfbe=0.0
1614 sq=sqrt(x**2+aspecs(ians)**2)
1615 if(tem.ne.0.0)eex=(sq-chemgc(ians))/tem
1616 if(eex.gt.60.)return
1617 if(eex.lt.-60)then
1618 hgcfbe=1.e25
1619 return
1620 endif
1621
1622 hgcfbe=sq*x**2*exp(-eex)
1623
1624 return
1625 end
1626
1627
1628 function hgcfbf(x)
1629
1630
1631
1632 parameter (mspecs=56)
1633 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
1634 common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
1635 common/ciakt/gen,iafs,ians,genm
1636 eex=61
1637 hgcfbf=0.0
1638
1639 sq=sqrt(x**2+aspecs(ians)**2)
1640 if(tem.ne.0.0)eex=(sq-chemgc(ians))/tem
1641 if(eex.gt.60.)return
1642 if(eex.lt.-60)then
1643 hgcfbf=1.e25
1644 return
1645 endif
1646
1647 hgcfbf=(aspecs(ians)**2+x**2)*x**2*exp(-eex)
1648
1649 return
1650 end
1651
1652
1653 function hgcfbn(x)
1654
1655
1656
1657 parameter (mspecs=56)
1658 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
1659 common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
1660 common/ciakt/gen,iafs,ians,genm
1661 eex=81.
1662 hgcfbn=0.0
1663
1664 sq=sqrt(x**2+aspecs(ians)**2)
1665 if(tem.ne.0.0)eex=(sq-chemgc(ians))/tem
1666 if(eex.gt.80.)return
1667 if(eex.lt.-60)then
1668 hgcfbn=1.e25
1669 return
1670 endif
1671
1672 hgcfbn=x**2*exp(-eex)
1673
1674 return
1675 end
1676
1677
1678 function hgcfhe(x)
1679
1680
1681
1682 parameter (mspecs=56)
1683 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
1684 common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
1685 common/ciakt/gen,iafs,ians,genm
1686 eex=81.
1687 hgcfhe=0.0
1688 igsp=int(gspecs(ians))
1689
1690 sq=sqrt(x**2+aspecs(ians)**2)
1691 if(tem.ne.0.0)eex=(sq-chemgc(ians))/tem
1692 if(eex.gt.80.)return
1693
1694 if(mod(igsp,2).ne.0)then
1695 d=-1.0
1696 if(eex.lt.1.e-10)return
1697 else
1698 d=1.0
1699 endif
1700
1701 hgcfhe=sq*x**2/(exp(eex)+d)
1702
1703 return
1704 end
1705
1706
1707 function hgcfhf(x)
1708
1709
1710
1711 parameter (mspecs=56)
1712 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
1713 common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
1714 common/ciakt/gen,iafs,ians,genm
1715 eex=61
1716 hgcfhf=0.0
1717 igsp=int(gspecs(ians))
1718
1719 sq=sqrt(x**2+aspecs(ians)**2)
1720 if(tem.ne.0.0)eex=(sq-chemgc(ians))/tem
1721 if(eex.gt.60.)return
1722 if(eex.lt.(-60.))return
1723
1724 if(mod(igsp,2).ne.0)then
1725 d=-1.0
1726 if(eex.lt.1.0e-10.and.eex.gt.(-1.0e-10))return
1727 else
1728 d=1.0
1729 endif
1730
1731 hgcfhf=(aspecs(ians)**2+x**2)*x**2/(exp(eex)+2.0*d+exp(-eex))
1732
1733 return
1734 end
1735
1736
1737 function hgcfhn(x)
1738
1739
1740
1741 parameter (mspecs=56)
1742 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
1743 common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
1744 common/ciakt/gen,iafs,ians,genm
1745 eex=81.
1746 hgcfhn=0.0
1747 igsp=int(gspecs(ians))
1748
1749 sq=sqrt(x**2+aspecs(ians)**2)
1750 if(tem.ne.0.0)eex=(sq-chemgc(ians))/tem
1751 if(eex.gt.80.)return
1752
1753 if(mod(igsp,2).ne.0)then
1754 d=-1.0
1755 if(eex.lt.1.e-10)return
1756 else
1757 d=1.0
1758 endif
1759
1760 hgcfhn=x**2/(exp(eex)+d)
1761
1762 return
1763 end
1764
1765
1766 function hgcfhw(x)
1767
1768
1769
1770 parameter (mspecs=56)
1771 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
1772 common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
1773 common/ciakt/gen,iafs,ians,genm
1774 eex=61
1775 hgcfhw=0.0
1776 igsp=int(gspecs(ians))
1777
1778 sq=sqrt(x**2+aspecs(ians)**2)
1779 if(tem.ne.0.0)eex=(sq-chemgc(ians))/tem
1780 if(eex.gt.60.)return
1781 if(eex.lt.(-60.))return
1782
1783 if(mod(igsp,2).ne.0)then
1784 d=-1.0
1785 if(eex.lt.1.0e-10.and.eex.gt.(-1.0e-10))return
1786 else
1787 d=1.0
1788 endif
1789
1790 hgcfhw=x**2/(exp(eex)+2.0*d+exp(-eex))
1791
1792 return
1793 end
1794
1795
1796
1797 subroutine hgchac(iboco)
1798
1799
1800
1801
1802 include 'epos.inc'
1803 parameter (mspecs=56)
1804 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
1805 common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
1806 common/cflavs/nflavs,kef(nflav),chem(nflav)
1807 common/cflac/ifok(nflav,mspecs),ifoa(nflav)
1808
1809 do i=1,nspecs
1810 chemgc(i)=0.0
1811 do ii=1,nflavs
1812 chemgc(i)=chemgc(i)+ifok(ii,i)*chem(ii)
1813 if(ish.ge.9)write(ifch,*)'mu_i:',chem(ii),' k_i:',ifok(ii,i)
1814 enddo
1815 if(ish.ge.9)write(ifch,*)'mu_nu:',chemgc(i)
1816 igsp=int(gspecs(i))
1817 if(mod(igsp,2).ne.0.and.chemgc(i).gt.aspecs(i).and.iboco.eq.0)
1818 *chemgc(i)=aspecs(i)
1819 enddo
1820
1821 return
1822 end
1823
1824
1825
1826 subroutine hgclim(a,b)
1827
1828
1829
1830
1831 include 'epos.inc'
1832 parameter (mspecs=56)
1833 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
1834 common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
1835 common/ciakt/gen,iafs,ians,genm
1836
1837 igsp=int(gspecs(ians))
1838
1839 if(mod(igsp,2).ne.0)then
1840 a=0.001
1841 else
1842 a=0.0
1843 endif
1844
1845 b=0.0
1846 bb=(chemgc(ians)+tem*80.)**2-aspecs(ians)**2
1847 if(ish.ge.9)write(ifch,*)'bb:',bb
1848 if(bb.ge.0.0)b=sqrt(bb)
1849 if(bb.lt.0.0)then
1850 if(ish.ge.9)write(ifch,*)'failure at hgclim, bb=',bb
1851 if(ish.ge.9)write(ifch,'(1x,a,i5,a,2x,f12.6,1x,a,2x,f9.6)')
1852 *'mu(',ispecs(ians),'):',chemgc(ians),' T:',tem
1853 endif
1854 if(ish.ge.9)write(ifch,*)'ians:',ians,' a:',a,' b:',b
1855 return
1856 end
1857
1858
1859 subroutine hgcnbi(iret)
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870 include 'epos.inc'
1871 parameter(maxp=500)
1872 common/chnbin/nump,ihadro(maxp)
1873 parameter (mspecs=56)
1874 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
1875 common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
1876 common/cgctot/rmstot,ptltot
1877 common/camgc/amgc,samgc,amtot
1878 common/cflavs/nflavs,kef(nflav),chem(nflav)
1879 common/cflac/ifok(nflav,mspecs),ifoa(nflav)
1880 common/clatt/nlattc,npmax
1881 common/cgcnb/nptlgc(mspecs)
1882 common/ctaue/taue
1883 common/cgck/k(nflav),kp(nflav),kps(nflav)
1884 *,idp(maxp),ida(mspecs),idb(mspecs)
1885 integer hgcndn
1886
1887 iret=0
1888 isho=ish
1889 if(ishsub/100.eq.50)ish=mod(ishsub,100)
1890
1891 if(ish.ge.7)write(ifch,*)('-',l=1,10)
1892 *,' entry sr hgcnbi ',('-',l=1,30)
1893
1894
1895 nh=nint(ptltot)
1896 iug=(1+iospec)/2*2-1
1897 if(iug.lt.9)call utstop('hgcnbi: iospec < 9&')
1898
1899
1900
1901 if(ionlat.eq.1)then
1902 s1=ptltot+2.*rmstot
1903 s2=1.3*ptltot
1904 s=max(s1,s2,6.)
1905 nlattc=nint(s)
1906 elseif(ionlat.eq.2)then
1907 s1=ptltot+3.*rmstot
1908 s2=1.5*ptltot
1909 s=max(s1,s2,6.)
1910 nlattc=nint(s)
1911 elseif(ionlat.eq.3)then
1912 s1=ptltot+4.*rmstot
1913 s2=2.*ptltot
1914 s=max(s1,s2,6.)
1915 nlattc=nint(s)
1916 elseif(ionlat.eq.0)then
1917 nlattc=8*(tecm/10)*(1/(tecm/volu))**0.2*(nspecs/3.)**0.3
1918 if(aspecs(1).lt.0.010)nlattc=nlattc*3
1919 nlattc=max(nlattc,20)
1920 endif
1921
1922 if(ish.ge.7)write(ifch,*)'nlattc:',nlattc
1923
1924
1925
1926 if(iozero.eq.-1)then
1927 iozero=nspecs
1928 elseif(iozero.eq.-2)then
1929 iozero=nspecs*int(sqrt(volu/tecm))
1930 endif
1931
1932
1933
1934 if(iozevt.gt.0)then
1935 iozero=(nrevt/iozevt+1)*iozinc !nrevt=event number - 1 !!
1936 write(ifch,*)'nrevt+1:',nrevt+1,' iozero:',iozero
1937 endif
1938
1939
1940
1941 ammin=2.*aspecs(1)
1942 if(tecm.lt.ammin)then
1943 write(ifch,*)'impossible to generate hadron configuration'
1944 call utstop('hgcnbi: tecm less than two pi0 masses&')
1945 endif
1946
1947 kk=1
1948 100 continue
1949
1950 if(kk.gt.20)then
1951 iret=1
1952 if(ish.ge.7)then
1953 write(ifch,*)'failed to generate hadron set for'
1954 *,' event:',nrevt+1
1955 write(ifch,*)'u d s :',keu,ked,kes,' E:',tecm
1956 write(ifch,*)('-',i=1,30)
1957 *,' exit sr hgcnbi ',('-',i=1,10)
1958 endif
1959 ish=isho
1960 return
1961 endif
1962
1963 amtot=0.0
1964 do i=1,nspecs
1965 nptlgc(i)=0
1966 enddo
1967 do ii=1,nflavs
1968 k(ii)=kef(ii)
1969 enddo
1970
1971 if(ish.ge.7)write(ifch,*)
1972 *'sample hadron multiplicities and total mass:'
1973
1974 kbar=keu+ked+kes
1975 kpar=iabs(keu)+iabs(ked)+iabs(kes)
1976 nbar=kbar/3.
1977 if(ish.ge.7)write(ifch,*)'baryon number:',nbar,' parton number:'
1978 *,kpar
1979
1980 nn=2
1981 if(ioinco.ne.2)then
1982 nn=hgcndn(0)
1983 else
1984 nn=nh
1985 endif
1986 nb=iabs(nbar)
1987 if(ish.ge.7)write(ifch,*)'<n>:',nh,' n_sample:',nn,' n_bar:',nb
1988 if(nn.gt.nb.and.nb.ne.0.and.nb.ge.nh)nn=nb
1989 if(nn.lt.nb.and.nb.ne.0)nn=nb
1990 km=kpar-iabs(kbar)
1991 nt=km/2+nb
1992 if(nt.gt.nn)nn=nt
1993 nn=max(nn,2)
1994
1995 if(ioinco.eq.2)then
1996 nit=15*taue
1997 else
1998 itpn=100
1999 nit=nn*itpn
2000 endif
2001 nbb=0
2002 n=0
2003
2004
2005 nptlgc(19)=nptlgc(19)+nb
2006 n=nb
2007 amtot=amtot+nb*aspecs(19)
2008 do ii=1,nflavs
2009 k(ii)=k(ii)-ifok(ii,19)*nb
2010 enddo
2011 nbb=nbb+nb
2012
2013
2014 do it=1,nit
2015
2016 xsp=nspecs
2017 x0=0.5
2018 xib=x0+xsp*rangen()
2019 ib=nint(xib)
2020 if(ib.gt.nspecs)ib=nspecs
2021 if(ib.lt.1)ib=1
2022 kb=ifok(1,ib)+ifok(2,ib)+ifok(3,ib)
2023 if(rangen().lt.0.5.and.nptlgc(ib).ge.1)then
2024 ni=-1
2025 else
2026 ni=1
2027 endif
2028 as=1.0
2029 if(nptlgc(ib).eq.0)as=0.5
2030 if(nptlgc(ib).eq.1.and.ni.eq.(-1))as=2.0
2031 if(ish.ge.9)write(ifch,*)
2032 *'id:',ispecs(ib),' <i>:',ptlngc(ib),' ni:',ni
2033
2034 if(ni.ne.0)then
2035
2036 if(ptlngc(ib).gt.5.0)then
2037
2038 pnla=hgcpnl(ib,0)
2039 pnlb=hgcpnl(ib,ni)
2040 pnlog=-pnla+pnlb
2041 if(ish.ge.9)write(ifch,*)'pnlog:',pnlog
2042 if(pnlog.lt.60)then
2043 pn=exp(pnlog)
2044 else
2045 pn=1.1
2046 endif
2047
2048 else
2049
2050 if(ni.eq.1)then
2051 pn=ptlngc(ib)/(nptlgc(ib)+1)
2052 elseif(ni.eq.(-1).and.ptlngc(ib).gt.1.e-20)then
2053 pn=nptlgc(ib)/ptlngc(ib)
2054 elseif(nptlgc(ib).gt.0)then
2055 pn=1.1
2056 else
2057 pn=0.0
2058 endif
2059
2060 endif
2061
2062 pm=1.0
2063 if(ioinfl.ge.0)then
2064 pmla=hgcpml(ib,0,ib,0)
2065 pmlb=hgcpml(ib,ni,ib,0)
2066 pmlog=-pmla+pmlb
2067 if(ish.ge.9)write(ifch,*)'pmlog:',pmlog
2068 if(pmlog.lt.60)then
2069 pm=exp(pmlog)
2070 else
2071 pm=1.1
2072 endif
2073 endif
2074
2075 p=pn*pm*as
2076 r=rangen()
2077 if(r.le.p)then
2078 nptlgc(ib)=nptlgc(ib)+ni
2079 n=n+ni
2080 amtot=amtot+ni*aspecs(ib)
2081 do ii=1,nflavs
2082 k(ii)=k(ii)-ifok(ii,ib)*ni
2083 enddo
2084 if(kb.ne.0)nbb=nbb+ni
2085 if(ish.ge.7.and.ni.gt.0)write(ifch,*)'add:'
2086 if(ish.ge.7.and.ni.lt.0)write(ifch,*)'remove:'
2087 if(ish.ge.7)write(ifch,*)'id:',ispecs(ib),' <n_i>:',ptlngc(ib)
2088 *,' n_i:',nptlgc(ib)
2089 if(ish.ge.7)write(ifch,*)'<n>:',nn,' it:',it
2090 if(ish.ge.7)write(ifch,*)'<M>:',amgc,' M:',amtot
2091 if(ish.ge.7)write(ifch,*)'p:',p,' r:',r
2092 if(ish.ge.7)write(ifch,*)'flav defect: u:',k(1),' d:'
2093 *,k(2),' s:',k(3)
2094 if(n.ge.nn.and.ioinco.ne.2)goto102
2095 endif
2096
2097 endif
2098
2099 enddo
2100
2101
2102 102 continue
2103
2104 ndd=0
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119 if(n.lt.nn.and.ioinco.ne.2)then
2120 ndd=nn-n
2121 nd=mod(ndd,4)
2122 xn=n
2123 xnn=nn
2124 xl=(xnn-xn)/4.
2125 l=aint(xl)
2126 if(ish.ge.7)write(ifch,*)'add pions/etas: ndd:',ndd
2127 *,' l:',l,' nd:',nd
2128 if(l.ge.1)then
2129 do j=1,l
2130 nptlgc(1)=nptlgc(1)+1
2131 nptlgc(2)=nptlgc(2)+1
2132 nptlgc(3)=nptlgc(3)+1
2133 nptlgc(8)=nptlgc(8)+1
2134 amtot=amtot+aspecs(1)+aspecs(2)+aspecs(3)+aspecs(8)
2135 enddo
2136 endif
2137 if(nd.eq.1)then
2138 nptlgc(1)=nptlgc(1)+1
2139 amtot=amtot+aspecs(1)
2140 elseif(nd.eq.2)then
2141 nptlgc(2)=nptlgc(2)+1
2142 nptlgc(3)=nptlgc(3)+1
2143 amtot=amtot+aspecs(2)+aspecs(3)
2144 elseif(nd.eq.3)then
2145 nptlgc(2)=nptlgc(2)+1
2146 nptlgc(3)=nptlgc(3)+1
2147 nptlgc(1)=nptlgc(1)+1
2148 amtot=amtot+aspecs(2)+aspecs(3)+aspecs(1)
2149 endif
2150 endif
2151
2152 if(n.eq.0.and.ioinco.eq.2)then
2153 nptlgc(2)=nptlgc(2)+1
2154 nptlgc(3)=nptlgc(3)+1
2155 amtot=amtot+aspecs(2)+aspecs(3)
2156 elseif(n.eq.1.and.ioinco.eq.2)then
2157 nptlgc(1)=nptlgc(1)+1
2158 amtot=amtot+aspecs(1)
2159 endif
2160
2161 if(amtot.ge.tecm.and.ioinfl.ge.0)then
2162 if(ish.ge.7)write(ifch,*)
2163 *'total mass exceeded , redo configuration'
2164 kk=kk+1
2165 goto100
2166 endif
2167
2168
2169 iii=0
2170 if(ish.ge.7)then
2171 write(ifch,*)'u d s :',keu,ked,kes,' E:',tecm
2172 write(ifch,*)
2173 *'hadron set without flavor conservation:'
2174 endif
2175 do i=1,nspecs
2176 n=nptlgc(i)
2177 if(n.ge.1)then
2178 do j=1,n
2179 iii=iii+1
2180 if(iii.gt.maxp)stop'iii>maxp in hgcnbi'
2181 idp(iii)=ispecs(i)
2182 enddo
2183 endif
2184 enddo
2185 if(ish.ge.7)then
2186 write(ifch,'(1x,10i6)')(idp(i),i=1,iii)
2187 write(ifch,*)'flav defect: u:',k(1),' d:'
2188 *,k(2),' s:',k(3)
2189 write(ifch,*)'M:',amtot,' <M>:',amgc
2190 endif
2191 if(ioinfl.le.0)goto1000
2192
2193 ll=1
2194 llmax=nn*25
2195 ior=1
2196
2197 120 if(k(1).ne.0.or.k(2).ne.0.or.k(3).ne.0)then
2198
2199 if(kk.gt.6)ior=0
2200
2201 if(ish.ge.7)write(ifch,*)
2202 *'remaining flavor defect before operation:',ll
2203 if(ish.ge.7)write(ifch,*)'flav defect: u:',k(1),' d:'
2204 *,k(2),' s:',k(3)
2205
2206 nida=0
2207 do i=1,nspecs
2208 if(nptlgc(i).gt.0)then
2209 nida=nida+1
2210 ida(nida)=i
2211 endif
2212 enddo
2213
2214 if(nida.eq.0)then
2215 if(ish.ge.7)write(ifch,*)'no proposals in a , redo'
2216 kk=kk+1
2217 goto100
2218 endif
2219
2220
2221 xna=0.5+nida*rangen()
2222 na=nint(xna)
2223 if(na.gt.nida)na=nida
2224 if(na.lt.1)na=1
2225 ia=ida(na)
2226 if(ish.ge.7)write(ifch,*)'nida:',nida,' ia:',ia
2227
2228 nidb=0
2229 do ii=1,nflavs
2230 kp(ii)=k(ii)+ifok(ii,ia)
2231 kps(ii)=isign(1,kp(ii))
2232 enddo
2233 if(ish.ge.7)write(ifch,*)
2234 *' assemble: u:',kp(1),' d:',kp(2),' s:',kp(3)
2235 do i=1,nspecs
2236 iacc=0
2237 naccsp=0
2238 naccmi=1
2239 do ii=1,nflavs
2240 naccsp=naccsp+iabs(ifok(ii,i))
2241 if(kp(ii).ne.0)then
2242 if(kps(ii)*ifok(ii,i).le.kps(ii)*kp(ii)
2243 *.and.kps(ii)*ifok(ii,i).gt.0)iacc=iacc+iabs(ifok(ii,i))
2244 endif
2245 enddo
2246 if(kp(1).eq.0.and.kp(2).eq.0.and.kp(3).eq.0)naccmi=0
2247 if(iacc.eq.naccsp.and.naccsp.ge.naccmi)then
2248 nidb=nidb+1
2249 idb(nidb)=i
2250 endif
2251 enddo
2252
2253 if(nidb.eq.0)then
2254 if(ish.ge.7)write(ifch,*)'no proposals in b , redo'
2255 kk=kk+1
2256 goto100
2257 endif
2258
2259 xnb=0.5+nidb*rangen()
2260 nb=nint(xnb)
2261 if(nb.gt.nidb)nb=nidb
2262 if(nb.lt.1)nb=1
2263 ib=idb(nb)
2264 if(ish.ge.7)write(ifch,*)'nidb:',nidb,' ib:',ib
2265 if(ish.ge.7)write(ifch,*)
2266 *'proposal:',ispecs(ia),' --> ',ispecs(ib)
2267
2268 asym=1.0
2269
2270
2271
2272 if(ptlngc(ia).gt.5.0)then
2273 pnali=hgcpnl(ia,0)
2274 pnalf=hgcpnl(ia,-1)
2275 pnalog=-pnali+pnalf
2276 if(ish.ge.7)write(ifch,*)'pnalog:',pnalog
2277 if(pnalog.lt.60)then
2278 pna=exp(pnalog)
2279 else
2280 pna=1.1
2281 endif
2282 else
2283 if(ptlngc(ia).gt.1.e-20)then
2284 pna=nptlgc(ia)/ptlngc(ia)
2285 elseif(nptlgc(ia).gt.0)then
2286 pna=1.1
2287 else
2288 pna=0.0
2289 endif
2290 endif
2291
2292 if(ptlngc(ib).gt.5.0)then
2293 pnbli=hgcpnl(ib,0)
2294 pnblf=hgcpnl(ib,1)
2295 pnblog=-pnbli+pnblf
2296 if(ish.ge.7)write(ifch,*)'pnblog:',pnblog
2297 if(pnblog.lt.60)then
2298 pnb=exp(pnblog)
2299 else
2300 pnb=1.1
2301 endif
2302 else
2303 pnb=ptlngc(ib)/(nptlgc(ib)+1)
2304 endif
2305
2306
2307 pmli=hgcpml(ia,0,ib,0)
2308 pmlf=hgcpml(ia,-1,ib,1)
2309 pmlog=-pmli+pmlf
2310 if(ish.ge.7)write(ifch,*)'pmlog:',pmlog
2311 if(pmlog.lt.60)then
2312 pm=exp(pmlog)
2313 else
2314 pm=1.1
2315 endif
2316
2317 p=pna*pnb*pm*asym
2318 if(ior.eq.0)then
2319 r=0.0
2320 else
2321 r=rangen()
2322 endif
2323
2324
2325
2326
2327
2328
2329
2330
2331 if(r.lt.p)then
2332 if(ish.ge.7)write(ifch,*)'p:',p,' r:',r,' asymmetry:',asym
2333 if(ish.ge.7)write(ifch,*)'remove ',ispecs(ia),' add ',ispecs(ib)
2334 *,' proposal accepted'
2335 nptlgc(ia)=nptlgc(ia)-1
2336 nptlgc(ib)=nptlgc(ib)+1
2337 amtot=amtot-aspecs(ia)+aspecs(ib)
2338 do ii=1,nflavs
2339 k(ii)=k(ii)+ifok(ii,ia)-ifok(ii,ib)
2340 enddo
2341 endif
2342
2343
2344 if(k(1).ne.0.or.k(2).ne.0.or.k(3).ne.0)then
2345 ll=ll+1
2346 if(ll.le.llmax)then
2347 goto120
2348 else
2349 if(ish.ge.7)write(ifch,*)'failed to remove defect, redo'
2350 kk=kk+1
2351 goto100
2352 endif
2353 endif
2354
2355 endif
2356
2357 1000 continue
2358
2359 nump=0
2360 kcu=0
2361 kcd=0
2362 kcs=0
2363 do i=1,nspecs
2364 n=nptlgc(i)
2365 if(n.ge.1)then
2366 do j=1,n
2367 nump=nump+1
2368 ihadro(nump)=ispecs(i)
2369 kcu=kcu+ifok(1,i)
2370 kcd=kcd+ifok(2,i)
2371 kcs=kcs+ifok(3,i)
2372 enddo
2373 endif
2374 enddo
2375
2376 if(ioinfl.gt.0)then
2377 if(kcu.ne.keu.or.kcd.ne.ked.or.kcs.ne.kes)then
2378 if(ish.ge.7)write(ifch,*)
2379 *'failed to remove flavor defect, redo configuration'
2380 kk=kk+1
2381 goto100
2382 endif
2383 endif
2384
2385 if(ioinct.ge.1)then
2386 chitot=0.0
2387 nutot=nspecs
2388 do i=1,nspecs
2389 chi=0.0
2390 if(rmsngc(i).gt.1.e-10)chi=(ptlngc(i)-nptlgc(i))/rmsngc(i)
2391 chitot=chitot+chi**2
2392 enddo
2393 call xhgccc(chitot)
2394
2395 u=0
2396 d=0
2397 s=0
2398 do i=1,nspecs
2399 u=u+ifok(1,i)*nptlgc(i)
2400 d=d+ifok(2,i)*nptlgc(i)
2401 s=s+ifok(3,i)*nptlgc(i)
2402 enddo
2403 call xhgcfl(u,d,s,0)
2404 call xhgcam(amtot,0)
2405 endif
2406
2407 if(ish.ge.7)then
2408 write(ifch,*)
2409 *'initial hadron set for droplet decay:'
2410 write(ifch,'(1x,10i6)')(ihadro(i),i=1,nump)
2411 endif
2412 if(nump.ge.nlattc)then
2413 nlattc=nump+1
2414 if(ish.ge.7)then
2415 write(ifch,*)'initial set > nlattc !'
2416 write(ifch,*)'new nlattc:',nlattc
2417 endif
2418 endif
2419 if(ish.ge.7)then
2420 write(ifch,*)'keu:',kef(1),' kcu:',kcu,' ku:',k(1)
2421 write(ifch,*)'ked:',kef(2),' kcd:',kcd,' kd:',k(2)
2422 write(ifch,*)'kes:',kef(3),' kcs:',kcs,' ks:',k(3)
2423 write(ifch,*)' nh:',nh,' nump:',nump
2424 write(ifch,*)' nu:',nutot,' chi^2:',chitot
2425 write(ifch,*)'iozero:',iozero,' iomom:',iomom
2426 write(ifch,*)
2427 *'total mass:',amtot,' droplet mass:',tecm
2428 write(ifch,*)'trials needed:',kk
2429 *,' operations needed:',ll
2430 write(ifch,*)'iterations:',it,' pions added:',ndd
2431 write(ifch,*)('-',i=1,30)
2432 *,' exit sr hgcnbi ',('-',i=1,10)
2433 endif
2434 ish=isho
2435 return
2436
2437 end
2438
2439
2440 integer function hgcndn(i)
2441
2442
2443
2444 include 'epos.inc'
2445 parameter (mspecs=56)
2446 common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
2447 common/cgctot/rmstot,ptltot
2448 common/clatt/nlattc,npmax
2449 a=iowidn
2450 kk=0
2451
2452 if(i.eq.0)then
2453
2454 1 continue
2455 kk=kk+1
2456 p=0.0
2457 nmin=2
2458 nh=nint(ptltot)
2459 nmax=nlattc
2460 xn=1.5+(nmax-nmin)*rangen()
2461 n=nint(xn)
2462 x=(n-ptltot)**2/2.0
2463 y=-70.
2464 if(rmstot.gt.1.e-15)y=-x/rmstot**2*a**2
2465 if(y.lt.70.)p=exp(y)
2466 if(rmstot.gt.1.e-15.and.iowidn.lt.0)p=p/sqrt(2.*pi)/rmstot
2467 if(p.ge.rangen())then
2468 hgcndn=n
2469 if(ish.ge.9)write(ifch,*)'hgcndn: k:',kk,' n:',hgcndn
2470 return
2471 else
2472 if(kk.le.25)goto1
2473 hgcndn=max(2,nh)
2474 if(ish.ge.9)write(ifch,*)'hgcndn: k:',kk,' n:',hgcndn
2475 return
2476 endif
2477
2478 else
2479
2480 2 continue
2481 kk=kk+1
2482 p=0.0
2483 nmin=0
2484 nh=nint(ptlngc(i))
2485 nmax=2*nh
2486 nmax=max(2,nmax)
2487 xn=-0.5+(nmax-nmin)*rangen()
2488 n=nint(xn)
2489 x=(n-ptlngc(i))**2/2.0
2490 if(x.lt.1.e-30)then
2491 p=1.
2492 else
2493 y=-70.
2494 if(rmsngc(i).gt.1.e-15)y=-x/rmsngc(i)**2
2495 if(y.lt.70.)p=exp(y)
2496 if(rmsngc(i).gt.1.e-15.and.iowidn.lt.0)
2497 *p=p/sqrt(2.*pi)/rmsngc(i)
2498 endif
2499 if(p.ge.rangen())then
2500 hgcndn=n
2501 if(ish.ge.9)write(ifch,*)'hgcndn: k:',kk,' n:',hgcndn
2502 return
2503 else
2504 if(kk.le.25)goto2
2505 hgcndn=nh
2506 if(ish.ge.9)write(ifch,*)'hgcndn: k:',kk,' n:',hgcndn
2507 return
2508 endif
2509
2510 endif
2511
2512 end
2513
2514
2515 function hgcpml(i1,n1,i2,n2)
2516
2517 include 'epos.inc'
2518 parameter (mspecs=56)
2519 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
2520 common/camgc/amgc,samgc,amtot
2521 common/cgcnb/nptlgc(mspecs)
2522 if(ish.ge.9)write(ifch,*)'i1:',i1,' i2:',i2
2523 if(ish.ge.9)write(ifch,*)'n1:',n1,' n2:',n2
2524 hgcpml=-1.e30
2525 ampr=n1*aspecs(i1)+n2*aspecs(i2)
2526 if((amtot+ampr).lt.tecm.and.(amtot+ampr).ge.0
2527 *.and.nptlgc(i1).ge.(-n1).and.nptlgc(i2).ge.(-n2))then
2528 hgcpml=0.0
2529 pl=(amtot-amgc+ampr)**2/2.0
2530 if(pl.lt.1.e-30)then
2531 hgcpml=0.0
2532 return
2533 endif
2534 if(samgc.gt.1.e-15)hgcpml=-pl/samgc**2
2535 endif
2536 if(ish.ge.9)write(ifch,*)'hgcpml:',hgcpml
2537 return
2538 end
2539
2540
2541 function hgcpnl(i,n)
2542
2543 include 'epos.inc'
2544 parameter (mspecs=56)
2545 common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
2546 common/cgcnb/nptlgc(mspecs)
2547 if(ish.ge.9)write(ifch,*)'i:',i,' n:',n
2548 hgcpnl=-1.e30
2549 if(nptlgc(i).ge.(-n))then
2550 pl=(nptlgc(i)-ptlngc(i)+n)**2/2.0
2551 if(pl.lt.1.e-30)then
2552 hgcpnl=0.0
2553 return
2554 endif
2555 if(rmsngc(i).gt.1.e-15)hgcpnl=-pl/rmsngc(i)**2
2556 endif
2557 if(ish.ge.9)write(ifch,*)'hgcpnl:',hgcpnl
2558 return
2559 end
2560
2561
2562
2563 subroutine hgcpen
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575 include 'epos.inc'
2576 parameter (mspecs=56)
2577 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
2578 common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
2579 common/cflavs/nflavs,kef(nflav),chem(nflav)
2580 common/cflac/ifok(nflav,mspecs),ifoa(nflav)
2581 common/ciakt/gen,iafs,ians,genm
2582 parameter (nbin=100)
2583 real edensi(nbin,nbin),qdensi(nbin,nbin)
2584 external hgcfhe
2585 external hgcfhn
2586 external hgcfbe
2587 external hgcfbn
2588
2589 iug=(1+iospec)/2*2-1
2590
2591
2592
2593
2594 if(iug.eq.1)nflavs=1
2595 if(iug.eq.3)nflavs=2
2596 if(iug.eq.5)nflavs=2
2597 if(iug.eq.7)nflavs=3
2598 if(iug.eq.9)nflavs=3
2599 if(iug.eq.11)nflavs=3
2600 tem=0.0
2601 do i=1,nflavs
2602 chem(i)=0.0
2603 enddo
2604 call hgchac(0)
2605 do i=1,nspecs
2606 ptlngc(i)=0.0
2607 rmsngc(i)=0.0
2608 enddo
2609
2610 nbt=nint(xpar3)
2611 nbc=nint(xpar6)
2612 nbc=min(nbc,100)
2613 nbt=min(nbt,100)
2614 dt=(xpar2-xpar1)/nbt
2615 dc=(xpar5-xpar4)/nbc
2616 ymax=xpar7
2617 cs=xpar8
2618
2619
2620 t0=xpar1+dt/2.
2621 c0=xpar4+dc/2
2622 do i=1,nbc
2623 chem(1)=c0+(i-1)*dc
2624 chem(2)=chem(1)
2625 chem(3)=cs
2626 chem(4)=0.0
2627 chem(5)=0.0
2628 chem(6)=0.0
2629 call hgchac(0)
2630 do ii=1,nbt
2631 tem=t0+(ii-1)*dt
2632 if(ish.ge.5)write(ifch,*)' mu:',chem(1),' T:',tem
2633
2634 qd=0.0
2635 ed=0.0
2636
2637 do ians=1,nspecs
2638
2639 call hgclim(a,b)
2640
2641 if(b.eq.0.0)then
2642 hden=0.0
2643 elseif(iostat.eq.0)then
2644 call uttraq(hgcfhn,a,b,hden)
2645 elseif(iostat.eq.1)then
2646 call uttraq(hgcfbn,a,b,hden)
2647 endif
2648 hd=hden*gspecs(ians)/2./pi**2/hquer**3
2649
2650 if(ish.ge.7)write(ifch,*)'i:',ians,' n_u:',ifok(1,ians),' hd:',hd
2651
2652 qd=qd+ifok(1,ians)*hd+ifok(2,ians)*hd
2653 if(qd.gt.ymax)qd=ymax
2654
2655 if(qd.lt.-ymax)qd=-ymax
2656
2657
2658
2659 if(b.eq.0.0)then
2660 edi=0.0
2661 elseif(iostat.eq.0)then
2662 call uttraq(hgcfhe,a,b,edi)
2663 elseif(iostat.eq.1)then
2664 call uttraq(hgcfbe,a,b,edi)
2665 endif
2666 edi=edi*gspecs(ians)/2./pi**2/hquer**3
2667
2668 if(ish.ge.7)write(ifch,*)'i:',ians,' mu:',chemgc(ians)
2669 * ,' edi:',edi
2670
2671 ed=ed+edi
2672 if(ed.gt.ymax)ed=ymax
2673
2674 enddo
2675
2676 if(ish.ge.5)write(ifch,*)' ed:',ed,' qd:',qd
2677 edensi(i,ii)=ed
2678 qdensi(i,ii)=qd
2679
2680 enddo
2681 enddo
2682
2683 write(ifhi,'(a)') 'openhisto'
2684 write(ifhi,'(a,2e11.3)')'xrange',xpar1,xpar2
2685 write(ifhi,'(a,2e11.3)')'yrange',xpar4,xpar5
2686 write(ifhi,'(a)') 'set ityp2d 5'
2687 write(ifhi,'(a,i4)') 'array2d',nbt
2688 do j=1,nbc
2689 do jj=1,nbt
2690 write(ifhi,'(e11.3)') edensi(j,jj)
2691 enddo
2692 enddo
2693 write(ifhi,'(a)') ' endarray'
2694 write(ifhi,'(a)') 'closehisto plot2d'
2695
2696 write(ifhi,'(a)') 'openhisto'
2697 write(ifhi,'(a,2e11.3)')'xrange',xpar1,xpar2
2698 write(ifhi,'(a,2e11.3)')'yrange',xpar4,xpar5
2699 write(ifhi,'(a)') 'set ityp2d 5'
2700 write(ifhi,'(a,i4)') 'array2d',nbt
2701 do j=1,nbc
2702 do jj=1,nbt
2703 write(ifhi,'(e11.3)') qdensi(j,jj)
2704 enddo
2705 enddo
2706 write(ifhi,'(a)') ' endarray'
2707 write(ifhi,'(a)') 'closehisto plot2d'
2708
2709 return
2710 end
2711
2712
2713 subroutine hgcpfl
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725 include 'epos.inc'
2726 parameter (mspecs=56)
2727 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
2728 common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
2729 common/cflavs/nflavs,kef(nflav),chem(nflav)
2730 common/ciakt/gen,iafs,ians,genm
2731 parameter (nbin=100)
2732 real efl(nbin,nbin),qfl(nbin,nbin),v(nbin),wn(nbin),we(nbin)
2733 external hgcfhf
2734 external hgcfhe
2735 external hgcfhn
2736 external hgcfhw
2737 external hgcfbf
2738 external hgcfbe
2739 external hgcfbn
2740
2741 iug=(1+iospec)/2*2-1
2742
2743
2744
2745
2746 if(iug.eq.1)nflavs=1
2747 if(iug.eq.3)nflavs=2
2748 if(iug.eq.5)nflavs=2
2749 if(iug.eq.7)nflavs=3
2750 if(iug.eq.9)nflavs=3
2751 if(iug.eq.11)nflavs=3
2752 tem=0.0
2753 do i=1,nflavs
2754 chem(i)=0.0
2755 enddo
2756 call hgchac(0)
2757 do i=1,nspecs
2758 ptlngc(i)=0.0
2759 rmsngc(i)=0.0
2760 enddo
2761
2762 nbt=nint(xpar3)
2763 nbv=nint(xpar6)
2764 nbv=min(nbv,100)
2765 nbt=min(nbt,100)
2766 dt=(xpar2-xpar1)/nbt
2767 dv=(xpar5-xpar4)/nbv
2768 ymax=1.e20
2769 chem(1)=xpar7
2770 chem(2)=xpar7
2771 chem(3)=xpar8
2772 call hgchac(0)
2773
2774
2775 t0=xpar1+dt/2.
2776 v0=xpar4
2777 do i=1,nbv
2778 volu=v0+(i-1)*dv
2779 do ii=1,nbt
2780 tem=t0+(ii-1)*dt
2781 if(ish.ge.5)write(ifch,*)'volu:',volu,' tem:',tem
2782
2783 ev=0.0
2784 ee=0.0
2785 qv=0.0
2786 qe=0.0
2787
2788 do ians=1,nspecs
2789
2790 call hgclim(a,b)
2791
2792 if(b.eq.0.0)then
2793 hn=0.0
2794 hv=0.0
2795 elseif(iostat.eq.0)then
2796 call uttraq(hgcfhn,a,b,hn)
2797 call uttraq(hgcfhw,a,b,hv)
2798 elseif(iostat.eq.1)then
2799 call uttraq(hgcfbn,a,b,hn)
2800 hv=hn
2801 endif
2802 hn=hn*volu*gspecs(ians)/2./pi**2/hquer**3
2803 hv=hv*volu*gspecs(ians)/2./pi**2/hquer**3
2804 if(ish.ge.5)write(ifch,*)'hn:',hn,' hv:',hv
2805
2806 hn=max(hn,1.e-15)
2807 qv=qv+hv
2808 qe=qe+hn
2809
2810
2811 if(qv.gt.ymax)qv=ymax
2812 if(qe.gt.ymax)qe=ymax
2813
2814
2815 if(b.eq.0.0)then
2816 eei=0.0
2817 evi=0.0
2818 elseif(iostat.eq.0)then
2819 call uttraq(hgcfhe,a,b,eei)
2820 call uttraq(hgcfhf,a,b,evi)
2821 elseif(iostat.eq.1)then
2822 call uttraq(hgcfbe,a,b,eei)
2823 call uttraq(hgcfbf,a,b,evi)
2824 endif
2825 eei=eei*volu*gspecs(ians)/2./pi**2/hquer**3
2826 evi=evi*volu*gspecs(ians)/2./pi**2/hquer**3
2827 if(ish.ge.5)write(ifch,*)'eei:',eei,' evi:',evi
2828
2829
2830 eei=max(eei,1.e-15)
2831 ev=ev+evi
2832 ee=ee+eei
2833 if(ev.gt.ymax)ev=ymax
2834 if(ee.gt.ymax)ee=ymax
2835 enddo
2836 if(ish.ge.5)write(ifch,*)'qv:',qv,' ev:',ev
2837
2838 qfl(i,ii)=0.
2839 efl(i,ii)=0.
2840 if(ev.gt.0.0.and.ee.gt.1.e-15)efl(i,ii)=sqrt(ev)/ee
2841 if(qv.gt.0.0.and.ee.gt.1.e-15)qfl(i,ii)=sqrt(qv)/qe
2842 if(tem.eq.0.195)then
2843 we(i)=efl(i,ii)
2844 wn(i)=qfl(i,ii)
2845 v(i)=volu
2846 endif
2847
2848 enddo
2849 enddo
2850
2851 write(ifhi,'(a)') 'openhisto'
2852 write(ifhi,'(a,2e11.3)')'xrange',xpar1,xpar2
2853 write(ifhi,'(a,2e11.3)')'yrange',xpar4,xpar5
2854 write(ifhi,'(a)') 'set ityp2d 5'
2855 write(ifhi,'(a,i4)') 'array2d',nbt
2856 do j=1,nbv
2857 do jj=1,nbt
2858 write(ifhi,'(e11.3)') efl(j,jj)
2859 enddo
2860 enddo
2861 write(ifhi,'(a)') ' endarray'
2862 write(ifhi,'(a)') 'closehisto plot2d'
2863
2864 write(ifhi,'(a)') 'openhisto'
2865 write(ifhi,'(a,2e11.3)')'xrange',xpar1,xpar2
2866 write(ifhi,'(a,2e11.3)')'yrange',xpar4,xpar5
2867 write(ifhi,'(a)') 'set ityp2d 5'
2868 write(ifhi,'(a,i4)') 'array2d',nbt
2869 do j=1,nbv
2870 do jj=1,nbt
2871 write(ifhi,'(e11.3)') qfl(j,jj)
2872 enddo
2873 enddo
2874 write(ifhi,'(a)') ' endarray'
2875 write(ifhi,'(a)') 'closehisto plot2d'
2876
2877 write(ifhi,'(a)') 'newpage zone 1 2 1'
2878 write(ifhi,'(a)') 'openhisto'
2879 write(ifhi,'(a,2e11.3)')'xrange',xpar4,xpar5
2880 write(ifhi,'(a)') 'htyp lfu xmod lin ymod lin'
2881 write(ifhi,'(a,i4)') 'array 2'
2882 do j=1,nbv
2883 write(ifhi,'(2e13.5)')v(j),we(j)
2884 enddo
2885 write(ifhi,'(a)') ' endarray'
2886 write(ifhi,'(a)') 'closehisto plot 0'
2887
2888 write(ifhi,'(a)') 'openhisto'
2889 write(ifhi,'(a,2e11.3)')'xrange',xpar4,xpar5
2890 write(ifhi,'(a)') 'htyp lfu xmod lin ymod lin'
2891 write(ifhi,'(a,i4)') 'array 2'
2892 do j=1,nbv
2893 write(ifhi,'(2e13.5)')v(j),wn(j)
2894 enddo
2895 write(ifhi,'(a)') ' endarray'
2896 write(ifhi,'(a)') 'closehisto plot 0'
2897
2898
2899 return
2900 end
2901
2902
2903
2904 subroutine hgcpyi(ist)
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919 include 'epos.inc'
2920 parameter (mspecs=56)
2921 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
2922 common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
2923 common/cgctot/rmstot,ptltot
2924 common/camgc/amgc,samgc,amtot
2925 common/ciakt/gen,iafs,ians,genm
2926 external hgcfhw
2927 external hgcfhn
2928
2929 if(iabs(ispecs(nspecs)).lt.10)then
2930
2931
2932
2933 if(ish.ge.5)write(ifch,*)'parton yield:'
2934 gln=16.*1.20206*tem**3/pi**2*volu/hquer**3
2935 sdg=sqrt(gln) !!???
2936 if(ish.ge.5)write(ifch,'(1x,a,f10.4,2x,a,f9.4,a)')
2937 *'<N( 0)> :',gln,' sigma :',sdg,' (qm-statistics!)'
2938 ptltot=gln
2939 rmstot=0.0
2940 vartot=gln
2941
2942 else
2943
2944 if(ish.ge.5)write(ifch,*)'hadronic yield:'
2945 ptltot=0.0
2946 rmstot=0.0
2947 vartot=0.0
2948
2949 endif
2950
2951 amgc=0.0
2952 samgc=0.0
2953
2954 do ians=1,nspecs
2955
2956
2957
2958 if(ist.eq.0)then
2959
2960 call hgclim(a,b)
2961 if(b.eq.0.0)then
2962 hden=0.0
2963 else
2964 call uttraq(hgcfhn,a,b,hden)
2965 endif
2966 ptlngc(ians)=hden*volu*gspecs(ians)/2./pi**2/hquer**3
2967
2968 else
2969
2970 if((chemgc(ians)/tem).gt.70.)then
2971 hpd=1.e30
2972 else
2973 hpd=exp(chemgc(ians)/tem)
2974 endif
2975 if(aspecs(ians).ne.0.)then
2976 fk2=hgcbk(2,aspecs(ians)/tem)
2977 hpd=hpd*gspecs(ians)*aspecs(ians)**2*tem*fk2
2978 */2./pi**2/hquer**3
2979 else
2980 hpd=hpd*gspecs(ians)*tem**3/pi**2/hquer**3
2981 endif
2982 ptlngc(ians)=hpd*volu
2983
2984 endif
2985
2986 ptltot=ptltot+ptlngc(ians)
2987 amgc=amgc+ptlngc(ians)*aspecs(ians)
2988 if(amgc.ge.tecm)amgc=tecm*0.9
2989
2990
2991
2992 rmsngc(ians)=0.0
2993
2994 if(ist.eq.0)then
2995
2996 call uttraq(hgcfhw,a,b,var)
2997 var=var*gspecs(ians)*volu/2./pi**2/hquer**3
2998 vartot=vartot+var
2999 if(var.ge.0.0)rmsngc(ians)=sqrt(var)
3000 samgc=samgc+var*aspecs(ians)
3001
3002 else
3003
3004 if(ptlngc(ians).ge.0.0)rmsngc(ians)=sqrt(ptlngc(ians))
3005 vartot=vartot+ptlngc(ians)
3006 samgc=samgc+ptlngc(ians)*aspecs(ians)
3007
3008 endif
3009
3010
3011 if(ish.ge.7)write(ifch,'(2x,a,i5,a,2x,f8.4,5x,a,3x,f8.4)')
3012 *'m(',ispecs(ians),') :',aspecs(ians),'mu :',chemgc(ians)
3013 if(ish.ge.5)write(ifch,'(1x,a,i5,a,2x,f8.4,2x,a,2x,f10.4)')
3014 *'<N(',ispecs(ians),')> :',ptlngc(ians),'sigma :',rmsngc(ians)
3015
3016 enddo
3017
3018 if(vartot.ge.0.0)rmstot=sqrt(vartot)
3019 if(samgc.ge.0.0)samgc=sqrt(samgc)
3020 if(amgc.ge.tecm)samgc=sqrt(amgc)
3021 if(ish.ge.5)write(ifch,'(1x,a,2x,f8.4,2x,a,2x,f10.4)')
3022 *'<N( all)> :',ptltot,'sigma :',rmstot
3023 if(ish.ge.5)write(ifch,'(1x,a,2x,f8.4,2x,a,2x,f10.4)')
3024 *'<M_tot> :',amgc,'sigma :',samgc
3025
3026 return
3027 end
3028
3029
3030 subroutine hgctbo(iba)
3031
3032
3033
3034
3035
3036
3037
3038
3039 include 'epos.inc'
3040 parameter (mspecs=56)
3041 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
3042 common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
3043 common/ciakt/gen,iafs,ians,genm
3044 external hgcbk
3045 external hgcbk1
3046 iba=0
3047 k=1
3048 t1=0.0
3049 t2=1.0
3050
3051 goto15
3052
3053 10 tem=t1+.5*(t2-t1)
3054 if(tem.le.1.e-7)return
3055 15 eden=0.0
3056
3057 do i=1,nspecs
3058
3059 if(aspecs(i).ne.0)then
3060 if(tem.ne.0.)arr=aspecs(i)/tem
3061 cba=(aspecs(i)/tem+12.*tem/aspecs(i)-3.*chemgc(i)/aspecs(i))
3062 **hgcbk(2,arr)+(3.-chemgc(i)/tem)*hgcbk1(arr)
3063 else
3064 cba=4.*tem-chemgc(i)
3065 endif
3066
3067 if(cba.lt.0.0)then
3068 iba=1
3069 return
3070 endif
3071
3072 x=0.
3073 if(tem.ne.0.)x=chemgc(i)/tem
3074
3075 if(x.le.70.)then
3076 y=exp(x)
3077 else
3078 y=1.e30
3079 endif
3080
3081 if(aspecs(i).ne.0.)then
3082 edi=y*(3./arr*hgcbk(2,arr)+hgcbk1(arr))
3083 **gspecs(i)*aspecs(i)**3*tem/2./pi**2/hquer**3
3084 else
3085 edi=y*3.*gspecs(i)*tem**4/pi**2/hquer**3
3086 endif
3087
3088 eden=eden+edi
3089
3090 enddo
3091
3092 if(iabs(ispecs(nspecs)).lt.10)
3093 *eden=eden+(8.*pi**2*tem**4/15.+bag4rt**4)/hquer**3
3094
3095 de=abs(eden-(tecm/volu))
3096 if(de.le.gen*(tecm/volu).or.de.le.genm)return
3097
3098
3099 if(eden.gt.(tecm/volu))then
3100 t2=tem
3101 else
3102 t1=tem
3103 endif
3104
3105 if(k.gt.300)return
3106
3107 k=k+1
3108 goto10
3109 end
3110
3111
3112 subroutine hgctex
3113
3114
3115
3116
3117
3118
3119
3120
3121 include 'epos.inc'
3122 parameter (mspecs=56)
3123 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
3124 common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
3125 common/ciakt/gen,iafs,ians,genm
3126 external hgcfhe
3127 k=1
3128 t1=0.0
3129 t2=tem+0.1
3130 goto15
3131
3132
3133
3134 10 tem=t1+.5*(t2-t1)
3135 15 continue
3136 if(tem.le.1.e-6)return
3137 eden=0.0
3138
3139 do ians=1,nspecs
3140 call hgclim(a,b)
3141 if(b.eq.0.0)then
3142 edi=0.0
3143 else
3144 call uttraq(hgcfhe,a,b,edi)
3145 endif
3146 edi=edi*gspecs(ians)/2./pi**2/hquer**3
3147 eden=eden+edi
3148 enddo
3149
3150 if(iabs(ispecs(nspecs)).lt.10)
3151 *eden=eden+(8.*pi**2*tem**4/15.+bag4rt**4)/hquer**3
3152
3153 de=abs(eden-(tecm/volu))
3154 if(de.le.gen*(tecm/volu).or.de.le.genm)return
3155
3156 if(eden.gt.(tecm/volu))then
3157 t2=tem
3158 else
3159 t1=tem
3160 endif
3161
3162 if(k.gt.300)then
3163 if(ish.ge.5)
3164 *write(ifch,*)'failure in tex'
3165 return
3166 endif
3167
3168 k=k+1
3169 goto10
3170 end
3171
3172
3173 subroutine hgctm0
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183 include 'epos.inc'
3184 parameter (mspecs=56)
3185 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
3186 common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
3187 common/ciakt/gen,iafs,ians,genm
3188
3189 k=1
3190
3191 t1=0.0
3192 t2=1.0
3193 10 tem=t1+.5*(t2-t1)
3194 if(tem.le.1.e-6)return
3195 eden=0.0
3196
3197 do i=1,nspecs
3198
3199 igsp=int(gspecs(i))
3200 if(mod(igsp,2).eq.0)then
3201 edhm0=7./240.*pi**2*tem**4+chemgc(i)**2*tem**2/8.
3202 *+chemgc(i)**4/pi**2/16.
3203 else
3204 edhm0=pi**2*tem**4/30.+chemgc(i)**2*tem**2/4.
3205 *-chemgc(i)**4/pi**2/16.
3206 endif
3207 edi=edhm0*gspecs(i)/hquer**3
3208
3209
3210 eden=eden+edi
3211 enddo
3212
3213 if(iabs(ispecs(nspecs)).lt.10)
3214 *eden=eden+(8.*pi**2*tem**4/15.+bag4rt**4)/hquer**3
3215
3216 de=abs(eden-(tecm/volu))
3217 if(de.le.gen*(tecm/volu).or.de.le.genm)return
3218
3219 if(eden.gt.(tecm/volu))then
3220 t2=tem
3221 else
3222 t1=tem
3223 endif
3224
3225 if(k.gt.300)then
3226 if(ish.ge.5)
3227 *write(ifch,*)'failure in tm0'
3228 return
3229 endif
3230
3231 k=k+1
3232 goto10
3233 end
3234
3235
3236 subroutine hnbcor(mode)
3237
3238
3239
3240
3241 include 'epos.inc'
3242 integer bns
3243 parameter (maxp=500,bns=100)
3244 common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
3245 dimension zwei(bns),zz(bns)!,phi(bns),yy(bns)
3246 common/cor/wert(bns),cwert(bns)
3247 character*6 cen,cvol
3248
3249 if(mode.eq.1)then
3250
3251 nctcor=nctcor+1
3252
3253 if(nctcor.eq.1)then
3254 do nn=1,bns
3255 wert(nn)=0
3256 cwert(nn)=0
3257 enddo
3258 endif
3259
3260 ll=0
3261
3262 do ii=1,np-1
3263 do jj=ii+1,np
3264
3265 ll=ll+1
3266 prod=0
3267
3268 do kk=1,3
3269 prod=prod+pcm(kk,ii)*pcm(kk,jj)
3270 enddo
3271
3272 cs=prod/pcm(5,ii)/pcm(5,jj)
3273
3274 if(abs(cs).gt.1.)then
3275 cs=aint(cs)
3276 ang=acos(cs)
3277 else
3278 ang=acos(cs)
3279 endif
3280
3281 if(cs.eq.1.)then
3282 nk=bns
3283 nw=1
3284 elseif(ang.eq.pi)then
3285 nk=1
3286 nw=bns
3287 else
3288 nw=1+aint(ang/pi*bns)
3289 nk=1+aint((cs+1.)/2.*bns)
3290 endif
3291 nw=min(nw,bns)
3292 nk=min(nk,bns)
3293
3294 wert(nw)=wert(nw)+1
3295 cwert(nk)=cwert(nk)+1
3296
3297 enddo
3298 enddo
3299
3300 elseif(mode.eq.2)then
3301
3302 do mm=1,bns
3303
3304 zwei(mm)=.5*2./bns+(mm-1)*2./bns-1.
3305
3306 zz(mm)=cwert(mm)/nctcor
3307 enddo
3308
3309 write(cen,'(f6.1)')tecm
3310 write(cvol,'(f6.1)')volu
3311
3312 write(ifhi,'(a)') 'newpage zone 1 1 1 openhisto'
3313 write(ifhi,'(a)') 'htyp lin xmod lin ymod lin'
3314 write(ifhi,'(a)') 'xrange -1 1'
3315 write(ifhi,'(a)') 'text 0 0 "xaxis cosine"'
3316 write(ifhi,'(a)') 'text 0 0 "yaxis counts"'
3317 write(ifhi,'(a)') 'text 0.4 0.91 "V='//cvol//'"'
3318 write(ifhi,'(a)') 'text 0.15 0.91 "E='//cen//'"'
3319 write(ifhi,'(a)') 'array 2'
3320 do mm=1,bns
3321 write(ifhi,'(2e13.5)')zwei(mm),zz(mm)
3322 enddo
3323 write(ifhi,'(a)') ' endarray'
3324 write(ifhi,'(a)') 'closehisto plot 0'
3325
3326 endif
3327
3328 return
3329 end
3330
3331
3332 subroutine hnbfac(faclog)
3333
3334
3335
3336
3337
3338
3339
3340
3341 include 'epos.inc'
3342 parameter(maxp=500)
3343 common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
3344
3345 common /clatt/nlattc,npmax
3346
3347 faclog=0
3348
3349
3350 flog=0
3351 do i=1,np
3352 call hnbfaf(i,gg,am,ioma)
3353 flog=flog+alog(gg*am*volu/4/pi**3/hquer**3/(nlattc+1-i))
3354 enddo
3355 faclog=faclog+flog
3356
3357 return
3358 end
3359
3360
3361 subroutine hnbfaf(i,gg,am,ioma)
3362
3363
3364
3365 common/metr1/iospec,iocova,iopair,iozero,ioflac,iomom
3366 parameter(maxp=500)
3367 common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
3368 common/drop6/tecm,volu
3369
3370 ioma=5
3371
3372 hquer=0.197327
3373 cc=0.216416
3374 dd=13.773935
3375
3376 call hnbspi(ident(i),spideg)
3377 gg=spideg
3378
3379 if(ioma.eq.1)am=amass(i)
3380 if(ioma.eq.2)am=tecm/np
3381 if(ioma.eq.3)am=1
3382 if(ioma.eq.4)
3383 *am=cc*dd*gg**(-0.25)*(tecm/volu)**(0.25)*hquer**(0.75)
3384 if(ioma.eq.5)am=0.5 ! 1GeV / 2 (dimension energy)
3385 if(iocova.eq.2)then
3386 am=0.5 ! 1 / 2 (no dimension)
3387 ioma=0
3388 endif
3389 return
3390 end
3391
3392
3393
3394
3395
3396
3397
3398
3399
3400
3401
3402
3403
3404
3405
3406
3407
3408
3409
3410
3411
3412
3413
3414
3415
3416
3417
3418
3419
3420
3421
3422
3423
3424
3425
3426
3427
3428
3429
3430
3431
3432
3433 subroutine hnbiiw(x,f,df)
3434
3435
3436
3437
3438
3439
3440
3441
3442
3443
3444
3445
3446 common/ciiw/iii,rrr
3447 i=iii
3448 f=x**(2*i-2)*(i-(i-1)*x**2)-rrr
3449 df=2*i*(i-1)*(x**(2*i-3)-x**(2*i-1))
3450 return
3451 end
3452
3453
3454 subroutine hnbini(iret)
3455
3456
3457
3458 include 'epos.inc'
3459 parameter(maxp=500)
3460 common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
3461 parameter (mspecs=56)
3462 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
3463 common/crnoz/rnoz(maxp-1)
3464 common/citer/iter,itermx
3465 common/cfact/faclog
3466 common/chnbin/nump,ihadro(maxp)
3467 common /clatt/nlattc,npmax
3468 parameter(maxit=50000)
3469 common/count/nacc,nrej,naccit(maxit),nptot,npit(maxit)
3470 common/ctaue/taue
3471 if(ish.ge.7)write(ifch,*)('-',i=1,10)
3472 *,' entry sr hnbini ',('-',i=1,30)
3473
3474 iter=0
3475
3476 nlattc=8*(tecm/10)*(1/(tecm/volu))**0.2*(nspecs/3.)**0.3
3477 if(aspecs(1).lt.0.010)nlattc=nlattc*3
3478 nlattc=max(nlattc,20)
3479 if(iternc.lt.0)iternc=1.500*nlattc
3480
3481 itermx=iterma
3482 if(itermx.le.0)then
3483 e=tecm/volu
3484 b=1.1*(e+0.33)**0.66
3485 a=13.*(e+0.13)**(-0.65)
3486 tm=34.*(e+0.65)**(-0.61)
3487 t=a+b*volu
3488 taue=max(t,tm)
3489 itermx=(-itermx)*taue
3490 else
3491 taue=0
3492 endif
3493 if(ish.ge.5)write(ifch,*)'itermx:',itermx
3494
3495 if(iternc.gt.itermx/2)iternc=itermx/2
3496
3497 if(ioinco.eq.0)then
3498 call hnbmin(keu,ked,kes,kec)
3499 if(iograc.eq.1)call hgcaaa
3500 elseif(ioinco.ge.1)then
3501 nk=keu+ked+ked+kec
3502 if(tecm.lt.1.5.and.nk.eq.0)then
3503 call hnbmin(keu,ked,kes,kec)
3504 elseif(tecm.lt.2.0.and.nk.ne.0)then
3505 call hnbmin(keu,ked,kes,kec)
3506 else
3507 call hgcaaa
3508 call hgcnbi(iret)
3509 if(iret.eq.1)then
3510 call hnbmin(keu,ked,kes,kec)
3511 if(ish.ge.5)then
3512 write(ifch,*)'hadron set from hnbmin:'
3513 write(ifch,'(10i6)')(ihadro(k),k=1,nump)
3514 endif
3515 endif
3516 endif
3517 endif
3518
3519 np=nump+nadd
3520 if(np.gt.maxp)stop'np too large'
3521
3522 nlattc=max(nlattc,1+int(np*1.2))
3523
3524 if(nlattc-1.gt.maxp)stop'maxp too small'
3525
3526 do i= 1, nlattc-1
3527 rnoz(i)=rangen()
3528 enddo
3529
3530 if(nadd.gt.0)then
3531 do i=nump+1,np
3532 ihadro(i)=110
3533 enddo
3534 endif
3535
3536 do i=1,np
3537 ident(i)=ihadro(i)
3538 amass(i)=-1
3539 do j=1,nspecs
3540 if(ident(i).eq.ispecs(j))then
3541 amass(i)=aspecs(j)
3542 goto1
3543 endif
3544 enddo
3545 1 continue
3546 if(amass(i).lt.0.)
3547 *call utstop('hnbini: invalid particle species&')
3548 enddo
3549
3550 if(iocova.eq.1)call hnbody !covariant
3551 if(iocova.eq.2)call hnbodz !noncovariant
3552 call hnbfac(faclog)
3553 wtlog=wtxlog+faclog
3554
3555 iret=0
3556 if(wtlog.le.-0.99999E+35)then
3557 if(ish.ge.1) then
3558 call utmsg('hnbini')
3559 write(ifch,*)'***** wtlog for initl config < -1E+35'
3560 write(ifch,*)'***** wtlog:',wtlog
3561 write(ifch,*)'***** droplet mass:',tecm
3562 write(ifch,*)'***** flavour:'
3563 write(ifch,*)'*****',keu,ked,kes,kec,keb,ket
3564 write(ifch,'(1x,a,1x,10i6)')'*****',(ihadro(i),i=1,nump)
3565 call utmsgf
3566 endif
3567 iret=1
3568 goto1000
3569 endif
3570
3571 if(ish.ge.7)then
3572 write(ifch,*)'initial configuration:'
3573 call hnbwri
3574 endif
3575
3576 itermx=iterma
3577 if(itermx.le.0)then
3578 e=tecm/volu
3579 b=1.1*(e+0.33)**0.66
3580 a=13.*(e+0.13)**(-0.65)
3581 tm=34.*(e+0.65)**(-0.61)
3582 t=a+b*volu
3583 taue=max(t,tm)
3584 itermx=(-itermx)*taue
3585 else
3586 taue=0
3587 endif
3588 if(ish.ge.5)write(ifch,*)'itermx:',itermx
3589
3590 if(iternc.gt.itermx/2)iternc=itermx/2
3591
3592 nacc=0
3593 nrej=0
3594
3595 1000 continue
3596
3597 if(ish.ge.7)write(ifch,*)('-',i=1,30)
3598 *,' exit sr hnbini ',('-',i=1,10)
3599
3600 return
3601 end
3602
3603
3604
3605
3606
3607
3608
3609
3610
3611
3612
3613
3614
3615
3616
3617
3618
3619
3620
3621
3622
3623
3624
3625
3626
3627
3628
3629
3630
3631
3632
3633
3634
3635
3636
3637
3638
3639
3640
3641
3642
3643
3644
3645 subroutine hnbmet
3646
3647
3648
3649
3650
3651
3652 include 'epos.inc'
3653 parameter(maxp=500)
3654 common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
3655 common/crnoz/rnoz(maxp-1)
3656 real rnozo(maxp-1)
3657 common/cfact/faclog
3658 dimension amasso(maxp),idento(maxp),pcmo(5,maxp)
3659 integer jc(nflav,2),jc1(nflav,2),jc2(nflav,2)
3660 common/citer/iter,itermx
3661 parameter (mspecs=56)
3662 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
3663 parameter (literm=500)
3664 common/cmet/kspecs(mspecs),liter,lspecs(literm,mspecs)
3665 *,iterl(literm),iterc(literm)
3666
3667 common /clatt/nlattc,npmax
3668 parameter (nhise=100)
3669 common/chise/hise(mspecs,nhise)
3670 integer id1old(2),id2old(2),id1new(2),id2new(2)
3671 parameter(maxit=50000)
3672 common/count/nacc,nrej,naccit(maxit),nptot,npit(maxit)
3673 if(ish.ge.7)then
3674 write(ifch,*)('-',i=1,10)
3675 *,' entry sr hnbmet ',('-',i=1,30)
3676 write(ifch,'(1x,a,i4)')'iteration:',iter
3677 endif
3678 if(mod(iter,iterpr).eq.0)write(ifmt,*)'iteration:',iter
3679 if(maxp.gt.np)then
3680 do n=np+1,maxp
3681 ident(n)=0
3682 enddo
3683 endif
3684
3685
3686
3687 if(iter.eq.1)then
3688 liter=1
3689 do i=1,nspecs
3690 kspecs(i)=0
3691 nptot=0
3692 do li=1,literm
3693 lspecs(li,i)=0
3694 enddo
3695 enddo
3696 do li=1,literm
3697 iterc(li)=0
3698 enddo
3699 do j=1,mspecs
3700 do i=1,nhise
3701 hise(j,i)=0
3702 enddo
3703 enddo
3704 call hnbzmu(-1)
3705 endif
3706
3707
3708
3709 wtlo=wtlog
3710 wtlox=wtxlog
3711 faclo=faclog
3712 npo=np
3713 if(np-1.gt.0)then
3714 do i=1,np-1
3715 rnozo(i)=rnoz(i)
3716 enddo
3717 endif
3718 if(np.gt.0)then
3719 do i=1,np
3720 amasso(i)=amass(i)
3721 idento(i)=ident(i)
3722 do j=1,5
3723 pcmo(j,i)=pcm(j,i)
3724 enddo
3725 enddo
3726 endif
3727
3728
3729
3730 xab=1
3731 xba=1
3732 if(iopair.eq.1)then
3733
3734 call hnbpad(1,n1,n2,n3,n4,mm,jc)
3735 id1old(1)=ident(n1)
3736 id2old(1)=ident(n2)
3737 id1old(2)=0
3738 id2old(2)=0
3739 call hnbpaj(jc,iwpair,id1,id2)
3740 ident(n1)=id1
3741 ident(n2)=id2
3742 call hnbrmz
3743 id1new(1)=id1
3744 id2new(1)=id2
3745 id1new(2)=0
3746 id2new(2)=0
3747 xab=1
3748 xba=1
3749 nzold=0
3750 if(id1old(1).eq.0)nzold=nzold+1
3751 if(id2old(1).eq.0)nzold=nzold+1
3752 nznew=0
3753 if(id1new(1).eq.0)nznew=nznew+1
3754 if(id2new(1).eq.0)nznew=nznew+1
3755
3756
3757
3758 elseif(iopair.eq.2)then
3759
3760 kkk=0
3761 25 call hnbpad(1,n1,n2,n3,n4,mm,jc)
3762 kkk=kkk+1
3763 id1old(1)=ident(n1)
3764 id2old(1)=ident(n2)
3765 call hnbpai(id1,id2,jc1)
3766 ident(n1)=id1
3767 ident(n2)=id2
3768 id1new(1)=id1
3769 id2new(1)=id2
3770 do i=1,nflav
3771 do j=1,2
3772 jc(i,j)=jc(i,j)-jc1(i,j)
3773 jc2(i,j)=jc(i,j)
3774 enddo
3775 enddo
3776 2 call hnbpad(2,n1,n2,n3,n4,mm,jc1)
3777 id1old(2)=ident(n3)
3778 id2old(2)=ident(n4)
3779 do i=1,nflav
3780 do j=1,2
3781 jc(i,j)=jc(i,j)+jc1(i,j)
3782 enddo
3783 enddo
3784 call hnbpaj(jc,iwpair,id1,id2)
3785 if(iwpair.eq.0)then
3786 do i=1,nflav
3787 do j=1,2
3788 jc(i,j)=jc2(i,j)
3789 enddo
3790 enddo
3791 if(ish.ge.7)write(ifch,*)'no pair possible'
3792 goto2
3793 endif
3794 ident(n3)=id1
3795 ident(n4)=id2
3796 id1new(2)=id1
3797 id2new(2)=id2
3798 call hnbrmz
3799 if(ish.ge.7)write(ifch,*)'wt-sum of 2. pairs (-->):',iwpair
3800 *,' chosen pair:',id1,id2
3801 call hnbpaj(jc1,iwpais,idum1,idum2)
3802 if(ish.ge.7)write(ifch,*)'wt-sum of 2. pairs (<--):',iwpais
3803 nzold=0
3804 if(id1old(1).eq.0)nzold=nzold+1
3805 if(id2old(1).eq.0)nzold=nzold+1
3806 if(id1old(2).eq.0)nzold=nzold+1
3807 if(id2old(2).eq.0)nzold=nzold+1
3808 if(ish.ge.7)write(ifch,*)'number of zeros (old):',nzold
3809 nznew=0
3810 if(id1new(1).eq.0)nznew=nznew+1
3811 if(id2new(1).eq.0)nznew=nznew+1
3812 if(id1new(2).eq.0)nznew=nznew+1
3813 if(id2new(2).eq.0)nznew=nznew+1
3814 if(ish.ge.7)write(ifch,*)'number of zeros (new):',nznew
3815 if(iorejz.eq.1.and.nzold.eq.4.and.nznew.eq.4.and.kkk.le.50)goto25
3816 xab=1./iwpair*iozero**nznew
3817 xba=1./iwpais*iozero**nzold
3818 if(ish.ge.7)write(ifch,*)'asymmetry factor:',xba/xab
3819 else
3820 call utstop('hnbmet: invalid choice for iopair&')
3821 endif
3822
3823
3824
3825 if(np.ge.2)then
3826 do i=1,np
3827 amass(i)=-1
3828 do j=1,nspecs
3829 if(ident(i).eq.ispecs(j))then
3830 amass(i)=aspecs(j)
3831 goto1
3832 endif
3833 enddo
3834 1 continue
3835 if(amass(i).lt.0.)
3836 *call utstop('hnbmet: invalid particle species&')
3837 enddo
3838 keepr=0
3839
3840 keepr=1
3841 if(iocova.eq.1)call hnbody
3842 if(iocova.eq.2)call hnbodz
3843 else
3844 wtxlog=-1e35
3845 endif
3846 call hnbfac(faclog)
3847 wtlog=wtxlog+faclog
3848 if(ish.ge.7)then
3849 write(ifch,*)'trial configuration:'
3850 call hnbwri
3851 endif
3852
3853
3854
3855 if(ish.ge.7)write(ifch,'(1x,a,4i5,a,4i5,a)')
3856 *'metropolis decision for '
3857 *,id1old(1),id2old(1),id1old(2),id2old(2),' --> '
3858 *,id1new(1),id2new(1),id1new(2),id2new(2),' :'
3859 iacc=0
3860 if(wtlog-wtlo.lt.30.)then
3861 q=exp(wtlog-wtlo)*xba/xab
3862 r=rangen()
3863 if(r.le.q)iacc=1
3864 if(ish.ge.7)write(ifch,*)'new weight / old weight:',q,' '
3865 *,'random number:',r
3866 else
3867 iacc=1
3868 if(ish.ge.7)write(ifch,*)'log new weight / old weight:'
3869 *,wtlog-wtlo
3870 endif
3871 if(iacc.eq.1)then
3872 if(ish.ge.7)write(ifch,*)'new configuration accepted'
3873 nacc=nacc+1
3874 naccit(iter)=1
3875 else
3876 if(ish.ge.7)write(ifch,*)'old configuration kept'
3877 nrej=nrej+1
3878 wtlog=wtlo
3879 wtxlog=wtlox
3880 faclog=faclo
3881 np=npo
3882 if(np-1.gt.0)then
3883 do i=1,np-1
3884 rnoz(i)=rnozo(i)
3885 enddo
3886 endif
3887 if(np.gt.0)then
3888 do i=1,np
3889 amass(i)=amasso(i)
3890 ident(i)=idento(i)
3891 do j=1,5
3892 pcm(j,i)=pcmo(j,i)
3893 enddo
3894 enddo
3895 endif
3896 endif
3897 if(ioobsv.eq.0)then
3898 npit(iter)=np
3899 if(iter.gt.iternc)nptot=nptot+np
3900 else
3901 npob=0
3902 do i=1,np
3903 if(ioobsv.eq.ident(i))npob=npob+1
3904 enddo
3905 npit(iter)=npob
3906 if(iter.gt.iternc)nptot=nptot+npob
3907 endif
3908 if(ish.ge.7)then
3909 write(ifch,*)'actual configuration:'
3910 call hnbwri
3911 if(ish.eq.27)stop'change this?????????????' !call hnbcor(1)
3912 endif
3913
3914
3915
3916 if(iosngl.ne.nrevt+1.and.iocite.ne.1)goto1000
3917 npmax=max(npmax,np)
3918 if(liter.le.literm)then
3919 iterc(liter)=iterc(liter)+1
3920 do i=1,np
3921 do j=1,nspecs
3922 if(ident(i).eq.ispecs(j))then
3923 lspecs(liter,j)=lspecs(liter,j)+1
3924 goto8
3925 endif
3926 enddo
3927 8 continue
3928 enddo
3929 if(mod(iter,iterpl).eq.0)then
3930 iterl(liter)=iter
3931 liter=liter+1
3932
3933
3934
3935
3936
3937
3938 endif
3939 endif
3940 if(iter.le.iternc)return
3941
3942 do i=1,np
3943 call hnbzen(i) !fill energy histogram
3944 do j=1,nspecs
3945 if(ident(i).eq.ispecs(j))then
3946 kspecs(j)=kspecs(j)+1
3947 goto7
3948 endif
3949 enddo
3950 7 continue
3951 enddo
3952 call hnbzmu(1) !fill multiplicity histogram
3953
3954 if(iter.eq.itermx.and.npmax.ge.nlattc.and.ish.ge.1)then
3955 call utmsg('hnbmet')
3956 write(ifch,*)'***** nlattc too small'
3957 write(ifch,*)'nlattc:',nlattc,' npmax:',npmax
3958 call utmsgf
3959 endif
3960
3961 1000 continue
3962 if(ish.ge.7)then
3963 write(ifch,*)'accepted proposals:',nacc
3964 *,' rejected proposals:',nrej
3965 write(ifch,*)('-',i=1,30)
3966 *,' exit sr hnbmet ',('-',i=1,10)
3967 endif
3968 return
3969 end
3970
3971
3972 subroutine hnbmin(keux,kedx,kesx,kecx)
3973
3974
3975
3976
3977
3978
3979
3980
3981
3982
3983
3984 include 'epos.inc'
3985 parameter(maxp=500)
3986 common/chnbin/nump,ihadro(maxp)
3987 logical wri
3988 character f1*11
3989 wri=.false.
3990 if(ish.ge.7)wri=.true.
3991 if(wri)write(ifch,*)('-',i=1,10)
3992 *,' entry sr hnbmin ',('-',i=1,30)
3993
3994 nump=0
3995 f1='(4i3,i7,i6)'
3996 ke=iabs(keux+kedx+kesx+kecx)
3997
3998 if(keux+kedx+kesx+kecx.ge.0)then
3999 keu=keux
4000 ked=kedx
4001 kes=kesx
4002 kec=kecx
4003 isi=1
4004 else
4005 keu=-keux
4006 ked=-kedx
4007 kes=-kesx
4008 kec=-kecx
4009 isi=-1
4010 endif
4011 if(wri)write(ifch,'(4i3)')keux,kedx,kesx,kecx
4012 if(wri)write(ifch,'(4i3)')keu,ked,kes,kec
4013
4014
4015 if(kec.ne.0)then
4016 10 continue
4017 if(kec.lt.0)then
4018 kec=kec+1
4019 if(keu.gt.ked)then
4020 keu=keu-1
4021 nump=nump+1
4022 ihadro(nump)=140
4023 if(wri)write(ifch,f1)keu,ked,kes,kec,nump,ihadro(nump)
4024 else
4025 ked=ked-1
4026 nump=nump+1
4027 ihadro(nump)=240
4028 if(wri)write(ifch,f1)keu,ked,kes,kec,nump,ihadro(nump)
4029 endif
4030 goto10
4031 endif
4032 11 continue
4033 if(kec.gt.0)then
4034 kec=kec-1
4035 if(keu.lt.ked)then
4036 keu=keu+1
4037 nump=nump+1
4038 ihadro(nump)=-140
4039 if(wri)write(ifch,f1)keu,ked,kes,kec,nump,ihadro(nump)
4040 else
4041 ked=ked+1
4042 nump=nump+1
4043 ihadro(nump)=-240
4044 if(wri)write(ifch,f1)keu,ked,kes,kec,nump,ihadro(nump)
4045 endif
4046 goto11
4047 endif
4048 endif
4049
4050
4051 5 continue
4052 if(kes.lt.0)then
4053 kes=kes+1
4054 if(keu.ge.ked)then
4055 keu=keu-1
4056 nump=nump+1
4057 ihadro(nump)=130
4058 if(wri)write(ifch,f1)keu,ked,kes,kec,nump,ihadro(nump)
4059 else
4060 ked=ked-1
4061 nump=nump+1
4062 ihadro(nump)=230
4063 if(wri)write(ifch,f1)keu,ked,kes,kec,nump,ihadro(nump)
4064 endif
4065 goto5
4066 endif
4067
4068
4069 6 continue
4070 if(ked.lt.0)then
4071 ked=ked+1
4072 if(keu.ge.kes)then
4073 keu=keu-1
4074 nump=nump+1
4075 ihadro(nump)=120
4076 if(wri)write(ifch,f1)keu,ked,kes,kec,nump,ihadro(nump)
4077 else
4078 kes=kes-1
4079 nump=nump+1
4080 ihadro(nump)=-230
4081 if(wri)write(ifch,f1)keu,ked,kes,kec,nump,ihadro(nump)
4082 endif
4083 goto6
4084 endif
4085
4086
4087 7 continue
4088 if(keu.lt.0)then
4089 keu=keu+1
4090 if(ked.ge.kes)then
4091 ked=ked-1
4092 nump=nump+1
4093 ihadro(nump)=-120
4094 if(wri)write(ifch,f1)keu,ked,kes,kec,nump,ihadro(nump)
4095 else
4096 kes=kes-1
4097 nump=nump+1
4098 ihadro(nump)=-130
4099 if(wri)write(ifch,f1)keu,ked,kes,kec,nump,ihadro(nump)
4100 endif
4101 goto7
4102 endif
4103
4104 if(keu+ked+kes+kec.ne.ke)call utstop('hnbmin: sum_kei /= ke&')
4105
4106 keq=keu+ked
4107
4108
4109 i=4
4110 2 i=i-1
4111 3 continue
4112 if((4-i)*kes.gt.(i-1)*keq)then
4113 kes=kes-i
4114 keq=keq-3+i
4115 nump=nump+1
4116 if(i.eq.3)ihadro(nump)=3331
4117 if(i.eq.2)ihadro(nump)=0330
4118 if(i.eq.1)ihadro(nump)=0030
4119 if(i.lt.3)then
4120 do j=1,3-i
4121 l=1+2*rangen()
4122 if(keu.gt.ked)l=1
4123 if(keu.lt.ked)l=2
4124 if(l.eq.1)keu=keu-1
4125 if(l.eq.2)ked=ked-1
4126 ihadro(nump)=ihadro(nump)+l*10**(4-j)
4127 enddo
4128 endif
4129 if(wri)write(ifch,f1)keu,ked,kes,kec,nump,ihadro(nump)
4130 if(kes.lt.0)call utstop('hnbmin: negative kes&')
4131 if(keq.lt.0)call utstop('hnbmin: negative keq&')
4132 goto3
4133 endif
4134 if(i.gt.1)goto2
4135
4136 if(keu+ked.ne.keq)call utstop('hnbmin: keu+ked /= keq&')
4137
4138
4139 i=4
4140 12 i=i-1
4141 13 continue
4142 if((4-i)*ked.gt.(i-1)*keu)then
4143 ked=ked-i
4144 keu=keu-3+i
4145 if(i.eq.3)then
4146 nump=nump+2
4147 ihadro(nump)=1220
4148 ihadro(nump-1)=-120
4149 else
4150 nump=nump+1
4151 if(i.eq.2)ihadro(nump)=1220
4152 if(i.eq.1)ihadro(nump)=1120
4153 endif
4154 if(wri)write(ifch,f1)keu,ked,kes,kec,nump,ihadro(nump)
4155 if(ked.lt.0)call utstop('hnbmin: negative ked&')
4156 if(keu.lt.0)call utstop('hnbmin: negative keu&')
4157 goto13
4158 endif
4159 if(i.gt.1)goto12
4160
4161 if(ked.ne.0)call utstop('hnbmin: ked .ne. 0&')
4162
4163
4164 9 continue
4165 if(keu.gt.0)then
4166 keu=keu-3
4167 nump=nump+2
4168 ihadro(nump)=1120
4169 ihadro(nump-1)=120
4170 if(wri)write(ifch,f1)keu,ked,kes,kec,nump,ihadro(nump)
4171 if(keu.lt.0)call utstop('hnbmin: negative keu&')
4172 goto9
4173 endif
4174
4175 if(keu.ne.0)call utstop('hnbmin: keu .ne. 0&')
4176
4177 if(isi.eq.-1)then
4178 do i=1,nump
4179 ihadro(i)=isi*ihadro(i)
4180 enddo
4181 endif
4182
4183 do lo=1,2
4184 if(nump.lt.2)then
4185 nump=nump+1
4186 ihadro(nump)=110
4187 if(wri)write(ifch,f1)keu,ked,kes,kec,nump,ihadro(nump)
4188 endif
4189 enddo
4190
4191 if(wri)write(ifch,*)('-',i=1,30)
4192 *,' exit sr hnbmin ',('-',i=1,10)
4193 return
4194 end
4195
4196
4197 subroutine hnbody
4198
4199
4200
4201
4202
4203
4204
4205
4206
4207
4208
4209
4210
4211
4212
4213
4214
4215
4216
4217
4218
4219
4220
4221
4222 include 'epos.inc'
4223 parameter(maxp=500)
4224 common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
4225 dimension emm(maxp)
4226 dimension rno(3*maxp-4)
4227
4228 dimension em(maxp),pd(maxp),ems(maxp),sm(maxp)
4229 *,pcm1(5*maxp)
4230 common/cffq/ffqlog(maxp)
4231 common/ciiw/iii,rrr
4232 equivalence (nt,np),(amass(1),em(1)),(pcm1(1),pcm(1,1))
4233 logical wri
4234 data twopi/6.2831853073/
4235 external hnbiiw
4236
4237 wri=.false.
4238 if(ish.ge.7)wri=.true.
4239 if(wri)then
4240 write(ifch,*)('-',i=1,10)
4241 *,' entry sr hnbody ',('-',i=1,30)
4242 write(ifch,1200)np,tecm
4243 write(ifch,*)'particle masses:'
4244 write(ifch,'(1x,10f6.3)')(amass(n),n=1,np)
4245 endif
4246
4247
4248
4249 ktnbod=ktnbod + 1
4250 if(ktnbod.le.1)then
4251 !... ffq(n) = pi * (twopi)**(n-2) / (n-2)!
4252 ffqlog(1)=-1e35
4253 ffqlog(2)=alog(pi)
4254 do n=3,maxp
4255 ffqlog(n)=ffqlog(n-1)+log(twopi/(n-2))
4256 enddo
4257 endif
4258
4259 if(nt.lt.2) goto 1001
4260 if(nt.gt.maxp) goto 1002
4261 ntm1=nt-1
4262 ntm2=nt-2
4263 ntnm4=3*nt - 4
4264 emm(1)=em(1)
4265 tm=0.0
4266 do 2 i=1,nt
4267 ems(i)=em(i)**2
4268 tm=tm+em(i)
4269 2 sm(i)=tm
4270 tecmtm=tecm-tm
4271 if(tecmtm.le.0.0) goto 1000
4272 emm(nt)=tecm
4273 wtmlog=alog(tecmtm)*ntm2 + ffqlog(nt) - alog(tecm)
4274
4275
4276
4277 do 3 i= 1, ntnm4
4278 3 rno(i)=rangen()
4279 if(ntm2) 9,5,4
4280 4 continue
4281 call flpsore(rno,ntm2)
4282
4283
4284
4285 do 6 j=2,ntm1
4286 6 emm(j)=rno(j-1)*tecmtm+sm(j)
4287
4288
4289
4290 5 continue
4291 wtxlog=wtmlog
4292 ir=ntm2
4293 do 7 i=1,ntm1
4294 pd(i)=hnbpdk(emm(i+1),emm(i),em(i+1))
4295 if(pd(i).gt.0.)then
4296 pdlog=alog(pd(i))
4297 else
4298 pdlog=-1e35
4299 endif
4300 wtxlog=wtxlog+pdlog
4301 7 continue
4302
4303
4304
4305 pcm(1,1)=0.0
4306 pcm(2,1)=pd(1)
4307 pcm(3,1)=0.0
4308 do i=2,nt
4309 pcm(1,i)=0.0
4310 pcm(2,i)=-pd(i-1)
4311 pcm(3,i)=0.0
4312 ir=ir+1
4313 bang=twopi*rno(ir)
4314 cb=cos(bang)
4315 sb=sin(bang)
4316 ir=ir+1
4317 c=2.0*rno(ir)-1.0
4318 s=sqrt(1.0-c*c)
4319 if(i.ne.nt)then
4320 esys=sqrt(pd(i)**2+emm(i)**2)
4321 beta=pd(i)/esys
4322 gama=esys/emm(i)
4323 do j=1,i
4324 ndx=5*j - 5
4325 aa= pcm1(ndx+1)**2 + pcm1(ndx+2)**2 + pcm1(ndx+3)**2
4326 pcm1(ndx+5)=sqrt(aa)
4327 pcm1(ndx+4)=sqrt(aa+ems(j))
4328 call hnbrt2(c,s,cb,sb,pcm,j)
4329 psave=gama*(pcm(2,j)+beta*pcm(4,j))
4330 pcm(2,j)=psave
4331 enddo
4332 else !(i.eq.nt)
4333 do j=1,i
4334 aa=pcm(1,j)**2 + pcm(2,j)**2 + pcm(3,j)**2
4335 pcm(5,j)=sqrt(aa)
4336 pcm(4,j)=sqrt(aa+ems(j))
4337 call hnbrt2(c,s,cb,sb,pcm,j)
4338 enddo
4339 endif
4340 enddo
4341
4342
4343
4344 9 continue
4345 goto1111
4346
4347 1000 continue
4348 if(wri)
4349 *write(ifch,*)'available energy zero or negative -> wtxlog=-1e35'
4350 wtxlog=-1e35
4351 goto1111
4352
4353 1001 continue
4354 if(wri)
4355 *write(ifch,*)'less than 2 outgoing particles -> wtxlog=-1e35'
4356 wtxlog=-1e35
4357 goto1111
4358
4359 1002 continue
4360 write(ifch,*)'too many outgoing particles'
4361 write(ifch,1150) ktnbod
4362 1150 format(47h0 above error detected in hnbody at call number,i7)
4363 write(ifch,1200) np,tecm
4364 1200 format(' np:',i6/' tecm:',f10.5)
4365 write(ifch,*)'particle masses:'
4366 write(ifch,'(1x,10f6.3)')(amass(jk),jk=1,np)
4367 stop
4368
4369 1111 continue
4370 if(wri)write(ifch,*)('-',i=1,30)
4371 *,' exit sr hnbody ',('-',i=1,10)
4372 return
4373 end
4374
4375
4376 SUBROUTINE FLPSORE(A,N)
4377
4378
4379
4380
4381
4382
4383
4384
4385
4386 DIMENSION A(N)
4387 COMMON /SLATE/ LT(20),RT(20)
4388 INTEGER R,RT
4389
4390 LEVEL=1
4391 LT(1)=1
4392 RT(1)=N
4393 10 L=LT(LEVEL)
4394 R=RT(LEVEL)
4395 LEVEL=LEVEL-1
4396 20 IF(R.GT.L) GO TO 200
4397 IF(LEVEL) 50,50,10
4398
4399
4400
4401
4402
4403
4404
4405 200 I=L
4406 J=R
4407 M=(L+R)/2
4408 X=A(M)
4409 220 IF(A(I).GE.X) GO TO 230
4410 I=I+1
4411 GO TO 220
4412 230 IF(A(J).LE.X) GO TO 231
4413 J=J-1
4414 GO TO 230
4415
4416 231 IF(I.GT.J) GO TO 232
4417 W=A(I)
4418 A(I)=A(J)
4419 A(J)=W
4420 I=I+1
4421 J=J-1
4422 IF(I.LE.J) GO TO 220
4423
4424 232 LEVEL=LEVEL+1
4425 IF((R-I).GE.(J-L)) GO TO 30
4426 LT(LEVEL)=L
4427 RT(LEVEL)=J
4428 L=I
4429 GO TO 20
4430 30 LT(LEVEL)=I
4431 RT(LEVEL)=R
4432 R=J
4433 GO TO 20
4434 50 continue
4435
4436 do i=1,n-1
4437 if(a(i).gt.a(i+1))stop'FLPSORE: ERROR. '
4438 enddo
4439
4440 RETURN
4441 END
4442
4443
4444
4445
4446
4447
4448 subroutine hnbodz
4449
4450
4451
4452
4453
4454
4455
4456
4457
4458
4459
4460
4461
4462
4463
4464
4465
4466
4467
4468
4469
4470 include 'epos.inc'
4471 parameter(maxp=500)
4472 common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
4473 common /clatt/nlattc,npmax
4474 common/cffq/ffqlog(maxp)
4475 dimension ti(maxp),xi(maxp),si(maxp),zi(maxp)
4476 common/crnoz/rnoz(maxp-1)
4477 double precision ps(5)
4478
4479 call utpri('hnbodz',ish,ishini,6)
4480 if(ish.ge.6)write(ifch,1200)np,tecm
4481 if(ish.ge.6)write(ifch,*)'particle masses:'
4482 if(ish.ge.6)write(ifch,'(1x,10f6.3)')(amass(n),n=1,np)
4483
4484
4485 ktnbod=ktnbod + 1
4486 if(ktnbod.gt.1) goto 1
4487
4488 ffqlog(1)=alog(4*pi)
4489 do n=2,maxp
4490 ffqlog(n)=ffqlog(n-1)+alog(4*pi/(n-1))
4491 enddo
4492 1 continue
4493
4494 if(np.lt.2) goto 1001
4495
4496 if(np.eq.2)then
4497 if(tecm.lt.amass(1)+amass(2)+0.00001)goto1000
4498 p0=utpcm(tecm,amass(1),amass(2))
4499 wtxlog=alog( 4*pi*p0
4500 */(1/sqrt(amass(1)**2+p0**2)+1/sqrt(amass(2)**2+p0**2)) )
4501 if(ish.ge.7)
4502 *write(ifch,*)'wtxlog:',wtxlog,' (np=2 treatment)'
4503 bang=2*pi*rangen()
4504 cb=cos(bang)
4505 sb=sin(bang)
4506 c=2.0*rangen()-1.0
4507 s=sqrt(1.0-c*c)
4508 do 9 i=1,2
4509 is=2*i-3
4510 pcm(5,i)=p0
4511 pcm(1,i)=is*pcm(5,i)*s*cb
4512 pcm(2,i)=is*pcm(5,i)*s*sb
4513 pcm(3,i)=is*pcm(5,i)*c
4514 pcm(4,i)=sqrt(amass(i)**2+p0**2)
4515 9 continue
4516 goto1111
4517 endif
4518
4519 if(np.gt.maxp) goto 1002
4520
4521 tm=0.0
4522 do 2 i=1,np
4523 tm=tm+amass(i)
4524 2 continue
4525 tt=tecm-tm
4526 if(tt.le.0.0) goto 1000
4527
4528 wtxlog=alog(tt)*(np-1) + ffqlog(np)
4529 if(ish.ge.7)
4530 *write(ifch,*)'wtxlog:',wtxlog,' (prefactor)'
4531
4532 if(keepr.eq.0)then
4533 do 3 i= 1, np-1
4534 3 rnoz(i)=rangen()
4535 else
4536 do lo=1,iomom
4537 j=1+rangen()*nlattc
4538 rnoz(j)=rangen()
4539 enddo
4540 endif
4541
4542 do i= 1, np-1
4543 zi(i)=rnoz(i)**(1./i)
4544 enddo
4545
4546 xi(np)=1
4547 do i=np-1,1,-1
4548 xi(i)=zi(i)*xi(i+1)
4549 enddo
4550
4551 if(ish.ge.9)write(ifch,*)'calculate t_i, e_i, p_i ...'
4552 do i=1,np-1
4553 si(i)=xi(i)*tt
4554 enddo
4555 ti(1)=si(1)
4556 if(ti(1).le.0.)ti(1)=1e-10
4557 ti(np)=tt-si(np-1)
4558 if(ti(np).le.0.)ti(np)=1e-10
4559 do i=np-1,2,-1
4560 ti(i)=si(i)-si(i-1)
4561 if(ti(i).le.0.)ti(i)=1e-10
4562 enddo
4563 do i=1,np
4564 pcm(1,i)=0
4565 pcm(2,i)=0
4566 pcm(3,i)=0
4567 pcm(4,i)=ti(i)+amass(i)
4568 p52=ti(i)*(ti(i)+2*amass(i))
4569 if(p52.gt.0)then
4570 pcm(5,i)=sqrt(p52)
4571 else
4572 pcm(5,i)=ti(i)*sqrt(1+2*amass(i)/ti(i))
4573 endif
4574 enddo
4575
4576 call hnbraw(7,200,w)
4577 if(w.gt.0.)then
4578 wtxlog=wtxlog+alog(w)
4579 else
4580 wtxlog=wtxlog-1e+30
4581 endif
4582 do 7 i=1,np
4583 wtxlog=wtxlog+alog(pcm(5,i))+alog(ti(i)+amass(i))
4584 7 continue
4585 if(ish.ge.7)
4586 *write(ifch,*)'wtxlog:',wtxlog
4587
4588 if(ish.ge.7)then
4589 write(ifch,*)'momenta:'
4590 do j=1,4
4591 ps(j)=0
4592 enddo
4593 do i=1,np
4594 do j=1,4
4595 ps(j)=ps(j)+pcm(j,i)
4596 enddo
4597 write(ifch,'(1x,i3,5x,5f12.5)')i,(pcm(j,i),j=1,5)
4598 enddo
4599 ps(5)=dsqrt(ps(1)**2+ps(2)**2+ps(3)**2)
4600 write(ifch,'(1x,a4,8x,5f12.5)')'sum:',(sngl(ps(j)),j=1,5)
4601 endif
4602 if(w.le.0.)goto1111
4603
4604 call hnbrot
4605 if(ish.ge.7)write(ifch,*)'momenta after rotations:'
4606 call hnbrop(96,0)
4607 call hnbrod
4608 if(ish.ge.7)write(ifch,*)'momenta after deformations:'
4609 call hnbrop(96,1)
4610 goto1111
4611
4612
4613 1000 continue
4614 if(ish.ge.6)
4615 *write(ifch,*)'available energy zero or negative -> wtxlog=-1e35'
4616 wtxlog=-1e35
4617 goto1111
4618
4619 1001 continue
4620 if(ish.ge.6)
4621 *write(ifch,*)'less than 2 outgoing particles -> wtxlog=-1e35'
4622 wtxlog=-1e35
4623 goto1111
4624
4625 1002 continue
4626 write(ifch,*)'too many outgoing particles'
4627 write(ifch,1150) ktnbod
4628 1150 format(47h0 above error detected in hnbody at call number,i7)
4629 write(ifch,1200) np,tecm
4630 1200 format(' np:',i6/' tecm:',f10.5)
4631 write(ifch,*)'particle masses:'
4632 write(ifch,'(1x,10f6.3)')(amass(jk),jk=1,np)
4633 stop
4634
4635 1111 continue
4636 call utprix('hnbodz',ish,ishini,6)
4637 return
4638 end
4639
4640
4641 subroutine hnbolo(loops)
4642
4643
4644
4645 include 'epos.inc'
4646 parameter(maxp=500)
4647 common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
4648 a=0
4649 k=0
4650 do j=1,loops
4651
4652 if(iocova.eq.1)call hnbody
4653 if(iocova.eq.2)call hnbodz
4654 if(ish.ge.8)write(ifch,*)'j:',j,' wtxlog:',wtxlog
4655 if(wtxlog.gt.-1e30)then
4656 k=k+1
4657 if(k.eq.1)c=wtxlog
4658 if(a.gt.0.)then
4659 if(alog(a).lt.wtxlog-c-20)then
4660 a=0
4661 c=wtxlog
4662 endif
4663 endif
4664 a=a+exp(wtxlog-c)
4665 endif
4666 if(ish.ge.8)write(ifch,*)'k:',k,' c:',c
4667 enddo
4668 a=a/loops
4669 wtxlog=alog(a)+c
4670 return
4671 end
4672
4673
4674 function hnbpdk(a,b,c)
4675
4676
4677
4678
4679
4680
4681
4682 double precision aa,bb,cc,a2,b2,c2
4683 aa=a
4684 bb=b
4685 cc=c
4686 a2=aa*aa
4687 b2=bb*bb
4688 c2=cc*cc
4689 if(a2 + (b2-c2)**2/a2-2.0*(b2+c2).le.0.)then
4690 hnbpdk = 0
4691 else
4692 hnbpdk = 0.5*dsqrt(a2 + (b2-c2)**2/a2 - 2.0*(b2+c2))
4693 endif
4694 return
4695 end
4696
4697
4698 subroutine hnbpad(k,n1,n2,n3,n4,mm,jc)
4699
4700
4701
4702
4703
4704 include 'epos.inc'
4705 integer jc(nflav,2),ic(2),jc1(nflav,2),ic1(2),jc2(nflav,2),ic2(2)
4706 common /clatt/nlattc,npmax
4707 parameter(maxp=500)
4708 common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
4709
4710 k1=n1
4711 k2=n2
4712
4713
4714
4715 1 continue
4716 n1=1+rangen()*nlattc
4717 n1=min(n1,nlattc)
4718 2 continue
4719 n2=1+rangen()*nlattc
4720 n2=min(n2,nlattc)
4721 if(n2.eq.n1)goto2
4722 if(n2.lt.n1)then
4723 n1r=n1
4724 n1=n2
4725 n2=n1r
4726 endif
4727 if(k.eq.2)then
4728 if(n1.eq.k1.or.n1.eq.k2.or.n2.eq.k1.or.n2.eq.k2)goto1
4729 endif
4730 if(ident(n1).ne.0.and.ident(n2).ne.0)mm=1 ! hadron-hadron
4731 if(ident(n1).ne.0.and.ident(n2).eq.0)mm=2 ! hadron-empty
4732 if(ident(n1).eq.0.and.ident(n2).ne.0)mm=2 ! empty-hadron
4733 if(ident(n1).eq.0.and.ident(n2).eq.0)mm=3 ! empty-empty
4734 if(ish.ge.7)then
4735 write(ifch,'(a,i2)')' mm:',mm
4736 write(ifch,*)'to be replaced:',n1,ident(n1)
4737 write(ifch,*)'to be replaced:',n2,ident(n2)
4738 endif
4739
4740
4741
4742 if(mm.eq.1)then
4743 call idtr4(ident(n1),ic1)
4744 call iddeco(ic1,jc1)
4745 call idtr4(ident(n2),ic2)
4746 call iddeco(ic2,jc2)
4747 do i=1,nflav
4748 do j=1,2
4749 jc(i,j)=jc1(i,j)+jc2(i,j)
4750 enddo
4751 enddo
4752 elseif(mm.eq.2.and.ident(n1).ne.0)then
4753 call idtr4(ident(n1),ic)
4754 call iddeco(ic,jc)
4755 elseif(mm.eq.2.and.ident(n2).ne.0)then
4756 call idtr4(ident(n2),ic)
4757 call iddeco(ic,jc)
4758 else
4759 do i=1,nflav
4760 do j=1,2
4761 jc(i,j)=0
4762 enddo
4763 enddo
4764 endif
4765
4766 if(k.eq.2)then
4767 n3=n1
4768 n4=n2
4769 endif
4770
4771 return
4772 end
4773
4774
4775 subroutine hnbpai(id1,id2,jc)
4776
4777
4778
4779 include 'epos.inc'
4780 integer jc(nflav,2),jc1(nflav,2),ic1(2),jc2(nflav,2),ic2(2)
4781 parameter (mspecs=56)
4782 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
4783
4784
4785
4786 i1=rangen()*(nspecs+iozero)-(iozero-1)
4787 i1=max(i1,0)
4788 i1=min(i1,nspecs)
4789 if(i1.eq.0)then
4790 id1=0
4791 do i=1,nflav
4792 do j=1,2
4793 jc1(i,j)=0
4794 enddo
4795 enddo
4796 else
4797 id1=ispecs(i1)
4798 call idtr4(id1,ic1)
4799 call iddeco(ic1,jc1)
4800 endif
4801 if(ish.ge.7)write(ifch,'(1x,a,i3,a,i5,a,6i2,3x,6i2)')
4802 *'i1:',i1,' id1:',id1,' jc1:',jc1
4803 i2=rangen()*(nspecs+iozero)-(iozero-1)
4804 i2=max(i2,0)
4805 i2=min(i2,nspecs)
4806 if(i2.eq.0)then
4807 id2=0
4808 do i=1,nflav
4809 do j=1,2
4810 jc2(i,j)=0
4811 enddo
4812 enddo
4813 else
4814 id2=ispecs(i2)
4815 call idtr4(id2,ic2)
4816 call iddeco(ic2,jc2)
4817 endif
4818 if(ish.ge.7)write(ifch,'(1x,a,i3,a,i5,a,6i2,3x,6i2)')
4819 *'i2:',i2,' id2:',id2,' jc2:',jc2
4820 if(ish.ge.7)write(ifch,'(a,i6,i6)')' pair:',id1,id2
4821
4822
4823
4824 do i=1,nflav
4825 do j=1,2
4826 jc(i,j)=jc1(i,j)+jc2(i,j)
4827 enddo
4828 enddo
4829 do i=1,nflav
4830 j12=jc(i,1)-jc(i,2)
4831 if(j12.ge.0)then
4832 jc(i,1)=j12
4833 jc(i,2)=0
4834 else
4835 jc(i,1)=0
4836 jc(i,2)=-j12
4837 endif
4838 enddo
4839 if(ish.ge.7)write(ifch,'(a,6i2,3x,6i2)')' jc:',jc
4840
4841 return
4842 end
4843
4844
4845 subroutine hnbpaj(jc,iwpair,id1,id2)
4846
4847
4848
4849
4850 include 'epos.inc'
4851 parameter(mspecs=56,mxids=200)
4852 parameter(mxpair=mspecs**2*4)
4853 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
4854 common/cspec2/jspecs(2,nflav,mspecs)
4855 common/cspec3/lkfok(8,-3:3,-3:3,-3:3,-3:3) !-charm
4856 common/cspec5/idpairst(2,mxpair,3**6),iwtpaist(0:mxpair,3**6)
4857 & ,idxpair(0:2,0:2,0:2,-1:1,-1:1,-1:1),ipairst(3**6)
4858 common/cflac/ifok(nflav,mspecs),ifoa(nflav)
4859 dimension ids(mxids),iwts(mxids),jc(nflav,2)!,jc2(nflav,2)
4860 dimension idpair(2,mxpair),iwtpai(mxpair)
4861 dimension jc1mi2(nflav),jcmi(nflav)
4862
4863
4864
4865
4866
4867
4868
4869
4870 ipair=0
4871 iwpair=0
4872 idx=0
4873 if(jc(1,1).gt.2)then
4874 goto 1
4875 elseif(jc(1,1).lt.0)then
4876 goto 1
4877 elseif(jc(2,1).gt.2)then
4878 goto 1
4879 elseif(jc(2,1).lt.0)then
4880 goto 1
4881 elseif(jc(3,1).gt.2)then
4882 goto 1
4883 elseif(jc(3,1).lt.0)then
4884 goto 1
4885 elseif(jc(1,2).gt.1)then
4886 goto 1
4887 elseif(jc(1,2).lt.-1)then
4888 goto 1
4889 elseif(jc(2,2).gt.1)then
4890 goto 1
4891 elseif(jc(2,2).lt.-1)then
4892 goto 1
4893 elseif(jc(3,2).gt.1)then
4894 goto 1
4895 elseif(jc(3,2).lt.-1)then
4896 goto 1
4897 elseif((abs(jc(4,1))+abs(jc(5,1))+abs(jc(6,1))+abs(jc(4,2))
4898 & +abs(jc(5,2))+abs(jc(6,2))).gt.0)then
4899 goto 1
4900 endif
4901 idx=idxpair(jc(1,1),jc(2,1),jc(3,1),jc(1,2),jc(2,2),jc(3,2))
4902 ipair=ipairst(idx)
4903 if(ipair.eq.0)return
4904 iwpair=iwtpaist(0,idx)
4905 do i=1,ipair
4906 idpair(1,i)=idpairst(1,i,idx)
4907 idpair(2,i)=idpairst(2,i,idx)
4908 iwtpai(i)=iwtpaist(i,idx)
4909 enddo
4910 goto 4 !pair fixed via table
4911
4912
4913 1 continue
4914 if(nspecs+1.gt.mxids)call utstop('hnbpaj: mxids too small&')
4915
4916 jc1mi2(1)=jc(1,1)-jc(1,2)
4917 jc1mi2(2)=jc(2,1)-jc(2,2)
4918 jc1mi2(3)=jc(3,1)-jc(3,2)
4919 jc1mi2(4)=jc(4,1)-jc(4,2)
4920 jc1mi2(5)=jc(5,1)-jc(5,2)
4921 jc1mi2(6)=jc(6,1)-jc(6,2)
4922
4923 nids=0
4924
4925 if(jc1mi2(1).ne.0)goto11
4926 if(jc1mi2(2).ne.0)goto11
4927 if(jc1mi2(3).ne.0)goto11
4928 if(jc1mi2(4).ne.0)goto11
4929 if(jc1mi2(5).ne.0)goto11
4930 if(jc1mi2(6).ne.0)goto11
4931 nids=nids+1
4932 ids(nids)=0
4933 iwts(nids)=iozero
4934 11 continue
4935
4936 do j=1,nspecs
4937 if(jc1mi2(1).ne.ifok(1,j))goto22
4938 if(jc1mi2(2).ne.ifok(2,j))goto22
4939 if(jc1mi2(3).ne.ifok(3,j))goto22
4940 if(jc1mi2(4).ne.ifok(4,j))goto22
4941 if(jc1mi2(5).ne.ifok(5,j))goto22
4942 if(jc1mi2(6).ne.ifok(6,j))goto22
4943 nids=nids+1
4944 ids(nids)=ispecs(j)
4945 iwts(nids)=1
4946 22 continue
4947 enddo
4948
4949 if(nids.eq.0)goto2
4950 if(nids.gt.mxpair)call utstop('hnbpaj: mxpair too small&')
4951 do k=1,nids
4952 ipair=ipair+1
4953 idpair(1,ipair)=0
4954 idpair(2,ipair)=ids(k)
4955 iwtpai(ipair)=iozero*iwts(k)
4956 iwpair=iwpair+iwtpai(ipair)
4957
4958
4959 enddo
4960 2 continue
4961
4962
4963
4964 do i1=1,nspecs
4965
4966
4967
4968
4969
4970
4971
4972
4973
4974
4975
4976
4977 jcmi(1)=jc1mi2(1)-jspecs(1,1,i1)+jspecs(2,1,i1)
4978 jcmi(2)=jc1mi2(2)-jspecs(1,2,i1)+jspecs(2,2,i1)
4979 jcmi(3)=jc1mi2(3)-jspecs(1,3,i1)+jspecs(2,3,i1)
4980 jcmi(4)=jc1mi2(4)-jspecs(1,4,i1)+jspecs(2,4,i1)
4981 jcmi(5)=jc1mi2(5)-jspecs(1,5,i1)+jspecs(2,5,i1)
4982 jcmi(6)=jc1mi2(6)-jspecs(1,6,i1)+jspecs(2,6,i1)
4983
4984 if(jcmi(5).ne.0)stop'HNBPAJ: b not treated'
4985 if(jcmi(6).ne.0)stop'HNBPAJ: t not treated'
4986
4987 nids=0
4988
4989 if(abs(jcmi(1)).gt.3)goto3
4990 if(abs(jcmi(2)).gt.3)goto3
4991 if(abs(jcmi(3)).gt.3)goto3
4992 if(abs(jcmi(4)).gt.3)goto3 !-charm
4993
4994 if(jcmi(1).ne.0)goto111
4995 if(jcmi(2).ne.0)goto111
4996 if(jcmi(3).ne.0)goto111
4997 if(jcmi(4).ne.0)goto111 !-charm
4998 nids=nids+1
4999 ids(nids)=0
5000 iwts(nids)=iozero
5001 111 continue
5002
5003 lkfok1=lkfok(1,jcmi(1),jcmi(2),jcmi(3),jcmi(4))
5004 if(lkfok1.gt.0)then
5005 nids=nids+1
5006 ids(nids)=lkfok(2,jcmi(1),jcmi(2),jcmi(3),jcmi(4))
5007 iwts(nids)=1
5008 if(lkfok1.gt.1)then
5009 nids=nids+1
5010 ids(nids)=lkfok(3,jcmi(1),jcmi(2),jcmi(3),jcmi(4))
5011 iwts(nids)=1
5012 if(lkfok1.gt.2)then
5013 if(lkfok1.gt.7) !-charm
5014 * stop'HNBPAJ: dimension of lkfok too small'
5015 do ii=3,lkfok1
5016 nids=nids+1
5017 ids(nids)=lkfok(1+ii,jcmi(1),jcmi(2),jcmi(3),jcmi(4))
5018 iwts(nids)=1
5019 enddo
5020 endif
5021 endif
5022 endif
5023
5024
5025
5026
5027
5028
5029
5030
5031
5032
5033
5034
5035
5036
5037 if(nids.eq.0)goto3
5038 if(ipair+nids.gt.mxpair)call utstop('hnbpaj: mxpair too small&')
5039 do k=1,nids
5040 ipair=ipair+1
5041 idpair(1,ipair)=ispecs(i1)
5042 idpair(2,ipair)=ids(k)
5043 iwtpai(ipair)=iwts(k)
5044 iwpair=iwpair+iwtpai(ipair)
5045 enddo
5046 if(ish.ge.7)then
5047 ipair0=ipair-nids
5048 do k=1,nids
5049 ipair0=ipair0+1
5050 write(ifch,'(a,i5,5x,a,i6,i6,5x,a,i6)')' pair nr:'
5051 *,ipair0,'ids:',ispecs(i1),ids(k),'weight:',iwtpai(ipair0)
5052 enddo
5053 endif
5054 3 continue
5055
5056 enddo
5057
5058
5059
5060 if(ipair.eq.0)then
5061 if(iwpair.ne.0)call utstop('hnbpaj: iwpair.ne.0&')
5062 return
5063 endif
5064
5065
5066 4 continue
5067
5068
5069 r=rangen()
5070 ir=1+r*iwpair
5071 ir=min(ir,iwpair)
5072 is=0
5073 do ip=1,ipair
5074 is=is+iwtpai(ip)
5075 if(ir.le.is)then
5076 id1=idpair(1,ip)
5077 id2=idpair(2,ip)
5078
5079
5080 goto 1000
5081 endif
5082 enddo
5083 write(ifmt,*)'hnbpaj:',jc,idx,ipair,iwpair,r,ir
5084 call utstop('hnbpaj: no pair selected&')
5085
5086 1000 continue
5087
5088 return
5089 end
5090
5091
5092 subroutine hnbpajini
5093
5094
5095
5096
5097
5098 include 'epos.inc'
5099 parameter(mspecs=56,mxids=200)
5100 parameter(mxpair=mspecs**2*4)
5101 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
5102 common/cspec2/jspecs(2,nflav,mspecs)
5103 common/cspec3/lkfok(8,-3:3,-3:3,-3:3,-3:3) !-charm
5104 common/cspec5/idpairst(2,mxpair,3**6),iwtpaist(0:mxpair,3**6)
5105 & ,idxpair(0:2,0:2,0:2,-1:1,-1:1,-1:1),ipairst(3**6)
5106 common/cflac/ifok(nflav,mspecs),ifoa(nflav)
5107 dimension ids(mxids),iwts(mxids)
5108 dimension jc1mi2(3),jcmi(4)
5109
5110
5111
5112
5113
5114
5115 idx=0
5116 do iaqs=-1,1
5117 do iaqd=-1,1
5118 do iaqu=-1,1
5119 do iqs=0,2
5120 do iqd=0,2
5121 do iqu=0,2
5122
5123 idx=idx+1
5124 idxpair(iqu,iqd,iqs,iaqu,iaqd,iaqs)=idx
5125
5126 ipair=0
5127 iwtpaist(0,idx)=0
5128 do i=1,mxids
5129 ids(i)=0
5130 iwts(i)=0
5131 enddo
5132 do i=1,mxpair
5133 idpairst(1,i,idx)=0
5134 idpairst(2,i,idx)=0
5135 iwtpaist(i,idx)=0
5136 enddo
5137
5138
5139
5140 if(nspecs+1.gt.mxids)call utstop('hnbpajini: mxids too small&')
5141
5142 jc1mi2(1)=iqu-iaqu
5143 jc1mi2(2)=iqd-iaqd
5144 jc1mi2(3)=iqs-iaqs
5145
5146 nids=0
5147
5148 if(jc1mi2(1).ne.0)goto11
5149 if(jc1mi2(2).ne.0)goto11
5150 if(jc1mi2(3).ne.0)goto11
5151 nids=nids+1
5152 ids(nids)=0
5153 iwts(nids)=iozero
5154 11 continue
5155
5156 do j=1,nspecs
5157 if(jc1mi2(1).ne.ifok(1,j))goto22
5158 if(jc1mi2(2).ne.ifok(2,j))goto22
5159 if(jc1mi2(3).ne.ifok(3,j))goto22
5160 nids=nids+1
5161 ids(nids)=ispecs(j)
5162 iwts(nids)=1
5163 22 continue
5164 enddo
5165
5166 if(nids.eq.0)goto2
5167 if(nids.gt.mxpair)call utstop('hnbpajini: mxpair too small&')
5168 do k=1,nids
5169 ipair=ipair+1
5170 idpairst(1,ipair,idx)=0
5171 idpairst(2,ipair,idx)=ids(k)
5172 iwtpaist(ipair,idx)=iozero*iwts(k)
5173 iwtpaist(0,idx)=iwtpaist(0,idx)+iwtpaist(ipair,idx)
5174
5175
5176 enddo
5177 2 continue
5178
5179
5180
5181 do i1=1,nspecs
5182
5183
5184
5185
5186
5187
5188
5189
5190
5191
5192
5193
5194 jcmi(1)=jc1mi2(1)-jspecs(1,1,i1)+jspecs(2,1,i1)
5195 jcmi(2)=jc1mi2(2)-jspecs(1,2,i1)+jspecs(2,2,i1)
5196 jcmi(3)=jc1mi2(3)-jspecs(1,3,i1)+jspecs(2,3,i1)
5197 jcmi(4)=0
5198
5199 nids=0
5200
5201 if(abs(jcmi(1)).gt.3)goto3
5202 if(abs(jcmi(2)).gt.3)goto3
5203 if(abs(jcmi(3)).gt.3)goto3
5204
5205 if(jcmi(1).ne.0)goto111
5206 if(jcmi(2).ne.0)goto111
5207 if(jcmi(3).ne.0)goto111
5208 nids=nids+1
5209 ids(nids)=0
5210 iwts(nids)=iozero
5211 111 continue
5212
5213 lkfok1=lkfok(1,jcmi(1),jcmi(2),jcmi(3),jcmi(4))
5214 if(lkfok1.gt.0)then
5215 nids=nids+1
5216 ids(nids)=lkfok(2,jcmi(1),jcmi(2),jcmi(3),jcmi(4))
5217 iwts(nids)=1
5218 if(lkfok1.gt.1)then
5219 nids=nids+1
5220 ids(nids)=lkfok(3,jcmi(1),jcmi(2),jcmi(3),jcmi(4))
5221 iwts(nids)=1
5222 if(lkfok1.gt.2)then
5223 if(lkfok1.gt.7) !-charm
5224 * stop'HNBPAJINI: dimension of lkfok too small'
5225 do ii=3,lkfok1
5226 nids=nids+1
5227 ids(nids)=lkfok(1+ii,jcmi(1),jcmi(2),jcmi(3),jcmi(4))
5228 iwts(nids)=1
5229 enddo
5230 endif
5231 endif
5232 endif
5233
5234
5235
5236
5237
5238
5239
5240
5241
5242
5243
5244
5245
5246
5247 if(nids.eq.0)goto3
5248 if(ipair+nids.gt.mxpair)
5249 & call utstop('hnbpajini: mxpair too small&')
5250 do k=1,nids
5251 ipair=ipair+1
5252 idpairst(1,ipair,idx)=ispecs(i1)
5253 idpairst(2,ipair,idx)=ids(k)
5254 iwtpaist(ipair,idx)=iwts(k)
5255 iwtpaist(0,idx)=iwtpaist(0,idx)+iwtpaist(ipair,idx)
5256 enddo
5257 ipairst(idx)=ipair
5258 3 continue
5259
5260 enddo
5261
5262
5263
5264 if(ipair.eq.0)then
5265 if(iwtpaist(0,idx).ne.0)call utstop('hnbpajini: iwpair.ne.0&')
5266 endif
5267
5268
5269 enddo
5270 enddo
5271 enddo
5272 enddo
5273 enddo
5274 enddo
5275
5276 return
5277 end
5278
5279
5280 subroutine hnbraw(npx,npy,w)
5281
5282
5283
5284
5285
5286
5287
5288
5289 include 'epos.inc'
5290 parameter(maxp=500)
5291 common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
5292 integer ii(maxp),isi(maxp)
5293 double precision ppcm(maxp),ww,ppsum,ppmax
5294 external hnbrax
5295 common/cepsr/nepsr
5296 if(ish.ge.9)write(ifch,*)('-',i=1,10)
5297 *,' entry sr hnbraw ',('-',i=1,30)
5298
5299 if(np.lt.3)call utstop('hnbraw: np must be at least 3&')
5300
5301 kper=5
5302 pi=3.1415927
5303 pmax=0
5304 do i=1,np
5305 pmax=pmax+pcm(5,i)
5306 enddo
5307 wio=0
5308 win=0
5309 whd=0
5310
5311
5312
5313 px=0
5314 ps=0
5315 do i=1,np
5316 px=max(px,pcm(5,i))
5317 ps=ps+pcm(5,i)
5318 enddo
5319 if(ps-2*px.le.0.)then
5320 w=0
5321 if(ish.ge.7)write(ifch,'(1x,a,e12.5,4x)')
5322 *'sum p_i - 2*p_max not positive --> w:',w
5323 goto1000
5324 endif
5325
5326
5327
5328 was=0
5329 do i=1,np
5330 was=was+pcm(5,i)**2
5331 enddo
5332 was=(was*2*pi/3)**(-1.5)
5333 if(ish.ge.7)write(ifch,'(1x,a,e12.5,4x)')
5334 *'asymptotic method: was:',was
5335
5336 if(np.gt.npy)then
5337 w=was
5338 goto1000
5339 endif
5340
5341 if(np.le.npx)goto9
5342
5343
5344
5345 if(ish.ge.9)write(ifch,*)'integral method...'
5346 itmax=8
5347 it=0
5348 b=pi*np*kper/pmax
5349 win=0
5350 nepsr=0
5351 3 continue
5352 it=it+1
5353 if(ish.ge.9)write(ifch,*)'it:',it
5354 b=b*5./3.
5355 wio=win
5356 call uttrap(hnbrax,0.,b,win)
5357 iok=0
5358 if(abs(win-wio).le.epsr*abs((win+wio)/2))iok=1
5359 if(it.eq.itmax)iok=1
5360 if(ish.ge.8.or.ish.ge.7.and.iok.eq.1)
5361 *write(ifch,'(1x,2(a,e12.5,2x),a,i2,2x,a,i4)')
5362 *'integral method: win:',win
5363 *,'upper limit:',b,'it:',it,'nepsr:',nepsr
5364 if(it.eq.itmax
5365 *.and.abs(win-wio).gt.epsr*abs((win+wio)/2))then
5366 nepsr=nepsr+1
5367 if(ish.ge.9)then
5368 call utmsg('hnbraw')
5369 write(ifch,*)
5370 *'***** requested accuracy could not be achieved'
5371 write(ifch,*)'achieved accuracy: '
5372 *,abs(win-wio)/abs((win+wio)/2)
5373 write(ifch,*)'requested accuracy:',epsr
5374 call utmsgf
5375 endif
5376 endif
5377 if(it.eq.1.or.iok.eq.0)goto3
5378
5379 if(nepsr.eq.0)then
5380 w=win
5381 goto1000
5382 endif
5383
5384 if(np.gt.20)then
5385 if(ish.ge.1)then
5386 call utmsg('hnbraw')
5387 write(ifch,*)
5388 * '***** requested accuracy could not be achieved'
5389 write(ifch,*)'achieved accuracy: '
5390 * ,abs(win-wio)/abs((win+wio)/2)
5391 write(ifch,*)'requested accuracy:',epsr
5392 call utmsgf
5393 endif
5394 w=win
5395 goto1000
5396 endif
5397
5398
5399
5400 9 continue
5401 ppmax=0
5402 do i=1,np
5403 ppcm(i)=pcm(5,i)
5404 ppmax=ppmax+ppcm(i)
5405 enddo
5406 ww=0
5407 do i=1,np
5408 ii(i)=0
5409 isi(i)=1
5410 enddo
5411 ppsum=ppmax
5412 i=0
5413 iprosi=1
5414 ww=iprosi*(ppsum/ppmax)**(np-3)
5415 if(ish.ge.8)
5416 *write(ifch,'(4x,i5,12x,f7.2,i5,f11.2)')np,sngl(ppsum)
5417 *,iprosi,sngl(ww)
5418 5 continue
5419 i=i+1
5420 if(i.gt.np)goto6
5421 if(ii(i).eq.1)goto5
5422 iprosi=-iprosi
5423 isi(i)=-isi(i)
5424 ppsum=ppsum+2*isi(i)*ppcm(i)
5425 if(ppsum.gt.0.or.ppsum.eq.0..and.isi(i).gt.0)then
5426 ww=ww+iprosi*(ppsum/ppmax)**(np-3)
5427 if(ish.ge.8)
5428 *write(ifch,'(4x,2i5,2f7.2,i5,f11.2)')
5429 *np,i,sngl(2*isi(i)*ppcm(i)),sngl(ppsum),iprosi,sngl(ww)
5430 else
5431 if(ish.ge.8)
5432 *write(ifch,'(4x,2i5,2f7.2,i5,4x,a)')
5433 *np,i,sngl(2*isi(i)*ppcm(i)),sngl(ppsum),iprosi,'not counted'
5434 endif
5435 ii(i)=1
5436 if(i.gt.1)then
5437 do j=1,i-1
5438 ii(j)=0
5439 enddo
5440 endif
5441 i=0
5442 goto5
5443 6 continue
5444 do i=1,np
5445 ww=ww*pmax/ppcm(i)/2./i
5446 enddo
5447 ww=-ww/pmax**3/pi/2.*np*(np-1)*(np-2)
5448 whd=ww
5449 if(ish.ge.7)write(ifch,'(1x,a,e12.5,4x,a)')
5450 *'hagedorn method: whd:',whd,'double precision'
5451
5452 w=whd
5453
5454 1000 continue
5455 if(ish.ge.9)write(ifch,*)('-',i=1,30)
5456 *,' exit sr hnbraw ',('-',i=1,10)
5457 return
5458 end
5459
5460
5461 function hnbrax(x)
5462
5463
5464
5465
5466
5467 parameter(maxp=500)
5468 common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
5469 common/cnsta/pi,pii,hquer,prom,piom,ainfin
5470 hnbrax= pii * x**2
5471 do i=1,np
5472 px=pcm(5,i)*x
5473 if(px.ne.0.)hnbrax=hnbrax*sin(px)/px
5474 enddo
5475 return
5476 end
5477
5478
5479 subroutine hnbrmz
5480
5481
5482
5483
5484 include 'epos.inc'
5485 parameter(maxp=500)
5486 common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
5487
5488 common /clatt/nlattc,npmax
5489 if(ish.ge.9)write(ifch,*)('-',i=1,10)
5490 *,' entry sr hnbrmz ',('-',i=1,30)
5491 if(np.eq.0)goto1000
5492
5493
5494
5495
5496
5497
5498 i=0
5499 np=nlattc+1
5500
5501 1 i=i+1
5502 if(i.gt.nlattc)then
5503 np=nlattc
5504 goto1000
5505 endif
5506 if(ident(i).ne.0)goto1
5507 2 np=np-1
5508 if(np.eq.0)goto1000
5509 if(ident(np).eq.0)goto2
5510
5511 if(ish.ge.9)then
5512 write(ifch,*)'ident:'
5513 write(ifch,'(1x,10i7)')(ident(j),j=1,nlattc)
5514 write(ifch,'(1x,a,i3,3x,a,i3)')'i:',i,'np:',np
5515 endif
5516
5517 if(i.eq.np+1)goto1000
5518
5519 ident(i)=ident(np)
5520 ident(np)=0
5521 goto1
5522
5523 1000 continue
5524 if(ish.ge.9)write(ifch,*)('-',i=1,30)
5525 *,' exit sr hnbrmz ',('-',i=1,10)
5526 end
5527
5528
5529 subroutine hnbrod
5530
5531
5532
5533
5534
5535
5536 include 'epos.inc'
5537 parameter(maxp=500)
5538 common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
5539 real x(3),y(3),z(3),w(3)
5540 if(ish.ge.8)write(ifch,*)'sr hnbrod: polygon deformation:'
5541
5542 err=0.01
5543
5544 kmax=1000
5545 fac=0.30
5546 x2max=(err*tecm)**2
5547
5548 if(ish.ge.8)write(ifch,'(a,i4,a,f12.6)')
5549 *' kmax:',kmax,' x2max:',x2max
5550
5551 x(1)=0
5552 x(2)=0
5553 x(3)=0
5554 do i=1,np
5555 x(1)=x(1)+pcm(1,i)
5556 x(2)=x(2)+pcm(2,i)
5557 x(3)=x(3)+pcm(3,i)
5558 enddo ! i
5559
5560 k=0
5561 1 continue
5562
5563 x2=x(1)**2+x(2)**2+x(3)**2
5564 if(ish.ge.8)write(ifch,'(a,i3,a,3f9.3,a,f12.6)')
5565 *' it',k,': x:',x,' x2:',x2
5566 if(x2.le.x2max)goto1000
5567 if(k.gt.kmax)goto1001
5568
5569 k=k+1
5570 ir=1+rangen()*np
5571 ir=min(ir,np)
5572
5573 z(1)=-x(1)
5574 z(2)=-x(2)
5575 z(3)=-x(3)
5576 x(1)=x(1)-pcm(1,ir)
5577 x(2)=x(2)-pcm(2,ir)
5578 x(3)=x(3)-pcm(3,ir)
5579 y(1)=pcm(1,ir)
5580 y(2)=pcm(2,ir)
5581 y(3)=pcm(3,ir)
5582 if(ish.ge.9)write(ifch,'(a,i3,a,3f9.3,a,3f9.3,a,i4)')
5583 *' it',k,': x:',x,' y:',y,' ir:',ir
5584 xxx=x(1)**2+x(2)**2+x(3)**2
5585 yyy=y(1)**2+y(2)**2+y(3)**2
5586 zzz=z(1)**2+z(2)**2+z(3)**2
5587 if(xxx.gt.0..and.yyy.gt.0..and.zzz.gt.0.)then
5588
5589 yy=sqrt(yyy)
5590 zz=sqrt(zzz)
5591 a=min(fac,fac*yy/zz)
5592 w(1)=y(1)+a*z(1)
5593 w(2)=y(2)+a*z(2)
5594 w(3)=y(3)+a*z(3)
5595 www=w(1)**2+w(2)**2+w(3)**2
5596 if(www.gt.0.)then
5597 ww=sqrt(www)
5598 y(1)=yy/ww*w(1)
5599 y(2)=yy/ww*w(2)
5600 y(3)=yy/ww*w(3)
5601 pcm(1,ir)=y(1)
5602 pcm(2,ir)=y(2)
5603 pcm(3,ir)=y(3)
5604 endif
5605 endif
5606 x(1)=x(1)+y(1)
5607 x(2)=x(2)+y(2)
5608 x(3)=x(3)+y(3)
5609 if(ish.ge.9)write(ifch,'(a,i3,a,3f9.3,a,3f9.3,a,i4)')
5610 *' it',k,': x:',x,' y:',y,' ir:',ir
5611
5612 goto1
5613
5614 1001 continue
5615 call utmsg('hnbrod')
5616 write(ifch,*)'***** total 3-momentum nonzero'
5617 write(ifch,'(3f12.5,5x,2f12.5)')(x(j),j=1,3),x2,x2max
5618 call utmsgf
5619
5620 1000 continue
5621 return
5622
5623 end
5624
5625
5626 subroutine hnbrop(ishx,ichk)
5627
5628
5629
5630 include 'epos.inc'
5631 parameter(maxp=500)
5632 common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
5633 double precision ps(5)
5634 err=0.01
5635 do j=1,4
5636 ps(j)=0
5637 enddo
5638 do i=1,np
5639 do j=1,4
5640 ps(j)=ps(j)+pcm(j,i)
5641 enddo
5642 if(ish.ge.ishx)write(ifch,'(1x,i3,5x,5f12.5)')i,(pcm(j,i),j=1,3)
5643 *,sqrt(pcm(1,i)**2+pcm(2,i)**2+pcm(3,i)**2),pcm(5,i)
5644 enddo
5645 ps(5)=dsqrt(ps(1)**2+ps(2)**2+ps(3)**2)
5646 if(ish.ge.ishx)write(ifch,'(1x,a4,8x,5f12.5)')
5647 *'sum:',(sngl(ps(j)),j=1,5)
5648 if(ichk.eq.1)then
5649 if(dabs(ps(1)).gt.err*tecm.or.dabs(ps(2)).gt.err*tecm
5650 *.or.dabs(ps(3)).gt.err*tecm)then
5651 call utmsg('hnbrop')
5652 write(ifch,*)'***** total 3-momentum nonzero'
5653 write(ifch,'(9x,5f12.5)')(sngl(ps(j)),j=1,5)
5654 call utmsgf
5655 endif
5656 endif
5657 return
5658 end
5659
5660
5661 subroutine hnbrot
5662
5663
5664
5665
5666
5667 common/cnsta/pi,pii,hquer,prom,piom,ainfin
5668 parameter(maxp=500)
5669 common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
5670 real u(3)
5671
5672 do i=1,np
5673 u(3)=2.*rangen()-1.
5674 phi=2.*pi*rangen()
5675 u(1)=sqrt(1.-u(3)**2)*cos(phi)
5676 u(2)=sqrt(1.-u(3)**2)*sin(phi)
5677 pcm(1,i)=pcm(5,i)*u(1)
5678 pcm(2,i)=pcm(5,i)*u(2)
5679 pcm(3,i)=pcm(5,i)*u(3)
5680 enddo
5681
5682 return
5683 end
5684
5685
5686
5687
5688
5689
5690
5691
5692
5693
5694
5695
5696
5697
5698
5699
5700
5701
5702
5703
5704
5705
5706
5707 subroutine hnbrt2(c,s,c2,s2,pr,i)
5708
5709
5710
5711
5712 parameter(maxp=500)
5713 dimension pr(5,maxp)
5714 k1 = 5*i - 4
5715 k2 = k1 + 1
5716 sa = pr(1,i)
5717 sb = pr(2,i)
5718 a = sa*c - sb*s
5719 pr(2,i) = sa*s + sb*c
5720 k2 = k2 + 1
5721 b = pr(3,i)
5722 pr(1,i) = a*c2 - b*s2
5723 pr(3,i) = a*s2 + b*c2
5724 return
5725 end
5726
5727
5728
5729
5730
5731
5732
5733
5734
5735
5736
5737
5738
5739
5740
5741
5742
5743
5744
5745
5746
5747
5748
5749
5750
5751
5752
5753
5754
5755
5756
5757
5758
5759
5760
5761
5762
5763
5764
5765
5766
5767
5768
5769
5770
5771
5772
5773
5774
5775
5776
5777
5778
5779
5780
5781
5782
5783
5784
5785
5786
5787
5788
5789 subroutine hnbspd(iopt)
5790
5791
5792
5793
5794
5795
5796
5797
5798
5799
5800
5801
5802
5803
5804
5805
5806
5807
5808
5809
5810
5811
5812
5813
5814
5815
5816 parameter (mspecs=56)
5817 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
5818 parameter (nflav=6)
5819 integer jc(nflav,2),ic(2)
5820 common/cflac/ifok(nflav,mspecs),ifoa(nflav)
5821 common/cspec2/jspecs(2,nflav,mspecs)
5822 common/cspec3/lkfok(8,-3:3,-3:3,-3:3,-3:3) !-charm
5823 common/cspec4/lkfoi(8,-3:3,-3:3,-3:3,-3:3) !-charm
5824 parameter(nspe01=1,nspe03=3,nspe05=7,nspe07=25,nspe09=54)
5825 parameter(nspe11=6,nspe13=55,nspe15=56)
5826 real jspe01(nspe01),jspe03(nspe03),jspe05(nspe05),jspe07(nspe07)
5827 *,jspe09(nspe09),jspe11(nspe11),jspe13(nspe13),jspe15(nspe15)
5828 data jspe01/ 110 /
5829 data jspe03/ 110, 120, -120 /
5830 data jspe05/ 110, 120, -120, 1120,-1120, 1220,-1220 /
5831 data jspe07/
5832 * 110, 120, -120, 130, -130, 230, -230, 220, 330
5833 *, 1120,-1120, 1220,-1220, 1130,-1130, 2130,-2130
5834 *, 1230,-1230, 2230,-2230, 1330,-1330, 2330,-2330 /
5835 data jspe09/
5836 * 110, 120, -120, 130, -130, 230, -230, 220, 330
5837 *, 111, 121, -121, 131, -131, 231, -231, 221, 331
5838 *, 1120,-1120, 1220,-1220, 1130,-1130, 2130,-2130
5839 *, 1230,-1230, 2230,-2230, 1330,-1330, 2330,-2330
5840 *, 1111,-1111, 1121,-1121, 1221,-1221, 2221,-2221, 1131,-1131
5841 *, 1231,-1231, 2231,-2231, 1331,-1331, 2331,-2331, 3331,-3331 /
5842 data jspe11/
5843 * 1, -1, 2, -2, 3, -3 /
5844 data jspe13/
5845 * 110, 120, -120, 130, -130, 230, -230, 220, 330
5846 *, 111, 121, -121, 131, -131, 231, -231, 221, 331
5847 *, 1120,-1120, 1220,-1220, 1130,-1130, 2130,-2130
5848 *, 1230,-1230, 2230,-2230, 1330,-1330, 2330,-2330
5849 *, 1111,-1111, 1121,-1121, 1221,-1221, 2221,-2221, 1131,-1131
5850 *, 1231,-1231, 2231,-2231, 1331,-1331, 2331,-2331, 3331,-3331
5851 *, 441 /
5852 data jspe15/
5853 * 110, 120, -120, 130, -130, 230, -230, 220, 330
5854 *, 111, 121, -121, 131, -131, 231, -231, 221, 331
5855 *, 1120,-1120, 1220,-1220, 1130,-1130, 2130,-2130
5856 *, 1230,-1230, 2230,-2230, 1330,-1330, 2330,-2330
5857 *, 1111,-1111, 1121,-1121, 1221,-1221, 2221,-2221, 1131,-1131
5858 *, 1231,-1231, 2231,-2231, 1331,-1331, 2331,-2331, 3331,-3331
5859 *, 441 , 30 /
5860
5861 if(iopt.gt.16)call utstop('hnbspd: invalid option&')
5862 ioptx=(1+iopt)/2*2-1
5863
5864 if(ioptx.eq.1)nspecs=nspe01
5865 if(ioptx.eq.3)nspecs=nspe03
5866 if(ioptx.eq.5)nspecs=nspe05
5867 if(ioptx.eq.7)nspecs=nspe07
5868 if(ioptx.eq.9)nspecs=nspe09
5869 if(ioptx.eq.11)nspecs=nspe11
5870 if(ioptx.eq.13)nspecs=nspe13
5871 if(ioptx.eq.15)nspecs=nspe15
5872 do i=1,nspecs
5873 if(ioptx.eq.1)ispecs(i)=jspe01(i)
5874 if(ioptx.eq.3)ispecs(i)=jspe03(i)
5875 if(ioptx.eq.5)ispecs(i)=jspe05(i)
5876 if(ioptx.eq.7)ispecs(i)=jspe07(i)
5877 if(ioptx.eq.9)ispecs(i)=jspe09(i)
5878 if(ioptx.eq.11)ispecs(i)=jspe11(i)
5879 if(ioptx.eq.13)ispecs(i)=jspe13(i)
5880 if(ioptx.eq.15)ispecs(i)=jspe15(i)
5881 if(ioptx.eq.iopt)then
5882 aspecs(i)=0
5883 else
5884 id=ispecs(i)
5885 call idmass(id,am)
5886 aspecs(i)=am
5887 endif
5888 call hnbspi(ispecs(i),gg)
5889 gspecs(i)=gg
5890 enddo
5891
5892 do nf=1,nflav
5893 ifoa(nf)=0
5894 enddo
5895 do iic=-3, 3 !-charm
5896 do iis=-3, 3
5897 do iid=-3, 3
5898 do iiu=-3, 3
5899 do ii=1,7
5900 lkfok(ii,iiu,iid,iis,iic)=0 !-charm
5901 lkfoi(ii,iiu,iid,iis,iic)=0 !-charm
5902 enddo
5903 enddo
5904 enddo
5905 enddo
5906 enddo
5907 do i=1,nspecs
5908 id=ispecs(i)
5909 call idtr4(id,ic)
5910 call iddeco(ic,jc)
5911 do nf=1,nflav
5912 ifok(nf,i)=jc(nf,1)-jc(nf,2)
5913 ifoa(nf)=ifoa(nf)+iabs(ifok(nf,i))
5914 jspecs(1,nf,i)=jc(nf,1)
5915 jspecs(2,nf,i)=jc(nf,2)
5916 enddo
5917 iiu=ifok(1,i)
5918 iid=ifok(2,i)
5919 iis=ifok(3,i)
5920 iic=ifok(4,i) !-charm
5921 if(abs(iiu).gt.3)stop'HNBSPD: u-dimension of lkfok too small'
5922 if(abs(iid).gt.3)stop'HNBSPD: d-dimension of lkfok too small'
5923 if(abs(iis).gt.3)stop'HNBSPD: s-dimension of lkfok too small'
5924 if(abs(iic).gt.3)stop'HNBSPD: c-dimension of lkfok too small' !-charm
5925
5926 if(ifok(5,i).ne.0)stop'HNBSPD: lkfok needs index for b'
5927 if(ifok(6,i).ne.0)stop'HNBSPD: lkfok needs index for t'
5928 lkfok(1,iiu,iid,iis,iic)=lkfok(1,iiu,iid,iis,iic)+1 !-charm
5929 lkfoi(1,iiu,iid,iis,iic)=lkfoi(1,iiu,iid,iis,iic)+1 !-charm
5930 ii=lkfok(1,iiu,iid,iis,iic) !-charm
5931 if(ii.gt.7)stop'HNBSPD: ii-dimension of lkfok too small'
5932 lkfok(1+ii,iiu,iid,iis,iic)=id !-charm
5933 lkfoi(1+ii,iiu,iid,iis,iic)=i !-charm
5934
5935
5936 enddo
5937
5938 return
5939 end
5940
5941
5942 subroutine hnbspf(ku,kd,ks,kc,kb,kt,j,n,spelog)
5943
5944
5945
5946
5947
5948
5949
5950
5951
5952
5953
5954
5955
5956 include 'epos.inc'
5957 parameter (mspecs=56)
5958 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
5959 common/cflac/ifok(nflav,mspecs),ifoa(nflav)
5960 integer m(7),l(7),ifot(nflav)
5961 common/csph/ifox(nflav),ifoy(nflav),jx,nx,ifom(nflav,mspecs)
5962 parameter(mxfacu=200)
5963 double precision faci(0:mxfacu)
5964 double precision utgam2,spelog,spe
5965
5966
5967 if(ish.ge.9)write(ifch,*)('-',i=1,10)
5968 *,' entry sr hnbspf ',('-',i=1,30)
5969 if(ish.ge.9)write(ifch,'(1x,a,9x,a,4x,a)')
5970 *' ku kd ks kc kb kt','j','n'
5971 if(ish.ge.9)write(ifch,'(1x,6i3,5x,2i5)')
5972 *ku,kd,ks,kc,kb,kt,j,n
5973 k=nspecs
5974 jx=j
5975 nx=n
5976 ifot(1)=ku
5977 ifot(2)=kd
5978 ifot(3)=ks
5979 ifot(4)=kc
5980 ifot(5)=kb
5981 ifot(6)=kt
5982
5983 if(ioflac.eq.1)then
5984
5985 if(ish.ge.9)write(ifch,'(1x,a,i1)')'ioflac=',ioflac
5986 g=0
5987 do i=1,nspecs
5988 if(i.ne.j)g=g+gspecs(i)
5989 enddo
5990 spelog=n*dlog(1.d0*g)
5991
5992 elseif(ioflac.eq.2)then
5993
5994 if(ish.ge.9)write(ifch,'(1x,a,i2)')'ioflac:',ioflac
5995 if(k.eq.3)then
5996 if(ish.ge.9)write(ifch,'(1x,a,i2)')'nspecs:',nspecs
5997 spe=0d0
5998 if(j.lt.1.or. j.gt.k)then
5999 do 1 n1=0,n
6000 do 2 n2=0,n-n1
6001 n3=n-n1-n2
6002 do 5 nf=1,nflav
6003 if(ifoa(nf).eq.0.and.ifot(nf).eq.0)goto5
6004 if(n1*ifok(nf,1)+n2*ifok(nf,2)+n3*ifok(nf,3).ne.ifot(nf))goto2
6005 5 continue
6006 spe=spe+utgam2(1.d0+n)
6007 &/utgam2(1.d0+n1)/utgam2(1.d0+n2)/utgam2(1.d0+n3)
6008 &*gspecs(1)**n1*gspecs(2)**n2*gspecs(3)**n3
6009 2 continue
6010 1 continue
6011 else
6012 do 3 i1=0,n
6013 i2=n-i1
6014 m(1)=0
6015 m(2)=i1
6016 m(3)=i2
6017 do i=1,3
6018 ii=1+mod(j-2+i,3)
6019 l(ii)=m(i)
6020 enddo
6021 n1=l(1)
6022 n2=l(2)
6023 n3=l(3)
6024 do 6 nf=1,nflav
6025 if(ifoa(nf).eq.0.and.ifot(nf).eq.0)goto6
6026 if(n1*ifok(nf,1)+n2*ifok(nf,2)+n3*ifok(nf,3).ne.ifot(nf))goto3
6027 6 continue
6028 spe=spe+utgam2(1.d0+n)
6029 &/utgam2(1.d0+n1)/utgam2(1.d0+n2)/utgam2(1.d0+n3)
6030 &*gspecs(1)**n1*gspecs(2)**n2*gspecs(3)**n3
6031 3 continue
6032 endif
6033 if(ish.ge.9)write(ifch,*)'spe:',spe
6034 spelog=-1000
6035 if(spe.gt.0.d0)spelog=dlog(spe)
6036 if(ish.ge.9)write(ifch,*)'spelog:',spelog
6037 elseif(k.eq.7)then
6038 if(ish.ge.9)write(ifch,'(1x,a,i2)')'nspecs:',nspecs
6039 if(n.gt.mxfacu)call utstop('hnbspf: mxfacu too small&')
6040 do lf=0,n
6041 faci(lf)=1.d0/utgam2(1d0+lf)
6042 enddo
6043 spe=0
6044 if(j.lt.1.or. j.gt.k)then
6045 do n1=0,n
6046 do n2=0,n-n1
6047 do n3=0,n-n1-n2
6048 do n4=0,n-n1-n2-n3
6049 do n5=0,n-n1-n2-n3-n4
6050 do 12 n6=0,n-n1-n2-n3-n4-n5
6051 n7=n-n1-n2-n3-n4-n5-n6
6052 do 15 nf=1,nflav
6053 if(ifoa(nf).eq.0.and.ifot(nf).eq.0)goto15
6054 if(n1*ifok(nf,1)+n2*ifok(nf,2)+n3*ifok(nf,3)+n4*ifok(nf,4)
6055 *+n5*ifok(nf,5)+n6*ifok(nf,6)+n7*ifok(nf,7).ne.ifot(nf))goto12
6056 15 continue
6057 spe=spe+1d0/faci(n)*faci(n1)*faci(n2)*faci(n3)*faci(n4)
6058 &*faci(n5)*faci(n6)*faci(n7)
6059 &*gspecs(1)**n1*gspecs(2)**n2*gspecs(3)**n3*gspecs(4)**n4
6060 &*gspecs(5)**n5*gspecs(6)**n6*gspecs(7)**n7
6061 12 continue
6062 enddo
6063 enddo
6064 enddo
6065 enddo
6066 enddo
6067 else
6068 do i1=0,n
6069 do i2=0,n-i1
6070 do i3=0,n-i1-i2
6071 do i4=0,n-i1-i2-i3
6072 do 13 i5=0,n-i1-i2-i3-i4
6073 i6=n-i1-i2-i3-i4-i5
6074 m(1)=0
6075 m(2)=i1
6076 m(3)=i2
6077 m(4)=i3
6078 m(5)=i4
6079 m(6)=i5
6080 m(7)=i6
6081 do i=1,7
6082 ii=1+mod(j-2+i,7)
6083 l(ii)=m(i)
6084 enddo
6085 n1=l(1)
6086 n2=l(2)
6087 n3=l(3)
6088 n4=l(4)
6089 n5=l(5)
6090 n6=l(6)
6091 n7=l(7)
6092 do 16 nf=1,nflav
6093 if(ifoa(nf).eq.0.and.ifot(nf).eq.0)goto16
6094 if(n1*ifok(nf,1)+n2*ifok(nf,2)+n3*ifok(nf,3)+n4*ifok(nf,4)
6095 *+n5*ifok(nf,5)+n6*ifok(nf,6)+n7*ifok(nf,7).ne.ifot(nf))goto13
6096 16 continue
6097 spe=spe+1d0/faci(n)*faci(n1)*faci(n2)*faci(n3)*faci(n4)
6098 &*faci(n5)*faci(n6)*faci(n7)
6099 &*gspecs(1)**n1*gspecs(2)**n2*gspecs(3)**n3*gspecs(4)**n4
6100 &*gspecs(5)**n5*gspecs(6)**n6*gspecs(7)**n7
6101 13 continue
6102 enddo
6103 enddo
6104 enddo
6105 enddo
6106 endif
6107 if(ish.ge.9)write(ifch,*)'spe:',spe
6108 spelog=-1000
6109 if(spe.gt.0.d0)spelog=dlog(spe)
6110 if(ish.ge.9)write(ifch,*)'spelog:',spelog
6111 else
6112 call utstop('hnbspf: ioflac=2 only for nspecs=3,7&')
6113 endif
6114
6115 elseif(ioflac.eq.3)then
6116
6117 call utstop('hnbspf: ioflac must be 1 or 2&')
6118
6119 endif
6120
6121 if(ish.ge.9)write(ifch,*)('-',i=1,30)
6122 *,' exit sr hnbspf ',('-',i=1,10)
6123 return
6124 end
6125
6126
6127 subroutine hnbspg(ku,kd,ks,kc,kb,kt,j,n,spelog)
6128
6129 include 'epos.inc'
6130 double precision spelog,spalog
6131 if(ioflac.ne.0)return
6132 ioflac=2
6133 call hnbspf(ku,kd,ks,kc,kb,kt,j,n,spalog)
6134 ioflac=3
6135 call hnbspf(ku,kd,ks,kc,kb,kt,j,n,spelog)
6136 ioflac=0
6137 write(ifch,*)'ioflac=2/3:',spalog,spelog
6138 return
6139 end
6140
6141
6142 subroutine hnbspi(id,spideg)
6143
6144
6145
6146 include 'epos.inc'
6147 parameter (nspec=62)
6148 dimension ispec(nspec),spid(nspec)
6149 data ispec/
6150 * 1, -1, 2, -2, 3, -3
6151 *, 110, 120, -120, 220, 130, -130, 230, -230, 330
6152 *, 111, 121, -121, 221, 131, -131, 231, -231, 331
6153 *, 1120, 1220, 1130, 2130, 1230, 2230, 1330, 2330
6154 *, 1111, 1121, 1221, 2221, 1131, 1231, 2231, 1331, 2331, 3331
6155 *,-1120,-1220,-1130,-2130,-1230,-2230,-1330,-2330
6156 *,-1111,-1121,-1221,-2221,-1131,-1231,-2231,-1331,-2331,-3331
6157 *,441,30/
6158 data spid/
6159 * 6*6.
6160 *, 9*1.
6161 *, 9*3.
6162 *, 8*2.
6163 *,10*4.
6164 *, 8*2.
6165 *,10*4.
6166 *,1*3
6167 *,1*3/
6168 do i=1,nspec
6169 if(id.eq.ispec(i))then
6170 spideg=spid(i)
6171 fac=1
6172 !factb ... not used
6173 !factq ... not used
6174 call idflav(id,ifl1,ifl2,ifl3,jspin,index)
6175 ifls=0
6176 if(abs(ifl1).eq.3)ifls=ifls+1
6177 if(abs(ifl2).eq.3)ifls=ifls+1
6178 if(abs(ifl3).eq.3)ifls=ifls+1
6179 if(iLHC.eq.1)then
6180 if(ifls.ge.1)then
6181 if(abs(id).gt.1000)then
6182 fac=fac*(1+facts)
6183 elseif(abs(id).lt.1000)then
6184 fac=fac*(1-facts)
6185 endif
6186 elseif(abs(id).gt.1000)then
6187 fac=fac*(1+factb)
6188 endif
6189 else
6190 if(ifls.ge.1)then
6191 if(abs(id).gt.1000)then
6192 fac=fac*(1+facts)
6193 elseif(abs(id).lt.1000)then
6194 fac=fac*(1-facts)
6195 endif
6196 endif
6197 endif
6198 spideg=spideg*fac
6199 goto1
6200 endif
6201 enddo
6202 call utstop('hnbspi: id not found&')
6203 1 continue
6204 return
6205 end
6206
6207
6208 subroutine hnbtst(iof12)
6209
6210
6211
6212
6213
6214 include 'epos.inc'
6215 parameter(maxp=500)
6216 common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
6217 common/ctst/psulog,wtulog
6218 integer ii(maxp)
6219 common /clatt/nlattc,npmax
6220
6221 pi=3.1415927
6222 hquer=0.197327
6223 ish0=ish
6224 if(ishsub/100.eq.23)ish=mod(ishsub,100)
6225 do i=1,np
6226 ii(i)=1
6227 enddo
6228
6229 if(ish.ge.7)write(ifch,*)('-',i=1,10)
6230 *,' entry sr hnbtst ',('-',i=1,30)
6231 if(ish.ge.7)write(ifch,*)'configuration:'
6232 if(ish.ge.7)write(ifch,*)(ident(i),i=1,np)
6233 if(ish.ge.7)write(ifch,*)'n_l:',nlattc,' n_0:',nlattc-np
6234
6235
6236 f5log=0
6237 do i=1,np
6238 call hnbfaf(i,gg,am,ioma)
6239 f5log=f5log+alog(gg*am*volu/4/pi**3/hquer**3)
6240 enddo
6241 if(ish.ge.7)write(ifch,*)'log(f5):',f5log
6242
6243
6244 f4log=0
6245 if(ish.ge.7)write(ifch,*)'log(f4):',f4log
6246
6247
6248 dbllog=0
6249 n1=1
6250 nx=1
6251 1 continue
6252 i=0
6253 x=0
6254 do n2=n1,np
6255 if(ident(n2).eq.ident(n1))then
6256 ii(n2)=0
6257 i=i+1
6258 x=x+alog(i*1.)
6259 endif
6260 if(ii(n2).ne.0.and.n2.gt.n1.and.nx.eq.n1
6261 *.and.ident(n2).ne.ident(n1))nx=n2
6262 enddo
6263 dbllog=dbllog+x
6264 if(nx.gt.n1)then
6265 n1=nx
6266 goto1
6267 endif
6268 f3log=-dbllog
6269 if(ish.ge.7)write(ifch,*)'log(f3):'
6270 *,f3log
6271
6272
6273 f35log=f5log+f4log+f3log
6274 if(ish.ge.7)write(ifch,*)'log(f3*f4*f5):',f35log
6275
6276
6277
6278 psilog=0.0
6279 if(iocova.eq.1)then
6280 psilog=alog(2.*np*np*(np-1)/tecm**4/pi)
6281 do i=1,np
6282 psilog=psilog+alog(tecm**2*pi/2./i/i)
6283 enddo
6284 elseif(iocova.eq.2)then
6285 psilog=-alog(2.*np-1)
6286 psilog=psilog+(np-1)*alog(pi/2.)
6287 do i=1,2*np-2
6288 psilog=psilog+alog((2.*np+i-2)/i)
6289 enddo
6290 do i=1,3*np-4
6291 psilog=psilog+alog(tecm/i)
6292 enddo
6293 endif
6294 if(ish.ge.7)write(ifch,*)'log(psi):',psilog
6295
6296
6297 w35log=f35log+psilog
6298 if(ish.ge.7)write(ifch,*)'log(f35*psi):',w35log
6299
6300 if(iof12.ne.0)then
6301
6302
6303 deglog=0
6304 do i=1,np
6305 deglog=deglog+alog(1.*i)
6306 enddo
6307 deglog=deglog+f3log
6308 do i=1,np
6309 deglog=deglog+alog(nlattc+1.-i)-alog(1.*i)
6310 enddo
6311 f12log=-deglog
6312
6313 w15log=w35log+f12log
6314 if(ish.ge.7)then
6315 write(ifch,*)'log(f1*f2):',f12log
6316 write(ifch,*)'log(f15*psi):',w15log
6317 write(ifch,'(1x,4(a,3x))')
6318 *'log(fac):','log(psi):',' log(wt):','log(wta):'
6319 write(ifch,'(1x,4(f9.3,3x))')
6320 *f12log+f35log,psilog,w15log,w15log-f12log
6321 endif
6322
6323 endif
6324
6325 psulog=psilog
6326 wtulog=w35log
6327
6328 if(ish.ge.7)write(ifch,*)('-',i=1,30)
6329 *,' exit sr hnbtst ',('-',i=1,10)
6330 ish=ish0
6331 return
6332 end
6333
6334
6335
6336
6337
6338
6339
6340
6341
6342
6343
6344
6345
6346
6347
6348
6349
6350
6351
6352
6353
6354
6355
6356
6357
6358
6359
6360
6361
6362
6363
6364
6365
6366
6367
6368 subroutine hnbwri
6369
6370
6371
6372 include 'epos.inc'
6373 parameter(maxp=500)
6374 common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
6375 common/cfact/faclog
6376 write(ifch,'(1x,a,i5)')'np:',np
6377 write(ifch,'(1x,3(a,3x))')
6378 *'log(fac):','log(psi):',' log(wt):'
6379 if(wtlog.gt.-1e30.and.wtxlog.gt.-1e30)then
6380 write(ifch,'(1x,3(f9.3,3x))')faclog,wtxlog,wtlog
6381 else
6382 write(ifch,*)faclog,wtxlog,wtlog
6383 endif
6384 if(np.le.1)return
6385 call hnbtst(1)
6386 write(ifch,*)'particle id codes:'
6387 write(ifch,'(1x,10i6)')(ident(n),n=1,np)
6388 write(ifch,*)'particle masses:'
6389 write(ifch,'(1x,10f6.3)')(amass(n),n=1,np)
6390 end
6391
6392
6393 subroutine hnbzen(iii)
6394
6395
6396
6397
6398 parameter(maxp=500)
6399 common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
6400 parameter (mspecs=56)
6401 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
6402 parameter (nhise=100)
6403 common/chise/hise(mspecs,nhise)
6404 de=2./nhise/2.
6405
6406 j=0
6407
6408 if(iii.gt.0)then
6409
6410 i=iii
6411 do l=1,nspecs
6412 if(ident(i).eq.ispecs(l))then
6413 j=l
6414 goto1
6415 endif
6416 enddo
6417 1 continue
6418 am=aspecs(j)
6419 e=pcm(4,i)
6420 ke=1+int((e-am)/(2*de))
6421 if(ke.ge.1.and.ke.le.nhise)hise(j,ke)=hise(j,ke)+1
6422 return
6423
6424 else
6425
6426 stop'STOP in hnbzen: iii=0'
6427
6428 endif
6429
6430 end
6431
6432
6433 subroutine hnbzmu(iii)
6434
6435
6436
6437
6438
6439 parameter(maxp=500)
6440 common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
6441 parameter (mspecs=56)
6442 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
6443 parameter (nhismu=500)
6444 common/chismu/hismu(mspecs,0:nhismu),hismus(nhismu)
6445
6446 if(iii.lt.0)then
6447
6448 do i=1,nhismu
6449 hismus(i)=0
6450 enddo
6451 do j=1,nspecs
6452 do i=0,nhismu
6453 hismu(j,i)=0
6454 enddo
6455 enddo
6456 goto1000
6457
6458 elseif(iii.gt.0)then
6459
6460 if(np.ge.1.and.np.le.nhismu)hismus(np)=hismus(np)+1
6461 do j=1,nspecs
6462 mu=0
6463 do i=1,np
6464 if(ident(i).eq.ispecs(j))mu=mu+1
6465 enddo
6466 if(mu.ge.0.and.mu.le.nhismu)hismu(j,mu)=hismu(j,mu)+1
6467 enddo
6468 goto1000
6469
6470 else
6471
6472 stop'STOP in sr hnbzmu: iii must not be 0'
6473
6474 endif
6475
6476 1000 continue
6477 return
6478 end
6479
6480
6481 subroutine xhgcam(amt,iii)
6482
6483
6484
6485
6486
6487
6488
6489 include 'epos.inc'
6490 parameter(nbmx=200)
6491 common/camdat/data(nbmx),datb(nbmx)
6492 parameter(mxclu=10000)
6493 real am(mxclu)
6494 character cen*6,cvol*6
6495
6496 save am
6497 data am /mxclu*0/
6498
6499 if(iii.eq.0)then
6500 am(nrclu)=amt
6501
6502 return
6503
6504 elseif(iii.lt.0)then
6505
6506 nbin=nint(xpar3)
6507 x1=xpar1
6508 x2=xpar2
6509 dam=(x2-x1)/nbin
6510 write(cen,'(f6.1)')tecm
6511 write(cvol,'(f6.1)')volu
6512
6513 do i=1,nbin
6514 data(i)=x1+(i-1)*dam
6515 datb(i)=0.0
6516 enddo
6517
6518 do i=1,nrclu
6519 xnb=(am(i)-x1)/dam+1.
6520 nb=nint(xnb)
6521 if(nb.le.nbin.and.nb.ge.1)datb(nb)=datb(nb)+1
6522 enddo
6523
6524 write(ifhi,'(a)') 'newpage zone 1 2 1'
6525
6526 write(ifhi,'(a)') 'openhisto'
6527 write(ifhi,'(a)') 'htyp his'
6528 write(ifhi,'(a)') 'xmod lin ymod lin'
6529 write(ifhi,'(a,2e11.3)')'xrange',x1,x2
6530 write(ifhi,'(a)') 'text 0 0 "xaxis total mass"'
6531 write(ifhi,'(a)') 'text 0 0 "yaxis N"'
6532 write(ifhi,'(a,a)') 'text 0.4 0.91 "V='//cvol//'"'
6533 write(ifhi,'(a,a)') 'text 0.15 0.91 "E='//cen//'"'
6534 write(ifhi,'(a)') 'array 2'
6535
6536 do j=1,nbin
6537 write(ifhi,'(2e13.5)')data(j),datb(j)
6538 enddo
6539
6540 write(ifhi,'(a)') ' endarray'
6541 write(ifhi,'(a)') 'closehisto plot 0'
6542
6543
6544 return
6545
6546 endif
6547
6548 end
6549
6550
6551 subroutine xhgccc(chi)
6552
6553
6554
6555
6556
6557
6558
6559
6560
6561
6562
6563 include 'epos.inc'
6564 parameter(nbin=200)
6565 common/chidat/data(nbin),datb(nbin)
6566 parameter(mxclu=10000)
6567 common/cchi/chi2(mxclu)
6568 character cnu*2,cinco*1,cen*6,cvol*6
6569 parameter (mspecs=56)
6570 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
6571
6572 if(chi.ge.0.0)then
6573
6574 nrclu=nrclu+1
6575 chi2(nrclu)=chi
6576
6577 return
6578
6579 elseif(chi.lt.0.0)then
6580
6581 x1=nint(xpar1)
6582 x2=nint(xpar2)
6583 da=xpar3
6584 write(cnu,'(i2)')nspecs
6585 write(cinco,'(i1)')ioinco
6586 write(cen,'(f6.1)')tecm
6587 write(cvol,'(f6.1)')volu
6588
6589 if(x2.eq.0)x2=50.0
6590 da=max(0.1,da)
6591 a0=x1
6592
6593 do i=1,nbin
6594 data(i)=a0+(i-1)*da
6595 datb(i)=0.0
6596 enddo
6597
6598 do i=1,nrclu
6599 nb=(chi2(i)+da/2.-a0)/da
6600 if(nb.le.nbin.and.nb.ge.1)datb(nb)=datb(nb)+1
6601 enddo
6602
6603 write(ifhi,'(a)') 'openhisto'
6604 write(ifhi,'(a)') 'htyp his'
6605 write(ifhi,'(a)') 'xmod lin ymod lin'
6606 write(ifhi,'(a,2e11.3)')'xrange',x1,x2
6607 write(ifhi,'(a)') 'text 0 0 "xaxis [V]^2"'
6608 write(ifhi,'(a)') 'text 0 0 "yaxis f([V]^2,n?eff!)"'
6609 if(iappl.eq.4)write(ifhi,'(a,a)')'text 0.4 0.91 "V='//cvol//'"'
6610 if(iappl.eq.4)write(ifhi,'(a,a)')'text 0.15 0.91 "E='//cen//'"'
6611 write(ifhi,'(a)') 'array 2'
6612
6613 do j=1,nbin
6614 dat=datb(j)/nevent/da
6615 write(ifhi,'(2e13.5)')data(j),dat
6616 enddo
6617
6618 write(ifhi,'(a)') ' endarray'
6619 write(ifhi,'(a)') 'closehisto'
6620
6621 return
6622
6623 endif
6624
6625 end
6626
6627
6628 subroutine xhgcen
6629
6630
6631
6632
6633
6634
6635
6636
6637
6638
6639
6640
6641
6642 include 'epos.inc'
6643 common/citer/iter,itermx
6644 parameter (nbin=200)
6645 real datx(nbin),daty(nbin)
6646 parameter (mspecs=56)
6647 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
6648 common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
6649 common/cbol/rmsbol(mspecs),ptlbol(mspecs),chebol(mspecs),tembol
6650 character ctem*5,cit*5,cen*6,cvo*6,chem*5
6651
6652 idpa=nint(xpar1)
6653 x1=xpar2
6654 x2=xpar3
6655 ltyp=nint(xpar4)
6656 ist=nint(xpar5)
6657 if(ist.eq.0.and.iostat.eq.1)ist=1
6658
6659 id=0
6660 jx=100
6661 do i=1,nspecs
6662 if(ispecs(i).eq.idpa)id=i
6663 enddo
6664
6665 dx=(x2-x1)/2./jx
6666 x0=x1+dx
6667
6668 do j=1,jx
6669 datx(j)=x0+(j-1)*dx*2.
6670 daty(j)=0.0
6671
6672 if(id.eq.0)then
6673
6674 do 10 i=1,nspecs
6675 dnde=0.0
6676 if(datx(j).ge.aspecs(i))then
6677 x=100.
6678 if(tem.ne.0.0.and.ist.eq.0)x=(datx(j)-chemgc(i))/tem
6679 if(tem.ne.0.0.and.ist.eq.1)x=(datx(j)-chebol(i))/tembol
6680 igsp=gspecs(i)
6681 if(x.ge.60)goto10
6682 if(mod(igsp,2).eq.0.and.ist.eq.0)then
6683 dnde=1./(exp(x)+1.)
6684 elseif(x.le.1.e-7.and.ist.eq.0)then
6685 dnde=1.e7
6686 elseif(ist.eq.0)then
6687 dnde=1./(exp(x)-1.)
6688 elseif(ist.eq.1)then
6689 dnde=exp(-x)
6690 endif
6691 endif
6692 daty(j)=daty(j)+dnde*gspecs(i)*volu/hquer**3/8./pi**3
6693 10 continue
6694
6695 else
6696
6697 dnde=0.0
6698 if(datx(j).ge.aspecs(id))then
6699 x=100.
6700 if(tem.ne.0.0.and.ist.eq.0)x=(datx(j)-chemgc(id))/tem
6701 if(tem.ne.0.0.and.ist.eq.1)x=(datx(j)-chebol(id))/tembol
6702 igsp=gspecs(id)
6703 if(x.ge.60)goto11
6704 if(mod(igsp,2).eq.0.and.ist.eq.0)then
6705 dnde=1./(exp(x)+1.)
6706 elseif(x.le.1.e-7.and.ist.eq.0)then
6707 dnde=1.e7
6708 elseif(ist.eq.0)then
6709 dnde=1./(exp(x)-1.)
6710 elseif(ist.eq.1)then
6711 dnde=exp(-x)
6712 endif
6713 endif
6714 11 daty(j)=dnde*gspecs(id)*volu/hquer**3/8./pi**3
6715
6716 endif
6717
6718 enddo
6719
6720 ctem=' '
6721 chem=' '
6722 if(tem.gt.0.)write(ctem,'(f5.3)')tem
6723 write(cen,'(f6.1)')tecm
6724 write(cvo,'(f6.1)')volu
6725 if(id.gt.0)write(chem,'(f5.3)')chemgc(id)
6726 write(cit,'(i5)')itermx
6727 write(ifhi,'(a)') 'openhisto'
6728 if(ltyp.eq.0)then
6729 write(ifhi,'(a)') 'htyp lda'
6730 elseif(ltyp.eq.1)then
6731 write(ifhi,'(a)') 'htyp ldo'
6732 elseif(ltyp.eq.2)then
6733 write(ifhi,'(a)') 'htyp lfu'
6734 elseif(ltyp.eq.3)then
6735 write(ifhi,'(a)') 'htyp ldd'
6736 endif
6737 write(ifhi,'(a)') 'xmod lin ymod log'
6738 write(ifhi,'(a,2e11.3)')'xrange',x1,x2
6739 write(ifhi,'(a)') 'text 0 0 "xaxis E?[n]! (GeV)"'
6740 write(ifhi,'(a)') 'text 0 0 "yaxis dN?[n]!/d^3!p"'
6741 write(ifhi,'(a,a)') 'text 0.3 0.10 "T='//ctem//'"'
6742 write(ifhi,'(a,a)') 'text 0.3 0.20 "[m]?[n]!='//chem//'"'
6743 write(ifhi,'(a,a)') 'text 0.3 0.20 "i?max!='//cit//'"'
6744 if(iocite.ne.1)then
6745 write(ifhi,'(a,a)') 'text 0.4 0.91 "V='//cvo//'"'
6746 write(ifhi,'(a,a)') 'text 0.15 0.91 "E='//cen//'"'
6747 endif
6748 write(ifhi,'(a)') 'array 2'
6749
6750 do j=1,jx
6751 write(ifhi,'(2e12.4)')datx(j),daty(j)
6752 enddo
6753
6754 write(ifhi,'(a)') ' endarray'
6755 write(ifhi,'(a)') 'closehisto'
6756
6757 return
6758 end
6759
6760
6761 subroutine xhgcfl(u,d,s,iii)
6762
6763
6764
6765
6766
6767 include 'epos.inc'
6768 parameter(nb=200)
6769 common/cfldat/data(nb),datb(nb),datc(nb),datu(nb)
6770 *,datd(nb),dats(nb)
6771 parameter(mxclu=10000)
6772 integer ku(mxclu),kd(mxclu),ks(mxclu)
6773 character cfl*3,cen*6,cvol*6
6774 save ku,kd,ks
6775 data ku/mxclu*0/,kd/mxclu*0/,ks/mxclu*0/
6776
6777 if(iii.eq.0)then
6778
6779 ku(nrclu)=u
6780 kd(nrclu)=d
6781 ks(nrclu)=s
6782
6783 return
6784
6785 elseif(iii.lt.0)then
6786
6787 kwid=nint(xpar1)
6788 nbin=2*kwid+1
6789 x1u=keu-kwid
6790 x2u=keu+kwid
6791 x1d=ked-kwid
6792 x2d=ked+kwid
6793 x1s=kes-kwid
6794 x2s=kes+kwid
6795 write(cen,'(f6.1)')tecm
6796 write(cvol,'(f6.1)')volu
6797
6798 do i=1,nbin
6799 data(i)=x1u+(i-1)
6800 datb(i)=x1d+(i-1)
6801 datc(i)=x1s+(i-1)
6802 datu(i)=0.0
6803 datd(i)=0.0
6804 dats(i)=0.0
6805 enddo
6806
6807 do i=1,nrclu
6808 nbu=(ku(i)-x1u+1)
6809 nbd=(kd(i)-x1d+1)
6810 nbs=(ks(i)-x1s+1)
6811 if(nbu.le.nbin.and.nbu.ge.1)datu(nbu)=datu(nbu)+1
6812 if(nbd.le.nbin.and.nbd.ge.1)datd(nbd)=datd(nbd)+1
6813 if(nbs.le.nbin.and.nbs.ge.1)dats(nbs)=dats(nbs)+1
6814 enddo
6815
6816 write(ifhi,'(a)') 'newpage zone 1 3 1'
6817
6818 write(cfl,'(i3)')keu
6819 write(ifhi,'(a)') 'openhisto'
6820 write(ifhi,'(a)') 'htyp his'
6821 write(ifhi,'(a)') 'xmod lin ymod lin'
6822 write(ifhi,'(a,2e11.3)')'xrange',x1u,x2u
6823 write(ifhi,'(a)') 'text 0 0 "xaxis net u content"'
6824 write(ifhi,'(a)') 'text 0 0 "yaxis N"'
6825 write(ifhi,'(a,a)') 'text 0.4 0.91 "V='//cvol//'"'
6826 write(ifhi,'(a,a)') 'text 0.15 0.91 "E='//cen//'"'
6827 write(ifhi,'(a,a)') 'text 0.65 0.91 "N?u!='//cfl//'"'
6828 write(ifhi,'(a)') 'array 2'
6829
6830 do j=1,nbin
6831 write(ifhi,'(2e13.5)')data(j),datu(j)
6832 enddo
6833
6834 write(ifhi,'(a)') ' endarray'
6835 write(ifhi,'(a)') 'closehisto plot 0'
6836
6837 write(cfl,'(i3)')ked
6838 write(ifhi,'(a)') 'openhisto'
6839 write(ifhi,'(a)') 'htyp his'
6840 write(ifhi,'(a)') 'xmod lin ymod lin'
6841 write(ifhi,'(a,2e11.3)')'xrange',x1d,x2d
6842 write(ifhi,'(a)') 'text 0 0 "xaxis net d content"'
6843 write(ifhi,'(a)') 'text 0 0 "yaxis N"'
6844 write(ifhi,'(a,a)') 'text 0.4 0.91 "V='//cvol//'"'
6845 write(ifhi,'(a,a)') 'text 0.15 0.91 "E='//cen//'"'
6846 write(ifhi,'(a,a)') 'text 0.65 0.91 "N?d!='//cfl//'"'
6847 write(ifhi,'(a)') 'array 2'
6848
6849 do j=1,nbin
6850 write(ifhi,'(2e13.5)')datb(j),datd(j)
6851 enddo
6852
6853 write(ifhi,'(a)') ' endarray'
6854 write(ifhi,'(a)') 'closehisto plot 0'
6855
6856 write(cfl,'(i3)')kes
6857 write(ifhi,'(a)') 'openhisto'
6858 write(ifhi,'(a)') 'htyp his'
6859 write(ifhi,'(a)') 'xmod lin ymod lin'
6860 write(ifhi,'(a,2e11.3)')'xrange',x1s,x2s
6861 write(ifhi,'(a)') 'text 0 0 "xaxis net s content"'
6862 write(ifhi,'(a)') 'text 0 0 "yaxis N"'
6863 write(ifhi,'(a,a)') 'text 0.4 0.91 "V='//cvol//'"'
6864 write(ifhi,'(a,a)') 'text 0.15 0.91 "E='//cen//'"'
6865 write(ifhi,'(a,a)') 'text 0.65 0.91 "N?s!='//cfl//'"'
6866 write(ifhi,'(a)') 'array 2'
6867
6868 do j=1,nbin
6869 write(ifhi,'(2e13.5)')datc(j),dats(j)
6870 enddo
6871
6872 write(ifhi,'(a)') ' endarray'
6873 write(ifhi,'(a)') 'closehisto plot 0'
6874
6875 return
6876
6877 endif
6878
6879 end
6880
6881
6882 subroutine xhgcmt
6883
6884
6885
6886
6887
6888
6889
6890
6891
6892
6893
6894 include 'epos.inc'
6895 common/citer/iter,itermx
6896 parameter (nbin=200)
6897 real datx(nbin),daty(nbin)
6898 parameter (mspecs=56)
6899 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
6900 common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
6901 character cen*6,cvo*6,cit*5,ctem*5
6902
6903 idpa=nint(xpar1)
6904 x1=xpar2
6905 x2=xpar3
6906 ltyp=nint(xpar4)
6907
6908 id=0
6909 jx=100
6910 do i=1,nspecs
6911 if(ispecs(i).eq.idpa)id=i
6912 enddo
6913
6914 dx=(x2-x1)/2./jx
6915 x0=x1+dx
6916
6917 do j=1,jx
6918 datx(j)=x0+(j-1)*dx*2.
6919 daty(j)=0.0
6920
6921 if(id.eq.0)then
6922
6923 do 10 i=1,nspecs
6924 dndmt=0.0
6925 if(datx(j).ge.aspecs(i))then
6926 x=100.
6927 xx=100.
6928 if(tem.ne.0.)x=datx(j)/tem
6929 if(tem.ne.0.)xx=chemgc(i)/tem
6930 if(abs(xx).le.60)dndmt=gspecs(i)*volu/hquer**3*exp(xx)*datx(j)
6931 */4./pi**3*hgcbk1(x)
6932 endif
6933 daty(j)=daty(j)+dndmt
6934 10 continue
6935
6936 else
6937
6938 dndmt=0.0
6939 if(datx(j).ge.aspecs(id))then
6940 x=100.
6941 xx=100.
6942 if(tem.ne.0.)x=datx(j)/tem
6943 if(tem.ne.0.)xx=chemgc(id)/tem
6944 if(abs(xx).le.60)dndmt=gspecs(id)*volu/hquer**3*exp(xx)*datx(j)
6945 */4./pi**3*hgcbk1(x)
6946 endif
6947 daty(j)=dndmt
6948
6949 endif
6950
6951 enddo
6952
6953 write(cit,'(i5)')itermx
6954 write(cen,'(f6.1)')tecm
6955 write(cvo,'(f6.1)')volu
6956 write(ctem,'(f5.3)')tem
6957 write(ifhi,'(a)') 'openhisto'
6958 if(ltyp.eq.0)then
6959 write(ifhi,'(a)') 'htyp lda'
6960 elseif(ltyp.eq.1)then
6961 write(ifhi,'(a)') 'htyp ldo'
6962 elseif(ltyp.eq.2)then
6963 write(ifhi,'(a)') 'htyp lfu'
6964 endif
6965 write(ifhi,'(a)') 'xmod lin ymod log'
6966 write(ifhi,'(a,2e11.3)')'xrange',x1,x2
6967 write(ifhi,'(a)') 'text 0 0 "xaxis m?t! (GeV)"'
6968 write(ifhi,'(a)') 'text 0 0 "yaxis dN?[n]!/d^2!m?t! "'
6969 write(ifhi,'(a,a)') 'text 0.3 0.10 "T='//ctem//'"'
6970 write(ifhi,'(a,a)') 'text 0.3 0.20 "i?max!='//cit//'"'
6971 write(ifhi,'(a,a)') 'text 0.4 0.91 "V='//cvo//'"'
6972 write(ifhi,'(a,a)') 'text 0.15 0.91 "E='//cen//'"'
6973 write(ifhi,'(a)') 'array 2'
6974
6975 do j=1,jx
6976 write(ifhi,'(2e12.4)')datx(j),daty(j)
6977 enddo
6978
6979 write(ifhi,'(a)') ' endarray'
6980 write(ifhi,'(a)') 'closehisto'
6981
6982 return
6983 end
6984
6985
6986 subroutine xhgcmu
6987
6988
6989
6990
6991
6992
6993
6994
6995
6996
6997
6998
6999
7000
7001
7002 include 'epos.inc'
7003 parameter (nbin=200)
7004 real datx(nbin),daty(nbin)
7005 parameter (mspecs=56)
7006 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
7007 common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
7008 common/cbol/rmsbol(mspecs),ptlbol(mspecs),chebol(mspecs),tembol
7009 common/cgctot/rmstot,ptltot
7010 character cyield*8,cen*6,cvo*6,cinco*1
7011
7012
7013 idpa=nint(xpar1)
7014 ixra=nint(xpar2)
7015 iwid=nint(xpar5)
7016 ltyp=nint(xpar6)
7017 ist=nint(xpar7)
7018 if(ist.eq.0.and.iostat.eq.1)ist=1
7019
7020
7021 pn=0.0
7022 id=0
7023 jx=100
7024 ymin=1./nevent/10.
7025 if(nevent.le.10)ymin=ymin/10.
7026 do i=1,nspecs
7027 if(ispecs(i).eq.idpa)id=i
7028 enddo
7029
7030 if(ixra.eq.1)then
7031 x1=anint(xpar3)
7032 x2=anint(xpar4)
7033 else
7034 if(id.eq.0)then
7035 x1=anint(ptltot-iwid*rmstot)
7036 x2=anint(ptltot+iwid*rmstot)
7037 else
7038 x1=anint(ptlngc(id)-iwid*rmsngc(id))
7039 x2=anint(ptlngc(id)+iwid*rmsngc(id))
7040 endif
7041 x2=max(x2,3.0)
7042 endif
7043
7044 x1=max(x1,0.0)
7045 dx=(x2-x1)/2./jx
7046 x0=x1+dx
7047 pn=0.0
7048
7049 do j=1,jx
7050 datx(j)=x0+(j-1)*dx*2.
7051 if(id.eq.0)then
7052
7053
7054
7055 x=100.
7056 if(rmstot.ge.1.e-10)x=(datx(j)-ptltot)**2/rmstot**2/2.
7057
7058 if(x.ge.60)then
7059 pn=0.0
7060 else
7061 pn=exp(-x)/rmstot/sqrt(2.*pi)
7062 endif
7063
7064 daty(j)=pn
7065
7066 else
7067
7068
7069
7070 x=100.
7071 if(rmsngc(id).ge.1.e-10.and.ist.eq.0)
7072 *x=(datx(j)-ptlngc(id))**2/rmsngc(id)**2/2.
7073 if(rmsbol(id).ge.1.e-10.and.ist.eq.1)
7074 *x=(datx(j)-ptlbol(id))**2/rmsbol(id)**2/2.
7075
7076 if(x.ge.60)then
7077 pn=0.0
7078 else
7079 if(ist.eq.0)pn=exp(-x)/rmsngc(id)/sqrt(2*pi)
7080 if(ist.eq.1)pn=exp(-x)/rmsbol(id)/sqrt(2*pi)
7081 endif
7082
7083 daty(j)=pn
7084
7085 endif
7086 enddo
7087
7088 if(id.eq.0)then
7089 write(cyield,'(f8.3)')ptltot
7090 else
7091 write(cyield,'(f8.3)')ptlngc(id)
7092 endif
7093 write(cinco,'(i1)')ioinco
7094 write(cen,'(f6.1)')tecm
7095 write(cvo,'(f6.1)')volu
7096 write(ifhi,'(a)') 'openhisto'
7097 if(ltyp.eq.0)then
7098 write(ifhi,'(a)') 'htyp lda'
7099 elseif(ltyp.eq.1)then
7100 write(ifhi,'(a)') 'htyp ldo'
7101 elseif(ltyp.eq.2)then
7102 write(ifhi,'(a)') 'htyp lfu'
7103 elseif(ltyp.eq.3)then
7104 write(ifhi,'(a)') 'htyp ldd'
7105 endif
7106 write(ifhi,'(a)') 'xmod lin ymod log'
7107 write(ifhi,'(a,2e11.3)')'xrange',x1,x2
7108 write(ifhi,'(a,e11.3,a)')'yrange',ymin,' auto'
7109 write(ifhi,'(a)') 'text 0 0 "xaxis N?[n]!"'
7110 write(ifhi,'(a)') 'text 0 0 "yaxis P(N?[n]!)"'
7111 write(ifhi,'(a,a)')'text 0.3 0.10 "" "L#N?[n]!"G#='//cyield//'""'
7112 write(ifhi,'(a,a)') 'text 0.3 0.2 "conf?in!='//cinco//'"'
7113 if(iocite.ne.1)then
7114 write(ifhi,'(a,a)') 'text 0.4 0.91 "V='//cvo//'"'
7115 write(ifhi,'(a,a)') 'text 0.15 0.91 "E='//cen//'"'
7116 endif
7117 write(ifhi,'(a)') 'array 2'
7118
7119 do j=1,jx
7120 write(ifhi,'(2e12.4)')datx(j),daty(j)
7121 enddo
7122
7123 write(ifhi,'(a)') ' endarray'
7124 write(ifhi,'(a)') 'closehisto'
7125
7126
7127 return
7128 end
7129
7130
7131
7132 subroutine xhgcmx
7133
7134
7135
7136
7137
7138
7139
7140
7141
7142
7143
7144
7145
7146
7147
7148 include 'epos.inc'
7149 parameter (nbin=200)
7150 real datx(nbin),daty(nbin)
7151 parameter (mspecs=56)
7152 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
7153 common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
7154 common/cbol/rmsbol(mspecs),ptlbol(mspecs),chebol(mspecs),tembol
7155 common/cgctot/rmstot,ptltot
7156 character cyield*8,cen*6,cvo*6,cinco*1
7157
7158
7159 idpa=nint(xpar1)
7160 ixra=nint(xpar2)
7161 iwid=nint(xpar5)
7162 ltyp=nint(xpar6)
7163 ist=nint(xpar7)
7164 if(ist.eq.0.and.iostat.eq.1)ist=1
7165 pn=0.
7166
7167
7168 id=0
7169 ymin=1./nevent/10.
7170 if(nevent.le.10)ymin=ymin/10.
7171 do i=1,nspecs
7172 if(ispecs(i).eq.idpa)id=i
7173 enddo
7174
7175 if(ixra.eq.1)then
7176 n1=nint(xpar3)
7177 n2=nint(xpar4)
7178 else
7179 if(id.eq.0)then
7180 n1=nint(ptltot-iwid*rmstot)
7181 n2=nint(ptltot+iwid*rmstot)
7182 else
7183 n1=nint(ptlngc(id)-iwid*rmsngc(id))
7184 n2=nint(ptlngc(id)+iwid*rmsngc(id))
7185 endif
7186 n2=max(n2,3)
7187 endif
7188
7189 n1=max(n1,0)
7190 jx=n2+1
7191
7192 do j=1,jx
7193 datx(j)=j-1
7194 jf=1
7195 if(j.gt.1)then
7196 do i=1,j-1
7197 jf=jf*i
7198 enddo
7199 endif
7200 if(id.eq.0)then
7201
7202
7203
7204
7205 daty(j)=1./jf*ptltot**(j-1)*exp(-ptltot)
7206
7207 else
7208
7209
7210
7211
7212 if(ist.eq.0)pn=1./jf*ptlngc(id)**(j-1)*exp(-ptlngc(id))
7213 if(ist.eq.1)pn=1./jf*ptlbol(id)**(j-1)*exp(-ptlbol(id))
7214
7215 daty(j)=pn
7216
7217 endif
7218 enddo
7219
7220 if(id.eq.0)then
7221 write(cyield,'(f8.3)')ptltot
7222 else
7223 write(cyield,'(f8.3)')ptlngc(id)
7224 endif
7225 write(cinco,'(i1)')ioinco
7226 write(cen,'(f6.1)')tecm
7227 write(cvo,'(f6.1)')volu
7228 write(ifhi,'(a)') 'openhisto'
7229 if(ltyp.eq.0)then
7230 write(ifhi,'(a)') 'htyp lda'
7231 elseif(ltyp.eq.1)then
7232 write(ifhi,'(a)') 'htyp ldo'
7233 elseif(ltyp.eq.2)then
7234 write(ifhi,'(a)') 'htyp lfu'
7235 elseif(ltyp.eq.3)then
7236 write(ifhi,'(a)') 'htyp ldd'
7237 endif
7238 write(ifhi,'(a)') 'xmod lin ymod log'
7239 write(ifhi,'(a,2i3)')'xrange',n1,n2
7240 write(ifhi,'(a,e11.3,a)')'yrange',ymin,' auto'
7241 write(ifhi,'(a)') 'text 0 0 "xaxis N?[n]!"'
7242 write(ifhi,'(a)') 'text 0 0 "yaxis P(N?[n]!)"'
7243 write(ifhi,'(a,a)')'text 0.3 0.10 "" "L#N?[n]!"G#='//cyield//'""'
7244 write(ifhi,'(a,a)') 'text 0.3 0.2 "conf?in!='//cinco//'"'
7245 if(iocite.ne.1)then
7246 write(ifhi,'(a,a)') 'text 0.4 0.91 "V='//cvo//'"'
7247 write(ifhi,'(a,a)') 'text 0.15 0.91 "E='//cen//'"'
7248 endif
7249 write(ifhi,'(a)') 'array 2'
7250
7251 do j=1,jx
7252 write(ifhi,'(2e12.4)')datx(j),daty(j)
7253 enddo
7254
7255 write(ifhi,'(a)') ' endarray'
7256 write(ifhi,'(a)') 'closehisto'
7257
7258
7259 return
7260 end
7261
7262
7263 subroutine xhgcpt
7264
7265
7266
7267
7268
7269
7270
7271
7272
7273
7274
7275
7276 include 'epos.inc'
7277 common/citer/iter,itermx
7278 parameter (nbin=200)
7279 real datx(nbin),daty(nbin)
7280 parameter (mspecs=56)
7281 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
7282 common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
7283 character crap*5,cen*6,cvo*6,cit*5
7284
7285 idpa=nint(xpar1)
7286 y=xpar2
7287 x1=xpar3
7288 x2=xpar4
7289 ltyp=xpar5
7290
7291 write(crap,'(f5.1)')y
7292 id=0
7293 jx=100
7294 do i=1,nspecs
7295 if(ispecs(i).eq.idpa)id=i
7296 enddo
7297
7298 dx=(x2-x1)/2./jx
7299 x0=x1+dx
7300
7301 do j=1,jx
7302 datx(j)=x0+(j-1)*dx*2.
7303 daty(j)=0.0
7304
7305 if(id.eq.0)then
7306
7307 do 10 i=1,nspecs
7308 x=100.
7309 if(tem.ne.0.)
7310 *x=(sqrt(aspecs(i)**2+datx(j)**2)*cosh(y)-chemgc(i))/tem
7311 if(x.ge.60)then
7312 dndpt=0.0
7313 else
7314 dndpt=exp(-x)
7315 endif
7316 dndpt=dndpt*gspecs(i)*volu/hquer**3*cosh(y)
7317 **sqrt(aspecs(i)**2+datx(j)**2)/8./pi**3
7318 daty(j)=daty(j)+dndpt
7319 10 continue
7320
7321 else
7322
7323 x=100.
7324 if(tem.ne.0.)
7325 *x=(sqrt(aspecs(id)**2+datx(j)**2)*cosh(y)-chemgc(id))/tem
7326 if(x.ge.60)then
7327 dndpt=0.0
7328 else
7329 dndpt=exp(-x)
7330 endif
7331 dndpt=dndpt*gspecs(id)*volu/hquer**3*cosh(y)
7332 **sqrt(aspecs(id)**2+datx(j)**2)/8./pi**3
7333 daty(j)=dndpt
7334
7335 endif
7336
7337 enddo
7338
7339 write(cit,'(i5)')itermx
7340 write(cen,'(f6.1)')tecm
7341 write(cvo,'(f6.1)')volu
7342 write(ifhi,'(a)') 'openhisto'
7343 if(ltyp.eq.0)then
7344 write(ifhi,'(a)') 'htyp lda'
7345 elseif(ltyp.eq.1)then
7346 write(ifhi,'(a)') 'htyp ldo'
7347 elseif(ltyp.eq.2)then
7348 write(ifhi,'(a)') 'htyp lfu'
7349 endif
7350 write(ifhi,'(a)') 'xmod lin ymod log'
7351 write(ifhi,'(a,2e11.3)')'xrange',x1,x2
7352 write(ifhi,'(a)') 'text 0 0 "xaxis p?t! (GeV/c)"'
7353 write(ifhi,'(a)') 'text 0 0 "yaxis dN?[n]!/dyd^2!p?t!"'
7354 write(ifhi,'(a)') 'text 0.10 0.10 "y = '//crap//'"'
7355 write(ifhi,'(a)') 'text 0.10 0.30 "i?max! = '//cit//'"'
7356 write(ifhi,'(a,a)') 'text 0.4 0.91 "V='//cvo//'"'
7357 write(ifhi,'(a,a)') 'text 0.15 0.91 "E='//cen//'"'
7358 write(ifhi,'(a)') 'array 2'
7359
7360 do j=1,jx
7361 write(ifhi,'(2e12.4)')datx(j),daty(j)
7362 enddo
7363
7364 write(ifhi,'(a)') ' endarray'
7365 write(ifhi,'(a)') 'closehisto'
7366
7367 return
7368 end
7369
7370
7371 subroutine xhgcra
7372
7373
7374
7375
7376
7377
7378
7379
7380
7381
7382
7383 include 'epos.inc'
7384 parameter (nbin=200)
7385 real datx(nbin),daty(nbin)
7386 parameter (mspecs=56)
7387 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
7388 common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
7389 common/cgctot/rmstot,ptltot
7390 character cen*6,cvo*6,cng*8
7391
7392 idpa=nint(xpar1)
7393 x1=nint(xpar2)
7394 x2=nint(xpar3)
7395 ltyp=nint(xpar4)
7396
7397 id=0
7398 jx=100
7399 ymin=1./nevent/10.
7400 if(nevent.le.10)ymin=ymin/10.
7401 do i=1,nspecs
7402 if(ispecs(i).eq.idpa)id=i
7403 enddo
7404
7405 dx=(x2-x1)/2./jx
7406 x0=x1+dx
7407
7408 do j=1,jx
7409
7410 datx(j)=x0+(j-1)*dx*2.
7411 daty(j)=0.0
7412 y=datx(j)
7413 if(ish.ge.9)write(ifch,*)'cosh y:',cosh(y)
7414
7415 if(id.eq.0)then
7416
7417 do 10 i=1,nspecs
7418 dndy=0.0
7419 sum=aspecs(i)**2*tem+2.*aspecs(i)*tem**2/cosh(y)
7420 *+2.*tem**3/cosh(y)**2
7421 x=100.
7422 if(tem.ne.0.0)
7423 *x=(aspecs(i)*cosh(y)-chemgc(i))/tem
7424
7425 if(x.ge.60.)then
7426 pro=0.0
7427 else
7428 pro=exp(-x)
7429 endif
7430
7431 pro=pro*gspecs(i)*volu/hquer**3/4./pi**2
7432
7433 if(pro.ge.(1.e-30).and.sum.ge.(1.e-30))then
7434 che=alog(pro)+alog(sum)
7435 else
7436 che=-61.0
7437 endif
7438 if(che.le.60.0.and.che.ge.(-60.0))dndy=pro*sum
7439
7440
7441 daty(j)=daty(j)+dndy
7442
7443 10 continue
7444
7445 else
7446
7447 dndy=0.0
7448 sum=aspecs(id)**2*tem+2.*aspecs(id)*tem**2/cosh(y)
7449 *+2.*tem**3/cosh(y)**2
7450 x=100.
7451 if(tem.ne.0.0)
7452 *x=(aspecs(id)*cosh(y)-chemgc(id))/tem
7453
7454 if(x.ge.60.)then
7455 pro=0.0
7456 else
7457 pro=exp(-x)
7458 endif
7459
7460 pro=pro*gspecs(id)*volu/hquer**3/4./pi**2
7461
7462 if(pro.ge.(1.e-30).and.sum.ge.(1.e-30))then
7463 che=alog(pro)+alog(sum)
7464 else
7465 che=-61.0
7466 endif
7467 if(che.le.60..and.che.ge.-60.)dndy=pro*sum
7468
7469 daty(j)=dndy
7470
7471 endif
7472
7473 enddo
7474
7475 write(cen,'(f6.1)')tecm
7476 write(cvo,'(f6.1)')volu
7477 if(id.eq.0)then
7478 write(cng,'(f8.3)')ptltot
7479 else
7480 write(cng,'(f8.3)')ptlngc(id)
7481 endif
7482 write(ifhi,'(a)') 'openhisto'
7483 if(ltyp.eq.0)then
7484 write(ifhi,'(a)') 'htyp lda'
7485 elseif(ltyp.eq.1)then
7486 write(ifhi,'(a)') 'htyp ldo'
7487 elseif(ltyp.eq.2)then
7488 write(ifhi,'(a)') 'htyp lfu'
7489 endif
7490
7491 write(ifhi,'(a)') 'xmod lin ymod log'
7492 write(ifhi,'(a,2e11.3)')'xrange',x1,x2
7493 write(ifhi,'(a,e11.3,a)')'yrange',ymin,' auto'
7494 write(ifhi,'(a)') 'text 0 0 "xaxis y"'
7495 write(ifhi,'(a)') 'text 0 0 "yaxis dN?[n]!/dy"'
7496 write(ifhi,'(a,a)') 'text 0.4 0.91 "V='//cvo//'"'
7497 write(ifhi,'(a,a)') 'text 0.15 0.91 "E='//cen//'"'
7498 write(ifhi,'(a,a)') 'text 0.3 0.10 "N?[n]!='//cng//'"'
7499 write(ifhi,'(a)') 'array 2'
7500
7501 do j=1,jx
7502 write(ifhi,'(2e12.4)')datx(j),daty(j)
7503 enddo
7504
7505 write(ifhi,'(a)') ' endarray'
7506 write(ifhi,'(a)') 'closehisto'
7507
7508 return
7509 end
7510
7511
7512 subroutine xhnben
7513
7514
7515
7516
7517
7518
7519
7520
7521
7522 include 'epos.inc'
7523 parameter (mspecs=56)
7524 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
7525 parameter (nhise=100)
7526 common/chise/hise(mspecs,nhise)
7527 parameter (literm=500)
7528 common/cmet/kspecs(mspecs),liter,lspecs(literm,mspecs)
7529 *,iterl(literm),iterc(literm)
7530 real datx(nhise),daty(nhise),dats(nhise)
7531 common/citer/iter,itermx
7532 character ch*1,chid*5,cyield*9,ctem*5
7533 de=2./nhise/2.
7534
7535 if(iocite.ne.1)stop'STOP: xhnben: iocite=1 required'
7536
7537 idcode=nint(xpar1)
7538 mode=nint(xpar2)
7539 kind=nint(xpar3)
7540
7541 do j=1,nspecs
7542 if(idcode.eq.ispecs(j))then
7543
7544 id=idcode
7545 am=aspecs(j)
7546 yield=1.*kspecs(j)/(itermx-iternc)
7547 if(kind.eq.1)ch=' '
7548 if(kind.eq.2)ch='e'
7549 ll=kind-1
7550 e0=am+de
7551 nebins=0
7552 do i=1,nhise
7553 e=e0+(i-1)*2*de
7554 p1=sqrt((e-de)**2-am**2)
7555 p2=sqrt((e+de)**2-am**2)
7556 d3p=4*pi*(p2**3-p1**3)/3
7557 datx(i)=e
7558 y=(1-ll+ll*e)*hise(j,i)/(itermx-iternc)/d3p
7559 if(y.gt.0.)then
7560 nebins=nebins+1
7561 daty(i)=alog(y)
7562 d=y/sqrt(hise(j,i))
7563 dats(i)=1e10
7564 if(y-d.gt.0.)dats(i)=alog(y+d)-alog(y-d)
7565 else
7566 daty(i)=-100
7567 dats(i)=1e10
7568 endif
7569
7570 enddo
7571 a=0.
7572 b=0.
7573 if(nebins.ge.3)then
7574 call utfit(datx,daty,nhise,dats,1,a,b,siga,sigb,chi2,q)
7575 tem=-1./b
7576 if(tem.lt.0.050.or.tem.gt.10.)then
7577 tem=0.
7578 a=0.
7579 b=0.
7580 endif
7581 endif
7582 do i=1,nhise
7583 daty(i)=exp(daty(i))
7584 enddo
7585 write(chid,'(i5)')id
7586 write(cyield,'(f9.4)')yield
7587 ctem=' '
7588 if(tem.gt.0.)write(ctem,'(f5.3)')tem
7589 write(ifhi,'(a)') 'openhisto xrange 0 3'
7590 write(ifhi,'(a)') 'htyp lin xmod lin ymod log'
7591 write(ifhi,'(a,a)') 'text 0 0 "title id='//chid
7592 * ,' N='//cyield//' T='//ctem//'"'
7593 write(ifhi,'(a)') 'text 0 0 "xaxis energy (GeV)"'
7594 write(ifhi,'(a)') 'text 0 0 "yaxis '//ch//' dn/d3p (GeV-3)"'
7595 write(ifhi,'(a)') 'array 2'
7596 do i=1,nhise
7597 if(mode.eq.1)write(ifhi,'(2e12.4)')datx(i),daty(i)
7598 if(mode.eq.2)write(ifhi,'(2e12.4)')datx(i),exp(a+b*datx(i))
7599 enddo
7600 write(ifhi,'(a)') ' endarray'
7601 write(ifhi,'(a)') 'closehisto'
7602
7603 endif
7604 enddo
7605
7606 return
7607 end
7608
7609
7610 subroutine xhnbit
7611
7612
7613
7614
7615
7616
7617
7618
7619 include 'epos.inc'
7620 parameter (mspecs=56)
7621 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
7622 parameter (literm=500)
7623 common/cmet/kspecs(mspecs),liter,lspecs(literm,mspecs)
7624 *,iterl(literm),iterc(literm)
7625 real datlx(literm),datly(literm)
7626 common/citer/iter,itermx
7627 character chid*5,ctecm*5,cvolu*6
7628 common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
7629 common/cgctot/rmstot,ptltot
7630
7631 if(iocite.ne.1)stop'STOP: xhnbit: iocite=1 required'
7632
7633 idcode=nint(xpar1)
7634 mode=nint(xpar2)
7635
7636 if(idcode.eq.0)then
7637
7638 yield=0
7639 do j=1,nspecs
7640 yield=yield+1.*kspecs(j)/(itermx-iternc)
7641 enddo
7642 datlx(1)=(iterl(1)+1)/2.
7643 do li=2,liter-1
7644 datlx(li)=(iterl(li)+iterl(li-1)+1)/2.
7645 enddo
7646 x1=0
7647 x2=iterl(liter-1)
7648 do li=1,liter-1
7649 y=0
7650 do j=1,nspecs
7651 y=y+lspecs(li,j)
7652 enddo
7653 if(mode.eq.1)datly(li)=y/iterc(li)
7654 if(mode.eq.2)datly(li)=yield
7655 if(mode.eq.3)datly(li)=ptltot
7656 enddo
7657 write(ctecm,'(f5.1)')tecm
7658 write(cvolu,'(f6.1)')volu
7659 write(ifhi,'(a,2e11.3)')'openhisto xrange',x1,x2
7660 write(ifhi,'(a)') 'htyp lin xmod lin ymod lin'
7661 write(ifhi,'(a,a)') 'text 0 0 "title E = '//ctecm//' V = '
7662 * ,cvolu//'"'
7663 write(ifhi,'(a)') 'text 0 0 "xaxis iterations"'
7664 write(ifhi,'(a)') 'text 0 0 "yaxis multiplicity"'
7665 write(ifhi,'(a)') 'array 2'
7666 do i=1,liter-1
7667 write(ifhi,'(2e12.4)') datlx(i),datly(i)
7668 enddo
7669 write(ifhi,'(a)') ' endarray'
7670 write(ifhi,'(a)') 'closehisto'
7671
7672 else
7673
7674 do j=1,nspecs
7675 if(idcode.eq.ispecs(j))then
7676
7677 yield=1.*kspecs(j)/(itermx-iternc)
7678 write(chid,'(i5)')idcode
7679 do li=1,liter-1
7680 datlx(li)=iterl(li)
7681 enddo
7682 x1=0
7683 x2=datlx(liter-1)
7684 do li=1,liter-1
7685 if(mode.eq.1)datly(li)=lspecs(li,j)*1./iterc(li)
7686 if(mode.eq.2)datly(li)=yield
7687 if(mode.eq.3)datly(li)=ptlngc(j)
7688 enddo
7689 write(ifhi,'(a,2e11.3)')'openhisto xrange',x1,x2
7690 write(ifhi,'(a)') 'htyp lin xmod lin ymod lin'
7691 write(ifhi,'(a)') 'text 0 0 "title id='//chid//'"'
7692 write(ifhi,'(a)') 'text 0 0 "xaxis iterations "'
7693 write(ifhi,'(a)') 'text 0 0 "yaxis multiplicity"'
7694 write(ifhi,'(a)') 'array 2'
7695 do i=1,liter-1
7696 write(ifhi,'(2e12.4)') datlx(i),datly(i)
7697 enddo
7698 write(ifhi,'(a)') ' endarray'
7699 write(ifhi,'(a)') 'closehisto'
7700
7701 endif
7702 enddo
7703
7704 endif
7705
7706 return
7707 end
7708
7709
7710 subroutine xhnbmu
7711
7712
7713
7714
7715
7716
7717
7718
7719
7720 include 'epos.inc'
7721 parameter (mspecs=56)
7722 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
7723 parameter (nhismu=500)
7724 common/chismu/hismu(mspecs,0:nhismu),hismus(nhismu)
7725 parameter (literm=500)
7726 common/cmet/kspecs(mspecs),liter,lspecs(literm,mspecs)
7727 *,iterl(literm),iterc(literm)
7728 real datx(nhismu),daty(nhismu)
7729 common/citer/iter,itermx
7730 common /clatt/nlattc,npmax
7731 character chid*5,cyield*9,ctecm*5,cvolu*6
7732
7733 if(iocite.ne.1)stop'STOP: xhnbmu: iocite=1 required'
7734
7735 idcode=nint(xpar1)
7736 ixr=nint(xpar2)
7737 xx1=xpar3
7738 xx2=xpar4
7739
7740 write(ctecm,'(f5.1)')tecm
7741 write(cvolu,'(f6.1)')volu
7742
7743 if(idcode.eq.0)then
7744
7745 yield=0
7746 do j=1,nspecs
7747 yield=yield+1.*kspecs(j)/(itermx-iternc)
7748 enddo
7749 write(cyield,'(f9.4)')yield
7750 i1=0
7751 i2=nlattc
7752 mus=0
7753 do i=1,nhismu
7754 if(i1.eq.0.and.nint(hismus(i)).gt.0)i1=i
7755 if(nint(hismus(i)).gt.0)i2=i
7756 mus=mus+hismus(i)
7757 enddo
7758 ij=0.5*(i1+i2)*0.20
7759 if(itermx.le.1000)ij=0.5*(i1+i2)*0.40
7760 if(itermx.le.100)ij=0.5*(i1+i2)*0.80
7761 i1=i1-ij
7762 i1=max(i1,2)
7763 i2=i2+ij
7764 ii=10
7765 if(i1.le.50)ii=5
7766 if(i1.le.20)ii=2
7767 i1=i1/ii*ii
7768 i2=i2/ii*ii+ii
7769 do i=i1,i2
7770 l=1+i-i1
7771 datx(l)=i
7772 daty(l)=hismus(i)/mus
7773 enddo
7774 jx=1+i2-i1
7775 if(ixr.eq.0)then
7776 x1=i1
7777 x2=i2
7778 else
7779 x1=xx1
7780 x2=xx2
7781 endif
7782 write(ifhi,'(a,2e11.3)')'openhisto xrange',x1,x2
7783 write(ifhi,'(a)') 'htyp lin xmod lin ymod log'
7784 write(ifhi,'(a,a)') 'text 0 0 "title E = '//ctecm//' V = '
7785 * ,cvolu//'"'
7786 write(ifhi,'(a)') 'text 0 0 "xaxis multiplicity n "'
7787 write(ifhi,'(a)') 'text 0 0 "yaxis dN/dn"'
7788 write(ifhi,'(a)') 'text 0.30 0.25 "N?MC!='//cyield//'"'
7789 write(ifhi,'(a)') 'array 2'
7790 do i=1,jx
7791 write(ifhi,'(2e12.4)') datx(i),daty(i)
7792 enddo
7793 write(ifhi,'(a)') ' endarray'
7794 write(ifhi,'(a)') 'closehisto'
7795
7796 else
7797
7798 do j=1,nspecs
7799 if(idcode.eq.ispecs(j))then
7800
7801 yield=1.*kspecs(j)/(itermx-iternc)
7802 write(cyield,'(f9.4)')yield
7803 write(chid,'(i5)')idcode
7804 i1=0
7805 i2=nlattc
7806 mus=0
7807 do i=0,nhismu
7808 if(i1.eq.0.and.nint(hismu(j,i)).gt.0)i1=i
7809 if(nint(hismu(j,i)).gt.0)i2=i
7810 mus=mus+hismu(j,i)
7811 enddo
7812 ij=0.5*(i1+i2)*0.30
7813 if(itermx.le.1000)ij=0.5*(i1+i2)*0.60
7814 if(itermx.le.100)ij=0.5*(i1+i2)*1.20
7815 i1=i1-ij
7816 i1=max(i1,0)
7817 i2=i2+ij
7818 ii=10
7819 if(i1.le.50)ii=5
7820 if(i1.le.20)ii=2
7821 i1=i1/ii*ii
7822 i2=i2/ii*ii+ii
7823 do i=i1,i2
7824 l=1+i-i1
7825 datx(l)=i
7826 daty(l)=hismu(j,i)/mus
7827 enddo
7828 jx=1+i2-i1
7829 if(ixr.eq.0)then
7830 x1=i1
7831 x2=i2
7832 else
7833 x1=xx1
7834 x2=xx2
7835 endif
7836 write(ifhi,'(a,2e11.3)')'openhisto xrange',x1,x2
7837 write(ifhi,'(a)') 'htyp lin xmod lin ymod log'
7838 write(ifhi,'(a)') 'text 0 0 "title id='//chid//'"'
7839 write(ifhi,'(a)') 'text 0 0 "xaxis multiplicity n "'
7840 write(ifhi,'(a)') 'text 0 0 "yaxis dN/dn"'
7841 write(ifhi,'(a)') 'text 0.30 0.25 "N?MC!='//cyield//'"'
7842 write(ifhi,'(a)') 'array 2'
7843 do i=1,jx
7844 write(ifhi,'(2e12.4)') datx(i),daty(i)
7845 enddo
7846 write(ifhi,'(a)') ' endarray'
7847 write(ifhi,'(a)') 'closehisto'
7848
7849 endif
7850 enddo
7851
7852 endif
7853
7854 return
7855 end
7856
7857
7858 subroutine xhnbmz
7859
7860
7861
7862
7863
7864
7865
7866
7867
7868
7869
7870
7871
7872
7873
7874 include 'epos.inc'
7875 parameter(maxp=500)
7876 common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
7877 common/ctst/psulog,wtulog
7878 parameter (mspecs=56)
7879 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
7880 parameter (nhismu=500)
7881 common/cflac/ifok(nflav,mspecs),ifoa(nflav)
7882 real datx(nhismu),datyu(nhismu)
7883 character cyieur*9
7884 real pzlog(nhismu)
7885 double precision spelog,cc,bb,dsu
7886 common/cyield/yield
7887 character*3 htyp
7888
7889 idcode=nint(xpar1)
7890 x1=xpar2
7891 x2=xpar3
7892 i1=nint(xpar2)
7893 i2=nint(xpar3)
7894 ii1=nint(xpar4)
7895 ii2=nint(xpar5)
7896 ih=nint(xpar6)
7897 htyp='lin'
7898 if(ih.eq.1)htyp='lfu'
7899 if(ih.eq.2)htyp='ldo'
7900 if(ih.eq.3)htyp='lda'
7901 if(ih.eq.4)htyp='ldd'
7902 itmax=nint(xpar7)
7903
7904 wtrlog=-1e30
7905 do i=ii1,ii2
7906 if(i.ge.2)then
7907 np=i
7908 do k=1,np
7909 ident(k)=110
7910 enddo
7911 call hnbtst(0)
7912 wtzlog=wtulog
7913 if(ioflac.eq.0)call hnbspg(keu,ked,kes,kec,keb,ket,0,np,spelog)
7914 if(ioflac.ne.0)call hnbspf(keu,ked,kes,kec,keb,ket,0,np,spelog)
7915 wtulog=wtulog+spelog
7916 else
7917 wtzlog=-1000
7918 wtulog=-1000
7919 endif
7920 pzlog(1+i-ii1)=wtzlog
7921 datyu(1+i-ii1)=wtulog
7922 wtrlog=max(wtrlog,wtulog)
7923 enddo
7924 yield=0
7925 su=0
7926 do i=ii1,ii2
7927 l=1+i-ii1
7928 pzlog(l)=pzlog(l)-wtrlog
7929 datyu(l)=datyu(l)-wtrlog
7930 if(datyu(l).gt.-50.)then
7931 datyu(l)=exp(datyu(l))
7932 else
7933 datyu(l)=exp(-50.)
7934 endif
7935 yield=yield+i*datyu(l)
7936 su=su+datyu(l)
7937 enddo
7938 yield=yield/su
7939 do i=ii1,ii2
7940 l=1+i-ii1
7941 datx(l)=i
7942 datyu(l)=datyu(l)/su
7943 enddo
7944 jx=1+ii2-ii1
7945 write(cyieur,'(f9.4)')yield
7946
7947 if(idcode.eq.0.and.itmax.eq.0)then
7948 write(ifhi,'(a,2e11.3)')'openhisto xrange',x1,x2
7949 write(ifhi,'(a)') 'htyp '//htyp//' xmod lin ymod log'
7950 write(ifhi,'(a)') 'text 0.30 0.15 "N?ana!='//cyieur//'"'
7951 write(ifhi,'(a)') 'array 2'
7952 do i=1,jx
7953 write(ifhi,'(2e12.4)') datx(i),datyu(i)
7954 enddo
7955 write(ifhi,'(a)') ' endarray'
7956 write(ifhi,'(a)') 'closehisto'
7957 elseif(idcode.eq.0)then
7958 write(ifhi,'(a,2e11.3)')'openhisto xrange',0.,itmax*1.
7959 write(ifhi,'(a)') 'htyp '//htyp//' xmod lin ymod lin'
7960 write(ifhi,'(a)') 'array 2'
7961 itm=20
7962 do i=1,itm
7963 write(ifhi,'(2e12.4)') (i-1.)*itmax/(itm-1.),yield
7964 enddo
7965 write(ifhi,'(a)') ' endarray'
7966 write(ifhi,'(a)') 'closehisto'
7967 endif
7968
7969 if(idcode.eq.0)return
7970
7971 do j=1,nspecs
7972 if(idcode.eq.ispecs(j))then
7973
7974 wtrlog=-1e30
7975 do i=i1,i2
7976 l=1+i-i1
7977 datx(l)=i
7978 enddo
7979 yield=0
7980 suj=0
7981 dsu=su
7982 do i=i1,i2
7983 l=1+i-i1
7984 bb=0
7985 nfi=0
7986 do ntot=max(i+1,ii1),min(i2*nspecs,ii2)
7987 nfi=nfi+1
7988 cc=1d0
7989 do kc=1,i
7990 cc=cc*(1.+ntot-kc)/kc*gspecs(j)
7991 enddo
7992 ku=keu-i*ifok(1,j)
7993 kd=ked-i*ifok(2,j)
7994 ks=kes-i*ifok(3,j)
7995 kc=kec-i*ifok(4,j)
7996 kb=keb-i*ifok(5,j)
7997 kt=ket-i*ifok(6,j)
7998 if(ioflac.eq.0)call hnbspg(ku,kd,ks,kc,kb,kt,j,ntot-i,spelog)
7999 if(ioflac.ne.0)call hnbspf(ku,kd,ks,kc,kb,kt,j,ntot-i,spelog)
8000 cc=cc*dexp(spelog)
8001 bb=bb+cc*dexp(1.d0*pzlog(1+ntot-ii1))/dsu
8002 enddo
8003 datyu(l)=bb
8004 yield=yield+i*datyu(l)
8005 suj=suj+datyu(l)
8006 enddo
8007 yield=yield/suj
8008 jx=1+i2-i1
8009 write(cyieur,'(f9.4)')yield
8010
8011 if(itmax.eq.0)then
8012 write(ifhi,'(a,2e11.3)')'openhisto xrange',x1,x2
8013 write(ifhi,'(a)') 'htyp '//htyp//' xmod lin ymod log'
8014 write(ifhi,'(a)') 'text 0.30 0.15 "N?ana!='//cyieur//'"'
8015 write(ifhi,'(a)') 'array 2'
8016 do i=1,jx
8017 write(ifhi,'(2e12.4)') datx(i),datyu(i)
8018 enddo
8019 write(ifhi,'(a)') ' endarray'
8020 write(ifhi,'(a)') 'closehisto'
8021 else
8022 write(ifhi,'(a,2e11.3)')'openhisto xrange',0.,itmax*1.
8023 write(ifhi,'(a)') 'htyp '//htyp//' xmod lin ymod lin'
8024 write(ifhi,'(a)') 'array 2'
8025 itm=20
8026 do i=1,itm
8027 write(ifhi,'(2e12.4)') (i-1.)*itmax/(itm-1.),yield
8028 enddo
8029 write(ifhi,'(a)') ' endarray'
8030 write(ifhi,'(a)') 'closehisto'
8031 endif
8032
8033 return
8034
8035 endif
8036 enddo
8037
8038 end
8039
8040
8041 subroutine xhnbte(iii)
8042
8043
8044
8045
8046
8047
8048
8049
8050
8051
8052
8053
8054
8055
8056
8057
8058
8059
8060
8061
8062
8063
8064
8065
8066
8067
8068
8069
8070 include 'epos.inc'
8071 parameter(maxit=50000)
8072 common/count/nacc,nrej,naccit(maxit),nptot,npit(maxit)
8073 common/citer/iter,itermx
8074 common /clatt/nlattc,npmax
8075 common/cgctot/rmstot,ptltot
8076 parameter (mspecs=56)
8077 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
8078 common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
8079 parameter (nbin=500)
8080 common/cdat/ data(nbin),datb(nbin),datc(nbin),datd(nbin)
8081 real dev(maxit)
8082 character cobs*5,cnc*5,cdz*5,czer*5
8083 *,cmom*5,cnp*7,cen*7,cvol*7,clatt*5,cit*5
8084 common/ctaue/taue
8085
8086 if(ioceau.ne.1)stop'STOP: ioceau=1 required'
8087 if(iii.eq.0.and.iappl.ne.4)stop'STOP: iappl=4 required'
8088 if(iii.gt.0.and.iappl.ne.1)stop'STOP: iappl=1 required'
8089
8090 if(iii.lt.0)jjj=nint(xpar1)
8091
8092 id=0
8093 ish0=ish
8094
8095
8096
8097 if(iii.ge.0)then
8098
8099
8100 if(iii.gt.0)nrclu=nrclu+1
8101 if(nrclu.gt.500)return
8102
8103
8104
8105 xnptot=nptot
8106 avnp=xnptot/(itermx-iternc)
8107 if(ish.ge.9)write(ifch,*)'event:',nrevt,' droplet:',nrclu
8108 *,' avnp:',avnp
8109
8110
8111
8112 corzer=0.0
8113 do i=iternc+1,itermx
8114 dev(i)=npit(i)-avnp
8115 corzer=corzer+dev(i)**2
8116 enddo
8117 corzer=corzer/(itermx-iternc)
8118 if(ish.ge.9)write(ifch,*)'c_0:',corzer
8119
8120
8121
8122 corone=0.0
8123 do i=iternc+1,itermx-1
8124 corone=corone+dev(i)*dev(i+1)
8125 enddo
8126 corone=corone/(itermx-iternc-1)
8127
8128
8129
8130 if(corone.gt.1.e-30.and.corzer.gt.1.e-30)then
8131 r=alog(corone)-alog(corzer)
8132 if(ish.ge.9)write(ifch,*)'log rho_1:',r
8133 taui=(-1.)/r
8134 else
8135 taui=0.
8136 endif
8137 if(ish.ge.9)write(ifch,*)'tau_init:',taui
8138
8139
8140
8141 if(taue.eq.0.0)then
8142 e=tecm/volu
8143 b=1.1*(e+0.33)**0.66
8144 a=13.*(e+0.13)**(-0.65)
8145 tm=34.*(e+0.65)**(-0.61)
8146 t=a+b*volu
8147 taue=max(t,tm)
8148 endif
8149
8150
8151
8152 xa=nacc
8153 ya=itermx
8154 accrat=xa/ya
8155
8156
8157
8158 if(iii.eq.0)then
8159 if(iozevt.gt.0)then
8160 data(nrevt)=iozero
8161 else
8162 data(nrevt)=nrevt
8163 endif
8164 datb(nrevt)=taui
8165 datc(nrevt)=accrat
8166 datd(nrevt)=taue
8167 else
8168 data(nrclu)=nrclu
8169 datb(nrclu)=taui-taue
8170 datc(nrclu)=accrat
8171 datd(nrclu)=avnp
8172 endif
8173
8174
8175 elseif(iii.lt.0.and.iappl.eq.4)then
8176
8177
8178 write(cmom,'(i3)')iomom
8179 write(cen,'(f7.3)')tecm
8180 if(ioobsv.eq.0)then
8181 write(cnp,'(f7.3)')ptltot
8182 else
8183 do i=1,nspecs
8184 if(ioobsv.eq.ispecs(i))id=i
8185 enddo
8186 write(cnp,'(f7.3)')ptlngc(id)
8187 endif
8188 write(cvol,'(f7.3)')volu
8189 write(clatt,'(i3)')nlattc
8190 write(cit,'(i5)')itermx
8191 if(ioobsv.eq.0)then
8192 write(cobs,'(a)')'all'
8193 else
8194 write(cobs,'(i5)')ioobsv
8195 endif
8196 write(cnc,'(i5)')iternc
8197 if(iozevt.eq.0)write(czer,'(i5)')iozero
8198 if(iozevt.gt.0)write(cdz,'(i5)')iozinc
8199
8200 x1=1
8201 x2=nevent
8202
8203 if(jjj.eq.1)then
8204
8205 write(ifhi,'(a)') 'openhisto'
8206 write(ifhi,'(a)') 'htyp lin xmod lin ymod lin'
8207 if(iozevt.gt.0)then
8208 write(ifhi,'(a)') 'text 0 0 "xaxis iozero"'
8209 else
8210 write(ifhi,'(a)') 'text 0 0 "xaxis event"'
8211 endif
8212 write(ifhi,'(a)') 'text 0 0 "yaxis [t]?exp!"'
8213 write(ifhi,'(a)') 'text 0.05 0.95 "E='//cen//'"'
8214 write(ifhi,'(a)') 'text 0.2 0.95 "V='//cvol//'"'
8215 write(ifhi,'(a)') 'text 0.35 0.95 "N?g!='//cnp//'"'
8216 write(ifhi,'(a)') 'text 0.55 0.95 "observable '//cobs//'"'
8217 write(ifhi,'(a,2e11.3)')'xrange',x1,x2
8218 write(ifhi,'(a)') 'array 2'
8219 do j=1,nevent
8220 write(ifhi,'(2e12.4)')data(j),datb(j)
8221 enddo
8222 write(ifhi,'(a)') ' endarray'
8223 write(ifhi,'(a)') 'closehisto plot 0-'
8224
8225 write(ifhi,'(a)') 'openhisto'
8226 write(ifhi,'(a)') 'htyp lin xmod lin ymod lin'
8227 write(ifhi,'(a,2e11.3)')'xrange',x1,x2
8228 write(ifhi,'(a)') 'array 2'
8229 do j=1,nevent
8230 write(ifhi,'(2e12.4)')data(j),datd(j)
8231 enddo
8232 write(ifhi,'(a)') ' endarray'
8233 write(ifhi,'(a)') 'closehisto'
8234
8235 elseif(jjj.eq.2)then
8236
8237 write(ifhi,'(a)') 'openhisto'
8238 write(ifhi,'(a)') 'htyp lin xmod lin ymod lin'
8239 if(iozevt.gt.0)then
8240 write(ifhi,'(a)') 'text 0 0 "xaxis iozero"'
8241 else
8242 write(ifhi,'(a)') 'text 0 0 "xaxis event"'
8243 endif
8244 write(ifhi,'(a)') 'text 0 0 "yaxis acceptence rate"'
8245 write(ifhi,'(a)') 'text 0.05 0.95 "iomom= '//cmom//'"'
8246 write(ifhi,'(a)') 'text 0.2 0.95 "nlattc= '//clatt//'"'
8247 if(iozevt.eq.0)
8248 *write(ifhi,'(a)') 'text 0.35 0.95 "iozero= '//czer//'"'
8249 write(ifhi,'(a)') 'text 0.55 0.95 "itermx= '//cit//'"'
8250 write(ifhi,'(a)') 'text 0.75 0.95 "iternc= '//cnc//'"'
8251 if(iozevt.gt.0)
8252 *write(ifhi,'(a)') 'text 0.35 0.95 "dzero= '//cdz//'"'
8253 if(iorejz.eq.1)
8254 *write(ifhi,'(a)') 'text 0.25 0.05 "zeros rejected !"'
8255 if(ioinco.ge.1)then
8256 write(ifhi,'(a)') 'text 0.05 0.05 "hot start"'
8257 else
8258 write(ifhi,'(a)') 'text 0.05 0.05 "cold start"'
8259 endif
8260 write(ifhi,'(a,2e11.3)')'xrange',x1,x2
8261 write(ifhi,'(a)') 'array 2'
8262 do j=1,nevent
8263 write(ifhi,'(2e12.4)')data(j),datc(j)
8264 enddo
8265 write(ifhi,'(a)') ' endarray'
8266 write(ifhi,'(a)') 'closehisto'
8267
8268 endif
8269
8270
8271 elseif(iii.lt.0.and.iappl.eq.1)then
8272
8273
8274 if(ioobsv.eq.0)then
8275 write(cobs,'(a)')'all'
8276 else
8277 write(cobs,'(i5)')ioobsv
8278 endif
8279
8280 x1=1
8281 x2=nrclu
8282
8283 if(jjj.eq.1)then
8284
8285 write(ifhi,'(a)') 'openhisto'
8286 write(ifhi,'(a)') 'htyp lin xmod lin ymod lin'
8287 write(ifhi,'(a)') 'text 0 0 "xaxis droplet"'
8288 write(ifhi,'(a)') 'text 0 0 "yaxis [D][t]?exp!"'
8289 write(ifhi,'(a)') 'text 0.05 0.91 "[D][t]?exp!=[t]?measured!
8290 *-[t]?parametrized"'
8291 write(ifhi,'(a,2e11.3)')'xrange',x1,x2
8292 write(ifhi,'(a,a,a)')'yrange',' auto',' auto'
8293 write(ifhi,'(a)') 'array 2'
8294 do j=1,nrclu
8295 write(ifhi,'(2e12.4)')data(j),datb(j)
8296 enddo
8297 write(ifhi,'(a)') ' endarray'
8298 write(ifhi,'(a)') 'closehisto'
8299
8300 elseif(jjj.eq.2)then
8301
8302 write(ifhi,'(a)') 'openhisto'
8303 write(ifhi,'(a)') 'htyp lin xmod lin ymod lin'
8304 write(ifhi,'(a)') 'text 0 0 "xaxis droplet"'
8305 write(ifhi,'(a)') 'text 0 0 "yaxis N?obs!"'
8306 write(ifhi,'(a)') 'text 0.05 0.95 "observable '//cobs//'"'
8307 write(ifhi,'(a,2e11.3)')'xrange',x1,x2
8308 write(ifhi,'(a)') 'array 2'
8309 do j=1,nrclu
8310 write(ifhi,'(2e12.4)')data(j),datd(j)
8311 enddo
8312 write(ifhi,'(a)') ' endarray'
8313 write(ifhi,'(a)') 'closehisto'
8314
8315 elseif(jjj.eq.3)then
8316
8317 write(ifhi,'(a)') 'openhisto'
8318 write(ifhi,'(a)') 'htyp lin xmod lin ymod lin'
8319 write(ifhi,'(a)') 'text 0 0 "xaxis droplet"'
8320 write(ifhi,'(a)') 'text 0 0 "yaxis accep. rate"'
8321 write(ifhi,'(a,2e11.3)')'xrange',x1,x2
8322 write(ifhi,'(a)') 'array 2'
8323 do j=1,nrclu
8324 write(ifhi,'(2e12.4)')data(j),datc(j)
8325 enddo
8326 write(ifhi,'(a)') ' endarray'
8327 write(ifhi,'(a)') 'closehisto'
8328
8329 endif
8330
8331
8332 endif
8333
8334
8335 ish=ish0
8336 return
8337 end
8338
8339
8340 subroutine xhnbti(iii)
8341
8342
8343
8344
8345
8346
8347
8348
8349
8350
8351
8352
8353
8354
8355
8356
8357
8358
8359
8360
8361
8362
8363
8364
8365
8366
8367
8368
8369
8370 include 'epos.inc'
8371 parameter(maxit=50000)
8372 common/count/nacc,nrej,naccit(maxit),nptot,npit(maxit)
8373 common/citer/iter,itermx
8374 parameter(maxp=500)
8375 common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
8376 common /clatt/nlattc,npmax
8377 common/cgctot/rmstot,ptltot
8378 parameter (mspecs=56)
8379 common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
8380 common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
8381 parameter (nbin=500)
8382 common/cdat2/data(nbin),datb(nbin),datc(nbin),datd(nbin)
8383 *,date(nbin),datf(nbin),datg(nbin),dath(nbin)
8384 common/cdat3/datx(nbin),daty(nbin),datz(nbin),datr(nbin)
8385 *,dats(nbin)
8386 real corfct(maxit),dev(maxit)
8387 character cobs*5,cdz*5,ccuev*5,cmpar*3,ctau*7
8388 character cmom*5,cnp*7,cen*7,cvol*7,clatt*5,cit*5,cavnp*7
8389 character cnacc*10,cnrej*10,caver*10,cioz*5,ciom*3,cnlat*5
8390
8391 if(iociau.ne.1)stop'STOP: iociau=1 required'
8392 if(iii.eq.0.and.iappl.ne.4)stop'STOP: iappl=4 required'
8393 if(iii.gt.0)stop'STOP: iii>0 not supported'
8394
8395 jjj=nint(xpar1)
8396 id=0
8397
8398
8399 if(iii.eq.0)then
8400
8401
8402
8403
8404 xnptot=nptot
8405 avnp=xnptot/(itermx-iternc)
8406 if(ish.ge.9)write(ifch,*)'event:',nrevt,' avnp:',avnp
8407
8408
8409
8410 corzer=0.0
8411 do i=iternc+1,itermx
8412 dev(i)=npit(i)-avnp
8413 if(ish.ge.9)write(ifch,*)'i:',i,' dev_i:',dev(i)
8414 corzer=corzer+dev(i)**2
8415 enddo
8416 corzer=corzer/(itermx-iternc)
8417 if(ish.ge.9)write(ifch,*)'c_0:',corzer
8418
8419
8420
8421 nt=itermx-iternc-1
8422 do it=1,nt
8423 corfct(it)=0.0
8424 do i=iternc+1,itermx-it
8425 corfct(it)=corfct(it)+dev(i)*dev(i+it)
8426 enddo
8427 corfct(it)=corfct(it)/(itermx-iternc-it)
8428 if(it.le.10.and.ish.ge.9)
8429 *write(ifch,*)'t:',it,' c_t:',corfct(it)
8430 enddo
8431
8432
8433
8434 if(corfct(1).gt.1.e-30.and.corzer.gt.1.e-30)then
8435 r=alog(corfct(1))-alog(corzer)
8436 if(ish.ge.9)write(ifch,*)'log rho_1:',r
8437 taui=(-1.)/r
8438 else
8439 taui=0.
8440 endif
8441 if(ish.ge.9)write(ifch,*)'tau_init:',taui
8442
8443
8444
8445 k=1
8446 mpar=iompar
8447 tau=taui
8448 taux=taui
8449 taum=0.0
8450
8451 mcut=0
8452 if(ish.ge.9)write(ifch,*)'initial tau:',tau,' c_M:',mpar
8453
8454 if(corzer.gt.1.e-30)then
8455
8456 5 mcut=mpar*abs(taux)
8457 tauo=tau
8458 tau=.5
8459 do it=1,mcut
8460 tau=tau+corfct(it)/corzer
8461 enddo
8462 taum=taum+tau
8463 taux=taum/k
8464 if(ish.ge.9)write(ifch,*)'iteration:',k,' M:',mcut,' tau:',tau
8465 if(mcut.lt.(mpar*tau).or.mcut.gt.(10.*tau))then
8466 dt=abs(tau-tauo)
8467 if(k.lt.20.and.dt.gt.0.2)then
8468 k=k+1
8469 goto5
8470 endif
8471 endif
8472 mcut=mpar*abs(taux)
8473 if(ish.ge.9)write(ifch,*)'tau_mean:',taux,' M:',mcut
8474 tau=0.5
8475 do it=1,mcut
8476 tau=tau+corfct(it)/corzer
8477 enddo
8478
8479 endif
8480
8481 vtau=(2.*mcut+1.)*2./(itermx-iternc)*tau**2
8482 stau=0.0
8483 if(vtau.ge.0.0)stau=sqrt(vtau)
8484 if(ish.ge.9)
8485 *write(ifch,*)'tau_int:',tau,' var:',vtau,' sig:',stau
8486
8487
8488
8489 vobs=2.*tau*corzer/(itermx-iternc)
8490 sobs=0.0
8491 if(vobs.ge.0.0)sobs=sqrt(vobs)
8492
8493
8494
8495 if(ioobsv.eq.0)then
8496 datf(nrevt)=ptltot
8497 else
8498 do j=1,np
8499 if(ioobsv.eq.ispecs(j))id=j
8500 enddo
8501 datf(nrevt)=ptlngc(id)
8502 endif
8503 datb(nrevt)=tau
8504 datc(nrevt)=stau
8505 date(nrevt)=sobs
8506 datd(nrevt)=avnp
8507 if(iozevt.gt.0)then
8508 data(nrevt)=iozero
8509 else
8510 data(nrevt)=nrevt
8511 endif
8512
8513
8514 if(iosngl.eq.nrevt+1)then
8515
8516
8517 nb=itermx/iterpl
8518 if(nb.gt.nbin)nb=nbin
8519
8520 datx(1)=iterpl/2
8521 daty(1)=naccit(1)
8522 datz(1)=1-naccit(1)
8523 if(iterpl.ge.2)then
8524 do j=1,iterpl-1
8525 daty(1)=daty(1)+naccit(1+j)
8526 datz(1)=datz(1)+1-naccit(1+j)
8527 enddo
8528 endif
8529 datr(1)=daty(1)/iterpl
8530 dats(1)=datz(1)/iterpl
8531 do i=2,nb
8532 datx(i)=datx(i-1)+iterpl
8533 daty(i)=daty(i-1)
8534 datz(i)=datz(i-1)
8535 do j=1,iterpl
8536 daty(i)=daty(i)+naccit((i-1)*iterpl+j)
8537 datz(i)=datz(i)+1-naccit((i-1)*iterpl+j)
8538 enddo
8539 datr(i)=daty(i)/i/iterpl
8540 dats(i)=datz(i)/i/iterpl
8541 enddo
8542 b=nacc
8543 c=itermx
8544 avrate=b/c
8545 write(cnacc,'(i6)')nacc
8546 write(cnrej,'(i6)')nrej
8547 write(caver,'(f5.3)')avrate
8548 write(cioz,'(i5)')iozero
8549 write(ciom,'(i3)')iomom
8550 write(cnlat,'(i5)')nlattc
8551 x1=datx(1)
8552 x2=datx(nb)
8553
8554 write(ifhi,'(a)') 'newpage zone 1 3 1 openhisto'
8555 write(ifhi,'(a)') 'htyp lin xmod lin ymod lin'
8556 write(ifhi,'(a)') 'text 0 0 "xaxis iterations"'
8557 write(ifhi,'(a)') 'text 0 0 "yaxis acceptence rate"'
8558 write(ifhi,'(a)') 'text 0.6 0.5 "accepted '//cnacc//'"'
8559 write(ifhi,'(a)') 'text 0.6 0.4 "rejected '//cnrej//'"'
8560 write(ifhi,'(a)') 'text 0.6 0.3 "aver. rate '//caver//'"'
8561 write(ifhi,'(a)') 'text 0.4 0.5 "nlattc='//cnlat//'"'
8562 write(ifhi,'(a)') 'text 0.4 0.4 "iozero='//cioz//'"'
8563 write(ifhi,'(a)') 'text 0.4 0.3 "iomom='//ciom//'"'
8564 write(ifhi,'(a,2e11.3)')'xrange',x1,x2
8565 write(ifhi,'(a)') 'array 2'
8566 do j=1,nb
8567 write(ifhi,'(2e12.4)')datx(j),datr(j)
8568 enddo
8569 write(ifhi,'(a)') ' endarray'
8570 write(ifhi,'(a)') 'closehisto plot 0-'
8571
8572 write(ifhi,'(a)') 'openhisto'
8573 write(ifhi,'(a,2e11.3)')'xrange',x1,x2
8574 write(ifhi,'(a)') 'array 2'
8575 do j=1,nb
8576 write(ifhi,'(2e12.4)')datx(j),dats(j)
8577 enddo
8578 write(ifhi,'(a)') ' endarray'
8579 write(ifhi,'(a)') 'closehisto plot 0'
8580
8581 m=min(mcut,500)
8582 do i=1,m
8583 datg(i)=i
8584 dath(i)=1000.
8585 if(corzer.gt.1.e-30)dath(i)=corfct(i)/corzer
8586 enddo
8587 write(ccuev,'(i5)')nrevt+1
8588 write(cmpar,'(i3)')mpar
8589 write(ctau,'(i7)')tau
8590 x1=1.
8591 x2=m
8592
8593 write(ifhi,'(a)') 'openhisto'
8594 write(ifhi,'(a)') 'htyp lin xmod lin ymod lin'
8595 write(ifhi,'(a)') 'text 0 0 "xaxis t"'
8596 write(ifhi,'(a)') 'text 0 0 "yaxis correl. func."'
8597 write(ifhi,'(a)') 'text 0.8 0.95 "event '//ccuev//'"'
8598 write(ifhi,'(a)')'text 0.05 0.95 "window parameter= '//cmpar//'"'
8599 write(ifhi,'(a)') 'text 0.35 0.95 "tau= '//ctau//'"'
8600 write(ifhi,'(a,2e11.3)')'xrange',x1,x2
8601 write(ifhi,'(a,a,a)')'yrange',' auto',' auto'
8602 write(ifhi,'(a)') 'array 2'
8603 do j=1,m
8604 write(ifhi,'(2e12.4)')datg(j),dath(j)
8605 enddo
8606 write(ifhi,'(a)') ' endarray'
8607 write(ifhi,'(a)') 'closehisto plot 0'
8608
8609
8610 endif
8611
8612
8613
8614 elseif(iii.lt.0)then
8615
8616
8617 write(cmom,'(i3)')iomom
8618 if(ioobsv.eq.0)then
8619 write(cnp,'(f7.3)')ptltot
8620 else
8621 do j=1,np
8622 if(ioobsv.eq.ispecs(j))id=j
8623 enddo
8624 write(cnp,'(f7.3)')ptlngc(id)
8625 endif
8626 write(cen,'(f7.3)')tecm
8627 write(cvol,'(f7.3)')volu
8628 write(clatt,'(i3)')nlattc
8629 write(cit,'(i5)')itermx
8630 write(cavnp,'(f7.3)')avnp
8631 if(iozevt.gt.0)
8632 *write(cdz,'(i5)')iozinc
8633 write(cmpar,'(i3)')mpar
8634 if(ioobsv.eq.0)then
8635 write(cobs,'(a)')'all'
8636 else
8637 write(cobs,'(i5)')ioobsv
8638 endif
8639
8640 x1=data(1)
8641 x2=data(nevent)
8642
8643 if(jjj.eq.1)then
8644
8645 write(ifhi,'(a)') 'openhisto'
8646 write(ifhi,'(a)') 'htyp pnt xmod lin ymod lin'
8647 if(iozevt.gt.0)then
8648 write(ifhi,'(a)') 'text 0 0 "xaxis iozero"'
8649 else
8650 write(ifhi,'(a)') 'text 0 0 "xaxis event"'
8651 endif
8652 write(ifhi,'(a)') 'text 0 0 "yaxis [t]?int!"'
8653 write(ifhi,'(a)')'text 0.05 0.95 "window parameter '//cmpar//'"'
8654 if(iozevt.gt.0)
8655 *write(ifhi,'(a)') 'text 0.8 0.95 "dzero= '//cdz//'"'
8656 write(ifhi,'(a,2e11.3)')'xrange',x1,x2
8657 write(ifhi,'(a)') 'array 3'
8658 do j=1,nevent
8659 write(ifhi,'(3e12.4)')data(j),datb(j),datc(j)
8660 enddo
8661 write(ifhi,'(a)') ' endarray'
8662 write(ifhi,'(a)') 'closehisto'
8663
8664 elseif(jjj.eq.2)then
8665
8666 write(ifhi,'(a)') 'openhisto'
8667 write(ifhi,'(a)') 'htyp pnt xmod lin ymod lin'
8668 if(iozevt.gt.0)then
8669 write(ifhi,'(a)') 'text 0 0 "xaxis iozero"'
8670 else
8671 write(ifhi,'(a)') 'text 0 0 "xaxis event"'
8672 endif
8673 write(ifhi,'(a)') 'text 0 0 "yaxis multiplicity"'
8674 write(ifhi,'(a)') 'text 0.05 0.95 "E='//cen//'"'
8675 write(ifhi,'(a)') 'text 0.2 0.95 "V='//cvol//'"'
8676 write(ifhi,'(a)') 'text 0.35 0.95 "N?g!='//cnp//'"'
8677 write(ifhi,'(a)') 'text 0.55 0.95 "observable '//cobs//'"'
8678 write(ifhi,'(a,2e11.3)')'xrange',x1,x2
8679 write(ifhi,'(a,a,a)')'yrange',' auto',' auto'
8680 write(ifhi,'(a)') 'array 3'
8681 do j=1,nevent
8682 write(ifhi,'(3e12.4)')data(j),datd(j),date(j)
8683 enddo
8684 write(ifhi,'(a)') ' endarray'
8685 write(ifhi,'(a)') 'closehisto plot 0-'
8686
8687
8688 write(ifhi,'(a)') 'openhisto'
8689 write(ifhi,'(a)') 'htyp lda xmod lin ymod lin'
8690 write(ifhi,'(a)') 'array 2'
8691 do j=1,nevent
8692 write(ifhi,'(2e12.4)')data(j),datf(j)
8693 enddo
8694 write(ifhi,'(a)') ' endarray'
8695 write(ifhi,'(a)') 'closehisto'
8696
8697 endif
8698
8699
8700 endif
8701
8702
8703 return
8704 end
8705
