hecmw_matrix_ordering_MC.f90

Go to the documentation of this file.

!-------------------------------------------------------------------------------
! Copyright (c) 2019 FrontISTR Commons
! This software is released under the MIT License, see LICENSE.txt
!-------------------------------------------------------------------------------
 
module m_hecmw_matrix_ordering_mc
  use hecmw_util
  implicit none
 
  private
  public :: hecmw_matrix_ordering_mc
 
contains
 
  subroutine hecmw_matrix_ordering_mc(N, indexL, itemL, indexU, itemU, &
      perm_cur, ncolor_in, ncolor_out, COLORindex, perm, iperm)
    implicit none
    integer(kind=kint), intent(in) :: n
    integer(kind=kint), intent(in) :: indexl(0:), indexu(0:)
    integer(kind=kint), intent(in) :: iteml(:), itemu(:)
    integer(kind=kint), intent(in) :: perm_cur(:)
    integer(kind=kint), intent(in) :: ncolor_in
    integer(kind=kint), intent(out) :: ncolor_out
    integer(kind=kint), intent(out) :: colorindex(0:)
    integer(kind=kint), intent(out) :: perm(:), iperm(:)
    integer(kind=kint), allocatable :: iwk(:)
    integer(kind=kint) :: nn_color, cntall, cnt, color
    integer(kind=kint) :: i, inode, j, jnode
    allocate(iwk(n))
    iwk = 0
    nn_color = n / ncolor_in
    cntall = 0
    colorindex(0) = 0
    do color=1,n
      cnt = 0
      do i=1,n
        inode = perm_cur(i)
        if (iwk(inode) > 0 .or. iwk(inode) == -1) cycle
        ! if (iwk(inode) == 0)
        iwk(inode) = color
        cntall = cntall + 1
        perm(cntall) = inode
        cnt = cnt + 1
        if (cnt == nn_color) exit
        if (cntall == n) exit
        ! mark all connected and uncolored nodes
        do j = indexl(inode-1)+1, indexl(inode)
          jnode = iteml(j)
          if (iwk(jnode) == 0) iwk(jnode) = -1
        end do
        do j = indexu(inode-1)+1, indexu(inode)
          jnode = itemu(j)
          if (jnode > n) cycle
          if (iwk(jnode) == 0) iwk(jnode) = -1
        end do
      end do
      colorindex(color) = cntall
      if (cntall == n) then
        ncolor_out = color
        exit
      end if
      ! unmark all marked nodes
      do i=1,n
        if (iwk(i) == -1) iwk(i) = 0
      end do
    end do
    deallocate(iwk)
    ! make iperm
    do i=1,n
      iperm(perm(i)) = i
    end do
  end subroutine hecmw_matrix_ordering_mc
 
end module m_hecmw_matrix_ordering_mc