      subroutine p_e_init(lpr) ! bernd berg, jan 15 2002.
      include '../../libs/fortran/implicit.sta'
      include '../../libs/fortran/constants.par'
c initializes arrays needed for generalized potts model mc calculation.
      include '../../libs/fortran_par/lat.par'
      include '../../libs/fortran_par/mc.par'
      include '../../libs/fortran_par/potts.par'
      include '../../libs/fortran_par/p_eds.par'
      include '../../libs/fortran_par/common_lat.f'
      include '../../libs/potts_par/common_potts.f'
      include '../../libs/fortran_par/common_p_eds.f'
      dimension ix(nd)
c initializations:
      if(lpr) call rmaset(iuo,iud1,iseed1,iseed2,'nexiste.pa') 
      if(.not.lpr) call rmaset(-iuo,iud1,iseed1,iseed2,'nexiste.pa') 
      call ranmar(xr) ! random numbers initialized; first random number.
      ia_min=mlink
      ia_max=0
      call lat_init(ms,nd,ipf,ipb,nla,ix) ! lattice initialized.
      call potts_act_tab(idel,nqm1)   ! potts action table calculated.
      if(istart.eq.1) call potts_order(ista,iact,nd,ms,nqm1) ! ordered start.
      if(istart.eq.2) call potts_ran(ista,ms,nq)  ! disordered start.
      if(istart.ne.1.and.istart.ne.2) stop "p_e_init: istart false."
      call potts_act(ista,ipf,idel,ms,nqm1,nd,iact) ! action calculated.
      call razero(ha,izero,mlink)         ! initialize action histogram.
      call p_e_tabs                       ! event driven mc tables.
c
      if(.not.lpr) return
      write(iuo,'(" initial randon number: xr =",1f12.6)') xr
      write(iuo,'(" lat.par: nd,nq,nla =",1i2,1i3,3x,8i4)')
     &                       nd,nq,nla
      write(iuo,'("          ms,mlink  =  ",2i10)') ms,mlink
      write(iuo,'(" mc.par:")')
      write(iuo,'(" iuo,iud1,iseed1,iseed2,    beta")')
      write(iuo,'(        2i4,           2i7,    1f11.6)')
     &              iuo,iud1,iseed1,iseed2,beta
      write(iuo,'(" initial action:     iact  =",1i10)') iact
      write(iuo,'(" nequi,nrpt,nmeas:      ",3i15)') nequi,nrpt,nmeas
      write(iuo,'("pstay,pmove,pstay+pmove:",3g15.7)')
     &             pstay,pmove,(pstay+pmove)
c
      return
      end 


      subroutine p_e_tabs ! bernd berg, jan 14 2002.
      include '../../libs/fortran/implicit.sta'
      include '../../libs/fortran/constants.par'
      include '../../libs/fortran_par/lat.par'
      include '../../libs/fortran_par/mc.par'
      include '../../libs/fortran_par/potts.par'
      include '../../libs/fortran_par/p_eds.par'
      include '../../libs/fortran_par/common_lat.f'
      include '../../libs/potts_par/common_potts.f'
      include '../../libs/fortran_par/common_p_eds.f'
      dimension iqarray(n2d),nqa(n2d)
      dimension nact_old(0:n2dp1,mcase),nact_new(0:n2dp1)
c
      xnsi=one/ms
      ncase=0
      do id=1,n2d
        nqa(id)=nq ! sets the box dimension for the ixcor call.
      end do
c
      do icon0=1,nconf0 ! loop over the neighbor configurations.
        call ixcor(iqarray,nqa,icon0,n2d)
        do iq0=0,nqm1   ! loop over the central state.
          do id=0,n2d
            nact_new(id)=0
          end do
          iconf=icon0+iq0*nconf0
          do iq=0,nqm1
            ia=0
            do id=1,n2d
              if(iq.eq.iqarray(id)) ia=ia+1
            end do
            if(iq.ne.iq0) nact_new(ia)=nact_new(ia)+1
            if(iq.eq.iq0) nact_new(n2dp1)=ia
          end do
          call p_e_compare(nact_old,nact_new,n2d,mcase,ncase,icase)
          if(ncase.gt.mcase) stop "p_e_tabs: enlarge mcase!"
	  if(icase.gt.ncase) then
	    icase=ncase
            peds0=exp(2*nact_new(n2dp1)*beta)
            psum=peds0
            do id=0,n2d
              psum=psum+nact_new(id)*exp(2*id*beta)
            end do
            qmove(ncase)=xnsi*(one-peds0/psum)
            do id=0,n2d
              peds1(id,ncase)=xnsi*exp(2*id*beta)/psum
            end do
          end if
          iacase(iconf)=icase
          ia_array(icase)=nact_new(n2dp1)
        end do
      end do
c
      if(ncase.ne.mcase) then
        write(iuo,*) "p_e_init->p_e_tabs:"
        write(iuo,'(" re-run with mcase = ncase =",i6,".")') ncase
        stop "p_e_tabs: mcase.ne.ncase - change in p_e.par."
      end if
c
      do icase=1,mcase
        pcase(icase)=zero
        nacase(icase)=0
        do is=1,ms
          index(is,icase)=0
        end do
      end do
c
      pstay=zero
      do is=1,ms
        iq0=ista(is)
        iconf=1+iq0*nconf0
        ifct=1
        ia0=0
        do id=1,nd
          iqf=ista(ipf(id,is))
          iconf=iconf+ifct*iqf
          ifct=ifct*nq
          iqb=ista(ipb(id,is))
          iconf=iconf+ifct*iqb
          ifct=ifct*nq
          ia0=ia0+idel(iq0,iqf)
          ia0=ia0+idel(iq0,iqb)
        end do
        icase=iacase(iconf)
        iscase(is)=icase
        nacase(icase)=nacase(icase)+1
        index(nacase(icase),icase)=is
        index(is,mcase+1)=nacase(icase)
        pcase(icase)=pcase(icase)+qmove(icase)
      end do
c
      pmove=zero
      do icase=1,mcase
        pmove=pmove+pcase(icase)
      end do
      pstay=one-pmove
c
      return
      end
