!# This source file is distributed with code Pégase.3.0.1 (2019-02-21).
!# Copyright: Michel Fioc (Michel.Fioc@iap.fr), Sorbonne université, 
!# Institut d'astrophysique de Paris/CNRS, France.
!# 
!# Pégase.3.0.1 is governed by the CeCILL license under French law and abides 
!# by the rules of distribution of free software. You can use, modify and/or 
!# redistribute this software under the terms of the CeCILL license as circulated 
!# by CEA, CNRS and INRIA at "http://www.cecill.info". The text of this license
!# is also available in French and in English in directory "doc_dir/" of this
!# code.
!# 
!# As a counterpart to the access to the source code and to the rights to copy,
!# modify and redistribute it granted by the license, users are provided only
!# with a limited warranty, and the software's author, the holder of the
!# economic rights, and the successive licensors have only limited
!# liability. 
!# 
!# The fact that you are presently reading this means that you have had
!# knowledge of the CeCILL license and that you accept its terms.
!#====================================================================== 

module mod_heap_index
  
  implicit none
  private
  public :: heap_index

contains

!#======================================================================

  subroutine heap_index(a, idx)

!# Given an array `a(1:n)` of strings, return the array of integers `idx(1:n)`
!# such that `a(idx(1:n))` is ordered by increasing values.
!# Based on the "heapsort" algorithm.

    implicit none
    character(len=*), dimension(:), intent(in) :: a
    integer, dimension(:), intent(out) :: idx
!#......................................................................
    integer :: n
    integer :: right, i
!#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

    n = size(a)
    idx(1:n) = (/(i, i = 1, n)/)
    call heapify(a, idx, n)
    right = n
    do
       if (right <= 1) exit
       call swap(idx(right), idx(1))
       right = right - 1
       call sift_down(a, idx, 1, right)
    enddo

  end subroutine heap_index

!#======================================================================

  subroutine swap(x, y)

    integer, intent(inout) :: x, y
!#......................................................................
    integer :: tmp
!#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

    tmp = y
    y = x
    x = tmp
    
  end subroutine swap

!#======================================================================

  subroutine heapify(a, idx, n)

    implicit none
    integer, intent(in) :: n
    character(len=*), dimension(:), intent(in) :: a
    integer, dimension(:), intent(inout) :: idx
!#......................................................................
    integer :: left
!#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

    left = n/2
    do
       if (left < 1) exit
       call sift_down(a, idx, left, n)
       left = left - 1
    enddo

  end subroutine heapify

!#======================================================================

  subroutine sift_down(a, idx, left, right)
    
    character(len=*), dimension(:), intent(in) :: a
    integer, dimension(:), intent(inout) :: idx
    integer, intent(in) :: left, right
!#......................................................................
    integer :: root, left_child, right_child, tmp
!#::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

    root = left
    do
       left_child = 2*root
       if (left_child > right) exit
       tmp = root
       if (a(idx(tmp)) < a(idx(left_child))) tmp = left_child
       right_child = left_child + 1
       if (right_child <= right) then
          if (a(idx(tmp)) < a(idx(right_child))) tmp = right_child
       endif
       if (tmp /= root) then
          call swap(idx(root), idx(tmp))
          root = tmp
       else
          return
       endif

    enddo

  end subroutine sift_down

end module mod_heap_index
