hecmw_ordering.F90

Go to the documentation of this file.

!-------------------------------------------------------------------------------
! Copyright (c) 2020 FrontISTR Commons
! This software is released under the MIT License, see LICENSE.txt
!-------------------------------------------------------------------------------
 
!----------------------------------------------------------------------
!         for direct solver
!----------------------------------------------------------------------
module hecmw_ordering
  use hecmw_util
  implicit none
 
  private
  public :: hecmw_ordering_gen
 
  integer(kind=kint), parameter:: ORDERING_DEFAULT = 0
  integer(kind=kint), parameter:: ORDERING_QMD     = 1
  integer(kind=kint), parameter:: ORDERING_METIS   = 2
  integer(kind=kint), parameter:: ORDERING_RCM     = 3
  integer(kind=kint), parameter:: ORDERING_NMAX    = 3
 
  integer(kind=kint), parameter:: ORDERING_DEBUG = 0
 
contains
 
  !======================================================================!
  !======================================================================!
  subroutine hecmw_ordering_gen(Neqns,Nttbr,Xadj,Adj0,Perm,Invp,opt,loglevel)
    use hecmw_ordering_qmd
    use hecmw_ordering_metis
    use hecmw_ordering_rcm
    implicit none
    !------
    integer(kind=kint), intent(in):: neqns
    integer(kind=kint), intent(in):: nttbr
    integer(kind=kint), intent(in):: adj0(:)
    integer(kind=kint), intent(in):: xadj(:)
    integer(kind=kint), intent(in):: opt
    integer(kind=kint), intent(in):: loglevel
    integer(kind=kint), intent(out):: perm(:)
    integer(kind=kint), intent(out):: invp(:)
    !------
    integer(kind=kint):: ordering
    ordering = opt
    if (ordering < 0 .or. ordering > ordering_nmax) then
      stop "ERROR ordering option for direct solver out of range"
    endif
    if (ordering == ordering_default) then
#ifdef HECMW_WITH_METIS
      ordering = ordering_metis
#else
      ordering = ordering_qmd
#endif
    endif
    select case (ordering)
    case(ordering_qmd)
      if (loglevel > 0) write(*,*) 'Ordering method: QMD'
      call hecmw_ordering_genqmd(neqns,nttbr,xadj,adj0,perm,invp)
    case(ordering_metis)
      if (loglevel > 0) write(*,*) 'Ordering method: METIS_NodeND'
      call hecmw_ordering_metis_nodend(neqns,xadj,adj0,perm,invp)
    case(ordering_rcm)
      if (loglevel > 0) write(*,*) 'Ordering method: RCM'
      call hecmw_ordering_genrcm(neqns,xadj,adj0,perm,invp)
    end select
    if (ordering_debug > 0) then
      call write_nonzero_profile(neqns, xadj, adj0, perm, invp)
      call write_perm(neqns, perm, invp)
    endif
  end subroutine hecmw_ordering_gen
 
  subroutine write_nonzero_profile(N, index, item, perm, iperm)
    implicit none
    integer(kind=kint), intent(in) :: N
    integer(kind=kint), intent(in) :: index(:)
    integer(kind=kint), intent(in) :: item(:)
    integer(kind=kint), intent(in) :: perm(:), iperm(:)
    integer(kind=kint), parameter :: F_ORG = 901
    integer(kind=kint), parameter :: F_NEW = 902
    integer(kind=kint) :: i, j, irow, jcol
    open(f_org, file='nzprof_org.txt', status='replace')
    do irow = 1, n
      i = irow
      do j = index(i), index(i+1)-1
        jcol = item(j)
        write(f_org,*) irow, jcol
      end do
    end do
    close(f_org)
    open(f_new, file='nzprof_new.txt', status='replace')
    do irow = 1, n
      i = perm(irow)
      do j = index(i), index(i+1)-1
        jcol = item(j)
        write(f_new,*) irow, iperm(jcol)
      end do
    end do
    close(f_new)
  end subroutine write_nonzero_profile
 
  subroutine write_perm(N, perm, iperm)
    implicit none
    integer(kind=kint), intent(in) :: N
    integer(kind=kint), intent(in) :: perm(:), iperm(:)
    integer(kind=kint), parameter :: F_PERM = 903
    integer(kind=kint) :: i
    open(f_perm, file='perm_iperm.txt', status='replace')
    do i = 1, n
      write(f_perm,*) perm(i), iperm(i)
    end do
    close(f_perm)
  end subroutine write_perm
 
end module hecmw_ordering