Back to home page

Project CMSSW displayed by LXR

 
 

    


File indexing completed on 2021-02-14 13:07:29

0001 c----------------------------------------------------------------------
0002       subroutine hnbaaa(ip,iret)  !former hnbaaa156 from epos-yyy
0003 c----------------------------------------------------------------------
0004 c  microcanonical decay of cluster ip via loop over hnbmet
0005 c----------------------------------------------------------------------
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 c      write(ifch,*)'droplet uds=',keu,ked,kes,'   E=',pptl(5,ip)
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 c      if(yco.gt.0..and.tecmor.gt.aumin) then
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 c          if(dta.ne.0.)then
0263 c            theta=0.5*atan(abs(xy)/abs(dta))
0264 c            if(    xy.gt.0..and.dta.gt.0.)then
0265 c              theta=theta
0266 c            elseif(xy.lt.0..and.dta.gt.0.)then
0267 c              theta=-theta
0268 c            elseif(xy.gt.0..and.dta.lt.0.)then
0269 c              theta=pi-theta
0270 c            elseif(xy.lt.0..and.dta.lt.0.)then
0271 c              theta=theta-pi
0272 c            endif
0273 c          else
0274 c            theta=2.*pi*rangen()
0275 c          endif
0276           !eccx=(yy-xx)/(yy+xx)
0277           yy=ev1
0278           xx=ev2
0279           ecc=(yy-xx)/(yy+xx)
0280 c          print*,'AA',ecc,theta
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 c          bp=sqrt(pcm(1,i)**2+pcm(2,i)**2)**yradpp
0320 cc          bp=sqrt(amass(i)**2+pcm(1,i)**2+pcm(2,i)**2)**yradpp
0321 c          be(1)=pcm(1,i)-bp*(aa*bex+cc*bey)
0322 c          be(2)=pcm(2,i)-bp*(bb*bex+dd*bey)
0323 c          be(4)=sqrt(be(1)**2+be(2)**2+pcm(3,i)**2
0324 c     *           +amass(i)**2)
0325 c          en=be(4)
0326 c          energ=energ+en
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 c          goto 300
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 c          bp=sqrt(pcm(1,i)**2+pcm(2,i)**2)**yradpp
0353 cc          bp=sqrt(amass(i)**2+pcm(1,i)**2+pcm(2,i)**2)
0354 c          pcm(1,i)=pcm(1,i)-bp*(aa*bex+cc*bey)
0355 c          pcm(2,i)=pcm(2,i)-bp*(bb*bex+dd*bey)
0356 c          pcm(4,i)=sqrt(pcm(1,i)**2+pcm(2,i)**2+pcm(3,i)**2
0357 c     *           +amass(i)**2)
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 c          write(6,*)'ipass,scal,e,esoll:'
0374 c     $         ,ipass,scal,sum,esoll
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 c protection against very high momentum particle (it can happen very very boosted cluster (which do no really make sense anyway))
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 c####################################################################################
0467 c####################################################################################
0468 c####################################################################################
0469 c####################################################################################
0470 c####################################################################################
0471 c#########                                                                  #########
0472 c#########                  hnb and hgc routines                            #########
0473 c#########                                                                  #########
0474 c####################################################################################
0475 c####################################################################################
0476 c####################################################################################
0477 c####################################################################################
0478 c####################################################################################
0479 
0480 
0481 c-----------------------------------------------------------------------
0482       subroutine hgcaaa
0483 c-----------------------------------------------------------------------
0484 c hadronic resonance gas in grand canonical treatment
0485 c returns T, chemical potentials and hadronic yield
0486 c (hadron chemical potentials as combinations of quark chemical potentials)
0487 c
0488 c input:
0489 c   iostat: 1: Boltzmann approximation, 0: quantum statistics  /metr3/
0490 c   tecm:                    droplet energy      /confg/
0491 c   volu:                    droplet volume      /confg/
0492 c   keu ked kes kec keb ket: net flavor number   /drop5/
0493 c
0494 c output:
0495 c   tem    : temperature [GeV]                            /cgchg/
0496 c   chem(1:nflav): quark chem. pot. [GeV]                 /cflav/
0497 c   chemgc(1:nspecs): hadron chem. pot. [GeV]             /cgchg/
0498 c   ptlngc(1:nspecs): hadron number                       /cgchg/
0499 c   rmsngc(1:nspecs): standard deviation of hadron number /cgchg/
0500 c
0501 c exact treatment (iostat=0):
0502 c for massive hadrons     : first in Boltzmann approximation with analytical
0503 c                           expressions for particle and energy densities,
0504 c                           then by using quantum statistics in integral form,
0505 c                           extracting mu and T using numerical integration
0506 c                           and an iterative procedure to solve for mu, T
0507 c for massless hadrons    : using analytic expressions for massles particles
0508 c                           and employing the  same algorithm as for massive
0509 c-----------------------------------------------------------------------
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 c     initialization
0528 c     --------------
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 c     initial T (m=0, baryon free)
0594 c     -------------------------------
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 c     search for temperature (chem=const)
0644 c     -----------------------------------
0645       idt=0
0646       temo=tem
0647 
0648        if(iospec.eq.iug)then
0649 
0650 c     massless particles
0651 c     ------------------
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 c     Boltzmann approxiamtion (massive particles)
0669 c     -------------------------------------------
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 c     search for chemical potentials (tem=const)
0694 c     ------------------------------------------
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 c     massless particles
0704 c     ------------------
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 c     Boltzmann approxiamtion (massive particles)
0714 c     -------------------------------------------
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 c     new hadron chem. potentials
0732 c     ---------------------------
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 c     checking results
0772 c     ----------------
0773       if(ish.ge.5)call hgcchb
0774 
0775 c     particle yield
0776 c     --------------
0777       call hgcpyi(1)
0778 
0779 c     checking flavor conservation
0780 c     ----------------------------
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 c     continue or return approximate values
0793 c     -------------------------------------
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 c     quantum statistics
0809 c     ------------------
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 c     new temperature
0824 c     ---------------
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 c     new quark chem. potentials
0853 c     --------------------------
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 c     new hadron chem. potentials
0864 c     ---------------------------
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 c     checking results
0877 c     ----------------
0878       if(ish.ge.5)call hgcchh(i)
0879 
0880 c     particle yield
0881 c     --------------
0882       call hgcpyi(0)
0883 
0884 c     checking flavor conservation
0885 c     ----------------------------
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 c     particle yield
0904 c     --------------
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 c---------------------------------------------------------------------
0921       function hgcbi0(x)
0922 c---------------------------------------------------------------------
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 c------------------------------------------------------------------------
0944       function hgcbi1(x)
0945 c------------------------------------------------------------------------
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 c---------------------------------------------------------------------
0968       function hgcbk0(x)
0969 c------------------------------------------------------------------------
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 c---------------------------------------------------------------
0990       function hgcbk1(x)
0991 c--------------------------------------------------------------------
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 c-------------------------------------------------------------------
1012       function hgcbk(n,x)
1013 c------------------------------------------------------------------
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 c----------------------------------------------------------------
1028       subroutine hgccbo(iba)
1029 c----------------------------------------------------------------
1030 c returns new chem(iafs) for boltzmann statistics
1031 c  input:
1032 c    tem
1033 c    kef/volu
1034 c  output:
1035 c    chem(iafs)
1036 c-----------------------------------------------------------------------
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 c     new chemical potential
1054 c     ----------------------
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 c     if(abs(fd).ge.100.)then
1084 c     iba=1
1085 c     return
1086 c     endif
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 c----------------------------------------------------------------------
1104       subroutine hgccch(iii)
1105 c----------------------------------------------------------------------
1106 c checks convergence of iterative algorithm
1107 c plots iteration values for T and mu_i
1108 c----------------------------------------------------------------------
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 c-----------------------------------------------------------------------
1260       subroutine hgccex
1261 c-----------------------------------------------------------------------
1262 c returns new chem(iafs) for massive quantum statistics
1263 c  input:
1264 c    tem
1265 c    kef/volu
1266 c  output:
1267 c    chem(iafs)
1268 c-----------------------------------------------------------------------
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 c     new chemical potential
1284 c     ----------------------
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 c------------------------------------------------------------------
1327       subroutine hgccfc
1328 c------------------------------------------------------------------
1329 c checks flavor conservation in particle yield
1330 c------------------------------------------------------------------
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 c----------------------------------------------------------------
1361       subroutine hgcchb
1362 c----------------------------------------------------------------
1363 c checks results by numerical integration
1364 c----------------------------------------------------------------
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 c----------------------------------------------------------------
1430       subroutine hgcchh(icorr)
1431 c----------------------------------------------------------------
1432 c checks results by numerical integration
1433 c----------------------------------------------------------------
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 c--------------------------------------------------------------------
1504       subroutine hgccm0
1505 c--------------------------------------------------------------------
1506 c returns new quark chemical potentials for massless quantum statistics
1507 c input:
1508 c  tem
1509 c  kef/volu
1510 c output:
1511 c  chem
1512 c---------------------------------------------------------------------
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 c     new chemical potential
1529 c     ----------------------
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 c            else
1549 c      if(ispecs(i).gt.0)then
1550 c     hpd=gspecs(i)*(chemgc(i)*tem**2/3.-chemgc(i)**3/pi**2/6.)/hquer**3
1551 c      else
1552 c     hpd=0.0
1553 c      endif
1554 c        endif
1555 
1556 c     n=1
1557 c0    xx=n*abs(chemgc(i))/tem
1558 c     if(xx.le.60.)then
1559 c     hpd=hpd+(-1.)**(n+1)/n**3/exp(xx)
1560 c     n=n+1
1561 c     goto20
1562 c     endif
1563 c     hpd=hpd*gspecs(i)*tem**3/pi**2/hquer**3
1564 c     if(chemgc(i).eq.abs(chemgc(i)))then
1565 c     hpd=gspecs(i)*(chemgc(i)*tem**2+chemgc(i)**3/pi**2)/6./hquer**3
1566 c    *-hpd
1567 c     endif
1568 
1569 c      else
1570 c     hpd=3.*gspecs(i)*tem**3*z3/4./pi**2/hquer**3
1571 c      endif
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 c-----------------------------------------------------------------------
1604       function hgcfbe(x)
1605 c-----------------------------------------------------------------------
1606 c integrand of energy density
1607 c------------------------------------------------------------------------
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 c-----------------------------------------------------------------
1628       function hgcfbf(x)
1629 c-----------------------------------------------------------------
1630 c integrand of mean square variance of  energy
1631 c----------------------------------------------------------------
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 c-----------------------------------------------------------------
1653       function hgcfbn(x)
1654 c-----------------------------------------------------------------
1655 c integrand of hadron density
1656 c-----------------------------------------------------------------
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 c-----------------------------------------------------------------------
1678       function hgcfhe(x)
1679 c-----------------------------------------------------------------------
1680 c integrand of energy density
1681 c------------------------------------------------------------------------
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 c-----------------------------------------------------------------
1707       function hgcfhf(x)
1708 c-----------------------------------------------------------------
1709 c integrand of mean square variance of  energy
1710 c----------------------------------------------------------------
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 c-----------------------------------------------------------------
1737       function hgcfhn(x)
1738 c-----------------------------------------------------------------
1739 c integrand of hadron density
1740 c-----------------------------------------------------------------
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 c-----------------------------------------------------------------
1766       function hgcfhw(x)
1767 c-----------------------------------------------------------------
1768 c integrand of mean square variance of hadron yield
1769 c----------------------------------------------------------------
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 c-----------------------------------------------------------------
1797       subroutine hgchac(iboco)
1798 c------------------------------------------------------------------
1799 c returns hadronic chemical potentials as combinations of quark
1800 c chemical potentials
1801 c----------------------------------------------------------------------
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 c-----------------------------------------------------------------------
1826       subroutine hgclim(a,b)
1827 c----------------------------------------------------------------------
1828 c returns integration limits for numerical evaluation of particle
1829 c and energy densities using quantum statistics
1830 c----------------------------------------------------------------------
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 c------------------------------------------------------------------------
1859       subroutine hgcnbi(iret)
1860 c-----------------------------------------------------------------------
1861 c uses hgcaaa results to generate initial hadron set, nlattc, iozero
1862 c input:
1863 c    ptlngc(1:nspecs): particle number expectation values  /cgchg/
1864 c output:
1865 c     nump:           number of hadrons   /chnbin/
1866 c     ihadro(1:nump): hadron ids          /chnbin/
1867 c     nlattc:         lattice size        /clatt/
1868 c     iozero:         zero weight         /metr1/
1869 c-----------------------------------------------------------------------
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 c     determine nlattc
1900 c     ----------------
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 c     determine iozero
1925 c     ----------------
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 c     modify iozero for testing
1933 c     -------------------------
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 c     initial hadron set
1940 c     ------------------
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 c     start with nb protons
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 c      if(nbb.lt.nb)then
2106 c      nba=nb-nbb
2107 c     if(nbar.gt.0)then
2108 c     if(ish.ge.7)write(ifch,*)'add protons: nba:',nba
2109 c     nptlgc(19)=nptlgc(19)+nba
2110 c     n=n+nba
2111 c     amtot=amtot+aspecs(19)*nba
2112 c     elseif(nbar.lt.0)then
2113 c     if(ish.ge.7)write(ifch,*)'add aprotons: nba:',nba
2114 c     nptlgc(20)=nptlgc(20)+nba
2115 c     n=n+nba
2116 c     amtot=amtot+aspecs(20)*nba
2117 c     endif
2118 c      endif
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 c      if(asym.gt.0.0)then
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 c      else
2325 
2326 c     r=1.0
2327 c     p=0.0
2328 
2329 c      endif
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 c--------------------------------------------------------------------
2440       integer function hgcndn(i)
2441 c--------------------------------------------------------------------
2442 c returns random multiplicity from gaussian distribution for species i
2443 c---------------------------------------------------------------------
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 c--------------------------------------------------------------------
2515       function hgcpml(i1,n1,i2,n2)
2516 c--------------------------------------------------------------------
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 c--------------------------------------------------------------------
2541       function hgcpnl(i,n)
2542 c--------------------------------------------------------------------
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 c--------------------------------------------------------------------
2563       subroutine hgcpen
2564 c--------------------------------------------------------------------
2565 c returns array for twodimensional plot of energy- and flavor-
2566 c density
2567 c--------------------------------------------------------------------
2568 c xpar1,xpar2 temperature range
2569 c xpar3       # of bins for temperature
2570 c xpar4,xpar5 chem.pot. range
2571 c xpar6       # of bins for chem.pot.
2572 c xpar7       max. density
2573 c xpar8       strange chem.pot.
2574 c--------------------------------------------------------------------
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 c     initialization
2592 c     --------------
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 c     if(qd.gt.ymax)qd=0.0
2655       if(qd.lt.-ymax)qd=-ymax
2656 c     if(qd.lt.-ymax)qd=0.0
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 c     if(ed.gt.ymax)ed=0.0
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 c--------------------------------------------------------------------
2713       subroutine hgcpfl
2714 c--------------------------------------------------------------------
2715 c returns array for twodimensional plot of energy- and flavor-
2716 c density fluctuations
2717 c--------------------------------------------------------------------
2718 c xpar1,xpar2 temperature range
2719 c xpar3       # of bins for temperature
2720 c xpar4,xpar5 chem.pot. range
2721 c xpar6       # of bins for chem.pot.
2722 c xpar7       max. density
2723 c xpar8       strange chem.pot.
2724 c--------------------------------------------------------------------
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 c     initialization
2744 c     --------------
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 c------------------------------------------------------------------
2904       subroutine hgcpyi(ist)
2905 c------------------------------------------------------------------
2906 c returns particle yield
2907 c input:
2908 c   tem   : temperature
2909 c   chemgc: chemical potentials
2910 c output:
2911 c   ptlngc: expectation value of particle number for each species
2912 c   rmsngc: standard deviation of ptlngc
2913 c   ptltot: total particle number
2914 c   rmstot: standard deviation of ptltot
2915 c works for hadrons and partons
2916 c  ist=1 boltzmann statistics
2917 c  ist=0 quantum statistics
2918 c--------------------------------------------------------------------
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 c     parton yield
2932 c     ------------
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 c     hadronic yield
2957 c     --------------
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 c     standard deviation
2991 c     ------------------
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 c------------------------------------------------------------------------
3030       subroutine hgctbo(iba)
3031 c------------------------------------------------------------------------
3032 c returns new tem using boltzmann statistics in analytic form
3033 c  input:
3034 c    chemgc
3035 c    tecm/volu
3036 c  output:
3037 c    tem
3038 c----------------------------------------------------------------------
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 c     if(eden.ge.100.)return
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 c----------------------------------------------------------------------
3112       subroutine hgctex
3113 c----------------------------------------------------------------------
3114 c returns new tem using massive quantum statistics in integral form
3115 c  input:
3116 c    chemgc
3117 c    tecm/volu
3118 c  output:
3119 c    tem
3120 c----------------------------------------------------------------------
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 c     new temperature
3133 c     ---------------
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 c-----------------------------------------------------------------
3173       subroutine hgctm0
3174 c-----------------------------------------------------------------
3175 c returns new tem using massless quantum statistics in analytic form
3176 c  input:
3177 c    chemgc
3178 c    tecm/volu
3179 c  output:
3180 c    tem
3181 c----------------------------------------------------------------------
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 c------------------------------------------------------------------------------
3236       subroutine hnbcor(mode)
3237 c------------------------------------------------------------------------------
3238 c determines(mode=1) and plots (mode=2) two particle  correlations
3239 c for the configurations /confg/
3240 c------------------------------------------------------------------------------
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 c      phi(mm)=.5*pi/bns+(mm-1)*pi/bns
3304       zwei(mm)=.5*2./bns+(mm-1)*2./bns-1.
3305 c      yy(mm)=wert(mm)/nctcor
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 c----------------------------------------------------------------------
3332       subroutine hnbfac(faclog)
3333 c----------------------------------------------------------------------
3334 c  returns log of factor for phase space weight
3335 c  faclog= log{ prod[ m_i*(2*s_i+1)*volu/4/pi**3/hquer**3/(n_l+1-i) ] }
3336 c      ~~~~~~~~~~~~~~
3337 c  corresponds to eq. 67 of micro paper :
3338 c         Cvol * Cdeg * Cident * Cmicro
3339 c    the factors partly compensate each other !!
3340 c----------------------------------------------------------------------
3341       include 'epos.inc'
3342       parameter(maxp=500)
3343       common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
3344 c      integer ii(maxp)
3345       common /clatt/nlattc,npmax
3346 
3347       faclog=0
3348 
3349 c sum_i log m_i*g_i*volu/4/pi**3/hquer**3/(n_l+1-i) -> flog
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 c----------------------------------------------------------------------
3361       subroutine hnbfaf(i,gg,am,ioma)
3362 c----------------------------------------------------------------------
3363 c  returns degeneracy gg and mass am  for factor f5
3364 c----------------------------------------------------------------------
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 cc----------------------------------------------------------------------
3393 c      subroutine hnbids(jc,ids,iwts,i)
3394 cc----------------------------------------------------------------------
3395 cc  returns i id-codes ids() corr to jc  and their weights iwts()
3396 cc----------------------------------------------------------------------
3397 c      parameter (mxids=200,mspecs=56,nflav=6)
3398 c      common/metr1/iospec,iocova,iopair,iozero,ioflac,iomom
3399 c      common/cflac/ifok(nflav,mspecs),ifoa(nflav)
3400 c      common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
3401 c      integer ids(mxids),jc(nflav,2),iwts(mxids),jc1mi2(nflav)
3402 c
3403 c      if(nspecs+1.gt.mxids)call utstop('hnbids: mxids too small&')
3404 c
3405 c      do n=1,nflav
3406 c      jc1mi2(n)=jc(n,1)-jc(n,2)
3407 c      enddo
3408 c
3409 c      i=0
3410 c
3411 c      do n=1,nflav
3412 c      if(jc1mi2(n).ne.0)goto1
3413 c      enddo
3414 c      i=i+1
3415 c      ids(i)=0
3416 c      iwts(i)=iozero
3417 c    1 continue
3418 c
3419 c           do j=1,nspecs
3420 c      do n=1,nflav
3421 c      if(jc1mi2(n).ne.ifok(n,j))goto2
3422 c      enddo
3423 c      i=i+1
3424 c      ids(i)=ispecs(j)
3425 c      iwts(i)=1
3426 c    2 continue
3427 c           enddo
3428 c
3429 c      return
3430 c      end
3431 c
3432 c----------------------------------------------------------------------
3433       subroutine hnbiiw(x,f,df)
3434 c----------------------------------------------------------------------
3435 c returns fctn value and first derivative at x of the
3436 c i-th integrated weight fctn minus random number
3437 c for the asympotic phase space integral.
3438 c input:
3439 c   x:   x-value
3440 c   iii: i-value (via common/ciiw/iii,rrr)
3441 c   rrr: random number   ( " )
3442 c output:
3443 c   f:   fctn value
3444 c   df:  first derivative
3445 c----------------------------------------------------------------------
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 c----------------------------------------------------------------------
3454       subroutine hnbini(iret)
3455 c----------------------------------------------------------------------
3456 c  generates initial configuration
3457 c----------------------------------------------------------------------
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 c      print *,np,nlattc
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 cc----------------------------------------------------------------------
3604 c      subroutine hnbint(tecmx,nevtxx,nsho)
3605 cc----------------------------------------------------------------------
3606 cc  calculates phase space integral of the minimal hadron configuration
3607 cc  compatibel with keu, ked, kes, kec for a total mass of tecm
3608 cc  by employing nevtxx simulations and printing results every nsho events
3609 cc----------------------------------------------------------------------
3610 c      include 'epos.inc'
3611 c      parameter(maxp=500)
3612 c      common/chnbin/nump,ihadro(maxp)
3613 c      common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
3614 c      tecm=tecmx
3615 c      write(ifch,*)
3616 c      write(ifch,'(1x,a,4i3,a,f10.4)')'droplet id:',keu,ked,kes,kec
3617 c     *,'   droplet mass:',tecm
3618 c      call hnbmin(keu,ked,kes,kec)
3619 c      np=nump
3620 c      if(np.gt.maxp)stop'np too large'
3621 c      do i=1,np
3622 c      id=ihadro(i)
3623 c      if(id.eq.30)then
3624 c          call idmass(2130,am)
3625 c          amass(i)=2*am-0.100
3626 c      else
3627 c         call idmass(id,amass(i))
3628 c      endif
3629 c      enddo
3630 c      wts=0
3631 c      n=0
3632 c           do ll=1,nevtxx
3633 c      n=n+1
3634 c      if(iocova.eq.1)call hnbody
3635 c      if(iocova.eq.2)call hnbodz
3636 c      wt=exp(wtxlog)
3637 c      wts=wts+wt
3638 c      if(mod(n,nsho).eq.0)
3639 c     *write(ifch,'(a,i7,3x,a,e13.6,3x,a,e13.6,3x,a,e13.6)')
3640 c     *'n:',n,'weight:',wt,'wts/n:',wts/n,'error:',wts/n/sqrt(1.*n)
3641 c           enddo
3642 c      return
3643 c      end
3644 cc----------------------------------------------------------------------
3645       subroutine hnbmet
3646 c----------------------------------------------------------------------
3647 c  change (or not) configuration via metropolis
3648 c  configuration=np,tecm,amass(),ident(),pcm(),volu,wtlog
3649 c    (common /confg/)
3650 c  nlattc (in /clatt/) must be set before calling this routine
3651 c----------------------------------------------------------------------
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 c      parameter (mxpair=mspecs**2*4)
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 c     for iter=1
3686 c     ----------
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 c     remember old configuration
3708 c     --------------------------
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 c     determine pair, construct new pair, update ident
3729 c     ------------------------------------------------
3730       xab=1
3731       xba=1
3732            if(iopair.eq.1)then
3733 c     (single pair method)
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 c     determine 2 pairs, construct 2 new pairs, update ident
3757 c     ------------------------------------------------------
3758            elseif(iopair.eq.2)then
3759 c     (double pair method)
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 c     determine masses/momenta/weight of trial configuration
3824 c     ------------------------------------------------------
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 c-c   call hnbolo(1000) !instead of "call hnbody" for testing
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 c     accept or not trial configuration (metropolis)
3854 c     ----------------------------------------------
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 c     printout/return
3915 c     ---------------
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 c     if(liter.le.literm)then
3933 c     iterc(liter)=iterc(liter-1)
3934 c     do j=1,nspecs
3935 c     lspecs(liter,j)=lspecs(liter-1,j)
3936 c     enddo
3937 c     endif
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 c----------------------------------------------------------------------
3972       subroutine hnbmin(keux,kedx,kesx,kecx)
3973 c----------------------------------------------------------------------
3974 c  returns min hadron set with given u,d,s,c content
3975 c  input:
3976 c     keux: net u quark number
3977 c     kedx: net d quark number
3978 c     kesx: net s quark number
3979 c     kecx: net c quark number
3980 c  output (written to /chnbin/):
3981 c     nump: number of hadrons
3982 c     ihadro(n): hadron id for n'th hadron
3983 c----------------------------------------------------------------------
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 c get rid of anti-c and c (140, 240, -140, -240)
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 c get rid of anti-s (130,230)
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 c get rid of anti-d (120, -230)
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 c get rid of anti-u (-120, -130)
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 c get rid of s (3331, x330, xx30)
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 c get rid of d (2221, 1220, 1120)
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 c get rid of u (1111)
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 c-------------------------------------------------------------
4197       subroutine hnbody
4198 c-------------------------------------------------------------
4199 c   formerly subr genbod from genlib (cernlib).
4200 c   modified by K. Werner, march 94.
4201 c   subr to generate n-body event
4202 c   according to fermi lorentz-invariant phase space.
4203 c   the phase space integral is the sum over the weights wt divided
4204 c   by the number of events (sum wt / n).
4205 c   adapted from fowl (cern w505) sept. 1974 by f. james.
4206 c   events are generated in their own center-of-mass,
4207 c   but may be transformed to any frame using loren4.
4208 c
4209 c   input to and output from subr thru common block config.
4210 c   input:
4211 c             np=number of outgoing particles
4212 c             tecm=total energy in center-of-mass
4213 c             amass(i)=mass of ith outgoing particle
4214 c   output:
4215 c             pcm(1,i)=x-momentum if ith particle
4216 c             pcm(2,i)=y-momentum if ith particle
4217 c             pcm(3,i)=z-momentum if ith particle
4218 c             pcm(4,i)=energy of ith particle
4219 c             pcm(5,i)=momentum of ith particle
4220 c             wtxlog=log of weight of event
4221 c--------------------------------------------------------------
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 c     !pcm1 is linear equiv. of pcm to avoid double indices
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 ctp060829      nas=5 !must be at least 3
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 c..... initialization
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 c...fill rno with 3*nt-4 random numbers, the first nt-2 being ordered
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 c...calculate emm().......M_i
4284 
4285       do 6 j=2,ntm1
4286     6 emm(j)=rno(j-1)*tecmtm+sm(j)
4287 
4288 c...calculate wtlog
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 c...complete specification of event (raubold-lynch method)
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 c...returns
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 c---------------------------------------------------------------------------------------------------------
4376       SUBROUTINE FLPSORE(A,N)
4377 C---------------------------------------------------------------------------------------------------------
4378 C CERN PROGLIB# M103    FLPSOR          .VERSION KERNFOR  3.15  820113
4379 C ORIG. 29/04/78
4380 C
4381 C   SORT THE ONE-DIMENSIONAL FLOATING POINT ARRAY A(1),...,A(N) BY
4382 C   INCREASING VALUES
4383 C
4384 C-    PROGRAM  M103  TAKEN FROM CERN PROGRAM LIBRARY,  29-APR-78
4385 C----------------------------------------------------------------------------------------------------------
4386       DIMENSION A(N)
4387       COMMON /SLATE/ LT(20),RT(20)
4388       INTEGER R,RT
4389 C
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 C
4399 C   SUBDIVIDE THE INTERVAL L,R
4400 C     L : LOWER LIMIT OF THE INTERVAL (INPUT)
4401 C     R : UPPER LIMIT OF THE INTERVAL (INPUT)
4402 C     J : UPPER LIMIT OF LOWER SUB-INTERVAL (OUTPUT)
4403 C     I : LOWER LIMIT OF UPPER SUB-INTERVAL (OUTPUT)
4404 C
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 C
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 C
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 c-------------------------------------------------------------
4448       subroutine hnbodz
4449 c-------------------------------------------------------------
4450 c   subr to generate n-body event
4451 c   according to non-invariant phase space.
4452 c   the phase space integral is the sum over the weights exp(wtxlog)
4453 c   divided by the number of events.
4454 c   ref.: hagedorn, nuov. cim. suppl ix, x (1958) 646.
4455 c   events are generated in their own center-of-mass.
4456 c
4457 c   input to and output from subr is thru common block config.
4458 c   input:
4459 c             np=number of outgoing particles
4460 c             tecm=total energy in center-of-mass
4461 c             amass(i)=mass of ith outgoing particle
4462 c   output:
4463 c             pcm(1,i)=x-momentum of ith particle
4464 c             pcm(2,i)=y-momentum of ith particle
4465 c             pcm(3,i)=z-momentum of ith particle
4466 c             pcm(4,i)=energy of ith particle
4467 c             pcm(5,i)=momentum of ith particle
4468 c             wtxlog=log of weight of event
4469 c--------------------------------------------------------------
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 c initialization ktnbod=1
4485       ktnbod=ktnbod + 1
4486       if(ktnbod.gt.1) goto 1
4487 c     !ffqlog(n) = log{ (4*pi)**n  / (n-1)! }
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 c set wtxlog -infinity for np<2
4494       if(np.lt.2) goto 1001
4495 c special treatment for np=2
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 c stop if np too large
4519       if(np.gt.maxp) goto 1002
4520 c initialization all ktnbod
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 c prefactor
4528       wtxlog=alog(tt)*(np-1) + ffqlog(np)
4529       if(ish.ge.7)
4530      *write(ifch,*)'wtxlog:',wtxlog,'   (prefactor)'
4531 c fill rnoz with np-1 random numbers
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 c calculate z_i distributed as i*z*(i-1)
4542       do i= 1, np-1
4543       zi(i)=rnoz(i)**(1./i)
4544       enddo
4545 c calculate x_i
4546       xi(np)=1
4547       do i=np-1,1,-1
4548       xi(i)=zi(i)*xi(i+1)
4549       enddo
4550 c calculate t_i, e_i, p_i
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 c calculate wtxlog
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 c print
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 c complete specification of event (random rotations and then deformations)
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 c error returns
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 c-----------------------------------------------------------------------
4641       subroutine hnbolo(loops)
4642 c-----------------------------------------------------------------------
4643 c  loop over hnbody
4644 c-----------------------------------------------------------------------
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 c-c   if(mod(j,iterpr).eq.0)write(ifmt,*)'     iteration:',iter,j
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 c-----------------------------------------------------------------------
4674       function hnbpdk(a,b,c)
4675 c-----------------------------------------------------------------------
4676 c  formerly pdk from cernlib
4677 c  returns momentum p for twobody decay  a --> b + c
4678 c           a, b, c are the three masses
4679 c~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
4680 c  this p is related to twobody phase space as R2 = pi * p /a
4681 c-----------------------------------------------------------------------
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 c----------------------------------------------------------------------
4698       subroutine hnbpad(k,n1,n2,n3,n4,mm,jc)
4699 c----------------------------------------------------------------------
4700 c  k=1: determ pair indices k1,k2
4701 c  k=2: determ pair indices k3,k4 (.ne. n1,n2)
4702 c  k=1 and k=2: mm: type of pair, jc: flavour of pair
4703 c----------------------------------------------------------------------
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 c     determine n1,n2 and mm
4714 c     ----------------------
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 c     flavour of n1+n2 --> jc
4741 c     -----------------------
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 c----------------------------------------------------------------------
4775       subroutine hnbpai(id1,id2,jc)
4776 c----------------------------------------------------------------------
4777 c  returns arbitrary hadron pair id1,id2, flavour written to jc
4778 c----------------------------------------------------------------------
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 c     construct pair id1,id2
4785 c     ----------------------
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 c     determine jc
4823 c     ------------
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 c----------------------------------------------------------------------
4845       subroutine hnbpaj(jc,iwpair,id1,id2)
4846 c----------------------------------------------------------------------
4847 c  returns sum of weights iwpair of possible pairs
4848 c  and randomly chosen hadron pair id1,id2 for given flavour jc
4849 c----------------------------------------------------------------------
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 c      nflv=nflav
4864 c      if(nflv.gt.6)
4865 c     *call utstop('hnbpaj: nflav.gt.6: modify this routine&')
4866 
4867 c     construct possible pairs id1,id2
4868 c     --------------------------------
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 c  id1=0:
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 c      if(ish.ge.6)write(ifch,'(a,i5,5x,a,i6,i6,5x,a,i6)')' pair nr:'
4958 c     *,ipair,'ids:',0,ids(k),'weight:',iwtpai(ipair)
4959       enddo
4960     2 continue
4961 
4962 c  id1>0:
4963 
4964         do i1=1,nspecs
4965 
4966 c        if(ish.ge.6)then
4967 c        do i=1,nflav
4968 c      jc2(i,1)=jc(i,1)-jspecs(1,i,i1)
4969 c      jc2(i,2)=jc(i,2)-jspecs(2,i,i1)
4970 c        enddo
4971 c      write(ifch,'(1x,a,i3,a,i6,a,6i2,3x,6i2)')
4972 c     *'i1:',i1,'   id1:',ispecs(i1),'   jc1:'
4973 c     *,(jspecs(1,i,i1),i=1,6),(jspecs(2,i,i1),i=1,6)
4974 c      write(ifch,'(a,6i2,3x,6i2)')' jc2:',jc2
4975 c        endif
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 c-charm      if(jcmi(4).ne.0)stop'HNBPAJ: c not treated'
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 c             do j=1,nspecs
5025 c      if(jcmi(1).ne.ifok(1,j))goto222
5026 c      if(jcmi(2).ne.ifok(2,j))goto222
5027 c      if(jcmi(3).ne.ifok(3,j))goto222
5028 c      if(jcmi(4).ne.ifok(4,j))goto222
5029 c      if(jcmi(5).ne.ifok(5,j))goto222
5030 c      if(jcmi(6).ne.ifok(6,j))goto222
5031 c      nids=nids+1
5032 c      ids(nids)=ispecs(j)
5033 c      iwts(nids)=1
5034 c  222 continue
5035 c             enddo
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 c     no pair found
5059 c     -------------
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 c     select pair
5068 c     -----------
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 c      if(ish.ge.6)write(ifch,*)'random number:',r
5079 c     *,' --> chosen pair:',ip
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 c----------------------------------------------------------------------
5092       subroutine hnbpajini
5093 c----------------------------------------------------------------------
5094 c  initialize array to speed up hnbpaj calculation
5095 c  store sum of weights iwpair of possible pairs in an array
5096 c  for any combinations of quarks
5097 c----------------------------------------------------------------------
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 c      write(ifmt,*)' Initialize droplet decay ...'
5112 
5113 c     construct possible pairs id1,id2
5114 c     --------------------------------
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 c  id1=0:
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 c      if(ish.ge.6)write(ifch,'(a,i5,5x,a,i6,i6,5x,a,i6)')' pair nr:'
5175 c     *,ipair,'ids:',0,ids(k),'weight:',iwtpai(ipair)
5176       enddo
5177     2 continue
5178 
5179 c  id1>0:
5180 
5181         do i1=1,nspecs
5182 
5183 c        if(ish.ge.6)then
5184 c        do i=1,nflav
5185 c      jc2(i,1)=jc(i,1)-jspecs(1,i,i1)
5186 c      jc2(i,2)=jc(i,2)-jspecs(2,i,i1)
5187 c        enddo
5188 c      write(ifch,'(1x,a,i3,a,i6,a,6i2,3x,6i2)')
5189 c     *'i1:',i1,'   id1:',ispecs(i1),'   jc1:'
5190 c     *,(jspecs(1,i,i1),i=1,6),(jspecs(2,i,i1),i=1,6)
5191 c      write(ifch,'(a,6i2,3x,6i2)')' jc2:',jc2
5192 c        endif
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 c             do j=1,nspecs
5235 c      if(jcmi(1).ne.ifok(1,j))goto222
5236 c      if(jcmi(2).ne.ifok(2,j))goto222
5237 c      if(jcmi(3).ne.ifok(3,j))goto222
5238 c      if(jcmi(4).ne.ifok(4,j))goto222
5239 c      if(jcmi(5).ne.ifok(5,j))goto222
5240 c      if(jcmi(6).ne.ifok(6,j))goto222
5241 c      nids=nids+1
5242 c      ids(nids)=ispecs(j)
5243 c      iwts(nids)=1
5244 c  222 continue
5245 c             enddo
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 c     no pair found
5263 c     -------------
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 c--------------------------------------------------------------------
5280       subroutine hnbraw(npx,npy,w)
5281 c--------------------------------------------------------------------
5282 c returns random walk fctn w=w(0,p_1,p_2,...,p_n) for noncovariant
5283 c phase space integral (see hagedorn, suppl nuov cim ix(x) (1958)646)
5284 c input: dimension np and momenta p_i=pcm(5,i) via /confg/
5285 c    1   < np <= npx : hagedorn method
5286 c    npx < np <= npy : integral method
5287 c    npy < np        : asymptotic method
5288 c--------------------------------------------------------------------
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 c     sum p_i - 2*p_max not positive
5312 c     ------------------------------
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 c     asymptotic method
5327 c     -----------------
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 c     integral method
5344 c     ---------------
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 c     hagedorn method (double)
5399 c     ------------------------
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 c--------------------------------------------------------------------
5461       function hnbrax(x)
5462 c--------------------------------------------------------------------
5463 c returns integrand for random walk fctn w=w(0,p_1,p_2,...,p_n):
5464 c 1./(2*pi**2) * x**2 * prod[sin(p_i*x)/(p_i*x)]
5465 c input: dimension np and momenta p_i=pcm(5,i) via /confg/
5466 c--------------------------------------------------------------------
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 c----------------------------------------------------------------------
5479       subroutine hnbrmz
5480 c----------------------------------------------------------------------
5481 c  removes intermediate zeros from ident
5482 c  updates np
5483 c----------------------------------------------------------------------
5484       include 'epos.inc'
5485       parameter(maxp=500)
5486       common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
5487 c      integer identx(maxp)
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 c      do i=1,np
5494 c      identx(i)=ident(i)
5495 c      enddo
5496 c      npx=np
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 c----------------------------------------------------------------------
5529       subroutine hnbrod
5530 c----------------------------------------------------------------------
5531 c deformes polygon of a sequence of arbitrarily rotated momentum
5532 c vectors such that the polygon gets closed
5533 c    input: pcm(1-3,i) representing polygon
5534 c    output: pcm(1-3,i) representing closed polygon
5535 c----------------------------------------------------------------------
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 c      xx=sqrt(xxx)
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 c----------------------------------------------------------------------
5626       subroutine hnbrop(ishx,ichk)
5627 c----------------------------------------------------------------------
5628 c  prints momenta of configuration (essentially to check rotation procedure)
5629 c----------------------------------------------------------------------
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 c----------------------------------------------------------------------
5661       subroutine hnbrot
5662 c----------------------------------------------------------------------
5663 c rotates momenta of /confg/ randomly
5664 c   input: pcm(5,i)
5665 c   output: pcm(1-3,i)
5666 c----------------------------------------------------------------------
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 cc-------------------------------------------------------------------
5686 c      subroutine hnbrt2old(c,s,c2,s2,pr,i)
5687 cc-------------------------------------------------------------------
5688 cc  formerly subr rotes2 from cernlib
5689 cc  this subr now does two rotations (xy and xz)
5690 cc-------------------------------------------------------------------
5691 c      parameter(maxp=500)
5692 c      dimension pr(5*maxp)
5693 c      k1 = 5*i - 4
5694 c      k2 = k1 + 1
5695 c      sa = pr(k1)
5696 c      sb = pr(k2)
5697 c      a      = sa*c - sb*s
5698 c      pr(k2) = sa*s + sb*c
5699 c      k2 = k2 + 1
5700 c      b = pr(k2)
5701 c      pr(k1) = a*c2 - b*s2
5702 c      pr(k2) = a*s2 + b*c2
5703 c      return
5704 c      end
5705 c
5706 c-------------------------------------------------------------------
5707       subroutine hnbrt2(c,s,c2,s2,pr,i)
5708 c-------------------------------------------------------------------
5709 c  formerly subr rotes2 from cernlib
5710 c  this subr now does two rotations (xy and xz)
5711 c-------------------------------------------------------------------
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 cc-----------------------------------------------------------------------
5728 c      subroutine hnbsor(a,n)
5729 cc-----------------------------------------------------------------------
5730 cc cern proglib# m103    flpsor          .version kernfor  3.15  820113
5731 cc orig. 29/04/78
5732 cc-----------------------------------------------------------------------
5733 cc   sort the one-dimensional floating point array a(1),...,a(n) by
5734 cc   increasing values
5735 cc-----------------------------------------------------------------------
5736 c      dimension a(*)
5737 c      common /slate/ lt(20),rt(20)
5738 c      integer r,rt
5739 cc
5740 c      level=1
5741 c      lt(1)=1
5742 c      rt(1)=n
5743 c   10 l=lt(level)
5744 c      r=rt(level)
5745 c      level=level-1
5746 c   20 if(r.gt.l) go to 200
5747 c      if(level) 50,50,10
5748 cc
5749 cc   subdivide the interval l,r
5750 cc     l : lower limit of the interval (input)
5751 cc     r : upper limit of the interval (input)
5752 cc     j : upper limit of lower sub-interval (output)
5753 cc     i : lower limit of upper sub-interval (output)
5754 cc
5755 c  200 i=l
5756 c      j=r
5757 c      m=(l+r)/2
5758 c      x=a(m)
5759 c  220 if(a(i).ge.x) go to 230
5760 c      i=i+1
5761 c      go to 220
5762 c  230 if(a(j).le.x) go to 231
5763 c      j=j-1
5764 c      go to 230
5765 cc
5766 c  231 if(i.gt.j) go to 232
5767 c      w=a(i)
5768 c      a(i)=a(j)
5769 c      a(j)=w
5770 c      i=i+1
5771 c      j=j-1
5772 c      if(i.le.j) go to 220
5773 cc
5774 c  232 level=level+1
5775 c      if(level.gt.20)stop'level too large'
5776 c      if((r-i).ge.(j-l)) go to 30
5777 c      lt(level)=l
5778 c      rt(level)=j
5779 c      l=i
5780 c      go to 20
5781 c   30 lt(level)=i
5782 c      rt(level)=r
5783 c      r=j
5784 c      go to 20
5785 c   50 return
5786 c      end
5787 c
5788 c-----------------------------------------------------------------------
5789       subroutine hnbspd(iopt)
5790 c-----------------------------------------------------------------------
5791 c  defines particle species and masses and degeneracies.
5792 c  input:
5793 c    iopt=odd number: massless
5794 c    iopt=even number: same as iopt-1, but massive
5795 c    iopt= 1: pi0 (massless)
5796 c    iopt= 2: pi0
5797 c    iopt= 3: pi-,pi0,pi+ (massless)
5798 c    iopt= 4: pi-,pi0,pi+
5799 c    iopt= 5: pi-,pi0,pi+,prt,aprt,ntr,antr (massless)
5800 c    iopt= 6: pi-,pi0,pi+,prt,aprt,ntr,antr
5801 c    iopt= 7: 25 hadrons (massless)
5802 c    iopt= 8: 25 hadrons
5803 c    iopt= 9: 54 hadrons (massless)
5804 c    iopt=10: 54 hadrons
5805 c    iopt=11:  3 quarks  (massless)
5806 c    iopt=12:  3 quarks
5807 c    iopt=13:  54 hadrons + J/psi   (massless)
5808 c    iopt=14:  54 hadrons + J/psi
5809 c    iopt=15:  54 hadrons + J/psi + H  (massless)
5810 c    iopt=16:  54 hadrons + J/psi + H
5811 c  output:
5812 c    nspecs: nr of species
5813 c    ispecs: id's
5814 c    aspecs: masses
5815 c-----------------------------------------------------------------------
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 c-charm      if(ifok(4,i).ne.0)stop'HNBSPD: lkfok needs index for c'
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 c       write(6,'(i5,5x,3i5,5x,i5,5x,6i5)')
5935 c     * id,iiu,iid,iis,(lkfok(iiu,iid,iis,kk),kk=1,7)
5936            enddo
5937 
5938       return
5939       end
5940 
5941 c-------------------------------------------------------------
5942       subroutine hnbspf(ku,kd,ks,kc,kb,kt,j,n,spelog)
5943 c-------------------------------------------------------------
5944 c  returns spelog = log of factor for consid. different species
5945 c  spelog is double precision
5946 c  option ioflac determines the method:
5947 c     ioflac=1: ignore flavour conservation
5948 c     ioflac=2: flavour conservation implemented straightforward
5949 c                 (only for nspecs=3,7)
5950 c     ioflac=3: flavour conservation via generating fctn
5951 c  further input:
5952 c     ku,...,kt (integer) : flavour
5953 c     j (integer) : excluded species
5954 c     n (integer) : multiplicity
5955 c-------------------------------------------------------------
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 c      parameter(numax=100,kqmax=100)
5966 c      parameter(mxhh=200)
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 c-------------------------------------------------------------
6127       subroutine hnbspg(ku,kd,ks,kc,kb,kt,j,n,spelog)
6128 c-------------------------------------------------------------
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 c----------------------------------------------------------------------
6142       subroutine hnbspi(id,spideg)
6143 c----------------------------------------------------------------------
6144 c  returns spin degeneracy spideg for particle id-code id
6145 c----------------------------------------------------------------------
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 c----------------------------------------------------------------------
6208       subroutine hnbtst(iof12)
6209 c----------------------------------------------------------------------
6210 c  calculates logs of prefactors and phase space integral
6211 c  for ultrarelativistic limit (massless particles) and (2*s_i+1)=1
6212 c  f12log and w15log=w35log+f12log not calculated calculated for iof12=0
6213 c----------------------------------------------------------------------
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 c log of prod m_i*volu/4/pi**3/hquer**3 -> f5log
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 c log f4log=0
6244       f4log=0
6245       if(ish.ge.7)write(ifch,*)'log(f4):',f4log
6246 
6247 c log of 1/prod n_alpha! -> f3log
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 c log of f3 * f4 * f5
6273       f35log=f5log+f4log+f3log
6274       if(ish.ge.7)write(ifch,*)'log(f3*f4*f5):',f35log
6275 
6276 c log of phase space integral --> psilog
6277 c ... initialization
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 c log of phase space integral * f3 * f4 * f5
6297       w35log=f35log+psilog
6298       if(ish.ge.7)write(ifch,*)'log(f35*psi):',w35log
6299 
6300            if(iof12.ne.0)then
6301 
6302 c log of macro/micro factor (f1*f2) --> f12log
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 cc----------------------------------------------------------------------
6335 c      subroutine hnbuex(x,e)
6336 cc----------------------------------------------------------------------
6337 cc  x --> x*10.**e with x.lt.10.**10.
6338 cc----------------------------------------------------------------------
6339 c           if(x.eq.0.)then
6340 c      e=0.
6341 c           else
6342 c      e=int(alog10(abs(x)))/10*10
6343 c      x=x/10.**e
6344 c           endif
6345 c      return
6346 c      end
6347 c
6348 cc----------------------------------------------------------------------
6349 c      subroutine hnbwin(n,w,q,i)
6350 cc----------------------------------------------------------------------
6351 cc  returns random index i according to weight w(i)
6352 cc----------------------------------------------------------------------
6353 c      real w(n),q(n)
6354 c      q(1)=w(1)
6355 c      do k=2,n
6356 c      q(k)=q(k-1)+w(k)
6357 c      enddo
6358 c      y=rangen()*q(n)
6359 c      do k=1,n
6360 c      i=k
6361 c      if(q(k).ge.y)goto1000
6362 c      enddo
6363 c      i=n
6364 c1000  return
6365 c      end
6366 c
6367 c----------------------------------------------------------------------
6368       subroutine hnbwri
6369 c----------------------------------------------------------------------
6370 c  writes (to ifch) an configuration
6371 c----------------------------------------------------------------------
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 c----------------------------------------------------------------------
6393       subroutine hnbzen(iii)
6394 c----------------------------------------------------------------------
6395 c analysis of events. energy spectra.
6396 c for iii>0: filling histogram considering ptl iii
6397 c----------------------------------------------------------------------
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 c----------------------------------------------------------------------
6433       subroutine hnbzmu(iii)
6434 c----------------------------------------------------------------------
6435 c analysis of events. multiplicity spectra.
6436 c for iii<0: settting histograms to zero (should be first call)
6437 c for iii>0: filling histogram considering ptl iii
6438 c----------------------------------------------------------------------
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 c-----------------------------------------------------------------------
6481       subroutine xhgcam(amt,iii)
6482 c-----------------------------------------------------------------------
6483 c creates unnormalized histogram for total mass of grand
6484 c canonically generated sample
6485 c xpar1: nr. of bins
6486 c xpar2: m_1 (lower boundary)
6487 c xpar3: m_2 (upper boundary)
6488 c-----------------------------------------------------------------------
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       if(iii.eq.0)then
6497 
6498       am(nrclu)=amt
6499 
6500       return
6501 
6502       elseif(iii.lt.0)then
6503 
6504       nbin=nint(xpar3)
6505       x1=xpar1
6506       x2=xpar2
6507       dam=(x2-x1)/nbin
6508       write(cen,'(f6.1)')tecm
6509       write(cvol,'(f6.1)')volu
6510 
6511       do i=1,nbin
6512       data(i)=x1+(i-1)*dam
6513       datb(i)=0.0
6514       enddo
6515 
6516       do i=1,nrclu
6517       xnb=(am(i)-x1)/dam+1.
6518       nb=nint(xnb)
6519       if(nb.le.nbin.and.nb.ge.1)datb(nb)=datb(nb)+1
6520       enddo
6521 
6522       write(ifhi,'(a)')       'newpage zone 1 2 1'
6523 
6524       write(ifhi,'(a)')       'openhisto'
6525       write(ifhi,'(a)')       'htyp his'
6526       write(ifhi,'(a)')       'xmod lin ymod lin'
6527       write(ifhi,'(a,2e11.3)')'xrange',x1,x2
6528       write(ifhi,'(a)')    'text 0 0 "xaxis total mass"'
6529       write(ifhi,'(a)')    'text 0 0 "yaxis N"'
6530       write(ifhi,'(a,a)')     'text 0.4 0.91 "V='//cvol//'"'
6531       write(ifhi,'(a,a)')     'text 0.15 0.91 "E='//cen//'"'
6532       write(ifhi,'(a)')       'array 2'
6533 
6534          do j=1,nbin
6535       write(ifhi,'(2e13.5)')data(j),datb(j)
6536          enddo
6537 
6538       write(ifhi,'(a)')    '  endarray'
6539       write(ifhi,'(a)')    'closehisto plot 0'
6540 
6541 
6542       return
6543 
6544            endif
6545 
6546        end
6547 
6548 c-----------------------------------------------------------------------
6549       subroutine xhgccc(chi)
6550 c-----------------------------------------------------------------------
6551 c creates unnormalized histogram for chi-squared test of initial
6552 c configuration (grand-canonical results are used)
6553 c for chi>0: chi-squared for each droplet configuration is written
6554 c            to /cchi/
6555 c for chi<0: creates histogram
6556 c            xpar1 specifies lower limit
6557 c            xpar2 specifies upper limit
6558 c            xpar3 specifies bin width
6559 c  newpage, zone and plot commands not included !!!
6560 c-----------------------------------------------------------------------
6561       include 'epos.inc'
6562       parameter(nbin=200)
6563       common/chidat/data(nbin),datb(nbin)
6564       parameter(mxclu=10000)
6565       common/cchi/chi2(mxclu)
6566       character cnu*2,cinco*1,cen*6,cvol*6
6567       parameter (mspecs=56)
6568       common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
6569 
6570          if(chi.ge.0.0)then
6571 
6572       nrclu=nrclu+1
6573       chi2(nrclu)=chi
6574 
6575       return
6576 
6577          elseif(chi.lt.0.0)then
6578 
6579       x1=nint(xpar1)
6580       x2=nint(xpar2)
6581       da=xpar3
6582       write(cnu,'(i2)')nspecs
6583       write(cinco,'(i1)')ioinco
6584       write(cen,'(f6.1)')tecm
6585       write(cvol,'(f6.1)')volu
6586 
6587       if(x2.eq.0)x2=50.0
6588       da=max(0.1,da)
6589       a0=x1
6590 
6591       do i=1,nbin
6592       data(i)=a0+(i-1)*da
6593       datb(i)=0.0
6594       enddo
6595 
6596       do i=1,nrclu
6597       nb=(chi2(i)+da/2.-a0)/da
6598       if(nb.le.nbin.and.nb.ge.1)datb(nb)=datb(nb)+1
6599       enddo
6600 
6601       write(ifhi,'(a)')       'openhisto'
6602       write(ifhi,'(a)')       'htyp his'
6603       write(ifhi,'(a)')       'xmod lin ymod lin'
6604       write(ifhi,'(a,2e11.3)')'xrange',x1,x2
6605       write(ifhi,'(a)')    'text 0 0 "xaxis [V]^2"'
6606       write(ifhi,'(a)')    'text 0 0 "yaxis f([V]^2,n?eff!)"'
6607       if(iappl.eq.4)write(ifhi,'(a,a)')'text 0.4 0.91 "V='//cvol//'"'
6608       if(iappl.eq.4)write(ifhi,'(a,a)')'text 0.15 0.91 "E='//cen//'"'
6609       write(ifhi,'(a)')       'array 2'
6610 
6611          do j=1,nbin
6612       dat=datb(j)/nevent/da
6613       write(ifhi,'(2e13.5)')data(j),dat
6614          enddo
6615 
6616       write(ifhi,'(a)')    '  endarray'
6617       write(ifhi,'(a)')    'closehisto'
6618 
6619       return
6620 
6621            endif
6622 
6623        end
6624 
6625 c-----------------------------------------------------------------------
6626       subroutine xhgcen
6627 c-----------------------------------------------------------------------
6628 c  creates energy spectrum plot for decayed QM-droplet
6629 c  using grand canonical results
6630 c input:
6631 c  xpar1 specifies particle species by paige id, 0 for all
6632 c  xpar2 and xpar3 specify xrange of plot
6633 c  xpar4 specifies line type : dashed (0), dotted (1), full (2) dado (3)
6634 c  xpar5 specifies statistics to be used ,(0) same as iostat
6635 c                                         (1) boltzmann
6636 c output:
6637 c  histo-file
6638 c  newpage, zone and plot commands not included !!!
6639 c-----------------------------------------------------------------------
6640       include 'epos.inc'
6641       common/citer/iter,itermx
6642       parameter (nbin=200)
6643       real datx(nbin),daty(nbin)
6644       parameter (mspecs=56)
6645       common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
6646       common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
6647       common/cbol/rmsbol(mspecs),ptlbol(mspecs),chebol(mspecs),tembol
6648       character ctem*5,cit*5,cen*6,cvo*6,chem*5
6649 
6650       idpa=nint(xpar1)
6651       x1=xpar2
6652       x2=xpar3
6653       ltyp=nint(xpar4)
6654       ist=nint(xpar5)
6655       if(ist.eq.0.and.iostat.eq.1)ist=1
6656 
6657       id=0
6658       jx=100
6659       do i=1,nspecs
6660       if(ispecs(i).eq.idpa)id=i
6661       enddo
6662 
6663       dx=(x2-x1)/2./jx
6664       x0=x1+dx
6665 
6666          do j=1,jx
6667          datx(j)=x0+(j-1)*dx*2.
6668          daty(j)=0.0
6669 
6670        if(id.eq.0)then
6671 
6672       do 10 i=1,nspecs
6673       dnde=0.0
6674         if(datx(j).ge.aspecs(i))then
6675       x=100.
6676       if(tem.ne.0.0.and.ist.eq.0)x=(datx(j)-chemgc(i))/tem
6677       if(tem.ne.0.0.and.ist.eq.1)x=(datx(j)-chebol(i))/tembol
6678       igsp=gspecs(i)
6679        if(x.ge.60)goto10
6680        if(mod(igsp,2).eq.0.and.ist.eq.0)then
6681       dnde=1./(exp(x)+1.)
6682        elseif(x.le.1.e-7.and.ist.eq.0)then
6683       dnde=1.e7
6684        elseif(ist.eq.0)then
6685       dnde=1./(exp(x)-1.)
6686        elseif(ist.eq.1)then
6687       dnde=exp(-x)
6688        endif
6689         endif
6690       daty(j)=daty(j)+dnde*gspecs(i)*volu/hquer**3/8./pi**3
6691 10    continue
6692 
6693        else
6694 
6695       dnde=0.0
6696         if(datx(j).ge.aspecs(id))then
6697       x=100.
6698       if(tem.ne.0.0.and.ist.eq.0)x=(datx(j)-chemgc(id))/tem
6699       if(tem.ne.0.0.and.ist.eq.1)x=(datx(j)-chebol(id))/tembol
6700       igsp=gspecs(id)
6701        if(x.ge.60)goto11
6702        if(mod(igsp,2).eq.0.and.ist.eq.0)then
6703       dnde=1./(exp(x)+1.)
6704        elseif(x.le.1.e-7.and.ist.eq.0)then
6705       dnde=1.e7
6706        elseif(ist.eq.0)then
6707       dnde=1./(exp(x)-1.)
6708        elseif(ist.eq.1)then
6709       dnde=exp(-x)
6710        endif
6711         endif
6712 11    daty(j)=dnde*gspecs(id)*volu/hquer**3/8./pi**3
6713 
6714        endif
6715 
6716          enddo
6717 
6718       ctem='     '
6719       chem='     '
6720       if(tem.gt.0.)write(ctem,'(f5.3)')tem
6721       write(cen,'(f6.1)')tecm
6722       write(cvo,'(f6.1)')volu
6723       if(id.gt.0)write(chem,'(f5.3)')chemgc(id)
6724       write(cit,'(i5)')itermx
6725       write(ifhi,'(a)')       'openhisto'
6726       if(ltyp.eq.0)then
6727       write(ifhi,'(a)')       'htyp lda'
6728       elseif(ltyp.eq.1)then
6729       write(ifhi,'(a)')       'htyp ldo'
6730       elseif(ltyp.eq.2)then
6731       write(ifhi,'(a)')       'htyp lfu'
6732       elseif(ltyp.eq.3)then
6733       write(ifhi,'(a)')       'htyp ldd'
6734       endif
6735       write(ifhi,'(a)')       'xmod lin ymod log'
6736       write(ifhi,'(a,2e11.3)')'xrange',x1,x2
6737       write(ifhi,'(a)')    'text 0 0 "xaxis E?[n]! (GeV)"'
6738       write(ifhi,'(a)')    'text 0 0 "yaxis dN?[n]!/d^3!p"'
6739       write(ifhi,'(a,a)')     'text 0.3 0.10 "T='//ctem//'"'
6740       write(ifhi,'(a,a)')     'text 0.3 0.20 "[m]?[n]!='//chem//'"'
6741       write(ifhi,'(a,a)')     'text 0.3 0.20 "i?max!='//cit//'"'
6742       if(iocite.ne.1)then
6743       write(ifhi,'(a,a)')     'text 0.4 0.91 "V='//cvo//'"'
6744       write(ifhi,'(a,a)')     'text 0.15 0.91 "E='//cen//'"'
6745       endif
6746       write(ifhi,'(a)')       'array 2'
6747 
6748          do j=1,jx
6749       write(ifhi,'(2e12.4)')datx(j),daty(j)
6750          enddo
6751 
6752       write(ifhi,'(a)')    '  endarray'
6753       write(ifhi,'(a)')    'closehisto'
6754 
6755       return
6756       end
6757 
6758 c-----------------------------------------------------------------------
6759       subroutine xhgcfl(u,d,s,iii)
6760 c-----------------------------------------------------------------------
6761 c creates unnormalized histogram for net flavor content of grand
6762 c canonically generated sample
6763 c xpar1: specifies width of plot, netflavor centered
6764 c-----------------------------------------------------------------------
6765       include 'epos.inc'
6766       parameter(nb=200)
6767       common/cfldat/data(nb),datb(nb),datc(nb),datu(nb)
6768      *,datd(nb),dats(nb)
6769       parameter(mxclu=10000)
6770       integer ku(mxclu),kd(mxclu),ks(mxclu)
6771       character cfl*3,cen*6,cvol*6
6772 c... initialize
6773       do i=1,nrclu
6774          ku(i)=0.0
6775          kd(i)=0.0
6776          ks(i)=0.0
6777       enddo
6778 
6779       if(iii.eq.0)then
6780       
6781       ku(nrclu)=u
6782       kd(nrclu)=d
6783       ks(nrclu)=s
6784 
6785       return
6786 
6787       elseif(iii.lt.0)then
6788 
6789       kwid=nint(xpar1)
6790       nbin=2*kwid+1
6791       x1u=keu-kwid
6792       x2u=keu+kwid
6793       x1d=ked-kwid
6794       x2d=ked+kwid
6795       x1s=kes-kwid
6796       x2s=kes+kwid
6797       write(cen,'(f6.1)')tecm
6798       write(cvol,'(f6.1)')volu
6799 
6800       do i=1,nbin
6801       data(i)=x1u+(i-1)
6802       datb(i)=x1d+(i-1)
6803       datc(i)=x1s+(i-1)
6804       datu(i)=0.0
6805       datd(i)=0.0
6806       dats(i)=0.0
6807       enddo
6808 
6809       do i=1,nrclu
6810       nbu=(ku(i)-x1u+1)
6811       nbd=(kd(i)-x1d+1)
6812       nbs=(ks(i)-x1s+1)
6813       if(nbu.le.nbin.and.nbu.ge.1)datu(nbu)=datu(nbu)+1
6814       if(nbd.le.nbin.and.nbd.ge.1)datd(nbd)=datd(nbd)+1
6815       if(nbs.le.nbin.and.nbs.ge.1)dats(nbs)=dats(nbs)+1
6816       enddo
6817 
6818       write(ifhi,'(a)')       'newpage zone 1 3 1'
6819 
6820       write(cfl,'(i3)')keu
6821       write(ifhi,'(a)')       'openhisto'
6822       write(ifhi,'(a)')       'htyp his'
6823       write(ifhi,'(a)')       'xmod lin ymod lin'
6824       write(ifhi,'(a,2e11.3)')'xrange',x1u,x2u
6825       write(ifhi,'(a)')    'text 0 0 "xaxis net u content"'
6826       write(ifhi,'(a)')    'text 0 0 "yaxis N"'
6827       write(ifhi,'(a,a)')     'text 0.4 0.91 "V='//cvol//'"'
6828       write(ifhi,'(a,a)')     'text 0.15 0.91 "E='//cen//'"'
6829       write(ifhi,'(a,a)')     'text 0.65 0.91 "N?u!='//cfl//'"'
6830       write(ifhi,'(a)')       'array 2'
6831 
6832          do j=1,nbin
6833       write(ifhi,'(2e13.5)')data(j),datu(j)
6834          enddo
6835 
6836       write(ifhi,'(a)')    '  endarray'
6837       write(ifhi,'(a)')    'closehisto plot 0'
6838 
6839       write(cfl,'(i3)')ked
6840       write(ifhi,'(a)')       'openhisto'
6841       write(ifhi,'(a)')       'htyp his'
6842       write(ifhi,'(a)')       'xmod lin ymod lin'
6843       write(ifhi,'(a,2e11.3)')'xrange',x1d,x2d
6844       write(ifhi,'(a)')    'text 0 0 "xaxis net d content"'
6845       write(ifhi,'(a)')    'text 0 0 "yaxis N"'
6846       write(ifhi,'(a,a)')     'text 0.4 0.91 "V='//cvol//'"'
6847       write(ifhi,'(a,a)')     'text 0.15 0.91 "E='//cen//'"'
6848       write(ifhi,'(a,a)')     'text 0.65 0.91 "N?d!='//cfl//'"'
6849       write(ifhi,'(a)')       'array 2'
6850 
6851          do j=1,nbin
6852       write(ifhi,'(2e13.5)')datb(j),datd(j)
6853          enddo
6854 
6855       write(ifhi,'(a)')    '  endarray'
6856       write(ifhi,'(a)')    'closehisto plot 0'
6857 
6858       write(cfl,'(i3)')kes
6859       write(ifhi,'(a)')       'openhisto'
6860       write(ifhi,'(a)')       'htyp his'
6861       write(ifhi,'(a)')       'xmod lin ymod lin'
6862       write(ifhi,'(a,2e11.3)')'xrange',x1s,x2s
6863       write(ifhi,'(a)')    'text 0 0 "xaxis net s content"'
6864       write(ifhi,'(a)')    'text 0 0 "yaxis N"'
6865       write(ifhi,'(a,a)')     'text 0.4 0.91 "V='//cvol//'"'
6866       write(ifhi,'(a,a)')     'text 0.15 0.91 "E='//cen//'"'
6867       write(ifhi,'(a,a)')     'text 0.65 0.91 "N?s!='//cfl//'"'
6868       write(ifhi,'(a)')       'array 2'
6869 
6870          do j=1,nbin
6871       write(ifhi,'(2e13.5)')datc(j),dats(j)
6872          enddo
6873 
6874       write(ifhi,'(a)')    '  endarray'
6875       write(ifhi,'(a)')    'closehisto plot 0'
6876 
6877       return
6878 
6879            endif
6880 
6881        end
6882 
6883 c-----------------------------------------------------------------------
6884       subroutine xhgcmt
6885 c-----------------------------------------------------------------------
6886 c creates transverse mass spectrum for QM-droplet decay
6887 c according to grand canonical results
6888 c input:
6889 c  xpar1 specifies particle species by paige id, 0 for all
6890 c  xpar2 and xpar3 specify xrange of plot
6891 c  xpar4 specifies line type : dashed (0), dotted (1), full (2)
6892 c output:
6893 c  histo-file
6894 c  newpage, zone and plot commands not included !!!
6895 c-----------------------------------------------------------------------
6896       include 'epos.inc'
6897       common/citer/iter,itermx
6898       parameter (nbin=200)
6899       real datx(nbin),daty(nbin)
6900       parameter (mspecs=56)
6901       common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
6902       common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
6903       character cen*6,cvo*6,cit*5,ctem*5
6904 
6905       idpa=nint(xpar1)
6906       x1=xpar2
6907       x2=xpar3
6908       ltyp=nint(xpar4)
6909 
6910       id=0
6911       jx=100
6912       do i=1,nspecs
6913       if(ispecs(i).eq.idpa)id=i
6914       enddo
6915 
6916       dx=(x2-x1)/2./jx
6917       x0=x1+dx
6918 
6919          do j=1,jx
6920          datx(j)=x0+(j-1)*dx*2.
6921          daty(j)=0.0
6922 
6923        if(id.eq.0)then
6924 
6925       do 10 i=1,nspecs
6926       dndmt=0.0
6927       if(datx(j).ge.aspecs(i))then
6928       x=100.
6929       xx=100.
6930       if(tem.ne.0.)x=datx(j)/tem
6931       if(tem.ne.0.)xx=chemgc(i)/tem
6932       if(abs(xx).le.60)dndmt=gspecs(i)*volu/hquer**3*exp(xx)*datx(j)
6933      */4./pi**3*hgcbk1(x)
6934       endif
6935       daty(j)=daty(j)+dndmt
6936 10    continue
6937 
6938        else
6939 
6940       dndmt=0.0
6941       if(datx(j).ge.aspecs(id))then
6942       x=100.
6943       xx=100.
6944       if(tem.ne.0.)x=datx(j)/tem
6945       if(tem.ne.0.)xx=chemgc(id)/tem
6946       if(abs(xx).le.60)dndmt=gspecs(id)*volu/hquer**3*exp(xx)*datx(j)
6947      */4./pi**3*hgcbk1(x)
6948       endif
6949       daty(j)=dndmt
6950 
6951        endif
6952 
6953          enddo
6954 
6955       write(cit,'(i5)')itermx
6956       write(cen,'(f6.1)')tecm
6957       write(cvo,'(f6.1)')volu
6958       write(ctem,'(f5.3)')tem
6959       write(ifhi,'(a)')       'openhisto'
6960       if(ltyp.eq.0)then
6961       write(ifhi,'(a)')       'htyp lda'
6962       elseif(ltyp.eq.1)then
6963       write(ifhi,'(a)')       'htyp ldo'
6964       elseif(ltyp.eq.2)then
6965       write(ifhi,'(a)')       'htyp lfu'
6966       endif
6967       write(ifhi,'(a)')       'xmod lin ymod log'
6968       write(ifhi,'(a,2e11.3)')'xrange',x1,x2
6969       write(ifhi,'(a)')    'text 0 0 "xaxis m?t! (GeV)"'
6970       write(ifhi,'(a)')    'text 0 0 "yaxis dN?[n]!/d^2!m?t! "'
6971       write(ifhi,'(a,a)')     'text 0.3 0.10 "T='//ctem//'"'
6972       write(ifhi,'(a,a)')     'text 0.3 0.20 "i?max!='//cit//'"'
6973       write(ifhi,'(a,a)')     'text 0.4 0.91 "V='//cvo//'"'
6974       write(ifhi,'(a,a)')     'text 0.15 0.91 "E='//cen//'"'
6975       write(ifhi,'(a)')       'array 2'
6976 
6977          do j=1,jx
6978       write(ifhi,'(2e12.4)')datx(j),daty(j)
6979          enddo
6980 
6981       write(ifhi,'(a)')    '  endarray'
6982       write(ifhi,'(a)')    'closehisto'
6983 
6984       return
6985       end
6986 
6987 c-----------------------------------------------------------------------
6988       subroutine xhgcmu
6989 c-----------------------------------------------------------------------
6990 c creates multiplicity plot for decayed QM-droplet
6991 c according to grand canonical results
6992 c input:
6993 c  xpar1 specifies species by paige id, 0 for total multiplicity
6994 c  xpar2 specifies xrange to be set automatically (0) or by hand (1)
6995 c  xpar3 and xpar4 xrange if xpar2 ne 0
6996 c  xpar5 xrange = average+-sigma*xpar5
6997 c  xpar6 specifies line type : dashed (0), dotted (1), full (2)
6998 c  xpar7 specifies statistics : same as iostat (0)
6999 c                               boltzmann (1)
7000 c output:
7001 c  histo-file
7002 c  newpage, zone and plot commands not included !!!
7003 c-----------------------------------------------------------------------
7004       include 'epos.inc'
7005       parameter (nbin=200)
7006       real datx(nbin),daty(nbin)
7007       parameter (mspecs=56)
7008       common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
7009       common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
7010       common/cbol/rmsbol(mspecs),ptlbol(mspecs),chebol(mspecs),tembol
7011       common/cgctot/rmstot,ptltot
7012       character cyield*8,cen*6,cvo*6,cinco*1
7013 
7014 
7015       idpa=nint(xpar1)
7016       ixra=nint(xpar2)
7017       iwid=nint(xpar5)
7018       ltyp=nint(xpar6)
7019       ist=nint(xpar7)
7020       if(ist.eq.0.and.iostat.eq.1)ist=1
7021 
7022 
7023       pn=0.0
7024       id=0
7025       jx=100
7026       ymin=1./nevent/10.
7027       if(nevent.le.10)ymin=ymin/10.
7028       do i=1,nspecs
7029       if(ispecs(i).eq.idpa)id=i
7030       enddo
7031 
7032        if(ixra.eq.1)then
7033       x1=anint(xpar3)
7034       x2=anint(xpar4)
7035        else
7036       if(id.eq.0)then
7037       x1=anint(ptltot-iwid*rmstot)
7038       x2=anint(ptltot+iwid*rmstot)
7039       else
7040       x1=anint(ptlngc(id)-iwid*rmsngc(id))
7041       x2=anint(ptlngc(id)+iwid*rmsngc(id))
7042       endif
7043       x2=max(x2,3.0)
7044        endif
7045 
7046       x1=max(x1,0.0)
7047       dx=(x2-x1)/2./jx
7048       x0=x1+dx
7049       pn=0.0
7050 
7051       do j=1,jx
7052       datx(j)=x0+(j-1)*dx*2.
7053       if(id.eq.0)then
7054 
7055 c     total multiplicity
7056 c     ------------------
7057       x=100.
7058       if(rmstot.ge.1.e-10)x=(datx(j)-ptltot)**2/rmstot**2/2.
7059 
7060        if(x.ge.60)then
7061       pn=0.0
7062        else
7063       pn=exp(-x)/rmstot/sqrt(2.*pi)
7064        endif
7065 
7066       daty(j)=pn
7067 
7068          else
7069 
7070 c     one species (specified by id)
7071 c     ------------------------------
7072       x=100.
7073       if(rmsngc(id).ge.1.e-10.and.ist.eq.0)
7074      *x=(datx(j)-ptlngc(id))**2/rmsngc(id)**2/2.
7075       if(rmsbol(id).ge.1.e-10.and.ist.eq.1)
7076      *x=(datx(j)-ptlbol(id))**2/rmsbol(id)**2/2.
7077 
7078        if(x.ge.60)then
7079       pn=0.0
7080        else
7081       if(ist.eq.0)pn=exp(-x)/rmsngc(id)/sqrt(2*pi)
7082       if(ist.eq.1)pn=exp(-x)/rmsbol(id)/sqrt(2*pi)
7083        endif
7084 
7085       daty(j)=pn
7086 
7087          endif
7088          enddo
7089 
7090       if(id.eq.0)then
7091       write(cyield,'(f8.3)')ptltot
7092       else
7093       write(cyield,'(f8.3)')ptlngc(id)
7094       endif
7095       write(cinco,'(i1)')ioinco
7096       write(cen,'(f6.1)')tecm
7097       write(cvo,'(f6.1)')volu
7098       write(ifhi,'(a)')       'openhisto'
7099       if(ltyp.eq.0)then
7100       write(ifhi,'(a)')       'htyp lda'
7101       elseif(ltyp.eq.1)then
7102       write(ifhi,'(a)')       'htyp ldo'
7103       elseif(ltyp.eq.2)then
7104       write(ifhi,'(a)')       'htyp lfu'
7105       elseif(ltyp.eq.3)then
7106       write(ifhi,'(a)')       'htyp ldd'
7107       endif
7108       write(ifhi,'(a)')       'xmod lin ymod log'
7109       write(ifhi,'(a,2e11.3)')'xrange',x1,x2
7110       write(ifhi,'(a,e11.3,a)')'yrange',ymin,'  auto'
7111       write(ifhi,'(a)')    'text 0 0 "xaxis N?[n]!"'
7112       write(ifhi,'(a)')    'text 0 0 "yaxis P(N?[n]!)"'
7113       write(ifhi,'(a,a)')'text 0.3 0.10 "" "L#N?[n]!"G#='//cyield//'""'
7114       write(ifhi,'(a,a)')     'text 0.3 0.2 "conf?in!='//cinco//'"'
7115       if(iocite.ne.1)then
7116       write(ifhi,'(a,a)')     'text 0.4 0.91 "V='//cvo//'"'
7117       write(ifhi,'(a,a)')     'text 0.15 0.91 "E='//cen//'"'
7118       endif
7119       write(ifhi,'(a)')       'array 2'
7120 
7121          do j=1,jx
7122       write(ifhi,'(2e12.4)')datx(j),daty(j)
7123          enddo
7124 
7125       write(ifhi,'(a)')    '  endarray'
7126       write(ifhi,'(a)')    'closehisto'
7127 
7128 
7129       return
7130       end
7131 
7132 
7133 c-----------------------------------------------------------------------
7134       subroutine xhgcmx
7135 c-----------------------------------------------------------------------
7136 c creates multiplicity plot for decayed QM-droplet
7137 c according to grand canonical results POISSON DISTRIB.!!!!
7138 c input:
7139 c  xpar1 specifies species by paige id, 0 for total multiplicity
7140 c  xpar2 specifies xrange to be set automatically (0) or by hand (1)
7141 c  xpar3 and xpar4 xrange if xpar2 ne 0
7142 c  xpar5 xrange = average+-sigma*xpar5
7143 c  xpar6 specifies line type : dashed (0), dotted (1), full (2) dado (3)
7144 c  xpar7 specifies statistics : same as iostat (0)
7145 c                               boltzmann (1)
7146 c output:
7147 c  histo-file
7148 c  newpage, zone and plot commands not included !!!
7149 c-----------------------------------------------------------------------
7150       include 'epos.inc'
7151       parameter (nbin=200)
7152       real datx(nbin),daty(nbin)
7153       parameter (mspecs=56)
7154       common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
7155       common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
7156       common/cbol/rmsbol(mspecs),ptlbol(mspecs),chebol(mspecs),tembol
7157       common/cgctot/rmstot,ptltot
7158       character cyield*8,cen*6,cvo*6,cinco*1
7159 
7160 
7161       idpa=nint(xpar1)
7162       ixra=nint(xpar2)
7163       iwid=nint(xpar5)
7164       ltyp=nint(xpar6)
7165       ist=nint(xpar7)
7166       if(ist.eq.0.and.iostat.eq.1)ist=1
7167       pn=0.
7168 
7169 
7170       id=0
7171       ymin=1./nevent/10.
7172       if(nevent.le.10)ymin=ymin/10.
7173       do i=1,nspecs
7174       if(ispecs(i).eq.idpa)id=i
7175       enddo
7176 
7177        if(ixra.eq.1)then
7178       n1=nint(xpar3)
7179       n2=nint(xpar4)
7180        else
7181       if(id.eq.0)then
7182       n1=nint(ptltot-iwid*rmstot)
7183       n2=nint(ptltot+iwid*rmstot)
7184       else
7185       n1=nint(ptlngc(id)-iwid*rmsngc(id))
7186       n2=nint(ptlngc(id)+iwid*rmsngc(id))
7187       endif
7188       n2=max(n2,3)
7189        endif
7190 
7191       n1=max(n1,0)
7192       jx=n2+1
7193 
7194       do j=1,jx
7195       datx(j)=j-1
7196       jf=1
7197       if(j.gt.1)then
7198       do i=1,j-1
7199       jf=jf*i
7200       enddo
7201       endif
7202       if(id.eq.0)then
7203 
7204 c     total multiplicity
7205 c     ------------------
7206 
7207       daty(j)=1./jf*ptltot**(j-1)*exp(-ptltot)
7208 
7209          else
7210 
7211 c     one species (specified by id)
7212 c     ------------------------------
7213 
7214       if(ist.eq.0)pn=1./jf*ptlngc(id)**(j-1)*exp(-ptlngc(id))
7215       if(ist.eq.1)pn=1./jf*ptlbol(id)**(j-1)*exp(-ptlbol(id))
7216 
7217       daty(j)=pn
7218 
7219          endif
7220          enddo
7221 
7222       if(id.eq.0)then
7223       write(cyield,'(f8.3)')ptltot
7224       else
7225       write(cyield,'(f8.3)')ptlngc(id)
7226       endif
7227       write(cinco,'(i1)')ioinco
7228       write(cen,'(f6.1)')tecm
7229       write(cvo,'(f6.1)')volu
7230       write(ifhi,'(a)')       'openhisto'
7231       if(ltyp.eq.0)then
7232       write(ifhi,'(a)')       'htyp lda'
7233       elseif(ltyp.eq.1)then
7234       write(ifhi,'(a)')       'htyp ldo'
7235       elseif(ltyp.eq.2)then
7236       write(ifhi,'(a)')       'htyp lfu'
7237       elseif(ltyp.eq.3)then
7238       write(ifhi,'(a)')       'htyp ldd'
7239       endif
7240       write(ifhi,'(a)')       'xmod lin ymod log'
7241       write(ifhi,'(a,2i3)')'xrange',n1,n2
7242       write(ifhi,'(a,e11.3,a)')'yrange',ymin,'  auto'
7243       write(ifhi,'(a)')    'text 0 0 "xaxis N?[n]!"'
7244       write(ifhi,'(a)')    'text 0 0 "yaxis P(N?[n]!)"'
7245       write(ifhi,'(a,a)')'text 0.3 0.10 "" "L#N?[n]!"G#='//cyield//'""'
7246       write(ifhi,'(a,a)')     'text 0.3 0.2 "conf?in!='//cinco//'"'
7247       if(iocite.ne.1)then
7248       write(ifhi,'(a,a)')     'text 0.4 0.91 "V='//cvo//'"'
7249       write(ifhi,'(a,a)')     'text 0.15 0.91 "E='//cen//'"'
7250       endif
7251       write(ifhi,'(a)')       'array 2'
7252 
7253          do j=1,jx
7254       write(ifhi,'(2e12.4)')datx(j),daty(j)
7255          enddo
7256 
7257       write(ifhi,'(a)')    '  endarray'
7258       write(ifhi,'(a)')    'closehisto'
7259 
7260 
7261       return
7262       end
7263 
7264 c-----------------------------------------------------------------------
7265       subroutine xhgcpt
7266 c-----------------------------------------------------------------------
7267 c creates transverse momentum spectrum for decayed QM-droplet
7268 c according to grand canonical results
7269 c input:
7270 c  xpar1 specifies particle species by paige id, 0 for all
7271 c  xpar2 rapidity window
7272 c  xpar3 and xpar4 specify xrange of plot
7273 c  xpar5 specifies line type : dashed (0), dotted (1), full (2)
7274 c output:
7275 c  histo-file
7276 c  newpage, zone and plot commands not included !!!
7277 c-----------------------------------------------------------------------
7278       include 'epos.inc'
7279       common/citer/iter,itermx
7280       parameter (nbin=200)
7281       real datx(nbin),daty(nbin)
7282       parameter (mspecs=56)
7283       common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
7284       common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
7285       character crap*5,cen*6,cvo*6,cit*5
7286 
7287       idpa=nint(xpar1)
7288       y=xpar2
7289       x1=xpar3
7290       x2=xpar4
7291       ltyp=xpar5
7292 
7293       write(crap,'(f5.1)')y
7294       id=0
7295       jx=100
7296       do i=1,nspecs
7297       if(ispecs(i).eq.idpa)id=i
7298       enddo
7299 
7300       dx=(x2-x1)/2./jx
7301       x0=x1+dx
7302 
7303          do j=1,jx
7304          datx(j)=x0+(j-1)*dx*2.
7305          daty(j)=0.0
7306 
7307        if(id.eq.0)then
7308 
7309       do 10 i=1,nspecs
7310       x=100.
7311       if(tem.ne.0.)
7312      *x=(sqrt(aspecs(i)**2+datx(j)**2)*cosh(y)-chemgc(i))/tem
7313        if(x.ge.60)then
7314       dndpt=0.0
7315        else
7316       dndpt=exp(-x)
7317        endif
7318       dndpt=dndpt*gspecs(i)*volu/hquer**3*cosh(y)
7319      **sqrt(aspecs(i)**2+datx(j)**2)/8./pi**3
7320       daty(j)=daty(j)+dndpt
7321 10    continue
7322 
7323        else
7324 
7325       x=100.
7326       if(tem.ne.0.)
7327      *x=(sqrt(aspecs(id)**2+datx(j)**2)*cosh(y)-chemgc(id))/tem
7328        if(x.ge.60)then
7329       dndpt=0.0
7330        else
7331       dndpt=exp(-x)
7332        endif
7333       dndpt=dndpt*gspecs(id)*volu/hquer**3*cosh(y)
7334      **sqrt(aspecs(id)**2+datx(j)**2)/8./pi**3
7335       daty(j)=dndpt
7336 
7337        endif
7338 
7339          enddo
7340 
7341       write(cit,'(i5)')itermx
7342       write(cen,'(f6.1)')tecm
7343       write(cvo,'(f6.1)')volu
7344       write(ifhi,'(a)')       'openhisto'
7345       if(ltyp.eq.0)then
7346       write(ifhi,'(a)')       'htyp lda'
7347       elseif(ltyp.eq.1)then
7348       write(ifhi,'(a)')       'htyp ldo'
7349       elseif(ltyp.eq.2)then
7350       write(ifhi,'(a)')       'htyp lfu'
7351       endif
7352       write(ifhi,'(a)')       'xmod lin ymod log'
7353       write(ifhi,'(a,2e11.3)')'xrange',x1,x2
7354       write(ifhi,'(a)')    'text 0 0 "xaxis p?t! (GeV/c)"'
7355       write(ifhi,'(a)')    'text 0 0 "yaxis dN?[n]!/dyd^2!p?t!"'
7356       write(ifhi,'(a)')    'text 0.10 0.10 "y = '//crap//'"'
7357       write(ifhi,'(a)')    'text 0.10 0.30 "i?max! = '//cit//'"'
7358       write(ifhi,'(a,a)')     'text 0.4 0.91 "V='//cvo//'"'
7359       write(ifhi,'(a,a)')     'text 0.15 0.91 "E='//cen//'"'
7360       write(ifhi,'(a)')       'array 2'
7361 
7362          do j=1,jx
7363       write(ifhi,'(2e12.4)')datx(j),daty(j)
7364          enddo
7365 
7366       write(ifhi,'(a)')    '  endarray'
7367       write(ifhi,'(a)')    'closehisto'
7368 
7369       return
7370       end
7371 
7372 c-----------------------------------------------------------------------
7373       subroutine xhgcra
7374 c-----------------------------------------------------------------------
7375 c creates rapidity distribution for decayed QM-droplet
7376 c according to grand canonical results
7377 c input:
7378 c  xpar1 specifies particle species by paige id, 0 for all
7379 c  xpar2 and xpar3 specify xrange of plot
7380 c  xpar4 specifies line type : dashed (0), dotted (1), full (2)
7381 c output:
7382 c  histo-file
7383 c  newpage, zone and plot commands not included !!!
7384 c-----------------------------------------------------------------------
7385       include 'epos.inc'
7386       parameter (nbin=200)
7387       real datx(nbin),daty(nbin)
7388       parameter (mspecs=56)
7389       common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
7390       common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
7391       common/cgctot/rmstot,ptltot
7392       character cen*6,cvo*6,cng*8
7393 
7394       idpa=nint(xpar1)
7395       x1=nint(xpar2)
7396       x2=nint(xpar3)
7397       ltyp=nint(xpar4)
7398 
7399       id=0
7400       jx=100
7401       ymin=1./nevent/10.
7402       if(nevent.le.10)ymin=ymin/10.
7403       do i=1,nspecs
7404       if(ispecs(i).eq.idpa)id=i
7405       enddo
7406 
7407       dx=(x2-x1)/2./jx
7408       x0=x1+dx
7409 
7410          do j=1,jx
7411 
7412          datx(j)=x0+(j-1)*dx*2.
7413          daty(j)=0.0
7414          y=datx(j)
7415          if(ish.ge.9)write(ifch,*)'cosh y:',cosh(y)
7416 
7417        if(id.eq.0)then
7418 
7419       do 10 i=1,nspecs
7420       dndy=0.0
7421       sum=aspecs(i)**2*tem+2.*aspecs(i)*tem**2/cosh(y)
7422      *+2.*tem**3/cosh(y)**2
7423       x=100.
7424       if(tem.ne.0.0)
7425      *x=(aspecs(i)*cosh(y)-chemgc(i))/tem
7426 
7427        if(x.ge.60.)then
7428       pro=0.0
7429        else
7430       pro=exp(-x)
7431       endif
7432 
7433       pro=pro*gspecs(i)*volu/hquer**3/4./pi**2
7434 
7435       if(pro.ge.(1.e-30).and.sum.ge.(1.e-30))then
7436       che=alog(pro)+alog(sum)
7437       else
7438       che=-61.0
7439       endif
7440       if(che.le.60.0.and.che.ge.(-60.0))dndy=pro*sum
7441 c     if(che.le.60.0.and.che.ge.(-60.0))dndy=exp(che)
7442 
7443       daty(j)=daty(j)+dndy
7444 
7445 10    continue
7446 
7447        else
7448 
7449       dndy=0.0
7450       sum=aspecs(id)**2*tem+2.*aspecs(id)*tem**2/cosh(y)
7451      *+2.*tem**3/cosh(y)**2
7452       x=100.
7453       if(tem.ne.0.0)
7454      *x=(aspecs(id)*cosh(y)-chemgc(id))/tem
7455 
7456        if(x.ge.60.)then
7457       pro=0.0
7458        else
7459       pro=exp(-x)
7460       endif
7461 
7462       pro=pro*gspecs(id)*volu/hquer**3/4./pi**2
7463 
7464       if(pro.ge.(1.e-30).and.sum.ge.(1.e-30))then
7465       che=alog(pro)+alog(sum)
7466       else
7467       che=-61.0
7468       endif
7469       if(che.le.60..and.che.ge.-60.)dndy=pro*sum
7470 
7471       daty(j)=dndy
7472 
7473        endif
7474 
7475          enddo
7476 
7477       write(cen,'(f6.1)')tecm
7478       write(cvo,'(f6.1)')volu
7479       if(id.eq.0)then
7480       write(cng,'(f8.3)')ptltot
7481       else
7482       write(cng,'(f8.3)')ptlngc(id)
7483       endif
7484       write(ifhi,'(a)')       'openhisto'
7485       if(ltyp.eq.0)then
7486       write(ifhi,'(a)')       'htyp lda'
7487       elseif(ltyp.eq.1)then
7488       write(ifhi,'(a)')       'htyp ldo'
7489       elseif(ltyp.eq.2)then
7490       write(ifhi,'(a)')       'htyp lfu'
7491       endif
7492 
7493       write(ifhi,'(a)')       'xmod lin ymod log'
7494       write(ifhi,'(a,2e11.3)')'xrange',x1,x2
7495       write(ifhi,'(a,e11.3,a)')'yrange',ymin,'  auto'
7496       write(ifhi,'(a)')    'text 0 0 "xaxis y"'
7497       write(ifhi,'(a)')    'text 0 0 "yaxis dN?[n]!/dy"'
7498       write(ifhi,'(a,a)')     'text 0.4 0.91 "V='//cvo//'"'
7499       write(ifhi,'(a,a)')     'text 0.15 0.91 "E='//cen//'"'
7500       write(ifhi,'(a,a)')     'text 0.3 0.10 "N?[n]!='//cng//'"'
7501       write(ifhi,'(a)')       'array 2'
7502 
7503          do j=1,jx
7504       write(ifhi,'(2e12.4)')datx(j),daty(j)
7505          enddo
7506 
7507       write(ifhi,'(a)')    '  endarray'
7508       write(ifhi,'(a)')    'closehisto'
7509 
7510       return
7511       end
7512 
7513 c-----------------------------------------------------------------------
7514       subroutine xhnben
7515 c-----------------------------------------------------------------------
7516 c produces histogram of energy spectrum (after metropolis run)
7517 c complete histogram: openhisto ... closehisto
7518 c iocite=1 required
7519 c-----------------------------------------------------------------------
7520 c xpar1: particle species (venus id-code)
7521 c xpar2: 1: actual spectrum 2: fit
7522 c xpar3: 1: de/d3p 2: ede/d3e
7523 c-----------------------------------------------------------------------
7524       include 'epos.inc'
7525       parameter (mspecs=56)
7526       common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
7527       parameter (nhise=100)
7528       common/chise/hise(mspecs,nhise)
7529       parameter (literm=500)
7530       common/cmet/kspecs(mspecs),liter,lspecs(literm,mspecs)
7531      *,iterl(literm),iterc(literm)
7532       real datx(nhise),daty(nhise),dats(nhise)
7533       common/citer/iter,itermx
7534       character ch*1,chid*5,cyield*9,ctem*5
7535       de=2./nhise/2.
7536 
7537       if(iocite.ne.1)stop'STOP: xhnben: iocite=1 required'
7538 
7539       idcode=nint(xpar1)
7540       mode=nint(xpar2)
7541       kind=nint(xpar3)
7542 
7543            do j=1,nspecs
7544            if(idcode.eq.ispecs(j))then
7545 
7546       id=idcode
7547       am=aspecs(j)
7548       yield=1.*kspecs(j)/(itermx-iternc)
7549       if(kind.eq.1)ch=' '
7550       if(kind.eq.2)ch='e'
7551       ll=kind-1
7552       e0=am+de
7553       nebins=0
7554         do i=1,nhise
7555       e=e0+(i-1)*2*de
7556       p1=sqrt((e-de)**2-am**2)
7557       p2=sqrt((e+de)**2-am**2)
7558       d3p=4*pi*(p2**3-p1**3)/3
7559       datx(i)=e
7560       y=(1-ll+ll*e)*hise(j,i)/(itermx-iternc)/d3p
7561       if(y.gt.0.)then
7562       nebins=nebins+1
7563       daty(i)=alog(y)
7564       d=y/sqrt(hise(j,i))
7565       dats(i)=1e10
7566       if(y-d.gt.0.)dats(i)=alog(y+d)-alog(y-d)
7567       else
7568       daty(i)=-100
7569       dats(i)=1e10
7570       endif
7571 c-c   if(e.lt.0.2)dats(i)=1e10
7572         enddo
7573       a=0.
7574       b=0.
7575         if(nebins.ge.3)then
7576       call utfit(datx,daty,nhise,dats,1,a,b,siga,sigb,chi2,q)
7577       tem=-1./b
7578       if(tem.lt.0.050.or.tem.gt.10.)then
7579       tem=0.
7580       a=0.
7581       b=0.
7582       endif
7583         endif
7584       do i=1,nhise
7585       daty(i)=exp(daty(i))
7586       enddo
7587       write(chid,'(i5)')id
7588       write(cyield,'(f9.4)')yield
7589       ctem='     '
7590       if(tem.gt.0.)write(ctem,'(f5.3)')tem
7591       write(ifhi,'(a)')    'openhisto xrange 0 3'
7592       write(ifhi,'(a)')    'htyp lin xmod lin ymod log'
7593       write(ifhi,'(a,a)')  'text 0 0 "title id='//chid
7594      *                           ,'   N='//cyield//'   T='//ctem//'"'
7595       write(ifhi,'(a)')    'text 0 0 "xaxis energy (GeV)"'
7596       write(ifhi,'(a)')    'text 0 0 "yaxis '//ch//' dn/d3p (GeV-3)"'
7597       write(ifhi,'(a)')    'array 2'
7598       do i=1,nhise
7599       if(mode.eq.1)write(ifhi,'(2e12.4)')datx(i),daty(i)
7600       if(mode.eq.2)write(ifhi,'(2e12.4)')datx(i),exp(a+b*datx(i))
7601       enddo
7602       write(ifhi,'(a)')    '  endarray'
7603       write(ifhi,'(a)')    'closehisto'
7604 
7605            endif
7606            enddo
7607 
7608       return
7609       end
7610 
7611 c-----------------------------------------------------------------------
7612       subroutine xhnbit
7613 c-----------------------------------------------------------------------
7614 c produces histogram of multiplicity versus iterations (after metropolis run)
7615 c complete histogram: openhisto ... closehisto
7616 c iocite=1 required
7617 c-----------------------------------------------------------------------
7618 c xpar1: particle species (0=all, else venus id-code)
7619 c xpar2: 1:actual multiplicity 2:average multiplicity 3:grand canonical
7620 c-----------------------------------------------------------------------
7621       include 'epos.inc'
7622       parameter (mspecs=56)
7623       common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
7624       parameter (literm=500)
7625       common/cmet/kspecs(mspecs),liter,lspecs(literm,mspecs)
7626      *,iterl(literm),iterc(literm)
7627       real datlx(literm),datly(literm)
7628       common/citer/iter,itermx
7629       character chid*5,ctecm*5,cvolu*6
7630       common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
7631       common/cgctot/rmstot,ptltot
7632 
7633       if(iocite.ne.1)stop'STOP: xhnbit: iocite=1 required'
7634 
7635       idcode=nint(xpar1)
7636       mode=nint(xpar2)
7637 
7638            if(idcode.eq.0)then
7639 
7640       yield=0
7641       do j=1,nspecs
7642       yield=yield+1.*kspecs(j)/(itermx-iternc)
7643       enddo
7644       datlx(1)=(iterl(1)+1)/2.
7645       do li=2,liter-1
7646       datlx(li)=(iterl(li)+iterl(li-1)+1)/2.
7647       enddo
7648       x1=0
7649       x2=iterl(liter-1)
7650       do li=1,liter-1
7651       y=0
7652       do j=1,nspecs
7653       y=y+lspecs(li,j)
7654       enddo
7655       if(mode.eq.1)datly(li)=y/iterc(li)
7656       if(mode.eq.2)datly(li)=yield
7657       if(mode.eq.3)datly(li)=ptltot
7658       enddo
7659       write(ctecm,'(f5.1)')tecm
7660       write(cvolu,'(f6.1)')volu
7661       write(ifhi,'(a,2e11.3)')'openhisto xrange',x1,x2
7662       write(ifhi,'(a)')       'htyp lin xmod lin ymod lin'
7663       write(ifhi,'(a,a)')     'text 0 0 "title E = '//ctecm//'   V = '
7664      *                                 ,cvolu//'"'
7665       write(ifhi,'(a)')       'text 0 0 "xaxis iterations"'
7666       write(ifhi,'(a)')       'text 0 0 "yaxis multiplicity"'
7667       write(ifhi,'(a)')       'array 2'
7668       do i=1,liter-1
7669       write(ifhi,'(2e12.4)')   datlx(i),datly(i)
7670       enddo
7671       write(ifhi,'(a)')       '  endarray'
7672       write(ifhi,'(a)')       'closehisto'
7673 
7674            else
7675 
7676            do j=1,nspecs
7677            if(idcode.eq.ispecs(j))then
7678 
7679       yield=1.*kspecs(j)/(itermx-iternc)
7680       write(chid,'(i5)')idcode
7681       do li=1,liter-1
7682       datlx(li)=iterl(li)
7683       enddo
7684       x1=0
7685       x2=datlx(liter-1)
7686       do li=1,liter-1
7687       if(mode.eq.1)datly(li)=lspecs(li,j)*1./iterc(li)
7688       if(mode.eq.2)datly(li)=yield
7689       if(mode.eq.3)datly(li)=ptlngc(j)
7690       enddo
7691       write(ifhi,'(a,2e11.3)')'openhisto xrange',x1,x2
7692       write(ifhi,'(a)')       'htyp lin xmod lin ymod lin'
7693       write(ifhi,'(a)')       'text 0 0 "title id='//chid//'"'
7694       write(ifhi,'(a)')       'text 0 0 "xaxis iterations "'
7695       write(ifhi,'(a)')       'text 0 0 "yaxis multiplicity"'
7696       write(ifhi,'(a)')       'array 2'
7697       do i=1,liter-1
7698       write(ifhi,'(2e12.4)')   datlx(i),datly(i)
7699       enddo
7700       write(ifhi,'(a)')       '  endarray'
7701       write(ifhi,'(a)')       'closehisto'
7702 
7703            endif
7704            enddo
7705 
7706            endif
7707 
7708       return
7709       end
7710 
7711 c-----------------------------------------------------------------------
7712       subroutine xhnbmu
7713 c-----------------------------------------------------------------------
7714 c produces histogram of multiplicity distribution (after metropolis run)
7715 c complete histogram: openhisto ... closehisto
7716 c iocite=1 required
7717 c-----------------------------------------------------------------------
7718 c xpar1: particle species (0=all, else venus id-code)
7719 c xpar2: xrange automatic (0) or given via xpar3,4 (else)
7720 c xpar3,4: xrange
7721 c-----------------------------------------------------------------------
7722       include 'epos.inc'
7723       parameter (mspecs=56)
7724       common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
7725       parameter (nhismu=500)
7726       common/chismu/hismu(mspecs,0:nhismu),hismus(nhismu)
7727       parameter (literm=500)
7728       common/cmet/kspecs(mspecs),liter,lspecs(literm,mspecs)
7729      *,iterl(literm),iterc(literm)
7730       real datx(nhismu),daty(nhismu)
7731       common/citer/iter,itermx
7732       common /clatt/nlattc,npmax
7733       character chid*5,cyield*9,ctecm*5,cvolu*6
7734 
7735       if(iocite.ne.1)stop'STOP: xhnbmu: iocite=1 required'
7736 
7737       idcode=nint(xpar1)
7738       ixr=nint(xpar2)
7739       xx1=xpar3
7740       xx2=xpar4
7741 
7742       write(ctecm,'(f5.1)')tecm
7743       write(cvolu,'(f6.1)')volu
7744 
7745            if(idcode.eq.0)then
7746 
7747       yield=0
7748       do j=1,nspecs
7749       yield=yield+1.*kspecs(j)/(itermx-iternc)
7750       enddo
7751       write(cyield,'(f9.4)')yield
7752       i1=0
7753       i2=nlattc
7754       mus=0
7755       do i=1,nhismu
7756       if(i1.eq.0.and.nint(hismus(i)).gt.0)i1=i
7757       if(nint(hismus(i)).gt.0)i2=i
7758       mus=mus+hismus(i)
7759       enddo
7760       ij=0.5*(i1+i2)*0.20
7761       if(itermx.le.1000)ij=0.5*(i1+i2)*0.40
7762       if(itermx.le.100)ij=0.5*(i1+i2)*0.80
7763       i1=i1-ij
7764       i1=max(i1,2)
7765       i2=i2+ij
7766       ii=10
7767       if(i1.le.50)ii=5
7768       if(i1.le.20)ii=2
7769       i1=i1/ii*ii
7770       i2=i2/ii*ii+ii
7771            do i=i1,i2
7772       l=1+i-i1
7773       datx(l)=i
7774       daty(l)=hismus(i)/mus
7775            enddo
7776       jx=1+i2-i1
7777       if(ixr.eq.0)then
7778       x1=i1
7779       x2=i2
7780       else
7781       x1=xx1
7782       x2=xx2
7783       endif
7784       write(ifhi,'(a,2e11.3)')'openhisto xrange',x1,x2
7785       write(ifhi,'(a)')       'htyp lin xmod lin ymod log'
7786       write(ifhi,'(a,a)')     'text 0 0 "title E = '//ctecm//'   V = '
7787      *                              ,cvolu//'"'
7788       write(ifhi,'(a)')       'text 0 0 "xaxis multiplicity n  "'
7789       write(ifhi,'(a)')       'text 0 0 "yaxis dN/dn"'
7790       write(ifhi,'(a)')       'text 0.30 0.25 "N?MC!='//cyield//'"'
7791       write(ifhi,'(a)')       'array 2'
7792       do i=1,jx
7793       write(ifhi,'(2e12.4)')   datx(i),daty(i)
7794       enddo
7795       write(ifhi,'(a)')       '  endarray'
7796       write(ifhi,'(a)')       'closehisto'
7797 
7798            else
7799 
7800            do j=1,nspecs
7801            if(idcode.eq.ispecs(j))then
7802 
7803       yield=1.*kspecs(j)/(itermx-iternc)
7804       write(cyield,'(f9.4)')yield
7805       write(chid,'(i5)')idcode
7806       i1=0
7807       i2=nlattc
7808       mus=0
7809       do i=0,nhismu
7810       if(i1.eq.0.and.nint(hismu(j,i)).gt.0)i1=i
7811       if(nint(hismu(j,i)).gt.0)i2=i
7812       mus=mus+hismu(j,i)
7813       enddo
7814       ij=0.5*(i1+i2)*0.30
7815       if(itermx.le.1000)ij=0.5*(i1+i2)*0.60
7816       if(itermx.le.100)ij=0.5*(i1+i2)*1.20
7817       i1=i1-ij
7818       i1=max(i1,0)
7819       i2=i2+ij
7820       ii=10
7821       if(i1.le.50)ii=5
7822       if(i1.le.20)ii=2
7823       i1=i1/ii*ii
7824       i2=i2/ii*ii+ii
7825            do i=i1,i2
7826       l=1+i-i1
7827       datx(l)=i
7828       daty(l)=hismu(j,i)/mus
7829            enddo
7830       jx=1+i2-i1
7831       if(ixr.eq.0)then
7832       x1=i1
7833       x2=i2
7834       else
7835       x1=xx1
7836       x2=xx2
7837       endif
7838       write(ifhi,'(a,2e11.3)')'openhisto xrange',x1,x2
7839       write(ifhi,'(a)')       'htyp lin xmod lin ymod log'
7840       write(ifhi,'(a)')       'text 0 0 "title id='//chid//'"'
7841       write(ifhi,'(a)')       'text 0 0 "xaxis multiplicity n  "'
7842       write(ifhi,'(a)')       'text 0 0 "yaxis dN/dn"'
7843       write(ifhi,'(a)')       'text 0.30 0.25 "N?MC!='//cyield//'"'
7844       write(ifhi,'(a)')       'array 2'
7845       do i=1,jx
7846       write(ifhi,'(2e12.4)')   datx(i),daty(i)
7847       enddo
7848       write(ifhi,'(a)')       '  endarray'
7849       write(ifhi,'(a)')       'closehisto'
7850 
7851            endif
7852            enddo
7853 
7854            endif
7855 
7856       return
7857       end
7858 
7859 c-----------------------------------------------------------------------
7860       subroutine xhnbmz
7861 c-----------------------------------------------------------------------
7862 c produces histogram of multiplicity distribution from droplet decay
7863 c or average multiplicity versus iterations
7864 c for massless hadrons
7865 c complete histogram: openhisto ... closehisto
7866 c-----------------------------------------------------------------------
7867 c xpar1: particle species (0=all, else venus id-code)
7868 c xpar2: lower limit multiplicity
7869 c xpar3: upper limit multiplicity
7870 c xpar4: lower limit total multiplicity   (also necc for xpar1.ne.0)
7871 c xpar5: upper limit  "      "            (also necc for xpar1.ne.0)
7872 c xpar6: sets htyp: 1->lfu, 2->ldo, 3->lda, 4->ldd
7873 c xpar7: 0: multiplicity distribution
7874 c        >0: av multiplicity vs iterations (itermx=xpar7)
7875 c-----------------------------------------------------------------------
7876       include 'epos.inc'
7877       parameter(maxp=500)
7878       common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
7879       common/ctst/psulog,wtulog
7880       parameter (mspecs=56)
7881       common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
7882       parameter (nhismu=500)
7883       common/cflac/ifok(nflav,mspecs),ifoa(nflav)
7884       real datx(nhismu),datyu(nhismu)
7885       character cyieur*9
7886       real pzlog(nhismu)
7887       double precision spelog,cc,bb,dsu
7888       common/cyield/yield
7889       character*3 htyp
7890 
7891       idcode=nint(xpar1)
7892       x1=xpar2
7893       x2=xpar3
7894       i1=nint(xpar2)
7895       i2=nint(xpar3)
7896       ii1=nint(xpar4)
7897       ii2=nint(xpar5)
7898       ih=nint(xpar6)
7899       htyp='lin'
7900       if(ih.eq.1)htyp='lfu'
7901       if(ih.eq.2)htyp='ldo'
7902       if(ih.eq.3)htyp='lda'
7903       if(ih.eq.4)htyp='ldd'
7904       itmax=nint(xpar7)
7905 
7906       wtrlog=-1e30
7907            do i=ii1,ii2
7908       if(i.ge.2)then
7909       np=i
7910       do k=1,np
7911       ident(k)=110
7912       enddo
7913       call hnbtst(0)
7914       wtzlog=wtulog
7915       if(ioflac.eq.0)call hnbspg(keu,ked,kes,kec,keb,ket,0,np,spelog)
7916       if(ioflac.ne.0)call hnbspf(keu,ked,kes,kec,keb,ket,0,np,spelog)
7917       wtulog=wtulog+spelog
7918       else
7919       wtzlog=-1000
7920       wtulog=-1000
7921       endif
7922       pzlog(1+i-ii1)=wtzlog
7923       datyu(1+i-ii1)=wtulog
7924       wtrlog=max(wtrlog,wtulog)
7925            enddo
7926       yield=0
7927       su=0
7928            do i=ii1,ii2
7929       l=1+i-ii1
7930       pzlog(l)=pzlog(l)-wtrlog
7931       datyu(l)=datyu(l)-wtrlog
7932       if(datyu(l).gt.-50.)then
7933       datyu(l)=exp(datyu(l))
7934       else
7935       datyu(l)=exp(-50.)
7936       endif
7937       yield=yield+i*datyu(l)
7938       su=su+datyu(l)
7939            enddo
7940       yield=yield/su
7941            do i=ii1,ii2
7942       l=1+i-ii1
7943       datx(l)=i
7944       datyu(l)=datyu(l)/su
7945            enddo
7946       jx=1+ii2-ii1
7947       write(cyieur,'(f9.4)')yield
7948 c     ---
7949         if(idcode.eq.0.and.itmax.eq.0)then
7950       write(ifhi,'(a,2e11.3)')'openhisto xrange',x1,x2
7951       write(ifhi,'(a)')       'htyp '//htyp//' xmod lin ymod log'
7952       write(ifhi,'(a)')       'text 0.30 0.15 "N?ana!='//cyieur//'"'
7953       write(ifhi,'(a)')       'array 2'
7954       do i=1,jx
7955       write(ifhi,'(2e12.4)')   datx(i),datyu(i)
7956       enddo
7957       write(ifhi,'(a)')       '  endarray'
7958       write(ifhi,'(a)')       'closehisto'
7959         elseif(idcode.eq.0)then
7960       write(ifhi,'(a,2e11.3)')'openhisto xrange',0.,itmax*1.
7961       write(ifhi,'(a)')       'htyp '//htyp//' xmod lin ymod lin'
7962       write(ifhi,'(a)')       'array 2'
7963       itm=20
7964       do i=1,itm
7965       write(ifhi,'(2e12.4)')   (i-1.)*itmax/(itm-1.),yield
7966       enddo
7967       write(ifhi,'(a)')       '  endarray'
7968       write(ifhi,'(a)')       'closehisto'
7969         endif
7970 c     ---
7971       if(idcode.eq.0)return
7972 
7973            do j=1,nspecs
7974            if(idcode.eq.ispecs(j))then
7975 
7976       wtrlog=-1e30
7977            do i=i1,i2
7978       l=1+i-i1
7979       datx(l)=i
7980            enddo
7981       yield=0
7982       suj=0
7983       dsu=su
7984            do i=i1,i2
7985       l=1+i-i1
7986       bb=0
7987       nfi=0
7988       do ntot=max(i+1,ii1),min(i2*nspecs,ii2)
7989       nfi=nfi+1
7990       cc=1d0
7991       do kc=1,i
7992       cc=cc*(1.+ntot-kc)/kc*gspecs(j)
7993       enddo
7994       ku=keu-i*ifok(1,j)
7995       kd=ked-i*ifok(2,j)
7996       ks=kes-i*ifok(3,j)
7997       kc=kec-i*ifok(4,j)
7998       kb=keb-i*ifok(5,j)
7999       kt=ket-i*ifok(6,j)
8000       if(ioflac.eq.0)call hnbspg(ku,kd,ks,kc,kb,kt,j,ntot-i,spelog)
8001       if(ioflac.ne.0)call hnbspf(ku,kd,ks,kc,kb,kt,j,ntot-i,spelog)
8002       cc=cc*dexp(spelog)
8003       bb=bb+cc*dexp(1.d0*pzlog(1+ntot-ii1))/dsu
8004       enddo
8005       datyu(l)=bb
8006       yield=yield+i*datyu(l)
8007       suj=suj+datyu(l)
8008            enddo
8009       yield=yield/suj
8010       jx=1+i2-i1
8011       write(cyieur,'(f9.4)')yield
8012 c     ---
8013         if(itmax.eq.0)then
8014       write(ifhi,'(a,2e11.3)')'openhisto xrange',x1,x2
8015       write(ifhi,'(a)')       'htyp '//htyp//' xmod lin ymod log'
8016       write(ifhi,'(a)')       'text 0.30 0.15 "N?ana!='//cyieur//'"'
8017       write(ifhi,'(a)')       'array 2'
8018       do i=1,jx
8019       write(ifhi,'(2e12.4)')   datx(i),datyu(i)
8020       enddo
8021       write(ifhi,'(a)')       '  endarray'
8022       write(ifhi,'(a)')       'closehisto'
8023         else
8024       write(ifhi,'(a,2e11.3)')'openhisto xrange',0.,itmax*1.
8025       write(ifhi,'(a)')       'htyp '//htyp//' xmod lin ymod lin'
8026       write(ifhi,'(a)')       'array 2'
8027       itm=20
8028       do i=1,itm
8029       write(ifhi,'(2e12.4)')   (i-1.)*itmax/(itm-1.),yield
8030       enddo
8031       write(ifhi,'(a)')       '  endarray'
8032       write(ifhi,'(a)')       'closehisto'
8033         endif
8034 c     ---
8035       return
8036 
8037            endif
8038            enddo
8039 
8040       end
8041 
8042 c-----------------------------------------------------------------------
8043       subroutine xhnbte(iii)
8044 c-----------------------------------------------------------------------
8045 c fills histograms (iii>=0) or writes histogram to histo-file (iii<0)
8046 c regarding exponential autocorrelation time and acceptance rate
8047 c
8048 c input:
8049 c   requires complete run with application hadron (iappl=1)
8050 c   or application metropolis (iappl=4)
8051 c   ioceau=1 necessary
8052 c
8053 c  output:
8054 c   for iii=0 (only valid for iappl=4):
8055 c     data(nrevt): nrevt  (event number)               /cdat/
8056 c     datb(nrevt): taui   (calculated corr time)       /cdat/
8057 c     datc(nrevt): accrat (acceptance rate)            /cdat/
8058 c     datd(nrevt): taue   (parametrized corr time)     /cdat/
8059 c   for iii>0 (only valid for iappl=1):
8060