      subroutine cbpointer(ic,is,ix,iasc,iwf1,iwf2,iwb1,iwb2,
     &                     ipfbcnt1,ipfbcnt2,ipbbcnt1,ipbbcnt2)
C Bernd Berg, Oct 11 2007. Only called when lbcex=.true..
C MPI pointers for BCs and corresponding modifications of checkerboard 
C pointers. Needed for both, Potts models and LGT.
C
C Presently the ipf1, ...  arrays are oversized for Potts. This could
C be changed by not using mbcs as their dimensions, but a new variable,
C which is mbcs in LGT and 0 for Potts.
C
C Input:   is = lattice site number, ic checkerboard color.
C          ix auxiliary array for coordinates.
C          iasc gets isc checkerboard label from is. Not kept permanently.
C
C Output:  ipf1,2, ipb1,2:   forward and backward checkerboard pointers.
C            Their labels refer to checkerboard of the originating site. 
C          ipfb1,2, ipbb1,2: pointers to gather boundaries. Their labels
C            refer to the checkerboard from which they gather.
C          ipfbcnt1(nd), ... counts boundary pointers for test in
C                            calling program. Not kept permanently.
      include '../../Libs/Fortran/implicit.sta'
      include 'mpif.h'
      include '../../Libs/Fortran_par/latmpi.par'
      include '../../Libs/Fortran_par/mc.par' ! Defines unit iud2.
      include '../../Libs/MPI_par/common_cblat.f'
c The (work) pointer arrays iwf1, iwf2, iwb1 and iwb2 enter as copies
c of the periodic lattice pointers arrays ipf1, ipf2, ipb1 and ipb2.
      dimension ix(nd),iasc(ms),iwf1(ndmpi,msc),iwf2(ndmpi,msc),
     &  iwb1(ndmpi,msc),iwb2(ndmpi,msc),ipfbcnt1(ndmpi),ipfbcnt2(ndmpi),
     &  ipbbcnt1(ndmpi),ipbbcnt2(ndmpi)
      ltest=.true.
      ltest=.false.
      call mpi_comm_rank(mpi_comm_world,my_id,ierr)
      if(ltest) then ! ----------------------------------------
        write(iuo,'("cbpointer: stop ltest my_id =",I8)') my_id
        write(iud2,'(/,"cbpointer: stop ltest.")') 
        close(iud2)
        call mpi_finalize(ierr)
      stop
      endif ! --------------------------------------------------
C 
      if(.not.lbcex) then
        if(my_id.eq.0) write(iuo,'("cbpointer: stop see MPI*.d.")')
        write(iud2,'("cbpointer: stop lbcex=.false., .true. required")')
        call mpi_finalize(ierr)
        close(iud2)
        call mpi_finalize(ierr)
      stop
      endif
C
C Pointers for BCs and modifications of the checkerboard pointers:
C
      isc=iasc(is)
      do idmpi=1,ndmpi
        call ixcor(ix,nla,is,nd)
C The logic in the following is:
C (a) Identify on sublattice my_id whether a site belongs to the
C     boundary of another sublattice in forward or backward idmpi 
C     direction.
C (b) Define new pointer arrays ipfb1, ipfb2, ipbb1, ipbb2, which
C     allow to gather the boundary sites on sublattice my_id. 
C     The number refers to the checkerboards from which they gather.
C     The b before the number stands for "boundary".
C     Forward (f) or backward (b) refer to the forward part or backward
C     part of the lattice from which we gather the sublattice from 
C     Once transferred to the destination lattice, the forward part
C     corresponds to a backward step out of the destination lattice,
C     correspondingly the backward part to a forward step.
C (c) Overwrite those ipf1, ipf2, ipb1, ipb2 checkerboard pointer, which
C     were implementing periodic boundary conditions, so that the point
C     now towards the gathered and transferred (later MPI send receive)
C     positions from the neighbouring sublattices. Note that the 
C     address scheme is the same on all sublattices.
C     iwf1, iwf2, iwb1, iwb2 are work arrays, which save the original
C     periodic pointers, so that there is no confusion with the already
C     overwritten entries. They are not needed in the simulation part.
        if(ix(idmpi).eq.nla(idmpi)-1) then ! Forward boundary pointers
          if(ic.eq.1) then ! Boundary arrays on checkerboard 1: isc->isbc.
C                          (is site position, b boundary, c checkerboard).
C Pointed to backward from checkerboard 2 ipb2(idmpi,iscf)=isbc.
            ipfbcnt1(idmpi)=ipfbcnt1(idmpi)+1
            if(ipfbcnt1(idmpi).gt.mscb) stop "cbpointer: ipfbcnt1."
            ipfb1(ipfbcnt1(idmpi),idmpi)=isc
            iscf=iwf1(idmpi,isc)
C Boundary location (on checkerboard 1 in the next sublattice):
            isbc=msc+ipfbcnt1(idmpi)+(idmpi-1)*mscb 
            ipb2(idmpi,iscf)=isbc ! changed ipb2, iwb2 keeps old value.
            if(ltest) write(iud2,'(2X,
     &           "cbpointer my_id,ic,idmpi,isc,iscf,ipb2:",I4,2I2,3I4)')
     &                      my_id,ic,idmpi,isc,iscf,ipb2(idmpi,iscf)
          else
            ipfbcnt2(idmpi)=ipfbcnt2(idmpi)+1
            if(ipfbcnt2(idmpi).gt.mscb) stop "cbpointer: ipfbcnt2."
            ipfb2(ipfbcnt2(idmpi),idmpi)=isc
            iscf=iwf2(idmpi,isc)
            isbc=msc+ipfbcnt2(idmpi)+(idmpi-1)*mscb ! boundary location.
            ipb1(idmpi,iscf)=isbc ! changed ipb1.
            if(ltest) write(iud2,'(2X,
     &        "cbpointer my_id,ic,idmpi,isc,iscf,ipb1:",I4,2I2,3I4)') 
     &                   my_id,ic,idmpi,isc,iscf,ipb1(idmpi,iscf)
          endif
        endif
        if(ix(idmpi).eq.0) then ! Backward boundary pointers
          if(ic.eq.1) then
            ipbbcnt1(idmpi)=ipbbcnt1(idmpi)+1
            if(ipbbcnt1(idmpi).gt.mscb) stop "cbpointer: ipbbcnt1."
            ipbb1(ipbbcnt1(idmpi),idmpi)=isc
            iscb=iwb1(idmpi,isc)
            isbc=noffset+ipbbcnt1(idmpi)+(idmpi-1)*mscb ! boundary location.
            ipf2(idmpi,iscb)=isbc ! changed ipf2.
            if(ltest) write(iud2,'(2X,
     &        "cbpointer my_id,ic,idmpi,isc,iscb,ipf2:",I4,2I2,3I4)') 
     &                   my_id,ic,idmpi,isc,iscb,ipf2(idmpi,iscb)
          else
            ipbbcnt2(idmpi)=ipbbcnt2(idmpi)+1
            if(ipbbcnt2(idmpi).gt.mscb) stop "cbpointer: ipbbcnt2."
            ipbb2(ipbbcnt2(idmpi),idmpi)=isc
            iscb=iwb2(idmpi,isc) ! old value of ifb2.
            isbc=noffset+ipbbcnt2(idmpi)+(idmpi-1)*mscb ! boundary location.
            ipf1(idmpi,iscb)=isbc ! changed ipf1.
            if(ltest) write(iud2,'(2X,
     &        "cbpointer my_id,ic,idmpi,isc,iscb,ipf1:",I4,2I2,3I4)') 
     &                   my_id,ic,idmpi,isc,iscb,ipf1(idmpi,iscb)
          endif
        endif
      end do
C
      return
      end
