      subroutine cbsu3_2init_mpi ! Bernd Berg Jun 29 2008. 
C Initialization for checkerboard U1 MC calculations.  
      include '../../Libs/Fortran/implicit.sta'
      include 'mpif.h'
      character cd*1,cf*1,cdmpi*1,clx*3,clt*3,cmy*4
      include '../../Libs/Fortran/constants.par'
      include '../../Libs/Fortran_par/latmpi.par'
      include '../../Libs/Fortran_par/mc.par'
      parameter(miuo=-iuo)
      include '../../Libs/MPI_par/common_cblat.f' ! nla_full
      include '../../Libs/MPISU3/common_cbsu3.f'
      dimension iwf1(ndmpi,msc),iwf2(ndmpi,msc),iwb1(ndmpi,msc),
     &  iwb2(ndmpi,msc), ix(nd) ! temporary arrays.
      lat3=lat2 ! Enforces error if lat3 parameter is still used!
      ltest=.true.
      ltest=.false.
C
      lerror=.false.
      call mpi_comm_rank(mpi_comm_world,my_id,ierr)
      call mpi_comm_size(mpi_comm_world,n_proc,ierr)
      do id=1,nd
        nla_full(id)=nla(id)
        if(id.le.ndmpi) nla_full(id)=mpifactor*nla(id)
      enddo
      if(lud2) write(iud2,'(/," cbsu3_2init_mpi: my_id =",I12)') my_id
      if(my_id.eq.0) then
        write(iuo,'(/," cbsu3_2init_mpi nlat, lat2:",I4,L4)') nlat,lat2
        if(nlat.eq.2) write(iuo,'(" nltau =",I8)') nltau
        if(lat2test) write(iuo,'(" lat2test =",L4)') lat2test
        write(iuo,'(3X,"boundary exchange lbcex =",L7)') lbcex
        write(iuo,'(3X,"seed2 with my_id lsd2mpi=",L7)') lsd2mpi
        write(iuo,'(3X,"ndmpi, mpifactor =  ",2I9)') ndmpi,mpifactor
        write(iuo,'(3X,"msmpi,n_proc =      ",2I9)') msmpi,n_proc
        write(iuo,'(3X,"ms sites =                    ",I8)') ms
        write(iuo,'(3X,"plaquettes mp,mptime,mpspace: ",3I8)')
     &                             mp,mptime,mpspace
        write(iuo,'(3X,"msc checkerboard sites =      ",I8)') msc
        write(iuo,'(3X,"mscb sites on one boundary =  ",I8)') mscb
        write(iuo,'(3X,"mbcsh ipf1, ipf2  extensions =",I8)') mbcsh
        write(iuo,'(3X,"mbcs sites on all boundaries =",I8)') mbcs
        write(iuo,'(3X,"ns1fbb for corner plaquettes =",I8)') ns1fbb
        write(iuo,'(3X,"array size nmat =             ",I8)') nmat
        write(iuo,'(3X,"send array size mscb18 =      ",I8)') (n18*mscb)
        write(iuo,'(3X,"send array size ns1fbb18 =",4X,I8)') n18*ns1fbb
        write(iuo,'(3X,"nla_mpi:",8I6)') nla_mpi
        write(iuo,'("   parameters (lat.dat,latc.par):")')
        write(iuo,'("     lattice dimension:",I10)') nd
        write(iuo,'("     # lattice sites:  ",I10)') ms
        write(iuo,'("     sublattices nla; nltau: ",8I4)') nla,nltau
        write(iuo,'("     full lattice:   ",8X,8I4)') nla_full
        if(.not.lsd2mpi) write(iuo,'(5X,
     &    "lsd2mpi=.false.: full lattice reproduces sublattice")')
        write(iuo,'("     mlink,mp:",2I12)') mlink,mp
        write(iuo,'("   parameters (mc.par):")')
        write(iuo,'("     beta0, beta1:  ",2F15.8)') beta0,beta1
        write(iuo,'("     nreq,nequi:    ",3I10)') nreq,nequi
        write(iuo,'("     nrpt,nmeas,nsw:",3I10)') nrpt,nmeas,nsw
        write(iuo,'("     iuo,iud1,iseed1,iseed2:",2I4,2I7)') 
     &                    iuo,iud1,iseed1,iseed2
        if(istart.lt.2) then
          write(iuo,'(5X,"ordered start istart =   ",I6)') istart
        else
          write(iuo,'(5X,"disordered start istart =",I6)') istart
        endif
      endif
      call mpi_barrier(mpi_comm_world,ierr)
C
      if(nlat.ne.1.and.nlat.ne.2) then
        lerror=.true.
        if(my_id.eq.0) write(iuo,'(/,"nlat must be 1 or 2 STOP.",/)')
      endif
C
      if(lat2.and.nlat.ne.2) then
        lerror=.true.
        write(iuo,'(/,"STOP Mismatch: nlat,lat2 =",I4,L4)') nlat,lat2
      endif
C
      if(ndmpi.lt.0.or.ndmpi.gt.nd) then
        lerror=.true.
        if(my_id.eq.0) write(iuo,'(/,"ndmpi false STOP.",/)')
      endif
C
      if(nltau.ne.nla(nd)) then ! Consistency checks:
        if((nla(nd)/nltau)*nltau.ne.nla(nd)) then
          lerror=.true.
          if(my_id.eq.0) write(iuo,'(/," nla(nd)/nltau STOP.",/)')
        endif
        if(ndmpi.eq.nd) then
          lerror=.true.
          if(my_id.eq.0) write(iuo,'(/," ndmpi/nltau:  STOP.",/)')
        endif
      endif
C
      if(nlat.eq.1.and.n_proc.ne.msmpi) then
        lerror=.true.
        if(my_id.eq.0) write(iuo,'(/,"n_proc.ne.msmpi",/)')
      endif
C
      if(nlat.eq.2.and.n_proc.ne.2*msmpi) then
        lerror=.true.
        if(my_id.eq.0) write(iuo,'(/,"n_proc.ne.2*msmpi",/)')
      endif
C
      ns=nsfun(nla,nd)
      if(ns.ne.ms) then
        lerror=.true.
        if(my_id.eq.0) write(iuo,'("STOP: latmpi.par, .dat mismatch.")')
      endif
C
      do id=1,nd
        if(2*(nla(id)/2).ne.nla(id)) then
          lerror=.true.
          if(my_id.eq.0) write(iuo,'(/,"STOP: nla(id) must be even.")')
        endif
      enddo
C
      if(mpifactor.gt.9) then
        lerror=.true.
         if(my_id.eq.0) write(iuo,'(/,"STOP: cf not for mpifactor>9.")')
      endif
C
      if(lerror) then
        if(my_id.eq.0) write(iuo,'(/,"cbsu3_2init_mpi stop lerror.",/)')
        if(lud2) write(iud2,'(/,"cbsu3_2init_mpi: stop lerror.",/)')
        if(lud2) close(iud2)
        call mpi_finalize(ierr)
      stop "cbsu3_2init_mpi: lerror."
      endif
C
      write(cd,'(I1.1)') nd
      write(cf,'(I1.1)') mpifactor
      write(cdmpi,'(I1.1)') ndmpi
      write(cf,'(I1.1)') mpifactor
      write(clx,'(I3.3)') nla(1)
      write(clt,'(I3.3)') nla(nd)
      write(cmy,'(I4.4)') my_id
c Prepare time series (action) file name
      write(cfile,'(A,"d",A,"f",A,"d",A,"x",A,"t",A)') 
     &      cd,cf,cdmpi,clx,clt,cmy
      if(lud2) write(iud2,'(" cbsu3_2init_mpi: filename: ",2A,".D")') 
     &                        cfln,cfile
C
      inquire(file=cfln//".bak",exist=lexist)
      if(lexist) then 
        if(my_id.eq.0) write(iuo,'("cbsu3_2init_mpi stop see MPI*.d.")')
        if(lud2) write(iud2,
     &          '("cbsu3_2init_mpi: Continuation not implemented.")')
        if(lud2) close(iud2)
        call mpi_finalize(ierr)
      stop "cbsu3_2init_mpi: Continuation not implemented."
      endif
C
      isd2=iseed2
      if(lsd2mpi) isd2=iseed2+my_id ! Different now! For nlat=2 test:
      if(lsd2mpi.and.lat2test.and.my_id.ge.msmpi) isd2=isd2-msmpi
      if(lud2) write(iud2,'(1x,"random number seed isd2 =",I10)') isd2
      call rmaset(miuo,iud1,iseed1,isd2,"no file") 
      call ranmar(xr)        ! first random number.
      acpt=zero              ! acceptance rate.
      call lat_init(msmpi,ndmpi,ipf_mpi,ipb_mpi,nla_mpi,ix)
      if(my_id.eq.0) write(iuo,'(3x,"lat_init for mpi done.")')
      if(nlat.eq.2) call lat2a_init(msmpi,ndmpi,ipf_mpi,ipb_mpi)
      if(nlat.eq.2.and.my_id.eq.0) write(iuo,'(3x,"lat2a_init done.")')
      if(nlat.eq.2.and.lat2) then
       call lat2b_init(iuo,my_id,msmpi,ndmpi,ipf_mpi,ipb_mpi,nla_mpi,ix)
       if(my_id.eq.0) write(iuo,'(3x,"lat2b_init done.")')
      endif
      call cblat_init(iwf1,iwf2,iwb1,iwb2)
      if(my_id.eq.0) write(iuo,'(3x,"cblat_init done.")')
      if(lbcex) then
        call cblgtpointer(iwf1,iwf2,iwb1,iwb2,my_id)
        if(my_id.eq.0) write(iuo,'(3x,"cblgtpointer done.")')
        if(ndmpi.ge.2) then
          call cblgtpnt2(iwf1,iwf2,iwb1,iwb2,my_id)
          if(my_id.eq.0) write(iuo,'(3x,"cblgtpnt2 done.")')
          if(lud2) write(iud2,'(1x,"cblgtpnt2 done.")')
        endif
      endif 
C
      if(ltest) then
        if(lud2) write(iud2,'(/,3x,"igathbb1:")')
        if(lud2) write(iud2,'(18I4)') igathbb1
        if(lud2) write(iud2,'(3x,"STOP: cblgtpointer done.")')
        if(my_id.eq.0) write(iuo,'(/,"cbsu3_2init_mpi: stop ltest.",/)')
        if(lud2) write(iud2,'(/,"cbsu3_2init_mpi: stop ltest.",/)')
        if(lud2) close(iud2)
        call mpi_finalize(ierr)
      stop "cbsu3_2init_mpi: ltest."
      endif
C
C Initialization of ibs arrays (has to be done before csu3_start):
      call cbsu3_iba_mpi(my_id)
      call csu3_start(a1su3,a2su3,n18,nmat,nd,msc,istart) ! Start conf.
      if(my_id.eq.0) print*,"  cbsu3_start done."
      call cbsu3_act_mpi(lbcex,my_id) ! initial action.
      if(my_id.eq.0) write(iuo,'(3x,"cbsu3_act_mpi done.")')
      if(lud2) write(iud2,
     &        '(/," cbsu3_2init_mpi: initial action =",G16.8)') act
c     if(lerror) call cbu1_act_check  ! check action.
C
      a_min=act
      a_max=act
      if(my_id.eq.0) then
        write(iuo,'("   Data filenames are listed in MPI*.d files.")') 
        write(iuo,'("   Initial randon number: xr =",1F16.6)') xr
        write(iuo,'("   Initial action on node 0:  act =",G15.6)') act
        write(iuo,'(" cbsu3_2init_mpi: initialization done.")')
      endif
      return
      end
