!-------------------------------------------------------------------------------
! Copyright (c) 2016 The University of Tokyo
! This software is released under the MIT License, see LICENSE.txt
!-------------------------------------------------------------------------------
module m_hecmw_matrix_ordering_METIS
  use hecmw_util
  use hecmw_metis_5
  use hecmw_etype
  use m_hecmw_mesh_edge_info
  implicit none

  private
  public :: hecmw_matrix_ordering_METIS
  public :: hecmw_matrix_ordering_METIS_from_MAT

  type hecmw_edge_info
    integer(kind=kint) :: N = 0
    integer(kind=kint), pointer :: node(:) => null()
  endtype hecmw_edge_info

contains

  subroutine hecmw_matrix_ordering_METIS(hecMESH, N, NP, indexL, itemL, indexU, itemU, perm, iperm)
    use, intrinsic :: iso_c_binding  !, only : C_int, C_double, C_float
    implicit none
    type(hecmwST_local_mesh) :: hecMESH
    integer(kind=kint), intent(in)  :: N, NP
    integer(kind=kint), intent(in)  :: indexL(0:), indexU(0:)
    integer(kind=kint), intent(in)  :: itemL(:), itemU(:)
    integer(kind=kint), intent(out) :: perm(:), iperm(:)

    type(hecmw_edge_info), allocatable :: edge(:)
    integer(kind=kint) :: i, j, k, iS, jS, jE, nu, nl
    integer(kind=kint) :: itype, icel, nedge, ic_type, in, jn, kn, nn, ne
    integer(kind=kint) :: imax, imin
    integer(kind=kint) :: nlocal(20)
    integer(kind=kint), allocatable :: check(:)
    integer(idx_t) :: ierr
    integer(idx_t) :: nvtxs
    integer(idx_t), pointer :: xadj(:)        => null()
    integer(idx_t), pointer :: adjncy(:)      => null()
    integer(idx_t), pointer :: vwgt(:)        => null()
    integer(idx_t), pointer :: options(:)     => null()
    integer(idx_t), pointer :: metis_perm(:)  => null()
    integer(idx_t), pointer :: metis_iperm(:) => null()
    real(kind=kreal) :: t1, t2

    t1 = HECMW_WTIME()

    nvtxs = N
    allocate(edge(N))

    do itype = 1, hecMESH%n_elem_type
      jS = hecMESH%elem_type_index(itype-1) + 1
      jE = hecMESH%elem_type_index(itype  )
      ic_type = hecMESH%elem_type_item(itype)
      if(hecmw_is_etype_link(ic_type))cycle
      nn = hecmw_get_max_node(ic_type)
      ne = hecmw_get_max_edge(ic_type)
      do icel=jS,jE
        iS = hecMESH%elem_node_index(icel-1)
        do i=1,nn
          nlocal(i) = hecMESH%elem_node_item(iS+i)
        enddo
        do i=1,nn
          in = nlocal(i)
          jn = edge(in)%N
          edge(in)%N = edge(in)%N + nn - 1
          call reallocate_array(jn, edge(in)%N, edge(in)%node)
          do j=1,nn
            if(i /= j)then
              jn = jn + 1
              edge(in)%node(jn) = nlocal(j)
            endif
          enddo
        enddo
      enddo
    enddo

    t2 = HECMW_WTIME()
    write(*,"(a,1pe11.4)")"      ** edge    time: ", t2-t1
    t1 = HECMW_WTIME()

    !buget sort (delete multiple entries)
    do i=1,N
      in = edge(i)%N
      imax = maxval(edge(i)%node)
      imin = minval(edge(i)%node)
      allocate(check(imin:imax))
      check(imin:imax) = 0
      do j=1,in
        check(edge(i)%node(j)) = 1
      enddo
      nn = 0
      do j=imin,imax
        if(check(j)==1) nn = nn + 1
      enddo
      edge(i)%N = nn
      deallocate(edge(i)%node)
      allocate(edge(i)%node(nn))
      in = 1
      do j=imin,imax
        if(check(j)==1)then
          edge(i)%node(in) = j
          in = in + 1
        endif
      enddo
      deallocate(check)
    enddo

    allocate(xadj(N+1))
    xadj(1) = 0
    do i = 1, N
      xadj(i+1) = xadj(i) + edge(i)%N
    enddo

    nedge = xadj(N+1)
    allocate(adjncy(nedge))
    in = 1
    do i=1,N
      do j=1,edge(i)%N
        adjncy(in) = edge(i)%node(j) - 1
        in = in + 1
      enddo
    enddo

    t2 = HECMW_WTIME()
    write(*,"(a,1pe11.4)")"      ** buget   time: ", t2-t1
    t1 = HECMW_WTIME()

    allocate(metis_perm(N))
    allocate(metis_iperm(N))

    ierr = hecmw_METIS_NodeND(nvtxs, xadj, adjncy, vwgt, options, metis_perm, metis_iperm)
    do i=1,N
      perm (i) = metis_perm(i)  + 1
      iperm(i) = metis_iperm(i) + 1
    enddo

    deallocate(metis_perm)
    deallocate(metis_iperm)
!    call reverse_ordering(N, perm, iperm)

    t2 = HECMW_WTIME()
    write(*,"(a,1pe11.4)")"      ** metis   time: ", t2-t1

  end subroutine hecmw_matrix_ordering_METIS

  subroutine hecmw_matrix_ordering_METIS_from_MAT(N, NP, indexL, itemL, indexU, itemU, perm, iperm)
    use, intrinsic :: iso_c_binding  !, only : C_int, C_double, C_float
    implicit none
    integer(kind=kint), intent(in)  :: N, NP
    integer(kind=kint), intent(in)  :: indexL(0:), indexU(0:)
    integer(kind=kint), intent(in)  :: itemL(:), itemU(:)
    integer(kind=kint), intent(out) :: perm(:), iperm(:)

    type(hecmw_edge_info), allocatable :: edge(:)
    integer(kind=kint) :: i, j, k, iS, jS, jE, nu, nl
    integer(kind=kint) :: irow, icel, nedge, ic_type, in, jn, kn, nn, ne
    integer(kind=kint) :: imax, imin
    integer(kind=kint) :: nlocal(20)
    integer(kind=kint), allocatable :: check(:), nozero(:)
    integer(idx_t) :: ierr
    integer(idx_t) :: nvtxs
    integer(idx_t), pointer :: xadj(:)        => null()
    integer(idx_t), pointer :: adjncy(:)      => null()
    integer(idx_t), pointer :: vwgt(:)        => null()
    integer(idx_t), pointer :: options(:)     => null()
    integer(idx_t), pointer :: metis_perm(:)  => null()
    integer(idx_t), pointer :: metis_iperm(:) => null()
    real(kind=kreal) :: t1, t2

    t1 = HECMW_WTIME()
    nvtxs = N
    allocate(edge(N))

    do irow=1,N
      nl = indexL(irow) - indexL(irow-1)
      nu = indexU(irow) - indexU(irow-1)
      in = nl + nu

      if(0 < in)then
        allocate(nozero(in))
        nozero = 0

        jn = 1
        jS = indexL(irow-1) + 1
        jE = indexL(irow  )
        do j=jS,jE
          nozero(jn) = itemL(j)
          jn = jn + 1
        enddo
        jS = indexU(irow-1) + 1
        jE = indexU(irow  )
        do j=jS,jE
          if(N < itemU(j))then
            nozero(jn) = irow
          else
            nozero(jn) = itemU(j)
          endif
          jn = jn + 1
        enddo

        call reallocate_array(edge(irow)%N, in, edge(irow)%node)
        edge(irow)%N = in

        do i=1,in
          edge(irow)%node(i) = nozero(i)
        enddo
        deallocate(nozero)
      endif
    enddo

    t2 = HECMW_WTIME()
    write(*,"(a,1pe11.4)")"      ** edge    time: ", t2-t1
    t1 = HECMW_WTIME()

    allocate(xadj(N+1))
    xadj(1) = 0
    do i = 1, N
      xadj(i+1) = xadj(i) + edge(i)%N
    enddo

    nedge = xadj(N+1)
    allocate(adjncy(nedge))
    in = 1
    do i=1,N
      do j=1,edge(i)%N
        adjncy(in) = edge(i)%node(j) - 1
        in = in + 1
      enddo
    enddo

    t2 = HECMW_WTIME()
    write(*,"(a,1pe11.4)")"      ** buget   time: ", t2-t1
    t1 = HECMW_WTIME()

    allocate(metis_perm(N))
    allocate(metis_iperm(N))

    ierr = hecmw_METIS_NodeND(nvtxs, xadj, adjncy, vwgt, options, metis_perm, metis_iperm)
    do i=1,N
      perm (i) = metis_perm(i)  + 1
      iperm(i) = metis_iperm(i) + 1
    enddo

    deallocate(metis_perm)
    deallocate(metis_iperm)
!    call reverse_ordering(N, perm, iperm)

    t2 = HECMW_WTIME()
    write(*,"(a,1pe11.4)")"      ** metis   time: ", t2-t1
  end subroutine hecmw_matrix_ordering_METIS_from_MAT

  subroutine reverse_ordering(N, perm, iperm)
    integer(kind=kint), intent(in) :: N
    integer(kind=kint), intent(inout) :: perm(:), iperm(:)
    integer(kind=kint) :: i, N1
    integer(kind=kint), allocatable :: tmp(:)

    allocate(tmp(N))
    do i=1,N
      tmp(i) = perm(i)
    enddo

    N1 = N + 1
    do i=1,N
      perm(i) = tmp(N1-i)
      iperm(perm(i)) = i
    enddo
  end subroutine reverse_ordering

  subroutine reallocate_array(iold, inew, x)
    implicit none
    integer(kind=kint), intent(in) :: iold, inew
    integer(kind=kint), pointer :: x(:), t(:)
    integer(kind=kint) :: i

    if(.not. associated(x))then
      allocate(x(inew))
    else
      t => x
      x => null()
      allocate(x(inew))
      do i=1,iold
        x(i) = t(i)
      enddo
      deallocate(t)
    endif
  end subroutine reallocate_array

end module m_hecmw_matrix_ordering_METIS
