c-----------------------------------------------------------------------
c
c   VERSION WITH SIMPLE BISECTION AND GROWTH OF CONN SET, COMBO (klh 07/09)
c
c   genmap.f performs the following operations:
c
c   1)  Read a nek5k .rea or (.rea/.re2) file describing problem geometry - 2D or 3D.
c
c   2)  Construct a standard finite element mesh from this file, i.e.,
c
c         a. a list of coordinates, X1, X2,...,X_npts,  where X_i = (xi,yi,zi) in 3D
c            or X_i = (xi,yi) in 2D
c
c
c         b. a list of E cells, each cell comprising 2^d integers, d=2 or 3, where
c            E is the number of spectral elements specified in the .rea file.
c            Each integer in a cell points to one of the coordinate X_i above.
c
c   3)  Generate the graph Laplacian, G, for the _dual_ graph corresponding to the
c       FE mesh.   Each node in the dual graph is an element.  Each edge in the
c       graph is an element G_ij, for any element i connected to j.
c
c          . G_ij = 1  if element i shares a vertex with element j
c          . G_ij = 2  if element i shares an edge with element j
c          . G_ij = 4  if element i shares an face with element j
c
c          . G_ii = - \sum j^=i G_ij
c
c
c   4)  Partition this graph using the Fiedler vector generated by a restarted
c       Lanczos iteration.
c
c   5)  Recur on (3)-(4) in a depth-first traversal of the subgraphs until
c       P branches have been identified, where P = floor(log_2 E).
c
c
c   6)  Output the results
c
c-----------------------------------------------------------------------
c
c  genmap() uses the symmetric vertex ordering
c
c      3 ----- 4
c      |       |
c      |       |
c      |       |
c      1 ----- 2
c
c  which can be extended to an arbitrary number of space dimensions
c  (like 3).
c
c-----------------------------------------------------------------------
      program genmap

c     read nekton .rea file and make a .map file

#     include "SIZE"

      parameter(lpts=8*lelm)
      common /carrayi/ cell (lpts) , pmap (lpts)
     $               , order(lpts) , elist(lpts)
      common /carrayw/ w1   (lpts) , w2   (lpts)
     $               , w3   (lpts) , w4   (lpts)
     $               , w5   (lpts)

      real        w14(4,lpts)
      equivalence (w1,w14)

      common /arrayr/  dx(4,lpts)

      common /carrayr/ bc(5,6,lelm)
      real*8 bc
      common /carrayc/ cbc(6,lelm)
      character*3      cbc

      logical ifconn,is_connected,face_conn

      integer     cell,pmap,order,elist,w1,w2,w3,w4,depth
      integer     e1,c1,f1

      wdsize=4
      eps=1.0e-12
      oneeps = 1.0+eps
      if (oneeps.ne.1.0) then
         wdsize=8
      endif

      call makemesh  (cell,nelv,nelt,irnk,dx,cbc,bc,ndim,w14)
c                                    irnk is # unique points

      nfc = 2*ndim
      nv  = 2**ndim
      mo  = 0   !max order initally zero.

      nic = lpts
      njc = lpts
      if (ndim.eq.3) then
         face_conn = .false.
         do i =1,5
            if (.not.face_conn) then
               call face_chk(face_conn,cell,nv,nelt,nic,njc,w1,w2,w3)
            else
               goto 15
            endif
         enddo
         write(6,*) "WARNING:Missing Face Connection Not Resolved"
         call exitt(1)
      endif
  15  continue

      call izero (order,irnk)

c     3/3/2010:  NO MORE SPECIAL OUTFLOW TREATMENT (fails w/ conj. ht.  transfer)

c     Determine number of outflow points and order them last
c     call set_outflow
c    $     (no,order,mo,cell,nv,nelv,irnk,cbc,nfc,w1,i0,i1,w2)

c     Find all periodic connections, based on cbc info.
      call periodic_vtx
     $               (cell,nv,nelt,irnk,dx,ndim,cbc,bc,nfc,w14,w5)

c     Recursive bisection of element graph; reverse-order interface points
      call rec_bisect (elist,pmap,order,mo,cell,nv,nelv,ndim
     $                                           ,w1,w2,w3,w4,w5)

c     Clean up
      call isort     (elist,w1,nelv)
      call iswap_ip  (pmap ,w1,nelv)

      if (nelt.gt.nelv) then
         nels = nelt-nelv ! number of elements in solid
         e1 = 1 + nelv
         c1 = 1 + nelv*nv

         write(6,*) 'Starting rec_bisect2: nels = ',nels
         write(6,*)
         write(6,*)
     $     'NOTE: rec_bisect works only when solid is contiguous',
     $     'We could fix this with a connected graph test.'
         write(6,*)

         call rec_bisect
     $        (elist,pmap(e1),order,mo,cell(c1),nv,nels,ndim
     $                                           ,w1,w2,w3,w4,w5)
         call isort     (elist   ,w1,nels)
         call iswap_ip  (pmap(e1),w1,nels)

c         call maptest   (pmap,nelv,nelt,'map test A',w1,w2)

      endif

      npts = nv*nelt
      call iranku       (cell,nrnk,npts,w1)
      call self_chk     (cell,nv,nelt,1)    ! check for not self-ptg.

      call fill_order   (order,mo,cell,nv,nelt)
      call assign_order (cell,nv,nelt,order)

      call iranku       (cell,nrnk,npts,w1) ! make cell numbering contiguous
      call self_chk     (cell,nv,nelt,2)    ! check for not self-ptg.
      if (nelv.eq.nelt) call reverse_p (pmap,nelt) ! lightly load node 0
c      call maptest      (pmap,nelv,nelt,'map test B',w1,w2)

c     Output to .map file:
c     noutflow    = no    ! for now - no outflow bcs
      noutflow    = 0     ! for now - no outflow bcs  (handled in nek?)
      call out_mapfile (pmap,nelt,cell,nv,nrnk,noutflow)
c      call maptest     (pmap,nelv,nelt,'map test C',w1,w2)

      call mult_chk(dx,ndim,nv,nelt,cell,nrnk)

c     call out_geofile (dx,ndim,nv,nelt,pmap,39)
c     call out_geofile2(dx,ndim,nv,nelt,cell,nrnk)

c     call outmati(pmap,13,9,'pmap  ',nelt,1)
c     open(unit=22,file='p.dat')
c     write(22,1) (pmap(k),k=1,nelt)
c   1 format(i9)
c     close(unit=22)

      end
c-----------------------------------------------------------------------
      subroutine makemesh(cell,nelv,nelt,irnk,dx,cbc,bc,ndim,wk)

c     read nekton .rea file and make a mesh

#     include "SIZE"

      integer      cell(1)
      character*3  cbc (6,1)
      real*8       bc  (5,6,1)
      real         dx  (1)
      real         wk  (1)
      integer e,f

      character*3 cbt(6)
      real*8      bt(5,6)

      parameter(lpts=8*lelm)

      common /arrayi/ i_n(lpts) , j_n(4*lpts)
     $                          , j_o(4*lpts)

      logical ifbinary,ifbswap
      integer buf(30)

      integer eface(6)  ! return Nekton preprocessor face ordering
      save    eface
      data    eface / 4 , 2 , 1 , 3 , 5 , 6 /

      io = 10
      ifma2 = .false.

      call getreafile('Input .rea / .re2 name:$',ifbinary,io,ierr)
      if (ierr.gt.0) then
         write(6,'(A)') 'Error no .rea / .re2 file found!'
c         call linearmsh(cell,nelv,nelt,ndim)
c         return
         call exitt(1)
      endif

      write(6,'(A)') 'Input mesh tolerance (default 0.2):'
      write(6,'(A,A)') 'NOTE: smaller is better, but generous is more ',
     &                 'forgiving for bad meshes.'

      read(5,'(f7.2)') qin
      if(qin.gt.0) then
        q = qin
      else
        write(6,'(A,2f7.2)') ' using default value'
        q = 0.2
      endif

      call cscan_dxyz (dx,nelt,nelv,ndim,ifbinary,ifbswap)

      ierr = 0
      if (ifbinary) then
         ifma2 = .true.
         ! skip curved side data
         if(wdsizi.eq.8) then
           call byte_read(rcurve,2,ierr)
           if (ifbswap) call byte_reverse8(rcurve,2,ierr)
           ncurve = rcurve
           if(ierr.ne.0) call exitti
     $         ('Error reading ncurve in makemesh ',ierr)
           do k = 1,ncurve
              call byte_read(buf,16,ierr)
              if(ierr.ne.0) call exitti
     $         ('Error reading curve data in makemesh ',ierr)
           enddo
         else
           call byte_read(ncurve,1,ierr)
           if (ifbswap) call byte_reverse(ncurve,1,ierr)
           if(ierr.ne.0) call exitti
     $         ('Error reading ncurve in makemesh ',ierr)
           do k = 1,ncurve
              call byte_read(buf,8,ierr)
              if(ierr.ne.0) call exitti
     $         ('Error reading curve data in makemesh ',ierr)
           enddo
         endif
c        For current version of genmap, only need the fluid bcs.
c        Later, for more complex MHD configs, we'll need fluid + induct.

c        Also, if we start to have fluid/thermal domains with differing
c        periodic bc topologies, then we'll need something completely
c        different (two distinct numberings).
c
c        In fact, we need the thermal bcs because of periodicity...
c        This is not pretty --- there are many cases to be considered.
c
c        For now, we default to solid topology if nelt > nelv
c

         call rd_bc_bin(cbc,bc,nelv,nelt,ifbswap)

         call byte_close(ierr)
         if(ierr.ne.0) call exitti
     $       ('Error closing file in makemesh ',ierr)
      else
         call cscan_bcs   (cbc,bc,nelv,nelt,ndim)
      endif
c     call outbc(cbc,bc,nelt,ndim,' CBC 1')
      close (unit=10)  ! close .rea file

      nface = 2*ndim
      do e=1,nelt !  SWAP TO PREPROCESSOR NOTATION
         call chcopy(cbt,cbc(1,e)  ,nface*3)
         call copy8 ( bt, bc(1,1,e),nface*5)
         do f=1,nface
            call copy8 ( bc(1,f,e), bt(1,eface(f)),5)
            call chcopy(cbc(  f,e),cbt(  eface(f)),3)
         enddo
      enddo
c     call outbc(cbc,bc,nelt,ndim,' CBC 2')

c     Compress vertices based on coordinates
      call unique_vertex2(cell,dx,ndim,nelt,q,i_n,j_n,j_o,wk)

      nv   = 2**ndim
      npts = nelt*nv

      call iranku    (cell,irnk,npts,i_n)
      call self_chk  (cell,nv,nelt,32)       ! check for not self-ptg.
      return
      end
c-----------------------------------------------------------------------
      subroutine linearmsh(cell,nelv,nelt,ndim)

      integer      cell(2,1)
      integer e

      ndim = 1

      write(6,*) 'Input number of linear finite elements:'
      read (5,*) nelt

      do e = 1,nelt
         cell(1,e) = e
         cell(2,e) = e+1
      enddo

      nelv=nelt

      return
      end
c-----------------------------------------------------------------------
      subroutine exitti(name,ie)
      character*40 name
      write(6,*) name, ie
      stop
      end
c-----------------------------------------------------------------------
      subroutine exitt(ie)
      write(6,*) 'exit status', ie
      stop
      end
c-----------------------------------------------------------------------
      subroutine cscan_dxyz (dx,nelt,nelv,ndim,ifbinary,ifbswap)
c
c     Scan for xyz data, read it, and set characteristic length, d2
c

#     include "SIZE"

      character*80 string
c
      real dx(1)
      real x(8),y(8),z(8)
      integer e,buf(50)
      integer*8 l

      integer h2s(8) ! hypercube to strange ordering
      save    h2s
      data    h2s / 1,2,4,3,5,6,8,7 /

      logical ifbinary,ifbswap

      ifbswap  = .false.

      write(6,*) 'reading mesh data ...'

      if (.not. ifbinary) then
         call cscan(string,'MESH DATA',9)
         read (10,*) nelt,ndim,nelv
      endif

      if (nelt.lt.0 .or. ifbinary) then
         ifbinary = .true.
         call open_bin_file(ifbswap,nelgtr,ndimr,nelgvr,wdsizi)
         if(wdsize.eq.4.and.wdsizi.eq.8) then
             write(6,*) "Double Precision .rea not supported ",
     $                  "in Single Precision mode, compile with -r8"
             call exitt(wdsize)
         endif
         nelt = nelgtr
         ndim = ndimr
         nelv = nelgvr
         nwds = (1 + ndim*(2**ndim))*(wdsizi/4) ! group + 2x4 for 2d, 3x8 for 3d
      endif

c      write(6,*) nelt,ndim,nelv,ifbinary, ' nelt,ndim,nelv,ifre2 '

      if (nelt.gt.lelm) then
        write(6,*) 'Abort: number of elements too large', nelt
        write(6,*) 'change MAXNEL and recompile'
        call exitt(1)
      endif

      b = 1.e22
      l = 1

      ierr = 0
      if (ndim.eq.3) then
         do e=1,nelt
            if(ifbinary) then
              call byte_read(buf,nwds,ierr)
              if(ierr.ne.0) goto 100
              call buf_to_xyz(buf,x,y,z,e,ifbswap,ndim,wdsizi)
            else
              read (10,80) string
              read (10,*)   (x(k),k=1,4)
              read (10,*)   (y(k),k=1,4)
              read (10,*)   (z(k),k=1,4)
              read (10,*)   (x(k),k=5,8)
              read (10,*)   (y(k),k=5,8)
              read (10,*)   (z(k),k=5,8)
            endif
c           write(6,*) e
c           do ii=1,8
c          write(6,*) x(ii),y(ii),z(ii)
c           enddo
            do k=1,8
               dx(l+0) = b
               dx(l+1) = x(h2s(k))
               dx(l+2) = y(h2s(k))
               dx(l+3) = z(h2s(k))
               l = l + (ndim+1)
            enddo
         enddo
      else
         do e=1,nelt
            if(ifbinary) then
              call byte_read(buf,nwds,ierr)
              if(ierr.ne.0) goto 100
              call buf_to_xyz(buf,x,y,z,e,ifbswap,ndim,wdsizi)
            else
              read (10,80) string
              read (10,*)   (x(k),k=1,4)
              read (10,*)   (y(k),k=1,4)
            endif
            do k=1,4
               dx(l+0) = b
               dx(l+1) = x(h2s(k))
               dx(l+2) = y(h2s(k))
               l = l + (ndim+1)
            enddo
         enddo
      endif
   80 format(a80)

      nvrt = 2**ndim
      call set_d2(dx,nvrt,nelt,ndim)

      return
 100  write(6,*) "Error reading xyz byte data in scan_dxyz. Abort"
      call exitt(ierr)
      return
      end
c-----------------------------------------------------------------------
      subroutine set_d2(dx,nvrt,nel,ndim)
      real dx(0:ndim,nvrt,nel)

      integer neigh(3,8),e
      save    neigh
      data    neigh / 2,3,5 , 1,4,6 , 1,4,7 , 2,3,8   ! symm. ordering
     $              , 1,6,7 , 2,5,8 , 3,5,8 , 4,6,7 /

      b = 1.e22

      do e = 1,nel
      do i = 1,nvrt

         dx(0,i,e) = b

         do k = 1,ndim

            n   = neigh(k,i)
            d2l = 0.

            do j=1,ndim
               d2l = d2l + (dx(j,n,e)-dx(j,i,e))**2
            enddo

            dx(0,i,e) = min (dx(0,i,e),d2l)
c           write(6,9) i,e,' dx',(dx(j,i,e),j=0,ndim)
c  9        format(2i6,a3,1p4e11.3)

         enddo

      enddo
      enddo
c     call exitt(5)

      return
      end
c-----------------------------------------------------------------------
      subroutine cscan_bcs  (cbc,bc,nelv,nelt,ndim)
c
c     Scan for cbc data and read it
c
      character*3  cbc(6,nelt)
      real*8       bc (5,6,nelt)
      character*80 string

      integer e

      call cscan(string,'BOUNDARY',8) ! for now, fluid only

      npass = 1
      if (nelt.gt.nelv) npass = 2

      do kpass = 1,npass

         read (10,80) string
   80    format(a80)

         ifield = kpass
         if (indx1(string,'NO ',3).ne.0) then
            ifield = ifield+1
            call cscan(string,'BOUNDARY',8) ! then, temp only
         endif

         nel=nelv
         if (kpass.eq.2) nel=nelt
         call rd_bc(cbc,bc,nel,ndim,ifield,10)

      enddo

      return
      end
c-----------------------------------------------------------------------
      subroutine rd_bc(cbc,bc,nel,ndim,ifield,io)

c     .Read Boundary Conditions (and connectivity data)

      character*3 cbc(6,nel)
      real*8      bc(5,6,nel)
      integer e,f

c     write(6,*) 'inside rd_bc: ',nel,ndim,ifield,io

      nbcrea = 5
      nface  = 2*ndim
      do e=1,nel
      do f=1,nface
         if (nel.lt.1000) then
            read(io,50,err=510,end=600)
     $      chtemp,
     $      cbc(f,e),id1,id2,
     $      (bc(ii,f,e),ii=1,nbcrea)
   50       format(a1,a3,2i3,5g14.6)
         elseif (nel.lt.100 000) then
            read(io,51,err=520,end=600)
     $      chtemp,
     $      cbc(f,e),id1,id2,
     $      (bc(ii,f,e),ii=1,nbcrea)
   51       format(a1,a3,i5,i1,5g14.6)
         elseif (nel.lt.1 000 000) then
            read(io,52,err=530,end=600)
     $      cbc(f,e),id1,(bc(ii,f,e),ii=1,nbcrea)
   52       format(1x,a3,i6,5g14.6)
         else
            read(io,53,err=540,end=600)
     $      cbc(f,e),id1,(bc(ii,f,e),ii=1,nbcrea)
   53       format(1x,a3,i12,5g18.11)
         endif
c        write(6,*) e,f,' ',cbc(f,e),' BC IN?',nel,ifield
      enddo
      enddo

      return
C
C     Error handling:
C
  500 format(2x,'ERROR: error reading ',i4,2i12,/,
     $       2x,'aborting ',a3,' in routine rdbdry.')
  510 write(6,500) ifield,e,nel,'510'
      call exitt(ifield)
      return

  520 write(6,500) ifield,e,nel,'520'
      call exitt(ifield)
      return

  530 write(6,500) ifield,e,nel,'530'
      call exitt(ifield)
      return

  540 write(6,500) ifield,e,nel,'540'
      call exitt(ifield)
      return

      return

  600 continue
      write(6,601) ifield,e,nel
  601 FORMAT(2X,'ERROR: end of file',i4,2i12,/,
     $       2X,'ABORTING 600 IN ROUTINE RDBDRY.')
      call exitt(ifield)
      return

      end
c-----------------------------------------------------------------------
      subroutine blank(s,n)
      character*1 s(1)
      do i=1,n
        s(i)=' '
      enddo
      return
      end
c-----------------------------------------------------------------------
      function ltrunc(s,n)
      character*1 s(1)
      ltrunc = 0
      do j=n,1,-1
         if (s(j).ne.' ') then
            ltrunc = j
            return
         endif
      enddo
      return
      end
c-----------------------------------------------------------------------
      integer function indx1(s1,s2,l2)
      character*80 s1,s2
C
      n1=80-l2+1
      indx1=0
      if (n1.lt.1) return
C
      do 300 i=1,n1
         i2=i+l2-1
         if (s1(i:i2).eq.s2(1:l2)) then
            indx1=i
            return
         endif
300   continue
c
      return
      end
c-----------------------------------------------------------------------
      subroutine cscan(sout,key,nk)
      character*80 sout,key
      character*80 string
      character*1  string1(80)
      equivalence (string1,string)
c
      do i=1,99999999
         call blank(string,80)
         read (10,80,end=100,err=100) string
         call chcopy(sout,string,80)
c        write (6,*) string
         if (indx1(string,key,nk).ne.0) return
      enddo
  100 continue
c
   80 format(a80)
      return
      end
c
c-----------------------------------------------------------------------
      subroutine readwrite(sout,key,nk)
      character*80 sout,key
      character*80 string
      character*1  string1(80)
      equivalence (string1,string)
c
      do i=1,90000
         call blank(string,80)
         read (10,80,end=100,err=100) string
         len = ltrunc(string,80)
         write(11,81) (string1(k),k=1,len)
         if (indx1(string,key,nk).ne.0) return
      enddo
  100 continue
c
   80 format(a80)
   81 format(80a1)
      return
      end
c
c-----------------------------------------------------------------------
      subroutine readwrite2(sout,key1,nk1,key2,nk2)
      character*80 sout,key1,key2
      character*80 string
      character*1  string1(80)
      equivalence (string1,string)
c
      do i=1,90000
         call blank(string,80)
         read (10,80,end=100,err=100) string
         len = ltrunc(string,80)
         write(11,81) (string1(k),k=1,len)
c        write(6 ,81) (string1(k),k=1,len)
         if (indx1(string,key1,nk1).ne.0) return
         if (indx1(string,key2,nk2).ne.0) return
      enddo
  100 continue
   80 format(a80)
   81 format(80a1)
      return
      end
c
c-----------------------------------------------------------------------
      integer function log2(k)
      rk=(k)
      rlog=log10(rk)
      rlog2=log10(2.0)
      rlog=rlog/rlog2  + 1.e-6  !  + 0.5  ! don't round up!
      log2=int(rlog)
      return
      end
c-----------------------------------------------------------------------
      function iglmin(a,n)
      integer a(1),tmin
      tmin=999999999
      do 100 i=1,n
         tmin=min(tmin,a(i))
  100 continue
      iglmin=tmin
      return
      end
c-----------------------------------------------------------------------
      function ivlmax(a,n)
      integer a(1),tmax
      tmax=-999999999
      do 100 i=1,n
         tmax=max(tmax,a(i))
  100 continue
      ivlmax=tmax
      return
      end
c-----------------------------------------------------------------------
      function iglmax(a,n)
      integer a(1),tmax
      tmax=-999999999
      do 100 i=1,n
         tmax=max(tmax,a(i))
  100 continue
      iglmax=tmax
      return
      end
c-----------------------------------------------------------------------
      function glmax(a,n)
      real a(1)
      tmax=-99.0E20
      do 100 i=1,n
         tmax=max(tmax,a(i))
  100 continue
      glmax=tmax
      return
      end
c-----------------------------------------------------------------------
      function glmin(a,n)
      real a(1)
      tmin=99.0E20
      do 100 i=1,n
         tmin=min(tmin,a(i))
  100 continue
      glmin = tmin
      return
      end
c-----------------------------------------------------------------------
      subroutine icopy(x,y,n)
      integer x(1),y(1)
      do i=1,n
         x(i) = y(i)
      enddo
      return
      end
c-----------------------------------------------------------------------
      subroutine cmult2(x,y,c,n)
      real x(1),y(1)
      do i=1,n
         x(i) = c*y(i)
      enddo
      return
      end
c-----------------------------------------------------------------------
      subroutine copy(x,y,n)
      real x(1),y(1)
      do i=1,n
         x(i) = y(i)
      enddo
      return
      end
c-----------------------------------------------------------------------
      subroutine copy8(x,y,n)
      real*8 x(1),y(1)
      do i=1,n
         x(i) = y(i)
      enddo
      return
      end
c-----------------------------------------------------------------------
      subroutine izero(x,n)
      integer x(1)
      do i=1,n
         x(i) = 0
      enddo
      return
      end
c-----------------------------------------------------------------------
      subroutine cfill(x,c,n)
      real x(1)
      do i=1,n
         x(i) = c
      enddo
      return
      end
c-----------------------------------------------------------------------
      subroutine rint(x,n)
      real x(1)
      do i=1,n
         x(i) = i
      enddo
      return
      end
c-----------------------------------------------------------------------
      subroutine jjnt(x,n)
      integer x(1)
      do i=1,n
         x(i) = i
      enddo
      return
      end
c-----------------------------------------------------------------------
      subroutine ifill(x,c,n)
      integer x(1),c
      do i=1,n
         x(i) = c
      enddo
      return
      end
c-----------------------------------------------------------------------
      subroutine icadd(x,c,n)
      integer x(1),c
      do i=1,n
         x(i) = x(i)+c
      enddo
      return
      end
c-----------------------------------------------------------------------
      subroutine cadd(x,c,n)
      real x(1)
      do i=1,n
         x(i) = x(i)+c
      enddo
      return
      end
c-----------------------------------------------------------------------
      subroutine cmult(x,c,n)
      real x(1)
      do i=1,n
         x(i) = x(i)*c
      enddo
      return
      end
c-----------------------------------------------------------------------
      subroutine chcopy(x,y,n)
      character*1 x(1),y(1)
      do i=1,n
         x(i) = y(i)
      enddo
      return
      end
c-----------------------------------------------------------------------
      subroutine getreafile(prompt,ifbinary,io,ierr)
c
      character*1 prompt(1)
      logical ifbinary
c
      common /sess/ session
      character*80 session

      character*80 file
      character*1  file1(80)
      equivalence (file1,file)

      ierr = 0
      ifbinary = .false.

c     Get file name
      len = indx1(prompt,'$',1) - 1
      write(6,81) (prompt(k),k=1,len)
   81 format(80a1)
      call blank(session,80)
      read(5,80) session
   80 format(a80)

      if (session.eq.'-1') then
         io = -1
         ierr = 1
         return
      else
         call chcopy(file,session,80)
         len = ltrunc(file,80)
         call chcopy(file1(len+1),'.rea',4)
         open(unit=io, file=file, status='old', iostat=ierr)

         if (ierr.gt.0) then
            call chcopy(file,session,80)
            len = ltrunc(file,80)
            call chcopy(file1(len+1),'.re2',4)
            inquire(file=file, exist=ifbinary)
            if(ifbinary) ierr = 0
         endif
      endif

      write(6,*) 'reading ', file

      return
      end
c-----------------------------------------------------------------------
      subroutine isort(a,ind,n)
C
C     Use Heap Sort (p 231 Num. Rec., 1st Ed.)
C
      integer a(1),ind(1)
      integer aa
C
      dO 10 j=1,n
         ind(j)=j
   10 continue
C
      if (n.le.1) return
      L=n/2+1
      ir=n
  100 continue
         if (l.gt.1) then
            l=l-1
            aa  = a  (l)
            ii  = ind(l)
         else
                 aa =   a(ir)
                 ii = ind(ir)
              a(ir) =   a( 1)
            ind(ir) = ind( 1)
            ir=ir-1
            if (ir.eq.1) then
                 a(1) = aa
               ind(1) = ii
               return
            endif
         endif
         i=l
         j=l+l
  200    continue
         if (j.le.ir) then
            if (j.lt.ir) then
               if ( a(j).lt.a(j+1) ) j=j+1
            endif
            if (aa.lt.a(j)) then
                 a(i) = a(j)
               ind(i) = ind(j)
               i=j
               j=j+j
            else
               j=ir+1
            endif
         GOTO 200
         endif
           a(i) = aa
         ind(i) = ii
      GOTO 100
      end
c-----------------------------------------------------------------------
      subroutine iswap_ip(x,p,n)
      integer x(1),xstart
      integer p(1)
c
c     In-place permutation: x' = x(p)
c
      do k=1,n
         if (p(k).gt.0) then   ! not swapped
            xstart     = x(k)
            loop_start = k
            last       = k
            do j=k,n
               next    = p(last)
               if (next.lt.0) then
                  write(6,*) 'Hey! iswap_ip problem.',j,k,n,next
                  call exitt(0)
               elseif (next.eq.loop_start) then
                  x(last) = xstart
                  p(last) = -p(last)
                  goto 10
               else
                  x(last) = x(next)
                  p(last) = -p(last)
                  last    = next
               endif
            enddo
   10       continue
         endif
      enddo
c
      do k=1,n
         p(k) = -p(k)
      enddo
      return
      end
c-----------------------------------------------------------------------
      subroutine iswapt_ip(x,p,n)
      integer x(1),t1,t2
      integer p(1)
c
c     In-place permutation: x'(p) = x
c

      do k=1,n
         if (p(k).gt.0) then   ! not swapped
            loop_start = k
            next       = p(loop_start)
            t1         = x(loop_start)
            do j=1,n
               if (next.lt.0) then
                  write(6,*) 'Hey! iswapt_ip problem.',j,k,n,next
                  call exitt(1)
               elseif (next.eq.loop_start) then
                  x(next) = t1
                  p(next) = -p(next)
                  goto 10
               else
                  t2      =  x(next)
                  x(next) =  t1
                  t1      =  t2
                  nextp   =  p(next)
                  p(next) = -p(next)
                  next    =  nextp
               endif
            enddo
   10       continue
         endif
      enddo
c
      do k=1,n
         p(k) = -p(k)
      enddo
      return
      end
c-----------------------------------------------------------------------
      subroutine sort(a,p,n)
c
c     Use Heap Sort (p 233 Num. Rec.), 5/26/93 pff.
c
c     returns sorted list a(), and permutation vector p()
c
      real    a(1),q
      integer p(1)
C
      if (n.le.1) return
      DO 10 J=1,N
         p(j)=j
   10 continue
C
      L=n/2+1
      ir=n
  100 CONTINUE
         IF (l.gt.1) THEN
            l=l-1
            indx=p(l)
            q=a(indx)
         ELSE
            indx=p(ir)
            q=a(indx)
            p(ir)=p(1)
            ir=ir-1
            if (ir.eq.1) then
               p(1)=indx
               return
            endif
         endif
         i=l
         j=l+l
  200    CONTINUE
         IF (J.le.IR) THEN
            IF (J.lt.IR) THEN
               IF ( A(p(j)).lt.A(p(j+1)) ) j=j+1
            endif
            IF (q.lt.A(p(j))) THEN
               p(I)=p(J)
               I=J
               J=J+J
            ELSE
               J=IR+1
            endif
         goto 200
         endif
         p(I)=indx
      goto 100
      end
c-----------------------------------------------------------------------
      subroutine csr_sort_colj(ia,ja,n,ind)
      integer ia(0:1),ja(1)
c
      do i=1,n
         j0 = ia(i-1)
         nj = ia(i)-j0
         call isort(ja(j0),ind,nj)
      enddo
c
      return
      end
c-----------------------------------------------------------------------
      subroutine out_csrmati(ia,ja,n,name9)
      integer ia(0:1),ja(1)
c
      character*9 name9
      character*4 s(33)
c
      write(6,1) name9,n
    1 format(/,'CSR Mat:',a9,3x,'n =',i9,/)
c
      mj = 11
      do i=1,n
         j0 = ia(i-1)
         j1 = ia(i)-1
         nj = j1-j0 + 1
         j1 = min(j1,j0+mj)
         if (nj.gt.0) write(6,26) i,nj,(ja(k),k=j0,j1)
      enddo
   26 format(2i4,': ',26i4)
c
      return
      end
c-----------------------------------------------------------------------
      subroutine iranku(a,rank,n,p)
c
c     Return r = rank of a() in place of a(), where r =< n
c     so that a() is the number of unique pts sorted such that
c     it is in the original spot
c     Use Heap Sort (p 233 Num. Rec.), 5/26/93 pff.
c
c
      integer a(1),p(1)
      integer rank

      call isort(a,p,n)

      rank = 1
      last = a(1)
      a(1) = 1

      do k=2,n
         next = a(k)
         if (next.ne.last) rank=rank+1
         a(k) = rank
         last = next
      enddo

      call iswapt_ip(a,p,n)  ! restore a() to orginal location

      return
      end
c-----------------------------------------------------------------------
      subroutine rec_bisect (elist,pmap,order,mo,cell,nv,nel,ndim
     $                      ,ia,da,w1,w2,w3)

      integer pmap(1),order(1),cell(nv,nel),elist(1),ia(0:1),da(0:1)
      integer w1(1),w2(1),w3(1)
      integer e,p,v,depth
      integer pmaps(100),elists(100),n2

      write(6,*) 'start rec_bisect:',nel
      do e=1,nel
         elist(e) = e
      enddo
      ia(0) = 1
      ia(1) = nel+1
      da(0) = 0

      max_depth = log2(nel)
      nel_even  = 2**max_depth

      if (nel.eq.1) pmap(1) = 1

      p  = 0
      l  = 1
      d  = 0
      depth = 0
      itmp = nel/100
      itmp = max(1,itmp)
      do i=1,nel
         j0 = ia(l-1)
         j1 = ia(l)-1
         n  = ia(l) - ia(l-1)

c         if (i.le.100)
c     $   write(6,8) i,depth,max_depth,l,j0,j1,n1,n2,p,' d2   '

             if(mod(i,itmp).eq.0 .or. i.eq.1)
     &          write(6,'(A,f6.1,A)') ' done: ', 100.*i/nel, '% '

         if (da(l-1).lt.max_depth.and.l.gt.0) then
            da(l-1) = da(l-1) + 1
            da(l  ) = da(l-1)
            depth   = da(l-1)
            call bipart_sort
     $        (n1,n2,pmap(j0),order,mo,elist(j0),n,cell,nv,p,w1,w2,w3)

c     &        write(6,8) i,depth,max_depth,l,j0,j1,n1,n2,p,' DEPTH'
c    8       format(i9,2i5,6i10,a6)
c           write(6,18) 'A',(pmap(k),k=1,nel)
c 18        format(a1,'pmap:',32i3)

            depth = da(l-1)+1
            if (depth.le.max_depth) then
               ia(l)   = j0 + n1
               ia(l+1) = j1 + 1
               l       = l+1
            else
               p       = p+2   !  increase base processor offset
               l       = l-1   !  go back in list
            endif
         endif

      enddo

      write(6,*) ' '
      write(6,*) 'done rec_bisect'
      return
      end
c-----------------------------------------------------------------------
      subroutine fill_order(order,mo,cell,nv,nel)
      integer order(1),cell(nv,nel)
      integer e,v

c     Fill in remaining separator sets
      do e=1,nel
      do v=1,nv
         i = cell(v,e)
c        write(6,*) i,v,e,order(i),mo
         if (order(i).eq.0) then
            mo = mo+1
            order(i) = mo
         endif
         order(i) = -abs(order(i)) ! set flag
c        write(6,*) i,v,e,order(i),mo
c        write(6,*)
      enddo
      enddo

c     Reverse separator set ordering
      do e=1,nel
      do v=1,nv
         i = cell(v,e)
         if (order(i).lt.0) order(i) = mo+1+order(i)
c        write(6,*) order(i),e,v
      enddo
      enddo

      return
      end
c-----------------------------------------------------------------------
      subroutine count_sep( count, order, nsep, elist, cell, nv, n1, n2)
c
c     order separator nodes
c
c
c     Output:
c
c     count - number of separators on each element
c
c     Input:
c
c     elist - list of active elements
c     cell  - list of vertices for each element (in global addr. space)
c

      integer count(1),elist(1),cell(nv,1),order(1)
      integer e,v

      nel = n1+n2
      call izero (count,nel)

      do k=1,n1         ! Set flags
         e = elist(k)
         do j=1,nv
            i = cell(j,e)
            order(i) = -1
         enddo
      enddo

      do k=n1+1,nel           ! Check flags
         e = elist(k)
         do j=1,nv
            i = cell(j,e)
            if (order(i).eq.-1) order(i) = -2
         enddo
      enddo

      do k=1,nel              ! Check flags
         e = elist(k)
         do j=1,nv
            i = cell(j,e)
            if (order(i).eq.-2) count(k) = count(k)+1
         enddo
      enddo

      nsep = 0
      do k=1,n1         ! Unset flags and count separators
         e = elist(k)
         do j=1,nv
            i = cell(j,e)
            if (order(i).eq.-2) nsep = nsep+1
            if (order(i).lt.0)  order(i) = 0
         enddo
      enddo

      return
      end
c-----------------------------------------------------------------------
      subroutine bipart_sort
     $   (n1,n2,pmap,order,mo,elist,nel,cell,nv,p,c,w1,w2)
c
c     Bipartition elist, order separator nodes, add p to partition
c
c
c     Output:
c
c     n1,n2 - number of elements on each 1/2
c
c     pmap  - sorted processor map
c     order - updated vertex separator ordering
c     mo    - current max(order)
c
c     elist - sorted by processor map
c
c     Input:
c
c     elist - list of active elements
c     nel   - number of active elements
c     cell  - list of vertices for each element (in global addr. space)
c     nv    - 8 for 3D, 4 for 2D
c     p     - current processor offset
c
c     Work arrays:
c
c     c     - nv*nel
c     w1    - nv*nel
c     w2    - nv*nel
c

#     include "SIZE"

      integer pmap(nel),order(1),elist(nel),cell(nv,1),part,c(nv,1)
      integer w1(1),w2(1)
      integer e,etype,ndim

      call isort (elist,w1,nel)
      do k = 1,nel           ! extract cell sublist
         e = elist(k)
         call icopy(c(1,k),cell(1,e),nv)
c        write(6,6) k,e,(c(j,k),j=1,8)
c 6      format(2i6,2x,8i8,' bp_cell')
      enddo
      npts  =  nv*nel

      call self_chk (c,nv,nel,4)       ! check for not self-ptg.

      if (nv.eq.2) then   ! 1D
         ndim  = 1
      elseif (nv.eq.4) then   ! 2D
         ndim  = 2
         etype = 4      ! Quadrilateral
      else
         ndim  = 3
         etype = 3      ! Hexahedral
      endif

      call spec_bis_conn(pmap,n1,n2,c,elist,nv,nel
     $                          ,cell,ndim,w1,w2)

      if (abs(n2-n1).gt.1) then ! rebalance load
         write(6,*) 'LOAD REBALANCE'
         if (n2.gt.n1) then ! swap

            j1 = n1+1
            j2 = n2+1
            call icopy(w1,elist(j1),n2)
            call icopy(elist(j2),elist,n1)
            call icopy(elist,w1,n2)

            call icopy(w1,pmap(j1),n2)
            call icopy(pmap(j2),pmap,n1)
            call icopy(pmap,w1,n2)

            m1 = n1
            n1 = n2
            n2 = m1

         endif
         ndif = (n1-n2)/2
         do i=1,ndif
            call count_sep( w1, order, nsep, elist, cell, nv, n1, n2 )
            j0 = 1
            j1 = n1+1
            call isort   ( w1    ,w2,n1)
            call iswap_ip( elist ,w2,n1)
            pmap(n1) = pmap(nel)
            n1 = n1-1
            n2 = n2+1
            mcount = iglmax(w1,nel)
            if (mod(i,4).eq.0 .or.    i.le.3)
     $         write(6,*) ndif,n1,n2,mcount,' Sep count',nsep
         enddo
      endif

      j0=1      ! Reset pmap and shift by current offset
      j1=n1+1
      call ifill(pmap(j0),2,n1)   ! Since n1 > n2, let's lightly load node 0
      call ifill(pmap(j1),1,n2)   ! by assigning node 0 to shorter stack.
      call icadd(pmap,p,nel)

c       call part_clean( order, nsep, elist, cell, nv, n1, n2, w1, w2)
c       call count_sep( w1, order, nsep, elist, cell, nv, n1, n2 )
c       mcount = iglmax(w1,nel)
        call ident_sep( order, mo, elist, cell, nv, n1, n2 )

      return
      end
c-----------------------------------------------------------------------
      subroutine part_clean(order,nsep,elist,cell,nv,n1,n2,count,wk)
c
c     Clean up partition by swapping
c
      integer count(1),elist(1),cell(nv,1),order(1),wk(1)
      integer e,v

      nel  = n1+n2
      snel = nel
      snel = sqrt(snel)
      nels = snel + 5      ! check lots of options for small cases
      nels = min(nels,nel)

      nvmx = (3*nv)/4
      do i=1,nels

         call count_sep(count, order, nsep, elist, cell, nv, n1, n2)

         j0 = 1
         j1 = n1+1

         call isort   ( count(j0),wk,n1)
         call iswap_ip( elist(j0),wk,n1)
         m1 = iglmax  ( count(j0),n1)

         call isort   ( count(j1),wk,n2)
         call iswap_ip( elist(j1),wk,n2)
         m2 = iglmax  ( count(j1),n2)

         mx = max(m1,m2)

         if (mx.eq.0) then
            return
         elseif (mx.le.nvmx) then
            return
         else          ! swap
            e = elist(n1)
            elist(n1)  = elist(nel)
            elist(nel) = e
         endif
      enddo

      return
      end
c-----------------------------------------------------------------------
      subroutine ident_sep( order, mo, elist, cell, nv, n1, n2 )
c
c     order separator nodes
c
c
c     Output:
c
c     order - updated vertex separator ordering
c     mo    - current max(order)
c
c     Input:
c
c     elist - list of active elements
c     cell  - list of vertices for each element (in global addr. space)
c     mo    - current max(order)
c

#     include "SIZE"

      integer elist(1),cell(nv,1),order(1)
      integer e,v

c--- diagnostic use only -----------------
c                                        !
c     common /arrayr/  dx(0:3,8,lelm)    !
c                                        !
c     integer icalld,kj(lelm),ke(lelm)   !
c     save    icalld                     !
c     data    icalld /0/                 !
c                                        !
c                                        !
c--- diagnostic use only -----------------
      mod1 = mo
c      nelnv=(n1+n2)*nv
c     do i=1,nelnv
c        write(6,*) order(i),i, ' id sep called'
c     enddo

      do k=1,n1         ! Set flags
         e = elist(k)
         do j=1,nv
            i = cell(j,e)
            if (order(i).eq.0) order(i) = -1
         enddo
      enddo

      m0=0
      do k=n1+1,n1+n2         ! Check flags
         e = elist(k)
         do j=1,nv
            i = cell(j,e)
            if (order(i).eq.-1) then
                mo = mo+1
                order(i) = mo
                m0 = m0+1
c               kj(m0) = j
c               ke(m0) = e
            endif
         enddo
      enddo

      nsep = mo-mod1
      if (nsep.gt.0) icalld=icalld+1

c     write(6,6) nsep,mo,mod1,m0
c   6 format(4i11,' nsep')

c     if (nv.eq.8) then ! 3d
c        do i=1,nsep
c           x=dx(1,kj(i),ke(i))
c           y=dx(2,kj(i),ke(i))
c           z=dx(3,kj(i),ke(i))
c           write(9,4) x,y,z,icalld
c   4       format(1p3e12.4,i9)
c        enddo
c     endif

      do k=1,n1         ! Unset flags
         e = elist(k)
         do j=1,nv
            i = cell(j,e)
            if (order(i).eq.-1) order(i) = 0
         enddo
      enddo

c     call out_order(order,mo,elist,cell,nv,n1,n2)
c     call exitt(5)

      return
      end
c-----------------------------------------------------------------------
      subroutine outmatti(u,m,n,name6,nid,ic)
      integer u(m,n)
      character*6 name6
      character*1 adum
c
c     Print out copies of a global matrix, transpose
c
         write(6,1) nid,m,n,name6,nid,ic
   1     format(3i6,'  Matrix T:',2x,a6,2i9)

         m8 = min(m,10)
         do j=1,n
            write(6,2) j,name6,(u(i,j),i=1,m8)
         enddo
   2     format(i8,1x,a6,10i9)

      return
      end
c-----------------------------------------------------------------------
      subroutine outmati(u,m,n,name6,nid,ic)
      integer u(m,n)
      character*6 name6
      character*1 adum
c
c     return
c
c     Print out copies of a global matrix
c
      n200 = min(n,200)
      if (m.gt.1) then
         write(6,1) nid,m,n,name6
   1     format(3i6,'  Matrix:',2x,a6)
         do i=1,m
            write(6,2) i,name6,(u(i,j),j=1,n200)
         enddo
   2     format(i8,1x,a6,20(10i9,/,10x))
      else
         write(6,3) nid,n,name6,(u(1,j),j=1,n200)
   3     format(2i8,1x,a6,20(10i9,/,10x))
      endif
      if (ic.eq.0) then
         write(6,*) 'cont: ',name6,nid
c        read (5,*) adum
      endif

      return
      end
c-----------------------------------------------------------------------
      subroutine outmat (u,m,n,name6,nid)
      real u(m,n)
      character*6 name6
c
c     return
c
c     Print out copies of a global matrix
c
      write(6,1) nid,m,n,name6
      n8 = min(8,n)
   1  format(3i6,'  Matrix:',2x,a6)
      do i=1,m
         write(6,2) i,name6,(u(i,j),j=1,n8)
      enddo
   2  format(i3,1x,a6,1p8e12.4)
c  2  format(i3,1x,a6,20(1p8e12.4,/,10x))

      return
      end
c-----------------------------------------------------------------------
      subroutine out_mapfile (pmap,nel,cell,nv,nrnk,noutflow)
      integer pmap(nel),cell(nv,nel)
      integer depth,d2

      depth            = log2(nel)
      d2               = 2**depth
      npts             = nel*nv
      call dmp_mapfile (pmap,nel,depth,cell,nv,nrnk,npts,noutflow)

      return
      end
c-----------------------------------------------------------------------
      subroutine dmp_mapfile (pmap,nel,depth,cell,nv,nrnk,npts,noutflow)

#     include "SIZE"

      common /sess/ session
      character*80 session
      character*80 fname
      character*1  fnam1(80)
      equivalence (fnam1,fname)

      integer pmap(nel),depth,cell(nv,nel)

      integer d2,e,p0
      common /arrayi2/ iwrk((1+8)*lelm)

      character*132 hdr
      character*5   version
      real*4 test
      data   test  / 6.54321 /

      d2 = 2**depth

      version = '#v001'

c      write(6,*) 'DEPTH:',depth,d2,nel,nrnk,npts,noutflow

      nactive = nrnk - noutflow

c      ifma2 = .false. ! force .map

      len = ltrunc(session,80)
      call chcopy(fname,session,80)
      if (ifma2) then
         call chcopy(fnam1(len+1),'.ma2',4)
      else
         call chcopy(fnam1(len+1),'.map',4)
      endif

      if (nv.ne.2)  then
         write(6,'(A,A)') 'writing ', fname
         if (ifma2) then
            call byte_open(fname,ierr)
            call blank(hdr,132)
            write(hdr,1) version,nel,nactive,depth,d2,npts,nrnk,noutflow
    1       format(a5,7i12)
            call byte_write(hdr,132/4,ierr)
            call byte_write(test,1,ierr) ! write the endian discriminator
         else
            open (unit=29,file=fname)
            write(29,2) nel,nactive,depth,d2,npts,nrnk,noutflow
    2       format(9i12)
        endif
      endif

      if (ifma2) then
         do e=1,nel
            iwrk(1) = pmap(e)-1
            call icopy(iwrk(2),cell(1,e),nv)
            call byte_write(iwrk,nv+1,ierr)
         enddo
      else
         do e=1,nel
            p0 = pmap(e)-1
            write(29,2) p0,(cell(k,e),k=1,nv)
         enddo
      endif

      return
      end
c-----------------------------------------------------------------------
      subroutine ituple_sort(a,lda,n,key,nkey,ind,aa)
C
C     Use Heap Sort (p 231 Num. Rec., 1st Ed.)
C
      integer a(lda,n),aa(lda)
      integer ind(1),key(nkey)
      logical iftuple_ialtb
C
      dO 10 j=1,n
         ind(j)=j
   10 continue
C
      if (n.le.1) return
      L=n/2+1
      ir=n
  100 continue
         if (l.gt.1) then
            l=l-1
c           aa  = a  (l)
            call icopy(aa,a(1,l),lda)
            ii  = ind(l)
         else
c           aa =   a(ir)
            call icopy(aa,a(1,ir),lda)
            ii = ind(ir)
c           a(ir) =   a( 1)
            call icopy(a(1,ir),a(1,1),lda)
            ind(ir) = ind( 1)
            ir=ir-1
            if (ir.eq.1) then
c              a(1) = aa
               call icopy(a(1,1),aa,lda)
               ind(1) = ii
               return
            endif
         endif
         i=l
         j=l+l
  200    continue
         if (j.le.ir) then
            if (j.lt.ir) then
               if (iftuple_ialtb(a(1,j),a(1,j+1),key,nkey)) j=j+1
            endif
            if (iftuple_ialtb(aa,a(1,j),key,nkey)) then
c              a(i) = a(j)
               call icopy(a(1,i),a(1,j),lda)
               ind(i) = ind(j)
               i=j
               j=j+j
            else
               j=ir+1
            endif
         GOTO 200
         endif
c        a(i) = aa
         call icopy(a(1,i),aa,lda)
         ind(i) = ii
      GOTO 100
      end
c-----------------------------------------------------------------------
      subroutine tuple_sort(a,lda,n,key,nkey,ind,aa)
C
C     Use Heap Sort (p 231 Num. Rec., 1st Ed.)
C
      real a(lda,n),aa(lda)
      integer ind(1),key(nkey)
      logical iftuple_altb
C
      dO 10 j=1,n
         ind(j)=j
   10 continue
C
      if (n.le.1) return
      L=n/2+1
      ir=n
  100 continue
         if (l.gt.1) then
            l=l-1
c           aa  = a  (l)
            call copy(aa,a(1,l),lda)
            ii  = ind(l)
         else
c           aa =   a(ir)
            call copy(aa,a(1,ir),lda)
            ii = ind(ir)
c           a(ir) =   a( 1)
            call copy(a(1,ir),a(1,1),lda)
            ind(ir) = ind( 1)
            ir=ir-1
            if (ir.eq.1) then
c              a(1) = aa
               call copy(a(1,1),aa,lda)
               ind(1) = ii
               return
            endif
         endif
         i=l
         j=l+l
  200    continue
         if (j.le.ir) then
            if (j.lt.ir) then
c              if ( a(j).lt.a(j+1) ) j=j+1
               if (iftuple_altb(a(1,j),a(1,j+1),key,nkey)) j=j+1
            endif
c           if (aa.lt.a(j)) then
            if (iftuple_altb(aa,a(1,j),key,nkey)) then
c              a(i) = a(j)
               call copy(a(1,i),a(1,j),lda)
               ind(i) = ind(j)
               i=j
               j=j+j
            else
               j=ir+1
            endif
         GOTO 200
         endif
c        a(i) = aa
         call copy(a(1,i),aa,lda)
         ind(i) = ii
      GOTO 100
      end
c-----------------------------------------------------------------------
      logical function iftuple_ialtb(a,b,key,nkey)
      integer a(1),b(1)
      integer key(nkey)
c
      do i=1,nkey
         k=key(i)
         if (a(k).lt.b(k)) then
            iftuple_ialtb = .true.
            return
         elseif (a(k).gt.b(k)) then
            iftuple_ialtb = .false.
            return
         endif
      enddo
      iftuple_ialtb = .false.
      return
      end
c-----------------------------------------------------------------------
      logical function iftuple_altb(a,b,key,nkey)
      real a(1),b(1)
      integer key(nkey)
c
      do i=1,nkey
         k=key(i)
         if (a(k).lt.b(k)) then
            iftuple_altb = .true.
            return
         elseif (a(k).gt.b(k)) then
            iftuple_altb = .false.
            return
         endif
      enddo
      iftuple_altb = .false.
      return
      end
c-----------------------------------------------------------------------
      logical function iftuple_ianeb(a,b,key,nkey)
      integer a(1),b(1)
      integer key(nkey)
c
      iftuple_ianeb = .false.
      do i=1,nkey
         k=key(i)
         if (a(k).ne.b(k)) then
            iftuple_ianeb = .true.
            return
         endif
      enddo
      return
      end
c-----------------------------------------------------------------------
      logical function iftuple_iaeqb(a,b,key,nkey)
      integer a(1),b(1)
      integer key(nkey)
c
      iftuple_iaeqb = .true.
      do i=1,nkey
         k=key(i)
         if (a(k).ne.b(k)) then
            iftuple_iaeqb = .false.
            return
         endif
      enddo
      return
      end
c-----------------------------------------------------------------------
      subroutine tuple_swapt_ip(x,m,n,p,t1,t2)
      real x(m,n),t1(m),t2(m)
      integer p(1)
c
c     In-place permutation: x'(p) = x
c

      do k=1,n
         if (p(k).gt.0) then   ! not swapped
            loop_start = k
            next       = p(loop_start)
            call copy(t1,x(1,loop_start),m)
            do j=1,n
               if (next.lt.0) then
                  write(6,*) 'Hey! iswapt_ip problem.',j,k,n,next
                  call exitt(1)
               elseif (next.eq.loop_start) then
                  call copy(x(1,next),t1,m)
                  p(next) = -p(next)
                  goto 10
               else
                  call copy(t2,x(1,next),m)
                  call copy(x(1,next),t1,m)
                  call copy(t1,t2       ,m)
                  nextp   =  p(next)
                  p(next) = -p(next)
                  next    =  nextp
               endif
            enddo
   10       continue
         endif
      enddo
c
      do k=1,n
         p(k) = -p(k)
      enddo
      return
      end
c-----------------------------------------------------------------------
      subroutine set_outflow(no,order,mo,cell,nv,nel,nrnk,cbc,nfc
     $                      ,ic,i0,i1,jc)
c
c     Order outflow nodes last
c

#     include "SIZE"

      integer cell(nv,nel),order(1)
      character*3      cbc(6,nel)

      integer ic(i0:i1),jc(1)

      parameter(lpts=8*lelm)
      common /arrayi2/ face (3*lpts) , elist(lelm) , ind  (lpts)
      integer face,elist

      integer     e,f,out_vtx,out_vtm
      character*3 cb
      logical     ifoutflow

      integer vface(4,6)  ! symm. vertices ordered on symm. faces
      save    vface
      data    vface / 1,3,5,7 , 2,4,6,8 , 1,2,5,6 , 3,4,7,8
     $              , 1,2,3,4 , 5,6,7,8 /

      ifoutflow = .false.
c
      nvf  = nv/2
      mvtx = nel*nv

      do e=1,nel
      do f=1,nfc
         cb = cbc(f,e)
c        write(6,*) cb,e,f,' cb'
         if (cb.eq.'O  ') then
            do i=1,nvf
               j = vface(i,f)
               if(cell(j,e).le.mvtx) cell(j,e) = cell(j,e) + mvtx
            enddo
            ifoutflow = .true.
         endif
      enddo
      enddo

c     Make cells consistent if you have an 'O  ' next to 'W  ' (say)
      do j=1,nv*nel
         i = cell(j,1)
         if (i.gt.mvtx) then  ! Outflow node, make attached nodes same
            ii = i - mvtx
            k0 = ic(ii)
            k1 = ic(ii+1)-1
            do k=k0,k1
               jj = jc(k)
               cell(jj,1) = i
            enddo
         endif
      enddo

      mo = 0
      no = 0
c      write(6,*) no,mo,out_vtm,ifoutflow,' OUTFLOW'
      if (.not. ifoutflow) return

      npts             = nel*nv
      call iranku      (cell,nrnk,npts,ind)
      call self_chk    (cell,nv,nel,5)       ! check for not self-ptg.

      out_vtm = mvtx + 1
      do e=1,nel  ! Determine number of unique outflow pts
      do f=1,nfc
         cb = cbc(f,e)
         if (cb.eq.'O  ') then
            do i=1,nvf
               j = vface(i,f)
               out_vtx = cell(j,e)
               out_vtm = min(out_vtm,out_vtx)
            enddo
         endif
      enddo
      enddo

      no = nrnk - out_vtm + 1

      mo = 0
      do i=out_vtm,nrnk
         mo = mo+1
         order(i) = mo
      enddo
      write(6,*) no,mo,out_vtm,ifoutflow,' OUTFLOW'

      return
      end
c-----------------------------------------------------------------------
      subroutine assign_order(cell,nv,nel,order)
c
c     Order nodes by "order"
c
      integer cell(nv,nel),order(1)

      integer     e,f

      do e=1,nel
      do k=1,nv
         i = cell(k,e)
         j = order(i)
         cell(k,e) = j
      enddo
      enddo

      return
      end
c-----------------------------------------------------------------------
      subroutine periodic_vtx
     $               (cell,nv,nel,irnk,dx,ndim,cbc,bc,nfc,iper,jmin)
c
c     NOTE:  .genmap() uses the symmetric vertex/face ordering.
c            .cbc() is ordered in symm. fashion
c            .Contents of cbc(), however, refer to nekton preprocessor
c             ordering, _not_ to the symmetric ordering.
c
c
c     Reassign cell() pointers to account for periodic connections.
c
      integer cell(nv,nel),iper(ndim,1),jmin(1)
      real dx(0:ndim,nv,nel)

      character*3      cbc(  6,nel)
      real*8           bc (5,6,nel)

      character*3      cb,cj
      integer e,f,v
      integer ipair(2,4)

      integer h2s(8) ! hypercube to strange ordering
      save    h2s
      data    h2s / 1,2,4,3,5,6,8,7 /

      integer eface(6)  ! return Nekton preprocessor face ordering
      save    eface
      data    eface / 4 , 2 , 1 , 3 , 5 , 6 /

      integer efaci(6)  ! return symmetric face ordering
      save    efaci
      data    efaci / 3 , 2 , 4 , 1 , 5 , 6 /

      write(6,*) 'start periodic vtx:',nel,irnk

      call izero(iper,ndim*irnk)   ! Zero out periodic indicator flag
      call jjnt (jmin,irnk)        ! Initial permutation = identity
      nvf = nv/2                   ! # vertices/face = 1/2 # vertices/cell

      nmn = irnk
      nmx = 0
      do e=1,nel
      do f=1,nfc
         cb = cbc(f,e)
c        write(6,*) cb,e,f,' cb'
         if (cb.eq.'P  ') then
           je = abs(bc(1,f,e))
           jf = bc(2,f,e)
           jf = efaci(jf)

           cj = cbc(jf,je)
           ke = abs(bc(1,jf,je))
           kf = bc(2,jf,je)
           kf = efaci(kf)

c          write(26,26)   e,f,cb,je,jf,cj,ke,kf,nel
c  26      format(i9,i2,1x,a3,i9,i2,1x,a3,i9,i2)

           if (bc(1,f,e).gt.0 .and. bc(1,jf,je).gt.0) then
              if (ke.ne.e .or. kf.ne.f .or. cj.ne.'P  ') then
               write(6,*)
               write(6,*) 'abort: PERIODIC MISMATCH 1:'
               write(6,6)   e,f,cb,' ie '
               write(6,6) je,jf,cj,' je '
               write(6,6) ke,kf,cj,' ke '
               write(6,*)
    6          format(i12,i3,1x,a3,1x,a4)
               call exitt(9)
              endif

              call find_connctd_pairs
     $                 (jmin,nvf,e,f,je,jf,cell,nv,dx,ndim,nel)

c             bc(1, f, e) = -bc(1, f, e) ! indicate that
c             bc(1,jf,je) = -bc(1,jf,je) ! pairing is done !!!

           elseif (bc(1,f,e)*bc(1,jf,je).le.0) then
              write(6,*)
              write(6,*) 'abort: PERIODIC MISMATCH 2:'
              write(6,6)   e,f,cb,' ie '
              write(6,6) je,jf,cj,' je '
              write(6,*) bc(1,f,e),bc(1,jf,je),' bc'
              write(6,*)
              call exitt(8)
           endif
         endif
      enddo
      enddo

c
c     Okay -- we now have the updated pointers, time to update
c     the cell pointers
c
      npts = nv*nel
      do i=1,npts
         cell(i,1) = jmin(cell(i,1))  ! permuted identity
      enddo
      call iranku      (cell,irnk,npts,iper) ! compress cell list
      call self_chk    (cell,nv,nel,6)       ! check for not self-ptg.

c
c     Reset bc array
c
      do e=1,nel
      do f=1,nfc
         if (cbc(f,e).eq.'P  ') bc(1,f,e) = abs(bc(1,f,e))
      enddo
      enddo

      write(6,*) 'done periodic vtx'

      return
      end
c-----------------------------------------------------------------------
      subroutine find_connctd_pairs
     $   (jmin,nvf,e,f,je,jf,cell,nv,dx,ndim,nel)

      integer jmin(1),cell(nv,1)
      real dx(0:ndim,nv,1)

      real x0(0:3,4),x1(0:3,4)
      real z0(0:3,4),z1(0:3,4)

      integer e,f,shift,smin

      integer vface(4,6)  ! circulant vertices on symm. faces, 3D
      save    vface       ! order ctr-clkws when looking at face
      data    vface / 1,5,7,3 , 2,4,8,6 , 1,2,6,5 , 3,7,8,4
     $              , 1,3,4,2 , 5,6,8,7 /
      integer wface(4,6)  ! circulant vertices on symm. faces, 2D
      save    wface       !
      data    wface / 3,1,0,0 , 2,4,0,0 , 1,2,0,0 , 4,3,0,0
     $              , 0,0,0,0 , 0,0,0,0 /

      integer icalld
      save    icalld
      data    icalld /0/

      icalld = icalld+1

      if (ndim.eq.2) call icopy(vface,wface,24)

      nvf = nv/2     ! # vertices/face = 1/2 # vertices/cell

c     write(6,4) e,f,je,jf,nv,nvf,ndim,' FACE'
c   4 format(i9,i3,i9,i3,3i3,a5)

      do i=1,nvf     ! Grab geometry for P-P face pair

         j0 = vface (i ,f)
         call copy  (x0(0,i),dx(0,j0, e),ndim+1)

         j1 = vface (i ,jf)
         call copy  (x1(0,i),dx(0,j1,je),ndim+1)

      enddo
      call copy(z0,x0,16)   ! For failure diagnosis
      call copy(z1,x1,16)   ! For failure diagnosis

      x0m = 0.
      do k=1,ndim           ! Subtract off mean of faces
         x0a = 0.
         x1a = 0.
         do i=1,nvf
            x0a = x0a + x0(k,i)
            x1a = x1a + x1(k,i)
         enddo
         do i=1,nvf
            x0m = max(x0m,abs(x0(k,i)))
            x0m = max(x0m,abs(x1(k,i)))
            x0(k,i) = x0(k,i) - x0a/nvf
            x1(k,i) = x1(k,i) - x1a/nvf
         enddo
      enddo

c     call outmat(x0,4,4,'  x0  ', e)
c     call outmat(x1,4,4,'  x1  ',je)

      d2min = 1.e22
      do shift=0,nvf-1
         d2 = 0.
         do i=1,nvf
            j=i+shift
            if (j.gt.nvf) j=j-nvf
            j=nvf+1-j              ! go backward for j !
c           write(6,5)
            do k=1,ndim
               d2 = d2 + (x0(k,i)-x1(k,j))**2
c              write(6,5) shift,i,j,k,x0(k,i),x1(k,j),d2
c   5          format(4i4,1p3e12.4,'  d2')
            enddo
         enddo
         if (d2.lt.d2min) then
            smin  = shift
            d2min = d2
         endif
      enddo
      shift = smin
      if (d2min.gt.0) d2min = sqrt(d2min)
      eps = 1.e-4
      eps = 1.e-3
      tol = eps*x0m
      if (d2min.gt.tol) then
         call outmat(x0,4,4,'  x0  ', e)
         call outmat(x1,4,4,'  x1  ',je)
         call outmat(z0,4,4,'  z0  ', e)
         call outmat(z1,4,4,'  z1  ',je)
         write(6,6) e , f,shift,eps,x0m
         write(6,6) je,jf,    i,tol,d2min
    6    format(i12,i2,i3,1p2e16.8,' abort: FACE MATCH FAIL')
         call exitt(0)
      endif

      if (nel.le.100000.or.mod(icalld,1000).eq.0)
     $   write(6,7) e,f,i,shift,d2min,icalld
    7    format(i12,i2,2i3,1p1e16.8,i9,' shift')

      do i=1,nvf

         j=i+shift
         if (j.gt.nvf) j=j-nvf
         j=nvf+1-j              ! go backward for j to make faces match

         iv = vface(i, f)
         jv = vface(j,jf)

         ic = cell(iv, e)
         jc = cell(jv,je)

         ijmin = jmin(ic)
         jjmin = jmin(jc)

         jmin(ic) = min(ijmin,jjmin)
         jmin(jc) = min(ijmin,jjmin)

      enddo

      return
      end
c-----------------------------------------------------------------------
      subroutine out_order(order,mo,elist,cell,nv,n1,n2)
c
c
c         +-----+
c         |     |
c         |     |
c         +-----+
c
c
c
c
c     Output orders for an 8x8 array of elements

      integer elist(1),cell(nv,16,16),order(1)
      integer e,v
      character*1 a(7,4,16,16)

      integer h2s(8) ! hypercube to strange ordering
      save    h2s
      data    h2s / 1,2,4,3,5,6,8,7 /

      call set_a(a)

      do l=1,n1+n2

         e = elist(l)
         if (l.le.n1) a(4,3,e,1) = 'X'
         if (l.gt.n1) a(4,3,e,1) = 'O'

         k=0
         do j=0,1
         do i=0,1
            k = k+1
            kstupid = h2s(k)
            v = cell(kstupid,e,1)
            if (i.eq.0.and.j.eq.0) write(a(1,1,e,1),1) order(v)
            if (i.eq.1.and.j.eq.0) write(a(5,1,e,1),1) order(v)
            if (i.eq.0.and.j.eq.1) write(a(1,4,e,1),1) order(v)
            if (i.eq.1.and.j.eq.1) write(a(5,4,e,1),1) order(v)
   1        format(i2)
         enddo
         enddo

      enddo
      write(6,*) 'n12:',n1,n2,nv
      call out_a(a)

      return
      end
c-----------------------------------------------------------------------
      subroutine out_a(a)
      character*1 a(7,4,16,16)
c
      do je=8,1,-1
      do j =4,1,-1
         write(6,1) ((a(i,j,ie,je),i=1,7),ie=1,8)
      enddo
      enddo
   1  format(56a1)

      write(6,*)
      write(6,*) 'continue ?'
      read (5,*) dumm

      return
      end
c-----------------------------------------------------------------------
      subroutine set_a(a)
      character*1 a(7,4,16,16)
c
c         +-----+
c         |     |
c         |     |
c         +-----+
c
      call blank(a,7*4*64)
c
      do je=1,8
      do ie=1,8
         write(a(1,1,ie,je),1)
         write(a(1,2,ie,je),2)
         write(a(1,3,ie,je),2)
         write(a(1,4,ie,je),1)
      enddo
      enddo
   1  format('+-----+')
   2  format('|     |')

      return
      end
c-----------------------------------------------------------------------
      subroutine outaij(ia,ja,n,name6,key)

      integer ia(0:n),ja(1)
      character*6 name6

c     if ia     < 0, then already on list
c     if ja(ia) < 0, then row is already processed

      write(6,*)
      write(6,*) ' OUT Aij ',name6,n,key

      do i=1,n
         j0 = abs(ia(i-1))
         j1 = abs(ia(i))-1
         m  = j1-j0 + 1
         m  = min(16,m)
         jm = j0 + m - 1
         write(6,1) i,j0,j1,'aij:',(ja(j),j=j0,jm)
      enddo
   1  format(3i4,1x,a4,1x,16i4)

      return
      end
c-----------------------------------------------------------------------
      function ipush(stack,val)
      integer stack(0:1),val

      n    = stack(0)
      if (n.ge.0) then
         n        = n+1
         stack(n) = val
         stack(0) = n
         ipush    = n
      else
         ipush    = -1
         write(6,*) 'ipush: negative stack count'
      endif
c     call outmati(stack,1,n+1,'stack:',val,1)

      return
      end
c-----------------------------------------------------------------------
      function ipop(nout,stack)
      integer stack(0:1)

      n    = stack(0)
      if (n.gt.0) then
         ipop     = stack(n)
         nout     = n-1
         stack(0) = nout
      else
         nout     = 0
         ipop     = 0
c        write(6,*) 'ipop: stack empty'
      endif
c     call outmati(stack,1,n+1,'popst:',ipop,1)

      return
      end
c-----------------------------------------------------------------------
      logical function is_connected(jactive,n0,ia,ja,n,jstack)

      integer ia(0:n),ja(1),jactive(n),jstack(0:n)

      character*1 adum

c     if ia     < 0, then already on list
c     if ja(ia) < 0, then row is already processed

      call izero(jactive,n)
      call izero(jstack ,n+1)

      m = ia(n)

      icurr      = 1
      jactive(1) = ia(icurr-1)

      do i=1,m             ! move through all entries in array

         j0 = ia     (icurr-1)
         j1 = ia     (icurr)
         jj = jactive(icurr)

         do j=jj,j1-1
            inext = ja(j)
            if (1.le.inext.and.inext.le.n) then  ! range check
               if (jactive(inext).eq.0) then
                  nstack = ipush(jstack,icurr)   ! push the return point
                  jactive(icurr) = j+1
                  jactive(inext) = ia(inext-1)
                  goto 10
               endif
            endif
         enddo

         jactive(icurr) = j1                     ! we've exhausted this row
         inext = ipop(nstack,jstack)

   10    icurr = inext
         if (icurr.eq.0) goto 100

      enddo
  100 continue

      n0           = 0
      is_connected = .true.

      do i=1,n
         if (jactive(i).eq.0) then
            n0           = n0+1
            is_connected = .false.
         endif
      enddo

c     write(6,*) is_connected,n,nstack,' is connected?'
c     if (.not.is_connected) then
c        n8 = min(n,18)
c        write(6,8) n,'jact:',(jactive(k),k=1,n8)
c        write(6,8) n,'ia:  ',(ia(k),k=0,n8-1)
c 8      format(i4,1x,a5,1x,18i5)
c        n8 = ia(n)-ia(0)-1
c        n8 = min(n8,18)
c        write(6,8) n8,'ja:  ',(ja(k),k=1,n8)
c     endif
c     call exitt(8)
c     read (5,*) adum

      return
      end
c-----------------------------------------------------------------------
      subroutine spec_bis(pmap,f,ia,ja,va,n,d,u,r,p2,
     $                                          w,rr,ev,m,ndim)

c     n = dimension of A
c     m = max # 50rations

      real d(m),u(m),f(n),r(n),p2(n),w(n),rr(n,m)
      integer pmap(n),ia(0:n),ja(1),va(1), ct

      if (n.lt.3) then
         call sbisect (pmap,f,p2,w,n)
         return
      endif

      call rint(f,n)
      n2 = n/2
      r1 = 1000.*n
      do i=1,n2              ! bias in 0-0-1 direction
         f(i) = f(i) + r1
      enddo
      call ortho1(f,n)
      ftf = glsc2(f,f,n)
      fnm = 1./sqrt(ftf)
      call cmult(f,fnm,n)

      npass =50
      do k=1,npass
         niter = m
         call glanczos(rr,n,d,u,niter,f,ia,ja,va,r,p2,w)
         call lanczos2(f,rr,n,ev,d,u,niter)
         if (niter.lt.m) goto 100
      enddo
  100 continue

      call sbisect (pmap,f,p2,w,n)
      return
      end
c----------------------------------------------------------------------
      subroutine sbisect(pmap,f,p,w,n)
      real f(n)
      integer pmap(n),p(n),w(n)

c     if (n.gt.2) then
         call sort     (f,w,n)
         call jjnt     (p,n)
         call iswap_ip (p,w,n)
c     else
c        call jjnt     (p,n)
c     endif

      n2 = n/2
      if (n.eq.1) n2 = 1

      do i=1,n2
         pmap(p(i)) = 1
      enddo

      do i=n2+1,n
         pmap(p(i)) = 2
      enddo

      return
      end

c-----------------------------------------------------------------------
      subroutine glanczos(rr,n,diag,upper,niter,f,ia,ja,va,r,p,w)
c
c     Lanczos applied to graph Laplacian
c
      real    rr(n,1),diag(1),upper(1),f(1),r(1),p(1),w(1)
      integer ia(1),ja(1),va(1)
      real one,eps

      call rzero(diag ,niter)
      call rzero(upper,niter)
      pap = 0.0
c
c     set machine tolerances
c
      one = 1.
      eps = 1.e-28
      if (one+eps .eq. one) eps = 1.e-12
      if (one+eps .eq. one) eps = 1.e-5
      eps = 1.e-5

      rtz1=1.0

      call copy  (r ,f,n)
      call ortho1(r,n)
      rtr   = glsc2(r,r,n)
      rnorm = sqrt(rtr)
      rtol  = rnorm*eps
      rni   = 1./rnorm
      call cmult2  (rr,r,rni,n)
      iter = 0

      do 1000 iter=1,niter
         rtz2=rtz1
         rtz1=rtr
         beta = rtz1/rtz2
         if (iter.eq.1) beta=0.0

         call add2s1(p,r,beta,n)
         call ortho1(p,n)
         call ax(w,p,ia,ja,va,n)

c        Save p^Ap for eigenvalue estimates
         pap_old = pap
         pap=glsc2(w,p,n)
         alpha=rtz1/pap
         alphm=-alpha
         call add2s2(r,w,alphm,n)
c        call outmat (r,16,16,'resid ',iter)

         rtr = glsc2(r,r,n)
         if (rtr.le.0) goto 1001
         rnorm = sqrt(rtr)
         rni   = 1./rnorm
         call cmult2  (rr(1,iter+1),r,rni,n)

c        Generate tridiagonal matrix for Lanczos scheme
         if (iter.eq.1) then
            diag(iter) = pap/rtz1
         else
            diag(iter)    = (beta**2 * pap_old + pap ) / rtz1
            upper(iter-1) = -beta * pap_old / sqrt(rtz2 * rtz1)
         endif
         if (rnorm.le.rtol) goto 1001
 1000 continue
      iter = iter-1
 1001 continue
c
      niter = iter
c      write(6,6) iter,n,rnorm,rtol
    6 format(i4,i12,' cg:',1p6e12.4)
c
      return
      end
c-----------------------------------------------------------------------
      subroutine ax(y,x,ia,ja,va,n)

c     This routine computes y = Ax, where A is the graph Laplacian

      real y(1),x(1)
      integer ia(0:1),ja(1),va(1)
c
      do i=1,n
         y(i) = 0
         do j=ia(i-1),ia(i)-1
            y(i) = y(i) + va(j)*x(ja(j))
         enddo
      enddo
      return
      end
c-----------------------------------------------------------------------
      subroutine ortho1(p,n)
c
c     Orthogonalize wrt the 1 vector
c
      real p(1)
c
      s = 0.
      do i=1,n
         s = s + p(i)
      enddo
      s = s/n
      do i=1,n
         p(i) = p(i) - s
      enddo
c
      return
      end
c-----------------------------------------------------------------------
      subroutine lanczos2(v1,rr,n,ev,d,u,m)
c
c     Compute two smallest eigenpair estimates for (m x m) sym tridiag matrix
c
c                         d1 u1
c                         u1 d2 u2
c                T  =        u2 d3 .
c                               .  .  um
c                                 um  dm
c
c     and sum the columns of the n x m matrix R (:=rr) using the Fiedler vec.
c
      real    v1(1),v2(1),rr(n,1),ev(m,1),d(1),u(1)

      call calcvec (d,u,v1,v1(m+1),m,imin,imax,ev)

      call rzero(v1,n)
      do j=1,m
         call add2s2(v1,rr(1,j),ev(j,imin),n)
      enddo

c     call outmat(ev(1,imin),1,m,'evmin ',imin)
c     call outmat(v1,16,16,'rsbeig',imin)

      return
      end
c-----------------------------------------------------------------------
      subroutine calcvec (diag,upper,d,e,n,imin,imax,z)
c
c     This is the numerical recipes tridiagonal eigenvalue/vectr solver.
c
c     -  Eigen vectors are returned in z(n,n)
c
c
      real diag(n),upper(n)
      real d(n),e(n),z(n,n)
c
      call copy (d,diag ,n)
      call copy (e,upper,n)
      call ident(z,n)
c
      do 15 l=1,n
         iter = 0
c
    1    do 12 m=l,n-1
            dd = abs( d(m) ) + abs( d(m+1) )
            if ( abs(e(m)) + dd .eq. dd ) goto 2
   12    continue
c
         m = n
    2    if ( m .ne. l ) then
c
            if ( iter .eq. 30 ) then
               write (6,*) 'too many iterations'
               return
            endif
c
            iter = iter + 1
            g = ( d(l+1) - d(l) ) / ( 2.0 * e(l) )
            r = sqrt( g**2 + 1.0 )
c
c    sign is defined as a(2) * abs( a(1) )
c
            g = d(m) - d(l) + e(l)/(g+sign(r,g))
            s = 1.0
            c = 1.0
            p = 0.0
c
            do 14 i = m-1,l,-1
               f = s * e(i)
               b = c * e(i)
               if ( abs(f) .ge. abs(g) ) then
                  c = g/f
                  r = sqrt( c**2 + 1.0 )
                  e(i+1) = f*r
                  s = 1.0/r
                  c = c*s
               else
                  s = f/g
                  r = sqrt( s**2 + 1.0 )
                  e(i+1) = g*r
                  c = 1.0 / r
                  s = s * c
               endif
c
               g = d(i+1) - p
               r = ( d(i) - g ) * s + 2.0 * c * b
               p = s * r
               d(i+1) = g + p
               g = c*r - b
c      ...     find eigenvectors ... (new, 11/19/94, pff, p.363.Num.Rec.I.)
               do 13 k=1,n
                  f = z(k,i+1)
                  z(k,i+1) = s*z(k,i)+c*f
                  z(k,i  ) = c*z(k,i)-s*f
   13          continue
c      ...     end of eigenvector section ...
   14       continue
c
            d(l) = d(l) - p
            e(l) = g
            e(m) = 0.0
            goto 1
         endif
c
   15 continue
c
      imin = 1
      imax = 1
      dmin = d(imin)
      dmax = d(imax)
      do 40 i = 1 , n
        if (d(i).lt.dmin) then
           dmin = d(i)
           imin = i
        endif
        if (d(i).gt.dmax) then
           dmax = d(i)
           imax = i
        endif
c       write(6,*) i,imin,imax,d(i),' iminx'
   40 continue
c     write(6,41) 'eig:',(d(i),i=1,n)
   41 format(a4,2x,5(1p10g12.4,/))
c
c     Orthonormalize eigenvectors
c
      n10 = min(n,10)
      do ko=1,n
         do ki=1,n
            e(ki) = glsc2(z(1,ki),z(1,ko),n)
            if (e(ki).ne.0.0) e(ki) = sqrt(abs(e(ki)))
         enddo
c        write(6,9) d(ko),(e(ki),ki=1,n10)
c   9    format(1pe12.4,' e:',1p10e12.4)
         scale = 1.0/e(ko)
         call cmult(z(1,ko),scale,n)
      enddo
c
      return
      end
c=======================================================================
      subroutine ident(a,n)
      real a(n,n)
      call rzero(a,n*n)
      do i=1,n
         a(i,i) = 1.0
      enddo
      return
      end
c=======================================================================
      subroutine rzero(a,n)
      real  a(1)
      do i = 1, n
         a(i) = 0.0
      enddo
      return
      end
c=======================================================================
      function glsc2(x,y,n)
      real x(1), y(1)
      s = x(1)*y(1)
      do i=2,n
         s = s+x(i)*y(i)
      enddo
      glsc2 = s
      return
      end

c=======================================================================
      subroutine add2s2(a,b,c,n)
      real  a(1),b(1)
      do i = 1, n
         a(i) = a(i) + c*b(i)
      enddo
      return
      end
c=======================================================================
      subroutine add2s1(a,b,c,n)
      real  a(1),b(1)
      do i = 1, n
         a(i) = c*a(i) + b(i)
      enddo
      return
      end

c=======================================================================
      subroutine reverse_p (p,n)          ! lightly load node 0
      integer p(n),pmax
c
      pmax = p(1)
      do i=1,n
         pmax = max(pmax,p(i))
      enddo
c      write(6,*) 'pmax:',pmax,n

      do i=1,n
         p(i) = pmax+1 - p(i)  ! range of p is [1:pmax]
      enddo
      return
      end

c-----------------------------------------------------------------------
      subroutine unique_vertex2(cell,dx,ndim,nel,q,ind,ninseg,ifseg,wk)

      integer cell(1),ind(1),ninseg(1)
      logical ifseg(1)
      real dx(0:ndim,1)

      integer e
      real dxt(4),t1(4),t2(4),wk(0:ndim,1)

      nvtx = 2**ndim
      n = nvtx*nel

      write(6,*) 'start locglob_lexico:',nvtx,nel,n,q

      qq = q*q  ! Square of relative tolerance

      do i=1,n
         cell(i)   = i
         ifseg (i) = .false.
      enddo

c     Sort by directions

      lda         = 1+ndim
      nseg        = 1
      ifseg(1)    = .true.
      ninseg(1)   = n

      do ipass=1,ndim   ! Multiple passes eliminates false positives
      do j=1,ndim       ! Sort within each segment
         write(6,*) 'locglob:',j,nseg,n
         i =1
         j1=j+1
         do iseg=1,nseg
            call tuple_sort(dx(0,i),lda,ninseg(iseg),j1,1,ind,dxt) !key=j1
            call iswap_ip  (cell(i),ind,ninseg(iseg)) ! Swap position
            i  =   i + ninseg(iseg)
         enddo

c        q=0.0010   ! Smaller is better
c        q=0.2      ! But generous is more forgiving for bad meshes!

         do i=2,n
           if ((dx(j,i)-dx(j,i-1))**2.gt.qq*min(dx(0,i),dx(0,i-1)))
     $        ifseg(i)=.true.
         enddo

         nseg = 0              !  Count up number of different segments
         do i=1,n
            if (ifseg(i)) then
               nseg = nseg+1
               ninseg(nseg) = 1
            else
               ninseg(nseg) = ninseg(nseg) + 1
            endif
         enddo
      enddo
      enddo
c
c     Assign global node numbers (now sorted lexigraphically!)
c
      ig  = 0
      ic  = 0
      icm = 0
      do i=1,n
        ic = ic+1     ! count number of instances at present ig

        if (ifseg(i)) then
           ig=ig+1
           icm = max(ic,icm)
           ic  = 0
        endif
        ind(cell(i)) = ig
      enddo
      nglb = ig

c     Unshuffle geometry:
       call tuple_swapt_ip(dx,lda,n,cell,t1,t2)

c     Reassign cell to hold global index numbering

      call icopy     (cell,ind,n)
      call self_chk  (cell,nvtx,nel,0)       ! check for not self-ptg.

c     Reassign geometry to match global index numbering
c     Retain the geometry that is associated with the smallest bounding radius

c     call copy          (wk,dx,lda*n)
c     call izero         (ind,nglb)      ! Flag to see if value already assigned

c     do i=1,n
c        ig = cell(i)
c        if (ind(ig).eq.0) then
c           call copy(dx(0,ig),wk(0,i),lda) ! lda = ndim+1 values ->global vtx
c           ind(ig) = 1
c        elseif (wk(0,i).lt.dx(0,ig)) then
c           call copy(dx(0,ig),wk(0,i),lda) ! lda = ndim+1 values ->global vtx
c        endif
c     enddo
      write(6,6) nseg,nglb,n,icm
    6 format(' done locglob_lexico:',4i12)

      return
      end
c-----------------------------------------------------------------------
      subroutine out_geofile (dx,ndim,nv,nel,pmap,io)
      integer pmap(nel),p0,e
      real dx(0:ndim,nv,nel)

      do e=1,nel
         p0 = pmap(e)-1
         x=0
         y=0
         z=0
         do i=1,nv
            x=x+dx(1,i,e)
            y=y+dx(2,i,e)
            z=z+dx(3,i,e)
         enddo
         x=x/nv
         y=y/nv
         z=z/nv
         write(io,1) p0,x,y,z
      enddo
    1 format(i12,1p3e12.4)

      return
      end
c-----------------------------------------------------------------------
      subroutine self_chk(cell,nv,nel,flag)     ! check for not self-ptg.
      integer cell(nv,nel),flag
      integer e

      do e=1,nel
      do i=1,nv
         do j=i+1,nv
            if (cell(i,e).eq.cell(j,e)) then

               write(6,*)
               call outmati(cell(1,e),2,4,'SELF!!',e,flag)

               write(6,*)
               write(6,*) 'ABORT: SELF-CHK ',i,j,e,flag
               write(6,*) 'Try to tighten the mesh tolerance!'

c              call outmatti  (cell,nv,nel,'slfchk',nel,flag)

               call exitt(flag)

            endif
         enddo
      enddo
      enddo

      return
      end
c-----------------------------------------------------------------------
      subroutine mult_chk(dx,ndim,nv,nel,cell,nrnk)

#     include "SIZE"

      real dx(0:ndim,nv,nel)
      integer cell(nv,nel)

      parameter(lpts=8*lelm)

      common /carrayw/ w1   (lpts) , w2   (lpts)
     $               , w3   (lpts) , w4   (lpts)
     $               , w5   (lpts)

      integer e,v,emax,vmax

      call rzero(w4,nrnk)
      mult_max = 0
      do e=1,nel                     ! Get global vertex multiplicities
      do v=1,nv
         i = cell(v,e)
         if (i.gt.nrnk) then
            write(6,1) e,v,i,nrnk,(dx(k,v,e),k=1,3)
    1       format(i12,i3,2i12,1p3e12.4,' i>nrnk! ERROR!')
         else
            w4(i)=w4(i)+1.
            mult = w4(i)
            mult_max = max(mult_max,mult)
         endif
      enddo
      enddo
c      write(6,*) nrnk,nel,mult_max,' nrank, nel, max. multiplicity'

      return
      end
c-----------------------------------------------------------------------
      subroutine rd_bc_bin(cbc,bc,nelv,nelt,ifbswap)

c     .Read Boundary Conditions (and connectivity data)

#     include "SIZE"

      character*3 cbc(6,lelm)
      real*8      bc (5,6,lelm)
      logical     ifbswap

      integer e,f,buf(30)

      npass = 1
      if (nelt.gt.nelv) npass = 2   ! default to thermal topology (for now)

      ierr = 0
      do kpass = 1,npass

         do e=1,nelt   ! fill up cbc w/ default
         do k=1,6
            cbc(k,e) = 'E  '
         enddo
         enddo

         nwds =(2 + 1 + 5)*(wdsizi/4)   ! eg + iside + cbc + bc(5,:,:)

         if(wdsizi.eq.8) then
            call byte_read(rbc_max,2,ierr)
            if (ifbswap) call byte_reverse8(rbc_max,2,ierr)
            nbc_max = rbc_max
            do k=1,nbc_max
c              write(6,*) k,' dobc1 ',nbc_max
               call byte_read(buf,nwds,ierr)
               n8wds=nwds/2
               if (ifbswap) call byte_reverse8(buf,nwds-2,ierr) ! last is char
               if(ierr.ne.0) call exitti
     &              ('Error reading byte bcs ',ierr)
               call buf_to_bc(cbc,bc,buf,nelt)
            enddo
         else
            call byte_read(nbc_max,1,ierr)
            if (ifbswap) call byte_reverse(nbc_max,1,ierr)
            do k=1,nbc_max
c              write(6,*) k,' dobc1 ',nbc_max
               call byte_read(buf,nwds,ierr)
               if (ifbswap) call byte_reverse(buf,nwds-1,ierr) ! last is char
               if(ierr.ne.0) call exitti
     &              ('Error reading byte bcs ',ierr)
               call buf_to_bc(cbc,bc,buf,nelt)
            enddo
         endif

      enddo

      return
      end

c-----------------------------------------------------------------------
      subroutine buf_to_bc(cbl,bl,buf,nelt)  ! version 1 of binary reader

#     include "SIZE"

      character*3 cbl(6,nelt)
      real*8      bl(5,6,nelt)
      integer     buf(30)

      integer e,eg,f

      if(wdsizi.eq.8) then
         call copyi4(e,buf(1),1) !1-2
         call copyi4(f,buf(3),1) !3-4
         call copy  (bl(1,f,e),buf(5),5) !5--14
         call chcopy(cbl( f,e),buf(15),3)!15-16
c     the following is not needed since buf(5)-buf(6) are already real
c         if(nelt.ge.1000000.and.cbl(f,e).eq.'P  ')
c     $   call copyi4(bl(1,f,e),buf(5),1) !Integer assign connecting P element
      else
         e  = buf(1)
         f  = buf(2)
         call copy48r ( bl(1,f,e),buf(3),5)
         call chcopy  (cbl(  f,e),buf(8),3)
         if(nelt.ge.1000000.and.cbl(f,e).eq.'P  ')
     $     bl(1,f,e) = buf(3) ! Integer assign of connecting periodic element
      endif

c      write(6,1) e,f,cbl(f,e),(bl(k,f,e),k=1,5),' CBC'
c  1   format(i8,i4,2x,a3,5f8.3,1x,a4)

      return
      end

c-----------------------------------------------------------------------
      subroutine buf_to_xyz(buf,xc,yc,zc,e,ifbswap,ndim,wdsizi)
c     version 1 of binary

      logical ifbswap
      integer e,eg,buf(0:49),wdsizi

      real xc(8),yc(8),zc(8)   !these are *8

      nwds = (1 + ndim*(2**ndim)) ! group + 2x4 for 2d, 3x8 for 3d

      ierr = 0

      if (ifbswap.and.wdsizi.eq.8)     then
          nwds=nwds*2
          call byte_reverse8(buf,nwds,ierr)
      elseif (ifbswap.and.wdsizi.eq.4) then
          call byte_reverse (buf,nwds,ierr)
      endif

      if (ierr.ne.0) call exitti
     $   ('Error byte_reverse in buf_to_xy ',ierr)

      if(wdsizi.eq.8) then
         call copyi4(igroup,buf(0),1) !0-1
         if (ndim.eq.3) then
            call copy  (xc,buf( 2),8) !2 --17
            call copy  (yc,buf(18),8) !18--33
            call copy  (zc,buf(34),8) !34--49
         else
            call copy  (xc,buf( 2),4) !2 --9
            call copy  (yc,buf(10),4) !10--17
         endif
      else
         igroup = buf(0)
         if (ndim.eq.3) then
            call copy4r(xc,buf( 1),8)
            call copy4r(yc,buf( 9),8)
            call copy4r(zc,buf(17),8)
         else
            call copy4r(xc,buf( 1),4)
            call copy4r(yc,buf( 5),4)
         endif
      endif

      return
      end

c-----------------------------------------------------------------------
       subroutine outcheck(buf,nwds)
       integer nwds
       real buf(nwds)

       nn = nwds/2
       do i=1,nn
          write(6,*) buf(i),i,' whatt'
       enddo

      return
      end

c-----------------------------------------------------------------------
c-----------------------------------------------------------------------
      subroutine open_bin_file(ifbswap,nelgt,ndim,nelgv,wdsizi)
c     open file & chk for byteswap & 8byte reals

      logical ifbswap,if_byte_swap_test

      CHARACTER*132 NAME
      CHARACTER*1  NAM1(132)
      EQUIVALENCE  (NAME,NAM1)

      integer fnami (33)
      character*132 fname,re2fle
      equivalence (fname,fnami)

      character*80 hdr
      character*5 version
      real*4      test

      character*1 re2(4)
      character*4 re24
      equivalence (re2,re24)
      DATA re24   /'.re2'       /

      common /sess/ session
      character*80 session

      integer wdsizi

      call izero  (fnami,33)

      len = ltrunc(session,80)
      call chcopy (nam1,session,80)
      len = len + 1
      call chcopy (nam1(len),re2,4)
      len = len + 3
      call chcopy (fname,nam1,len)

      ierr=0
      call byte_open(fname,ierr)
      if(ierr.ne.0) call exitti
     $  ('Error opening file in open_bin_file ',ierr)
      call byte_read(hdr,20,ierr)
      if(ierr.ne.0) call exitti
     $  ('Error reading header in open_bin_file ',ierr)
c      write(6,80) hdr
c   80 format(a80)

      read (hdr,1) version,nelgt,ndim,nelgv
    1 format(a5,i9,i3,i9)
      wdsizi=4
      if(version.eq.'#v002')wdsizi=8
      if(version.eq.'#v003')wdsizi=8

      call byte_read(test,1,ierr)
      if(ierr.ne.0) call exitti
     $  ('Error reading test number in open_bin_file ',ierr)
      ifbswap = if_byte_swap_test(test)

      return
      end
c-----------------------------------------------------------------------
      logical function if_byte_swap_test(bytetest)
c
      real*4 bytetest,test2
      real*4 test_pattern
      save   test_pattern
c
      test_pattern = 6.54321
      eps          = 0.00020
      etest        = abs(test_pattern-bytetest)
      if_byte_swap_test = .true.
      if (etest.le.eps) if_byte_swap_test = .false.

      ierr  = 0
      test2 = bytetest
      call byte_reverse(test2,1,ierr)
      if(ierr.ne.0) call exitti
     $  ('Error with byte_reverse in if_byte_swap_test ',ierr)
c     write(6,*) 'Byte swap:',if_byte_swap_test,bytetest,test2

      return
      end

c-----------------------------------------------------------------------
      subroutine copyI4(a,b,n)
      integer A(1)
      REAL   B(1)
      DO 100 I = 1, N
 100     A(I) = B(I)
      return
      end
c-----------------------------------------------------------------------
      subroutine copy4(a,b,n)
      real*4 a(1)
      real*4 b(1)
      do i = 1, n
         a(i) = b(i)
      enddo
      return
      end
c-----------------------------------------------------------------------
      subroutine copy4r(a,b,n)
      real   a(1)
      real*4 b(1)
      do i = 1, n
         a(i) = b(i)
      enddo
      return
      end
c-----------------------------------------------------------------------
      subroutine copy48r(a,b,n)
      real*8 a(1)
      real*4 b(1)
      do i = 1, n
         a(i) = b(i)
      enddo
      return
      end
c-----------------------------------------------------------------------

      INTEGER FUNCTION INDX132(S1,S2,L2)
      CHARACTER*132 S1,S2
C
      N1=80-L2+1
      INDX132=0
      IF (N1.LT.1) return
C
      DO 100 I=1,N1
         I2=I+L2-1
         IF (S1(I:I2).EQ.S2(1:L2)) THEN
            INDX132=I
            return
         ENDIF
  100 CONTINUE
C
      return
      end
c-----------------------------------------------------------------------
      subroutine cell2v(i0,i1,ic,nic,jc,njc,cell,nv,ncell,type,wk)
c
c     Generate a list of cells that point to each numbered
c     vertex in [i0,i1].  ic/jc is the csr-formated list.
c
c     Cells (aka elements) have nv local verties.
c
      integer ic(1),jc(1),cell(nv,ncell),wk(1),type
c
      i0 = iglmin(cell,nv*ncell)
      i1 = iglmax(cell,nv*ncell)

      if (i1-i0.gt.nic) then
         write(6,1) i0,i1,nic,nv,ncell,njc
    1    format(' ERROR: nic too small in cell2v:',6i12)
         i0 = 0 ! error return code
         i1 = 0 ! error return code
         return
      endif

      call cell2v1(ic,i0,i1,jc,njc,cell,nv,ncell,type,wk)
c     do i = 1,nv*ncell
c        write(6,*) jc(i), cell(i,1), ic(i)
c     enddo
c     call exit

      return
      end
c-----------------------------------------------------------------------
      subroutine cell2v1(ic,i0,i1,jc,njc,cell,nv,ncell,type,wk)
c
c     Generate a list of cells that point to each numbered
c     vertex in [i0,i1].  ic/jc is the csr-formated list.
c
c     Cells (aka elements) have nv local verties.
c
      integer ic(i0:i1),jc(1),cell(nv,ncell),wk(i0:i1),type

c     Step 1:  count number of cells per vertex
c  the number of cells each vertex 'touches'

      nic = i1-i0+1
      call izero(wk,nic)
      do j=1,nv*ncell
         i = cell(j,1)
         wk(i) = wk(i) + 1
      enddo
c  wk() is an array refering to each vertex, and holds the num of cells
c     Step 2:  Generate csr pointer

      ic(1) = 1
      do i=i0,i1
         ic(i+1) = ic(i) + wk(i)
         wk(i)   = 0
      enddo

c     Step 3:  fill jc()

      if (type.eq.1) then ! return cell
         do k=1,ncell
         do j=1,nv
            i = cell(j,k)
            jc(ic(i)+wk(i)) = k  ! This is the cell number
            wk(i) = wk(i) + 1    ! This is number filled for ith vertex
         enddo
         enddo

      else                ! return structured pointer
         do j=1,nv*ncell
            i = cell(j,1)
            jc(ic(i)+wk(i)) = j  ! This is the structured pointer
            wk(i) = wk(i) + 1    ! This is number filled for ith vertex
         enddo
      endif

c     Diagnostics

c     write(6,*)
c     do i=i0,i1
c        j0 = ic(i)
c        j1 = ic(i+1)-1
c        write(6,1) i,(jc(j),j=j0,j1)
c  1     format(i8,' c2v:',20i5)
c     enddo

      return
      end
c-----------------------------------------------------------------------
      subroutine greedy (pmap,cell,nv,nelv,nelt,ndim,ic,jc,ip,ep,ne,pb)
c
c     Distribute elements e > nelv to processors p \in [1,pmax]
c
c     Two pass strategy:
c
c     1st pass:  fill underloaded processors
c
c     2nd pass:  assign any T element to any connected processor p
c                for which ne(p) < nep_max
c
c
c     Required resources:
c
c     ne(p), p(e), pmax, nep_max
c

      integer pmap(1)
     $      , cell (nv,1)
     $      , ip(0:1),ep(1)          ! These are
     $      , ic(1),jc(1)            ! work arrays
     $      , ne(0:nelv)             ! upon input
     $      , pb(1)

      integer e,pp,p,pnext,pmax

      pmax = iglmax(pmap,nelv)  ! pmap is sorted by e, pmap is 1's based
      call izero(ne,pmax+1)
      do e=1,nelv
         ne(pmap(e)) = ne(pmap(e)) + 1
      enddo

      nepf_min = iglmin(ne(1),pmax)   ! min number of elem/proc, fluid
      nepf_max = iglmax(ne(1),pmax)   ! max number of elem/proc, fluid
      if (nepf_max-nepf_min.gt.1) then
         write(6,*) 'ERROR: nepfmax/min:',nepf_max,nepf_min,nelv,nelt
         call exitt(11)
      endif

      nep_max = nelt/pmax
      if (nep_max*pmax .lt. nelt) nep_max = nep_max + 1

c
c     Build processor-to-element map
c
      call build_proc_el(ip,ep,ne,pmap,pmax,nelv)

      nepf_min = iglmin(ne(1),pmax)   ! min number of elem/proc, fluid
      nepf_max = iglmax(ne(1),pmax)   ! max number of elem/proc, fluid
      if (nepf_max-nepf_min.gt.1) then
         write(6,*) 'ERROR2: nepfmax/min:',nepf_max,nepf_min,nelv,nelt
         call exitt(11)
      endif

      nep_max = nelt/pmax

      call breadth_first_fill(pb,pmax)
      goto 11

c     First loop, use greedy to fill underloaded processors

      do pp=1,pmax
       p = pb(pp)+1
       nep0 = ne(p)
       if (ne(p).lt.nepf_max) then  !  [ip,ep: csr proc-el list]
          j0=ip(p)
          j1=ip(p+1)-1
          do j=j0,j1   ! loop over all elements e on proc p
             e = ep(j)
             do i=1,nv
                iv=cell(i,e)   ! Find elements ke attached to e
                k0 = ic(iv)
                k1 = ic(iv+1)-1
c     write(6,7) pp,p,j0,j1,i,k0,k1,iv,' j0j1 '
c   7 format(8i8,a6)
                do k=k0,k1
                   kv = jc(k)  !   This is the structured vertex pointer
                   ke = 1 + (kv-1)/nv      !  = neighboring element
c       write(6,9) e,ke,pmap(ke),pp,p,j,i,k,' pmpke'
c   9   format(8i8,a6)
                   if (pmap(ke).le.0) then ! Found an unattached element
                      pmap(ke) = p
                      ne  (p ) = ne(p)+1
                      goto 10
                   endif
                enddo
             enddo
          enddo
       endif
   10  continue  ! next processor
       if (nep0.ne.ne(p)) write(6,8) pp,p,nep0,ne(p),nepf_max,' p1st'
      enddo

c      call maptest (pmap,nelv,nelt,'map test x',ep,ip)
      call exitt(nelt)
c
c     Repeat first loop, using _anything_ to fill underloaded processors
c
   11 continue
      ke_min = nelv
      do pp=1,pmax
       p = pb(pp)+1
       nep0 = ne(p)
       if (ne(p).lt.nepf_max) then
          do ke=ke_min+1,nelt
             if (pmap(ke).le.0) then
                pmap(ke) = p
                ne  (p ) = ne(p)+1
                ke_min = ke
                goto 20
             endif
          enddo
       endif
   20  continue
c      if (nep0.ne.ne(p)) write(6,8) pp,p,nep0,ne(p),nepf_max,' p2nd'
       write(6,8) pp,p,nep0,ne(p),nepf_max,' p2nd'
  8    format(5i9,a5)
      enddo

c      call maptest (pmap,nelv,nelt,'map test x',ep,ip)
      call exitt(nelt)

c     Diagnostic - any underloaded left ?
      do pp=1,pmax
       p = pb(pp)+1
       if (ne(p).lt.nepf_max) write(6,*) pp,p,ne(p),nepf_max,' under'
      enddo

c
c     Now, use greedy to distribute remaining elements
c
c     (First version of this code, we revert to round robin...)
c

      n_new = 0
      pnext = 0
      do e=nelv+1,nelt
         if (pmap(e).le.0) then
            pnext = pnext+1
            if (pnext.gt.pmax) pnext = 1
            p = pb(pnext)+1
            pmap(e) = p
            ne  (p) = ne(p) + 1
            n_new = n_new + 1
         endif
      enddo
      write(6,*) n_new,nelv,nelt,' n remaining'

      return
      end
c-----------------------------------------------------------------------
      subroutine build_proc_el(ip,ep,ne,pmap,pmax,nel)
      integer ip(0:1),ep(1),ne(0:1),pmap(1),pmax
      integer e,p

c     Step 1:  count number of elems per proc
      call izero(ne,pmax+1)
      do e=1,nel
         p=pmap(e)   ! pmap is 1-based,  a "0" --> not specified
         ne(p) = ne(p) + 1
      enddo

c     Step 2:  Generate csr pointer

      ip(0) = 1
      do p=0,pmax
         ip(p+1) = ip(p) + ne(p)
         ne(p)   = 0
      enddo

c     Step 3:  fill ep()

      do e=1,nel
         p = pmap(e)
         ep(ip(p) + ne(p)) = e
         ne(p)             = ne(p) + 1 ! This is number filled for proc p
      enddo

      return
      end
c-----------------------------------------------------------------------
      function indxi(list,item,n)
      integer list(1)

      indxi = 0
      do j=1,n
         if (list(j).eq.item) then
            indxi = j
            return
         endif
      enddo

      return
      end
c-----------------------------------------------------------------------
      subroutine c2c(ic2c,jc2c,vc2c,cell,nv,nel,iv2c,jv2c,nn,wk)

c     build the c-to-c connectivity matrix in CSR format

      integer ic2c(1),jc2c(1),vc2c(1),cell(nv,nel)
      integer iv2c(1),jv2c(1),wk(1)
      integer e,type,row_sum,i

c     Step 1:  build the v-to-c connectivity matrix in CSR format
      nic = nn
      njc = nn
      type = 1 ! return vertex-to-cell pointer in (iv2c,jv2c) csr pair
      call cell2v(i0,i1,iv2c,nic,jv2c,njc,cell,nv,nel,type,wk)
      nic = i1-i0+1
c     call outaij(iv2c,jv2c,nic,'iv2c  ',type)

c     Step 2: strip mine

      n_in_strip = 20
      nstrips    = nel / n_in_strip + 1

      k0 = 1                        ! offsets for work array
      k1 = k0 + n_in_strip + 1
      k2 = k1 + n_in_strip + 1

      ie0 = 1
      ic2c(ie0) = 1

      do istrip=1,nstrips
         ie1   = ie0 + n_in_strip - 1
         ie1   = min(ie1,nel)
         ncell = ie1 - ie0 + 1
         call c2cs(ic2c,jc2c,vc2c
     $            ,iv2c,jv2c,i0,i1
     $            ,cell,nv,ie0,ie1
     $            ,wk(k0),wk(k1),wk(k2))
         ie0 = ie1+1
      enddo

c
c     Convert vc2c to graph Laplacian
c
      do e=1,nel
         j0 = ic2c(e)
         j1 = ic2c(e+1)-1
         nj = j1-j0 + 1
         ii = indxi(jc2c(j0),e,nj)
         row_sum = 0
         do k=1,nj
            if (k.ne.ii) then
               j = j0+k-1
               row_sum=row_sum + vc2c(j)
               vc2c(j)=-vc2c(j)           ! off-diag elements < 0
            endif
         enddo
         j = j0+ii-1
         vc2c(j)=row_sum  ! diagonal entry of graph Laplacian = row_sum

         if (ii.eq.0) then
            write(6,*) 'c2c graph, did not find self?',e,j0,j1
            call outmati(jc2c(j0),1,nj,'c2cslf',e,1)
            call exitt(nj)
         endif
      enddo
      return
      end
c-----------------------------------------------------------------------
      subroutine c2cs(ic2c,jc2c,vc2c
     $               ,iv2c,jv2c,k0,k1
     $               ,cell,nv,ie0,ie1
     $               ,nee,ic2t,jc2t)

      integer ic2c(1),jc2c(1),vc2c(1),cell(nv,1)
      integer iv2c(k0:k1),jv2c(1)

      integer nee(ie0:ie1),ic2t(ie0:ie1+1),jc2t(1)

      ne = ie1-ie0 + 1
      call izero(nee(ie0),ne)

      do ie=ie0,ie1              ! Counting phase
      do iv=1,nv
         jv = cell(iv,ie)
         j0 = iv2c(jv)
         j1 = iv2c(jv+1)-1
c        write(6,*) ie,iv,jv,j0,j1,nee(ie),' nee A'
         do jj=j0,j1
            nee(ie) = nee(ie)+1  ! this count too high; compressed below
         enddo
      enddo
      enddo
c     call outmati(nee,1,ne,'nee  1',ne,1)

      ic2t(ie0) = 1
      do ie=ie0,ie1
         ic2t(ie+1) = ic2t(ie) + nee(ie)
      enddo

      j0 = ic2t(ie0)
      j1 = ic2t(ie1)+1
      nj = j1-j0
      call izero(jc2t(j0),nj)
      call izero(nee(ie0),ne)

      do ie=ie0,ie1          ! First filling phase
         i0 = ic2t(ie)
         do iv=1,nv
            jv = cell(iv,ie)
            j0 = iv2c(jv)
            j1 = iv2c(jv+1)-1
            do jj=j0,j1
               je       = jv2c(jj)
               ii       = indxi(jc2t(i0),je,nee(ie))
               if (ii.eq.0) then
                  ji       = i0 + nee(ie)
                  jc2t(ji) = je
                  nee(ie)  = nee(ie)+1     ! # unique elements connected to ie
               endif
            enddo
         enddo
      enddo

      do ie=ie0,ie1
         ic2c(ie+1) = ic2c(ie) + nee(ie)
      enddo
      call izero(nee(ie0),ne)

      do ie=ie0,ie1          ! Compression + 2nd filling phase
         i0 = ic2c(ie)
         do iv=1,nv
            jv = cell(iv,ie)
            j0 = iv2c(jv)
            j1 = iv2c(jv+1)-1
            do jj=j0,j1
               je       = jv2c(jj)
               ii       = indxi(jc2c(i0),je,nee(ie))
               if (ii.eq.0) then
                  ji       = i0 + nee(ie)
                  jc2c(ji) = je
                  vc2c(ji) =  1            ! # connections for pair (ie,je)
                  nee(ie)  = nee(ie)+1     ! # unique elements connected to ie
               else
                  ji       = i0 + ii - 1
                  vc2c(ji) = vc2c(ji) + 1  ! # connections for pair (ie,je)
               endif
            enddo
         enddo
      enddo

      return
      end
c-----------------------------------------------------------------------
      subroutine outbc(cbc,bc,nel,ndim,name6)
      character*3 cbc(6,1)
      real*8       bc(5,6,1)
      character*6 name6
      integer e,f

      nface = 2*ndim
      do e=1,nel
      do f=1,nface
         write(6,1) e,f,cbc(f,e),(bc(k,f,e),k=1,5),name6
      enddo
      enddo
    1 format(i12,i4,2x,a3,5g18.11,1x,a6)
      return
      end
c-----------------------------------------------------------------------
      subroutine breadth_first_fill(p,np)
      integer p(0:1)
      integer start,stride,count

      kmax     = log2(np) + 1
      count    = 0
      p(count) = 0
      stride   = np

      do k=1,kmax
         next = stride/2
         do i=1,np
            count    = count+1
            p(count) = next
            next     = next + stride
            if (next.ge.np) goto 10
         enddo
   10    continue
         stride = stride/2
      enddo

      return
      end
c-----------------------------------------------------------------------
      subroutine cell_plot(dx,cell,nv,ndim,nel,io_in)
      real    dx(0:ndim,1)
      integer cell(nv,nel),e
      character*8 filename

      integer circ2lex(4),count, file1, file2, file3

      save    circ2lex,count
      data    circ2lex  / 1 , 2 , 4 , 3 /
      data    count     / 1 /

      io = io_in + count
      count = count + 1
      if (count.EQ.100 .OR. count.EQ.5) count=count+3

      file1=11
      file2=12
      file3=14
      if (io.eq.file1.or.io.eq.file2.or.io.eq.file3) then
        if (io.EQ.file1) filename = 'cpt1.dat'
        if (io.EQ.file2) filename = 'cpt2.dat'
        if (io.EQ.file3) filename = 'cpt3.dat'
        io=15
        OPEN(unit=io,file = filename)
        do e=1,nel
          write(io,*)  ! insert blank line for "pen up" in gnuplot
          do kk=1,nv+1 ! Walk around the 4 points (in "circular" order)
             k = kk
             if (kk.gt.nv) k = 1   ! Rewrite 1st point to close loop
             lc = circ2lex(k)      ! convert circ to lexicographical order
             lg = cell(lc,e)       ! get the "global" index from current cell
             write(io,1) (dx(j,lg),j=1,2),lg,e
    1        format(1p2e15.6,i8,i10)
          enddo
        enddo
      close(io)
      endif

      write(6,*) 'Plotted ',nel,' cells to unit ',io,'.'

      return
      end
c-----------------------------------------------------------------------
      subroutine spec_bis_conn(pmap,n1,n2,c,elist,nv,nel
     $                                ,cell,ndim,w1,w2)
c
c Calls Lanczos algorithm, if that fails, do
c geometric bisection if that fails do  non-geometric bisection
c
c Ensures that all graphs are connected(unless infinite loop occurred)
c

#     include "SIZE"

      integer pmap(nel),n1,n2,ndim,elist(nel),w1(1),w2(1)
      integer cell(nv,1),c(nv,nel)
      parameter(lpts=8*lelm)
      parameter(mm=50)

      common /arrayr1/ f(lelm),r(lelm),p2(lelm),w(lelm),rr(lelm,mm)
     $               , ev(mm*mm),d(mm),u(mm)
      common /arrayi2/ jdual(32*lelm) , vdual(32*lelm)
     $               , idual(lelm)
      common /arrayi3/ wk(lpts+2*lelm)
      common /arrayi/ iv2c(lpts) , jv2c(2*lpts)
      integer idual,jdual,vdual,wk, iv2c,jv2c
      integer list(lpts)
      equivalence (jv2c,list)

      logical ifconn,is_connected
      integer key(8), wk2(8),nkey
      integer e,size1,size2,temp

      save    numset, largeset
      data    numset      / 0 /
      data    largeset    / 0 /

c     write(6,*) 'spec_bis: ', nel
      m=mm

      call izero (key,8) ! zero out arrays to avoid
      call izero (wk2,8) ! potential compiler issues

      call c2c(idual,jdual,vdual,c,nv,nel,iv2c,jv2c,lpts,wk)
      ifconn = is_connected(list,n0,idual,jdual,nel,wk)
      if (ifconn) then
         call spec_bis  (pmap,f,idual,jdual,vdual
     $                     ,nel,d,u,r,p2,w,rr,ev,m,ndim)
         call sort_count(pmap,elist,n1,n2,nel,w1,wk)
c
c Check to see if initial was connected..
c
         do k  = 1,n1                 ! extract cell sublist for A
            e  = elist(k)
            k4 = 1 + nv*(k-1)
            call icopy(w1(k4),cell(1,e),nv)
         enddo
         j=1
         do k  = n1+1,nel              ! extract cell sublist for B
            e  = elist(k)
            j4 = 1 + nv*(j-1)
            call icopy(w2(j4),cell(1,e),nv)
            j  = j+1
         enddo

         call c2c(idual,jdual,vdual,w1,nv,n1,iv2c,jv2c,lpts,wk)
         ifconn = is_connected(list,n0,idual,jdual,n1,wk)
         if (ifconn) then
            call c2c(idual, jdual,vdual,w2,nv,n2,iv2c,jv2c,lpts,wk)
            ifconn  = is_connected(list,n0,idual,jdual,n2,wk)
            if (ifconn) then
               return
            else
c              write(6,*) 'N2 was not connected-Lanczos', n0,n2,nel
            endif
         else
c           write(6,*) 'N1 was not connected-Lanczos', n0,n1, nel
         endif
c
c  Sort cell and bisect - almost the same as last resort..
c
         do k  = 1,nel
            e  = elist(k)
            call icopy(c(1,k),cell(1,e),nv)
         enddo

         nkey = nv
         call jjnt       (key,nv)
         call ituple_sort(c  ,nv,nel,key,nkey,w1,wk2)
         call iswap_ip   (elist,w1,nel)

         do i = 1,n1
            pmap(i) = 1
         enddo
         do i = n1+1,nel
            pmap(i) = 2
         enddo
c        call sort_count(pmap,elist,n1,n2,nel,w1,wk)
c        not needed because elist is already sorted and pmap
c        is assigned in order.
c
c Now Check to see if that worked...
c
         do k  = 1,n1                 ! extract cell sublist for A
            e  = elist(k)
            k4 = 1 + nv*(k-1)
            call icopy(w1(k4),cell(1,e),nv)
         enddo
         j=1
         do k  = n1+1,nel              ! extract cell sublist for B
            e  = elist(k)
            j4 = 1 + nv*(j-1)
            call icopy(w2(j4),cell(1,e),nv)
            j  = j+1
         enddo

         call c2c(idual,jdual,vdual,w1,nv,n1,iv2c,jv2c,lpts,wk)

         ifconn = is_connected(list,n0,idual,jdual,n1,wk)

         if (ifconn) then
            call c2c(idual, jdual,vdual,w2,nv,n2,iv2c,jv2c,lpts,wk)
            ifconn  = is_connected(list,n0,idual,jdual,n2,wk)
            if (ifconn) then
c              write(6,*) 'RECONN'
               return
            else
c              write(6,*) 'N2 not connected-Geo',n0,n2,nel
            endif
         else
c           write(6,*) 'N1 not connected-Geo',n0,n1,nel
         endif

c
c If the simple bisection failed, do a complicated one
c
         call c2c(idual, jdual,vdual,c,nv,nel,iv2c,jv2c,lpts,wk)

         call jjnt(wk,nel)

         w1(1)   = wk(1)
         w2(1)   = wk(nel)
         wk(1)   = 0
         wk(nel) = 0
         size1   = 1
         size2   = 1

         do i = 1,nel
            if (size1+size2.eq.nel) goto 30
            i0 = idual(w1(i  ))
            i1 = idual(w1(i)+1)-1
            j0 = idual(w2(i  ))
            j1 = idual(w2(i)+1)-1

            if (i.le.size1) then
               do k=i0,i1
                  if (jdual(k).ne.w1(i)) then
                     do j = 1,nel
                        if (jdual(k).eq.wk(j)) then
                           w1(size1+1) = wk(j)
                           wk(j)       = 0
                           size1       = size1+1
                           goto 10
                        endif
                     enddo
                  endif
  10              continue
               enddo
            endif
            if (i.le.size2) then
               do k=j0,j1
                  if (jdual(k).ne.w2(i)) then
                     do j = 1,nel
                        if (jdual(k).eq.wk(j)) then
                           w2(size2+1) = wk(j)
                           wk(j)       = 0
                           size2       = size2 +1
                           goto 20
                        endif
                     enddo
                  endif
  20              continue
               enddo
            endif
         enddo

  30     continue
         do i=1,size1
            pmap(i) = 1
         enddo
         do i=size1+1,nel
            pmap(i) = 2
         enddo

         call icopy    (w1(size1+1),w2,size2)
         call iswap_ip (elist,w1,nel)
c
c Transfer separator nodes, checking for connectivity
c
         temp=0
  50     if (size1.gt.n1) then
            call count_sep (wk,w2,num,elist,cell,nv,size1,size2)
            if (temp.eq.size1) goto 60     !Prevents Infinite Loop
            temp = size1
            do i =1,temp
               if (wk(i).gt.0) then
                  pmap(i) = 2
                  size1   = size1-1
                  size2   = size2+1
                  k4   = 1
                  do k = 1,nel
                     if (pmap(k).eq.1) then
                        e  = elist(k)
                        call icopy(w1(k4),cell(1,e),nv)
                        k4 = k4+nv
                     endif
                  enddo
                  call c2c(idual,jdual,vdual,w1,nv
     $                                      ,size1,iv2c,jv2c,lpts,w2)
                  ifconn = is_connected(list,n0,idual,jdual,size1,w2)
                  if (.not.ifconn) then
                     pmap(i) = 1
                     size1   = size1+1
                     size2   = size2-1
                  endif
                  if (size2.eq.n2) goto 40
               endif
            enddo
         endif
         if (size1.lt.n1) then !check set 2 for sep nodes and swap
            call count_sep (wk,w2,num,elist,cell,nv,size1,size2)
            if (temp.eq.size1) goto 60     !Prevents Infinite Loop
            temp = size1
            do i = temp+1,nel
               if (wk(i).gt.0) then !this element has sep. node
                  pmap(i) = 1
                  size2   = size2-1
                  size1   = size1+1
                  k4 = 1
                  do k = 1,nel
                     if (pmap(k).eq.2) then
                        e  = elist(k)
                        call icopy(w1(k4),cell(1,e),nv)
                        k4 = k4+nv
                     endif
                  enddo
                  call c2c(idual,jdual,vdual,w1,nv
     $                                      ,size2,iv2c,jv2c,lpts,w2)
                  ifconn = is_connected(list,n0,idual,jdual,size2,w2)
                  if (.not.ifconn) then
                     pmap(i) = 2
                     size2   = size2+1
                     size1   = size1-1
                  endif
                  if (size1.eq.n1) goto 40
               endif
            enddo
         endif

  40     continue

         call sort_count(pmap,elist,size1,size2,nel,w2,wk)
         if (size1.ne.n1) goto 50
c
c Now Check to see if that worked..
c
         do k = 1,n1                 ! extract cell sublist for A
            e  = elist(k)
            k4 = 1 + nv*(k-1)
            call icopy(w1(k4),cell(1,e),nv)
         enddo
         j=1
         do k = n1+1,nel              ! extract cell sublist for B
            e  = elist(k)
            j4 = 1 + nv*(j-1)
            call icopy(w2(j4),cell(1,e),nv)
            j  = j+1
         enddo

         call c2c(idual,jdual,vdual,w1,nv,n1,iv2c,jv2c,lpts,wk)
         ifconn = is_connected(list,n0,idual,jdual,n1,wk)
         if (ifconn) then
            call c2c(idual, jdual,vdual,w2,nv,n2,iv2c,jv2c,lpts,wk)
            ifconn  = is_connected(list,n0,idual,jdual,n2,wk)
            if (ifconn) then
c              write(6,*) 'RECONN'
               return
            else
               write(6,*) 'N2 not connected-Growth',n0,n2,nel
            return
            endif
         else
            write(6,*) 'N1 not connected-Growth',n0,n1,nel
            return
         endif
c
c If there was an infinite loop, just divide it...
c
  60     continue
c        write(6,*) 'infinite loop'
         do i = 1,n1
            pmap(i) = 1
         enddo
         do i = n1+1,nel
            pmap(i) = 2
         enddo
c
c If All else fails...(only when infinite loop occurred)
c
      else
         numset = numset+1
         if (nel.ge.64) largeset = largeset+1
         write(6,*) 'not connected',n0,nel,numset,largeset

         n1 = nel/2
         n2 = nel - n1
         i1 = 0
         i2 = 0
         call jjnt(key,nv)
         nkey = nv
         call ituple_sort(c,nv,nel,key,nkey,w1,wk2)
         call iswap_ip   (list,w1,nel)
         call iswap_ip   (elist,w1,nel)

         do i=1,nel
            if (i1.lt.n1.and.i2.lt.n2) then
               if (list(i).ne.0) then
                  i1      = i1+1
                  pmap(i) =  1
               else
                  i2      = i2+1
                  pmap(i) =  2
               endif
            elseif (i1.lt.n1) then
               pmap(i) =  1
               i1      = i1+1
            else
               pmap(i) =  2
               i2      = i2+1
            endif
         enddo
         call sort_count(pmap,elist,n1,n2,nel,w1,wk)
      endif

      return
      end
c-----------------------------------------------------------------------
      subroutine sort_count(pmap,elist,n1,n2,nel,w1,wk)

      integer pmap(nel),elist(nel),n1,n2,w1(1),wk(1)

      integer key(2), nkey, wk2(2),k

      k = 1
      do i = 1,nel
         wk(k)   = pmap (i)
         wk(k+1) = elist(i)
         k       = k+2
      enddo

      key(1) = 1
      key(2) = 2
      nkey   = 2
      call ituple_sort(wk,2,nel,key,nkey,w1,wk2)

      k = 1
      do i = 1,nel
         pmap (i) = wk(k)
         elist(i) = wk(k+1)
         k        = k+2
      enddo

      n1 = nel     ! Count number in each 1/2
      do i = 2,nel
         if (pmap(i).ne.pmap(1)) then
            n1 = i-1
            goto 10
         endif
      enddo
   10 continue
      n2 = nel - n1

      return
      end
c-----------------------------------------------------------------------
      subroutine assign_gllnid(gllnid,iunsort,nelgt,nelgv,np)
c
      integer gllnid(1),iunsort(1),nelgt,np
      integer e,eg

      log2p = log2(np)
      np2   = 2**log2p
      if (np2.eq.np.and.nelgv.eq.nelgt) then   ! std power of 2 case
         npstar = ivlmax(gllnid,nelgt)+1
         nnpstr = npstar/np
         do eg=1,nelgt
            ko=gllnid(eg)
            if (gllnid(eg).ge.0) gllnid(eg) = gllnid(eg)/nnpstr
         enddo
         return
      elseif (np2.eq.np) then   ! std power of 2 case, conjugate heat xfer
         npstar = max(np,ivlmax(gllnid,nelgv)+1)
         nnpstr = npstar/np
         do eg=1,nelgv
            ko=gllnid(eg)
            if (gllnid(eg).ge.0) gllnid(eg) = gllnid(eg)/nnpstr
         enddo

         nelgs  = nelgt-nelgv  ! number of solid elements
         npstar = max(np,ivlmax(gllnid(nelgv+1),nelgs)+1)
         nnpstr = npstar/np
         do eg=nelgv+1,nelgt
            ko=gllnid(eg)
            if (gllnid(eg).ge.0) gllnid(eg) = gllnid(eg)/nnpstr
         enddo

         return
      else
         call exitti
     $      ('Conjugate heat transfer requires P=power of 2 ',np)
      endif

c  Below is the code for P a non-power of two:

c  Split the sorted gllnid array (read from .map file)
c  into np contiguous partitions.

c  To load balance the partitions in case of mod(nelgt,np)>0
c  add 1 contiguous entry out of the sorted list to NODE_i
c  where i = np-mod(nelgt,np) ... np

      nel   = nelgt/np       ! number of elements per processor
      nmod  = mod(nelgt,np)  ! bounded between 1 ... np-1
      npp   = np - nmod      ! how many paritions of size nel

      ! sort gllnid
      call isort(gllnid,iunsort,nelgt)

      ! setup partitions of size nel
      k   = 0
      do ip = 0,npp-1
         do e = 1,nel
            k = k + 1
            gllnid(k) = ip
         enddo
      enddo
      ! setup partitions of size nel+1
      if(nmod.gt.0) then
        do ip = npp,np-1
           do e = 1,nel+1
              k = k + 1
              gllnid(k) = ip
           enddo
        enddo
      endif

      ! unddo sorting to restore initial ordering by
      ! global element number
      call iswapt_ip(gllnid,iunsort,nelgt)

      return
      end
c-----------------------------------------------------------------------
      subroutine maptest (pmap,nelgv,nelgt,name10,gllnid,wk)
      integer pmap(1),gllnid(1),wk(2,0:1)
      character*10 name10
      integer e

      np = 32  ! default test value for np

      do e=1,nelgt
         gllnid(e) = pmap(e)-1
      enddo
      call assign_gllnid(gllnid,wk,nelgt,nelgv,np)

      call izero(wk,2*np)
      do e=1,nelgt
         mid = gllnid(e)
         if (mid.ge.0) then
           wk (2,mid) = wk(2,mid) + 1
           if (e.le.nelgv) wk (1,mid) = wk(1,mid) + 1
         endif
c        write(6,2)e,mid,wk(1,mid),wk(2,mid),nelgv,nelgt,name10,np
c   2    format(4i8,2i9,' mid ',a10,' np =',i8)
      enddo
c      do mid=0,np-1
c         write(6,1) mid,wk(1,mid),wk(2,mid),nelgv,nelgt,name10,np
c    1    format(3i8,2i11,' NEL ',a10,' np =',i8)
c      enddo

      return
      end
c-----------------------------------------------------------------------
      subroutine outcell(cell,dx,n,ndim)

      integer cell(n)
      real dx(0:ndim,n)

      do i = 1,n
      write(6,6) cell(i),i,dx(1,i),dx(2,i)
      enddo
   6  format(i8,i3,3g15.6)

      return
      end
c-----------------------------------------------------------------------
      subroutine face_chk(face_conn,cell,
     $                        nv,ncell,nic,njc,v2cind,v2c,w3)
c     checks that every face has proper connectivity
c        i.e. if a 3D face has 3 vertices connected a another,
c             it must have a fourth
c     vc2    : vertex to cell pointer
c     vc2ind : indicies for the vertex to cell pointer
c     cell   : global vertex numbering

      integer vface(4,6)  ! symm. vertices ordered on symm. faces
      save    vface
      data    vface / 1,3,5,7 , 2,4,6,8 , 1,2,5,6 , 3,4,7,8
     $              , 1,2,3,4 , 5,6,7,8 /

      logical face_conn,is_ok,n_is_3
      integer cell(nv,ncell),v2c(1),v2cind(1),w3(200),share(200)
      integer f,v,vfail,v2

      ndim = 3
      itype = 1          ! vertex to cell pointers !
      call cell2v(i0,i1,v2cind,nic,v2c,njc,cell,nv,ncell,itype,w3)

      nface = ndim*2     ! number of faces per element
      nfv   = 2*(ndim-1) ! number of vertices in each face

      face_conn = .true.

      do i = 1,ncell
      do f = 1,nface
         n_shared = 0
         do v = 1,nfv
            iv1 = cell(vface(v,f),i)
            j0  = v2cind(iv1)
            j1  = v2cind(iv1+1)-1
            do j=j0,j1
               je = v2c(j)
               if (je.ne.i) then
                  n_shared = n_shared+1
                  share(n_shared) = je
               endif
            enddo
         enddo

         call isort(share,w3,n_shared)

         ilast = 0
         icount = 0
         n_is_3 = .false.

         do k = 1,n_shared
            if (share(k).eq.ilast) then
               icount = icount+1
               if(icount.eq.3) then
                  n_is_3 = .true.
               elseif(icount.eq.nfv) then
                  n_is_3 = .false.
               endif
            else
              icount = 1
              ilast  = share(k)
              if(n_is_3) then  !FAIL
                 n_fail = share(k-1)
                 write(6,6) f,i,n_fail,k,n_shared
    6            format('MISSING FACE CONNECTION  a',i3,2i10,i4,i3)
                 write(6,*) (share(kk),kk=1,n_shared)
                 goto 10
              endif
            endif
         enddo
         if (n_is_3) then !FAIL
            n_fail = share(k-1)
            write(6,*) 'MISSING FACE CONNECTION  b',i,f,n_fail,k
            goto 10
         endif
      enddo
      enddo

      return

   10 continue
      do vfail = 1,nfv
         iv1 = cell(vface(vfail,f),i)
         j0    = v2cind(iv1)
         j1    = v2cind(iv1+1)-1
         is_ok = .false.
         do j  = j0,j1          ! Checks that pt_iv1 connects to k
            if (v2c(j).eq.n_fail) is_ok = .true.
         enddo
         if(.not.is_ok) goto 20 ! Then this pt is our failed one
      enddo

  20  continue
      vfail = vface(vfail,f)             ! Failed vertex, on element i
      call find_v2(v2,i,n_fail,cell,ncell,nv,v2cind,v2c)
      call fix_geom(cell,i,vfail,n_fail,v2,v2cind,v2c,ncell,nv)
      face_conn = .false.

      return
      end
c-----------------------------------------------------------------------
      subroutine find_v2(v2,e1,e2,cell,nel,nv,ind,jc)
c
c     Find the vertex(v2) on e2 that (v1,e1) should be connected to
c
      integer cell(nv,nel),ind(1),jc(1)
      integer e1,e2,v2
      integer f,v,vf,ncount
      logical is_ok

      integer vface(4,6)  ! symm. vertices ordered on symm. faces
      save    vface
      data    vface / 1,3,5,7 , 2,4,6,8 , 1,2,5,6 , 3,4,7,8
     $              , 1,2,3,4 , 5,6,7,8 /

      do f = 1,6
         ncount = 0
         do v = 1,4
            iv2 = cell(vface(v,f),e2)
            j0  = ind(iv2)
            j1  = ind(iv2+1)-1
            is_ok = .false.
            do j=j0,j1
               if(jc(j).eq.e1) then
                 ncount = ncount +1
                 is_ok = .true.
               endif
            enddo
            if(.not.is_ok)vf = v
         enddo
         if(ncount.eq.3) goto 10
      enddo
  10  continue
      v2 = vface(vf,f)

      return
      end
c-----------------------------------------------------------------------
      subroutine fix_geom(cell,e1,v1,e2,v2,ind,jc,nel,nv)
c
c     Changes the wrong point (v1,e1) to the correct point (v2,e2)
c     Then checks that no other (v1,e1) exist in the geom.
c
      integer cell(nv,nel),ind(1),jc(1)
      integer e1,v1,e2,v2,wrong_cell

      iv1 = cell(v1,e1)
      iv2 = cell(v2,e2)
      ivt = min(iv1,iv2)         ! what will now be the "correct" cell
      ivf = max(iv1,iv2)         ! what will now be the "incorrect" cell

      j0 = ind(ivf)
      j1 = ind(ivf)
      do j = j0,j1
         ke = jc(j)
         do k = 1,nv
            if (cell(k,ke).eq.ivf) cell(k,ke)=ivt
         enddo
      enddo

      return
      end
c-----------------------------------------------------------------------
      function mod1(i,n)
C
C     Yields MOD(I,N) with the exception that if I=K*N, result is N.
C
      mod1=0
      if (i.eq.0) return
      if (n.eq.0) then
         write(6,*)
     $  'WARNING:  Attempt to take MOD(I,0) in FUNCTION MOD1.'
         return
      endif
      ii = i+n-1
      mod1 = mod(ii,n)+1
      return
      end
c-----------------------------------------------------------------------