EPOS/epos167/epos-dro-168.f

   1 c----------------------------------------------------------------------
   2       subroutine amicro
   3 c----------------------------------------------------------------------
   4 c  microcanonical decay of cluster specified via keu...ket, tecm, volu
   5 c----------------------------------------------------------------------
   6       include 'epos.inc'
   7       common/drop9/mkeu,mked,mkes,mkec,mkeb,mket
   8      $     ,iwkeu,iwked,iwkes,iwkec,iwkeb,iwket
   9       common/cxyzt/xptl(mxptl),yptl(mxptl),zptl(mxptl),tptl(mxptl)
  10      *,optl(mxptl),uptl(mxptl),sptl(mxptl),rptl(mxptl,3)
  11       double precision tpro,zpro,ttar,ztar,ttaus,detap,detat
  12       common /cttaus/  tpro,zpro,ttar,ztar,ttaus,detap,detat
  13       integer jc(nflav,2),ic(2)
  14
  15       call utpri('amicro',ish,ishini,4)
  16
  17       nevt=0
  18       nptl=0
  19
  20       ttaus=1
  21 ctp060829      taus=sngl(ttaus)
  22       ypjtl=6
  23       yhaha=3
  24       etapro=(ypjtl-yhaha)*etafac
  25       etatar=-yhaha*etafac
  26       detap=dble(etapro)
  27       detat=dble(etatar)
  28       tpro=dcosh(detap)
  29       zpro=dsinh(detap)
  30       ttar=dcosh(detat)
  31       ztar=dsinh(detat)
  32
  33       if(ish.ge.5)write(ifch,'(a/6i4)')
  34      *' keu ked kes kec keb ket:',keu,ked,kes,kec,keb,ket
  35       do i=1,6
  36       jc(i,1)=0
  37       jc(i,2)=0
  38       enddo
  39  10   if(mkeu.ne.0.or.iwkeu.ne.0)then
  40  12     x=-log(rangen())*iwkeu+mkeu
  41         if(rangen().lt.0.5) x=real(mkeu)-(x-real(mkeu))
  42         if( exp(-((x-mkeu)/iwkeu)**2) / exp(-abs(x-mkeu)/iwkeu)/2
  43      $       .lt. rangen() ) goto 12
  44         keu=nint(x)
  45       endif
  46       if(mked.ne.0.or.iwked.ne.0)then
  47  13     x=-log(rangen())*iwked+mked
  48         if(rangen().lt.0.5) x=real(mked)-(x-real(mked))
  49         if( exp(-((x-mked)/iwked)**2) / exp(-abs(x-mked)/iwked)/2
  50      $       .lt. rangen() ) goto 13
  51         ked=nint(x)
  52       endif
  53       if(mkes.ne.0.or.iwkes.ne.0)then
  54  15     x=-log(rangen())*iwkes+mkes
  55         if(rangen().lt.0.5) x=real(mkes)-(x-real(mkes))
  56         if( exp(-((x-mkes)/iwkes)**2) / exp(-abs(x-mkes)/iwkes)/2
  57      $       .lt. rangen() ) goto 15
  58         kes=nint(x)
  59       endif
  60       if(real((keu+ked+kes)/3).ne.real(keu+kes+ked)/3.) goto 10
  61       if(keu.ge.0)jc(1,1)=keu
  62       if(ked.ge.0)jc(2,1)=ked
  63       if(kes.ge.0)jc(3,1)=kes
  64       if(kec.ge.0)jc(4,1)=kec
  65       if(keb.ge.0)jc(5,1)=keb
  66       if(ket.ge.0)jc(6,1)=ket
  67       if(keu.lt.0)jc(1,2)=-keu
  68       if(ked.lt.0)jc(2,2)=-ked
  69       if(kes.lt.0)jc(3,2)=-kes
  70       if(kec.lt.0)jc(4,2)=-kec
  71       if(keb.lt.0)jc(5,2)=-keb
  72       if(ket.lt.0)jc(6,2)=-ket
  73       if(ish.ge.5)write(ifch,'(a/6i4/6i4)')' jc:',jc
  74       idr=0
  75       do  nf=1,nflav
  76         do  ij=1,2
  77           if(jc(nf,ij).ge.10)idr=7*10**8
  78         enddo
  79       enddo
  80       if(idr/10**8.ne.7)then
  81         call idenco(jc,ic,ireten)
  82 c       if(ireten.eq.1)call utstop('ametro: idenco ret code = 1&')
  83         if(ic(1).eq.0.and.ic(2).eq.0)then
  84           ic(1)=100000
  85           ic(2)=100000
  86         endif
  87
  88         idr=8*10**8+ic(1)*100+ic(2)/100
  89         if(ish.ge.5)write(ifch,'(a,i9)')' id:',idr
  90         dez=0.5e-4
  91       else
  92         idr=idr
  93      *       +mod(jc(1,1)+jc(2,1)+jc(3,1)+jc(4,1),10**4)*10**4
  94      *       +mod(jc(1,2)+jc(2,2)+jc(3,2)+jc(4,2),10**4)
  95         call idtrbi(jc,ibptl(1,1),ibptl(2,1),ibptl(3,1),ibptl(4,1))
  96         dez=0.5e-4
  97       endif
  98
  99       pptl(1,1)=0
 100       pptl(2,1)=0
 101       pptl(3,1)=0
 102       pptl(4,1)=tecm
 103       pptl(5,1)=tecm
 104
 105       g=1
 106
 107       nptl=nptl+1
 108       idptl(nptl)=idr
 109       pptl(1,nptl)=0
 110       pptl(2,nptl)=0
 111       pptl(3,nptl)=0
 112       pptl(4,nptl)=tecm*g
 113       pptl(5,nptl)=tecm*g
 114       radptl(nptl)=(3*volu/pi/4.)**0.33333
 115       istptl(nptl)=10
 116       tivptl(2,1)=1.
 117
 118       nptlb=nptl
 119       call hnbaaa(nptl,iret)
 120       if(iret.eq.1)stop'STOP: sr amicro: hnbaaa return code = 1.   '
 121       istptl(nptl)=istptl(nptl)+1
 122       ifrptl(1,nptl)=nptlb+1
 123       ifrptl(2,nptl)=nptl
 124       x=xorptl(1,nptl)
 125       y=xorptl(2,nptl)
 126       z=xorptl(3,nptl)
 127       t=xorptl(4,nptl)
 128       do n=nptlb+1,nptl
 129         iorptl(n)=nptlb
 130         jorptl(n)=0
 131         istptl(n)=0
 132         ifrptl(1,n)=0
 133         ifrptl(2,n)=0
 134         xorptl(1,n)=x
 135         xorptl(2,n)=y
 136         xorptl(3,n)=z
 137         xorptl(4,n)=t
 138         tivptl(1,n)=t
 139         call idtau(idptl(n),pptl(4,n),pptl(5,n),taugm)
 140         r=rangen()
 141         tivptl(2,n)=t+taugm*(-alog(r))
 142         ityptl(n)=60
 143         radptl(n)=0.
 144         itsptl(n)=0
 145         rinptl(n)=-9999
 146       enddo
 147
 148       if(ioceau.eq.1)call xhnbte(0)
 149       if(iociau.eq.1)call xhnbti(0)
 150
 151       call utprix('amicro',ish,ishini,4)
 152       return
 153       end
 154
 155 c-----------------------------------------------------------------------
 156       subroutine hgcaaa
 157 c-----------------------------------------------------------------------
 158 c hadronic resonance gas in grand canonical treatment
 159 c returns T, chemical potentials and hadronic yield
 160 c (hadron chemical potentials as combinations of quark chemical potentials)
 161 c
 162 c input:
 163 c   iostat: 1: Boltzmann approximation, 0: quantum statistics  /metr3/
 164 c   tecm:                    droplet energy      /confg/
 165 c   volu:                    droplet volume      /confg/
 166 c   keu ked kes kec keb ket: net flavor number   /drop5/
 167 c
 168 c output:
 169 c   tem    : temperature [GeV]                            /cgchg/
 170 c   chem(1:nflav): quark chem. pot. [GeV]                 /cflav/
 171 c   chemgc(1:nspecs): hadron chem. pot. [GeV]             /cgchg/
 172 c   ptlngc(1:nspecs): hadron number                       /cgchg/
 173 c   rmsngc(1:nspecs): standard deviation of hadron number /cgchg/
 174 c
 175 c exact treatment (iostat=0):
 176 c for massive hadrons     : first in Boltzmann approximation with analytical
 177 c                           expressions for particle and energy densities,
 178 c                           then by using quantum statistics in integral form,
 179 c                           extracting mu and T using numerical integration
 180 c                           and an iterative procedure to solve for mu, T
 181 c for massless hadrons    : using analytic expressions for massles particles
 182 c                           and employing the  same algorithm as for massive
 183 c-----------------------------------------------------------------------
 184       include 'epos.inc'
 185       parameter (mspecs=56)
 186       common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
 187       common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
 188       common/cbol/rmsbol(mspecs),ptlbol(mspecs),chebol(mspecs),tembol
 189       common/cflavs/nflavs,kef(nflav),chem(nflav)
 190       common/ciakt/gen,iafs,ians,genm
 191       common/cnrit/nrit
 192       gen=10.0**(-epsgc)
 193       genm=gen/10.
 194
 195       isho=ish
 196       if(ishsub/100.eq.51)ish=mod(ishsub,100)
 197
 198       iug=(1+iospec)/2*2-1
 199
 200
 201 c     initialization
 202 c     --------------
 203       kef(1)=keu
 204       kef(2)=ked
 205       kef(3)=kes
 206       kef(4)=kec
 207       kef(5)=keb
 208       kef(6)=ket
 209
 210       if(iug.eq.1)nflavs=1
 211       if(iug.eq.3)nflavs=2
 212       if(iug.eq.5)nflavs=2
 213       if(iug.eq.7)nflavs=3
 214       if(iug.eq.9)nflavs=3
 215       if(iug.eq.11)nflavs=3
 216       tem=0.0
 217       do i=1,nflavs
 218       chem(i)=0.0
 219       enddo
 220       call hgchac(0)
 221       do i=1,nspecs
 222       ptlngc(i)=0.0
 223       rmsngc(i)=0.0
 224       enddo
 225       nrit=0
 226
 227       if(ish.ge.5)then
 228         write(ifch,*)('-',l=1,10)
 229      *,' entry sr hgcaaa ',('-',l=1,30)
 230         write(ifch,'(1x,a,2x,3i3)')
 231      *'>>> grand canonical hadron gas for droplet with u d s content:'
 232      *,keu,ked,kes
 233         write(ifch,'(1x,a,2x,f7.3,2x,a,2x,f7.3)')
 234      *'mass [GeV]:',tecm,'volume [fm^3]:',volu
 235       endif
 236
 237       if(iug.eq.1.and.keu.ne.0.and.ish.ge.5)then
 238       write(ifch,*)'inversion impossible !!!'
 239       write(ifch,*)'keu=0 required for this option'
 240       write(ifch,*)'T = mu(i) = 0 returned'
 241       if(ish.ge.5)write(ifch,*)('-',i=1,30)
 242      *,' exit sr hgcaaa ',('-',i=1,10)
 243       return
 244       endif
 245       if(iug.eq.3.and.(keu+ked).ne.0.and.ish.ge.5)then
 246       write(ifch,*)'inversion impossible !!!'
 247       write(ifch,*)'keu+ked=0 required for this option'
 248       write(ifch,*)'T = mu(i) = 0 returned'
 249       if(ish.ge.5)write(ifch,*)('-',i=1,30)
 250      *,' exit sr hgcaaa ',('-',i=1,10)
 251       return
 252       endif
 253       kf=keu+ked+kes+kec+keb+ket
 254       kf=abs(kf)
 255       if(kf.ne.0)then
 256       if(mod(kf,3).ne.0.and.ish.ge.5)then
 257       write(ifch,*)'inversion impossible !!!'
 258       write(ifch,*)'sum must be multiple of three'
 259       write(ifch,*)'T = mu(i) = 0 returned'
 260       if(ish.ge.5)write(ifch,*)('-',i=1,30)
 261      *,' exit sr hgcaaa ',('-',i=1,10)
 262       return
 263       endif
 264       endif
 265
 266
 267 c     initial T (m=0, baryon free)
 268 c     -------------------------------
 269       gfac=0.0
 270
 271        if(iostat.eq.0.and.iospec.eq.iug)then
 272       do i=1,nspecs
 273       igsp=int(gspecs(i))
 274       if(mod(igsp,2).eq.0)then
 275       gfac=gfac+7.*gspecs(i)/8.
 276       else
 277       gfac=gfac+gspecs(i)
 278       endif
 279       enddo
 280       if(iabs(ispecs(nspecs)).lt.10)gfac=gfac+16.
 281       tem=(tecm/volu*hquer**3*30./pi**2/gfac)**.25
 282        else
 283       do i=1,nspecs
 284       gfac=gfac+gspecs(i)
 285       enddo
 286       if(iabs(ispecs(nspecs)).lt.10)gfac=gfac+16.
 287       tem=(tecm/volu*hquer**3*pi**2/gfac/3.)**.25
 288       tem=2.*tem
 289        endif
 290
 291       if(ish.ge.5)write(ifch,1)'initial T :',tem
 292 1     format(1x,a,3x,f9.6)
 293
 294       if(ish.ge.5)write(ifch,*)'iospec: ',iospec
 295
 296        if(ish.ge.5.and.iospec.ne.iug)then
 297       write(ifch,*)'inversion in Boltzmann approx. :'
 298        elseif(ish.ge.5.and.iospec.eq.iug)then
 299       write(ifch,*)'inversion for massless hadrons :'
 300        endif
 301
 302        if(ish.ge.5)then
 303       if(nflavs.eq.1)write(ifch,'(3x,a,8x,a)')
 304      *'T:','chemu:'
 305       if(nflavs.eq.2)write(ifch,'(3x,a,8x,a,5x,a)')
 306      *'T:','chemu:','chemd:'
 307       if(nflavs.eq.3)write(ifch,'(3x,a,8x,a,5x,a,5x,a)')
 308      *'T:','chemu:','chemd:','chems:'
 309        endif
 310
 311       k=1
 312 10    continue
 313       if(ish.ge.9.and.mod(k,10).eq.0)
 314      *write(ifch,*)'hgc iteration:',k
 315       if(ish.ge.9)call hgccch(1)
 316
 317 c     search for temperature (chem=const)
 318 c     -----------------------------------
 319       idt=0
 320       temo=tem
 321
 322        if(iospec.eq.iug)then
 323
 324 c     massless particles
 325 c     ------------------
 326       if(iostat.eq.0)then
 327       if(ish.ge.9)
 328      *write(ifch,*)'iteration (massless):',k
 329       call hgctm0
 330       elseif(iostat.eq.1)then
 331       if(ish.ge.9)
 332      *write(ifch,*)'iteration (Boltzmann, massless):',k
 333       call hgctbo(ibna)
 334       if(ibna.eq.1)then
 335       tem=temo
 336       goto20
 337       endif
 338       endif
 339
 340        else
 341
 342 c     Boltzmann approxiamtion (massive particles)
 343 c     -------------------------------------------
 344       if(ish.ge.9)
 345      *write(ifch,*)'iteration (Boltzmann, massive):',k
 346       call hgctbo(ibna)
 347       if(ibna.eq.1)then
 348       tem=temo
 349       goto20
 350       endif
 351
 352        endif
 353
 354       if(tem.le.1.e-6.and.ish.ge.5)then
 355       write(ifch,*)'inversion imposssible'
 356       write(ifch,*)'T:',tem
 357       if(ioinco.ge.1)call hnbmin(keu,ked,kes,kec)
 358       if(ish.ge.5)write(ifch,*)('-',i=1,30)
 359      *,' exit sr hgcaaa ',('-',i=1,10)
 360       ish=isho
 361       return
 362       endif
 363
 364       dt=abs(temo-tem)
 365       if(dt.le.gen*temo.or.dt.le.genm)idt=1
 366
 367 c     search for chemical potentials (tem=const)
 368 c     ------------------------------------------
 369       idch=0
 370       ibna=0
 371
 372         do iafs=1,nflavs
 373       chemo=chem(iafs)
 374
 375        if(iospec.eq.iug)then
 376
 377 c     massless particles
 378 c     ------------------
 379       if(iostat.eq.0)then
 380       call hgccm0
 381       elseif(iostat.eq.1)then
 382       call hgccbo(ibna)
 383       endif
 384
 385        else
 386
 387 c     Boltzmann approxiamtion (massive particles)
 388 c     -------------------------------------------
 389       call hgccbo(ibna)
 390
 391        endif
 392
 393       dch=abs(chemo-chem(iafs))
 394       if(ish.ge.9)write(ifch,*)'dch:',dch
 395       if(dch.le.abs(gen*chemo).or.dch.le.genm)idch=idch+1
 396       if(ibna.eq.1)then
 397       chem(iafs)=chemo
 398       call hgchac(0)
 399       goto20
 400       endif
 401
 402         enddo
 403
 404
 405 c     new hadron chem. potentials
 406 c     ---------------------------
 407       call hgchac(0)
 408
 409
 410       if(ish.ge.5.and.nflavs.eq.1)
 411      *write(ifch,'(1x,f8.6,2x,f9.6)')
 412      *tem,chem(1)
 413       if(ish.ge.5.and.nflavs.eq.2)
 414      *write(ifch,'(1x,f8.6,2x,f9.6,2x,f9.6)')
 415      *tem,chem(1),chem(2)
 416       if(ish.ge.5.and.nflavs.eq.3)
 417      *write(ifch,'(1x,f8.6,2x,f9.6,2x,f9.6,2x,f9.6)')
 418      *tem,chem(1),chem(2),chem(3)
 419       if(idch.eq.nflavs.and.idt.eq.1)goto20
 420
 421
 422       k=k+1
 423
 424        if(k.gt.300)then
 425        if(ish.ge.5)
 426      *write(ifch,*)'failure in approximate solution'
 427       goto20
 428        endif
 429
 430       goto10
 431
 432 20    continue
 433       if(ish.ge.9)call hgccch(0)
 434       if(ish.ge.5)write(ifch,'(1x,a,1x,f9.6)')'  T  :',tem
 435       do i=1,nflavs
 436       if(i.eq.1.and.ish.ge.5)
 437      *write(ifch,'(1x,a,1x,f9.6)')'chemu:',chem(1)
 438       if(i.eq.2.and.ish.ge.5)
 439      *write(ifch,'(1x,a,1x,f9.6)')'chemd:',chem(2)
 440       if(i.eq.3.and.ish.ge.5)
 441      *write(ifch,'(1x,a,1x,f9.6)')'chems:',chem(3)
 442       enddo
 443
 444
 445 c     checking results
 446 c     ----------------
 447       if(ish.ge.5)call hgcchb
 448
 449 c     particle yield
 450 c     --------------
 451       call hgcpyi(1)
 452
 453 c     checking flavor conservation
 454 c     ----------------------------
 455       if(ish.ge.5)call hgccfc
 456
 457       if(iug.eq.iospec.and.iostat.eq.0)then
 458       if(ish.ge.5)write(ifch,*)
 459      *'approximation and exact treatment equal'
 460       if(ish.ge.5)write(ifch,*)('-',i=1,30)
 461      *,' exit sr hgcaaa ',('-',i=1,10)
 462       ish=isho
 463       return
 464       endif
 465
 466 c     continue or return approximate values
 467 c     -------------------------------------
 468       do i=1,nspecs
 469       rmsbol(i)=rmsngc(i)
 470       ptlbol(i)=ptlngc(i)
 471       chebol(i)=chemgc(i)
 472       enddo
 473       tembol=tem
 474       if(iostat.eq.1)then
 475       if(ish.ge.5)write(ifch,*)('-',i=1,30)
 476      *,' exit sr hgcaaa ',('-',i=1,10)
 477       ish=isho
 478       return
 479       endif
 480
 481
 482 c     quantum statistics
 483 c     ------------------
 484       if(ish.ge.5)write(ifch,*)'quantum statistics:'
 485       if(ish.ge.5.and.nflavs.eq.1)write(ifch,'(3x,a,8x,a)')
 486      *'T:','chemu:'
 487       if(ish.ge.5.and.nflavs.eq.2)write(ifch,'(3x,a,8x,a,6x,a)')
 488      *'T:','chemu:','chemd:'
 489       if(ish.ge.5.and.nflavs.eq.3)write(ifch,'(3x,a,8x,a,6x,a,6x,a)')
 490      *'T:','chemu:','chemd:','chems:'
 491       k=1
 492
 493 30    continue
 494       if(ish.ge.9.and.mod(k,10).eq.0)
 495      *write(ifch,*)'hgc iteration:',k
 496
 497 c     new temperature
 498 c     ---------------
 499       idt=0
 500       temo=tem
 501       call hgctex
 502       if(ish.ge.5.and.nflavs.eq.1)
 503      *write(ifch,'(1x,f10.8,2x,f10.7)')
 504      *tem,chem(1)
 505       if(ish.ge.5.and.nflavs.eq.2)
 506      *write(ifch,'(1x,f10.8,2x,f10.7,2x,f10.7)')
 507      *tem,chem(1),chem(2)
 508       if(ish.ge.5.and.nflavs.eq.3)
 509      *write(ifch,'(1x,f10.8,2x,f10.7,2x,f10.7,2x,f10.7)')
 510      *tem,chem(1),chem(2),chem(3)
 511
 512       if(tem.le.1.e-6.and.ish.ge.5)then
 513       write(ifch,*)'inversion imposssible'
 514       write(ifch,*)'T:',tem
 515       call hnbmin(keu,ked,kes,kec)
 516       if(ish.ge.5)write(ifch,*)('-',i=1,30)
 517      *,' exit sr hgcaaa ',('-',i=1,10)
 518       ish=isho
 519       return
 520       endif
 521
 522       dt=abs(temo-tem)
 523       if(dt.le.gen*temo.or.dt.le.genm)idt=1
 524       if(ish.ge.9)write(ifch,*)'dtem:',dt
 525
 526 c     new quark chem. potentials
 527 c     --------------------------
 528       idch=0
 529       do iafs=1,nflavs
 530       chemo=chem(iafs)
 531       call hgccex
 532       dch=abs(chemo-chem(iafs))
 533       if(ish.ge.9)write(ifch,*)'dche:',dch
 534       if(dch.le.abs(gen*chemo).or.dch.le.genm)idch=idch+1
 535       enddo
 536
 537 c     new hadron chem. potentials
 538 c     ---------------------------
 539       call hgchac(0)
 540
 541        if(idch.eq.nflavs.and.idt.eq.1)then
 542 50    continue
 543       if(ish.ge.5)write(ifch,*)'results:'
 544       if(ish.ge.5)write(ifch,51)'  T  :',tem
 545       if(nflavs.ge.1.and.ish.ge.5)write(ifch,51)'chemu:',chem(1)
 546       if(nflavs.ge.2.and.ish.ge.5)write(ifch,51)'chemd:',chem(2)
 547       if(nflavs.ge.3.and.ish.ge.5)write(ifch,51)'chems:',chem(3)
 548 51    format(1x,a,3x,f9.6)
 549
 550 c     checking results
 551 c     ----------------
 552       if(ish.ge.5)call hgcchh(i)
 553
 554 c     particle yield
 555 c     --------------
 556       call hgcpyi(0)
 557
 558 c     checking flavor conservation
 559 c     ----------------------------
 560       call hgccfc
 561
 562       if(ish.ge.5)write(ifch,*)('-',i=1,30)
 563      *,' exit sr hgcaaa ',('-',i=1,10)
 564       ish=isho
 565       return
 566        endif
 567
 568        if(k.gt.300)then
 569        if(ish.ge.5)
 570      *write(ifch,*)'failure in exact solution'
 571       if(ish.ge.5)write(ifch,*)'results:'
 572       if(ish.ge.5)write(ifch,51)'  T  :',tem
 573       if(nflavs.ge.1.and.ish.ge.5)write(ifch,51)'chemu:',chem(1)
 574       if(nflavs.ge.2.and.ish.ge.5)write(ifch,51)'chemd:',chem(2)
 575       if(nflavs.ge.3.and.ish.ge.5)write(ifch,51)'chems:',chem(3)
 576
 577 c     particle yield
 578 c     --------------
 579       call hgcpyi(0)
 580
 581       if(ish.ge.5)write(ifch,*)('-',i=1,30)
 582      *,' exit sr hgcaaa ',('-',i=1,10)
 583       ish=isho
 584       return
 585
 586        endif
 587
 588       k=k+1
 589       goto30
 590
 591       end
 592
 593
 594 c---------------------------------------------------------------------
 595       function hgcbi0(x)
 596 c---------------------------------------------------------------------
 597       DOUBLE PRECISION p1,p2,p3,p4,p5,p6,p7,q1,q2,q3,q4,q5,q6,q7,q8,q9,y
 598       SAVE p1,p2,p3,p4,p5,p6,p7,q1,q2,q3,q4,q5,q6,q7,q8,q9
 599       DATA p1,p2,p3,p4,p5,p6,p7/1.0d0,3.5156229d0,3.0899424d0,
 600      *1.2067492d0,0.2659732d0,0.360768d-1,0.45813d-2/
 601       DATA q1,q2,q3,q4,q5,q6,q7,q8,q9/0.39894228d0,0.1328592d-1,
 602      *0.225319d-2,-0.157565d-2,0.916281d-2,-0.2057706d-1,0.2635537d-1,
 603      *-0.1647633d-1,0.392377d-2/
 604       if (abs(x).lt.3.75) then
 605         y=dble((x/3.75)**2)
 606         hgcbi0=sngl(p1+y*(p2+y*(p3+y*(p4+y*(p5+y*(p6+y*p7))))))
 607       else
 608         ax=abs(x)
 609         y=dble(3.75/ax)
 610         hgcbi0=(exp(ax)/sqrt(ax))*(q1+y*(q2+y*(q3+y*(q4+y*(q5+y*(q6+y*
 611      *(q7+y*(q8+y*q9))))))))
 612       endif
 613       return
 614       end
 615
 616
 617 c------------------------------------------------------------------------
 618       function hgcbi1(x)
 619 c------------------------------------------------------------------------
 620       DOUBLE PRECISION p1,p2,p3,p4,p5,p6,p7,q1,q2,q3,q4,q5,q6,q7,q8,q9,y
 621       SAVE p1,p2,p3,p4,p5,p6,p7,q1,q2,q3,q4,q5,q6,q7,q8,q9
 622       DATA p1,p2,p3,p4,p5,p6,p7/0.5d0,0.87890594d0,0.51498869d0,
 623      *0.15084934d0,0.2658733d-1,0.301532d-2,0.32411d-3/
 624       DATA q1,q2,q3,q4,q5,q6,q7,q8,q9/0.39894228d0,-0.3988024d-1,
 625      *-0.362018d-2,0.163801d-2,-0.1031555d-1,0.2282967d-1,-0.2895312d-1,
 626      *0.1787654d-1,-0.420059d-2/
 627       if (abs(x).lt.3.75) then
 628         y=dble((x/3.75)**2)
 629         hgcbi1=x*(p1+y*(p2+y*(p3+y*(p4+y*(p5+y*(p6+y*p7))))))
 630       else
 631         ax=abs(x)
 632         y=dble(3.75/ax)
 633         hgcbi1=(exp(ax)/sqrt(ax))*(q1+y*(q2+y*(q3+y*(q4+y*(q5+y*(q6+y*
 634      *(q7+y*(q8+y*q9))))))))
 635         if(x.lt.0.)hgcbi1=-hgcbi1
 636       endif
 637       return
 638       END
 639
 640
 641 c---------------------------------------------------------------------
 642       function hgcbk0(x)
 643 c------------------------------------------------------------------------
 644       DOUBLE PRECISION p1,p2,p3,p4,p5,p6,p7,q1,q2,q3,q4,q5,q6,q7,y
 645       SAVE p1,p2,p3,p4,p5,p6,p7,q1,q2,q3,q4,q5,q6,q7
 646       DATA p1,p2,p3,p4,p5,p6,p7/-0.57721566d0,0.42278420d0,0.23069756d0,
 647      *0.3488590d-1,0.262698d-2,0.10750d-3,0.74d-5/
 648       DATA q1,q2,q3,q4,q5,q6,q7/1.25331414d0,-0.7832358d-1,0.2189568d-1,
 649      *-0.1062446d-1,0.587872d-2,-0.251540d-2,0.53208d-3/
 650       if (x.le.2.0) then
 651         y=dble(x*x/4.0)
 652         hgcbk0=(-log(x/2.0)*hgcbi0(x))+(p1+y*(p2+y*(p3+y*(p4+y*(p5+y*
 653      *(p6+y*p7))))))
 654       else
 655         y=dble(2.0/x)
 656         hgcbk0=(exp(-x)/sqrt(x))*(q1+y*(q2+y*(q3+y*(q4+y*(q5+y*(q6+y*
 657      *q7))))))
 658       endif
 659       return
 660       END
 661
 662
 663 c---------------------------------------------------------------
 664       function hgcbk1(x)
 665 c--------------------------------------------------------------------
 666       DOUBLE PRECISION p1,p2,p3,p4,p5,p6,p7,q1,q2,q3,q4,q5,q6,q7,y
 667       SAVE p1,p2,p3,p4,p5,p6,p7,q1,q2,q3,q4,q5,q6,q7
 668       DATA p1,p2,p3,p4,p5,p6,p7/1.0d0,0.15443144d0,-0.67278579d0,
 669      *-0.18156897d0,-0.1919402d-1,-0.110404d-2,-0.4686d-4/
 670       DATA q1,q2,q3,q4,q5,q6,q7/1.25331414d0,0.23498619d0,-0.3655620d-1,
 671      *0.1504268d-1,-0.780353d-2,0.325614d-2,-0.68245d-3/
 672       if (x.le.2.0) then
 673         y=dble(x*x/4.0)
 674         hgcbk1=(log(x/2.0)*hgcbi1(x))+(1.0/x)*(p1+y*(p2+y*(p3+y*(p4+y*
 675      *(p5+y*(p6+y*p7))))))
 676       else
 677         y=dble(2.0/x)
 678         hgcbk1=(exp(-x)/sqrt(x))*(q1+y*(q2+y*(q3+y*(q4+y*(q5+y*(q6+y*
 679      *q7))))))
 680       endif
 681       return
 682       END
 683
 684
 685 c-------------------------------------------------------------------
 686       function hgcbk(n,x)
 687 c------------------------------------------------------------------
 688       tox=2.0/x
 689       bkm=hgcbk0(x)
 690       bk=hgcbk1(x)
 691       do 11 j=1,n-1
 692         bkp=bkm+j*tox*bk
 693         bkm=bk
 694         bk=bkp
 695 11    continue
 696       hgcbk=bk
 697       return
 698       END
 699
 700
 701 c----------------------------------------------------------------
 702       subroutine hgccbo(iba)
 703 c----------------------------------------------------------------
 704 c returns new chem(iafs) for boltzmann statistics
 705 c  input:
 706 c    tem
 707 c    kef/volu
 708 c  output:
 709 c    chem(iafs)
 710 c-----------------------------------------------------------------------
 711       common/cnsta/pi,pii,hquer,prom,piom,ainfin
 712       common/drop6/tecm,volu
 713       parameter (mspecs=56)
 714       common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
 715       common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
 716       parameter(nflav=6)
 717       common/cflavs/nflavs,kef(nflav),chem(nflav)
 718       common/cflac/ifok(nflav,mspecs),ifoa(nflav)
 719       common/ciakt/gen,iafs,ians,genm
 720       external hgcbk
 721       k=1
 722       iba=0
 723       c1=-0.5
 724       c2=0.5
 725       goto11
 726
 727 c     new chemical potential
 728 c     ----------------------
 729 10    chem(iafs)=c1+0.5*(c2-c1)
 730 11    continue
 731       fd=0.0
 732       call hgchac(0)
 733
 734         do i=1,nspecs
 735
 736         if(ifok(iafs,i).ne.0)then
 737        if((chemgc(i)/tem).gt.70.)then
 738       hpd=1.e30
 739        else
 740       hpd=exp(chemgc(i)/tem)
 741        endif
 742        if(aspecs(i).ne.0.)then
 743       fk2=hgcbk(2,aspecs(i)/tem)
 744       hpd=hpd*gspecs(i)*aspecs(i)**2*tem*fk2
 745      */2./pi**2/hquer**3
 746        else
 747       hpd=hpd*gspecs(i)*tem**3/pi**2/hquer**3
 748        endif
 749       hfd=ifok(iafs,i)*hpd
 750       fd=fd+hfd
 751         endif
 752
 753         enddo
 754
 755       dfd=abs(fd-(kef(iafs)/volu))
 756       if(dfd.le.abs(gen*(kef(iafs)/volu)).or.dfd.le.genm)return
 757 c     if(abs(fd).ge.100.)then
 758 c     iba=1
 759 c     return
 760 c     endif
 761
 762
 763        if(fd.gt.(kef(iafs)/volu))then
 764       c2=chem(iafs)
 765       else
 766       c1=chem(iafs)
 767        endif
 768
 769       k=k+1
 770       if(k.gt.300)return
 771
 772       goto10
 773
 774       end
 775
 776
 777 c----------------------------------------------------------------------
 778       subroutine hgccch(iii)
 779 c----------------------------------------------------------------------
 780 c checks convergence of iterative algorithm
 781 c plots iteration values for T and mu_i
 782 c----------------------------------------------------------------------
 783       include 'epos.inc'
 784       parameter (mspecs=56)
 785       common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
 786       common/cflavs/nflavs,kef(nflav),chem(nflav)
 787       parameter (nbin=500)
 788       common/cdatc/data(nbin),datb(nbin),datc(nbin),datd(nbin)
 789      *,date(nbin),datf(nbin),datg(nbin),dath(nbin),dati(nbin)
 790       common/cnrit/nrit
 791       character cen*4,cvol*4,cu*3,cd*3,cs*3
 792
 793            if(iii.gt.0)then
 794
 795       nrit=nrit+1
 796       data(nrit)=nrit
 797       datb(nrit)=tem
 798       datc(nrit)=chem(1)
 799       datd(nrit)=chem(2)
 800       date(nrit)=chem(3)
 801
 802            elseif(iii.eq.0)then
 803
 804       nrit=nrit+1
 805       data(nrit)=nrit
 806       datb(nrit)=tem
 807       datc(nrit)=chem(1)
 808       datd(nrit)=chem(2)
 809       date(nrit)=chem(3)
 810       do i=1,nrit
 811       datf(i)=datb(nrit)
 812       datg(i)=datc(nrit)
 813       dath(i)=datd(nrit)
 814       dati(i)=date(nrit)
 815       enddo
 816
 817       x1=data(1)
 818       x2=data(nrit)
 819       write(cen,'(f4.1)')tecm
 820       write(cvol,'(f4.1)')volu
 821       write(cu,'(i3)')keu
 822       write(cd,'(i3)')ked
 823       write(cs,'(i3)')kes
 824
 825
 826       write(ifhi,'(a)')       'newpage zone 1 4 1 openhisto'
 827       write(ifhi,'(a)')       'htyp lin xmod lin ymod lin'
 828       write(ifhi,'(a)')       'text 0 0 "xaxis Iteration"'
 829       write(ifhi,'(a)')       'text 0 0 "yaxis T (GeV)"'
 830       write(ifhi,'(a)')       'text 0.15 0.9 "E= '//cen//'"'
 831       write(ifhi,'(a)')       'text 0.4 0.9 "V= '//cvol//'"'
 832       write(ifhi,'(a,2e11.3)')'xrange',x1,x2
 833       write(ifhi,'(3a)')'yrange',' auto',' auto'
 834       write(ifhi,'(a)')       'array 2'
 835       do j=1,nrit
 836       write(ifhi,'(2e12.4)')data(j),datb(j)
 837       enddo
 838       write(ifhi,'(a)')       '  endarray'
 839       write(ifhi,'(a)')       'closehisto plot 0-'
 840
 841       write(ifhi,'(a)')       'openhisto'
 842       write(ifhi,'(a)')       'htyp lin xmod lin ymod lin'
 843       write(ifhi,'(a,2e11.3)')'xrange',x1,x2
 844       write(ifhi,'(3a)')'yrange',' auto',' auto'
 845       write(ifhi,'(a)')       'array 2'
 846       do j=1,nrit
 847       write(ifhi,'(2e12.4)')data(j),datf(j)
 848       enddo
 849       write(ifhi,'(a)')       '  endarray'
 850       write(ifhi,'(a)')       'closehisto plot 0'
 851
 852       write(ifhi,'(a)')       'openhisto'
 853       write(ifhi,'(a)')       'htyp lin xmod lin ymod lin'
 854       write(ifhi,'(a)')       'text 0 0 "xaxis Iteration"'
 855       write(ifhi,'(a)')       'text 0 0 "yaxis [m]^1! (GeV)"'
 856       write(ifhi,'(a)')       'text 0.15 0.9 "Q^1!= '//cu//'"'
 857       write(ifhi,'(a,2e11.3)')'xrange',x1,x2
 858       write(ifhi,'(3a)')'yrange',' auto',' auto'
 859       write(ifhi,'(a)')       'array 2'
 860       do j=1,nrit
 861       write(ifhi,'(2e12.4)')data(j),datc(j)
 862       enddo
 863       write(ifhi,'(a)')       '  endarray'
 864       write(ifhi,'(a)')       'closehisto plot 0-'
 865
 866       write(ifhi,'(a)')       'openhisto'
 867       write(ifhi,'(a)')       'htyp lin xmod lin ymod lin'
 868       write(ifhi,'(a,2e11.3)')'xrange',x1,x2
 869       write(ifhi,'(3a)')'yrange',' auto',' auto'
 870       write(ifhi,'(a)')       'array 2'
 871       do j=1,nrit
 872       write(ifhi,'(2e12.4)')data(j),datg(j)
 873       enddo
 874       write(ifhi,'(a)')       '  endarray'
 875       write(ifhi,'(a)')       'closehisto plot 0'
 876
 877       write(ifhi,'(a)')       'openhisto'
 878       write(ifhi,'(a)')       'htyp lin xmod lin ymod lin'
 879       write(ifhi,'(a)')       'text 0 0 "xaxis Iteration"'
 880       write(ifhi,'(a)')       'text 0 0 "yaxis [m]^2! (GeV)"'
 881       write(ifhi,'(a)')       'text 0.15 0.9 "Q^2!= '//cd//'"'
 882       write(ifhi,'(a,2e11.3)')'xrange',x1,x2
 883       write(ifhi,'(3a)')'yrange',' auto',' auto'
 884       write(ifhi,'(a)')       'array 2'
 885       do j=1,nrit
 886       write(ifhi,'(2e12.4)')data(j),datd(j)
 887       enddo
 888       write(ifhi,'(a)')       '  endarray'
 889       write(ifhi,'(a)')       'closehisto plot 0-'
 890
 891       write(ifhi,'(a)')       'openhisto'
 892       write(ifhi,'(a)')       'htyp lin xmod lin ymod lin'
 893       write(ifhi,'(a,2e11.3)')'xrange',x1,x2
 894       write(ifhi,'(3a)')'yrange',' auto',' auto'
 895       write(ifhi,'(a)')       'array 2'
 896       do j=1,nrit
 897       write(ifhi,'(2e12.4)')data(j),dath(j)
 898       enddo
 899       write(ifhi,'(a)')       '  endarray'
 900       write(ifhi,'(a)')       'closehisto plot 0'
 901
 902       write(ifhi,'(a)')       'openhisto'
 903       write(ifhi,'(a)')       'htyp lin xmod lin ymod lin'
 904       write(ifhi,'(a)')       'text 0 0 "xaxis Iteration"'
 905       write(ifhi,'(a)')       'text 0 0 "yaxis [m]^3! (GeV)"'
 906       write(ifhi,'(a)')       'text 0.15 0.9 "Q^3!= '//cs//'"'
 907       write(ifhi,'(a,2e11.3)')'xrange',x1,x2
 908       write(ifhi,'(3a)')'yrange',' auto',' auto'
 909       write(ifhi,'(a)')       'array 2'
 910       do j=1,nrit
 911       write(ifhi,'(2e12.4)')data(j),date(j)
 912       enddo
 913       write(ifhi,'(a)')       '  endarray'
 914       write(ifhi,'(a)')       'closehisto plot 0-'
 915
 916       write(ifhi,'(a)')       'openhisto'
 917       write(ifhi,'(a)')       'htyp lin xmod lin ymod lin'
 918       write(ifhi,'(a,2e11.3)')'xrange',x1,x2
 919       write(ifhi,'(3a)')'yrange',' auto',' auto'
 920       write(ifhi,'(a)')       'array 2'
 921       do j=1,nrit
 922       write(ifhi,'(2e12.4)')data(j),dati(j)
 923       enddo
 924       write(ifhi,'(a)')       '  endarray'
 925       write(ifhi,'(a)')       'closehisto plot 0'
 926
 927            endif
 928
 929        return
 930
 931        end
 932
 933 c-----------------------------------------------------------------------
 934       subroutine hgccex
 935 c-----------------------------------------------------------------------
 936 c returns new chem(iafs) for massive quantum statistics
 937 c  input:
 938 c    tem
 939 c    kef/volu
 940 c  output:
 941 c    chem(iafs)
 942 c-----------------------------------------------------------------------
 943       include 'epos.inc'
 944       parameter (mspecs=56)
 945       common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
 946       common/cflavs/nflavs,kef(nflav),chem(nflav)
 947       common/cflac/ifok(nflav,mspecs),ifoa(nflav)
 948       common/ciakt/gen,iafs,ians,genm
 949       external hgcfhn
 950
 951       k=1
 952
 953       c1=-0.5
 954       c2=0.5
 955       goto11
 956
 957 c     new chemical potential
 958 c     ----------------------
 959 10    chem(iafs)=c1+0.5*(c2-c1)
 960 11    continue
 961
 962       fd=0.0
 963         do ians=1,nspecs
 964        if(ifok(iafs,ians).ne.0)then
 965
 966       call hgchac(0)
 967       call hgclim(a,b)
 968       if(b.eq.0.0)then
 969       hpd=0.0
 970       else
 971       call uttraq(hgcfhn,a,b,hpd)
 972       endif
 973       hpd=hpd*gspecs(ians)/2./pi**2/hquer**3
 974       fd=fd+hpd*ifok(iafs,ians)
 975
 976        endif
 977         enddo
 978
 979       dfd=abs(fd-(kef(iafs)/volu))
 980       if(dfd.le.abs(gen*(kef(iafs)/volu)).or.dfd.le.genm)return
 981
 982        if(fd.gt.(kef(iafs)/volu))then
 983       c2=chem(iafs)
 984       else
 985       c1=chem(iafs)
 986        endif
 987
 988       k=k+1
 989       if(k.gt.300)then
 990       if(ish.ge.5)
 991      *write(ifch,*)'failure at cex at iafs:',iafs
 992       return
 993       endif
 994
 995       goto10
 996
 997       end
 998
 999
1000 c------------------------------------------------------------------
1001       subroutine hgccfc
1002 c------------------------------------------------------------------
1003 c checks flavor conservation in particle yield
1004 c------------------------------------------------------------------
1005       include 'epos.inc'
1006       parameter (mspecs=56)
1007       common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
1008       common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
1009       common/cflavs/nflavs,kef(nflav),chem(nflav)
1010       common/cflac/ifok(nflav,mspecs),ifoa(nflav)
1011
1012       if(ish.ge.5)write(ifch,*)'checking flavor conservation'
1013       do i=1,nflavs
1014       ckef=0.0
1015       do ii=1,nspecs
1016       ckef=ckef+ifok(i,ii)*ptlngc(ii)
1017       enddo
1018       dkef=abs(ckef-kef(i))
1019       if(dkef.le.1.e-2)then
1020       if(i.eq.1.and.ish.ge.5)write(ifch,*)'u conserved'
1021       if(i.eq.2.and.ish.ge.5)write(ifch,*)'d conserved'
1022       if(i.eq.3.and.ish.ge.5)write(ifch,*)'s conserved'
1023       else
1024       if(i.eq.1.and.ish.ge.5)write(ifch,*)'u not conserved'
1025       if(i.eq.2.and.ish.ge.5)write(ifch,*)'d not conserved'
1026       if(i.eq.3.and.ish.ge.5)write(ifch,*)'s not conserved'
1027       if(ish.ge.5)write(ifch,*)'df:',dkef
1028       endif
1029       enddo
1030
1031       return
1032       end
1033
1034 c----------------------------------------------------------------
1035       subroutine hgcchb
1036 c----------------------------------------------------------------
1037 c checks results by numerical integration
1038 c----------------------------------------------------------------
1039       include 'epos.inc'
1040       parameter (mspecs=56)
1041       common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
1042       common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
1043       common/cflavs/nflavs,kef(nflav),chem(nflav)
1044       common/cflac/ifok(nflav,mspecs),ifoa(nflav)
1045       common/ciakt/gen,iafs,ians,genm
1046       external hgcfbe
1047       external hgcfbn
1048       if(ish.ge.5)write(ifch,*)
1049      *'check by numer. calc. of expect. values:'
1050       iced=0
1051       ceden=0.0
1052        do ians=1,nspecs
1053       call hgclim(a,b)
1054       if(b.eq.0.0)then
1055       cedh=0.0
1056       else
1057       call uttraq(hgcfbe,a,b,cedh)
1058       endif
1059       if(ish.ge.9)write(ifch,*)'cedh:',cedh
1060       ced=cedh*gspecs(ians)/2./pi**2/hquer**3
1061       ceden=ceden+ced
1062        enddo
1063
1064       if(iabs(ispecs(nspecs)).lt.10)
1065      *ceden=ceden+(8.*pi**2*tem**4/15.+bag4rt**4)/hquer**3
1066
1067       if(ish.ge.5)write(ifch,*)'energy density   :',ceden
1068       ded=abs((tecm/volu)-ceden)
1069       if((tecm/volu)*gen.ge.ded.or.ded.le.gen)iced=1
1070       icfd=0
1071
1072        do i=1,nflavs
1073       cfd=0.0
1074       do ians=1,nspecs
1075       call hgclim(a,b)
1076       if(b.eq.0.0)then
1077       hpd=0.0
1078       else
1079       call uttraq(hgcfbn,a,b,hpd)
1080       endif
1081       hfd=ifok(i,ians)*hpd*gspecs(ians)/2./pi**2/hquer**3
1082       if(ish.ge.9)write(ifch,*)'hfd:',hfd
1083       cfd=cfd+hfd
1084       enddo
1085       if(i.eq.1.and.ish.ge.5)write(ifch,5)'flavor density u :',cfd
1086       if(i.eq.2.and.ish.ge.5)write(ifch,5)'flavor density d :',cfd
1087       if(i.eq.3.and.ish.ge.5)write(ifch,5)'flavor density s :',cfd
1088 5     format(1x,a,1x,f12.6)
1089       dfd=abs(cfd-(kef(i)/volu))
1090       if(abs(gen*(kef(i)/volu)).ge.dfd.or.dfd.le.gen)
1091      *icfd=icfd+1
1092        enddo
1093
1094        if(iced.eq.1.and.icfd.eq.nflavs)then
1095       if(ish.ge.5)write(ifch,*)'results agree'
1096       else
1097       if(ish.ge.5)write(ifch,*)'results disagree'
1098        endif
1099
1100       return
1101       end
1102
1103 c----------------------------------------------------------------
1104       subroutine hgcchh(icorr)
1105 c----------------------------------------------------------------
1106 c checks results by numerical integration
1107 c----------------------------------------------------------------
1108       include 'epos.inc'
1109       parameter (mspecs=56)
1110       common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
1111       common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
1112       common/cflavs/nflavs,kef(nflav),chem(nflav)
1113       common/cflac/ifok(nflav,mspecs),ifoa(nflav)
1114       common/ciakt/gen,iafs,ians,genm
1115       external hgcfhe
1116       external hgcfhn
1117       icorr=0
1118       if(ish.ge.5)write(ifch,*)
1119      *'check by numer. calc. of expect. values:'
1120
1121       iced=0
1122       ceden=0.0
1123        do ians=1,nspecs
1124       call hgclim(a,b)
1125       if(b.eq.0.0)then
1126       cedh=0.0
1127       else
1128       call uttraq(hgcfhe,a,b,cedh)
1129       endif
1130       if(ish.ge.9)write(ifch,*)'cedh:',cedh
1131       ced=cedh*gspecs(ians)/2./pi**2/hquer**3
1132       ceden=ceden+ced
1133        enddo
1134
1135       if(iabs(ispecs(nspecs)).lt.10)
1136      *ceden=ceden+(8.*pi**2*tem**4/15.+bag4rt**4)/hquer**3
1137
1138       if(ish.ge.5)write(ifch,*)'energy density   :',ceden
1139       ded=abs((tecm/volu)-ceden)
1140       if((tecm/volu)*gen.ge.ded.or.ded.le.gen)iced=1
1141
1142       icfd=0
1143
1144        do i=1,nflavs
1145       cfd=0.0
1146       do ians=1,nspecs
1147       call hgclim(a,b)
1148       if(b.eq.0.0)then
1149       hpd=0.0
1150       else
1151       call uttraq(hgcfhn,a,b,hpd)
1152       endif
1153       hfd=ifok(i,ians)*hpd*gspecs(ians)/2./pi**2/hquer**3
1154       if(ish.ge.9)write(ifch,*)'hfd:',hfd
1155       cfd=cfd+hfd
1156       enddo
1157       if(i.eq.1.and.ish.ge.5)write(ifch,5)'flavor density u :',cfd
1158       if(i.eq.2.and.ish.ge.5)write(ifch,5)'flavor density d :',cfd
1159       if(i.eq.3.and.ish.ge.5)write(ifch,5)'flavor density s :',cfd
1160 5     format(1x,a,1x,f9.6)
1161       dfd=abs(cfd-(kef(i)/volu))
1162       if(abs(gen*(kef(i)/volu)).ge.dfd.or.dfd.le.gen)
1163      *icfd=icfd+1
1164        enddo
1165
1166        if(iced.eq.1.and.icfd.eq.nflavs)then
1167       if(ish.ge.5)write(ifch,*)'results agree'
1168       icorr=1
1169       else
1170       if(ish.ge.5)write(ifch,*)'results disagree'
1171        endif
1172
1173       return
1174       end
1175
1176
1177 c--------------------------------------------------------------------
1178       subroutine hgccm0
1179 c--------------------------------------------------------------------
1180 c returns new quark chemical potentials for massless quantum statistics
1181 c input:
1182 c  tem
1183 c  kef/volu
1184 c output:
1185 c  chem
1186 c---------------------------------------------------------------------
1187       include 'epos.inc'
1188       parameter (mspecs=56)
1189       common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
1190       common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
1191       common/cflavs/nflavs,kef(nflav),chem(nflav)
1192       common/cflac/ifok(nflav,mspecs),ifoa(nflav)
1193       common/ciakt/gen,iafs,ians,genm
1194       external hgcfhn
1195       k=1
1196       z3=1.2020569
1197
1198       c1=-0.5
1199       c2=0.5
1200       goto11
1201
1202 c     new chemical potential
1203 c     ----------------------
1204 10    chem(iafs)=c1+0.5*(c2-c1)
1205 11    continue
1206
1207       fd=0.0
1208       call hgchac(0)
1209
1210                do i=1,nspecs
1211               if(ifok(iafs,i).ne.0)then
1212
1213            igsp=int(gspecs(i))
1214           if(mod(igsp,2).eq.0)then
1215
1216        if(ispecs(i).gt.0)then
1217       hpd=gspecs(i)*(chemgc(i)*tem**2+chemgc(i)**3/pi**2)/6./hquer**3
1218        else
1219       hpd=0.0
1220        endif
1221
1222 c            else
1223 c      if(ispecs(i).gt.0)then
1224 c     hpd=gspecs(i)*(chemgc(i)*tem**2/3.-chemgc(i)**3/pi**2/6.)/hquer**3
1225 c      else
1226 c     hpd=0.0
1227 c      endif
1228 c        endif
1229
1230 c     n=1
1231 c0    xx=n*abs(chemgc(i))/tem
1232 c     if(xx.le.60.)then
1233 c     hpd=hpd+(-1.)**(n+1)/n**3/exp(xx)
1234 c     n=n+1
1235 c     goto20
1236 c     endif
1237 c     hpd=hpd*gspecs(i)*tem**3/pi**2/hquer**3
1238 c     if(chemgc(i).eq.abs(chemgc(i)))then
1239 c     hpd=gspecs(i)*(chemgc(i)*tem**2+chemgc(i)**3/pi**2)/6./hquer**3
1240 c    *-hpd
1241 c     endif
1242
1243 c      else
1244 c     hpd=3.*gspecs(i)*tem**3*z3/4./pi**2/hquer**3
1245 c      endif
1246
1247          else
1248
1249       hpd=gspecs(i)*tem**3*z3/pi**2/hquer**3
1250
1251          endif
1252
1253       hfd=hpd*ifok(iafs,i)
1254       fd=fd+hfd
1255
1256        endif
1257         enddo
1258
1259       dfd=abs(fd-(kef(iafs)/volu))
1260       if(dfd.le.abs(gen*(kef(iafs)/volu)).or.dfd.le.genm)return
1261
1262        if(fd.gt.(kef(iafs)/volu))then
1263       c2=chem(iafs)
1264       else
1265       c1=chem(iafs)
1266        endif
1267
1268       k=k+1
1269       if(k.gt.300)then
1270       if(ish.ge.5)
1271      *write(ifch,*)'failure at cm0 at iafs:',iafs
1272       return
1273       endif
1274       goto10
1275       end
1276
1277 c-----------------------------------------------------------------------
1278       function hgcfbe(x)
1279 c-----------------------------------------------------------------------
1280 c integrand of energy density
1281 c------------------------------------------------------------------------
1282       parameter (mspecs=56)
1283       common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
1284       common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
1285       common/ciakt/gen,iafs,ians,genm
1286       eex=81.
1287       hgcfbe=0.0
1288       sq=sqrt(x**2+aspecs(ians)**2)
1289       if(tem.ne.0.0)eex=(sq-chemgc(ians))/tem
1290       if(eex.gt.60.)return
1291       if(eex.lt.-60)then
1292       hgcfbe=1.e25
1293       return
1294       endif
1295
1296       hgcfbe=sq*x**2*exp(-eex)
1297
1298       return
1299       end
1300
1301 c-----------------------------------------------------------------
1302       function hgcfbf(x)
1303 c-----------------------------------------------------------------
1304 c integrand of mean square variance of  energy
1305 c----------------------------------------------------------------
1306       parameter (mspecs=56)
1307       common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
1308       common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
1309       common/ciakt/gen,iafs,ians,genm
1310       eex=61
1311       hgcfbf=0.0
1312
1313       sq=sqrt(x**2+aspecs(ians)**2)
1314       if(tem.ne.0.0)eex=(sq-chemgc(ians))/tem
1315       if(eex.gt.60.)return
1316       if(eex.lt.-60)then
1317       hgcfbf=1.e25
1318       return
1319       endif
1320
1321       hgcfbf=(aspecs(ians)**2+x**2)*x**2*exp(-eex)
1322
1323       return
1324       end
1325
1326 c-----------------------------------------------------------------
1327       function hgcfbn(x)
1328 c-----------------------------------------------------------------
1329 c integrand of hadron density
1330 c-----------------------------------------------------------------
1331       parameter (mspecs=56)
1332       common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
1333       common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
1334       common/ciakt/gen,iafs,ians,genm
1335       eex=81.
1336       hgcfbn=0.0
1337
1338       sq=sqrt(x**2+aspecs(ians)**2)
1339       if(tem.ne.0.0)eex=(sq-chemgc(ians))/tem
1340       if(eex.gt.80.)return
1341       if(eex.lt.-60)then
1342       hgcfbn=1.e25
1343       return
1344       endif
1345
1346       hgcfbn=x**2*exp(-eex)
1347
1348       return
1349       end
1350
1351 c-----------------------------------------------------------------------
1352       function hgcfhe(x)
1353 c-----------------------------------------------------------------------
1354 c integrand of energy density
1355 c------------------------------------------------------------------------
1356       parameter (mspecs=56)
1357       common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
1358       common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
1359       common/ciakt/gen,iafs,ians,genm
1360       eex=81.
1361       hgcfhe=0.0
1362       igsp=int(gspecs(ians))
1363
1364       sq=sqrt(x**2+aspecs(ians)**2)
1365       if(tem.ne.0.0)eex=(sq-chemgc(ians))/tem
1366       if(eex.gt.80.)return
1367
1368        if(mod(igsp,2).ne.0)then
1369       d=-1.0
1370       if(eex.lt.1.e-10)return
1371        else
1372       d=1.0
1373        endif
1374
1375       hgcfhe=sq*x**2/(exp(eex)+d)
1376
1377       return
1378       end
1379
1380 c-----------------------------------------------------------------
1381       function hgcfhf(x)
1382 c-----------------------------------------------------------------
1383 c integrand of mean square variance of  energy
1384 c----------------------------------------------------------------
1385       parameter (mspecs=56)
1386       common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
1387       common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
1388       common/ciakt/gen,iafs,ians,genm
1389       eex=61
1390       hgcfhf=0.0
1391       igsp=int(gspecs(ians))
1392
1393       sq=sqrt(x**2+aspecs(ians)**2)
1394       if(tem.ne.0.0)eex=(sq-chemgc(ians))/tem
1395       if(eex.gt.60.)return
1396       if(eex.lt.(-60.))return
1397
1398        if(mod(igsp,2).ne.0)then
1399       d=-1.0
1400       if(eex.lt.1.0e-10.and.eex.gt.(-1.0e-10))return
1401        else
1402       d=1.0
1403        endif
1404
1405       hgcfhf=(aspecs(ians)**2+x**2)*x**2/(exp(eex)+2.0*d+exp(-eex))
1406
1407       return
1408       end
1409
1410 c-----------------------------------------------------------------
1411       function hgcfhn(x)
1412 c-----------------------------------------------------------------
1413 c integrand of hadron density
1414 c-----------------------------------------------------------------
1415       parameter (mspecs=56)
1416       common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
1417       common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
1418       common/ciakt/gen,iafs,ians,genm
1419       eex=81.
1420       hgcfhn=0.0
1421       igsp=int(gspecs(ians))
1422
1423       sq=sqrt(x**2+aspecs(ians)**2)
1424       if(tem.ne.0.0)eex=(sq-chemgc(ians))/tem
1425       if(eex.gt.80.)return
1426
1427        if(mod(igsp,2).ne.0)then
1428       d=-1.0
1429       if(eex.lt.1.e-10)return
1430        else
1431       d=1.0
1432        endif
1433
1434       hgcfhn=x**2/(exp(eex)+d)
1435
1436       return
1437       end
1438
1439 c-----------------------------------------------------------------
1440       function hgcfhw(x)
1441 c-----------------------------------------------------------------
1442 c integrand of mean square variance of hadron yield
1443 c----------------------------------------------------------------
1444       parameter (mspecs=56)
1445       common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
1446       common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
1447       common/ciakt/gen,iafs,ians,genm
1448       eex=61
1449       hgcfhw=0.0
1450       igsp=int(gspecs(ians))
1451
1452       sq=sqrt(x**2+aspecs(ians)**2)
1453       if(tem.ne.0.0)eex=(sq-chemgc(ians))/tem
1454       if(eex.gt.60.)return
1455       if(eex.lt.(-60.))return
1456
1457        if(mod(igsp,2).ne.0)then
1458       d=-1.0
1459       if(eex.lt.1.0e-10.and.eex.gt.(-1.0e-10))return
1460        else
1461       d=1.0
1462        endif
1463
1464       hgcfhw=x**2/(exp(eex)+2.0*d+exp(-eex))
1465
1466       return
1467       end
1468
1469
1470 c-----------------------------------------------------------------
1471       subroutine hgchac(iboco)
1472 c------------------------------------------------------------------
1473 c returns hadronic chemical potentials as combinations of quark
1474 c chemical potentials
1475 c----------------------------------------------------------------------
1476       include 'epos.inc'
1477       parameter (mspecs=56)
1478       common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
1479       common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
1480       common/cflavs/nflavs,kef(nflav),chem(nflav)
1481       common/cflac/ifok(nflav,mspecs),ifoa(nflav)
1482
1483        do i=1,nspecs
1484       chemgc(i)=0.0
1485       do ii=1,nflavs
1486       chemgc(i)=chemgc(i)+ifok(ii,i)*chem(ii)
1487       if(ish.ge.9)write(ifch,*)'mu_i:',chem(ii),' k_i:',ifok(ii,i)
1488       enddo
1489       if(ish.ge.9)write(ifch,*)'mu_nu:',chemgc(i)
1490       igsp=int(gspecs(i))
1491       if(mod(igsp,2).ne.0.and.chemgc(i).gt.aspecs(i).and.iboco.eq.0)
1492      *chemgc(i)=aspecs(i)
1493        enddo
1494
1495       return
1496       end
1497
1498
1499 c-----------------------------------------------------------------------
1500       subroutine hgclim(a,b)
1501 c----------------------------------------------------------------------
1502 c returns integration limits for numerical evaluation of particle
1503 c and energy densities using quantum statistics
1504 c----------------------------------------------------------------------
1505       include 'epos.inc'
1506       parameter (mspecs=56)
1507       common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
1508       common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
1509       common/ciakt/gen,iafs,ians,genm
1510
1511       igsp=int(gspecs(ians))
1512
1513        if(mod(igsp,2).ne.0)then
1514       a=0.001
1515        else
1516       a=0.0
1517        endif
1518
1519       b=0.0
1520       bb=(chemgc(ians)+tem*80.)**2-aspecs(ians)**2
1521       if(ish.ge.9)write(ifch,*)'bb:',bb
1522       if(bb.ge.0.0)b=sqrt(bb)
1523       if(bb.lt.0.0)then
1524       if(ish.ge.9)write(ifch,*)'failure at hgclim, bb=',bb
1525       if(ish.ge.9)write(ifch,'(1x,a,i5,a,2x,f12.6,1x,a,2x,f9.6)')
1526      *'mu(',ispecs(ians),'):',chemgc(ians),' T:',tem
1527       endif
1528       if(ish.ge.9)write(ifch,*)'ians:',ians,' a:',a,' b:',b
1529       return
1530       end
1531
1532 c------------------------------------------------------------------------
1533       subroutine hgcnbi(iret)
1534 c-----------------------------------------------------------------------
1535 c uses hgcaaa results to generate initial hadron set, nlattc, iozero
1536 c input:
1537 c    ptlngc(1:nspecs): particle number expectation values  /cgchg/
1538 c output:
1539 c     nump:           number of hadrons   /chnbin/
1540 c     ihadro(1:nump): hadron ids          /chnbin/
1541 c     nlattc:         lattice size        /clatt/
1542 c     iozero:         zero weight         /metr1/
1543 c-----------------------------------------------------------------------
1544       include 'epos.inc'
1545       parameter(maxp=500)
1546       common/chnbin/nump,ihadro(maxp)
1547       parameter (mspecs=56)
1548       common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
1549       common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
1550       common/cgctot/rmstot,ptltot
1551       common/camgc/amgc,samgc,amtot
1552       common/cflavs/nflavs,kef(nflav),chem(nflav)
1553       common/cflac/ifok(nflav,mspecs),ifoa(nflav)
1554       common/clatt/nlattc,npmax
1555       common/cgcnb/nptlgc(mspecs)
1556       common/ctaue/taue
1557       common/cgck/k(nflav),kp(nflav),kps(nflav)
1558      *,idp(maxp),ida(mspecs),idb(mspecs)
1559       integer hgcndn
1560
1561       iret=0
1562       isho=ish
1563       if(ishsub/100.eq.50)ish=mod(ishsub,100)
1564
1565       if(ish.ge.7)write(ifch,*)('-',l=1,10)
1566      *,' entry sr hgcnbi ',('-',l=1,30)
1567
1568
1569       nh=nint(ptltot)
1570       iug=(1+iospec)/2*2-1
1571       if(iug.lt.9)call utstop('hgcnbi: iospec < 9&')
1572
1573 c     determine nlattc
1574 c     ----------------
1575         if(ionlat.eq.1)then
1576       s1=ptltot+2.*rmstot
1577       s2=1.3*ptltot
1578       s=max(s1,s2,6.)
1579       nlattc=nint(s)
1580        elseif(ionlat.eq.2)then
1581       s1=ptltot+3.*rmstot
1582       s2=1.5*ptltot
1583       s=max(s1,s2,6.)
1584       nlattc=nint(s)
1585        elseif(ionlat.eq.3)then
1586       s1=ptltot+4.*rmstot
1587       s2=2.*ptltot
1588       s=max(s1,s2,6.)
1589       nlattc=nint(s)
1590         elseif(ionlat.eq.0)then
1591       nlattc=8*(tecm/10)*(1/(tecm/volu))**0.2*(nspecs/3.)**0.3
1592       if(aspecs(1).lt.0.010)nlattc=nlattc*3
1593       nlattc=max(nlattc,20)
1594         endif
1595
1596       if(ish.ge.7)write(ifch,*)'nlattc:',nlattc
1597
1598 c     determine iozero
1599 c     ----------------
1600       if(iozero.eq.-1)then
1601       iozero=nspecs
1602       elseif(iozero.eq.-2)then
1603       iozero=nspecs*int(sqrt(volu/tecm))
1604       endif
1605
1606 c     modify iozero for testing
1607 c     -------------------------
1608       if(iozevt.gt.0)then
1609       iozero=(nrevt/iozevt+1)*iozinc   !nrevt=event number - 1 !!
1610       write(ifch,*)'nrevt+1:',nrevt+1,'   iozero:',iozero
1611       endif
1612
1613 c     initial hadron set
1614 c     ------------------
1615       ammin=2.*aspecs(1)
1616       if(tecm.lt.ammin)then
1617       write(ifch,*)'impossible to generate hadron configuration'
1618       call utstop('hgcnbi: tecm less than two pi0 masses&')
1619       endif
1620
1621       kk=1
1622 100   continue
1623
1624        if(kk.gt.20)then
1625        iret=1
1626       if(ish.ge.7)then
1627       write(ifch,*)'failed to generate hadron set for'
1628      *,' event:',nrevt+1
1629       write(ifch,*)'u d s :',keu,ked,kes,' E:',tecm
1630       write(ifch,*)('-',i=1,30)
1631      *,' exit sr hgcnbi ',('-',i=1,10)
1632       endif
1633       ish=isho
1634       return
1635         endif
1636
1637       amtot=0.0
1638       do i=1,nspecs
1639       nptlgc(i)=0
1640       enddo
1641       do ii=1,nflavs
1642       k(ii)=kef(ii)
1643       enddo
1644
1645       if(ish.ge.7)write(ifch,*)
1646      *'sample hadron multiplicities and total mass:'
1647
1648       kbar=keu+ked+kes
1649       kpar=iabs(keu)+iabs(ked)+iabs(kes)
1650       nbar=kbar/3.
1651       if(ish.ge.7)write(ifch,*)'baryon number:',nbar,' parton number:'
1652      *,kpar
1653
1654       nn=2
1655       if(ioinco.ne.2)then
1656       nn=hgcndn(0)
1657       else
1658       nn=nh
1659       endif
1660       nb=iabs(nbar)
1661       if(ish.ge.7)write(ifch,*)'<n>:',nh,' n_sample:',nn,' n_bar:',nb
1662       if(nn.gt.nb.and.nb.ne.0.and.nb.ge.nh)nn=nb
1663       if(nn.lt.nb.and.nb.ne.0)nn=nb
1664       km=kpar-iabs(kbar)
1665       nt=km/2+nb
1666       if(nt.gt.nn)nn=nt
1667       nn=max(nn,2)
1668
1669       if(ioinco.eq.2)then
1670       nit=15*taue
1671       else
1672       itpn=100
1673       nit=nn*itpn
1674       endif
1675       nbb=0
1676       n=0
1677
1678 c     start with nb protons
1679       nptlgc(19)=nptlgc(19)+nb
1680       n=nb
1681       amtot=amtot+nb*aspecs(19)
1682       do ii=1,nflavs
1683       k(ii)=k(ii)-ifok(ii,19)*nb
1684       enddo
1685       nbb=nbb+nb
1686
1687
1688        do it=1,nit
1689
1690       xsp=nspecs
1691       x0=0.5
1692       xib=x0+xsp*rangen()
1693       ib=nint(xib)
1694       if(ib.gt.nspecs)ib=nspecs
1695       if(ib.lt.1)ib=1
1696       kb=ifok(1,ib)+ifok(2,ib)+ifok(3,ib)
1697       if(rangen().lt.0.5.and.nptlgc(ib).ge.1)then
1698       ni=-1
1699       else
1700       ni=1
1701       endif
1702       as=1.0
1703       if(nptlgc(ib).eq.0)as=0.5
1704       if(nptlgc(ib).eq.1.and.ni.eq.(-1))as=2.0
1705       if(ish.ge.9)write(ifch,*)
1706      *'id:',ispecs(ib),' <i>:',ptlngc(ib),' ni:',ni
1707
1708          if(ni.ne.0)then
1709
1710        if(ptlngc(ib).gt.5.0)then
1711
1712       pnla=hgcpnl(ib,0)
1713       pnlb=hgcpnl(ib,ni)
1714       pnlog=-pnla+pnlb
1715       if(ish.ge.9)write(ifch,*)'pnlog:',pnlog
1716       if(pnlog.lt.60)then
1717       pn=exp(pnlog)
1718       else
1719       pn=1.1
1720       endif
1721
1722        else
1723
1724       if(ni.eq.1)then
1725       pn=ptlngc(ib)/(nptlgc(ib)+1)
1726       elseif(ni.eq.(-1).and.ptlngc(ib).gt.1.e-20)then
1727       pn=nptlgc(ib)/ptlngc(ib)
1728       elseif(nptlgc(ib).gt.0)then
1729       pn=1.1
1730       else
1731       pn=0.0
1732       endif
1733
1734        endif
1735
1736        pm=1.0
1737        if(ioinfl.ge.0)then
1738       pmla=hgcpml(ib,0,ib,0)
1739       pmlb=hgcpml(ib,ni,ib,0)
1740       pmlog=-pmla+pmlb
1741       if(ish.ge.9)write(ifch,*)'pmlog:',pmlog
1742       if(pmlog.lt.60)then
1743       pm=exp(pmlog)
1744       else
1745       pm=1.1
1746       endif
1747        endif
1748
1749       p=pn*pm*as
1750       r=rangen()
1751       if(r.le.p)then
1752       nptlgc(ib)=nptlgc(ib)+ni
1753       n=n+ni
1754       amtot=amtot+ni*aspecs(ib)
1755       do ii=1,nflavs
1756       k(ii)=k(ii)-ifok(ii,ib)*ni
1757       enddo
1758       if(kb.ne.0)nbb=nbb+ni
1759       if(ish.ge.7.and.ni.gt.0)write(ifch,*)'add:'
1760       if(ish.ge.7.and.ni.lt.0)write(ifch,*)'remove:'
1761       if(ish.ge.7)write(ifch,*)'id:',ispecs(ib),' <n_i>:',ptlngc(ib)
1762      *,' n_i:',nptlgc(ib)
1763       if(ish.ge.7)write(ifch,*)'<n>:',nn,' it:',it
1764       if(ish.ge.7)write(ifch,*)'<M>:',amgc,' M:',amtot
1765       if(ish.ge.7)write(ifch,*)'p:',p,' r:',r
1766       if(ish.ge.7)write(ifch,*)'flav defect: u:',k(1),' d:'
1767      *,k(2),' s:',k(3)
1768       if(n.ge.nn.and.ioinco.ne.2)goto102
1769       endif
1770
1771        endif
1772
1773        enddo
1774
1775
1776 102   continue
1777
1778        ndd=0
1779 c      if(nbb.lt.nb)then
1780 c      nba=nb-nbb
1781 c     if(nbar.gt.0)then
1782 c     if(ish.ge.7)write(ifch,*)'add protons: nba:',nba
1783 c     nptlgc(19)=nptlgc(19)+nba
1784 c     n=n+nba
1785 c     amtot=amtot+aspecs(19)*nba
1786 c     elseif(nbar.lt.0)then
1787 c     if(ish.ge.7)write(ifch,*)'add aprotons: nba:',nba
1788 c     nptlgc(20)=nptlgc(20)+nba
1789 c     n=n+nba
1790 c     amtot=amtot+aspecs(20)*nba
1791 c     endif
1792 c      endif
1793        if(n.lt.nn.and.ioinco.ne.2)then
1794       ndd=nn-n
1795       nd=mod(ndd,4)
1796       xn=n
1797       xnn=nn
1798       xl=(xnn-xn)/4.
1799       l=aint(xl)
1800       if(ish.ge.7)write(ifch,*)'add pions/etas: ndd:',ndd
1801      *,' l:',l,' nd:',nd
1802         if(l.ge.1)then
1803        do j=1,l
1804       nptlgc(1)=nptlgc(1)+1
1805       nptlgc(2)=nptlgc(2)+1
1806       nptlgc(3)=nptlgc(3)+1
1807       nptlgc(8)=nptlgc(8)+1
1808       amtot=amtot+aspecs(1)+aspecs(2)+aspecs(3)+aspecs(8)
1809        enddo
1810         endif
1811       if(nd.eq.1)then
1812       nptlgc(1)=nptlgc(1)+1
1813       amtot=amtot+aspecs(1)
1814       elseif(nd.eq.2)then
1815       nptlgc(2)=nptlgc(2)+1
1816       nptlgc(3)=nptlgc(3)+1
1817       amtot=amtot+aspecs(2)+aspecs(3)
1818       elseif(nd.eq.3)then
1819       nptlgc(2)=nptlgc(2)+1
1820       nptlgc(3)=nptlgc(3)+1
1821       nptlgc(1)=nptlgc(1)+1
1822       amtot=amtot+aspecs(2)+aspecs(3)+aspecs(1)
1823       endif
1824        endif
1825
1826        if(n.eq.0.and.ioinco.eq.2)then
1827       nptlgc(2)=nptlgc(2)+1
1828       nptlgc(3)=nptlgc(3)+1
1829       amtot=amtot+aspecs(2)+aspecs(3)
1830        elseif(n.eq.1.and.ioinco.eq.2)then
1831       nptlgc(1)=nptlgc(1)+1
1832       amtot=amtot+aspecs(1)
1833        endif
1834
1835       if(amtot.ge.tecm.and.ioinfl.ge.0)then
1836       if(ish.ge.7)write(ifch,*)
1837      *'total mass exceeded , redo configuration'
1838       kk=kk+1
1839       goto100
1840       endif
1841
1842
1843       iii=0
1844       if(ish.ge.7)then
1845         write(ifch,*)'u d s :',keu,ked,kes,' E:',tecm
1846         write(ifch,*)
1847      *'hadron set without flavor conservation:'
1848       endif
1849       do i=1,nspecs
1850       n=nptlgc(i)
1851       if(n.ge.1)then
1852       do j=1,n
1853       iii=iii+1
1854       if(iii.gt.maxp)stop'iii>maxp in hgcnbi'
1855       idp(iii)=ispecs(i)
1856       enddo
1857       endif
1858       enddo
1859       if(ish.ge.7)then
1860         write(ifch,'(1x,10i6)')(idp(i),i=1,iii)
1861         write(ifch,*)'flav defect: u:',k(1),' d:'
1862      *,k(2),' s:',k(3)
1863         write(ifch,*)'M:',amtot,' <M>:',amgc
1864       endif
1865       if(ioinfl.le.0)goto1000
1866
1867       ll=1
1868       llmax=nn*25
1869       ior=1
1870
1871 120        if(k(1).ne.0.or.k(2).ne.0.or.k(3).ne.0)then
1872
1873         if(kk.gt.6)ior=0
1874
1875       if(ish.ge.7)write(ifch,*)
1876      *'remaining flavor defect before operation:',ll
1877       if(ish.ge.7)write(ifch,*)'flav defect: u:',k(1),' d:'
1878      *,k(2),' s:',k(3)
1879
1880       nida=0
1881       do i=1,nspecs
1882       if(nptlgc(i).gt.0)then
1883       nida=nida+1
1884       ida(nida)=i
1885       endif
1886       enddo
1887
1888       if(nida.eq.0)then
1889       if(ish.ge.7)write(ifch,*)'no proposals in a , redo'
1890       kk=kk+1
1891       goto100
1892       endif
1893
1894
1895       xna=0.5+nida*rangen()
1896       na=nint(xna)
1897       if(na.gt.nida)na=nida
1898       if(na.lt.1)na=1
1899       ia=ida(na)
1900       if(ish.ge.7)write(ifch,*)'nida:',nida,' ia:',ia
1901
1902       nidb=0
1903       do ii=1,nflavs
1904       kp(ii)=k(ii)+ifok(ii,ia)
1905       kps(ii)=isign(1,kp(ii))
1906       enddo
1907       if(ish.ge.7)write(ifch,*)
1908      *'   assemble: u:',kp(1),' d:',kp(2),' s:',kp(3)
1909       do i=1,nspecs
1910       iacc=0
1911       naccsp=0
1912       naccmi=1
1913       do ii=1,nflavs
1914       naccsp=naccsp+iabs(ifok(ii,i))
1915       if(kp(ii).ne.0)then
1916       if(kps(ii)*ifok(ii,i).le.kps(ii)*kp(ii)
1917      *.and.kps(ii)*ifok(ii,i).gt.0)iacc=iacc+iabs(ifok(ii,i))
1918       endif
1919       enddo
1920       if(kp(1).eq.0.and.kp(2).eq.0.and.kp(3).eq.0)naccmi=0
1921       if(iacc.eq.naccsp.and.naccsp.ge.naccmi)then
1922       nidb=nidb+1
1923       idb(nidb)=i
1924       endif
1925       enddo
1926
1927       if(nidb.eq.0)then
1928       if(ish.ge.7)write(ifch,*)'no proposals in b , redo'
1929       kk=kk+1
1930       goto100
1931       endif
1932
1933       xnb=0.5+nidb*rangen()
1934       nb=nint(xnb)
1935       if(nb.gt.nidb)nb=nidb
1936       if(nb.lt.1)nb=1
1937       ib=idb(nb)
1938       if(ish.ge.7)write(ifch,*)'nidb:',nidb,' ib:',ib
1939       if(ish.ge.7)write(ifch,*)
1940      *'proposal:',ispecs(ia),' --> ',ispecs(ib)
1941
1942       asym=1.0
1943
1944 c      if(asym.gt.0.0)then
1945
1946        if(ptlngc(ia).gt.5.0)then
1947       pnali=hgcpnl(ia,0)
1948       pnalf=hgcpnl(ia,-1)
1949       pnalog=-pnali+pnalf
1950       if(ish.ge.7)write(ifch,*)'pnalog:',pnalog
1951       if(pnalog.lt.60)then
1952       pna=exp(pnalog)
1953       else
1954       pna=1.1
1955       endif
1956        else
1957       if(ptlngc(ia).gt.1.e-20)then
1958       pna=nptlgc(ia)/ptlngc(ia)
1959       elseif(nptlgc(ia).gt.0)then
1960       pna=1.1
1961       else
1962       pna=0.0
1963       endif
1964        endif
1965
1966        if(ptlngc(ib).gt.5.0)then
1967       pnbli=hgcpnl(ib,0)
1968       pnblf=hgcpnl(ib,1)
1969       pnblog=-pnbli+pnblf
1970       if(ish.ge.7)write(ifch,*)'pnblog:',pnblog
1971       if(pnblog.lt.60)then
1972       pnb=exp(pnblog)
1973       else
1974       pnb=1.1
1975       endif
1976        else
1977       pnb=ptlngc(ib)/(nptlgc(ib)+1)
1978        endif
1979
1980
1981       pmli=hgcpml(ia,0,ib,0)
1982       pmlf=hgcpml(ia,-1,ib,1)
1983       pmlog=-pmli+pmlf
1984       if(ish.ge.7)write(ifch,*)'pmlog:',pmlog
1985       if(pmlog.lt.60)then
1986       pm=exp(pmlog)
1987       else
1988       pm=1.1
1989       endif
1990
1991       p=pna*pnb*pm*asym
1992       if(ior.eq.0)then
1993       r=0.0
1994       else
1995       r=rangen()
1996       endif
1997
1998 c      else
1999
2000 c     r=1.0
2001 c     p=0.0
2002
2003 c      endif
2004
2005        if(r.lt.p)then
2006       if(ish.ge.7)write(ifch,*)'p:',p,' r:',r,' asymmetry:',asym
2007       if(ish.ge.7)write(ifch,*)'remove ',ispecs(ia),'  add ',ispecs(ib)
2008      *,'  proposal accepted'
2009       nptlgc(ia)=nptlgc(ia)-1
2010       nptlgc(ib)=nptlgc(ib)+1
2011       amtot=amtot-aspecs(ia)+aspecs(ib)
2012       do ii=1,nflavs
2013       k(ii)=k(ii)+ifok(ii,ia)-ifok(ii,ib)
2014       enddo
2015        endif
2016
2017
2018         if(k(1).ne.0.or.k(2).ne.0.or.k(3).ne.0)then
2019        ll=ll+1
2020       if(ll.le.llmax)then
2021       goto120
2022       else
2023       if(ish.ge.7)write(ifch,*)'failed to remove defect, redo'
2024       kk=kk+1
2025       goto100
2026        endif
2027         endif
2028
2029          endif
2030
2031 1000  continue
2032
2033       nump=0
2034       kcu=0
2035       kcd=0
2036       kcs=0
2037       do i=1,nspecs
2038       n=nptlgc(i)
2039       if(n.ge.1)then
2040       do j=1,n
2041       nump=nump+1
2042       ihadro(nump)=ispecs(i)
2043       kcu=kcu+ifok(1,i)
2044       kcd=kcd+ifok(2,i)
2045       kcs=kcs+ifok(3,i)
2046       enddo
2047       endif
2048       enddo
2049
2050           if(ioinfl.gt.0)then
2051         if(kcu.ne.keu.or.kcd.ne.ked.or.kcs.ne.kes)then
2052       if(ish.ge.7)write(ifch,*)
2053      *'failed to remove flavor defect, redo configuration'
2054       kk=kk+1
2055       goto100
2056         endif
2057           endif
2058
2059       if(ioinct.ge.1)then
2060         chitot=0.0
2061         nutot=nspecs
2062         do i=1,nspecs
2063         chi=0.0
2064         if(rmsngc(i).gt.1.e-10)chi=(ptlngc(i)-nptlgc(i))/rmsngc(i)
2065         chitot=chitot+chi**2
2066         enddo
2067         call xhgccc(chitot)
2068
2069         u=0
2070         d=0
2071         s=0
2072         do i=1,nspecs
2073         u=u+ifok(1,i)*nptlgc(i)
2074         d=d+ifok(2,i)*nptlgc(i)
2075         s=s+ifok(3,i)*nptlgc(i)
2076         enddo
2077         call xhgcfl(u,d,s,0)
2078         call xhgcam(amtot,0)
2079       endif
2080
2081       if(ish.ge.7)then
2082         write(ifch,*)
2083      *'initial hadron set for droplet decay:'
2084         write(ifch,'(1x,10i6)')(ihadro(i),i=1,nump)
2085       endif
2086        if(nump.ge.nlattc)then
2087          nlattc=nump+1
2088          if(ish.ge.7)then
2089            write(ifch,*)'initial set > nlattc !'
2090            write(ifch,*)'new nlattc:',nlattc
2091          endif
2092        endif
2093        if(ish.ge.7)then
2094          write(ifch,*)'keu:',kef(1),' kcu:',kcu,' ku:',k(1)
2095          write(ifch,*)'ked:',kef(2),' kcd:',kcd,' kd:',k(2)
2096          write(ifch,*)'kes:',kef(3),' kcs:',kcs,' ks:',k(3)
2097          write(ifch,*)' nh:',nh,' nump:',nump
2098          write(ifch,*)' nu:',nutot,'  chi^2:',chitot
2099          write(ifch,*)'iozero:',iozero,'  iomom:',iomom
2100          write(ifch,*)
2101      *'total mass:',amtot,' droplet mass:',tecm
2102          write(ifch,*)'trials needed:',kk
2103      *,' operations needed:',ll
2104          write(ifch,*)'iterations:',it,' pions added:',ndd
2105          write(ifch,*)('-',i=1,30)
2106      *,' exit sr hgcnbi ',('-',i=1,10)
2107        endif
2108       ish=isho
2109       return
2110
2111       end
2112
2113 c--------------------------------------------------------------------
2114       integer function hgcndn(i)
2115 c--------------------------------------------------------------------
2116 c returns random multiplicity from gaussian distribution for species i
2117 c---------------------------------------------------------------------
2118       include 'epos.inc'
2119       parameter (mspecs=56)
2120       common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
2121       common/cgctot/rmstot,ptltot
2122       common/clatt/nlattc,npmax
2123       a=iowidn
2124       kk=0
2125
2126        if(i.eq.0)then
2127
2128 1     continue
2129       kk=kk+1
2130       p=0.0
2131       nmin=2
2132       nh=nint(ptltot)
2133       nmax=nlattc
2134       xn=1.5+(nmax-nmin)*rangen()
2135       n=nint(xn)
2136       x=(n-ptltot)**2/2.0
2137       y=-70.
2138       if(rmstot.gt.1.e-15)y=-x/rmstot**2*a**2
2139       if(y.lt.70.)p=exp(y)
2140       if(rmstot.gt.1.e-15.and.iowidn.lt.0)p=p/sqrt(2.*pi)/rmstot
2141       if(p.ge.rangen())then
2142       hgcndn=n
2143       if(ish.ge.9)write(ifch,*)'hgcndn: k:',kk,' n:',hgcndn
2144       return
2145       else
2146       if(kk.le.25)goto1
2147       hgcndn=max(2,nh)
2148       if(ish.ge.9)write(ifch,*)'hgcndn: k:',kk,' n:',hgcndn
2149       return
2150       endif
2151
2152        else
2153
2154 2     continue
2155       kk=kk+1
2156       p=0.0
2157       nmin=0
2158       nh=nint(ptlngc(i))
2159       nmax=2*nh
2160       nmax=max(2,nmax)
2161       xn=-0.5+(nmax-nmin)*rangen()
2162       n=nint(xn)
2163       x=(n-ptlngc(i))**2/2.0
2164       if(x.lt.1.e-30)then
2165       p=1.
2166       else
2167       y=-70.
2168       if(rmsngc(i).gt.1.e-15)y=-x/rmsngc(i)**2
2169       if(y.lt.70.)p=exp(y)
2170       if(rmsngc(i).gt.1.e-15.and.iowidn.lt.0)
2171      *p=p/sqrt(2.*pi)/rmsngc(i)
2172       endif
2173       if(p.ge.rangen())then
2174       hgcndn=n
2175       if(ish.ge.9)write(ifch,*)'hgcndn: k:',kk,' n:',hgcndn
2176       return
2177       else
2178       if(kk.le.25)goto2
2179       hgcndn=nh
2180       if(ish.ge.9)write(ifch,*)'hgcndn: k:',kk,' n:',hgcndn
2181       return
2182       endif
2183
2184        endif
2185
2186       end
2187
2188 c--------------------------------------------------------------------
2189       function hgcpml(i1,n1,i2,n2)
2190 c--------------------------------------------------------------------
2191       include 'epos.inc'
2192       parameter (mspecs=56)
2193       common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
2194       common/camgc/amgc,samgc,amtot
2195       common/cgcnb/nptlgc(mspecs)
2196       if(ish.ge.9)write(ifch,*)'i1:',i1,' i2:',i2
2197       if(ish.ge.9)write(ifch,*)'n1:',n1,' n2:',n2
2198       hgcpml=-1.e30
2199       ampr=n1*aspecs(i1)+n2*aspecs(i2)
2200       if((amtot+ampr).lt.tecm.and.(amtot+ampr).ge.0
2201      *.and.nptlgc(i1).ge.(-n1).and.nptlgc(i2).ge.(-n2))then
2202       hgcpml=0.0
2203       pl=(amtot-amgc+ampr)**2/2.0
2204       if(pl.lt.1.e-30)then
2205       hgcpml=0.0
2206       return
2207       endif
2208       if(samgc.gt.1.e-15)hgcpml=-pl/samgc**2
2209       endif
2210       if(ish.ge.9)write(ifch,*)'hgcpml:',hgcpml
2211       return
2212       end
2213
2214 c--------------------------------------------------------------------
2215       function hgcpnl(i,n)
2216 c--------------------------------------------------------------------
2217       include 'epos.inc'
2218       parameter (mspecs=56)
2219       common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
2220       common/cgcnb/nptlgc(mspecs)
2221       if(ish.ge.9)write(ifch,*)'i:',i,' n:',n
2222       hgcpnl=-1.e30
2223       if(nptlgc(i).ge.(-n))then
2224       pl=(nptlgc(i)-ptlngc(i)+n)**2/2.0
2225       if(pl.lt.1.e-30)then
2226       hgcpnl=0.0
2227       return
2228       endif
2229       if(rmsngc(i).gt.1.e-15)hgcpnl=-pl/rmsngc(i)**2
2230       endif
2231       if(ish.ge.9)write(ifch,*)'hgcpnl:',hgcpnl
2232       return
2233       end
2234
2235
2236 c--------------------------------------------------------------------
2237       subroutine hgcpen
2238 c--------------------------------------------------------------------
2239 c returns array for twodimensional plot of energy- and flavor-
2240 c density
2241 c--------------------------------------------------------------------
2242 c xpar1,xpar2 temperature range
2243 c xpar3       # of bins for temperature
2244 c xpar4,xpar5 chem.pot. range
2245 c xpar6       # of bins for chem.pot.
2246 c xpar7       max. density
2247 c xpar8       strange chem.pot.
2248 c--------------------------------------------------------------------
2249       include 'epos.inc'
2250       parameter (mspecs=56)
2251       common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
2252       common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
2253       common/cflavs/nflavs,kef(nflav),chem(nflav)
2254       common/cflac/ifok(nflav,mspecs),ifoa(nflav)
2255       common/ciakt/gen,iafs,ians,genm
2256       parameter (nbin=100)
2257       real edensi(nbin,nbin),qdensi(nbin,nbin)
2258       external hgcfhe
2259       external hgcfhn
2260       external hgcfbe
2261       external hgcfbn
2262
2263       iug=(1+iospec)/2*2-1
2264
2265 c     initialization
2266 c     --------------
2267
2268       if(iug.eq.1)nflavs=1
2269       if(iug.eq.3)nflavs=2
2270       if(iug.eq.5)nflavs=2
2271       if(iug.eq.7)nflavs=3
2272       if(iug.eq.9)nflavs=3
2273       if(iug.eq.11)nflavs=3
2274       tem=0.0
2275       do i=1,nflavs
2276       chem(i)=0.0
2277       enddo
2278       call hgchac(0)
2279       do i=1,nspecs
2280       ptlngc(i)=0.0
2281       rmsngc(i)=0.0
2282       enddo
2283
2284       nbt=nint(xpar3)
2285       nbc=nint(xpar6)
2286       nbc=min(nbc,100)
2287       nbt=min(nbt,100)
2288       dt=(xpar2-xpar1)/nbt
2289       dc=(xpar5-xpar4)/nbc
2290       ymax=xpar7
2291       cs=xpar8
2292
2293
2294       t0=xpar1+dt/2.
2295       c0=xpar4+dc/2
2296       do i=1,nbc
2297       chem(1)=c0+(i-1)*dc
2298       chem(2)=chem(1)
2299       chem(3)=cs
2300       chem(4)=0.0
2301       chem(5)=0.0
2302       chem(6)=0.0
2303       call hgchac(0)
2304       do ii=1,nbt
2305       tem=t0+(ii-1)*dt
2306       if(ish.ge.5)write(ifch,*)' mu:',chem(1),' T:',tem
2307
2308        qd=0.0
2309        ed=0.0
2310
2311       do ians=1,nspecs
2312
2313       call hgclim(a,b)
2314
2315       if(b.eq.0.0)then
2316       hden=0.0
2317       elseif(iostat.eq.0)then
2318       call uttraq(hgcfhn,a,b,hden)
2319       elseif(iostat.eq.1)then
2320       call uttraq(hgcfbn,a,b,hden)
2321       endif
2322       hd=hden*gspecs(ians)/2./pi**2/hquer**3
2323
2324       if(ish.ge.7)write(ifch,*)'i:',ians,' n_u:',ifok(1,ians),' hd:',hd
2325
2326       qd=qd+ifok(1,ians)*hd+ifok(2,ians)*hd
2327       if(qd.gt.ymax)qd=ymax
2328 c     if(qd.gt.ymax)qd=0.0
2329       if(qd.lt.-ymax)qd=-ymax
2330 c     if(qd.lt.-ymax)qd=0.0
2331
2332
2333       if(b.eq.0.0)then
2334       edi=0.0
2335       elseif(iostat.eq.0)then
2336       call uttraq(hgcfhe,a,b,edi)
2337       elseif(iostat.eq.1)then
2338       call uttraq(hgcfbe,a,b,edi)
2339       endif
2340       edi=edi*gspecs(ians)/2./pi**2/hquer**3
2341
2342       if(ish.ge.7)write(ifch,*)'i:',ians,' mu:',chemgc(ians)
2343      *                        ,' edi:',edi
2344
2345       ed=ed+edi
2346       if(ed.gt.ymax)ed=ymax
2347 c     if(ed.gt.ymax)ed=0.0
2348       enddo
2349
2350       if(ish.ge.5)write(ifch,*)' ed:',ed,' qd:',qd
2351       edensi(i,ii)=ed
2352       qdensi(i,ii)=qd
2353
2354       enddo
2355       enddo
2356
2357       write(ifhi,'(a)')      'openhisto'
2358       write(ifhi,'(a,2e11.3)')'xrange',xpar1,xpar2
2359       write(ifhi,'(a,2e11.3)')'yrange',xpar4,xpar5
2360       write(ifhi,'(a)')      'set ityp2d 5'
2361       write(ifhi,'(a,i4)')   'array2d',nbt
2362       do j=1,nbc
2363       do jj=1,nbt
2364       write(ifhi,'(e11.3)') edensi(j,jj)
2365       enddo
2366       enddo
2367       write(ifhi,'(a)')       '  endarray'
2368       write(ifhi,'(a)')       'closehisto plot2d'
2369
2370       write(ifhi,'(a)')      'openhisto'
2371       write(ifhi,'(a,2e11.3)')'xrange',xpar1,xpar2
2372       write(ifhi,'(a,2e11.3)')'yrange',xpar4,xpar5
2373       write(ifhi,'(a)')      'set ityp2d 5'
2374       write(ifhi,'(a,i4)')   'array2d',nbt
2375       do j=1,nbc
2376       do jj=1,nbt
2377       write(ifhi,'(e11.3)') qdensi(j,jj)
2378       enddo
2379       enddo
2380       write(ifhi,'(a)')       '  endarray'
2381       write(ifhi,'(a)')       'closehisto plot2d'
2382
2383         return
2384         end
2385
2386 c--------------------------------------------------------------------
2387       subroutine hgcpfl
2388 c--------------------------------------------------------------------
2389 c returns array for twodimensional plot of energy- and flavor-
2390 c density fluctuations
2391 c--------------------------------------------------------------------
2392 c xpar1,xpar2 temperature range
2393 c xpar3       # of bins for temperature
2394 c xpar4,xpar5 chem.pot. range
2395 c xpar6       # of bins for chem.pot.
2396 c xpar7       max. density
2397 c xpar8       strange chem.pot.
2398 c--------------------------------------------------------------------
2399       include 'epos.inc'
2400       parameter (mspecs=56)
2401       common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
2402       common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
2403       common/cflavs/nflavs,kef(nflav),chem(nflav)
2404       common/ciakt/gen,iafs,ians,genm
2405       parameter (nbin=100)
2406       real efl(nbin,nbin),qfl(nbin,nbin),v(nbin),wn(nbin),we(nbin)
2407       external hgcfhf
2408       external hgcfhe
2409       external hgcfhn
2410       external hgcfhw
2411       external hgcfbf
2412       external hgcfbe
2413       external hgcfbn
2414
2415       iug=(1+iospec)/2*2-1
2416
2417 c     initialization
2418 c     --------------
2419
2420       if(iug.eq.1)nflavs=1
2421       if(iug.eq.3)nflavs=2
2422       if(iug.eq.5)nflavs=2
2423       if(iug.eq.7)nflavs=3
2424       if(iug.eq.9)nflavs=3
2425       if(iug.eq.11)nflavs=3
2426       tem=0.0
2427       do i=1,nflavs
2428       chem(i)=0.0
2429       enddo
2430       call hgchac(0)
2431       do i=1,nspecs
2432       ptlngc(i)=0.0
2433       rmsngc(i)=0.0
2434       enddo
2435
2436       nbt=nint(xpar3)
2437       nbv=nint(xpar6)
2438       nbv=min(nbv,100)
2439       nbt=min(nbt,100)
2440       dt=(xpar2-xpar1)/nbt
2441       dv=(xpar5-xpar4)/nbv
2442       ymax=1.e20
2443       chem(1)=xpar7
2444       chem(2)=xpar7
2445       chem(3)=xpar8
2446       call hgchac(0)
2447
2448
2449       t0=xpar1+dt/2.
2450       v0=xpar4
2451       do i=1,nbv
2452       volu=v0+(i-1)*dv
2453       do ii=1,nbt
2454       tem=t0+(ii-1)*dt
2455       if(ish.ge.5)write(ifch,*)'volu:',volu,' tem:',tem
2456
2457        ev=0.0
2458        ee=0.0
2459        qv=0.0
2460        qe=0.0
2461
2462       do ians=1,nspecs
2463
2464       call hgclim(a,b)
2465
2466       if(b.eq.0.0)then
2467       hn=0.0
2468       hv=0.0
2469       elseif(iostat.eq.0)then
2470       call uttraq(hgcfhn,a,b,hn)
2471       call uttraq(hgcfhw,a,b,hv)
2472       elseif(iostat.eq.1)then
2473       call uttraq(hgcfbn,a,b,hn)
2474       hv=hn
2475       endif
2476       hn=hn*volu*gspecs(ians)/2./pi**2/hquer**3
2477       hv=hv*volu*gspecs(ians)/2./pi**2/hquer**3
2478       if(ish.ge.5)write(ifch,*)'hn:',hn,' hv:',hv
2479
2480       hn=max(hn,1.e-15)
2481       qv=qv+hv
2482       qe=qe+hn
2483
2484
2485       if(qv.gt.ymax)qv=ymax
2486       if(qe.gt.ymax)qe=ymax
2487
2488
2489       if(b.eq.0.0)then
2490       eei=0.0
2491       evi=0.0
2492       elseif(iostat.eq.0)then
2493       call uttraq(hgcfhe,a,b,eei)
2494       call uttraq(hgcfhf,a,b,evi)
2495       elseif(iostat.eq.1)then
2496       call uttraq(hgcfbe,a,b,eei)
2497       call uttraq(hgcfbf,a,b,evi)
2498       endif
2499       eei=eei*volu*gspecs(ians)/2./pi**2/hquer**3
2500       evi=evi*volu*gspecs(ians)/2./pi**2/hquer**3
2501       if(ish.ge.5)write(ifch,*)'eei:',eei,' evi:',evi
2502
2503
2504       eei=max(eei,1.e-15)
2505       ev=ev+evi
2506       ee=ee+eei
2507       if(ev.gt.ymax)ev=ymax
2508       if(ee.gt.ymax)ee=ymax
2509       enddo
2510       if(ish.ge.5)write(ifch,*)'qv:',qv,' ev:',ev
2511
2512       qfl(i,ii)=0.
2513       efl(i,ii)=0.
2514       if(ev.gt.0.0.and.ee.gt.1.e-15)efl(i,ii)=sqrt(ev)/ee
2515       if(qv.gt.0.0.and.ee.gt.1.e-15)qfl(i,ii)=sqrt(qv)/qe
2516       if(tem.eq.0.195)then
2517       we(i)=efl(i,ii)
2518       wn(i)=qfl(i,ii)
2519       v(i)=volu
2520       endif
2521
2522       enddo
2523       enddo
2524
2525       write(ifhi,'(a)')      'openhisto'
2526       write(ifhi,'(a,2e11.3)')'xrange',xpar1,xpar2
2527       write(ifhi,'(a,2e11.3)')'yrange',xpar4,xpar5
2528       write(ifhi,'(a)')      'set ityp2d 5'
2529       write(ifhi,'(a,i4)')   'array2d',nbt
2530       do j=1,nbv
2531       do jj=1,nbt
2532       write(ifhi,'(e11.3)') efl(j,jj)
2533       enddo
2534       enddo
2535       write(ifhi,'(a)')       '  endarray'
2536       write(ifhi,'(a)')       'closehisto plot2d'
2537
2538       write(ifhi,'(a)')      'openhisto'
2539       write(ifhi,'(a,2e11.3)')'xrange',xpar1,xpar2
2540       write(ifhi,'(a,2e11.3)')'yrange',xpar4,xpar5
2541       write(ifhi,'(a)')      'set ityp2d 5'
2542       write(ifhi,'(a,i4)')   'array2d',nbt
2543       do j=1,nbv
2544       do jj=1,nbt
2545       write(ifhi,'(e11.3)') qfl(j,jj)
2546       enddo
2547       enddo
2548       write(ifhi,'(a)')       '  endarray'
2549       write(ifhi,'(a)')       'closehisto plot2d'
2550
2551       write(ifhi,'(a)')      'newpage zone 1 2 1'
2552       write(ifhi,'(a)')      'openhisto'
2553       write(ifhi,'(a,2e11.3)')'xrange',xpar4,xpar5
2554       write(ifhi,'(a)')      'htyp lfu xmod lin ymod lin'
2555       write(ifhi,'(a,i4)')   'array 2'
2556       do j=1,nbv
2557       write(ifhi,'(2e13.5)')v(j),we(j)
2558       enddo
2559       write(ifhi,'(a)')       '  endarray'
2560       write(ifhi,'(a)')       'closehisto plot 0'
2561
2562       write(ifhi,'(a)')      'openhisto'
2563       write(ifhi,'(a,2e11.3)')'xrange',xpar4,xpar5
2564       write(ifhi,'(a)')      'htyp lfu xmod lin ymod lin'
2565       write(ifhi,'(a,i4)')   'array 2'
2566       do j=1,nbv
2567       write(ifhi,'(2e13.5)')v(j),wn(j)
2568       enddo
2569       write(ifhi,'(a)')       '  endarray'
2570       write(ifhi,'(a)')       'closehisto plot 0'
2571
2572
2573         return
2574         end
2575
2576
2577 c------------------------------------------------------------------
2578       subroutine hgcpyi(ist)
2579 c------------------------------------------------------------------
2580 c returns particle yield
2581 c input:
2582 c   tem   : temperature
2583 c   chemgc: chemical potentials
2584 c output:
2585 c   ptlngc: expectation value of particle number for each species
2586 c   rmsngc: standard deviation of ptlngc
2587 c   ptltot: total particle number
2588 c   rmstot: standard deviation of ptltot
2589 c works for hadrons and partons
2590 c  ist=1 boltzmann statistics
2591 c  ist=0 quantum statistics
2592 c--------------------------------------------------------------------
2593       include 'epos.inc'
2594       parameter (mspecs=56)
2595       common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
2596       common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
2597       common/cgctot/rmstot,ptltot
2598       common/camgc/amgc,samgc,amtot
2599       common/ciakt/gen,iafs,ians,genm
2600       external hgcfhw
2601       external hgcfhn
2602
2603        if(iabs(ispecs(nspecs)).lt.10)then
2604
2605 c     parton yield
2606 c     ------------
2607       if(ish.ge.5)write(ifch,*)'parton yield:'
2608       gln=16.*1.20206*tem**3/pi**2*volu/hquer**3
2609       sdg=sqrt(gln)   !!???
2610       if(ish.ge.5)write(ifch,'(1x,a,f10.4,2x,a,f9.4,a)')
2611      *'<N(    0)> :',gln,' sigma :',sdg,' (qm-statistics!)'
2612       ptltot=gln
2613       rmstot=0.0
2614       vartot=gln
2615
2616        else
2617
2618       if(ish.ge.5)write(ifch,*)'hadronic yield:'
2619       ptltot=0.0
2620       rmstot=0.0
2621       vartot=0.0
2622
2623        endif
2624
2625       amgc=0.0
2626       samgc=0.0
2627
2628        do ians=1,nspecs
2629
2630 c     hadronic yield
2631 c     --------------
2632        if(ist.eq.0)then
2633
2634       call hgclim(a,b)
2635       if(b.eq.0.0)then
2636       hden=0.0
2637       else
2638       call uttraq(hgcfhn,a,b,hden)
2639       endif
2640       ptlngc(ians)=hden*volu*gspecs(ians)/2./pi**2/hquer**3
2641
2642        else
2643
2644        if((chemgc(ians)/tem).gt.70.)then
2645       hpd=1.e30
2646        else
2647       hpd=exp(chemgc(ians)/tem)
2648        endif
2649        if(aspecs(ians).ne.0.)then
2650       fk2=hgcbk(2,aspecs(ians)/tem)
2651       hpd=hpd*gspecs(ians)*aspecs(ians)**2*tem*fk2
2652      */2./pi**2/hquer**3
2653        else
2654       hpd=hpd*gspecs(ians)*tem**3/pi**2/hquer**3
2655        endif
2656       ptlngc(ians)=hpd*volu
2657
2658        endif
2659
2660       ptltot=ptltot+ptlngc(ians)
2661       amgc=amgc+ptlngc(ians)*aspecs(ians)
2662       if(amgc.ge.tecm)amgc=tecm*0.9
2663
2664 c     standard deviation
2665 c     ------------------
2666       rmsngc(ians)=0.0
2667
2668        if(ist.eq.0)then
2669
2670       call uttraq(hgcfhw,a,b,var)
2671       var=var*gspecs(ians)*volu/2./pi**2/hquer**3
2672       vartot=vartot+var
2673       if(var.ge.0.0)rmsngc(ians)=sqrt(var)
2674       samgc=samgc+var*aspecs(ians)
2675
2676        else
2677
2678       if(ptlngc(ians).ge.0.0)rmsngc(ians)=sqrt(ptlngc(ians))
2679       vartot=vartot+ptlngc(ians)
2680       samgc=samgc+ptlngc(ians)*aspecs(ians)
2681
2682        endif
2683
2684
2685       if(ish.ge.7)write(ifch,'(2x,a,i5,a,2x,f8.4,5x,a,3x,f8.4)')
2686      *'m(',ispecs(ians),')  :',aspecs(ians),'mu :',chemgc(ians)
2687       if(ish.ge.5)write(ifch,'(1x,a,i5,a,2x,f8.4,2x,a,2x,f10.4)')
2688      *'<N(',ispecs(ians),')> :',ptlngc(ians),'sigma :',rmsngc(ians)
2689
2690        enddo
2691
2692       if(vartot.ge.0.0)rmstot=sqrt(vartot)
2693       if(samgc.ge.0.0)samgc=sqrt(samgc)
2694       if(amgc.ge.tecm)samgc=sqrt(amgc)
2695       if(ish.ge.5)write(ifch,'(1x,a,2x,f8.4,2x,a,2x,f10.4)')
2696      *'<N(  all)> :',ptltot,'sigma :',rmstot
2697       if(ish.ge.5)write(ifch,'(1x,a,2x,f8.4,2x,a,2x,f10.4)')
2698      *'<M_tot>    :',amgc,'sigma :',samgc
2699
2700       return
2701       end
2702
2703 c------------------------------------------------------------------------
2704       subroutine hgctbo(iba)
2705 c------------------------------------------------------------------------
2706 c returns new tem using boltzmann statistics in analytic form
2707 c  input:
2708 c    chemgc
2709 c    tecm/volu
2710 c  output:
2711 c    tem
2712 c----------------------------------------------------------------------
2713       include 'epos.inc'
2714       parameter (mspecs=56)
2715       common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
2716       common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
2717       common/ciakt/gen,iafs,ians,genm
2718       external hgcbk
2719       external hgcbk1
2720       iba=0
2721       k=1
2722       t1=0.0
2723       t2=1.0
2724
2725       goto15
2726
2727 10    tem=t1+.5*(t2-t1)
2728       if(tem.le.1.e-7)return
2729 15    eden=0.0
2730
2731         do i=1,nspecs
2732
2733        if(aspecs(i).ne.0)then
2734       if(tem.ne.0.)arr=aspecs(i)/tem
2735       cba=(aspecs(i)/tem+12.*tem/aspecs(i)-3.*chemgc(i)/aspecs(i))
2736      **hgcbk(2,arr)+(3.-chemgc(i)/tem)*hgcbk1(arr)
2737        else
2738       cba=4.*tem-chemgc(i)
2739        endif
2740
2741       if(cba.lt.0.0)then
2742       iba=1
2743       return
2744       endif
2745
2746       if(tem.ne.0.)x=chemgc(i)/tem
2747
2748        if(x.le.70.)then
2749       y=exp(x)
2750        else
2751       y=1.e30
2752        endif
2753
2754        if(aspecs(i).ne.0.)then
2755       edi=y*(3./arr*hgcbk(2,arr)+hgcbk1(arr))
2756      **gspecs(i)*aspecs(i)**3*tem/2./pi**2/hquer**3
2757        else
2758       edi=y*3.*gspecs(i)*tem**4/pi**2/hquer**3
2759        endif
2760
2761       eden=eden+edi
2762
2763         enddo
2764
2765       if(iabs(ispecs(nspecs)).lt.10)
2766      *eden=eden+(8.*pi**2*tem**4/15.+bag4rt**4)/hquer**3
2767
2768       de=abs(eden-(tecm/volu))
2769       if(de.le.gen*(tecm/volu).or.de.le.genm)return
2770 c     if(eden.ge.100.)return
2771
2772        if(eden.gt.(tecm/volu))then
2773       t2=tem
2774       else
2775       t1=tem
2776        endif
2777
2778        if(k.gt.300)return
2779
2780       k=k+1
2781       goto10
2782       end
2783
2784 c----------------------------------------------------------------------
2785       subroutine hgctex
2786 c----------------------------------------------------------------------
2787 c returns new tem using massive quantum statistics in integral form
2788 c  input:
2789 c    chemgc
2790 c    tecm/volu
2791 c  output:
2792 c    tem
2793 c----------------------------------------------------------------------
2794       include 'epos.inc'
2795       parameter (mspecs=56)
2796       common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
2797       common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
2798       common/ciakt/gen,iafs,ians,genm
2799       external hgcfhe
2800       k=1
2801       t1=0.0
2802       t2=tem+0.1
2803       goto15
2804
2805 c     new temperature
2806 c     ---------------
2807 10    tem=t1+.5*(t2-t1)
2808 15    continue
2809       if(tem.le.1.e-6)return
2810       eden=0.0
2811
2812        do ians=1,nspecs
2813       call hgclim(a,b)
2814       if(b.eq.0.0)then
2815       edi=0.0
2816       else
2817       call uttraq(hgcfhe,a,b,edi)
2818       endif
2819       edi=edi*gspecs(ians)/2./pi**2/hquer**3
2820       eden=eden+edi
2821        enddo
2822
2823       if(iabs(ispecs(nspecs)).lt.10)
2824      *eden=eden+(8.*pi**2*tem**4/15.+bag4rt**4)/hquer**3
2825
2826       de=abs(eden-(tecm/volu))
2827       if(de.le.gen*(tecm/volu).or.de.le.genm)return
2828
2829        if(eden.gt.(tecm/volu))then
2830       t2=tem
2831       else
2832       t1=tem
2833        endif
2834
2835        if(k.gt.300)then
2836        if(ish.ge.5)
2837      *write(ifch,*)'failure in tex'
2838       return
2839        endif
2840
2841       k=k+1
2842       goto10
2843       end
2844
2845 c-----------------------------------------------------------------
2846       subroutine hgctm0
2847 c-----------------------------------------------------------------
2848 c returns new tem using massless quantum statistics in analytic form
2849 c  input:
2850 c    chemgc
2851 c    tecm/volu
2852 c  output:
2853 c    tem
2854 c----------------------------------------------------------------------
2855
2856       include 'epos.inc'
2857       parameter (mspecs=56)
2858       common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
2859       common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
2860       common/ciakt/gen,iafs,ians,genm
2861
2862       k=1
2863
2864       t1=0.0
2865       t2=1.0
2866 10    tem=t1+.5*(t2-t1)
2867       if(tem.le.1.e-6)return
2868       eden=0.0
2869
2870         do i=1,nspecs
2871
2872       igsp=int(gspecs(i))
2873       if(mod(igsp,2).eq.0)then
2874       edhm0=7./240.*pi**2*tem**4+chemgc(i)**2*tem**2/8.
2875      *+chemgc(i)**4/pi**2/16.
2876       else
2877       edhm0=pi**2*tem**4/30.+chemgc(i)**2*tem**2/4.
2878      *-chemgc(i)**4/pi**2/16.
2879       endif
2880       edi=edhm0*gspecs(i)/hquer**3
2881
2882
2883       eden=eden+edi
2884         enddo
2885
2886       if(iabs(ispecs(nspecs)).lt.10)
2887      *eden=eden+(8.*pi**2*tem**4/15.+bag4rt**4)/hquer**3
2888
2889       de=abs(eden-(tecm/volu))
2890       if(de.le.gen*(tecm/volu).or.de.le.genm)return
2891
2892        if(eden.gt.(tecm/volu))then
2893       t2=tem
2894       else
2895       t1=tem
2896        endif
2897
2898        if(k.gt.300)then
2899        if(ish.ge.5)
2900      *write(ifch,*)'failure in tm0'
2901       return
2902        endif
2903
2904       k=k+1
2905       goto10
2906       end
2907
2908 c----------------------------------------------------------------------
2909       subroutine hnbxxx(ip,iret)
2910 c----------------------------------------------------------------------
2911 c  decays droplet very fast ... and hopefully not too badly
2912 c----------------------------------------------------------------------
2913       include 'epos.inc'
2914       integer jc(nflav,2),jc1(nflav,2)
2915       integer ifl(nflav)
2916       double precision p(5),c(5)
2917       real u(3),pin(4),pout(4),poutx(4)
2918       parameter (mspecs=56)
2919       common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
2920        !-------------------------------------------------------------
2921        !   110,  120, -120,  130, -130,  230, -230,  220,  330
2922        !,  111,  121, -121,  131, -131,  231, -231,  221,  331
2923        !, 1120,-1120, 1220,-1220, 1130,-1130, 2130,-2130
2924        !, 1230,-1230, 2230,-2230, 1330,-1330, 2330,-2330
2925        !, 1111,-1111, 1121,-1121, 1221,-1221, 2221,-2221, 1131,-1131
2926        !, 1231,-1231, 2231,-2231, 1331,-1331, 2331,-2331, 3331,-3331
2927        !-------------------------------------------------------------
2928       integer ianti(mspecs)
2929       data ianti/ 1, 3, 2, 5, 4, 7, 6, 8, 9
2930      *          ,10,12,11,14,13,16,15,17,18
2931      *          ,20,19,22,21,24,23,26,25
2932      *          ,28,27,30,29,32,31,34,33
2933      *          ,36,35,38,37,40,39,42,41,44,43
2934      *          ,46,45,48,47,50,49,52,51,54,53,0,0/
2935       common/xxxspecs/wtot,wspecs(mspecs),zspecs(mspecs)
2936       parameter(mxdrop=35,mxe=10)
2937       common/xxxspecsy/ndrop(-4:4,-4:4,-4:4)
2938       common/xxxspecsx/ee(mxe),wwspecs(mxdrop,mxe,mspecs)
2939       common/cspec2/jspecs(2,nflav,mspecs)
2940       common/cspec4/lkfoi(8,-3:3,-3:3,-3:3,-3:3)  !-charm
2941 ctp060829      parameter (mxidh=3331)
2942       real wbar(-1:1)
2943
2944       call utpri('hnbxxx',ish,ishini,4)
2945       iret=0
2946
2947       call idquac(ip,nqi,nsi,nai,jc)
2948       keu=jc(1,1)-jc(1,2)
2949       ked=jc(2,1)-jc(2,2)
2950       kes=jc(3,1)-jc(3,2)
2951       n=ndrop(keu,ked,kes)
2952       if(n.eq.0)stop'hnbxxx: n=0'
2953
2954 c...fill wspecs
2955
2956       e=pptl(5,ip)
2957       k=1
2958       do while(k.lt.mxe.and.ee(k).lt.e)
2959         k=k+1
2960       enddo
2961       k=max(k,2)
2962       xi=(e-ee(k-1))/(ee(k)-ee(k-1))
2963       do i=1,nspecs
2964         ii=i
2965         if(n.lt.0)ii=ianti(i)
2966         w1=wwspecs(abs(n),k-1,ii)
2967         w2=wwspecs(abs(n),k,ii)
2968         wspecs(i)=w1+xi*(w2-w1)
2969       enddo
2970
2971             if(ish.ge.5)then
2972             write(ifch,*)'keu,ked,kes,n:',keu,ked,kes,n
2973             write(ifch,'(9x, 9f6.3)')(wspecs(i),i=1,9)
2974             write(ifch,'(9x, 9f6.3)')(wspecs(i),i=10,18)
2975             write(ifch,'(9x, 8f6.3)')(wspecs(i),i=19,26)
2976             write(ifch,'(9x, 8f6.3)')(wspecs(i),i=27,34)
2977             write(ifch,'(9x,10f6.3)')(wspecs(i),i=35,44)
2978             write(ifch,'(9x,10f6.3)')(wspecs(i),i=45,54)
2979             endif
2980
2981 c...initializations
2982
2983       do j=1,5
2984       c(j)=pptl(j,ip)
2985       enddo
2986       do j=1,4
2987       pin(j)=pptl(j,ip)
2988       pout(j)=0
2989       poutx(j)=0
2990       enddo
2991       wtot=0
2992       do i=1,nspecs
2993        wtot=wtot+wspecs(i)
2994        zspecs(i)=0
2995       enddo
2996       wbar(1)=0
2997       wbar(-1)=0
2998       do i=19,53,2
2999        wbar(1)=wbar(1)+wspecs(i)
3000        wbar(-1)=wbar(-1)+wspecs(i+1)
3001       enddo
3002       wbar(1)=wbar(1)  /wtot
3003       wbar(-1)=wbar(-1)/wtot
3004       w12=0
3005       do i=19,34
3006         w12=w12+wspecs(i)
3007       enddo
3008       w32=0        !35,36,41,42,53,54 excluded
3009       do i=37,40
3010         w32=w32+wspecs(i)
3011       enddo
3012       do i=43,52
3013         w32=w32+wspecs(i)
3014       enddo
3015       sum=w12+w32
3016       w12=w12/sum
3017       w32=w32/sum
3018       w0=0
3019       do i=1,9
3020         w0=w0+wspecs(i)
3021       enddo
3022       w1=0
3023       do i=10,18
3024         w1=w1+wspecs(i)
3025       enddo
3026       sum=w0+w1
3027       w0=w0/sum
3028       w1=w1/sum
3029       nptlb=nptl
3030       call idquac(ip,nq,ns,na,jc)
3031       nbar=nq/3
3032       nbarini=nbar
3033       do nf=1,nflav
3034         ifl(nf)=jc(nf,1)-jc(nf,2)
3035       enddo
3036
3037 c...print
3038
3039            if(ish.ge.5)then
3040            write(ifch,*)'ip=',ip,'  id=',idptl(ip),' e=',sngl(c(5))
3041            write(ifch,*)'jc=',jc
3042            write(ifch,*)'nq=',nq,'  na=',na,'  nbar=',nbar
3043            write(ifch,*)'wtot=',wtot
3044            endif
3045
3046 c...generate number of hadrons
3047
3048       wfac=1.05 !mean increased by factor wfac
3049       aa=wtot*wfac
3050       if(aa.le.70.)then
3051  776    nhad=0
3052         pr=1
3053         sum=1
3054         wfac=1.05 !mean increased by factor wfac
3055         rr=rangen()*exp(aa)
3056         do while (sum.lt.rr)
3057           nhad=nhad+1
3058           if(nhad.gt.10*aa)goto776
3059           pr=pr*aa/nhad
3060           sum=sum+pr
3061             !print*,'r:',rr,'  n:',nhad,'  sum pr:',sum
3062         enddo
3063         nhad=max(2,nhad)
3064       else
3065  778    nhad=aa-30
3066         sum=0
3067         rr=rangen()
3068         do while (sum.lt.rr)
3069           nhad=nhad+1
3070           if(nhad.gt.10*aa)goto778
3071           sum=sum+exp(nhad-aa)*(aa/nhad)**nhad/sqrt(2*pi*nhad)
3072             !print*,'r:',rr,'  n:',nhad,'  sum pr:',sum
3073         enddo
3074         nhad=max(2,nhad)
3075       endif
3076           if(ish.ge.5)write(ifch,*)'-----> ',nhad,' hadrons'
3077
3078 c...generate first n-2 hadrons
3079
3080       do n=1,nhad-2
3081   1     sum=0
3082         i=0
3083         rr=rangen()*wtot
3084         do while (sum.lt.rr)
3085           i=i+1
3086           sum=sum+wspecs(i)
3087         enddo
3088         if(ispecs(i).gt.1000)then
3089           nbari=1
3090         elseif(ispecs(i).lt.-1000)then
3091           nbari=-1
3092         else
3093           nbari=0
3094         endif
3095         if(nbari*nbarini.gt.0
3096      *  .and.nbari*(nbar-nbari).lt.0.and.rangen().gt.wbar(-nbari))then
3097           if(ish.ge.5)
3098      *    write(ifch,*)'-----',nptl,nbar,ispecs(i),wbar(-nbari),rr
3099           goto1
3100         elseif(nbari*(nbar-nbari).lt.0)then
3101             if(ish.ge.5)write(ifch,*)'+++++',wbar(-nbari)
3102         endif
3103         nbar=nbar-nbari
3104         nptl=nptl+1
3105         id=ispecs(i)
3106         idptl(nptl)=id
3107         call idquac(nptl,nq,ns,na,jc1)
3108         do nf=1,nflav
3109          ifl(nf)=ifl(nf)-jc1(nf,1)+jc1(nf,2)
3110         enddo
3111              if(ish.ge.5)
3112      *       write(ifch,*)'nptl=',nptl,'  id=',id,'  ifl=',ifl
3113       enddo
3114       do nf=1,nflav
3115         if(ifl(nf).ge.0)then
3116           jc(nf,1)=ifl(nf)
3117           jc(nf,2)=0
3118         else
3119           jc(nf,1)=0
3120           jc(nf,2)=-ifl(nf)
3121         endif
3122       enddo
3123             if(ish.ge.5)then
3124             write(ifch,*)'jc=',jc
3125             write(ifch,*)'hadrons:',(idptl(n),n=nptlb+1,nptl)
3126      *            ,'  --> nbar=',nbar
3127             endif
3128
3129 c...last two hadrons
3130
3131       if(nbar.ne.0)then
3132         do n=1,abs(nbar)
3133           ii=nbar/abs(nbar)
3134           i1=idraflz(jc,(3-ii)/2)
3135           i2=idraflz(jc,(3-ii)/2)
3136           i3=idraflz(jc,(3-ii)/2)
3137           if(i1.eq.i2.and.i2.eq.i3)then
3138             id=ii*(i1*1000+i2*100+i3*10+1)
3139           else
3140             if(i2.lt.i1)then
3141               ix=i1
3142               i1=i2
3143               i2=ix
3144             endif
3145             if(i3.lt.i2)then
3146               ix=i2
3147               i2=i3
3148               i3=ix
3149             endif
3150             if(i2.lt.i1)then
3151               ix=i1
3152               i1=i2
3153               i2=ix
3154             endif
3155             ispin=0
3156             if(rangen().lt.w32)ispin=1
3157             id=ii*(i1*1000+i2*100+i3*10+ispin)
3158            endif
3159           nptl=nptl+1
3160           idptl(nptl)=id
3161             if(ish.ge.5)
3162      *       write(ifch,*)'nptl=',nptl,'  baryon=',id,'  jc=',jc
3163         enddo
3164       endif
3165
3166       call idquacjc(jc,nqu,naq)
3167       do while (nqu.gt.0.or.nptl.eq.nptlb)
3168         if(nqu.eq.0)then
3169           i1=1.5+rangen()
3170           i2=1.5+rangen()
3171           jc(i1,1)=jc(i1,1)+1
3172           jc(i2,2)=jc(i2,2)+1
3173         else
3174           i1=idraflz(jc,1)
3175           i2=idraflz(jc,2)
3176         endif
3177         ii=1
3178         if(i2.lt.i1)then
3179           ix=i1
3180           i1=i2
3181           i2=ix
3182           ii=-1
3183         endif
3184         ispin=0
3185         if(rangen().lt.w1)ispin=1
3186         id=ii*(i1*100+i2*10+ispin)
3187         nptl=nptl+1
3188         idptl(nptl)=id
3189             if(ish.ge.5)write(ifch,*)'nptl=',nptl,'  nqu=',nqu
3190      &                               ,'  naq=',naq,' --> meson',id
3191         call idquacjc(jc,nqu,naq)
3192       enddo
3193
3194       nmiss=nhad-nptl+nptlb
3195             if(ish.ge.5)then
3196             write(ifch,*)nmiss,' hadron(s) missing'
3197             write(ifch,*)'hadrons:',(idptl(n),n=nptlb+1,nptl)
3198             endif
3199
3200 c            nsechad=lkfoi(1,ifl(1),ifl(2),ifl(3),ifl(4))
3201 c            if(nsechad.gt.0)then
3202 c              i2x=min(nsechad,1+rangen()*nsechad)
3203 c              i2=lkfoi(1+i2x,ifl(1),ifl(2),ifl(3),ifl(4))
3204 c               !print*,'secnd chosen hadron:',ispecs(i2),wzspecs(i2)
3205
3206 c... generate momenta
3207
3208            if(ish.ge.5)write(ifch,*)'hadron momenta:'
3209       do n=nptlb+1,nptl
3210         id=idptl(n)
3211         call idmass(id,am)
3212         !prepare proposal function
3213         ! f_prop:  f0(x)=0,                     x<am
3214         !          f1(x)=const=f2(b),           am<x<b,
3215         !          f2(x)=x**2*exp(7-a*x),       x>b
3216         a=11
3217         b=0.9
3218         b=max(b,am+0.1)
3219         !relative weights ... consider here f1/exp(7), f2/exp(7)
3220         c1=(b-am)*b**2*exp(-a*b)
3221         c2=(b**2/a+2*b/a**2+2/a**3)*exp(-a*b)
3222             if(ish.ge.5)write(ifch,*)'c1 c2:',c1,c2
3223         rrr=1
3224         fff=0
3225         do while(rrr.gt.fff)
3226           !proposal
3227           i=2
3228           if(rangen().lt.c1/(c1+c2))i=1
3229                if(ish.ge.5)write(ifch,*)'i=',i
3230           if(i.eq.1)then
3231             x=am+rangen()*(b-am)
3232             fx=b**2*exp(-a*b)  *exp(7.)
3233           else
3234             r=alog(rangen())
3235             !find root of log((x**2/a+2*x/a**2+2/a**3)*exp(-a*x)/c2)-r
3236             x=20
3237             do k=1,4
3238               f=alog(x**2/a+2*x/a**2+2/a**3)-a*x-alog(c2)-r
3239               fp=(2*x/a+2/a**2)/(x**2/a+2*x/a**2+2/a**3)-a
3240               xb=x
3241               x=x-f/fp
3242                    if(ish.ge.5)write(ifch,*)'k,xb,f,fp,x: ',k,xb,f,fp,x
3243             enddo
3244             fx=x**2*exp(-a*x)   *exp(7.)
3245           endif
3246           !acceptance
3247           rrr=rangen()
3248           if(x.le.2)then
3249             fff=sqrt(x-am)*x*exp(-4*x-1.75*x**2)  /fx
3250           else
3251             fff=sqrt(x-am)*x*exp(7-11*x)          /fx
3252           endif
3253                if(ish.ge.5)write(ifch,*)'fff,rrr',fff,rrr
3254         enddo
3255         e=x
3256         pa=sqrt(e**2-am**2)
3257         u(3)=2.*rangen()-1.
3258         phi=2.*pi*rangen()
3259         u(1)=sqrt(1.-u(3)**2)*cos(phi)
3260         u(2)=sqrt(1.-u(3)**2)*sin(phi)
3261         do j=1,3
3262          pptl(j,n)=pa*u(j)
3263          pout(j)=pout(j)+pptl(j,n)
3264         enddo
3265         pptl(4,n)=e
3266         pptl(5,n)=am
3267         pout(4)=pout(4)+e
3268         if(ish.ge.5)
3269      *  write(ifch,*)pptl(1,n),pptl(2,n),pptl(3,n),pptl(4,n),pptl(5,n)
3270       enddo
3271
3272 c...check total energy ... rescale (maybe)
3273
3274             if(ish.ge.5)then
3275             write(ifch,*)'pout(cms)=',pout
3276             write(ifch,*)'energy_in(cms)=  ',sngl(c(5))
3277             endif
3278
3279 c...boost
3280
3281       do n=nptlb+1,nptl
3282         do j=1,4
3283          p(j)=pptl(j,n)
3284         enddo
3285         call utlob2(-1,c(1),c(2),c(3),c(4),c(5),p(1),p(2),p(3),p(4),10)
3286         do j=1,4
3287          pptl(j,n)=p(j)
3288          poutx(j)=poutx(j)+pptl(j,n)
3289         enddo
3290       enddo
3291            if(ish.ge.5)then
3292            write(ifch,*)'pout(lab)=',poutx
3293            write(ifch,*)'pin(lab)= ',pin
3294            endif
3295       call utprix('hnbxxx',ish,ishini,4)
3296       return
3297       end
3298
3299 c----------------------------------------------------------------------
3300       subroutine hnbxxxini
3301 c----------------------------------------------------------------------
3302       include 'epos.inc'
3303       logical lcalc
3304       parameter (mspecs=56)
3305       common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
3306        !-------------------------------------------------------------
3307        !   110,  120, -120,  130, -130,  230, -230,  220,  330
3308        !,  111,  121, -121,  131, -131,  231, -231,  221,  331
3309        !, 1120,-1120, 1220,-1220, 1130,-1130, 2130,-2130
3310        !, 1230,-1230, 2230,-2230, 1330,-1330, 2330,-2330
3311        !, 1111,-1111, 1121,-1121, 1221,-1221, 2221,-2221, 1131,-1131
3312        !, 1231,-1231, 2231,-2231, 1331,-1331, 2331,-2331, 3331,-3331
3313        !-------------------------------------------------------------
3314       common/xxxspecs/wtot,wspecs(mspecs),zspecs(mspecs)
3315       integer ittspecs(mspecs)
3316       parameter(mxdrop=35,mxe=10)
3317       common/xxxspecsy/ndrop(-4:4,-4:4,-4:4)
3318       common/xxxspecsx/ee(mxe),wwspecs(mxdrop,mxe,mspecs)
3319       inquire(file=fndr(1:nfndr),exist=lcalc)
3320       if(lcalc)then
3321         if(inicnt.eq.1)then
3322           do ku=-4,4
3323             do kd=-4,4
3324               do ks=-4,4
3325                 ndrop(ku,kd,ks)=0
3326               enddo
3327             enddo
3328           enddo
3329           write(ifmt,'(3a)')'read from ',fndr(1:nfndr),' ...'
3330           open(1,file=fndr(1:nfndr),status='old')
3331           read(1,*)mxxdrop
3332           if(mxxdrop.ne.mxdrop)stop'hnbxxxini: wrong nr of droplets'
3333           do n=1,mxdrop
3334             read(1,*)ku,kd,ks
3335             if(abs(ku).gt.4)stop'hnbxxxini: ku out of range'
3336             if(abs(kd).gt.4)stop'hnbxxxini: kd out of range'
3337             if(abs(ks).gt.4)stop'hnbxxxini: ks out of range'
3338             ndrop(ku,kd,ks)=n
3339             ndrop(-ku,-kd,-ks)=-n
3340           enddo
3341           read(1,*)(ittspecs(i),i=1,nspecs)
3342           do i=1,nspecs
3343             if(ittspecs(i).ne.ispecs(i))stop'hnbxxxini: wrong id table'
3344           enddo
3345           read(1,*)ee
3346           do n=1,mxdrop
3347             read(1,*)((wwspecs(n,k,i),i=1,nspecs),k=1,mxe)
3348           enddo
3349           close(1)
3350         endif
3351       else
3352         stop'hnbxxxini: file not found.                 '
3353       endif
3354       end
3355
3356 c----------------------------------------------------------------------
3357       subroutine hnbaaa(ip,iret)
3358 c----------------------------------------------------------------------
3359       include 'epos.inc'
3360       if(ioclude.eq.1)call hnbaaa156(ip,iret)
3361       if(ioclude.eq.2)stop'ioclude.eq.2 no longer supported.    '
3362       if(ioclude.eq.3)call hnbaaanew(ip,iret)
3363       end
3364
3365 c----------------------------------------------------------------------
3366       subroutine hnbaaanew(ip,iret)
3367 c----------------------------------------------------------------------
3368 c  microcanonical decay of cluster ip via loop over hnbmet
3369 c----------------------------------------------------------------------
3370       include 'epos.inc'
3371       include 'epos.inchy'
3372       common/cxyzt/xptl(mxptl),yptl(mxptl),zptl(mxptl),tptl(mxptl)
3373      *,optl(mxptl),uptl(mxptl),sptl(mxptl),rptl(mxptl,3)
3374       parameter(maxp=500)
3375       common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
3376       common/citer/iter,itermx
3377       integer jc(nflav,2)
3378       double precision p(5),c(5)
3379       parameter(maxit=50000)
3380       common/count/nacc,nrej,naccit(maxit),nptot,npit(maxit)
3381       dimension uu(4),pe(5),pa(5)
3382       common/yrad/yrad(maxp),phifop(maxp),radfop(maxp),taufop(maxp)
3383       common/xxxspecsy/ndrop(-4:4,-4:4,-4:4)
3384       common/cdelzet/delzet,delsgr /cvocell/vocell
3385       common/cen/ncentr /ctauhac/ntauhac(ncenthy,netahy)
3386       common/cranphi/ranphi,ranecc,weiecc
3387       character txt*40
3388       data icnthnb /0/ !vv2 /0./ nvv2 /0/  vv3 /0./
3389       !save vv2,nvv2,vv3
3390       save icnthnb
3391
3392       call utpri('hnbaaa',ish,ishini,4)
3393
3394       if(ish.ge.3)then
3395       write(ifch,140)
3396   140 format(/' ----------------------------------'/
3397      *'    droplet decay'/
3398      *' ----------------------------------')
3399       write(ifch,*)'droplet:'
3400       call alist('&',ip,ip)
3401       endif
3402
3403       iret=0
3404       do j=1,5
3405       c(j)=pptl(j,ip)
3406       enddo
3407
3408       call idquac(ip,nqi,nsi,nai,jc)
3409       keu=jc(1,1)-jc(1,2)
3410       ked=jc(2,1)-jc(2,2)
3411       kes=jc(3,1)-jc(3,2)
3412       kec=jc(4,1)-jc(4,2)
3413       keb=jc(5,1)-jc(5,2)
3414       ket=jc(6,1)-jc(6,2)
3415       !print*,'droplet uds=',keu,ked,kes,'   E=',pptl(5,ip)
3416
3417       volu=4./3.*pi*radptl(ip)**3
3418
3419       if(volu.le.0)call utstop('hnbaaa: volume = 0&')
3420       if(volu.lt.0.01)then
3421         call utmsg('hnbaaa')
3422         write(ifch,*)'*****  very small volume:',volu
3423         write(ifch,*)
3424      *  'id:',idptl(ip),' r:',radptl(ip),' m:',pptl(5,ip)
3425         call utmsgf
3426       endif
3427
3428     !~~~~~~~~~read in freeze out surface properties from hydro~~~~~~~~~~~~
3429       if(iorsdf.eq.3.and.ityptl(ip).eq.60)then
3430        icnthnb=icnthnb+1
3431        if(icnthnb.eq.1)then
3432         !here we use epos.iniXXX (like epos.ini1fc)
3433         !instead of the generic filename epos.inihy
3434         open(3,file=fnnx(1:nfnnx)//fnhy(1:nfnhy),status='old',err=99)
3435         read(3,*)txt
3436         read(3,*)maprojx,matargx,engyx,epscrix
3437         if(maprojx.ne.maproj)stop'hnbaaa: maprojx.ne.maproj.       '
3438         if(matargx.ne.matarg)stop'hnbaaanew: matargx.ne.matarg.       '
3439         if(engyx.ne.engy)stop'hnbaaanew: engyx.ne.engy.       '
3440         if(epscrix.ne.epscri(ioclude))then
3441           print*,'hnbaaanew: epscrix.ne.epscri(',ioclude,').       '
3442           stop
3443         endif
3444         read(3,*)ncenthyx,netahyx,ntauhyx,nphihyx,nradhyx
3445         if(ncenthyx.ne.ncenthy)stop'hnbaaanew: ncenthyx.ne.ncenthy.   '
3446         if(netahyx.ne.netahy)stop'hnbaaanew: netahyx.ne.netahy.       '
3447         if(ntauhyx.ne.ntauhy)stop'hnbaaanew: ntauhyx.ne.ntauhy.       '
3448         if(nphihyx.ne.nphihy)stop'hnbaaanew: nphihyx.ne.nphihy.       '
3449         if(nradhyx.ne.nradhy)stop'hnbaaanew: nradhyx.ne.nradhy.       '
3450         read(3,*)ntauhoc
3451         read(3,*)centhy,etahy,phihy,radhy
3452         read(3,*)tauhoc
3453         read(3,*)epsii
3454         read(3,*)rom,yom,wom
3455         close(3)
3456        endif
3457       endif
3458
3459     !~~~~~~~~~define womi yomi romi~~~~~~~~~~~~
3460       if(iorsdf.eq.3.and.icnthnb.eq.1)then
3461        if(ioclude.eq.3)then
3462         do ncent=1,ncenthy
3463          do neta=1,netahy
3464            do ntau=1,ntauhoc(ncent)
3465             do i=1,2
3466                womi(ncent,neta,ntau,i)=wom(ncent,neta,ntau,i)
3467                yomi(ncent,neta,ntau,i)=yom(ncent,neta,ntau,i)
3468                romi(ncent,neta,ntau,i)=rom(ncent,neta,ntau,i)
3469             enddo
3470            enddo
3471          enddo
3472         enddo
3473        elseif(ioclude.eq.2)then
3474          stop'in hnbaaanew: ioclude=2 not supported any more.'
3475        else
3476          stop'in hnbaaa: invalid ioclude.          '
3477        endif
3478       endif
3479
3480     !~~tau partition function paut(ncent,neta,ntau)
3481     !~~phi partition function pauf(ncent,neta,ntau,nphi)
3482       if(iorsdf.eq.3.and.icnthnb.eq.1)then
3483        do ncent=1,ncenthy
3484         do neta=1,netahy
3485          womax=0
3486          ntauhac(ncent,neta)=0
3487          do ntau=1,ntauhoc(ncent)
3488           if(womi(ncent,neta,ntau,1).gt.womax )then
3489            womax=womi(ncent,neta,ntau,1)
3490            ntauhac(ncent,neta)=ntau
3491           endif
3492            !print*,ncent,neta,ntau,ntauhac(ncent,neta)
3493           !. ,    womi(ncent,neta,ntau,1)
3494          enddo
3495          paut(ncent,neta,1)=0
3496          do ntau=2,ntauhac(ncent,neta)
3497            paut(ncent,neta,ntau)=womi(ncent,neta,ntau,1)/womax
3498            !print*,ncent,neta,ntau,paut(ncent,neta,ntau)
3499          enddo
3500          !~~phi~~~~
3501          do ntau=2,ntauhac(ncent,neta)
3502            pauf(ncent,neta,ntau,1)=0
3503            do nphi=2,nphihy
3504             dphi=phihy(nphi)-phihy(nphi-1)
3505             c1=cos(2*phihy(nphi-1))
3506             c2=cos(2*phihy(nphi))
3507             w1=womi(ncent,neta,ntau  ,1)+c1*womi(ncent,neta,ntau  ,2)
3508      .        -womi(ncent,neta,ntau-1,1)-c1*womi(ncent,neta,ntau-1,2)
3509             w2=womi(ncent,neta,ntau  ,1)+c2*womi(ncent,neta,ntau  ,2)
3510      .        -womi(ncent,neta,ntau-1,1)-c2*womi(ncent,neta,ntau-1,2)
3511              pauf(ncent,neta,ntau,nphi)
3512      .        =pauf(ncent,neta,ntau,nphi-1)+0.5*(w1+w2)*dphi
3513            enddo
3514            w=pauf(ncent,neta,ntau,nphihy)
3515            if(w.eq.0.)stop'hnbaaanew: w.eq.0.    '
3516            do nphi=2,nphihy
3517             pauf(ncent,neta,ntau,nphi)=pauf(ncent,neta,ntau,nphi)/w
3518            enddo
3519          enddo
3520         enddo
3521        enddo
3522       endif
3523
3524     !~~~~~~~~~determine ncentr~~~~~~~~~~~~
3525       if(iorsdf.eq.3.and.ityptl(ip).eq.60)then !!!fusion on!!!
3526         ncentr=0
3527         dbmin=1000.
3528         do ncent=1,ncenthy
3529          db=abs(bimevt-centhy(ncent))
3530          if(db.lt.dbmin)then
3531           dbmin=db
3532           ncentr=ncent
3533          endif
3534         enddo
3535         !print*,ncentr,bimevt,centhy(ncentr)
3536       endif
3537
3538     !~~~~~define masses~~~~~~~~~~~~~~~~
3539       amin=utamnu(keu,ked,kes,kec,keb,ket,5)
3540       aumin=amuseg
3541       ipo=ip
3542       if(ityptl(ip).eq.60)ipo=iorptl(ip)
3543       tecmor=pptl(5,ipo)
3544       tecm=pptl(5,ip)
3545       tecmxx=tecm
3546
3547     !~~~~~~~~~determine netar~~~~~~~~~~~~
3548       if(iorsdf.eq.3.and.ityptl(ip).eq.60)then
3549        z=xorptl(3,ipo)
3550        t=xorptl(4,ipo)
3551        !print*,z,t,ityptl(ip),tecm
3552        if(t+z.le.0..or.t-z.le.0.)then
3553          zetaor=1000.
3554        else
3555          zetaor=abs(0.5*log((t+z)/(t-z)))
3556        endif
3557        netar=0
3558        detamin=1000.
3559        do neta=1,netahy
3560         deta=abs(zetaor-etahy(neta))
3561         if(deta.lt.detamin)then
3562          detamin=deta
3563          netar=neta
3564         endif
3565        enddo
3566        !print*,netar,zetaor,etahy(netar)
3567       endif
3568
3569       fradflo=1.
3570
3571     !~~~~~redefine energy in case of radial flow~~~~~~~~~~~~~~~~
3572       if(iappl.ne.4.and.iorsdf.eq.3.and.tecmor.gt.aumin
3573      ..and.ityptl(ip).eq.60)then
3574        am=0.
3575        do ntau=2,ntauhac(ncentr,netar)
3576         d=paut(ncentr,netar,ntau)-paut(ncentr,netar,ntau-1)
3577         am=am+d
3578        enddo
3579        en=0.
3580        do ntau=2,ntauhac(ncentr,netar)
3581           d=paut(ncentr,netar,ntau)-paut(ncentr,netar,ntau-1)
3582           y=( yomi(ncentr,netar,ntau-1,1)
3583      .       +yomi(ncentr,netar,ntau,1)) / 2
3584           en=en+d*cosh(y)
3585        enddo
3586        fradflo=1.
3587        if(en.ne.0.)fradflo=am/en
3588        if(tecm*fradflo.lt.amin)fradflo=1.
3589       endif
3590       tecm=tecm*fradflo
3591
3592     !~~~~~redefine energy in case of long coll flow
3593       if(iappl.eq.4.or.iorsdf.ne.3
3594      &.or.ityptl(ip).eq.40.or.ityptl(ip).eq.50)then !not for droplets from remnants
3595         yco=0
3596       else
3597        if(ylongmx.lt.0.)then
3598         yco=delzet * 1.75
3599        else
3600         yco=ylongmx
3601        endif
3602       endif
3603       tecmx=tecm
3604       if(yco.gt.0..and.tecmor.gt.aumin) then
3605         tecm=tecm/sinh(yco)*yco
3606       else
3607         yco=0.
3608       endif
3609       !print*,'========= cluster energy: ',pptl(5,ip),tecmx,tecm
3610
3611     !~~~~~~~~~redefine volume~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
3612
3613       vocri=tecm/epscri(ioclude)
3614       volu=max(vocri,vocell)
3615
3616     !~~~~~~~~~decay~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
3617       call hnbini(iret)
3618       !if(iret.ne.0)write(ifch,*)'***** unsucessfull hnbini *****'
3619       if(iret.ne.0)goto1000
3620       if(ioinct.ge.1)goto1
3621
3622       do iter=1,itermx
3623         naccit(iter)=0
3624         call hnbmet
3625       enddo
3626
3627 1     continue
3628
3629       if(ioceau.eq.1.and.iappl.eq.1)call xhnbte(ip)
3630
3631     !~~~~~~~~~~long coll flow -> particles~~~~~~~~~~~~~~~~
3632       if(yco.gt.0.) then
3633         errlim=0.0001
3634         tecm=tecmx
3635  611    energ=0.
3636         do i=1,np
3637           yrad(i)=(2*rangen()-1)*yco
3638           uu(3)=sinh(yrad(i))
3639           uu(4)=cosh(yrad(i))
3640           energ=energ+uu(4)*pcm(4,i)+uu(3)*pcm(3,i)
3641         enddo
3642         if(abs(energ-tecm).gt.0.1) goto 611
3643         !print*,'===== energy after flow boosts',energ,'   soll: ',tecm
3644         do j=1,4
3645           pe(j)=0.
3646         enddo
3647         do i=1,np
3648           uu(1)= 0
3649           uu(2)= 0
3650           uu(3)= sinh(yrad(i))
3651           uu(4)= cosh(yrad(i))
3652           call utlob3(-1,uu(1),uu(2),uu(3),uu(4),1e0
3653      *         , pcm(1,i), pcm(2,i), pcm(3,i), pcm(4,i))
3654           do j=1,4
3655           pe(j)=pe(j)+pcm(j,i)
3656           enddo
3657         enddo
3658         pe(5)=sqrt(pe(4)**2-pe(3)**2-pe(2)**2-pe(1)**2)
3659         !write(6,'(a,5e11.3)')'flow boosts',pe
3660         do j=1,4
3661           pa(j)=0.
3662         enddo
3663         do i=1,np
3664           call utlob3(1,pe(1),pe(2),pe(3),pe(4),pe(5)
3665      *         , pcm(1,i), pcm(2,i), pcm(3,i), pcm(4,i))
3666           do j=1,4
3667             pa(j)=pa(j)+pcm(j,i)
3668           enddo
3669         enddo
3670         pa(5)=sqrt(pa(4)**2-pa(3)**2-pa(2)**2-pa(1)**2)
3671         !write(6,'(a,5e11.3)')' cms boost ',pa
3672         esoll=tecm
3673         scal=1.
3674         do ipass=1,200
3675           sum=0.
3676           do  j=1,np
3677             do k=1,3
3678               pcm(k,j)=scal*pcm(k,j)
3679             enddo
3680             pcm(4,j)=sqrt(pcm(1,j)**2+pcm(2,j)**2+pcm(3,j)**2
3681      *           +amass(j)**2)
3682             sum=sum+pcm(4,j)
3683           enddo
3684           scal=esoll/sum
3685           !write(6,*)'ipass,scal,e,esoll:'
3686           !    $         ,ipass,scal,sum,esoll
3687           if(abs(scal-1.).le.errlim) goto301
3688         enddo
3689  301    continue
3690         do j=1,4
3691           pa(j)=0.
3692         enddo
3693         do i=1,np
3694           do j=1,4
3695             pa(j)=pa(j)+pcm(j,i)
3696           enddo
3697         enddo
3698         pa(5)=sqrt(pa(4)**2-pa(3)**2-pa(2)**2-pa(1)**2)
3699         !write(6,'(a,5e11.3)')' rescaling ',pa
3700       endif
3701
3702     !~~~~~~~~~~radial flow -> particles~~~~~~~~~~~~~~~~~~
3703       if(fradflo.lt.1.) then
3704         aa=1
3705         bb=0
3706         cc=0
3707         dd=1
3708         if(ityptl(ip).eq.60)then
3709           ipo=iorptl(ip)
3710           xx=uptl(ipo)   ! <x**2>
3711           yy=optl(ipo)   ! <y**2>
3712           xy=desptl(ipo) ! <x*y>
3713           dta=0.5*abs(xx-yy)
3714           ev1=(xx+yy)/2+sqrt(dta**2+xy**2)
3715           ev2=(xx+yy)/2-sqrt(dta**2+xy**2)
3716           !if(xy.lt.0..and.dta.ne.0.)then
3717           !  phiclu=0.5*atan(-xy/dta)
3718           !elseif(xy.gt.0..and.dta.ne.0.)then
3719           !  phiclu=-0.5*atan(xy/dta)
3720           !else
3721           !  phiclu=0
3722           !endif
3723           yy=ev1
3724           xx=ev2
3725               ecc=(yy-xx)/(yy+xx)
3726         endif
3727         errlim=0.0001
3728         tecm=tecmxx
3729         phinull=phievt+ranphi
3730         do n=1,np
3731           !~~determine random tau from paut(ncentr,netar,ntau)
3732           r=rangen()
3733           ntau=1
3734           do while(paut(ncentr,netar,ntau).lt.r)
3735            ntau=ntau+1
3736           enddo
3737           if(ntau.eq.1)ntau=2
3738           ntau1=ntau-1
3739           ntau2=ntau
3740           tau1=tauhoc(ncentr,ntau1)
3741           tau2=tauhoc(ncentr,ntau2)
3742           f1=paut(ncentr,netar,ntau1)-r
3743           f2=paut(ncentr,netar,ntau2)-r
3744           f=f1/(f1-f2)
3745           fx=f
3746           tau= tau1*(1-f) + tau2*f
3747           taufop(n)=tau
3748           !~~determine phifop~~~~~
3749           r=rangen()
3750           if(pauf(ncentr,netar,ntau-1,nphihy).gt.0.
3751      .    .and.pauf(ncentr,netar,ntau,nphihy).gt.0.)then
3752             nphi=1
3753             do while((pauf(ncentr,netar,ntau1,nphi)*(1-fx)
3754      .               + pauf(ncentr,netar,ntau2,nphi)*fx)   .lt.r)
3755              nphi=nphi+1
3756             enddo
3757             if(nphi.eq.1)nphi=2
3758             nphi1=nphi-1
3759             nphi2=nphi
3760             phi1=phihy(nphi1)
3761             phi2=phihy(nphi2)
3762             f1=pauf(ncentr,netar,ntau,nphi1)-r
3763             f2=pauf(ncentr,netar,ntau,nphi2)-r
3764             f=f1/(f1-f2)
3765             phi=phi1+f*(phi2-phi1)
3766           else
3767             phi=rangen()*pi/2.
3768           endif
3769           if(px.ge.0..and.py.ge.0.)then
3770            continue
3771           elseif(px.lt.0..and.py.gt.0.)then
3772            phi=pi-phi
3773           elseif(px.lt.0..and.py.lt.0.)then
3774            phi=pi+phi
3775           elseif(px.gt.0..and.py.lt.0.)then
3776            phi=2*pi-phi
3777           endif
3778           phifop(n)=phi
3779           !~~determine yrad~~~~
3780            yr1=yomi(ncentr,netar,ntau1,1)
3781      .        +yomi(ncentr,netar,ntau1,2)*cos(2*phi)
3782            yr2=yomi(ncentr,netar,ntau2,1)
3783      .        +yomi(ncentr,netar,ntau2,2)*cos(2*phi)
3784           yr= yr1*(1-fx)+ fx*yr2
3785           yrad(n)=yr
3786          !~~determine radfop~~~~
3787           rad1=romi(ncentr,netar,ntau1,1)
3788      .        +romi(ncentr,netar,ntau1,2)*cos(2*phi)
3789           rad2=romi(ncentr,netar,ntau2,1)
3790      .        +romi(ncentr,netar,ntau2,2)*cos(2*phi)
3791           rad= rad1*(1-fx) + fx*rad2
3792           radfop(n)=rad
3793         enddo
3794         energ=0.
3795         do n=1,np
3796           uu(1)=sinh(yrad(n))*cos(phifop(n)+phinull)
3797           uu(2)=sinh(yrad(n))*sin(phifop(n)+phinull)
3798           uu(3)=0d0
3799           uu(4)=sqrt(1+uu(1)**2+uu(2)**2)
3800           !px=pcm(1,n)
3801           !py=pcm(2,n)
3802           !vv2=vv2+(px**2-py**2)/(px**2+py**2)
3803           call utlob3(-1,uu(1),uu(2),uu(3),uu(4),1e0
3804      *         , pcm(1,n), pcm(2,n), pcm(3,n), pcm(4,n))
3805           energ=energ+pcm(4,n)
3806         !?????????????????????????????????????????????????
3807         !  px=pcm(1,n)
3808         !  py=pcm(2,n)
3809         !  vv3=vv3+(px**2-py**2)/(px**2+py**2)
3810         !  nvv2=nvv2+1
3811         !  if(mod(nvv2,100).eq.0)
3812         !.   print*,'++++',nvv2,vv2/nvv2,vv3/nvv2
3813         !?????????????????????????????????????????????????
3814         enddo
3815         esoll=tecm
3816         scal=1.
3817         do ipass=1,200
3818           sum=0.
3819           do  j=1,np
3820             do k=1,3
3821               pcm(k,j)=scal*pcm(k,j)
3822             enddo
3823             pcm(4,j)=sqrt(pcm(1,j)**2+pcm(2,j)**2+pcm(3,j)**2
3824      *           +amass(j)**2)
3825             sum=sum+pcm(4,j)
3826           enddo
3827           scal=esoll/sum
3828           !write(6,*)'ipass,scal,e,esoll:'
3829           ! $         ,ipass,scal,sum,esoll
3830           if(abs(scal-1.).le.errlim) goto300
3831         enddo
3832  300    continue
3833         !print*, scal
3834       else
3835         do n=1,np
3836           yrad(n)=0.
3837           phifop(n)=0.
3838           radfop(n)=0.
3839           taufop(n)=0.
3840         enddo
3841       endif
3842     !~~~~~~~~~~~~~~~
3843
3844       nptlb=nptl
3845       do n=1,np
3846         nptl=nptl+1
3847         if(nptl.gt.mxptl)call utstop('hnbptl: mxptl too small&')
3848         idptl(nptl)=ident(n)
3849         do j=1,4
3850           p(j)=pcm(j,n)
3851         enddo
3852         p(5)=amass(n)
3853         call utlob2(-1,c(1),c(2),c(3),c(4),c(5),p(1),p(2),p(3),p(4),10)
3854         do j=1,5
3855           pptl(j,nptl)=p(j)
3856         enddo
3857         if(fradflo.lt.1.) then
3858           ityptl(nptl)=60
3859         else
3860           ityptl(nptl)=19
3861         endif
3862         if(ityptl(ip).eq.60)then
3863          if(ityptl(nptl).eq.60)then
3864           ipo=iorptl(ip)
3865           yr=yrad(n)
3866           phi=phifop(n)
3867           tau=taufop(n)
3868           r=radfop(n)
3869           !---add r-randomness
3870           !dr=5
3871           !do while(dr.lt.-2.or.dr.gt.2.)
3872           ! dr=sqrt(3.)*(rangen()+rangen()+rangen()+rangen()-2)
3873           !enddo
3874           !r=r+dr
3875           zeta=0.5*log((p(4)+p(3))/(p(4)-p(3)))
3876           !deleta=etahy(2)-etahy(1)
3877           !zeta=zetaor-0.5*delzet+delzet*rangen()
3878           z=tau*sinh(zeta)
3879           t=tau*cosh(zeta)
3880           xorptl(1,nptl)=r*cos(phifop(n)+phinull)
3881           xorptl(2,nptl)=r*sin(phifop(n)+phinull)
3882           xorptl(3,nptl)=z
3883           xorptl(4,nptl)=t
3884          else
3885           xorptl(1,nptl)=xorptl(1,ip)
3886           xorptl(2,nptl)=xorptl(2,ip)
3887           xorptl(3,nptl)=xorptl(3,ip)
3888           xorptl(4,nptl)=xorptl(4,ip)
3889          endif
3890         endif
3891       enddo
3892       if(ish.ge.3)then
3893         write(ifch,*)'decay products:'
3894         call alist('&',nptlb+1,nptl)
3895         if(ish.ge.5)then
3896           write(ifch,*)'momentum sum:'
3897           do kk=1,5
3898           pptl(kk,nptl+1)=0
3899           do ii=nptlb+1,nptl
3900           pptl(kk,nptl+1)=pptl(kk,nptl+1)+pptl(kk,ii)
3901           enddo
3902           pptl(kk,nptl+2)=c(kk)
3903           enddo
3904           call alist('&',nptl+1,nptl+2)
3905         endif
3906       endif
3907
3908  1000 continue
3909
3910       call utprix('hnbaaa',ish,ishini,4)
3911       return
3912
3913    99 print*,'hnbaaanew: error opening hydro table'
3914       print*,'          file=',fnnx(1:nfnnx)//fnhy(1:nfnhy)
3915       print*,'maybe "fname inihy  ..." forgotten in optns file ???'
3916       print*,'    this is necessary in case of "set ioclude 3"'
3917       stop'070817'
3918
3919       end
3920
3921 c------------------------------------------------------------------------------
3922       subroutine xSpaceTime
3923 c------------------------------------------------------------------------------
3924       include 'epos.inc'
3925       if(iSpaceTime.eq.1.and.ioclude.gt.1)then
3926          call xCoreCorona(0,0)
3927          do neta=1,5,2
3928            call xFoMass(neta)
3929            call xFoRadius(neta)
3930            call xFoRadRapidity(neta)
3931            call xFreezeOutTauX(neta)
3932          enddo
3933          call xFreezeOutTauEta
3934          call xFreezeOutTZ
3935       elseif(iSpaceTime.eq.1)then
3936          call xCoreCorona(0,0)
3937          !stop'bjinta: space-time plots require ioclude>1.          '
3938       endif
3939       end
3940
3941 c------------------------------------------------------------------------------
3942       subroutine xFreezeOutTauX(neta)
3943 c------------------------------------------------------------------------------
3944       include 'epos.inc'
3945       include 'epos.inchy'
3946       common/cxyzt/xptl(mxptl),yptl(mxptl),zptl(mxptl),tptl(mxptl)
3947      *,optl(mxptl),uptl(mxptl),sptl(mxptl),rptl(mxptl,3)
3948       common/cen/ncentr /ctauhac/ntauhac(ncenthy,netahy)
3949       character *8 cbim,cbimhy
3950       call centrality(bimevt        ,cbim)
3951       call centrality(centhy(ncentr),cbimhy)
3952     !..........................................................................
3953       nhis=1
3954       npl=0
3955       nplx=0
3956       deleta=etahy(2)-etahy(1)
3957       eta1=etahy(neta)-deleta/2
3958       eta2=etahy(neta)+deleta/2
3959       etaav=etahy(neta)
3960       taumax=tauhoc(ncentr,ntauhac(ncentr,neta))+4
3961       do n=1,nptl
3962         if(ityptl(n).eq.60
3963      * .and.istptl(n).ne.12.and.istptl(n).ne.11)then
3964          if(istptl(iorptl(n)).eq.11)then
3965           tau=0
3966           tau2=xorptl(4,n)**2-xorptl(3,n)**2
3967           if(tau2.gt.0.)tau=sqrt(tau2)
3968           if(tau.lt.taumax)then
3969            rap=
3970      *     .5*alog((xorptl(4,n)+xorptl(3,n))/(xorptl(4,n)-xorptl(3,n)))
3971            if(rap.ge.eta1.and.rap.le.eta2)then
3972            if(abs(xorptl(2,n)).le.2)then
3973             npl=npl+1
3974             nplx=nplx+1
3975             if(npl.eq.1)then
3976               if(nplx.gt.1)
3977      *        write(ifhi,'(a)')       '  endarray closehisto plot 0-'
3978               write(ifhi,'(a)')       '!-------------------------------'
3979               write(ifhi,'(a)')       '!   tau-x      '
3980               write(ifhi,'(a)')       '!-------------------------------'
3981               write(ifhi,'(a)')       '!newpage'
3982               write(ifhi,'(a,i1)')    'openhisto name t-r-0-',nhis
3983               write(ifhi,'(a)')       'htyp prl xmod lin ymod lin'
3984               write(ifhi,'(a)')       'xrange -10 10'
3985               write(ifhi,'(a,f5.1)')  'yrange 0 ',taumax
3986               write(ifhi,'(a)')       'txt  "xaxis x (fm)"'
3987               write(ifhi,'(a)')       'txt  "yaxis [t] (fm/c)"'
3988               write(ifhi,'(a,f4.1,a)')'text 0.55 0.90 "[c]=',etaav,'"'
3989               write(ifhi,'(a)')    'text 0.02 0.90 ""-2fm"L#y"L#2fm""'
3990            write(ifhi,'(a,f4.1,a,f4.1,a)')'text 0.77 0.92 "'//cbim//'"'
3991               write(ifhi,'(a)')       'array 2'
3992             endif
3993             write(ifhi,'(2e11.3)')xorptl(1,n),tau
3994             if(npl.eq.1000)then
3995               nhis=nhis+1
3996               npl=0
3997             endif
3998            endif
3999            endif
4000           endif
4001          endif
4002         endif
4003       enddo
4004       if(nplx.gt.0)write(ifhi,'(a)')  '  endarray closehisto plot 0-'
4005     !..........................................................................
4006        nhis=1
4007       npl=0
4008       nplx=0
4009       npli=20
4010       do n=1,nptl
4011         if(dezptl(n).lt.1e3.and.n.le.maxfra
4012      *  .and.(istptl(n).eq.0.or.istptl(n).eq.1))then
4013            rap=1e10
4014            xp=tptl(n)+zptl(n)
4015            xm=tptl(n)-zptl(n)
4016            if(xp.gt.0.0.and.xm.gt.0.0)rap=.5*alog(xp/xm)
4017            if(rap.ge.-0.5.and.rap.le.0.5)then
4018            if(abs(xorptl(2,n)).le.2)then
4019             npl=npl+npli
4020             nplx=nplx+1
4021             if(npl.eq.npli)then
4022               if(nplx.gt.1)
4023      *        write(ifhi,'(a)')       '  endarray closehisto plot 0-'
4024               write(ifhi,'(a)')       '!-------------------------------'
4025               write(ifhi,'(a)')       '!   tau-x    corona  '
4026               write(ifhi,'(a)')       '!-------------------------------'
4027               write(ifhi,'(a,i1)')    'openhisto name t-r-0-cor-',nhis
4028               write(ifhi,'(a)')       'htyp pgl '
4029               write(ifhi,'(a)')       'array 2'
4030             endif
4031             x=xorptl(1,n)
4032             y=xorptl(2,n)
4033             z=xorptl(3,n)
4034             t=xorptl(4,n)
4035             tau=0
4036             tau2=t**2-z**2
4037             if(tau2.gt.0.)tau=sqrt(tau2)
4038             if(abs(y).le.2)
4039      .      write(ifhi,'(2e11.3)')x,tau
4040             dt=0.1
4041             do k=1,npli-1
4042             x=x+pptl(1,n)/pptl(4,n)*dt
4043             y=y+pptl(2,n)/pptl(4,n)*dt
4044             z=z+pptl(3,n)/pptl(4,n)*dt
4045             t=t+dt
4046             tau=0
4047             tau2=t**2-z**2
4048             if(tau2.gt.0.)tau=sqrt(tau2)
4049             if(abs(y).le.2)
4050      .            write(ifhi,'(2e11.3)')x,tau
4051             enddo
4052             if(npl.eq.1000)then
4053               nhis=nhis+1
4054               npl=0
4055             endif
4056            endif
4057            endif
4058         endif
4059       enddo
4060       write(ifhi,'(a)')  '  endarray closehisto plot 0'
4061     !..........................................................................
4062        end
4063
4064 c------------------------------------------------------------------------------
4065       subroutine xFreezeOutTauEta
4066 c------------------------------------------------------------------------------
4067       include 'epos.inc'
4068       include 'epos.inchy'
4069       common/cxyzt/xptl(mxptl),yptl(mxptl),zptl(mxptl),tptl(mxptl)
4070      *,optl(mxptl),uptl(mxptl),sptl(mxptl),rptl(mxptl,3)
4071       character *8 cbim,cbimhy
4072       common/cen/ncentr /ctauhac/ntauhac(ncenthy,netahy)
4073       call centrality(bimevt        ,cbim)
4074       call centrality(centhy(ncentr),cbimhy)
4075       taumax=tauhoc(ncentr,ntauhac(ncentr,1))+4
4076     !..........................................................................
4077       nhis=1
4078       npl=0
4079       do n=1,nptl
4080         if(ityptl(n).eq.60
4081      * .and.istptl(n).ne.12.and.istptl(n).ne.11)then
4082          if(istptl(iorptl(n)).eq.11)then
4083           tau=0
4084           tau2=xorptl(4,n)**2-xorptl(3,n)**2
4085           if(tau2.gt.0.)tau=sqrt(tau2)
4086           if(tau.lt.taumax)then
4087             npl=npl+1
4088             if(npl.eq.1)then
4089               write(ifhi,'(a)')      '!-------------------------------'
4090               write(ifhi,'(a)')      '!   tau-eta      '
4091               write(ifhi,'(a)')      '!-------------------------------'
4092               write(ifhi,'(a)')      '!newpage'
4093               write(ifhi,'(a,i1)')   'openhisto name t-eta-',nhis
4094               write(ifhi,'(a)')      'htyp prl xmod lin ymod lin'
4095               write(ifhi,'(a)')      'xrange -4 4'
4096               write(ifhi,'(a,f5.1)')  'yrange 0 ',taumax
4097               write(ifhi,'(a)')    'txt  "xaxis [c] "'
4098               write(ifhi,'(a)')    'txt  "yaxis [t] (fm/c)"'
4099       write(ifhi,'(a,f4.1,a,f4.1,a)')'text 0.77 0.92 "'//cbim//'"'
4100               write(ifhi,'(a)')       'array 2'
4101             endif
4102             eta=
4103      *     .5*alog((xorptl(4,n)+xorptl(3,n))/(xorptl(4,n)-xorptl(3,n)))
4104             write(ifhi,'(2e11.3)') eta,tau
4105             if(npl.eq.1000)then
4106               write(ifhi,'(a)')    '  endarray closehisto plot 0-'
4107               nhis=nhis+1
4108               npl=0
4109             endif
4110           endif
4111          endif
4112         endif
4113       enddo
4114       if(npl.ne.0)write(ifhi,'(a)')  '  endarray closehisto plot 0'
4115       if(npl.eq.0)stop'xFreezeOutTZ: no particles!!!!!            '
4116       end
4117
4118 c------------------------------------------------------------------------------
4119       subroutine xFreezeOutTZ
4120 c------------------------------------------------------------------------------
4121       include 'epos.inc'
4122       include 'epos.inchy'
4123       common/cxyzt/xptl(mxptl),yptl(mxptl),zptl(mxptl),tptl(mxptl)
4124      *,optl(mxptl),uptl(mxptl),sptl(mxptl),rptl(mxptl,3)
4125       character *8 cbim,cbimhy
4126       common/cen/ncentr
4127       call centrality(bimevt        ,cbim)
4128       call centrality(centhy(ncentr),cbimhy)
4129     !..........................................................................
4130       nhis=1
4131       npl=0
4132       do n=1,nptl
4133         if(ityptl(n).eq.60
4134      * .and.istptl(n).ne.12.and.istptl(n).ne.11)then
4135          if(istptl(iorptl(n)).eq.11)then
4136             npl=npl+1
4137             if(npl.eq.1)then
4138               write(ifhi,'(a)')      '!-------------------------------'
4139               write(ifhi,'(a)')      '!   t-z      '
4140               write(ifhi,'(a)')      '!-------------------------------'
4141               write(ifhi,'(a)')      '!newpage'
4142               write(ifhi,'(a,i1)')   'openhisto name t-z-',nhis
4143               write(ifhi,'(a)')      'htyp prl xmod lin ymod lin'
4144               write(ifhi,'(a)')      'xrange -25 25'
4145               write(ifhi,'(a)')      'yrange 0 25 '
4146               write(ifhi,'(a)')    'txt  "xaxis z (fm)"'
4147               write(ifhi,'(a)')    'txt  "yaxis t (fm/c)"'
4148       write(ifhi,'(a,f4.1,a,f4.1,a)')'text 0.75 0.22 "'//cbim//'"'
4149               write(ifhi,'(a)')       'array 2'
4150             endif
4151             write(ifhi,'(2e11.3)') xorptl(3,n),xorptl(4,n)
4152             if(npl.eq.1000)then
4153               write(ifhi,'(a)')    '  endarray closehisto plot 0-'
4154               nhis=nhis+1
4155               npl=0
4156             endif
4157          endif
4158         endif
4159       enddo
4160       if(npl.ne.0)write(ifhi,'(a)')  '  endarray closehisto plot 0'
4161       if(npl.eq.0)stop'xFreezeOutTZ: no particles!!!!!            '
4162       end
4163
4164 c------------------------------------------------------------------------------
4165       subroutine xFoMass(neta)
4166 c------------------------------------------------------------------------------
4167       include 'epos.inc'
4168       include 'epos.inchy'
4169       common/cen/ncentr /ctauhac/ntauhac(ncenthy,netahy)
4170       character *8 cbim
4171       call centrality(bimevt        ,cbim)
4172       taumax=tauhoc(ncentr,ntauhac(ncentr,neta))+2
4173       netahyxx=netahy
4174       write(ifhi,'(a)')    '!----------------------------------------'
4175       write(ifhi,'(a,i3)') '!   hydro freeze out w_0 w_2     '
4176       write(ifhi,'(a)')    '!----------------------------------------'
4177       write(ifhi,'(a)')       '!newpage'
4178       do ii=1,2
4179         write(ifhi,'(a,3i1)')'openhisto htyp lin name w-',neta,nn,ii
4180         if(ii.eq.1)then !----------------------
4181          write(ifhi,'(a,f4.1)')'xmod lin xrange 0. ',taumax
4182          write(ifhi,'(a)')    'txt  "xaxis [t] (fm/c)"'
4183          write(ifhi,'(a)') 'ymod lin yrange auto auto '
4184          write(ifhi,'(a,f4.2,a)') 'text 0.1 0.9 "  [c]=',etahy(neta),'"'
4185          write(ifhi,'(a)')'txt "yaxis w?0!  w?2!  (GeVc/fm) "'
4186          write(ifhi,'(a,f4.1,a,f4.1,a)')'text 0.50 0.9 "'//cbim//'  "'
4187         endif       !-------------------------------
4188         write(ifhi,'(a)')'array 2'
4189         deltau=tauhoc(ncentr,2)-tauhoc(ncentr,1)
4190         do ntau=2,ntauhac(ncentr,neta)
4191          dy=(wom(ncentr,neta,ntau,ii)-wom(ncentr,neta,ntau-1,ii))
4192          write(ifhi,'(2e13.5)')tauhoc(ncentr,ntau)-deltau/2,dy
4193         enddo
4194         write(ifhi,'(a)') 'endarray closehisto '
4195         if(ii.ne.2)write(ifhi,'(a)') 'plot 0-'
4196         if(ii.eq.2)write(ifhi,'(a)') 'plot 0'
4197       enddo
4198       end
4199
4200 c------------------------------------------------------------------------------
4201       subroutine xFoRadius(neta)
4202 c------------------------------------------------------------------------------
4203       include 'epos.inc'
4204       include 'epos.inchy'
4205       common/cen/ncentr /ctauhac/ntauhac(ncenthy,netahy)
4206       character *8 cbim
4207       call centrality(bimevt        ,cbim)
4208       taumax=tauhoc(ncentr,ntauhac(ncentr,neta))+2
4209       netahyxx=netahy
4210       write(ifhi,'(a)')    '!----------------------------------------'
4211       write(ifhi,'(a,i3)') '!        hydro freeze out r_0 r_2     '
4212       write(ifhi,'(a)')    '!----------------------------------------'
4213       write(ifhi,'(a)')    '!newpage'
4214       do ii=1,2
4215         write(ifhi,'(a,3i1)')'openhisto htyp lin name r-',neta,nn,ii
4216         if(ii.eq.1)then !----------------------
4217          write(ifhi,'(a,f4.1)')'xmod lin xrange 0. ',taumax
4218          write(ifhi,'(a)')'txt  "xaxis [t] (fm/c)"'
4219          write(ifhi,'(a)') 'ymod lin yrange auto auto '
4220          write(ifhi,'(a,f4.2,a)')'text 0.1 0.9 "   [c]=',etahy(neta),'"'
4221          write(ifhi,'(a)')'txt "yaxis r?0!  r?2!  (fm) "'
4222          write(ifhi,'(a,f4.1,a,f4.1,a)')'text 0.50 0.9 "'//cbim//'  "'
4223         endif !-------------------------------
4224         write(ifhi,'(a)')'array 2'
4225         do ntau=2,ntauhac(ncentr,neta)
4226          write(ifhi,'(2e13.5)')tauhoc(ncentr,ntau)
4227      .     ,romi(ncentr,neta,ntau,ii)
4228          enddo
4229         write(ifhi,'(a)') 'endarray closehisto '
4230         if(ii.ne.2)write(ifhi,'(a)') 'plot 0-'
4231         if(ii.eq.2)write(ifhi,'(a)') 'plot 0'
4232       enddo
4233       end
4234
4235 c------------------------------------------------------------------------------
4236       subroutine xFoRadRapidity(neta)
4237 c------------------------------------------------------------------------------
4238       include 'epos.inc'
4239       include 'epos.inchy'
4240       common/cen/ncentr /ctauhac/ntauhac(ncenthy,netahy)
4241       character *8 cbim
4242       call centrality(bimevt        ,cbim)
4243       taumax=tauhoc(ncentr,ntauhac(ncentr,neta))+2
4244       netahyxx=netahy
4245       write(ifhi,'(a)')    '!----------------------------------------'
4246       write(ifhi,'(a,i3)') '!        hydro freeze out y_0 y_2      '
4247       write(ifhi,'(a)')    '!----------------------------------------'
4248       write(ifhi,'(a)')    '!newpage'
4249       do ii=1,2
4250         write(ifhi,'(a,3i1)')'openhisto htyp lin name y-',neta,nn,ii
4251         if(ii.eq.1)then !----------------------
4252          write(ifhi,'(a,f4.1)')'xmod lin xrange 0. ',taumax
4253          write(ifhi,'(a)')'txt "xaxis [t] (fm/c)"'
4254          write(ifhi,'(a)') 'ymod lin yrange auto auto '
4255          write(ifhi,'(a,f4.2,a)')'text 0.1 0.9 "   [c]=',etahy(neta),'"'
4256          write(ifhi,'(a)')'txt "yaxis y?0!  y?2! "'
4257           write(ifhi,'(a,f4.1,a,f4.1,a)')'text 0.50 0.9 "'//cbim//'  "'
4258         endif !-------------------------------
4259         write(ifhi,'(a)')'array 2'
4260         do ntau=2,ntauhac(ncentr,neta)
4261          write(ifhi,'(2e13.5)')tauhoc(ncentr,ntau)
4262      .     ,yomi(ncentr,neta,ntau,ii)
4263         enddo
4264         write(ifhi,'(a)') 'endarray closehisto '
4265         if(ii.ne.2)write(ifhi,'(a)') 'plot 0-'
4266         if(ii.eq.2)write(ifhi,'(a)') 'plot 0'
4267       enddo
4268       end
4269
4270 c------------------------------------------------------------------------------
4271       subroutine centrality(b,cbim)
4272 c------------------------------------------------------------------------------
4273       include 'epos.inc'
4274       character *8 cbim
4275       parameter (maxb=16)
4276       dimension iperc(maxb),bim(maxb)
4277       parameter(mxdefine=40)
4278       character w1define*100,w2define*100
4279       common/cdefine/ndefine,l1define(mxdefine),l2define(mxdefine)
4280      &               ,w1define(mxdefine),w2define(mxdefine)
4281
4282       data iperc /0,5,10,15,20,25,30,35,40,45,50,60,70,80,92,100/
4283
4284       do n=1,maxb
4285         bim(n)=0
4286       enddo
4287       do m=1,ndefine
4288         if(w1define(m)(1:l1define(m)).eq.'bim05')then
4289           read(w2define(m)(1:l2define(m)),*)bim(2)
4290         elseif(w1define(m)(1:l1define(m)).eq.'bim10')then
4291           read(w2define(m)(1:l2define(m)),*)bim(3)
4292         elseif(w1define(m)(1:l1define(m)).eq.'bim15')then
4293           read(w2define(m)(1:l2define(m)),*)bim(4)
4294         elseif(w1define(m)(1:l1define(m)).eq.'bim20')then
4295           read(w2define(m)(1:l2define(m)),*)bim(5)
4296         elseif(w1define(m)(1:l1define(m)).eq.'bim25')then
4297           read(w2define(m)(1:l2define(m)),*)bim(6)
4298         elseif(w1define(m)(1:l1define(m)).eq.'bim30')then
4299           read(w2define(m)(1:l2define(m)),*)bim(7)
4300         elseif(w1define(m)(1:l1define(m)).eq.'bim35')then
4301           read(w2define(m)(1:l2define(m)),*)bim(8)
4302         elseif(w1define(m)(1:l1define(m)).eq.'bim40')then
4303           read(w2define(m)(1:l2define(m)),*)bim(9)
4304         elseif(w1define(m)(1:l1define(m)).eq.'bim45')then
4305           read(w2define(m)(1:l2define(m)),*)bim(10)
4306         elseif(w1define(m)(1:l1define(m)).eq.'bim50')then
4307           read(w2define(m)(1:l2define(m)),*)bim(11)
4308         elseif(w1define(m)(1:l1define(m)).eq.'bim60')then
4309           read(w2define(m)(1:l2define(m)),*)bim(12)
4310         elseif(w1define(m)(1:l1define(m)).eq.'bim70')then
4311           read(w2define(m)(1:l2define(m)),*)bim(13)
4312         elseif(w1define(m)(1:l1define(m)).eq.'bim80')then
4313           read(w2define(m)(1:l2define(m)),*)bim(14)
4314         elseif(w1define(m)(1:l1define(m)).eq.'bim92')then
4315           read(w2define(m)(1:l2define(m)),*)bim(15)
4316         endif
4317       enddo
4318       bim(16)=100.
4319       do n=2,maxb
4320         if(bim(n).eq.0.)then
4321           print*,'******* ERROR in subroutine centrality: '
4322      .       ,' #define bim?? ??? missing. *******  '
4323           print*,'   n=',n
4324           stop'14082007'
4325         endif
4326       enddo
4327
4328       n=1
4329       do while(bim(n).lt.b)
4330         n=n+1
4331       enddo
4332       n=max(2,n)
4333       write(cbim,'(a,i2,a,i2,a)')' ',iperc(n-1),'-',iperc(n),'% '
4334       !print*,cbim
4335
4336       end
4337
4338 c-----------------------------------------------------------------------
4339       subroutine xCoreCorona(iii,jjj)
4340 c-----------------------------------------------------------------------
4341 c     space-time evolution of core and corona
4342 c
4343 c     cluster ............   ist=11  ity=60
4344 c     core particles .....   ist=0   ity=60
4345 c     corona particles ...   ist=0   ity/=60
4346 c
4347 c    iii=1: plot also binary collisions
4348 c    jjj>0: multiplicity trigger (useful for pp)
4349 c-----------------------------------------------------------------------
4350       include 'epos.inc'
4351       include 'epos.incems'
4352       include 'epos.inchy'
4353       common/cen/ncentr
4354       common/cxyzt/xptl(mxptl),yptl(mxptl),zptl(mxptl),tptl(mxptl)
4355      *,optl(mxptl),uptl(mxptl),sptl(mxptl),rptl(mxptl,3)
4356       common/cdelzet/delzet,delsgr
4357       parameter (myy=48,mrr=100)
4358       real yy(myy),rr(mrr)
4359       common/cranphi/ranphi,ranecc,weiecc
4360       character *8 cbim,cbimhy
4361       cbim='        '
4362       cbimhy='        '
4363       if(ioclude.gt.1)call centrality(bimevt        ,cbim)
4364       if(ioclude.gt.1)call centrality(centhy(ncentr),cbimhy)
4365
4366       phi=ranphi+phievt
4367       !print*,'RandomPhi=',ranphi,'   EventPhi=',phievt
4368       rapmax=6
4369       radmax=10
4370       r1=0.0
4371       if(maproj.gt.1)r1=radnuc(maproj)
4372       r2=0.0
4373       if(matarg.gt.1)r2=radnuc(matarg)
4374       if(maproj.eq.1.and.matarg.gt.1)r1=r2
4375       if(maproj.gt.1.and.matarg.eq.1)r2=r1
4376       a=7.8
4377       b=bimevt/2
4378       n1=koievt
4379       n2=0
4380       do k=1,koll
4381        if(itpr(k).gt.0)n2=n2+1
4382       enddo
4383       n3=nglevt
4384
4385       if(jjj.gt.0)then
4386       multy1=0
4387        do i=maproj+matarg+1,nptl
4388         if(istptl(i).eq.0)then
4389           amt=pptl(5,i)**2+pptl(1,i)**2+pptl(2,i)**2
4390           rap=1000
4391           if(amt.gt.0..and.pptl(4,i).gt.0.)then
4392             amt=sqrt(amt)
4393             rap=sign(1.,pptl(3,i))*alog((pptl(4,i)+abs(pptl(3,i)))/amt)
4394           endif
4395           ch=0
4396           if(abs(idptl(i)).ge.100.and.abs(idptl(i)).lt.10000)then
4397             call idchrg(idptl(i),ch)
4398             if(abs(ch).gt.0.1.and.abs(rap).le.1.)multy1=multy1+1
4399           endif
4400          endif
4401         enddo
4402         ih1=jjj/100
4403         ih2=mod(jjj,100)
4404         if(0.5*multy1.lt.ih1.or.0.5*multy1.gt.ih2)return
4405       endif
4406
4407       write(ifhi,'(a)')       '!---------------------------------'
4408       write(ifhi,'(a)')       '!   core particles                '
4409       write(ifhi,'(a)')       '!---------------------------------'
4410       write(ifhi,'(a)')       '!newpage'
4411       write(ifhi,'(a)')      'openhisto name st1'
4412       write(ifhi,'(a)')       'htyp prv xmod lin ymod lin'
4413       write(ifhi,'(a,2e11.3)')'xrange',-a*1.5,a*1.5
4414       write(ifhi,'(a,2e11.3)')'yrange',-a,a
4415       write(ifhi,'(a)')    'text 1.02 -0.15 " x"'
4416       write(ifhi,'(a)')    'txt "yaxis y"'
4417       write(ifhi,'(a)')       'text 0.05 0.90 "core"'
4418       write(ifhi,'(a)')       'text 0.05 0.80 "corona"'
4419       write(ifhi,'(a,f4.1,a)')'text 0.82 0.07 "[c]=0"'
4420       write(ifhi,'(a,f4.1,a,f4.1,a)')'text 0.77 0.92 "'//cbim//'"'
4421       write(ifhi,'(a)')       'array 2'
4422       ncore=0
4423       do i=1,nptl
4424        if(abs(sptl(i)).lt.0.5*delsgr.and.istptl(i).eq.2)then
4425          write(ifhi,'(2e11.3)')xptl(i)*cos(phi)+yptl(i)*sin(phi)
4426      .      ,                      -xptl(i)*sin(phi)+yptl(i)*cos(phi)
4427          ncore=ncore+1
4428        endif
4429       enddo
4430       write(ifhi,'(a)')    '  endarray'
4431       write(ifhi,'(a)')    'closehisto plot 0-'
4432       write(ifhi,'(a)')       '!----------------------------------'
4433       write(ifhi,'(a)')       '!   corona particles               '
4434       write(ifhi,'(a)')       '!----------------------------------'
4435       write(ifhi,'(a)')      'openhisto name st2'
4436       write(ifhi,'(a)')       'htyp pgv xmod lin ymod lin'
4437       write(ifhi,'(a)')       'array 2'
4438       ncorona=0
4439       do i=1,nptl
4440        if(abs(sptl(i)).lt.0.5*delsgr.and.istptl(i).eq.0
4441      .  .and.ityptl(i).ne.60.and.ityptl(i).ne.19)then
4442          write(ifhi,'(2e11.3)')xptl(i)*cos(phi)+yptl(i)*sin(phi)
4443      .      ,                      -xptl(i)*sin(phi)+yptl(i)*cos(phi)
4444         ncorona=ncorona+1
4445        endif
4446       enddo
4447       write(ifhi,'(a)')    '  endarray'
4448       write(ifhi,'(a)')    'closehisto'
4449       !print*,'b=',bimevt,'   ncorona:ncore =  ',ncorona,':',ncore
4450          if(iii.eq.1)then
4451       write(ifhi,'(a)')       '!----------------------------------'
4452       write(ifhi,'(a)')       '!   binary collisions             '
4453       write(ifhi,'(a)')       '!----------------------------------'
4454       write(ifhi,'(a)')    'plot 0-'
4455       write(ifhi,'(a)')      'openhisto name coo'
4456       write(ifhi,'(a)')       'htyp pbl xmod lin ymod lin'
4457       write(ifhi,'(a,2e11.3)')'xrange',-a*1.5,a*1.5
4458       write(ifhi,'(a,2e11.3)')'yrange',-a,a
4459       write(ifhi,'(a)')       'array 2'
4460       do k=1,koll
4461        if(itpr(k).gt.0)then
4462          write(ifhi,'(2e11.3)')coord(1,k)*cos(phi)+coord(2,k)*sin(phi)
4463      * ,                      -coord(1,k)*sin(phi)+coord(2,k)*cos(phi)
4464        endif
4465       enddo
4466       write(ifhi,'(a)')    '  endarray'
4467       write(ifhi,'(a)')    'closehisto'
4468          endif
4469       if(r1.ne.0.0)then
4470         write(ifhi,'(a)')    'plot 0-'
4471         write(ifhi,'(a)')       '!----------------------------------'
4472         write(ifhi,'(a)')       '!   hard spheres             '
4473         write(ifhi,'(a)')       '!----------------------------------'
4474         write(ifhi,'(a)')   'openhisto name stc1 htyp lyu'
4475         write(ifhi,'(a)')   'array 2'
4476         do j=-50,50
4477          phi=j/50.*pi*0.55
4478          write(ifhi,'(2e11.3)')r1*cos(phi)-b,r1*sin(phi)
4479         enddo
4480         write(ifhi,'(a)')    '  endarray'
4481         write(ifhi,'(a)')    'closehisto'
4482       endif
4483       if(r2.ne.0.0)then
4484         write(ifhi,'(a)')    'plot 0-'
4485         write(ifhi,'(a)')   'openhisto name stc1 htyp lyu'
4486         write(ifhi,'(a)')   'array 2'
4487         do j=-50,50
4488          phi=j/50.*pi*0.55
4489          write(ifhi,'(2e11.3)')-r1*cos(phi)+b,r1*sin(phi)
4490         enddo
4491         write(ifhi,'(a)')    '  endarray'
4492         write(ifhi,'(a)')    'closehisto'
4493       endif
4494
4495       write(ifhi,'(a)')    'plot 0'
4496
4497    !........................................................................................
4498       if(ioclude.le.1)return
4499    !........................................................................................
4500       delrap=2*rapmax/float(myy)
4501       do m=1,myy
4502         yy(m)=0
4503       enddo
4504       do n=1,nptl
4505         if(dezptl(n).lt.1e3.and.n.le.maxfra.and.istptl(n).eq.2)then
4506         routp=-sin(phievt)*xptl(n)+cos(phievt)*yptl(n)
4507         rinp = cos(phievt)*xptl(n)+sin(phievt)*yptl(n)
4508         if(abs(rinp).le.1.and.abs(routp).le.1.)then
4509           rapx=dezptl(n)
4510           eco=0
4511           amt=pptl(5,n)**2+pptl(1,n)**2+pptl(2,n)**2
4512           if(amt.gt.0..and.pptl(4,n)+abs(pptl(3,n)).gt.0.d0)then
4513             amt=sqrt(amt)
4514             rap=sign(1.,pptl(3,n))*alog((pptl(4,n)+abs(pptl(3,n)))/amt)
4515             eco=amt*cosh(rap-rapx)
4516           endif
4517           m=(rapx+rapmax)/delrap+1
4518           if(m.gt.myy)m=myy
4519           yy(m)=yy(m)+eco
4520         endif
4521         endif
4522       enddo
4523       write(ifhi,'(a)')'!---------------------------------------------'
4524       write(ifhi,'(a)')'!    core segment energy per d[c]dxdy         '
4525       write(ifhi,'(a)')'!           vs space-time rapidity rapx       '
4526       write(ifhi,'(a)')'!   (same as histogram rapx eco... in optns)  '
4527       write(ifhi,'(a)')'!---------------------------------------------'
4528       write(ifhi,'(a)')       '!newpage'
4529       write(ifhi,'(a)')    'openhisto name rapx'
4530       write(ifhi,'(a)')       'htyp lin xmod lin ymod lin'
4531       write(ifhi,'(a,2f7.3)') 'xrange ',-rapmax,rapmax
4532       write(ifhi,'(a)')        'yrange 0 auto '
4533       write(ifhi,'(a)')  'txt "title initial energy          "'
4534       write(ifhi,'(a,f4.1,a)')'text 0.05 0.70 "x=0"'
4535       write(ifhi,'(a,f4.1,a)')'text 0.05 0.60 "y=0"'
4536       write(ifhi,'(a,f4.1,a,f4.1,a)')'text 0.75 0.90 "'//cbim//'"'
4537       write(ifhi,'(a)')  'txt  "xaxis space-time rapidity [c] "'
4538       write(ifhi,'(a)')  'txt  "yaxis dE/d[c]dxdy "'
4539       write(ifhi,'(a)')       'array 2'
4540       do m=1,myy
4541         write(ifhi,'(2e11.3)')-rapmax+(m-0.5)*delrap, yy(m)/4./delrap
4542       enddo
4543       write(ifhi,'(a)')  '  endarray closehisto plot 0-'
4544    !........................................................................................
4545       delrap=2*rapmax/float(myy)
4546       do m=1,myy
4547         yy(m)=0
4548       enddo
4549       do n=1,nptl
4550         if(dezptl(n).lt.1e3.and.n.le.maxfra.and.istptl(n)/2.eq.0)then
4551         routp=-sin(phievt)*xptl(n)+cos(phievt)*yptl(n)
4552         rinp = cos(phievt)*xptl(n)+sin(phievt)*yptl(n)
4553         if(abs(rinp).le.1.and.abs(routp).le.1.)then
4554           rapx=dezptl(n)
4555           eco=0
4556           amt=pptl(5,n)**2+pptl(1,n)**2+pptl(2,n)**2
4557           if(amt.gt.0..and.pptl(4,n)+abs(pptl(3,n)).gt.0.d0)then
4558             amt=sqrt(amt)
4559             rap=sign(1.,pptl(3,n))*alog((pptl(4,n)+abs(pptl(3,n)))/amt)
4560             eco=amt*cosh(rap-rapx)
4561           endif
4562           m=(rapx+rapmax)/delrap+1
4563           if(m.ge.1.and.m.le.myy)yy(m)=yy(m)+eco
4564         endif
4565         endif
4566       enddo
4567       write(ifhi,'(a)')'!---------------------------------------------'
4568       write(ifhi,'(a)')'!    corona segment energy per d[c]dxdy       '
4569       write(ifhi,'(a)')'!           vs space-time rapidity rapx       '
4570       write(ifhi,'(a)')'!   (same as histogram rapx eco... in optns)  '
4571       write(ifhi,'(a)')'!---------------------------------------------'
4572       write(ifhi,'(a)')    'openhisto name rapx'
4573       write(ifhi,'(a)')       'htyp lin xmod lin ymod lin'
4574       write(ifhi,'(a,2f7.3)') 'xrange ',-rapmax,rapmax
4575       write(ifhi,'(a)')        'yrange 0 auto '
4576       write(ifhi,'(a)')  'txt "title initial energy          "'
4577       write(ifhi,'(a)')  'txt  "xaxis space-time rapidity [c] "'
4578       write(ifhi,'(a)')  'txt  "yaxis dE/d[c]dxdy "'
4579       write(ifhi,'(a)')       'array 2'
4580       do m=1,myy
4581         write(ifhi,'(2e11.3)')-rapmax+(m-0.5)*delrap, yy(m)/4./delrap
4582       enddo
4583       write(ifhi,'(a)')  '  endarray closehisto plot 0-'
4584       call xEiniEta(1)
4585       write(ifhi,'(a)')  'plot 0'
4586    !........................................................................................
4587       delrad=2*radmax/float(mrr)
4588       do m=1,mrr
4589         rr(m)=0
4590       enddo
4591       do n=1,nptl
4592         if(dezptl(n).lt.1e3.and.n.le.maxfra.and.istptl(n).eq.2)then
4593         routp=-sin(phievt)*xptl(n)+cos(phievt)*yptl(n)
4594         rinp = cos(phievt)*xptl(n)+sin(phievt)*yptl(n)
4595         rapx=dezptl(n)
4596         if(abs(rapx).le.1.and.abs(routp).le.1.)then
4597           eco=0
4598           amt=pptl(5,n)**2+pptl(1,n)**2+pptl(2,n)**2
4599           if(amt.gt.0..and.pptl(4,n)+abs(pptl(3,n)).gt.0.d0)then
4600             amt=sqrt(amt)
4601             rap=sign(1.,pptl(3,n))*alog((pptl(4,n)+abs(pptl(3,n)))/amt)
4602             eco=amt*cosh(rap-rapx)
4603           endif
4604           m=(rinp+radmax)/delrad+1
4605           if(m.gt.mrr)m=mrr
4606           rr(m)=rr(m)+eco
4607         endif
4608         endif
4609       enddo
4610       write(ifhi,'(a)')'!---------------------------------------------'
4611       write(ifhi,'(a)')'!    core segment energy per d[c]dxdy vs x    '
4612       write(ifhi,'(a)')'!   (same as histogram rinp eco... in optns)  '
4613       write(ifhi,'(a)')'!---------------------------------------------'
4614       write(ifhi,'(a)')       '!newpage'
4615       write(ifhi,'(a)')    'openhisto name rapx'
4616       write(ifhi,'(a)')       'htyp lin xmod lin ymod lin'
4617       write(ifhi,'(a,2f7.3)') 'xrange ',-radmax,radmax
4618       write(ifhi,'(a)')        'yrange 0 auto '
4619       write(ifhi,'(a)')  'txt "title initial energy          "'
4620       write(ifhi,'(a,f4.1,a)')'text 0.05 0.70 "[c]=0"'
4621       write(ifhi,'(a,f4.1,a)')'text 0.05 0.60 "y=0"'
4622       write(ifhi,'(a,f4.1,a,f4.1,a)')'text 0.75 0.90 "'//cbim//'"'
4623       write(ifhi,'(a)')  'txt  "xaxis x (fm)"'
4624       write(ifhi,'(a)')  'txt  "yaxis dE/d[c]dxdy "'
4625       write(ifhi,'(a)')       'array 2'
4626       do m=1,mrr
4627         write(ifhi,'(2e11.3)')-radmax+(m-0.5)*delrad, rr(m)/4./delrad
4628       enddo
4629       write(ifhi,'(a)')  '  endarray closehisto plot 0-'
4630    !........................................................................................
4631       delrad=2*radmax/float(mrr)
4632       do m=1,mrr
4633         rr(m)=0
4634       enddo
4635       do n=1,nptl
4636         if(dezptl(n).lt.1e3.and.n.le.maxfra.and.istptl(n)/2.eq.0)then
4637         routp=-sin(phievt)*xptl(n)+cos(phievt)*yptl(n)
4638         rinp = cos(phievt)*xptl(n)+sin(phievt)*yptl(n)
4639         rapx=dezptl(n)
4640         if(abs(rapx).le.1.and.abs(routp).le.1.)then
4641           eco=0
4642           amt=pptl(5,n)**2+pptl(1,n)**2+pptl(2,n)**2
4643           if(amt.gt.0..and.pptl(4,n)+abs(pptl(3,n)).gt.0.d0)then
4644             amt=sqrt(amt)
4645             rap=sign(1.,pptl(3,n))*alog((pptl(4,n)+abs(pptl(3,n)))/amt)
4646             eco=amt*cosh(rap-rapx)
4647           endif
4648           m=(rinp+radmax)/delrad+1
4649           if(m.gt.mrr)m=mrr
4650           rr(m)=rr(m)+eco
4651         endif
4652         endif
4653       enddo
4654       write(ifhi,'(a)')'!---------------------------------------------'
4655       write(ifhi,'(a)')'!    corona segment energy per d[c]dxdy vs x  '
4656       write(ifhi,'(a)')'!   (same as histogram rinp eco... in optns)  '
4657       write(ifhi,'(a)')'!---------------------------------------------'
4658       write(ifhi,'(a)')    'openhisto name rapx'
4659       write(ifhi,'(a)')       'htyp lin xmod lin ymod lin'
4660       write(ifhi,'(a)')       'array 2'
4661       do m=1,mrr
4662         write(ifhi,'(2e11.3)')-radmax+(m-0.5)*delrad, rr(m)/4./delrad
4663       enddo
4664       write(ifhi,'(a)')  '  endarray closehisto plot 0-'
4665       call xEiniX(1)
4666       write(ifhi,'(a)')  'plot 0'
4667    !........................................................................................
4668       delrad=2*radmax/float(mrr)
4669       do m=1,mrr
4670         rr(m)=0
4671       enddo
4672       do n=1,nptl
4673         if(dezptl(n).lt.1e3.and.n.le.maxfra.and.istptl(n).eq.2)then
4674         routp=-sin(phievt)*xptl(n)+cos(phievt)*yptl(n)
4675         rinp = cos(phievt)*xptl(n)+sin(phievt)*yptl(n)
4676         rapx=dezptl(n)
4677         if(abs(rapx).le.1.and.abs(rinp).le.1.)then
4678           eco=0
4679           amt=pptl(5,n)**2+pptl(1,n)**2+pptl(2,n)**2
4680           if(amt.gt.0..and.pptl(4,n)+abs(pptl(3,n)).gt.0.d0)then
4681             amt=sqrt(amt)
4682             rap=sign(1.,pptl(3,n))*alog((pptl(4,n)+abs(pptl(3,n)))/amt)
4683             eco=amt*cosh(rap-rapx)
4684           endif
4685           m=(routp+radmax)/delrad+1
4686           if(m.gt.mrr)m=mrr
4687           rr(m)=rr(m)+eco
4688         endif
4689         endif
4690       enddo
4691       write(ifhi,'(a)')'!---------------------------------------------'
4692       write(ifhi,'(a)')'!    core segment energy per d[c]dxdy vs y    '
4693       write(ifhi,'(a)')'!   (same as histogram routp eco... in optns)  '
4694       write(ifhi,'(a)')'!---------------------------------------------'
4695       write(ifhi,'(a)')       '!newpage'
4696       write(ifhi,'(a)')    'openhisto name rout'
4697       write(ifhi,'(a)')       'htyp lin xmod lin ymod lin'
4698       write(ifhi,'(a,2f7.3)') 'xrange ',-radmax,radmax
4699       write(ifhi,'(a)')        'yrange 0 auto '
4700       write(ifhi,'(a)')  'txt "title initial energy          "'
4701       write(ifhi,'(a,f4.1,a)')'text 0.05 0.70 "[c]=0"'
4702       write(ifhi,'(a,f4.1,a)')'text 0.05 0.60 "x=0"'
4703       write(ifhi,'(a,f4.1,a,f4.1,a)')'text 0.75 0.90 "'//cbim//'"'
4704       write(ifhi,'(a)')  'txt  "xaxis y (fm)"'
4705       write(ifhi,'(a)')  'txt  "yaxis dE/d[c]dxdy "'
4706       write(ifhi,'(a)')       'array 2'
4707       do m=1,mrr
4708         write(ifhi,'(2e11.3)')-radmax+(m-0.5)*delrad, rr(m)/4./delrad
4709       enddo
4710       write(ifhi,'(a)')  '  endarray closehisto plot 0-'
4711    !........................................................................................
4712       delrad=2*radmax/float(mrr)
4713       do m=1,mrr
4714         rr(m)=0
4715       enddo
4716       do n=1,nptl
4717         if(dezptl(n).lt.1e3.and.n.le.maxfra.and.istptl(n)/2.eq.0)then
4718         routp=-sin(phievt)*xptl(n)+cos(phievt)*yptl(n)
4719         rinp = cos(phievt)*xptl(n)+sin(phievt)*yptl(n)
4720         rapx=dezptl(n)
4721         if(abs(rapx).le.1.and.abs(rinp).le.1.)then
4722           eco=0
4723           amt=pptl(5,n)**2+pptl(1,n)**2+pptl(2,n)**2
4724           if(amt.gt.0..and.pptl(4,n)+abs(pptl(3,n)).gt.0.d0)then
4725             amt=sqrt(amt)
4726             rap=sign(1.,pptl(3,n))*alog((pptl(4,n)+abs(pptl(3,n)))/amt)
4727             eco=amt*cosh(rap-rapx)
4728           endif
4729           m=(routp+radmax)/delrad+1
4730           if(m.gt.mrr)m=mrr
4731           rr(m)=rr(m)+eco
4732         endif
4733         endif
4734       enddo
4735       write(ifhi,'(a)')'!---------------------------------------------'
4736       write(ifhi,'(a)')'!    corona segment energy per d[c]dxdy vs y  '
4737       write(ifhi,'(a)')'!   (same as histogram routp eco... in optns)  '
4738       write(ifhi,'(a)')'!---------------------------------------------'
4739       write(ifhi,'(a)')    'openhisto name rout'
4740       write(ifhi,'(a)')       'htyp lin xmod lin ymod lin'
4741       write(ifhi,'(a)')       'array 2'
4742       do m=1,mrr
4743         write(ifhi,'(2e11.3)')-radmax+(m-0.5)*delrad, rr(m)/4./delrad
4744       enddo
4745       write(ifhi,'(a)')  '  endarray closehisto plot 0-'
4746       call xEiniY(1)
4747       write(ifhi,'(a)')  'plot 0'
4748
4749       end
4750
4751 c------------------------------------------------------------------------------
4752       subroutine xEini(ii)
4753 c------------------------------------------------------------------------------
4754       include 'epos.inc'
4755       include 'epos.inchy'
4756       common/cen/ncentr
4757
4758       entry xEiniX(ii)
4759       write(ifhi,'(a)')    '!----------------------------------------'
4760       write(ifhi,'(a,i3)') '!        hydro initial energy vs x  '
4761       write(ifhi,'(a)')    '!----------------------------------------'
4762       write(ifhi,'(a)')'openhisto  array 2'
4763       do nr=nradhy,2,-1
4764        write(ifhi,'(2e13.5)')
4765      .     -radhy(nr),epsii(ncentr,ii,1,nr)*tauhoc(ncentr,1)
4766       enddo
4767       do nr=1,nradhy
4768        write(ifhi,'(2e13.5)')
4769      .     radhy(nr),epsii(ncentr,ii,1,nr)*tauhoc(ncentr,1)
4770       enddo
4771       write(ifhi,'(a)') 'endarray closehisto '
4772       return
4773
4774       entry xEiniY(ii)
4775       write(ifhi,'(a)')    '!----------------------------------------'
4776       write(ifhi,'(a,i3)') '!        hydro initial energy vs y     '
4777       write(ifhi,'(a)')    '!----------------------------------------'
4778       write(ifhi,'(a)')'openhisto  array 2'
4779       do nr=nradhy,2,-1
4780        write(ifhi,'(2e13.5)')
4781      .    -radhy(nr),epsii(ncentr,ii,nphihy,nr)*tauhoc(ncentr,1)
4782       enddo
4783       do nr=1,nradhy
4784        write(ifhi,'(2e13.5)')
4785      .    radhy(nr),epsii(ncentr,ii,nphihy,nr)*tauhoc(ncentr,1)
4786       enddo
4787       write(ifhi,'(a)') 'endarray closehisto '
4788       return
4789
4790       entry xEiniEta(ii)
4791       write(ifhi,'(a)')    '!----------------------------------------'
4792       write(ifhi,'(a,i3)') '!        hydro initial energy vs y     '
4793       write(ifhi,'(a)')    '!----------------------------------------'
4794       write(ifhi,'(a)')'openhisto  array 2'
4795       do neta=netahy,2,-1
4796        write(ifhi,'(2e13.5)')
4797      .   -etahy(neta),epsii(ncentr,neta,1,1)*tauhoc(ncentr,1)
4798       enddo
4799       do neta=1,netahy
4800        write(ifhi,'(2e13.5)')
4801      .   etahy(neta),epsii(ncentr,neta,1,1)*tauhoc(ncentr,1)
4802       enddo
4803       write(ifhi,'(a)') 'endarray closehisto '
4804       return
4805
4806       end
4807
4808 c------------------------------------------------------------------------------
4809       subroutine hnbcor(mode)
4810 c------------------------------------------------------------------------------
4811 c determines(mode=1) and plots (mode=2) two particle  correlations
4812 c for the configurations /confg/
4813 c------------------------------------------------------------------------------
4814       include 'epos.inc'
4815       integer bns
4816       parameter (maxp=500,bns=100)
4817       common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
4818       dimension zwei(bns),zz(bns)!,phi(bns),yy(bns)
4819       common/cor/wert(bns),cwert(bns)
4820       character*6 cen,cvol
4821
4822            if(mode.eq.1)then
4823
4824       nctcor=nctcor+1
4825
4826       if(nctcor.eq.1)then
4827       do nn=1,bns
4828       wert(nn)=0
4829       cwert(nn)=0
4830       enddo
4831       endif
4832
4833       ll=0
4834
4835       do ii=1,np-1
4836       do jj=ii+1,np
4837
4838       ll=ll+1
4839       prod=0
4840
4841       do kk=1,3
4842       prod=prod+pcm(kk,ii)*pcm(kk,jj)
4843       enddo
4844
4845       cs=prod/pcm(5,ii)/pcm(5,jj)
4846
4847       if(abs(cs).gt.1.)then
4848       cs=aint(cs)
4849       ang=acos(cs)
4850       else
4851       ang=acos(cs)
4852       endif
4853
4854       if(cs.eq.1.)then
4855       nk=bns
4856       nw=1
4857       elseif(ang.eq.pi)then
4858       nk=1
4859       nw=bns
4860       else
4861       nw=1+aint(ang/pi*bns)
4862       nk=1+aint((cs+1.)/2.*bns)
4863       endif
4864       nw=min(nw,bns)
4865       nk=min(nk,bns)
4866
4867       wert(nw)=wert(nw)+1
4868       cwert(nk)=cwert(nk)+1
4869
4870       enddo
4871       enddo
4872
4873            elseif(mode.eq.2)then
4874
4875       do mm=1,bns
4876 c      phi(mm)=.5*pi/bns+(mm-1)*pi/bns
4877       zwei(mm)=.5*2./bns+(mm-1)*2./bns-1.
4878 c      yy(mm)=wert(mm)/nctcor
4879       zz(mm)=cwert(mm)/nctcor
4880       enddo
4881
4882       write(cen,'(f6.1)')tecm
4883       write(cvol,'(f6.1)')volu
4884
4885       write(ifhi,'(a)')    'newpage zone 1 1 1 openhisto'
4886       write(ifhi,'(a)')    'htyp lin xmod lin ymod lin'
4887       write(ifhi,'(a)')    'xrange -1 1'
4888       write(ifhi,'(a)')    'text 0 0 "xaxis cosine"'
4889       write(ifhi,'(a)')    'text 0 0 "yaxis counts"'
4890       write(ifhi,'(a)')    'text 0.4 0.91 "V='//cvol//'"'
4891       write(ifhi,'(a)')    'text 0.15 0.91 "E='//cen//'"'
4892       write(ifhi,'(a)')    'array 2'
4893          do mm=1,bns
4894       write(ifhi,'(2e13.5)')zwei(mm),zz(mm)
4895          enddo
4896       write(ifhi,'(a)')    '  endarray'
4897       write(ifhi,'(a)')    'closehisto plot 0'
4898
4899            endif
4900
4901       return
4902       end
4903
4904 c----------------------------------------------------------------------
4905       subroutine hnbfac(faclog)
4906 c----------------------------------------------------------------------
4907 c  returns log of factor for phase space weight
4908 c  faclog= log{ prod[ m_i*(2*s_i+1)*volu/4/pi**3/hquer**3/(n_l+1-i) ] }
4909 c      ~~~~~~~~~~~~~~
4910 c  corresponds to eq. 67 of micro paper :
4911 c         Cvol * Cdeg * Cident * Cmicro
4912 c    the factors partly compensate each other !!
4913 c----------------------------------------------------------------------
4914       include 'epos.inc'
4915       parameter(maxp=500)
4916       common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
4917 c      integer ii(maxp)
4918       common /clatt/nlattc,npmax
4919
4920       faclog=0
4921
4922 c sum_i log m_i*g_i*volu/4/pi**3/hquer**3/(n_l+1-i) -> flog
4923       flog=0
4924       do i=1,np
4925       call hnbfaf(i,gg,am,ioma)
4926       flog=flog+alog(gg*am*volu/4/pi**3/hquer**3/(nlattc+1-i))
4927       enddo
4928       faclog=faclog+flog
4929
4930       return
4931       end
4932
4933 c----------------------------------------------------------------------
4934       subroutine hnbfaf(i,gg,am,ioma)
4935 c----------------------------------------------------------------------
4936 c  returns degeneracy gg and mass am  for factor f5
4937 c----------------------------------------------------------------------
4938       common/metr1/iospec,iocova,iopair,iozero,ioflac,iomom
4939       parameter(maxp=500)
4940       common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
4941       common/drop6/tecm,volu
4942
4943       ioma=5
4944
4945       hquer=0.197327
4946       cc=0.216416
4947       dd=13.773935
4948
4949       call hnbspi(ident(i),spideg)
4950       gg=spideg
4951
4952       if(ioma.eq.1)am=amass(i)
4953       if(ioma.eq.2)am=tecm/np
4954       if(ioma.eq.3)am=1
4955       if(ioma.eq.4)
4956      *am=cc*dd*gg**(-0.25)*(tecm/volu)**(0.25)*hquer**(0.75)
4957       if(ioma.eq.5)am=0.5   ! 1GeV / 2  (dimension energy)
4958       if(iocova.eq.2)then
4959       am=0.5                ! 1 / 2     (no dimension)
4960       ioma=0
4961       endif
4962       return
4963       end
4964
4965 cc----------------------------------------------------------------------
4966 c      subroutine hnbids(jc,ids,iwts,i)
4967 cc----------------------------------------------------------------------
4968 cc  returns i id-codes ids() corr to jc  and their weights iwts()
4969 cc----------------------------------------------------------------------
4970 c      parameter (mxids=200,mspecs=56,nflav=6)
4971 c      common/metr1/iospec,iocova,iopair,iozero,ioflac,iomom
4972 c      common/cflac/ifok(nflav,mspecs),ifoa(nflav)
4973 c      common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
4974 c      integer ids(mxids),jc(nflav,2),iwts(mxids),jc1mi2(nflav)
4975 c
4976 c      if(nspecs+1.gt.mxids)call utstop('hnbids: mxids too small&')
4977 c
4978 c      do n=1,nflav
4979 c      jc1mi2(n)=jc(n,1)-jc(n,2)
4980 c      enddo
4981 c
4982 c      i=0
4983 c
4984 c      do n=1,nflav
4985 c      if(jc1mi2(n).ne.0)goto1
4986 c      enddo
4987 c      i=i+1
4988 c      ids(i)=0
4989 c      iwts(i)=iozero
4990 c    1 continue
4991 c
4992 c           do j=1,nspecs
4993 c      do n=1,nflav
4994 c      if(jc1mi2(n).ne.ifok(n,j))goto2
4995 c      enddo
4996 c      i=i+1
4997 c      ids(i)=ispecs(j)
4998 c      iwts(i)=1
4999 c    2 continue
5000 c           enddo
5001 c
5002 c      return
5003 c      end
5004 c
5005 c----------------------------------------------------------------------
5006       subroutine hnbiiw(x,f,df)
5007 c----------------------------------------------------------------------
5008 c returns fctn value and first derivative at x of the
5009 c i-th integrated weight fctn minus random number
5010 c for the asympotic phase space integral.
5011 c input:
5012 c   x:   x-value
5013 c   iii: i-value (via common/ciiw/iii,rrr)
5014 c   rrr: random number   ( " )
5015 c output:
5016 c   f:   fctn value
5017 c   df:  first derivative
5018 c----------------------------------------------------------------------
5019       common/ciiw/iii,rrr
5020       i=iii
5021       f=x**(2*i-2)*(i-(i-1)*x**2)-rrr
5022       df=2*i*(i-1)*(x**(2*i-3)-x**(2*i-1))
5023       return
5024       end
5025
5026 c----------------------------------------------------------------------
5027       subroutine hnbini(iret)
5028 c----------------------------------------------------------------------
5029 c  generates initial configuration
5030 c----------------------------------------------------------------------
5031       include 'epos.inc'
5032       parameter(maxp=500)
5033       common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
5034       parameter (mspecs=56)
5035       common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
5036       common/crnoz/rnoz(maxp-1)
5037       common/citer/iter,itermx
5038       common/cfact/faclog
5039       common/chnbin/nump,ihadro(maxp)
5040       common /clatt/nlattc,npmax
5041       parameter(maxit=50000)
5042       common/count/nacc,nrej,naccit(maxit),nptot,npit(maxit)
5043       common/ctaue/taue
5044       if(ish.ge.7)write(ifch,*)('-',i=1,10)
5045      *,' entry sr hnbini ',('-',i=1,30)
5046
5047       iter=0
5048
5049       nlattc=8*(tecm/10)*(1/(tecm/volu))**0.2*(nspecs/3.)**0.3
5050       if(aspecs(1).lt.0.010)nlattc=nlattc*3
5051       nlattc=max(nlattc,20)
5052       if(iternc.lt.0)iternc=1.500*nlattc
5053
5054       itermx=iterma
5055       if(itermx.le.0)then
5056         e=tecm/volu
5057         b=1.1*(e+0.33)**0.66
5058         a=13.*(e+0.13)**(-0.65)
5059         tm=34.*(e+0.65)**(-0.61)
5060         t=a+b*volu
5061         taue=max(t,tm)
5062         itermx=(-itermx)*taue
5063       else
5064         taue=0
5065       endif
5066       if(ish.ge.5)write(ifch,*)'itermx:',itermx
5067
5068       if(iternc.gt.itermx/2)iternc=itermx/2
5069
5070       if(ioinco.eq.0)then
5071             call hnbmin(keu,ked,kes,kec)
5072             if(iograc.eq.1)call hgcaaa
5073       elseif(ioinco.ge.1)then
5074             nk=keu+ked+ked+kec
5075             if(tecm.lt.1.5.and.nk.eq.0)then
5076                       call hnbmin(keu,ked,kes,kec)
5077             elseif(tecm.lt.2.0.and.nk.ne.0)then
5078                       call hnbmin(keu,ked,kes,kec)
5079             else
5080                       call hgcaaa
5081                       call hgcnbi(iret)
5082                       if(iret.eq.1)then
5083                         call hnbmin(keu,ked,kes,kec)
5084                         if(ish.ge.5)then
5085                           write(ifch,*)'hadron set from hnbmin:'
5086                           write(ifch,'(10i6)')(ihadro(k),k=1,nump)
5087                         endif
5088                       endif
5089            endif
5090       endif
5091
5092       np=nump+nadd
5093       if(np.gt.maxp)stop'np too large'
5094
5095       nlattc=max(nlattc,1+int(np*1.2))
5096 c      print *,np,nlattc
5097       if(nlattc-1.gt.maxp)stop'maxp too small'
5098
5099       do i= 1, nlattc-1
5100       rnoz(i)=rangen()
5101       enddo
5102
5103       if(nadd.gt.0)then
5104       do i=nump+1,np
5105       ihadro(i)=110
5106       enddo
5107       endif
5108
5109            do i=1,np
5110       ident(i)=ihadro(i)
5111       amass(i)=-1
5112       do j=1,nspecs
5113       if(ident(i).eq.ispecs(j))then
5114       amass(i)=aspecs(j)
5115       goto1
5116       endif
5117       enddo
5118     1 continue
5119       if(amass(i).lt.0.)
5120      *call utstop('hnbini: invalid particle species&')
5121            enddo
5122
5123       if(iocova.eq.1)call hnbody    !covariant
5124       if(iocova.eq.2)call hnbodz    !noncovariant
5125       call hnbfac(faclog)
5126       wtlog=wtxlog+faclog
5127
5128       iret=0
5129       if(wtlog.le.-0.99999E+35)then
5130         if(ish.ge.1) then
5131           call utmsg('hnbini')
5132           write(ifch,*)'*****  wtlog for initl config < -1E+35'
5133           write(ifch,*)'***** wtlog:',wtlog
5134           write(ifch,*)'***** droplet mass:',tecm
5135           write(ifch,*)'***** flavour:'
5136           write(ifch,*)'*****',keu,ked,kes,kec,keb,ket
5137           write(ifch,'(1x,a,1x,10i6)')'*****',(ihadro(i),i=1,nump)
5138           call utmsgf
5139         endif
5140         iret=1
5141         goto1000
5142       endif
5143
5144       if(ish.ge.7)then
5145         write(ifch,*)'initial configuration:'
5146         call hnbwri
5147       endif
5148
5149       itermx=iterma
5150       if(itermx.le.0)then
5151       e=tecm/volu
5152       b=1.1*(e+0.33)**0.66
5153       a=13.*(e+0.13)**(-0.65)
5154       tm=34.*(e+0.65)**(-0.61)
5155       t=a+b*volu
5156       taue=max(t,tm)
5157       itermx=(-itermx)*taue
5158       else
5159       taue=0
5160       endif
5161       if(ish.ge.5)write(ifch,*)'itermx:',itermx
5162
5163       if(iternc.gt.itermx/2)iternc=itermx/2
5164
5165       nacc=0
5166       nrej=0
5167
5168  1000 continue
5169
5170       if(ish.ge.7)write(ifch,*)('-',i=1,30)
5171      *,' exit sr hnbini ',('-',i=1,10)
5172
5173       return
5174       end
5175
5176 cc----------------------------------------------------------------------
5177 c      subroutine hnbint(tecmx,nevtxx,nsho)
5178 cc----------------------------------------------------------------------
5179 cc  calculates phase space integral of the minimal hadron configuration
5180 cc  compatibel with keu, ked, kes, kec for a total mass of tecm
5181 cc  by employing nevtxx simulations and printing results every nsho events
5182 cc----------------------------------------------------------------------
5183 c      include 'epos.inc'
5184 c      parameter(maxp=500)
5185 c      common/chnbin/nump,ihadro(maxp)
5186 c      common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
5187 c      tecm=tecmx
5188 c      write(ifch,*)
5189 c      write(ifch,'(1x,a,4i3,a,f10.4)')'droplet id:',keu,ked,kes,kec
5190 c     *,'   droplet mass:',tecm
5191 c      call hnbmin(keu,ked,kes,kec)
5192 c      np=nump
5193 c      if(np.gt.maxp)stop'np too large'
5194 c      do i=1,np
5195 c      id=ihadro(i)
5196 c      if(id.eq.30)then
5197 c          call idmass(2130,am)
5198 c          amass(i)=2*am-0.100
5199 c      else
5200 c         call idmass(id,amass(i))
5201 c      endif
5202 c      enddo
5203 c      wts=0
5204 c      n=0
5205 c           do ll=1,nevtxx
5206 c      n=n+1
5207 c      if(iocova.eq.1)call hnbody
5208 c      if(iocova.eq.2)call hnbodz
5209 c      wt=exp(wtxlog)
5210 c      wts=wts+wt
5211 c      if(mod(n,nsho).eq.0)
5212 c     *write(ifch,'(a,i7,3x,a,e13.6,3x,a,e13.6,3x,a,e13.6)')
5213 c     *'n:',n,'weight:',wt,'wts/n:',wts/n,'error:',wts/n/sqrt(1.*n)
5214 c           enddo
5215 c      return
5216 c      end
5217 cc----------------------------------------------------------------------
5218       subroutine hnbmet
5219 c----------------------------------------------------------------------
5220 c  change (or not) configuration via metropolis
5221 c  configuration=np,tecm,amass(),ident(),pcm(),volu,wtlog
5222 c    (common /confg/)
5223 c  nlattc (in /clatt/) must be set before calling this routine
5224 c----------------------------------------------------------------------
5225       include 'epos.inc'
5226       parameter(maxp=500)
5227       common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
5228       common/crnoz/rnoz(maxp-1)
5229       real rnozo(maxp-1)
5230       common/cfact/faclog
5231       dimension amasso(maxp),idento(maxp),pcmo(5,maxp)
5232       integer jc(nflav,2),jc1(nflav,2),jc2(nflav,2)
5233       common/citer/iter,itermx
5234       parameter (mspecs=56)
5235       common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
5236       parameter (literm=500)
5237       common/cmet/kspecs(mspecs),liter,lspecs(literm,mspecs)
5238      *,iterl(literm),iterc(literm)
5239 c      parameter (mxpair=mspecs**2*4)
5240       common /clatt/nlattc,npmax
5241       parameter (nhise=100)
5242       common/chise/hise(mspecs,nhise)
5243       integer id1old(2),id2old(2),id1new(2),id2new(2)
5244       parameter(maxit=50000)
5245       common/count/nacc,nrej,naccit(maxit),nptot,npit(maxit)
5246       if(ish.ge.7)then
5247         write(ifch,*)('-',i=1,10)
5248      *,' entry sr hnbmet ',('-',i=1,30)
5249         write(ifch,'(1x,a,i4)')'iteration:',iter
5250       endif
5251       if(mod(iter,iterpr).eq.0)write(ifmt,*)'iteration:',iter
5252       if(maxp.gt.np)then
5253       do n=np+1,maxp
5254       ident(n)=0
5255       enddo
5256       endif
5257
5258 c     for iter=1
5259 c     ----------
5260            if(iter.eq.1)then
5261       liter=1
5262       do i=1,nspecs
5263       kspecs(i)=0
5264       nptot=0
5265       do li=1,literm
5266       lspecs(li,i)=0
5267       enddo
5268       enddo
5269       do li=1,literm
5270       iterc(li)=0
5271       enddo
5272       do j=1,mspecs
5273       do i=1,nhise
5274       hise(j,i)=0
5275       enddo
5276       enddo
5277       call hnbzmu(-1)
5278            endif
5279
5280 c     remember old configuration
5281 c     --------------------------
5282       wtlo=wtlog
5283       wtlox=wtxlog
5284       faclo=faclog
5285       npo=np
5286       if(np-1.gt.0)then
5287       do i=1,np-1
5288       rnozo(i)=rnoz(i)
5289       enddo
5290       endif
5291       if(np.gt.0)then
5292       do i=1,np
5293       amasso(i)=amass(i)
5294       idento(i)=ident(i)
5295       do j=1,5
5296       pcmo(j,i)=pcm(j,i)
5297       enddo
5298       enddo
5299       endif
5300
5301 c     determine pair, construct new pair, update ident
5302 c     ------------------------------------------------
5303            if(iopair.eq.1)then
5304 c     (single pair method)
5305       call hnbpad(1,n1,n2,n3,n4,mm,jc)
5306       id1old(1)=ident(n1)
5307       id2old(1)=ident(n2)
5308       id1old(2)=0
5309       id2old(2)=0
5310       call hnbpaj(jc,iwpair,id1,id2)
5311       ident(n1)=id1
5312       ident(n2)=id2
5313       call hnbrmz
5314       id1new(1)=id1
5315       id2new(1)=id2
5316       id1new(2)=0
5317       id2new(2)=0
5318       xab=1
5319       xba=1
5320       nzold=0
5321       if(id1old(1).eq.0)nzold=nzold+1
5322       if(id2old(1).eq.0)nzold=nzold+1
5323       nznew=0
5324       if(id1new(1).eq.0)nznew=nznew+1
5325       if(id2new(1).eq.0)nznew=nznew+1
5326
5327 c     determine 2 pairs, construct 2 new pairs, update ident
5328 c     ------------------------------------------------------
5329            elseif(iopair.eq.2)then
5330 c     (double pair method)
5331       kkk=0
5332    25 call hnbpad(1,n1,n2,n3,n4,mm,jc)
5333       kkk=kkk+1
5334       id1old(1)=ident(n1)
5335       id2old(1)=ident(n2)
5336       call hnbpai(id1,id2,jc1)
5337       ident(n1)=id1
5338       ident(n2)=id2
5339       id1new(1)=id1
5340       id2new(1)=id2
5341       do i=1,nflav
5342       do j=1,2
5343       jc(i,j)=jc(i,j)-jc1(i,j)
5344       jc2(i,j)=jc(i,j)
5345       enddo
5346       enddo
5347     2 call hnbpad(2,n1,n2,n3,n4,mm,jc1)
5348       id1old(2)=ident(n3)
5349       id2old(2)=ident(n4)
5350       do i=1,nflav
5351       do j=1,2
5352       jc(i,j)=jc(i,j)+jc1(i,j)
5353       enddo
5354       enddo
5355       call hnbpaj(jc,iwpair,id1,id2)
5356       if(iwpair.eq.0)then
5357       do i=1,nflav
5358       do j=1,2
5359       jc(i,j)=jc2(i,j)
5360       enddo
5361       enddo
5362       if(ish.ge.7)write(ifch,*)'no pair possible'
5363       goto2
5364       endif
5365       ident(n3)=id1
5366       ident(n4)=id2
5367       id1new(2)=id1
5368       id2new(2)=id2
5369       call hnbrmz
5370       if(ish.ge.7)write(ifch,*)'wt-sum of 2. pairs (-->):',iwpair
5371      *,'   chosen pair:',id1,id2
5372       call hnbpaj(jc1,iwpais,idum1,idum2)
5373       if(ish.ge.7)write(ifch,*)'wt-sum of 2. pairs (<--):',iwpais
5374       nzold=0
5375       if(id1old(1).eq.0)nzold=nzold+1
5376       if(id2old(1).eq.0)nzold=nzold+1
5377       if(id1old(2).eq.0)nzold=nzold+1
5378       if(id2old(2).eq.0)nzold=nzold+1
5379       if(ish.ge.7)write(ifch,*)'number of zeros (old):',nzold
5380       nznew=0
5381       if(id1new(1).eq.0)nznew=nznew+1
5382       if(id2new(1).eq.0)nznew=nznew+1
5383       if(id1new(2).eq.0)nznew=nznew+1
5384       if(id2new(2).eq.0)nznew=nznew+1
5385       if(ish.ge.7)write(ifch,*)'number of zeros (new):',nznew
5386       if(iorejz.eq.1.and.nzold.eq.4.and.nznew.eq.4.and.kkk.le.50)goto25
5387       xab=1./iwpair*iozero**nznew
5388       xba=1./iwpais*iozero**nzold
5389       if(ish.ge.7)write(ifch,*)'asymmetry factor:',xba/xab
5390            else
5391       call utstop('hnbmet: invalid choice for iopair&')
5392            endif
5393
5394 c     determine masses/momenta/weight of trial configuration
5395 c     ------------------------------------------------------
5396       if(np.ge.2)then
5397            do i=1,np
5398       amass(i)=-1
5399       do j=1,nspecs
5400       if(ident(i).eq.ispecs(j))then
5401       amass(i)=aspecs(j)
5402       goto1
5403       endif
5404       enddo
5405     1 continue
5406       if(amass(i).lt.0.)
5407      *call utstop('hnbmet: invalid particle species&')
5408            enddo
5409       keepr=0
5410 c-c   call hnbolo(1000) !instead of "call hnbody" for testing
5411       keepr=1
5412       if(iocova.eq.1)call hnbody
5413       if(iocova.eq.2)call hnbodz
5414       else
5415       wtxlog=-1e35
5416       endif
5417       call hnbfac(faclog)
5418       wtlog=wtxlog+faclog
5419       if(ish.ge.7)then
5420         write(ifch,*)'trial configuration:'
5421         call hnbwri
5422       endif
5423
5424 c     accept or not trial configuration (metropolis)
5425 c     ----------------------------------------------
5426       if(ish.ge.7)write(ifch,'(1x,a,4i5,a,4i5,a)')
5427      *'metropolis decision for '
5428      *,id1old(1),id2old(1),id1old(2),id2old(2),'   -->  '
5429      *,id1new(1),id2new(1),id1new(2),id2new(2),' :'
5430       iacc=0
5431            if(wtlog-wtlo.lt.30.)then
5432       q=exp(wtlog-wtlo)*xba/xab
5433       r=rangen()
5434       if(r.le.q)iacc=1
5435       if(ish.ge.7)write(ifch,*)'new weight / old weight:',q,'    '
5436      *,'random number:',r
5437            else
5438       iacc=1
5439       if(ish.ge.7)write(ifch,*)'log new weight / old weight:'
5440      *,wtlog-wtlo
5441            endif
5442            if(iacc.eq.1)then
5443       if(ish.ge.7)write(ifch,*)'new configuration accepted'
5444       nacc=nacc+1
5445       naccit(iter)=1
5446            else
5447       if(ish.ge.7)write(ifch,*)'old configuration kept'
5448       nrej=nrej+1
5449       wtlog=wtlo
5450       wtxlog=wtlox
5451       faclog=faclo
5452       np=npo
5453       if(np-1.gt.0)then
5454       do i=1,np-1
5455       rnoz(i)=rnozo(i)
5456       enddo
5457       endif
5458       if(np.gt.0)then
5459       do i=1,np
5460       amass(i)=amasso(i)
5461       ident(i)=idento(i)
5462       do j=1,5
5463       pcm(j,i)=pcmo(j,i)
5464       enddo
5465       enddo
5466       endif
5467            endif
5468            if(ioobsv.eq.0)then
5469       npit(iter)=np
5470       if(iter.gt.iternc)nptot=nptot+np
5471       else
5472       npob=0
5473       do i=1,np
5474       if(ioobsv.eq.ident(i))npob=npob+1
5475       enddo
5476       npit(iter)=npob
5477       if(iter.gt.iternc)nptot=nptot+npob
5478            endif
5479       if(ish.ge.7)then
5480         write(ifch,*)'actual configuration:'
5481         call hnbwri
5482         if(ish.eq.27)stop'change this?????????????' !call hnbcor(1)
5483       endif
5484
5485 c     printout/return
5486 c     ---------------
5487       if(iosngl.ne.nrevt+1.and.iocite.ne.1)goto1000
5488       npmax=max(npmax,np)
5489            if(liter.le.literm)then
5490       iterc(liter)=iterc(liter)+1
5491       do i=1,np
5492       do j=1,nspecs
5493       if(ident(i).eq.ispecs(j))then
5494       lspecs(liter,j)=lspecs(liter,j)+1
5495       goto8
5496       endif
5497       enddo
5498     8 continue
5499       enddo
5500       if(mod(iter,iterpl).eq.0)then
5501       iterl(liter)=iter
5502       liter=liter+1
5503 c     if(liter.le.literm)then
5504 c     iterc(liter)=iterc(liter-1)
5505 c     do j=1,nspecs
5506 c     lspecs(liter,j)=lspecs(liter-1,j)
5507 c     enddo
5508 c     endif
5509       endif
5510            endif
5511       if(iter.le.iternc)return
5512
5513            do i=1,np
5514       call hnbzen(i)  !fill energy histogram
5515       do j=1,nspecs
5516       if(ident(i).eq.ispecs(j))then
5517       kspecs(j)=kspecs(j)+1
5518       goto7
5519       endif
5520       enddo
5521     7 continue
5522            enddo
5523       call hnbzmu(1)  !fill multiplicity histogram
5524
5525            if(iter.eq.itermx.and.npmax.ge.nlattc.and.ish.ge.1)then
5526       call utmsg('hnbmet')
5527       write(ifch,*)'*****  nlattc too small'
5528       write(ifch,*)'nlattc:',nlattc,'   npmax:',npmax
5529       call utmsgf
5530            endif
5531
5532 1000  continue
5533       if(ish.ge.7)then
5534         write(ifch,*)'accepted proposals:',nacc
5535      *,'  rejected proposals:',nrej
5536         write(ifch,*)('-',i=1,30)
5537      *,' exit sr hnbmet ',('-',i=1,10)
5538       endif
5539       return
5540       end
5541
5542 c----------------------------------------------------------------------
5543       subroutine hnbmin(keux,kedx,kesx,kecx)
5544 c----------------------------------------------------------------------
5545 c  returns min hadron set with given u,d,s,c content
5546 c  input:
5547 c     keux: net u quark number
5548 c     kedx: net d quark number
5549 c     kesx: net s quark number
5550 c     kecx: net c quark number
5551 c  output (written to /chnbin/):
5552 c     nump: number of hadrons
5553 c     ihadro(n): hadron id for n'th hadron
5554 c----------------------------------------------------------------------
5555       include 'epos.inc'
5556       parameter(maxp=500)
5557       common/chnbin/nump,ihadro(maxp)
5558       logical wri
5559       character f1*11
5560       wri=.false.
5561       if(ish.ge.7)wri=.true.
5562       if(wri)write(ifch,*)('-',i=1,10)
5563      *,' entry sr hnbmin ',('-',i=1,30)
5564
5565       nump=0
5566       f1='(4i3,i7,i6)'
5567       ke=iabs(keux+kedx+kesx+kecx)
5568
5569       if(keux+kedx+kesx+kecx.ge.0)then
5570       keu=keux
5571       ked=kedx
5572       kes=kesx
5573       kec=kecx
5574       isi=1
5575       else
5576       keu=-keux
5577       ked=-kedx
5578       kes=-kesx
5579       kec=-kecx
5580       isi=-1
5581       endif
5582       if(wri)write(ifch,'(4i3)')keux,kedx,kesx,kecx
5583       if(wri)write(ifch,'(4i3)')keu,ked,kes,kec
5584
5585 c get rid of anti-c and c (140, 240, -140, -240)
5586       if(kec.ne.0)then
5587    10 continue
5588       if(kec.lt.0)then
5589       kec=kec+1
5590       if(keu.gt.ked)then
5591       keu=keu-1
5592       nump=nump+1
5593       ihadro(nump)=140
5594       if(wri)write(ifch,f1)keu,ked,kes,kec,nump,ihadro(nump)
5595       else
5596       ked=ked-1
5597       nump=nump+1
5598       ihadro(nump)=240
5599       if(wri)write(ifch,f1)keu,ked,kes,kec,nump,ihadro(nump)
5600       endif
5601       goto10
5602       endif
5603    11 continue
5604       if(kec.gt.0)then
5605       kec=kec-1
5606       if(keu.lt.ked)then
5607       keu=keu+1
5608       nump=nump+1
5609       ihadro(nump)=-140
5610       if(wri)write(ifch,f1)keu,ked,kes,kec,nump,ihadro(nump)
5611       else
5612       ked=ked+1
5613       nump=nump+1
5614       ihadro(nump)=-240
5615       if(wri)write(ifch,f1)keu,ked,kes,kec,nump,ihadro(nump)
5616       endif
5617       goto11
5618       endif
5619       endif
5620
5621 c get rid of anti-s (130,230)
5622     5 continue
5623       if(kes.lt.0)then
5624       kes=kes+1
5625       if(keu.ge.ked)then
5626       keu=keu-1
5627       nump=nump+1
5628       ihadro(nump)=130
5629       if(wri)write(ifch,f1)keu,ked,kes,kec,nump,ihadro(nump)
5630       else
5631       ked=ked-1
5632       nump=nump+1
5633       ihadro(nump)=230
5634       if(wri)write(ifch,f1)keu,ked,kes,kec,nump,ihadro(nump)
5635       endif
5636       goto5
5637       endif
5638
5639 c get rid of anti-d (120, -230)
5640    6  continue
5641       if(ked.lt.0)then
5642       ked=ked+1
5643       if(keu.ge.kes)then
5644       keu=keu-1
5645       nump=nump+1
5646       ihadro(nump)=120
5647       if(wri)write(ifch,f1)keu,ked,kes,kec,nump,ihadro(nump)
5648       else
5649       kes=kes-1
5650       nump=nump+1
5651       ihadro(nump)=-230
5652       if(wri)write(ifch,f1)keu,ked,kes,kec,nump,ihadro(nump)
5653       endif
5654       goto6
5655       endif
5656
5657 c get rid of anti-u (-120, -130)
5658     7 continue
5659       if(keu.lt.0)then
5660       keu=keu+1
5661       if(ked.ge.kes)then
5662       ked=ked-1
5663       nump=nump+1
5664       ihadro(nump)=-120
5665       if(wri)write(ifch,f1)keu,ked,kes,kec,nump,ihadro(nump)
5666       else
5667       kes=kes-1
5668       nump=nump+1
5669       ihadro(nump)=-130
5670       if(wri)write(ifch,f1)keu,ked,kes,kec,nump,ihadro(nump)
5671       endif
5672       goto7
5673       endif
5674
5675       if(keu+ked+kes+kec.ne.ke)call utstop('hnbmin: sum_kei /= ke&')
5676
5677       keq=keu+ked
5678
5679 c get rid of s (3331, x330, xx30)
5680       i=4
5681     2 i=i-1
5682     3 continue
5683       if((4-i)*kes.gt.(i-1)*keq)then
5684       kes=kes-i
5685       keq=keq-3+i
5686       nump=nump+1
5687       if(i.eq.3)ihadro(nump)=3331
5688       if(i.eq.2)ihadro(nump)=0330
5689       if(i.eq.1)ihadro(nump)=0030
5690            if(i.lt.3)then
5691       do j=1,3-i
5692       l=1+2*rangen()
5693       if(keu.gt.ked)l=1
5694       if(keu.lt.ked)l=2
5695       if(l.eq.1)keu=keu-1
5696       if(l.eq.2)ked=ked-1
5697       ihadro(nump)=ihadro(nump)+l*10**(4-j)
5698       enddo
5699            endif
5700       if(wri)write(ifch,f1)keu,ked,kes,kec,nump,ihadro(nump)
5701       if(kes.lt.0)call utstop('hnbmin: negative kes&')
5702       if(keq.lt.0)call utstop('hnbmin: negative keq&')
5703       goto3
5704       endif
5705       if(i.gt.1)goto2
5706
5707       if(keu+ked.ne.keq)call utstop('hnbmin: keu+ked /= keq&')
5708
5709 c get rid of d (2221, 1220, 1120)
5710       i=4
5711    12 i=i-1
5712    13 continue
5713       if((4-i)*ked.gt.(i-1)*keu)then
5714       ked=ked-i
5715       keu=keu-3+i
5716       if(i.eq.3)then
5717       nump=nump+2
5718       ihadro(nump)=1220
5719       ihadro(nump-1)=-120
5720       else
5721       nump=nump+1
5722       if(i.eq.2)ihadro(nump)=1220
5723       if(i.eq.1)ihadro(nump)=1120
5724       endif
5725       if(wri)write(ifch,f1)keu,ked,kes,kec,nump,ihadro(nump)
5726       if(ked.lt.0)call utstop('hnbmin: negative ked&')
5727       if(keu.lt.0)call utstop('hnbmin: negative keu&')
5728       goto13
5729       endif
5730       if(i.gt.1)goto12
5731
5732       if(ked.ne.0)call utstop('hnbmin: ked .ne. 0&')
5733
5734 c get rid of u (1111)
5735     9 continue
5736       if(keu.gt.0)then
5737       keu=keu-3
5738       nump=nump+2
5739       ihadro(nump)=1120
5740       ihadro(nump-1)=120
5741       if(wri)write(ifch,f1)keu,ked,kes,kec,nump,ihadro(nump)
5742       if(keu.lt.0)call utstop('hnbmin: negative keu&')
5743       goto9
5744       endif
5745
5746       if(keu.ne.0)call utstop('hnbmin: keu .ne. 0&')
5747
5748       if(isi.eq.-1)then
5749       do i=1,nump
5750       ihadro(i)=isi*ihadro(i)
5751       enddo
5752       endif
5753
5754       do lo=1,2
5755       if(nump.lt.2)then
5756       nump=nump+1
5757       ihadro(nump)=110
5758       if(wri)write(ifch,f1)keu,ked,kes,kec,nump,ihadro(nump)
5759       endif
5760       enddo
5761
5762       if(wri)write(ifch,*)('-',i=1,30)
5763      *,' exit sr hnbmin ',('-',i=1,10)
5764       return
5765       end
5766
5767 c-------------------------------------------------------------
5768       subroutine hnbody
5769 c-------------------------------------------------------------
5770 c   formerly subr genbod from genlib (cernlib).
5771 c   modified by K. Werner, march 94.
5772 c   subr to generate n-body event
5773 c   according to fermi lorentz-invariant phase space.
5774 c   the phase space integral is the sum over the weights wt divided
5775 c   by the number of events (sum wt / n).
5776 c   adapted from fowl (cern w505) sept. 1974 by f. james.
5777 c   events are generated in their own center-of-mass,
5778 c   but may be transformed to any frame using loren4.
5779 c
5780 c   input to and output from subr thru common block config.
5781 c   input:
5782 c             np=number of outgoing particles
5783 c             tecm=total energy in center-of-mass
5784 c             amass(i)=mass of ith outgoing particle
5785 c   output:
5786 c             pcm(1,i)=x-momentum if ith particle
5787 c             pcm(2,i)=y-momentum if ith particle
5788 c             pcm(3,i)=z-momentum if ith particle
5789 c             pcm(4,i)=energy of ith particle
5790 c             pcm(5,i)=momentum of ith particle
5791 c             wtxlog=log of weight of event
5792 c--------------------------------------------------------------
5793       include 'epos.inc'
5794       parameter(maxp=500)
5795       common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
5796       dimension emm(maxp)
5797       dimension rno(3*maxp-4)
5798 c     !pcm1 is linear equiv. of pcm to avoid double indices
5799       dimension em(maxp),pd(maxp),ems(maxp),sm(maxp)
5800      *,pcm1(5*maxp)
5801       common/cffq/ffqlog(maxp)
5802       common/ciiw/iii,rrr
5803       equivalence (nt,np),(amass(1),em(1)),(pcm1(1),pcm(1,1))
5804       logical wri
5805       data twopi/6.2831853073/
5806       external hnbiiw
5807 ctp060829      nas=5 !must be at least 3
5808       wri=.false.
5809       if(ish.ge.7)wri=.true.
5810       if(wri)then
5811         write(ifch,*)('-',i=1,10)
5812      *,' entry sr hnbody ',('-',i=1,30)
5813         write(ifch,1200)np,tecm
5814         write(ifch,*)'particle masses:'
5815         write(ifch,'(1x,10f6.3)')(amass(n),n=1,np)
5816       endif
5817
5818 c..... initialization
5819
5820       ktnbod=ktnbod + 1
5821       if(ktnbod.le.1)then
5822         !... ffq(n) = pi * (twopi)**(n-2) / (n-2)!
5823         ffqlog(1)=-1e35
5824         ffqlog(2)=alog(pi)
5825         do n=3,maxp
5826         ffqlog(n)=ffqlog(n-1)+log(twopi/(n-2))
5827         enddo
5828       endif
5829
5830       if(nt.lt.2) goto 1001
5831       if(nt.gt.maxp) goto 1002
5832       ntm1=nt-1
5833       ntm2=nt-2
5834       ntnm4=3*nt - 4
5835       emm(1)=em(1)
5836       tm=0.0
5837       do 2 i=1,nt
5838       ems(i)=em(i)**2
5839       tm=tm+em(i)
5840     2 sm(i)=tm
5841       tecmtm=tecm-tm
5842       if(tecmtm.le.0.0) goto 1000
5843       emm(nt)=tecm
5844       wtmlog=alog(tecmtm)*ntm2 + ffqlog(nt) - alog(tecm)
5845
5846 c...fill rno with 3*nt-4 random numbers, the first nt-2 being ordered
5847
5848       do 3 i= 1, ntnm4
5849     3 rno(i)=rangen()
5850       if(ntm2) 9,5,4
5851     4 continue
5852       call flpsore(rno,ntm2)
5853
5854 c...calculate emm().......M_i
5855
5856       do 6 j=2,ntm1
5857     6 emm(j)=rno(j-1)*tecmtm+sm(j)
5858
5859 c...calculate wtlog
5860
5861     5 continue
5862       wtxlog=wtmlog
5863       ir=ntm2
5864       do 7 i=1,ntm1
5865         pd(i)=hnbpdk(emm(i+1),emm(i),em(i+1))
5866         if(pd(i).gt.0.)then
5867           pdlog=alog(pd(i))
5868         else
5869           pdlog=-1e35
5870         endif
5871         wtxlog=wtxlog+pdlog
5872     7 continue
5873
5874 c...complete specification of event (raubold-lynch method)
5875
5876       pcm(1,1)=0.0
5877       pcm(2,1)=pd(1)
5878       pcm(3,1)=0.0
5879       do i=2,nt
5880         pcm(1,i)=0.0
5881         pcm(2,i)=-pd(i-1)
5882         pcm(3,i)=0.0
5883         ir=ir+1
5884         bang=twopi*rno(ir)
5885         cb=cos(bang)
5886         sb=sin(bang)
5887         ir=ir+1
5888         c=2.0*rno(ir)-1.0
5889         s=sqrt(1.0-c*c)
5890         if(i.ne.nt)then
5891           esys=sqrt(pd(i)**2+emm(i)**2)
5892           beta=pd(i)/esys
5893           gama=esys/emm(i)
5894           do j=1,i
5895             ndx=5*j - 5
5896             aa= pcm1(ndx+1)**2 + pcm1(ndx+2)**2 + pcm1(ndx+3)**2
5897             pcm1(ndx+5)=sqrt(aa)
5898             pcm1(ndx+4)=sqrt(aa+ems(j))
5899             call hnbrt2(c,s,cb,sb,pcm,j)
5900             psave=gama*(pcm(2,j)+beta*pcm(4,j))
5901             pcm(2,j)=psave
5902           enddo
5903         else !(i.eq.nt)
5904           do j=1,i
5905             aa=pcm(1,j)**2 + pcm(2,j)**2 + pcm(3,j)**2
5906             pcm(5,j)=sqrt(aa)
5907             pcm(4,j)=sqrt(aa+ems(j))
5908             call hnbrt2(c,s,cb,sb,pcm,j)
5909           enddo
5910         endif
5911       enddo
5912
5913 c...returns
5914
5915   9   continue
5916       goto1111
5917
5918  1000 continue
5919       if(wri)
5920      *write(ifch,*)'available energy zero or negative -> wtxlog=-1e35'
5921       wtxlog=-1e35
5922       goto1111
5923
5924  1001 continue
5925       if(wri)
5926      *write(ifch,*)'less than 2 outgoing particles -> wtxlog=-1e35'
5927       wtxlog=-1e35
5928       goto1111
5929
5930  1002 continue
5931       write(ifch,*)'too many outgoing particles'
5932  1050 write(ifch,1150) ktnbod
5933  1150 format(47h0 above error detected in hnbody at call number,i7)
5934       write(ifch,1200) np,tecm
5935  1200 format(' np:',i6/' tecm:',f10.5)
5936       write(ifch,*)'particle masses:'
5937       write(ifch,'(1x,10f6.3)')(amass(jk),jk=1,np)
5938       stop
5939
5940 1111  continue
5941       if(wri)write(ifch,*)('-',i=1,30)
5942      *,' exit sr hnbody ',('-',i=1,10)
5943       return
5944       end
5945
5946 c---------------------------------------------------------------------------------------------------------
5947       SUBROUTINE FLPSORE(A,N)
5948 C---------------------------------------------------------------------------------------------------------
5949 C CERN PROGLIB# M103    FLPSOR          .VERSION KERNFOR  3.15  820113
5950 C ORIG. 29/04/78
5951 C
5952 C   SORT THE ONE-DIMENSIONAL FLOATING POINT ARRAY A(1),...,A(N) BY
5953 C   INCREASING VALUES
5954 C
5955 C-    PROGRAM  M103  TAKEN FROM CERN PROGRAM LIBRARY,  29-APR-78
5956 C----------------------------------------------------------------------------------------------------------
5957       DIMENSION A(N)
5958       COMMON /SLATE/ LT(20),RT(20)
5959       INTEGER R,RT
5960 C
5961       LEVEL=1
5962       LT(1)=1
5963       RT(1)=N
5964    10 L=LT(LEVEL)
5965       R=RT(LEVEL)
5966       LEVEL=LEVEL-1
5967    20 IF(R.GT.L) GO TO 200
5968       IF(LEVEL) 50,50,10
5969 C
5970 C   SUBDIVIDE THE INTERVAL L,R
5971 C     L : LOWER LIMIT OF THE INTERVAL (INPUT)
5972 C     R : UPPER LIMIT OF THE INTERVAL (INPUT)
5973 C     J : UPPER LIMIT OF LOWER SUB-INTERVAL (OUTPUT)
5974 C     I : LOWER LIMIT OF UPPER SUB-INTERVAL (OUTPUT)
5975 C
5976   200 I=L
5977       J=R
5978       M=(L+R)/2
5979       X=A(M)
5980   220 IF(A(I).GE.X) GO TO 230
5981       I=I+1
5982       GO TO 220
5983   230 IF(A(J).LE.X) GO TO 231
5984       J=J-1
5985       GO TO 230
5986 C
5987   231 IF(I.GT.J) GO TO 232
5988       W=A(I)
5989       A(I)=A(J)
5990       A(J)=W
5991       I=I+1
5992       J=J-1
5993       IF(I.LE.J) GO TO 220
5994 C
5995   232 LEVEL=LEVEL+1
5996       IF((R-I).GE.(J-L)) GO TO 30
5997       LT(LEVEL)=L
5998       RT(LEVEL)=J
5999       L=I
6000       GO TO 20
6001    30 LT(LEVEL)=I
6002       RT(LEVEL)=R
6003       R=J
6004       GO TO 20
6005    50 continue
6006
6007       do i=1,n-1
6008         if(a(i).gt.a(i+1))stop'FLPSORE: ERROR.                    '
6009       enddo
6010
6011       RETURN
6012       END
6013
6014
6015
6016
6017
6018 c-------------------------------------------------------------
6019       subroutine hnbodz
6020 c-------------------------------------------------------------
6021 c   subr to generate n-body event
6022 c   according to non-invariant phase space.
6023 c   the phase space integral is the sum over the weights exp(wtxlog)
6024 c   divided by the number of events.
6025 c   ref.: hagedorn, nuov. cim. suppl ix, x (1958) 646.
6026 c   events are generated in their own center-of-mass.
6027 c
6028 c   input to and output from subr is thru common block config.
6029 c   input:
6030 c             np=number of outgoing particles
6031 c             tecm=total energy in center-of-mass
6032 c             amass(i)=mass of ith outgoing particle
6033 c   output:
6034 c             pcm(1,i)=x-momentum of ith particle
6035 c             pcm(2,i)=y-momentum of ith particle
6036 c             pcm(3,i)=z-momentum of ith particle
6037 c             pcm(4,i)=energy of ith particle
6038 c             pcm(5,i)=momentum of ith particle
6039 c             wtxlog=log of weight of event
6040 c--------------------------------------------------------------
6041       include 'epos.inc'
6042       parameter(maxp=500)
6043       common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
6044       common /clatt/nlattc,npmax
6045       common/cffq/ffqlog(maxp)
6046       dimension ti(maxp),xi(maxp),si(maxp),zi(maxp)
6047       common/crnoz/rnoz(maxp-1)
6048       double precision ps(5)
6049
6050       call utpri('hnbodz',ish,ishini,6)
6051       if(ish.ge.6)write(ifch,1200)np,tecm
6052       if(ish.ge.6)write(ifch,*)'particle masses:'
6053       if(ish.ge.6)write(ifch,'(1x,10f6.3)')(amass(n),n=1,np)
6054
6055 c initialization ktnbod=1
6056       ktnbod=ktnbod + 1
6057       if(ktnbod.gt.1) goto 1
6058 c     !ffqlog(n) = log{ (4*pi)**n  / (n-1)! }
6059       ffqlog(1)=alog(4*pi)
6060       do n=2,maxp
6061       ffqlog(n)=ffqlog(n-1)+alog(4*pi/(n-1))
6062       enddo
6063     1 continue
6064 c set wtxlog -infinity for np<2
6065       if(np.lt.2) goto 1001
6066 c special treatment for np=2
6067       if(np.eq.2)then
6068       if(tecm.lt.amass(1)+amass(2)+0.00001)goto1000
6069       p0=utpcm(tecm,amass(1),amass(2))
6070       wtxlog=alog( 4*pi*p0
6071      */(1/sqrt(amass(1)**2+p0**2)+1/sqrt(amass(2)**2+p0**2)) )
6072       if(ish.ge.7)
6073      *write(ifch,*)'wtxlog:',wtxlog,'   (np=2 treatment)'
6074       bang=2*pi*rangen()
6075       cb=cos(bang)
6076       sb=sin(bang)
6077       c=2.0*rangen()-1.0
6078       s=sqrt(1.0-c*c)
6079       do 9 i=1,2
6080       is=2*i-3
6081       pcm(5,i)=p0
6082       pcm(1,i)=is*pcm(5,i)*s*cb
6083       pcm(2,i)=is*pcm(5,i)*s*sb
6084       pcm(3,i)=is*pcm(5,i)*c
6085       pcm(4,i)=sqrt(amass(i)**2+p0**2)
6086     9 continue
6087       goto1111
6088       endif
6089 c stop if np too large
6090       if(np.gt.maxp) goto 1002
6091 c initialization all ktnbod
6092       tm=0.0
6093       do 2 i=1,np
6094       tm=tm+amass(i)
6095     2 continue
6096       tt=tecm-tm
6097       if(tt.le.0.0) goto 1000
6098 c prefactor
6099       wtxlog=alog(tt)*(np-1) + ffqlog(np)
6100       if(ish.ge.7)
6101      *write(ifch,*)'wtxlog:',wtxlog,'   (prefactor)'
6102 c fill rnoz with np-1 random numbers
6103       if(keepr.eq.0)then
6104       do 3 i= 1, np-1
6105     3 rnoz(i)=rangen()
6106       else
6107       do lo=1,iomom
6108       j=1+rangen()*nlattc
6109       rnoz(j)=rangen()
6110       enddo
6111       endif
6112 c calculate z_i distributed as i*z*(i-1)
6113       do i= 1, np-1
6114       zi(i)=rnoz(i)**(1./i)
6115       enddo
6116 c calculate x_i
6117       xi(np)=1
6118       do i=np-1,1,-1
6119       xi(i)=zi(i)*xi(i+1)
6120       enddo
6121 c calculate t_i, e_i, p_i
6122       if(ish.ge.9)write(ifch,*)'calculate t_i, e_i, p_i ...'
6123       do i=1,np-1
6124       si(i)=xi(i)*tt
6125       enddo
6126       ti(1)=si(1)
6127       if(ti(1).le.0.)ti(1)=1e-10
6128       ti(np)=tt-si(np-1)
6129       if(ti(np).le.0.)ti(np)=1e-10
6130       do i=np-1,2,-1
6131       ti(i)=si(i)-si(i-1)
6132       if(ti(i).le.0.)ti(i)=1e-10
6133       enddo
6134       do i=1,np
6135       pcm(1,i)=0
6136       pcm(2,i)=0
6137       pcm(3,i)=0
6138       pcm(4,i)=ti(i)+amass(i)
6139       p52=ti(i)*(ti(i)+2*amass(i))
6140       if(p52.gt.0)then
6141       pcm(5,i)=sqrt(p52)
6142       else
6143       pcm(5,i)=ti(i)*sqrt(1+2*amass(i)/ti(i))
6144       endif
6145       enddo
6146 c calculate wtxlog
6147       call hnbraw(7,200,w)
6148       if(w.gt.0.)then
6149       wtxlog=wtxlog+alog(w)
6150       else
6151       wtxlog=wtxlog-1e+30
6152       endif
6153       do 7 i=1,np
6154       wtxlog=wtxlog+alog(pcm(5,i))+alog(ti(i)+amass(i))
6155     7 continue
6156       if(ish.ge.7)
6157      *write(ifch,*)'wtxlog:',wtxlog
6158 c print
6159       if(ish.ge.7)then
6160       write(ifch,*)'momenta:'
6161       do j=1,4
6162       ps(j)=0
6163       enddo
6164       do i=1,np
6165       do j=1,4
6166       ps(j)=ps(j)+pcm(j,i)
6167       enddo
6168       write(ifch,'(1x,i3,5x,5f12.5)')i,(pcm(j,i),j=1,5)
6169       enddo
6170       ps(5)=dsqrt(ps(1)**2+ps(2)**2+ps(3)**2)
6171       write(ifch,'(1x,a4,8x,5f12.5)')'sum:',(sngl(ps(j)),j=1,5)
6172       endif
6173       if(w.le.0.)goto1111
6174 c complete specification of event (random rotations and then deformations)
6175       call hnbrot
6176       if(ish.ge.7)write(ifch,*)'momenta after rotations:'
6177       call hnbrop(96,0)
6178       call hnbrod
6179       if(ish.ge.7)write(ifch,*)'momenta after deformations:'
6180       call hnbrop(96,1)
6181       goto1111
6182
6183 c error returns
6184  1000 continue
6185       if(ish.ge.6)
6186      *write(ifch,*)'available energy zero or negative -> wtxlog=-1e35'
6187       wtxlog=-1e35
6188       goto1111
6189
6190  1001 continue
6191       if(ish.ge.6)
6192      *write(ifch,*)'less than 2 outgoing particles -> wtxlog=-1e35'
6193       wtxlog=-1e35
6194       goto1111
6195
6196  1002 continue
6197       write(ifch,*)'too many outgoing particles'
6198  1050 write(ifch,1150) ktnbod
6199  1150 format(47h0 above error detected in hnbody at call number,i7)
6200       write(ifch,1200) np,tecm
6201  1200 format(' np:',i6/' tecm:',f10.5)
6202       write(ifch,*)'particle masses:'
6203       write(ifch,'(1x,10f6.3)')(amass(jk),jk=1,np)
6204       stop
6205
6206 1111  continue
6207       call utprix('hnbodz',ish,ishini,6)
6208       return
6209       end
6210
6211 c-----------------------------------------------------------------------
6212       subroutine hnbolo(loops)
6213 c-----------------------------------------------------------------------
6214 c  loop over hnbody
6215 c-----------------------------------------------------------------------
6216       include 'epos.inc'
6217       parameter(maxp=500)
6218       common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
6219       a=0
6220       k=0
6221       do j=1,loops
6222 c-c   if(mod(j,iterpr).eq.0)write(ifmt,*)'     iteration:',iter,j
6223       if(iocova.eq.1)call hnbody
6224       if(iocova.eq.2)call hnbodz
6225       if(ish.ge.8)write(ifch,*)'j:',j,'   wtxlog:',wtxlog
6226            if(wtxlog.gt.-1e30)then
6227       k=k+1
6228       if(k.eq.1)c=wtxlog
6229            if(a.gt.0.)then
6230       if(alog(a).lt.wtxlog-c-20)then
6231       a=0
6232       c=wtxlog
6233       endif
6234            endif
6235       a=a+exp(wtxlog-c)
6236            endif
6237       if(ish.ge.8)write(ifch,*)'k:',k,'   c:',c
6238       enddo
6239       a=a/loops
6240       wtxlog=alog(a)+c
6241       return
6242       end
6243
6244 c-----------------------------------------------------------------------
6245       function hnbpdk(a,b,c)
6246 c-----------------------------------------------------------------------
6247 c  formerly pdk from cernlib
6248 c  returns momentum p for twobody decay  a --> b + c
6249 c           a, b, c are the three masses
6250 c~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
6251 c  this p is related to twobody phase space as R2 = pi * p /a
6252 c-----------------------------------------------------------------------
6253       double precision aa,bb,cc,a2,b2,c2
6254       aa=a
6255       bb=b
6256       cc=c
6257       a2=aa*aa
6258       b2=bb*bb
6259       c2=cc*cc
6260       if(a2 + (b2-c2)**2/a2-2.0*(b2+c2).le.0.)then
6261       hnbpdk = 0
6262       else
6263       hnbpdk = 0.5*dsqrt(a2 + (b2-c2)**2/a2 - 2.0*(b2+c2))
6264       endif
6265       return
6266       end
6267
6268 c----------------------------------------------------------------------
6269       subroutine hnbpad(k,n1,n2,n3,n4,mm,jc)
6270 c----------------------------------------------------------------------
6271 c  k=1: determ pair indices k1,k2
6272 c  k=2: determ pair indices k3,k4 (.ne. n1,n2)
6273 c  k=1 and k=2: mm: type of pair, jc: flavour of pair
6274 c----------------------------------------------------------------------
6275       include 'epos.inc'
6276       integer jc(nflav,2),ic(2),jc1(nflav,2),ic1(2),jc2(nflav,2),ic2(2)
6277       common /clatt/nlattc,npmax
6278       parameter(maxp=500)
6279       common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
6280
6281       if(k.eq.2)then
6282       k1=n1
6283       k2=n2
6284       endif
6285
6286 c     determine n1,n2 and mm
6287 c     ----------------------
6288     1 continue
6289       n1=1+rangen()*nlattc
6290       n1=min(n1,nlattc)
6291     2 continue
6292       n2=1+rangen()*nlattc
6293       n2=min(n2,nlattc)
6294       if(n2.eq.n1)goto2
6295       if(n2.lt.n1)then
6296       n1r=n1
6297       n1=n2
6298       n2=n1r
6299       endif
6300       if(k.eq.2)then
6301       if(n1.eq.k1.or.n1.eq.k2.or.n2.eq.k1.or.n2.eq.k2)goto1
6302       endif
6303       if(ident(n1).ne.0.and.ident(n2).ne.0)mm=1  ! hadron-hadron
6304       if(ident(n1).ne.0.and.ident(n2).eq.0)mm=2  ! hadron-empty
6305       if(ident(n1).eq.0.and.ident(n2).ne.0)mm=2  ! empty-hadron
6306       if(ident(n1).eq.0.and.ident(n2).eq.0)mm=3  ! empty-empty
6307       if(ish.ge.7)then
6308         write(ifch,'(a,i2)')' mm:',mm
6309         write(ifch,*)'to be replaced:',n1,ident(n1)
6310         write(ifch,*)'to be replaced:',n2,ident(n2)
6311       endif
6312
6313 c     flavour of n1+n2 --> jc
6314 c     -----------------------
6315            if(mm.eq.1)then
6316       call idtr4(ident(n1),ic1)
6317       call iddeco(ic1,jc1)
6318       call idtr4(ident(n2),ic2)
6319       call iddeco(ic2,jc2)
6320       do i=1,nflav
6321       do j=1,2
6322       jc(i,j)=jc1(i,j)+jc2(i,j)
6323       enddo
6324       enddo
6325            elseif(mm.eq.2.and.ident(n1).ne.0)then
6326       call idtr4(ident(n1),ic)
6327       call iddeco(ic,jc)
6328            elseif(mm.eq.2.and.ident(n2).ne.0)then
6329       call idtr4(ident(n2),ic)
6330       call iddeco(ic,jc)
6331            else
6332       do i=1,nflav
6333       do j=1,2
6334       jc(i,j)=0
6335       enddo
6336       enddo
6337            endif
6338
6339       if(k.eq.2)then
6340       n3=n1
6341       n4=n2
6342       endif
6343
6344       return
6345       end
6346
6347 c----------------------------------------------------------------------
6348       subroutine hnbpai(id1,id2,jc)
6349 c----------------------------------------------------------------------
6350 c  returns arbitrary hadron pair id1,id2, flavour written to jc
6351 c----------------------------------------------------------------------
6352       include 'epos.inc'
6353       integer jc(nflav,2),jc1(nflav,2),ic1(2),jc2(nflav,2),ic2(2)
6354       parameter (mspecs=56)
6355       common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
6356
6357 c     construct pair id1,id2
6358 c     ----------------------
6359       i1=rangen()*(nspecs+iozero)-(iozero-1)
6360       i1=max(i1,0)
6361       i1=min(i1,nspecs)
6362       if(i1.eq.0)then
6363       id1=0
6364       do i=1,nflav
6365       do j=1,2
6366       jc1(i,j)=0
6367       enddo
6368       enddo
6369       else
6370       id1=ispecs(i1)
6371       call idtr4(id1,ic1)
6372       call iddeco(ic1,jc1)
6373       endif
6374       if(ish.ge.7)write(ifch,'(1x,a,i3,a,i5,a,6i2,3x,6i2)')
6375      *'i1:',i1,'   id1:',id1,'   jc1:',jc1
6376       i2=rangen()*(nspecs+iozero)-(iozero-1)
6377       i2=max(i2,0)
6378       i2=min(i2,nspecs)
6379       if(i2.eq.0)then
6380       id2=0
6381       do i=1,nflav
6382       do j=1,2
6383       jc2(i,j)=0
6384       enddo
6385       enddo
6386       else
6387       id2=ispecs(i2)
6388       call idtr4(id2,ic2)
6389       call iddeco(ic2,jc2)
6390       endif
6391       if(ish.ge.7)write(ifch,'(1x,a,i3,a,i5,a,6i2,3x,6i2)')
6392      *'i2:',i2,'   id2:',id2,'   jc2:',jc2
6393       if(ish.ge.7)write(ifch,'(a,i6,i6)')' pair:',id1,id2
6394
6395 c     determine jc
6396 c     ------------
6397       do i=1,nflav
6398       do j=1,2
6399       jc(i,j)=jc1(i,j)+jc2(i,j)
6400       enddo
6401       enddo
6402       do i=1,nflav
6403       j12=jc(i,1)-jc(i,2)
6404       if(j12.ge.0)then
6405       jc(i,1)=j12
6406       jc(i,2)=0
6407       else
6408       jc(i,1)=0
6409       jc(i,2)=-j12
6410       endif
6411       enddo
6412       if(ish.ge.7)write(ifch,'(a,6i2,3x,6i2)')' jc:',jc
6413
6414       return
6415       end
6416
6417 c----------------------------------------------------------------------
6418       subroutine hnbpaj(jc,iwpair,id1,id2)
6419 c----------------------------------------------------------------------
6420 c  returns sum of weights iwpair of possible pairs
6421 c  and randomly chosen hadron pair id1,id2 for given flavour jc
6422 c----------------------------------------------------------------------
6423       include 'epos.inc'
6424       parameter(mspecs=56,mxids=200)
6425       parameter(mxpair=mspecs**2*4)
6426       common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
6427       common/cspec2/jspecs(2,nflav,mspecs)
6428       common/cspec3/lkfok(8,-3:3,-3:3,-3:3,-3:3)  !-charm
6429       common/cspec5/idpairst(2,mxpair,3**6),iwtpaist(0:mxpair,3**6)
6430      &              ,idxpair(0:2,0:2,0:2,-1:1,-1:1,-1:1),ipairst(3**6)
6431       common/cflac/ifok(nflav,mspecs),ifoa(nflav)
6432       dimension ids(mxids),iwts(mxids),jc(nflav,2)!,jc2(nflav,2)
6433       dimension idpair(2,mxpair),iwtpai(mxpair)
6434       dimension jc1mi2(nflav),jcmi(nflav)
6435
6436 c      nflv=nflav
6437 c      if(nflv.gt.6)
6438 c     *call utstop('hnbpaj: nflav.gt.6: modify this routine&')
6439
6440 c     construct possible pairs id1,id2
6441 c     --------------------------------
6442
6443       ipair=0
6444       iwpair=0
6445       idx=0
6446       if(jc(1,1).gt.2)then
6447         goto 1
6448       elseif(jc(1,1).lt.0)then
6449         goto 1
6450       elseif(jc(2,1).gt.2)then
6451         goto 1
6452       elseif(jc(2,1).lt.0)then
6453         goto 1
6454       elseif(jc(3,1).gt.2)then
6455         goto 1
6456       elseif(jc(3,1).lt.0)then
6457         goto 1
6458       elseif(jc(1,2).gt.1)then
6459         goto 1
6460       elseif(jc(1,2).lt.-1)then
6461         goto 1
6462       elseif(jc(2,2).gt.1)then
6463         goto 1
6464       elseif(jc(2,2).lt.-1)then
6465         goto 1
6466       elseif(jc(3,2).gt.1)then
6467         goto 1
6468       elseif(jc(3,2).lt.-1)then
6469         goto 1
6470       elseif((abs(jc(4,1))+abs(jc(5,1))+abs(jc(6,1))+abs(jc(4,2))
6471      &       +abs(jc(5,2))+abs(jc(6,2))).gt.0)then
6472         goto 1
6473       endif
6474       idx=idxpair(jc(1,1),jc(2,1),jc(3,1),jc(1,2),jc(2,2),jc(3,2))
6475       ipair=ipairst(idx)
6476       if(ipair.eq.0)return
6477       iwpair=iwtpaist(0,idx)
6478       do i=1,ipair
6479         idpair(1,i)=idpairst(1,i,idx)
6480         idpair(2,i)=idpairst(2,i,idx)
6481         iwtpai(i)=iwtpaist(i,idx)
6482       enddo
6483       goto 4           !pair fixed via table
6484
6485 c  id1=0:
6486  1    continue
6487       if(nspecs+1.gt.mxids)call utstop('hnbpaj: mxids too small&')
6488
6489       jc1mi2(1)=jc(1,1)-jc(1,2)
6490       jc1mi2(2)=jc(2,1)-jc(2,2)
6491       jc1mi2(3)=jc(3,1)-jc(3,2)
6492       jc1mi2(4)=jc(4,1)-jc(4,2)
6493       jc1mi2(5)=jc(5,1)-jc(5,2)
6494       jc1mi2(6)=jc(6,1)-jc(6,2)
6495
6496       nids=0
6497
6498       if(jc1mi2(1).ne.0)goto11
6499       if(jc1mi2(2).ne.0)goto11
6500       if(jc1mi2(3).ne.0)goto11
6501       if(jc1mi2(4).ne.0)goto11
6502       if(jc1mi2(5).ne.0)goto11
6503       if(jc1mi2(6).ne.0)goto11
6504       nids=nids+1
6505       ids(nids)=0
6506       iwts(nids)=iozero
6507    11 continue
6508
6509       do j=1,nspecs
6510       if(jc1mi2(1).ne.ifok(1,j))goto22
6511       if(jc1mi2(2).ne.ifok(2,j))goto22
6512       if(jc1mi2(3).ne.ifok(3,j))goto22
6513       if(jc1mi2(4).ne.ifok(4,j))goto22
6514       if(jc1mi2(5).ne.ifok(5,j))goto22
6515       if(jc1mi2(6).ne.ifok(6,j))goto22
6516       nids=nids+1
6517       ids(nids)=ispecs(j)
6518       iwts(nids)=1
6519    22 continue
6520       enddo
6521
6522       if(nids.eq.0)goto2
6523       if(nids.gt.mxpair)call utstop('hnbpaj: mxpair too small&')
6524       do k=1,nids
6525       ipair=ipair+1
6526       idpair(1,ipair)=0
6527       idpair(2,ipair)=ids(k)
6528       iwtpai(ipair)=iozero*iwts(k)
6529       iwpair=iwpair+iwtpai(ipair)
6530 c      if(ish.ge.6)write(ifch,'(a,i5,5x,a,i6,i6,5x,a,i6)')' pair nr:'
6531 c     *,ipair,'ids:',0,ids(k),'weight:',iwtpai(ipair)
6532       enddo
6533     2 continue
6534
6535 c  id1>0:
6536
6537         do i1=1,nspecs
6538
6539 c        if(ish.ge.6)then
6540 c        do i=1,nflav
6541 c      jc2(i,1)=jc(i,1)-jspecs(1,i,i1)
6542 c      jc2(i,2)=jc(i,2)-jspecs(2,i,i1)
6543 c        enddo
6544 c      write(ifch,'(1x,a,i3,a,i6,a,6i2,3x,6i2)')
6545 c     *'i1:',i1,'   id1:',ispecs(i1),'   jc1:'
6546 c     *,(jspecs(1,i,i1),i=1,6),(jspecs(2,i,i1),i=1,6)
6547 c      write(ifch,'(a,6i2,3x,6i2)')' jc2:',jc2
6548 c        endif
6549
6550       jcmi(1)=jc1mi2(1)-jspecs(1,1,i1)+jspecs(2,1,i1)
6551       jcmi(2)=jc1mi2(2)-jspecs(1,2,i1)+jspecs(2,2,i1)
6552       jcmi(3)=jc1mi2(3)-jspecs(1,3,i1)+jspecs(2,3,i1)
6553       jcmi(4)=jc1mi2(4)-jspecs(1,4,i1)+jspecs(2,4,i1)
6554       jcmi(5)=jc1mi2(5)-jspecs(1,5,i1)+jspecs(2,5,i1)
6555       jcmi(6)=jc1mi2(6)-jspecs(1,6,i1)+jspecs(2,6,i1)
6556 c-charm      if(jcmi(4).ne.0)stop'HNBPAJ: c not treated'
6557       if(jcmi(5).ne.0)stop'HNBPAJ: b not treated'
6558       if(jcmi(6).ne.0)stop'HNBPAJ: t not treated'
6559
6560       nids=0
6561
6562       if(abs(jcmi(1)).gt.3)goto3
6563       if(abs(jcmi(2)).gt.3)goto3
6564       if(abs(jcmi(3)).gt.3)goto3
6565       if(abs(jcmi(4)).gt.3)goto3   !-charm
6566
6567       if(jcmi(1).ne.0)goto111
6568       if(jcmi(2).ne.0)goto111
6569       if(jcmi(3).ne.0)goto111
6570       if(jcmi(4).ne.0)goto111  !-charm
6571       nids=nids+1
6572       ids(nids)=0
6573       iwts(nids)=iozero
6574   111 continue
6575
6576       lkfok1=lkfok(1,jcmi(1),jcmi(2),jcmi(3),jcmi(4))
6577       if(lkfok1.gt.0)then
6578        nids=nids+1
6579        ids(nids)=lkfok(2,jcmi(1),jcmi(2),jcmi(3),jcmi(4))
6580        iwts(nids)=1
6581        if(lkfok1.gt.1)then
6582         nids=nids+1
6583         ids(nids)=lkfok(3,jcmi(1),jcmi(2),jcmi(3),jcmi(4))
6584         iwts(nids)=1
6585         if(lkfok1.gt.2)then
6586          if(lkfok1.gt.7)       !-charm
6587      *   stop'HNBPAJ: dimension of lkfok too small'
6588          do ii=3,lkfok1
6589          nids=nids+1
6590          ids(nids)=lkfok(1+ii,jcmi(1),jcmi(2),jcmi(3),jcmi(4))
6591          iwts(nids)=1
6592          enddo
6593         endif
6594        endif
6595       endif
6596
6597 c             do j=1,nspecs
6598 c      if(jcmi(1).ne.ifok(1,j))goto222
6599 c      if(jcmi(2).ne.ifok(2,j))goto222
6600 c      if(jcmi(3).ne.ifok(3,j))goto222
6601 c      if(jcmi(4).ne.ifok(4,j))goto222
6602 c      if(jcmi(5).ne.ifok(5,j))goto222
6603 c      if(jcmi(6).ne.ifok(6,j))goto222
6604 c      nids=nids+1
6605 c      ids(nids)=ispecs(j)
6606 c      iwts(nids)=1
6607 c  222 continue
6608 c             enddo
6609
6610       if(nids.eq.0)goto3
6611       if(ipair+nids.gt.mxpair)call utstop('hnbpaj: mxpair too small&')
6612       do k=1,nids
6613       ipair=ipair+1
6614       idpair(1,ipair)=ispecs(i1)
6615       idpair(2,ipair)=ids(k)
6616       iwtpai(ipair)=iwts(k)
6617       iwpair=iwpair+iwtpai(ipair)
6618       enddo
6619       if(ish.ge.7)then
6620       ipair0=ipair-nids
6621       do k=1,nids
6622       ipair0=ipair0+1
6623       write(ifch,'(a,i5,5x,a,i6,i6,5x,a,i6)')' pair nr:'
6624      *,ipair0,'ids:',ispecs(i1),ids(k),'weight:',iwtpai(ipair0)
6625       enddo
6626       endif
6627     3 continue
6628
6629         enddo
6630
6631 c     no pair found
6632 c     -------------
6633       if(ipair.eq.0)then
6634       if(iwpair.ne.0)call utstop('hnbpaj: iwpair.ne.0&')
6635       return
6636       endif
6637
6638
6639  4    continue
6640 c     select pair
6641 c     -----------
6642       r=rangen()
6643       ir=1+r*iwpair
6644       ir=min(ir,iwpair)
6645       is=0
6646       do ip=1,ipair
6647       is=is+iwtpai(ip)
6648       if(ir.le.is)then
6649       id1=idpair(1,ip)
6650       id2=idpair(2,ip)
6651 c      if(ish.ge.6)write(ifch,*)'random number:',r
6652 c     *,' --> chosen pair:',ip
6653       goto 1000
6654       endif
6655       enddo
6656       write(ifmt,*)'hnbpaj:',jc,idx,ipair,iwpair,r,ir
6657       call utstop('hnbpaj: no pair selected&')
6658
6659 1000  continue
6660
6661       return
6662       end
6663
6664 c----------------------------------------------------------------------
6665       subroutine hnbpajini
6666 c----------------------------------------------------------------------
6667 c  initialize array to speed up hnbpaj calculation
6668 c  store sum of weights iwpair of possible pairs in an array
6669 c  for any combinations of quarks
6670 c----------------------------------------------------------------------
6671       include 'epos.inc'
6672       parameter(mspecs=56,mxids=200)
6673       parameter(mxpair=mspecs**2*4)
6674       common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
6675       common/cspec2/jspecs(2,nflav,mspecs)
6676       common/cspec3/lkfok(8,-3:3,-3:3,-3:3,-3:3)  !-charm
6677       common/cspec5/idpairst(2,mxpair,3**6),iwtpaist(0:mxpair,3**6)
6678      &              ,idxpair(0:2,0:2,0:2,-1:1,-1:1,-1:1),ipairst(3**6)
6679       common/cflac/ifok(nflav,mspecs),ifoa(nflav)
6680       dimension ids(mxids),iwts(mxids)
6681       dimension jc1mi2(3),jcmi(4)
6682
6683
6684 c      write(ifmt,*)' Initialize droplet decay ...'
6685
6686 c     construct possible pairs id1,id2
6687 c     --------------------------------
6688       idx=0
6689       do iaqs=-1,1
6690         do iaqd=-1,1
6691           do iaqu=-1,1
6692             do iqs=0,2
6693               do iqd=0,2
6694                 do iqu=0,2
6695
6696       idx=idx+1
6697       idxpair(iqu,iqd,iqs,iaqu,iaqd,iaqs)=idx
6698
6699       ipair=0
6700       iwtpaist(0,idx)=0
6701       do i=1,mxids
6702         ids(i)=0
6703         iwts(i)=0
6704       enddo
6705       do i=1,mxpair
6706         idpairst(1,i,idx)=0
6707         idpairst(2,i,idx)=0
6708         iwtpaist(i,idx)=0
6709       enddo
6710
6711 c  id1=0:
6712
6713       if(nspecs+1.gt.mxids)call utstop('hnbpajini: mxids too small&')
6714
6715       jc1mi2(1)=iqu-iaqu
6716       jc1mi2(2)=iqd-iaqd
6717       jc1mi2(3)=iqs-iaqs
6718
6719       nids=0
6720
6721       if(jc1mi2(1).ne.0)goto11
6722       if(jc1mi2(2).ne.0)goto11
6723       if(jc1mi2(3).ne.0)goto11
6724       nids=nids+1
6725       ids(nids)=0
6726       iwts(nids)=iozero
6727    11 continue
6728
6729       do j=1,nspecs
6730       if(jc1mi2(1).ne.ifok(1,j))goto22
6731       if(jc1mi2(2).ne.ifok(2,j))goto22
6732       if(jc1mi2(3).ne.ifok(3,j))goto22
6733       nids=nids+1
6734       ids(nids)=ispecs(j)
6735       iwts(nids)=1
6736    22 continue
6737       enddo
6738
6739       if(nids.eq.0)goto2
6740       if(nids.gt.mxpair)call utstop('hnbpajini: mxpair too small&')
6741       do k=1,nids
6742       ipair=ipair+1
6743       idpairst(1,ipair,idx)=0
6744       idpairst(2,ipair,idx)=ids(k)
6745       iwtpaist(ipair,idx)=iozero*iwts(k)
6746       iwtpaist(0,idx)=iwtpaist(0,idx)+iwtpaist(ipair,idx)
6747 c      if(ish.ge.6)write(ifch,'(a,i5,5x,a,i6,i6,5x,a,i6)')' pair nr:'
6748 c     *,ipair,'ids:',0,ids(k),'weight:',iwtpai(ipair)
6749       enddo
6750     2 continue
6751
6752 c  id1>0:
6753
6754         do i1=1,nspecs
6755
6756 c        if(ish.ge.6)then
6757 c        do i=1,nflav
6758 c      jc2(i,1)=jc(i,1)-jspecs(1,i,i1)
6759 c      jc2(i,2)=jc(i,2)-jspecs(2,i,i1)
6760 c        enddo
6761 c      write(ifch,'(1x,a,i3,a,i6,a,6i2,3x,6i2)')
6762 c     *'i1:',i1,'   id1:',ispecs(i1),'   jc1:'
6763 c     *,(jspecs(1,i,i1),i=1,6),(jspecs(2,i,i1),i=1,6)
6764 c      write(ifch,'(a,6i2,3x,6i2)')' jc2:',jc2
6765 c        endif
6766
6767       jcmi(1)=jc1mi2(1)-jspecs(1,1,i1)+jspecs(2,1,i1)
6768       jcmi(2)=jc1mi2(2)-jspecs(1,2,i1)+jspecs(2,2,i1)
6769       jcmi(3)=jc1mi2(3)-jspecs(1,3,i1)+jspecs(2,3,i1)
6770       jcmi(4)=0
6771
6772       nids=0
6773
6774       if(abs(jcmi(1)).gt.3)goto3
6775       if(abs(jcmi(2)).gt.3)goto3
6776       if(abs(jcmi(3)).gt.3)goto3
6777
6778       if(jcmi(1).ne.0)goto111
6779       if(jcmi(2).ne.0)goto111
6780       if(jcmi(3).ne.0)goto111
6781       nids=nids+1
6782       ids(nids)=0
6783       iwts(nids)=iozero
6784   111 continue
6785
6786       lkfok1=lkfok(1,jcmi(1),jcmi(2),jcmi(3),jcmi(4))
6787       if(lkfok1.gt.0)then
6788        nids=nids+1
6789        ids(nids)=lkfok(2,jcmi(1),jcmi(2),jcmi(3),jcmi(4))
6790        iwts(nids)=1
6791        if(lkfok1.gt.1)then
6792         nids=nids+1
6793         ids(nids)=lkfok(3,jcmi(1),jcmi(2),jcmi(3),jcmi(4))
6794         iwts(nids)=1
6795         if(lkfok1.gt.2)then
6796          if(lkfok1.gt.7)       !-charm
6797      *   stop'HNBPAJINI: dimension of lkfok too small'
6798          do ii=3,lkfok1
6799          nids=nids+1
6800          ids(nids)=lkfok(1+ii,jcmi(1),jcmi(2),jcmi(3),jcmi(4))
6801          iwts(nids)=1
6802          enddo
6803         endif
6804        endif
6805       endif
6806
6807 c             do j=1,nspecs
6808 c      if(jcmi(1).ne.ifok(1,j))goto222
6809 c      if(jcmi(2).ne.ifok(2,j))goto222
6810 c      if(jcmi(3).ne.ifok(3,j))goto222
6811 c      if(jcmi(4).ne.ifok(4,j))goto222
6812 c      if(jcmi(5).ne.ifok(5,j))goto222
6813 c      if(jcmi(6).ne.ifok(6,j))goto222
6814 c      nids=nids+1
6815 c      ids(nids)=ispecs(j)
6816 c      iwts(nids)=1
6817 c  222 continue
6818 c             enddo
6819
6820       if(nids.eq.0)goto3
6821       if(ipair+nids.gt.mxpair)
6822      &     call utstop('hnbpajini: mxpair too small&')
6823       do k=1,nids
6824       ipair=ipair+1
6825       idpairst(1,ipair,idx)=ispecs(i1)
6826       idpairst(2,ipair,idx)=ids(k)
6827       iwtpaist(ipair,idx)=iwts(k)
6828       iwtpaist(0,idx)=iwtpaist(0,idx)+iwtpaist(ipair,idx)
6829       enddo
6830       ipairst(idx)=ipair
6831     3 continue
6832
6833         enddo
6834
6835 c     no pair found
6836 c     -------------
6837       if(ipair.eq.0)then
6838       if(iwtpaist(0,idx).ne.0)call utstop('hnbpajini: iwpair.ne.0&')
6839       endif
6840
6841 1000  continue
6842
6843
6844                 enddo
6845               enddo
6846             enddo
6847           enddo
6848         enddo
6849       enddo
6850
6851       return
6852       end
6853
6854 c--------------------------------------------------------------------
6855       subroutine hnbraw(npx,npy,w)
6856 c--------------------------------------------------------------------
6857 c returns random walk fctn w=w(0,p_1,p_2,...,p_n) for noncovariant
6858 c phase space integral (see hagedorn, suppl nuov cim ix(x) (1958)646)
6859 c input: dimension np and momenta p_i=pcm(5,i) via /confg/
6860 c    1   < np <= npx : hagedorn method
6861 c    npx < np <= npy : integral method
6862 c    npy < np        : asymptotic method
6863 c--------------------------------------------------------------------
6864       include 'epos.inc'
6865       parameter(maxp=500)
6866       common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
6867       integer ii(maxp),isi(maxp)
6868       double precision ppcm(maxp),ww,ppsum,ppmax
6869       external hnbrax
6870       common/cepsr/nepsr
6871       if(ish.ge.9)write(ifch,*)('-',i=1,10)
6872      *,' entry sr hnbraw ',('-',i=1,30)
6873
6874       if(np.lt.3)call utstop('hnbraw: np must be at least 3&')
6875
6876       kper=5
6877       pi=3.1415927
6878       pmax=0
6879       do i=1,np
6880       pmax=pmax+pcm(5,i)
6881       enddo
6882       wio=0
6883       win=0
6884       whd=0
6885
6886 c     sum p_i - 2*p_max not positive
6887 c     ------------------------------
6888       px=0
6889       ps=0
6890       do i=1,np
6891       px=max(px,pcm(5,i))
6892       ps=ps+pcm(5,i)
6893       enddo
6894       if(ps-2*px.le.0.)then
6895       w=0
6896       if(ish.ge.7)write(ifch,'(1x,a,e12.5,4x)')
6897      *'sum p_i - 2*p_max not positive -->  w:',w
6898       goto1000
6899       endif
6900
6901 c     asymptotic method
6902 c     -----------------
6903       was=0
6904       do i=1,np
6905       was=was+pcm(5,i)**2
6906       enddo
6907       was=(was*2*pi/3)**(-1.5)
6908       if(ish.ge.7)write(ifch,'(1x,a,e12.5,4x)')
6909      *'asymptotic method: was:',was
6910
6911       if(np.gt.npy)then
6912       w=was
6913       goto1000
6914       endif
6915
6916       if(np.le.npx)goto9
6917
6918 c     integral method
6919 c     ---------------
6920       if(ish.ge.9)write(ifch,*)'integral method...'
6921       itmax=8
6922       it=0
6923       b=pi*np*kper/pmax
6924       win=0
6925       nepsr=0
6926     3 continue
6927       it=it+1
6928       if(ish.ge.9)write(ifch,*)'it:',it
6929       b=b*5./3.
6930       wio=win
6931       call uttrap(hnbrax,0.,b,win)
6932       iok=0
6933       if(abs(win-wio).le.epsr*abs((win+wio)/2))iok=1
6934       if(it.eq.itmax)iok=1
6935       if(ish.ge.8.or.ish.ge.7.and.iok.eq.1)
6936      *write(ifch,'(1x,2(a,e12.5,2x),a,i2,2x,a,i4)')
6937      *'integral method:   win:',win
6938      *,'upper limit:',b,'it:',it,'nepsr:',nepsr
6939            if(it.eq.itmax
6940      *.and.abs(win-wio).gt.epsr*abs((win+wio)/2))then
6941       nepsr=nepsr+1
6942       if(ish.ge.9)then
6943       call utmsg('hnbraw')
6944       write(ifch,*)
6945      *'*****  requested accuracy could not be achieved'
6946       write(ifch,*)'achieved accuracy: '
6947      *,abs(win-wio)/abs((win+wio)/2)
6948       write(ifch,*)'requested accuracy:',epsr
6949       call utmsgf
6950       endif
6951            endif
6952       if(it.eq.1.or.iok.eq.0)goto3
6953
6954       if(nepsr.eq.0)then
6955       w=win
6956       goto1000
6957       endif
6958
6959       if(np.gt.20)then
6960         if(ish.ge.1)then
6961           call utmsg('hnbraw')
6962           write(ifch,*)
6963      *         '*****  requested accuracy could not be achieved'
6964           write(ifch,*)'achieved accuracy: '
6965      *         ,abs(win-wio)/abs((win+wio)/2)
6966           write(ifch,*)'requested accuracy:',epsr
6967           call utmsgf
6968         endif
6969         w=win
6970         goto1000
6971       endif
6972
6973 c     hagedorn method (double)
6974 c     ------------------------
6975     9 continue
6976       ppmax=0
6977       do i=1,np
6978       ppcm(i)=pcm(5,i)
6979       ppmax=ppmax+ppcm(i)
6980       enddo
6981       ww=0
6982       do i=1,np
6983       ii(i)=0
6984       isi(i)=1
6985       enddo
6986       ppsum=ppmax
6987       i=0
6988       iprosi=1
6989       ww=iprosi*(ppsum/ppmax)**(np-3)
6990       if(ish.ge.8)
6991      *write(ifch,'(4x,i5,12x,f7.2,i5,f11.2)')np,sngl(ppsum)
6992      *,iprosi,sngl(ww)
6993     5 continue
6994       i=i+1
6995       if(i.gt.np)goto6
6996       if(ii(i).eq.1)goto5
6997       iprosi=-iprosi
6998       isi(i)=-isi(i)
6999       ppsum=ppsum+2*isi(i)*ppcm(i)
7000            if(ppsum.gt.0.or.ppsum.eq.0..and.isi(i).gt.0)then
7001       ww=ww+iprosi*(ppsum/ppmax)**(np-3)
7002       if(ish.ge.8)
7003      *write(ifch,'(4x,2i5,2f7.2,i5,f11.2)')
7004      *np,i,sngl(2*isi(i)*ppcm(i)),sngl(ppsum),iprosi,sngl(ww)
7005            else
7006       if(ish.ge.8)
7007      *write(ifch,'(4x,2i5,2f7.2,i5,4x,a)')
7008      *np,i,sngl(2*isi(i)*ppcm(i)),sngl(ppsum),iprosi,'not counted'
7009            endif
7010       ii(i)=1
7011       if(i.gt.1)then
7012       do j=1,i-1
7013       ii(j)=0
7014       enddo
7015       endif
7016       i=0
7017       goto5
7018     6 continue
7019       do i=1,np
7020       ww=ww*pmax/ppcm(i)/2./i
7021       enddo
7022       ww=-ww/pmax**3/pi/2.*np*(np-1)*(np-2)
7023       whd=ww
7024       if(ish.ge.7)write(ifch,'(1x,a,e12.5,4x,a)')
7025      *'hagedorn method:   whd:',whd,'double precision'
7026
7027       w=whd
7028
7029 1000  continue
7030       if(ish.ge.9)write(ifch,*)('-',i=1,30)
7031      *,' exit sr hnbraw ',('-',i=1,10)
7032       return
7033       end
7034
7035 c--------------------------------------------------------------------
7036       function hnbrax(x)
7037 c--------------------------------------------------------------------
7038 c returns integrand for random walk fctn w=w(0,p_1,p_2,...,p_n):
7039 c 1./(2*pi**2) * x**2 * prod[sin(p_i*x)/(p_i*x)]
7040 c input: dimension np and momenta p_i=pcm(5,i) via /confg/
7041 c--------------------------------------------------------------------
7042       parameter(maxp=500)
7043       common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
7044       common/cnsta/pi,pii,hquer,prom,piom,ainfin
7045       hnbrax= pii * x**2
7046       do i=1,np
7047       px=pcm(5,i)*x
7048       if(px.ne.0.)hnbrax=hnbrax*sin(px)/px
7049       enddo
7050       return
7051       end
7052
7053 c----------------------------------------------------------------------
7054       subroutine hnbrmz
7055 c----------------------------------------------------------------------
7056 c  removes intermediate zeros from ident
7057 c  updates np
7058 c----------------------------------------------------------------------
7059       include 'epos.inc'
7060       parameter(maxp=500)
7061       common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
7062 c      integer identx(maxp)
7063       common /clatt/nlattc,npmax
7064       if(ish.ge.9)write(ifch,*)('-',i=1,10)
7065      *,' entry sr hnbrmz ',('-',i=1,30)
7066       if(np.eq.0)goto1000
7067
7068 c      do i=1,np
7069 c      identx(i)=ident(i)
7070 c      enddo
7071 c      npx=np
7072
7073       i=0
7074       np=nlattc+1
7075
7076     1 i=i+1
7077       if(i.gt.nlattc)then
7078       np=nlattc
7079       goto1000
7080       endif
7081       if(ident(i).ne.0)goto1
7082     2 np=np-1
7083       if(np.eq.0)goto1000
7084       if(ident(np).eq.0)goto2
7085
7086       if(ish.ge.9)then
7087       write(ifch,*)'ident:'
7088       write(ifch,'(1x,10i7)')(ident(j),j=1,nlattc)
7089       write(ifch,'(1x,a,i3,3x,a,i3)')'i:',i,'np:',np
7090       endif
7091
7092       if(i.eq.np+1)goto1000
7093
7094       ident(i)=ident(np)
7095       ident(np)=0
7096       goto1
7097
7098 1000  continue
7099       if(ish.ge.9)write(ifch,*)('-',i=1,30)
7100      *,' exit sr hnbrmz ',('-',i=1,10)
7101       end
7102
7103 c----------------------------------------------------------------------
7104       subroutine hnbrod
7105 c----------------------------------------------------------------------
7106 c deformes polygon of a sequence of arbitrarily rotated momentum
7107 c vectors such that the polygon gets closed
7108 c    input: pcm(1-3,i) representing polygon
7109 c    output: pcm(1-3,i) representing closed polygon
7110 c----------------------------------------------------------------------
7111       include 'epos.inc'
7112       parameter(maxp=500)
7113       common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
7114       real x(3),y(3),z(3),w(3)
7115       if(ish.ge.8)write(ifch,*)'sr hnbrod: polygon deformation:'
7116
7117       err=0.01
7118
7119       kmax=1000
7120       fac=0.30
7121       x2max=(err*tecm)**2
7122
7123       if(ish.ge.8)write(ifch,'(a,i4,a,f12.6)')
7124      *' kmax:',kmax,'   x2max:',x2max
7125
7126       x(1)=0
7127       x(2)=0
7128       x(3)=0
7129       do i=1,np
7130       x(1)=x(1)+pcm(1,i)
7131       x(2)=x(2)+pcm(2,i)
7132       x(3)=x(3)+pcm(3,i)
7133       enddo ! i
7134
7135       k=0
7136    1  continue
7137
7138       x2=x(1)**2+x(2)**2+x(3)**2
7139       if(ish.ge.8)write(ifch,'(a,i3,a,3f9.3,a,f12.6)')
7140      *' it',k,':   x:',x,'      x2:',x2
7141       if(x2.le.x2max)goto1000
7142       if(k.gt.kmax)goto1001
7143
7144       k=k+1
7145       ir=1+rangen()*np
7146       ir=min(ir,np)
7147
7148       z(1)=-x(1)
7149       z(2)=-x(2)
7150       z(3)=-x(3)
7151       x(1)=x(1)-pcm(1,ir)
7152       x(2)=x(2)-pcm(2,ir)
7153       x(3)=x(3)-pcm(3,ir)
7154       y(1)=pcm(1,ir)
7155       y(2)=pcm(2,ir)
7156       y(3)=pcm(3,ir)
7157       if(ish.ge.9)write(ifch,'(a,i3,a,3f9.3,a,3f9.3,a,i4)')
7158      *' it',k,':   x:',x,'   y:',y,'  ir:',ir
7159       xxx=x(1)**2+x(2)**2+x(3)**2
7160       yyy=y(1)**2+y(2)**2+y(3)**2
7161       zzz=z(1)**2+z(2)**2+z(3)**2
7162          if(xxx.gt.0..and.yyy.gt.0..and.zzz.gt.0.)then
7163 c      xx=sqrt(xxx)
7164       yy=sqrt(yyy)
7165       zz=sqrt(zzz)
7166       a=min(fac,fac*yy/zz)
7167       w(1)=y(1)+a*z(1)
7168       w(2)=y(2)+a*z(2)
7169       w(3)=y(3)+a*z(3)
7170       www=w(1)**2+w(2)**2+w(3)**2
7171          if(www.gt.0.)then
7172       ww=sqrt(www)
7173       y(1)=yy/ww*w(1)
7174       y(2)=yy/ww*w(2)
7175       y(3)=yy/ww*w(3)
7176       pcm(1,ir)=y(1)
7177       pcm(2,ir)=y(2)
7178       pcm(3,ir)=y(3)
7179          endif
7180          endif
7181       x(1)=x(1)+y(1)
7182       x(2)=x(2)+y(2)
7183       x(3)=x(3)+y(3)
7184       if(ish.ge.9)write(ifch,'(a,i3,a,3f9.3,a,3f9.3,a,i4)')
7185      *' it',k,':   x:',x,'   y:',y,'  ir:',ir
7186
7187       goto1
7188
7189  1001 continue
7190       call utmsg('hnbrod')
7191       write(ifch,*)'*****  total 3-momentum nonzero'
7192       write(ifch,'(3f12.5,5x,2f12.5)')(x(j),j=1,3),x2,x2max
7193       call utmsgf
7194
7195  1000 continue
7196       return
7197
7198       end
7199
7200 c----------------------------------------------------------------------
7201       subroutine hnbrop(ishx,ichk)
7202 c----------------------------------------------------------------------
7203 c  prints momenta of configuration (essentially to check rotation procedure)
7204 c----------------------------------------------------------------------
7205       include 'epos.inc'
7206       parameter(maxp=500)
7207       common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
7208       double precision ps(5)
7209       err=0.01
7210       do j=1,4
7211       ps(j)=0
7212       enddo
7213       do i=1,np
7214       do j=1,4
7215       ps(j)=ps(j)+pcm(j,i)
7216       enddo
7217       if(ish.ge.ishx)write(ifch,'(1x,i3,5x,5f12.5)')i,(pcm(j,i),j=1,3)
7218      *,sqrt(pcm(1,i)**2+pcm(2,i)**2+pcm(3,i)**2),pcm(5,i)
7219       enddo
7220       ps(5)=dsqrt(ps(1)**2+ps(2)**2+ps(3)**2)
7221       if(ish.ge.ishx)write(ifch,'(1x,a4,8x,5f12.5)')
7222      *'sum:',(sngl(ps(j)),j=1,5)
7223            if(ichk.eq.1)then
7224            if(dabs(ps(1)).gt.err*tecm.or.dabs(ps(2)).gt.err*tecm
7225      *.or.dabs(ps(3)).gt.err*tecm)then
7226       call utmsg('hnbrop')
7227       write(ifch,*)'*****  total 3-momentum nonzero'
7228       write(ifch,'(9x,5f12.5)')(sngl(ps(j)),j=1,5)
7229       call utmsgf
7230            endif
7231            endif
7232       return
7233       end
7234
7235 c----------------------------------------------------------------------
7236       subroutine hnbrot
7237 c----------------------------------------------------------------------
7238 c rotates momenta of /confg/ randomly
7239 c   input: pcm(5,i)
7240 c   output: pcm(1-3,i)
7241 c----------------------------------------------------------------------
7242       common/cnsta/pi,pii,hquer,prom,piom,ainfin
7243       parameter(maxp=500)
7244       common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
7245       real u(3)
7246
7247       do i=1,np
7248       u(3)=2.*rangen()-1.
7249       phi=2.*pi*rangen()
7250       u(1)=sqrt(1.-u(3)**2)*cos(phi)
7251       u(2)=sqrt(1.-u(3)**2)*sin(phi)
7252       pcm(1,i)=pcm(5,i)*u(1)
7253       pcm(2,i)=pcm(5,i)*u(2)
7254       pcm(3,i)=pcm(5,i)*u(3)
7255       enddo
7256
7257       return
7258       end
7259
7260 cc-------------------------------------------------------------------
7261 c      subroutine hnbrt2old(c,s,c2,s2,pr,i)
7262 cc-------------------------------------------------------------------
7263 cc  formerly subr rotes2 from cernlib
7264 cc  this subr now does two rotations (xy and xz)
7265 cc-------------------------------------------------------------------
7266 c      parameter(maxp=500)
7267 c      dimension pr(5*maxp)
7268 c      k1 = 5*i - 4
7269 c      k2 = k1 + 1
7270 c      sa = pr(k1)
7271 c      sb = pr(k2)
7272 c      a      = sa*c - sb*s
7273 c      pr(k2) = sa*s + sb*c
7274 c      k2 = k2 + 1
7275 c      b = pr(k2)
7276 c      pr(k1) = a*c2 - b*s2
7277 c      pr(k2) = a*s2 + b*c2
7278 c      return
7279 c      end
7280 c
7281 c-------------------------------------------------------------------
7282       subroutine hnbrt2(c,s,c2,s2,pr,i)
7283 c-------------------------------------------------------------------
7284 c  formerly subr rotes2 from cernlib
7285 c  this subr now does two rotations (xy and xz)
7286 c-------------------------------------------------------------------
7287       parameter(maxp=500)
7288       dimension pr(5,maxp)
7289       k1 = 5*i - 4
7290       k2 = k1 + 1
7291       sa = pr(1,i)
7292       sb = pr(2,i)
7293       a      = sa*c - sb*s
7294       pr(2,i) = sa*s + sb*c
7295       k2 = k2 + 1
7296       b = pr(3,i)
7297       pr(1,i) = a*c2 - b*s2
7298       pr(3,i) = a*s2 + b*c2
7299       return
7300       end
7301
7302 cc-----------------------------------------------------------------------
7303 c      subroutine hnbsor(a,n)
7304 cc-----------------------------------------------------------------------
7305 cc cern proglib# m103    flpsor          .version kernfor  3.15  820113
7306 cc orig. 29/04/78
7307 cc-----------------------------------------------------------------------
7308 cc   sort the one-dimensional floating point array a(1),...,a(n) by
7309 cc   increasing values
7310 cc-----------------------------------------------------------------------
7311 c      dimension a(*)
7312 c      common /slate/ lt(20),rt(20)
7313 c      integer r,rt
7314 cc
7315 c      level=1
7316 c      lt(1)=1
7317 c      rt(1)=n
7318 c   10 l=lt(level)
7319 c      r=rt(level)
7320 c      level=level-1
7321 c   20 if(r.gt.l) go to 200
7322 c      if(level) 50,50,10
7323 cc
7324 cc   subdivide the interval l,r
7325 cc     l : lower limit of the interval (input)
7326 cc     r : upper limit of the interval (input)
7327 cc     j : upper limit of lower sub-interval (output)
7328 cc     i : lower limit of upper sub-interval (output)
7329 cc
7330 c  200 i=l
7331 c      j=r
7332 c      m=(l+r)/2
7333 c      x=a(m)
7334 c  220 if(a(i).ge.x) go to 230
7335 c      i=i+1
7336 c      go to 220
7337 c  230 if(a(j).le.x) go to 231
7338 c      j=j-1
7339 c      go to 230
7340 cc
7341 c  231 if(i.gt.j) go to 232
7342 c      w=a(i)
7343 c      a(i)=a(j)
7344 c      a(j)=w
7345 c      i=i+1
7346 c      j=j-1
7347 c      if(i.le.j) go to 220
7348 cc
7349 c  232 level=level+1
7350 c      if(level.gt.20)stop'level too large'
7351 c      if((r-i).ge.(j-l)) go to 30
7352 c      lt(level)=l
7353 c      rt(level)=j
7354 c      l=i
7355 c      go to 20
7356 c   30 lt(level)=i
7357 c      rt(level)=r
7358 c      r=j
7359 c      go to 20
7360 c   50 return
7361 c      end
7362 c
7363 c-----------------------------------------------------------------------
7364       subroutine hnbspd(iopt)
7365 c-----------------------------------------------------------------------
7366 c  defines particle species and masses and degeneracies.
7367 c  input:
7368 c    iopt=odd number: massless
7369 c    iopt=even number: same as iopt-1, but massive
7370 c    iopt= 1: pi0 (massless)
7371 c    iopt= 2: pi0
7372 c    iopt= 3: pi-,pi0,pi+ (massless)
7373 c    iopt= 4: pi-,pi0,pi+
7374 c    iopt= 5: pi-,pi0,pi+,prt,aprt,ntr,antr (massless)
7375 c    iopt= 6: pi-,pi0,pi+,prt,aprt,ntr,antr
7376 c    iopt= 7: 25 hadrons (massless)
7377 c    iopt= 8: 25 hadrons
7378 c    iopt= 9: 54 hadrons (massless)
7379 c    iopt=10: 54 hadrons
7380 c    iopt=11:  3 quarks  (massless)
7381 c    iopt=12:  3 quarks
7382 c    iopt=13:  54 hadrons + J/psi   (massless)
7383 c    iopt=14:  54 hadrons + J/psi
7384 c    iopt=15:  54 hadrons + J/psi + H  (massless)
7385 c    iopt=16:  54 hadrons + J/psi + H
7386 c  output:
7387 c    nspecs: nr of species
7388 c    ispecs: id's
7389 c    aspecs: masses
7390 c-----------------------------------------------------------------------
7391       parameter (mspecs=56)
7392       common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
7393       parameter (nflav=6)
7394       integer jc(nflav,2),ic(2)
7395       common/cflac/ifok(nflav,mspecs),ifoa(nflav)
7396       common/cspec2/jspecs(2,nflav,mspecs)
7397       common/cspec3/lkfok(8,-3:3,-3:3,-3:3,-3:3)  !-charm
7398       common/cspec4/lkfoi(8,-3:3,-3:3,-3:3,-3:3)  !-charm
7399       parameter(nspe01=1,nspe03=3,nspe05=7,nspe07=25,nspe09=54)
7400       parameter(nspe11=6,nspe13=55,nspe15=56)
7401       real jspe01(nspe01),jspe03(nspe03),jspe05(nspe05),jspe07(nspe07)
7402      *,jspe09(nspe09),jspe11(nspe11),jspe13(nspe13),jspe15(nspe15)
7403       data jspe01/   110 /
7404       data jspe03/   110,  120, -120 /
7405       data jspe05/   110,  120, -120, 1120,-1120, 1220,-1220 /
7406       data jspe07/
7407      *   110,  120, -120,  130, -130,  230, -230,  220,  330
7408      *, 1120,-1120, 1220,-1220, 1130,-1130, 2130,-2130
7409      *, 1230,-1230, 2230,-2230, 1330,-1330, 2330,-2330 /
7410       data jspe09/
7411      *   110,  120, -120,  130, -130,  230, -230,  220,  330
7412      *,  111,  121, -121,  131, -131,  231, -231,  221,  331
7413      *, 1120,-1120, 1220,-1220, 1130,-1130, 2130,-2130
7414      *, 1230,-1230, 2230,-2230, 1330,-1330, 2330,-2330
7415      *, 1111,-1111, 1121,-1121, 1221,-1221, 2221,-2221, 1131,-1131
7416      *, 1231,-1231, 2231,-2231, 1331,-1331, 2331,-2331, 3331,-3331 /
7417       data jspe11/
7418      *     1,   -1,    2,   -2,    3,   -3   /
7419       data jspe13/
7420      *   110,  120, -120,  130, -130,  230, -230,  220,  330
7421      *,  111,  121, -121,  131, -131,  231, -231,  221,  331
7422      *, 1120,-1120, 1220,-1220, 1130,-1130, 2130,-2130
7423      *, 1230,-1230, 2230,-2230, 1330,-1330, 2330,-2330
7424      *, 1111,-1111, 1121,-1121, 1221,-1221, 2221,-2221, 1131,-1131
7425      *, 1231,-1231, 2231,-2231, 1331,-1331, 2331,-2331, 3331,-3331
7426      *, 441 /
7427       data jspe15/
7428      *   110,  120, -120,  130, -130,  230, -230,  220,  330
7429      *,  111,  121, -121,  131, -131,  231, -231,  221,  331
7430      *, 1120,-1120, 1220,-1220, 1130,-1130, 2130,-2130
7431      *, 1230,-1230, 2230,-2230, 1330,-1330, 2330,-2330
7432      *, 1111,-1111, 1121,-1121, 1221,-1221, 2221,-2221, 1131,-1131
7433      *, 1231,-1231, 2231,-2231, 1331,-1331, 2331,-2331, 3331,-3331
7434      *, 441 , 30 /
7435
7436       if(iopt.gt.16)call utstop('hnbspd: invalid option&')
7437       ioptx=(1+iopt)/2*2-1
7438
7439       if(ioptx.eq.1)nspecs=nspe01
7440       if(ioptx.eq.3)nspecs=nspe03
7441       if(ioptx.eq.5)nspecs=nspe05
7442       if(ioptx.eq.7)nspecs=nspe07
7443       if(ioptx.eq.9)nspecs=nspe09
7444       if(ioptx.eq.11)nspecs=nspe11
7445       if(ioptx.eq.13)nspecs=nspe13
7446       if(ioptx.eq.15)nspecs=nspe15
7447            do i=1,nspecs
7448       if(ioptx.eq.1)ispecs(i)=jspe01(i)
7449       if(ioptx.eq.3)ispecs(i)=jspe03(i)
7450       if(ioptx.eq.5)ispecs(i)=jspe05(i)
7451       if(ioptx.eq.7)ispecs(i)=jspe07(i)
7452       if(ioptx.eq.9)ispecs(i)=jspe09(i)
7453       if(ioptx.eq.11)ispecs(i)=jspe11(i)
7454       if(ioptx.eq.13)ispecs(i)=jspe13(i)
7455       if(ioptx.eq.15)ispecs(i)=jspe15(i)
7456       if(ioptx.eq.iopt)then
7457       aspecs(i)=0
7458       else
7459         id=ispecs(i)
7460         call idmass(id,am)
7461         aspecs(i)=am
7462       endif
7463       call hnbspi(ispecs(i),gg)
7464       gspecs(i)=gg
7465            enddo
7466
7467       do nf=1,nflav
7468       ifoa(nf)=0
7469       enddo
7470       do iic=-3, 3                !-charm
7471       do iis=-3, 3
7472       do iid=-3, 3
7473       do iiu=-3, 3
7474       do ii=1,7
7475       lkfok(ii,iiu,iid,iis,iic)=0   !-charm
7476       lkfoi(ii,iiu,iid,iis,iic)=0   !-charm
7477       enddo
7478       enddo
7479       enddo
7480       enddo
7481       enddo
7482            do i=1,nspecs
7483       id=ispecs(i)
7484       call idtr4(id,ic)
7485       call iddeco(ic,jc)
7486       do nf=1,nflav
7487       ifok(nf,i)=jc(nf,1)-jc(nf,2)
7488       ifoa(nf)=ifoa(nf)+iabs(ifok(nf,i))
7489       jspecs(1,nf,i)=jc(nf,1)
7490       jspecs(2,nf,i)=jc(nf,2)
7491       enddo
7492       iiu=ifok(1,i)
7493       iid=ifok(2,i)
7494       iis=ifok(3,i)
7495       iic=ifok(4,i)  !-charm
7496       if(abs(iiu).gt.3)stop'HNBSPD: u-dimension of lkfok too small'
7497       if(abs(iid).gt.3)stop'HNBSPD: d-dimension of lkfok too small'
7498       if(abs(iis).gt.3)stop'HNBSPD: s-dimension of lkfok too small'
7499       if(abs(iic).gt.3)stop'HNBSPD: c-dimension of lkfok too small'   !-charm
7500 c-charm      if(ifok(4,i).ne.0)stop'HNBSPD: lkfok needs index for c'
7501       if(ifok(5,i).ne.0)stop'HNBSPD: lkfok needs index for b'
7502       if(ifok(6,i).ne.0)stop'HNBSPD: lkfok needs index for t'
7503       lkfok(1,iiu,iid,iis,iic)=lkfok(1,iiu,iid,iis,iic)+1             !-charm
7504       lkfoi(1,iiu,iid,iis,iic)=lkfoi(1,iiu,iid,iis,iic)+1             !-charm
7505       ii=lkfok(1,iiu,iid,iis,iic)                                      !-charm
7506       if(ii.gt.7)stop'HNBSPD: ii-dimension of lkfok too small'
7507       lkfok(1+ii,iiu,iid,iis,iic)=id                                 !-charm
7508       lkfoi(1+ii,iiu,iid,iis,iic)=i                                 !-charm
7509 c       write(6,'(i5,5x,3i5,5x,i5,5x,6i5)')
7510 c     * id,iiu,iid,iis,(lkfok(iiu,iid,iis,kk),kk=1,7)
7511            enddo
7512
7513       return
7514       end
7515
7516 c-------------------------------------------------------------
7517       subroutine hnbspf(ku,kd,ks,kc,kb,kt,j,n,spelog)
7518 c-------------------------------------------------------------
7519 c  returns spelog = log of factor for consid. different species
7520 c  spelog is double precision
7521 c  option ioflac determines the method:
7522 c     ioflac=1: ignore flavour conservation
7523 c     ioflac=2: flavour conservation implemented straightforward
7524 c                 (only for nspecs=3,7)
7525 c     ioflac=3: flavour conservation via generating fctn
7526 c  further input:
7527 c     ku,...,kt (integer) : flavour
7528 c     j (integer) : excluded species
7529 c     n (integer) : multiplicity
7530 c-------------------------------------------------------------
7531       include 'epos.inc'
7532       parameter (mspecs=56)
7533       common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
7534       common/cflac/ifok(nflav,mspecs),ifoa(nflav)
7535       integer m(7),l(7),ifot(nflav)
7536       common/csph/ifox(nflav),ifoy(nflav),jx,nx,ifom(nflav,mspecs)
7537       parameter(mxfacu=200)
7538       double precision faci(0:mxfacu)
7539       double precision utgam2,spelog,spe
7540 c      parameter(numax=100,kqmax=100)
7541 c      parameter(mxhh=200)
7542       if(ish.ge.9)write(ifch,*)('-',i=1,10)
7543      *,' entry sr hnbspf ',('-',i=1,30)
7544       if(ish.ge.9)write(ifch,'(1x,a,9x,a,4x,a)')
7545      *' ku kd ks kc kb kt','j','n'
7546       if(ish.ge.9)write(ifch,'(1x,6i3,5x,2i5)')
7547      *ku,kd,ks,kc,kb,kt,j,n
7548       k=nspecs
7549       jx=j
7550       nx=n
7551       ifot(1)=ku
7552       ifot(2)=kd
7553       ifot(3)=ks
7554       ifot(4)=kc
7555       ifot(5)=kb
7556       ifot(6)=kt
7557
7558            if(ioflac.eq.1)then
7559
7560       if(ish.ge.9)write(ifch,'(1x,a,i1)')'ioflac=',ioflac
7561       g=0
7562       do i=1,nspecs
7563       if(i.ne.j)g=g+gspecs(i)
7564       enddo
7565       spelog=n*dlog(1.d0*g)
7566
7567            elseif(ioflac.eq.2)then
7568
7569       if(ish.ge.9)write(ifch,'(1x,a,i2)')'ioflac:',ioflac
7570            if(k.eq.3)then
7571       if(ish.ge.9)write(ifch,'(1x,a,i2)')'nspecs:',nspecs
7572       spe=0d0
7573            if(j.lt.1.or. j.gt.k)then
7574       do 1 n1=0,n
7575       do 2 n2=0,n-n1
7576       n3=n-n1-n2
7577       do 5 nf=1,nflav
7578       if(ifoa(nf).eq.0.and.ifot(nf).eq.0)goto5
7579       if(n1*ifok(nf,1)+n2*ifok(nf,2)+n3*ifok(nf,3).ne.ifot(nf))goto2
7580     5 continue
7581       spe=spe+utgam2(1.d0+n)
7582      &/utgam2(1.d0+n1)/utgam2(1.d0+n2)/utgam2(1.d0+n3)
7583      &*gspecs(1)**n1*gspecs(2)**n2*gspecs(3)**n3
7584     2 continue
7585     1 continue
7586            else
7587       do 3 i1=0,n
7588       i2=n-i1
7589       m(1)=0
7590       m(2)=i1
7591       m(3)=i2
7592       do i=1,3
7593       ii=1+mod(j-2+i,3)
7594       l(ii)=m(i)
7595       enddo
7596       n1=l(1)
7597       n2=l(2)
7598       n3=l(3)
7599       do 6 nf=1,nflav
7600       if(ifoa(nf).eq.0.and.ifot(nf).eq.0)goto6
7601       if(n1*ifok(nf,1)+n2*ifok(nf,2)+n3*ifok(nf,3).ne.ifot(nf))goto3
7602     6 continue
7603       spe=spe+utgam2(1.d0+n)
7604      &/utgam2(1.d0+n1)/utgam2(1.d0+n2)/utgam2(1.d0+n3)
7605      &*gspecs(1)**n1*gspecs(2)**n2*gspecs(3)**n3
7606     3 continue
7607            endif
7608       if(ish.ge.9)write(ifch,*)'spe:',spe
7609       spelog=-1000
7610       if(spe.gt.0.d0)spelog=dlog(spe)
7611       if(ish.ge.9)write(ifch,*)'spelog:',spelog
7612            elseif(k.eq.7)then
7613       if(ish.ge.9)write(ifch,'(1x,a,i2)')'nspecs:',nspecs
7614       if(n.gt.mxfacu)call utstop('hnbspf: mxfacu too small&')
7615       do lf=0,n
7616       faci(lf)=1.d0/utgam2(1d0+lf)
7617       enddo
7618       spe=0
7619            if(j.lt.1.or. j.gt.k)then
7620       do n1=0,n
7621       do n2=0,n-n1
7622       do n3=0,n-n1-n2
7623       do n4=0,n-n1-n2-n3
7624       do n5=0,n-n1-n2-n3-n4
7625       do 12 n6=0,n-n1-n2-n3-n4-n5
7626       n7=n-n1-n2-n3-n4-n5-n6
7627       do 15 nf=1,nflav
7628       if(ifoa(nf).eq.0.and.ifot(nf).eq.0)goto15
7629       if(n1*ifok(nf,1)+n2*ifok(nf,2)+n3*ifok(nf,3)+n4*ifok(nf,4)
7630      *+n5*ifok(nf,5)+n6*ifok(nf,6)+n7*ifok(nf,7).ne.ifot(nf))goto12
7631    15 continue
7632       spe=spe+1d0/faci(n)*faci(n1)*faci(n2)*faci(n3)*faci(n4)
7633      &*faci(n5)*faci(n6)*faci(n7)
7634      &*gspecs(1)**n1*gspecs(2)**n2*gspecs(3)**n3*gspecs(4)**n4
7635      &*gspecs(5)**n5*gspecs(6)**n6*gspecs(7)**n7
7636    12 continue
7637       enddo
7638       enddo
7639       enddo
7640       enddo
7641       enddo
7642            else
7643       do i1=0,n
7644       do i2=0,n-i1
7645       do i3=0,n-i1-i2
7646       do i4=0,n-i1-i2-i3
7647       do 13 i5=0,n-i1-i2-i3-i4
7648       i6=n-i1-i2-i3-i4-i5
7649       m(1)=0
7650       m(2)=i1
7651       m(3)=i2
7652       m(4)=i3
7653       m(5)=i4
7654       m(6)=i5
7655       m(7)=i6
7656       do i=1,7
7657       ii=1+mod(j-2+i,7)
7658       l(ii)=m(i)
7659       enddo
7660       n1=l(1)
7661       n2=l(2)
7662       n3=l(3)
7663       n4=l(4)
7664       n5=l(5)
7665       n6=l(6)
7666       n7=l(7)
7667       do 16 nf=1,nflav
7668       if(ifoa(nf).eq.0.and.ifot(nf).eq.0)goto16
7669       if(n1*ifok(nf,1)+n2*ifok(nf,2)+n3*ifok(nf,3)+n4*ifok(nf,4)
7670      *+n5*ifok(nf,5)+n6*ifok(nf,6)+n7*ifok(nf,7).ne.ifot(nf))goto13
7671    16 continue
7672       spe=spe+1d0/faci(n)*faci(n1)*faci(n2)*faci(n3)*faci(n4)
7673      &*faci(n5)*faci(n6)*faci(n7)
7674      &*gspecs(1)**n1*gspecs(2)**n2*gspecs(3)**n3*gspecs(4)**n4
7675      &*gspecs(5)**n5*gspecs(6)**n6*gspecs(7)**n7
7676    13 continue
7677       enddo
7678       enddo
7679       enddo
7680       enddo
7681            endif
7682       if(ish.ge.9)write(ifch,*)'spe:',spe
7683       spelog=-1000
7684       if(spe.gt.0.d0)spelog=dlog(spe)
7685       if(ish.ge.9)write(ifch,*)'spelog:',spelog
7686            else
7687       call utstop('hnbspf: ioflac=2 only for nspecs=3,7&')
7688            endif
7689
7690            elseif(ioflac.eq.3)then
7691
7692       call utstop('hnbspf: ioflac must be 1 or 2&')
7693
7694            endif
7695
7696       if(ish.ge.9)write(ifch,*)('-',i=1,30)
7697      *,' exit sr hnbspf ',('-',i=1,10)
7698       return
7699       end
7700
7701 c-------------------------------------------------------------
7702       subroutine hnbspg(ku,kd,ks,kc,kb,kt,j,n,spelog)
7703 c-------------------------------------------------------------
7704       include 'epos.inc'
7705       double precision spelog,spalog
7706       if(ioflac.ne.0)return
7707       ioflac=2
7708       call hnbspf(ku,kd,ks,kc,kb,kt,j,n,spalog)
7709       ioflac=3
7710       call hnbspf(ku,kd,ks,kc,kb,kt,j,n,spelog)
7711       ioflac=0
7712       write(ifch,*)'ioflac=2/3:',spalog,spelog
7713       return
7714       end
7715
7716 c----------------------------------------------------------------------
7717       subroutine hnbspi(id,spideg)
7718 c----------------------------------------------------------------------
7719 c  returns spin degeneracy spideg for particle id-code id
7720 c----------------------------------------------------------------------
7721       include 'epos.inc'
7722       parameter (nspec=62)
7723       dimension ispec(nspec),spid(nspec)
7724       data ispec/
7725      *     1,   -1,    2,   -2,    3,   -3
7726      *,  110,  120, -120,  220,  130, -130,  230, -230,  330
7727      *,  111,  121, -121,  221,  131, -131,  231, -231,  331
7728      *, 1120, 1220, 1130, 2130, 1230, 2230, 1330, 2330
7729      *, 1111, 1121, 1221, 2221, 1131, 1231, 2231, 1331, 2331, 3331
7730      *,-1120,-1220,-1130,-2130,-1230,-2230,-1330,-2330
7731      *,-1111,-1121,-1221,-2221,-1131,-1231,-2231,-1331,-2331,-3331
7732      *,441,30/
7733       data spid/
7734      *  6*6.
7735      *, 9*1.
7736      *, 9*3.
7737      *, 8*2.
7738      *,10*4.
7739      *, 8*2.
7740      *,10*4.
7741      *,1*3
7742      *,1*3/
7743       do i=1,nspec
7744       if(id.eq.ispec(i))then
7745       spideg=spid(i)
7746       fac=1
7747       !factb ... not used
7748       !factq ... not used
7749       call idflav(id,ifl1,ifl2,ifl3,jspin,index)
7750       ifls=0
7751       if(abs(ifl1).eq.3)ifls=ifls+1
7752       if(abs(ifl2).eq.3)ifls=ifls+1
7753       if(abs(ifl3).eq.3)ifls=ifls+1
7754       if(ifls.ge.1)then
7755         if(abs(id).gt.1000)then
7756           fac=fac*(1+facts)
7757         elseif(abs(id).lt.1000)then
7758           fac=fac*(1-facts)
7759         endif
7760       endif
7761       spideg=spideg*fac
7762       goto1
7763       endif
7764       enddo
7765       call utstop('hnbspi: id not found&')
7766     1 continue
7767       return
7768       end
7769
7770 c----------------------------------------------------------------------
7771       subroutine hnbtst(iof12)
7772 c----------------------------------------------------------------------
7773 c  calculates logs of prefactors and phase space integral
7774 c  for ultrarelativistic limit (massless particles) and (2*s_i+1)=1
7775 c  f12log and w15log=w35log+f12log not calculated calculated for iof12=0
7776 c----------------------------------------------------------------------
7777       include 'epos.inc'
7778       parameter(maxp=500)
7779       common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
7780       common/ctst/psulog,wtulog
7781       integer ii(maxp)
7782       common /clatt/nlattc,npmax
7783
7784       pi=3.1415927
7785       hquer=0.197327
7786       ish0=ish
7787       if(ishsub/100.eq.23)ish=mod(ishsub,100)
7788       do i=1,np
7789       ii(i)=1
7790       enddo
7791
7792       if(ish.ge.7)write(ifch,*)('-',i=1,10)
7793      *,' entry sr hnbtst ',('-',i=1,30)
7794       if(ish.ge.7)write(ifch,*)'configuration:'
7795       if(ish.ge.7)write(ifch,*)(ident(i),i=1,np)
7796       if(ish.ge.7)write(ifch,*)'n_l:',nlattc,'   n_0:',nlattc-np
7797
7798 c log of prod m_i*volu/4/pi**3/hquer**3 -> f5log
7799       f5log=0
7800       do i=1,np
7801       call hnbfaf(i,gg,am,ioma)
7802       f5log=f5log+alog(gg*am*volu/4/pi**3/hquer**3)
7803       enddo
7804       if(ish.ge.7)write(ifch,*)'log(f5):',f5log
7805
7806 c log f4log=0
7807       f4log=0
7808       if(ish.ge.7)write(ifch,*)'log(f4):',f4log
7809
7810 c log of 1/prod n_alpha! -> f3log
7811       dbllog=0
7812       n1=1
7813       nx=1
7814     1 continue
7815       i=0
7816       x=0
7817       do n2=n1,np
7818       if(ident(n2).eq.ident(n1))then
7819       ii(n2)=0
7820       i=i+1
7821       x=x+alog(i*1.)
7822       endif
7823       if(ii(n2).ne.0.and.n2.gt.n1.and.nx.eq.n1
7824      *.and.ident(n2).ne.ident(n1))nx=n2
7825       enddo
7826       dbllog=dbllog+x
7827       if(nx.gt.n1)then
7828       n1=nx
7829       goto1
7830       endif
7831       f3log=-dbllog
7832       if(ish.ge.7)write(ifch,*)'log(f3):'
7833      *,f3log
7834
7835 c log of f3 * f4 * f5
7836       f35log=f5log+f4log+f3log
7837       if(ish.ge.7)write(ifch,*)'log(f3*f4*f5):',f35log
7838
7839 c log of phase space integral --> psilog
7840            if(iocova.eq.1)then
7841       psilog=alog(2.*np*np*(np-1)/tecm**4/pi)
7842       do i=1,np
7843       psilog=psilog+alog(tecm**2*pi/2./i/i)
7844       enddo
7845            elseif(iocova.eq.2)then
7846       psilog=-alog(2.*np-1)
7847       psilog=psilog+(np-1)*alog(pi/2.)
7848       do i=1,2*np-2
7849       psilog=psilog+alog((2.*np+i-2)/i)
7850       enddo
7851       do i=1,3*np-4
7852       psilog=psilog+alog(tecm/i)
7853       enddo
7854            endif
7855       if(ish.ge.7)write(ifch,*)'log(psi):',psilog
7856
7857 c log of phase space integral * f3 * f4 * f5
7858       w35log=f35log+psilog
7859       if(ish.ge.7)write(ifch,*)'log(f35*psi):',w35log
7860
7861            if(iof12.ne.0)then
7862
7863 c log of macro/micro factor (f1*f2) --> f12log
7864       deglog=0
7865       do i=1,np
7866       deglog=deglog+alog(1.*i)
7867       enddo
7868       deglog=deglog+f3log
7869       do i=1,np
7870       deglog=deglog+alog(nlattc+1.-i)-alog(1.*i)
7871       enddo
7872       f12log=-deglog
7873
7874       w15log=w35log+f12log
7875       if(ish.ge.7)then
7876         write(ifch,*)'log(f1*f2):',f12log
7877         write(ifch,*)'log(f15*psi):',w15log
7878         write(ifch,'(1x,4(a,3x))')
7879      *'log(fac):','log(psi):',' log(wt):','log(wta):'
7880         write(ifch,'(1x,4(f9.3,3x))')
7881      *f12log+f35log,psilog,w15log,w15log-f12log
7882       endif
7883
7884            endif
7885
7886       psulog=psilog
7887       wtulog=w35log
7888
7889       if(ish.ge.7)write(ifch,*)('-',i=1,30)
7890      *,' exit sr hnbtst ',('-',i=1,10)
7891       ish=ish0
7892       return
7893       end
7894
7895 cc----------------------------------------------------------------------
7896 c      subroutine hnbuex(x,e)
7897 cc----------------------------------------------------------------------
7898 cc  x --> x*10.**e with x.lt.10.**10.
7899 cc----------------------------------------------------------------------
7900 c           if(x.eq.0.)then
7901 c      e=0.
7902 c           else
7903 c      e=int(alog10(abs(x)))/10*10
7904 c      x=x/10.**e
7905 c           endif
7906 c      return
7907 c      end
7908 c
7909 cc----------------------------------------------------------------------
7910 c      subroutine hnbwin(n,w,q,i)
7911 cc----------------------------------------------------------------------
7912 cc  returns random index i according to weight w(i)
7913 cc----------------------------------------------------------------------
7914 c      real w(n),q(n)
7915 c      q(1)=w(1)
7916 c      do k=2,n
7917 c      q(k)=q(k-1)+w(k)
7918 c      enddo
7919 c      y=rangen()*q(n)
7920 c      do k=1,n
7921 c      i=k
7922 c      if(q(k).ge.y)goto1000
7923 c      enddo
7924 c      i=n
7925 c1000  return
7926 c      end
7927 c
7928 c----------------------------------------------------------------------
7929       subroutine hnbwri
7930 c----------------------------------------------------------------------
7931 c  writes (to ifch) an configuration
7932 c----------------------------------------------------------------------
7933       include 'epos.inc'
7934       parameter(maxp=500)
7935       common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
7936       common/cfact/faclog
7937       write(ifch,'(1x,a,i5)')'np:',np
7938       write(ifch,'(1x,3(a,3x))')
7939      *'log(fac):','log(psi):',' log(wt):'
7940       if(wtlog.gt.-1e30.and.wtxlog.gt.-1e30)then
7941       write(ifch,'(1x,3(f9.3,3x))')faclog,wtxlog,wtlog
7942       else
7943       write(ifch,*)faclog,wtxlog,wtlog
7944       endif
7945       if(np.le.1)return
7946       call hnbtst(1)
7947       write(ifch,*)'particle id codes:'
7948       write(ifch,'(1x,10i6)')(ident(n),n=1,np)
7949       write(ifch,*)'particle masses:'
7950       write(ifch,'(1x,10f6.3)')(amass(n),n=1,np)
7951       end
7952
7953 c----------------------------------------------------------------------
7954       subroutine hnbzen(iii)
7955 c----------------------------------------------------------------------
7956 c analysis of events. energy spectra.
7957 c for iii>0: filling histogram considering ptl iii
7958 c----------------------------------------------------------------------
7959       parameter(maxp=500)
7960       common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
7961       parameter (mspecs=56)
7962       common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
7963       parameter (nhise=100)
7964       common/chise/hise(mspecs,nhise)
7965       de=2./nhise/2.
7966
7967            if(iii.gt.0)then
7968
7969       i=iii
7970       do l=1,nspecs
7971       if(ident(i).eq.ispecs(l))then
7972       j=l
7973       goto1
7974       endif
7975       enddo
7976     1 continue
7977       am=aspecs(j)
7978       e=pcm(4,i)
7979       ke=1+int((e-am)/(2*de))
7980       if(ke.ge.1.and.ke.le.nhise)hise(j,ke)=hise(j,ke)+1
7981       return
7982
7983            else
7984
7985       stop'STOP in hnbzen: iii=0'
7986
7987            endif
7988
7989       end
7990
7991 c----------------------------------------------------------------------
7992       subroutine hnbzmu(iii)
7993 c----------------------------------------------------------------------
7994 c analysis of events. multiplicity spectra.
7995 c for iii<0: settting histograms to zero (should be first call)
7996 c for iii>0: filling histogram considering ptl iii
7997 c----------------------------------------------------------------------
7998       parameter(maxp=500)
7999       common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
8000       parameter (mspecs=56)
8001       common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
8002       parameter (nhismu=500)
8003       common/chismu/hismu(mspecs,0:nhismu),hismus(nhismu)
8004
8005            if(iii.lt.0)then
8006
8007       do i=1,nhismu
8008       hismus(i)=0
8009       enddo
8010       do j=1,nspecs
8011       do i=0,nhismu
8012       hismu(j,i)=0
8013       enddo
8014       enddo
8015       goto1000
8016
8017            elseif(iii.gt.0)then
8018
8019       if(np.ge.1.and.np.le.nhismu)hismus(np)=hismus(np)+1
8020       do j=1,nspecs
8021       mu=0
8022       do i=1,np
8023       if(ident(i).eq.ispecs(j))mu=mu+1
8024       enddo
8025       if(mu.ge.0.and.mu.le.nhismu)hismu(j,mu)=hismu(j,mu)+1
8026       enddo
8027       goto1000
8028
8029            else
8030
8031       stop'STOP in sr hnbzmu: iii must not be 0'
8032
8033            endif
8034
8035 1000  continue
8036       return
8037       end
8038
8039 c-----------------------------------------------------------------------
8040       subroutine xhgcam(amt,iii)
8041 c-----------------------------------------------------------------------
8042 c creates unnormalized histogram for total mass of grand
8043 c canonically generated sample
8044 c xpar1: nr. of bins
8045 c xpar2: m_1 (lower boundary)
8046 c xpar3: m_2 (upper boundary)
8047 c-----------------------------------------------------------------------
8048       include 'epos.inc'
8049       parameter(nbmx=200)
8050       common/camdat/data(nbmx),datb(nbmx)
8051       parameter(mxclu=10000)
8052       real am(mxclu)
8053       character cen*6,cvol*6
8054
8055       if(iii.eq.0)then
8056
8057       am(nrclu)=amt
8058
8059       return
8060
8061       elseif(iii.lt.0)then
8062
8063       nbin=nint(xpar3)
8064       x1=xpar1
8065       x2=xpar2
8066       dam=(x2-x1)/nbin
8067       write(cen,'(f6.1)')tecm
8068       write(cvol,'(f6.1)')volu
8069
8070       do i=1,nbin
8071       data(i)=x1+(i-1)*dam
8072       datb(i)=0.0
8073       enddo
8074
8075       do i=1,nrclu
8076       xnb=(am(i)-x1)/dam+1.
8077       nb=nint(xnb)
8078       if(nb.le.nbin.and.nb.ge.1)datb(nb)=datb(nb)+1
8079       enddo
8080
8081       write(ifhi,'(a)')       'newpage zone 1 2 1'
8082
8083       write(ifhi,'(a)')       'openhisto'
8084       write(ifhi,'(a)')       'htyp his'
8085       write(ifhi,'(a)')       'xmod lin ymod lin'
8086       write(ifhi,'(a,2e11.3)')'xrange',x1,x2
8087       write(ifhi,'(a)')    'text 0 0 "xaxis total mass"'
8088       write(ifhi,'(a)')    'text 0 0 "yaxis N"'
8089       write(ifhi,'(a,a)')     'text 0.4 0.91 "V='//cvol//'"'
8090       write(ifhi,'(a,a)')     'text 0.15 0.91 "E='//cen//'"'
8091       write(ifhi,'(a)')       'array 2'
8092
8093          do j=1,nbin
8094       write(ifhi,'(2e13.5)')data(j),datb(j)
8095          enddo
8096
8097       write(ifhi,'(a)')    '  endarray'
8098       write(ifhi,'(a)')    'closehisto plot 0'
8099
8100
8101       return
8102
8103            endif
8104
8105        end
8106
8107 c-----------------------------------------------------------------------
8108       subroutine xhgccc(chi)
8109 c-----------------------------------------------------------------------
8110 c creates unnormalized histogram for chi-squared test of initial
8111 c configuration (grand-canonical results are used)
8112 c for chi>0: chi-squared for each droplet configuration is written
8113 c            to /cchi/
8114 c for chi<0: creates histogram
8115 c            xpar1 specifies lower limit
8116 c            xpar2 specifies upper limit
8117 c            xpar3 specifies bin width
8118 c  newpage, zone and plot commands not included !!!
8119 c-----------------------------------------------------------------------
8120       include 'epos.inc'
8121       parameter(nbin=200)
8122       common/chidat/data(nbin),datb(nbin)
8123       parameter(mxclu=10000)
8124       common/cchi/chi2(mxclu)
8125       character cnu*2,cinco*1,cen*6,cvol*6
8126       parameter (mspecs=56)
8127       common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
8128
8129          if(chi.ge.0.0)then
8130
8131       nrclu=nrclu+1
8132       chi2(nrclu)=chi
8133
8134       return
8135
8136          elseif(chi.lt.0.0)then
8137
8138       x1=nint(xpar1)
8139       x2=nint(xpar2)
8140       da=xpar3
8141       write(cnu,'(i2)')nspecs
8142       write(cinco,'(i1)')ioinco
8143       write(cen,'(f6.1)')tecm
8144       write(cvol,'(f6.1)')volu
8145
8146       if(x2.eq.0)x2=50.0
8147       da=max(0.1,da)
8148       a0=x1
8149
8150       do i=1,nbin
8151       data(i)=a0+(i-1)*da
8152       datb(i)=0.0
8153       enddo
8154
8155       do i=1,nrclu
8156       nb=(chi2(i)+da/2.-a0)/da
8157       if(nb.le.nbin.and.nb.ge.1)datb(nb)=datb(nb)+1
8158       enddo
8159
8160       write(ifhi,'(a)')       'openhisto'
8161       write(ifhi,'(a)')       'htyp his'
8162       write(ifhi,'(a)')       'xmod lin ymod lin'
8163       write(ifhi,'(a,2e11.3)')'xrange',x1,x2
8164       write(ifhi,'(a)')    'text 0 0 "xaxis [V]^2"'
8165       write(ifhi,'(a)')    'text 0 0 "yaxis f([V]^2,n?eff!)"'
8166       if(iappl.eq.4)write(ifhi,'(a,a)')'text 0.4 0.91 "V='//cvol//'"'
8167       if(iappl.eq.4)write(ifhi,'(a,a)')'text 0.15 0.91 "E='//cen//'"'
8168       write(ifhi,'(a)')       'array 2'
8169
8170          do j=1,nbin
8171       dat=datb(j)/nevent/da
8172       write(ifhi,'(2e13.5)')data(j),dat
8173          enddo
8174
8175       write(ifhi,'(a)')    '  endarray'
8176       write(ifhi,'(a)')    'closehisto'
8177
8178       return
8179
8180            endif
8181
8182        end
8183
8184 c-----------------------------------------------------------------------
8185       subroutine xhgcen
8186 c-----------------------------------------------------------------------
8187 c  creates energy spectrum plot for decayed QM-droplet
8188 c  using grand canonical results
8189 c input:
8190 c  xpar1 specifies particle species by paige id, 0 for all
8191 c  xpar2 and xpar3 specify xrange of plot
8192 c  xpar4 specifies line type : dashed (0), dotted (1), full (2) dado (3)
8193 c  xpar5 specifies statistics to be used ,(0) same as iostat
8194 c                                         (1) boltzmann
8195 c output:
8196 c  histo-file
8197 c  newpage, zone and plot commands not included !!!
8198 c-----------------------------------------------------------------------
8199       include 'epos.inc'
8200       common/citer/iter,itermx
8201       parameter (nbin=200)
8202       real datx(nbin),daty(nbin)
8203       parameter (mspecs=56)
8204       common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
8205       common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
8206       common/cbol/rmsbol(mspecs),ptlbol(mspecs),chebol(mspecs),tembol
8207       character ctem*5,cit*5,cen*6,cvo*6,chem*5
8208
8209       idpa=nint(xpar1)
8210       x1=xpar2
8211       x2=xpar3
8212       ltyp=nint(xpar4)
8213       ist=nint(xpar5)
8214       if(ist.eq.0.and.iostat.eq.1)ist=1
8215
8216       id=0
8217       jx=100
8218       do i=1,nspecs
8219       if(ispecs(i).eq.idpa)id=i
8220       enddo
8221
8222       dx=(x2-x1)/2./jx
8223       x0=x1+dx
8224
8225          do j=1,jx
8226          datx(j)=x0+(j-1)*dx*2.
8227          daty(j)=0.0
8228
8229        if(id.eq.0)then
8230
8231       do 10 i=1,nspecs
8232       dnde=0.0
8233         if(datx(j).ge.aspecs(i))then
8234       x=100.
8235       if(tem.ne.0.0.and.ist.eq.0)x=(datx(j)-chemgc(i))/tem
8236       if(tem.ne.0.0.and.ist.eq.1)x=(datx(j)-chebol(i))/tembol
8237       igsp=gspecs(i)
8238        if(x.ge.60)goto10
8239        if(mod(igsp,2).eq.0.and.ist.eq.0)then
8240       dnde=1./(exp(x)+1.)
8241        elseif(x.le.1.e-7.and.ist.eq.0)then
8242       dnde=1.e7
8243        elseif(ist.eq.0)then
8244       dnde=1./(exp(x)-1.)
8245        elseif(ist.eq.1)then
8246       dnde=exp(-x)
8247        endif
8248         endif
8249       daty(j)=daty(j)+dnde*gspecs(i)*volu/hquer**3/8./pi**3
8250 10    continue
8251
8252        else
8253
8254       dnde=0.0
8255         if(datx(j).ge.aspecs(id))then
8256       x=100.
8257       if(tem.ne.0.0.and.ist.eq.0)x=(datx(j)-chemgc(id))/tem
8258       if(tem.ne.0.0.and.ist.eq.1)x=(datx(j)-chebol(id))/tembol
8259       igsp=gspecs(id)
8260        if(x.ge.60)goto11
8261        if(mod(igsp,2).eq.0.and.ist.eq.0)then
8262       dnde=1./(exp(x)+1.)
8263        elseif(x.le.1.e-7.and.ist.eq.0)then
8264       dnde=1.e7
8265        elseif(ist.eq.0)then
8266       dnde=1./(exp(x)-1.)
8267        elseif(ist.eq.1)then
8268       dnde=exp(-x)
8269        endif
8270         endif
8271 11    daty(j)=dnde*gspecs(id)*volu/hquer**3/8./pi**3
8272
8273        endif
8274
8275          enddo
8276
8277       ctem='     '
8278       chem='     '
8279       if(tem.gt.0.)write(ctem,'(f5.3)')tem
8280       write(cen,'(f6.1)')tecm
8281       write(cvo,'(f6.1)')volu
8282       if(id.gt.0)write(chem,'(f5.3)')chemgc(id)
8283       write(cit,'(i5)')itermx
8284       write(ifhi,'(a)')       'openhisto'
8285       if(ltyp.eq.0)then
8286       write(ifhi,'(a)')       'htyp lda'
8287       elseif(ltyp.eq.1)then
8288       write(ifhi,'(a)')       'htyp ldo'
8289       elseif(ltyp.eq.2)then
8290       write(ifhi,'(a)')       'htyp lfu'
8291       elseif(ltyp.eq.3)then
8292       write(ifhi,'(a)')       'htyp ldd'
8293       endif
8294       write(ifhi,'(a)')       'xmod lin ymod log'
8295       write(ifhi,'(a,2e11.3)')'xrange',x1,x2
8296       write(ifhi,'(a)')    'text 0 0 "xaxis E?[n]! (GeV)"'
8297       write(ifhi,'(a)')    'text 0 0 "yaxis dN?[n]!/d^3!p"'
8298       write(ifhi,'(a,a)')     'text 0.3 0.10 "T='//ctem//'"'
8299       write(ifhi,'(a,a)')     'text 0.3 0.20 "[m]?[n]!='//chem//'"'
8300       write(ifhi,'(a,a)')     'text 0.3 0.20 "i?max!='//cit//'"'
8301       if(iocite.ne.1)then
8302       write(ifhi,'(a,a)')     'text 0.4 0.91 "V='//cvo//'"'
8303       write(ifhi,'(a,a)')     'text 0.15 0.91 "E='//cen//'"'
8304       endif
8305       write(ifhi,'(a)')       'array 2'
8306
8307          do j=1,jx
8308       write(ifhi,'(2e12.4)')datx(j),daty(j)
8309          enddo
8310
8311       write(ifhi,'(a)')    '  endarray'
8312       write(ifhi,'(a)')    'closehisto'
8313
8314       return
8315       end
8316
8317 c-----------------------------------------------------------------------
8318       subroutine xhgcfl(u,d,s,iii)
8319 c-----------------------------------------------------------------------
8320 c creates unnormalized histogram for net flavor content of grand
8321 c canonically generated sample
8322 c xpar1: specifies width of plot, netflavor centered
8323 c-----------------------------------------------------------------------
8324       include 'epos.inc'
8325       parameter(nb=200)
8326       common/cfldat/data(nb),datb(nb),datc(nb),datu(nb)
8327      *,datd(nb),dats(nb)
8328       parameter(mxclu=10000)
8329       integer ku(mxclu),kd(mxclu),ks(mxclu)
8330       character cfl*3,cen*6,cvol*6
8331
8332       if(iii.eq.0)then
8333
8334       ku(nrclu)=u
8335       kd(nrclu)=d
8336       ks(nrclu)=s
8337
8338       return
8339
8340       elseif(iii.lt.0)then
8341
8342       kwid=nint(xpar1)
8343       nbin=2*kwid+1
8344       x1u=keu-kwid
8345       x2u=keu+kwid
8346       x1d=ked-kwid
8347       x2d=ked+kwid
8348       x1s=kes-kwid
8349       x2s=kes+kwid
8350       write(cen,'(f6.1)')tecm
8351       write(cvol,'(f6.1)')volu
8352
8353       do i=1,nbin
8354       data(i)=x1u+(i-1)
8355       datb(i)=x1d+(i-1)
8356       datc(i)=x1s+(i-1)
8357       datu(i)=0.0
8358       datd(i)=0.0
8359       dats(i)=0.0
8360       enddo
8361
8362       do i=1,nrclu
8363       nbu=(ku(i)-x1u+1)
8364       nbd=(kd(i)-x1d+1)
8365       nbs=(ks(i)-x1s+1)
8366       if(nbu.le.nbin.and.nbu.ge.1)datu(nbu)=datu(nbu)+1
8367       if(nbd.le.nbin.and.nbd.ge.1)datd(nbd)=datd(nbd)+1
8368       if(nbs.le.nbin.and.nbs.ge.1)dats(nbs)=dats(nbs)+1
8369       enddo
8370
8371       write(ifhi,'(a)')       'newpage zone 1 3 1'
8372
8373       write(cfl,'(i3)')keu
8374       write(ifhi,'(a)')       'openhisto'
8375       write(ifhi,'(a)')       'htyp his'
8376       write(ifhi,'(a)')       'xmod lin ymod lin'
8377       write(ifhi,'(a,2e11.3)')'xrange',x1u,x2u
8378       write(ifhi,'(a)')    'text 0 0 "xaxis net u content"'
8379       write(ifhi,'(a)')    'text 0 0 "yaxis N"'
8380       write(ifhi,'(a,a)')     'text 0.4 0.91 "V='//cvol//'"'
8381       write(ifhi,'(a,a)')     'text 0.15 0.91 "E='//cen//'"'
8382       write(ifhi,'(a,a)')     'text 0.65 0.91 "N?u!='//cfl//'"'
8383       write(ifhi,'(a)')       'array 2'
8384
8385          do j=1,nbin
8386       write(ifhi,'(2e13.5)')data(j),datu(j)
8387          enddo
8388
8389       write(ifhi,'(a)')    '  endarray'
8390       write(ifhi,'(a)')    'closehisto plot 0'
8391
8392       write(cfl,'(i3)')ked
8393       write(ifhi,'(a)')       'openhisto'
8394       write(ifhi,'(a)')       'htyp his'
8395       write(ifhi,'(a)')       'xmod lin ymod lin'
8396       write(ifhi,'(a,2e11.3)')'xrange',x1d,x2d
8397       write(ifhi,'(a)')    'text 0 0 "xaxis net d content"'
8398       write(ifhi,'(a)')    'text 0 0 "yaxis N"'
8399       write(ifhi,'(a,a)')     'text 0.4 0.91 "V='//cvol//'"'
8400       write(ifhi,'(a,a)')     'text 0.15 0.91 "E='//cen//'"'
8401       write(ifhi,'(a,a)')     'text 0.65 0.91 "N?d!='//cfl//'"'
8402       write(ifhi,'(a)')       'array 2'
8403
8404          do j=1,nbin
8405       write(ifhi,'(2e13.5)')datb(j),datd(j)
8406          enddo
8407
8408       write(ifhi,'(a)')    '  endarray'
8409       write(ifhi,'(a)')    'closehisto plot 0'
8410
8411       write(cfl,'(i3)')kes
8412       write(ifhi,'(a)')       'openhisto'
8413       write(ifhi,'(a)')       'htyp his'
8414       write(ifhi,'(a)')       'xmod lin ymod lin'
8415       write(ifhi,'(a,2e11.3)')'xrange',x1s,x2s
8416       write(ifhi,'(a)')    'text 0 0 "xaxis net s content"'
8417       write(ifhi,'(a)')    'text 0 0 "yaxis N"'
8418       write(ifhi,'(a,a)')     'text 0.4 0.91 "V='//cvol//'"'
8419       write(ifhi,'(a,a)')     'text 0.15 0.91 "E='//cen//'"'
8420       write(ifhi,'(a,a)')     'text 0.65 0.91 "N?s!='//cfl//'"'
8421       write(ifhi,'(a)')       'array 2'
8422
8423          do j=1,nbin
8424       write(ifhi,'(2e13.5)')datc(j),dats(j)
8425          enddo
8426
8427       write(ifhi,'(a)')    '  endarray'
8428       write(ifhi,'(a)')    'closehisto plot 0'
8429
8430       return
8431
8432            endif
8433
8434        end
8435
8436 c-----------------------------------------------------------------------
8437       subroutine xhgcmt
8438 c-----------------------------------------------------------------------
8439 c creates transverse mass spectrum for QM-droplet decay
8440 c according to grand canonical results
8441 c input:
8442 c  xpar1 specifies particle species by paige id, 0 for all
8443 c  xpar2 and xpar3 specify xrange of plot
8444 c  xpar4 specifies line type : dashed (0), dotted (1), full (2)
8445 c output:
8446 c  histo-file
8447 c  newpage, zone and plot commands not included !!!
8448 c-----------------------------------------------------------------------
8449       include 'epos.inc'
8450       common/citer/iter,itermx
8451       parameter (nbin=200)
8452       real datx(nbin),daty(nbin)
8453       parameter (mspecs=56)
8454       common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
8455       common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
8456       character cen*6,cvo*6,cit*5,ctem*5
8457
8458       idpa=nint(xpar1)
8459       x1=xpar2
8460       x2=xpar3
8461       ltyp=nint(xpar4)
8462
8463       id=0
8464       jx=100
8465       do i=1,nspecs
8466       if(ispecs(i).eq.idpa)id=i
8467       enddo
8468
8469       dx=(x2-x1)/2./jx
8470       x0=x1+dx
8471
8472          do j=1,jx
8473          datx(j)=x0+(j-1)*dx*2.
8474          daty(j)=0.0
8475
8476        if(id.eq.0)then
8477
8478       do 10 i=1,nspecs
8479       dndmt=0.0
8480       if(datx(j).ge.aspecs(i))then
8481       x=100.
8482       xx=100.
8483       if(tem.ne.0.)x=datx(j)/tem
8484       if(tem.ne.0.)xx=chemgc(i)/tem
8485       if(abs(xx).le.60)dndmt=gspecs(i)*volu/hquer**3*exp(xx)*datx(j)
8486      */4./pi**3*hgcbk1(x)
8487       endif
8488       daty(j)=daty(j)+dndmt
8489 10    continue
8490
8491        else
8492
8493       dndmt=0.0
8494       if(datx(j).ge.aspecs(id))then
8495       x=100.
8496       xx=100.
8497       if(tem.ne.0.)x=datx(j)/tem
8498       if(tem.ne.0.)xx=chemgc(id)/tem
8499       if(abs(xx).le.60)dndmt=gspecs(id)*volu/hquer**3*exp(xx)*datx(j)
8500      */4./pi**3*hgcbk1(x)
8501       endif
8502       daty(j)=dndmt
8503
8504        endif
8505
8506          enddo
8507
8508       write(cit,'(i5)')itermx
8509       write(cen,'(f6.1)')tecm
8510       write(cvo,'(f6.1)')volu
8511       write(ctem,'(f5.3)')tem
8512       write(ifhi,'(a)')       'openhisto'
8513       if(ltyp.eq.0)then
8514       write(ifhi,'(a)')       'htyp lda'
8515       elseif(ltyp.eq.1)then
8516       write(ifhi,'(a)')       'htyp ldo'
8517       elseif(ltyp.eq.2)then
8518       write(ifhi,'(a)')       'htyp lfu'
8519       endif
8520       write(ifhi,'(a)')       'xmod lin ymod log'
8521       write(ifhi,'(a,2e11.3)')'xrange',x1,x2
8522       write(ifhi,'(a)')    'text 0 0 "xaxis m?t! (GeV)"'
8523       write(ifhi,'(a)')    'text 0 0 "yaxis dN?[n]!/d^2!m?t! "'
8524       write(ifhi,'(a,a)')     'text 0.3 0.10 "T='//ctem//'"'
8525       write(ifhi,'(a,a)')     'text 0.3 0.20 "i?max!='//cit//'"'
8526       write(ifhi,'(a,a)')     'text 0.4 0.91 "V='//cvo//'"'
8527       write(ifhi,'(a,a)')     'text 0.15 0.91 "E='//cen//'"'
8528       write(ifhi,'(a)')       'array 2'
8529
8530          do j=1,jx
8531       write(ifhi,'(2e12.4)')datx(j),daty(j)
8532          enddo
8533
8534       write(ifhi,'(a)')    '  endarray'
8535       write(ifhi,'(a)')    'closehisto'
8536
8537       return
8538       end
8539
8540 c-----------------------------------------------------------------------
8541       subroutine xhgcmu
8542 c-----------------------------------------------------------------------
8543 c creates multiplicity plot for decayed QM-droplet
8544 c according to grand canonical results
8545 c input:
8546 c  xpar1 specifies species by paige id, 0 for total multiplicity
8547 c  xpar2 specifies xrange to be set automatically (0) or by hand (1)
8548 c  xpar3 and xpar4 xrange if xpar2 ne 0
8549 c  xpar5 xrange = average+-sigma*xpar5
8550 c  xpar6 specifies line type : dashed (0), dotted (1), full (2)
8551 c  xpar7 specifies statistics : same as iostat (0)
8552 c                               boltzmann (1)
8553 c output:
8554 c  histo-file
8555 c  newpage, zone and plot commands not included !!!
8556 c-----------------------------------------------------------------------
8557       include 'epos.inc'
8558       parameter (nbin=200)
8559       real datx(nbin),daty(nbin)
8560       parameter (mspecs=56)
8561       common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
8562       common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
8563       common/cbol/rmsbol(mspecs),ptlbol(mspecs),chebol(mspecs),tembol
8564       common/cgctot/rmstot,ptltot
8565       character cyield*8,cen*6,cvo*6,cinco*1
8566
8567
8568       idpa=nint(xpar1)
8569       ixra=nint(xpar2)
8570       iwid=nint(xpar5)
8571       ltyp=nint(xpar6)
8572       ist=nint(xpar7)
8573       if(ist.eq.0.and.iostat.eq.1)ist=1
8574
8575
8576       id=0
8577       jx=100
8578       ymin=1./nevent/10.
8579       if(nevent.le.10)ymin=ymin/10.
8580       do i=1,nspecs
8581       if(ispecs(i).eq.idpa)id=i
8582       enddo
8583
8584        if(ixra.eq.1)then
8585       x1=anint(xpar3)
8586       x2=anint(xpar4)
8587        else
8588       if(id.eq.0)then
8589       x1=anint(ptltot-iwid*rmstot)
8590       x2=anint(ptltot+iwid*rmstot)
8591       else
8592       x1=anint(ptlngc(id)-iwid*rmsngc(id))
8593       x2=anint(ptlngc(id)+iwid*rmsngc(id))
8594       endif
8595       x2=max(x2,3.0)
8596        endif
8597
8598       x1=max(x1,0.0)
8599       dx=(x2-x1)/2./jx
8600       x0=x1+dx
8601
8602       do j=1,jx
8603       datx(j)=x0+(j-1)*dx*2.
8604       if(id.eq.0)then
8605
8606 c     total multiplicity
8607 c     ------------------
8608       x=100.
8609       if(rmstot.ge.1.e-10)x=(datx(j)-ptltot)**2/rmstot**2/2.
8610
8611        if(x.ge.60)then
8612       pn=0.0
8613        else
8614       pn=exp(-x)/rmstot/sqrt(2.*pi)
8615        endif
8616
8617       daty(j)=pn
8618
8619          else
8620
8621 c     one species (specified by id)
8622 c     ------------------------------
8623       x=100.
8624       if(rmsngc(id).ge.1.e-10.and.ist.eq.0)
8625      *x=(datx(j)-ptlngc(id))**2/rmsngc(id)**2/2.
8626       if(rmsbol(id).ge.1.e-10.and.ist.eq.1)
8627      *x=(datx(j)-ptlbol(id))**2/rmsbol(id)**2/2.
8628
8629        if(x.ge.60)then
8630       pn=0.0
8631        else
8632       if(ist.eq.0)pn=exp(-x)/rmsngc(id)/sqrt(2*pi)
8633       if(ist.eq.1)pn=exp(-x)/rmsbol(id)/sqrt(2*pi)
8634        endif
8635
8636       daty(j)=pn
8637
8638          endif
8639          enddo
8640
8641       if(id.eq.0)then
8642       write(cyield,'(f8.3)')ptltot
8643       else
8644       write(cyield,'(f8.3)')ptlngc(id)
8645       endif
8646       write(cinco,'(i1)')ioinco
8647       write(cen,'(f6.1)')tecm
8648       write(cvo,'(f6.1)')volu
8649       write(ifhi,'(a)')       'openhisto'
8650       if(ltyp.eq.0)then
8651       write(ifhi,'(a)')       'htyp lda'
8652       elseif(ltyp.eq.1)then
8653       write(ifhi,'(a)')       'htyp ldo'
8654       elseif(ltyp.eq.2)then
8655       write(ifhi,'(a)')       'htyp lfu'
8656       elseif(ltyp.eq.3)then
8657       write(ifhi,'(a)')       'htyp ldd'
8658       endif
8659       write(ifhi,'(a)')       'xmod lin ymod log'
8660       write(ifhi,'(a,2e11.3)')'xrange',x1,x2
8661       write(ifhi,'(a,e11.3,a)')'yrange',ymin,'  auto'
8662       write(ifhi,'(a)')    'text 0 0 "xaxis N?[n]!"'
8663       write(ifhi,'(a)')    'text 0 0 "yaxis P(N?[n]!)"'
8664       write(ifhi,'(a,a)')'text 0.3 0.10 "" "L#N?[n]!"G#='//cyield//'""'
8665       write(ifhi,'(a,a)')     'text 0.3 0.2 "conf?in!='//cinco//'"'
8666       if(iocite.ne.1)then
8667       write(ifhi,'(a,a)')     'text 0.4 0.91 "V='//cvo//'"'
8668       write(ifhi,'(a,a)')     'text 0.15 0.91 "E='//cen//'"'
8669       endif
8670       write(ifhi,'(a)')       'array 2'
8671
8672          do j=1,jx
8673       write(ifhi,'(2e12.4)')datx(j),daty(j)
8674          enddo
8675
8676       write(ifhi,'(a)')    '  endarray'
8677       write(ifhi,'(a)')    'closehisto'
8678
8679
8680       return
8681       end
8682
8683
8684 c-----------------------------------------------------------------------
8685       subroutine xhgcmx
8686 c-----------------------------------------------------------------------
8687 c creates multiplicity plot for decayed QM-droplet
8688 c according to grand canonical results POISSON DISTRIB.!!!!
8689 c input:
8690 c  xpar1 specifies species by paige id, 0 for total multiplicity
8691 c  xpar2 specifies xrange to be set automatically (0) or by hand (1)
8692 c  xpar3 and xpar4 xrange if xpar2 ne 0
8693 c  xpar5 xrange = average+-sigma*xpar5
8694 c  xpar6 specifies line type : dashed (0), dotted (1), full (2) dado (3)
8695 c  xpar7 specifies statistics : same as iostat (0)
8696 c                               boltzmann (1)
8697 c output:
8698 c  histo-file
8699 c  newpage, zone and plot commands not included !!!
8700 c-----------------------------------------------------------------------
8701       include 'epos.inc'
8702       parameter (nbin=200)
8703       real datx(nbin),daty(nbin)
8704       parameter (mspecs=56)
8705       common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
8706       common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
8707       common/cbol/rmsbol(mspecs),ptlbol(mspecs),chebol(mspecs),tembol
8708       common/cgctot/rmstot,ptltot
8709       character cyield*8,cen*6,cvo*6,cinco*1
8710
8711
8712       idpa=nint(xpar1)
8713       ixra=nint(xpar2)
8714       iwid=nint(xpar5)
8715       ltyp=nint(xpar6)
8716       ist=nint(xpar7)
8717       if(ist.eq.0.and.iostat.eq.1)ist=1
8718
8719
8720       id=0
8721       ymin=1./nevent/10.
8722       if(nevent.le.10)ymin=ymin/10.
8723       do i=1,nspecs
8724       if(ispecs(i).eq.idpa)id=i
8725       enddo
8726
8727        if(ixra.eq.1)then
8728       n1=nint(xpar3)
8729       n2=nint(xpar4)
8730        else
8731       if(id.eq.0)then
8732       n1=nint(ptltot-iwid*rmstot)
8733       n2=nint(ptltot+iwid*rmstot)
8734       else
8735       n1=nint(ptlngc(id)-iwid*rmsngc(id))
8736       n2=nint(ptlngc(id)+iwid*rmsngc(id))
8737       endif
8738       n2=max(n2,3)
8739        endif
8740
8741       n1=max(n1,0)
8742       jx=n2+1
8743
8744       do j=1,jx
8745       datx(j)=j-1
8746       jf=1
8747       if(j.gt.1)then
8748       do i=1,j-1
8749       jf=jf*i
8750       enddo
8751       endif
8752       if(id.eq.0)then
8753
8754 c     total multiplicity
8755 c     ------------------
8756
8757       daty(j)=1./jf*ptltot**(j-1)*exp(-ptltot)
8758
8759          else
8760
8761 c     one species (specified by id)
8762 c     ------------------------------
8763
8764       if(ist.eq.0)pn=1./jf*ptlngc(id)**(j-1)*exp(-ptlngc(id))
8765       if(ist.eq.1)pn=1./jf*ptlbol(id)**(j-1)*exp(-ptlbol(id))
8766
8767       daty(j)=pn
8768
8769          endif
8770          enddo
8771
8772       if(id.eq.0)then
8773       write(cyield,'(f8.3)')ptltot
8774       else
8775       write(cyield,'(f8.3)')ptlngc(id)
8776       endif
8777       write(cinco,'(i1)')ioinco
8778       write(cen,'(f6.1)')tecm
8779       write(cvo,'(f6.1)')volu
8780       write(ifhi,'(a)')       'openhisto'
8781       if(ltyp.eq.0)then
8782       write(ifhi,'(a)')       'htyp lda'
8783       elseif(ltyp.eq.1)then
8784       write(ifhi,'(a)')       'htyp ldo'
8785       elseif(ltyp.eq.2)then
8786       write(ifhi,'(a)')       'htyp lfu'
8787       elseif(ltyp.eq.3)then
8788       write(ifhi,'(a)')       'htyp ldd'
8789       endif
8790       write(ifhi,'(a)')       'xmod lin ymod log'
8791       write(ifhi,'(a,2i3)')'xrange',n1,n2
8792       write(ifhi,'(a,e11.3,a)')'yrange',ymin,'  auto'
8793       write(ifhi,'(a)')    'text 0 0 "xaxis N?[n]!"'
8794       write(ifhi,'(a)')    'text 0 0 "yaxis P(N?[n]!)"'
8795       write(ifhi,'(a,a)')'text 0.3 0.10 "" "L#N?[n]!"G#='//cyield//'""'
8796       write(ifhi,'(a,a)')     'text 0.3 0.2 "conf?in!='//cinco//'"'
8797       if(iocite.ne.1)then
8798       write(ifhi,'(a,a)')     'text 0.4 0.91 "V='//cvo//'"'
8799       write(ifhi,'(a,a)')     'text 0.15 0.91 "E='//cen//'"'
8800       endif
8801       write(ifhi,'(a)')       'array 2'
8802
8803          do j=1,jx
8804       write(ifhi,'(2e12.4)')datx(j),daty(j)
8805          enddo
8806
8807       write(ifhi,'(a)')    '  endarray'
8808       write(ifhi,'(a)')    'closehisto'
8809
8810
8811       return
8812       end
8813
8814 c-----------------------------------------------------------------------
8815       subroutine xhgcpt
8816 c-----------------------------------------------------------------------
8817 c creates transverse momentum spectrum for decayed QM-droplet
8818 c according to grand canonical results
8819 c input:
8820 c  xpar1 specifies particle species by paige id, 0 for all
8821 c  xpar2 rapidity window
8822 c  xpar3 and xpar4 specify xrange of plot
8823 c  xpar5 specifies line type : dashed (0), dotted (1), full (2)
8824 c output:
8825 c  histo-file
8826 c  newpage, zone and plot commands not included !!!
8827 c-----------------------------------------------------------------------
8828       include 'epos.inc'
8829       common/citer/iter,itermx
8830       parameter (nbin=200)
8831       real datx(nbin),daty(nbin)
8832       parameter (mspecs=56)
8833       common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
8834       common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
8835       character crap*5,cen*6,cvo*6,cit*5
8836
8837       idpa=nint(xpar1)
8838       y=xpar2
8839       x1=xpar3
8840       x2=xpar4
8841       ltyp=xpar5
8842
8843       write(crap,'(f5.1)')y
8844       id=0
8845       jx=100
8846       do i=1,nspecs
8847       if(ispecs(i).eq.idpa)id=i
8848       enddo
8849
8850       dx=(x2-x1)/2./jx
8851       x0=x1+dx
8852
8853          do j=1,jx
8854          datx(j)=x0+(j-1)*dx*2.
8855          daty(j)=0.0
8856
8857        if(id.eq.0)then
8858
8859       do 10 i=1,nspecs
8860       x=100.
8861       if(tem.ne.0.)
8862      *x=(sqrt(aspecs(i)**2+datx(j)**2)*cosh(y)-chemgc(i))/tem
8863        if(x.ge.60)then
8864       dndpt=0.0
8865        else
8866       dndpt=exp(-x)
8867        endif
8868       dndpt=dndpt*gspecs(i)*volu/hquer**3*cosh(y)
8869      **sqrt(aspecs(i)**2+datx(j)**2)/8./pi**3
8870       daty(j)=daty(j)+dndpt
8871 10    continue
8872
8873        else
8874
8875       x=100.
8876       if(tem.ne.0.)
8877      *x=(sqrt(aspecs(id)**2+datx(j)**2)*cosh(y)-chemgc(id))/tem
8878        if(x.ge.60)then
8879       dndpt=0.0
8880        else
8881       dndpt=exp(-x)
8882        endif
8883       dndpt=dndpt*gspecs(id)*volu/hquer**3*cosh(y)
8884      **sqrt(aspecs(id)**2+datx(j)**2)/8./pi**3
8885       daty(j)=dndpt
8886
8887        endif
8888
8889          enddo
8890
8891       write(cit,'(i5)')itermx
8892       write(cen,'(f6.1)')tecm
8893       write(cvo,'(f6.1)')volu
8894       write(ifhi,'(a)')       'openhisto'
8895       if(ltyp.eq.0)then
8896       write(ifhi,'(a)')       'htyp lda'
8897       elseif(ltyp.eq.1)then
8898       write(ifhi,'(a)')       'htyp ldo'
8899       elseif(ltyp.eq.2)then
8900       write(ifhi,'(a)')       'htyp lfu'
8901       endif
8902       write(ifhi,'(a)')       'xmod lin ymod log'
8903       write(ifhi,'(a,2e11.3)')'xrange',x1,x2
8904       write(ifhi,'(a)')    'text 0 0 "xaxis p?t! (GeV/c)"'
8905       write(ifhi,'(a)')    'text 0 0 "yaxis dN?[n]!/dyd^2!p?t!"'
8906       write(ifhi,'(a)')    'text 0.10 0.10 "y = '//crap//'"'
8907       write(ifhi,'(a)')    'text 0.10 0.30 "i?max! = '//cit//'"'
8908       write(ifhi,'(a,a)')     'text 0.4 0.91 "V='//cvo//'"'
8909       write(ifhi,'(a,a)')     'text 0.15 0.91 "E='//cen//'"'
8910       write(ifhi,'(a)')       'array 2'
8911
8912          do j=1,jx
8913       write(ifhi,'(2e12.4)')datx(j),daty(j)
8914          enddo
8915
8916       write(ifhi,'(a)')    '  endarray'
8917       write(ifhi,'(a)')    'closehisto'
8918
8919       return
8920       end
8921
8922 c-----------------------------------------------------------------------
8923       subroutine xhgcra
8924 c-----------------------------------------------------------------------
8925 c creates rapidity distribution for decayed QM-droplet
8926 c according to grand canonical results
8927 c input:
8928 c  xpar1 specifies particle species by paige id, 0 for all
8929 c  xpar2 and xpar3 specify xrange of plot
8930 c  xpar4 specifies line type : dashed (0), dotted (1), full (2)
8931 c output:
8932 c  histo-file
8933 c  newpage, zone and plot commands not included !!!
8934 c-----------------------------------------------------------------------
8935       include 'epos.inc'
8936       parameter (nbin=200)
8937       real datx(nbin),daty(nbin)
8938       parameter (mspecs=56)
8939       common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
8940       common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
8941       common/cgctot/rmstot,ptltot
8942       character cen*6,cvo*6,cng*8
8943
8944       idpa=nint(xpar1)
8945       x1=nint(xpar2)
8946       x2=nint(xpar3)
8947       ltyp=nint(xpar4)
8948
8949       id=0
8950       jx=100
8951       ymin=1./nevent/10.
8952       if(nevent.le.10)ymin=ymin/10.
8953       do i=1,nspecs
8954       if(ispecs(i).eq.idpa)id=i
8955       enddo
8956
8957       dx=(x2-x1)/2./jx
8958       x0=x1+dx
8959
8960          do j=1,jx
8961
8962          datx(j)=x0+(j-1)*dx*2.
8963          daty(j)=0.0
8964          y=datx(j)
8965          if(ish.ge.9)write(ifch,*)'cosh y:',cosh(y)
8966
8967        if(id.eq.0)then
8968
8969       do 10 i=1,nspecs
8970       dndy=0.0
8971       sum=aspecs(i)**2*tem+2.*aspecs(i)*tem**2/cosh(y)
8972      *+2.*tem**3/cosh(y)**2
8973       x=100.
8974       if(tem.ne.0.0)
8975      *x=(aspecs(i)*cosh(y)-chemgc(i))/tem
8976
8977        if(x.ge.60.)then
8978       pro=0.0
8979        else
8980       pro=exp(-x)
8981       endif
8982
8983       pro=pro*gspecs(i)*volu/hquer**3/4./pi**2
8984
8985       if(pro.ge.(1.e-30).and.sum.ge.(1.e-30))then
8986       che=alog(pro)+alog(sum)
8987       else
8988       che=-61.0
8989       endif
8990       if(che.le.60.0.and.che.ge.(-60.0))dndy=pro*sum
8991 c     if(che.le.60.0.and.che.ge.(-60.0))dndy=exp(che)
8992
8993       daty(j)=daty(j)+dndy
8994
8995 10    continue
8996
8997        else
8998
8999       dndy=0.0
9000       sum=aspecs(id)**2*tem+2.*aspecs(id)*tem**2/cosh(y)
9001      *+2.*tem**3/cosh(y)**2
9002       x=100.
9003       if(tem.ne.0.0)
9004      *x=(aspecs(id)*cosh(y)-chemgc(id))/tem
9005
9006        if(x.ge.60.)then
9007       pro=0.0
9008        else
9009       pro=exp(-x)
9010       endif
9011
9012       pro=pro*gspecs(id)*volu/hquer**3/4./pi**2
9013
9014       if(pro.ge.(1.e-30).and.sum.ge.(1.e-30))then
9015       che=alog(pro)+alog(sum)
9016       else
9017       che=-61.0
9018       endif
9019       if(che.le.60..and.che.ge.-60.)dndy=pro*sum
9020
9021       daty(j)=dndy
9022
9023        endif
9024
9025          enddo
9026
9027       write(cen,'(f6.1)')tecm
9028       write(cvo,'(f6.1)')volu
9029       if(id.eq.0)then
9030       write(cng,'(f8.3)')ptltot
9031       else
9032       write(cng,'(f8.3)')ptlngc(id)
9033       endif
9034       write(ifhi,'(a)')       'openhisto'
9035       if(ltyp.eq.0)then
9036       write(ifhi,'(a)')       'htyp lda'
9037       elseif(ltyp.eq.1)then
9038       write(ifhi,'(a)')       'htyp ldo'
9039       elseif(ltyp.eq.2)then
9040       write(ifhi,'(a)')       'htyp lfu'
9041       endif
9042
9043       write(ifhi,'(a)')       'xmod lin ymod log'
9044       write(ifhi,'(a,2e11.3)')'xrange',x1,x2
9045       write(ifhi,'(a,e11.3,a)')'yrange',ymin,'  auto'
9046       write(ifhi,'(a)')    'text 0 0 "xaxis y"'
9047       write(ifhi,'(a)')    'text 0 0 "yaxis dN?[n]!/dy"'
9048       write(ifhi,'(a,a)')     'text 0.4 0.91 "V='//cvo//'"'
9049       write(ifhi,'(a,a)')     'text 0.15 0.91 "E='//cen//'"'
9050       write(ifhi,'(a,a)')     'text 0.3 0.10 "N?[n]!='//cng//'"'
9051       write(ifhi,'(a)')       'array 2'
9052
9053          do j=1,jx
9054       write(ifhi,'(2e12.4)')datx(j),daty(j)
9055          enddo
9056
9057       write(ifhi,'(a)')    '  endarray'
9058       write(ifhi,'(a)')    'closehisto'
9059
9060       return
9061       end
9062
9063 c-----------------------------------------------------------------------
9064       subroutine xhnben
9065 c-----------------------------------------------------------------------
9066 c produces histogram of energy spectrum (after metropolis run)
9067 c complete histogram: openhisto ... closehisto
9068 c iocite=1 required
9069 c-----------------------------------------------------------------------
9070 c xpar1: particle species (venus id-code)
9071 c xpar2: 1: actual spectrum 2: fit
9072 c xpar3: 1: de/d3p 2: ede/d3e
9073 c-----------------------------------------------------------------------
9074       include 'epos.inc'
9075       parameter (mspecs=56)
9076       common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
9077       parameter (nhise=100)
9078       common/chise/hise(mspecs,nhise)
9079       parameter (literm=500)
9080       common/cmet/kspecs(mspecs),liter,lspecs(literm,mspecs)
9081      *,iterl(literm),iterc(literm)
9082       real datx(nhise),daty(nhise),dats(nhise)
9083       common/citer/iter,itermx
9084       character ch*1,chid*5,cyield*9,ctem*5
9085       de=2./nhise/2.
9086
9087       if(iocite.ne.1)stop'STOP: xhnben: iocite=1 required'
9088
9089       idcode=nint(xpar1)
9090       mode=nint(xpar2)
9091       kind=nint(xpar3)
9092
9093            do j=1,nspecs
9094            if(idcode.eq.ispecs(j))then
9095
9096       id=idcode
9097       am=aspecs(j)
9098       yield=1.*kspecs(j)/(itermx-iternc)
9099       if(kind.eq.1)ch=' '
9100       if(kind.eq.2)ch='e'
9101       ll=kind-1
9102       e0=am+de
9103       nebins=0
9104         do i=1,nhise
9105       e=e0+(i-1)*2*de
9106       p1=sqrt((e-de)**2-am**2)
9107       p2=sqrt((e+de)**2-am**2)
9108       d3p=4*pi*(p2**3-p1**3)/3
9109       datx(i)=e
9110       y=(1-ll+ll*e)*hise(j,i)/(itermx-iternc)/d3p
9111       if(y.gt.0.)then
9112       nebins=nebins+1
9113       daty(i)=alog(y)
9114       d=y/sqrt(hise(j,i))
9115       dats(i)=1e10
9116       if(y-d.gt.0.)dats(i)=alog(y+d)-alog(y-d)
9117       else
9118       daty(i)=-100
9119       dats(i)=1e10
9120       endif
9121 c-c   if(e.lt.0.2)dats(i)=1e10
9122         enddo
9123       a=0.
9124       b=0.
9125         if(nebins.ge.3)then
9126       call utfit(datx,daty,nhise,dats,1,a,b,siga,sigb,chi2,q)
9127       tem=-1./b
9128       if(tem.lt.0.050.or.tem.gt.10.)then
9129       tem=0.
9130       a=0.
9131       b=0.
9132       endif
9133         endif
9134       do i=1,nhise
9135       daty(i)=exp(daty(i))
9136       enddo
9137       write(chid,'(i5)')id
9138       write(cyield,'(f9.4)')yield
9139       ctem='     '
9140       if(tem.gt.0.)write(ctem,'(f5.3)')tem
9141       write(ifhi,'(a)')    'openhisto xrange 0 3'
9142       write(ifhi,'(a)')    'htyp lin xmod lin ymod log'
9143       write(ifhi,'(a,a)')  'text 0 0 "title id='//chid
9144      *                           ,'   N='//cyield//'   T='//ctem//'"'
9145       write(ifhi,'(a)')    'text 0 0 "xaxis energy (GeV)"'
9146       write(ifhi,'(a)')    'text 0 0 "yaxis '//ch//' dn/d3p (GeV-3)"'
9147       write(ifhi,'(a)')    'array 2'
9148       do i=1,nhise
9149       if(mode.eq.1)write(ifhi,'(2e12.4)')datx(i),daty(i)
9150       if(mode.eq.2)write(ifhi,'(2e12.4)')datx(i),exp(a+b*datx(i))
9151       enddo
9152       write(ifhi,'(a)')    '  endarray'
9153       write(ifhi,'(a)')    'closehisto'
9154
9155            endif
9156            enddo
9157
9158       return
9159       end
9160
9161 c-----------------------------------------------------------------------
9162       subroutine xhnbit
9163 c-----------------------------------------------------------------------
9164 c produces histogram of multiplicity versus iterations (after metropolis run)
9165 c complete histogram: openhisto ... closehisto
9166 c iocite=1 required
9167 c-----------------------------------------------------------------------
9168 c xpar1: particle species (0=all, else venus id-code)
9169 c xpar2: 1:actual multiplicity 2:average multiplicity 3:grand canonical
9170 c-----------------------------------------------------------------------
9171       include 'epos.inc'
9172       parameter (mspecs=56)
9173       common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
9174       parameter (literm=500)
9175       common/cmet/kspecs(mspecs),liter,lspecs(literm,mspecs)
9176      *,iterl(literm),iterc(literm)
9177       real datlx(literm),datly(literm)
9178       common/citer/iter,itermx
9179       character chid*5,ctecm*5,cvolu*6
9180       common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
9181       common/cgctot/rmstot,ptltot
9182
9183       if(iocite.ne.1)stop'STOP: xhnbit: iocite=1 required'
9184
9185       idcode=nint(xpar1)
9186       mode=nint(xpar2)
9187
9188            if(idcode.eq.0)then
9189
9190       yield=0
9191       do j=1,nspecs
9192       yield=yield+1.*kspecs(j)/(itermx-iternc)
9193       enddo
9194       datlx(1)=(iterl(1)+1)/2.
9195       do li=2,liter-1
9196       datlx(li)=(iterl(li)+iterl(li-1)+1)/2.
9197       enddo
9198       x1=0
9199       x2=iterl(liter-1)
9200       do li=1,liter-1
9201       y=0
9202       do j=1,nspecs
9203       y=y+lspecs(li,j)
9204       enddo
9205       if(mode.eq.1)datly(li)=y/iterc(li)
9206       if(mode.eq.2)datly(li)=yield
9207       if(mode.eq.3)datly(li)=ptltot
9208       enddo
9209       write(ctecm,'(f5.1)')tecm
9210       write(cvolu,'(f6.1)')volu
9211       write(ifhi,'(a,2e11.3)')'openhisto xrange',x1,x2
9212       write(ifhi,'(a)')       'htyp lin xmod lin ymod lin'
9213       write(ifhi,'(a,a)')     'text 0 0 "title E = '//ctecm//'   V = '
9214      *                                 ,cvolu//'"'
9215       write(ifhi,'(a)')       'text 0 0 "xaxis iterations"'
9216       write(ifhi,'(a)')       'text 0 0 "yaxis multiplicity"'
9217       write(ifhi,'(a)')       'array 2'
9218       do i=1,liter-1
9219       write(ifhi,'(2e12.4)')   datlx(i),datly(i)
9220       enddo
9221       write(ifhi,'(a)')       '  endarray'
9222       write(ifhi,'(a)')       'closehisto'
9223
9224            else
9225
9226            do j=1,nspecs
9227            if(idcode.eq.ispecs(j))then
9228
9229       yield=1.*kspecs(j)/(itermx-iternc)
9230       write(chid,'(i5)')idcode
9231       do li=1,liter-1
9232       datlx(li)=iterl(li)
9233       enddo
9234       x1=0
9235       x2=datlx(liter-1)
9236       do li=1,liter-1
9237       if(mode.eq.1)datly(li)=lspecs(li,j)*1./iterc(li)
9238       if(mode.eq.2)datly(li)=yield
9239       if(mode.eq.3)datly(li)=ptlngc(j)
9240       enddo
9241       write(ifhi,'(a,2e11.3)')'openhisto xrange',x1,x2
9242       write(ifhi,'(a)')       'htyp lin xmod lin ymod lin'
9243       write(ifhi,'(a)')       'text 0 0 "title id='//chid//'"'
9244       write(ifhi,'(a)')       'text 0 0 "xaxis iterations "'
9245       write(ifhi,'(a)')       'text 0 0 "yaxis multiplicity"'
9246       write(ifhi,'(a)')       'array 2'
9247       do i=1,liter-1
9248       write(ifhi,'(2e12.4)')   datlx(i),datly(i)
9249       enddo
9250       write(ifhi,'(a)')       '  endarray'
9251       write(ifhi,'(a)')       'closehisto'
9252
9253            endif
9254            enddo
9255
9256            endif
9257
9258       return
9259       end
9260
9261 c-----------------------------------------------------------------------
9262       subroutine xhnbmu
9263 c-----------------------------------------------------------------------
9264 c produces histogram of multiplicity distribution (after metropolis run)
9265 c complete histogram: openhisto ... closehisto
9266 c iocite=1 required
9267 c-----------------------------------------------------------------------
9268 c xpar1: particle species (0=all, else venus id-code)
9269 c xpar2: xrange automatic (0) or given via xpar3,4 (else)
9270 c xpar3,4: xrange
9271 c-----------------------------------------------------------------------
9272       include 'epos.inc'
9273       parameter (mspecs=56)
9274       common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
9275       parameter (nhismu=500)
9276       common/chismu/hismu(mspecs,0:nhismu),hismus(nhismu)
9277       parameter (literm=500)
9278       common/cmet/kspecs(mspecs),liter,lspecs(literm,mspecs)
9279      *,iterl(literm),iterc(literm)
9280       real datx(nhismu),daty(nhismu)
9281       common/citer/iter,itermx
9282       common /clatt/nlattc,npmax
9283       character chid*5,cyield*9,ctecm*5,cvolu*6
9284
9285       if(iocite.ne.1)stop'STOP: xhnbmu: iocite=1 required'
9286
9287       idcode=nint(xpar1)
9288       ixr=nint(xpar2)
9289       xx1=xpar3
9290       xx2=xpar4
9291
9292       write(ctecm,'(f5.1)')tecm
9293       write(cvolu,'(f6.1)')volu
9294
9295            if(idcode.eq.0)then
9296
9297       yield=0
9298       do j=1,nspecs
9299       yield=yield+1.*kspecs(j)/(itermx-iternc)
9300       enddo
9301       write(cyield,'(f9.4)')yield
9302       i1=0
9303       i2=nlattc
9304       mus=0
9305       do i=1,nhismu
9306       if(i1.eq.0.and.nint(hismus(i)).gt.0)i1=i
9307       if(nint(hismus(i)).gt.0)i2=i
9308       mus=mus+hismus(i)
9309       enddo
9310       ij=0.5*(i1+i2)*0.20
9311       if(itermx.le.1000)ij=0.5*(i1+i2)*0.40
9312       if(itermx.le.100)ij=0.5*(i1+i2)*0.80
9313       i1=i1-ij
9314       i1=max(i1,2)
9315       i2=i2+ij
9316       ii=10
9317       if(i1.le.50)ii=5
9318       if(i1.le.20)ii=2
9319       i1=i1/ii*ii
9320       i2=i2/ii*ii+ii
9321            do i=i1,i2
9322       l=1+i-i1
9323       datx(l)=i
9324       daty(l)=hismus(i)/mus
9325            enddo
9326       jx=1+i2-i1
9327       if(ixr.eq.0)then
9328       x1=i1
9329       x2=i2
9330       else
9331       x1=xx1
9332       x2=xx2
9333       endif
9334       write(ifhi,'(a,2e11.3)')'openhisto xrange',x1,x2
9335       write(ifhi,'(a)')       'htyp lin xmod lin ymod log'
9336       write(ifhi,'(a,a)')     'text 0 0 "title E = '//ctecm//'   V = '
9337      *                              ,cvolu//'"'
9338       write(ifhi,'(a)')       'text 0 0 "xaxis multiplicity n  "'
9339       write(ifhi,'(a)')       'text 0 0 "yaxis dN/dn"'
9340       write(ifhi,'(a)')       'text 0.30 0.25 "N?MC!='//cyield//'"'
9341       write(ifhi,'(a)')       'array 2'
9342       do i=1,jx
9343       write(ifhi,'(2e12.4)')   datx(i),daty(i)
9344       enddo
9345       write(ifhi,'(a)')       '  endarray'
9346       write(ifhi,'(a)')       'closehisto'
9347
9348            else
9349
9350            do j=1,nspecs
9351            if(idcode.eq.ispecs(j))then
9352
9353       yield=1.*kspecs(j)/(itermx-iternc)
9354       write(cyield,'(f9.4)')yield
9355       write(chid,'(i5)')idcode
9356       i1=0
9357       i2=nlattc
9358       mus=0
9359       do i=0,nhismu
9360       if(i1.eq.0.and.nint(hismu(j,i)).gt.0)i1=i
9361       if(nint(hismu(j,i)).gt.0)i2=i
9362       mus=mus+hismu(j,i)
9363       enddo
9364       ij=0.5*(i1+i2)*0.30
9365       if(itermx.le.1000)ij=0.5*(i1+i2)*0.60
9366       if(itermx.le.100)ij=0.5*(i1+i2)*1.20
9367       i1=i1-ij
9368       i1=max(i1,0)
9369       i2=i2+ij
9370       ii=10
9371       if(i1.le.50)ii=5
9372       if(i1.le.20)ii=2
9373       i1=i1/ii*ii
9374       i2=i2/ii*ii+ii
9375            do i=i1,i2
9376       l=1+i-i1
9377       datx(l)=i
9378       daty(l)=hismu(j,i)/mus
9379            enddo
9380       jx=1+i2-i1
9381       if(ixr.eq.0)then
9382       x1=i1
9383       x2=i2
9384       else
9385       x1=xx1
9386       x2=xx2
9387       endif
9388       write(ifhi,'(a,2e11.3)')'openhisto xrange',x1,x2
9389       write(ifhi,'(a)')       'htyp lin xmod lin ymod log'
9390       write(ifhi,'(a)')       'text 0 0 "title id='//chid//'"'
9391       write(ifhi,'(a)')       'text 0 0 "xaxis multiplicity n  "'
9392       write(ifhi,'(a)')       'text 0 0 "yaxis dN/dn"'
9393       write(ifhi,'(a)')       'text 0.30 0.25 "N?MC!='//cyield//'"'
9394       write(ifhi,'(a)')       'array 2'
9395       do i=1,jx
9396       write(ifhi,'(2e12.4)')   datx(i),daty(i)
9397       enddo
9398       write(ifhi,'(a)')       '  endarray'
9399       write(ifhi,'(a)')       'closehisto'
9400
9401            endif
9402            enddo
9403
9404            endif
9405
9406       return
9407       end
9408
9409 c-----------------------------------------------------------------------
9410       subroutine xhnbmz
9411 c-----------------------------------------------------------------------
9412 c produces histogram of multiplicity distribution from droplet decay
9413 c or average multiplicity versus iterations
9414 c for massless hadrons
9415 c complete histogram: openhisto ... closehisto
9416 c-----------------------------------------------------------------------
9417 c xpar1: particle species (0=all, else venus id-code)
9418 c xpar2: lower limit multiplicity
9419 c xpar3: upper limit multiplicity
9420 c xpar4: lower limit total multiplicity   (also necc for xpar1.ne.0)
9421 c xpar5: upper limit  "      "            (also necc for xpar1.ne.0)
9422 c xpar6: sets htyp: 1->lfu, 2->ldo, 3->lda, 4->ldd
9423 c xpar7: 0: multiplicity distribution
9424 c        >0: av multiplicity vs iterations (itermx=xpar7)
9425 c-----------------------------------------------------------------------
9426       include 'epos.inc'
9427       parameter(maxp=500)
9428       common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
9429       common/ctst/psulog,wtulog
9430       parameter (mspecs=56)
9431       common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
9432       parameter (nhismu=500)
9433       common/cflac/ifok(nflav,mspecs),ifoa(nflav)
9434       real datx(nhismu),datyu(nhismu)
9435       character cyieur*9
9436       real pzlog(nhismu)
9437       double precision spelog,cc,bb,dsu
9438       common/cyield/yield
9439       character*3 htyp
9440
9441       idcode=nint(xpar1)
9442       x1=xpar2
9443       x2=xpar3
9444       i1=nint(xpar2)
9445       i2=nint(xpar3)
9446       ii1=nint(xpar4)
9447       ii2=nint(xpar5)
9448       ih=nint(xpar6)
9449       htyp='lin'
9450       if(ih.eq.1)htyp='lfu'
9451       if(ih.eq.2)htyp='ldo'
9452       if(ih.eq.3)htyp='lda'
9453       if(ih.eq.4)htyp='ldd'
9454       itmax=nint(xpar7)
9455
9456       wtrlog=-1e30
9457            do i=ii1,ii2
9458       if(i.ge.2)then
9459       np=i
9460       do k=1,np
9461       ident(k)=110
9462       enddo
9463       call hnbtst(0)
9464       wtzlog=wtulog
9465       if(ioflac.eq.0)call hnbspg(keu,ked,kes,kec,keb,ket,0,np,spelog)
9466       if(ioflac.ne.0)call hnbspf(keu,ked,kes,kec,keb,ket,0,np,spelog)
9467       wtulog=wtulog+spelog
9468       else
9469       wtzlog=-1000
9470       wtulog=-1000
9471       endif
9472       pzlog(1+i-ii1)=wtzlog
9473       datyu(1+i-ii1)=wtulog
9474       wtrlog=max(wtrlog,wtulog)
9475            enddo
9476       yield=0
9477       su=0
9478            do i=ii1,ii2
9479       l=1+i-ii1
9480       pzlog(l)=pzlog(l)-wtrlog
9481       datyu(l)=datyu(l)-wtrlog
9482       if(datyu(l).gt.-50.)then
9483       datyu(l)=exp(datyu(l))
9484       else
9485       datyu(l)=exp(-50.)
9486       endif
9487       yield=yield+i*datyu(l)
9488       su=su+datyu(l)
9489            enddo
9490       yield=yield/su
9491            do i=ii1,ii2
9492       l=1+i-ii1
9493       datx(l)=i
9494       datyu(l)=datyu(l)/su
9495            enddo
9496       jx=1+ii2-ii1
9497       write(cyieur,'(f9.4)')yield
9498 c     ---
9499         if(idcode.eq.0.and.itmax.eq.0)then
9500       write(ifhi,'(a,2e11.3)')'openhisto xrange',x1,x2
9501       write(ifhi,'(a)')       'htyp '//htyp//' xmod lin ymod log'
9502       write(ifhi,'(a)')       'text 0.30 0.15 "N?ana!='//cyieur//'"'
9503       write(ifhi,'(a)')       'array 2'
9504       do i=1,jx
9505       write(ifhi,'(2e12.4)')   datx(i),datyu(i)
9506       enddo
9507       write(ifhi,'(a)')       '  endarray'
9508       write(ifhi,'(a)')       'closehisto'
9509         elseif(idcode.eq.0)then
9510       write(ifhi,'(a,2e11.3)')'openhisto xrange',0.,itmax*1.
9511       write(ifhi,'(a)')       'htyp '//htyp//' xmod lin ymod lin'
9512       write(ifhi,'(a)')       'array 2'
9513       itm=20
9514       do i=1,itm
9515       write(ifhi,'(2e12.4)')   (i-1.)*itmax/(itm-1.),yield
9516       enddo
9517       write(ifhi,'(a)')       '  endarray'
9518       write(ifhi,'(a)')       'closehisto'
9519         endif
9520 c     ---
9521       if(idcode.eq.0)return
9522
9523            do j=1,nspecs
9524            if(idcode.eq.ispecs(j))then
9525
9526       wtrlog=-1e30
9527            do i=i1,i2
9528       l=1+i-i1
9529       datx(l)=i
9530            enddo
9531       yield=0
9532       suj=0
9533       dsu=su
9534            do i=i1,i2
9535       l=1+i-i1
9536       bb=0
9537       nfi=0
9538       do ntot=max(i+1,ii1),min(i2*nspecs,ii2)
9539       nfi=nfi+1
9540       cc=1d0
9541       do kc=1,i
9542       cc=cc*(1.+ntot-kc)/kc*gspecs(j)
9543       enddo
9544       ku=keu-i*ifok(1,j)
9545       kd=ked-i*ifok(2,j)
9546       ks=kes-i*ifok(3,j)
9547       kc=kec-i*ifok(4,j)
9548       kb=keb-i*ifok(5,j)
9549       kt=ket-i*ifok(6,j)
9550       if(ioflac.eq.0)call hnbspg(ku,kd,ks,kc,kb,kt,j,ntot-i,spelog)
9551       if(ioflac.ne.0)call hnbspf(ku,kd,ks,kc,kb,kt,j,ntot-i,spelog)
9552       cc=cc*dexp(spelog)
9553       bb=bb+cc*dexp(1.d0*pzlog(1+ntot-ii1))/dsu
9554       enddo
9555       datyu(l)=bb
9556       yield=yield+i*datyu(l)
9557       suj=suj+datyu(l)
9558            enddo
9559       yield=yield/suj
9560       jx=1+i2-i1
9561       write(cyieur,'(f9.4)')yield
9562 c     ---
9563         if(itmax.eq.0)then
9564       write(ifhi,'(a,2e11.3)')'openhisto xrange',x1,x2
9565       write(ifhi,'(a)')       'htyp '//htyp//' xmod lin ymod log'
9566       write(ifhi,'(a)')       'text 0.30 0.15 "N?ana!='//cyieur//'"'
9567       write(ifhi,'(a)')       'array 2'
9568       do i=1,jx
9569       write(ifhi,'(2e12.4)')   datx(i),datyu(i)
9570       enddo
9571       write(ifhi,'(a)')       '  endarray'
9572       write(ifhi,'(a)')       'closehisto'
9573         else
9574       write(ifhi,'(a,2e11.3)')'openhisto xrange',0.,itmax*1.
9575       write(ifhi,'(a)')       'htyp '//htyp//' xmod lin ymod lin'
9576       write(ifhi,'(a)')       'array 2'
9577       itm=20
9578       do i=1,itm
9579       write(ifhi,'(2e12.4)')   (i-1.)*itmax/(itm-1.),yield
9580       enddo
9581       write(ifhi,'(a)')       '  endarray'
9582       write(ifhi,'(a)')       'closehisto'
9583         endif
9584 c     ---
9585       return
9586
9587            endif
9588            enddo
9589
9590       end
9591
9592 c-----------------------------------------------------------------------
9593       subroutine xhnbte(iii)
9594 c-----------------------------------------------------------------------
9595 c fills histograms (iii>=0) or writes histogram to histo-file (iii<0)
9596 c regarding exponential autocorrelation time and acceptance rate
9597 c
9598 c input:
9599 c   requires complete run with application hadron (iappl=1)
9600 c   or application metropolis (iappl=4)
9601 c   ioceau=1 necessary
9602 c
9603 c  output:
9604 c   for iii=0 (only valid for iappl=4):
9605 c     data(nrevt): nrevt  (event number)               /cdat/
9606 c     datb(nrevt): taui   (calculated corr time)       /cdat/
9607 c     datc(nrevt): accrat (acceptance rate)            /cdat/
9608 c     datd(nrevt): taue   (parametrized corr time)     /cdat/
9609 c   for iii>0 (only valid for iappl=1):
9610 c     nrclu=nrclu+1                                    /cnrclu/
9611 c     data(nrclu): nrclu  (droplet number)             /cdat/
9612 c     datb(nrclu): taui-taue (calc - param corr time)  /cdat/
9613 c     datc(nrclu): accrat (acceptance rate)            /cdat/
9614 c     datd(nrclu): avnp (average particle number)      /cdat/
9615 c   for iii<0:
9616 c     writes complete histogram (openhisto ... closehisto) to histofile
9617 c       for iappl=4:                for iappl=1:
9618 c         xpar1=1: (data,datb,datd) xpar1=1: (data,datb)
9619 c         xpar1=2: (data,datc)      xpar1=2: (data,datd)
9620 c                                   xpar1=3: (data,datc)
9621 c-----------------------------------------------------------------------
9622       include 'epos.inc'
9623       parameter(maxit=50000)
9624       common/count/nacc,nrej,naccit(maxit),nptot,npit(maxit)
9625       common/citer/iter,itermx
9626       common /clatt/nlattc,npmax
9627       common/cgctot/rmstot,ptltot
9628       parameter (mspecs=56)
9629       common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
9630       common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
9631       parameter (nbin=500)
9632       common/cdat/ data(nbin),datb(nbin),datc(nbin),datd(nbin)
9633       real dev(maxit)
9634       character cobs*5,cnc*5,cdz*5,czer*5
9635      *,cmom*5,cnp*7,cen*7,cvol*7,clatt*5,cit*5
9636       common/ctaue/taue
9637
9638       if(ioceau.ne.1)stop'STOP: ioceau=1 required'
9639       if(iii.eq.0.and.iappl.ne.4)stop'STOP: iappl=4 required'
9640       if(iii.gt.0.and.iappl.ne.1)stop'STOP: iappl=1 required'
9641
9642       if(iii.lt.0)jjj=nint(xpar1)
9643
9644       ish0=ish
9645 c     ish=98
9646
9647 c          ----------------
9648            if(iii.ge.0)then
9649 c          ----------------
9650
9651       if(iii.gt.0)nrclu=nrclu+1
9652       if(nrclu.gt.500)return
9653
9654 c     mean
9655 c     ----
9656       xnptot=nptot
9657       avnp=xnptot/(itermx-iternc)
9658       if(ish.ge.9)write(ifch,*)'event:',nrevt,'   droplet:',nrclu
9659      *,'   avnp:',avnp
9660
9661 c     calculate corfct_0
9662 c     ------------------
9663       corzer=0.0
9664       do i=iternc+1,itermx
9665       dev(i)=npit(i)-avnp
9666       corzer=corzer+dev(i)**2
9667       enddo
9668       corzer=corzer/(itermx-iternc)
9669       if(ish.ge.9)write(ifch,*)'c_0:',corzer
9670
9671 c     calculate corfct_1
9672 c     ------------------
9673       corone=0.0
9674       do i=iternc+1,itermx-1
9675       corone=corone+dev(i)*dev(i+1)
9676       enddo
9677       corone=corone/(itermx-iternc-1)
9678
9679 c     calculate initial autocorrelation time
9680 c     -----------------------------------------
9681       if(corone.gt.1.e-30.and.corzer.gt.1.e-30)then
9682       r=alog(corone)-alog(corzer)
9683       if(ish.ge.9)write(ifch,*)'log rho_1:',r
9684       taui=(-1.)/r
9685       else
9686       taui=0.
9687       endif
9688       if(ish.ge.9)write(ifch,*)'tau_init:',taui
9689
9690 c     calculate parametrized autocorrelation time (if necessary)
9691 c     ----------------------------------------------------------
9692       if(taue.eq.0.0)then
9693       e=tecm/volu
9694       b=1.1*(e+0.33)**0.66
9695       a=13.*(e+0.13)**(-0.65)
9696       tm=34.*(e+0.65)**(-0.61)
9697       t=a+b*volu
9698       taue=max(t,tm)
9699       endif
9700
9701 c     calculate acceptance rate
9702 c     -------------------------
9703       xa=nacc
9704       ya=itermx
9705       accrat=xa/ya
9706
9707 c     write to data/b/c/d
9708 c     -------------------
9709        if(iii.eq.0)then
9710       if(iozevt.gt.0)then
9711       data(nrevt)=iozero
9712       else
9713       data(nrevt)=nrevt
9714       endif
9715       datb(nrevt)=taui
9716       datc(nrevt)=accrat
9717       datd(nrevt)=taue
9718        else
9719       data(nrclu)=nrclu
9720       datb(nrclu)=taui-taue
9721       datc(nrclu)=accrat
9722       datd(nrclu)=avnp
9723        endif
9724
9725 c          -----------------------------------
9726            elseif(iii.lt.0.and.iappl.eq.4)then
9727 c          -----------------------------------
9728
9729       write(cmom,'(i3)')iomom
9730       write(cen,'(f7.3)')tecm
9731        if(ioobsv.eq.0)then
9732       write(cnp,'(f7.3)')ptltot
9733        else
9734        do i=1,nspecs
9735        if(ioobsv.eq.ispecs(i))id=i
9736        enddo
9737       write(cnp,'(f7.3)')ptlngc(id)
9738        endif
9739       write(cvol,'(f7.3)')volu
9740       write(clatt,'(i3)')nlattc
9741       write(cit,'(i5)')itermx
9742       if(ioobsv.eq.0)then
9743       write(cobs,'(a)')'all'
9744       else
9745       write(cobs,'(i5)')ioobsv
9746       endif
9747       write(cnc,'(i5)')iternc
9748       if(iozevt.eq.0)write(czer,'(i5)')iozero
9749       if(iozevt.gt.0)write(cdz,'(i5)')iozinc
9750
9751       x1=1
9752       x2=nevent
9753
9754       if(jjj.eq.1)then
9755
9756       write(ifhi,'(a)')       'openhisto'
9757       write(ifhi,'(a)')       'htyp lin xmod lin ymod lin'
9758       if(iozevt.gt.0)then
9759       write(ifhi,'(a)')       'text 0 0 "xaxis iozero"'
9760       else
9761       write(ifhi,'(a)')       'text 0 0 "xaxis event"'
9762       endif
9763       write(ifhi,'(a)')       'text 0 0 "yaxis [t]?exp!"'
9764       write(ifhi,'(a)')       'text 0.05 0.95 "E='//cen//'"'
9765       write(ifhi,'(a)')       'text 0.2  0.95 "V='//cvol//'"'
9766       write(ifhi,'(a)')       'text 0.35 0.95 "N?g!='//cnp//'"'
9767       write(ifhi,'(a)')       'text 0.55 0.95 "observable  '//cobs//'"'
9768       write(ifhi,'(a,2e11.3)')'xrange',x1,x2
9769       write(ifhi,'(a)')       'array 2'
9770       do j=1,nevent
9771       write(ifhi,'(2e12.4)')data(j),datb(j)
9772       enddo
9773       write(ifhi,'(a)')       '  endarray'
9774       write(ifhi,'(a)')       'closehisto plot 0-'
9775
9776       write(ifhi,'(a)')       'openhisto'
9777       write(ifhi,'(a)')       'htyp lin xmod lin ymod lin'
9778       write(ifhi,'(a,2e11.3)')'xrange',x1,x2
9779       write(ifhi,'(a)')       'array 2'
9780       do j=1,nevent
9781       write(ifhi,'(2e12.4)')data(j),datd(j)
9782       enddo
9783       write(ifhi,'(a)')       '  endarray'
9784       write(ifhi,'(a)')       'closehisto'
9785
9786       elseif(jjj.eq.2)then
9787
9788       write(ifhi,'(a)')       'openhisto'
9789       write(ifhi,'(a)')       'htyp lin xmod lin ymod lin'
9790       if(iozevt.gt.0)then
9791       write(ifhi,'(a)')       'text 0 0 "xaxis iozero"'
9792       else
9793       write(ifhi,'(a)')       'text 0 0 "xaxis event"'
9794       endif
9795       write(ifhi,'(a)')       'text 0 0 "yaxis acceptence rate"'
9796       write(ifhi,'(a)')       'text 0.05 0.95 "iomom= '//cmom//'"'
9797       write(ifhi,'(a)')       'text 0.2  0.95 "nlattc= '//clatt//'"'
9798       if(iozevt.eq.0)
9799      *write(ifhi,'(a)')       'text 0.35 0.95 "iozero= '//czer//'"'
9800       write(ifhi,'(a)')       'text 0.55 0.95 "itermx= '//cit//'"'
9801       write(ifhi,'(a)')       'text 0.75 0.95 "iternc= '//cnc//'"'
9802       if(iozevt.gt.0)
9803      *write(ifhi,'(a)')       'text 0.35  0.95 "dzero= '//cdz//'"'
9804       if(iorejz.eq.1)
9805      *write(ifhi,'(a)')    'text 0.25 0.05 "zeros rejected !"'
9806       if(ioinco.ge.1)then
9807       write(ifhi,'(a)')    'text 0.05 0.05 "hot start"'
9808       else
9809       write(ifhi,'(a)')    'text 0.05 0.05 "cold start"'
9810       endif
9811       write(ifhi,'(a,2e11.3)')'xrange',x1,x2
9812       write(ifhi,'(a)')       'array 2'
9813       do j=1,nevent
9814       write(ifhi,'(2e12.4)')data(j),datc(j)
9815       enddo
9816       write(ifhi,'(a)')       '  endarray'
9817       write(ifhi,'(a)')       'closehisto'
9818
9819       endif
9820
9821 c          -----------------------------------
9822            elseif(iii.lt.0.and.iappl.eq.1)then
9823 c          -----------------------------------
9824
9825       if(ioobsv.eq.0)then
9826       write(cobs,'(a)')'all'
9827       else
9828       write(cobs,'(i5)')ioobsv
9829       endif
9830
9831       x1=1
9832       x2=nrclu
9833
9834       if(jjj.eq.1)then
9835
9836       write(ifhi,'(a)')       'openhisto'
9837       write(ifhi,'(a)')       'htyp lin xmod lin ymod lin'
9838       write(ifhi,'(a)')       'text 0 0 "xaxis droplet"'
9839       write(ifhi,'(a)')       'text 0 0 "yaxis [D][t]?exp!"'
9840       write(ifhi,'(a)')       'text 0.05 0.91 "[D][t]?exp!=[t]?measured!
9841      *-[t]?parametrized"'
9842       write(ifhi,'(a,2e11.3)')'xrange',x1,x2
9843       write(ifhi,'(a,a,a)')'yrange',' auto',' auto'
9844       write(ifhi,'(a)')       'array 2'
9845       do j=1,nrclu
9846       write(ifhi,'(2e12.4)')data(j),datb(j)
9847       enddo
9848       write(ifhi,'(a)')       '  endarray'
9849       write(ifhi,'(a)')       'closehisto'
9850
9851       elseif(jjj.eq.2)then
9852
9853       write(ifhi,'(a)')       'openhisto'
9854       write(ifhi,'(a)')       'htyp lin xmod lin ymod lin'
9855       write(ifhi,'(a)')       'text 0 0 "xaxis droplet"'
9856       write(ifhi,'(a)')       'text 0 0 "yaxis N?obs!"'
9857       write(ifhi,'(a)')       'text 0.05 0.95 "observable  '//cobs//'"'
9858       write(ifhi,'(a,2e11.3)')'xrange',x1,x2
9859       write(ifhi,'(a)')       'array 2'
9860       do j=1,nrclu
9861       write(ifhi,'(2e12.4)')data(j),datd(j)
9862       enddo
9863       write(ifhi,'(a)')       '  endarray'
9864       write(ifhi,'(a)')       'closehisto'
9865
9866       elseif(jjj.eq.3)then
9867
9868       write(ifhi,'(a)')       'openhisto'
9869       write(ifhi,'(a)')       'htyp lin xmod lin ymod lin'
9870       write(ifhi,'(a)')       'text 0 0 "xaxis droplet"'
9871       write(ifhi,'(a)')       'text 0 0 "yaxis accep. rate"'
9872       write(ifhi,'(a,2e11.3)')'xrange',x1,x2
9873       write(ifhi,'(a)')       'array 2'
9874       do j=1,nrclu
9875       write(ifhi,'(2e12.4)')data(j),datc(j)
9876       enddo
9877       write(ifhi,'(a)')       '  endarray'
9878       write(ifhi,'(a)')       'closehisto'
9879
9880       endif
9881
9882 c          -----
9883            endif
9884 c          -----
9885
9886       ish=ish0
9887       return
9888       end
9889
9890 c-------------------------------------------------------------------------
9891       subroutine xhnbti(iii)
9892 c-------------------------------------------------------------------------
9893 c fills histograms (iii=0) or writes histogram to histo-file (iii<0)
9894 c regarding integrated autocorrelation time and corresponding multiplicity
9895 c and variance
9896 c
9897 c input:
9898 c   requires complete run with application metropolis (iappl=4)
9899 c   iociau=1 necessary
9900 c   iompar (parameter for windowing algorithm by  a.d.sokal) must
9901 c   be set to 3 < c_M < 11
9902 c
9903 c  output:
9904 c   for iii=0 (only valid for iappl=4):
9905 c     data(nrevt): nrevt (event number)              /cdat/
9906 c     datb(nrevt): tau   (calculated int corr time)  /cdat/
9907 c     datc(nrevt): stau  (variance tau)              /cdat/
9908 c     datd(nrevt): avnp  (multiplicity)              /cdat/
9909 c     date(nrevt): sobs  (variance multiplicity)     /cdat/
9910 c     datf(nrevt):       (gc multiplicity)           /cdat/
9911 c   for iii=0 and iosngl>0:
9912 c     writes complete set of histograms (newpage zone 1 3 1
9913 c     openhisto ... closehisto plot0 ... openhisto ... closehisto plot 0)
9914 c     concerning acceptance rate, rejection rate, correlation function
9915 c     for specific event, specified by value of iosngl (=nrevt+1)
9916 c   for iii<0:
9917 c     writes complete histogram (openhisto ... closehisto) to histofile
9918 c       xpar1=1: (data,datb,datc)
9919 c       xpar1=2: (data,datd,date,datf)
9920 c------------------------------------------------------------------------
9921       include 'epos.inc'
9922       parameter(maxit=50000)
9923       common/count/nacc,nrej,naccit(maxit),nptot,npit(maxit)
9924       common/citer/iter,itermx
9925       parameter(maxp=500)
9926       common/confg/np,amass(maxp),ident(maxp),pcm(5,maxp),wtxlog,wtlog
9927       common /clatt/nlattc,npmax
9928       common/cgctot/rmstot,ptltot
9929       parameter (mspecs=56)
9930       common/cspecs/nspecs,ispecs(mspecs),aspecs(mspecs),gspecs(mspecs)
9931       common/cgchg/rmsngc(mspecs),ptlngc(mspecs),chemgc(mspecs),tem
9932       parameter (nbin=500)
9933       common/cdat2/data(nbin),datb(nbin),datc(nbin),datd(nbin)
9934      *,date(nbin),datf(nbin),datg(nbin),dath(nbin)
9935       common/cdat3/datx(nbin),daty(nbin),datz(nbin),datr(nbin)
9936      *,dats(nbin)
9937       real corfct(maxit),dev(maxit)
9938       character cobs*5,cdz*5,ccuev*5,cmpar*3,ctau*7
9939       character cmom*5,cnp*7,cen*7,cvol*7,clatt*5,cit*5,cavnp*7
9940       character cnacc*10,cnrej*10,caver*10,cioz*5,ciom*3,cnlat*5
9941
9942       if(iociau.ne.1)stop'STOP: iociau=1 required'
9943       if(iii.eq.0.and.iappl.ne.4)stop'STOP: iappl=4 required'
9944       if(iii.gt.0)stop'STOP: iii>0 not supported'
9945
9946       jjj=nint(xpar1)
9947
9948 c          ----------------
9949            if(iii.eq.0)then
9950 c          ----------------
9951
9952 c     mean
9953 c     ----
9954       xnptot=nptot
9955       avnp=xnptot/(itermx-iternc)
9956       if(ish.ge.9)write(ifch,*)'event:',nrevt,'   avnp:',avnp
9957
9958 c     normalization of corfct_i
9959 c     -------------------------
9960       corzer=0.0
9961       do i=iternc+1,itermx
9962       dev(i)=npit(i)-avnp
9963       if(ish.ge.9)write(ifch,*)'i:',i,'  dev_i:',dev(i)
9964       corzer=corzer+dev(i)**2
9965       enddo
9966       corzer=corzer/(itermx-iternc)
9967       if(ish.ge.9)write(ifch,*)'c_0:',corzer
9968
9969 c     calculate corfct_i
9970 c     ------------------
9971       nt=itermx-iternc-1
9972       do it=1,nt
9973       corfct(it)=0.0
9974       do i=iternc+1,itermx-it
9975       corfct(it)=corfct(it)+dev(i)*dev(i+it)
9976       enddo
9977       corfct(it)=corfct(it)/(itermx-iternc-it)
9978       if(it.le.10.and.ish.ge.9)
9979      *write(ifch,*)'t:',it,'  c_t:',corfct(it)
9980       enddo
9981
9982 c     calculate initial autocorrelation time
9983 c     -----------------------------------------
9984       if(corfct(1).gt.1.e-30.and.corzer.gt.1.e-30)then
9985       r=alog(corfct(1))-alog(corzer)
9986       if(ish.ge.9)write(ifch,*)'log rho_1:',r
9987       taui=(-1.)/r
9988       else
9989       taui=0.
9990       endif
9991       if(ish.ge.9)write(ifch,*)'tau_init:',taui
9992
9993 c     calculate integrated autocorrelation time
9994 c     -----------------------------------------
9995       k=1
9996       mpar=iompar
9997       tau=taui
9998       taux=taui
9999       taum=0.0
10000       if(ish.ge.9)write(ifch,*)'initial tau:',tau,'   c_M:',mpar
10001
10002         if(corzer.gt.1.e-30)then
10003
10004 5     mcut=mpar*abs(taux)
10005       tauo=tau
10006       tau=.5
10007       do it=1,mcut
10008       tau=tau+corfct(it)/corzer
10009       enddo
10010       taum=taum+tau
10011       taux=taum/k
10012       if(ish.ge.9)write(ifch,*)'iteration:',k,'   M:',mcut,'  tau:',tau
10013       if(mcut.lt.(mpar*tau).or.mcut.gt.(10.*tau))then
10014       dt=abs(tau-tauo)
10015       if(k.lt.20.and.dt.gt.0.2)then
10016       k=k+1
10017       goto5
10018       endif
10019       endif
10020       mcut=mpar*abs(taux)
10021       if(ish.ge.9)write(ifch,*)'tau_mean:',taux,'   M:',mcut
10022       tau=0.5
10023       do it=1,mcut
10024       tau=tau+corfct(it)/corzer
10025       enddo
10026
10027        endif
10028
10029       vtau=(2.*mcut+1.)*2./(itermx-iternc)*tau**2
10030       stau=0.0
10031       if(vtau.ge.0.0)stau=sqrt(vtau)
10032       if(ish.ge.9)
10033      *write(ifch,*)'tau_int:',tau,'   var:',vtau,'   sig:',stau
10034
10035 c     calculate variance of observable
10036 c     --------------------------------
10037       vobs=2.*tau*corzer/(itermx-iternc)
10038       sobs=0.0
10039       if(vobs.ge.0.0)sobs=sqrt(vobs)
10040
10041 c     write to data-f
10042 c     ---------------
10043        if(ioobsv.eq.0)then
10044       datf(nrevt)=ptltot
10045        else
10046       do j=1,np
10047       if(ioobsv.eq.ispecs(j))id=j
10048       enddo
10049       datf(nrevt)=ptlngc(id)
10050        endif
10051       datb(nrevt)=tau
10052       datc(nrevt)=stau
10053       date(nrevt)=sobs
10054       datd(nrevt)=avnp
10055       if(iozevt.gt.0)then
10056       data(nrevt)=iozero
10057       else
10058       data(nrevt)=nrevt
10059       endif
10060
10061 c          -------------------------
10062            if(iosngl.eq.nrevt+1)then
10063 c          -------------------------
10064
10065       nb=itermx/iterpl
10066       if(nb.gt.nbin)nb=nbin
10067
10068       datx(1)=iterpl/2
10069       daty(1)=naccit(1)
10070       datz(1)=1-naccit(1)
10071       if(iterpl.ge.2)then
10072       do j=1,iterpl-1
10073       daty(1)=daty(1)+naccit(1+j)
10074       datz(1)=datz(1)+1-naccit(1+j)
10075       enddo
10076       endif
10077       datr(1)=daty(1)/iterpl
10078       dats(1)=datz(1)/iterpl
10079       do i=2,nb
10080       datx(i)=datx(i-1)+iterpl
10081       daty(i)=daty(i-1)
10082       datz(i)=datz(i-1)
10083       do j=1,iterpl
10084       daty(i)=daty(i)+naccit((i-1)*iterpl+j)
10085       datz(i)=datz(i)+1-naccit((i-1)*iterpl+j)
10086       enddo
10087       datr(i)=daty(i)/i/iterpl
10088       dats(i)=datz(i)/i/iterpl
10089       enddo
10090       b=nacc
10091       c=itermx
10092       avrate=b/c
10093       write(cnacc,'(i6)')nacc
10094       write(cnrej,'(i6)')nrej
10095       write(caver,'(f5.3)')avrate
10096       write(cioz,'(i5)')iozero
10097       write(ciom,'(i3)')iomom
10098       write(cnlat,'(i5)')nlattc
10099       x1=datx(1)
10100       x2=datx(nb)
10101
10102       write(ifhi,'(a)')       'newpage zone 1 3 1 openhisto'
10103       write(ifhi,'(a)')       'htyp lin xmod lin ymod lin'
10104       write(ifhi,'(a)')       'text 0 0 "xaxis iterations"'
10105       write(ifhi,'(a)')       'text 0 0 "yaxis acceptence rate"'
10106       write(ifhi,'(a)')       'text 0.6 0.5 "accepted '//cnacc//'"'
10107       write(ifhi,'(a)')       'text 0.6 0.4 "rejected  '//cnrej//'"'
10108       write(ifhi,'(a)')       'text 0.6 0.3 "aver. rate  '//caver//'"'
10109       write(ifhi,'(a)')       'text 0.4 0.5 "nlattc='//cnlat//'"'
10110       write(ifhi,'(a)')       'text 0.4 0.4 "iozero='//cioz//'"'
10111       write(ifhi,'(a)')       'text 0.4 0.3 "iomom='//ciom//'"'
10112       write(ifhi,'(a,2e11.3)')'xrange',x1,x2
10113       write(ifhi,'(a)')       'array 2'
10114       do j=1,nb
10115       write(ifhi,'(2e12.4)')datx(j),datr(j)
10116       enddo
10117       write(ifhi,'(a)')       '  endarray'
10118       write(ifhi,'(a)')       'closehisto plot 0-'
10119
10120       write(ifhi,'(a)')       'openhisto'
10121       write(ifhi,'(a,2e11.3)')'xrange',x1,x2
10122       write(ifhi,'(a)')       'array 2'
10123       do j=1,nb
10124       write(ifhi,'(2e12.4)')datx(j),dats(j)
10125       enddo
10126       write(ifhi,'(a)')       '  endarray'
10127       write(ifhi,'(a)')       'closehisto plot 0'
10128
10129       m=min(mcut,500)
10130       do i=1,m
10131       datg(i)=i
10132       dath(i)=1000.
10133       if(corzer.gt.1.e-30)dath(i)=corfct(i)/corzer
10134       enddo
10135       write(ccuev,'(i5)')nrevt+1
10136       write(cmpar,'(i3)')mpar
10137       write(ctau,'(i7)')tau
10138       x1=1.
10139       x2=m
10140
10141       write(ifhi,'(a)')       'openhisto'
10142       write(ifhi,'(a)')       'htyp lin xmod lin ymod lin'
10143       write(ifhi,'(a)')       'text 0 0 "xaxis t"'
10144       write(ifhi,'(a)')       'text 0 0 "yaxis correl. func."'
10145       write(ifhi,'(a)')       'text 0.8 0.95 "event '//ccuev//'"'
10146       write(ifhi,'(a)')'text 0.05 0.95  "window parameter= '//cmpar//'"'
10147       write(ifhi,'(a)')       'text 0.35 0.95  "tau= '//ctau//'"'
10148       write(ifhi,'(a,2e11.3)')'xrange',x1,x2
10149       write(ifhi,'(a,a,a)')'yrange',' auto',' auto'
10150       write(ifhi,'(a)')       'array 2'
10151       do j=1,m
10152       write(ifhi,'(2e12.4)')datg(j),dath(j)
10153       enddo
10154       write(ifhi,'(a)')       '  endarray'
10155       write(ifhi,'(a)')       'closehisto plot 0'
10156
10157 c          -----
10158            endif
10159 c          -----
10160
10161 c          --------------------
10162            elseif(iii.lt.0)then
10163 c          --------------------
10164
10165       write(cmom,'(i3)')iomom
10166        if(ioobsv.eq.0)then
10167       write(cnp,'(f7.3)')ptltot
10168        else
10169       do j=1,np
10170       if(ioobsv.eq.ispecs(j))id=j
10171       enddo
10172       write(cnp,'(f7.3)')ptlngc(id)
10173        endif
10174       write(cen,'(f7.3)')tecm
10175       write(cvol,'(f7.3)')volu
10176       write(clatt,'(i3)')nlattc
10177       write(cit,'(i5)')itermx
10178       write(cavnp,'(f7.3)')avnp
10179       if(iozevt.gt.0)
10180      *write(cdz,'(i5)')iozinc
10181       write(cmpar,'(i3)')mpar
10182       if(ioobsv.eq.0)then
10183       write(cobs,'(a)')'all'
10184       else
10185       write(cobs,'(i5)')ioobsv
10186       endif
10187
10188       x1=data(1)
10189       x2=data(nevent)
10190
10191       if(jjj.eq.1)then
10192
10193       write(ifhi,'(a)')       'openhisto'
10194       write(ifhi,'(a)')       'htyp pnt xmod lin ymod lin'
10195       if(iozevt.gt.0)then
10196       write(ifhi,'(a)')       'text 0 0 "xaxis iozero"'
10197       else
10198       write(ifhi,'(a)')       'text 0 0 "xaxis event"'
10199       endif
10200       write(ifhi,'(a)')       'text 0 0 "yaxis [t]?int!"'
10201       write(ifhi,'(a)')'text 0.05 0.95  "window parameter '//cmpar//'"'
10202       if(iozevt.gt.0)
10203      *write(ifhi,'(a)')       'text 0.8  0.95 "dzero= '//cdz//'"'
10204       write(ifhi,'(a,2e11.3)')'xrange',x1,x2
10205       write(ifhi,'(a)')       'array 3'
10206       do j=1,nevent
10207       write(ifhi,'(3e12.4)')data(j),datb(j),datc(j)
10208       enddo
10209       write(ifhi,'(a)')       '  endarray'
10210       write(ifhi,'(a)')       'closehisto'
10211
10212       elseif(jjj.eq.2)then
10213
10214       write(ifhi,'(a)')       'openhisto'
10215       write(ifhi,'(a)')       'htyp pnt xmod lin ymod lin'
10216       if(iozevt.gt.0)then
10217       write(ifhi,'(a)')       'text 0 0 "xaxis iozero"'
10218       else
10219       write(ifhi,'(a)')       'text 0 0 "xaxis event"'
10220       endif
10221       write(ifhi,'(a)')       'text 0 0 "yaxis multiplicity"'
10222       write(ifhi,'(a)')       'text 0.05 0.95 "E='//cen//'"'
10223       write(ifhi,'(a)')       'text 0.2 0.95 "V='//cvol//'"'
10224       write(ifhi,'(a)')       'text 0.35 0.95 "N?g!='//cnp//'"'
10225       write(ifhi,'(a)')       'text 0.55 0.95 "observable  '//cobs//'"'
10226       write(ifhi,'(a,2e11.3)')'xrange',x1,x2
10227       write(ifhi,'(a,a,a)')'yrange',' auto',' auto'
10228       write(ifhi,'(a)')       'array 3'
10229       do j=1,nevent
10230       write(ifhi,'(3e12.4)')data(j),datd(j),date(j)
10231       enddo
10232       write(ifhi,'(a)')       '  endarray'
10233       write(ifhi,'(a)')       'closehisto   plot 0-'
10234
10235
10236       write(ifhi,'(a)')       'openhisto'
10237       write(ifhi,'(a)')       'htyp lda xmod lin ymod lin'
10238       write(ifhi,'(a)')       'array 2'
10239       do j=1,nevent
10240       write(ifhi,'(2e12.4)')data(j),datf(j)
10241       enddo
10242       write(ifhi,'(a)')       '  endarray'
10243       write(ifhi,'(a)')       'closehisto'
10244
10245       endif
10246
10247 c          -----
10248            endif
10249 c          -----
10250
10251       return
10252       end